source: cprs/branches/tmg-cprs/m_files/TMGSTUTL.m.bak@ 796

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

Initial upload
File size: 62.7 KB
Line 
1TMGSTUTL ;TMG/kst/String Utilities and Library ;03/25/06
2 ;;1.0;TMG-LIB;**1**;09/01/05
3
4 ;"TMG STRING UTILITIES
5
6 ;"=======================================================================
7 ;" API -- Public Functions.
8 ;"=======================================================================
9 ;"CleaveToArray^TMGSTUTL(Text,Divider,Array)
10 ;"CatArray(Words,i1,i2,DivChr) -- return concat array from index1 to index2
11 ;"CleaveStr^TMGSTUTL(Text,Divider,PartB)
12 ;"SplitStr^TMGSTUTL(Text,Width,PartB)
13 ;"SetStrLen^TMGSTUTL(Text,Width)
14 ;"$$NestSplit^TMGSTUTL(Text,OpenBracket,CloseBracket,SBefore,S,SAfter)
15 ;"$$Substitute^TMGSTUTL(S,Match,NewValue)
16 ;"$$FormatArray^TMGSTUTL(InArray,OutArray,Divider)
17 ;"$$Trim^TMGSTUTL(S,TrimCh) ; --> or use $$TRIM^XLFSTR
18 ;"$$TrimL^TMGSTUTL(S,TrimCh)
19 ;"$$TrimR^TMGSTUTL(S,TrimCh)
20 ;"$$TrimRType^TMGSTUTL(S,type)
21 ;"$$NumLWS^TMGSTUTL(S)
22 ;"$$MakeWS^TMGSTUTL(n)
23 ;"WordWrapArray^TMGSTUTL(.Array,Width,SpecialIndent)
24 ;"SplitLine^TMGSTUTL(s,.LineArray,Width)
25 ;"WriteWP^TMGSTUTL(NodeRef)
26 ;"$$LPad^TMGSTUTL(S,width) ;"NOTE: should use XLFSTR fn below
27 ;"$$RPad^TMGSTUTL(S,width) ;"NOTE: should use XLFSTR fn below
28 ;"$$Center^TMGSTUTL(S,width) ;"NOTE: should use XLFSTR fn below
29 ;"$$Clip^TMGSTUTL(S,width)
30 ;"$$STRB2H^TMGSTUTL(s,F) Convert a string to hex characters
31 ;"$$CapWords^TMGSTUTL(S,Divider) ;"capitalize the first character of each word in a string
32 ;"$$LinuxStr^TMGSTUTL(S) ;"Convert string to a valid linux filename
33 ;"StrToWP^TMGSTUTL(s,pArray,width,DivCh,InitLine) ;"wrap long string into a WP array
34 ;"$$WPToStr^TMGSTUTL(pArray,DivCh,MaxLen,InitLine)
35 ;"Comp2Strs(s1,s2) -- compare two strings and assign an arbritrary score to their similarity
36 ;"$$PosNum(s,[Num],LeadingSpace) -- return position of a number in a string
37 ;"IsNumeric(s) -- deterimine if word s is a numeric
38 ;"ScrubNumeric(s) -- remove numeric words from a sentence
39 ;"Pos(subStr,s,count) -- return the beginning position of subStr in s
40 ;"DiffPos(s1,s2) -- Return the position of the first difference between s1 and s2
41 ;"DiffWords(Words1,Words2) -- Return index of first different word between Words arrays
42 ;"SimStr(s1,p1,s2,p2) -- return matching string in s1 and s2, starting at position p1,p2
43 ;"SimWord(Words1,p1,Words2,p2) -- return the matching words in both words array 1 and 2, starting
44 ;" at word positions p1 and p2.
45 ;"SimPos(s1,s2) -- return the first position that two strings are similar.
46 ;"SimWPos(Words1,Words2,DivStr,p1,p2,MatchStr) -- return the first position that two word arrays
47 ;" are similar. This means the first index in Words array 1 that matches to words in Words array 2.
48 ;"DiffStr(s1,s2,DivChr) -- Return how s1 differs from s2.
49 ;"CatArray(Words,i1,i2,DivChr) -- return concat array from index1 to index2
50 ;"$$QtProtect(s) -- Protects quotes by converting all quotes do double quotes (" --> "")
51 ;"$$InQt(s,Pos) -- return if a character at position P is inside quotes in s
52 ;"$$GetWord(s,Pos,OpenDiv,CloseDiv) -- extract a word from a sentance, bounded by OpenDiv,CloseDiv
53 ;"$$CmdChStrip(s) -- Strips all characters < #32 from string.
54 ;"$$StrBounds(s,p) -- return position of end of string
55 ;"NonWhite(s,p) -- return index of first non-whitespace character
56 ;"Pad2Pos(Pos,ch) -- return a padding string from current $X up to Pos, using ch
57
58 ;"=======================================================================
59 ;"Dependancies
60 ;" uses TMGDEBUG for debug messaging.
61 ;"=======================================================================
62 ;"=======================================================================
63
64 ;"------------------------------------------------------------------------
65 ;"FYI, String functions in XLFSTR module:
66 ;"------------------------------------------------------------------------
67 ;"$$CJ^XLFSTR(s,i[,p]) -- Returns a center-justified string
68 ;" s=string, i=field size, p(optional)=pad character
69 ;"$$LJ^XLFSTR(s,i[,p]) -- Returns a left-justified string
70 ;" s=string, i=field size, p(optional)=pad character
71 ;"$$RJ^XLFSTR(s,i[,p]) -- Returns a right-justified string
72 ;" s=string, i=field size, p(optional)=pad character
73 ;"$$INVERT^XLFSTR(s) -- returns an inverted string (i.e. "ABC"-->"CBA")
74 ;"$$LOW^XLFSTR(s) -- returns string with all letters converted to lower-case
75 ;"$$UP^XLFSTR(s) -- returns string with all letters converted to upper-case
76 ;"$$TRIM^XLFSTR(s,[LRFlags],[char])
77 ;"$$REPEAT^XLFSTR(s,Count) -- returns a string that is a repeat of s Count times
78 ;"$$REPLACE^XLFSTR(s,.spec) -- Uses a multi-character $TRanslate to return a
79 ;" string with the specified string replaced
80 ;" s=input string, spec=array passed by reference
81 ;" spec format:
82 ;" spec("Any_Search_String")="Replacement_String"
83 ;"$$STRIP^XLFSTR(s,Char) -- returns string striped of all instances of Char
84
85 ;"=======================================================================
86
87CleaveToArray(Text,Divider,Array,InitIndex)
88 ;"Purpose: To take a string, delineated by 'divider' and
89 ;" to split it up into all its parts, putting each part
90 ;" into an array. e.g.:
91 ;" This/Is/A/Test, with '/' divider would result in
92 ;" Array(1)="This"
93 ;" Array(2)="Is"
94 ;" Array(3)="A"
95 ;" Array(4)="Test"
96 ;" Array(cMaxNode)=4 ;cMaxNode="MAXNODE"
97 ;"Input: Text - the input string -- should NOT be passed by reference.
98 ;" Divider - the delineating string
99 ;" Array - The array to receive output **SHOULD BE PASSED BY REFERENCE.
100 ;" InitIndex - OPTIONAL -- The index of the array to start with, i.e. 0 or 1. Default=1
101 ;"Output: Array is changed, as outlined above
102 ;"Result: none
103 ;"Notes: Note -- Text is NOT changed (unless passed by reference, in
104 ;" which case the next to the last piece is put into Text)
105 ;" Array is killed, the filled with data **ONLY** IF DIVISIONS FOUND
106 ;" Limit of 256 nodes
107 ;" if cMaxNode is not defined, "MAXNODE" will be used
108
109 set DBIndent=$get(DBIndent,0)
110 do DebugEntry^TMGDEBUG(.DBIndent,"CleaveToArray")
111
112 set InitIndex=$get(InitIndex,1)
113 new PartB
114 new count set count=InitIndex
115 set cMaxNode=$get(cMaxNode,"MAXNODE")
116
117 kill Array ;"Clear out any old data
118
119C2ArLoop
120 if '(Text[Divider) do goto C2ArDone
121 . set Array(count)=Text ;"put it all into first line.
122 . set Array(cMaxNode)=1
123 do CleaveStr(.Text,Divider,.PartB)
124 set Array(count)=Text
125 set Array(cMaxNode)=count
126 set count=count+1
127 if '(PartB[Divider) do goto C2ArDone
128 . set Array(count)=PartB
129 . set Array(cMaxNode)=count
130 else do goto C2ArLoop
131 . set Text=$get(PartB)
132 . set PartB=""
133
134C2ArDone
135 do DebugExit^TMGDEBUG(.DBIndent,"CleaveToArray")
136 quit
137
138
139CleaveStr(Text,Divider,PartB)
140 ;"Purpse: To take a string, delineated by 'Divider'
141 ;" and to split it into two parts: Text and PartB
142 ;" e.g. Text="Hello\nThere"
143 ;" Divider="\n"
144 ;" Function will result in: Text="Hello", PartB="There"
145 ;"Input: Text - the input string **SHOULD BE PASSED BY REFERENCE.
146 ;" Divider - the delineating string
147 ;" PartB - the string to get second part **SHOULD BE PASSED BY REFERENCE.
148 ;"Output: Text and PartB will be changed
149 ;" Function will result in: Text="Hello", PartB="There"
150 ;"Result: none
151
152 set DBIndent=$get(DBIndent,0)
153 do DebugEntry^TMGDEBUG(.DBIndent,"CleaveStr")
154
155 do DebugMsg^TMGDEBUG(DBIndent,"Text=",Text)
156
157 if '$data(Text) goto CSDone
158 if '$Data(Divider) goto CSDone
159 set PartB=""
160
161 new PartA
162
163 if Text[Divider do
164 . set PartA=$piece(Text,Divider,1)
165 . set PartB=$piece(Text,Divider,2,256)
166 . set Text=PartA
167
168 do DebugMsg^TMGDEBUG(DBIndent,"After Processing, Text='",Text,"', and PartB='",PartB,"'")
169CSDone
170 do DebugExit^TMGDEBUG(.DBIndent,"CleaveStr")
171 quit
172
173
174SplitStr(Text,Width,PartB)
175 ;"PUBLIC FUNCTION
176 ;"Purpose: To a string into two parts. The first part will fit within 'Width'
177 ;" the second part is what is left over
178 ;" The split will be inteligent, so words are not divided (splits at a space)
179 ;"Input: Text = input text. **Should be passed by reference
180 ;" Width = the constraining width
181 ;" PartB = the left over part. **Should be passed by reference
182 ;"output: Text and PartB are modified
183 ;"result: none.
184
185 new Len
186 set Width=$get(Width,80)
187 new SpaceFound set SpaceFound=0
188 new SplitPoint set SplitPoint=Width
189 set Text=$get(Text)
190 set PartB=""
191
192 set Len=$length(Text)
193 if Len>Width do
194 . new Ch
195 . for SplitPoint=SplitPoint:-1:1 do quit:SpaceFound
196 . . set Ch=$extract(Text,SplitPoint,SplitPoint)
197 . . set SpaceFound=(Ch=" ")
198 . if 'SpaceFound set SplitPoint=Width
199 . set s1=$extract(Text,1,SplitPoint)
200 . set PartB=$extract(Text,SplitPoint+1,1024) ;"max String length=1024
201 . set Text=s1
202 else do
203
204 quit
205
206
207
208SetStrLen(Text,Width)
209 ;"PUBLIC FUNCTION
210 ;"Purpose: To make string exactly Width in length
211 ;" Shorten as needed, or pad with terminal spaces as needed.
212 ;"Input: Text -- should be passed as reference. This is string to alter.
213 ;" Width -- the desired width
214 ;"Results: none.
215
216 set Text=$get(Text)
217 set Width=$get(Width,80)
218 new result set result=Text
219 new i,Len
220
221 set Len=$length(result)
222 if Len>Width do
223 . set result=$extract(result,1,Width)
224 else if Len<Width do
225 . for i=1:1:(Width-Len) set result=result_" "
226
227 set Text=result ;"pass back changes
228
229 quit
230
231
232NestSplit(Text,OpenBracket,CloseBracket,SBefore,S,SAfter)
233 ;"PUBLIC FUNCTION
234 ;"Purpose: To take a string in this format:
235 ;" Text='a big black {{Data.Section[{{MVar.Num}}]}} chased me'
236 ;" OpenBracket='{{'
237 ;" CloseBracket='}}'
238 ;" and return:
239 ;" SBefore='a big black {{Data.Section['
240 ;" S='MVar.Num
241 ;" SAfter=']}} chased me'
242 ;" Notice that this function will return the INNER-MOST text inside the brackets pair
243 ;" Note: if multiple sets of brackets exist in the string, like this:
244 ;" 'I am a {{MVar.Person}} who loves {{MVar.Food}} every day.
245 ;" Then the LAST set (i.e. MVar.Food) will be returned in S
246 ;"
247 ;"Input:Text -- the string to operate on
248 ;" OpenBracket -- string with opening brackets (i.e. '(','{', '{{' etc.)
249 ;" CloseBracket -- string with close brackets (i.e. ')','}','}}' etc.)
250 ;" SBefore -- SHOULD BE PASSED BY REFERENCE... to receive results.
251 ;" S -- SHOULD BE PASSED BY REFERENCE... to receive results.
252 ;" SAfter -- SHOULD BE PASSED BY REFERENCE... to receive results.
253 ;"Output: SBefore -- returns all text up to innermost opening brackets, or "" if none
254 ;" S -- returns text INSIDE innermost brackets -- with brackets REMOVED, or "" if none
255 ;" SAfter -- returns all text after innermost opening brackets, or "" if none
256 ;" Text is NOT changed
257 ;" NOTE: Above vars must be passed by reference to recieve results.
258 ;"Results: 1=valid results returned in output vars.
259 ;" 0=No text found inside brackets, so output vars empty.
260
261 set SBefore="",S="",SAfter=""
262 new Result set Result=0
263
264 ;"do DebugEntry^TMGDEBUG(.DBIndent,"NestSplit")
265
266 if $data(Text)#10=0 goto QNSp
267 ;"do DebugMsg^TMGDEBUG(DBIndent,"Looking at '",Text,"'")
268 if ($data(OpenBracket)#10=0)!($data(CloseBracket)#10=0) goto QNSp
269 if '((Text[OpenBracket)&(Text[CloseBracket)) goto QNSp
270
271
272 ;"First we need to get the text after LAST instance of OpenBracket
273 ;"i.e. 'MVar.Num}}]}}' chased m from 'a big black {{Data.Section[{{MVar.Num}}]}} chased me'
274 new i set i=2
275 new part set part=""
276 new temp set temp=""
277NSL1 set temp=$piece(Text,OpenBracket,i)
278 if temp'="" do goto NSL1
279 . set part=temp
280 . set SBefore=$piece(Text,OpenBracket,1,i-1)
281 . set i=i+1
282
283 ;"do DebugMsg^TMGDEBUG(DBIndent,"First part is: ",SBefore)
284
285 ;"Now we find the text before the FIRST instance of CloseBracket
286 ;"i.e. 'MVar.Num' from 'MVar.Num}}]}} chased me'
287 ;"do DebugMsg^TMGDEBUG(DBIndent,"part=",part)
288 set S=$piece(part,CloseBracket,1)
289 set SAfter=$piece(part,CloseBracket,2,128)
290
291 ;"do DebugMsg^TMGDEBUG(DBIndent,"Main result is :",S)
292 ;"do DebugMsg^TMGDEBUG(DBIndent,"Part after result is: ",SAfter)
293
294 ;"If we got here, we are successful
295 set Result=1
296
297QNSp
298 ;"do DebugExit^TMGDEBUG(.DBIndent,"NestSplit")
299
300 quit Result
301
302
303Substitute(S,Match,NewValue)
304 ;"PUBLIC FUNCTION
305 ;"Purpose: to look for all instances of Match in S, and replace with NewValue
306 ;"Input: S - string to alter. Altered if passed by reference
307 ;" Match -- the sequence to look for, i.e. '##'
308 ;" NewValue -- what to replace Match with, i.e. '$$'
309 ;"Note: This is different than $translate, as follows
310 ;" $translate("ABC###DEF","###","$") --> "ABC$$$DEF"
311 ;" Substitute("ABC###DEF","###","$") --> "ABC$DEF"
312 ;"Result: returns altered string (if any alterations indicated)
313 ;"Output: S is altered, if passed by reference.
314
315 new spec
316 set spec($get(Match))=$get(NewValue)
317 set S=$$REPLACE^XLFSTR(S,.spec)
318
319 quit S
320
321
322FormatArray(InArray,OutArray,Divider)
323 ;"PUBLIC FUNCTION
324 ;"Purpose: The XML parser does not recognize whitespace, or end-of-line
325 ;" characters. Thus many lines get lumped together. However, if there
326 ;" is a significant amount of text, then the parser will put the text into
327 ;" several lines (when get attrib text called etc.)
328 ;" SO, this function is to take an array composed of input lines (each
329 ;" with multiple sublines clumped together), and format it such that each
330 ;" line is separated in the array.
331 ;" e.g. Take this input array"
332 ;" InArray(cText,1)="line one\nline two\nline three\n
333 ;" InArray(cText,2)="line four\nline five\nline six\n
334 ;" and convert to:
335 ;" OutArray(1)="line one"
336 ;" OutArray(2)="line two"
337 ;" OutArray(3)="line three"
338 ;" OutArray(4)="line four"
339 ;" OutArray(5)="line five"
340 ;" OutArray(6)="line six"
341 ;"Input: InArray, best if passed by reference (faster) -- see example above
342 ;" Note: expected to be in format: InArray(cText,n)
343 ;" OutArray, must be passed by reference-- see example above
344 ;" Divider: the character(s) that divides lines ("\n" in this example)
345 ;"Note: It is expected that InArray will be index by integers (i.e. 1, 2, 3)
346 ;" And this should be the case, as that is how XML functions pass back.
347 ;" Limit of 256 separate lines on any one InArray line
348 ;"Output: OutArray is set, any prior data is killed
349 ;"result: 1=OK to continue, 0=abort
350
351 set DEBUG=$get(DEBUG,0)
352 set cOKToCont=$get(cOKToCont,1)
353 set cAbort=$get(cAbort,0)
354
355 if DEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"FormatArray")
356
357 new result set result=cOKToCont
358 new InIndex
359 new OutIndex set OutIndex=1
360 new TempArray
361 new Done
362
363 kill OutArray ;"remove any prior data
364
365 if DEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Input array:")
366 if DEBUG do ArrayDump^TMGDEBUG("InArray")
367
368 if $data(Divider)=0 do goto FADone
369 . set result=cAbort
370
371 set Done=0
372 for InIndex=1:1 do quit:Done
373 . if $data(InArray(cText,InIndex))=0 set Done=1 quit
374 . if DEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Converting line: ",InArray(cText,InIndex))
375 . do CleaveToArray^TMGSTUTL(InArray(cText,InIndex),Divider,.TempArray,OutIndex)
376 . if DEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Resulting temp array:")
377 . if DEBUG do ArrayDump^TMGDEBUG("TempArray")
378 . set OutIndex=TempArray(cMaxNode)+1
379 . kill TempArray(cMaxNode)
380 . merge OutArray=TempArray
381 . if DEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"OutArray so far:")
382 . if DEBUG do ArrayDump^TMGDEBUG("OutArray")
383
384FADone
385 if DEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"FormatArray")
386 quit result
387
388
389
390TrimL(S,TrimCh)
391 ;"Purpose: To a trip a string of leading white space
392 ;" i.e. convert " hello" into "hello"
393 ;"Input: S -- the string to convert. Won't be changed if passed by reference
394 ;" TrimCh -- OPTIONAL: Charachter to trim. Default is " "
395 ;"Results: returns modified string
396 ;"Note: processing limitation is string length=1024
397
398 set DEBUG=$get(DEBUG,0)
399 set cOKToCont=$get(cOKToCont,1)
400 set cAbort=$get(cAbort,0)
401 set TrimCh=$get(TrimCh," ")
402
403 new result set result=$get(S)
404 new Ch set Ch=""
405 for do quit:(Ch'=TrimCh)
406 . set Ch=$extract(result,1,1)
407 . if Ch=TrimCh set result=$extract(result,2,1024)
408
409 quit result
410
411
412TrimR(S,TrimCh)
413 ;"Purpose: To a trip a string of trailing white space
414 ;" i.e. convert "hello " into "hello"
415 ;"Input: S -- the string to convert. Won't be changed if passed by reference
416 ;" TrimCh -- OPTIONAL: Charachter to trim. Default is " "
417 ;"Results: returns modified string
418 ;"Note: processing limitation is string length=1024
419
420 set DEBUG=$get(DEBUG,0)
421 set cOKToCont=$get(cOKToCont,1)
422 set cAbort=$get(cAbort,0)
423 set TrimCh=$get(TrimCh," ")
424
425 if DEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"TrimR")
426
427 new result set result=$get(S)
428 new Ch set Ch=""
429 new L
430
431 for do quit:(Ch'=TrimCh)
432 . set L=$length(result)
433 . set Ch=$extract(result,L,L)
434 . if Ch=TrimCh do
435 . . set result=$extract(result,1,L-1)
436
437 if DEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"TrimR")
438 quit result
439
440Trim(S,TrimCh)
441 ;"Purpose: To a trip a string of leading and trailing white space
442 ;" i.e. convert " hello " into "hello"
443 ;"Input: S -- the string to convert. Won't be changed if passed by reference
444 ;" TrimCh -- OPTIONAL: Charachter to trim. Default is " "
445 ;"Results: returns modified string
446 ;"Note: processing limitation is string length=1024
447
448 ;"NOTE: this function could be replaced with $$TRIM^XLFSTR
449
450 set DEBUG=$get(DEBUG,0)
451 set cOKToCont=$get(cOKToCont,1)
452 set cAbort=$get(cAbort,0)
453 set TrimCh=$get(TrimCh," ")
454
455 if DEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"Trim")
456
457 new result set result=$get(S)
458 set result=$$TrimL(.result,TrimCh)
459 set result=$$TrimR(.result,TrimCh)
460
461 if DEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"Trim")
462 quit result
463
464TrimRType(S,type)
465 ;"Scope: PUBLIC FUNCTION
466 ;"Purpose: trim characters on the right of the string of a specified type.
467 ;" Goal, to be able to distinguish between numbers and strings.
468 ;" i.e. "1234<=" --> "1234" by trimming strings
469 ;"Input: S -- The string to work on
470 ;" type -- the type of characters to TRIM: N for numbers,C for non-numbers (characters)
471 ;"Results : modified string
472
473 set tempS=$get(S)
474 set type=$$UP^XLFSTR($get(type)) goto:(type="") TRTDone
475 new done set done=0
476 for quit:(tempS="")!done do
477 . new c set c=$extract(tempS,$length(tempS))
478 . new cType set cType="C"
479 . if +c=c set cType="N"
480 . if type["N" do
481 . . if cType="N" set tempS=$extract(tempS,1,$length(tempS)-1) quit
482 . . set done=1
483 . else if type["C" do
484 . . if cType="C" set tempS=$extract(tempS,1,$length(tempS)-1) quit
485 . . set done=1
486 . else set done=1
487
488TRTDone quit tempS
489
490NumLWS(S)
491 ;"Scope: PUBLIC FUNCTION
492 ;":Purpose: To count the number of white space characters on the left
493 ;" side of the string
494
495 new result set result=0
496 new i,ch
497 set S=$get(S)
498
499 for i=1:1:$length(S) do quit:(ch'=" ")
500 . set ch=$extract(S,i,i)
501 . if ch=" " set result=result+1
502
503 quit result
504
505
506MakeWS(n)
507 ;"Scope: PUBLIC FUNCTION
508 ;"Purpose: Return a whitespace string that is n characters long
509
510 new result set result=""
511 set n=$get(n,0)
512 if n'>0 goto MWSDone
513
514 new i
515 for i=1:1:n set result=result_" "
516
517MWSDone
518 quit result
519
520
521WordWrapArray(Array,Width,SpecialIndent)
522 ;"Scope: PUBLIC FUNCTION
523 ;"Purpose: To take an array and perform word wrapping such that
524 ;" no line is longer than Width.
525 ;" This function is really designed for reformatting a Fileman WP field
526 ;"Input: Array MUST BE PASSED BY REFERENCE. This contains the array
527 ;" to be reformatted. Changes will be made to this array.
528 ;" It is expected that Array will be in this format:
529 ;" Array(1)="Some text on the first line."
530 ;" Array(2)="Some text on the second line."
531 ;" Array(3)="Some text on the third line."
532 ;" Array(4)="Some text on the fourth line."
533 ;" or
534 ;" Array(1,0)="Some text on the first line."
535 ;" Array(2,0)="Some text on the second line."
536 ;" Array(3,0)="Some text on the third line."
537 ;" Array(4,0)="Some text on the fourth line."
538 ;" Width -- the limit on the length of any line. Default value=70
539 ;" SpecialIndent : if 1, then wrapping is done like this:
540 ;" " This is a very long line......"
541 ;" will be wrapped like this:
542 ;" " This is a very
543 ;" " long line ...
544 ;" Notice that the leading space is copied subsequent line.
545 ;" Also, a line like this:
546 ;" " 1. Here is the beginning of a paragraph that is very long..."
547 ;" will be wrapped like this:
548 ;" " 1. Here is the beginning of a paragraph
549 ;" " that is very long..."
550 ;" Notice that a pattern '#. ' causes the wrapping to match the start of
551 ;" of the text on the line above.
552 ;" The exact rules for matching this are as follows:
553 ;" (FirstWord?.N1".")!(FirstWord?1.3E1".")
554 ;" i.e. any number of digits, followed by "."
555 ;" OR 1-4 all upper-case characters followed by a "."
556 ;" This will allow "VIII. " pattern but not "viii. "
557 ;" HOWEVER, might get confused with a word, like "NOTE. "
558 ;"
559 ;" This, below, is not dependant on SpecialIndent setting
560 ;" Also, because some of the lines have already partly wrapped, like this:
561 ;" " 1. Here is the beginning of a paragraph that is very long..."
562 ;" "and this is a line that has already wrapped.
563 ;" So when the first line is wrapped, it would look like this:
564 ;" " 1. Here is the beginning of a paragraph
565 ;" " that is very long..."
566 ;" "and this is a line that has already wrapped.
567 ;" But is should look like this:
568 ;" " 1. Here is the beginning of a paragraph
569 ;" " that is very long...and this is a line
570 ;" " that has already wrapped.
571 ;" But the next line SHOULD NOT be pulled up if it is the start
572 ;" of a new paragraph. I will tell by looking for #. paattern.
573
574
575 ;"Result -- none
576
577 if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"WordWrapArray^TMGSTUTL")
578 new tempArray set tempArray="" ;"holds result during work.
579 new tindex set tindex=0
580 new index
581 set index=$order(Array(""))
582 new s
583 new residualS set residualS=""
584 new AddZero set AddZero=0
585 set Width=$get(Width,70)
586
587 if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Starting loop")
588
589 if index'="" for do quit:((index="")&(residualS=""))
590 . set s=$get(Array(index))
591 . if s="" do
592 . . set s=$get(Array(index,0))
593 . . set AddZero=1
594 . if residualS'="" do ;"See if should join to next line. Don't if '#. ' pattern
595 . . new FirstWord set FirstWord=$piece($$Trim(s)," ",1)
596 . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"First Word: ",FirstWord)
597 . . if (FirstWord?.N1".")!(FirstWord?1.4U1".") do ;"match for '#.' pattern
598 . . . ;"Here we have the next line is a new paragraph, so don't link to residualS
599 . . . set tindex=tindex+1
600 . . . if AddZero=0 set tempArray(tindex)=residualS
601 . . . else set tempArray(tindex,0)=residualS
602 . . . set residualS=""
603 . if $length(residualS)+$length(s)'<256 do
604 . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"ERROR -- string too long.")
605 . set s=residualS_s
606 . set residualS=""
607 . if $length(s)>Width do
608 . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Long line: ",s)
609 . . new LineArray
610 . . new NumLines
611 . . set NumLines=$$SplitLine(.s,.LineArray,Width,.SpecialIndent)
612 . . if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("LineArray")
613 . . set s=""
614 . . new LineIndex
615 . . for LineIndex=1:1:NumLines do
616 . . . set tindex=tindex+1
617 . . . if AddZero=0 set tempArray(tindex)=LineArray(LineIndex)
618 . . . else set tempArray(tindex,0)=LineArray(LineIndex)
619 . . ;"long wrap probably continues into next paragraph, so link together.
620 . . if NumLines>2 do
621 . . . if AddZero=0 set residualS=tempArray(tindex) set tempArray(tindex)=""
622 . . . else set residualS=tempArray(tindex,0) set tempArray(tindex,0)=""
623 . . . set tindex=tindex-1
624 . else do
625 . . set tindex=tindex+1
626 . . if AddZero=0 set tempArray(tindex)=s
627 . . else set tempArray(tindex,0)=s
628 . set index=$order(Array(index))
629 else do
630 . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Array appears empty")
631
632
633 kill Array
634 merge Array=tempArray
635
636 if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("Array")
637
638 if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent," WordWrapArray^TMGSTUTL")
639 quit
640
641
642SplitLine(s,LineArray,Width,SpecialIndent,Indent)
643 ;"Scope: PUBLIC FUNCTION
644 ;"Purpose: To take a long line, and wrap into an array, such that each
645 ;" line is not longer than Width.
646 ;" Line breaks will be made at spaces, unless there are no spaces in
647 ;" the entire line (in which case, the line will be divided at Width).
648 ;"Input: s= string with the long line. **If passed by reference**, then
649 ;" it WILL BE CHANGED to equal the last line of array.
650 ;" LineArray -- MUST BE PASSED BY REFERENCE. This OUT variable will
651 ;" receive the resulting array.
652 ;" Width = the desired wrap width.
653 ;" SpecialIndent [OPTIONAL]: if 1, then wrapping is done like this:
654 ;" " This is a very long line......"
655 ;" will be wrapped like this:
656 ;" " This is a very
657 ;" " long line ...
658 ;" Notice that the leading space is copied subsequent line.
659 ;" Also, a line like this:
660 ;" " 1. Here is the beginning of a paragraph that is very long..."
661 ;" will be wrapped like this:
662 ;" " 1. Here is the beginning of a paragraph
663 ;" " that is very long..."
664 ;" Notice that a pattern '#. ' causes the wrapping to match the start
665 ;" of the text on the line above.
666 ;" Indent [OPTIONAL]: Any absolute amount that all lines should be indented by.
667 ;" This could be used if this long line is continuation of an
668 ;" indentation above it.
669 ;"Result: resulting number of lines (1 if no wrap needed).
670
671 if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"SplitLine")
672
673 new result set result=0
674 kill LineArray
675 if ($get(s)="")!($get(Width)'>0) goto SPDone
676 new index set index=0
677 new p,tempS,splitPoint
678
679 new PreSpace set PreSpace=$$NeededWS(s,.SpecialIndent,.Indent)
680
681 if ($length(s)>Width) for do quit:($length(s)'>Width)
682 . for splitPoint=1:1:Width do quit:($length(tempS)>Width)
683 . . set tempS=$piece(s," ",1,splitPoint)
684 . . ;"write "tempS>",tempS,!
685 . if splitPoint>1 do
686 . . set tempS=$piece(s," ",1,splitPoint-1)
687 . . set s=$piece(s," ",splitPoint,Width)
688 . else do
689 . . ;"We must have a word > Width with no spaces--so just divide
690 . . set tempS=$extract(s,1,Width)
691 . . set s=$extract(s,Width+1,999)
692 . set index=index+1
693 . set LineArray(index)=tempS
694 . set s=PreSpace_s
695 . ;"write "tempS>",tempS,!
696 . ;"write "s>",s,!
697
698 set index=index+1
699 set LineArray(index)=s
700
701 set result=index
702
703SPDone
704 if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"SplitLine")
705 quit result
706
707
708
709NeededWS(S,SpecialIndent,Indent)
710 ;"Scope: PRIVATE
711 ;"Purpose: Evaluate the line, and create the white space string
712 ;" need for wrapped lines
713 ;"Input: s -- the string to eval. i.e.
714 ;" " John is very happy today ... .. .. .. .."
715 ;" or " 1. John is very happy today ... .. .. .. .."
716 ;" SpecialIndent -- See SplitLine() discussion
717 ;" Indent -- See SplitLine() discussion
718
719 new result set result=""
720 if $get(S)="" goto NdWSDone
721
722 new WSNum
723 set WSNum=+$get(Indent,0)
724 set WSNum=WSNum+$$NumLWS(S)
725
726 if $get(SpecialIndent)=1 do
727 . new ts,FirstWord
728 . set ts=$$TrimL(.S)
729 . set FirstWord=$piece(ts," ",1)
730 . if (FirstWord?.N1".")!(FirstWord?1.4U1".") do ;"match for '#.' pattern
731 . . set WSNum=WSNum+$length(FirstWord)
732 . . set ts=$piece(ts," ",2,9999)
733 . . set WSNum=WSNum+$$NumLWS(.ts)+1
734
735 set result=$$MakeWS(WSNum)
736
737NdWSDone
738 quit result
739
740
741WriteWP(NodeRef)
742 ;"Purpose: Given a reference to a WP field, this function will print it out.
743 ;"INput: NodeRef -- the name of the node to print out.
744 ;" For example, "^PS(50.605,1,1)"
745 ;"Modification: 2/10/06 -- I removed need for @NodeRef@(0) to contain data.
746
747 new i
748 ;"if $get(@NodeRef@(0))="" goto WWPDone
749 set i=$order(@NodeRef@(0))
750 if i'="" for do quit:(i="")
751 . new OneLine
752 . set OneLine=$get(@NodeRef@(i))
753 . if OneLine="" set OneLine=$get(@NodeRef@(i,0))
754 . write OneLine,!
755 . set i=$order(@NodeRef@(i))
756
757WWPDone quit
758
759
760LPad(S,width)
761 ;"Purpose: To add space ("pad") string S such that final width is per specified with.
762 ;" space is added to left side of string
763 ;"Input: S : the string to pad.
764 ;" width : the desired final width
765 ;"result: returns resulting string
766 ;"Example: LPad("$5.23",7)=" $5.23"
767
768 quit $$RJ^XLFSTR(.S,.width," ")
769
770RPad(S,width)
771 ;"Purpose: To add space ("pad") string S such that final width is per specified with.
772 ;" space is added to right side of string
773 ;"Input: S : the string to pad.
774 ;" width : the desired final width
775 ;"result: returns resulting string
776 ;"Example: RPad("$5.23",7)="$5.23 "
777
778 quit $$LJ^XLFSTR(.S,.width," ")
779
780Center(S,width)
781 ;"Purpose: to return a center justified string
782
783 quit $$CJ^XLFSTR(.S,.width," ")
784
785Clip(S,width)
786 ;"Purpose: to ensure that string S is no longer than width
787
788 new result set result=$get(S)
789 if result'="" set result=$extract(S,1,width)
790ClipDone
791 quit result
792
793
794STRB2H(s,F,noSpace)
795 ;"Convert a string to hex characters)
796 ;"Input: s -- the input string (need not be ascii characters)
797 ;" F -- (optional) if F>0 then will append an ascii display of string.
798 ;" noSpace -- (Optional) if >0 then characters NOT separated by spaces
799 ;"result -- the converted string
800
801 new i,ch
802 new result set result=""
803
804 for i=1:1:$length(s) do
805 . set ch=$extract(s,i)
806 . set result=result_$$HEXCHR^TMGMISC($ascii(ch))
807 . if +$get(noSpace)=0 set result=result_" "
808
809 if $get(F)>0 set result=result_" "_$$HIDECTRLS^TMGSTUTL(s)
810 quit result
811
812
813HIDECTRLS(s)
814 ;"hide all unprintable characters from a string
815 new i,ch,byte
816 new result set result=""
817 for i=1:1:$length(s) do
818 . set ch=$e(s,i)
819 . set byte=$ascii(ch)
820 . if (byte<32)!(byte>122) set result=result_"."
821 . else set result=result_ch
822
823 quit result
824
825
826
827CapWords(S,Divider)
828 ;"Purpose: convert each word in the string: 'test string' --> 'Test String', 'TEST STRING' --> 'Test String'
829
830 ;"Input: S -- the string to convert
831 ;" Divider -- [OPTIONAL] the character used to separate string (default is ' ' [space])
832 ;"Result: returns the converted string
833
834 new s2,part
835 new result set result=""
836 set Divider=$get(Divider," ")
837
838 set s2=$$LOW^XLFSTR(S)
839
840 for i=1:1 do quit:part=""
841 . set part=$piece(s2,Divider,i)
842 . if part="" quit
843 . set $extract(part,1)=$$UP^XLFSTR($extract(part,1))
844 . if result'="" set result=result_Divider
845 . set result=result_part
846
847 quit result
848
849
850LinuxStr(S)
851 ;"Purpose: convert string to a valid linux filename
852 ;" e.g. 'File Name' --> 'File\ Name'
853
854 quit $$Substitute(.S," ","\ ")
855
856
857
858NiceSplit(S,Len,s1,s2,s2Min,DivCh)
859 ;"Purpose: to split S into two strings, s1 & s2
860 ;" Furthermore, s1's length must be <= length.
861 ;" and the split will be made at spaces
862 ;"Input: S -- the string to split
863 ;" Len -- the length limit of s1
864 ;" s1 -- PASS BY REFERENCE, an OUT parameter
865 ;" receives first part of split
866 ;" s2 -- PASS BY REFERENCE, an OUT parameter
867 ;" receives the rest of string
868 ;" s2Min -- OPTIONAL -- the minimum that
869 ;" length of s2 can be. Note, if s2
870 ;" is "", then this is not applied
871 ;" DivCH -- OPTIONAL, default is " ".
872 ;" This is the character to split words by
873 ;"Output: s1 and s2 is filled with data
874 ;"Result: none
875
876 set (s1,s2)=""
877 if $get(DivCh)="" set DivCh=" "
878
879 if $length(S)'>Len do goto NSpDone
880 . set s1=S
881
882 new i
883 new done
884 for i=200:-1:1 do quit:(done)
885 . set s1=$piece(S,DivCh,1,i)_DivCh
886 . set s2=$piece(S,DivCh,i+1,999)
887 . set done=($length(s1)'>Len)
888 . if done,+$get(s2Min)>0 do
889 . . if s2="" quit
890 . . set done=($length(s2)'<s2Min)
891
892NSpDone quit
893
894
895StrToWP(s,pArray,width,DivCh,InitLine)
896 ;"Purpose: to take a long string and wrap it into formal WP format
897 ;"Input: s: the long string to wrap into the WP field
898 ;" pArray: the NAME of the array to put output into.
899 ;" Any pre-existing data in this array will NOT be killed
900 ;" width: OPTIONAL -- the width to target for word wrapping. Default is 60
901 ;" DivCh: OPTIONAL -- the character to use separate words (to allow nice wrapping). Default is " "
902 ;" InitLine: OPTIONAL -- the line to start putting data into. Default is 1
903 ;"Output: pArray will be filled as follows:
904 ;" @pArray@(InitLine+0)=line 1
905 ;" @pArray@(InitLine+1)=line 2
906 ;" @pArray@(InitLine+2)=line 3
907
908 if +$get(width)=0 set width=60
909 if $get(DivCh)="" set DivCh=" "
910 new tempS set tempS=$get(s)
911 if $get(InitLine)="" set InitLine=1
912 new curLine set curLine=+InitLine
913 ;"kill @pArray
914
915 for do quit:(tempS="")
916 . new s1,s2
917 . do NiceSplit(tempS,width,.s1,.s2,,DivCh)
918 . set @pArray@(curLine)=s1
919 . set curLine=curLine+1
920 . set tempS=s2
921
922 quit
923
924
925WPToStr(pArray,DivCh,MaxLen,InitLine)
926 ;"Purpose: This is the opposite of StrToWP. It takes a WP field, and concatenates
927 ;" each line to make one long string.
928 ;"Input: pArray: the NAME of the array to get WP lines from. Expected format as follows
929 ;" @pArray@(InitLine+0)=line 1
930 ;" @pArray@(InitLine+1)=line 2
931 ;" @pArray@(InitLine+2)=line 3
932 ;" -or-
933 ;" @pArray@(InitLine+0,0)=line 1
934 ;" @pArray@(InitLine+1,0)=line 2
935 ;" @pArray@(InitLine+2,0)=line 3
936 ;" DivCh: OPTIONAL, default is " ". This character is appended to the end of each line, e.g
937 ;" output=output_line1_DivCh_line2
938 ;" MaxLen: OPTIONAL, default=255. The maximum allowable length of the resulting string.
939 ;" InitLine: OPTIONAL -- the line in pArray to start reading data from. Default is 1
940 ;"result: Returns one long string representing the WP array
941
942 new i,OneLine,result,Len
943 set i=$get(InitLine,1)
944 set result=""
945 set DivCh=$get(DivCh," ")
946 set MaxLen=$get(MaxLen,255)
947 set Len=0
948
949 for do quit:(OneLine="")!(Len'<MaxLen)!(+i'>0)
950 . set OneLine=$get(@pArray@(i))
951 . if OneLine="" set OneLine=$get(@pArray@(i,0))
952 . if OneLine="" quit
953 . set Len=$length(result)+$length(DivCh)
954 . if Len+$length(OneLine)>MaxLen do
955 . . set OneLine=$extract(OneLine,1,(MaxLen-Len))
956 . set result=result_OneLine_DivCh
957 . set Len=Len+$length(OneLine)
958 . set i=$order(@pArray@(i))
959
960 quit result;
961
962
963Comp2Strs(s1,s2)
964 ;"Purpose: To compare two strings and assign an arbritrary score to their similarity
965 ;"Input: s1,s2 -- The two strings to compare
966 ;"Result: a score comparing the two strings
967 ;" 0.5 point for every word in s1 that is also in s2 (case specific)
968 ;" 0.25 point for every word in s1 that is also in s2 (not case specific)
969 ;" 0.5 point for every word in s2 that is also in s1 (case specific)
970 ;" 0.25 point for every word in s2 that is also in s1 (not case specific)
971 ;" 1 points if same number of words in string (compared each way)
972 ;" 2 points for each word that is in the same position in each string (case specific)
973 ;" 1.5 points for each word that is in the same position in each string (not case specific)
974
975 new score set score=0
976 new Us1 set Us1=$$UP^XLFSTR(s1)
977 new Us2 set Us2=$$UP^XLFSTR(s2)
978
979 new i
980 for i=1:1:$length(s1," ") do
981 . if s2[$piece(s1," ",i) set score=score+0.5
982 . else if Us2[$piece(Us1," ",i) set score=score+0.25
983 . if $piece(s1," ",i)=$piece(s2," ",i) set score=score+1
984 . else if $piece(Us1," ",i)=$piece(Us2," ",i) set score=score+1.5
985
986 for i=1:1:$length(s2," ") do
987 . if s1[$piece(s2," ",i) set score=score+0.5
988 . else if Us1[$piece(Us2," ",i) set score=score+0.25
989 . if $piece(s1," ",i)=$piece(s2," ",i) set score=score+1
990 . else if $piece(Us1," ",i)=$piece(Us2," ",i) set score=score+1.5
991
992 if $length(s1," ")=$length(s2," ") set score=score+2
993
994 quit score
995
996
997PosNum(s,Num,LeadingSpace)
998 ;"Purpose: To return the position of the first Number in a string
999 ;"Input: S -- string to check
1000 ;" Num -- OPTIONAL, default is 0-9 numbers. number to look for.
1001 ;" LeadingSpace -- OPTIONAL. If 1 then looks for " #" or " .#", not just "#"
1002 ;"Results: -1 if not found, otherwise position of found digit.
1003
1004 new result set result=-1
1005 new Leader set Leader=""
1006 if $get(LeadingSpace)=1 set Leader=" "
1007
1008 if $get(Num) do goto PNDone
1009 . set result=$find(s,Leader_Num)-1
1010
1011 new temp,i,decimalFound
1012 for i=0:1:9 do
1013 . set decimalFound=0
1014 . set temp=$find(s,Leader_i)
1015 . if (temp=0)&(Leader'="") do
1016 . . set temp=$find(s,Leader_"."_i)
1017 . . if temp>-1 set decimalFound=1
1018 . if temp>-1 set temp=temp-$length(Leader_i)
1019 . if decimalFound set temp=temp-1
1020 . if (temp>0)&((temp<result)!(result=-1)) set result=temp
1021
1022PNDone
1023 if (result>0)&(Leader=" ") set result=result+1
1024 quit result
1025
1026
1027IsNumeric(s)
1028 ;"Purpose: To deterimine if word s is a numeric
1029 ;" Examples of numeric words:
1030 ;" 10, N-100, 0.5%, 50000UNT/ML
1031 ;" the test will be if the word contains any digit 0-9
1032 ;"Results: 1 if is a numeric word, 0 if not.
1033
1034 quit ($$PosNum(.s)>0)
1035
1036
1037ScrubNumeric(s)
1038 ;"Purpose: This is a specialty function designed to remove numeric words
1039 ;" from a sentence. E.g.
1040 ;" BELLADONNA ALK 0.3/PHENOBARB 16MG CHW TB --> BELLADONNA ALK /PHENOBARB CHW TB
1041 ;" ESTROGENS,CONJUGATED 2MG/ML INJ (IN OIL) --> ESTROGENS,CONJUGATED INJ (IN OIL)
1042
1043 new Array,i,result
1044 set s=$$Substitute(s,"/MG","")
1045 set s=$$Substitute(s,"/ML","")
1046 set s=$$Substitute(s,"/"," / ")
1047 set s=$$Substitute(s,"-"," - ")
1048 do CleaveToArray(s," ",.Array)
1049 new ToKill
1050 set i=0 for set i=$order(Array(i)) quit:+i'>0 do
1051 . if (Array(i)="MG")&($get(ToKill(i-1))=1) set ToKill(i)=1 quit
1052 . if (Array(i)="MCG")&($get(ToKill(i-1))=1) set ToKill(i)=1 quit
1053 . if (Array(i)="MEQ")&($get(ToKill(i-1))=1) set ToKill(i)=1 quit
1054 . if (Array(i)="%")&($get(ToKill(i-1))=1) set ToKill(i)=1 quit
1055 . if (Array(i)="MM")&($get(ToKill(i-1))=1) set ToKill(i)=1 quit
1056 . if $$IsNumeric(Array(i))=0 quit
1057 . set ToKill(i)=1
1058 . new tempS set tempS=$get(Array(i-1))
1059 . if (tempS="/")!(tempS="-") set ToKill(i-1)=1
1060 . if (tempS="NO")!(tempS="#") set ToKill(i-1)=1
1061
1062 set i=0 for set i=$order(Array(i)) quit:+i'>0 do
1063 . if $get(ToKill(i))=1 kill Array(i)
1064
1065 set i="",result=""
1066 for set i=$order(Array(i)) quit:+i'>0 do
1067 . set result=result_Array(i)_" "
1068
1069 set result=$$Trim(result)
1070 set result=$$Substitute(result," / ","/")
1071 set result=$$Substitute(result," - ","-")
1072
1073 quit result
1074
1075
1076Pos(subStr,s,count)
1077 ;"Purpose: return the beginning position of subStr in s
1078 ;"Input: subStr -- the string to be searched for in s
1079 ;" s -- the string to search
1080 ;" count -- OPTIONAL, the instance to return pos of (1=1st, 2=2nd, etc.)
1081 ;" if count=2 and only 1 instance exists, then 0 returned
1082 ;"Result: the beginning position, or 0 if not found
1083 ;"Note: This function differs from $find in that $find returns the pos of the
1084 ;" first character AFTER the subStr
1085
1086 set count=$get(count,1)
1087 new result set result=0
1088 new instance set instance=1
1089PS1
1090 set result=$find(s,subStr,result+1)
1091 if result>0 set result=result-$length(subStr)
1092 if count>instance set instance=instance+1 goto PS1
1093
1094 quit result
1095
1096
1097ArrayPos(array,s)
1098 ;"Purpose: return the index position of s in array
1099
1100 ;"...
1101
1102 quit
1103
1104DiffPos(s1,s2)
1105 ;"Purpose: Return the position of the first difference between s1 and s2
1106 ;"Input -- s1, s2 : The strings to compare.
1107 ;"result: the position (in s1) of the first difference, or 0 if no difference
1108
1109 new l set l=$length(s1)
1110 if $length(s2)>l set l=$length(s2)
1111 new done set done=0
1112 new i for i=1:1:l do quit:(done=1)
1113 . set done=($extract(s1,1,i)'=$extract(s2,1,i))
1114 new result set result=0
1115 if done=1 set result=i
1116 quit result
1117
1118
1119DiffWPos(Words1,Words2)
1120 ;"Purpose: Return the index of the first different word between Words arrays
1121 ;"Input: Words1,Words2 -- the array of words, such as would be made
1122 ;" by CleaveToArray^TMGSTUTL
1123 ;"Returns: Index of first different word in Words1, or 0 if no difference
1124
1125 new l set l=+$get(Words1("MAXNODE"))
1126 if +$get(Words2("MAXNODE"))>l set l=+$get(Words2("MAXNODE"))
1127 new done set done=0
1128 new i for i=1:1:l do quit:(done=1)
1129 . set done=($get(Words1(i))'=$get(Words2(i)))
1130 new result
1131 if done=1 set result=i
1132 else set result=0
1133 quit result
1134
1135
1136SimStr(s1,p1,s2,p2)
1137 ;"Purpose: return the matching string in both s1 and s2, starting
1138 ;" at positions p1 and p2.
1139 ;" Example: s1='Tom is 12 years old', p1=7
1140 ;" s2='Bill will be 12 years young tomorrow' p2=13
1141 ;" would return ' 12 years '
1142
1143 new ch1,ch2,offset,result,done
1144 set result="",done=0
1145 for offset=0:1:9999 do quit:(done=1)
1146 . set ch1=$extract(s1,p1+offset)
1147 . set ch2=$extract(s2,p2+offset)
1148 . if (ch1=ch2) set result=result_ch1
1149 . else set done=1
1150 quit result
1151
1152
1153SimWord(Words1,p1,Words2,p2)
1154 ;"Purpose: return the matching words in both words array 1 and 2, starting
1155 ;" at word positions p1 and p2. This function is different from
1156 ;" SimStr in that it works with whole words
1157 ;" Example:
1158 ;" Words1(1)=Tom Words2(1)=Bill
1159 ;" Words1(2)=is Words2(2)=will
1160 ;" Words1(3)=12 Words2(3)=be
1161 ;" Words1(4)=years Words2(4)=12
1162 ;" Words1(5)=old Words2(5)=years
1163 ;" Words1("MAXNODE")=5 Words2(6)=young
1164 ;" Words2(7)=tomorrow
1165 ;" Words1("MAXNODE")=7
1166 ;" This will return 3, (where '12 years' starts)
1167 ;" if p1=3 and p2=4 would return '12 years'
1168 ;"Note: A '|' will be used as word separator when constructing result
1169 ;"Input: Words1,Words2 -- the array of words, such as would be made
1170 ;" by CleaveToArray^TMGSTUTL. e.g.
1171 ;" p1,p2 -- the index of the word in Words array to start with
1172 ;"result: (see example)
1173
1174 new w1,w2,offset,result,done
1175 set result="",done=0
1176 for offset=0:1:$get(Words1("MAXNODE")) do quit:(done=1)
1177 . set w1=$get(Words1(offset+p1))
1178 . set w2=$get(Words2(offset+p2))
1179 . if (w1=w2)&(w1'="") do
1180 . . if (result'="") set result=result_"|"
1181 . . set result=result_w1
1182 . else set done=1
1183 quit result
1184
1185
1186SimPos(s1,s2,DivStr,pos1,pos2,MatchStr)
1187 ;"Purpose: return the first position that two strings are similar. This means
1188 ;" the first position in string s1 that characters match in s2. A
1189 ;" match will be set to mean 3 or more characters being the same.
1190 ;" Example: s1='Tom is 12 years old'
1191 ;" s2='Bill will be 12 years young tomorrow'
1192 ;" This will return 7, (where '12 years' starts)
1193 ;"Input: s1,s2 -- the two strings to compare
1194 ;" DivStr -- OPTIONAL, the character to use to separate the answers
1195 ;" in the return string. Default is '^'
1196 ;" pos1 -- OPTIONAL, an OUT PARAMETER. Returns Pos1 from result
1197 ;" pos2 -- OPTIONAL, an OUT PARAMETER. Returns Pos2 from result
1198 ;" MatchStr -- OPTIONAL, an OUT PARAMETER. Returns MatchStr from result
1199 ;"Results: Pos1^Pos2^MatchStr Pos1=position in s1, Pos2=position in s2,
1200 ;" MatchStr=the matching Str
1201
1202 set DivStr=$get(DivStr,"^")
1203 new startPos,subStr,found,s2Pos
1204 set found=0,s2Pos=0
1205 for startPos=1:1:$length(s1) do quit:(found=1)
1206 . set subStr=$extract(s1,startPos,startPos+3)
1207 . set s2Pos=$$Pos(subStr,s2)
1208 . set found=(s2Pos>0)
1209
1210 new result
1211 if found=1 do
1212 . set pos1=startPos,pos2=s2Pos
1213 . set MatchStr=$$SimStr(s1,startPos,s2,s2Pos)
1214 else do
1215 . set pos1=0,pos2=0,MatchStr=""
1216
1217 set result=pos1_DivStr_pos2_DivStr_MatchStr
1218
1219 quit result
1220
1221
1222SimWPos(Words1,Words2,DivStr,p1,p2,MatchStr)
1223 ;"Purpose: return the first position that two word arrays are similar. This means
1224 ;" the first index in Words array 1 that matches to words in Words array 2.
1225 ;" A match will be set to mean the two words are equal
1226 ;" Example:
1227 ;" Words1(1)=Tom Words2(1)=Bill
1228 ;" Words1(2)=is Words2(2)=will
1229 ;" Words1(3)=12 Words2(3)=be
1230 ;" Words1(4)=years Words2(4)=12
1231 ;" Words1(5)=old Words2(5)=years
1232 ;" Words1("MAXNODE")=5 Words2(6)=young
1233 ;" Words2(7)=tomorrow
1234 ;" Words2("MAXNODE")=7
1235 ;" This will return 3, (where '12 years' starts)
1236 ;"Input: Words1,Words2 -- the two arrays to compare
1237 ;" DivStr -- OPTIONAL, the character to use to separate the answers
1238 ;" in the return string. Default is '^'
1239 ;" pos1 -- OPTIONAL, an OUT PARAMETER. Returns Pos1 from result
1240 ;" pos2 -- OPTIONAL, an OUT PARAMETER. Returns Pos2 from result
1241 ;" MatchStr -- OPTIONAL, an OUT PARAMETER. Returns MatchStr from result
1242 ;"Results: Pos1^Pos2^MatchStr Pos1=position in Words1, Pos2=position in Words2,
1243 ;" MatchStr=the first matching Word or phrase
1244 ;" Note: | will be used as a word separator for phrases.
1245
1246 set DivStr=$get(DivStr,"^")
1247 new startPos,word1,found,w2Pos
1248 set found=0,s2Pos=0
1249 for startPos=1:1:+$get(Words1("MAXNODE")) do quit:(found=1)
1250 . set word1=$get(Words1(startPos))
1251 . set w2Pos=$$IndexOf^TMGMISC($name(Words2),word1)
1252 . set found=(w2Pos>0)
1253
1254 if found=1 do
1255 . set p1=startPos,p2=w2Pos
1256 . set MatchStr=$$SimWord(.Words1,p1,.Words2,p2)
1257 else do
1258 . set p1=0,p2=0,MatchStr=""
1259
1260 new result set result=p1_DivStr_p2_DivStr_MatchStr
1261
1262 quit result
1263
1264
1265DiffStr(s1,s2,DivChr)
1266 ;"Purpose: Return how s1 differs from s2. E.g.
1267 ;" s1='Today was the birthday of Bill and John'
1268 ;" s2='Yesterday was the birthday of Tom and Sue'
1269 ;" results='Today^1^Bill^26^John^35'
1270 ;" This means that 'Today', starting at pos 1 in s1 differs
1271 ;" from s2. And 'Bill' starting at pos 26 differs from s2 etc..
1272 ;"Input: s1,s2 -- the two strings to compare
1273 ;" DivStr -- OPTIONAL, the character to use to separate the answers
1274 ;" in the return string. Default is '^'
1275 ;"Results: DiffStr1^pos1^DiffStr2^pos2^...
1276
1277 set DivChr=$get(DivChr,"^")
1278 new result set result=""
1279 new offset set offset=0
1280 new p1,p2,matchStr,matchLen
1281 new diffStr,temp
1282DSLoop
1283 set temp=$$SimPos(s1,s2,DivChr,.p1,.p2,.matchStr)
1284 ;"Returns: Pos1^Pos2^MatchStr Pos1=pos in s1, Pos2=pos in s2, MatchStr=the matching Str
1285 if p1=0 set:(s1'="") result=result_s1_DivChr_(+offset) goto DSDone
1286
1287 set matchLen=$length(matchStr)
1288
1289 if p1>1 do
1290 . set diffStr=$extract(s1,1,p1-1)
1291 . set result=result_diffStr_DivChr_(1+offset)_DivChr
1292 set offset=offset+(p1+matchLen-1)
1293 set s1=$extract(s1,p1+matchLen,9999) ;"trim s1
1294 set s2=$extract(s2,p2+matchLen,9999) ;"trim s2
1295 goto DSLoop
1296DSDone
1297 quit result
1298
1299
1300DiffWords(Words1,Words2,DivChr)
1301 ;"Purpose: Return how Word arrays Words1 differs from Words2. E.g.
1302 ;" Example:
1303 ;" Words1(1)=Tom Words2(1)=Bill
1304 ;" Words1(2)=is Words2(2)=will
1305 ;" Words1(3)=12 Words2(3)=be
1306 ;" Words1(4)=years Words2(4)=12
1307 ;" Words1(5)=old Words2(5)=years
1308 ;" Words1("MAXNODE")=5 Words2(6)=young
1309 ;" Words2(7)=tomorrow
1310 ;" Words1("MAXNODE")=7
1311 ;"
1312 ;" s1='Today was the birthday of Bill and John'
1313 ;" s2='Yesterday was the birthday of Tom and Sue'
1314 ;" results='Tom is^1^old^5'
1315 ;" This means that 'Tom is', starting at pos 1 in Words1 differs
1316 ;" from Words2. And 'old' starting at pos 5 differs from Words2 etc..
1317 ;"Input: Words1,Words2 -- PASS BY REFERENCE. The two word arrays to compare
1318 ;" DivStr -- OPTIONAL, the character to use to separate the answers
1319 ;" in the return string. Default is '^'
1320 ;"Note: The words in DiffStr are divided by "|"
1321 ;"Results: DiffStr1A>DiffStr1B^pos1>pos2^DiffStr2A>DiffStr2B^pos1>pos2^...
1322 ;" The A DiffStr would be what the value is in Words1, and
1323 ;" the B DiffStr would be what the value is in Words2, or @ if deleted.
1324
1325 set DivChr=$get(DivChr,"^")
1326 new result set result=""
1327 new trimmed1,trimmed2 set trimmed1=0,trimmed2=0
1328 new p1,p2,matchStr,matchLen
1329 new diffStr1,diffStr2,temp
1330 new tWords1,tWords2
1331 merge tWords1=Words1
1332 merge tWords2=Words2
1333 new i,len1,len2,trimLen1,trimLen2
1334 new diffPos1,diffPos2
1335 set len1=+$get(tWords1("MAXNODE"))
1336 set len2=+$get(tWords2("MAXNODE"))
1337DWLoop
1338 set temp=$$SimWPos(.tWords1,.tWords2,DivChr,.p1,.p2,.matchStr)
1339 ;"Returns: Pos1^Pos2^MatchStr Pos1=pos in s1, Pos2=pos in s2, MatchStr=the matching Str
1340
1341 ;"Possible return options:
1342 ;" p1=p2=0 -- two strings have nothing in common
1343 ;" p1=p2=1 -- first word of each string is the same
1344 ;" p1=p2=X -- words 1..(X-1) differ from each other.
1345 ;" p1>p2 -- e.g. EXT REL TAB --> XR TAB
1346 ;" p1<p2 -- XR TAB --> EXT REL TAB
1347
1348 if (p1=0)&(p2=0) do
1349 . set diffStr1=$$CatArray(.tWords1,1,len1,"|")
1350 . set diffStr2=$$CatArray(.tWords2,1,len2,"|")
1351 . set trimLen1=len1,trimLen2=len2
1352 . set diffPos1=1+trimmed1
1353 . set diffPos2=1+trimmed2
1354 else if (p1=1)&(p2=1) do
1355 . set diffStr1="@",diffStr2="@"
1356 . set trimLen1=1,trimLen2=1
1357 . set diffPos1=0,diffPos2=0
1358 else do
1359 . set diffStr1=$$CatArray(.tWords1,1,p1-1,"|")
1360 . set diffStr2=$$CatArray(.tWords2,1,p2-1,"|")
1361 . set trimLen1=p1-1,trimLen2=p2-1
1362 . set diffPos1=1+trimmed1,diffPos2=1+trimmed2
1363
1364 if diffStr1="" set diffStr1="@"
1365 if diffStr2="" set diffStr2="@"
1366
1367 if '((diffStr1="@")&(diffStr1="@")) do
1368 . set:(result'="")&($extract(result,$length(result))'=DivChr) result=result_DivChr
1369 . set result=result_diffStr1_">"_diffStr2_DivChr
1370 . set result=result_diffPos1_">"_diffPos2
1371
1372 do ListTrim^TMGMISC("tWords1",1,trimLen1,"MAXNODE")
1373 do ListTrim^TMGMISC("tWords2",1,trimLen2,"MAXNODE")
1374 set trimmed1=trimmed1+trimLen1
1375 set trimmed2=trimmed2+trimLen2
1376
1377 if ($get(tWords1("MAXNODE"))=0)&($get(tWords2("MAXNODE"))=0) goto DWDone
1378 goto DWLoop
1379
1380DWDone
1381 quit result
1382
1383CatArray(Words,i1,i2,DivChr)
1384 ;"Purpose: For given word array, return contatenated results from index1 to index2
1385 ;"Input: Words -- PASS BY REFERENCE. Array of Words, as might be created by CleaveToArray
1386 ;" i1 -- the index to start concat at
1387 ;" i2 -- the last index to include in concat
1388 ;" DivChr -- OPTIONAL. The character to used to separate words. Default=" "
1389
1390 new result set result=""
1391 set DivChr=$get(DivChr," ")
1392 new i for i=i1:1:i2 do
1393 . new word set word=$get(Words(i))
1394 . if word="" quit
1395 . set:(result'="")&($extract(result,$length(result))'=DivChr) result=result_DivChr
1396 . set result=result_word
1397 quit result
1398
1399
1400QtProtect(s)
1401 ;"Purpose: Protects quotes by converting all quotes do double quotes (" --> "")
1402 ;"Input : s -- The string to be modified. Original string is unchanged.
1403 ;"Result: returns a string with all instances of single instances of quotes
1404 ;" being replaced with two quotes.
1405
1406 new tempS
1407 set tempS=$$Substitute($get(s),"""""","<^@^>") ;"protect original double quotes
1408 set tempS=$$Substitute(tempS,"""","""""")
1409 set tempS=$$Substitute(tempS,"<^@^>","""""") ;"reverse protection
1410 quit tempS
1411
1412
1413GetStrPos(s,StartPos,P1,P2) ;"INCOMPLETE!!
1414 ;"Purpose: return position of start and end of a string (marked by starting
1415 ;" and ending quote. Search is started at StartPos.
1416 ;" Example: if s='She said "Hello" to Bill', and StartPos=1
1417 ;" then P1 should be returned as 10, and P2 as 16
1418 ;"Input: s -- the text to be
1419 ;" StartPos -- the position to start the search at. Optional: default=1
1420 ;" P1 -- PASS BY REFERENCE, an Out Parameter
1421 ;" P2 -- PASS BY REFERENCE, an Out Parameter
1422 ;"Results: None
1423 ;"Output: P1 and P2 are returned as per example above, or 0 if not quotes in text
1424
1425 set P1=0,P2=0
1426 if s'["""" goto GSPDone
1427 set StartPos=+$get(StartPos,1)
1428 new tempS set tempS=$extract(s,StartPos,$length(s))
1429 set tempS=$$Substitute(tempS,"""""",$char(1)_$char(1))
1430
1431 ;"FINISH... NOT COMPLETED...
1432GSPDone
1433 quit
1434
1435InQt(s,Pos)
1436 ;"Purpose: to return if a given character, in string(s), is insided quotes
1437 ;" e.g. s='His name is "Bill," OK?' and if p=14, then returns 1
1438 ;" (note the above string is usually stored as:
1439 ;" "His name is ""Bill,"" OK?" in the text editor, BUT in the
1440 ;" strings that will be passed here I will get only 1 quote character
1441 ;"Input: s -- the string to scan
1442 ;" Pos -- the position of the character in question
1443 ;"Results: 0 if not inside quotes, 1 if it is.
1444 ;"NOTE: if Pos points to the bounding quotes, the result is 0
1445 new inQt set inQt=0
1446 if (Pos>$length(s))!(Pos<1) goto IQtDone
1447 new p set p=$find(s,"""")-1
1448 if p<Pos for p=p-1:1:Pos set:($extract(s,p)="""") inQt='inQt
1449IQtDone quit inQt
1450
1451
1452GetWord(s,Pos,OpenDiv,CloseDiv)
1453 ;"Purpose: Extract a word from a sentance, bounded by OpenDiv,CloseDiv
1454 ;"Example: s="The cat is hungry", Pos=14 --> returns "hungry"
1455 ;"Example: s="Find('Purple')", Pos=8, OpenDiv="(", CloseDiv=")" --> returns "'Purple'"
1456 ;"Input: s -- the string containing the source sentence
1457 ;" Pos -- the index of a character anywhere inside desired word.
1458 ;" OpenDiv -- OPTIONAL, default is " " this is what marks the start of the word.
1459 ;" NOTE: if $length(OpenDiv)>1, then OpenDiv is considered
1460 ;" to be a SET of characters, any of which can be used
1461 ;" as a opening character.
1462 ;" CloseDiv -- OPTIONAL, default is " " this is what marks the end of the word.
1463 ;" NOTE: if $length(CloseDiv)>1, then CloseDiv is considered
1464 ;" to be a SET of characters, any of which can be used
1465 ;" as a closing character.
1466 ;"Results: returns desired word, or "" if problem.
1467 ;
1468 new result set result=""
1469 set OpenDiv=$get(OpenDiv," ")
1470 set CloseDiv=$get(CloseDiv," ")
1471 set Pos=+$get(Pos) if Pos'>0 goto GWdDone
1472 new p1,p2,len,i
1473 set len=$length(s)
1474 for p2=Pos:1:len if CloseDiv[$extract(s,p2) set p2=p2-1 quit
1475 for p1=Pos:-1:1 if OpenDiv[$extract(s,p1) set p1=p1+1 quit
1476 set result=$extract(s,p1,p2)
1477GWdDone quit result
1478
1479CmdChStrip(s)
1480 ;"Purpose: Strip all characters < #32 from string.
1481 new Codes,i,result
1482 set Codes=""
1483 for i=1:1:31 set Codes=Codes_$char(i)
1484 set result=$translate(s,Codes,"")
1485 quit result
1486
1487StrBounds(s,p)
1488 ;"Purpose: given position of start of string, returns index of end of string
1489 ;"Input: s -- the string to eval
1490 ;" p -- the index of the start of the string
1491 ;"Results : returns the index of the end of the string, or 0 if not found.
1492 new result set result=0
1493 for p=p+1:1 quit:(p>$length(s))!(result>0) do
1494 . if $extract(s,p)'="""" quit
1495 . set p=p+1
1496 . if $extract(s,p)="""" quit
1497 . set result=p-1
1498 quit result
1499
1500NonWhite(s,p)
1501 ;"Purpose: given starting position, return index of first non-whitespace character
1502 ;" Note: either a " " or a TAB [$char(9)] will be considered a whitespace char
1503 ;"result: returns index if non-whitespace, or index past end of string if none found.
1504 new result,ch,done
1505 for result=p:1 quit:(result>$length(s)) do quit:done
1506 . set ch=$extract(s,result)
1507 . set done=(ch'=" ")&(ch'=$char(9))
1508 quit result
1509
1510Pad2Pos(Pos,ch)
1511 ;"Purpose: return a string that can be used to pad from the current $X
1512 ;" screen cursor position, up to Pos, using char Ch (optional)
1513 ;"Input: Pos -- a screen X cursor position, i.e. from 1-80 etc (depending on screen width)
1514 ;" ch -- Optional, default is " "
1515 ;"Result: returns string of padded characters.
1516 new width set width=+$get(Pos)-$X if width'>0 set width=0
1517 quit $$LJ^XLFSTR("",width,.ch)
1518
Note: See TracBrowser for help on using the repository browser.