- 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 Feb 18, 2025@23:54:46 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 ;