ALPBPWRD.m

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 ---ALPBPWRD   9166     printed  Mar 13, 2025@20:44:12                                                                                                                                                                                                    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