NHINVPS ;SLC/MKB -- Pharmacy extract
;;1.0;NHIN;**1**;Dec 01, 2009;Build 11
;
; External References DBIA#
; ------------------- -----
; DIQ 2056
; PSOORRL,^TMP("PS",$J) 2400
; PSS50,^TMP($J 4483
;
; ------------ Get medications from VistA ------------
;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's meds
N PS0,NHI,NHITM,IV K ^TMP("PS",$J)
S DFN=+$G(DFN) Q:DFN<1
S BEG=$G(BEG,1410101),END=$G(END,9999998),MAX=$G(MAX,999999)
;
; get one med
I $G(ID) D D:$D(NHITM)>9 XML(.NHITM) K ^TMP("PS",$J) Q
. I ID["N" D NVA^NHINVPSO(ID,.NHITM) Q
. I ID["O",(ID'["P")&(ID'["S") D RX^NHINVPSO(ID,.NHITM) Q
. D OEL^PSOORRL(DFN,ID)
. I ID["O",(ID["P")!(ID["S") D PEN1^NHINVPSO(ID,.NHITM) Q
. S IV=$S(ID["V":1,$G(^TMP("PS",$J,"B",0)):1,1:0)
. D @($S(IV:"IV1",1:"IN1")_"^NHINVPSI(ID,.NHITM)")
;
; get all meds
D OCL^PSOORRL(DFN,BEG,END)
S NHI=0 F S NHI=$O(^TMP("PS",$J,NHI)) Q:NHI<1!(NHI>MAX) S PS0=$G(^(NHI,0)) D I $D(NHITM)>9 D XML(.NHITM)
. S ID=$P(PS0,U) K NHITM
. I ID["N" D NVA^NHINVPSO(ID,.NHITM) Q
. I ID["O" D RX^NHINVPSO(ID,.NHITM) Q
. S IV=$S(ID["V":1,$G(^TMP("PS",$J,NHI,"B",0)):1,1:0)
. D @($S(IV:"IV",1:"IN")_"^NHINVPSI(ID,.NHITM)")
K ^TMP("PS",$J)
Q
;
NDF(DRUG,I) ; -- Set NDF data for dispense DRUG ien
N VUID,X
S DRUG=+$G(DRUG) Q:'DRUG
D NDF^PSS50(DRUG,,,,,"NDF") S I=+$G(I)+1
S MED("product",I)=DRUG_U_$G(^TMP($J,"NDF",DRUG,.01))_"^^D" ;Drug
S X=$G(^TMP($J,"NDF",DRUG,20)),VUID=$$GET1^DIQ(50.6,+X_",",99.99)
S MED("product",I,"G")=X_U_VUID ;VA Generic
S X=$G(^TMP($J,"NDF",DRUG,22)),VUID=$$GET1^DIQ(50.68,+X_",",99.99)
S MED("product",I,"P")=X_U_VUID ;VA Product
S MED("product",I,"C")=$P($G(^TMP($J,"NDF",+DRUG,25)),U,3) ;display name
K ^TMP($J,"NDF",DRUG)
Q
;
; ------------ Return data to middle tier ------------
;
XML(MED) ; -- Return patient meds as XML
N ATT,X,Y,I,NAMES
D ADD("<med>") S NHINTOTL=$G(NHINTOTL)+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^Z"
... I ATT="fill" S NAMES="fillDate^fillRouting^releaseDate^fillQuantity^fillDaysSupply^partial^Z"
... I ATT="product" S NAMES="code^name^vuid^role^concentration^Z"
... S Y="<"_ATT_" "_$$LOOP_$S(ATT'="product":"/>",1:">") D ADD(Y)
... Q:ATT'="product"
... 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^NHINV(X)_"</"_ATT_">" Q
. I X'["^" S Y="<"_ATT_" value='"_$$ESC^NHINV(X)_"' />" Q
. I $L(X)>1 S NAMES="code^name^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^NHINV($P(X,U,P))_"' "
Q STR
;
ADD(X) ; Add a line @NHIN@(n)=X
S NHINI=$G(NHINI)+1
S @NHIN@(NHINI)=X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNHINVPS 3405 printed Dec 13, 2024@02:17:21 Page 2
NHINVPS ;SLC/MKB -- Pharmacy extract
+1 ;;1.0;NHIN;**1**;Dec 01, 2009;Build 11
+2 ;
+3 ; External References DBIA#
+4 ; ------------------- -----
+5 ; DIQ 2056
+6 ; PSOORRL,^TMP("PS",$J) 2400
+7 ; PSS50,^TMP($J 4483
+8 ;
+9 ; ------------ Get medications from VistA ------------
+10 ;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's meds
+1 NEW PS0,NHI,NHITM,IV
KILL ^TMP("PS",$JOB)
+2 SET DFN=+$GET(DFN)
if DFN<1
QUIT
+3 SET BEG=$GET(BEG,1410101)
SET END=$GET(END,9999998)
SET MAX=$GET(MAX,999999)
+4 ;
+5 ; get one med
+6 IF $GET(ID)
Begin DoDot:1
+7 IF ID["N"
DO NVA^NHINVPSO(ID,.NHITM)
QUIT
+8 IF ID["O"
IF (ID'["P")&(ID'["S")
DO RX^NHINVPSO(ID,.NHITM)
QUIT
+9 DO OEL^PSOORRL(DFN,ID)
+10 IF ID["O"
IF (ID["P")!(ID["S")
DO PEN1^NHINVPSO(ID,.NHITM)
QUIT
+11 SET IV=$SELECT(ID["V":1,$GET(^TMP("PS",$JOB,"B",0)):1,1:0)
+12 DO @($SELECT(IV:"IV1",1:"IN1")_"^NHINVPSI(ID,.NHITM)")
End DoDot:1
if $DATA(NHITM)>9
DO XML(.NHITM)
KILL ^TMP("PS",$JOB)
QUIT
+13 ;
+14 ; get all meds
+15 DO OCL^PSOORRL(DFN,BEG,END)
+16 SET NHI=0
FOR
SET NHI=$ORDER(^TMP("PS",$JOB,NHI))
if NHI<1!(NHI>MAX)
QUIT
SET PS0=$GET(^(NHI,0))
Begin DoDot:1
+17 SET ID=$PIECE(PS0,U)
KILL NHITM
+18 IF ID["N"
DO NVA^NHINVPSO(ID,.NHITM)
QUIT
+19 IF ID["O"
DO RX^NHINVPSO(ID,.NHITM)
QUIT
+20 SET IV=$SELECT(ID["V":1,$GET(^TMP("PS",$JOB,NHI,"B",0)):1,1:0)
+21 DO @($SELECT(IV:"IV",1:"IN")_"^NHINVPSI(ID,.NHITM)")
End DoDot:1
IF $DATA(NHITM)>9
DO XML(.NHITM)
+22 KILL ^TMP("PS",$JOB)
+23 QUIT
+24 ;
NDF(DRUG,I) ; -- Set NDF data for dispense DRUG ien
+1 NEW VUID,X
+2 SET DRUG=+$GET(DRUG)
if 'DRUG
QUIT
+3 DO NDF^PSS50(DRUG,,,,,"NDF")
SET I=+$GET(I)+1
+4 ;Drug
SET MED("product",I)=DRUG_U_$GET(^TMP($JOB,"NDF",DRUG,.01))_"^^D"
+5 SET X=$GET(^TMP($JOB,"NDF",DRUG,20))
SET VUID=$$GET1^DIQ(50.6,+X_",",99.99)
+6 ;VA Generic
SET MED("product",I,"G")=X_U_VUID
+7 SET X=$GET(^TMP($JOB,"NDF",DRUG,22))
SET VUID=$$GET1^DIQ(50.68,+X_",",99.99)
+8 ;VA Product
SET MED("product",I,"P")=X_U_VUID
+9 ;display name
SET MED("product",I,"C")=$PIECE($GET(^TMP($JOB,"NDF",+DRUG,25)),U,3)
+10 KILL ^TMP($JOB,"NDF",DRUG)
+11 QUIT
+12 ;
+13 ; ------------ Return data to middle tier ------------
+14 ;
XML(MED) ; -- Return patient meds as XML
+1 NEW ATT,X,Y,I,NAMES
+2 DO ADD("<med>")
SET NHINTOTL=$GET(NHINTOTL)+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^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^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,"C"))
IF $LENGTH(X)
SET Y="<class "_$$LOOP_"/>"
DO ADD(Y)
+14 SET X=$GET(MED(ATT,I,"G"))
IF $LENGTH(X)
SET Y="<vaGeneric "_$$LOOP_"/>"
DO ADD(Y)
+15 SET X=$GET(MED(ATT,I,"P"))
IF $LENGTH(X)
SET Y="<vaProduct "_$$LOOP_"/>"
DO ADD(Y)
+16 DO ADD("</product>")
End DoDot:3
+17 DO ADD("</"_ATT_"s>")
End DoDot:2
SET Y=""
QUIT
+18 SET X=$GET(MED(ATT))
SET Y=""
if '$LENGTH(X)
QUIT
+19 IF ATT="sig"!(ATT?1"ptIn"1.A)
SET Y="<"_ATT_" xml:space='preserve'>"_$$ESC^NHINV(X)_"</"_ATT_">"
QUIT
+20 IF X'["^"
SET Y="<"_ATT_" value='"_$$ESC^NHINV(X)_"' />"
QUIT
+21 IF $LENGTH(X)>1
SET NAMES="code^name^Z"
SET Y="<"_ATT_" "_$$LOOP_"/>"
End DoDot:1
IF $LENGTH(Y)
DO ADD(Y)
+22 DO ADD("</med>")
+23 QUIT
+24 ;
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^NHINV($PIECE(X,U,P))_"' "
+3 QUIT STR
+4 ;
ADD(X) ; Add a line @NHIN@(n)=X
+1 SET NHINI=$GET(NHINI)+1
+2 SET @NHIN@(NHINI)=X
+3 QUIT
