TMGMISC ;TMG/kst/Misc utility library ;03/25/06; 5/24/10 ;;1.0;TMG-LIB;**1**;07/12/05 ;"TMG MISCELLANEOUS FUNCTIONS ;"Kevin Toppenberg MD ;"GNU General Public License (GPL) applies ;"7-12-2005 ;"======================================================================= ;" API -- Public Functions. ;"======================================================================= ;"STARTRPC -- Start up RPCBroker on port 9210 ;"STOPRPC -- Stop RPCBroker on port 9210 ;"STOPTSKM -- Stop TaskMan non-interactively ;"EDITPT(AddOK) ;"GetPersonClass(PersonClass,ProviderType,Specialty) ;"$$DocLines(IEN,Chars) -- Count number of lines and chars in a 8925 WP field ;"$$WPChars(Ptr) ;"$$RoundUp(n) ;"$$RoundDn(n) ;"$$Round(n) ;"$$InList(Value,ArrayP) -- return if Value is in an array. ;"$$ListCt(pArray) ;"$$LISTCT(pArray) -- same as $$ListCt(pArray) ;"$$NodeCt(pArray) -- count all the nodes in an array ;"$$IndexOf(pArray,value) ;"ListPack(pArray,StartNum,IncValue) ;"ListAdd(pArray,index,value) ;"ListAnd(pArray1,pArray2,pResult) ;"ListNot(pArray1,pArray2,pResult) ;"$$DTFormat(FMDate,format) -- format fileman dates ;"$$CompDOB(DOB1,DOB2) -- compare two dates ;"BrowseBy(CompArray,ByTag) -- Allow a user to interact with dynamic text tree ;"$$CompName(Name1,Name2) -- compare two names ;"$$FormatName(Name) ;"$$HEXCHR(V) -- Take one BYTE and return HEX Values ;"$$HEXCHR2(n,digits) -- convert a number (of arbitrary length) to HEX digits ;"$$HEX2NUM(s) -- convert a string like this $10 to decimal number (e.g.) 16 ;"$$OR(a,b) ; perform a bitwise OR on operands a and b ;"ParsePos(pos,label,offset,routine,dmod) ;"ScanMod(Module,pArray) ;"ConvertPos(Pos,pArray) ;"CompArray(pArray1,pArray2) return if two arrays are identical ;"$$CompABArray(pArrayA,pArrayB,pOutArray) -- FULL compare of two arrays, return diffArray ;"$$IterTemplate(Template,Prior) ;"$$NumPieces(s,delim,maxPoss) -- return number of pieces in string ;"$$LastPiece(s,delim,maxPoss) -- return the last piece of a string ;"$$ParseLast(s,remainS,delim,maxPoss) -- return the last piece AND the first part of the string ;"$$Trim1Node(pRef) -- To shorten a reference by one node. ;"BROWSEASK -- ask user for the name of an array, then display nodes ;"BRWSASK2 -- Improved... Ask user for the name of an array, then display nodes ;"BROWSENODES(current,Order,paginate,countNodes) -- display nodes of specified array ;"BRWSNOD2(curRef,Order,countNodes) -- display nodes of specified array, using Scroll box ;"ShowNodes(pArray,order,paginate,countNodes) -- display all the nodes of the given array ;"ShowNod2(pArray,order,countNodes) -- display all the nodes of the given array, using Scroll box ;"$$IsNumeric(value) -- determine if value is pure numeric. ;"$$ClipDDigits(Num,digits) -- clip number to specified number of digits ;"LaunchScreenman(File,FormIEN,RecIEN,Page) -- launching point screenman form ;"$$NumSigChs --determine how many characters are signficant in a variable name ;"MkMultList(input,List) -- create a list of entries, given a string containing a list of entries. ;"MkRangeList(Num,EndNum,List) -- create a list of entries, given a starting and ending number ;"$$Caller(Code) -- From call stack, return the location of the caller of the function ;"======================================================================= ;"PRIVATE API FUNCTIONS ;"======================================================================= ;"GetPersonClass(PersonClass,ProviderType,Specialty) ;"ProcessToken(Token,Output) ;"$$IsSuffix(s) ;"$$IsTitle(s) ;"ShowBy(CompArray,ByTag,aOpen,bOpen,cOpen) ;"CtTemplate(Template) -- return the Count of IEN's stored in a SORT TEMPLATE ;"======================================================================= ;"DEPENDENCIES ;" TMGDBAPI ;" TMGIOUTL ;" TMGDEBUG ;" TMGSTUTL ;"======================================================================= ;"======================================================================= STARTRPC ; ;" -- Start up RPCBroker on port 9210 WRITE "Starting RPC Broker on port 9210",! DO STRT^XWBTCP(9210) WRITE ! QUIT ; STOPRPC ; ;" -- Stop RPC Broker on port 9210 WRITE "Stopping RPC Broker on port 9210",! DO STOP^XWBTCP(9210) WRITE ! QUIT ; STOPTSKM ; ;"-- Shut Down Task Managers non-interactively ;" Taken from STOP^ZTMKU ; WRITE !,"Shutting down TaskMan and submanagers." DO GROUP^ZTMKU("SMAN^ZTMKU(NODE)") DO GROUP^ZTMKU("SSUB^ZTMKU(NODE)") WRITE !,"Okay!",! QUIT ; EDITPT(TMGADDOK) ;"Purpose: To ask for a patient name, and then allow editing ;"Input: TMGADDOK: if 1, then adding new patients is allowed ;"Result: none ; DO LO^DGUTL SET DGCLPR="" NEW DGDIV SET DGDIV=$$PRIM^VASITE ; IF DGDIV>0 SET %ZIS("B")=$PIECE($get(^DG(40.8,+DGDIV,"DEV")),U,1) ; KILL %ZIS("B") IF '$data(DGIO),$PIECE(^DG(43,1,0),U,30) do . SET %ZIS="N",IOP="HOME" . DO ^%ZIS ; A DO ENDREG^DGREG($GET(DFN)) DO IF (Y<0) GOTO EDITDONE . WRITE !! . IF $GET(TMGADDOK)=1 DO . . SET DIC=2,DIC(0)="ALEQM" . . SET DLAYGO=2 . ELSE DO . . SET DIC=2,DIC(0)="AEQM" . . SET DLAYGO=0 . KILL DIC("S") . DO ^DIC . KILL DLAYGO . IF Y<0 QUIT . SET (DFN,DA)=+Y . SET DGNEW=$P(Y,"^",3) . NEW Y . DO PAUSE^DG10 . DO BEGINREG^DGREG(DFN) . IF DGNEW DO NEW^DGRP ; IF +$GET(DGNEW) DO . ;" query CMOR for Patient Record Flag Assignments if NEW patient and . ;" display results. . IF $$PRFQRY^DGPFAPI(DFN) DO DISPPRF^DGPFAPI(DFN) ; SET (DGFC,CURR)=0 SET DA=DFN SET DGFC="^1" SET VET=$SELECT($DATA(^DPT(DFN,"VET")):^("VET")'="Y",1:0) ; SET %ZIS="N",IOP="HOME" DO ^%ZIS SET DGELVER=0 ;"DO EN^DGRPD ;"IF $data(DGRPOUT) DO GOTO A ;". DO ENDREG^DGREG($G(DFN)) ;". DO HL7A08^VAFCDD01 ;". KILL DFN,DGRPOUT ; ;"DO HINQ^DG10 IF $D(^DIC(195.4,1,"UP")) IF ^("UP") DO ADM^RTQ3 ; DO REG^IVMCQ($G(DFN)) ;" send financial query ; SET DGRPV=0 DO EN1^DGRP ; EDITDONE IF $PIECE($GET(^VA(200,DUZ,"TMG")),"^",1)="C" DO . WRITE @IOF,! ;"clear screen if settings call for this. ; QUIT GetPersonClass(PersonClass,ProviderType,Specialty) ;"Purpose: To look through the PERSON CLASS file and find matching record ;"Input -- PersonClass -- a value to match against the .01 field (PROVIDER TYPE) ;" Behavioral Health and Social Service ;" Chiropractors ;" Dental Service ;" Dietary and Nutritional Service ;" Emergency Medical Service ;" Eye and Vision Services ;" Nursing Service ;" Nursing Service Related ;" Physicians (M.D. and D.O.) ;" etc. ;" -- ProviderType -- a value to match against the 1 field (CLASSIFICATION) ;" Physician/Osteopath ;" Resident, Allopathic (includes Interns, Residents, Fellows) ;" Psychologist ;" Neuropsychologist ;" etc. ;" -- Specialty -- a value to match against the 2 field (AREA OF SPECIALIZATION) ;"Output -- (via results) ;"Result -- Returns record number in PERSON CLASS file, OR 0 if not found new RecNum,Params set Params(0,"FILE")="PERSON CLASS" set Params(".01")=$get(PersonClass) set Params("1")=$get(ProviderType) set Params("2")=$get(Specialty) set RecNum=$$RecFind^TMGDBAPI(.Params) GPCDone quit RecNum DocLines(IEN,Chars) ;"Purpose: To count the number of lines and characters in a WP field ;" Initially it is targeted at entries in TIU DOCUMENT file. ;"Input: IEN -- the record number in TIU DOCUMENT to count ;" Chars -- and OUT parameter. PASS BY REFERENCE ;"Results: Returns number of lines, (with 1 decimal value) ;" Also will return character count in Chars, if passed by reference ;"NOte: This uses the Characters per line parameter value stored in ;" field .03 of TIU PARAMETERS (in ^TIU(8925.99)) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"DocLines^TMGMISC") new CharsPerLine new LineCount set LineCount=0 set Chars=0 set CharsPerLine=+$piece($get(^TIU(8925.99,1,0)),"^",3) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"CharsPerLine=",CharsPerLine) set WPPtr=$name(^TIU(8925,IEN,"TEXT")) set Chars=$$WPChars(WPPtr) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Chars=",Chars) if CharsPerLine'=0 do . set LineCount=(((Chars/CharsPerLine)*10)\1)/10 . ;"new IntLC,LC,Delta . ;"set LC=Chars\CharsPerLine . ;"set IntLC=Chars\CharsPerLine ;" \ is integer divide . ;"set Delta=(LC-IntLC)*10 . i;"f Delta>4 set IntLC=IntLC+1 ;"Round to closest integer value. . ;"set LineCount=IntLC if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"LineCount=",LineCount) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"DocLines^TMGMISC") quit LineCount WPChars(Ptr) ;"Purpose: To count the number of characters in the WP field ;" pointed to by the name stored in Ptr ;"Results: Returns number of characters, including spaces if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"WPChars^TMGMISC") new index new Chars set Chars=0 if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Ptr=",Ptr) set index=$order(@Ptr@(0)) for do quit:(index="") . if index="" quit . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"index='",index,"'") . ;"new s set s=$get(@Ptr@(index,0)) write "s=",s,! . set Chars=Chars+$length($get(@Ptr@(index,0))) . set index=$order(@Ptr@(index)) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"WPChars^TMGMISC") quit Chars RoundUp(n) ;"SCOPE: PUBLIC ;"Purpose: find the next greatest integer after decimal value of n (round up) ;" 1.1 --> 2 ;" 1.0 --> 1 ;" -2.8 --> 2 ;"input: n -- decimal or integer value ;"output an integer, rounded up. new result set result=n\1 if result 1 ;" -2.2 --> -2 ;"input: n -- decimal or integer value ;"output an integer, rounded down. new result set result=n\1 quit result Round(n) ;"SCOPE: PUBLIC ;"Purpose: find the nearest integer from decimal value of n ;" for values 0.0-0.49 --> 0 ;" for values 0.5-0.99 --> 1 ;"input: n -- decimal or integer value ;"output an integer, rounded to nearest integer new result set result=n new decimal set decimal=+(n-(n\1)) if decimal<0.5 do . set result=$$RoundDn(n) else do . set result=$$RoundUp(n) quit result InList(Value,ArrayP) ;"SCOPE: PUBLIC ;"Purpose: To return if Value is in an array. Match must be exact (i.e. '=') ;"Input: Value -- the value to test for. Should not be an array ;" ArrayP -- the name of the array. e.g. ArrayP="MyArray(""Title"")" ;"Format of Array: It may be in one of two possible formats: ;" 1. MyArray("Title")=Value, or ;" 2. MyArray("Title")="*" <-- a signal that multiple values are given ;" MyArray("Title",1)=Value1 ;" MyArray("Title",2)=Value2 ;" The '1','2', etc may anything ;"Results: 1 if Value is in list, 0 if not new result set result=0 new index if ($get(ArrayP)'="")&($data(Value)=1) do . if @ArrayP'="*" set result=(@ArrayP=$get(Value)) quit . set index=$order(@ArrayP@("")) quit:(index="") . for do quit:(index="")!(result=1) . . if @ArrayP@(index)=Value set result=1 quit . . set index=$order(@ArrayP@(index)) ILDone quit result ;"IndexOf(pArray,value) ;" ;"SCOPE: PUBLIC ;" ;"Purpose: To scan array and return first index holding value ;" ;"Input: pArray -- PASS BY NAME. Array to scan, in format like this: ;" ;" @pArray@(1)=value1 ;" ;" @pArray@(2)=value2 ;" ;" @pArray@(3)=value3 ;" ;" @pArray@("some name index 1")=value4 ;" ;" @pArray@("some name index 2")=value5 ;" ;" value -- the value to search for ;" ;"results: returns the index holding the value ;" ;" new result set result="" ;" new done set done=0 ;" new index set index="" ;" for set index=$order(@pArray@(index)) quit:(index="")!(done=1) do ;" . set done=($get(@pArray@(index))=value) ;" . if done set result=index ;" ;"IODone quit result LISTCT(pArray) ;" SAAC complient entry point. quit $$ListCt(pArray) ListCt(pArray) ;"SCOPE: PUBLIC ;"Purpose: to count the number of entries in an array ;"Input: pArray -- PASS BY NAME. pointer to (name of) array to test. ;"Output: the number of entries at highest level ;" e.g. Array("TELEPHONE")=1234 ;" Array("CAR")=4764 ;" Array("DOG")=5213 ;" Array("DOG","COLLAR")=5213 <-- not highest level,not counted. ;" The above array would have a count of 3 ;"Results: returns count, or count up to point of any error new i,result set result=0 do . new $etrap . set $etrap="write ""?? Error Trapped ??"",! set $ECODE="""" quit" . set i=$order(@pArray@("")) . if i="" quit . for set result=result+1 set i=$order(@pArray@(i)) quit:i="" quit result NodeCt(pArray) ;"SCOPE: PUBLIC ;"Purpose: to count all the nodes in an array ;"Input: pArray -- PASS BY NAME. pointer to (name of) array to test. ;"Output: the number of entries at highest level ;" e.g. Array("TELEPHONE")=1234 ;" Array("CAR")=4764 ;" Array("DOG")=5213 ;" Array("DOG","COLLAR")=5213 <-- IS counted ;" The above array would have a count of 4 ;"Results: returns count, or count up to point of any error new result set result=0 for set pArray=$query(@pArray),result=result+1 quit:(pArray="") quit result IndexOf(pArray,value) ;"SCOPE: PUBLIC: ;"Purpose: To search through an array of keys and values, and return 1st index (i.e. key) of value ;"Input: pArray -- NAME OF array to search, format: ;" @pArray@(key1)=value1 ;" @pArray@(key2)=value2 ;" @pArray@(key3)=value3 ;" value -- the value to search for ;"Results: will return key for first found (based on $order sequence),or "" if not found new result set result="" new i set i="" new done set done=0 for set i=$order(@pArray@(i)) quit:(i="")!(done=1) do . if $get(@pArray@(i))=value set result=i,done=1 quit result ListPack(pArray,StartNum,IncValue) ;"SCOPE: PUBLIC ;"Purpose: to take an array with numeric ordering and pack values. ;" e.g. Array(3)="dog" ;" Array(5)="cat" ;" Array(75)="goat" ;" Will be pack as follows: ;" Array(1)="dog" ;" Array(2)="cat" ;" Array(3)="goat" ;"Input: pArray -- pointer to (NAME OF) array to pack. ;" StartNum -- OPTIONAL, default=1. Value to start numbering at ;" IncValue -- OPTIONAL, default=1. Amount to add to index value each time ;"Output: array will be altered ;"Results: none. ;"Notes: It is assumed that all of the indices are numeric ;" Nodes that are ALPHA (non-numeric) will be KILLED!! ;" If nodes have subnodes, they will be preserved. new TMGlpArray new i new count set count=$get(StartNum,1) set i=$order(@pArray@("")) if +i=i for do quit:(+i'=i) . merge TMGlpArray(count)=@pArray@(i) . set count=count+$get(IncValue,1) . set i=$order(@pArray@(i)) kill @pArray merge @pArray=TMGlpArray quit ListTrim(pArray,startIndex,endIndex,CountName) ;"SCOPE: PUBLIC ;"Purpose: Take a list with numeric (integer) ordering, and trim (kill) entry ;" items startIndex...endIndex ;"Input: pArray -- PASS BY NAME. The array to trim ;" startIndex -- the first index item to kill. Default=1 ;" endIndex -- the last index item to kill. Default=1 ;" CountName -- OPTIONAL. The name of a node that includes the ;" final count of remaining nodes. Default is "COUNT" ;"Output: Array items will be killed. Also, a node with the resulting count ;" of remaining items will be created, with name of CountName. e.g. ;" INPUT: startIndex=1, endIndex=4 ;" @pArray@(2)="grape" ;" @pArray@(3)="orange" ;" @pArray@(5)="apple" ;" @pArray@(7)="pear" ;" @pArray@(9)="peach" ;" ;" OUTPUT: ;" @pArray@(5)="apple" ;" @pArray@(7)="pear" ;" @pArray@(9)="peach" ;" @pArray@("COUNT")=3 set startIndex=$get(startIndex,1) set endIndex=$get(endIndex,1) set CountName=$get(CountName,"COUNT") kill @pArray@(CountName) new i for i=startIndex:1:endIndex kill @pArray@(i) do ListPack(pArray) set @pArray@(CountName)=$$ListCt(pArray) quit ListAdd(pArray,index,value) ;"SCOPE: PUBLIC ;"Purpose: To take a simple list and add to end of ist ;" e.g. Array("Apple")=75 ;" Array("Pear")=19 ;" ;" do ListAdd("Array","Grape",12) --> ;" ;" e.g. Array("Apple")=75 ;" Array("Pear")=19 ;" Array("Grape")=12 ;"Note: function creation aborted, because there is no intrinsic ordering in arrays. I.e. the above would actually ;" be in this order, as returned by $order(): ;" e.g. Array("Apple")=75 ;" Array("Grape")=12 <-- "G" comes before "P" alphabetically ;" Array("Pear")=19 ;"I'll leave this here as a reminder to myself next time. quit ListAnd(pArray1,pArray2,pResult) ;"Purpose: To take two lists, and create a third list that has only those entries that ;" exist in Array1 AND Array2 ;"Input: pArray1 : NAME OF array for list 1 ;" pArray2 : NAME OF array for list 2 ;" pResult : NAME OF array to results -- any preexisting entries will be killed ;"Note: only TOP LEVEL nodes are considered, and *value* for pArray1 use for combined value ;"E.g. of Use ;" @pArray1@("cat")="feline" ;" @pArray1@("dog")="canine" ;" @pArray1@("horse")="equinine" ;" @pArray1@("bird")="avian" ;" @pArray1@("bird","weight")=12 <--- will be ignored, not a top level node ;" ;" @pArray2@("hog")="porcine" ;" @pArray2@("horse")="equinine" ;" @pArray2@("cow")="bovine" ;" @pArray2@("bird")="flier" <----- note different value for key="bird" ;" ;" resulting list: ;" @pResult@("horse")="equinine" ;" @pResult@("bird")="avian" <-- note value from pArray1 used. new Result new i set i=$order(@pArray1@("")) if i'="" for do quit:(i="") . if $data(@pArray2@(i))#10 do . . set Result(i)=$get(@pArray1@(i)) . set i=$order(@pArray1@(i)) kill @pResult merge @pResult=Result quit ListNot(pArray1,pArray2,Verbose) ;"Purpose: To take two lists, and remove all entries from list 2 from list 1 ;" exist in Array1 NOT Array2 ;"Input: pArray1 : NAME OF array for list 1 ;" pArray2 : NAME OF array for list 2 ;" Verbose: OPTIONAL. if 1 then verbose output, progress bar etc. ;"Note: only TOP LEVEL nodes are considered, and ;" *value* for pArray1 use for combined value ;"E.g. of Use ;" list 1: ;" @pArray1@("cat")="feline" ;" @pArray1@("dog")="canine" ;" @pArray1@("horse")="equinine" ;" @pArray1@("bird")="avian" ;" @pArray1@("bird","weight")=12 <--- will be ignored, not a top level node ;" ;" list 2: ;" @pArray1@("cat")="feline" ;" @pArray1@("horse")="equinine" ;" ;" resulting list: ;" @pArray1@("dog")="canine" ;" @pArray1@("bird")="avian" ;" @pArray1@("bird","weight")=12 ;" new Itr,index set index=$$ItrAInit^TMGITR(pArray2,.Itr) if Verbose=1 do PrepProgress^TMGITR(.Itr,20,1,"index") if index'="" for do quit:($$ItrANext^TMGITR(.Itr,.index)="") . kill @pArray1@(i) quit ;"Note: Sometime, compare this function to $$DATE^TIULS ... I didn't know about this function before! DTFormat(FMDate,format,Array) ;"SCOPE: PUBLIC ;"Purpose: to allow custom formating of fileman dates in to text equivalents ;"Input: FMDate -- this is the date to work on, in Fileman Format ;" format -- a formating string with codes as follows. ;" yy -- 2 digit year ;" yyyy -- 4 digit year ;" m - month number without a leading 0. ;" mm -- 2 digit month number (01-12) ;" mmm - abreviated months (Jan,Feb,Mar etc.) ;" mmmm -- full names of months (January,February,March etc) ;" d -- the number of the day of the month (1-31) without a leading 0 ;" dd -- 2 digit number of the day of the month ;" w -- the numeric day of the week (1-7) ;" ww -- abreviated day of week (Mon,Tue,Wed) ;" www -- day of week (Monday,Tuesday,Wednesday) ;" h -- the number of the hour without a leading 0 (1-23) 24-hr clock mode ;" hh -- 2 digit number of the hour. 24-hr clock mode ;" H -- the number of the hour without a leading 0 (1-12) 12-hr clock mode ;" HH -- 2 digit number of the hour. 12-hr clock mode ;" # -- will display 'am' for hours 1-12 and 'pm' for hours 13-24 ;" M - the number of minutes with out a leading 0 ;" MM -- a 2 digit display of minutes ;" s - the number of seconds without a leading 0 ;" ss -- a 2 digit display of number of seconds. ;" allowed punctuation symbols-- ' ' : , / @ .;- (space, colon, comma, forward slash, at symbol,semicolon,period,hyphen) ;" 'text' is included as is, even if it is same as a formatting code ;" Other unexpected text will be ignored ;" ;" If a date value of 0 is found for a code, that code is ignored (except for min/sec) ;" ;" Examples: with FMDate=3050215.183000 (i.e. Feb 5, 2005 @ 18:30 0 sec) ;" "mmmm d,yyyy" --> "February 5,2005" ;" "mm d,yyyy" --> "Feb 5,2005" ;" "'Exactly' H:MM # 'on' mm/dd/yy" --> "Exactly 6:30 pm on 02/05/05" ;" "mm/dd/yyyy" --> "02/05/2005" ;" ;" Array -- OPTIONAL, if supplied, SHOULD BE PASSED BY REFERENCE ;" The array will be filled with data as follows: ;" Array(Token)=value for that token (ignores codes such as '/',':' ect) ;"Output: Text of date, as specified by above new result set result="" new Token set Token="" new LastToken set LastToken="" new ch set ch="" new LastCh set LastCh="" new InStr set InStr=0 new done set done=0 new i if $get(format)="" goto FDTDone if +$get(FMDate)=0 goto FDTDone for i=1:1:$length(format) do quit:done . set LastCh=ch . set ch=$extract(format,i) ;"get next char of format string. . if (ch'=LastCh)&(LastCh'="")&(InStr=0) do ProcessToken(FMDate,.Token,.result,.Array) . set Token=Token_ch . if ch="'" do quit . . if InStr do ProcessToken(FMDate,.Token,.result) . . set InStr='InStr ;"toggle In-String mode . if (i=$length(format)) do ProcessToken(FMDate,.Token,.result,.Array) FDTDone quit result ProcessToken(FMDate,Token,Output,Array) ;"SCOPE: PRIVATE ;"Purpose: To take tokens and build output following rules specified by DTFormat) ;"Input: FMDate -- the date to work with ;" Token -- SHOULD BE PASSED BY REFERENCE. The code as oulined in DTFormat ;" Output -- SHOULD BE PASSED BY REFERENCE. The cumulative output ;" Array -- OPTIONAL, if supplied, SHOULD BE PASSED BY REFERENCE ;" The array will be filled with data as follows: ;" Array(Token)=value for that token (ignores codes such as '/') if $extract(Token,1,1)="'" do goto PTDone . new Str set Str=$extract(Token,2,$length(Token)-1) . set Output=Output_Str if Token=" " set Output=Output_Token goto PTDone if Token="." set Output=Output_Token goto PTDone if Token=":" set Output=Output_Token goto PTDone if Token="/" set Output=Output_Token goto PTDone if Token=";" set Output=Output_Token goto PTDone if Token="," set Output=Output_Token goto PTDone if Token="-" set Output=Output_Token goto PTDone if Token="@" set Output=Output_Token goto PTDone if Token="yy" do goto PTDone . new Year set Year=+$extract(FMDate,1,3) . if Year=0 quit . set Year=+$extract(FMDate,2,3) . if Year<10 set Year="0"_Year . set Output=Output_Year . set Array(Token)=Year; if Token="yyyy" do goto PTDone . new Year set Year=+$extract(FMDate,1,3) . if Year>0 do . . set Year=Year+1700 . . set Output=Output_Year . . set Array(Token)=Year if Token="m" do goto PTDone . new Month set Month=+$extract(FMDate,4,5) . if Month>0 do . . set Output=Output_Month . . set Array(Token)=Month if Token="mm" do goto PTDone . new Month set Month=+$extract(FMDate,4,5) . if Month=0 quit . if Month<10 set Month="0"_Month . set Output=Output_Month . set Array(Token)=Month if Token="mmm" do goto PTDone . new Month set Month=+$extract(FMDate,4,5) . if Month=0 quit . else if Month=1 set Month="Jan" . else if Month=2 set Month="Feb" . else if Month=3 set Month="Mar" . else if Month=4 set Month="Apr" . else if Month=5 set Month="May" . else if Month=6 set Month="Jun" . else if Month=7 set Month="Jul" . else if Month=8 set Month="Aug" . else if Month=9 set Month="Sept" . else if Month=10 set Month="Oct" . else if Month=11 set Month="Nov" . else if Month=12 set Month="Dec" . if +Month=0 do . . set Output=Output_Month . . set Array(Token)=Month if Token="mmmm" do goto PTDone . new Month set Month=+$extract(FMDate,4,5) . if Month=0 quit . else if Month=1 set Month="January" . else if Month=2 set Month="February" . else if Month=3 set Month="March" . else if Month=4 set Month="April" . else if Month=5 set Month="May" . else if Month=6 set Month="June" . else if Month=7 set Month="July" . else if Month=8 set Month="August" . else if Month=9 set Month="September" . else if Month=10 set Month="October" . else if Month=11 set Month="November" . else if Month=12 set Month="December" . else if +Month=0 do . . set Output=Output_Month . . set Array(Token)=Month if Token="d" do goto PTDone . new Day set Day=+$extract(FMDate,6,7) . if Day>0 do . . set Output=Output_Day . . set Array(Token)=Day if Token="dd" do goto PTDone . new Day set Day=+$extract(FMDate,6,7) . if Day=0 quit . if Day<10 set Day="0"_Day . set Output=Output_Day . set Array(Token)=Day if Token="w" do goto PTDone . new DOW set DOW=$$DOW^XLFDT(FMDate,1) . if DOW>0 do . . set Output=Output_DOW . . set Array(Token)=DOW if Token="ww" do goto PTDone . new DOW set DOW=$$DOW^XLFDT(FMDate,1) . if (DOW<0)!(DOW>6) quit . if DOW=0 set DOW="Sun" . if DOW=1 set DOW="Mon" . if DOW=2 set DOW="Tue" . if DOW=3 set DOW="Wed" . if DOW=4 set DOW="Thur" . if DOW=5 set DOW="Fri" . if DOW=6 set DOW="Sat" . set Output=Output_DOW . set Array(Token)=DOW if Token="www" do goto PTDone . new DOW set DOW=$$DOW^XLFDT(FMDate) . if DOW'="day" do . . set Output=Output_DOW . . set Array(Token)=DOW if Token="h" do goto PTDone . new Hour set Hour=+$extract(FMDate,9,10) . if Hour>0 do . . set Output=Output_Hour . . set Array(Token)=Hour if Token="hh" do goto PTDone . new Hour set Hour=+$extract(FMDate,9,10) . if Hour=0 quit . if Hour<10 set Hour="0"_Hour . set Output=Output_Hour . set Array(Token)=Hour if Token="H" do goto PTDone . new Hour set Hour=+$extract(FMDate,9,10) . if Hour>12 set Hour=Hour-12 . if Hour>0 do . . set Output=Output_Hour . . set Array(Token)=Hour if Token="HH" do goto PTDone . new Hour set Hour=+$extract(FMDate,9,10) . if Hour=0 quit . if Hour>12 set Hour=Hour-12 . if Hour<10 set Hour="0"_Hour . set Output=Output_Hour . set Array(Token)=Hour if Token="#" do goto PTDone . new Hour set Hour=+$extract(FMDate,9,10) . new code . if Hour=0 quit . if Hour>12 set code="pm" . else set code="am" . set Output=Output_code . set Array(Token)=code new Min set Min=+$extract(FMDate,11,12) if Token="M" do goto PTDone . new Min set Min=+$extract(FMDate,11,12) . set Output=Output_Min . set Array(Token)=Min if Token="MM" do goto PTDone . new Min set Min=+$extract(FMDate,11,12) . if Min<10 set Min="0"_Min . set Output=Output_Min . set Array(Token)=Min if Token="s" do goto PTDone . new Sec set Sec=+$extract(FMDate,13,14) . set Output=Output_Sec . set Array(Token)=Sec if Token="ss" do goto PTDone . new Sec set Sec=+$extract(FMDate,13,14) . if Sec<10 set Sec="0"_Sec . set Output=Output_Sec . set Array(Token)=Sec PTDone set Token="" quit CompDOB(DOB1,DOB2) ;"Purpose: to compare two DOB and return if they match, or are similar ;"Input: DOB1,DOB2 -- the two values to compare (in external format) ;"Result: 0 - no similarity or equality ;" 0.25 - doubt similarity ;" 0.50 - possible similarity ;" 0.75 - probable similarity ;" 1 - exact match ;"Note: I made this function because during lookups, I would get failures with data such as: ;" WILLIAM,JOHN G JR 05-21-60 ;" WILLIAM,JOHN G JR 05-11-60 <-- date differs by one digit. ;"Rules for comparision ;" if dates differ by 1 digit --> score of 0.75 ;" if dates differ by an absolute difference of < 1 months --> 0.75 ;" if dates differ by an absolute difference of < 6 months --> 0.50 ;" if dates differ by an absolute difference of < 1 year --> 0.25 ;" if dates differ by 2 digits --> 0.25 new DT1,DT2 new result set result=0 new %DT set X=DOB1 do ^%DT set DT1=Y ;"convert into internal format to avoid format snafu's set X=DOB2 do ^%DT set DT2=Y new DT1array,DT2array new temp if DT1=DT2 set result=1 goto CDOBDone set temp=$$DTFormat^TMGMISC(DT1,"mm/dd/yy",.DT1array) ;"parse date parts into array. set temp=$$DTFormat^TMGMISC(DT2,"mm/dd/yy",.DT2array) ;"Compare digits new NumDif set NumDif=0 new dg1,dg2 set dg1=$extract($get(DT1array("dd")),1,1) set dg2=$extract($get(DT2array("dd")),1,1) if dg1'=dg2 set NumDif=NumDif+1 set dg1=$extract($get(DT1array("dd")),2,2) set dg2=$extract($get(DT2array("dd")),2,2) if dg1'=dg2 set NumDif=NumDif+1 set dg1=$extract($get(DT1array("mm")),1,1) set dg2=$extract($get(DT2array("mm")),1,1) if dg1'=dg2 set NumDif=NumDif+1 set dg1=$extract($get(DT1array("mm")),2,2) set dg2=$extract($get(DT2array("mm")),2,2) if dg1'=dg2 set NumDif=NumDif+1 set dg1=$extract($get(DT1array("yy")),1,1) set dg2=$extract($get(DT2array("yy")),1,1) if dg1'=dg2 set NumDif=NumDif+1 set dg1=$extract($get(DT1array("yy")),2,2) set dg2=$extract($get(DT2array("yy")),2,2) if dg1'=dg2 set NumDif=NumDif+1 if NumDif=1 set result=0.75 goto CDOBDone if NumDif=2 set result=0.50 ;"Compare absolute date new H1,H2,DateDif set H1=$$FMTH^XLFDT(DT1,1) set H2=$$FMTH^XLFDT(DT2,1) set DateDif=$$HDIFF^XLFDT(H1,H2,1) ;"1=results in 'days' if $$HDIFF^XLFDT(H2,H1)>DateDif set DateDif=$$HDIFF^XLFDT(H2,H1) new score set score=0 if DateDif<30 set score=0.75 if DateDif<(30*6) set score=0.50 if DateDif<365 set score=0.25 if score>result set result=score CDOBDone quit result BrowseBy(CompArray,ByTag) ;"Purpose: Allow a user to interact with dynamic text tree ;" that will open and close nodes. ;"Input: CompArray -- array to browse. Should be in this format ;" CompArray("opening tag",a,b,c,d) ;" ByTag -- the name to use in for "opening tag") new aOpen set aOpen=0 new bOpen set bOpen=0 new cOpen set cOpen=0 new done set done=0 new input for do quit:(done=1) . do ShowBy(.CompArray,ByTag,aOpen,bOpen,cOpen) . read "Enter option:",input:$get(DTIME,3600),! . if input="" set input=0 . if +input>0 do . . if aOpen=0 do . . . set aOpen=input,bOpen=0,cOpen=0 . . else if bOpen=0 do . . . set bOpen=input,cOpen=0 . . else if cOpen=0 set cOpen=input . else if input=0 do . . if cOpen'=0 set cOpen=0 quit . . if bOpen'=0 set bOpen=0 quit . . set aOpen=0 . else if input="^" set done=1 quit ShowBy(CompArray,ByTag,aOpen,bOpen,cOpen) new a,b,c,d new acount set acount=0 new bcount set bcount=0 new ccount set ccount=0 new dcount set dcount=0 write # set a=$order(CompArray(ByTag,"")) if a'="" for do quit:(a="") . set acount=acount+1 . new nexta set nexta=$order(CompArray(ByTag,a)) . new Aindent . if (aOpen=0) do . . if acount<10 write "0" . . write acount,". " . else write "... " . write a,! . set b=$order(CompArray(ByTag,a,"")) . if (aOpen=acount)&(b'="") for do quit:(b="") . . set bcount=bcount+1 . . new nextb set nextb=$order(CompArray(ByTag,a,b)) . . new Bindent . . write " +--" . . if (bOpen=0) do . . . if bcount<10 write "0" . . . write bcount,". " . . else write "... " . . write b,! . . if nextb'="" set Aindent=" | " . . else set Aindent=" " . . set c=$order(CompArray(ByTag,a,b,"")) . . if (bOpen=bcount)&(c'="") for do quit:(c="") . . . set ccount=ccount+1 . . . new nextc set nextc=$order(CompArray(ByTag,a,b,c)) . . . if nextc'="" set Bindent=" | " . . . else set Bindent=" " . . . write Aindent," +--" . . . if (cOpen=0) do . . . . if ccount<10 write "0" . . . . write ccount,". " . . . else write "... " . . . write c,! . . . set d=$order(CompArray(ByTag,a,b,c,"")) . . . if (cOpen=ccount)&(d'="") for do quit:(d="") . . . . set dcount=dcount+1 . . . . write Aindent,Bindent," +-- " . . . . if dcount<10 write "0" . . . . write dcount,". " . . . . write d,! . . . . set d=$order(CompArray(ByTag,a,b,c,d)) . . . set c=nextc . . set b=nextb . set a=nexta SBDone quit CompName(Name1,Name2) ;"Purpose: To compare two names, to see if they are the name, or compatible. ;" e.g. WILLIAMS,J BILL vs. WILLAMS,JOHN BILL, vs. WILLIAMS,JOHN B ;"Input: Two names to compare ;"Result: 0 -- if entries conflict ;" 0.5 -- if entries are consistent (i.e. in example above) ;" 1 -- if entries completely match ;"Note: This function WILL IGNORE a suffix. This is because ;" WILLIAM,BILL 5-1-1950 ;" WILLIAM,BILL SR 5-1-1950 ;" would be considered the same person (the date is the determining factor) ;"Rules: Last names must completely match or --> 0 ;" If name is exactly the same, then --> 1 ;" Initial must be same as first letters in name (e.g. N vs. NEWTON) --> 0.5 new result set result=1 new NArray1,NArray2,TMGMsg set Name1=$$FormatName(Name1,1) ;"should convert to standard format. set Name2=$$FormatName(Name2,1) do STDNAME^XLFNAME(.Name1,"C",.TMGMsg) do STDNAME^XLFNAME(.Name1,"C",.TMGMsg) ;"Doing a second time will ensure Array not in initial format. do STDNAME^XLFNAME(.Name2,"C",.TMGMsg) do STDNAME^XLFNAME(.Name2,"C",.TMGMsg) ;"Doing a second time will ensure Array not in initial format. if Name1=Name2 set result=1 goto CompNDone if Name1("FAMILY")'=Name2("FAMILY") do goto:(result=0) CompNDone . if $$EN^XUA4A71(Name1("FAMILY"))'=$$EN^XUA4A71(Name2("FAMILY")) set result=0 ;"check soundex equality if Name1("GIVEN")'=Name2("GIVEN") do . if $$EN^XUA4A71(Name1("GIVEN"))=$$EN^XUA4A71(Name2("GIVEN")) quit ;"check soundex equality . new n1,n2 . set n1=Name1("GIVEN") . set n2=Name2("GIVEN") . if $length(n2)<$length(n1) do ;"ensure length n2>n1 . . new temp set temp=n2 . . set n2=n1,n1=temp . if $extract(n2,1,$length(n1))=n1 set result=0.5 . else set result=0 if result=0 goto CompNDone if Name1("MIDDLE")'=Name2("MIDDLE") do . if $$EN^XUA4A71(Name1("MIDDLE"))=$$EN^XUA4A71(Name2("MIDDLE")) quit ;"check soundex equality . new n1,n2 . set n1=Name1("MIDDLE") . set n2=Name2("MIDDLE") . if $length(n2)<$length(n1) do ;"ensure length n2>n1 . . new temp set temp=n2 . . set n2=n1,n1=temp . if $extract(n2,1,$length(n1))=n1 set result=0.5 . else set result=0 if result=0 goto CompNDone CompNDone quit result FormatName(Name,CutTitle) ;"Purpose: To ensure patient name is properly formated. ;" i.e. John G. Doe --> DOE,JOHN G ;" John G. Doe III --> DOE,JOHN G III ;" John G. Doe,III --> DOE,JOHN G III ;" Doe, John G --> DOE,JOHN G ;" Doe,John g.,III, phd --> DOE,JOHN G III PHD ;"Input: Name -- the name to be reformated ;" CutTitle -- OPTIONAL -- if 1, then titles (e.g. MD, PhD etc) will be cut ;"Results: returns properly formated name ;"Note: If Name is passed by reference, it will be changed ;" Also, NO lookup is done in database to ensure name exists ;"Note: this function malfunctioned on a patient with name like this: ;" JOHN A VAN DER BON --> BON,JOHN A VAN DER (should be VAN DER BON,JOHN A) ;" I don't have a quick for this right now... ;"Also, Sue St. Clair --> CLAIR,SUE ST this is also wrong. ;"FYI: do STDNAME^XLFNAME(.NAME,FLAGS,.ERRARRAY) can also do standardization, ;" and also parse to component parts. It specifically address the St. Clair issue. if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"FormatName^TMGGDFN") new NameArray new MaxNode new Suffix set Suffix="" new i,s,lname new fname set fname="" new result set result="" if $data(Name)#10=0 goto FormatNDone if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Person's name initially is: '",Name,"'") set Name=$translate(Name,"*.","") ;"cleans off any *'s or .'s from initials etc. if Name[", " do . new s1,s2 . set s1=$piece(Name,", ",1) . set s2=$piece(Name,", ",2) . if $$IsTitle($$UP^XLFSTR(s2))&($get(CutTitle)=1) do . . set Name=s1 . else do . . set Name=s1_","_s2 . ;"set Name=$translate(Name,", ",",") ;"Convert 'Doe, John' into 'Doe,John' set Name=$$UP^XLFSTR(Name) ;"convert to upper case if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"After translations, name is: '",Name,"'") set result=$$FORMAT^DPTNAME(Name,3,30) ;"Convert to 'internal' format if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"After $$FORMAT^DPTNAME, name is: '",result,"'") ;"Now, test if FORMAT^DPTNAME caused empty name, i.e. ;" John G Doe --> "" (it wanted Doe,John G) set lname=$piece(result,",",2) if $$IsTitle(lname)&($get(CutTitle)=1) do ;"trim off title if not wanted. . set result=$piece(result,",",1) . set lname="" if $$IsSuffix(lname)=1 do . ;"Here we have 'JOHN DOE,III' --> must be changed to 'DOE,JOHN III' . set Name=$translate(Name,","," ") ;"First change 'JOHN DOE,III' --> 'JOHN DOE III' . set result="" ;"signal need to rearrange letters. if (result="")&(Name'[",") do . set s=Name . do CleaveToArray^TMGSTUTL(s," ",.NameArray,1) . set MaxNode=+$get(NameArray("MAXNODE")) . if MaxNode=0 quit . if $get(CutTitle)=1 do . . if $$IsTitle(NameArray(MaxNode)) do . . . kill NameArray(MaxNode) . . . set MaxNode=MaxNode-1 . . . set NameArray("MAXNODE")=MaxNode . set lname=NameArray(MaxNode) . if ($$IsSuffix(lname)=1)!($$IsTitle(lname)) do . . ;"Change JOHN G DOE III --> JOHN G III DOE (order change in array) . . set lname=NameArray(MaxNode-1) ;"i.e. DOE . . set Suffix=NameArray(MaxNode) ;"i.e. III . . set NameArray(MaxNode)=lname . . set NameArray(MaxNode-1)=Suffix . set result=lname_"," . for i=1:1:MaxNode-1 do . . set result=result_NameArray(i)_" " ;"convert potential 'DOE,JOHN G,III, PHD' --> 'DOE,JOHN G III PHD' set lname=$piece(result,",",1) set fname=$piece(result,",",2,99) set fname=$translate(fname,","," ") set result=lname_","_fname set result=$$Trim^TMGSTUTL(result) ;"One last run through, after all custom alterations made. ;"convert potential 'DOE,JOHN G III PHD' --> 'DOE,JOHN G III PHD' set result=$$FORMAT^DPTNAME(result,3,30) ;"Convert to 'internal' format FormatNDone if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"FormatName^TMGGDFN") quit result IsSuffix(s) ;"Purpose: to return whether s is a suffix (i.e. I,II,Jr.,Sr. etc.) ;"Input: s : the string to check ;"Result 0 if NOT a suffix, 1 if IS a suffix. new result set result=0 if (s="I")!(s="II")!(s="III")!(s="JR")!(s="SR") set result=1 quit result IsTitle(s) ;"Purpose: to return whether s is a title (i.e. MD,PHD,JD,DDS etc.) ;"Input: s : the string to check ;"Result 0 if NOT a suffix, 1 if IS a suffix. new result set result=0 if (s="MD")!(s="PHD")!(s="JD")!(s="DDS") set result=1 if (s="FNP")!(s="GNP")!(s="NP")!(s="PA") set result=1 if (s="RN")!(s="LPN") set result=1 quit result HEXCHR(V) ;"Scope: PUBLIC ;"Take one BYTE and return HEX Values ;"(from Chris Richardson -- thanks!) new NV,B1,B2 set NV="0123456789ABCDEF" set B1=(V#16)+1 ; "0 to 15 becomes 1 to 16 set B2=(V\16)+1 quit $E(NV,B2)_$E(NV,B1) HEXCHR2(n,digits) ;"SCOPE: PUBLIC ;"Purpose: convert n to hex characters ;"Input: n -- the number to convert ;" digits: (optional) number of digits in output. Leading 0's padded to ;" front of answer to set number of digits. ;" e.g. if answer is "A", then ;" 2 -> mandates at least 2 digits ("0A") ;" 3->3 digits ("00A") ;"Note: This function is not as fast as HEXCHR(V) new lo new result set result="" new ch set digits=$get(digits,1) for do quit:(n=0) . set lo=n#16 . if (lo<10) set ch=+lo . else set ch=$char(55+lo) . set result=ch_result . set n=n\16 if $length(result) 16 new multiplier set multiplier=1 new result set result=0 if $extract(s,1)="$" set s=$extract(s,2,$length(s)) for do quit:(s="") . new sStart,sEnd,n . set sStart=$extract(s,1,$length(s)-1) . set sEnd=$extract(s,$length(s)) . if +sEnd=sEnd set n=sEnd . else set n=($ascii(sEnd)-65)+16 . set result=result+(n*multiplier) . set multiplier=multiplier*16 . set s=sStart quit result OR(a,b) ;"Scope: PUBLIC ;"Purpose: to perform a bitwise OR on operands a and b new result set result=0 new mult set mult=1 for do quit:(a'>0)&(b'>0) . set result=result+(((a#2)!(b#2))*mult) . set a=a\2,b=b\2,mult=mult*2 quit result ParsePos(pos,label,offset,routine,dmod) ;"Purpose: to convert a pos string (e.g. X+2^ROUTINE$DMOD) into componant parts ;"Input: pos -- the string, as example above ;" label -- OUT PARAM, PASS BY REF, would return "x" ;" offset -- OUT PARAM, PASS BY REF, would return "+2" ;" routine -- OUT PARAM, PASS BY REF, would return "ROUTINE" ;" dmod -- OUT PARAM, PASS BY REF, would return "DMOD" ;"Results: none ;"Note: results are shortened to 8 characters. new s set s=$get(pos) set dmod=$piece(s,"$",1) ;"e.g. X+2^ROUTINE$DMOD-->X+2^ROUTINE set routine=$piece(s,"^",2) set routine=$extract(routine,1,8) set label=$piece(s,"^",1) set offset=$piece(label,"+",2) set label=$piece(label,"+",1) set label=$extract(label,1,8) quit ScanMod(Module,pArray) ;"Purpose: To scan a module and find all the labels/entry points/Entry points ;"Input: Module -- The name of the module, like "XGF" (not "XGF.m" or "^XGF") ;" pArray -- pointer to (NAME OF) array Will be filled like this ;" pArray(1,"TAG")="Label1" ;" pArray(1,"OFFSET")=1 ;" pArray(2,"TAG")="Label2" ;" pArray(2,"OFFSET")=9 ;" pArray(3,"TAG")="Label3" etc. ;" pArray(3,"OFFSET")=15 ;" pArray("Label1")=1 ;" pArray("Label2")=2 ;" pArray("Label3")=3 ;" ;" NOTE: there seems to be a problem if the passed pArray value is "pArray", ;" so use another name. ;" ;"Output: Results are put into array ;"Result: none new smIdx set smIdx=1 new LabelNum set LabelNum=0 new smLine set smLine="" if $get(Module)="" goto SMDone for do quit:(smLine="") . new smCh . set smLine=$text(+smIdx^@Module) . if smLine="" quit . set smLine=$$Substitute^TMGSTUTL(smLine,$Char(9)," ") ;"replace tabs for 8 spaces . set smCh=$extract(smLine,1) . if (smCh'=" ")&(smCh'=";") do . . new label . . set label=$piece(smLine," ",1) . . set LabelNum=LabelNum+1 . . set @pArray@(LabelNum,"TAG")=label . . set @pArray@(LabelNum,"OFFSET")=smIdx . . set @pArray@(label)=LabelNum . set smIdx=smIdx+1 SMDone quit ConvertPos(Pos,pArray) ;"Purpose: to convert a text positioning line from one that is relative to the last tag/label, into ;" one that is relative to the start of the file ;" e.g. START+8^MYFUNCT --> +32^MYFUNCT ;"Input: Pos -- a position, as returned from $ZPOS ;" pArray -- pointer to (name of). Array holding holding tag offsets ;" pArray will be in this format: ;" pArray("ModuleA",1,"TAG")="ALabel1" ;" pArray("ModuleA",1,"OFFSET")=1 ;" pArray("ModuleA",2,"TAG")="ALabel2" ;" pArray("ModuleA",2,"OFFSET")=9 ;" pArray("ModuleA","Label1")=1 ;" pArray("ModuleA","Label2")=2 ;" pArray("ModuleA","Label3")=3 ;" pArray("ModuleB",1,"TAG")="BLabel1" ;" pArray("ModuleB",1,"OFFSET")=4 ;" pArray("ModuleB",2,"TAG")="BLabel2" ;" pArray("ModuleB",2,"OFFSET")=23 ;" pArray("ModuleB","Label1")=1 ;" pArray("ModuleB","Label2")=2 ;" pArray("ModuleB","Label3")=3 ;" NOTE: -- if array passed is empty, then this function will call ScanModule to fill it ;"Result: returns the new position line, relative to the start of the file/module ;" new cpS new cpResult set cpResult="" new cpRoutine,cpLabel,cpOffset set cpS=$piece(Pos,"$",1) ;"e.g. X+2^ROUTINE$DMOD-->X+2^ROUTINE if cpS="" goto CPDone set cpRoutine=$piece(cpS,"^",2) if cpRoutine="" goto CPDone set cpS=$piece(cpS,"^",1) set cpOffset=+$piece(cpS,"+",2) ;"if cpOffset="" set cpOffset=1 ;"else set cpOffset=+cpOffset set cpLabel=$piece(cpS,"+",1) if $data(@pArray@(cpRoutine))=0 do . new p2Array set p2Array=$name(@pArray@(cpRoutine)) . do ScanMod(cpRoutine,p2Array) new cpIdx set cpIdx=+$get(@pArray@(cpRoutine,cpLabel)) if cpIdx=0 goto CPDone new cpGOffset set cpGOffset=@pArray@(cpRoutine,cpIdx,"OFFSET") set cpResult="+"_+(cpGOffset+cpOffset)_"^"_cpRoutine CPDone quit cpResult CompArray(pArray1,pArray2) ;"Purpose: To return if two arrays are identical ;" Equality means that all nodes and values are present and equal ;"Input: Array1 -- PASS BY NAME. The *name of* the first array to be compared ;" Array1 -- PASS BY NAME. The *name of* the second array to be compared ;"Output: 1 if two are identical, 0 if not new result set result=1 new index1,index2 set index1=$order(@pArray1@("")) set index2=$order(@pArray2@("")) if (index1="")!(index2="") set result=0 goto CADone for do quit:(result=0)!(index1="")!(index2="") . if index2'=index2 set result=0 quit . if $get(@pArray1@(index1))'=$get(@pArray2@(index2)) set result=0 quit . if ($data(@pArray1@(index1))'<10)!($data(@pArray2@(index2))'<10) do . . set result=$$CompArray($name(@pArray1@(index1)),$name(@pArray2@(index2))) . set index1=$order(@pArray1@(index1)) . set index2=$order(@pArray2@(index2)) CADone quit result IterTemplate(Template,Prior) ;"Purpose: To iterate through a SORT TEMPLATE (i.e. provide record numbers held in the template ;" one at a time. For each time this function is called, one record number (IEN) is returned. ;"Input: Template: the IEN of an entry from file SORT TEMPLATE (file# .401) ;" Prior -- OPTIONAL (default is to return first record), an IEN as returned from this ;" function during the last call. ;"Result: Returns the next record found in list, occuring after Prior, or -1 if error or not found ;" Returns "" if end of list (no next record) ;"Example of use: This will list all records held in SORT TEMPLATE record# 809 ;" set IEN="" ;" for s IEN=$$IterTemplate^TMGMISC(809,IEN) w IEN,! q:(+IEN'>0) set Prior=$get(Prior) set result=-1 if +$get(Template)'>0 goto ItTDone set result=$order(^DIBT(Template,1,Prior)) ItTDone quit result CtTemplate(Template) ;"Purpose: To return the Count of IEN's stored in a SORT TEMPLATE ;"Input: Template: the IEN of an entry from file SORT TEMPLATE (file# .401) ;"Result: Returns the count of records held new name set name=$name(^DIBT(Template,1)) quit $$ListCt(name) NumPieces(s,delim,maxPoss) ;"Purpose: to return the number of pieces in s, using delim as a delimiter ;"Input: s -- the string to test ;" delim -- OPTIONAL -- the delimiter (e.g. ',' or ';' or ' ' etc), default=" " ;" maxPoss -- OPTIONAL the maximum number of possible pieces, default=32 ;" the function counts DOWN from this number, so if s has more than default, must specify ;"Result: Returns the number of pieces ;" e.g. 'this is a test', space delimiter --> returns 4 ;"Note: ("this is a test",";") --> 1 ;" ("",";") --> 0 ;"NOTICE!!! ;"After writing this function, I was told that $length(s,delim) will do this. ;" I will leave this here as a reminder, but it probably shouldn't be used.... quit $length(s,$get(delim," ")) new i,result set result=0 if $get(s)="" goto NPsDone set delim=$get(delim," ") set maxPoss=+$get(maxPoss,32) for result=maxPoss:-1:1 quit:($piece(s,delim,result)'="") quit result LastPiece(s,delim,maxPoss) ;"Purpose: to return the last piece of a string ;"Input: s -- the string to use ;" delim -- OPTIONAL -- the delimiter (e.g. ',' or ';' or ' ' etc), default=" " ;" maxPoss -- OPTIONAL the maximum number of possible pieces, default=32 (see NumPieces function) ;"Results : returns the LAST piece in the string new result set result="" if $get(s)="" goto LPDone set delim=$get(delim," ") new n set n=$length(s,delim) set result=$piece(s,delim,n) LPDone quit result ParseLast(s,remainS,delim,maxPoss) ;"Purpose: to return the last piece of a string, AND return the first part of the string in remainS ;"Input: s -- the string to use ;" remainS -- an OUT parameter. PASS BY REFERENCE. Returns the part of the string up to result ;" delim -- OPTIONAL -- the delimiter (e.g. ',' or ';' or ' ' etc), default=" " ;" maxPoss -- OPTIONAL the maximum number of possible pieces, default=32 (see NumPieces function) ;"Results : returns the LAST piece in the string new result set result="" new tempS set tempS=s ;"in case s passed by reference, and remainS=s (i.e. w $$ParseLast(s,.s) set remainS="" set delim=$get(delim," ") if $get(tempS)="" goto PLDone new n set n=$length(s,delim) set result=$piece(tempS,delim,n) if n>1 set remainS=$piece(tempS,delim,1,n-1) PLDone quit result NPsDone quit result Trim1Node(pRef) ;"Purpose: To shorten a reference by one node. ;" e.g. "Array(567,2342,123)" --> "Array(567,2342)" ;"Input: pRef -- the NAME OF an array. ;"Result: will return shortened reference, or "" if problem ;" If no nodes to trim, just array name will be returnes. new result set result=pRef if pRef="" goto T1NDone if $qlength(pRef)>0 set result=$name(@pRef,$qlength(pRef)-1) goto T1NDone ;"Below is an old way I came up with (not as effecient!) ;"NOT USED. set result=$qsubscript(pRef,0) new numNodes,i set numNodes=$qlength(pRef) for i=1:1:(numNodes-1) do . new node set node=$qsubscript(pRef,i) . set result=$name(@result@(node)) T1NDone quit result BROWSEASK ;"Purpose: to ask user for the name of an array, then display nodes new current new order set order=1 ;"default = forward display. new paginate set paginate=0 ;"no pagination new countNodes set countNodes=0 ;"no counting write ! read "Enter name of array (or File number) to display nodes in: ",current:$get(DTIME,3600),! if +current=current do . set current=$get(^DIC(+current,0,"GL")) . if current="" write "File number not found. Quitting.",! quit . write "Browsing array: ",current,! if current="" set current="^" if current="^" goto BADone new % set %=2 ;" default= NO write "Display in REVERSE order? " do YN^DICN write ! if %=1 set order=-1 if %=-1 goto BADone set %=2 write "Pause after each page? " do YN^DICN write ! if %=1 set paginate=1 if %=-1 goto BADone set %=2 write "Show number of subnodes? " do YN^DICN write ! if %=1 set countNodes=1 if %=-1 goto BADone do BROWSENODES(current,order,paginate,countNodes) BADone quit BROWSENODES(current,Order,paginate,countNodes) ;"Purpose: to display nodes of specified array ;"Input: Current -- The reference to display ;" order -- OPTIONAL, default=1; 1 for forward, -1 for backwards order ;" paginate -- OPTIONAL, default=0; 0=no pagination, 1=pause after each page ;" countNodes -- OPTIONAL, default=0; 1=show number of child nodes. new parent,child set parent="" set order=$get(order,1) set paginate=$get(paginate,0) set countNodes=$get(countNodes,0) new len set len=$length(current) new lastChar set lastChar=$extract(current,len) if lastChar'=")" do . if current'["(" quit . if lastChar="," set current=$extract(current,1,len-1) . if lastChar="(" set current=$extract(current,1,len-1) quit . set current=current_")" BNLoop if current="" goto BNDone set child=$$ShowNodes(current,order,paginate,countNodes) if child'="" do . set parent(child)=current . set current=child else set current=$get(parent(current)) goto BNLoop BNDone quit ShowNodes(pArray,order,paginate,countNodes) ;"Purpose: To display all the nodes of the given array ;"Input: pArray -- NAME OF array to display ;" order -- OPTIONAL, default=1; 1 for forward, -1 for backwards order ;" paginate -- OPTIONAL, default=0; 0=no pagination, 1=pause after each page ;" countNodes -- OPTIONAL, default=0; 1=show number of child nodes. ;"Results: returns NAME OF next node to display (or "" if none) new TMGi new count set count=1 new Answers new someShown set someShown=0 new abort set abort=0 set paginate=$get(paginate,0) new pageCount set pageCount=0 new pageLen set pageLen=20 set countNodes=$get(countNodes,0) write pArray,! set TMGi=$order(@pArray@(""),order) if TMGi'="" for do quit:(TMGi="")!(abort=1) . write count,". +--[",TMGi,"]" . if countNodes=1 write "(",$$ListCt($name(@pArray@(TMGi))),")" . write "=",$extract($get(@pArray@(TMGi)),1,40),! . set someShown=1 . set Answers(count)=$name(@pArray@(TMGi)) . set count=count+1 . new temp read *temp:0 . if temp'=-1 set abort=1 . set pageCount=pageCount+1 . if (paginate=1)&(pageCount>pageLen) do . . new temp . . read "Press [ENTER] to continue (^ to stop list)...",temp:$get(DTIME,3600),! . . if temp="^" set abort=1 . . set pageCount=0 . set TMGi=$order(@pArray@(TMGi),order) if someShown=0 write " (no data)",! write !,"Enter # to browse (^ to backup): ^//" new temp read temp:$get(DTIME,3600),! new result set result=$get(Answers(temp)) quit result BRWSASK2 ;"Purpose: Improved... Ask user for the name of an array, then display nodes new current new order set order=1 ;"default = forward display. new countNodes set countNodes=0 ;"no counting write ! read "Enter name of array (or File number) to display nodes in: ",current:$get(DTIME,3600),! if +current=current do . set current=$get(^DIC(+current,0,"GL")) . if current="" write "File number not found. Quitting.",! quit . write "Browsing array: ",current,! if current="" set current="^" if current="^" goto BA2Done new % set %=2 ;" default= NO write "Display in REVERSE order? " do YN^DICN write ! if %=1 set order=-1 if %=-1 goto BA2Done set %=2 write "Show number of subnodes? " do YN^DICN write ! if %=1 set countNodes=1 if %=-1 goto BA2Done do BRWSNOD2(current,order,countNodes) BA2Done quit BRWSNOD2(curRef,Order,countNodes) ;"Purpose: to display nodes of specified array ;"Input: curRef -- The reference to display ;" order -- OPTIONAL, default=1; 1 for forward, -1 for backwards order ;" paginate -- OPTIONAL, default=0; 0=no pagination, 1=pause after each page ;" countNodes -- OPTIONAL, default=0; 1=show number of child nodes. set curRef=$$CREF^DILF(curRef) if curRef="" goto BN2Done new TMGBRWORDER set TMGBRWORDER=$get(order,1) new TMGBRWCN set TMGBRWCN=$get(countNodes,0) if $$ShowNod2(curRef,TMGBRWORDER,TMGBRWCN) BN2Done quit ShowNod2(pArray,order,countNodes) ;"Purpose: To display all the nodes of the given array ;" UPDATED function to use Scroller box. ;"Input: pArray -- NAME OF array to display ;" order -- OPTIONAL, default=1; 1 for forward, -1 for backwards order ;" countNodes -- OPTIONAL, default=0; 1=show number of child nodes. ;"Results: returns NAME OF next node to display (or "" if none) new TMGi,Option new dispArray,dispI set dispI=1 set order=$get(order,1) set countNodes=$get(countNodes,0) ; set TMGi="" for set TMGi=$order(@pArray@(TMGi),order) quit:(TMGi="") do . new s set s=" +---["_TMGi_"]" . if countNodes=1 set s=s_"("_$$ListCt($name(@pArray@(TMGi)))_")" . new s2 set s2=$extract($get(@pArray@(TMGi)),1,40) . if s2'="" set s=s_"="_s2 . if $data(@pArray@(TMGi))>9 set s=s_" ..." . set dispArray(dispI,s)=$name(@pArray@(TMGi)),dispI=dispI+1 if $data(dispArray)=0 set dispArray(dispI,"")="",dispI=dispI+1 ; set Option("HEADER",1)="Data for "_pArray set Option("FOOTER",1,1)="? Help" set Option("FOOTER",1,2)="LEFT Backup" set Option("FOOTER",1,3)="RIGHT Browse IN" set Option("ON SELECT")="HndOnSel^TMGMISC" set Option("ON CMD")="HndOnCmd^TMGMISC" ; write # do Scroller^TMGUSRIF("dispArray",.Option) quit pArray HndOnSel(pArray,Option,Info) ;"Purpose: handle ON SELECT event from Scroller^TMGUSRIF, launched by ShowNod2 ;"Input: pArray,Option,Info -- see documentation in Scroller^TMGUSRIF ;" Info has this: ;" Info("CURRENT LINE","NUMBER")=number currently highlighted line ;" Info("CURRENT LINE","TEXT")=Text of currently highlighted line ;" Info("CURRENT LINE","RETURN")=return value of currently highlighted line ; new ref set ref=$get(Info("CURRENT LINE","RETURN")) if ref'="" if $$ShowNod2(ref,TMGBRWORDER,TMGBRWCN) quit HndOnCmd(pArray,Option,Info) ;"Purpose: handle ON SELECT event from Scroller, launched by ShowNod2 ;"Input: pArray,Option,Info -- see documentation in Scroller ;" Info has this: ;" Info("USER INPUT")=input ;" Info("CURRENT LINE","NUMBER")=number currently highlighted line ;" Info("CURRENT LINE","TEXT")=Text of currently highlighted line ;" Info("CURRENT LINE","RETURN")=return value of currently highlighted line ;" TMGSCLRMSG,TMGBRWORDER,TMGBRWCN - globally scoped variables that are used. ;"results: none (required to have none) new input set input=$$UP^XLFSTR($get(Info("USER INPUT"))) if input["LEFT" do . set TMGSCLRMSG="^" else if input["RIGHT" do . new ref set ref=$get(Info("CURRENT LINE","RETURN")) . if ref'="" if $$ShowNod2(ref,TMGBRWORDER,TMGBRWCN) else if input="?" do . write !,"Use UP and DOWN cursor keys to select global node",! . write "LEFT will back up, and RIGHT or ENTER will browse node",! . write "^ at the ':' prompt will cause a back up of one level",! . do PressToCont^TMGUSRIF else if input'="" do . write !,"Input ",$get(Info("USER INPUT"))," not recognized.",! . do PressToCont^TMGUSRIF ; write # quit IsNumeric(value) ;"Purpose: to determine if value is pure numeric. ;"Note: This will be a more involved test than simply: if +value=value, because ;" +"00001" is not the same as "1" or 1. Also +"123abc"--> 123, but is not pure numeric set value=$$Trim^TMGSTUTL(value) ;" trim whitespace set value=$$TrimL^TMGSTUTL(value,"0") ;"trim leading zeros quit (value=+value) ClipDDigits(Num,digits) ;"Purpose: to clip number to specified number of decimal digits ;" e.g. 1234.9876543 --> 1234.9876 if digits=4 ;"Input: Num -- the number to process ;" digits -- the number of allowed decimal digits after the decimal point ;"Result: returns the number clipped to the specified number of decimals ;" note: this is a CLIP, not a ROUND function new result set result=Num new decimals set decimals=$extract($piece(Num,".",2),1,digits) set result=$piece(Num,".",1) if decimals'="" set result=result_"."_decimals CDgDone quit result Diff(File,IENS1,IENS2,Result) ;"Purpose: to determine how two records differ in a given file ;"Input: File -- file name or number of file containing records to be compared ;" IENS1 -- the IEN (or IENS if file is a subfile) of the first record to be compared ;" IENS2 -- the IEN (or IENS if file is a subfile) of the second record to be compared ;" Result -- PASS BE REFERENCE, and OUT PARAMETER ;" Format of output Result array. Will only hold differences ;" e.g. Result(FieldNum,"EXTRA",1)=valueOfField ;" e.g. Result(FieldNum,"EXTRA",2)=valueOfField ;" e.g. Result(FieldNum,"CONFLICT",1)=valueOfField ;" e.g. Result(FieldNum,"CONFLICT",2)=valueOfField ;" e.g. Result(FieldNum,"FIELD NAMES")=FieldName ;"Note: this will consider only the first 1024 characters of WP fields ;"Note: For now, multiples (subfiles) will be IGNORED new fileNum set fileNum=+$get(File) if fileNum=0 set fileNum=$$GetFileNum^TMGDBAPI(.File) new subFileNum new field set field=$order(^DD(fileNum,0)) if +field>0 for do quit:(+field'>0) . set subFileNum=+$piece($get(^DD(fileNum,field,0)),"^",2) ;"get subfile number, or 0 if not subfile . if subFileNum>0 do ;"finish later... . . ;"Here I need to somehow cycle through each record of the subfile and compare THOSE . . new subResult . . do DiffSubFile(subFileNum,.IENS1,.IENS2,.subResult) ;"null function for now . . ;"do some merge between Result and subResult . else do Diff1Field(fileNum,field,.IENS1,.IENS2,.Result) . set field=$order(^DD(fileNum,field)) quit Diff1Field(File,Field,IENS1,IEN2,Result) ;"Purpose: to determine how two records differ for one given field ;"Input: File -- file NUMBER of file containing records to be compared ;" Field -- Field NUMBER to be evaluated ;" IENS1 -- the IEN (or IENS if file is a subfile) of the first record to be compared ;" IENS2 -- the IEN (or IENS if file is a subfile) of the second record to be compared ;" Result -- PASS BE REFERENCE, and OUT PARAMETER ;" Format of output Result array. Will only hold differences ;" e.g. Result(FieldNum,"EXTRA",1)=valueOfField ;" e.g. Result(FieldNum,"EXTRA",2)=valueOfField ;" e.g. Result(FieldNum,"CONFLICT",1)=valueOfField ;" e.g. Result(FieldNum,"CONFLICT",2)=valueOfField ;" e.g. Result(FieldNum,"FIELD NAMES")=FieldName ;"Results: none (data returned in Result out parameter) ;"Note: only first 1023 characters of a WP field will be compared new value1,value2,TMGWP1,TMGWP2 new fieldName set fieldName=$piece($get(^DD(File,Field,0)),"^",1) set value1=$$GET1^DIQ(File,IENS1,Field,"","TMGWP1") set value2=$$GET1^DIQ(File,IENS2,Field,"","TMGWP2") if $data(TMGWP1)!$data(TMGWP2) do . set value1=$$WPToStr^TMGSTUTL("TMGWP1"," ",1023) ;"Turn first 1023 characters into one long string . set value2=$$WPToStr^TMGSTUTL("TMGWP2"," ",1023) ;"Turn first 1023 characters into one long string if value1=value2 goto D1FDone ;"default is no conflict if (value2="")&(value1'="") do . set Result(Field,"EXTRA",1)=value1 . set Result(Field,"FIELD NAME")=fieldName if (value1="")&(value2'="") do . set Result(Field,"EXTRA",2)=value2 . set Result(Field,"FIELD NAME")=fieldName if (value1'="")&(value2'="") do . set Result(Field,"CONFLICT",1)=value1 . set Result(Field,"CONFLICT",2)=value2 . set Result(Field,"FIELD NAME")=fieldName D1FDone quit DiffSubFile(SubFile,IENS1,IENS2,Result) quit Array2XML(pArray,pResult,indent) ;"Purpose: to convert an array into XML format ;"Input: pArray -- the NAME OF the array to convert (array can be any format) ;" pResult -- the NAME OF the output array. ;" format: ;" Result(0)="" ;" Result(1)="Node Value ;" Result(2)=" Node Value ;" Result(3)=" Node Value ;" Result(4)=" Node Value ;"<--- start subnode ;" Result(5)=" Node Value ;" Result(6)=" Node Value ;" Result(7)=" ;"<---- end subnode ;" Result(8)=" Node Value ;" indent -- OPTIONAL. if 1, then subnodes have whitespace indent for pretty viewing ;"Output: pResult is filled ;"Result: none. ;"Note: example call do Array2XML("MyArray","MyOutput",1) kill @pResult set @pResult@(0)=0 if $get(indent)=1 set indent="" else set indent=-1 do A2XNode(pArray,pResult,.indent) set @pResult@(0)=$$XMLHDR^MXMLUTL quit A2XNode(pArray,pResult,indent) ;"Purpose: To do the output for Array2XML ;"Input: pArray - the NAME OF the array to convert ;" pResult - the NAME OF the output array. ;" Format to be as described in Array2XML, which one exception: Result(0)=MaxLine ;" indent -- OPTIONAL. if numeric value, then subnodes WON't whitespace indent for pretty viewing ;" otherwise, indent is string holding space to indent ;"Result: none new i,s set indent=$get(indent) set i=$order(@pArray@("")) if i'="" for do quit:(i="") . set s="" if indent'=-1 set s=indent . set s=s_""_$get(@pArray@(i)) . set s=$$SYMENC^MXMLUTL(s) . if $data(@pArray@(i))>1 do . . set @pResult@(0)=+$get(@pResult@(0))+1 ;"Increment maxline . . set @pResult@(@pResult@(0))=s . . new subIndent set subIndent=-1 . . if indent'=-1 set subIndent=indent_" " . . do A2XNode($name(@pArray@(i)),pResult,subIndent) . . set s="" if indent'=-1 set s=indent . . set s=s_"" . else do . . set s=s_"" . set @pResult@(0)=+$get(@pResult@(0))+1 ;"Increment maxline . set @pResult@(@pResult@(0))=s . set i=$order(@pArray@(i)) quit Up(pArray) ;"Purpose: Return a NAME of an array that is one level 'up' from the ;" the current array. This really means one node shorter. ;" e.g. '^MyVar('plant','tree','apple tree')' --> '^MyVar('plant','tree')' ;"Results: returns shorten array as above, or "" if error new result set result="" if $get(pArray)="" goto UpDone set result=$qsubscript(pArray,0) new i for i=1:1:$qlength(pArray)-1 do . set result=$name(@result@($qsubscript(pArray,i))) UpDone quit result LaunchScreenman(File,FormIEN,RecIEN,Page) ;"Purpose: to provide a programatic launching point for displaying a ;" screenman form for editing a record ;"Input: File -- the IEN of file to be edited ;" FormIEN -- the IEN in file FORM (.403) ;" RecIEN -- the IEN in File to edit ;" Page -- OPTIONAL, default=1. The starting page of form. ;"Note: Form should be compiled before calling the function. This can be ;" achieved by running the form once from ^DDSRUN (or viat Fileman menu) new DDSFILE set DDSFILE=File new DDSRUNDR set DDSRUNDR=FormIEN new DDSPAGE set DDSPAGE=+$get(Page,1) new DA set DA=RecIEN do REC+9^DDSRUN ;"this goes against SAC conventions. quit NumSigChs() ;"Purpose: To determine how many characters are signficant in a variable name ;" I.e. older versions of GT.M had only the first 8 characters as ;" significant. Newer versions allow more characters to be significant. new pVar1,pVar2,i set pVar1="zb",i=2 new done set done=0 for do quit:done . set i=i+1 . set pVar2=pVar1_"b" . set pVar1=pVar1_"a" . new @pVar2,@pVar1 . set @pVar1=7 . if $get(@pVar2)=@pVar1 set done=1 quit (i-1) SrchReplace(File,Field,Caption) ;"Purpose: To do a text-based search and replace in all record of ;" specified file, in the text of the specified file. ;" Note: this does not work with pointer fields. It would ;" fail to find the matching text in the pointer value and ignore it. ;" It does not support subfiles. ;"Input: File -- the file name or number to work with. ;" Field -- the field name or number to work with ;" Caption -- OPTIONAL. A descriptive text of action. ;"Output: Data in records will be changed via Fileman and errors (if found) ;" will be written to console. ;"Results: none. if $get(File)="" goto SRDone if $get(Field)="" goto SRDone new OKToCont set OKToCont=1 if +Field'=Field set OKToCont=$$SetFileFldNums^TMGDBAPI(File,Field,.File,.Field) if OKToCont=0 goto SRDone if $get(Caption)'="" do . write !,!,Caption,! . write "----------------------------------------------------",!! new searchS,replaceS,% SR1 write "Enter characters/words to SEARCH for (^ to abort): " read searchS:$get(DTIME,3600),! if (searchS="")!(searchS="^") goto SRDone write "REPLACE with (^ to abort): " read replaceS:$get(DTIME,3600),! if (replaceS="^") goto SRDone write "'",searchS,"'-->'",replaceS,"'",! set %=1 write "OK" do YN^DICN write ! if %=1 goto SR2 if %=-1 goto SRDone goto SR1 SR2 new Itr,IEN,CurValue,abort,count new ref set ref=$get(^DIC(File,0,"GL")) set ref=$$CREF^DILF(ref) if ref="" goto SRDone new node set node=$piece($get(^DD(File,Field,0)),"^",4) new piece set piece=$piece(node,";",2) set node=$piece(node,";",1) set abort=0,count=0 set IEN=$$ItrInit^TMGITR(File,.Itr) do PrepProgress^TMGITR(.Itr,20,0,"IEN") if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort . if $$UserAborted^TMGUSRIF() set abort=1 quit . set CurValue=$piece($get(@ref@(IEN,node)),"^",piece) . if CurValue'[searchS quit SR3 . new newValue set newValue=$$Substitute^TMGSTUTL(CurValue,searchS,replaceS) . new TMGFDA,TMGMSG . set TMGFDA(File,IEN_",",Field)=newValue . do FILE^DIE("K","TMGFDA","TMGMSG") . do ShowIfDIERR^TMGDEBUG(.TMGMSG) . set count=count+1 do ProgressDone^TMGITR(.Itr) write count," records changed",! do PressToCont^TMGUSRIF SRDone quit MkMultList(input,List) ;"Purpose: To create a list of entries, given a string containing a list of entries. ;"Input: input -- a string of user input. E.g.: '345,3,12678,78-85,2' or '78-93' or '15' ;" List -- PASS BY REFERENCE. An OUT PARAMETER. ;"Output: List will be filled as follows: ;" List(Entry number)="" ;" List(Entry number)="" ;" List(Entry number)="" ;"Result: 1 if values found, 0 none found, or error encountered new result set result=0 new i for i=1:1:$length(input,",") do . new value set value=$piece(input,",",i) . if +value=value do . . set List(value)="" . . set result=1 . else if value["-" do . . new n1,n2 . . set n1=+$piece(value,"-",1) . . set n2=+$piece(value,"-",2) . . set result=$$MkRangeList(n1,n2,.List) quit result MkRangeList(Num,EndNum,List) ;"Purpose: To create a list of entries, given a starting and ending number ;"Input: Num -- the start entry number ;" EndNum -- OPTIONAL, the last entry number (if supplied then all values ;" between Num and Endnum will be added to list ;" List -- PASS BY REFERENCE. An OUT PARAMETER. ;"Output: List will be filled as follows: ;" List(Entry number)="" ;" List(Entry number)="" ;" List(Entry number)="" ;"Result: 1 if value input found, otherwise 0 new result set result=0 set EndNum=$get(EndNum,Num) if (+Num'=Num)!(+EndNum'=EndNum) goto MkRLDone new i for i=Num:1:EndNum do . set List(i)="" . set result=1 MkRLDone quit result Flags(Var,Flag,Mode) ;"Purpose: To set,delete,or toggle a flag stored in Var ;"Input: Var -- PASS BY REFERENCE. The variable holding the flags ;" Flag -- a single character flag to be stored in Var ;" Mode: should be: 'SET','DEL',or 'TOGGLE'. Default is 'SET' ;"Results: none set Flag=$get(Flag,"SET") set Var=$get(Var) if $get(Mode)="TOGGLE" do . if Var[Flag set Mode="DEL" . else set Mode="SET" if $get(Mode)="SET" do . if Var[Flag quit . set Var=Var_Flag if $get(Mode)="DEL" do . if Var'[Flag quit . set Var=$piece(Var,Flag,1)_$piece(Var,Flag,2) quit CompABArray(pArrayA,pArrayB,pExtraB,pMissingB,pDiff,ProgressFn,IncVar) ;"Purpose: To compare two arrays, A & B, and return results in OutArray ;" that specifies how ArrayB differs from ArrayA ;"Input: pArrayA -- PASS BY NAME. Baseline array to be compared against ;" pArrayB -- PASS BY NAME. Array to be compare against ArrayA ;" pExtraB -- PASS BY NAME. An OUT PARAMETER. Array of extra info from B ;" OPTIONAL. If not provided, then data not filled. ;" pMissingB -- PASS BY NAME. An OUT PARAMETER. Array of missing info ;" OPTIONAL. If not provided, then data not filled. ;" pDiff -- PASS BY NAME. An OUT PARAMETER. Output as below. ;" OPTIONAL. If not provided, then data not filled. ;" @pOutArray@("A",node,node,node,...)=different value ;" @pOutArray@("B",node,node,node,...)=different value ;" ProgressFn -- OPTIONAL -- M code to exec as a progress indicator ;" IncVar -- OPTIONAL -- a counter that can be referenced by ProgressFn ;"Results: 0=OK, 1=aborted new indexA,indexB set IncVar=+$get(IncVar) set ProgressFn=$get(ProgressFn) set pExtraB=$get(pExtraB) set pMissingB=$get(pMissingB) set pdiff=$get(pDiff) new abort set abort=0 new Compared set indexA="" for set indexA=$order(@pArrayA@(indexA)) quit:(indexA="")!abort do . set IncVar=IncVar+1 . if (IncVar#10=1),(ProgressFn'="") do quit:(abort) . . new $etrap set $etrap="set $etrap="""",$ecode=""""" . . xecute ProgressFn . . write !,pArrayA,"(",indexA,") ",! do CUU^TMGTERM(2) ;"temp . . if $$UserAborted^TMGUSRIF() set abort=1 quit . if $data(@pArrayB@(indexA))=0 do quit . . if (pMissingB'="") merge @pMissingB@(pArrayA,indexA)=@pArrayA@(indexA) . new s1,s2 . set s1=$get(@pArrayA@(indexA)) . set s2=$get(@pArrayB@(indexA)) . if s1'=s2 do . . if pDiff="" quit . . if $$TRIM^XLFSTR(s1)=$$TRIM^XLFSTR(s2) quit . . set @pDiff@("A",pArrayA,indexA)=s1 . . set @pDiff@("B",pArrayA,indexA)=s2 . set abort=$$CompABArray($name(@pArrayA@(indexA)),$name(@pArrayB@(indexA)),.pExtraB,.pMissingB,.pDiff,.ProgressFn,.IncVar) . set Compared($name(@pArrayA@(indexA)),$name(@pArrayB@(indexA)))=1 new temp set temp=1 set indexB="" for set indexB=$order(@pArrayB@(indexB)) quit:(indexB="")!abort do . set temp=temp+1 . if (temp#10=1) do quit:(abort) . . write !,pArrayA,"(",indexB,") ",! do CUU^TMGTERM(2) ;"temp . . if $$UserAborted^TMGUSRIF() set abort=1 quit . if $data(@pArrayA@(indexB))=0 do quit . . if (pExtraB'="") merge @pExtraB@(pArrayA,indexB)=@pArrayB@(indexB) . if $get(Compared($name(@pArrayA@(indexB)),$name(@pArrayB@(indexB))))=1 do quit ;"already checked . . new temp . set abort=$$CompABArray($name(@pArrayA@(indexB)),$name(@pArrayB@(indexB)),.pExtraB,.pMissingB,.pDiff) quit abort FixArray(ref) ;"Purpose: Convert an array like this: ;" @ref@("^DD(2,.362)",21,1,0) --> @ref@("^DD",2,.362,21,1,0) ;" @ref@("^DD(2,.362)",21,2,0) --> @ref@("^DD",2,.362,21,2,0) ;" @ref@("^DD(2,.362)",23,0) --> @ref@("^DD",2,.362,23,0) ;" @ref@("^DD(2,.362)",23,1,0) --> @ref@("^DD",2,.362,23,1,0) ;" @ref@("^DD(2,0,""IX"")","ACFL2",2,.312) --> @ref@("^DD",2,0,"IX","ACFL2",2,.312) ;" @ref@("^DD(2,0,""IX"")","AEXP",2,.351) --> @ref@("^DD",2,0,"IX","AEXP",2,.351) ;" @ref@("^DD(2,0,""IX"")","TMGS",2,22701) --> @ref@("^DD",2,0,"IX","TMGS",2,22701) ;" @ref@("^DD(2,0,""PT"")",228.1,.02) --> @ref@("^DD",2,0,"PT",228.1,.02) ;" @ref@("^DD(2,0,""PT"")",228.2,.02) --> @ref@("^DD",2,0,"PT",228.2,.02) ;" @ref@("^DD(2,0,""PT"")",19620.92,.08) --> @ref@("^DD",2,0,"PT",19620.92,.08) ;" @ref@("^DD(2,0,""PT"",115)",.01) --> @ref@("^DD",2,0,"PT",115,.01) ;"Input: ref -- PASS BY NAME ;"Output: contents of @ref are converted as above. ;"Results: none new origRef set origRef=ref new output,s1,i for set ref=$query(@ref) quit:(ref="") do . set s1=$qsubscript(ref,1) . new newRef set newRef="output" . new startI set startI=1 . if s1["(" do . . set startI=2 . . set newRef=newRef_"("""_$qs(s1,0)_""")" . . if $qlength(s1)>1 for i=1:1:$qlength(s1) do . . . set newRef=$name(@newRef@($qsubscript(s1,i))) . for i=startI:1:$qlength(ref) do . . new s3 set s3=$qsubscript(ref,i) . . set newRef=$name(@newRef@(s3)) . merge @newRef=@ref kill @origRef merge @origRef=output ;"put changes back into original array quit Caller(Code) ;"Purpose: From call stack, return the location of the caller of the function ;" Note this will not return the address of the function calling ;" Caller, but instead, the address of the function before that ;" in the stack. ;" So a function (A) can call this routine to find out who called it (A). ;"Input: Code -- OPTIONAL. PASS BY REFERANCE, AN OUT PARAMETER ;" Filled with line of calling code. set Code=$STACK($STACK-2,"MCODE") new result set result=$STACK($STACK-2,"PLACE") if result="" set result="?" quit result