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

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

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