ALPBPCLN ;OIFO-DALLAS MW,SED,KC-PRINT 3-7 DAY MAR BCMA BCBU REPORT FOR CLINICS ;3/9/13 9:13am
;;3.0;BAR CODE MED ADMIN;**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.
;
EN(RPT) ;Entry point to print either All clinics or a selected clinics
N ALPBCL
S RPT=$G(RPT,"ALL") ;assume All cllinics if RPT is not defined
;
;selected Clinic report tag
F D Q:$D(DIRUT)
.D:RPT="CLN"
..W !,"Inpatient Pharmacy Orders for a selected Clinic"
..S DIR(0)="FAO^2:30"
..S DIR("A")="Select CLINIC: "
..S DIR("?")="^D CLINLIST^ALPBUTL(""C"")"
..D ^DIR K DIR
..I $D(DIRUT) Q
..D CLINSEL^ALPBUTL(Y,.ALPBSEL)
..I +$G(ALPBSEL(0))=0 D Q
...W $C(7)
...W " ??"
...D CLINLIST^ALPBUTL("C")
...K ALPBSEL
..I +$G(ALPBSEL(0))=1 D
...S ALPBCL=ALPBSEL(1)
...W " ",ALPBCL
...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 Clinic from the list (1-"_ALPBSEL(0)_"): "
...W ! D ^DIR K DIR
...I $D(DIRUT) K ALPBSEL Q
...S ALPBCL=ALPBSEL(+Y)
...W " ",ALPBCL
...K ALPBSEL
.Q:$D(DIRUT)!($D(DUOUT))
.I ($G(RPT)="CLN")&($G(ALPBCL)="") D Q
..W !,"No Clinic Selected"
.;
.; Get All or 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:RPT="CLN" ALPBCL,DIRUT,DTOUT,X,Y Q
.S ALPBOTYP=Y
.;
.; Include a Patient's Inpatient Medications on this Clinic Report
.S ALPBINCLI=""
.S DIR(0)="SA^Y:YES;N:NO"
.S DIR("A")="Include a Patient's Inpatient Medications on the Clinic report? "
.S DIR("B")="YES"
.S DIR("?",1)=" [Y]es = include any Inpatient medications found for this patient on the"
.S DIR("?",2)=" Clinic report."
.S DIR("?",3)=" [N]o = do not include Inpatient medications for this patient on the"
.S DIR("?")=" Clinic report."
.W ! D ^DIR K DIR
.I $D(DIRUT) K ALPBOTYP,DIRUT,DTOUT,DUOUT,X,Y Q
.S ALPBINCLI=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 Entries?
.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,ALPBCL,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,ALPBCL,ALPBINCLI,POP
.;
.; output not queued...
.I '$D(IO("Q")) D
..W ! W:RPT="ALL" "ALL CLINICS REPORT" W:RPT="CLN" "SELECTED CLINIC REPORT FOR "_$G(ALPBCL) W " IS RUNNING...",! H 1
..U IO
..D DQ(RPT)
..I IO'=IO(0) D ^%ZISC
.;
.; Set up the Task
.I $D(IO("Q")) D
..S ZTRTN="DQ^ALPBPCLN(RPT)"
..S ZTDESC="PSB INPT PHARM ORDERS FOR CLIN "_$S(($G(ALPBCL)'=""):ALPBCL,1:"ALL CLINICS")
..S ZTSAVE("ALPBDAYS")=""
..S ZTSAVE("ALPBCL")=""
..S ZTSAVE("ALPBMLOG")=""
..S ZTSAVE("ALPBOTYP")=""
..S ZTSAVE("ALPBINCLI")=""
..S ZTSAVE("RPT")=""
..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,ALPBCL,ALPBINCLI
.I RPT="ALL" S DIRUT=1
K DIRUT,DTOUT,X,Y
Q
;
DQ(RPT) ; output entry point...
; set report date... SED 11/4/03
N ALPBRDAT S ALPBRDAT=$S(ALPBOTYP="C":$$NOW^XLFDT(),1:"")
K ^TMP($J),^TMP("PSBCL",$J)
D @RPT ;Do Tag CLN or ALL
D DONE
Q
;
ALL ;All Clinic report
N ALPBPG,ALPBIEN,PATNAM
;loop thru Clinics xref for ALL clinics & build ^TMP, sorted by
; Clinic, by patn name, by patn ien
S ALPBCL=""
F S ALPBCL=$O(^ALPB(53.7,"AC",ALPBCL)) Q:ALPBCL="" D
.S ALPBIEN=0
.F S ALPBIEN=$O(^ALPB(53.7,"AC",ALPBCL,ALPBIEN)) Q:'ALPBIEN D
..S PATNAM=$P(^ALPB(53.7,ALPBIEN,0),U)
..S ^TMP("PSBCL",$J,ALPBCL,PATNAM,ALPBIEN)=""
S ALPBCL=""
F S ALPBCL=$O(^TMP("PSBCL",$J,ALPBCL)) Q:ALPBCL="" D
.D GETORDS
S ALPBPG=0
D PRT
Q
;
CLN ;Selected Clinic report
N ALPBPG,ALPBIEN,PATNAM
;loop thru Clinics xref & build a TMP global for each clinic on file
; by clinic name, by patn name, by patn ien
S ALPBIEN=0
F S ALPBIEN=$O(^ALPB(53.7,"AC",ALPBCL,ALPBIEN)) Q:'ALPBIEN D
.S PATNAM=$P(^ALPB(53.7,ALPBIEN,0),U)
.S ^TMP("PSBCL",$J,ALPBCL,PATNAM,ALPBIEN)=""
D GETORDS
S ALPBPG=0
D PRT
Q
;
GETORDS ;Get orders per clinic
N ALPBPTN,ALPBIEN,ALPBOIEN,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST
N ALPBORDS,ALPBDATA,ALPBDAT0
S ALPBPTN=""
F S ALPBPTN=$O(^TMP("PSBCL",$J,ALPBCL,ALPBPTN)) Q:ALPBPTN="" D
.S ALPBIEN=0 K ALPBORDS
.F S ALPBIEN=$O(^TMP("PSBCL",$J,ALPBCL,ALPBPTN,ALPBIEN)) Q:'ALPBIEN D
..D ORDS^ALPBUTL(ALPBIEN,ALPBRDAT,.ALPBORDS,ALPBCL,ALPBINCLI)
..I $G(ALPBPDAT(0))="" S ALPBPDAT(0)=$G(^ALPB(53.7,ALPBIEN,0))
..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))
...S ALPBCLIN=$P(ALPBDAT0,U,5) S:ALPBCLIN="" ALPBCLIN=0
...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"
...; 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))
...S ^TMP($J,ALPBPTN)=ALPBIEN
...S ^TMP($J,ALPBPTN,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST,ALPBORDN)=ALPBOIEN
Q
;
PRT ;
N ALPBPTN,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST
S ALPBPTN=""
F S ALPBPTN=$O(^TMP($J,ALPBPTN)) Q:ALPBPTN="" D
.S ALPBIEN=^TMP($J,ALPBPTN)
.S ALPBPDAT(0)=$G(^ALPB(53.7,ALPBIEN,0))
.K ALPBPDAT(1) M ALPBPDAT(1)=^ALPB(53.7,ALPBIEN,1)
.I ALPBPG=0 D PAGE
.S ALPBCLIN=""
.F S ALPBCLIN=$O(^TMP($J,ALPBPTN,ALPBCLIN)) Q:ALPBCLIN="" D
..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)
......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
.; print footer at end of this patient's record...
.I $Y+10>IOSL D PAGE
.;
.;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
.S ALPBPG=0
.K ALPBDAT
Q
;
DONE ;
K ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBCL,ALPRM,ALPRM1,ALPBD,^TMP($J),^TMP("PSBCL",$J)
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[HALPBPCLN 8367 printed Oct 16, 2024@17:40:22 Page 2
ALPBPCLN ;OIFO-DALLAS MW,SED,KC-PRINT 3-7 DAY MAR BCMA BCBU REPORT FOR CLINICS ;3/9/13 9:13am
+1 ;;3.0;BAR CODE MED ADMIN;**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 ;
EN(RPT) ;Entry point to print either All clinics or a selected clinics
+1 NEW ALPBCL
+2 ;assume All cllinics if RPT is not defined
SET RPT=$GET(RPT,"ALL")
+3 ;
+4 ;selected Clinic report tag
+5 FOR
Begin DoDot:1
+6 if RPT="CLN"
Begin DoDot:2
+7 WRITE !,"Inpatient Pharmacy Orders for a selected Clinic"
+8 SET DIR(0)="FAO^2:30"
+9 SET DIR("A")="Select CLINIC: "
+10 SET DIR("?")="^D CLINLIST^ALPBUTL(""C"")"
+11 DO ^DIR
KILL DIR
+12 IF $DATA(DIRUT)
QUIT
+13 DO CLINSEL^ALPBUTL(Y,.ALPBSEL)
+14 IF +$GET(ALPBSEL(0))=0
Begin DoDot:3
+15 WRITE $CHAR(7)
+16 WRITE " ??"
+17 DO CLINLIST^ALPBUTL("C")
+18 KILL ALPBSEL
End DoDot:3
QUIT
+19 IF +$GET(ALPBSEL(0))=1
Begin DoDot:3
+20 SET ALPBCL=ALPBSEL(1)
+21 WRITE " ",ALPBCL
+22 KILL ALPBSEL
End DoDot:3
+23 IF +$GET(ALPBSEL(0))>1
Begin DoDot:3
+24 SET ALPBX=0
+25 FOR
SET ALPBX=$ORDER(ALPBSEL(ALPBX))
if 'ALPBX
QUIT
WRITE !?2,$JUSTIFY(ALPBX,2)," ",ALPBSEL(ALPBX)
+26 KILL ALPBX
+27 SET DIR(0)="NA^1:"_ALPBSEL(0)
+28 SET DIR("A")="Select Clinic from the list (1-"_ALPBSEL(0)_"): "
+29 WRITE !
DO ^DIR
KILL DIR
+30 IF $DATA(DIRUT)
KILL ALPBSEL
QUIT
+31 SET ALPBCL=ALPBSEL(+Y)
+32 WRITE " ",ALPBCL
+33 KILL ALPBSEL
End DoDot:3
IF $DATA(DIRUT)
KILL DIRUT,DTOUT,X,Y
QUIT
End DoDot:2
+34 if $DATA(DIRUT)!($DATA(DUOUT))
QUIT
+35 IF ($GET(RPT)="CLN")&($GET(ALPBCL)="")
Begin DoDot:2
+36 WRITE !,"No Clinic Selected"
End DoDot:2
QUIT
+37 ;
+38 ; Get All or 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)
if RPT="CLN"
KILL ALPBCL,DIRUT,DTOUT,X,Y
QUIT
+45 SET ALPBOTYP=Y
+46 ;
+47 ; Include a Patient's Inpatient Medications on this Clinic Report
+48 SET ALPBINCLI=""
+49 SET DIR(0)="SA^Y:YES;N:NO"
+50 SET DIR("A")="Include a Patient's Inpatient Medications on the Clinic report? "
+51 SET DIR("B")="YES"
+52 SET DIR("?",1)=" [Y]es = include any Inpatient medications found for this patient on the"
+53 SET DIR("?",2)=" Clinic report."
+54 SET DIR("?",3)=" [N]o = do not include Inpatient medications for this patient on the"
+55 SET DIR("?")=" Clinic report."
+56 WRITE !
DO ^DIR
KILL DIR
+57 IF $DATA(DIRUT)
KILL ALPBOTYP,DIRUT,DTOUT,DUOUT,X,Y
QUIT
+58 SET ALPBINCLI=Y
+59 ;
+60 ; Print How Many Days MAR?...
+61 SET DIR(0)="NA^1:7"
+62 SET DIR("A")="Print how many days MAR? "
+63 SET DIR("B")=$$DEFDAYS^ALPBUTL()
+64 SET DIR("?")="The default is shown; please select a number 1 to 7."
+65 WRITE !
DO ^DIR
KILL DIR
+66 IF $DATA(DIRUT)
KILL ALPBOTYP,DIRUT,DTOUT,X,Y
QUIT
+67 SET ALPBDAYS=+Y
+68 ;
+69 ; BCMA Med Log Info for How Many Entries?
+70 SET DIR(0)="NA^1:99"
+71 SET DIR("B")=$$DEFML^ALPBUTL3()
+72 SET DIR("A")="Select how many BCMA Medication Log history: "
+73 SET DIR("A",1)=" "
+74 SET DIR("?",1)="Select a number of BCMA Medication log entries"
+75 SET DIR("?",2)="for each of the patient's orders"
+76 SET DIR("?")="They are listed by the most current entry first"
+77 DO ^DIR
KILL DIR
+78 IF $DATA(DIRUT)
KILL ALPBOTYP,ALPBCL,DIRUT,DTOUT,X,Y
QUIT
+79 SET ALPBMLOG=Y
+80 ;
+81 SET %ZIS="Q"
+82 SET %ZIS("B")=$$DEFPRT^ALPBUTL()
+83 IF %ZIS("B")=""
KILL %ZIS("B")
+84 WRITE !
DO ^%ZIS
KILL %ZIS
+85 IF POP
Begin DoDot:2
+86 WRITE $CHAR(7)
+87 KILL ALPBMLOG,ALPBOTYP,ALPBCL,ALPBINCLI,POP
End DoDot:2
QUIT
+88 ;
+89 ; output not queued...
+90 IF '$DATA(IO("Q"))
Begin DoDot:2
+91 WRITE !
if RPT="ALL"
WRITE "ALL CLINICS REPORT"
if RPT="CLN"
WRITE "SELECTED CLINIC REPORT FOR "_$GET(ALPBCL)
WRITE " IS RUNNING...",!
HANG 1
+92 USE IO
+93 DO DQ(RPT)
+94 IF IO'=IO(0)
DO ^%ZISC
End DoDot:2
+95 ;
+96 ; Set up the Task
+97 IF $DATA(IO("Q"))
Begin DoDot:2
+98 SET ZTRTN="DQ^ALPBPCLN(RPT)"
+99 SET ZTDESC="PSB INPT PHARM ORDERS FOR CLIN "_$SELECT(($GET(ALPBCL)'=""):ALPBCL,1:"ALL CLINICS")
+100 SET ZTSAVE("ALPBDAYS")=""
+101 SET ZTSAVE("ALPBCL")=""
+102 SET ZTSAVE("ALPBMLOG")=""
+103 SET ZTSAVE("ALPBOTYP")=""
+104 SET ZTSAVE("ALPBINCLI")=""
+105 SET ZTSAVE("RPT")=""
+106 SET ZTIO=ION
+107 DO ^%ZTLOAD
+108 DO HOME^%ZIS
+109 WRITE !,$SELECT($GET(ZTSK):"Task number "_ZTSK_" queued.",1:"ERROR -- NOT QUEUED!")
+110 KILL IO("Q"),ZTSK
End DoDot:2
+111 KILL ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBCL,ALPBINCLI
+112 IF RPT="ALL"
SET DIRUT=1
End DoDot:1
if $DATA(DIRUT)
QUIT
+113 KILL DIRUT,DTOUT,X,Y
+114 QUIT
+115 ;
DQ(RPT) ; output entry point...
+1 ; set report date... SED 11/4/03
+2 NEW ALPBRDAT
SET ALPBRDAT=$SELECT(ALPBOTYP="C":$$NOW^XLFDT(),1:"")
+3 KILL ^TMP($JOB),^TMP("PSBCL",$JOB)
+4 ;Do Tag CLN or ALL
DO @RPT
+5 DO DONE
+6 QUIT
+7 ;
ALL ;All Clinic report
+1 NEW ALPBPG,ALPBIEN,PATNAM
+2 ;loop thru Clinics xref for ALL clinics & build ^TMP, sorted by
+3 ; Clinic, by patn name, by patn ien
+4 SET ALPBCL=""
+5 FOR
SET ALPBCL=$ORDER(^ALPB(53.7,"AC",ALPBCL))
if ALPBCL=""
QUIT
Begin DoDot:1
+6 SET ALPBIEN=0
+7 FOR
SET ALPBIEN=$ORDER(^ALPB(53.7,"AC",ALPBCL,ALPBIEN))
if 'ALPBIEN
QUIT
Begin DoDot:2
+8 SET PATNAM=$PIECE(^ALPB(53.7,ALPBIEN,0),U)
+9 SET ^TMP("PSBCL",$JOB,ALPBCL,PATNAM,ALPBIEN)=""
End DoDot:2
End DoDot:1
+10 SET ALPBCL=""
+11 FOR
SET ALPBCL=$ORDER(^TMP("PSBCL",$JOB,ALPBCL))
if ALPBCL=""
QUIT
Begin DoDot:1
+12 DO GETORDS
End DoDot:1
+13 SET ALPBPG=0
+14 DO PRT
+15 QUIT
+16 ;
CLN ;Selected Clinic report
+1 NEW ALPBPG,ALPBIEN,PATNAM
+2 ;loop thru Clinics xref & build a TMP global for each clinic on file
+3 ; by clinic name, by patn name, by patn ien
+4 SET ALPBIEN=0
+5 FOR
SET ALPBIEN=$ORDER(^ALPB(53.7,"AC",ALPBCL,ALPBIEN))
if 'ALPBIEN
QUIT
Begin DoDot:1
+6 SET PATNAM=$PIECE(^ALPB(53.7,ALPBIEN,0),U)
+7 SET ^TMP("PSBCL",$JOB,ALPBCL,PATNAM,ALPBIEN)=""
End DoDot:1
+8 DO GETORDS
+9 SET ALPBPG=0
+10 DO PRT
+11 QUIT
+12 ;
GETORDS ;Get orders per clinic
+1 NEW ALPBPTN,ALPBIEN,ALPBOIEN,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST
+2 NEW ALPBORDS,ALPBDATA,ALPBDAT0
+3 SET ALPBPTN=""
+4 FOR
SET ALPBPTN=$ORDER(^TMP("PSBCL",$JOB,ALPBCL,ALPBPTN))
if ALPBPTN=""
QUIT
Begin DoDot:1
+5 SET ALPBIEN=0
KILL ALPBORDS
+6 FOR
SET ALPBIEN=$ORDER(^TMP("PSBCL",$JOB,ALPBCL,ALPBPTN,ALPBIEN))
if 'ALPBIEN
QUIT
Begin DoDot:2
+7 DO ORDS^ALPBUTL(ALPBIEN,ALPBRDAT,.ALPBORDS,ALPBCL,ALPBINCLI)
+8 IF $GET(ALPBPDAT(0))=""
SET ALPBPDAT(0)=$GET(^ALPB(53.7,ALPBIEN,0))
+9 SET ALPBOIEN=0
+10 FOR
SET ALPBOIEN=$ORDER(ALPBORDS(ALPBOIEN))
if 'ALPBOIEN
QUIT
Begin DoDot:3
+11 SET ALPBDATA=$GET(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,1))
+12 SET ALPBDAT0=$GET(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,0))
+13 SET ALPBCLIN=$PIECE(ALPBDAT0,U,5)
if ALPBCLIN=""
SET ALPBCLIN=0
+14 SET ALPBOCT=$PIECE($GET(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,3)),U,1)
+15 if $PIECE($GET(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,4)),U,3)["PRN"
SET ALPBOCT=ALPBOCT_"P"
+16 ;drug name being used for alpha-sorting medications within order types (unit dose, unit dose-PRN, intravenous, intravenous-PRN)
+17 SET ALPBDRGNAME=$PIECE($GET(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,7,1,0)),U,2)
+18 if ALPBDRGNAME=""
SET ALPBDRGNAME="NOT FOUND"
+19 ; if report is for "C"urrent, check stop date and quit if
+20 ; stop date is less than report date
+21 IF ALPBOTYP="C"&($PIECE(ALPBDATA,U,2)<ALPBRDAT)
KILL ALPBDATA
QUIT
+22 SET ALPBORDN=ALPBORDS(ALPBOIEN)
+23 SET ALPBOST=$$STAT2^ALPBUTL1(ALPBORDS(ALPBOIEN,2))
+24 SET ^TMP($JOB,ALPBPTN)=ALPBIEN
+25 SET ^TMP($JOB,ALPBPTN,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST,ALPBORDN)=ALPBOIEN
End DoDot:3
End DoDot:2
End DoDot:1
+26 QUIT
+27 ;
PRT ;
+1 NEW ALPBPTN,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST
+2 SET ALPBPTN=""
+3 FOR
SET ALPBPTN=$ORDER(^TMP($JOB,ALPBPTN))
if ALPBPTN=""
QUIT
Begin DoDot:1
+4 SET ALPBIEN=^TMP($JOB,ALPBPTN)
+5 SET ALPBPDAT(0)=$GET(^ALPB(53.7,ALPBIEN,0))
+6 KILL ALPBPDAT(1)
MERGE ALPBPDAT(1)=^ALPB(53.7,ALPBIEN,1)
+7 IF ALPBPG=0
DO PAGE
+8 SET ALPBCLIN=""
+9 FOR
SET ALPBCLIN=$ORDER(^TMP($JOB,ALPBPTN,ALPBCLIN))
if ALPBCLIN=""
QUIT
Begin DoDot:2
+10 SET ALPBOCT=""
+11 FOR
SET ALPBOCT=$ORDER(^TMP($JOB,ALPBPTN,ALPBCLIN,ALPBOCT))
if ALPBOCT=""
QUIT
Begin DoDot:3
+12 SET ALPBDRGNAME=""
+13 FOR
SET ALPBDRGNAME=$ORDER(^TMP($JOB,ALPBPTN,ALPBCLIN,ALPBOCT,ALPBDRGNAME))
if ALPBDRGNAME=""
QUIT
Begin DoDot:4
+14 SET ALPBOST=""
+15 FOR
SET ALPBOST=$ORDER(^TMP($JOB,ALPBPTN,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST))
if ALPBOST=""
QUIT
Begin DoDot:5
+16 SET ALPBORDN=""
+17 FOR
SET ALPBORDN=$ORDER(^TMP($JOB,ALPBPTN,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST,ALPBORDN))
if ALPBORDN=""
QUIT
Begin DoDot:6
+18 SET ALPBOIEN=^TMP($JOB,ALPBPTN,ALPBCLIN,ALPBOCT,ALPBDRGNAME,ALPBOST,ALPBORDN)
+19 ; get and print this order's data...
+20 MERGE ALPBDATA=^ALPB(53.7,ALPBIEN,2,ALPBOIEN)
+21 DO F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,ALPBMLOG,.ALPBFORM,ALPBIEN)
+22 IF $Y+ALPBFORM(0)=IOSL!($Y+ALPBFORM(0)>IOSL)
DO PAGE
+23 FOR ALPBX=1:1:ALPBFORM(0)
WRITE !,ALPBFORM(ALPBX)
+24 KILL ALPBDATA,ALPBFORM,ALPBOIEN,ALPBX
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+25 ; print footer at end of this patient's record...
+26 IF $Y+10>IOSL
DO PAGE
+27 ;
+28 ;additional blank lines added to separate footer from header and
+29 ;allow room for notes
+30 IF $EXTRACT(IOST)="P"
FOR
if $Y>=(IOSL-6)
QUIT
WRITE !
+31 ;
+32 DO FOOT^ALPBFRMU
+33 SET ALPBPG=0
+34 KILL ALPBDAT
End DoDot:1
+35 QUIT
+36 ;
DONE ;
+1 KILL ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBCL,ALPRM,ALPRM1,ALPBD,^TMP($JOB),^TMP("PSBCL",$JOB)
+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
