source: FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBOMT.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.4 KB
Line 
1PSBOMT ;BIRMINGHAM/TEJ-BCMA MEDICATION THERAPY REPORT ;Mar 2004
2 ;;3.0;BAR CODE MED ADMIN;**32**;Mar 2004;Build 32
3 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
4 ;
5 ; Reference/IA
6 ; File 50.7/2880
7 ; File 52.6/436
8 ; File 52.7/437
9 ; File 200/10060
10 ; EN^PSJBCMA1/2829
11 ; IEN^PSN50P65/4543
12 ; DRGIEN^PSS50P7/4662
13 ; VAC^PSS50/4533
14 ; ^PSDRUG(/221
15EN ;
16 N PSBHDR,PSBORDS,PSBORD,PSBOIP
17 N TMP
18 K TMP("PSBOIS",$J),TMP("VA CLASS",$J),TMP("PSBADDS",$J),TMP("PSBSOLS",$J),PSBLGD,PSBOIL,PSBDDL,PSBSOLL,PSBADDL
19 S PSBCLSS=0,PSBCFLG=0
20 S PSBXDFN=$P(PSBRPT(.1),U,2)
21 S PSBSTRT=$P(PSBRPT(.1),U,6)+$P(PSBRPT(.1),U,7),PSBSTOP=$P(PSBRPT(.1),U,8)+$P(PSBRPT(.1),U,9)
22 K PSBOCRIT F Y=1:1:4 I $P(PSBRPT(.2),U,Y) S PSBOCRIT=$G(PSBOCRIT,"")_$P("C^P^OC^O",U,Y)_"^"
23 D NOW^%DTC S (Y,PSBNOWX)=% D DD^%DT S PSBDTTM=$E(Y,1,18)
24 S:+PSBSTRT'>0 PSBSTRT=$$FMADD^XLFDT(X,-1)
25 S:+PSBSTOP'>0 PSBSTOP=$P(%,".")
26 I $D(PSBRPT(.2)) I $P(PSBRPT(.2),U,8) S PSBCFLG=1
27 I $D(PSBRPT(2)) F XD=$O(PSBRPT(2,0)):1:$O(PSBRPT(2,"B"),-1) S PSBRPT(2,XD,0)=$TR(PSBRPT(2,XD,0),"~",U) D:$P(PSBRPT(2,XD,0),U)="MT"
28 .I $P(PSBRPT(2,XD,0),U,2)="OIT" D Q
29 ..S PSBSRCHL="ORDERABLE ITEM SEARCH LIST:",PSBOIL(+$P(PSBRPT(2,XD,0),U,3))=""
30 ..S PSB=$P(PSBRPT(2,XD,0),U,3) F X=1:1:$L(PSB,",") Q:$P(PSB,",",X)="" S (TMP("PSBOIS",$J,$P(PSB,",",X)),PSBOIP("OIP",$P(PSB,",",X)))=""
31 .I $P(PSBRPT(2,XD,0),U,2)="ADD" D Q
32 ..S PSBSRCHL="IV MEDICATION SEARCH LIST:"
33 ..I $D(^PSDRUG("A526",$P(PSBRPT(2,XD,0),U,3))) S X2=$O(^PSDRUG("A526",$P(PSBRPT(2,XD,0),U,3),"")) S PSBADDL(X2)="",TMP("PSBOIS",$J,$$OFROMA(X2))=""
34 .I $P(PSBRPT(2,XD,0),U,2)="SOL" D Q
35 ..S PSBSRCHL="IV MEDICATION SEARCH LIST:"
36 ..I $D(^PSDRUG("A527",$P(PSBRPT(2,XD,0),U,3))) S X2=$O(^PSDRUG("A527",$P(PSBRPT(2,XD,0),U,3),"")) S PSBSOLL(X2)="",TMP("PSBOIS",$J,$$OFROMS(X2))=""
37 .I $P(PSBRPT(2,XD,0),U,2)="DD" D K PSBDRGS Q
38 ..S PSBSRCHL="DISPENSED DRUG SEARCH LIST:",PSBDDL($P(PSBRPT(2,XD,0),U,3))=""
39 ..K PSBDRGS S PSBDRGS="" D OILST^PSBRPCMO(.PSBDRGS,$P(PSBRPT(2,XD,0),U,3),"UD")
40 ..F X2=PSBDRGS(0):1:$O(PSBDRGS(""),-1) I +PSBDRGS(1)'<0 S TMP("PSBOIS",$J,$P(PSBDRGS(X2),U,4))=""
41 .I $P(PSBRPT(2,XD,0),U,2)="VAC" D
42 ..S PSBSRCHL="VA DRUG CLASS SEARCH LIST:"
43 ..S PSBCLS=$P(PSBRPT(2,XD,0),U,3) D GETCLSS(PSBCLS) K PSBDDRG("VAC") M TMP("VA CLASS",$J,PSBCLS,"DDRG")=PSBDDRG K PSBDDRG
44 ..S PSBCLSS=1
45 M PSBOIP("OIP")=TMP("PSBOIS",$J)
46 D OUT(PSBXDFN,PSBSTRT,PSBSTOP)
47 Q
48OUT(PSBXDFN,PSBSTRT,PSBSTOP) ;
49 D:PSBCLSS GETOIS ; POSSBLE CLASS ITEMS VIA AVAIL ORDERS
50 D GETADSO^PSBOMT1 ; ALL ADDS AND SOLS
51 D FINDIENS^PSBOMT1 ; FIND ALL MED LOG ENTRS
52 D PREOUT ; WRIT TO GLOBL
53 D WRITEOT
54 D CLEANSUM^PSBOMT1
55 D CLEANALL^PSBOMT1
56 Q
57GETOIS ;
58 K ^TMP("PSJ",$J),PSBTMP
59 D EN^PSJBCMA(PSBXDFN,PSBSTRT)
60 Q:^TMP("PSJ",$J,1,0)<0
61 M PSBTMP=^TMP("PSJ",$J) K ^TMP("PSJ",$J)
62 S X=0 F S X=$O(PSBTMP(X)) Q:+X=0 D
63 .Q:$G(PSBOCRIT,"")'[$P(PSBTMP(X,1),U,2)_"^"
64 .S PSBORDN=$P(PSBTMP(X,0),U,3) S PSBORDS(PSBORDN)=""
65 .I $D(PSBTMP(X,700)) D Q
66 ..F XX=1:1:PSBTMP(X,700,0) D
67 ...S PSBCLS="" F S PSBCLS=$O(TMP("VA CLASS",$J,PSBCLS)) Q:+PSBCLS=0 D
68 ....I '$D(TMP("VA CLASS",$J,PSBCLS,"DDRG",$P(PSBTMP(X,700,XX,0),U))) Q
69 ....S PSBORDS(PSBORDN,"DD",$P(PSBTMP(X,700,XX,0),U))=""
70 ....S PSBORDS(PSBORDN,"OIP",$P(PSBTMP(X,3),U))=""
71 ..M PSBOIP("OIP")=PSBORDS(PSBORDN,"OIP")
72 .I $D(PSBTMP(X,850)) M PSBORDS(PSBORDN,"ADD")=PSBTMP(X,850) D
73 ..F XX=1:1:PSBORDS(PSBORDN,"ADD",0) S PSBORDS(PSBORDN,"OIP",$$OFROMA($P(PSBORDS(PSBORDN,"ADD",XX,0),U)))=""
74 ..M PSBOIP("OIP")=PSBORDS(PSBORDN,"OIP")
75 .I $D(PSBTMP(X,950)) M PSBORDS(PSBORDN,"SOL")=PSBTMP(X,950) D
76 ..F XX=1:1:PSBORDS(PSBORDN,"SOL",0) S PSBORDS(PSBORDN,"OIP",$$OFROMS($P(PSBORDS(PSBORDN,"SOL",XX,0),U)))=""
77 ..M PSBOIP("OIP")=PSBORDS(PSBORDN,"OIP")
78 K PSBTMP
79 M TMP("PSBOIS",$J)=PSBOIP("OIP")
80 Q
81OFROMA(PSBADD) ;OITEM FROM AN ADDITIVE
82 S X1=$$GET1^DIQ(52.6,PSBADD_",",15,"I")
83 I PSBCLSS D
84 .S X2=$$GETDRN(X1)
85 .S PSBCLS="" K X3 F Q:$D(X3) S PSBCLS=$O(TMP("VA CLASS",$J,PSBCLS)) Q:+PSBCLS=0 D
86 ..I $D(TMP("VA CLASS",$J,PSBCLS,"DDRG",X2)) S X3=X1
87 .I '$D(X3) S X3=0
88 Q $G(X3,X1)
89OFROMS(PSBSOL) ;OITEM FROM A SOLUTION
90 S X1=$$GET1^DIQ(52.7,PSBSOL_",",9,"I")
91 I PSBCLSS D
92 .S X2=$$GETDRN(X1)
93 .S PSBCLS="" K X3 F Q:$D(X3) S PSBCLS=$O(TMP("VA CLASS",$J,PSBCLS)) Q:+PSBCLS=0 D
94 ..I $D(TMP("VA CLASS",$J,PSBCLS,"DDRG",X2)) S X3=X1
95 .I '$D(X3) S X3=0
96 Q $G(X3,X1)
97PREOUT ;
98 K PSBUNK S XDT="" F S XDT=$O(TMP("PSBIENS",$J,XDT),-1) Q:XDT="" S XIEN="",XIEN=$O(TMP("PSBIENS",$J,XDT,XIEN)) D
99 .Q:$$NONSTS(PSBXDFN,XIEN)
100 .S PSBIEN=XIEN
101 .S PSBIENS=PSBIEN_","
102 .D OUTPUT
103 Q
104OUTPUT ;
105 S PSBSPC=$J("",80)
106 S W=$E($$GET1^DIQ(53.79,PSBIENS,.02)_PSBSPC,1,20)_" "
107 S W=W_$S($P(^PSB(53.79,PSBIEN,0),U,9)="":"?? ",1:$E($P(^PSB(53.79,PSBIEN,0),U,9)_" ",1,2)_" ")
108 S:$P(^PSB(53.79,PSBIEN,0),U,9)="" PSBUNK=1
109 S W=W_$E($P($G(^PSB(53.79,PSBIEN,.1)),U,2)_PSBSPC,1,2)_" "
110 S W=W_$E($E($$GET1^DIQ(53.79,PSBIENS,.06),1,18)_PSBSPC,1,21)_" "
111 S W=W_$E($$GET1^DIQ(53.79,PSBIENS,"ACTION BY:INITIAL")_PSBSPC,1,10)_" ",PSBLGD("INITIALS",$$GET1^DIQ(53.79,PSBIENS,"ACTION BY","I"))=""
112 S W=W_$$GET1^DIQ(53.79,PSBIENS,.16)
113 D ADD(W)
114 K PSBV
115 F PSBNODE=.5,.6,.7 D
116 .S PSBDD=$S(PSBNODE=.5:53.795,PSBNODE=.6:53.796,1:53.797)
117 .F PSBY=0:0 S PSBY=$O(^PSB(53.79,PSBIEN,PSBNODE,PSBY)) Q:'PSBY D
118 ..I $$GET1^DIQ(53.79,PSBIENS,.11)["V" S PSBV=1
119 ..D WRAPMEDS($$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.01),$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.03),$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.02),$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.04))
120 I PSBCFLG=1 D COMNTS
121 D ADD("")
122 Q
123COMNTS ;
124 N Z,CNT
125 S Z="",CNT=0
126 I $D(^PSB(53.79,PSBIEN,.3,0)) D
127 .D ADD("")
128 .D ADD($J("",44)_"Comments: "_$$MAKELINE^PSBOMT1("-",78))
129 .S XT="" F S XT=$O(^PSB(53.79,PSBIEN,.3,XT)) Q:XT="" I XT'=0 D
130 ..D:CNT=1 ADD("")
131 ..S Y=$P(^PSB(53.79,PSBIEN,.3,XT,0),"^",3) D DD^%DT S XBR=Y
132 ..S Z=XBR_" "_$P(^VA(200,$P(^PSB(53.79,PSBIEN,.3,XT,0),"^",2),0),"^",2)
133 ..D WRAP($P(^PSB(53.79,PSBIEN,.3,XT,0),"^",1),Z,PSBIEN)
134 ..S CNT=1
135 .D ADD($J("",54)_$$MAKELINE^PSBOMT1("-",78))
136 Q
137WRAPMEDS(MED,UG,UO,UOA) ;
138 ;THIS WILL CREATE UPTO 3 LINES
139 S MED=$E(MED_$J("",40),1,40)
140 N UGWRAP,ORWRAP
141 S (CNTX,UOA1,UOA16,UOA31)=""
142 I +$G(UG)?1"."1.N S UG=0_+UG
143 I +$G(UO)?1"."1.N S UO=0_+UO
144 I $G(PSBV,0) S UO="NA"
145 F CNT=1:15:45 D
146 .D PARSE^PSBOMT1(UOA,CNT)
147 .S UGWRAP=$E(UG,CNT,(CNT+7)),UOWRAP=$E(UO,CNT,(CNT+7))
148 .I CNT=1 D ADD($J("",55)_MED_" "_$$PAD^PSBOMT1(UOWRAP,8)_" "_$$PAD^PSBOMT1(UGWRAP,8)_" "_$$PAD^PSBOMT1(UOA1,15))
149 .I (CNT>1),($L(UGWRAP)>0!$L(@("UOA"_CNT))>0) D ADD($J("",94)_$$PAD^PSBOMT1(UOWRAP,8)_" "_$$PAD^PSBOMT1(UGWRAP,8)_" "_$$PAD^PSBOMT1(@("UOA"_CNT),15))
150 Q
151HEADA ;
152 W !
153 W "Location",?21,"St Sch Administration Date",?50,"By",?61,"Injection Site",?96,"Units",?104,"Units",?113,"Units of"
154 W !,?55,"Medication & Dosage",?96,"Ordered",?104,"Given",?113,"Administration"
155 W !
156 W $$MAKELINE^PSBOMT1("-",132)
157 Q
158NONSTS(PSBX,PSBY) ;
159 D CLEAN^PSBVT,PSJ1^PSBVT(PSBX,$$GET1^DIQ(53.79,PSBY_",","ORDER REFERENCE NUMBER","I"))
160 Q PSBOCRIT'[PSBSCHT_"^"
161WRITEOT ;
162 D HDR^PSBOMT1
163 D MEDS
164 D PT^PSBOHDR(PSBXDFN,.PSBHDR),HEADA
165 I '$D(TMP("PSBIENS",$J)) D ADD("<<<< NO HISTORY FOUND FOR THIS TIME FRAME >>>>")
166 S EX="" F S EX=$O(^TMP("PSB",$J,EX)) Q:EX="" D
167 .I $Y>(IOSL-5) D
168 ..W $$PTFTR^PSBOHDR()
169 ..D PT^PSBOHDR(PSBXDFN,.PSBHDR),HEADA
170 .W !,$G(^TMP("PSB",$J,EX))
171 D:$D(TMP("PSBIENS",$J)) LEGEND^PSBOMT1
172 D FTR^PSBOMT1
173 Q
174MEDS ;
175 N MED,XA,XB
176 S MED="",XB=$O(PSBHDR(""),-1)+1
177 S PSBHDR(XB)=PSBSRCHL
178 I PSBCLSS S XA=0 K PSBGOT F S XA=$O(TMP("VA CLASS",$J,XA)) Q:+XA=0 D
179 .K ^TMP($J,"PSBLIST") D IEN^PSN50P65(XA,"??","PSBLIST")
180 .I ^TMP($J,"PSBLIST",0)>0 S MED=^TMP($J,"PSBLIST",XA,1) Q:$D(PSBGOT(MED)) K ^TMP($J,"PSBLIST")
181 .I $L(PSBHDR(XB)_" "_$G(MED," * NO DATA FOUND * "))+3>IOM D Q
182 ..S XB=XB+1,PSBHDR(XB)=" / "_MED S PSBGOT(MED)=""
183 .S PSBHDR(XB)=PSBHDR(XB)_$S(($L(PSBHDR(XB),":")=2)&($P(PSBHDR(XB),":",2)=""):" ",1:" / ")_MED,PSBGOT(MED)=""
184 I $D(PSBOIL) S XA="" K PSBGOT F S XA=$O(PSBOIL(XA)) Q:XA="" D
185 .S MED=$$GET1^DIQ(50.7,XA,.01) Q:$D(PSBGOT(MED)) S PSBGOT(MED)=""
186 .I $L(PSBHDR(XB)_" / "_MED)+3>IOM D Q
187 ..S XB=XB+1,PSBHDR(XB)=" / "_MED
188 .S PSBHDR(XB)=PSBHDR(XB)_$S(($L(PSBHDR(XB),":")=2)&($P(PSBHDR(XB),":",2)=""):" ",1:" / ")_MED
189 I $D(PSBADDL) S XA="" K PSBGOT F S XA=$O(PSBADDL(XA)) Q:XA="" D
190 .S MED=$$GET1^DIQ(52.6,XA,.01) Q:$D(PSBGOT(MED)) S PSBGOT(MED)=""
191 .I $L(PSBHDR(XB)_" / "_MED)+3>IOM D Q
192 ..S XB=XB+1,PSBHDR(XB)=" / "_MED
193 .S PSBHDR(XB)=PSBHDR(XB)_$S(($L(PSBHDR(XB),":")=2)&($P(PSBHDR(XB),":",2)=""):" ",1:" / ")_MED
194 I $D(PSBSOLL) S XA="" K PSBGOT F S XA=$O(PSBSOLL(XA)) Q:XA="" D
195 .S MED=$$GET1^DIQ(52.7,XA,.01) Q:$D(PSBGOT(MED)) S PSBGOT(MED)=""
196 .I $L(PSBHDR(XB)_" / "_MED)+3>IOM D Q
197 ..S XB=XB+1,PSBHDR(XB)=" / "_MED
198 .S PSBHDR(XB)=PSBHDR(XB)_$S(($L(PSBHDR(XB),":")=2)&($P(PSBHDR(XB),":",2)=""):" ",1:" / ")_MED
199 I $D(PSBDDL) S XA="" F S XA=$O(PSBDDL(XA)) Q:XA="" D
200 .S MED=$$GET1^DIQ(50,XA,.01)
201 .I $L(PSBHDR(XB)_" / "_MED)+3>IOM D Q
202 ..S XB=XB+1,PSBHDR(XB)=" / "_MED
203 .S PSBHDR(XB)=PSBHDR(XB)_$S(($L(PSBHDR(XB),":")=2)&($P(PSBHDR(XB),":",2)=""):" ",1:" / ")_MED
204 Q
205WRAP(SIZE,ZP,BRIEN) ;
206 D ADD($J("",55)_ZP)
207 D ADD($J("",55)_$E(SIZE,1,75))
208 I $L(SIZE)>75 D ADD($J("",55)_$E(SIZE,76,150))
209 Q
210ADD(XE) ;
211 S ^TMP("PSB",$J,$O(^TMP("PSB",$J,""),-1)+1)=XE
212 Q
213GETDRN(IEN1) ;
214 ; Get the Drug IEN (p50) via OI IEN (p50.7)
215 K ^TMP($J,"PSBLIST")
216 D DRGIEN^PSS50P7(IEN1,,"PSBLIST")
217 S DN=$O(^TMP($J,"PSBLIST",0))
218 K ^TMP($J,"PSBLIST")
219 Q DN
220GETCLSS(IEN1) ;
221 ; Get the Items w/i VA Class
222 K ^TMP($J,"PSBLIST")
223 D VAC^PSS50(IEN1,,,"PSBLIST")
224 M PSBDDRG=^TMP($J,"PSBLIST")
225 K ^TMP($J,"PSBLIST")
226 Q
Note: See TracBrowser for help on using the repository browser.