PSBODL ;BIRMINGHAM/EFC-DUE LIST ;Mar 2004
;;3.0;BAR CODE MED ADMIN;**5,9,38,32,25**;Mar 2004;Build 6
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
; Reference/IA
; EN^PSJBCMA/2828
; $$GET^XPAR/2263
; ^XLFDT/10103
;
EN ; Prt DL
N PSBGBL,PSBHDR,IOINHI,IOINORM,PSBGIVEN,PSBIEN,PSBLGDT,PSBEVDT,DFN,PSBFLAG
S X="IOINHI;IOINORM" D ENDR^%ZISS S X=""
I '$D(^TMP("PSBO",$J,"B")) S ^TMP("PSBO",$J,"B","EMPTY")=""
S PSBGBL="^TMP(""PSBO"",$J,""B"")"
I $G(PSBRPT(.4)) S $P(PSBRPT(.2),U,8)=1
F S PSBGBL=$Q(@PSBGBL) Q:PSBGBL="" Q:$QS(PSBGBL,1)'="PSBO"!($QS(PSBGBL,2)'=$J) D
.S DFN=$QS(PSBGBL,5)
.K PSBHDR
.S PSBHDR(1)="MEDICATION DUE LIST for "
.S (Y,PSBEVDT)=$P(PSBRPT(.1),U,6) D D^DIQ S Z=Y,PSBHDR(1)=PSBHDR(1)_Y_"@" S Y=$P(PSBRPT(.1),U,7) S PSBHDR(1)=PSBHDR(1)_$E(Y_"0000",2,5)
.S PSBEVDT2=$P(PSBRPT(.1),U,6) S Y=$P(PSBRPT(.1),U,9) S:Y]"" PSBHDR(1)=PSBHDR(1)_" to "_Z_"@"_$E(Y_"0000",2,5)
.S PSBHDR(2)="Schedule Type(s): --"
.F Y=1:1:4 I $P(PSBRPT(.2),U,Y) S $P(PSBHDR(2),": ",2)=$P(PSBHDR(2),": ",2)_$S(PSBHDR(2)["--":"",1:"/ ")_$P("Continuous^PRN^On-Call^One-Time",U,Y)_" " S PSBHDR(2)=$TR(PSBHDR(2),"-","")
.S PSBHDR(3)="Order Type(s): --"
.F Y=6,7,8 I $P(PSBRPT(.2),U,Y) S $P(PSBHDR(3),": ",2)=$P(PSBHDR(3),": ",2)_$S(PSBHDR(3)["--":"",1:"/ ")_$P("^^^^^IV^Unit Dose^Future Orders",U,Y)_" " S PSBHDR(3)=$TR(PSBHDR(3),"-","")
.I $QS(PSBGBL,4)="EMPTY" D Q
..S X="" F S X=$O(PSBHDR(X)) Q:X="" D W !!?10,"** NO DATA FOR ENTIRE NURSE/WARD LOCATION **",! Q
...W !,PSBHDR(X)
.D PRINT(DFN)
K ^TMP("PSJ",$J),^TMP("PSB",$J),^TMP("PSBO",$J)
Q
PRINT(DFN) ;^TMP($J.
N PSBGBL,PSBOSTRT,PSBOSTOP,PSBINDX,PSBTYPE,PSBSCH,PSBSCHT
N PSBMED,PSBORD,PSB,PSBX,PSBY,PSBZ,PSBSTOP,PSBSTRT,PSBSM,PSBNUM,PSBAT
N PSBADMIN,PSBADM,PSBSTAT,PSBWFLAG
W $$HDR()
S PSBOSTRT=$P(PSBRPT(.1),U,6)+$P(PSBRPT(.1),U,7)
S PSBOSTOP=$P(PSBRPT(.1),U,6)+$P(PSBRPT(.1),U,9)
K ^TMP("PSJ",$J),^TMP("PSB",$J)
D EN^PSJBCMA(DFN,PSBOSTRT,"")
I $G(^TMP("PSJ",$J,1,0))=-1 W !!?10,"** NO SPECIFIED MEDICATIONS TO PRINT **",!,$$BLANKS(),$$FTR^PSBODL1() Q
S PSBI1=0 F S PSBODATE=$$FMADD^XLFDT(PSBEVDT,PSBI1) Q:PSBODATE>PSBEVDT2 D
.S PSBI1=1
.S Y=PSBODATE D D^DIQ
.W !!,"Administration Date: "_Y,!
.S PSBINDX=0
.F S PSBINDX=$O(^TMP("PSJ",$J,PSBINDX)) Q:'PSBINDX D
..S PSBTYPE=$P(^TMP("PSJ",$J,PSBINDX,0),U,3),PSBTYPE=$E(PSBTYPE,$L(PSBTYPE))
..Q:PSBTYPE=""!(PSBTYPE="P") ; No Pend this ver
..S PSBSTAT=^TMP("PSJ",$J,PSBINDX,1)
..I $P(PSBSTAT,U,7)["D"!($P(PSBSTAT,U,7)="E")!($P(PSBSTAT,U,8)) Q
..Q:PSBTYPE="U"&('$P(PSBRPT(.2),U,7))
..Q:PSBTYPE="V"&('$P(PSBRPT(.2),U,6))
..S PSBTYPE=$S(PSBTYPE="U":"UD-",PSBTYPE="V":"IV-",1:"**")
..S Y=$P(PSBSTAT,U,2)
..Q:Y="C"&('$P(PSBRPT(.2),U,1))
..Q:Y="P"&('$P(PSBRPT(.2),U,2))
..Q:Y="OC"&('$P(PSBRPT(.2),U,3))
..Q:Y="O"&('$P(PSBRPT(.2),U,4))
..S PSBSCHT=Y
..S:PSBSCHT="" PSBSCHT="*"
..S PSBMED=$P(^TMP("PSJ",$J,PSBINDX,3),U,2)
..S PSBORD=$P(^TMP("PSJ",$J,PSBINDX,0),U,3)
..S ^TMP("PSB",$J,"B",PSBTYPE,PSBSCHT,PSBMED,PSBORD)=""
.I '$D(^TMP("PSB",$J,"B")) W !!?10,"** NO SPECIFIED MEDICATIONS TO PRINT **",!,$$BLANKS(),$$FTR^PSBODL1() Q
.S PSBGBL=$NAME(^TMP("PSB",$J,"B")),PSBWFLAG=0
.F S PSBGBL=$Q(@PSBGBL) Q:PSBGBL="" Q:($QS(PSBGBL,1)'="PSB")!($QS(PSBGBL,2)'=$J)!($QS(PSBGBL,3)'="B") D
..K PSBORD,PSBFUTRO
..S PSBTYPE=$QS(PSBGBL,4)
..S PSBSCHT=$QS(PSBGBL,5)
..S PSBMED=$QS(PSBGBL,6)
..S PSBORD=$QS(PSBGBL,7)
..D CLEAN^PSBVT
..D PSJ1^PSBVT(DFN,PSBORD)
..D NOW^%DTC S PSBNOW=%
..Q:PSBOSP<PSBOSTRT
..Q:(PSBOSP<PSBOSTRT)&(PSBSCHT'="O")
..Q:(PSBOSP'>PSBNOW)
..S (PSBYES,PSBODD,PSBDAYB,PSBSCBR)=0
..S:$$PSBDCHK1^PSBVT1(PSBSCH) PSBYES=1,PSBDAYB=1
..F I=1:1 Q:$P(PSBSCH,"-",I)="" I $P(PSBSCH,"-",I)?2N!($P(PSBSCH,"-",I)?4N) S PSBYES=1,PSBSCBR=1
..I PSBYES,PSBADST="",PSBSCHT'="O",PSBSCHT'="OC",PSBSCHT'="P" D Q
...D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Admin times required",PSBSCH)
..I PSBSCHT="OC" S PSBYES=1
..I PSBSCHT="P" S PSBYES=1
..I "PCS"'[PSBIVT S PSBYES=1
..I PSBIVT["S",PSBISYR'=1 S PSBYES=1
..I PSBIVT["C",PSBCHEMT'="P",PSBISYR'=1 S PSBYES=1
..I PSBIVT["C",PSBCHEMT="A" S PSBYES=1
..I PSBFREQ="O" S PSBFREQ=1440
..I PSBFREQ="D" S PSBFREQ=""
..I PSBSCHT="P" S PSBFREQ=1440
..I PSBSCHT="O" S PSBFREQ=1440
..I 'PSBYES,PSBFREQ<1 D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Invalid frequency received from order",PSBSCH) Q
..S PSBVALB=$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH)
..I 'PSBDAYB,'PSBSCBR,PSBSCHT="C",PSBVALB="1",PSBADST'="",PSBFREQ<1 D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Invalid frequency received from order",PSBSCH) Q
..I +PSBFREQ>0 I (PSBFREQ#1440'=0),(1440#PSBFREQ'=0) S PSBODD=1
..I PSBODD,PSBADST'="" D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Administration Times on ODD SCHEDULE",PSBSCH) Q
..I PSBADST'="" D
...F PSBY=1:1:$L(PSBADST,"-") D
....D:($P(PSBADST,"-",PSBY)'?2N)&($P(PSBADST,"-",PSBY)'?4N)
.....D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Invalid Admin times",PSBSCH)
..I PSBSCHT="C",PSBOTYP="U" Q:'$$OKAY^PSBVDLU1(PSBOST,PSBODATE,PSBSCH,PSBONX,PSBOITX,PSBFREQ,)
..I PSBSCHT="C",$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH),'$$OKAY^PSBVDLU1(PSBOST,PSBODATE,PSBSCH,PSBONX,PSBOITX,PSBFREQ) Q
..I PSBSCHT="O" D Q:PSBGVN
...S (PSBGVN,X,Y)=""
...F S X=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X),-1) Q:'X D
....F S Y=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X,Y),-1) Q:'Y D
.....I $P(^PSB(53.79,Y,.1),U)=PSBONX,$P(^PSB(53.79,Y,0),U,9)="G" S PSBGVN=1,(X,Y)=0
..S PSBRMN=1
..I PSBSCHT="O" D
...Q:(PSBOST'=PSBOSP)
...Q:(PSBOSP<PSBOSTRT)
...Q:((%'>PSBOST)!(%'=PSBOST))
...S PSBRMN=0
..Q:'PSBRMN
..I PSBOST>$$FMADD^XLFDT(PSBNOW,"","",+($$GET^XPAR("DIV","PSB ADMIN BEFORE"))) S ^TMP("PSBO",$J,DFN,PSBORD,PSBTYPE)="" Q
..I PSBSCHT="OC" D Q:PSBGVN&('$$GET^XPAR("DIV","PSB ADMIN MULTIPLE ONCALL"))
...S (PSBGVN,X,Y)=""
...F S X=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X),-1) Q:'X D
....F S Y=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X,Y),-1) Q:'Y D
.....I $P(^PSB(53.79,Y,.1),U)=PSBONX,$P(^PSB(53.79,Y,0),U,9)="G" S PSBGVN=1,(X,Y)=0
..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:$P($G(^PSB(53.79,PSBIEN,0)),U,9)="G" PSBLGDT=X
..S PSBADMIN="" K ^TMP("PSB",$J,"GETADMIN")
..I PSBSCHT="C" D Q:PSBADMIN=""
...S PSBX=PSBADST,PSBFLAG=1
...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'=1 S PSBX="0000",PSBFLAG=0
....I "HA"[PSBIVT S:PSBIVT]"" PSBX="0000",PSBFLAG=0
...I ((PSBIVT="S")!(PSBIVT="C")),(PSBISYR=1) S:+($G(PSBX))=0 PSBX=""
...I (PSBIVT="C"),(PSBCHEMT="P") S:+($G(PSBX))=0 PSBX=""
...I PSBOTYP="U",PSBX="0000" S PSBX=""
...I PSBIVT="P" S:+($G(PSBX))=0 PSBX=""
...I PSBX="" S:($G(PSBFREQ)>29)!(PSBFREQ="D") PSBX=$$GETADMIN^PSBVDLU1(DFN,PSBONX,PSBOST,PSBFREQ,PSBODATE)
...E S ^TMP("PSB",$J,"GETADMIN",0)=PSBX
...D:PSBX'=""
....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
......S PSBAT=+(PSBODATE_"."_$P(PSBX,"-",PSBY))
......I PSBFLAG Q:PSBAT<PSBOSTRT!(PSBAT>PSBOSTOP)
......D VAL^PSBMLVAL(.PSBZ,DFN,PSBON,PSBOTYP,PSBAT)
......I (PSBZ(0)<0)&(PSBCNT=1) S ^TMP("PSBO",$J,DFN,PSBORD,PSBTYPE,PSBAT)="" Q
......I (PSBAT'["."),($G(PSBORD)["V") I (PSBOST<PSBOSTOP),(PSBOST'<PSBOSTRT) S ^TMP("PSBO",$J,DFN,PSBORD,PSBTYPE,PSBAT)="" Q
......Q:+PSBZ(0)<0
......I $G(PSBOST)'>$G(PSBAT) D
.......Q:($G(PSBOSP)'>$G(PSBAT))
.......S PSBADMIN=PSBADMIN_$S(PSBADMIN]"":"-",1:"")_$P(PSBX,"-",PSBY)
......E I ($P($G(PSBOST),".")'>$P($G(PSBAT),"."))&($P($G(PSBAT),".",2)="") S PSBADMIN=PSBADMIN_$S(PSBADMIN]"":"-",1:"")_$P(PSBX,"-",PSBY)
...I +$G(PSBFREQ)>0,$G(PSBFREQ)<30,PSBADMIN'="0000" S PSBADMIN="Due every "_$G(PSBFREQ)_" minutes."
..I $Y>(IOSL-(12+($L(PSBADMIN)/27))) W !?(IOM-36\2),"(Medications Continued on Next Page)",$$FTR^PSBODL1(),$$HDR()
..I PSBSM S PSBSM=$S(PSBSMX:"H",1:"")_"SM"
..E S PSBSM=""
..W !,$J(PSBSM,3),?6,PSBTYPE,$E(PSBSCHT,1,4),?12 S PSBWFLAG=1
..S X="",Y=0
..D WRAPPUP^PSBODL1
.I '$G(PSBWFLAG) W !!,?10,"** NO SPECIFIED MEDICATIONS TO PRINT **"
.W $$BLANKS(),$$FTR^PSBODL1()
.S PSBORD=$O(^TMP("PSBO",$J,DFN,""),-1)
.I +$G(PSBORD)>0,$P(PSBRPT(.4),U,1),$D(^TMP("PSBO",$J,DFN,PSBORD)) D EN^PSBODL1
Q
HDR() ;
D PT^PSBOHDR(DFN,.PSBHDR)
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() ;
Q:'$P(PSBRPT(.2),U,5) ""
W !
D:$Y>(IOSL-26)
.W ?(IOM-42\2),"(Changes/Addendums to Orders on Next Page)"
.W $$FTR^PSBODL1(),$$HDR() ; New page - no room for blanks
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 ___"
.W ?20,"Drug: ",$TR($J("",22)," ","_")
.W ?50,"Give: ",$TR($J("",42)," ","_")
.W ?100,"Start: _________ Stop: _________"
.W !?20,"Spec"
.W !?3,"OT ___ OC ___"
.W ?20,"Inst: ",$TR($J("",72)," ","_")
.W ?100,"Initials: ______ Date: _________"
W !,$TR($J("",IOM)," ","-")
Q ""
PSBODL ;BIRMINGHAM/EFC-DUE LIST ;Mar 2004
+1 ;;3.0;BAR CODE MED ADMIN;**5,9,38,32,25**;Mar 2004;Build 6
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; EN^PSJBCMA/2828
+6 ; $$GET^XPAR/2263
+7 ; ^XLFDT/10103
+8 ;
EN ; Prt DL
+1 NEW PSBGBL,PSBHDR,IOINHI,IOINORM,PSBGIVEN,PSBIEN,PSBLGDT,PSBEVDT,DFN,PSBFLAG
+2 SET X="IOINHI;IOINORM"
DO ENDR^%ZISS
SET X=""
+3 IF '$DATA(^TMP("PSBO",$JOB,"B"))
SET ^TMP("PSBO",$JOB,"B","EMPTY")=""
+4 SET PSBGBL="^TMP(""PSBO"",$J,""B"")"
+5 IF $GET(PSBRPT(.4))
SET $PIECE(PSBRPT(.2),U,8)=1
+6 FOR
SET PSBGBL=$QUERY(@PSBGBL)
IF PSBGBL=""
QUIT
IF $QSUBSCRIPT(PSBGBL,1)'="PSBO"!($QSUBSCRIPT(PSBGBL,2)'=$JOB)
QUIT
Begin DoDot:1
+7 SET DFN=$QSUBSCRIPT(PSBGBL,5)
+8 KILL PSBHDR
+9 SET PSBHDR(1)="MEDICATION DUE LIST for "
+10 SET (Y,PSBEVDT)=$PIECE(PSBRPT(.1),U,6)
DO D^DIQ
SET Z=Y
SET PSBHDR(1)=PSBHDR(1)_Y_"@"
SET Y=$PIECE(PSBRPT(.1),U,7)
SET PSBHDR(1)=PSBHDR(1)_$EXTRACT(Y_"0000",2,5)
+11 SET PSBEVDT2=$PIECE(PSBRPT(.1),U,6)
SET Y=$PIECE(PSBRPT(.1),U,9)
IF Y]""
SET PSBHDR(1)=PSBHDR(1)_" to "_Z_"@"_$EXTRACT(Y_"0000",2,5)
+12 SET PSBHDR(2)="Schedule Type(s): --"
+13 FOR Y=1:1:4
IF $PIECE(PSBRPT(.2),U,Y)
SET $PIECE(PSBHDR(2),": ",2)=$PIECE(PSBHDR(2),": ",2)_$SELECT(PSBHDR(2)["--":"",1:"/ ")_$PIECE("Continuous^PRN^On-Call^One-Time",U,Y)_" "
SET PSBHDR(2)=$TRANSLATE(PSBHDR(2),"-","")
+14 SET PSBHDR(3)="Order Type(s): --"
+15 FOR Y=6,7,8
IF $PIECE(PSBRPT(.2),U,Y)
SET $PIECE(PSBHDR(3),": ",2)=$PIECE(PSBHDR(3),": ",2)_$SELECT(PSBHDR(3)["--":"",1:"/ ")_$PIECE("^^^^^IV^Unit Dose^Future Orders",U,Y)_" "
SET PSBHDR(3)=$TRANSLATE(PSBHDR(3),"-","")
+16 IF $QSUBSCRIPT(PSBGBL,4)="EMPTY"
Begin DoDot:2
+17 SET X=""
FOR
SET X=$ORDER(PSBHDR(X))
IF X=""
QUIT
Begin DoDot:3
+18 WRITE !,PSBHDR(X)
End DoDot:3
WRITE !!?10,"** NO DATA FOR ENTIRE NURSE/WARD LOCATION **",!
QUIT
End DoDot:2
QUIT
+19 DO PRINT(DFN)
End DoDot:1
+20 KILL ^TMP("PSJ",$JOB),^TMP("PSB",$JOB),^TMP("PSBO",$JOB)
+21 QUIT
PRINT(DFN) ;^TMP($J.
+1 NEW PSBGBL,PSBOSTRT,PSBOSTOP,PSBINDX,PSBTYPE,PSBSCH,PSBSCHT
+2 NEW PSBMED,PSBORD,PSB,PSBX,PSBY,PSBZ,PSBSTOP,PSBSTRT,PSBSM,PSBNUM,PSBAT
+3 NEW PSBADMIN,PSBADM,PSBSTAT,PSBWFLAG
+4 WRITE $$HDR()
+5 SET PSBOSTRT=$PIECE(PSBRPT(.1),U,6)+$PIECE(PSBRPT(.1),U,7)
+6 SET PSBOSTOP=$PIECE(PSBRPT(.1),U,6)+$PIECE(PSBRPT(.1),U,9)
+7 KILL ^TMP("PSJ",$JOB),^TMP("PSB",$JOB)
+8 DO EN^PSJBCMA(DFN,PSBOSTRT,"")
+9 IF $GET(^TMP("PSJ",$JOB,1,0))=-1
WRITE !!?10,"** NO SPECIFIED MEDICATIONS TO PRINT **",!,$$BLANKS(),$$FTR^PSBODL1()
QUIT
+10 SET PSBI1=0
FOR
SET PSBODATE=$$FMADD^XLFDT(PSBEVDT,PSBI1)
IF PSBODATE>PSBEVDT2
QUIT
Begin DoDot:1
+11 SET PSBI1=1
+12 SET Y=PSBODATE
DO D^DIQ
+13 WRITE !!,"Administration Date: "_Y,!
+14 SET PSBINDX=0
+15 FOR
SET PSBINDX=$ORDER(^TMP("PSJ",$JOB,PSBINDX))
IF 'PSBINDX
QUIT
Begin DoDot:2
+16 SET PSBTYPE=$PIECE(^TMP("PSJ",$JOB,PSBINDX,0),U,3)
SET PSBTYPE=$EXTRACT(PSBTYPE,$LENGTH(PSBTYPE))
+17 ; No Pend this ver
IF PSBTYPE=""!(PSBTYPE="P")
QUIT
+18 SET PSBSTAT=^TMP("PSJ",$JOB,PSBINDX,1)
+19 IF $PIECE(PSBSTAT,U,7)["D"!($PIECE(PSBSTAT,U,7)="E")!($PIECE(PSBSTAT,U,8))
QUIT
+20 IF PSBTYPE="U"&('$PIECE(PSBRPT(.2),U,7))
QUIT
+21 IF PSBTYPE="V"&('$PIECE(PSBRPT(.2),U,6))
QUIT
+22 SET PSBTYPE=$SELECT(PSBTYPE="U":"UD-",PSBTYPE="V":"IV-",1:"**")
+23 SET Y=$PIECE(PSBSTAT,U,2)
+24 IF Y="C"&('$PIECE(PSBRPT(.2),U,1))
QUIT
+25 IF Y="P"&('$PIECE(PSBRPT(.2),U,2))
QUIT
+26 IF Y="OC"&('$PIECE(PSBRPT(.2),U,3))
QUIT
+27 IF Y="O"&('$PIECE(PSBRPT(.2),U,4))
QUIT
+28 SET PSBSCHT=Y
+29 IF PSBSCHT=""
SET PSBSCHT="*"
+30 SET PSBMED=$PIECE(^TMP("PSJ",$JOB,PSBINDX,3),U,2)
+31 SET PSBORD=$PIECE(^TMP("PSJ",$JOB,PSBINDX,0),U,3)
+32 SET ^TMP("PSB",$JOB,"B",PSBTYPE,PSBSCHT,PSBMED,PSBORD)=""
End DoDot:2
+33 IF '$DATA(^TMP("PSB",$JOB,"B"))
WRITE !!?10,"** NO SPECIFIED MEDICATIONS TO PRINT **",!,$$BLANKS(),$$FTR^PSBODL1()
QUIT
+34 SET PSBGBL=$NAME(^TMP("PSB",$JOB,"B"))
SET PSBWFLAG=0
+35 FOR
SET PSBGBL=$QUERY(@PSBGBL)
IF PSBGBL=""
QUIT
IF ($QSUBSCRIPT(PSBGBL,1)'="PSB")!($QSUBSCRIPT(PSBGBL,2)'=$JOB)!($QSUBSCRIPT(PSBGBL,3)'="B")
QUIT
Begin DoDot:2
+36 KILL PSBORD,PSBFUTRO
+37 SET PSBTYPE=$QSUBSCRIPT(PSBGBL,4)
+38 SET PSBSCHT=$QSUBSCRIPT(PSBGBL,5)
+39 SET PSBMED=$QSUBSCRIPT(PSBGBL,6)
+40 SET PSBORD=$QSUBSCRIPT(PSBGBL,7)
+41 DO CLEAN^PSBVT
+42 DO PSJ1^PSBVT(DFN,PSBORD)
+43 DO NOW^%DTC
SET PSBNOW=%
+44 IF PSBOSP<PSBOSTRT
QUIT
+45 IF (PSBOSP<PSBOSTRT)&(PSBSCHT'="O")
QUIT
+46 IF (PSBOSP'>PSBNOW)
QUIT
+47 SET (PSBYES,PSBODD,PSBDAYB,PSBSCBR)=0
+48 IF $$PSBDCHK1^PSBVT1(PSBSCH)
SET PSBYES=1
SET PSBDAYB=1
+49 FOR I=1:1
IF $PIECE(PSBSCH,"-",I)=""
QUIT
IF $PIECE(PSBSCH,"-",I)?2N!($PIECE(PSBSCH,"-",I)?4N)
SET PSBYES=1
SET PSBSCBR=1
+50 IF PSBYES
IF PSBADST=""
IF PSBSCHT'="O"
IF PSBSCHT'="OC"
IF PSBSCHT'="P"
Begin DoDot:3
+51 DO ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Admin times required",PSBSCH)
End DoDot:3
QUIT
+52 IF PSBSCHT="OC"
SET PSBYES=1
+53 IF PSBSCHT="P"
SET PSBYES=1
+54 IF "PCS"'[PSBIVT
SET PSBYES=1
+55 IF PSBIVT["S"
IF PSBISYR'=1
SET PSBYES=1
+56 IF PSBIVT["C"
IF PSBCHEMT'="P"
IF PSBISYR'=1
SET PSBYES=1
+57 IF PSBIVT["C"
IF PSBCHEMT="A"
SET PSBYES=1
+58 IF PSBFREQ="O"
SET PSBFREQ=1440
+59 IF PSBFREQ="D"
SET PSBFREQ=""
+60 IF PSBSCHT="P"
SET PSBFREQ=1440
+61 IF PSBSCHT="O"
SET PSBFREQ=1440
+62 IF 'PSBYES
IF PSBFREQ<1
DO ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Invalid frequency received from order",PSBSCH)
QUIT
+63 SET PSBVALB=$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH)
+64 IF 'PSBDAYB
IF 'PSBSCBR
IF PSBSCHT="C"
IF PSBVALB="1"
IF PSBADST'=""
IF PSBFREQ<1
DO ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Invalid frequency received from order",PSBSCH)
QUIT
+65 IF +PSBFREQ>0
IF (PSBFREQ#1440'=0)
IF (1440#PSBFREQ'=0)
SET PSBODD=1
+66 IF PSBODD
IF PSBADST'=""
DO ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Administration Times on ODD SCHEDULE",PSBSCH)
QUIT
+67 IF PSBADST'=""
Begin DoDot:3
+68 FOR PSBY=1:1:$LENGTH(PSBADST,"-")
Begin DoDot:4
+69 IF ($PIECE(PSBADST,"-",PSBY)'?2N)&($PIECE(PSBADST,"-",PSBY)'?4N)
Begin DoDot:5
+70 DO ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Invalid Admin times",PSBSCH)
End DoDot:5
End DoDot:4
End DoDot:3
+71 IF PSBSCHT="C"
IF PSBOTYP="U"
IF '$$OKAY^PSBVDLU1(PSBOST,PSBODATE,PSBSCH,PSBONX,PSBOITX,PSBFREQ,)
QUIT
+72 IF PSBSCHT="C"
IF $$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH)
IF '$$OKAY^PSBVDLU1(PSBOST,PSBODATE,PSBSCH,PSBONX,PSBOITX,PSBFREQ)
QUIT
+73 IF PSBSCHT="O"
Begin DoDot:3
+74 SET (PSBGVN,X,Y)=""
+75 FOR
SET X=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,X),-1)
IF 'X
QUIT
Begin DoDot:4
+76 FOR
SET Y=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,X,Y),-1)
IF 'Y
QUIT
Begin DoDot:5
+77 IF $PIECE(^PSB(53.79,Y,.1),U)=PSBONX
IF $PIECE(^PSB(53.79,Y,0),U,9)="G"
SET PSBGVN=1
SET (X,Y)=0
End DoDot:5
End DoDot:4
End DoDot:3
IF PSBGVN
QUIT
+78 SET PSBRMN=1
+79 IF PSBSCHT="O"
Begin DoDot:3
+80 IF (PSBOST'=PSBOSP)
QUIT
+81 IF (PSBOSP<PSBOSTRT)
QUIT
+82 IF ((%'>PSBOST)!(%'=PSBOST))
QUIT
+83 SET PSBRMN=0
End DoDot:3
+84 IF 'PSBRMN
QUIT
+85 IF PSBOST>$$FMADD^XLFDT(PSBNOW,"","",+($$GET^XPAR("DIV","PSB ADMIN BEFORE")))
SET ^TMP("PSBO",$JOB,DFN,PSBORD,PSBTYPE)=""
QUIT
+86 IF PSBSCHT="OC"
Begin DoDot:3
+87 SET (PSBGVN,X,Y)=""
+88 FOR
SET X=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,X),-1)
IF 'X
QUIT
Begin DoDot:4
+89 FOR
SET Y=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,X,Y),-1)
IF 'Y
QUIT
Begin DoDot:5
+90 IF $PIECE(^PSB(53.79,Y,.1),U)=PSBONX
IF $PIECE(^PSB(53.79,Y,0),U,9)="G"
SET PSBGVN=1
SET (X,Y)=0
End DoDot:5
End DoDot:4
End DoDot:3
IF PSBGVN&('$$GET^XPAR("DIV","PSB ADMIN MULTIPLE ONCALL"))
QUIT
+91 SET PSBLGDT=""
SET X=""
+92 FOR
SET X=$ORDER(^PSB(53.79,"AOIP",DFN,+PSBOIT,X),-1)
IF 'X
QUIT
Begin DoDot:3
+93 SET PSBIEN=""
+94 FOR
SET PSBIEN=$ORDER(^PSB(53.79,"AOIP",DFN,+PSBOIT,X,PSBIEN),-1)
IF PSBIEN=""
QUIT
Begin DoDot:4
+95 IF $PIECE($GET(^PSB(53.79,PSBIEN,0)),U,9)="G"
SET PSBLGDT=X
End DoDot:4
IF PSBLGDT
QUIT
End DoDot:3
IF PSBLGDT
QUIT
+96 SET PSBADMIN=""
KILL ^TMP("PSB",$JOB,"GETADMIN")
+97 IF PSBSCHT="C"
Begin DoDot:3
+98 SET PSBX=PSBADST
SET PSBFLAG=1
+99 IF PSBX=""
Begin DoDot:4
+100 IF PSBIVT="C"
IF PSBCHEMT="A"
SET PSBX="0000"
SET PSBFLAG=0
+101 IF PSBIVT="C"
IF PSBISYR=0
SET PSBX="0000"
SET PSBFLAG=0
+102 IF PSBIVT="S"
IF PSBISYR'=1
SET PSBX="0000"
SET PSBFLAG=0
+103 IF "HA"[PSBIVT
IF PSBIVT]""
SET PSBX="0000"
SET PSBFLAG=0
End DoDot:4
+104 IF ((PSBIVT="S")!(PSBIVT="C"))
IF (PSBISYR=1)
IF +($GET(PSBX))=0
SET PSBX=""
+105 IF (PSBIVT="C")
IF (PSBCHEMT="P")
IF +($GET(PSBX))=0
SET PSBX=""
+106 IF PSBOTYP="U"
IF PSBX="0000"
SET PSBX=""
+107 IF PSBIVT="P"
IF +($GET(PSBX))=0
SET PSBX=""
+108 IF PSBX=""
IF ($GET(PSBFREQ)>29)!(PSBFREQ="D")
SET PSBX=$$GETADMIN^PSBVDLU1(DFN,PSBONX,PSBOST,PSBFREQ,PSBODATE)
+109 IF '$TEST
SET ^TMP("PSB",$JOB,"GETADMIN",0)=PSBX
+110 IF PSBX'=""
Begin DoDot:4
+111 FOR PSBXX=0:1
IF '$DATA(^TMP("PSB",$JOB,"GETADMIN",PSBXX))
QUIT
SET PSBX=$GET(^TMP("PSB",$JOB,"GETADMIN",PSBXX))
Begin DoDot:5
+112 FOR PSBY=1:1:$LENGTH(PSBX,"-")
Begin DoDot:6
+113 SET PSBAT=+(PSBODATE_"."_$PIECE(PSBX,"-",PSBY))
+114 IF PSBFLAG
IF PSBAT<PSBOSTRT!(PSBAT>PSBOSTOP)
QUIT
+115 DO VAL^PSBMLVAL(.PSBZ,DFN,PSBON,PSBOTYP,PSBAT)
+116 IF (PSBZ(0)<0)&(PSBCNT=1)
SET ^TMP("PSBO",$JOB,DFN,PSBORD,PSBTYPE,PSBAT)=""
QUIT
+117 IF (PSBAT'[".")
IF ($GET(PSBORD)["V")
IF (PSBOST<PSBOSTOP)
IF (PSBOST'<PSBOSTRT)
SET ^TMP("PSBO",$JOB,DFN,PSBORD,PSBTYPE,PSBAT)=""
QUIT
+118 IF +PSBZ(0)<0
QUIT
+119 IF $GET(PSBOST)'>$GET(PSBAT)
Begin DoDot:7
+120 IF ($GET(PSBOSP)'>$GET(PSBAT))
QUIT
+121 SET PSBADMIN=PSBADMIN_$SELECT(PSBADMIN]"":"-",1:"")_$PIECE(PSBX,"-",PSBY)
End DoDot:7
+122 IF '$TEST
IF ($PIECE($GET(PSBOST),".")'>$PIECE($GET(PSBAT),"."))&($PIECE($GET(PSBAT),".",2)="")
SET PSBADMIN=PSBADMIN_$SELECT(PSBADMIN]"":"-",1:"")_$PIECE(PSBX,"-",PSBY)
End DoDot:6
End DoDot:5
End DoDot:4
+123 IF +$GET(PSBFREQ)>0
IF $GET(PSBFREQ)<30
IF PSBADMIN'="0000"
SET PSBADMIN="Due every "_$GET(PSBFREQ)_" minutes."
End DoDot:3
IF PSBADMIN=""
QUIT
+124 IF $Y>(IOSL-(12+($LENGTH(PSBADMIN)/27)))
WRITE !?(IOM-36\2),"(Medications Continued on Next Page)",$$FTR^PSBODL1(),$$HDR()
+125 IF PSBSM
SET PSBSM=$SELECT(PSBSMX:"H",1:"")_"SM"
+126 IF '$TEST
SET PSBSM=""
+127 WRITE !,$JUSTIFY(PSBSM,3),?6,PSBTYPE,$EXTRACT(PSBSCHT,1,4),?12
SET PSBWFLAG=1
+128 SET X=""
SET Y=0
+129 DO WRAPPUP^PSBODL1
End DoDot:2
+130 IF '$GET(PSBWFLAG)
WRITE !!,?10,"** NO SPECIFIED MEDICATIONS TO PRINT **"
+131 WRITE $$BLANKS(),$$FTR^PSBODL1()
+132 SET PSBORD=$ORDER(^TMP("PSBO",$JOB,DFN,""),-1)
+133 IF +$GET(PSBORD)>0
IF $PIECE(PSBRPT(.4),U,1)
IF $DATA(^TMP("PSBO",$JOB,DFN,PSBORD))
DO EN^PSBODL1
End DoDot:1
+134 QUIT
HDR() ;
+1 DO PT^PSBOHDR(DFN,.PSBHDR)
+2 WRITE !,"Self",?85,"Last",?100,"Start",?110,"Stop",?120,"Verifying"
+3 WRITE !,"Med",?6,"Sched",?14,"Medication",?50,"Dose",?78,"Route",?85,"Given",?100,"Date",?110,"Date",?120,"Rph/Rn"
+4 WRITE !,?100,"@Time",?110,"@Time"
+5 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
+6 QUIT ""
BLANKS() ;
+1 IF '$PIECE(PSBRPT(.2),U,5)
QUIT ""
+2 WRITE !
+3 IF $Y>(IOSL-26)
Begin DoDot:1
+4 WRITE ?(IOM-42\2),"(Changes/Addendums to Orders on Next Page)"
+5 ; New page - no room for blanks
WRITE $$FTR^PSBODL1(),$$HDR()
End DoDot:1
+6 IF IOSL<100
FOR
IF $Y>(IOSL-26)
QUIT
WRITE !
+7 WRITE ?(IOM-28\2),"Changes/Addendums to orders"
+8 FOR X=1:1:4
Begin DoDot:1
+9 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
+10 WRITE !!?3,"CON ___ PRN ___"
+11 WRITE ?20,"Drug: ",$TRANSLATE($JUSTIFY("",22)," ","_")
+12 WRITE ?50,"Give: ",$TRANSLATE($JUSTIFY("",42)," ","_")
+13 WRITE ?100,"Start: _________ Stop: _________"
+14 WRITE !?20,"Spec"
+15 WRITE !?3,"OT ___ OC ___"
+16 WRITE ?20,"Inst: ",$TRANSLATE($JUSTIFY("",72)," ","_")
+17 WRITE ?100,"Initials: ______ Date: _________"
End DoDot:1
+18 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
+19 QUIT ""
