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

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

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