GMRAPES1 ;HIRMFO/RM,WAA-SELECT PATIENT ALLERGY TO EDIT ;10/1/07 10:42
;;4.0;Adverse Reaction Tracking;**13,14,17,41**;Mar 29, 1996;Build 8
ADAR ; ADD A NEW A/AR FOR THIS PATIENT
S GMRAPA="" F X=0:0 S X=$O(^GMR(120.8,"B",DFN,X)) Q:X'>0 I $S('$D(^GMR(120.8,X,0)):0,$P(^(0),"^",2)=GMRAAR(0):1,1:0),$S('$D(^("ER")):1,1:'+^("ER")) S GMRAPA=X Q
Q:GMRAPA>0
I $D(XRTL) D T0^%ZOSV ; START RT
D NOW^%DTC
S GMRAAR(1)=+$E(%,1,12),DIC="^GMR(120.8,",DIC(0)="LQ",DLAYGO=120.8
S DIC("DR")=".02////"_GMRAAR(0)_";1////^S X=GMRAAR;4////"_GMRAAR(1)_";5////"_DUZ_";15///0;17///U;3.1////"_$S($G(GMRAAR("O"))'="":GMRAAR("O"),1:"O"),X=DFN
K DD,DO D FILE^DICN
K DIC,DLAYGO S GMRAPA=+Y,GMRANEW=Y>0
;S GMRACAUS="RADIOLOGICAL/CONTRAST MEDIA",GMRADRCL=$O(^PS(50.605,"B","DX100",0))_";PS(50.605," ;41 Code not needed
K GMRAING,GMRADRCL ;41 Removed GMRACAUS and added GMRAING
I GMRAPA'>0 D Q ;Entry is not added
. I $D(XRT0) S XRTN=$T(+0) D T1^%ZOSV ; STOP RT IF EXITING HERE
. Q
;
UPDATE ;Updates entry with drug ingredients and/or drug classes - this API added with patch 17
;Start of New code to support Drug Classes
;This code section will auto stuff Ings and VA Drug Classes
;GMRAING() will have all the Ing for the selected reaction
;GMRADRCL() will have all the drug classes for the selected
;reaction.
;If the Reactant is a Drug Ingrediant
I GMRAAR[50.416 S GMRAING(+GMRAAR)="" G STING
;If the Reacant is a Drug Class
I GMRAAR[50.605 S GMRADRCL(+GMRAAR)=""
;If the Reactant is a entry in the GMR ALLERGY file
I GMRAAR[120.82 D
.S Y=0 F S Y=$O(^GMRD(120.82,+GMRAAR,"ING",Y)) Q:Y'>0 I $D(^GMRD(120.82,+GMRAAR,"ING",Y,0)),+^(0)>0 S GMRAING(+^(0))=""
.S Y=0 F S Y=$O(^GMRD(120.82,+GMRAAR,"CLASS",Y)) Q:Y'>0 I $D(^GMRD(120.82,+GMRAAR,"CLASS",Y,0)),+^(0)>0 S GMRADRCL(+^(0))=""
.Q
;41 - Section related to PSDRUG no longer needed
;I GMRAAR["PSDRUG" D
;.N PSODA
;.S PSODA=+GMRAAR K ^TMP("PSO",$J) D ^PSONGR F Y=0:0 S Y=$O(^TMP("PSO",$J,Y)) Q:Y'>0 S GMRAING(Y)=""
;.N GMRAX,GMRAY
;.S GMRAX=$P($G(^PSDRUG(+GMRAAR,"ND")),U,6) S:GMRAX>0 GMRADRCL(GMRAX)="" Q
;.S GMRAX=$P($G(^PSDRUG(+GMRAAR,0)),U,2) Q:GMRAX=""
;.S GMRAY=$O(^PS(50.605,"B",GMRAX,"")) S:GMRAY>0 GMRADRCL(GMRAY)=""
;.Q
I GMRAAR["PSNDF" D
.N PSNDA
.S PSNDA=+GMRAAR K ^TMP("PSN",$J) D ^PSNNGR F Y=0:0 S Y=$O(^TMP("PSN",$J,Y)) Q:Y'>0 S GMRAING(Y)=""
.; all classes for NDF entry returned in GMRADRCL
.N CLASS
.S CLASS=$$CLIST^PSNAPIS(+GMRAAR,.GMRADRCL)
.Q
K ^TMP("PSN",$J),PSOID,PSNID ;41 - Removed K ^TMP("PSO",$J)
STING ;Stuffing Drug Ing & VA Drug Classes into file 120.8
I $D(GMRAING) D
.S DA(1)=+GMRAPA,DIC="^GMR(120.8,"_+GMRAPA_",2,",DLAYGO=120.8,DIC(0)="L",DIC("P")="120.802PA"
.F X=0:0 S X=$O(GMRAING(X)) Q:X'>0 I '$D(^GMR(120.8,GMRAPA,2,"B",X)) K DD,DO,DINUM D FILE^DICN
.K DIC,DLAYGO
.Q
I $D(GMRADRCL) D
.S DA(1)=+GMRAPA,DIC="^GMR(120.8,"_+GMRAPA_",3,",DIC(0)="L",DIC("P")="120.803PA"
.F X=0:0 S X=$O(GMRADRCL(X)) Q:X'>0 I '$D(^GMR(120.8,GMRAPA,3,"B",X)) K DD,DO,DINUM D FILE^DICN
.K DIC
.Q
I $D(XRT0) S XRTN=$T(+0) D T1^%ZOSV ; STOP RT IF EXITING HERE
K GMRADRCL,GMRAING
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRAPES1 3148 printed Sep 23, 2025@19:16:05 Page 2
GMRAPES1 ;HIRMFO/RM,WAA-SELECT PATIENT ALLERGY TO EDIT ;10/1/07 10:42
+1 ;;4.0;Adverse Reaction Tracking;**13,14,17,41**;Mar 29, 1996;Build 8
ADAR ; ADD A NEW A/AR FOR THIS PATIENT
+1 SET GMRAPA=""
FOR X=0:0
SET X=$ORDER(^GMR(120.8,"B",DFN,X))
if X'>0
QUIT
IF $SELECT('$DATA(^GMR(120.8,X,0)):0,$PIECE(^(0),"^",2)=GMRAAR(0):1,1:0)
IF $SELECT('$DATA(^("ER")):1,1:'+^("ER"))
SET GMRAPA=X
QUIT
+2 if GMRAPA>0
QUIT
+3 ; START RT
IF $DATA(XRTL)
DO T0^%ZOSV
+4 DO NOW^%DTC
+5 SET GMRAAR(1)=+$EXTRACT(%,1,12)
SET DIC="^GMR(120.8,"
SET DIC(0)="LQ"
SET DLAYGO=120.8
+6 SET DIC("DR")=".02////"_GMRAAR(0)_";1////^S X=GMRAAR;4////"_GMRAAR(1)_";5////"_DUZ_";15///0;17///U;3.1////"_$SELECT($GET(GMRAAR("O"))'="":GMRAAR("O"),1:"O")
SET X=DFN
+7 KILL DD,DO
DO FILE^DICN
+8 KILL DIC,DLAYGO
SET GMRAPA=+Y
SET GMRANEW=Y>0
+9 ;S GMRACAUS="RADIOLOGICAL/CONTRAST MEDIA",GMRADRCL=$O(^PS(50.605,"B","DX100",0))_";PS(50.605," ;41 Code not needed
+10 ;41 Removed GMRACAUS and added GMRAING
KILL GMRAING,GMRADRCL
+11 ;Entry is not added
IF GMRAPA'>0
Begin DoDot:1
+12 ; STOP RT IF EXITING HERE
IF $DATA(XRT0)
SET XRTN=$TEXT(+0)
DO T1^%ZOSV
+13 QUIT
End DoDot:1
QUIT
+14 ;
UPDATE ;Updates entry with drug ingredients and/or drug classes - this API added with patch 17
+1 ;Start of New code to support Drug Classes
+2 ;This code section will auto stuff Ings and VA Drug Classes
+3 ;GMRAING() will have all the Ing for the selected reaction
+4 ;GMRADRCL() will have all the drug classes for the selected
+5 ;reaction.
+6 ;If the Reactant is a Drug Ingrediant
+7 IF GMRAAR[50.416
SET GMRAING(+GMRAAR)=""
GOTO STING
+8 ;If the Reacant is a Drug Class
+9 IF GMRAAR[50.605
SET GMRADRCL(+GMRAAR)=""
+10 ;If the Reactant is a entry in the GMR ALLERGY file
+11 IF GMRAAR[120.82
Begin DoDot:1
+12 SET Y=0
FOR
SET Y=$ORDER(^GMRD(120.82,+GMRAAR,"ING",Y))
if Y'>0
QUIT
IF $DATA(^GMRD(120.82,+GMRAAR,"ING",Y,0))
IF +^(0)>0
SET GMRAING(+^(0))=""
+13 SET Y=0
FOR
SET Y=$ORDER(^GMRD(120.82,+GMRAAR,"CLASS",Y))
if Y'>0
QUIT
IF $DATA(^GMRD(120.82,+GMRAAR,"CLASS",Y,0))
IF +^(0)>0
SET GMRADRCL(+^(0))=""
+14 QUIT
End DoDot:1
+15 ;41 - Section related to PSDRUG no longer needed
+16 ;I GMRAAR["PSDRUG" D
+17 ;.N PSODA
+18 ;.S PSODA=+GMRAAR K ^TMP("PSO",$J) D ^PSONGR F Y=0:0 S Y=$O(^TMP("PSO",$J,Y)) Q:Y'>0 S GMRAING(Y)=""
+19 ;.N GMRAX,GMRAY
+20 ;.S GMRAX=$P($G(^PSDRUG(+GMRAAR,"ND")),U,6) S:GMRAX>0 GMRADRCL(GMRAX)="" Q
+21 ;.S GMRAX=$P($G(^PSDRUG(+GMRAAR,0)),U,2) Q:GMRAX=""
+22 ;.S GMRAY=$O(^PS(50.605,"B",GMRAX,"")) S:GMRAY>0 GMRADRCL(GMRAY)=""
+23 ;.Q
+24 IF GMRAAR["PSNDF"
Begin DoDot:1
+25 NEW PSNDA
+26 SET PSNDA=+GMRAAR
KILL ^TMP("PSN",$JOB)
DO ^PSNNGR
FOR Y=0:0
SET Y=$ORDER(^TMP("PSN",$JOB,Y))
if Y'>0
QUIT
SET GMRAING(Y)=""
+27 ; all classes for NDF entry returned in GMRADRCL
+28 NEW CLASS
+29 SET CLASS=$$CLIST^PSNAPIS(+GMRAAR,.GMRADRCL)
+30 QUIT
End DoDot:1
+31 ;41 - Removed K ^TMP("PSO",$J)
KILL ^TMP("PSN",$JOB),PSOID,PSNID
STING ;Stuffing Drug Ing & VA Drug Classes into file 120.8
+1 IF $DATA(GMRAING)
Begin DoDot:1
+2 SET DA(1)=+GMRAPA
SET DIC="^GMR(120.8,"_+GMRAPA_",2,"
SET DLAYGO=120.8
SET DIC(0)="L"
SET DIC("P")="120.802PA"
+3 FOR X=0:0
SET X=$ORDER(GMRAING(X))
if X'>0
QUIT
IF '$DATA(^GMR(120.8,GMRAPA,2,"B",X))
KILL DD,DO,DINUM
DO FILE^DICN
+4 KILL DIC,DLAYGO
+5 QUIT
End DoDot:1
+6 IF $DATA(GMRADRCL)
Begin DoDot:1
+7 SET DA(1)=+GMRAPA
SET DIC="^GMR(120.8,"_+GMRAPA_",3,"
SET DIC(0)="L"
SET DIC("P")="120.803PA"
+8 FOR X=0:0
SET X=$ORDER(GMRADRCL(X))
if X'>0
QUIT
IF '$DATA(^GMR(120.8,GMRAPA,3,"B",X))
KILL DD,DO,DINUM
DO FILE^DICN
+9 KILL DIC
+10 QUIT
End DoDot:1
+11 ; STOP RT IF EXITING HERE
IF $DATA(XRT0)
SET XRTN=$TEXT(+0)
DO T1^%ZOSV
+12 KILL GMRADRCL,GMRAING
+13 QUIT
