Index: cprs/branches/tmg-cprs/Server_KIDS/TMG-CPRS-SEARCH-1.0-1.KIDS =================================================================== --- cprs/branches/tmg-cprs/Server_KIDS/TMG-CPRS-SEARCH-1.0-1.KIDS (revision 792) +++ cprs/branches/tmg-cprs/Server_KIDS/TMG-CPRS-SEARCH-1.0-1.KIDS (revision 792) @@ -0,0 +1,14882 @@ +KIDS Distribution saved on Jun 07, 2010@13:11:23 +TMG CPRS SEARCH 1.0*1 +**KIDS**:TMG-CPRS-SEARCH*1.0*1^ + +**INSTALL NAME** +TMG-CPRS-SEARCH*1.0*1 +"BLD",7635,0) +TMG-CPRS-SEARCH*1.0*1^^0^3100607^n +"BLD",7635,1,0) +^^4^4^3100607^^ +"BLD",7635,1,1,0) +This provides functionality for advanced patient +"BLD",7635,1,2,0) +from inside CPRS. +"BLD",7635,1,3,0) + +"BLD",7635,1,4,0) +This patch provides the server code. +"BLD",7635,4,0) +^9.64PA^^0 +"BLD",7635,6.3) +1 +"BLD",7635,"INID") +^n +"BLD",7635,"INIT") +INSTALL^TMGRPCSR +"BLD",7635,"KRN",0) +^9.67PA^8989.52^19 +"BLD",7635,"KRN",.4,0) +.4 +"BLD",7635,"KRN",.401,0) +.401 +"BLD",7635,"KRN",.402,0) +.402 +"BLD",7635,"KRN",.403,0) +.403 +"BLD",7635,"KRN",.5,0) +.5 +"BLD",7635,"KRN",.84,0) +.84 +"BLD",7635,"KRN",3.6,0) +3.6 +"BLD",7635,"KRN",3.8,0) +3.8 +"BLD",7635,"KRN",9.2,0) +9.2 +"BLD",7635,"KRN",9.8,0) +9.8 +"BLD",7635,"KRN",9.8,"NM",0) +^9.68A^9^9 +"BLD",7635,"KRN",9.8,"NM",1,0) +TMGDEBUG^^0^B10098 +"BLD",7635,"KRN",9.8,"NM",2,0) +TMGMISC^^0^B4580543 +"BLD",7635,"KRN",9.8,"NM",3,0) +TMGSTUTL^^0^B14433 +"BLD",7635,"KRN",9.8,"NM",4,0) +TMGDBAPI^^0^B13172584 +"BLD",7635,"KRN",9.8,"NM",5,0) +TMGSRCH^^0^B209173527 +"BLD",7635,"KRN",9.8,"NM",6,0) +TMGSRCH0^^0^B267429171 +"BLD",7635,"KRN",9.8,"NM",7,0) +TMGSRCH1^^0^B205466169 +"BLD",7635,"KRN",9.8,"NM",8,0) +TMGRPC1B^^0^B10826405 +"BLD",7635,"KRN",9.8,"NM",9,0) +TMGRPCSR^^0^B34779751 +"BLD",7635,"KRN",9.8,"NM","B","TMGDBAPI",4) + +"BLD",7635,"KRN",9.8,"NM","B","TMGDEBUG",1) + +"BLD",7635,"KRN",9.8,"NM","B","TMGMISC",2) + +"BLD",7635,"KRN",9.8,"NM","B","TMGRPC1B",8) + +"BLD",7635,"KRN",9.8,"NM","B","TMGRPCSR",9) + +"BLD",7635,"KRN",9.8,"NM","B","TMGSRCH",5) + +"BLD",7635,"KRN",9.8,"NM","B","TMGSRCH0",6) + +"BLD",7635,"KRN",9.8,"NM","B","TMGSRCH1",7) + +"BLD",7635,"KRN",9.8,"NM","B","TMGSTUTL",3) + +"BLD",7635,"KRN",19,0) +19 +"BLD",7635,"KRN",19.1,0) +19.1 +"BLD",7635,"KRN",101,0) +101 +"BLD",7635,"KRN",409.61,0) +409.61 +"BLD",7635,"KRN",771,0) +771 +"BLD",7635,"KRN",870,0) +870 +"BLD",7635,"KRN",8989.51,0) +8989.51 +"BLD",7635,"KRN",8989.52,0) +8989.52 +"BLD",7635,"KRN",8994,0) +8994 +"BLD",7635,"KRN",8994,"NM",0) +^9.68A^1^1 +"BLD",7635,"KRN",8994,"NM",1,0) +TMG SEARCH CHANNEL^^0 +"BLD",7635,"KRN",8994,"NM","B","TMG SEARCH CHANNEL",1) + +"BLD",7635,"KRN","B",.4,.4) + +"BLD",7635,"KRN","B",.401,.401) + +"BLD",7635,"KRN","B",.402,.402) + +"BLD",7635,"KRN","B",.403,.403) + +"BLD",7635,"KRN","B",.5,.5) + +"BLD",7635,"KRN","B",.84,.84) + +"BLD",7635,"KRN","B",3.6,3.6) + +"BLD",7635,"KRN","B",3.8,3.8) + +"BLD",7635,"KRN","B",9.2,9.2) + +"BLD",7635,"KRN","B",9.8,9.8) + +"BLD",7635,"KRN","B",19,19) + +"BLD",7635,"KRN","B",19.1,19.1) + +"BLD",7635,"KRN","B",101,101) + +"BLD",7635,"KRN","B",409.61,409.61) + +"BLD",7635,"KRN","B",771,771) + +"BLD",7635,"KRN","B",870,870) + +"BLD",7635,"KRN","B",8989.51,8989.51) + +"BLD",7635,"KRN","B",8989.52,8989.52) + +"BLD",7635,"KRN","B",8994,8994) + +"INIT") +INSTALL^TMGRPCSR +"KRN",8994,2499,-1) +0^1 +"KRN",8994,2499,0) +TMG SEARCH CHANNEL^CHANNEL^TMGRPCSR^2^^0^^1^1 +"KRN",8994,2499,1,0) +^8994.01^1^1^3100527^^^ +"KRN",8994,2499,1,1,0) +This RPC will be used to pass multiple requests back and forth from client to server +"KRN",8994,2499,2,0) +^8994.02A^1^1 +"KRN",8994,2499,2,1,0) +INPUT^3^^1^1 +"KRN",8994,2499,2,1,1,0) +^^1^1^3100527^^ +"KRN",8994,2499,2,1,1,1,0) +This is the data array sent from client. +"KRN",8994,2499,2,"B","INPUT",1) + +"KRN",8994,2499,2,"PARAMSEQ",1,1) + +"KRN",8994,2499,3,0) +^8994.03^1^1^3100527^^^ +"KRN",8994,2499,3,1,0) +This is the result array passed from server back to client. See documentation in CHANNEL^TMGRPCSR +"MBREQ") +0 +"ORD",16,8994) +8994;16;1;;;;;;;RPCDEL^XPDIA1 +"ORD",16,8994,0) +REMOTE PROCEDURE +"QUES","XPF1",0) +Y +"QUES","XPF1","??") +^D REP^XPDH +"QUES","XPF1","A") +Shall I write over your |FLAG| File +"QUES","XPF1","B") +YES +"QUES","XPF1","M") +D XPF1^XPDIQ +"QUES","XPF2",0) +Y +"QUES","XPF2","??") +^D DTA^XPDH +"QUES","XPF2","A") +Want my data |FLAG| yours +"QUES","XPF2","B") +YES +"QUES","XPF2","M") +D XPF2^XPDIQ +"QUES","XPI1",0) +YO +"QUES","XPI1","??") +^D INHIBIT^XPDH +"QUES","XPI1","A") +Want KIDS to INHIBIT LOGONs during the install +"QUES","XPI1","B") +NO +"QUES","XPI1","M") +D XPI1^XPDIQ +"QUES","XPM1",0) +PO^VA(200,:EM +"QUES","XPM1","??") +^D MG^XPDH +"QUES","XPM1","A") +Enter the Coordinator for Mail Group '|FLAG|' +"QUES","XPM1","B") + +"QUES","XPM1","M") +D XPM1^XPDIQ +"QUES","XPO1",0) +Y +"QUES","XPO1","??") +^D MENU^XPDH +"QUES","XPO1","A") +Want KIDS to Rebuild Menu Trees Upon Completion of Install +"QUES","XPO1","B") +NO +"QUES","XPO1","M") +D XPO1^XPDIQ +"QUES","XPZ1",0) +Y +"QUES","XPZ1","??") +^D OPT^XPDH +"QUES","XPZ1","A") +Want to DISABLE Scheduled Options, Menu Options, and Protocols +"QUES","XPZ1","B") +NO +"QUES","XPZ1","M") +D XPZ1^XPDIQ +"QUES","XPZ2",0) +Y +"QUES","XPZ2","??") +^D RTN^XPDH +"QUES","XPZ2","A") +Want to MOVE routines to other CPUs +"QUES","XPZ2","B") +NO +"QUES","XPZ2","M") +D XPZ2^XPDIQ +"RTN") +9 +"RTN","TMGDBAPI") +0^4^B13172584 +"RTN","TMGDBAPI",1,0) +TMGDBAPI ;TMG/kst/Database API library ;03/25/06, 5/24,10 +"RTN","TMGDBAPI",2,0) + ;;1.0;TMG-LIB;**1**;07/12/05;Build 1 +"RTN","TMGDBAPI",3,0) + +"RTN","TMGDBAPI",4,0) + ;"TMG DATABASE API FUNCTIONS +"RTN","TMGDBAPI",5,0) + ;"Kevin Toppenberg MD +"RTN","TMGDBAPI",6,0) + ;"GNU General Public License (GPL) applies +"RTN","TMGDBAPI",7,0) + ;"7-12-2005 +"RTN","TMGDBAPI",8,0) + +"RTN","TMGDBAPI",9,0) + ;"======================================================================= +"RTN","TMGDBAPI",10,0) + ;" API -- Public Functions. +"RTN","TMGDBAPI",11,0) + ;"======================================================================= +"RTN","TMGDBAPI",12,0) + ;"$$GetNumField^TMGDBAPI(FileNumber,FieldName) ;Convert Field Name to Field Number +"RTN","TMGDBAPI",13,0) + ;"$$GetFileNum^TMGDBAPI(FileName) ;Convert File Name to File Number +"RTN","TMGDBAPI",14,0) + ;"$$SetFileFldNums^TMGDBAPI(File,Field,FileNumber,FieldNumber) ;do both functions above at once. +"RTN","TMGDBAPI",15,0) + ;"$$GetFName^TMGDBAPI(FileNumber) ;Convert File Number to File Name +"RTN","TMGDBAPI",16,0) + ;"$$GetFldName^TMGDBAPI(File,FieldNumber) ;Convert Field Number to Field Name +"RTN","TMGDBAPI",17,0) + ;"$$GetFldList^TMGDBAPI(File,pArray) ;Get list of all fields for a file. +"RTN","TMGDBAPI",18,0) + ;"FieldExists^TMGDBAPI(FileNumber,Field) +"RTN","TMGDBAPI",19,0) + ;"SetFieldInfo^TMGDBAPI(File,Field,Array) +"RTN","TMGDBAPI",20,0) + ;"GetFieldInfo^TMGDBAPI(FileNumber,Field,VarOutP) +"RTN","TMGDBAPI",21,0) + ;"GetSubFileNumber^TMGDBAPI(FileNumber,Field) +"RTN","TMGDBAPI",22,0) + ;"$$IsSubFile^TMGDBAPI(File) +"RTN","TMGDBAPI",23,0) + ;"$$ISWPFLD(FILE,FLD) +"RTN","TMGDBAPI",24,0) + ;"GetSubFInfo^TMGDBAPI(SubFileNum,Array) +"RTN","TMGDBAPI",25,0) + ;"GetRecMatch^TMGDBAPI(Data,RecNumIEN) +"RTN","TMGDBAPI",26,0) + ;"CompRec^TMGDBAPI(FileNumber,dbRec,TestRec) +"RTN","TMGDBAPI",27,0) + ;"UploadData^TMGDBAPI(DaDIta,RecNumIEN) +"RTN","TMGDBAPI",28,0) + ;"ValueLookup^TMGDBAPI(Params) +"RTN","TMGDBAPI",29,0) + ;"FileUtility^TMGDBAPI(Params) +"RTN","TMGDBAPI",30,0) + ;"AddRec^TMGDBAPI(Data) +"RTN","TMGDBAPI",31,0) + ;"OverwriteRec^TMGDBAPI(RecNum,Data) +"RTN","TMGDBAPI",32,0) + ;"SetupFileNum^TMGDBAPI(Data) +"RTN","TMGDBAPI",33,0) + ;"RecFind^TMGDBAPI(Params) +"RTN","TMGDBAPI",34,0) + ;"FieldCompare^TMGDBAPI(TestField,dbField,Type) +"RTN","TMGDBAPI",35,0) + ;"$$dbWrite^TMGDBAPI(FDA,Overwrite,TMGIDE,Flags,ErrArray) +"RTN","TMGDBAPI",36,0) + ;"$$DelIEN^TMGDBAPI(File,RecNumIEN,ErrArray) +"RTN","TMGDBAPI",37,0) + ;"$$WriteWP^TMGDBAPI(File,RecNumIEN,Field,Array) +"RTN","TMGDBAPI",38,0) + ;"$$ReadWP^TMGDBAPI(File,IENS,Field,Array) +"RTN","TMGDBAPI",39,0) + ;"$$ShowIfError^TMGDBAPI(TMGMsg,PriorErrorFund) +"RTN","TMGDBAPI",40,0) + ;"$$GetValidInput^TMGDBAPI(File,Field) -- Get a valid input for field in file, asking user +"RTN","TMGDBAPI",41,0) + ;"$$AskFIENS^TMGDBAPI() -- pick a (sub)file number, then pick a record from that file. +"RTN","TMGDBAPI",42,0) + ;"$$AskIENS^TMGDBAPI(FileNum) -- return IENS for File (or subfile) number +"RTN","TMGDBAPI",43,0) + ;"GetRef^TMGDBAPI(file,IENS,field) -- to return the global reference for a given record +"RTN","TMGDBAPI",44,0) + ;"GetPtrsOUT^TMGDBAPI(FileNum,Info) -- get a list of pointers out from the file. +"RTN","TMGDBAPI",45,0) + ;"$$TrimFDA^TMGDBAPI(FDA,Quiet) -- Trim FDA of any data already present in the database +"RTN","TMGDBAPI",46,0) + +"RTN","TMGDBAPI",47,0) + ;"======================================================================= +"RTN","TMGDBAPI",48,0) + ;"PRIVATE API FUNCTIONS +"RTN","TMGDBAPI",49,0) + ;"======================================================================= +"RTN","TMGDBAPI",50,0) + ;"ConvertFDA(FDA,MarkerArray) +"RTN","TMGDBAPI",51,0) + ;"ConvertIENS(IENS,MarkerArray) +"RTN","TMGDBAPI",52,0) + ;"SetupFDA(Data,FDA,IENS,SrchType,MarkNum,MsgArray,Minimal,RecNum) +"RTN","TMGDBAPI",53,0) + ;"HackWrite(GlobalP,FileNumber,IENS,FieldNum,Data) +"RTN","TMGDBAPI",54,0) + ;"HandleHacksArray(MsgArray) +"RTN","TMGDBAPI",55,0) + ;"GetRefArray(FileNum,array) +"RTN","TMGDBAPI",56,0) + +"RTN","TMGDBAPI",57,0) + ;"======================================================================= +"RTN","TMGDBAPI",58,0) + ;"DEPENDENCIES +"RTN","TMGDBAPI",59,0) + ;"TMGDEBUG +"RTN","TMGDBAPI",60,0) + ;"TMGUSRIF +"RTN","TMGDBAPI",61,0) + ;"TMGSTUTL +"RTN","TMGDBAPI",62,0) + ;"======================================================================= +"RTN","TMGDBAPI",63,0) + +"RTN","TMGDBAPI",64,0) + ;"======================================================================= +"RTN","TMGDBAPI",65,0) + +"RTN","TMGDBAPI",66,0) + ;"FORMAT OF DATA ARRAY +"RTN","TMGDBAPI",67,0) + +"RTN","TMGDBAPI",68,0) + ;" cNull="(none)" +"RTN","TMGDBAPI",69,0) + ;" cRecNum="RECNUM" +"RTN","TMGDBAPI",70,0) + ;" cOutput="OUTVAR" +"RTN","TMGDBAPI",71,0) + ;" cGlobal="GLOBAL" +"RTN","TMGDBAPI",72,0) + ;" cEntries="Entries" +"RTN","TMGDBAPI",73,0) + ;" cFlags="FLAGS" +"RTN","TMGDBAPI",74,0) + ;" cParentIENS="ParentIENS" +"RTN","TMGDBAPI",75,0) + +"RTN","TMGDBAPI",76,0) + ;"The Data array will be filed with data. (An example) +"RTN","TMGDBAPI",77,0) + ;" Data(0,"FILE")="1234.1" <-- "NEW PERSON" Note conversion +"RTN","TMGDBAPI",78,0) + ;" Data(0,"FILE",cGlobal)="^DIC(200)" <-- note, NOT "^DIC(200," +"RTN","TMGDBAPI",79,0) + ;" Data(0,cRecNum)=2 <-- only if user-specified. +"RTN","TMGDBAPI",80,0) + ;" Data(0,cEntries)=1 +"RTN","TMGDBAPI",81,0) + ;" Data(1,".01")="MyData1" +"RTN","TMGDBAPI",82,0) + ;" Data(1,".01","MATCHVALUE")="MyData1" +"RTN","TMGDBAPI",83,0) + ;" Data(1,".01",cFlags)=any flags given (only present if user specified) +"RTN","TMGDBAPI",84,0) + ;" Data(1,".02")="Bill" +"RTN","TMGDBAPI",85,0) + ;" Data(1,".02","MATCHVALUE")="John" +"RTN","TMGDBAPI",86,0) + ;" Data(1,".03")="MyData3" +"RTN","TMGDBAPI",87,0) + ;" Data(1,".03",cFlags)=any flags given (only present if user specified) +"RTN","TMGDBAPI",88,0) + ;" Data(1,".04")="MyData4" +"RTN","TMGDBAPI",89,0) + ;" Data(1,".06")="MyData5" <-- note "NAME" was converted to ".06" +"RTN","TMGDBAPI",90,0) + ;" Data(1,".07",0,cEntries)=2 <-- "ITEM" converted to ".07" +"RTN","TMGDBAPI",91,0) + ;" Data(1,".07",0,cParentIENS)=",10033," +"RTN","TMGDBAPI",92,0) + ;" Data(1,".07",1,".01")="SubEntry1" +"RTN","TMGDBAPI",93,0) + ;" Data(1,".07",1,".02")="SE1" +"RTN","TMGDBAPI",94,0) + ;" Data(1,".07",1,".03")="'Some Info'" +"RTN","TMGDBAPI",95,0) + ;" Data(1,".07",2,".01")="SubEntry2" +"RTN","TMGDBAPI",96,0) + ;" Data(1,".07",2,".02")="SE2" +"RTN","TMGDBAPI",97,0) + ;" Data(1,".07",2,".04",0,cEntries)=1 ;"TEXT converted to .04 +"RTN","TMGDBAPI",98,0) + ;" Data(1,".07",2,".04",0,cParentIENS)=",3,10033," +"RTN","TMGDBAPI",99,0) + ;" Data(1,".07",2,".04",1,".01")="JD" +"RTN","TMGDBAPI",100,0) + ;" Data(1,".07",2,".04",1,".02")="DOE,JOHN" +"RTN","TMGDBAPI",101,0) + +"RTN","TMGDBAPI",102,0) + ;"======================================================================= +"RTN","TMGDBAPI",103,0) + ;"======================================================================= +"RTN","TMGDBAPI",104,0) + +"RTN","TMGDBAPI",105,0) +GetNumField(FileNumber,FieldName) +"RTN","TMGDBAPI",106,0) + ;"PUBLIC FUNCTION +"RTN","TMGDBAPI",107,0) + ;"Purpose: Given file and the name of a field, this will return the field NUMBER +"RTN","TMGDBAPI",108,0) + ;"Input: FileNumber. Number of file, i.e. "4.11" +"RTN","TMGDBAPI",109,0) + ;" FieldName: the name of a field, i.e. "NAME" spelling must exactly match +"RTN","TMGDBAPI",110,0) + ;"Output: Returns field number, i.e. ".01" or 0 if not found +"RTN","TMGDBAPI",111,0) + +"RTN","TMGDBAPI",112,0) + new cOKToCont set cOKToCont=1 +"RTN","TMGDBAPI",113,0) + new cAbort set cAbort=0 +"RTN","TMGDBAPI",114,0) + if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 +"RTN","TMGDBAPI",115,0) + +"RTN","TMGDBAPI",116,0) + new result +"RTN","TMGDBAPI",117,0) + if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetNumField^TMGDBAPI") +"RTN","TMGDBAPI",118,0) + +"RTN","TMGDBAPI",119,0) + set result=$$FLDNUM^DILFD(FileNumber,FieldName) +"RTN","TMGDBAPI",120,0) + +"RTN","TMGDBAPI",121,0) + if result'=0 goto GNMFDone +"RTN","TMGDBAPI",122,0) + +"RTN","TMGDBAPI",123,0) + ;"-------------------------- +"RTN","TMGDBAPI",124,0) + ;"The below is a manual method +"RTN","TMGDBAPI",125,0) + +"RTN","TMGDBAPI",126,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Having difficulty finding field name (? due to security ?). Doing Manual Check.") +"RTN","TMGDBAPI",127,0) + +"RTN","TMGDBAPI",128,0) + new FoundField +"RTN","TMGDBAPI",129,0) + new Index +"RTN","TMGDBAPI",130,0) + new result set result=cAbort +"RTN","TMGDBAPI",131,0) + set U=$get(U,"^") ;"Setup up U if doesn't yet exist +"RTN","TMGDBAPI",132,0) + +"RTN","TMGDBAPI",133,0) + if $$VFILE^DILFD(FileNumber)=0 do goto GNMFDone +"RTN","TMGDBAPI",134,0) + . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: Requested file, #"_FileNumber_", doesn't exist.") +"RTN","TMGDBAPI",135,0) + +"RTN","TMGDBAPI",136,0) + set Index="" +"RTN","TMGDBAPI",137,0) +GNmLoop set Index=$order(^DD(FileNumber,Index)) +"RTN","TMGDBAPI",138,0) + if Index="" goto GNMFDone +"RTN","TMGDBAPI",139,0) + if $data(^DD(FileNumber,Index,0))=0 goto GNMFDone +"RTN","TMGDBAPI",140,0) + set FoundField=$piece(^DD(FileNumber,Index,0),"^",1) +"RTN","TMGDBAPI",141,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Comparing fields: '",FoundField,"' vs. '",FieldName,"'") +"RTN","TMGDBAPI",142,0) + if FieldName=FoundField do goto GNMFDone +"RTN","TMGDBAPI",143,0) + . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Match!") +"RTN","TMGDBAPI",144,0) + . set result=Index +"RTN","TMGDBAPI",145,0) + goto GNmLoop +"RTN","TMGDBAPI",146,0) + +"RTN","TMGDBAPI",147,0) +GNMFDone +"RTN","TMGDBAPI",148,0) + if result=cAbort do +"RTN","TMGDBAPI",149,0) + . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Unable to convert '",FieldName,"' in file '",FileNumber,"' to a field number. Check for Field name typo") +"RTN","TMGDBAPI",150,0) + if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetNumField^TMGDBAPI") +"RTN","TMGDBAPI",151,0) + +"RTN","TMGDBAPI",152,0) + quit result +"RTN","TMGDBAPI",153,0) + +"RTN","TMGDBAPI",154,0) +SetFileFldNums(File,Field,FileNumber,FieldNumber) +"RTN","TMGDBAPI",155,0) + ;"Purpose: To provide a generic shell to ensure that File and Field numbers are in place +"RTN","TMGDBAPI",156,0) + ;"Input: File -- File number or name +"RTN","TMGDBAPI",157,0) + ;" Field -- field number or name +"RTN","TMGDBAPI",158,0) + ;" FileNumber -- PASS BY REFERENCE -- an out parameter +"RTN","TMGDBAPI",159,0) + ;" FieldNum -- PASS BY REFERENCE -- an out parameter +"RTN","TMGDBAPI",160,0) + ;"Results: cOKToCont(1) if ok, otherwise cAbort(0) if error +"RTN","TMGDBAPI",161,0) + ;"Output -- FileNumber and FieldNumber are filled in. +"RTN","TMGDBAPI",162,0) + +"RTN","TMGDBAPI",163,0) + new cOKToCont set cOKToCont=1 +"RTN","TMGDBAPI",164,0) + new cAbort set cAbort=0 +"RTN","TMGDBAPI",165,0) + if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 +"RTN","TMGDBAPI",166,0) + +"RTN","TMGDBAPI",167,0) + new result set result=cOKToCont +"RTN","TMGDBAPI",168,0) + if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"SetFileFldNums^TMGDBAPI") +"RTN","TMGDBAPI",169,0) + +"RTN","TMGDBAPI",170,0) + set FileNumber=+$get(File) +"RTN","TMGDBAPI",171,0) + if FileNumber=0 set FileNumber=$$GetFileNum(.File) +"RTN","TMGDBAPI",172,0) + if FileNumber=0 do goto SFFNDone +"RTN","TMGDBAPI",173,0) + . set result=cAbort +"RTN","TMGDBAPI",174,0) + . do ShowError^TMGDEBUG(.PriorErrorFound,"Can't convert file '"_$get(File)_", to a number.") +"RTN","TMGDBAPI",175,0) + +"RTN","TMGDBAPI",176,0) + set FieldNumber=$get(Field) +"RTN","TMGDBAPI",177,0) + if FieldNumber=0 set FieldNumber=$$GetNumField(FileNumber,.Field) +"RTN","TMGDBAPI",178,0) + if FieldNumber=0 do goto SFFNDone +"RTN","TMGDBAPI",179,0) + . set result=cAbort +"RTN","TMGDBAPI",180,0) + . do ShowError^TMGDEBUG(.PriorErrorFound,"Can't convert field '"_$get(Field)_", to a number.") +"RTN","TMGDBAPI",181,0) + +"RTN","TMGDBAPI",182,0) +SFFNDone +"RTN","TMGDBAPI",183,0) + if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"SetFileFldNums^TMGDBAPI") +"RTN","TMGDBAPI",184,0) + quit result +"RTN","TMGDBAPI",185,0) + +"RTN","TMGDBAPI",186,0) + +"RTN","TMGDBAPI",187,0) +FieldExists(FileNumber,Field) +"RTN","TMGDBAPI",188,0) + ;"PUBLIC FUNCTION +"RTN","TMGDBAPI",189,0) + ;"Purpose: To ensure that a field exists -- even if hidden by security measures +"RTN","TMGDBAPI",190,0) + ;"Input: FileNumber: File to check +"RTN","TMGDBAPI",191,0) + ;" Field: the field number (or name) to check +"RTN","TMGDBAPI",192,0) + ;"Result: 1 if field exists, 0 if doesn't, 2 if exists but is hidden to user +"RTN","TMGDBAPI",193,0) + +"RTN","TMGDBAPI",194,0) + new result,FieldNumber +"RTN","TMGDBAPI",195,0) + if +Field=0 set FieldNumber=$$GetNumField(FileNumber,Field) +"RTN","TMGDBAPI",196,0) + else set FieldNumber=Field +"RTN","TMGDBAPI",197,0) + +"RTN","TMGDBAPI",198,0) + set result=$$VFIELD^DILFD(FileNumber,FieldNumber) +"RTN","TMGDBAPI",199,0) + if result=1 goto FExsDone +"RTN","TMGDBAPI",200,0) + +"RTN","TMGDBAPI",201,0) + ;"Try a low-level data dictionary eval to see if really does exist, but is hidden +"RTN","TMGDBAPI",202,0) + if $data(^DD(FileNumber,FieldNumber,0))'=0 set result=2 +"RTN","TMGDBAPI",203,0) + +"RTN","TMGDBAPI",204,0) +FExsDone +"RTN","TMGDBAPI",205,0) + quit result +"RTN","TMGDBAPI",206,0) + +"RTN","TMGDBAPI",207,0) + +"RTN","TMGDBAPI",208,0) + +"RTN","TMGDBAPI",209,0) +GetSubFileNumber(FileNumber,Field) +"RTN","TMGDBAPI",210,0) + ;"PUBLIC FUNCTION +"RTN","TMGDBAPI",211,0) + ;"Purpose: If FieldNumber is a 'multiple' field, then this function should return 'subfile' +"RTN","TMGDBAPI",212,0) + ;" number of the sub file. +"RTN","TMGDBAPI",213,0) + ;"Input:FileNumber-- the file number (or sub file number) that field exists in +"RTN","TMGDBAPI",214,0) + ;" Field-- the field number (or name) in file to lookup +"RTN","TMGDBAPI",215,0) + ;"Result: Returns sub file number, or 0 if not found or invalid +"RTN","TMGDBAPI",216,0) + +"RTN","TMGDBAPI",217,0) + new cOKToCont set cOKToCont=1 +"RTN","TMGDBAPI",218,0) + new cAbort set cAbort=0 +"RTN","TMGDBAPI",219,0) + if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 +"RTN","TMGDBAPI",220,0) + +"RTN","TMGDBAPI",221,0) + new Info +"RTN","TMGDBAPI",222,0) + new result set result=cAbort +"RTN","TMGDBAPI",223,0) + new Output +"RTN","TMGDBAPI",224,0) + +"RTN","TMGDBAPI",225,0) + if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetSubFileNumber^TMGDBAPI") +"RTN","TMGDBAPI",226,0) + +"RTN","TMGDBAPI",227,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FileNumber=",FileNumber) +"RTN","TMGDBAPI",228,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Field=",Field) +"RTN","TMGDBAPI",229,0) + +"RTN","TMGDBAPI",230,0) + ;"First, verify file (or subfile) exists +"RTN","TMGDBAPI",231,0) + if $$VFILE^DILFD(FileNumber)=0 do goto GSFDone ;"abort +"RTN","TMGDBAPI",232,0) + . do ShowError^TMGDEBUG(.PriorErrorFound,"File number '"_FileNumber_"' is not valid.") +"RTN","TMGDBAPI",233,0) + +"RTN","TMGDBAPI",234,0) + ;"Next, ensure Field exists in file +"RTN","TMGDBAPI",235,0) + if $$FieldExists(FileNumber,Field)=0 do goto GSFDone ;"abort +"RTN","TMGDBAPI",236,0) + . do ShowError^TMGDEBUG(.PriorErrorFound,"Field number '"_Field_"' is not valid.") +"RTN","TMGDBAPI",237,0) + +"RTN","TMGDBAPI",238,0) + ;"Next, ensure field is a multiple and get field info. +"RTN","TMGDBAPI",239,0) + do GetFieldInfo(FileNumber,Field,"Output") +"RTN","TMGDBAPI",240,0) + if $data(Output("MULTIPLE-VALUED"))=0 do goto GSFDone ;"abort +"RTN","TMGDBAPI",241,0) + . do ShowError^TMGDEBUG(.PriorErrorFound,"Field '"_Field_"' in File '"_FileNumber_"' is not a subfile.") +"RTN","TMGDBAPI",242,0) + +"RTN","TMGDBAPI",243,0) + ;"Now actually get subfile number +"RTN","TMGDBAPI",244,0) + if $data(Output("SPECIFIER"))=0 do goto GSFDone ;"abort +"RTN","TMGDBAPI",245,0) + . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to find 'Specifier' (subfile number)") +"RTN","TMGDBAPI",246,0) + set result=+Output("SPECIFIER") +"RTN","TMGDBAPI",247,0) + +"RTN","TMGDBAPI",248,0) + ;"Now actually get subfile number +"RTN","TMGDBAPI",249,0) + ;"set Info=$get(^DD(FileNumber,Field,0),0) +"RTN","TMGDBAPI",250,0) + ;"if Info=0 do goto GSFDone +"RTN","TMGDBAPI",251,0) + ;". do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to get information from data dictionary.") +"RTN","TMGDBAPI",252,0) + ;"set result=+$piece(Info,"^",2) +"RTN","TMGDBAPI",253,0) + +"RTN","TMGDBAPI",254,0) +GSFDone +"RTN","TMGDBAPI",255,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"SubFile number is: ",result) +"RTN","TMGDBAPI",256,0) + if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetSubFileNumber^TMGDBAPI") +"RTN","TMGDBAPI",257,0) + quit result +"RTN","TMGDBAPI",258,0) + +"RTN","TMGDBAPI",259,0) +ISWPFLD(FILE,FLD) ; +"RTN","TMGDBAPI",260,0) + ;"Purpose: return if field FLD is a WP field +"RTN","TMGDBAPI",261,0) + ;"Input: FILE -- file NUMBER +"RTN","TMGDBAPI",262,0) + ;" FLD -- field NUMBER +"RTN","TMGDBAPI",263,0) + ;"Result: 1 if WP field, 0 if not +"RTN","TMGDBAPI",264,0) + new result set result=0 +"RTN","TMGDBAPI",265,0) + new info +"RTN","TMGDBAPI",266,0) + set info=$piece($get(^DD(FILE,FLD,0)),"^",2) +"RTN","TMGDBAPI",267,0) + if +info'=info goto IWPDN +"RTN","TMGDBAPI",268,0) + new subFile set subFile=+info +"RTN","TMGDBAPI",269,0) + set info=$piece($get(^DD(subFile,.01,0)),"^",2) +"RTN","TMGDBAPI",270,0) + set result=(info["W") +"RTN","TMGDBAPI",271,0) +IWPDN quit result +"RTN","TMGDBAPI",272,0) + +"RTN","TMGDBAPI",273,0) +IsSubFile(File) +"RTN","TMGDBAPI",274,0) + ;"Purpose: to return if file is actually a subfile +"RTN","TMGDBAPI",275,0) + ;"Input: File -- File name or number +"RTN","TMGDBAPI",276,0) + ;"Results: Parent file number^Field in Parent File +"RTN","TMGDBAPI",277,0) + ;" or 0 if not a subfile. +"RTN","TMGDBAPI",278,0) + +"RTN","TMGDBAPI",279,0) + new result +"RTN","TMGDBAPI",280,0) + if +File'=File set File=$$GetFileNum(File) +"RTN","TMGDBAPI",281,0) + set result=+$get(^DD(File,0,"UP")) +"RTN","TMGDBAPI",282,0) + if result'>0 goto ISFDone +"RTN","TMGDBAPI",283,0) + +"RTN","TMGDBAPI",284,0) + ;"Now find which field this sub file is in its parent +"RTN","TMGDBAPI",285,0) + new fldInParent set fldInParent=0 +"RTN","TMGDBAPI",286,0) + new field set field=0 +"RTN","TMGDBAPI",287,0) + new done set done=0 +"RTN","TMGDBAPI",288,0) + for set field=$order(^DD(result,field)) quit:(+field'>0)!(done=1) do +"RTN","TMGDBAPI",289,0) + . new fldInfo set fldInfo=$piece($get(^DD(result,field,0)),"^",2) +"RTN","TMGDBAPI",290,0) + . if +fldInfo=File set fldInParent=field set done=1 +"RTN","TMGDBAPI",291,0) + if fldInParent>0 set result=result_"^"_fldInParent +"RTN","TMGDBAPI",292,0) +ISFDone +"RTN","TMGDBAPI",293,0) + quit result +"RTN","TMGDBAPI",294,0) + +"RTN","TMGDBAPI",295,0) + +"RTN","TMGDBAPI",296,0) +GetSubFInfo(SubFileNum,Array) +"RTN","TMGDBAPI",297,0) + ;"PUBLIC FUNCTION +"RTN","TMGDBAPI",298,0) + ;"Purpose: To take a subfile NUMBER, and return information about it. +"RTN","TMGDBAPI",299,0) + ;"Input: SubFileNum-- the sub file number +"RTN","TMGDBAPI",300,0) + ;" Array -- PASS BY REFERENCE. An array to receive results. +"RTN","TMGDBAPI",301,0) + ;" any preexisting data is deleted. +"RTN","TMGDBAPI",302,0) + ;"Output Array is formated as follows: +"RTN","TMGDBAPI",303,0) + ;" Array("SUBFILE","NUMBER")=file number of this sub file. +"RTN","TMGDBAPI",304,0) + ;" Array("SUBFILE","NAME")=file name of this sub file. +"RTN","TMGDBAPI",305,0) + ;" Array("PARENT","NUMBER")=parent file number +"RTN","TMGDBAPI",306,0) + ;" Array("PARENT","NAME")=parent file name +"RTN","TMGDBAPI",307,0) + ;" Array("PARENT","GL")=global reference of parent, in open format<-- only valid if parent isn't also a subfile +"RTN","TMGDBAPI",308,0) + ;" Array("FIELD IN PARENT","NUMBER")=field number of subfile in parent +"RTN","TMGDBAPI",309,0) + ;" Array("FIELD IN PARENT","NAME")=filed name of subfile in parent +"RTN","TMGDBAPI",310,0) + ;" Array("FIELD IN PARENT","LOC")=node and piece where subfile is stored +"RTN","TMGDBAPI",311,0) + ;" Array("FIELD IN PARENT","CODE")=code giving subfile's attributes. +"RTN","TMGDBAPI",312,0) + ;"Result: 1 if found info, or 0 if not found or invalid +"RTN","TMGDBAPI",313,0) + +"RTN","TMGDBAPI",314,0) + new result set result=0 +"RTN","TMGDBAPI",315,0) + if '$get(SubFileNum) goto GSPDone +"RTN","TMGDBAPI",316,0) + kill Array +"RTN","TMGDBAPI",317,0) + set Array("SUBFILE","NUMBER")=SubFileNum +"RTN","TMGDBAPI",318,0) + set Array("SUBFILE","NAME")=$piece($get(^DD(SubFileNum,0)),"^",1) +"RTN","TMGDBAPI",319,0) + new parent +"RTN","TMGDBAPI",320,0) + set parent=+$get(^DD(SubFileNum,0,"UP")) +"RTN","TMGDBAPI",321,0) + if parent=0 goto GSPDone +"RTN","TMGDBAPI",322,0) + set Array("PARENT","NUMBER")=parent +"RTN","TMGDBAPI",323,0) + set Array("PARENT","NAME")=$order(^DD(parent,0,"NM","")) +"RTN","TMGDBAPI",324,0) + set Array("PARENT","GL")=$get(^DIC(parent,0,"GL")) +"RTN","TMGDBAPI",325,0) + new i set i=$order(^DD(parent,"")) +"RTN","TMGDBAPI",326,0) + for do quit:(i="")!(result=1) ;"scan all fields for a match +"RTN","TMGDBAPI",327,0) + . quit:(i="") +"RTN","TMGDBAPI",328,0) + . new node,num +"RTN","TMGDBAPI",329,0) + . set node=$get(^DD(parent,i,0)) +"RTN","TMGDBAPI",330,0) + . if +$piece(node,"^",2)=SubFileNum do quit +"RTN","TMGDBAPI",331,0) + . . set Array("FIELD IN PARENT","NUMBER")=i +"RTN","TMGDBAPI",332,0) + . . set Array("FIELD IN PARENT","NAME")=$piece(node,"^",1) +"RTN","TMGDBAPI",333,0) + . . set Array("FIELD IN PARENT","LOC")=$piece(node,"^",4) +"RTN","TMGDBAPI",334,0) + . . set Array("FIELD IN PARENT","CODE")=$piece(node,"^",2) +"RTN","TMGDBAPI",335,0) + . . set result=1 +"RTN","TMGDBAPI",336,0) + . set i=$order(^DD(parent,i)) +"RTN","TMGDBAPI",337,0) + +"RTN","TMGDBAPI",338,0) +GSPDone +"RTN","TMGDBAPI",339,0) + quit result +"RTN","TMGDBAPI",340,0) + +"RTN","TMGDBAPI",341,0) + +"RTN","TMGDBAPI",342,0) + +"RTN","TMGDBAPI",343,0) +GetFieldInfo(FileNumber,Field,VarOutP,InfoS) +"RTN","TMGDBAPI",344,0) + ;"PUBLIC FUNCTION +"RTN","TMGDBAPI",345,0) + ;"Purpose: To get Field info, +"RTN","TMGDBAPI",346,0) + ;"Input: FileNumber: File or subfile number +"RTN","TMGDBAPI",347,0) + ;" Field: Field name or number +"RTN","TMGDBAPI",348,0) + ;" VarOutP -- the NAME of the variable to put result into. +"RTN","TMGDBAPI",349,0) + ;" InfoS -- [OPTIONAL] -- additional attributes of field info to be looked up +"RTN","TMGDBAPI",350,0) + ;" (as allowed by FIELD^DID). Multiple items should be +"RTN","TMGDBAPI",351,0) + ;" separated by a semicolon (';') +"RTN","TMGDBAPI",352,0) + ;" e.g. "TITLE;LABEL;POINTER" +"RTN","TMGDBAPI",353,0) + ;"Output: Data is put into VarOutP (any thing in VarOutP is erased first +"RTN","TMGDBAPI",354,0) + ;" i.e. @VarOutP@("MULTIPLE-VALUED")=X +"RTN","TMGDBAPI",355,0) + ;" i.e. @VarOutP@("SPECIFIER")=Y +"RTN","TMGDBAPI",356,0) + ;" i.e. @VarOutP@("TYPE")=Z +"RTN","TMGDBAPI",357,0) + ;" i.e. @VarOutP@("StoreLoc")="0;1" <-- not from fileman output (i.e. extra info) +"RTN","TMGDBAPI",358,0) + ;" (if additional attributes were specified, they will also be in array) +"RTN","TMGDBAPI",359,0) + ;"Result: none +"RTN","TMGDBAPI",360,0) + +"RTN","TMGDBAPI",361,0) + kill @VarOutP ;"erase any old information +"RTN","TMGDBAPI",362,0) + +"RTN","TMGDBAPI",363,0) + if +Field=0 set Field=$$GetNumField(FileNumber,Field) +"RTN","TMGDBAPI",364,0) + set @VarOutP@("StoreLoc")=$piece($get(^DD(FileNumber,Field,0)),"^",4) +"RTN","TMGDBAPI",365,0) + +"RTN","TMGDBAPI",366,0) + new Attribs set Attribs="MULTIPLE-VALUED;SPECIFIER;TYPE" +"RTN","TMGDBAPI",367,0) + if $data(InfoS) set Attribs=Attribs_";"_InfoS +"RTN","TMGDBAPI",368,0) + ;"Next, check if field is a multiple and get field info. +"RTN","TMGDBAPI",369,0) + do FIELD^DID(FileNumber,Field,,Attribs,VarOutP,"TMGMsg") +"RTN","TMGDBAPI",370,0) + if $data(TMGMsg) do +"RTN","TMGDBAPI",371,0) + . if $data(TMGMsg("DIERR"))'=0 do quit +"RTN","TMGDBAPI",372,0) + . . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) +"RTN","TMGDBAPI",373,0) + +"RTN","TMGDBAPI",374,0) +GFIDone +"RTN","TMGDBAPI",375,0) + quit +"RTN","TMGDBAPI",376,0) + +"RTN","TMGDBAPI",377,0) + +"RTN","TMGDBAPI",378,0) + +"RTN","TMGDBAPI",379,0) +HackWrite(GlobalP,FileNumber,IENS,FieldNum,Data) +"RTN","TMGDBAPI",380,0) + ;"PUBLIC FUNCTION +"RTN","TMGDBAPI",381,0) + ;"Purpse: To force data into a field -- using low level 'hack' method +"RTN","TMGDBAPI",382,0) + ;"Input: GlobalP -- the NAME of the global to put this into, i.e. "^VA(200," +"RTN","TMGDBAPI",383,0) + ;" FileNumber- the file number +"RTN","TMGDBAPI",384,0) + ;" IENS -- the standard API IENS +"RTN","TMGDBAPI",385,0) + ;" FieldNum the field to put this into +"RTN","TMGDBAPI",386,0) + ;" Data -- the value to put in +"RTN","TMGDBAPI",387,0) + ;"Note: This can be used to put a value of "@" into a field +"RTN","TMGDBAPI",388,0) + ;"Result: 1 if ok to continue, 0=abort +"RTN","TMGDBAPI",389,0) + ;"!!!NOTICE: This is a very low level means of accessing the database. +"RTN","TMGDBAPI",390,0) + ;" The built in data verifiers, indexers etc etc will not be made aware of +"RTN","TMGDBAPI",391,0) + ;" changes made to the database through this method. USE ONLY WITH CAUTION. +"RTN","TMGDBAPI",392,0) + +"RTN","TMGDBAPI",393,0) + new cOKToCont set cOKToCont=1 +"RTN","TMGDBAPI",394,0) + new cAbort set cAbort=0 +"RTN","TMGDBAPI",395,0) + if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 +"RTN","TMGDBAPI",396,0) + +"RTN","TMGDBAPI",397,0) + new result set result=cAbort +"RTN","TMGDBAPI",398,0) + +"RTN","TMGDBAPI",399,0) + if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"HackWrite^TMGDBAPI") +"RTN","TMGDBAPI",400,0) + +"RTN","TMGDBAPI",401,0) + if '$data(GlobalP) goto HWDone +"RTN","TMGDBAPI",402,0) + if '$data(FileNumber) goto HWDone +"RTN","TMGDBAPI",403,0) + if '$data(IENS) goto HWDone +"RTN","TMGDBAPI",404,0) + if '$data(FieldNum) goto HWDone +"RTN","TMGDBAPI",405,0) + if '$data(Data) goto HWDone +"RTN","TMGDBAPI",406,0) + +"RTN","TMGDBAPI",407,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"GlobalP: ",GlobalP) +"RTN","TMGDBAPI",408,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"File:",FileNumber) +"RTN","TMGDBAPI",409,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"IENS:",IENS) +"RTN","TMGDBAPI",410,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldNum:",FieldNum) +"RTN","TMGDBAPI",411,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Data:",Data) +"RTN","TMGDBAPI",412,0) + +"RTN","TMGDBAPI",413,0) + new DDInfo +"RTN","TMGDBAPI",414,0) + new FieldInfo +"RTN","TMGDBAPI",415,0) + new Index,Part +"RTN","TMGDBAPI",416,0) + new OldData +"RTN","TMGDBAPI",417,0) + new RecNum +"RTN","TMGDBAPI",418,0) + +"RTN","TMGDBAPI",419,0) + ;"Get info from data dictionary r.e. where actual fields are stored in files. +"RTN","TMGDBAPI",420,0) + set DDInfo=$get(^DD(FileNumber,FieldNum,0)) +"RTN","TMGDBAPI",421,0) + if '$data(DDInfo) goto HWDone +"RTN","TMGDBAPI",422,0) + set FieldInfo=$piece(DDInfo,"^",4) +"RTN","TMGDBAPI",423,0) + if '$data(FieldInfo),(FieldInfo="") goto HWDone +"RTN","TMGDBAPI",424,0) + set Index=$piece(FieldInfo,";",1) +"RTN","TMGDBAPI",425,0) + set Part=$piece(FieldInfo,";",2) +"RTN","TMGDBAPI",426,0) + +"RTN","TMGDBAPI",427,0) + ;"Convert global form of ^VA(200, into ^VA(200) +"RTN","TMGDBAPI",428,0) + new Len +"RTN","TMGDBAPI",429,0) + set Len=$length(GlobalP) +"RTN","TMGDBAPI",430,0) + if $extract(GlobalP,Len)="," do +"RTN","TMGDBAPI",431,0) + . set $extract(GlobalP,Len)=")" +"RTN","TMGDBAPI",432,0) + +"RTN","TMGDBAPI",433,0) + set RecNum=$piece(IENS,",",1) +"RTN","TMGDBAPI",434,0) + if $piece(IENS,",",2)'="" do goto HWDone +"RTN","TMGDBAPI",435,0) + . do ShowError^TMGDEBUG(.PriorErrorFound,"Hack writing to subfiles not supported") +"RTN","TMGDBAPI",436,0) + if $data(@GlobalP@(RecNum,Index))=0 goto HWDone +"RTN","TMGDBAPI",437,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"I think the correct data place is: ",GlobalP,"(",RecNum,",",Index,") at piece: ",Part) +"RTN","TMGDBAPI",438,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"That line is now: ",@GlobalP@(RecNum,Index)) +"RTN","TMGDBAPI",439,0) + set OldData=$piece(@GlobalP@(RecNum,Index),"^",Part) +"RTN","TMGDBAPI",440,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"And that data item is now: '",OldData,"'") +"RTN","TMGDBAPI",441,0) + if Data'=OldData do +"RTN","TMGDBAPI",442,0) + . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Performing hack write") +"RTN","TMGDBAPI",443,0) + . set $piece(@GlobalP@(RecNum,Index),"^",Part)=Data +"RTN","TMGDBAPI",444,0) + . ;"Give Message +"RTN","TMGDBAPI",445,0) + . new Text +"RTN","TMGDBAPI",446,0) + . set Text(0)=" Caution" +"RTN","TMGDBAPI",447,0) + . set Text(1)="Yikes!" +"RTN","TMGDBAPI",448,0) + . set Text(2)=" " +"RTN","TMGDBAPI",449,0) + . set Text(3)="We just bypassed all safety measures, " +"RTN","TMGDBAPI",450,0) + . set Text(4)="and wrote directly to the database." +"RTN","TMGDBAPI",451,0) + . set Text(5)="Make sure you know what you are doing!!" +"RTN","TMGDBAPI",452,0) + . set Text(6)=" " +"RTN","TMGDBAPI",453,0) + . set Text(7)="File: "_FileNumber +"RTN","TMGDBAPI",454,0) + . set Text(8)="Field: "_FieldNum +"RTN","TMGDBAPI",455,0) + . set Text(9)="Prior value: '"_OldData_"'" +"RTN","TMGDBAPI",456,0) + . set Text(10)="New value: '"_Data_"'" +"RTN","TMGDBAPI",457,0) + . set Text(11)=" " +"RTN","TMGDBAPI",458,0) + . set Text(12)="(This was caused by using Flags='H' in" +"RTN","TMGDBAPI",459,0) + . set Text(13)="the XML script.)" +"RTN","TMGDBAPI",460,0) + . do PopupArray^TMGUSRIF(5,45,.Text) +"RTN","TMGDBAPI",461,0) + else do +"RTN","TMGDBAPI",462,0) + . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"No need for hackwrite... the data is already what we want.") +"RTN","TMGDBAPI",463,0) + +"RTN","TMGDBAPI",464,0) +HWDone +"RTN","TMGDBAPI",465,0) + if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"HackWrite^TMGDBAPI") +"RTN","TMGDBAPI",466,0) + quit +"RTN","TMGDBAPI",467,0) + +"RTN","TMGDBAPI",468,0) + +"RTN","TMGDBAPI",469,0) +HandleHacksArray(MsgArray) +"RTN","TMGDBAPI",470,0) + ;"PUBLIC FUNCTION +"RTN","TMGDBAPI",471,0) + ;"Purpose: To cycle through an array of hackwrites and process each one. +"RTN","TMGDBAPI",472,0) + ;"Input: HacksArray. Best if passed by reference +"RTN","TMGDBAPI",473,0) + ;" Expected format of array: +"RTN","TMGDBAPI",474,0) + ;" MsgArray(cHack,0,cEntries)=Number of Entries +"RTN","TMGDBAPI",475,0) + ;" MsgArray(cHack,n) = Global;FileNumber;IENS;FieldNum;Data +"RTN","TMGDBAPI",476,0) + ;" MsgArray(cHack,n,cFlags)=User specified Flags for field. +"RTN","TMGDBAPI",477,0) + ;"Output: database is changed +"RTN","TMGDBAPI",478,0) + ;"Result: 1 if ok to continue, 0=abort +"RTN","TMGDBAPI",479,0) + ;"!!!NOTICE: This is a very low level means of accessing the database. +"RTN","TMGDBAPI",480,0) + ;" The built in data verifiers, indexers etc etc will not be made aware of +"RTN","TMGDBAPI",481,0) + ;" changes made to the database through this method. USE ONLY WITH CAUTION. +"RTN","TMGDBAPI",482,0) + +"RTN","TMGDBAPI",483,0) + new cOKToCont set cOKToCont=1 +"RTN","TMGDBAPI",484,0) + new cAbort set cAbort=0 +"RTN","TMGDBAPI",485,0) + if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 +"RTN","TMGDBAPI",486,0) + new cHack set cHack="H" +"RTN","TMGDBAPI",487,0) + new cEntries set cEntries="Entries" +"RTN","TMGDBAPI",488,0) + +"RTN","TMGDBAPI",489,0) + if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"HandleHacksArray^TMGDBAPI") +"RTN","TMGDBAPI",490,0) + +"RTN","TMGDBAPI",491,0) + new result set result=cOKToCont +"RTN","TMGDBAPI",492,0) + new index set index=1 +"RTN","TMGDBAPI",493,0) + new GlobalP,FileNum,IENS,FieldNum,Data +"RTN","TMGDBAPI",494,0) + new s +"RTN","TMGDBAPI",495,0) + +"RTN","TMGDBAPI",496,0) + for index=1:1:$get(MsgArray(cHack,0,cEntries)) do quit:(s="")!(result=cAbort) +"RTN","TMGDBAPI",497,0) + . set s=$get(MsgArray(cHack,index)) if s="" quit +"RTN","TMGDBAPI",498,0) + . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Processing: ",s) +"RTN","TMGDBAPI",499,0) + . set GlobalP=$piece(s,";",1) +"RTN","TMGDBAPI",500,0) + . set FileNum=$piece(s,";",2) +"RTN","TMGDBAPI",501,0) + . set IENS=$piece(s,";",3) +"RTN","TMGDBAPI",502,0) + . set FieldNum=$piece(s,";",4) +"RTN","TMGDBAPI",503,0) + . set Data=$piece(s,";",5) +"RTN","TMGDBAPI",504,0) + . set result=$$HackWrite(GlobalP,FileNum,IENS,FieldNum,Data) +"RTN","TMGDBAPI",505,0) + +"RTN","TMGDBAPI",506,0) + if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"HandleHacksArray^TMGDBAPI") +"RTN","TMGDBAPI",507,0) + quit result +"RTN","TMGDBAPI",508,0) + +"RTN","TMGDBAPI",509,0) + +"RTN","TMGDBAPI",510,0) +GetRecMatch(Data,RecNumIEN) +"RTN","TMGDBAPI",511,0) + ;"PUBLIC FUNCTION +"RTN","TMGDBAPI",512,0) + ;"Purpose: Take Data array from DoUpload, and search in database +"RTN","TMGDBAPI",513,0) + ;" for a prior matching record +"RTN","TMGDBAPI",514,0) + ;"Input: Data - Data array will contain all the information that is to be uploaded +"RTN","TMGDBAPI",515,0) + ;" Fields that should be specifically matched will have "MATCHTHIS" fields. +"RTN","TMGDBAPI",516,0) + ;" A field may have a "MATCHTHIS" node meaning that the value +"RTN","TMGDBAPI",517,0) + ;" specified should be searched for. +"RTN","TMGDBAPI",518,0) + ;" Or, rarely, one may want to specifically search for a different +"RTN","TMGDBAPI",519,0) + ;" search value. This is stored in a "MATCHVALUE" node. This +"RTN","TMGDBAPI",520,0) + ;" node is ignored if "MATCHTHIS" node is present. +"RTN","TMGDBAPI",521,0) + ;" The .01 field always is used for searching. If not present, then +"RTN","TMGDBAPI",522,0) + ;" a "MATCHTHIS" node is assumed. +"RTN","TMGDBAPI",523,0) + ;" Example array: +"RTN","TMGDBAPI",524,0) + ;" Data(0,"FILE")="1234.1" <-- "NEW PERSON" Note conversion +"RTN","TMGDBAPI",525,0) + ;" Data(1,".01")="BILL" +"RTN","TMGDBAPI",526,0) + ;" Data(1,".01","MATCHVALUE")="JOHN" <-- optional search value +"RTN","TMGDBAPI",527,0) + ;" Data(1,".01","MATCHTHIS")=1 +"RTN","TMGDBAPI",528,0) + ;" Data(1,".02")="Sue" +"RTN","TMGDBAPI",529,0) + ;" Data(1,".03")="MyData3" +"RTN","TMGDBAPI",530,0) + ;" Data(1,".03",cFlags)=any flags given (only present if user specified) +"RTN","TMGDBAPI",531,0) + ;" RecNumIEN -- MUST PASS BY REFERENCE. An OUT parameter to receive results +"RTN","TMGDBAPI",532,0) + ;"Output: Returns answer in RecNumIEN (record number in file) if found, or 0 otherwise +"RTN","TMGDBAPI",533,0) + ;"Result: 1=OKToContinue, 0=Abort +"RTN","TMGDBAPI",534,0) + ;"Note: +"RTN","TMGDBAPI",535,0) + ;" * Data in Multiple fields are NOT used for matching. +"RTN","TMGDBAPI",536,0) + ;" * I am not going to support matching for subrecords (i.e. SubEntry stuff above) +"RTN","TMGDBAPI",537,0) + ;" * If data passed is a subset of a larger data group (i.e. when this function +"RTN","TMGDBAPI",538,0) + ;" is called recursively to handle a subfile), then an entry will be placed +"RTN","TMGDBAPI",539,0) + ;" in the Data(0,cParentIENS) that will specify the RecNumIEN of the parent record +"RTN","TMGDBAPI",540,0) + ;" holding this subfile. +"RTN","TMGDBAPI",541,0) + +"RTN","TMGDBAPI",542,0) + new cOKToCont set cOKToCont=1 +"RTN","TMGDBAPI",543,0) + new cAbort set cAbort=0 +"RTN","TMGDBAPI",544,0) + if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 +"RTN","TMGDBAPI",545,0) + new cParentIENS set cParentIENS="ParentIENS" +"RTN","TMGDBAPI",546,0) + +"RTN","TMGDBAPI",547,0) + new FileNumber,FieldNum +"RTN","TMGDBAPI",548,0) + set RecNumIEN=0 +"RTN","TMGDBAPI",549,0) + new IENS,Fields,Flags +"RTN","TMGDBAPI",550,0) + new MatchValue set MatchValue="" +"RTN","TMGDBAPI",551,0) + new FieldMatch set FieldMatch="" +"RTN","TMGDBAPI",552,0) + new ScreenCode +"RTN","TMGDBAPI",553,0) + new Matches,NumMatches +"RTN","TMGDBAPI",554,0) + new TMGMsg +"RTN","TMGDBAPI",555,0) + new result set result=cOKToCont +"RTN","TMGDBAPI",556,0) + new index +"RTN","TMGDBAPI",557,0) + new SlimData ;"Will hold just those fields that should be matched against +"RTN","TMGDBAPI",558,0) + new OneMatch +"RTN","TMGDBAPI",559,0) + +"RTN","TMGDBAPI",560,0) + set IENS=$get(Data(0,cParentIENS)) +"RTN","TMGDBAPI",561,0) + if IENS'="" if $extract(IENS,1)'="," do +"RTN","TMGDBAPI",562,0) + . set IENS=","_IENS +"RTN","TMGDBAPI",563,0) + +"RTN","TMGDBAPI",564,0) + set Fields="@" +"RTN","TMGDBAPI",565,0) + ;"Setup specifier to tell which fields to return info on +"RTN","TMGDBAPI",566,0) + new done set done=0 +"RTN","TMGDBAPI",567,0) + set index=0 +"RTN","TMGDBAPI",568,0) + for set index=$order(Data(index)) quit:(index="")!done do +"RTN","TMGDBAPI",569,0) + . set FieldNum="" +"RTN","TMGDBAPI",570,0) + . for set FieldNum=$order(Data(index,FieldNum)) quit:(+FieldNum=0) do +"RTN","TMGDBAPI",571,0) + . . if $get(Data(index,FieldNum,"MATCHTHIS"))=1 do +"RTN","TMGDBAPI",572,0) + . . . set FieldMatch=$get(Data(index,FieldNum)) +"RTN","TMGDBAPI",573,0) + . . else set FieldMatch=$get(Data(index,FieldNum,"MATCHVALUE")) +"RTN","TMGDBAPI",574,0) + . . if FieldNum=".01" do +"RTN","TMGDBAPI",575,0) + . . . if FieldMatch="" set FieldMatch=$get(Data(index,.01)) +"RTN","TMGDBAPI",576,0) + . . . set MatchValue=FieldMatch +"RTN","TMGDBAPI",577,0) + . . if FieldMatch'="" do +"RTN","TMGDBAPI",578,0) + . . . set Fields=Fields_";"_FieldNum +"RTN","TMGDBAPI",579,0) + . . . set SlimData(FieldNum)=FieldMatch +"RTN","TMGDBAPI",580,0) + . . . set FieldMatch="" +"RTN","TMGDBAPI",581,0) + . set done=1 ;"Force handling only 1 entry (i.e. #1), then quit after first cycle. +"RTN","TMGDBAPI",582,0) + +"RTN","TMGDBAPI",583,0) + set FileNumber=$get(Data(0,"FILE")) +"RTN","TMGDBAPI",584,0) + set ScreenCode="" +"RTN","TMGDBAPI",585,0) + set Flags="" +"RTN","TMGDBAPI",586,0) + +"RTN","TMGDBAPI",587,0) + ;"====================================================== +"RTN","TMGDBAPI",588,0) + ;"Call FIND^DIC +"RTN","TMGDBAPI",589,0) + ;"====================================================== +"RTN","TMGDBAPI",590,0) + ;"Params: +"RTN","TMGDBAPI",591,0) + ;"FILE,IENS,FIELDS,FLAGS,VALUE,NUMBER,INDEXES,SCREEN,IDENTIFIER,TARGET_ROOT,MSG_ROOTS +"RTN","TMGDBAPI",592,0) + do FIND^DIC(FileNumber,$get(IENS),Fields,Flags,MatchValue,"*",,ScreenCode,,"Matches","TMGMsg") +"RTN","TMGDBAPI",593,0) + if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"TMGDBAPI::FIND^DIC") +"RTN","TMGDBAPI",594,0) + ;"====================================================== +"RTN","TMGDBAPI",595,0) + ;"====================================================== +"RTN","TMGDBAPI",596,0) + +"RTN","TMGDBAPI",597,0) + if $data(TMGMsg) do +"RTN","TMGDBAPI",598,0) + . if $data(TMGMsg("DIERR"))'=0 do quit +"RTN","TMGDBAPI",599,0) + . . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) +"RTN","TMGDBAPI",600,0) + . . set result=cAbort +"RTN","TMGDBAPI",601,0) + if result=cAbort goto GRMQuit +"RTN","TMGDBAPI",602,0) + +"RTN","TMGDBAPI",603,0) + if $data(Matches("DILIST"))=0 goto GRMQuit ;"keep RecNumIEN default of 0 +"RTN","TMGDBAPI",604,0) + set NumMatches=$piece(Matches("DILIST",0),"^",1) +"RTN","TMGDBAPI",605,0) + if NumMatches=0 goto GRMQuit ;"keep RecNumIEN default of 0 +"RTN","TMGDBAPI",606,0) + +"RTN","TMGDBAPI",607,0) + for index=1:1:NumMatches do quit:RecNumIEN'=0 ;"Note: FIRST match returned. +"RTN","TMGDBAPI",608,0) + . kill OneMatch +"RTN","TMGDBAPI",609,0) + . merge OneMatch=Matches("DILIST","ID",index) +"RTN","TMGDBAPI",610,0) + . if $$CompRec(FileNumber,.OneMatch,.SlimData) set RecNumIEN=Matches("DILIST",2,index) +"RTN","TMGDBAPI",611,0) + +"RTN","TMGDBAPI",612,0) +GRMQuit +"RTN","TMGDBAPI",613,0) + quit result +"RTN","TMGDBAPI",614,0) + +"RTN","TMGDBAPI",615,0) + +"RTN","TMGDBAPI",616,0) +CompRec(FileNumber,dbRec,TestRec) +"RTN","TMGDBAPI",617,0) + ;"PUBLIC FUNCTION +"RTN","TMGDBAPI",618,0) + ;"Purpose: To compare data from the database against a test match +"RTN","TMGDBAPI",619,0) + ;"Input: FileNumber: the file data is from +"RTN","TMGDBAPI",620,0) + ;" dbRec, an array of data from the database in the following format +"RTN","TMGDBAPI",621,0) + ;" dbRec(.01)="JOHNS,BILL" +"RTN","TMGDBAPI",622,0) + ;" dbRec(.02)="MALE" +"RTN","TMGDBAPI",623,0) + ;" dbRec(.03)="01/20/1957" +"RTN","TMGDBAPI",624,0) + ;" dbRec(.07)="(123) 555-1212" +"RTN","TMGDBAPI",625,0) + ;" TestRec, an array of data to test for match with, in same format +"RTN","TMGDBAPI",626,0) + ;" as above. Note: there may well be less entries in this array +"RTN","TMGDBAPI",627,0) + ;" than in the dbRec +"RTN","TMGDBAPI",628,0) + ;" TestRec(.01)="JOHNS,BILL" +"RTN","TMGDBAPI",629,0) + ;" TestRec(.03)="01/20/1957" +"RTN","TMGDBAPI",630,0) + ;"Output: 1 if all values in TestRec=dbRec. 0=conflict +"RTN","TMGDBAPI",631,0) + ;" Note: values in dbRec that don't have a corresponding entry in TestRec +"RTN","TMGDBAPI",632,0) + ;" are ignored. +"RTN","TMGDBAPI",633,0) + +"RTN","TMGDBAPI",634,0) + new cOKToCont set cOKToCont=1 +"RTN","TMGDBAPI",635,0) + new cAbort set cAbort=0 +"RTN","TMGDBAPI",636,0) + if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 +"RTN","TMGDBAPI",637,0) + +"RTN","TMGDBAPI",638,0) + new result set result=cOKToCont +"RTN","TMGDBAPI",639,0) + new index set index="" +"RTN","TMGDBAPI",640,0) + new FieldType,TMGFDA,TMGMsg +"RTN","TMGDBAPI",641,0) + new dbIDT,testIDT ;" IDT = internal form of date/time +"RTN","TMGDBAPI",642,0) + +"RTN","TMGDBAPI",643,0) + if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"CompRec^TMGDBAPI") +"RTN","TMGDBAPI",644,0) + +"RTN","TMGDBAPI",645,0) + if TMGDEBUG do +"RTN","TMGDBAPI",646,0) + . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is records to be compared") +"RTN","TMGDBAPI",647,0) + . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"dbRec:") +"RTN","TMGDBAPI",648,0) + . do ArrayDump^TMGDEBUG("dbRec") ;"zwr dbRec(*) +"RTN","TMGDBAPI",649,0) + . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"TestRec:") +"RTN","TMGDBAPI",650,0) + . do ArrayDump^TMGDEBUG("TestRec") ;"zwr TestRec(*) +"RTN","TMGDBAPI",651,0) + +"RTN","TMGDBAPI",652,0) +CRLoop +"RTN","TMGDBAPI",653,0) + set index=$order(TestRec(index)) +"RTN","TMGDBAPI",654,0) + if index="" goto CRDone +"RTN","TMGDBAPI",655,0) + if $data(dbRec(index))=0 goto CRLoop +"RTN","TMGDBAPI",656,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Comparing field ",index) +"RTN","TMGDBAPI",657,0) + kill TMGFDA,TMGMsg +"RTN","TMGDBAPI",658,0) + do FIELD^DID(FileNumber,index,,"TYPE","TMGFDA","TMGMsg") +"RTN","TMGDBAPI",659,0) + if $get(TMGFDA("TYPE"))="DATE/TIME" do goto CRDone:'result +"RTN","TMGDBAPI",660,0) + . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Doing special date comparison") +"RTN","TMGDBAPI",661,0) + . set X=TestRec(index) +"RTN","TMGDBAPI",662,0) + . do ^%DT ;"convert date/time into internal format +"RTN","TMGDBAPI",663,0) + . set testIDT=Y +"RTN","TMGDBAPI",664,0) + . set X=dbRec(index) +"RTN","TMGDBAPI",665,0) + . do ^%DT ;"convert date/time into internal format +"RTN","TMGDBAPI",666,0) + . set dbIDT=Y +"RTN","TMGDBAPI",667,0) + . if testIDT'=dbIDT do +"RTN","TMGDBAPI",668,0) + . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Dates not equal: ",TestRec(index)," vs, ",dbRec(index)) +"RTN","TMGDBAPI",669,0) + . . set result=cAbort +"RTN","TMGDBAPI",670,0) + else if TestRec(index)'=dbRec(index) do goto CRDone ;"Note: simple '=' compare +"RTN","TMGDBAPI",671,0) + . set result=cAbort +"RTN","TMGDBAPI",672,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Fields are equal") +"RTN","TMGDBAPI",673,0) + goto CRLoop +"RTN","TMGDBAPI",674,0) +CRDone +"RTN","TMGDBAPI",675,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Leaving CompRec. Result=",result," (0 if conflict)") +"RTN","TMGDBAPI",676,0) + +"RTN","TMGDBAPI",677,0) + if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"CompRec^TMGDBAPI") +"RTN","TMGDBAPI",678,0) + quit result +"RTN","TMGDBAPI",679,0) + +"RTN","TMGDBAPI",680,0) + +"RTN","TMGDBAPI",681,0) +UploadData(Data,RecNumIEN) +"RTN","TMGDBAPI",682,0) + ;"PUBLIC FUNCTION +"RTN","TMGDBAPI",683,0) + ;"Purpose: Do actual upload of Data, given in specific format +"RTN","TMGDBAPI",684,0) + ;"Note: This function may be called recursively by subfiles +"RTN","TMGDBAPI",685,0) + ;"Input: Data -- data in format show at TOP OF THIS FILE +"RTN","TMGDBAPI",686,0) + ;" Note: If this function is being passed recursively, then the data +"RTN","TMGDBAPI",687,0) + ;" passed is probably just a subpart that corresponds to the subfile +"RTN","TMGDBAPI",688,0) + ;" RecNumIEN -- OPTIONAL pameter. May be used to specify the +"RTN","TMGDBAPI",689,0) + ;" record to force data into. If passed by reference, then +"RTN","TMGDBAPI",690,0) + ;" record number (IEN) where data was placed is passed back. +"RTN","TMGDBAPI",691,0) + ;" Use of this parameter only makes sense when filing the highest +"RTN","TMGDBAPI",692,0) + ;" level file. (When filing subfiles recursively, then the parent +"RTN","TMGDBAPI",693,0) + ;" record number is stored in (0,cParentIENS)=",10033," e.g.) +"RTN","TMGDBAPI",694,0) + ;"Output: Information will be put into global database, based on +"RTN","TMGDBAPI",695,0) + ;" entries in Data. +"RTN","TMGDBAPI",696,0) + ;" Record number (IEN) of record will be put into RecNumIEN (or 0 if error) +"RTN","TMGDBAPI",697,0) + ;"Result: Returns success 1=OK to continue. 0=Abort +"RTN","TMGDBAPI",698,0) + +"RTN","TMGDBAPI",699,0) + new cOKToCont set cOKToCont=1 +"RTN","TMGDBAPI",700,0) + new cAbort set cAbort=0 +"RTN","TMGDBAPI",701,0) + if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 +"RTN","TMGDBAPI",702,0) + new cEntries set cEntries="Entries" +"RTN","TMGDBAPI",703,0) + +"RTN","TMGDBAPI",704,0) + if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"UploadData^TMGDBAPI") +"RTN","TMGDBAPI",705,0) + +"RTN","TMGDBAPI",706,0) + new result set result=cOKToCont +"RTN","TMGDBAPI",707,0) + new NumEntries +"RTN","TMGDBAPI",708,0) + new index +"RTN","TMGDBAPI",709,0) + +"RTN","TMGDBAPI",710,0) + set RecNumIEN=$get(RecNumIEN,0) ;"See if user-specified IEN was given. +"RTN","TMGDBAPI",711,0) + +"RTN","TMGDBAPI",712,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"RecNumIEN=",RecNumIEN) +"RTN","TMGDBAPI",713,0) + +"RTN","TMGDBAPI",714,0) + if RecNumIEN'=0 do goto UDDone:(result=cAbort) +"RTN","TMGDBAPI",715,0) + . new Params,MyOutVar +"RTN","TMGDBAPI",716,0) + . set Params("FILE")=$get(Data(0,"FILE")) +"RTN","TMGDBAPI",717,0) + . set Params(cRecNum)=RecNumIEN +"RTN","TMGDBAPI",718,0) + . set Params(cField)=".01" +"RTN","TMGDBAPI",719,0) + . set Params(cOutput)="MyOutVar" +"RTN","TMGDBAPI",720,0) + . set result=$$ValueLookup(.Params) ;"result=0 (cAbort) if unsuccessful lookup +"RTN","TMGDBAPI",721,0) + . if result=cAbort do +"RTN","TMGDBAPI",722,0) + . . if $data(PriorErrorFound)=0 new PriorErrorFound +"RTN","TMGDBAPI",723,0) + . . new s set s="Unable to overwrite data into record#"_RecNumIEN_" because that record does not already exist.\n" +"RTN","TMGDBAPI",724,0) + . . set s=s_"Will try to put data into a new record, which may not be record#"_RecNumIEN +"RTN","TMGDBAPI",725,0) + . . do ShowError^TMGDEBUG(.PriorErrorFound,s) +"RTN","TMGDBAPI",726,0) + . . set result=cOKToCont +"RTN","TMGDBAPI",727,0) + . . set PriorErrorFound=0 ;"clear errors and continue program. +"RTN","TMGDBAPI",728,0) + . . set RecNumIEN=0 +"RTN","TMGDBAPI",729,0) + +"RTN","TMGDBAPI",730,0) + set NumEntries=$get(Data(0,cEntries)) +"RTN","TMGDBAPI",731,0) + for index=1:1:NumEntries do quit:(result=cAbort) +"RTN","TMGDBAPI",732,0) + . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Starting loop to process all uploadData entries. Entry=",index) +"RTN","TMGDBAPI",733,0) + . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"RecNumIEN=",RecNumIEN) +"RTN","TMGDBAPI",734,0) + . new tData ;"Create a tData array that has only 1 entry in it. +"RTN","TMGDBAPI",735,0) + . merge tData(0)=Data(0) +"RTN","TMGDBAPI",736,0) + . set tData(0,cEntries)=1 +"RTN","TMGDBAPI",737,0) + . merge tData(1)=Data(index) +"RTN","TMGDBAPI",738,0) + . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"This is entry to process") +"RTN","TMGDBAPI",739,0) + . if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("tData") +"RTN","TMGDBAPI",740,0) + . if RecNumIEN=0 set result=$$GetRecMatch(.tData,.RecNumIEN) ;"if no prior record, returns 0 +"RTN","TMGDBAPI",741,0) + . if result=cAbort quit ;//kt added 1/6/05 +"RTN","TMGDBAPI",742,0) + . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Using RecNumIEN=",RecNumIEN) +"RTN","TMGDBAPI",743,0) + . ; +"RTN","TMGDBAPI",744,0) + . if RecNumIEN=0 do quit:(result=cAbort) +"RTN","TMGDBAPI",745,0) + . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"calling AddRec") +"RTN","TMGDBAPI",746,0) + . . new AddRecNum +"RTN","TMGDBAPI",747,0) + . . set AddRecNum=$$AddRec(.tData) +"RTN","TMGDBAPI",748,0) + . . if AddRecNum=0 do quit +"RTN","TMGDBAPI",749,0) + . . . do ShowError^TMGDEBUG(.PriorErrorFound,"Error adding a record.") +"RTN","TMGDBAPI",750,0) + . . . set result=cAbort +"RTN","TMGDBAPI",751,0) + . else do quit:(result=cAbort) +"RTN","TMGDBAPI",752,0) + . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"calling Overwriterec") +"RTN","TMGDBAPI",753,0) + . . set result=$$OverwriteRec(RecNumIEN,.tData) +"RTN","TMGDBAPI",754,0) + . . set RecNumIEN=0 ;"We won't to file any more into that record num, force search next cycle. +"RTN","TMGDBAPI",755,0) + . . if result=cAbort do quit +"RTN","TMGDBAPI",756,0) + . . . do ShowError^TMGDEBUG(.PriorErrorFound,"Error modifying an existing record.") +"RTN","TMGDBAPI",757,0) + +"RTN","TMGDBAPI",758,0) +UDDone +"RTN","TMGDBAPI",759,0) + ;"if (result'=cAbort) set result=(RecNumIEN>0) +"RTN","TMGDBAPI",760,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Result = ",result) +"RTN","TMGDBAPI",761,0) + if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"UploadData^TMGDBAPI") +"RTN","TMGDBAPI",762,0) + quit result +"RTN","TMGDBAPI",763,0) + +"RTN","TMGDBAPI",764,0) + +"RTN","TMGDBAPI",765,0) + +"RTN","TMGDBAPI",766,0) +ValueLookup(Params) +"RTN","TMGDBAPI",767,0) + ;"PUBLIC FUNCTION +"RTN","TMGDBAPI",768,0) + ;"Purpose: To look for a value of a given value in a given record in given file. +"RTN","TMGDBAPI",769,0) + ;"Input: Params -- an array loaded with expected parameters. I.e.: +"RTN","TMGDBAPI",770,0) + ;" Params("FILE")="NEW PERSON" in our example +"RTN","TMGDBAPI",771,0) + ;" Params(cRecNum)="1" in example +"RTN","TMGDBAPI",772,0) + ;" Params(cField)=".01" in our example (could be Name of field) +"RTN","TMGDBAPI",773,0) + ;" Params(cOutput)="MyVar" +"RTN","TMGDBAPI",774,0) + ;"Output: MyVar is loaded with data, i.e.: +"RTN","TMGDBAPI",775,0) + ;" MyVar("FILE")=200 +"RTN","TMGDBAPI",776,0) + ;" MyVar(cGlobal)="^VA(200)" +"RTN","TMGDBAPI",777,0) + ;" MyVar(cGlobal,cOpen)="^VA(200," +"RTN","TMGDBAPI",778,0) + ;" MyVar(cRecNum)=1 +"RTN","TMGDBAPI",779,0) + ;" MyVar(cField)=.01 +"RTN","TMGDBAPI",780,0) + ;" MyVar(cValue)=xxx <-- the looked-up value +"RTN","TMGDBAPI",781,0) + ;"Returns: If should continue execution: 1=OK to continue. 0=unsuccessful lookup +"RTN","TMGDBAPI",782,0) + ;"Note: I am getting values by directly looking into database, rather than use +"RTN","TMGDBAPI",783,0) + ;" the usual lookup commands. I am doing this so that there will be no +"RTN","TMGDBAPI",784,0) + ;" 'hidden' data, based on security etc. +"RTN","TMGDBAPI",785,0) + ;" **I need to check, but this probably means that the data returned will be +"RTN","TMGDBAPI",786,0) + ;" in INTERNAL FILEMAN FORMAT (i.e. time values are encoded etc.) +"RTN","TMGDBAPI",787,0) + +"RTN","TMGDBAPI",788,0) + new cOKToCont set cOKToCont=1 +"RTN","TMGDBAPI",789,0) + new cAbort set cAbort=0 +"RTN","TMGDBAPI",790,0) + if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 +"RTN","TMGDBAPI",791,0) + new cField set cField="FIELD" ;"Field" +"RTN","TMGDBAPI",792,0) + new cNull set cNull="(none)" +"RTN","TMGDBAPI",793,0) + new cRecNum set cRecNum="RECNUM" ;"RecNum +"RTN","TMGDBAPI",794,0) + new cOutput set cOutput="OUTVAR" ;"OutVar" +"RTN","TMGDBAPI",795,0) + new cGlobal set cGlobal="GLOBAL" +"RTN","TMGDBAPI",796,0) + new cValueLookup set cValueLookup="LOOKUPFIELDVALUE" ;"LookupFieldValue" +"RTN","TMGDBAPI",797,0) + new cOpen set cOpen="OPEN" +"RTN","TMGDBAPI",798,0) + +"RTN","TMGDBAPI",799,0) + +"RTN","TMGDBAPI",800,0) + if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ValueLookup^TMGDBAPI") +"RTN","TMGDBAPI",801,0) + new result set result=cAbort +"RTN","TMGDBAPI",802,0) + +"RTN","TMGDBAPI",803,0) + new Data +"RTN","TMGDBAPI",804,0) + new DDInfo +"RTN","TMGDBAPI",805,0) + new FieldInfo +"RTN","TMGDBAPI",806,0) + new Index,Part +"RTN","TMGDBAPI",807,0) + +"RTN","TMGDBAPI",808,0) + new Field set Field=$get(Params(cField),cNull) +"RTN","TMGDBAPI",809,0) + new RecNum set RecNum=$get(Params(cRecNum),cNull) +"RTN","TMGDBAPI",810,0) + new OutVarP set OutVarP=$get(Params(cOutput),cNull) +"RTN","TMGDBAPI",811,0) + if (RecNum=cNull),(OutVarP=cNull) goto DVLUDone +"RTN","TMGDBAPI",812,0) + kill @OutVarP ;"--ensure old variables in output variable are removed. +"RTN","TMGDBAPI",813,0) + +"RTN","TMGDBAPI",814,0) + set Data(0,"FILE")=$get(Params("FILE")) +"RTN","TMGDBAPI",815,0) + set result=$$SetupFileNum(.Data) +"RTN","TMGDBAPI",816,0) + if result=cAbort goto DVLUDone +"RTN","TMGDBAPI",817,0) + new FileNum set FileNum=$get(Data(0,"FILE"),cNull) +"RTN","TMGDBAPI",818,0) + new GlobalP set GlobalP=$get(Data(0,"FILE",cGlobal),cNull) +"RTN","TMGDBAPI",819,0) + if (FileNum=cNull),(GlobalP=cNull) goto DVLUDone +"RTN","TMGDBAPI",820,0) + new FieldNum set FieldNum=$$GetNumField(FileNum,Field) +"RTN","TMGDBAPI",821,0) + if FieldNum=0 goto DVLUDone +"RTN","TMGDBAPI",822,0) + +"RTN","TMGDBAPI",823,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"GlobalP: ",GlobalP) +"RTN","TMGDBAPI",824,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"File: ",FileNum) +"RTN","TMGDBAPI",825,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Rec#: ",RecNum) +"RTN","TMGDBAPI",826,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldNum: ",FieldNum) +"RTN","TMGDBAPI",827,0) + +"RTN","TMGDBAPI",828,0) + ;"Get info from data dictionary r.e. where actual fields are stored in files. +"RTN","TMGDBAPI",829,0) + set DDInfo=$get(^DD(FileNum,FieldNum,0)) +"RTN","TMGDBAPI",830,0) + if $data(DDInfo)=0 goto HWDone +"RTN","TMGDBAPI",831,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"DDInfo='",DDInfo,"', $data(DDInfo)=",$data(DDinfo)) +"RTN","TMGDBAPI",832,0) + set FieldInfo=$piece(DDInfo,"^",4) +"RTN","TMGDBAPI",833,0) + if '$data(FieldInfo),(FieldInfo="") goto DVLUDone +"RTN","TMGDBAPI",834,0) + set Index=$piece(FieldInfo,";",1) +"RTN","TMGDBAPI",835,0) + set Part=$piece(FieldInfo,";",2) +"RTN","TMGDBAPI",836,0) + +"RTN","TMGDBAPI",837,0) + if $data(@GlobalP@(RecNum,Index))=0 goto DVLUDone +"RTN","TMGDBAPI",838,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"I think the correct data place is: ",GlobalP,"(",RecNum,",",Index,") at piece: ",Part) +"RTN","TMGDBAPI",839,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"That line is now: ",@GlobalP@(RecNum,Index)) +"RTN","TMGDBAPI",840,0) + set Data=$piece(@GlobalP@(RecNum,Index),"^",Part) +"RTN","TMGDBAPI",841,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"And our value is: ",Data) +"RTN","TMGDBAPI",842,0) + +"RTN","TMGDBAPI",843,0) + kill @OutVarP +"RTN","TMGDBAPI",844,0) + set @OutVarP@("FILE")=FileNum +"RTN","TMGDBAPI",845,0) + set @OutVarP@(cRecNum)=RecNum +"RTN","TMGDBAPI",846,0) + set @OutVarP@(cField)=FieldNum +"RTN","TMGDBAPI",847,0) + set @OutVarP@(cValue)=Data +"RTN","TMGDBAPI",848,0) + set @OutVarP@(cGlobal)=GlobalP +"RTN","TMGDBAPI",849,0) + set @OutVarP@(cGlobal,cOpen)=$get(Data(0,"FILE",cGlobal,cOpen)) +"RTN","TMGDBAPI",850,0) + +"RTN","TMGDBAPI",851,0) + set result=cOKToCont +"RTN","TMGDBAPI",852,0) + +"RTN","TMGDBAPI",853,0) +DVLUDone +"RTN","TMGDBAPI",854,0) + if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ValueLookup^TMGDBAPI") +"RTN","TMGDBAPI",855,0) + quit result +"RTN","TMGDBAPI",856,0) + +"RTN","TMGDBAPI",857,0) + +"RTN","TMGDBAPI",858,0) +FileUtility(Params) +"RTN","TMGDBAPI",859,0) + ;"PUBLIC FUNCTION +"RTN","TMGDBAPI",860,0) + ;"Purpose: To provide file access/manipulation utilities to script user +"RTN","TMGDBAPI",861,0) + ;"syntax: +"RTN","TMGDBAPI",862,0) + ;" +"RTN","TMGDBAPI",863,0) + ;"Input: Params -- an array loaded with expected parameters. I.e.: +"RTN","TMGDBAPI",864,0) + ;" Params("FILE")="NEW PERSON" for example +"RTN","TMGDBAPI",865,0) + ;" File: The name of the file to act upon. +"RTN","TMGDBAPI",866,0) + ;" File may have subnodes (i.e. "NEW PERSON|ALIAS|TITLE") +"RTN","TMGDBAPI",867,0) + ;" **BUT**, any deletion or set values will only work on top level (i.e. "NEW PERSON") +"RTN","TMGDBAPI",868,0) + ;" Params(cFn)="info" or "delete", or "set" [OPTIONAL] +"RTN","TMGDBAPI",869,0) + ;" Fn="delete" If Field is not specified: +"RTN","TMGDBAPI",870,0) + ;" Will cause record RecNum to be deleted. +"RTN","TMGDBAPI",871,0) + ;" MyOutVar("DELETED")=RecNum of deleted record, or +"RTN","TMGDBAPI",872,0) + ;" 0 if not found. +"RTN","TMGDBAPI",873,0) + ;" If Field IS specified: +"RTN","TMGDBAPI",874,0) + ;" Will delete the value in field, in record RecNum +"RTN","TMGDBAPI",875,0) + ;" Note: delete is intended only for the highest-level records +"RTN","TMGDBAPI",876,0) + ;" (i.e. not subfiels, or multiple fields) +"RTN","TMGDBAPI",877,0) + ;" Note: delete method uses ^DIK to delete the record +"RTN","TMGDBAPI",878,0) + ;" Fn="info" Will just fill in info below. +"RTN","TMGDBAPI",879,0) + ;" If Fn not specified, this is default +"RTN","TMGDBAPI",880,0) + ;" Fn="set" Will put Value into Field, in RecNum, in File (all required) +"RTN","TMGDBAPI",881,0) + ;" Params(cRecNum)="1" for example +"RTN","TMGDBAPI",882,0) + ;" RecNum: [OPTIONAL] Specifies which record to act on. If not +"RTN","TMGDBAPI",883,0) + ;" specified, then just file info is returned. +"RTN","TMGDBAPI",884,0) + ;" Params(cField)=".01" for example (could be Name of field) +"RTN","TMGDBAPI",885,0) + ;" Field: [OPTIONAL] Specifies which field to act on. +"RTN","TMGDBAPI",886,0) + ;" Params(cOutput)="MyVar" +"RTN","TMGDBAPI",887,0) + ;" OutVar: Needed to get information back from function (but still Optional) +"RTN","TMGDBAPI",888,0) + ;" Gives name of variable to put info into. +"RTN","TMGDBAPI",889,0) + ;"Output: MyVar is loaded with data, i.e. +"RTN","TMGDBAPI",890,0) + ;" i.e. MyOutVar("FILE")=Filenumber +"RTN","TMGDBAPI",891,0) + ;" MyOutVar("FILE","FILE")=SubFilenumber <-- only if subnodes input in File name (e.g."ALIAS") +"RTN","TMGDBAPI",892,0) + ;" MyOutVar("FILE","FILE","FILE")=SubSubFilenumber <-- only if subnodes input in File name (e.g."TITLE") +"RTN","TMGDBAPI",893,0) + ;" MyOutVar("GLOBAL")="^VA(200)" +"RTN","TMGDBAPI",894,0) + ;" MyOutVar("GLOBAL, OPEN")="^VA(200," +"RTN","TMGDBAPI",895,0) + ;" MyOutVar("RECNUM")=record number +"RTN","TMGDBAPI",896,0) + ;" MyOutVar("FIELD")=Filenumber +"RTN","TMGDBAPI",897,0) + ;" MyOutVar("VALUE")=xxxx <=== value of field (PRIOR TO deletion, if deleted) +"RTN","TMGDBAPI",898,0) + ;" MyOutVar("NEXTREC")=record number after RecNum, or "" if none +"RTN","TMGDBAPI",899,0) + ;" MyOutVar("PREVREC")=record number before RecNum, or "" if none +"RTN","TMGDBAPI",900,0) + ;" MyOutVar("FN")=the function executed +"RTN","TMGDBAPI",901,0) + ;" MyOutVar("NUMRECS")=Number of records in file PRIOR to any deletions +"RTN","TMGDBAPI",902,0) + ;" MyOutVar("FIRSTREC")=Rec number of first record in file +"RTN","TMGDBAPI",903,0) + ;" MyOutVar("LASTREC")=Rec number of last record in file +"RTN","TMGDBAPI",904,0) + ;"Returns: If should continue execution: 1=OK to continue. 0=abort +"RTN","TMGDBAPI",905,0) + ;"Note: I am getting values by directly looking into database, rather than use +"RTN","TMGDBAPI",906,0) + ;" the usual lookup commands. I am doing this so that there will be no +"RTN","TMGDBAPI",907,0) + ;" 'hidden' data, based on security etc. +"RTN","TMGDBAPI",908,0) + +"RTN","TMGDBAPI",909,0) + if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 +"RTN","TMGDBAPI",910,0) + new cOKToCont set cOKToCont=1 +"RTN","TMGDBAPI",911,0) + new cAbort set cAbort=0 +"RTN","TMGDBAPI",912,0) + new cField set cField="FIELD" ;"Field" +"RTN","TMGDBAPI",913,0) + new cNull set cNull="(none)" +"RTN","TMGDBAPI",914,0) + new cRecNum set cRecNum="RECNUM" ;"RecNum +"RTN","TMGDBAPI",915,0) + new cRecord set cRecord="RECORD" ;"Record" +"RTN","TMGDBAPI",916,0) + new cOutput set cOutput="OUTVAR" ;"OutVar" +"RTN","TMGDBAPI",917,0) + new cGlobal set cGlobal="GLOBAL" +"RTN","TMGDBAPI",918,0) + new cValueLookup set cValueLookup="LOOKUPFIELDVALUE" ;"LookupFieldValue" +"RTN","TMGDBAPI",919,0) + new cOpen set cOpen="OPEN" +"RTN","TMGDBAPI",920,0) + new cInfo set cInfo="INFO" ;"Info +"RTN","TMGDBAPI",921,0) + if $data(cNodeDiv)#10=0 new cNodeDiv set cNodeDiv="|" +"RTN","TMGDBAPI",922,0) + new cDelete set cDelete="DELETE" ;"Delete +"RTN","TMGDBAPI",923,0) + new cNextRec set cNextRec="NEXTREC" +"RTN","TMGDBAPI",924,0) + new cPrev set cPrev="PREV" +"RTN","TMGDBAPI",925,0) + new cNumRecs set cNumRecs="NUMRECS" +"RTN","TMGDBAPI",926,0) + new cFirstRec set cFirstRec="FIRSTREC" +"RTN","TMGDBAPI",927,0) + new cLastRec set cLastRec="LASTREC" +"RTN","TMGDBAPI",928,0) + +"RTN","TMGDBAPI",929,0) + if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"DoFileUtility^TMGDBAPI") +"RTN","TMGDBAPI",930,0) + new result set result=cAbort +"RTN","TMGDBAPI",931,0) + +"RTN","TMGDBAPI",932,0) + new Data +"RTN","TMGDBAPI",933,0) + new DDInfo +"RTN","TMGDBAPI",934,0) + new FieldInfo +"RTN","TMGDBAPI",935,0) + new Index,Part +"RTN","TMGDBAPI",936,0) + new DummyOut +"RTN","TMGDBAPI",937,0) + +"RTN","TMGDBAPI",938,0) + new OutVarP set OutVarP=$get(Params(cOutput),cNull) +"RTN","TMGDBAPI",939,0) + ;"if (OutVarP=cNull) goto DFUTDone +"RTN","TMGDBAPI",940,0) + if (OutVarP=cNull) do +"RTN","TMGDBAPI",941,0) + . set OutVarP="DummyOut" +"RTN","TMGDBAPI",942,0) + +"RTN","TMGDBAPI",943,0) + kill @OutVarP ;"--ensure old variables in output variable are removed. +"RTN","TMGDBAPI",944,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Output variable=",OutVarP) +"RTN","TMGDBAPI",945,0) + +"RTN","TMGDBAPI",946,0) + new RecNum set RecNum=$get(Params(cRecNum)) +"RTN","TMGDBAPI",947,0) + set @OutVarP@(cRecNum)=RecNum +"RTN","TMGDBAPI",948,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"RecNum=",RecNum) +"RTN","TMGDBAPI",949,0) + +"RTN","TMGDBAPI",950,0) + new Fn set Fn=$get(Params(cFn),cInfo) +"RTN","TMGDBAPI",951,0) + set Fn=$$UP^XLFSTR(Fn) +"RTN","TMGDBAPI",952,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Action Fn=",Fn) +"RTN","TMGDBAPI",953,0) + +"RTN","TMGDBAPI",954,0) + new Value set Value=$get(Params(cValue)) +"RTN","TMGDBAPI",955,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Value=",Value) +"RTN","TMGDBAPI",956,0) + +"RTN","TMGDBAPI",957,0) + new FileN set FileN=$get(Params("FILE")) +"RTN","TMGDBAPI",958,0) + +"RTN","TMGDBAPI",959,0) + new SpliceArray +"RTN","TMGDBAPI",960,0) + if FileN[cNodeDiv do ;"Parse 'NEW PERSON|ALIAS|TITLE' into 'NEW PERSON', 'ALIAS', 'TITLE' +"RTN","TMGDBAPI",961,0) + . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Multiple nodes found for file name. Processing...") +"RTN","TMGDBAPI",962,0) + . do CleaveToArray^TMGSTUTL(FileN,cNodeDiv,.SpliceArray) +"RTN","TMGDBAPI",963,0) + . set FileN=$get(SpliceArray(1)) +"RTN","TMGDBAPI",964,0) + set Data(0,"FILE")=FileN +"RTN","TMGDBAPI",965,0) + set result=$$SetupFileNum(.Data) if result=cAbort goto DFUTDone +"RTN","TMGDBAPI",966,0) + new FileNum set FileNum=$get(Data(0,"FILE"),cNull) +"RTN","TMGDBAPI",967,0) + set @OutVarP@("FILE")=FileNum +"RTN","TMGDBAPI",968,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FileNum=",FileNum) +"RTN","TMGDBAPI",969,0) + +"RTN","TMGDBAPI",970,0) + new index set index=2 +"RTN","TMGDBAPI",971,0) + new GlobalP set GlobalP=$name(@OutVarP@("FILE")) +"RTN","TMGDBAPI",972,0) + if $data(SpliceArray(index)) do +"RTN","TMGDBAPI",973,0) + . for index=index:1 do quit:index="" +"RTN","TMGDBAPI",974,0) + . . set FileN=SpliceArray(index) +"RTN","TMGDBAPI",975,0) + . . set FileNum=$$GetSubFileNumber(FileNum,FileN) +"RTN","TMGDBAPI",976,0) + . . if +FileNum'=0 set @GlobalP@("FILE")=FileNum +"RTN","TMGDBAPI",977,0) + . . set GlobalP=$name(@GlobalP@("FILE")) +"RTN","TMGDBAPI",978,0) + . . set index=$order(SpliceArray(index)) +"RTN","TMGDBAPI",979,0) + +"RTN","TMGDBAPI",980,0) + new GlobalP set GlobalP=$get(Data(0,"FILE",cGlobal),cNull) +"RTN","TMGDBAPI",981,0) + if (FileNum=cNull),(GlobalP=cNull) goto DFUTDone +"RTN","TMGDBAPI",982,0) + set @OutVarP@(cGlobal)=GlobalP +"RTN","TMGDBAPI",983,0) + set @OutVarP@(cGlobal,cOpen)=$get(Data(0,"FILE",cGlobal,cOpen)) +"RTN","TMGDBAPI",984,0) + +"RTN","TMGDBAPI",985,0) + ;"If we've gotten this far, will consider the function a success +"RTN","TMGDBAPI",986,0) + set result=cOKToCont +"RTN","TMGDBAPI",987,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Setting fn result to success") +"RTN","TMGDBAPI",988,0) + +"RTN","TMGDBAPI",989,0) + new FieldN set FieldN=$get(Params(cField)) +"RTN","TMGDBAPI",990,0) + new FieldNum +"RTN","TMGDBAPI",991,0) + if (+FieldN=0)&(FieldN'="") do +"RTN","TMGDBAPI",992,0) + . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldN=",FieldN) +"RTN","TMGDBAPI",993,0) + . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FileNum=",FileNum) +"RTN","TMGDBAPI",994,0) + . set FieldNum=$$GetNumField(FileNum,FieldN) +"RTN","TMGDBAPI",995,0) + else do +"RTN","TMGDBAPI",996,0) + . if FieldN +"RTN","TMGDBAPI",997,0) + . set FieldNum=FieldN +"RTN","TMGDBAPI",998,0) + set @OutVarP@(cField)=FieldNum +"RTN","TMGDBAPI",999,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldNum=",FieldNum) +"RTN","TMGDBAPI",1000,0) + +"RTN","TMGDBAPI",1001,0) + if $data(@GlobalP@(0))=0 goto DFUTDone +"RTN","TMGDBAPI",1002,0) + new NumRecs set NumRecs=$piece(@GlobalP@(0),"^",4) +"RTN","TMGDBAPI",1003,0) + new LastRec set LastRec=$piece(@GlobalP@(0),"^",3) +"RTN","TMGDBAPI",1004,0) + set @OutVarP@(cNumRecs)=NumRecs +"RTN","TMGDBAPI",1005,0) + set @OutVarP@(cLastRec)=LastRec +"RTN","TMGDBAPI",1006,0) + new RecI set RecI=LastRec +"RTN","TMGDBAPI",1007,0) + new PrevRec +"RTN","TMGDBAPI",1008,0) + for do quit:(RecI="")!(RecI=0) ;"Scan backwards to find first record +"RTN","TMGDBAPI",1009,0) + . set PrevRec=$order(@GlobalP@(RecI),-1) +"RTN","TMGDBAPI",1010,0) + . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"PrevRec=",PrevRec," RecI=",RecI) +"RTN","TMGDBAPI",1011,0) + . if (PrevRec="")!(PrevRec=0) do +"RTN","TMGDBAPI",1012,0) + . . set @OutVarP@(cFirstRec)=RecI +"RTN","TMGDBAPI",1013,0) + . set RecI=PrevRec +"RTN","TMGDBAPI",1014,0) + +"RTN","TMGDBAPI",1015,0) + if FieldNum="" do goto DFUTDone +"RTN","TMGDBAPI",1016,0) + . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"No field name specified") +"RTN","TMGDBAPI",1017,0) + . if (Fn=cDelete)&(RecNum'="") do +"RTN","TMGDBAPI",1018,0) + . . set DIK=$get(Data(0,"FILE",cGlobal,cOpen)) +"RTN","TMGDBAPI",1019,0) + . . set DA=RecNum +"RTN","TMGDBAPI",1020,0) + . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Deleting one record (number: ",RecNum,") from File number",FileNum) +"RTN","TMGDBAPI",1021,0) + . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Notice: deleting record does not clear any pointers to deleted records") +"RTN","TMGDBAPI",1022,0) + . . do ^DIK +"RTN","TMGDBAPI",1023,0) + +"RTN","TMGDBAPI",1024,0) + ;"Get info from data dictionary r.e. where actual fields are stored in files. +"RTN","TMGDBAPI",1025,0) + set DDInfo=$get(^DD(FileNum,FieldNum,0)) +"RTN","TMGDBAPI",1026,0) + if '$data(DDInfo) goto HWDone +"RTN","TMGDBAPI",1027,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"DDInfo=",DDInfo) +"RTN","TMGDBAPI",1028,0) + set FieldInfo=$piece(DDInfo,"^",4) +"RTN","TMGDBAPI",1029,0) + if '$data(FieldInfo),(FieldInfo="") goto DFUTDone +"RTN","TMGDBAPI",1030,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldInfo=",FieldInfo) +"RTN","TMGDBAPI",1031,0) + set Index=$piece(FieldInfo,";",1) +"RTN","TMGDBAPI",1032,0) + set Part=$piece(FieldInfo,";",2) +"RTN","TMGDBAPI",1033,0) + +"RTN","TMGDBAPI",1034,0) + if RecNum="" goto DFUTDone +"RTN","TMGDBAPI",1035,0) + if $data(@GlobalP@(RecNum,Index))=0 goto DFUTDone +"RTN","TMGDBAPI",1036,0) + +"RTN","TMGDBAPI",1037,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"I think the correct data place is: ",GlobalP,"(",RecNum,",",Index,") at piece: ",Part) +"RTN","TMGDBAPI",1038,0) + new Temp set Temp=@GlobalP@(RecNum,Index) +"RTN","TMGDBAPI",1039,0) + set @OutVarP@(cValue)=$piece(Temp,"^",Part) +"RTN","TMGDBAPI",1040,0) + kill Temp +"RTN","TMGDBAPI",1041,0) + set @OutVarP@(cNextRec)=$order(@GlobalP@(RecNum)) +"RTN","TMGDBAPI",1042,0) + set @OutVarP@(cPrev)=$order(@GlobalP@(RecNum),-1) +"RTN","TMGDBAPI",1043,0) + +"RTN","TMGDBAPI",1044,0) + if Fn=cDelete do +"RTN","TMGDBAPI",1045,0) + . set $piece(@GlobalP@(RecNum,Index),"^",Part)="" +"RTN","TMGDBAPI",1046,0) + +"RTN","TMGDBAPI",1047,0) + if Fn=cSet do +"RTN","TMGDBAPI",1048,0) + . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Performing a hack write. CAUTION!") +"RTN","TMGDBAPI",1049,0) + . set $piece(@GlobalP@(RecNum,Index),"^",Part)=Value +"RTN","TMGDBAPI",1050,0) + +"RTN","TMGDBAPI",1051,0) + set result=cOKToCont +"RTN","TMGDBAPI",1052,0) + +"RTN","TMGDBAPI",1053,0) +DFUTDone +"RTN","TMGDBAPI",1054,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Fn result=",result) +"RTN","TMGDBAPI",1055,0) + if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"DoFileUtility^TMGDBAPI") +"RTN","TMGDBAPI",1056,0) + quit result +"RTN","TMGDBAPI",1057,0) + +"RTN","TMGDBAPI",1058,0) + +"RTN","TMGDBAPI",1059,0) + +"RTN","TMGDBAPI",1060,0) +AddRec(Data) +"RTN","TMGDBAPI",1061,0) + ;"Purpose: Use info from data array to create a MINIMAL new record in database +"RTN","TMGDBAPI",1062,0) + ;" This record will have only it's .01 field, and any multiple +"RTN","TMGDBAPI",1063,0) + ;" subfiles will have only their .01 fields also. +"RTN","TMGDBAPI",1064,0) + ;"Input: Data - Data array should be in format output from GetRInfo +"RTN","TMGDBAPI",1065,0) + ;"Output: data base will be modified by adding record +"RTN","TMGDBAPI",1066,0) + ;"Assumption: That a matching record does not already exist in database +"RTN","TMGDBAPI",1067,0) + ;"Returns: RecNum of added record, or 0 if error (0=abort) +"RTN","TMGDBAPI",1068,0) + +"RTN","TMGDBAPI",1069,0) + ;"NOTE!!! -- As I review this code, does it really return record number added??? +"RTN","TMGDBAPI",1070,0) + +"RTN","TMGDBAPI",1071,0) + if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 +"RTN","TMGDBAPI",1072,0) + new cOKToCont set cOKToCont=1 +"RTN","TMGDBAPI",1073,0) + new cAbort set cAbort=0 +"RTN","TMGDBAPI",1074,0) + new cParentIENS set cParentIENS="ParentIENS" +"RTN","TMGDBAPI",1075,0) + +"RTN","TMGDBAPI",1076,0) + +"RTN","TMGDBAPI",1077,0) + new tmgFDA,TMGFDA ;"Fileman Data Array +"RTN","TMGDBAPI",1078,0) + new IENS ;"Internal Entry Number String +"RTN","TMGDBAPI",1079,0) + new RecNum ;"Internal number entry array +"RTN","TMGDBAPI",1080,0) + new Flags +"RTN","TMGDBAPI",1081,0) + new TMGMsg +"RTN","TMGDBAPI",1082,0) + new FileNum +"RTN","TMGDBAPI",1083,0) + new result set result=cAbort +"RTN","TMGDBAPI",1084,0) + new FDAIndex +"RTN","TMGDBAPI",1085,0) + new MarkerArray +"RTN","TMGDBAPI",1086,0) + new MsgArray +"RTN","TMGDBAPI",1087,0) + +"RTN","TMGDBAPI",1088,0) + if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"AddRec^TMGDBAPI") +"RTN","TMGDBAPI",1089,0) + +"RTN","TMGDBAPI",1090,0) + set IENS=$get(Data(0,cParentIENS)) +"RTN","TMGDBAPI",1091,0) + +"RTN","TMGDBAPI",1092,0) + new MarkNum set MarkNum=0 +"RTN","TMGDBAPI",1093,0) + set result=$$SetupFDA(.Data,.tmgFDA,IENS,"+",.MarkNum,.MsgArray) +"RTN","TMGDBAPI",1094,0) + if result=cAbort goto SkRDone +"RTN","TMGDBAPI",1095,0) + set FileNum=$get(Data(0,"FILE"),0) +"RTN","TMGDBAPI",1096,0) + if FileNum=0 set result=cAbort goto SkRDone +"RTN","TMGDBAPI",1097,0) + +"RTN","TMGDBAPI",1098,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is master MsgArray") +"RTN","TMGDBAPI",1099,0) + if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("MsgArray") +"RTN","TMGDBAPI",1100,0) + +"RTN","TMGDBAPI",1101,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is master tmgFDA") +"RTN","TMGDBAPI",1102,0) + if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("tmgFDA") ;"zwr tmgFDA(*) +"RTN","TMGDBAPI",1103,0) + +"RTN","TMGDBAPI",1104,0) + set FDAIndex=FileNum +"RTN","TMGDBAPI",1105,0) + for do quit:(FDAIndex="")!(result=cAbort) +"RTN","TMGDBAPI",1106,0) + . kill TMGFDA +"RTN","TMGDBAPI",1107,0) + . merge TMGFDA(FDAIndex)=tmgFDA(FDAIndex) +"RTN","TMGDBAPI",1108,0) + . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Starting cycle with "_FDAIndex_" part.") +"RTN","TMGDBAPI",1109,0) + . ; +"RTN","TMGDBAPI",1110,0) + . set Flags="E" ;"E=External format values +"RTN","TMGDBAPI",1111,0) + . ; +"RTN","TMGDBAPI",1112,0) + . set result=$$ConvertFDA(.TMGFDA,.MarkerArray) +"RTN","TMGDBAPI",1113,0) + . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"AFTER CONVERSION, Here is the FDA to pass to UPDATE^DIE") +"RTN","TMGDBAPI",1114,0) + . if TMGDEBUG do ArrayDump^TMGDEBUG("TMGFDA") ;"zwr TMGFDA(*) +"RTN","TMGDBAPI",1115,0) + . ; +"RTN","TMGDBAPI",1116,0) + . ;"====================================================== +"RTN","TMGDBAPI",1117,0) + . ;"Call UPDATE^DIE +"RTN","TMGDBAPI",1118,0) + . ;"====================================================== +"RTN","TMGDBAPI",1119,0) + . if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"TMGDBAPI::UPDATE^DIE") +"RTN","TMGDBAPI",1120,0) + . if $data(TMGFDA)'=0 do +"RTN","TMGDBAPI",1121,0) + . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Flags=",Flags) +"RTN","TMGDBAPI",1122,0) + . . new $etrap set $etrap="do ErrTrp^TMGDBAPI" +"RTN","TMGDBAPI",1123,0) + . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Remember, UPDATE^DIE adds new entries in files or subfiles.") +"RTN","TMGDBAPI",1124,0) + . . set ^TMP("TMG",$J,"ErrorTrap")=result +"RTN","TMGDBAPI",1125,0) + . . set ^TMP("TMG",$J,"Caller")="UPDATE^DIE" +"RTN","TMGDBAPI",1126,0) + . . do UPDATE^DIE(Flags,"TMGFDA","RecNum","TMGMsg") +"RTN","TMGDBAPI",1127,0) + . . set result=^TMP("TMG",$J,"ErrorTrap") +"RTN","TMGDBAPI",1128,0) + . . kill ^TMP("TMG",$J,"ErrorTrap") +"RTN","TMGDBAPI",1129,0) + . . kill ^TMP("TMG",$J,"Caller") +"RTN","TMGDBAPI",1130,0) + . if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"TMGDBAPI::UPDATE^DIE") +"RTN","TMGDBAPI",1131,0) + . ;"====================================================== +"RTN","TMGDBAPI",1132,0) + . ;"====================================================== +"RTN","TMGDBAPI",1133,0) + . ; +"RTN","TMGDBAPI",1134,0) + . if $data(RecNum) do +"RTN","TMGDBAPI",1135,0) + . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is RecNum array after update/filing") +"RTN","TMGDBAPI",1136,0) + . . if TMGDEBUG do ArrayDump^TMGDEBUG("RecNum") ;"zwr RecNum(*) +"RTN","TMGDBAPI",1137,0) + . . merge MarkerArray=RecNum +"RTN","TMGDBAPI",1138,0) + . . if result=cAbort do +"RTN","TMGDBAPI",1139,0) + . . . new index +"RTN","TMGDBAPI",1140,0) + . . . set index=$order(RecNum("")) +"RTN","TMGDBAPI",1141,0) + . . . set result=$get(RecNum(index)) +"RTN","TMGDBAPI",1142,0) + . . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Output Record#=",result) +"RTN","TMGDBAPI",1143,0) + . else do +"RTN","TMGDBAPI",1144,0) + . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"After update/filing, RecNum array is empty!") +"RTN","TMGDBAPI",1145,0) + . ; +"RTN","TMGDBAPI",1146,0) + . if $data(TMGMsg("DIERR")) do quit +"RTN","TMGDBAPI",1147,0) + . . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) +"RTN","TMGDBAPI",1148,0) + . . if $data(RecNum(1)) do +"RTN","TMGDBAPI",1149,0) + . . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Trying to ignore error") +"RTN","TMGDBAPI",1150,0) + . . . set PriorErrorFound=0 +"RTN","TMGDBAPI",1151,0) + . . else do +"RTN","TMGDBAPI",1152,0) + . . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Unable to ignore error") +"RTN","TMGDBAPI",1153,0) + . . . set result=cAbort +"RTN","TMGDBAPI",1154,0) + . do +"RTN","TMGDBAPI",1155,0) + . . new tI set tI=FDAIndex +"RTN","TMGDBAPI",1156,0) + . . set FDAIndex=$order(tmgFDA(FDAIndex)) +"RTN","TMGDBAPI",1157,0) + . . kill tmgFDA(tI) +"RTN","TMGDBAPI",1158,0) + +"RTN","TMGDBAPI",1159,0) + if result=cAbort do goto SkRDone +"RTN","TMGDBAPI",1160,0) + . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Error encountered, dropping out.") +"RTN","TMGDBAPI",1161,0) + +"RTN","TMGDBAPI",1162,0) + set result=$$HandleHacksArray(.MsgArray) +"RTN","TMGDBAPI",1163,0) + +"RTN","TMGDBAPI",1164,0) + if result=cAbort goto SkRDone +"RTN","TMGDBAPI",1165,0) + +"RTN","TMGDBAPI",1166,0) +SkRDone +"RTN","TMGDBAPI",1167,0) + if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"AddRec^TMGDBAPI") +"RTN","TMGDBAPI",1168,0) + quit result +"RTN","TMGDBAPI",1169,0) + +"RTN","TMGDBAPI",1170,0) + +"RTN","TMGDBAPI",1171,0) + +"RTN","TMGDBAPI",1172,0) + ;"========================================================= +"RTN","TMGDBAPI",1173,0) + ;" Error trap routine +"RTN","TMGDBAPI",1174,0) + ;"========================================================= +"RTN","TMGDBAPI",1175,0) +ErrTrp +"RTN","TMGDBAPI",1176,0) + new cAbort set cAbort=0 +"RTN","TMGDBAPI",1177,0) + set $etrap="",$ecode="" +"RTN","TMGDBAPI",1178,0) + new Caller +"RTN","TMGDBAPI",1179,0) + set Caller=$get(^TMP("TMG",$J,"Caller"),"?") +"RTN","TMGDBAPI",1180,0) + do ShowError^TMGDEBUG(.PriorErrorFound,"Error trapped. Caller was: ",Caller) +"RTN","TMGDBAPI",1181,0) + if $data(TMGMsg) do ShowDIERR^TMGDEBUG(TMGMsg) +"RTN","TMGDBAPI",1182,0) + set ^TMP("TMG",$J,"ErrorTrap")=cAbort +"RTN","TMGDBAPI",1183,0) + quit +"RTN","TMGDBAPI",1184,0) + ;"========================================================= +"RTN","TMGDBAPI",1185,0) + ;" End of Error trap routine +"RTN","TMGDBAPI",1186,0) + ;"========================================================= +"RTN","TMGDBAPI",1187,0) + +"RTN","TMGDBAPI",1188,0) + ;"======================================================== +"RTN","TMGDBAPI",1189,0) + ;"The following routines were moved to shorten module length +"RTN","TMGDBAPI",1190,0) + +"RTN","TMGDBAPI",1191,0) +ConvertFDA(FDA,MarkerArray) +"RTN","TMGDBAPI",1192,0) + goto ConvertFDA+1^TMGDBAP2 +"RTN","TMGDBAPI",1193,0) + +"RTN","TMGDBAPI",1194,0) +ConvertIENS(IENS,MarkerArray) +"RTN","TMGDBAPI",1195,0) + goto ConvertIENS+1^TMGDBAP2 +"RTN","TMGDBAPI",1196,0) + +"RTN","TMGDBAPI",1197,0) +SetupFDA(Data,FDA,parentIENS,SrchType,MarkNum,MsgArray,Minimal,RecNum) +"RTN","TMGDBAPI",1198,0) + goto SetupFDA+1^TMGDBAP2 +"RTN","TMGDBAPI",1199,0) + +"RTN","TMGDBAPI",1200,0) +OverwriteRec(RecNum,Data) +"RTN","TMGDBAPI",1201,0) + goto OverwriteRec+1^TMGDBAP2 +"RTN","TMGDBAPI",1202,0) + +"RTN","TMGDBAPI",1203,0) +GetFileNum(FileName) +"RTN","TMGDBAPI",1204,0) + goto GetFileNum+1^TMGDBAP2 +"RTN","TMGDBAPI",1205,0) + +"RTN","TMGDBAPI",1206,0) +GetFName(FileNumber) +"RTN","TMGDBAPI",1207,0) + goto GetFName+1^TMGDBAP2 +"RTN","TMGDBAPI",1208,0) + +"RTN","TMGDBAPI",1209,0) +GetFldName(File,FieldNumber) +"RTN","TMGDBAPI",1210,0) + goto GetFldName+1^TMGDBAP2 +"RTN","TMGDBAPI",1211,0) + +"RTN","TMGDBAPI",1212,0) +GetFldList(File,pArray) +"RTN","TMGDBAPI",1213,0) + goto GetFldList+1^TMGDBAP2 +"RTN","TMGDBAPI",1214,0) + +"RTN","TMGDBAPI",1215,0) +SetupFileNum(Data) +"RTN","TMGDBAPI",1216,0) + goto SetupFileNum+1^TMGDBAP2 +"RTN","TMGDBAPI",1217,0) + +"RTN","TMGDBAPI",1218,0) +RecFind(Params) +"RTN","TMGDBAPI",1219,0) + goto RecFind+1^TMGDBAP2 +"RTN","TMGDBAPI",1220,0) + +"RTN","TMGDBAPI",1221,0) +FieldCompare(TestField,dbField,Type) +"RTN","TMGDBAPI",1222,0) + goto FieldCompare+1^TMGDBAP2 +"RTN","TMGDBAPI",1223,0) + +"RTN","TMGDBAPI",1224,0) +EnsureWrite(File,Field,IENS,Value,Flags,MsgArray) +"RTN","TMGDBAPI",1225,0) + goto EnsureWrite+1^TMGDBAP2 +"RTN","TMGDBAPI",1226,0) + +"RTN","TMGDBAPI",1227,0) +dbWrite(FDA,Overwrite,TMGIEN,Flags,ErrArray) +"RTN","TMGDBAPI",1228,0) + goto dbWrite+1^TMGDBAP2 +"RTN","TMGDBAPI",1229,0) + +"RTN","TMGDBAPI",1230,0) +DelIEN(File,RecNumIEN,ErrArray) +"RTN","TMGDBAPI",1231,0) + goto DelIEN+1^TMGDBAP2 +"RTN","TMGDBAPI",1232,0) + +"RTN","TMGDBAPI",1233,0) +WriteWP(File,RecNumIEN,Field,TMGArray) +"RTN","TMGDBAPI",1234,0) + goto WriteWP+1^TMGDBAP2 +"RTN","TMGDBAPI",1235,0) + +"RTN","TMGDBAPI",1236,0) +ReadWP(File,IENS,Field,Array) +"RTN","TMGDBAPI",1237,0) + goto ReadWP+1^TMGDBAP2 +"RTN","TMGDBAPI",1238,0) + +"RTN","TMGDBAPI",1239,0) +ShowIfError(TMGMsg,PriorErrorFound) +"RTN","TMGDBAPI",1240,0) + goto ShowIfError+1^TMGDBAP2 +"RTN","TMGDBAPI",1241,0) + +"RTN","TMGDBAPI",1242,0) +DataImport(Info,ProgressFN) +"RTN","TMGDBAPI",1243,0) + goto DataImport+1^TMGDBAP2 +"RTN","TMGDBAPI",1244,0) + +"RTN","TMGDBAPI",1245,0) +Set1(File,IEN,Field,Value,Flag) +"RTN","TMGDBAPI",1246,0) + goto Set1+1^TMGDBAP2 +"RTN","TMGDBAPI",1247,0) + +"RTN","TMGDBAPI",1248,0) +GetValidInput(File,Field) +"RTN","TMGDBAPI",1249,0) + goto GetValidInput+1^TMGDBAP2 +"RTN","TMGDBAPI",1250,0) + +"RTN","TMGDBAPI",1251,0) +AskFIENS() +"RTN","TMGDBAPI",1252,0) + goto AskFIENS+1^TMGDBAP2 +"RTN","TMGDBAPI",1253,0) + +"RTN","TMGDBAPI",1254,0) +ASKSCRN +"RTN","TMGDBAPI",1255,0) + goto ASKSCRN+1^TMGDBAP2 +"RTN","TMGDBAPI",1256,0) + +"RTN","TMGDBAPI",1257,0) +AskIENS(FileNum,IENS) +"RTN","TMGDBAPI",1258,0) + goto AskIENS+1^TMGDBAP2 +"RTN","TMGDBAPI",1259,0) + +"RTN","TMGDBAPI",1260,0) +GetRefArray(FileNum,array) +"RTN","TMGDBAPI",1261,0) + goto GetRefArray+1^TMGDBAP2 +"RTN","TMGDBAPI",1262,0) + +"RTN","TMGDBAPI",1263,0) +FIENS2Root(FIENS) +"RTN","TMGDBAPI",1264,0) + goto FIENS2Root+1^TMGDBAP2 +"RTN","TMGDBAPI",1265,0) + +"RTN","TMGDBAPI",1266,0) +GetRef(file,IENS,field) +"RTN","TMGDBAPI",1267,0) + goto GetRef+1^TMGDBAP2 +"RTN","TMGDBAPI",1268,0) + +"RTN","TMGDBAPI",1269,0) +TrimFDA(FDA,Quiet) +"RTN","TMGDBAPI",1270,0) + goto TrimFDA+1^TMGDBAP2 +"RTN","TMGDBAPI",1271,0) + +"RTN","TMGDBAPI",1272,0) +GetPtrsOUT(File,Info) +"RTN","TMGDBAPI",1273,0) + goto GetPtrsOUT+1^TMGDBAP2 +"RTN","TMGDBAPI",1274,0) + +"RTN","TMGDEBUG") +0^1^B10098 +"RTN","TMGDEBUG",1,0) +TMGDEBUG ;TMG/kst/Debug utilities: logging, record dump ;03/25/06 +"RTN","TMGDEBUG",2,0) + ;;1.0;TMG-LIB;**1**;07/12/05;Build 1 +"RTN","TMGDEBUG",3,0) + +"RTN","TMGDEBUG",4,0) + ;"TMG DEBUG UTILITIES +"RTN","TMGDEBUG",5,0) + ;"Kevin Toppenberg MD +"RTN","TMGDEBUG",6,0) + ;"GNU General Public License (GPL) applies +"RTN","TMGDEBUG",7,0) + ;"7-12-2005 +"RTN","TMGDEBUG",8,0) + +"RTN","TMGDEBUG",9,0) + ;"======================================================================= +"RTN","TMGDEBUG",10,0) + ;" API -- Public Functions. +"RTN","TMGDEBUG",11,0) + ;"======================================================================= +"RTN","TMGDEBUG",12,0) + ;"$$GetDebugMode^TMGDEBUG(DefVal) +"RTN","TMGDEBUG",13,0) + ;"OpenDefLogFile^TMGDEBUG +"RTN","TMGDEBUG",14,0) + ;"OpenLogFile^TMGDEBUG(DefPath,DefName) +"RTN","TMGDEBUG",15,0) + ;"DebugMsg^TMGDEBUG(DBIndent,Msg,A,B,C,D,E,F,G,H,I,J,K,L) +"RTN","TMGDEBUG",16,0) + ;"DebugWrite^TMGDEBUG(DBIndent,s,AddNewline) +"RTN","TMGDEBUG",17,0) + ;"DebugIndent^TMGDEBUG(Num) +"RTN","TMGDEBUG",18,0) + ;"ArrayDump^TMGDEBUG(ArrayP,index,indent) +"RTN","TMGDEBUG",19,0) + ;"ASKANODES +"RTN","TMGDEBUG",20,0) + ;"ArrayNodes(pArray) +"RTN","TMGDEBUG",21,0) + ;"DebugEntry^TMGDEBUG((DBIndent,ProcName) +"RTN","TMGDEBUG",22,0) + ;"DebugExit^TMGDEBUG(DBIndent,ProcName) +"RTN","TMGDEBUG",23,0) + ;"ShowError^TMGDEBUG(PriorErrorFound,Error) +"RTN","TMGDEBUG",24,0) + ;"$$GetErrStr^TMGDEBUG(ErrArray) +"RTN","TMGDEBUG",25,0) + ;"ShowIfDIERR^TMGDEBUG(ErrMsg,PriorErrorFound) ;really same as below +"RTN","TMGDEBUG",26,0) + ;"ShowDIERR^TMGDEBUG(ErrMsg,PriorErrorFound) +"RTN","TMGDEBUG",27,0) + ;"ExpandLine(Pos) +"RTN","TMGDEBUG",28,0) + ;"ASKDUMP -- A record dumper -- a little different from Fileman Inquire +"RTN","TMGDEBUG",29,0) + ;"DumpRec(FileNum,IEN) -- dump (display) a record, using Fileman functionality. +"RTN","TMGDEBUG",30,0) + ;"DumpRec2(FileNum,IEN,ShowEmpty) -- dump (display) a record, NOT Fileman's Inquire code +"RTN","TMGDEBUG",31,0) + +"RTN","TMGDEBUG",32,0) + ;"======================================================================= +"RTN","TMGDEBUG",33,0) + ;"Private API functions +"RTN","TMGDEBUG",34,0) + +"RTN","TMGDEBUG",35,0) + ;"DumpRec2(FileNum,IEN,ShowEmpty) +"RTN","TMGDEBUG",36,0) + ;"WriteRLabel(IEN,Ender) +"RTN","TMGDEBUG",37,0) + ;"WriteFLabel(Label,Field,Type,Ender) +"RTN","TMGDEBUG",38,0) + ;"WriteLine(Line) +"RTN","TMGDEBUG",39,0) + +"RTN","TMGDEBUG",40,0) + ;"======================================================================= +"RTN","TMGDEBUG",41,0) + ;"DEPENDENCIES +"RTN","TMGDEBUG",42,0) + ;" TMGUSRIF +"RTN","TMGDEBUG",43,0) + +"RTN","TMGDEBUG",44,0) + ;"Note: This module accesses custom file 22711, TMG UPLOAD SETTINGS +"RTN","TMGDEBUG",45,0) + ;" It is OK if this file does not exist (i.e. on other computer systems.) However, the function +"RTN","TMGDEBUG",46,0) + ;" OpenDefLogFile will fail to find a default specified file, and would not open a log file. +"RTN","TMGDEBUG",47,0) + ;" Nothing is PUT INTO this file in this module. So new global would NOT be created. +"RTN","TMGDEBUG",48,0) + ;"======================================================================= +"RTN","TMGDEBUG",49,0) + ;"======================================================================= +"RTN","TMGDEBUG",50,0) + +"RTN","TMGDEBUG",51,0) +GetDebugMode(DefVal) +"RTN","TMGDEBUG",52,0) + ;"Purpose: to ask if debug output desired +"RTN","TMGDEBUG",53,0) + ;"Input: DefVal [optional] -- Default choice +"RTN","TMGDEBUG",54,0) + ;"result: returns values as below +"RTN","TMGDEBUG",55,0) + ;" 0, cdbNone - no debug +"RTN","TMGDEBUG",56,0) + ;" 1, cdbToScrn - Debug output to screen +"RTN","TMGDEBUG",57,0) + ;" 2, cdbToFile - Debug output to file +"RTN","TMGDEBUG",58,0) + ;" 3, cdbToTail - Debug output to X tail dialog box. +"RTN","TMGDEBUG",59,0) + ;" Note: 2-2-06 I am adding a mode (-1) which is EXTRA QUIET (used initially in ShowError) +"RTN","TMGDEBUG",60,0) + ;"Note: This does not set up output streams etc, just gets preference. +"RTN","TMGDEBUG",61,0) + +"RTN","TMGDEBUG",62,0) + new cdbNone set cdbNone=0 +"RTN","TMGDEBUG",63,0) + new cdbAbort set cdbAbort=0 +"RTN","TMGDEBUG",64,0) + new cdbToScrn set cdbToScrn=1 ;"was 2 +"RTN","TMGDEBUG",65,0) + new cdbToFile set cdbToFile=2 ;"was 3 +"RTN","TMGDEBUG",66,0) + new cdbToTail set cdbToTail=3 ;"was 4 +"RTN","TMGDEBUG",67,0) + +"RTN","TMGDEBUG",68,0) + new Input +"RTN","TMGDEBUG",69,0) + new result set result=cdbNone ;"the default +"RTN","TMGDEBUG",70,0) + new Default set Default=$get(DefVal,3) +"RTN","TMGDEBUG",71,0) + +"RTN","TMGDEBUG",72,0) + write !,"Select debug output option:",! +"RTN","TMGDEBUG",73,0) + write " '^'. Abort",! +"RTN","TMGDEBUG",74,0) + write " 0. NO debug output",! +"RTN","TMGDEBUG",75,0) + write " 1. Show debug output on screen",! +"RTN","TMGDEBUG",76,0) + write " 2. Send debug output to file",! +"RTN","TMGDEBUG",77,0) + if $get(DispMode(cDialog)) do +"RTN","TMGDEBUG",78,0) + . write " 3. Show debug output in X tail dialog box.",! +"RTN","TMGDEBUG",79,0) + +"RTN","TMGDEBUG",80,0) + write "Enter option number ("_Default_"): " +"RTN","TMGDEBUG",81,0) + read Input,! +"RTN","TMGDEBUG",82,0) + +"RTN","TMGDEBUG",83,0) + if Input="" do +"RTN","TMGDEBUG",84,0) + . write "Defaulting to: ",Default,! +"RTN","TMGDEBUG",85,0) + . set Input=Default +"RTN","TMGDEBUG",86,0) + +"RTN","TMGDEBUG",87,0) + if Input="^" set result=cdbAbort +"RTN","TMGDEBUG",88,0) + if Input=0 set result=cdbNone +"RTN","TMGDEBUG",89,0) + if Input=1 set result=cdbToScrn +"RTN","TMGDEBUG",90,0) + if Input=2 set result=cdbToFile +"RTN","TMGDEBUG",91,0) + if Input=3 set result=cdbToTail +"RTN","TMGDEBUG",92,0) + +"RTN","TMGDEBUG",93,0) +GDMDone +"RTN","TMGDEBUG",94,0) + quit result +"RTN","TMGDEBUG",95,0) + +"RTN","TMGDEBUG",96,0) +OpenDefLogFile +"RTN","TMGDEBUG",97,0) + ;"Purpose: To open a default log file for debug output +"RTN","TMGDEBUG",98,0) + ;"Results: none +"RTN","TMGDEBUG",99,0) + +"RTN","TMGDEBUG",100,0) + new DefPath,DefName +"RTN","TMGDEBUG",101,0) + +"RTN","TMGDEBUG",102,0) + set DefPath=$piece($get(^TMG(22711,1,2)),"^",1) +"RTN","TMGDEBUG",103,0) + set DefName=$piece($get(^TMG(22711,1,1)),"^",1) +"RTN","TMGDEBUG",104,0) + +"RTN","TMGDEBUG",105,0) + do OpenLogFile(.DefPath,.DefName) +"RTN","TMGDEBUG",106,0) + +"RTN","TMGDEBUG",107,0) + quit +"RTN","TMGDEBUG",108,0) + +"RTN","TMGDEBUG",109,0) + +"RTN","TMGDEBUG",110,0) +OpenLogFile(DefPath,DefName) +"RTN","TMGDEBUG",111,0) + ;"Purpose: To open a log file for debug output +"RTN","TMGDEBUG",112,0) + ;"Input: DefPath -- the default path, like this: "/tmp/" <-- note trailing '/' +"RTN","TMGDEBUG",113,0) + ;" DefName -- default file name (without path). e.g. "LogFile.tmp" +"RTN","TMGDEBUG",114,0) + ;"Results: None +"RTN","TMGDEBUG",115,0) + +"RTN","TMGDEBUG",116,0) + new DebugFPath set DebugFPath=$get(DefPath,"/tmp/") +"RTN","TMGDEBUG",117,0) + new DebugFName set DebugFName=$get(DefName,"M_DebugLog.tmp") +"RTN","TMGDEBUG",118,0) + if $get(TMGDEBUG)>1 do +"RTN","TMGDEBUG",119,0) + . write "Note: Sending debug output to file: ",DebugFPath,DebugFName,! +"RTN","TMGDEBUG",120,0) + +"RTN","TMGDEBUG",121,0) + ;"new DebugFile -- don't NEW here, needs to be global-scope +"RTN","TMGDEBUG",122,0) + set DebugFile=DebugFPath_DebugFName +"RTN","TMGDEBUG",123,0) + new FileSpec set FileSpec(DebugFile)="" +"RTN","TMGDEBUG",124,0) + +"RTN","TMGDEBUG",125,0) + if +$piece($get(^TMG(22711,1,1)),"^",2)'=1 do +"RTN","TMGDEBUG",126,0) + . ;"kill any pre-existing log +"RTN","TMGDEBUG",127,0) + . new result +"RTN","TMGDEBUG",128,0) + . set result=$$DEL^%ZISH(DebugFPath,$name(FileSpec)) ;"delete any preexisting one. +"RTN","TMGDEBUG",129,0) + +"RTN","TMGDEBUG",130,0) + open DebugFile +"RTN","TMGDEBUG",131,0) + use $PRINCIPAL +"RTN","TMGDEBUG",132,0) + +"RTN","TMGDEBUG",133,0) + quit +"RTN","TMGDEBUG",134,0) + +"RTN","TMGDEBUG",135,0) + +"RTN","TMGDEBUG",136,0) +DebugMsg(DBIndent,Msg,A,B,C,D,E,F,G,H,I,J,K,L) +"RTN","TMGDEBUG",137,0) + ;"PUBLIC FUNCTION +"RTN","TMGDEBUG",138,0) + ;"Purpose: a debugging message output procedure +"RTN","TMGDEBUG",139,0) + ;"Input:DBIndent -- the value of indentation expected +"RTN","TMGDEBUG",140,0) + ;" Msg -- a string or value to show as message +"RTN","TMGDEBUG",141,0) + ;" A..L -- extra values to show. +"RTN","TMGDEBUG",142,0) + ;" +"RTN","TMGDEBUG",143,0) + if $get(TMGDEBUG,0)=0 quit +"RTN","TMGDEBUG",144,0) + set cTrue=$get(cTrue,1) +"RTN","TMGDEBUG",145,0) + set DBIndent=$get(DBIndent,0) +"RTN","TMGDEBUG",146,0) + +"RTN","TMGDEBUG",147,0) + set Msg=$get(Msg) +"RTN","TMGDEBUG",148,0) + set Msg=Msg_$get(A) +"RTN","TMGDEBUG",149,0) + set Msg=Msg_$get(B) +"RTN","TMGDEBUG",150,0) + set Msg=Msg_$get(C) +"RTN","TMGDEBUG",151,0) + set Msg=Msg_$get(D) +"RTN","TMGDEBUG",152,0) + set Msg=Msg_$get(E) +"RTN","TMGDEBUG",153,0) + set Msg=Msg_$get(F) +"RTN","TMGDEBUG",154,0) + set Msg=Msg_$get(G) +"RTN","TMGDEBUG",155,0) + set Msg=Msg_$get(H) +"RTN","TMGDEBUG",156,0) + set Msg=Msg_$get(I) +"RTN","TMGDEBUG",157,0) + set Msg=Msg_$get(J) +"RTN","TMGDEBUG",158,0) + set Msg=Msg_$get(K) +"RTN","TMGDEBUG",159,0) + set Msg=Msg_$get(L) +"RTN","TMGDEBUG",160,0) + do DebugIndent(DBIndent) +"RTN","TMGDEBUG",161,0) + do DebugWrite(DBIndent,.Msg,cTrue) +"RTN","TMGDEBUG",162,0) + +"RTN","TMGDEBUG",163,0) + quit +"RTN","TMGDEBUG",164,0) + +"RTN","TMGDEBUG",165,0) + +"RTN","TMGDEBUG",166,0) +DebugWrite(DBIndent,s,AddNewline) +"RTN","TMGDEBUG",167,0) + ;"PUBLIC FUNCTION +"RTN","TMGDEBUG",168,0) + ;"Purpose: to write debug output. Having the proc separate will allow +"RTN","TMGDEBUG",169,0) + ;" easier dump to file etc. +"RTN","TMGDEBUG",170,0) + ;"Input:DBIndent, the amount of indentation expected for output. +"RTN","TMGDEBUG",171,0) + ;" s -- the text to write +"RTN","TMGDEBUG",172,0) + ;" AddNewline -- boolean, 1 if ! (i.e. newline) should be written after s +"RTN","TMGDEBUG",173,0) + +"RTN","TMGDEBUG",174,0) + ;"Relevant DEBUG values +"RTN","TMGDEBUG",175,0) + ;" cdbNone - no debug (0) +"RTN","TMGDEBUG",176,0) + ;" cdbToScrn - Debug output to screen (1) +"RTN","TMGDEBUG",177,0) + ;" cdbToFile - Debug output to file (2) +"RTN","TMGDEBUG",178,0) + ;" cdbToTail - Debug output to X tail dialog box. (3) +"RTN","TMGDEBUG",179,0) + ;"Note: If above values are not defined, then functionality will be ignored. +"RTN","TMGDEBUG",180,0) + +"RTN","TMGDEBUG",181,0) + +"RTN","TMGDEBUG",182,0) + set cdbNone=$get(cdbNone,0) +"RTN","TMGDEBUG",183,0) + set cdbToScrn=$get(cdbToScrn,1) +"RTN","TMGDEBUG",184,0) + set cdbToFile=$get(cdbToFile,2) +"RTN","TMGDEBUG",185,0) + set cdbToTail=$get(cdbToTail,3) +"RTN","TMGDEBUG",186,0) + set TMGDEBUG=$get(TMGDEBUG,cdbNone) +"RTN","TMGDEBUG",187,0) + if $get(TMGDEBUG)=cdbNone quit +"RTN","TMGDEBUG",188,0) + +"RTN","TMGDEBUG",189,0) + if (TMGDEBUG=$get(cdbToFile))!(TMGDEBUG=$get(cdbToTail)) do +"RTN","TMGDEBUG",190,0) + . if $data(DebugFile) use DebugFile +"RTN","TMGDEBUG",191,0) + +"RTN","TMGDEBUG",192,0) + new ch,chN,l,i +"RTN","TMGDEBUG",193,0) + set l=$length(s) +"RTN","TMGDEBUG",194,0) + for i=1:1:l do +"RTN","TMGDEBUG",195,0) + . set ch=$extract(s,i) +"RTN","TMGDEBUG",196,0) + . set chN=$ascii(ch) +"RTN","TMGDEBUG",197,0) + . if (chN<32)&(chN'=13) write "<",chN,">" +"RTN","TMGDEBUG",198,0) + . else write ch +"RTN","TMGDEBUG",199,0) + ;"write s +"RTN","TMGDEBUG",200,0) + +"RTN","TMGDEBUG",201,0) + set cTrue=$get(cTrue,1) +"RTN","TMGDEBUG",202,0) + if $get(AddNewline)=cTrue write ! +"RTN","TMGDEBUG",203,0) + +"RTN","TMGDEBUG",204,0) + if (TMGDEBUG=$get(cdbToFile))!(TMGDEBUG=$get(cdbToTail)) do +"RTN","TMGDEBUG",205,0) + . use $PRINCIPAL +"RTN","TMGDEBUG",206,0) + +"RTN","TMGDEBUG",207,0) + quit +"RTN","TMGDEBUG",208,0) + +"RTN","TMGDEBUG",209,0) + +"RTN","TMGDEBUG",210,0) +DebugIndent(DBIndentForced) +"RTN","TMGDEBUG",211,0) + ;"PUBLIC FUNCTION +"RTN","TMGDEBUG",212,0) + ;"Purpose: to provide a unified indentation for debug messages +"RTN","TMGDEBUG",213,0) + ;"Input: DBIndent = number of indentations +"RTN","TMGDEBUG",214,0) + ;" Forced = 1 if to indent regardless of DEBUG mode +"RTN","TMGDEBUG",215,0) + +"RTN","TMGDEBUG",216,0) + set Forced=$get(Forced,0) +"RTN","TMGDEBUG",217,0) + +"RTN","TMGDEBUG",218,0) + if ($get(TMGDEBUG,0)=0)&(Forced=0) quit +"RTN","TMGDEBUG",219,0) + new i +"RTN","TMGDEBUG",220,0) + for i=1:1:DBIndent do +"RTN","TMGDEBUG",221,0) + . if Forced do DebugWrite(DBIndent," ") +"RTN","TMGDEBUG",222,0) + . else do DebugWrite(DBIndent,". ") +"RTN","TMGDEBUG",223,0) + quit +"RTN","TMGDEBUG",224,0) + +"RTN","TMGDEBUG",225,0) + +"RTN","TMGDEBUG",226,0) + +"RTN","TMGDEBUG",227,0) +ArrayDump(ArrayP,TMGIDX,indent,flags) +"RTN","TMGDEBUG",228,0) + ;"PUBLIC FUNCTION +"RTN","TMGDEBUG",229,0) + ;"Purpose: to get a custom version of GTM's "zwr" command +"RTN","TMGDEBUG",230,0) + ;"Input: Uses global scope var DBIndent (if defined) +"RTN","TMGDEBUG",231,0) + ;" ArrayP: NAME of global or variable to display, i.e. "^VA(200)", "MyVar" +"RTN","TMGDEBUG",232,0) + ;" TMGIDX: initial index (i.e. 5 if wanting to start with ^VA(200,5) -- Optional +"RTN","TMGDEBUG",233,0) + ;" indent: spacing from left margin to begin with. (A number. Each count is 2 spaces) +"RTN","TMGDEBUG",234,0) + ;" OPTIONAL: indent may be an array, with information about columns +"RTN","TMGDEBUG",235,0) + ;" to skip. For example: +"RTN","TMGDEBUG",236,0) + ;" indent=3, indent(2)=0 --> show | for columns 1 & 3, but NOT 2 +"RTN","TMGDEBUG",237,0) + ;" flags: OPTIONAL. "F"-> flat (don't use tre structure) +"RTN","TMGDEBUG",238,0) + ;"Result: none +"RTN","TMGDEBUG",239,0) + +"RTN","TMGDEBUG",240,0) + ;"--Leave out, this calls itself recursively! do DebugEntry("ArrayDump") +"RTN","TMGDEBUG",241,0) + ;"--Leave out, this calls itself recursively! do DebugMsg^TMGDEBUG("ArrayP=",ArrayP,", TMGIDX=",index) +"RTN","TMGDEBUG",242,0) + +"RTN","TMGDEBUG",243,0) + if $data(ArrayP)=0 quit +"RTN","TMGDEBUG",244,0) + +"RTN","TMGDEBUG",245,0) + if $get(flags)["F" do goto ADDone +"RTN","TMGDEBUG",246,0) + . new ref set ref=ArrayP +"RTN","TMGDEBUG",247,0) + . new nNums set nNums=$qlength(ref) +"RTN","TMGDEBUG",248,0) + . new lValue set lValue=$qsubscript(ref,nNums) +"RTN","TMGDEBUG",249,0) + . write ref,"=""",$get(@ref),"""",! +"RTN","TMGDEBUG",250,0) + . for set ref=$query(@ref) quit:(ref="")!($qsubscript(ref,nNums)'=lValue) do +"RTN","TMGDEBUG",251,0) + . . write ref,"=""",$get(@ref),"""",! +"RTN","TMGDEBUG",252,0) + +"RTN","TMGDEBUG",253,0) + ;"Note: I need to do some validation to ensure ArrayP doesn't have any null nodes. +"RTN","TMGDEBUG",254,0) + new X set X="SET TEMP=$GET("_ArrayP_")" +"RTN","TMGDEBUG",255,0) + set X=$$UP^XLFSTR(X) +"RTN","TMGDEBUG",256,0) + do ^DIM ;"a method to ensure ArrayP doesn't have an invalid reference. +"RTN","TMGDEBUG",257,0) + if $get(X)="" quit +"RTN","TMGDEBUG",258,0) + +"RTN","TMGDEBUG",259,0) + set DBIndent=$get(DBIndent,0) +"RTN","TMGDEBUG",260,0) + set cTrue=$get(cTrue,1) +"RTN","TMGDEBUG",261,0) + set cFalse=$get(cFalse,0) +"RTN","TMGDEBUG",262,0) + +"RTN","TMGDEBUG",263,0) + ;"Force this function to output, even if TMGDEBUG is not defined. +"RTN","TMGDEBUG",264,0) + ;"if $data(TMGDEBUG)=0 new TMGDEBUG ;"//kt 1-16-06, doesn't seem to be working +"RTN","TMGDEBUG",265,0) + new TMGDEBUG ;"//kt added 1-16-06 +"RTN","TMGDEBUG",266,0) + set TMGDEBUG=1 +"RTN","TMGDEBUG",267,0) + +"RTN","TMGDEBUG",268,0) + new ChildP,TMGi +"RTN","TMGDEBUG",269,0) + +"RTN","TMGDEBUG",270,0) + set TMGIDX=$get(TMGIDX,"") +"RTN","TMGDEBUG",271,0) + set indent=$get(indent,0) +"RTN","TMGDEBUG",272,0) + new SavIndex set SavIndex=TMGIDX +"RTN","TMGDEBUG",273,0) + +"RTN","TMGDEBUG",274,0) + do DebugIndent(DBIndent) +"RTN","TMGDEBUG",275,0) + +"RTN","TMGDEBUG",276,0) + if indent>0 do +"RTN","TMGDEBUG",277,0) + . for TMGi=1:1:indent-1 do +"RTN","TMGDEBUG",278,0) + . . new s set s="" +"RTN","TMGDEBUG",279,0) + . . if $get(indent(TMGi),-1)=0 set s=" " +"RTN","TMGDEBUG",280,0) + . . else set s="| " +"RTN","TMGDEBUG",281,0) + . . do DebugWrite(DBIndent,s) +"RTN","TMGDEBUG",282,0) + . do DebugWrite(DBIndent,"}~") +"RTN","TMGDEBUG",283,0) + +"RTN","TMGDEBUG",284,0) + if TMGIDX'="" do +"RTN","TMGDEBUG",285,0) + . if $data(@ArrayP@(TMGIDX))#10=1 do +"RTN","TMGDEBUG",286,0) + . . new s set s=@ArrayP@(TMGIDX) +"RTN","TMGDEBUG",287,0) + . . if s="" set s="""""" +"RTN","TMGDEBUG",288,0) + . . new qt set qt="" +"RTN","TMGDEBUG",289,0) + . . if +TMGIDX'=TMGIDX set qt="""" +"RTN","TMGDEBUG",290,0) + . . do DebugWrite(DBIndent,qt_TMGIDX_qt_" = "_s,cTrue) +"RTN","TMGDEBUG",291,0) + . else do +"RTN","TMGDEBUG",292,0) + . . do DebugWrite(DBIndent,TMGIDX,1) +"RTN","TMGDEBUG",293,0) + . set ArrayP=$name(@ArrayP@(TMGIDX)) +"RTN","TMGDEBUG",294,0) + else do +"RTN","TMGDEBUG",295,0) + . ;"do DebugWrite(DBIndent,ArrayP_"(*)",cFalse) +"RTN","TMGDEBUG",296,0) + . do DebugWrite(DBIndent,ArrayP,cFalse) +"RTN","TMGDEBUG",297,0) + . if $data(@ArrayP)#10=1 do +"RTN","TMGDEBUG",298,0) + . . do DebugWrite(0,"="_$get(@ArrayP),cFalse) +"RTN","TMGDEBUG",299,0) + . do DebugWrite(0,"",cTrue) +"RTN","TMGDEBUG",300,0) + +"RTN","TMGDEBUG",301,0) + set TMGIDX=$order(@ArrayP@("")) +"RTN","TMGDEBUG",302,0) + if TMGIDX="" goto ADDone +"RTN","TMGDEBUG",303,0) + set indent=indent+1 +"RTN","TMGDEBUG",304,0) + +"RTN","TMGDEBUG",305,0) + for do quit:TMGIDX="" +"RTN","TMGDEBUG",306,0) + . new tTMGIDX set tTMGIDX=$order(@ArrayP@(TMGIDX)) +"RTN","TMGDEBUG",307,0) + . if tTMGIDX="" set indent(indent)=0 +"RTN","TMGDEBUG",308,0) + . new tIndent merge tIndent=indent +"RTN","TMGDEBUG",309,0) + . do ArrayDump(ArrayP,TMGIDX,.tIndent) ;"Call self recursively +"RTN","TMGDEBUG",310,0) + . set TMGIDX=$order(@ArrayP@(TMGIDX)) +"RTN","TMGDEBUG",311,0) + +"RTN","TMGDEBUG",312,0) + ;"Put in a blank space at end of subbranch +"RTN","TMGDEBUG",313,0) + do DebugIndent(DBIndent) +"RTN","TMGDEBUG",314,0) + +"RTN","TMGDEBUG",315,0) + if indent>0 do +"RTN","TMGDEBUG",316,0) + . for TMGi=1:1:indent-1 do +"RTN","TMGDEBUG",317,0) + . . new s set s="" +"RTN","TMGDEBUG",318,0) + . . if $get(indent(TMGi),-1)=0 set s=" " +"RTN","TMGDEBUG",319,0) + . . else set s="| " +"RTN","TMGDEBUG",320,0) + . . do DebugWrite(DBIndent,s) +"RTN","TMGDEBUG",321,0) + . do DebugWrite(DBIndent," ",1) +"RTN","TMGDEBUG",322,0) + +"RTN","TMGDEBUG",323,0) +ADDone +"RTN","TMGDEBUG",324,0) + ;"--Leave out, this calls itself recursively! do DebugExit("ArrayDump") +"RTN","TMGDEBUG",325,0) + quit +"RTN","TMGDEBUG",326,0) + +"RTN","TMGDEBUG",327,0) + +"RTN","TMGDEBUG",328,0) +ASKANODES +"RTN","TMGDEBUG",329,0) + ;"Purpose: to ask user for the name of an array, then display nodes +"RTN","TMGDEBUG",330,0) + +"RTN","TMGDEBUG",331,0) + new name +"RTN","TMGDEBUG",332,0) + write ! +"RTN","TMGDEBUG",333,0) + read "Enter name of array to display nodes in: ",name,! +"RTN","TMGDEBUG",334,0) + if name="^" set name="" +"RTN","TMGDEBUG",335,0) + if name'="" do ArrayNodes(name) +"RTN","TMGDEBUG",336,0) + quit +"RTN","TMGDEBUG",337,0) + +"RTN","TMGDEBUG",338,0) + +"RTN","TMGDEBUG",339,0) +ArrayNodes(pArray) +"RTN","TMGDEBUG",340,0) + ;"Purpose: To display all the nodes of the given array +"RTN","TMGDEBUG",341,0) + ;"Input: pArray -- NAME OF array to display +"RTN","TMGDEBUG",342,0) + +"RTN","TMGDEBUG",343,0) + new TMGi +"RTN","TMGDEBUG",344,0) + +"RTN","TMGDEBUG",345,0) + write pArray,! +"RTN","TMGDEBUG",346,0) + set TMGi=$order(@pArray@("")) +"RTN","TMGDEBUG",347,0) + if TMGi'="" for do quit:(TMGi="") +"RTN","TMGDEBUG",348,0) + . write " +--(",TMGi,")",! +"RTN","TMGDEBUG",349,0) + . set TMGi=$order(@pArray@(TMGi)) +"RTN","TMGDEBUG",350,0) + +"RTN","TMGDEBUG",351,0) + quit +"RTN","TMGDEBUG",352,0) + +"RTN","TMGDEBUG",353,0) +DebugEntry(DBIndent,ProcName) +"RTN","TMGDEBUG",354,0) + ;"PUBLIC FUNCTION +"RTN","TMGDEBUG",355,0) + ;"Purpose: A way to show when entering a procedure, in debug mode +"RTN","TMGDEBUG",356,0) + ;"Input: DBIndent, a variable to keep track of indentation amount--PASS BY REFERENCE +"RTN","TMGDEBUG",357,0) + ;" ProcName: any arbitrary name to show when decreasing indent amount. +"RTN","TMGDEBUG",358,0) + +"RTN","TMGDEBUG",359,0) + set ProcName=$get(ProcName,"?") +"RTN","TMGDEBUG",360,0) + set DBIndent=$get(DBIndent,0) +"RTN","TMGDEBUG",361,0) + do DebugMsg(DBIndent,ProcName_" {") +"RTN","TMGDEBUG",362,0) + set DBIndent=DBIndent+1 +"RTN","TMGDEBUG",363,0) + quit +"RTN","TMGDEBUG",364,0) + +"RTN","TMGDEBUG",365,0) + +"RTN","TMGDEBUG",366,0) +DebugExit(DBIndent,ProcName) +"RTN","TMGDEBUG",367,0) + ;"PUBLIC FUNCTION +"RTN","TMGDEBUG",368,0) + ;"Purpose: A way to show when leaving a procedure, in debug mode +"RTN","TMGDEBUG",369,0) + ;"Input: DBIndent, a variable to keep track of indentation amount--PASS BY REFERENCE +"RTN","TMGDEBUG",370,0) + ;" ProcName: any arbitrary name to show when decreasing indent amount. +"RTN","TMGDEBUG",371,0) + +"RTN","TMGDEBUG",372,0) + ;"write "DBIndent=",DBIndent,! +"RTN","TMGDEBUG",373,0) + ;"write "ProcName=",ProcName,! +"RTN","TMGDEBUG",374,0) + set ProcName=$get(ProcName,"?") +"RTN","TMGDEBUG",375,0) + set DBIndent=$get(DBIndent)-1 +"RTN","TMGDEBUG",376,0) + if DBIndent<0 set DBIndent=0 +"RTN","TMGDEBUG",377,0) + do DebugMsg(DBIndent,"} //"_ProcName) +"RTN","TMGDEBUG",378,0) + +"RTN","TMGDEBUG",379,0) + quit +"RTN","TMGDEBUG",380,0) + +"RTN","TMGDEBUG",381,0) + +"RTN","TMGDEBUG",382,0) + +"RTN","TMGDEBUG",383,0) + +"RTN","TMGDEBUG",384,0) +ShowError(PriorErrorFound,Error) +"RTN","TMGDEBUG",385,0) + ;"Purpose: to output an error message +"RTN","TMGDEBUG",386,0) + ;"Input: [OPTIONAL] PriorErrorFound -- var to see if an error already shown. +"RTN","TMGDEBUG",387,0) + ;" if not passed, then default value used ('no prior error') +"RTN","TMGDEBUG",388,0) + ;" Error -- a string to display +"RTN","TMGDEBUG",389,0) + ;"results: none +"RTN","TMGDEBUG",390,0) + +"RTN","TMGDEBUG",391,0) + if $get(TMGDEBUG)=-1 quit ;"EXTRA QUIET mode --> skip entirely +"RTN","TMGDEBUG",392,0) + +"RTN","TMGDEBUG",393,0) + if $get(TMGDEBUG)>0 do DebugEntry(.DBIndent,"ShowError") +"RTN","TMGDEBUG",394,0) + if $get(TMGDEBUG)>0 do DebugMsg(.DBIndent,"Error msg=",Error) +"RTN","TMGDEBUG",395,0) + +"RTN","TMGDEBUG",396,0) + if $get(PriorErrorFound,0) do goto ShErrQuit ;"Remove to show cascading errors +"RTN","TMGDEBUG",397,0) + . if $get(TMGDEBUG)>0 do DebugMsg(.DBIndent,"Prior error found, so won't show this error.") +"RTN","TMGDEBUG",398,0) + +"RTN","TMGDEBUG",399,0) + if $data(DBIndent)=0 new DBIndent ;"If it wasn't global before, keep it that way. +"RTN","TMGDEBUG",400,0) + new SaveIndent set SaveIndent=$get(DBIndent) +"RTN","TMGDEBUG",401,0) + set DBIndent=1 +"RTN","TMGDEBUG",402,0) + do PopupBox^TMGUSRIF(" ERROR . . .",Error) +"RTN","TMGDEBUG",403,0) + set PriorErrorFound=1 +"RTN","TMGDEBUG",404,0) + set DBIndent=SaveIndent +"RTN","TMGDEBUG",405,0) + +"RTN","TMGDEBUG",406,0) +ShErrQuit +"RTN","TMGDEBUG",407,0) + if $get(TMGDEBUG)>0 do DebugExit(.DBIndent,"ShowError") +"RTN","TMGDEBUG",408,0) + +"RTN","TMGDEBUG",409,0) + quit +"RTN","TMGDEBUG",410,0) + +"RTN","TMGDEBUG",411,0) + +"RTN","TMGDEBUG",412,0) +GetErrStr(ErrArray) +"RTN","TMGDEBUG",413,0) + ;"Purpose: convert a standard DIERR array into a string for output +"RTN","TMGDEBUG",414,0) + ;"Input: ErrArray -- PASS BY REFERENCE. example: +"RTN","TMGDEBUG",415,0) + ;" array("DIERR")="1^1" +"RTN","TMGDEBUG",416,0) + ;" array("DIERR",1)=311 +"RTN","TMGDEBUG",417,0) + ;" array("DIERR",1,"PARAM",0)=3 +"RTN","TMGDEBUG",418,0) + ;" array("DIERR",1,"PARAM","FIELD")=.02 +"RTN","TMGDEBUG",419,0) + ;" array("DIERR",1,"PARAM","FILE")=2 +"RTN","TMGDEBUG",420,0) + ;" array("DIERR",1,"PARAM","IENS")="+1," +"RTN","TMGDEBUG",421,0) + ;" array("DIERR",1,"TEXT",1)="The new record '+1,' lacks some required identifiers." +"RTN","TMGDEBUG",422,0) + ;" array("DIERR","E",311,1)="" +"RTN","TMGDEBUG",423,0) + ;"Results: returns one long equivalent string from above array. +"RTN","TMGDEBUG",424,0) + +"RTN","TMGDEBUG",425,0) + new ErrStr +"RTN","TMGDEBUG",426,0) + new TMGIDX +"RTN","TMGDEBUG",427,0) + new ErrNum +"RTN","TMGDEBUG",428,0) + +"RTN","TMGDEBUG",429,0) + set ErrStr="" +"RTN","TMGDEBUG",430,0) + for ErrNum=1:1:+$get(ErrArray("DIERR")) do +"RTN","TMGDEBUG",431,0) + . set ErrStr=ErrStr_"Fileman says: '" +"RTN","TMGDEBUG",432,0) + . if ErrNum'=1 set ErrStr=ErrStr_"(Error# "_ErrNum_") " +"RTN","TMGDEBUG",433,0) + . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"TEXT","")) +"RTN","TMGDEBUG",434,0) + . if TMGIDX'="" for do quit:(TMGIDX="") +"RTN","TMGDEBUG",435,0) + . . set ErrStr=ErrStr_$get(ErrArray("DIERR",ErrNum,"TEXT",TMGIDX))_" " +"RTN","TMGDEBUG",436,0) + . . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"TEXT",TMGIDX)) +"RTN","TMGDEBUG",437,0) + . if $get(ErrArray("DIERR",ErrNum,"PARAM",0))>0 do +"RTN","TMGDEBUG",438,0) + . . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"PARAM",0)) +"RTN","TMGDEBUG",439,0) + . . set ErrStr=ErrStr_"Details: " +"RTN","TMGDEBUG",440,0) + . . for do quit:(TMGIDX="") +"RTN","TMGDEBUG",441,0) + . . . if TMGIDX="" quit +"RTN","TMGDEBUG",442,0) + . . . set ErrStr=ErrStr_"["_TMGIDX_"]="_$get(ErrArray("DIERR",1,"PARAM",TMGIDX))_" " +"RTN","TMGDEBUG",443,0) + . . . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"PARAM",TMGIDX)) +"RTN","TMGDEBUG",444,0) + +"RTN","TMGDEBUG",445,0) + quit ErrStr +"RTN","TMGDEBUG",446,0) + +"RTN","TMGDEBUG",447,0) + +"RTN","TMGDEBUG",448,0) + +"RTN","TMGDEBUG",449,0) +ShowIfDIERR(ErrMsg,PriorErrorFound) ;"really same as below +"RTN","TMGDEBUG",450,0) + goto SEL1 +"RTN","TMGDEBUG",451,0) + +"RTN","TMGDEBUG",452,0) +ShowDIERR(ErrMsg,PriorErrorFound) +"RTN","TMGDEBUG",453,0) + ;"Purpose: To provide a standard output mechanism for the fileman DIERR message +"RTN","TMGDEBUG",454,0) + ;"Input: ErrMsg -- PASS BY REFERENCE. a standard error message array, as +"RTN","TMGDEBUG",455,0) + ;" put out by fileman calls +"RTN","TMGDEBUG",456,0) + ;" PriorErrorFound -- OPTIONAL variable to keep track if prior error found. +"RTN","TMGDEBUG",457,0) + ;" Note -- can also be used as ErrorFound (i.e. set to 1 if error found) +"RTN","TMGDEBUG",458,0) + ;"Output -- none +"RTN","TMGDEBUG",459,0) + ;"Result -- none +"RTN","TMGDEBUG",460,0) + +"RTN","TMGDEBUG",461,0) +SEL1 +"RTN","TMGDEBUG",462,0) + if $get(TMGDEBUG)=-1 quit ;"EXTRA QUIET mode --> skip entirely +"RTN","TMGDEBUG",463,0) + +"RTN","TMGDEBUG",464,0) + if $get(TMGDEBUG)>0 do DebugEntry(.DBIndent,"ShowDIERR") +"RTN","TMGDEBUG",465,0) + +"RTN","TMGDEBUG",466,0) + if $data(ErrMsg("DIERR")) do +"RTN","TMGDEBUG",467,0) + . if $get(TMGDEBUG)>0 do DebugMsg(.DBIndent,"Error message found. Here is array:") +"RTN","TMGDEBUG",468,0) + . if $get(TMGDEBUG) do ArrayDump("ErrMsg") +"RTN","TMGDEBUG",469,0) + . new ErrStr +"RTN","TMGDEBUG",470,0) + . set ErrStr=$$GetErrStr(.ErrMsg) +"RTN","TMGDEBUG",471,0) + . do ShowError(.PriorErrorFound,.ErrStr) +"RTN","TMGDEBUG",472,0) + +"RTN","TMGDEBUG",473,0) + if $get(TMGDEBUG)>0 do DebugExit(.DBIndent,"ShowDIERR") +"RTN","TMGDEBUG",474,0) + quit +"RTN","TMGDEBUG",475,0) + +"RTN","TMGDEBUG",476,0) +ExpandLine(Pos) +"RTN","TMGDEBUG",477,0) + ;"Purpose: to expand a line of code, found at position "Pos", using ^XINDX8 functionality +"RTN","TMGDEBUG",478,0) + ;"Input: Pos: a position as returned by $ZPOS (e.g. G+5^DIS, or +23^DIS) +"RTN","TMGDEBUG",479,0) + ;"Output: Writes to the currently selecte IO device and expansion of one line of code +"RTN","TMGDEBUG",480,0) + ;"Note: This is used for taking the very long lines of code, as found in Fileman, and +"RTN","TMGDEBUG",481,0) + ;" convert them to a format with one command on each line. +"RTN","TMGDEBUG",482,0) + ;" Note: it appears to do syntax checking and shows ERROR if syntax is not per VA +"RTN","TMGDEBUG",483,0) + ;" conventions--such as commands must be UPPERCASE etc. +"RTN","TMGDEBUG",484,0) + +"RTN","TMGDEBUG",485,0) + ;"--- copied and modified from XINDX8.m --- +"RTN","TMGDEBUG",486,0) + +"RTN","TMGDEBUG",487,0) + kill ^UTILITY($J) +"RTN","TMGDEBUG",488,0) + +"RTN","TMGDEBUG",489,0) + new label,offset,RTN,dmod +"RTN","TMGDEBUG",490,0) + do ParsePos^TMGMISC(Pos,.label,.offset,.RTN,.dmod) +"RTN","TMGDEBUG",491,0) + if label'="" do ;"change position from one relative to label into one relative to top of file +"RTN","TMGDEBUG",492,0) + . new CodeArray +"RTN","TMGDEBUG",493,0) + . set Pos=$$ConvertPos^TMGMISC(Pos,"CodeArray") +"RTN","TMGDEBUG",494,0) + . do ParsePos^TMGMISC(Pos,.label,.offset,.RTN,.dmod) +"RTN","TMGDEBUG",495,0) + +"RTN","TMGDEBUG",496,0) + if RTN="" goto ELDone +"RTN","TMGDEBUG",497,0) + +"RTN","TMGDEBUG",498,0) + do BUILD^XINDX7 +"RTN","TMGDEBUG",499,0) + set ^UTILITY($J,RTN)="" +"RTN","TMGDEBUG",500,0) + do LOAD^XINDEX +"RTN","TMGDEBUG",501,0) + set CCN=0 +"RTN","TMGDEBUG",502,0) + for I=1:1:+^UTILITY($J,1,RTN,0,0) S CCN=CCN+$L(^UTILITY($J,1,RTN,0,I,0))+2 +"RTN","TMGDEBUG",503,0) + set ^UTILITY($J,1,RTN,0)=CCN +"RTN","TMGDEBUG",504,0) + ;"do ^XINDX8 -- included below +"RTN","TMGDEBUG",505,0) + +"RTN","TMGDEBUG",506,0) + new Q,DDOT,LO,PG,LIN,ML,IDT +"RTN","TMGDEBUG",507,0) + new tIOSL set tIOSL=IOSL +"RTN","TMGDEBUG",508,0) + set IOSL=999999 ;"really long 'page length' prevents header printout (and error) +"RTN","TMGDEBUG",509,0) + +"RTN","TMGDEBUG",510,0) + set Q="""" +"RTN","TMGDEBUG",511,0) + set DDOT=0 +"RTN","TMGDEBUG",512,0) + set LO=0 +"RTN","TMGDEBUG",513,0) + set PG=+$G(PG) +"RTN","TMGDEBUG",514,0) + +"RTN","TMGDEBUG",515,0) + set LC=offset +"RTN","TMGDEBUG",516,0) + if $D(^UTILITY($J,1,RTN,0,LC)) do +"RTN","TMGDEBUG",517,0) + . S LIN=^(LC,0),ML=0,IDT=10 +"RTN","TMGDEBUG",518,0) + . set LO=LC-1 +"RTN","TMGDEBUG",519,0) + . D CD^XINDX8 +"RTN","TMGDEBUG",520,0) + +"RTN","TMGDEBUG",521,0) + K AGR,EOC,IDT,JJ,LO,ML,OLD,SAV,TY +"RTN","TMGDEBUG",522,0) + +"RTN","TMGDEBUG",523,0) + set IOSL=tIOSL ;"restore saved IOSL +"RTN","TMGDEBUG",524,0) +ELDone +"RTN","TMGDEBUG",525,0) + quit +"RTN","TMGDEBUG",526,0) + +"RTN","TMGDEBUG",527,0) + +"RTN","TMGDEBUG",528,0) +DumpRec(FileNum,IEN) +"RTN","TMGDEBUG",529,0) + ;"Purpose: to dump (display) a record, using Fileman functionality. +"RTN","TMGDEBUG",530,0) + ;"Input: FileNum -- the number of the file to dump from +"RTN","TMGDEBUG",531,0) + ;" IEN -- the record number to display +"RTN","TMGDEBUG",532,0) + ;"Note: this code is modified from INQ^DII +"RTN","TMGDEBUG",533,0) + +"RTN","TMGDEBUG",534,0) + new DIC,X,Y,DI,DPP,DK,DICSS +"RTN","TMGDEBUG",535,0) + +"RTN","TMGDEBUG",536,0) + set X=FileNum,Y=X +"RTN","TMGDEBUG",537,0) + +"RTN","TMGDEBUG",538,0) + set DI=$get(^DIC(FileNum,0,"GL")) if DI="" quit +"RTN","TMGDEBUG",539,0) + set DPP(1)=FileNum_"^^^@" +"RTN","TMGDEBUG",540,0) + set DK=FileNum +"RTN","TMGDEBUG",541,0) + +"RTN","TMGDEBUG",542,0) + K ^UTILITY($J),^(U,$J),DIC,DIQ,DISV,DIBT,DICS +"RTN","TMGDEBUG",543,0) + +"RTN","TMGDEBUG",544,0) + set DIK=1 +"RTN","TMGDEBUG",545,0) + set ^UTILITY(U,$J,DIK,IEN)="" ;"<-- note, to have multiple IEN's shown, iterate via DIK +"RTN","TMGDEBUG",546,0) + +"RTN","TMGDEBUG",547,0) + do S^DII ;"Jump into Fileman code. +"RTN","TMGDEBUG",548,0) + +"RTN","TMGDEBUG",549,0) + quit +"RTN","TMGDEBUG",550,0) + +"RTN","TMGDEBUG",551,0) + +"RTN","TMGDEBUG",552,0) +xASKDUMP +"RTN","TMGDEBUG",553,0) + ;"Purpose: A record dumper -- a little different from Fileman Inquire +"RTN","TMGDEBUG",554,0) + +"RTN","TMGDEBUG",555,0) + new DIC,X,Y +"RTN","TMGDEBUG",556,0) + new FileNum,IEN +"RTN","TMGDEBUG",557,0) + new UseDefault set UseDefault=1 +"RTN","TMGDEBUG",558,0) + +"RTN","TMGDEBUG",559,0) + ;"Pick file to dump from +"RTN","TMGDEBUG",560,0) +xASK1 set DIC=1 +"RTN","TMGDEBUG",561,0) + set DIC(0)="AEQM" +"RTN","TMGDEBUG",562,0) + if UseDefault do ;"leave the redundant do loop, it protects $T, so second do ^DIC isn't called +"RTN","TMGDEBUG",563,0) + . do ^DICRW ;" has default value of user's last response +"RTN","TMGDEBUG",564,0) + else do ^DIC ;doesn't have default value... +"RTN","TMGDEBUG",565,0) + if +Y'>0 write ! goto xASKDone +"RTN","TMGDEBUG",566,0) + set FileNum=+Y +"RTN","TMGDEBUG",567,0) + +"RTN","TMGDEBUG",568,0) + ;"Pick record to dump +"RTN","TMGDEBUG",569,0) +xASKLOOP kill DIC,X +"RTN","TMGDEBUG",570,0) + set DIC=+FileNum +"RTN","TMGDEBUG",571,0) + set DIC(0)="AEQM" +"RTN","TMGDEBUG",572,0) + do ^DIC write ! +"RTN","TMGDEBUG",573,0) + if +Y'>0 set UseDefault=0 goto xASK1 +"RTN","TMGDEBUG",574,0) + set IEN=+Y +"RTN","TMGDEBUG",575,0) + +"RTN","TMGDEBUG",576,0) + new % set %=2 +"RTN","TMGDEBUG",577,0) + write "Display empty fields" +"RTN","TMGDEBUG",578,0) + do YN^DICN +"RTN","TMGDEBUG",579,0) + if %=-1 write ! goto xASKDone +"RTN","TMGDEBUG",580,0) + +"RTN","TMGDEBUG",581,0) + new %ZIS +"RTN","TMGDEBUG",582,0) + set %ZIS("A")="Enter Output Device: " +"RTN","TMGDEBUG",583,0) + set %ZIS("B")="HOME" +"RTN","TMGDEBUG",584,0) + do ^%ZIS ;"standard device call +"RTN","TMGDEBUG",585,0) + if POP do goto xASKDone +"RTN","TMGDEBUG",586,0) + . do ShowError^TMGDEBUG(.PriorErrorFound,"Error opening output. Aborting.") +"RTN","TMGDEBUG",587,0) + use IO +"RTN","TMGDEBUG",588,0) + +"RTN","TMGDEBUG",589,0) + ;"Do the output +"RTN","TMGDEBUG",590,0) + write ! +"RTN","TMGDEBUG",591,0) + do DumpRec2(FileNum,IEN,(%=1)) +"RTN","TMGDEBUG",592,0) + +"RTN","TMGDEBUG",593,0) + ;" Close the output device +"RTN","TMGDEBUG",594,0) + do ^%ZISC +"RTN","TMGDEBUG",595,0) + +"RTN","TMGDEBUG",596,0) + new temp +"RTN","TMGDEBUG",597,0) + read "Press [ENTER] to continue...",temp:$get(DTIME,3600),! +"RTN","TMGDEBUG",598,0) + +"RTN","TMGDEBUG",599,0) + goto xASKLOOP +"RTN","TMGDEBUG",600,0) + +"RTN","TMGDEBUG",601,0) +xASKDone +"RTN","TMGDEBUG",602,0) + quit +"RTN","TMGDEBUG",603,0) + +"RTN","TMGDEBUG",604,0) +ASKDUMP +"RTN","TMGDEBUG",605,0) + ;"Purpose: A record dumper -- a little different from Fileman Inquire +"RTN","TMGDEBUG",606,0) + +"RTN","TMGDEBUG",607,0) + write !!," -= RECORD DUMPER =-",! +"RTN","TMGDEBUG",608,0) + new FIENS,IENS +"RTN","TMGDEBUG",609,0) +AL1 +"RTN","TMGDEBUG",610,0) + set FIENS=$$AskFIENS^TMGDBAPI() +"RTN","TMGDEBUG",611,0) + if (FIENS["?")!(FIENS="^") goto ASKDone +"RTN","TMGDEBUG",612,0) + +"RTN","TMGDEBUG",613,0) + set FileNum=$piece(FIENS,"^",1) +"RTN","TMGDEBUG",614,0) + set IENS=$piece(FIENS,"^",2) +"RTN","TMGDEBUG",615,0) + +"RTN","TMGDEBUG",616,0) +AL2 +"RTN","TMGDEBUG",617,0) + set IENS=$$AskIENS^TMGDBAPI(FileNum,IENS) +"RTN","TMGDEBUG",618,0) + if (IENS["?")!(IENS="") goto AL1 +"RTN","TMGDEBUG",619,0) + +"RTN","TMGDEBUG",620,0) + new % set %=2 +"RTN","TMGDEBUG",621,0) + write "Display empty fields" +"RTN","TMGDEBUG",622,0) + do YN^DICN +"RTN","TMGDEBUG",623,0) + if %=-1 write ! goto ASKDone +"RTN","TMGDEBUG",624,0) + +"RTN","TMGDEBUG",625,0) + new %ZIS +"RTN","TMGDEBUG",626,0) + set %ZIS("A")="Enter Output Device: " +"RTN","TMGDEBUG",627,0) + set %ZIS("B")="HOME" +"RTN","TMGDEBUG",628,0) + do ^%ZIS ;"standard device call +"RTN","TMGDEBUG",629,0) + if POP do goto ASKDone +"RTN","TMGDEBUG",630,0) + . do ShowError^TMGDEBUG(.PriorErrorFound,"Error opening output. Aborting.") +"RTN","TMGDEBUG",631,0) + use IO +"RTN","TMGDEBUG",632,0) + +"RTN","TMGDEBUG",633,0) + ;"Do the output +"RTN","TMGDEBUG",634,0) + write ! do DumpRec2(FileNum,IENS,(%=1)) +"RTN","TMGDEBUG",635,0) + +"RTN","TMGDEBUG",636,0) + ;" Close the output device +"RTN","TMGDEBUG",637,0) + do ^%ZISC +"RTN","TMGDEBUG",638,0) + +"RTN","TMGDEBUG",639,0) + do PressToCont^TMGUSRIF +"RTN","TMGDEBUG",640,0) + ;"new temp +"RTN","TMGDEBUG",641,0) + ;"read "Press [ENTER] to continue...",temp:$get(DTIME,3600),! +"RTN","TMGDEBUG",642,0) + +"RTN","TMGDEBUG",643,0) + set IENS=$piece(IENS,",",2,99) ;"force Pick of new record to dump +"RTN","TMGDEBUG",644,0) + if +IENS>0 goto AL2 +"RTN","TMGDEBUG",645,0) + goto AL1 +"RTN","TMGDEBUG",646,0) + +"RTN","TMGDEBUG",647,0) +ASKDone +"RTN","TMGDEBUG",648,0) + quit +"RTN","TMGDEBUG",649,0) + +"RTN","TMGDEBUG",650,0) + +"RTN","TMGDEBUG",651,0) +DumpRec2(FileNum,IENS,ShowEmpty,FieldsArray) +"RTN","TMGDEBUG",652,0) + ;"Purpose: to dump (display) a record, NOT using ^DII (Fileman's Inquire code) +"RTN","TMGDEBUG",653,0) + ;"Input: FileNum -- the number of the file to dump from +"RTN","TMGDEBUG",654,0) + ;" IENS -- the record number to display (or IENS: #,#,#,) +"RTN","TMGDEBUG",655,0) + ;" ShowEmpty -- OPTIONAL; if 1 then empty fields will be displayed +"RTN","TMGDEBUG",656,0) + ;" FieldsArray -- OPTIONAL. PASS BY REFERENCE. +"RTN","TMGDEBUG",657,0) + ;" Allows user to specify which fields to show. Format: +"RTN","TMGDEBUG",658,0) + ;" FieldsArray(FieldtoShow)="" <-- FieldtoShow is name or number +"RTN","TMGDEBUG",659,0) + ;" FieldsArray(FieldtoShow)="" <-- FieldtoShow is name or number +"RTN","TMGDEBUG",660,0) + ;" Default is an empty array, in which all fields are considered +"RTN","TMGDEBUG",661,0) + +"RTN","TMGDEBUG",662,0) + new Fields +"RTN","TMGDEBUG",663,0) + set Fields("*")="" +"RTN","TMGDEBUG",664,0) + new flags set flags="i" +"RTN","TMGDEBUG",665,0) + if $get(ShowEmpty)=1 set flags=flags_"b" +"RTN","TMGDEBUG",666,0) + +"RTN","TMGDEBUG",667,0) + write "Record# ",IENS," in FILE: ",FileNum,! +"RTN","TMGDEBUG",668,0) + +"RTN","TMGDEBUG",669,0) + new field,fieldName +"RTN","TMGDEBUG",670,0) + if $data(FieldsArray)=0 do +"RTN","TMGDEBUG",671,0) + . set field=$order(^DD(FileNum,0)) +"RTN","TMGDEBUG",672,0) + . if +field>0 for do quit:(+field'>0) +"RTN","TMGDEBUG",673,0) + . . set fieldName=$piece(^DD(FileNum,field,0),"^",1) +"RTN","TMGDEBUG",674,0) + . . set Fields("TAG NAME",field)=fieldName_"("_field_")" +"RTN","TMGDEBUG",675,0) + . . set field=$order(^DD(FileNum,field)) +"RTN","TMGDEBUG",676,0) + else do ;"Handle case of showing ONLY requested fields +"RTN","TMGDEBUG",677,0) + . new temp set temp="" +"RTN","TMGDEBUG",678,0) + . for set temp=$order(FieldsArray(temp)) quit:(temp="") do +"RTN","TMGDEBUG",679,0) + . . if +temp=temp do +"RTN","TMGDEBUG",680,0) + . . . set field=+temp +"RTN","TMGDEBUG",681,0) + . . . set fieldName=$piece(^DD(FileNum,field,0),"^",1) +"RTN","TMGDEBUG",682,0) + . . else do +"RTN","TMGDEBUG",683,0) + . . . set fieldName=temp +"RTN","TMGDEBUG",684,0) + . . . if $$SetFileFldNums^TMGDBAPI(FileNum,fieldName,,.field)=0 quit +"RTN","TMGDEBUG",685,0) + . . set Fields("TAG NAME",field)=fieldName_"("_field_")" +"RTN","TMGDEBUG",686,0) + . ;"Now exclude those fields not specifically included +"RTN","TMGDEBUG",687,0) + . set field=0 +"RTN","TMGDEBUG",688,0) + . for set field=$order(^DD(FileNum,field)) quit:(+field'>0) do +"RTN","TMGDEBUG",689,0) + . . if $data(Fields("TAG NAME",field))'=0 quit +"RTN","TMGDEBUG",690,0) + . . set fieldName=$piece(^DD(FileNum,field,0),"^",1) +"RTN","TMGDEBUG",691,0) + . . set Fields("Field Exclude",field)="" +"RTN","TMGDEBUG",692,0) + +"RTN","TMGDEBUG",693,0) + new RFn,FFn,LFn,WPLFn +"RTN","TMGDEBUG",694,0) + set RFn="WriteRLabel^TMGDEBUG" +"RTN","TMGDEBUG",695,0) + set FFn="WriteFLabel^TMGDEBUG" +"RTN","TMGDEBUG",696,0) + set LFn="WriteLine^TMGDEBUG" +"RTN","TMGDEBUG",697,0) + set WPLFn="WriteWPLine^TMGDEBUG" +"RTN","TMGDEBUG",698,0) + +"RTN","TMGDEBUG",699,0) + ;"write "Using flags (options): ",flags,! +"RTN","TMGDEBUG",700,0) + +"RTN","TMGDEBUG",701,0) + if +IENS=IENS do +"RTN","TMGDEBUG",702,0) + . do Write1Rec^TMGXMLE2(FileNum,IENS,.Fields,flags,,,"",RFn,FFn,LFn,WPLFn) +"RTN","TMGDEBUG",703,0) + else do ;"dump a subfile record +"RTN","TMGDEBUG",704,0) + . do Write1Rec^TMGXMLE2(FileNum,+IENS,.Fields,flags,,IENS,"",RFn,FFn,LFn,WPLFn) +"RTN","TMGDEBUG",705,0) + +"RTN","TMGDEBUG",706,0) + quit +"RTN","TMGDEBUG",707,0) + +"RTN","TMGDEBUG",708,0) + +"RTN","TMGDEBUG",709,0) +WriteRLabel(IEN,Ender) +"RTN","TMGDEBUG",710,0) + ;"Purpose: To actually write out labels for record starting and ending. +"RTN","TMGDEBUG",711,0) + ;" IEN -- the IEN (record number) of the record +"RTN","TMGDEBUG",712,0) + ;" Ender -- OPTIONAL if 1, then ends field. +"RTN","TMGDEBUG",713,0) + ;"Results: none. +"RTN","TMGDEBUG",714,0) + ;"Note: Used by DumpRec2 above, with callback from TMGXMLE2 +"RTN","TMGDEBUG",715,0) + +"RTN","TMGDEBUG",716,0) + if +$get(Ender)>0 write ! +"RTN","TMGDEBUG",717,0) + else write " Multiple Entry #",IEN,"",! +"RTN","TMGDEBUG",718,0) + +"RTN","TMGDEBUG",719,0) + quit +"RTN","TMGDEBUG",720,0) + +"RTN","TMGDEBUG",721,0) + +"RTN","TMGDEBUG",722,0) +WriteFLabel(Label,Field,Type,Ender) +"RTN","TMGDEBUG",723,0) + ;"Purpose: This is the code that actually does writing of labels etc for output +"RTN","TMGDEBUG",724,0) + ;" This is a CUSTOM CALL BACK function called by Write1Fld^TMGXMLE2 +"RTN","TMGDEBUG",725,0) + ;"Input: Label -- OPTIONAL -- Name of label, to write after 'label=' +"RTN","TMGDEBUG",726,0) + ;" Field -- OPTIONAL -- Name of field, to write after 'id=' +"RTN","TMGDEBUG",727,0) + ;" Type -- OPTIONAL -- Typeof field, to write after 'type=' +"RTN","TMGDEBUG",728,0) + ;" Ender -- OPTIONAL if 1, then ends field. +"RTN","TMGDEBUG",729,0) + ;"Results: none. +"RTN","TMGDEBUG",730,0) + ;"Note: Used by DumpRec2 above, with callback from TMGXMLE2 +"RTN","TMGDEBUG",731,0) + +"RTN","TMGDEBUG",732,0) + ;"To write out or +"RTN","TMGDEBUG",733,0) + +"RTN","TMGDEBUG",734,0) + if +$get(Ender)>0 do +"RTN","TMGDEBUG",735,0) + . write ! +"RTN","TMGDEBUG",736,0) + else do +"RTN","TMGDEBUG",737,0) + . new s set s=Field +"RTN","TMGDEBUG",738,0) + . if $get(Field)'="" write $$RJ^XLFSTR(.s,6," "),"-" +"RTN","TMGDEBUG",739,0) + . if $get(Label)'="" write Label," " +"RTN","TMGDEBUG",740,0) + . ;"if $get(Type)'="" write "type=""",Type,""" " +"RTN","TMGDEBUG",741,0) + . write ": " +"RTN","TMGDEBUG",742,0) + +"RTN","TMGDEBUG",743,0) + quit +"RTN","TMGDEBUG",744,0) + +"RTN","TMGDEBUG",745,0) + +"RTN","TMGDEBUG",746,0) +WriteLine(Line) +"RTN","TMGDEBUG",747,0) + ;"Purpose: To actually write out labels for record starting and ending. +"RTN","TMGDEBUG",748,0) + ;"Input: Line -- The line of text to be written out. +"RTN","TMGDEBUG",749,0) + ;"Results: none. +"RTN","TMGDEBUG",750,0) + ;"Note: Used by DumpRec2 above, with callback from TMGXMLE2 +"RTN","TMGDEBUG",751,0) + +"RTN","TMGDEBUG",752,0) + write line +"RTN","TMGDEBUG",753,0) + quit +"RTN","TMGDEBUG",754,0) + +"RTN","TMGDEBUG",755,0) + +"RTN","TMGDEBUG",756,0) +WriteWPLine(Line) +"RTN","TMGDEBUG",757,0) + ;"Purpose: To actually write out line from WP field +"RTN","TMGDEBUG",758,0) + ;"Input: Line -- The line of text to be written out. +"RTN","TMGDEBUG",759,0) + ;"Results: none. +"RTN","TMGDEBUG",760,0) + ;"Note: Used by DumpRec2 above, with callback from TMGXMLE2 +"RTN","TMGDEBUG",761,0) + +"RTN","TMGDEBUG",762,0) + write line,! +"RTN","TMGDEBUG",763,0) + quit +"RTN","TMGDEBUG",764,0) + +"RTN","TMGMISC") +0^2^B4580543 +"RTN","TMGMISC",1,0) +TMGMISC ;TMG/kst/Misc utility library ;03/25/06; 5/24/10 +"RTN","TMGMISC",2,0) + ;;1.0;TMG-LIB;**1**;07/12/05;Build 1 +"RTN","TMGMISC",3,0) + +"RTN","TMGMISC",4,0) + ;"TMG MISCELLANEOUS FUNCTIONS +"RTN","TMGMISC",5,0) + ;"Kevin Toppenberg MD +"RTN","TMGMISC",6,0) + ;"GNU General Public License (GPL) applies +"RTN","TMGMISC",7,0) + ;"7-12-2005 +"RTN","TMGMISC",8,0) + +"RTN","TMGMISC",9,0) + ;"======================================================================= +"RTN","TMGMISC",10,0) + ;" API -- Public Functions. +"RTN","TMGMISC",11,0) + ;"======================================================================= +"RTN","TMGMISC",12,0) + ;"STARTRPC -- Start up RPCBroker on port 9210 +"RTN","TMGMISC",13,0) + ;"STOPRPC -- Stop RPCBroker on port 9210 +"RTN","TMGMISC",14,0) + ;"STOPTSKM -- Stop TaskMan non-interactively +"RTN","TMGMISC",15,0) + ;"EDITPT(AddOK) +"RTN","TMGMISC",16,0) + ;"GetPersonClass(PersonClass,ProviderType,Specialty) +"RTN","TMGMISC",17,0) + ;"$$DocLines(IEN,Chars) -- Count number of lines and chars in a 8925 WP field +"RTN","TMGMISC",18,0) + ;"$$WPChars(Ptr) +"RTN","TMGMISC",19,0) + ;"$$RoundUp(n) +"RTN","TMGMISC",20,0) + ;"$$RoundDn(n) +"RTN","TMGMISC",21,0) + ;"$$Round(n) +"RTN","TMGMISC",22,0) + ;"$$InList(Value,ArrayP) -- return if Value is in an array. +"RTN","TMGMISC",23,0) + ;"$$ListCt(pArray) +"RTN","TMGMISC",24,0) + ;"$$LISTCT(pArray) -- same as $$ListCt(pArray) +"RTN","TMGMISC",25,0) + ;"$$NodeCt(pArray) -- count all the nodes in an array +"RTN","TMGMISC",26,0) + ;"$$IndexOf(pArray,value) +"RTN","TMGMISC",27,0) + ;"ListPack(pArray,StartNum,IncValue) +"RTN","TMGMISC",28,0) + ;"ListAdd(pArray,index,value) +"RTN","TMGMISC",29,0) + ;"ListAnd(pArray1,pArray2,pResult) +"RTN","TMGMISC",30,0) + ;"ListNot(pArray1,pArray2,pResult) +"RTN","TMGMISC",31,0) + ;"$$DTFormat(FMDate,format) -- format fileman dates +"RTN","TMGMISC",32,0) + ;"$$CompDOB(DOB1,DOB2) -- compare two dates +"RTN","TMGMISC",33,0) + ;"BrowseBy(CompArray,ByTag) -- Allow a user to interact with dynamic text tree +"RTN","TMGMISC",34,0) + ;"$$CompName(Name1,Name2) -- compare two names +"RTN","TMGMISC",35,0) + ;"$$FormatName(Name) +"RTN","TMGMISC",36,0) + ;"$$HEXCHR(V) -- Take one BYTE and return HEX Values +"RTN","TMGMISC",37,0) + ;"$$HEXCHR2(n,digits) -- convert a number (of arbitrary length) to HEX digits +"RTN","TMGMISC",38,0) + ;"$$HEX2NUM(s) -- convert a string like this $10 to decimal number (e.g.) 16 +"RTN","TMGMISC",39,0) + ;"$$OR(a,b) ; perform a bitwise OR on operands a and b +"RTN","TMGMISC",40,0) + ;"ParsePos(pos,label,offset,routine,dmod) +"RTN","TMGMISC",41,0) + ;"ScanMod(Module,pArray) +"RTN","TMGMISC",42,0) + ;"ConvertPos(Pos,pArray) +"RTN","TMGMISC",43,0) + ;"CompArray(pArray1,pArray2) return if two arrays are identical +"RTN","TMGMISC",44,0) + ;"$$CompABArray(pArrayA,pArrayB,pOutArray) -- FULL compare of two arrays, return diffArray +"RTN","TMGMISC",45,0) + ;"$$IterTemplate(Template,Prior) +"RTN","TMGMISC",46,0) + ;"$$NumPieces(s,delim,maxPoss) -- return number of pieces in string +"RTN","TMGMISC",47,0) + ;"$$LastPiece(s,delim,maxPoss) -- return the last piece of a string +"RTN","TMGMISC",48,0) + ;"$$ParseLast(s,remainS,delim,maxPoss) -- return the last piece AND the first part of the string +"RTN","TMGMISC",49,0) + ;"$$Trim1Node(pRef) -- To shorten a reference by one node. +"RTN","TMGMISC",50,0) + ;"BROWSEASK -- ask user for the name of an array, then display nodes +"RTN","TMGMISC",51,0) + ;"BRWSASK2 -- Improved... Ask user for the name of an array, then display nodes +"RTN","TMGMISC",52,0) + ;"BROWSENODES(current,Order,paginate,countNodes) -- display nodes of specified array +"RTN","TMGMISC",53,0) + ;"BRWSNOD2(curRef,Order,countNodes) -- display nodes of specified array, using Scroll box +"RTN","TMGMISC",54,0) + ;"ShowNodes(pArray,order,paginate,countNodes) -- display all the nodes of the given array +"RTN","TMGMISC",55,0) + ;"ShowNod2(pArray,order,countNodes) -- display all the nodes of the given array, using Scroll box +"RTN","TMGMISC",56,0) + ;"$$IsNumeric(value) -- determine if value is pure numeric. +"RTN","TMGMISC",57,0) + ;"$$ClipDDigits(Num,digits) -- clip number to specified number of digits +"RTN","TMGMISC",58,0) + ;"LaunchScreenman(File,FormIEN,RecIEN,Page) -- launching point screenman form +"RTN","TMGMISC",59,0) + ;"$$NumSigChs --determine how many characters are signficant in a variable name +"RTN","TMGMISC",60,0) + ;"MkMultList(input,List) -- create a list of entries, given a string containing a list of entries. +"RTN","TMGMISC",61,0) + ;"MkRangeList(Num,EndNum,List) -- create a list of entries, given a starting and ending number +"RTN","TMGMISC",62,0) + ;"$$Caller(Code) -- From call stack, return the location of the caller of the function +"RTN","TMGMISC",63,0) + +"RTN","TMGMISC",64,0) + ;"======================================================================= +"RTN","TMGMISC",65,0) + ;"PRIVATE API FUNCTIONS +"RTN","TMGMISC",66,0) + ;"======================================================================= +"RTN","TMGMISC",67,0) + ;"GetPersonClass(PersonClass,ProviderType,Specialty) +"RTN","TMGMISC",68,0) + ;"ProcessToken(Token,Output) +"RTN","TMGMISC",69,0) + ;"$$IsSuffix(s) +"RTN","TMGMISC",70,0) + ;"$$IsTitle(s) +"RTN","TMGMISC",71,0) + ;"ShowBy(CompArray,ByTag,aOpen,bOpen,cOpen) +"RTN","TMGMISC",72,0) + ;"CtTemplate(Template) -- return the Count of IEN's stored in a SORT TEMPLATE +"RTN","TMGMISC",73,0) + +"RTN","TMGMISC",74,0) + ;"======================================================================= +"RTN","TMGMISC",75,0) + ;"DEPENDENCIES +"RTN","TMGMISC",76,0) + ;" TMGDBAPI +"RTN","TMGMISC",77,0) + ;" TMGIOUTL +"RTN","TMGMISC",78,0) + ;" TMGDEBUG +"RTN","TMGMISC",79,0) + ;" TMGSTUTL +"RTN","TMGMISC",80,0) + ;"======================================================================= +"RTN","TMGMISC",81,0) + ;"======================================================================= +"RTN","TMGMISC",82,0) + +"RTN","TMGMISC",83,0) +STARTRPC ; +"RTN","TMGMISC",84,0) + ;" -- Start up RPCBroker on port 9210 +"RTN","TMGMISC",85,0) + WRITE "Starting RPC Broker on port 9210",! +"RTN","TMGMISC",86,0) + DO STRT^XWBTCP(9210) +"RTN","TMGMISC",87,0) + WRITE ! +"RTN","TMGMISC",88,0) + QUIT +"RTN","TMGMISC",89,0) + ; +"RTN","TMGMISC",90,0) +STOPRPC ; +"RTN","TMGMISC",91,0) + ;" -- Stop RPC Broker on port 9210 +"RTN","TMGMISC",92,0) + WRITE "Stopping RPC Broker on port 9210",! +"RTN","TMGMISC",93,0) + DO STOP^XWBTCP(9210) +"RTN","TMGMISC",94,0) + WRITE ! +"RTN","TMGMISC",95,0) + QUIT +"RTN","TMGMISC",96,0) + ; +"RTN","TMGMISC",97,0) +STOPTSKM ; +"RTN","TMGMISC",98,0) + ;"-- Shut Down Task Managers non-interactively +"RTN","TMGMISC",99,0) + ;" Taken from STOP^ZTMKU +"RTN","TMGMISC",100,0) + ; +"RTN","TMGMISC",101,0) + WRITE !,"Shutting down TaskMan and submanagers." +"RTN","TMGMISC",102,0) + DO GROUP^ZTMKU("SMAN^ZTMKU(NODE)") +"RTN","TMGMISC",103,0) + DO GROUP^ZTMKU("SSUB^ZTMKU(NODE)") +"RTN","TMGMISC",104,0) + WRITE !,"Okay!",! +"RTN","TMGMISC",105,0) + QUIT +"RTN","TMGMISC",106,0) + ; +"RTN","TMGMISC",107,0) +EDITPT(TMGADDOK) +"RTN","TMGMISC",108,0) + ;"Purpose: To ask for a patient name, and then allow editing +"RTN","TMGMISC",109,0) + ;"Input: TMGADDOK: if 1, then adding new patients is allowed +"RTN","TMGMISC",110,0) + ;"Result: none +"RTN","TMGMISC",111,0) + ; +"RTN","TMGMISC",112,0) + DO LO^DGUTL +"RTN","TMGMISC",113,0) + SET DGCLPR="" +"RTN","TMGMISC",114,0) + NEW DGDIV SET DGDIV=$$PRIM^VASITE +"RTN","TMGMISC",115,0) + ; +"RTN","TMGMISC",116,0) + IF DGDIV>0 SET %ZIS("B")=$PIECE($get(^DG(40.8,+DGDIV,"DEV")),U,1) +"RTN","TMGMISC",117,0) + ; +"RTN","TMGMISC",118,0) + KILL %ZIS("B") +"RTN","TMGMISC",119,0) + IF '$data(DGIO),$PIECE(^DG(43,1,0),U,30) do +"RTN","TMGMISC",120,0) + . SET %ZIS="N",IOP="HOME" +"RTN","TMGMISC",121,0) + . DO ^%ZIS +"RTN","TMGMISC",122,0) + ; +"RTN","TMGMISC",123,0) +A DO ENDREG^DGREG($GET(DFN)) +"RTN","TMGMISC",124,0) + DO IF (Y<0) GOTO EDITDONE +"RTN","TMGMISC",125,0) + . WRITE !! +"RTN","TMGMISC",126,0) + . IF $GET(TMGADDOK)=1 DO +"RTN","TMGMISC",127,0) + . . SET DIC=2,DIC(0)="ALEQM" +"RTN","TMGMISC",128,0) + . . SET DLAYGO=2 +"RTN","TMGMISC",129,0) + . ELSE DO +"RTN","TMGMISC",130,0) + . . SET DIC=2,DIC(0)="AEQM" +"RTN","TMGMISC",131,0) + . . SET DLAYGO=0 +"RTN","TMGMISC",132,0) + . KILL DIC("S") +"RTN","TMGMISC",133,0) + . DO ^DIC +"RTN","TMGMISC",134,0) + . KILL DLAYGO +"RTN","TMGMISC",135,0) + . IF Y<0 QUIT +"RTN","TMGMISC",136,0) + . SET (DFN,DA)=+Y +"RTN","TMGMISC",137,0) + . SET DGNEW=$P(Y,"^",3) +"RTN","TMGMISC",138,0) + . NEW Y +"RTN","TMGMISC",139,0) + . DO PAUSE^DG10 +"RTN","TMGMISC",140,0) + . DO BEGINREG^DGREG(DFN) +"RTN","TMGMISC",141,0) + . IF DGNEW DO NEW^DGRP +"RTN","TMGMISC",142,0) + ; +"RTN","TMGMISC",143,0) + IF +$GET(DGNEW) DO +"RTN","TMGMISC",144,0) + . ;" query CMOR for Patient Record Flag Assignments if NEW patient and +"RTN","TMGMISC",145,0) + . ;" display results. +"RTN","TMGMISC",146,0) + . IF $$PRFQRY^DGPFAPI(DFN) DO DISPPRF^DGPFAPI(DFN) +"RTN","TMGMISC",147,0) + ; +"RTN","TMGMISC",148,0) + SET (DGFC,CURR)=0 +"RTN","TMGMISC",149,0) + SET DA=DFN +"RTN","TMGMISC",150,0) + SET DGFC="^1" +"RTN","TMGMISC",151,0) + SET VET=$SELECT($DATA(^DPT(DFN,"VET")):^("VET")'="Y",1:0) +"RTN","TMGMISC",152,0) + ; +"RTN","TMGMISC",153,0) + SET %ZIS="N",IOP="HOME" +"RTN","TMGMISC",154,0) + DO ^%ZIS +"RTN","TMGMISC",155,0) + SET DGELVER=0 +"RTN","TMGMISC",156,0) + ;"DO EN^DGRPD +"RTN","TMGMISC",157,0) + ;"IF $data(DGRPOUT) DO GOTO A +"RTN","TMGMISC",158,0) + ;". DO ENDREG^DGREG($G(DFN)) +"RTN","TMGMISC",159,0) + ;". DO HL7A08^VAFCDD01 +"RTN","TMGMISC",160,0) + ;". KILL DFN,DGRPOUT +"RTN","TMGMISC",161,0) + ; +"RTN","TMGMISC",162,0) + ;"DO HINQ^DG10 +"RTN","TMGMISC",163,0) + IF $D(^DIC(195.4,1,"UP")) IF ^("UP") DO ADM^RTQ3 +"RTN","TMGMISC",164,0) + ; +"RTN","TMGMISC",165,0) + DO REG^IVMCQ($G(DFN)) ;" send financial query +"RTN","TMGMISC",166,0) + ; +"RTN","TMGMISC",167,0) + SET DGRPV=0 +"RTN","TMGMISC",168,0) + DO EN1^DGRP +"RTN","TMGMISC",169,0) + ; +"RTN","TMGMISC",170,0) +EDITDONE +"RTN","TMGMISC",171,0) + IF $PIECE($GET(^VA(200,DUZ,"TMG")),"^",1)="C" DO +"RTN","TMGMISC",172,0) + . WRITE @IOF,! ;"clear screen if settings call for this. +"RTN","TMGMISC",173,0) + ; +"RTN","TMGMISC",174,0) + QUIT +"RTN","TMGMISC",175,0) + +"RTN","TMGMISC",176,0) + +"RTN","TMGMISC",177,0) +GetPersonClass(PersonClass,ProviderType,Specialty) +"RTN","TMGMISC",178,0) + ;"Purpose: To look through the PERSON CLASS file and find matching record +"RTN","TMGMISC",179,0) + ;"Input -- PersonClass -- a value to match against the .01 field (PROVIDER TYPE) +"RTN","TMGMISC",180,0) + ;" Behavioral Health and Social Service +"RTN","TMGMISC",181,0) + ;" Chiropractors +"RTN","TMGMISC",182,0) + ;" Dental Service +"RTN","TMGMISC",183,0) + ;" Dietary and Nutritional Service +"RTN","TMGMISC",184,0) + ;" Emergency Medical Service +"RTN","TMGMISC",185,0) + ;" Eye and Vision Services +"RTN","TMGMISC",186,0) + ;" Nursing Service +"RTN","TMGMISC",187,0) + ;" Nursing Service Related +"RTN","TMGMISC",188,0) + ;" Physicians (M.D. and D.O.) +"RTN","TMGMISC",189,0) + ;" etc. +"RTN","TMGMISC",190,0) + ;" -- ProviderType -- a value to match against the 1 field (CLASSIFICATION) +"RTN","TMGMISC",191,0) + ;" Physician/Osteopath +"RTN","TMGMISC",192,0) + ;" Resident, Allopathic (includes Interns, Residents, Fellows) +"RTN","TMGMISC",193,0) + ;" Psychologist +"RTN","TMGMISC",194,0) + ;" Neuropsychologist +"RTN","TMGMISC",195,0) + ;" etc. +"RTN","TMGMISC",196,0) + ;" -- Specialty -- a value to match against the 2 field (AREA OF SPECIALIZATION) +"RTN","TMGMISC",197,0) + ;"Output -- (via results) +"RTN","TMGMISC",198,0) + ;"Result -- Returns record number in PERSON CLASS file, OR 0 if not found +"RTN","TMGMISC",199,0) + +"RTN","TMGMISC",200,0) + new RecNum,Params +"RTN","TMGMISC",201,0) + +"RTN","TMGMISC",202,0) + set Params(0,"FILE")="PERSON CLASS" +"RTN","TMGMISC",203,0) + set Params(".01")=$get(PersonClass) +"RTN","TMGMISC",204,0) + set Params("1")=$get(ProviderType) +"RTN","TMGMISC",205,0) + set Params("2")=$get(Specialty) +"RTN","TMGMISC",206,0) + +"RTN","TMGMISC",207,0) + set RecNum=$$RecFind^TMGDBAPI(.Params) +"RTN","TMGMISC",208,0) + +"RTN","TMGMISC",209,0) +GPCDone +"RTN","TMGMISC",210,0) + quit RecNum +"RTN","TMGMISC",211,0) + +"RTN","TMGMISC",212,0) + +"RTN","TMGMISC",213,0) +DocLines(IEN,Chars) +"RTN","TMGMISC",214,0) + ;"Purpose: To count the number of lines and characters in a WP field +"RTN","TMGMISC",215,0) + ;" Initially it is targeted at entries in TIU DOCUMENT file. +"RTN","TMGMISC",216,0) + ;"Input: IEN -- the record number in TIU DOCUMENT to count +"RTN","TMGMISC",217,0) + ;" Chars -- and OUT parameter. PASS BY REFERENCE +"RTN","TMGMISC",218,0) + ;"Results: Returns number of lines, (with 1 decimal value) +"RTN","TMGMISC",219,0) + ;" Also will return character count in Chars, if passed by reference +"RTN","TMGMISC",220,0) + ;"NOte: This uses the Characters per line parameter value stored in +"RTN","TMGMISC",221,0) + ;" field .03 of TIU PARAMETERS (in ^TIU(8925.99)) +"RTN","TMGMISC",222,0) + +"RTN","TMGMISC",223,0) + if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"DocLines^TMGMISC") +"RTN","TMGMISC",224,0) + +"RTN","TMGMISC",225,0) + new CharsPerLine +"RTN","TMGMISC",226,0) + new LineCount set LineCount=0 +"RTN","TMGMISC",227,0) + set Chars=0 +"RTN","TMGMISC",228,0) + set CharsPerLine=+$piece($get(^TIU(8925.99,1,0)),"^",3) +"RTN","TMGMISC",229,0) + +"RTN","TMGMISC",230,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"CharsPerLine=",CharsPerLine) +"RTN","TMGMISC",231,0) + +"RTN","TMGMISC",232,0) + set WPPtr=$name(^TIU(8925,IEN,"TEXT")) +"RTN","TMGMISC",233,0) + set Chars=$$WPChars(WPPtr) +"RTN","TMGMISC",234,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Chars=",Chars) +"RTN","TMGMISC",235,0) + +"RTN","TMGMISC",236,0) + if CharsPerLine'=0 do +"RTN","TMGMISC",237,0) + . set LineCount=(((Chars/CharsPerLine)*10)\1)/10 +"RTN","TMGMISC",238,0) + . ;"new IntLC,LC,Delta +"RTN","TMGMISC",239,0) + . ;"set LC=Chars\CharsPerLine +"RTN","TMGMISC",240,0) + . ;"set IntLC=Chars\CharsPerLine ;" \ is integer divide +"RTN","TMGMISC",241,0) + . ;"set Delta=(LC-IntLC)*10 +"RTN","TMGMISC",242,0) + . i;"f Delta>4 set IntLC=IntLC+1 ;"Round to closest integer value. +"RTN","TMGMISC",243,0) + . ;"set LineCount=IntLC +"RTN","TMGMISC",244,0) + +"RTN","TMGMISC",245,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"LineCount=",LineCount) +"RTN","TMGMISC",246,0) + +"RTN","TMGMISC",247,0) + if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"DocLines^TMGMISC") +"RTN","TMGMISC",248,0) + quit LineCount +"RTN","TMGMISC",249,0) + +"RTN","TMGMISC",250,0) + +"RTN","TMGMISC",251,0) +WPChars(Ptr) +"RTN","TMGMISC",252,0) + ;"Purpose: To count the number of characters in the WP field +"RTN","TMGMISC",253,0) + ;" pointed to by the name stored in Ptr +"RTN","TMGMISC",254,0) + ;"Results: Returns number of characters, including spaces +"RTN","TMGMISC",255,0) + +"RTN","TMGMISC",256,0) + if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"WPChars^TMGMISC") +"RTN","TMGMISC",257,0) + +"RTN","TMGMISC",258,0) + new index +"RTN","TMGMISC",259,0) + new Chars set Chars=0 +"RTN","TMGMISC",260,0) + +"RTN","TMGMISC",261,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Ptr=",Ptr) +"RTN","TMGMISC",262,0) + set index=$order(@Ptr@(0)) +"RTN","TMGMISC",263,0) + for do quit:(index="") +"RTN","TMGMISC",264,0) + . if index="" quit +"RTN","TMGMISC",265,0) + . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"index='",index,"'") +"RTN","TMGMISC",266,0) + . ;"new s set s=$get(@Ptr@(index,0)) write "s=",s,! +"RTN","TMGMISC",267,0) + . set Chars=Chars+$length($get(@Ptr@(index,0))) +"RTN","TMGMISC",268,0) + . set index=$order(@Ptr@(index)) +"RTN","TMGMISC",269,0) + +"RTN","TMGMISC",270,0) + if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"WPChars^TMGMISC") +"RTN","TMGMISC",271,0) + +"RTN","TMGMISC",272,0) + quit Chars +"RTN","TMGMISC",273,0) + +"RTN","TMGMISC",274,0) + +"RTN","TMGMISC",275,0) + +"RTN","TMGMISC",276,0) +RoundUp(n) +"RTN","TMGMISC",277,0) + ;"SCOPE: PUBLIC +"RTN","TMGMISC",278,0) + ;"Purpose: find the next greatest integer after decimal value of n (round up) +"RTN","TMGMISC",279,0) + ;" 1.1 --> 2 +"RTN","TMGMISC",280,0) + ;" 1.0 --> 1 +"RTN","TMGMISC",281,0) + ;" -2.8 --> 2 +"RTN","TMGMISC",282,0) + ;"input: n -- decimal or integer value +"RTN","TMGMISC",283,0) + ;"output an integer, rounded up. +"RTN","TMGMISC",284,0) + +"RTN","TMGMISC",285,0) + new result +"RTN","TMGMISC",286,0) + set result=n\1 +"RTN","TMGMISC",287,0) + if result 1 +"RTN","TMGMISC",294,0) + ;" -2.2 --> -2 +"RTN","TMGMISC",295,0) + ;"input: n -- decimal or integer value +"RTN","TMGMISC",296,0) + ;"output an integer, rounded down. +"RTN","TMGMISC",297,0) + +"RTN","TMGMISC",298,0) + new result +"RTN","TMGMISC",299,0) + set result=n\1 +"RTN","TMGMISC",300,0) + quit result +"RTN","TMGMISC",301,0) + +"RTN","TMGMISC",302,0) +Round(n) +"RTN","TMGMISC",303,0) + ;"SCOPE: PUBLIC +"RTN","TMGMISC",304,0) + ;"Purpose: find the nearest integer from decimal value of n +"RTN","TMGMISC",305,0) + ;" for values 0.0-0.49 --> 0 +"RTN","TMGMISC",306,0) + ;" for values 0.5-0.99 --> 1 +"RTN","TMGMISC",307,0) + ;"input: n -- decimal or integer value +"RTN","TMGMISC",308,0) + ;"output an integer, rounded to nearest integer +"RTN","TMGMISC",309,0) + +"RTN","TMGMISC",310,0) + new result set result=n +"RTN","TMGMISC",311,0) + new decimal +"RTN","TMGMISC",312,0) + +"RTN","TMGMISC",313,0) + set decimal=+(n-(n\1)) +"RTN","TMGMISC",314,0) + if decimal<0.5 do +"RTN","TMGMISC",315,0) + . set result=$$RoundDn(n) +"RTN","TMGMISC",316,0) + else do +"RTN","TMGMISC",317,0) + . set result=$$RoundUp(n) +"RTN","TMGMISC",318,0) + +"RTN","TMGMISC",319,0) + quit result +"RTN","TMGMISC",320,0) + +"RTN","TMGMISC",321,0) + +"RTN","TMGMISC",322,0) +InList(Value,ArrayP) +"RTN","TMGMISC",323,0) + ;"SCOPE: PUBLIC +"RTN","TMGMISC",324,0) + ;"Purpose: To return if Value is in an array. Match must be exact (i.e. '=') +"RTN","TMGMISC",325,0) + ;"Input: Value -- the value to test for. Should not be an array +"RTN","TMGMISC",326,0) + ;" ArrayP -- the name of the array. e.g. ArrayP="MyArray(""Title"")" +"RTN","TMGMISC",327,0) + ;"Format of Array: It may be in one of two possible formats: +"RTN","TMGMISC",328,0) + ;" 1. MyArray("Title")=Value, or +"RTN","TMGMISC",329,0) + ;" 2. MyArray("Title")="*" <-- a signal that multiple values are given +"RTN","TMGMISC",330,0) + ;" MyArray("Title",1)=Value1 +"RTN","TMGMISC",331,0) + ;" MyArray("Title",2)=Value2 +"RTN","TMGMISC",332,0) + ;" The '1','2', etc may anything +"RTN","TMGMISC",333,0) + ;"Results: 1 if Value is in list, 0 if not +"RTN","TMGMISC",334,0) + +"RTN","TMGMISC",335,0) + new result set result=0 +"RTN","TMGMISC",336,0) + new index +"RTN","TMGMISC",337,0) + if ($get(ArrayP)'="")&($data(Value)=1) do +"RTN","TMGMISC",338,0) + . if @ArrayP'="*" set result=(@ArrayP=$get(Value)) quit +"RTN","TMGMISC",339,0) + . set index=$order(@ArrayP@("")) quit:(index="") +"RTN","TMGMISC",340,0) + . for do quit:(index="")!(result=1) +"RTN","TMGMISC",341,0) + . . if @ArrayP@(index)=Value set result=1 quit +"RTN","TMGMISC",342,0) + . . set index=$order(@ArrayP@(index)) +"RTN","TMGMISC",343,0) + +"RTN","TMGMISC",344,0) +ILDone +"RTN","TMGMISC",345,0) + quit result +"RTN","TMGMISC",346,0) + +"RTN","TMGMISC",347,0) + +"RTN","TMGMISC",348,0) + ;"IndexOf(pArray,value) +"RTN","TMGMISC",349,0) + ;" ;"SCOPE: PUBLIC +"RTN","TMGMISC",350,0) + ;" ;"Purpose: To scan array and return first index holding value +"RTN","TMGMISC",351,0) + ;" ;"Input: pArray -- PASS BY NAME. Array to scan, in format like this: +"RTN","TMGMISC",352,0) + ;" ;" @pArray@(1)=value1 +"RTN","TMGMISC",353,0) + ;" ;" @pArray@(2)=value2 +"RTN","TMGMISC",354,0) + ;" ;" @pArray@(3)=value3 +"RTN","TMGMISC",355,0) + ;" ;" @pArray@("some name index 1")=value4 +"RTN","TMGMISC",356,0) + ;" ;" @pArray@("some name index 2")=value5 +"RTN","TMGMISC",357,0) + ;" ;" value -- the value to search for +"RTN","TMGMISC",358,0) + ;" ;"results: returns the index holding the value +"RTN","TMGMISC",359,0) + ;" +"RTN","TMGMISC",360,0) + ;" new result set result="" +"RTN","TMGMISC",361,0) + ;" new done set done=0 +"RTN","TMGMISC",362,0) + ;" new index set index="" +"RTN","TMGMISC",363,0) + ;" for set index=$order(@pArray@(index)) quit:(index="")!(done=1) do +"RTN","TMGMISC",364,0) + ;" . set done=($get(@pArray@(index))=value) +"RTN","TMGMISC",365,0) + ;" . if done set result=index +"RTN","TMGMISC",366,0) + ;" +"RTN","TMGMISC",367,0) + ;"IODone quit result +"RTN","TMGMISC",368,0) + +"RTN","TMGMISC",369,0) +LISTCT(pArray) ;" SAAC complient entry point. +"RTN","TMGMISC",370,0) + quit $$ListCt(pArray) +"RTN","TMGMISC",371,0) +ListCt(pArray) +"RTN","TMGMISC",372,0) + ;"SCOPE: PUBLIC +"RTN","TMGMISC",373,0) + ;"Purpose: to count the number of entries in an array +"RTN","TMGMISC",374,0) + ;"Input: pArray -- PASS BY NAME. pointer to (name of) array to test. +"RTN","TMGMISC",375,0) + ;"Output: the number of entries at highest level +"RTN","TMGMISC",376,0) + ;" e.g. Array("TELEPHONE")=1234 +"RTN","TMGMISC",377,0) + ;" Array("CAR")=4764 +"RTN","TMGMISC",378,0) + ;" Array("DOG")=5213 +"RTN","TMGMISC",379,0) + ;" Array("DOG","COLLAR")=5213 <-- not highest level,not counted. +"RTN","TMGMISC",380,0) + ;" The above array would have a count of 3 +"RTN","TMGMISC",381,0) + ;"Results: returns count, or count up to point of any error +"RTN","TMGMISC",382,0) + new i,result set result=0 +"RTN","TMGMISC",383,0) + +"RTN","TMGMISC",384,0) + do +"RTN","TMGMISC",385,0) + . new $etrap +"RTN","TMGMISC",386,0) + . set $etrap="write ""?? Error Trapped ??"",! set $ECODE="""" quit" +"RTN","TMGMISC",387,0) + . set i=$order(@pArray@("")) +"RTN","TMGMISC",388,0) + . if i="" quit +"RTN","TMGMISC",389,0) + . for set result=result+1 set i=$order(@pArray@(i)) quit:i="" +"RTN","TMGMISC",390,0) + +"RTN","TMGMISC",391,0) + quit result +"RTN","TMGMISC",392,0) + +"RTN","TMGMISC",393,0) +NodeCt(pArray) +"RTN","TMGMISC",394,0) + ;"SCOPE: PUBLIC +"RTN","TMGMISC",395,0) + ;"Purpose: to count all the nodes in an array +"RTN","TMGMISC",396,0) + ;"Input: pArray -- PASS BY NAME. pointer to (name of) array to test. +"RTN","TMGMISC",397,0) + ;"Output: the number of entries at highest level +"RTN","TMGMISC",398,0) + ;" e.g. Array("TELEPHONE")=1234 +"RTN","TMGMISC",399,0) + ;" Array("CAR")=4764 +"RTN","TMGMISC",400,0) + ;" Array("DOG")=5213 +"RTN","TMGMISC",401,0) + ;" Array("DOG","COLLAR")=5213 <-- IS counted +"RTN","TMGMISC",402,0) + ;" The above array would have a count of 4 +"RTN","TMGMISC",403,0) + ;"Results: returns count, or count up to point of any error +"RTN","TMGMISC",404,0) + new result set result=0 +"RTN","TMGMISC",405,0) + for set pArray=$query(@pArray),result=result+1 quit:(pArray="") +"RTN","TMGMISC",406,0) + quit result +"RTN","TMGMISC",407,0) + +"RTN","TMGMISC",408,0) +IndexOf(pArray,value) +"RTN","TMGMISC",409,0) + ;"SCOPE: PUBLIC: +"RTN","TMGMISC",410,0) + ;"Purpose: To search through an array of keys and values, and return 1st index (i.e. key) of value +"RTN","TMGMISC",411,0) + ;"Input: pArray -- NAME OF array to search, format: +"RTN","TMGMISC",412,0) + ;" @pArray@(key1)=value1 +"RTN","TMGMISC",413,0) + ;" @pArray@(key2)=value2 +"RTN","TMGMISC",414,0) + ;" @pArray@(key3)=value3 +"RTN","TMGMISC",415,0) + ;" value -- the value to search for +"RTN","TMGMISC",416,0) + ;"Results: will return key for first found (based on $order sequence),or "" if not found +"RTN","TMGMISC",417,0) + +"RTN","TMGMISC",418,0) + new result set result="" +"RTN","TMGMISC",419,0) + new i set i="" +"RTN","TMGMISC",420,0) + new done set done=0 +"RTN","TMGMISC",421,0) + for set i=$order(@pArray@(i)) quit:(i="")!(done=1) do +"RTN","TMGMISC",422,0) + . if $get(@pArray@(i))=value set result=i,done=1 +"RTN","TMGMISC",423,0) + +"RTN","TMGMISC",424,0) + quit result +"RTN","TMGMISC",425,0) + +"RTN","TMGMISC",426,0) +ListPack(pArray,StartNum,IncValue) +"RTN","TMGMISC",427,0) + ;"SCOPE: PUBLIC +"RTN","TMGMISC",428,0) + ;"Purpose: to take an array with numeric ordering and pack values. +"RTN","TMGMISC",429,0) + ;" e.g. Array(3)="dog" +"RTN","TMGMISC",430,0) + ;" Array(5)="cat" +"RTN","TMGMISC",431,0) + ;" Array(75)="goat" +"RTN","TMGMISC",432,0) + ;" Will be pack as follows: +"RTN","TMGMISC",433,0) + ;" Array(1)="dog" +"RTN","TMGMISC",434,0) + ;" Array(2)="cat" +"RTN","TMGMISC",435,0) + ;" Array(3)="goat" +"RTN","TMGMISC",436,0) + ;"Input: pArray -- pointer to (NAME OF) array to pack. +"RTN","TMGMISC",437,0) + ;" StartNum -- OPTIONAL, default=1. Value to start numbering at +"RTN","TMGMISC",438,0) + ;" IncValue -- OPTIONAL, default=1. Amount to add to index value each time +"RTN","TMGMISC",439,0) + ;"Output: array will be altered +"RTN","TMGMISC",440,0) + ;"Results: none. +"RTN","TMGMISC",441,0) + ;"Notes: It is assumed that all of the indices are numeric +"RTN","TMGMISC",442,0) + ;" Nodes that are ALPHA (non-numeric) will be KILLED!! +"RTN","TMGMISC",443,0) + ;" If nodes have subnodes, they will be preserved. +"RTN","TMGMISC",444,0) + +"RTN","TMGMISC",445,0) + new TMGlpArray +"RTN","TMGMISC",446,0) + new i +"RTN","TMGMISC",447,0) + new count set count=$get(StartNum,1) +"RTN","TMGMISC",448,0) + set i=$order(@pArray@("")) +"RTN","TMGMISC",449,0) + if +i=i for do quit:(+i'=i) +"RTN","TMGMISC",450,0) + . merge TMGlpArray(count)=@pArray@(i) +"RTN","TMGMISC",451,0) + . set count=count+$get(IncValue,1) +"RTN","TMGMISC",452,0) + . set i=$order(@pArray@(i)) +"RTN","TMGMISC",453,0) + kill @pArray +"RTN","TMGMISC",454,0) + merge @pArray=TMGlpArray +"RTN","TMGMISC",455,0) + quit +"RTN","TMGMISC",456,0) + +"RTN","TMGMISC",457,0) + +"RTN","TMGMISC",458,0) +ListTrim(pArray,startIndex,endIndex,CountName) +"RTN","TMGMISC",459,0) + ;"SCOPE: PUBLIC +"RTN","TMGMISC",460,0) + ;"Purpose: Take a list with numeric (integer) ordering, and trim (kill) entry +"RTN","TMGMISC",461,0) + ;" items startIndex...endIndex +"RTN","TMGMISC",462,0) + ;"Input: pArray -- PASS BY NAME. The array to trim +"RTN","TMGMISC",463,0) + ;" startIndex -- the first index item to kill. Default=1 +"RTN","TMGMISC",464,0) + ;" endIndex -- the last index item to kill. Default=1 +"RTN","TMGMISC",465,0) + ;" CountName -- OPTIONAL. The name of a node that includes the +"RTN","TMGMISC",466,0) + ;" final count of remaining nodes. Default is "COUNT" +"RTN","TMGMISC",467,0) + ;"Output: Array items will be killed. Also, a node with the resulting count +"RTN","TMGMISC",468,0) + ;" of remaining items will be created, with name of CountName. e.g. +"RTN","TMGMISC",469,0) + ;" INPUT: startIndex=1, endIndex=4 +"RTN","TMGMISC",470,0) + ;" @pArray@(2)="grape" +"RTN","TMGMISC",471,0) + ;" @pArray@(3)="orange" +"RTN","TMGMISC",472,0) + ;" @pArray@(5)="apple" +"RTN","TMGMISC",473,0) + ;" @pArray@(7)="pear" +"RTN","TMGMISC",474,0) + ;" @pArray@(9)="peach" +"RTN","TMGMISC",475,0) + ;" +"RTN","TMGMISC",476,0) + ;" OUTPUT: +"RTN","TMGMISC",477,0) + ;" @pArray@(5)="apple" +"RTN","TMGMISC",478,0) + ;" @pArray@(7)="pear" +"RTN","TMGMISC",479,0) + ;" @pArray@(9)="peach" +"RTN","TMGMISC",480,0) + ;" @pArray@("COUNT")=3 +"RTN","TMGMISC",481,0) + +"RTN","TMGMISC",482,0) + set startIndex=$get(startIndex,1) +"RTN","TMGMISC",483,0) + set endIndex=$get(endIndex,1) +"RTN","TMGMISC",484,0) + set CountName=$get(CountName,"COUNT") +"RTN","TMGMISC",485,0) + kill @pArray@(CountName) +"RTN","TMGMISC",486,0) + new i for i=startIndex:1:endIndex kill @pArray@(i) +"RTN","TMGMISC",487,0) + do ListPack(pArray) +"RTN","TMGMISC",488,0) + set @pArray@(CountName)=$$ListCt(pArray) +"RTN","TMGMISC",489,0) + quit +"RTN","TMGMISC",490,0) + +"RTN","TMGMISC",491,0) + +"RTN","TMGMISC",492,0) +ListAdd(pArray,index,value) +"RTN","TMGMISC",493,0) + ;"SCOPE: PUBLIC +"RTN","TMGMISC",494,0) + ;"Purpose: To take a simple list and add to end of ist +"RTN","TMGMISC",495,0) + ;" e.g. Array("Apple")=75 +"RTN","TMGMISC",496,0) + ;" Array("Pear")=19 +"RTN","TMGMISC",497,0) + ;" +"RTN","TMGMISC",498,0) + ;" do ListAdd("Array","Grape",12) --> +"RTN","TMGMISC",499,0) + ;" +"RTN","TMGMISC",500,0) + ;" e.g. Array("Apple")=75 +"RTN","TMGMISC",501,0) + ;" Array("Pear")=19 +"RTN","TMGMISC",502,0) + ;" Array("Grape")=12 +"RTN","TMGMISC",503,0) + +"RTN","TMGMISC",504,0) + ;"Note: function creation aborted, because there is no intrinsic ordering in arrays. I.e. the above would actually +"RTN","TMGMISC",505,0) + ;" be in this order, as returned by $order(): +"RTN","TMGMISC",506,0) + ;" e.g. Array("Apple")=75 +"RTN","TMGMISC",507,0) + ;" Array("Grape")=12 <-- "G" comes before "P" alphabetically +"RTN","TMGMISC",508,0) + ;" Array("Pear")=19 +"RTN","TMGMISC",509,0) + +"RTN","TMGMISC",510,0) + ;"I'll leave this here as a reminder to myself next time. +"RTN","TMGMISC",511,0) + +"RTN","TMGMISC",512,0) + quit +"RTN","TMGMISC",513,0) + +"RTN","TMGMISC",514,0) + +"RTN","TMGMISC",515,0) +ListAnd(pArray1,pArray2,pResult) +"RTN","TMGMISC",516,0) + ;"Purpose: To take two lists, and create a third list that has only those entries that +"RTN","TMGMISC",517,0) + ;" exist in Array1 AND Array2 +"RTN","TMGMISC",518,0) + ;"Input: pArray1 : NAME OF array for list 1 +"RTN","TMGMISC",519,0) + ;" pArray2 : NAME OF array for list 2 +"RTN","TMGMISC",520,0) + ;" pResult : NAME OF array to results -- any preexisting entries will be killed +"RTN","TMGMISC",521,0) + ;"Note: only TOP LEVEL nodes are considered, and *value* for pArray1 use for combined value +"RTN","TMGMISC",522,0) + ;"E.g. of Use +"RTN","TMGMISC",523,0) + ;" @pArray1@("cat")="feline" +"RTN","TMGMISC",524,0) + ;" @pArray1@("dog")="canine" +"RTN","TMGMISC",525,0) + ;" @pArray1@("horse")="equinine" +"RTN","TMGMISC",526,0) + ;" @pArray1@("bird")="avian" +"RTN","TMGMISC",527,0) + ;" @pArray1@("bird","weight")=12 <--- will be ignored, not a top level node +"RTN","TMGMISC",528,0) + ;" +"RTN","TMGMISC",529,0) + ;" @pArray2@("hog")="porcine" +"RTN","TMGMISC",530,0) + ;" @pArray2@("horse")="equinine" +"RTN","TMGMISC",531,0) + ;" @pArray2@("cow")="bovine" +"RTN","TMGMISC",532,0) + ;" @pArray2@("bird")="flier" <----- note different value for key="bird" +"RTN","TMGMISC",533,0) + ;" +"RTN","TMGMISC",534,0) + ;" resulting list: +"RTN","TMGMISC",535,0) + ;" @pResult@("horse")="equinine" +"RTN","TMGMISC",536,0) + ;" @pResult@("bird")="avian" <-- note value from pArray1 used. +"RTN","TMGMISC",537,0) + +"RTN","TMGMISC",538,0) + new Result +"RTN","TMGMISC",539,0) + +"RTN","TMGMISC",540,0) + new i set i=$order(@pArray1@("")) +"RTN","TMGMISC",541,0) + if i'="" for do quit:(i="") +"RTN","TMGMISC",542,0) + . if $data(@pArray2@(i))#10 do +"RTN","TMGMISC",543,0) + . . set Result(i)=$get(@pArray1@(i)) +"RTN","TMGMISC",544,0) + . set i=$order(@pArray1@(i)) +"RTN","TMGMISC",545,0) + +"RTN","TMGMISC",546,0) + kill @pResult +"RTN","TMGMISC",547,0) + merge @pResult=Result +"RTN","TMGMISC",548,0) + +"RTN","TMGMISC",549,0) + quit +"RTN","TMGMISC",550,0) + +"RTN","TMGMISC",551,0) + +"RTN","TMGMISC",552,0) +ListNot(pArray1,pArray2,Verbose) +"RTN","TMGMISC",553,0) + ;"Purpose: To take two lists, and remove all entries from list 2 from list 1 +"RTN","TMGMISC",554,0) + ;" exist in Array1 NOT Array2 +"RTN","TMGMISC",555,0) + ;"Input: pArray1 : NAME OF array for list 1 +"RTN","TMGMISC",556,0) + ;" pArray2 : NAME OF array for list 2 +"RTN","TMGMISC",557,0) + ;" Verbose: OPTIONAL. if 1 then verbose output, progress bar etc. +"RTN","TMGMISC",558,0) + +"RTN","TMGMISC",559,0) + ;"Note: only TOP LEVEL nodes are considered, and +"RTN","TMGMISC",560,0) + ;" *value* for pArray1 use for combined value +"RTN","TMGMISC",561,0) + +"RTN","TMGMISC",562,0) + ;"E.g. of Use +"RTN","TMGMISC",563,0) + ;" list 1: +"RTN","TMGMISC",564,0) + ;" @pArray1@("cat")="feline" +"RTN","TMGMISC",565,0) + ;" @pArray1@("dog")="canine" +"RTN","TMGMISC",566,0) + ;" @pArray1@("horse")="equinine" +"RTN","TMGMISC",567,0) + ;" @pArray1@("bird")="avian" +"RTN","TMGMISC",568,0) + ;" @pArray1@("bird","weight")=12 <--- will be ignored, not a top level node +"RTN","TMGMISC",569,0) + ;" +"RTN","TMGMISC",570,0) + ;" list 2: +"RTN","TMGMISC",571,0) + ;" @pArray1@("cat")="feline" +"RTN","TMGMISC",572,0) + ;" @pArray1@("horse")="equinine" +"RTN","TMGMISC",573,0) + ;" +"RTN","TMGMISC",574,0) + ;" resulting list: +"RTN","TMGMISC",575,0) + ;" @pArray1@("dog")="canine" +"RTN","TMGMISC",576,0) + ;" @pArray1@("bird")="avian" +"RTN","TMGMISC",577,0) + ;" @pArray1@("bird","weight")=12 +"RTN","TMGMISC",578,0) + ;" +"RTN","TMGMISC",579,0) + +"RTN","TMGMISC",580,0) + new Itr,index +"RTN","TMGMISC",581,0) + set index=$$ItrAInit^TMGITR(pArray2,.Itr) +"RTN","TMGMISC",582,0) + if Verbose=1 do PrepProgress^TMGITR(.Itr,20,1,"index") +"RTN","TMGMISC",583,0) + if index'="" for do quit:($$ItrANext^TMGITR(.Itr,.index)="") +"RTN","TMGMISC",584,0) + . kill @pArray1@(i) +"RTN","TMGMISC",585,0) + +"RTN","TMGMISC",586,0) + quit +"RTN","TMGMISC",587,0) + +"RTN","TMGMISC",588,0) + +"RTN","TMGMISC",589,0) + ;"Note: Sometime, compare this function to $$DATE^TIULS ... I didn't know about this function before! +"RTN","TMGMISC",590,0) +DTFormat(FMDate,format,Array) +"RTN","TMGMISC",591,0) + ;"SCOPE: PUBLIC +"RTN","TMGMISC",592,0) + ;"Purpose: to allow custom formating of fileman dates in to text equivalents +"RTN","TMGMISC",593,0) + ;"Input: FMDate -- this is the date to work on, in Fileman Format +"RTN","TMGMISC",594,0) + ;" format -- a formating string with codes as follows. +"RTN","TMGMISC",595,0) + ;" yy -- 2 digit year +"RTN","TMGMISC",596,0) + ;" yyyy -- 4 digit year +"RTN","TMGMISC",597,0) + ;" m - month number without a leading 0. +"RTN","TMGMISC",598,0) + ;" mm -- 2 digit month number (01-12) +"RTN","TMGMISC",599,0) + ;" mmm - abreviated months (Jan,Feb,Mar etc.) +"RTN","TMGMISC",600,0) + ;" mmmm -- full names of months (January,February,March etc) +"RTN","TMGMISC",601,0) + ;" d -- the number of the day of the month (1-31) without a leading 0 +"RTN","TMGMISC",602,0) + ;" dd -- 2 digit number of the day of the month +"RTN","TMGMISC",603,0) + ;" w -- the numeric day of the week (1-7) +"RTN","TMGMISC",604,0) + ;" ww -- abreviated day of week (Mon,Tue,Wed) +"RTN","TMGMISC",605,0) + ;" www -- day of week (Monday,Tuesday,Wednesday) +"RTN","TMGMISC",606,0) + ;" h -- the number of the hour without a leading 0 (1-23) 24-hr clock mode +"RTN","TMGMISC",607,0) + ;" hh -- 2 digit number of the hour. 24-hr clock mode +"RTN","TMGMISC",608,0) + ;" H -- the number of the hour without a leading 0 (1-12) 12-hr clock mode +"RTN","TMGMISC",609,0) + ;" HH -- 2 digit number of the hour. 12-hr clock mode +"RTN","TMGMISC",610,0) + ;" # -- will display 'am' for hours 1-12 and 'pm' for hours 13-24 +"RTN","TMGMISC",611,0) + ;" M - the number of minutes with out a leading 0 +"RTN","TMGMISC",612,0) + ;" MM -- a 2 digit display of minutes +"RTN","TMGMISC",613,0) + ;" s - the number of seconds without a leading 0 +"RTN","TMGMISC",614,0) + ;" ss -- a 2 digit display of number of seconds. +"RTN","TMGMISC",615,0) + ;" allowed punctuation symbols-- ' ' : , / @ .;- (space, colon, comma, forward slash, at symbol,semicolon,period,hyphen) +"RTN","TMGMISC",616,0) + ;" 'text' is included as is, even if it is same as a formatting code +"RTN","TMGMISC",617,0) + ;" Other unexpected text will be ignored +"RTN","TMGMISC",618,0) + ;" +"RTN","TMGMISC",619,0) + ;" If a date value of 0 is found for a code, that code is ignored (except for min/sec) +"RTN","TMGMISC",620,0) + ;" +"RTN","TMGMISC",621,0) + ;" Examples: with FMDate=3050215.183000 (i.e. Feb 5, 2005 @ 18:30 0 sec) +"RTN","TMGMISC",622,0) + ;" "mmmm d,yyyy" --> "February 5,2005" +"RTN","TMGMISC",623,0) + ;" "mm d,yyyy" --> "Feb 5,2005" +"RTN","TMGMISC",624,0) + ;" "'Exactly' H:MM # 'on' mm/dd/yy" --> "Exactly 6:30 pm on 02/05/05" +"RTN","TMGMISC",625,0) + ;" "mm/dd/yyyy" --> "02/05/2005" +"RTN","TMGMISC",626,0) + ;" +"RTN","TMGMISC",627,0) + ;" Array -- OPTIONAL, if supplied, SHOULD BE PASSED BY REFERENCE +"RTN","TMGMISC",628,0) + ;" The array will be filled with data as follows: +"RTN","TMGMISC",629,0) + ;" Array(Token)=value for that token (ignores codes such as '/',':' ect) +"RTN","TMGMISC",630,0) + +"RTN","TMGMISC",631,0) + ;"Output: Text of date, as specified by above +"RTN","TMGMISC",632,0) + +"RTN","TMGMISC",633,0) + new result set result="" +"RTN","TMGMISC",634,0) + new Token set Token="" +"RTN","TMGMISC",635,0) + new LastToken set LastToken="" +"RTN","TMGMISC",636,0) + new ch set ch="" +"RTN","TMGMISC",637,0) + new LastCh set LastCh="" +"RTN","TMGMISC",638,0) + new InStr set InStr=0 +"RTN","TMGMISC",639,0) + new done set done=0 +"RTN","TMGMISC",640,0) + new i +"RTN","TMGMISC",641,0) + +"RTN","TMGMISC",642,0) + if $get(format)="" goto FDTDone +"RTN","TMGMISC",643,0) + if +$get(FMDate)=0 goto FDTDone +"RTN","TMGMISC",644,0) + +"RTN","TMGMISC",645,0) + for i=1:1:$length(format) do quit:done +"RTN","TMGMISC",646,0) + . set LastCh=ch +"RTN","TMGMISC",647,0) + . set ch=$extract(format,i) ;"get next char of format string. +"RTN","TMGMISC",648,0) + . if (ch'=LastCh)&(LastCh'="")&(InStr=0) do ProcessToken(FMDate,.Token,.result,.Array) +"RTN","TMGMISC",649,0) + . set Token=Token_ch +"RTN","TMGMISC",650,0) + . if ch="'" do quit +"RTN","TMGMISC",651,0) + . . if InStr do ProcessToken(FMDate,.Token,.result) +"RTN","TMGMISC",652,0) + . . set InStr='InStr ;"toggle In-String mode +"RTN","TMGMISC",653,0) + . if (i=$length(format)) do ProcessToken(FMDate,.Token,.result,.Array) +"RTN","TMGMISC",654,0) + +"RTN","TMGMISC",655,0) +FDTDone +"RTN","TMGMISC",656,0) + quit result +"RTN","TMGMISC",657,0) + +"RTN","TMGMISC",658,0) + +"RTN","TMGMISC",659,0) +ProcessToken(FMDate,Token,Output,Array) +"RTN","TMGMISC",660,0) + ;"SCOPE: PRIVATE +"RTN","TMGMISC",661,0) + ;"Purpose: To take tokens and build output following rules specified by DTFormat) +"RTN","TMGMISC",662,0) + ;"Input: FMDate -- the date to work with +"RTN","TMGMISC",663,0) + ;" Token -- SHOULD BE PASSED BY REFERENCE. The code as oulined in DTFormat +"RTN","TMGMISC",664,0) + ;" Output -- SHOULD BE PASSED BY REFERENCE. The cumulative output +"RTN","TMGMISC",665,0) + ;" Array -- OPTIONAL, if supplied, SHOULD BE PASSED BY REFERENCE +"RTN","TMGMISC",666,0) + ;" The array will be filled with data as follows: +"RTN","TMGMISC",667,0) + ;" Array(Token)=value for that token (ignores codes such as '/') +"RTN","TMGMISC",668,0) + +"RTN","TMGMISC",669,0) + +"RTN","TMGMISC",670,0) + if $extract(Token,1,1)="'" do goto PTDone +"RTN","TMGMISC",671,0) + . new Str set Str=$extract(Token,2,$length(Token)-1) +"RTN","TMGMISC",672,0) + . set Output=Output_Str +"RTN","TMGMISC",673,0) + +"RTN","TMGMISC",674,0) + if Token=" " set Output=Output_Token goto PTDone +"RTN","TMGMISC",675,0) + if Token="." set Output=Output_Token goto PTDone +"RTN","TMGMISC",676,0) + if Token=":" set Output=Output_Token goto PTDone +"RTN","TMGMISC",677,0) + if Token="/" set Output=Output_Token goto PTDone +"RTN","TMGMISC",678,0) + if Token=";" set Output=Output_Token goto PTDone +"RTN","TMGMISC",679,0) + if Token="," set Output=Output_Token goto PTDone +"RTN","TMGMISC",680,0) + if Token="-" set Output=Output_Token goto PTDone +"RTN","TMGMISC",681,0) + if Token="@" set Output=Output_Token goto PTDone +"RTN","TMGMISC",682,0) + +"RTN","TMGMISC",683,0) + if Token="yy" do goto PTDone +"RTN","TMGMISC",684,0) + . new Year set Year=+$extract(FMDate,1,3) +"RTN","TMGMISC",685,0) + . if Year=0 quit +"RTN","TMGMISC",686,0) + . set Year=+$extract(FMDate,2,3) +"RTN","TMGMISC",687,0) + . if Year<10 set Year="0"_Year +"RTN","TMGMISC",688,0) + . set Output=Output_Year +"RTN","TMGMISC",689,0) + . set Array(Token)=Year; +"RTN","TMGMISC",690,0) + +"RTN","TMGMISC",691,0) + if Token="yyyy" do goto PTDone +"RTN","TMGMISC",692,0) + . new Year set Year=+$extract(FMDate,1,3) +"RTN","TMGMISC",693,0) + . if Year>0 do +"RTN","TMGMISC",694,0) + . . set Year=Year+1700 +"RTN","TMGMISC",695,0) + . . set Output=Output_Year +"RTN","TMGMISC",696,0) + . . set Array(Token)=Year +"RTN","TMGMISC",697,0) + +"RTN","TMGMISC",698,0) + if Token="m" do goto PTDone +"RTN","TMGMISC",699,0) + . new Month set Month=+$extract(FMDate,4,5) +"RTN","TMGMISC",700,0) + . if Month>0 do +"RTN","TMGMISC",701,0) + . . set Output=Output_Month +"RTN","TMGMISC",702,0) + . . set Array(Token)=Month +"RTN","TMGMISC",703,0) + +"RTN","TMGMISC",704,0) + if Token="mm" do goto PTDone +"RTN","TMGMISC",705,0) + . new Month set Month=+$extract(FMDate,4,5) +"RTN","TMGMISC",706,0) + . if Month=0 quit +"RTN","TMGMISC",707,0) + . if Month<10 set Month="0"_Month +"RTN","TMGMISC",708,0) + . set Output=Output_Month +"RTN","TMGMISC",709,0) + . set Array(Token)=Month +"RTN","TMGMISC",710,0) + +"RTN","TMGMISC",711,0) + if Token="mmm" do goto PTDone +"RTN","TMGMISC",712,0) + . new Month set Month=+$extract(FMDate,4,5) +"RTN","TMGMISC",713,0) + . if Month=0 quit +"RTN","TMGMISC",714,0) + . else if Month=1 set Month="Jan" +"RTN","TMGMISC",715,0) + . else if Month=2 set Month="Feb" +"RTN","TMGMISC",716,0) + . else if Month=3 set Month="Mar" +"RTN","TMGMISC",717,0) + . else if Month=4 set Month="Apr" +"RTN","TMGMISC",718,0) + . else if Month=5 set Month="May" +"RTN","TMGMISC",719,0) + . else if Month=6 set Month="Jun" +"RTN","TMGMISC",720,0) + . else if Month=7 set Month="Jul" +"RTN","TMGMISC",721,0) + . else if Month=8 set Month="Aug" +"RTN","TMGMISC",722,0) + . else if Month=9 set Month="Sept" +"RTN","TMGMISC",723,0) + . else if Month=10 set Month="Oct" +"RTN","TMGMISC",724,0) + . else if Month=11 set Month="Nov" +"RTN","TMGMISC",725,0) + . else if Month=12 set Month="Dec" +"RTN","TMGMISC",726,0) + . if +Month=0 do +"RTN","TMGMISC",727,0) + . . set Output=Output_Month +"RTN","TMGMISC",728,0) + . . set Array(Token)=Month +"RTN","TMGMISC",729,0) + +"RTN","TMGMISC",730,0) + if Token="mmmm" do goto PTDone +"RTN","TMGMISC",731,0) + . new Month set Month=+$extract(FMDate,4,5) +"RTN","TMGMISC",732,0) + . if Month=0 quit +"RTN","TMGMISC",733,0) + . else if Month=1 set Month="January" +"RTN","TMGMISC",734,0) + . else if Month=2 set Month="February" +"RTN","TMGMISC",735,0) + . else if Month=3 set Month="March" +"RTN","TMGMISC",736,0) + . else if Month=4 set Month="April" +"RTN","TMGMISC",737,0) + . else if Month=5 set Month="May" +"RTN","TMGMISC",738,0) + . else if Month=6 set Month="June" +"RTN","TMGMISC",739,0) + . else if Month=7 set Month="July" +"RTN","TMGMISC",740,0) + . else if Month=8 set Month="August" +"RTN","TMGMISC",741,0) + . else if Month=9 set Month="September" +"RTN","TMGMISC",742,0) + . else if Month=10 set Month="October" +"RTN","TMGMISC",743,0) + . else if Month=11 set Month="November" +"RTN","TMGMISC",744,0) + . else if Month=12 set Month="December" +"RTN","TMGMISC",745,0) + . else if +Month=0 do +"RTN","TMGMISC",746,0) + . . set Output=Output_Month +"RTN","TMGMISC",747,0) + . . set Array(Token)=Month +"RTN","TMGMISC",748,0) + +"RTN","TMGMISC",749,0) + if Token="d" do goto PTDone +"RTN","TMGMISC",750,0) + . new Day set Day=+$extract(FMDate,6,7) +"RTN","TMGMISC",751,0) + . if Day>0 do +"RTN","TMGMISC",752,0) + . . set Output=Output_Day +"RTN","TMGMISC",753,0) + . . set Array(Token)=Day +"RTN","TMGMISC",754,0) + +"RTN","TMGMISC",755,0) + if Token="dd" do goto PTDone +"RTN","TMGMISC",756,0) + . new Day set Day=+$extract(FMDate,6,7) +"RTN","TMGMISC",757,0) + . if Day=0 quit +"RTN","TMGMISC",758,0) + . if Day<10 set Day="0"_Day +"RTN","TMGMISC",759,0) + . set Output=Output_Day +"RTN","TMGMISC",760,0) + . set Array(Token)=Day +"RTN","TMGMISC",761,0) + +"RTN","TMGMISC",762,0) + if Token="w" do goto PTDone +"RTN","TMGMISC",763,0) + . new DOW set DOW=$$DOW^XLFDT(FMDate,1) +"RTN","TMGMISC",764,0) + . if DOW>0 do +"RTN","TMGMISC",765,0) + . . set Output=Output_DOW +"RTN","TMGMISC",766,0) + . . set Array(Token)=DOW +"RTN","TMGMISC",767,0) + +"RTN","TMGMISC",768,0) + if Token="ww" do goto PTDone +"RTN","TMGMISC",769,0) + . new DOW set DOW=$$DOW^XLFDT(FMDate,1) +"RTN","TMGMISC",770,0) + . if (DOW<0)!(DOW>6) quit +"RTN","TMGMISC",771,0) + . if DOW=0 set DOW="Sun" +"RTN","TMGMISC",772,0) + . if DOW=1 set DOW="Mon" +"RTN","TMGMISC",773,0) + . if DOW=2 set DOW="Tue" +"RTN","TMGMISC",774,0) + . if DOW=3 set DOW="Wed" +"RTN","TMGMISC",775,0) + . if DOW=4 set DOW="Thur" +"RTN","TMGMISC",776,0) + . if DOW=5 set DOW="Fri" +"RTN","TMGMISC",777,0) + . if DOW=6 set DOW="Sat" +"RTN","TMGMISC",778,0) + . set Output=Output_DOW +"RTN","TMGMISC",779,0) + . set Array(Token)=DOW +"RTN","TMGMISC",780,0) + +"RTN","TMGMISC",781,0) + if Token="www" do goto PTDone +"RTN","TMGMISC",782,0) + . new DOW set DOW=$$DOW^XLFDT(FMDate) +"RTN","TMGMISC",783,0) + . if DOW'="day" do +"RTN","TMGMISC",784,0) + . . set Output=Output_DOW +"RTN","TMGMISC",785,0) + . . set Array(Token)=DOW +"RTN","TMGMISC",786,0) + +"RTN","TMGMISC",787,0) + if Token="h" do goto PTDone +"RTN","TMGMISC",788,0) + . new Hour set Hour=+$extract(FMDate,9,10) +"RTN","TMGMISC",789,0) + . if Hour>0 do +"RTN","TMGMISC",790,0) + . . set Output=Output_Hour +"RTN","TMGMISC",791,0) + . . set Array(Token)=Hour +"RTN","TMGMISC",792,0) + +"RTN","TMGMISC",793,0) + if Token="hh" do goto PTDone +"RTN","TMGMISC",794,0) + . new Hour set Hour=+$extract(FMDate,9,10) +"RTN","TMGMISC",795,0) + . if Hour=0 quit +"RTN","TMGMISC",796,0) + . if Hour<10 set Hour="0"_Hour +"RTN","TMGMISC",797,0) + . set Output=Output_Hour +"RTN","TMGMISC",798,0) + . set Array(Token)=Hour +"RTN","TMGMISC",799,0) + +"RTN","TMGMISC",800,0) + if Token="H" do goto PTDone +"RTN","TMGMISC",801,0) + . new Hour set Hour=+$extract(FMDate,9,10) +"RTN","TMGMISC",802,0) + . if Hour>12 set Hour=Hour-12 +"RTN","TMGMISC",803,0) + . if Hour>0 do +"RTN","TMGMISC",804,0) + . . set Output=Output_Hour +"RTN","TMGMISC",805,0) + . . set Array(Token)=Hour +"RTN","TMGMISC",806,0) + +"RTN","TMGMISC",807,0) + if Token="HH" do goto PTDone +"RTN","TMGMISC",808,0) + . new Hour set Hour=+$extract(FMDate,9,10) +"RTN","TMGMISC",809,0) + . if Hour=0 quit +"RTN","TMGMISC",810,0) + . if Hour>12 set Hour=Hour-12 +"RTN","TMGMISC",811,0) + . if Hour<10 set Hour="0"_Hour +"RTN","TMGMISC",812,0) + . set Output=Output_Hour +"RTN","TMGMISC",813,0) + . set Array(Token)=Hour +"RTN","TMGMISC",814,0) + +"RTN","TMGMISC",815,0) + if Token="#" do goto PTDone +"RTN","TMGMISC",816,0) + . new Hour set Hour=+$extract(FMDate,9,10) +"RTN","TMGMISC",817,0) + . new code +"RTN","TMGMISC",818,0) + . if Hour=0 quit +"RTN","TMGMISC",819,0) + . if Hour>12 set code="pm" +"RTN","TMGMISC",820,0) + . else set code="am" +"RTN","TMGMISC",821,0) + . set Output=Output_code +"RTN","TMGMISC",822,0) + . set Array(Token)=code +"RTN","TMGMISC",823,0) + +"RTN","TMGMISC",824,0) + new Min set Min=+$extract(FMDate,11,12) +"RTN","TMGMISC",825,0) + +"RTN","TMGMISC",826,0) + if Token="M" do goto PTDone +"RTN","TMGMISC",827,0) + . new Min set Min=+$extract(FMDate,11,12) +"RTN","TMGMISC",828,0) + . set Output=Output_Min +"RTN","TMGMISC",829,0) + . set Array(Token)=Min +"RTN","TMGMISC",830,0) + +"RTN","TMGMISC",831,0) + if Token="MM" do goto PTDone +"RTN","TMGMISC",832,0) + . new Min set Min=+$extract(FMDate,11,12) +"RTN","TMGMISC",833,0) + . if Min<10 set Min="0"_Min +"RTN","TMGMISC",834,0) + . set Output=Output_Min +"RTN","TMGMISC",835,0) + . set Array(Token)=Min +"RTN","TMGMISC",836,0) + +"RTN","TMGMISC",837,0) + if Token="s" do goto PTDone +"RTN","TMGMISC",838,0) + . new Sec set Sec=+$extract(FMDate,13,14) +"RTN","TMGMISC",839,0) + . set Output=Output_Sec +"RTN","TMGMISC",840,0) + . set Array(Token)=Sec +"RTN","TMGMISC",841,0) + +"RTN","TMGMISC",842,0) + if Token="ss" do goto PTDone +"RTN","TMGMISC",843,0) + . new Sec set Sec=+$extract(FMDate,13,14) +"RTN","TMGMISC",844,0) + . if Sec<10 set Sec="0"_Sec +"RTN","TMGMISC",845,0) + . set Output=Output_Sec +"RTN","TMGMISC",846,0) + . set Array(Token)=Sec +"RTN","TMGMISC",847,0) + +"RTN","TMGMISC",848,0) +PTDone +"RTN","TMGMISC",849,0) + set Token="" +"RTN","TMGMISC",850,0) + quit +"RTN","TMGMISC",851,0) + +"RTN","TMGMISC",852,0) + +"RTN","TMGMISC",853,0) + +"RTN","TMGMISC",854,0) + +"RTN","TMGMISC",855,0) +CompDOB(DOB1,DOB2) +"RTN","TMGMISC",856,0) + ;"Purpose: to compare two DOB and return if they match, or are similar +"RTN","TMGMISC",857,0) + ;"Input: DOB1,DOB2 -- the two values to compare (in external format) +"RTN","TMGMISC",858,0) + ;"Result: 0 - no similarity or equality +"RTN","TMGMISC",859,0) + ;" 0.25 - doubt similarity +"RTN","TMGMISC",860,0) + ;" 0.50 - possible similarity +"RTN","TMGMISC",861,0) + ;" 0.75 - probable similarity +"RTN","TMGMISC",862,0) + ;" 1 - exact match +"RTN","TMGMISC",863,0) + ;"Note: I made this function because during lookups, I would get failures with data such as: +"RTN","TMGMISC",864,0) + ;" WILLIAM,JOHN G JR 05-21-60 +"RTN","TMGMISC",865,0) + ;" WILLIAM,JOHN G JR 05-11-60 <-- date differs by one digit. +"RTN","TMGMISC",866,0) + ;"Rules for comparision +"RTN","TMGMISC",867,0) + ;" if dates differ by 1 digit --> score of 0.75 +"RTN","TMGMISC",868,0) + ;" if dates differ by an absolute difference of < 1 months --> 0.75 +"RTN","TMGMISC",869,0) + ;" if dates differ by an absolute difference of < 6 months --> 0.50 +"RTN","TMGMISC",870,0) + ;" if dates differ by an absolute difference of < 1 year --> 0.25 +"RTN","TMGMISC",871,0) + ;" if dates differ by 2 digits --> 0.25 +"RTN","TMGMISC",872,0) + +"RTN","TMGMISC",873,0) + new DT1,DT2 +"RTN","TMGMISC",874,0) + new result set result=0 +"RTN","TMGMISC",875,0) + +"RTN","TMGMISC",876,0) + new %DT +"RTN","TMGMISC",877,0) + set X=DOB1 do ^%DT set DT1=Y ;"convert into internal format to avoid format snafu's +"RTN","TMGMISC",878,0) + set X=DOB2 do ^%DT set DT2=Y +"RTN","TMGMISC",879,0) + +"RTN","TMGMISC",880,0) + new DT1array,DT2array +"RTN","TMGMISC",881,0) + new temp +"RTN","TMGMISC",882,0) + if DT1=DT2 set result=1 goto CDOBDone +"RTN","TMGMISC",883,0) + +"RTN","TMGMISC",884,0) + set temp=$$DTFormat^TMGMISC(DT1,"mm/dd/yy",.DT1array) ;"parse date parts into array. +"RTN","TMGMISC",885,0) + set temp=$$DTFormat^TMGMISC(DT2,"mm/dd/yy",.DT2array) +"RTN","TMGMISC",886,0) + +"RTN","TMGMISC",887,0) + ;"Compare digits +"RTN","TMGMISC",888,0) + new NumDif set NumDif=0 +"RTN","TMGMISC",889,0) + new dg1,dg2 +"RTN","TMGMISC",890,0) + +"RTN","TMGMISC",891,0) + set dg1=$extract($get(DT1array("dd")),1,1) set dg2=$extract($get(DT2array("dd")),1,1) +"RTN","TMGMISC",892,0) + if dg1'=dg2 set NumDif=NumDif+1 +"RTN","TMGMISC",893,0) + set dg1=$extract($get(DT1array("dd")),2,2) set dg2=$extract($get(DT2array("dd")),2,2) +"RTN","TMGMISC",894,0) + if dg1'=dg2 set NumDif=NumDif+1 +"RTN","TMGMISC",895,0) + +"RTN","TMGMISC",896,0) + set dg1=$extract($get(DT1array("mm")),1,1) set dg2=$extract($get(DT2array("mm")),1,1) +"RTN","TMGMISC",897,0) + if dg1'=dg2 set NumDif=NumDif+1 +"RTN","TMGMISC",898,0) + set dg1=$extract($get(DT1array("mm")),2,2) set dg2=$extract($get(DT2array("mm")),2,2) +"RTN","TMGMISC",899,0) + if dg1'=dg2 set NumDif=NumDif+1 +"RTN","TMGMISC",900,0) + +"RTN","TMGMISC",901,0) + set dg1=$extract($get(DT1array("yy")),1,1) set dg2=$extract($get(DT2array("yy")),1,1) +"RTN","TMGMISC",902,0) + if dg1'=dg2 set NumDif=NumDif+1 +"RTN","TMGMISC",903,0) + set dg1=$extract($get(DT1array("yy")),2,2) set dg2=$extract($get(DT2array("yy")),2,2) +"RTN","TMGMISC",904,0) + if dg1'=dg2 set NumDif=NumDif+1 +"RTN","TMGMISC",905,0) + +"RTN","TMGMISC",906,0) + if NumDif=1 set result=0.75 goto CDOBDone +"RTN","TMGMISC",907,0) + if NumDif=2 set result=0.50 +"RTN","TMGMISC",908,0) + +"RTN","TMGMISC",909,0) + ;"Compare absolute date +"RTN","TMGMISC",910,0) + new H1,H2,DateDif +"RTN","TMGMISC",911,0) + set H1=$$FMTH^XLFDT(DT1,1) +"RTN","TMGMISC",912,0) + set H2=$$FMTH^XLFDT(DT2,1) +"RTN","TMGMISC",913,0) + set DateDif=$$HDIFF^XLFDT(H1,H2,1) ;"1=results in 'days' +"RTN","TMGMISC",914,0) + if $$HDIFF^XLFDT(H2,H1)>DateDif set DateDif=$$HDIFF^XLFDT(H2,H1) +"RTN","TMGMISC",915,0) + +"RTN","TMGMISC",916,0) + new score set score=0 +"RTN","TMGMISC",917,0) + if DateDif<30 set score=0.75 +"RTN","TMGMISC",918,0) + if DateDif<(30*6) set score=0.50 +"RTN","TMGMISC",919,0) + if DateDif<365 set score=0.25 +"RTN","TMGMISC",920,0) + +"RTN","TMGMISC",921,0) + if score>result set result=score +"RTN","TMGMISC",922,0) + +"RTN","TMGMISC",923,0) +CDOBDone +"RTN","TMGMISC",924,0) + quit result +"RTN","TMGMISC",925,0) + +"RTN","TMGMISC",926,0) + +"RTN","TMGMISC",927,0) + +"RTN","TMGMISC",928,0) +BrowseBy(CompArray,ByTag) +"RTN","TMGMISC",929,0) + ;"Purpose: Allow a user to interact with dynamic text tree +"RTN","TMGMISC",930,0) + ;" that will open and close nodes. +"RTN","TMGMISC",931,0) + ;"Input: CompArray -- array to browse. Should be in this format +"RTN","TMGMISC",932,0) + ;" CompArray("opening tag",a,b,c,d) +"RTN","TMGMISC",933,0) + ;" ByTag -- the name to use in for "opening tag") +"RTN","TMGMISC",934,0) + +"RTN","TMGMISC",935,0) + new aOpen set aOpen=0 +"RTN","TMGMISC",936,0) + new bOpen set bOpen=0 +"RTN","TMGMISC",937,0) + new cOpen set cOpen=0 +"RTN","TMGMISC",938,0) + +"RTN","TMGMISC",939,0) + new done set done=0 +"RTN","TMGMISC",940,0) + new input +"RTN","TMGMISC",941,0) + +"RTN","TMGMISC",942,0) + for do quit:(done=1) +"RTN","TMGMISC",943,0) + . do ShowBy(.CompArray,ByTag,aOpen,bOpen,cOpen) +"RTN","TMGMISC",944,0) + . read "Enter option:",input:$get(DTIME,3600),! +"RTN","TMGMISC",945,0) + . if input="" set input=0 +"RTN","TMGMISC",946,0) + . if +input>0 do +"RTN","TMGMISC",947,0) + . . if aOpen=0 do +"RTN","TMGMISC",948,0) + . . . set aOpen=input,bOpen=0,cOpen=0 +"RTN","TMGMISC",949,0) + . . else if bOpen=0 do +"RTN","TMGMISC",950,0) + . . . set bOpen=input,cOpen=0 +"RTN","TMGMISC",951,0) + . . else if cOpen=0 set cOpen=input +"RTN","TMGMISC",952,0) + . else if input=0 do +"RTN","TMGMISC",953,0) + . . if cOpen'=0 set cOpen=0 quit +"RTN","TMGMISC",954,0) + . . if bOpen'=0 set bOpen=0 quit +"RTN","TMGMISC",955,0) + . . set aOpen=0 +"RTN","TMGMISC",956,0) + . else if input="^" set done=1 +"RTN","TMGMISC",957,0) + +"RTN","TMGMISC",958,0) + quit +"RTN","TMGMISC",959,0) + +"RTN","TMGMISC",960,0) + +"RTN","TMGMISC",961,0) +ShowBy(CompArray,ByTag,aOpen,bOpen,cOpen) +"RTN","TMGMISC",962,0) + +"RTN","TMGMISC",963,0) + new a,b,c,d +"RTN","TMGMISC",964,0) + new acount set acount=0 +"RTN","TMGMISC",965,0) + new bcount set bcount=0 +"RTN","TMGMISC",966,0) + new ccount set ccount=0 +"RTN","TMGMISC",967,0) + new dcount set dcount=0 +"RTN","TMGMISC",968,0) + +"RTN","TMGMISC",969,0) + write # +"RTN","TMGMISC",970,0) + +"RTN","TMGMISC",971,0) + set a=$order(CompArray(ByTag,"")) +"RTN","TMGMISC",972,0) + if a'="" for do quit:(a="") +"RTN","TMGMISC",973,0) + . set acount=acount+1 +"RTN","TMGMISC",974,0) + . new nexta set nexta=$order(CompArray(ByTag,a)) +"RTN","TMGMISC",975,0) + . new Aindent +"RTN","TMGMISC",976,0) + . if (aOpen=0) do +"RTN","TMGMISC",977,0) + . . if acount<10 write "0" +"RTN","TMGMISC",978,0) + . . write acount,". " +"RTN","TMGMISC",979,0) + . else write "... " +"RTN","TMGMISC",980,0) + . write a,! +"RTN","TMGMISC",981,0) + . set b=$order(CompArray(ByTag,a,"")) +"RTN","TMGMISC",982,0) + . if (aOpen=acount)&(b'="") for do quit:(b="") +"RTN","TMGMISC",983,0) + . . set bcount=bcount+1 +"RTN","TMGMISC",984,0) + . . new nextb set nextb=$order(CompArray(ByTag,a,b)) +"RTN","TMGMISC",985,0) + . . new Bindent +"RTN","TMGMISC",986,0) + . . write " +--" +"RTN","TMGMISC",987,0) + . . if (bOpen=0) do +"RTN","TMGMISC",988,0) + . . . if bcount<10 write "0" +"RTN","TMGMISC",989,0) + . . . write bcount,". " +"RTN","TMGMISC",990,0) + . . else write "... " +"RTN","TMGMISC",991,0) + . . write b,! +"RTN","TMGMISC",992,0) + . . if nextb'="" set Aindent=" | " +"RTN","TMGMISC",993,0) + . . else set Aindent=" " +"RTN","TMGMISC",994,0) + . . set c=$order(CompArray(ByTag,a,b,"")) +"RTN","TMGMISC",995,0) + . . if (bOpen=bcount)&(c'="") for do quit:(c="") +"RTN","TMGMISC",996,0) + . . . set ccount=ccount+1 +"RTN","TMGMISC",997,0) + . . . new nextc set nextc=$order(CompArray(ByTag,a,b,c)) +"RTN","TMGMISC",998,0) + . . . if nextc'="" set Bindent=" | " +"RTN","TMGMISC",999,0) + . . . else set Bindent=" " +"RTN","TMGMISC",1000,0) + . . . write Aindent," +--" +"RTN","TMGMISC",1001,0) + . . . if (cOpen=0) do +"RTN","TMGMISC",1002,0) + . . . . if ccount<10 write "0" +"RTN","TMGMISC",1003,0) + . . . . write ccount,". " +"RTN","TMGMISC",1004,0) + . . . else write "... " +"RTN","TMGMISC",1005,0) + . . . write c,! +"RTN","TMGMISC",1006,0) + . . . set d=$order(CompArray(ByTag,a,b,c,"")) +"RTN","TMGMISC",1007,0) + . . . if (cOpen=ccount)&(d'="") for do quit:(d="") +"RTN","TMGMISC",1008,0) + . . . . set dcount=dcount+1 +"RTN","TMGMISC",1009,0) + . . . . write Aindent,Bindent," +-- " +"RTN","TMGMISC",1010,0) + . . . . if dcount<10 write "0" +"RTN","TMGMISC",1011,0) + . . . . write dcount,". " +"RTN","TMGMISC",1012,0) + . . . . write d,! +"RTN","TMGMISC",1013,0) + . . . . set d=$order(CompArray(ByTag,a,b,c,d)) +"RTN","TMGMISC",1014,0) + . . . set c=nextc +"RTN","TMGMISC",1015,0) + . . set b=nextb +"RTN","TMGMISC",1016,0) + . set a=nexta +"RTN","TMGMISC",1017,0) + +"RTN","TMGMISC",1018,0) +SBDone +"RTN","TMGMISC",1019,0) + quit +"RTN","TMGMISC",1020,0) + +"RTN","TMGMISC",1021,0) + +"RTN","TMGMISC",1022,0) + +"RTN","TMGMISC",1023,0) +CompName(Name1,Name2) +"RTN","TMGMISC",1024,0) + ;"Purpose: To compare two names, to see if they are the name, or compatible. +"RTN","TMGMISC",1025,0) + ;" e.g. WILLIAMS,J BILL vs. WILLAMS,JOHN BILL, vs. WILLIAMS,JOHN B +"RTN","TMGMISC",1026,0) + ;"Input: Two names to compare +"RTN","TMGMISC",1027,0) + ;"Result: 0 -- if entries conflict +"RTN","TMGMISC",1028,0) + ;" 0.5 -- if entries are consistent (i.e. in example above) +"RTN","TMGMISC",1029,0) + ;" 1 -- if entries completely match +"RTN","TMGMISC",1030,0) + ;"Note: This function WILL IGNORE a suffix. This is because +"RTN","TMGMISC",1031,0) + ;" WILLIAM,BILL 5-1-1950 +"RTN","TMGMISC",1032,0) + ;" WILLIAM,BILL SR 5-1-1950 +"RTN","TMGMISC",1033,0) + ;" would be considered the same person (the date is the determining factor) +"RTN","TMGMISC",1034,0) + ;"Rules: Last names must completely match or --> 0 +"RTN","TMGMISC",1035,0) + ;" If name is exactly the same, then --> 1 +"RTN","TMGMISC",1036,0) + ;" Initial must be same as first letters in name (e.g. N vs. NEWTON) --> 0.5 +"RTN","TMGMISC",1037,0) + +"RTN","TMGMISC",1038,0) + new result set result=1 +"RTN","TMGMISC",1039,0) + +"RTN","TMGMISC",1040,0) + new NArray1,NArray2,TMGMsg +"RTN","TMGMISC",1041,0) + +"RTN","TMGMISC",1042,0) + set Name1=$$FormatName(Name1,1) ;"should convert to standard format. +"RTN","TMGMISC",1043,0) + set Name2=$$FormatName(Name2,1) +"RTN","TMGMISC",1044,0) + +"RTN","TMGMISC",1045,0) + do STDNAME^XLFNAME(.Name1,"C",.TMGMsg) +"RTN","TMGMISC",1046,0) + do STDNAME^XLFNAME(.Name1,"C",.TMGMsg) ;"Doing a second time will ensure Array not in initial format. +"RTN","TMGMISC",1047,0) + +"RTN","TMGMISC",1048,0) + do STDNAME^XLFNAME(.Name2,"C",.TMGMsg) +"RTN","TMGMISC",1049,0) + do STDNAME^XLFNAME(.Name2,"C",.TMGMsg) ;"Doing a second time will ensure Array not in initial format. +"RTN","TMGMISC",1050,0) + +"RTN","TMGMISC",1051,0) + if Name1=Name2 set result=1 goto CompNDone +"RTN","TMGMISC",1052,0) + if Name1("FAMILY")'=Name2("FAMILY") do goto:(result=0) CompNDone +"RTN","TMGMISC",1053,0) + . if $$EN^XUA4A71(Name1("FAMILY"))'=$$EN^XUA4A71(Name2("FAMILY")) set result=0 ;"check soundex equality +"RTN","TMGMISC",1054,0) + +"RTN","TMGMISC",1055,0) + if Name1("GIVEN")'=Name2("GIVEN") do +"RTN","TMGMISC",1056,0) + . if $$EN^XUA4A71(Name1("GIVEN"))=$$EN^XUA4A71(Name2("GIVEN")) quit ;"check soundex equality +"RTN","TMGMISC",1057,0) + . new n1,n2 +"RTN","TMGMISC",1058,0) + . set n1=Name1("GIVEN") +"RTN","TMGMISC",1059,0) + . set n2=Name2("GIVEN") +"RTN","TMGMISC",1060,0) + . if $length(n2)<$length(n1) do ;"ensure length n2>n1 +"RTN","TMGMISC",1061,0) + . . new temp set temp=n2 +"RTN","TMGMISC",1062,0) + . . set n2=n1,n1=temp +"RTN","TMGMISC",1063,0) + . if $extract(n2,1,$length(n1))=n1 set result=0.5 +"RTN","TMGMISC",1064,0) + . else set result=0 +"RTN","TMGMISC",1065,0) + if result=0 goto CompNDone +"RTN","TMGMISC",1066,0) + +"RTN","TMGMISC",1067,0) + if Name1("MIDDLE")'=Name2("MIDDLE") do +"RTN","TMGMISC",1068,0) + . if $$EN^XUA4A71(Name1("MIDDLE"))=$$EN^XUA4A71(Name2("MIDDLE")) quit ;"check soundex equality +"RTN","TMGMISC",1069,0) + . new n1,n2 +"RTN","TMGMISC",1070,0) + . set n1=Name1("MIDDLE") +"RTN","TMGMISC",1071,0) + . set n2=Name2("MIDDLE") +"RTN","TMGMISC",1072,0) + . if $length(n2)<$length(n1) do ;"ensure length n2>n1 +"RTN","TMGMISC",1073,0) + . . new temp set temp=n2 +"RTN","TMGMISC",1074,0) + . . set n2=n1,n1=temp +"RTN","TMGMISC",1075,0) + . if $extract(n2,1,$length(n1))=n1 set result=0.5 +"RTN","TMGMISC",1076,0) + . else set result=0 +"RTN","TMGMISC",1077,0) + if result=0 goto CompNDone +"RTN","TMGMISC",1078,0) + +"RTN","TMGMISC",1079,0) +CompNDone +"RTN","TMGMISC",1080,0) + quit result +"RTN","TMGMISC",1081,0) + +"RTN","TMGMISC",1082,0) + +"RTN","TMGMISC",1083,0) + +"RTN","TMGMISC",1084,0) +FormatName(Name,CutTitle) +"RTN","TMGMISC",1085,0) + ;"Purpose: To ensure patient name is properly formated. +"RTN","TMGMISC",1086,0) + ;" i.e. John G. Doe --> DOE,JOHN G +"RTN","TMGMISC",1087,0) + ;" John G. Doe III --> DOE,JOHN G III +"RTN","TMGMISC",1088,0) + ;" John G. Doe,III --> DOE,JOHN G III +"RTN","TMGMISC",1089,0) + ;" Doe, John G --> DOE,JOHN G +"RTN","TMGMISC",1090,0) + ;" Doe,John g.,III, phd --> DOE,JOHN G III PHD +"RTN","TMGMISC",1091,0) + ;"Input: Name -- the name to be reformated +"RTN","TMGMISC",1092,0) + ;" CutTitle -- OPTIONAL -- if 1, then titles (e.g. MD, PhD etc) will be cut +"RTN","TMGMISC",1093,0) + ;"Results: returns properly formated name +"RTN","TMGMISC",1094,0) + ;"Note: If Name is passed by reference, it will be changed +"RTN","TMGMISC",1095,0) + ;" Also, NO lookup is done in database to ensure name exists +"RTN","TMGMISC",1096,0) + +"RTN","TMGMISC",1097,0) + ;"Note: this function malfunctioned on a patient with name like this: +"RTN","TMGMISC",1098,0) + ;" JOHN A VAN DER BON --> BON,JOHN A VAN DER (should be VAN DER BON,JOHN A) +"RTN","TMGMISC",1099,0) + ;" I don't have a quick for this right now... +"RTN","TMGMISC",1100,0) + ;"Also, Sue St. Clair --> CLAIR,SUE ST this is also wrong. +"RTN","TMGMISC",1101,0) + +"RTN","TMGMISC",1102,0) + ;"FYI: do STDNAME^XLFNAME(.NAME,FLAGS,.ERRARRAY) can also do standardization, +"RTN","TMGMISC",1103,0) + ;" and also parse to component parts. It specifically address the St. Clair issue. +"RTN","TMGMISC",1104,0) + +"RTN","TMGMISC",1105,0) + if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"FormatName^TMGGDFN") +"RTN","TMGMISC",1106,0) + +"RTN","TMGMISC",1107,0) + new NameArray +"RTN","TMGMISC",1108,0) + new MaxNode +"RTN","TMGMISC",1109,0) + new Suffix set Suffix="" +"RTN","TMGMISC",1110,0) + new i,s,lname +"RTN","TMGMISC",1111,0) + new fname set fname="" +"RTN","TMGMISC",1112,0) + new result set result="" +"RTN","TMGMISC",1113,0) + if $data(Name)#10=0 goto FormatNDone +"RTN","TMGMISC",1114,0) + +"RTN","TMGMISC",1115,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Person's name initially is: '",Name,"'") +"RTN","TMGMISC",1116,0) + set Name=$translate(Name,"*.","") ;"cleans off any *'s or .'s from initials etc. +"RTN","TMGMISC",1117,0) + if Name[", " do +"RTN","TMGMISC",1118,0) + . new s1,s2 +"RTN","TMGMISC",1119,0) + . set s1=$piece(Name,", ",1) +"RTN","TMGMISC",1120,0) + . set s2=$piece(Name,", ",2) +"RTN","TMGMISC",1121,0) + . if $$IsTitle($$UP^XLFSTR(s2))&($get(CutTitle)=1) do +"RTN","TMGMISC",1122,0) + . . set Name=s1 +"RTN","TMGMISC",1123,0) + . else do +"RTN","TMGMISC",1124,0) + . . set Name=s1_","_s2 +"RTN","TMGMISC",1125,0) + . ;"set Name=$translate(Name,", ",",") ;"Convert 'Doe, John' into 'Doe,John' +"RTN","TMGMISC",1126,0) + set Name=$$UP^XLFSTR(Name) ;"convert to upper case +"RTN","TMGMISC",1127,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"After translations, name is: '",Name,"'") +"RTN","TMGMISC",1128,0) + set result=$$FORMAT^DPTNAME(Name,3,30) ;"Convert to 'internal' format +"RTN","TMGMISC",1129,0) + if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"After $$FORMAT^DPTNAME, name is: '",result,"'") +"RTN","TMGMISC",1130,0) + +"RTN","TMGMISC",1131,0) + ;"Now, test if FORMAT^DPTNAME caused empty name, i.e. +"RTN","TMGMISC",1132,0) + ;" John G Doe --> "" (it wanted Doe,John G) +"RTN","TMGMISC",1133,0) + set lname=$piece(result,",",2) +"RTN","TMGMISC",1134,0) + if $$IsTitle(lname)&($get(CutTitle)=1) do ;"trim off title if not wanted. +"RTN","TMGMISC",1135,0) + . set result=$piece(result,",",1) +"RTN","TMGMISC",1136,0) + . set lname="" +"RTN","TMGMISC",1137,0) + if $$IsSuffix(lname)=1 do +"RTN","TMGMISC",1138,0) + . ;"Here we have 'JOHN DOE,III' --> must be changed to 'DOE,JOHN III' +"RTN","TMGMISC",1139,0) + . set Name=$translate(Name,","," ") ;"First change 'JOHN DOE,III' --> 'JOHN DOE III' +"RTN","TMGMISC",1140,0) + . set result="" ;"signal need to rearrange letters. +"RTN","TMGMISC",1141,0) + if (result="")&(Name'[",") do +"RTN","TMGMISC",1142,0) + . set s=Name +"RTN","TMGMISC",1143,0) + . do CleaveToArray^TMGSTUTL(s," ",.NameArray,1) +"RTN","TMGMISC",1144,0) + . set MaxNode=+$get(NameArray("MAXNODE")) +"RTN","TMGMISC",1145,0) + . if MaxNode=0 quit +"RTN","TMGMISC",1146,0) + . if $get(CutTitle)=1 do +"RTN","TMGMISC",1147,0) + . . if $$IsTitle(NameArray(MaxNode)) do +"RTN","TMGMISC",1148,0) + . . . kill NameArray(MaxNode) +"RTN","TMGMISC",1149,0) + . . . set MaxNode=MaxNode-1 +"RTN","TMGMISC",1150,0) + . . . set NameArray("MAXNODE")=MaxNode +"RTN","TMGMISC",1151,0) + . set lname=NameArray(MaxNode) +"RTN","TMGMISC",1152,0) + . if ($$IsSuffix(lname)=1)!($$IsTitle(lname)) do +"RTN","TMGMISC",1153,0) + . . ;"Change JOHN G DOE III --> JOHN G III DOE (order change in array) +"RTN","TMGMISC",1154,0) + . . set lname=NameArray(MaxNode-1) ;"i.e. DOE +"RTN","TMGMISC",1155,0) + . . set Suffix=NameArray(MaxNode) ;"i.e. III +"RTN","TMGMISC",1156,0) + . . set NameArray(MaxNode)=lname +"RTN","TMGMISC",1157,0) + . . set NameArray(MaxNode-1)=Suffix +"RTN","TMGMISC",1158,0) + . set result=lname_"," +"RTN","TMGMISC",1159,0) + . for i=1:1:MaxNode-1 do +"RTN","TMGMISC",1160,0) + . . set result=result_NameArray(i)_" " +"RTN","TMGMISC",1161,0) + +"RTN","TMGMISC",1162,0) + ;"convert potential 'DOE,JOHN G,III, PHD' --> 'DOE,JOHN G III PHD' +"RTN","TMGMISC",1163,0) + set lname=$piece(result,",",1) +"RTN","TMGMISC",1164,0) + set fname=$piece(result,",",2,99) +"RTN","TMGMISC",1165,0) + set fname=$translate(fname,","," ") +"RTN","TMGMISC",1166,0) + set result=lname_","_fname +"RTN","TMGMISC",1167,0) + +"RTN","TMGMISC",1168,0) + set result=$$Trim^TMGSTUTL(result) +"RTN","TMGMISC",1169,0) + +"RTN","TMGMISC",1170,0) + ;"One last run through, after all custom alterations made. +"RTN","TMGMISC",1171,0) + ;"convert potential 'DOE,JOHN G III PHD' --> 'DOE,JOHN G III PHD' +"RTN","TMGMISC",1172,0) + set result=$$FORMAT^DPTNAME(result,3,30) ;"Convert to 'internal' format +"RTN","TMGMISC",1173,0) + +"RTN","TMGMISC",1174,0) +FormatNDone +"RTN","TMGMISC",1175,0) + if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"FormatName^TMGGDFN") +"RTN","TMGMISC",1176,0) + quit result +"RTN","TMGMISC",1177,0) + +"RTN","TMGMISC",1178,0) + +"RTN","TMGMISC",1179,0) +IsSuffix(s) +"RTN","TMGMISC",1180,0) + ;"Purpose: to return whether s is a suffix (i.e. I,II,Jr.,Sr. etc.) +"RTN","TMGMISC",1181,0) + ;"Input: s : the string to check +"RTN","TMGMISC",1182,0) + ;"Result 0 if NOT a suffix, 1 if IS a suffix. +"RTN","TMGMISC",1183,0) + +"RTN","TMGMISC",1184,0) + new result set result=0 +"RTN","TMGMISC",1185,0) + +"RTN","TMGMISC",1186,0) + if (s="I")!(s="II")!(s="III")!(s="JR")!(s="SR") set result=1 +"RTN","TMGMISC",1187,0) + +"RTN","TMGMISC",1188,0) + quit result +"RTN","TMGMISC",1189,0) + +"RTN","TMGMISC",1190,0) + +"RTN","TMGMISC",1191,0) +IsTitle(s) +"RTN","TMGMISC",1192,0) + ;"Purpose: to return whether s is a title (i.e. MD,PHD,JD,DDS etc.) +"RTN","TMGMISC",1193,0) + ;"Input: s : the string to check +"RTN","TMGMISC",1194,0) + ;"Result 0 if NOT a suffix, 1 if IS a suffix. +"RTN","TMGMISC",1195,0) + +"RTN","TMGMISC",1196,0) + new result set result=0 +"RTN","TMGMISC",1197,0) + +"RTN","TMGMISC",1198,0) + if (s="MD")!(s="PHD")!(s="JD")!(s="DDS") set result=1 +"RTN","TMGMISC",1199,0) + if (s="FNP")!(s="GNP")!(s="NP")!(s="PA") set result=1 +"RTN","TMGMISC",1200,0) + if (s="RN")!(s="LPN") set result=1 +"RTN","TMGMISC",1201,0) + +"RTN","TMGMISC",1202,0) + quit result +"RTN","TMGMISC",1203,0) + +"RTN","TMGMISC",1204,0) + +"RTN","TMGMISC",1205,0) + +"RTN","TMGMISC",1206,0) +HEXCHR(V) +"RTN","TMGMISC",1207,0) + ;"Scope: PUBLIC +"RTN","TMGMISC",1208,0) + ;"Take one BYTE and return HEX Values +"RTN","TMGMISC",1209,0) + ;"(from Chris Richardson -- thanks!) +"RTN","TMGMISC",1210,0) + new NV,B1,B2 +"RTN","TMGMISC",1211,0) + set NV="0123456789ABCDEF" +"RTN","TMGMISC",1212,0) + set B1=(V#16)+1 ; "0 to 15 becomes 1 to 16 +"RTN","TMGMISC",1213,0) + set B2=(V\16)+1 +"RTN","TMGMISC",1214,0) + quit $E(NV,B2)_$E(NV,B1) +"RTN","TMGMISC",1215,0) + +"RTN","TMGMISC",1216,0) + +"RTN","TMGMISC",1217,0) +HEXCHR2(n,digits) +"RTN","TMGMISC",1218,0) + ;"SCOPE: PUBLIC +"RTN","TMGMISC",1219,0) + ;"Purpose: convert n to hex characters +"RTN","TMGMISC",1220,0) + ;"Input: n -- the number to convert +"RTN","TMGMISC",1221,0) + ;" digits: (optional) number of digits in output. Leading 0's padded to +"RTN","TMGMISC",1222,0) + ;" front of answer to set number of digits. +"RTN","TMGMISC",1223,0) + ;" e.g. if answer is "A", then +"RTN","TMGMISC",1224,0) + ;" 2 -> mandates at least 2 digits ("0A") +"RTN","TMGMISC",1225,0) + ;" 3->3 digits ("00A") +"RTN","TMGMISC",1226,0) + ;"Note: This function is not as fast as HEXCHR(V) +"RTN","TMGMISC",1227,0) + +"RTN","TMGMISC",1228,0) + new lo +"RTN","TMGMISC",1229,0) + new result set result="" +"RTN","TMGMISC",1230,0) + new ch +"RTN","TMGMISC",1231,0) + set digits=$get(digits,1) +"RTN","TMGMISC",1232,0) + +"RTN","TMGMISC",1233,0) + for do quit:(n=0) +"RTN","TMGMISC",1234,0) + . set lo=n#16 +"RTN","TMGMISC",1235,0) + . if (lo<10) set ch=+lo +"RTN","TMGMISC",1236,0) + . else set ch=$char(55+lo) +"RTN","TMGMISC",1237,0) + . set result=ch_result +"RTN","TMGMISC",1238,0) + . set n=n\16 +"RTN","TMGMISC",1239,0) + +"RTN","TMGMISC",1240,0) + if $length(result) 16 +"RTN","TMGMISC",1250,0) + +"RTN","TMGMISC",1251,0) + new multiplier set multiplier=1 +"RTN","TMGMISC",1252,0) + new result set result=0 +"RTN","TMGMISC",1253,0) + +"RTN","TMGMISC",1254,0) + if $extract(s,1)="$" set s=$extract(s,2,$length(s)) +"RTN","TMGMISC",1255,0) + +"RTN","TMGMISC",1256,0) + for do quit:(s="") +"RTN","TMGMISC",1257,0) + . new sStart,sEnd,n +"RTN","TMGMISC",1258,0) + . set sStart=$extract(s,1,$length(s)-1) +"RTN","TMGMISC",1259,0) + . set sEnd=$extract(s,$length(s)) +"RTN","TMGMISC",1260,0) + . if +sEnd=sEnd set n=sEnd +"RTN","TMGMISC",1261,0) + . else set n=($ascii(sEnd)-65)+16 +"RTN","TMGMISC",1262,0) + . set result=result+(n*multiplier) +"RTN","TMGMISC",1263,0) + . set multiplier=multiplier*16 +"RTN","TMGMISC",1264,0) + . set s=sStart +"RTN","TMGMISC",1265,0) + +"RTN","TMGMISC",1266,0) + quit result +"RTN","TMGMISC",1267,0) + +"RTN","TMGMISC",1268,0) + +"RTN","TMGMISC",1269,0) +OR(a,b) +"RTN","TMGMISC",1270,0) + ;"Scope: PUBLIC +"RTN","TMGMISC",1271,0) + ;"Purpose: to perform a bitwise OR on operands a and b +"RTN","TMGMISC",1272,0) + +"RTN","TMGMISC",1273,0) + new result set result=0 +"RTN","TMGMISC",1274,0) + new mult set mult=1 +"RTN","TMGMISC",1275,0) + for do quit:(a'>0)&(b'>0) +"RTN","TMGMISC",1276,0) + . set result=result+(((a#2)!(b#2))*mult) +"RTN","TMGMISC",1277,0) + . set a=a\2,b=b\2,mult=mult*2 +"RTN","TMGMISC",1278,0) + +"RTN","TMGMISC",1279,0) + quit result +"RTN","TMGMISC",1280,0) + +"RTN","TMGMISC",1281,0) + +"RTN","TMGMISC",1282,0) +ParsePos(pos,label,offset,routine,dmod) +"RTN","TMGMISC",1283,0) + ;"Purpose: to convert a pos string (e.g. X+2^ROUTINE$DMOD) into componant parts +"RTN","TMGMISC",1284,0) + ;"Input: pos -- the string, as example above +"RTN","TMGMISC",1285,0) + ;" label -- OUT PARAM, PASS BY REF, would return "x" +"RTN","TMGMISC",1286,0) + ;" offset -- OUT PARAM, PASS BY REF, would return "+2" +"RTN","TMGMISC",1287,0) + ;" routine -- OUT PARAM, PASS BY REF, would return "ROUTINE" +"RTN","TMGMISC",1288,0) + ;" dmod -- OUT PARAM, PASS BY REF, would return "DMOD" +"RTN","TMGMISC",1289,0) + ;"Results: none +"RTN","TMGMISC",1290,0) + ;"Note: results are shortened to 8 characters. +"RTN","TMGMISC",1291,0) + +"RTN","TMGMISC",1292,0) + new s +"RTN","TMGMISC",1293,0) + set s=$get(pos) +"RTN","TMGMISC",1294,0) + set dmod=$piece(s,"$",1) ;"e.g. X+2^ROUTINE$DMOD-->X+2^ROUTINE +"RTN","TMGMISC",1295,0) + set routine=$piece(s,"^",2) +"RTN","TMGMISC",1296,0) + set routine=$extract(routine,1,8) +"RTN","TMGMISC",1297,0) + set label=$piece(s,"^",1) +"RTN","TMGMISC",1298,0) + set offset=$piece(label,"+",2) +"RTN","TMGMISC",1299,0) + set label=$piece(label,"+",1) +"RTN","TMGMISC",1300,0) + set label=$extract(label,1,8) +"RTN","TMGMISC",1301,0) + +"RTN","TMGMISC",1302,0) + quit +"RTN","TMGMISC",1303,0) + +"RTN","TMGMISC",1304,0) + +"RTN","TMGMISC",1305,0) +ScanMod(Module,pArray) +"RTN","TMGMISC",1306,0) + ;"Purpose: To scan a module and find all the labels/entry points/Entry points +"RTN","TMGMISC",1307,0) + ;"Input: Module -- The name of the module, like "XGF" (not "XGF.m" or "^XGF") +"RTN","TMGMISC",1308,0) + ;" pArray -- pointer to (NAME OF) array Will be filled like this +"RTN","TMGMISC",1309,0) + ;" pArray(1,"TAG")="Label1" +"RTN","TMGMISC",1310,0) + ;" pArray(1,"OFFSET")=1 +"RTN","TMGMISC",1311,0) + ;" pArray(2,"TAG")="Label2" +"RTN","TMGMISC",1312,0) + ;" pArray(2,"OFFSET")=9 +"RTN","TMGMISC",1313,0) + ;" pArray(3,"TAG")="Label3" etc. +"RTN","TMGMISC",1314,0) + ;" pArray(3,"OFFSET")=15 +"RTN","TMGMISC",1315,0) + ;" pArray("Label1")=1 +"RTN","TMGMISC",1316,0) + ;" pArray("Label2")=2 +"RTN","TMGMISC",1317,0) + ;" pArray("Label3")=3 +"RTN","TMGMISC",1318,0) + ;" +"RTN","TMGMISC",1319,0) + ;" NOTE: there seems to be a problem if the passed pArray value is "pArray", +"RTN","TMGMISC",1320,0) + ;" so use another name. +"RTN","TMGMISC",1321,0) + ;" +"RTN","TMGMISC",1322,0) + ;"Output: Results are put into array +"RTN","TMGMISC",1323,0) + ;"Result: none +"RTN","TMGMISC",1324,0) + +"RTN","TMGMISC",1325,0) + new smIdx set smIdx=1 +"RTN","TMGMISC",1326,0) + new LabelNum set LabelNum=0 +"RTN","TMGMISC",1327,0) + new smLine set smLine="" +"RTN","TMGMISC",1328,0) + if $get(Module)="" goto SMDone +"RTN","TMGMISC",1329,0) + +"RTN","TMGMISC",1330,0) + for do quit:(smLine="") +"RTN","TMGMISC",1331,0) + . new smCh +"RTN","TMGMISC",1332,0) + . set smLine=$text(+smIdx^@Module) +"RTN","TMGMISC",1333,0) + . if smLine="" quit +"RTN","TMGMISC",1334,0) + . set smLine=$$Substitute^TMGSTUTL(smLine,$Char(9)," ") ;"replace tabs for 8 spaces +"RTN","TMGMISC",1335,0) + . set smCh=$extract(smLine,1) +"RTN","TMGMISC",1336,0) + . if (smCh'=" ")&(smCh'=";") do +"RTN","TMGMISC",1337,0) + . . new label +"RTN","TMGMISC",1338,0) + . . set label=$piece(smLine," ",1) +"RTN","TMGMISC",1339,0) + . . set LabelNum=LabelNum+1 +"RTN","TMGMISC",1340,0) + . . set @pArray@(LabelNum,"TAG")=label +"RTN","TMGMISC",1341,0) + . . set @pArray@(LabelNum,"OFFSET")=smIdx +"RTN","TMGMISC",1342,0) + . . set @pArray@(label)=LabelNum +"RTN","TMGMISC",1343,0) + . set smIdx=smIdx+1 +"RTN","TMGMISC",1344,0) + +"RTN","TMGMISC",1345,0) +SMDone +"RTN","TMGMISC",1346,0) + quit +"RTN","TMGMISC",1347,0) + +"RTN","TMGMISC",1348,0) + +"RTN","TMGMISC",1349,0) +ConvertPos(Pos,pArray) +"RTN","TMGMISC",1350,0) + ;"Purpose: to convert a text positioning line from one that is relative to the last tag/label, into +"RTN","TMGMISC",1351,0) + ;" one that is relative to the start of the file +"RTN","TMGMISC",1352,0) + ;" e.g. START+8^MYFUNCT --> +32^MYFUNCT +"RTN","TMGMISC",1353,0) + ;"Input: Pos -- a position, as returned from $ZPOS +"RTN","TMGMISC",1354,0) + ;" pArray -- pointer to (name of). Array holding holding tag offsets +"RTN","TMGMISC",1355,0) + ;" pArray will be in this format: +"RTN","TMGMISC",1356,0) + ;" pArray("ModuleA",1,"TAG")="ALabel1" +"RTN","TMGMISC",1357,0) + ;" pArray("ModuleA",1,"OFFSET")=1 +"RTN","TMGMISC",1358,0) + ;" pArray("ModuleA",2,"TAG")="ALabel2" +"RTN","TMGMISC",1359,0) + ;" pArray("ModuleA",2,"OFFSET")=9 +"RTN","TMGMISC",1360,0) + ;" pArray("ModuleA","Label1")=1 +"RTN","TMGMISC",1361,0) + ;" pArray("ModuleA","Label2")=2 +"RTN","TMGMISC",1362,0) + ;" pArray("ModuleA","Label3")=3 +"RTN","TMGMISC",1363,0) + ;" pArray("ModuleB",1,"TAG")="BLabel1" +"RTN","TMGMISC",1364,0) + ;" pArray("ModuleB",1,"OFFSET")=4 +"RTN","TMGMISC",1365,0) + ;" pArray("ModuleB",2,"TAG")="BLabel2" +"RTN","TMGMISC",1366,0) + ;" pArray("ModuleB",2,"OFFSET")=23 +"RTN","TMGMISC",1367,0) + ;" pArray("ModuleB","Label1")=1 +"RTN","TMGMISC",1368,0) + ;" pArray("ModuleB","Label2")=2 +"RTN","TMGMISC",1369,0) + ;" pArray("ModuleB","Label3")=3 +"RTN","TMGMISC",1370,0) + ;" NOTE: -- if array passed is empty, then this function will call ScanModule to fill it +"RTN","TMGMISC",1371,0) + ;"Result: returns the new position line, relative to the start of the file/module +"RTN","TMGMISC",1372,0) + ;" +"RTN","TMGMISC",1373,0) + +"RTN","TMGMISC",1374,0) + new cpS +"RTN","TMGMISC",1375,0) + new cpResult set cpResult="" +"RTN","TMGMISC",1376,0) + new cpRoutine,cpLabel,cpOffset +"RTN","TMGMISC",1377,0) + +"RTN","TMGMISC",1378,0) + set cpS=$piece(Pos,"$",1) ;"e.g. X+2^ROUTINE$DMOD-->X+2^ROUTINE +"RTN","TMGMISC",1379,0) + if cpS="" goto CPDone +"RTN","TMGMISC",1380,0) + +"RTN","TMGMISC",1381,0) + set cpRoutine=$piece(cpS,"^",2) +"RTN","TMGMISC",1382,0) + if cpRoutine="" goto CPDone +"RTN","TMGMISC",1383,0) + +"RTN","TMGMISC",1384,0) + set cpS=$piece(cpS,"^",1) +"RTN","TMGMISC",1385,0) + set cpOffset=+$piece(cpS,"+",2) +"RTN","TMGMISC",1386,0) + ;"if cpOffset="" set cpOffset=1 +"RTN","TMGMISC",1387,0) + ;"else set cpOffset=+cpOffset +"RTN","TMGMISC",1388,0) + set cpLabel=$piece(cpS,"+",1) +"RTN","TMGMISC",1389,0) + +"RTN","TMGMISC",1390,0) + if $data(@pArray@(cpRoutine))=0 do +"RTN","TMGMISC",1391,0) + . new p2Array set p2Array=$name(@pArray@(cpRoutine)) +"RTN","TMGMISC",1392,0) + . do ScanMod(cpRoutine,p2Array) +"RTN","TMGMISC",1393,0) + +"RTN","TMGMISC",1394,0) + new cpIdx set cpIdx=+$get(@pArray@(cpRoutine,cpLabel)) +"RTN","TMGMISC",1395,0) + if cpIdx=0 goto CPDone +"RTN","TMGMISC",1396,0) + new cpGOffset set cpGOffset=@pArray@(cpRoutine,cpIdx,"OFFSET") +"RTN","TMGMISC",1397,0) + set cpResult="+"_+(cpGOffset+cpOffset)_"^"_cpRoutine +"RTN","TMGMISC",1398,0) + +"RTN","TMGMISC",1399,0) +CPDone +"RTN","TMGMISC",1400,0) + quit cpResult +"RTN","TMGMISC",1401,0) + +"RTN","TMGMISC",1402,0) + +"RTN","TMGMISC",1403,0) + +"RTN","TMGMISC",1404,0) + +"RTN","TMGMISC",1405,0) +CompArray(pArray1,pArray2) +"RTN","TMGMISC",1406,0) + ;"Purpose: To return if two arrays are identical +"RTN","TMGMISC",1407,0) + ;" Equality means that all nodes and values are present and equal +"RTN","TMGMISC",1408,0) + ;"Input: Array1 -- PASS BY NAME. The *name of* the first array to be compared +"RTN","TMGMISC",1409,0) + ;" Array1 -- PASS BY NAME. The *name of* the second array to be compared +"RTN","TMGMISC",1410,0) + ;"Output: 1 if two are identical, 0 if not +"RTN","TMGMISC",1411,0) + +"RTN","TMGMISC",1412,0) + new result set result=1 +"RTN","TMGMISC",1413,0) + new index1,index2 +"RTN","TMGMISC",1414,0) + set index1=$order(@pArray1@("")) +"RTN","TMGMISC",1415,0) + set index2=$order(@pArray2@("")) +"RTN","TMGMISC",1416,0) + if (index1="")!(index2="") set result=0 goto CADone +"RTN","TMGMISC",1417,0) + for do quit:(result=0)!(index1="")!(index2="") +"RTN","TMGMISC",1418,0) + . if index2'=index2 set result=0 quit +"RTN","TMGMISC",1419,0) + . if $get(@pArray1@(index1))'=$get(@pArray2@(index2)) set result=0 quit +"RTN","TMGMISC",1420,0) + . if ($data(@pArray1@(index1))'<10)!($data(@pArray2@(index2))'<10) do +"RTN","TMGMISC",1421,0) + . . set result=$$CompArray($name(@pArray1@(index1)),$name(@pArray2@(index2))) +"RTN","TMGMISC",1422,0) + . set index1=$order(@pArray1@(index1)) +"RTN","TMGMISC",1423,0) + . set index2=$order(@pArray2@(index2)) +"RTN","TMGMISC",1424,0) + +"RTN","TMGMISC",1425,0) +CADone quit result +"RTN","TMGMISC",1426,0) + +"RTN","TMGMISC",1427,0) + +"RTN","TMGMISC",1428,0) + +"RTN","TMGMISC",1429,0) +IterTemplate(Template,Prior) +"RTN","TMGMISC",1430,0) + ;"Purpose: To iterate through a SORT TEMPLATE (i.e. provide record numbers held in the template +"RTN","TMGMISC",1431,0) + ;" one at a time. For each time this function is called, one record number (IEN) is returned. +"RTN","TMGMISC",1432,0) + ;"Input: Template: the IEN of an entry from file SORT TEMPLATE (file# .401) +"RTN","TMGMISC",1433,0) + ;" Prior -- OPTIONAL (default is to return first record), an IEN as returned from this +"RTN","TMGMISC",1434,0) + ;" function during the last call. +"RTN","TMGMISC",1435,0) + ;"Result: Returns the next record found in list, occuring after Prior, or -1 if error or not found +"RTN","TMGMISC",1436,0) + ;" Returns "" if end of list (no next record) +"RTN","TMGMISC",1437,0) + +"RTN","TMGMISC",1438,0) + ;"Example of use: This will list all records held in SORT TEMPLATE record# 809 +"RTN","TMGMISC",1439,0) + ;" set IEN="" +"RTN","TMGMISC",1440,0) + ;" for s IEN=$$IterTemplate^TMGMISC(809,IEN) w IEN,! q:(+IEN'>0) +"RTN","TMGMISC",1441,0) + +"RTN","TMGMISC",1442,0) + set Prior=$get(Prior) +"RTN","TMGMISC",1443,0) + set result=-1 +"RTN","TMGMISC",1444,0) + if +$get(Template)'>0 goto ItTDone +"RTN","TMGMISC",1445,0) + +"RTN","TMGMISC",1446,0) + set result=$order(^DIBT(Template,1,Prior)) +"RTN","TMGMISC",1447,0) + +"RTN","TMGMISC",1448,0) +ItTDone quit result +"RTN","TMGMISC",1449,0) + +"RTN","TMGMISC",1450,0) +CtTemplate(Template) +"RTN","TMGMISC",1451,0) + ;"Purpose: To return the Count of IEN's stored in a SORT TEMPLATE +"RTN","TMGMISC",1452,0) + ;"Input: Template: the IEN of an entry from file SORT TEMPLATE (file# .401) +"RTN","TMGMISC",1453,0) + ;"Result: Returns the count of records held +"RTN","TMGMISC",1454,0) + +"RTN","TMGMISC",1455,0) + new name set name=$name(^DIBT(Template,1)) +"RTN","TMGMISC",1456,0) + quit $$ListCt(name) +"RTN","TMGMISC",1457,0) + +"RTN","TMGMISC",1458,0) + +"RTN","TMGMISC",1459,0) +NumPieces(s,delim,maxPoss) +"RTN","TMGMISC",1460,0) + ;"Purpose: to return the number of pieces in s, using delim as a delimiter +"RTN","TMGMISC",1461,0) + ;"Input: s -- the string to test +"RTN","TMGMISC",1462,0) + ;" delim -- OPTIONAL -- the delimiter (e.g. ',' or ';' or ' ' etc), default=" " +"RTN","TMGMISC",1463,0) + ;" maxPoss -- OPTIONAL the maximum number of possible pieces, default=32 +"RTN","TMGMISC",1464,0) + ;" the function counts DOWN from this number, so if s has more than default, must specify +"RTN","TMGMISC",1465,0) + ;"Result: Returns the number of pieces +"RTN","TMGMISC",1466,0) + ;" e.g. 'this is a test', space delimiter --> returns 4 +"RTN","TMGMISC",1467,0) + ;"Note: ("this is a test",";") --> 1 +"RTN","TMGMISC",1468,0) + ;" ("",";") --> 0 +"RTN","TMGMISC",1469,0) + +"RTN","TMGMISC",1470,0) + ;"NOTICE!!! +"RTN","TMGMISC",1471,0) + ;"After writing this function, I was told that $length(s,delim) will do this. +"RTN","TMGMISC",1472,0) + ;" I will leave this here as a reminder, but it probably shouldn't be used.... +"RTN","TMGMISC",1473,0) + quit $length(s,$get(delim," ")) +"RTN","TMGMISC",1474,0) + +"RTN","TMGMISC",1475,0) + +"RTN","TMGMISC",1476,0) + new i,result set result=0 +"RTN","TMGMISC",1477,0) + if $get(s)="" goto NPsDone +"RTN","TMGMISC",1478,0) + set delim=$get(delim," ") +"RTN","TMGMISC",1479,0) + set maxPoss=+$get(maxPoss,32) +"RTN","TMGMISC",1480,0) + +"RTN","TMGMISC",1481,0) + for result=maxPoss:-1:1 quit:($piece(s,delim,result)'="") +"RTN","TMGMISC",1482,0) + +"RTN","TMGMISC",1483,0) + quit result +"RTN","TMGMISC",1484,0) + +"RTN","TMGMISC",1485,0) +LastPiece(s,delim,maxPoss) +"RTN","TMGMISC",1486,0) + ;"Purpose: to return the last piece of a string +"RTN","TMGMISC",1487,0) + ;"Input: s -- the string to use +"RTN","TMGMISC",1488,0) + ;" delim -- OPTIONAL -- the delimiter (e.g. ',' or ';' or ' ' etc), default=" " +"RTN","TMGMISC",1489,0) + ;" maxPoss -- OPTIONAL the maximum number of possible pieces, default=32 (see NumPieces function) +"RTN","TMGMISC",1490,0) + ;"Results : returns the LAST piece in the string +"RTN","TMGMISC",1491,0) + +"RTN","TMGMISC",1492,0) + new result set result="" +"RTN","TMGMISC",1493,0) + if $get(s)="" goto LPDone +"RTN","TMGMISC",1494,0) + set delim=$get(delim," ") +"RTN","TMGMISC",1495,0) + new n +"RTN","TMGMISC",1496,0) + set n=$length(s,delim) +"RTN","TMGMISC",1497,0) + set result=$piece(s,delim,n) +"RTN","TMGMISC",1498,0) + +"RTN","TMGMISC",1499,0) +LPDone +"RTN","TMGMISC",1500,0) + quit result +"RTN","TMGMISC",1501,0) + +"RTN","TMGMISC",1502,0) +ParseLast(s,remainS,delim,maxPoss) +"RTN","TMGMISC",1503,0) + ;"Purpose: to return the last piece of a string, AND return the first part of the string in remainS +"RTN","TMGMISC",1504,0) + ;"Input: s -- the string to use +"RTN","TMGMISC",1505,0) + ;" remainS -- an OUT parameter. PASS BY REFERENCE. Returns the part of the string up to result +"RTN","TMGMISC",1506,0) + ;" delim -- OPTIONAL -- the delimiter (e.g. ',' or ';' or ' ' etc), default=" " +"RTN","TMGMISC",1507,0) + ;" maxPoss -- OPTIONAL the maximum number of possible pieces, default=32 (see NumPieces function) +"RTN","TMGMISC",1508,0) + ;"Results : returns the LAST piece in the string +"RTN","TMGMISC",1509,0) + +"RTN","TMGMISC",1510,0) + new result set result="" +"RTN","TMGMISC",1511,0) + new tempS set tempS=s ;"in case s passed by reference, and remainS=s (i.e. w $$ParseLast(s,.s) +"RTN","TMGMISC",1512,0) + set remainS="" +"RTN","TMGMISC",1513,0) + set delim=$get(delim," ") +"RTN","TMGMISC",1514,0) + +"RTN","TMGMISC",1515,0) + if $get(tempS)="" goto PLDone +"RTN","TMGMISC",1516,0) + new n +"RTN","TMGMISC",1517,0) + set n=$length(s,delim) +"RTN","TMGMISC",1518,0) + set result=$piece(tempS,delim,n) +"RTN","TMGMISC",1519,0) + if n>1 set remainS=$piece(tempS,delim,1,n-1) +"RTN","TMGMISC",1520,0) + +"RTN","TMGMISC",1521,0) +PLDone +"RTN","TMGMISC",1522,0) + quit result +"RTN","TMGMISC",1523,0) + +"RTN","TMGMISC",1524,0) + +"RTN","TMGMISC",1525,0) + +"RTN","TMGMISC",1526,0) +NPsDone +"RTN","TMGMISC",1527,0) + quit result +"RTN","TMGMISC",1528,0) + +"RTN","TMGMISC",1529,0) + +"RTN","TMGMISC",1530,0) +Trim1Node(pRef) +"RTN","TMGMISC",1531,0) + ;"Purpose: To shorten a reference by one node. +"RTN","TMGMISC",1532,0) + ;" e.g. "Array(567,2342,123)" --> "Array(567,2342)" +"RTN","TMGMISC",1533,0) + ;"Input: pRef -- the NAME OF an array. +"RTN","TMGMISC",1534,0) + ;"Result: will return shortened reference, or "" if problem +"RTN","TMGMISC",1535,0) + ;" If no nodes to trim, just array name will be returnes. +"RTN","TMGMISC",1536,0) + +"RTN","TMGMISC",1537,0) + new result set result=pRef +"RTN","TMGMISC",1538,0) + if pRef="" goto T1NDone +"RTN","TMGMISC",1539,0) + +"RTN","TMGMISC",1540,0) + if $qlength(pRef)>0 set result=$name(@pRef,$qlength(pRef)-1) +"RTN","TMGMISC",1541,0) + goto T1NDone +"RTN","TMGMISC",1542,0) + +"RTN","TMGMISC",1543,0) + ;"Below is an old way I came up with (not as effecient!) +"RTN","TMGMISC",1544,0) + ;"NOT USED. +"RTN","TMGMISC",1545,0) + set result=$qsubscript(pRef,0) +"RTN","TMGMISC",1546,0) + +"RTN","TMGMISC",1547,0) + new numNodes,i +"RTN","TMGMISC",1548,0) + set numNodes=$qlength(pRef) +"RTN","TMGMISC",1549,0) + for i=1:1:(numNodes-1) do +"RTN","TMGMISC",1550,0) + . new node set node=$qsubscript(pRef,i) +"RTN","TMGMISC",1551,0) + . set result=$name(@result@(node)) +"RTN","TMGMISC",1552,0) + +"RTN","TMGMISC",1553,0) +T1NDone +"RTN","TMGMISC",1554,0) + quit result +"RTN","TMGMISC",1555,0) + +"RTN","TMGMISC",1556,0) + +"RTN","TMGMISC",1557,0) +BROWSEASK +"RTN","TMGMISC",1558,0) + ;"Purpose: to ask user for the name of an array, then display nodes +"RTN","TMGMISC",1559,0) + +"RTN","TMGMISC",1560,0) + new current +"RTN","TMGMISC",1561,0) + new order set order=1 ;"default = forward display. +"RTN","TMGMISC",1562,0) + new paginate set paginate=0 ;"no pagination +"RTN","TMGMISC",1563,0) + new countNodes set countNodes=0 ;"no counting +"RTN","TMGMISC",1564,0) + write ! +"RTN","TMGMISC",1565,0) + read "Enter name of array (or File number) to display nodes in: ",current:$get(DTIME,3600),! +"RTN","TMGMISC",1566,0) + if +current=current do +"RTN","TMGMISC",1567,0) + . set current=$get(^DIC(+current,0,"GL")) +"RTN","TMGMISC",1568,0) + . if current="" write "File number not found. Quitting.",! quit +"RTN","TMGMISC",1569,0) + . write "Browsing array: ",current,! +"RTN","TMGMISC",1570,0) + if current="" set current="^" +"RTN","TMGMISC",1571,0) + if current="^" goto BADone +"RTN","TMGMISC",1572,0) + +"RTN","TMGMISC",1573,0) + new % set %=2 ;" default= NO +"RTN","TMGMISC",1574,0) + write "Display in REVERSE order? " +"RTN","TMGMISC",1575,0) + do YN^DICN write ! +"RTN","TMGMISC",1576,0) + if %=1 set order=-1 +"RTN","TMGMISC",1577,0) + if %=-1 goto BADone +"RTN","TMGMISC",1578,0) + +"RTN","TMGMISC",1579,0) + set %=2 +"RTN","TMGMISC",1580,0) + write "Pause after each page? " +"RTN","TMGMISC",1581,0) + do YN^DICN write ! +"RTN","TMGMISC",1582,0) + if %=1 set paginate=1 +"RTN","TMGMISC",1583,0) + if %=-1 goto BADone +"RTN","TMGMISC",1584,0) + +"RTN","TMGMISC",1585,0) + set %=2 +"RTN","TMGMISC",1586,0) + write "Show number of subnodes? " +"RTN","TMGMISC",1587,0) + do YN^DICN write ! +"RTN","TMGMISC",1588,0) + if %=1 set countNodes=1 +"RTN","TMGMISC",1589,0) + if %=-1 goto BADone +"RTN","TMGMISC",1590,0) + +"RTN","TMGMISC",1591,0) + do BROWSENODES(current,order,paginate,countNodes) +"RTN","TMGMISC",1592,0) +BADone +"RTN","TMGMISC",1593,0) + quit +"RTN","TMGMISC",1594,0) + +"RTN","TMGMISC",1595,0) + +"RTN","TMGMISC",1596,0) +BROWSENODES(current,Order,paginate,countNodes) +"RTN","TMGMISC",1597,0) + ;"Purpose: to display nodes of specified array +"RTN","TMGMISC",1598,0) + ;"Input: Current -- The reference to display +"RTN","TMGMISC",1599,0) + ;" order -- OPTIONAL, default=1; 1 for forward, -1 for backwards order +"RTN","TMGMISC",1600,0) + ;" paginate -- OPTIONAL, default=0; 0=no pagination, 1=pause after each page +"RTN","TMGMISC",1601,0) + ;" countNodes -- OPTIONAL, default=0; 1=show number of child nodes. +"RTN","TMGMISC",1602,0) + +"RTN","TMGMISC",1603,0) + new parent,child +"RTN","TMGMISC",1604,0) + set parent="" +"RTN","TMGMISC",1605,0) + set order=$get(order,1) +"RTN","TMGMISC",1606,0) + set paginate=$get(paginate,0) +"RTN","TMGMISC",1607,0) + set countNodes=$get(countNodes,0) +"RTN","TMGMISC",1608,0) + +"RTN","TMGMISC",1609,0) + new len set len=$length(current) +"RTN","TMGMISC",1610,0) + new lastChar set lastChar=$extract(current,len) +"RTN","TMGMISC",1611,0) + if lastChar'=")" do +"RTN","TMGMISC",1612,0) + . if current'["(" quit +"RTN","TMGMISC",1613,0) + . if lastChar="," set current=$extract(current,1,len-1) +"RTN","TMGMISC",1614,0) + . if lastChar="(" set current=$extract(current,1,len-1) quit +"RTN","TMGMISC",1615,0) + . set current=current_")" +"RTN","TMGMISC",1616,0) + +"RTN","TMGMISC",1617,0) +BNLoop +"RTN","TMGMISC",1618,0) + if current="" goto BNDone +"RTN","TMGMISC",1619,0) + set child=$$ShowNodes(current,order,paginate,countNodes) +"RTN","TMGMISC",1620,0) + if child'="" do +"RTN","TMGMISC",1621,0) + . set parent(child)=current +"RTN","TMGMISC",1622,0) + . set current=child +"RTN","TMGMISC",1623,0) + else set current=$get(parent(current)) +"RTN","TMGMISC",1624,0) + goto BNLoop +"RTN","TMGMISC",1625,0) +BNDone +"RTN","TMGMISC",1626,0) + quit +"RTN","TMGMISC",1627,0) + +"RTN","TMGMISC",1628,0) + +"RTN","TMGMISC",1629,0) +ShowNodes(pArray,order,paginate,countNodes) +"RTN","TMGMISC",1630,0) + ;"Purpose: To display all the nodes of the given array +"RTN","TMGMISC",1631,0) + ;"Input: pArray -- NAME OF array to display +"RTN","TMGMISC",1632,0) + ;" order -- OPTIONAL, default=1; 1 for forward, -1 for backwards order +"RTN","TMGMISC",1633,0) + ;" paginate -- OPTIONAL, default=0; 0=no pagination, 1=pause after each page +"RTN","TMGMISC",1634,0) + ;" countNodes -- OPTIONAL, default=0; 1=show number of child nodes. +"RTN","TMGMISC",1635,0) + ;"Results: returns NAME OF next node to display (or "" if none) +"RTN","TMGMISC",1636,0) + +"RTN","TMGMISC",1637,0) + new TMGi +"RTN","TMGMISC",1638,0) + new count set count=1 +"RTN","TMGMISC",1639,0) + new Answers +"RTN","TMGMISC",1640,0) + new someShown set someShown=0 +"RTN","TMGMISC",1641,0) + new abort set abort=0 +"RTN","TMGMISC",1642,0) + set paginate=$get(paginate,0) +"RTN","TMGMISC",1643,0) + new pageCount set pageCount=0 +"RTN","TMGMISC",1644,0) + new pageLen set pageLen=20 +"RTN","TMGMISC",1645,0) + set countNodes=$get(countNodes,0) +"RTN","TMGMISC",1646,0) + +"RTN","TMGMISC",1647,0) + write pArray,! +"RTN","TMGMISC",1648,0) + set TMGi=$order(@pArray@(""),order) +"RTN","TMGMISC",1649,0) + if TMGi'="" for do quit:(TMGi="")!(abort=1) +"RTN","TMGMISC",1650,0) + . write count,". +--[",TMGi,"]" +"RTN","TMGMISC",1651,0) + . if countNodes=1 write "(",$$ListCt($name(@pArray@(TMGi))),")" +"RTN","TMGMISC",1652,0) + . write "=",$extract($get(@pArray@(TMGi)),1,40),! +"RTN","TMGMISC",1653,0) + . set someShown=1 +"RTN","TMGMISC",1654,0) + . set Answers(count)=$name(@pArray@(TMGi)) +"RTN","TMGMISC",1655,0) + . set count=count+1 +"RTN","TMGMISC",1656,0) + . new temp read *temp:0 +"RTN","TMGMISC",1657,0) + . if temp'=-1 set abort=1 +"RTN","TMGMISC",1658,0) + . set pageCount=pageCount+1 +"RTN","TMGMISC",1659,0) + . if (paginate=1)&(pageCount>pageLen) do +"RTN","TMGMISC",1660,0) + . . new temp +"RTN","TMGMISC",1661,0) + . . read "Press [ENTER] to continue (^ to stop list)...",temp:$get(DTIME,3600),! +"RTN","TMGMISC",1662,0) + . . if temp="^" set abort=1 +"RTN","TMGMISC",1663,0) + . . set pageCount=0 +"RTN","TMGMISC",1664,0) + . set TMGi=$order(@pArray@(TMGi),order) +"RTN","TMGMISC",1665,0) + +"RTN","TMGMISC",1666,0) + if someShown=0 write " (no data)",! +"RTN","TMGMISC",1667,0) + write !,"Enter # to browse (^ to backup): ^//" +"RTN","TMGMISC",1668,0) + new temp read temp:$get(DTIME,3600),! +"RTN","TMGMISC",1669,0) + +"RTN","TMGMISC",1670,0) + new result set result=$get(Answers(temp)) +"RTN","TMGMISC",1671,0) + +"RTN","TMGMISC",1672,0) + quit result +"RTN","TMGMISC",1673,0) + +"RTN","TMGMISC",1674,0) + +"RTN","TMGMISC",1675,0) +BRWSASK2 +"RTN","TMGMISC",1676,0) + ;"Purpose: Improved... Ask user for the name of an array, then display nodes +"RTN","TMGMISC",1677,0) + +"RTN","TMGMISC",1678,0) + new current +"RTN","TMGMISC",1679,0) + new order set order=1 ;"default = forward display. +"RTN","TMGMISC",1680,0) + new countNodes set countNodes=0 ;"no counting +"RTN","TMGMISC",1681,0) + write ! +"RTN","TMGMISC",1682,0) + read "Enter name of array (or File number) to display nodes in: ",current:$get(DTIME,3600),! +"RTN","TMGMISC",1683,0) + if +current=current do +"RTN","TMGMISC",1684,0) + . set current=$get(^DIC(+current,0,"GL")) +"RTN","TMGMISC",1685,0) + . if current="" write "File number not found. Quitting.",! quit +"RTN","TMGMISC",1686,0) + . write "Browsing array: ",current,! +"RTN","TMGMISC",1687,0) + if current="" set current="^" +"RTN","TMGMISC",1688,0) + if current="^" goto BA2Done +"RTN","TMGMISC",1689,0) + +"RTN","TMGMISC",1690,0) + new % set %=2 ;" default= NO +"RTN","TMGMISC",1691,0) + write "Display in REVERSE order? " do YN^DICN write ! +"RTN","TMGMISC",1692,0) + if %=1 set order=-1 +"RTN","TMGMISC",1693,0) + if %=-1 goto BA2Done +"RTN","TMGMISC",1694,0) + +"RTN","TMGMISC",1695,0) + set %=2 +"RTN","TMGMISC",1696,0) + write "Show number of subnodes? " do YN^DICN write ! +"RTN","TMGMISC",1697,0) + if %=1 set countNodes=1 +"RTN","TMGMISC",1698,0) + if %=-1 goto BA2Done +"RTN","TMGMISC",1699,0) + +"RTN","TMGMISC",1700,0) + do BRWSNOD2(current,order,countNodes) +"RTN","TMGMISC",1701,0) +BA2Done +"RTN","TMGMISC",1702,0) + quit +"RTN","TMGMISC",1703,0) + +"RTN","TMGMISC",1704,0) +BRWSNOD2(curRef,Order,countNodes) +"RTN","TMGMISC",1705,0) + ;"Purpose: to display nodes of specified array +"RTN","TMGMISC",1706,0) + ;"Input: curRef -- The reference to display +"RTN","TMGMISC",1707,0) + ;" order -- OPTIONAL, default=1; 1 for forward, -1 for backwards order +"RTN","TMGMISC",1708,0) + ;" paginate -- OPTIONAL, default=0; 0=no pagination, 1=pause after each page +"RTN","TMGMISC",1709,0) + ;" countNodes -- OPTIONAL, default=0; 1=show number of child nodes. +"RTN","TMGMISC",1710,0) + set curRef=$$CREF^DILF(curRef) +"RTN","TMGMISC",1711,0) + if curRef="" goto BN2Done +"RTN","TMGMISC",1712,0) + new TMGBRWORDER set TMGBRWORDER=$get(order,1) +"RTN","TMGMISC",1713,0) + new TMGBRWCN set TMGBRWCN=$get(countNodes,0) +"RTN","TMGMISC",1714,0) + if $$ShowNod2(curRef,TMGBRWORDER,TMGBRWCN) +"RTN","TMGMISC",1715,0) +BN2Done quit +"RTN","TMGMISC",1716,0) + +"RTN","TMGMISC",1717,0) +ShowNod2(pArray,order,countNodes) +"RTN","TMGMISC",1718,0) + ;"Purpose: To display all the nodes of the given array +"RTN","TMGMISC",1719,0) + ;" UPDATED function to use Scroller box. +"RTN","TMGMISC",1720,0) + ;"Input: pArray -- NAME OF array to display +"RTN","TMGMISC",1721,0) + ;" order -- OPTIONAL, default=1; 1 for forward, -1 for backwards order +"RTN","TMGMISC",1722,0) + ;" countNodes -- OPTIONAL, default=0; 1=show number of child nodes. +"RTN","TMGMISC",1723,0) + ;"Results: returns NAME OF next node to display (or "" if none) +"RTN","TMGMISC",1724,0) + +"RTN","TMGMISC",1725,0) + new TMGi,Option +"RTN","TMGMISC",1726,0) + new dispArray,dispI set dispI=1 +"RTN","TMGMISC",1727,0) + set order=$get(order,1) +"RTN","TMGMISC",1728,0) + set countNodes=$get(countNodes,0) +"RTN","TMGMISC",1729,0) + ; +"RTN","TMGMISC",1730,0) + set TMGi="" for set TMGi=$order(@pArray@(TMGi),order) quit:(TMGi="") do +"RTN","TMGMISC",1731,0) + . new s set s=" +---["_TMGi_"]" +"RTN","TMGMISC",1732,0) + . if countNodes=1 set s=s_"("_$$ListCt($name(@pArray@(TMGi)))_")" +"RTN","TMGMISC",1733,0) + . new s2 set s2=$extract($get(@pArray@(TMGi)),1,40) +"RTN","TMGMISC",1734,0) + . if s2'="" set s=s_"="_s2 +"RTN","TMGMISC",1735,0) + . if $data(@pArray@(TMGi))>9 set s=s_" ..." +"RTN","TMGMISC",1736,0) + . set dispArray(dispI,s)=$name(@pArray@(TMGi)),dispI=dispI+1 +"RTN","TMGMISC",1737,0) + if $data(dispArray)=0 set dispArray(dispI,"")="",dispI=dispI+1 +"RTN","TMGMISC",1738,0) + ; +"RTN","TMGMISC",1739,0) + set Option("HEADER",1)="Data for "_pArray +"RTN","TMGMISC",1740,0) + set Option("FOOTER",1,1)="? Help" +"RTN","TMGMISC",1741,0) + set Option("FOOTER",1,2)="LEFT Backup" +"RTN","TMGMISC",1742,0) + set Option("FOOTER",1,3)="RIGHT Browse IN" +"RTN","TMGMISC",1743,0) + set Option("ON SELECT")="HndOnSel^TMGMISC" +"RTN","TMGMISC",1744,0) + set Option("ON CMD")="HndOnCmd^TMGMISC" +"RTN","TMGMISC",1745,0) + ; +"RTN","TMGMISC",1746,0) + write # +"RTN","TMGMISC",1747,0) + do Scroller^TMGUSRIF("dispArray",.Option) +"RTN","TMGMISC",1748,0) + quit pArray +"RTN","TMGMISC",1749,0) + +"RTN","TMGMISC",1750,0) +HndOnSel(pArray,Option,Info) +"RTN","TMGMISC",1751,0) + ;"Purpose: handle ON SELECT event from Scroller^TMGUSRIF, launched by ShowNod2 +"RTN","TMGMISC",1752,0) + ;"Input: pArray,Option,Info -- see documentation in Scroller^TMGUSRIF +"RTN","TMGMISC",1753,0) + ;" Info has this: +"RTN","TMGMISC",1754,0) + ;" Info("CURRENT LINE","NUMBER")=number currently highlighted line +"RTN","TMGMISC",1755,0) + ;" Info("CURRENT LINE","TEXT")=Text of currently highlighted line +"RTN","TMGMISC",1756,0) + ;" Info("CURRENT LINE","RETURN")=return value of currently highlighted line +"RTN","TMGMISC",1757,0) + ; +"RTN","TMGMISC",1758,0) + new ref set ref=$get(Info("CURRENT LINE","RETURN")) +"RTN","TMGMISC",1759,0) + if ref'="" if $$ShowNod2(ref,TMGBRWORDER,TMGBRWCN) +"RTN","TMGMISC",1760,0) + quit +"RTN","TMGMISC",1761,0) + +"RTN","TMGMISC",1762,0) + +"RTN","TMGMISC",1763,0) +HndOnCmd(pArray,Option,Info) +"RTN","TMGMISC",1764,0) + ;"Purpose: handle ON SELECT event from Scroller, launched by ShowNod2 +"RTN","TMGMISC",1765,0) + ;"Input: pArray,Option,Info -- see documentation in Scroller +"RTN","TMGMISC",1766,0) + ;" Info has this: +"RTN","TMGMISC",1767,0) + ;" Info("USER INPUT")=input +"RTN","TMGMISC",1768,0) + ;" Info("CURRENT LINE","NUMBER")=number currently highlighted line +"RTN","TMGMISC",1769,0) + ;" Info("CURRENT LINE","TEXT")=Text of currently highlighted line +"RTN","TMGMISC",1770,0) + ;" Info("CURRENT LINE","RETURN")=return value of currently highlighted line +"RTN","TMGMISC",1771,0) + ;" TMGSCLRMSG,TMGBRWORDER,TMGBRWCN - globally scoped variables that are used. +"RTN","TMGMISC",1772,0) + ;"results: none (required to have none) +"RTN","TMGMISC",1773,0) + +"RTN","TMGMISC",1774,0) + new input set input=$$UP^XLFSTR($get(Info("USER INPUT"))) +"RTN","TMGMISC",1775,0) + if input["LEFT" do +"RTN","TMGMISC",1776,0) + . set TMGSCLRMSG="^" +"RTN","TMGMISC",1777,0) + else if input["RIGHT" do +"RTN","TMGMISC",1778,0) + . new ref set ref=$get(Info("CURRENT LINE","RETURN")) +"RTN","TMGMISC",1779,0) + . if ref'="" if $$ShowNod2(ref,TMGBRWORDER,TMGBRWCN) +"RTN","TMGMISC",1780,0) + else if input="?" do +"RTN","TMGMISC",1781,0) + . write !,"Use UP and DOWN cursor keys to select global node",! +"RTN","TMGMISC",1782,0) + . write "LEFT will back up, and RIGHT or ENTER will browse node",! +"RTN","TMGMISC",1783,0) + . write "^ at the ':' prompt will cause a back up of one level",! +"RTN","TMGMISC",1784,0) + . do PressToCont^TMGUSRIF +"RTN","TMGMISC",1785,0) + else if input'="" do +"RTN","TMGMISC",1786,0) + . write !,"Input ",$get(Info("USER INPUT"))," not recognized.",! +"RTN","TMGMISC",1787,0) + . do PressToCont^TMGUSRIF +"RTN","TMGMISC",1788,0) + ; +"RTN","TMGMISC",1789,0) + write # +"RTN","TMGMISC",1790,0) + quit +"RTN","TMGMISC",1791,0) + +"RTN","TMGMISC",1792,0) + +"RTN","TMGMISC",1793,0) +IsNumeric(value) +"RTN","TMGMISC",1794,0) + ;"Purpose: to determine if value is pure numeric. +"RTN","TMGMISC",1795,0) + ;"Note: This will be a more involved test than simply: if +value=value, because +"RTN","TMGMISC",1796,0) + ;" +"00001" is not the same as "1" or 1. Also +"123abc"--> 123, but is not pure numeric +"RTN","TMGMISC",1797,0) + set value=$$Trim^TMGSTUTL(value) ;" trim whitespace +"RTN","TMGMISC",1798,0) + set value=$$TrimL^TMGSTUTL(value,"0") ;"trim leading zeros +"RTN","TMGMISC",1799,0) + quit (value=+value) +"RTN","TMGMISC",1800,0) + +"RTN","TMGMISC",1801,0) + +"RTN","TMGMISC",1802,0) +ClipDDigits(Num,digits) +"RTN","TMGMISC",1803,0) + ;"Purpose: to clip number to specified number of decimal digits +"RTN","TMGMISC",1804,0) + ;" e.g. 1234.9876543 --> 1234.9876 if digits=4 +"RTN","TMGMISC",1805,0) + ;"Input: Num -- the number to process +"RTN","TMGMISC",1806,0) + ;" digits -- the number of allowed decimal digits after the decimal point +"RTN","TMGMISC",1807,0) + ;"Result: returns the number clipped to the specified number of decimals +"RTN","TMGMISC",1808,0) + ;" note: this is a CLIP, not a ROUND function +"RTN","TMGMISC",1809,0) + +"RTN","TMGMISC",1810,0) + new result set result=Num +"RTN","TMGMISC",1811,0) + new decimals set decimals=$extract($piece(Num,".",2),1,digits) +"RTN","TMGMISC",1812,0) + set result=$piece(Num,".",1) +"RTN","TMGMISC",1813,0) + if decimals'="" set result=result_"."_decimals +"RTN","TMGMISC",1814,0) +CDgDone +"RTN","TMGMISC",1815,0) + quit result +"RTN","TMGMISC",1816,0) + +"RTN","TMGMISC",1817,0) + +"RTN","TMGMISC",1818,0) +Diff(File,IENS1,IENS2,Result) +"RTN","TMGMISC",1819,0) + ;"Purpose: to determine how two records differ in a given file +"RTN","TMGMISC",1820,0) + ;"Input: File -- file name or number of file containing records to be compared +"RTN","TMGMISC",1821,0) + ;" IENS1 -- the IEN (or IENS if file is a subfile) of the first record to be compared +"RTN","TMGMISC",1822,0) + ;" IENS2 -- the IEN (or IENS if file is a subfile) of the second record to be compared +"RTN","TMGMISC",1823,0) + ;" Result -- PASS BE REFERENCE, and OUT PARAMETER +"RTN","TMGMISC",1824,0) + ;" Format of output Result array. Will only hold differences +"RTN","TMGMISC",1825,0) + ;" e.g. Result(FieldNum,"EXTRA",1)=valueOfField +"RTN","TMGMISC",1826,0) + ;" e.g. Result(FieldNum,"EXTRA",2)=valueOfField +"RTN","TMGMISC",1827,0) + ;" e.g. Result(FieldNum,"CONFLICT",1)=valueOfField +"RTN","TMGMISC",1828,0) + ;" e.g. Result(FieldNum,"CONFLICT",2)=valueOfField +"RTN","TMGMISC",1829,0) + ;" e.g. Result(FieldNum,"FIELD NAMES")=FieldName +"RTN","TMGMISC",1830,0) + ;"Note: this will consider only the first 1024 characters of WP fields +"RTN","TMGMISC",1831,0) + ;"Note: For now, multiples (subfiles) will be IGNORED +"RTN","TMGMISC",1832,0) + +"RTN","TMGMISC",1833,0) + new fileNum set fileNum=+$get(File) +"RTN","TMGMISC",1834,0) + if fileNum=0 set fileNum=$$GetFileNum^TMGDBAPI(.File) +"RTN","TMGMISC",1835,0) + new subFileNum +"RTN","TMGMISC",1836,0) + +"RTN","TMGMISC",1837,0) + new field set field=$order(^DD(fileNum,0)) +"RTN","TMGMISC",1838,0) + if +field>0 for do quit:(+field'>0) +"RTN","TMGMISC",1839,0) + . set subFileNum=+$piece($get(^DD(fileNum,field,0)),"^",2) ;"get subfile number, or 0 if not subfile +"RTN","TMGMISC",1840,0) + . if subFileNum>0 do ;"finish later... +"RTN","TMGMISC",1841,0) + . . ;"Here I need to somehow cycle through each record of the subfile and compare THOSE +"RTN","TMGMISC",1842,0) + . . new subResult +"RTN","TMGMISC",1843,0) + . . do DiffSubFile(subFileNum,.IENS1,.IENS2,.subResult) ;"null function for now +"RTN","TMGMISC",1844,0) + . . ;"do some merge between Result and subResult +"RTN","TMGMISC",1845,0) + . else do Diff1Field(fileNum,field,.IENS1,.IENS2,.Result) +"RTN","TMGMISC",1846,0) + . set field=$order(^DD(fileNum,field)) +"RTN","TMGMISC",1847,0) + +"RTN","TMGMISC",1848,0) + quit +"RTN","TMGMISC",1849,0) + +"RTN","TMGMISC",1850,0) + +"RTN","TMGMISC",1851,0) +Diff1Field(File,Field,IENS1,IEN2,Result) +"RTN","TMGMISC",1852,0) + ;"Purpose: to determine how two records differ for one given field +"RTN","TMGMISC",1853,0) + ;"Input: File -- file NUMBER of file containing records to be compared +"RTN","TMGMISC",1854,0) + ;" Field -- Field NUMBER to be evaluated +"RTN","TMGMISC",1855,0) + ;" IENS1 -- the IEN (or IENS if file is a subfile) of the first record to be compared +"RTN","TMGMISC",1856,0) + ;" IENS2 -- the IEN (or IENS if file is a subfile) of the second record to be compared +"RTN","TMGMISC",1857,0) + ;" Result -- PASS BE REFERENCE, and OUT PARAMETER +"RTN","TMGMISC",1858,0) + ;" Format of output Result array. Will only hold differences +"RTN","TMGMISC",1859,0) + ;" e.g. Result(FieldNum,"EXTRA",1)=valueOfField +"RTN","TMGMISC",1860,0) + ;" e.g. Result(FieldNum,"EXTRA",2)=valueOfField +"RTN","TMGMISC",1861,0) + ;" e.g. Result(FieldNum,"CONFLICT",1)=valueOfField +"RTN","TMGMISC",1862,0) + ;" e.g. Result(FieldNum,"CONFLICT",2)=valueOfField +"RTN","TMGMISC",1863,0) + ;" e.g. Result(FieldNum,"FIELD NAMES")=FieldName +"RTN","TMGMISC",1864,0) + ;"Results: none (data returned in Result out parameter) +"RTN","TMGMISC",1865,0) + ;"Note: only first 1023 characters of a WP field will be compared +"RTN","TMGMISC",1866,0) + +"RTN","TMGMISC",1867,0) + new value1,value2,TMGWP1,TMGWP2 +"RTN","TMGMISC",1868,0) + new fieldName set fieldName=$piece($get(^DD(File,Field,0)),"^",1) +"RTN","TMGMISC",1869,0) + +"RTN","TMGMISC",1870,0) + set value1=$$GET1^DIQ(File,IENS1,Field,"","TMGWP1") +"RTN","TMGMISC",1871,0) + set value2=$$GET1^DIQ(File,IENS2,Field,"","TMGWP2") +"RTN","TMGMISC",1872,0) + +"RTN","TMGMISC",1873,0) + if $data(TMGWP1)!$data(TMGWP2) do +"RTN","TMGMISC",1874,0) + . set value1=$$WPToStr^TMGSTUTL("TMGWP1"," ",1023) ;"Turn first 1023 characters into one long string +"RTN","TMGMISC",1875,0) + . set value2=$$WPToStr^TMGSTUTL("TMGWP2"," ",1023) ;"Turn first 1023 characters into one long string +"RTN","TMGMISC",1876,0) + +"RTN","TMGMISC",1877,0) + if value1=value2 goto D1FDone ;"default is no conflict +"RTN","TMGMISC",1878,0) + if (value2="")&(value1'="") do +"RTN","TMGMISC",1879,0) + . set Result(Field,"EXTRA",1)=value1 +"RTN","TMGMISC",1880,0) + . set Result(Field,"FIELD NAME")=fieldName +"RTN","TMGMISC",1881,0) + if (value1="")&(value2'="") do +"RTN","TMGMISC",1882,0) + . set Result(Field,"EXTRA",2)=value2 +"RTN","TMGMISC",1883,0) + . set Result(Field,"FIELD NAME")=fieldName +"RTN","TMGMISC",1884,0) + if (value1'="")&(value2'="") do +"RTN","TMGMISC",1885,0) + . set Result(Field,"CONFLICT",1)=value1 +"RTN","TMGMISC",1886,0) + . set Result(Field,"CONFLICT",2)=value2 +"RTN","TMGMISC",1887,0) + . set Result(Field,"FIELD NAME")=fieldName +"RTN","TMGMISC",1888,0) + +"RTN","TMGMISC",1889,0) +D1FDone +"RTN","TMGMISC",1890,0) + quit +"RTN","TMGMISC",1891,0) + +"RTN","TMGMISC",1892,0) +DiffSubFile(SubFile,IENS1,IENS2,Result) +"RTN","TMGMISC",1893,0) + +"RTN","TMGMISC",1894,0) + quit +"RTN","TMGMISC",1895,0) + +"RTN","TMGMISC",1896,0) + +"RTN","TMGMISC",1897,0) + +"RTN","TMGMISC",1898,0) +Array2XML(pArray,pResult,indent) +"RTN","TMGMISC",1899,0) + ;"Purpose: to convert an array into XML format +"RTN","TMGMISC",1900,0) + ;"Input: pArray -- the NAME OF the array to convert (array can be any format) +"RTN","TMGMISC",1901,0) + ;" pResult -- the NAME OF the output array. +"RTN","TMGMISC",1902,0) + ;" format: +"RTN","TMGMISC",1903,0) + ;" Result(0)="" +"RTN","TMGMISC",1904,0) + ;" Result(1)="Node Value +"RTN","TMGMISC",1905,0) + ;" Result(2)=" Node Value +"RTN","TMGMISC",1906,0) + ;" Result(3)=" Node Value +"RTN","TMGMISC",1907,0) + ;" Result(4)=" Node Value ;"<--- start subnode +"RTN","TMGMISC",1908,0) + ;" Result(5)=" Node Value +"RTN","TMGMISC",1909,0) + ;" Result(6)=" Node Value +"RTN","TMGMISC",1910,0) + ;" Result(7)=" ;"<---- end subnode +"RTN","TMGMISC",1911,0) + ;" Result(8)=" Node Value +"RTN","TMGMISC",1912,0) + ;" indent -- OPTIONAL. if 1, then subnodes have whitespace indent for pretty viewing +"RTN","TMGMISC",1913,0) + ;"Output: pResult is filled +"RTN","TMGMISC",1914,0) + ;"Result: none. +"RTN","TMGMISC",1915,0) + ;"Note: example call do Array2XML("MyArray","MyOutput",1) +"RTN","TMGMISC",1916,0) + +"RTN","TMGMISC",1917,0) + kill @pResult +"RTN","TMGMISC",1918,0) + set @pResult@(0)=0 +"RTN","TMGMISC",1919,0) + if $get(indent)=1 set indent="" +"RTN","TMGMISC",1920,0) + else set indent=-1 +"RTN","TMGMISC",1921,0) + do A2XNode(pArray,pResult,.indent) +"RTN","TMGMISC",1922,0) + set @pResult@(0)=$$XMLHDR^MXMLUTL +"RTN","TMGMISC",1923,0) + +"RTN","TMGMISC",1924,0) + quit +"RTN","TMGMISC",1925,0) + +"RTN","TMGMISC",1926,0) + +"RTN","TMGMISC",1927,0) +A2XNode(pArray,pResult,indent) +"RTN","TMGMISC",1928,0) + ;"Purpose: To do the output for Array2XML +"RTN","TMGMISC",1929,0) + ;"Input: pArray - the NAME OF the array to convert +"RTN","TMGMISC",1930,0) + ;" pResult - the NAME OF the output array. +"RTN","TMGMISC",1931,0) + ;" Format to be as described in Array2XML, which one exception: Result(0)=MaxLine +"RTN","TMGMISC",1932,0) + ;" indent -- OPTIONAL. if numeric value, then subnodes WON't whitespace indent for pretty viewing +"RTN","TMGMISC",1933,0) + ;" otherwise, indent is string holding space to indent +"RTN","TMGMISC",1934,0) + ;"Result: none +"RTN","TMGMISC",1935,0) + +"RTN","TMGMISC",1936,0) + new i,s +"RTN","TMGMISC",1937,0) + set indent=$get(indent) +"RTN","TMGMISC",1938,0) + set i=$order(@pArray@("")) +"RTN","TMGMISC",1939,0) + if i'="" for do quit:(i="") +"RTN","TMGMISC",1940,0) + . set s="" if indent'=-1 set s=indent +"RTN","TMGMISC",1941,0) + . set s=s_""_$get(@pArray@(i)) +"RTN","TMGMISC",1942,0) + . set s=$$SYMENC^MXMLUTL(s) +"RTN","TMGMISC",1943,0) + . if $data(@pArray@(i))>1 do +"RTN","TMGMISC",1944,0) + . . set @pResult@(0)=+$get(@pResult@(0))+1 ;"Increment maxline +"RTN","TMGMISC",1945,0) + . . set @pResult@(@pResult@(0))=s +"RTN","TMGMISC",1946,0) + . . new subIndent set subIndent=-1 +"RTN","TMGMISC",1947,0) + . . if indent'=-1 set subIndent=indent_" " +"RTN","TMGMISC",1948,0) + . . do A2XNode($name(@pArray@(i)),pResult,subIndent) +"RTN","TMGMISC",1949,0) + . . set s="" if indent'=-1 set s=indent +"RTN","TMGMISC",1950,0) + . . set s=s_"" +"RTN","TMGMISC",1951,0) + . else do +"RTN","TMGMISC",1952,0) + . . set s=s_"" +"RTN","TMGMISC",1953,0) + . set @pResult@(0)=+$get(@pResult@(0))+1 ;"Increment maxline +"RTN","TMGMISC",1954,0) + . set @pResult@(@pResult@(0))=s +"RTN","TMGMISC",1955,0) + . set i=$order(@pArray@(i)) +"RTN","TMGMISC",1956,0) + +"RTN","TMGMISC",1957,0) + quit +"RTN","TMGMISC",1958,0) + +"RTN","TMGMISC",1959,0) + +"RTN","TMGMISC",1960,0) +Up(pArray) +"RTN","TMGMISC",1961,0) + ;"Purpose: Return a NAME of an array that is one level 'up' from the +"RTN","TMGMISC",1962,0) + ;" the current array. This really means one node shorter. +"RTN","TMGMISC",1963,0) + ;" e.g. '^MyVar('plant','tree','apple tree')' --> '^MyVar('plant','tree')' +"RTN","TMGMISC",1964,0) + ;"Results: returns shorten array as above, or "" if error +"RTN","TMGMISC",1965,0) + +"RTN","TMGMISC",1966,0) + new result set result="" +"RTN","TMGMISC",1967,0) + if $get(pArray)="" goto UpDone +"RTN","TMGMISC",1968,0) + set result=$qsubscript(pArray,0) +"RTN","TMGMISC",1969,0) + new i +"RTN","TMGMISC",1970,0) + for i=1:1:$qlength(pArray)-1 do +"RTN","TMGMISC",1971,0) + . set result=$name(@result@($qsubscript(pArray,i))) +"RTN","TMGMISC",1972,0) + +"RTN","TMGMISC",1973,0) +UpDone quit result +"RTN","TMGMISC",1974,0) + +"RTN","TMGMISC",1975,0) + +"RTN","TMGMISC",1976,0) +LaunchScreenman(File,FormIEN,RecIEN,Page) +"RTN","TMGMISC",1977,0) + ;"Purpose: to provide a programatic launching point for displaying a +"RTN","TMGMISC",1978,0) + ;" screenman form for editing a record +"RTN","TMGMISC",1979,0) + ;"Input: File -- the IEN of file to be edited +"RTN","TMGMISC",1980,0) + ;" FormIEN -- the IEN in file FORM (.403) +"RTN","TMGMISC",1981,0) + ;" RecIEN -- the IEN in File to edit +"RTN","TMGMISC",1982,0) + ;" Page -- OPTIONAL, default=1. The starting page of form. +"RTN","TMGMISC",1983,0) + ;"Note: Form should be compiled before calling the function. This can be +"RTN","TMGMISC",1984,0) + ;" achieved by running the form once from ^DDSRUN (or viat Fileman menu) +"RTN","TMGMISC",1985,0) + +"RTN","TMGMISC",1986,0) + new DDSFILE set DDSFILE=File +"RTN","TMGMISC",1987,0) + new DDSRUNDR set DDSRUNDR=FormIEN +"RTN","TMGMISC",1988,0) + new DDSPAGE set DDSPAGE=+$get(Page,1) +"RTN","TMGMISC",1989,0) + new DA set DA=RecIEN +"RTN","TMGMISC",1990,0) + +"RTN","TMGMISC",1991,0) + do REC+9^DDSRUN ;"this goes against SAC conventions. +"RTN","TMGMISC",1992,0) + +"RTN","TMGMISC",1993,0) + quit +"RTN","TMGMISC",1994,0) + +"RTN","TMGMISC",1995,0) + +"RTN","TMGMISC",1996,0) +NumSigChs() +"RTN","TMGMISC",1997,0) + ;"Purpose: To determine how many characters are signficant in a variable name +"RTN","TMGMISC",1998,0) + ;" I.e. older versions of GT.M had only the first 8 characters as +"RTN","TMGMISC",1999,0) + ;" significant. Newer versions allow more characters to be significant. +"RTN","TMGMISC",2000,0) + +"RTN","TMGMISC",2001,0) + new pVar1,pVar2,i +"RTN","TMGMISC",2002,0) + set pVar1="zb",i=2 +"RTN","TMGMISC",2003,0) + new done set done=0 +"RTN","TMGMISC",2004,0) + for do quit:done +"RTN","TMGMISC",2005,0) + . set i=i+1 +"RTN","TMGMISC",2006,0) + . set pVar2=pVar1_"b" +"RTN","TMGMISC",2007,0) + . set pVar1=pVar1_"a" +"RTN","TMGMISC",2008,0) + . new @pVar2,@pVar1 +"RTN","TMGMISC",2009,0) + . set @pVar1=7 +"RTN","TMGMISC",2010,0) + . if $get(@pVar2)=@pVar1 set done=1 +"RTN","TMGMISC",2011,0) + +"RTN","TMGMISC",2012,0) + quit (i-1) +"RTN","TMGMISC",2013,0) + +"RTN","TMGMISC",2014,0) + +"RTN","TMGMISC",2015,0) +SrchReplace(File,Field,Caption) +"RTN","TMGMISC",2016,0) + ;"Purpose: To do a text-based search and replace in all record of +"RTN","TMGMISC",2017,0) + ;" specified file, in the text of the specified file. +"RTN","TMGMISC",2018,0) + ;" Note: this does not work with pointer fields. It would +"RTN","TMGMISC",2019,0) + ;" fail to find the matching text in the pointer value and ignore it. +"RTN","TMGMISC",2020,0) + ;" It does not support subfiles. +"RTN","TMGMISC",2021,0) + ;"Input: File -- the file name or number to work with. +"RTN","TMGMISC",2022,0) + ;" Field -- the field name or number to work with +"RTN","TMGMISC",2023,0) + ;" Caption -- OPTIONAL. A descriptive text of action. +"RTN","TMGMISC",2024,0) + ;"Output: Data in records will be changed via Fileman and errors (if found) +"RTN","TMGMISC",2025,0) + ;" will be written to console. +"RTN","TMGMISC",2026,0) + ;"Results: none. +"RTN","TMGMISC",2027,0) + +"RTN","TMGMISC",2028,0) + if $get(File)="" goto SRDone +"RTN","TMGMISC",2029,0) + if $get(Field)="" goto SRDone +"RTN","TMGMISC",2030,0) + new OKToCont set OKToCont=1 +"RTN","TMGMISC",2031,0) + if +Field'=Field set OKToCont=$$SetFileFldNums^TMGDBAPI(File,Field,.File,.Field) +"RTN","TMGMISC",2032,0) + if OKToCont=0 goto SRDone +"RTN","TMGMISC",2033,0) + +"RTN","TMGMISC",2034,0) + if $get(Caption)'="" do +"RTN","TMGMISC",2035,0) + . write !,!,Caption,! +"RTN","TMGMISC",2036,0) + . write "----------------------------------------------------",!! +"RTN","TMGMISC",2037,0) + +"RTN","TMGMISC",2038,0) + new searchS,replaceS,% +"RTN","TMGMISC",2039,0) +SR1 +"RTN","TMGMISC",2040,0) + write "Enter characters/words to SEARCH for (^ to abort): " +"RTN","TMGMISC",2041,0) + read searchS:$get(DTIME,3600),! +"RTN","TMGMISC",2042,0) + if (searchS="")!(searchS="^") goto SRDone +"RTN","TMGMISC",2043,0) + write "REPLACE with (^ to abort): " +"RTN","TMGMISC",2044,0) + read replaceS:$get(DTIME,3600),! +"RTN","TMGMISC",2045,0) + if (replaceS="^") goto SRDone +"RTN","TMGMISC",2046,0) + write "'",searchS,"'-->'",replaceS,"'",! +"RTN","TMGMISC",2047,0) + set %=1 +"RTN","TMGMISC",2048,0) + write "OK" do YN^DICN write ! +"RTN","TMGMISC",2049,0) + if %=1 goto SR2 +"RTN","TMGMISC",2050,0) + if %=-1 goto SRDone +"RTN","TMGMISC",2051,0) + goto SR1 +"RTN","TMGMISC",2052,0) + +"RTN","TMGMISC",2053,0) +SR2 +"RTN","TMGMISC",2054,0) + new Itr,IEN,CurValue,abort,count +"RTN","TMGMISC",2055,0) + new ref set ref=$get(^DIC(File,0,"GL")) +"RTN","TMGMISC",2056,0) + set ref=$$CREF^DILF(ref) +"RTN","TMGMISC",2057,0) + if ref="" goto SRDone +"RTN","TMGMISC",2058,0) + new node set node=$piece($get(^DD(File,Field,0)),"^",4) +"RTN","TMGMISC",2059,0) + new piece set piece=$piece(node,";",2) +"RTN","TMGMISC",2060,0) + set node=$piece(node,";",1) +"RTN","TMGMISC",2061,0) + +"RTN","TMGMISC",2062,0) + set abort=0,count=0 +"RTN","TMGMISC",2063,0) + set IEN=$$ItrInit^TMGITR(File,.Itr) +"RTN","TMGMISC",2064,0) + do PrepProgress^TMGITR(.Itr,20,0,"IEN") +"RTN","TMGMISC",2065,0) + if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort +"RTN","TMGMISC",2066,0) + . if $$UserAborted^TMGUSRIF() set abort=1 quit +"RTN","TMGMISC",2067,0) + . set CurValue=$piece($get(@ref@(IEN,node)),"^",piece) +"RTN","TMGMISC",2068,0) + . if CurValue'[searchS quit +"RTN","TMGMISC",2069,0) +SR3 . new newValue set newValue=$$Substitute^TMGSTUTL(CurValue,searchS,replaceS) +"RTN","TMGMISC",2070,0) + . new TMGFDA,TMGMSG +"RTN","TMGMISC",2071,0) + . set TMGFDA(File,IEN_",",Field)=newValue +"RTN","TMGMISC",2072,0) + . do FILE^DIE("K","TMGFDA","TMGMSG") +"RTN","TMGMISC",2073,0) + . do ShowIfDIERR^TMGDEBUG(.TMGMSG) +"RTN","TMGMISC",2074,0) + . set count=count+1 +"RTN","TMGMISC",2075,0) + do ProgressDone^TMGITR(.Itr) +"RTN","TMGMISC",2076,0) + +"RTN","TMGMISC",2077,0) + write count," records changed",! +"RTN","TMGMISC",2078,0) + do PressToCont^TMGUSRIF +"RTN","TMGMISC",2079,0) + +"RTN","TMGMISC",2080,0) +SRDone +"RTN","TMGMISC",2081,0) + quit +"RTN","TMGMISC",2082,0) + +"RTN","TMGMISC",2083,0) + +"RTN","TMGMISC",2084,0) +MkMultList(input,List) +"RTN","TMGMISC",2085,0) + ;"Purpose: To create a list of entries, given a string containing a list of entries. +"RTN","TMGMISC",2086,0) + ;"Input: input -- a string of user input. E.g.: '345,3,12678,78-85,2' or '78-93' or '15' +"RTN","TMGMISC",2087,0) + ;" List -- PASS BY REFERENCE. An OUT PARAMETER. +"RTN","TMGMISC",2088,0) + ;"Output: List will be filled as follows: +"RTN","TMGMISC",2089,0) + ;" List(Entry number)="" +"RTN","TMGMISC",2090,0) + ;" List(Entry number)="" +"RTN","TMGMISC",2091,0) + ;" List(Entry number)="" +"RTN","TMGMISC",2092,0) + ;"Result: 1 if values found, 0 none found, or error encountered +"RTN","TMGMISC",2093,0) + +"RTN","TMGMISC",2094,0) + new result set result=0 +"RTN","TMGMISC",2095,0) + +"RTN","TMGMISC",2096,0) + new i +"RTN","TMGMISC",2097,0) + for i=1:1:$length(input,",") do +"RTN","TMGMISC",2098,0) + . new value set value=$piece(input,",",i) +"RTN","TMGMISC",2099,0) + . if +value=value do +"RTN","TMGMISC",2100,0) + . . set List(value)="" +"RTN","TMGMISC",2101,0) + . . set result=1 +"RTN","TMGMISC",2102,0) + . else if value["-" do +"RTN","TMGMISC",2103,0) + . . new n1,n2 +"RTN","TMGMISC",2104,0) + . . set n1=+$piece(value,"-",1) +"RTN","TMGMISC",2105,0) + . . set n2=+$piece(value,"-",2) +"RTN","TMGMISC",2106,0) + . . set result=$$MkRangeList(n1,n2,.List) +"RTN","TMGMISC",2107,0) + +"RTN","TMGMISC",2108,0) + quit result +"RTN","TMGMISC",2109,0) + +"RTN","TMGMISC",2110,0) + +"RTN","TMGMISC",2111,0) +MkRangeList(Num,EndNum,List) +"RTN","TMGMISC",2112,0) + ;"Purpose: To create a list of entries, given a starting and ending number +"RTN","TMGMISC",2113,0) + ;"Input: Num -- the start entry number +"RTN","TMGMISC",2114,0) + ;" EndNum -- OPTIONAL, the last entry number (if supplied then all values +"RTN","TMGMISC",2115,0) + ;" between Num and Endnum will be added to list +"RTN","TMGMISC",2116,0) + ;" List -- PASS BY REFERENCE. An OUT PARAMETER. +"RTN","TMGMISC",2117,0) + ;"Output: List will be filled as follows: +"RTN","TMGMISC",2118,0) + ;" List(Entry number)="" +"RTN","TMGMISC",2119,0) + ;" List(Entry number)="" +"RTN","TMGMISC",2120,0) + ;" List(Entry number)="" +"RTN","TMGMISC",2121,0) + ;"Result: 1 if value input found, otherwise 0 +"RTN","TMGMISC",2122,0) + +"RTN","TMGMISC",2123,0) + new result set result=0 +"RTN","TMGMISC",2124,0) + set EndNum=$get(EndNum,Num) +"RTN","TMGMISC",2125,0) + if (+Num'=Num)!(+EndNum'=EndNum) goto MkRLDone +"RTN","TMGMISC",2126,0) + +"RTN","TMGMISC",2127,0) + new i +"RTN","TMGMISC",2128,0) + for i=Num:1:EndNum do +"RTN","TMGMISC",2129,0) + . set List(i)="" +"RTN","TMGMISC",2130,0) + . set result=1 +"RTN","TMGMISC",2131,0) + +"RTN","TMGMISC",2132,0) +MkRLDone +"RTN","TMGMISC",2133,0) + quit result +"RTN","TMGMISC",2134,0) + +"RTN","TMGMISC",2135,0) + +"RTN","TMGMISC",2136,0) +Flags(Var,Flag,Mode) +"RTN","TMGMISC",2137,0) + ;"Purpose: To set,delete,or toggle a flag stored in Var +"RTN","TMGMISC",2138,0) + ;"Input: Var -- PASS BY REFERENCE. The variable holding the flags +"RTN","TMGMISC",2139,0) + ;" Flag -- a single character flag to be stored in Var +"RTN","TMGMISC",2140,0) + ;" Mode: should be: 'SET','DEL',or 'TOGGLE'. Default is 'SET' +"RTN","TMGMISC",2141,0) + ;"Results: none +"RTN","TMGMISC",2142,0) + +"RTN","TMGMISC",2143,0) + set Flag=$get(Flag,"SET") +"RTN","TMGMISC",2144,0) + set Var=$get(Var) +"RTN","TMGMISC",2145,0) + if $get(Mode)="TOGGLE" do +"RTN","TMGMISC",2146,0) + . if Var[Flag set Mode="DEL" +"RTN","TMGMISC",2147,0) + . else set Mode="SET" +"RTN","TMGMISC",2148,0) + if $get(Mode)="SET" do +"RTN","TMGMISC",2149,0) + . if Var[Flag quit +"RTN","TMGMISC",2150,0) + . set Var=Var_Flag +"RTN","TMGMISC",2151,0) + if $get(Mode)="DEL" do +"RTN","TMGMISC",2152,0) + . if Var'[Flag quit +"RTN","TMGMISC",2153,0) + . set Var=$piece(Var,Flag,1)_$piece(Var,Flag,2) +"RTN","TMGMISC",2154,0) + +"RTN","TMGMISC",2155,0) + quit +"RTN","TMGMISC",2156,0) + +"RTN","TMGMISC",2157,0) + +"RTN","TMGMISC",2158,0) +CompABArray(pArrayA,pArrayB,pExtraB,pMissingB,pDiff,ProgressFn,IncVar) +"RTN","TMGMISC",2159,0) + ;"Purpose: To compare two arrays, A & B, and return results in OutArray +"RTN","TMGMISC",2160,0) + ;" that specifies how ArrayB differs from ArrayA +"RTN","TMGMISC",2161,0) + ;"Input: pArrayA -- PASS BY NAME. Baseline array to be compared against +"RTN","TMGMISC",2162,0) + ;" pArrayB -- PASS BY NAME. Array to be compare against ArrayA +"RTN","TMGMISC",2163,0) + ;" pExtraB -- PASS BY NAME. An OUT PARAMETER. Array of extra info from B +"RTN","TMGMISC",2164,0) + ;" OPTIONAL. If not provided, then data not filled. +"RTN","TMGMISC",2165,0) + ;" pMissingB -- PASS BY NAME. An OUT PARAMETER. Array of missing info +"RTN","TMGMISC",2166,0) + ;" OPTIONAL. If not provided, then data not filled. +"RTN","TMGMISC",2167,0) + ;" pDiff -- PASS BY NAME. An OUT PARAMETER. Output as below. +"RTN","TMGMISC",2168,0) + ;" OPTIONAL. If not provided, then data not filled. +"RTN","TMGMISC",2169,0) + ;" @pOutArray@("A",node,node,node,...)=different value +"RTN","TMGMISC",2170,0) + ;" @pOutArray@("B",node,node,node,...)=different value +"RTN","TMGMISC",2171,0) + ;" ProgressFn -- OPTIONAL -- M code to exec as a progress indicator +"RTN","TMGMISC",2172,0) + ;" IncVar -- OPTIONAL -- a counter that can be referenced by ProgressFn +"RTN","TMGMISC",2173,0) + ;"Results: 0=OK, 1=aborted +"RTN","TMGMISC",2174,0) + +"RTN","TMGMISC",2175,0) + new indexA,indexB +"RTN","TMGMISC",2176,0) + +"RTN","TMGMISC",2177,0) + set IncVar=+$get(IncVar) +"RTN","TMGMISC",2178,0) + set ProgressFn=$get(ProgressFn) +"RTN","TMGMISC",2179,0) + set pExtraB=$get(pExtraB) +"RTN","TMGMISC",2180,0) + set pMissingB=$get(pMissingB) +"RTN","TMGMISC",2181,0) + set pdiff=$get(pDiff) +"RTN","TMGMISC",2182,0) + new abort set abort=0 +"RTN","TMGMISC",2183,0) + new Compared +"RTN","TMGMISC",2184,0) + +"RTN","TMGMISC",2185,0) + set indexA="" +"RTN","TMGMISC",2186,0) + for set indexA=$order(@pArrayA@(indexA)) quit:(indexA="")!abort do +"RTN","TMGMISC",2187,0) + . set IncVar=IncVar+1 +"RTN","TMGMISC",2188,0) + . if (IncVar#10=1),(ProgressFn'="") do quit:(abort) +"RTN","TMGMISC",2189,0) + . . new $etrap set $etrap="set $etrap="""",$ecode=""""" +"RTN","TMGMISC",2190,0) + . . xecute ProgressFn +"RTN","TMGMISC",2191,0) + . . write !,pArrayA,"(",indexA,") ",! do CUU^TMGTERM(2) ;"temp +"RTN","TMGMISC",2192,0) + . . if $$UserAborted^TMGUSRIF() set abort=1 quit +"RTN","TMGMISC",2193,0) + . if $data(@pArrayB@(indexA))=0 do quit +"RTN","TMGMISC",2194,0) + . . if (pMissingB'="") merge @pMissingB@(pArrayA,indexA)=@pArrayA@(indexA) +"RTN","TMGMISC",2195,0) + . new s1,s2 +"RTN","TMGMISC",2196,0) + . set s1=$get(@pArrayA@(indexA)) +"RTN","TMGMISC",2197,0) + . set s2=$get(@pArrayB@(indexA)) +"RTN","TMGMISC",2198,0) + . if s1'=s2 do +"RTN","TMGMISC",2199,0) + . . if pDiff="" quit +"RTN","TMGMISC",2200,0) + . . if $$TRIM^XLFSTR(s1)=$$TRIM^XLFSTR(s2) quit +"RTN","TMGMISC",2201,0) + . . set @pDiff@("A",pArrayA,indexA)=s1 +"RTN","TMGMISC",2202,0) + . . set @pDiff@("B",pArrayA,indexA)=s2 +"RTN","TMGMISC",2203,0) + . set abort=$$CompABArray($name(@pArrayA@(indexA)),$name(@pArrayB@(indexA)),.pExtraB,.pMissingB,.pDiff,.ProgressFn,.IncVar) +"RTN","TMGMISC",2204,0) + . set Compared($name(@pArrayA@(indexA)),$name(@pArrayB@(indexA)))=1 +"RTN","TMGMISC",2205,0) + +"RTN","TMGMISC",2206,0) + new temp set temp=1 +"RTN","TMGMISC",2207,0) + set indexB="" +"RTN","TMGMISC",2208,0) + for set indexB=$order(@pArrayB@(indexB)) quit:(indexB="")!abort do +"RTN","TMGMISC",2209,0) + . set temp=temp+1 +"RTN","TMGMISC",2210,0) + . if (temp#10=1) do quit:(abort) +"RTN","TMGMISC",2211,0) + . . write !,pArrayA,"(",indexB,") ",! do CUU^TMGTERM(2) ;"temp +"RTN","TMGMISC",2212,0) + . . if $$UserAborted^TMGUSRIF() set abort=1 quit +"RTN","TMGMISC",2213,0) + . if $data(@pArrayA@(indexB))=0 do quit +"RTN","TMGMISC",2214,0) + . . if (pExtraB'="") merge @pExtraB@(pArrayA,indexB)=@pArrayB@(indexB) +"RTN","TMGMISC",2215,0) + . if $get(Compared($name(@pArrayA@(indexB)),$name(@pArrayB@(indexB))))=1 do quit ;"already checked +"RTN","TMGMISC",2216,0) + . . new temp +"RTN","TMGMISC",2217,0) + . set abort=$$CompABArray($name(@pArrayA@(indexB)),$name(@pArrayB@(indexB)),.pExtraB,.pMissingB,.pDiff) +"RTN","TMGMISC",2218,0) + +"RTN","TMGMISC",2219,0) + quit abort +"RTN","TMGMISC",2220,0) + +"RTN","TMGMISC",2221,0) + +"RTN","TMGMISC",2222,0) +FixArray(ref) +"RTN","TMGMISC",2223,0) + ;"Purpose: Convert an array like this: +"RTN","TMGMISC",2224,0) + ;" @ref@("^DD(2,.362)",21,1,0) --> @ref@("^DD",2,.362,21,1,0) +"RTN","TMGMISC",2225,0) + ;" @ref@("^DD(2,.362)",21,2,0) --> @ref@("^DD",2,.362,21,2,0) +"RTN","TMGMISC",2226,0) + ;" @ref@("^DD(2,.362)",23,0) --> @ref@("^DD",2,.362,23,0) +"RTN","TMGMISC",2227,0) + ;" @ref@("^DD(2,.362)",23,1,0) --> @ref@("^DD",2,.362,23,1,0) +"RTN","TMGMISC",2228,0) + ;" @ref@("^DD(2,0,""IX"")","ACFL2",2,.312) --> @ref@("^DD",2,0,"IX","ACFL2",2,.312) +"RTN","TMGMISC",2229,0) + ;" @ref@("^DD(2,0,""IX"")","AEXP",2,.351) --> @ref@("^DD",2,0,"IX","AEXP",2,.351) +"RTN","TMGMISC",2230,0) + ;" @ref@("^DD(2,0,""IX"")","TMGS",2,22701) --> @ref@("^DD",2,0,"IX","TMGS",2,22701) +"RTN","TMGMISC",2231,0) + ;" @ref@("^DD(2,0,""PT"")",228.1,.02) --> @ref@("^DD",2,0,"PT",228.1,.02) +"RTN","TMGMISC",2232,0) + ;" @ref@("^DD(2,0,""PT"")",228.2,.02) --> @ref@("^DD",2,0,"PT",228.2,.02) +"RTN","TMGMISC",2233,0) + ;" @ref@("^DD(2,0,""PT"")",19620.92,.08) --> @ref@("^DD",2,0,"PT",19620.92,.08) +"RTN","TMGMISC",2234,0) + ;" @ref@("^DD(2,0,""PT"",115)",.01) --> @ref@("^DD",2,0,"PT",115,.01) +"RTN","TMGMISC",2235,0) + ;"Input: ref -- PASS BY NAME +"RTN","TMGMISC",2236,0) + ;"Output: contents of @ref are converted as above. +"RTN","TMGMISC",2237,0) + ;"Results: none +"RTN","TMGMISC",2238,0) + +"RTN","TMGMISC",2239,0) + new origRef set origRef=ref +"RTN","TMGMISC",2240,0) + new output,s1,i +"RTN","TMGMISC",2241,0) + for set ref=$query(@ref) quit:(ref="") do +"RTN","TMGMISC",2242,0) + . set s1=$qsubscript(ref,1) +"RTN","TMGMISC",2243,0) + . new newRef set newRef="output" +"RTN","TMGMISC",2244,0) + . new startI set startI=1 +"RTN","TMGMISC",2245,0) + . if s1["(" do +"RTN","TMGMISC",2246,0) + . . set startI=2 +"RTN","TMGMISC",2247,0) + . . set newRef=newRef_"("""_$qs(s1,0)_""")" +"RTN","TMGMISC",2248,0) + . . if $qlength(s1)>1 for i=1:1:$qlength(s1) do +"RTN","TMGMISC",2249,0) + . . . set newRef=$name(@newRef@($qsubscript(s1,i))) +"RTN","TMGMISC",2250,0) + . for i=startI:1:$qlength(ref) do +"RTN","TMGMISC",2251,0) + . . new s3 set s3=$qsubscript(ref,i) +"RTN","TMGMISC",2252,0) + . . set newRef=$name(@newRef@(s3)) +"RTN","TMGMISC",2253,0) + . merge @newRef=@ref +"RTN","TMGMISC",2254,0) + +"RTN","TMGMISC",2255,0) + kill @origRef +"RTN","TMGMISC",2256,0) + merge @origRef=output ;"put changes back into original array +"RTN","TMGMISC",2257,0) + +"RTN","TMGMISC",2258,0) + quit +"RTN","TMGMISC",2259,0) + +"RTN","TMGMISC",2260,0) + +"RTN","TMGMISC",2261,0) +Caller(Code) +"RTN","TMGMISC",2262,0) + ;"Purpose: From call stack, return the location of the caller of the function +"RTN","TMGMISC",2263,0) + ;" Note this will not return the address of the function calling +"RTN","TMGMISC",2264,0) + ;" Caller, but instead, the address of the function before that +"RTN","TMGMISC",2265,0) + ;" in the stack. +"RTN","TMGMISC",2266,0) + ;" So a function (A) can call this routine to find out who called it (A). +"RTN","TMGMISC",2267,0) + ;"Input: Code -- OPTIONAL. PASS BY REFERANCE, AN OUT PARAMETER +"RTN","TMGMISC",2268,0) + ;" Filled with line of calling code. +"RTN","TMGMISC",2269,0) + set Code=$STACK($STACK-2,"MCODE") +"RTN","TMGMISC",2270,0) + new result set result=$STACK($STACK-2,"PLACE") +"RTN","TMGMISC",2271,0) + if result="" set result="?" +"RTN","TMGMISC",2272,0) + quit result +"RTN","TMGMISC",2273,0) + +"RTN","TMGRPC1B") +0^8^B10826405 +"RTN","TMGRPC1B",1,0) +TMGRPC1B ;TMG/kst-RPC Functions ;3/28/10 +"RTN","TMGRPC1B",2,0) + ;;1.0;TMG-LIB;**1**;3/28/10;Build 1 +"RTN","TMGRPC1B",3,0) + ; +"RTN","TMGRPC1B",4,0) + ;"TMG RPC FUNCTIONS +"RTN","TMGRPC1B",5,0) + ; +"RTN","TMGRPC1B",6,0) + ;"Copyright Kevin Toppenberg MD +"RTN","TMGRPC1B",7,0) + ;"Released under GNU General Public License (GPL) +"RTN","TMGRPC1B",8,0) + ;" +"RTN","TMGRPC1B",9,0) + ;"======================================================================= +"RTN","TMGRPC1B",10,0) + ;" RPC -- Public Functions. +"RTN","TMGRPC1B",11,0) + ;"======================================================================= +"RTN","TMGRPC1B",12,0) + ;"EVALTIUO +"RTN","TMGRPC1B",13,0) + ;"INSTALL -- Add the RPC's to the OPTION record OR CPRS GUI CHART +"RTN","TMGRPC1B",14,0) + ;"======================================================================= +"RTN","TMGRPC1B",15,0) + ;"PRIVATE API FUNCTIONS +"RTN","TMGRPC1B",16,0) + ;"======================================================================= +"RTN","TMGRPC1B",17,0) + ;"INSTALL1(RPCNAME) -- Add 1 RPC to the OPTION record OR CPRS GUI CHART +"RTN","TMGRPC1B",18,0) + ; +"RTN","TMGRPC1B",19,0) + ;"======================================================================= +"RTN","TMGRPC1B",20,0) + ;"======================================================================= +"RTN","TMGRPC1B",21,0) + ;"Dependencies: +"RTN","TMGRPC1B",22,0) + ;" DIC, TMGDEBUG +"RTN","TMGRPC1B",23,0) + ;"======================================================================= +"RTN","TMGRPC1B",24,0) + ;"======================================================================= +"RTN","TMGRPC1B",25,0) + ; +"RTN","TMGRPC1B",26,0) + ;"OK TO DELETE THIS FUNCTION LATER IF WANTED.... +"RTN","TMGRPC1B",27,0) +EVALTIUO(TMGY,TMGOBJNM) ;"--- DEPRECIATED. Will use 'TIU TEMPLATE GETTEXT' RPC instead +"RTN","TMGRPC1B",28,0) + ;"Purpose: To return the resolved text of a TIU Text Object. +"RTN","TMGRPC1B",29,0) + ;"Input: TIUY -- This is output result for RPC caller +"RTN","TMGRPC1B",30,0) + ;" TMGOBJNM -- This is the name of the TIU TEXT OBJECT to obtain. +"RTN","TMGRPC1B",31,0) + ;"Note: lines wrapped at 200 chars length +"RTN","TMGRPC1B",32,0) + ;"Results : none +"RTN","TMGRPC1B",33,0) + ; +"RTN","TMGRPC1B",34,0) + KILL ^TMG("TMP","TABLE") +"RTN","TMGRPC1B",35,0) + zshow "*":^TMG("TMP","TABLE") +"RTN","TMGRPC1B",36,0) + NEW TMGSTR +"RTN","TMGRPC1B",37,0) + SET TMGOBJNM=$GET(TMGOBJNM) +"RTN","TMGRPC1B",38,0) + IF TMGOBJNM["|" DO GOTO STOR +"RTN","TMGRPC1B",39,0) + . SET TMGSTR="Passed TEXT OBJECT name should not contain '|' character" +"RTN","TMGRPC1B",40,0) + SET TMGSTR="|"_TMGOBJNM_"|" +"RTN","TMGRPC1B",41,0) + SET TMGSTR=$$BOIL^TIUSRVD(TMGSTR) ;" Execute Boilerplates +"RTN","TMGRPC1B",42,0) + ; +"RTN","TMGRPC1B",43,0) +STOR NEW REF SET REF=$NAME(^TMP("TMG OBJ EVAL",$J)) +"RTN","TMGRPC1B",44,0) + NEW IDX SET IDX=0 +"RTN","TMGRPC1B",45,0) + KILL @REF +"RTN","TMGRPC1B",46,0) + SET TMGY=REF +"RTN","TMGRPC1B",47,0) + FOR DO QUIT:(TMGSTR="") +"RTN","TMGRPC1B",48,0) + . NEW SA,SB +"RTN","TMGRPC1B",49,0) + . SET (SA,SB)="" +"RTN","TMGRPC1B",50,0) + . IF $LENGTH(TMGSTR)>200 DO +"RTN","TMGRPC1B",51,0) + . . SET SB=$EXTRACT(TMGSTR,201,999) +"RTN","TMGRPC1B",52,0) + . . SET TMGSTR=$EXTRACT(TMGSTR,1,200) +"RTN","TMGRPC1B",53,0) + . SET IDX=IDX+1 +"RTN","TMGRPC1B",54,0) + . SET @REF@(IDX)=TMGSTR +"RTN","TMGRPC1B",55,0) + . SET TMGSTR=SB +"RTN","TMGRPC1B",56,0) + QUIT +"RTN","TMGRPC1B",57,0) + ; +"RTN","TMGRPC1B",58,0) + ; +"RTN","TMGRPC1B",59,0) +INSTALL ; +"RTN","TMGRPC1B",60,0) + ;"Purpose: to add the RPC's to the OPTION record OR CPRS GUI CHART +"RTN","TMGRPC1B",61,0) + DO INSTALL1("TMG EVAL TIU TEXT OBJECT") +"RTN","TMGRPC1B",62,0) + QUIT +"RTN","TMGRPC1B",63,0) + ; +"RTN","TMGRPC1B",64,0) +INSTALL1(RPCNAME) ; +"RTN","TMGRPC1B",65,0) + ;"Purpose: to add 1 RPC to the OPTION record OR CPRS GUI CHART +"RTN","TMGRPC1B",66,0) + NEW DIC,X,Y,DA +"RTN","TMGRPC1B",67,0) + SET DIC="^DIC(19,",DIC(0)="M" +"RTN","TMGRPC1B",68,0) + SET X="OR CPRS GUI CHART" +"RTN","TMGRPC1B",69,0) + DO ^DIC +"RTN","TMGRPC1B",70,0) + IF +Y'>0 DO QUIT +"RTN","TMGRPC1B",71,0) + . WRITE "ERROR. Unable to find [OR CPRS GUI CHART] in file OPTION (#19)",! +"RTN","TMGRPC1B",72,0) + . NEW TEMP READ "Press [ENTER] to continue...",TEMP:($GET(DTIME,3600)) +"RTN","TMGRPC1B",73,0) + . WRITE ! +"RTN","TMGRPC1B",74,0) + SET DA(1)=+Y +"RTN","TMGRPC1B",75,0) + SET DIC=DIC_DA(1)_",""RPC""," +"RTN","TMGRPC1B",76,0) + SET DIC(0)="ML" ;"LAYGO --> add entry if not found +"RTN","TMGRPC1B",77,0) + SET X=RPCNAME +"RTN","TMGRPC1B",78,0) + DO ^DIC +"RTN","TMGRPC1B",79,0) + IF +Y'>0 DO +"RTN","TMGRPC1B",80,0) + . WRITE "ERROR. Unable to add or find "_RPCNAME_" for subfile RPC in record",! +"RTN","TMGRPC1B",81,0) + . WRITE "OR CPRS GUI CHART in file OPTION (#19)",! +"RTN","TMGRPC1B",82,0) + . NEW TEMP READ "Press [ENTER] to continue...",TEMP:($GET(DTIME,3600)) +"RTN","TMGRPC1B",83,0) + . WRITE ! +"RTN","TMGRPC1B",84,0) + QUIT +"RTN","TMGRPCSR") +0^9^B34779751 +"RTN","TMGRPCSR",1,0) +TMGRPCSR ;TMG/kst/RPC entry points for Search API ; 6/4/10 +"RTN","TMGRPCSR",2,0) + ;;1.0;TMG-LIB;**1**;05/25/10;Build 1 +"RTN","TMGRPCSR",3,0) + ; +"RTN","TMGRPCSR",4,0) + ;"RPC ENTRY POINTS FOR TMG FILEMAN SEARCH API +"RTN","TMGRPCSR",5,0) + ; +"RTN","TMGRPCSR",6,0) + ;"Copyright Kevin Toppenberg MD 5/25/10 +"RTN","TMGRPCSR",7,0) + ;"Released under GNU General Public License (GPL) +"RTN","TMGRPCSR",8,0) + ;" +"RTN","TMGRPCSR",9,0) + ;"NOTE: this function depends on new version of LIST^DIC, from G. Timpson Patch +"RTN","TMGRPCSR",10,0) + ;"======================================================================= +"RTN","TMGRPCSR",11,0) + ;" RPC -- Public Functions. +"RTN","TMGRPCSR",12,0) + ;"======================================================================= +"RTN","TMGRPCSR",13,0) + ;"CHANNEL(TMGRESULT,INPUT) -- general purpose channel RPC from a GUI config program +"RTN","TMGRPCSR",14,0) + ;"LAUNCH(OUT,FILENUM,SRCHSTR) -- launch background search thread, return JOB # +"RTN","TMGRPCSR",15,0) + ;"STATUS(OUT,JOBNUM) --Return status of background job. +"RTN","TMGRPCSR",16,0) + ;"RESULTS(OUT,JOBNUM) -- Return results from background search job. +"RTN","TMGRPCSR",17,0) + ;" +"RTN","TMGRPCSR",18,0) + ;"======================================================================= +"RTN","TMGRPCSR",19,0) + ;"PRIVATE API FUNCTIONS +"RTN","TMGRPCSR",20,0) + ;"======================================================================= +"RTN","TMGRPCSR",21,0) + ;" +"RTN","TMGRPCSR",22,0) + ;"======================================================================= +"RTN","TMGRPCSR",23,0) + ;"======================================================================= +"RTN","TMGRPCSR",24,0) + ;"Dependencies: +"RTN","TMGRPCSR",25,0) + ;" ^XLFSTR, ^TMGRPCS0, TMGSRCH1 +"RTN","TMGRPCSR",26,0) + ;"======================================================================= +"RTN","TMGRPCSR",27,0) + ;"======================================================================= +"RTN","TMGRPCSR",28,0) + ; +"RTN","TMGRPCSR",29,0) +CHANNEL(TMGRESULT,INPUT) ; +"RTN","TMGRPCSR",30,0) + ;"Purpose: This will be a general purpose channel RPC from a GUI config program +"RTN","TMGRPCSR",31,0) + ;"Input: TMGRESULT -- this is an OUT parameter, and it is always passed by reference +"RTN","TMGRPCSR",32,0) + ;" INPUT -- this will be array of data sent from the GUI client. Defined below: +"RTN","TMGRPCSR",33,0) + ;" +"RTN","TMGRPCSR",34,0) + ;" INPUT("REQUEST")="cmd^params" Valid values for "cmd" are: +"RTN","TMGRPCSR",35,0) + ;" "LAUNCH" -- Start background task for search +"RTN","TMGRPCSR",36,0) + ;" params: FileNumber^SearchString <-- See docs for Search String in TMGSRCH.m +"RTN","TMGRPCSR",37,0) + ;" "STATUS" -- Get status of background task +"RTN","TMGRPCSR",38,0) + ;" params: JobNumber +"RTN","TMGRPCSR",39,0) + ;" "IEN LIST" ; was RESULTS +"RTN","TMGRPCSR",40,0) + ;" params: JobNumber^Fields +"RTN","TMGRPCSR",41,0) + ;" NOTE: If Fields left blank, then NO FIELDS is assumed +"RTN","TMGRPCSR",42,0) + ;" "IEN DETAILS" -- Get details of 1 IEN entry +"RTN","TMGRPCSR",43,0) + ;" params: JobNumber^IEN +"RTN","TMGRPCSR",44,0) + ;" "PREP SUBSET" +"RTN","TMGRPCSR",45,0) + ;" params: JobNumber^[Field[;FLD[;FLD...]]] +"RTN","TMGRPCSR",46,0) + ;" Field -- The desired field number(s). +"RTN","TMGRPCSR",47,0) + ;" OPTIONAL. DEFAULT is .01 +"RTN","TMGRPCSR",48,0) + ;" If more than one supplied, then output is +"RTN","TMGRPCSR",49,0) + ;" concatinated. Separate fieldnumbers with ';' +"RTN","TMGRPCSR",50,0) + ;" "CLEAR" -- clear results from last search. +"RTN","TMGRPCSR",51,0) + ;" params: JobNumber +"RTN","TMGRPCSR",52,0) + ;" "ALLOWED FILES ENTRY SUBSET" -- get sublist of list .01 fields for allowed files (those pointing into FileNum) +"RTN","TMGRPCSR",53,0) + ;" params: FileNum^ListStartValue^direction^MaxCount(optional, def=44)^Simple +"RTN","TMGRPCSR",54,0) + ;" "FIELD LIST SUBSET" -- get sublist of fields names in file +"RTN","TMGRPCSR",55,0) + ;" params: FileNum^ListStartValue^direction^MaxCount(optional, def=44)^Simple +"RTN","TMGRPCSR",56,0) + ;" "RESULTS LIST SUBSET" -- get sublist of search results +"RTN","TMGRPCSR",57,0) + ;" params: JobNum^ListStartValue^direction^MaxCount(optional, def=44) +"RTN","TMGRPCSR",58,0) + ;"Output: results of this function should be put into TMGRESULTS array. +"RTN","TMGRPCSR",59,0) + ;" For cmd: +"RTN","TMGRPCSR",60,0) + ;" "LAUNCH" +"RTN","TMGRPCSR",61,0) + ;" TMGRESULT(0)=1^JobNumber +"RTN","TMGRPCSR",62,0) + ;" "STATUS" +"RTN","TMGRPCSR",63,0) + ;" TMGRESULT(0)=1^%Done^Message. <-- Will be '1^100^#DONE#' when task is done. +"RTN","TMGRPCSR",64,0) + ;" "IEN LIST" +"RTN","TMGRPCSR",65,0) + ;" TMGRESULT(0)=1 if Success or -1^Message" +"RTN","TMGRPCSR",66,0) + ;" TMGRESULT(1)=IEN^[Fld Value] <-- Field value returned, if requested +"RTN","TMGRPCSR",67,0) + ;" TMGRESULT(2)=IEN^[Fld Value] +"RTN","TMGRPCSR",68,0) + ;" etc ... +"RTN","TMGRPCSR",69,0) + ;" "PREP SUBSET" +"RTN","TMGRPCSR",70,0) + ;" TMGRESULT(0)=1^Success or -1^Message +"RTN","TMGRPCSR",71,0) + ;" "CLEAR" +"RTN","TMGRPCSR",72,0) + ;" TMGRESULT(0)=1^Success +"RTN","TMGRPCSR",73,0) + ;" "ALLOWED FILES ENTRY SUBSET" +"RTN","TMGRPCSR",74,0) + ;" TMGRESULT(0)="1^Success" or "-1^Message" +"RTN","TMGRPCSR",75,0) + ;" TMGRESULT(1)=FileNum^FileName +"RTN","TMGRPCSR",76,0) + ;" TMGRESULT(2)=FileNum^FileName +"RTN","TMGRPCSR",77,0) + ;" etc ... +"RTN","TMGRPCSR",78,0) + ;" "FIELD LIST SUBSET" +"RTN","TMGRPCSR",79,0) + ;" TMGRESULT(0)="1^Success" or "-1^Message" +"RTN","TMGRPCSR",80,0) + ;" TMGRESULT(1)=FLDNum^Name^Info +"RTN","TMGRPCSR",81,0) + ;" TMGRESULT(2)=FLDNum^Name^Info +"RTN","TMGRPCSR",82,0) + ;" etc ... +"RTN","TMGRPCSR",83,0) + ;" "RESULTS LIST SUBSET" +"RTN","TMGRPCSR",84,0) + ;" TMGRESULT(0)="1^Success" or "-1^Message" +"RTN","TMGRPCSR",85,0) + ;" TMGRESULT(1)=IENNum^RequestedFieldNames +"RTN","TMGRPCSR",86,0) + ;" TMGRESULT(2)=IENNum^RequestedFieldNames +"RTN","TMGRPCSR",87,0) + ;" etc ... +"RTN","TMGRPCSR",88,0) + ;"Result: none +"RTN","TMGRPCSR",89,0) + ; +"RTN","TMGRPCSR",90,0) + NEW TMGCOMMAND,TMGCOMMAND +"RTN","TMGRPCSR",91,0) + SET TMGCOMMAND=$$TRIM^XLFSTR($$UP^XLFSTR($PIECE($GET(INPUT("REQUEST")),"^",1))) +"RTN","TMGRPCSR",92,0) + SET TMGPARAMS=$$UP^XLFSTR($PIECE($GET(INPUT("REQUEST")),"^",2,199)) +"RTN","TMGRPCSR",93,0) + ; +"RTN","TMGRPCSR",94,0) + ;"MERGE ^TMG("TMP","RPC","TMGRPCSR",$H,"TMGCOMMAND")=TMGCOMMAND +"RTN","TMGRPCSR",95,0) + ;"MERGE ^TMG("TMP","RPC","TMGRPCSR",$H,"TMGPARAMS")=TMGPARAMS +"RTN","TMGRPCSR",96,0) + ; +"RTN","TMGRPCSR",97,0) + SET TMGRESULT(0)="-1^No command requested." ;"default to error state. +"RTN","TMGRPCSR",98,0) + IF TMGCOMMAND="LAUNCH" DO +"RTN","TMGRPCSR",99,0) + . DO LAUNCH^TMGRPCS0(.TMGRESULT,TMGPARAMS) +"RTN","TMGRPCSR",100,0) + IF TMGCOMMAND="STATUS" DO +"RTN","TMGRPCSR",101,0) + . DO STATUS^TMGRPCS0(.TMGRESULT,TMGPARAMS) +"RTN","TMGRPCSR",102,0) + ELSE IF TMGCOMMAND="RESULTS" DO +"RTN","TMGRPCSR",103,0) + . DO IENLIST^TMGRPCS0(.TMGRESULT,TMGPARAMS) +"RTN","TMGRPCSR",104,0) + ELSE IF TMGCOMMAND="PREP SUBSET" DO +"RTN","TMGRPCSR",105,0) + . DO PREPSB^TMGRPCS0(.TMGRESULT,TMGPARAMS) +"RTN","TMGRPCSR",106,0) + ELSE IF TMGCOMMAND="CLEAR" DO +"RTN","TMGRPCSR",107,0) + . DO CLEAR^TMGRPCS0(.TMGRESULT,TMGPARAMS) +"RTN","TMGRPCSR",108,0) + ELSE IF TMGCOMMAND="ALLOWED FILES ENTRY SUBSET" DO +"RTN","TMGRPCSR",109,0) + . DO GETAFSUB^TMGSRCH1(.TMGRESULT,TMGPARAMS) +"RTN","TMGRPCSR",110,0) + ELSE IF TMGCOMMAND="FIELD LIST SUBSET" DO +"RTN","TMGRPCSR",111,0) + . DO GETFLDSB^TMGSRCH1(.TMGRESULT,TMGPARAMS) +"RTN","TMGRPCSR",112,0) + ELSE IF TMGCOMMAND="RESULTS LIST SUBSET" DO +"RTN","TMGRPCSR",113,0) + . DO GETRSLTSB^TMGRPCS0(.TMGRESULT,TMGPARAMS) +"RTN","TMGRPCSR",114,0) + ; +"RTN","TMGRPCSR",115,0) + QUIT +"RTN","TMGRPCSR",116,0) + ; +"RTN","TMGRPCSR",117,0) +INSTALL ; +"RTN","TMGRPCSR",118,0) + ;"Purpose: to add the RPC's to the OPTION record OR CPRS GUI CHART +"RTN","TMGRPCSR",119,0) + DO INSTALL1^TMGRPC1B("TMG SEARCH CHANNEL") +"RTN","TMGRPCSR",120,0) + QUIT +"RTN","TMGRPCSR",121,0) + ; +"RTN","TMGRPCSR",122,0) + +"RTN","TMGSRCH") +0^5^B209173527 +"RTN","TMGSRCH",1,0) +TMGSRCH ;TMG/kst/Search API ; 6/4/10 +"RTN","TMGSRCH",2,0) + ;;1.0;TMG-LIB;**1**;05/19/10;Build 1 +"RTN","TMGSRCH",3,0) + ; +"RTN","TMGSRCH",4,0) + ;"TMG FILEMAN SEARCH API +"RTN","TMGSRCH",5,0) + ; +"RTN","TMGSRCH",6,0) + ;"Copyright Kevin Toppenberg MD 5/19/10 +"RTN","TMGSRCH",7,0) + ;"Released under GNU General Public License (GPL) +"RTN","TMGSRCH",8,0) + ;" +"RTN","TMGSRCH",9,0) + ;"NOTE: this function depends on new version of LIST^DIC, from G. Timpson Patch +"RTN","TMGSRCH",10,0) + ;"======================================================================= +"RTN","TMGSRCH",11,0) + ;" RPC -- Public Functions. +"RTN","TMGSRCH",12,0) + ;"======================================================================= +"RTN","TMGSRCH",13,0) + ;"SRCH(OUT,FILENUM,STR) --A search function, to support calls by RPC from CPRS +"RTN","TMGSRCH",14,0) + ;"BKSRCH(FILENUM,STR) -- designed to be called via JOB --> separate job thread +"RTN","TMGSRCH",15,0) + ;"FMSRCH(OUT,FILENUM,COMPEXPR) --A wrapper for Fileman search call +"RTN","TMGSRCH",16,0) + ;"======================================================================= +"RTN","TMGSRCH",17,0) + ;"PRIVATE API FUNCTIONS +"RTN","TMGSRCH",18,0) + ;"======================================================================= +"RTN","TMGSRCH",19,0) + ;"PARSESTR(FILENUM,STR,ARRAY,FNUMPTR) -- Parse user input into formatted array +"RTN","TMGSRCH",20,0) + ;"PARSE1(FILENUM,STR,FNUMPTR,ARRAY) --Parse a simple search term +"RTN","TMGSRCH",21,0) + ;"BKPGFN(MSG,PCT) -- Callable progress function code for background thread. +"RTN","TMGSRCH",22,0) + ;"DOSRCH(PTMGOUT,FILENUM,STR,PGFN) --Common search codes +"RTN","TMGSRCH",23,0) + ;"======================================================================= +"RTN","TMGSRCH",24,0) + ;"======================================================================= +"RTN","TMGSRCH",25,0) + ;"Dependencies: +"RTN","TMGSRCH",26,0) + ;" TMGDBAPI, DIE, XLFSTR, TMGSRCH0, TMGSRCH1, TMGSTUTL +"RTN","TMGSRCH",27,0) + ;"======================================================================= +"RTN","TMGSRCH",28,0) + ;"======================================================================= +"RTN","TMGSRCH",29,0) + ; +"RTN","TMGSRCH",30,0) + ; +"RTN","TMGSRCH",31,0) + ;"======================================================================= +"RTN","TMGSRCH",32,0) + ;" SEARCH STRING DOCUMENTATION +"RTN","TMGSRCH",33,0) + ;"======================================================================= +"RTN","TMGSRCH",34,0) + ;"Search string examples: +"RTN","TMGSRCH",35,0) + ;" 8925:.02(.01="SMITH,JOHN") +"RTN","TMGSRCH",36,0) + ;" 1234:.01(.03in"32..55") <-- this is a range test +"RTN","TMGSRCH",37,0) + ;" 1234:.99((.01="SMITH,JOHN") OR (.01="SMITH,BILL")) AND 4567:.01(.02'="4/2/10") NOT (1["HAPPY") +"RTN","TMGSRCH",38,0) + ;" 8925:(REPORT TEXT[DM-2)!(REPORT TEXT[HTN) AND 120.5:((VITAL TYPE=PULSE)&(RATE>70)) Targetfile=2 +"RTN","TMGSRCH",39,0) + ;" +"RTN","TMGSRCH",40,0) + ;"SYNTAX: +"RTN","TMGSRCH",41,0) + ;" -- File specifier. To specify searching in a file OTHER THAN target filenumber, an optional +"RTN","TMGSRCH",42,0) + ;" FILENUM:FLD[:FLD[:FLD...]] may be specified. However, ultimately, this must point back +"RTN","TMGSRCH",43,0) + ;" to the target filenumber. E.g. Search in file 8925, but for each entry found, use the IEN +"RTN","TMGSRCH",44,0) + ;" specified by FLD (or FLDA:FLDB or FLDA:FLDB:FLDC:...). NOTE: If just FILENUM is provided +"RTN","TMGSRCH",45,0) + ;" without specifying FLD(s) to point to target filenumber, then the code will find a path +"RTN","TMGSRCH",46,0) + ;" (if possible), using first one found. +"RTN","TMGSRCH",47,0) + ;" FILENUM:(...) +"RTN","TMGSRCH",48,0) + ;" The logic is read from left to right, honoring parentheses. If a filenumber +"RTN","TMGSRCH",49,0) + ;" is not specified, then the last specified filenumber is used. +"RTN","TMGSRCH",50,0) + ;" E.g. 1234:.01( LogicA ) OR 234:.99( LogicB ) AND ( LogicC ) +"RTN","TMGSRCH",51,0) + ;" LogicA fields refer to file 1234:.01. +"RTN","TMGSRCH",52,0) + ;" LogicB fields refer to file 234:.99 +"RTN","TMGSRCH",53,0) + ;" LogicA fields refer to file 234:.99 (last specified file number) +"RTN","TMGSRCH",54,0) + ;" E.g. 5678:.01( (LogicA1) OR 5432:.88(LogicA2) NOT (LogicA3) ) or (LogicB) +"RTN","TMGSRCH",55,0) + ;" LogicA1 fields refer to file 5678:.01 +"RTN","TMGSRCH",56,0) + ;" LogicA2 fields refer to file 5432:.88 +"RTN","TMGSRCH",57,0) + ;" LogicA3 fields refer to file 5432:.88 (last specified file number inside parentheses) +"RTN","TMGSRCH",58,0) + ;" LogicB fields refer to file 5678 (last specified file number at same parentheses level) +"RTN","TMGSRCH",59,0) + ;" -- Each individual search term must be enclosed in parentheses, and may contain sub-terms +"RTN","TMGSRCH",60,0) + ;" enclosed in nested parentheses +"RTN","TMGSRCH",61,0) + ;" -- Each individual search term is comprised of: +"RTN","TMGSRCH",62,0) + ;" FIELD then COMPARATOR then VALUE +"RTN","TMGSRCH",63,0) + ;" 1. FIELDS -- can be name or number. This is for currently active file (see below) +"RTN","TMGSRCH",64,0) + ;" may also be FIELDA:FIELDB:... when FIELDA is a pointer, then FIELDB +"RTN","TMGSRCH",65,0) + ;" is taken from the pointed-to file. If FIELDB is not provided, and FIELDA +"RTN","TMGSRCH",66,0) + ;" is a pointer, then the .01 field of pointed-to-file. Individual field +"RTN","TMGSRCH",67,0) + ;" names may be inclosed in quotes +"RTN","TMGSRCH",68,0) + ;" 2. COMPARATOR -- can be: +"RTN","TMGSRCH",69,0) + ;" "=" -- means exact match +"RTN","TMGSRCH",70,0) + ;" "'=", "<>", -- any of these means Does-not-equal +"RTN","TMGSRCH",71,0) + ;" ">=", "'<" -- means greater-than-or-equal-to (same as not-less-than) +"RTN","TMGSRCH",72,0) + ;" "<=", "'>" -- means less-than-or-equal-to (same sa not-greater-than) +"RTN","TMGSRCH",73,0) + ;" "in","IN","In","{" -- means field is in specified rage (see Value below) +"RTN","TMGSRCH",74,0) + ;" When using IN, if field name is provided by NAME (not number), +"RTN","TMGSRCH",75,0) + ;" then field name should be inclosed in quotes to separate the +"RTN","TMGSRCH",76,0) + ;" letters of the field name from the letters of 'IN'. +"RTN","TMGSRCH",77,0) + ;" "[" -- means 'contains'. Interpreted as follows: +"RTN","TMGSRCH",78,0) + ;" -- For Word processor (WP) fields, this means that any line in the entire field +"RTN","TMGSRCH",79,0) + ;" can contain search term, to be matched positive. +"RTN","TMGSRCH",80,0) + ;" -- For free text field, then just text of field is searched. +"RTN","TMGSRCH",81,0) + ;" 3. VALUE -- The search term to search for. Should be in quotes. +"RTN","TMGSRCH",82,0) + ;" Note: if comparator is "IN", then syntax is "Value1..Value2" +"RTN","TMGSRCH",83,0) + ;" There should be a ".." between the two values. +"RTN","TMGSRCH",84,0) + ;" -- Logical combiners of separate search terms allowed are: +"RTN","TMGSRCH",85,0) + ;" "OR" or "|" or "||" or "!" +"RTN","TMGSRCH",86,0) + ;" "AND" or "&" or "&&" +"RTN","TMGSRCH",87,0) + ;" "NOT" or "'" or "ANDNOT" +"RTN","TMGSRCH",88,0) + ;"======================================================================= +"RTN","TMGSRCH",89,0) + ;"======================================================================= +"RTN","TMGSRCH",90,0) + ; +"RTN","TMGSRCH",91,0) + ; +"RTN","TMGSRCH",92,0) +TEST ; +"RTN","TMGSRCH",93,0) + NEW STR,OUT +"RTN","TMGSRCH",94,0) + ;"SET STR="8925:(STATUS=COMPLETED)&((PATIENT[CUTSHALL)!(PATIENT[CUTSHAW))" +"RTN","TMGSRCH",95,0) + SET STR="8925:(REPORT TEXT[DM-2)!(REPORT TEXT[HTN) AND 120.5:((VITAL TYPE=PULSE)&(RATE>70))" +"RTN","TMGSRCH",96,0) + ;"SET STR="8925:(REPORT TEXT[DM-2) AND 120.5:((VITAL TYPE=PULSE)&(RATE>70))" +"RTN","TMGSRCH",97,0) + ;"SET STR="8925:(REPORT TEXT[HTN) AND 120.5:((VITAL TYPE=PULSE)&(RATE{70..75))" +"RTN","TMGSRCH",98,0) + ;"SET STR="8925:(REPORT TEXT[DM-2)!(REPORT TEXT[HTN)" +"RTN","TMGSRCH",99,0) + ;"WRITE STR,! +"RTN","TMGSRCH",100,0) + ;"DO SRCH(.OUT,2,STR) +"RTN","TMGSRCH",101,0) + ;"NEW CT SET CT=+$GET(OUT("COUNT")) +"RTN","TMGSRCH",102,0) + ;"WRITE "Found ",CT," total matches.",! +"RTN","TMGSRCH",103,0) + ; +"RTN","TMGSRCH",104,0) + DO BKSRCH(2,STR) +"RTN","TMGSRCH",105,0) + NEW STATUS,PCT +"RTN","TMGSRCH",106,0) + NEW REF SET REF=$NAME(^TMP("TMG","TMGSRCH",$J)) +"RTN","TMGSRCH",107,0) + FOR DO QUIT:(STATUS["#DONE#") +"RTN","TMGSRCH",108,0) + . HANG 1 +"RTN","TMGSRCH",109,0) + . SET STATUS=$GET(@REF@("MSG")) +"RTN","TMGSRCH",110,0) + . WRITE "STATUS: ",STATUS,! +"RTN","TMGSRCH",111,0) + ;"IF $DATA(@REF) ZWR @REF +"RTN","TMGSRCH",112,0) + QUIT +"RTN","TMGSRCH",113,0) + ; +"RTN","TMGSRCH",114,0) +SRCH(OUT,FILENUM,STR) ; +"RTN","TMGSRCH",115,0) + ;"Purpose: A search function, to support calls by RPC from CPRS +"RTN","TMGSRCH",116,0) + ;"Input: OUT-- Pass by reference. AN OUT PARAMETER. +"RTN","TMGSRCH",117,0) + ;" FILENUM -- The target file number that resulting IENs will be in +"RTN","TMGSRCH",118,0) + ;" STR -- This is a logic string for searching. See details above. +"RTN","TMGSRCH",119,0) + ;"Results: OUT is filled in. Format: +"RTN","TMGSRCH",120,0) + ;" OUT(0)=1 for success, or -1^Error Message +"RTN","TMGSRCH",121,0) + ;" OUT(IEN)="" +"RTN","TMGSRCH",122,0) + ;" OUT(IEN)="" +"RTN","TMGSRCH",123,0) + ;" OUT("COUNT")=Count of number of found records. +"RTN","TMGSRCH",124,0) + ;"Results: None +"RTN","TMGSRCH",125,0) + ;" +"RTN","TMGSRCH",126,0) + DO DOSRCH("OUT",.FILENUM,.STR) ; +"RTN","TMGSRCH",127,0) +SRCHDN QUIT +"RTN","TMGSRCH",128,0) + ; +"RTN","TMGSRCH",129,0) + ; +"RTN","TMGSRCH",130,0) +BKSRCH(FILENUM,STR) ; +"RTN","TMGSRCH",131,0) + ;"Purpose: this function is designed to be called via JOB, to setup separate job thread +"RTN","TMGSRCH",132,0) + ;" E.g. JOB BKSRCH^TMGTMGSRCH(FILENUM,STR) NEW MSGJOB SET MSGJOB=$ZJOB +"RTN","TMGSRCH",133,0) + ;" NOTE: When job, output MSG will be "#DONE#" (see below) +"RTN","TMGSRCH",134,0) + ;"Input: Filenum: This this is the target file of the search. +"RTN","TMGSRCH",135,0) + ;" STR -- This is the logic string for searching. Format as per SRCH() docs +"RTN","TMGSRCH",136,0) + ;"Output: Output will go into ^TMP("TMG","TMGSRCH",$J,"OUT") +"RTN","TMGSRCH",137,0) + ;" Messages will go into ^TMP("TMG","TMGSRCH",$J,"MSG") +"RTN","TMGSRCH",138,0) + ;" % Done will go into ^TMP("TMG","TMGSRCH",$J,"PCT") +"RTN","TMGSRCH",139,0) + ;"Results: none +"RTN","TMGSRCH",140,0) + NEW PGFN SET PGFN="DO BKPGFN^TMGSRCH(.TMGSTAT,.TMGPCT)" +"RTN","TMGSRCH",141,0) + NEW POUT SET POUT=$NAME(^TMP("TMG","TMGSRCH",$J,"OUT")) +"RTN","TMGSRCH",142,0) + KILL @POUT +"RTN","TMGSRCH",143,0) + DO DOSRCH(POUT,.FILENUM,.STR,PGFN) ; +"RTN","TMGSRCH",144,0) + DO BKPGFN("#DONE#",100) +"RTN","TMGSRCH",145,0) + QUIT ;"This should terminate thread (if called by JOB as above) +"RTN","TMGSRCH",146,0) + ; +"RTN","TMGSRCH",147,0) +BKPGFN(MSG,PCT) ; +"RTN","TMGSRCH",148,0) + ;"Callable progress function code for background thread. +"RTN","TMGSRCH",149,0) + SET ^TMP("TMG","TMGSRCH",$J,"MSG")=$GET(MSG) +"RTN","TMGSRCH",150,0) + SET ^TMP("TMG","TMGSRCH",$J,"PCT")=$GET(PCT) +"RTN","TMGSRCH",151,0) + QUIT +"RTN","TMGSRCH",152,0) + ; +"RTN","TMGSRCH",153,0) + ; +"RTN","TMGSRCH",154,0) +DOSRCH(PTMGOUT,FILENUM,STR,PGFN) ; +"RTN","TMGSRCH",155,0) + ;"Common entry endpoint for search entry tags. See docs in SRCH() +"RTN","TMGSRCH",156,0) + ;"Input: PTMGOUT -- Pass by NAME. The name of the output array +"RTN","TMGSRCH",157,0) + ;" FILENUM -- See SRCH() +"RTN","TMGSRCH",158,0) + ;" STR -- See SRCH() +"RTN","TMGSRCH",159,0) + ;" TMGPGFN -- OPTIONAL. Mumps code that will be called periodically +"RTN","TMGSRCH",160,0) + ;" to allow display of progress of slow searches. +"RTN","TMGSRCH",161,0) + ;" Code may depend on the following variables: +"RTN","TMGSRCH",162,0) + ;" TMGSTAT -- The most recent status text +"RTN","TMGSRCH",163,0) + ;" TMGPCT -- a very gross estimate of % done (0-100%) +"RTN","TMGSRCH",164,0) + ;"Results -- None. +"RTN","TMGSRCH",165,0) + NEW TMGARRAY,RESULT,CT +"RTN","TMGSRCH",166,0) + SET RESULT=$$PARSESTR(.FILENUM,STR,.TMGARRAY) +"RTN","TMGSRCH",167,0) + ; +"RTN","TMGSRCH",168,0) + ;"MERGE ^TMG("TMP","RPC","TMGRPCSR","TMGARRAY")=TMGARRAY ;"TEMP!!! +"RTN","TMGSRCH",169,0) + ; +"RTN","TMGSRCH",170,0) + IF +RESULT=-1 SET @PTMGOUT@(0)=RESULT GOTO DSRCHDN +"RTN","TMGSRCH",171,0) + SET CT=$$ARRYSRCH^TMGSRCH0(FILENUM,PTMGOUT,.TMGARRAY,.PGFN) +"RTN","TMGSRCH",172,0) + SET @PTMGOUT@("COUNT")=CT +"RTN","TMGSRCH",173,0) + SET @PTMGOUT@("FILENUM")=FILENUM +"RTN","TMGSRCH",174,0) + IF $GET(@PTMGOUT@(0))="" SET @PTMGOUT@(0)=1 ;"Success +"RTN","TMGSRCH",175,0) +DSRCHDN QUIT +"RTN","TMGSRCH",176,0) + ; +"RTN","TMGSRCH",177,0) + ; +"RTN","TMGSRCH",178,0) +PARSESTR(FILENUM,STR,ARRAY,FNUMPTR) ; +"RTN","TMGSRCH",179,0) + ;"Purpose: To take user input, validate it, and parse into an formatted array +"RTN","TMGSRCH",180,0) + ;"Input: FILENUM -- The file number that is the target of the search. +"RTN","TMGSRCH",181,0) + ;" STR: This is the user input string. Format as documented in SRCH() above. +"RTN","TMGSRCH",182,0) + ;" ARRAY -- PASS BY REFERENCE. An OUT PARAMETER. Format as follows. +"RTN","TMGSRCH",183,0) + ;" ARRAY(1,"FNUMPTR")= FNUM:FLDA[:FLDB[:FLDC...]] FNUM is filenumber that +"RTN","TMGSRCH",184,0) + ;" contain search field, and then fields used to point +"RTN","TMGSRCH",185,0) + ;" back to *TARGET* FILENUM for entire search +"RTN","TMGSRCH",186,0) + ;" ARRAY(1,"FLD")=Fieldnumber to search +"RTN","TMGSRCH",187,0) + ;" ARRAY(1,"COMP")=Comparator, will be "=", "'=", "'<", or "'>", "[", "{", "IN" +"RTN","TMGSRCH",188,0) + ;" ARRAY(1,"SRCH")=The value of to be used in search. +"RTN","TMGSRCH",189,0) + ;" ARRAY(1,"WP")=1 if field is a WP field +"RTN","TMGSRCH",190,0) + ;" ARRAY(2,...) The second search term. +"RTN","TMGSRCH",191,0) + ;" ARRAY(2,"LOGIC")=#^Combiner +"RTN","TMGSRCH",192,0) + ;" # means the set so far. +"RTN","TMGSRCH",193,0) + ;" Combiner will be "AND", "OR", or "NOT" +"RTN","TMGSRCH",194,0) + ;" ARRAY(3,...) The third search term (which is comprised of sub terms) +"RTN","TMGSRCH",195,0) + ;" ARRAY(3,1,... The first subterm (same format as higher level) +"RTN","TMGSRCH",196,0) + ;" ARRAY(3,2,... The second subterm (same format as higher level) +"RTN","TMGSRCH",197,0) + ;" ARRAY(n,...) The N'th search term. +"RTN","TMGSRCH",198,0) + ;" removed-> ARRAY("SETCOMP",i)= NumA^Combiner^NumB +"RTN","TMGSRCH",199,0) + ;" NumA and NumB refer to seach term number (e.g. 1, 2, ... n above) +"RTN","TMGSRCH",200,0) + ;" If NumA="#", then it means 'the resulting set of results so far' +"RTN","TMGSRCH",201,0) + ;" Combiner will be "AND", "OR", or "NOT" +"RTN","TMGSRCH",202,0) + ;" i is the index variable, and logic should be evaluated in numerical order +"RTN","TMGSRCH",203,0) + ;" FNUMPTR: Will be used when calling self reiteratively. Leave blank in first call. +"RTN","TMGSRCH",204,0) + ;" DON'T pass by reference. This is 'FileNum:FLD[:FLD[:FLD...]] specifier +"RTN","TMGSRCH",205,0) + ;"Results: 1 if OK, or -1^Message if error during processing. +"RTN","TMGSRCH",206,0) + ; +"RTN","TMGSRCH",207,0) + NEW SUBSTRA,SUBSTRB,POS +"RTN","TMGSRCH",208,0) + NEW RESULT SET RESULT=1 ;"default to success +"RTN","TMGSRCH",209,0) + NEW TERMNUM SET TERMNUM=0 +"RTN","TMGSRCH",210,0) + SET FILENUM=+$GET(FILENUM) +"RTN","TMGSRCH",211,0) + IF FILENUM'>0 DO GOTO PSDN +"RTN","TMGSRCH",212,0) + . SET RESULT="-1^Target file number not provided." +"RTN","TMGSRCH",213,0) + SET FNUMPTR=$GET(FNUMPTR,FILENUM) +"RTN","TMGSRCH",214,0) + SET ARRAY("FILE")=FILENUM +"RTN","TMGSRCH",215,0) + NEW LOGICNUM SET LOGICNUM=0 +"RTN","TMGSRCH",216,0) + NEW DONE SET DONE=0 +"RTN","TMGSRCH",217,0) + FOR DO QUIT:(DONE=1)!(+RESULT=-1) +"RTN","TMGSRCH",218,0) + . NEW TEMPARRAY +"RTN","TMGSRCH",219,0) + . SET TERMNUM=TERMNUM+1 +"RTN","TMGSRCH",220,0) + . ;"--- Get file number, if any +"RTN","TMGSRCH",221,0) + . SET STR=$$TRIM^XLFSTR(STR) +"RTN","TMGSRCH",222,0) + . IF +$PIECE(STR,"(",1)>0 DO QUIT:(+RESULT=-1) +"RTN","TMGSRCH",223,0) + . . SET FNUMPTR=$PIECE(STR,"(",1) ;"Convert 1234:.01:.02:(...) --> 1234:.01:.02: +"RTN","TMGSRCH",224,0) + . . IF $EXTRACT(FNUMPTR,$LENGTH(FNUMPTR))=":" SET FNUMPTR=$EXTRACT(FNUMPTR,1,$LENGTH(FNUMPTR)-1) +"RTN","TMGSRCH",225,0) + . . IF ($PIECE(FNUMPTR,":",2)="")&(+FNUMPTR'=FILENUM) DO QUIT:(+RESULT=-1) +"RTN","TMGSRCH",226,0) + . . . NEW SAVPTR SET SAVPTR=FNUMPTR +"RTN","TMGSRCH",227,0) + . . . SET FNUMPTR=$PIECE($$PATHTO^TMGSRCH1(+FNUMPTR,FILENUM),"^",1) +"RTN","TMGSRCH",228,0) + . . . IF FNUMPTR="" SET RESULT="-1^Unable to find path to file #"_FILENUM_" from "_SAVPTR +"RTN","TMGSRCH",229,0) + . . ELSE IF $$FNPTR^TMGSRCH1(FNUMPTR)'=FILENUM DO QUIT +"RTN","TMGSRCH",230,0) + . . . SET RESULT="-1^'"_FNUMPTR_"' points to file #"_$$FNPTR^TMGSRCH1(FNUMPTR)_", not file #"_FILENUM_" as expected" +"RTN","TMGSRCH",231,0) + . ;"Split STR --> SUBSTRA + SUBSTRB +"RTN","TMGSRCH",232,0) + . SET SUBSTRA=$$MATCHXTR^TMGSTUTL(STR,"(",,,"(") +"RTN","TMGSRCH",233,0) + . IF SUBSTRA="" SET DONE=1 QUIT +"RTN","TMGSRCH",234,0) + . SET POS=$FIND(STR,SUBSTRA) ;"Return pos of following character +"RTN","TMGSRCH",235,0) + . SET SUBSTRB=$EXTRACT(STR,POS+1,9999) ;"Should be " [LOGICTERM] [SearchTerm]..." +"RTN","TMGSRCH",236,0) + . ;"Process SUBSTRA, either directly if single term, or recursively if compound term. +"RTN","TMGSRCH",237,0) + . IF $$HNQTSUB^TMGSTUTL(SUBSTRA,"(") DO +"RTN","TMGSRCH",238,0) + . . SET RESULT=$$PARSESTR(FILENUM,SUBSTRA,.TEMPARRAY,FNUMPTR) +"RTN","TMGSRCH",239,0) + . . SET ARRAY(TERMNUM,"SUBTERMS")=1 +"RTN","TMGSRCH",240,0) + . ELSE DO +"RTN","TMGSRCH",241,0) + . . SET RESULT=$$PARSE1(FILENUM,SUBSTRA,FNUMPTR,.TEMPARRAY) +"RTN","TMGSRCH",242,0) + . IF +RESULT=-1 QUIT +"RTN","TMGSRCH",243,0) + . SET SUBSTRA="" +"RTN","TMGSRCH",244,0) + . MERGE ARRAY(TERMNUM)=TEMPARRAY +"RTN","TMGSRCH",245,0) + . ;"Now get Logic term connecting this to next term (if any) +"RTN","TMGSRCH",246,0) + . SET SUBSTRB=$$TRIM^XLFSTR(SUBSTRB) ;"Remove opening (and closing) spaces +"RTN","TMGSRCH",247,0) + . NEW LOGICTERM SET LOGICTERM="" +"RTN","TMGSRCH",248,0) + . NEW P,CH +"RTN","TMGSRCH",249,0) + . NEW DNCOMB SET DNCOMB=0 +"RTN","TMGSRCH",250,0) + . FOR P=1:1:$LENGTH(SUBSTRB) DO QUIT:DNCOMB!(+RESULT=-1) +"RTN","TMGSRCH",251,0) + . . SET CH=$$UP^XLFSTR($EXTRACT(SUBSTRB,P)) +"RTN","TMGSRCH",252,0) + . . IF ("&|'!ANDORNOT"'[CH) SET DNCOMB=1 QUIT +"RTN","TMGSRCH",253,0) + . . SET LOGICTERM=LOGICTERM_CH +"RTN","TMGSRCH",254,0) + . SET STR=$EXTRACT(SUBSTRB,$LENGTH(LOGICTERM)+1,9999),SUBSTRB="" +"RTN","TMGSRCH",255,0) + . IF LOGICTERM="" QUIT +"RTN","TMGSRCH",256,0) + . SET LOGICTERM=$$FIXCOMB^TMGSRCH1(LOGICTERM,.RESULT) QUIT:(+RESULT=-1) +"RTN","TMGSRCH",257,0) + . NEW CURSET SET CURSET=$SELECT(TERMNUM=1:"1",1:"#") +"RTN","TMGSRCH",258,0) + . SET LOGICNUM=LOGICNUM+1 +"RTN","TMGSRCH",259,0) + . ;"SET ARRAY("SETCOMP",LOGICNUM)=CURSET_"^"_LOGICTERM_"^"_(TERMNUM+1) ;"will check later that TERMNUM+1 is supplied +"RTN","TMGSRCH",260,0) + . SET ARRAY(TERMNUM+1,"LOGIC")="#^"_LOGICTERM +"RTN","TMGSRCH",261,0) +PSDN QUIT RESULT +"RTN","TMGSRCH",262,0) + ; +"RTN","TMGSRCH",263,0) + ; +"RTN","TMGSRCH",264,0) +PARSE1(FILENUM,STR,FNUMPTR,ARRAY) ; +"RTN","TMGSRCH",265,0) + ;"Purpose: Parse a simple search term (e.g. .01="SMITH,JOHN"). Also validate that field exists in file. +"RTN","TMGSRCH",266,0) + ;"Input: FILENUM -- The TARGET filenumber that the entire search is referencing. +"RTN","TMGSRCH",267,0) + ;" STR: This is part of the user input string to parse +"RTN","TMGSRCH",268,0) + ;" FNUMPTR: FNUM:FLDA[:FLDB[:FLDC...]] FNUM is filenumber that contain search field, and then +"RTN","TMGSRCH",269,0) + ;" fields used to point back to *TARGET* FILENUM for entire search +"RTN","TMGSRCH",270,0) + ;" ARRAY -- PASS BY REFERENCE. An OUT PARAMETER. Format as follows. +"RTN","TMGSRCH",271,0) + ;" ARRAY("FNUMPTR")=Filenumber that contains field) +"RTN","TMGSRCH",272,0) + ;" ARRAY("FLD")=Fieldnumber to search +"RTN","TMGSRCH",273,0) + ;" ARRAY("COMP")=Comparator, will be "=", "'=", "'<", or "'>", "[","IN", "{" +"RTN","TMGSRCH",274,0) + ;" ARRAY("SRCH")=The value of to be used in search. +"RTN","TMGSRCH",275,0) + ;" ARRAY("WP")=1 if field is a WP field +"RTN","TMGSRCH",276,0) + ;"NOTE: If field specifies a DATE, then the search value will be converted to FileMan format +"RTN","TMGSRCH",277,0) + ;"Results: 1 if OK, or -1^Message if error during processing. +"RTN","TMGSRCH",278,0) + ;" +"RTN","TMGSRCH",279,0) + NEW RESULT SET RESULT=1 ;"default to success +"RTN","TMGSRCH",280,0) + NEW SAV SET SAV=STR +"RTN","TMGSRCH",281,0) + SET STR=$$TRIM^XLFSTR($GET(STR)) +"RTN","TMGSRCH",282,0) + SET ARRAY("FNUMPTR")=FNUMPTR +"RTN","TMGSRCH",283,0) + NEW FLD,FLDS SET FLDS="" +"RTN","TMGSRCH",284,0) + NEW TMGTFILE SET TMGTFILE=+FNUMPTR +"RTN","TMGSRCH",285,0) + FOR QUIT:("'<>=[:({"[$EXTRACT(STR,1))!(STR="") DO +"RTN","TMGSRCH",286,0) + . SET FLD=$$GETFLD^TMGSRCH1(.STR) ; +"RTN","TMGSRCH",287,0) + . NEW SAVFIL SET SAVFIL=TMGTFILE +"RTN","TMGSRCH",288,0) + . NEW ONEFLD SET ONEFLD=$$FLDNUM^TMGSRCH1(.TMGTFILE,.FLD) +"RTN","TMGSRCH",289,0) + . IF ONEFLD'>0 DO QUIT +"RTN","TMGSRCH",290,0) + . . SET RESULT="-1^Field ["_FLD_"] was not found in file ["_SAVFIL_"]" +"RTN","TMGSRCH",291,0) + . IF FLDS'="" SET FLDS=FLDS_":" +"RTN","TMGSRCH",292,0) + . SET FLDS=FLDS_ONEFLD +"RTN","TMGSRCH",293,0) + IF +RESULT=-1 GOTO PS1DN +"RTN","TMGSRCH",294,0) + SET ARRAY("FLD")=FLDS +"RTN","TMGSRCH",295,0) + IF $$ISWPFLD^TMGDBAPI(+FNUMPTR,+FLDS) SET ARRAY("WP")=1 +"RTN","TMGSRCH",296,0) + NEW FLDTYPE SET FLDTYPE=$PIECE($GET(^DD(+FNUMPTR,+FLDS,0)),"^",2) +"RTN","TMGSRCH",297,0) + IF FLDTYPE["M" DO GOTO PS1DN +"RTN","TMGSRCH",298,0) + . SET RESULT="-1^Searches in fields that are MULTIPLES not supported" +"RTN","TMGSRCH",299,0) + SET STR=$$TRIM^XLFSTR(STR) +"RTN","TMGSRCH",300,0) + NEW COMP +"RTN","TMGSRCH",301,0) + IF $$UP^XLFSTR($EXTRACT(STR,1,3))="'IN" SET COMP="'IN" +"RTN","TMGSRCH",302,0) + ELSE IF $$UP^XLFSTR($EXTRACT(STR,1,2))="IN" SET COMP="IN" +"RTN","TMGSRCH",303,0) + ELSE DO +"RTN","TMGSRCH",304,0) + . SET COMP="" NEW P,CH +"RTN","TMGSRCH",305,0) + . FOR P=1:1:$LENGTH(STR) SET CH=$EXTRACT(STR,P) QUIT:("'!<>=[{"'[CH) SET COMP=COMP_CH +"RTN","TMGSRCH",306,0) + SET STR=$EXTRACT(STR,$LENGTH(COMP)+1,9999) +"RTN","TMGSRCH",307,0) + SET COMP=$$FIXCOMP^TMGSRCH1(COMP,.RESULT) +"RTN","TMGSRCH",308,0) + IF +RESULT=-1 GOTO PS1DN +"RTN","TMGSRCH",309,0) + SET ARRAY("COMP")=COMP +"RTN","TMGSRCH",310,0) + SET STR=$$TRIM^XLFSTR(STR) ;"Remove any spaces after comparator +"RTN","TMGSRCH",311,0) + NEW SRCH SET SRCH=$$TRIM^XLFSTR(STR,,"""") ;"Trim quotes, if any. +"RTN","TMGSRCH",312,0) + IF FLDTYPE["D" DO GOTO:(+RESULT=-1) PS1DN ;"standardized dates +"RTN","TMGSRCH",313,0) + . NEW ADATE SET ADATE=SRCH +"RTN","TMGSRCH",314,0) + . NEW TEMPRSLT SET TEMPRSLT="" +"RTN","TMGSRCH",315,0) + . FOR QUIT:(ADATE="")!(+RESULT=-1) DO +"RTN","TMGSRCH",316,0) + . . IF TEMPRSLT'="" SET TEMPRSLT=TEMPRSLT_".." +"RTN","TMGSRCH",317,0) + . . SET TEMPRSLT=TEMPRSLT_$$STDDATE^TMGSRCH1($PIECE(ADATE,"..",1),.RESULT) +"RTN","TMGSRCH",318,0) + . . IF +RESULT=-1 QUIT +"RTN","TMGSRCH",319,0) + . . SET ADATE=$PIECE(SRCH,"..",2) +"RTN","TMGSRCH",320,0) + . SET SRCH=TEMPRSLT +"RTN","TMGSRCH",321,0) + ELSE IF FLDTYPE["S" DO ;"Convert FM SET type into internal format +"RTN","TMGSRCH",322,0) + . NEW OUT,TMGMSG +"RTN","TMGSRCH",323,0) + . DO VAL^DIE(+FNUMPTR,"+1,",FLD,"E",SRCH,.OUT,,"TMGMSG") +"RTN","TMGSRCH",324,0) + . SET SRCH=$GET(OUT) +"RTN","TMGSRCH",325,0) + IF SRCH'="" SET ARRAY("SRCH")=SRCH +"RTN","TMGSRCH",326,0) + ELSE DO GOTO PS1DN +"RTN","TMGSRCH",327,0) + . SET RESULT="-1^Search value is invalid" +"RTN","TMGSRCH",328,0) + ; +"RTN","TMGSRCH",329,0) +PS1DN IF +RESULT=-1 SET RESULT=RESULT_", found in ["_SAV_"]" +"RTN","TMGSRCH",330,0) + QUIT RESULT +"RTN","TMGSRCH",331,0) + ; +"RTN","TMGSRCH",332,0) + ; +"RTN","TMGSRCH",333,0) +FMSRCH(TMGFILE,TMGCOMPEXPR,TMGOUT,TMGOPTION) ; +"RTN","TMGSRCH",334,0) + QUIT $$FMSRCH^TMGSRCH0(.TMGFILE,.TMGCOMPEXPR,.TMGOUT,.TMGOPTION) +"RTN","TMGSRCH",335,0) + +"RTN","TMGSRCH0") +0^6^B267429171 +"RTN","TMGSRCH0",1,0) +TMGSRCH0 ;TMG/kst/Search API ;05/19/10 ; 6/4/10 +"RTN","TMGSRCH0",2,0) + ;;1.0;TMG-LIB;**1**;05/19/10;Build 1 +"RTN","TMGSRCH0",3,0) + ; +"RTN","TMGSRCH0",4,0) + ;"TMG FILEMAN SEARCH API +"RTN","TMGSRCH0",5,0) + ; +"RTN","TMGSRCH0",6,0) + ;"Copyright Kevin Toppenberg MD 5/19/10 +"RTN","TMGSRCH0",7,0) + ;"Released under GNU General Public License (GPL) +"RTN","TMGSRCH0",8,0) + ;" +"RTN","TMGSRCH0",9,0) + ;"NOTE: this function depends on new version of LIST^DIC, from G. Timpson Patch +"RTN","TMGSRCH0",10,0) + ;"======================================================================= +"RTN","TMGSRCH0",11,0) + ;" RPC -- Public Functions. +"RTN","TMGSRCH0",12,0) + ;"======================================================================= +"RTN","TMGSRCH0",13,0) + ;"FMSRCH(OUT,FILENUM,COMPEXPR) --A wrapper for Fileman search call +"RTN","TMGSRCH0",14,0) + ;"ARRYSRCH(FILENUM,PRESULT,ARRAY) -- Process parsed array, doing search +"RTN","TMGSRCH0",15,0) + ;"======================================================================= +"RTN","TMGSRCH0",16,0) + ;"PRIVATE API FUNCTIONS +"RTN","TMGSRCH0",17,0) + ;"======================================================================= +"RTN","TMGSRCH0",18,0) + ;"USRPGFN(TMGPGFN,TMGSTAT) -- Do user Progress Function, if any. +"RTN","TMGSRCH0",19,0) + ;"SAMEFILE(PARRAY,STARTNUM,CURFILE) --Return range of search terms that are all in the same Fileman file +"RTN","TMGSRCH0",20,0) + ;"COMPEXPR(FILENUM,PARRAY,STARTN,ENDN,SRCHFILE,FIELDS) -- prepair a FILEMAN COMPUTED EXPRSSION from elements in ARRAY +"RTN","TMGSRCH0",21,0) + ;"FIXCOMB(COMB) -- Fix COMBINER term +"RTN","TMGSRCH0",22,0) + ;"COMP1XP(PARRAY,FIELDS) -- prepair 1 FILEMAN COMPUTED EXPRSSION from elements in ARRAY +"RTN","TMGSRCH0",23,0) + ;"FIXSET(TMGRSLT,TARGETFILE,SRCHFILE,FLDS,TMGSET) -- Change output of FMSRCH into needed format. +"RTN","TMGSRCH0",24,0) + ;"RESOLV(FILE,FLDSTR,IEN,ERR) -- follow pointer path to final value. +"RTN","TMGSRCH0",25,0) + ;"DOCOMB(COMB,TMG1SET,PRESULT) -- combine TMG1SET with @PRESULT based on logical operation COMBiner +"RTN","TMGSRCH0",26,0) + ;"======================================================================= +"RTN","TMGSRCH0",27,0) + ;"======================================================================= +"RTN","TMGSRCH0",28,0) + ;"Dependencies: +"RTN","TMGSRCH0",29,0) + ;" DIC (custom version), TMGDEBUG, TMGMISC, TMGSTUTL +"RTN","TMGSRCH0",30,0) + ;"======================================================================= +"RTN","TMGSRCH0",31,0) + ;"======================================================================= +"RTN","TMGSRCH0",32,0) + ; +"RTN","TMGSRCH0",33,0) + ; +"RTN","TMGSRCH0",34,0) +ARRYSRCH(FILENUM,PRESULT,TMGARRAY,TMGPGFN) ; +"RTN","TMGSRCH0",35,0) + ;"Purpose: Process parsed array, doing search on terms, and combining them. +"RTN","TMGSRCH0",36,0) + ;"Input: FILENUM -- This is the target file +"RTN","TMGSRCH0",37,0) + ;" PRESULT-- Pass by NAME. AN OUT PARAMETER. (see output below) +"RTN","TMGSRCH0",38,0) + ;" TMGARRAY -- Pass by reference. Contains search terms. Format +"RTN","TMGSRCH0",39,0) + ;" TMGARRAY("FILE")=FileNumber (This is target output file) +"RTN","TMGSRCH0",40,0) + ;" TMGARRAY(index,"FLD")=Field to search +"RTN","TMGSRCH0",41,0) + ;" TMGARRAY(index,"FNUMPTR")=FileNum:FLD[:FLD[:FLD...]] +"RTN","TMGSRCH0",42,0) + ;" TMGARRAY(index,"SRCH")=Value to search for +"RTN","TMGSRCH0",43,0) + ;" TMGARRAY(index,"LOGIC",num)=... +"RTN","TMGSRCH0",44,0) + ;" TMGARRAY(index,"WP")=1 if field is a WP field +"RTN","TMGSRCH0",45,0) + ;" TMGARRAY(index,"COMP")=comparator Allowed Comparators: =, '=, '<, '>, [, IN +"RTN","TMGSRCH0",46,0) + ;" TMGARRAY(index,"SUBTERMS")=1 if has subterms +"RTN","TMGSRCH0",47,0) + ;" TMGARRAY(index,indexB,...)... +"RTN","TMGSRCH0",48,0) + ;" TMGPGFN -- OPTIONAL. Mumps code that will be called periodically +"RTN","TMGSRCH0",49,0) + ;" to allow display of progress of slow searches. +"RTN","TMGSRCH0",50,0) + ;" Code may depend on the following variables: +"RTN","TMGSRCH0",51,0) + ;" TMGSTAT -- The most recent status text +"RTN","TMGSRCH0",52,0) + ;" TMGPCT -- a very gross estimate of % done (0-100%) +"RTN","TMGSRCH0",53,0) + ;"Output: PRESULT is filled in. Format: +"RTN","TMGSRCH0",54,0) + ;" @PRESULT@(0)=-1^Error Message, if needed +"RTN","TMGSRCH0",55,0) + ;" -or- +"RTN","TMGSRCH0",56,0) + ;" @PRESULT@(IEN)="" +"RTN","TMGSRCH0",57,0) + ;" @PRESULT@(IEN)="" +"RTN","TMGSRCH0",58,0) + ;"Result: Returns number of matches found. +"RTN","TMGSRCH0",59,0) + NEW ENTRYNUM,ENDNUM,TEMP,TMGEXPR,TMGFLDS,TMGFILE,MAXNUM +"RTN","TMGSRCH0",60,0) + NEW CT +"RTN","TMGSRCH0",61,0) + KILL @PRESULT +"RTN","TMGSRCH0",62,0) + NEW ERR SET ERR=0 +"RTN","TMGSRCH0",63,0) + NEW DONE SET DONE=0 +"RTN","TMGSRCH0",64,0) + SET MAXNUM=+$ORDER(TMGARRAY("@"),-1) +"RTN","TMGSRCH0",65,0) + IF MAXNUM<1 SET MAXNUM=1 ;"Avoid any divide by zero error +"RTN","TMGSRCH0",66,0) + SET ENTRYNUM=1 +"RTN","TMGSRCH0",67,0) + FOR DO QUIT:(DONE=1)!(+ERR=-1) +"RTN","TMGSRCH0",68,0) + . SET TEMP=$$SAMEFILE("TMGARRAY",ENTRYNUM) +"RTN","TMGSRCH0",69,0) + . SET ENDNUM=$PIECE(TEMP,"^",2) +"RTN","TMGSRCH0",70,0) + . IF ENDNUM NOTE: if WP field is encountered, this is kicked out as NOT +"RTN","TMGSRCH0",109,0) + ;" in same file, to overcome LIST^DIC limitation. (REMOVED AFTER LIMITATION FIXED) +"RTN","TMGSRCH0",110,0) + ;"Input: PARRAY -- PASS BY NAME. This is ARRAY as passed to DOSRCH +"RTN","TMGSRCH0",111,0) + ;" STARTNUM -- OPTIONAL. The index to start consideration of. Default=1 +"RTN","TMGSRCH0",112,0) + ;" CURFILE -- OPTIONAL. Used when calling self reiteratively. Leave blank first time. +"RTN","TMGSRCH0",113,0) + ;"Result: StartIndex^EndIndex of entries dealing with same file. +"RTN","TMGSRCH0",114,0) + ; +"RTN","TMGSRCH0",115,0) + SET STARTNUM=$GET(STARTNUM,1) +"RTN","TMGSRCH0",116,0) + NEW RESULT SET RESULT=STARTNUM_"^-1" +"RTN","TMGSRCH0",117,0) + NEW I SET I=STARTNUM-1 +"RTN","TMGSRCH0",118,0) + SET CURFILE=+$GET(CURFILE) +"RTN","TMGSRCH0",119,0) + NEW DONE SET DONE=0 +"RTN","TMGSRCH0",120,0) + FOR SET I=$ORDER(@PARRAY@(I)) QUIT:(+I'>0)!(DONE=1) DO +"RTN","TMGSRCH0",121,0) + . NEW THISFNUM SET THISFNUM=+$GET(@PARRAY@(I,"FNUMPTR")) +"RTN","TMGSRCH0",122,0) + . IF $GET(@PARRAY@(I,"SUBTERMS"))=1 DO QUIT:DONE=1 +"RTN","TMGSRCH0",123,0) + . . SET THISFNUM=CURFILE +"RTN","TMGSRCH0",124,0) + . . NEW TEMP SET TEMP=$$SAMEFILE($NAME(@PARRAY@(I)),1,.THISFNUM) +"RTN","TMGSRCH0",125,0) + . . NEW NUM2 SET NUM2=$PIECE(TEMP,"^",2) +"RTN","TMGSRCH0",126,0) + . . IF NUM2=-1 SET DONE=1 QUIT +"RTN","TMGSRCH0",127,0) + . . IF +$ORDER(@PARRAY@(I,NUM2))>0 SET DONE=1 +"RTN","TMGSRCH0",128,0) + . IF (CURFILE>0) DO QUIT:DONE=1 +"RTN","TMGSRCH0",129,0) + . . IF (THISFNUM'=CURFILE) SET DONE=1 QUIT +"RTN","TMGSRCH0",130,0) + . . ;"IF $GET(@PARRAY@(I,"WP"))=1 SET DONE=1 QUIT +"RTN","TMGSRCH0",131,0) + . SET CURFILE=THISFNUM +"RTN","TMGSRCH0",132,0) + . SET $PIECE(RESULT,"^",2)=I +"RTN","TMGSRCH0",133,0) + QUIT RESULT +"RTN","TMGSRCH0",134,0) + ; +"RTN","TMGSRCH0",135,0) +COMPEXPR(FILENUM,PARRAY,STARTN,ENDN,SRCHFILE,FIELDS) ; +"RTN","TMGSRCH0",136,0) + ;"Purpose: to prepair a FILEMAN COMPUTED EXPRSSION from elements in ARRAY +"RTN","TMGSRCH0",137,0) + ;"Input: ARRAY -- Pass by reference. Contains search terms. Format +"RTN","TMGSRCH0",138,0) + ;" @PARRAY@("FILE")=FileNumber (This is target output file) +"RTN","TMGSRCH0",139,0) + ;" @PARRAY@(index,"FLD")=Field to search +"RTN","TMGSRCH0",140,0) + ;" @PARRAY@(index,"FNUMPTR")=FileNum:FLD[:FLD[:FLD...]] +"RTN","TMGSRCH0",141,0) + ;" @PARRAY@(index,"SRCH")=Value to search for +"RTN","TMGSRCH0",142,0) + ;" @PARRAY@(index,"COMP")=comparator Allowed Comparators: =, '=, '<, '>, [, IN +"RTN","TMGSRCH0",143,0) + ;" @PARRAY@(index,"SUBTERMS")=1 if has subterms +"RTN","TMGSRCH0",144,0) + ;" STARTN -- The starting index to consider +"RTN","TMGSRCH0",145,0) + ;" ENDN -- the ending index to consider +"RTN","TMGSRCH0",146,0) + ;" SRCHFILE --PASS BY REFERENCE. This is the file to search for fields in +"RTN","TMGSRCH0",147,0) + ;" FIELDS -- Pass by reference. This is the desired output fields. +"RTN","TMGSRCH0",148,0) + ;"Results: Will return a COMPUTED EXPRESSION, or -1^Message +"RTN","TMGSRCH0",149,0) + ;" +"RTN","TMGSRCH0",150,0) + NEW RESULT SET RESULT="" +"RTN","TMGSRCH0",151,0) + NEW I,CURFIL +"RTN","TMGSRCH0",152,0) + SET CURFIL=0 +"RTN","TMGSRCH0",153,0) + FOR I=STARTN:1:ENDN DO QUIT:(+RESULT=-1) +"RTN","TMGSRCH0",154,0) + . IF RESULT'="" DO +"RTN","TMGSRCH0",155,0) + . . NEW COMB SET COMB=$PIECE($GET(@PARRAY@(I,"LOGIC")),"^",2) +"RTN","TMGSRCH0",156,0) + . . DO FIXCOMB(.COMB) +"RTN","TMGSRCH0",157,0) + . . SET RESULT=RESULT_COMB +"RTN","TMGSRCH0",158,0) + . IF $GET(@PARRAY@(I,"SUBTERMS"))=1 DO QUIT +"RTN","TMGSRCH0",159,0) + . . NEW ENUM SET ENUM=+$ORDER(@PARRAY@(I,"@"),-1) +"RTN","TMGSRCH0",160,0) + . . NEW TEMP SET TEMP=$$COMPEXPR(FILENUM,$NAME(@PARRAY@(I)),1,ENUM,.SRCHFILE,.FIELDS) +"RTN","TMGSRCH0",161,0) + . . IF +TEMP=-1 SET RESULT=TEMP +"RTN","TMGSRCH0",162,0) + . . SET RESULT=RESULT_TEMP +"RTN","TMGSRCH0",163,0) + . NEW PRIOREXP SET PRIOREXP=$GET(@PARRAY@(I,"FM COMP EXPR")) +"RTN","TMGSRCH0",164,0) + . IF PRIOREXP'="" SET RESULT=RESULT_PRIOREXP QUIT +"RTN","TMGSRCH0",165,0) + . NEW FNUMPTR SET FNUMPTR=$GET(@PARRAY@(I,"FNUMPTR")) +"RTN","TMGSRCH0",166,0) + . IF FNUMPTR="" DO QUIT +"RTN","TMGSRCH0",167,0) + . . SET RESULT="-1^No FNUMPTR found in array. Can't create computed expression" +"RTN","TMGSRCH0",168,0) + . IF CURFIL=0 SET CURFIL=+FNUMPTR +"RTN","TMGSRCH0",169,0) + . IF CURFIL'=+FNUMPTR DO QUIT +"RTN","TMGSRCH0",170,0) + . . SET RESULT="-1^Can't make computed expression involving different files." +"RTN","TMGSRCH0",171,0) + . SET SRCHFILE=CURFIL +"RTN","TMGSRCH0",172,0) + . NEW EXPR SET EXPR=$$COMP1XP($NAME(@PARRAY@(I)),.FIELDS) +"RTN","TMGSRCH0",173,0) + . IF +EXPR=-1 SET RESULT=EXPR QUIT +"RTN","TMGSRCH0",174,0) + . SET @PARRAY@(I,"FM COMP EXPR")=EXPR +"RTN","TMGSRCH0",175,0) + . SET RESULT=RESULT_EXPR +"RTN","TMGSRCH0",176,0) + QUIT RESULT +"RTN","TMGSRCH0",177,0) + ; +"RTN","TMGSRCH0",178,0) +FIXCOMB(COMB) ; "Fix COMBINER terms +"RTN","TMGSRCH0",179,0) + IF COMB="AND" SET COMB="&" +"RTN","TMGSRCH0",180,0) + ELSE IF COMB="OR" SET COMB="!" +"RTN","TMGSRCH0",181,0) + ELSE IF COMB="NOT" SET COMB="&'" +"RTN","TMGSRCH0",182,0) + QUIT +"RTN","TMGSRCH0",183,0) + ; +"RTN","TMGSRCH0",184,0) +COMP1XP(PARRAY,FIELDS) ; +"RTN","TMGSRCH0",185,0) + ;"Purpose: to prepair ONE FILEMAN COMPUTED EXPRSSION from elements in ARRAY +"RTN","TMGSRCH0",186,0) + ;"Input: PARRAY -- Pass by NAME. Contains search terms. Format +"RTN","TMGSRCH0",187,0) + ;" @PARRAY@("FLD")=Field to search +"RTN","TMGSRCH0",188,0) + ;" @PARRAY@("FNUMPTR")=FileNum:FLD[:FLD[:FLD...]] +"RTN","TMGSRCH0",189,0) + ;" @PARRAY@("SRCH")=Value to search for (or Value..Value2 if IN comparator) +"RTN","TMGSRCH0",190,0) + ;" @PARRAY@("COMP")=comparator Allowed Comparators: =, '=, '<, '>, [, IN +"RTN","TMGSRCH0",191,0) + ;" FIELDS -- Pass by reference. This is the desired output fields. +"RTN","TMGSRCH0",192,0) + ;"Results: Will return a COMPUTED EXPRESSION, or -1^Message +"RTN","TMGSRCH0",193,0) + ; +"RTN","TMGSRCH0",194,0) + NEW RESULT SET RESULT="" +"RTN","TMGSRCH0",195,0) + NEW FLD SET FLD=$GET(@PARRAY@("FLD")) +"RTN","TMGSRCH0",196,0) + IF +FLD=0 DO GOTO CP1DN +"RTN","TMGSRCH0",197,0) + . SET RESULT="-1^No field number found" +"RTN","TMGSRCH0",198,0) + SET FIELDS=$PIECE($GET(@PARRAY@("FNUMPTR")),":",2,999) +"RTN","TMGSRCH0",199,0) + NEW COMP SET COMP=$GET(@PARRAY@("COMP")) +"RTN","TMGSRCH0",200,0) + IF COMP="" DO GOTO CP1DN +"RTN","TMGSRCH0",201,0) + . SET RESULT="-1^No comparator found" +"RTN","TMGSRCH0",202,0) + NEW VALUE SET VALUE=$GET(@PARRAY@("SRCH")) +"RTN","TMGSRCH0",203,0) + IF VALUE="" DO GOTO CP1DN +"RTN","TMGSRCH0",204,0) + . SET RESULT="-1^No value to search for found." +"RTN","TMGSRCH0",205,0) + IF COMP'="IN" DO +"RTN","TMGSRCH0",206,0) + . SET RESULT="(#"_FLD_COMP_""""_VALUE_""")" +"RTN","TMGSRCH0",207,0) + ELSE DO ;"Handle .01IN"5..10" +"RTN","TMGSRCH0",208,0) + . NEW V1,V2 +"RTN","TMGSRCH0",209,0) + . SET V1=$PIECE(VALUE,"..",1) +"RTN","TMGSRCH0",210,0) + . SET V2=$PIECE(VALUE,"..",2) +"RTN","TMGSRCH0",211,0) + . IF (V1="")!(V2="") DO QUIT +"RTN","TMGSRCH0",212,0) + . . SET RESULT="-1^Range values (e.g. V1..V2) not found for IN comparator." +"RTN","TMGSRCH0",213,0) + . SET RESULT="((#"_FLD_"'<"""_V1_""")&(#"_FLD_"'>"""_V2_"""))" +"RTN","TMGSRCH0",214,0) + IF +RESULT=-1 GOTO CP1DN +"RTN","TMGSRCH0",215,0) + ; +"RTN","TMGSRCH0",216,0) +CP1DN QUIT RESULT +"RTN","TMGSRCH0",217,0) + ; +"RTN","TMGSRCH0",218,0) +FMSRCH(TMGFILE,TMGCOMPEXPR,TMGOUT,TMGOPTION) ; +"RTN","TMGSRCH0",219,0) + ;"Purpose: This is a wrapper for new Fileman search call LIST^DIC +"RTN","TMGSRCH0",220,0) + ;"Input: TMGFILE -- File name or number to search in. +"RTN","TMGSRCH0",221,0) + ;" TMGFILE(0) -- If FILE refers to a subfile, then FILE(0) must be set to +"RTN","TMGSRCH0",222,0) + ;" the IENS that identifies which subfile to search. +"RTN","TMGSRCH0",223,0) + ;" If supplied, then FILE should be PASSED BY REFERENCE +"RTN","TMGSRCH0",224,0) + ;" TMGCOMPEXPR -- This is a FILEMAN COMPUTED EXPRESSION used for search. +"RTN","TMGSRCH0",225,0) + ;" TMGOUT -- PASS BY REFERENCE. an OUT PARAMETER. Pre-existing data killed. +"RTN","TMGSRCH0",226,0) + ;" This is array that will be filled with results. +"RTN","TMGSRCH0",227,0) + ;" e.g. OUT(IEN)=IEN^FieldValue(s) +"RTN","TMGSRCH0",228,0) + ;" If OPTION("BYROOT")=1, then OUT must hold the *name* of a variable to be filled. +"RTN","TMGSRCH0",229,0) + ;" e.g. @OUT@(IEN)=IEN^FieldValue(s) +"RTN","TMGSRCH0",230,0) + ;" TMGOUT("ERR") -- will be filled with error messages, if encountered +"RTN","TMGSRCH0",231,0) + ;" TMGOPTION -- (OPTIONAL) -- Used to past customizations to LIST^DIC. +"RTN","TMGSRCH0",232,0) + ;" TMGOPTION("BYROOT") If 1, then TMGOUT holds name of variable to be filled with results. +"RTN","TMGSRCH0",233,0) + ;" ** See details in documentation for LIST^DIC for items below ** +"RTN","TMGSRCH0",234,0) + ;" TMGOPTION("FIELDS") -- Optional. Fields to return with each entry. +"RTN","TMGSRCH0",235,0) + ;" TMGOPTION("FLAGS") -- Optional. Default="PX" Note: "X" will always be passed to LIST^DIC +"RTN","TMGSRCH0",236,0) + ;" TMGOPTION("NUMBER") -- Optional. Max number of entries to return. Default is "*" (all) +"RTN","TMGSRCH0",237,0) + ;" TMGOPTION("FROM") -- Optional. Index entry from which to begin the list. +"RTN","TMGSRCH0",238,0) + ;" TMGOPTION("PART") -- Optional. A partial match restriction. +"RTN","TMGSRCH0",239,0) + ;" TMGOPTION("SCREEN") -- Optional. Screening code to apply to each potential entry. +"RTN","TMGSRCH0",240,0) + ;" TMGOPTION("ID") -- Optional. Identifier: text to accompany each entry returned in the list. +"RTN","TMGSRCH0",241,0) + ;"Results: returns # of matches. +"RTN","TMGSRCH0",242,0) + NEW TMGRESULT SET TMGRESULT=0 +"RTN","TMGSRCH0",243,0) + SET TMGFILE=$GET(TMGFILE) +"RTN","TMGSRCH0",244,0) + IF +TMGFILE'=TMGFILE DO +"RTN","TMGSRCH0",245,0) + . NEW X,Y,DIC +"RTN","TMGSRCH0",246,0) + . SET DIC=1,DIC(0)="M" +"RTN","TMGSRCH0",247,0) + . SET X=TMGFILE +"RTN","TMGSRCH0",248,0) + . DO ^DIC +"RTN","TMGSRCH0",249,0) + . SET TMGFILE=+Y +"RTN","TMGSRCH0",250,0) + NEW TMGIENS SET TMGIENS=$GET(FILE(0)) +"RTN","TMGSRCH0",251,0) + NEW TMGFLDS SET TMGFLDS=$GET(TMGOPTION("FIELDS"),"@;") +"RTN","TMGSRCH0",252,0) + NEW TMGFLAGS SET TMGFLAGS=$GET(TMGOPTION("FLAGS"),"P") +"RTN","TMGSRCH0",253,0) + IF TMGFLAGS'["X" SET TMGFLAGS=TMGFLAGS_"X" +"RTN","TMGSRCH0",254,0) + NEW TMGMAX SET TMGMAX=$GET(TMGOPTION("NUMBER"),"*") +"RTN","TMGSRCH0",255,0) + NEW TMGFROM MERGE TMGFROM=TMGOPTION("FROM") +"RTN","TMGSRCH0",256,0) + NEW TMGPART MERGE TMGPART=TMGOPTION("PART") +"RTN","TMGSRCH0",257,0) + NEW TMGSCR SET TMGSCR=$GET(TMGOPTION("SCREEN")) +"RTN","TMGSRCH0",258,0) + NEW TMGID SET TMGID=$GET(TMGOPTION("ID")) +"RTN","TMGSRCH0",259,0) + SET TMGCOMPEXPR=$GET(TMGCOMPEXPR) +"RTN","TMGSRCH0",260,0) + NEW TMGRSLT,TMGMSG +"RTN","TMGSRCH0",261,0) + NEW TMGDB,TMGX SET TMGDB=0 ;"Can be changed when stepping through code. +"RTN","TMGSRCH0",262,0) + IF TMGDB=1 DO +"RTN","TMGSRCH0",263,0) + . SET TMGX="DO LIST^DIC("_TMGFILE_"," +"RTN","TMGSRCH0",264,0) + . IF $GET(TMGIENS)'="" SET TMGX=TMGX_""""_TMGIENS_"""" +"RTN","TMGSRCH0",265,0) + . SET TMGX=TMGX_","""_TMGFLDS_"""," +"RTN","TMGSRCH0",266,0) + . SET TMGX=TMGX_""""_TMGFLAGS_""","""_TMGMAX_"""," +"RTN","TMGSRCH0",267,0) + . IF $DATA(TMGFROM) SET TMGX=TMGX_".TMGFROM" +"RTN","TMGSRCH0",268,0) + . SET TMGX=TMGX_"," +"RTN","TMGSRCH0",269,0) + . IF $DATA(TMGPART) SET TMGX=TMGX_".TMGPART" +"RTN","TMGSRCH0",270,0) + . SET TMGX=TMGX_","""_$$QTPROTECT^TMGSTUTL(TMGCOMPEXPR)_"""," +"RTN","TMGSRCH0",271,0) + . IF $GET(TMGSCR)'="" SET TMGMAX=TMGMAX_""""_TMGSCR_"""" +"RTN","TMGSRCH0",272,0) + . SET TMGX=TMGX_"," +"RTN","TMGSRCH0",273,0) + . IF $GET(TMGID)'="" SET TMGMAX=TMGMAX_""""_TMGID_"""" +"RTN","TMGSRCH0",274,0) + . SET TMGX=TMGX_"," +"RTN","TMGSRCH0",275,0) + . SET TMGX=TMGX_"""TMGRSLT"",""TMGMSG"")" +"RTN","TMGSRCH0",276,0) + DO LIST^DIC(TMGFILE,TMGIENS,TMGFLDS,TMGFLAGS,TMGMAX,.TMGFROM,.TMGPART,TMGCOMPEXPR,TMGSCR,TMGID,"TMGRSLT","TMGMSG") +"RTN","TMGSRCH0",277,0) + NEW BYROOT SET BYROOT=+$GET(TMGOPTION("BYROOT")) +"RTN","TMGSRCH0",278,0) + NEW OUTROOT +"RTN","TMGSRCH0",279,0) + IF BYROOT SET OUTROOT=TMGOUT +"RTN","TMGSRCH0",280,0) + ELSE SET OUTROOT="TMGOUT" +"RTN","TMGSRCH0",281,0) + KILL @OUTROOT +"RTN","TMGSRCH0",282,0) + IF $DATA(TMGMSG("DIERR")) DO GOTO FMSDN +"RTN","TMGSRCH0",283,0) + . MERGE @OUTROOT@("ERR")=TMGMSG("DIERR") ;"copy in errors, if any +"RTN","TMGSRCH0",284,0) + . SET TMGRESULT=0 +"RTN","TMGSRCH0",285,0) + MERGE @OUTROOT@(0)=TMGRSLT("DILIST",0) +"RTN","TMGSRCH0",286,0) + NEW I SET I=0 +"RTN","TMGSRCH0",287,0) + NEW IENPCE SET IENPCE=0 +"RTN","TMGSRCH0",288,0) + FOR I=1:1:999 IF $PIECE(TMGRSLT("DILIST",0,"MAP"),"^",I)="IEN" SET IENPCE=I QUIT +"RTN","TMGSRCH0",289,0) + SET I=0 FOR SET I=$ORDER(TMGRSLT("DILIST",I)) QUIT:(+I'>0) DO +"RTN","TMGSRCH0",290,0) + . NEW VALUE SET VALUE=$GET(TMGRSLT("DILIST",I,0)) +"RTN","TMGSRCH0",291,0) + . NEW IEN SET IEN=$PIECE(VALUE,"^",IENPCE) +"RTN","TMGSRCH0",292,0) + . SET @OUTROOT@(IEN)=VALUE +"RTN","TMGSRCH0",293,0) + MERGE @OUTROOT@("ID")=TMGRSLT("ID") ;"Copy in identifiers, if any +"RTN","TMGSRCH0",294,0) + SET TMGRESULT=+$PIECE(TMGRSLT("DILIST",0),"^",1) +"RTN","TMGSRCH0",295,0) +FMSDN QUIT TMGRESULT +"RTN","TMGSRCH0",296,0) + ; +"RTN","TMGSRCH0",297,0) + ; +"RTN","TMGSRCH0",298,0) +FIXSET(TMGIN,TARGETFN,SRCHFILE,FLDS,TMG1SET) ; +"RTN","TMGSRCH0",299,0) + ;"Purpose: Change output of FMSRCH into needed format. +"RTN","TMGSRCH0",300,0) + ;" Note: FMSRCH() won't allow ouput fields in format of .02:.01:.1 etc. +"RTN","TMGSRCH0",301,0) + ;"Input: TMGIN -- PASS BY REFERENCE. The results of FMSRCH. Format: +"RTN","TMGSRCH0",302,0) + ;" TMGIN(SrchFileIEN)=SrchFileIEN^FieldValue <-- FieldValue is a pointer/IEN +"RTN","TMGSRCH0",303,0) + ;" TARGETFN -- The this the target file number. +"RTN","TMGSRCH0",304,0) + ;" SRCHFILE -- The file that the results are from. +"RTN","TMGSRCH0",305,0) + ;" FLDS -- The desired fields. e.g. .02, or .02:.01 etc. +"RTN","TMGSRCH0",306,0) + ;" TMG1SET -- PASS BY REFERENCE. AN OUT PARAMETER. Prior results killed +"RTN","TMGSRCH0",307,0) + ;" TMG1SET(SrchFileIEN)="" +"RTN","TMGSRCH0",308,0) + ;" TMG1SET(SrchFileIEN)="" +"RTN","TMGSRCH0",309,0) + ;" TMG1SET("DETAILS",TargetFileIEN,SrchFileNum,SrchFileIEN) +"RTN","TMGSRCH0",310,0) + ;" TMG1SET("DETAILS",TargetFileIEN,SrchFileNum,SrchFileIEN) +"RTN","TMGSRCH0",311,0) + ;"Results: 0 if OK, or -1^Message if error. +"RTN","TMGSRCH0",312,0) + KILL TMG1SET +"RTN","TMGSRCH0",313,0) + NEW RESULT SET RESULT=0 +"RTN","TMGSRCH0",314,0) + NEW VALUE +"RTN","TMGSRCH0",315,0) + NEW ERR SET ERR=0 +"RTN","TMGSRCH0",316,0) + NEW IEN SET IEN=0 +"RTN","TMGSRCH0",317,0) + FOR SET IEN=$ORDER(TMGIN(IEN)) QUIT:(+IEN'>0)!(+RESULT=-1) DO +"RTN","TMGSRCH0",318,0) + . IF SRCHFILE'=TARGETFN DO +"RTN","TMGSRCH0",319,0) + . . SET VALUE=$PIECE($GET(TMGIN(IEN)),"^",2) QUIT:(+VALUE'>0) +"RTN","TMGSRCH0",320,0) + . . IF FLDS[":" SET VALUE=$$RESOLV(SRCHFILE,FLDS,VALUE,.ERR) +"RTN","TMGSRCH0",321,0) + . ELSE DO +"RTN","TMGSRCH0",322,0) + . . SET VALUE=+$GET(TMGIN(IEN)) +"RTN","TMGSRCH0",323,0) + . QUIT:(+VALUE'>0) +"RTN","TMGSRCH0",324,0) + . IF +ERR=-1 SET RESULT=ERR QUIT +"RTN","TMGSRCH0",325,0) + . SET TMG1SET(VALUE)="" +"RTN","TMGSRCH0",326,0) + . SET TMG1SET("DETAILS",VALUE,SRCHFILE,IEN)="" ;"<-- Value=IEN in target file, IEN=IEN in SRCHFILE +"RTN","TMGSRCH0",327,0) + QUIT RESULT +"RTN","TMGSRCH0",328,0) + ; +"RTN","TMGSRCH0",329,0) +RESOLV(FILE,FLDSTR,IEN,ERR) ;" NOTE: THIS NEEDS TO BE COMPILED. INEFFECIENT TO DO EACH TIME. +"RTN","TMGSRCH0",330,0) + ;"Purpose: To follow pointer path to final value. +"RTN","TMGSRCH0",331,0) + ;"Input: FILE -- File that IEN is in. +"RTN","TMGSRCH0",332,0) + ;" FLDSTR -- e.g. ".02:.01:10:.01" +"RTN","TMGSRCH0",333,0) + ;" IEN -- This is the value in FILE of the first field in FLDSTR (e.g. ".02") +"RTN","TMGSRCH0",334,0) + ;" ERR -- PASS BY REFERENCE. AN OUT PARAMETER. -1^Err Msg, if any +"RTN","TMGSRCH0",335,0) + ;"Result: Returns resolved value (INTERNAL FORMAT) +"RTN","TMGSRCH0",336,0) + NEW P2FILE,INFO +"RTN","TMGSRCH0",337,0) + SET ERR="" +"RTN","TMGSRCH0",338,0) + NEW RESULT SET RESULT="" +"RTN","TMGSRCH0",339,0) + IF FLDSTR[":" DO GOTO:(+ERR=-1) RLVDN +"RTN","TMGSRCH0",340,0) + . NEW ZNODE SET ZNODE=$GET(^DD(FILE,+FLDSTR,0)) +"RTN","TMGSRCH0",341,0) + . IF ZNODE="" DO QUIT +"RTN","TMGSRCH0",342,0) + . . SET ERR="-1^Can't find declaration in DD for File #"_FILE_", FLD #"_+FLDSTR +"RTN","TMGSRCH0",343,0) + . SET INFO=$PIECE(ZNODE,"^",2) +"RTN","TMGSRCH0",344,0) + . SET P2FILE=+$PIECE(INFO,"P",2) +"RTN","TMGSRCH0",345,0) + . IF P2FILE'>0 DO QUIT +"RTN","TMGSRCH0",346,0) + . . SET ERR="-1^File #"_FILE_", FLD #"_+FLDSTR_" is not a pointer field." +"RTN","TMGSRCH0",347,0) + . NEW ROOT SET ROOT="^"_$PIECE(ZNODE,"^",3)_IEN_")" +"RTN","TMGSRCH0",348,0) + . NEW NEXTFLDS SET NEXTFLDS=$PIECE(FLDSTR,":",2,999) +"RTN","TMGSRCH0",349,0) + . SET ZNODE=$GET(^DD(P2FILE,+NEXTFLDS,0)) +"RTN","TMGSRCH0",350,0) + . NEW NODE SET NODE=$PIECE($PIECE(ZNODE,"^",4),";",1) +"RTN","TMGSRCH0",351,0) + . NEW PCE SET PCE=$PIECE($PIECE(ZNODE,"^",4),";",2) +"RTN","TMGSRCH0",352,0) + . NEW NEXTIEN SET NEXTIEN=$PIECE($GET(@ROOT@(NODE)),"^",PCE) +"RTN","TMGSRCH0",353,0) + . SET RESULT=$$RESOLV(P2FILE,NEXTFLDS,NEXTIEN,.ERR) +"RTN","TMGSRCH0",354,0) + ELSE SET RESULT=IEN +"RTN","TMGSRCH0",355,0) +RLVDN QUIT RESULT +"RTN","TMGSRCH0",356,0) + ; +"RTN","TMGSRCH0",357,0) +DOCOMB(COMB,TMG1SET,PRESULT) ; +"RTN","TMGSRCH0",358,0) + ;"Purpose: combine TMG1SET with @PRESULT based on logical operation COMBiner +"RTN","TMGSRCH0",359,0) + ;"Input: COMB= &, !, &' +"RTN","TMGSRCH0",360,0) + ;" TMG1SET -- PASS BY REFERENCE. +"RTN","TMGSRCH0",361,0) + ;" PRESULT -- PASS BY NAME. +"RTN","TMGSRCH0",362,0) + IF COMB="!" MERGE @PRESULT=TMG1SET +"RTN","TMGSRCH0",363,0) + ELSE IF COMB="&" DO +"RTN","TMGSRCH0",364,0) + . NEW TEMPSET +"RTN","TMGSRCH0",365,0) + . NEW I SET I=0 +"RTN","TMGSRCH0",366,0) + . FOR SET I=$ORDER(TMG1SET(I)) QUIT:(+I'>0) DO +"RTN","TMGSRCH0",367,0) + . . IF $DATA(@PRESULT@(I))=0 QUIT +"RTN","TMGSRCH0",368,0) + . . SET TEMPSET(I)="" +"RTN","TMGSRCH0",369,0) + . . MERGE TEMPSET("DETAILS",I)=TMG1SET("DETAILS",I) +"RTN","TMGSRCH0",370,0) + . . MERGE TEMPSET("DETAILS",I)=@PRESULT@("DETAILS",I) +"RTN","TMGSRCH0",371,0) + . KILL @PRESULT MERGE @PRESULT=TEMPSET +"RTN","TMGSRCH0",372,0) + ELSE IF COMB="&'" DO +"RTN","TMGSRCH0",373,0) + . NEW I SET I=0 +"RTN","TMGSRCH0",374,0) + . FOR SET I=$ORDER(TMG1SET(I)) QUIT:(+I'>0) DO +"RTN","TMGSRCH0",375,0) + . . KILL @PRESULT@(I) ;"Remove any entry in TMG1SET from @PRESULT@ +"RTN","TMGSRCH0",376,0) + . KILL @PRESULT MERGE @PRESULT=TEMPSET +"RTN","TMGSRCH0",377,0) + QUIT +"RTN","TMGSRCH0",378,0) + +"RTN","TMGSRCH1") +0^7^B205466169 +"RTN","TMGSRCH1",1,0) +TMGSRCH1 ;TMG/kst/Search API ; 6/4/10 +"RTN","TMGSRCH1",2,0) + ;;1.0;TMG-LIB;**1**;05/19/10;Build 1 +"RTN","TMGSRCH1",3,0) + ; +"RTN","TMGSRCH1",4,0) + ;"TMG FILEMAN SEARCH API +"RTN","TMGSRCH1",5,0) + ; +"RTN","TMGSRCH1",6,0) + ;"Copyright Kevin Toppenberg MD 5/19/10 +"RTN","TMGSRCH1",7,0) + ;"Released under GNU General Public License (GPL) +"RTN","TMGSRCH1",8,0) + ;" +"RTN","TMGSRCH1",9,0) + ;"NOTE: this function depends on new version of LIST^DIC, from G. Timpson Patch +"RTN","TMGSRCH1",10,0) + ;"======================================================================= +"RTN","TMGSRCH1",11,0) + ;" RPC -- Public Functions. +"RTN","TMGSRCH1",12,0) + ;"======================================================================= +"RTN","TMGSRCH1",13,0) + ;"FNPTR(FNUMPTR) -- Resolve a FNUMPTR, finding ultimate target file +"RTN","TMGSRCH1",14,0) + ;"PATHTO(FROMFILE,TOFILE,COUNT) -- Find a 'path' of fields that gets from file A -->B +"RTN","TMGSRCH1",15,0) + ;"FLDNUM(TMGFILE,TMGNAME) --Turn a field name into number, and change FILE to pointed-to-file +"RTN","TMGSRCH1",16,0) + ;"======================================================================= +"RTN","TMGSRCH1",17,0) + ;"PRIVATE API FUNCTIONS +"RTN","TMGSRCH1",18,0) + ;"======================================================================= +"RTN","TMGSRCH1",19,0) + ;"GETFLD(STR) -- Separate field name from comparator +"RTN","TMGSRCH1",20,0) + ;"FIXCOMP(COMP,ERR) --Standardize value comparators, e.g. <> becomes '= +"RTN","TMGSRCH1",21,0) + ;"FIXCOMB(COMB,ERR) --Standardize expression combiners, e.g. | becomes OR +"RTN","TMGSRCH1",22,0) + ;"STDDATE(TMGDATE,ERR) --Standardized date, or report error +"RTN","TMGSRCH1",23,0) + ;"======================================================================= +"RTN","TMGSRCH1",24,0) + ;"======================================================================= +"RTN","TMGSRCH1",25,0) + ;"Dependencies: +"RTN","TMGSRCH1",26,0) + ;" ^DIC, TMGSTUTL, XLFSTR, %DT, XLFDT +"RTN","TMGSRCH1",27,0) + ;"======================================================================= +"RTN","TMGSRCH1",28,0) + ;"======================================================================= +"RTN","TMGSRCH1",29,0) + ; +"RTN","TMGSRCH1",30,0) + ; +"RTN","TMGSRCH1",31,0) +FNPTR(FNUMPTR) ; +"RTN","TMGSRCH1",32,0) + ;"Puprose: To resolve a FNUMPTR, finding ultimate target file +"RTN","TMGSRCH1",33,0) + ;"Input: FNUMPTR: Format: FNUM:FLDA[:FLDB[:FLDC...]] FNUM is filenumber that +"RTN","TMGSRCH1",34,0) + ;" contain search field, and then fields used to point to *TARGET* FILENUM +"RTN","TMGSRCH1",35,0) + ;"Results: -1^Error message if error, otherwise returns pointed to file +"RTN","TMGSRCH1",36,0) + NEW RESULT,FILE,FLD,I,DONE +"RTN","TMGSRCH1",37,0) + SET FILE=+$GET(FNUMPTR) +"RTN","TMGSRCH1",38,0) + SET RESULT=0 +"RTN","TMGSRCH1",39,0) + SET DONE=0 +"RTN","TMGSRCH1",40,0) + FOR I=2:1:999 DO QUIT:(+RESULT=-1)!(DONE=1) +"RTN","TMGSRCH1",41,0) + . SET FLD=$PIECE(FNUMPTR,":",I) +"RTN","TMGSRCH1",42,0) + . IF FLD="" SET DONE=1 QUIT +"RTN","TMGSRCH1",43,0) + . IF $DATA(^DD(FILE,FLD,0))=0 DO QUIT +"RTN","TMGSRCH1",44,0) + . . SET RESULT="-1^Field ["_FLD_"] was not found in file ["_FILE_"]" +"RTN","TMGSRCH1",45,0) + . NEW FLDTYPE SET FLDTYPE=$PIECE(^DD(+FILE,+FLD,0),"^",2) +"RTN","TMGSRCH1",46,0) + . IF FLDTYPE'["P" DO QUIT +"RTN","TMGSRCH1",47,0) + . . SET RESULT="-1^Field ["_FLD_"] does not point to another file." +"RTN","TMGSRCH1",48,0) + . SET FILE=+$PIECE(FLDTYPE,"P",2) +"RTN","TMGSRCH1",49,0) + SET RESULT=FILE +"RTN","TMGSRCH1",50,0) + QUIT RESULT +"RTN","TMGSRCH1",51,0) + ; +"RTN","TMGSRCH1",52,0) +PATHTO(FROMFILE,TOFILE,COUNT) ; +"RTN","TMGSRCH1",53,0) + ;"Purpose: to find a "path" of fields that gets from file A -->B (if possible) +"RTN","TMGSRCH1",54,0) + ;" E.g. From TIU DOCUMENT to PATIENT would yield ".01:.01", meaning +"RTN","TMGSRCH1",55,0) + ;" that the .01 field of TIU DOCUMENT-->IHS PATIENT, and +"RTN","TMGSRCH1",56,0) + ;" .01 field of IHS PATIEN-->PATIENT +"RTN","TMGSRCH1",57,0) + ;"Input: FROMFILE -- The starting file number +"RTN","TMGSRCH1",58,0) + ;" TOFILE -- The target file number +"RTN","TMGSRCH1",59,0) + ;" COUNT -- used when calling self reiteratively. Leave blank on first call. +"RTN","TMGSRCH1",60,0) + ;"Note: This fill only allow the length of the path to be 3 links long. +"RTN","TMGSRCH1",61,0) + ;" Also, the search is stopped after the first link is found. +"RTN","TMGSRCH1",62,0) + ;" NOTE: If the file link is changed to be longer than 3, then +"RTN","TMGSRCH1",63,0) + ;" GETAFSUB() must also be changed +"RTN","TMGSRCH1",64,0) + ;"Results: Returns field link, e.g. ".01;2;.01" +"RTN","TMGSRCH1",65,0) + SET COUNT=+$GET(COUNT) +"RTN","TMGSRCH1",66,0) + NEW RESULT SET RESULT="" +"RTN","TMGSRCH1",67,0) + SET FROMFILE=+$GET(FROMFILE) +"RTN","TMGSRCH1",68,0) + NEW FLD SET FLD=0 +"RTN","TMGSRCH1",69,0) + FOR SET FLD=$ORDER(^DD(FROMFILE,FLD)) QUIT:(+FLD'>0)!(RESULT'="") DO +"RTN","TMGSRCH1",70,0) + . NEW INFO SET INFO=$PIECE($GET(^DD(FROMFILE,FLD,0)),"^",2) +"RTN","TMGSRCH1",71,0) + . IF INFO'["P" QUIT +"RTN","TMGSRCH1",72,0) + . NEW PT SET PT=+$PIECE(INFO,"P",2) +"RTN","TMGSRCH1",73,0) + . IF PT=FROMFILE QUIT ;"ignore pointers to self +"RTN","TMGSRCH1",74,0) + . IF PT=TOFILE SET RESULT=FROMFILE_":"_FLD_"->"_TOFILE QUIT +"RTN","TMGSRCH1",75,0) + . IF COUNT>2 QUIT +"RTN","TMGSRCH1",76,0) + . NEW TEMP SET TEMP=$$PATHTO(PT,TOFILE,COUNT+1) +"RTN","TMGSRCH1",77,0) + . IF TEMP'="" SET RESULT=FROMFILE_":"_FLD_"->"_TEMP +"RTN","TMGSRCH1",78,0) + IF COUNT=0 DO +"RTN","TMGSRCH1",79,0) + . NEW TEMP,I +"RTN","TMGSRCH1",80,0) + . SET TEMP="" +"RTN","TMGSRCH1",81,0) + . FOR I=1:1:$LENGTH(RESULT,"->") DO +"RTN","TMGSRCH1",82,0) + . . NEW PART SET PART=$PIECE(RESULT,"->",I) +"RTN","TMGSRCH1",83,0) + . . NEW PART2 SET PART2=$PIECE(PART,":",2) +"RTN","TMGSRCH1",84,0) + . . IF PART2="" QUIT +"RTN","TMGSRCH1",85,0) + . . IF TEMP'="" SET TEMP=TEMP_":" +"RTN","TMGSRCH1",86,0) + . . SET TEMP=TEMP_PART2 +"RTN","TMGSRCH1",87,0) + . SET RESULT=FROMFILE_":"_TEMP_"^"_RESULT +"RTN","TMGSRCH1",88,0) + QUIT RESULT +"RTN","TMGSRCH1",89,0) + ; +"RTN","TMGSRCH1",90,0) + ; +"RTN","TMGSRCH1",91,0) +GETFLD(STR) ; +"RTN","TMGSRCH1",92,0) + ;"Purpose: To separate field name from comparator +"RTN","TMGSRCH1",93,0) + ;"Input: STR -- PASS BY REFERENCE -- the string to pull field from +"RTN","TMGSRCH1",94,0) + ;"Results: returns extracted field. +"RTN","TMGSRCH1",95,0) + NEW FLD +"RTN","TMGSRCH1",96,0) + IF +STR>0 DO +"RTN","TMGSRCH1",97,0) + . SET FLD=+STR +"RTN","TMGSRCH1",98,0) + . SET STR=$PIECE(STR,FLD,2,999) +"RTN","TMGSRCH1",99,0) + ELSE DO +"RTN","TMGSRCH1",100,0) + . IF $EXTRACT(STR,1)="""" DO +"RTN","TMGSRCH1",101,0) + . . SET FLD=$$MATCHXTR^TMGSTUTL(STR,"""",,,"""") +"RTN","TMGSRCH1",102,0) + . . IF FLD'="" SET STR=$EXTRACT(STR,$LENGTH(FLD)+3,9999) +"RTN","TMGSRCH1",103,0) + . ELSE DO +"RTN","TMGSRCH1",104,0) + . . SET FLD="" +"RTN","TMGSRCH1",105,0) + . . NEW P FOR P=1:1:$LENGTH(STR) QUIT:"'<>=[:{"[$EXTRACT(STR,P) DO +"RTN","TMGSRCH1",106,0) + . . . SET FLD=FLD_$EXTRACT(STR,P) +"RTN","TMGSRCH1",107,0) + . . IF FLD'="" SET STR=$EXTRACT(STR,$LENGTH(FLD)+1,9999) +"RTN","TMGSRCH1",108,0) + QUIT FLD +"RTN","TMGSRCH1",109,0) + ; +"RTN","TMGSRCH1",110,0) +FLDNUM(TMGFILE,TMGNAME) ; +"RTN","TMGSRCH1",111,0) + ;"Purpose: To turn a field name into number, and change FILE to pointed-to-file +"RTN","TMGSRCH1",112,0) + ;"Input: TMGFILE -- PASS BY REFERENCE. Input is current file. Output is new pointed-to-file +"RTN","TMGSRCH1",113,0) + ;" TMGNAME -- PASS BY REFERENCE. The field name to look up. Name will be cleaned up. +"RTN","TMGSRCH1",114,0) + NEW DIC,X,Y SET Y=0 +"RTN","TMGSRCH1",115,0) + IF TMGNAME="" SET TMGFILE=0 GOTO FLDNDN +"RTN","TMGSRCH1",116,0) + SET DIC="^DD("_+TMGFILE_"," +"RTN","TMGSRCH1",117,0) + SET TMGNAME=$$TRIM^XLFSTR(TMGNAME,," ") +"RTN","TMGSRCH1",118,0) + SET TMGNAME=$$TRIM^XLFSTR(TMGNAME,,"""") +"RTN","TMGSRCH1",119,0) + SET X=TMGNAME +"RTN","TMGSRCH1",120,0) + DO ^DIC +"RTN","TMGSRCH1",121,0) + IF +Y'>0 GOTO FLDNDN +"RTN","TMGSRCH1",122,0) + NEW INFO SET INFO=$PIECE($GET(^DD(+TMGFILE,+Y,0)),"^",2) +"RTN","TMGSRCH1",123,0) + IF INFO'["P" SET TMGFILE=0 GOTO FLDNDN +"RTN","TMGSRCH1",124,0) + SET TMGFILE=+$PIECE(INFO,"P",2) +"RTN","TMGSRCH1",125,0) +FLDNDN QUIT +Y +"RTN","TMGSRCH1",126,0) + ; +"RTN","TMGSRCH1",127,0) +FIXCOMP(COMP,ERR) ; +"RTN","TMGSRCH1",128,0) + ;"Purpose: to standardize value comparators, e.g. <> becomes '= +"RTN","TMGSRCH1",129,0) + NEW RESULT SET RESULT="" +"RTN","TMGSRCH1",130,0) + IF COMP="=" SET RESULT=COMP GOTO FCDN +"RTN","TMGSRCH1",131,0) + NEW COMPSAV SET COMPSAV=COMP +"RTN","TMGSRCH1",132,0) + SET COMP=$$UP^XLFSTR(COMP) +"RTN","TMGSRCH1",133,0) + IF (COMP="<>") SET COMP="'=" +"RTN","TMGSRCH1",134,0) + ELSE IF (COMP=">=") SET COMP="'<" +"RTN","TMGSRCH1",135,0) + ELSE IF (COMP="<=") SET COMP="'>" +"RTN","TMGSRCH1",136,0) + ELSE IF (COMP="{") SET COMP="IN" +"RTN","TMGSRCH1",137,0) + NEW NOT +"RTN","TMGSRCH1",138,0) + SET NOT=$EXTRACT(COMP,1) IF NOT="'" SET COMP=$EXTRACT(COMP,2,999) +"RTN","TMGSRCH1",139,0) + ELSE SET NOT="" +"RTN","TMGSRCH1",140,0) + IF (COMP="=")!(COMP="[")!(COMP="IN")!(COMP="<")!(COMP=">") DO +"RTN","TMGSRCH1",141,0) + . SET RESULT=NOT_COMP +"RTN","TMGSRCH1",142,0) + ELSE SET ERR="-1^'"_COMPSAV_"' is not a valid comparator." +"RTN","TMGSRCH1",143,0) +FCDN QUIT RESULT +"RTN","TMGSRCH1",144,0) + ; +"RTN","TMGSRCH1",145,0) +FIXCOMB(COMB,ERR) ; +"RTN","TMGSRCH1",146,0) + ;"Purpose: to standardize expression combiners, e.g. | becomes OR +"RTN","TMGSRCH1",147,0) + NEW COMBSAV SET COMBSAV=COMB +"RTN","TMGSRCH1",148,0) + IF (COMB="|")!(COMB="||")!(COMB="!") SET COMB="OR" +"RTN","TMGSRCH1",149,0) + ELSE IF (COMB="&")!(COMB="&&") SET COMB="AND" +"RTN","TMGSRCH1",150,0) + ELSE IF (COMB="'")!(COMB="ANDNOT") SET COMB="NOT" +"RTN","TMGSRCH1",151,0) + IF (COMB'="AND")&(COMB'="OR")&(COMB'="NOT") SET COMB="" +"RTN","TMGSRCH1",152,0) + IF COMB="" SET ERR="-1^'"_COMBSAV_"' is not a valid set combiner." +"RTN","TMGSRCH1",153,0) + QUIT COMB +"RTN","TMGSRCH1",154,0) + ; +"RTN","TMGSRCH1",155,0) +STDDATE(TMGDATE,ERR) ; +"RTN","TMGSRCH1",156,0) + ;"Purpose: return a standardized date, or report error +"RTN","TMGSRCH1",157,0) + NEW X,Y,%DT +"RTN","TMGSRCH1",158,0) + NEW RESULT SET RESULT="" +"RTN","TMGSRCH1",159,0) + SET %DT="T" +"RTN","TMGSRCH1",160,0) + SET X=TMGDATE +"RTN","TMGSRCH1",161,0) + DO ^%DT +"RTN","TMGSRCH1",162,0) + IF Y=-1 SET ERR="-1^Invalid date: ["_X_"]" +"RTN","TMGSRCH1",163,0) + ELSE SET RESULT=$$FMTE^XLFDT(Y,5) +"RTN","TMGSRCH1",164,0) + QUIT RESULT +"RTN","TMGSRCH1",165,0) + ; +"RTN","TMGSRCH1",166,0) +GETAFSUB(TMGOUT,TMGPARAMS) ;"GET ALLOW FILES SUBSET +"RTN","TMGSRCH1",167,0) + ;"Purpose: For a given file to be searched, return sublist of allowed +"RTN","TMGSRCH1",168,0) + ;" related files which can be used as search terms. NOTE: only +"RTN","TMGSRCH1",169,0) + ;" files that point back to the original search file are allowed. +"RTN","TMGSRCH1",170,0) + ;" NOTE: This function will return not only files that point +"RTN","TMGSRCH1",171,0) + ;" directly back to search file, but also files that point to +"RTN","TMGSRCH1",172,0) + ;" other files that point to search file. In fact, there can +"RTN","TMGSRCH1",173,0) + ;" be a distance of 3 files between returned file and search file. +"RTN","TMGSRCH1",174,0) + ;" If this allowed distance of 3 files is changed, then PATHTO() +"RTN","TMGSRCH1",175,0) + ;" must also be changed. +"RTN","TMGSRCH1",176,0) + ;" NOTE: Subfiles not currently supported +"RTN","TMGSRCH1",177,0) + ;"Input: TMGPARAMS -- FileNum^ListStartValue^direction^MaxCount(optional, def=44)^Simple +"RTN","TMGSRCH1",178,0) + ;" FileNum -- this is the search file, results must point back to this +"RTN","TMGSRCH1",179,0) + ;" ListStartValue -- OPTIONAL -- text to $ORDER() from +"RTN","TMGSRCH1",180,0) + ;" Direction -- $ORDER(xx,Direction) direction (should be 1 or -1) -- OPTIONAL +"RTN","TMGSRCH1",181,0) + ;" MaxCount -- OPTIONAL. Default is 44 values returned. +"RTN","TMGSRCH1",182,0) + ;" Simple -- OPTIONAL Default is 0 (false). If 1, then +"RTN","TMGSRCH1",183,0) + ;" a very limited list of files returned, with +"RTN","TMGSRCH1",184,0) + ;" more user-friendly pseudo names +"RTN","TMGSRCH1",185,0) + ;"Output: TMGRESULTS is filled as follows. +"RTN","TMGSRCH1",186,0) + ;" TMGRESULT(0)="1^Success" or "-1^Message" +"RTN","TMGSRCH1",187,0) + ;" TMGRESULT(1)=IEN^FileName +"RTN","TMGSRCH1",188,0) + ;" TMGRESULT(2)=IEN^FileName +"RTN","TMGSRCH1",189,0) + ;"NOTE: Any files that don't have data are excluded. +"RTN","TMGSRCH1",190,0) + NEW TMGFILE SET TMGFILE=+$PIECE(TMGPARAMS,"^",1) +"RTN","TMGSRCH1",191,0) + IF TMGFILE'>0 DO GOTO GAFSDN +"RTN","TMGSRCH1",192,0) + . SET TMGOUT(0)="-1^No file number supplied" +"RTN","TMGSRCH1",193,0) + NEW TMGFROM SET TMGFROM=$PIECE(TMGPARAMS,"^",2) +"RTN","TMGSRCH1",194,0) + NEW TMGDIR SET TMGDIR=$PIECE(TMGPARAMS,"^",3) +"RTN","TMGSRCH1",195,0) + IF TMGDIR'=-1 SET TMGDIR=1 +"RTN","TMGSRCH1",196,0) + NEW TMGMAXCT SET TMGMAXCT=+$PIECE(TMGPARAMS,"^",4) +"RTN","TMGSRCH1",197,0) + IF TMGMAXCT=0 SET TMGMAXCT=44 +"RTN","TMGSRCH1",198,0) + NEW TMGSIMPLE SET TMGSIMPLE=+$PIECE(TMGPARAMS,"^",5) +"RTN","TMGSRCH1",199,0) + ; +"RTN","TMGSRCH1",200,0) + IF (TMGFILE=2),(TMGSIMPLE=1) DO GOTO GAFS0 +"RTN","TMGSRCH1",201,0) + . SET TMGOUT(1)="2^1. PATIENT INFO" +"RTN","TMGSRCH1",202,0) + . SET TMGOUT(2)="8925^2. NOTES" +"RTN","TMGSRCH1",203,0) + . SET TMGOUT(3)="120.5^3. VITALS" +"RTN","TMGSRCH1",204,0) + . SET TMGOUT(4)="9000010^4. VISIT" +"RTN","TMGSRCH1",205,0) + . SET TMGOUT(5)="9000010.18^5. LINKED CPT CODE" +"RTN","TMGSRCH1",206,0) + ; +"RTN","TMGSRCH1",207,0) + NEW TMGREF SET TMGREF=$NAME(^TMP("TMG","TMGSRCH",$J,"ALLOWED FILES",TMGFILE)) +"RTN","TMGSRCH1",208,0) + IF $DATA(@TMGREF)=0 DO +"RTN","TMGSRCH1",209,0) + . DO SETUPLS(TMGREF,TMGFILE) +"RTN","TMGSRCH1",210,0) + NEW TMGSTARTIEN SET TMGSTARTIEN="" +"RTN","TMGSRCH1",211,0) + NEW TMGI SET TMGI=0 +"RTN","TMGSRCH1",212,0) + FOR SET TMGFROM=$ORDER(@TMGREF@("B",TMGFROM),TMGDIR) QUIT:(TMGFROM="")!(TMGI'0)!(TMGI'0) DO +"RTN","TMGSRCH1",236,0) + . SET NAME=$PIECE($GET(^DIC(AFILE,0)),"^",1) QUIT:NAME="" +"RTN","TMGSRCH1",237,0) + . SET GL=$GET(^DIC(AFILE,0,"GL")) QUIT:(GL="") +"RTN","TMGSRCH1",238,0) + . SET GL=GL_"0)" NEW INFO SET INFO=$GET(@GL) +"RTN","TMGSRCH1",239,0) + . NEW NUMRECS SET NUMRECS=+$PIECE(INFO,"^",4) QUIT:NUMRECS'>0 +"RTN","TMGSRCH1",240,0) + . SET @POUT@("B",NAME,AFILE)="" +"RTN","TMGSRCH1",241,0) + . IF CT<3 DO SETUPLS(POUT,AFILE,CT+1) +"RTN","TMGSRCH1",242,0) + QUIT +"RTN","TMGSRCH1",243,0) + ; +"RTN","TMGSRCH1",244,0) +GETFLDSB(TMGOUT,TMGPARAMS) ; +"RTN","TMGSRCH1",245,0) + ;"Purpose: Get FIELD list subset, for file +"RTN","TMGSRCH1",246,0) + ;"Input: TMGPARAMS -- FileNum^ListStartValue^direction^MaxCount(optional, def=44)^Simple +"RTN","TMGSRCH1",247,0) + ;" FileNum -- this is the file to get fields in +"RTN","TMGSRCH1",248,0) + ;" ListStartValue -- OPTIONAL -- text to $ORDER() from +"RTN","TMGSRCH1",249,0) + ;" Direction -- $ORDER(xx,Direction) direction (should be 1 or -1) -- OPTIONAL +"RTN","TMGSRCH1",250,0) + ;" MaxCount -- OPTIONAL. Default is 44 values returned. +"RTN","TMGSRCH1",251,0) + ;" Simple -- OPTIONAL Default is 0 (false). If 1, then +"RTN","TMGSRCH1",252,0) + ;" a very limited list of files returned, with +"RTN","TMGSRCH1",253,0) + ;" more user-friendly pseudo names +"RTN","TMGSRCH1",254,0) + ;"Output: TMGRESULTS is filled as follows. +"RTN","TMGSRCH1",255,0) + ;" TMGRESULT(0)="1^Success" or "-1^Message" +"RTN","TMGSRCH1",256,0) + ;" TMGRESULT(1)=FldNum^Name^InfoNodes2-4 +"RTN","TMGSRCH1",257,0) + ;" TMGRESULT(2)=FldNum^Name^InfoNodes2-4 +"RTN","TMGSRCH1",258,0) + ;"NOTE: Any files that don't have data are excluded. Subfiles also excluded +"RTN","TMGSRCH1",259,0) + NEW TMGFILE SET TMGFILE=+$PIECE(TMGPARAMS,"^",1) +"RTN","TMGSRCH1",260,0) + IF TMGFILE'>0 DO GOTO GFSBDN +"RTN","TMGSRCH1",261,0) + . SET TMGOUT(0)="-1^No file number supplied" +"RTN","TMGSRCH1",262,0) + NEW TMGFROM SET TMGFROM=$PIECE(TMGPARAMS,"^",2) +"RTN","TMGSRCH1",263,0) + NEW TMGDIR SET TMGDIR=$PIECE(TMGPARAMS,"^",3) +"RTN","TMGSRCH1",264,0) + IF TMGDIR'=-1 SET TMGDIR=1 +"RTN","TMGSRCH1",265,0) + NEW TMGMAXCT SET TMGMAXCT=+$PIECE(TMGPARAMS,"^",4) +"RTN","TMGSRCH1",266,0) + IF TMGMAXCT=0 SET TMGMAXCT=44 +"RTN","TMGSRCH1",267,0) + NEW TMGSIMPLE SET TMGSIMPLE=+$PIECE(TMGPARAMS,"^",5) +"RTN","TMGSRCH1",268,0) + ; +"RTN","TMGSRCH1",269,0) + NEW TMGI SET TMGI=0 +"RTN","TMGSRCH1",270,0) + NEW HANDLED SET HANDLED=0 +"RTN","TMGSRCH1",271,0) + IF TMGSIMPLE DO +"RTN","TMGSRCH1",272,0) + . IF TMGFILE=2 DO ;"2^PATIENT INFO" +"RTN","TMGSRCH1",273,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".01^NAME" +"RTN","TMGSRCH1",274,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".02^SEX" +"RTN","TMGSRCH1",275,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".03^DATE OF BIRTH" +"RTN","TMGSRCH1",276,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".033^AGE" +"RTN","TMGSRCH1",277,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".05^MARITAL STATUS" +"RTN","TMGSRCH1",278,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".07^OCCUPATION" +"RTN","TMGSRCH1",279,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".09^SOCIAL SECURITY NUMBER" +"RTN","TMGSRCH1",280,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".114^CITY" +"RTN","TMGSRCH1",281,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".115^STATE" +"RTN","TMGSRCH1",282,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".116^ZIP CODE" +"RTN","TMGSRCH1",283,0) + . . SET HANDLED=1 +"RTN","TMGSRCH1",284,0) + . IF TMGFILE=8925 DO ;"8925^NOTES" +"RTN","TMGSRCH1",285,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".01^TYPE OF NOTE" +"RTN","TMGSRCH1",286,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".05^STATUS" +"RTN","TMGSRCH1",287,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".07^BEGINNING DATE" +"RTN","TMGSRCH1",288,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".08^ENDING DATE" +"RTN","TMGSRCH1",289,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)="2^NOTE TEXT" +"RTN","TMGSRCH1",290,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)="1201^CREATION DATE" +"RTN","TMGSRCH1",291,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)="1202^AUTHOR/DICTATOR" +"RTN","TMGSRCH1",292,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)="1204^EXPECTED SIGNER" +"RTN","TMGSRCH1",293,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)="1211^VISIT LOCATION" +"RTN","TMGSRCH1",294,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)="1502^SIGNED BY" +"RTN","TMGSRCH1",295,0) + . . SET HANDLED=1 +"RTN","TMGSRCH1",296,0) + . IF TMGFILE=120.5 DO ;"120.5^VITALS" +"RTN","TMGSRCH1",297,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".01^DATE/TIME TAKEN" +"RTN","TMGSRCH1",298,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".03^VITAL TYPE" +"RTN","TMGSRCH1",299,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".05^LOCATION" +"RTN","TMGSRCH1",300,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)="1.2^VALUE" +"RTN","TMGSRCH1",301,0) + . . SET HANDLED=1 +"RTN","TMGSRCH1",302,0) + . IF TMGFILE=9000010 DO ;"9000010^VISIT" +"RTN","TMGSRCH1",303,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".01^DATE/TIME" +"RTN","TMGSRCH1",304,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".03^TYPE" +"RTN","TMGSRCH1",305,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".22^LOCATION" +"RTN","TMGSRCH1",306,0) + . . SET HANDLED=1 +"RTN","TMGSRCH1",307,0) + . IF TMGFILE=9000010.18 DO ;"9000010.18^LINKED CPT CODE" +"RTN","TMGSRCH1",308,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".01^CPT NAME" +"RTN","TMGSRCH1",309,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".04^PROVIDER NARRATIVE" +"RTN","TMGSRCH1",310,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".05^DIAGNOSIS" +"RTN","TMGSRCH1",311,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".07^PRINCIPLE PROCEDURE" +"RTN","TMGSRCH1",312,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)="1204^ENCOUNTER PROVIDER" +"RTN","TMGSRCH1",313,0) + . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)="80201^CATEGORY" +"RTN","TMGSRCH1",314,0) + . . SET HANDLED=1 +"RTN","TMGSRCH1",315,0) + IF HANDLED DO ADDINFO(TMGFILE,.TMGOUT) GOTO GFSB0 +"RTN","TMGSRCH1",316,0) + ; +"RTN","TMGSRCH1",317,0) + NEW TMGREF SET TMGREF=$NAME(^DD(TMGFILE)) +"RTN","TMGSRCH1",318,0) + FOR SET TMGFROM=$ORDER(@TMGREF@("B",TMGFROM),TMGDIR) QUIT:(TMGFROM="")!(TMGI'0)!(TMGI'0,($$ISWPFLD^TMGDBAPI(TMGFILE,TMGFLD)=0) QUIT ;"Don't return subfile fields (for now) +"RTN","TMGSRCH1",323,0) + . . SET TMGI=TMGI+1 +"RTN","TMGSRCH1",324,0) + . . SET TMGOUT(TMGI)=TMGFLD_"^"_TMGFROM_"^"_INFO +"RTN","TMGSRCH1",325,0) + ; +"RTN","TMGSRCH1",326,0) +GFSB0 SET TMGOUT(0)="1^Success" +"RTN","TMGSRCH1",327,0) +GFSBDN QUIT +"RTN","TMGSRCH1",328,0) + ; +"RTN","TMGSRCH1",329,0) +ADDINFO(TMGFILE,TMGOUT); +"RTN","TMGSRCH1",330,0) + ;"Purpose: To add INFO to field entries, as created in GETFLDSB +"RTN","TMGSRCH1",331,0) + NEW I SET I=0 +"RTN","TMGSRCH1",332,0) + FOR SET I=$ORDER(TMGOUT(I)) QUIT:(+I'>0) DO +"RTN","TMGSRCH1",333,0) + . NEW ENTRY SET ENTRY=$GET(TMGOUT(I)) QUIT:(ENTRY="") +"RTN","TMGSRCH1",334,0) + . NEW TMGFLD SET TMGFLD=+ENTRY +"RTN","TMGSRCH1",335,0) + . NEW INFO SET INFO=$PIECE($GET(^DD(TMGFILE,TMGFLD,0)),"^",2,4) +"RTN","TMGSRCH1",336,0) + . SET TMGOUT(I)=ENTRY_"^"_INFO +"RTN","TMGSRCH1",337,0) + QUIT +"RTN","TMGSTUTL") +0^3^B14433 +"RTN","TMGSTUTL",1,0) +TMGSTUTL ;TMG/kst/String Utilities and Library ;03/25/06,5/10/10 ; 5/19/10 5:01pm +"RTN","TMGSTUTL",2,0) + ;;1.0;TMG-LIB;**1**;09/01/05;Build 1 +"RTN","TMGSTUTL",3,0) + +"RTN","TMGSTUTL",4,0) + ;"TMG STRING UTILITIES +"RTN","TMGSTUTL",5,0) + +"RTN","TMGSTUTL",6,0) + ;"======================================================================= +"RTN","TMGSTUTL",7,0) + ;" API -- Public Functions. +"RTN","TMGSTUTL",8,0) + ;"======================================================================= +"RTN","TMGSTUTL",9,0) + ;"CleaveToArray^TMGSTUTL(Text,Divider,Array) +"RTN","TMGSTUTL",10,0) + ;"CatArray(Words,i1,i2,DivChr) -- return concat array from index1 to index2 +"RTN","TMGSTUTL",11,0) + ;"CleaveStr^TMGSTUTL(Text,Divider,PartB) +"RTN","TMGSTUTL",12,0) + ;"SplitStr^TMGSTUTL(Text,Width,PartB) +"RTN","TMGSTUTL",13,0) + ;"SetStrLen^TMGSTUTL(Text,Width) +"RTN","TMGSTUTL",14,0) + ;"$$NestSplit^TMGSTUTL(Text,OpenBracket,CloseBracket,SBefore,S,SAfter) +"RTN","TMGSTUTL",15,0) + ;"$$Substitute^TMGSTUTL(S,Match,NewValue) +"RTN","TMGSTUTL",16,0) + ;"$$FormatArray^TMGSTUTL(InArray,OutArray,Divider) +"RTN","TMGSTUTL",17,0) + ;"$$Trim^TMGSTUTL(S,TrimCh) ; --> or use $$TRIM^XLFSTR +"RTN","TMGSTUTL",18,0) + ;"$$TrimL^TMGSTUTL(S,TrimCh) +"RTN","TMGSTUTL",19,0) + ;"$$TrimR^TMGSTUTL(S,TrimCh) +"RTN","TMGSTUTL",20,0) + ;"$$TrimRType^TMGSTUTL(S,type) +"RTN","TMGSTUTL",21,0) + ;"$$NumLWS^TMGSTUTL(S) +"RTN","TMGSTUTL",22,0) + ;"$$MakeWS^TMGSTUTL(n) +"RTN","TMGSTUTL",23,0) + ;"WordWrapArray^TMGSTUTL(.Array,Width,SpecialIndent) +"RTN","TMGSTUTL",24,0) + ;"SplitLine^TMGSTUTL(s,.LineArray,Width) +"RTN","TMGSTUTL",25,0) + ;"WriteWP^TMGSTUTL(NodeRef) +"RTN","TMGSTUTL",26,0) + ;"$$LPad^TMGSTUTL(S,width) ;"NOTE: should use XLFSTR fn below +"RTN","TMGSTUTL",27,0) + ;"$$RPad^TMGSTUTL(S,width) ;"NOTE: should use XLFSTR fn below +"RTN","TMGSTUTL",28,0) + ;"$$Center^TMGSTUTL(S,width) ;"NOTE: should use XLFSTR fn below +"RTN","TMGSTUTL",29,0) + ;"$$Clip^TMGSTUTL(S,width) +"RTN","TMGSTUTL",30,0) + ;"$$STRB2H^TMGSTUTL(s,F) Convert a string to hex characters +"RTN","TMGSTUTL",31,0) + ;"$$CapWords^TMGSTUTL(S,Divider) ;"capitalize the first character of each word in a string +"RTN","TMGSTUTL",32,0) + ;"$$LinuxStr^TMGSTUTL(S) ;"Convert string to a valid linux filename +"RTN","TMGSTUTL",33,0) + ;"StrToWP^TMGSTUTL(s,pArray,width,DivCh,InitLine) ;"wrap long string into a WP array +"RTN","TMGSTUTL",34,0) + ;"$$WPToStr^TMGSTUTL(pArray,DivCh,MaxLen,InitLine) +"RTN","TMGSTUTL",35,0) + ;"Comp2Strs(s1,s2) -- compare two strings and assign an arbritrary score to their similarity +"RTN","TMGSTUTL",36,0) + ;"$$PosNum(s,[Num],LeadingSpace) -- return position of a number in a string +"RTN","TMGSTUTL",37,0) + ;"IsNumeric(s) -- deterimine if word s is a numeric +"RTN","TMGSTUTL",38,0) + ;"ScrubNumeric(s) -- remove numeric words from a sentence +"RTN","TMGSTUTL",39,0) + ;"Pos(subStr,s,count) -- return the beginning position of subStr in s +"RTN","TMGSTUTL",40,0) + ;"DiffPos(s1,s2) -- Return the position of the first difference between s1 and s2 +"RTN","TMGSTUTL",41,0) + ;"DiffWords(Words1,Words2) -- Return index of first different word between Words arrays +"RTN","TMGSTUTL",42,0) + ;"SimStr(s1,p1,s2,p2) -- return matching string in s1 and s2, starting at position p1,p2 +"RTN","TMGSTUTL",43,0) + ;"SimWord(Words1,p1,Words2,p2) -- return the matching words in both words array 1 and 2, starting +"RTN","TMGSTUTL",44,0) + ;" at word positions p1 and p2. +"RTN","TMGSTUTL",45,0) + ;"SimPos(s1,s2) -- return the first position that two strings are similar. +"RTN","TMGSTUTL",46,0) + ;"SimWPos(Words1,Words2,DivStr,p1,p2,MatchStr) -- return the first position that two word arrays +"RTN","TMGSTUTL",47,0) + ;" are similar. This means the first index in Words array 1 that matches to words in Words array 2. +"RTN","TMGSTUTL",48,0) + ;"DiffStr(s1,s2,DivChr) -- Return how s1 differs from s2. +"RTN","TMGSTUTL",49,0) + ;"CatArray(Words,i1,i2,DivChr) -- return concat array from index1 to index2 +"RTN","TMGSTUTL",50,0) + ;"$$QtProtect(s) -- Protects quotes by converting all quotes to double quotes (" --> "") +"RTN","TMGSTUTL",51,0) + ;"$$QTPROTECT(S) -- Same as $$QtProtect(s) +"RTN","TMGSTUTL",52,0) + ;"$$InQt(s,Pos) -- return if a character at position P is inside quotes in s +"RTN","TMGSTUTL",53,0) + ;"$$HNQTSUB(s,SubStr) --Same as $$HasNonQtSub +"RTN","TMGSTUTL",54,0) + ;"$$HasNonQtSub(s,SubStr) -- return if string s contains SubStr, but not inside quotes. +"RTN","TMGSTUTL",55,0) + ;"$$GetWord(s,Pos,OpenDiv,CloseDiv) -- extract a word from a sentance, bounded by OpenDiv,CloseDiv +"RTN","TMGSTUTL",56,0) + ;"$$MATCHXTR(s,DivCh,Group,Map) -- Same as $$MatchXtract +"RTN","TMGSTUTL",57,0) + ;"$$MatchXtract(s,DivCh,Group,Map) -- extract a string bounded by DivCh, honoring matching encapsulators +"RTN","TMGSTUTL",58,0) + ;"MapMatch(s,Map) -- map a string with nested braces, parentheses etc (encapsulators) +"RTN","TMGSTUTL",59,0) + ;"$$CmdChStrip(s) -- Strips all characters < #32 from string. +"RTN","TMGSTUTL",60,0) + ;"$$StrBounds(s,p) -- return position of end of string +"RTN","TMGSTUTL",61,0) + ;"NonWhite(s,p) -- return index of first non-whitespace character +"RTN","TMGSTUTL",62,0) + ;"Pad2Pos(Pos,ch) -- return a padding string from current $X up to Pos, using ch +"RTN","TMGSTUTL",63,0) + ;"HTML2TXT(Array) -- Take WP array that is HTML formatted, and strip

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

, and +"RTN","TMGSTUTL",1647,0) + ;" return in a format of 1 line per array node. +"RTN","TMGSTUTL",1648,0) + ;"Input: Array -- PASS BY REFERENCE. This array will be altered. +"RTN","TMGSTUTL",1649,0) + ;"Results: none +"RTN","TMGSTUTL",1650,0) + ;"NOTE: This conversion causes some loss of HTML tags, so a round trip +"RTN","TMGSTUTL",1651,0) + ;" conversion back to HTML would fail. +"RTN","TMGSTUTL",1652,0) + ;"Called from: TMGTIUOJ.m +"RTN","TMGSTUTL",1653,0) + +"RTN","TMGSTUTL",1654,0) + new outArray,outI +"RTN","TMGSTUTL",1655,0) + set outI=1 +"RTN","TMGSTUTL",1656,0) + +"RTN","TMGSTUTL",1657,0) + ;"Clear out confusing non-breaking spaces. +"RTN","TMGSTUTL",1658,0) + new spec +"RTN","TMGSTUTL",1659,0) + set spec(" ")=" " +"RTN","TMGSTUTL",1660,0) + set spec("<")="<" +"RTN","TMGSTUTL",1661,0) + set spec(">")=">" +"RTN","TMGSTUTL",1662,0) + set spec("&")="&" +"RTN","TMGSTUTL",1663,0) + set spec(""")="""" +"RTN","TMGSTUTL",1664,0) + new line set line=0 +"RTN","TMGSTUTL",1665,0) + for set line=$order(Array(line)) quit:(line="") do +"RTN","TMGSTUTL",1666,0) + . new lineS set lineS=$get(Array(line,0)) +"RTN","TMGSTUTL",1667,0) + . set Array(line,0)=$$REPLACE^XLFSTR(lineS,.spec) +"RTN","TMGSTUTL",1668,0) + +"RTN","TMGSTUTL",1669,0) + new s2 set s2="" +"RTN","TMGSTUTL",1670,0) + new line set line=0 +"RTN","TMGSTUTL",1671,0) + for set line=$order(Array(line)) quit:(line="") do +"RTN","TMGSTUTL",1672,0) + . new lineS set lineS=s2_$get(Array(line,0)) +"RTN","TMGSTUTL",1673,0) + . set s2="" +"RTN","TMGSTUTL",1674,0) + . for do quit:(lineS'["<") +"RTN","TMGSTUTL",1675,0) + . . if (lineS["

")&($piece(lineS,"

",1)'["
") do quit +"RTN","TMGSTUTL",1676,0) + . . . set outArray(outI,0)=$piece(lineS,"

",1) +"RTN","TMGSTUTL",1677,0) + . . . set outI=outI+1 +"RTN","TMGSTUTL",1678,0) + . . . set outArray(outI,0)="" ;"Add blank line to create paragraph break. +"RTN","TMGSTUTL",1679,0) + . . . set outI=outI+1 +"RTN","TMGSTUTL",1680,0) + . . . set lineS=$piece(lineS,"

",2,999) +"RTN","TMGSTUTL",1681,0) + . . if (lineS["

")&($piece(lineS,"

",1)'["
") do quit +"RTN","TMGSTUTL",1682,0) + . . . set outArray(outI,0)=$piece(lineS,"

",1) +"RTN","TMGSTUTL",1683,0) + . . . set outI=outI+1 +"RTN","TMGSTUTL",1684,0) + . . . set outArray(outI,0)="" ;"Add blank line to create paragraph break. +"RTN","TMGSTUTL",1685,0) + . . . set outI=outI+1 +"RTN","TMGSTUTL",1686,0) + . . . set lineS=$piece(lineS,"

",2,999) +"RTN","TMGSTUTL",1687,0) + . . if (lineS["")&($piece(lineS,"",1)'["
") do quit +"RTN","TMGSTUTL",1688,0) + . . . set outArray(outI,0)=$piece(lineS,"",1) ;" _"" +"RTN","TMGSTUTL",1689,0) + . . . set outI=outI+1 +"RTN","TMGSTUTL",1690,0) + . . . set outArray(outI,0)="" ;"Add blank line to create paragraph break. +"RTN","TMGSTUTL",1691,0) + . . . set outI=outI+1 +"RTN","TMGSTUTL",1692,0) + . . . set lineS=$piece(lineS,"",2,999) +"RTN","TMGSTUTL",1693,0) + . . if lineS["
" do quit +"RTN","TMGSTUTL",1694,0) + . . . set outArray(outI,0)=$piece(lineS,"
",1) +"RTN","TMGSTUTL",1695,0) + . . . set outI=outI+1 +"RTN","TMGSTUTL",1696,0) + . . . set lineS=$piece(lineS,"
",2,999) +"RTN","TMGSTUTL",1697,0) + . . set s2=lineS,lineS="" +"RTN","TMGSTUTL",1698,0) + . set s2=s2_lineS +"RTN","TMGSTUTL",1699,0) + if s2'="" do +"RTN","TMGSTUTL",1700,0) + . set outArray(outI,0)=s2 +"RTN","TMGSTUTL",1701,0) + . set outI=outI+1 +"RTN","TMGSTUTL",1702,0) + +"RTN","TMGSTUTL",1703,0) + kill Array +"RTN","TMGSTUTL",1704,0) + merge Array=outArray +"RTN","TMGSTUTL",1705,0) + quit +"RTN","TMGSTUTL",1706,0) + +"RTN","TMGSTUTL",1707,0) + +"RTN","TMGSTUTL",1708,0) +TrimTags(lineS) +"RTN","TMGSTUTL",1709,0) + ;"Purpose: To cut out HTML tags (e.g. <...>) from lineS, however, is protected +"RTN","TMGSTUTL",1710,0) + ;"Input: lineS : the string to work on. +"RTN","TMGSTUTL",1711,0) + ;"Results: the modified string +"RTN","TMGSTUTL",1712,0) + ;"Called from: TMGTIUOJ.m +"RTN","TMGSTUTL",1713,0) + new result,key,spec +"RTN","TMGSTUTL",1714,0) + set spec("")="[no data]" +"RTN","TMGSTUTL",1715,0) + set result=$$REPLACE^XLFSTR(lineS,.spec) +"RTN","TMGSTUTL",1716,0) + for quit:((result'["<")!(result'[">")) do +"RTN","TMGSTUTL",1717,0) + . new partA,partB +"RTN","TMGSTUTL",1718,0) + . set partA=$piece(result,"<",1) +"RTN","TMGSTUTL",1719,0) + . new temp set temp=$extract(result,$length(partA)+1,999) +"RTN","TMGSTUTL",1720,0) + . set partB=$piece(temp,">",2,99) +"RTN","TMGSTUTL",1721,0) + . set result=partA_partB +"RTN","TMGSTUTL",1722,0) + quit result +"RTN","TMGSTUTL",1723,0) + +"RTN","TMGSTUTL",1724,0) +IsHTML(IEN8925) +"RTN","TMGSTUTL",1725,0) + ;"Purpose: to specify if the text held in the REPORT TEXT field is HTML markup +"RTN","TMGSTUTL",1726,0) + ;"Input: IEN8925 -- record number in file 8925 +"RTN","TMGSTUTL",1727,0) + ;"Results: 1 if HTML markup, 0 otherwise. +"RTN","TMGSTUTL",1728,0) + ;"Note: This is not a perfect test. +"RTN","TMGSTUTL",1729,0) + ; +"RTN","TMGSTUTL",1730,0) + new result set result=0 +"RTN","TMGSTUTL",1731,0) + new Done set Done=0 +"RTN","TMGSTUTL",1732,0) + new line set line=0 +"RTN","TMGSTUTL",1733,0) + for set line=$order(^TIU(8925,IEN8925,"TEXT",line)) quit:(line="")!Done do +"RTN","TMGSTUTL",1734,0) + . new lineS set lineS=$$UP^XLFSTR($get(^TIU(8925,IEN8925,"TEXT",line,0))) +"RTN","TMGSTUTL",1735,0) + . if (lineS["") set Done=1,result=1 quit +"RTN","TMGSTUTL",1736,0) + quit result +"RTN","TMGSTUTL",1737,0) + +"VER") +8.0^22.0 +**END** +**END** Index: cprs/branches/tmg-cprs/Server_KIDS/TMG-CPRS-SEARCH-1.0-1.txt =================================================================== --- cprs/branches/tmg-cprs/Server_KIDS/TMG-CPRS-SEARCH-1.0-1.txt (revision 792) +++ cprs/branches/tmg-cprs/Server_KIDS/TMG-CPRS-SEARCH-1.0-1.txt (revision 792) @@ -0,0 +1,110 @@ +$TXT Created by TOPPENBERG,KEVIN at FAMILY PHYSICANS OF GREENEVILLE (KIDS) on Monday, 06/07/10 +============================================================================= +Run Date: JUNE 7,2010 Designation: TMG-CPRS-SEARCH-1.0*1 +Package : TMG - FAMILY PHYSICANS OF GREENEVILLE Priority: Optional +Version : 1 SEQ #3 Status: Released +============================================================================= + +Associated patches: None + +Subject: Patch to support TMG-CPRS + +Category: + - Routine + +Description: +============ + + This patch provides the functionality for TMG-CPRS's search function. + + INSTALLATION INSTRUCTIONS: + ========================== + This patch should cause minimal impact on live systems, as it provides only 1 routine, + Installation will take less than 1 minute. Users may remain on the system. Note: the + follow instructions were copied from another KIDS install and modified. There may be + some discrepancies. + + The following are instructions for those using the Packman method: + ------------------------------------------------------------------ + 1. Use the INSTALL/CHECK MESSAGE option on the PackMan menu. + + 2. Review your mapped set. If any of the routines listed in the + ROUTINE SUMMARY section are mapped, they should be removed + from the mapped set at this time. + + 3. From the Kernel Installation and Distribution System Menu, select + the Installation menu. + + 4. From this menu, you may elect to use the following options + (when prompted for INSTALL NAME, enter TMG-CPRS-SEARCH-1.0-1: + a. Backup a Transport Global + b. Compare Transport Global to Current System + c. Verify Checksums in Transport Global + + 5. Use the Install Package(s) option and select the package TMG-CPRS-SEARCH-1.0-1 + + 6. When prompted 'Want KIDS to INHIBIT LOGONs during the install? YES//' + respond NO. + + 7. When prompted 'Want to DISABLE Scheduled Options, Menu Options, and + Protocols? YES//', respond NO. + + 8. If routines were unmapped as part of step 2, they should be returned + to the mapped set once the installation has run to completion. + + 9. (See step 9 below) + + The following are instructions for those loading the patch via Host File System: + --------------------------------------------------------------------------------- + 1. Navigate the menu option path to reach the Kernel Installation and Distribution + System Menu. Or, the menu option XPD MAIN may be entered directly. + + 2. Next, at the menu displaying: + Edits and Distribution ... + Utilities ... + Installation ... <---------- pick this one. + + 3. Next, at the menu displaying the options as below, choose each of the options + in a step-by-step fashion, in numerical order (i.e. 1, 2, 3 etc.) Step #1 will + prompt the user to enter the file path on the host file system where the source + file is stored. The filename to enter is TMG-CPRS-SEARCH-1.0-1.KIDS, but add the + appropriate path. E.g. /tmp/TMG-CPRS-SEARCH-1.0-1.KIDS + + 1 Load a Distribution + 2 Verify Checksums in Transport Global + 3 Print Transport Global + 4 Compare Transport Global to Current System + 5 Backup a Transport Global + 6 Install Package(s) + Restart Install of Package(s) + Unload a Distribution + + 4. From this menu, you may elect to use the following options + (when prompted for INSTALL NAME, enter TMG-CPRS-SEARCH-1.0-1 + a. Backup a Transport Global + b. Compare Transport Global to Current System + c. Verify Checksums in Transport Global + + 5. Use the Install Package(s) option and select the package TMG1-1.0-3 + + 6. When prompted 'Want KIDS to INHIBIT LOGONs during the install? YES//' + respond NO. + + 7. When prompted 'Want to DISABLE Scheduled Options, Menu Options, and + Protocols? YES//', respond NO. + + 8. If routines were unmapped as part of step 2, they should be returned + to the mapped set once the installation has run to completion. + + +============================================================================= +User Information: +Entered By : TOPPENBERG,KEVIN Date Entered : JUNE 07,2010 +Completed By: TOPPENBERG,KEVIN Date Completed: JUNE 07,2010 +Released By : TOPPENBERG,KEVIN Date Released : JUNE 07,2010 +============================================================================= + +Packman Mail Message: +===================== + +$END TXT Index: cprs/branches/tmg-cprs/Server_KIDS/TMG-CPRS-TEXTOBJ-FMFLD-1.0-1.TXT =================================================================== --- cprs/branches/tmg-cprs/Server_KIDS/TMG-CPRS-TEXTOBJ-FMFLD-1.0-1.TXT (revision 739) +++ cprs/branches/tmg-cprs/Server_KIDS/TMG-CPRS-TEXTOBJ-FMFLD-1.0-1.TXT (revision 792) @@ -98,4 +98,6 @@ NAME: SMITH,JOHN A SEX: MALE + **Notice that results are returned in alphabetical order, based on field name, + not on order of requested fields. |TMG PATIENT FLD{NAME;SEX;AGE^S}|