PSBODL ;BIRMINGHAM/EFC-DUE LIST ;03/06/16 3:06pm
;;3.0;BAR CODE MED ADMIN;**5,9,38,32,25,63,68,70,83**;Mar 2004;Build 89
;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
; GETSIOPI^PSJBCMA5/5763
;
;*68 - add call to retrieve New WP Special Instructions/OPI fields
;*70 - add Clinic filter and insert clinic name into array to force
; it to sort before admin times & print clinic name when changes
;*83 - add Remove times to the report that need removing.
;
EN ; Prt DL
N PSBGBL,PSBHDR,IOINHI,IOINORM,PSBGIVEN,PSBIEN,PSBLGDT,PSBEVDT,DFN,PSBFLAG,PSBSRCHL
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
;check Clinic or Nurs Unit search list *70
S PSBSRCHL=$$SRCHLIST^PSBOHDR()
;
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),"-","")
.D:$G(PSBSRCHL)]"" ;*70
..S PSBHDR(4)=""
..S:$P(PSBRPT(4),U,2)="C" PSBHDR(5)="Clinic Search List: "
..S:$P(PSBRPT(4),U,2)="I" PSBHDR(5)="Ward Location: "
.;
.I $QS(PSBGBL,4)="EMPTY" D Q
..W $$EMPTYHDR^PSBOHDR(PSBSRCHL)
..W !!?10,"** NO DATA FOUND for "_$S(PSBCLINORD:"Clinic Search List",1:"Entire Ward/Nurse Location")_" **",! Q
.;
.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,PSBODATE,PSBCLINIC,PSBCLNMB,PSBTMPSD,PSBSTTMP ;*70
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 GETREMOV^PSBO1(DFN) ;83
D EN^PSJBCMA(DFN,PSBOSTRT,"")
D:PSBCLINORD ;*70 filer clinics
. I $D(PSBRPT(2)) D FILTERCO^PSBO Q
. D INCLUDCO^PSBVDLU1
I 'PSBCLINORD D REMOVECO^PSBVDLU1 ;*70
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 Q:PSBODATE=-1 D ;Quit if Date is not valid Fileman Date added in PSB*3*63
.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 PSBCLINIC=$P(^TMP("PSJ",$J,PSBINDX,0),U,11),PSBCLNMB=$P(^TMP("PSJ",$J,PSBINDX,0),U,12) ;*70
..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 PSBCLINIC]"" S ^TMP("PSB",$J,"C",DFN,PSBORD)=PSBCLNMB_"^"_PSBCLINIC
.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)
..;*68 begin
..K ^TMP("PSJBCMA5",$J,DFN,PSBONX)
..D GETSIOPI^PSJBCMA5(DFN,PSBONX,1)
..;*68 end
..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",$G(PSBOST)<$G(PSBOSTRT) Q:'$$OKAY^PSBVDLU1(PSBOST,PSBODATE,PSBSCH,PSBONX,PSBOITX,PSBFREQ,) ;Add check for QOD schedules in PSB*3*63
..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 $G(PSBORD) S PSBCLINIC=$P($G(^TMP("PSB",$J,"C",+$G(DFN),PSBORD)),"^",2)
..I +$G(PSBCLINIC) I PSBOST>PSBNOW S ^TMP("PSBO",$J,DFN,PSBORD,PSBTYPE)="" Q
..I '$G(PSBCLINIC) 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) K PSBSTTMP D Q:$G(PSBSTTMP)
.......I ('$G(PSBCLINIC)&(PSBOST'<$$FMADD^XLFDT(PSBNOW,"","",($$GET^XPAR("DIV","PSB ADMIN BEFORE"))))) S PSBSTTMP=1 Q
.......I ($G(PSBCLINIC)&(PSBOST'<PSBNOW)) S ^TMP("PSBO",$J,DFN,PSBORD,PSBTYPE,PSBAT)="",PSBSTTMP=1 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 !,PSBCLINIC ;*70
..W !,$J(PSBSM,3),?6,PSBTYPE,$E(PSBSCHT,1,4),?12 S PSBWFLAG=1
..S X="",Y=0
..D WRAPPUP^PSBODL1
.;check for Removes not yet printed on report
.D CHKREM^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
I $G(PSBODATE)=-1 W !!,?10,"** NO SPECIFIED MEDICATIONS TO PRINT **",$$BLANKS(),$$FTR^PSBODL1() ;Add no medications message, blank lines and footer to patients for invalid Fileman date in PSB*3*63
;
K ^TMP("PSJBCMA5",$J)
Q
HDR() ;
D PT^PSBOHDR(DFN,.PSBHDR,,,PSBSRCHL)
W !
W:PSBCLINORD "Location"
W ?100,"Start",?110,"Stop"
W !,"Self",?85,"Last",?100,"Date",?110,"Date",?120,"Verifying"
W !,"Med",?6,"Sched",?14,"Medication",?50,"Dose",?78,"Route",?85,"Given",?100,"@Time",?110,"@Time",?120,"Rph/Rn"
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 !!?48,"Remove: ",$TR($J("",42)," ","_") ;*83
.W !?20,"Spec"
.W !?3,"OT ___ OC ___"
.W ?20,"Inst: ",$TR($J("",72)," ","_")
.W ?100,"Initials: ______ Date: _________"
W !,$TR($J("",IOM)," ","-")
Q ""
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBODL 11657 printed Dec 13, 2024@01:40:31 Page 2
PSBODL ;BIRMINGHAM/EFC-DUE LIST ;03/06/16 3:06pm
+1 ;;3.0;BAR CODE MED ADMIN;**5,9,38,32,25,63,68,70,83**;Mar 2004;Build 89
+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 ; GETSIOPI^PSJBCMA5/5763
+9 ;
+10 ;*68 - add call to retrieve New WP Special Instructions/OPI fields
+11 ;*70 - add Clinic filter and insert clinic name into array to force
+12 ; it to sort before admin times & print clinic name when changes
+13 ;*83 - add Remove times to the report that need removing.
+14 ;
EN ; Prt DL
+1 NEW PSBGBL,PSBHDR,IOINHI,IOINORM,PSBGIVEN,PSBIEN,PSBLGDT,PSBEVDT,DFN,PSBFLAG,PSBSRCHL
+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 ;check Clinic or Nurs Unit search list *70
+7 SET PSBSRCHL=$$SRCHLIST^PSBOHDR()
+8 ;
+9 FOR
SET PSBGBL=$QUERY(@PSBGBL)
if PSBGBL=""
QUIT
if $QSUBSCRIPT(PSBGBL,1)'="PSBO"!($QSUBSCRIPT(PSBGBL,2)'=$JOB)
QUIT
Begin DoDot:1
+10 SET DFN=$QSUBSCRIPT(PSBGBL,5)
+11 KILL PSBHDR
+12 SET PSBHDR(1)="MEDICATION DUE LIST for "
+13 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)
+14 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)
+15 SET PSBHDR(2)="Schedule Type(s): --"
+16 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),"-","")
+17 SET PSBHDR(3)="Order Type(s): --"
+18 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),"-","")
+19 ;*70
if $GET(PSBSRCHL)]""
Begin DoDot:2
+20 SET PSBHDR(4)=""
+21 if $PIECE(PSBRPT(4),U,2)="C"
SET PSBHDR(5)="Clinic Search List: "
+22 if $PIECE(PSBRPT(4),U,2)="I"
SET PSBHDR(5)="Ward Location: "
End DoDot:2
+23 ;
+24 IF $QSUBSCRIPT(PSBGBL,4)="EMPTY"
Begin DoDot:2
+25 WRITE $$EMPTYHDR^PSBOHDR(PSBSRCHL)
+26 WRITE !!?10,"** NO DATA FOUND for "_$SELECT(PSBCLINORD:"Clinic Search List",1:"Entire Ward/Nurse Location")_" **",!
QUIT
End DoDot:2
QUIT
+27 ;
+28 DO PRINT(DFN)
End DoDot:1
+29 ;
+30 KILL ^TMP("PSJ",$JOB),^TMP("PSB",$JOB),^TMP("PSBO",$JOB)
+31 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 ;*70
NEW PSBADMIN,PSBADM,PSBSTAT,PSBWFLAG,PSBODATE,PSBCLINIC,PSBCLNMB,PSBTMPSD,PSBSTTMP
+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 ;83
DO GETREMOV^PSBO1(DFN)
+9 DO EN^PSJBCMA(DFN,PSBOSTRT,"")
+10 ;*70 filer clinics
if PSBCLINORD
Begin DoDot:1
+11 IF $DATA(PSBRPT(2))
DO FILTERCO^PSBO
QUIT
+12 DO INCLUDCO^PSBVDLU1
End DoDot:1
+13 ;*70
IF 'PSBCLINORD
DO REMOVECO^PSBVDLU1
+14 IF $GET(^TMP("PSJ",$JOB,1,0))=-1
WRITE !!?10,"** NO SPECIFIED MEDICATIONS TO PRINT **",!,$$BLANKS(),$$FTR^PSBODL1()
QUIT
+15 ;Quit if Date is not valid Fileman Date added in PSB*3*63
SET PSBI1=0
FOR
SET PSBODATE=$$FMADD^XLFDT(PSBEVDT,PSBI1)
if PSBODATE>PSBEVDT2
QUIT
if PSBODATE=-1
QUIT
Begin DoDot:1
+16 SET PSBI1=1
+17 SET Y=PSBODATE
DO D^DIQ
+18 WRITE !!,"Administration Date: "_Y,!
+19 SET PSBINDX=0
+20 FOR
SET PSBINDX=$ORDER(^TMP("PSJ",$JOB,PSBINDX))
if 'PSBINDX
QUIT
Begin DoDot:2
+21 ;*70
SET PSBCLINIC=$PIECE(^TMP("PSJ",$JOB,PSBINDX,0),U,11)
SET PSBCLNMB=$PIECE(^TMP("PSJ",$JOB,PSBINDX,0),U,12)
+22 SET PSBTYPE=$PIECE(^TMP("PSJ",$JOB,PSBINDX,0),U,3)
SET PSBTYPE=$EXTRACT(PSBTYPE,$LENGTH(PSBTYPE))
+23 ; No Pend this ver
if PSBTYPE=""!(PSBTYPE="P")
QUIT
+24 SET PSBSTAT=^TMP("PSJ",$JOB,PSBINDX,1)
+25 IF $PIECE(PSBSTAT,U,7)["D"!($PIECE(PSBSTAT,U,7)="E")!($PIECE(PSBSTAT,U,8))
QUIT
+26 if PSBTYPE="U"&('$PIECE(PSBRPT(.2),U,7))
QUIT
+27 if PSBTYPE="V"&('$PIECE(PSBRPT(.2),U,6))
QUIT
+28 SET PSBTYPE=$SELECT(PSBTYPE="U":"UD-",PSBTYPE="V":"IV-",1:"**")
+29 SET Y=$PIECE(PSBSTAT,U,2)
+30 if Y="C"&('$PIECE(PSBRPT(.2),U,1))
QUIT
+31 if Y="P"&('$PIECE(PSBRPT(.2),U,2))
QUIT
+32 if Y="OC"&('$PIECE(PSBRPT(.2),U,3))
QUIT
+33 if Y="O"&('$PIECE(PSBRPT(.2),U,4))
QUIT
+34 SET PSBSCHT=Y
+35 if PSBSCHT=""
SET PSBSCHT="*"
+36 SET PSBMED=$PIECE(^TMP("PSJ",$JOB,PSBINDX,3),U,2)
+37 SET PSBORD=$PIECE(^TMP("PSJ",$JOB,PSBINDX,0),U,3)
+38 SET ^TMP("PSB",$JOB,"B",PSBTYPE,PSBSCHT,PSBMED,PSBORD)=""
+39 IF PSBCLINIC]""
SET ^TMP("PSB",$JOB,"C",DFN,PSBORD)=PSBCLNMB_"^"_PSBCLINIC
End DoDot:2
+40 IF '$DATA(^TMP("PSB",$JOB,"B"))
WRITE !!?10,"** NO SPECIFIED MEDICATIONS TO PRINT **",!,$$BLANKS(),$$FTR^PSBODL1()
QUIT
+41 SET PSBGBL=$NAME(^TMP("PSB",$JOB,"B"))
SET PSBWFLAG=0
+42 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
+43 KILL PSBORD,PSBFUTRO
+44 SET PSBTYPE=$QSUBSCRIPT(PSBGBL,4)
+45 SET PSBSCHT=$QSUBSCRIPT(PSBGBL,5)
+46 SET PSBMED=$QSUBSCRIPT(PSBGBL,6)
+47 SET PSBORD=$QSUBSCRIPT(PSBGBL,7)
+48 DO CLEAN^PSBVT
+49 DO PSJ1^PSBVT(DFN,PSBORD)
+50 ;*68 begin
+51 KILL ^TMP("PSJBCMA5",$JOB,DFN,PSBONX)
+52 DO GETSIOPI^PSJBCMA5(DFN,PSBONX,1)
+53 ;*68 end
+54 DO NOW^%DTC
SET PSBNOW=%
+55 if PSBOSP<PSBOSTRT
QUIT
+56 if (PSBOSP<PSBOSTRT)&(PSBSCHT'="O")
QUIT
+57 if (PSBOSP'>PSBNOW)
QUIT
+58 SET (PSBYES,PSBODD,PSBDAYB,PSBSCBR)=0
+59 if $$PSBDCHK1^PSBVT1(PSBSCH)
SET PSBYES=1
SET PSBDAYB=1
+60 FOR I=1:1
if $PIECE(PSBSCH,"-",I)=""
QUIT
IF $PIECE(PSBSCH,"-",I)?2N!($PIECE(PSBSCH,"-",I)?4N)
SET PSBYES=1
SET PSBSCBR=1
+61 IF PSBYES
IF PSBADST=""
IF PSBSCHT'="O"
IF PSBSCHT'="OC"
IF PSBSCHT'="P"
Begin DoDot:3
+62 DO ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Admin times required",PSBSCH)
End DoDot:3
QUIT
+63 IF PSBSCHT="OC"
SET PSBYES=1
+64 IF PSBSCHT="P"
SET PSBYES=1
+65 IF "PCS"'[PSBIVT
SET PSBYES=1
+66 IF PSBIVT["S"
IF PSBISYR'=1
SET PSBYES=1
+67 IF PSBIVT["C"
IF PSBCHEMT'="P"
IF PSBISYR'=1
SET PSBYES=1
+68 IF PSBIVT["C"
IF PSBCHEMT="A"
SET PSBYES=1
+69 IF PSBFREQ="O"
SET PSBFREQ=1440
+70 IF PSBFREQ="D"
SET PSBFREQ=""
+71 IF PSBSCHT="P"
SET PSBFREQ=1440
+72 IF PSBSCHT="O"
SET PSBFREQ=1440
+73 IF 'PSBYES
IF PSBFREQ<1
DO ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Invalid frequency received from order",PSBSCH)
QUIT
+74 SET PSBVALB=$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH)
+75 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
+76 IF +PSBFREQ>0
IF (PSBFREQ#1440'=0)
IF (1440#PSBFREQ'=0)
SET PSBODD=1
+77 IF PSBODD
IF PSBADST'=""
DO ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Administration Times on ODD SCHEDULE",PSBSCH)
QUIT
+78 IF PSBADST'=""
Begin DoDot:3
+79 FOR PSBY=1:1:$LENGTH(PSBADST,"-")
Begin DoDot:4
+80 if ($PIECE(PSBADST,"-",PSBY)'?2N)&($PIECE(PSBADST,"-",PSBY)'?4N)
Begin DoDot:5
+81 DO ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Invalid Admin times",PSBSCH)
End DoDot:5
End DoDot:4
End DoDot:3
+82 ;Add check for QOD schedules in PSB*3*63
IF PSBSCHT="C"
IF PSBOTYP="U"
IF $GET(PSBOST)<$GET(PSBOSTRT)
if '$$OKAY^PSBVDLU1(PSBOST,PSBODATE,PSBSCH,PSBONX,PSBOITX,PSBFREQ,)
QUIT
+83 IF PSBSCHT="C"
IF $$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH)
IF '$$OKAY^PSBVDLU1(PSBOST,PSBODATE,PSBSCH,PSBONX,PSBOITX,PSBFREQ)
QUIT
+84 IF PSBSCHT="O"
Begin DoDot:3
+85 SET (PSBGVN,X,Y)=""
+86 FOR
SET X=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,X),-1)
if 'X
QUIT
Begin DoDot:4
+87 FOR
SET Y=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,X,Y),-1)
if 'Y
QUIT
Begin DoDot:5
+88 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
+89 SET PSBRMN=1
+90 IF PSBSCHT="O"
Begin DoDot:3
+91 if (PSBOST'=PSBOSP)
QUIT
+92 if (PSBOSP<PSBOSTRT)
QUIT
+93 if ((%'>PSBOST)!(%'=PSBOST))
QUIT
+94 SET PSBRMN=0
End DoDot:3
+95 if 'PSBRMN
QUIT
+96 IF $GET(PSBORD)
SET PSBCLINIC=$PIECE($GET(^TMP("PSB",$JOB,"C",+$GET(DFN),PSBORD)),"^",2)
+97 IF +$GET(PSBCLINIC)
IF PSBOST>PSBNOW
SET ^TMP("PSBO",$JOB,DFN,PSBORD,PSBTYPE)=""
QUIT
+98 IF '$GET(PSBCLINIC)
IF PSBOST>$$FMADD^XLFDT(PSBNOW,"","",+($$GET^XPAR("DIV","PSB ADMIN BEFORE")))
SET ^TMP("PSBO",$JOB,DFN,PSBORD,PSBTYPE)=""
QUIT
+99 IF PSBSCHT="OC"
Begin DoDot:3
+100 SET (PSBGVN,X,Y)=""
+101 FOR
SET X=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,X),-1)
if 'X
QUIT
Begin DoDot:4
+102 FOR
SET Y=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,X,Y),-1)
if 'Y
QUIT
Begin DoDot:5
+103 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
+104 SET PSBLGDT=""
SET X=""
+105 FOR
SET X=$ORDER(^PSB(53.79,"AOIP",DFN,+PSBOIT,X),-1)
if 'X
QUIT
Begin DoDot:3
+106 SET PSBIEN=""
+107 FOR
SET PSBIEN=$ORDER(^PSB(53.79,"AOIP",DFN,+PSBOIT,X,PSBIEN),-1)
if PSBIEN=""
QUIT
Begin DoDot:4
+108 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
+109 SET PSBADMIN=""
KILL ^TMP("PSB",$JOB,"GETADMIN")
+110 IF PSBSCHT="C"
Begin DoDot:3
+111 SET PSBX=PSBADST
SET PSBFLAG=1
+112 if PSBX=""
Begin DoDot:4
+113 IF PSBIVT="C"
IF PSBCHEMT="A"
SET PSBX="0000"
SET PSBFLAG=0
+114 IF PSBIVT="C"
IF PSBISYR=0
SET PSBX="0000"
SET PSBFLAG=0
+115 IF PSBIVT="S"
IF PSBISYR'=1
SET PSBX="0000"
SET PSBFLAG=0
+116 IF "HA"[PSBIVT
if PSBIVT]""
SET PSBX="0000"
SET PSBFLAG=0
End DoDot:4
+117 IF ((PSBIVT="S")!(PSBIVT="C"))
IF (PSBISYR=1)
if +($GET(PSBX))=0
SET PSBX=""
+118 IF (PSBIVT="C")
IF (PSBCHEMT="P")
if +($GET(PSBX))=0
SET PSBX=""
+119 IF PSBOTYP="U"
IF PSBX="0000"
SET PSBX=""
+120 IF PSBIVT="P"
if +($GET(PSBX))=0
SET PSBX=""
+121 IF PSBX=""
if ($GET(PSBFREQ)>29)!(PSBFREQ="D")
SET PSBX=$$GETADMIN^PSBVDLU1(DFN,PSBONX,PSBOST,PSBFREQ,PSBODATE)
+122 IF '$TEST
SET ^TMP("PSB",$JOB,"GETADMIN",0)=PSBX
+123 if PSBX'=""
Begin DoDot:4
+124 FOR PSBXX=0:1
if '$DATA(^TMP("PSB",$JOB,"GETADMIN",PSBXX))
QUIT
SET PSBX=$GET(^TMP("PSB",$JOB,"GETADMIN",PSBXX))
Begin DoDot:5
+125 FOR PSBY=1:1:$LENGTH(PSBX,"-")
Begin DoDot:6
+126 SET PSBAT=+(PSBODATE_"."_$PIECE(PSBX,"-",PSBY))
+127 IF PSBFLAG
if PSBAT<PSBOSTRT!(PSBAT>PSBOSTOP)
QUIT
+128 DO VAL^PSBMLVAL(.PSBZ,DFN,PSBON,PSBOTYP,PSBAT)
+129 IF (PSBZ(0)<0)&(PSBCNT=1)
SET ^TMP("PSBO",$JOB,DFN,PSBORD,PSBTYPE,PSBAT)=""
QUIT
+130 IF (PSBAT'[".")
IF ($GET(PSBORD)["V")
IF (PSBOST<PSBOSTOP)
KILL PSBSTTMP
Begin DoDot:7
+131 IF ('$GET(PSBCLINIC)&(PSBOST'<$$FMADD^XLFDT(PSBNOW,"","",($$GET^XPAR("DIV","PSB ADMIN BEFORE")))))
SET PSBSTTMP=1
QUIT
+132 IF ($GET(PSBCLINIC)&(PSBOST'<PSBNOW))
SET ^TMP("PSBO",$JOB,DFN,PSBORD,PSBTYPE,PSBAT)=""
SET PSBSTTMP=1
QUIT
End DoDot:7
if $GET(PSBSTTMP)
QUIT
+133 if +PSBZ(0)<0
QUIT
+134 IF $GET(PSBOST)'>$GET(PSBAT)
Begin DoDot:7
+135 if ($GET(PSBOSP)'>$GET(PSBAT))
QUIT
+136 SET PSBADMIN=PSBADMIN_$SELECT(PSBADMIN]"":"-",1:"")_$PIECE(PSBX,"-",PSBY)
End DoDot:7
+137 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
+138 IF +$GET(PSBFREQ)>0
IF $GET(PSBFREQ)<30
IF PSBADMIN'="0000"
SET PSBADMIN="Due every "_$GET(PSBFREQ)_" minutes."
End DoDot:3
if PSBADMIN=""
QUIT
+139 IF $Y>(IOSL-(12+($LENGTH(PSBADMIN)/27)))
WRITE !?(IOM-36\2),"(Medications Continued on Next Page)",$$FTR^PSBODL1(),$$HDR()
+140 IF PSBSM
SET PSBSM=$SELECT(PSBSMX:"H",1:"")_"SM"
+141 IF '$TEST
SET PSBSM=""
+142 ;*70
WRITE !,PSBCLINIC
+143 WRITE !,$JUSTIFY(PSBSM,3),?6,PSBTYPE,$EXTRACT(PSBSCHT,1,4),?12
SET PSBWFLAG=1
+144 SET X=""
SET Y=0
+145 DO WRAPPUP^PSBODL1
End DoDot:2
+146 ;check for Removes not yet printed on report
+147 DO CHKREM^PSBODL1
+148 IF '$GET(PSBWFLAG)
WRITE !!,?10,"** NO SPECIFIED MEDICATIONS TO PRINT **"
+149 WRITE $$BLANKS(),$$FTR^PSBODL1()
+150 SET PSBORD=$ORDER(^TMP("PSBO",$JOB,DFN,""),-1)
+151 IF +$GET(PSBORD)>0
IF $PIECE(PSBRPT(.4),U,1)
IF $DATA(^TMP("PSBO",$JOB,DFN,PSBORD))
DO EN^PSBODL1
End DoDot:1
+152 ;Add no medications message, blank lines and footer to patients for invalid Fileman date in PSB*3*63
IF $GET(PSBODATE)=-1
WRITE !!,?10,"** NO SPECIFIED MEDICATIONS TO PRINT **",$$BLANKS(),$$FTR^PSBODL1()
+153 ;
+154 KILL ^TMP("PSJBCMA5",$JOB)
+155 QUIT
HDR() ;
+1 DO PT^PSBOHDR(DFN,.PSBHDR,,,PSBSRCHL)
+2 WRITE !
+3 if PSBCLINORD
WRITE "Location"
+4 WRITE ?100,"Start",?110,"Stop"
+5 WRITE !,"Self",?85,"Last",?100,"Date",?110,"Date",?120,"Verifying"
+6 WRITE !,"Med",?6,"Sched",?14,"Medication",?50,"Dose",?78,"Route",?85,"Given",?100,"@Time",?110,"@Time",?120,"Rph/Rn"
+7 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
+8 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 ;*83
WRITE !!?48,"Remove: ",$TRANSLATE($JUSTIFY("",42)," ","_")
+15 WRITE !?20,"Spec"
+16 WRITE !?3,"OT ___ OC ___"
+17 WRITE ?20,"Inst: ",$TRANSLATE($JUSTIFY("",72)," ","_")
+18 WRITE ?100,"Initials: ______ Date: _________"
End DoDot:1
+19 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
+20 QUIT ""
