VPRDGMRA ;SLC/MKB -- Allergy/Reaction extract ;Aug 02, 2018@13:10:03
;;1.0;VIRTUAL PATIENT RECORD;**1,9,12**;Sep 01, 2011;Build 6
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^VA(200 10060
; %DT 10003
; GMRADPT 10099
; EN1^GMRAOR2 2422
; PSN50P41 4531
; PSN50P65 4543
; $$GET1^DIQ(120.86 3449
;
; ------------ Get reactions from VistA ------------
;
EN(DFN,BEG,END,MAX,IFN) ; -- find patient's allergies/reactions
N GMRA,GMRAL,VPRN,VPRITM,VPRCNT
S DFN=+$G(DFN) Q:DFN<1
S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999),VPRCNT=0
D EN1^GMRADPT
;
; get one reaction
I $G(IFN) D EN1(IFN,.VPRITM),XML(.VPRITM) Q
;
; get all reactions
I 'GMRAL D Q
. S VPRITM("assessment")=$S(GMRAL=0:"nka",1:"not done")
. S VPRITM("facility")=$$FAC^VPRD ;local stn#^name
. S VPRITM("entered")=$$GET1^DIQ(120.86,DFN,3,"I") ;mwa p12 added date entered to nka/none return
. D XML(.VPRITM)
S VPRN=0 F S VPRN=+$O(GMRAL(VPRN)) Q:VPRN<1 D Q:VPRCNT'<MAX
. K VPRITM D EN1(VPRN,.VPRITM) Q:'$D(VPRITM)
. D XML(.VPRITM) S VPRCNT=VPRCNT+1
Q
;
EN1(ID,REAC) ; -- return a reaction in REAC("attribute")=value
; from EN: expects GMRAL(ID)
N VPRY,GMRA,I,J,X,Y,SEV,TXT,SEV K REAC
S GMRA=$G(GMRAL(ID)) D EN1^GMRAOR2(ID,"VPRY")
S X=$P(VPRY,U,10) I $L(X) S X=$$DATE(X) Q:X<BEG Q:X>END S REAC("entered")=X
S REAC("facility")=$$FAC^VPRD ;local stn#^name
S REAC("id")=ID,REAC("name")=$P(VPRY,U) I $P(GMRA,U,9) D
. S X=$P(GMRA,U,9),Y=+$P(X,"(",2) I 'Y,X["PSDRUG" S Y=50
. S REAC("localCode")=X,REAC("vuid")=$$VUID^VPRD(+X,Y)
S X=$P(VPRY,U,6) S:$L(X) REAC("mechanism")=X
S X=$P(VPRY,U,5),REAC("source")=$E(X)
S REAC("type")=$S($L(GMRA):$P(GMRA,U,7),1:$$DFO($P(VPRY,U,7)))_U_$P(VPRY,U,7)
I $P(VPRY,U,4)="VERIFIED",$P(VPRY,U,9) S REAC("verified")=$P(VPRY,U,9)
S I=0,SEV="" F S I=$O(VPRY("O",I)) Q:I<1 S X=$P(VPRY("O",I),U,2) S:X]SEV SEV=X ;find highest severity
S:$L(SEV) REAC("severity")=SEV
; reactions
S I=0 F S I=$O(GMRAL(ID,"S",I)) Q:I<1 D
. S X=$G(GMRAL(ID,"S",I)),Y=+$P(X,";",2)
. S REAC("reaction",I)=$P(X,";")_U_$$VUID^VPRD(Y,120.83)
; comments
S I=0 F S I=$O(VPRY("C",I)) Q:I<1 D
. S X=$G(VPRY("C",I)) K TXT
. S Y=$P(X,U,3)_U_$P(X,U)
. S Y=Y_U_$S($L($P(X,U,2)):$E($P(X,U,2)),1:"E")
. S J=0 F S J=$O(VPRY("C",I,J)) Q:J<1 S X=$G(VPRY("C",I,J,0)),TXT(J)=X
. K X S X=$$STRING^VPRD(.TXT)
. S REAC("comment",I)=Y_U_X ;name^date^type^text
; drug info
I $D(VPRY("I")) D
. N ROOT S ROOT=$$B^PSN50P41
. S I=0 F S I=$O(VPRY("I",I)) Q:I<1 S X=$G(VPRY("I",I)) D
.. N IEN S IEN=$O(@ROOT@(X,0))
.. S REAC("drugIngredient",I)=X_U_$$VUID^VPRD(IEN,50.416)
I $D(VPRY("V")) D
. S I=0 F S I=$O(VPRY("V",I)) Q:I<1 S X=$G(VPRY("V",I)) D
.. D C^PSN50P65("",$P(X,U,2),"PSN")
.. N IEN S IEN=+$O(^TMP($J,"PSN","C",$P(X,U),0))
.. S REAC("drugClass",I)=$P(X,U,2)_U_$$VUID^VPRD(IEN,50.605)
I GMRA="" S REAC("removed")=1 ;entered in error
Q
;
DATE(X) ; -- Return internal form of date X
N %DT,Y
S %DT="TXS" D ^%DT
Q Y
;
DFO(X) ; -- Return 'DFO' string for mechanism name(s)
N I,P,Y S Y=""
F I=1:1:$L(X,",") S P=$P(X,",",I),Y=Y_$S($E(P)=" ":$E(P,2),1:$E(P))
S:Y="" Y=$G(X)
Q Y
;
; ------------ Return data to middle tier ------------
;
XML(REAC) ; -- Return patient reaction as XML
; as <element code='123' displayName='ABC' />
N ATT,X,Y,I,P,NM,TAG
D ADD("<allergy>") S VPRTOTL=$G(VPRTOTL)+1
S ATT="" F S ATT=$O(REAC(ATT)) Q:ATT="" D D:$L(Y) ADD(Y)
. I ATT="comment" D S Y="" Q
.. S I=0,Y="<comments>" D ADD(Y)
.. F S I=$O(REAC(ATT,I)) Q:I<1 S X=$G(REAC(ATT,I)) D
... S Y="<comment id='"_I
... S:$L($P(X,U,2)) Y=Y_"' entered='"_$P(X,U,2)
... S:$L($P(X,U,1)) Y=Y_"' enteredBy='"_$$ESC^VPRD($P(X,U,1))
... S:$L($P(X,U,3)) Y=Y_"' commentType='"_$P(X,U,3)
... S:$L($P(X,U,4)) Y=Y_"' commentText='"_$$ESC^VPRD($P(X,U,4))
... S Y=Y_"' />" D ADD(Y)
.. D ADD("</comments>")
. I $O(REAC(ATT,0)) D S Y="" Q
.. S NM=ATT_$S($E(ATT,$L(ATT))="s":"es",1:"s") D ADD("<"_NM_">")
.. S I=0 F S I=$O(REAC(ATT,I)) Q:I<1 D
... S X=$G(REAC(ATT,I)),Y="<"_ATT_" "
... F P=1:1 S TAG=$P("name^vuid^severity^Z",U,P) Q:TAG="Z" I $L($P(X,U,P)) S Y=Y_TAG_"='"_$$ESC^VPRD($P(X,U,P))_"' "
... S Y=Y_"/>" D ADD(Y)
.. D ADD("</"_NM_">")
. S X=$G(REAC(ATT)),Y="" Q:'$L(X)
. I X'["^" S Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />" Q
. I $L(X)>1 D S Y=""
.. S Y="<"_ATT_" "
.. F P=1:1 S TAG=$P("code^name^Z",U,P) Q:TAG="Z" I $L($P(X,U,P)) S Y=Y_TAG_"='"_$$ESC^VPRD($P(X,U,P))_"' "
.. S Y=Y_"/>" D ADD(Y)
D ADD("</allergy>")
Q
;
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[HVPRDGMRA 4912 printed Oct 16, 2024@18:45:01 Page 2
VPRDGMRA ;SLC/MKB -- Allergy/Reaction extract ;Aug 02, 2018@13:10:03
+1 ;;1.0;VIRTUAL PATIENT RECORD;**1,9,12**;Sep 01, 2011;Build 6
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^VA(200 10060
+7 ; %DT 10003
+8 ; GMRADPT 10099
+9 ; EN1^GMRAOR2 2422
+10 ; PSN50P41 4531
+11 ; PSN50P65 4543
+12 ; $$GET1^DIQ(120.86 3449
+13 ;
+14 ; ------------ Get reactions from VistA ------------
+15 ;
EN(DFN,BEG,END,MAX,IFN) ; -- find patient's allergies/reactions
+1 NEW GMRA,GMRAL,VPRN,VPRITM,VPRCNT
+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)
SET VPRCNT=0
+4 DO EN1^GMRADPT
+5 ;
+6 ; get one reaction
+7 IF $GET(IFN)
DO EN1(IFN,.VPRITM)
DO XML(.VPRITM)
QUIT
+8 ;
+9 ; get all reactions
+10 IF 'GMRAL
Begin DoDot:1
+11 SET VPRITM("assessment")=$SELECT(GMRAL=0:"nka",1:"not done")
+12 ;local stn#^name
SET VPRITM("facility")=$$FAC^VPRD
+13 ;mwa p12 added date entered to nka/none return
SET VPRITM("entered")=$$GET1^DIQ(120.86,DFN,3,"I")
+14 DO XML(.VPRITM)
End DoDot:1
QUIT
+15 SET VPRN=0
FOR
SET VPRN=+$ORDER(GMRAL(VPRN))
if VPRN<1
QUIT
Begin DoDot:1
+16 KILL VPRITM
DO EN1(VPRN,.VPRITM)
if '$DATA(VPRITM)
QUIT
+17 DO XML(.VPRITM)
SET VPRCNT=VPRCNT+1
End DoDot:1
if VPRCNT'<MAX
QUIT
+18 QUIT
+19 ;
EN1(ID,REAC) ; -- return a reaction in REAC("attribute")=value
+1 ; from EN: expects GMRAL(ID)
+2 NEW VPRY,GMRA,I,J,X,Y,SEV,TXT,SEV
KILL REAC
+3 SET GMRA=$GET(GMRAL(ID))
DO EN1^GMRAOR2(ID,"VPRY")
+4 SET X=$PIECE(VPRY,U,10)
IF $LENGTH(X)
SET X=$$DATE(X)
if X<BEG
QUIT
if X>END
QUIT
SET REAC("entered")=X
+5 ;local stn#^name
SET REAC("facility")=$$FAC^VPRD
+6 SET REAC("id")=ID
SET REAC("name")=$PIECE(VPRY,U)
IF $PIECE(GMRA,U,9)
Begin DoDot:1
+7 SET X=$PIECE(GMRA,U,9)
SET Y=+$PIECE(X,"(",2)
IF 'Y
IF X["PSDRUG"
SET Y=50
+8 SET REAC("localCode")=X
SET REAC("vuid")=$$VUID^VPRD(+X,Y)
End DoDot:1
+9 SET X=$PIECE(VPRY,U,6)
if $LENGTH(X)
SET REAC("mechanism")=X
+10 SET X=$PIECE(VPRY,U,5)
SET REAC("source")=$EXTRACT(X)
+11 SET REAC("type")=$SELECT($LENGTH(GMRA):$PIECE(GMRA,U,7),1:$$DFO($PIECE(VPRY,U,7)))_U_$PIECE(VPRY,U,7)
+12 IF $PIECE(VPRY,U,4)="VERIFIED"
IF $PIECE(VPRY,U,9)
SET REAC("verified")=$PIECE(VPRY,U,9)
+13 ;find highest severity
SET I=0
SET SEV=""
FOR
SET I=$ORDER(VPRY("O",I))
if I<1
QUIT
SET X=$PIECE(VPRY("O",I),U,2)
if X]SEV
SET SEV=X
+14 if $LENGTH(SEV)
SET REAC("severity")=SEV
+15 ; reactions
+16 SET I=0
FOR
SET I=$ORDER(GMRAL(ID,"S",I))
if I<1
QUIT
Begin DoDot:1
+17 SET X=$GET(GMRAL(ID,"S",I))
SET Y=+$PIECE(X,";",2)
+18 SET REAC("reaction",I)=$PIECE(X,";")_U_$$VUID^VPRD(Y,120.83)
End DoDot:1
+19 ; comments
+20 SET I=0
FOR
SET I=$ORDER(VPRY("C",I))
if I<1
QUIT
Begin DoDot:1
+21 SET X=$GET(VPRY("C",I))
KILL TXT
+22 SET Y=$PIECE(X,U,3)_U_$PIECE(X,U)
+23 SET Y=Y_U_$SELECT($LENGTH($PIECE(X,U,2)):$EXTRACT($PIECE(X,U,2)),1:"E")
+24 SET J=0
FOR
SET J=$ORDER(VPRY("C",I,J))
if J<1
QUIT
SET X=$GET(VPRY("C",I,J,0))
SET TXT(J)=X
+25 KILL X
SET X=$$STRING^VPRD(.TXT)
+26 ;name^date^type^text
SET REAC("comment",I)=Y_U_X
End DoDot:1
+27 ; drug info
+28 IF $DATA(VPRY("I"))
Begin DoDot:1
+29 NEW ROOT
SET ROOT=$$B^PSN50P41
+30 SET I=0
FOR
SET I=$ORDER(VPRY("I",I))
if I<1
QUIT
SET X=$GET(VPRY("I",I))
Begin DoDot:2
+31 NEW IEN
SET IEN=$ORDER(@ROOT@(X,0))
+32 SET REAC("drugIngredient",I)=X_U_$$VUID^VPRD(IEN,50.416)
End DoDot:2
End DoDot:1
+33 IF $DATA(VPRY("V"))
Begin DoDot:1
+34 SET I=0
FOR
SET I=$ORDER(VPRY("V",I))
if I<1
QUIT
SET X=$GET(VPRY("V",I))
Begin DoDot:2
+35 DO C^PSN50P65("",$PIECE(X,U,2),"PSN")
+36 NEW IEN
SET IEN=+$ORDER(^TMP($JOB,"PSN","C",$PIECE(X,U),0))
+37 SET REAC("drugClass",I)=$PIECE(X,U,2)_U_$$VUID^VPRD(IEN,50.605)
End DoDot:2
End DoDot:1
+38 ;entered in error
IF GMRA=""
SET REAC("removed")=1
+39 QUIT
+40 ;
DATE(X) ; -- Return internal form of date X
+1 NEW %DT,Y
+2 SET %DT="TXS"
DO ^%DT
+3 QUIT Y
+4 ;
DFO(X) ; -- Return 'DFO' string for mechanism name(s)
+1 NEW I,P,Y
SET Y=""
+2 FOR I=1:1:$LENGTH(X,",")
SET P=$PIECE(X,",",I)
SET Y=Y_$SELECT($EXTRACT(P)=" ":$EXTRACT(P,2),1:$EXTRACT(P))
+3 if Y=""
SET Y=$GET(X)
+4 QUIT Y
+5 ;
+6 ; ------------ Return data to middle tier ------------
+7 ;
XML(REAC) ; -- Return patient reaction as XML
+1 ; as <element code='123' displayName='ABC' />
+2 NEW ATT,X,Y,I,P,NM,TAG
+3 DO ADD("<allergy>")
SET VPRTOTL=$GET(VPRTOTL)+1
+4 SET ATT=""
FOR
SET ATT=$ORDER(REAC(ATT))
if ATT=""
QUIT
Begin DoDot:1
+5 IF ATT="comment"
Begin DoDot:2
+6 SET I=0
SET Y="<comments>"
DO ADD(Y)
+7 FOR
SET I=$ORDER(REAC(ATT,I))
if I<1
QUIT
SET X=$GET(REAC(ATT,I))
Begin DoDot:3
+8 SET Y="<comment id='"_I
+9 if $LENGTH($PIECE(X,U,2))
SET Y=Y_"' entered='"_$PIECE(X,U,2)
+10 if $LENGTH($PIECE(X,U,1))
SET Y=Y_"' enteredBy='"_$$ESC^VPRD($PIECE(X,U,1))
+11 if $LENGTH($PIECE(X,U,3))
SET Y=Y_"' commentType='"_$PIECE(X,U,3)
+12 if $LENGTH($PIECE(X,U,4))
SET Y=Y_"' commentText='"_$$ESC^VPRD($PIECE(X,U,4))
+13 SET Y=Y_"' />"
DO ADD(Y)
End DoDot:3
+14 DO ADD("</comments>")
End DoDot:2
SET Y=""
QUIT
+15 IF $ORDER(REAC(ATT,0))
Begin DoDot:2
+16 SET NM=ATT_$SELECT($EXTRACT(ATT,$LENGTH(ATT))="s":"es",1:"s")
DO ADD("<"_NM_">")
+17 SET I=0
FOR
SET I=$ORDER(REAC(ATT,I))
if I<1
QUIT
Begin DoDot:3
+18 SET X=$GET(REAC(ATT,I))
SET Y="<"_ATT_" "
+19 FOR P=1:1
SET TAG=$PIECE("name^vuid^severity^Z",U,P)
if TAG="Z"
QUIT
IF $LENGTH($PIECE(X,U,P))
SET Y=Y_TAG_"='"_$$ESC^VPRD($PIECE(X,U,P))_"' "
+20 SET Y=Y_"/>"
DO ADD(Y)
End DoDot:3
+21 DO ADD("</"_NM_">")
End DoDot:2
SET Y=""
QUIT
+22 SET X=$GET(REAC(ATT))
SET Y=""
if '$LENGTH(X)
QUIT
+23 IF X'["^"
SET Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />"
QUIT
+24 IF $LENGTH(X)>1
Begin DoDot:2
+25 SET Y="<"_ATT_" "
+26 FOR P=1:1
SET TAG=$PIECE("code^name^Z",U,P)
if TAG="Z"
QUIT
IF $LENGTH($PIECE(X,U,P))
SET Y=Y_TAG_"='"_$$ESC^VPRD($PIECE(X,U,P))_"' "
+27 SET Y=Y_"/>"
DO ADD(Y)
End DoDot:2
SET Y=""
End DoDot:1
if $LENGTH(Y)
DO ADD(Y)
+28 DO ADD("</allergy>")
+29 QUIT
+30 ;
ADD(X) ; Add a line @VPR@(n)=X
+1 SET VPRI=$GET(VPRI)+1
+2 SET @VPR@(VPRI)=X
+3 QUIT
