source: WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBOPM.m@ 1789

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

initial load of WorldVistAEHR
File size: 8.3 KB
Line 
1PSBOPM ;BIRMINGHAM/BSR-BCMA OIT HISTORY ;Mar 2004
2 ;;3.0;BAR CODE MED ADMIN;**3,9,13,17**;Mar 2004;Build 1
3 ;;Per VHA Directive 2004-038, 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 ;
12EN ;
13 N PSBHDR,DFN
14 S PSBGBL="^TMP(""PSBO"",$J,""B"")"
15 F S PSBGBL=$Q(@PSBGBL) Q:PSBGBL="" Q:$QS(PSBGBL,2)'=$J Q:$QS(PSBGBL,1)'["PSBO" D
16 .S DFN=$QS(PSBGBL,5)
17 I '$G(DFN) W !,("Error: No Patient IEN") Q
18 S PSBSTRT=$P(PSBRPT(.1),U,6)+$P(PSBRPT(.1),U,7)
19 S PSBSTOP=$P(PSBRPT(.1),U,8)+$P(PSBRPT(.1),U,9)
20 S PSBCOM=$P(PSBRPT(.2),"^",8) ;COMMENT FLAG 1 MEANS YES
21 I PSBSTRT="0" D
22 .D NOW^%DTC S PSBSTOP=%
23 .S X1=((PSBSTOP)\1) S X2=-$$GET^XPAR("ALL","PSB MED HIST DAYS BACK")
24 .S:X2'<0 X2=-30 D C^%DTC S PSBSTRT=X
25 .S PSBCOM=$$GET^XPAR("ALL","PSB RPT INCL COMMENTS")
26 D OUT(DFN,PSBSTRT,PSBSTOP,PSBORDNM)
27 Q
28 ;
29OUT(DFN,PSBSTRT,PSBSTOP,PSBORDNM) ;
30 D CLEANALL ;CLEAN UP VARIABLES AND TMP ARRAY
31 ;
32 ;IF PSBORDNM DOESN'T CONTAIN A "U" OR A "V", SKIP THE ORDER LOOKUP
33 S PSBOR=1
34 I PSBORDNM'["U",PSBORDNM'["V" D
35 .S:'$$GETORD^PSBOPM1(.PSBORDNM) PSBOR=0
36 .I 'PSBOR&(PSBORDNM]"") S TMP("PSBOIS",$J,PSBORDNM)=""
37 I PSBOR D
38 .D GETORDN
39 .D GETOIS
40 D GETADSO ; GET ALL ADDITIVES AND SOLUTIONS
41 D FINDIENS^PSBOPM1 ; FIND EVERY MED LOG ENTRIES THAT SHOULD BE ON THE RPT
42 D PREOUT ; WRITE DATA TO GLOBAL
43 D WRITEOT ;
44 D CLEANSUM ; CLEAN UP AND LEAVE LIST OF IENS FOR THE REPORT.
45 Q
46 ;
47GETORDN ;
48 K ^TMP("PSJ1",$J)
49 D EN^PSJBCMA1(DFN,PSBORDNM,1)
50 Q
51 ;
52GETOIS ; LOAD PSBOIS(#) WITH ALL OF THE ORDERABLE ITEMS
53 I PSBORDNM["U" D
54 .;GET UNIT DOSE ORDERS
55 .S PSBOI=$P(^TMP("PSJ1",$J,2),"^")
56 .S PSBOI=$S(PSBOI["U":$TR(PSBOI,"U",""),PSBOI["V":$TR(PSBOI,"V",""),1:PSBOI)
57 .S TMP("PSBOIS",$J,PSBOI)=""
58 ;
59 ;IV ORDERS NEED TO USE THE ADDITIVE AND SOLUTION NUMBER TO BACK
60 ;TRACK TO THE OI ASSOCIATED WITH IT
61 I PSBORDNM["V" D
62 .;GET ADDITIVES OFF THE ORDER
63 .I $G(^TMP("PSJ1",$J,850,0)) D
64 ..S XXX="" F S XXX=$O(^TMP("PSJ1",$J,850,XXX)) Q:XXX="" D
65 ...S XXY="" F S XXY=$O(^TMP("PSJ1",$J,850,XXX,XXY)) Q:XXY="" D
66 ....S PSBADD=$P(^TMP("PSJ1",$J,850,XXX,XXY),"^")
67 ....;CONVERT ADDITIVE TO ORDERABLE ITEM AND ADD TO LIST
68 ....S TMP("PSBOIS",$J,$$OFROMA(PSBADD))=""
69 .; GET SOLUTIONS OFF THE ORDER
70 .I $G(^TMP("PSJ1",$J,950,0)) D
71 ..S XXX="" F S XXX=$O(^TMP("PSJ1",$J,950,XXX)) Q:XXX="" D
72 ...S XXY="" F S XXY=$O(^TMP("PSJ1",$J,950,XXX,XXY)) Q:XXY="" D
73 ....S PSBSOL=$P(^TMP("PSJ1",$J,950,XXX,XXY),"^")
74 ....;
75 ....;CONVERT SOLUTIOIN TO ORDERABLE ITEM AND ADD TO LIST
76 ....S TMP("PSBOIS",$J,$$OFROMS(PSBSOL))=""
77 Q
78 ;
79OFROMA(PSBADD) ;GET ORDERABLE ITEM FROM AN ADDITIVE
80 Q $$GET1^DIQ(52.6,PSBADD_",",15,"I")
81 ;
82OFROMS(PSBSOL) ; GET ORDERABLE ITEM FROM A SOLUTION
83 Q $$GET1^DIQ(52.7,PSBSOL_",",9,"I")
84 ;
85GETADSO ; GET ALL ADDITIVES FOR ALL ORDERABLE ITEMS
86 K PSBAOUT,PSBSOUT
87 S XA="" F S XA=$O(TMP("PSBOIS",$J,XA)) Q:XA="" D
88 .D LIST^DIC(52.6,"","@;15I","QPI","","","","AOI","","","PSBAOUT")
89 .S XB=0 F S XB=$O(PSBAOUT("DILIST",XB)) Q:XB="" D
90 ..I $P(PSBAOUT("DILIST",XB,0),"^",2)=XA D
91 ...S TMP("PSBADDS",$J,$P(PSBAOUT("DILIST",XB,0),"^",1))=""
92 K PSBAOUT
93 ; GET ALL SOLUTIONS FOR ALL ORDERABLE ITEMS
94 S XA="" F S XA=$O(TMP("PSBOIS",$J,XA)) Q:XA="" D
95 .D LIST^DIC(52.7,"","@;9I","QPI","","","","AOI","","","PSBSOUT")
96 .S XB=0 F S XB=$O(PSBSOUT("DILIST",XB)) Q:XB="" D
97 ..I $P(PSBSOUT("DILIST",XB,0),"^",2)=XA D
98 ...S TMP("PSBSOLS",$J,$P(PSBSOUT("DILIST",XB,0),"^",1))=""
99 K PSBSOUT
100 Q
101 ;
102PREOUT ;
103 N TYP
104 F TYP="UD","ADD","SOL" D
105 .Q:'$D(TMP("PSBIENS",$J,TYP))
106 .K PSBUNK S XDT="" F S XDT=$O(TMP("PSBIENS",$J,TYP,XDT),-1) Q:XDT="" S I="",I=$O(TMP("PSBIENS",$J,TYP,XDT,I)) D
107 ..I TYP="UD" Q:$D(TMP("PSBIENS",$J,"ADD",XDT,I)) Q:$D(TMP("PSBIENS",$J,"SOL",XDT,I))
108 ..S PSBIEN=I
109 ..S PSBIENS=PSBIEN_","
110 ..D OUTPUT(TYP)
111 Q
112 ;
113OUTPUT(TYP) ;
114 S PSBSPC=$J("",80)
115 S W=$E($$GET1^DIQ(53.79,PSBIENS,.02)_PSBSPC,1,20)_" "
116 S W=W_$S($P(^PSB(53.79,PSBIEN,0),U,9)="":"?? ",1:$E($P(^PSB(53.79,PSBIEN,0),U,9)_" ",1,2)_" ")
117 S:$P(^PSB(53.79,PSBIEN,0),U,9)="" PSBUNK=1
118 S W=W_$E($P($G(^PSB(53.79,PSBIEN,.1)),U,2)_PSBSPC,1,2)_" "
119 S W=W_$E($E($$GET1^DIQ(53.79,PSBIENS,.06),1,18)_PSBSPC,1,21)_" "
120 S W=W_$E($$GET1^DIQ(53.79,PSBIENS,"ACTION BY:INITIAL")_PSBSPC,1,10)_" "
121 S W=W_$$GET1^DIQ(53.79,PSBIENS,.16)
122 D ADD(W,TYP)
123 F PSBNODE=.5,.6,.7 D
124 .S PSBDD=$S(PSBNODE=.5:53.795,PSBNODE=.6:53.796,1:53.797)
125 .F PSBY=0:0 S PSBY=$O(^PSB(53.79,PSBIEN,PSBNODE,PSBY)) Q:'PSBY D
126 ..D WRAPMEDS($$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.01),$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.03),$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.04),TYP)
127 I PSBCOM=1 D COMNTS ;GETS COMMENTS
128 D ADD("",TYP)
129 Q
130 ;
131COMNTS ;
132 N Z,CNT
133 S Z="",CNT=0
134 I $D(^PSB(53.79,PSBIEN,.3,0)) D
135 .D ADD("",TYP)
136 .D ADD($J("",44)_"Comments: "_$$MAKELINE("-",78),TYP)
137 .S XT="" F S XT=$O(^PSB(53.79,PSBIEN,.3,XT)) Q:XT="" I XT'=0 D
138 ..D:CNT=1 ADD("",TYP)
139 ..S Y=$P(^PSB(53.79,PSBIEN,.3,XT,0),"^",3) D DD^%DT S XBR=Y
140 ..S Z=XBR_" "_$P(^VA(200,$P(^PSB(53.79,PSBIEN,.3,XT,0),"^",2),0),"^",2)
141 ..D WRAP($P(^PSB(53.79,PSBIEN,.3,XT,0),"^",1),Z,PSBIEN)
142 ..S CNT=1
143 .D ADD($J("",54)_$$MAKELINE("-",78),TYP)
144 Q
145 ;
146WRAP(SIZE,ZP,BRIEN) ;
147 D ADD($J("",55)_ZP,TYP)
148 D ADD($J("",55)_$E(SIZE,1,75),TYP)
149 I $L(SIZE)>75 D ADD($J("",55)_$E(SIZE,76,150),TYP)
150 Q
151 ;
152HEADA ;
153 W !
154 W "Location",?21,"St Sch Administration Date",?50,"By",?61,"Injection Site",?96,"Units",?112,"Units of"
155 W !,?55,"Medication & Dosage",?96,"GIVEN",?112,"Administration"
156 W !
157 W $$MAKELINE("-",132)
158 Q
159 ;
160ADD(XE,TYP) ;
161 S ^TMP("PSB",$J,TYP,$O(^TMP("PSB",$J,TYP,""),-1)+1)=XE
162 Q
163 ;
164WRAPMEDS(MED,UG,UOA,TYP) ;
165 ;MED IS NOT WRAPPED: MAX LENGTH IN PSDRUG/52.6/52.7 IS 40
166 ;UG/UOA MAX AT 30/40 AND WILL BE WRAPPED AT 15 EACH
167 ;THIS WILL CREATE UPTO 3 LINES
168 S MED=$E(MED_$J("",40),1,40)
169 N UGWRAP
170 S (CNTX,UOA1,UOA16,UOA31)=""
171 I +$G(UG)?1"."1.N S UG=0_+UG
172 F CNT=1:15:45 D
173 .D PARSE(UOA,CNT)
174 .S UGWRAP=$E(UG,CNT,(CNT+14))
175 .I CNT=1 D ADD($J("",55)_MED_" "_$$PAD(UGWRAP,15)_" "_$$PAD(UOA1,15),TYP)
176 .I (CNT>1),($L(UGWRAP)>0!$L(@("UOA"_CNT))>0) D ADD($J("",96)_$$PAD(UGWRAP,15)_" "_$$PAD(@("UOA"_CNT),15),TYP)
177 Q
178 ;
179PAD(X,CNT) ;
180 Q $E(X_$J("",CNT),1,CNT)
181WRITEOT ;
182 N TPE
183 S Y=$P(PSBSTRT,".",1) D D^DIQ S PSTRTA=Y
184 S Y=$P(PSBSTOP,".",1) D D^DIQ S PSTP=Y
185 S PSBHDR(1)="MEDICATION HISTORY for "_PSTRTA_" to "_PSTP
186 I '$D(TMP("PSBIENS",$J)) D ADD("<<<< NO HISTORY FOUND FOR THIS TIME .FRAME >>>>","UD")
187 S TPE="" F S TPE=$O(^TMP("PSB",$J,TPE)) Q:TPE="" D
188 .D MEDS(TPE)
189 .D PT^PSBOHDR(DFN,.PSBHDR),HEADA
190 .S EX="" F S EX=$O(^TMP("PSB",$J,TPE,EX)) Q:EX="" D
191 ..I $Y>(IOSL-5) D
192 ...W $$PTFTR^PSBOHDR()
193 ...D PT^PSBOHDR(DFN,.PSBHDR),HEADA
194 ..W !,$G(^TMP("PSB",$J,TPE,EX))
195 W $$PTFTR^PSBOHDR()
196 Q
197 ;
198FTR() ;
199 I (IOSL<100) F Q:$Y>(IOSL-10) W !
200 W !,$TR($J("",IOM)," ","=")
201 S X="Ward: "_PSBHDR("WARD")_" Room-Bed: "_PSBHDR("ROOM")
202 W !,PSBHDR("NAME"),?(IOM-11\2),PSBHDR("SSN"),?(IOM-$L(X)),X
203 Q ""
204 ;
205MEDS(TYP) ;
206 N MED,XA,XB,DPTR,DRG,FLE,SBSC
207 S MED="",XB=3,DRG=""
208 S PSBHDR(3)="MEDICATIONS SEARCH LIST:"
209 S XA="" F S XA=$O(TMP("PSBOIS",$J,XA)) Q:XA="" D
210 .S MED=$$GET1^DIQ(50.7,XA,.01)
211 .I $L(PSBHDR(XB)_" "_MED)>IOM D
212 ..S XB=XB+1,PSBHDR(XB)=" "_MED
213 .E S PSBHDR(XB)=PSBHDR(XB)_$S($L(PSBHDR(XB))<26:" ",1:"; ")_MED
214 S XA=999 F S XA=$O(PSBHDR(XA),-1) Q:XA=XB K PSBHDR(XA)
215 I TYP'="" D
216 .I TYP["UD" S TYP="UNIT DOSE",SBSC="PSBOIS",FLE=50.7
217 .I TYP["AD" S TYP="ADDITIVE",SBSC="PSBADDS",FLE=52.6
218 .I TYP["SO" S TYP="SOLUTION",SBSC="PSBSOLS",FLE=52.7
219 .S DPTR="" F S DPTR=$O(TMP(SBSC,$J,DPTR)) Q:DPTR="" I TMP(SBSC,$J,DPTR) D
220 ..S DRG=$$GET1^DIQ(FLE,DPTR,.01)
221 ..S PSBHDR($O(PSBHDR(999),-1)+1)=$S(TYP="UNIT DOSE":"",1:"SEARCH FOR "_TYP_": "_DRG)
222 .K TMP(SBSC,$J)
223 Q
224 ;
225CLEANALL ; KILL ALL TMP LEVELS USED VARIABLES
226 K ^TMP("PSB",$J),^TMP("PSJ1",$J),TMP("PSBOIS",$J),TMP("PSBADDS",$J),TMP("PSBSOLS",$J),TMP("PSBIENS",$J),TMP("ARY",$J),DRG,DPTR,PSBOR,FLE,SBSC,TPE
227 Q
228 ;
229CLEANSUM ; KILLL ALL BUT THE "PSBIENS" LEVEL
230 K ^TMP("PSB",$J),^TMP("PSJ1",$J),TMP("PSBIENS",$J),TMP("PSBOIS",$J),TMP("PSBADDS",$J),TMP("PSBSOLS",$J)
231 Q
232MAKELINE(X,CNT) ;LINE OF WHAT'S PASSED IN CNT TIMES
233 N Y,Z
234 S Y=""
235 F Z=1:1:CNT S Y=Y_X
236 Q Y
237 ;
238PARSE(X,CNT) ;Split text for wrapping.
239 S CNTX="UOA"_CNT,@CNTX=@CNTX_$E(X,CNT,(CNT+14)),UOAX=""
240 F S:$F(@CNTX,", ",+UOAX)>0 UOAX=$F(@CNTX,", ",+UOAX) Q:'$F(@CNTX,", ",+UOAX)
241 I UOAX<1 F S:$F(@CNTX," ",+UOAX)>0 UOAX=$F(@CNTX," ",+UOAX) Q:'$F(@CNTX," ",+UOAX)
242 I UOAX>1,(($L(UOA)-(CNT+14))>0) S CNTXX=$E(@CNTX,1,UOAX-1),@("UOA"_(CNT+15))=$E(@CNTX,UOAX,UOAX+14),@CNTX=CNTXX
243 Q
244 ;
Note: See TracBrowser for help on using the repository browser.