source: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJBCMA.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 9.5 KB
Line 
1PSJBCMA ;BIR/MV-RETURN INPATIENT ACTIVE MEDS (CONDENSED) ;16 Mar 99 / 10:13 AM
2 ;;5.0; INPATIENT MEDICATIONS ;**32,41,46,57,63,66,56,69,58,81,91,104,111,112,186,159,173**;16 DEC 97;Build 4
3 ;
4 ; Reference to ^PS(50.7 is supported by DBIA 2180.
5 ; Reference to ^PS(51 is supported by DBIA 2176.
6 ; Reference to ^PS(51.1 is supported by DIBA 2177.
7 ; Reference to ^PS(51.2 is supported by DBIA 2178.
8 ; Reference to ^PS(52.6 is supported by DBIA 1231.
9 ; Reference to ^PS(52.7 is supported by DBIA 2173.
10 ; Reference to ^PS(55 is supported by DBIA 2191.
11 ; Reference to ^PSDRUG is supported by DBIA 2192.
12 ; Usage of this routine by BCMA is supported by DBIA 2828.
13 ;
14EN(DFN,BDT,OTDATE) ; return condensed list of inpat meds
15 NEW CNT,DN,F,FON,ON,PST,WBDT,X,X1,X2,Y,%
16 D:+$G(DFN) ORDER
17 I '$D(^TMP("PSJ",$J,1,0)) S ^(0)=-1
18 K PSJINX
19 Q
20ORDER ;Loop thru orders.
21 I '+$G(BDT) D NOW^%DTC S BDT=%
22 I BDT'["." S BDT=BDT_".0001"
23 S PSJINX=0
24 ;U/D orders
25 S F="^PS(55,DFN,5,",WBDT=BDT
26 F S WBDT=$O(^PS(55,DFN,5,"AUS",WBDT)) Q:'WBDT D
27 . F ON=0:0 S ON=$O(^PS(55,DFN,5,"AUS",WBDT,ON)) Q:'ON S FON=ON_"U",PSJON(FON)="" D UDVAR
28 ;IV orders
29 S F="^PS(55,DFN,""IV"",",WBDT=BDT
30 F S WBDT=$O(^PS(55,DFN,"IV","AIS",WBDT)) Q:'WBDT D
31 . F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",WBDT,ON)) Q:'ON S FON=ON_"V",PSJON(FON)="" D IVVAR
32 ;Pending orders
33 S F="^PS(53.1,"
34 F PST="P","N" F ON=0:0 S ON=$O(^PS(53.1,"AS",PST,DFN,ON)) Q:'ON D
35 . S FON=ON_"P"
36 . S X=$P($G(^PS(53.1,+ON,0)),U,4) D @$S(X="F":"IVVAR",1:"UDVAR")
37 ;When a one-time order is found, check against PSJON(FON) array to
38 ;make sure no duplicate orders is return on ^TMP.
39 I '+$G(OTDATE) D NOW^%DTC S X1=$E(%,1,12),X2=-30 D C^%DTC S OTDATE=X
40 I OTDATE'["." S OTDATE=OTDATE_".0001"
41 Q:BDT'>OTDATE
42 S F="^PS(55,DFN,5,",WBDT=OTDATE
43 F S WBDT=$O(^PS(55,DFN,5,"AU","O",WBDT)) Q:'WBDT D
44 . F ON=0:0 S ON=$O(^PS(55,DFN,5,"AU","O",WBDT,ON)) Q:'ON D
45 .. S FON=ON_"U" D:'$D(PSJON(FON)) UDVAR
46 S F="^PS(55,DFN,""IV"",",WBDT=OTDATE
47 F S WBDT=$O(^PS(55,DFN,"IV","AIS",WBDT)) Q:'WBDT D
48 . F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",WBDT,ON)) Q:'ON D
49 .. S X=$P($G(^PS(55,DFN,"IV",ON,0)),U,9)
50 .. I X]"",$$ONE(DFN,ON_"V",X,$P(X,"^",2),$P(X,"^",3))="O" D
51 ... S FON=ON_"V" D:'$D(PSJON(FON)) IVVAR
52 K PSJON
53 Q
54 ;
55UDVAR ;Set ^TMP for Unit dose & Pending orders
56 D UDPEND Q:'$$CLINICS($G(CLINIC))
57 D TMP
58 ;Setup Dispense drug for ^TMP
59 S CNT=0 D NOW^%DTC
60 F X=0:0 S X=$O(@(F_ON_",1,"_X_")")) Q:'X D
61 . S PSJDD=@(F_ON_",1,"_X_",0)") I $P(PSJDD,"^",3)]"",$P(PSJDD,"^",3)'>% Q
62 . S CNT=CNT+1
63 . S ^TMP("PSJ",$J,PSJINX,700,CNT,0)=+PSJDD_U_$P($G(^PSDRUG(+PSJDD,0)),U)_U_$S((FON["U")&($P(PSJDD,U,2)=""):1,(FON["U")&($E($P(PSJDD,U,2))="."):"0"_$P(PSJDD,U,2),1:$P(PSJDD,U,2))_U_$P(PSJDD,U,3)
64 S:CNT ^TMP("PSJ",$J,PSJINX,700,0)=CNT
65 K PSJ,PSJDD
66 Q
67IVVAR ;Set variables for IV and pending orders
68 NEW ND,X,Y
69 I FON["P" D UDPEND Q:'$$CLINICS(CLINIC) S PSJ("INFRATE")=$P($G(^PS(53.1,ON,8)),U,5)
70 I FON["V" D Q:'$$CLINICS(CLINIC)
71 . S X=$G(^PS(55,DFN,"IV",ON,0)),CLINIC=$G(^("DSS")) Q:'$$CLINICS(CLINIC)
72 . S PSJ("STARTDT")=$P(X,U,2),PSJ("STOPDT")=$P(X,U,3)
73 . S PSJ("INFRATE")=$P(X,U,8),PSJ("SCHD")=$P(X,U,9)
74 . S PSJ("ADM")=$P(X,U,11),PSJ("AUTO")=$P(X,U,12),PSJ("STATUS")=$P(X,U,17)
75 . S PSJ("IVTYPE")=$P(X,U,4),PSJ("INSYR")=$P(X,U,5)
76 . S PSJ("CPRS")=$P(X,U,21),PSJ("CHEMO")=$P(X,U,23)
77 . S X=$G(^PS(55,DFN,"IV",ON,.2))
78 . S PSJ("DO")="",PSJ("MR")=$P(X,U,3),PSJ("PRI")=$P(X,U,4),PSJ("FLG")=$P(X,U,7),PSJ("COM")="",PSJ("SRC")=""
79 . I PSJ("FLG") D
80 .. N S1,A,B,C
81 .. S S1="" F S S1=$O(^PS(55,DFN,"IV",ON,"A",S1),-1) Q:'S1 S C=$G(^(S1,0)) S A=$P(C,U,2),B=$P(C,U,4) Q:A="UG" D I PSJ("SRC")]"" Q
82 ... Q:A'="G"
83 ... S PSJ("SRC")=$S(B["FLAGGED BY PHARM":"PHARMACIST",B["FLAGGED BY CPRS":"CPRS",1:"")
84 ... S PSJ("COM")=$P(B," ",4,99)
85 . S PSJ("OI")=+X
86 . S X=$G(^PS(55,DFN,"IV",ON,2))
87 . S PSJ("PREV")=$P(X,U,5) I PSJ("PREV")["V",(+PSJ("PREV")=+ON) S PSJ("PREV")=""
88 . S PSJ("FOLLOW")=$P(X,U,6),PSJ("RFO")=$P(X,U,9) I PSJ("FOLLOW")["V",(+PSJ("FOLLOW")=+ON) S (PSJ("FOLLOW"),PSJ("RFO"))=""
89 . S PSJ("SIOPI")=$S($P($G(^PS(55,DFN,"IV",+ON,3)),"^",2)&($P($G(^PS(55,DFN,"IV",+ON,3)),"^")'=""):"!",1:"")_$P($G(^(3)),"^")
90 . N SCHD S SCHD=PSJ("SCHD")
91 . S PSJ("STC")=$$ONE(DFN,ON_"V",SCHD,PSJ("STARTDT"),PSJ("STOPDT"))
92 . I PSJ("STC")=""!(PSJ("STC")="C") S PSJ("STC")=$S(SCHD["PRN":"P",1:"C")
93 . I PSJ("STC")="C" S PSJ("STC")=$S(SCHD["ON CALL":"OC",SCHD["ON-CALL":"OC",SCHD["ONCALL":"OC",1:"C")
94 D TMP
95 S CNT=0
96 F X=0:0 S X=$O(@(F_ON_",""AD"","_X_")")) Q:'X D
97 . S ND=$G(@(F_ON_",""AD"","_X_",0)")),DN=$G(^PS(52.6,+ND,0))
98 . S CNT=CNT+1,^TMP("PSJ",$J,PSJINX,850,CNT,0)=+ND_U_$P(DN,U)_U_$P(ND,U,2)_U_$P(ND,U,3)
99 S:CNT ^TMP("PSJ",$J,PSJINX,850,0)=CNT,CNT=0
100 F X=0:0 S X=$O(@(F_ON_",""SOL"","_X_")")) Q:'X D
101 . S ND=$G(@(F_ON_",""SOL"","_X_",0)")),DN=$G(^PS(52.7,+ND,0))
102 . S CNT=CNT+1,^TMP("PSJ",$J,PSJINX,950,CNT,0)=+ND_U_$P(DN,U)_U_$P(ND,U,2)_U_$P(DN,U,4)
103 S:CNT ^TMP("PSJ",$J,PSJINX,950,0)=CNT
104 K PSJ
105 S X1=0
106 F S X1=$O(^PS(55,DFN,"IVBCMA",X1)) Q:'X1 D
107 . S XX=$G(^PS(55,DFN,"IVBCMA",X1,0)) Q:ON'=$P(XX,"^",2) S PSJBCID=$P(XX,"^"),X2=0
108 . F I=1:1 S X2=$O(^PS(55,DFN,"IVBCMA",X1,"AD",X2)) Q:'X2 S X=^(X2,0),^TMP("PSJ",$J,PSJINX,800,PSJBCID,I)=+X_"^"_$S($D(^PS(52.6,+X,0)):$P(^(0),"^"),1:"*****")_"^"_$P(X,"^",2,99)
109 . I I>1 S ^TMP("PSJ",$J,PSJINX,800,PSJBCID,0)=I-1
110 . S X2=0
111 . F I=1:1 S X2=$O(^PS(55,DFN,"IVBCMA",X1,"SOL",X2)) Q:'X2 S X=^(X2,0),^TMP("PSJ",$J,PSJINX,900,PSJBCID,I)=$P(X,"^")_"^"_$S($D(^PS(52.7,$P(X,"^"),0)):$P(^(0),"^"),1:"*****")_"^"_$P(X,"^",2,99)
112 . I I>1 S ^TMP("PSJ",$J,PSJINX,900,PSJBCID,0)=I-1
113 Q
114UDPEND ;
115 S X=$G(@(F_ON_",0)")) I $P(F,",")[53.1 S CLINIC=$G(@(F_ON_",""DSS"")")) Q:'$$CLINICS(CLINIC)
116 I $P(F,",")[55 S CLINIC=$G(@(F_ON_",8)")) Q:'$$CLINICS(CLINIC)
117 S PSJ("MR")=$P(X,U,3),PSJ("SM")=$P(X,U,5),PSJ("HSM")=$P(X,U,6)
118 S PSJ("ST")=$P(X,U,7),PSJ("STATUS")=$P(X,U,9)
119 S PSJ("CPRS")=$P(X,U,21),PSJ("PREV")=$P(X,U,25),PSJ("FOLLOW")=$P(X,U,26),PSJ("RFO")=$P(X,U,27)
120 S:FON["U" PSJ("NGIVEN")=$P(X,U,22)
121 S X=$G(@(F_ON_",.2)"))
122 S PSJ("DO")=$P(X,U,2),PSJ("PRI")=$P(X,U,4),PSJ("FLG")=$P(X,U,7),PSJ("COM")="",PSJ("SRC")=""
123 I PSJ("FLG") D
124 . N S1,A,B,C
125 . S S1="" F S S1=$O(^PS(55,DFN,5,ON,9,S1),-1) Q:'S1 S C=$G(^(S1,0)) S A=$P(C,U,3),B=$P(C,U,4) Q:A=7010!(A=7030) D I PSJ("SRC")]"" Q
126 .. Q:A'=7000&(A'=7020)
127 .. S PSJ("SRC")=$S(A=7000:"PHARMACIST",A=7020:"CPRS",1:"")
128 .. S PSJ("COM")=$G(@(F_ON_",13)"))
129 S PSJ("OI")=+X
130 S X=$G(@(F_ON_",2)"))
131 S PSJ("SCHD")=$P(X,U),PSJ("STARTDT")=$P(X,U,2)
132 S PSJ("STOPDT")=$P(X,U,4),PSJ("ADM")=$P(X,U,5)
133 S X=$G(@(F_ON_",4)"))
134 S PSJ("AUTO")=$P(X,U,11)
135 ;naked reference on line below refers to full reference created by indirect reference to F_ON, where F may refer to ^PS(53.1 or the IV or UD multiple ^PS(55
136 S PSJ("SIOPI")=$S($P($G(@(F_ON_",6)")),"^",2)&($P($G(@(F_ON_",6)")),"^")'=""):"!",1:"")_$$ENSET($P($G(^(6)),"^"))
137 D SIOPI
138 S PSJ("STC")=PSJ("ST")
139 I PSJ("ST")="R"!(PSJ("ST")="C") S PSJ("STC")=$S(PSJ("SCHD")["PRN":"P","^ONCALL^ON-CALL^ON CALL^"[("^"_PSJ("SCHD")_"^"):"OC",$$ONE(DFN,FON,PSJ("SCHD"))="O":"O",1:"C")
140 Q
141TMP ;Setup ^TMP that have common fields between IV and U/D
142 N A
143 S PSJINX=PSJINX+1
144 S PSJ("OINAME")=$$OIDF^PSJLMUT1(+PSJ("OI")) I PSJ("OINAME")["NOT FOUND" S PSJ("OINAME")=""
145 S PSJ("OIDF")=$$GET1^DIQ(50.7,+PSJ("OI"),.02)
146 I PSJ("OINAME")="" S PSJ("OIDF")=""
147 S A=$G(^PS(51.2,+PSJ("MR"),0)),PSJ("MRABB")=$P(A,U,3),PSJ("MRNM")=$P(A,U)
148 S ^TMP("PSJ",$J,PSJINX,0)=DFN_U_+ON_U_FON_U_PSJ("PREV")_U_PSJ("FOLLOW")_U_$G(PSJ("IVTYPE"))_U_$G(PSJ("INSYR"))_U_$G(PSJ("CHEMO"))_U_PSJ("CPRS")_U_$G(PSJ("RFO"))
149 S ^TMP("PSJ",$J,PSJINX,1)=PSJ("MRABB")_U_PSJ("STC")_U_$G(PSJ("SCHD"))_U_PSJ("STARTDT")_U_PSJ("STOPDT")_U_PSJ("ADM")_U_PSJ("STATUS")_U_$G(PSJ("NGIVEN"))_U_$G(PSJ("ST"))_U_$G(PSJ("AUTO"))
150 S ^TMP("PSJ",$J,PSJINX,1,0)=$P(A,U,8)_U_PSJ("MRNM")_U_$P(A,U,9)
151 S ^TMP("PSJ",$J,PSJINX,2)=PSJ("DO")_U_$G(PSJ("INFRATE"))_U_$G(PSJ("SM"))_U_$G(PSJ("HSM"))
152 S ^TMP("PSJ",$J,PSJINX,3)=PSJ("OI")_U_PSJ("OINAME")_U_PSJ("OIDF")
153 S ^TMP("PSJ",$J,PSJINX,4)=PSJ("SIOPI")
154 S A=$$SNDTSTA^PSJHL4A(PSJ("PRI"),PSJ("SCHD"))
155 S ^TMP("PSJ",$J,PSJINX,5)=$S(A=1:0,1:1)_U_PSJ("FLG")_U_PSJ("SRC")_U_PSJ("COM")
156 Q
157SIOPI ; Use provider comments if order is pending and there is no SI
158 NEW X,Y,Z
159 I FON["P",(PSJ("SIOPI")=""),$O(^PS(53.1,+ON,12,0)) D
160 . F X=0:0 S X=$O(^PS(53.1,+ON,12,X)) Q:'X S Z=$G(^(X,0)) D
161 .. S Y=$L(PSJ("SIOPI"))
162 .. S:Y+$L(Z)'>179 PSJ("SIOPI")=PSJ("SIOPI")_Z_""
163 . I Y+$L(Z)>179 S PSJ("SIOPI")="SEE PROVIDER COMMENTS"
164 Q
165ENSET(X) ; expands SPECIAL INSTRUCTIONS field contained in X into Y
166 N X1,X2,Y S Y=""
167 F X1=1:1:$L(X," ") S X2=$P(X," ",X1) I X2]"" S Y=Y_$S($L(X2)>30:X2,'$D(^PS(51,+$O(^PS(51,"B",X2,0)),0)):X2,$P(^(0),"^",2)]""&$P(^(0),"^",4):$P(^(0),"^",2),1:X2)_" "
168 S Y=$E(Y,1,$L(Y)-1)
169 Q Y
170ONE(DFN,ORD,SCH,START,STOP) ;determine if order is a one-time
171 ; Input: DFN - patient's internal entry number
172 ; ORD - order number to check (must contain U or V)
173 ; SCH - schedule text (required)
174 ; START - order start date (optional)
175 ; STOP - order stop date (optional)
176 N X
177 I $G(PSJ("PREV")),$G(PSJ("FOLLOW")) I +PSJ("PREV")=+PSJ("FOLLOW") S (PSJ("PREV"),PSJ("FOLLOW"))=""
178 I $G(DFN)]"",$G(ORD)]"",ORD["U",$P(^PS(55,DFN,5,+ORD,0),"^",7)'="R" Q $P(^PS(55,DFN,5,+ORD,0),"^",7)
179 I $G(SCH)="" Q ""
180 I SCH="TODAY"!(SCH="ONCE")!(SCH="NOW")!(SCH="ONE TIME")!(SCH="ONETIME")!(SCH="ONE-TIME")!(SCH="1TIME")!(SCH="1 TIME")!(SCH="1-TIME")!(SCH="STAT") Q "O"
181 I $D(^PS(51.1,"AC","PSJ",SCH)) S X=$O(^(SCH,"")) S X=$P(^PS(51.1,X,0),"^",5) Q $S(X="D":"C",1:X)
182 I $G(START)]"",$G(STOP)]"",START=STOP Q "O"
183 Q ""
184CLINIC(CL) ;
185 I $P(CL,"^",2)?7N!($P(CL,"^",2)?7N1".".N) Q 1
186 Q 0
187CLINICS(CL) ;
188 Q:'$$CLINIC(CL) 1
189 Q:'$D(^PS(53.46,"B",+CL)) 1
190 N A
191 S A=$O(^PS(53.46,"B",+CL,"")) Q:'A 1
192 Q $P(^PS(53.46,A,0),"^",4)
Note: See TracBrowser for help on using the repository browser.