Routine: PSBODL1

PSBODL1 ;BIRMINGHAM/VRN-DUE LIST ;4/26/21  12:11

 ;;3.0;BAR CODE MED ADMIN;**5,9,32,28,68,70,83,106**;Mar 2004;Build 43

 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.

 ;*68 - print New unlimited Wp Special Instructions/OPI fields

 ;*70 - add Psbsrchl to HDR

 ;*83 - add Removes to the report that need attention.

 ;*106- add Hazardous Handle & Dispose flags

EN ;

 N QQ

 S PSBFOHDR=0

 S PSBORD=0 F  S PSBORD=$O(^TMP("PSBO",$J,DFN,PSBORD)) Q:PSBORD=""  S PSBTYPE=$O(^TMP("PSBO",$J,DFN,PSBORD,"")) D

 .D CLEAN^PSBVT

 .D PSJ1^PSBVT(DFN,PSBORD)

 .I PSBSCHT="C" D  Q:PSBADMIN=""

 ..S PSBX=PSBADST,PSBFLAG=1

 ..I PSBX="",PSBONX["V",PSBIVT'="P" S PSBFLAG=0

 ..S (PSBYES,PSBODD)=0

 ..S:$$PSBDCHK1^PSBVT1(PSBSCH) PSBYES=1

 ..F I=1:1 Q:$P(PSBSCH,"-",I)=""  I $P(PSBSCH,"-",I)?2N!($P(PSBSCH,"-",I)?4N) S PSBYES=1

 ..I PSBYES,PSBADST="",PSBSCHT'="O",PSBSCHT'="OC",PSBSCHT'="P"  Q

 ..I PSBFREQ="O" S PSBFREQ=1440

 ..I 'PSBYES,PSBADST="",PSBFREQ<1 Q

 ..I +PSBFREQ>0 I (PSBFREQ#1440'=0),(1440#PSBFREQ'=0) S PSBODD=1

 ..I PSBODD,PSBADST'="" Q

 ..D:PSBX=""

 ...I PSBIVT="C",PSBCHEMT="A" S PSBX="0000",PSBFLAG=0

 ...I PSBIVT="C",PSBISYR=0 S PSBX="0000",PSBFLAG=0

 ...I PSBIVT="S",PSBISYR=0 S PSBX="0000",PSBFLAG=0

 ...I "HA"[PSBIVT S PSBX="0000",PSBFLAG=0

 ..I ("SC"[PSBIVT),(PSBISYR=1) S PSBX=""

 ..I (PSBIVT="C"),(PSBCHEMT="P") S PSBX=""

 ..I PSBOTYP="U",PSBX="0000" S PSBX=""

 ..I PSBIVT="P",$G(PSBX)=0 S PSBX=""

 ..I PSBX="" S PSBX=$$GETADMIN^PSBVDLU1(DFN,PSBONX,PSBOST,PSBFREQ,PSBEVDT)

 ..E  K ^TMP("PSB",$J,"GETADMIN") S ^TMP("PSB",$J,"GETADMIN",0)=PSBX

 ..S PSBADMIN=""

 ..F PSBXX=0:1 Q:'$D(^TMP("PSB",$J,"GETADMIN",PSBXX))  S PSBX=$G(^TMP("PSB",$J,"GETADMIN",PSBXX)) D

 ...F PSBY=1:1:$L(PSBX,"-")  D

 ....Q:($P(PSBX,"-",PSBY)'?2N)&($P(PSBX,"-",PSBY)'?4N)

 ....S PSBAT=+(PSBODATE_"."_$P(PSBX,"-",PSBY))

 ....I PSBFLAG Q:PSBAT<PSBOSTRT!(PSBAT>PSBOSTOP)  ; Report Window

 ....D VAL^PSBMLVAL(.PSBZ,DFN,PSBONX,PSBTYPE,PSBAT)

 ....S:$G(PSBFREQ)>29 PSBADMIN=PSBADMIN_$S(PSBADMIN]"":"-",1:"")_$P(PSBX,"-",PSBY)

 ....S:$G(PSBFREQ)<30 PSBADMIN="Due every "_$G(PSBFREQ)_" minutes."

 .I PSBSCHT'="C" S PSBADMIN=PSBADST

 .; Get LAST GIVEN date/time

 .S PSBLGDT="",X=""

 .F  S X=$O(^PSB(53.79,"AOIP",DFN,+PSBOIT,X),-1) Q:'X  D  Q:PSBLGDT

 ..S PSBIEN=""

 ..F  S PSBIEN=$O(^PSB(53.79,"AOIP",DFN,+PSBOIT,X,PSBIEN),-1) Q:PSBIEN=""  D  Q:PSBLGDT

 ...S:"MHNR"'[$P($G(^PSB(53.79,PSBIEN,0)),U,9) PSBLGDT=X

 .I $Y>(IOSL-12) I $Y<(IOSL-4) W !?(IOM-36\2),"(Medications Continued on Next Page)",$$FTR(),$$HDR()

 .I PSBSM S PSBSM=$S(PSBSMX:"H",1:"")_"SM"

 .E  S PSBSM=""

 .I 'PSBFOHDR S PSBFOHDR=1 W $$HDR()

 .W !,$J(PSBSM,3),?6,PSBTYPE,$E(PSBSCHT,1,4),?12 S PSBWFLAG=1

 .S X="",Y=0

 .W $$WRAP(14,34,PSBOITX)

 .; *106 adds the hazardous handle/dispose notices

 .N PSBHAZ

 .S PSBHAZ=""

 .I PSBHAZHN=1 S PSBHAZ="<<HAZ Handle>> "

 .I PSBHAZDS=1 S PSBHAZ=PSBHAZ_"<<HAZ Dispose>>"

 .W:PSBHAZ]"" $$WRAP(14,45,PSBHAZ)

 .S PSBADM="Give: "_PSBDOSE_"  "_PSBSCH

 .W $$WRAP(50,27,PSBADM)

 .W $$WRAP(78,6,PSBMR)

 .W ?85 I PSBLGDT W $E(PSBLGDT,4,5),"/",$E(PSBLGDT,6,7),"/",$E(PSBLGDT,2,3) W "@",$E($P(PSBLGDT,".",2)_"0000",1,4)

 .W ?100,$P($TR($$FMTE^XLFDT(PSBOST,2),"@"," ")," ")

 .W ?110,$P($TR($$FMTE^XLFDT(PSBOSP,2),"@"," ")," ")

 .W ?120,$S(PSBVPHI]"":PSBVPHI,1:"***"),"/",$S(PSBVNI]"":PSBVNI,1:"***")

 .W !,?100,"@"_$P(PSBOSTX,"  ",2),?110,"@"_$P(PSBOSPX,"  ",2)

 .W IOINHI  ; To Highlight the Dispense Drugs...

 .I $D(PSBDDA) S Y=0 F  S Y=$O(PSBDDA(Y)) Q:'Y  D

 ..Q:$P(PSBDDA(Y),U,5)&($P(PSBDDA(Y),U,5)<PSBNOW)

 ..W !?14,"*",$$WRAP(15,33,$P(PSBDDA(Y),U,3)_" ("_+$P(PSBDDA(Y),U,2)_")")

 .I $D(PSBADA) S Y=0 F  S Y=$O(PSBADA(Y)) Q:'Y  W !?14,"*",$$WRAP(15,33,$P(PSBADA(Y),U,3)_" ("_$P(PSBADA(Y),U,4)_")")

 .I $D(PSBSOLA) S Y=0 F  S Y=$O(PSBSOLA(Y)) Q:'Y  W !?14,"*",$$WRAP(15,33,$P(PSBSOLA(Y),U,3)_" ("_$P(PSBSOLA(Y),U,4)_")")

 .W IOINORM ; Highlight Off

 .S PSBADM=$S(PSBADMIN]"":"Admin Times: "_PSBADMIN,1:"")

 .W:PSBADM]"" $$WRAP(50,27,PSBADM)

