source: WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBOCM.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: 9.3 KB
Line 
1PSBOCM ;BIRMINGHAM/TEJ-COVERSHEET MEDICATION OVERVIEW 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 4/10090
7 ; File 200/10060
8EN ;
9 N PSBX1X,RESULTS,RESULT,PSBFUTR
10 S PSBFUTR=$TR(PSBRPT(1),"~","^")
11 S (PSBOCRIT,PSBXFLG,PSBCFLG)="" ; Order Status search criteria - "A"ctive, "D"C ed, "E"xpired"
12 S:$P(PSBFUTR,U,7) PSBOCRIT=PSBOCRIT_"D" S:$P(PSBFUTR,U,8) PSBOCRIT=PSBOCRIT_"E" S:$P(PSBFUTR,U,5) PSBOCRIT=PSBOCRIT_"A"
13 S:$P(PSBFUTR,U,4) PSBOCRIT=PSBOCRIT_"F"
14 S:$P(PSBFUTR,U,11) PSBXFLG=1
15 I $D(PSBRPT(.2)) I $P(PSBRPT(.2),U,8) S PSBCFLG=1
16 K PSBSRTBY,PSBCMT,PSBADM,PSBDATA,PSBOUTP,PSBLGD,PSBHDR,PSBSTS
17 S PSBSORT=1
18 D NOW^%DTC S (Y,PSBNOWX)=% D DD^%DT S PSBDTTM=$E(Y,1,18)
19 D GETPAR^PSBPAR("ALL","PSB ADMIN BEFORE")
20 S PSBB4=0 S:RESULTS(0)>0 PSBB4=+RESULTS(0)
21 D GETPAR^PSBPAR("ALL","PSB ADMIN AFTER")
22 S PSBAFT=0 S:RESULTS(0)>0 PSBAFT=+RESULTS(0)
23 K ^XTMP("PSBO",$J,"PSBLIST")
24 S (PSBPGNUM,PSBLNTOT,PSBTOT,PSBX1X)=""
25 K PSBLIST,PSBLIST2
26 S PSBXDFN=$P(PSBRPT(.1),U,2)
27 S PSBLIST(PSBXDFN)=""
28 S (PSBX1X,PSBTOT)=0
29 F S PSBX1X=$O(PSBLIST(PSBX1X)) Q:+PSBX1X=0 D
30 .D RPC^PSBCSUTL(.PSBAREA,PSBX1X)
31 .M PSBDATA=@PSBAREA
32 .S PSBX2X=1
33 .S PSBLIST2("ACTIVE")=0,PSBLIST2("FUTURE")=0,PSBLIST2("EXPIRED/DC'd")=0,PSBLIST2(" * ERROR * ")=0
34 .F S PSBX2X=$O(PSBDATA(PSBX2X)) Q:+PSBX2X=0 D
35 ..S PSBDATA=PSBDATA(PSBX2X)
36 ..I $P(PSBDATA,U)="ORD" D Q
37 ...K PSBDRUGN
38 ...S PSBORDN=$P(PSBDATA,U,3)
39 ...S PSBTB=$P(PSBDATA,U,29) S PSBTB=$S(PSBTB=1:"UD",PSBTB=2:"IVPB",PSBTB=3:"IV",1:" * ERROR * ")
40 ...S PSBTB(PSBORDN,PSBTB)=""
41 ...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 * ")
42 ...S PSBSTS(PSBORDN,PSBSTS)=""
43 ...S PSBSTSX=$S($P(PSBDATA,U,27)'>PSBNOWX:"EXPIRED/DC'd",$$FMADD^XLFDT($P(PSBDATA,U,22),,,-PSBB4)'>PSBNOWX:"ACTIVE",$P(PSBDATA,U,22)>$$FMADD^XLFDT(PSBNOWX,,,PSBB4):"FUTURE",1:" * ERROR * ")
44 ...S PSBLIST2(PSBSTSX,$P(PSBDATA,U,9),PSBORDN)="" S PSBLIST2(PSBSTSX)=PSBLIST2(PSBSTSX)+1
45 ...S:PSBOCRIT[$E(PSBSTSX,1) PSBTOT=PSBTOT+1
46 ...S PSBSCHTY=$P(PSBDATA,U,6)
47 ...I PSBTB="IV" S PSBSCHTY=" "
48 ...S PSBSCHTY(PSBORDN,PSBSCHTY)=""
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 PSBSCHD=$P(PSBDATA,U,7) I PSBSCHD="" S PSBSCHD=" "
53 ...S PSBSCHD(PSBORDN,PSBSCHD)=""
54 ...S PSBNXTX1=$$NEXTADM^PSBCSUTX(PSBX1X,PSBORDN)
55 ...I PSBSTS["Hold" S PSBNXTX2="Provider Hold"
56 ...I PSBSTS'["Hold",(PSBNXTX1]"") D
57 ....I PSBNOWX>$$FMADD^XLFDT(PSBNXTX1,,,PSBAFT) S PSBNXTX2="MISSED "_PSBNXTX1
58 ....E S:+PSBNXTX1>0 PSBNXTX2="DUE "_PSBNXTX1
59 ...S PSBNXTX1=$$FMTDT^PSBOCE1(PSBNXTX1)
60 ...I ("^P^OC^O"[("^"_PSBSCHTY))!(PSBTB="IV")!(PSBSTS["Discontinued")!(PSBSTS["Expired") S:PSBSTS'["Hold" PSBNXTX2=" "
61 ...S PSBNXTX(PSBORDN,$G(PSBNXTX2," "))=""
62 ...; ** SPECIAL INSTRUCTIONS **
63 ...S PSBX2X=PSBX2X+1
64 ...S PSBSI=$P(PSBDATA(PSBX2X),U,2)
65 ...I PSBSI]" " S PSBSI(PSBORDN,PSBSI)=""
66 ...S PSBOSTDT=$P(PSBDATA,U,22)
67 ...S PSBOSTDT(PSBORDN,PSBOSTDT)=""
68 ...S PSBOSPDT=$P(PSBDATA,U,27)
69 ...S PSBOSPDT(PSBORDN,PSBOSPDT)=""
70 ..I "^DD^ADD^SOL"[(U_$P(PSBDATA(PSBX2X),U)) D Q
71 ...F I=PSBX2X:1 S PSBDATA1=PSBDATA(I) D Q:$D(PSBOMDR(PSBORDN))
72 ....I "^DD^ADD^SOL"[(U_$P(PSBDATA1,U)) S PSBX2X=I S PSBDRUGN=$G(PSBDRUGN,"")_$P(PSBDATA1,U,3)_", " Q
73 ....S $E(PSBDRUGN,$L(PSBDRUGN)-1)="" S PSBDRUGN(PSBORDN,$E(PSBDRUGN,1,250))=PSBDRUGN
74 ....S PSBOMDR(PSBORDN,$E((PSBDRUGN_"; "_PSBDOSR),1,250))=PSBDRUGN_"; "_PSBDOSR
75 ..I $P(PSBDATA,U)="END" Q
76 ..I $P(PSBDATA(PSBX2X),U)="ORF" D Q
77 ...S PSBDATA=PSBDATA(PSBX2X)
78 ...S:$P(PSBDATA,U,2)]"" PSBFLGD(PSBORDN,$P(PSBDATA,U,3)_" - "_$P(PSBDATA,U,4))=""
79 ..I ($P(PSBDATA,U)="ADM")&($P(PSBDATA,U,4)]"") D
80 ...S PSBXID=$P(PSBDATA,U,6)_U_$P(PSBDATA,U,4),PSBADM(PSBORDN,(-1*($P(PSBDATA,U,6))),PSBXID)=PSBDATA
81 ...S PSBTEST="" F S PSBTEST=$O(PSBFLGD(PSBORDN,PSBTEST)) Q:PSBTEST="" I $P(PSBTEST,":")="NOX" K PSBFLGD(PSBORDN,PSBTEST) Q
82 ...I $O(PSBSCHTY(PSBORDN,""))="P" S PSBPRNR(PSBORDN,$P(PSBDATA,U,4))=$P(PSBDATA,U,9)
83 ...I $P(PSBDATA,U,3)]"" S PSBBID(PSBORDN,$P(PSBDATA,U,4))=$P(PSBDATA,U,3)
84 ...S:PSBXFLG PSBLGD(PSBORDN,"X","INITIALS",$P(PSBDATA,U,8))=""
85 ...K PSBDATA(PSBX2X)
86 ...I ($P(PSBDATA(PSBX2X+1),U)="CMT") F S PSBDATA=PSBDATA(PSBX2X+1) Q:($P(PSBDATA,U)'="CMT") D
87 ....S PSBX2X=PSBX2X+1
88 ....S PSBDATA=PSBDATA(PSBX2X)
89 ....K PSBDATA(PSBX2X)
90 ....S:$P(PSBDATA,U,3)]"" PSBPRNEF(PSBORDN,$P(PSBXID,U,2))=$P(PSBDATA,U,3)
91 ....I 'PSBCFLG S PSBDATA=PSBDATA(PSBX2X+1) Q
92 ....I $P(PSBDATA,U,2)'="" D
93 .....S PSBLGD(PSBORDN,"C","INITIALS",$P(PSBDATA,U,4))=""
94 .....S PSBCMT(PSBORDN,$P(PSBXID,U,2),(-1*$P(PSBDATA,U,6)))=PSBDATA
95 I +PSBTOT=0 K PSBLIST,^XTMP("PSBO",$J,"PSBLIST")
96 D CREATHDR^PSBOCM1
97 D SUBHDR^PSBOCE
98 D BLDRPT
99 D WRTRPT^PSBOCM1
100 Q
101BLDRPT ; Buld REPORT DATA
102 S PSBTOPHD=PSBLNTOT-2
103 K PSBL2ULN
104 I '$D(PSBLIST2) D Q
105 .S PSBOUTP(0,PSBLNTOT)="W !!,""<<<< NO ORDERS TO DISPLAY >>>>"",!!"
106 S PSBMORE=5 F PSBX1X="ACTIVE","FUTURE","EXPIRED/DC'd"," * ERROR * " D
107 .I PSBX1X'=" * ERROR * " S PSBSUM=PSBX1X_" ["_PSBLIST2(PSBX1X)_$S(PSBLIST2(PSBX1X)=1:" Order",1:" Orders")_"]" S PSBOUTP($$PGTOT,PSBLNTOT)="W !!,"""_PSBSUM_""""
108 .Q:PSBLIST2(PSBX1X)=0
109 .Q:PSBOCRIT'[$E(PSBX1X,1)
110 .S:$L(PSBSUM)>$G(PSBL2ULN,0) PSBL2ULN=$L(PSBSUM)
111 .S PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,$TR($J("""",PSBL2ULN),"" "",""=""),!"
112 .S PSBOUTP($$PGTOT,PSBLNTOT)="W !"
113 .K PSBDATA
114 .S X0="",PSBTOT1=0
115 .F S X0=$O(PSBLIST2(PSBX1X,X0)) Q:X0="" S PSBX2X="" F S PSBX2X=$O(PSBLIST2(PSBX1X,X0,PSBX2X)) Q:PSBX2X="" D
116 ..M PSBLGD("INITIALS")=PSBLGD(PSBX2X,"X","INITIALS") M PSBLGD("INITIALS")=PSBLGD(PSBX2X,"C","INITIALS")
117 ..S PSBDATA(1,1)=$O(PSBTB(PSBX2X,""))
118 ..S PSBDATA(1,2)=$O(PSBSTS(PSBX2X,""))
119 ..S PSBDATA(1,3)=$O(PSBSCHTY(PSBX2X,""))
120 ..S Y0=$O(PSBOMDR(PSBX2X,"")) I Y0]"" S PSBDATA(1,4)="("_X0_")",PSBDATA(1,4,0)=PSBOMDR(PSBX2X,Y0)
121 ..S PSBDATA(1,5)=$O(PSBSCHD(PSBX2X,""))
122 ..S PSBDATA(1,6)=$O(PSBNXTX(PSBX2X,""))
123 ..S:PSBDATA(1,6)'["Hold" $P(PSBDATA(1,6)," ",2)=$$FMTDT^PSBOCE1($P(PSBDATA(1,6)," ",2))
124 ..S PSBDATA(1,7)=$$FMTDT^PSBOCE1($O(PSBOSTDT(PSBX2X,"")))
125 ..S PSBDATA(1,8)=$$FMTDT^PSBOCE1($E($O(PSBOSPDT(PSBX2X,"")),1,12))
126 ..S PSBSIDAT(1)=$O(PSBSI(PSBX2X,""))
127 ..S PSBTOT1=PSBTOT1+1
128 ..K PSBDATA(2),PSBDATA(3),PSBSILN
129 ..D BUILDLN^PSBOCM1,SIOPI(.PSBSIDAT,PSBTAB8,$S(PSBX2X["V":"Other Print Info:",1:""))
130 ..I $D(PSBRPLN) S PSBMORE=$O(PSBRPLN(""),-1)+6 I $D(PSBSILN) S PSBMORE=PSBMORE+$O(PSBSILN(""),-1)
131 ..K PSB1,X 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
132 ..S PSBCNT=PSBTOT1_" "_$G(PSB1,"")
133 ..S PSBOUTP($$PGTOT,PSBLNTOT)="W """_PSBCNT_""""
134 ..S I="" F S I=$O(PSBRPLN(I)) Q:+I=0 D
135 ...S PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBRPLN(I)_""""
136 ..S I="" F S I=$O(PSBSILN(I)) Q:+I=0 D
137 ...S PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBSILN(I)_""""
138 ..S PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,$TR($J("""",PSBTAB8),"" "",""-""),!"
139 ..K PSBRPLN,PSBDATA,PSBSILN
140 D:+PSBTOT>0 LGD
141 Q
142PGTOT(X) ;mnt PAGE Number
143 I (PSBLNTOT+PSBMORE)>(IOSL) D PGC^PSBOCE1
144 I $G(X,1) S PSBLNTOT=PSBLNTOT+$G(X,1),PSBMORE=PSBMORE-$G(X,1)
145 Q PSBPGNUM
146SIOPI(PSBXSI,TAB,Y) ;
147 Q:$G(PSBXSI(1))']""
148 I $G(Y,"")']"" S Y="Special Instructions: "
149 S PSBXSI(1)=" "_Y_PSBXSI(1)
150 N X
151 K J,TXT1,TXT2 S J(0)=""
152 S J=($O(J(""),-1)+1) S PSBSILN(J)="",J(J)="" S J=($O(J(""),-1)+1)
153 F X=1:1 Q:'$D(PSBXSI(X)) D
154 .S TXT1=PSBXSI(X)
155 .I ($L(TXT1)>0),$F(TXT1,"""")>1 D
156 ..S TXT1=$TR(TXT1,"""","^")
157 ..I $L(TXT1)+5'<TAB S TXT2=$E(TXT1,TAB-9,999),TXT1=$E(TXT1,1,TAB-10)
158 ..I $L(TXT1,"^")>1 F Y=1:1:$L(TXT1,"^")-1 S $P(TXT1,"^",Y)=$P(TXT1,"^",Y)_""""
159 ..I $D(TXT2) I $L(TXT2,"^")>1 F X=1:1:$L(TXT2,"^")-1 S $P(TXT2,"^",X)=$P(TXT2,"^",X)_""""
160 ..S TXT1=$TR(TXT1,"^","""") I $D(TXT2) S TXT2=$TR(TXT2,"^","""")
161 .S $E(PSBSILN(J),5,999)=TXT1,J(J)="",J=J+1
162 .I $D(TXT2) S $E(PSBSILN(J),5,999)=TXT2,J(J)="",J=J+1
163 S $E(PSBSILN(J),3,999)=" ",J(J)="",J=J+1
164 Q
165LGD ; Create Report's Legend
166 K PSBLGDO
167 S PSBLGD("ORDER TYPES","C")="Continuous"
168 S PSBLGD("ORDER TYPES","O")="One Time"
169 S PSBLGD("ORDER TYPES","OC")="On Call"
170 S PSBLGD("ORDER TYPES","P")="PRN"
171 S PSB=0 F S PSB=$O(PSBLGD("INITIALS",PSB)) Q:+PSB=0 D
172 .S PSBINIT=$$GET1^DIQ(200,PSB_",","INITIAL"),PSBLGD("INITIALS",$S(PSBINIT']" ":"*n/a*",1:PSBINIT))=$$GET1^DIQ(200,PSB_",","NAME")
173 .K PSBLGD("INITIALS",PSB)
174 S PSBPGNUM=$O(PSBOUTP(""),-1),PSBLGDO(0)="REPORT LEGEND"
175 S PSBLGDO(1)=""
176 S PSBLGDO(2)=$S($G(PSBNO,0):"",1:"SCHEDULE TYPES")
177 S PSBLGDO(3)=""
178 I '$G(PSBNO,0) S X1="",X2=3 F S X1=$O(PSBLGD("ORDER TYPES",X1)) Q:X1="" S X2=X2+1,PSBLGDO(X2)=X1,$E(PSBLGDO(X2),5)="- "_PSBLGD("ORDER TYPES",X1)
179 I $D(PSBLGD("INITIALS")) S $E(PSBLGDO(2),35)="INITIALS" S X1="",X2=3 F S X1=$O(PSBLGD("INITIALS",X1)) Q:X1="" S X2=X2+1,$E(PSBLGDO(X2),35)=X1,$E(PSBLGDO(X2),40)="- "_PSBLGD("INITIALS",X1)
180 S (PSBMORE,X0)=10+($O(PSBLGDO(""),-1))
181 I (PSBLNTOT+PSBMORE)'<IOSL S PSBLNTOT=PSBTOPHD-2,PSBPGNUM=PSBPGNUM+1
182 I IOSL<1000 S X2=PSBLNTOT F Q:X2'<(IOSL-(X0+3)) S PSBOUTP($$PGTOT,PSBLNTOT)="W !",X2=X2+1
183 S PSBMORE=X0
184 S PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,"""_$TR($J("",IOM)," ","=")_""",!"
185 F X1=0:1 Q:'$D(PSBLGDO(X1)) S PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_$G(PSBLGDO(X1)," ")_""""
186 S PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,"""_$TR($J("",IOM)," ","=")_""",!"
187 Q
Note: See TracBrowser for help on using the repository browser.