source: FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBOCE.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 
1PSBOCE ;BIRMINGHAM/TEJ-Expired/DC'd/EXPIRING ORDERS 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 ;
5EN ;
6 N PSBX1X,RESULTS,RESULT,PSBFUTR
7 S PSBFUTR=$TR(PSBRPT(1),"~",U)
8 S (PSBOCRIT,PSBXFLG,PSBCFLG)="" ; Ord Status srch crit - "A"ctve, "D"C ed, "E"xpred"
9 S:$P(PSBFUTR,U,7) PSBOCRIT=PSBOCRIT_"Expired/DC'd" S:$P(PSBFUTR,U,8) PSBOCRIT=PSBOCRIT_"Expired/DC'd" S:$P(PSBFUTR,U,9) PSBOCRIT=PSBOCRIT_"Expiring Today"
10 S:$P(PSBFUTR,U,10) PSBOCRIT=PSBOCRIT_"Expiring Tomorrow"
11 S:$P(PSBFUTR,U,11) PSBXFLG=1
12 I $D(PSBRPT(.2)) I $P(PSBRPT(.2),U,8) S PSBCFLG=1
13 K PSBSRTBY,PSBCMT,PSBADM,PSBDATA,PSBOUTP,PSBLGD
14 S PSBSORT=1
15 D NOW^%DTC S (Y,PSBNOWX)=% D DD^%DT S PSBDTTM=Y
16 D GETPAR^PSBPAR("ALL","PSB ADMIN BEFORE")
17 S PSBB4=0 S:RESULTS(0)>0 PSBB4=+RESULTS(0)
18 D GETPAR^PSBPAR("ALL","PSB ADMIN AFTER")
19 S PSBAFT=0 S:RESULTS(0)>0 PSBAFT=+RESULTS(0)
20 K ^XTMP("PSBO",$J,"PSBLIST")
21 S (PSBPGNUM,PSBLNTOT,PSBTOT,PSBX1X)=""
22 K PSBLIST,PSBLIST2
23 S PSBXDFN=$P(PSBRPT(.1),U,2)
24 S PSBLIST(PSBXDFN)=""
25 S (PSBX1X,PSBTOT)=0
26 F S PSBX1X=$O(PSBLIST(PSBX1X)) Q:+PSBX1X=0 D
27 .D RPC^PSBCSUTL(.PSBAREA,PSBX1X)
28 .M PSBDATA=@PSBAREA
29 .S PSBX2X=1
30 .S (PSBLIST2("Expiring Tomorrow"),PSBLIST2("Expiring Today"),PSBLIST2("Expired/DC'd"),PSBLIST2(" * NO * "))=0
31 .F S PSBX2X=$O(PSBDATA(PSBX2X)) Q:+PSBX2X=0 D
32 ..S PSBDATA=PSBDATA(PSBX2X)
33 ..I $P(PSBDATA,U)="ORD" D Q
34 ...K PSBDRUGN
35 ...S PSBORDN=$P(PSBDATA,U,3)
36 ...S PSBTB=$P(PSBDATA,U,29) S PSBTB=$S(PSBTB=1:"UD",PSBTB=2:"IVPB",PSBTB=3:"IV",1:" * ERROR * ")
37 ...S PSBTB(PSBORDN,PSBTB)=""
38 ...S PSBSTS=$P(PSBDATA,U,23) S PSBSTS=$S((PSBSTS="A")&(($P(PSBDATA,U,27)>PSBNOWX)):"Active",PSBSTS="H":"On Hold",PSBSTS="D":"Discontinued",PSBSTS="DE":"Discontinued (Edit)",(PSBSTS="E")!($P(PSBDATA,U,27)'>PSBNOWX):"Expired",1:" * ERROR * ")
39 ...S PSBSTS(PSBORDN,PSBSTS)=""
40 ...S X2=$P(PSBDATA,U,27),X3=$P(PSBNOWX,".")
41 ...S PSBSTSX=$S((X2<PSBNOWX):"Expired/DC'd",(X3'>X2)&($$FMADD^XLFDT(X3,1)>X2):"Expiring Today",($$FMADD^XLFDT(X3,1)'>X2)&(X2'>$$FMADD^XLFDT(X3,2)):"Expiring Tomorrow",1:" * NO * ")
42 ...I PSBSTS["Discontinued" S PSBSTSX="Expired/DC'd"
43 ...S PSBLIST2(PSBSTSX,$P(PSBDATA,U,9),PSBORDN)="" S PSBLIST2(PSBSTSX)=PSBLIST2(PSBSTSX)+1
44 ...S:PSBOCRIT[PSBSTSX PSBTOT=PSBTOT+1
45 ...S PSBSCHTY=$P(PSBDATA,U,6)
46 ...S PSBSCHTY(PSBORDN,PSBSCHTY)=""
47 ...S PSBSCHD=$P(PSBDATA,U,7) I PSBSCHD="" S PSBSCHD=" "
48 ...S PSBSCHD(PSBORDN,PSBSCHD)=""
49 ...S PSBDOSR=$P(PSBDATA,U,10)_", "_$P(PSBDATA,U,11)
50 ...S PSBDOSR=$TR($E(PSBDOSR,1)," ")_$E(PSBDOSR,2,999)
51 ...S PSBDOSR(PSBORDN,PSBDOSR)="" K PSBOMDR(PSBORDN)
52 ...S PSBNXTX1=$$NEXTADM^PSBCSUTX(PSBX1X,PSBORDN)
53 ...I PSBSTS["Hold" S PSBNXTX2="Provider Hold"
54 ...I PSBSTS'["Hold" D
55 ....I PSBNOWX>$$FMADD^XLFDT(PSBNXTX1,,,PSBAFT) S PSBNXTX2="MISSED "_PSBNXTX1
56 ....E S PSBNXTX2="DUE "_PSBNXTX1
57 ...S PSBNXTX1=$$FMTDT^PSBOCE1(PSBNXTX1)
58 ...I ("^P^OC^O"[(U_PSBSCHTY))!(PSBTB="IV")!(PSBSTS["Discontinued")!(PSBSTS["Expired") S:PSBSTS'["Hold" PSBNXTX2=" "
59 ...S PSBNXTX(PSBORDN,PSBNXTX2)=""
60 ...; ** SPC INSTR **
61 ...S PSBX2X=PSBX2X+1
62 ...S PSBSI=$P(PSBDATA(PSBX2X),U,2)
63 ...I PSBSI]" " S PSBSI(PSBORDN,PSBSI)=""
64 ...S PSBOSTDT=$P(PSBDATA,U,22)
65 ...S PSBOSTDT(PSBORDN,PSBOSTDT)=""
66 ...S PSBOSPDT=$P(PSBDATA,U,27)
67 ...S PSBOSPDT(PSBORDN,PSBOSPDT)=""
68 ..I "^DD^ADD^SOL"[(U_$P(PSBDATA,U)) D Q
69 ...F I=PSBX2X:1 S PSBDATA1=PSBDATA(I) D Q:$D(PSBOMDR(PSBORDN))
70 ....I "^DD^ADD^SOL"[(U_$P(PSBDATA1,U)) S PSBX2X=I S PSBDRUGN=$G(PSBDRUGN,"")_$P(PSBDATA1,U,3)_", " Q
71 ....S $E(PSBDRUGN,$L(PSBDRUGN)-1)="" S PSBDRUGN(PSBORDN,$E(PSBDRUGN,1,250))=PSBDRUGN
72 ....S PSBOMDR(PSBORDN,$E((PSBDRUGN_"; "_PSBDOSR),1,250))=PSBDRUGN_"; "_PSBDOSR
73 ..I $P(PSBDATA,U)="END" Q
74 ..I $P(PSBDATA(PSBX2X+1),U)="ORF" D Q
75 ...S PSBX2X=PSBX2X+1 S PSBDATA=PSBDATA(PSBX2X)
76 ...S:$P(PSBDATA,U,2)]"" PSBFLGD(PSBORDN,$P(PSBDATA,U,3)_" - "_$P(PSBDATA,U,4))=""
77 ..I ($P(PSBDATA,U)="ADM")&($P(PSBDATA,U,4)]"") D
78 ...S PSBXID=$P(PSBDATA,U,6)_U_$P(PSBDATA,U,4),PSBADM(PSBORDN,(-1*($P(PSBDATA,U,6))),PSBXID)=PSBDATA
79 ...I $O(PSBSCHTY(PSBORDN,""))="P" S PSBPRNR(PSBORDN,$P(PSBDATA,U,4))=$P(PSBDATA,U,9)
80 ...I $P(PSBDATA,U,3)]"" S PSBBID(PSBORDN,$P(PSBDATA,U,4))=$P(PSBDATA,U,3)
81 ...S:PSBXFLG PSBLGD(PSBORDN,"X","INITIALS",$P(PSBDATA,U,8))=""
82 ...K PSBDATA(PSBX2X)
83 ...I ($P(PSBDATA(PSBX2X+1),U)="CMT") F S PSBDATA=PSBDATA(PSBX2X+1) Q:($P(PSBDATA,U)'="CMT") D
84 ....S PSBX2X=PSBX2X+1
85 ....S PSBDATA=PSBDATA(PSBX2X)
86 ....K PSBDATA(PSBX2X)
87 ....S:$P(PSBDATA,U,3)]"" PSBPRNEF(PSBORDN,$P(PSBXID,U,2))=$P(PSBDATA,U,3)
88 ....I 'PSBCFLG S PSBDATA=PSBDATA(PSBX2X+1) Q
89 ....I $P(PSBDATA,U,2)'="" D
90 .....S PSBLGD(PSBORDN,"C","INITIALS",$P(PSBDATA,U,4))=""
91 .....S PSBCMT(PSBORDN,$P(PSBXID,U,2),(-1*$P(PSBDATA,U,6)))=PSBDATA
92 I '$D(PSBLIST2) K PSBLIST,^XTMP("PSBO",$J,"PSBLIST")
93 D CREATHDR
94 D SUBHDR
95 D BLDRPT
96 D WRTRPT
97 Q
98BLDRPT ; Buld RPT DATA
99 S X0="" K PSBLIST2(" * NO * "),PSBL2ULN
100 S PSBTOPHD=PSBLNTOT-2
101 I '$D(PSBLIST2) D Q
102 .S PSBOUTP(0,PSBLNTOT)="W !!,""<<<< NO ORDERS TO DISPLAY >>>>"",!!"
103 S PSBMORE=5 F PSBX1X="Expired/DC'd","Expiring Today","Expiring Tomorrow" D
104 .I PSBX1X'=" * ERROR * " S PSBSUM=PSBX1X_" ["_PSBLIST2(PSBX1X)_$S(PSBLIST2(PSBX1X)=1:" Order",1:" Orders")_"]" S PSBOUTP($$PGTOT,PSBLNTOT)="W !!,"""_PSBSUM_""""
105 .Q:PSBLIST2(PSBX1X)=0
106 .Q:PSBOCRIT'[PSBX1X
107 .S:$L(PSBSUM)>$G(PSBL2ULN,0) PSBL2ULN=$L(PSBSUM)
108 .S PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,$TR($J("""",PSBL2ULN),"" "",""=""),!"
109 .S PSBOUTP($$PGTOT,PSBLNTOT)="W !"
110 .K PSBDATA
111 .S X0="",PSBTOT1=0
112 .F S X0=$O(PSBLIST2(PSBX1X,X0)) Q:X0="" F S PSBX2X=$O(PSBLIST2(PSBX1X,X0,PSBX2X)) Q:PSBX2X="" D
113 ..M PSBLGD("INITIALS")=PSBLGD(PSBX2X,"X","INITIALS") M PSBLGD("INITIALS")=PSBLGD(PSBX2X,"C","INITIALS")
114 ..S PSBDATA(1,1)=$O(PSBTB(PSBX2X,""))
115 ..S PSBDATA(1,2)=$O(PSBSTS(PSBX2X,""))
116 ..S PSBDATA(1,3)=$O(PSBSCHTY(PSBX2X,""))
117 ..S Y0=$O(PSBOMDR(PSBX2X,"")) I Y0]"" S PSBDATA(1,4)="("_X0_")",PSBDATA(1,4,0)=PSBOMDR(PSBX2X,Y0)
118 ..S PSBDATA(1,5)=$O(PSBSCHD(PSBX2X,""))
119 ..S PSBDATA(1,6)=$O(PSBNXTX(PSBX2X,""))
120 ..S:PSBDATA(1,6)'["Hold" $P(PSBDATA(1,6)," ",2)=$$FMTDT^PSBOCE1($P(PSBDATA(1,6)," ",2))
121 ..S PSBDATA(1,7)=$$FMTDT^PSBOCE1($O(PSBOSTDT(PSBX2X,"")))
122 ..S PSBDATA(1,8)=$$FMTDT^PSBOCE1($E($O(PSBOSPDT(PSBX2X,"")),1,12))
123 ..S PSBSIDAT(1)=$O(PSBSI(PSBX2X,""))
124 ..S PSBTOT1=PSBTOT1+1
125 ..K PSBDATA(2),PSBDATA(3),PSBSILN
126 ..D BUILDLN^PSBOCE1,SIOPI^PSBOCM(.PSBSIDAT,PSBTAB8,$S(PSBX2X["V":"Other Print Info:",1:""))
127 ..I $D(PSBRPLN) S PSBMORE=$O(PSBRPLN(""),-1)+6 I $D(PSBSILN) S PSBMORE=PSBMORE+$O(PSBSILN(""),-1)
128 ..K PSB1 I $D(PSBFLGD(PSBX2X)) S PSB="" F S PSB=$O(PSBFLGD(PSBX2X,PSB)) Q:PSB="" I ($P(PSB,":")'="NOX")&($P(PSB,":")'="STAT") S PSB1=$G(PSB1,"")_PSB
129 ..S PSBCNT=PSBTOT1_" "_$G(PSB1,"")
130 ..S PSBOUTP($$PGTOT,PSBLNTOT)="W """_PSBCNT_""""
131 ..S I="" F S I=$O(PSBRPLN(I)) Q:+I=0 D
132 ...S PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBRPLN(I)_""""
133 ..S I="" F S I=$O(PSBSILN(I)) Q:+I=0 D
134 ...S PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBSILN(I)_""""
135 ..S PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,$TR($J("""",PSBTAB8),"" "",""-""),!"
136 ..K PSBRPLN,PSBDATA,PSBSILN
137 D:+PSBTOT>0 LGD^PSBOCM
138 Q
139WRTRPT ; writ
140 I $O(PSBOUTP(""),-1)<1 D Q
141 .X PSBOUTP($O(PSBOUTP(""),-1),21)
142 .D FTR
143 S PSBPGNUM=1
144 S PSBZ="" F S PSBZ=$O(PSBOUTP(PSBZ)) Q:PSBZ="" D
145 .I PSBPGNUM'=PSBZ D FTR S PSBPGNUM=PSBZ D HDR,SUBHDR
146 .S PSBX2X="" F S PSBX2X=$O(PSBOUTP(PSBZ,PSBX2X)) Q:PSBX2X="" D
147 ..X PSBOUTP(PSBZ,PSBX2X)
148 D FTR
149 K ^XTMP("PSBO",$J,"PSBLIST"),PSBOUTP
150 Q
151HDR ; Hder
152 W:$Y>1 @IOF
153 W:$X>1 !
154 S PSBRPNM="BCMA COVERSHEET EXPIRED/DC'd/EXPIRING ORDERS REPORT"
155 D:$P(PSBRPT(.1),U,1)="P"
156 .S PSBHDR(0)=PSBRPNM
157 .S PSBHDR(1)="Order Status(es): --"
158 .F Y=7,8,9,10 I $P(PSBFUTR,U,Y) S $P(PSBHDR(1),": ",2)=$P(PSBHDR(1),": ",2)_$S(PSBHDR(1)["--":"",1:"/ ")_$P("^^^^^^Expired^DC'd^Expiring Today^Expiring Tomorrow^^^^^^^^",U,Y)_" " S PSBHDR(1)=$TR(PSBHDR(1),"-","")
159 .I $P(PSBFUTR,U,11) S PSBHDR(2)="Include Action(s)"_$S(PSBCFLG:" & Comments/Reasons",1:"")
160 .D PT^PSBOHDR(PSBXDFN,.PSBHDR)
161 Q
162SUBHDR ;
163 N PSBAL S PSBAL=$O(PSBHDR("ALERGY",""),-1) S PSBAL=$S((PSBAL/12)>(PSBAL\12):(PSBAL\12)+1,1:(PSBAL\12))
164 N PSBRE S PSBRE=$O(PSBHDR("REAC",""),-1) S PSBRE=$S((PSBRE/12)>(PSBRE\12):(PSBRE\12)+1,1:(PSBRE\12))
165 S PSBLNTOT=$O(PSBHDR(""),-1)+9+PSBAL+PSBRE+1
166 I $G(PSBPGNUM,0)=1 W !,?(PSBTAB8-($L("Total Orders reported: "_+PSBTOT))),"Total Orders reported: "_+PSBTOT,! S PSBLNTOT=PSBLNTOT+2
167 W !,$TR($J("",PSBTAB8)," ","_") S PSBLNTOT=PSBLNTOT+1
168 W !,$G(PSBHD1,"") S PSBLNTOT=PSBLNTOT+1
169 W !,$G(PSBHD2,"") S PSBLNTOT=PSBLNTOT+1
170 W !,$TR($J("",PSBTAB8)," ","="),! S PSBLNTOT=PSBLNTOT+2
171 I $D(NOTE(PSBPGNUM)) W NOTE(PSBPGNUM),!! S PSBLNTOT=PSBLNTOT+2
172 Q
173FTR ; Footr
174 D PTFTR^PSBOHDR()
175 S PSBPG="Page: "_PSBPGNUM_" of "_$S($O(PSBOUTP(""),-1)=0:1,1:$O(PSBOUTP(""),-1))
176 S PSBPGRM=PSBTAB8-($L(PSBPG))
177 W !,PSBRPNM," ",?(PSBPGRM-($L(PSBDTTM)+3)),PSBDTTM_" "_PSBPG
178 Q
179PGTOT(X) ;mnt PAGE Number
180 I (PSBLNTOT+PSBMORE)>(IOSL) D PGC^PSBOCE1
181 I $G(X,1) S PSBLNTOT=PSBLNTOT+$G(X,1),PSBMORE=PSBMORE-$G(X,1)
182 Q PSBPGNUM
183CREATHDR ;
184 K PSBHD1,PSBHD2
185 I IOM'<132 S PSBMORE=4,PSBHD1=$P($T(HD132A),"~",2),PSBHD2=$P($T(HD132B),";",2),PSBBLANK=$P($T(H132BLK),";",2)
186 E S PSBHD1="THIS REPORT SUPPORTS >131 CHAR./LINE PRINT FORMATS ONLY" K PSBLIST2 Q
187 ; tabs
188 S PSBTAB0=1 F PSBI=0:1:($L(PSBHD1,"|")-1) S:PSBI>0 @("PSBTAB"_PSBI)=($F(PSBHD1,"|",@("PSBTAB"_(PSBI-1))+1))-1
189 S PSBPGNUM=1
190 D HDR
191 Q
192HD132A ;~ VDL | Status |Type| Medication; Dosage, Route | Schedule | Next | Order Start | Order Stop |
193 Q
194HD132B ; Tab | | | | | Action | Date | Date |
195 Q
196H132BLK ;; | | | | | | | |
197 Q
Note: See TracBrowser for help on using the repository browser.