- 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
- 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
