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
