GMRAPEM0 ; HIRMFO/WAA,FT - ALLERGY/ADVERSE REACTION PATIENT EDIT DRIVER; October 18, 2023@08:47:00
;;4.0;Adverse Reaction Tracking;**2,5,17,21,36,50,58,63,51,68**;Mar 29, 1996;Build 5
;
; Reference to $$ONOFF^ORB3USER in ICR #7211
; Reference to CHKMEDS^ORWDAL32,GETPROV^ORWDAL32,SENDALRT^ORWDAL32 in ICR #6756
;
EN11 ; Entry point for GMRA USER E/E PAT REC DATA option
; GMRAUSER is a flag that indicates that this is a User
; If user has Verifier Key then user will act normal
I '$D(^XUSEC("GMRA-ALLERGY VERIFY",DUZ)) S GMRAUSER=1
;
EN1 ; Entry for ENTER/EDIT PATIENT REACTION DATA option
; EDIT PATIENT A/AR (DFN UNK.)
S GMRAOUT=0
W @IOF D PAT^GMRAPAT ; Select A Patient
D:'GMRAOUT EN21 G:'GMRAOUT EN1
K DFN,DIC,GMRAOUT,GMRARET,GMA,GMRAUSER
D EXIT,EN1^GMRAKILL
Q
;
EN21 ; Process patient data and determine if patient is NKA
S GMRAOUT=$G(GMRAOUT,0)
; check patient assessment before enter/edit reaction
I $$NKA^GMRANKA(DFN),$$NKASCR^GMRANKA(DFN) D ;delete 120.86 entry if assessment=yes, but no active reactions in 120.8
.N DA,DIK
.S DIK="^GMR(120.86,",DA=DFN D ^DIK
.Q
I '$$NKA^GMRANKA(DFN) D NKAASK^GMRANKA(DFN,.GMRAOUT) Q:GMRAOUT I '$$NKA^GMRANKA(DFN) Q
L +^XTMP("GMRAED",DFN):1 I '$T D MESS^GMRAGUI1 Q ;21
S GMRAOUT=0
D:'GMRAOUT SELECT
I $G(GMRAPA)'>0 S GMRAOUT=0
S GMRARP=1 I 'GMRAOUT D
.D ASK^GMRAUTL("Enter another Causative Agent? ",.GMRAOUT,.GMRARP)
.I 'GMRARP S GMRACNT=$O(^TMP($J,"GMRASF","B"),-1) D
..I GMRACNT D SIGNOFF^GMRASIGN
..I 'GMRAOUT D IDBAND^GMRASIGN
..I GMRAOUT S GMRAOUT=2-GMRAOUT D:GMRAOUT&($D(^TMP($J,"GMRASF"))) ALERT^GMRASIGN K ^TMP($J,"GMRASF"),GMRACNT
..Q
.Q
I GMRARP,'GMRAOUT K GMRARP L -^XTMP("GMRAED",DFN) G EN21 ;21
K GMRARP
; check patient assessment when exiting enter/edit reaction
I $$NKA^GMRANKA(DFN),$$NKASCR^GMRANKA(DFN) D ;delete 120.86 entry if assessment=yes, but no active reactions in 120.8
.N DA,DIK
.S DIK="^GMR(120.86,",DA=DFN D ^DIK
.Q
L -^XTMP("GMRAED",DFN) ;21
Q
;
EN2 ; EDIT PATIENT A/AR (DFN KNOWN)
; Called from the GMRAOR ALLERGY ENTER/EDIT protocol
I '$D(^XUSEC("GMRA-ALLERGY VERIFY",DUZ)) S GMRAUSER=1
N GMRAOUT
D EN21 D
.;N GMRAOUT
.D EXIT,EN1^GMRAKILL
.Q
K GMA,GMRARET,GMRAUSER
Q
;
ALERT ; PROCESS ALERTS FOR ART
N DFN,GMRAPA,GMRACNT,GMRAOUT,GMRANEW,GMRAUSER
S (GMRACNT,GMRAOUT,GMRANEW)=0 D
. I $G(XQADATA)="" S XQAKILL=0 Q
. S DFN=$P(XQADATA,U),GMRAPA=$P(XQADATA,U,2),GMRAUSER=$P(XQADATA,U,3) Q:'DFN!'GMRAPA
. I $D(^XUSEC("GMRA-ALLERGY VERIFY",DUZ)) K GMRAUSER
. S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)=""
. I $P(GMRAPA(0),U,12) D Q
. . W !,"This reaction has been signed off.",$C(7)
. . D HANGT^GMRAPEH0
. . S XQAKILL=0
. . Q
. D EDIT^GMRAPEM4
. D UPDATE^GMRAPEM3
. I '$P(GMRAPA(0),U,12) D SIGNOFF^GMRASIGN
. I GMRAOUT S GMRAOUT=2-GMRAOUT K XQAKILL
. E D
. .I $P(GMRAPA(0),U,12) S XQAKILL=0
. .I '$P(GMRAPA(0),U,12) K XQAKILL
. D EXIT,EN1^GMRAKILL
. Q
Q
;
SELECT ;Select a patient reaction
S GMRACNT=0 D 1^VADPT
S GMRALOC=$P(VAIN(4),U,2),GMRANAM=VADM(1),GMRASEX=VADM(5),GMRAOUT=0,GMRAOTH=$O(^GMRD(120.83,"B","OTHER REACTION",0)) D KVAR^VADPT K VA,VAROOT
K GMRADUP S GMRALAGO=1
D REACT^GMRAPAT(DFN) ; Load all reaction for this patient.
D EN1^GMRAPES0
I GMRAPA>0 D TYPE D
.I $G(GMRAEVT) D XQOR ;post event if anything edited ;P68
.I GMRAOUT D:$G(GMRANEW) DELETE S:'$$MISSREQ&('$P($G(GMRAPA(0)),U,12)) GMRAOUT=0,^TMP($J,"GMRASF","B",GMRAPA,GMRACNT)="",^TMP($J,"GMRASF",GMRACNT,GMRAPA)="" D:GMRAOUT UPOUT^GMRAPEM3 Q ; 21,36
.I GMRAERR D ERR^GMRAPEM3 Q ;The reaction was entered in error
.I $P(GMRAPA(0),U,12) D SIGNED^GMRAPEM3 Q ;The reaction has been signed
.; Reaction is a new reaction or Update data
.I GMRANEW D GMRACHK^GMRAPEM0(GMRAPA)
.I GMRANEW D MEDCHK ; NSR 20070203
.D UPDATE^GMRAPEM3
.Q
K GMRAEVT
Q
;
TYPE ; Select the type of the process to use this reaction
S GMRAERR=0,GMRAEVT=0 K GMRAPA1
; If reaction is not new check to see if user want to enter in error
I 'GMRANEW W @IOF N GMRADFN D EN1^GMRAPEE0 I GMRAERR!GMRAOUT Q
;If reaction is observed and signed off
I $P(GMRAPA(0),U,6)="o",$P(GMRAPA(0),U,12) D Q:GMRAOUT
.Q:$G(GMRAUSER,0)
.N GMRARP
.S GMRARP=0 D ASK^GMRAUTL("DO YOU WISH TO EDIT OBSERVED DATA? ",.GMRAOUT,.GMRARP) Q:GMRAOUT
.Q:'GMRARP ;Observed data
.N GMRAOD S GMRAOD=$D(^GMR(120.85,"C",GMRAPA)) ;Existing observation data?
OBSDATE .;
.S GMRALAGO=1 F D EN2^GMRAU85 Q:GMRAPA1>0 Q:GMRAOUT W !,"You must enter a valid date or an Up-arrow to exit",!,$C(7)
.I 'GMRAOUT,GMRAPA1>0 D EN2^GMRAROBS S:$P($G(^GMR(120.8,GMRAPA,0)),U,16)=1 GMRAEVT=1 ;P68
.I '$D(^GMR(120.85,"C",GMRAPA)),$G(GMRANEW)!('$G(GMRANEW)&($G(GMRAOD))) D OBSPROB S GMRAOUT=0 G OBSDATE
.Q
;Verify data
I 'GMRAERR,$P($G(^GMR(120.8,GMRAPA,0)),U,16)=0,$P(GMRAPA(0),U,12)=1,$D(^XUSEC("GMRA-ALLERGY VERIFY",DUZ)) D Q:GMRAOUT
.K GMRAVER S GMRAVER=0
.N GMRAPRNT D EN1^GMRAVFY K GMRALLER,GMRAMEC,GMRAY
.I $P($G(^GMR(120.8,GMRAPA,0)),U,16)=1 S GMRASLL(GMRAPA)=1
.Q
;EDIT Verified data
I 'GMRAERR,$P($G(^GMR(120.8,GMRAPA,0)),U,16)=1,$D(^XUSEC("GMRA-ALLERGY VERIFY",DUZ)) D Q:GMRAOUT
.Q:$G(GMRAVER)=1
.N GMRARP
.S GMRARP=0
.D ASK^GMRAUTL("DO YOU WISH TO EDIT VERIFIED DATA? ",.GMRAOUT,.GMRARP) Q:GMRAOUT
.I GMRARP D SITE^GMRAUTL,EN1^GMRAPED0 S GMRAEVT=1 ;P68
.Q
;if the reaction is new or not signed off
I '$P(GMRAPA(0),U,12) D
.D EDIT^GMRAPEM4
.I $P($G(^GMR(120.8,GMRAPA,0)),U,16) S GMRASLL(GMRAPA)=1
.Q
Q
;
EXIT S GMRAPA=0 F S GMRAPA=$O(^TMP($J,"GMRASF","B",GMRAPA)) Q:GMRAPA<1 D UNLOCK^GMRAUTL(120.8,GMRAPA)
K ^TMP($J,"GMRASF")
K ^TMP($J,"GMRALST")
Q
;
DELETE ;Delete entry if required information is not entered - section added in 17
N DA,DIK,GMRAPA1
W !!,"Entry process not completed, deleting entry...",!
S GMRAPA1=$O(^GMR(120.85,"C",GMRAPA,0))
I GMRAPA1,$G(^GMR(120.85,GMRAPA1,0))="" K ^GMR(120.85,"C",GMRAPA,GMRAPA1)
I GMRAPA1 S DIK="^GMR(120.85,",DA=GMRAPA1 D ^DIK D UNLOCK^GMRAUTL(120.85,GMRAPA1)
I GMRAPA S DIK="^GMR(120.8,",DA=GMRAPA D ^DIK D UNLOCK^GMRAUTL(120.8,GMRAPA)
Q
;
OBSPROB ;Display help information for missing observed date/time entry
W !!,"Observed reactions must have at least one observation entry.",!,"If this reaction is incorrect then enter a date and then proceed",!,"to mark it as entered in error.",!
Q
;
MISSREQ() ;Function determines if required data is missing
N GMRA0,TYPE
S GMRA0=$G(^GMR(120.8,+$G(GMRAPA),0)) I GMRA0="" Q 1 ;Entry not found
S TYPE=$P(GMRA0,U,6) ;Get observed/historical
I TYPE="" Q 1 ;Type not entered
I TYPE="h" Q 0 ;Historical has no requirements
I TYPE="o" I '$D(^GMR(120.85,"C",GMRAPA))!('$O(^GMR(120.85,+$O(^GMR(120.85,"C",GMRAPA,0)),2,0)))!('$$REQCOM) Q 1 ;Missing obs date/time or sign/symptom or required comment
Q 0
;
REQCOM() ;Function determines if comments required
I '$D(GMRASITE) D SITE^GMRAUTL
I +$P(^GMRD(120.84,+GMRASITE,0),U,4)=0 Q 1 ;Comments required?
I $O(^GMR(120.8,GMRAPA,26,0)) Q 1
Q 0
;
GMRACHK(GMRAPA) ;
;Send a warning MailMan message if the VA DRUG CLASS field is empty.
;Get the first, if any,VA DRUG CLASS entries for this agent.
N PATALLER,VADRCL1,PATNAME,REAC,REACTS,LINE
N PATIEN,SSN,LAST4
D GETS^DIQ(120.8,GMRAPA_",","**","E","PATALLER")
;mod by CAS - to skip all but "D" Drug type reactions
I $P($G(^GMR(120.8,GMRAPA,0)),"^",20)'["D" Q
S VADRCL1=$G(PATALLER(120.803,"1,"_GMRAPA_",",.01,"E"))
S PATNAME=$G(PATALLER(120.8,GMRAPA_",",.01,"E"))
S PATIEN=$$GET1^DIQ(120.8,GMRAPA,.01,"I")
S SSN=$$GET1^DIQ(2,PATIEN,.09,"E")
S LAST4=$E(PATNAME,1,1)_$E(SSN,6,9)
I '$G(GMRAERR),(VADRCL1=""),(PATNAME'="") D
. K ^XTMP("GMRACHK",$J)
. S LINE=1
. S ^XTMP("GMRACHK",$J,LINE)="The following allergy/adverse reaction may need a VA DRUG CLASS added"
. S LINE=LINE+1
. S ^XTMP("GMRACHK",$J,LINE)="for the following Patient:"
. S LINE=LINE+1
. S ^XTMP("GMRACHK",$J,LINE)=""
. S LINE=LINE+1
. S ^XTMP("GMRACHK",$J,LINE)="Patient: "_PATNAME
. S LINE=LINE+1
. S ^XTMP("GMRACHK",$J,LINE)="LAST4: "_LAST4
. S LINE=LINE+1
. S ^XTMP("GMRACHK",$J,LINE)="Reactant: "_$G(PATALLER(120.8,GMRAPA_",",.02,"E"))
. S LINE=LINE+1
. ;Build a pretty string of reactions
. S REAC=1
. S REACTS=$G(PATALLER(120.81,REAC_","_GMRAPA_",",.01,"E"))
. S REAC=REAC+1
. F Q:'$D(PATALLER(120.81,REAC_","_GMRAPA_",",.01,"E")) D
. . S REACTS=REACTS_", "_$G(PATALLER(120.81,REAC_","_GMRAPA_",",.01,"E"))
. . S REAC=REAC+1
. S ^XTMP("GMRACHK",$J,LINE)="Reactions: "_REACTS
. S LINE=LINE+1
. S ^XTMP("GMRACHK",$J,LINE)="OBS/HIS: "_$G(PATALLER(120.8,GMRAPA_",",6,"E"))
. S LINE=LINE+1
. S ^XTMP("GMRACHK",$J,LINE)="Location: "_$$GET1^DIQ(405,$$GET1^DIQ(2,DFN,.102,"I"),.06,"E")
. S LINE=LINE+1
. S XMDUZ=DUZ
. S XMTEXT="^XTMP(""GMRACHK"","_$J_","
. I $G(DUZ(2))="" S DUZ(2)=+$$STA^XUAF4($$KSP^XUPARAM("INST"))
. S XMSUB="ALLERGY/ADVERSE REACTION WITHOUT VA DRUG CLASS ("
. S XMSUB=XMSUB_$P($$NS^XUAF4(DUZ(2)),U)_")"
. S XMY("G.ADVERSE_ALLERGY_WARNING")=""
. D ^XMD
. K ^XTMP("GMRACHK",$J)
Q
;
MEDCHK ; NSR 20070203
N GMRAMCHK
W !!,?2,"Checking new allergy against the patient's active medication profile . . . "
D CHKMEDS^ORWDAL32(.GMRAMCHK,$P(GMRAPA(0),"^"),$P(GMRAPA(0),"^",2))
I GMRAMCHK'>0 W !!,?2,"No conflicts were discovered.",! K GMRAMCHK Q
I GMRAMCHK>0 D
. N GMRADA,GMRAYN,GMRAPROV,GMRASEND,GMRASLST,GMRALST,GMRAORD,GMRADUZ,GMRAOUT
. W !!,?2,"The following Active Orders contain "_$P(GMRAPA(0),"^",2)_":"
. S GMRADA=""
. F S GMRADA=$O(GMRAMCHK(GMRADA)) Q:GMRADA="" I $D(GMRAMCHK(GMRADA)) D
. . W !!,$P(GMRAMCHK(GMRADA),"^",3)_" (Order #"_$P(GMRAMCHK(GMRADA),"^")_") An alert will be sent to:"
. . D GETPROV^ORWDAL32(.GMRAPROV,$P(GMRAMCHK(GMRADA),"^"),+$G(DFN))
. . N PRVDA S PRVDA=""
. . F S PRVDA=$O(GMRAPROV(PRVDA)) Q:PRVDA="" I $D(GMRAPROV(PRVDA)) D
. . . S GMRASLST($P(GMRAMCHK(GMRADA),"^"),$P(GMRAPROV(PRVDA),";"))=GMRAPROV(PRVDA)
. . . W !?3,$P(GMRAPROV(PRVDA),"^",2)," - ",$P(GMRAPROV(PRVDA),"^",3)
. . K GMRAPROV
. W !!
. S (GMRAOUT,GMRAYN)=0 D ASK^GMRAUTL("Do you wish to send the alert(s) to additional recipients? ",.GMRAOUT,.GMRAYN) Q:GMRAOUT
. I GMRAYN D ADDSTHR(.GMRALST)
. I $D(GMRASLST) S GMRAORD="" F S GMRAORD=$O(GMRASLST(GMRAORD)) Q:GMRAORD="" I $D(GMRASLST(GMRAORD)) D
. . K GMRAPROV
. . S GMRAPROV=""
. . I $D(GMRALST) M GMRAPROV=GMRALST
. . D SENDALRT^ORWDAL32(.GMRASEND,GMRAORD,.GMRAPROV)
. K GMRASEND,GMRASLST
K GMRAMCHK
Q
;
ADDSTHR(GMRALST) ; NSR 20070203
K GMRALST
N DIC,I,GMRAYN,GMRAON,GMRANOTE,GMRAOUT,Y
S GMRAYN=0
S GMRANOTE=88 ;NEW ALLERGY ENTERED/ACTIVE MED notification
F I=1:1 D Q:'GMRAYN
. S DIC="^VA(200,",DIC(0)="AEBQ"
. S DIC("A")="Enter Recipient's Name: " D ^DIC
. I +Y>0 D
. . S GMRAON=$P($$ONOFF^ORB3USER(GMRANOTE,+Y,"","",""),U,1)
. . I GMRAON="OFF" W !!," User is unable to receive the notification!",! Q
. . S GMRALST($P(Y,"^"))=$P(Y,"^")_";VA(200,"_"^"_$P(Y,"^",2) K DIC,Y
. S (GMRAOUT,GMRAYN)=0 D ASK^GMRAUTL("Add another recipient? ",.GMRAOUT,.GMRAYN) Q:GMRAOUT
Q
;
XQOR ; GMRA EDIT VERIFIED DATA event driver ;P68
N X S X=+$O(^ORD(101,"B","GMRA EDIT VERIFIED DATA",0))_";ORD(101,"
Q:'X Q:'$G(GMRAPA)
S:'$D(GMRAPA(0)) GMRAPA(0)=$G(^GMR(120.8,+GMRAPA,0))
I $D(GMRAPA1) D
. S:$G(GMRAPA1)>0 GMRAPA1(0)=$G(^GMR(120.85,+GMRAPA1,0))
. ; cleanup GMRAPA1 if no selection (carried over from last edit)
. I $G(GMRAPA1)<0!($P(GMRAPA1(0),U,15)'=GMRAPA) K GMRAPA1
D:X EN^XQOR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRAPEM0 11601 printed Sep 23, 2025@19:15:55 Page 2
GMRAPEM0 ; HIRMFO/WAA,FT - ALLERGY/ADVERSE REACTION PATIENT EDIT DRIVER; October 18, 2023@08:47:00
+1 ;;4.0;Adverse Reaction Tracking;**2,5,17,21,36,50,58,63,51,68**;Mar 29, 1996;Build 5
+2 ;
+3 ; Reference to $$ONOFF^ORB3USER in ICR #7211
+4 ; Reference to CHKMEDS^ORWDAL32,GETPROV^ORWDAL32,SENDALRT^ORWDAL32 in ICR #6756
+5 ;
EN11 ; Entry point for GMRA USER E/E PAT REC DATA option
+1 ; GMRAUSER is a flag that indicates that this is a User
+2 ; If user has Verifier Key then user will act normal
+3 IF '$DATA(^XUSEC("GMRA-ALLERGY VERIFY",DUZ))
SET GMRAUSER=1
+4 ;
EN1 ; Entry for ENTER/EDIT PATIENT REACTION DATA option
+1 ; EDIT PATIENT A/AR (DFN UNK.)
+2 SET GMRAOUT=0
+3 ; Select A Patient
WRITE @IOF
DO PAT^GMRAPAT
+4 if 'GMRAOUT
DO EN21
if 'GMRAOUT
GOTO EN1
+5 KILL DFN,DIC,GMRAOUT,GMRARET,GMA,GMRAUSER
+6 DO EXIT
DO EN1^GMRAKILL
+7 QUIT
+8 ;
EN21 ; Process patient data and determine if patient is NKA
+1 SET GMRAOUT=$GET(GMRAOUT,0)
+2 ; check patient assessment before enter/edit reaction
+3 ;delete 120.86 entry if assessment=yes, but no active reactions in 120.8
IF $$NKA^GMRANKA(DFN)
IF $$NKASCR^GMRANKA(DFN)
Begin DoDot:1
+4 NEW DA,DIK
+5 SET DIK="^GMR(120.86,"
SET DA=DFN
DO ^DIK
+6 QUIT
End DoDot:1
+7 IF '$$NKA^GMRANKA(DFN)
DO NKAASK^GMRANKA(DFN,.GMRAOUT)
if GMRAOUT
QUIT
IF '$$NKA^GMRANKA(DFN)
QUIT
+8 ;21
LOCK +^XTMP("GMRAED",DFN):1
IF '$TEST
DO MESS^GMRAGUI1
QUIT
+9 SET GMRAOUT=0
+10 if 'GMRAOUT
DO SELECT
+11 IF $GET(GMRAPA)'>0
SET GMRAOUT=0
+12 SET GMRARP=1
IF 'GMRAOUT
Begin DoDot:1
+13 DO ASK^GMRAUTL("Enter another Causative Agent? ",.GMRAOUT,.GMRARP)
+14 IF 'GMRARP
SET GMRACNT=$ORDER(^TMP($JOB,"GMRASF","B"),-1)
Begin DoDot:2
+15 IF GMRACNT
DO SIGNOFF^GMRASIGN
+16 IF 'GMRAOUT
DO IDBAND^GMRASIGN
+17 IF GMRAOUT
SET GMRAOUT=2-GMRAOUT
if GMRAOUT&($DATA(^TMP($JOB,"GMRASF")))
DO ALERT^GMRASIGN
KILL ^TMP($JOB,"GMRASF"),GMRACNT
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 ;21
IF GMRARP
IF 'GMRAOUT
KILL GMRARP
LOCK -^XTMP("GMRAED",DFN)
GOTO EN21
+21 KILL GMRARP
+22 ; check patient assessment when exiting enter/edit reaction
+23 ;delete 120.86 entry if assessment=yes, but no active reactions in 120.8
IF $$NKA^GMRANKA(DFN)
IF $$NKASCR^GMRANKA(DFN)
Begin DoDot:1
+24 NEW DA,DIK
+25 SET DIK="^GMR(120.86,"
SET DA=DFN
DO ^DIK
+26 QUIT
End DoDot:1
+27 ;21
LOCK -^XTMP("GMRAED",DFN)
+28 QUIT
+29 ;
EN2 ; EDIT PATIENT A/AR (DFN KNOWN)
+1 ; Called from the GMRAOR ALLERGY ENTER/EDIT protocol
+2 IF '$DATA(^XUSEC("GMRA-ALLERGY VERIFY",DUZ))
SET GMRAUSER=1
+3 NEW GMRAOUT
+4 DO EN21
Begin DoDot:1
+5 ;N GMRAOUT
+6 DO EXIT
DO EN1^GMRAKILL
+7 QUIT
End DoDot:1
+8 KILL GMA,GMRARET,GMRAUSER
+9 QUIT
+10 ;
ALERT ; PROCESS ALERTS FOR ART
+1 NEW DFN,GMRAPA,GMRACNT,GMRAOUT,GMRANEW,GMRAUSER
+2 SET (GMRACNT,GMRAOUT,GMRANEW)=0
Begin DoDot:1
+3 IF $GET(XQADATA)=""
SET XQAKILL=0
QUIT
+4 SET DFN=$PIECE(XQADATA,U)
SET GMRAPA=$PIECE(XQADATA,U,2)
SET GMRAUSER=$PIECE(XQADATA,U,3)
if 'DFN!'GMRAPA
QUIT
+5 IF $DATA(^XUSEC("GMRA-ALLERGY VERIFY",DUZ))
KILL GMRAUSER
+6 SET GMRAPA(0)=$GET(^GMR(120.8,GMRAPA,0))
if GMRAPA(0)=""
QUIT
+7 IF $PIECE(GMRAPA(0),U,12)
Begin DoDot:2
+8 WRITE !,"This reaction has been signed off.",$CHAR(7)
+9 DO HANGT^GMRAPEH0
+10 SET XQAKILL=0
+11 QUIT
End DoDot:2
QUIT
+12 DO EDIT^GMRAPEM4
+13 DO UPDATE^GMRAPEM3
+14 IF '$PIECE(GMRAPA(0),U,12)
DO SIGNOFF^GMRASIGN
+15 IF GMRAOUT
SET GMRAOUT=2-GMRAOUT
KILL XQAKILL
+16 IF '$TEST
Begin DoDot:2
+17 IF $PIECE(GMRAPA(0),U,12)
SET XQAKILL=0
+18 IF '$PIECE(GMRAPA(0),U,12)
KILL XQAKILL
End DoDot:2
+19 DO EXIT
DO EN1^GMRAKILL
+20 QUIT
End DoDot:1
+21 QUIT
+22 ;
SELECT ;Select a patient reaction
+1 SET GMRACNT=0
DO 1^VADPT
+2 SET GMRALOC=$PIECE(VAIN(4),U,2)
SET GMRANAM=VADM(1)
SET GMRASEX=VADM(5)
SET GMRAOUT=0
SET GMRAOTH=$ORDER(^GMRD(120.83,"B","OTHER REACTION",0))
DO KVAR^VADPT
KILL VA,VAROOT
+3 KILL GMRADUP
SET GMRALAGO=1
+4 ; Load all reaction for this patient.
DO REACT^GMRAPAT(DFN)
+5 DO EN1^GMRAPES0
+6 IF GMRAPA>0
DO TYPE
Begin DoDot:1
+7 ;post event if anything edited ;P68
IF $GET(GMRAEVT)
DO XQOR
+8 ; 21,36
IF GMRAOUT
if $GET(GMRANEW)
DO DELETE
if '$$MISSREQ&('$PIECE($GET(GMRAPA(0)),U,12))
SET GMRAOUT=0
SET ^TMP($JOB,"GMRASF","B",GMRAPA,GMRACNT)=""
SET ^TMP($JOB,"GMRASF",GMRACNT,GMRAPA)=""
if GMRAOUT
DO UPOUT^GMRAPEM3
QUIT
+9 ;The reaction was entered in error
IF GMRAERR
DO ERR^GMRAPEM3
QUIT
+10 ;The reaction has been signed
IF $PIECE(GMRAPA(0),U,12)
DO SIGNED^GMRAPEM3
QUIT
+11 ; Reaction is a new reaction or Update data
+12 IF GMRANEW
DO GMRACHK^GMRAPEM0(GMRAPA)
+13 ; NSR 20070203
IF GMRANEW
DO MEDCHK
+14 DO UPDATE^GMRAPEM3
+15 QUIT
End DoDot:1
+16 KILL GMRAEVT
+17 QUIT
+18 ;
TYPE ; Select the type of the process to use this reaction
+1 SET GMRAERR=0
SET GMRAEVT=0
KILL GMRAPA1
+2 ; If reaction is not new check to see if user want to enter in error
+3 IF 'GMRANEW
WRITE @IOF
NEW GMRADFN
DO EN1^GMRAPEE0
IF GMRAERR!GMRAOUT
QUIT
+4 ;If reaction is observed and signed off
+5 IF $PIECE(GMRAPA(0),U,6)="o"
IF $PIECE(GMRAPA(0),U,12)
Begin DoDot:1
+6 if $GET(GMRAUSER,0)
QUIT
+7 NEW GMRARP
+8 SET GMRARP=0
DO ASK^GMRAUTL("DO YOU WISH TO EDIT OBSERVED DATA? ",.GMRAOUT,.GMRARP)
if GMRAOUT
QUIT
+9 ;Observed data
if 'GMRARP
QUIT
+10 ;Existing observation data?
NEW GMRAOD
SET GMRAOD=$DATA(^GMR(120.85,"C",GMRAPA))
OBSDATE ;
+1 SET GMRALAGO=1
FOR
DO EN2^GMRAU85
if GMRAPA1>0
QUIT
if GMRAOUT
QUIT
WRITE !,"You must enter a valid date or an Up-arrow to exit",!,$CHAR(7)
+2 ;P68
IF 'GMRAOUT
IF GMRAPA1>0
DO EN2^GMRAROBS
if $PIECE($GET(^GMR(120.8,GMRAPA,0)),U,16)=1
SET GMRAEVT=1
+3 IF '$DATA(^GMR(120.85,"C",GMRAPA))
IF $GET(GMRANEW)!('$GET(GMRANEW)&($GET(GMRAOD)))
DO OBSPROB
SET GMRAOUT=0
GOTO OBSDATE
+4 QUIT
End DoDot:1
if GMRAOUT
QUIT
+5 ;Verify data
+6 IF 'GMRAERR
IF $PIECE($GET(^GMR(120.8,GMRAPA,0)),U,16)=0
IF $PIECE(GMRAPA(0),U,12)=1
IF $DATA(^XUSEC("GMRA-ALLERGY VERIFY",DUZ))
Begin DoDot:1
+7 KILL GMRAVER
SET GMRAVER=0
+8 NEW GMRAPRNT
DO EN1^GMRAVFY
KILL GMRALLER,GMRAMEC,GMRAY
+9 IF $PIECE($GET(^GMR(120.8,GMRAPA,0)),U,16)=1
SET GMRASLL(GMRAPA)=1
+10 QUIT
End DoDot:1
if GMRAOUT
QUIT
+11 ;EDIT Verified data
+12 IF 'GMRAERR
IF $PIECE($GET(^GMR(120.8,GMRAPA,0)),U,16)=1
IF $DATA(^XUSEC("GMRA-ALLERGY VERIFY",DUZ))
Begin DoDot:1
+13 if $GET(GMRAVER)=1
QUIT
+14 NEW GMRARP
+15 SET GMRARP=0
+16 DO ASK^GMRAUTL("DO YOU WISH TO EDIT VERIFIED DATA? ",.GMRAOUT,.GMRARP)
if GMRAOUT
QUIT
+17 ;P68
IF GMRARP
DO SITE^GMRAUTL
DO EN1^GMRAPED0
SET GMRAEVT=1
+18 QUIT
End DoDot:1
if GMRAOUT
QUIT
+19 ;if the reaction is new or not signed off
+20 IF '$PIECE(GMRAPA(0),U,12)
Begin DoDot:1
+21 DO EDIT^GMRAPEM4
+22 IF $PIECE($GET(^GMR(120.8,GMRAPA,0)),U,16)
SET GMRASLL(GMRAPA)=1
+23 QUIT
End DoDot:1
+24 QUIT
+25 ;
EXIT SET GMRAPA=0
FOR
SET GMRAPA=$ORDER(^TMP($JOB,"GMRASF","B",GMRAPA))
if GMRAPA<1
QUIT
DO UNLOCK^GMRAUTL(120.8,GMRAPA)
+1 KILL ^TMP($JOB,"GMRASF")
+2 KILL ^TMP($JOB,"GMRALST")
+3 QUIT
+4 ;
DELETE ;Delete entry if required information is not entered - section added in 17
+1 NEW DA,DIK,GMRAPA1
+2 WRITE !!,"Entry process not completed, deleting entry...",!
+3 SET GMRAPA1=$ORDER(^GMR(120.85,"C",GMRAPA,0))
+4 IF GMRAPA1
IF $GET(^GMR(120.85,GMRAPA1,0))=""
KILL ^GMR(120.85,"C",GMRAPA,GMRAPA1)
+5 IF GMRAPA1
SET DIK="^GMR(120.85,"
SET DA=GMRAPA1
DO ^DIK
DO UNLOCK^GMRAUTL(120.85,GMRAPA1)
+6 IF GMRAPA
SET DIK="^GMR(120.8,"
SET DA=GMRAPA
DO ^DIK
DO UNLOCK^GMRAUTL(120.8,GMRAPA)
+7 QUIT
+8 ;
OBSPROB ;Display help information for missing observed date/time entry
+1 WRITE !!,"Observed reactions must have at least one observation entry.",!,"If this reaction is incorrect then enter a date and then proceed",!,"to mark it as entered in error.",!
+2 QUIT
+3 ;
MISSREQ() ;Function determines if required data is missing
+1 NEW GMRA0,TYPE
+2 ;Entry not found
SET GMRA0=$GET(^GMR(120.8,+$GET(GMRAPA),0))
IF GMRA0=""
QUIT 1
+3 ;Get observed/historical
SET TYPE=$PIECE(GMRA0,U,6)
+4 ;Type not entered
IF TYPE=""
QUIT 1
+5 ;Historical has no requirements
IF TYPE="h"
QUIT 0
+6 ;Missing obs date/time or sign/symptom or required comment
IF TYPE="o"
IF '$DATA(^GMR(120.85,"C",GMRAPA))!('$ORDER(^GMR(120.85,+$ORDER(^GMR(120.85,"C",GMRAPA,0)),2,0)))!('$$REQCOM)
QUIT 1
+7 QUIT 0
+8 ;
REQCOM() ;Function determines if comments required
+1 IF '$DATA(GMRASITE)
DO SITE^GMRAUTL
+2 ;Comments required?
IF +$PIECE(^GMRD(120.84,+GMRASITE,0),U,4)=0
QUIT 1
+3 IF $ORDER(^GMR(120.8,GMRAPA,26,0))
QUIT 1
+4 QUIT 0
+5 ;
GMRACHK(GMRAPA) ;
+1 ;Send a warning MailMan message if the VA DRUG CLASS field is empty.
+2 ;Get the first, if any,VA DRUG CLASS entries for this agent.
+3 NEW PATALLER,VADRCL1,PATNAME,REAC,REACTS,LINE
+4 NEW PATIEN,SSN,LAST4
+5 DO GETS^DIQ(120.8,GMRAPA_",","**","E","PATALLER")
+6 ;mod by CAS - to skip all but "D" Drug type reactions
+7 IF $PIECE($GET(^GMR(120.8,GMRAPA,0)),"^",20)'["D"
QUIT
+8 SET VADRCL1=$GET(PATALLER(120.803,"1,"_GMRAPA_",",.01,"E"))
+9 SET PATNAME=$GET(PATALLER(120.8,GMRAPA_",",.01,"E"))
+10 SET PATIEN=$$GET1^DIQ(120.8,GMRAPA,.01,"I")
+11 SET SSN=$$GET1^DIQ(2,PATIEN,.09,"E")
+12 SET LAST4=$EXTRACT(PATNAME,1,1)_$EXTRACT(SSN,6,9)
+13 IF '$GET(GMRAERR)
IF (VADRCL1="")
IF (PATNAME'="")
Begin DoDot:1
+14 KILL ^XTMP("GMRACHK",$JOB)
+15 SET LINE=1
+16 SET ^XTMP("GMRACHK",$JOB,LINE)="The following allergy/adverse reaction may need a VA DRUG CLASS added"
+17 SET LINE=LINE+1
+18 SET ^XTMP("GMRACHK",$JOB,LINE)="for the following Patient:"
+19 SET LINE=LINE+1
+20 SET ^XTMP("GMRACHK",$JOB,LINE)=""
+21 SET LINE=LINE+1
+22 SET ^XTMP("GMRACHK",$JOB,LINE)="Patient: "_PATNAME
+23 SET LINE=LINE+1
+24 SET ^XTMP("GMRACHK",$JOB,LINE)="LAST4: "_LAST4
+25 SET LINE=LINE+1
+26 SET ^XTMP("GMRACHK",$JOB,LINE)="Reactant: "_$GET(PATALLER(120.8,GMRAPA_",",.02,"E"))
+27 SET LINE=LINE+1
+28 ;Build a pretty string of reactions
+29 SET REAC=1
+30 SET REACTS=$GET(PATALLER(120.81,REAC_","_GMRAPA_",",.01,"E"))
+31 SET REAC=REAC+1
+32 FOR
if '$DATA(PATALLER(120.81,REAC_","_GMRAPA_",",.01,"E"))
QUIT
Begin DoDot:2
+33 SET REACTS=REACTS_", "_$GET(PATALLER(120.81,REAC_","_GMRAPA_",",.01,"E"))
+34 SET REAC=REAC+1
End DoDot:2
+35 SET ^XTMP("GMRACHK",$JOB,LINE)="Reactions: "_REACTS
+36 SET LINE=LINE+1
+37 SET ^XTMP("GMRACHK",$JOB,LINE)="OBS/HIS: "_$GET(PATALLER(120.8,GMRAPA_",",6,"E"))
+38 SET LINE=LINE+1
+39 SET ^XTMP("GMRACHK",$JOB,LINE)="Location: "_$$GET1^DIQ(405,$$GET1^DIQ(2,DFN,.102,"I"),.06,"E")
+40 SET LINE=LINE+1
+41 SET XMDUZ=DUZ
+42 SET XMTEXT="^XTMP(""GMRACHK"","_$JOB_","
+43 IF $GET(DUZ(2))=""
SET DUZ(2)=+$$STA^XUAF4($$KSP^XUPARAM("INST"))
+44 SET XMSUB="ALLERGY/ADVERSE REACTION WITHOUT VA DRUG CLASS ("
+45 SET XMSUB=XMSUB_$PIECE($$NS^XUAF4(DUZ(2)),U)_")"
+46 SET XMY("G.ADVERSE_ALLERGY_WARNING")=""
+47 DO ^XMD
+48 KILL ^XTMP("GMRACHK",$JOB)
End DoDot:1
+49 QUIT
+50 ;
MEDCHK ; NSR 20070203
+1 NEW GMRAMCHK
+2 WRITE !!,?2,"Checking new allergy against the patient's active medication profile . . . "
+3 DO CHKMEDS^ORWDAL32(.GMRAMCHK,$PIECE(GMRAPA(0),"^"),$PIECE(GMRAPA(0),"^",2))
+4 IF GMRAMCHK'>0
WRITE !!,?2,"No conflicts were discovered.",!
KILL GMRAMCHK
QUIT
+5 IF GMRAMCHK>0
Begin DoDot:1
+6 NEW GMRADA,GMRAYN,GMRAPROV,GMRASEND,GMRASLST,GMRALST,GMRAORD,GMRADUZ,GMRAOUT
+7 WRITE !!,?2,"The following Active Orders contain "_$PIECE(GMRAPA(0),"^",2)_":"
+8 SET GMRADA=""
+9 FOR
SET GMRADA=$ORDER(GMRAMCHK(GMRADA))
if GMRADA=""
QUIT
IF $DATA(GMRAMCHK(GMRADA))
Begin DoDot:2
+10 WRITE !!,$PIECE(GMRAMCHK(GMRADA),"^",3)_" (Order #"_$PIECE(GMRAMCHK(GMRADA),"^")_") An alert will be sent to:"
+11 DO GETPROV^ORWDAL32(.GMRAPROV,$PIECE(GMRAMCHK(GMRADA),"^"),+$GET(DFN))
+12 NEW PRVDA
SET PRVDA=""
+13 FOR
SET PRVDA=$ORDER(GMRAPROV(PRVDA))
if PRVDA=""
QUIT
IF $DATA(GMRAPROV(PRVDA))
Begin DoDot:3
+14 SET GMRASLST($PIECE(GMRAMCHK(GMRADA),"^"),$PIECE(GMRAPROV(PRVDA),";"))=GMRAPROV(PRVDA)
+15 WRITE !?3,$PIECE(GMRAPROV(PRVDA),"^",2)," - ",$PIECE(GMRAPROV(PRVDA),"^",3)
End DoDot:3
+16 KILL GMRAPROV
End DoDot:2
+17 WRITE !!
+18 SET (GMRAOUT,GMRAYN)=0
DO ASK^GMRAUTL("Do you wish to send the alert(s) to additional recipients? ",.GMRAOUT,.GMRAYN)
if GMRAOUT
QUIT
+19 IF GMRAYN
DO ADDSTHR(.GMRALST)
+20 IF $DATA(GMRASLST)
SET GMRAORD=""
FOR
SET GMRAORD=$ORDER(GMRASLST(GMRAORD))
if GMRAORD=""
QUIT
IF $DATA(GMRASLST(GMRAORD))
Begin DoDot:2
+21 KILL GMRAPROV
+22 SET GMRAPROV=""
+23 IF $DATA(GMRALST)
MERGE GMRAPROV=GMRALST
+24 DO SENDALRT^ORWDAL32(.GMRASEND,GMRAORD,.GMRAPROV)
End DoDot:2
+25 KILL GMRASEND,GMRASLST
End DoDot:1
+26 KILL GMRAMCHK
+27 QUIT
+28 ;
ADDSTHR(GMRALST) ; NSR 20070203
+1 KILL GMRALST
+2 NEW DIC,I,GMRAYN,GMRAON,GMRANOTE,GMRAOUT,Y
+3 SET GMRAYN=0
+4 ;NEW ALLERGY ENTERED/ACTIVE MED notification
SET GMRANOTE=88
+5 FOR I=1:1
Begin DoDot:1
+6 SET DIC="^VA(200,"
SET DIC(0)="AEBQ"
+7 SET DIC("A")="Enter Recipient's Name: "
DO ^DIC
+8 IF +Y>0
Begin DoDot:2
+9 SET GMRAON=$PIECE($$ONOFF^ORB3USER(GMRANOTE,+Y,"","",""),U,1)
+10 IF GMRAON="OFF"
WRITE !!," User is unable to receive the notification!",!
QUIT
+11 SET GMRALST($PIECE(Y,"^"))=$PIECE(Y,"^")_";VA(200,"_"^"_$PIECE(Y,"^",2)
KILL DIC,Y
End DoDot:2
+12 SET (GMRAOUT,GMRAYN)=0
DO ASK^GMRAUTL("Add another recipient? ",.GMRAOUT,.GMRAYN)
if GMRAOUT
QUIT
End DoDot:1
if 'GMRAYN
QUIT
+13 QUIT
+14 ;
XQOR ; GMRA EDIT VERIFIED DATA event driver ;P68
+1 NEW X
SET X=+$ORDER(^ORD(101,"B","GMRA EDIT VERIFIED DATA",0))_";ORD(101,"
+2 if 'X
QUIT
if '$GET(GMRAPA)
QUIT
+3 if '$DATA(GMRAPA(0))
SET GMRAPA(0)=$GET(^GMR(120.8,+GMRAPA,0))
+4 IF $DATA(GMRAPA1)
Begin DoDot:1
+5 if $GET(GMRAPA1)>0
SET GMRAPA1(0)=$GET(^GMR(120.85,+GMRAPA1,0))
+6 ; cleanup GMRAPA1 if no selection (carried over from last edit)
+7 IF $GET(GMRAPA1)<0!($PIECE(GMRAPA1(0),U,15)'=GMRAPA)
KILL GMRAPA1
End DoDot:1
+8 if X
DO EN^XQOR
+9 QUIT
