Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORWDPS33

ORWDPS33.m

Go to the documentation of this file.
  1. 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
  1. ;Per VHA Directive 6402, this routine should not be modified.
  1. ;This routine move several RPCs from ORWDPS32 because of the routine size
  1. ; Reference to DSUP^PSOSIGDS in ICR #3278
  1. ;
  1. COMPLOC(ORY,ORID,LOC) ;
  1. S ORY=0
  1. I LOC'=+$P($G(^OR(100,+ORID,0)),U,10) S ORY=1
  1. Q
  1. DOSES(LST,OI) ; return doses for an orderable item - TEST ONLY
  1. N ORTMP,ORI,ORJ,ILST,LSTA,NDF,ORWDRG,VAPN,X,PSTYPE S PSTYPE="O"
  1. D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP)
  1. S ORI=0 F S ORI=$O(ORTMP(ORI)) Q:'ORI S ORWDRG=+ORTMP(ORI) D
  1. . K ^TMP($J,"ORWDPS32 DRUG")
  1. . D NDF^PSS50(+ORWDRG,,,,,"ORWDPS32 DRUG")
  1. . S VAPN=$P($G(^TMP($J,"ORWDPS32 DRUG",+ORWDRG,22)),U),NDF=$P($G(^TMP($J,"ORWDPS32 DRUG",+ORWDRG,20)),U)
  1. . S X=$$DFSU^PSNAPIS(NDF,VAPN)
  1. . S LSTA($P(X,U,4),$P(X,U,6))=""
  1. . I +$P(X,U,4)=$P(X,U,4) S LSTA($P(X,U,4)*2,$P(X,U,6))=""
  1. K ^TMP($J,"ORWDPS32 DRUG")
  1. S ORI="",ILST=0 F S ORI=$O(LSTA(ORI)) Q:ORI="" D
  1. . S ORJ="" F S ORJ=$O(LSTA(ORI,ORJ)) Q:ORJ="" D
  1. . . S ILST=ILST+1,LST(ILST)=ORI_" "_ORJ
  1. Q
  1. ;
  1. DRUGMSG(VAL,IEN) ; return any message associated with a dispense drug
  1. N X S X=$$ENDCM^PSJORUTL(IEN)
  1. S VAL=$P(X,U,2)_U_$P(X,U,4)
  1. Q
  1. ;
  1. FORMALT(ORLST,IEN,PSTYPE) ; return a list of formulary alternatives
  1. D ENRFA^PSJORUTL(IEN,PSTYPE,.ORLST)
  1. N I,OI S I=0 F S I=$O(ORLST(I)) Q:'I D
  1. . S OI=+$O(^ORD(101.43,"ID",+$P(ORLST(I),U,4)_";99PSP",0))
  1. . S $P(ORLST(I),U,4)=OI I OI S $P(ORLST(I),U,5)=$P(^ORD(101.43,OI,0),U)
  1. Q
  1. ;
  1. GETADDFR(ORY,OIIEN) ;
  1. N PSOI,TEMP
  1. S ORY=""
  1. S PSOI=+$P($G(^ORD(101.43,OIIEN,0)),U,2)
  1. S TEMP=$$IV^PSSDSAPA(PSOI)
  1. S ORY=$$ADDFRQCV^ORMBLDP1(TEMP,"I")
  1. Q
  1. ;
  1. ISVALIV(RESULT,ORID,ACTION) ;
  1. N ARRAY,CNT,ID,IVD,CLIVD,NUM,ORDERID,OUTPUT,ROUTE,ROUTEID,TYPE
  1. S TYPE=$S(ACTION="XFR":"transfered",ACTION="RN":"renewed",1:"copied")
  1. S IVD=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE",""))
  1. S CLIVD=$O(^ORD(101.41,"B","CLINIC OR PAT FLUID OE",""))
  1. I IVD=0,CLIVD=0 Q
  1. I +$P($G(^OR(100,+ORID,0)),U,5)'=IVD,+$P($G(^OR(100,+ORID,0)),U,5)'=CLIVD Q
  1. S ORDERID="",ROUTEID="",CNT=0
  1. F S ORDERID=$O(^OR(100,+ORID,4.5,"ID","ORDERABLE",ORDERID)) Q:ORDERID'>0 D
  1. .I +$G(^OR(100,+ORID,4.5,ORDERID,1))'>0 Q
  1. .S CNT=CNT+1,ARRAY(CNT)=^OR(100,+ORID,4.5,ORDERID,1)
  1. S ROUTEID=+$O(^OR(100,+ORID,4.5,"ID","ROUTE","")) I ROUTEID'>0 D Q
  1. .S RESULT="This order contains an invalid route. It cannot be "_TYPE_"."
  1. S ROUTE=+$G(^OR(100,+ORID,4.5,ROUTEID,1)) I ROUTE'>0 D Q
  1. .S RESULT="This order contains an invalid route. It cannot be "_TYPE_"."
  1. S OUTPUT=$$IVQOVAL(.ARRAY,ROUTE) I OUTPUT="" D
  1. .;S TYPE=$S(ACTION="XFR":"transfered",ACTION="RN":"renewed",1:"copied")
  1. .S RESULT="This order contains an invalid route. It cannot be "_TYPE_"."
  1. I RESULT'="" Q
  1. N IVTYPE,IVTYPEID,INFUSEID,INFUSE
  1. S IVTYPEID=+$O(^OR(100,+ORID,4.5,"ID","TYPE","")) I IVTYPEID'>0 D Q
  1. .S RESULT="This order contains an invalid IV Type. It cannot be "_TYPE_"."
  1. S IVTYPE=$G(^OR(100,+ORID,4.5,IVTYPEID,1)) I IVTYPE="" D Q
  1. .S RESULT="This order contains an invalid IV Type. It cannot be "_TYPE_"."
  1. S INFUSEID=+$O(^OR(100,+ORID,4.5,"ID","RATE","")) Q:INFUSEID'>0
  1. S INFUSE=$G(^OR(100,+ORID,4.5,INFUSEID,1)) Q:INFUSE=""
  1. I $$VALINF^ORWDXM3(IVTYPE,INFUSE)=0 D
  1. .;S TYPE=$S(ACTION="XFR":"transfered",ACTION="RN":"renewed",1:"copied")
  1. .S RESULT="This order contains an invalid infusion rate. It cannot be "_TYPE_"."
  1. ;//AGP IV ADDITIVE FREQUENCY
  1. I IVTYPE="C",ACTION="RN" D
  1. .N ADDCNT,ADDIEN,ADDFCNT,SUB
  1. .S ADDIEN=$$PTR^ORCD("OR GTX ADDITIVE")
  1. .S ADDCNT=0,ADDFCNT=0,SUB=0
  1. .F S SUB=$O(^OR(100,+ORID,4.5,"ID","ORDERABLE",SUB)) Q:SUB'>0 D
  1. ..I $P($G(^OR(100,+ORID,4.5,SUB,0)),U,2)'=ADDIEN Q
  1. ..S ADDCNT=ADDCNT+1
  1. .S SUB=0
  1. .F S SUB=$O(^OR(100,+ORID,4.5,"ID","ADDFREQ",SUB)) Q:SUB'>0 S ADDFCNT=ADDFCNT+1
  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."
  1. Q
  1. ;
  1. IVQOVAL(ARRAY,ROUTE) ;
  1. N CNT,RARR,RESULT
  1. S RESULT=""
  1. D IVDOSFRM(.RARR,.ARRAY,1)
  1. S CNT="" F S CNT=$O(RARR(CNT)) Q:CNT'>0!(RESULT'="") D
  1. .I $P(RARR(CNT),U)=ROUTE S RESULT=RARR(CNT) Q
  1. Q RESULT
  1. ;
  1. IVDOSFRM(LST,ORDERIDS,ALLIV) ;
  1. N ORARRAY,CNT,CNT1,OI,POI
  1. S OI="",CNT=0,CNT1=0
  1. F S OI=$O(ORDERIDS(OI)) Q:OI'>0 D
  1. .S POI=+$P($G(^ORD(101.43,$G(ORDERIDS(OI)),0)),U,2) Q:POI'>0
  1. .S CNT=CNT+1
  1. .S ORARRAY(CNT)=POI
  1. I CNT=0 Q
  1. S ORARRAY(0)=CNT
  1. D START1^PSSJORDF(.ORARRAY,ALLIV)
  1. S CNT="" F S CNT=$O(ORARRAY(CNT)) Q:CNT'>0 D
  1. .S CNT1=CNT1+1,LST(CNT1)=$G(ORARRAY(CNT))
  1. ;this temp should be killed by Pharmacy. This will be removed once
  1. ;Pharmacy send an update
  1. K ^TMP("PSJMR",$J)
  1. Q
  1. ;
  1. IVIND(LST,ORDERIDS) ;*405-IND
  1. N CNT,OI,POI,LST1,LST2,TEXT
  1. S OI=0
  1. F S OI=$O(ORDERIDS(OI)) Q:'OI D
  1. .S POI=+$P($G(^ORD(101.43,ORDERIDS(OI),0)),U,2) Q:'POI
  1. .K LST1
  1. .D INDICAT2^ORWDPS2(.LST1,POI)
  1. .Q:'$D(LST1)
  1. .S CNT=0 F S CNT=$O(LST1(CNT)) Q:'CNT D
  1. ..S TEXT="i"_$E(LST1(CNT),2,99)
  1. ..S LST2(TEXT)=""
  1. Q:'$D(LST2)
  1. S CNT=0,OI="" F S OI=$O(LST2(OI)) Q:OI="" S CNT=CNT+1,LST(CNT)=OI
  1. Q
  1. ;
  1. ISSPLY(VAL,IEN) ; return true if orderable item is a supply
  1. S VAL=0
  1. I $P($G(^ORD(101.43,IEN,"PS")),U,5)=1 S VAL=1
  1. Q
  1. IVAMT(VAL,OI,ORWTYP) ; return UNITS^AMOUNT |^AMOUNT^AMOUNT...| for IV soln
  1. N I,PSOI,ORWY,AMT
  1. S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2)_ORWTYP,VAL=""
  1. D ENVOL^PSJORUT2(PSOI,.ORWY)
  1. I ORWTYP="B" D
  1. . S I=0 F S I=$O(ORWY(I)) Q:I'>0 S AMT(+ORWY(I))="" D
  1. . . I ORWY(I)<1 D ;SBR
  1. . . . K AMT(+ORWY(I))
  1. . . . S AMT(0_+ORWY(I))=""
  1. . S AMT=0,VAL="ML" F S AMT=$O(AMT(AMT)) Q:AMT'>0 S VAL=VAL_U_AMT
  1. I ORWTYP="A" D
  1. . S I=+$O(ORWY(0)) S VAL=$P($G(ORWY(I)),U,2)
  1. . I '$L(VAL) S VAL="ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM^MMOL"
  1. Q
  1. ;
  1. MEDISIV(VAL,IEN) ; return true if orderable item is IV medication
  1. S VAL=0
  1. I $P($G(^ORD(101.43,IEN,"PS")),U)=2 S VAL=1
  1. Q
  1. ;
  1. SCSTS(VAL,ORVP,ORDRUG) ; return service connected eligibility for patient
  1. N ORWP94 S ORWP94=$O(^ORD(101.41,"AB","PS MEDS",0))>0
  1. I $L($T(SC^PSOCP)),$$SC^PSOCP(+ORVP,+$G(ORDRUG)) S VAL=0 G XSCSTS
  1. I 'ORWP94,(+$$RXST^IBARXEU(+ORVP)>0) S VAL=0 G XSCSTS
  1. S VAL=1
  1. XSCSTS Q
  1. ;
  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
  1. ; this is based on the input transform from 52,7
  1. K:(+X'>0)!(+X>99999999)!(X'?.8N.1".".2N)!($L(X)>12) X
  1. S OK=$S($D(X):1,1:0)
  1. Q
  1. ;
  1. VALRATE(VAL,X) ; return "1" (true) if IV rate text is valid
  1. I $E($RE($$UPPER^ORWDPS32(X)),1,5)="RH/LM" S X=$E(X,1,$L(X)-5)
  1. S X=$$TRIM^ORWDPS32(X)
  1. D ORINF^PSIVSP S VAL=$S($D(X)>0:1,1:0)_U_$G(X)
  1. Q
  1. VALSCH(OK,X,PSTYPE) ; validate a schedule, return 1 if valid, 0 if not
  1. I '$L($T(EN^PSSGSGUI)) S OK=-1 Q
  1. I $E($T(EN^PSSGSGUI),1,4)="EN(X" D
  1. . N ORX S ORX=$G(X) D EN^PSSGSGUI(.ORX,$G(PSTYPE,"I"))
  1. . K X S:$D(ORX) X=ORX
  1. E D
  1. . D EN^PSSGSGUI
  1. S OK=$S($D(X):1,1:0)
  1. Q
  1. ;
  1. 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
  1. ; VAL=DISPENCE FREQUENCY of the patient in file 603.01
  1. S VAL=0
  1. I '$G(PAT)!('$G(DRG))!('$G(DSUP))!('$G(OI)) Q
  1. N ORWX,ORDFR,MSG
  1. S ORWX("PATIENT")=PAT,ORWX("DRUG")=DRG,ORWX("OI")=OI
  1. D DSUP^PSOSIGDS(.ORWX)
  1. S ORDFR=$G(ORWX("DAYS SUPPLY"))
  1. Q:'ORDFR
  1. I DSUP'>ORDFR,("^7^14^28^"[("^"_DSUP_"^")) S VAL=1 Q
  1. S MSG="Patient eligibility for this medication will only allow a Days Supply of "
  1. 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
  1. I ORDFR=14 S VAL="0^"_MSG_"14 days with 0 refills, or 7 days with up to 1 refill." Q
  1. I ORDFR=7 S VAL="0^"_MSG_"7 with 0 refills."
  1. Q