VPRSDAL ;SLC/MKB -- SDA Allergy utilities ;10/25/18 15:29
;;1.0;VIRTUAL PATIENT RECORD;**8,10,14,29,31**;Sep 01, 2011;Build 3
;;Per VHA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^GMR(120.8 6973
; ^GMR(120.86 3449
; DILFD 2055
; DIQ 2056
; GMRADPT 10099
; GMRAOR2 2422
;
QRY ; -- Allergies/Adverse Reactions query
; Expects DSTRT, DSTOP, DMAX from DDEGET and returns DLIST(#)=ien
N X,ERR,VPRN,GMRA,ID
S X=$G(FILTER("status")),ERR=$S(X="":1,X["I":1,1:0) ;In/Active
S VPRN=0,GMRA="0^0^111^0^"_ERR
I $L($T(EN2^GMRADPT)) D EN2^GMRADPT I 1
E D EN1^GMRADPT
I 'GMRAL,ERR,$D(^GMR(120.8,"B",DFN)) D Q
. S ID=0 ;if only inactives, GMRADPT returns nothing
. F S ID=$O(^GMR(120.8,"B",DFN,ID)) Q:ID<1 S VPRN=VPRN+1,DLIST(VPRN)=ID
S ID=0 F S ID=+$O(GMRAL(ID)) Q:ID<1 S VPRN=VPRN+1,DLIST(VPRN)=ID Q:VPRN'<DMAX
Q
;
ALG1(IEN) ; -- return info for single allergy in VPRALG & GMRAY arrays
N GMRA K VPRALG
I '$D(^GMR(120.8,+$G(IEN),0)) S DDEOUT=1 Q
I '$D(GMRAL) D
. N DFN S DFN=+$$GET1^DIQ(120.8,IEN_",",.01,"I")
. S GMRA="0^0^111^0^1"
. I $L($T(EN2^GMRADPT)) D EN2^GMRADPT Q
. D EN1^GMRADPT
M VPRALG=GMRAL(IEN)
I $G(VPRALG)="" S VPRALG="" ;S DDEOUT=1 Q
I $L($T(EN2^GMRAOR2)) D EN2^GMRAOR2(IEN,"GMRAY") Q
D EN1^GMRAOR2(IEN,"GMRAY")
Q
;
ALLERGEN(VPTR) ; -- return code^name^system for Allergen
N Y,FN,TYPE,CSYS S VPTR=$G(VPTR)
S FN=$S(VPTR["PSDRUG":50,1:+$P(VPTR,"(",2)),TYPE=$P(VPRALG,U,7)
S CSYS=$S(TYPE="D":"RXN^UNI^SCT",TYPE["D":"RXN^SCT^UNI",1:"SCT^UNI")
S Y=$$CODE^VPRSDA(+VPTR,FN,CSYS) I Y="" D
. N NAME S NAME=$$GET1^DIQ(FN,+VPTR,$S(FN=50.605:1,1:.01))
. ; $$EXTERNAL^DILFD(120.8,1,,VPTR)
. S Y=$$VUID^VPRD(+VPTR,FN) I Y S Y=Y_U_NAME_"^VHAT" Q
. S Y=+$G(VPTR)_U_NAME_"^VA"_FN
Q Y
;
CMT1(IEN,TYPE) ; -- return TYPE comment
N I,TXT,Y
S IEN=+$G(IEN),TYPE=$G(TYPE,"E") ;default to Error
S I=$O(^GMR(120.8,IEN,26,"AVER",TYPE,0)),Y=""
I I M TXT=^GMR(120.8,IEN,26,I,2) S Y=$$STRING^VPRD(.TXT)
Q Y
;
CMTS(IEN) ; -- return list of comments in
; DLIST(#) = id ^ date ^ user ^ type ^ facility ^ text
; expects VASITE (read only) from Entity
N I,X,Y,TXT S IEN=+$G(IEN)
S I=0 F S I=$O(^GMR(120.8,IEN,26,I)) Q:I<1 S X=$G(^(I,0)) D
. Q:$P(X,U,3)="E"
. S $P(X,U,3)=$$EXTERNAL^DILFD(120.826,1.5,,$P(X,U,3))
. M TXT=^GMR(120.8,IEN,26,I,2) S Y=$$STRING^VPRD(.TXT)
. S DLIST(I)=I_","_IEN_U_X_U_+$G(VASITE)_U_Y
Q
;
SEVRTY(IEN) ; -- return overall Allergy Severity
N I,SEV,X,Y
S (SEV,Y)="",I=0
I $D(GMRAY("H")) S SEV=$P(GMRAY("H"),U,2)
; else find highest severity among reactions
F S I=$O(GMRAY("O",I)) Q:I<1 S X=$P(GMRAY("O",I),U,2) I $L(X) D
. I X?1"LIFE".E S SEV=X Q
. I X]SEV S SEV=X
I $L(SEV)>1 S Y=$$SNOMED(SEV)
Q Y
;
SNOMED(SEV) ; -- return SEVerity name as coded element
N X,Y S SEV=$G(SEV),X=$E(SEV,1,2)
S Y=$S(X="MI":255604002,X="MO":6736007,X="SE":24484000,X="LI":442452003,1:"")
I Y S Y=Y_U_SEV_"^SNOMED CT"
E S Y=SEV_U_SEV
Q Y
;
EVTDT(IEN) ; -- return first D/T of Event
I $G(GMRAY("H")) S Y=$P(GMRAY("H"),U) Q Y
N I,RDT,X,Y
S I=0,RDT=9999999,Y=""
; find first date.time among reactions
F S I=$O(GMRAY("O",I)) Q:I<1 S X=$P(GMRAY("O",I),U) S:X<RDT RDT=X
S:RDT<9999999 Y=RDT
Q Y
;
REACTN(IEN) ; -- convert ien^name[^date] to national code for Sign/Symptom
; Returns +IEN, VPRDT=date [for extension],
; VPREACTN=code^name^system [SNOMED or VUID],
; VPRNAME =local name [Original Text]
N Y S Y="" K VPRNAME
S VPREACTN=$P($G(IEN),U,1,2),VPRDT=$P($G(IEN),U,3),IEN=+$G(IEN)
S Y=$$CODE^VPRSDA(IEN,120.83,"SCT") S:$L(Y) VPRNAME=$P(VPREACTN,U,2)
I Y="" S Y=$$VUID^VPRD(IEN,120.83) S:$L(Y) Y=Y_U_$P(VPREACTN,U,2)_"^VHAT"
S:$L(Y) VPREACTN=Y ;return code string
Q
;
ASSESS ; -- get Assessment #120.86 for patient
; expects ID (read only) from Entity
I '$G(DFN),$G(ID) S DFN=ID
Q:'$G(DFN) Q:$P($G(^GMR(120.86,DFN,0)),U,2) ;has allergies
S DLIST(1)=DFN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRSDAL 4186 printed Sep 23, 2025@20:22:15 Page 2
VPRSDAL ;SLC/MKB -- SDA Allergy utilities ;10/25/18 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**8,10,14,29,31**;Sep 01, 2011;Build 3
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^GMR(120.8 6973
+7 ; ^GMR(120.86 3449
+8 ; DILFD 2055
+9 ; DIQ 2056
+10 ; GMRADPT 10099
+11 ; GMRAOR2 2422
+12 ;
QRY ; -- Allergies/Adverse Reactions query
+1 ; Expects DSTRT, DSTOP, DMAX from DDEGET and returns DLIST(#)=ien
+2 NEW X,ERR,VPRN,GMRA,ID
+3 ;In/Active
SET X=$GET(FILTER("status"))
SET ERR=$SELECT(X="":1,X["I":1,1:0)
+4 SET VPRN=0
SET GMRA="0^0^111^0^"_ERR
+5 IF $LENGTH($TEXT(EN2^GMRADPT))
DO EN2^GMRADPT
IF 1
+6 IF '$TEST
DO EN1^GMRADPT
+7 IF 'GMRAL
IF ERR
IF $DATA(^GMR(120.8,"B",DFN))
Begin DoDot:1
+8 ;if only inactives, GMRADPT returns nothing
SET ID=0
+9 FOR
SET ID=$ORDER(^GMR(120.8,"B",DFN,ID))
if ID<1
QUIT
SET VPRN=VPRN+1
SET DLIST(VPRN)=ID
End DoDot:1
QUIT
+10 SET ID=0
FOR
SET ID=+$ORDER(GMRAL(ID))
if ID<1
QUIT
SET VPRN=VPRN+1
SET DLIST(VPRN)=ID
if VPRN'<DMAX
QUIT
+11 QUIT
+12 ;
ALG1(IEN) ; -- return info for single allergy in VPRALG & GMRAY arrays
+1 NEW GMRA
KILL VPRALG
+2 IF '$DATA(^GMR(120.8,+$GET(IEN),0))
SET DDEOUT=1
QUIT
+3 IF '$DATA(GMRAL)
Begin DoDot:1
+4 NEW DFN
SET DFN=+$$GET1^DIQ(120.8,IEN_",",.01,"I")
+5 SET GMRA="0^0^111^0^1"
+6 IF $LENGTH($TEXT(EN2^GMRADPT))
DO EN2^GMRADPT
QUIT
+7 DO EN1^GMRADPT
End DoDot:1
+8 MERGE VPRALG=GMRAL(IEN)
+9 ;S DDEOUT=1 Q
IF $GET(VPRALG)=""
SET VPRALG=""
+10 IF $LENGTH($TEXT(EN2^GMRAOR2))
DO EN2^GMRAOR2(IEN,"GMRAY")
QUIT
+11 DO EN1^GMRAOR2(IEN,"GMRAY")
+12 QUIT
+13 ;
ALLERGEN(VPTR) ; -- return code^name^system for Allergen
+1 NEW Y,FN,TYPE,CSYS
SET VPTR=$GET(VPTR)
+2 SET FN=$SELECT(VPTR["PSDRUG":50,1:+$PIECE(VPTR,"(",2))
SET TYPE=$PIECE(VPRALG,U,7)
+3 SET CSYS=$SELECT(TYPE="D":"RXN^UNI^SCT",TYPE["D":"RXN^SCT^UNI",1:"SCT^UNI")
+4 SET Y=$$CODE^VPRSDA(+VPTR,FN,CSYS)
IF Y=""
Begin DoDot:1
+5 NEW NAME
SET NAME=$$GET1^DIQ(FN,+VPTR,$SELECT(FN=50.605:1,1:.01))
+6 ; $$EXTERNAL^DILFD(120.8,1,,VPTR)
+7 SET Y=$$VUID^VPRD(+VPTR,FN)
IF Y
SET Y=Y_U_NAME_"^VHAT"
QUIT
+8 SET Y=+$GET(VPTR)_U_NAME_"^VA"_FN
End DoDot:1
+9 QUIT Y
+10 ;
CMT1(IEN,TYPE) ; -- return TYPE comment
+1 NEW I,TXT,Y
+2 ;default to Error
SET IEN=+$GET(IEN)
SET TYPE=$GET(TYPE,"E")
+3 SET I=$ORDER(^GMR(120.8,IEN,26,"AVER",TYPE,0))
SET Y=""
+4 IF I
MERGE TXT=^GMR(120.8,IEN,26,I,2)
SET Y=$$STRING^VPRD(.TXT)
+5 QUIT Y
+6 ;
CMTS(IEN) ; -- return list of comments in
+1 ; DLIST(#) = id ^ date ^ user ^ type ^ facility ^ text
+2 ; expects VASITE (read only) from Entity
+3 NEW I,X,Y,TXT
SET IEN=+$GET(IEN)
+4 SET I=0
FOR
SET I=$ORDER(^GMR(120.8,IEN,26,I))
if I<1
QUIT
SET X=$GET(^(I,0))
Begin DoDot:1
+5 if $PIECE(X,U,3)="E"
QUIT
+6 SET $PIECE(X,U,3)=$$EXTERNAL^DILFD(120.826,1.5,,$PIECE(X,U,3))
+7 MERGE TXT=^GMR(120.8,IEN,26,I,2)
SET Y=$$STRING^VPRD(.TXT)
+8 SET DLIST(I)=I_","_IEN_U_X_U_+$GET(VASITE)_U_Y
End DoDot:1
+9 QUIT
+10 ;
SEVRTY(IEN) ; -- return overall Allergy Severity
+1 NEW I,SEV,X,Y
+2 SET (SEV,Y)=""
SET I=0
+3 IF $DATA(GMRAY("H"))
SET SEV=$PIECE(GMRAY("H"),U,2)
+4 ; else find highest severity among reactions
+5 FOR
SET I=$ORDER(GMRAY("O",I))
if I<1
QUIT
SET X=$PIECE(GMRAY("O",I),U,2)
IF $LENGTH(X)
Begin DoDot:1
+6 IF X?1"LIFE".E
SET SEV=X
QUIT
+7 IF X]SEV
SET SEV=X
End DoDot:1
+8 IF $LENGTH(SEV)>1
SET Y=$$SNOMED(SEV)
+9 QUIT Y
+10 ;
SNOMED(SEV) ; -- return SEVerity name as coded element
+1 NEW X,Y
SET SEV=$GET(SEV)
SET X=$EXTRACT(SEV,1,2)
+2 SET Y=$SELECT(X="MI":255604002,X="MO":6736007,X="SE":24484000,X="LI":442452003,1:"")
+3 IF Y
SET Y=Y_U_SEV_"^SNOMED CT"
+4 IF '$TEST
SET Y=SEV_U_SEV
+5 QUIT Y
+6 ;
EVTDT(IEN) ; -- return first D/T of Event
+1 IF $GET(GMRAY("H"))
SET Y=$PIECE(GMRAY("H"),U)
QUIT Y
+2 NEW I,RDT,X,Y
+3 SET I=0
SET RDT=9999999
SET Y=""
+4 ; find first date.time among reactions
+5 FOR
SET I=$ORDER(GMRAY("O",I))
if I<1
QUIT
SET X=$PIECE(GMRAY("O",I),U)
if X<RDT
SET RDT=X
+6 if RDT<9999999
SET Y=RDT
+7 QUIT Y
+8 ;
REACTN(IEN) ; -- convert ien^name[^date] to national code for Sign/Symptom
+1 ; Returns +IEN, VPRDT=date [for extension],
+2 ; VPREACTN=code^name^system [SNOMED or VUID],
+3 ; VPRNAME =local name [Original Text]
+4 NEW Y
SET Y=""
KILL VPRNAME
+5 SET VPREACTN=$PIECE($GET(IEN),U,1,2)
SET VPRDT=$PIECE($GET(IEN),U,3)
SET IEN=+$GET(IEN)
+6 SET Y=$$CODE^VPRSDA(IEN,120.83,"SCT")
if $LENGTH(Y)
SET VPRNAME=$PIECE(VPREACTN,U,2)
+7 IF Y=""
SET Y=$$VUID^VPRD(IEN,120.83)
if $LENGTH(Y)
SET Y=Y_U_$PIECE(VPREACTN,U,2)_"^VHAT"
+8 ;return code string
if $LENGTH(Y)
SET VPREACTN=Y
+9 QUIT
+10 ;
ASSESS ; -- get Assessment #120.86 for patient
+1 ; expects ID (read only) from Entity
+2 IF '$GET(DFN)
IF $GET(ID)
SET DFN=ID
+3 ;has allergies
if '$GET(DFN)
QUIT
if $PIECE($GET(^GMR(120.86,DFN,0)),U,2)
QUIT
+4 SET DLIST(1)=DFN
+5 QUIT
