VPRDPSOR ;SLC/MKB -- Medication extract by order ;8/2/11 15:29
;;1.0;VIRTUAL PATIENT RECORD;**1,4,18,28,32,33**;Sep 01, 2011;Build 8
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^DIC(9.4 10048
; ^OR(100 5771
; ^ORD(100.98 873
; ^SC 10040
; ^VA(200 10060
; DIQ 2056
; ORCD 5493
; ORQ1,^TMP("ORR",$J) 3154
; ORX8 871,2467,3071
; PSOORRL,^TMP("PS",$J) 2400
; PSS50P7 4662
; PSS51P2 4548
;
; ------------ Get data from VistA ------------
;
EN(DFN,BEG,END,MAX,ORIFN) ; -- find a patient's orders
S DFN=+$G(DFN) Q:DFN<1 ;invalid patient
S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)
N ORDIALOG ;med dialog array, keep/reuse
;
; get one order
I $G(ORIFN) D EN1(ORIFN,.VPRITM),XML^VPRDPS(.VPRITM):$D(VPRITM) Q
;
; get all orders
N TYPE,ORDG,ORFLG,ORVP,ORLIST,VPRITM,VPRCNT,VPRN,ORLIST,ORIFN,X3,X4,DAD
S TYPE=$G(FILTER("vaType")) S:$L(TYPE) TYPE=$S(TYPE="N":"NV",TYPE="V":"IV",1:TYPE)_" "
S ORDG=+$O(^ORD(100.98,"B",TYPE_"RX",0)),ORVP=DFN_";DPT("
S ORFLG=+$G(FILTER("view"),6) ;default = Released Orders
I 7<ORFLG,ORFLG<22,ORFLG'=18 Q ;action, event views not supported
D EN^ORQ1(ORVP,ORDG,ORFLG,,BEG,END)
K ^TMP("VPROR",$J) S (VPRCNT,VPRN)=0
F S VPRN=$O(^TMP("ORR",$J,ORLIST,VPRN)) Q:VPRN<1 S ORIFN=+$G(^(VPRN)) D Q:VPRCNT'<MAX
. Q:$D(^TMP("VPROR",$J,ORIFN)) ;Q:$P(ORIFN,";",2)>1 S ORIFN=+ORIFN
. S X3=$G(^OR(100,ORIFN,3)),X4=$G(^(4))
. Q:$P(X3,U,3)=13 I X4["P",$P(X3,U,3)=1 Q ;cancelled
. S DAD=$P(X3,U,9) I DAD Q:$D(^TMP("VPROR",$J,DAD)) S ORIFN=DAD
. K VPRITM D EN1(ORIFN,.VPRITM) Q:'$D(VPRITM)
. D XML^VPRDPS(.VPRITM)
. S ^TMP("VPROR",$J,ORIFN)="",VPRCNT=VPRCNT+1
K ^TMP("VPROR",$J),^TMP("ORR",$J),^TMP($J,"PSOI")
Q
;
EN1(IFN,MED) ; -- return an order in MED("attribute")=value [from EN]
N ORUPCHUK,ORVP,ORPCL,ORPK,ORDUZ,ORODT,ORSTRT,ORSTOP,ORL,ORTO,ORSTS,ORNP,ORPV,ORTX
N CLS,OI,X,LOC,DRUG,DA,CNT,VPRESP K MED
S IFN=+$G(IFN) I IFN<1!'$D(^OR(100,IFN)) Q
I $G(DFN),+$P($G(^OR(100,IFN,0)),U,2)'=DFN Q
I '$$RX(IFN) Q ; p33 - make sure the order is a real med order.
S ORPK=$$PKGID^ORX8(IFN)
S X=$S(ORPK:$E(ORPK,$L(ORPK)),1:"Z") S:X=+X X="R" ;last char = PS file
S CLS=$S("RSN"[X:"O","UV"[X:"I",1:$$GETCLS) ; p18 added package check in new function
I CLS="O",ORPK=+ORPK!(ORPK["R") D RX^VPRDPSO(ORPK,.MED) S MED("id")=IFN Q
S MED("id")=IFN,MED("orderID")=IFN,MED("vaType")=CLS
S:ORPK MED("medID")=ORPK_";"_CLS
D EN^ORX8(IFN) S X="" F S X=$O(ORUPCHUK(X)) Q:X="" S:$D(ORUPCHUK(X))#2 @X=ORUPCHUK(X)
S MED("ordered")=$G(ORODT),MED("orderingProvider")=$G(ORNP)_U_$$PROVSPC^VPRD(+ORNP)
S X=$$LASTPROV(IFN),MED("currentProvider")=X_U_$$PROVSPC^VPRD(+X)
S MED("start")=$G(ORSTRT),MED("stop")=$G(ORSTOP)
S MED("vaStatus")=$P($G(ORSTS),U,2),MED("status")=$$STATUS(+$G(ORSTS))
S X=$$VALUE^ORX8(IFN,"INDICATION") S:$L(X) MED("indication")=X
S LOC=+$G(ORL) S:LOC MED("location")=LOC_U_$P(^SC(LOC,0),U)
I CLS="I" D
. S:$P($G(^SC(+$G(LOC),0)),U,25) MED("IMO")=1
. S X=$P($G(^OR(100,IFN,3)),U,9) S:X MED("parent")=X
S MED("facility")=$$FAC^VPRD(LOC) I ORPK D
. N IFN D OEL^PSOORRL(DFN,ORPK_";"_CLS)
I $$IV D IV^VPRDPSI Q
S:CLS="O" MED("type")="Prescription"
S:ORPK["N" MED("vaType")="N",MED("type")="OTC"
ENA ; get order responses
S OI=$$OI^ORX8(IFN) I OI S MED("name")=$P(OI,U,2) D
. D ZERO^PSS50P7(+$P(OI,U,3),,,"PSOI")
. S MED("form")=$P($G(^TMP($J,"PSOI",+$P(OI,U,3),.02)),U,2)
. S:+$G(^TMP($J,"PSOI",+$P(OI,U,3),.09)) MED("supply")=1
D RESP(IFN,.VPRESP) ;order responses
S DRUG=+$G(^TMP("PS",$J,"DD",1,0)) S:'DRUG DRUG=+$G(VPRESP("DRUG",1))
S MED("sig")=$S(CLS="I":"Give: ",1:"")_$G(VPRESP("SIG",1)) ;ORTX(2)
I CLS="I"!(ORPK["N") D G ENQ ;UD or NVA: single dose, or child orders
. I '$O(^OR(100,IFN,2,0)) S MED("dose",1)=$$DOSE(1)_U_$G(ORSTRT)_U_$G(ORSTOP) Q
. N DD,CONJ M CONJ=VPRESP("CONJ")
. S (DA,CNT)=0 F S DA=$O(^OR(100,IFN,2,DA)) Q:DA<1 D
.. K VPRESP D RESP(DA,.VPRESP)
.. S CNT=CNT+1,MED("dose",CNT)=$$DOSE(1)_U_$P($G(^OR(100,DA,0)),U,8,9)_U_DA
.. S $P(MED("dose",CNT),U,8)=$G(CONJ(CNT))
.. I $P(MED("dose",CNT),U,10)>$G(ORSTOP) S ORSTOP=$P(MED("dose",CNT),U,10)
.. S:'DRUG DD=+$G(VPRESP("DRUG",1)),DD(DD,DA)="" ;dispense drug(s)
.. ; get ^TMP("PS",$J) from 1st child, if Inpt parent:
.. I '$D(^TMP("PS",$J)) S ORPK=$$PKGID^ORX8(DA) D OEL^PSOORRL(DFN,ORPK_";"_CLS)
. S MED("stop")=$G(ORSTOP) ;reset from last child order
. S DD=$O(DD(0)) I DD,'$O(DD(DD)) S DRUG=DD Q ;1 drug for order
. S (DD,CNT)=0 F S DD=$O(DD(DD)) Q:DD<1 S DA=0 F S DA=$O(DD(DD,DA)) Q:DA<1 S CNT=CNT+1 D NDF^VPRDPS(DD,CNT,DA)
; pending Rx: dose(s), qty, etc.
S CNT=0 F S CNT=$O(VPRESP("INSTR",CNT)) Q:CNT<1 S MED("dose",CNT)=$$DOSE(CNT) ;_STRT^STOP
S MED("quantity")=$G(VPRESP("QTY",1))
S MED("daysSupply")=$G(VPRESP("SUPPLY",1))
S MED("routing")=$G(VPRESP("PICKUP",1))
S MED("fillsAllowed")=$G(VPRESP("REFILLS",1))
S MED("ptInstructions")=$G(VPRESP("PI",1))
ENQ ; finish
D:DRUG NDF^VPRDPS(+DRUG)
S X=+$P($G(^TMP("PS",$J,"RXN",0)),U,5)
S:X MED("pharmacist")=X_U_$P($G(^VA(200,X,0)),U)
K ^TMP("PS",$J),^TMP($J,"PSOI")
Q
;
IV() ; -- Return 1 or 0, if order is for IV/infusion
I ORPK["V" Q 1
I $P($G(ORTO),U,2)?1"IV".E Q 1
I +$G(ORPCL)=130 Q 1
I $G(^TMP("PS",$J,"B",0)) Q 1
Q 0
;
DOSE(N) ; --add dosage data from VPRESP(ID,N) [instance N]
N DOSE,X,ID S N=+$G(N,1)
S DOSE=$P($G(VPRESP("DOSE",N)),"&",1,4),DOSE=$TR(DOSE,"&","^")
I '$L($P(DOSE,U)) S DOSE=$G(VPRESP("INSTR",N))_"^^^"
S X=+$G(VPRESP("ROUTE",N)) D ALL^PSS51P2(X,,,,"VPRTE")
S DOSE=DOSE_U_$G(^TMP($J,"VPRTE",X,1))
F ID="SCHEDULE","DAYS","CONJ" S DOSE=DOSE_U_$G(VPRESP(ID,N))
K ^TMP($J,"VPRTE")
Q DOSE
;
LASTPROV(IFN) ; -- return last provider who took action on order IFN
N I,X,Y S Y="^"
S I="A" F S I=$O(^OR(100,IFN,8,I),-1) Q:I<1 S X=$G(^(I,0)) D Q:Y
. I $P(X,U,5) S Y=+$P(X,U,5) Q ;signer
. I $P(X,U,3) S Y=+$P(X,U,3) Q ;orderer
S:Y Y=Y_U_$P($G(^VA(200,Y,0)),U)
Q Y
;
STRING(IFN,ID) ; -- return text value as a string
N DA,I,X,Y
S DA=+$O(^OR(100,IFN,4.5,"ID",ID,0)) Q:DA<1 ""
S I=+$O(^OR(100,IFN,4.5,DA,2,0)),Y=$G(^(I,0))
F S I=+$O(^OR(100,IFN,4.5,DA,2,I)) Q:I<1 S X=$G(^(I,0)) D
. I $E(Y,$L(Y))'=" " S Y=Y_" "
. S Y=Y_X
Q Y
;
STATUS(X) ; -- return HITSP status for 100.01 #X
S X=+$G(X) S:'X X=99 ;no status
I X=3 Q "hold"
I X=10!(X=11)!(X=5) Q "not active"
I X=1!(X=12)!(X=13) Q "not active"
I X=14!(X=99) Q "not active"
I X=2!(X=7)!(X=15) Q "historical"
Q "active"
;
RESP(ORIFN,RESP) ; -- return order responses [internal form]
N VPRDLG,I,J,W,ID,TYPE,X,Y
I '$D(ORDIALOG) S ORDIALOG=129 D GETDLG1^ORCD(129)
D GETORDER^ORCD(+$G(ORIFN),"VPRDLG")
S I=0 F S I=$O(VPRDLG(I)) Q:I<1 D
. S ID=$P($G(ORDIALOG(I)),U,2) Q:'$L(ID)
. S TYPE=$P($G(ORDIALOG(I,0)),U)
. S J=0 F S J=$O(VPRDLG(I,J)) Q:J<1 I $D(VPRDLG(I,J)) D
.. S X=VPRDLG(I,J) I TYPE'="W" S RESP(ID,J)=X Q
.. S Y=$G(@X@(1,0)),W=1 F S W=$O(@X@(W)) Q:W<1 S Y=Y_$S($E(Y,$L(Y))'=" ":" ",1:"")_$G(@X@(W,0))
.. S:$L(Y) RESP(ID,J)=Y
Q
GETCLS() ; p18 added package check
N PKGIEN S PKGIEN=$$GET1^DIQ(100,IFN_",",12,"I")
I $P($G(^DIC(9.4,PKGIEN,0)),U)="INPATIENT MEDICATIONS" Q "I"
I $P($G(^DIC(9.4,PKGIEN,0)),U)="OUTPATIENT PHARMACY" Q "O"
Q $$GET1^DIQ(100,IFN_",",10,"I")
;
RX(ORIFN) ; -- is order really a med? (non-PS order in display group)
N X,Y,PKG S Y=0
S X=$P($G(^OR(100,+$G(ORIFN),0)),U,14),PKG=$$GET1^DIQ(9.4,+X_",",1)
I $E(PKG,1,2)="PS" S Y=1
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDPSOR 7869 printed Apr 09, 2024@21:47:14 Page 2
VPRDPSOR ;SLC/MKB -- Medication extract by order ;8/2/11 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**1,4,18,28,32,33**;Sep 01, 2011;Build 8
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^DIC(9.4 10048
+7 ; ^OR(100 5771
+8 ; ^ORD(100.98 873
+9 ; ^SC 10040
+10 ; ^VA(200 10060
+11 ; DIQ 2056
+12 ; ORCD 5493
+13 ; ORQ1,^TMP("ORR",$J) 3154
+14 ; ORX8 871,2467,3071
+15 ; PSOORRL,^TMP("PS",$J) 2400
+16 ; PSS50P7 4662
+17 ; PSS51P2 4548
+18 ;
+19 ; ------------ Get data from VistA ------------
+20 ;
EN(DFN,BEG,END,MAX,ORIFN) ; -- find a patient's orders
+1 ;invalid patient
SET DFN=+$GET(DFN)
if DFN<1
QUIT
+2 SET BEG=$GET(BEG,1410101)
SET END=$GET(END,4141015)
SET MAX=$GET(MAX,9999)
+3 ;med dialog array, keep/reuse
NEW ORDIALOG
+4 ;
+5 ; get one order
+6 IF $GET(ORIFN)
DO EN1(ORIFN,.VPRITM)
if $DATA(VPRITM)
DO XML^VPRDPS(.VPRITM)
QUIT
+7 ;
+8 ; get all orders
+9 NEW TYPE,ORDG,ORFLG,ORVP,ORLIST,VPRITM,VPRCNT,VPRN,ORLIST,ORIFN,X3,X4,DAD
+10 SET TYPE=$GET(FILTER("vaType"))
if $LENGTH(TYPE)
SET TYPE=$SELECT(TYPE="N":"NV",TYPE="V":"IV",1:TYPE)_" "
+11 SET ORDG=+$ORDER(^ORD(100.98,"B",TYPE_"RX",0))
SET ORVP=DFN_";DPT("
+12 ;default = Released Orders
SET ORFLG=+$GET(FILTER("view"),6)
+13 ;action, event views not supported
IF 7<ORFLG
IF ORFLG<22
IF ORFLG'=18
QUIT
+14 DO EN^ORQ1(ORVP,ORDG,ORFLG,,BEG,END)
+15 KILL ^TMP("VPROR",$JOB)
SET (VPRCNT,VPRN)=0
+16 FOR
SET VPRN=$ORDER(^TMP("ORR",$JOB,ORLIST,VPRN))
if VPRN<1
QUIT
SET ORIFN=+$GET(^(VPRN))
Begin DoDot:1
+17 ;Q:$P(ORIFN,";",2)>1 S ORIFN=+ORIFN
if $DATA(^TMP("VPROR",$JOB,ORIFN))
QUIT
+18 SET X3=$GET(^OR(100,ORIFN,3))
SET X4=$GET(^(4))
+19 ;cancelled
if $PIECE(X3,U,3)=13
QUIT
IF X4["P"
IF $PIECE(X3,U,3)=1
QUIT
+20 SET DAD=$PIECE(X3,U,9)
IF DAD
if $DATA(^TMP("VPROR",$JOB,DAD))
QUIT
SET ORIFN=DAD
+21 KILL VPRITM
DO EN1(ORIFN,.VPRITM)
if '$DATA(VPRITM)
QUIT
+22 DO XML^VPRDPS(.VPRITM)
+23 SET ^TMP("VPROR",$JOB,ORIFN)=""
SET VPRCNT=VPRCNT+1
End DoDot:1
if VPRCNT'<MAX
QUIT
+24 KILL ^TMP("VPROR",$JOB),^TMP("ORR",$JOB),^TMP($JOB,"PSOI")
+25 QUIT
+26 ;
EN1(IFN,MED) ; -- return an order in MED("attribute")=value [from EN]
+1 NEW ORUPCHUK,ORVP,ORPCL,ORPK,ORDUZ,ORODT,ORSTRT,ORSTOP,ORL,ORTO,ORSTS,ORNP,ORPV,ORTX
+2 NEW CLS,OI,X,LOC,DRUG,DA,CNT,VPRESP
KILL MED
+3 SET IFN=+$GET(IFN)
IF IFN<1!'$DATA(^OR(100,IFN))
QUIT
+4 IF $GET(DFN)
IF +$PIECE($GET(^OR(100,IFN,0)),U,2)'=DFN
QUIT
+5 ; p33 - make sure the order is a real med order.
IF '$$RX(IFN)
QUIT
+6 SET ORPK=$$PKGID^ORX8(IFN)
+7 ;last char = PS file
SET X=$SELECT(ORPK:$EXTRACT(ORPK,$LENGTH(ORPK)),1:"Z")
if X=+X
SET X="R"
+8 ; p18 added package check in new function
SET CLS=$SELECT("RSN"[X:"O","UV"[X:"I",1:$$GETCLS)
+9 IF CLS="O"
IF ORPK=+ORPK!(ORPK["R")
DO RX^VPRDPSO(ORPK,.MED)
SET MED("id")=IFN
QUIT
+10 SET MED("id")=IFN
SET MED("orderID")=IFN
SET MED("vaType")=CLS
+11 if ORPK
SET MED("medID")=ORPK_";"_CLS
+12 DO EN^ORX8(IFN)
SET X=""
FOR
SET X=$ORDER(ORUPCHUK(X))
if X=""
QUIT
if $DATA(ORUPCHUK(X))#2
SET @X=ORUPCHUK(X)
+13 SET MED("ordered")=$GET(ORODT)
SET MED("orderingProvider")=$GET(ORNP)_U_$$PROVSPC^VPRD(+ORNP)
+14 SET X=$$LASTPROV(IFN)
SET MED("currentProvider")=X_U_$$PROVSPC^VPRD(+X)
+15 SET MED("start")=$GET(ORSTRT)
SET MED("stop")=$GET(ORSTOP)
+16 SET MED("vaStatus")=$PIECE($GET(ORSTS),U,2)
SET MED("status")=$$STATUS(+$GET(ORSTS))
+17 SET X=$$VALUE^ORX8(IFN,"INDICATION")
if $LENGTH(X)
SET MED("indication")=X
+18 SET LOC=+$GET(ORL)
if LOC
SET MED("location")=LOC_U_$PIECE(^SC(LOC,0),U)
+19 IF CLS="I"
Begin DoDot:1
+20 if $PIECE($GET(^SC(+$GET(LOC),0)),U,25)
SET MED("IMO")=1
+21 SET X=$PIECE($GET(^OR(100,IFN,3)),U,9)
if X
SET MED("parent")=X
End DoDot:1
+22 SET MED("facility")=$$FAC^VPRD(LOC)
IF ORPK
Begin DoDot:1
+23 NEW IFN
DO OEL^PSOORRL(DFN,ORPK_";"_CLS)
End DoDot:1
+24 IF $$IV
DO IV^VPRDPSI
QUIT
+25 if CLS="O"
SET MED("type")="Prescription"
+26 if ORPK["N"
SET MED("vaType")="N"
SET MED("type")="OTC"
ENA ; get order responses
+1 SET OI=$$OI^ORX8(IFN)
IF OI
SET MED("name")=$PIECE(OI,U,2)
Begin DoDot:1
+2 DO ZERO^PSS50P7(+$PIECE(OI,U,3),,,"PSOI")
+3 SET MED("form")=$PIECE($GET(^TMP($JOB,"PSOI",+$PIECE(OI,U,3),.02)),U,2)
+4 if +$GET(^TMP($JOB,"PSOI",+$PIECE(OI,U,3),.09))
SET MED("supply")=1
End DoDot:1
+5 ;order responses
DO RESP(IFN,.VPRESP)
+6 SET DRUG=+$GET(^TMP("PS",$JOB,"DD",1,0))
if 'DRUG
SET DRUG=+$GET(VPRESP("DRUG",1))
+7 ;ORTX(2)
SET MED("sig")=$SELECT(CLS="I":"Give: ",1:"")_$GET(VPRESP("SIG",1))
+8 ;UD or NVA: single dose, or child orders
IF CLS="I"!(ORPK["N")
Begin DoDot:1
+9 IF '$ORDER(^OR(100,IFN,2,0))
SET MED("dose",1)=$$DOSE(1)_U_$GET(ORSTRT)_U_$GET(ORSTOP)
QUIT
+10 NEW DD,CONJ
MERGE CONJ=VPRESP("CONJ")
+11 SET (DA,CNT)=0
FOR
SET DA=$ORDER(^OR(100,IFN,2,DA))
if DA<1
QUIT
Begin DoDot:2
+12 KILL VPRESP
DO RESP(DA,.VPRESP)
+13 SET CNT=CNT+1
SET MED("dose",CNT)=$$DOSE(1)_U_$PIECE($GET(^OR(100,DA,0)),U,8,9)_U_DA
+14 SET $PIECE(MED("dose",CNT),U,8)=$GET(CONJ(CNT))
+15 IF $PIECE(MED("dose",CNT),U,10)>$GET(ORSTOP)
SET ORSTOP=$PIECE(MED("dose",CNT),U,10)
+16 ;dispense drug(s)
if 'DRUG
SET DD=+$GET(VPRESP("DRUG",1))
SET DD(DD,DA)=""
+17 ; get ^TMP("PS",$J) from 1st child, if Inpt parent:
+18 IF '$DATA(^TMP("PS",$JOB))
SET ORPK=$$PKGID^ORX8(DA)
DO OEL^PSOORRL(DFN,ORPK_";"_CLS)
End DoDot:2
+19 ;reset from last child order
SET MED("stop")=$GET(ORSTOP)
+20 ;1 drug for order
SET DD=$ORDER(DD(0))
IF DD
IF '$ORDER(DD(DD))
SET DRUG=DD
QUIT
+21 SET (DD,CNT)=0
FOR
SET DD=$ORDER(DD(DD))
if DD<1
QUIT
SET DA=0
FOR
SET DA=$ORDER(DD(DD,DA))
if DA<1
QUIT
SET CNT=CNT+1
DO NDF^VPRDPS(DD,CNT,DA)
End DoDot:1
GOTO ENQ
+22 ; pending Rx: dose(s), qty, etc.
+23 ;_STRT^STOP
SET CNT=0
FOR
SET CNT=$ORDER(VPRESP("INSTR",CNT))
if CNT<1
QUIT
SET MED("dose",CNT)=$$DOSE(CNT)
+24 SET MED("quantity")=$GET(VPRESP("QTY",1))
+25 SET MED("daysSupply")=$GET(VPRESP("SUPPLY",1))
+26 SET MED("routing")=$GET(VPRESP("PICKUP",1))
+27 SET MED("fillsAllowed")=$GET(VPRESP("REFILLS",1))
+28 SET MED("ptInstructions")=$GET(VPRESP("PI",1))
ENQ ; finish
+1 if DRUG
DO NDF^VPRDPS(+DRUG)
+2 SET X=+$PIECE($GET(^TMP("PS",$JOB,"RXN",0)),U,5)
+3 if X
SET MED("pharmacist")=X_U_$PIECE($GET(^VA(200,X,0)),U)
+4 KILL ^TMP("PS",$JOB),^TMP($JOB,"PSOI")
+5 QUIT
+6 ;
IV() ; -- Return 1 or 0, if order is for IV/infusion
+1 IF ORPK["V"
QUIT 1
+2 IF $PIECE($GET(ORTO),U,2)?1"IV".E
QUIT 1
+3 IF +$GET(ORPCL)=130
QUIT 1
+4 IF $GET(^TMP("PS",$JOB,"B",0))
QUIT 1
+5 QUIT 0
+6 ;
DOSE(N) ; --add dosage data from VPRESP(ID,N) [instance N]
+1 NEW DOSE,X,ID
SET N=+$GET(N,1)
+2 SET DOSE=$PIECE($GET(VPRESP("DOSE",N)),"&",1,4)
SET DOSE=$TRANSLATE(DOSE,"&","^")
+3 IF '$LENGTH($PIECE(DOSE,U))
SET DOSE=$GET(VPRESP("INSTR",N))_"^^^"
+4 SET X=+$GET(VPRESP("ROUTE",N))
DO ALL^PSS51P2(X,,,,"VPRTE")
+5 SET DOSE=DOSE_U_$GET(^TMP($JOB,"VPRTE",X,1))
+6 FOR ID="SCHEDULE","DAYS","CONJ"
SET DOSE=DOSE_U_$GET(VPRESP(ID,N))
+7 KILL ^TMP($JOB,"VPRTE")
+8 QUIT DOSE
+9 ;
LASTPROV(IFN) ; -- return last provider who took action on order IFN
+1 NEW I,X,Y
SET Y="^"
+2 SET I="A"
FOR
SET I=$ORDER(^OR(100,IFN,8,I),-1)
if I<1
QUIT
SET X=$GET(^(I,0))
Begin DoDot:1
+3 ;signer
IF $PIECE(X,U,5)
SET Y=+$PIECE(X,U,5)
QUIT
+4 ;orderer
IF $PIECE(X,U,3)
SET Y=+$PIECE(X,U,3)
QUIT
End DoDot:1
if Y
QUIT
+5 if Y
SET Y=Y_U_$PIECE($GET(^VA(200,Y,0)),U)
+6 QUIT Y
+7 ;
STRING(IFN,ID) ; -- return text value as a string
+1 NEW DA,I,X,Y
+2 SET DA=+$ORDER(^OR(100,IFN,4.5,"ID",ID,0))
if DA<1
QUIT ""
+3 SET I=+$ORDER(^OR(100,IFN,4.5,DA,2,0))
SET Y=$GET(^(I,0))
+4 FOR
SET I=+$ORDER(^OR(100,IFN,4.5,DA,2,I))
if I<1
QUIT
SET X=$GET(^(I,0))
Begin DoDot:1
+5 IF $EXTRACT(Y,$LENGTH(Y))'=" "
SET Y=Y_" "
+6 SET Y=Y_X
End DoDot:1
+7 QUIT Y
+8 ;
STATUS(X) ; -- return HITSP status for 100.01 #X
+1 ;no status
SET X=+$GET(X)
if 'X
SET X=99
+2 IF X=3
QUIT "hold"
+3 IF X=10!(X=11)!(X=5)
QUIT "not active"
+4 IF X=1!(X=12)!(X=13)
QUIT "not active"
+5 IF X=14!(X=99)
QUIT "not active"
+6 IF X=2!(X=7)!(X=15)
QUIT "historical"
+7 QUIT "active"
+8 ;
RESP(ORIFN,RESP) ; -- return order responses [internal form]
+1 NEW VPRDLG,I,J,W,ID,TYPE,X,Y
+2 IF '$DATA(ORDIALOG)
SET ORDIALOG=129
DO GETDLG1^ORCD(129)
+3 DO GETORDER^ORCD(+$GET(ORIFN),"VPRDLG")
+4 SET I=0
FOR
SET I=$ORDER(VPRDLG(I))
if I<1
QUIT
Begin DoDot:1
+5 SET ID=$PIECE($GET(ORDIALOG(I)),U,2)
if '$LENGTH(ID)
QUIT
+6 SET TYPE=$PIECE($GET(ORDIALOG(I,0)),U)
+7 SET J=0
FOR
SET J=$ORDER(VPRDLG(I,J))
if J<1
QUIT
IF $DATA(VPRDLG(I,J))
Begin DoDot:2
+8 SET X=VPRDLG(I,J)
IF TYPE'="W"
SET RESP(ID,J)=X
QUIT
+9 SET Y=$GET(@X@(1,0))
SET W=1
FOR
SET W=$ORDER(@X@(W))
if W<1
QUIT
SET Y=Y_$SELECT($EXTRACT(Y,$LENGTH(Y))'=" ":" ",1:"")_$GET(@X@(W,0))
+10 if $LENGTH(Y)
SET RESP(ID,J)=Y
End DoDot:2
End DoDot:1
+11 QUIT
GETCLS() ; p18 added package check
+1 NEW PKGIEN
SET PKGIEN=$$GET1^DIQ(100,IFN_",",12,"I")
+2 IF $PIECE($GET(^DIC(9.4,PKGIEN,0)),U)="INPATIENT MEDICATIONS"
QUIT "I"
+3 IF $PIECE($GET(^DIC(9.4,PKGIEN,0)),U)="OUTPATIENT PHARMACY"
QUIT "O"
+4 QUIT $$GET1^DIQ(100,IFN_",",10,"I")
+5 ;
RX(ORIFN) ; -- is order really a med? (non-PS order in display group)
+1 NEW X,Y,PKG
SET Y=0
+2 SET X=$PIECE($GET(^OR(100,+$GET(ORIFN),0)),U,14)
SET PKG=$$GET1^DIQ(9.4,+X_",",1)
+3 IF $EXTRACT(PKG,1,2)="PS"
SET Y=1
+4 QUIT Y
