ALPBPPAT ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCBU BACKUP REPORT FOR A SELECTED PATIENT ;2/13/13 13:13pm
;;3.0;BAR CODE MED ADMIN;**8,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 patient"
.S DIR(0)="PAO^53.7:QEMZ"
.S DIR("A")="Select PATIENT NAME: "
.D ^DIR K DIR
.I $D(DIRUT) K X,Y Q
.S ALPBIEN=+Y
.S ALPBPTN=Y(0,0)
.; 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; 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
..K ALPBIEN,ALPBPTN,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^ALPBPPAT"
..S ZTIO=ION
..S ZTDESC="PSB INPT PHARM ORDERS FOR "_ALPBPTN
..S ZTSAVE("ALPBDAYS")=""
..S ZTSAVE("ALPBIEN")=""
..S ZTSAVE("ALPBMLOG")=""
..S ZTSAVE("ALPBOTYP")=""
..D ^%ZTLOAD
..D HOME^%ZIS
..W !!,$S(+$G(ZTSK):"Task "_ZTSK_" queued.",1:"ERROR: NOT QUEUED!")
..K IO("Q"),ZTSK
.;
.K ALPBDAYS,ALPBIEN,ALPBMLOG,ALPBOTYP,ALPBPTN,X,Y
K DIRUT,DTOUT,X,Y
Q
;
DQ ; output entry point...
K ^TMP($J)
N ALPBCLIN ;*73
;
; set report date...
S ALPBRDAT=$$NOW^XLFDT()
S ALPBPT(0)=$G(^ALPB(53.7,ALPBIEN,0))
M ALPBPT(1)=^ALPB(53.7,ALPBIEN,1)
S ALPBPG=1
D HDR^ALPBFRMU(.ALPBPT,ALPBPG,.ALPBHDR)
F I=1:1:ALPBHDR(0) W !,ALPBHDR(I)
K ALPBHDR
;
; loop through orders and sort by order status...
N ALPBNOMEDS1,ALPBDRGNAME
S ALPBOIEN=0,ALPBNOMEDS1=1
F S ALPBOIEN=$O(^ALPB(53.7,ALPBIEN,2,ALPBOIEN)) Q:'ALPBOIEN D
.M ALPBDATA=^ALPB(53.7,ALPBIEN,2,ALPBOIEN)
.; if report type is "C"urrent and stop date is less than report date then quit and if status contains 'on hold' do not print and quit...
.I ALPBOTYP="C" D Q:'$D(ALPBDATA)
..I $$STAT^ALPBUTL1($E($P(ALPBDATA(0),U,3),1,2))["on hold" K ALPBDATA Q
..I $G(ALPBDATA(1))="" K ALPBDATA Q
..I $P(ALPBDATA(1),U,2)<ALPBRDAT K ALPBDATA
.S ALPBNOMEDS1=0
.S ALPBCLIN=$P(ALPBDATA(0),U,5) S:ALPBCLIN="" ALPBCLIN=0 ;*73
.S ALPBORDN=$P(ALPBDATA(0),U)
.S ALPBOCT=$P($G(ALPBDATA(3)),U,1)
.S:$P($G(ALPBDATA(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(ALPBDATA(7,1,0)),U,2)
.; gets the medications order status based on the order status code
.S ALPBOST=$$STAT2^ALPBUTL1($P($P($G(ALPBDATA(0),"XX"),U,3),"~"))
.S ^TMP($J,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST,ALPBORDN)=ALPBOIEN
.K ALPBDATA,ALPBOST,ALPBOCT,ALPBDRGNAME
;
; loop through the sorted orders...
S ALPBCLIN=""
F S ALPBCLIN=$O(^TMP($J,ALPBCLIN)) Q:ALPBCLIN="" D
.S ALPBOCT=""
.F S ALPBOCT=$O(^TMP($J,ALPBCLIN,ALPBOCT)) Q:ALPBOCT="" D
..S ALPBDRGNAME=""
..F S ALPBDRGNAME=$O(^TMP($J,ALPBCLIN,ALPBOCT,ALPBDRGNAME)) Q:ALPBDRGNAME="" D
...S ALPBOST=""
...F S ALPBOST=$O(^TMP($J,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST)) Q:ALPBOST="" D
....S ALPBORDN=""
....F S ALPBORDN=$O(^TMP($J,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST,ALPBORDN)) Q:ALPBORDN="" D
.....S ALPBOIEN=^TMP($J,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST,ALPBORDN)
.....M ALPBDATA=^ALPB(53.7,ALPBIEN,2,ALPBOIEN)
.....W !
.....D F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,ALPBMLOG,.ALPBFORM,ALPBIEN)
.....; paginate?...
.....I $Y+ALPBFORM(0)=IOSL!($Y+ALPBFORM(0)>IOSL) D
......W @IOF
......S ALPBPG=ALPBPG+1
......D HDR^ALPBFRMU(.ALPBPT,ALPBPG,.ALPBHDR)
......F I=1:1:ALPBHDR(0) W !,ALPBHDR(I)
......W !
......K ALPBHDR
.....F I=1:1:ALPBFORM(0) W !,ALPBFORM(I)
.....K ALPBDATA,ALPBFORM
....K ALPBORDN
...K ALPBOST
..K ALPBDRGNAME
.K ALPBOCT
;
;notification message displays one line below header info if patient has no med orders when the report is generated
I ALPBNOMEDS1 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 !
;
; print footer at end of this patient's record...
D FOOT^ALPBFRMU
;
K ALPBDAYS,ALPBMLOG,ALPBOIEN,ALPBORDN,ALPBOST,ALPBOTYP,ALPBPG,ALPBPT,ALPBRDAT,^TMP($J),ALPBNOMEDS1
I $D(ZTQUEUED) S ZTREQ="@"
;
; write form feed at end if output device is a printer...
I $E(IOST)="P" W @IOF
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HALPBPPAT 5713 printed Apr 09, 2024@20:46:08 Page 2
ALPBPPAT ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCBU BACKUP REPORT FOR A SELECTED PATIENT ;2/13/13 13:13pm
+1 ;;3.0;BAR CODE MED ADMIN;**8,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 patient"
+12 SET DIR(0)="PAO^53.7:QEMZ"
+13 SET DIR("A")="Select PATIENT NAME: "
+14 DO ^DIR
KILL DIR
+15 IF $DATA(DIRUT)
KILL X,Y
QUIT
+16 SET ALPBIEN=+Y
+17 SET ALPBPTN=Y(0,0)
+18 ; get all or just current orders?...
+19 SET DIR(0)="SA^A:ALL;C:CURRENT"
+20 SET DIR("A")="Report [A]LL or [C]URRENT orders? "
+21 SET DIR("B")="CURRENT"
+22 SET DIR("?")="[A]LL=all orders in the file, [C]URRENT=orders not yet expired."
+23 WRITE !
DO ^DIR
KILL DIR
+24 IF $DATA(DIRUT)
KILL DIRUT,DTOUT,X,Y
QUIT
+25 SET ALPBOTYP=Y
+26 ;
+27 ; print how many days MAR?...
+28 SET DIR(0)="NA^1:7"
+29 SET DIR("A")="Print how many days MAR? "
+30 SET DIR("B")=$$DEFDAYS^ALPBUTL()
+31 SET DIR("?")="The default is shown; please select a number 1 to 7."
+32 WRITE !
DO ^DIR
KILL DIR
+33 IF $DATA(DIRUT)
KILL ALPBOTYP,DIRUT,DTOUT,X,Y
QUIT
+34 SET ALPBDAYS=+Y
+35 ;
+36 ; BCMA Med Log info for how many ?...
+37 SET DIR(0)="NA^1:99"
+38 SET DIR("B")=$$DEFML^ALPBUTL3()
+39 SET DIR("A")="Select how many BCMA Medication Log history: "
+40 SET DIR("A",1)=" "
+41 SET DIR("?",1)="Select a number of BCMA Medication log entries"
+42 SET DIR("?",2)="for each of the patient's orders"
+43 SET DIR("?")="They are listed by the most current entry first"
+44 DO ^DIR
KILL DIR
+45 IF $DATA(DIRUT)
KILL ALPBOTYP,ALPBWARD,DIRUT,DTOUT,X,Y
QUIT
+46 SET ALPBMLOG=Y
+47 ;
+48 SET %ZIS="Q"
+49 SET %ZIS("B")=$$DEFPRT^ALPBUTL()
+50 IF %ZIS("B")=""
KILL %ZIS("B")
+51 WRITE !
DO ^%ZIS
KILL %ZIS
+52 IF POP
Begin DoDot:2
+53 KILL ALPBIEN,ALPBPTN,POP
End DoDot:2
QUIT
+54 ;
+55 ; output not queued...
+56 IF '$DATA(IO("Q"))
Begin DoDot:2
+57 USE IO
+58 DO DQ
+59 IF IO'=IO(0)
DO ^%ZISC
End DoDot:2
+60 ;
+61 ; set up the Task...
+62 IF $DATA(IO("Q"))
Begin DoDot:2
+63 SET ZTRTN="DQ^ALPBPPAT"
+64 SET ZTIO=ION
+65 SET ZTDESC="PSB INPT PHARM ORDERS FOR "_ALPBPTN
+66 SET ZTSAVE("ALPBDAYS")=""
+67 SET ZTSAVE("ALPBIEN")=""
+68 SET ZTSAVE("ALPBMLOG")=""
+69 SET ZTSAVE("ALPBOTYP")=""
+70 DO ^%ZTLOAD
+71 DO HOME^%ZIS
+72 WRITE !!,$SELECT(+$GET(ZTSK):"Task "_ZTSK_" queued.",1:"ERROR: NOT QUEUED!")
+73 KILL IO("Q"),ZTSK
End DoDot:2
+74 ;
+75 KILL ALPBDAYS,ALPBIEN,ALPBMLOG,ALPBOTYP,ALPBPTN,X,Y
End DoDot:1
if $DATA(DIRUT)
QUIT
+76 KILL DIRUT,DTOUT,X,Y
+77 QUIT
+78 ;
DQ ; output entry point...
+1 KILL ^TMP($JOB)
+2 ;*73
NEW ALPBCLIN
+3 ;
+4 ; set report date...
+5 SET ALPBRDAT=$$NOW^XLFDT()
+6 SET ALPBPT(0)=$GET(^ALPB(53.7,ALPBIEN,0))
+7 MERGE ALPBPT(1)=^ALPB(53.7,ALPBIEN,1)
+8 SET ALPBPG=1
+9 DO HDR^ALPBFRMU(.ALPBPT,ALPBPG,.ALPBHDR)
+10 FOR I=1:1:ALPBHDR(0)
WRITE !,ALPBHDR(I)
+11 KILL ALPBHDR
+12 ;
+13 ; loop through orders and sort by order status...
+14 NEW ALPBNOMEDS1,ALPBDRGNAME
+15 SET ALPBOIEN=0
SET ALPBNOMEDS1=1
+16 FOR
SET ALPBOIEN=$ORDER(^ALPB(53.7,ALPBIEN,2,ALPBOIEN))
if 'ALPBOIEN
QUIT
Begin DoDot:1
+17 MERGE ALPBDATA=^ALPB(53.7,ALPBIEN,2,ALPBOIEN)
+18 ; if report type is "C"urrent and stop date is less than report date then quit and if status contains 'on hold' do not print and quit...
+19 IF ALPBOTYP="C"
Begin DoDot:2
+20 IF $$STAT^ALPBUTL1($EXTRACT($PIECE(ALPBDATA(0),U,3),1,2))["on hold"
KILL ALPBDATA
QUIT
+21 IF $GET(ALPBDATA(1))=""
KILL ALPBDATA
QUIT
+22 IF $PIECE(ALPBDATA(1),U,2)<ALPBRDAT
KILL ALPBDATA
End DoDot:2
if '$DATA(ALPBDATA)
QUIT
+23 SET ALPBNOMEDS1=0
+24 ;*73
SET ALPBCLIN=$PIECE(ALPBDATA(0),U,5)
if ALPBCLIN=""
SET ALPBCLIN=0
+25 SET ALPBORDN=$PIECE(ALPBDATA(0),U)
+26 SET ALPBOCT=$PIECE($GET(ALPBDATA(3)),U,1)
+27 if $PIECE($GET(ALPBDATA(4)),U,3)["PRN"
SET ALPBOCT=ALPBOCT_"P"
+28 ;drug name being used for alpha-sorting medications within order types (unit dose, unit dose-PRN, intravenous, intravenous-PRN)
+29 SET ALPBDRGNAME=$PIECE($GET(ALPBDATA(7,1,0)),U,2)
+30 ; gets the medications order status based on the order status code
+31 SET ALPBOST=$$STAT2^ALPBUTL1($PIECE($PIECE($GET(ALPBDATA(0),"XX"),U,3),"~"))
+32 SET ^TMP($JOB,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST,ALPBORDN)=ALPBOIEN
+33 KILL ALPBDATA,ALPBOST,ALPBOCT,ALPBDRGNAME
End DoDot:1
+34 ;
+35 ; loop through the sorted orders...
+36 SET ALPBCLIN=""
+37 FOR
SET ALPBCLIN=$ORDER(^TMP($JOB,ALPBCLIN))
if ALPBCLIN=""
QUIT
Begin DoDot:1
+38 SET ALPBOCT=""
+39 FOR
SET ALPBOCT=$ORDER(^TMP($JOB,ALPBCLIN,ALPBOCT))
if ALPBOCT=""
QUIT
Begin DoDot:2
+40 SET ALPBDRGNAME=""
+41 FOR
SET ALPBDRGNAME=$ORDER(^TMP($JOB,ALPBCLIN,ALPBOCT,ALPBDRGNAME))
if ALPBDRGNAME=""
QUIT
Begin DoDot:3
+42 SET ALPBOST=""
+43 FOR
SET ALPBOST=$ORDER(^TMP($JOB,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST))
if ALPBOST=""
QUIT
Begin DoDot:4
+44 SET ALPBORDN=""
+45 FOR
SET ALPBORDN=$ORDER(^TMP($JOB,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST,ALPBORDN))
if ALPBORDN=""
QUIT
Begin DoDot:5
+46 SET ALPBOIEN=^TMP($JOB,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST,ALPBORDN)
+47 MERGE ALPBDATA=^ALPB(53.7,ALPBIEN,2,ALPBOIEN)
+48 WRITE !
+49 DO F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,ALPBMLOG,.ALPBFORM,ALPBIEN)
+50 ; paginate?...
+51 IF $Y+ALPBFORM(0)=IOSL!($Y+ALPBFORM(0)>IOSL)
Begin DoDot:6
+52 WRITE @IOF
+53 SET ALPBPG=ALPBPG+1
+54 DO HDR^ALPBFRMU(.ALPBPT,ALPBPG,.ALPBHDR)
+55 FOR I=1:1:ALPBHDR(0)
WRITE !,ALPBHDR(I)
+56 WRITE !
+57 KILL ALPBHDR
End DoDot:6
+58 FOR I=1:1:ALPBFORM(0)
WRITE !,ALPBFORM(I)
+59 KILL ALPBDATA,ALPBFORM
End DoDot:5
+60 KILL ALPBORDN
End DoDot:4
+61 KILL ALPBOST
End DoDot:3
+62 KILL ALPBDRGNAME
End DoDot:2
+63 KILL ALPBOCT
End DoDot:1
+64 ;
+65 ;notification message displays one line below header info if patient has no med orders when the report is generated
+66 IF ALPBNOMEDS1
Begin DoDot:1
+67 WRITE !!,"No Active Medication Orders were reported to the Contingency at the time the MAR was printed ",!!!
+68 ;additional blank lines added to separate footer from header and allow room for notes
+69 IF $EXTRACT(IOST)="P"
FOR
if $Y>=(IOSL-6)
QUIT
WRITE !
End DoDot:1
+70 ;
+71 ; print footer at end of this patient's record...
+72 DO FOOT^ALPBFRMU
+73 ;
+74 KILL ALPBDAYS,ALPBMLOG,ALPBOIEN,ALPBORDN,ALPBOST,ALPBOTYP,ALPBPG,ALPBPT,ALPBRDAT,^TMP($JOB),ALPBNOMEDS1
+75 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+76 ;
+77 ; write form feed at end if output device is a printer...
+78 IF $EXTRACT(IOST)="P"
WRITE @IOF
+79 QUIT
