Routine: VPRDPS

VPRDPS ;SLC/MKB -- Pharmacy extract ;8/2/11  15:29

 ;;1.0;VIRTUAL PATIENT RECORD;**1,4,5**;Sep 01, 2011;Build 21

 ;;Per VHA Directive 2004-038, this routine should not be modified.

 ; External References          DBIA#

 ; -------------------          -----

 ; ^OR(100)                      5771

 ; ORX8                          2467

 ; PSOORRL,^TMP("PS",$J)         2400

 ; PSS50,^TMP($J                 4533

 ; PSS50P7,^TMP($J               4662

 ; PSSDI                         4551

 ; ------------ Get medications from VistA ------------

EN(DFN,BEG,END,MAX,ORIFN) ; -- find patient's meds

 N PS0,VPRN,VPRITM,TYPE,ID K ^TMP("PS",$J)

 S DFN=+$G(DFN) Q:DFN<1

 S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)

 ; get one med

 I $G(ORIFN) D EN1^VPRDPSOR(ORIFN,.VPRITM),XML(.VPRITM):$D(VPRITM) Q

 ; get all meds

 D OCL^PSOORRL(DFN,BEG,END) M ^TMP("VPRPS",$J)=^TMP("PS",$J)

 S TYPE=$G(FILTER("vaType"))

 S VPRN=0 F  S VPRN=$O(^TMP("VPRPS",$J,VPRN)) Q:VPRN<1!(VPRN>MAX)  S PS0=$G(^(VPRN,0)) D  I $D(VPRITM)>9 D XML(.VPRITM)

 . S ID=$P(PS0,U),ORIFN=+$P(PS0,U,8) K VPRITM

 . Q:'ORIFN!'$D(^OR(100,ORIFN,0))

 . I $L(TYPE) Q:'$$MATCH

 . D:ORIFN EN1^VPRDPSOR(ORIFN,.VPRITM)

 K ^TMP("VPRPS",$J),^TMP("PS",$J),^TMP($J,"PSOI")

MATCH() ; -- Return 1 or 0, if order matches FILTER criteria

 N Y S Y=0

 I ID["O" D

 . I TYPE="N",ID["N" S Y=1 Q

 . I TYPE="O",ID'["N" S Y=1 Q

 . ; TYPE="S",ID'["N",$$SUPPLY(ORIFN) S Y=1 Q

 I ID["I" D

 . N IV S IV=$S(ID["V":1,$G(^TMP("VPRPS",$J,VPRN,"B",0)):1,1:0)

 . I TYPE="V",IV S Y=1

 . I TYPE="I",'IV S Y=1

Q Y

SUPPLY(ORDER) ; -- Return 1 or 0, if ORDER is for a supply item

 N OI,Y S OI=$$OI^ORX8(ORDER),Y=0

 D ZERO^PSS50P7(+$P(OI,U,3),,,"PSOI")

 S Y=+$G(^TMP($J,"PSOI",+$P(OI,U,3),.09))

Q Y

NDF(DRUG,VPI,ORD) ; -- Set NDF data for dispense DRUG ien

 N VPRX,STR,VUID,X,I

 S DRUG=+$G(DRUG) Q:'DRUG

 D EN^PSSDI(50,,50,"901;902",DRUG,"VPRX")

 S STR=$S($G(VPRX(50,DRUG,901)):$G(VPRX(50,DRUG,901))_" "_$G(VPRX(50,DRUG,902)),1:"")

 D NDF^PSS50(DRUG,,,,,"NDF") S VPI=+$G(VPI,1)

 S MED("product",VPI)=DRUG_U_$G(^TMP($J,"NDF",DRUG,.01))_"^^D^"_STR_U_$G(ORD) ;Drug

 S X=$G(^TMP($J,"NDF",DRUG,20)) ;VA Generic

 S MED("product",VPI,"G")=X_U_$$VUID^VPRD(+X,50.6)

 S X=$G(^TMP($J,"NDF",DRUG,22)) ;VA Product

 S MED("product",VPI,"P")=X_U_$$VUID^VPRD(+X,50.68)

 S X=$G(^TMP($J,"NDF",DRUG,25)) ;VA Drug Class

 S MED("product",VPI,"C")=$P(X,U,2,3)_U_$$VUID^VPRD(+X,50.605)

 K ^TMP($J,"NDF",DRUG)

VUID(ORDER) ; -- return VUID for VA Product in ORDER

 N X,Y,DRUG S Y=""

 S DRUG=$$VALUE^ORX8(+$G(ORDER),"DRUG")

 I DRUG D

 . D NDF^PSS50(DRUG,,,,,"NDF")

 . S X=$G(^TMP($J,"NDF",DRUG,22)),Y=$$VUID^VPRD(+X,50.68)

 . K ^TMP($J,"NDF")

Q Y

 ; ------------ Return data to middle tier ------------

XML(MED) ; -- Return patient meds as XML

 N ATT,X,Y,I,NAMES

 D ADD("<med>") S VPRTOTL=$G(VPRTOTL)+1

 S ATT="" F  S ATT=$O(MED(ATT)) Q:ATT=""  D  I $L(Y) D ADD(Y)

 . I $O(MED(ATT,0)) D  S Y="" Q  ;multiples

 .. D ADD("<"_ATT_"s>")

 .. S I=0 F  S I=$O(MED(ATT,I)) Q:I<1  D

 ... S X=$G(MED(ATT,I)),NAMES=""

 ... I ATT="dose" S NAMES="dose^units^unitsPerDose^noun^route^schedule^duration^conjunction^doseStart^doseStop^order^Z"

 ... I ATT="fill" S NAMES="fillDate^fillRouting^releaseDate^fillQuantity^fillDaysSupply^partial^Z"

 ... I ATT="product" S NAMES="code^name^vuid^role^concentration^order^Z"

 ... S Y="<"_ATT_" "_$$LOOP_$S(ATT'="product":"/>",1:">") D ADD(Y)

 ... Q:ATT'="product"

 ... S X=$G(MED(ATT,I,"O")) I $L(X) S Y="<ordItem "_$$LOOP_"/>" D ADD(Y)

 ... S X=$G(MED(ATT,I,"C")) I $L(X) S Y="<class "_$$LOOP_"/>" D ADD(Y)

 ... S X=$G(MED(ATT,I,"G")) I $L(X) S Y="<vaGeneric "_$$LOOP_"/>" D ADD(Y)

 ... S X=$G(MED(ATT,I,"P")) I $L(X) S Y="<vaProduct "_$$LOOP_"/>" D ADD(Y)

 ... D ADD("</product>")

 .. D ADD("</"_ATT_"s>")

 . S X=$G(MED(ATT)),Y="" Q:'$L(X)

 . I ATT="sig"!(ATT?1"ptIn"1.A) S Y="<"_ATT_" xml:space='preserve'>"_$$ESC^VPRD(X)_"</"_ATT_">" Q

 . I X'["^" S Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />" Q

 . I $L(X)>1 S NAMES="code^name"_$S(ATT["Provider":U_$$PROVTAGS^VPRD,1:"")_"^Z",Y="<"_ATT_" "_$$LOOP_"/>"

 D ADD("</med>")

LOOP() ; -- build sub-items string from NAMES and X

 N STR,P,TAG S STR=""

 F P=1:1 S TAG=$P(NAMES,U,P) Q:TAG="Z"  I $L($P(X,U,P)) S STR=STR_TAG_"='"_$$ESC^VPRD($P(X,U,P))_"' "

 Q STR

ADD(X) ; Add a line @VPR@(n)=X

 S VPRI=$G(VPRI)+1

 S @VPR@(VPRI)=X

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDPS   4459     printed  Feb 19, 2025@00:11:20                                                                                                                                                                                                      Page 2

VPRDPS    ;SLC/MKB -- Pharmacy extract ;8/2/11  15:29

 +1       ;;1.0;VIRTUAL PATIENT RECORD;**1,4,5**;Sep 01, 2011;Build 21

 +2       ;;Per VHA Directive 2004-038, this routine should not be modified.

 +3       ;

 +4       ; External References          DBIA#

 +5       ; -------------------          -----

 +6       ; ^OR(100)                      5771

 +7       ; ORX8                          2467

 +8       ; PSOORRL,^TMP("PS",$J)         2400

 +9       ; PSS50,^TMP($J                 4533

 +10      ; PSS50P7,^TMP($J               4662

 +11      ; PSSDI                         4551

 +12      ;

 +13      ; ------------ Get medications from VistA ------------

 +14      ;

EN(DFN,BEG,END,MAX,ORIFN) ; -- find patient's meds

 +1        NEW PS0,VPRN,VPRITM,TYPE,ID

           KILL ^TMP("PS",$JOB)

 +2        SET DFN=+$GET(DFN)

           if DFN<1

               QUIT

 +3        SET BEG=$GET(BEG,1410101)

           SET END=$GET(END,4141015)

           SET MAX=$GET(MAX,9999)

 +4       ;

 +5       ; get one med

 +6        IF $GET(ORIFN)

               DO EN1^VPRDPSOR(ORIFN,.VPRITM)

               if $DATA(VPRITM)

                   DO XML(.VPRITM)

               QUIT

 +7       ;

 +8       ; get all meds

 +9        DO OCL^PSOORRL(DFN,BEG,END)

           MERGE ^TMP("VPRPS",$JOB)=^TMP("PS",$JOB)

 +10       SET TYPE=$GET(FILTER("vaType"))

 +11       SET VPRN=0

FOR

               SET VPRN=$ORDER(^TMP("VPRPS",$JOB,VPRN))

               if VPRN<1!(VPRN>MAX)

                   QUIT

               SET PS0=$GET(^(VPRN,0))

               Begin DoDot:1

 +12               SET ID=$PIECE(PS0,U)

                   SET ORIFN=+$PIECE(PS0,U,8)

                   KILL VPRITM

 +13               if 'ORIFN!'$DATA(^OR(100,ORIFN,0))

                       QUIT

 +14               IF $LENGTH(TYPE)

                       if '$$MATCH

                           QUIT

 +15               if ORIFN

                       DO EN1^VPRDPSOR(ORIFN,.VPRITM)

               End DoDot:1

               IF $DATA(VPRITM)>9

                   DO XML(.VPRITM)

 +16       KILL ^TMP("VPRPS",$JOB),^TMP("PS",$JOB),^TMP($JOB,"PSOI")

 +17       QUIT

 +18      ;

MATCH()   ; -- Return 1 or 0, if order matches FILTER criteria

 +1        NEW Y

           SET Y=0

 +2        IF ID["O"

               Begin DoDot:1

 +3                IF TYPE="N"

                       IF ID["N"

                           SET Y=1

                           QUIT

 +4                IF TYPE="O"

                       IF ID'["N"

                           SET Y=1

                           QUIT

 +5       ; TYPE="S",ID'["N",$$SUPPLY(ORIFN) S Y=1 Q

               End DoDot:1

 +6        IF ID["I"

               Begin DoDot:1

 +7                NEW IV

                   SET IV=$SELECT(ID["V":1,$GET(^TMP("VPRPS",$JOB,VPRN,"B",0)):1,1:0)

 +8                IF TYPE="V"

                       IF IV

                           SET Y=1

 +9                IF TYPE="I"

                       IF 'IV

                           SET Y=1

               End DoDot:1

 +10       QUIT Y

 +11      ;

SUPPLY(ORDER) ; -- Return 1 or 0, if ORDER is for a supply item

 +1        NEW OI,Y

           SET OI=$$OI^ORX8(ORDER)

           SET Y=0

 +2        DO ZERO^PSS50P7(+$PIECE(OI,U,3),,,"PSOI")

 +3        SET Y=+$GET(^TMP($JOB,"PSOI",+$PIECE(OI,U,3),.09))

 +4        QUIT Y

 +5       ;

NDF(DRUG,VPI,ORD) ; -- Set NDF data for dispense DRUG ien

 +1        NEW VPRX,STR,VUID,X,I

 +2        SET DRUG=+$GET(DRUG)

           if 'DRUG

               QUIT

 +3        DO EN^PSSDI(50,,50,"901;902",DRUG,"VPRX")

 +4        SET STR=$SELECT($GET(VPRX(50,DRUG,901)):$GET(VPRX(50,DRUG,901))_" "_$GET(VPRX(50,DRUG,902)),1:"")

 +5        DO NDF^PSS50(DRUG,,,,,"NDF")

           SET VPI=+$GET(VPI,1)

 +6       ;Drug

           SET MED("product",VPI)=DRUG_U_$GET(^TMP($JOB,"NDF",DRUG,.01))_"^^D^"_STR_U_$GET(ORD)

 +7       ;VA Generic

           SET X=$GET(^TMP($JOB,"NDF",DRUG,20))

 +8        SET MED("product",VPI,"G")=X_U_$$VUID^VPRD(+X,50.6)

 +9       ;VA Product

           SET X=$GET(^TMP($JOB,"NDF",DRUG,22))

 +10       SET MED("product",VPI,"P")=X_U_$$VUID^VPRD(+X,50.68)

 +11      ;VA Drug Class

           SET X=$GET(^TMP($JOB,"NDF",DRUG,25))

 +12       SET MED("product",VPI,"C")=$PIECE(X,U,2,3)_U_$$VUID^VPRD(+X,50.605)

 +13       KILL ^TMP($JOB,"NDF",DRUG)

 +14       QUIT

 +15      ;

VUID(ORDER) ; -- return VUID for VA Product in ORDER

 +1        NEW X,Y,DRUG

           SET Y=""

 +2        SET DRUG=$$VALUE^ORX8(+$GET(ORDER),"DRUG")

 +3        IF DRUG

               Begin DoDot:1

 +4                DO NDF^PSS50(DRUG,,,,,"NDF")

 +5                SET X=$GET(^TMP($JOB,"NDF",DRUG,22))

                   SET Y=$$VUID^VPRD(+X,50.68)

 +6                KILL ^TMP($JOB,"NDF")

               End DoDot:1

 +7        QUIT Y

 +8       ;

 +9       ; ------------ Return data to middle tier ------------

 +10      ;

XML(MED)  ; -- Return patient meds as XML

 +1        NEW ATT,X,Y,I,NAMES

 +2        DO ADD("<med>")

           SET VPRTOTL=$GET(VPRTOTL)+1

 +3        SET ATT=""

FOR

               SET ATT=$ORDER(MED(ATT))

               if ATT=""

                   QUIT

               Begin DoDot:1

 +4       ;multiples

                   IF $ORDER(MED(ATT,0))

                       Begin DoDot:2

 +5                        DO ADD("<"_ATT_"s>")

 +6                        SET I=0

FOR

                               SET I=$ORDER(MED(ATT,I))

                               if I<1

                                   QUIT

                               Begin DoDot:3

 +7                                SET X=$GET(MED(ATT,I))

                                   SET NAMES=""

 +8                                IF ATT="dose"

                                       SET NAMES="dose^units^unitsPerDose^noun^route^schedule^duration^conjunction^doseStart^doseStop^order^Z"

 +9                                IF ATT="fill"

                                       SET NAMES="fillDate^fillRouting^releaseDate^fillQuantity^fillDaysSupply^partial^Z"

 +10                               IF ATT="product"

                                       SET NAMES="code^name^vuid^role^concentration^order^Z"

 +11                               SET Y="<"_ATT_" "_$$LOOP_$S(ATT'="product":"/>",1:">")

                                   DO ADD(Y)

 +12                               if ATT'="product"

                                       QUIT

 +13                               SET X=$GET(MED(ATT,I,"O"))

                                   IF $LENGTH(X)

                                       SET Y="<ordItem "_$$LOOP_"/>"

                                       DO ADD(Y)

 +14                               SET X=$GET(MED(ATT,I,"C"))

                                   IF $LENGTH(X)

                                       SET Y="<class "_$$LOOP_"/>"

                                       DO ADD(Y)

 +15                               SET X=$GET(MED(ATT,I,"G"))

                                   IF $LENGTH(X)

                                       SET Y="<vaGeneric "_$$LOOP_"/>"

                                       DO ADD(Y)

 +16                               SET X=$GET(MED(ATT,I,"P"))

                                   IF $LENGTH(X)

                                       SET Y="<vaProduct "_$$LOOP_"/>"

                                       DO ADD(Y)

 +17                               DO ADD("</product>")

                               End DoDot:3

 +18                       DO ADD("</"_ATT_"s>")

                       End DoDot:2

                       SET Y=""

                       QUIT

 +19               SET X=$GET(MED(ATT))

                   SET Y=""

                   if '$LENGTH(X)

                       QUIT

 +20               IF ATT="sig"!(ATT?1"ptIn"1.A)

                       SET Y="<"_ATT_" xml:space='preserve'>"_$$ESC^VPRD(X)_"</"_ATT_">"

                       QUIT

 +21               IF X'["^"

                       SET Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />"

                       QUIT

 +22               IF $LENGTH(X)>1

                       SET NAMES="code^name"_$SELECT(ATT["Provider":U_$$PROVTAGS^VPRD,1:"")_"^Z"

                       SET Y="<"_ATT_" "_$$LOOP_"/>"

               End DoDot:1

               IF $LENGTH(Y)

                   DO ADD(Y)

 +23       DO ADD("</med>")

 +24       QUIT

 +25      ;

LOOP()    ; -- build sub-items string from NAMES and X

 +1        NEW STR,P,TAG

           SET STR=""

 +2        FOR P=1:1

               SET TAG=$PIECE(NAMES,U,P)

               if TAG="Z"

                   QUIT

               IF $LENGTH($PIECE(X,U,P))

                   SET STR=STR_TAG_"='"_$$ESC^VPRD($PIECE(X,U,P))_"' "

 +3        QUIT STR

 +4       ;

ADD(X)    ; Add a line @VPR@(n)=X

 +1        SET VPRI=$GET(VPRI)+1

 +2        SET @VPR@(VPRI)=X

 +3        QUIT

VPRDPS.m