FHWGMR ; HISC/NCA - Signed Reaction Event Filer ;2/16/96 11:37
;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28
EN1 ; File Entered Signed Reaction
Q:+$$VERSION^XPDUTL("GMRA")'=4
S FLG=1 D CHK G:'FLG KIL
S EVT="M^O^^"_"Allergy - "_ALG D FIL
I FHGMRN'="" D UPDFP
G KIL
CAN ; File Cancelled/Entered in Error Allergy
S FLG=1 D CHK G:'FLG KIL
S EVT="M^O^^"_"Allergy - "_ALG_" Cancelled" D FIL
I FHGMRN'="" D CANFP
G KIL
FIL ; File Event
D ^FHORX
Q
KIL K %,%H,%I,ADM,ALG,COM,DFN,FHSTR,FHTYP,FHWRD,FLG,FHALGN,FHGMRN,FHFPN,FHFPIEN,X Q
CHK ; Check Validity of Data Passed
I 'GMRAPA!($G(GMRAPA(0))="") G ERR
S FHSTR=$G(GMRAPA(0)),DFN=+FHSTR G:'DFN ERR
S FHALGN=$P(FHSTR,U,3)
S FHGMRN="" I $P(FHALGN,";",2)="GMRD(120.82," S FHGMRN=$P(FHALGN,";",1)
S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" G ERR
S ALG=$P(FHSTR,"^",2) G:ALG="" ERR
G:'$D(^FHPT(FHDFN)) ERR S FHWRD=$G(^DPT(DFN,.1)) ;G:FHWRD="" ERR
S ADM="" I FHWRD'="" S ADM=$G(^DPT("CN",FHWRD,DFN)) ;G:ADM<1 ERR
G:'$P(FHSTR,"^",12) ERR
S FHTYP=$P(FHSTR,"^",20) G:FHTYP'["F" ERR
Q
UPDFP ;Automatically add FP's corresponding to the Allergy
D ^FHSELA2
UPDFP1 I $O(^FH(115.2,"C",FHGMRN,""))="" D MISSFP Q ;No Corr FP for FHGMRN
F FHFPN=0:0 S FHFPN=$O(^FH(115.2,"C",FHGMRN,FHFPN)) Q:FHFPN'>0 D ADD
Q
ADD ;Add the FP(s) to the patient record
I $O(^FHPT(FHDFN,"P","B",FHFPN,"")) Q ;pt already has the FP
I $G(^FH(115.2,FHFPN,"I"))="Y" Q ;don't assign INACTIVE FP's
S Y=FHFPN K DIC,DO S DA(1)=FHDFN,DIC="^FHPT("_DA(1)_",""P"","
S DIC(0)="L",DIC("P")=$P(^DD(115,10,0),U,2),X=+Y
D FILE^DICN I Y=-1 Q
K DIE S DA=+Y,DA(1)=FHDFN,DIE="^FHPT("_DA(1)_",""P"","
S DR="1////^S X=""BNE""" D ^DIE
S COM="Add "_$P($G(^FH(115.2,FHFPN,0)),U,1)_" (BNE) (D)"
S EVT="P^O^^"_COM D ^FHORX
Q
MISSFP ;
I '$D(^GMRD(120.82,FHGMRN,0)) Q ;bad pointer/entry
S FHANAME=$P($G(^GMRD(120.82,FHGMRN,0)),U,1)
S FHPTNM=$P($G(^DPT(DFN,0)),U,1)
S FHRR="" F S FHRR=$O(^TMP($J,"FHALG",FHRR)) Q:FHRR="" S FHRRNM=$P(^TMP($J,"FHALG",FHRR),";",2,99) D
.S FHZ=0 F S FHZ=FHZ+1,FHANMZZ=$P(FHRRNM,";",FHZ) Q:FHANMZZ="" D
..I FHANMZZ=FHANAME S ^TMP($J,"FHMISS",FHRR,FHPTNM)=FHANAME
Q
CANFP ;Automatically cancel FP's corresponding to Allergy Entered in Error
I $O(^FH(115.2,"C",FHGMRN,""))="" Q ;No Corr FP for this GMRA Allergy
F FHFPN=0:0 S FHFPN=$O(^FH(115.2,"C",FHGMRN,FHFPN)) Q:FHFPN'>0 D REM
Q
REM ;Remove the FP(s) from the patient record
I '$O(^FHPT(FHDFN,"P","B",FHFPN,"")) Q ;pt does not have the FP
S FHFPIEN=$O(^FHPT(FHDFN,"P","B",FHFPN,""))
S DA(1)=FHDFN,DA=FHFPIEN,DIK="^FHPT("_DA(1)_",""P""," D ^DIK
S COM="Del "_$P($G(^FH(115.2,FHFPN,0)),U,1)_" (BNE) (D)"
S EVT="P^O^^"_COM D ^FHORX
Q
ERR S FLG=0 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHWGMR 2726 printed Dec 13, 2024@01:55:17 Page 2
FHWGMR ; HISC/NCA - Signed Reaction Event Filer ;2/16/96 11:37
+1 ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28
EN1 ; File Entered Signed Reaction
+1 if +$$VERSION^XPDUTL("GMRA")'=4
QUIT
+2 SET FLG=1
DO CHK
if 'FLG
GOTO KIL
+3 SET EVT="M^O^^"_"Allergy - "_ALG
DO FIL
+4 IF FHGMRN'=""
DO UPDFP
+5 GOTO KIL
CAN ; File Cancelled/Entered in Error Allergy
+1 SET FLG=1
DO CHK
if 'FLG
GOTO KIL
+2 SET EVT="M^O^^"_"Allergy - "_ALG_" Cancelled"
DO FIL
+3 IF FHGMRN'=""
DO CANFP
+4 GOTO KIL
FIL ; File Event
+1 DO ^FHORX
+2 QUIT
KIL KILL %,%H,%I,ADM,ALG,COM,DFN,FHSTR,FHTYP,FHWRD,FLG,FHALGN,FHGMRN,FHFPN,FHFPIEN,X
QUIT
CHK ; Check Validity of Data Passed
+1 IF 'GMRAPA!($GET(GMRAPA(0))="")
GOTO ERR
+2 SET FHSTR=$GET(GMRAPA(0))
SET DFN=+FHSTR
if 'DFN
GOTO ERR
+3 SET FHALGN=$PIECE(FHSTR,U,3)
+4 SET FHGMRN=""
IF $PIECE(FHALGN,";",2)="GMRD(120.82,"
SET FHGMRN=$PIECE(FHALGN,";",1)
+5 SET FHZ115="P"_DFN
DO CHECK^FHOMDPA
IF FHDFN=""
GOTO ERR
+6 SET ALG=$PIECE(FHSTR,"^",2)
if ALG=""
GOTO ERR
+7 ;G:FHWRD="" ERR
if '$DATA(^FHPT(FHDFN))
GOTO ERR
SET FHWRD=$GET(^DPT(DFN,.1))
+8 ;G:ADM<1 ERR
SET ADM=""
IF FHWRD'=""
SET ADM=$GET(^DPT("CN",FHWRD,DFN))
+9 if '$PIECE(FHSTR,"^",12)
GOTO ERR
+10 SET FHTYP=$PIECE(FHSTR,"^",20)
if FHTYP'["F"
GOTO ERR
+11 QUIT
UPDFP ;Automatically add FP's corresponding to the Allergy
+1 DO ^FHSELA2
UPDFP1 ;No Corr FP for FHGMRN
IF $ORDER(^FH(115.2,"C",FHGMRN,""))=""
DO MISSFP
QUIT
+1 FOR FHFPN=0:0
SET FHFPN=$ORDER(^FH(115.2,"C",FHGMRN,FHFPN))
if FHFPN'>0
QUIT
DO ADD
+2 QUIT
ADD ;Add the FP(s) to the patient record
+1 ;pt already has the FP
IF $ORDER(^FHPT(FHDFN,"P","B",FHFPN,""))
QUIT
+2 ;don't assign INACTIVE FP's
IF $GET(^FH(115.2,FHFPN,"I"))="Y"
QUIT
+3 SET Y=FHFPN
KILL DIC,DO
SET DA(1)=FHDFN
SET DIC="^FHPT("_DA(1)_",""P"","
+4 SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(115,10,0),U,2)
SET X=+Y
+5 DO FILE^DICN
IF Y=-1
QUIT
+6 KILL DIE
SET DA=+Y
SET DA(1)=FHDFN
SET DIE="^FHPT("_DA(1)_",""P"","
+7 SET DR="1////^S X=""BNE"""
DO ^DIE
+8 SET COM="Add "_$PIECE($GET(^FH(115.2,FHFPN,0)),U,1)_" (BNE) (D)"
+9 SET EVT="P^O^^"_COM
DO ^FHORX
+10 QUIT
MISSFP ;
+1 ;bad pointer/entry
IF '$DATA(^GMRD(120.82,FHGMRN,0))
QUIT
+2 SET FHANAME=$PIECE($GET(^GMRD(120.82,FHGMRN,0)),U,1)
+3 SET FHPTNM=$PIECE($GET(^DPT(DFN,0)),U,1)
+4 SET FHRR=""
FOR
SET FHRR=$ORDER(^TMP($JOB,"FHALG",FHRR))
if FHRR=""
QUIT
SET FHRRNM=$PIECE(^TMP($JOB,"FHALG",FHRR),";",2,99)
Begin DoDot:1
+5 SET FHZ=0
FOR
SET FHZ=FHZ+1
SET FHANMZZ=$PIECE(FHRRNM,";",FHZ)
if FHANMZZ=""
QUIT
Begin DoDot:2
+6 IF FHANMZZ=FHANAME
SET ^TMP($JOB,"FHMISS",FHRR,FHPTNM)=FHANAME
End DoDot:2
End DoDot:1
+7 QUIT
CANFP ;Automatically cancel FP's corresponding to Allergy Entered in Error
+1 ;No Corr FP for this GMRA Allergy
IF $ORDER(^FH(115.2,"C",FHGMRN,""))=""
QUIT
+2 FOR FHFPN=0:0
SET FHFPN=$ORDER(^FH(115.2,"C",FHGMRN,FHFPN))
if FHFPN'>0
QUIT
DO REM
+3 QUIT
REM ;Remove the FP(s) from the patient record
+1 ;pt does not have the FP
IF '$ORDER(^FHPT(FHDFN,"P","B",FHFPN,""))
QUIT
+2 SET FHFPIEN=$ORDER(^FHPT(FHDFN,"P","B",FHFPN,""))
+3 SET DA(1)=FHDFN
SET DA=FHFPIEN
SET DIK="^FHPT("_DA(1)_",""P"","
DO ^DIK
+4 SET COM="Del "_$PIECE($GET(^FH(115.2,FHFPN,0)),U,1)_" (BNE) (D)"
+5 SET EVT="P^O^^"_COM
DO ^FHORX
+6 QUIT
ERR SET FLG=0
QUIT
