ORCDPSIV ;SLC/MKB-Pharmacy IV dialog utilities ;06/17/10
;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,38,48,158,195,243,296,280,388,467,499**;Dec 17, 1997;Build 165
;Per VHA Directive 6402, this routine should not be modified.
;
; Reference to IVDEA^PSSUTIL1 in ICR #3784
; Reference to ^PSIVSP in ICR #2945
; Reference to ^PSJORUT2 in ICR #2402
; Reference to ^PSSDSAPA in ICR #5504
; Reference to ^PSSGS0 in ICR #3423
;
CKSCH ; -- validate schedule [Called from P-S Action]
N ORX S ORX=ORDIALOG(PROMPT,ORI) Q:ORX=$G(ORESET) K ORSD
D EN^PSSGS0(.ORX,"I")
I $D(ORX) S ORDIALOG(PROMPT,ORI)=ORX Q
W $C(7),!,"Enter a standard schedule for administering this medication."
Q
ISONETIM(SCH) ;
N DUR
I SCH="" Q 0
K ^TMP($J,"ORCDPSIV GETSCHTYP")
D ZERO^PSS51P1(,SCH,"PSJ","O","ORCDPSIV GETSCHTYP")
I $D(^TMP($J,"ORCDPSIV GETSCHTYP","B",SCH)) D Q 1
.S DUR=$$PTR^ORCD("OR GTX DURATION")
.I $G(ORDIALOG(DUR,1))="" Q
.S ORDIALOG(DUR,1)=""
.W !,"IV Orders with a schedule type of one-time cannot have a duration."
.W !,"The duration has been deleted from this quick order." H 1
K ^TMP($J,"ORCDPSIV GETSCHTYP")
Q 0
;
ADDFRD(ORDIALOG,INST,PROMPT) ;
N ADDFRIEN,ADDIEN,OI,PSOI,RESULT
S RESULT=""
I $G(ORIVTYPE)'="C" Q RESULT
S ADDFRIEN=$O(^ORD(101.41,"AB","OR GTX ADDITIVE FREQUENCY","")) I 'ADDFRIEN Q RESULT
S ADDIEN=$O(^ORD(101.41,"AB","OR GTX ADDITIVE","")) I 'ADDIEN Q RESULT
S RESULT=$$RECALL^ORCD(PROMPT,INST) I RESULT'="" Q RESULT
S OI=$G(ORDIALOG(ADDIEN,INST)) I OI="" Q RESULT
S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2) I +PSOI'>0 Q RESULT
S RESULT=$$IV^PSSDSAPA(+PSOI)
S RESULT=$S(RESULT="A":"All Bags",RESULT=1:"1 Bag/Day",1:"")
Q RESULT
;
ADDFRQC ;
I $G(ORIVTYPE)'="C" Q
W !,"Select from the list of the codes below to assign an additive frequency for this additive."
W !,"A = All Bags"
W !,"1 = 1 Bag/Day"
W !,"S = See Comments"
W !
Q
ADDFRQI ;
S X=$$UP^XLFSTR(X)
I X'="A",X'=1,X'="S" D ADDFRQC K X Q
I X="A" S X="All Bags" Q
I X=1 S X="1 Bag/Day" Q
I X="S" S X="See Comments"
Q
;
PROVIDER ; -- Check provider, if authorized to write med orders
I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS MED ORDERS") W $C(7),!!,"OREMAS key holders may not enter medication orders." S ORQUIT=1 Q
N PS,NAME S PS=$G(^VA(200,+$G(ORNP),"PS")),NAME=$P($G(^(20)),U,2)
I '$L(NAME) S NAME=$P(^VA(200,+$G(ORNP),0),U)
I '$P(PS,U) W $C(7),!!,NAME_" is not authorized to write medication orders!" S ORQUIT=1
I $P(PS,U,4),$$NOW^XLFDT>$P(PS,U,4) W $C(7),!!,NAME_" is no longer authorized to write medication orders!" S ORQUIT=1
I $G(ORQUIT) W !,"You must select another provider to continue.",! S PS=$$MEDPROV I PS S ORXNP=ORNP,ORNP=PS K ORQUIT
Q
;
MEDPROV() ; -- Return ordering med provider
N X,Y,D,DIC
S DIC=200,DIC(0)="AEQ",DIC("A")="Select PROVIDER: ",D="AK.PROVIDER"
S DIC("S")="I $P($G(^(""PS"")),U),'$P(^(""PS""),U,4)!($P(^(""PS""),U,4)>$$NOW^XLFDT)"
D IX^DIC S:Y>0 Y=+Y I Y'>0 S Y="^"
Q Y
;
CHANGED(TYPE) ; -- Kill dependent values when OI changes
N PROMPTS,NAME,PTR,P,I
Q:'$L($G(TYPE)) S PROMPTS=""
S:TYPE="B" PROMPTS="VOLUME"
S:TYPE="A" PROMPTS="STRENGTH PSIV^UNITS"
I TYPE="T" D
.S PROMPTS="INFUSION RATE^SCHEDULE^ADDITIVE FREQUENCY"
.S PTR=$O(^ORD(101.41,"AB","OR GTX DURATION","")) Q:'PTR
.I $G(ORDIALOG(PTR,1))["DOSES" S PROMPTS=PROMPTS_U_"DURATION"
;
F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P) D
. S PTR=$O(^ORD(101.41,"AB","OR GTX "_NAME,0)) Q:'PTR
. K ORDIALOG(PTR,ORI)
. ;S I=0 F S I=$O(ORDIALOG(PTR,I)) Q:I'>0 K ORDIALOG(PTR,I)
. K ORDIALOG(PTR,"LIST")
Q
;
INACTIVE(TYPE) ; -- Check OI inactive date
N OI,X,I,PSOI,DEA,EXIT,ORDEA S:$G(TYPE)'="A" TYPE="S"
S OI=+$G(ORDIALOG(PROMPT,INST)) Q:OI'>0
I $G(^ORD(101.43,OI,.1)),^(.1)'>$$NOW^XLFDT D Q ;inactive
. S X=$S(TYPE="A":"additive",1:"solution"),ORQUIT=1
. W $C(7),!,"This "_X_" may not be ordered anymore. Please select another."
S I=$S(TYPE="A":4,1:3) I '$P($G(^ORD(101.43,OI,"PS")),U,I) D Q
. S X=$S(TYPE="A":"an additive",1:"a solution"),ORQUIT=1
. W $C(7),!,"This item may not be ordered as "_X_"."
S EXIT=$$INPT^ORCD I EXIT=0 D ROUTECHK Q
Q:'$L($T(IVDEA^PSSUTIL1)) ;DBIA #3784
S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2)
S DEA=$$IVDEA^PSSUTIL1(PSOI,TYPE) I DEA>0 D Q:$G(ORQUIT)
.;*499 - Support multiple DEA numbers for a provider
. I $G(ORNP) S ORDEA=$$PRDEA^XUSER(ORNP) I '$L(ORDEA),'$L($P($G(^VA(200,+ORNP,"PS")),U,3)) W $C(7),!,$P($G(^(0)),U)_" must have a DEA# or VA# to order this drug!" S ORQUIT=1 Q
. I DEA=1 W $C(7),!,"This order will require a wet signature!"
D ROUTECHK
Q
;
VOLUME ; -- get allowable volumes for solution
N PSOI,ORY,CNT,I,XORY K ORDIALOG(PROMPT,"LIST")
S PSOI=+$P($G(^ORD(101.43,+$$VAL^ORCD("SOLUTION",INST),0)),U,2)_"B"
D ENVOL^PSJORUT2(PSOI,.ORY) Q:'ORY
;S (I,CNT)=0 F S I=$O(ORY(I)) Q:I'>0 S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",+ORY(I))=+ORY(I)
S (I,CNT)=0 F S I=$O(ORY(I)) Q:I'>0 D
. S CNT=CNT+1
. S XORY(I)=+ORY(I) I XORY(I)<1,$E(XORY(I),1,2)'="0." S XORY(I)=0_XORY(I)
. S ORDIALOG(PROMPT,"LIST",XORY(I))=XORY(I)
S ORDIALOG(PROMPT,"LIST")=CNT_"^1"
Q
;
UNITS ; -- get allowable units for current additive
N PSOI,ORY,I,UNITS
S PSOI=+$P(^ORD(101.43,+ORDIALOG($$PTR^ORCD("OR GTX ADDITIVE"),INST),0),U,2)_"A"
D ENVOL^PSJORUT2(PSOI,.ORY)
S I=$O(ORY(0)) Q:'I S UNITS=$P($G(ORY(I)),U,2)
S ORDIALOG($$PTR^ORCD("OR GTX UNITS"),INST)=UNITS
W !," (Units for this additive are "_UNITS_")"
Q
;
PREMIX() ; -- Returns 1 or 0, if IV base is a premix solution
N BASE,PS,I,Y
S BASE=$$PTR^ORCD("OR GTX ORDERABLE ITEM"),Y=0
S I=0 F S I=$O(ORDIALOG(BASE,I)) Q:I'>0 D Q:Y
. S PS=$G(^ORD(101.43,+$G(ORDIALOG(BASE,I)),"PS"))
. I $P(PS,U,3)&($P(PS,U,4)) S Y=1
Q Y
;
IVRTEENT ;
N ARRAY,DIR,RIEN,TROUTE
I ORTYPE'="Z" Q
S RIEN=$P($G(ORDIALOG("B","ROUTE")),U,2) Q:RIEN'>0
S EXIT=0,TROUTE=$G(ORDIALOG(RIEN,1)) Q:TROUTE'>0
I $$IVRTESCR(TROUTE)=1 Q
S ORDIALOG(RIEN,1)=""
W !!,"The selected route is not a valid route for this order."
W !,"Select a new route for this order from the list of routes below."
D RTEDISP(.ARRAY)
Q
;
BIVOI(ARRAY) ;
N CNT,NUM,OIIEN,OTYPE
S CNT=0
F OTYPE="SOLUTION","ADDITIVE" D
.S OIIEN=+$P($G(ORDIALOG("B",OTYPE)),U,2) I OIIEN>0 D
..S NUM=0 F S NUM=$O(ORDIALOG(OIIEN,NUM)) Q:NUM'>0 I +$G(ORDIALOG(OIIEN,NUM))>0 D
...S CNT=CNT+1,ARRAY(CNT)=ORDIALOG(OIIEN,NUM)
Q
;
LVROUTES ;
N ARRAY,ROUTES
D BIVOI(.ARRAY)
D IVDOSFRM^ORWDPS33(.ROUTES,.ARRAY,1)
D RTEDISP(.ROUTES)
Q
;
RTEDISP(ROUTES) ;
N CNT
S CNT="" F S CNT=$O(ROUTES(CNT)) Q:CNT'>0 D
.W !,$P($G(ROUTES(CNT)),U,2)
Q
;
IVRTESCR(Y) ;
N ARRAY,ROUTES,VALUE
D BIVOI(.ARRAY)
S VALUE=$$IVQOVAL^ORWDPS33(.ARRAY,Y) I VALUE'="" Q 1
Q 0
;
ROUTECHK ;
N CNT,IEN,ROUTE,VALUE
S RIEN=$P($G(ORDIALOG("B","ROUTE")),U,2) Q:RIEN'>0
S TROUTE=$G(ORDIALOG(RIEN,1)) Q:TROUTE'>0
I $$IVRTESCR(TROUTE)=1 Q
S ORDIALOG(RIEN,1)=""
W !!,"The route defined for this order is an invalid route."
W !,"You will need to define a new route for this order."
Q
;
ENRATE ; -- set display text, help based on IV TYPE
N X,MSG S X=$G(ORIVTYPE),MSG=""
S ORDIALOG(PROMPT,"A")=$S(X="I":"Infuse over time (min): ",1:"Infusion Rate (ml/hr): ")
S MSG="Enter the "_$S(X="I":"number of minutes over which to infuse this medication.",1:"infusion rate, as the number of ml/hr or Text@Number of Labels per day. ")
S ORDIALOG(PROMPT,"?")=MSG,ORDIALOG(PROMPT,"??")=MSG ;p388
I X="I" D
.N RATEI,RATEV,TIME,UNIT
.S RATEI=$P($G(ORDIALOG("B","INFUSION RATE")),U,2) Q:RATEI'>0
.S RATEV=$G(ORDIALOG(RATEI,1)) Q:'$L(RATEV)
.I RATEV'["INFUSE OVER" Q
.S TIME=$P(RATEV," ",3)
.S UNIT=$P(RATEV," ",4)
.I TIME["." Q
.I UNIT="Hours" S TIME=TIME*60
.S ORDIALOG(RATEI,1)=TIME
Q
;
INF ; -- input transform for INFUSION RATE
N ALPHA,CNT,EXIT,FAIL,LDEC,RDEC,TEMP
I $G(ORIVTYPE)="I" D Q
.I X["." W !,"Infuse Over Time must be a whole number." K X Q
.I $L(X)>4 W !,"Infuse Over Time cannot exceed 4 characters for minutes." K X Q
.S FAIL=0
.F CNT=1:1:$L(X) D I FAIL=1 Q
..I ($A($E(X,CNT))<48)!($A($E(X,CNT))>58) S FAIL=1
.I FAIL=1 W !,"Infuse Over Time must be a whole number." K X Q
K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X) Q
I $G(ORIVTYPE)="C" D Q
.S TEMP=$E(X,($L(X)-5),$L(X))
.I X["@",$$UP^XLFSTR(TEMP)=" ML/HR" Q
.S ALPHA=0
.I X'["@",X'["." D I ALPHA=1 K X Q
..F CNT=1:1:$L(X) D I ALPHA=1 Q
...I ($A($E(X,CNT))<48)!($A($E(X,CNT))>58) S ALPHA=1
.S EXIT=0
.I X[".",X'["@" D I EXIT=1 K X Q
..S LDEC=$P(X,"."),RDEC=$P(X,".",2)
..I LDEC="" W !,"Infusion Rate required a leading numeric value." S EXIT=1
..I $L(RDEC)>1 W !,"Infusion Rate cannot exceed one decimal place." S EXIT=1
..S ALPHA=0
..F CNT=1:1:$L(LDEC) D I ALPHA=1 S EXIT=1 Q
...I ($A($E(LDEC,CNT))<48)!($A($E(LDEC,CNT))>58) S ALPHA=1
..I $L(RDEC)=0 Q
..F CNT=1:1:$L(RDEC) D I ALPHA=1 S EXIT=1 Q
...I ($A($E(RDEC,CNT))<48)!($A($E(RDEC,CNT))>58) S ALPHA=1
.D ORINF^PSIVSP Q
; -- assume #minutes for now
K:(X'=+X)!(X<1)!(X>999) X ;range?
Q
;
VALIDAYS(X) ; -- Validate IV duration
N UNITS,X1,X2,Y,I
I X'?1.N." "1.A Q 0
S UNITS="^MIN^HOURS^DAYS^M^H^D^",(X1,X2)=""
F I=1:1:$L(X) S Y=$E(X,I) S:Y?1N X1=X1_Y S:Y?1A X2=X2_$$UP^XLFSTR(Y)
I 'X1 Q 0
I UNITS'[(U_X2_U) Q 0
Q 1
;
VALDURA(X) ;-- Validate IV duration/limitation
K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X) Q
;
IVPSI ;INPUT-TRANSFORM
I $L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) S X="" Q
I $L(X)>1,X[" " W !,"Spaces are not allow in the duration." K X Q
I $E(X)=0 W !,!,"Duration cannot start with a zero." K X Q
I X["." W !,!,"Invalid duration or total volume.",!,"Duration has to be integer value!" S X="" Q
S X=$$UP^XLFSTR(X)
I X["DOSES" D Q
.I $G(ORIVTYPE)'="I" K X W !,"Continuous IV Orders cannot have DOSES as a duration." Q
.I +$P(X,"DOSES")<1,+$P(X,"DOSES")>200000 W !,"Invalid number of Doses.",! K X Q
I (X'?.N1.2A),(X'?.N1".".N1.2A) W !,!,"Invalid duration or total volume.",! S X="" Q
I (X?.N1A) D
. I (X["L")!(X["H")!(X["D") Q
. E W !,!,"Invalid duration or total volume.",! S X="" Q
I (X?.N1".".N1A) D
. I X["L" Q
. E W !,!,"Invalid duration or total volume.",!,"Duration has to be integer value!",! S X="" Q
I (X?.N2A)!(X?.N1".".N2A) D
. I (X["ML")!(X["CC") Q
. E W !,!,"Invalid duration or total volume",! S X="" Q
I X="" K X
Q
;
IVPSI1 ; ASK ON CONDITION
N DURI,DURV,TEMPX
I $G(OROTSCH)=1 Q
S DURI=$P($G(ORDIALOG("B","LIMITATION")),U,2)
I DURI>0 S DURV=$G(ORDIALOG(DURI,1))
I $L(DURV)>1,$E(DURV)="f",DURV["doses" D
.S TEMPX=$P(DURV," ",5)_"DOSES"
.I TEMPX'="",TEMPX'=DURV S ORDIALOG(DURI,1)=TEMPX
N INT,IVTYPE,ONETIME,TYPE,SCH,SCHNAME
D IVDURT($G(ORIVTYPE))
;I $G(ORIVTYPE)'="I" D G IVPS1X
;.W !,!,"Enter the length of administrative time or total volume for IV fluid order followed by ML or CC for milliliters, L for liters, D for days, H for hours to set limitation."
;.W !,"(Examples: 1500ML, 1000CC, 1L, 3D, or 72H)",!
;W !,"This field is optional a value does not need to be entered."
;W !,!,"Enter the length of administrative time or total volume for IV fluid order followed by ML or CC for milliliters, L for liters, D for days, H for hours or DOSES to set limitation."
;W !,"(Examples: 1500ML, 1000CC, 1L, 3D, 72H, or 10DOSES)",!
IVPS1X ;
;W !,"This field is optional a value does not need to be entered."
I 1
Q
;
IVDURT(TYPE) ;
I TYPE'="I" D G IVDURX
.W !,!,"Enter the length of administrative time or total volume for IV fluid order followed by ML or CC for milliliters, L for liters, D for days, H for hours to set limitation."
.W !,"(Examples: 1500ML, 1000CC, 1L, 3D, or 72H)",!
W !,"This field is optional a value does not need to be entered."
W !,!,"Enter the length of administrative time or total volume for IV fluid order followed by ML or CC for milliliters, L for liters, D for days, H for hours or DOSES to set limitation."
W !,"(Examples: 1500ML, 1000CC, 1L, 3D, 72H, or 10DOSES)",!
IVDURX ;
W !,"This field is optional a value does not need to be entered."
Q
;
IVDURH ;
D IVDURT($G(ORIVTYPE))
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCDPSIV 12226 printed Oct 16, 2024@18:28:48 Page 2
ORCDPSIV ;SLC/MKB-Pharmacy IV dialog utilities ;06/17/10
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,38,48,158,195,243,296,280,388,467,499**;Dec 17, 1997;Build 165
+2 ;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference to IVDEA^PSSUTIL1 in ICR #3784
+5 ; Reference to ^PSIVSP in ICR #2945
+6 ; Reference to ^PSJORUT2 in ICR #2402
+7 ; Reference to ^PSSDSAPA in ICR #5504
+8 ; Reference to ^PSSGS0 in ICR #3423
+9 ;
CKSCH ; -- validate schedule [Called from P-S Action]
+1 NEW ORX
SET ORX=ORDIALOG(PROMPT,ORI)
if ORX=$GET(ORESET)
QUIT
KILL ORSD
+2 DO EN^PSSGS0(.ORX,"I")
+3 IF $DATA(ORX)
SET ORDIALOG(PROMPT,ORI)=ORX
QUIT
+4 WRITE $CHAR(7),!,"Enter a standard schedule for administering this medication."
+5 QUIT
ISONETIM(SCH) ;
+1 NEW DUR
+2 IF SCH=""
QUIT 0
+3 KILL ^TMP($JOB,"ORCDPSIV GETSCHTYP")
+4 DO ZERO^PSS51P1(,SCH,"PSJ","O","ORCDPSIV GETSCHTYP")
+5 IF $DATA(^TMP($JOB,"ORCDPSIV GETSCHTYP","B",SCH))
Begin DoDot:1
+6 SET DUR=$$PTR^ORCD("OR GTX DURATION")
+7 IF $GET(ORDIALOG(DUR,1))=""
QUIT
+8 SET ORDIALOG(DUR,1)=""
+9 WRITE !,"IV Orders with a schedule type of one-time cannot have a duration."
+10 WRITE !,"The duration has been deleted from this quick order."
HANG 1
End DoDot:1
QUIT 1
+11 KILL ^TMP($JOB,"ORCDPSIV GETSCHTYP")
+12 QUIT 0
+13 ;
ADDFRD(ORDIALOG,INST,PROMPT) ;
+1 NEW ADDFRIEN,ADDIEN,OI,PSOI,RESULT
+2 SET RESULT=""
+3 IF $GET(ORIVTYPE)'="C"
QUIT RESULT
+4 SET ADDFRIEN=$ORDER(^ORD(101.41,"AB","OR GTX ADDITIVE FREQUENCY",""))
IF 'ADDFRIEN
QUIT RESULT
+5 SET ADDIEN=$ORDER(^ORD(101.41,"AB","OR GTX ADDITIVE",""))
IF 'ADDIEN
QUIT RESULT
+6 SET RESULT=$$RECALL^ORCD(PROMPT,INST)
IF RESULT'=""
QUIT RESULT
+7 SET OI=$GET(ORDIALOG(ADDIEN,INST))
IF OI=""
QUIT RESULT
+8 SET PSOI=+$PIECE($GET(^ORD(101.43,OI,0)),U,2)
IF +PSOI'>0
QUIT RESULT
+9 SET RESULT=$$IV^PSSDSAPA(+PSOI)
+10 SET RESULT=$SELECT(RESULT="A":"All Bags",RESULT=1:"1 Bag/Day",1:"")
+11 QUIT RESULT
+12 ;
ADDFRQC ;
+1 IF $GET(ORIVTYPE)'="C"
QUIT
+2 WRITE !,"Select from the list of the codes below to assign an additive frequency for this additive."
+3 WRITE !,"A = All Bags"
+4 WRITE !,"1 = 1 Bag/Day"
+5 WRITE !,"S = See Comments"
+6 WRITE !
+7 QUIT
ADDFRQI ;
+1 SET X=$$UP^XLFSTR(X)
+2 IF X'="A"
IF X'=1
IF X'="S"
DO ADDFRQC
KILL X
QUIT
+3 IF X="A"
SET X="All Bags"
QUIT
+4 IF X=1
SET X="1 Bag/Day"
QUIT
+5 IF X="S"
SET X="See Comments"
+6 QUIT
+7 ;
PROVIDER ; -- Check provider, if authorized to write med orders
+1 IF $DATA(^XUSEC("OREMAS",DUZ))
IF '$$GET^XPAR("ALL","OR OREMAS MED ORDERS")
WRITE $CHAR(7),!!,"OREMAS key holders may not enter medication orders."
SET ORQUIT=1
QUIT
+2 NEW PS,NAME
SET PS=$GET(^VA(200,+$GET(ORNP),"PS"))
SET NAME=$PIECE($GET(^(20)),U,2)
+3 IF '$LENGTH(NAME)
SET NAME=$PIECE(^VA(200,+$GET(ORNP),0),U)
+4 IF '$PIECE(PS,U)
WRITE $CHAR(7),!!,NAME_" is not authorized to write medication orders!"
SET ORQUIT=1
+5 IF $PIECE(PS,U,4)
IF $$NOW^XLFDT>$P(PS,U,4)
WRITE $CHAR(7),!!,NAME_" is no longer authorized to write medication orders!"
SET ORQUIT=1
+6 IF $GET(ORQUIT)
WRITE !,"You must select another provider to continue.",!
SET PS=$$MEDPROV
IF PS
SET ORXNP=ORNP
SET ORNP=PS
KILL ORQUIT
+7 QUIT
+8 ;
MEDPROV() ; -- Return ordering med provider
+1 NEW X,Y,D,DIC
+2 SET DIC=200
SET DIC(0)="AEQ"
SET DIC("A")="Select PROVIDER: "
SET D="AK.PROVIDER"
+3 SET DIC("S")="I $P($G(^(""PS"")),U),'$P(^(""PS""),U,4)!($P(^(""PS""),U,4)>$$NOW^XLFDT)"
+4 DO IX^DIC
if Y>0
SET Y=+Y
IF Y'>0
SET Y="^"
+5 QUIT Y
+6 ;
CHANGED(TYPE) ; -- Kill dependent values when OI changes
+1 NEW PROMPTS,NAME,PTR,P,I
+2 if '$LENGTH($GET(TYPE))
QUIT
SET PROMPTS=""
+3 if TYPE="B"
SET PROMPTS="VOLUME"
+4 if TYPE="A"
SET PROMPTS="STRENGTH PSIV^UNITS"
+5 IF TYPE="T"
Begin DoDot:1
+6 SET PROMPTS="INFUSION RATE^SCHEDULE^ADDITIVE FREQUENCY"
+7 SET PTR=$ORDER(^ORD(101.41,"AB","OR GTX DURATION",""))
if 'PTR
QUIT
+8 IF $GET(ORDIALOG(PTR,1))["DOSES"
SET PROMPTS=PROMPTS_U_"DURATION"
End DoDot:1
+9 ;
+10 FOR P=1:1:$LENGTH(PROMPTS,U)
SET NAME=$PIECE(PROMPTS,U,P)
Begin DoDot:1
+11 SET PTR=$ORDER(^ORD(101.41,"AB","OR GTX "_NAME,0))
if 'PTR
QUIT
+12 KILL ORDIALOG(PTR,ORI)
+13 ;S I=0 F S I=$O(ORDIALOG(PTR,I)) Q:I'>0 K ORDIALOG(PTR,I)
+14 KILL ORDIALOG(PTR,"LIST")
End DoDot:1
+15 QUIT
+16 ;
INACTIVE(TYPE) ; -- Check OI inactive date
+1 NEW OI,X,I,PSOI,DEA,EXIT,ORDEA
if $GET(TYPE)'="A"
SET TYPE="S"
+2 SET OI=+$GET(ORDIALOG(PROMPT,INST))
if OI'>0
QUIT
+3 ;inactive
IF $GET(^ORD(101.43,OI,.1))
IF ^(.1)'>$$NOW^XLFDT
Begin DoDot:1
+4 SET X=$SELECT(TYPE="A":"additive",1:"solution")
SET ORQUIT=1
+5 WRITE $CHAR(7),!,"This "_X_" may not be ordered anymore. Please select another."
End DoDot:1
QUIT
+6 SET I=$SELECT(TYPE="A":4,1:3)
IF '$PIECE($GET(^ORD(101.43,OI,"PS")),U,I)
Begin DoDot:1
+7 SET X=$SELECT(TYPE="A":"an additive",1:"a solution")
SET ORQUIT=1
+8 WRITE $CHAR(7),!,"This item may not be ordered as "_X_"."
End DoDot:1
QUIT
+9 SET EXIT=$$INPT^ORCD
IF EXIT=0
DO ROUTECHK
QUIT
+10 ;DBIA #3784
if '$LENGTH($TEXT(IVDEA^PSSUTIL1))
QUIT
+11 SET PSOI=+$PIECE($GET(^ORD(101.43,OI,0)),U,2)
+12 SET DEA=$$IVDEA^PSSUTIL1(PSOI,TYPE)
IF DEA>0
Begin DoDot:1
+13 ;*499 - Support multiple DEA numbers for a provider
+14 IF $GET(ORNP)
SET ORDEA=$$PRDEA^XUSER(ORNP)
IF '$LENGTH(ORDEA)
IF '$LENGTH($PIECE($GET(^VA(200,+ORNP,"PS")),U,3))
WRITE $CHAR(7),!,$PIECE($GET(^(0)),U)_" must have a DEA# or VA# to order this drug!"
SET ORQUIT=1
QUIT
+15 IF DEA=1
WRITE $CHAR(7),!,"This order will require a wet signature!"
End DoDot:1
if $GET(ORQUIT)
QUIT
+16 DO ROUTECHK
+17 QUIT
+18 ;
VOLUME ; -- get allowable volumes for solution
+1 NEW PSOI,ORY,CNT,I,XORY
KILL ORDIALOG(PROMPT,"LIST")
+2 SET PSOI=+$PIECE($GET(^ORD(101.43,+$$VAL^ORCD("SOLUTION",INST),0)),U,2)_"B"
+3 DO ENVOL^PSJORUT2(PSOI,.ORY)
if 'ORY
QUIT
+4 ;S (I,CNT)=0 F S I=$O(ORY(I)) Q:I'>0 S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",+ORY(I))=+ORY(I)
+5 SET (I,CNT)=0
FOR
SET I=$ORDER(ORY(I))
if I'>0
QUIT
Begin DoDot:1
+6 SET CNT=CNT+1
+7 SET XORY(I)=+ORY(I)
IF XORY(I)<1
IF $EXTRACT(XORY(I),1,2)'="0."
SET XORY(I)=0_XORY(I)
+8 SET ORDIALOG(PROMPT,"LIST",XORY(I))=XORY(I)
End DoDot:1
+9 SET ORDIALOG(PROMPT,"LIST")=CNT_"^1"
+10 QUIT
+11 ;
UNITS ; -- get allowable units for current additive
+1 NEW PSOI,ORY,I,UNITS
+2 SET PSOI=+$PIECE(^ORD(101.43,+ORDIALOG($$PTR^ORCD("OR GTX ADDITIVE"),INST),0),U,2)_"A"
+3 DO ENVOL^PSJORUT2(PSOI,.ORY)
+4 SET I=$ORDER(ORY(0))
if 'I
QUIT
SET UNITS=$PIECE($GET(ORY(I)),U,2)
+5 SET ORDIALOG($$PTR^ORCD("OR GTX UNITS"),INST)=UNITS
+6 WRITE !," (Units for this additive are "_UNITS_")"
+7 QUIT
+8 ;
PREMIX() ; -- Returns 1 or 0, if IV base is a premix solution
+1 NEW BASE,PS,I,Y
+2 SET BASE=$$PTR^ORCD("OR GTX ORDERABLE ITEM")
SET Y=0
+3 SET I=0
FOR
SET I=$ORDER(ORDIALOG(BASE,I))
if I'>0
QUIT
Begin DoDot:1
+4 SET PS=$GET(^ORD(101.43,+$GET(ORDIALOG(BASE,I)),"PS"))
+5 IF $PIECE(PS,U,3)&($PIECE(PS,U,4))
SET Y=1
End DoDot:1
if Y
QUIT
+6 QUIT Y
+7 ;
IVRTEENT ;
+1 NEW ARRAY,DIR,RIEN,TROUTE
+2 IF ORTYPE'="Z"
QUIT
+3 SET RIEN=$PIECE($GET(ORDIALOG("B","ROUTE")),U,2)
if RIEN'>0
QUIT
+4 SET EXIT=0
SET TROUTE=$GET(ORDIALOG(RIEN,1))
if TROUTE'>0
QUIT
+5 IF $$IVRTESCR(TROUTE)=1
QUIT
+6 SET ORDIALOG(RIEN,1)=""
+7 WRITE !!,"The selected route is not a valid route for this order."
+8 WRITE !,"Select a new route for this order from the list of routes below."
+9 DO RTEDISP(.ARRAY)
+10 QUIT
+11 ;
BIVOI(ARRAY) ;
+1 NEW CNT,NUM,OIIEN,OTYPE
+2 SET CNT=0
+3 FOR OTYPE="SOLUTION","ADDITIVE"
Begin DoDot:1
+4 SET OIIEN=+$PIECE($GET(ORDIALOG("B",OTYPE)),U,2)
IF OIIEN>0
Begin DoDot:2
+5 SET NUM=0
FOR
SET NUM=$ORDER(ORDIALOG(OIIEN,NUM))
if NUM'>0
QUIT
IF +$GET(ORDIALOG(OIIEN,NUM))>0
Begin DoDot:3
+6 SET CNT=CNT+1
SET ARRAY(CNT)=ORDIALOG(OIIEN,NUM)
End DoDot:3
End DoDot:2
End DoDot:1
+7 QUIT
+8 ;
LVROUTES ;
+1 NEW ARRAY,ROUTES
+2 DO BIVOI(.ARRAY)
+3 DO IVDOSFRM^ORWDPS33(.ROUTES,.ARRAY,1)
+4 DO RTEDISP(.ROUTES)
+5 QUIT
+6 ;
RTEDISP(ROUTES) ;
+1 NEW CNT
+2 SET CNT=""
FOR
SET CNT=$ORDER(ROUTES(CNT))
if CNT'>0
QUIT
Begin DoDot:1
+3 WRITE !,$PIECE($GET(ROUTES(CNT)),U,2)
End DoDot:1
+4 QUIT
+5 ;
IVRTESCR(Y) ;
+1 NEW ARRAY,ROUTES,VALUE
+2 DO BIVOI(.ARRAY)
+3 SET VALUE=$$IVQOVAL^ORWDPS33(.ARRAY,Y)
IF VALUE'=""
QUIT 1
+4 QUIT 0
+5 ;
ROUTECHK ;
+1 NEW CNT,IEN,ROUTE,VALUE
+2 SET RIEN=$PIECE($GET(ORDIALOG("B","ROUTE")),U,2)
if RIEN'>0
QUIT
+3 SET TROUTE=$GET(ORDIALOG(RIEN,1))
if TROUTE'>0
QUIT
+4 IF $$IVRTESCR(TROUTE)=1
QUIT
+5 SET ORDIALOG(RIEN,1)=""
+6 WRITE !!,"The route defined for this order is an invalid route."
+7 WRITE !,"You will need to define a new route for this order."
+8 QUIT
+9 ;
ENRATE ; -- set display text, help based on IV TYPE
+1 NEW X,MSG
SET X=$GET(ORIVTYPE)
SET MSG=""
+2 SET ORDIALOG(PROMPT,"A")=$SELECT(X="I":"Infuse over time (min): ",1:"Infusion Rate (ml/hr): ")
+3 SET MSG="Enter the "_$SELECT(X="I":"number of minutes over which to infuse this medication.",1:"infusion rate, as the number of ml/hr or Text@Number of Labels per day. ")
+4 ;p388
SET ORDIALOG(PROMPT,"?")=MSG
SET ORDIALOG(PROMPT,"??")=MSG
+5 IF X="I"
Begin DoDot:1
+6 NEW RATEI,RATEV,TIME,UNIT
+7 SET RATEI=$PIECE($GET(ORDIALOG("B","INFUSION RATE")),U,2)
if RATEI'>0
QUIT
+8 SET RATEV=$GET(ORDIALOG(RATEI,1))
if '$LENGTH(RATEV)
QUIT
+9 IF RATEV'["INFUSE OVER"
QUIT
+10 SET TIME=$PIECE(RATEV," ",3)
+11 SET UNIT=$PIECE(RATEV," ",4)
+12 IF TIME["."
QUIT
+13 IF UNIT="Hours"
SET TIME=TIME*60
+14 SET ORDIALOG(RATEI,1)=TIME
End DoDot:1
+15 QUIT
+16 ;
INF ; -- input transform for INFUSION RATE
+1 NEW ALPHA,CNT,EXIT,FAIL,LDEC,RDEC,TEMP
+2 IF $GET(ORIVTYPE)="I"
Begin DoDot:1
+3 IF X["."
WRITE !,"Infuse Over Time must be a whole number."
KILL X
QUIT
+4 IF $LENGTH(X)>4
WRITE !,"Infuse Over Time cannot exceed 4 characters for minutes."
KILL X
QUIT
+5 SET FAIL=0
+6 FOR CNT=1:1:$LENGTH(X)
Begin DoDot:2
+7 IF ($ASCII($EXTRACT(X,CNT))<48)!($ASCII($EXTRACT(X,CNT))>58)
SET FAIL=1
End DoDot:2
IF FAIL=1
QUIT
+8 IF FAIL=1
WRITE !,"Infuse Over Time must be a whole number."
KILL X
QUIT
End DoDot:1
QUIT
+9 if $LENGTH(X)<1!($LENGTH(X)>30)!(X["""")!($ASCII(X)=45)
KILL X
IF '$DATA(X)
QUIT
+10 IF $GET(ORIVTYPE)="C"
Begin DoDot:1
+11 SET TEMP=$EXTRACT(X,($LENGTH(X)-5),$LENGTH(X))
+12 IF X["@"
IF $$UP^XLFSTR(TEMP)=" ML/HR"
QUIT
+13 SET ALPHA=0
+14 IF X'["@"
IF X'["."
Begin DoDot:2
+15 FOR CNT=1:1:$LENGTH(X)
Begin DoDot:3
+16 IF ($ASCII($EXTRACT(X,CNT))<48)!($ASCII($EXTRACT(X,CNT))>58)
SET ALPHA=1
End DoDot:3
IF ALPHA=1
QUIT
End DoDot:2
IF ALPHA=1
KILL X
QUIT
+17 SET EXIT=0
+18 IF X["."
IF X'["@"
Begin DoDot:2
+19 SET LDEC=$PIECE(X,".")
SET RDEC=$PIECE(X,".",2)
+20 IF LDEC=""
WRITE !,"Infusion Rate required a leading numeric value."
SET EXIT=1
+21 IF $LENGTH(RDEC)>1
WRITE !,"Infusion Rate cannot exceed one decimal place."
SET EXIT=1
+22 SET ALPHA=0
+23 FOR CNT=1:1:$LENGTH(LDEC)
Begin DoDot:3
+24 IF ($ASCII($EXTRACT(LDEC,CNT))<48)!($ASCII($EXTRACT(LDEC,CNT))>58)
SET ALPHA=1
End DoDot:3
IF ALPHA=1
SET EXIT=1
QUIT
+25 IF $LENGTH(RDEC)=0
QUIT
+26 FOR CNT=1:1:$LENGTH(RDEC)
Begin DoDot:3
+27 IF ($ASCII($EXTRACT(RDEC,CNT))<48)!($ASCII($EXTRACT(RDEC,CNT))>58)
SET ALPHA=1
End DoDot:3
IF ALPHA=1
SET EXIT=1
QUIT
End DoDot:2
IF EXIT=1
KILL X
QUIT
+28 DO ORINF^PSIVSP
QUIT
End DoDot:1
QUIT
+29 ; -- assume #minutes for now
+30 ;range?
if (X'=+X)!(X<1)!(X>999)
KILL X
+31 QUIT
+32 ;
VALIDAYS(X) ; -- Validate IV duration
+1 NEW UNITS,X1,X2,Y,I
+2 IF X'?1.N." "1.A
QUIT 0
+3 SET UNITS="^MIN^HOURS^DAYS^M^H^D^"
SET (X1,X2)=""
+4 FOR I=1:1:$LENGTH(X)
SET Y=$EXTRACT(X,I)
if Y?1N
SET X1=X1_Y
if Y?1A
SET X2=X2_$$UP^XLFSTR(Y)
+5 IF 'X1
QUIT 0
+6 IF UNITS'[(U_X2_U)
QUIT 0
+7 QUIT 1
+8 ;
VALDURA(X) ;-- Validate IV duration/limitation
+1 if $LENGTH(X)<1!($LENGTH(X)>30)!(X["""")!($ASCII(X)=45)
KILL X
IF '$DATA(X)
QUIT
+2 ;
IVPSI ;INPUT-TRANSFORM
+1 IF $LENGTH(X)<1!($LENGTH(X)>30)!(X["""")!($ASCII(X)=45)
SET X=""
QUIT
+2 IF $LENGTH(X)>1
IF X[" "
WRITE !,"Spaces are not allow in the duration."
KILL X
QUIT
+3 IF $EXTRACT(X)=0
WRITE !,!,"Duration cannot start with a zero."
KILL X
QUIT
+4 IF X["."
WRITE !,!,"Invalid duration or total volume.",!,"Duration has to be integer value!"
SET X=""
QUIT
+5 SET X=$$UP^XLFSTR(X)
+6 IF X["DOSES"
Begin DoDot:1
+7 IF $GET(ORIVTYPE)'="I"
KILL X
WRITE !,"Continuous IV Orders cannot have DOSES as a duration."
QUIT
+8 IF +$PIECE(X,"DOSES")<1
IF +$PIECE(X,"DOSES")>200000
WRITE !,"Invalid number of Doses.",!
KILL X
QUIT
End DoDot:1
QUIT
+9 IF (X'?.N1.2A)
IF (X'?.N1".".N1.2A)
WRITE !,!,"Invalid duration or total volume.",!
SET X=""
QUIT
+10 IF (X?.N1A)
Begin DoDot:1
+11 IF (X["L")!(X["H")!(X["D")
QUIT
+12 IF '$TEST
WRITE !,!,"Invalid duration or total volume.",!
SET X=""
QUIT
End DoDot:1
+13 IF (X?.N1".".N1A)
Begin DoDot:1
+14 IF X["L"
QUIT
+15 IF '$TEST
WRITE !,!,"Invalid duration or total volume.",!,"Duration has to be integer value!",!
SET X=""
QUIT
End DoDot:1
+16 IF (X?.N2A)!(X?.N1".".N2A)
Begin DoDot:1
+17 IF (X["ML")!(X["CC")
QUIT
+18 IF '$TEST
WRITE !,!,"Invalid duration or total volume",!
SET X=""
QUIT
End DoDot:1
+19 IF X=""
KILL X
+20 QUIT
+21 ;
IVPSI1 ; ASK ON CONDITION
+1 NEW DURI,DURV,TEMPX
+2 IF $GET(OROTSCH)=1
QUIT
+3 SET DURI=$PIECE($GET(ORDIALOG("B","LIMITATION")),U,2)
+4 IF DURI>0
SET DURV=$GET(ORDIALOG(DURI,1))
+5 IF $LENGTH(DURV)>1
IF $EXTRACT(DURV)="f"
IF DURV["doses"
Begin DoDot:1
+6 SET TEMPX=$PIECE(DURV," ",5)_"DOSES"
+7 IF TEMPX'=""
IF TEMPX'=DURV
SET ORDIALOG(DURI,1)=TEMPX
End DoDot:1
+8 NEW INT,IVTYPE,ONETIME,TYPE,SCH,SCHNAME
+9 DO IVDURT($GET(ORIVTYPE))
+10 ;I $G(ORIVTYPE)'="I" D G IVPS1X
+11 ;.W !,!,"Enter the length of administrative time or total volume for IV fluid order followed by ML or CC for milliliters, L for liters, D for days, H for hours to set limitation."
+12 ;.W !,"(Examples: 1500ML, 1000CC, 1L, 3D, or 72H)",!
+13 ;W !,"This field is optional a value does not need to be entered."
+14 ;W !,!,"Enter the length of administrative time or total volume for IV fluid order followed by ML or CC for milliliters, L for liters, D for days, H for hours or DOSES to set limitation."
+15 ;W !,"(Examples: 1500ML, 1000CC, 1L, 3D, 72H, or 10DOSES)",!
IVPS1X ;
+1 ;W !,"This field is optional a value does not need to be entered."
+2 IF 1
+3 QUIT
+4 ;
IVDURT(TYPE) ;
+1 IF TYPE'="I"
Begin DoDot:1
+2 WRITE !,!,"Enter the length of administrative time or total volume for IV fluid order followed by ML or CC for milliliters, L for liters, D for days, H for hours to set limitation."
+3 WRITE !,"(Examples: 1500ML, 1000CC, 1L, 3D, or 72H)",!
End DoDot:1
GOTO IVDURX
+4 WRITE !,"This field is optional a value does not need to be entered."
+5 WRITE !,!,"Enter the length of administrative time or total volume for IV fluid order followed by ML or CC for milliliters, L for liters, D for days, H for hours or DOSES to set limitation."
+6 WRITE !,"(Examples: 1500ML, 1000CC, 1L, 3D, 72H, or 10DOSES)",!
IVDURX ;
+1 WRITE !,"This field is optional a value does not need to be entered."
+2 QUIT
+3 ;
IVDURH ;
+1 DO IVDURT($GET(ORIVTYPE))
+2 QUIT
+3 ;
