source: FOIAVistA/trunk/r/DIETETICS-FH/FHWGMR.m@ 761

Last change on this file since 761 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 2.6 KB
Line 
1FHWGMR ; HISC/NCA - Signed Reaction Event Filer ;2/16/96 11:37
2 ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28
3EN1 ; File Entered Signed Reaction
4 Q:+$$VERSION^XPDUTL("GMRA")'=4
5 S FLG=1 D CHK G:'FLG KIL
6 S EVT="M^O^^"_"Allergy - "_ALG D FIL
7 I FHGMRN'="" D UPDFP
8 G KIL
9CAN ; File Cancelled/Entered in Error Allergy
10 S FLG=1 D CHK G:'FLG KIL
11 S EVT="M^O^^"_"Allergy - "_ALG_" Cancelled" D FIL
12 I FHGMRN'="" D CANFP
13 G KIL
14FIL ; File Event
15 D ^FHORX
16 Q
17KIL K %,%H,%I,ADM,ALG,COM,DFN,FHSTR,FHTYP,FHWRD,FLG,FHALGN,FHGMRN,FHFPN,FHFPIEN,X Q
18CHK ; Check Validity of Data Passed
19 I 'GMRAPA!($G(GMRAPA(0))="") G ERR
20 S FHSTR=$G(GMRAPA(0)),DFN=+FHSTR G:'DFN ERR
21 S FHALGN=$P(FHSTR,U,3)
22 S FHGMRN="" I $P(FHALGN,";",2)="GMRD(120.82," S FHGMRN=$P(FHALGN,";",1)
23 S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" G ERR
24 S ALG=$P(FHSTR,"^",2) G:ALG="" ERR
25 G:'$D(^FHPT(FHDFN)) ERR S FHWRD=$G(^DPT(DFN,.1)) ;G:FHWRD="" ERR
26 S ADM="" I FHWRD'="" S ADM=$G(^DPT("CN",FHWRD,DFN)) ;G:ADM<1 ERR
27 G:'$P(FHSTR,"^",12) ERR
28 S FHTYP=$P(FHSTR,"^",20) G:FHTYP'["F" ERR
29 Q
30UPDFP ;Automatically add FP's corresponding to the Allergy
31 D ^FHSELA2
32UPDFP1 I $O(^FH(115.2,"C",FHGMRN,""))="" D MISSFP Q ;No Corr FP for FHGMRN
33 F FHFPN=0:0 S FHFPN=$O(^FH(115.2,"C",FHGMRN,FHFPN)) Q:FHFPN'>0 D ADD
34 Q
35ADD ;Add the FP(s) to the patient record
36 I $O(^FHPT(FHDFN,"P","B",FHFPN,"")) Q ;pt already has the FP
37 I $G(^FH(115.2,FHFPN,"I"))="Y" Q ;don't assign INACTIVE FP's
38 S Y=FHFPN K DIC,DO S DA(1)=FHDFN,DIC="^FHPT("_DA(1)_",""P"","
39 S DIC(0)="L",DIC("P")=$P(^DD(115,10,0),U,2),X=+Y
40 D FILE^DICN I Y=-1 Q
41 K DIE S DA=+Y,DA(1)=FHDFN,DIE="^FHPT("_DA(1)_",""P"","
42 S DR="1////^S X=""BNE""" D ^DIE
43 S COM="Add "_$P($G(^FH(115.2,FHFPN,0)),U,1)_" (BNE) (D)"
44 S EVT="P^O^^"_COM D ^FHORX
45 Q
46MISSFP ;
47 I '$D(^GMRD(120.82,FHGMRN,0)) Q ;bad pointer/entry
48 S FHANAME=$P($G(^GMRD(120.82,FHGMRN,0)),U,1)
49 S FHPTNM=$P($G(^DPT(DFN,0)),U,1)
50 S FHRR="" F S FHRR=$O(^TMP($J,"FHALG",FHRR)) Q:FHRR="" S FHRRNM=$P(^TMP($J,"FHALG",FHRR),";",2,99) D
51 .S FHZ=0 F S FHZ=FHZ+1,FHANMZZ=$P(FHRRNM,";",FHZ) Q:FHANMZZ="" D
52 ..I FHANMZZ=FHANAME S ^TMP($J,"FHMISS",FHRR,FHPTNM)=FHANAME
53 Q
54CANFP ;Automatically cancel FP's corresponding to Allergy Entered in Error
55 I $O(^FH(115.2,"C",FHGMRN,""))="" Q ;No Corr FP for this GMRA Allergy
56 F FHFPN=0:0 S FHFPN=$O(^FH(115.2,"C",FHGMRN,FHFPN)) Q:FHFPN'>0 D REM
57 Q
58REM ;Remove the FP(s) from the patient record
59 I '$O(^FHPT(FHDFN,"P","B",FHFPN,"")) Q ;pt does not have the FP
60 S FHFPIEN=$O(^FHPT(FHDFN,"P","B",FHFPN,""))
61 S DA(1)=FHDFN,DA=FHFPIEN,DIK="^FHPT("_DA(1)_",""P""," D ^DIK
62 S COM="Del "_$P($G(^FH(115.2,FHFPN,0)),U,1)_" (BNE) (D)"
63 S EVT="P^O^^"_COM D ^FHORX
64 Q
65ERR S FLG=0 Q
Note: See TracBrowser for help on using the repository browser.