.;;

 .;*68 begin

 .I PSBSIFLG,'$G(^TMP("PSJBCMA5",$J,DFN,PSBORD)) D

 ..W !?14,"Special Instructions:",?36,"<None Entered.>",DFN,U,PSBORD,"<"

 .D:PSBSIFLG

 ..F QQ=0:0 S QQ=$O(^TMP("PSJBCMA5",$J,DFN,PSBORD,QQ)) Q:'QQ  D

 ...W:QQ=1 !?14,"Special Instructions:",?36,^TMP("PSJBCMA5",$J,DFN,PSBORD,QQ)

 ...W:QQ>1 !?36,^TMP("PSJBCMA5",$J,DFN,PSBORD,QQ)

 .W !,$TR($J("",IOM)," ","-")

 I '$G(PSBWFLAG) W !!,?10,"** NO SPECIFIED MEDICATIONS TO PRINT **"

 W:PSBFOHDR $$BLANKS(),$$FTR()

 K ^TMP("PSB",$J,"GETADMIN")

WRAPPUP ;Do wrapping per PSBODL (Due List Report)

 N PSBHAZ

 W $$WRAP(14,34,PSBMED)

 ;*106 adds the hazardous handle/dispose notices

 S PSBHAZ=""

 I PSBHAZHN=1 S PSBHAZ="<<HAZ Handle>> "

 I PSBHAZDS=1 S PSBHAZ=PSBHAZ_"<<HAZ Dispose>>"

 W:PSBHAZ]"" $$WRAP(14,45,PSBHAZ)

 S PSBADM="Give: "_PSBDOSE_"  "_PSBSCH

 W $$WRAP(50,27,PSBADM),?78,$$WRAP(78,6,PSBMR)

 W ?85 D:PSBLGDT

 .W $E(PSBLGDT,4,5),"/",$E(PSBLGDT,6,7),"/",$E(PSBLGDT,2,3),"@",$E($P(PSBLGDT,".",2)_"0000",1,4)

 W ?100,$P($TR($$FMTE^XLFDT(PSBOST,2),"@"," ")," "),?110,$P($TR($$FMTE^XLFDT(PSBOSP,2),"@"," ")," "),?120,$S(PSBVPHI]"":PSBVPHI,1:"***"),"/"

 W $S(PSBVNI]"":PSBVNI,1:"***"),!,?100,"@"_$P(PSBOSTX,"  ",2),?110,"@"_$P(PSBOSPX,"  ",2)

 W IOINHI

 I $D(PSBDDA) S Y=0 F  S Y=$O(PSBDDA(Y)) Q:'Y  D

 .Q:$P(PSBDDA(Y),U,5)&($P(PSBDDA(Y),U,5)<PSBNOW)

 .W !?14,"*",$$WRAP(15,33,$P(PSBDDA(Y),U,3)) ;_" ("_+$P(PSBDDA(Y),U,2)_")")

 I $D(PSBADA) S Y=0 F  S Y=$O(PSBADA(Y)) Q:'Y  W !?14,"*",$$WRAP(15,33,$P(PSBADA(Y),U,3)) ;_" ("_$P(PSBADA(Y),U,4)_")")

 I $D(PSBSOLA) S Y=0 F  S Y=$O(PSBSOLA(Y)) Q:'Y  W !?14,"*",$$WRAP(15,33,$P(PSBSOLA(Y),U,3)) ;_" ("_$P(PSBSOLA(Y),U,4)_")")

 W IOINORM ; Hlight Off

 S PSBADM=$S(PSBADMIN]"":"Admin Times: "_PSBADMIN,1:"")

 W:PSBADM]"" $$WRAP(50,27,PSBADM)

 ;Find associated remove with this ,med just printed on report

 ; use Tmp Gbl from Getremov call in PSBODL

 N IEN,RMA,RMTIM,RMDTTM,TIM,INDX

 F IEN=0:0 S IEN=$O(^TMP("PSB",$J,"RM","B",PSBORD,IEN)) Q:'IEN  D

 .S RMTIM=$P(^TMP("PSB",$J,"RM",IEN),U,1)

 .;skip if this RMV does not fall witin report dates

 .Q:($P(RMTIM,".")<PSBEVDT)!($P(RMTIM,".")>PSBEVDT2)

 .S RMA(RMTIM)=""

 .;kill out used entires so won't use again at end of report time

 .K ^TMP("PSB",$J,"RM",IEN)

 K ^TMP("PSB",$J,"RM","B",PSBORD)

 S (RMDTTM,RMTIM)="",INDX=0

 F TIM=0:0 S TIM=$O(RMA(TIM)) Q:'TIM  D

 .S INDX=INDX+1

 .S RMTIM=$E($P(TIM,".",2)_"0000",1,4)

 .S RMDTTM=$S(INDX=1:RMTIM,1:RMDTTM_"-"_RMTIM)

 W:RMDTTM]"" !?50,"Remove Time: "_RMDTTM

 ;*68 begin

 I PSBSIFLG,'$G(^TMP("PSJBCMA5",$J,DFN,PSBORD)) W !?14,"Special Instructions:",?36,"<None Entered.>"

 D:PSBSIFLG

 .F QQ=0:0 S QQ=$O(^TMP("PSJBCMA5",$J,DFN,PSBORD,QQ)) Q:'QQ  D

 ..W:QQ=1 !?14,"Special Instructions:"

 ..W:QQ>1 !

 ..W ?36,^TMP("PSJBCMA5",$J,DFN,PSBORD,QQ)

 W !,$TR($J("",IOM)," ","-")

