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

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

Initial upload
File size: 87.7 KB
Line 
1TMGMISC ;TMG/kst/Misc utility library ;03/25/06
2 ;;1.0;TMG-LIB;**1**;07/12/05
3
4 ;"TMG MISCELLANEOUS FUNCTIONS
5 ;"Kevin Toppenberg MD
6 ;"GNU General Public License (GPL) applies
7 ;"7-12-2005
8
9 ;"=======================================================================
10 ;" API -- Public Functions.
11 ;"=======================================================================
12 ;"STARTRPC -- Start up RPCBroker on port 9210
13 ;"STOPRPC -- Stop RPCBroker on port 9210
14 ;"STOPTSKM -- Stop TaskMan non-interactively
15 ;"EDITPT(AddOK)
16 ;"GetPersonClass(PersonClass,ProviderType,Specialty)
17 ;"$$DocLines(IEN,Chars) -- Count number of lines and chars in a 8925 WP field
18 ;"$$WPChars(Ptr)
19 ;"$$RoundUp(n)
20 ;"$$RoundDn(n)
21 ;"$$Round(n)
22 ;"$$InList(Value,ArrayP) -- return if Value is in an array.
23 ;"$$ListCt(pArray)
24 ;"$$NodeCt(pArray) -- count all the nodes in an array
25 ;"$$IndexOf(pArray,value)
26 ;"ListPack(pArray,StartNum,IncValue)
27 ;"ListAdd(pArray,index,value)
28 ;"ListAnd(pArray1,pArray2,pResult)
29 ;"ListNot(pArray1,pArray2,pResult)
30 ;"$$DTFormat(FMDate,format) -- format fileman dates
31 ;"$$CompDOB(DOB1,DOB2) -- compare two dates
32 ;"BrowseBy(CompArray,ByTag) -- Allow a user to interact with dynamic text tree
33 ;"$$CompName(Name1,Name2) -- compare two names
34 ;"$$FormatName(Name)
35 ;"$$HEXCHR(V) -- Take one BYTE and return HEX Values
36 ;"$$HEXCHR2(n,digits) -- convert a number (of arbitrary length) to HEX digits
37 ;"$$HEX2NUM(s) -- convert a string like this $10 to decimal number (e.g.) 16
38 ;"$$OR(a,b) ; perform a bitwise OR on operands a and b
39 ;"ParsePos(pos,label,offset,routine,dmod)
40 ;"ScanMod(Module,pArray)
41 ;"ConvertPos(Pos,pArray)
42 ;"CompArray(pArray1,pArray2) return if two arrays are identical
43 ;"$$CompABArray(pArrayA,pArrayB,pOutArray) -- FULL compare of two arrays, return diffArray
44 ;"$$IterTemplate(Template,Prior)
45 ;"$$NumPieces(s,delim,maxPoss) -- return number of pieces in string
46 ;"$$LastPiece(s,delim,maxPoss) -- return the last piece of a string
47 ;"$$ParseLast(s,remainS,delim,maxPoss) -- return the last piece AND the first part of the string
48 ;"$$Trim1Node(pRef) -- To shorten a reference by one node.
49 ;"BROWSEASK -- ask user for the name of an array, then display nodes
50 ;"BRWSASK2 -- Improved... Ask user for the name of an array, then display nodes
51 ;"BROWSENODES(current,Order,paginate,countNodes) -- display nodes of specified array
52 ;"BRWSNOD2(curRef,Order,countNodes) -- display nodes of specified array, using Scroll box
53 ;"ShowNodes(pArray,order,paginate,countNodes) -- display all the nodes of the given array
54 ;"ShowNod2(pArray,order,countNodes) -- display all the nodes of the given array, using Scroll box
55 ;"$$IsNumeric(value) -- determine if value is pure numeric.
56 ;"$$ClipDDigits(Num,digits) -- clip number to specified number of digits
57 ;"LaunchScreenman(File,FormIEN,RecIEN,Page) -- launching point screenman form
58 ;"$$NumSigChs --determine how many characters are signficant in a variable name
59 ;"MkMultList(input,List) -- create a list of entries, given a string containing a list of entries.
60 ;"MkRangeList(Num,EndNum,List) -- create a list of entries, given a starting and ending number
61 ;"$$Caller(Code) -- From call stack, return the location of the caller of the function
62
63 ;"=======================================================================
64 ;"PRIVATE API FUNCTIONS
65 ;"=======================================================================
66 ;"GetPersonClass(PersonClass,ProviderType,Specialty)
67 ;"ProcessToken(Token,Output)
68 ;"$$IsSuffix(s)
69 ;"$$IsTitle(s)
70 ;"ShowBy(CompArray,ByTag,aOpen,bOpen,cOpen)
71 ;"CtTemplate(Template) -- return the Count of IEN's stored in a SORT TEMPLATE
72
73 ;"=======================================================================
74 ;"DEPENDENCIES
75 ;" TMGDBAPI
76 ;" TMGIOUTL
77 ;" TMGDEBUG
78 ;" TMGSTUTL
79 ;"=======================================================================
80 ;"=======================================================================
81
82STARTRPC ;
83 ;" -- Start up RPCBroker on port 9210
84 WRITE "Starting RPC Broker on port 9210",!
85 DO STRT^XWBTCP(9210)
86 WRITE !
87 QUIT
88 ;
89STOPRPC ;
90 ;" -- Stop RPC Broker on port 9210
91 WRITE "Stopping RPC Broker on port 9210",!
92 DO STOP^XWBTCP(9210)
93 WRITE !
94 QUIT
95 ;
96STOPTSKM ;
97 ;"-- Shut Down Task Managers non-interactively
98 ;" Taken from STOP^ZTMKU
99 ;
100 WRITE !,"Shutting down TaskMan and submanagers."
101 DO GROUP^ZTMKU("SMAN^ZTMKU(NODE)")
102 DO GROUP^ZTMKU("SSUB^ZTMKU(NODE)")
103 WRITE !,"Okay!",!
104 QUIT
105 ;
106EDITPT(TMGADDOK)
107 ;"Purpose: To ask for a patient name, and then allow editing
108 ;"Input: TMGADDOK: if 1, then adding new patients is allowed
109 ;"Result: none
110 ;
111 DO LO^DGUTL
112 SET DGCLPR=""
113 NEW DGDIV SET DGDIV=$$PRIM^VASITE
114 ;
115 IF DGDIV>0 SET %ZIS("B")=$PIECE($get(^DG(40.8,+DGDIV,"DEV")),U,1)
116 ;
117 KILL %ZIS("B")
118 IF '$data(DGIO),$PIECE(^DG(43,1,0),U,30) do
119 . SET %ZIS="N",IOP="HOME"
120 . DO ^%ZIS
121 ;
122A DO ENDREG^DGREG($GET(DFN))
123 DO IF (Y<0) GOTO EDITDONE
124 . WRITE !!
125 . IF $GET(TMGADDOK)=1 DO
126 . . SET DIC=2,DIC(0)="ALEQM"
127 . . SET DLAYGO=2
128 . ELSE DO
129 . . SET DIC=2,DIC(0)="AEQM"
130 . . SET DLAYGO=0
131 . KILL DIC("S")
132 . DO ^DIC
133 . KILL DLAYGO
134 . IF Y<0 QUIT
135 . SET (DFN,DA)=+Y
136 . SET DGNEW=$P(Y,"^",3)
137 . NEW Y
138 . DO PAUSE^DG10
139 . DO BEGINREG^DGREG(DFN)
140 . IF DGNEW DO NEW^DGRP
141 ;
142 IF +$GET(DGNEW) DO
143 . ;" query CMOR for Patient Record Flag Assignments if NEW patient and
144 . ;" display results.
145 . IF $$PRFQRY^DGPFAPI(DFN) DO DISPPRF^DGPFAPI(DFN)
146 ;
147 SET (DGFC,CURR)=0
148 SET DA=DFN
149 SET DGFC="^1"
150 SET VET=$SELECT($DATA(^DPT(DFN,"VET")):^("VET")'="Y",1:0)
151 ;
152 SET %ZIS="N",IOP="HOME"
153 DO ^%ZIS
154 SET DGELVER=0
155 ;"DO EN^DGRPD
156 ;"IF $data(DGRPOUT) DO GOTO A
157 ;". DO ENDREG^DGREG($G(DFN))
158 ;". DO HL7A08^VAFCDD01
159 ;". KILL DFN,DGRPOUT
160 ;
161 ;"DO HINQ^DG10
162 IF $D(^DIC(195.4,1,"UP")) IF ^("UP") DO ADM^RTQ3
163 ;
164 DO REG^IVMCQ($G(DFN)) ;" send financial query
165 ;
166 SET DGRPV=0
167 DO EN1^DGRP
168 ;
169EDITDONE
170 IF $PIECE($GET(^VA(200,DUZ,"TMG")),"^",1)="C" DO
171 . WRITE @IOF,! ;"clear screen if settings call for this.
172 ;
173 QUIT
174
175
176GetPersonClass(PersonClass,ProviderType,Specialty)
177 ;"Purpose: To look through the PERSON CLASS file and find matching record
178 ;"Input -- PersonClass -- a value to match against the .01 field (PROVIDER TYPE)
179 ;" Behavioral Health and Social Service
180 ;" Chiropractors
181 ;" Dental Service
182 ;" Dietary and Nutritional Service
183 ;" Emergency Medical Service
184 ;" Eye and Vision Services
185 ;" Nursing Service
186 ;" Nursing Service Related
187 ;" Physicians (M.D. and D.O.)
188 ;" etc.
189 ;" -- ProviderType -- a value to match against the 1 field (CLASSIFICATION)
190 ;" Physician/Osteopath
191 ;" Resident, Allopathic (includes Interns, Residents, Fellows)
192 ;" Psychologist
193 ;" Neuropsychologist
194 ;" etc.
195 ;" -- Specialty -- a value to match against the 2 field (AREA OF SPECIALIZATION)
196 ;"Output -- (via results)
197 ;"Result -- Returns record number in PERSON CLASS file, OR 0 if not found
198
199 new RecNum,Params
200
201 set Params(0,"FILE")="PERSON CLASS"
202 set Params(".01")=$get(PersonClass)
203 set Params("1")=$get(ProviderType)
204 set Params("2")=$get(Specialty)
205
206 set RecNum=$$RecFind^TMGDBAPI(.Params)
207
208GPCDone
209 quit RecNum
210
211
212DocLines(IEN,Chars)
213 ;"Purpose: To count the number of lines and characters in a WP field
214 ;" Initially it is targeted at entries in TIU DOCUMENT file.
215 ;"Input: IEN -- the record number in TIU DOCUMENT to count
216 ;" Chars -- and OUT parameter. PASS BY REFERENCE
217 ;"Results: Returns number of lines, (with 1 decimal value)
218 ;" Also will return character count in Chars, if passed by reference
219 ;"NOte: This uses the Characters per line parameter value stored in
220 ;" field .03 of TIU PARAMETERS (in ^TIU(8925.99))
221
222 if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"DocLines^TMGMISC")
223
224 new CharsPerLine
225 new LineCount set LineCount=0
226 set Chars=0
227 set CharsPerLine=+$piece($get(^TIU(8925.99,1,0)),"^",3)
228
229 if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"CharsPerLine=",CharsPerLine)
230
231 set WPPtr=$name(^TIU(8925,IEN,"TEXT"))
232 set Chars=$$WPChars(WPPtr)
233 if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Chars=",Chars)
234
235 if CharsPerLine'=0 do
236 . set LineCount=(((Chars/CharsPerLine)*10)\1)/10
237 . ;"new IntLC,LC,Delta
238 . ;"set LC=Chars\CharsPerLine
239 . ;"set IntLC=Chars\CharsPerLine ;" \ is integer divide
240 . ;"set Delta=(LC-IntLC)*10
241 . i;"f Delta>4 set IntLC=IntLC+1 ;"Round to closest integer value.
242 . ;"set LineCount=IntLC
243
244 if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"LineCount=",LineCount)
245
246 if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"DocLines^TMGMISC")
247 quit LineCount
248
249
250WPChars(Ptr)
251 ;"Purpose: To count the number of characters in the WP field
252 ;" pointed to by the name stored in Ptr
253 ;"Results: Returns number of characters, including spaces
254
255 if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"WPChars^TMGMISC")
256
257 new index
258 new Chars set Chars=0
259
260 if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Ptr=",Ptr)
261 set index=$order(@Ptr@(0))
262 for do quit:(index="")
263 . if index="" quit
264 . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"index='",index,"'")
265 . ;"new s set s=$get(@Ptr@(index,0)) write "s=",s,!
266 . set Chars=Chars+$length($get(@Ptr@(index,0)))
267 . set index=$order(@Ptr@(index))
268
269 if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"WPChars^TMGMISC")
270
271 quit Chars
272
273
274
275RoundUp(n)
276 ;"SCOPE: PUBLIC
277 ;"Purpose: find the next greatest integer after decimal value of n (round up)
278 ;" 1.1 --> 2
279 ;" 1.0 --> 1
280 ;" -2.8 --> 2
281 ;"input: n -- decimal or integer value
282 ;"output an integer, rounded up.
283
284 new result
285 set result=n\1
286 if result<n set result=result+1
287 quit result
288
289RoundDn(n)
290 ;"SCOPE: PUBLIC
291 ;"Purpose: To round the decimal value of n downward (towards 0)
292 ;" 1.4 --> 1
293 ;" -2.2 --> -2
294 ;"input: n -- decimal or integer value
295 ;"output an integer, rounded down.
296
297 new result
298 set result=n\1
299 quit result
300
301Round(n)
302 ;"SCOPE: PUBLIC
303 ;"Purpose: find the nearest integer from decimal value of n
304 ;" for values 0.0-0.49 --> 0
305 ;" for values 0.5-0.99 --> 1
306 ;"input: n -- decimal or integer value
307 ;"output an integer, rounded to nearest integer
308
309 new result set result=n
310 new decimal
311
312 set decimal=+(n-(n\1))
313 if decimal<0.5 do
314 . set result=$$RoundDn(n)
315 else do
316 . set result=$$RoundUp(n)
317
318 quit result
319
320
321InList(Value,ArrayP)
322 ;"SCOPE: PUBLIC
323 ;"Purpose: To return if Value is in an array. Match must be exact (i.e. '=')
324 ;"Input: Value -- the value to test for. Should not be an array
325 ;" ArrayP -- the name of the array. e.g. ArrayP="MyArray(""Title"")"
326 ;"Format of Array: It may be in one of two possible formats:
327 ;" 1. MyArray("Title")=Value, or
328 ;" 2. MyArray("Title")="*" <-- a signal that multiple values are given
329 ;" MyArray("Title",1)=Value1
330 ;" MyArray("Title",2)=Value2
331 ;" The '1','2', etc may anything
332 ;"Results: 1 if Value is in list, 0 if not
333
334 new result set result=0
335 new index
336 if ($get(ArrayP)'="")&($data(Value)=1) do
337 . if @ArrayP'="*" set result=(@ArrayP=$get(Value)) quit
338 . set index=$order(@ArrayP@("")) quit:(index="")
339 . for do quit:(index="")!(result=1)
340 . . if @ArrayP@(index)=Value set result=1 quit
341 . . set index=$order(@ArrayP@(index))
342
343ILDone
344 quit result
345
346
347 ;"IndexOf(pArray,value)
348 ;" ;"SCOPE: PUBLIC
349 ;" ;"Purpose: To scan array and return first index holding value
350 ;" ;"Input: pArray -- PASS BY NAME. Array to scan, in format like this:
351 ;" ;" @pArray@(1)=value1
352 ;" ;" @pArray@(2)=value2
353 ;" ;" @pArray@(3)=value3
354 ;" ;" @pArray@("some name index 1")=value4
355 ;" ;" @pArray@("some name index 2")=value5
356 ;" ;" value -- the value to search for
357 ;" ;"results: returns the index holding the value
358 ;"
359 ;" new result set result=""
360 ;" new done set done=0
361 ;" new index set index=""
362 ;" for set index=$order(@pArray@(index)) quit:(index="")!(done=1) do
363 ;" . set done=($get(@pArray@(index))=value)
364 ;" . if done set result=index
365 ;"
366 ;"IODone quit result
367
368
369ListCt(pArray)
370 ;"SCOPE: PUBLIC
371 ;"Purpose: to count the number of entries in an array
372 ;"Input: pArray -- PASS BY NAME. pointer to (name of) array to test.
373 ;"Output: the number of entries at highest level
374 ;" e.g. Array("TELEPHONE")=1234
375 ;" Array("CAR")=4764
376 ;" Array("DOG")=5213
377 ;" Array("DOG","COLLAR")=5213 <-- not highest level,not counted.
378 ;" The above array would have a count of 3
379 ;"Results: returns count, or count up to point of any error
380 new i,result set result=0
381
382 do
383 . new $etrap
384 . set $etrap="write ""?? Error Trapped ??"",! set $ECODE="""" quit"
385 . set i=$order(@pArray@(""))
386 . if i="" quit
387 . for set result=result+1 set i=$order(@pArray@(i)) quit:i=""
388
389 quit result
390
391NodeCt(pArray)
392 ;"SCOPE: PUBLIC
393 ;"Purpose: to count all the nodes in an array
394 ;"Input: pArray -- PASS BY NAME. pointer to (name of) array to test.
395 ;"Output: the number of entries at highest level
396 ;" e.g. Array("TELEPHONE")=1234
397 ;" Array("CAR")=4764
398 ;" Array("DOG")=5213
399 ;" Array("DOG","COLLAR")=5213 <-- IS counted
400 ;" The above array would have a count of 4
401 ;"Results: returns count, or count up to point of any error
402 new result set result=0
403 for set pArray=$query(@pArray),result=result+1 quit:(pArray="")
404 quit result
405
406IndexOf(pArray,value)
407 ;"SCOPE: PUBLIC:
408 ;"Purpose: To search through an array of keys and values, and return 1st index (i.e. key) of value
409 ;"Input: pArray -- NAME OF array to search, format:
410 ;" @pArray@(key1)=value1
411 ;" @pArray@(key2)=value2
412 ;" @pArray@(key3)=value3
413 ;" value -- the value to search for
414 ;"Results: will return key for first found (based on $order sequence),or "" if not found
415
416 new result set result=""
417 new i set i=""
418 new done set done=0
419 for set i=$order(@pArray@(i)) quit:(i="")!(done=1) do
420 . if $get(@pArray@(i))=value set result=i,done=1
421
422 quit result
423
424ListPack(pArray,StartNum,IncValue)
425 ;"SCOPE: PUBLIC
426 ;"Purpose: to take an array with numeric ordering and pack values.
427 ;" e.g. Array(3)="dog"
428 ;" Array(5)="cat"
429 ;" Array(75)="goat"
430 ;" Will be pack as follows:
431 ;" Array(1)="dog"
432 ;" Array(2)="cat"
433 ;" Array(3)="goat"
434 ;"Input: pArray -- pointer to (NAME OF) array to pack.
435 ;" StartNum -- OPTIONAL, default=1. Value to start numbering at
436 ;" IncValue -- OPTIONAL, default=1. Amount to add to index value each time
437 ;"Output: array will be altered
438 ;"Results: none.
439 ;"Notes: It is assumed that all of the indices are numeric
440 ;" Nodes that are ALPHA (non-numeric) will be KILLED!!
441 ;" If nodes have subnodes, they will be preserved.
442
443 new TMGlpArray
444 new i
445 new count set count=$get(StartNum,1)
446 set i=$order(@pArray@(""))
447 if +i=i for do quit:(+i'=i)
448 . merge TMGlpArray(count)=@pArray@(i)
449 . set count=count+$get(IncValue,1)
450 . set i=$order(@pArray@(i))
451 kill @pArray
452 merge @pArray=TMGlpArray
453 quit
454
455
456ListTrim(pArray,startIndex,endIndex,CountName)
457 ;"SCOPE: PUBLIC
458 ;"Purpose: Take a list with numeric (integer) ordering, and trim (kill) entry
459 ;" items startIndex...endIndex
460 ;"Input: pArray -- PASS BY NAME. The array to trim
461 ;" startIndex -- the first index item to kill. Default=1
462 ;" endIndex -- the last index item to kill. Default=1
463 ;" CountName -- OPTIONAL. The name of a node that includes the
464 ;" final count of remaining nodes. Default is "COUNT"
465 ;"Output: Array items will be killed. Also, a node with the resulting count
466 ;" of remaining items will be created, with name of CountName. e.g.
467 ;" INPUT: startIndex=1, endIndex=4
468 ;" @pArray@(2)="grape"
469 ;" @pArray@(3)="orange"
470 ;" @pArray@(5)="apple"
471 ;" @pArray@(7)="pear"
472 ;" @pArray@(9)="peach"
473 ;"
474 ;" OUTPUT:
475 ;" @pArray@(5)="apple"
476 ;" @pArray@(7)="pear"
477 ;" @pArray@(9)="peach"
478 ;" @pArray@("COUNT")=3
479
480 set startIndex=$get(startIndex,1)
481 set endIndex=$get(endIndex,1)
482 set CountName=$get(CountName,"COUNT")
483 kill @pArray@(CountName)
484 new i for i=startIndex:1:endIndex kill @pArray@(i)
485 do ListPack(pArray)
486 set @pArray@(CountName)=$$ListCt(pArray)
487 quit
488
489
490ListAdd(pArray,index,value)
491 ;"SCOPE: PUBLIC
492 ;"Purpose: To take a simple list and add to end of ist
493 ;" e.g. Array("Apple")=75
494 ;" Array("Pear")=19
495 ;"
496 ;" do ListAdd("Array","Grape",12) -->
497 ;"
498 ;" e.g. Array("Apple")=75
499 ;" Array("Pear")=19
500 ;" Array("Grape")=12
501
502 ;"Note: function creation aborted, because there is no intrinsic ordering in arrays. I.e. the above would actually
503 ;" be in this order, as returned by $order():
504 ;" e.g. Array("Apple")=75
505 ;" Array("Grape")=12 <-- "G" comes before "P" alphabetically
506 ;" Array("Pear")=19
507
508 ;"I'll leave this here as a reminder to myself next time.
509
510 quit
511
512
513ListAnd(pArray1,pArray2,pResult)
514 ;"Purpose: To take two lists, and create a third list that has only those entries that
515 ;" exist in Array1 AND Array2
516 ;"Input: pArray1 : NAME OF array for list 1
517 ;" pArray2 : NAME OF array for list 2
518 ;" pResult : NAME OF array to results -- any preexisting entries will be killed
519 ;"Note: only TOP LEVEL nodes are considered, and *value* for pArray1 use for combined value
520 ;"E.g. of Use
521 ;" @pArray1@("cat")="feline"
522 ;" @pArray1@("dog")="canine"
523 ;" @pArray1@("horse")="equinine"
524 ;" @pArray1@("bird")="avian"
525 ;" @pArray1@("bird","weight")=12 <--- will be ignored, not a top level node
526 ;"
527 ;" @pArray2@("hog")="porcine"
528 ;" @pArray2@("horse")="equinine"
529 ;" @pArray2@("cow")="bovine"
530 ;" @pArray2@("bird")="flier" <----- note different value for key="bird"
531 ;"
532 ;" resulting list:
533 ;" @pResult@("horse")="equinine"
534 ;" @pResult@("bird")="avian" <-- note value from pArray1 used.
535
536 new Result
537
538 new i set i=$order(@pArray1@(""))
539 if i'="" for do quit:(i="")
540 . if $data(@pArray2@(i))#10 do
541 . . set Result(i)=$get(@pArray1@(i))
542 . set i=$order(@pArray1@(i))
543
544 kill @pResult
545 merge @pResult=Result
546
547 quit
548
549
550ListNot(pArray1,pArray2,Verbose)
551 ;"Purpose: To take two lists, and remove all entries from list 2 from list 1
552 ;" exist in Array1 NOT Array2
553 ;"Input: pArray1 : NAME OF array for list 1
554 ;" pArray2 : NAME OF array for list 2
555 ;" Verbose: OPTIONAL. if 1 then verbose output, progress bar etc.
556
557 ;"Note: only TOP LEVEL nodes are considered, and
558 ;" *value* for pArray1 use for combined value
559
560 ;"E.g. of Use
561 ;" list 1:
562 ;" @pArray1@("cat")="feline"
563 ;" @pArray1@("dog")="canine"
564 ;" @pArray1@("horse")="equinine"
565 ;" @pArray1@("bird")="avian"
566 ;" @pArray1@("bird","weight")=12 <--- will be ignored, not a top level node
567 ;"
568 ;" list 2:
569 ;" @pArray1@("cat")="feline"
570 ;" @pArray1@("horse")="equinine"
571 ;"
572 ;" resulting list:
573 ;" @pArray1@("dog")="canine"
574 ;" @pArray1@("bird")="avian"
575 ;" @pArray1@("bird","weight")=12
576 ;"
577
578 new Itr,index
579 set index=$$ItrAInit^TMGITR(pArray2,.Itr)
580 if Verbose=1 do PrepProgress^TMGITR(.Itr,20,1,"index")
581 if index'="" for do quit:($$ItrANext^TMGITR(.Itr,.index)="")
582 . kill @pArray1@(i)
583
584 quit
585
586
587 ;"Note: Sometime, compare this function to $$DATE^TIULS ... I didn't know about this function before!
588DTFormat(FMDate,format,Array)
589 ;"SCOPE: PUBLIC
590 ;"Purpose: to allow custom formating of fileman dates in to text equivalents
591 ;"Input: FMDate -- this is the date to work on, in Fileman Format
592 ;" format -- a formating string with codes as follows.
593 ;" yy -- 2 digit year
594 ;" yyyy -- 4 digit year
595 ;" m - month number without a leading 0.
596 ;" mm -- 2 digit month number (01-12)
597 ;" mmm - abreviated months (Jan,Feb,Mar etc.)
598 ;" mmmm -- full names of months (January,February,March etc)
599 ;" d -- the number of the day of the month (1-31) without a leading 0
600 ;" dd -- 2 digit number of the day of the month
601 ;" w -- the numeric day of the week (1-7)
602 ;" ww -- abreviated day of week (Mon,Tue,Wed)
603 ;" www -- day of week (Monday,Tuesday,Wednesday)
604 ;" h -- the number of the hour without a leading 0 (1-23) 24-hr clock mode
605 ;" hh -- 2 digit number of the hour. 24-hr clock mode
606 ;" H -- the number of the hour without a leading 0 (1-12) 12-hr clock mode
607 ;" HH -- 2 digit number of the hour. 12-hr clock mode
608 ;" # -- will display 'am' for hours 1-12 and 'pm' for hours 13-24
609 ;" M - the number of minutes with out a leading 0
610 ;" MM -- a 2 digit display of minutes
611 ;" s - the number of seconds without a leading 0
612 ;" ss -- a 2 digit display of number of seconds.
613 ;" allowed punctuation symbols-- ' ' : , / @ .;- (space, colon, comma, forward slash, at symbol,semicolon,period,hyphen)
614 ;" 'text' is included as is, even if it is same as a formatting code
615 ;" Other unexpected text will be ignored
616 ;"
617 ;" If a date value of 0 is found for a code, that code is ignored (except for min/sec)
618 ;"
619 ;" Examples: with FMDate=3050215.183000 (i.e. Feb 5, 2005 @ 18:30 0 sec)
620 ;" "mmmm d,yyyy" --> "February 5,2005"
621 ;" "mm d,yyyy" --> "Feb 5,2005"
622 ;" "'Exactly' H:MM # 'on' mm/dd/yy" --> "Exactly 6:30 pm on 02/05/05"
623 ;" "mm/dd/yyyy" --> "02/05/2005"
624 ;"
625 ;" Array -- OPTIONAL, if supplied, SHOULD BE PASSED BY REFERENCE
626 ;" The array will be filled with data as follows:
627 ;" Array(Token)=value for that token (ignores codes such as '/',':' ect)
628
629 ;"Output: Text of date, as specified by above
630
631 new result set result=""
632 new Token set Token=""
633 new LastToken set LastToken=""
634 new ch set ch=""
635 new LastCh set LastCh=""
636 new InStr set InStr=0
637 new done set done=0
638 new i
639
640 if $get(format)="" goto FDTDone
641 if +$get(FMDate)=0 goto FDTDone
642
643 for i=1:1:$length(format) do quit:done
644 . set LastCh=ch
645 . set ch=$extract(format,i) ;"get next char of format string.
646 . if (ch'=LastCh)&(LastCh'="")&(InStr=0) do ProcessToken(FMDate,.Token,.result,.Array)
647 . set Token=Token_ch
648 . if ch="'" do quit
649 . . if InStr do ProcessToken(FMDate,.Token,.result)
650 . . set InStr='InStr ;"toggle In-String mode
651 . if (i=$length(format)) do ProcessToken(FMDate,.Token,.result,.Array)
652
653FDTDone
654 quit result
655
656
657ProcessToken(FMDate,Token,Output,Array)
658 ;"SCOPE: PRIVATE
659 ;"Purpose: To take tokens and build output following rules specified by DTFormat)
660 ;"Input: FMDate -- the date to work with
661 ;" Token -- SHOULD BE PASSED BY REFERENCE. The code as oulined in DTFormat
662 ;" Output -- SHOULD BE PASSED BY REFERENCE. The cumulative output
663 ;" Array -- OPTIONAL, if supplied, SHOULD BE PASSED BY REFERENCE
664 ;" The array will be filled with data as follows:
665 ;" Array(Token)=value for that token (ignores codes such as '/')
666
667
668 if $extract(Token,1,1)="'" do goto PTDone
669 . new Str set Str=$extract(Token,2,$length(Token)-1)
670 . set Output=Output_Str
671
672 if Token=" " set Output=Output_Token goto PTDone
673 if Token="." set Output=Output_Token goto PTDone
674 if Token=":" set Output=Output_Token goto PTDone
675 if Token="/" set Output=Output_Token goto PTDone
676 if Token=";" set Output=Output_Token goto PTDone
677 if Token="," set Output=Output_Token goto PTDone
678 if Token="-" set Output=Output_Token goto PTDone
679 if Token="@" set Output=Output_Token goto PTDone
680
681 if Token="yy" do goto PTDone
682 . new Year set Year=+$extract(FMDate,1,3)
683 . if Year=0 quit
684 . set Year=+$extract(FMDate,2,3)
685 . if Year<10 set Year="0"_Year
686 . set Output=Output_Year
687 . set Array(Token)=Year;
688
689 if Token="yyyy" do goto PTDone
690 . new Year set Year=+$extract(FMDate,1,3)
691 . if Year>0 do
692 . . set Year=Year+1700
693 . . set Output=Output_Year
694 . . set Array(Token)=Year
695
696 if Token="m" do goto PTDone
697 . new Month set Month=+$extract(FMDate,4,5)
698 . if Month>0 do
699 . . set Output=Output_Month
700 . . set Array(Token)=Month
701
702 if Token="mm" do goto PTDone
703 . new Month set Month=+$extract(FMDate,4,5)
704 . if Month=0 quit
705 . if Month<10 set Month="0"_Month
706 . set Output=Output_Month
707 . set Array(Token)=Month
708
709 if Token="mmm" do goto PTDone
710 . new Month set Month=+$extract(FMDate,4,5)
711 . if Month=0 quit
712 . else if Month=1 set Month="Jan"
713 . else if Month=2 set Month="Feb"
714 . else if Month=3 set Month="Mar"
715 . else if Month=4 set Month="Apr"
716 . else if Month=5 set Month="May"
717 . else if Month=6 set Month="Jun"
718 . else if Month=7 set Month="Jul"
719 . else if Month=8 set Month="Aug"
720 . else if Month=9 set Month="Sept"
721 . else if Month=10 set Month="Oct"
722 . else if Month=11 set Month="Nov"
723 . else if Month=12 set Month="Dec"
724 . if +Month=0 do
725 . . set Output=Output_Month
726 . . set Array(Token)=Month
727
728 if Token="mmmm" do goto PTDone
729 . new Month set Month=+$extract(FMDate,4,5)
730 . if Month=0 quit
731 . else if Month=1 set Month="January"
732 . else if Month=2 set Month="February"
733 . else if Month=3 set Month="March"
734 . else if Month=4 set Month="April"
735 . else if Month=5 set Month="May"
736 . else if Month=6 set Month="June"
737 . else if Month=7 set Month="July"
738 . else if Month=8 set Month="August"
739 . else if Month=9 set Month="September"
740 . else if Month=10 set Month="October"
741 . else if Month=11 set Month="November"
742 . else if Month=12 set Month="December"
743 . else if +Month=0 do
744 . . set Output=Output_Month
745 . . set Array(Token)=Month
746
747 if Token="d" do goto PTDone
748 . new Day set Day=+$extract(FMDate,6,7)
749 . if Day>0 do
750 . . set Output=Output_Day
751 . . set Array(Token)=Day
752
753 if Token="dd" do goto PTDone
754 . new Day set Day=+$extract(FMDate,6,7)
755 . if Day=0 quit
756 . if Day<10 set Day="0"_Day
757 . set Output=Output_Day
758 . set Array(Token)=Day
759
760 if Token="w" do goto PTDone
761 . new DOW set DOW=$$DOW^XLFDT(FMDate,1)
762 . if DOW>0 do
763 . . set Output=Output_DOW
764 . . set Array(Token)=DOW
765
766 if Token="ww" do goto PTDone
767 . new DOW set DOW=$$DOW^XLFDT(FMDate,1)
768 . if (DOW<0)!(DOW>6) quit
769 . if DOW=0 set DOW="Sun"
770 . if DOW=1 set DOW="Mon"
771 . if DOW=2 set DOW="Tue"
772 . if DOW=3 set DOW="Wed"
773 . if DOW=4 set DOW="Thur"
774 . if DOW=5 set DOW="Fri"
775 . if DOW=6 set DOW="Sat"
776 . set Output=Output_DOW
777 . set Array(Token)=DOW
778
779 if Token="www" do goto PTDone
780 . new DOW set DOW=$$DOW^XLFDT(FMDate)
781 . if DOW'="day" do
782 . . set Output=Output_DOW
783 . . set Array(Token)=DOW
784
785 if Token="h" do goto PTDone
786 . new Hour set Hour=+$extract(FMDate,9,10)
787 . if Hour>0 do
788 . . set Output=Output_Hour
789 . . set Array(Token)=Hour
790
791 if Token="hh" do goto PTDone
792 . new Hour set Hour=+$extract(FMDate,9,10)
793 . if Hour=0 quit
794 . if Hour<10 set Hour="0"_Hour
795 . set Output=Output_Hour
796 . set Array(Token)=Hour
797
798 if Token="H" do goto PTDone
799 . new Hour set Hour=+$extract(FMDate,9,10)
800 . if Hour>12 set Hour=Hour-12
801 . if Hour>0 do
802 . . set Output=Output_Hour
803 . . set Array(Token)=Hour
804
805 if Token="HH" do goto PTDone
806 . new Hour set Hour=+$extract(FMDate,9,10)
807 . if Hour=0 quit
808 . if Hour>12 set Hour=Hour-12
809 . if Hour<10 set Hour="0"_Hour
810 . set Output=Output_Hour
811 . set Array(Token)=Hour
812
813 if Token="#" do goto PTDone
814 . new Hour set Hour=+$extract(FMDate,9,10)
815 . new code
816 . if Hour=0 quit
817 . if Hour>12 set code="pm"
818 . else set code="am"
819 . set Output=Output_code
820 . set Array(Token)=code
821
822 new Min set Min=+$extract(FMDate,11,12)
823
824 if Token="M" do goto PTDone
825 . new Min set Min=+$extract(FMDate,11,12)
826 . set Output=Output_Min
827 . set Array(Token)=Min
828
829 if Token="MM" do goto PTDone
830 . new Min set Min=+$extract(FMDate,11,12)
831 . if Min<10 set Min="0"_Min
832 . set Output=Output_Min
833 . set Array(Token)=Min
834
835 if Token="s" do goto PTDone
836 . new Sec set Sec=+$extract(FMDate,13,14)
837 . set Output=Output_Sec
838 . set Array(Token)=Sec
839
840 if Token="ss" do goto PTDone
841 . new Sec set Sec=+$extract(FMDate,13,14)
842 . if Sec<10 set Sec="0"_Sec
843 . set Output=Output_Sec
844 . set Array(Token)=Sec
845
846PTDone
847 set Token=""
848 quit
849
850
851
852
853CompDOB(DOB1,DOB2)
854 ;"Purpose: to compare two DOB and return if they match, or are similar
855 ;"Input: DOB1,DOB2 -- the two values to compare (in external format)
856 ;"Result: 0 - no similarity or equality
857 ;" 0.25 - doubt similarity
858 ;" 0.50 - possible similarity
859 ;" 0.75 - probable similarity
860 ;" 1 - exact match
861 ;"Note: I made this function because during lookups, I would get failures with data such as:
862 ;" WILLIAM,JOHN G JR 05-21-60
863 ;" WILLIAM,JOHN G JR 05-11-60 <-- date differs by one digit.
864 ;"Rules for comparision
865 ;" if dates differ by 1 digit --> score of 0.75
866 ;" if dates differ by an absolute difference of < 1 months --> 0.75
867 ;" if dates differ by an absolute difference of < 6 months --> 0.50
868 ;" if dates differ by an absolute difference of < 1 year --> 0.25
869 ;" if dates differ by 2 digits --> 0.25
870
871 new DT1,DT2
872 new result set result=0
873
874 new %DT
875 set X=DOB1 do ^%DT set DT1=Y ;"convert into internal format to avoid format snafu's
876 set X=DOB2 do ^%DT set DT2=Y
877
878 new DT1array,DT2array
879 new temp
880 if DT1=DT2 set result=1 goto CDOBDone
881
882 set temp=$$DTFormat^TMGMISC(DT1,"mm/dd/yy",.DT1array) ;"parse date parts into array.
883 set temp=$$DTFormat^TMGMISC(DT2,"mm/dd/yy",.DT2array)
884
885 ;"Compare digits
886 new NumDif set NumDif=0
887 new dg1,dg2
888
889 set dg1=$extract($get(DT1array("dd")),1,1) set dg2=$extract($get(DT2array("dd")),1,1)
890 if dg1'=dg2 set NumDif=NumDif+1
891 set dg1=$extract($get(DT1array("dd")),2,2) set dg2=$extract($get(DT2array("dd")),2,2)
892 if dg1'=dg2 set NumDif=NumDif+1
893
894 set dg1=$extract($get(DT1array("mm")),1,1) set dg2=$extract($get(DT2array("mm")),1,1)
895 if dg1'=dg2 set NumDif=NumDif+1
896 set dg1=$extract($get(DT1array("mm")),2,2) set dg2=$extract($get(DT2array("mm")),2,2)
897 if dg1'=dg2 set NumDif=NumDif+1
898
899 set dg1=$extract($get(DT1array("yy")),1,1) set dg2=$extract($get(DT2array("yy")),1,1)
900 if dg1'=dg2 set NumDif=NumDif+1
901 set dg1=$extract($get(DT1array("yy")),2,2) set dg2=$extract($get(DT2array("yy")),2,2)
902 if dg1'=dg2 set NumDif=NumDif+1
903
904 if NumDif=1 set result=0.75 goto CDOBDone
905 if NumDif=2 set result=0.50
906
907 ;"Compare absolute date
908 new H1,H2,DateDif
909 set H1=$$FMTH^XLFDT(DT1,1)
910 set H2=$$FMTH^XLFDT(DT2,1)
911 set DateDif=$$HDIFF^XLFDT(H1,H2,1) ;"1=results in 'days'
912 if $$HDIFF^XLFDT(H2,H1)>DateDif set DateDif=$$HDIFF^XLFDT(H2,H1)
913
914 new score set score=0
915 if DateDif<30 set score=0.75
916 if DateDif<(30*6) set score=0.50
917 if DateDif<365 set score=0.25
918
919 if score>result set result=score
920
921CDOBDone
922 quit result
923
924
925
926BrowseBy(CompArray,ByTag)
927 ;"Purpose: Allow a user to interact with dynamic text tree
928 ;" that will open and close nodes.
929 ;"Input: CompArray -- array to browse. Should be in this format
930 ;" CompArray("opening tag",a,b,c,d)
931 ;" ByTag -- the name to use in for "opening tag")
932
933 new aOpen set aOpen=0
934 new bOpen set bOpen=0
935 new cOpen set cOpen=0
936
937 new done set done=0
938 new input
939
940 for do quit:(done=1)
941 . do ShowBy(.CompArray,ByTag,aOpen,bOpen,cOpen)
942 . read "Enter option:",input:$get(DTIME,3600),!
943 . if input="" set input=0
944 . if +input>0 do
945 . . if aOpen=0 do
946 . . . set aOpen=input,bOpen=0,cOpen=0
947 . . else if bOpen=0 do
948 . . . set bOpen=input,cOpen=0
949 . . else if cOpen=0 set cOpen=input
950 . else if input=0 do
951 . . if cOpen'=0 set cOpen=0 quit
952 . . if bOpen'=0 set bOpen=0 quit
953 . . set aOpen=0
954 . else if input="^" set done=1
955
956 quit
957
958
959ShowBy(CompArray,ByTag,aOpen,bOpen,cOpen)
960
961 new a,b,c,d
962 new acount set acount=0
963 new bcount set bcount=0
964 new ccount set ccount=0
965 new dcount set dcount=0
966
967 write #
968
969 set a=$order(CompArray(ByTag,""))
970 if a'="" for do quit:(a="")
971 . set acount=acount+1
972 . new nexta set nexta=$order(CompArray(ByTag,a))
973 . new Aindent
974 . if (aOpen=0) do
975 . . if acount<10 write "0"
976 . . write acount,". "
977 . else write "... "
978 . write a,!
979 . set b=$order(CompArray(ByTag,a,""))
980 . if (aOpen=acount)&(b'="") for do quit:(b="")
981 . . set bcount=bcount+1
982 . . new nextb set nextb=$order(CompArray(ByTag,a,b))
983 . . new Bindent
984 . . write " +--"
985 . . if (bOpen=0) do
986 . . . if bcount<10 write "0"
987 . . . write bcount,". "
988 . . else write "... "
989 . . write b,!
990 . . if nextb'="" set Aindent=" | "
991 . . else set Aindent=" "
992 . . set c=$order(CompArray(ByTag,a,b,""))
993 . . if (bOpen=bcount)&(c'="") for do quit:(c="")
994 . . . set ccount=ccount+1
995 . . . new nextc set nextc=$order(CompArray(ByTag,a,b,c))
996 . . . if nextc'="" set Bindent=" | "
997 . . . else set Bindent=" "
998 . . . write Aindent," +--"
999 . . . if (cOpen=0) do
1000 . . . . if ccount<10 write "0"
1001 . . . . write ccount,". "
1002 . . . else write "... "
1003 . . . write c,!
1004 . . . set d=$order(CompArray(ByTag,a,b,c,""))
1005 . . . if (cOpen=ccount)&(d'="") for do quit:(d="")
1006 . . . . set dcount=dcount+1
1007 . . . . write Aindent,Bindent," +-- "
1008 . . . . if dcount<10 write "0"
1009 . . . . write dcount,". "
1010 . . . . write d,!
1011 . . . . set d=$order(CompArray(ByTag,a,b,c,d))
1012 . . . set c=nextc
1013 . . set b=nextb
1014 . set a=nexta
1015
1016SBDone
1017 quit
1018
1019
1020
1021CompName(Name1,Name2)
1022 ;"Purpose: To compare two names, to see if they are the name, or compatible.
1023 ;" e.g. WILLIAMS,J BILL vs. WILLAMS,JOHN BILL, vs. WILLIAMS,JOHN B
1024 ;"Input: Two names to compare
1025 ;"Result: 0 -- if entries conflict
1026 ;" 0.5 -- if entries are consistent (i.e. in example above)
1027 ;" 1 -- if entries completely match
1028 ;"Note: This function WILL IGNORE a suffix. This is because
1029 ;" WILLIAM,BILL 5-1-1950
1030 ;" WILLIAM,BILL SR 5-1-1950
1031 ;" would be considered the same person (the date is the determining factor)
1032 ;"Rules: Last names must completely match or --> 0
1033 ;" If name is exactly the same, then --> 1
1034 ;" Initial must be same as first letters in name (e.g. N vs. NEWTON) --> 0.5
1035
1036 new result set result=1
1037
1038 new NArray1,NArray2,TMGMsg
1039
1040 set Name1=$$FormatName(Name1,1) ;"should convert to standard format.
1041 set Name2=$$FormatName(Name2,1)
1042
1043 do STDNAME^XLFNAME(.Name1,"C",.TMGMsg)
1044 do STDNAME^XLFNAME(.Name1,"C",.TMGMsg) ;"Doing a second time will ensure Array not in initial format.
1045
1046 do STDNAME^XLFNAME(.Name2,"C",.TMGMsg)
1047 do STDNAME^XLFNAME(.Name2,"C",.TMGMsg) ;"Doing a second time will ensure Array not in initial format.
1048
1049 if Name1=Name2 set result=1 goto CompNDone
1050 if Name1("FAMILY")'=Name2("FAMILY") do goto:(result=0) CompNDone
1051 . if $$EN^XUA4A71(Name1("FAMILY"))'=$$EN^XUA4A71(Name2("FAMILY")) set result=0 ;"check soundex equality
1052
1053 if Name1("GIVEN")'=Name2("GIVEN") do
1054 . if $$EN^XUA4A71(Name1("GIVEN"))=$$EN^XUA4A71(Name2("GIVEN")) quit ;"check soundex equality
1055 . new n1,n2
1056 . set n1=Name1("GIVEN")
1057 . set n2=Name2("GIVEN")
1058 . if $length(n2)<$length(n1) do ;"ensure length n2>n1
1059 . . new temp set temp=n2
1060 . . set n2=n1,n1=temp
1061 . if $extract(n2,1,$length(n1))=n1 set result=0.5
1062 . else set result=0
1063 if result=0 goto CompNDone
1064
1065 if Name1("MIDDLE")'=Name2("MIDDLE") do
1066 . if $$EN^XUA4A71(Name1("MIDDLE"))=$$EN^XUA4A71(Name2("MIDDLE")) quit ;"check soundex equality
1067 . new n1,n2
1068 . set n1=Name1("MIDDLE")
1069 . set n2=Name2("MIDDLE")
1070 . if $length(n2)<$length(n1) do ;"ensure length n2>n1
1071 . . new temp set temp=n2
1072 . . set n2=n1,n1=temp
1073 . if $extract(n2,1,$length(n1))=n1 set result=0.5
1074 . else set result=0
1075 if result=0 goto CompNDone
1076
1077CompNDone
1078 quit result
1079
1080
1081
1082FormatName(Name,CutTitle)
1083 ;"Purpose: To ensure patient name is properly formated.
1084 ;" i.e. John G. Doe --> DOE,JOHN G
1085 ;" John G. Doe III --> DOE,JOHN G III
1086 ;" John G. Doe,III --> DOE,JOHN G III
1087 ;" Doe, John G --> DOE,JOHN G
1088 ;" Doe,John g.,III, phd --> DOE,JOHN G III PHD
1089 ;"Input: Name -- the name to be reformated
1090 ;" CutTitle -- OPTIONAL -- if 1, then titles (e.g. MD, PhD etc) will be cut
1091 ;"Results: returns properly formated name
1092 ;"Note: If Name is passed by reference, it will be changed
1093 ;" Also, NO lookup is done in database to ensure name exists
1094
1095 ;"Note: this function malfunctioned on a patient with name like this:
1096 ;" JOHN A VAN DER BON --> BON,JOHN A VAN DER (should be VAN DER BON,JOHN A)
1097 ;" I don't have a quick for this right now...
1098 ;"Also, Sue St. Clair --> CLAIR,SUE ST this is also wrong.
1099
1100 ;"FYI: do STDNAME^XLFNAME(.NAME,FLAGS,.ERRARRAY) can also do standardization,
1101 ;" and also parse to component parts. It specifically address the St. Clair issue.
1102
1103 if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"FormatName^TMGGDFN")
1104
1105 new NameArray
1106 new MaxNode
1107 new Suffix set Suffix=""
1108 new i,s,lname
1109 new fname set fname=""
1110 new result set result=""
1111 if $data(Name)#10=0 goto FormatNDone
1112
1113 if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Person's name initially is: '",Name,"'")
1114 set Name=$translate(Name,"*.","") ;"cleans off any *'s or .'s from initials etc.
1115 if Name[", " do
1116 . new s1,s2
1117 . set s1=$piece(Name,", ",1)
1118 . set s2=$piece(Name,", ",2)
1119 . if $$IsTitle($$UP^XLFSTR(s2))&($get(CutTitle)=1) do
1120 . . set Name=s1
1121 . else do
1122 . . set Name=s1_","_s2
1123 . ;"set Name=$translate(Name,", ",",") ;"Convert 'Doe, John' into 'Doe,John'
1124 set Name=$$UP^XLFSTR(Name) ;"convert to upper case
1125 if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"After translations, name is: '",Name,"'")
1126 set result=$$FORMAT^DPTNAME(Name,3,30) ;"Convert to 'internal' format
1127 if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"After $$FORMAT^DPTNAME, name is: '",result,"'")
1128
1129 ;"Now, test if FORMAT^DPTNAME caused empty name, i.e.
1130 ;" John G Doe --> "" (it wanted Doe,John G)
1131 set lname=$piece(result,",",2)
1132 if $$IsTitle(lname)&($get(CutTitle)=1) do ;"trim off title if not wanted.
1133 . set result=$piece(result,",",1)
1134 . set lname=""
1135 if $$IsSuffix(lname)=1 do
1136 . ;"Here we have 'JOHN DOE,III' --> must be changed to 'DOE,JOHN III'
1137 . set Name=$translate(Name,","," ") ;"First change 'JOHN DOE,III' --> 'JOHN DOE III'
1138 . set result="" ;"signal need to rearrange letters.
1139 if (result="")&(Name'[",") do
1140 . set s=Name
1141 . do CleaveToArray^TMGSTUTL(s," ",.NameArray,1)
1142 . set MaxNode=+$get(NameArray("MAXNODE"))
1143 . if MaxNode=0 quit
1144 . if $get(CutTitle)=1 do
1145 . . if $$IsTitle(NameArray(MaxNode)) do
1146 . . . kill NameArray(MaxNode)
1147 . . . set MaxNode=MaxNode-1
1148 . . . set NameArray("MAXNODE")=MaxNode
1149 . set lname=NameArray(MaxNode)
1150 . if ($$IsSuffix(lname)=1)!($$IsTitle(lname)) do
1151 . . ;"Change JOHN G DOE III --> JOHN G III DOE (order change in array)
1152 . . set lname=NameArray(MaxNode-1) ;"i.e. DOE
1153 . . set Suffix=NameArray(MaxNode) ;"i.e. III
1154 . . set NameArray(MaxNode)=lname
1155 . . set NameArray(MaxNode-1)=Suffix
1156 . set result=lname_","
1157 . for i=1:1:MaxNode-1 do
1158 . . set result=result_NameArray(i)_" "
1159
1160 ;"convert potential 'DOE,JOHN G,III, PHD' --> 'DOE,JOHN G III PHD'
1161 set lname=$piece(result,",",1)
1162 set fname=$piece(result,",",2,99)
1163 set fname=$translate(fname,","," ")
1164 set result=lname_","_fname
1165
1166 set result=$$Trim^TMGSTUTL(result)
1167
1168 ;"One last run through, after all custom alterations made.
1169 ;"convert potential 'DOE,JOHN G III PHD' --> 'DOE,JOHN G III PHD'
1170 set result=$$FORMAT^DPTNAME(result,3,30) ;"Convert to 'internal' format
1171
1172FormatNDone
1173 if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"FormatName^TMGGDFN")
1174 quit result
1175
1176
1177IsSuffix(s)
1178 ;"Purpose: to return whether s is a suffix (i.e. I,II,Jr.,Sr. etc.)
1179 ;"Input: s : the string to check
1180 ;"Result 0 if NOT a suffix, 1 if IS a suffix.
1181
1182 new result set result=0
1183
1184 if (s="I")!(s="II")!(s="III")!(s="JR")!(s="SR") set result=1
1185
1186 quit result
1187
1188
1189IsTitle(s)
1190 ;"Purpose: to return whether s is a title (i.e. MD,PHD,JD,DDS etc.)
1191 ;"Input: s : the string to check
1192 ;"Result 0 if NOT a suffix, 1 if IS a suffix.
1193
1194 new result set result=0
1195
1196 if (s="MD")!(s="PHD")!(s="JD")!(s="DDS") set result=1
1197 if (s="FNP")!(s="GNP")!(s="NP")!(s="PA") set result=1
1198 if (s="RN")!(s="LPN") set result=1
1199
1200 quit result
1201
1202
1203
1204HEXCHR(V)
1205 ;"Scope: PUBLIC
1206 ;"Take one BYTE and return HEX Values
1207 ;"(from Chris Richardson -- thanks!)
1208 new NV,B1,B2
1209 set NV="0123456789ABCDEF"
1210 set B1=(V#16)+1 ; "0 to 15 becomes 1 to 16
1211 set B2=(V\16)+1
1212 quit $E(NV,B2)_$E(NV,B1)
1213
1214
1215HEXCHR2(n,digits)
1216 ;"SCOPE: PUBLIC
1217 ;"Purpose: convert n to hex characters
1218 ;"Input: n -- the number to convert
1219 ;" digits: (optional) number of digits in output. Leading 0's padded to
1220 ;" front of answer to set number of digits.
1221 ;" e.g. if answer is "A", then
1222 ;" 2 -> mandates at least 2 digits ("0A")
1223 ;" 3->3 digits ("00A")
1224 ;"Note: This function is not as fast as HEXCHR(V)
1225
1226 new lo
1227 new result set result=""
1228 new ch
1229 set digits=$get(digits,1)
1230
1231 for do quit:(n=0)
1232 . set lo=n#16
1233 . if (lo<10) set ch=+lo
1234 . else set ch=$char(55+lo)
1235 . set result=ch_result
1236 . set n=n\16
1237
1238 if $length(result)<digits do
1239 . new i
1240 . for i=1:1:digits-$length(result) do
1241 . . set result="0"_result
1242
1243 quit result
1244
1245HEX2NUM(s)
1246 ;"Scope: PUBLIC
1247 ;"Purpose: to convert a string like this $10 --> 16
1248
1249 new multiplier set multiplier=1
1250 new result set result=0
1251
1252 if $extract(s,1)="$" set s=$extract(s,2,$length(s))
1253
1254 for do quit:(s="")
1255 . new sStart,sEnd,n
1256 . set sStart=$extract(s,1,$length(s)-1)
1257 . set sEnd=$extract(s,$length(s))
1258 . if +sEnd=sEnd set n=sEnd
1259 . else set n=($ascii(sEnd)-65)+16
1260 . set result=result+(n*multiplier)
1261 . set multiplier=multiplier*16
1262 . set s=sStart
1263
1264 quit result
1265
1266
1267OR(a,b)
1268 ;"Scope: PUBLIC
1269 ;"Purpose: to perform a bitwise OR on operands a and b
1270
1271 new result set result=0
1272 new mult set mult=1
1273 for do quit:(a'>0)&(b'>0)
1274 . set result=result+(((a#2)!(b#2))*mult)
1275 . set a=a\2,b=b\2,mult=mult*2
1276
1277 quit result
1278
1279
1280ParsePos(pos,label,offset,routine,dmod)
1281 ;"Purpose: to convert a pos string (e.g. X+2^ROUTINE$DMOD) into componant parts
1282 ;"Input: pos -- the string, as example above
1283 ;" label -- OUT PARAM, PASS BY REF, would return "x"
1284 ;" offset -- OUT PARAM, PASS BY REF, would return "+2"
1285 ;" routine -- OUT PARAM, PASS BY REF, would return "ROUTINE"
1286 ;" dmod -- OUT PARAM, PASS BY REF, would return "DMOD"
1287 ;"Results: none
1288 ;"Note: results are shortened to 8 characters.
1289
1290 new s
1291 set s=$get(pos)
1292 set dmod=$piece(s,"$",1) ;"e.g. X+2^ROUTINE$DMOD-->X+2^ROUTINE
1293 set routine=$piece(s,"^",2)
1294 set routine=$extract(routine,1,8)
1295 set label=$piece(s,"^",1)
1296 set offset=$piece(label,"+",2)
1297 set label=$piece(label,"+",1)
1298 set label=$extract(label,1,8)
1299
1300 quit
1301
1302
1303ScanMod(Module,pArray)
1304 ;"Purpose: To scan a module and find all the labels/entry points/Entry points
1305 ;"Input: Module -- The name of the module, like "XGF" (not "XGF.m" or "^XGF")
1306 ;" pArray -- pointer to (NAME OF) array Will be filled like this
1307 ;" pArray(1,"TAG")="Label1"
1308 ;" pArray(1,"OFFSET")=1
1309 ;" pArray(2,"TAG")="Label2"
1310 ;" pArray(2,"OFFSET")=9
1311 ;" pArray(3,"TAG")="Label3" etc.
1312 ;" pArray(3,"OFFSET")=15
1313 ;" pArray("Label1")=1
1314 ;" pArray("Label2")=2
1315 ;" pArray("Label3")=3
1316 ;"
1317 ;" NOTE: there seems to be a problem if the passed pArray value is "pArray",
1318 ;" so use another name.
1319 ;"
1320 ;"Output: Results are put into array
1321 ;"Result: none
1322
1323 new smIdx set smIdx=1
1324 new LabelNum set LabelNum=0
1325 new smLine set smLine=""
1326 if $get(Module)="" goto SMDone
1327
1328 for do quit:(smLine="")
1329 . new smCh
1330 . set smLine=$text(+smIdx^@Module)
1331 . if smLine="" quit
1332 . set smLine=$$Substitute^TMGSTUTL(smLine,$Char(9)," ") ;"replace tabs for 8 spaces
1333 . set smCh=$extract(smLine,1)
1334 . if (smCh'=" ")&(smCh'=";") do
1335 . . new label
1336 . . set label=$piece(smLine," ",1)
1337 . . set LabelNum=LabelNum+1
1338 . . set @pArray@(LabelNum,"TAG")=label
1339 . . set @pArray@(LabelNum,"OFFSET")=smIdx
1340 . . set @pArray@(label)=LabelNum
1341 . set smIdx=smIdx+1
1342
1343SMDone
1344 quit
1345
1346
1347ConvertPos(Pos,pArray)
1348 ;"Purpose: to convert a text positioning line from one that is relative to the last tag/label, into
1349 ;" one that is relative to the start of the file
1350 ;" e.g. START+8^MYFUNCT --> +32^MYFUNCT
1351 ;"Input: Pos -- a position, as returned from $ZPOS
1352 ;" pArray -- pointer to (name of). Array holding holding tag offsets
1353 ;" pArray will be in this format:
1354 ;" pArray("ModuleA",1,"TAG")="ALabel1"
1355 ;" pArray("ModuleA",1,"OFFSET")=1
1356 ;" pArray("ModuleA",2,"TAG")="ALabel2"
1357 ;" pArray("ModuleA",2,"OFFSET")=9
1358 ;" pArray("ModuleA","Label1")=1
1359 ;" pArray("ModuleA","Label2")=2
1360 ;" pArray("ModuleA","Label3")=3
1361 ;" pArray("ModuleB",1,"TAG")="BLabel1"
1362 ;" pArray("ModuleB",1,"OFFSET")=4
1363 ;" pArray("ModuleB",2,"TAG")="BLabel2"
1364 ;" pArray("ModuleB",2,"OFFSET")=23
1365 ;" pArray("ModuleB","Label1")=1
1366 ;" pArray("ModuleB","Label2")=2
1367 ;" pArray("ModuleB","Label3")=3
1368 ;" NOTE: -- if array passed is empty, then this function will call ScanModule to fill it
1369 ;"Result: returns the new position line, relative to the start of the file/module
1370 ;"
1371
1372 new cpS
1373 new cpResult set cpResult=""
1374 new cpRoutine,cpLabel,cpOffset
1375
1376 set cpS=$piece(Pos,"$",1) ;"e.g. X+2^ROUTINE$DMOD-->X+2^ROUTINE
1377 if cpS="" goto CPDone
1378
1379 set cpRoutine=$piece(cpS,"^",2)
1380 if cpRoutine="" goto CPDone
1381
1382 set cpS=$piece(cpS,"^",1)
1383 set cpOffset=+$piece(cpS,"+",2)
1384 ;"if cpOffset="" set cpOffset=1
1385 ;"else set cpOffset=+cpOffset
1386 set cpLabel=$piece(cpS,"+",1)
1387
1388 if $data(@pArray@(cpRoutine))=0 do
1389 . new p2Array set p2Array=$name(@pArray@(cpRoutine))
1390 . do ScanMod(cpRoutine,p2Array)
1391
1392 new cpIdx set cpIdx=+$get(@pArray@(cpRoutine,cpLabel))
1393 if cpIdx=0 goto CPDone
1394 new cpGOffset set cpGOffset=@pArray@(cpRoutine,cpIdx,"OFFSET")
1395 set cpResult="+"_+(cpGOffset+cpOffset)_"^"_cpRoutine
1396
1397CPDone
1398 quit cpResult
1399
1400
1401
1402
1403CompArray(pArray1,pArray2)
1404 ;"Purpose: To return if two arrays are identical
1405 ;" Equality means that all nodes and values are present and equal
1406 ;"Input: Array1 -- PASS BY NAME. The *name of* the first array to be compared
1407 ;" Array1 -- PASS BY NAME. The *name of* the second array to be compared
1408 ;"Output: 1 if two are identical, 0 if not
1409
1410 new result set result=1
1411 new index1,index2
1412 set index1=$order(@pArray1@(""))
1413 set index2=$order(@pArray2@(""))
1414 if (index1="")!(index2="") set result=0 goto CADone
1415 for do quit:(result=0)!(index1="")!(index2="")
1416 . if index2'=index2 set result=0 quit
1417 . if $get(@pArray1@(index1))'=$get(@pArray2@(index2)) set result=0 quit
1418 . if ($data(@pArray1@(index1))'<10)!($data(@pArray2@(index2))'<10) do
1419 . . set result=$$CompArray($name(@pArray1@(index1)),$name(@pArray2@(index2)))
1420 . set index1=$order(@pArray1@(index1))
1421 . set index2=$order(@pArray2@(index2))
1422
1423CADone quit result
1424
1425
1426
1427IterTemplate(Template,Prior)
1428 ;"Purpose: To iterate through a SORT TEMPLATE (i.e. provide record numbers held in the template
1429 ;" one at a time. For each time this function is called, one record number (IEN) is returned.
1430 ;"Input: Template: the IEN of an entry from file SORT TEMPLATE (file# .401)
1431 ;" Prior -- OPTIONAL (default is to return first record), an IEN as returned from this
1432 ;" function during the last call.
1433 ;"Result: Returns the next record found in list, occuring after Prior, or -1 if error or not found
1434 ;" Returns "" if end of list (no next record)
1435
1436 ;"Example of use: This will list all records held in SORT TEMPLATE record# 809
1437 ;" set IEN=""
1438 ;" for s IEN=$$IterTemplate^TMGMISC(809,IEN) w IEN,! q:(+IEN'>0)
1439
1440 set Prior=$get(Prior)
1441 set result=-1
1442 if +$get(Template)'>0 goto ItTDone
1443
1444 set result=$order(^DIBT(Template,1,Prior))
1445
1446ItTDone quit result
1447
1448CtTemplate(Template)
1449 ;"Purpose: To return the Count of IEN's stored in a SORT TEMPLATE
1450 ;"Input: Template: the IEN of an entry from file SORT TEMPLATE (file# .401)
1451 ;"Result: Returns the count of records held
1452
1453 new name set name=$name(^DIBT(Template,1))
1454 quit $$ListCt(name)
1455
1456
1457NumPieces(s,delim,maxPoss)
1458 ;"Purpose: to return the number of pieces in s, using delim as a delimiter
1459 ;"Input: s -- the string to test
1460 ;" delim -- OPTIONAL -- the delimiter (e.g. ',' or ';' or ' ' etc), default=" "
1461 ;" maxPoss -- OPTIONAL the maximum number of possible pieces, default=32
1462 ;" the function counts DOWN from this number, so if s has more than default, must specify
1463 ;"Result: Returns the number of pieces
1464 ;" e.g. 'this is a test', space delimiter --> returns 4
1465 ;"Note: ("this is a test",";") --> 1
1466 ;" ("",";") --> 0
1467
1468 ;"NOTICE!!!
1469 ;"After writing this function, I was told that $length(s,delim) will do this.
1470 ;" I will leave this here as a reminder, but it probably shouldn't be used....
1471 quit $length(s,$get(delim," "))
1472
1473
1474 new i,result set result=0
1475 if $get(s)="" goto NPsDone
1476 set delim=$get(delim," ")
1477 set maxPoss=+$get(maxPoss,32)
1478
1479 for result=maxPoss:-1:1 quit:($piece(s,delim,result)'="")
1480
1481 quit result
1482
1483LastPiece(s,delim,maxPoss)
1484 ;"Purpose: to return the last piece of a string
1485 ;"Input: s -- the string to use
1486 ;" delim -- OPTIONAL -- the delimiter (e.g. ',' or ';' or ' ' etc), default=" "
1487 ;" maxPoss -- OPTIONAL the maximum number of possible pieces, default=32 (see NumPieces function)
1488 ;"Results : returns the LAST piece in the string
1489
1490 new result set result=""
1491 if $get(s)="" goto LPDone
1492 set delim=$get(delim," ")
1493 new n
1494 set n=$length(s,delim)
1495 set result=$piece(s,delim,n)
1496
1497LPDone
1498 quit result
1499
1500ParseLast(s,remainS,delim,maxPoss)
1501 ;"Purpose: to return the last piece of a string, AND return the first part of the string in remainS
1502 ;"Input: s -- the string to use
1503 ;" remainS -- an OUT parameter. PASS BY REFERENCE. Returns the part of the string up to result
1504 ;" delim -- OPTIONAL -- the delimiter (e.g. ',' or ';' or ' ' etc), default=" "
1505 ;" maxPoss -- OPTIONAL the maximum number of possible pieces, default=32 (see NumPieces function)
1506 ;"Results : returns the LAST piece in the string
1507
1508 new result set result=""
1509 new tempS set tempS=s ;"in case s passed by reference, and remainS=s (i.e. w $$ParseLast(s,.s)
1510 set remainS=""
1511 set delim=$get(delim," ")
1512
1513 if $get(tempS)="" goto PLDone
1514 new n
1515 set n=$length(s,delim)
1516 set result=$piece(tempS,delim,n)
1517 if n>1 set remainS=$piece(tempS,delim,1,n-1)
1518
1519PLDone
1520 quit result
1521
1522
1523
1524NPsDone
1525 quit result
1526
1527
1528Trim1Node(pRef)
1529 ;"Purpose: To shorten a reference by one node.
1530 ;" e.g. "Array(567,2342,123)" --> "Array(567,2342)"
1531 ;"Input: pRef -- the NAME OF an array.
1532 ;"Result: will return shortened reference, or "" if problem
1533 ;" If no nodes to trim, just array name will be returnes.
1534
1535 new result set result=pRef
1536 if pRef="" goto T1NDone
1537
1538 if $qlength(pRef)>0 set result=$name(@pRef,$qlength(pRef)-1)
1539 goto T1NDone
1540
1541 ;"Below is an old way I came up with (not as effecient!)
1542 ;"NOT USED.
1543 set result=$qsubscript(pRef,0)
1544
1545 new numNodes,i
1546 set numNodes=$qlength(pRef)
1547 for i=1:1:(numNodes-1) do
1548 . new node set node=$qsubscript(pRef,i)
1549 . set result=$name(@result@(node))
1550
1551T1NDone
1552 quit result
1553
1554
1555BROWSEASK
1556 ;"Purpose: to ask user for the name of an array, then display nodes
1557
1558 new current
1559 new order set order=1 ;"default = forward display.
1560 new paginate set paginate=0 ;"no pagination
1561 new countNodes set countNodes=0 ;"no counting
1562 write !
1563 read "Enter name of array (or File number) to display nodes in: ",current:$get(DTIME,3600),!
1564 if +current=current do
1565 . set current=$get(^DIC(+current,0,"GL"))
1566 . if current="" write "File number not found. Quitting.",! quit
1567 . write "Browsing array: ",current,!
1568 if current="" set current="^"
1569 if current="^" goto BADone
1570
1571 new % set %=2 ;" default= NO
1572 write "Display in REVERSE order? "
1573 do YN^DICN write !
1574 if %=1 set order=-1
1575 if %=-1 goto BADone
1576
1577 set %=2
1578 write "Pause after each page? "
1579 do YN^DICN write !
1580 if %=1 set paginate=1
1581 if %=-1 goto BADone
1582
1583 set %=2
1584 write "Show number of subnodes? "
1585 do YN^DICN write !
1586 if %=1 set countNodes=1
1587 if %=-1 goto BADone
1588
1589 do BROWSENODES(current,order,paginate,countNodes)
1590BADone
1591 quit
1592
1593
1594BROWSENODES(current,Order,paginate,countNodes)
1595 ;"Purpose: to display nodes of specified array
1596 ;"Input: Current -- The reference to display
1597 ;" order -- OPTIONAL, default=1; 1 for forward, -1 for backwards order
1598 ;" paginate -- OPTIONAL, default=0; 0=no pagination, 1=pause after each page
1599 ;" countNodes -- OPTIONAL, default=0; 1=show number of child nodes.
1600
1601 new parent,child
1602 set parent=""
1603 set order=$get(order,1)
1604 set paginate=$get(paginate,0)
1605 set countNodes=$get(countNodes,0)
1606
1607 new len set len=$length(current)
1608 new lastChar set lastChar=$extract(current,len)
1609 if lastChar'=")" do
1610 . if current'["(" quit
1611 . if lastChar="," set current=$extract(current,1,len-1)
1612 . if lastChar="(" set current=$extract(current,1,len-1) quit
1613 . set current=current_")"
1614
1615BNLoop
1616 if current="" goto BNDone
1617 set child=$$ShowNodes(current,order,paginate,countNodes)
1618 if child'="" do
1619 . set parent(child)=current
1620 . set current=child
1621 else set current=$get(parent(current))
1622 goto BNLoop
1623BNDone
1624 quit
1625
1626
1627ShowNodes(pArray,order,paginate,countNodes)
1628 ;"Purpose: To display all the nodes of the given array
1629 ;"Input: pArray -- NAME OF array to display
1630 ;" order -- OPTIONAL, default=1; 1 for forward, -1 for backwards order
1631 ;" paginate -- OPTIONAL, default=0; 0=no pagination, 1=pause after each page
1632 ;" countNodes -- OPTIONAL, default=0; 1=show number of child nodes.
1633 ;"Results: returns NAME OF next node to display (or "" if none)
1634
1635 new TMGi
1636 new count set count=1
1637 new Answers
1638 new someShown set someShown=0
1639 new abort set abort=0
1640 set paginate=$get(paginate,0)
1641 new pageCount set pageCount=0
1642 new pageLen set pageLen=20
1643 set countNodes=$get(countNodes,0)
1644
1645 write pArray,!
1646 set TMGi=$order(@pArray@(""),order)
1647 if TMGi'="" for do quit:(TMGi="")!(abort=1)
1648 . write count,". +--[",TMGi,"]"
1649 . if countNodes=1 write "(",$$ListCt($name(@pArray@(TMGi))),")"
1650 . write "=",$extract($get(@pArray@(TMGi)),1,40),!
1651 . set someShown=1
1652 . set Answers(count)=$name(@pArray@(TMGi))
1653 . set count=count+1
1654 . new temp read *temp:0
1655 . if temp'=-1 set abort=1
1656 . set pageCount=pageCount+1
1657 . if (paginate=1)&(pageCount>pageLen) do
1658 . . new temp
1659 . . read "Press [ENTER] to continue (^ to stop list)...",temp:$get(DTIME,3600),!
1660 . . if temp="^" set abort=1
1661 . . set pageCount=0
1662 . set TMGi=$order(@pArray@(TMGi),order)
1663
1664 if someShown=0 write " (no data)",!
1665 write !,"Enter # to browse (^ to backup): ^//"
1666 new temp read temp:$get(DTIME,3600),!
1667
1668 new result set result=$get(Answers(temp))
1669
1670 quit result
1671
1672
1673BRWSASK2
1674 ;"Purpose: Improved... Ask user for the name of an array, then display nodes
1675
1676 new current
1677 new order set order=1 ;"default = forward display.
1678 new countNodes set countNodes=0 ;"no counting
1679 write !
1680 read "Enter name of array (or File number) to display nodes in: ",current:$get(DTIME,3600),!
1681 if +current=current do
1682 . set current=$get(^DIC(+current,0,"GL"))
1683 . if current="" write "File number not found. Quitting.",! quit
1684 . write "Browsing array: ",current,!
1685 if current="" set current="^"
1686 if current="^" goto BA2Done
1687
1688 new % set %=2 ;" default= NO
1689 write "Display in REVERSE order? " do YN^DICN write !
1690 if %=1 set order=-1
1691 if %=-1 goto BA2Done
1692
1693 set %=2
1694 write "Show number of subnodes? " do YN^DICN write !
1695 if %=1 set countNodes=1
1696 if %=-1 goto BA2Done
1697
1698 do BRWSNOD2(current,order,countNodes)
1699BA2Done
1700 quit
1701
1702BRWSNOD2(curRef,Order,countNodes)
1703 ;"Purpose: to display nodes of specified array
1704 ;"Input: curRef -- The reference to display
1705 ;" order -- OPTIONAL, default=1; 1 for forward, -1 for backwards order
1706 ;" paginate -- OPTIONAL, default=0; 0=no pagination, 1=pause after each page
1707 ;" countNodes -- OPTIONAL, default=0; 1=show number of child nodes.
1708 set curRef=$$CREF^DILF(curRef)
1709 if curRef="" goto BN2Done
1710 new TMGBRWORDER set TMGBRWORDER=$get(order,1)
1711 new TMGBRWCN set TMGBRWCN=$get(countNodes,0)
1712 if $$ShowNod2(curRef,TMGBRWORDER,TMGBRWCN)
1713BN2Done quit
1714
1715ShowNod2(pArray,order,countNodes)
1716 ;"Purpose: To display all the nodes of the given array
1717 ;" UPDATED function to use Scroller box.
1718 ;"Input: pArray -- NAME OF array to display
1719 ;" order -- OPTIONAL, default=1; 1 for forward, -1 for backwards order
1720 ;" countNodes -- OPTIONAL, default=0; 1=show number of child nodes.
1721 ;"Results: returns NAME OF next node to display (or "" if none)
1722
1723 new TMGi,Option
1724 new dispArray,dispI set dispI=1
1725 set order=$get(order,1)
1726 set countNodes=$get(countNodes,0)
1727 ;
1728 set TMGi="" for set TMGi=$order(@pArray@(TMGi),order) quit:(TMGi="") do
1729 . new s set s=" +---["_TMGi_"]"
1730 . if countNodes=1 set s=s_"("_$$ListCt($name(@pArray@(TMGi)))_")"
1731 . new s2 set s2=$extract($get(@pArray@(TMGi)),1,40)
1732 . if s2'="" set s=s_"="_s2
1733 . if $data(@pArray@(TMGi))>9 set s=s_" ..."
1734 . set dispArray(dispI,s)=$name(@pArray@(TMGi)),dispI=dispI+1
1735 if $data(dispArray)=0 set dispArray(dispI,"<NO DATA>")="",dispI=dispI+1
1736 ;
1737 set Option("HEADER",1)="Data for "_pArray
1738 set Option("FOOTER",1,1)="? Help"
1739 set Option("FOOTER",1,2)="LEFT Backup"
1740 set Option("FOOTER",1,3)="RIGHT Browse IN"
1741 set Option("ON SELECT")="HndOnSel^TMGMISC"
1742 set Option("ON CMD")="HndOnCmd^TMGMISC"
1743 ;
1744 write #
1745 do Scroller^TMGUSRIF("dispArray",.Option)
1746 quit pArray
1747
1748HndOnSel(pArray,Option,Info)
1749 ;"Purpose: handle ON SELECT event from Scroller^TMGUSRIF, launched by ShowNod2
1750 ;"Input: pArray,Option,Info -- see documentation in Scroller^TMGUSRIF
1751 ;" Info has this:
1752 ;" Info("CURRENT LINE","NUMBER")=number currently highlighted line
1753 ;" Info("CURRENT LINE","TEXT")=Text of currently highlighted line
1754 ;" Info("CURRENT LINE","RETURN")=return value of currently highlighted line
1755 ;
1756 new ref set ref=$get(Info("CURRENT LINE","RETURN"))
1757 if ref'="" if $$ShowNod2(ref,TMGBRWORDER,TMGBRWCN)
1758 quit
1759
1760
1761HndOnCmd(pArray,Option,Info)
1762 ;"Purpose: handle ON SELECT event from Scroller, launched by ShowNod2
1763 ;"Input: pArray,Option,Info -- see documentation in Scroller
1764 ;" Info has this:
1765 ;" Info("USER INPUT")=input
1766 ;" Info("CURRENT LINE","NUMBER")=number currently highlighted line
1767 ;" Info("CURRENT LINE","TEXT")=Text of currently highlighted line
1768 ;" Info("CURRENT LINE","RETURN")=return value of currently highlighted line
1769 ;" TMGSCLRMSG,TMGBRWORDER,TMGBRWCN - globally scoped variables that are used.
1770 ;"results: none (required to have none)
1771
1772 new input set input=$$UP^XLFSTR($get(Info("USER INPUT")))
1773 if input["LEFT" do
1774 . set TMGSCLRMSG="^"
1775 else if input["RIGHT" do
1776 . new ref set ref=$get(Info("CURRENT LINE","RETURN"))
1777 . if ref'="" if $$ShowNod2(ref,TMGBRWORDER,TMGBRWCN)
1778 else if input="?" do
1779 . write !,"Use UP and DOWN cursor keys to select global node",!
1780 . write "LEFT will back up, and RIGHT or ENTER will browse node",!
1781 . write "^ at the ':' prompt will cause a back up of one level",!
1782 . do PressToCont^TMGUSRIF
1783 else if input'="" do
1784 . write !,"Input ",$get(Info("USER INPUT"))," not recognized.",!
1785 . do PressToCont^TMGUSRIF
1786 ;
1787 write #
1788 quit
1789
1790
1791IsNumeric(value)
1792 ;"Purpose: to determine if value is pure numeric.
1793 ;"Note: This will be a more involved test than simply: if +value=value, because
1794 ;" +"00001" is not the same as "1" or 1. Also +"123abc"--> 123, but is not pure numeric
1795 set value=$$Trim^TMGSTUTL(value) ;" trim whitespace
1796 set value=$$TrimL^TMGSTUTL(value,"0") ;"trim leading zeros
1797 quit (value=+value)
1798
1799
1800ClipDDigits(Num,digits)
1801 ;"Purpose: to clip number to specified number of decimal digits
1802 ;" e.g. 1234.9876543 --> 1234.9876 if digits=4
1803 ;"Input: Num -- the number to process
1804 ;" digits -- the number of allowed decimal digits after the decimal point
1805 ;"Result: returns the number clipped to the specified number of decimals
1806 ;" note: this is a CLIP, not a ROUND function
1807
1808 new result set result=Num
1809 new decimals set decimals=$extract($piece(Num,".",2),1,digits)
1810 set result=$piece(Num,".",1)
1811 if decimals'="" set result=result_"."_decimals
1812CDgDone
1813 quit result
1814
1815
1816Diff(File,IENS1,IENS2,Result)
1817 ;"Purpose: to determine how two records differ in a given file
1818 ;"Input: File -- file name or number of file containing records to be compared
1819 ;" IENS1 -- the IEN (or IENS if file is a subfile) of the first record to be compared
1820 ;" IENS2 -- the IEN (or IENS if file is a subfile) of the second record to be compared
1821 ;" Result -- PASS BE REFERENCE, and OUT PARAMETER
1822 ;" Format of output Result array. Will only hold differences
1823 ;" e.g. Result(FieldNum,"EXTRA",1)=valueOfField
1824 ;" e.g. Result(FieldNum,"EXTRA",2)=valueOfField
1825 ;" e.g. Result(FieldNum,"CONFLICT",1)=valueOfField
1826 ;" e.g. Result(FieldNum,"CONFLICT",2)=valueOfField
1827 ;" e.g. Result(FieldNum,"FIELD NAMES")=FieldName
1828 ;"Note: this will consider only the first 1024 characters of WP fields
1829 ;"Note: For now, multiples (subfiles) will be IGNORED
1830
1831 new fileNum set fileNum=+$get(File)
1832 if fileNum=0 set fileNum=$$GetFileNum^TMGDBAPI(.File)
1833 new subFileNum
1834
1835 new field set field=$order(^DD(fileNum,0))
1836 if +field>0 for do quit:(+field'>0)
1837 . set subFileNum=+$piece($get(^DD(fileNum,field,0)),"^",2) ;"get subfile number, or 0 if not subfile
1838 . if subFileNum>0 do ;"finish later...
1839 . . ;"Here I need to somehow cycle through each record of the subfile and compare THOSE
1840 . . new subResult
1841 . . do DiffSubFile(subFileNum,.IENS1,.IENS2,.subResult) ;"null function for now
1842 . . ;"do some merge between Result and subResult
1843 . else do Diff1Field(fileNum,field,.IENS1,.IENS2,.Result)
1844 . set field=$order(^DD(fileNum,field))
1845
1846 quit
1847
1848
1849Diff1Field(File,Field,IENS1,IEN2,Result)
1850 ;"Purpose: to determine how two records differ for one given field
1851 ;"Input: File -- file NUMBER of file containing records to be compared
1852 ;" Field -- Field NUMBER to be evaluated
1853 ;" IENS1 -- the IEN (or IENS if file is a subfile) of the first record to be compared
1854 ;" IENS2 -- the IEN (or IENS if file is a subfile) of the second record to be compared
1855 ;" Result -- PASS BE REFERENCE, and OUT PARAMETER
1856 ;" Format of output Result array. Will only hold differences
1857 ;" e.g. Result(FieldNum,"EXTRA",1)=valueOfField
1858 ;" e.g. Result(FieldNum,"EXTRA",2)=valueOfField
1859 ;" e.g. Result(FieldNum,"CONFLICT",1)=valueOfField
1860 ;" e.g. Result(FieldNum,"CONFLICT",2)=valueOfField
1861 ;" e.g. Result(FieldNum,"FIELD NAMES")=FieldName
1862 ;"Results: none (data returned in Result out parameter)
1863 ;"Note: only first 1023 characters of a WP field will be compared
1864
1865 new value1,value2,TMGWP1,TMGWP2
1866 new fieldName set fieldName=$piece($get(^DD(File,Field,0)),"^",1)
1867
1868 set value1=$$GET1^DIQ(File,IENS1,Field,"","TMGWP1")
1869 set value2=$$GET1^DIQ(File,IENS2,Field,"","TMGWP2")
1870
1871 if $data(TMGWP1)!$data(TMGWP2) do
1872 . set value1=$$WPToStr^TMGSTUTL("TMGWP1"," ",1023) ;"Turn first 1023 characters into one long string
1873 . set value2=$$WPToStr^TMGSTUTL("TMGWP2"," ",1023) ;"Turn first 1023 characters into one long string
1874
1875 if value1=value2 goto D1FDone ;"default is no conflict
1876 if (value2="")&(value1'="") do
1877 . set Result(Field,"EXTRA",1)=value1
1878 . set Result(Field,"FIELD NAME")=fieldName
1879 if (value1="")&(value2'="") do
1880 . set Result(Field,"EXTRA",2)=value2
1881 . set Result(Field,"FIELD NAME")=fieldName
1882 if (value1'="")&(value2'="") do
1883 . set Result(Field,"CONFLICT",1)=value1
1884 . set Result(Field,"CONFLICT",2)=value2
1885 . set Result(Field,"FIELD NAME")=fieldName
1886
1887D1FDone
1888 quit
1889
1890DiffSubFile(SubFile,IENS1,IENS2,Result)
1891
1892 quit
1893
1894
1895
1896Array2XML(pArray,pResult,indent)
1897 ;"Purpose: to convert an array into XML format
1898 ;"Input: pArray -- the NAME OF the array to convert (array can be any format)
1899 ;" pResult -- the NAME OF the output array.
1900 ;" format:
1901 ;" Result(0)="<?xml version='1.0'?>"
1902 ;" Result(1)="<Node id="Node Name">Node Value</Node>
1903 ;" Result(2)=" <Node id="Node Name">Node Value</Node>
1904 ;" Result(3)=" <Node id="Node Name">Node Value</Node>
1905 ;" Result(4)=" <Node id="Node Name">Node Value ;"<--- start subnode
1906 ;" Result(5)=" <Node id="Node Name">Node Value</Node>
1907 ;" Result(6)=" <Node id="Node Name">Node Value</Node>
1908 ;" Result(7)=" </Node> ;"<---- end subnode
1909 ;" Result(8)=" <Node id="Node Name">Node Value</Node>
1910 ;" indent -- OPTIONAL. if 1, then subnodes have whitespace indent for pretty viewing
1911 ;"Output: pResult is filled
1912 ;"Result: none.
1913 ;"Note: example call do Array2XML("MyArray","MyOutput",1)
1914
1915 kill @pResult
1916 set @pResult@(0)=0
1917 if $get(indent)=1 set indent=""
1918 else set indent=-1
1919 do A2XNode(pArray,pResult,.indent)
1920 set @pResult@(0)=$$XMLHDR^MXMLUTL
1921
1922 quit
1923
1924
1925A2XNode(pArray,pResult,indent)
1926 ;"Purpose: To do the output for Array2XML
1927 ;"Input: pArray - the NAME OF the array to convert
1928 ;" pResult - the NAME OF the output array.
1929 ;" Format to be as described in Array2XML, which one exception: Result(0)=MaxLine
1930 ;" indent -- OPTIONAL. if numeric value, then subnodes WON't whitespace indent for pretty viewing
1931 ;" otherwise, indent is string holding space to indent
1932 ;"Result: none
1933
1934 new i,s
1935 set indent=$get(indent)
1936 set i=$order(@pArray@(""))
1937 if i'="" for do quit:(i="")
1938 . set s="" if indent'=-1 set s=indent
1939 . set s=s_"<Node id="""_i_""">"_$get(@pArray@(i))
1940 . set s=$$SYMENC^MXMLUTL(s)
1941 . if $data(@pArray@(i))>1 do
1942 . . set @pResult@(0)=+$get(@pResult@(0))+1 ;"Increment maxline
1943 . . set @pResult@(@pResult@(0))=s
1944 . . new subIndent set subIndent=-1
1945 . . if indent'=-1 set subIndent=indent_" "
1946 . . do A2XNode($name(@pArray@(i)),pResult,subIndent)
1947 . . set s="" if indent'=-1 set s=indent
1948 . . set s=s_"</Node>"
1949 . else do
1950 . . set s=s_"</Node>"
1951 . set @pResult@(0)=+$get(@pResult@(0))+1 ;"Increment maxline
1952 . set @pResult@(@pResult@(0))=s
1953 . set i=$order(@pArray@(i))
1954
1955 quit
1956
1957
1958Up(pArray)
1959 ;"Purpose: Return a NAME of an array that is one level 'up' from the
1960 ;" the current array. This really means one node shorter.
1961 ;" e.g. '^MyVar('plant','tree','apple tree')' --> '^MyVar('plant','tree')'
1962 ;"Results: returns shorten array as above, or "" if error
1963
1964 new result set result=""
1965 if $get(pArray)="" goto UpDone
1966 set result=$qsubscript(pArray,0)
1967 new i
1968 for i=1:1:$qlength(pArray)-1 do
1969 . set result=$name(@result@($qsubscript(pArray,i)))
1970
1971UpDone quit result
1972
1973
1974LaunchScreenman(File,FormIEN,RecIEN,Page)
1975 ;"Purpose: to provide a programatic launching point for displaying a
1976 ;" screenman form for editing a record
1977 ;"Input: File -- the IEN of file to be edited
1978 ;" FormIEN -- the IEN in file FORM (.403)
1979 ;" RecIEN -- the IEN in File to edit
1980 ;" Page -- OPTIONAL, default=1. The starting page of form.
1981 ;"Note: Form should be compiled before calling the function. This can be
1982 ;" achieved by running the form once from ^DDSRUN (or viat Fileman menu)
1983
1984 new DDSFILE set DDSFILE=File
1985 new DDSRUNDR set DDSRUNDR=FormIEN
1986 new DDSPAGE set DDSPAGE=+$get(Page,1)
1987 new DA set DA=RecIEN
1988
1989 do REC+9^DDSRUN ;"this goes against SAC conventions.
1990
1991 quit
1992
1993
1994NumSigChs()
1995 ;"Purpose: To determine how many characters are signficant in a variable name
1996 ;" I.e. older versions of GT.M had only the first 8 characters as
1997 ;" significant. Newer versions allow more characters to be significant.
1998
1999 new pVar1,pVar2,i
2000 set pVar1="zb",i=2
2001 new done set done=0
2002 for do quit:done
2003 . set i=i+1
2004 . set pVar2=pVar1_"b"
2005 . set pVar1=pVar1_"a"
2006 . new @pVar2,@pVar1
2007 . set @pVar1=7
2008 . if $get(@pVar2)=@pVar1 set done=1
2009
2010 quit (i-1)
2011
2012
2013SrchReplace(File,Field,Caption)
2014 ;"Purpose: To do a text-based search and replace in all record of
2015 ;" specified file, in the text of the specified file.
2016 ;" Note: this does not work with pointer fields. It would
2017 ;" fail to find the matching text in the pointer value and ignore it.
2018 ;" It does not support subfiles.
2019 ;"Input: File -- the file name or number to work with.
2020 ;" Field -- the field name or number to work with
2021 ;" Caption -- OPTIONAL. A descriptive text of action.
2022 ;"Output: Data in records will be changed via Fileman and errors (if found)
2023 ;" will be written to console.
2024 ;"Results: none.
2025
2026 if $get(File)="" goto SRDone
2027 if $get(Field)="" goto SRDone
2028 new OKToCont set OKToCont=1
2029 if +Field'=Field set OKToCont=$$SetFileFldNums^TMGDBAPI(File,Field,.File,.Field)
2030 if OKToCont=0 goto SRDone
2031
2032 if $get(Caption)'="" do
2033 . write !,!,Caption,!
2034 . write "----------------------------------------------------",!!
2035
2036 new searchS,replaceS,%
2037SR1
2038 write "Enter characters/words to SEARCH for (^ to abort): "
2039 read searchS:$get(DTIME,3600),!
2040 if (searchS="")!(searchS="^") goto SRDone
2041 write "REPLACE with (^ to abort): "
2042 read replaceS:$get(DTIME,3600),!
2043 if (replaceS="^") goto SRDone
2044 write "'",searchS,"'-->'",replaceS,"'",!
2045 set %=1
2046 write "OK" do YN^DICN write !
2047 if %=1 goto SR2
2048 if %=-1 goto SRDone
2049 goto SR1
2050
2051SR2
2052 new Itr,IEN,CurValue,abort,count
2053 new ref set ref=$get(^DIC(File,0,"GL"))
2054 set ref=$$CREF^DILF(ref)
2055 if ref="" goto SRDone
2056 new node set node=$piece($get(^DD(File,Field,0)),"^",4)
2057 new piece set piece=$piece(node,";",2)
2058 set node=$piece(node,";",1)
2059
2060 set abort=0,count=0
2061 set IEN=$$ItrInit^TMGITR(File,.Itr)
2062 do PrepProgress^TMGITR(.Itr,20,0,"IEN")
2063 if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort
2064 . if $$UserAborted^TMGUSRIF() set abort=1 quit
2065 . set CurValue=$piece($get(@ref@(IEN,node)),"^",piece)
2066 . if CurValue'[searchS quit
2067SR3 . new newValue set newValue=$$Substitute^TMGSTUTL(CurValue,searchS,replaceS)
2068 . new TMGFDA,TMGMSG
2069 . set TMGFDA(File,IEN_",",Field)=newValue
2070 . do FILE^DIE("K","TMGFDA","TMGMSG")
2071 . do ShowIfDIERR^TMGDEBUG(.TMGMSG)
2072 . set count=count+1
2073 do ProgressDone^TMGITR(.Itr)
2074
2075 write count," records changed",!
2076 do PressToCont^TMGUSRIF
2077
2078SRDone
2079 quit
2080
2081
2082MkMultList(input,List)
2083 ;"Purpose: To create a list of entries, given a string containing a list of entries.
2084 ;"Input: input -- a string of user input. E.g.: '345,3,12678,78-85,2' or '78-93' or '15'
2085 ;" List -- PASS BY REFERENCE. An OUT PARAMETER.
2086 ;"Output: List will be filled as follows:
2087 ;" List(Entry number)=""
2088 ;" List(Entry number)=""
2089 ;" List(Entry number)=""
2090 ;"Result: 1 if values found, 0 none found, or error encountered
2091
2092 new result set result=0
2093
2094 new i
2095 for i=1:1:$length(input,",") do
2096 . new value set value=$piece(input,",",i)
2097 . if +value=value do
2098 . . set List(value)=""
2099 . . set result=1
2100 . else if value["-" do
2101 . . new n1,n2
2102 . . set n1=+$piece(value,"-",1)
2103 . . set n2=+$piece(value,"-",2)
2104 . . set result=$$MkRangeList(n1,n2,.List)
2105
2106 quit result
2107
2108
2109MkRangeList(Num,EndNum,List)
2110 ;"Purpose: To create a list of entries, given a starting and ending number
2111 ;"Input: Num -- the start entry number
2112 ;" EndNum -- OPTIONAL, the last entry number (if supplied then all values
2113 ;" between Num and Endnum will be added to list
2114 ;" List -- PASS BY REFERENCE. An OUT PARAMETER.
2115 ;"Output: List will be filled as follows:
2116 ;" List(Entry number)=""
2117 ;" List(Entry number)=""
2118 ;" List(Entry number)=""
2119 ;"Result: 1 if value input found, otherwise 0
2120
2121 new result set result=0
2122 set EndNum=$get(EndNum,Num)
2123 if (+Num'=Num)!(+EndNum'=EndNum) goto MkRLDone
2124
2125 new i
2126 for i=Num:1:EndNum do
2127 . set List(i)=""
2128 . set result=1
2129
2130MkRLDone
2131 quit result
2132
2133
2134Flags(Var,Flag,Mode)
2135 ;"Purpose: To set,delete,or toggle a flag stored in Var
2136 ;"Input: Var -- PASS BY REFERENCE. The variable holding the flags
2137 ;" Flag -- a single character flag to be stored in Var
2138 ;" Mode: should be: 'SET','DEL',or 'TOGGLE'. Default is 'SET'
2139 ;"Results: none
2140
2141 set Flag=$get(Flag,"SET")
2142 set Var=$get(Var)
2143 if $get(Mode)="TOGGLE" do
2144 . if Var[Flag set Mode="DEL"
2145 . else set Mode="SET"
2146 if $get(Mode)="SET" do
2147 . if Var[Flag quit
2148 . set Var=Var_Flag
2149 if $get(Mode)="DEL" do
2150 . if Var'[Flag quit
2151 . set Var=$piece(Var,Flag,1)_$piece(Var,Flag,2)
2152
2153 quit
2154
2155
2156CompABArray(pArrayA,pArrayB,pExtraB,pMissingB,pDiff,ProgressFn,IncVar)
2157 ;"Purpose: To compare two arrays, A & B, and return results in OutArray
2158 ;" that specifies how ArrayB differs from ArrayA
2159 ;"Input: pArrayA -- PASS BY NAME. Baseline array to be compared against
2160 ;" pArrayB -- PASS BY NAME. Array to be compare against ArrayA
2161 ;" pExtraB -- PASS BY NAME. An OUT PARAMETER. Array of extra info from B
2162 ;" OPTIONAL. If not provided, then data not filled.
2163 ;" pMissingB -- PASS BY NAME. An OUT PARAMETER. Array of missing info
2164 ;" OPTIONAL. If not provided, then data not filled.
2165 ;" pDiff -- PASS BY NAME. An OUT PARAMETER. Output as below.
2166 ;" OPTIONAL. If not provided, then data not filled.
2167 ;" @pOutArray@("A",node,node,node,...)=different value
2168 ;" @pOutArray@("B",node,node,node,...)=different value
2169 ;" ProgressFn -- OPTIONAL -- M code to exec as a progress indicator
2170 ;" IncVar -- OPTIONAL -- a counter that can be referenced by ProgressFn
2171 ;"Results: 0=OK, 1=aborted
2172
2173 new indexA,indexB
2174
2175 set IncVar=+$get(IncVar)
2176 set ProgressFn=$get(ProgressFn)
2177 set pExtraB=$get(pExtraB)
2178 set pMissingB=$get(pMissingB)
2179 set pdiff=$get(pDiff)
2180 new abort set abort=0
2181 new Compared
2182
2183 set indexA=""
2184 for set indexA=$order(@pArrayA@(indexA)) quit:(indexA="")!abort do
2185 . set IncVar=IncVar+1
2186 . if (IncVar#10=1),(ProgressFn'="") do quit:(abort)
2187 . . new $etrap set $etrap="set $etrap="""",$ecode="""""
2188 . . xecute ProgressFn
2189 . . write !,pArrayA,"(",indexA,") ",! do CUU^TMGTERM(2) ;"temp
2190 . . if $$UserAborted^TMGUSRIF() set abort=1 quit
2191 . if $data(@pArrayB@(indexA))=0 do quit
2192 . . if (pMissingB'="") merge @pMissingB@(pArrayA,indexA)=@pArrayA@(indexA)
2193 . new s1,s2
2194 . set s1=$get(@pArrayA@(indexA))
2195 . set s2=$get(@pArrayB@(indexA))
2196 . if s1'=s2 do
2197 . . if pDiff="" quit
2198 . . if $$TRIM^XLFSTR(s1)=$$TRIM^XLFSTR(s2) quit
2199 . . set @pDiff@("A",pArrayA,indexA)=s1
2200 . . set @pDiff@("B",pArrayA,indexA)=s2
2201 . set abort=$$CompABArray($name(@pArrayA@(indexA)),$name(@pArrayB@(indexA)),.pExtraB,.pMissingB,.pDiff,.ProgressFn,.IncVar)
2202 . set Compared($name(@pArrayA@(indexA)),$name(@pArrayB@(indexA)))=1
2203
2204 new temp set temp=1
2205 set indexB=""
2206 for set indexB=$order(@pArrayB@(indexB)) quit:(indexB="")!abort do
2207 . set temp=temp+1
2208 . if (temp#10=1) do quit:(abort)
2209 . . write !,pArrayA,"(",indexB,") ",! do CUU^TMGTERM(2) ;"temp
2210 . . if $$UserAborted^TMGUSRIF() set abort=1 quit
2211 . if $data(@pArrayA@(indexB))=0 do quit
2212 . . if (pExtraB'="") merge @pExtraB@(pArrayA,indexB)=@pArrayB@(indexB)
2213 . if $get(Compared($name(@pArrayA@(indexB)),$name(@pArrayB@(indexB))))=1 do quit ;"already checked
2214 . . new temp
2215 . set abort=$$CompABArray($name(@pArrayA@(indexB)),$name(@pArrayB@(indexB)),.pExtraB,.pMissingB,.pDiff)
2216
2217 quit abort
2218
2219
2220FixArray(ref)
2221 ;"Purpose: Convert an array like this:
2222 ;" @ref@("^DD(2,.362)",21,1,0) --> @ref@("^DD",2,.362,21,1,0)
2223 ;" @ref@("^DD(2,.362)",21,2,0) --> @ref@("^DD",2,.362,21,2,0)
2224 ;" @ref@("^DD(2,.362)",23,0) --> @ref@("^DD",2,.362,23,0)
2225 ;" @ref@("^DD(2,.362)",23,1,0) --> @ref@("^DD",2,.362,23,1,0)
2226 ;" @ref@("^DD(2,0,""IX"")","ACFL2",2,.312) --> @ref@("^DD",2,0,"IX","ACFL2",2,.312)
2227 ;" @ref@("^DD(2,0,""IX"")","AEXP",2,.351) --> @ref@("^DD",2,0,"IX","AEXP",2,.351)
2228 ;" @ref@("^DD(2,0,""IX"")","TMGS",2,22701) --> @ref@("^DD",2,0,"IX","TMGS",2,22701)
2229 ;" @ref@("^DD(2,0,""PT"")",228.1,.02) --> @ref@("^DD",2,0,"PT",228.1,.02)
2230 ;" @ref@("^DD(2,0,""PT"")",228.2,.02) --> @ref@("^DD",2,0,"PT",228.2,.02)
2231 ;" @ref@("^DD(2,0,""PT"")",19620.92,.08) --> @ref@("^DD",2,0,"PT",19620.92,.08)
2232 ;" @ref@("^DD(2,0,""PT"",115)",.01) --> @ref@("^DD",2,0,"PT",115,.01)
2233 ;"Input: ref -- PASS BY NAME
2234 ;"Output: contents of @ref are converted as above.
2235 ;"Results: none
2236
2237 new origRef set origRef=ref
2238 new output,s1,i
2239 for set ref=$query(@ref) quit:(ref="") do
2240 . set s1=$qsubscript(ref,1)
2241 . new newRef set newRef="output"
2242 . new startI set startI=1
2243 . if s1["(" do
2244 . . set startI=2
2245 . . set newRef=newRef_"("""_$qs(s1,0)_""")"
2246 . . if $qlength(s1)>1 for i=1:1:$qlength(s1) do
2247 . . . set newRef=$name(@newRef@($qsubscript(s1,i)))
2248 . for i=startI:1:$qlength(ref) do
2249 . . new s3 set s3=$qsubscript(ref,i)
2250 . . set newRef=$name(@newRef@(s3))
2251 . merge @newRef=@ref
2252
2253 kill @origRef
2254 merge @origRef=output ;"put changes back into original array
2255
2256 quit
2257
2258
2259Caller(Code)
2260 ;"Purpose: From call stack, return the location of the caller of the function
2261 ;" Note this will not return the address of the function calling
2262 ;" Caller, but instead, the address of the function before that
2263 ;" in the stack.
2264 ;" So a function (A) can call this routine to find out who called it (A).
2265 ;"Input: Code -- OPTIONAL. PASS BY REFERANCE, AN OUT PARAMETER
2266 ;" Filled with line of calling code.
2267 set Code=$STACK($STACK-2,"MCODE")
2268 new result set result=$STACK($STACK-2,"PLACE")
2269 if result="" set result="?"
2270 quit result
2271
Note: See TracBrowser for help on using the repository browser.