- 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 Mar 13, 2025@21:49:29 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
