KIDS Distribution saved on Jun 16, 2010@20:19:10 TMG-CPRS-SEARCH*1.0*2 **KIDS**:TMG-CPRS-SEARCH*1.0*2^ **INSTALL NAME** TMG-CPRS-SEARCH*1.0*2 "BLD",7635,0) TMG-CPRS-SEARCH*1.0*2^^0^3100616^n "BLD",7635,1,0) ^^9^9^3100616^^ "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,1,5,0) "BLD",7635,1,6,0) This patch corrects a missing routine (TMGRPCS0). "BLD",7635,1,7,0) This patch is a complete patch, not just supplying "BLD",7635,1,8,0) the missing parts from version *1 "BLD",7635,1,9,0) "BLD",7635,4,0) ^9.64PA^^0 "BLD",7635,6.3) 2 "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^10^10 "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",10,0) TMGRPCS0^^0^B115072705 "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","TMGRPCS0",10) "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) "BLD",7635,"PRET") "BLD",7635,"QUES",0) ^9.62^^ "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") 10 "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 2 "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 2 "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 2 "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 2 "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","TMGRPCS0") 0^10^B115072705 "RTN","TMGRPCS0",1,0) TMGRPCS0 ;TMG/kst/RPC entry points for Search API ; 6/4/10 "RTN","TMGRPCS0",2,0) ;;1.0;TMG-LIB;**1**;05/25/10;Build 2 "RTN","TMGRPCS0",3,0) ; "RTN","TMGRPCS0",4,0) ;"RPC ENTRY POINTS FOR TMG FILEMAN SEARCH API "RTN","TMGRPCS0",5,0) ; "RTN","TMGRPCS0",6,0) ;"Copyright Kevin Toppenberg MD 5/25/10 "RTN","TMGRPCS0",7,0) ;"Released under GNU General Public License (GPL) "RTN","TMGRPCS0",8,0) ;" "RTN","TMGRPCS0",9,0) ;"NOTE: this function depends on new version of LIST^DIC, from G. Timpson Patch "RTN","TMGRPCS0",10,0) ;"======================================================================= "RTN","TMGRPCS0",11,0) ;" RPC -- Public Functions. "RTN","TMGRPCS0",12,0) ;"======================================================================= "RTN","TMGRPCS0",13,0) ;"LAUNCH(OUT,PARAMS) -- launch background search thread, return JOB # "RTN","TMGRPCS0",14,0) ;"STATUS(OUT,JOBNUM) --Return status of background job. "RTN","TMGRPCS0",15,0) ;"IENLIST(OUT,JOBNUM) -- Return results from background search job. "RTN","TMGRPCS0",16,0) ;"IENDETAL(OUT,TMGPARAMS) -- Return Detail of 1 IEN from from results from background search job. "RTN","TMGRPCS0",17,0) ;"CLEAR(OUT,JOBNUM) -- Clear data from background search job. "RTN","TMGRPCS0",18,0) ;" "RTN","TMGRPCS0",19,0) ;"======================================================================= "RTN","TMGRPCS0",20,0) ;"PRIVATE API FUNCTIONS "RTN","TMGRPCS0",21,0) ;"======================================================================= "RTN","TMGRPCS0",22,0) ;" "RTN","TMGRPCS0",23,0) ;"======================================================================= "RTN","TMGRPCS0",24,0) ;"======================================================================= "RTN","TMGRPCS0",25,0) ;"Dependencies: "RTN","TMGRPCS0",26,0) ;" ^DIQ, ^XLFSTR, ^TMGSRCH "RTN","TMGRPCS0",27,0) ;"======================================================================= "RTN","TMGRPCS0",28,0) ;"======================================================================= "RTN","TMGRPCS0",29,0) ; "RTN","TMGRPCS0",30,0) TEST ; "RTN","TMGRPCS0",31,0) NEW STR,OUT "RTN","TMGRPCS0",32,0) ;"SET STR="8925:(STATUS=COMPLETED)&((PATIENT[CUTSHALL)!(PATIENT[CUTSHAW))" "RTN","TMGRPCS0",33,0) ;"SET STR="8925:(REPORT TEXT[DM-2)!(REPORT TEXT[HTN) AND 120.5:((VITAL TYPE=PULSE)&(RATE>70))" "RTN","TMGRPCS0",34,0) ;"SET STR="8925:(REPORT TEXT[DM-2) AND 120.5:((VITAL TYPE=PULSE)&(RATE>70))" "RTN","TMGRPCS0",35,0) ;"SET STR="8925:(REPORT TEXT[DM-2)!(REPORT TEXT[HTN)" "RTN","TMGRPCS0",36,0) SET STR="8925:(REPORT TEXT[HTN) AND 120.5:((VITAL TYPE=PULSE)&(RATE{70..75))" "RTN","TMGRPCS0",37,0) NEW RESULT "RTN","TMGRPCS0",38,0) DO LAUNCH(.RESULT,"2^"_STR) "RTN","TMGRPCS0",39,0) SET JOBNUM=+$GET(RESULT(0)) "RTN","TMGRPCS0",40,0) FOR DO QUIT:(STATUS["#DONE#") "RTN","TMGRPCS0",41,0) . HANG 1 "RTN","TMGRPCS0",42,0) . DO STATUS(.STATUS,JOBNUM) "RTN","TMGRPCS0",43,0) . WRITE "STATUS: ",STATUS,! "RTN","TMGRPCS0",44,0) DO IENLIST(.OUT,JOBNUM) ; "RTN","TMGRPCS0",45,0) IF $DATA(OUT) ZWR OUT "RTN","TMGRPCS0",46,0) DO PRESSTOCONT^TMGUSRIF "RTN","TMGRPCS0",47,0) QUIT "RTN","TMGRPCS0",48,0) ; "RTN","TMGRPCS0",49,0) LAUNCH(OUT,TMGPARAM) ; "RTN","TMGRPCS0",50,0) ;"Purpose: to launch background search thread, and return its JOB number "RTN","TMGRPCS0",51,0) ;"Input: OUT -- Passed by REFERENCE. A single value "RTN","TMGRPCS0",52,0) ;" TMGPARAM -- Filenumber^SearchString "RTN","TMGRPCS0",53,0) ;" Filenumber -- The file number to search for "RTN","TMGRPCS0",54,0) ;" SearchStr -- The logic string. See docs in TMGSRCH.m "RTN","TMGRPCS0",55,0) ;"Output: OUT=Job# or -1^Message "RTN","TMGRPCS0",56,0) ;"Results: None "RTN","TMGRPCS0",57,0) NEW FILENUM SET FILENUM=$PIECE(TMGPARAM,"^",1) "RTN","TMGRPCS0",58,0) NEW SRCHSTR SET SRCHSTR=$PIECE(TMGPARAM,"^",2) "RTN","TMGRPCS0",59,0) JOB BKSRCH^TMGSRCH(FILENUM,SRCHSTR) "RTN","TMGRPCS0",60,0) SET OUT(0)="1^"_$ZJOB "RTN","TMGRPCS0",61,0) QUIT "RTN","TMGRPCS0",62,0) ; "RTN","TMGRPCS0",63,0) STATUS(OUT,JOBNUM) ; "RTN","TMGRPCS0",64,0) ;"Purpose: Return status of background job. "RTN","TMGRPCS0",65,0) ;"Input: OUT -- Passed by REFERENCE. A single value "RTN","TMGRPCS0",66,0) ;" JOBNUM -- The job number of task to query "RTN","TMGRPCS0",67,0) ;"Output: OUT(0)=1^%Done^Message. Will be '100^#DONE#' when task is done. "RTN","TMGRPCS0",68,0) ;"Results: None "RTN","TMGRPCS0",69,0) NEW REF SET REF=$NAME(^TMP("TMG","TMGSRCH",JOBNUM)) "RTN","TMGRPCS0",70,0) NEW PCT SET PCT=$GET(@REF@("PCT")) "RTN","TMGRPCS0",71,0) NEW MSG SET MSG=$GET(@REF@("MSG")) "RTN","TMGRPCS0",72,0) NEW CNT SET CNT=$GET(@REF@("OUT","COUNT")) "RTN","TMGRPCS0",73,0) SET OUT(0)="1^"_PCT_"^"_MSG_"^"_CNT "RTN","TMGRPCS0",74,0) QUIT "RTN","TMGRPCS0",75,0) ; "RTN","TMGRPCS0",76,0) IENLIST(OUT,TMGPARAM) ; "RTN","TMGRPCS0",77,0) ;"Purpose: Return IEN LIST from results from background search job. "RTN","TMGRPCS0",78,0) ;" NOTE: This should not be called until STATUS() returns #DONE# "RTN","TMGRPCS0",79,0) ;"Input: OUT -- Passed by REFERENCE. And out array "RTN","TMGRPCS0",80,0) ;" TMGPARAM -- JOBNUM^FLDNUM "RTN","TMGRPCS0",81,0) ;" JOBNUM = The job number of task to query "RTN","TMGRPCS0",82,0) ;" FLDNUM = The desired field number. OPTIONAL. Default is none "RTN","TMGRPCS0",83,0) ;"Output: OUT(0)=status "RTN","TMGRPCS0",84,0) ;" OUT(index)=IEN^[VALUE] <-- Value is external value of FLD "RTN","TMGRPCS0",85,0) ;" OUT(index)=IEN^[VALUE] <-- Value is external value of FLD "RTN","TMGRPCS0",86,0) ;"Results: None "RTN","TMGRPCS0",87,0) NEW JOBNUM SET JOBNUM=+$PIECE(TMGPARAM,"^",1) "RTN","TMGRPCS0",88,0) NEW TMGFLD SET TMGFLD=+$PIECE(TMGPARAM,"^",2) "RTN","TMGRPCS0",89,0) NEW REF SET REF=$NAME(^TMP("TMG","TMGSRCH",JOBNUM)) "RTN","TMGRPCS0",90,0) NEW TMGFNUM SET TMGFNUM=+$GET(@REF@("OUT","FILENUM")) "RTN","TMGRPCS0",91,0) NEW I SET I=1 "RTN","TMGRPCS0",92,0) NEW IEN SET IEN=0 "RTN","TMGRPCS0",93,0) IF (TMGFLD>0),(TMGFNUM>0) GOTO IL2 ;"Handle differently "RTN","TMGRPCS0",94,0) ;"------------------------------------ "RTN","TMGRPCS0",95,0) FOR SET IEN=$ORDER(@REF@("OUT",IEN)) QUIT:(+IEN'>0) DO "RTN","TMGRPCS0",96,0) . NEW VALUE SET VALUE="" "RTN","TMGRPCS0",97,0) . IF (TMGFLD>0),(TMGFNUM>0) SET VALUE=$$GET1^DIQ(TMGFNUM,IEN_",",TMGFLD) "RTN","TMGRPCS0",98,0) . SET OUT(I)=IEN_"^"_VALUE "RTN","TMGRPCS0",99,0) . SET I=I+1 "RTN","TMGRPCS0",100,0) GOTO ILDN "RTN","TMGRPCS0",101,0) ;"------------------------------------ "RTN","TMGRPCS0",102,0) IL2 ;"Sort by FLD value, not IEN value "RTN","TMGRPCS0",103,0) NEW TEMP,VALUE "RTN","TMGRPCS0",104,0) FOR SET IEN=$ORDER(@REF@("OUT",IEN)) QUIT:(+IEN'>0) DO "RTN","TMGRPCS0",105,0) . SET VALUE=$$GET1^DIQ(TMGFNUM,IEN_",",TMGFLD) "RTN","TMGRPCS0",106,0) . SET TEMP(VALUE,IEN)="" "RTN","TMGRPCS0",107,0) SET VALUE="" "RTN","TMGRPCS0",108,0) FOR SET VALUE=$ORDER(TEMP(VALUE)) QUIT:(VALUE="") DO "RTN","TMGRPCS0",109,0) . SET IEN=0 FOR SET IEN=$ORDER(TEMP(VALUE,IEN)) QUIT:(IEN="") DO "RTN","TMGRPCS0",110,0) . . SET OUT(I)=IEN_"^"_VALUE "RTN","TMGRPCS0",111,0) . . SET I=I+1 "RTN","TMGRPCS0",112,0) ;"------------------------------------ "RTN","TMGRPCS0",113,0) ILDN IF $DATA(OUT)=0 SET OUT(0)="-1^NO RESULTS" "RTN","TMGRPCS0",114,0) ELSE SET OUT(0)="1^Success" "RTN","TMGRPCS0",115,0) QUIT "RTN","TMGRPCS0",116,0) ; "RTN","TMGRPCS0",117,0) PREPSB(OUT,TMGPARAMS) ;"Prep Subset "RTN","TMGRPCS0",118,0) ;"Purpose: Prepare an array that can be used by an TORComboBox.NeedData "RTN","TMGRPCS0",119,0) ;" to return a subset of the results. "RTN","TMGRPCS0",120,0) ;" NOTE: This should not be called until STATUS() returns #DONE# "RTN","TMGRPCS0",121,0) ;"Input: OUT -- Passed by REFERENCE. And out array "RTN","TMGRPCS0",122,0) ;" TMGPARAM -- JOBNUM^Field[;FLD[;FLD...]] "RTN","TMGRPCS0",123,0) ;" JOBNUM = The job number of task to query "RTN","TMGRPCS0",124,0) ;" Field... = The desired field number(s). OPTIONAL. DEFAULT is .01 "RTN","TMGRPCS0",125,0) ;" If more than one supplied, then output is "RTN","TMGRPCS0",126,0) ;" concatinated. Separate fieldnumbers with ';' "RTN","TMGRPCS0",127,0) ;"Output: OUT(0)=1^Success or -1^Message "RTN","TMGRPCS0",128,0) ;"Results: None "RTN","TMGRPCS0",129,0) NEW JOBNUM SET JOBNUM=+$PIECE(TMGPARAMS,"^",1) "RTN","TMGRPCS0",130,0) NEW TMGFLDS SET TMGFLDS=$PIECE(TMGPARAMS,"^",2) "RTN","TMGRPCS0",131,0) IF TMGFLDS="" SET TMGFLDS=".01" "RTN","TMGRPCS0",132,0) NEW REF SET REF=$NAME(^TMP("TMG","TMGSRCH",JOBNUM)) "RTN","TMGRPCS0",133,0) NEW TMGFNUM SET TMGFNUM=+$GET(@REF@("OUT","FILENUM")) "RTN","TMGRPCS0",134,0) IF TMGFNUM'>0 DO GOTO PREPDN "RTN","TMGRPCS0",135,0) . SET OUT(0)="-1^Unable to find file number at "_$NAME(@REF@("OUT","FILENUM")) "RTN","TMGRPCS0",136,0) NEW IEN SET IEN=0 "RTN","TMGRPCS0",137,0) NEW VALUE "RTN","TMGRPCS0",138,0) NEW TMGERR SET TMGERR=0 "RTN","TMGRPCS0",139,0) FOR SET IEN=$ORDER(@REF@("OUT",IEN)) QUIT:(+IEN'>0)!TMGERR DO "RTN","TMGRPCS0",140,0) . SET VALUE="" "RTN","TMGRPCS0",141,0) . NEW I FOR I=1:1:$LENGTH(TMGFLDS,";") DO "RTN","TMGRPCS0",142,0) . . NEW TMG1FLD SET TMG1FLD=+$PIECE(TMGFLDS,";",I) QUIT:TMG1FLD'>0 "RTN","TMGRPCS0",143,0) . . SET VALUE=VALUE_$$GET1^DIQ(TMGFNUM,IEN_",",TMG1FLD,,"TMGERR")_" " "RTN","TMGRPCS0",144,0) . . IF $DATA(TMGERR("DIERR")) DO "RTN","TMGRPCS0",145,0) . . . SET TMGERR=1 "RTN","TMGRPCS0",146,0) . . . SET TMGERR("MSG")=$$GetErrStr^TMGDEBUG(.TMGERR) "RTN","TMGRPCS0",147,0) . SET VALUE=$$TRIM^XLFSTR(VALUE) "RTN","TMGRPCS0",148,0) . QUIT:VALUE="" "RTN","TMGRPCS0",149,0) . SET @REF@("B",VALUE,IEN)="" "RTN","TMGRPCS0",150,0) ;"------------------------------------ "RTN","TMGRPCS0",151,0) IF TMGERR SET OUT(0)="-1^"_$GET(TMGERR("MSG")) "RTN","TMGRPCS0",152,0) IF $DATA(@REF@("B"))=0 SET OUT(0)="-1^NO RESULTS" "RTN","TMGRPCS0",153,0) ELSE SET OUT(0)="1^Success" "RTN","TMGRPCS0",154,0) PREPDN QUIT "RTN","TMGRPCS0",155,0) ; "RTN","TMGRPCS0",156,0) IENDETAL(OUT,TMGPARAMS) ; "RTN","TMGRPCS0",157,0) ;"Purpose: Return Detail of 1 IEN from from results from background search job. "RTN","TMGRPCS0",158,0) ;" NOTE: This should not be called until STATUS() returns #DONE# "RTN","TMGRPCS0",159,0) ;" Example: Imagine that a search has been made for a PATIENT with "RTN","TMGRPCS0",160,0) ;" an associated TIU DOCUMENT containing "HTN". The primary "RTN","TMGRPCS0",161,0) ;" goal of the search is to get the IEN of the found PATIENT(s) "RTN","TMGRPCS0",162,0) ;" However, after finding this patient, one might want to be "RTN","TMGRPCS0",163,0) ;" able to reference the particular TIU DOCUMENTS leading to "RTN","TMGRPCS0",164,0) ;" the match. That is the purpose of this function. So, in "RTN","TMGRPCS0",165,0) ;" the parameters below, the input IEN would be the IEN in "RTN","TMGRPCS0",166,0) ;" the PATIENT file, and the output would include the file "RTN","TMGRPCS0",167,0) ;" number for TIU DOCUMENT, and the IEN's of the entries in "RTN","TMGRPCS0",168,0) ;" this file that lead to the final results "RTN","TMGRPCS0",169,0) ;"Input: OUT -- Passed by REFERENCE. And out array "RTN","TMGRPCS0",170,0) ;" TMGPARAM -- JobNum^IEN "RTN","TMGRPCS0",171,0) ;" JOBNUM -- The job number of task to query "RTN","TMGRPCS0",172,0) ;" IEN -- The End Search IEN "RTN","TMGRPCS0",173,0) ;"Output: OUT(0)=status "RTN","TMGRPCS0",174,0) ;" OUT(index)=FileNum^IENInFile^.01Value "RTN","TMGRPCS0",175,0) ;" OUT(index)=FileNum^IENInFile^.01Value "RTN","TMGRPCS0",176,0) ;" OUT(index)=FileNum^IENInFile^.01Value "RTN","TMGRPCS0",177,0) ;"Results: None "RTN","TMGRPCS0",178,0) NEW JOBNUM SET JOBNUM=+$PIECE($GET(TMGPARAMS),"^",1) "RTN","TMGRPCS0",179,0) IF JOBNUM=0 DO GOTO IEDDN "RTN","TMGRPCS0",180,0) . SET OUT(0)="-1^Invalid Job Number." "RTN","TMGRPCS0",181,0) NEW SRCHIEN SET SRCHIEN=+$PIECE($GET(TMGPARAMS),"^",2) "RTN","TMGRPCS0",182,0) IF SRCHIEN=0 DO GOTO IEDDN "RTN","TMGRPCS0",183,0) . SET OUT(0)="-1^Invalid IEN Number." "RTN","TMGRPCS0",184,0) NEW REF SET REF=$NAME(^TMP("TMG","TMGSRCH",JOBNUM,"OUT","DETAILS",SRCHIEN)) "RTN","TMGRPCS0",185,0) NEW I SET I=1 "RTN","TMGRPCS0",186,0) NEW FNUM SET FNUM=0 "RTN","TMGRPCS0",187,0) FOR SET FNUM=$ORDER(@REF@(FNUM)) QUIT:(+FNUM'>0) DO "RTN","TMGRPCS0",188,0) . NEW SUPIEN SET SUPIEN=0 "RTN","TMGRPCS0",189,0) . FOR SET SUPIEN=$ORDER(@REF@(FNUM,SUPIEN)) QUIT:(+SUPIEN'>0) DO "RTN","TMGRPCS0",190,0) . . NEW VALUE SET VALUE=$GET(@REF@(FNUM,SUPIEN)) "RTN","TMGRPCS0",191,0) . . IF VALUE="" DO "RTN","TMGRPCS0",192,0) . . . SET VALUE=$$GET1^DIQ(FNUM,SUPIEN_",",.01) "RTN","TMGRPCS0",193,0) . . . SET @REF@(FNUM,SUPIEN)=VALUE "RTN","TMGRPCS0",194,0) . . SET OUT(I)=FNUM_"^"_SUPIEN_"^"_VALUE "RTN","TMGRPCS0",195,0) . . SET I=I+1 "RTN","TMGRPCS0",196,0) IF $DATA(OUT)=0 SET OUT(0)="-1^NO RESULTS" "RTN","TMGRPCS0",197,0) ELSE SET OUT(0)="1^Success" "RTN","TMGRPCS0",198,0) IEDDN QUIT "RTN","TMGRPCS0",199,0) ; "RTN","TMGRPCS0",200,0) GETRSLTSB(TMGOUT,TMGPARAMS) ; "RTN","TMGRPCS0",201,0) ;"Purpose: Get RESULTS list subset, for job number. NOTE: This should "RTN","TMGRPCS0",202,0) ;" only be called after a successful call to PREPSB^TMGRPCS0() "RTN","TMGRPCS0",203,0) ;" which will prepair the list. "RTN","TMGRPCS0",204,0) ;"Input: TMGPARAMS -- JobNum^ListStartValue^direction^MaxCount(optional, def=44) "RTN","TMGRPCS0",205,0) ;" JobNum -- this is job number of results to return. "RTN","TMGRPCS0",206,0) ;" ListStartValue -- OPTIONAL -- text to $ORDER() from "RTN","TMGRPCS0",207,0) ;" Direction -- $ORDER(xx,Direction) direction (should be 1 or -1) -- OPTIONAL "RTN","TMGRPCS0",208,0) ;" MaxCount -- OPTIONAL. Default is 44 values returned. "RTN","TMGRPCS0",209,0) ;"Output: TMGRESULTS is filled as follows. "RTN","TMGRPCS0",210,0) ;" TMGRESULT(0)="1^Success" or "-1^Message" "RTN","TMGRPCS0",211,0) ;" TMGRESULT(1)=IENNum^RequestedFieldNames "RTN","TMGRPCS0",212,0) ;" TMGRESULT(2)=IENNum^RequestedFieldNames "RTN","TMGRPCS0",213,0) ;"NOTE: Any files that don't have data are excluded. Subfiles also excluded "RTN","TMGRPCS0",214,0) ; "RTN","TMGRPCS0",215,0) NEW JOBNUM SET JOBNUM=+$PIECE(TMGPARAMS,"^",1) "RTN","TMGRPCS0",216,0) IF JOBNUM'>0 DO GOTO GAFSDN "RTN","TMGRPCS0",217,0) . SET TMGOUT(0)="-1^No Job Number Supplied" "RTN","TMGRPCS0",218,0) NEW TMGFROM SET TMGFROM=$PIECE(TMGPARAMS,"^",2) "RTN","TMGRPCS0",219,0) NEW TMGDIR SET TMGDIR=$PIECE(TMGPARAMS,"^",3) "RTN","TMGRPCS0",220,0) IF TMGDIR'=-1 SET TMGDIR=1 "RTN","TMGRPCS0",221,0) NEW TMGMAXCT SET TMGMAXCT=+$PIECE(TMGPARAMS,"^",4) "RTN","TMGRPCS0",222,0) IF TMGMAXCT=0 SET TMGMAXCT=44 "RTN","TMGRPCS0",223,0) ; "RTN","TMGRPCS0",224,0) NEW TMGREF SET TMGREF=$NAME(^TMP("TMG","TMGSRCH",JOBNUM)) "RTN","TMGRPCS0",225,0) NEW TMGI SET TMGI=0 "RTN","TMGRPCS0",226,0) FOR SET TMGFROM=$ORDER(@TMGREF@("B",TMGFROM),TMGDIR) QUIT:(TMGFROM="")!(TMGI'0)!(TMGI' "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 2 "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 2 "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 2 "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 2 "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**