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")
Q
;
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)," ","-")
Q
;
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")
Q
;
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBODL1 10898 printed Apr 09, 2024@20:45:58 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
