Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

TMGMISC.m@ 834

Last change on this file since 834 was 796, checked in by Kevin Toppenberg, 14 years ago
Initial upload
File size: 87.8 KB

Rev	Line
[796]	1	TMGMISC ;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
	83	STARTRPC ;
	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	;
	90	STOPRPC ;
	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	;
	97	STOPTSKM ;
	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	;
	107	EDITPT(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	;
	123	A 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	;
	170	EDITDONE
	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
	177	GetPersonClass(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
	209	GPCDone
	210	quit RecNum
	211
	212
	213	DocLines(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
	251	WPChars(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
	276	RoundUp(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
	290	RoundDn(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
	302	Round(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
	322	InList(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
	344	ILDone
	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
	369	LISTCT(pArray) ;" SAAC complient entry point.
	370	quit $$ListCt(pArray)
	371	ListCt(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
	393	NodeCt(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
	408	IndexOf(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
	426	ListPack(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
	458	ListTrim(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
	492	ListAdd(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
	515	ListAnd(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
	552	ListNot(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!
	590	DTFormat(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
	655	FDTDone
	656	quit result
	657
	658
	659	ProcessToken(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
	848	PTDone
	849	set Token=""
	850	quit
	851
	852
	853
	854
	855	CompDOB(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
	923	CDOBDone
	924	quit result
	925
	926
	927
	928	BrowseBy(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
	961	ShowBy(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
	1018	SBDone
	1019	quit
	1020
	1021
	1022
	1023	CompName(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
	1079	CompNDone
	1080	quit result
	1081
	1082
	1083
	1084	FormatName(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
	1174	FormatNDone
	1175	if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"FormatName^TMGGDFN")
	1176	quit result
	1177
	1178
	1179	IsSuffix(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
	1191	IsTitle(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
	1206	HEXCHR(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
	1217	HEXCHR2(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
	1247	HEX2NUM(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
	1269	OR(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
	1282	ParsePos(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
	1305	ScanMod(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
	1345	SMDone
	1346	quit
	1347
	1348
	1349	ConvertPos(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
	1399	CPDone
	1400	quit cpResult
	1401
	1402
	1403
	1404
	1405	CompArray(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
	1425	CADone quit result
	1426
	1427
	1428
	1429	IterTemplate(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
	1448	ItTDone quit result
	1449
	1450	CtTemplate(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
	1459	NumPieces(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
	1485	LastPiece(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
	1499	LPDone
	1500	quit result
	1501
	1502	ParseLast(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
	1521	PLDone
	1522	quit result
	1523
	1524
	1525
	1526	NPsDone
	1527	quit result
	1528
	1529
	1530	Trim1Node(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
	1553	T1NDone
	1554	quit result
	1555
	1556
	1557	BROWSEASK
	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)
	1592	BADone
	1593	quit
	1594
	1595
	1596	BROWSENODES(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
	1617	BNLoop
	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
	1625	BNDone
	1626	quit
	1627
	1628
	1629	ShowNodes(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
	1675	BRWSASK2
	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)
	1701	BA2Done
	1702	quit
	1703
	1704	BRWSNOD2(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)
	1715	BN2Done quit
	1716
	1717	ShowNod2(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
	1750	HndOnSel(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
	1763	HndOnCmd(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
	1793	IsNumeric(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
	1802	ClipDDigits(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
	1814	CDgDone
	1815	quit result
	1816
	1817
	1818	Diff(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
	1851	Diff1Field(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
	1889	D1FDone
	1890	quit
	1891
	1892	DiffSubFile(SubFile,IENS1,IENS2,Result)
	1893
	1894	quit
	1895
	1896
	1897
	1898	Array2XML(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
	1927	A2XNode(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
	1960	Up(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
	1973	UpDone quit result
	1974
	1975
	1976	LaunchScreenman(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
	1996	NumSigChs()
	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
	2015	SrchReplace(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,%
	2039	SR1
	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
	2053	SR2
	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
	2069	SR3 . 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
	2080	SRDone
	2081	quit
	2082
	2083
	2084	MkMultList(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
	2111	MkRangeList(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
	2132	MkRLDone
	2133	quit result
	2134
	2135
	2136	Flags(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
	2158	CompABArray(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
	2222	FixArray(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
	2261	Caller(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.

Context Navigation

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

Download in other formats: