HMPDGMRA ;SLC/MKB,ASMR/RRB,BL,JD - Allergy/Reaction extract;Aug 29, 2016 20:06:27
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**1,3**;May 15, 2016;Build 15
;Per VA Directive 6402, this routine should not be modified.
;
;DE4220 - JD - 4/1/16: Fixed the date function so that seconds are considered for
; Origination Date/Time field (^DD(120.8,4)).
;
; External References DBIA#
; ------------------- -----
; ^VA(200 10060
; %DT 10003
; GMRADPT 10099
; EN1^GMRAOR2 2422
; PSN50P41 4531
; PSN50P65 4543
Q
; ------------ Get reactions from VistA ------------
;
EN(DFN,BEG,END,MAX,IFN) ; -- find patient's allergies/reactions
N GMRA,GMRAL,HMPN,HMPITM,HMPCNT
S DFN=+$G(DFN) I '(DFN>0) D LOGDPT^HMPLOG(DFN) Q ;DE4496, 19 August 2016
S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999),HMPCNT=0
D EN1^GMRADPT
;
; get one reaction
I $G(IFN) D EN1(IFN,.HMPITM),XML(.HMPITM) Q
;
; get all reactions
I 'GMRAL D Q
. S HMPITM("assessment")=$S(GMRAL=0:"nka",1:"not done")
. S HMPITM("facility")=$$FAC^HMPD ;local stn#^name
. D XML(.HMPITM)
S HMPN=0 F S HMPN=+$O(GMRAL(HMPN)) Q:HMPN<1 D Q:HMPCNT'<MAX
. K HMPITM D EN1(HMPN,.HMPITM) Q:'$D(HMPITM)
. D XML(.HMPITM) S HMPCNT=HMPCNT+1
Q
;
EN1(ID,REAC) ; -- return a reaction in REAC("attribute")=value
; from EN: expects GMRAL(ID)
N HMPY,GMRA,I,J,X,Y,SEV,TXT,SEV K REAC
S GMRA=$G(GMRAL(ID)) D EN1^GMRAOR2(ID,"HMPY")
S X=$P(HMPY,U,10) I $L(X) S X=$$DATE(X) Q:X<BEG Q:X>END S REAC("entered")=X
S REAC("facility")=$$FAC^HMPD ;local stn#^name
S REAC("id")=ID,REAC("name")=$P(HMPY,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^HMPD(+X,Y)
S X=$P(HMPY,U,6) S:$L(X) REAC("mechanism")=X
S X=$P(HMPY,U,5),REAC("source")=$E(X)
S REAC("type")=$S($L(GMRA):$P(GMRA,U,7),1:$$DFO($P(HMPY,U,7)))_U_$P(HMPY,U,7)
I $P(HMPY,U,4)="VERIFIED",$P(HMPY,U,9) S REAC("verified")=$P(HMPY,U,9)
S I=0,SEV="" F S I=$O(HMPY("O",I)) Q:I<1 S X=$P(HMPY("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^HMPD(Y,120.83)
; comments
S I=0 F S I=$O(HMPY("C",I)) Q:I<1 D
. S X=$G(HMPY("C",I)) K TXT
. S Y=$$VA200($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(HMPY("C",I,J)) Q:J<1 S X=$G(HMPY("C",I,J,0)),TXT(J)=X
. K X S X=$$STRING^HMPD(.TXT)
. S REAC("comment",I)=Y_U_X ;ien^name^date^type^text
; drug info
I $D(HMPY("I")) D
. N ROOT S ROOT=$$B^PSN50P41
. S I=0 F S I=$O(HMPY("I",I)) Q:I<1 S X=$G(HMPY("I",I)) D
.. N IEN S IEN=$O(@ROOT@(X,0))
.. S REAC("drugIngredient",I)=X_U_$$VUID^HMPD(IEN,50.416)
I $D(HMPY("V")) D
. S I=0 F S I=$O(HMPY("V",I)) Q:I<1 S X=$G(HMPY("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^HMPD(IEN,50.605)
I GMRA="" S REAC("removed")=1 ;entered in error
Q
;
VA200(NAME) ; -- Return ien^name from #200
N Y S NAME=$G(NAME),Y="^"
I $L(NAME) S Y=+$O(^VA(200,"B",NAME,0))_U_NAME ; IA 10060, DE2818
Q Y
;
DATE(X) ; -- Return internal form of date X
N %DT,Y
S %DT="STX" D ^%DT ;Added the "S" to allow for seconds. DE4220
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 HMPTOTL=$G(HMPTOTL)+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,3)) Y=Y_"' entered='"_$P(X,U,3)
... S:$L($P(X,U,2)) Y=Y_"' enteredBy='"_$$ESC^HMPD($P(X,U,2))
... S:$L($P(X,U,4)) Y=Y_"' commentType='"_$P(X,U,4)
... S:$L($P(X,U,5)) Y=Y_"' commentText='"_$$ESC^HMPD($P(X,U,5))
... 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^HMPD($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^HMPD(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^HMPD($P(X,U,P))_"' "
.. S Y=Y_"/>" D ADD(Y)
D ADD("</allergy>")
Q
;
ADD(X) ; Add a line @HMP@(n)=X
S HMPI=$G(HMPI)+1
S @HMP@(HMPI)=X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPDGMRA 5211 printed Sep 23, 2025@19:29:12 Page 2
HMPDGMRA ;SLC/MKB,ASMR/RRB,BL,JD - Allergy/Reaction extract;Aug 29, 2016 20:06:27
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**1,3**;May 15, 2016;Build 15
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;DE4220 - JD - 4/1/16: Fixed the date function so that seconds are considered for
+5 ; Origination Date/Time field (^DD(120.8,4)).
+6 ;
+7 ; External References DBIA#
+8 ; ------------------- -----
+9 ; ^VA(200 10060
+10 ; %DT 10003
+11 ; GMRADPT 10099
+12 ; EN1^GMRAOR2 2422
+13 ; PSN50P41 4531
+14 ; PSN50P65 4543
+15 QUIT
+16 ; ------------ Get reactions from VistA ------------
+17 ;
EN(DFN,BEG,END,MAX,IFN) ; -- find patient's allergies/reactions
+1 NEW GMRA,GMRAL,HMPN,HMPITM,HMPCNT
+2 ;DE4496, 19 August 2016
SET DFN=+$GET(DFN)
IF '(DFN>0)
DO LOGDPT^HMPLOG(DFN)
QUIT
+3 SET BEG=$GET(BEG,1410101)
SET END=$GET(END,4141015)
SET MAX=$GET(MAX,9999)
SET HMPCNT=0
+4 DO EN1^GMRADPT
+5 ;
+6 ; get one reaction
+7 IF $GET(IFN)
DO EN1(IFN,.HMPITM)
DO XML(.HMPITM)
QUIT
+8 ;
+9 ; get all reactions
+10 IF 'GMRAL
Begin DoDot:1
+11 SET HMPITM("assessment")=$SELECT(GMRAL=0:"nka",1:"not done")
+12 ;local stn#^name
SET HMPITM("facility")=$$FAC^HMPD
+13 DO XML(.HMPITM)
End DoDot:1
QUIT
+14 SET HMPN=0
FOR
SET HMPN=+$ORDER(GMRAL(HMPN))
if HMPN<1
QUIT
Begin DoDot:1
+15 KILL HMPITM
DO EN1(HMPN,.HMPITM)
if '$DATA(HMPITM)
QUIT
+16 DO XML(.HMPITM)
SET HMPCNT=HMPCNT+1
End DoDot:1
if HMPCNT'<MAX
QUIT
+17 QUIT
+18 ;
EN1(ID,REAC) ; -- return a reaction in REAC("attribute")=value
+1 ; from EN: expects GMRAL(ID)
+2 NEW HMPY,GMRA,I,J,X,Y,SEV,TXT,SEV
KILL REAC
+3 SET GMRA=$GET(GMRAL(ID))
DO EN1^GMRAOR2(ID,"HMPY")
+4 SET X=$PIECE(HMPY,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^HMPD
+6 SET REAC("id")=ID
SET REAC("name")=$PIECE(HMPY,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^HMPD(+X,Y)
End DoDot:1
+9 SET X=$PIECE(HMPY,U,6)
if $LENGTH(X)
SET REAC("mechanism")=X
+10 SET X=$PIECE(HMPY,U,5)
SET REAC("source")=$EXTRACT(X)
+11 SET REAC("type")=$SELECT($LENGTH(GMRA):$PIECE(GMRA,U,7),1:$$DFO($PIECE(HMPY,U,7)))_U_$PIECE(HMPY,U,7)
+12 IF $PIECE(HMPY,U,4)="VERIFIED"
IF $PIECE(HMPY,U,9)
SET REAC("verified")=$PIECE(HMPY,U,9)
+13 ;find highest severity
SET I=0
SET SEV=""
FOR
SET I=$ORDER(HMPY("O",I))
if I<1
QUIT
SET X=$PIECE(HMPY("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^HMPD(Y,120.83)
End DoDot:1
+19 ; comments
+20 SET I=0
FOR
SET I=$ORDER(HMPY("C",I))
if I<1
QUIT
Begin DoDot:1
+21 SET X=$GET(HMPY("C",I))
KILL TXT
+22 SET Y=$$VA200($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(HMPY("C",I,J))
if J<1
QUIT
SET X=$GET(HMPY("C",I,J,0))
SET TXT(J)=X
+25 KILL X
SET X=$$STRING^HMPD(.TXT)
+26 ;ien^name^date^type^text
SET REAC("comment",I)=Y_U_X
End DoDot:1
+27 ; drug info
+28 IF $DATA(HMPY("I"))
Begin DoDot:1
+29 NEW ROOT
SET ROOT=$$B^PSN50P41
+30 SET I=0
FOR
SET I=$ORDER(HMPY("I",I))
if I<1
QUIT
SET X=$GET(HMPY("I",I))
Begin DoDot:2
+31 NEW IEN
SET IEN=$ORDER(@ROOT@(X,0))
+32 SET REAC("drugIngredient",I)=X_U_$$VUID^HMPD(IEN,50.416)
End DoDot:2
End DoDot:1
+33 IF $DATA(HMPY("V"))
Begin DoDot:1
+34 SET I=0
FOR
SET I=$ORDER(HMPY("V",I))
if I<1
QUIT
SET X=$GET(HMPY("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^HMPD(IEN,50.605)
End DoDot:2
End DoDot:1
+38 ;entered in error
IF GMRA=""
SET REAC("removed")=1
+39 QUIT
+40 ;
VA200(NAME) ; -- Return ien^name from #200
+1 NEW Y
SET NAME=$GET(NAME)
SET Y="^"
+2 ; IA 10060, DE2818
IF $LENGTH(NAME)
SET Y=+$ORDER(^VA(200,"B",NAME,0))_U_NAME
+3 QUIT Y
+4 ;
DATE(X) ; -- Return internal form of date X
+1 NEW %DT,Y
+2 ;Added the "S" to allow for seconds. DE4220
SET %DT="STX"
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 HMPTOTL=$GET(HMPTOTL)+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,3))
SET Y=Y_"' entered='"_$PIECE(X,U,3)
+10 if $LENGTH($PIECE(X,U,2))
SET Y=Y_"' enteredBy='"_$$ESC^HMPD($PIECE(X,U,2))
+11 if $LENGTH($PIECE(X,U,4))
SET Y=Y_"' commentType='"_$PIECE(X,U,4)
+12 if $LENGTH($PIECE(X,U,5))
SET Y=Y_"' commentText='"_$$ESC^HMPD($PIECE(X,U,5))
+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^HMPD($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^HMPD(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^HMPD($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 @HMP@(n)=X
+1 SET HMPI=$GET(HMPI)+1
+2 SET @HMP@(HMPI)=X
+3 QUIT
