ALPBPWRD ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCMA BCBU REPORT FOR A SELECTED WARD ;01/01/03
;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; NOTE: this routine is designed for hard-copy output.
; Output is formatted for 132-column printing.
;
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)
..K ALPBSEL
.;
.; 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 ALPBWARD,DIRUT,DTOUT,X,Y Q
.S ALPBOTYP=Y
.;
.;SORT BY NAME OR ROOM/BED added 6/23/05
.S DIR(0)="SA^N:Name;R:Room/Bed"
.S DIR("A")="Sort Patients by [N]ame or [R]oom/Bed? "
.S DIR("B")="Room/bed"
.S DIR("?")="Sort by [N]ame or [R]oom Bed"
.W ! D ^DIR K DIR
.I $D(DIRUT) K ALPBWARD,DIRUT,DTOUT,X,Y Q
.S ALPBSORT=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 enter 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 D Q
..W $C(7)
..K ALPBMLOG,ALPBOTYP,ALPBWARD,POP
.;
.; 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^ALPBPWRD"
..S ZTDESC="PSB INPT PHARM ORDERS FOR WARD "_ALPBWARD
..S ZTSAVE("ALPBDAYS")=""
..S ZTSAVE("ALPBWARD")=""
..S ZTSAVE("ALPBMLOG")=""
..S ZTSAVE("ALPBOTYP")=""
..S ZTSAVE("ALPBSORT")=""
..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 ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBWARD
K DIRUT,DTOUT,X,Y
Q
;
DQ ; output entry point...
K ^TMP($J)
;
; set report date... SED 11/4/03
S ALPBRDAT=$S(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
.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
..I $G(ALPBPDAT(0))="" S ALPBPDAT(0)=$G(^ALPB(53.7,ALPBIEN,0))
..S ALPBOIEN=0
..F S ALPBOIEN=$O(ALPBORDS(ALPBOIEN)) Q:'ALPBOIEN D
...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,1))
...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"
...; if report is for "C"urrent, check stop date and quit if
...; stop date is less than report date...
...I ALPBOTYP="C"&($P(ALPBDATA,U,2)<ALPBRDAT) K ALPBDATA Q
...S ALPBORDN=ALPBORDS(ALPBOIEN)
...S ALPBOST=$$STAT2^ALPBUTL1(ALPBORDS(ALPBOIEN,2))
...I '$D(^TMP($J,ALPBPTN)) S ^TMP($J,ALPBPTN)=ALPBIEN
...S ^TMP($J,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)=ALPBOIEN
...K ALPBDATA,ALPBORDN,ALPBOST
..K ALPBOIEN,ALPBORDS,ALPBPDAT
.K ALPBIEN
K ALPBPTN
;
; Sort by Patient Name or room/bed capability added 6/23/05 KFOX
S ALPBPG=0
S ALPBPTN=""
I ALPBSORT="N" D
.F S ALPBPTN=$O(^TMP($J,ALPBPTN)) Q:ALPBPTN="" S ALPBIEN=^TMP($J,ALPBPTN) D PRT
;SORT BY ROOM/BED
I ALPBSORT="R" D
.S ALPBD="",ALPRM=""
.F S ALPBPTN=$O(^TMP($J,ALPBPTN)) Q:ALPBPTN="" D Q:ALPBPTN=""
..I ALPBPTN="BCBU" S ALPBPTN=$O(^TMP($J,ALPBPTN)) ;SKIP "BCBU" SUBSCRIBE
..I ALPBPTN="" Q ;PSB*3*37 Stop null subscript when "BCBU" is the last entry in ^TMP
..S ALPBIEN=^TMP($J,ALPBPTN) S ALPRM=$P($G(^ALPB(53.7,ALPBIEN,0)),"^",6),ALPBD=$P($G(^ALPB(53.7,ALPBIEN,0)),"^",7)
..I ALPBD="" S ALPB="NONE" I ALPRM="" S ALPB="NONE" ;INCASE NO ROOM AND BED YET
..S ^TMP($J,"BCBU",ALPRM,ALPRM,ALPBD,ALPBPTN)=ALPBIEN
.S ALPRM1="" F S ALPRM1=$O(^TMP($J,"BCBU",ALPRM1)) Q:ALPRM1="" D
..S ALPRM="" F S ALPRM=$O(^TMP($J,"BCBU",ALPRM1,ALPRM)) Q:ALPRM="" D
...S ALPBD="" F S ALPBD=$O(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD)) Q:ALPBD="" D
....S ALPBPTN="" F S ALPBPTN=$O(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD,ALPBPTN)) Q:ALPBPTN="" D
.....S ALPBIEN=$G(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD,ALPBPTN)) D PRT
D DONE
Q
PRT S ALPBPDAT(0)=$G(^ALPB(53.7,ALPBIEN,0))
M ALPBPDAT(1)=^ALPB(53.7,ALPBIEN,1)
I ALPBPG=0 D PAGE
S ALPBOCT=""
F S ALPBOCT=$O(^TMP($J,ALPBPTN,ALPBOCT)) Q:ALPBOCT="" D
.S ALPBOST=""
.F S ALPBOST=$O(^TMP($J,ALPBPTN,ALPBOCT,ALPBOST)) Q:ALPBOST="" D
..S ALPBORDN=""
..F S ALPBORDN=$O(^TMP($J,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)) Q:ALPBORDN="" D
...S ALPBOIEN=^TMP($J,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)
...;D F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,.ALPBFORM)
...I $Y+ALPBFORM(0)=IOSL!($Y+ALPBFORM(0)>IOSL) D PAGE
...F ALPBX=1:1:ALPBFORM(0) W !,ALPBFORM(ALPBX)
...K ALPBDATA,ALPBFORM,ALPBOIEN,ALPBX
..K ALPBORDN
.K ALPBOST
K ALPBOCT
; print footer at end of this patient's record...
I $Y+10>IOSL D PAGE
W !!
D FOOT^ALPBFRMU
;Print a blank page between patient
W @IOF
S ALPBPG=0
K ALPBPDAT
Q
;K ALPBIEN,ALPBPDAT KILLING ALPBIEN WILL BREAK SORT BY ROOM/BED
;
DONE ;
K ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBPG,ALPBPTN,ALPBRDAT,ALPBWARD,^TMP($J),ALPRM,ALPRM1,ALPBD,ALPBIEN,ALPBSORT
I $D(ZTQUEUED) S ZTREQ="@"
Q
;
PAGE ; print page header for patient...
W @IOF
S ALPBPG=ALPBPG+1
D HDR^ALPBFRMU(.ALPBPDAT,ALPBPG,.ALPBHDR)
F ALPBX=1:1:ALPBHDR(0) W !,ALPBHDR(ALPBX)
K ALPBHDR,ALPBX
Q
ALPBPWRD ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCMA BCBU REPORT FOR A SELECTED WARD ;01/01/03
+1 ;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; NOTE: this routine is designed for hard-copy output.
+5 ; Output is formatted for 132-column printing.
+6 ;
+7 FOR
Begin DoDot:1
+8 WRITE !,"Inpatient Pharmacy Orders for a selected ward"
+9 SET DIR(0)="FAO^2:10"
+10 SET DIR("A")="Select WARD: "
+11 SET DIR("?")="^D WARDLIST^ALPBUTL(""C"")"
+12 DO ^DIR
KILL DIR
+13 IF $DATA(DIRUT)
QUIT
+14 DO WARDSEL^ALPBUTL(Y,.ALPBSEL)
+15 IF +$GET(ALPBSEL(0))=0
Begin DoDot:2
+16 WRITE $CHAR(7)
+17 WRITE " ??"
+18 DO WARDLIST^ALPBUTL("C")
+19 KILL ALPBSEL
End DoDot:2
QUIT
+20 IF +$GET(ALPBSEL(0))=1
Begin DoDot:2
+21 SET ALPBWARD=ALPBSEL(1)
+22 WRITE " ",ALPBWARD
+23 KILL ALPBSEL
End DoDot:2
+24 IF +$GET(ALPBSEL(0))>1
Begin DoDot:2
+25 SET ALPBX=0
+26 FOR
SET ALPBX=$ORDER(ALPBSEL(ALPBX))
IF 'ALPBX
QUIT
WRITE !?2,$JUSTIFY(ALPBX,2)," ",ALPBSEL(ALPBX)
+27 KILL ALPBX
+28 SET DIR(0)="NA^1:"_ALPBSEL(0)
+29 SET DIR("A")="Select Ward from the list (1-"_ALPBSEL(0)_"): "
+30 WRITE !
DO ^DIR
KILL DIR
+31 IF $DATA(DIRUT)
KILL ALPBSEL
QUIT
+32 SET ALPBWARD=ALPBSEL(+Y)
+33 KILL ALPBSEL
End DoDot:2
IF $DATA(DIRUT)
KILL DIRUT,DTOUT,X,Y
QUIT
+34 ;
+35 ; get all or just current orders?...
+36 SET DIR(0)="SA^A:ALL;C:CURRENT"
+37 SET DIR("A")="Report [A]LL or [C]URRENT orders? "
+38 SET DIR("B")="CURRENT"
+39 SET DIR("?")="[A]LL=all orders in the file, [C]URRENT=orders not yet expired."
+40 WRITE !
DO ^DIR
KILL DIR
+41 IF $DATA(DIRUT)
KILL ALPBWARD,DIRUT,DTOUT,X,Y
QUIT
+42 SET ALPBOTYP=Y
+43 ;
+44 ;SORT BY NAME OR ROOM/BED added 6/23/05
+45 SET DIR(0)="SA^N:Name;R:Room/Bed"
+46 SET DIR("A")="Sort Patients by [N]ame or [R]oom/Bed? "
+47 SET DIR("B")="Room/bed"
+48 SET DIR("?")="Sort by [N]ame or [R]oom Bed"
+49 WRITE !
DO ^DIR
KILL DIR
+50 IF $DATA(DIRUT)
KILL ALPBWARD,DIRUT,DTOUT,X,Y
QUIT
+51 SET ALPBSORT=Y
+52 ;
+53 ; print how many days MAR?...
+54 SET DIR(0)="NA^1:7"
+55 SET DIR("A")="Print how many days MAR? "
+56 SET DIR("B")=$$DEFDAYS^ALPBUTL()
+57 SET DIR("?")="The default is shown; you may enter 3 or 7."
+58 WRITE !
DO ^DIR
KILL DIR
+59 IF $DATA(DIRUT)
KILL ALPBOTYP,DIRUT,DTOUT,X,Y
QUIT
+60 SET ALPBDAYS=+Y
+61 ;
+62 ; BCMA Med Log info for how many ?...
+63 SET DIR(0)="NA^1:99"
+64 SET DIR("B")=$$DEFML^ALPBUTL3()
+65 SET DIR("A")="Select how many BCMA Medication Log history: "
+66 SET DIR("A",1)=" "
+67 SET DIR("?",1)="Select a number of BCMA Medication log entries"
+68 SET DIR("?",2)="for each of the patient's orders"
+69 SET DIR("?")="They are listed by the most current entry first"
+70 DO ^DIR
KILL DIR
+71 IF $DATA(DIRUT)
KILL ALPBOTYP,ALPBWARD,DIRUT,DTOUT,X,Y
QUIT
+72 SET ALPBMLOG=Y
+73 ;
+74 SET %ZIS="Q"
+75 SET %ZIS("B")=$$DEFPRT^ALPBUTL()
+76 IF %ZIS("B")=""
KILL %ZIS("B")
+77 WRITE !
DO ^%ZIS
KILL %ZIS
+78 IF POP
Begin DoDot:2
+79 WRITE $CHAR(7)
+80 KILL ALPBMLOG,ALPBOTYP,ALPBWARD,POP
End DoDot:2
QUIT
+81 ;
+82 ; output not queued...
+83 IF '$DATA(IO("Q"))
Begin DoDot:2
+84 USE IO
+85 DO DQ
+86 IF IO'=IO(0)
DO ^%ZISC
End DoDot:2
+87 ;
+88 ; set up the Task...
+89 IF $DATA(IO("Q"))
Begin DoDot:2
+90 SET ZTRTN="DQ^ALPBPWRD"
+91 SET ZTDESC="PSB INPT PHARM ORDERS FOR WARD "_ALPBWARD
+92 SET ZTSAVE("ALPBDAYS")=""
+93 SET ZTSAVE("ALPBWARD")=""
+94 SET ZTSAVE("ALPBMLOG")=""
+95 SET ZTSAVE("ALPBOTYP")=""
+96 SET ZTSAVE("ALPBSORT")=""
+97 SET ZTIO=ION
+98 DO ^%ZTLOAD
+99 DO HOME^%ZIS
+100 WRITE !,$SELECT($GET(ZTSK):"Task number "_ZTSK_" queued.",1:"ERROR -- NOT QUEUED!")
+101 KILL IO("Q"),ZTSK
End DoDot:2
+102 KILL ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBWARD
End DoDot:1
IF $DATA(DIRUT)
QUIT
+103 KILL DIRUT,DTOUT,X,Y
+104 QUIT
+105 ;
DQ ; output entry point...
+1 KILL ^TMP($JOB)
+2 ;
+3 ; set report date... SED 11/4/03
+4 SET ALPBRDAT=$SELECT(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=""
QUIT
Begin DoDot:1
+9 SET ALPBIEN=0
+10 FOR
SET ALPBIEN=$ORDER(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN,ALPBIEN))
IF 'ALPBIEN
QUIT
Begin DoDot:2
+11 DO ORDS^ALPBUTL(ALPBIEN,ALPBRDAT,.ALPBORDS)
+12 IF +ALPBORDS(0)'>0
KILL ALPBORDS
QUIT
+13 IF $GET(ALPBPDAT(0))=""
SET ALPBPDAT(0)=$GET(^ALPB(53.7,ALPBIEN,0))
+14 SET ALPBOIEN=0
+15 FOR
SET ALPBOIEN=$ORDER(ALPBORDS(ALPBOIEN))
IF 'ALPBOIEN
QUIT
Begin DoDot:3
+16 SET ALPBDATA=$GET(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,1))
+17 SET ALPBOCT=$PIECE($GET(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,3)),U,1)
+18 IF $PIECE($GET(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,4)),U,3)["PRN"
SET ALPBOCT=ALPBOCT_"P"
+19 ; if report is for "C"urrent, check stop date and quit if
+20 ; stop date is less than report date...
+21 IF ALPBOTYP="C"&($PIECE(ALPBDATA,U,2)<ALPBRDAT)
KILL ALPBDATA
QUIT
+22 SET ALPBORDN=ALPBORDS(ALPBOIEN)
+23 SET ALPBOST=$$STAT2^ALPBUTL1(ALPBORDS(ALPBOIEN,2))
+24 IF '$DATA(^TMP($JOB,ALPBPTN))
SET ^TMP($JOB,ALPBPTN)=ALPBIEN
+25 SET ^TMP($JOB,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)=ALPBOIEN
+26 KILL ALPBDATA,ALPBORDN,ALPBOST
End DoDot:3
+27 KILL ALPBOIEN,ALPBORDS,ALPBPDAT
End DoDot:2
+28 KILL ALPBIEN
End DoDot:1
+29 KILL ALPBPTN
+30 ;
+31 ; Sort by Patient Name or room/bed capability added 6/23/05 KFOX
+32 SET ALPBPG=0
+33 SET ALPBPTN=""
+34 IF ALPBSORT="N"
Begin DoDot:1
+35 FOR
SET ALPBPTN=$ORDER(^TMP($JOB,ALPBPTN))
IF ALPBPTN=""
QUIT
SET ALPBIEN=^TMP($JOB,ALPBPTN)
DO PRT
End DoDot:1
+36 ;SORT BY ROOM/BED
+37 IF ALPBSORT="R"
Begin DoDot:1
+38 SET ALPBD=""
SET ALPRM=""
+39 FOR
SET ALPBPTN=$ORDER(^TMP($JOB,ALPBPTN))
IF ALPBPTN=""
QUIT
Begin DoDot:2
+40 ;SKIP "BCBU" SUBSCRIBE
IF ALPBPTN="BCBU"
SET ALPBPTN=$ORDER(^TMP($JOB,ALPBPTN))
+41 ;PSB*3*37 Stop null subscript when "BCBU" is the last entry in ^TMP
IF ALPBPTN=""
QUIT
+42 SET ALPBIEN=^TMP($JOB,ALPBPTN)
SET ALPRM=$PIECE($GET(^ALPB(53.7,ALPBIEN,0)),"^",6)
SET ALPBD=$PIECE($GET(^ALPB(53.7,ALPBIEN,0)),"^",7)
+43 ;INCASE NO ROOM AND BED YET
IF ALPBD=""
SET ALPB="NONE"
IF ALPRM=""
SET ALPB="NONE"
+44 SET ^TMP($JOB,"BCBU",ALPRM,ALPRM,ALPBD,ALPBPTN)=ALPBIEN
End DoDot:2
IF ALPBPTN=""
QUIT
+45 SET ALPRM1=""
FOR
SET ALPRM1=$ORDER(^TMP($JOB,"BCBU",ALPRM1))
IF ALPRM1=""
QUIT
Begin DoDot:2
+46 SET ALPRM=""
FOR
SET ALPRM=$ORDER(^TMP($JOB,"BCBU",ALPRM1,ALPRM))
IF ALPRM=""
QUIT
Begin DoDot:3
+47 SET ALPBD=""
FOR
SET ALPBD=$ORDER(^TMP($JOB,"BCBU",ALPRM1,ALPRM,ALPBD))
IF ALPBD=""
QUIT
Begin DoDot:4
+48 SET ALPBPTN=""
FOR
SET ALPBPTN=$ORDER(^TMP($JOB,"BCBU",ALPRM1,ALPRM,ALPBD,ALPBPTN))
IF ALPBPTN=""
QUIT
Begin DoDot:5
+49 SET ALPBIEN=$GET(^TMP($JOB,"BCBU",ALPRM1,ALPRM,ALPBD,ALPBPTN))
DO PRT
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+50 DO DONE
+51 QUIT
PRT SET ALPBPDAT(0)=$GET(^ALPB(53.7,ALPBIEN,0))
+1 MERGE ALPBPDAT(1)=^ALPB(53.7,ALPBIEN,1)
+2 IF ALPBPG=0
DO PAGE
+3 SET ALPBOCT=""
+4 FOR
SET ALPBOCT=$ORDER(^TMP($JOB,ALPBPTN,ALPBOCT))
IF ALPBOCT=""
QUIT
Begin DoDot:1
+5 SET ALPBOST=""
+6 FOR
SET ALPBOST=$ORDER(^TMP($JOB,ALPBPTN,ALPBOCT,ALPBOST))
IF ALPBOST=""
QUIT
Begin DoDot:2
+7 SET ALPBORDN=""
+8 FOR
SET ALPBORDN=$ORDER(^TMP($JOB,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN))
IF ALPBORDN=""
QUIT
Begin DoDot:3
+9 SET ALPBOIEN=^TMP($JOB,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)
+10 ; get and print this order's data...
+11 MERGE ALPBDATA=^ALPB(53.7,ALPBIEN,2,ALPBOIEN)
+12 DO F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,ALPBMLOG,.ALPBFORM,ALPBIEN)
+13 ;D F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,.ALPBFORM)
+14 IF $Y+ALPBFORM(0)=IOSL!($Y+ALPBFORM(0)>IOSL)
DO PAGE
+15 FOR ALPBX=1:1:ALPBFORM(0)
WRITE !,ALPBFORM(ALPBX)
+16 KILL ALPBDATA,ALPBFORM,ALPBOIEN,ALPBX
End DoDot:3
+17 KILL ALPBORDN
End DoDot:2
+18 KILL ALPBOST
End DoDot:1
+19 KILL ALPBOCT
+20 ; print footer at end of this patient's record...
+21 IF $Y+10>IOSL
DO PAGE
+22 WRITE !!
+23 DO FOOT^ALPBFRMU
+24 ;Print a blank page between patient
+25 WRITE @IOF
+26 SET ALPBPG=0
+27 KILL ALPBPDAT
+28 QUIT
+29 ;K ALPBIEN,ALPBPDAT KILLING ALPBIEN WILL BREAK SORT BY ROOM/BED
+30 ;
DONE ;
+1 KILL ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBPG,ALPBPTN,ALPBRDAT,ALPBWARD,^TMP($JOB),ALPRM,ALPRM1,ALPBD,ALPBIEN,ALPBSORT
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 QUIT
+4 ;
PAGE ; print page header for patient...
+1 WRITE @IOF
+2 SET ALPBPG=ALPBPG+1
+3 DO HDR^ALPBFRMU(.ALPBPDAT,ALPBPG,.ALPBHDR)
+4 FOR ALPBX=1:1:ALPBHDR(0)
WRITE !,ALPBHDR(ALPBX)
+5 KILL ALPBHDR,ALPBX
+6 QUIT
