PSIVSP ;BIR/RGY,PR,CML - DOSE PROCESSOR ;1/3/12 3:36pm
;;5.0;INPATIENT MEDICATIONS;**30,37,41,50,56,74,83,111,133,138,134,213,229,279,305,331,256,347,358,439**;16 DEC 97;Build 1
;
; Reference to ^PS(51.1 is supported by DBIA #2177
;
; PSJ*439 - Removed the 3 from dev initials in line 1 which now causes an
; XINDEX error. Added outer parentheses to the string check in the
; ORINF tag to more accurately process the string and not add the
; "ml/hr" suffix unnecessarily.
;
EN ;
NEW PSJORGX
Q:'$D(X)
S ATZERO=0 I X["@",$P(X,"@",2)=0 S ATZERO=1,X=$P(X,"@")
;D EN^PSGS0 S (P(9),PSIVSC1)=$S($G(X)]"":X,1:$G(P(9))),P(11)=$S($G(PSGS0Y):PSGS0Y,1:$G(P(11))),(XT,P(15))=$S(($G(PSGS0XT)!($G(PSGS0XT)="O")!($G(PSGS0XT)="D")):$G(PSGS0XT),1:$G(P(15)))
;PSJ*5*256 - not set P(9) when FN order so the Old schedule name is not auto replaced with .01 value
S PSJORGX=X
;PSJ*5*358
D EN^PSGS0
I ($G(PSJOCFG)="FN IV"),(($G(P(9))="")&($G(X)]"")) S P(9)=$G(X)
I ($G(PSJOCFG)'="FN IV"),$S((($G(X)]"")&($G(X)'=PSJORGX)):1,$G(PSJOCFG)="":0,1:1) S P(9)=$S($G(X)]"":X,1:$G(P(9)))
S P(11)=$S($G(PSGS0Y):PSGS0Y,1:$G(P(11))),(XT,P(15))=$S(($G(PSGS0XT)!($G(PSGS0XT)="O")!($G(PSGS0XT)="D")):$G(PSGS0XT),1:$G(P(15)))
I $G(ATZERO) S P(7)=1
K ATZERO Q
EN1 ;
S (PSIVAT,PSIVWAT,Y)="",XT=-1,X0=X,X=$S(X="ON CALL":X,X="ONCALL":X,X="ON-CALL":X,X="ONETIME":X,X="ONE-TIME":X,X="ONE TIME":X,X="1TIME":X,X="1 TIME":X,X="1-TIME":X,$L(X," ")<3:$P(X," "),1:$P(X," ",1,2))
S:$E(X)="^" X=$E(X,2,999) G:X="" Q S:(X["@0")&($$SCHREQ^PSJLIVFD(.P)) ATZERO=1 S X=$S(X["@0":$P(X,"@"),1:X),P(7)=$S($G(ATZERO):1,1:"") K ATZERO
I $S($D(^PS(51.1,"AC","PSJ",X)):1,1:$E($O(^(X)),1,$L(X))=X) D DIC I Y'<0 G SH
NS0 S Y=""
I $E(X,1,2)="AD" S XT=-1 Q
I $E(X,1,3)="BID"!($E(X,1,3)="TID")!($E(X,1,3)="QID") S XT=1440\$F("BTQ",$E(X))
E S:$E(X)="Q" X=$E(X,2,99) S:'X X=$E(X)["O"+1_X S I=+X,X=$P(X,I,2),XT=I*$S(X["'":1,(X["D"&(X'["AD"))!(X["AM")!(X["PM")!(X["HS"&(X'["THS")):1440,X["H"&(X'["TH"):60,X["AC"!(X["PC"):480,X["W":10080,X["M":40320,1:0),X=X0 D
. I 'XT,X'="NOW",X'="STAT",X'="ONCE",X'="ONE-TIME",X'="ONE TIME",X'="ONETIME",X'="1-TIME",X'="1 TIME",X'="1TIME",Y="" S XT=-1
SH ;
I +Y<1,$E(X0)'="^" W:$G(ON)'["P" " ",$S(XT=0&($S("^NOW^STAT^ONCE^ONE-TIME^ONETIME^1TIME^1-TIME^"[(U_$P(X," ")_U):1,X["1 TIME":1,1:X["ONE TIME")):"(ONCE ONLY)",XT>0:"Nonstandard schedule",XT<0:"",1:"(??)") W:XT>0 " (",XT," MINUTES)"
Q Q:X="ONE TIME"
N I S X0=$P(X," ")_$S($L(X0," ")-1:" ",1:"")_$P(X0," ",2,99) K:XT<0!($L(X0)>22) X S:$D(X) X=X0 K X0 S:$G(P(7)) XT="" Q
NEWQ ;N I S X0=$P(X," ")_$S($L(X0," ")-1:" ",1:"")_$P(X0," ",2,99) K:XT<0!($L(X0)>22) X S:$D(X) X=X0 S:P(7) X=X0 K X0 K:XT>0&('P(7)) X Q
Q
;
;*229 Add Temp val for dose limit in IOE
ENDL N PSIVLIMT W " Dose limit .... " S PSIVLIMT="a"_X,PSIVMIN=P(15)*X,PSIVSD=+P(2)
I PSIVMIN<0 W !!," --- There is something wrong with this order !!",!," Call inpatient supervisor ....." S Y=-1 K PSIVMIN Q
I P(15)'["D",P(4)="P"!(P(5))!(P(23)="P"),PSIVMIN=0,"^NOW^STAT^ONCE^ONE-TIME^ONE TIME^ON CALL^ONETIME^1TIME^1 TIME^1-TIME^"'[(U_P(9)_U) D DLP G QDL
;*229 DOW Calc and dose lim should match CPRS, if it's vol limit, we leave old functionality
I $G(P(9))]"",$G(P(11))]"" D ENSTOP^PSIVCAL S Y=X I 1 ;*229 ENSTOP^PSIVCAL returns X, we wanted Y.
E D ENT^PSIVWL
QDL I $D(X) S X=Y X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2) S Y=X
Q
DLP ;
S X=X+1,$P(PSIVSD,".",2)=$P(PSIVSD,".",2)_$E("0000",1,4-$L($P(PSIVSD,".",2))) D CHK S X2=0,Y=1 I X<2 S Y=+PSIVSD G QDLP
I $P(PSIVSD,".",2)>$P(P(11),"-",$L(P(11),"-")) S X2=1 G OV
G:$P(P(11),"-")>$P(PSIVSD,".",2) OV
F Y=1:1 S X1=$P(P(11),"-",Y) I X1=$P(PSIVSD,".",2)!($P(PSIVSD,".",2)<X1) Q
OV I P(11)="" W $C(7)," ???",!?15,"*** You have not defined any administration times !!" K X Q
F Y=Y:1 S:$P(P(11),"-",Y)="" X2=X2+1,Y=0,X=X+1 S X=X-1 Q:X<1
S X=PSIVSD\1 I X2>0 S X1=PSIVSD D C^%DTC S X=$P(X,".") ; install with version 17.3 of fileman
S Y=+(X_"."_$P(P(11),"-",Y))
QDLP K X1,X2 Q
;
ENI ;
N PSIZEROX S PSIZEROX=0_+X
K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X)!'$D(P(4)) Q
;*229 Reset ATZERO flag.
I $P(X,"@",2)'=0!'$$SCHREQ^PSJLIVFD(.P) S P(7)=""
I P(4)="P"!(P(5))!(P(23)="P") Q:'X S X="INFUSE OVER "_X_" MINUTE"_$S(X>1:"S",1:"") W " ",X Q
I $E(X)="." K X Q ;Enforce leading zero.
I X'=+X!(X'=0_+X),X["@",($P(X,"@",2,999)'=+$P(X,"@",2,999)!(+$P(X,"@",2,999)<0)) K X Q
S SPSOL=$O(DRG("SOL",0)) I 'SPSOL K SPSOL,X W " You must define at least one solution !!" Q
I (X=+X)!(X=PSIZEROX) I X'["@" S X=X_" ml/hr" W " ml/hr" D SPSOL S P(15)=$S('X:0,1:SPSOL\X*60+(SPSOL#X/X*60+.5)\1) K SPSOL Q
S SPSOL=$S(($P(X,"@",2)?1.N):$P(X,"@",2),1:$G(P("NUMLBL"))) I SPSOL S P("NUMLBL")=+SPSOL
S:$P(X,"@")=+X!($P(X,"@")=PSIZEROX) $P(X,"@")=$P(X,"@")_" ml/hr" W " ",+SPSOL," Label",$S(SPSOL'=1:"s",1:"")," per day",!?15,"at an infusion rate of: ",$P(X,"@") S P(15)=$S('SPSOL:0,1:1440/SPSOL\1) K SPSOL
I X["@",$P(X,"@",2)=0,$$SCHREQ^PSJLIVFD(.P) S P(7)=1 ; Set ATZERO flag
;*305
I '$G(PSJEXMSG) D EXPINF^PSIVEDT1(.X)
Q
SPSOL S SPSOL=0 F XXX=0:0 S XXX=$O(DRG("SOL",XXX)) Q:'XXX S SPSOL=SPSOL+$P(DRG("SOL",XXX),U,3)
K XXX Q
CHK F Y=1:1 Q:$L(P(11))>240!($P(P(11),"-",Y)="") S $P(P(11),"-",Y)=$P(P(11),"-",Y)_$E("0000",1,4-$L($P(P(11),"-",Y)))
Q
;
DIC ; 51.1 look-up
N PSJSCH S PSJSCH=X I '$D(WSCHADM) N VAIP D IN5^VADPT S WSCHADM=VAIP(5),X=PSJSCH
K DIC S DIC="^PS(51.1,",DIC(0)=$E("E",'$D(NOECH))_"ISZ"
; The naked reference below refers to the full reference inside indirection to ^PS(51.1
S DIC("W")="W "" "","_$S('$D(WSCHADM):"$P(^(0),""^"",2)",'+WSCHADM:"$P(^(0),""^"",2)",1:"$S($D(^PS(51.1,+Y,1,+WSCHADM,0)):$P(^(0),""^"",2),1:$P(^PS(51.1,+Y,0),""^"",2))"),D="APPSJ" S:$D(PSIVSPQF) DIC(0)=DIC(0)_"O"
D IX^DIC K DIC
S:$D(DIE)#2 DIC=DIE Q:Y<0
S X=Y(0,0),ZZY=Y,(XT,Y)="" I $D(WSCHADM),$D(^PS(51.1,+ZZY,1,+WSCHADM,0)),$P(^(0),"^",2)]"" S (PSIVWAT,Y)=$P(^(0),"^",2)
K ZZY,WSCHADM S:Y="" (X,PSIVSC1)=$P(Y(0),U),(PSIVAT,Y)=$P(Y(0),"^",2) S XT=$P(Y(0),"^",3) Q
;
ORINF ; OERR input transform for Infusion Rate
; X=data
N INFUSE
K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X) Q
I X?.E1L.E S INFUSE=$$ENLU^PSGMI(X) Q:(INFUSE="TITRATE")!(INFUSE="BOLUS")!($P(INFUSE," ")="INFUSE")!($P(INFUSE," ")="Infuse")
Q:(X="TITRATE")!(X="BOLUS")!($P(X," ")="INFUSE")!($P(X," ")="Infuse")
I X["=" D Q ; NOIS LOU-0501-42191
.N X2,X1 S X1=$P(X,"="),X2=$P(X,"=",2)
.I X1["ML/HR",(+X1=$P(X1,"ML/HR"))!(+X1=$P(X1," ML/HR")) D
..S X1=$TR(X1,"ML/HR","ml/hr")
.I X2["ML/HR",(+X2=$P(X2,"ML/HR"))!(+X2=$P(X2," ML/HR")) D
..S X2=$TR(X2,"ML/HR","ml/hr")
.I X1[" ml/hr",(+X1=$P(X1," ml/hr")) D
..S X1=$P(X1," ml/hr")_$P(X1," ml/hr",2,9999)
.I X2[" ml/hr",(+X2=$P(X2," ml/hr")) D
..S X2=$P(X2," ml/hr")_$P(X2," ml/hr",2,9999)
.I X1["ml/hr",(+X1=$P(X1,"ml/hr")) D
..S X1=$P(X1,"ml/hr")_$P(X1,"ml/hr",2,9999)
.I X2["ml/hr",(+X2=$P(X2,"ml/hr")) D
..S X2=$P(X2,"ml/hr")_$P(X2,"ml/hr",2,9999)
.I X2'=+X2 D
..I X2>0&(X2<1) Q
..I ($P(X2,"@",2,999)'=+$P(X2,"@",2,999)!(+$P(X2,"@",2,999)<0)) K X Q
.I X1>0&(X1<1) I +X1=("."_$P(X1,".",2)) S X1=X1_" ml/hr" ; PSJ*439
.I X2>0&(X2<1) I +X2=("."_$P(X2,".",2)) S X2=X2_" ml/hr" ; PSJ*439
.I X1=+X1 S X1=X1_" ml/hr"
.I X2=+X2 S X2=X2_" ml/hr"
.S:$P(X2,"@")=+X2 $P(X2,"@")=$P(X2,"@")_" ml/hr"
.S X=X1_"="_X2
I X["ML/HR",(+X=$P(X,"ML/HR"))!(+X=$P(X," ML/HR")) S X=$TR(X,"ML/HR","ml/hr")
I X[" ml/hr",+X=$P(X," ml/hr") S X=$P(X," ml/hr")_$P(X," ml/hr",2,9999)
I X["ml/hr",+X=$P(X,"ml/hr") S X=$P(X,"ml/hr")_$P(X,"ml/hr",2,9999)
I X>0,X<1 D Q
.I X["ML/HR",(+X=$P($P(X,"ML/HR"),".",2))!(+X=$P($P(X," ML/HR"),".",2)) S X=$TR(X,"ML/HR","ml/hr")
.I X[" ml/hr",(+X=$P($P(X," ml/hr"),".",2)) S X=$P(X," ml/hr")_$P(X," ml/hr",2,9999)
.I X["ml/hr",+X=$P(X,"ml/hr") S X=$P(X,"ml/hr")_$P(X,"ml/hr",2,9999)
.I +X=X S X=X_" ml/hr"
.I $P(X,0,2)=+X S X=X_" ml/hr"
.S X=0_+X_$P(X,+X,2)
I '(X>0&X<1) I X'=+X,($P(X,"@",2,999)'=+$P(X,"@",2,999)!(+$P(X,"@",2,999)<0)) K X Q
I X=+X S X=X_" ml/hr" Q
S:$P(X,"@")=+X $P(X,"@")=$P(X,"@")_" ml/hr"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVSP 8125 printed Jan 18, 2025@03:06:18 Page 2
PSIVSP ;BIR/RGY,PR,CML - DOSE PROCESSOR ;1/3/12 3:36pm
+1 ;;5.0;INPATIENT MEDICATIONS;**30,37,41,50,56,74,83,111,133,138,134,213,229,279,305,331,256,347,358,439**;16 DEC 97;Build 1
+2 ;
+3 ; Reference to ^PS(51.1 is supported by DBIA #2177
+4 ;
+5 ; PSJ*439 - Removed the 3 from dev initials in line 1 which now causes an
+6 ; XINDEX error. Added outer parentheses to the string check in the
+7 ; ORINF tag to more accurately process the string and not add the
+8 ; "ml/hr" suffix unnecessarily.
+9 ;
EN ;
+1 NEW PSJORGX
+2 if '$DATA(X)
QUIT
+3 SET ATZERO=0
IF X["@"
IF $PIECE(X,"@",2)=0
SET ATZERO=1
SET X=$PIECE(X,"@")
+4 ;D EN^PSGS0 S (P(9),PSIVSC1)=$S($G(X)]"":X,1:$G(P(9))),P(11)=$S($G(PSGS0Y):PSGS0Y,1:$G(P(11))),(XT,P(15))=$S(($G(PSGS0XT)!($G(PSGS0XT)="O")!($G(PSGS0XT)="D")):$G(PSGS0XT),1:$G(P(15)))
+5 ;PSJ*5*256 - not set P(9) when FN order so the Old schedule name is not auto replaced with .01 value
+6 SET PSJORGX=X
+7 ;PSJ*5*358
+8 DO EN^PSGS0
+9 IF ($GET(PSJOCFG)="FN IV")
IF (($GET(P(9))="")&($GET(X)]""))
SET P(9)=$GET(X)
+10 IF ($GET(PSJOCFG)'="FN IV")
IF $SELECT((($GET(X)]"")&($GET(X)'=PSJORGX)):1,$GET(PSJOCFG)="":0,1:1)
SET P(9)=$SELECT($GET(X)]"":X,1:$GET(P(9)))
+11 SET P(11)=$SELECT($GET(PSGS0Y):PSGS0Y,1:$GET(P(11)))
SET (XT,P(15))=$SELECT(($GET(PSGS0XT)!($GET(PSGS0XT)="O")!($GET(PSGS0XT)="D")):$GET(PSGS0XT),1:$GET(P(15)))
+12 IF $GET(ATZERO)
SET P(7)=1
+13 KILL ATZERO
QUIT
EN1 ;
+1 SET (PSIVAT,PSIVWAT,Y)=""
SET XT=-1
SET X0=X
SET X=$SELECT(X="ON CALL":X,X="ONCALL":X,X="ON-CALL":X,X="ONETIME":X,X="ONE-TIME":X,X="ONE TIME":X,X="1TIME":X,X="1 TIME":X,X="1-TIME":X,$LENGTH(X," ")<3:$PIECE(X," "),1:$PIECE(X," ",1,2))
+2 if $EXTRACT(X)="^"
SET X=$EXTRACT(X,2,999)
if X=""
GOTO Q
if (X["@0")&($$SCHREQ^PSJLIVFD(.P))
SET ATZERO=1
SET X=$SELECT(X["@0":$PIECE(X,"@"),1:X)
SET P(7)=$SELECT($GET(ATZERO):1,1:"")
KILL ATZERO
+3 IF $SELECT($DATA(^PS(51.1,"AC","PSJ",X)):1,1:$EXTRACT($ORDER(^(X)),1,$LENGTH(X))=X)
DO DIC
IF Y'<0
GOTO SH
NS0 SET Y=""
+1 IF $EXTRACT(X,1,2)="AD"
SET XT=-1
QUIT
+2 IF $EXTRACT(X,1,3)="BID"!($EXTRACT(X,1,3)="TID")!($EXTRACT(X,1,3)="QID")
SET XT=1440\$FIND("BTQ",$EXTRACT(X))
+3 IF '$TEST
if $EXTRACT(X)="Q"
SET X=$EXTRACT(X,2,99)
if 'X
SET X=$EXTRACT(X)["O"+1_X
SET I=+X
SET X=$PIECE(X,I,2)
SET XT=I*$SELECT(X["'":1,(X["D"&(X'["AD"))!(X["AM")!(X["PM")!(X["HS"&(X'["THS")):1440,X["H"&(X'["TH"):60,X["AC"!(X["PC"):480,X["W":10080,X["M":40320,1:0)
SET X=X0
Begin DoDot:1
+4 IF 'XT
IF X'="NOW"
IF X'="STAT"
IF X'="ONCE"
IF X'="ONE-TIME"
IF X'="ONE TIME"
IF X'="ONETIME"
IF X'="1-TIME"
IF X'="1 TIME"
IF X'="1TIME"
IF Y=""
SET XT=-1
End DoDot:1
SH ;
+1 IF +Y<1
IF $EXTRACT(X0)'="^"
if $GET(ON)'["P"
WRITE " ",$SELECT(XT=0&($SELECT("^NOW^STAT^ONCE^ONE-TIME^ONETIME^1TIME^1-TIME^"[(U_$PIECE(X," ")_U):1,X["1 TIME":1,1:X["ONE TIME")):"(ONCE ONLY)",XT>0:"Nonstandard schedule",XT<0:"",1:"(??)")
if XT>0
WRITE " (",XT," MINUTES)"
Q if X="ONE TIME"
QUIT
+1 NEW I
SET X0=$PIECE(X," ")_$SELECT($LENGTH(X0," ")-1:" ",1:"")_$PIECE(X0," ",2,99)
if XT<0!($LENGTH(X0)>22)
KILL X
if $DATA(X)
SET X=X0
KILL X0
if $GET(P(7))
SET XT=""
QUIT
NEWQ ;N I S X0=$P(X," ")_$S($L(X0," ")-1:" ",1:"")_$P(X0," ",2,99) K:XT<0!($L(X0)>22) X S:$D(X) X=X0 S:P(7) X=X0 K X0 K:XT>0&('P(7)) X Q
+1 QUIT
+2 ;
+3 ;*229 Add Temp val for dose limit in IOE
ENDL NEW PSIVLIMT
WRITE " Dose limit .... "
SET PSIVLIMT="a"_X
SET PSIVMIN=P(15)*X
SET PSIVSD=+P(2)
+1 IF PSIVMIN<0
WRITE !!," --- There is something wrong with this order !!",!," Call inpatient supervisor ....."
SET Y=-1
KILL PSIVMIN
QUIT
+2 IF P(15)'["D"
IF P(4)="P"!(P(5))!(P(23)="P")
IF PSIVMIN=0
IF "^NOW^STAT^ONCE^ONE-TIME^ONE TIME^ON CALL^ONETIME^1TIME^1 TIME^1-TIME^"'[(U_P(9)_U)
DO DLP
GOTO QDL
+3 ;*229 DOW Calc and dose lim should match CPRS, if it's vol limit, we leave old functionality
+4 ;*229 ENSTOP^PSIVCAL returns X, we wanted Y.
IF $GET(P(9))]""
IF $GET(P(11))]""
DO ENSTOP^PSIVCAL
SET Y=X
IF 1
+5 IF '$TEST
DO ENT^PSIVWL
QDL IF $DATA(X)
SET X=Y
XECUTE ^DD("DD")
WRITE $PIECE(Y,"@")," ",$PIECE(Y,"@",2)
SET Y=X
+1 QUIT
DLP ;
+1 SET X=X+1
SET $PIECE(PSIVSD,".",2)=$PIECE(PSIVSD,".",2)_$EXTRACT("0000",1,4-$LENGTH($PIECE(PSIVSD,".",2)))
DO CHK
SET X2=0
SET Y=1
IF X<2
SET Y=+PSIVSD
GOTO QDLP
+2 IF $PIECE(PSIVSD,".",2)>$PIECE(P(11),"-",$LENGTH(P(11),"-"))
SET X2=1
GOTO OV
+3 if $PIECE(P(11),"-")>$PIECE(PSIVSD,".",2)
GOTO OV
+4 FOR Y=1:1
SET X1=$PIECE(P(11),"-",Y)
IF X1=$PIECE(PSIVSD,".",2)!($PIECE(PSIVSD,".",2)<X1)
QUIT
OV IF P(11)=""
WRITE $CHAR(7)," ???",!?15,"*** You have not defined any administration times !!"
KILL X
QUIT
+1 FOR Y=Y:1
if $PIECE(P(11),"-",Y)=""
SET X2=X2+1
SET Y=0
SET X=X+1
SET X=X-1
if X<1
QUIT
+2 ; install with version 17.3 of fileman
SET X=PSIVSD\1
IF X2>0
SET X1=PSIVSD
DO C^%DTC
SET X=$PIECE(X,".")
+3 SET Y=+(X_"."_$PIECE(P(11),"-",Y))
QDLP KILL X1,X2
QUIT
+1 ;
ENI ;
+1 NEW PSIZEROX
SET PSIZEROX=0_+X
+2 if $LENGTH(X)<1!($LENGTH(X)>30)!(X["""")!($ASCII(X)=45)
KILL X
IF '$DATA(X)!'$DATA(P(4))
QUIT
+3 ;*229 Reset ATZERO flag.
+4 IF $PIECE(X,"@",2)'=0!'$$SCHREQ^PSJLIVFD(.P)
SET P(7)=""
+5 IF P(4)="P"!(P(5))!(P(23)="P")
if 'X
QUIT
SET X="INFUSE OVER "_X_" MINUTE"_$SELECT(X>1:"S",1:"")
WRITE " ",X
QUIT
+6 ;Enforce leading zero.
IF $EXTRACT(X)="."
KILL X
QUIT
+7 IF X'=+X!(X'=0_+X)
IF X["@"
IF ($PIECE(X,"@",2,999)'=+$PIECE(X,"@",2,999)!(+$PIECE(X,"@",2,999)<0))
KILL X
QUIT
+8 SET SPSOL=$ORDER(DRG("SOL",0))
IF 'SPSOL
KILL SPSOL,X
WRITE " You must define at least one solution !!"
QUIT
+9 IF (X=+X)!(X=PSIZEROX)
IF X'["@"
SET X=X_" ml/hr"
WRITE " ml/hr"
DO SPSOL
SET P(15)=$SELECT('X:0,1:SPSOL\X*60+(SPSOL#X/X*60+.5)\1)
KILL SPSOL
QUIT
+10 SET SPSOL=$SELECT(($PIECE(X,"@",2)?1.N):$PIECE(X,"@",2),1:$GET(P("NUMLBL")))
IF SPSOL
SET P("NUMLBL")=+SPSOL
+11 if $PIECE(X,"@")=+X!($PIECE(X,"@")=PSIZEROX)
SET $PIECE(X,"@")=$PIECE(X,"@")_" ml/hr"
WRITE " ",+SPSOL," Label",$SELECT(SPSOL'=1:"s",1:"")," per day",!?15,"at an infusion rate of: ",$PIECE(X,"@")
SET P(15)=$SELECT('SPSOL:0,1:1440/SPSOL\1)
KILL SPSOL
+12 ; Set ATZERO flag
IF X["@"
IF $PIECE(X,"@",2)=0
IF $$SCHREQ^PSJLIVFD(.P)
SET P(7)=1
+13 ;*305
+14 IF '$GET(PSJEXMSG)
DO EXPINF^PSIVEDT1(.X)
+15 QUIT
SPSOL SET SPSOL=0
FOR XXX=0:0
SET XXX=$ORDER(DRG("SOL",XXX))
if 'XXX
QUIT
SET SPSOL=SPSOL+$PIECE(DRG("SOL",XXX),U,3)
+1 KILL XXX
QUIT
CHK FOR Y=1:1
if $LENGTH(P(11))>240!($PIECE(P(11),"-",Y)="")
QUIT
SET $PIECE(P(11),"-",Y)=$PIECE(P(11),"-",Y)_$EXTRACT("0000",1,4-$LENGTH($PIECE(P(11),"-",Y)))
+1 QUIT
+2 ;
DIC ; 51.1 look-up
+1 NEW PSJSCH
SET PSJSCH=X
IF '$DATA(WSCHADM)
NEW VAIP
DO IN5^VADPT
SET WSCHADM=VAIP(5)
SET X=PSJSCH
+2 KILL DIC
SET DIC="^PS(51.1,"
SET DIC(0)=$EXTRACT("E",'$DATA(NOECH))_"ISZ"
+3 ; The naked reference below refers to the full reference inside indirection to ^PS(51.1
+4 SET DIC("W")="W "" "","_$SELECT('$DATA(WSCHADM):"$P(^(0),""^"",2)",'+WSCHADM:"$P(^(0),""^"",2)",1:"$S($D(^PS(51.1,+Y,1,+WSCHADM,0)):$P(^(0),""^"",2),1:$P(^PS(51.1,+Y,0),""^"",2))")
SET D="APPSJ"
if $DATA(PSIVSPQF)
SET DIC(0)=DIC(0)_"O"
+5 DO IX^DIC
KILL DIC
+6 if $DATA(DIE)#2
SET DIC=DIE
if Y<0
QUIT
+7 SET X=Y(0,0)
SET ZZY=Y
SET (XT,Y)=""
IF $DATA(WSCHADM)
IF $DATA(^PS(51.1,+ZZY,1,+WSCHADM,0))
IF $PIECE(^(0),"^",2)]""
SET (PSIVWAT,Y)=$PIECE(^(0),"^",2)
+8 KILL ZZY,WSCHADM
if Y=""
SET (X,PSIVSC1)=$PIECE(Y(0),U)
SET (PSIVAT,Y)=$PIECE(Y(0),"^",2)
SET XT=$PIECE(Y(0),"^",3)
QUIT
+9 ;
ORINF ; OERR input transform for Infusion Rate
+1 ; X=data
+2 NEW INFUSE
+3 if $LENGTH(X)<1!($LENGTH(X)>30)!(X["""")!($ASCII(X)=45)
KILL X
IF '$DATA(X)
QUIT
+4 IF X?.E1L.E
SET INFUSE=$$ENLU^PSGMI(X)
if (INFUSE="TITRATE")!(INFUSE="BOLUS")!($PIECE(INFUSE," ")="INFUSE")!($PIECE(INFUSE," ")="Infuse")
QUIT
+5 if (X="TITRATE")!(X="BOLUS")!($PIECE(X," ")="INFUSE")!($PIECE(X," ")="Infuse")
QUIT
+6 ; NOIS LOU-0501-42191
IF X["="
Begin DoDot:1
+7 NEW X2,X1
SET X1=$PIECE(X,"=")
SET X2=$PIECE(X,"=",2)
+8 IF X1["ML/HR"
IF (+X1=$PIECE(X1,"ML/HR"))!(+X1=$PIECE(X1," ML/HR"))
Begin DoDot:2
+9 SET X1=$TRANSLATE(X1,"ML/HR","ml/hr")
End DoDot:2
+10 IF X2["ML/HR"
IF (+X2=$PIECE(X2,"ML/HR"))!(+X2=$PIECE(X2," ML/HR"))
Begin DoDot:2
+11 SET X2=$TRANSLATE(X2,"ML/HR","ml/hr")
End DoDot:2
+12 IF X1[" ml/hr"
IF (+X1=$PIECE(X1," ml/hr"))
Begin DoDot:2
+13 SET X1=$PIECE(X1," ml/hr")_$PIECE(X1," ml/hr",2,9999)
End DoDot:2
+14 IF X2[" ml/hr"
IF (+X2=$PIECE(X2," ml/hr"))
Begin DoDot:2
+15 SET X2=$PIECE(X2," ml/hr")_$PIECE(X2," ml/hr",2,9999)
End DoDot:2
+16 IF X1["ml/hr"
IF (+X1=$PIECE(X1,"ml/hr"))
Begin DoDot:2
+17 SET X1=$PIECE(X1,"ml/hr")_$PIECE(X1,"ml/hr",2,9999)
End DoDot:2
+18 IF X2["ml/hr"
IF (+X2=$PIECE(X2,"ml/hr"))
Begin DoDot:2
+19 SET X2=$PIECE(X2,"ml/hr")_$PIECE(X2,"ml/hr",2,9999)
End DoDot:2
+20 IF X2'=+X2
Begin DoDot:2
+21 IF X2>0&(X2<1)
QUIT
+22 IF ($PIECE(X2,"@",2,999)'=+$PIECE(X2,"@",2,999)!(+$PIECE(X2,"@",2,999)<0))
KILL X
QUIT
End DoDot:2
+23 ; PSJ*439
IF X1>0&(X1<1)
IF +X1=("."_$PIECE(X1,".",2))
SET X1=X1_" ml/hr"
+24 ; PSJ*439
IF X2>0&(X2<1)
IF +X2=("."_$PIECE(X2,".",2))
SET X2=X2_" ml/hr"
+25 IF X1=+X1
SET X1=X1_" ml/hr"
+26 IF X2=+X2
SET X2=X2_" ml/hr"
+27 if $PIECE(X2,"@")=+X2
SET $PIECE(X2,"@")=$PIECE(X2,"@")_" ml/hr"
+28 SET X=X1_"="_X2
End DoDot:1
QUIT
+29 IF X["ML/HR"
IF (+X=$PIECE(X,"ML/HR"))!(+X=$PIECE(X," ML/HR"))
SET X=$TRANSLATE(X,"ML/HR","ml/hr")
+30 IF X[" ml/hr"
IF +X=$PIECE(X," ml/hr")
SET X=$PIECE(X," ml/hr")_$PIECE(X," ml/hr",2,9999)
+31 IF X["ml/hr"
IF +X=$PIECE(X,"ml/hr")
SET X=$PIECE(X,"ml/hr")_$PIECE(X,"ml/hr",2,9999)
+32 IF X>0
IF X<1
Begin DoDot:1
+33 IF X["ML/HR"
IF (+X=$PIECE($PIECE(X,"ML/HR"),".",2))!(+X=$PIECE($PIECE(X," ML/HR"),".",2))
SET X=$TRANSLATE(X,"ML/HR","ml/hr")
+34 IF X[" ml/hr"
IF (+X=$PIECE($PIECE(X," ml/hr"),".",2))
SET X=$PIECE(X," ml/hr")_$PIECE(X," ml/hr",2,9999)
+35 IF X["ml/hr"
IF +X=$PIECE(X,"ml/hr")
SET X=$PIECE(X,"ml/hr")_$PIECE(X,"ml/hr",2,9999)
+36 IF +X=X
SET X=X_" ml/hr"
+37 IF $PIECE(X,0,2)=+X
SET X=X_" ml/hr"
+38 SET X=0_+X_$PIECE(X,+X,2)
End DoDot:1
QUIT
+39 IF '(X>0&X<1)
IF X'=+X
IF ($PIECE(X,"@",2,999)'=+$PIECE(X,"@",2,999)!(+$PIECE(X,"@",2,999)<0))
KILL X
QUIT
+40 IF X=+X
SET X=X_" ml/hr"
QUIT
+41 if $PIECE(X,"@")=+X
SET $PIECE(X,"@")=$PIECE(X,"@")_" ml/hr"
+42 QUIT
