TMGDBAPI ;TMG/kst/Database API library ;03/25/06, 5/24,10 ;;1.0;TMG-LIB;**1**;07/12/05 ;"TMG DATABASE API FUNCTIONS ;"Kevin Toppenberg MD ;"GNU General Public License (GPL) applies ;"7-12-2005 ;"======================================================================= ;" API -- Public Functions. ;"======================================================================= ;"$$GetNumField^TMGDBAPI(FileNumber,FieldName) ;Convert Field Name to Field Number ;"$$GetFileNum^TMGDBAPI(FileName) ;Convert File Name to File Number ;"$$SetFileFldNums^TMGDBAPI(File,Field,FileNumber,FieldNumber) ;do both functions above at once. ;"$$GetFName^TMGDBAPI(FileNumber) ;Convert File Number to File Name ;"$$GetFldName^TMGDBAPI(File,FieldNumber) ;Convert Field Number to Field Name ;"$$GetFldList^TMGDBAPI(File,pArray) ;Get list of all fields for a file. ;"FieldExists^TMGDBAPI(FileNumber,Field) ;"SetFieldInfo^TMGDBAPI(File,Field,Array) ;"GetFieldInfo^TMGDBAPI(FileNumber,Field,VarOutP) ;"GetSubFileNumber^TMGDBAPI(FileNumber,Field) ;"$$IsSubFile^TMGDBAPI(File) ;"$$ISWPFLD(FILE,FLD) ;"GetSubFInfo^TMGDBAPI(SubFileNum,Array) ;"GetRecMatch^TMGDBAPI(Data,RecNumIEN) ;"CompRec^TMGDBAPI(FileNumber,dbRec,TestRec) ;"UploadData^TMGDBAPI(DaDIta,RecNumIEN) ;"ValueLookup^TMGDBAPI(Params) ;"FileUtility^TMGDBAPI(Params) ;"AddRec^TMGDBAPI(Data) ;"OverwriteRec^TMGDBAPI(RecNum,Data) ;"SetupFileNum^TMGDBAPI(Data) ;"RecFind^TMGDBAPI(Params) ;"FieldCompare^TMGDBAPI(TestField,dbField,Type) ;"$$dbWrite^TMGDBAPI(FDA,Overwrite,TMGIDE,Flags,ErrArray) ;"$$DelIEN^TMGDBAPI(File,RecNumIEN,ErrArray) ;"$$WriteWP^TMGDBAPI(File,RecNumIEN,Field,Array) ;"$$ReadWP^TMGDBAPI(File,IENS,Field,Array) ;"$$ShowIfError^TMGDBAPI(TMGMsg,PriorErrorFund) ;"$$GetValidInput^TMGDBAPI(File,Field) -- Get a valid input for field in file, asking user ;"$$AskFIENS^TMGDBAPI() -- pick a (sub)file number, then pick a record from that file. ;"$$AskIENS^TMGDBAPI(FileNum) -- return IENS for File (or subfile) number ;"GetRef^TMGDBAPI(file,IENS,field) -- to return the global reference for a given record ;"GetPtrsOUT^TMGDBAPI(FileNum,Info) -- get a list of pointers out from the file. ;"$$TrimFDA^TMGDBAPI(FDA,Quiet) -- Trim FDA of any data already present in the database ;"======================================================================= ;"PRIVATE API FUNCTIONS ;"======================================================================= ;"ConvertFDA(FDA,MarkerArray) ;"ConvertIENS(IENS,MarkerArray) ;"SetupFDA(Data,FDA,IENS,SrchType,MarkNum,MsgArray,Minimal,RecNum) ;"HackWrite(GlobalP,FileNumber,IENS,FieldNum,Data) ;"HandleHacksArray(MsgArray) ;"GetRefArray(FileNum,array) ;"======================================================================= ;"DEPENDENCIES ;"TMGDEBUG ;"TMGUSRIF ;"TMGSTUTL ;"======================================================================= ;"======================================================================= ;"FORMAT OF DATA ARRAY ;" cNull="(none)" ;" cRecNum="RECNUM" ;" cOutput="OUTVAR" ;" cGlobal="GLOBAL" ;" cEntries="Entries" ;" cFlags="FLAGS" ;" cParentIENS="ParentIENS" ;"The Data array will be filed with data. (An example) ;" Data(0,"FILE")="1234.1" <-- "NEW PERSON" Note conversion ;" Data(0,"FILE",cGlobal)="^DIC(200)" <-- note, NOT "^DIC(200," ;" Data(0,cRecNum)=2 <-- only if user-specified. ;" Data(0,cEntries)=1 ;" Data(1,".01")="MyData1" ;" Data(1,".01","MATCHVALUE")="MyData1" ;" Data(1,".01",cFlags)=any flags given (only present if user specified) ;" Data(1,".02")="Bill" ;" Data(1,".02","MATCHVALUE")="John" ;" Data(1,".03")="MyData3" ;" Data(1,".03",cFlags)=any flags given (only present if user specified) ;" Data(1,".04")="MyData4" ;" Data(1,".06")="MyData5" <-- note "NAME" was converted to ".06" ;" Data(1,".07",0,cEntries)=2 <-- "ITEM" converted to ".07" ;" Data(1,".07",0,cParentIENS)=",10033," ;" Data(1,".07",1,".01")="SubEntry1" ;" Data(1,".07",1,".02")="SE1" ;" Data(1,".07",1,".03")="'Some Info'" ;" Data(1,".07",2,".01")="SubEntry2" ;" Data(1,".07",2,".02")="SE2" ;" Data(1,".07",2,".04",0,cEntries)=1 ;"TEXT converted to .04 ;" Data(1,".07",2,".04",0,cParentIENS)=",3,10033," ;" Data(1,".07",2,".04",1,".01")="JD" ;" Data(1,".07",2,".04",1,".02")="DOE,JOHN" ;"======================================================================= ;"======================================================================= GetNumField(FileNumber,FieldName) ;"PUBLIC FUNCTION ;"Purpose: Given file and the name of a field, this will return the field NUMBER ;"Input: FileNumber. Number of file, i.e. "4.11" ;" FieldName: the name of a field, i.e. "NAME" spelling must exactly match ;"Output: Returns field number, i.e. ".01" or 0 if not found new cOKToCont set cOKToCont=1 new cAbort set cAbort=0 if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 new result if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetNumField^TMGDBAPI") set result=$$FLDNUM^DILFD(FileNumber,FieldName) if result'=0 goto GNMFDone ;"-------------------------- ;"The below is a manual method if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Having difficulty finding field name (? due to security ?). Doing Manual Check.") new FoundField new Index new result set result=cAbort set U=$get(U,"^") ;"Setup up U if doesn't yet exist if $$VFILE^DILFD(FileNumber)=0 do goto GNMFDone . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: Requested file, #"_FileNumber_", doesn't exist.") set Index="" GNmLoop set Index=$order(^DD(FileNumber,Index)) if Index="" goto GNMFDone if $data(^DD(FileNumber,Index,0))=0 goto GNMFDone set FoundField=$piece(^DD(FileNumber,Index,0),"^",1) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Comparing fields: '",FoundField,"' vs. '",FieldName,"'") if FieldName=FoundField do goto GNMFDone . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Match!") . set result=Index goto GNmLoop GNMFDone if result=cAbort do . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Unable to convert '",FieldName,"' in file '",FileNumber,"' to a field number. Check for Field name typo") if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetNumField^TMGDBAPI") quit result SetFileFldNums(File,Field,FileNumber,FieldNumber) ;"Purpose: To provide a generic shell to ensure that File and Field numbers are in place ;"Input: File -- File number or name ;" Field -- field number or name ;" FileNumber -- PASS BY REFERENCE -- an out parameter ;" FieldNum -- PASS BY REFERENCE -- an out parameter ;"Results: cOKToCont(1) if ok, otherwise cAbort(0) if error ;"Output -- FileNumber and FieldNumber are filled in. new cOKToCont set cOKToCont=1 new cAbort set cAbort=0 if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 new result set result=cOKToCont if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"SetFileFldNums^TMGDBAPI") set FileNumber=+$get(File) if FileNumber=0 set FileNumber=$$GetFileNum(.File) if FileNumber=0 do goto SFFNDone . set result=cAbort . do ShowError^TMGDEBUG(.PriorErrorFound,"Can't convert file '"_$get(File)_", to a number.") set FieldNumber=$get(Field) if FieldNumber=0 set FieldNumber=$$GetNumField(FileNumber,.Field) if FieldNumber=0 do goto SFFNDone . set result=cAbort . do ShowError^TMGDEBUG(.PriorErrorFound,"Can't convert field '"_$get(Field)_", to a number.") SFFNDone if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"SetFileFldNums^TMGDBAPI") quit result FieldExists(FileNumber,Field) ;"PUBLIC FUNCTION ;"Purpose: To ensure that a field exists -- even if hidden by security measures ;"Input: FileNumber: File to check ;" Field: the field number (or name) to check ;"Result: 1 if field exists, 0 if doesn't, 2 if exists but is hidden to user new result,FieldNumber if +Field=0 set FieldNumber=$$GetNumField(FileNumber,Field) else set FieldNumber=Field set result=$$VFIELD^DILFD(FileNumber,FieldNumber) if result=1 goto FExsDone ;"Try a low-level data dictionary eval to see if really does exist, but is hidden if $data(^DD(FileNumber,FieldNumber,0))'=0 set result=2 FExsDone quit result GetSubFileNumber(FileNumber,Field) ;"PUBLIC FUNCTION ;"Purpose: If FieldNumber is a 'multiple' field, then this function should return 'subfile' ;" number of the sub file. ;"Input:FileNumber-- the file number (or sub file number) that field exists in ;" Field-- the field number (or name) in file to lookup ;"Result: Returns sub file number, or 0 if not found or invalid new cOKToCont set cOKToCont=1 new cAbort set cAbort=0 if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 new Info new result set result=cAbort new Output if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetSubFileNumber^TMGDBAPI") if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FileNumber=",FileNumber) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Field=",Field) ;"First, verify file (or subfile) exists if $$VFILE^DILFD(FileNumber)=0 do goto GSFDone ;"abort . do ShowError^TMGDEBUG(.PriorErrorFound,"File number '"_FileNumber_"' is not valid.") ;"Next, ensure Field exists in file if $$FieldExists(FileNumber,Field)=0 do goto GSFDone ;"abort . do ShowError^TMGDEBUG(.PriorErrorFound,"Field number '"_Field_"' is not valid.") ;"Next, ensure field is a multiple and get field info. do GetFieldInfo(FileNumber,Field,"Output") if $data(Output("MULTIPLE-VALUED"))=0 do goto GSFDone ;"abort . do ShowError^TMGDEBUG(.PriorErrorFound,"Field '"_Field_"' in File '"_FileNumber_"' is not a subfile.") ;"Now actually get subfile number if $data(Output("SPECIFIER"))=0 do goto GSFDone ;"abort . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to find 'Specifier' (subfile number)") set result=+Output("SPECIFIER") ;"Now actually get subfile number ;"set Info=$get(^DD(FileNumber,Field,0),0) ;"if Info=0 do goto GSFDone ;". do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to get information from data dictionary.") ;"set result=+$piece(Info,"^",2) GSFDone if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"SubFile number is: ",result) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetSubFileNumber^TMGDBAPI") quit result ISWPFLD(FILE,FLD) ; ;"Purpose: return if field FLD is a WP field ;"Input: FILE -- file NUMBER ;" FLD -- field NUMBER ;"Result: 1 if WP field, 0 if not new result set result=0 new info set info=$piece($get(^DD(FILE,FLD,0)),"^",2) if +info'=info goto IWPDN new subFile set subFile=+info set info=$piece($get(^DD(subFile,.01,0)),"^",2) set result=(info["W") IWPDN quit result IsSubFile(File) ;"Purpose: to return if file is actually a subfile ;"Input: File -- File name or number ;"Results: Parent file number^Field in Parent File ;" or 0 if not a subfile. new result if +File'=File set File=$$GetFileNum(File) set result=+$get(^DD(File,0,"UP")) if result'>0 goto ISFDone ;"Now find which field this sub file is in its parent new fldInParent set fldInParent=0 new field set field=0 new done set done=0 for set field=$order(^DD(result,field)) quit:(+field'>0)!(done=1) do . new fldInfo set fldInfo=$piece($get(^DD(result,field,0)),"^",2) . if +fldInfo=File set fldInParent=field set done=1 if fldInParent>0 set result=result_"^"_fldInParent ISFDone quit result GetSubFInfo(SubFileNum,Array) ;"PUBLIC FUNCTION ;"Purpose: To take a subfile NUMBER, and return information about it. ;"Input: SubFileNum-- the sub file number ;" Array -- PASS BY REFERENCE. An array to receive results. ;" any preexisting data is deleted. ;"Output Array is formated as follows: ;" Array("SUBFILE","NUMBER")=file number of this sub file. ;" Array("SUBFILE","NAME")=file name of this sub file. ;" Array("PARENT","NUMBER")=parent file number ;" Array("PARENT","NAME")=parent file name ;" Array("PARENT","GL")=global reference of parent, in open format<-- only valid if parent isn't also a subfile ;" Array("FIELD IN PARENT","NUMBER")=field number of subfile in parent ;" Array("FIELD IN PARENT","NAME")=filed name of subfile in parent ;" Array("FIELD IN PARENT","LOC")=node and piece where subfile is stored ;" Array("FIELD IN PARENT","CODE")=code giving subfile's attributes. ;"Result: 1 if found info, or 0 if not found or invalid new result set result=0 if '$get(SubFileNum) goto GSPDone kill Array set Array("SUBFILE","NUMBER")=SubFileNum set Array("SUBFILE","NAME")=$piece($get(^DD(SubFileNum,0)),"^",1) new parent set parent=+$get(^DD(SubFileNum,0,"UP")) if parent=0 goto GSPDone set Array("PARENT","NUMBER")=parent set Array("PARENT","NAME")=$order(^DD(parent,0,"NM","")) set Array("PARENT","GL")=$get(^DIC(parent,0,"GL")) new i set i=$order(^DD(parent,"")) for do quit:(i="")!(result=1) ;"scan all fields for a match . quit:(i="") . new node,num . set node=$get(^DD(parent,i,0)) . if +$piece(node,"^",2)=SubFileNum do quit . . set Array("FIELD IN PARENT","NUMBER")=i . . set Array("FIELD IN PARENT","NAME")=$piece(node,"^",1) . . set Array("FIELD IN PARENT","LOC")=$piece(node,"^",4) . . set Array("FIELD IN PARENT","CODE")=$piece(node,"^",2) . . set result=1 . set i=$order(^DD(parent,i)) GSPDone quit result GetFieldInfo(FileNumber,Field,VarOutP,InfoS) ;"PUBLIC FUNCTION ;"Purpose: To get Field info, ;"Input: FileNumber: File or subfile number ;" Field: Field name or number ;" VarOutP -- the NAME of the variable to put result into. ;" InfoS -- [OPTIONAL] -- additional attributes of field info to be looked up ;" (as allowed by FIELD^DID). Multiple items should be ;" separated by a semicolon (';') ;" e.g. "TITLE;LABEL;POINTER" ;"Output: Data is put into VarOutP (any thing in VarOutP is erased first ;" i.e. @VarOutP@("MULTIPLE-VALUED")=X ;" i.e. @VarOutP@("SPECIFIER")=Y ;" i.e. @VarOutP@("TYPE")=Z ;" i.e. @VarOutP@("StoreLoc")="0;1" <-- not from fileman output (i.e. extra info) ;" (if additional attributes were specified, they will also be in array) ;"Result: none kill @VarOutP ;"erase any old information if +Field=0 set Field=$$GetNumField(FileNumber,Field) set @VarOutP@("StoreLoc")=$piece($get(^DD(FileNumber,Field,0)),"^",4) new Attribs set Attribs="MULTIPLE-VALUED;SPECIFIER;TYPE" if $data(InfoS) set Attribs=Attribs_";"_InfoS ;"Next, check if field is a multiple and get field info. do FIELD^DID(FileNumber,Field,,Attribs,VarOutP,"TMGMsg") if $data(TMGMsg) do . if $data(TMGMsg("DIERR"))'=0 do quit . . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) GFIDone quit HackWrite(GlobalP,FileNumber,IENS,FieldNum,Data) ;"PUBLIC FUNCTION ;"Purpse: To force data into a field -- using low level 'hack' method ;"Input: GlobalP -- the NAME of the global to put this into, i.e. "^VA(200," ;" FileNumber- the file number ;" IENS -- the standard API IENS ;" FieldNum the field to put this into ;" Data -- the value to put in ;"Note: This can be used to put a value of "@" into a field ;"Result: 1 if ok to continue, 0=abort ;"!!!NOTICE: This is a very low level means of accessing the database. ;" The built in data verifiers, indexers etc etc will not be made aware of ;" changes made to the database through this method. USE ONLY WITH CAUTION. new cOKToCont set cOKToCont=1 new cAbort set cAbort=0 if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 new result set result=cAbort if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"HackWrite^TMGDBAPI") if '$data(GlobalP) goto HWDone if '$data(FileNumber) goto HWDone if '$data(IENS) goto HWDone if '$data(FieldNum) goto HWDone if '$data(Data) goto HWDone if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"GlobalP: ",GlobalP) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"File:",FileNumber) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"IENS:",IENS) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldNum:",FieldNum) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Data:",Data) new DDInfo new FieldInfo new Index,Part new OldData new RecNum ;"Get info from data dictionary r.e. where actual fields are stored in files. set DDInfo=$get(^DD(FileNumber,FieldNum,0)) if '$data(DDInfo) goto HWDone set FieldInfo=$piece(DDInfo,"^",4) if '$data(FieldInfo),(FieldInfo="") goto HWDone set Index=$piece(FieldInfo,";",1) set Part=$piece(FieldInfo,";",2) ;"Convert global form of ^VA(200, into ^VA(200) new Len set Len=$length(GlobalP) if $extract(GlobalP,Len)="," do . set $extract(GlobalP,Len)=")" set RecNum=$piece(IENS,",",1) if $piece(IENS,",",2)'="" do goto HWDone . do ShowError^TMGDEBUG(.PriorErrorFound,"Hack writing to subfiles not supported") if $data(@GlobalP@(RecNum,Index))=0 goto HWDone if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"I think the correct data place is: ",GlobalP,"(",RecNum,",",Index,") at piece: ",Part) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"That line is now: ",@GlobalP@(RecNum,Index)) set OldData=$piece(@GlobalP@(RecNum,Index),"^",Part) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"And that data item is now: '",OldData,"'") if Data'=OldData do . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Performing hack write") . set $piece(@GlobalP@(RecNum,Index),"^",Part)=Data . ;"Give Message . new Text . set Text(0)=" Caution" . set Text(1)="Yikes!" . set Text(2)=" " . set Text(3)="We just bypassed all safety measures, " . set Text(4)="and wrote directly to the database." . set Text(5)="Make sure you know what you are doing!!" . set Text(6)=" " . set Text(7)="File: "_FileNumber . set Text(8)="Field: "_FieldNum . set Text(9)="Prior value: '"_OldData_"'" . set Text(10)="New value: '"_Data_"'" . set Text(11)=" " . set Text(12)="(This was caused by using Flags='H' in" . set Text(13)="the XML script.)" . do PopupArray^TMGUSRIF(5,45,.Text) else do . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"No need for hackwrite... the data is already what we want.") HWDone if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"HackWrite^TMGDBAPI") quit HandleHacksArray(MsgArray) ;"PUBLIC FUNCTION ;"Purpose: To cycle through an array of hackwrites and process each one. ;"Input: HacksArray. Best if passed by reference ;" Expected format of array: ;" MsgArray(cHack,0,cEntries)=Number of Entries ;" MsgArray(cHack,n) = Global;FileNumber;IENS;FieldNum;Data ;" MsgArray(cHack,n,cFlags)=User specified Flags for field. ;"Output: database is changed ;"Result: 1 if ok to continue, 0=abort ;"!!!NOTICE: This is a very low level means of accessing the database. ;" The built in data verifiers, indexers etc etc will not be made aware of ;" changes made to the database through this method. USE ONLY WITH CAUTION. new cOKToCont set cOKToCont=1 new cAbort set cAbort=0 if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 new cHack set cHack="H" new cEntries set cEntries="Entries" if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"HandleHacksArray^TMGDBAPI") new result set result=cOKToCont new index set index=1 new GlobalP,FileNum,IENS,FieldNum,Data new s for index=1:1:$get(MsgArray(cHack,0,cEntries)) do quit:(s="")!(result=cAbort) . set s=$get(MsgArray(cHack,index)) if s="" quit . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Processing: ",s) . set GlobalP=$piece(s,";",1) . set FileNum=$piece(s,";",2) . set IENS=$piece(s,";",3) . set FieldNum=$piece(s,";",4) . set Data=$piece(s,";",5) . set result=$$HackWrite(GlobalP,FileNum,IENS,FieldNum,Data) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"HandleHacksArray^TMGDBAPI") quit result GetRecMatch(Data,RecNumIEN) ;"PUBLIC FUNCTION ;"Purpose: Take Data array from DoUpload, and search in database ;" for a prior matching record ;"Input: Data - Data array will contain all the information that is to be uploaded ;" Fields that should be specifically matched will have "MATCHTHIS" fields. ;" A field may have a "MATCHTHIS" node meaning that the value ;" specified should be searched for. ;" Or, rarely, one may want to specifically search for a different ;" search value. This is stored in a "MATCHVALUE" node. This ;" node is ignored if "MATCHTHIS" node is present. ;" The .01 field always is used for searching. If not present, then ;" a "MATCHTHIS" node is assumed. ;" Example array: ;" Data(0,"FILE")="1234.1" <-- "NEW PERSON" Note conversion ;" Data(1,".01")="BILL" ;" Data(1,".01","MATCHVALUE")="JOHN" <-- optional search value ;" Data(1,".01","MATCHTHIS")=1 ;" Data(1,".02")="Sue" ;" Data(1,".03")="MyData3" ;" Data(1,".03",cFlags)=any flags given (only present if user specified) ;" RecNumIEN -- MUST PASS BY REFERENCE. An OUT parameter to receive results ;"Output: Returns answer in RecNumIEN (record number in file) if found, or 0 otherwise ;"Result: 1=OKToContinue, 0=Abort ;"Note: ;" * Data in Multiple fields are NOT used for matching. ;" * I am not going to support matching for subrecords (i.e. SubEntry stuff above) ;" * If data passed is a subset of a larger data group (i.e. when this function ;" is called recursively to handle a subfile), then an entry will be placed ;" in the Data(0,cParentIENS) that will specify the RecNumIEN of the parent record ;" holding this subfile. new cOKToCont set cOKToCont=1 new cAbort set cAbort=0 if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 new cParentIENS set cParentIENS="ParentIENS" new FileNumber,FieldNum set RecNumIEN=0 new IENS,Fields,Flags new MatchValue set MatchValue="" new FieldMatch set FieldMatch="" new ScreenCode new Matches,NumMatches new TMGMsg new result set result=cOKToCont new index new SlimData ;"Will hold just those fields that should be matched against new OneMatch set IENS=$get(Data(0,cParentIENS)) if IENS'="" if $extract(IENS,1)'="," do . set IENS=","_IENS set Fields="@" ;"Setup specifier to tell which fields to return info on new done set done=0 set index=0 for set index=$order(Data(index)) quit:(index="")!done do . set FieldNum="" . for set FieldNum=$order(Data(index,FieldNum)) quit:(+FieldNum=0) do . . if $get(Data(index,FieldNum,"MATCHTHIS"))=1 do . . . set FieldMatch=$get(Data(index,FieldNum)) . . else set FieldMatch=$get(Data(index,FieldNum,"MATCHVALUE")) . . if FieldNum=".01" do . . . if FieldMatch="" set FieldMatch=$get(Data(index,.01)) . . . set MatchValue=FieldMatch . . if FieldMatch'="" do . . . set Fields=Fields_";"_FieldNum . . . set SlimData(FieldNum)=FieldMatch . . . set FieldMatch="" . set done=1 ;"Force handling only 1 entry (i.e. #1), then quit after first cycle. set FileNumber=$get(Data(0,"FILE")) set ScreenCode="" set Flags="" ;"====================================================== ;"Call FIND^DIC ;"====================================================== ;"Params: ;"FILE,IENS,FIELDS,FLAGS,VALUE,NUMBER,INDEXES,SCREEN,IDENTIFIER,TARGET_ROOT,MSG_ROOTS do FIND^DIC(FileNumber,$get(IENS),Fields,Flags,MatchValue,"*",,ScreenCode,,"Matches","TMGMsg") if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"TMGDBAPI::FIND^DIC") ;"====================================================== ;"====================================================== if $data(TMGMsg) do . if $data(TMGMsg("DIERR"))'=0 do quit . . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) . . set result=cAbort if result=cAbort goto GRMQuit if $data(Matches("DILIST"))=0 goto GRMQuit ;"keep RecNumIEN default of 0 set NumMatches=$piece(Matches("DILIST",0),"^",1) if NumMatches=0 goto GRMQuit ;"keep RecNumIEN default of 0 for index=1:1:NumMatches do quit:RecNumIEN'=0 ;"Note: FIRST match returned. . kill OneMatch . merge OneMatch=Matches("DILIST","ID",index) . if $$CompRec(FileNumber,.OneMatch,.SlimData) set RecNumIEN=Matches("DILIST",2,index) GRMQuit quit result CompRec(FileNumber,dbRec,TestRec) ;"PUBLIC FUNCTION ;"Purpose: To compare data from the database against a test match ;"Input: FileNumber: the file data is from ;" dbRec, an array of data from the database in the following format ;" dbRec(.01)="JOHNS,BILL" ;" dbRec(.02)="MALE" ;" dbRec(.03)="01/20/1957" ;" dbRec(.07)="(123) 555-1212" ;" TestRec, an array of data to test for match with, in same format ;" as above. Note: there may well be less entries in this array ;" than in the dbRec ;" TestRec(.01)="JOHNS,BILL" ;" TestRec(.03)="01/20/1957" ;"Output: 1 if all values in TestRec=dbRec. 0=conflict ;" Note: values in dbRec that don't have a corresponding entry in TestRec ;" are ignored. new cOKToCont set cOKToCont=1 new cAbort set cAbort=0 if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 new result set result=cOKToCont new index set index="" new FieldType,TMGFDA,TMGMsg new dbIDT,testIDT ;" IDT = internal form of date/time if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"CompRec^TMGDBAPI") if TMGDEBUG do . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is records to be compared") . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"dbRec:") . do ArrayDump^TMGDEBUG("dbRec") ;"zwr dbRec(*) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"TestRec:") . do ArrayDump^TMGDEBUG("TestRec") ;"zwr TestRec(*) CRLoop set index=$order(TestRec(index)) if index="" goto CRDone if $data(dbRec(index))=0 goto CRLoop if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Comparing field ",index) kill TMGFDA,TMGMsg do FIELD^DID(FileNumber,index,,"TYPE","TMGFDA","TMGMsg") if $get(TMGFDA("TYPE"))="DATE/TIME" do goto CRDone:'result . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Doing special date comparison") . set X=TestRec(index) . do ^%DT ;"convert date/time into internal format . set testIDT=Y . set X=dbRec(index) . do ^%DT ;"convert date/time into internal format . set dbIDT=Y . if testIDT'=dbIDT do . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Dates not equal: ",TestRec(index)," vs, ",dbRec(index)) . . set result=cAbort else if TestRec(index)'=dbRec(index) do goto CRDone ;"Note: simple '=' compare . set result=cAbort if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Fields are equal") goto CRLoop CRDone if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Leaving CompRec. Result=",result," (0 if conflict)") if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"CompRec^TMGDBAPI") quit result UploadData(Data,RecNumIEN) ;"PUBLIC FUNCTION ;"Purpose: Do actual upload of Data, given in specific format ;"Note: This function may be called recursively by subfiles ;"Input: Data -- data in format show at TOP OF THIS FILE ;" Note: If this function is being passed recursively, then the data ;" passed is probably just a subpart that corresponds to the subfile ;" RecNumIEN -- OPTIONAL pameter. May be used to specify the ;" record to force data into. If passed by reference, then ;" record number (IEN) where data was placed is passed back. ;" Use of this parameter only makes sense when filing the highest ;" level file. (When filing subfiles recursively, then the parent ;" record number is stored in (0,cParentIENS)=",10033," e.g.) ;"Output: Information will be put into global database, based on ;" entries in Data. ;" Record number (IEN) of record will be put into RecNumIEN (or 0 if error) ;"Result: Returns success 1=OK to continue. 0=Abort new cOKToCont set cOKToCont=1 new cAbort set cAbort=0 if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 new cEntries set cEntries="Entries" if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"UploadData^TMGDBAPI") new result set result=cOKToCont new NumEntries new index set RecNumIEN=$get(RecNumIEN,0) ;"See if user-specified IEN was given. if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"RecNumIEN=",RecNumIEN) if RecNumIEN'=0 do goto UDDone:(result=cAbort) . new Params,MyOutVar . set Params("FILE")=$get(Data(0,"FILE")) . set Params(cRecNum)=RecNumIEN . set Params(cField)=".01" . set Params(cOutput)="MyOutVar" . set result=$$ValueLookup(.Params) ;"result=0 (cAbort) if unsuccessful lookup . if result=cAbort do . . if $data(PriorErrorFound)=0 new PriorErrorFound . . new s set s="Unable to overwrite data into record#"_RecNumIEN_" because that record does not already exist.\n" . . set s=s_"Will try to put data into a new record, which may not be record#"_RecNumIEN . . do ShowError^TMGDEBUG(.PriorErrorFound,s) . . set result=cOKToCont . . set PriorErrorFound=0 ;"clear errors and continue program. . . set RecNumIEN=0 set NumEntries=$get(Data(0,cEntries)) for index=1:1:NumEntries do quit:(result=cAbort) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Starting loop to process all uploadData entries. Entry=",index) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"RecNumIEN=",RecNumIEN) . new tData ;"Create a tData array that has only 1 entry in it. . merge tData(0)=Data(0) . set tData(0,cEntries)=1 . merge tData(1)=Data(index) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"This is entry to process") . if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("tData") . if RecNumIEN=0 set result=$$GetRecMatch(.tData,.RecNumIEN) ;"if no prior record, returns 0 . if result=cAbort quit ;//kt added 1/6/05 . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Using RecNumIEN=",RecNumIEN) . ; . if RecNumIEN=0 do quit:(result=cAbort) . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"calling AddRec") . . new AddRecNum . . set AddRecNum=$$AddRec(.tData) . . if AddRecNum=0 do quit . . . do ShowError^TMGDEBUG(.PriorErrorFound,"Error adding a record.") . . . set result=cAbort . else do quit:(result=cAbort) . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"calling Overwriterec") . . set result=$$OverwriteRec(RecNumIEN,.tData) . . set RecNumIEN=0 ;"We won't to file any more into that record num, force search next cycle. . . if result=cAbort do quit . . . do ShowError^TMGDEBUG(.PriorErrorFound,"Error modifying an existing record.") UDDone ;"if (result'=cAbort) set result=(RecNumIEN>0) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Result = ",result) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"UploadData^TMGDBAPI") quit result ValueLookup(Params) ;"PUBLIC FUNCTION ;"Purpose: To look for a value of a given value in a given record in given file. ;"Input: Params -- an array loaded with expected parameters. I.e.: ;" Params("FILE")="NEW PERSON" in our example ;" Params(cRecNum)="1" in example ;" Params(cField)=".01" in our example (could be Name of field) ;" Params(cOutput)="MyVar" ;"Output: MyVar is loaded with data, i.e.: ;" MyVar("FILE")=200 ;" MyVar(cGlobal)="^VA(200)" ;" MyVar(cGlobal,cOpen)="^VA(200," ;" MyVar(cRecNum)=1 ;" MyVar(cField)=.01 ;" MyVar(cValue)=xxx <-- the looked-up value ;"Returns: If should continue execution: 1=OK to continue. 0=unsuccessful lookup ;"Note: I am getting values by directly looking into database, rather than use ;" the usual lookup commands. I am doing this so that there will be no ;" 'hidden' data, based on security etc. ;" **I need to check, but this probably means that the data returned will be ;" in INTERNAL FILEMAN FORMAT (i.e. time values are encoded etc.) new cOKToCont set cOKToCont=1 new cAbort set cAbort=0 if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 new cField set cField="FIELD" ;"Field" new cNull set cNull="(none)" new cRecNum set cRecNum="RECNUM" ;"RecNum new cOutput set cOutput="OUTVAR" ;"OutVar" new cGlobal set cGlobal="GLOBAL" new cValueLookup set cValueLookup="LOOKUPFIELDVALUE" ;"LookupFieldValue" new cOpen set cOpen="OPEN" if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ValueLookup^TMGDBAPI") new result set result=cAbort new Data new DDInfo new FieldInfo new Index,Part new Field set Field=$get(Params(cField),cNull) new RecNum set RecNum=$get(Params(cRecNum),cNull) new OutVarP set OutVarP=$get(Params(cOutput),cNull) if (RecNum=cNull),(OutVarP=cNull) goto DVLUDone kill @OutVarP ;"--ensure old variables in output variable are removed. set Data(0,"FILE")=$get(Params("FILE")) set result=$$SetupFileNum(.Data) if result=cAbort goto DVLUDone new FileNum set FileNum=$get(Data(0,"FILE"),cNull) new GlobalP set GlobalP=$get(Data(0,"FILE",cGlobal),cNull) if (FileNum=cNull),(GlobalP=cNull) goto DVLUDone new FieldNum set FieldNum=$$GetNumField(FileNum,Field) if FieldNum=0 goto DVLUDone if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"GlobalP: ",GlobalP) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"File: ",FileNum) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Rec#: ",RecNum) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldNum: ",FieldNum) ;"Get info from data dictionary r.e. where actual fields are stored in files. set DDInfo=$get(^DD(FileNum,FieldNum,0)) if $data(DDInfo)=0 goto HWDone if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"DDInfo='",DDInfo,"', $data(DDInfo)=",$data(DDinfo)) set FieldInfo=$piece(DDInfo,"^",4) if '$data(FieldInfo),(FieldInfo="") goto DVLUDone set Index=$piece(FieldInfo,";",1) set Part=$piece(FieldInfo,";",2) if $data(@GlobalP@(RecNum,Index))=0 goto DVLUDone if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"I think the correct data place is: ",GlobalP,"(",RecNum,",",Index,") at piece: ",Part) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"That line is now: ",@GlobalP@(RecNum,Index)) set Data=$piece(@GlobalP@(RecNum,Index),"^",Part) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"And our value is: ",Data) kill @OutVarP set @OutVarP@("FILE")=FileNum set @OutVarP@(cRecNum)=RecNum set @OutVarP@(cField)=FieldNum set @OutVarP@(cValue)=Data set @OutVarP@(cGlobal)=GlobalP set @OutVarP@(cGlobal,cOpen)=$get(Data(0,"FILE",cGlobal,cOpen)) set result=cOKToCont DVLUDone if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ValueLookup^TMGDBAPI") quit result FileUtility(Params) ;"PUBLIC FUNCTION ;"Purpose: To provide file access/manipulation utilities to script user ;"syntax: ;" ;"Input: Params -- an array loaded with expected parameters. I.e.: ;" Params("FILE")="NEW PERSON" for example ;" File: The name of the file to act upon. ;" File may have subnodes (i.e. "NEW PERSON|ALIAS|TITLE") ;" **BUT**, any deletion or set values will only work on top level (i.e. "NEW PERSON") ;" Params(cFn)="info" or "delete", or "set" [OPTIONAL] ;" Fn="delete" If Field is not specified: ;" Will cause record RecNum to be deleted. ;" MyOutVar("DELETED")=RecNum of deleted record, or ;" 0 if not found. ;" If Field IS specified: ;" Will delete the value in field, in record RecNum ;" Note: delete is intended only for the highest-level records ;" (i.e. not subfiels, or multiple fields) ;" Note: delete method uses ^DIK to delete the record ;" Fn="info" Will just fill in info below. ;" If Fn not specified, this is default ;" Fn="set" Will put Value into Field, in RecNum, in File (all required) ;" Params(cRecNum)="1" for example ;" RecNum: [OPTIONAL] Specifies which record to act on. If not ;" specified, then just file info is returned. ;" Params(cField)=".01" for example (could be Name of field) ;" Field: [OPTIONAL] Specifies which field to act on. ;" Params(cOutput)="MyVar" ;" OutVar: Needed to get information back from function (but still Optional) ;" Gives name of variable to put info into. ;"Output: MyVar is loaded with data, i.e. ;" i.e. MyOutVar("FILE")=Filenumber ;" MyOutVar("FILE","FILE")=SubFilenumber <-- only if subnodes input in File name (e.g."ALIAS") ;" MyOutVar("FILE","FILE","FILE")=SubSubFilenumber <-- only if subnodes input in File name (e.g."TITLE") ;" MyOutVar("GLOBAL")="^VA(200)" ;" MyOutVar("GLOBAL, OPEN")="^VA(200," ;" MyOutVar("RECNUM")=record number ;" MyOutVar("FIELD")=Filenumber ;" MyOutVar("VALUE")=xxxx <=== value of field (PRIOR TO deletion, if deleted) ;" MyOutVar("NEXTREC")=record number after RecNum, or "" if none ;" MyOutVar("PREVREC")=record number before RecNum, or "" if none ;" MyOutVar("FN")=the function executed ;" MyOutVar("NUMRECS")=Number of records in file PRIOR to any deletions ;" MyOutVar("FIRSTREC")=Rec number of first record in file ;" MyOutVar("LASTREC")=Rec number of last record in file ;"Returns: If should continue execution: 1=OK to continue. 0=abort ;"Note: I am getting values by directly looking into database, rather than use ;" the usual lookup commands. I am doing this so that there will be no ;" 'hidden' data, based on security etc. if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 new cOKToCont set cOKToCont=1 new cAbort set cAbort=0 new cField set cField="FIELD" ;"Field" new cNull set cNull="(none)" new cRecNum set cRecNum="RECNUM" ;"RecNum new cRecord set cRecord="RECORD" ;"Record" new cOutput set cOutput="OUTVAR" ;"OutVar" new cGlobal set cGlobal="GLOBAL" new cValueLookup set cValueLookup="LOOKUPFIELDVALUE" ;"LookupFieldValue" new cOpen set cOpen="OPEN" new cInfo set cInfo="INFO" ;"Info if $data(cNodeDiv)#10=0 new cNodeDiv set cNodeDiv="|" new cDelete set cDelete="DELETE" ;"Delete new cNextRec set cNextRec="NEXTREC" new cPrev set cPrev="PREV" new cNumRecs set cNumRecs="NUMRECS" new cFirstRec set cFirstRec="FIRSTREC" new cLastRec set cLastRec="LASTREC" if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"DoFileUtility^TMGDBAPI") new result set result=cAbort new Data new DDInfo new FieldInfo new Index,Part new DummyOut new OutVarP set OutVarP=$get(Params(cOutput),cNull) ;"if (OutVarP=cNull) goto DFUTDone if (OutVarP=cNull) do . set OutVarP="DummyOut" kill @OutVarP ;"--ensure old variables in output variable are removed. if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Output variable=",OutVarP) new RecNum set RecNum=$get(Params(cRecNum)) set @OutVarP@(cRecNum)=RecNum if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"RecNum=",RecNum) new Fn set Fn=$get(Params(cFn),cInfo) set Fn=$$UP^XLFSTR(Fn) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Action Fn=",Fn) new Value set Value=$get(Params(cValue)) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Value=",Value) new FileN set FileN=$get(Params("FILE")) new SpliceArray if FileN[cNodeDiv do ;"Parse 'NEW PERSON|ALIAS|TITLE' into 'NEW PERSON', 'ALIAS', 'TITLE' . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Multiple nodes found for file name. Processing...") . do CleaveToArray^TMGSTUTL(FileN,cNodeDiv,.SpliceArray) . set FileN=$get(SpliceArray(1)) set Data(0,"FILE")=FileN set result=$$SetupFileNum(.Data) if result=cAbort goto DFUTDone new FileNum set FileNum=$get(Data(0,"FILE"),cNull) set @OutVarP@("FILE")=FileNum if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FileNum=",FileNum) new index set index=2 new GlobalP set GlobalP=$name(@OutVarP@("FILE")) if $data(SpliceArray(index)) do . for index=index:1 do quit:index="" . . set FileN=SpliceArray(index) . . set FileNum=$$GetSubFileNumber(FileNum,FileN) . . if +FileNum'=0 set @GlobalP@("FILE")=FileNum . . set GlobalP=$name(@GlobalP@("FILE")) . . set index=$order(SpliceArray(index)) new GlobalP set GlobalP=$get(Data(0,"FILE",cGlobal),cNull) if (FileNum=cNull),(GlobalP=cNull) goto DFUTDone set @OutVarP@(cGlobal)=GlobalP set @OutVarP@(cGlobal,cOpen)=$get(Data(0,"FILE",cGlobal,cOpen)) ;"If we've gotten this far, will consider the function a success set result=cOKToCont if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Setting fn result to success") new FieldN set FieldN=$get(Params(cField)) new FieldNum if (+FieldN=0)&(FieldN'="") do . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldN=",FieldN) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FileNum=",FileNum) . set FieldNum=$$GetNumField(FileNum,FieldN) else do . if FieldN . set FieldNum=FieldN set @OutVarP@(cField)=FieldNum if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldNum=",FieldNum) if $data(@GlobalP@(0))=0 goto DFUTDone new NumRecs set NumRecs=$piece(@GlobalP@(0),"^",4) new LastRec set LastRec=$piece(@GlobalP@(0),"^",3) set @OutVarP@(cNumRecs)=NumRecs set @OutVarP@(cLastRec)=LastRec new RecI set RecI=LastRec new PrevRec for do quit:(RecI="")!(RecI=0) ;"Scan backwards to find first record . set PrevRec=$order(@GlobalP@(RecI),-1) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"PrevRec=",PrevRec," RecI=",RecI) . if (PrevRec="")!(PrevRec=0) do . . set @OutVarP@(cFirstRec)=RecI . set RecI=PrevRec if FieldNum="" do goto DFUTDone . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"No field name specified") . if (Fn=cDelete)&(RecNum'="") do . . set DIK=$get(Data(0,"FILE",cGlobal,cOpen)) . . set DA=RecNum . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Deleting one record (number: ",RecNum,") from File number",FileNum) . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Notice: deleting record does not clear any pointers to deleted records") . . do ^DIK ;"Get info from data dictionary r.e. where actual fields are stored in files. set DDInfo=$get(^DD(FileNum,FieldNum,0)) if '$data(DDInfo) goto HWDone if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"DDInfo=",DDInfo) set FieldInfo=$piece(DDInfo,"^",4) if '$data(FieldInfo),(FieldInfo="") goto DFUTDone if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldInfo=",FieldInfo) set Index=$piece(FieldInfo,";",1) set Part=$piece(FieldInfo,";",2) if RecNum="" goto DFUTDone if $data(@GlobalP@(RecNum,Index))=0 goto DFUTDone if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"I think the correct data place is: ",GlobalP,"(",RecNum,",",Index,") at piece: ",Part) new Temp set Temp=@GlobalP@(RecNum,Index) set @OutVarP@(cValue)=$piece(Temp,"^",Part) kill Temp set @OutVarP@(cNextRec)=$order(@GlobalP@(RecNum)) set @OutVarP@(cPrev)=$order(@GlobalP@(RecNum),-1) if Fn=cDelete do . set $piece(@GlobalP@(RecNum,Index),"^",Part)="" if Fn=cSet do . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Performing a hack write. CAUTION!") . set $piece(@GlobalP@(RecNum,Index),"^",Part)=Value set result=cOKToCont DFUTDone if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Fn result=",result) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"DoFileUtility^TMGDBAPI") quit result AddRec(Data) ;"Purpose: Use info from data array to create a MINIMAL new record in database ;" This record will have only it's .01 field, and any multiple ;" subfiles will have only their .01 fields also. ;"Input: Data - Data array should be in format output from GetRInfo ;"Output: data base will be modified by adding record ;"Assumption: That a matching record does not already exist in database ;"Returns: RecNum of added record, or 0 if error (0=abort) ;"NOTE!!! -- As I review this code, does it really return record number added??? if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 new cOKToCont set cOKToCont=1 new cAbort set cAbort=0 new cParentIENS set cParentIENS="ParentIENS" new tmgFDA,TMGFDA ;"Fileman Data Array new IENS ;"Internal Entry Number String new RecNum ;"Internal number entry array new Flags new TMGMsg new FileNum new result set result=cAbort new FDAIndex new MarkerArray new MsgArray if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"AddRec^TMGDBAPI") set IENS=$get(Data(0,cParentIENS)) new MarkNum set MarkNum=0 set result=$$SetupFDA(.Data,.tmgFDA,IENS,"+",.MarkNum,.MsgArray) if result=cAbort goto SkRDone set FileNum=$get(Data(0,"FILE"),0) if FileNum=0 set result=cAbort goto SkRDone if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is master MsgArray") if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("MsgArray") if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is master tmgFDA") if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("tmgFDA") ;"zwr tmgFDA(*) set FDAIndex=FileNum for do quit:(FDAIndex="")!(result=cAbort) . kill TMGFDA . merge TMGFDA(FDAIndex)=tmgFDA(FDAIndex) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Starting cycle with "_FDAIndex_" part.") . ; . set Flags="E" ;"E=External format values . ; . set result=$$ConvertFDA(.TMGFDA,.MarkerArray) . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"AFTER CONVERSION, Here is the FDA to pass to UPDATE^DIE") . if TMGDEBUG do ArrayDump^TMGDEBUG("TMGFDA") ;"zwr TMGFDA(*) . ; . ;"====================================================== . ;"Call UPDATE^DIE . ;"====================================================== . if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"TMGDBAPI::UPDATE^DIE") . if $data(TMGFDA)'=0 do . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Flags=",Flags) . . new $etrap set $etrap="do ErrTrp^TMGDBAPI" . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Remember, UPDATE^DIE adds new entries in files or subfiles.") . . set ^TMP("TMG",$J,"ErrorTrap")=result . . set ^TMP("TMG",$J,"Caller")="UPDATE^DIE" . . do UPDATE^DIE(Flags,"TMGFDA","RecNum","TMGMsg") . . set result=^TMP("TMG",$J,"ErrorTrap") . . kill ^TMP("TMG",$J,"ErrorTrap") . . kill ^TMP("TMG",$J,"Caller") . if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"TMGDBAPI::UPDATE^DIE") . ;"====================================================== . ;"====================================================== . ; . if $data(RecNum) do . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is RecNum array after update/filing") . . if TMGDEBUG do ArrayDump^TMGDEBUG("RecNum") ;"zwr RecNum(*) . . merge MarkerArray=RecNum . . if result=cAbort do . . . new index . . . set index=$order(RecNum("")) . . . set result=$get(RecNum(index)) . . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Output Record#=",result) . else do . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"After update/filing, RecNum array is empty!") . ; . if $data(TMGMsg("DIERR")) do quit . . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) . . if $data(RecNum(1)) do . . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Trying to ignore error") . . . set PriorErrorFound=0 . . else do . . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Unable to ignore error") . . . set result=cAbort . do . . new tI set tI=FDAIndex . . set FDAIndex=$order(tmgFDA(FDAIndex)) . . kill tmgFDA(tI) if result=cAbort do goto SkRDone . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Error encountered, dropping out.") set result=$$HandleHacksArray(.MsgArray) if result=cAbort goto SkRDone SkRDone if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"AddRec^TMGDBAPI") quit result ;"========================================================= ;" Error trap routine ;"========================================================= ErrTrp new cAbort set cAbort=0 set $etrap="",$ecode="" new Caller set Caller=$get(^TMP("TMG",$J,"Caller"),"?") do ShowError^TMGDEBUG(.PriorErrorFound,"Error trapped. Caller was: ",Caller) if $data(TMGMsg) do ShowDIERR^TMGDEBUG(TMGMsg) set ^TMP("TMG",$J,"ErrorTrap")=cAbort quit ;"========================================================= ;" End of Error trap routine ;"========================================================= ;"======================================================== ;"The following routines were moved to shorten module length ConvertFDA(FDA,MarkerArray) goto ConvertFDA+1^TMGDBAP2 ConvertIENS(IENS,MarkerArray) goto ConvertIENS+1^TMGDBAP2 SetupFDA(Data,FDA,parentIENS,SrchType,MarkNum,MsgArray,Minimal,RecNum) goto SetupFDA+1^TMGDBAP2 OverwriteRec(RecNum,Data) goto OverwriteRec+1^TMGDBAP2 GetFileNum(FileName) goto GetFileNum+1^TMGDBAP2 GetFName(FileNumber) goto GetFName+1^TMGDBAP2 GetFldName(File,FieldNumber) goto GetFldName+1^TMGDBAP2 GetFldList(File,pArray) goto GetFldList+1^TMGDBAP2 SetupFileNum(Data) goto SetupFileNum+1^TMGDBAP2 RecFind(Params) goto RecFind+1^TMGDBAP2 FieldCompare(TestField,dbField,Type) goto FieldCompare+1^TMGDBAP2 EnsureWrite(File,Field,IENS,Value,Flags,MsgArray) goto EnsureWrite+1^TMGDBAP2 dbWrite(FDA,Overwrite,TMGIEN,Flags,ErrArray) goto dbWrite+1^TMGDBAP2 DelIEN(File,RecNumIEN,ErrArray) goto DelIEN+1^TMGDBAP2 WriteWP(File,RecNumIEN,Field,TMGArray) goto WriteWP+1^TMGDBAP2 ReadWP(File,IENS,Field,Array) goto ReadWP+1^TMGDBAP2 ShowIfError(TMGMsg,PriorErrorFound) goto ShowIfError+1^TMGDBAP2 DataImport(Info,ProgressFN) goto DataImport+1^TMGDBAP2 Set1(File,IEN,Field,Value,Flag) goto Set1+1^TMGDBAP2 GetValidInput(File,Field) goto GetValidInput+1^TMGDBAP2 AskFIENS() goto AskFIENS+1^TMGDBAP2 ASKSCRN goto ASKSCRN+1^TMGDBAP2 AskIENS(FileNum,IENS) goto AskIENS+1^TMGDBAP2 GetRefArray(FileNum,array) goto GetRefArray+1^TMGDBAP2 FIENS2Root(FIENS) goto FIENS2Root+1^TMGDBAP2 GetRef(file,IENS,field) goto GetRef+1^TMGDBAP2 TrimFDA(FDA,Quiet) goto TrimFDA+1^TMGDBAP2 GetPtrsOUT(File,Info) goto GetPtrsOUT+1^TMGDBAP2