ALPBPALL ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCMA BACLUP REPORT FOR ALL WARDS ;2/13/13 13:13pm
;;3.0;BAR CODE MED ADMIN;**8,29,48,59,73**;Mar 2004;Build 31
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; based on original code by FD@NJHCS, May 2002
;
;*73 Add Clinic Order (CO) identification and clinic name print with
; CO's sorting after IM meds.
;
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
;
;added in PSB*3*59 to benefit users located at the long term care and domiciliary sites
;include patients without active medications?...
I ALPBOTYP="A" S ALPBWOMED=""
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 ALPBWOMED=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 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")=""
.S ZTSAVE("ALPBWOMED")=""
.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,ALPBWOMED
Q
;
DQ ; output entry point...
K ^TMP($J)
N ALPBCLIN,ALPBDAT0
;
; set report date...MOD 11/03/03 SED
S ALPBRDAT=$S(ALPBOTYP="C":$$NOW^XLFDT(),1:"")
;
; loop through ward cross reference in 53.7...
N ALPBDRGNAME
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&(ALPBWOMED="Y") D Q
....S ^TMP($J,ALPBWARD,ALPBPTN)=ALPBIEN
....K ALPBORDS
...S ALPBOIEN=0
...F S ALPBOIEN=$O(ALPBORDS(ALPBOIEN)) Q:'ALPBOIEN D
....S ALPBDAT0=$G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,0))
....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 ALPBDRGNAME=$P($G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,7,1,0)),U,2)
....S ALPBCLIN=$P(ALPBDAT0,U,5) S:ALPBCLIN="" ALPBCLIN=0 ;*73
....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,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST,ALPBORDN)=ALPBOIEN
....K ALPBDATA,ALPBORDN,ALPBOST,ALPBOCT,ALPBDRGNAME
...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)
..N ALPBNOMEDS2
..S ALPBNOMEDS2=""
..S:$D(^TMP($J,ALPBWARD,ALPBPTN))=1 ALPBNOMEDS2=1
..; paginate between patients...
..I ALPBPG=0 D PAGE
..S ALPBCLIN=""
..F S ALPBCLIN=$O(^TMP($J,ALPBWARD,ALPBPTN,ALPBCLIN)) Q:ALPBCLIN="" D
...S ALPBOCT=""
...F S ALPBOCT=$O(^TMP($J,ALPBWARD,ALPBPTN,ALPBCLIN,ALPBOCT)) Q:ALPBOCT="" D
....S ALPBDRGNAME=""
....F S ALPBDRGNAME=$O(^TMP($J,ALPBWARD,ALPBPTN,ALPBCLIN,ALPBOCT,ALPBDRGNAME)) Q:ALPBDRGNAME="" D
.....S ALPBOST=""
.....F S ALPBOST=$O(^TMP($J,ALPBWARD,ALPBPTN,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST)) Q:ALPBOST="" D
......S ALPBORDN=""
......F S ALPBORDN=$O(^TMP($J,ALPBWARD,ALPBPTN,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST,ALPBORDN)) Q:ALPBORDN="" D
.......S ALPBOIEN=^TMP($J,ALPBWARD,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)
.......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 ALPBDRGNAME
..K ALPBIEN,ALPBPDAT,ALPBOCT
..S ALPBPG=0
..;notification message displays one line below header info if patient has no med orders when the report is generated
..I ALPBNOMEDS2 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
..;Print a blank page between patient (this was removed by PSB*3*59 - the BCMA Workgroup agreed to condense the report)
..;W @IOF
.K ALPBPTN
;
K ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBPG,ALPBRDAT,ALPBWARD,^TMP($J),ALPBNOMEDS2
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HALPBPALL 6708 printed Nov 22, 2024@16:49:41 Page 2
ALPBPALL ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCMA BACLUP REPORT FOR ALL WARDS ;2/13/13 13:13pm
+1 ;;3.0;BAR CODE MED ADMIN;**8,29,48,59,73**;Mar 2004;Build 31
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; based on original code by FD@NJHCS, May 2002
+5 ;
+6 ;*73 Add Clinic Order (CO) identification and clinic name print with
+7 ; CO's sorting after IM meds.
+8 ;
+9 WRITE !,"Inpatient Pharmacy Orders for all wards"
+10 ;
+11 ; get all or just current orders?...
+12 SET DIR(0)="SA^A:ALL;C:CURRENT"
+13 SET DIR("A")="Report [A]LL or [C]URRENT orders? "
+14 SET DIR("B")="CURRENT"
+15 SET DIR("?")="[A]LL=all orders in the file, [C]URRENT=orders not yet expired."
+16 WRITE !
DO ^DIR
KILL DIR
+17 IF $DATA(DIRUT)
KILL DIRUT,DTOUT,X,Y
QUIT
+18 SET ALPBOTYP=Y
+19 ;
+20 ;added in PSB*3*59 to benefit users located at the long term care and domiciliary sites
+21 ;include patients without active medications?...
+22 IF ALPBOTYP="A"
SET ALPBWOMED=""
+23 IF ALPBOTYP="C"
Begin DoDot:1
+24 SET DIR(0)="SA^Y:YES;N:NO"
+25 SET DIR("A")="Include Patients Without Active Medications? "
+26 SET DIR("B")="YES"
+27 SET DIR("?",1)="[Y]es=include patients without active medication orders,"
+28 SET DIR("?",2)="[N]o=do not include patients without active medication orders."
+29 WRITE !
DO ^DIR
KILL DIR
+30 IF $DATA(DIRUT)
KILL ALPBOTYP,DIRUT,DTOUT,X,Y
QUIT
+31 SET ALPBWOMED=Y
End DoDot:1
+32 ;
+33 ; print how many days MAR?...
+34 SET DIR(0)="NA^1:7"
+35 SET DIR("A")="Print how many days MAR? "
+36 SET DIR("B")=$$DEFDAYS^ALPBUTL()
+37 SET DIR("?")="The default is shown; please select a number 1 to 7."
+38 WRITE !
DO ^DIR
KILL DIR
+39 IF $DATA(DIRUT)
KILL ALPBOTYP,DIRUT,DTOUT,X,Y
QUIT
+40 SET ALPBDAYS=+Y
+41 ;
+42 ; BCMA Med Log info for how many ?...
+43 SET DIR(0)="NA^1:99"
+44 SET DIR("B")=$$DEFML^ALPBUTL3()
+45 SET DIR("A")="Select how many BCMA Medication Log history: "
+46 SET DIR("A",1)=" "
+47 SET DIR("?",1)="Select a number of BCMA Medication log entries"
+48 SET DIR("?",2)="for each of the patient's orders"
+49 SET DIR("?")="They are listed by the most current entry first"
+50 DO ^DIR
KILL DIR
+51 IF $DATA(DIRUT)
KILL ALPBOTYP,ALPBWARD,DIRUT,DTOUT,X,Y
QUIT
+52 SET ALPBMLOG=Y
+53 ;
+54 SET %ZIS="Q"
+55 SET %ZIS("B")=$$DEFPRT^ALPBUTL()
+56 IF %ZIS("B")=""
KILL %ZIS("B")
+57 WRITE !
DO ^%ZIS
KILL %ZIS
+58 IF POP
KILL POP
QUIT
+59 ;
+60 ; output not queued...
+61 IF '$DATA(IO("Q"))
Begin DoDot:1
+62 USE IO
+63 DO DQ
+64 IF IO'=IO(0)
DO ^%ZISC
End DoDot:1
+65 ;
+66 ; set up the task...
+67 IF $DATA(IO("Q"))
Begin DoDot:1
+68 SET ZTRTN="DQ^ALPBPALL"
+69 SET ZTDESC="PSB INPT PHARM ORDER FOR ALL WARDS"
+70 SET ZTIO=ION
+71 SET ZTSAVE("ALPBMLOG")=""
+72 SET ZTSAVE("ALPBOTYP")=""
+73 SET ZTSAVE("ALPBDAYS")=""
+74 SET ZTSAVE("ALPBWOMED")=""
+75 DO ^%ZTLOAD
+76 DO HOME^%ZIS
+77 WRITE !,$SELECT($GET(ZTSK):"Task number "_ZTSK_" queued.",1:"ERROR -- NOT QUEUED!")
+78 KILL IO("Q"),ZTSK
End DoDot:1
+79 KILL ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBWOMED
+80 QUIT
+81 ;
DQ ; output entry point...
+1 KILL ^TMP($JOB)
+2 NEW ALPBCLIN,ALPBDAT0
+3 ;
+4 ; set report date...MOD 11/03/03 SED
+5 SET ALPBRDAT=$SELECT(ALPBOTYP="C":$$NOW^XLFDT(),1:"")
+6 ;
+7 ; loop through ward cross reference in 53.7...
+8 NEW ALPBDRGNAME
+9 SET ALPBWARD=""
+10 FOR
SET ALPBWARD=$ORDER(^ALPB(53.7,"AW",ALPBWARD))
if ALPBWARD=""
QUIT
Begin DoDot:1
+11 SET ALPBPTN=""
+12 FOR
SET ALPBPTN=$ORDER(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN))
if ALPBPTN=""
QUIT
Begin DoDot:2
+13 SET ALPBIEN=0
+14 FOR
SET ALPBIEN=$ORDER(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN,ALPBIEN))
if 'ALPBIEN
QUIT
Begin DoDot:3
+15 DO ORDS^ALPBUTL(ALPBIEN,ALPBRDAT,.ALPBORDS)
+16 IF +ALPBORDS(0)'>0&(ALPBWOMED="Y")
Begin DoDot:4
+17 SET ^TMP($JOB,ALPBWARD,ALPBPTN)=ALPBIEN
+18 KILL ALPBORDS
End DoDot:4
QUIT
+19 SET ALPBOIEN=0
+20 FOR
SET ALPBOIEN=$ORDER(ALPBORDS(ALPBOIEN))
if 'ALPBOIEN
QUIT
Begin DoDot:4
+21 SET ALPBDAT0=$GET(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,0))
+22 SET ALPBDATA=$GET(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,1))
+23 IF ALPBOTYP="C"&($PIECE(ALPBDATA,U,2)<ALPBRDAT)
KILL ALPBDATA
QUIT
+24 SET ALPBOCT=$PIECE($GET(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,3)),U,1)
+25 if $PIECE($GET(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,4)),U,3)["PRN"
SET ALPBOCT=ALPBOCT_"P"
+26 SET ALPBDRGNAME=$PIECE($GET(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,7,1,0)),U,2)
+27 ;*73
SET ALPBCLIN=$PIECE(ALPBDAT0,U,5)
if ALPBCLIN=""
SET ALPBCLIN=0
+28 SET ALPBORDN=ALPBORDS(ALPBOIEN)
+29 SET ALPBOST=$$STAT2^ALPBUTL1(ALPBORDS(ALPBOIEN,2))
+30 IF '$DATA(^TMP($JOB,ALPBWARD,ALPBPTN))
SET ^TMP($JOB,ALPBWARD,ALPBPTN)=ALPBIEN
+31 SET ^TMP($JOB,ALPBWARD,ALPBPTN,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST,ALPBORDN)=ALPBOIEN
+32 KILL ALPBDATA,ALPBORDN,ALPBOST,ALPBOCT,ALPBDRGNAME
End DoDot:4
+33 KILL ALPBOIEN,ALPBORDS
End DoDot:3
+34 KILL ALPBIEN
End DoDot:2
+35 KILL ALPBPTN
End DoDot:1
+36 KILL ALPBWARD
+37 ;
+38 ; process through our sorted list...
+39 SET ALPBPG=0
+40 SET ALPBWARD=""
+41 FOR
SET ALPBWARD=$ORDER(^TMP($JOB,ALPBWARD))
if ALPBWARD=""
QUIT
Begin DoDot:1
+42 SET ALPBPTN=""
+43 FOR
SET ALPBPTN=$ORDER(^TMP($JOB,ALPBWARD,ALPBPTN))
if ALPBPTN=""
QUIT
Begin DoDot:2
+44 SET ALPBIEN=+^TMP($JOB,ALPBWARD,ALPBPTN)
+45 SET ALPBPDAT(0)=$GET(^ALPB(53.7,ALPBIEN,0))
+46 MERGE ALPBPDAT(1)=^ALPB(53.7,ALPBIEN,1)
+47 NEW ALPBNOMEDS2
+48 SET ALPBNOMEDS2=""
+49 if $DATA(^TMP($JOB,ALPBWARD,ALPBPTN))=1
SET ALPBNOMEDS2=1
+50 ; paginate between patients...
+51 IF ALPBPG=0
DO PAGE
+52 SET ALPBCLIN=""
+53 FOR
SET ALPBCLIN=$ORDER(^TMP($JOB,ALPBWARD,ALPBPTN,ALPBCLIN))
if ALPBCLIN=""
QUIT
Begin DoDot:3
+54 SET ALPBOCT=""
+55 FOR
SET ALPBOCT=$ORDER(^TMP($JOB,ALPBWARD,ALPBPTN,ALPBCLIN,ALPBOCT))
if ALPBOCT=""
QUIT
Begin DoDot:4
+56 SET ALPBDRGNAME=""
+57 FOR
SET ALPBDRGNAME=$ORDER(^TMP($JOB,ALPBWARD,ALPBPTN,ALPBCLIN,ALPBOCT,ALPBDRGNAME))
if ALPBDRGNAME=""
QUIT
Begin DoDot:5
+58 SET ALPBOST=""
+59 FOR
SET ALPBOST=$ORDER(^TMP($JOB,ALPBWARD,ALPBPTN,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST))
if ALPBOST=""
QUIT
Begin DoDot:6
+60 SET ALPBORDN=""
+61 FOR
SET ALPBORDN=$ORDER(^TMP($JOB,ALPBWARD,ALPBPTN,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST,ALPBORDN))
if ALPBORDN=""
QUIT
Begin DoDot:7
+62 SET ALPBOIEN=^TMP($JOB,ALPBWARD,ALPBPTN,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST,ALPBORDN)
+63 ; get and print this order's data...
+64 MERGE ALPBDATA=^ALPB(53.7,ALPBIEN,2,ALPBOIEN)
+65 DO F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,ALPBMLOG,.ALPBFORM,ALPBIEN)
+66 IF $Y+ALPBFORM(0)>IOSL
DO PAGE
+67 SET ALPBX=0
+68 FOR
SET ALPBX=$ORDER(ALPBFORM(ALPBX))
if 'ALPBX
QUIT
WRITE !,ALPBFORM(ALPBX)
+69 KILL ALPBDATA,ALPBFORM,ALPBOIEN,ALPBX
End DoDot:7
+70 KILL ALPBORDN
End DoDot:6
+71 KILL ALPBOST
End DoDot:5
+72 KILL ALPBDRGNAME
End DoDot:4
End DoDot:3
+73 KILL ALPBIEN,ALPBPDAT,ALPBOCT
+74 SET ALPBPG=0
+75 ;notification message displays one line below header info if patient has no med orders when the report is generated
+76 IF ALPBNOMEDS2
Begin DoDot:3
+77 WRITE !!,"No Active Medication Orders were reported to the Contingency at the time the MAR was printed ",!!!
+78 ;additional blank lines added to separate footer from header and allow room for notes
+79 IF $EXTRACT(IOST)="P"
FOR
if $Y>=(IOSL-6)
QUIT
WRITE !
End DoDot:3
+80 ; print footer at end of this patient's record...
+81 DO FOOT^ALPBFRMU
+82 ;Print a blank page between patient (this was removed by PSB*3*59 - the BCMA Workgroup agreed to condense the report)
+83 ;W @IOF
End DoDot:2
+84 KILL ALPBPTN
End DoDot:1
+85 ;
+86 KILL ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBPG,ALPBRDAT,ALPBWARD,^TMP($JOB),ALPBNOMEDS2
+87 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+88 QUIT
+89 ;
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
