- 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 Feb 18, 2025@23:21:39 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