WRAP(X,Y,Z) ; Quick text wrap

 F  Q:'$L(Z)  D

 .W:$X>X !

 .W:$X<X ?X

 .I $L(Z)<Y W Z S Z="" Q

 .F PSB=Y:-1:0 Q:$E(Z,PSB)=" "

 .S:PSB<1 PSB=Y

 .W $E(Z,1,PSB)

 .S Z=$E(Z,PSB+1,255)

 Q ""

FTR() ; [Extrinsic] Page footer

 ; Sub Module Description:

 ; (No Description Available)

 I (IOSL<100) F  Q:$Y>(IOSL-10)  W !

 W !,$TR($J("",IOM)," ","=")

 S X="Ward: "_PSBHDR("WARD")_"  Room-Bed: "_PSBHDR("ROOM")

 W !,PSBHDR("NAME"),?(IOM-11\2),PSBHDR("SSN"),?(IOM-$L(X)),X

 Q ""

HDR() ; Page Header

 Q:'PSBFOHDR ""

 D PT^PSBOHDR(DFN,.PSBHDR,,,PSBSRCHL)                            ;*70

W !

W !

 W !,?(IOM-28\2),"*****   FUTURE ORDERS   *****"

W !

 W !,"Self",?85,"Last",?100,"Start",?110,"Stop",?120,"Verifying"

 W !,"Med",?6,"Sched",?14,"Medication",?50,"Dose",?78,"Route",?85,"Given",?100,"Date",?110,"Date",?120,"Rph/Rn"

 W !,?100,"@Time",?110,"@Time"

 W !,$TR($J("",IOM)," ","-")

 Q ""

BLANKS() ; [Extrinsic] Print blanks at end of printout for changes

 Q:'$P(PSBRPT(.2),U,5) ""

W !

 I $Y>(IOSL-26) W ?(IOM-42\2),"(Changes/Addendums to Orders on Next Page)" W $$FTR(),$$HDR() ; Not enough space - new page

 I IOSL<100 F  Q:$Y>(IOSL-26)  W !

 W ?(IOM-28\2),"Changes/Addendums to orders"

 F X=1:1:4 D

 .W !,$TR($J("",IOM)," ","-")

 .W !!?3,"CON ___ PRN ___",?20,"Drug: ",$TR($J("",22)," ","_"),?50,"Give: ",$TR($J("",42)," ","_"),?100,"Start: _________ Stop: _________"

 .W !?20,"Spec"

 .W !?3,"OT  ___ OC  ___",?20,"Inst: ",$TR($J("",72)," ","_"),?100,"Initials: ______ Date: _________"

 W !,$TR($J("",IOM)," ","-")

 Q ""

CHKREM ;Find RMs not yet triggered to print by the normal Admin time process

 ;  these will be meds that have no more admins to do today, but a

 ;  previous Give earlier today or from a prior day, still have a

 ;  Remove pending

 N IEN,RMA,RMTIM,RMDTTM,TIM,INDX

 S ORD=""

 F  S ORD=$O(^TMP("PSB",$J,"RM","B",ORD)) Q:ORD=""  D

 .F IEN=0:0 S IEN=$O(^TMP("PSB",$J,"RM","B",ORD,IEN)) Q:'IEN  D

 ..S RMTIM=$P(^TMP("PSB",$J,"RM",IEN),U,1)

 ..;skip if this RMV does not fall witin report dates

 ..Q:($P(RMTIM,".")<PSBEVDT)!($P(RMTIM,".")>PSBEVDT2)

 ..S RMA(RMTIM)=""

 .S (RMDTTM,RMTIM)="",INDX=0

 .F TIM=0:0 S TIM=$O(RMA(TIM)) Q:'TIM  D

 ..S INDX=INDX+1

 ..S RMTIM=$E($P(TIM,".",2)_"0000",1,4)

 ..S RMDTTM=$S(INDX=1:RMTIM,1:RMDTTM_"-"_RMTIM)

 ..I RMDTTM]"" D WRAPREM

 .K RMA

 K ^TMP("PSB",$J,"RM")

