source: WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBSWRD.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: 3.9 KB
Line 
1ALPBSWRD ;OIFO-DALLAS MW,SED,KC - display BCBU records for patients on a selected ward ;01/01/03
2 ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
3 ;
4 F D Q:$D(DIRUT)
5 .W !!,"Inpatient Pharmacy Orders for a selected ward"
6 .S DIR(0)="FAO^2:10"
7 .S DIR("A")="Select WARD: "
8 .S DIR("?")="^D WARDLIST^ALPBUTL(""C"")"
9 .D ^DIR K DIR
10 .I $D(DIRUT) Q
11 .D WARDSEL^ALPBUTL(Y,.ALPBSEL)
12 .I +$G(ALPBSEL(0))=0 D Q
13 ..W $C(7)
14 ..W " ??"
15 ..D WARDLIST^ALPBUTL("C")
16 ..K ALPBSEL
17 .I +$G(ALPBSEL(0))=1 D
18 ..S ALPBWARD=ALPBSEL(1)
19 ..W " ",ALPBWARD
20 ..K ALPBSEL
21 .I +$G(ALPBSEL(0))>1 D I $D(DIRUT) K DIRUT,DTOUT,X,Y Q
22 ..S ALPBX=0
23 ..F S ALPBX=$O(ALPBSEL(ALPBX)) Q:'ALPBX W !?2,$J(ALPBX,2)," ",ALPBSEL(ALPBX)
24 ..K ALPBX
25 ..S DIR(0)="NA^1:"_ALPBSEL(0)
26 ..S DIR("A")="Select Ward from the list (1-"_ALPBSEL(0)_"): "
27 ..W ! D ^DIR K DIR
28 ..I $D(DIRUT) K ALPBSEL Q
29 ..S ALPBWARD=ALPBSEL(+Y)
30 .;
31 .; all or just current orders?...
32 .S DIR(0)="SA^A:ALL;C:CURRENT"
33 .S DIR("A")="[A]LL or [C]URRENT orders? "
34 .S DIR("B")="CURRENT"
35 .S DIR("?")="ALL=all orders, CURRENT=all orders not expired or inactive"
36 .W ! D ^DIR K DIR
37 .I $D(DIRUT) K ALPBWARD,DIRUT,DTOUT,X,Y Q
38 .S ALPBOTYP=Y
39 .;
40 .; BCMA Med Log info for how many days?...
41 .S X1=$$DT^XLFDT()
42 .S X2=-3
43 .D C^%DTC
44 .S DIR(0)="DA^::EXP"
45 .S DIR("B")=$$FMTE^XLFDT(X)
46 .S DIR("A")="Select beginning date for BCMA Medication Log history: "
47 .S DIR("A",1)=" "
48 .S DIR("?")="want only current day's entries, enter 'T' for today."
49 .S DIR("?",1)="Select a date (in the past) from which you wish to see"
50 .S DIR("?",2)="any BCMA Medication Log entries for each of this patient's"
51 .S DIR("?",3)="orders. The default date shown is 3 days ago. If you"
52 .D ^DIR K DIR
53 .I $D(DIRUT) K ALPBOTYP,DIRUT,DTOUT,X,Y Q
54 .S ALPBMLOG=Y
55 .;
56 .S %ZIS="Q"
57 .W ! D ^%ZIS K %ZIS
58 .I POP D Q
59 ..W $C(7)
60 ..K ALPBWARD,POP
61 .;
62 .; output not queued...
63 .I '$D(IO("Q")) D
64 ..U IO
65 ..D DISP
66 ..I IO'=IO(0) D ^%ZISC
67 .;
68 .; set up the Task...
69 .I $D(IO("Q")) D
70 ..S ZTRTN="DISP^ALPBHL3"
71 ..S ZTDESC="PSB INPT PHARM ORDERS FOR WARD "_ALPBWARD
72 ..S ZTSAVE("ALPBWARD")=""
73 ..S ZTSAVE("ALPBOTYP")=""
74 ..S ZTSAVE("ALPBMLOG")=""
75 ..S ZTIO=ION
76 ..D ^%ZTLOAD
77 ..D HOME^%ZIS
78 ..W !,$S($G(ZTSK):"Task number "_ZTSK_" queued.",1:"ERROR -- NOT QUEUED!")
79 ..K IO("Q"),ZTSK
80 .K ALPBOTYP,ALPBWARD
81 K DIRUT,DTOUT,X,Y
82 Q
83 ;
84DISP ; output entry point...
85 I $E(IOST)="C" W @IOF
86 ;
87 ; set report date...
88 S ALPBRDAT=$S($G(ALPBOTYP)="C":$$NOW^XLFDT(),1:"")
89 ;
90 ; loop through ward cross reference in 53.7...
91 S ALPBPTN=""
92 F S ALPBPTN=$O(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN)) Q:ALPBPTN=""!($D(DIRUT)) D
93 .S (ALPBIEN,ALPBPG)=0
94 .F S ALPBIEN=$O(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN,ALPBIEN)) Q:'ALPBIEN!($D(DIRUT)) D
95 ..S ALPBPT(0)=^ALPB(53.7,ALPBIEN,0)
96 ..M ALPBPT(1)=^ALPB(53.7,ALPBIEN,1)
97 ..I ALPBPG=0 D PAGE
98 ..D ORDS^ALPBUTL(ALPBIEN,ALPBRDAT,.ALPBORDS)
99 ..I +ALPBORDS(0)=0 D Q
100 ...W !!,">> NO ORDERS FOUND <<"
101 ...K ALPBORDS,ALPBPT
102 ..S ALPBOIEN=0
103 ..F S ALPBOIEN=$O(ALPBORDS(ALPBOIEN)) Q:'ALPBOIEN!($D(DIRUT)) D
104 ...M ALPBDATA=^ALPB(53.7,ALPBIEN,2,ALPBOIEN)
105 ...;
106 ...D F80^ALPBFRM2(.ALPBDATA,ALPBMLOG,.ALPBFORM)
107 ...I $Y+ALPBFORM(0)=IOSL!($Y+ALPBFORM(0)>IOSL) D Q:$D(DIRUT)
108 ....S DIR(0)="E"
109 ....D ^DIR K DIR
110 ....I $D(DIRUT) K ALPBDATA,ALPBFORM,ALPBPT Q
111 ....D PAGE
112 ...;
113 ...S ALPBX=0
114 ...F S ALPBX=$O(ALPBFORM(ALPBX)) Q:'ALPBX W !,ALPBFORM(ALPBX)
115 ...K ALPBDATA,ALPBFORM,ALPBX
116 ...I +$O(ALPBORDS(ALPBOIEN))=0 D
117 ....S ALPBX="END OF "_$S(ALPBOTYP="A":"ALL",1:"CURRENT")_" ORDERS FOR "_ALPBPTN
118 ....S ALPBX=$$CJ^XLFSTR(ALPBX,80,"-")
119 ....W !,ALPBX
120 ....K ALPBX
121 ....S DIR(0)="E"
122 ....D ^DIR K DIR
123 ..K ALPBOIEN,ALPBORDS,ALPBPT
124 .K ALPBIEN,ALPBPG
125 I $E(IOST)="C" W @IOF
126 K ALPBMLOG,ALPBOTYP,ALPBPTN,ALPBRDAT,DIRUT,DTOUT,X,Y
127 I $D(ZTQUEUED) S ZTREQ="@"
128 Q
129 ;
130PAGE ; screen header for patient...
131 W @IOF
132 S ALPBPG=ALPBPG+1
133 D HDR^ALPBFRM2(.ALPBPT,ALPBOTYP,ALPBPG,.ALPBHDR)
134 F I=1:1:ALPBHDR(0) W !,ALPBHDR(I)
135 K ALPBHDR
136 Q
137 ;
138CONT ; continue?...
139 I $E(IOST)="C" D
140 .S DIR(0)="E"
141 .D ^DIR K DIR
142 I '$D(DIRUT) D
143 .S ALPBPG=ALPBPG+1
144 .D PAGE
145 Q
Note: See TracBrowser for help on using the repository browser.