source: FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJUTL1.m@ 1800

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

initial load of FOIAVistA 6/30/08 version
File size: 8.9 KB
Line 
1PSJUTL1 ;BIR/MLM-MISC. INPATIENT UTILITIES ;29 Jul 98 / 4:29 PM
2 ;;5.0; INPATIENT MEDICATIONS ;**15,50,58**;16 DEC 97
3 ;
4 ; Reference to ^PSSLOCK is supported by DBIA# 2789.
5 ; Reference to ^PS(55 is supported by DBIA# 2191.
6 ; Reference to ^PS(50.7 is supported by DBIA# 2180.
7 ; Reference to ^PS(52.6 is supported by DBIA# 1231.
8 ; Reference to ^PS(52.7 is supported by DBIA# 2173.
9 ; Reference to ^PS(59.7 is supported by DBIA# 2181.
10 ; Reference to ^PSDRUG is supported by DBIA# 2192.
11 ; Reference to ^XPD(9.7 is supported by DBIA# 2197.
12 ;
13CONVERT(DFN,TYPE) ;
14 ; Convert existing UD orders to new format. Only run once/patient, and
15 ; only converts orders with a stop date<(5.0 Install date-365)
16 ; DFN = Patient IEN
17 ; TYPE = Background or Interactive mode
18 ;
19 S TYPE=TYPE&($E($G(IOST))="C")
20 ;I '$D(^PS(55,DFN,0))!($P($G(^PS(55,DFN,5.1)),U,11)=1) Q
21 ;I $S($P($G(^PS(55,DFN,5.1)),U,11)=1:1,$O(^PS(55,DFN,"IV",0)):0,$O(^PS(55,DFN,5,0)):0,1:'$O(^PS(53.1,"C",DFN,0))) Q
22 I $P($G(^PS(55,DFN,5.1)),U,11)=1 Q
23 N ADS,ADS1,DDRG,ND,ON,ON1,PSGDT,PSJOI,STAT,STPDT,STS,X,XX,X1,X2
24 ;I '$D(^PS(55,DFN,0)) D
25 ;I '$D(^PS(55,DFN,0))&(($O(^PS(55,DFN,"IV",0)))!($O(^PS(55,DFN,5,0)))!($O(^PS(53.1,"C",DFN,0)))) D
26 I '$D(^PS(55,DFN,0))&($D(^PS(55,DFN))!($O(^PS(53.1,"C",DFN,0)))) D
27 .N X,Y,DA,DIK S ^PS(55,DFN,0)=DFN K DIK S DA=DFN,DIK="^PS(55,",DIK(1)=.01 D EN^DIK
28 ;I TYPE W !!,"Converting old orders for ",$P($G(^DPT(DFN,0)),U)," to new format."
29 S X1=$P($G(^PS(59.7,1,20)),U,2),X2=-365 I 'X1 D NOW^%DTC S X1=$P(%,".")
30 D C^%DTC S PSGDT=X
31 ;Convert and Backfill orders in 53.1.
32 F STAT="D","DE","N","P","U" S STS=$O(^PS(53.1,"AS",STAT)) F ON=0:0 S ON=$O(^PS(53.1,"AS",STAT,DFN,ON)) Q:'ON I '$G(^PS(53.1,ON,.2)) D
33 .S PSJOI="",ND=$G(^PS(53.1,+ON,.1)),DDRG=+$G(^PS(53.1,ON,1,+$O(^PS(53.1,ON,1,0)),0)) S:DDRG PSJOI=+$G(^PSDRUG(DDRG,2))
34 .I 'PSJOI F DDRG=0:0 S DDRG=$O(^PSDRUG("AP",+ND,DDRG)) Q:'DDRG!PSJOI S PSJOI=+$G(^PSDRUG(DDRG,2)) D
35 .; convert pending UD orders that have "I" in 4th piece for TYPE
36 .I STAT="P",($P($G(^PS(53.1,ON,0)),"^",4)="I"),(PSJOI) S $P(^PS(53.1,ON,0),"^",4)=$$CNV2(PSJOI)
37 .I PSJOI S ^PS(53.1,ON,.2)=PSJOI_U_$P(ND,U,2) W:TYPE "."
38 .I PSJOI!($P($G(^PS(53.1,+ON,0)),U,4)="F") D EN1^PSJHL2(DFN,"ZC",ON_"P")
39 .; convert order location codes for ^PS(53.1
40 .K PSJXX S PSJXX=$G(^PS(53.1,ON,0)) I $L(PSJXX) S $P(PSJXX,"^",25,26)=$$CNV($P(PSJXX,"^",25))_"^"_$$CNV($P(PSJXX,"^",26)) S ^(0)=PSJXX K PSJXX
41 ;Convert and Backfill UD orders.
42 F STPDT=PSGDT:0 S STPDT=$O(^PS(55,DFN,5,"AUS",STPDT)) Q:'STPDT F ON=0:0 S ON=$O(^PS(55,DFN,5,"AUS",STPDT,ON)) Q:'ON I '$G(^PS(55,DFN,5,ON,.2)) D
43 .S PSJOI="",ND=$G(^PS(55,DFN,5,+ON,.1)),DDRG=$O(^PS(55,DFN,5,ON,1,0)),XX=+$G(^PS(55,DFN,5,ON,1,+DDRG,0)) S:XX PSJOI=+$G(^PSDRUG(XX,2))
44 .I 'PSJOI F DDRG=0:0 S DDRG=$O(^PSDRUG("AP",+ND,DDRG)) Q:'DDRG!PSJOI S PSJOI=+$G(^PSDRUG(DDRG,2))
45 .I PSJOI S ^PS(55,DFN,5,ON,.2)=PSJOI_U_$P(ND,U,2) W:TYPE "." D EN1^PSJHL2(DFN,"ZC",ON_"U")
46 .; convert order location codes for Unit Dose orders
47 .K PSJXX S PSJXX=$G(^PS(55,DFN,5,ON,0)) I $L(PSJXX) S $P(PSJXX,"^",25,26)=$$CNV($P(PSJXX,"^",25))_"^"_$$CNV($P(PSJXX,"^",26)) S ^(0)=PSJXX K PSJXX
48 ;Convert and Backfill IV orders.
49 F STPDT=PSGDT:0 S STPDT=$O(^PS(55,DFN,"IV","AIS",STPDT)) Q:'STPDT F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",STPDT,ON)) Q:'ON I '$G(^PS(55,DFN,"IV",ON,.2)) D
50 .S PSJOI="",ND=$G(^PS(55,DFN,"IV",ON,6)) F ADS="AD","SOL" I 'PSJOI F ON1=0:0 S ON1=$O(^PS(55,DFN,"IV",ON,ADS,ON1)) Q:'ON1!PSJOI S XX=+$G(^PS(55,DFN,"IV",ON,ADS,ON1,0)) D
51 ..S:XX PSJOI=$S(ADS="AD":$P($G(^PS(52.6,XX,0)),U,11),1:$P($G(^PS(52.7,XX,0)),U,11)) I PSJOI S ^PS(55,DFN,"IV",ON,.2)=PSJOI_U_$P(ND,U,2,3) W:TYPE "."
52 .S PSJ200=$P($G(^PS(55,DFN,"IV",ON,2)),U,3) Q:PSJ200=""
53 .S X=$O(^VA(200,"B",PSJ200,0)),XX=$O(^VA(200,"B",PSJ200,X))
54 .I 'X!XX S ^XTMP("PSJ NEW PERSON",PSJ200,DFN,ON)="" Q
55 .S $P(^PS(55,DFN,"IV",ON,2),U,11)=X
56 .D EN1^PSJHL2(DFN,"ZC",ON_"V")
57 .; convert order location codes for IVs
58 .K PSJXX S PSJXX=$G(^PS(55,DFN,"IV",ON,2)) I $L(PSJXX) S $P(PSJXX,"^",5,6)=$$CNV($P(PSJXX,"^",5))_"^"_$$CNV($P(PSJXX,"^",6)) S ^(2)=PSJXX K PSJXX
59 ;Delete Unreleased entries after converting.
60 F ON=0:0 S ON=$O(^PS(53.1,"AS","U",DFN,ON)) Q:'ON I $G(^PS(53.1,ON,.2)) S DIK="^PS(53.1,",DA=ON D ^DIK K DIK
61 S:$D(^PS(55,DFN,0)) $P(^PS(55,DFN,5.1),U,11)=1
62 Q
63 ;
64NFWS(DFN,ON,PSJPWD) ; Determine if order is NF or WS
65 ;Input: DFN - Patient IEN
66 ; ON - Order #_Order Code
67 ; PSJPWD - IEN of patient's ward
68 ; Where Order Code IDs order location ("P":53.1; "U":55.06,1:55.01)
69 ;Output: NF flag^WS flag^Self Med^Hosp Supplied Self Med
70 N ND
71 Q:$S(ON["U":0,1:ON'["P") ""
72 ;S PSJPWD="",X=$P($G(^DPT(DFN,.1)),U) I X]"" S PSJPWD=$O(^DIC(42,"B",X,0))
73 S PSJ="",PSJREF=$S(ON["P":"^PS(53.1,",1:"^PS(55,"_DFN_",5,")_+ON_","
74 F PSJDD=0:0 S PSJDD=$O(@(PSJREF_"1,"_PSJDD_")")) Q:'PSJDD S ND=$G(^(PSJDD,0)) D CHKDD
75 S $P(PSJ,U,3,4)=$P($G(@(PSJREF_"0)")),U,5,6)
76 Q PSJ
77 ;
78CHKDD ; Determine if dispense drug is NF or WS
79 ;
80 S:$P($G(^PSDRUG(+ND,0)),U,9) $P(PSJ,U)=1
81 S:$$WSCHK^PSJO(PSJPWD,+ND) $P(PSJ,U,2)=1
82 Q
83FIND ;
84 F DFN=0:0 S DFN=$O(^PS(55,DFN)) Q:'DFN D
85 .I $O(^PS(55,DFN,5,0))!$O(^PS(55,DFN,"IV",0)) D
86 ..I '$P($G(^PS(55,DFN,5.1)),U,11) W !,DFN
87 Q
88 ;
89CNV(PSJM) ; converts order location codes to just 'U' 'P' and 'V'
90 I PSJM="" Q PSJM
91 I PSJM["V" Q PSJM
92 I PSJM["A"!(PSJM["O") Q ($E(PSJM,1,$L(+PSJM))_"U")
93 I PSJM["N"!(PSJM["P") Q ($E(PSJM,1,$L(+PSJM))_"P")
94 Q PSJM
95CNV2(IEN507) ; converts pending orders with 3rd piece set to "I"
96 ; is the orderable item marked for IV ?
97 I $P($G(^PS(50.7,IEN507,0)),"^",3)=1 Q "I"
98 E Q "U"
99 Q
100CNIV(DFN) ;Converts OI on active and pending IV orders for POE
101 ;for all patients or a selected patient
102 NEW ON,PSGDT,STPDT,START,PSJX
103 I $G(DFN) D Q:PSJX>1
104 . S PSJX=$P($G(^PS(55,DFN,5.1)),U,11)
105 . Q:PSJX=3
106 . I PSJX=2 D MARKIV^PSJUTL3(DFN) Q
107 ;I '$D(^XTMP("PSSCONA")),'$D(^XTMP("PSSCONS")) Q
108 D NOW^%DTC S START=%
109 S X1=DT_".0001",X2=-365
110 D C^%DTC S PSGDT=X
111 I $G(DFN) D CNIV1(DFN),MARKIV^PSJUTL3(DFN) Q
112 NEW DFN
113 F DFN=0:0 S DFN=$O(^PS(55,DFN)) Q:'DFN D CNIV1(DFN),MARKIV^PSJUTL3(DFN)
114 D ENIVUD^PSJ0050
115 D SEND
116 Q
117CNIV1(DFN) ;
118 ;I $P($G(^PS(55,DFN,5.1)),U,11)=2 Q
119 Q:'$$L^PSSLOCK(DFN,0)
120 S $P(^PS(55,DFN,5.1),U,11)=2
121 I '$D(^XTMP("PSSCONA")),'$D(^XTMP("PSSCONS")) D UL^PSSLOCK(DFN) Q
122 F STPDT=PSGDT:0 S STPDT=$O(^PS(55,DFN,"IV","AIS",STPDT)) Q:'STPDT D
123 . F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",STPDT,ON)) Q:'ON D IVCHK
124 F ON=0:0 S ON=$O(^PS(53.1,"AS","P",DFN,ON)) Q:'ON D PENDING
125 D UL^PSSLOCK(DFN)
126 Q
127IVCHK ;Match AD/SOL against Xtmp
128 NEW PSJAD,PSJCNR,PSJOI,PSJSOL,PSJXAD,PSJXNOI,PSJXSOL
129 S PSJOI=+$G(^PS(55,DFN,"IV",ON,.2)) Q:'+PSJOI
130 ;
131 ;Set local array for AD/SOL from the order
132 F PSJAD=0:0 S PSJAD=$O(^PS(55,DFN,"IV",ON,"AD",PSJAD)) Q:'PSJAD D
133 . I $G(^PS(55,DFN,"IV",ON,"AD",PSJAD,0)) S PSJAD(+^(0))=""
134 F PSJSOL=0:0 S PSJSOL=$O(^PS(55,DFN,"IV",ON,"SOL",PSJSOL)) Q:'PSJSOL D
135 . I $G(^PS(55,DFN,"IV",ON,"SOL",PSJSOL,0)) S PSJSOL(+^(0))=""
136 D MATCH,UPD(ON_"V")
137 Q
138 ;
139MATCH ;If AD/SOL from XTMP matches to AD/SOL within the order, set new OI array
140 K PSJXNOI
141 F PSJXAD=0:0 S PSJXAD=$O(^XTMP("PSSCONA",+PSJOI,PSJXAD)) Q:'PSJXAD D
142 . I $D(PSJAD(PSJXAD)) S PSJXNOI(+^XTMP("PSSCONA",+PSJOI,PSJXAD))=""
143 F PSJXSOL=0:0 S PSJXSOL=$O(^XTMP("PSSCONS",+PSJOI,PSJXSOL)) Q:'PSJXSOL D
144 . I $D(PSJSOL(PSJXSOL)) S PSJXNOI(+^XTMP("PSSCONS",+PSJOI,PSJXSOL))=""
145 Q
146 ;
147UPD(ON) ;Loop thru the new OI array
148 NEW PSJCNT S PSJCNT=0
149 F X=0:0 S X=$O(PSJXNOI(X)) Q:'X S PSJCNT=PSJCNT+1
150 I PSJCNT=1 D
151 . S PSJXNOI=$O(PSJXNOI(0))
152 . I +PSJOI=PSJXNOI Q
153 . S X=$P($G(^PS(50.7,PSJXNOI,0)),U,4)
154 . I X]"",(X'>DT) Q
155 . ;/W !,"DFN: ",DFN," ON: ",ON," NEW OI: ",PSJXNOI
156 . S:ON["V" $P(^PS(55,DFN,"IV",+ON,.2),U,1)=+PSJXNOI
157 . S:ON["P" $P(^PS(53.1,+ON,.2),U,1)=+PSJXNOI
158 . D EN1^PSJHL2(DFN,"ZC",ON)
159 . D EN^PSJ0050(DFN,+ON,+PSJOI,PSJXNOI)
160 Q
161PENDING ;Converting Pending IV order with Ad/Sol
162 NEW PSJAD,PSJOI,PSJSOL,PSJXNOI
163 S X=$P($G(^PS(53.1,ON,0)),U,4) I $S(X="I":0,X="F":0,1:1) Q
164 S PSJOI=+$G(^PS(53.1,ON,.2)) Q:'+PSJOI
165 ;
166 ;If pending has no AD/SOL, and on 1 new OI matched to old OI then update.
167 I '$D(^PS(53.1,ON,"AD")),'$D(^PS(53.1,ON,"SOL")) D Q
168 . F X=0:0 S X=$O(^XTMP("PSSCONA",PSJOI,X)) Q:'X S PSJXNOI(+^(X))=""
169 . F X=0:0 S X=$O(^XTMP("PSSCONS",PSJOI,X)) Q:'X S PSJXNOI(+^(X))=""
170 . D UPD(ON_"P")
171 ;
172 ;Loop thru the pending AD/SOL
173 F PSJAD=0:0 S PSJAD=$O(^PS(53.1,ON,"AD",PSJAD)) Q:'PSJAD D
174 . I $G(^PS(53.1,ON,"AD",PSJAD,0)) S PSJAD(+^(0))=""
175 F PSJSOL=0:0 S PSJSOL=$O(^PS(55,ON,"SOL",PSJSOL)) Q:'PSJSOL D
176 . I $G(^PS(53.1,ON,"SOL",PSJSOL,0)) S PSJSOL(+^(0))=""
177 D MATCH,UPD(ON_"P")
178 Q
179SEND ;Send mail message
180 NEW DIFROM,XMDUZ,XMSUB,XMTEXT,XMY,STOP,LINE
181 D NOW^%DTC S STOP=%
182 S LINE(1)="The conversion was first started: "_$$FMTE^XLFDT(START)
183 S LINE(2)="It ran to completion: "_$$FMTE^XLFDT(STOP)
184 S XMSUB="Inpatient Meds IV conversion",XMTEXT="LINE("
185 S XMDUZ="Inpatient Meds POE"
186 S XMY(+DUZ)="" D ^XMD
187 Q
188INSTLDT() ;Return the date PSJ*5*58 was first installed
189 NEW DIC,X,Y
190 S X=$O(^XPD(9.7,"B","PSJ*5.0*58",0))
191 Q:'+X ""
192 S DIC="^XPD(9.7,",DIC(0)="NZ" D ^DIC
193 Q $P($G(Y(0)),U,3)
Note: See TracBrowser for help on using the repository browser.