WRAPREM ;print standalone removes found

 N X,PSBIEN,PSBLGDT,PSBADM

 D CLEAN^PSBVT,PSJ1^PSBVT(DFN,ORD)

 ; Get LAST GIVEN date/time

 S PSBLGDT="",X=""

 F  S X=$O(^PSB(53.79,"AOIP",DFN,+PSBOIT,X),-1) Q:'X  D  Q:PSBLGDT

 .S PSBIEN=""

 .F  S PSBIEN=$O(^PSB(53.79,"AOIP",DFN,+PSBOIT,X,PSBIEN),-1) Q:PSBIEN=""  D  Q:PSBLGDT

 ..S:"MHNR"'[$P($G(^PSB(53.79,PSBIEN,0)),U,9) PSBLGDT=X

 I PSBSM D

 .S PSBSM=$S(PSBSMX:"H",1:"")_"SM"

 E  D

 .S PSBSM=""

 W !!,$J(PSBSM,3),?6,PSBTYPE,$E(PSBSCHT,1,4),?12 S PSBWFLAG=1

 W $$WRAP(14,34,PSBOITX)

 S PSBADM="Give: "_PSBDOSE_"  "_PSBSCH

 W $$WRAP(50,27,PSBADM),?78,$$WRAP(78,6,PSBMR)

 W ?85 D:PSBLGDT

 .W $E(PSBLGDT,4,5),"/",$E(PSBLGDT,6,7),"/",$E(PSBLGDT,2,3),"@",$E($P(PSBLGDT,".",2)_"0000",1,4)

 W ?100,$P($TR($$FMTE^XLFDT(PSBOST,2),"@"," ")," "),?110,$P($TR($$FMTE^XLFDT(PSBOSP,2),"@"," ")," "),?120,$S(PSBVPHI]"":PSBVPHI,1:"***"),"/"

 W $S(PSBVNI]"":PSBVNI,1:"***"),!,?100,"@"_$P(PSBOSTX,"  ",2),?110,"@"_$P(PSBOSPX,"  ",2)

 W IOINHI

 I $D(PSBDDA) S Y=0 F  S Y=$O(PSBDDA(Y)) Q:'Y  D

 .Q:$P(PSBDDA(Y),U,5)&($P(PSBDDA(Y),U,5)<PSBNOW)

 .W !?14,"*",$$WRAP(15,33,$P(PSBDDA(Y),U,3)) ;_" ("_+$P(PSBDDA(Y),U,2)_")")

 I $D(PSBADA) S Y=0 F  S Y=$O(PSBADA(Y)) Q:'Y  W !?14,"*",$$WRAP(15,33,$P(PSBADA(Y),U,3)) ;_" ("_$P(PSBADA(Y),U,4)_")")

 I $D(PSBSOLA) S Y=0 F  S Y=$O(PSBSOLA(Y)) Q:'Y  W !?14,"*",$$WRAP(15,33,$P(PSBSOLA(Y),U,3)) ;_" ("_$P(PSBSOLA(Y),U,4)_")")

 W IOINORM ; Hlight Off

 S PSBADM="Admin Times: none "

 W:PSBADM]"" $$WRAP(50,27,PSBADM)

 W !?50,"Remove Time: "_RMDTTM

 W !,$TR($J("",IOM)," ","-")

 D CLEAN^PSBVT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBODL1   10898     printed  Feb 18, 2025@23:06:55                                                                                                                                                                                                    Page 2

PSBODL1   ;BIRMINGHAM/VRN-DUE LIST ;4/26/21  12:11

 +1       ;;3.0;BAR CODE MED ADMIN;**5,9,32,28,68,70,83,106**;Mar 2004;Build 43

 +2       ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.

 +3       ;

 +4       ;*68 - print New unlimited Wp Special Instructions/OPI fields

 +5       ;*70 - add Psbsrchl to HDR

 +6       ;*83 - add Removes to the report that need attention.

 +7       ;*106- add Hazardous Handle & Dispose flags

 +8       ;

EN        ;

 +1        NEW QQ

 +2        SET PSBFOHDR=0

 +3        SET PSBORD=0

