source: FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDSTATU.m@ 628

Last change on this file since 628 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.6 KB
Line 
1MDSTATU ; HOIFO/NCA - Print List of Document Titles Needed ;10/21/04 13:44
2 ;;1.0;CLINICAL PROCEDURES;**5**;Apr 01, 2004;Build 1
3 ; Reference Integration Agreement:
4 ; IA# 10035 [Supported] Access to DPT file (#2)
5 ; IA# 10039 [Supported] Hospital Location lookup in DIC(42
6 ; IA# 10061 [Supported VADPT calls
7 ; IA# 10104 [Supported] Routine XLFSTR calls
8 ;
9DISP ; Display List of TIU titles need to be created for Medicine procedures
10 W ! K IOP,%ZIS S %ZIS("A")="Select Device: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP Q:POP
11 I $D(IO("Q")) S ZTRTN="D1^MDSTATU",ZTREQ="@",ZTSAVE("ZTREQ")="",ZTDESC="List Documents Titles Needed",(ZTDTH,ZTIO)="" D ^%ZTLOAD D ^%ZISC W !,"Request Queued" Q
12 U IO D D1 D ^%ZISC K %ZIS,IOP Q
13D1 ; Process Display
14 N ANS,CNT,DTP,LN,LP,MDK,MDF,MDFIL,MDN,MDN1,MDR,MDTIT,MDV,MDX,PG,S1,TIT,X
15 S (CNT,PG)=0,ANS="",S1=$S(IOST?1"C".E:IOSL-2,1:IOSL-7) D H1 S MDFIL=8925.1
16 S LP=0 F S LP=$O(^MDD(703.9,1,1,LP)) Q:LP<1!(ANS="^") S MDF=$G(^(LP,0)) D
17 .Q:'$P(MDF,U,3)
18 .S MDTIT=$P(MDF,U,5) Q:MDTIT
19 .Q:'$P(MDF,U) S MDR="MCAR("_+$P(MDF,U)
20 .S MDN=0 F S MDN=$O(^MCAR(697.2,"C",MDR,MDN)) Q:MDN<1!(ANS="^") I $G(^MCAR(697.2,MDN,0))'="" D
21 ..S CNT=CNT+1,MDK=$G(^MCAR(697.2,MDN,0)),TIT=$S($P(MDK,U,8)'="":$P(MDK,U,8),1:$P(MDK,U)),TIT=$$UP^XLFSTR(TIT),MDN1=$G(^MCAR(697.2,MDN,1))
22 ..D:$Y'<S1 HDR Q:ANS="^"
23 ..I $P(MDF,U)=699 Q:$P(MDN1,U)="S"
24 ..I $P(MDF,U)=694 Q:$P(MDN1,U)="S"
25 ..I $P(MDF,U)=699.5 Q:$P(MDN1,U)="P"
26 ..S MDV="HISTORICAL "_TIT_$S(TIT["PROCEDURE":"",1:" PROCEDURE")
27 ..S:$L(MDV)>60 MDV=$E(MDV,1,60)
28 ..Q:+$$FIND1^DIC(MDFIL,"","BOX",MDV,"B","","MDERR")
29 ..W !,TIT,?35,MDV
30 I 'CNT W !!,"No Historical TIU titles need to be created."
31 W ! Q
32PAUSE ; Pause For Scroll
33 I IOST?1"C".E R !!,"Press RETURN to continue. ",X:DTIME S:'$T!(X["^") ANS="^" Q:ANS="^" I "^"'[X W !,"Enter a RETURN to Continue." G PAUSE
34 Q
35DTP ; Printable Date/Time
36 S %=DTP,DTP=$J(+$E(DTP,6,7),2)_"-"_$P("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$E(DTP,4,5))_"-"_$E(DTP,2,3)
37 S:%#1 %=+$E(%_"0",9,10)_"^"_$E(%_"000",11,12),DTP=DTP_$J($S(%>12:%-12,1:+%),3)_":"_$P(%,"^",2)_$S(%<12:"am",%<24:"pm",1:"m") K % Q
38HDR ; Display Header and Scroll Pause
39 D PAUSE Q:ANS="^"
40H1 ; Print Header
41 W:'($E(IOST,1,2)'="C-"&'PG) @IOF
42 D NOW^%DTC S MDX=%
43 S PG=PG+1,DTP=MDX D DTP W !,DTP,?20,"L I S T O F T I U T I T L E S N E E D E D",?73,"Page ",PG
44 W ! S $P(LN,"-",80)="" W !,LN,!
45 W !,"PROCEDURES",?35,"Titles Needed to be Created"
46 W !,"----------",?35,"---------------------------",!
47 Q
48SETDEF ; Set default CP Definitions in Conversion Parameter
49 N MDERR,MDDIEN,MDK,MDF,MDFC,MDFIL,MDFDA,MDLP,MDN,MDNAM,MDOPT,MDR,MDS,MDTAR,MDNAM,MDX,MDY S MDFIL=8925.1 K MDTAR
50 F MDX=1:1 S MDOPT=$P($T(MEDTIT+MDX),";;",2) Q:MDOPT="**END**" D
51 .S MDS=$P(MDOPT,";",2)
52 .S MDY=+$$FIND1^DIC(MDFIL,"","BOX",MDS,"B","","MDERR") Q:'MDY
53 .S MDTAR(+MDOPT)=+MDY
54 S MDLP=0 F S MDLP=$O(^MDD(703.9,1,1,MDLP)) Q:MDLP<1 S MDF=$G(^(MDLP,0)) D
55 .S MDFC=+$P(MDF,U) Q:'MDFC S MDR="MCAR("_MDFC
56 .Q:MDFC=699
57 .Q:MDFC=699.5
58 .Q:MDFC=694
59 .S (MDK,MDN)=0,MDNAM="" F S MDN=$O(^MCAR(697.2,"C",MDR,MDN)) Q:MDN<1 I $G(^MCAR(697.2,MDN,0))'="" D
60 ..S MDK=$G(^MCAR(697.2,MDN,0)),MDNAM=$S($P(MDK,U,8)'="":$P(MDK,U,8),1:$P(MDK,U)),MDNAM=$$UP^XLFSTR(MDNAM)
61 .I MDNAM=""&(+$P(MDF,U)=694.5) S MDNAM="CARDIAC SURGERY RISK ASSESSMENT"
62 .Q:MDNAM=""
63 .S:$L(MDNAM)<30 MDNAM=MDNAM_" - HIST"
64 .S:$L(MDNAM)>30 MDNAM=$E(MDNAM,1,30)
65 .I '$O(^MDS(702.01,"B",MDNAM,0)) D
66 ..Q:$P(MDF,U,2)'=""
67 ..K MDERR,MDDIEN
68 ..S MDFDA(702.01,"+1,",.01)=MDNAM
69 ..D UPDATE^DIE("","MDFDA","MDDIEN","MDERR") Q:$D(MDERR)
70 ..S:+MDDIEN(1) $P(^MDD(703.9,1,1,MDLP,0),U,2)=+MDDIEN(1)
71 .I $P(MDF,U,5)="" S:+$G(MDTAR(MDFC)) $P(^MDD(703.9,1,1,MDLP,0),U,5)=+$G(MDTAR(MDFC))
72 Q
73GETMED(MDMNO,MDTYPE) ; Get the Medicine Procedure name
74 N MDI,MDMF,MDLL,MDLL1,MDLL6,MDLL8,MDNA
75 S MDNA=""
76 Q:MDTYPE="" MDNA
77 Q:'+MDMNO MDNA
78 S MDI=+MDMNO,MDMF=+$P(MDMNO,"MCAR(",2) Q:'MDMF MDNA
79 I MDMF=699 D
80 .S (MDLL,MDLL1)=$P($G(^MCAR(699,+MDI,0)),U,12) Q:'MDLL
81 .S MDLL=$G(^MCAR(697.2,MDLL,0)) Q:MDLL=""
82 .S MDNA=$S($P(MDLL,U,8)'="":$P(MDLL,U,8),1:$P(MDLL,U)) Q
83 I MDMF=699.5 D
84 .S MDLL6=$P($G(^MCAR(699.5,+MDI,0)),U,6) Q:'MDLL6
85 .S MDLL8=$P($G(^MCAR(699.5,+MDI,0)),U,8) S:MDLL8="" MDLL8=" "
86 .S MDLL=$G(^MCAR(697.2,MDLL6,0)) Q:MDLL=""
87 .I MDTYPE="N" S MDNA=$S($P(MDLL,U,8)'="":$P(MDLL,U,8),1:$P(MDLL,U)) Q
88 .I MDTYPE="P" S MDNA=$E(($E($P(MDLL,U,8),1,13)_"/"_$P($G(^MCAR(697.2,+MDLL8,0)),U)),1,30)
89 I MDMF=694 D
90 .S MDLL=$P($G(^MCAR(694,MDI,0)),U,3) Q:'MDLL
91 .S MDLL=$G(^MCAR(697.2,MDLL,0)) Q:MDLL=""
92 .S MDNA=$S($P(MDLL,U,8)'="":$P(MDLL,U,8),1:$P(MDLL,U)) Q
93 S:MDNA'="" MDNA=$$UP^XLFSTR(MDNA)
94 Q MDNA
95LOCATP(MDNNO) ; Locate the CP Definition procedure or Add the New Entry
96 N MDDIEN,MDERR,MDFDA,MDNM,Y S Y=0
97 Q:'+MDNNO 0 S MDMNO=MDNNO
98 S MDNM=$$GETMED(MDMNO,"P") Q:MDNM="" Y
99 S MDNM=MDNM_" - HIST" S:$L(MDNM)>30 MDNM=$E(MDNM,1,30)
100 S Y=$O(^MDS(702.01,"B",MDNM,0)) Q:+Y Y
101 S MDFDA(702.01,"+1,",.01)=MDNM
102 D UPDATE^DIE("","MDFDA","MDDIEN","MDERR") Q:$D(MDERR)
103 S Y=+MDDIEN(1)
104 Q Y
105LOCATN(MDNNO) ; Locate the Historical Document Title
106 N MDDIEN,MDERR,MDFDA,MDNM,MDT,MDV,Y S Y=0,MDV=8925.1
107 Q:'+MDNNO 0 S MDMNO=MDNNO
108 S MDNM=$$GETMED(MDMNO,"N") Q:MDNM="" Y
109 S MDT="HISTORICAL "_MDNM_$S(MDNM["PROCEDURE":"",1:" PROCEDURE")
110 S Y=+$$FIND1^DIC(MDV,"","BOX",MDT,"B","","MDERR")
111 Q Y
112HOSP(MDNNO) ; Locate the Hospital Location
113 N MDERR,MDI,MDMF,MDOPT,MDL,MDS,MDTAR,MDV,MDW,MDW1,MDX
114 S MDL=0 K MDTAR
115 Q:'+MDNNO MDL
116 S MDI=+MDNNO,MDMF=+$P(MDNNO,"MCAR(",2) Q:'MDMF MDL
117 F MDX=1:1 S MDOPT=$P($T(MEDTIT+MDX),";;",2) Q:MDOPT="**END**" D
118 .S MDS=$P(MDOPT,";",3,4)
119 .S MDTAR(+MDOPT)=MDS
120 S MDS=$G(MDTAR(MDMF))
121 S:+$P(MDS,";",2) MDL=$P($G(^MCAR(MDMF,MDI,$P(MDS,";"))),"^",+$P(MDS,";",2))
122 I 'MDL D
123 .S DFN=+$P($G(^MCAR(MDMF,MDI,0)),U,2),VAIP("D")=$P($G(^MCAR(MDMF,MDI,0)),U,1)
124 .D IN5^VADPT S MDW=+VAIP(5) D KVAR^VADPT S:MDW MDL=+$P($G(^DIC(42,+MDW,44)),U)
125 .I 'MDL S MDW=$G(^DPT(DFN,.1)) I MDW'="" S MDV=42,MDW1=$$FIND1^DIC(MDV,"","BOX",MDW,"B","","MDERR") S:MDW1 MDL=+$P($G(^DIC(42,+MDW1,44)),U)
126 Q MDL
127MEDTIT ;; [Medicine Historical Document Titles]
128 ;;691.1;HISTORICAL CARDIAC CATHETERIZATION PROCEDURE;0;6
129 ;;691;HISTORICAL ECHOCARDIOGRAM PROCEDURE;11;2
130 ;;691.5;HISTORICAL ELECTROCARDIOGRAM PROCEDURE;8;1
131 ;;691.8;HISTORICAL ELECTROPHYSIOLOGY PROCEDURE;15;3
132 ;;691.7;HISTORICAL EXERCISE TOLERANCE TEST PROCEDURE;10;5
133 ;;691.6;HISTORICAL HOLTER PROCEDURE;0;18
134 ;;698;HISTORICAL PACEMAKER IMPLANTATION PROCEDURE
135 ;;698.1;HISTORICAL PACEMAKER IMPLANTATION PROCEDURE
136 ;;698.2;HISTORICAL PACEMAKER IMPLANTATION PROCEDURE
137 ;;698.3;HISTORICAL PACEMAKER IMPLANTATION PROCEDURE
138 ;;694.5;HISTORICAL PRE/POST SURGERY RISK NOTE
139 ;;694; ;0;4
140 ;;699; ;0;11
141 ;;700;HISTORICAL PULMONARY FUNCTION TEST PROCEDURE;0;10
142 ;;701;HISTORICAL RHEUMATOLOGY PROCEDURE
143 ;;**END**
Note: See TracBrowser for help on using the repository browser.