NHINVART ;SLC/MKB -- Allergy/Reaction extract
;;1.0;NHIN;**1**;Oct 25, 2010;Build 11
;
; External References DBIA#
; ------------------- -----
; %DT 10003
; GMRADPT 10099
; EN1^GMRAOR2 2422
; PSN50P41 4531
; PSN50P65 4543
;
; ------------ Get reactions from VistA ------------
;
EN(DFN,BEG,END,MAX,IFN) ; -- find patient's allergies/reactions
N GMRA,GMRAL,NHI,NHITM,NHICNT
S DFN=+$G(DFN) Q:DFN<1
S BEG=$G(BEG,1410101),END=$G(END,9999998),MAX=$G(MAX,999999),NHICNT=0
D EN1^GMRADPT
;
; get one reaction
I $G(IFN) D EN1(IFN,.NHITM),XML(.NHITM) Q
;
; get all reactions
I 'GMRAL S NHITM("assessment")=$S(GMRAL=0:"nka",1:"not done") D XML(.NHITM) Q
S NHI=0 F S NHI=+$O(GMRAL(NHI)) Q:NHI<1 D Q:NHICNT'<MAX
. K NHITM D EN1(NHI,.NHITM) Q:'$D(NHITM)
. D XML(.NHITM) S NHICNT=NHICNT+1
Q
;
EN1(ID,REAC) ; -- return a reaction in REAC("attribute")=value
; from EN: expects GMRAL(ID)
N NHY,GMRA,I,J,X,Y,SEV,TXT,NM,SEV K REAC
S GMRA=$G(GMRAL(ID)) D EN1^GMRAOR2(ID,"NHY")
S X=$P(NHY,U,10) I $L(X) S X=$$DATE(X) Q:X<BEG Q:X>END S REAC("entered")=X
S REAC("facility")=$$FAC^NHINV ;local stn#^name
S REAC("id")=ID,REAC("name")=$P(NHY,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^NHINV(+X,Y)
S X=$P(NHY,U,6) S:$L(X) REAC("mechanism")=X
S X=$P(NHY,U,5),REAC("source")=$E(X)
S REAC("adverseEventType")=$S($L(GMRA):$P(GMRA,U,7),1:$$DFO($P(NHY,U,7)))
I $P(NHY,U,4)="VERIFIED",$P(NHY,U,9) S REAC("verified")=$P(NHY,U,9)
S I=0,SEV="" F S I=$O(NHY("O",I)) Q:I<1 S X=$P(NHY("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(NHY("S",I)) Q:I<1 D
. S X=NHY("S",I),NM=$P(X," (") S:NM="" NM="OTHER REACTION"
. S Y=+$$FIND1^DIC(120.83,,"QX",NM)
. S REAC("reaction",I)=NM_U_$$VUID^NHINV(Y,120.83)
; comments
S I=0 F S I=$O(NHY("C",I)) Q:I<1 D
. S X=$G(NHY("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(NHY("C",I,J)) Q:J<1 S X=$G(NHY("C",I,J,0)),TXT(J)=X
. K X S X=$$STRING^NHINV(.TXT)
. S REAC("comment",I)=Y_U_X ;ien^name^date^type^text
; drug info
I $D(NHY("I")) D
. N ROOT S ROOT=$$B^PSN50P41
. S I=0 F S I=$O(NHY("I",I)) Q:I<1 S X=$G(NHY("I",I)) D
.. N IEN S IEN=$O(@ROOT@(X,0))
.. S REAC("drugIngredient",I)=X_U_$$VUID^NHINV(IEN,50.416)
I $D(NHY("V")) D
. S I=0 F S I=$O(NHY("V",I)) Q:I<1 S X=$G(NHY("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^NHINV(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
Q Y
;
DATE(X) ; -- Return internal form of date X
N %DT,Y
S %DT="TX" 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 NHINTOTL=$G(NHINTOTL)+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^NHINV($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^NHINV($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^NHINV($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^NHINV(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^NHINV($P(X,U,P))_"' "
.. S Y=Y_"/>" D ADD(Y)
D ADD("</allergy>")
Q
;
ADD(X) ; Add a line @NHIN@(n)=X
S NHINI=$G(NHINI)+1
S @NHIN@(NHINI)=X
Q
;
C32(REAC) ; -- convert iens to C32 codes
N X,Y,I
S X=$G(REAC("product")) I X S $P(REAC("product"),U)=$$VUID^NHINV(+X,120.82)
S X=$P($G(REAC("type")),U),Y=$P($G(REAC("mechanism")),U)
I $L(X) D S $P(REAC("type"),U)=I
. I Y="A" S I=$S(X["D":416098002,X["F":414285001,1:419199007) Q
. I Y="P" S I=$S(X["D":59037007,X["F":235719002,1:420134006) Q
. S I=$S(X["D":419511003,X["F":418471000,1:418038007)
S X=+$G(REAC("severity")) I X D
. S X=$S(X=1:255604002,X=2:6736007,X=3:24484000,1:X)
. S $P(REAC("severity"),U)=X
S I=0 F S I=$O(REAC("reaction",I)) Q:I<1 D
. S X=$G(REAC("reaction",I)) Q:'X
. S $P(REAC("reaction",I),U)=$$VUID^NHINV(+X,120.83)
S I=0 F S I=$O(REAC("drugClass",I)) Q:I<1 D
. S X=$G(REAC("drugClass",I)) Q:'X
. S $P(REAC("drugClass",I),U)=$$VUID^NHINV(+X,50.605)
S I=0 F S I=$O(REAC("drugIngredient",I)) Q:I<1 D
. S X=$G(REAC("drugIngredient",I)) Q:'X
. S $P(REAC("drugIngredient",I),U)=$$VUID^NHINV(+X,50.416)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNHINVART 5701 printed Dec 13, 2024@02:17:14 Page 2
NHINVART ;SLC/MKB -- Allergy/Reaction extract
+1 ;;1.0;NHIN;**1**;Oct 25, 2010;Build 11
+2 ;
+3 ; External References DBIA#
+4 ; ------------------- -----
+5 ; %DT 10003
+6 ; GMRADPT 10099
+7 ; EN1^GMRAOR2 2422
+8 ; PSN50P41 4531
+9 ; PSN50P65 4543
+10 ;
+11 ; ------------ Get reactions from VistA ------------
+12 ;
EN(DFN,BEG,END,MAX,IFN) ; -- find patient's allergies/reactions
+1 NEW GMRA,GMRAL,NHI,NHITM,NHICNT
+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)
SET NHICNT=0
+4 DO EN1^GMRADPT
+5 ;
+6 ; get one reaction
+7 IF $GET(IFN)
DO EN1(IFN,.NHITM)
DO XML(.NHITM)
QUIT
+8 ;
+9 ; get all reactions
+10 IF 'GMRAL
SET NHITM("assessment")=$SELECT(GMRAL=0:"nka",1:"not done")
DO XML(.NHITM)
QUIT
+11 SET NHI=0
FOR
SET NHI=+$ORDER(GMRAL(NHI))
if NHI<1
QUIT
Begin DoDot:1
+12 KILL NHITM
DO EN1(NHI,.NHITM)
if '$DATA(NHITM)
QUIT
+13 DO XML(.NHITM)
SET NHICNT=NHICNT+1
End DoDot:1
if NHICNT'<MAX
QUIT
+14 QUIT
+15 ;
EN1(ID,REAC) ; -- return a reaction in REAC("attribute")=value
+1 ; from EN: expects GMRAL(ID)
+2 NEW NHY,GMRA,I,J,X,Y,SEV,TXT,NM,SEV
KILL REAC
+3 SET GMRA=$GET(GMRAL(ID))
DO EN1^GMRAOR2(ID,"NHY")
+4 SET X=$PIECE(NHY,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^NHINV
+6 SET REAC("id")=ID
SET REAC("name")=$PIECE(NHY,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^NHINV(+X,Y)
End DoDot:1
+9 SET X=$PIECE(NHY,U,6)
if $LENGTH(X)
SET REAC("mechanism")=X
+10 SET X=$PIECE(NHY,U,5)
SET REAC("source")=$EXTRACT(X)
+11 SET REAC("adverseEventType")=$SELECT($LENGTH(GMRA):$PIECE(GMRA,U,7),1:$$DFO($PIECE(NHY,U,7)))
+12 IF $PIECE(NHY,U,4)="VERIFIED"
IF $PIECE(NHY,U,9)
SET REAC("verified")=$PIECE(NHY,U,9)
+13 ;find highest severity
SET I=0
SET SEV=""
FOR
SET I=$ORDER(NHY("O",I))
if I<1
QUIT
SET X=$PIECE(NHY("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(NHY("S",I))
if I<1
QUIT
Begin DoDot:1
+17 SET X=NHY("S",I)
SET NM=$PIECE(X," (")
if NM=""
SET NM="OTHER REACTION"
+18 SET Y=+$$FIND1^DIC(120.83,,"QX",NM)
+19 SET REAC("reaction",I)=NM_U_$$VUID^NHINV(Y,120.83)
End DoDot:1
+20 ; comments
+21 SET I=0
FOR
SET I=$ORDER(NHY("C",I))
if I<1
QUIT
Begin DoDot:1
+22 SET X=$GET(NHY("C",I))
KILL TXT
+23 SET Y=$$VA200($PIECE(X,U,3))_U_$PIECE(X,U)
+24 SET Y=Y_U_$SELECT($LENGTH($PIECE(X,U,2)):$EXTRACT($PIECE(X,U,2)),1:"E")
+25 SET J=0
FOR
SET J=$ORDER(NHY("C",I,J))
if J<1
QUIT
SET X=$GET(NHY("C",I,J,0))
SET TXT(J)=X
+26 KILL X
SET X=$$STRING^NHINV(.TXT)
+27 ;ien^name^date^type^text
SET REAC("comment",I)=Y_U_X
End DoDot:1
+28 ; drug info
+29 IF $DATA(NHY("I"))
Begin DoDot:1
+30 NEW ROOT
SET ROOT=$$B^PSN50P41
+31 SET I=0
FOR
SET I=$ORDER(NHY("I",I))
if I<1
QUIT
SET X=$GET(NHY("I",I))
Begin DoDot:2
+32 NEW IEN
SET IEN=$ORDER(@ROOT@(X,0))
+33 SET REAC("drugIngredient",I)=X_U_$$VUID^NHINV(IEN,50.416)
End DoDot:2
End DoDot:1
+34 IF $DATA(NHY("V"))
Begin DoDot:1
+35 SET I=0
FOR
SET I=$ORDER(NHY("V",I))
if I<1
QUIT
SET X=$GET(NHY("V",I))
Begin DoDot:2
+36 DO C^PSN50P65("",$PIECE(X,U,2),"PSN")
+37 NEW IEN
SET IEN=+$ORDER(^TMP($JOB,"PSN","C",$PIECE(X,U),0))
+38 SET REAC("drugClass",I)=$PIECE(X,U,2)_U_$$VUID^NHINV(IEN,50.605)
End DoDot:2
End DoDot:1
+39 ;entered in error
IF GMRA=""
SET REAC("removed")=1
+40 QUIT
+41 ;
VA200(NAME) ; -- Return ien^name from #200
+1 NEW Y
SET NAME=$GET(NAME)
SET Y="^"
+2 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 SET %DT="TX"
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 NHINTOTL=$GET(NHINTOTL)+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^NHINV($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^NHINV($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^NHINV($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^NHINV(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^NHINV($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 @NHIN@(n)=X
+1 SET NHINI=$GET(NHINI)+1
+2 SET @NHIN@(NHINI)=X
+3 QUIT
+4 ;
C32(REAC) ; -- convert iens to C32 codes
+1 NEW X,Y,I
+2 SET X=$GET(REAC("product"))
IF X
SET $PIECE(REAC("product"),U)=$$VUID^NHINV(+X,120.82)
+3 SET X=$PIECE($GET(REAC("type")),U)
SET Y=$PIECE($GET(REAC("mechanism")),U)
+4 IF $LENGTH(X)
Begin DoDot:1
+5 IF Y="A"
SET I=$SELECT(X["D":416098002,X["F":414285001,1:419199007)
QUIT
+6 IF Y="P"
SET I=$SELECT(X["D":59037007,X["F":235719002,1:420134006)
QUIT
+7 SET I=$SELECT(X["D":419511003,X["F":418471000,1:418038007)
End DoDot:1
SET $PIECE(REAC("type"),U)=I
+8 SET X=+$GET(REAC("severity"))
IF X
Begin DoDot:1
+9 SET X=$SELECT(X=1:255604002,X=2:6736007,X=3:24484000,1:X)
+10 SET $PIECE(REAC("severity"),U)=X
End DoDot:1
+11 SET I=0
FOR
SET I=$ORDER(REAC("reaction",I))
if I<1
QUIT
Begin DoDot:1
+12 SET X=$GET(REAC("reaction",I))
if 'X
QUIT
+13 SET $PIECE(REAC("reaction",I),U)=$$VUID^NHINV(+X,120.83)
End DoDot:1
+14 SET I=0
FOR
SET I=$ORDER(REAC("drugClass",I))
if I<1
QUIT
Begin DoDot:1
+15 SET X=$GET(REAC("drugClass",I))
if 'X
QUIT
+16 SET $PIECE(REAC("drugClass",I),U)=$$VUID^NHINV(+X,50.605)
End DoDot:1
+17 SET I=0
FOR
SET I=$ORDER(REAC("drugIngredient",I))
if I<1
QUIT
Begin DoDot:1
+18 SET X=$GET(REAC("drugIngredient",I))
if 'X
QUIT
+19 SET $PIECE(REAC("drugIngredient",I),U)=$$VUID^NHINV(+X,50.416)
End DoDot:1
+20 QUIT