FOR

               SET PSBORD=$ORDER(^TMP("PSBO",$JOB,DFN,PSBORD))

               if PSBORD=""

                   QUIT

               SET PSBTYPE=$ORDER(^TMP("PSBO",$JOB,DFN,PSBORD,""))

               Begin DoDot:1

 +4                DO CLEAN^PSBVT

 +5                DO PSJ1^PSBVT(DFN,PSBORD)

 +6                IF PSBSCHT="C"

                       Begin DoDot:2

 +7                        SET PSBX=PSBADST

                           SET PSBFLAG=1

 +8                        IF PSBX=""

                               IF PSBONX["V"

                                   IF PSBIVT'="P"

                                       SET PSBFLAG=0

 +9                        SET (PSBYES,PSBODD)=0

 +10                       if $$PSBDCHK1^PSBVT1(PSBSCH)

                               SET PSBYES=1

 +11                       FOR I=1:1

                               if $PIECE(PSBSCH,"-",I)=""

                                   QUIT

                               IF $PIECE(PSBSCH,"-",I)?2N!($PIECE(PSBSCH,"-",I)?4N)

                                   SET PSBYES=1

 +12                       IF PSBYES

                               IF PSBADST=""

                                   IF PSBSCHT'="O"

                                       IF PSBSCHT'="OC"

                                           IF PSBSCHT'="P"

                                               QUIT

 +13                       IF PSBFREQ="O"

                               SET PSBFREQ=1440

 +14                       IF 'PSBYES

                               IF PSBADST=""

                                   IF PSBFREQ<1

                                       QUIT

 +15                       IF +PSBFREQ>0

                               IF (PSBFREQ#1440'=0)

                                   IF (1440#PSBFREQ'=0)

                                       SET PSBODD=1

 +16                       IF PSBODD

                               IF PSBADST'=""

                                   QUIT

 +17                       if PSBX=""

                               Begin DoDot:3

 +18                               IF PSBIVT="C"

                                       IF PSBCHEMT="A"

                                           SET PSBX="0000"

                                           SET PSBFLAG=0

 +19                               IF PSBIVT="C"

                                       IF PSBISYR=0

                                           SET PSBX="0000"

                                           SET PSBFLAG=0

 +20                               IF PSBIVT="S"

                                       IF PSBISYR=0

                                           SET PSBX="0000"

                                           SET PSBFLAG=0

 +21                               IF "HA"[PSBIVT

                                       SET PSBX="0000"

                                       SET PSBFLAG=0

                               End DoDot:3

 +22                       IF ("SC"[PSBIVT)

                               IF (PSBISYR=1)

                                   SET PSBX=""

 +23                       IF (PSBIVT="C")

                               IF (PSBCHEMT="P")

                                   SET PSBX=""

 +24                       IF PSBOTYP="U"

                               IF PSBX="0000"

                                   SET PSBX=""

 +25                       IF PSBIVT="P"

                               IF $GET(PSBX)=0

                                   SET PSBX=""

 +26                       IF PSBX=""

                               SET PSBX=$$GETADMIN^PSBVDLU1(DFN,PSBONX,PSBOST,PSBFREQ,PSBEVDT)

 +27                      IF '$TEST

                               KILL ^TMP("PSB",$JOB,"GETADMIN")

                               SET ^TMP("PSB",$JOB,"GETADMIN",0)=PSBX

 +28                       SET PSBADMIN=""

 +29                       FOR PSBXX=0:1

                               if '$DATA(^TMP("PSB",$JOB,"GETADMIN",PSBXX))

                                   QUIT

                               SET PSBX=$GET(^TMP("PSB",$JOB,"GETADMIN",PSBXX))

                               Begin DoDot:3

 +30                               FOR PSBY=1:1:$LENGTH(PSBX,"-")

                                       Begin DoDot:4

 +31                                       if ($PIECE(PSBX,"-",PSBY)'?2N)&($PIECE(PSBX,"-",PSBY)'?4N)

                                               QUIT

 +32                                       SET PSBAT=+(PSBODATE_"."_$PIECE(PSBX,"-",PSBY))

 +33      ; Report Window

                                           IF PSBFLAG

                                               if PSBAT<PSBOSTRT!(PSBAT>PSBOSTOP)

                                                   QUIT

 +34                                       DO VAL^PSBMLVAL(.PSBZ,DFN,PSBONX,PSBTYPE,PSBAT)

 +35                                       if $GET(PSBFREQ)>29

                                               SET PSBADMIN=PSBADMIN_$SELECT(PSBADMIN]"":"-",1:"")_$PIECE(PSBX,"-",PSBY)

 +36                                       if $GET(PSBFREQ)<30

                                               SET PSBADMIN="Due every "_$GET(PSBFREQ)_" minutes."

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

                       if PSBADMIN=""

                           QUIT

 +37               IF PSBSCHT'="C"

                       SET PSBADMIN=PSBADST

 +38      ; Get LAST GIVEN date/time

 +39               SET PSBLGDT=""

                   SET X=""

 +40               FOR

                       SET X=$ORDER(^PSB(53.79,"AOIP",DFN,+PSBOIT,X),-1)

                       if 'X

                           QUIT

                       Begin DoDot:2

 +41                       SET PSBIEN=""

 +42                       FOR

                               SET PSBIEN=$ORDER(^PSB(53.79,"AOIP",DFN,+PSBOIT,X,PSBIEN),-1)

                               if PSBIEN=""

                                   QUIT

                               Begin DoDot:3

 +43                               if "MHNR"'[$PIECE($GET(^PSB(53.79,PSBIEN,0)),U,9)

                                       SET PSBLGDT=X

                               End DoDot:3

                               if PSBLGDT

                                   QUIT

                       End DoDot:2

                       if PSBLGDT

                           QUIT

 +44               IF $Y>(IOSL-12)

                       IF $Y<(IOSL-4)

                           WRITE !?(IOM-36\2),"(Medications Continued on Next Page)",$$FTR(),$$HDR()

 +45               IF PSBSM

                       SET PSBSM=$SELECT(PSBSMX:"H",1:"")_"SM"

 +46              IF '$TEST

                       SET PSBSM=""

 +47               IF 'PSBFOHDR

                       SET PSBFOHDR=1

                       WRITE $$HDR()

 +48               WRITE !,$JUSTIFY(PSBSM,3),?6,PSBTYPE,$EXTRACT(PSBSCHT,1,4),?12

                   SET PSBWFLAG=1

 +49               SET X=""

                   SET Y=0

 +50               WRITE $$WRAP(14,34,PSBOITX)

 +51      ; *106 adds the hazardous handle/dispose notices

 +52               NEW PSBHAZ

 +53               SET PSBHAZ=""

 +54               IF PSBHAZHN=1

                       SET PSBHAZ="<<HAZ Handle>> "

 +55               IF PSBHAZDS=1

                       SET PSBHAZ=PSBHAZ_"<<HAZ Dispose>>"

 +56               if PSBHAZ]""

                       WRITE $$WRAP(14,45,PSBHAZ)

 +57               SET PSBADM="Give: "_PSBDOSE_"  "_PSBSCH

 +58               WRITE $$WRAP(50,27,PSBADM)

 +59               WRITE $$WRAP(78,6,PSBMR)

 +60               WRITE ?85

                   IF PSBLGDT

                       WRITE $EXTRACT(PSBLGDT,4,5),"/",$EXTRACT(PSBLGDT,6,7),"/",$EXTRACT(PSBLGDT,2,3)

                       WRITE "@",$EXTRACT($PIECE(PSBLGDT,".",2)_"0000",1,4)

 +61               WRITE ?100,$PIECE($TRANSLATE($$FMTE^XLFDT(PSBOST,2),"@"," ")," ")

 +62               WRITE ?110,$PIECE($TRANSLATE($$FMTE^XLFDT(PSBOSP,2),"@"," ")," ")

 +63               WRITE ?120,$SELECT(PSBVPHI]"":PSBVPHI,1:"***"),"/",$SELECT(PSBVNI]"":PSBVNI,1:"***")

 +64               WRITE !,?100,"@"_$PIECE(PSBOSTX,"  ",2),?110,"@"_$PIECE(PSBOSPX,"  ",2)

 +65      ; To Highlight the Dispense Drugs...

                   WRITE IOINHI

 +66               IF $DATA(PSBDDA)

                       SET Y=0

FOR

                           SET Y=$ORDER(PSBDDA(Y))

                           if 'Y

                               QUIT

                           Begin DoDot:2

 +67                           if $PIECE(PSBDDA(Y),U,5)&($PIECE(PSBDDA(Y),U,5)<PSBNOW)

                                   QUIT

 +68                           WRITE !?14,"*",$$WRAP(15,33,$PIECE(PSBDDA(Y),U,3)_" ("_+$PIECE(PSBDDA(Y),U,2)_")")

                           End DoDot:2

 +69               IF $DATA(PSBADA)

                       SET Y=0

FOR

                           SET Y=$ORDER(PSBADA(Y))

                           if 'Y

                               QUIT

                           WRITE !?14,"*",$$WRAP(15,33,$PIECE(PSBADA(Y),U,3)_" ("_$PIECE(PSBADA(Y),U,4)_")")

 +70               IF $DATA(PSBSOLA)

                       SET Y=0

FOR

                           SET Y=$ORDER(PSBSOLA(Y))

                           if 'Y

                               QUIT

                           WRITE !?14,"*",$$WRAP(15,33,$PIECE(PSBSOLA(Y),U,3)_" ("_$PIECE(PSBSOLA(Y),U,4)_")")

 +71      ; Highlight Off

                   WRITE IOINORM

 +72               SET PSBADM=$SELECT(PSBADMIN]"":"Admin Times: "_PSBADMIN,1:"")

 +73               if PSBADM]""

                       WRITE $$WRAP(50,27,PSBADM)

 +74      ;;

 +75      ;*68 begin

 +76               IF PSBSIFLG

                       IF '$GET(^TMP("PSJBCMA5",$JOB,DFN,PSBORD))

                           Begin DoDot:2

 +77                           WRITE !?14,"Special Instructions:",?36,"<None Entered.>",DFN,U,PSBORD,"<"

                           End DoDot:2

 +78               if PSBSIFLG

                       Begin DoDot:2

 +79                       FOR QQ=0:0

                               SET QQ=$ORDER(^TMP("PSJBCMA5",$JOB,DFN,PSBORD,QQ))

                               if 'QQ

                                   QUIT

                               Begin DoDot:3

 +80                               if QQ=1

                                       WRITE !?14,"Special Instructions:",?36,^TMP("PSJBCMA5",$JOB,DFN,PSBORD,QQ)

 +81                               if QQ>1

                                       WRITE !?36,^TMP("PSJBCMA5",$JOB,DFN,PSBORD,QQ)

                               End DoDot:3

                       End DoDot:2

 +82               WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")

               End DoDot:1

 +83       IF '$GET(PSBWFLAG)

               WRITE !!,?10,"** NO SPECIFIED MEDICATIONS TO PRINT **"

 +84       if PSBFOHDR

               WRITE $$BLANKS(),$$FTR()

 +85       KILL ^TMP("PSB",$JOB,"GETADMIN")

 +86       QUIT

 +87      ;

