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**