- ALPBPALL ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCMA BACLUP REPORT FOR ALL WARDS ;01/01/03
- ;;3.0;BAR CODE MED ADMIN;**8,29**;Mar 2004
- ;
- ; based on original code by FD@NJHCS, May 2002
- ;
- W !,"Inpatient Pharmacy Orders for all wards"
- ;
- ; get all or just current orders?...
- S DIR(0)="SA^A:ALL;C:CURRENT"
- S DIR("A")="Report [A]LL or [C]URRENT orders? "
- S DIR("B")="CURRENT"
- S DIR("?")="[A]LL=all orders in the file, [C]URRENT=orders not yet expired."
- W ! D ^DIR K DIR
- I $D(DIRUT) K DIRUT,DTOUT,X,Y Q
- S ALPBOTYP=Y
- ;
- ; print how many days MAR?...
- S DIR(0)="NA^1:7"
- S DIR("A")="Print how many days MAR? "
- S DIR("B")=$$DEFDAYS^ALPBUTL()
- S DIR("?")="The default is shown; you may choose 3 or 7."
- W ! D ^DIR K DIR
- I $D(DIRUT) K ALPBOTYP,DIRUT,DTOUT,X,Y Q
- S ALPBDAYS=+Y
- ;
- ; BCMA Med Log info for how many ?...
- S DIR(0)="NA^1:99"
- S DIR("B")=$$DEFML^ALPBUTL3()
- S DIR("A")="Select how many BCMA Medication Log history: "
- S DIR("A",1)=" "
- S DIR("?",1)="Select a number of BCMA Medication log entries"
- S DIR("?",2)="for each of the patient's orders"
- S DIR("?")="They are listed by the most current entry first"
- D ^DIR K DIR
- I $D(DIRUT) K ALPBOTYP,ALPBWARD,DIRUT,DTOUT,X,Y Q
- S ALPBMLOG=Y
- ;
- S %ZIS="Q"
- S %ZIS("B")=$$DEFPRT^ALPBUTL()
- I %ZIS("B")="" K %ZIS("B")
- W ! D ^%ZIS K %ZIS
- I POP K POP Q
- ;
- ; output not queued...
- I '$D(IO("Q")) D
- .U IO
- .D DQ
- .I IO'=IO(0) D ^%ZISC
- ;
- ; set up the task...
- I $D(IO("Q")) D
- .S ZTRTN="DQ^ALPBPALL"
- .S ZTDESC="PSB INPT PHARM ORDER FOR ALL WARDS"
- .S ZTIO=ION
- .S ZTSAVE("ALPBMLOG")=""
- .S ZTSAVE("ALPBOTYP")=""
- .S ZTSAVE("ALPBDAYS")=""
- .D ^%ZTLOAD
- .D HOME^%ZIS
- .W !,$S($G(ZTSK):"Task number "_ZTSK_" queued.",1:"ERROR -- NOT QUEUED!")
- .K IO("Q"),ZTSK
- K ALPBDAYS,ALPBMLOG,ALPBOTYP
- Q
- ;
- DQ ; output entry point...
- K ^TMP($J)
- ;
- ; set report date...MOD 11/03/03 SED
- S ALPBRDAT=$S(ALPBOTYP="C":$$NOW^XLFDT(),1:"")
- ;
- ; loop through ward cross reference in 53.7...
- S ALPBWARD=""
- F S ALPBWARD=$O(^ALPB(53.7,"AW",ALPBWARD)) Q:ALPBWARD="" D
- .S ALPBPTN=""
- .F S ALPBPTN=$O(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN)) Q:ALPBPTN="" D
- ..S ALPBIEN=0
- ..F S ALPBIEN=$O(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN,ALPBIEN)) Q:'ALPBIEN D
- ...D ORDS^ALPBUTL(ALPBIEN,ALPBRDAT,.ALPBORDS)
- ...I +ALPBORDS(0)'>0 K ALPBORDS Q
- ...S ALPBOIEN=0
- ...F S ALPBOIEN=$O(ALPBORDS(ALPBOIEN)) Q:'ALPBOIEN D
- ....S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,1))
- ....I ALPBOTYP="C"&($P(ALPBDATA,U,2)<ALPBRDAT) K ALPBDATA Q
- ....S ALPBOCT=$P($G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,3)),U,1)
- ....S:$P($G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,4)),U,3)["PRN" ALPBOCT=ALPBOCT_"P"
- ....S ALPBORDN=ALPBORDS(ALPBOIEN)
- ....S ALPBOST=$$STAT2^ALPBUTL1(ALPBORDS(ALPBOIEN,2))
- ....I '$D(^TMP($J,ALPBWARD,ALPBPTN)) S ^TMP($J,ALPBWARD,ALPBPTN)=ALPBIEN
- ....S ^TMP($J,ALPBWARD,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)=ALPBOIEN
- ....K ALPBDATA,ALPBORDN,ALPBOST,ALPBOCT
- ...K ALPBOIEN,ALPBORDS
- ..K ALPBIEN
- .K ALPBPTN
- K ALPBWARD
- ;
- ; process through our sorted list...
- S ALPBPG=0
- S ALPBWARD=""
- F S ALPBWARD=$O(^TMP($J,ALPBWARD)) Q:ALPBWARD="" D
- .S ALPBPTN=""
- .F S ALPBPTN=$O(^TMP($J,ALPBWARD,ALPBPTN)) Q:ALPBPTN="" D
- ..S ALPBIEN=+^TMP($J,ALPBWARD,ALPBPTN)
- ..S ALPBPDAT(0)=$G(^ALPB(53.7,ALPBIEN,0))
- ..M ALPBPDAT(1)=^ALPB(53.7,ALPBIEN,1)
- ..; paginate between patients...
- ..I ALPBPG=0 D PAGE
- ..S ALPBOCT=""
- ..F S ALPBOCT=$O(^TMP($J,ALPBWARD,ALPBPTN,ALPBOCT)) Q:ALPBOCT="" D
- ...S ALPBOST=""
- ...F S ALPBOST=$O(^TMP($J,ALPBWARD,ALPBPTN,ALPBOCT,ALPBOST)) Q:ALPBOST="" D
- ....S ALPBORDN=""
- ....F S ALPBORDN=$O(^TMP($J,ALPBWARD,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)) Q:ALPBORDN="" D
- .....S ALPBOIEN=^TMP($J,ALPBWARD,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)
- .....; get and print this order's data...
- .....M ALPBDATA=^ALPB(53.7,ALPBIEN,2,ALPBOIEN)
- .....D F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,ALPBMLOG,.ALPBFORM,ALPBIEN)
- .....I $Y+ALPBFORM(0)>IOSL D PAGE
- .....S ALPBX=0
- .....F S ALPBX=$O(ALPBFORM(ALPBX)) Q:'ALPBX W !,ALPBFORM(ALPBX)
- .....K ALPBDATA,ALPBFORM,ALPBOIEN,ALPBX
- ....K ALPBORDN
- ...K ALPBOST
- ..K ALPBIEN,ALPBPDAT,ALPBOCT
- ..S ALPBPG=0
- ..; print footer at end of this patient's record...
- ..D FOOT^ALPBFRMU
- ..;Print a blank page between patients
- ..W @IOF
- .K ALPBPTN
- ;
- K ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBPG,ALPBRDAT,ALPBWARD,^TMP($J)
- I $D(ZTQUEUED) S ZTREQ="@"
- Q
- ;
- PAGE ; paginate and print header for a patient...
- W @IOF
- ; increment page count...
- S ALPBPG=ALPBPG+1
- D HDR^ALPBFRMU(.ALPBPDAT,ALPBPG,.ALPBHDR)
- S ALPBX=0
- F S ALPBX=$O(ALPBHDR(ALPBX)) Q:'ALPBX W !,ALPBHDR(ALPBX)
- K ALPBHDR,ALPBX
- Q
- ALPBPALL ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCMA BACLUP REPORT FOR ALL WARDS ;01/01/03
- +1 ;;3.0;BAR CODE MED ADMIN;**8,29**;Mar 2004
- +2 ;
- +3 ; based on original code by FD@NJHCS, May 2002
- +4 ;
- +5 WRITE !,"Inpatient Pharmacy Orders for all wards"
- +6 ;
- +7 ; get all or just current orders?...
- +8 SET DIR(0)="SA^A:ALL;C:CURRENT"
- +9 SET DIR("A")="Report [A]LL or [C]URRENT orders? "
- +10 SET DIR("B")="CURRENT"
- +11 SET DIR("?")="[A]LL=all orders in the file, [C]URRENT=orders not yet expired."
- +12 WRITE !
- DO ^DIR
- KILL DIR
- +13 IF $DATA(DIRUT)
- KILL DIRUT,DTOUT,X,Y
- QUIT
- +14 SET ALPBOTYP=Y
- +15 ;
- +16 ; print how many days MAR?...
- +17 SET DIR(0)="NA^1:7"
- +18 SET DIR("A")="Print how many days MAR? "
- +19 SET DIR("B")=$$DEFDAYS^ALPBUTL()
- +20 SET DIR("?")="The default is shown; you may choose 3 or 7."
- +21 WRITE !
- DO ^DIR
- KILL DIR
- +22 IF $DATA(DIRUT)
- KILL ALPBOTYP,DIRUT,DTOUT,X,Y
- QUIT
- +23 SET ALPBDAYS=+Y
- +24 ;
- +25 ; BCMA Med Log info for how many ?...
- +26 SET DIR(0)="NA^1:99"
- +27 SET DIR("B")=$$DEFML^ALPBUTL3()
- +28 SET DIR("A")="Select how many BCMA Medication Log history: "
- +29 SET DIR("A",1)=" "
- +30 SET DIR("?",1)="Select a number of BCMA Medication log entries"
- +31 SET DIR("?",2)="for each of the patient's orders"
- +32 SET DIR("?")="They are listed by the most current entry first"
- +33 DO ^DIR
- KILL DIR
- +34 IF $DATA(DIRUT)
- KILL ALPBOTYP,ALPBWARD,DIRUT,DTOUT,X,Y
- QUIT
- +35 SET ALPBMLOG=Y
- +36 ;
- +37 SET %ZIS="Q"
- +38 SET %ZIS("B")=$$DEFPRT^ALPBUTL()
- +39 IF %ZIS("B")=""
- KILL %ZIS("B")
- +40 WRITE !
- DO ^%ZIS
- KILL %ZIS
- +41 IF POP
- KILL POP
- QUIT
- +42 ;
- +43 ; output not queued...
- +44 IF '$DATA(IO("Q"))
- Begin DoDot:1
- +45 USE IO
- +46 DO DQ
- +47 IF IO'=IO(0)
- DO ^%ZISC
- End DoDot:1
- +48 ;
- +49 ; set up the task...
- +50 IF $DATA(IO("Q"))
- Begin DoDot:1
- +51 SET ZTRTN="DQ^ALPBPALL"
- +52 SET ZTDESC="PSB INPT PHARM ORDER FOR ALL WARDS"
- +53 SET ZTIO=ION
- +54 SET ZTSAVE("ALPBMLOG")=""
- +55 SET ZTSAVE("ALPBOTYP")=""
- +56 SET ZTSAVE("ALPBDAYS")=""
- +57 DO ^%ZTLOAD
- +58 DO HOME^%ZIS
- +59 WRITE !,$SELECT($GET(ZTSK):"Task number "_ZTSK_" queued.",1:"ERROR -- NOT QUEUED!")
- +60 KILL IO("Q"),ZTSK
- End DoDot:1
- +61 KILL ALPBDAYS,ALPBMLOG,ALPBOTYP
- +62 QUIT
- +63 ;
- DQ ; output entry point...
- +1 KILL ^TMP($JOB)
- +2 ;
- +3 ; set report date...MOD 11/03/03 SED
- +4 SET ALPBRDAT=$SELECT(ALPBOTYP="C":$$NOW^XLFDT(),1:"")
- +5 ;
- +6 ; loop through ward cross reference in 53.7...
- +7 SET ALPBWARD=""
- +8 FOR
- SET ALPBWARD=$ORDER(^ALPB(53.7,"AW",ALPBWARD))
- IF ALPBWARD=""
- QUIT
- Begin DoDot:1
- +9 SET ALPBPTN=""
- +10 FOR
- SET ALPBPTN=$ORDER(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN))
- IF ALPBPTN=""
- QUIT
- Begin DoDot:2
- +11 SET ALPBIEN=0
- +12 FOR
- SET ALPBIEN=$ORDER(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN,ALPBIEN))
- IF 'ALPBIEN
- QUIT
- Begin DoDot:3
- +13 DO ORDS^ALPBUTL(ALPBIEN,ALPBRDAT,.ALPBORDS)
- +14 IF +ALPBORDS(0)'>0
- KILL ALPBORDS
- QUIT
- +15 SET ALPBOIEN=0
- +16 FOR
- SET ALPBOIEN=$ORDER(ALPBORDS(ALPBOIEN))
- IF 'ALPBOIEN
- QUIT
- Begin DoDot:4
- +17 SET ALPBDATA=$GET(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,1))
- +18 IF ALPBOTYP="C"&($PIECE(ALPBDATA,U,2)<ALPBRDAT)
- KILL ALPBDATA
- QUIT
- +19 SET ALPBOCT=$PIECE($GET(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,3)),U,1)
- +20 IF $PIECE($GET(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,4)),U,3)["PRN"
- SET ALPBOCT=ALPBOCT_"P"
- +21 SET ALPBORDN=ALPBORDS(ALPBOIEN)
- +22 SET ALPBOST=$$STAT2^ALPBUTL1(ALPBORDS(ALPBOIEN,2))
- +23 IF '$DATA(^TMP($JOB,ALPBWARD,ALPBPTN))
- SET ^TMP($JOB,ALPBWARD,ALPBPTN)=ALPBIEN
- +24 SET ^TMP($JOB,ALPBWARD,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)=ALPBOIEN
- +25 KILL ALPBDATA,ALPBORDN,ALPBOST,ALPBOCT
- End DoDot:4
- +26 KILL ALPBOIEN,ALPBORDS
- End DoDot:3
- +27 KILL ALPBIEN
- End DoDot:2
- +28 KILL ALPBPTN
- End DoDot:1
- +29 KILL ALPBWARD
- +30 ;
- +31 ; process through our sorted list...
- +32 SET ALPBPG=0
- +33 SET ALPBWARD=""
- +34 FOR
- SET ALPBWARD=$ORDER(^TMP($JOB,ALPBWARD))
- IF ALPBWARD=""
- QUIT
- Begin DoDot:1
- +35 SET ALPBPTN=""
- +36 FOR
- SET ALPBPTN=$ORDER(^TMP($JOB,ALPBWARD,ALPBPTN))
- IF ALPBPTN=""
- QUIT
- Begin DoDot:2
- +37 SET ALPBIEN=+^TMP($JOB,ALPBWARD,ALPBPTN)
- +38 SET ALPBPDAT(0)=$GET(^ALPB(53.7,ALPBIEN,0))
- +39 MERGE ALPBPDAT(1)=^ALPB(53.7,ALPBIEN,1)
- +40 ; paginate between patients...
- +41 IF ALPBPG=0
- DO PAGE
- +42 SET ALPBOCT=""
- +43 FOR
- SET ALPBOCT=$ORDER(^TMP($JOB,ALPBWARD,ALPBPTN,ALPBOCT))
- IF ALPBOCT=""
- QUIT
- Begin DoDot:3
- +44 SET ALPBOST=""
- +45 FOR
- SET ALPBOST=$ORDER(^TMP($JOB,ALPBWARD,ALPBPTN,ALPBOCT,ALPBOST))
- IF ALPBOST=""
- QUIT
- Begin DoDot:4
- +46 SET ALPBORDN=""
- +47 FOR
- SET ALPBORDN=$ORDER(^TMP($JOB,ALPBWARD,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN))
- IF ALPBORDN=""
- QUIT
- Begin DoDot:5
- +48 SET ALPBOIEN=^TMP($JOB,ALPBWARD,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)
- +49 ; get and print this order's data...
- +50 MERGE ALPBDATA=^ALPB(53.7,ALPBIEN,2,ALPBOIEN)
- +51 DO F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,ALPBMLOG,.ALPBFORM,ALPBIEN)
- +52 IF $Y+ALPBFORM(0)>IOSL
- DO PAGE
- +53 SET ALPBX=0
- +54 FOR
- SET ALPBX=$ORDER(ALPBFORM(ALPBX))
- IF 'ALPBX
- QUIT
- WRITE !,ALPBFORM(ALPBX)
- +55 KILL ALPBDATA,ALPBFORM,ALPBOIEN,ALPBX
- End DoDot:5
- +56 KILL ALPBORDN
- End DoDot:4
- +57 KILL ALPBOST
- End DoDot:3
- +58 KILL ALPBIEN,ALPBPDAT,ALPBOCT
- +59 SET ALPBPG=0
- +60 ; print footer at end of this patient's record...
- +61 DO FOOT^ALPBFRMU
- +62 ;Print a blank page between patients
- +63 WRITE @IOF
- End DoDot:2
- +64 KILL ALPBPTN
- End DoDot:1
- +65 ;
- +66 KILL ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBPG,ALPBRDAT,ALPBWARD,^TMP($JOB)
- +67 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +68 QUIT
- +69 ;
- PAGE ; paginate and print header for a patient...
- +1 WRITE @IOF
- +2 ; increment page count...
- +3 SET ALPBPG=ALPBPG+1
- +4 DO HDR^ALPBFRMU(.ALPBPDAT,ALPBPG,.ALPBHDR)
- +5 SET ALPBX=0
- +6 FOR
- SET ALPBX=$ORDER(ALPBHDR(ALPBX))
- IF 'ALPBX
- QUIT
- WRITE !,ALPBHDR(ALPBX)
- +7 KILL ALPBHDR,ALPBX
- +8 QUIT