WRAPPUP   ;Do wrapping per PSBODL (Due List Report)

 +1       ;

 +2        NEW PSBHAZ

 +3        WRITE $$WRAP(14,34,PSBMED)

 +4       ;*106 adds the hazardous handle/dispose notices

 +5        SET PSBHAZ=""

 +6        IF PSBHAZHN=1

               SET PSBHAZ="<<HAZ Handle>> "

 +7        IF PSBHAZDS=1

               SET PSBHAZ=PSBHAZ_"<<HAZ Dispose>>"

 +8        if PSBHAZ]""

               WRITE $$WRAP(14,45,PSBHAZ)

 +9        SET PSBADM="Give: "_PSBDOSE_"  "_PSBSCH

 +10       WRITE $$WRAP(50,27,PSBADM),?78,$$WRAP(78,6,PSBMR)

 +11       WRITE ?85

           if PSBLGDT

               Begin DoDot:1

 +12               WRITE $EXTRACT(PSBLGDT,4,5),"/",$EXTRACT(PSBLGDT,6,7),"/",$EXTRACT(PSBLGDT,2,3),"@",$EXTRACT($PIECE(PSBLGDT,".",2)_"0000",1,4)

               End DoDot:1

 +13       WRITE ?100,$PIECE($TRANSLATE($$FMTE^XLFDT(PSBOST,2),"@"," ")," "),?110,$PIECE($TRANSLATE($$FMTE^XLFDT(PSBOSP,2),"@"," ")," "),?120,$SELECT(PSBVPHI]"":PSBVPHI,1:"***"),"/"

 +14       WRITE $SELECT(PSBVNI]"":PSBVNI,1:"***"),!,?100,"@"_$PIECE(PSBOSTX,"  ",2),?110,"@"_$PIECE(PSBOSPX,"  ",2)

 +15       WRITE IOINHI

 +16       IF $DATA(PSBDDA)

               SET Y=0

FOR

                   SET Y=$ORDER(PSBDDA(Y))

                   if 'Y

                       QUIT

                   Begin DoDot:1

 +17                   if $PIECE(PSBDDA(Y),U,5)&($PIECE(PSBDDA(Y),U,5)<PSBNOW)

                           QUIT

 +18      ;_" ("_+$P(PSBDDA(Y),U,2)_")")

                       WRITE !?14,"*",$$WRAP(15,33,$PIECE(PSBDDA(Y),U,3))

                   End DoDot:1

 +19      ;_" ("_$P(PSBADA(Y),U,4)_")")

           IF $DATA(PSBADA)

               SET Y=0

FOR

                   SET Y=$ORDER(PSBADA(Y))

                   if 'Y

                       QUIT

                   WRITE !?14,"*",$$WRAP(15,33,$PIECE(PSBADA(Y),U,3))

 +20      ;_" ("_$P(PSBSOLA(Y),U,4)_")")

           IF $DATA(PSBSOLA)

               SET Y=0

