source: cprs/branches/tmg-cprs/m_files/TMGABV.m@ 840

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

Initial upload

File size: 15.0 KB
RevLine 
[796]1TMGABV ;TMG/kst/Abbreviation code ; 03/25/06
2 ;;1.0;TMG-LIB;**1**;12/23/05
3
4 ;" ABBREVIATION code
5
6 ;"Kevin Toppenberg MD
7 ;"GNU General Public License (GPL) applies
8 ;"12-23-2006
9
10 ;"=======================================================================
11 ;" API -- Public Functions.
12 ;"=======================================================================
13 ;"$$Read(OrigName,LenCat,DefValue)
14 ;"Write(OrigName,ShortName,LenCat,AskConfirm)
15 ;"Del(OrigName,LenCat,AskConfirm)
16 ;"GetAbvr(Name,AskUser,UseSR)
17 ;"Fix(ShortName) -- provides a way to fix erroneous abbreviations.
18 ;"ShowDiff -- scan and show changes. This is not very useful (a testing function)
19 ;"ScanDel(Text) -- scan for text and allow deletions.
20
21 ;"=======================================================================
22 ;" Private Functions.
23 ;"=======================================================================
24 ;"CheckDel(longName,DiffArray,DiffStr,lenCat)
25 ;"Fix1(ShortName) -- provide a way to fix erroneous abbreviations.
26 ;"ShowLinks(ShortName,LenCat,array) -- show a chain of abbreviations.
27 ;"GetDiff(longName,LenCat) -- for longName, return what changes for it's abbreviation
28 ;"GetDiffStr(longName,shortName) -- given longName and it's shortname abbreviation, return what changes
29 ;"ScanAbvs(xstr,showProgress) -- scan abbreviations and execute code
30
31 ;"=======================================================================
32 ;"=======================================================================
33
34Read(OrigName,LenCat,DefValue)
35 ;"Purpose: To read from the ABBREV array and return an abbreviation
36 ;"Input: OrigName -- the name to look up
37 ;" LenCat -- OPTIONAL. If specified, then results returned from that category
38 ;" if LenCat="ALL" then all categories are scanned until some value found.
39 ;" DefValue -- OPTIONAL. If specified, a default value if not found
40 ;"Results: Returns the found abbreviation, or "" if not found
41
42 set DefValue=$get(DefValue)
43 new result set result=DefValue
44 if $get(OrigName)="" goto RdDone
45 if $get(LenCat)'="" do
46 . if LenCat="ALL" do
47 . . set result=$get(^TMG("ABBREV",OrigName),DefValue) quit:(result'="")
48 . . set LenCat=""
49 . . for set LenCat=$order(^TMG("ABBREV",LenCat),-1) quit:(+LenCat'=LenCat)!(result'="") do
50 . . . set result=$get(^TMG("ABBREV",LenCat,OrigName),DefValue)
51 . else do
52 . . set result=$get(^TMG("ABBREV",LenCat,OrigName),DefValue)
53 else do
54 . set result=$get(^TMG("ABBREV",OrigName),DefValue)
55RdDone
56 if result'="" do
57 . if ($get(TMGDBABV)=1)&(result'=OrigName) do
58 . . write OrigName,"-->",!,result," OK"
59 . . new % set %=1 do YN^DICN write !
60 . . if %=1 quit
61 . . set result=""
62 . . if %=-1 quit
63 . . if %=2 do Del(OrigNameName,.LenCat,1)
64
65 quit result
66
67
68Write(OrigName,ShortName,LenCat,AskConfirm)
69 ;"Purpose: To provide a unified writer for ABBREV array
70 ;"Input: OrigName -- the longer name that the abbreviation will stand for
71 ;" ShortName -- the shorter abbreviation of OrigName
72 ;" LenCat -- OPTIONAL -- If supplied, then abbreviation will be stored in this category
73 ;" AskConfirm -- OPTIONAL -- if 1 then user asked to confirm save.
74 ;"results: none
75 ;"Note: Assigning a NULL ShortName is not currently allowed.
76
77 if $get(OrigName)="" goto WtDone
78 if $get(ShortName)="" goto WtDone
79 set AskConfirm=$get(AskConfirm,0)
80 if $$Read(OrigName,.LenCat)=ShortName goto WtDone ;"Skip write if already there
81 new % set %=1
82 if AskConfirm=1 do
83W1 . write "[",OrigName,"] --> [",ShortName,"]",!
84 . write "Save for future use"
85 . do YN^DICN write !
86 if %'=1 goto WtDone
87 if $get(LenCat)'="" do
88 . set ^TMG("ABBREV",LenCat,OrigName)=ShortName
89 . set ^TMG("ABBREV",LenCat,"XREF",ShortName)=OrigName
90 else do
91 . set ^TMG("ABBREV",OrigName)=ShortName
92 . set ^TMG("ABBREV","XREF",ShortName)=OrigName
93WtDone quit
94
95
96Del(OrigName,LenCat,AskConfirm)
97 ;"Purpose: To delete a value from the ABBREV array
98 ;"Input: OrigName -- the name to look up
99 ;" LenCat -- OPTIONAL. If specified, then category to delete from
100 ;" AskConfirm -- OPTIONAL -- if 1 then user asked to confirm save.
101 ;"Results: none
102
103 if $get(OrigName)="" goto DelDone
104 set AskConfirm=$get(AskConfirm,0)
105 new CurValue
106 if $get(LenCat)'="" set CurValue=$get(^TMG("ABBREV",LenCat,OrigName))
107 else set CurValue=$get(^TMG("ABBREV",OrigName))
108 new % set %=1
109 if AskConfirm=1 do
110 . write "[",OrigName,"] -->",!,"[",CurValue,"]",!
111 . write "OK to DELETE" do YN^DICN write !
112 if %'=1 goto DelDone
113 if $get(LenCat)'="" do
114 . kill ^TMG("ABBREV",LenCat,OrigName)
115 . kill ^TMG("ABBREV",LenCat,"XREF",CurValue)
116 else do
117 . kill ^TMG("ABBREV",OrigName)
118 . kill ^TMG("ABBREV","XREF",CurValue)
119 if AskConfirm'=1 goto DelDone
120
121 ;"Now see if this same problem needs to be fixed in other abbreviations.
122 new tempS set tempS=$$GetDiffStr(OrigName,CurValue)
123 new DiffArray,count set count=1
124 write "That association had the following difference(s):",!
125 for quit:(tempS'["^") do
126 . new OneDiff set OneDiff=$piece(tempS,"^",1)
127 . set DiffArray(count)=OneDiff,count=count+1
128 . write " ",$piece(OneDiff,">",1)," --> ",$piece(OneDiff,">",2),!
129 . set tempS=tempS=$piece(tempS,"^",3,999)
130 set DiffArray("MAXNODE")=$$ListCt^TMGMISC("DiffArray")
131 set %=1
132 write "Delete all other abbreviations that have these difference(s)"
133 do YN^DICN write !
134 if %'=1 goto DelDone
135Del1 new xstr set xstr="do CheckDel(longName,.DiffArray,DiffStr,lenCat)"
136 do ScanAbvs(xstr,1)
137
138DelDone quit
139
140
141CheckDel(longName,DiffArray,DiffStr,lenCat)
142 ;"Purpose: this is a callback function for a ScanAbvs run
143 ;" it will be called for each abbreviation
144 ;"Input: DiffArray -- PASS BY REFERENCE. Format:
145 ;" DiffArray(1)="Long1>short1"
146 ;" DiffArray(2)="Long2>short2"
147 ;" DiffArray(3)="Long3>short3"
148 ;" DiffArray("MAXNODE")=3
149 ;" DiffStr -- a difference string, as created by $$GetDiff
150 ;" lenCat -- the category that eval is from, or "" if none
151
152 new shouldDel set shouldDel=1
153 new i for i=1:1:+$get(DiffArray("MAXNODE")) do quit:(shouldDel=0)
154 . set shouldDel=DiffStr[DiffArray(i)
155
156 if shouldDel=1 do Del(longName,lenCat,0)
157 quit
158
159
160
161GetAbvr(Name,AskUser,UseSR)
162 ;"Purpose: To get an abbreviation for one word
163 ;"Input: Name -- name to shorten
164 ;" AskUser -- if 1, then user will be asked to supply abbreviations
165 ;" UseSR -- OPTIONAL, default=0. If 0, then ^DIR won't be used
166 ;"Note: The name returned here may be longer than desired, no testing of length done.
167 ;"Results: Returns abreviated name, or original name if not found, or "" if deleted
168
169 set UseSR=$get(UseSR,0)
170
171 new result,Y
172 set result=$get(Name)
173 if Name="" goto GADone
174 if $get(AskUser)=1 do
175 . write "Enter a shorter form of '"_Name_"' (^ to delete)",!
176 . if UseSR do
177 . . new DIR
178 . . set DIR(0)="F"
179 . . set DIR("A")="New Name"
180 . . set DIR("B")=result
181 . . do ^DIR write !
182 . else do
183 . . read "New Name: ",Y:($get(DTIME,3600)),!
184 . if Y="^" do quit
185 . . write "Delete word from name"
186 . . new % set %=1 do YN^DICN write !
187 . . if %=1 set result=""
188 . if Y'=result do
189 . . do Write(Name,Y,,1) ;"1=> confirm save
190 . . set result=Y
191 else do
192 . set result=$$Read(Name,,Name)
193 . if result="^" set result="" do Del(Name)
194 . if result="" quit
195 . if ($get(TMGDBABV)=1)&(result'=Name) do
196 . . write Name,"-->",!,result,!," OK"
197 . . new % set %=1 do YN^DICN write !
198 . . if %=1 quit
199 . . if %=-1 set result="" quit
200 . . if %=2 do
201 . . . write "Delete abbreviation" do YN^DICN write !
202 . . . if %=1 do Del(Name) set result=""
203
204GADone
205 quit result
206
207
208
209Fix(ShortName,Context)
210 ;"Purpose: To provide a way to fix erroneous abbreviations.
211 ;"Input: ShortName -- the abbreviation to fix.
212 ;" Context -- OPTIONAL. The sentence ShortName is found in.
213 ;"Result: Returns new name after fixing mislinked abbreviations,
214 ;" or 0 for requested retry
215
216 new Menu,Option
217 set Context=$get(Context)
218 new result set result=""
219
220FL1 if Context="" goto FL2
221
222 set Menu(0)="Pick Which to Fix"
223 set Menu(1)=ShortName
224 set Menu(2)=Context
225 write #
226 set Option=$$Menu^TMGUSRIF(.Menu,"^")
227 if Option="^" goto FixDone
228
229FL2 if (Option=1)!(Context="") do goto:(Context'="") FL1 goto FixDone
230 . set ShortName=$$Fix1(ShortName)
231 . if ShortName'="" set result=ShortName
232 if (Option=2) do goto FixDone
233 . new temp set temp=$$Fix1(Context)
234 . set result=0
235 if (Option="^") goto FixDone
236 goto FL1
237
238FixDone
239 quit result
240
241
242Fix1(ShortName)
243 ;"Purpose: To provide a way to fix erroneous abbreviations.
244 ;"Input: ShortName -- the abbreviation to fix.
245 ;"Result: Returns new name after fixing mislinked abbreviations.
246
247 new array,Option
248 new Name,LenCat
249 new result set result=""
250 new max
251Fix1Loop
252 kill array
253 do ShowLinks(ShortName,,.array)
254 ;"Return Format
255 ;" array(x)=ShortName <-- LongerName[TAB]LongerName^LenCat
256
257 set max=+$get(array("MAX"))
258 kill array("MAX")
259 set array(0)="Pick item to DELETE"
260 write #
261 set Option=$$Menu^TMGUSRIF(.array,"^")
262 if Option="^" goto Fix1Done
263 set Name=$piece(Option,"^",1)
264 set LenCat=$piece(Option,"^",2)
265 do Del(Name,LenCat,1)
266 goto Fix1Loop
267
268Fix1Done
269 new s set s=$get(array(max))
270 set s=$piece(s,$char(9),2)
271 set s=$piece(s,"^",1)
272 set result=s
273 quit result
274
275
276
277ShowLinks(ShortName,LenCat,array)
278 ;"Purpose: To show a chain of abbreviations.
279 ;"Input: ShortName -- the abbreviation to check.
280 ;" LenCat -- the category to look in
281 ;" Array -- PASS BY REFERENCE. an OUT PARAMETER. Format
282 ;" array("MAX")=maxCount (e.g. 2)
283 ;" array(1)=ShortName <-- LongerName[TAB]LongerName^LenCat
284 ;" array(2)=ShortName <-- LongerName[TAB]LongerName^LenCat
285
286 new i set i=""
287 new max set max=$get(array("MAX"),0)
288 new value set value=""
289 if $get(LenCat)="" do
290 . for set i=$order(^TMG("ABBREV",i)) quit:(+i'>0) do
291 . . do ShowLinks(ShortName,i,.array)
292 . set value=$get(^TMG("ABBREV","XREF",ShortName))
293 else do
294 . set value=$get(^TMG("ABBREV",LenCat,"XREF",ShortName))
295 if value'="" do
296 . set max=max+1
297 . write max,". ",ShortName," <-- ",value,!
298 . set array(max)=ShortName_" <-- "_value_$char(9)_value_"^"_$get(LenCat)
299 . set array("MAX")=max
300 . do ShowLinks(value,.LenCat,.array)
301
302 quit
303
304GetDiff(longName,LenCat)
305 ;"Purpose: for a given longName, return what changes for it's abbreviation
306 ;"Input: longName -- the original name to search for
307 ;" LenCat -- OPTIONAL. Default is "ALL"
308 ;"Results: returns difference between longName and its abbreviation, or "" if none.
309 ;"Results: DiffLong1>DiffShort1^pos1>pos2^DiffLong2>DiffShort2^pos1>pos2^...
310
311 new result set result=""
312 set LenCat=$get(LenCat,"ALL")
313 new shortName set shortName=$$Read(longName,LenCat)
314 if shortName'="" set result=$$GetDiffStr(longName,shortName)
315 quit result
316
317
318GetDiffStr(longName,shortName)
319 ;"Purpose: for a given longName and it's shortname abbreviation,
320 ;" return what changes for it's abbreviation
321 ;"Results: returns difference between longName and shortName, or "" if none.
322 ;"Results: DiffLong1>DiffShort1^pos1>pos2^DiffLong2>DiffShort2^pos1>pos2^...
323
324 new DiffStr set DiffStr=""
325 ;"if $get(shortName)="" goto GDSDone
326 new longWords,shortWords
327 new DivCh set DivCh=" "
328 if $length(longName,"/")>3 set DivCh="/"
329 do CleaveToArray^TMGSTUTL(longName,DivCh,.longWords)
330 do CleaveToArray^TMGSTUTL(shortName,DivCh,.shortWords)
331 new temp,i
332 set temp=$$DiffWords^TMGSTUTL(.longWords,.shortWords)
333 for do quit:(temp="")
334 . new origS,destNum
335 . set origS=$piece(temp,"^",1)
336 . set temp=$piece(temp,"^",3,999)
337 . if DiffStr'="" set DiffStr=DiffStr_"^"
338 . set DiffStr=DiffStr_origS
339GDSDone quit DiffStr
340
341
342ScanAbvs(xstr,showProgress)
343 ;"Purpose: scan abbreviations and execute code
344 ;"Input: xstr -- OPTIONAL. m code to execute for each entry.´
345 ;" showProgress -- OPTIONAL. if 1, progress bar is shown.
346 ;"Note: The following variables will be defined, for use in xstr:
347 ;" longName,shortName,DiffStr,lenCat
348
349 new longName,shortName,lenCat,DiffStr
350
351 set longName="",lenCat=""
352
353 new Itr
354 ;"for set longName=$order(^TMG("ABBREV",longName),-1) quit:(+longName>0) do
355 set longName=$$ItrAInit^TMGITR($name(^TMG("ABBREV")),.Itr,-1)
356 if $get(showProgress)=1 do PrepProgress^TMGITR(.Itr,20,1,"longName")
357 if longName'="" for do quit:(+$$ItrANext^TMGITR(.Itr,.longName,-1)>0)!(longName="")
358 . new shortName
359 . set shortName=$get(^TMG("ABBREV",longName))
360 . set DiffStr=$$GetDiffStr(longName,shortName)
361 . if xstr'="" xecute xstr
362
363 set lenCat=0
364 for set lenCat=$order(^TMG("ABBREV",lenCat)) quit:(+lenCat'=lenCat) do
365 . if $get(showProgress)=1 write !
366 . ;"set longName=""
367 . ;"for set longName=$order(^TMG("ABBREV",lenCat,longName),-1) quit:(+longName>0)!(longName="") do
368 . set longName=$$ItrAInit^TMGITR($name(^TMG("ABBREV",lenCat)),.Itr,-1)
369 . if $get(showProgress)=1 do PrepProgress^TMGITR(.Itr,20,1,"longName")
370 . if longName'="" for do quit:(+$$ItrANext^TMGITR(.Itr,.longName,-1)>0)!(longName="")
371 . . new shortName set shortName=$get(^TMG("ABBREV",longName))
372 . . set DiffStr=$$GetDiffStr(longName,shortName)
373 . . if xstr'="" xecute xstr
374
375 quit
376
377
378ShowDiff
379 ;"Purpose: scan and show changes
380
381 new xstr
382 set xstr="write longName,"" --> ["",DiffStr,""] "",shortName,!"
383 do ScanAbvs(xstr,1)
384 quit
385
386
387ScanDel(Text)
388 ;"Purpose: scan for text and allow deletions.
389
390 new xstr
391 set xstr="if DiffStr[Text do Del(longName,,1)"
392 do ScanAbvs(xstr)
393 quit
394
395
Note: See TracBrowser for help on using the repository browser.