Routine: VPRSDAL

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

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")

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

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

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRSDAL   4186     printed  Feb 19, 2025@00:12:21                                                                                                                                                                                                     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

VPRSDAL.m