Routine: VPRDPSOR

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")

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")

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

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

VPRDPSOR.m