ALPBPWRD ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCMA BCBU REPORT FOR A SELECTED WARD ; 2/27/13 2:24pm
;;3.0;BAR CODE MED ADMIN;**8,37,48,59,73**;Mar 2004;Build 31
;;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.
;
;*73 Add Clinic Order (CO) identification and clinic name print with
; CO's sorting after IM meds.
;
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
.;
.;added in PSB*3*59 to benefit users located at the long term care and domiciliary sites.
.;include patients without active medications?...
.S ALPBWOMD=""
.I ALPBOTYP="C" D
..S DIR(0)="SA^Y:YES;N:NO"
..S DIR("A")="Include Patients Without Active Medications? "
..S DIR("B")="YES"
..S DIR("?",1)="[Y]es=include patients without active medication orders,"
..S DIR("?",2)="[N]o=do not include patients without active medication orders."
..W ! D ^DIR K DIR
..I $D(DIRUT) K ALPBOTYP,DIRUT,DTOUT,X,Y Q
..S ALPBWOMD=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,ALPBWOMD,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; please select a number 1 to 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,ALPBWOMD
.;
.; 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 ZTSAVE("ALPBWOMD")=""
..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,ALPBWOMD
K DIRUT,DTOUT,X,Y
Q
;
DQ ; output entry point...
K ^TMP($J)
N ALPBCLIN ;*73
;
; set report date... SED 11/4/03
S ALPBRDAT=$S(ALPBOTYP="C":$$NOW^XLFDT(),1:"")
;
; loop through ward cross reference in 53.7...
N ALPBDRGNAME
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 $G(ALPBPDAT(0))="" S ALPBPDAT(0)=$G(^ALPB(53.7,ALPBIEN,0))
..I +ALPBORDS(0)'>0&(ALPBWOMD="Y") D Q
...S ^TMP($J,ALPBPTN)=ALPBIEN
...K ALPBORDS
..S ALPBOIEN=0
..F S ALPBOIEN=$O(ALPBORDS(ALPBOIEN)) Q:'ALPBOIEN D
...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,1))
...S ALPBDAT0=$G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,0)) ;*73
...S ALPBCLIN=$P(ALPBDAT0,U,5) S:ALPBCLIN="" ALPBCLIN=0 ;*73
...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"
...;drug name being used for alpha-sorting medications within order types (unit dose, unit dose-PRN, intravenous, intravenous-PRN)
...S ALPBDRGNAME=$P($G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,7,1,0)),U,2)
...S:ALPBDRGNAME="" ALPBDRGNAME="NOT FOUND" ;*73
...; 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,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST,ALPBORDN)=ALPBOIEN ;*73
...K ALPBDATA,ALPBDAT0,ALPBORDN,ALPBOST,ALPBDRGNAME
..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)
..S:$TR(ALPBD,"""","")="" ALPBD="NONE" S:$TR(ALPRM,"""","")="" ALPRM="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
N ALPBNOMDS
S ALPBNOMDS=""
S:$D(^TMP($J,ALPBPTN))=1 ALPBNOMDS=1
S ALPBCLIN="" ;*73
F S ALPBCLIN=$O(^TMP($J,ALPBPTN,ALPBCLIN)) Q:ALPBCLIN="" D ;*73
.S ALPBOCT=""
.F S ALPBOCT=$O(^TMP($J,ALPBPTN,ALPBCLIN,ALPBOCT)) Q:ALPBOCT="" D
..S ALPBDRGNAME=""
..F S ALPBDRGNAME=$O(^TMP($J,ALPBPTN,ALPBCLIN,ALPBOCT,ALPBDRGNAME)) Q:ALPBDRGNAME="" D
...S ALPBOST=""
...F S ALPBOST=$O(^TMP($J,ALPBPTN,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST)) Q:ALPBOST="" D
....S ALPBORDN=""
....F S ALPBORDN=$O(^TMP($J,ALPBPTN,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST,ALPBORDN)) Q:ALPBORDN="" D
.....S ALPBOIEN=^TMP($J,ALPBPTN,ALPBCLIN,ALPBOCT,ALPBDRGNAME,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 ALPBDRGNAME
.K ALPBOCT
; print footer at end of this patient's record...
I $Y+10>IOSL D PAGE
;notification message displays one line below header info if patient has no med orders when the report is generated
I ALPBNOMDS D
.W !!,"No Active Medication Orders were reported to the Contingency at the time the MAR was printed ",!!!
.;additional blank lines added to separate footer from header and allow room for notes
.I $E(IOST)="P" F Q:$Y>=(IOSL-6) W !
;
D FOOT^ALPBFRMU
;Print a blank page between patient (this was removed by PSB*3*59 - the BCMA Workgroup agreed to condense the report)
;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,ALPBNOMDS
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HALPBPWRD 9166 printed Dec 13, 2024@01:39:33 Page 2
ALPBPWRD ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCMA BCBU REPORT FOR A SELECTED WARD ; 2/27/13 2:24pm
+1 ;;3.0;BAR CODE MED ADMIN;**8,37,48,59,73**;Mar 2004;Build 31
+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 ;*73 Add Clinic Order (CO) identification and clinic name print with
+8 ; CO's sorting after IM meds.
+9 ;
+10 FOR
Begin DoDot:1
+11 WRITE !,"Inpatient Pharmacy Orders for a selected ward"
+12 SET DIR(0)="FAO^2:10"
+13 SET DIR("A")="Select WARD: "
+14 SET DIR("?")="^D WARDLIST^ALPBUTL(""C"")"
+15 DO ^DIR
KILL DIR
+16 IF $DATA(DIRUT)
QUIT
+17 DO WARDSEL^ALPBUTL(Y,.ALPBSEL)
+18 IF +$GET(ALPBSEL(0))=0
Begin DoDot:2
+19 WRITE $CHAR(7)
+20 WRITE " ??"
+21 DO WARDLIST^ALPBUTL("C")
+22 KILL ALPBSEL
End DoDot:2
QUIT
+23 IF +$GET(ALPBSEL(0))=1
Begin DoDot:2
+24 SET ALPBWARD=ALPBSEL(1)
+25 WRITE " ",ALPBWARD
+26 KILL ALPBSEL
End DoDot:2
+27 IF +$GET(ALPBSEL(0))>1
Begin DoDot:2
+28 SET ALPBX=0
+29 FOR
SET ALPBX=$ORDER(ALPBSEL(ALPBX))
if 'ALPBX
QUIT
WRITE !?2,$JUSTIFY(ALPBX,2)," ",ALPBSEL(ALPBX)
+30 KILL ALPBX
+31 SET DIR(0)="NA^1:"_ALPBSEL(0)
+32 SET DIR("A")="Select Ward from the list (1-"_ALPBSEL(0)_"): "
+33 WRITE !
DO ^DIR
KILL DIR
+34 IF $DATA(DIRUT)
KILL ALPBSEL
QUIT
+35 SET ALPBWARD=ALPBSEL(+Y)
+36 KILL ALPBSEL
End DoDot:2
IF $DATA(DIRUT)
KILL DIRUT,DTOUT,X,Y
QUIT
+37 ;
+38 ; get all or just current orders?...
+39 SET DIR(0)="SA^A:ALL;C:CURRENT"
+40 SET DIR("A")="Report [A]LL or [C]URRENT orders? "
+41 SET DIR("B")="CURRENT"
+42 SET DIR("?")="[A]LL=all orders in the file, [C]URRENT=orders not yet expired."
+43 WRITE !
DO ^DIR
KILL DIR
+44 IF $DATA(DIRUT)
KILL ALPBWARD,DIRUT,DTOUT,X,Y
QUIT
+45 SET ALPBOTYP=Y
+46 ;
+47 ;added in PSB*3*59 to benefit users located at the long term care and domiciliary sites.
+48 ;include patients without active medications?...
+49 SET ALPBWOMD=""
+50 IF ALPBOTYP="C"
Begin DoDot:2
+51 SET DIR(0)="SA^Y:YES;N:NO"
+52 SET DIR("A")="Include Patients Without Active Medications? "
+53 SET DIR("B")="YES"
+54 SET DIR("?",1)="[Y]es=include patients without active medication orders,"
+55 SET DIR("?",2)="[N]o=do not include patients without active medication orders."
+56 WRITE !
DO ^DIR
KILL DIR
+57 IF $DATA(DIRUT)
KILL ALPBOTYP,DIRUT,DTOUT,X,Y
QUIT
+58 SET ALPBWOMD=Y
End DoDot:2
+59 ;
+60 ;SORT BY NAME OR ROOM/BED added 6/23/05
+61 SET DIR(0)="SA^N:Name;R:Room/Bed"
+62 SET DIR("A")="Sort Patients by [N]ame or [R]oom/Bed? "
+63 SET DIR("B")="Room/bed"
+64 SET DIR("?")="Sort by [N]ame or [R]oom Bed"
+65 WRITE !
DO ^DIR
KILL DIR
+66 IF $DATA(DIRUT)
KILL ALPBWARD,ALPBWOMD,DIRUT,DTOUT,X,Y
QUIT
+67 SET ALPBSORT=Y
+68 ;
+69 ; print how many days MAR?...
+70 SET DIR(0)="NA^1:7"
+71 SET DIR("A")="Print how many days MAR? "
+72 SET DIR("B")=$$DEFDAYS^ALPBUTL()
+73 SET DIR("?")="The default is shown; please select a number 1 to 7."
+74 WRITE !
DO ^DIR
KILL DIR
+75 IF $DATA(DIRUT)
KILL ALPBOTYP,DIRUT,DTOUT,X,Y
QUIT
+76 SET ALPBDAYS=+Y
+77 ;
+78 ; BCMA Med Log info for how many ?...
+79 SET DIR(0)="NA^1:99"
+80 SET DIR("B")=$$DEFML^ALPBUTL3()
+81 SET DIR("A")="Select how many BCMA Medication Log history: "
+82 SET DIR("A",1)=" "
+83 SET DIR("?",1)="Select a number of BCMA Medication log entries"
+84 SET DIR("?",2)="for each of the patient's orders"
+85 SET DIR("?")="They are listed by the most current entry first"
+86 DO ^DIR
KILL DIR
+87 IF $DATA(DIRUT)
KILL ALPBOTYP,ALPBWARD,DIRUT,DTOUT,X,Y
QUIT
+88 SET ALPBMLOG=Y
+89 ;
+90 SET %ZIS="Q"
+91 SET %ZIS("B")=$$DEFPRT^ALPBUTL()
+92 IF %ZIS("B")=""
KILL %ZIS("B")
+93 WRITE !
DO ^%ZIS
KILL %ZIS
+94 IF POP
Begin DoDot:2
+95 WRITE $CHAR(7)
+96 KILL ALPBMLOG,ALPBOTYP,ALPBWARD,POP,ALPBWOMD
End DoDot:2
QUIT
+97 ;
+98 ; output not queued...
+99 IF '$DATA(IO("Q"))
Begin DoDot:2
+100 USE IO
+101 DO DQ
+102 IF IO'=IO(0)
DO ^%ZISC
End DoDot:2
+103 ;
+104 ; set up the Task...
+105 IF $DATA(IO("Q"))
Begin DoDot:2
+106 SET ZTRTN="DQ^ALPBPWRD"
+107 SET ZTDESC="PSB INPT PHARM ORDERS FOR WARD "_ALPBWARD
+108 SET ZTSAVE("ALPBDAYS")=""
+109 SET ZTSAVE("ALPBWARD")=""
+110 SET ZTSAVE("ALPBMLOG")=""
+111 SET ZTSAVE("ALPBOTYP")=""
+112 SET ZTSAVE("ALPBSORT")=""
+113 SET ZTSAVE("ALPBWOMD")=""
+114 SET ZTIO=ION
+115 DO ^%ZTLOAD
+116 DO HOME^%ZIS
+117 WRITE !,$SELECT($GET(ZTSK):"Task number "_ZTSK_" queued.",1:"ERROR -- NOT QUEUED!")
+118 KILL IO("Q"),ZTSK
End DoDot:2
+119 KILL ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBWARD,ALPBWOMD
End DoDot:1
if $DATA(DIRUT)
QUIT
+120 KILL DIRUT,DTOUT,X,Y
+121 QUIT
+122 ;
DQ ; output entry point...
+1 KILL ^TMP($JOB)
+2 ;*73
NEW ALPBCLIN
+3 ;
+4 ; set report date... SED 11/4/03
+5 SET ALPBRDAT=$SELECT(ALPBOTYP="C":$$NOW^XLFDT(),1:"")
+6 ;
+7 ; loop through ward cross reference in 53.7...
+8 NEW ALPBDRGNAME
+9 SET ALPBPTN=""
+10 FOR
SET ALPBPTN=$ORDER(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN))
if ALPBPTN=""
QUIT
Begin DoDot:1
+11 SET ALPBIEN=0
+12 FOR
SET ALPBIEN=$ORDER(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN,ALPBIEN))
if 'ALPBIEN
QUIT
Begin DoDot:2
+13 DO ORDS^ALPBUTL(ALPBIEN,ALPBRDAT,.ALPBORDS)
+14 IF $GET(ALPBPDAT(0))=""
SET ALPBPDAT(0)=$GET(^ALPB(53.7,ALPBIEN,0))
+15 IF +ALPBORDS(0)'>0&(ALPBWOMD="Y")
Begin DoDot:3
+16 SET ^TMP($JOB,ALPBPTN)=ALPBIEN
+17 KILL ALPBORDS
End DoDot:3
QUIT
+18 SET ALPBOIEN=0
+19 FOR
SET ALPBOIEN=$ORDER(ALPBORDS(ALPBOIEN))
if 'ALPBOIEN
QUIT
Begin DoDot:3
+20 SET ALPBDATA=$GET(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,1))
+21 ;*73
SET ALPBDAT0=$GET(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,0))
+22 ;*73
SET ALPBCLIN=$PIECE(ALPBDAT0,U,5)
if ALPBCLIN=""
SET ALPBCLIN=0
+23 SET ALPBOCT=$PIECE($GET(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,3)),U,1)
+24 if $PIECE($GET(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,4)),U,3)["PRN"
SET ALPBOCT=ALPBOCT_"P"
+25 ;drug name being used for alpha-sorting medications within order types (unit dose, unit dose-PRN, intravenous, intravenous-PRN)
+26 SET ALPBDRGNAME=$PIECE($GET(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,7,1,0)),U,2)
+27 ;*73
if ALPBDRGNAME=""
SET ALPBDRGNAME="NOT FOUND"
+28 ; if report is for "C"urrent, check stop date and quit if
+29 ; stop date is less than report date
+30 IF ALPBOTYP="C"&($PIECE(ALPBDATA,U,2)<ALPBRDAT)
KILL ALPBDATA
QUIT
+31 SET ALPBORDN=ALPBORDS(ALPBOIEN)
+32 SET ALPBOST=$$STAT2^ALPBUTL1(ALPBORDS(ALPBOIEN,2))
+33 IF '$DATA(^TMP($JOB,ALPBPTN))
SET ^TMP($JOB,ALPBPTN)=ALPBIEN
+34 ;*73
SET ^TMP($JOB,ALPBPTN,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST,ALPBORDN)=ALPBOIEN
+35 KILL ALPBDATA,ALPBDAT0,ALPBORDN,ALPBOST,ALPBDRGNAME
End DoDot:3
+36 KILL ALPBOIEN,ALPBORDS,ALPBPDAT
End DoDot:2
+37 KILL ALPBIEN
End DoDot:1
+38 KILL ALPBPTN
+39 ;
+40 ; Sort by Patient Name or room/bed capability added 6/23/05 KFOX
+41 SET ALPBPG=0
+42 SET ALPBPTN=""
+43 IF ALPBSORT="N"
Begin DoDot:1
+44 FOR
SET ALPBPTN=$ORDER(^TMP($JOB,ALPBPTN))
if ALPBPTN=""
QUIT
SET ALPBIEN=^TMP($JOB,ALPBPTN)
DO PRT
End DoDot:1
+45 ;SORT BY ROOM/BED
+46 IF ALPBSORT="R"
Begin DoDot:1
+47 SET ALPBD=""
SET ALPRM=""
+48 FOR
SET ALPBPTN=$ORDER(^TMP($JOB,ALPBPTN))
if ALPBPTN=""
QUIT
Begin DoDot:2
+49 ;SKIP "BCBU" SUBSCRIBE
IF ALPBPTN="BCBU"
SET ALPBPTN=$ORDER(^TMP($JOB,ALPBPTN))
+50 ;PSB*3*37 Stop null subscript when "BCBU" is the last entry in ^TMP
IF ALPBPTN=""
QUIT
+51 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)
+52 ;INCASE NO ROOM AND BED YET
if $TRANSLATE(ALPBD,"""","")=""
SET ALPBD="NONE"
if $TRANSLATE(ALPRM,"""","")=""
SET ALPRM="NONE"
+53 SET ^TMP($JOB,"BCBU",ALPRM,ALPRM,ALPBD,ALPBPTN)=ALPBIEN
End DoDot:2
if ALPBPTN=""
QUIT
+54 SET ALPRM1=""
FOR
SET ALPRM1=$ORDER(^TMP($JOB,"BCBU",ALPRM1))
if ALPRM1=""
QUIT
Begin DoDot:2
+55 SET ALPRM=""
FOR
SET ALPRM=$ORDER(^TMP($JOB,"BCBU",ALPRM1,ALPRM))
if ALPRM=""
QUIT
Begin DoDot:3
+56 SET ALPBD=""
FOR
SET ALPBD=$ORDER(^TMP($JOB,"BCBU",ALPRM1,ALPRM,ALPBD))
if ALPBD=""
QUIT
Begin DoDot:4
+57 SET ALPBPTN=""
FOR
SET ALPBPTN=$ORDER(^TMP($JOB,"BCBU",ALPRM1,ALPRM,ALPBD,ALPBPTN))
if ALPBPTN=""
QUIT
Begin DoDot:5
+58 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
+59 DO DONE
+60 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 NEW ALPBNOMDS
+4 SET ALPBNOMDS=""
+5 if $DATA(^TMP($JOB,ALPBPTN))=1
SET ALPBNOMDS=1
+6 ;*73
SET ALPBCLIN=""
+7 ;*73
FOR
SET ALPBCLIN=$ORDER(^TMP($JOB,ALPBPTN,ALPBCLIN))
if ALPBCLIN=""
QUIT
Begin DoDot:1
+8 SET ALPBOCT=""
+9 FOR
SET ALPBOCT=$ORDER(^TMP($JOB,ALPBPTN,ALPBCLIN,ALPBOCT))
if ALPBOCT=""
QUIT
Begin DoDot:2
+10 SET ALPBDRGNAME=""
+11 FOR
SET ALPBDRGNAME=$ORDER(^TMP($JOB,ALPBPTN,ALPBCLIN,ALPBOCT,ALPBDRGNAME))
if ALPBDRGNAME=""
QUIT
Begin DoDot:3
+12 SET ALPBOST=""
+13 FOR
SET ALPBOST=$ORDER(^TMP($JOB,ALPBPTN,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST))
if ALPBOST=""
QUIT
Begin DoDot:4
+14 SET ALPBORDN=""
+15 FOR
SET ALPBORDN=$ORDER(^TMP($JOB,ALPBPTN,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST,ALPBORDN))
if ALPBORDN=""
QUIT
Begin DoDot:5
+16 SET ALPBOIEN=^TMP($JOB,ALPBPTN,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST,ALPBORDN)
+17 ; get and print this order's data...
+18 MERGE ALPBDATA=^ALPB(53.7,ALPBIEN,2,ALPBOIEN)
+19 DO F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,ALPBMLOG,.ALPBFORM,ALPBIEN)
+20 ;D F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,.ALPBFORM)
+21 IF $Y+ALPBFORM(0)=IOSL!($Y+ALPBFORM(0)>IOSL)
DO PAGE
+22 FOR ALPBX=1:1:ALPBFORM(0)
WRITE !,ALPBFORM(ALPBX)
+23 KILL ALPBDATA,ALPBFORM,ALPBOIEN,ALPBX
End DoDot:5
+24 KILL ALPBORDN
End DoDot:4
+25 KILL ALPBOST
End DoDot:3
+26 KILL ALPBDRGNAME
End DoDot:2
+27 KILL ALPBOCT
End DoDot:1
+28 ; print footer at end of this patient's record...
+29 IF $Y+10>IOSL
DO PAGE
+30 ;notification message displays one line below header info if patient has no med orders when the report is generated
+31 IF ALPBNOMDS
Begin DoDot:1
+32 WRITE !!,"No Active Medication Orders were reported to the Contingency at the time the MAR was printed ",!!!
+33 ;additional blank lines added to separate footer from header and allow room for notes
+34 IF $EXTRACT(IOST)="P"
FOR
if $Y>=(IOSL-6)
QUIT
WRITE !
End DoDot:1
+35 ;
+36 DO FOOT^ALPBFRMU
+37 ;Print a blank page between patient (this was removed by PSB*3*59 - the BCMA Workgroup agreed to condense the report)
+38 ;W @IOF
+39 SET ALPBPG=0
+40 KILL ALPBPDAT
+41 QUIT
+42 ;K ALPBIEN,ALPBPDAT KILLING ALPBIEN WILL BREAK SORT BY ROOM/BED
+43 ;
DONE ;
+1 KILL ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBPG,ALPBPTN,ALPBRDAT,ALPBWARD,^TMP($JOB),ALPRM,ALPRM1,ALPBD,ALPBIEN,ALPBSORT,ALPBNOMDS
+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
