source: WorldVistAEHR/trunk/r/DIETETICS-FH/FHSELA1.m@ 619

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

initial load of WorldVistAEHR
File size: 6.8 KB
Line 
1FHSELA1 ;Hines OIFO/RTK - Map GMR Allergy file to Food Prefs ;3/07/2007
2 ;;5.5;DIETETICS;**8,12**;Jan 28, 2005;Build 3
3 ;
4 ;10/16/2007 BAY/KAM FH*5.5*12 Remedy Call 210385 Do not allow
5 ; user to change Food Preference name or
6 ; LIKE/DISLIKE field
7 ;
8CREATE ; Check for any missing Allergy-type FP's or one's not renamed in 115.2
9 ; and allow user to create the FP on the fly
10 D ^FHSELA2 S NUM=0,FHQUIT=0
11 W !!!,"The following Allergy Food Preference titles are not on file."
12 W !,"You may use this option to create these Food Preference entries:"
13 D CRLIST I NUM=0 W !,"No Food Preferences need to be mapped." D EXIT Q
14 I FHQUIT=1 D EXIT Q
15 I FHRESP=""!(FHRESP="M") D EXIT Q
16 S FHAFPNM=$P(FHLIST(FHRESP),"^",1)
17 W !,FHAFPNM," "
18 K DIR S DIR("A")="Add to Food Preference file",DIR(0)="Y" D ^DIR
19 I $D(DIRUT) D EXIT Q
20 I Y'=1 D CREATE Q
21 D ADD
22 W !!," ...done. ",FHAFPNM," Food Preference has been added!" H 1
23 D CREATE Q
24 D EXIT Q
25CRLIST ;
26 W !!?5,"MISSING FOOD PREFERENCE LIST"
27 W !?5,"============================"
28 S FHSEL=0,FHK=""
29 F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK=""!(FHQUIT=1)!(FHSEL=1) D
30 .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99)
31 .S FHZ1="ALLERGY - "_$P(FHFPS,";",1)
32 .I $D(^FH(115.2,"B",FHZ1)) Q
33 .S NUM=NUM+1,PAD=$S($L(NUM)=1:" ",1:"") W !,PAD,NUM
34 .W ?8,FHZ1
35 .S FHLIST(NUM)=FHZ1_"^"_FHFPS
36 .I NUM#5=0!($O(^TMP($J,"FHALG",FHK))="") D PG Q
37 .Q
38 I FHQUIT=0,FHSEL=0,NUM#5'=0 D PG Q
39 Q
40ADD ;
41 S FHALGMZ=1
42 S X=FHAFPNM K DIC,DO
43 S (DIC,DIE)="^FH(115.2,",DIC(0)="L" D FILE^DICN
44 ; 10/16/2007 BP/KAM FH*5.5*12 Default DISLIKE and prevent Food Preference name change in the next line
45 S (FHDA,DA)=+Y,DR="26;1////D"
46 D ^DIE K DA,DIE,DR
47 D TRAN^FHSEL1
48 Q
49PG ;
50 S FHRESP="" W ! K DIR
51 S DIR("A")="Select Food Preference or 'M' to see more ('^' to EXIT)"
52 S DIR(0)="F",DIR("B")="M" D ^DIR I $D(DIRUT) S FHQUIT=1 Q
53 S FHRESP=Y
54 I FHRESP?1"M" Q
55 I FHRESP?1.3N,FHRESP>0,FHRESP<(NUM+1) S FHSEL=1 Q
56 W !!,"Select from 1 to ",NUM D PG Q
57 Q
58MAP ; Map allergies by setting pointers in 115.2 to correct entries in 120.82
59 D ^FHSELA2
60 S FHK=""
61 F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D
62 .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99)
63 .S FHZ1="ALLERGY - "_$P(FHFPS,";",1)
64 .I '$D(^FH(115.2,"B",FHZ1)) Q ;not set-up in 115.2, can't map
65 .S FHFPIEN=$O(^FH(115.2,"B",FHZ1,""))
66 .S FHALMP=$P(FHFPS,";",2,99) I FHALMP="" Q ;no allergies to map
67 .S FHZ=0 F S FHZ=FHZ+1 S FHANAM=$P(FHALMP,";",FHZ) Q:FHANAM="" D
68 ..D LOOKUP
69 Q
70LOOKUP ; Look-up the Allergy in 120.82 and set the pointer
71 S FHX=FHANAM
72 F FHVAL=0:0 S FHVAL=$O(^GMRD(120.82,"B",FHX,FHVAL)) Q:FHVAL'>0 D
73 .I $D(^FH(115.2,FHFPIEN,"ALG","B",FHVAL)) Q ;pointer already exists
74 .S Y=FHVAL K DIC,DO S DA(1)=FHFPIEN,DIC="^FH(115.2,"_DA(1)_",""ALG"","
75 .S DIC(0)="L",DIC("P")=$P(^DD(115.2,25,0),U,2),X=+Y
76 .D FILE^DICN
77 Q
78DISPMAP ;
79 W !!,"This option can be used to display the Standard GMR Allergy"
80 W !,"entries and the Food Preferences they map to.",!! K DIR
81 S DIR("A")="Display Map by Allergies or by Food Preferences (A/F): "
82 S DIR(0)="SA^A:Allergies;F:Food Preferences" D ^DIR
83 I $D(DIRUT) D EXIT Q
84 S FHSEL=Y
85 D DEV
86 Q
87DEV ;get device and set up queue
88 W ! K %ZIS,IOP S %ZIS="Q" D ^%ZIS Q:POP
89 I '$D(IO("Q")) U IO D LISTMAP,^%ZISC,EXIT Q
90 S ZTRTN="LISTMAP^FHSELA1",ZTSAVE("FHSEL")=""
91 S ZTDESC="GMR Allergy/Food Preference Map Display" D ^%ZTLOAD
92 D ^%ZISC K %ZIS,IOP
93 D EXIT
94 Q
95LISTMAP ; List Map by Allergies or by Food Preferences
96 I FHSEL="A" D LISTAL Q
97 I FHSEL="F" D LISTFP Q
98 Q
99LISTFP ; List all the Allergy-type Food Pref's and corresponding GMR Allergies
100 D ^FHSELA2
101 S FHK="" W !!,"ALLERGY TYPE FOOD PREFERENCE MAP"
102 W !!,"NFS Food Preference Title",?40,"GMR Standard Allergy(s)"
103 W !,"==================================="
104 W ?40,"==================================="
105 F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D
106 .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99),FHZ1=$P(FHFPS,";",1)
107 .W !,"ALLERGY - ",FHZ1
108 .S FHALMP=$P(FHFPS,";",2,99) I FHALMP="" W ?40,"** NONE **" Q
109 .S FHZ=0,N=0 F S FHZ=FHZ+1,FHANAM=$P(FHALMP,";",FHZ) Q:FHANAM="" D
110 ..W ?40,$S(FHZ>1:",",1:"") S N=N+$L(FHANAM)+1 W:N>40 !?40 S:N>40 N=0 W FHANAM I N=0 S N=N+$L(FHANAM)+1
111 D EXIT Q
112LISTAL ; List all the GMR Allergies and the Food Pref to map to
113 D ^FHSELA2
114 S FHK="" W !!,"GMR STANDARD FOOD ALLERGY MAP"
115 W !!,"GMR Allergy Name",?25,"Corresponding NFS Food Preference"
116 W !,"=======================",?25,"===================================="
117 F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D
118 .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99),FHZ1=$P(FHFPS,";",1)
119 .S FHALMP=$P(FHFPS,";",2,99) I FHALMP="" Q
120 .S FHZ=0,N=0 F S FHZ=FHZ+1,FHANAM=$P(FHALMP,";",FHZ) Q:FHANAM="" D
121 ..S ^TMP($J,"FHAL",FHANAM)="ALLERGY - "_FHZ1
122 S FHANAMZ=""
123 F S FHANAMZ=$O(^TMP($J,"FHAL",FHANAMZ)) Q:FHANAMZ="" D
124 .W !,FHANAMZ,?25,"...maps to: ",^TMP($J,"FHAL",FHANAMZ)
125 D EXIT Q
126MISSING ; List all Food Pref's with no pointers to 120.82
127 D ^FHSELA2
128 S FHK=""
129 F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D
130 .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99),FHZ1=$P(FHFPS,";",1)
131 .I $P(FHFPS,";",2)'="" Q
132 .W !?5,"ALLERGY - ",FHZ1," does not have corresponding 120.82 entries"
133 D EXIT Q
134CHECK ; Check for any missing Allergy-type FP's or one's not renamed in 115.2
135 D ^FHSELA2
136 S FHK="",FLG=0
137 W !,"The following Food Preferences titles were not found in file #115.2:"
138 F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D
139 .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99)
140 .S FHZ1="ALLERGY - "_$P(FHFPS,";",1)
141 .I '$D(^FH(115.2,"B",FHZ1)) W !,FHZ1 S FLG=1
142 I FLG=0 W !,"ALL FOOD PREFERENCES HAVE BEEN RENAMED!"
143 D EXIT Q
144 ;
145UPDATE ;Update Food Preferences for all Patient's based on Allergies
146 D ^FHSELA2 S FHCOUNT=0,FHQT=0
147 W !!,"...Updating Patient Food Preferences based on Food-Type Allergies"
148 W "..." K FHMISS F FHDFN=0:0 S FHDFN=$O(^FHPT(FHDFN)) Q:FHDFN'>0 D
149 .S FHCOUNT=FHCOUNT+1 I FHCOUNT#100=0 W "."
150 .D GETZN^FHOMUTL I FILE'="P" Q
151 .S DFN=IEN D ALG^FHCLN I '$O(^TMP($J,"FHGMRAL","")) Q
152 .F FHGMRN=0:0 S FHGMRN=$O(^TMP($J,"FHGMRAL",FHGMRN)) Q:FHGMRN="" D UPDFP1^FHWGMR
153 I $G(FHPST8)=1 K ^TMP($J,"FHGMRAL"),^TMP($J,"FHMISS"),FHGMRN,FHMSAL,FHMSFP,FHMSPT,FHPST8,FHCOUNT Q
154 D LIST
155 K ^TMP($J,"FHGMRAL"),^TMP($J,"FHMISS"),FHGMRN,FHMSAL,FHMSFP,FHMSPT,FHPST8,FHCOUNT,FHQT
156 Q
157LIST ;
158 I '$D(^TMP($J,"FHMISS")) Q
159 W !!,"The following entries need to be mapped in order to automatically"
160 W !,"update the Patient Food Preferences:",! S FHCOUNT=0,FHQT=0
161 S FHMSFP="" F S FHMSFP=$O(^TMP($J,"FHMISS",FHMSFP)) Q:FHMSFP=""!(FHQT=1) D
162 .W !,"'ALLERGY - ",FHMSFP,"'" S FHCOUNT=FHCOUNT+1
163 .S FHMSPT="" F S FHMSPT=$O(^TMP($J,"FHMISS",FHMSFP,FHMSPT)) Q:FHMSPT="" D
164 ..S FHMSAL=$P($G(^TMP($J,"FHMISS",FHMSFP,FHMSPT)),U,1)
165 ..W !?3,"Patient: ",$E(FHMSPT,1,30),?43,"Allergy: ",FHMSAL
166 ..S FHCOUNT=FHCOUNT+1
167 ..I FHCOUNT>14 S FHCOUNT=0 W ! K DIR S DIR(0)="E" D ^DIR W ! I X="^" S FHQT=1
168 Q
169EXIT ;
170 D MAP
171 K ^TMP($J,"FHALG"),^TMP($J,"FHAL")
172 K FHFPIEN,FHK,FHX,FHZ,FHFPS,FHZ1,FHVAL,N,FHANAM,FHANAMZ
173 K FHQUIT,NUM,FHRESP,FHAFPNM,FHSEL,PAD,FHLIST,FHALGMZ,FHALMP
Note: See TracBrowser for help on using the repository browser.