source: cprs/branches/tmg-cprs/m_files/TMGSHORT.m@ 1428

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

Initial upload

File size: 28.6 KB
Line 
1TMGSHORT ;TMG/kst/Code to Shorten Names ;03/25/06
2 ;;1.0;TMG-LIB;**1**;12/23/06
3
4 ;" SHORTEN NAMES 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 ;"ShortNetName(GenericName,TradeName,Strength,Units,MaxLen)
14 ;"$$ShortenArray(Names,Dividers,MaxLen,AllowCut) -- core menus for shortening name
15 ;"$$PShortName(Name,Length,AskUser) -- shorten the drug smartly, using abbreviations
16 ;"$$ShortName(Name,Length,AskUser,DivStr) -- shorten the drug smartly, using abbreviations
17 ;"$$Short2Name(Name,Div1,Div2,.Words,.Dividers) -- Shorten a name to shortest form possible
18 ;"$$Short1Name(Name,MaxLen,Div1,Div2,Words,Dividers) -- An interactive editing of one name
19 ;"$$Cut1Name(Name,MaxLen,Div1,Div2,Words,Dividers) -- A non-interactive cut of one name
20
21 ;"=======================================================================
22 ;" Private Functions.
23 ;"=======================================================================
24 ;"$$ReadJoin(JoinNum,Len,Words,Dividers) -- read out a phrase of joined words, Len words long
25 ;"SetJoin(JoinNum,Len,Words,Dividers) -- reform the Word and Dividers arrays such that
26 ;" words are joined together. E.g. #1='One' #2='Minute' ==> #1='One Minute'
27 ;"SubDivArray(Words,Dividers,Div1,Div2) -- check and handle if words in Words array need subdivision
28 ;"PackArrays(pNames,pDividers) -- pack the arrays, after items had been deleted.
29 ;"CompArray(Names,Dividers) -- reconstruct the resulting sentence from words in array.
30 ;"AutoShortenArray(.Names,.Dividers,MaxLen,Div1,Div2) -- automatically shorten the words in the array
31 ;"$$CutName(.Names,.Dividers,MaxLen) -- return a non-interactive shortened ('cut') name
32
33 ;"=======================================================================
34 ;"=======================================================================
35
36ShortNetName(GenericName,TradeName,Strength,Units,MaxLen,AllowCut)
37 ;"Purpose: to create a shortened name from parts, not longer than MaxLen
38 ;"Input: GenericName -- Generic portion of name
39 ;" TradeName -- Tradename portion of name
40 ;" Strength -- OPTIONAL Strength portion of name
41 ;" Units -- OPTIONAL units portion of name
42 ;" MaxLen -- the maximum length
43 ;" AllowCut -- OPTIONAL If 1 then name may be cut off with ... to reach target length
44 ;" and user will not be asked for input
45 ;" If 2 then name wil be shortened as far as possible, but it
46 ;" wil not be cut off
47 ;"Result: Returns new shortened name, or "^" for user abort
48
49 new result,temp
50 set GenericName=$get(GenericName)
51 set TradeName=$get(TradeName)
52 set Strength=$get(Strength)
53 set Units=$get(Units)
54 set MaxLen=$get(MaxLen,16)
55 set AllowCut=$get(AllowCut,0)
56
57 new Names,Dividers
58 new unitsIdx,GenericIdx set GenericIdx=0,unitsIdx=0
59 ;"sometimes 'Trade Name' is actually an expanded form of the Generic name
60 ;"e.g. ACETAZOLAMIDE (ACETAZOLAMIDE CAP USP) 250
61 ;"In these cases I will delete the duplication
62SNN0 if $extract(TradeName,1,$length(GenericName))=GenericName set GenericName=""
63 if (TradeName="")!(GenericName="") do
64 . new i set i=0
65 . if TradeName'="" set i=i+1,Names(i)=TradeName,Dividers(i)=" "
66 . if GenericName'="" set i=i+1,Names(i)=GenericName,Dividers(i)=" ",GenericIdx=i
67 . ;"set Names(i)=TradeName,Dividers(i)=" ",i=i+1
68 . if Strength'="" set i=i+1,Names(i)=Strength,Dividers(i)=" "
69 . if Units'="" set i=i+1,Names(i)=Units,unitsIdx=i,Dividers(i)=""
70 . set Names("MAXNODE")=i,Dividers("MAXNODE")=i
71 else do
72 . new i set i=0
73 . set i=i+1,Names(i)=TradeName,Dividers(i)=" ("
74 . set i=i+1,Names(i)=GenericName,GenericIdx=i,Dividers(i)=") "
75 . ;"set i=i+1,Names(i)=GenericName,GenericIdx=i,Dividers(i)=" (" ;changed 10-30-07
76 . ;"set i=i+1,Names(i)=TradeName,Dividers(i)=") "
77 . if Strength'="" set i=i+1,Names(i)=Strength,Dividers(i)=" "
78 . if Units'="" set i=i+1,Names(i)=Units,unitsIdx=i,Dividers(i)=""
79 . set Names("MAXNODE")=i,Dividers("MAXNODE")=i
80
81 for i=1:1:Names("MAXNODE")-1 do ;"don't cleave units (e.g. MG/ML)
82 . set:(i>1) Names(i)=$translate(Names(i),"/","|")
83 do SubDivArray(.Names,.Dividers," ","/")
84
85 set result=$$ShortenArray(.Names,.Dividers,MaxLen,AllowCut)
86 if result=0 kill Names,Dividers goto SNN0 ;"honor requested retry
87
88 ;"If shortening required "...", see if removing parts of name allow goal.
89 if (AllowCut=1)&(result["...") do
90SNN1 . ;"try removing units first
91 . kill Names(unitsIdx),Dividers(unitsIdx)
92 . do PackArrays("Names","Dividers")
93 . set result=$$ShortenArray(.Names,.Dividers,MaxLen,AllowCut)
94 . if result'["..." quit
95 . if GenericIdx'=0 do
96 . . kill Names(GenericIdx)
97 . . if Dividers(GenericIdx)=" (" set Dividers(GenericIdx+1)=" "
98 . . kill Dividers(GenericIdx)
99 . . do PackArrays("Names","Dividers")
100 . . set result=$$ShortenArray(.Names,.Dividers,MaxLen,AllowCut)
101 . if result'["..." quit
102 . ;"more later... ?
103
104SNNDone
105 set result=$$Trim^TMGSTUTL(result)
106 if $extract(result,1,1)="(" do ;"Input transform doesn't allow first chart to be '('
107 . ;"NOTE: I should write better code to change only the LAST ) to "", i.e. not cut out ALL ()'s
108 . set result=$translate(result,"(","")
109 . set result=$translate(result,")","")
110 if (result[")")&(result'["(") set result=$translate(result,")","")
111 set result=$translate(result,"|","/")
112 quit result
113
114
115ShortenArray(Names,Dividers,MaxLen,AllowCut)
116 ;"Purpose: shorten name
117 ;"Input: Names -- PASS BY REFERENCE. An array containing the words
118 ;" Dividers -- PASS BY REFERENCE. An array containing the bits between words
119 ;" MaxLen -- OPTIONAL. Default=1. The length that words must fit within
120 ;" AllowCut -- OPTIONAL. Default=0. Set 1 if automatic shortening is allowed.
121 ;" If 1, MaxLen value SHOULD BE supplied
122 ;" If 2 then name wil be shortened as far as possible, but it
123 ;" wil not be cut off. User will not be asked.
124
125 ;"Result: returns the shortened name, or "^" for abort, or 0 for requested retry.
126
127 new result set result=""
128 set MaxLen=$get(MaxLen,1)
129 set AllowCut=$get(AllowCut,0)
130 new UserAsked set UserAsked=0
131 new StartOver set StartOver=0
132 new OrigName set OrigName=$$CompArray(.Names,.Dividers)
133
134 ;"First try a non-interactive shortening
135 set result=$$AutoShortenArray(.Names,.Dividers,MaxLen,"/"," ")
136 if (AllowCut'=1)&(result["...") goto SNA0
137 if $length(result)'>MaxLen goto SNA1Done
138
139SNA0 if AllowCut=1 set result=$$CutName(.Names,.Dividers,MaxLen) goto SNA1Done
140 if AllowCut=2 set result=$$CompArray(.Names,.Dividers) goto SNA1Done
141
142SNA1 if result=0 goto SNA2Done ;"requesting retry.
143 set result=$$Trim^TMGSTUTL($$CompArray(.Names,.Dividers))
144 if $length(result)'>MaxLen goto SNA1Done
145
146 write OrigName,"-->",!
147 write "Current Name:",!
148 write result,!
149 if MaxLen>1 do
150 . new tempS set tempS="Shorten to ---> |"
151 . for i=1:1:MaxLen-$length(tempS) write " "
152 . write tempS
153 . for i=1:1:$length(result)-MaxLen write "x"
154 . write !
155
156 write "-----------------------",!
157 for i=1:1:Names("MAXNODE") do
158 . if $get(Names(i))="" quit
159 . write i,". ",Names(i)
160 . new temp set temp=$$GetAbvr^TMGABV(Names(i),0)
161 . if (temp'="")&(temp'=Names(i)) write " (<-- Quick Fix: ",temp,")"
162 . write !
163 write "-----------------------",!
164 write " # (or #-#) -- Shorten name(s) Q# (or #-#) -- Use Quick FiX",!
165 write " S# -- Sub-edit name T -- Free text for ALL",!
166 write " S?# -- Sub-edit name (ask for divider character)",!
167 write " Sx# -- Sub-edit name (use any character (i.e. replace 'x') as divider)",!
168 write " J# -- Join word # to word #+1 F# -- Fix erroneous abbrev",!
169 write " D# (or D#-#) -- Delete # X# -- Kill Quick Fix",!
170 write " ! -- toggle debug mode ",$select(($get(TMGDBABV)=1):"OFF",1:"ON"),!
171 write " C -- cut to: ",$$CutName(.Names,.Dividers,MaxLen),!
172 ;"write " ^^ -- Abort",!
173 write "(^ to quit, ^^ to abort): ^//"
174 set UserAsked=1
175 read temp:$get(DTIME,3600),!
176 set temp=$$UP^XLFSTR(temp)
177 if temp="" set temp="^" do goto SNA1Done
178 . set result=$$CompArray(.Names,.Dividers)
179 if temp="^^" set result="^" goto SNA2Done
180 if temp="C" set AllowCut=1 goto SNA0
181 if "S"[$extract(temp,1) do
182 . new num1,s
183 . new nodeDiv set nodeDiv=" "
184 . set s=$extract(temp,2)
185 . if +s'=s do quit:(nodeDiv="^")
186 . . if s="?" do quit:(nodeDiv="^")
187 . . . write "Enter character that divides words (e.g. '/' ',' '|' ';' ' ' etc.)",!
188 . . . read "Divider character? ' '// ",nodeDiv,!
189 . . . if nodeDiv="" set nodeDiv=" "
190 . . else set nodeDiv=s
191 . . set num1=+$extract(temp,3,99)
192 . else set num1=+$extract(temp,2,99)
193 . if num1=0 read "Enter NUMBER of name to edit: ",num1:$get(DTIME,3600),!
194 . set num1=+num1
195 . if (num1'>0)!(num1>Names("MAXNODE")) quit
196 . new temp set temp=$$Short1Name(Names(num1),$length(Names(num1))-1,nodeDiv)
197 . if (temp="^")!(temp="")!(temp=Names(num1)) quit
198 . do Write^TMGABV(Names(num1),temp,,1) ;"1=> confirm
199 . set Names(num1)=temp
200 if temp="T" do goto SNA1Done
201TX1 . write "Enter text for ENTIRE name (combining all shown parts) (^ to abort):",!
202 . read "> ",input:$get(DTIME,3600),!
203 . if input="^" quit
204 . ;"kill Words,Dividers
205 . kill Names,Dividers
206 . ;"set Words(1)=input,Words("MAXNODE")=1,Dividers(1)=""
207 . set Names(1)=input,Names("MAXNODE")=1,Dividers(1)=""
208 if "J"[$extract(temp,1) do
209 . new JoinNum
210 . set JoinNum=+$extract(temp,2,99)
211 . if JoinNum'>0 read "Enter # to join: ",JoinNum:$get(DTIME,3600),!
212 . if +JoinNum'>0 quit
213 . ;"if JoinNum=Words("MAXNODE") do quit
214 . if JoinNum=Names("MAXNODE") do quit
215 . . write "Enter the # of the FIRST word to be joined.",!
216JL1 . ;"do SetJoin(JoinNum,2,.Words,.Dividers)
217 . do SetJoin(JoinNum,2,.Names,.Dividers)
218 if (temp="D")!(temp?1"D".N)!(temp?1"D".N1"-".N) do goto SNA1
219JL2 . new delNum,delNum2,i
220 . set temp=$extract(temp,2,99)
221 . ;"if Words("MAXNODE")=1 set delNum=1,delNum2=1
222 . if $get(Names("MAXNODE"))=1 set delNum=1,delNum2=1
223 . else do
224 . . set delNum=+$piece(temp,"-",1)
225 . . set delNum2=+$piece(temp,"-",2)
226 . . if delNum2<delNum set delNum2=delNum
227 . . if delNum>0 quit
228 . . read "Enter # (or #-#) to delete: ",temp:$get(DTIME,3600),!
229 . . set delNum=+$piece(temp,"-",1)
230 . . set delNum2=+$piece(temp,"-",2)
231 . . if delNum2<delNum set delNum2=delNum
232 . for i=delNum:1:delNum2 do
233 . . ;"if +i>0 kill Words(i),Dividers(i)
234 . . if +i>0 kill Names(i),Dividers(i)
235 . ;"do PackArrays("Words","Dividers")
236 . do PackArrays("Names","Dividers")
237 if "X"[$extract(temp,1) do
238 . new delNum
239 . ;"if Words("MAXNODE")=1 set delNum=1
240 . if Names("MAXNODE")=1 set delNum=1
241 . else do
242 . . set delNum=+$extract(temp,2,99)
243 . . if delNum>0 quit
244 . . read "Enter # of Quick Fix to delete: ",delNum:$get(DTIME,3600),!
245 . ;"if +delNum>0 do Del^TMGABV(Words(delNum))
246 . if +delNum>0 do Del^TMGABV(Names(delNum))
247 if (temp?.N)!(temp?.N1"-".N) do goto SNA1
248 . new num1,num2
249 . set num1=+$piece(temp,"-",1)
250 . set num2=+$piece(temp,"-",2)
251 . if num2=0 set num2=num1
252 . new tempS set tempS=""
253 . for i=num1:1:num2 set tempS=tempS_Names(i)_" "
254 . set tempS=$$Trim^TMGSTUTL(tempS)
255 . set tempS=$$GetAbvr^TMGABV(tempS,1)
256 . for i=num1+1:1:num2 kill Names(i)
257 . for i=num1:1:(num2-1) kill Dividers(i)
258 . set Names(num1)=tempS
259 . do PackArrays("Names","Dividers")
260 if (temp="Q")!(temp?1"Q".N)!(temp?1"Q".N1"-".N) do goto SNA1
261 . new num1,num2
262 . set num1=+$extract(temp,2,99)
263 . if num1=0 do quit:(+num1=0)
264 . . read "Enter NUMBER(S) of Quick Fix to use: ",temp:$get(DTIME,3600),!
265 . . set num1=+$piece(temp,"-",1)
266 . . set num2=+$piece(temp,"-",2)
267 . if +$get(num2)=0 set num2=num1
268 . for i=num1:1:num2 do
269 . . set Names(i)=$$GetAbvr^TMGABV(Names(i),0)
270 if (temp="F")!(temp?1"F"1N) do goto SNA1
271 . new num1 set num1=+$extract(temp,2,99)
272 . if num1=0 do quit:(+num1=0)
273 . . read "Enter NUMBER of abbreviation to fix: ",temp:$get(DTIME,3600),!
274 . . set num1=+temp
275 . new s set s=$$Fix^TMGABV(Names(num1),OrigName)
276 . if s=0 set result=0 quit ;"signal retry
277 . set Names(num1)=s
278 . if Names(num1)="" do
279 . . kill Names(num1)
280 . . ;"do PackArrays("Words","Dividers")
281 . . do PackArrays("Names","Dividers")
282 if (temp="!") do goto SNA1
283JL5 . if $get(TMGDBABV)=1 kill TMGDBABV
284 . else set TMGDBABV=1
285 . set result=0 ;"signal request for retry.
286 goto SNA1
287
288SNA1Done set result=$$Trim^TMGSTUTL(result)
289SNA2Done
290 if (UserAsked=1)&(+result'=0) write "Using: ",result,!
291 quit result
292
293
294ReadJoin(JoinNum,Len,Words,Dividers)
295 ;"Purpose: To read out a phrase of joined words, Len words long
296 ;"Input: JoinNum -- the index in Words where joining begins
297 ;" Len -- the length to return. e.g. 2 --> two words joined
298 ;" Words -- PASS BY REFERENCE. Array holding words
299 ;" Dividers -- PASS BY REFERENCE. Array holding dividers between words
300 ;"Results: returns string of joined words
301
302 new result set result=""
303 if (JoinNum+Len-1)>Words("MAXNODE") goto RJDone
304 set result=$get(Words(JoinNum))
305 new i for i=JoinNum:1:(JoinNum+Len-2) do
306 . set result=result_Dividers(i)_$get(Words(i+1))
307RJDone quit result
308
309
310SetJoin(JoinNum,Len,Words,Dividers)
311 ;"Purpose: To reform the Word and Dividers arrays such that words are
312 ;" joined together. E.g. #1='One' #2='Minute' ==> #1='One Minute'
313 ;"Input: JoinNum -- the index in Words where joining begins
314 ;" Len -- the length to return. e.g. 2 --> two words joined
315 ;" Words -- PASS BY REFERENCE. Array holding words
316 ;" Dividers -- PASS BY REFERENCE. Array holding dividers between words
317 ;"Results: None
318
319 new temp set temp=$$ReadJoin^TMGSHORT(JoinNum,Len,.Words,.Dividers)
320 new i for i=JoinNum:1:(JoinNum+Len-1) do
321 . if i'=JoinNum kill Words(i)
322 . if i'=(JoinNum+Len-1) kill Dividers(i)
323
324 set Words(JoinNum)=temp
325 do PackArrays("Words","Dividers")
326
327 quit
328
329
330Short1Name(Name,MaxLen,Div1,Div2,Words,Dividers)
331 ;"Purpose: An interactive editing of one name
332 ;"Input: Name -- the name (string) to shorten.
333 ;" MaxLen -- OPTIONAL. The Max length of the string.
334 ;" Div1 -- OPTIONAL. The first character used to separate words. Default is " "
335 ;" Div2 -- OPTIONAL. The second character used to separate words. Default is "/"
336 ;" Words -- OPTIONAL. PASS BY REFERENCE, an OUT PARAMETER. Returns Name divided up into words
337 ;" Dividers -- OPTIONAL. PASS BY REFERENCE, an OUT PARAMETER. Returns dividers between words
338 ;"Results: returns shortened name, or "^" for user abort
339
340 set Div1=$get(Div1," ")
341 set Div2=$get(Div2)
342
343S1N0 do CleaveToArray^TMGSTUTL(Name,Div1,.Words)
344 for i=1:1:Words("MAXNODE") set Dividers(i)=Div1
345 set Dividers(Words("MAXNODE"))=""
346 if Div2'="" do SubDivArray(.Words,.Dividers,Div1,Div2)
347
348 set result=$$ShortenArray^TMGSHORT(.Words,.Dividers,MaxLen,0)
349 if result=0 kill Words,Dividers goto S1N0
350
351 quit result
352
353
354Cut1Name(Name,MaxLen,Div1,Div2,Words,Dividers)
355 ;"Purpose: A non-interactive cut of one name
356 ;"Input: Name -- the name (string) to shorten.
357 ;" MaxLen -- The length of the string to cut to.
358 ;" Div1 -- OPTIONAL. The first character used to separate words. Default is " "
359 ;" Div2 -- OPTIONAL. The second character used to separate words. Default is "/"
360 ;" Words -- OPTIONAL. PASS BY REFERENCE, an OUT PARAMETER. Returns Name divided up into words
361 ;" Dividers -- OPTIONAL. PASS BY REFERENCE, an OUT PARAMETER. Returns dividers between words
362 ;"Results: returns cut name
363
364 set Div1=$get(Div1," ")
365 set Div2=$get(Div2)
366
367 do CleaveToArray^TMGSTUTL(Name,Div1,.Words)
368 for i=1:1:Words("MAXNODE") set Dividers(i)=Div1
369 set Dividers(Words("MAXNODE"))=""
370 if Div2'="" do SubDivArray(.Words,.Dividers,Div1,Div2)
371
372 set result=$$CutName(.Words,.Dividers,MaxLen)
373
374 quit result
375
376
377Short2Name(Name,Div1,Div2,Words,Dividers,Category)
378 ;"Purpose: Shorten a name, using abbreviations etc. to shortest form possible
379 ;" Will separate name into individual words, separated by spaces
380 ;" and try to abbreviate each one.
381 ;"Input: Name -- name to shorten
382 ;" Div1 -- OPTIONAL. The first character used to separate words. Default is " "
383 ;" Div2 -- OPTIONAL. The second character used to separate words. Default is "/"
384 ;" Words -- OPTIONAL. PASS BY REFERENCE, an OUT PARAMETER. Returns Name divided up into words
385 ;" Dividers -- OPTIONAL. PASS BY REFERENCE, an OUT PARAMETER. Returns dividers between words
386 ;" Category -- OPTIONAL. a category to look for phrases in
387 ;"Result: returns a shortened form of name
388 ;"Note: no testing of length done.
389 ;"Note: this function is NOT interactive with the user
390 ;"Note: This functions should be called repetatively,using the output from
391 ;" the last run as the input for the next run, until there is not further
392 ;" change, to get the best results.
393
394 new temp,result,i
395 set result=""
396 if $get(Name)="" goto SN2Don2
397
398 set result=$$GetAbvr^TMGABV(Name,0)
399 if (result'="")&(result'=Name) goto SN2Done
400
401 set Div1=$get(Div1," ") if Div1="" set Div1="@@@@"
402 set Div2=$get(Div2,"/") if Div2="" set Div2="@@@@"
403
404 kill Words,Dividers
405 do CleaveToArray^TMGSTUTL(Name,Div1,.Words)
406 for i=1:1:Words("MAXNODE") set Dividers(i)=Div1
407 set Dividers(Words("MAXNODE"))="" ;"//kt added 10/27/06
408
409 ;"Note: This purposefully does not keep rechecking for ever shortening
410 ;" Abreviations (or abrv of abrv's) so that the calling function
411 ;" can concat the results from this onto others and determine a
412 ;" total length, and then recall if needed.
413 new count set count=Words("MAXNODE")
414 for i=1:1:count do
415 . new temp,temp2
416 . if Words(i)[Div2 set temp=$$Short2Name(Words(i),Div2)
417 . else set temp=$$GetAbvr^TMGABV(Words(i),0)
418 . set Words(i)=temp
419
420 ;"Now look for double word matches
421 set Category=$get(Category,0)
422SNL0 for i=1:1:count do
423 . new temp,temp2
424 . set temp=$$ReadJoin^TMGSHORT(i,2,.Words,.Dividers)
425 . set temp2=$$GetAbvr^TMGABV(temp,Category)
426 . if (temp2'="")&(temp'=temp2) do
427SNL1 . . ;"write "Found double word match: ",temp,"-->",temp2,!
428 . . do SetJoin^TMGSHORT(i,2,.Words,.Dividers)
429 . . set Words(i)=temp2
430 . . ;"zwr Words(*)
431 . . set i=0,count=Words("MAXNODE")
432
433 set result=$$CompArray(.Words,.Dividers)
434
435SN2Done set result=$$Trim^TMGSTUTL(result)
436 if (Name'=result) do Write^TMGABV(Name,result)
437
438SN2Don2 quit result
439
440
441SubDivArray(Words,Dividers,Div1,Div2)
442 ;"Purpose: To see if any words in Words array needs to be subdivided,
443 ;" and to handle if needed.
444 ;"Input: Words -- PASS BY REFERENCE. Array of words
445 ;" Dividers -- PASS BY REFERENCE. Array of dividing parts
446 ;" Div1 -- the first division character, e.g. "/" or " "
447 ;" Div2 -- the second division character, e.g. " " or "/"
448 ;"Results: none
449
450 new i
451 for i=1:1:Words("MAXNODE") do
452 . if Words(i)[Div2 do
453 . . new tempWords,j
454 . . do CleaveToArray^TMGSTUTL(Words(i),Div2,.tempWords)
455 . . for j=1:1:tempWords("MAXNODE") do
456 . . . set Words(+(i_"."_j))=tempWords(j)
457 . . . if j'=tempWords("MAXNODE") set Dividers(+(i_"."_j))=Div2
458 . . . else set Dividers(+(i_"."_j))=Div1
459 . . kill Words(i),Dividers(i)
460 do PackArrays("Words","Dividers")
461
462 quit
463
464
465PackArrays(pNames,pDividers)
466 ;"Purpose: to pack the arrays, after items had been deleted.
467 ;"Input: Names -- PASS BY NAME. Array of words
468 ;" Dividers -- PASS BY NAME. Array of dividing parts
469 ;"Result: none
470
471 do ListPack^TMGMISC(pNames)
472 do ListPack^TMGMISC(pDividers)
473 set @pNames@("MAXNODE")=$$ListCt^TMGMISC(pNames)
474 set @pDividers@("MAXNODE")=$$ListCt^TMGMISC(pDividers)
475 quit
476
477
478CompArray(Names,Dividers)
479 ;"Purpose: to reconstruct the resulting sentence from words in array.
480 ;"Input: Names -- PASS BY REFERENCE. Array of words
481 ;" Dividers -- PASS BY REFERENCE. Array of dividing parts
482 ;"Result: returns the compiled result
483
484 new result,j
485 set result=""
486 for j=1:1:Names("MAXNODE") do
487 . set result=result_Names(j)
488 . if Names(j)'="" set result=result_Dividers(j)
489 quit result
490
491
492AutoShortenArray(Names,Dividers,MaxLen,Div1,Div2)
493 ;"Purpose: To automatically shorten the words in the array
494 ;"Input: Names -- PASS BY REFERENCE. Array of words
495 ;" Dividers -- PASS BY REFERENCE. Array of dividing parts
496 ;" Div1 -- the first division character, e.g. "/" or " "
497 ;" Div2 -- the second division character, e.g. " " or "/"
498
499 new result,newName,changeMade
500 set result=""
501
502 new temp set temp=$$CompArray(.Names,.Dividers)
503 set result=$$GetAbvr^TMGABV(temp,0)
504 if result="^" set result="" do Del^TMGABV(temp)
505 if (result'="")&($length(result)'>MaxLen) goto ASADone
506
507 for do quit:(changeMade=0)!($length(result)'>MaxLen)
508 . set changeMade=0
509 . for i=1:1:Names("MAXNODE") do
510 . . set newName=$$Short2Name(Names(i),.Div1,.Div2)
511 . . ;"there was a loop where a name was repeatitively being replace with longer names --> crash
512 . . if (newName'=Names(i))&($length(newName)<$length(Names(i))) do
513 . . . set Names(i)=newName
514 . . . set changeMade=1
515 . set result=$$CompArray(.Names,.Dividers)
516
517ASADone
518 quit result
519
520
521CutName(Names,Dividers,MaxLen)
522 ;"Purpose: To return a non-interactive shortened ('cut') name
523 ;"Input: Names - PASS BY REFERENCE. As created in ShortNetName
524 ;" This is an array with the various words in the name
525 ;" Dividers -- PASS BY REFERENCE As created in ShortNetName
526 ;" This is an array with the spaces or punctiation separating words
527 ;" MaxLen -- The target length for result
528 ;"Result: returns the shortened name
529
530 new partA,partB,Max,i,lenA
531 new result
532
533 set Max=$get(Names("MAXNODE"))
534
535 if Max'>3 do goto CutDone
536 . set result=$$CompArray(.Names,.Dividers)
537 . set result=$extract(result,1,MaxLen)
538
539 set partB=$get(Dividers(Max-3))
540 for i=Max-2:1:Max do
541 . set partB=partB_Names(i)
542 . if Names(i)'="" set partB=partB_Dividers(i)
543 set partB=$$Trim^TMGSTUTL(partB)
544 set partA=""
545 for i=1:1:Max-3 set partA=partA_Names(i) set:(i<(Max-3))&(Names(i)'="") partA=partA_Dividers(i)
546 new allowedALen set allowedALen=MaxLen-$length(partB)
547 set lenA=$length(partA)
548 if lenA>allowedALen do
549 . set allowedALen=allowedALen-4
550 . if lenA=0 set partA="" quit
551 . if (allowedALen/lenA)<0.4 set partA="" quit
552 . if allowedALen<4 set partA="" quit
553 . set partA=$extract(partA,1,allowedALen)_"... "
554 set result=$$Trim^TMGSTUTL(partA_partB)
555 if $length(result)>MaxLen do
556 . if partA="" do
557 . . set partB="" ;"$get(Dividers(Max-2))
558 . . for i=Max-1:1:Max do
559 . . . set partB=partB_Names(i)
560 . . . if Names(i)'="" set partB=partB_Dividers(i)
561 . . set partB=$$Trim^TMGSTUTL(partB)
562 . . set partA=Names(Max-2)
563 . . new allowedALen set allowedALen=MaxLen-$length(partB)-4
564 . . set partA=$extract(partA,1,allowedALen)_"... "
565 . . set result=partA_partB
566 . else set result=$extract(result,1,MaxLen)
567
568CutDone
569 quit result
570
571
572PShortName(Name,Length,AskUser)
573 ;"Purpose: To shorten the drug smartly, using abbreviations
574 ;" This function differs from ShortName (see below) because it smartly
575 ;" 'P'icks whether to use '/' or ' ' as a divider str.
576 ;"Input: Name -- the drug name to shorten
577 ;" Expected format is that found in file 50.6 field .01,
578 ;" i.e. INGREDIENT/INGREDIENT/INGREDIENT...
579 ;" Length -- The desired string length
580 ;" AskUser -- OPTIONAL. Default=0.
581 ;" If 1 then user is asked to supply abreviations if needed.
582 ;" If 2 then name is shortened as much as possible, but it
583 ;" might be longer than Length, it is not cut, and user is
584 ;" not asked.
585 ;"Result : returns shortened name, "^" for abort.
586
587 new DivStr,result
588 if $length(Name,"/")>2 set DivStr="/"
589 else set DivStr=" "
590
591 set result=$$ShortName(.Name,.Length,.AskUser,DivStr)
592 quit result
593
594ShortName(Name,Length,AskUser,DivStr)
595 ;"Purpose: To shorten the drug smartly, using abbreviations
596 ;"Input: Name -- the drug name to shorten
597 ;" Expected format is that found in file 50.6 field .01,
598 ;" i.e. INGREDIENT/INGREDIENT/INGREDIENT...
599 ;" Length -- The desired string length
600 ;" AskUser -- OPTIONAL. Default=0.
601 ;" If 1 then user is asked to supply abreviations if needed.
602 ;" If 2 then name is shortened as much as possible, but it
603 ;" might be longer than Length, it is not cut, and user is
604 ;" not asked.
605 ;" DivStr -- the divider that separates parts. Default="/"
606 ;"Result : returns shortened name, "^" for abort.
607
608 new temp,Words,Dividers
609 set AskUser=$get(AskUser,0)
610 set DivStr=$get(DivStr,"/")
611
612 if Name="" set temp="^" goto SNDone
613 set temp=$$Read^TMGABV(Name,Length)
614
615 if (temp'="")&($length(temp)'>Length) goto SNDone
616
617 ;"Note: $$ShortName does NOT check length
618 new oldTemp,done
619 set temp=Name,done=0
620 for do quit:done!($length(temp)'>Length)
621 . set oldTemp=temp
622 . set temp=$$Short2Name(temp,DivStr,"",.Words,.Dividers,Length)
623 . if temp=oldTemp set done=1 quit
624 . if ($length(temp)'>Length) set done=1 ;"don't quit yet
625 . if (temp["...")&(AskUser=1) write !,"Remove '...' from name",! set done=0
626
627 if (($length(temp)>Length)&(AskUser=1)) do
628SNm0 . new killthis set killthis=0
629 . write "IEN 50.6=",$get(IEN50d6,"?")," IEN 50.606=",$get(IEN50d606,"?")
630 . write " Dose=",$get(Dose,"?")," IEN 50=",$get(IEN50,"?"),!
631 . write Name,!
632SNm1 . set temp=$$Short1Name(temp,Length,DivStr,"",.Words,.Dividers)
633 . if (temp'="")&(temp'="^")&(temp'=Name) do
634 . . do Write^TMGABV(Name,temp,Length,(AskUser=1))
635 . write !
636
637 if ($length(temp)>Length)&(AskUser'=2) do
638 . if ($data(Words)=0)!($data(Dividers)=0) do quit
639 . . set temp=$extract(temp,1,Length)
640 . set temp=$$CutName(.Words,.Dividers,Length)
641SNDone
642 if $extract(temp,1)="/" set temp=$extract(temp,2,Length)
643 quit temp
644
645
Note: See TracBrowser for help on using the repository browser.