source: cprs/branches/tmg-cprs/m_files/TMGSTUTL.m

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

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