FOR

                   SET Y=$ORDER(PSBSOLA(Y))

                   if 'Y

                       QUIT

                   WRITE !?14,"*",$$WRAP(15,33,$PIECE(PSBSOLA(Y),U,3))

 +21      ; Hlight Off

           WRITE IOINORM

 +22       SET PSBADM=$SELECT(PSBADMIN]"":"Admin Times: "_PSBADMIN,1:"")

 +23       if PSBADM]""

               WRITE $$WRAP(50,27,PSBADM)

 +24      ;

 +25      ;Find associated remove with this ,med just printed on report

 +26      ; use Tmp Gbl from Getremov call in PSBODL

 +27       NEW IEN,RMA,RMTIM,RMDTTM,TIM,INDX

 +28       FOR IEN=0:0

               SET IEN=$ORDER(^TMP("PSB",$JOB,"RM","B",PSBORD,IEN))

               if 'IEN

                   QUIT

               Begin DoDot:1

 +29               SET RMTIM=$PIECE(^TMP("PSB",$JOB,"RM",IEN),U,1)

 +30      ;skip if this RMV does not fall witin report dates

 +31               if ($PIECE(RMTIM,".")<PSBEVDT)!($PIECE(RMTIM,".")>PSBEVDT2)

                       QUIT

 +32               SET RMA(RMTIM)=""

 +33      ;kill out used entires so won't use again at end of report time

 +34               KILL ^TMP("PSB",$JOB,"RM",IEN)

               End DoDot:1

 +35       KILL ^TMP("PSB",$JOB,"RM","B",PSBORD)

 +36      ;

 +37       SET (RMDTTM,RMTIM)=""

           SET INDX=0

 +38       FOR TIM=0:0

               SET TIM=$ORDER(RMA(TIM))

               if 'TIM

                   QUIT

               Begin DoDot:1

 +39               SET INDX=INDX+1

 +40               SET RMTIM=$EXTRACT($PIECE(TIM,".",2)_"0000",1,4)

 +41               SET RMDTTM=$SELECT(INDX=1:RMTIM,1:RMDTTM_"-"_RMTIM)

               End DoDot:1

 +42       if RMDTTM]""

               WRITE !?50,"Remove Time: "_RMDTTM

 +43      ;

 +44      ;*68 begin

 +45       IF PSBSIFLG

               IF '$GET(^TMP("PSJBCMA5",$JOB,DFN,PSBORD))

                   WRITE !?14,"Special Instructions:",?36,"<None Entered.>"

 +46       if PSBSIFLG

               Begin DoDot:1

 +47               FOR QQ=0:0

                       SET QQ=$ORDER(^TMP("PSJBCMA5",$JOB,DFN,PSBORD,QQ))

                       if 'QQ

                           QUIT

                       Begin DoDot:2

 +48                       if QQ=1

                               WRITE !?14,"Special Instructions:"

 +49                       if QQ>1

                               WRITE !

 +50                       WRITE ?36,^TMP("PSJBCMA5",$JOB,DFN,PSBORD,QQ)

                       End DoDot:2

               End DoDot:1

 +51       WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")

 +52       QUIT

 +53      ;

WRAP(X,Y,Z) ; Quick text wrap

 +1        FOR

               if '$LENGTH(Z)

                   QUIT

               Begin DoDot:1

 +2                if $X>X

                       WRITE !

 +3                if $X<X

                       WRITE ?X

 +4                IF $LENGTH(Z)<Y

                       WRITE Z

                       SET Z=""

                       QUIT

 +5                FOR PSB=Y:-1:0

                       if $EXTRACT(Z,PSB)=" "

                           QUIT

 +6                if PSB<1

                       SET PSB=Y

 +7                WRITE $EXTRACT(Z,1,PSB)

 +8                SET Z=$EXTRACT(Z,PSB+1,255)

               End DoDot:1

 +9        QUIT ""

 +10      ;

FTR()     ; [Extrinsic] Page footer

 +1       ;

 +2       ; Sub Module Description:

 +3       ; (No Description Available)

 +4       ;

 +5        IF (IOSL<100)

FOR

                   if $Y>(IOSL-10)

                       QUIT

                   WRITE !

 +6        WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","=")

 +7        SET X="Ward: "_PSBHDR("WARD")_"  Room-Bed: "_PSBHDR("ROOM")

 +8        WRITE !,PSBHDR("NAME"),?(IOM-11\2),PSBHDR("SSN"),?(IOM-$LENGTH(X)),X

 +9        QUIT ""

 +10      ;

HDR()     ; Page Header

 +1        if 'PSBFOHDR

               QUIT ""

 +2       ;*70

           DO PT^PSBOHDR(DFN,.PSBHDR,,,PSBSRCHL)

 +3        WRITE !

 +4        WRITE !

 +5        WRITE !,?(IOM-28\2),"*****   FUTURE ORDERS   *****"

 +6        WRITE !

 +7        WRITE !,"Self",?85,"Last",?100,"Start",?110,"Stop",?120,"Verifying"

 +8        WRITE !,"Med",?6,"Sched",?14,"Medication",?50,"Dose",?78,"Route",?85,"Given",?100,"Date",?110,"Date",?120,"Rph/Rn"

 +9        WRITE !,?100,"@Time",?110,"@Time"

 +10       WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")

 +11       QUIT ""

 +12      ;

BLANKS()  ; [Extrinsic] Print blanks at end of printout for changes

 +1        if '$PIECE(PSBRPT(.2),U,5)

               QUIT ""

 +2        WRITE !

 +3       ; Not enough space - new page

           IF $Y>(IOSL-26)

               WRITE ?(IOM-42\2),"(Changes/Addendums to Orders on Next Page)"

               WRITE $$FTR(),$$HDR()

 +4        IF IOSL<100

FOR

                   if $Y>(IOSL-26)

                       QUIT

                   WRITE !

 +5        WRITE ?(IOM-28\2),"Changes/Addendums to orders"

 +6        FOR X=1:1:4

               Begin DoDot:1

 +7                WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")

 +8                WRITE !!?3,"CON ___ PRN ___",?20,"Drug: ",$TRANSLATE($JUSTIFY("",22)," ","_"),?50,"Give: ",$TRANSLATE($JUSTIFY("",42)," ","_"),?100,"Start: _________ Stop: _________"

 +9                WRITE !?20,"Spec"

 +10               WRITE !?3,"OT  ___ OC  ___",?20,"Inst: ",$TRANSLATE($JUSTIFY("",72)," ","_"),?100,"Initials: ______ Date: _________"

               End DoDot:1

 +11       WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")

 +12       QUIT ""

 +13      ;

