ALPBSWRD ;OIFO-DALLAS MW,SED,KC - display BCBU records for patients on a selected ward ;01/01/03
;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
;
F D Q:$D(DIRUT)
.W !!,"Inpatient Pharmacy Orders for a selected ward"
.S DIR(0)="FAO^2:10"
.S DIR("A")="Select WARD: "
.S DIR("?")="^D WARDLIST^ALPBUTL(""C"")"
.D ^DIR K DIR
.I $D(DIRUT) Q
.D WARDSEL^ALPBUTL(Y,.ALPBSEL)
.I +$G(ALPBSEL(0))=0 D Q
..W $C(7)
..W " ??"
..D WARDLIST^ALPBUTL("C")
..K ALPBSEL
.I +$G(ALPBSEL(0))=1 D
..S ALPBWARD=ALPBSEL(1)
..W " ",ALPBWARD
..K ALPBSEL
.I +$G(ALPBSEL(0))>1 D I $D(DIRUT) K DIRUT,DTOUT,X,Y Q
..S ALPBX=0
..F S ALPBX=$O(ALPBSEL(ALPBX)) Q:'ALPBX W !?2,$J(ALPBX,2)," ",ALPBSEL(ALPBX)
..K ALPBX
..S DIR(0)="NA^1:"_ALPBSEL(0)
..S DIR("A")="Select Ward from the list (1-"_ALPBSEL(0)_"): "
..W ! D ^DIR K DIR
..I $D(DIRUT) K ALPBSEL Q
..S ALPBWARD=ALPBSEL(+Y)
.;
.; all or just current orders?...
.S DIR(0)="SA^A:ALL;C:CURRENT"
.S DIR("A")="[A]LL or [C]URRENT orders? "
.S DIR("B")="CURRENT"
.S DIR("?")="ALL=all orders, CURRENT=all orders not expired or inactive"
.W ! D ^DIR K DIR
.I $D(DIRUT) K ALPBWARD,DIRUT,DTOUT,X,Y Q
.S ALPBOTYP=Y
.;
.; BCMA Med Log info for how many days?...
.S X1=$$DT^XLFDT()
.S X2=-3
.D C^%DTC
.S DIR(0)="DA^::EXP"
.S DIR("B")=$$FMTE^XLFDT(X)
.S DIR("A")="Select beginning date for BCMA Medication Log history: "
.S DIR("A",1)=" "
.S DIR("?")="want only current day's entries, enter 'T' for today."
.S DIR("?",1)="Select a date (in the past) from which you wish to see"
.S DIR("?",2)="any BCMA Medication Log entries for each of this patient's"
.S DIR("?",3)="orders. The default date shown is 3 days ago. If you"
.D ^DIR K DIR
.I $D(DIRUT) K ALPBOTYP,DIRUT,DTOUT,X,Y Q
.S ALPBMLOG=Y
.;
.S %ZIS="Q"
.W ! D ^%ZIS K %ZIS
.I POP D Q
..W $C(7)
..K ALPBWARD,POP
.;
.; output not queued...
.I '$D(IO("Q")) D
..U IO
..D DISP
..I IO'=IO(0) D ^%ZISC
.;
.; set up the Task...
.I $D(IO("Q")) D
..S ZTRTN="DISP^ALPBHL3"
..S ZTDESC="PSB INPT PHARM ORDERS FOR WARD "_ALPBWARD
..S ZTSAVE("ALPBWARD")=""
..S ZTSAVE("ALPBOTYP")=""
..S ZTSAVE("ALPBMLOG")=""
..S ZTIO=ION
..D ^%ZTLOAD
..D HOME^%ZIS
..W !,$S($G(ZTSK):"Task number "_ZTSK_" queued.",1:"ERROR -- NOT QUEUED!")
..K IO("Q"),ZTSK
.K ALPBOTYP,ALPBWARD
K DIRUT,DTOUT,X,Y
Q
;
DISP ; output entry point...
I $E(IOST)="C" W @IOF
;
; set report date...
S ALPBRDAT=$S($G(ALPBOTYP)="C":$$NOW^XLFDT(),1:"")
;
; loop through ward cross reference in 53.7...
S ALPBPTN=""
F S ALPBPTN=$O(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN)) Q:ALPBPTN=""!($D(DIRUT)) D
.S (ALPBIEN,ALPBPG)=0
.F S ALPBIEN=$O(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN,ALPBIEN)) Q:'ALPBIEN!($D(DIRUT)) D
..S ALPBPT(0)=^ALPB(53.7,ALPBIEN,0)
..M ALPBPT(1)=^ALPB(53.7,ALPBIEN,1)
..I ALPBPG=0 D PAGE
..D ORDS^ALPBUTL(ALPBIEN,ALPBRDAT,.ALPBORDS)
..I +ALPBORDS(0)=0 D Q
...W !!,">> NO ORDERS FOUND <<"
...K ALPBORDS,ALPBPT
..S ALPBOIEN=0
..F S ALPBOIEN=$O(ALPBORDS(ALPBOIEN)) Q:'ALPBOIEN!($D(DIRUT)) D
...M ALPBDATA=^ALPB(53.7,ALPBIEN,2,ALPBOIEN)
...;
...D F80^ALPBFRM2(.ALPBDATA,ALPBMLOG,.ALPBFORM)
...I $Y+ALPBFORM(0)=IOSL!($Y+ALPBFORM(0)>IOSL) D Q:$D(DIRUT)
....S DIR(0)="E"
....D ^DIR K DIR
....I $D(DIRUT) K ALPBDATA,ALPBFORM,ALPBPT Q
....D PAGE
...;
...S ALPBX=0
...F S ALPBX=$O(ALPBFORM(ALPBX)) Q:'ALPBX W !,ALPBFORM(ALPBX)
...K ALPBDATA,ALPBFORM,ALPBX
...I +$O(ALPBORDS(ALPBOIEN))=0 D
....S ALPBX="END OF "_$S(ALPBOTYP="A":"ALL",1:"CURRENT")_" ORDERS FOR "_ALPBPTN
....S ALPBX=$$CJ^XLFSTR(ALPBX,80,"-")
....W !,ALPBX
....K ALPBX
....S DIR(0)="E"
....D ^DIR K DIR
..K ALPBOIEN,ALPBORDS,ALPBPT
.K ALPBIEN,ALPBPG
I $E(IOST)="C" W @IOF
K ALPBMLOG,ALPBOTYP,ALPBPTN,ALPBRDAT,DIRUT,DTOUT,X,Y
I $D(ZTQUEUED) S ZTREQ="@"
Q
;
PAGE ; screen header for patient...
W @IOF
S ALPBPG=ALPBPG+1
D HDR^ALPBFRM2(.ALPBPT,ALPBOTYP,ALPBPG,.ALPBHDR)
F I=1:1:ALPBHDR(0) W !,ALPBHDR(I)
K ALPBHDR
Q
;
CONT ; continue?...
I $E(IOST)="C" D
.S DIR(0)="E"
.D ^DIR K DIR
I '$D(DIRUT) D
.S ALPBPG=ALPBPG+1
.D PAGE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HALPBSWRD 4179 printed Oct 16, 2024@17:40:28 Page 2
ALPBSWRD ;OIFO-DALLAS MW,SED,KC - display BCBU records for patients on a selected ward ;01/01/03
+1 ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
+2 ;
+3 FOR
Begin DoDot:1
+4 WRITE !!,"Inpatient Pharmacy Orders for a selected ward"
+5 SET DIR(0)="FAO^2:10"
+6 SET DIR("A")="Select WARD: "
+7 SET DIR("?")="^D WARDLIST^ALPBUTL(""C"")"
+8 DO ^DIR
KILL DIR
+9 IF $DATA(DIRUT)
QUIT
+10 DO WARDSEL^ALPBUTL(Y,.ALPBSEL)
+11 IF +$GET(ALPBSEL(0))=0
Begin DoDot:2
+12 WRITE $CHAR(7)
+13 WRITE " ??"
+14 DO WARDLIST^ALPBUTL("C")
+15 KILL ALPBSEL
End DoDot:2
QUIT
+16 IF +$GET(ALPBSEL(0))=1
Begin DoDot:2
+17 SET ALPBWARD=ALPBSEL(1)
+18 WRITE " ",ALPBWARD
+19 KILL ALPBSEL
End DoDot:2
+20 IF +$GET(ALPBSEL(0))>1
Begin DoDot:2
+21 SET ALPBX=0
+22 FOR
SET ALPBX=$ORDER(ALPBSEL(ALPBX))
if 'ALPBX
QUIT
WRITE !?2,$JUSTIFY(ALPBX,2)," ",ALPBSEL(ALPBX)
+23 KILL ALPBX
+24 SET DIR(0)="NA^1:"_ALPBSEL(0)
+25 SET DIR("A")="Select Ward from the list (1-"_ALPBSEL(0)_"): "
+26 WRITE !
DO ^DIR
KILL DIR
+27 IF $DATA(DIRUT)
KILL ALPBSEL
QUIT
+28 SET ALPBWARD=ALPBSEL(+Y)
End DoDot:2
IF $DATA(DIRUT)
KILL DIRUT,DTOUT,X,Y
QUIT
+29 ;
+30 ; all or just current orders?...
+31 SET DIR(0)="SA^A:ALL;C:CURRENT"
+32 SET DIR("A")="[A]LL or [C]URRENT orders? "
+33 SET DIR("B")="CURRENT"
+34 SET DIR("?")="ALL=all orders, CURRENT=all orders not expired or inactive"
+35 WRITE !
DO ^DIR
KILL DIR
+36 IF $DATA(DIRUT)
KILL ALPBWARD,DIRUT,DTOUT,X,Y
QUIT
+37 SET ALPBOTYP=Y
+38 ;
+39 ; BCMA Med Log info for how many days?...
+40 SET X1=$$DT^XLFDT()
+41 SET X2=-3
+42 DO C^%DTC
+43 SET DIR(0)="DA^::EXP"
+44 SET DIR("B")=$$FMTE^XLFDT(X)
+45 SET DIR("A")="Select beginning date for BCMA Medication Log history: "
+46 SET DIR("A",1)=" "
+47 SET DIR("?")="want only current day's entries, enter 'T' for today."
+48 SET DIR("?",1)="Select a date (in the past) from which you wish to see"
+49 SET DIR("?",2)="any BCMA Medication Log entries for each of this patient's"
+50 SET DIR("?",3)="orders. The default date shown is 3 days ago. If you"
+51 DO ^DIR
KILL DIR
+52 IF $DATA(DIRUT)
KILL ALPBOTYP,DIRUT,DTOUT,X,Y
QUIT
+53 SET ALPBMLOG=Y
+54 ;
+55 SET %ZIS="Q"
+56 WRITE !
DO ^%ZIS
KILL %ZIS
+57 IF POP
Begin DoDot:2
+58 WRITE $CHAR(7)
+59 KILL ALPBWARD,POP
End DoDot:2
QUIT
+60 ;
+61 ; output not queued...
+62 IF '$DATA(IO("Q"))
Begin DoDot:2
+63 USE IO
+64 DO DISP
+65 IF IO'=IO(0)
DO ^%ZISC
End DoDot:2
+66 ;
+67 ; set up the Task...
+68 IF $DATA(IO("Q"))
Begin DoDot:2
+69 SET ZTRTN="DISP^ALPBHL3"
+70 SET ZTDESC="PSB INPT PHARM ORDERS FOR WARD "_ALPBWARD
+71 SET ZTSAVE("ALPBWARD")=""
+72 SET ZTSAVE("ALPBOTYP")=""
+73 SET ZTSAVE("ALPBMLOG")=""
+74 SET ZTIO=ION
+75 DO ^%ZTLOAD
+76 DO HOME^%ZIS
+77 WRITE !,$SELECT($GET(ZTSK):"Task number "_ZTSK_" queued.",1:"ERROR -- NOT QUEUED!")
+78 KILL IO("Q"),ZTSK
End DoDot:2
+79 KILL ALPBOTYP,ALPBWARD
End DoDot:1
if $DATA(DIRUT)
QUIT
+80 KILL DIRUT,DTOUT,X,Y
+81 QUIT
+82 ;
DISP ; output entry point...
+1 IF $EXTRACT(IOST)="C"
WRITE @IOF
+2 ;
+3 ; set report date...
+4 SET ALPBRDAT=$SELECT($GET(ALPBOTYP)="C":$$NOW^XLFDT(),1:"")
+5 ;
+6 ; loop through ward cross reference in 53.7...
+7 SET ALPBPTN=""
+8 FOR
SET ALPBPTN=$ORDER(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN))
if ALPBPTN=""!($DATA(DIRUT))
QUIT
Begin DoDot:1
+9 SET (ALPBIEN,ALPBPG)=0
+10 FOR
SET ALPBIEN=$ORDER(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN,ALPBIEN))
if 'ALPBIEN!($DATA(DIRUT))
QUIT
Begin DoDot:2
+11 SET ALPBPT(0)=^ALPB(53.7,ALPBIEN,0)
+12 MERGE ALPBPT(1)=^ALPB(53.7,ALPBIEN,1)
+13 IF ALPBPG=0
DO PAGE
+14 DO ORDS^ALPBUTL(ALPBIEN,ALPBRDAT,.ALPBORDS)
+15 IF +ALPBORDS(0)=0
Begin DoDot:3
+16 WRITE !!,">> NO ORDERS FOUND <<"
+17 KILL ALPBORDS,ALPBPT
End DoDot:3
QUIT
+18 SET ALPBOIEN=0
+19 FOR
SET ALPBOIEN=$ORDER(ALPBORDS(ALPBOIEN))
if 'ALPBOIEN!($DATA(DIRUT))
QUIT
Begin DoDot:3
+20 MERGE ALPBDATA=^ALPB(53.7,ALPBIEN,2,ALPBOIEN)
+21 ;
+22 DO F80^ALPBFRM2(.ALPBDATA,ALPBMLOG,.ALPBFORM)
+23 IF $Y+ALPBFORM(0)=IOSL!($Y+ALPBFORM(0)>IOSL)
Begin DoDot:4
+24 SET DIR(0)="E"
+25 DO ^DIR
KILL DIR
+26 IF $DATA(DIRUT)
KILL ALPBDATA,ALPBFORM,ALPBPT
QUIT
+27 DO PAGE
End DoDot:4
if $DATA(DIRUT)
QUIT
+28 ;
+29 SET ALPBX=0
+30 FOR
SET ALPBX=$ORDER(ALPBFORM(ALPBX))
if 'ALPBX
QUIT
WRITE !,ALPBFORM(ALPBX)
+31 KILL ALPBDATA,ALPBFORM,ALPBX
+32 IF +$ORDER(ALPBORDS(ALPBOIEN))=0
Begin DoDot:4
+33 SET ALPBX="END OF "_$SELECT(ALPBOTYP="A":"ALL",1:"CURRENT")_" ORDERS FOR "_ALPBPTN
+34 SET ALPBX=$$CJ^XLFSTR(ALPBX,80,"-")
+35 WRITE !,ALPBX
+36 KILL ALPBX
+37 SET DIR(0)="E"
+38 DO ^DIR
KILL DIR
End DoDot:4
End DoDot:3
+39 KILL ALPBOIEN,ALPBORDS,ALPBPT
End DoDot:2
+40 KILL ALPBIEN,ALPBPG
End DoDot:1
+41 IF $EXTRACT(IOST)="C"
WRITE @IOF
+42 KILL ALPBMLOG,ALPBOTYP,ALPBPTN,ALPBRDAT,DIRUT,DTOUT,X,Y
+43 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+44 QUIT
+45 ;
PAGE ; screen header for patient...
+1 WRITE @IOF
+2 SET ALPBPG=ALPBPG+1
+3 DO HDR^ALPBFRM2(.ALPBPT,ALPBOTYP,ALPBPG,.ALPBHDR)
+4 FOR I=1:1:ALPBHDR(0)
WRITE !,ALPBHDR(I)
+5 KILL ALPBHDR
+6 QUIT
+7 ;
CONT ; continue?...
+1 IF $EXTRACT(IOST)="C"
Begin DoDot:1
+2 SET DIR(0)="E"
+3 DO ^DIR
KILL DIR
End DoDot:1
+4 IF '$DATA(DIRUT)
Begin DoDot:1
+5 SET ALPBPG=ALPBPG+1
+6 DO PAGE
End DoDot:1
+7 QUIT
