PSBVDLU1 ;BIRMINGHAM/EFC-VIRTUAL DUE LIST (VDL) UTILITIES ;03/06/16 3:06pm
;;3.0;BAR CODE MED ADMIN;**13,32,68,70,83,92**;Mar 2004;Build 9
;Per VA Directive 6402, this routine should not be modified.
;
; Reference/IA
; EN^PSJBCMA/2828
; EN^PSJBCMA1/2829
; GETSIOPI^PSJBCMA5/5763
;
;*68 - add call to add special instructions (SI) entries to the
; ^TMP("PSB") global that ends up in the RESULTS ARRAY of
; RPC PSB GETORDERTAB.
;*70 - add tags to rebuild TMP array built by PSJBCMA to filter
; in or out Clinic Orders per request.
;*83 - define new var PSBDOA (duration On time in min for MRR meds)
; and add flag and remove time to PSBREC(34 & 35)
;
ODDSCH(PSBTABX) ;
I (PSBOST'<PSBWBEG)&(PSBOST'>PSBWEND) D ADD(PSBREC,PSBOTXT,PSBOST,PSBDDS,PSBSOLS,PSBADDS,PSBTABX) ;Include start date/time as admin
S PSBQUIT=0,PSBCDT=PSBOST F S PSBCDT=$$FMADD^XLFDT(PSBCDT,"","",PSBFREQ) Q:PSBQUIT=1 D
.I $P(PSBCDT,".",2)="" S PSBCDT=PSBCDT-1_".24"
.I PSBCDT>PSBWEND S PSBQUIT=1 Q
.I PSBCDT'<PSBWBEG,PSBCDT<PSBOSP D ADD(PSBREC,PSBOTXT,PSBCDT,PSBDDS,PSBSOLS,PSBADDS,PSBTABX) Q
Q
GETFREQ(PSBDFN,PSBORDN) ;
K ^TMP("PSJ1",$J)
D EN^PSJBCMA1(PSBDFN,PSBORDN,1)
S PSBFREQ=$P(^TMP("PSJ1",$J,4),U,11)
S PSBSCHBR=$P(^TMP("PSJ1",$J,2),"^",5)
I $$PSBDCHK1^PSBVT1(PSBSCHBR) S PSBFREQ=""
K ^TMP("PSJ1",$J)
Q PSBFREQ
;
GETADMIN(PSBDFN,PSBORDN,PSBSTRT,PSBFREQ,PSBEVDT) ;
;Determine administration times of an odd schedule for today
N PSBADMIN
K ^TMP("PSB",$J,"GETADMIN")
D EN^PSJBCMA1(PSBDFN,PSBORDN,1)
S PSBADMIN=$P(^TMP("PSJ1",$J,4),U,9),PSBFREQ=$P(^TMP("PSJ1",$J,4),U,11),^TMP("PSB",$J,"GETADMIN",0)=PSBADMIN
I $E(PSBFREQ)'?1N K ^TMP("PSJ1",$J) Q $G(^TMP("PSB",$J,"GETADMIN",0))
I PSBFREQ=0 K ^TMP("PSJ1",$J) Q $G(^TMP("PSB",$J,"GETADMIN",0))
I PSBSTRT'<PSBEVDT S PSBADMIN=$E($P(PSBSTRT,".",2)_"0000",1,4),^TMP("PSB",$J,"GETADMIN",0)=PSBADMIN
S PSBCDT=PSBSTRT,(PSBADTMX,PSBQUIT)=0 F S PSBCDT=$$FMADD^XLFDT(PSBCDT,"","",PSBFREQ) D Q:PSBQUIT=1
.I $P(PSBCDT,".",2)="" S PSBCDT=PSBCDT-1_".24"
.I (PSBCDT\1)>(PSBEVDT\1) S PSBQUIT=1 Q
.I (PSBCDT\1)=(PSBEVDT\1) S PSBADMIN=PSBADMIN_$S(PSBADMIN="":"",1:"-")_$E($P(PSBCDT,".",2)_"0000",1,4)
.S ^TMP("PSB",$J,"GETADMIN",PSBADTMX)=PSBADMIN
.S:($L(PSBADMIN)+5)>255 PSBADTMX=PSBADTMX+1,PSBADMIN=""
K ^TMP("PSJ1",$J),PSBADTMX
Q $G(^TMP("PSB",$J,"GETADMIN",0))
;
ADD(PSBREC,PSBSI,PSBDT,PSBDD,PSBSOL,PSBADD,PSBTAB) ;
;
; Description: Add order to ^TMP("PSB",$J,PSBTAB,...) for RPC Return RESULTS
;
; PSBREC=order hdr from above
; PSBSI=special instructions
; PSBDT=admin date/time
; PSBDD=Dispense Drugs
; PSBSOL=Solutions
; PSBADD=Additives
;
N PSB
S PSBDT=$E(PSBDT,1,12),PSBQR=0
S PSB=$O(^TMP("PSB",$J,PSBTAB,""),-1) ; Get next node
S $P(PSBREC,U,14)=PSBDT ; Admin Time sits in ^14
;
; *83 If MRR Med, add Remove code & Remove time, (34,35)
D REMOVETM(PSBMRRFL,PSBSCHT)
;
I $P(PSBREC,U,5)'="O" S X=$O(^PSB(53.79,"AORD",DFN,PSBONX,PSBDT,0)) D:X
.S $P(PSBREC,U,12)=X
.K PSBLCK L +^PSB(53.79,X):1 I L -^PSB(53.79,X) S PSBLCK=1
.S PSBSTUS=$P(^PSB(53.79,X,0),U,9),$P(PSBREC,U,13)=$S(PSBSTUS="N":"",(PSBSTUS="")&$G(PSBLCK):"U",1:PSBSTUS),$P(PSBREC,U,23)=$P(^PSB(53.79,X,0),U,10),$P(PSBREC,U,24)=$P(^PSB(53.79,X,0),U,7)
.I $D(^PSB(53.79,X)) I PSBDOSEF="PATCH",PSBSTUS="G",PSBDT=$P(^PSB(53.79,X,.1),U,3),PSBQRR=0 S PSBQR=1
.I PSBSTUS="G",$G(PSBFLAG) D CHECK ;Get the correct dispense drug
I ($P(PSBREC,U,5)="O") D
.S X=$O(^PSB(53.79,"AORDX",DFN,PSBONX,"")) Q:X=""
.S Y=$O(^PSB(53.79,"AORDX",DFN,PSBONX,X,"")) Q:Y="" S $P(PSBREC,U,12)=Y
.K PSBLCK L +^PSB(53.79,Y):1 I L -^PSB(53.79,Y) S PSBLCK=1
.S PSBSTUS=$P(^PSB(53.79,Y,0),U,9),$P(PSBREC,U,13)=$S(PSBSTUS="N":"",(PSBSTUS="")&$G(PSBLCK):"U",1:PSBSTUS),$P(PSBREC,U,24)=$P(^PSB(53.79,Y,0),U,7)
.I $D(^PSB(53.79,Y)) I PSBDOSEF="PATCH",PSBSTUS="G",PSBDT=$P(^PSB(53.79,Y,.1),U,3),PSBQRR=0 S PSBQR=1
.I PSBSTUS="G",$G(PSBFLAG) D CHECK
Q:PSBQR=1
;
S $P(PSBREC,U,25)=0 I $G(PSBTRFL),$P(PSBREC,U,11)]"",$P(PSBREC,U,11)'<$G(PSBNTDT),$P(PSBREC,U,11)'>$G(PSBTRDT) S $P(PSBREC,U,25)=1
S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=PSBREC ; Order Hdr
I $P(PSBREC,U,12)]"" S PSBONVDL($P(PSBREC,U,12))=""
S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=PSBSI ; Special Instructions
; add dispense drugs
I $D(PSBDDA) S X="" F S X=$O(PSBDDA(X)) Q:X="" S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=PSBDDA(X)
S PSBCHDT=0
I (PSBTAB'["CVRSHT"),(PSBONX["V"),(PSBOSTS="D"),($G(PSBFOR)="") D Q ;get infusing bag from DCed but not DEed orders
.D PSJ^PSBVT(PSBX)
.D INFUSING^PSBVDLU2 I PSBCOMP=0 Q
.I $D(PSBSOLA) S X="" F S X=$O(PSBSOLA(X)) Q:X="" S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=PSBSOLA(X)
.I $D(PSBADA) S X="" F S X=$O(PSBADA(X)) Q:X="" S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=PSBADA(X)
.S X="" F S X=$O(PSBPORA(PSBONX,X)) S PSBUID=$P(PSBPORA(PSBONX,X),U,1) Q:PSBUID]"" Q:X=""
.I PSBUID["P" Q
.I PSBUID["WS" D
..S PSBNODE=$O(^PSB(53.79,"AUID",DFN,X,PSBUID,""))
..S PSBUIDA(PSBUID)="ID"_U_PSBUID
..S X=0 F S X=$O(^PSB(53.79,PSBNODE,.6,X)) Q:'X S PSBUIDA(PSBUID)=PSBUIDA(PSBUID)_U_"ADD;"_$P(^PSB(53.79,PSBNODE,.6,X,0),U,1)
..S X=0 F S X=$O(^PSB(53.79,PSBNODE,.7,X)) Q:'X S PSBUIDA(PSBUID)=PSBUIDA(PSBUID)_U_"SOL;"_$P(^PSB(53.79,PSBNODE,.7,X,0),U,1)
.S PSBSONX=PSBONX
.I '$D(PSBUIDA(PSBUID)) S PSBCKOR="" F S PSBCKOR=$O(PSBPORA(PSBSONX,PSBCKOR)) Q:PSBCKOR="" D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBCKOR) Q:$D(PSBUIDA(PSBUID))
.S PSBONX=PSBSONX
.S:$D(PSBUIDA(PSBUID)) PSB=PSB+2,^TMP("PSB",$J,PSBTAB,PSB-1)=PSBUIDA(PSBUID),^TMP("PSB",$J,PSBTAB,PSB)="END"
.D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$O(PSBPORA("")))
; add additives
I $D(PSBADA) S X="" F S X=$O(PSBADA(X)) Q:X="" S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=PSBADA(X)
; add solutions
I $D(PSBSOLA) S X="" F S X=$O(PSBSOLA(X)) Q:X="" S $P(PSBSOLA(X),U,5)="",PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=PSBSOLA(X)
I PSBONX["V" D EN^PSBPOIV(DFN,PSBONX) ; get bags
I $D(^TMP("PSBAR",$J)) S PSBUID=DFN_"V"_99999 F S PSBUID=$O(^TMP("PSBAR",$J,PSBUID),-1) Q:PSBUID="" D
.S PSBUIDS=^TMP("PSBAR",$J,PSBUID)
.I $P(PSBUIDS,U,1)="I",$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" Q ; bag has invalid IV parameter, is not infusing or stopped
.I $P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S",$P(PSBUIDS,U,8)'="" Q ; label is no longer valid, bag is not infusing or stopped
.I $P(PSBUIDS,U,2)="C" Q ; bag is completed
.I $P(PSBUIDS,U,2)="G" Q ; bag is given (PBTAB)
.S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=$P(PSBUIDS,U,10,999)
K ^TMP("PSBAR",$J)
D:PSBSIOPI GETSI(DFN,PSBONX,PSBTAB) ;*68
S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)="END"
S ^TMP("PSB",$J,PSBTAB,0)=PSB
Q
;
CHECK S FILE=53.795,PSBNODE=.5,PSBIENS=X_","
F I=0:0 S I=$O(^PSB(53.79,X,PSBNODE,I)) Q:'I S $P(PSBDDS,U,3,4)=$$GET1^DIQ(FILE,I_","_PSBIENS,.01,"I")_U_$$GET1^DIQ(FILE,I_","_PSBIENS,.01)
Q
;
VNURSE(PSBTAB) ;add initials of verifying pharmacist/verifying nurse
F PSBLP=1:1:$P(^TMP("PSB",$J,PSBTAB,0),U,1) S X=^TMP("PSB",$J,PSBTAB,PSBLP) I $P(X,U)=DFN D
.K ^TMP("PSJ1",$J)
.D PSJ1^PSBVT(DFN,$P(X,U,2))
.S $P(^TMP("PSB",$J,PSBTAB,PSBLP),U,19)=$S(PSBVNI]"":PSBVNI,PSBVNX]"":$E($P(PSBVNX,",",2))_$E(PSBVNX),1:"***") ;Use first and last initial from name field if Initial field blank, PSB*3*92
K PSBLP,PSBTAB
Q
;
OKAY(PSBSTRT,PSBADMIN,PSBSCH,PSBORDER,PSBDRUG,PSBFREQ,PSBOSTS) ;
;
; Description: Determines if an order schedule is valid for
; the date in PSBADMIN (i.e. Q4D, is it valid today)
;
; PSBSTRT: Start Date of order (Time ignored)
; PSBADMIN: Date of administration to check (Time ignored)
; PSBSCH: Schedule (i.e. MO-WE-FR@0900 or Q48H...)
; PSBORDER: Order reference
; PSBDRUG: Drug ordered (Orderable Item)
; PSBOSTS: The status of the order
;
N PSBOKAY,PSBDAYS,PSBDOW
S PSBOSTS=$G(PSBOSTS)
;
S PSBOKAY=0 ; Default Flag
I PSBFREQ'="",PSBFREQ'="D",PSBFREQ'>1440 Q 1
;PRN and ONE TIMES show everyday
I (PSBSCHT="P")!(PSBSCHT="O") Q 1
S PSBDAYS=$$DAYS(PSBSCH)
;
I PSBDAYS=1 S PSBOKAY=1 Q PSBOKAY ; Order is everyday
;
; find out if today is a good day for multi days
S PSBOKAY=0,PSBRDTE=PSBSTRT
S PSBADBR=PSBADMIN\1
S PSBENR=(PSBADMIN\1)+1
I PSBDAYS>1 D Q PSBOKAY
.I PSBADBR=(PSBSTRT\1) S PSBOKAY=1
.F S PSBRDTE=$$FMADD^XLFDT(PSBRDTE,"","",PSBFREQ) Q:PSBRDTE>PSBENR D
..I $P(PSBRDTE,".",2)="" S PSBRDTE=PSBRDTE-1_".24"
..I PSBRDTE\1=PSBADBR S PSBOKAY=1
..I PSBOKAY="1" Q
;
; Try the MO-WE-FR@0800 thing as last resort
S X=PSBADMIN D H^%DTC I %Y=-1 D Q PSBOKAY ; Error
.S PSBOKAY=0
.Q:PSBOSTS="E"
.Q:$G(PSBMHND)="PSBOMH"
.D ERROR^PSBMLU($G(PSBORDER,"UNKNOWN"),$G(PSBDRUG,""),DFN,"Unable to determine schedule "_PSBSCH,PSBSCH)
S PSBDOW=$P("SU^MO^TU^WE^TH^FR^SA",U,%Y+1)
I $F(PSBSCH,PSBDOW)>0 S PSBOKAY=1 Q PSBOKAY
S PSBOKAY=0
Q PSBOKAY
;
DAYS(PSB) ; Return days between doses (-1: error, 1:everyday 2: QOD...)
;
; Is it a PRN
I PSB?.E1"PRN".E Q 1 ; Straight PRN - As Needed
;
S PSB=$TR(PSB," ","")
I PSB?2.4N.E Q 1
S X=PSBFREQ/1440 Q X
;
Q
;
LAST ;
S PSBCC=0
S ZZ="" F S ZZ=$O(^PSB(53.79,X,.3,ZZ),-1) Q:'ZZ Q:PSBFLAG=1 S PSBDATA2=$G(^(ZZ,0)) D
.S PSBCC=PSBCC+1
.I (PSBCC=2)!($P($P(PSBDATA2,U)," ")="Refused:")!($P($P(PSBDATA2,U)," ")="Held:") S $P(PSBREC,U,11)=$P(PSBDATA2,U,3),PSBFLAG=1
Q
;
GETSI(DFN,ORD,TAB) ;Get Special Instructions/Other Print Info from IM ;*68
;
; This Tag will load the SIOPI WP text into the TMP global used by
; the PSB GETORDERTAB RPC, which ends up in the RESULTS array passed
; back to the BCMA GUI.
;
N QQ
K ^TMP("PSJBCMA5",$J,DFN,ORD)
D GETSIOPI^PSJBCMA5(DFN,ORD,1)
Q:'$D(^TMP("PSJBCMA5",$J,DFN,ORD))
F QQ=0:0 S QQ=$O(^TMP("PSJBCMA5",$J,DFN,ORD,QQ)) Q:'QQ D
.S PSB=PSB+1
.S ^TMP("PSB",$J,TAB,PSB)="SI^"_^TMP("PSJBCMA5",$J,DFN,ORD,QQ)
K ^TMP("PSJBCMA5",$J,DFN,ORD)
Q
;
INCLUDCO ;Rebuild TMP global from PSJBCMA, RETAIN CLINC ORDERS ONLY *70
N QQ,IMCNT,COCNT
S (IMCNT,COCNT)=0 K ^TMP("PSJTMP",$J)
F QQ=0:0 S QQ=$O(^TMP("PSJ",$J,QQ)) Q:'QQ D
. I $P($G(^TMP("PSJ",$J,QQ,0)),U,11)]"" D
.. S COCNT=COCNT+1
.. M ^TMP("PSJTMP",$J,COCNT)=^TMP("PSJ",$J,QQ)
K ^TMP("PSJ",$J) M ^TMP("PSJ",$J)=^TMP("PSJTMP",$J)
K ^TMP("PSJTMP",$J)
S:'$D(^TMP("PSJ",$J)) ^TMP("PSJ",$J,1,0)=-1
Q
;
REMOVECO ;Rebuild TMP global from PSJBCMA, RETAIN IM ORDERS ONLY *70
N QQ,IMCNT
S IMCNT=0 K ^TMP("PSJTMP",$J)
F QQ=0:0 S QQ=$O(^TMP("PSJ",$J,QQ)) Q:'QQ D
. I $P($G(^TMP("PSJ",$J,QQ,0)),U,11)="" D Q
.. S IMCNT=IMCNT+1
.. M ^TMP("PSJTMP",$J,IMCNT)=^TMP("PSJ",$J,QQ)
K ^TMP("PSJ",$J) M ^TMP("PSJ",$J)=^TMP("PSJTMP",$J)
K ^TMP("PSJTMP",$J)
S:'$D(^TMP("PSJ",$J)) ^TMP("PSJ",$J,1,0)=-1
Q
;
MODELITE() ;
N ORDCNT,CLIN,ORDNO,STRT,STOP,STAT,PSBIMNOW,PSBIMDT
S ORDCNT=""
K ^TMP("PSJ",$J)
S PSBIMNOW=+$E($$NOW^XLFDT,1,10),PSBIMDT=$P(PSBIMNOW,".")
D EN^PSJBCMA(DFN,PSBIMNOW,PSBIMDT)
Q:^TMP("PSJ",$J,1,0)=-1 ""
F QQ=0:0 S QQ=$O(^TMP("PSJ",$J,QQ)) Q:'QQ D
. S CLIN=$P(^TMP("PSJ",$J,QQ,0),U,11)
. S ORDNO=$P(^TMP("PSJ",$J,QQ,0),U,3)
. S STRT=$P($P(^TMP("PSJ",$J,QQ,1),U,4),".")
. S STOP=$P($P(^TMP("PSJ",$J,QQ,1),U,5),".")
. S STAT=$P(^TMP("PSJ",$J,QQ,1),U,7)
. D:CLIN]""
.. I ORDNO'["P",(STAT="A"!(STAT="H")!(STAT="R")!(STAT="O")),STRT'>DT,STOP'<DT S $P(ORDCNT,U,2)=1 ;modelite display for held, renewed, and on call PSB*3*92
. D:CLIN=""
.. I ORDNO'["P",(STAT="A"!(STAT="H")!(STAT="R")!(STAT="O")),STRT'>DT,STOP'<DT S $P(ORDCNT,U)=1 ;modelite display for held and renewed, and on call PSB*3*92
Q ORDCNT
;
INITTAB ;*70
K ^TMP("PSB",$J,PSBTAB)
S ^TMP("PSB",$J,PSBTAB,0)=1
S ^TMP("PSB",$J,PSBTAB,1)="-1^No Administration(s) due at this time."
Q
;
FINDORD(BWDFWD,DFN,PSBDT,PSBTAB) ;Search a patient's orders Bwd or Fwd *70
; Find the next day that contains an Active admin time not Given.
;
N QQ,SPDT,STARTDT,STDT,STOPDT,STPDT
S PSBSIOPI="",PSBCLINORD=1
N NODE1,ENDDT,STRDT,STOPDT,STDT,SPDT,STARTDT,STOPDT,SDT,QUIT,REC,QQ
N PSBWBEG,PSBWEND,PSBWADM,FOUND,GIVE,PDT
K ^TMP("PSJ",$J)
D EN^PSJBCMA(DFN,PSBDT,PSBDT),INCLUDCO^PSBVDLU1
Q:^TMP("PSJ",$J,1,0)=-1 -1
;
;read thru psj tmp and create start date xref
F QQ=0:0 S QQ=$O(^TMP("PSJ",$J,QQ)) Q:'QQ D
. S NODE1=$G(^TMP("PSJ",$J,QQ,1))
. Q:$P(NODE1,U,7)'="A" ;not active sts
. S STRDT=$P($P(NODE1,U,4),"."),STDT(STRDT)=""
. S STPDT=$P($P(NODE1,U,5),"."),SPDT(STPDT)=""
S STARTDT=+$O(STDT(0))
Q:(BWDFWD=-1)&('STARTDT) -1
S STOPDT=+$O(SPDT(999999999),-1)
Q:(BWDFWD=1)&('STOPDT) -1
;
D:BWDFWD=-1 LOOPBWD
D:BWDFWD=1 LOOPFWD
Q PDT
;
LOOPBWD ; Loop thru days backwards and quit when pass End date. *70
S (REC,QUIT,FOUND)=0
F QQ=BWDFWD:BWDFWD S PDT=$$FMADD^XLFDT(PSBDT,QQ) Q:PDT<STARTDT D Q:FOUND!QUIT
. I PDT<STARTDT S QUIT=1 Q
. D INITTAB^PSBVDLU1
. S PSBWBEG=$P(PDT,".")_".0000"
. S PSBWEND=$P(PDT,".")_".2400"
. S PSBWADM=99999
. S PSBWADM=$$FMADD^XLFDT(PDT,"","",+PSBWADM)
. D:PSBTAB="UDTAB" EN^PSBVDLUD(DFN,PDT)
. D:PSBTAB="PBTAB" EN^PSBVDLPB(DFN,PDT)
. S FOUND=+$G(^TMP("PSB",$J,PSBTAB,2)) ;=dfn, if data found
. S GIVE=$P($G(^TMP("PSB",$J,PSBTAB,2)),U,13) ;get give sts
. S:GIVE="G" FOUND=0 ;skip, as was given
S:'FOUND PDT=-1
Q
;
LOOPFWD ; Loop thru days forwards and quit when pass End date. *70
S (REC,QUIT,FOUND)=0
F QQ=BWDFWD:BWDFWD S PDT=$$FMADD^XLFDT(PSBDT,QQ) Q:PDT>STOPDT D Q:FOUND!QUIT
. I PDT>STOPDT S QUIT=1 Q
. D INITTAB^PSBVDLU1
. S PSBWBEG=$P(PDT,".")_".0000"
. S PSBWEND=$P(PDT,".")_".2400"
. S PSBWADM=99999
. S PSBWADM=$$FMADD^XLFDT(PDT,"","",+PSBWADM)
. D:PSBTAB="UDTAB" EN^PSBVDLUD(DFN,PDT)
. D:PSBTAB="PBTAB" EN^PSBVDLPB(DFN,PDT)
. S FOUND=+$G(^TMP("PSB",$J,PSBTAB,2)) ;=dfn, if data found
. S GIVE=$P($G(^TMP("PSB",$J,PSBTAB,2)),U,13) ;get give sts
. S:GIVE="G" FOUND=0 ;skip, as was given
S:'FOUND PDT=-1
Q
;
PATCHON(DFN,ORDR) ;check if any patches are still Given & Not Removed per this patient
; Return values:
; Func: True/False (1/0) for patches do exist on a patient.
; ORDR(): array element "C"linic or "I"npatient order = 1 when
; at least 1 order of this type exists.
;
N ON,DAYSBK,ORDNO,STOPDT,IMCL
S ON=0,ORDR("C")=0,ORDR("I")=0
Q:'$D(^PSB(53.79,"APATCH",DFN)) ON
F QQ=0:0 S QQ=$O(^PSB(53.79,"APATCH",DFN,QQ)) Q:'QQ D
. F RR=0:0 S RR=$O(^PSB(53.79,"APATCH",DFN,QQ,RR)) Q:'RR D
.. I $P(^PSB(53.79,RR,0),U,9)="G" D
... S ORDNO=$P(^PSB(53.79,RR,.1),"^")
... D CLEAN^PSBVT
... D PSJ1^PSBVT(DFN,ORDNO) Q:'$G(PSBOSP)
... S STOPDT=PSBOSP
... S DAYSBK=+($$GET^XPAR("DIV","PSB VDL PATCH DAYS"))
...; simulate PSBVDLPA logic to look back Kernel param days
... I DAYSBK D NOW^%DTC I $$FMADD^XLFDT($P(STOPDT,"."),DAYSBK)<X Q
... S ON=1
... S IMCL=$S($G(PSBCLORD)]"":"C",1:"I"),ORDR(IMCL)=1
... D CLEAN^PSBVT
Q ON
;
INFUSING(DFN,ORDR) ;check if any IV's have bags infusing per this patient
; Return values:
; Func: True/False (1/0) for patches do exist on a patient.
; ORDR(): array element "C"linic or "I"npatient order = 1 when
; at least 1 order of this type exists.
;
N ON,DAYSBK,ORDNO,STOPDT,IMCL,PSBCLIEN
S ON=0,ORDR("C")=0,ORDR("I")=0
Q:'$D(^PSB(53.79,"AINFUSING",DFN)) ON
F QQ=0:0 S QQ=$O(^PSB(53.79,"AINFUSING",DFN,QQ)) Q:'QQ D
. F RR=0:0 S RR=$O(^PSB(53.79,"AINFUSING",DFN,QQ,RR)) Q:'RR D
.. S ORDNO=$P(^PSB(53.79,RR,.1),"^")
.. D CLEAN^PSBVT
.. D PSJ1^PSBVT(DFN,ORDNO) Q:'$G(PSBOSP)
.. S STOPDT=PSBOSP
.. ; simulate IV VDL logic to look 3 days back for IM meds or 7 days
.. ; for CO med.
.. D NOW^%DTC
.. I '$G(PSBCLIEN),$$FMADD^XLFDT($P(STOPDT,"."),3)<X Q
.. I $G(PSBCLIEN),$$FMADD^XLFDT($P(STOPDT,"."),7)<X Q
.. S ON=1
.. S IMCL=$S($G(PSBCLORD)]"":"C",1:"I"),ORDR(IMCL)=1
.. D CLEAN^PSBVT
Q ON
;
STOPPED(DFN,ORDR) ;check if any IV's have bags infusing per this patient
; Return values:
; Func: True/False (1/0) for patches do exist on a patient.
; ORDR(): array element "C"linic or "I"npatient order = 1 when
; at least 1 order of this type exists.
;
N ON,DAYSBK,ORDNO,STOPDT,IMCL,PSBCLIEN
S ON=0,ORDR("C")=0,ORDR("I")=0
Q:'$D(^PSB(53.79,"ASTOPPED",DFN)) ON
F QQ=0:0 S QQ=$O(^PSB(53.79,"ASTOPPED",DFN,QQ)) Q:'QQ D
. F RR=0:0 S RR=$O(^PSB(53.79,"ASTOPPED",DFN,QQ,RR)) Q:'RR D
.. S ORDNO=$P(^PSB(53.79,RR,.1),"^")
.. D CLEAN^PSBVT
.. D PSJ1^PSBVT(DFN,ORDNO) Q:'$G(PSBOSP)
.. S STOPDT=PSBOSP
.. ; simulate IV VDL logic to look 3 days back for IM meds or 7 days
.. ; for CO med.
.. D NOW^%DTC
.. I 'PSBCLIEN,$$FMADD^XLFDT($P(STOPDT,"."),3)<X Q
.. I PSBCLIEN,$$FMADD^XLFDT($P(STOPDT,"."),7)<X Q
.. S ON=1
.. S IMCL=$S($G(PSBCLORD)]"":"C",1:"I"),ORDR(IMCL)=1
.. D CLEAN^PSBVT
Q ON
;
REMOVETM(MRR,STYP) ;** Check if MRR med & add to Results array (34,35) *83
;
; Add MRR code to Results(34) and if MRR > 0 then add remove time
; to Results(35).
;
N RMDT,RMTIM
S $P(PSBREC,U,34)=MRR ;set MRR flag in 34
;
Q:'MRR ;Quit, not MRR med, no remove time
Q:(PSBSCHT="OC")!(PSBSCHT="P") ;Quit, schd types have no admin times
Q:$P(PSBREC,U,35) ;Quit, already set from get MRR rtns
;
; Remove date/time Calculation method will correctly compute a future
; Remove date/time per this admin time, by using the FMADD function
; to add the DOA value to the admin time. DOA value is the time the
; med is to be on the patient and must be removed after that time.
;
; **Notice: Sched Type of "O", Remove time = Order Stop date/time
;
; e.g. if sched is Q7D and Freq=10080, then DOA=10080 also, and is
; returned by PSJBCMA1
;
S ADMTIM=$P(PSBREC,U,14) ;admin time
S:PSBDOA RMTIM=$$FMADD^XLFDT(ADMTIM,,,PSBDOA) ;calc RM time if DOA
I (PSBDOA<1!(PSBOSP>$$NOW^XLFDT)),STYP="O" S RMTIM=PSBOSP ;RM time for One-Time, non-expired orders, PSB*3*92
S $P(PSBREC,U,35)=$G(RMTIM) ;Add RM date/time
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBVDLU1 18113 printed Apr 09, 2024@20:45:14 Page 2
PSBVDLU1 ;BIRMINGHAM/EFC-VIRTUAL DUE LIST (VDL) UTILITIES ;03/06/16 3:06pm
+1 ;;3.0;BAR CODE MED ADMIN;**13,32,68,70,83,92**;Mar 2004;Build 9
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; EN^PSJBCMA/2828
+6 ; EN^PSJBCMA1/2829
+7 ; GETSIOPI^PSJBCMA5/5763
+8 ;
+9 ;*68 - add call to add special instructions (SI) entries to the
+10 ; ^TMP("PSB") global that ends up in the RESULTS ARRAY of
+11 ; RPC PSB GETORDERTAB.
+12 ;*70 - add tags to rebuild TMP array built by PSJBCMA to filter
+13 ; in or out Clinic Orders per request.
+14 ;*83 - define new var PSBDOA (duration On time in min for MRR meds)
+15 ; and add flag and remove time to PSBREC(34 & 35)
+16 ;
ODDSCH(PSBTABX) ;
+1 ;Include start date/time as admin
IF (PSBOST'<PSBWBEG)&(PSBOST'>PSBWEND)
DO ADD(PSBREC,PSBOTXT,PSBOST,PSBDDS,PSBSOLS,PSBADDS,PSBTABX)
+2 SET PSBQUIT=0
SET PSBCDT=PSBOST
FOR
SET PSBCDT=$$FMADD^XLFDT(PSBCDT,"","",PSBFREQ)
if PSBQUIT=1
QUIT
Begin DoDot:1
+3 IF $PIECE(PSBCDT,".",2)=""
SET PSBCDT=PSBCDT-1_".24"
+4 IF PSBCDT>PSBWEND
SET PSBQUIT=1
QUIT
+5 IF PSBCDT'<PSBWBEG
IF PSBCDT<PSBOSP
DO ADD(PSBREC,PSBOTXT,PSBCDT,PSBDDS,PSBSOLS,PSBADDS,PSBTABX)
QUIT
End DoDot:1
+6 QUIT
GETFREQ(PSBDFN,PSBORDN) ;
+1 KILL ^TMP("PSJ1",$JOB)
+2 DO EN^PSJBCMA1(PSBDFN,PSBORDN,1)
+3 SET PSBFREQ=$PIECE(^TMP("PSJ1",$JOB,4),U,11)
+4 SET PSBSCHBR=$PIECE(^TMP("PSJ1",$JOB,2),"^",5)
+5 IF $$PSBDCHK1^PSBVT1(PSBSCHBR)
SET PSBFREQ=""
+6 KILL ^TMP("PSJ1",$JOB)
+7 QUIT PSBFREQ
+8 ;
GETADMIN(PSBDFN,PSBORDN,PSBSTRT,PSBFREQ,PSBEVDT) ;
+1 ;Determine administration times of an odd schedule for today
+2 NEW PSBADMIN
+3 KILL ^TMP("PSB",$JOB,"GETADMIN")
+4 DO EN^PSJBCMA1(PSBDFN,PSBORDN,1)
+5 SET PSBADMIN=$PIECE(^TMP("PSJ1",$JOB,4),U,9)
SET PSBFREQ=$PIECE(^TMP("PSJ1",$JOB,4),U,11)
SET ^TMP("PSB",$JOB,"GETADMIN",0)=PSBADMIN
+6 IF $EXTRACT(PSBFREQ)'?1N
KILL ^TMP("PSJ1",$JOB)
QUIT $GET(^TMP("PSB",$JOB,"GETADMIN",0))
+7 IF PSBFREQ=0
KILL ^TMP("PSJ1",$JOB)
QUIT $GET(^TMP("PSB",$JOB,"GETADMIN",0))
+8 IF PSBSTRT'<PSBEVDT
SET PSBADMIN=$EXTRACT($PIECE(PSBSTRT,".",2)_"0000",1,4)
SET ^TMP("PSB",$JOB,"GETADMIN",0)=PSBADMIN
+9 SET PSBCDT=PSBSTRT
SET (PSBADTMX,PSBQUIT)=0
FOR
SET PSBCDT=$$FMADD^XLFDT(PSBCDT,"","",PSBFREQ)
Begin DoDot:1
+10 IF $PIECE(PSBCDT,".",2)=""
SET PSBCDT=PSBCDT-1_".24"
+11 IF (PSBCDT\1)>(PSBEVDT\1)
SET PSBQUIT=1
QUIT
+12 IF (PSBCDT\1)=(PSBEVDT\1)
SET PSBADMIN=PSBADMIN_$SELECT(PSBADMIN="":"",1:"-")_$EXTRACT($PIECE(PSBCDT,".",2)_"0000",1,4)
+13 SET ^TMP("PSB",$JOB,"GETADMIN",PSBADTMX)=PSBADMIN
+14 if ($LENGTH(PSBADMIN)+5)>255
SET PSBADTMX=PSBADTMX+1
SET PSBADMIN=""
End DoDot:1
if PSBQUIT=1
QUIT
+15 KILL ^TMP("PSJ1",$JOB),PSBADTMX
+16 QUIT $GET(^TMP("PSB",$JOB,"GETADMIN",0))
+17 ;
ADD(PSBREC,PSBSI,PSBDT,PSBDD,PSBSOL,PSBADD,PSBTAB) ;
+1 ;
+2 ; Description: Add order to ^TMP("PSB",$J,PSBTAB,...) for RPC Return RESULTS
+3 ;
+4 ; PSBREC=order hdr from above
+5 ; PSBSI=special instructions
+6 ; PSBDT=admin date/time
+7 ; PSBDD=Dispense Drugs
+8 ; PSBSOL=Solutions
+9 ; PSBADD=Additives
+10 ;
+11 NEW PSB
+12 SET PSBDT=$EXTRACT(PSBDT,1,12)
SET PSBQR=0
+13 ; Get next node
SET PSB=$ORDER(^TMP("PSB",$JOB,PSBTAB,""),-1)
+14 ; Admin Time sits in ^14
SET $PIECE(PSBREC,U,14)=PSBDT
+15 ;
+16 ; *83 If MRR Med, add Remove code & Remove time, (34,35)
+17 DO REMOVETM(PSBMRRFL,PSBSCHT)
+18 ;
+19 IF $PIECE(PSBREC,U,5)'="O"
SET X=$ORDER(^PSB(53.79,"AORD",DFN,PSBONX,PSBDT,0))
if X
Begin DoDot:1
+20 SET $PIECE(PSBREC,U,12)=X
+21 KILL PSBLCK
LOCK +^PSB(53.79,X):1
IF $TEST
LOCK -^PSB(53.79,X)
SET PSBLCK=1
+22 SET PSBSTUS=$PIECE(^PSB(53.79,X,0),U,9)
SET $PIECE(PSBREC,U,13)=$SELECT(PSBSTUS="N":"",(PSBSTUS="")&$GET(PSBLCK):"U",1:PSBSTUS)
SET $PIECE(PSBREC,U,23)=$PIECE(^PSB(53.79,X,0),U,10)
SET $PIECE(PSBREC,U,24)=$PIECE(^PSB(53.79,X,0),U,7)
+23 IF $DATA(^PSB(53.79,X))
IF PSBDOSEF="PATCH"
IF PSBSTUS="G"
IF PSBDT=$PIECE(^PSB(53.79,X,.1),U,3)
IF PSBQRR=0
SET PSBQR=1
+24 ;Get the correct dispense drug
IF PSBSTUS="G"
IF $GET(PSBFLAG)
DO CHECK
End DoDot:1
+25 IF ($PIECE(PSBREC,U,5)="O")
Begin DoDot:1
+26 SET X=$ORDER(^PSB(53.79,"AORDX",DFN,PSBONX,""))
if X=""
QUIT
+27 SET Y=$ORDER(^PSB(53.79,"AORDX",DFN,PSBONX,X,""))
if Y=""
QUIT
SET $PIECE(PSBREC,U,12)=Y
+28 KILL PSBLCK
LOCK +^PSB(53.79,Y):1
IF $TEST
LOCK -^PSB(53.79,Y)
SET PSBLCK=1
+29 SET PSBSTUS=$PIECE(^PSB(53.79,Y,0),U,9)
SET $PIECE(PSBREC,U,13)=$SELECT(PSBSTUS="N":"",(PSBSTUS="")&$GET(PSBLCK):"U",1:PSBSTUS)
SET $PIECE(PSBREC,U,24)=$PIECE(^PSB(53.79,Y,0),U,7)
+30 IF $DATA(^PSB(53.79,Y))
IF PSBDOSEF="PATCH"
IF PSBSTUS="G"
IF PSBDT=$PIECE(^PSB(53.79,Y,.1),U,3)
IF PSBQRR=0
SET PSBQR=1
+31 IF PSBSTUS="G"
IF $GET(PSBFLAG)
DO CHECK
End DoDot:1
+32 if PSBQR=1
QUIT
+33 ;
+34 SET $PIECE(PSBREC,U,25)=0
IF $GET(PSBTRFL)
IF $PIECE(PSBREC,U,11)]""
IF $PIECE(PSBREC,U,11)'<$GET(PSBNTDT)
IF $PIECE(PSBREC,U,11)'>$GET(PSBTRDT)
SET $PIECE(PSBREC,U,25)=1
+35 ; Order Hdr
SET PSB=PSB+1
SET ^TMP("PSB",$JOB,PSBTAB,PSB)=PSBREC
+36 IF $PIECE(PSBREC,U,12)]""
SET PSBONVDL($PIECE(PSBREC,U,12))=""
+37 ; Special Instructions
SET PSB=PSB+1
SET ^TMP("PSB",$JOB,PSBTAB,PSB)=PSBSI
+38 ; add dispense drugs
+39 IF $DATA(PSBDDA)
SET X=""
FOR
SET X=$ORDER(PSBDDA(X))
if X=""
QUIT
SET PSB=PSB+1
SET ^TMP("PSB",$JOB,PSBTAB,PSB)=PSBDDA(X)
+40 SET PSBCHDT=0
+41 ;get infusing bag from DCed but not DEed orders
IF (PSBTAB'["CVRSHT")
IF (PSBONX["V")
IF (PSBOSTS="D")
IF ($GET(PSBFOR)="")
Begin DoDot:1
+42 DO PSJ^PSBVT(PSBX)
+43 DO INFUSING^PSBVDLU2
IF PSBCOMP=0
QUIT
+44 IF $DATA(PSBSOLA)
SET X=""
FOR
SET X=$ORDER(PSBSOLA(X))
if X=""
QUIT
SET PSB=PSB+1
SET ^TMP("PSB",$JOB,PSBTAB,PSB)=PSBSOLA(X)
+45 IF $DATA(PSBADA)
SET X=""
FOR
SET X=$ORDER(PSBADA(X))
if X=""
QUIT
SET PSB=PSB+1
SET ^TMP("PSB",$JOB,PSBTAB,PSB)=PSBADA(X)
+46 SET X=""
FOR
SET X=$ORDER(PSBPORA(PSBONX,X))
SET PSBUID=$PIECE(PSBPORA(PSBONX,X),U,1)
if PSBUID]""
QUIT
if X=""
QUIT
+47 IF PSBUID["P"
QUIT
+48 IF PSBUID["WS"
Begin DoDot:2
+49 SET PSBNODE=$ORDER(^PSB(53.79,"AUID",DFN,X,PSBUID,""))
+50 SET PSBUIDA(PSBUID)="ID"_U_PSBUID
+51 SET X=0
FOR
SET X=$ORDER(^PSB(53.79,PSBNODE,.6,X))
if 'X
QUIT
SET PSBUIDA(PSBUID)=PSBUIDA(PSBUID)_U_"ADD;"_$PIECE(^PSB(53.79,PSBNODE,.6,X,0),U,1)
+52 SET X=0
FOR
SET X=$ORDER(^PSB(53.79,PSBNODE,.7,X))
if 'X
QUIT
SET PSBUIDA(PSBUID)=PSBUIDA(PSBUID)_U_"SOL;"_$PIECE(^PSB(53.79,PSBNODE,.7,X,0),U,1)
End DoDot:2
+53 SET PSBSONX=PSBONX
+54 IF '$DATA(PSBUIDA(PSBUID))
SET PSBCKOR=""
FOR
SET PSBCKOR=$ORDER(PSBPORA(PSBSONX,PSBCKOR))
if PSBCKOR=""
QUIT
DO CLEAN^PSBVT
DO PSJ1^PSBVT(DFN,PSBCKOR)
if $DATA(PSBUIDA(PSBUID))
QUIT
+55 SET PSBONX=PSBSONX
+56 if $DATA(PSBUIDA(PSBUID))
SET PSB=PSB+2
SET ^TMP("PSB",$JOB,PSBTAB,PSB-1)=PSBUIDA(PSBUID)
SET ^TMP("PSB",$JOB,PSBTAB,PSB)="END"
+57 DO CLEAN^PSBVT
DO PSJ1^PSBVT(DFN,$ORDER(PSBPORA("")))
End DoDot:1
QUIT
+58 ; add additives
+59 IF $DATA(PSBADA)
SET X=""
FOR
SET X=$ORDER(PSBADA(X))
if X=""
QUIT
SET PSB=PSB+1
SET ^TMP("PSB",$JOB,PSBTAB,PSB)=PSBADA(X)
+60 ; add solutions
+61 IF $DATA(PSBSOLA)
SET X=""
FOR
SET X=$ORDER(PSBSOLA(X))
if X=""
QUIT
SET $PIECE(PSBSOLA(X),U,5)=""
SET PSB=PSB+1
SET ^TMP("PSB",$JOB,PSBTAB,PSB)=PSBSOLA(X)
+62 ; get bags
IF PSBONX["V"
DO EN^PSBPOIV(DFN,PSBONX)
+63 IF $DATA(^TMP("PSBAR",$JOB))
SET PSBUID=DFN_"V"_99999
FOR
SET PSBUID=$ORDER(^TMP("PSBAR",$JOB,PSBUID),-1)
if PSBUID=""
QUIT
Begin DoDot:1
+64 SET PSBUIDS=^TMP("PSBAR",$JOB,PSBUID)
+65 ; bag has invalid IV parameter, is not infusing or stopped
IF $PIECE(PSBUIDS,U,1)="I"
IF $PIECE(PSBUIDS,U,2)'="I"
IF $PIECE(PSBUIDS,U,2)'="S"
QUIT
+66 ; label is no longer valid, bag is not infusing or stopped
IF $PIECE(PSBUIDS,U,2)'="I"
IF $PIECE(PSBUIDS,U,2)'="S"
IF $PIECE(PSBUIDS,U,8)'=""
QUIT
+67 ; bag is completed
IF $PIECE(PSBUIDS,U,2)="C"
QUIT
+68 ; bag is given (PBTAB)
IF $PIECE(PSBUIDS,U,2)="G"
QUIT
+69 SET PSB=PSB+1
SET ^TMP("PSB",$JOB,PSBTAB,PSB)=$PIECE(PSBUIDS,U,10,999)
End DoDot:1
+70 KILL ^TMP("PSBAR",$JOB)
+71 ;*68
if PSBSIOPI
DO GETSI(DFN,PSBONX,PSBTAB)
+72 SET PSB=PSB+1
SET ^TMP("PSB",$JOB,PSBTAB,PSB)="END"
+73 SET ^TMP("PSB",$JOB,PSBTAB,0)=PSB
+74 QUIT
+75 ;
CHECK SET FILE=53.795
SET PSBNODE=.5
SET PSBIENS=X_","
+1 FOR I=0:0
SET I=$ORDER(^PSB(53.79,X,PSBNODE,I))
if 'I
QUIT
SET $PIECE(PSBDDS,U,3,4)=$$GET1^DIQ(FILE,I_","_PSBIENS,.01,"I")_U_$$GET1^DIQ(FILE,I_","_PSBIENS,.01)
+2 QUIT
+3 ;
VNURSE(PSBTAB) ;add initials of verifying pharmacist/verifying nurse
+1 FOR PSBLP=1:1:$PIECE(^TMP("PSB",$JOB,PSBTAB,0),U,1)
SET X=^TMP("PSB",$JOB,PSBTAB,PSBLP)
IF $PIECE(X,U)=DFN
Begin DoDot:1
+2 KILL ^TMP("PSJ1",$JOB)
+3 DO PSJ1^PSBVT(DFN,$PIECE(X,U,2))
+4 ;Use first and last initial from name field if Initial field blank, PSB*3*92
SET $PIECE(^TMP("PSB",$JOB,PSBTAB,PSBLP),U,19)=$SELECT(PSBVNI]"":PSBVNI,PSBVNX]"":$EXTRACT($PIECE(PSBVNX,",",2))_$EXTRACT(PSBVNX),1:"***")
End DoDot:1
+5 KILL PSBLP,PSBTAB
+6 QUIT
+7 ;
OKAY(PSBSTRT,PSBADMIN,PSBSCH,PSBORDER,PSBDRUG,PSBFREQ,PSBOSTS) ;
+1 ;
+2 ; Description: Determines if an order schedule is valid for
+3 ; the date in PSBADMIN (i.e. Q4D, is it valid today)
+4 ;
+5 ; PSBSTRT: Start Date of order (Time ignored)
+6 ; PSBADMIN: Date of administration to check (Time ignored)
+7 ; PSBSCH: Schedule (i.e. MO-WE-FR@0900 or Q48H...)
+8 ; PSBORDER: Order reference
+9 ; PSBDRUG: Drug ordered (Orderable Item)
+10 ; PSBOSTS: The status of the order
+11 ;
+12 NEW PSBOKAY,PSBDAYS,PSBDOW
+13 SET PSBOSTS=$GET(PSBOSTS)
+14 ;
+15 ; Default Flag
SET PSBOKAY=0
+16 IF PSBFREQ'=""
IF PSBFREQ'="D"
IF PSBFREQ'>1440
QUIT 1
+17 ;PRN and ONE TIMES show everyday
+18 IF (PSBSCHT="P")!(PSBSCHT="O")
QUIT 1
+19 SET PSBDAYS=$$DAYS(PSBSCH)
+20 ;
+21 ; Order is everyday
IF PSBDAYS=1
SET PSBOKAY=1
QUIT PSBOKAY
+22 ;
+23 ; find out if today is a good day for multi days
+24 SET PSBOKAY=0
SET PSBRDTE=PSBSTRT
+25 SET PSBADBR=PSBADMIN\1
+26 SET PSBENR=(PSBADMIN\1)+1
+27 IF PSBDAYS>1
Begin DoDot:1
+28 IF PSBADBR=(PSBSTRT\1)
SET PSBOKAY=1
+29 FOR
SET PSBRDTE=$$FMADD^XLFDT(PSBRDTE,"","",PSBFREQ)
if PSBRDTE>PSBENR
QUIT
Begin DoDot:2
+30 IF $PIECE(PSBRDTE,".",2)=""
SET PSBRDTE=PSBRDTE-1_".24"
+31 IF PSBRDTE\1=PSBADBR
SET PSBOKAY=1
+32 IF PSBOKAY="1"
QUIT
End DoDot:2
End DoDot:1
QUIT PSBOKAY
+33 ;
+34 ; Try the MO-WE-FR@0800 thing as last resort
+35 ; Error
SET X=PSBADMIN
DO H^%DTC
IF %Y=-1
Begin DoDot:1
+36 SET PSBOKAY=0
+37 if PSBOSTS="E"
QUIT
+38 if $GET(PSBMHND)="PSBOMH"
QUIT
+39 DO ERROR^PSBMLU($GET(PSBORDER,"UNKNOWN"),$GET(PSBDRUG,""),DFN,"Unable to determine schedule "_PSBSCH,PSBSCH)
End DoDot:1
QUIT PSBOKAY
+40 SET PSBDOW=$PIECE("SU^MO^TU^WE^TH^FR^SA",U,%Y+1)
+41 IF $FIND(PSBSCH,PSBDOW)>0
SET PSBOKAY=1
QUIT PSBOKAY
+42 SET PSBOKAY=0
+43 QUIT PSBOKAY
+44 ;
DAYS(PSB) ; Return days between doses (-1: error, 1:everyday 2: QOD...)
+1 ;
+2 ; Is it a PRN
+3 ; Straight PRN - As Needed
IF PSB?.E1"PRN".E
QUIT 1
+4 ;
+5 SET PSB=$TRANSLATE(PSB," ","")
+6 IF PSB?2.4N.E
QUIT 1
+7 SET X=PSBFREQ/1440
QUIT X
+8 ;
+9 QUIT
+10 ;
LAST ;
+1 SET PSBCC=0
+2 SET ZZ=""
FOR
SET ZZ=$ORDER(^PSB(53.79,X,.3,ZZ),-1)
if 'ZZ
QUIT
if PSBFLAG=1
QUIT
SET PSBDATA2=$GET(^(ZZ,0))
Begin DoDot:1
+3 SET PSBCC=PSBCC+1
+4 IF (PSBCC=2)!($PIECE($PIECE(PSBDATA2,U)," ")="Refused:")!($PIECE($PIECE(PSBDATA2,U)," ")="Held:")
SET $PIECE(PSBREC,U,11)=$PIECE(PSBDATA2,U,3)
SET PSBFLAG=1
End DoDot:1
+5 QUIT
+6 ;
GETSI(DFN,ORD,TAB) ;Get Special Instructions/Other Print Info from IM ;*68
+1 ;
+2 ; This Tag will load the SIOPI WP text into the TMP global used by
+3 ; the PSB GETORDERTAB RPC, which ends up in the RESULTS array passed
+4 ; back to the BCMA GUI.
+5 ;
+6 NEW QQ
+7 KILL ^TMP("PSJBCMA5",$JOB,DFN,ORD)
+8 DO GETSIOPI^PSJBCMA5(DFN,ORD,1)
+9 if '$DATA(^TMP("PSJBCMA5",$JOB,DFN,ORD))
QUIT
+10 FOR QQ=0:0
SET QQ=$ORDER(^TMP("PSJBCMA5",$JOB,DFN,ORD,QQ))
if 'QQ
QUIT
Begin DoDot:1
+11 SET PSB=PSB+1
+12 SET ^TMP("PSB",$JOB,TAB,PSB)="SI^"_^TMP("PSJBCMA5",$JOB,DFN,ORD,QQ)
End DoDot:1
+13 KILL ^TMP("PSJBCMA5",$JOB,DFN,ORD)
+14 QUIT
+15 ;
INCLUDCO ;Rebuild TMP global from PSJBCMA, RETAIN CLINC ORDERS ONLY *70
+1 NEW QQ,IMCNT,COCNT
+2 SET (IMCNT,COCNT)=0
KILL ^TMP("PSJTMP",$JOB)
+3 FOR QQ=0:0
SET QQ=$ORDER(^TMP("PSJ",$JOB,QQ))
if 'QQ
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^TMP("PSJ",$JOB,QQ,0)),U,11)]""
Begin DoDot:2
+5 SET COCNT=COCNT+1
+6 MERGE ^TMP("PSJTMP",$JOB,COCNT)=^TMP("PSJ",$JOB,QQ)
End DoDot:2
End DoDot:1
+7 KILL ^TMP("PSJ",$JOB)
MERGE ^TMP("PSJ",$JOB)=^TMP("PSJTMP",$JOB)
+8 KILL ^TMP("PSJTMP",$JOB)
+9 if '$DATA(^TMP("PSJ",$JOB))
SET ^TMP("PSJ",$JOB,1,0)=-1
+10 QUIT
+11 ;
REMOVECO ;Rebuild TMP global from PSJBCMA, RETAIN IM ORDERS ONLY *70
+1 NEW QQ,IMCNT
+2 SET IMCNT=0
KILL ^TMP("PSJTMP",$JOB)
+3 FOR QQ=0:0
SET QQ=$ORDER(^TMP("PSJ",$JOB,QQ))
if 'QQ
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^TMP("PSJ",$JOB,QQ,0)),U,11)=""
Begin DoDot:2
+5 SET IMCNT=IMCNT+1
+6 MERGE ^TMP("PSJTMP",$JOB,IMCNT)=^TMP("PSJ",$JOB,QQ)
End DoDot:2
QUIT
End DoDot:1
+7 KILL ^TMP("PSJ",$JOB)
MERGE ^TMP("PSJ",$JOB)=^TMP("PSJTMP",$JOB)
+8 KILL ^TMP("PSJTMP",$JOB)
+9 if '$DATA(^TMP("PSJ",$JOB))
SET ^TMP("PSJ",$JOB,1,0)=-1
+10 QUIT
+11 ;
MODELITE() ;
+1 NEW ORDCNT,CLIN,ORDNO,STRT,STOP,STAT,PSBIMNOW,PSBIMDT
+2 SET ORDCNT=""
+3 KILL ^TMP("PSJ",$JOB)
+4 SET PSBIMNOW=+$EXTRACT($$NOW^XLFDT,1,10)
SET PSBIMDT=$PIECE(PSBIMNOW,".")
+5 DO EN^PSJBCMA(DFN,PSBIMNOW,PSBIMDT)
+6 if ^TMP("PSJ",$JOB,1,0)=-1
QUIT ""
+7 FOR QQ=0:0
SET QQ=$ORDER(^TMP("PSJ",$JOB,QQ))
if 'QQ
QUIT
Begin DoDot:1
+8 SET CLIN=$PIECE(^TMP("PSJ",$JOB,QQ,0),U,11)
+9 SET ORDNO=$PIECE(^TMP("PSJ",$JOB,QQ,0),U,3)
+10 SET STRT=$PIECE($PIECE(^TMP("PSJ",$JOB,QQ,1),U,4),".")
+11 SET STOP=$PIECE($PIECE(^TMP("PSJ",$JOB,QQ,1),U,5),".")
+12 SET STAT=$PIECE(^TMP("PSJ",$JOB,QQ,1),U,7)
+13 if CLIN]""
Begin DoDot:2
+14 ;modelite display for held, renewed, and on call PSB*3*92
IF ORDNO'["P"
IF (STAT="A"!(STAT="H")!(STAT="R")!(STAT="O"))
IF STRT'>DT
IF STOP'<DT
SET $PIECE(ORDCNT,U,2)=1
End DoDot:2
+15 if CLIN=""
Begin DoDot:2
+16 ;modelite display for held and renewed, and on call PSB*3*92
IF ORDNO'["P"
IF (STAT="A"!(STAT="H")!(STAT="R")!(STAT="O"))
IF STRT'>DT
IF STOP'<DT
SET $PIECE(ORDCNT,U)=1
End DoDot:2
End DoDot:1
+17 QUIT ORDCNT
+18 ;
INITTAB ;*70
+1 KILL ^TMP("PSB",$JOB,PSBTAB)
+2 SET ^TMP("PSB",$JOB,PSBTAB,0)=1
+3 SET ^TMP("PSB",$JOB,PSBTAB,1)="-1^No Administration(s) due at this time."
+4 QUIT
+5 ;
FINDORD(BWDFWD,DFN,PSBDT,PSBTAB) ;Search a patient's orders Bwd or Fwd *70
+1 ; Find the next day that contains an Active admin time not Given.
+2 ;
+3 NEW QQ,SPDT,STARTDT,STDT,STOPDT,STPDT
+4 SET PSBSIOPI=""
SET PSBCLINORD=1
+5 NEW NODE1,ENDDT,STRDT,STOPDT,STDT,SPDT,STARTDT,STOPDT,SDT,QUIT,REC,QQ
+6 NEW PSBWBEG,PSBWEND,PSBWADM,FOUND,GIVE,PDT
+7 KILL ^TMP("PSJ",$JOB)
+8 DO EN^PSJBCMA(DFN,PSBDT,PSBDT)
DO INCLUDCO^PSBVDLU1
+9 if ^TMP("PSJ",$JOB,1,0)=-1
QUIT -1
+10 ;
+11 ;read thru psj tmp and create start date xref
+12 FOR QQ=0:0
SET QQ=$ORDER(^TMP("PSJ",$JOB,QQ))
if 'QQ
QUIT
Begin DoDot:1
+13 SET NODE1=$GET(^TMP("PSJ",$JOB,QQ,1))
+14 ;not active sts
if $PIECE(NODE1,U,7)'="A"
QUIT
+15 SET STRDT=$PIECE($PIECE(NODE1,U,4),".")
SET STDT(STRDT)=""
+16 SET STPDT=$PIECE($PIECE(NODE1,U,5),".")
SET SPDT(STPDT)=""
End DoDot:1
+17 SET STARTDT=+$ORDER(STDT(0))
+18 if (BWDFWD=-1)&('STARTDT)
QUIT -1
+19 SET STOPDT=+$ORDER(SPDT(999999999),-1)
+20 if (BWDFWD=1)&('STOPDT)
QUIT -1
+21 ;
+22 if BWDFWD=-1
DO LOOPBWD
+23 if BWDFWD=1
DO LOOPFWD
+24 QUIT PDT
+25 ;
LOOPBWD ; Loop thru days backwards and quit when pass End date. *70
+1 SET (REC,QUIT,FOUND)=0
+2 FOR QQ=BWDFWD:BWDFWD
SET PDT=$$FMADD^XLFDT(PSBDT,QQ)
if PDT<STARTDT
QUIT
Begin DoDot:1
+3 IF PDT<STARTDT
SET QUIT=1
QUIT
+4 DO INITTAB^PSBVDLU1
+5 SET PSBWBEG=$PIECE(PDT,".")_".0000"
+6 SET PSBWEND=$PIECE(PDT,".")_".2400"
+7 SET PSBWADM=99999
+8 SET PSBWADM=$$FMADD^XLFDT(PDT,"","",+PSBWADM)
+9 if PSBTAB="UDTAB"
DO EN^PSBVDLUD(DFN,PDT)
+10 if PSBTAB="PBTAB"
DO EN^PSBVDLPB(DFN,PDT)
+11 ;=dfn, if data found
SET FOUND=+$GET(^TMP("PSB",$JOB,PSBTAB,2))
+12 ;get give sts
SET GIVE=$PIECE($GET(^TMP("PSB",$JOB,PSBTAB,2)),U,13)
+13 ;skip, as was given
if GIVE="G"
SET FOUND=0
End DoDot:1
if FOUND!QUIT
QUIT
+14 if 'FOUND
SET PDT=-1
+15 QUIT
+16 ;
LOOPFWD ; Loop thru days forwards and quit when pass End date. *70
+1 SET (REC,QUIT,FOUND)=0
+2 FOR QQ=BWDFWD:BWDFWD
SET PDT=$$FMADD^XLFDT(PSBDT,QQ)
if PDT>STOPDT
QUIT
Begin DoDot:1
+3 IF PDT>STOPDT
SET QUIT=1
QUIT
+4 DO INITTAB^PSBVDLU1
+5 SET PSBWBEG=$PIECE(PDT,".")_".0000"
+6 SET PSBWEND=$PIECE(PDT,".")_".2400"
+7 SET PSBWADM=99999
+8 SET PSBWADM=$$FMADD^XLFDT(PDT,"","",+PSBWADM)
+9 if PSBTAB="UDTAB"
DO EN^PSBVDLUD(DFN,PDT)
+10 if PSBTAB="PBTAB"
DO EN^PSBVDLPB(DFN,PDT)
+11 ;=dfn, if data found
SET FOUND=+$GET(^TMP("PSB",$JOB,PSBTAB,2))
+12 ;get give sts
SET GIVE=$PIECE($GET(^TMP("PSB",$JOB,PSBTAB,2)),U,13)
+13 ;skip, as was given
if GIVE="G"
SET FOUND=0
End DoDot:1
if FOUND!QUIT
QUIT
+14 if 'FOUND
SET PDT=-1
+15 QUIT
+16 ;
PATCHON(DFN,ORDR) ;check if any patches are still Given & Not Removed per this patient
+1 ; Return values:
+2 ; Func: True/False (1/0) for patches do exist on a patient.
+3 ; ORDR(): array element "C"linic or "I"npatient order = 1 when
+4 ; at least 1 order of this type exists.
+5 ;
+6 NEW ON,DAYSBK,ORDNO,STOPDT,IMCL
+7 SET ON=0
SET ORDR("C")=0
SET ORDR("I")=0
+8 if '$DATA(^PSB(53.79,"APATCH",DFN))
QUIT ON
+9 FOR QQ=0:0
SET QQ=$ORDER(^PSB(53.79,"APATCH",DFN,QQ))
if 'QQ
QUIT
Begin DoDot:1
+10 FOR RR=0:0
SET RR=$ORDER(^PSB(53.79,"APATCH",DFN,QQ,RR))
if 'RR
QUIT
Begin DoDot:2
+11 IF $PIECE(^PSB(53.79,RR,0),U,9)="G"
Begin DoDot:3
+12 SET ORDNO=$PIECE(^PSB(53.79,RR,.1),"^")
+13 DO CLEAN^PSBVT
+14 DO PSJ1^PSBVT(DFN,ORDNO)
if '$GET(PSBOSP)
QUIT
+15 SET STOPDT=PSBOSP
+16 SET DAYSBK=+($$GET^XPAR("DIV","PSB VDL PATCH DAYS"))
+17 ; simulate PSBVDLPA logic to look back Kernel param days
+18 IF DAYSBK
DO NOW^%DTC
IF $$FMADD^XLFDT($PIECE(STOPDT,"."),DAYSBK)<X
QUIT
+19 SET ON=1
+20 SET IMCL=$SELECT($GET(PSBCLORD)]"":"C",1:"I")
SET ORDR(IMCL)=1
+21 DO CLEAN^PSBVT
End DoDot:3
End DoDot:2
End DoDot:1
+22 QUIT ON
+23 ;
INFUSING(DFN,ORDR) ;check if any IV's have bags infusing per this patient
+1 ; Return values:
+2 ; Func: True/False (1/0) for patches do exist on a patient.
+3 ; ORDR(): array element "C"linic or "I"npatient order = 1 when
+4 ; at least 1 order of this type exists.
+5 ;
+6 NEW ON,DAYSBK,ORDNO,STOPDT,IMCL,PSBCLIEN
+7 SET ON=0
SET ORDR("C")=0
SET ORDR("I")=0
+8 if '$DATA(^PSB(53.79,"AINFUSING",DFN))
QUIT ON
+9 FOR QQ=0:0
SET QQ=$ORDER(^PSB(53.79,"AINFUSING",DFN,QQ))
if 'QQ
QUIT
Begin DoDot:1
+10 FOR RR=0:0
SET RR=$ORDER(^PSB(53.79,"AINFUSING",DFN,QQ,RR))
if 'RR
QUIT
Begin DoDot:2
+11 SET ORDNO=$PIECE(^PSB(53.79,RR,.1),"^")
+12 DO CLEAN^PSBVT
+13 DO PSJ1^PSBVT(DFN,ORDNO)
if '$GET(PSBOSP)
QUIT
+14 SET STOPDT=PSBOSP
+15 ; simulate IV VDL logic to look 3 days back for IM meds or 7 days
+16 ; for CO med.
+17 DO NOW^%DTC
+18 IF '$GET(PSBCLIEN)
IF $$FMADD^XLFDT($PIECE(STOPDT,"."),3)<X
QUIT
+19 IF $GET(PSBCLIEN)
IF $$FMADD^XLFDT($PIECE(STOPDT,"."),7)<X
QUIT
+20 SET ON=1
+21 SET IMCL=$SELECT($GET(PSBCLORD)]"":"C",1:"I")
SET ORDR(IMCL)=1
+22 DO CLEAN^PSBVT
End DoDot:2
End DoDot:1
+23 QUIT ON
+24 ;
STOPPED(DFN,ORDR) ;check if any IV's have bags infusing per this patient
+1 ; Return values:
+2 ; Func: True/False (1/0) for patches do exist on a patient.
+3 ; ORDR(): array element "C"linic or "I"npatient order = 1 when
+4 ; at least 1 order of this type exists.
+5 ;
+6 NEW ON,DAYSBK,ORDNO,STOPDT,IMCL,PSBCLIEN
+7 SET ON=0
SET ORDR("C")=0
SET ORDR("I")=0
+8 if '$DATA(^PSB(53.79,"ASTOPPED",DFN))
QUIT ON
+9 FOR QQ=0:0
SET QQ=$ORDER(^PSB(53.79,"ASTOPPED",DFN,QQ))
if 'QQ
QUIT
Begin DoDot:1
+10 FOR RR=0:0
SET RR=$ORDER(^PSB(53.79,"ASTOPPED",DFN,QQ,RR))
if 'RR
QUIT
Begin DoDot:2
+11 SET ORDNO=$PIECE(^PSB(53.79,RR,.1),"^")
+12 DO CLEAN^PSBVT
+13 DO PSJ1^PSBVT(DFN,ORDNO)
if '$GET(PSBOSP)
QUIT
+14 SET STOPDT=PSBOSP
+15 ; simulate IV VDL logic to look 3 days back for IM meds or 7 days
+16 ; for CO med.
+17 DO NOW^%DTC
+18 IF 'PSBCLIEN
IF $$FMADD^XLFDT($PIECE(STOPDT,"."),3)<X
QUIT
+19 IF PSBCLIEN
IF $$FMADD^XLFDT($PIECE(STOPDT,"."),7)<X
QUIT
+20 SET ON=1
+21 SET IMCL=$SELECT($GET(PSBCLORD)]"":"C",1:"I")
SET ORDR(IMCL)=1
+22 DO CLEAN^PSBVT
End DoDot:2
End DoDot:1
+23 QUIT ON
+24 ;
REMOVETM(MRR,STYP) ;** Check if MRR med & add to Results array (34,35) *83
+1 ;
+2 ; Add MRR code to Results(34) and if MRR > 0 then add remove time
+3 ; to Results(35).
+4 ;
+5 NEW RMDT,RMTIM
+6 ;set MRR flag in 34
SET $PIECE(PSBREC,U,34)=MRR
+7 ;
+8 ;Quit, not MRR med, no remove time
if 'MRR
QUIT
+9 ;Quit, schd types have no admin times
if (PSBSCHT="OC")!(PSBSCHT="P")
QUIT
+10 ;Quit, already set from get MRR rtns
if $PIECE(PSBREC,U,35)
QUIT
+11 ;
+12 ; Remove date/time Calculation method will correctly compute a future
+13 ; Remove date/time per this admin time, by using the FMADD function
+14 ; to add the DOA value to the admin time. DOA value is the time the
+15 ; med is to be on the patient and must be removed after that time.
+16 ;
+17 ; **Notice: Sched Type of "O", Remove time = Order Stop date/time
+18 ;
+19 ; e.g. if sched is Q7D and Freq=10080, then DOA=10080 also, and is
+20 ; returned by PSJBCMA1
+21 ;
+22 ;admin time
SET ADMTIM=$PIECE(PSBREC,U,14)
+23 ;calc RM time if DOA
if PSBDOA
SET RMTIM=$$FMADD^XLFDT(ADMTIM,,,PSBDOA)
+24 ;RM time for One-Time, non-expired orders, PSB*3*92
IF (PSBDOA<1!(PSBOSP>$$NOW^XLFDT))
IF STYP="O"
SET RMTIM=PSBOSP
+25 ;Add RM date/time
SET $PIECE(PSBREC,U,35)=$GET(RMTIM)
+26 QUIT
