source: cprs/branches/tmg-cprs/m_files/TMGNDF0C.m@ 1523

Last change on this file since 1523 was 796, checked in by Kevin Toppenberg, 14 years ago

Initial upload

File size: 15.1 KB
RevLine 
[796]1TMGNDF2B ;TMG/kst/FDA Import: Ensure DRUG INGREDIENTS ;03/25/06
2 ;;1.0;TMG-LIB;**1**;11/21/06
3
4 ;" FDA - NATIONAL DRUG FILES COMPILING FUNCTIONS
5 ;" -- FILLING DRUG INGREDIENTS FILE WITH NEW VALUES
6 ;"Kevin Toppenberg MD
7 ;"GNU General Public License (GPL) applies
8 ;"11-21-2006
9
10 ;"=======================================================================
11 ;" API -- Public Functions.
12 ;"=======================================================================
13 ;"Menu -- Provide menu to entry points of main routines
14 ;"=======================================================================
15 ;"CheckIngredients -- To cycle through ingredients and ensure that there is an extry in the
16 ;" DRUG INGREDIENTS file. This has to be an interactive process.
17
18 ;"=======================================================================
19 ;" Private Functions.
20 ;"=======================================================================
21 ;"ShowInstructions
22 ;"LookupRx(ingredient)
23 ;"ShowMatches(Array,max,Label)
24 ;"AddRangeMatch(ScanArray,Label,StartN,EndN)
25 ;"AddMatch(ScanArray,Label,number)
26 ;"ULRangeMatch(ScanArray,StartN,EndN)
27 ;"ULMatch(ScanArray,number)
28 ;"AddOneIngredient(Name)
29 ;"FindIgdMatch(Name,Interactive)
30 ;"DoAddIgd(Name,ParentIEN)
31
32 ;"=======================================================================
33 ;"=======================================================================
34Menu
35 ;"Purpose: Provide menu to entry points of main routines
36
37 new Menu,UsrSlct
38 set Menu(0)="Pick Option for Checking Import Ingredients (0C)"
39 set Menu(1)="Check for NEW ingredients to ADD."_$char(9)_"CheckIngredients"
40 set Menu("P")="Prev Stage"_$char(9)_"Prev"
41 set Menu("N")="Next Stage"_$char(9)_"Next"
42
43MC1 write #
44 set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^")
45 if UsrSlct="^" goto MCDone
46 if UsrSlct=0 set UsrSlct=""
47
48 if UsrSlct="CheckIngredients" do CheckIngredients goto MC1
49 if UsrSlct="Prev" goto Menu^TMGNDF0B ;"quit can occur from there...
50 if UsrSlct="Next" goto Menu^TMGNDF1A ;"quit can occur from there...
51 goto MC1
52
53MCDone
54 quit
55
56
57CheckIngredients
58 ;"Purpose: To cycle through ingredients and ensure that there is an extry in the
59 ;" DRUG INGREDIENTS file. This has to be an interactive process.
60 ;"Input: none
61 ;"Results: none
62 ;"Note: if record in 22706.9 (TMG FDA IMPORT COMPILED) for a given listing
63 ;" has been marked for SKIPPING, or DONE ADDING, then listing will be skipped.
64
65 new Answers,index,ingredient
66 write "Collecting list of INGREDIENTS that need to be added to database...",!
67 new count set count=1
68 new MissingArray
69
70 new Itr,IEN
71 new abort set abort=0
72 set index=$$ItrInit^TMGITR(22706.4,.Itr)
73 do PrepProgress^TMGITR(.Itr,20,0,"index")
74 if index'="" for do quit:(+$$ItrNext^TMGITR(.Itr,.index)'>0)!abort
75 . if $$UserAborted^TMGUSRIF set abort=1 quit
76 . new listingIEN set listingIEN=+$piece($get(^TMG(22706.4,index,0)),"^",1) ;"Not required...
77 . if (listingIEN>0),$piece($get(^TMG(22706.9,listingIEN,1)),"^",4)=1 quit ;"1=SKIP
78 . set ingredient=$piece($get(^TMG(22706.4,index,0)),"^",4)
79 . set ingredient=$extract(ingredient,1,64)
80 . if $get(Answers(ingredient))="" do
81 . . set Y=$$LookupRx(ingredient)
82 . . if +Y'>0 set MissingArray(ingredient)=""
83 . . if +Y>0 set Answers(ingredient)=+Y
84 do ProgressDone^TMGITR(.Itr)
85
86 do HandleMissing(.MissingArray)
87 quit
88
89
90Check1(IEN) ;"finish later
91 ;"Purpose: to scan the ingredients for 1 entry in 22706.9
92 ;"Input: IEN -- IEN in 22706.9
93
94 new ingredient
95 new MissingArray
96
97 new fdaIEN,Y
98 set fdaIEN=+$piece($get(^TMG(22706.9,IEN,0)),"^",1)
99 set ingredient=$piece($get(^TMG(22706.4,fdaIEN,0)),"^",4)
100 set ingredient=$extract(ingredient,1,64)
101 set Y=$$LookupRx(ingredient)
102 if +Y'>0 do
103 . set MissingArray(ingredient)=""
104 . do HandleMissing(.MissingArray)
105 quit
106
107
108HandleMissing(MissingArray)
109 ;"Purpose: To handle and process the array of missing ingredients
110 ;"Input: MissingArray(ingredient)=""
111 ;" MissingArray(ingredient)=""
112 ;"Result: none
113
114 new max set max=$$ListCt^TMGMISC("MissingArray")
115 write !,"Found ",max," missing INGREDIENTS.",!
116
117 new ScanArray,count
118 write "Summarizing list...",!
119 set count=1
120 set ingredient=""
121 new startTime set startTime=$H
122 new abort set abort=0
123 for set ingredient=$order(MissingArray(ingredient)) quit:(ingredient="")!abort do
124 . if count#10=1 do ProgressBar^TMGUSRIF(count,ingredient,1,max,80,startTime)
125 . if ingredient["ALLERGENIC EXTRACT" do
126 . . set Y=$$DoAddIgd(ingredient,0)
127 . else do
128 . . set Y=$$FindIgdMatch(ingredient,0)
129 . . if +Y>0 set ScanArray("MATCHED",count,ingredient)=Y
130 . . else set ScanArray("UNMATCHED",count,ingredient)=""
131 . set count=count+1
132 . set abort=$$UserAborted^TMGUSRIF
133 write !
134
135 new done set done=0
136 new input set input="R"
137 new displaySet set displaySet="MATCHED"
138 for do quit:(done=1)
139 . if input="R" do
140 . . write !!,"Now pick which potential matches are ",displaySet,!
141 . . do ShowMatches(.ScanArray,max,displaySet)
142 . write " (R to refresh, C custom handle, UL to UnLink)",!
143 . write " (# or #-#, ^ to continue, ? for instructions, "
144 . if displaySet="MATCHED" write "U show Unmatched)",!
145 . else write "M show Matched)",!
146 . write "Enter number(s) to ACCEPT (or codes listed above): ?//"
147 . read input,!
148 . if input="" set input="?"
149 . set input=$$UP^XLFSTR(input)
150 . if input="^" set done=1
151 . if (input="U") do
152 . . set displaySet="UNMATCHED"
153 . . set input="R"
154 . if (input="M") do
155 . . set displaySet="MATCHED"
156 . . set input="R"
157 . if (input="A") do
158 . . set displaySet="MATCHED"
159 . . set input="R"
160 . if (input="?") do
161 . . do ShowInstructions
162 . . set input="R"
163 . if +input=input do
164 . . do AddMatch(.ScanArray,displaySet,+input)
165 . . set input="R"
166 . if input["-" do
167 . . new N1,N2
168 . . set N1=$piece(input,"-",1)
169 . . set N2=$piece(input,"-",2)
170 . . do AddRangeMatch(.ScanArray,displaySet,N1,N2)
171 . . set input="R"
172 . if input="C" do
173 . . read "Enter number for Custom Handling: ",input,!
174 . . if +input'=input quit
175 . . set ingredient=$order(ScanArray(displaySet,+input,""))
176 . . set Y=$$AddOneIngredient(ingredient)
177 . . if +Y>0 kill ScanArray(displaySet,+input,ingredient)
178 . . set input="R"
179 . if input="UL" do
180 . . read "Enter number to Unlink (# or #-#): ",input,!
181 . . if +input=input do
182 . . . do ULMatch(.ScanArray,input)
183 . . else if input["-" do
184 . . . new N1,N2
185 . . . set N1=$piece(input,"-",1)
186 . . . set N2=$piece(input,"-",2)
187 . . . do ULRangeMatch(.ScanArray,N1,N2)
188 . . set input="R"
189
190 quit
191
192
193ShowInstructions
194 write !!,"INSTRUCTIONS:",!
195 write "----------------------------------------------------------------------------",!
196 write "Before adding any medicines or drugs into the database, the underlying",!
197 write "INGREDIENTS must be entered. Each drug will have one or more ingredients",!
198 write "that will be linked to these new entries. DRUG INTERACTIONS are based on",!
199 write "ingredients rather than on the name of the drug itself.",!!
200 write "Often, the name supplied is more specific than an entry already in the",!
201 write "database. For example:",!
202 write " CAFFEINE <-- already in database",!
203 write " CAFFEINE CITRATE <-- new import",!
204 write "Clearly, these two compounds are related, and it could be said that:",!
205 write "CAFFEINE is the PRIMARY INGREDIENT in CAFFEINE CITRATE, or as will be",!
206 write "seen shortly, summarized like this:",!
207 write "CAFFEINE <-- CAFFEINE CITRATE",!!
208 do PressToCont^TMGUSRIF
209 write "What follows next will be a listing of all the ingredients to be added into",!
210 write "the database. The computer will have made a best guess at linking the new",!
211 write "entries to parent compounds (i.e. PRIMARY INGREDIENTS). But not all of these",!
212 write "guesses will be correct. IT IS YOUR JOB TO SCREEN THESE.",!!
213 write "If a linkage or matching is correct, just type in its number to ACCEPT it.",!
214 write "If a linkage or matching is NOT correct, it shoud be UNLINKED.",!
215 write "If you feel you can search for a better match, attempt a CUSTOM handling.",!!
216 write "When you are done with accepting or rejecting the computers matches, you should",!
217 write "then process all the UNMATCHED entries, by selecting 'U' to show UNMATCHED.",!
218 write "These very likely may all be accepted at once by entering a range number (e.g.",!
219 write "1-1000).",!!
220 write "When you have completed processing all the matched and unmatched entries, enter",!
221 write "^ to continue.",!
222
223 new temp
224 read "Press <ENTER> to continue.",temp:$get(DTIME,3600),!
225 quit
226
227
228LookupRx(ingredient)
229 ;"Purpose: To look up ingredient in the DRUG INGREDIENTS file
230 ;"Input: ingredient -- the name of the ingredient to lookup
231 ;"Result: -1 if not fount, or 1234^ingredientname format
232
233 new DIC,X,Y
234 set DIC=50.416
235 set DIC(0)="M"
236 new TMGROOT,TMGMSG
237
238 set Y=-1
239 do FIND^DIC(50.416,,".01E","M",ingredient,"*",,,,"TMGROOT","TMGMSG")
240 if +$get(TMGROOT("DILIST",0))>0 do
241 . set Y=$get(TMGROOT("DILIST",2,1),-1)_"^"_$get(TMGROOT("DILIST",1,1))
242 . if +Y'>0 do
243 . . set X=ingredient
244 . . do ^DIC
245
246 quit Y
247
248
249ShowMatches(Array,max,Label)
250 new count,ingredient,value
251 new someShown set someShown=0
252 for count=1:1:max do
253 . set ingredient=$order(ScanArray(Label,count,""))
254 . if ingredient="" quit
255 . set someShown=1
256 . set value=$get(ScanArray(Label,count,ingredient))
257 . write " ",count,". "
258 . if +value>0 write $piece(value,"^",2)
259 . else write "(no parent ingredient)"
260 . write " <--child of-- ",ingredient,!
261 if someShown=0 do
262 . write " --- (List is Empty) ---",!
263
264 quit
265
266AddRangeMatch(ScanArray,Label,StartN,EndN)
267 new num
268 for num=StartN:1:EndN do
269 . do AddMatch(.ScanArray,Label,num)
270 quit
271
272AddMatch(ScanArray,Label,number)
273 new ingredient,Y
274 set ingredient=$order(ScanArray(Label,number,""))
275 set Y=$get(ScanArray(Label,number,ingredient))
276 if (ingredient'="") do
277 . set Y=$$DoAddIgd(ingredient,Y)
278 . kill ScanArray(Label,number,ingredient)
279 quit
280
281ULRangeMatch(ScanArray,StartN,EndN)
282 new num
283 for num=StartN:1:EndN do
284 . do ULMatch(.ScanArray,num)
285 quit
286
287ULMatch(ScanArray,number)
288 new ingredient,Y
289 set ingredient=$order(ScanArray("MATCHED",number,""))
290 if (ingredient'="") set ScanArray("UNMATCHED",number,ingredient)=""
291 kill ScanArray("MATCHED",number)
292 quit
293
294
295AddOneIngredient(Name)
296 ;"Purpose: To add ingredient name to the DRUG INGREDIENTS -- will try to find a parent
297 ;" ingredient interactively
298 ;"Input: Name -- the name of the ingredient to be added.
299 ;"Output: DRUG INGREDIENTS file will have records added.
300 ;"Results: Will return record number (IEN) of newly added record, or 0 if error
301 ;"Note: This function assumes that the ingredient does not already exist in the file.
302
303 new result set result=0
304 if $get(Name)="" goto AOIDone
305
306 new Y
307 set Y=$$FindIgdMatch(Name,1)
308
309 new % set %=1 ;"1=YES
310 if +Y'>0 do
311 . write "A parent primary ingredient was not found for ",!
312 . write " ",Name," <-- UNMATCHED COMPOUND (Add Now)",!
313 . write "Add Now? "
314 . do YN^DICN ;"returns result in %
315 . write !
316
317 if %=1 do
318 . set result=$$DoAddIgd(Name,Y)
319
320AOIDone
321 quit result
322
323
324FindIgdMatch(Name,Interactive)
325 ;"Purpose: To find a match for Name from DRUG INGREDIENTS
326 ;"Input: Name -- the name of the ingredient to be added.
327 ;" Interactive -- OPTIONAL, default=1
328 ;" if 1 then user is asked question,
329 ;" if 0 then best guess is returned.
330 ;"Results: -1 if not found
331 ;" or 1234^Name
332
333 if $get(Name)="" goto FMDone
334
335 set Interactive=$get(Interactive,1)
336
337 if Interactive do
338 . write "------------------------------------------",!
339 . write "Looking for a parent, PRIMARY INGREDIENT for: ",!
340 . write " ",Name," <-- UNMATCHED COMPOUND",!
341
342 new DIC,X,Y,%
343 set DIC=50.416
344 set DIC(0)="M"
345
346 new parent set parent=$$Substitute^TMGSTUTL(Name,", "," ")
347 set parent=$translate(parent,","," ")
348 for do quit:(+Y>0)!(parent="")
349 . new temp
350 . set temp=$$ParseLast^TMGMISC(parent,.parent," ") ;"cut last word off from drug name
351 . set X=$$Trim^TMGSTUTL(parent)
352 . do ^DIC
353 . if Interactive'=1 quit
354 . if +Y>0 do
355 . . ;"At this point, we either have possible match (+Y>0), or no match (parent="")
356 . . write " '"_$piece(Y,"^",2)_"' <-- ?? MATCH ??",!
357 . . write "Use this as the PRIMARY INGREDIENT? "
358 . . set %=1 ;"1=YES
359 . . do YN^DICN ;"returns result in %
360 . . write !
361 . . if %'=1 set Y=0
362 . else do
363 . . if X'="" write " ",X," <-- (not found).",!
364
365 if (+Y'>0)&(Interactive) do
366 . write " No match found. Let's try a generic lookup..."
367 . set DIC(0)="AEQM"
368 . set DIC("A")=" LOOKUP: Enter PRIMARY INGREDIENT (or ^ to continue) ^// "
369 . do ^DIC
370 . write !
371
372FMDone
373 quit Y
374
375
376DoAddIgd(Name,ParentIEN)
377 ;"Purpose: to do the actual addition to the DRUG INGREDIENTS file
378 ;"Input: Name -- the string of the drug name
379 ;" ParentIEN -- a value as returned from DIC (i.e. 1234^Name)
380 ;"Results: IEN of added value, or 0 if not added.
381
382 new result set result=0
383 new TMGFDA,TMGIEN,TMGMSG
384 new PrimIngred set PrimIngred=$get(ParentIEN)
385 set TMGFDA(50.416,"+1,",.01)=$extract(Name,1,64)
386 if +PrimIngred>0 set TMGFDA(50.416,"+1,",2)=$piece(PrimIngred,"^",1)
387 new temp set temp=$get(DUZ(0))
388 set DUZ(0)="^" ;"needed for file permission
389 new tempLaygo merge tempLaygo=^DD(50.416,.01,"LAYGO")
390 kill ^DD(50.416,.01,"LAYGO") ;"temporarily remove lock-down
391 do UPDATE^DIE("","TMGFDA","TMGIEN","TMGMSG")
392 set DUZ(0)=temp
393 merge ^DD(50.416,.01,"LAYGO")=tempLaygo
394 if $data(TMGMSG)&(+$get(Quiet)=0) do
395 . new PriorErrorFound
396 . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound)
397 set result=$get(TMGIEN(1))
398
399 quit result
400
Note: See TracBrowser for help on using the repository browser.