CHKREM    ;Find RMs not yet triggered to print by the normal Admin time process

 +1       ;  these will be meds that have no more admins to do today, but a

 +2       ;  previous Give earlier today or from a prior day, still have a

 +3       ;  Remove pending

 +4        NEW IEN,RMA,RMTIM,RMDTTM,TIM,INDX

 +5        SET ORD=""

 +6        FOR

               SET ORD=$ORDER(^TMP("PSB",$JOB,"RM","B",ORD))

               if ORD=""

                   QUIT

               Begin DoDot:1

 +7                FOR IEN=0:0

                       SET IEN=$ORDER(^TMP("PSB",$JOB,"RM","B",ORD,IEN))

                       if 'IEN

                           QUIT

                       Begin DoDot:2

 +8                        SET RMTIM=$PIECE(^TMP("PSB",$JOB,"RM",IEN),U,1)

 +9       ;skip if this RMV does not fall witin report dates

 +10                       if ($PIECE(RMTIM,".")<PSBEVDT)!($PIECE(RMTIM,".")>PSBEVDT2)

                               QUIT

 +11                       SET RMA(RMTIM)=""

                       End DoDot:2

 +12               SET (RMDTTM,RMTIM)=""

                   SET INDX=0

 +13               FOR TIM=0:0

                       SET TIM=$ORDER(RMA(TIM))

                       if 'TIM

                           QUIT

                       Begin DoDot:2

 +14                       SET INDX=INDX+1

 +15                       SET RMTIM=$EXTRACT($PIECE(TIM,".",2)_"0000",1,4)

 +16                       SET RMDTTM=$SELECT(INDX=1:RMTIM,1:RMDTTM_"-"_RMTIM)

 +17                       IF RMDTTM]""

                               DO WRAPREM

                       End DoDot:2

 +18               KILL RMA

               End DoDot:1

 +19       KILL ^TMP("PSB",$JOB,"RM")

 +20       QUIT

 +21      ;

WRAPREM   ;print standalone removes found

 +1        NEW X,PSBIEN,PSBLGDT,PSBADM

 +2        DO CLEAN^PSBVT

           DO PSJ1^PSBVT(DFN,ORD)

 +3       ; Get LAST GIVEN date/time

 +4        SET PSBLGDT=""

           SET X=""

 +5        FOR

               SET X=$ORDER(^PSB(53.79,"AOIP",DFN,+PSBOIT,X),-1)

               if 'X

                   QUIT

               Begin DoDot:1

 +6                SET PSBIEN=""

 +7                FOR

                       SET PSBIEN=$ORDER(^PSB(53.79,"AOIP",DFN,+PSBOIT,X,PSBIEN),-1)

                       if PSBIEN=""

                           QUIT

                       Begin DoDot:2

 +8                        if "MHNR"'[$PIECE($GET(^PSB(53.79,PSBIEN,0)),U,9)

                               SET PSBLGDT=X

                       End DoDot:2

                       if PSBLGDT

                           QUIT

               End DoDot:1

               if PSBLGDT

                   QUIT

 +9       ;

 +10       IF PSBSM

               Begin DoDot:1

 +11               SET PSBSM=$SELECT(PSBSMX:"H",1:"")_"SM"

               End DoDot:1

 +12      IF '$TEST

               Begin DoDot:1

 +13               SET PSBSM=""

               End DoDot:1

 +14       WRITE !!,$JUSTIFY(PSBSM,3),?6,PSBTYPE,$EXTRACT(PSBSCHT,1,4),?12

           SET PSBWFLAG=1

 +15       WRITE $$WRAP(14,34,PSBOITX)

 +16       SET PSBADM="Give: "_PSBDOSE_"  "_PSBSCH

 +17       WRITE $$WRAP(50,27,PSBADM),?78,$$WRAP(78,6,PSBMR)

 +18       WRITE ?85

           if PSBLGDT

               Begin DoDot:1

 +19               WRITE $EXTRACT(PSBLGDT,4,5),"/",$EXTRACT(PSBLGDT,6,7),"/",$EXTRACT(PSBLGDT,2,3),"@",$EXTRACT($PIECE(PSBLGDT,".",2)_"0000",1,4)

               End DoDot:1

 +20       WRITE ?100,$PIECE($TRANSLATE($$FMTE^XLFDT(PSBOST,2),"@"," ")," "),?110,$PIECE($TRANSLATE($$FMTE^XLFDT(PSBOSP,2),"@"," ")," "),?120,$SELECT(PSBVPHI]"":PSBVPHI,1:"***"),"/"

 +21       WRITE $SELECT(PSBVNI]"":PSBVNI,1:"***"),!,?100,"@"_$PIECE(PSBOSTX,"  ",2),?110,"@"_$PIECE(PSBOSPX,"  ",2)

 +22       WRITE IOINHI

 +23       IF $DATA(PSBDDA)

               SET Y=0

FOR

                   SET Y=$ORDER(PSBDDA(Y))

                   if 'Y

                       QUIT

                   Begin DoDot:1

 +24                   if $PIECE(PSBDDA(Y),U,5)&($PIECE(PSBDDA(Y),U,5)<PSBNOW)

                           QUIT

 +25      ;_" ("_+$P(PSBDDA(Y),U,2)_")")

                       WRITE !?14,"*",$$WRAP(15,33,$PIECE(PSBDDA(Y),U,3))

                   End DoDot:1

 +26      ;_" ("_$P(PSBADA(Y),U,4)_")")

           IF $DATA(PSBADA)

               SET Y=0

FOR

                   SET Y=$ORDER(PSBADA(Y))

                   if 'Y

                       QUIT

                   WRITE !?14,"*",$$WRAP(15,33,$PIECE(PSBADA(Y),U,3))

 +27      ;_" ("_$P(PSBSOLA(Y),U,4)_")")

           IF $DATA(PSBSOLA)

               SET Y=0

FOR

                   SET Y=$ORDER(PSBSOLA(Y))

                   if 'Y

                       QUIT

                   WRITE !?14,"*",$$WRAP(15,33,$PIECE(PSBSOLA(Y),U,3))

 +28      ; Hlight Off

           WRITE IOINORM

 +29       SET PSBADM="Admin Times: none "

 +30       if PSBADM]""

               WRITE $$WRAP(50,27,PSBADM)

 +31       WRITE !?50,"Remove Time: "_RMDTTM

 +32       WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")

 +33       DO CLEAN^PSBVT

 +34       QUIT

PSBODL1.m