ALPBPPAT.m

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 ---ALPBPPAT   5713     printed  Feb 18, 2025@23:05:55                                                                                                                                                                                                    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