- ORWDPS33 ;SLC/KCM - Pharmacy Calls for GUI Dialog ;Aug 05, 2022@12:24:43
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**243,280,350,405**;Dec 17, 1997;Build 211
- ;Per VHA Directive 6402, this routine should not be modified.
- ;This routine move several RPCs from ORWDPS32 because of the routine size
- ; Reference to DSUP^PSOSIGDS in ICR #3278
- ;
- COMPLOC(ORY,ORID,LOC) ;
- S ORY=0
- I LOC'=+$P($G(^OR(100,+ORID,0)),U,10) S ORY=1
- Q
- DOSES(LST,OI) ; return doses for an orderable item - TEST ONLY
- N ORTMP,ORI,ORJ,ILST,LSTA,NDF,ORWDRG,VAPN,X,PSTYPE S PSTYPE="O"
- D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP)
- S ORI=0 F S ORI=$O(ORTMP(ORI)) Q:'ORI S ORWDRG=+ORTMP(ORI) D
- . K ^TMP($J,"ORWDPS32 DRUG")
- . D NDF^PSS50(+ORWDRG,,,,,"ORWDPS32 DRUG")
- . S VAPN=$P($G(^TMP($J,"ORWDPS32 DRUG",+ORWDRG,22)),U),NDF=$P($G(^TMP($J,"ORWDPS32 DRUG",+ORWDRG,20)),U)
- . S X=$$DFSU^PSNAPIS(NDF,VAPN)
- . S LSTA($P(X,U,4),$P(X,U,6))=""
- . I +$P(X,U,4)=$P(X,U,4) S LSTA($P(X,U,4)*2,$P(X,U,6))=""
- K ^TMP($J,"ORWDPS32 DRUG")
- S ORI="",ILST=0 F S ORI=$O(LSTA(ORI)) Q:ORI="" D
- . S ORJ="" F S ORJ=$O(LSTA(ORI,ORJ)) Q:ORJ="" D
- . . S ILST=ILST+1,LST(ILST)=ORI_" "_ORJ
- Q
- ;
- DRUGMSG(VAL,IEN) ; return any message associated with a dispense drug
- N X S X=$$ENDCM^PSJORUTL(IEN)
- S VAL=$P(X,U,2)_U_$P(X,U,4)
- Q
- ;
- FORMALT(ORLST,IEN,PSTYPE) ; return a list of formulary alternatives
- D ENRFA^PSJORUTL(IEN,PSTYPE,.ORLST)
- N I,OI S I=0 F S I=$O(ORLST(I)) Q:'I D
- . S OI=+$O(^ORD(101.43,"ID",+$P(ORLST(I),U,4)_";99PSP",0))
- . S $P(ORLST(I),U,4)=OI I OI S $P(ORLST(I),U,5)=$P(^ORD(101.43,OI,0),U)
- Q
- ;
- GETADDFR(ORY,OIIEN) ;
- N PSOI,TEMP
- S ORY=""
- S PSOI=+$P($G(^ORD(101.43,OIIEN,0)),U,2)
- S TEMP=$$IV^PSSDSAPA(PSOI)
- S ORY=$$ADDFRQCV^ORMBLDP1(TEMP,"I")
- Q
- ;
- ISVALIV(RESULT,ORID,ACTION) ;
- N ARRAY,CNT,ID,IVD,CLIVD,NUM,ORDERID,OUTPUT,ROUTE,ROUTEID,TYPE
- S TYPE=$S(ACTION="XFR":"transfered",ACTION="RN":"renewed",1:"copied")
- S IVD=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE",""))
- S CLIVD=$O(^ORD(101.41,"B","CLINIC OR PAT FLUID OE",""))
- I IVD=0,CLIVD=0 Q
- I +$P($G(^OR(100,+ORID,0)),U,5)'=IVD,+$P($G(^OR(100,+ORID,0)),U,5)'=CLIVD Q
- S ORDERID="",ROUTEID="",CNT=0
- F S ORDERID=$O(^OR(100,+ORID,4.5,"ID","ORDERABLE",ORDERID)) Q:ORDERID'>0 D
- .I +$G(^OR(100,+ORID,4.5,ORDERID,1))'>0 Q
- .S CNT=CNT+1,ARRAY(CNT)=^OR(100,+ORID,4.5,ORDERID,1)
- S ROUTEID=+$O(^OR(100,+ORID,4.5,"ID","ROUTE","")) I ROUTEID'>0 D Q
- .S RESULT="This order contains an invalid route. It cannot be "_TYPE_"."
- S ROUTE=+$G(^OR(100,+ORID,4.5,ROUTEID,1)) I ROUTE'>0 D Q
- .S RESULT="This order contains an invalid route. It cannot be "_TYPE_"."
- S OUTPUT=$$IVQOVAL(.ARRAY,ROUTE) I OUTPUT="" D
- .;S TYPE=$S(ACTION="XFR":"transfered",ACTION="RN":"renewed",1:"copied")
- .S RESULT="This order contains an invalid route. It cannot be "_TYPE_"."
- I RESULT'="" Q
- N IVTYPE,IVTYPEID,INFUSEID,INFUSE
- S IVTYPEID=+$O(^OR(100,+ORID,4.5,"ID","TYPE","")) I IVTYPEID'>0 D Q
- .S RESULT="This order contains an invalid IV Type. It cannot be "_TYPE_"."
- S IVTYPE=$G(^OR(100,+ORID,4.5,IVTYPEID,1)) I IVTYPE="" D Q
- .S RESULT="This order contains an invalid IV Type. It cannot be "_TYPE_"."
- S INFUSEID=+$O(^OR(100,+ORID,4.5,"ID","RATE","")) Q:INFUSEID'>0
- S INFUSE=$G(^OR(100,+ORID,4.5,INFUSEID,1)) Q:INFUSE=""
- I $$VALINF^ORWDXM3(IVTYPE,INFUSE)=0 D
- .;S TYPE=$S(ACTION="XFR":"transfered",ACTION="RN":"renewed",1:"copied")
- .S RESULT="This order contains an invalid infusion rate. It cannot be "_TYPE_"."
- ;//AGP IV ADDITIVE FREQUENCY
- I IVTYPE="C",ACTION="RN" D
- .N ADDCNT,ADDIEN,ADDFCNT,SUB
- .S ADDIEN=$$PTR^ORCD("OR GTX ADDITIVE")
- .S ADDCNT=0,ADDFCNT=0,SUB=0
- .F S SUB=$O(^OR(100,+ORID,4.5,"ID","ORDERABLE",SUB)) Q:SUB'>0 D
- ..I $P($G(^OR(100,+ORID,4.5,SUB,0)),U,2)'=ADDIEN Q
- ..S ADDCNT=ADDCNT+1
- .S SUB=0
- .F S SUB=$O(^OR(100,+ORID,4.5,"ID","ADDFREQ",SUB)) Q:SUB'>0 S ADDFCNT=ADDFCNT+1
- .I ADDCNT'=ADDFCNT S RESULT="This order does not contain the same number of values for the Additives and the IV Additive Frequency prompts. It cannot be renewed."
- Q
- ;
- IVQOVAL(ARRAY,ROUTE) ;
- N CNT,RARR,RESULT
- S RESULT=""
- D IVDOSFRM(.RARR,.ARRAY,1)
- S CNT="" F S CNT=$O(RARR(CNT)) Q:CNT'>0!(RESULT'="") D
- .I $P(RARR(CNT),U)=ROUTE S RESULT=RARR(CNT) Q
- Q RESULT
- ;
- IVDOSFRM(LST,ORDERIDS,ALLIV) ;
- N ORARRAY,CNT,CNT1,OI,POI
- S OI="",CNT=0,CNT1=0
- F S OI=$O(ORDERIDS(OI)) Q:OI'>0 D
- .S POI=+$P($G(^ORD(101.43,$G(ORDERIDS(OI)),0)),U,2) Q:POI'>0
- .S CNT=CNT+1
- .S ORARRAY(CNT)=POI
- I CNT=0 Q
- S ORARRAY(0)=CNT
- D START1^PSSJORDF(.ORARRAY,ALLIV)
- S CNT="" F S CNT=$O(ORARRAY(CNT)) Q:CNT'>0 D
- .S CNT1=CNT1+1,LST(CNT1)=$G(ORARRAY(CNT))
- ;this temp should be killed by Pharmacy. This will be removed once
- ;Pharmacy send an update
- K ^TMP("PSJMR",$J)
- Q
- ;
- IVIND(LST,ORDERIDS) ;*405-IND
- N CNT,OI,POI,LST1,LST2,TEXT
- S OI=0
- F S OI=$O(ORDERIDS(OI)) Q:'OI D
- .S POI=+$P($G(^ORD(101.43,ORDERIDS(OI),0)),U,2) Q:'POI
- .K LST1
- .D INDICAT2^ORWDPS2(.LST1,POI)
- .Q:'$D(LST1)
- .S CNT=0 F S CNT=$O(LST1(CNT)) Q:'CNT D
- ..S TEXT="i"_$E(LST1(CNT),2,99)
- ..S LST2(TEXT)=""
- Q:'$D(LST2)
- S CNT=0,OI="" F S OI=$O(LST2(OI)) Q:OI="" S CNT=CNT+1,LST(CNT)=OI
- Q
- ;
- ISSPLY(VAL,IEN) ; return true if orderable item is a supply
- S VAL=0
- I $P($G(^ORD(101.43,IEN,"PS")),U,5)=1 S VAL=1
- Q
- IVAMT(VAL,OI,ORWTYP) ; return UNITS^AMOUNT |^AMOUNT^AMOUNT...| for IV soln
- N I,PSOI,ORWY,AMT
- S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2)_ORWTYP,VAL=""
- D ENVOL^PSJORUT2(PSOI,.ORWY)
- I ORWTYP="B" D
- . S I=0 F S I=$O(ORWY(I)) Q:I'>0 S AMT(+ORWY(I))="" D
- . . I ORWY(I)<1 D ;SBR
- . . . K AMT(+ORWY(I))
- . . . S AMT(0_+ORWY(I))=""
- . S AMT=0,VAL="ML" F S AMT=$O(AMT(AMT)) Q:AMT'>0 S VAL=VAL_U_AMT
- I ORWTYP="A" D
- . S I=+$O(ORWY(0)) S VAL=$P($G(ORWY(I)),U,2)
- . I '$L(VAL) S VAL="ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM^MMOL"
- Q
- ;
- MEDISIV(VAL,IEN) ; return true if orderable item is IV medication
- S VAL=0
- I $P($G(^ORD(101.43,IEN,"PS")),U)=2 S VAL=1
- Q
- ;
- SCSTS(VAL,ORVP,ORDRUG) ; return service connected eligibility for patient
- N ORWP94 S ORWP94=$O(^ORD(101.41,"AB","PS MEDS",0))>0
- I $L($T(SC^PSOCP)),$$SC^PSOCP(+ORVP,+$G(ORDRUG)) S VAL=0 G XSCSTS
- I 'ORWP94,(+$$RXST^IBARXEU(+ORVP)>0) S VAL=0 G XSCSTS
- S VAL=1
- XSCSTS Q
- ;
- VALQTY(OK,X) ; validate a quantity, return 1 if valid, 0 if not
- ; to be compatible with LM, make sure X is integer from 1 to 240
- ; this is based on the input transform from 52,7
- K:(+X'>0)!(+X>99999999)!(X'?.8N.1".".2N)!($L(X)>12) X
- S OK=$S($D(X):1,1:0)
- Q
- ;
- VALRATE(VAL,X) ; return "1" (true) if IV rate text is valid
- I $E($RE($$UPPER^ORWDPS32(X)),1,5)="RH/LM" S X=$E(X,1,$L(X)-5)
- S X=$$TRIM^ORWDPS32(X)
- D ORINF^PSIVSP S VAL=$S($D(X)>0:1,1:0)_U_$G(X)
- Q
- VALSCH(OK,X,PSTYPE) ; validate a schedule, return 1 if valid, 0 if not
- I '$L($T(EN^PSSGSGUI)) S OK=-1 Q
- I $E($T(EN^PSSGSGUI),1,4)="EN(X" D
- . N ORX S ORX=$G(X) D EN^PSSGSGUI(.ORX,$G(PSTYPE,"I"))
- . K X S:$D(ORX) X=ORX
- E D
- . D EN^PSSGSGUI
- S OK=$S($D(X):1,1:0)
- Q
- ;
- CLZDS(VAL,PAT,DRG,DSUP,OI) ; return the days supply for a given cloz patient
- ; PAT=Patient DFN, DRG=Drug IEN, DSUP=Days Supply to validate, OI=Orderable Item IEN
- ; VAL=DISPENCE FREQUENCY of the patient in file 603.01
- S VAL=0
- I '$G(PAT)!('$G(DRG))!('$G(DSUP))!('$G(OI)) Q
- N ORWX,ORDFR,MSG
- S ORWX("PATIENT")=PAT,ORWX("DRUG")=DRG,ORWX("OI")=OI
- D DSUP^PSOSIGDS(.ORWX)
- S ORDFR=$G(ORWX("DAYS SUPPLY"))
- Q:'ORDFR
- I DSUP'>ORDFR,("^7^14^28^"[("^"_DSUP_"^")) S VAL=1 Q
- S MSG="Patient eligibility for this medication will only allow a Days Supply of "
- I ORDFR=28 S VAL="0^"_MSG_"28 days with 0 refills, 14 days with up to 1 refill, or 7 days with up to 3 refills." Q
- I ORDFR=14 S VAL="0^"_MSG_"14 days with 0 refills, or 7 days with up to 1 refill." Q
- I ORDFR=7 S VAL="0^"_MSG_"7 with 0 refills."
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWDPS33 7920 printed Jan 18, 2025@03:36:53 Page 2
- ORWDPS33 ;SLC/KCM - Pharmacy Calls for GUI Dialog ;Aug 05, 2022@12:24:43
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**243,280,350,405**;Dec 17, 1997;Build 211
- +2 ;Per VHA Directive 6402, this routine should not be modified.
- +3 ;This routine move several RPCs from ORWDPS32 because of the routine size
- +4 ; Reference to DSUP^PSOSIGDS in ICR #3278
- +5 ;
- COMPLOC(ORY,ORID,LOC) ;
- +1 SET ORY=0
- +2 IF LOC'=+$PIECE($GET(^OR(100,+ORID,0)),U,10)
- SET ORY=1
- +3 QUIT
- DOSES(LST,OI) ; return doses for an orderable item - TEST ONLY
- +1 NEW ORTMP,ORI,ORJ,ILST,LSTA,NDF,ORWDRG,VAPN,X,PSTYPE
- SET PSTYPE="O"
- +2 DO ENDD^PSJORUTL("^^^"_+$PIECE($GET(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP)
- +3 SET ORI=0
- FOR
- SET ORI=$ORDER(ORTMP(ORI))
- if 'ORI
- QUIT
- SET ORWDRG=+ORTMP(ORI)
- Begin DoDot:1
- +4 KILL ^TMP($JOB,"ORWDPS32 DRUG")
- +5 DO NDF^PSS50(+ORWDRG,,,,,"ORWDPS32 DRUG")
- +6 SET VAPN=$PIECE($GET(^TMP($JOB,"ORWDPS32 DRUG",+ORWDRG,22)),U)
- SET NDF=$PIECE($GET(^TMP($JOB,"ORWDPS32 DRUG",+ORWDRG,20)),U)
- +7 SET X=$$DFSU^PSNAPIS(NDF,VAPN)
- +8 SET LSTA($PIECE(X,U,4),$PIECE(X,U,6))=""
- +9 IF +$PIECE(X,U,4)=$PIECE(X,U,4)
- SET LSTA($PIECE(X,U,4)*2,$PIECE(X,U,6))=""
- End DoDot:1
- +10 KILL ^TMP($JOB,"ORWDPS32 DRUG")
- +11 SET ORI=""
- SET ILST=0
- FOR
- SET ORI=$ORDER(LSTA(ORI))
- if ORI=""
- QUIT
- Begin DoDot:1
- +12 SET ORJ=""
- FOR
- SET ORJ=$ORDER(LSTA(ORI,ORJ))
- if ORJ=""
- QUIT
- Begin DoDot:2
- +13 SET ILST=ILST+1
- SET LST(ILST)=ORI_" "_ORJ
- End DoDot:2
- End DoDot:1
- +14 QUIT
- +15 ;
- DRUGMSG(VAL,IEN) ; return any message associated with a dispense drug
- +1 NEW X
- SET X=$$ENDCM^PSJORUTL(IEN)
- +2 SET VAL=$PIECE(X,U,2)_U_$PIECE(X,U,4)
- +3 QUIT
- +4 ;
- FORMALT(ORLST,IEN,PSTYPE) ; return a list of formulary alternatives
- +1 DO ENRFA^PSJORUTL(IEN,PSTYPE,.ORLST)
- +2 NEW I,OI
- SET I=0
- FOR
- SET I=$ORDER(ORLST(I))
- if 'I
- QUIT
- Begin DoDot:1
- +3 SET OI=+$ORDER(^ORD(101.43,"ID",+$PIECE(ORLST(I),U,4)_";99PSP",0))
- +4 SET $PIECE(ORLST(I),U,4)=OI
- IF OI
- SET $PIECE(ORLST(I),U,5)=$PIECE(^ORD(101.43,OI,0),U)
- End DoDot:1
- +5 QUIT
- +6 ;
- GETADDFR(ORY,OIIEN) ;
- +1 NEW PSOI,TEMP
- +2 SET ORY=""
- +3 SET PSOI=+$PIECE($GET(^ORD(101.43,OIIEN,0)),U,2)
- +4 SET TEMP=$$IV^PSSDSAPA(PSOI)
- +5 SET ORY=$$ADDFRQCV^ORMBLDP1(TEMP,"I")
- +6 QUIT
- +7 ;
- ISVALIV(RESULT,ORID,ACTION) ;
- +1 NEW ARRAY,CNT,ID,IVD,CLIVD,NUM,ORDERID,OUTPUT,ROUTE,ROUTEID,TYPE
- +2 SET TYPE=$SELECT(ACTION="XFR":"transfered",ACTION="RN":"renewed",1:"copied")
- +3 SET IVD=$ORDER(^ORD(101.41,"B","PSJI OR PAT FLUID OE",""))
- +4 SET CLIVD=$ORDER(^ORD(101.41,"B","CLINIC OR PAT FLUID OE",""))
- +5 IF IVD=0
- IF CLIVD=0
- QUIT
- +6 IF +$PIECE($GET(^OR(100,+ORID,0)),U,5)'=IVD
- IF +$PIECE($GET(^OR(100,+ORID,0)),U,5)'=CLIVD
- QUIT
- +7 SET ORDERID=""
- SET ROUTEID=""
- SET CNT=0
- +8 FOR
- SET ORDERID=$ORDER(^OR(100,+ORID,4.5,"ID","ORDERABLE",ORDERID))
- if ORDERID'>0
- QUIT
- Begin DoDot:1
- +9 IF +$GET(^OR(100,+ORID,4.5,ORDERID,1))'>0
- QUIT
- +10 SET CNT=CNT+1
- SET ARRAY(CNT)=^OR(100,+ORID,4.5,ORDERID,1)
- End DoDot:1
- +11 SET ROUTEID=+$ORDER(^OR(100,+ORID,4.5,"ID","ROUTE",""))
- IF ROUTEID'>0
- Begin DoDot:1
- +12 SET RESULT="This order contains an invalid route. It cannot be "_TYPE_"."
- End DoDot:1
- QUIT
- +13 SET ROUTE=+$GET(^OR(100,+ORID,4.5,ROUTEID,1))
- IF ROUTE'>0
- Begin DoDot:1
- +14 SET RESULT="This order contains an invalid route. It cannot be "_TYPE_"."
- End DoDot:1
- QUIT
- +15 SET OUTPUT=$$IVQOVAL(.ARRAY,ROUTE)
- IF OUTPUT=""
- Begin DoDot:1
- +16 ;S TYPE=$S(ACTION="XFR":"transfered",ACTION="RN":"renewed",1:"copied")
- +17 SET RESULT="This order contains an invalid route. It cannot be "_TYPE_"."
- End DoDot:1
- +18 IF RESULT'=""
- QUIT
- +19 NEW IVTYPE,IVTYPEID,INFUSEID,INFUSE
- +20 SET IVTYPEID=+$ORDER(^OR(100,+ORID,4.5,"ID","TYPE",""))
- IF IVTYPEID'>0
- Begin DoDot:1
- +21 SET RESULT="This order contains an invalid IV Type. It cannot be "_TYPE_"."
- End DoDot:1
- QUIT
- +22 SET IVTYPE=$GET(^OR(100,+ORID,4.5,IVTYPEID,1))
- IF IVTYPE=""
- Begin DoDot:1
- +23 SET RESULT="This order contains an invalid IV Type. It cannot be "_TYPE_"."
- End DoDot:1
- QUIT
- +24 SET INFUSEID=+$ORDER(^OR(100,+ORID,4.5,"ID","RATE",""))
- if INFUSEID'>0
- QUIT
- +25 SET INFUSE=$GET(^OR(100,+ORID,4.5,INFUSEID,1))
- if INFUSE=""
- QUIT
- +26 IF $$VALINF^ORWDXM3(IVTYPE,INFUSE)=0
- Begin DoDot:1
- +27 ;S TYPE=$S(ACTION="XFR":"transfered",ACTION="RN":"renewed",1:"copied")
- +28 SET RESULT="This order contains an invalid infusion rate. It cannot be "_TYPE_"."
- End DoDot:1
- +29 ;//AGP IV ADDITIVE FREQUENCY
- +30 IF IVTYPE="C"
- IF ACTION="RN"
- Begin DoDot:1
- +31 NEW ADDCNT,ADDIEN,ADDFCNT,SUB
- +32 SET ADDIEN=$$PTR^ORCD("OR GTX ADDITIVE")
- +33 SET ADDCNT=0
- SET ADDFCNT=0
- SET SUB=0
- +34 FOR
- SET SUB=$ORDER(^OR(100,+ORID,4.5,"ID","ORDERABLE",SUB))
- if SUB'>0
- QUIT
- Begin DoDot:2
- +35 IF $PIECE($GET(^OR(100,+ORID,4.5,SUB,0)),U,2)'=ADDIEN
- QUIT
- +36 SET ADDCNT=ADDCNT+1
- End DoDot:2
- +37 SET SUB=0
- +38 FOR
- SET SUB=$ORDER(^OR(100,+ORID,4.5,"ID","ADDFREQ",SUB))
- if SUB'>0
- QUIT
- SET ADDFCNT=ADDFCNT+1
- +39 IF ADDCNT'=ADDFCNT
- SET RESULT="This order does not contain the same number of values for the Additives and the IV Additive Frequency prompts. It cannot be renewed."
- End DoDot:1
- +40 QUIT
- +41 ;
- IVQOVAL(ARRAY,ROUTE) ;
- +1 NEW CNT,RARR,RESULT
- +2 SET RESULT=""
- +3 DO IVDOSFRM(.RARR,.ARRAY,1)
- +4 SET CNT=""
- FOR
- SET CNT=$ORDER(RARR(CNT))
- if CNT'>0!(RESULT'="")
- QUIT
- Begin DoDot:1
- +5 IF $PIECE(RARR(CNT),U)=ROUTE
- SET RESULT=RARR(CNT)
- QUIT
- End DoDot:1
- +6 QUIT RESULT
- +7 ;
- IVDOSFRM(LST,ORDERIDS,ALLIV) ;
- +1 NEW ORARRAY,CNT,CNT1,OI,POI
- +2 SET OI=""
- SET CNT=0
- SET CNT1=0
- +3 FOR
- SET OI=$ORDER(ORDERIDS(OI))
- if OI'>0
- QUIT
- Begin DoDot:1
- +4 SET POI=+$PIECE($GET(^ORD(101.43,$GET(ORDERIDS(OI)),0)),U,2)
- if POI'>0
- QUIT
- +5 SET CNT=CNT+1
- +6 SET ORARRAY(CNT)=POI
- End DoDot:1
- +7 IF CNT=0
- QUIT
- +8 SET ORARRAY(0)=CNT
- +9 DO START1^PSSJORDF(.ORARRAY,ALLIV)
- +10 SET CNT=""
- FOR
- SET CNT=$ORDER(ORARRAY(CNT))
- if CNT'>0
- QUIT
- Begin DoDot:1
- +11 SET CNT1=CNT1+1
- SET LST(CNT1)=$GET(ORARRAY(CNT))
- End DoDot:1
- +12 ;this temp should be killed by Pharmacy. This will be removed once
- +13 ;Pharmacy send an update
- +14 KILL ^TMP("PSJMR",$JOB)
- +15 QUIT
- +16 ;
- IVIND(LST,ORDERIDS) ;*405-IND
- +1 NEW CNT,OI,POI,LST1,LST2,TEXT
- +2 SET OI=0
- +3 FOR
- SET OI=$ORDER(ORDERIDS(OI))
- if 'OI
- QUIT
- Begin DoDot:1
- +4 SET POI=+$PIECE($GET(^ORD(101.43,ORDERIDS(OI),0)),U,2)
- if 'POI
- QUIT
- +5 KILL LST1
- +6 DO INDICAT2^ORWDPS2(.LST1,POI)
- +7 if '$DATA(LST1)
- QUIT
- +8 SET CNT=0
- FOR
- SET CNT=$ORDER(LST1(CNT))
- if 'CNT
- QUIT
- Begin DoDot:2
- +9 SET TEXT="i"_$EXTRACT(LST1(CNT),2,99)
- +10 SET LST2(TEXT)=""
- End DoDot:2
- End DoDot:1
- +11 if '$DATA(LST2)
- QUIT
- +12 SET CNT=0
- SET OI=""
- FOR
- SET OI=$ORDER(LST2(OI))
- if OI=""
- QUIT
- SET CNT=CNT+1
- SET LST(CNT)=OI
- +13 QUIT
- +14 ;
- ISSPLY(VAL,IEN) ; return true if orderable item is a supply
- +1 SET VAL=0
- +2 IF $PIECE($GET(^ORD(101.43,IEN,"PS")),U,5)=1
- SET VAL=1
- +3 QUIT
- IVAMT(VAL,OI,ORWTYP) ; return UNITS^AMOUNT |^AMOUNT^AMOUNT...| for IV soln
- +1 NEW I,PSOI,ORWY,AMT
- +2 SET PSOI=+$PIECE($GET(^ORD(101.43,OI,0)),U,2)_ORWTYP
- SET VAL=""
- +3 DO ENVOL^PSJORUT2(PSOI,.ORWY)
- +4 IF ORWTYP="B"
- Begin DoDot:1
- +5 SET I=0
- FOR
- SET I=$ORDER(ORWY(I))
- if I'>0
- QUIT
- SET AMT(+ORWY(I))=""
- Begin DoDot:2
- +6 ;SBR
- IF ORWY(I)<1
- Begin DoDot:3
- +7 KILL AMT(+ORWY(I))
- +8 SET AMT(0_+ORWY(I))=""
- End DoDot:3
- End DoDot:2
- +9 SET AMT=0
- SET VAL="ML"
- FOR
- SET AMT=$ORDER(AMT(AMT))
- if AMT'>0
- QUIT
- SET VAL=VAL_U_AMT
- End DoDot:1
- +10 IF ORWTYP="A"
- Begin DoDot:1
- +11 SET I=+$ORDER(ORWY(0))
- SET VAL=$PIECE($GET(ORWY(I)),U,2)
- +12 IF '$LENGTH(VAL)
- SET VAL="ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM^MMOL"
- End DoDot:1
- +13 QUIT
- +14 ;
- MEDISIV(VAL,IEN) ; return true if orderable item is IV medication
- +1 SET VAL=0
- +2 IF $PIECE($GET(^ORD(101.43,IEN,"PS")),U)=2
- SET VAL=1
- +3 QUIT
- +4 ;
- SCSTS(VAL,ORVP,ORDRUG) ; return service connected eligibility for patient
- +1 NEW ORWP94
- SET ORWP94=$ORDER(^ORD(101.41,"AB","PS MEDS",0))>0
- +2 IF $LENGTH($TEXT(SC^PSOCP))
- IF $$SC^PSOCP(+ORVP,+$GET(ORDRUG))
- SET VAL=0
- GOTO XSCSTS
- +3 IF 'ORWP94
- IF (+$$RXST^IBARXEU(+ORVP)>0)
- SET VAL=0
- GOTO XSCSTS
- +4 SET VAL=1
- XSCSTS QUIT
- +1 ;
- VALQTY(OK,X) ; validate a quantity, return 1 if valid, 0 if not
- +1 ; to be compatible with LM, make sure X is integer from 1 to 240
- +2 ; this is based on the input transform from 52,7
- +3 if (+X'>0)!(+X>99999999)!(X'?.8N.1".".2N)!($LENGTH(X)>12)
- KILL X
- +4 SET OK=$SELECT($DATA(X):1,1:0)
- +5 QUIT
- +6 ;
- VALRATE(VAL,X) ; return "1" (true) if IV rate text is valid
- +1 IF $EXTRACT($REVERSE($$UPPER^ORWDPS32(X)),1,5)="RH/LM"
- SET X=$EXTRACT(X,1,$LENGTH(X)-5)
- +2 SET X=$$TRIM^ORWDPS32(X)
- +3 DO ORINF^PSIVSP
- SET VAL=$SELECT($DATA(X)>0:1,1:0)_U_$GET(X)
- +4 QUIT
- VALSCH(OK,X,PSTYPE) ; validate a schedule, return 1 if valid, 0 if not
- +1 IF '$LENGTH($TEXT(EN^PSSGSGUI))
- SET OK=-1
- QUIT
- +2 IF $EXTRACT($TEXT(EN^PSSGSGUI),1,4)="EN(X"
- Begin DoDot:1
- +3 NEW ORX
- SET ORX=$GET(X)
- DO EN^PSSGSGUI(.ORX,$GET(PSTYPE,"I"))
- +4 KILL X
- if $DATA(ORX)
- SET X=ORX
- End DoDot:1
- +5 IF '$TEST
- Begin DoDot:1
- +6 DO EN^PSSGSGUI
- End DoDot:1
- +7 SET OK=$SELECT($DATA(X):1,1:0)
- +8 QUIT
- +9 ;
- CLZDS(VAL,PAT,DRG,DSUP,OI) ; return the days supply for a given cloz patient
- +1 ; PAT=Patient DFN, DRG=Drug IEN, DSUP=Days Supply to validate, OI=Orderable Item IEN
- +2 ; VAL=DISPENCE FREQUENCY of the patient in file 603.01
- +3 SET VAL=0
- +4 IF '$GET(PAT)!('$GET(DRG))!('$GET(DSUP))!('$GET(OI))
- QUIT
- +5 NEW ORWX,ORDFR,MSG
- +6 SET ORWX("PATIENT")=PAT
- SET ORWX("DRUG")=DRG
- SET ORWX("OI")=OI
- +7 DO DSUP^PSOSIGDS(.ORWX)
- +8 SET ORDFR=$GET(ORWX("DAYS SUPPLY"))
- +9 if 'ORDFR
- QUIT
- +10 IF DSUP'>ORDFR
- IF ("^7^14^28^"[("^"_DSUP_"^"))
- SET VAL=1
- QUIT
- +11 SET MSG="Patient eligibility for this medication will only allow a Days Supply of "
- +12 IF ORDFR=28
- SET VAL="0^"_MSG_"28 days with 0 refills, 14 days with up to 1 refill, or 7 days with up to 3 refills."
- QUIT
- +13 IF ORDFR=14
- SET VAL="0^"_MSG_"14 days with 0 refills, or 7 days with up to 1 refill."
- QUIT
- +14 IF ORDFR=7
- SET VAL="0^"_MSG_"7 with 0 refills."
- +15 QUIT