PSIVCAL ;BIR/RGY,PR-CALCULATES START AND STOP DATES ; 11/20/19 11:03am
;;5.0;INPATIENT MEDICATIONS;**4,26,41,47,63,67,69,58,94,80,110,111,177,120,134,229,279,395**;16 DEC 97;Build 8
;
; Reference to ^PS(50.7 is supported by DBIA #2180.
; Reference to ^PS(52.6 is supported by DBIA #1231.
; Reference to ^PS(55 is supported by DBIA #2191.
;
ENT ;NEEDS PSIVTYPE (P(4))
I $G(PSJREN) D Q:P(2)
. I $G(P("OLDON")) N P2 S P2=$G(@("^PS(55,"_DFN_",""IV"","_+P("OLDON")_",0)")),P2=$P(P2,"^",2) I P2 S P(2)=P2
I $G(PSJORD)["P",$G(P("APPT"))?7N1"."1.N S START=$$DATE2^PSJUTL2(P("APPT")) S:($$FMDIFF^XLFDT(START,PSGDT,2)<0) START=+$E(PSGDT,1,12) G Q
I $G(PSJSYSW0)=""!($P(PSJSYSW0,U,5)=2) S START=+$E(P("LOG"),1,12) G Q
S PSIVSN=+P("IVRM"),START="",PSIVTYPE=$G(P(4)) Q:PSIVTYPE=""
N PSIV X $S($E(PSIVAC)="C":"S X=+$E(P(""LOG""),1,12) D H^%DTC S PSIV=%T",1:"S PSIV=$P($H,"","",2)") G T2:PSIVTYPE'["P"&('P(5))
I P(11)']"" X $S($E(PSIVAC)="C":"S Y=+$E(P(""LOG""),1,12)",1:"D NOW^%DTC S Y=%") S Y=Y+.007\.01/100 S:'$P(Y,".",2) Y=$$MDNGHT(Y) X ^DD("DD") S START=Y G Q
S X=P(11) D CHK S PX=Y,X1=PSIV\3600,X2=PSIV#3600\60,X=$E(".0",1,$L(X1)#2+1)_X1_$E("0",X2<10)_X2,START=$S($E(PSIVAC)="C":$P(P("LOG"),"."),1:"T")
S X1=$P(PX,"-"),X1=$E(".0",1,$L(X1)#2+1)_X1,X2=$P(PX,"-",PSGCNT),X2=$E(".0",1,$L(X2)#2+1)_X2
S NAT=+$P($G(^PS(59.6,+$O(^PS(59.6,"B",+VAIN(4),0)),0)),U,5)
I '$D(PSGDT) S PSGDT=$$DATE^PSJUTL2()
I X<X1,'NAT S START=$$ENSD^PSGNE3(P(9),P(11),+$E(P("LOG"),1,12),PSGDT) G Q
I X>X2 S START=$$ENSD^PSGNE3(P(9),P(11),+$E(P("LOG"),1,12),PSGDT) G Q
T6 F I=2:1:PSGCNT S X1="."_$P(PX,"-",I-1),X2="."_$P(PX,"-",I) Q:+X1<X&(+X2>X)
S X1=X-X1,X2=$S(NAT:0,1:X2-X),START=$S(X1<X2:$P(PX,"-",I-1),1:$P(PX,"-",I)) S:START="" START=$P(PX,"-") X $S($E(PSIVAC)="C":"S Y=$P(P(""LOG""),""."") X ^DD(""DD"") S PSIV=Y",1:"S PSIV=""TODAY""") S START=PSIV_"@"_$E("0",$L(START)=3)_START G Q
T2 S X=+("."_$E(10000+(PSIV\3600*100)+(PSIV#3600\60),2,5)),START=$O(^PS(59.5,PSIVSN,3,"AT",X)) S:'START START=$O(^(0)),PSIVTOM=1 I 'START S START=X K PSIVTOM
S START=$S($E(PSIVAC)="C":$P(P("LOG"),"."),1:DT)_START I $D(PSIVTOM) S X1=$S($E(PSIVAC)="C":$P(P("LOG"),"."),1:DT),X2=1 D C^%DTC S Y=$P(X,".")_START K PSIVTOM
S X=START,%DT="XRTX" D ^%DT
Q ;
I START["@" S X=START,%DT="RTX" D ^%DT S START=+Y
S P(2)=START
I $G(PSJORD)["P" D:'$G(PSGRDTX(+PSJORD,"PSGSD")) REQDT^PSJLIVMD(PSJORD) S START=$G(PSGRDTX(+PSJORD,"PSGSD")) S P(2)=$S(START:START,1:P(2))
K NAT,START,PSIVTYPE,PSIVSTRT,PSGCNT,X1,X2,PX
Q
CHK F Y=1:1 Q:$L(X)>240!($P(X,"-",Y)="") S $P(X,"-",Y)=$P(X,"-",Y)_$E("0000",1,4-$L($P(X,"-",Y)))
S Y=X,PSGCNT=$L(X,"-") S:X]""&(PSGCNT<1) PSGCNT=1 Q
;
ENSTOP ; WILL CALCULATE STOP DATE FOR ORDER
;NEEDS (DFN) & ON
N WALL,P3,ADX,DDLX,OIX,DRGT,PSIDAY,PSIMIN,LIMDAY S (WALL,P3,PSIDAY,PSIMIN)=0
D:'$G(PSIVSITE) ^PSIVSET Q:'P(2)
I P(23)'="" S PSIVTYPE="C"
S STOP="",X="",PSIVSTRT=P(2),PSIVTYPE=$G(P(4)) I $G(PSJREN) D
. N RDT I $G(ON)["P" S RDT=+$$LASTREN^PSJLMPRI(DFN,ON)
. S PSIVSTRT=$$DATE2^PSJUTL2($S($G(RDT):RDT,1:$G(PSGDT)))
;BHW - PSJ*5*177 - Begin Modifications - Reset Start date to Last Renewed date for active orders that have been renewed
I ('$G(PSJREN))&($G(P(4))="A")&($G(ON)["V") D
. N RDT S RDT=+$$LASTREN^PSJLMPRI(DFN,ON)
. I +RDT S PSIVSTRT=RDT
. Q
;BHW - PSJ*5*177 - End Modifications - Resetting PSIVSTRT will recalculate the stop date based on the Last renewed date.
;
I $S("^NOW^STAT^ONCE^ONE-TIME^ONE TIME^ONETIME^1TIME^1-TIME^1 TIME^"[(U_P(9)_U):1,1:0),PSIVTYPE="P"!P(5)!(P(23)="P") S X=$$ENOSD^PSJDCU(PSJSYSW0,PSIVSTRT,DFN) I X]"" S:P(11)=""&($G(ON)["P") PSIVCAL=1 G END
I '$G(P("OVRIDE")),$G(ON) N DUR,DURMIN,PSJPROV,PSJDNM,A,PSJDAY I $G(ON)["V"!(($G(ON)["P")&($P($G(^PS(53.1,+ON,0)),"^",4)="F")) D
. S DUR=$$GETDUR^PSJLIVMD(DFN,+ON,"IV",1) I DUR]"" S DURMIN=$$DURMIN^PSJLIVMD(DUR) I DURMIN S PSIMIN=DURMIN
I $P(PSIVSITE,"^",5) D
. N Z S Y=0
. F S Y=$O(^PS(55,DFN,"IV",Y)) Q:'Y S Z=^(Y,0) D Q:X]""
.. I $P(Z,"^",17)="A",$$ONE^PSJBCMA(DFN,Y_"V",$P(Z,"^",9))'="O" S X=$P(Z,"^",3) Q
S:$G(X) WALL=X
S PSIDAY=$S(PSIVTYPE="A":$P(PSIVSITE,"^",4),PSIVTYPE="H":$P(PSIVSITE,"^",17),PSIVTYPE="P":$P(PSIVSITE,"^",18),PSIVTYPE="S":$P(PSIVSITE,"^",20),1:$P(PSIVSITE,"^",21))
;*229 Add Dose Limit for IOE
I '$G(ON),$G(PSIVLIMT)]"" S PSIVLIM=PSIVLIMT
I $G(ON)["P"!($G(ON)["V") I '$G(P("OVRIDE")) N MINS,LIM S PSIVLIM=$S($G(PSIVLIMT)]"":PSIVLIMT,1:$$GETLIM(DFN,ON)) I $G(PSIVLIM)]"" S MINS=$$GETMIN(PSIVLIM,DFN,ON,.LIMDAY) D
.I (MINS&(MINS<PSIMIN))!'PSIMIN S PSIMIN=MINS
S PSJDAY="" D I PSJDAY]"",PSJDAY<PSIDAY S PSIDAY=PSJDAY
. N A,B,PSJCLIN
. Q:'$D(PSJORD) S A=""
. I PSJORD["P" S A=$G(^PS(53.1,+PSJORD,"DSS"))
. I PSJORD["U" S A=$G(^PS(55,PSGP,5,+PSJORD,8))
. I PSJORD["V" S A=$G(^PS(55,PSGP,"IV",+PSJORD,"DSS"))
. S:(+$G(A)<0) A=""
. S (PSJCLIN,A)=$P(A,"^") Q:A="" S PSJCLIN=$P($G(^SC(+$G(PSJCLIN),0)),"^") Q:PSJCLIN="" I $D(^PS(53.46,"B",A)) S B=$O(^PS(53.46,"B",A,"")),PSJDAY=$P(^PS(53.46,B,0),"^",2)
F X=0:0 S X=$O(DRG("AD",X)) Q:'X I $P(^PS(52.6,+$P(DRG("AD",+X),U),0),"^",4),($P(^(0),"^",4))<+PSIDAY S PSIDAY=$P(^(0),"^",4)
I WALL,($$FMADD^XLFDT(PSIVSTRT,PSIDAY,"D"))>WALL S PSIDAY=$$FMDIFF^XLFDT(WALL,PSIVSTRT,1) S:PSIDAY<1 PSIDAY=""
S DRGT=$S($G(DRG("AD",0)):"AD",1:"SOL") F ADX=0:0 S ADX=$O(DRG(DRGT,ADX)) Q:'ADX!($G(DRGTMP)&($G(DRGTN)["AD")&(DRGT="SOL")) D ;395 use $G of "AD",0 node
. S OIX=+$P(DRG(DRGT,ADX),"^",6),DDLX=$P(^PS(50.7,OIX,0),"^",5) Q:'DDLX D DDLIM(.PSIDAY,.P3)
I '$G(DRG("AD",0)),$G(DRGTMP),($G(DRGTN)["SOL") S OIX=$P($G(DRGTMP),"^",6) I OIX S DDLX=$P(^PS(50.7,OIX,0),"^",5) I DDLX D DDLIM(.PSIDAY,.P3)
I $G(PSIVLIM)["a",'$G(P("OVRIDE")) S DDLX=$P(PSIVLIM,"a",2)_"L" I $G(DDLX) D DDLIM(.PSIDAY,.P3)
I $G(P(2)) I P3>P(2) S X=P3 Q ;*229 Quit so we use dose limit.
S:('PSIDAY&'PSIMIN) PSIDAY=1
TIME S X2=PSIDAY,X1=PSIVSTRT D C^%DTC S X=$P(X,"."),X=X_$S($P(PSIVSITE,"^",14)="":.2359,1:"."_$P(PSIVSITE,"^",14))
I PSIMIN D
. I $G(PSIDAY),((PSIDAY*1440)<PSIMIN) K PSIVLIM,P("LIMIT") S P("OVRIDE")=1 Q
. ;*229 if PSIMIN=(PSIDAY*1440) then dose lim, if day lim use site param.
. I (PSIMIN<=(PSIDAY*1440)!'$G(PSIDAY)) S X=$$FMADD^XLFDT(PSIVSTRT,,,PSIMIN) D
. . I $G(P("LIMIT"))["d" S X=$P(X,"."),X=X_$S($P(PSIVSITE,"^",14)="":.2359,1:"."_$P(PSIVSITE,"^",14))
;
END ;
S P(3)=+X
I $G(PSJORD)["P" D:'$G(PSGRDTX(+PSJORD,"PSGFD")) REQDT^PSJLIVMD(PSJORD) S P(3)=$S($G(PSGRDTX(+PSJORD,"PSGFD")):PSGRDTX(+PSJORD,"PSGFD"),1:P(3))
S P(3)=$$DATE2^PSJUTL2(P(3)),P(2)=$$DATE2^PSJUTL2(P(2))
Q
;
ENAD ;Will get last admin. time for order (needs dfn and on)
N P4,PSIVX,PSIVY
I $P(PSJSYSW0,U,5)=2 S PSIVADM=$$DATE^PSJUTL2() Q
I $S($G(PSIVAC)["R":1,P(9)="QOD":1,1:P(9)?1"Q".N1"D") S PSIVADM=$$ENSD^PSGNE3(P(9),P(11),+$E(P("LOG"),1,12),+$P($G(^PS(55,DFN,"IV",+P("OLDON"),0)),U,2)) Q:PSIVADM
S PSIVX=X,PSIVY=Y,P4=P(4) S:P(4)="C" P4=P(23) S:P4="S" P4=$S(P(5):"P",1:"A") D NOW^%DTC S Y=%,PSIVNOW=Y I (P4="P"&(P(11)="")&'P(15))!("HA"[P4&'P(15)) S Y=Y+.007\.01/100 G QAD
D P:P4="P"&('P(15)),AH:P(15)
QAD ;
S:'$D(PSGSA) PSGSA=""
S PSIVSD=Y I Y S OD=$L(PSGSA," ") I OD>2 S X=+PSGSA\1 F OD1=2:1:OD-1 I $P(PSGSA," ",OD1)'>$S(OD1>2:$P(PSGSA," ",OD1-1),1:PSGSA#1) S X1=X,X2=1 D C^%DTC
I PSIVSD,OD>2 S Y=X_PSIVSD
S PSIVADM=+Y,X=PSIVX,Y=PSIVY K PSGSA,PSIVSD,OD,OD1,PSIVMI,PSIVNOW S:PSIVADM<P(2) PSIVADM=P(2) Q
;
P S CD=PSIVNOW,PSGSA="",(PSIVSD,OD)=DT_.0001,X=P(11) D CHK S P(11)=X D ENP4^PSIVWL
I PSGSA="" S PSIVSD=DT_.0001,PSIVMIN=-1440 D ENT^PSIVWL S $P(Y,".",2)=$P(P(11),"-",$L(P(11),"-")) Q
S Y=$P(PSGSA," ",$L(PSGSA," ")-1) Q
AH F PSIVADM=0:-1 S CD=PSIVNOW,(X,X1)=DT,X2=PSIVADM D:X2 C^%DTC S X=$P(X,".") S (OD1,PSIVSD,OD)=X_.0001,PSIVMIN=P(15) D ENP3^PSIVWL Q:PSIVADM<-4!(PSGSA]"")
S Y=$P(PSGSA," ",$L(PSGSA," ")-1) Q
MDNGHT(Y) ;Sets Start Date/Time on orders placed between midnight and 12:30
S Y=$$FMADD^XLFDT(Y,-1,0,0,0),Y=$P(Y,".")_".24" Q Y
;
DDLIM(PSIVDUR,STPDT) ; Day Dose Limit
N P3,NEWDAYS,NEWDUR,LASTD
I DDLX["D" D Q:(STPDT=0)
.I +DDLX'<+PSIVDUR S STPDT=0 Q
.S PSIVDUR=+DDLX,X2=PSIVDUR,X1=PSIVSTRT D C^%DTC S X=$P(X,"."),X=X_$S($P(PSIVSITE,"^",14)="":.2359,1:"."_$P(PSIVSITE,"^",14)) I X>P(2) S P(3)=X
I DDLX["L",($G(P(9))]""),("AH"'[$G(PSIVTYPE)) S LASTD=$$DOSES(DDLX,.P) I LASTD D
.S NEWDUR=$$FMDIFF^XLFDT(LASTD,P(2),2) I NEWDUR>0 S NEWDAYS=(NEWDUR/86400)
.I $G(NEWDAYS) I NEWDAYS<PSIVDUR S PSIVDUR=NEWDAYS S P(3)=$$DATE2^PSJUTL2(LASTD)
;*229 Should be using LASTD if exists
S P(3)=$$DATE2^PSJUTL2($S($G(LASTD):LASTD,1:P(3))),P(2)=$$DATE2^PSJUTL2(P(2)) S STPDT=P(3)
Q
;
GETLIM(DFN,PSJORD) ; Convert IV Limits to minutes (only if in 'time' form).
N ND2P5,F
S F=$S(PSJORD["P":"^PS(53.1,+PSJORD,",PSJORD["V":"^PS(55,DFN,""IV"",+PSJORD,",1:"")
S ND2P5=$G(@(F_"2.5)")) S LIM=$P(ND2P5,"^",4) Q:LIM="" 0
S ND0=$G(@(F_"0)")) I PSJORD["P",$P(ND0,"^",4)="U" Q 0
N MULT S MULT=$S($E(LIM)="h":60,$E(LIM)="d":1440,$E(LIM)="m":LIM,$E(LIM)="l":LIM,$E(LIM)="a":LIM,1:0) I MULT S LIM=MULT*$E(LIM,2,99)
Q LIM
;
GETMIN(LIM,DFN,PSJORD,DAYS) ; Return the duration of the IV Limit in minutes (includes IV Limits in volume and doses format)
S LIM=$$GETMIN^PSIVUTL1(LIM,DFN,PSJORD,.DAYS)
Q LIM
DOSES(DDLX,PRAY) ; Find stop date when 'doses' are sent as an IV Limit
Q:$G(DDLX)'["L" ""
I $P(DDLX,"L")["." S DDLX=($P(DDLX,".")+1)_"L"
I '$G(PRAY(15)),$G(PRAY(11)) S PRAY(15)=1440/$L(PRAY(11),"-")
Q:'$G(PRAY(2))!'$G(OIX) ""
N FIRST,DOSAR,LAST,TMP9 S LAST="",TMP9=PRAY(9)
S STRING=PRAY(2)_"^"_$S($G(STPDT):STPDT,1:$$FMADD^XLFDT(PSGDT,30))_"^"_PRAY(9)_"^C^"_OIX_"^"_PRAY(11) S FIRST=$$ENQ^PSJORP2(DFN,STRING)
S P(9)=TMP9
S FIRST=$S($G(FIRST):FIRST,1:PRAY(2)) Q:'FIRST S DSTMP=FIRST,DOSAR(1)=DSTMP D
.;*229 Add Dose Limit Calc
.I $G(DDLX)["L",$G(PRAY(15)),($G(PRAY(11))']"")!($G(PRAY(15))>1440) N PSIVSD,PSIVMIN,X S PSIVMIN=(+DDLX*PRAY(15)),PSIVSD=+PRAY(2) D ENT^PSIVWL S DOSAR(1)=Y Q
.I '$G(PRAY(11)) F I=2:1:DDLX+1 S DOSAR(I)=$$FMADD^XLFDT(DSTMP,,,PRAY(15)),DSTMP=DOSAR(I) Q
.I $G(PRAY(11)) N ADMS,NXT,LAST,DAY S LAST=$P(DSTMP,".",2),DAY=$P(DSTMP,".") D
..F II=1:1:$L(PRAY(11),"-") S ADMS(+$P(PRAY(11),"-",II))=$P(PRAY(11),"-",II)
..;*229 Include DOW Calc, Need to Q if DAY<0 if we go past max dt
..F IJ=2:1:DDLX+1 S NXT=$O(ADMS(+LAST)),LAST=NXT D Q:DAY<0
...I NXT="" S NXT=$O(ADMS(NXT)),LAST=NXT,DAY=$$FMADD^XLFDT(DAY,$$MWFD(PRAY(9),DAY)) Q:DAY<0
...S DOSAR(IJ)=DAY_"."_ADMS(NXT),DSTMP=DOSAR(IJ)
..I +DDLX=1 S NXT=$O(ADMS(LAST)),LAST=NXT D
...I NXT="" S NXT=$O(ADMS(NXT)),LAST=NXT
I $D(DOSAR) S LAST=$O(DOSAR(""),-1) I LAST S LAST=DOSAR(LAST)
Q LAST
;
MWFD(SCH,LAST) ;*229 Add to calc which days in DOW
;Calculate Days to add for DOW sched
N X,Y
I '$$DOW^PSIVUTL(SCH) Q 1 ;return 1 if not DOW
F I=1:1:7 S X=$$FMADD^XLFDT(LAST,I) D DW^%DTC I SCH[$E(X,1,2) S Y=I Q
Q Y
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVCAL 10842 printed Oct 16, 2024@18:04:43 Page 2
PSIVCAL ;BIR/RGY,PR-CALCULATES START AND STOP DATES ; 11/20/19 11:03am
+1 ;;5.0;INPATIENT MEDICATIONS;**4,26,41,47,63,67,69,58,94,80,110,111,177,120,134,229,279,395**;16 DEC 97;Build 8
+2 ;
+3 ; Reference to ^PS(50.7 is supported by DBIA #2180.
+4 ; Reference to ^PS(52.6 is supported by DBIA #1231.
+5 ; Reference to ^PS(55 is supported by DBIA #2191.
+6 ;
ENT ;NEEDS PSIVTYPE (P(4))
+1 IF $GET(PSJREN)
Begin DoDot:1
+2 IF $GET(P("OLDON"))
NEW P2
SET P2=$GET(@("^PS(55,"_DFN_",""IV"","_+P("OLDON")_",0)"))
SET P2=$PIECE(P2,"^",2)
IF P2
SET P(2)=P2
End DoDot:1
if P(2)
QUIT
+3 IF $GET(PSJORD)["P"
IF $GET(P("APPT"))?7N1"."1.N
SET START=$$DATE2^PSJUTL2(P("APPT"))
if ($$FMDIFF^XLFDT(START,PSGDT,2)<0)
SET START=+$EXTRACT(PSGDT,1,12)
GOTO Q
+4 IF $GET(PSJSYSW0)=""!($PIECE(PSJSYSW0,U,5)=2)
SET START=+$EXTRACT(P("LOG"),1,12)
GOTO Q
+5 SET PSIVSN=+P("IVRM")
SET START=""
SET PSIVTYPE=$GET(P(4))
if PSIVTYPE=""
QUIT
+6 NEW PSIV
XECUTE $SELECT($EXTRACT(PSIVAC)="C":"S X=+$E(P(""LOG""),1,12) D H^%DTC S PSIV=%T",1:"S PSIV=$P($H,"","",2)")
if PSIVTYPE'["P"&('P(5))
GOTO T2
+7 IF P(11)']""
XECUTE $SELECT($EXTRACT(PSIVAC)="C":"S Y=+$E(P(""LOG""),1,12)",1:"D NOW^%DTC S Y=%")
SET Y=Y+.007\.01/100
if '$PIECE(Y,".",2)
SET Y=$$MDNGHT(Y)
XECUTE ^DD("DD")
SET START=Y
GOTO Q
+8 SET X=P(11)
DO CHK
SET PX=Y
SET X1=PSIV\3600
SET X2=PSIV#3600\60
SET X=$EXTRACT(".0",1,$LENGTH(X1)#2+1)_X1_$EXTRACT("0",X2<10)_X2
SET START=$SELECT($EXTRACT(PSIVAC)="C":$PIECE(P("LOG"),"."),1:"T")
+9 SET X1=$PIECE(PX,"-")
SET X1=$EXTRACT(".0",1,$LENGTH(X1)#2+1)_X1
SET X2=$PIECE(PX,"-",PSGCNT)
SET X2=$EXTRACT(".0",1,$LENGTH(X2)#2+1)_X2
+10 SET NAT=+$PIECE($GET(^PS(59.6,+$ORDER(^PS(59.6,"B",+VAIN(4),0)),0)),U,5)
+11 IF '$DATA(PSGDT)
SET PSGDT=$$DATE^PSJUTL2()
+12 IF X<X1
IF 'NAT
SET START=$$ENSD^PSGNE3(P(9),P(11),+$EXTRACT(P("LOG"),1,12),PSGDT)
GOTO Q
+13 IF X>X2
SET START=$$ENSD^PSGNE3(P(9),P(11),+$EXTRACT(P("LOG"),1,12),PSGDT)
GOTO Q
T6 FOR I=2:1:PSGCNT
SET X1="."_$PIECE(PX,"-",I-1)
SET X2="."_$PIECE(PX,"-",I)
if +X1<X&(+X2>X)
QUIT
+1 SET X1=X-X1
SET X2=$SELECT(NAT:0,1:X2-X)
SET START=$SELECT(X1<X2:$PIECE(PX,"-",I-1),1:$PIECE(PX,"-",I))
if START=""
SET START=$PIECE(PX,"-")
XECUTE $SELECT($EXTRACT(PSIVAC)="C":"S Y=$P(P(""LOG""),""."") X ^DD(""DD"") S PSIV=Y",1:"S PSIV=""TODAY""")
SET START=PSIV_"@"_$EXTRACT("0",$LENGTH(START)=3)_START
GOTO Q
T2 SET X=+("."_$EXTRACT(10000+(PSIV\3600*100)+(PSIV#3600\60),2,5))
SET START=$ORDER(^PS(59.5,PSIVSN,3,"AT",X))
if 'START
SET START=$ORDER(^(0))
SET PSIVTOM=1
IF 'START
SET START=X
KILL PSIVTOM
+1 SET START=$SELECT($EXTRACT(PSIVAC)="C":$PIECE(P("LOG"),"."),1:DT)_START
IF $DATA(PSIVTOM)
SET X1=$SELECT($EXTRACT(PSIVAC)="C":$PIECE(P("LOG"),"."),1:DT)
SET X2=1
DO C^%DTC
SET Y=$PIECE(X,".")_START
KILL PSIVTOM
+2 SET X=START
SET %DT="XRTX"
DO ^%DT
Q ;
+1 IF START["@"
SET X=START
SET %DT="RTX"
DO ^%DT
SET START=+Y
+2 SET P(2)=START
+3 IF $GET(PSJORD)["P"
if '$GET(PSGRDTX(+PSJORD,"PSGSD"))
DO REQDT^PSJLIVMD(PSJORD)
SET START=$GET(PSGRDTX(+PSJORD,"PSGSD"))
SET P(2)=$SELECT(START:START,1:P(2))
+4 KILL NAT,START,PSIVTYPE,PSIVSTRT,PSGCNT,X1,X2,PX
+5 QUIT
CHK FOR Y=1:1
if $LENGTH(X)>240!($PIECE(X,"-",Y)="")
QUIT
SET $PIECE(X,"-",Y)=$PIECE(X,"-",Y)_$EXTRACT("0000",1,4-$LENGTH($PIECE(X,"-",Y)))
+1 SET Y=X
SET PSGCNT=$LENGTH(X,"-")
if X]""&(PSGCNT<1)
SET PSGCNT=1
QUIT
+2 ;
ENSTOP ; WILL CALCULATE STOP DATE FOR ORDER
+1 ;NEEDS (DFN) & ON
+2 NEW WALL,P3,ADX,DDLX,OIX,DRGT,PSIDAY,PSIMIN,LIMDAY
SET (WALL,P3,PSIDAY,PSIMIN)=0
+3 if '$GET(PSIVSITE)
DO ^PSIVSET
if 'P(2)
QUIT
+4 IF P(23)'=""
SET PSIVTYPE="C"
+5 SET STOP=""
SET X=""
SET PSIVSTRT=P(2)
SET PSIVTYPE=$GET(P(4))
IF $GET(PSJREN)
Begin DoDot:1
+6 NEW RDT
IF $GET(ON)["P"
SET RDT=+$$LASTREN^PSJLMPRI(DFN,ON)
+7 SET PSIVSTRT=$$DATE2^PSJUTL2($SELECT($GET(RDT):RDT,1:$GET(PSGDT)))
End DoDot:1
+8 ;BHW - PSJ*5*177 - Begin Modifications - Reset Start date to Last Renewed date for active orders that have been renewed
+9 IF ('$GET(PSJREN))&($GET(P(4))="A")&($GET(ON)["V")
Begin DoDot:1
+10 NEW RDT
SET RDT=+$$LASTREN^PSJLMPRI(DFN,ON)
+11 IF +RDT
SET PSIVSTRT=RDT
+12 QUIT
End DoDot:1
+13 ;BHW - PSJ*5*177 - End Modifications - Resetting PSIVSTRT will recalculate the stop date based on the Last renewed date.
+14 ;
+15 IF $SELECT("^NOW^STAT^ONCE^ONE-TIME^ONE TIME^ONETIME^1TIME^1-TIME^1 TIME^"[(U_P(9)_U):1,1:0)
IF PSIVTYPE="P"!P(5)!(P(23)="P")
SET X=$$ENOSD^PSJDCU(PSJSYSW0,PSIVSTRT,DFN)
IF X]""
if P(11)=""&($GET(ON)["P")
SET PSIVCAL=1
GOTO END
+16 IF '$GET(P("OVRIDE"))
IF $GET(ON)
NEW DUR,DURMIN,PSJPROV,PSJDNM,A,PSJDAY
IF $GET(ON)["V"!(($GET(ON)["P")&($PIECE($GET(^PS(53.1,+ON,0)),"^",4)="F"))
Begin DoDot:1
+17 SET DUR=$$GETDUR^PSJLIVMD(DFN,+ON,"IV",1)
IF DUR]""
SET DURMIN=$$DURMIN^PSJLIVMD(DUR)
IF DURMIN
SET PSIMIN=DURMIN
End DoDot:1
+18 IF $PIECE(PSIVSITE,"^",5)
Begin DoDot:1
+19 NEW Z
SET Y=0
+20 FOR
SET Y=$ORDER(^PS(55,DFN,"IV",Y))
if 'Y
QUIT
SET Z=^(Y,0)
Begin DoDot:2
+21 IF $PIECE(Z,"^",17)="A"
IF $$ONE^PSJBCMA(DFN,Y_"V",$PIECE(Z,"^",9))'="O"
SET X=$PIECE(Z,"^",3)
QUIT
End DoDot:2
if X]""
QUIT
End DoDot:1
+22 if $GET(X)
SET WALL=X
+23 SET PSIDAY=$SELECT(PSIVTYPE="A":$PIECE(PSIVSITE,"^",4),PSIVTYPE="H":$PIECE(PSIVSITE,"^",17),PSIVTYPE="P":$PIECE(PSIVSITE,"^",18),PSIVTYPE="S":$PIECE(PSIVSITE,"^",20),1:$PIECE(PSIVSITE,"^",21))
+24 ;*229 Add Dose Limit for IOE
+25 IF '$GET(ON)
IF $GET(PSIVLIMT)]""
SET PSIVLIM=PSIVLIMT
+26 IF $GET(ON)["P"!($GET(ON)["V")
IF '$GET(P("OVRIDE"))
NEW MINS,LIM
SET PSIVLIM=$SELECT($GET(PSIVLIMT)]"":PSIVLIMT,1:$$GETLIM(DFN,ON))
IF $GET(PSIVLIM)]""
SET MINS=$$GETMIN(PSIVLIM,DFN,ON,.LIMDAY)
Begin DoDot:1
+27 IF (MINS&(MINS<PSIMIN))!'PSIMIN
SET PSIMIN=MINS
End DoDot:1
+28 SET PSJDAY=""
Begin DoDot:1
+29 NEW A,B,PSJCLIN
+30 if '$DATA(PSJORD)
QUIT
SET A=""
+31 IF PSJORD["P"
SET A=$GET(^PS(53.1,+PSJORD,"DSS"))
+32 IF PSJORD["U"
SET A=$GET(^PS(55,PSGP,5,+PSJORD,8))
+33 IF PSJORD["V"
SET A=$GET(^PS(55,PSGP,"IV",+PSJORD,"DSS"))
+34 if (+$GET(A)<0)
SET A=""
+35 SET (PSJCLIN,A)=$PIECE(A,"^")
if A=""
QUIT
SET PSJCLIN=$PIECE($GET(^SC(+$GET(PSJCLIN),0)),"^")
if PSJCLIN=""
QUIT
IF $DATA(^PS(53.46,"B",A))
SET B=$ORDER(^PS(53.46,"B",A,""))
SET PSJDAY=$PIECE(^PS(53.46,B,0),"^",2)
End DoDot:1
IF PSJDAY]""
IF PSJDAY<PSIDAY
SET PSIDAY=PSJDAY
+36 FOR X=0:0
SET X=$ORDER(DRG("AD",X))
if 'X
QUIT
IF $PIECE(^PS(52.6,+$PIECE(DRG("AD",+X),U),0),"^",4)
IF ($PIECE(^(0),"^",4))<+PSIDAY
SET PSIDAY=$PIECE(^(0),"^",4)
+37 IF WALL
IF ($$FMADD^XLFDT(PSIVSTRT,PSIDAY,"D"))>WALL
SET PSIDAY=$$FMDIFF^XLFDT(WALL,PSIVSTRT,1)
if PSIDAY<1
SET PSIDAY=""
+38 ;395 use $G of "AD",0 node
SET DRGT=$SELECT($GET(DRG("AD",0)):"AD",1:"SOL")
FOR ADX=0:0
SET ADX=$ORDER(DRG(DRGT,ADX))
if 'ADX!($GET(DRGTMP)&($GET(DRGTN)["AD")&(DRGT="SOL"))
QUIT
Begin DoDot:1
+39 SET OIX=+$PIECE(DRG(DRGT,ADX),"^",6)
SET DDLX=$PIECE(^PS(50.7,OIX,0),"^",5)
if 'DDLX
QUIT
DO DDLIM(.PSIDAY,.P3)
End DoDot:1
+40 IF '$GET(DRG("AD",0))
IF $GET(DRGTMP)
IF ($GET(DRGTN)["SOL")
SET OIX=$PIECE($GET(DRGTMP),"^",6)
IF OIX
SET DDLX=$PIECE(^PS(50.7,OIX,0),"^",5)
IF DDLX
DO DDLIM(.PSIDAY,.P3)
+41 IF $GET(PSIVLIM)["a"
IF '$GET(P("OVRIDE"))
SET DDLX=$PIECE(PSIVLIM,"a",2)_"L"
IF $GET(DDLX)
DO DDLIM(.PSIDAY,.P3)
+42 ;*229 Quit so we use dose limit.
IF $GET(P(2))
IF P3>P(2)
SET X=P3
QUIT
+43 if ('PSIDAY&'PSIMIN)
SET PSIDAY=1
TIME SET X2=PSIDAY
SET X1=PSIVSTRT
DO C^%DTC
SET X=$PIECE(X,".")
SET X=X_$SELECT($PIECE(PSIVSITE,"^",14)="":.2359,1:"."_$PIECE(PSIVSITE,"^",14))
+1 IF PSIMIN
Begin DoDot:1
+2 IF $GET(PSIDAY)
IF ((PSIDAY*1440)<PSIMIN)
KILL PSIVLIM,P("LIMIT")
SET P("OVRIDE")=1
QUIT
+3 ;*229 if PSIMIN=(PSIDAY*1440) then dose lim, if day lim use site param.
+4 IF (PSIMIN<=(PSIDAY*1440)!'$GET(PSIDAY))
SET X=$$FMADD^XLFDT(PSIVSTRT,,,PSIMIN)
Begin DoDot:2
+5 IF $GET(P("LIMIT"))["d"
SET X=$PIECE(X,".")
SET X=X_$SELECT($PIECE(PSIVSITE,"^",14)="":.2359,1:"."_$PIECE(PSIVSITE,"^",14))
End DoDot:2
End DoDot:1
+6 ;
END ;
+1 SET P(3)=+X
+2 IF $GET(PSJORD)["P"
if '$GET(PSGRDTX(+PSJORD,"PSGFD"))
DO REQDT^PSJLIVMD(PSJORD)
SET P(3)=$SELECT($GET(PSGRDTX(+PSJORD,"PSGFD")):PSGRDTX(+PSJORD,"PSGFD"),1:P(3))
+3 SET P(3)=$$DATE2^PSJUTL2(P(3))
SET P(2)=$$DATE2^PSJUTL2(P(2))
+4 QUIT
+5 ;
ENAD ;Will get last admin. time for order (needs dfn and on)
+1 NEW P4,PSIVX,PSIVY
+2 IF $PIECE(PSJSYSW0,U,5)=2
SET PSIVADM=$$DATE^PSJUTL2()
QUIT
+3 IF $SELECT($GET(PSIVAC)["R":1,P(9)="QOD":1,1:P(9)?1"Q".N1"D")
SET PSIVADM=$$ENSD^PSGNE3(P(9),P(11),+$EXTRACT(P("LOG"),1,12),+$PIECE($GET(^PS(55,DFN,"IV",+P("OLDON"),0)),U,2))
if PSIVADM
QUIT
+4 SET PSIVX=X
SET PSIVY=Y
SET P4=P(4)
if P(4)="C"
SET P4=P(23)
if P4="S"
SET P4=$SELECT(P(5):"P",1:"A")
DO NOW^%DTC
SET Y=%
SET PSIVNOW=Y
IF (P4="P"&(P(11)="")&'P(15))!("HA"[P4&'P(15))
SET Y=Y+.007\.01/100
GOTO QAD
+5 if P4="P"&('P(15))
DO P
if P(15)
DO AH
QAD ;
+1 if '$DATA(PSGSA)
SET PSGSA=""
+2 SET PSIVSD=Y
IF Y
SET OD=$LENGTH(PSGSA," ")
IF OD>2
SET X=+PSGSA\1
FOR OD1=2:1:OD-1
IF $PIECE(PSGSA," ",OD1)'>$SELECT(OD1>2:$PIECE(PSGSA," ",OD1-1),1:PSGSA#1)
SET X1=X
SET X2=1
DO C^%DTC
+3 IF PSIVSD
IF OD>2
SET Y=X_PSIVSD
+4 SET PSIVADM=+Y
SET X=PSIVX
SET Y=PSIVY
KILL PSGSA,PSIVSD,OD,OD1,PSIVMI,PSIVNOW
if PSIVADM<P(2)
SET PSIVADM=P(2)
QUIT
+5 ;
P SET CD=PSIVNOW
SET PSGSA=""
SET (PSIVSD,OD)=DT_.0001
SET X=P(11)
DO CHK
SET P(11)=X
DO ENP4^PSIVWL
+1 IF PSGSA=""
SET PSIVSD=DT_.0001
SET PSIVMIN=-1440
DO ENT^PSIVWL
SET $PIECE(Y,".",2)=$PIECE(P(11),"-",$LENGTH(P(11),"-"))
QUIT
+2 SET Y=$PIECE(PSGSA," ",$LENGTH(PSGSA," ")-1)
QUIT
AH FOR PSIVADM=0:-1
SET CD=PSIVNOW
SET (X,X1)=DT
SET X2=PSIVADM
if X2
DO C^%DTC
SET X=$PIECE(X,".")
SET (OD1,PSIVSD,OD)=X_.0001
SET PSIVMIN=P(15)
DO ENP3^PSIVWL
if PSIVADM<-4!(PSGSA]"")
QUIT
+1 SET Y=$PIECE(PSGSA," ",$LENGTH(PSGSA," ")-1)
QUIT
MDNGHT(Y) ;Sets Start Date/Time on orders placed between midnight and 12:30
+1 SET Y=$$FMADD^XLFDT(Y,-1,0,0,0)
SET Y=$PIECE(Y,".")_".24"
QUIT Y
+2 ;
DDLIM(PSIVDUR,STPDT) ; Day Dose Limit
+1 NEW P3,NEWDAYS,NEWDUR,LASTD
+2 IF DDLX["D"
Begin DoDot:1
+3 IF +DDLX'<+PSIVDUR
SET STPDT=0
QUIT
+4 SET PSIVDUR=+DDLX
SET X2=PSIVDUR
SET X1=PSIVSTRT
DO C^%DTC
SET X=$PIECE(X,".")
SET X=X_$SELECT($PIECE(PSIVSITE,"^",14)="":.2359,1:"."_$PIECE(PSIVSITE,"^",14))
IF X>P(2)
SET P(3)=X
End DoDot:1
if (STPDT=0)
QUIT
+5 IF DDLX["L"
IF ($GET(P(9))]"")
IF ("AH"'[$GET(PSIVTYPE))
SET LASTD=$$DOSES(DDLX,.P)
IF LASTD
Begin DoDot:1
+6 SET NEWDUR=$$FMDIFF^XLFDT(LASTD,P(2),2)
IF NEWDUR>0
SET NEWDAYS=(NEWDUR/86400)
+7 IF $GET(NEWDAYS)
IF NEWDAYS<PSIVDUR
SET PSIVDUR=NEWDAYS
SET P(3)=$$DATE2^PSJUTL2(LASTD)
End DoDot:1
+8 ;*229 Should be using LASTD if exists
+9 SET P(3)=$$DATE2^PSJUTL2($SELECT($GET(LASTD):LASTD,1:P(3)))
SET P(2)=$$DATE2^PSJUTL2(P(2))
SET STPDT=P(3)
+10 QUIT
+11 ;
GETLIM(DFN,PSJORD) ; Convert IV Limits to minutes (only if in 'time' form).
+1 NEW ND2P5,F
+2 SET F=$SELECT(PSJORD["P":"^PS(53.1,+PSJORD,",PSJORD["V":"^PS(55,DFN,""IV"",+PSJORD,",1:"")
+3 SET ND2P5=$GET(@(F_"2.5)"))
SET LIM=$PIECE(ND2P5,"^",4)
if LIM=""
QUIT 0
+4 SET ND0=$GET(@(F_"0)"))
IF PSJORD["P"
IF $PIECE(ND0,"^",4)="U"
QUIT 0
+5 NEW MULT
SET MULT=$SELECT($EXTRACT(LIM)="h":60,$EXTRACT(LIM)="d":1440,$EXTRACT(LIM)="m":LIM,$EXTRACT(LIM)="l":LIM,$EXTRACT(LIM)="a":LIM,1:0)
IF MULT
SET LIM=MULT*$EXTRACT(LIM,2,99)
+6 QUIT LIM
+7 ;
GETMIN(LIM,DFN,PSJORD,DAYS) ; Return the duration of the IV Limit in minutes (includes IV Limits in volume and doses format)
+1 SET LIM=$$GETMIN^PSIVUTL1(LIM,DFN,PSJORD,.DAYS)
+2 QUIT LIM
DOSES(DDLX,PRAY) ; Find stop date when 'doses' are sent as an IV Limit
+1 if $GET(DDLX)'["L"
QUIT ""
+2 IF $PIECE(DDLX,"L")["."
SET DDLX=($PIECE(DDLX,".")+1)_"L"
+3 IF '$GET(PRAY(15))
IF $GET(PRAY(11))
SET PRAY(15)=1440/$LENGTH(PRAY(11),"-")
+4 if '$GET(PRAY(2))!'$GET(OIX)
QUIT ""
+5 NEW FIRST,DOSAR,LAST,TMP9
SET LAST=""
SET TMP9=PRAY(9)
+6 SET STRING=PRAY(2)_"^"_$SELECT($GET(STPDT):STPDT,1:$$FMADD^XLFDT(PSGDT,30))_"^"_PRAY(9)_"^C^"_OIX_"^"_PRAY(11)
SET FIRST=$$ENQ^PSJORP2(DFN,STRING)
+7 SET P(9)=TMP9
+8 SET FIRST=$SELECT($GET(FIRST):FIRST,1:PRAY(2))
if 'FIRST
QUIT
SET DSTMP=FIRST
SET DOSAR(1)=DSTMP
Begin DoDot:1
+9 ;*229 Add Dose Limit Calc
+10 IF $GET(DDLX)["L"
IF $GET(PRAY(15))
IF ($GET(PRAY(11))']"")!($GET(PRAY(15))>1440)
NEW PSIVSD,PSIVMIN,X
SET PSIVMIN=(+DDLX*PRAY(15))
SET PSIVSD=+PRAY(2)
DO ENT^PSIVWL
SET DOSAR(1)=Y
QUIT
+11 IF '$GET(PRAY(11))
FOR I=2:1:DDLX+1
SET DOSAR(I)=$$FMADD^XLFDT(DSTMP,,,PRAY(15))
SET DSTMP=DOSAR(I)
QUIT
+12 IF $GET(PRAY(11))
NEW ADMS,NXT,LAST,DAY
SET LAST=$PIECE(DSTMP,".",2)
SET DAY=$PIECE(DSTMP,".")
Begin DoDot:2
+13 FOR II=1:1:$LENGTH(PRAY(11),"-")
SET ADMS(+$PIECE(PRAY(11),"-",II))=$PIECE(PRAY(11),"-",II)
+14 ;*229 Include DOW Calc, Need to Q if DAY<0 if we go past max dt
+15 FOR IJ=2:1:DDLX+1
SET NXT=$ORDER(ADMS(+LAST))
SET LAST=NXT
Begin DoDot:3
+16 IF NXT=""
SET NXT=$ORDER(ADMS(NXT))
SET LAST=NXT
SET DAY=$$FMADD^XLFDT(DAY,$$MWFD(PRAY(9),DAY))
if DAY<0
QUIT
+17 SET DOSAR(IJ)=DAY_"."_ADMS(NXT)
SET DSTMP=DOSAR(IJ)
End DoDot:3
if DAY<0
QUIT
+18 IF +DDLX=1
SET NXT=$ORDER(ADMS(LAST))
SET LAST=NXT
Begin DoDot:3
+19 IF NXT=""
SET NXT=$ORDER(ADMS(NXT))
SET LAST=NXT
End DoDot:3
End DoDot:2
End DoDot:1
+20 IF $DATA(DOSAR)
SET LAST=$ORDER(DOSAR(""),-1)
IF LAST
SET LAST=DOSAR(LAST)
+21 QUIT LAST
+22 ;
MWFD(SCH,LAST) ;*229 Add to calc which days in DOW
+1 ;Calculate Days to add for DOW sched
+2 NEW X,Y
+3 ;return 1 if not DOW
IF '$$DOW^PSIVUTL(SCH)
QUIT 1
+4 FOR I=1:1:7
SET X=$$FMADD^XLFDT(LAST,I)
DO DW^%DTC
IF SCH[$EXTRACT(X,1,2)
SET Y=I
QUIT
+5 QUIT Y
+6 ;
