- 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 Feb 19, 2025@00:11:23 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