source: WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBODL.m@ 724

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

initial load of WorldVistAEHR

File size: 8.9 KB
Line 
1PSBODL ;BIRMINGHAM/EFC-DUE LIST ;Mar 2004
2 ;;3.0;BAR CODE MED ADMIN;**5,9,38,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 ; EN^PSJBCMA/2828
7 ; $$GET^XPAR/2263
8 ; ^XLFDT/10103
9 ;
10EN ; Prt DL
11 N PSBGBL,PSBHDR,IOINHI,IOINORM,PSBGIVEN,PSBIEN,PSBLGDT,PSBEVDT,DFN,PSBFLAG
12 S X="IOINHI;IOINORM" D ENDR^%ZISS S X=""
13 I '$D(^TMP("PSBO",$J,"B")) S ^TMP("PSBO",$J,"B","EMPTY")=""
14 S PSBGBL="^TMP(""PSBO"",$J,""B"")"
15 I $G(PSBRPT(.4)) S $P(PSBRPT(.2),U,8)=1
16 F S PSBGBL=$Q(@PSBGBL) Q:PSBGBL="" Q:$QS(PSBGBL,1)'="PSBO"!($QS(PSBGBL,2)'=$J) D
17 .S DFN=$QS(PSBGBL,5)
18 .K PSBHDR
19 .S PSBHDR(1)="MEDICATION DUE LIST for "
20 .S (Y,PSBEVDT)=$P(PSBRPT(.1),U,6) D D^DIQ S Z=Y,PSBHDR(1)=PSBHDR(1)_Y_"@" S Y=$P(PSBRPT(.1),U,7) S PSBHDR(1)=PSBHDR(1)_$E(Y_"0000",2,5)
21 .S PSBEVDT2=$P(PSBRPT(.1),U,6) S Y=$P(PSBRPT(.1),U,9) S:Y]"" PSBHDR(1)=PSBHDR(1)_" to "_Z_"@"_$E(Y_"0000",2,5)
22 .S PSBHDR(2)="Schedule Type(s): --"
23 .F Y=1:1:4 I $P(PSBRPT(.2),U,Y) S $P(PSBHDR(2),": ",2)=$P(PSBHDR(2),": ",2)_$S(PSBHDR(2)["--":"",1:"/ ")_$P("Continuous^PRN^On-Call^One-Time",U,Y)_" " S PSBHDR(2)=$TR(PSBHDR(2),"-","")
24 .S PSBHDR(3)="Order Type(s): --"
25 .F Y=6,7,8 I $P(PSBRPT(.2),U,Y) S $P(PSBHDR(3),": ",2)=$P(PSBHDR(3),": ",2)_$S(PSBHDR(3)["--":"",1:"/ ")_$P("^^^^^IV^Unit Dose^Future Orders",U,Y)_" " S PSBHDR(3)=$TR(PSBHDR(3),"-","")
26 .I $QS(PSBGBL,4)="EMPTY" D Q
27 ..S X="" F S X=$O(PSBHDR(X)) Q:X="" D W !!?10,"** NO DATA FOR ENTIRE NURSE/WARD LOCATION **",! Q
28 ...W !,PSBHDR(X)
29 .D PRINT(DFN)
30 K ^TMP("PSJ",$J),^TMP("PSB",$J),^TMP("PSBO",$J)
31 Q
32PRINT(DFN) ;^TMP($J.
33 N PSBGBL,PSBOSTRT,PSBOSTOP,PSBINDX,PSBTYPE,PSBSCH,PSBSCHT
34 N PSBMED,PSBORD,PSB,PSBX,PSBY,PSBZ,PSBSTOP,PSBSTRT,PSBSM,PSBNUM,PSBAT
35 N PSBADMIN,PSBADM,PSBSTAT,PSBWFLAG
36 W $$HDR()
37 S PSBOSTRT=$P(PSBRPT(.1),U,6)+$P(PSBRPT(.1),U,7)
38 S PSBOSTOP=$P(PSBRPT(.1),U,6)+$P(PSBRPT(.1),U,9)
39 K ^TMP("PSJ",$J),^TMP("PSB",$J)
40 D EN^PSJBCMA(DFN,PSBOSTRT,"")
41 I $G(^TMP("PSJ",$J,1,0))=-1 W !!?10,"** NO SPECIFIED MEDICATIONS TO PRINT **",!,$$BLANKS(),$$FTR^PSBODL1() Q
42 S PSBI1=0 F S PSBODATE=$$FMADD^XLFDT(PSBEVDT,PSBI1) Q:PSBODATE>PSBEVDT2 D
43 .S PSBI1=1
44 .S Y=PSBODATE D D^DIQ
45 .W !!,"Administration Date: "_Y,!
46 .S PSBINDX=0
47 .F S PSBINDX=$O(^TMP("PSJ",$J,PSBINDX)) Q:'PSBINDX D
48 ..S PSBTYPE=$P(^TMP("PSJ",$J,PSBINDX,0),U,3),PSBTYPE=$E(PSBTYPE,$L(PSBTYPE))
49 ..Q:PSBTYPE=""!(PSBTYPE="P") ; No Pend this ver
50 ..S PSBSTAT=^TMP("PSJ",$J,PSBINDX,1)
51 ..I $P(PSBSTAT,U,7)["D"!($P(PSBSTAT,U,8)) Q
52 ..Q:PSBTYPE="U"&('$P(PSBRPT(.2),U,7))
53 ..Q:PSBTYPE="V"&('$P(PSBRPT(.2),U,6))
54 ..S PSBTYPE=$S(PSBTYPE="U":"UD-",PSBTYPE="V":"IV-",1:"**")
55 ..S Y=$P(PSBSTAT,U,2)
56 ..Q:Y="C"&('$P(PSBRPT(.2),U,1))
57 ..Q:Y="P"&('$P(PSBRPT(.2),U,2))
58 ..Q:Y="OC"&('$P(PSBRPT(.2),U,3))
59 ..Q:Y="O"&('$P(PSBRPT(.2),U,4))
60 ..S PSBSCHT=Y
61 ..S:PSBSCHT="" PSBSCHT="*"
62 ..S PSBMED=$P(^TMP("PSJ",$J,PSBINDX,3),U,2)
63 ..S PSBORD=$P(^TMP("PSJ",$J,PSBINDX,0),U,3)
64 ..S ^TMP("PSB",$J,"B",PSBTYPE,PSBSCHT,PSBMED,PSBORD)=""
65 .I '$D(^TMP("PSB",$J,"B")) W !!?10,"** NO SPECIFIED MEDICATIONS TO PRINT **",!,$$BLANKS(),$$FTR^PSBODL1() Q
66 .S PSBGBL=$NAME(^TMP("PSB",$J,"B")),PSBWFLAG=0
67 .F S PSBGBL=$Q(@PSBGBL) Q:PSBGBL="" Q:($QS(PSBGBL,1)'="PSB")!($QS(PSBGBL,2)'=$J)!($QS(PSBGBL,3)'="B") D
68 ..K PSBORD,PSBFUTRO
69 ..S PSBTYPE=$QS(PSBGBL,4)
70 ..S PSBSCHT=$QS(PSBGBL,5)
71 ..S PSBMED=$QS(PSBGBL,6)
72 ..S PSBORD=$QS(PSBGBL,7)
73 ..D CLEAN^PSBVT
74 ..D PSJ1^PSBVT(DFN,PSBORD)
75 ..D NOW^%DTC S PSBNOW=%
76 ..Q:PSBOSP<PSBOSTRT
77 ..Q:(PSBOSP<PSBOSTRT)&(PSBSCHT'="O")
78 ..S (PSBYES,PSBODD,PSBDAYB,PSBSCBR)=0
79 ..S:$$PSBDCHK1^PSBVT1(PSBSCH) PSBYES=1,PSBDAYB=1
80 ..F I=1:1 Q:$P(PSBSCH,"-",I)="" I $P(PSBSCH,"-",I)?2N!($P(PSBSCH,"-",I)?4N) S PSBYES=1,PSBSCBR=1
81 ..I PSBYES,PSBADST="",PSBSCHT'="O",PSBSCHT'="OC",PSBSCHT'="P" D Q
82 ...D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Admin times required",PSBSCH)
83 ..I PSBSCHT="OC" S PSBYES=1
84 ..I PSBSCHT="P" S PSBYES=1
85 ..I "PCS"'[PSBIVT S PSBYES=1
86 ..I PSBIVT["S",PSBISYR'=1 S PSBYES=1
87 ..I PSBIVT["C",PSBCHEMT'="P",PSBISYR'=1 S PSBYES=1
88 ..I PSBIVT["C",PSBCHEMT="A" S PSBYES=1
89 ..I PSBFREQ="O" S PSBFREQ=1440
90 ..I PSBFREQ="D" S PSBFREQ=""
91 ..I PSBSCHT="P" S PSBFREQ=1440
92 ..I PSBSCHT="O" S PSBFREQ=1440
93 ..I 'PSBYES,PSBFREQ<1 D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Invalid frequency received from order",PSBSCH) Q
94 ..S PSBVALB=$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH)
95 ..I 'PSBDAYB,'PSBSCBR,PSBSCHT="C",PSBVALB="1",PSBADST'="",PSBFREQ<1 D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Invalid frequency received from order",PSBSCH) Q
96 ..I +PSBFREQ>0 I (PSBFREQ#1440'=0),(1440#PSBFREQ'=0) S PSBODD=1
97 ..I PSBODD,PSBADST'="" D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Administration Times on ODD SCHEDULE",PSBSCH) Q
98 ..I PSBADST'="" D
99 ...F PSBY=1:1:$L(PSBADST,"-") D
100 ....D:($P(PSBADST,"-",PSBY)'?2N)&($P(PSBADST,"-",PSBY)'?4N)
101 .....D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Invalid Admin times",PSBSCH)
102 ..I PSBSCHT="C",PSBOTYP="U" Q:'$$OKAY^PSBVDLU1(PSBOST,PSBODATE,PSBSCH,PSBONX,PSBOITX,PSBFREQ,)
103 ..I PSBSCHT="C",$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH),'$$OKAY^PSBVDLU1(PSBOST,PSBODATE,PSBSCH,PSBONX,PSBOITX,PSBFREQ) Q
104 ..I PSBSCHT="O" D Q:PSBGVN
105 ...S (PSBGVN,X,Y)=""
106 ...F S X=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X),-1) Q:'X D
107 ....F S Y=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X,Y),-1) Q:'Y D
108 .....I $P(^PSB(53.79,Y,.1),U)=PSBONX,$P(^PSB(53.79,Y,0),U,9)="G" S PSBGVN=1,(X,Y)=0
109 ..S PSBRMN=1
110 ..I PSBSCHT="O",PSBOST'=PSBOSP,PSBOSP<PSBOSTRT S PSBRMN=0
111 ..Q:'PSBRMN
112 ..I PSBOST>$$FMADD^XLFDT(PSBNOW,"","",+($$GET^XPAR("DIV","PSB ADMIN BEFORE"))) S ^TMP("PSBO",$J,DFN,PSBORD,PSBTYPE)="" Q
113 ..I PSBSCHT="OC" D Q:PSBGVN&('$$GET^XPAR("DIV","PSB ADMIN MULTIPLE ONCALL"))
114 ...S (PSBGVN,X,Y)=""
115 ...F S X=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X),-1) Q:'X D
116 ....F S Y=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X,Y),-1) Q:'Y D
117 .....I $P(^PSB(53.79,Y,.1),U)=PSBONX,$P(^PSB(53.79,Y,0),U,9)="G" S PSBGVN=1,(X,Y)=0
118 ..S PSBLGDT="",X=""
119 ..F S X=$O(^PSB(53.79,"AOIP",DFN,+PSBOIT,X),-1) Q:'X D Q:PSBLGDT
120 ...S PSBIEN=""
121 ...F S PSBIEN=$O(^PSB(53.79,"AOIP",DFN,+PSBOIT,X,PSBIEN),-1) Q:PSBIEN="" D Q:PSBLGDT
122 ....S:$P($G(^PSB(53.79,PSBIEN,0)),U,9)="G" PSBLGDT=X
123 ..S PSBADMIN="" K ^TMP("PSB",$J,"GETADMIN")
124 ..I PSBSCHT="C" D Q:PSBADMIN=""
125 ...S PSBX=PSBADST,PSBFLAG=1
126 ...D:PSBX=""
127 ....I PSBIVT="C",PSBCHEMT="A" S PSBX="0000",PSBFLAG=0
128 ....I PSBIVT="C",PSBISYR=0 S PSBX="0000",PSBFLAG=0
129 ....I PSBIVT="S",PSBISYR'=1 S PSBX="0000",PSBFLAG=0
130 ....I "HA"[PSBIVT S:PSBIVT]"" PSBX="0000",PSBFLAG=0
131 ...I ((PSBIVT="S")!(PSBIVT="C")),(PSBISYR=1) S:+($G(PSBX))=0 PSBX=""
132 ...I (PSBIVT="C"),(PSBCHEMT="P") S:+($G(PSBX))=0 PSBX=""
133 ...I PSBOTYP="U",PSBX="0000" S PSBX=""
134 ...I PSBIVT="P" S:+($G(PSBX))=0 PSBX=""
135 ...I PSBX="" S:($G(PSBFREQ)>29)!(PSBFREQ="D") PSBX=$$GETADMIN^PSBVDLU1(DFN,PSBONX,PSBOST,PSBFREQ,PSBODATE)
136 ...E S ^TMP("PSB",$J,"GETADMIN",0)=PSBX
137 ...D:PSBX'=""
138 ....F PSBXX=0:1 Q:'$D(^TMP("PSB",$J,"GETADMIN",PSBXX)) S PSBX=$G(^TMP("PSB",$J,"GETADMIN",PSBXX)) D
139 .....F PSBY=1:1:$L(PSBX,"-") D
140 ......S PSBAT=+(PSBODATE_"."_$P(PSBX,"-",PSBY))
141 ......I PSBFLAG Q:PSBAT<PSBOSTRT!(PSBAT>PSBOSTOP)
142 ......D VAL^PSBMLVAL(.PSBZ,DFN,PSBON,PSBOTYP,PSBAT)
143 ......I (PSBZ(0)<0)&(PSBCNT=1) S ^TMP("PSBO",$J,DFN,PSBORD,PSBTYPE,PSBAT)="" Q
144 ......I (PSBAT'["."),($G(PSBORD)["V") I (PSBOST<PSBOSTOP),(PSBOST'<PSBOSTRT) S ^TMP("PSBO",$J,DFN,PSBORD,PSBTYPE,PSBAT)="" Q
145 ......Q:+PSBZ(0)<0
146 ......I $G(PSBOST)'>$G(PSBAT) S PSBADMIN=PSBADMIN_$S(PSBADMIN]"":"-",1:"")_$P(PSBX,"-",PSBY)
147 ......E I ($P($G(PSBOST),".")'>$P($G(PSBAT),"."))&($P($G(PSBAT),".",2)="") S PSBADMIN=PSBADMIN_$S(PSBADMIN]"":"-",1:"")_$P(PSBX,"-",PSBY)
148 ...I +$G(PSBFREQ)>0,$G(PSBFREQ)<30,PSBADMIN'="0000" S PSBADMIN="Due every "_$G(PSBFREQ)_" minutes."
149 ..I $Y>(IOSL-(12+($L(PSBADMIN)/27))) W !?(IOM-36\2),"(Medications Continued on Next Page)",$$FTR^PSBODL1(),$$HDR()
150 ..I PSBSM S PSBSM=$S(PSBSMX:"H",1:"")_"SM"
151 ..E S PSBSM=""
152 ..W !,$J(PSBSM,3),?6,PSBTYPE,$E(PSBSCHT,1,4),?12 S PSBWFLAG=1
153 ..S X="",Y=0
154 ..D WRAPPUP^PSBODL1
155 .I '$G(PSBWFLAG) W !!,?10,"** NO SPECIFIED MEDICATIONS TO PRINT **"
156 .W $$BLANKS(),$$FTR^PSBODL1()
157 .S PSBORD=$O(^TMP("PSBO",$J,DFN,""),-1)
158 .I +$G(PSBORD)>0,$P(PSBRPT(.4),U,1),$D(^TMP("PSBO",$J,DFN,PSBORD)) D EN^PSBODL1
159 Q
160HDR() ;
161 D PT^PSBOHDR(DFN,.PSBHDR)
162 W !,"Self",?85,"Last",?100,"Start",?110,"Stop",?120,"Verifying"
163 W !,"Med",?6,"Sched",?14,"Medication",?50,"Dose",?78,"Route",?85,"Given",?100,"Date",?110,"Date",?120,"Rph/Rn"
164 W !,?100,"@Time",?110,"@Time"
165 W !,$TR($J("",IOM)," ","-")
166 Q ""
167BLANKS() ;
168 Q:'$P(PSBRPT(.2),U,5) ""
169 W !
170 D:$Y>(IOSL-26)
171 .W ?(IOM-42\2),"(Changes/Addendums to Orders on Next Page)"
172 .W $$FTR^PSBODL1(),$$HDR() ; New page - no room for blanks
173 I IOSL<100 F Q:$Y>(IOSL-26) W !
174 W ?(IOM-28\2),"Changes/Addendums to orders"
175 F X=1:1:4 D
176 .W !,$TR($J("",IOM)," ","-")
177 .W !!?3,"CON ___ PRN ___"
178 .W ?20,"Drug: ",$TR($J("",22)," ","_")
179 .W ?50,"Give: ",$TR($J("",42)," ","_")
180 .W ?100,"Start: _________ Stop: _________"
181 .W !?20,"Spec"
182 .W !?3,"OT ___ OC ___"
183 .W ?20,"Inst: ",$TR($J("",72)," ","_")
184 .W ?100,"Initials: ______ Date: _________"
185 W !,$TR($J("",IOM)," ","-")
186 Q ""
Note: See TracBrowser for help on using the repository browser.