ORWDPS33 ; SLC/KCM - Pharmacy Calls for GUI Dialog ;06-Jun-2013 09:19;PLS
;;3.0;ORDER ENTRY/RESULTS REPORTING;**243,1010,1011**;Dec 17, 1997;Build 242
;Per VHA Directive 2004-038, this routine should not be modified.
;This routine move several RPCs from ORWDPS32 because of the routine size
; Modified - IHS/MSC/PLS - 11/22/2011 - Line VALQTY+3
; - 06/06/2013 - Line VALQTY+6
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,LTSA,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)
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
;
ISVALIV(RESULT,ORID,ACTION) ;
N ARRAY,CNT,ID,IVD,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","")) Q:IVD'>0
I +$P($G(^OR(100,+ORID,0)),U,5)'=IVD 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_"."
Q
;
IVQOVAL(ARRAY,ROUTE) ;
N CNT,RARR,RESULT
S RESULT=""
D IVDOSFRM(.RARR,.ARRAY,0,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,DEFAULT,ALLIV) ;
N ARRAY,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 ARRAY(CNT)=POI
I CNT=0 Q
S ARRAY(0)=CNT
D START1^PSSJORDF(.ARRAY,ALLIV)
S CNT="" F S CNT=$O(ARRAY(CNT)) Q:CNT'>0 D
.S CNT1=CNT1+1,LST(CNT1)=$G(ARRAY(CNT))
;this temp should be killed by Pharmacy. This will be removed once
;Pharmacy send an update
K ^TMP("PSJMR",$J)
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
;IHS/MSC/PLS - 11/22/11
;K:(+X'>0)!(+X>99999999)!(X'?.8N.1".".2N)!($L(X)>12) X
;K:(+X'>0)!(+X>99999999)!(X'?.8N.1".".3N)!($L(X)>12) X
;IHS/MSC/PLS - 06/06/13
K:(+X'>0)!(+X>99999999)!(X'?.8N.1".".3N)!($L(X)>12)!((X[".")&(+$P(X,".",2)=0)) 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=$G(X) ;S OK=$S($D(X):1,1:0)
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
;
ORWDPS33 ; SLC/KCM - Pharmacy Calls for GUI Dialog ;06-Jun-2013 09:19;PLS
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**243,1010,1011**;Dec 17, 1997;Build 242
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;This routine move several RPCs from ORWDPS32 because of the routine size
+4 ; Modified - IHS/MSC/PLS - 11/22/2011 - Line VALQTY+3
+5 ; - 06/06/2013 - Line VALQTY+6
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,LTSA,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 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 ;
ISVALIV(RESULT,ORID,ACTION) ;
+1 NEW ARRAY,CNT,ID,IVD,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",""))
IF IVD'>0
QUIT
+4 IF +$PIECE($GET(^OR(100,+ORID,0)),U,5)'=IVD
QUIT
+5 SET ORDERID=""
SET ROUTEID=""
SET CNT=0
+6 FOR
SET ORDERID=$ORDER(^OR(100,+ORID,4.5,"ID","ORDERABLE",ORDERID))
IF ORDERID'>0
QUIT
Begin DoDot:1
+7 IF +$GET(^OR(100,+ORID,4.5,ORDERID,1))'>0
QUIT
+8 SET CNT=CNT+1
SET ARRAY(CNT)=^OR(100,+ORID,4.5,ORDERID,1)
End DoDot:1
+9 SET ROUTEID=+$ORDER(^OR(100,+ORID,4.5,"ID","ROUTE",""))
IF ROUTEID'>0
Begin DoDot:1
+10 SET RESULT="This order contains an invalid route it cannot be "_TYPE_"."
End DoDot:1
QUIT
+11 SET ROUTE=+$GET(^OR(100,+ORID,4.5,ROUTEID,1))
IF ROUTE'>0
Begin DoDot:1
+12 SET RESULT="This order contains an invalid route it cannot be "_TYPE_"."
End DoDot:1
QUIT
+13 SET OUTPUT=$$IVQOVAL(.ARRAY,ROUTE)
IF OUTPUT=""
Begin DoDot:1
+14 ;S TYPE=$S(ACTION="XFR":"transfered",ACTION="RN":"renewed",1:"copied")
+15 SET RESULT="This order contains an invalid route it cannot be "_TYPE_"."
End DoDot:1
+16 IF RESULT'=""
QUIT
+17 NEW IVTYPE,IVTYPEID,INFUSEID,INFUSE
+18 SET IVTYPEID=+$ORDER(^OR(100,+ORID,4.5,"ID","TYPE",""))
IF IVTYPEID'>0
Begin DoDot:1
+19 SET RESULT="This order contains an invalid IV Type it cannot be "_TYPE_"."
End DoDot:1
QUIT
+20 SET IVTYPE=$GET(^OR(100,+ORID,4.5,IVTYPEID,1))
IF IVTYPE=""
Begin DoDot:1
+21 SET RESULT="This order contains an invalid IV Type it cannot be "_TYPE_"."
End DoDot:1
QUIT
+22 SET INFUSEID=+$ORDER(^OR(100,+ORID,4.5,"ID","RATE",""))
IF INFUSEID'>0
QUIT
+23 SET INFUSE=$GET(^OR(100,+ORID,4.5,INFUSEID,1))
IF INFUSE=""
QUIT
+24 IF $$VALINF^ORWDXM3(IVTYPE,INFUSE)=0
Begin DoDot:1
+25 ;S TYPE=$S(ACTION="XFR":"transfered",ACTION="RN":"renewed",1:"copied")
+26 SET RESULT="This order contains an invalid infusion rate it cannot be "_TYPE_"."
End DoDot:1
+27 QUIT
+28 ;
IVQOVAL(ARRAY,ROUTE) ;
+1 NEW CNT,RARR,RESULT
+2 SET RESULT=""
+3 DO IVDOSFRM(.RARR,.ARRAY,0,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,DEFAULT,ALLIV) ;
+1 NEW ARRAY,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 ARRAY(CNT)=POI
End DoDot:1
+7 IF CNT=0
QUIT
+8 SET ARRAY(0)=CNT
+9 DO START1^PSSJORDF(.ARRAY,ALLIV)
+10 SET CNT=""
FOR
SET CNT=$ORDER(ARRAY(CNT))
IF CNT'>0
QUIT
Begin DoDot:1
+11 SET CNT1=CNT1+1
SET LST(CNT1)=$GET(ARRAY(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 ;
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 ;IHS/MSC/PLS - 11/22/11
+4 ;K:(+X'>0)!(+X>99999999)!(X'?.8N.1".".2N)!($L(X)>12) X
+5 ;K:(+X'>0)!(+X>99999999)!(X'?.8N.1".".3N)!($L(X)>12) X
+6 ;IHS/MSC/PLS - 06/06/13
+7 IF (+X'>0)!(+X>99999999)!(X'?.8N.1".".3N)!($LENGTH(X)>12)!((X[".")&(+$PIECE(X,".",2)=0))
KILL X
+8 SET OK=$SELECT($DATA(X):1,1:0)
+9 QUIT
+10 ;
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 ;S OK=$S($D(X):1,1:0)
DO ORINF^PSIVSP
SET VAL=$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 ;
