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")
Q
;
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)
Q
;
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>")
Q
;
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDPS 4459 printed Sep 23, 2025@20:21:15 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
