source: FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBPWRD.m@ 952

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

initial load of FOIAVistA 6/30/08 version

File size: 6.6 KB
Line 
1ALPBPWRD ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCMA BCBU REPORT FOR A SELECTED WARD ;01/01/03
2 ;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ; NOTE: this routine is designed for hard-copy output.
6 ; Output is formatted for 132-column printing.
7 ;
8 F D Q:$D(DIRUT)
9 .W !,"Inpatient Pharmacy Orders for a selected ward"
10 .S DIR(0)="FAO^2:10"
11 .S DIR("A")="Select WARD: "
12 .S DIR("?")="^D WARDLIST^ALPBUTL(""C"")"
13 .D ^DIR K DIR
14 .I $D(DIRUT) Q
15 .D WARDSEL^ALPBUTL(Y,.ALPBSEL)
16 .I +$G(ALPBSEL(0))=0 D Q
17 ..W $C(7)
18 ..W " ??"
19 ..D WARDLIST^ALPBUTL("C")
20 ..K ALPBSEL
21 .I +$G(ALPBSEL(0))=1 D
22 ..S ALPBWARD=ALPBSEL(1)
23 ..W " ",ALPBWARD
24 ..K ALPBSEL
25 .I +$G(ALPBSEL(0))>1 D I $D(DIRUT) K DIRUT,DTOUT,X,Y Q
26 ..S ALPBX=0
27 ..F S ALPBX=$O(ALPBSEL(ALPBX)) Q:'ALPBX W !?2,$J(ALPBX,2)," ",ALPBSEL(ALPBX)
28 ..K ALPBX
29 ..S DIR(0)="NA^1:"_ALPBSEL(0)
30 ..S DIR("A")="Select Ward from the list (1-"_ALPBSEL(0)_"): "
31 ..W ! D ^DIR K DIR
32 ..I $D(DIRUT) K ALPBSEL Q
33 ..S ALPBWARD=ALPBSEL(+Y)
34 ..K ALPBSEL
35 .;
36 .; get all or just current orders?...
37 .S DIR(0)="SA^A:ALL;C:CURRENT"
38 .S DIR("A")="Report [A]LL or [C]URRENT orders? "
39 .S DIR("B")="CURRENT"
40 .S DIR("?")="[A]LL=all orders in the file, [C]URRENT=orders not yet expired."
41 .W ! D ^DIR K DIR
42 .I $D(DIRUT) K ALPBWARD,DIRUT,DTOUT,X,Y Q
43 .S ALPBOTYP=Y
44 .;
45 .;SORT BY NAME OR ROOM/BED added 6/23/05
46 .S DIR(0)="SA^N:Name;R:Room/Bed"
47 .S DIR("A")="Sort Patients by [N]ame or [R]oom/Bed? "
48 .S DIR("B")="Room/bed"
49 .S DIR("?")="Sort by [N]ame or [R]oom Bed"
50 .W ! D ^DIR K DIR
51 .I $D(DIRUT) K ALPBWARD,DIRUT,DTOUT,X,Y Q
52 .S ALPBSORT=Y
53 .;
54 .; print how many days MAR?...
55 .S DIR(0)="NA^1:7"
56 .S DIR("A")="Print how many days MAR? "
57 .S DIR("B")=$$DEFDAYS^ALPBUTL()
58 .S DIR("?")="The default is shown; you may enter 3 or 7."
59 .W ! D ^DIR K DIR
60 .I $D(DIRUT) K ALPBOTYP,DIRUT,DTOUT,X,Y Q
61 .S ALPBDAYS=+Y
62 .;
63 .; BCMA Med Log info for how many ?...
64 .S DIR(0)="NA^1:99"
65 .S DIR("B")=$$DEFML^ALPBUTL3()
66 .S DIR("A")="Select how many BCMA Medication Log history: "
67 .S DIR("A",1)=" "
68 .S DIR("?",1)="Select a number of BCMA Medication log entries"
69 .S DIR("?",2)="for each of the patient's orders"
70 .S DIR("?")="They are listed by the most current entry first"
71 .D ^DIR K DIR
72 .I $D(DIRUT) K ALPBOTYP,ALPBWARD,DIRUT,DTOUT,X,Y Q
73 .S ALPBMLOG=Y
74 .;
75 .S %ZIS="Q"
76 .S %ZIS("B")=$$DEFPRT^ALPBUTL()
77 .I %ZIS("B")="" K %ZIS("B")
78 .W ! D ^%ZIS K %ZIS
79 .I POP D Q
80 ..W $C(7)
81 ..K ALPBMLOG,ALPBOTYP,ALPBWARD,POP
82 .;
83 .; output not queued...
84 .I '$D(IO("Q")) D
85 ..U IO
86 ..D DQ
87 ..I IO'=IO(0) D ^%ZISC
88 .;
89 .; set up the Task...
90 .I $D(IO("Q")) D
91 ..S ZTRTN="DQ^ALPBPWRD"
92 ..S ZTDESC="PSB INPT PHARM ORDERS FOR WARD "_ALPBWARD
93 ..S ZTSAVE("ALPBDAYS")=""
94 ..S ZTSAVE("ALPBWARD")=""
95 ..S ZTSAVE("ALPBMLOG")=""
96 ..S ZTSAVE("ALPBOTYP")=""
97 ..S ZTSAVE("ALPBSORT")=""
98 ..S ZTIO=ION
99 ..D ^%ZTLOAD
100 ..D HOME^%ZIS
101 ..W !,$S($G(ZTSK):"Task number "_ZTSK_" queued.",1:"ERROR -- NOT QUEUED!")
102 ..K IO("Q"),ZTSK
103 .K ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBWARD
104 K DIRUT,DTOUT,X,Y
105 Q
106 ;
107DQ ; output entry point...
108 K ^TMP($J)
109 ;
110 ; set report date... SED 11/4/03
111 S ALPBRDAT=$S(ALPBOTYP="C":$$NOW^XLFDT(),1:"")
112 ;
113 ; loop through ward cross reference in 53.7...
114 S ALPBPTN=""
115 F S ALPBPTN=$O(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN)) Q:ALPBPTN="" D
116 .S ALPBIEN=0
117 .F S ALPBIEN=$O(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN,ALPBIEN)) Q:'ALPBIEN D
118 ..D ORDS^ALPBUTL(ALPBIEN,ALPBRDAT,.ALPBORDS)
119 ..I +ALPBORDS(0)'>0 K ALPBORDS Q
120 ..I $G(ALPBPDAT(0))="" S ALPBPDAT(0)=$G(^ALPB(53.7,ALPBIEN,0))
121 ..S ALPBOIEN=0
122 ..F S ALPBOIEN=$O(ALPBORDS(ALPBOIEN)) Q:'ALPBOIEN D
123 ...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,1))
124 ...S ALPBOCT=$P($G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,3)),U,1)
125 ...S:$P($G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,4)),U,3)["PRN" ALPBOCT=ALPBOCT_"P"
126 ...; if report is for "C"urrent, check stop date and quit if
127 ...; stop date is less than report date...
128 ...I ALPBOTYP="C"&($P(ALPBDATA,U,2)<ALPBRDAT) K ALPBDATA Q
129 ...S ALPBORDN=ALPBORDS(ALPBOIEN)
130 ...S ALPBOST=$$STAT2^ALPBUTL1(ALPBORDS(ALPBOIEN,2))
131 ...I '$D(^TMP($J,ALPBPTN)) S ^TMP($J,ALPBPTN)=ALPBIEN
132 ...S ^TMP($J,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)=ALPBOIEN
133 ...K ALPBDATA,ALPBORDN,ALPBOST
134 ..K ALPBOIEN,ALPBORDS,ALPBPDAT
135 .K ALPBIEN
136 K ALPBPTN
137 ;
138 ; Sort by Patient Name or room/bed capability added 6/23/05 KFOX
139 S ALPBPG=0
140 S ALPBPTN=""
141 I ALPBSORT="N" D
142 .F S ALPBPTN=$O(^TMP($J,ALPBPTN)) Q:ALPBPTN="" S ALPBIEN=^TMP($J,ALPBPTN) D PRT
143 ;SORT BY ROOM/BED
144 I ALPBSORT="R" D
145 .S ALPBD="",ALPRM=""
146 .F S ALPBPTN=$O(^TMP($J,ALPBPTN)) Q:ALPBPTN="" D Q:ALPBPTN=""
147 ..I ALPBPTN="BCBU" S ALPBPTN=$O(^TMP($J,ALPBPTN)) ;SKIP "BCBU" SUBSCRIBE
148 ..I ALPBPTN="" Q ;PSB*3*37 Stop null subscript when "BCBU" is the last entry in ^TMP
149 ..S ALPBIEN=^TMP($J,ALPBPTN) S ALPRM=$P($G(^ALPB(53.7,ALPBIEN,0)),"^",6),ALPBD=$P($G(^ALPB(53.7,ALPBIEN,0)),"^",7)
150 ..I ALPBD="" S ALPB="NONE" I ALPRM="" S ALPB="NONE" ;INCASE NO ROOM AND BED YET
151 ..S ^TMP($J,"BCBU",ALPRM,ALPRM,ALPBD,ALPBPTN)=ALPBIEN
152 .S ALPRM1="" F S ALPRM1=$O(^TMP($J,"BCBU",ALPRM1)) Q:ALPRM1="" D
153 ..S ALPRM="" F S ALPRM=$O(^TMP($J,"BCBU",ALPRM1,ALPRM)) Q:ALPRM="" D
154 ...S ALPBD="" F S ALPBD=$O(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD)) Q:ALPBD="" D
155 ....S ALPBPTN="" F S ALPBPTN=$O(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD,ALPBPTN)) Q:ALPBPTN="" D
156 .....S ALPBIEN=$G(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD,ALPBPTN)) D PRT
157 D DONE
158 Q
159PRT S ALPBPDAT(0)=$G(^ALPB(53.7,ALPBIEN,0))
160 M ALPBPDAT(1)=^ALPB(53.7,ALPBIEN,1)
161 I ALPBPG=0 D PAGE
162 S ALPBOCT=""
163 F S ALPBOCT=$O(^TMP($J,ALPBPTN,ALPBOCT)) Q:ALPBOCT="" D
164 .S ALPBOST=""
165 .F S ALPBOST=$O(^TMP($J,ALPBPTN,ALPBOCT,ALPBOST)) Q:ALPBOST="" D
166 ..S ALPBORDN=""
167 ..F S ALPBORDN=$O(^TMP($J,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)) Q:ALPBORDN="" D
168 ...S ALPBOIEN=^TMP($J,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)
169 ...; get and print this order's data...
170 ...M ALPBDATA=^ALPB(53.7,ALPBIEN,2,ALPBOIEN)
171 ...D F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,ALPBMLOG,.ALPBFORM,ALPBIEN)
172 ...;D F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,.ALPBFORM)
173 ...I $Y+ALPBFORM(0)=IOSL!($Y+ALPBFORM(0)>IOSL) D PAGE
174 ...F ALPBX=1:1:ALPBFORM(0) W !,ALPBFORM(ALPBX)
175 ...K ALPBDATA,ALPBFORM,ALPBOIEN,ALPBX
176 ..K ALPBORDN
177 .K ALPBOST
178 K ALPBOCT
179 ; print footer at end of this patient's record...
180 I $Y+10>IOSL D PAGE
181 W !!
182 D FOOT^ALPBFRMU
183 ;Print a blank page between patient
184 W @IOF
185 S ALPBPG=0
186 K ALPBPDAT
187 Q
188 ;K ALPBIEN,ALPBPDAT KILLING ALPBIEN WILL BREAK SORT BY ROOM/BED
189 ;
190DONE ;
191 K ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBPG,ALPBPTN,ALPBRDAT,ALPBWARD,^TMP($J),ALPRM,ALPRM1,ALPBD,ALPBIEN,ALPBSORT
192 I $D(ZTQUEUED) S ZTREQ="@"
193 Q
194 ;
195PAGE ; print page header for patient...
196 W @IOF
197 S ALPBPG=ALPBPG+1
198 D HDR^ALPBFRMU(.ALPBPDAT,ALPBPG,.ALPBHDR)
199 F ALPBX=1:1:ALPBHDR(0) W !,ALPBHDR(ALPBX)
200 K ALPBHDR,ALPBX
201 Q
Note: See TracBrowser for help on using the repository browser.