TMGFMUT ;TMG/kst/Fileman utility functions ;03/25/06 ;;1.0;TMG-LIB;**1**;07/12/05 ;"TMG FILEMAN-UTILITY FUNCTIONS ;"Kevin Toppenberg MD ;"GNU General Public License (GPL) applies ;"7-12-2005 ;"======================================================================= ;" API -- Public Functions. ;"======================================================================= ;"$$PTRLINKS ;"$$FilePtrs(File,OutVarP) ;"DispArray(ArrayP,DispdList,indentDepth,MaxDepth) ;"ASKPTRIN ;"ASKMVPTR ;"QTMVPTR(Info,PFn) --quietly redirect pointers. ;"QTMMVPTR(Info,ShowProgress) --quietly redirect multiple pointers at once. ;"$$PtrsIn(File,IEN,Array) ;"$$PtrsMIn(IENArray,Array,ShowProgress) ;"$$PossPtrs(File,Array) ;"$$FMDate(DateStr) -- convert string to FM date, with extended syntax handing ;"======================================================================= ;"PRIVATE API FUNCTIONS ;"======================================================================= ;"ScanFile(FInfo,IEN,Array) ;"ScanMFile(FInfoArray,IENArray,Array,ShowProgress) ;"HandleSubFile(SearchValue,FileArray,Array,IENS,Ref) ;"HandleMSubFile(IENArray,FileArray,Array,IENS,Ref) ;"======================================================================= ;"DEPENDENCIES ;"======================================================================= ;"TMGDBAPI ;"======================================================================= PTRLINKS ;"Purpose: To examine the Fileman data dictionary for a specified file ;" Then tell any pointers out to other files. If found, then display ;" this 'dependency'. Then follow trail to that file, and show it's ;" 'dependency'. Trail will be followed up to N levels deep (set=6 here) ;"Results: 1=OKToContinue, 0=failure new File,Info,DispdList new result write "Display pointer dependencies between files.",!! read "Enter file name or number to explore (^ to abort): ",File,! if File="^" goto PTDone set result=$$FilePtrs(File,"Info") if result=0 write "Error. Aborting. Sorry about that...",!! goto PTDone do DispArray("Info",.DispdList,0,6) ;"force max depth=6 PTDone quit result FilePtrs(File,OutVarP) ;"For File, create array listing those fields with pointers to other files ;"Input: File -- can be file name or number to explore ;" OutVarP -- the name of array to put results into ;"Output: Values are put into @OutVarP as follows: ;" @OutVarP@(FileNum,"FILE NAME")=File Name ;" @OutVarP@(FileNum,FieldNum)=Field Number ;" @OutVarP@(FileNum,FieldNum,"FIELD NAME")=Field Name ;" @OutVarP@(FileNum,FieldNum,"POINTS TO","GREF")=Open format global reference ;" @OutVarP@(FileNum,FieldNum,"POINTS TO","FILE NAME")=File name pointed to ;" @OutVarP@(FileNum,FieldNum,"POINTS TO","FILE NUMBER")=File number pointed to ;" @OutVarP@(FileNum,FieldNum,"X GET")=Code to xecute to get value ;" e.g. SET TMGVALUE=$PIECE($GET(^VA(200,TMGIEN,.11),"^",5))" ;" note: TMGIEN is IEN to lookup, and result is in TMGVALUE ;" @OutVarP@(FileNum,FieldNum,"X SET")=Code to xecute to set value ;" e.g. SET TMGVALUE=$PIECE(^VA(200,TMGIEN,.11),"^",5)=TMGVALUE" ;" ** For subfiles ** ... ;" @OutVarP@(FileNum,FieldNum,"SUBFILE",FileNum,FieldNum,"FIELD NAME")=Field Name ;" @OutVarP@(FileNum,FieldNum,"SUBFILE",FileNum,FieldNum,"POINTS TO","GREF")=Open format global reference ;" @OutVarP@(FileNum,FieldNum,"SUBFILE",FileNum,FieldNum,"POINTS TO","FILE NAME")=File name pointed to ;" @OutVarP@(FileNum,FieldNum,"SUBFILE",FileNum,FieldNum,"POINTS TO","FILE NUMBER")=File number pointed to ;" @OutVarP@(FileNum,FieldNum,"SUBFILE",FileNum,FieldNum,"X GET")=Code to xecute to get value ;" e.g. SET TMGVALUE=$PIECE($GET(^VA(200,TMGIEN,TMGIEN(1),.11),"^",5))" ;" note: TMGIEN is IEN to lookup, and result is in TMGVALUE ;" @OutVarP@(FileNum,FieldNum,"X SET")=Code to xecute to set value ;" e.g. SET TMGVALUE=$PIECE(^VA(200,TMGIEN,TMGIEN(1),.11),"^",5)=TMGVALUE" ;" ... etc. ;"Results: 1=OKToContinue, 0=failure new TMGptrArray new result new index new FileNum,FileName set result=$$GetFldList^TMGDBAPI(.File,"TMGptrArray") if result=0 goto FPtrDone set result=($get(OutVarP)'="") if result=0 goto FPtrDone if +$get(File)=0 do . set FileNum=$$GetFileNum^TMGDBAPI(.File) . set FileName=$get(File) else do . set FileNum=+File . set FileName=$$GetFName^TMGDBAPI(FileNum) set result=(FileNum'=0) if result=0 goto FPtrDone set index=$order(TMGptrArray("")) for do quit:(result=0)!(index="") . new fieldnum,TMGFldInfo . set fieldnum=index . if +fieldnum=0 set result=0 quit . do FIELD^DID(FileNum,fieldnum,,"POINTER;MULTIPLE-VALUED","TMGFldInfo","TMGMsg") . if $data(TMGMsg) do set result=0 quit . . if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("TMGMsg") . . if $data(TMGMsg("DIERR"))'=0 do quit . . . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) . if $get(TMGFldInfo("MULTIPLE-VALUED"))=1 do . . ;" handle subfiles via a recursive call . . new subfile,subArrayP . . set subfile=$$GetSubFileNumber^TMGDBAPI(FileNum,fieldnum) . . if subfile=0 quit . . set subArrayP=$name(@OutVarP@(FileNum,fieldnum,"SUBFILE")) . . ;"set subArrayP=OutVarP . . set result=$$FilePtrs(subfile,subArrayP) . if $get(TMGFldInfo("POINTER"))'="" do . . if +TMGFldInfo("POINTER")>0 quit ;"screen out computed nodes. . . if TMGFldInfo("POINTER")[":" quit ;"screen out set type fields . . new gref,node0 . . set gref=TMGFldInfo("POINTER") . . set @OutVarP@(FileNum,"FILE NAME")=FileName . . set @OutVarP@(FileNum,fieldnum,"FIELD NAME")=$$GetFldName^TMGDBAPI(FileNum,fieldnum) . . set @OutVarP@(FileNum,fieldnum,"POINTS TO","GREF")=gref . . set gref="^"_gref_"0)" . . ;"write "index=",index," gref=",gref,! . . set node0=$get(@gref) . . set @OutVarP@(FileNum,fieldnum,"POINTS TO","FILE NAME")=$piece(node0,"^",1) . . set @OutVarP@(FileNum,fieldnum,"POINTS TO","FILE NUMBER")=+$piece(node0,"^",2) . . new DD set DD=$get(^DD(FileNum,fieldnum,0)) quit:(DD="") . . new nodepce set nodepce=$piece(DD,"^",4) quit:(nodepce="") . . new node set node=+$piece(nodepce,";",1) quit:(node="") . . new pce set pce=+$piece(nodepce,";",2) quit:(pce'>0) . . new thisGL set thisGL=$get(^DIC(FileNum,0,"GL")) . . new getCode,setCode . . if thisGL="" do quit:(thisGL="") . . . ;"Note: I am only going to support 1 sub level. More--> brain hurts! . . . new upNum set upNum=$get(^DD(FileNum,0,"UP")) . . . if upNum="" quit . . . set thisGL=$get(^DIC(upNum,0,"GL")) . . . if thisGL="" quit ;"happens with sub-sub.. nodes. . . . set getCode="SET TMGVALUE=$PIECE($GET("_thisGL_"TMGIEN,TMGIEN(1),"_node_")),""^"","_pce_")" . . . set setCode="SET $PIECE("_thisGL_"TMGIEN,TMGIEN(1),"_node_"),""^"","_pce_")=TMGVALUE" . . else do . . . set getCode="SET TMGVALUE=$PIECE($GET("_thisGL_"TMGIEN,"_node_")),""^"","_pce_")" . . . set setCode="SET $PIECE("_thisGL_"TMGIEN,"_node_"),""^"","_pce_")=TMGVALUE" . . set @OutVarP@(FileNum,fieldnum,"X GET")=getCode . . set @OutVarP@(FileNum,fieldnum,"X SET")=setCode . set index=$order(TMGptrArray(index)) FPtrDone quit result DispArray(ArrayP,DispdList,indentDepth,MaxDepth) ;"Purpose: Display array created by FilePtrs (see format there) ;"Input: ArrayP : name of array containing information ;" DispdList : array (pass by reference) contining list of files already displayed ;" DispdList("TIU DOCUMENT")="" ;" DispdList("PATIENT")="" etc. ;" indentDepth : Number of indents deep this function is. Default=0 ;" MaxDepth : maximum number of indents deep allowed. new i,fieldnum,file,FileName set indentDepth=+$get(indentDepth,0) new indentS set indentS="" for i=1:1:(indentDepth) s indentS=indentS_". " set file=$order(@ArrayP@("")) set FileName=$get(@ArrayP@(file,"FILE NAME")) set DispdList(FileName)="" if FileName'="" write indentS,"FILE: ",FileName,! set fieldnum=$order(@ArrayP@(file,"")) for do quit:(+fieldnum=0) . if +fieldnum=0 quit . new p2FName . set p2FName=$get(@ArrayP@(file,fieldnum,"POINTS TO","FILE NAME")) . write indentS,"field: ",$get(@ArrayP@(file,fieldnum,"FIELD NAME")),"--> file: ",p2FName . if $data(DispdList(p2FName))=0 do . . set DispdList(p2FName)="" . . if indentDepth0 goto APTDone set DIC=File do ^DIC set IEN=+Y if IEN'>0 goto APTDone new TMGTIME set TMGTIME=$H ;"set PFn="w TMGCODE,"" "",((TMGCUR/TMGTOTAL)*100)\1,""%"",!" set PFn="do ProgressBar^TMGUSRIF(TMGCUR,""File: ""_$P(TMGCODE,""^"",1),1,TMGTOTAL)" write !!,"Starting File Scan for instances of pointers (references) to this record.",!! set result=$$PtrsIn(File,IEN,.Array,PFn) if result=0 write !,"There was some problem. Sorry.",!! goto APTDone if $data(Array) do . write !,"Done. Here are results:",! . write "Format is: ",! . write " Array(File#,IEN,0)=LastCount",! . write " Array(File#,IEN,count)=FullRef;piece;IENS;TopGlobalRef",! . write " Description of parts:",! . write " ----------------------",! . write " File# -- the file the found entry exists it (may be a subfile number)",! . write " IEN -- the record number in file",! . write " Note: IEN here is different from the IEN passed in as a parameter",! . write " FullRef -- the is the full reference to the found value. e.g.",! . write " set value=$piece(@FullRef,""^"",piece)",! . write " piece -- piece where value is stored in the node that is specified by FullRef",! . write " IENS -- this is provided only for matches in subfiles. ",! . write " It is the IENS that may be used in database calls",! . write " TopGlobalRef -- this is the global reference for file. If the match is in a",! . write " subfile, then this is the global reference of the parent file ",! . write " (or the highest grandparent file if the parent file itself is",! . write " a subfile)",! . zwr Array(*) . write "---------------------------",! . new temp read "Press [ENTER] to continue.",temp:$get(DTIME,3600),! else write !,"No pointers to that record found.",! APTDone quit SCRLPTRIN ;"Purpose: An scrolling interface shell to PtrsIn. ;" Will ask for name of a file, and then a record in that file. ;" Will then show all pointers to that particular record. ;" Will then allow one to trace along pointer path (in or out) new File,IEN,Array,PFn,result new AFile,AIEN,ACount new ShowArray,ShowResults,Header,Count new PickStr,PickInfo,Abort,Menu,UsrSlct new DIC,X,Y write !!,"Pointer Scanner/Browser.",! write "Will look for all pointers (references) to specified record.",!! set DIC="^DIC(" set DIC(0)="MAQE" DO ^DIC set File=+Y if File'>0 goto SCPTDone set DIC=File do ^DIC set IEN=+Y if IEN'>0 goto SCPTDone new TMGTIME set TMGTIME=$H set PFn="do ProgressBar^TMGUSRIF(TMGCUR,""File: ""_$P(TMGCODE,""^"",1),1,TMGTOTAL)" SCPT1 ; write !!,"Scanning files for instances of pointers (references) to this record.",!! set result=$$PtrsIn(File,IEN,.Array,PFn) if result=0 do goto APTDone . write !,"There was some problem. Sorry.",!! . do PressToCont^TMGUSRIF ;"Returned format is: ",! ;" Array(File#,IEN,0)=LastCount",! ;" Array(File#,IEN,count)=FullRef;piece;IENS;TopGlobalRef",! ;" Description of parts:",! set File=0,Abort=0 for set File=$order(Array(File)) quit:(+File'>0) do . new FName set FName=$piece($get(^DIC(File,0)),"^",1) . new IEN set IEN=0; . for set IEN=$order(Array(File,IEN)) quit:(+IEN'>0) do . . new Value01 set Value01=$$GET1^DIQ(File,IEN,.01) . . set Count=0 . . for set Count=$order(Array(File,IEN,Count)) quit:(+Count'>0) do . . . new Str set Str=FName_"; #"_IEN_"; "_Value01 . . . if Count>1 set Str=Str_" ("_Count_")" . . . set ShowArray(Str,File_"^"_IEN_"^"_Count)="" . . . set Header="Pick ONE (and only ONE) record to explore. Press ESC ESC when done." SCPT2 kill ShowResults if $get(TMGPTCABORT)=1 goto SCPTDone do Slctor2^TMGUSRIF("ShowArray","ShowResults",Header) set Count=$$ListCt^TMGMISC("ShowResults") if Count>1 do goto SCPT2 . write "Please pick ONE (and only ONE) record to explore.",! . write "You selected at least ",Count,! . write "Enter ^ to quit",! . do PressToCont^TMGUSRIF set PickStr="" set PickStr=$order(ShowResults(PickStr)) if PickStr="" do goto SCPTDone . write "No selected record. Goodbye.",! . do PressToCont^TMGUSRIF set Count=$$ListCt^TMGMISC("ShowArray("_PickStr_")") if Count>0 do goto SCPTDone . set Abort=1 . write "Please pick ONE (and only ONE) record to explore.",! . write "You selected at least ",Count,! . do PressToCont^TMGUSRIF set PickInfo=$order(ShowResults(PickStr,"")) set AFile=$piece(PickInfo,"^",1) set AIEN=$piece(PickInfo,"^",2) set ACount=$piece(PickInfo,"^",3) set Menu(0)="Pick Option." set Menu(1)="Show info for this selected record"_$C(9)_"ShowInfo" set Menu(2)="DUMP this record"_$C(9)_"DumpRec" set Menu(3)="Show pointers INTO selected record"_$C(9)_"ShowPtrIN" set Menu(4)="Browse to other records pointed OUT from this record."_$C(9)_"BrowseOUT" MC1 write # set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") if UsrSlct="^" do goto SCPTDone . write "Goodbye.",! if UsrSlct=0 set UsrSlct="" if UsrSlct="ShowInfo" do goto MC1 . if $data(Array(AFile,AIEN,ACount))=0 quit . zwr Array(AFile,AIEN,ACount,*) . do PressToCont^TMGUSRIF if UsrSlct="DumpRec" do goto MC1 . do DumpRec2^TMGDEBUG(AFile,AIEN,0) . do PressToCont^TMGUSRIF if UsrSlct="ShowPtrIN" do goto SCPT1 . set File=AFile . set IEN=AIEN . set Count=ACount if UsrSlct="BrowseOUT" do goto MC1 . do Browse^TMGBROWS(AFile,AIEN,0) . do PressToCont^TMGUSRIF goto MC1 SCPTDone quit ASKMVPTR ;"Purpose: An interface shell toRedirect any pointer. ;" Will ask for name of a file, and then a record in that file. ;" Will then pass information to fileman function to move pointers. ;"Note: Example of array passed to P^DITP ;" 23510 is $J ;" 47 is IEN to be deleted in file 50 (stored at ^PSDRUG(*)) ;" 1646 is IEN to be substituted for all 47's ;" ;" First part of array is list of all files & fields that point to file ;" ---------------- ;" ^UTILITY("DIT",23510,0,1)="727.819^67^P50'" ;" ... ;" ^UTILITY("DIT",23510,0,54)="801.43^.02^RV" ;" ^UTILITY("DIT",23510,0,55)="810.31^.04^V" ;" ^UTILITY("DIT",23510,0,56)="810.32^.01^V" ;" ^UTILITY("DIT",23510,0,57)="811.52^.01^MVX" ;" ^UTILITY("DIT",23510,0,58)="811.902^.01^MVX" ;" ^UTILITY("DIT",23510,0,59)="9009032.4^.05^P50'" ;" ;" Second part of array is list of changes that should be made. Only 1 change shown here. ;" ---------------- ;" ^UTILITY("DIT",23510,47)="1646;PSDRUG(" ;" ^UTILITY("DIT",23510,"47;PSDRUG(")="1646;PSDRUG(" new File,fromIEN,toIEN,Array,PFn,result new PossPtrs write !,"Pointer Redirection Utility",! write "Will change pointers to FROM to TO value",! kill DIC set DIC("A")="Select File holding records being pointed to: " set DIC="^DIC(" set DIC(0)="MAQE" d ^DIC ;"Get File to search set File=+Y if File'>0 goto AMPTDone ;"Get list of files/fields with pointers in set result=$$PossPtrs(File,.PossPtrs) if result=0 goto AMPTDone if $data(PossPtrs)'>0 goto AMPTDone set DIC=File set DIC("A")="Select Original (i.e OLD) Record: " do ^DIC ;"get FROM record in File set fromIEN=+Y if fromIEN'>0 goto AMPTDone set DIC("A")="Select New Record: " do ^DIC ;"get FROM record in File set toIEN=+Y if toIEN'>0 goto AMPTDone ;"set PFn="w TMGCODE,"" "",((TMGCUR/TMGTOTAL)*100)\1,""%"",!" ;"new TMGTIME set TMGTIME=$H set PFn="do ProgressBar^TMGUSRIF(TMGCUR,""Scanning File: ""_$P(TMGCODE,""^"",1),1,TMGTOTAL)" write !!,"Starting File Scan for instances of pointers (references) to this record.",!! set result=$$PtrsIn(File,fromIEN,.Array,PFn) if result=0 goto AMPTDone ;" write !,"Here are possible pointers in (file level)",! ;" if $data(PossPtrs) zwr PossPtrs(*) ;" write !,"Here are actual pointers in",! ;" if $data(Array) zwr Array(*) ;"Now convert to FileMan Format. kill ^UTILITY("DIT",$J) do Prep4FM(.Array) if $data(^UTILITY("DIT",$J)) do . merge ^UTILITY("DIT",$J,0)=PossPtrs . ;"write !,"here are results",! . ;" zwr ^UTILITY("DIT",$J,*) . set DIR(0)="Y",DIR("B")="YES" . set DIR("A")="Ask Fileman to redirect pointers?" . set DIR("?")="Enter YES if you want Fileman to change all instances of the FROM record into the TO record." . do ^DIR ;"get user response . if +Y'=1 quit . write "YES",! . do PTS^DITP else do . write "No matches found...",!! AMPTDone quit QTMVPTR(Info,PFn) ;"NOTE: this function hasn't been debugged/tested yet ;"Purpose: An interface to quietly redirect any pointer. ;"Input: Info, an array containing info for redirecting pointers. ;" Format: Note: File can be file name or number. ;" Info(File,OldIEN)=newIEN ;" Info(File,OldIEN)=newIEN1 ;" Info(File,OldIEN)=newIEN ;" PFn: OPTIONAL, a progress function (must be a complete M expression) ;"Output: all pointers in linked files to OldIEN will be changed to newIEN ;"Results: none ;"Note: Example of array passed to P^DITP ;" 23510 is $J ;" 47 is IEN to be deleted in file 50 (stored at ^PSDRUG(*)) ;" 1646 is IEN to be substituted for all 47's ;" ;" First part of array is list of all files & fields that point to file ;" ---------------- ;" ^UTILITY("DIT",23510,0,1)="727.819^67^P50'" ;" ... ;" ^UTILITY("DIT",23510,0,54)="801.43^.02^RV" ;" ^UTILITY("DIT",23510,0,55)="810.31^.04^V" ;" ^UTILITY("DIT",23510,0,56)="810.32^.01^V" ;" ^UTILITY("DIT",23510,0,57)="811.52^.01^MVX" ;" ^UTILITY("DIT",23510,0,58)="811.902^.01^MVX" ;" ^UTILITY("DIT",23510,0,59)="9009032.4^.05^P50'" ;" ;" Second part of array is list of changes that should be made. Only 1 change shown here. ;" ---------------- ;" ^UTILITY("DIT",23510,47)="1646;PSDRUG(" ;" ^UTILITY("DIT",23510,"47;PSDRUG(")="1646;PSDRUG(" new File,Array,result set PFn=$get(PFn) new Itr,File ;"Cycle through all files to be changed. set File=$$ItrAInit^TMGITR("Info",.Itr) if File'="" for do quit:($$ItrANext^TMGITR(.Itr,.File)="") . new PossPtrs . if +File'=File set File=$$GetFileNum^TMGDBAPI(File) ;Convert File Name to File Number . ;"Get list of files/fields with pointers in . set result=$$PossPtrs(File,.PossPtrs) if result=0 quit . if $data(PossPtrs)'>0 quit . kill ^UTILITY("DIT",$J) . new fromIEN,toIEN,fromItr . set fromIEN=+$$ItrAInit^TMGITR($name(Info(File)),.fromItr) . new done2 set done2=0 . ;"Cycle through all records to be changed. . if fromIEN'=0 for do quit:(+$$ItrANext^TMGITR(.fromItr,.fromIEN)=0)!(done2=1) . . set toIEN=$get(Info(File,fromIEN)) . . set result=$$PtrsIn(File,fromIEN,.Array,PFn) if result=0 set done2=1 . . do Prep4FM(.Array) . if $data(^UTILITY("DIT",$J))=0 quit . merge ^UTILITY("DIT",$J,0)=PossPtrs . do PTS^DITP ;"Note: call separately for each file specified. QMPTDone quit QTMMVPTR(Info,ShowProgress) ;"NOTE: this function hasn't been debugged/tested yet ;"Purpose: An interface to quietly redirect multiple pointer. ;"NOTE: This functions differes from QTMVPTR in that it can look for all IEN's ;" for a given file at once, speeding database access. ;"Input: Info, an array containing info for redirecting pointers. ;" Format: Note: File can be file name or number. ;" Info(File,OldIEN)=newIEN ;" Info(File,OldIEN)=newIEN1 ;" Info(File,OldIEN)=newIEN ;" ShowProgress: if 1, progress bar shown ;"Output: all pointers in linked files to OldIEN will be changed to newIEN ;"Results: none ;"Note: Example of array passed to P^DITP ;" 23510 is $J ;" 47 is IEN to be deleted in file 50 (stored at ^PSDRUG(*)) ;" 1646 is IEN to be substituted for all 47's ;" ;" First part of array is list of all files & fields that point to file ;" ---------------- ;" ^UTILITY("DIT",23510,0,1)="727.819^67^P50'" ;" ... ;" ^UTILITY("DIT",23510,0,54)="801.43^.02^RV" ;" ^UTILITY("DIT",23510,0,55)="810.31^.04^V" ;" ^UTILITY("DIT",23510,0,56)="810.32^.01^V" ;" ^UTILITY("DIT",23510,0,57)="811.52^.01^MVX" ;" ^UTILITY("DIT",23510,0,58)="811.902^.01^MVX" ;" ^UTILITY("DIT",23510,0,59)="9009032.4^.05^P50'" ;" ;" Second part of array is list of changes that should be made. Only 1 change shown here. ;" ---------------- ;" ^UTILITY("DIT",23510,47)="1646;PSDRUG(" ;" ^UTILITY("DIT",23510,"47;PSDRUG(")="1646;PSDRUG(" new ToFile,Array,result set PFn=$get(PFn) new Itr ;"Cycle through all files to be changed. set ToFile=$$ItrAInit^TMGITR("Info",.Itr) if ToFile'="" for do quit:($$ItrANext^TMGITR(.Itr,.ToFile)="") . new PossPtrs . if +ToFile'=ToFile set ToFile=$$GetFileNum^TMGDBAPI(ToFile) ;"Convert File Name to File Number . ;"Get list of files/fields with pointers in . set result=$$PossPtrs(ToFile,.PossPtrs) if result=0 quit . if $data(PossPtrs)'>0 quit . kill ^UTILITY("DIT",$J) . ;"new fromIEN,toIEN,fromItr . ;"set fromIEN=+$$ItrAInit^TMGITR($name(Info(ToFile)),.fromItr) . new IENArray set IENArray=ToFile . merge IENArray=Info(ToFile) . set IENArray=ToFile . set result=$$PtrsMIn(.IENArray,.Array,.ShowProgress) . new toFile2,toIEN,fromFile,fromIEN,Array2 . set toFile2="" . for set toFile2=$order(Array(toFile2)) quit:(toFile2="") do . . set toIEN="" . . for set toIEN=$order(Array(toFile2,toIEN)) quit:(toIEN="") do . . . set fromFile="" . . . for set fromFile=$order(Array(toFile2,toIEN,fromFile)) quit:(fromFile="") do . . . . set fromIEN="" . . . . for set fromIEN=$order(Array(toFile2,toIEN,fromFile,fromIEN)) quit:(fromIEN="") do . . . . . merge Array2(fromFile,fromIEN)=Array(toFile2,toIEN,fromFile,fromIEN) . set toFile2="" . for set toFile2=$order(Array2(toFile2)) quit:(toFile2="") do . . do MPrep4FM(toFile2,.Array2) . . if $data(^UTILITY("DIT",$J))=0 quit . . merge ^UTILITY("DIT",$J,0)=PossPtrs . . do PTS^DITP ;"Note: call separately for each file specified. QMMPTDone quit Prep4FM(Array) ;"Purpose: to convert Array with redirection info into format for Fileman ;"Input: Array -- PASS BY REFERENCE. An array as created by PtrsIn() ;"Output: Data will be put into ^UTILITY('DIT',$J) ;"Results: none ;"Now convert to FileMan Format. new iFile,iIEN,count,index,toRef set iFile=$order(Array("")) if +iFile'=0 for do quit:(+iFile=0) . set iIEN=$order(Array(iFile,"")) . if +iIEN'=0 for do quit:(+iIEN=0) . . set count=+$get(Array(iFile,iIEN,0)) . . for index=1:1:count do . . . set toRef=$piece($get(Array(iFile,iIEN,count)),";",4) . . . set toRef=$extract(toRef,2,999) . . . set ^UTILITY("DIT",$J,fromIEN)=toIEN_";"_toRef . . . set ^UTILITY("DIT",$J,""_fromIEN_";"_toRef_"")=""_toIEN_";"_toRef_"" . . set iIEN=$order(Array(iFile,iIEN)) . set iFile=$order(Array(iFile)) quit MPrep4FM(fromFile,Array) ;"Purpose: to convert Array with redirection info into format for Fileman ;"Input: fromFile -- the FromFileNum -- Note: should be called once for ;" each File number ;" Array -- PASS BY REFERENCE. An array as created by PtrsMIn() ;" Array(FromFile#,fromIEN,0)=LastCount ;" Array(FromFile#,fromIEN,count)=FullRef;piece;IENS;TopGlobalRef ;"Output: Data will be put into ^UTILITY('DIT',$J) ;"Results: none ;"Now convert to FileMan Format. new fromIEN set fromIEN="" for set fromIEN=$order(Array(fromFile,fromIEN)) quit:(+fromIEN'>0) do . new count . set count=+$get(Array(fromFile,fromIEN,0)) . new index for index=1:1:count do . . new toRef . . set toRef=$piece($get(Array(fromFile,fromIEN,count)),";",4) . . set toRef=$extract(toRef,2,999) . . set ^UTILITY("DIT",$J,fromIEN)=toIEN_";"_toRef . . set ^UTILITY("DIT",$J,""_fromIEN_";"_toRef_"")=""_toIEN_";"_toRef_"" quit PtrsIn(File,IEN,Array,PrgsFn) ;"SCOPE: PUBLIC ;"Purpose: Create a list of incoming pointers to a given record in given file ;"Input: File: The file to investigate (Number or Name) ;" IEN: IEN of record to ;" Array -- PASS BY REFERENCE. An array to receive results back. ;" any prexisting data in Array is killed before filling ;" PrgsFn: OPTIONAL -- ;" because this search process can be quite lengthy, ;" an optional line of M code may be given here that will be executed ;" before each file is scanned. The following variables will be defined: ;" TMGCODE -- will hold code of current file being scanned. ;" TMGTOTAL -- will hold total number of records to scan ;" TMGCUR -- will hold count of current record being scanned. ;"Output: Array is filled with format as follows: ;" Array(File#,IEN,0)=LastCount ;" Array(File#,IEN,count)=FullRef;piece;IENS;TopGlobalRef ;" Description of parts: ;" ---------------------- ;" File# -- the file the found entry exists it (may be a subfile number) ;" IEN -- the record number in file ;" Note: IEN here is different from the IEN passed in as a parameter ;" FullRef -- the is the full reference to the found value. e.g. ;" set value=$piece(@FullRef,"^",piece) ;" piece -- the piece where value is stored in the node that is specified by FullRef ;" IENS -- this is provided only for matches in subfiles. It is the IENS that may be used in database calls ;" TopGlobalRef -- this is the global reference for file. If the match is in a subfile, then ;" this is the global reference of the parent file (or the highest grandparent file if ;" the parent file itself is a subfile, etc.) ;" ;"Result: 1 if results found, 0 if error occurred. ;"NOTE: This function manually scans through potentially HUGE numbers of records-->BE PATIENT! kill Array new result set result=0 new FileNum set IEN=+$get(IEN) if IEN=0 goto FPIDone ;"NOTE: IEN doesn't have to point to a valid record. if $data(File)#10=0 goto FPIDone if +File=0 set FileNum=$$GetFileNum^TMGDBAPI(File) ;"Convert File Name to File Number else set FileNum=File if +FileNum=0 goto FPIDone new PossArray,TMGCODE if $$PossPtrs(File,.PossArray)=0 goto FPIDone ;"Count number of records to scan new TMGCUR set TMGCUR=0 new TMGTOTAL set TMGTOTAL=0 do . new temp set temp=$order(PossArray("")) . if temp'="" for do quit:(temp="") . . new code set code=PossArray(temp) . . new ref set ref=$get(^DIC(+code,0,"GL")) . . set ref=$$CREF^DILF(ref) ;"convert open to closed format . . new NumRecs . . if ref'="" set NumRecs=+$piece(@ref@(0),"^",4) . . else set NumRecs=10000 ;"some arbitrary guess of #recs in a subfile . . set TMGTOTAL=TMGTOTAL+1 . . set TMGTOTAL(TMGTOTAL)=NumRecs . . set temp=$order(PossArray(temp)) . set temp=$order(TMGTOTAL("")) . set TMGTOTAL=1 . if temp'="" for do quit:(temp="") . . set TMGTOTAL=TMGTOTAL+TMGTOTAL(temp) . . set temp=$order(TMGTOTAL(temp)) . if TMGTOTAL=0 set TMGTOTAL=1 ;"avoid div by zero issues. new count set count=1 new index set index=$order(PossArray("")) if index'="" for do quit:(index="") . set TMGCUR=TMGCUR+TMGTOTAL(count) . set count=count+1 . set TMGCODE=PossArray(index) . if $get(PrgsFn)'="" do . . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"" set $etrap="""",$ecode=""""" . . xecute PrgsFn . do ScanFile(TMGCODE,IEN,.Array) . set index=$order(PossArray(index)) set result=1 FPIDone quit result PtrsMIn(IENArray,Array,ShowProgress) ;"SCOPE: PUBLIC ;"Purpose: Create a list of incoming pointers to an array of records in given file ;"NOTE: this function differes from PtrsIn because is allows multiple input IEN's ;"Input: IENArray: PASS BY REFERENCE. Array of IENs of record in ToFile. Format: ;" IENArray=SourceFile# ;" IENArray(IEN)="" ;" IENArray(IEN)="" ;" Array -- PASS BY REFERENCE. An array to receive results back. Format below. ;" any prexisting data in Array is killed before filling ;" ShowProgress: if 1, progress bar shown ;"Output: Array is filled with format as follows: ;" Array(ToFile#,ToIEN,FromFile#,fromIEN,0)=LastCount ;" Array(ToFile#,ToIEN,FromFile#,fromIEN,count)=FullRef;piece;IENS;TopGlobalRef ;" Description of parts: ;" ---------------------- ;" ToFile# -- the file containing the target IEN record ;" ToIEN --the IEN in ToFile ;" FromFile# -- the file the found entry exists it (may be a subfile number) ;" fromIEN -- the record number in file ;" Note: IEN here is different from the IEN passed in as a parameter ;" FullRef -- the is the full reference to the found value. e.g. ;" set value=$piece(@FullRef,"^",piece) ;" piece -- the piece where value is stored in the node that is specified by FullRef ;" IENS -- this is provided only for matches in subfiles. It is the IENS that may be used in database calls ;" TopGlobalRef -- this is the global reference for file. If the match is in a subfile, then ;" this is the global reference of the parent file (or the highest grandparent file if ;" the parent file itself is a subfile, etc.) ;" ;"Result: 1 if results found, 0 if error occurred. ;"NOTE: This function manually scans through potentially HUGE numbers of records-->BE PATIENT! kill Array new result set result=0 new FileNum set ToFile=$get(IENArray) if ToFile="" goto FMPIDone if +ToFile=0 set FileNum=$$GetFileNum^TMGDBAPI(File) ;"Convert File Name to File Number else set FileNum=ToFile if +FileNum=0 goto FMPIDone new PossArray if $$PossPtrs(FileNum,.PossArray)=0 goto FMPIDone new FInfoArray new index set index="" for set index=$order(PossArray(index)) quit:(index="") do . new tempS set tempS=$get(PossArray(index)) . new fromFile set fromFile=$piece(tempS,"^",1) . new fromField set fromField=$piece(tempS,"^",2) . new fldCode set fldCode=$piece(tempS,"^",3) . set FInfoArray(fromFile,fromField)=fldCode do ScanMFile(.FInfoArray,.IENArray,.Array,.ShowProgress) set result=1 FMPIDone quit result ScanFile(FInfo,IEN,Array) ;"SCOPE: PUBLIC ;"Purpose: To scan one file (from array setup by PossPtrs) for actual pointers to IEN ;"Input: FInfo : OtherFile#^Field#^FieldCode(piece#2 of 0 node of ^DD entry for field) ;"Examples of possible inputs follow: ;"50^62.05^*P50'" ;"695^.01^RP50'" ;"801.43^.02^RV" ;"810.31^.04^V" ;"811.902^.01^MVX" ;"NOTE: Idea for future enhancement: Allow FInfo to hold a list rather than just one value. ;" This would be for instances where multiple fields in given record need to be searched ;" This might speed up database access times. ;" IEN : the IEN that pointers should point to, to be considered a match. ;" Array : PASS BY REFERENCE. An array to receive results. ;"Output: Format of Array output: ;" Array(File#,IEN,0)=LastCount ;" Array(File#,IEN,count)=FullRef;piece;IENS;TopGlobalRef ;" Description of parts: ;" ---------------------- ;" File# -- the file the found entry exists it (may be a subfile number) ;" IEN -- the record number in file ;" Note: IEN here is different from the IEN passed in as a parameter ;" FullRef -- the is the full reference to the found value. e.g. ;" set value=$piece(@FullRef,"^",piece) ;" piece -- the piece where value is stored in the node that is specified by FullRef ;" IENS -- this is provided only for matches in subfiles. It is the IENS that may be used in database calls ;" TopGlobalRef -- this is the global reference for file. If the match is in a subfile, then ;" this is the global reference of the parent file (or the highest grandparent file if ;" the parent file itself is a subfile, etc.) ;" ;"result : none new File set File=$piece(FInfo,"^",1) if File="" goto SFDone new Field set Field=$piece(FInfo,"^",2) if Field="" goto SFDone new Code set Code=$piece(FInfo,"^",3) if Code="" goto SFDone new count if '((Code["P")!(Code["V")) goto SFDone new GRef new znode set znode=$get(^DD(File,Field,0)) new loc set loc=$piece(znode,"^",4) new node set node=$piece(loc,";",1) new pce set pce=$piece(loc,";",2) if +$$IsSubFile^TMGDBAPI(File) do . new FileArray,i,k,FNum,SubInfo . set i=0 . set FileArray(0)=0 . set FileArray(i,"PARENT","LOC")=loc . set FNum=File . for do quit:(+FNum=0) ;"setup array describing subfile's inheritence . . set i=i+1 . . set FileArray(i)=FNum . . if i=1 set FileArray(0,"FILE")=FNum . . if $$GetSubFInfo^TMGDBAPI(FNum,.SubInfo) do . . . set FileArray(i,"PARENT","LOC")=SubInfo("FIELD IN PARENT","LOC") . . . set GRef=$get(SubInfo("PARENT","GL")) ;"<-- only valid for highest ancestor . . else do . . . set (FileArray(0,"TOP GL"),FileArray(i,"PARENT","GL"))=$get(^DIC(FNum,0,"GL")) . . set FNum=$$IsSubFile^TMGDBAPI(FNum) . do HandleSubFile(IEN,.FileArray,.Array) else do . set GRef=$get(^DIC(File,0,"GL")) . new ORef set ORef=GRef . set GRef=$$CREF^DILF(GRef) ;"convert open to closed format . new index set index=$order(@GRef@(0)) . if index'="" for do quit:(index="") . . new value set value=$get(@GRef@(index,node)) . . if $piece(value,"^",pce)=IEN do . . . set Array(File,index,0)=1 . . . set Array(File,index,1)=$name(@GRef@(index,node))_";"_pce_";"_""_";"_ORef . . set index=$order(@GRef@(index)) SFDone quit ScanMFile(FInfoArray,IENArray,Array,ShowProgress) ;"SCOPE: PUBLIC ;"Purpose: To scan multiple file (from array setup by PossPtrs) for actual pointers to IENs ;"Input: FInfoArray : PASS BY REFERENCE. Format: ;" FInfoArray(OtherFile,Field)=FieldCode(piece#2 of 0 node of ^DD entry for field) ;" Examples of possible inputs follow: ;" FInfoArray(50,62.05)="*P50'" ;" FInfoArray(695,.01)="RP50'" ;" FInfoArray(801.43,.02)="RV" ;" FInfoArray(810.31,.04)="V" ;" FInfoArray(811.902,.01)="MVX" ;" IENArray : PASS BY REFERENCE. IEN's that pointers should point TO, to be considered a match. ;" Format: IENArray=SourceFile ;" IENArray(IEN)="" ;" IENArray(IEN)="" ;" Array : PASS BY REFERENCE. AN OUT PARAMETER. Format: ;" Array(ToFile#,ToIEN,fromFile#,fromIEN,0)=LastCount ;" Array(ToFile#,ToIEN,fromFile#,fromIEN,count)=FullRef;piece;IENS;TopGlobalRef ;" Description of parts: ;" ---------------------- ;" ToFile# -- the file containing the target IEN record ;" ToIEN --the IEN in ToFile ;" fromFile# -- the file the found entry exists it (may be a subfile number) ;" fromIEN -- the record number in file ;" Note: IEN here is different from the IEN passed in as a parameter ;" FullRef -- the is the full reference to the found value. e.g. ;" set value=$piece(@FullRef,"^",piece) ;" piece -- the piece where value is stored in the node that is specified by FullRef ;" IENS -- this is provided only for matches in subfiles. It is the IENS that may be used in database calls ;" TopGlobalRef -- this is the global reference for file. If the match is in a subfile, then ;" this is the global reference of the parent file (or the highest grandparent file if ;" the parent file itself is a subfile, etc.) ;" ShowProgress: if 1, progress bar shown ;" ;"result : none new ToFile set ToFile=+$get(IENArray) set ShowProgress=$get(ShowProgress,0) new abort set abort=0 set fromFile="" for set fromFile=$order(FInfoArray(fromFile)) quit:(fromFile="")!abort do . if $$UserAborted^TMGUSRIF set abort=1 quit . write !,"Processing File#: ",fromFile,! . new Field set Field="" . for set Field=$order(FInfoArray(fromFile,Field)) quit:(Field="") do . . write " Field#: ",Field,! . . new Code set Code=$get(FInfoArray(fromFile,Field)) if Code="" quit . . new count . . if '((Code["P")!(Code["V")) goto SFDone . . new GRef . . new znode set znode=$get(^DD(fromFile,Field,0)) . . new loc set loc=$piece(znode,"^",4) . . new node set node=$piece(loc,";",1) . . new pce set pce=$piece(loc,";",2) . . if +$$IsSubFile^TMGDBAPI(fromFile) do . . . new FileArray,i,k,FNum,SubInfo . . . set i=0 . . . set FileArray(0)=0 . . . set FileArray(i,"PARENT","LOC")=loc . . . set FNum=fromFile . . . for do quit:(+FNum=0) ;"setup array describing subfile's inheritence . . . . set i=i+1 . . . . set FileArray(i)=FNum . . . . if i=1 set FileArray(0,"FILE")=FNum . . . . if $$GetSubFInfo^TMGDBAPI(FNum,.SubInfo) do . . . . . set FileArray(i,"PARENT","LOC")=SubInfo("FIELD IN PARENT","LOC") . . . . . set GRef=$get(SubInfo("PARENT","GL")) ;"<-- only valid for highest ancestor . . . . else do . . . . . set (FileArray(0,"TOP GL"),FileArray(i,"PARENT","GL"))=$get(^DIC(FNum,0,"GL")) . . . . set FNum=$$IsSubFile^TMGDBAPI(FNum) . . . do HandleMSubFile(.IENArray,.FileArray,.Array) . . else do . . . set GRef=$get(^DIC(fromFile,0,"GL")) . . . new ORef set ORef=GRef . . . set GRef=$$CREF^DILF(GRef) ;"convert open to closed format . . . new Itr,fromIEN . . . set fromIEN=$$ItrAInit^TMGITR(GRef,.Itr) . . . if ShowProgress=1 do PrepProgress^TMGITR(.Itr,20,1,"fromIEN") . . . if fromIEN'="" for do quit:($$ItrANext^TMGITR(.Itr,.fromIEN)="")!abort . . . . if $$UserAborted^TMGUSRIF set abort=1 quit . . . . ;"for set fromIEN=$order(@GRef@(fromIEN)) quit:(fromIEN="") do . . . . new valueS set valueS=$get(@GRef@(fromIEN,node)) . . . . new ToIEN set ToIEN=$piece(valueS,"^",pce) . . . . if $data(IENArray(ToIEN))>0 do . . . . . new lastCount set lastCount=+$get(Array(ToFile,ToIEN,fromFile,fromIEN,0))+1 . . . . . set Array(ToFile,ToIEN,fromFile,fromIEN,0)=lastCount . . . . . set Array(ToFile,ToIEN,fromFile,fromIEN,lastCount)=$name(@GRef@(fromIEN,node))_";"_pce_";"_""_";"_ORef SMFDone quit HandleSubFile(SearchValue,FileArray,Array,IENS,Ref) ;"Purpose: To provide a means of recursively handling subfiles, searching for SearchValue. ;"Input: SearchValue -- the value to be searched for, in INTERNAL format. ;" File Array -- PASS BY REFERENCE An array that describes the parent file numbers ;" and storage locations. Example: ;" FileArra(0,"TOP GL")="^XTV(8989.3," ;" FileArra(0,"FILE")=8989.33211 ;" FileArra(0)=0 ;" FileArra(0,"PARENT","LOC")="0;1" <-- for FileArray(0) node, stores node;piece ;" FileArra(1)=8989.33211 ;" FileArra(1,"PARENT","LOC")="1;0" <--- 1 is storage node ;" FileArra(2)=8989.3321 ;" FileArra(2,"PARENT","LOC")="1;0" <--- 1 is storage node ;" FileArra(3)=8989.332 ;" FileArra(3,"PARENT","LOC")="ABPKG;0" <--- "ABPKG" is storage node ;" FileArra(4)=8989.3 ;" FileArra(4,"PARENT","GL")="^XTV(8989.3," ;" Array -- PASS BY REFERENCE. An array the receives any search matches. ;" Format is as follows ;" Array(File#,IEN,0)=LastCount ;" Array(File#,IEN,count)=FullRef;piece;IENS;TopGlobalRef ;" ;" IENS -- OPTIONAL -- used by this function internally during recursive calls ;" Ref -- OPTIONAL -- used by this function internally during recursive calls new index,s,IEN,CRef,pce,node set index=$order(FileArray(""),-1) set s=$get(FileArray(index,"PARENT","LOC")) set node=$piece(s,";",1) set pce=+$piece(s,";",2) if s'="" do . if +node'=node set node=""""_node_"""" . set s=node_"," else do . set s=$get(FileArray(index,"PARENT","GL")) . set node="" set Ref=$get(Ref)_s if Ref="" goto HSFDone set CRef=$$CREF^DILF(Ref) new subFArray merge subFArray=FileArray kill subFArray(index) ;"trim top entry from list/array if index>0 do . set IEN=$order(@CRef@(0)) . if +IEN>0 for do quit:(+IEN=0) . . new subRef,subIENS . . set subRef=Ref_IEN_"," . . set subIENS=IEN_","_$get(IENS) . . do HandleSubFile(SearchValue,.subFArray,.Array,.subIENS,subRef) . . set IEN=$order(@CRef@(IEN)) else do . if (pce>0) do ;"Here is were the actual comparison to SearchValue occurs . . set subRef=$$CREF^DILF(subRef) . . new p,t set (p,t)=0 . . for set t=$find(subRef,",",t) set:(t>0) p=t quit:(t=0) ;"find pos of last parameter . . ;"new ORef set ORef=$extract(subRef,1,p-1) . . set IEN=$piece($extract(subRef,p,99),")",1) . . new value set value=$get(@subRef@(node)) . . set value=$piece(value,"^",pce) . . set value=$piece(value,";",1) ;"I think VARIABLE pointers format is: IEN;file# . . if value=SearchValue do . . . new tFile set tFile=$get(FileArray(0,"FILE"),"?") . . . new count set count=$get(Array(tFile,IEN,0))+1 . . . set Array(tFile,IEN,0)=count . . . set Array(tFile,IEN,count)=$name(@subRef@(node))_";"_pce_";"_""_$get(IENS)_""_";"_$get(FileArray(0,"TOP GL")) HSFDone quit HandleMSubFile(IENArray,FileArray,Array,IENS,Ref) ;"Purpose: To provide a means of recursively handling subfiles, searching for SearchValue. ;"Input: IENArray : PASS BY REFERENCE. IEN's to search for in INTERNAL format. ;" Format: IENArray=SourceFile ;" IENArray(IEN)="" ;" IENArray(IEN)="" ;" File Array -- PASS BY REFERENCE An array that describes the parent file numbers ;" and storage locations. Example: ;" FileArray(0,"TOP GL")="^XTV(8989.3," ;" FileArray(0,"FILE")=8989.33211 ;" FileArray(0)=0 ;" FileArray(0,"PARENT","LOC")="0;1" <-- for FileArray(0) node, stores node;piece ;" FileArray(1)=8989.33211 ;" FileArray(1,"PARENT","LOC")="1;0" <--- 1 is storage node ;" FileArray(2)=8989.3321 ;" FileArray(2,"PARENT","LOC")="1;0" <--- 1 is storage node ;" FileArray(3)=8989.332 ;" FileArray(3,"PARENT","LOC")="ABPKG;0" <--- "ABPKG" is storage node ;" FileArray(4)=8989.3 ;" FileArray(4,"PARENT","GL")="^XTV(8989.3," ;" Array : PASS BY REFERENCE. AN OUT PARAMETER. Format: ;" Array(ToFile#,ToIEN,fromFile#,fromIEN,0)=LastCount ;" Array(ToFile#,ToIEN,fromFile#,fromIEN,count)=FullRef;piece;IENS;TopGlobalRef ;" Description of parts: ;" ---------------------- ;" ToFile# -- the file containing the target IEN record ;" ToIEN --the IEN in ToFile ;" fromFile# -- the file the found entry exists it (may be a subfile number) ;" fromIEN -- the record number in file ;" Note: IEN here is different from the IEN passed in as a parameter ;" FullRef -- the is the full reference to the found value. e.g. ;" set value=$piece(@FullRef,"^",piece) ;" piece -- the piece where value is stored in the node that is specified by FullRef ;" IENS -- this is provided only for matches in subfiles. It is the IENS that may be used in database calls ;" TopGlobalRef -- this is the global reference for file. If the match is in a subfile, then ;" this is the global reference of the parent file (or the highest grandparent file if ;" the parent file itself is a subfile, etc.) ;" ;" IENS -- OPTIONAL -- used by this function internally during recursive calls ;" Ref -- OPTIONAL -- used by this function internally during recursive calls new ToFile set ToFile=$get(IENArray) new index,s,IEN,CRef,pce,node set index=$order(FileArray(""),-1) set s=$get(FileArray(index,"PARENT","LOC")) set node=$piece(s,";",1) set pce=+$piece(s,";",2) if s'="" do . if +node'=node set node=""""_node_"""" . set s=node_"," else do . set s=$get(FileArray(index,"PARENT","GL")) . set node="" set Ref=$get(Ref)_s if Ref="" goto HSFDone set CRef=$$CREF^DILF(Ref) new subFArray merge subFArray=FileArray kill subFArray(index) ;"trim top entry from list/array if index>0 do . set fromIEN=0 . for set fromIEN=$order(@CRef@(fromIEN)) quit:(+fromIEN=0) do . . new subRef,subIENS . . set subRef=Ref_fromIEN_"," . . set subIENS=fromIEN_","_$get(IENS) . . do HandleMSubFile(.IENArray,.subFArray,.Array,.subIENS,subRef) else do . if (pce>0) do ;"Here is were the actual comparison to SearchValue occurs . . set subRef=$$CREF^DILF(subRef) . . new p,t set (p,t)=0 . . for set t=$find(subRef,",",t) set:(t>0) p=t quit:(t=0) ;"find pos of last parameter . . ;"new ORef set ORef=$extract(subRef,1,p-1) . . set fromIEN=$piece($extract(subRef,p,99),")",1) . . new valueS set valueS=$get(@subRef@(node)) . . set valueS=$piece(valueS,"^",pce) . . new ToIEN set ToIEN=$piece(valueS,";",1) ;"I think VARIABLE pointers format is: IEN;file# . . if $data(IENArray(ToIEN))>0 do . . . new fromFile set fromFile=$get(FileArray(0,"FILE"),"?") . . . new count set count=$get(Array(ToFile,ToIEN,fromFile,fromIEN,0))+1 . . . set Array(ToFile,ToIEN,fromFile,fromIEN,0)=count . . . set Array(ToFile,ToIEN,fromFile,fromIEN,count)=$name(@subRef@(node))_";"_pce_";"_""_$get(IENS)_""_";"_$get(FileArray(0,"TOP GL")) HMSFDone quit PossPtrs(File,Array) ;"SCOPE: PUBLIC ;"Purpose: to create a list of all possible pointers to a specified file, i.e. all other fields/fields ;" that point to the specified file. ;"Input: File: The file to investigate (Number or Name) ;" Array -- PASS BY REFERENCE. An array to receive results back. ;" any prexisting data in Array is killed before filling ;"Output: Array is filled with format as follows: ;" Array(1)=OtherFile#^Field#^FieldCode(piece#2 of 0 node of ^DD entry for field) ;" Array(2)=OtherFile#^Field#^FieldCode ;"Result: 1 if results found, 0 if error occurred. kill Array new result set result=0 new FileNum if $data(File)#10=0 goto PPtrsDone if +File=0 set FileNum=$$GetFileNum^TMGDBAPI(File) ;"Convert File Name to File Number else set FileNum=File if +FileNum=0 goto PPtrsDone new count set count=1 new PtrFile set PtrFile=$order(^DD(FileNum,0,"PT","")) if PtrFile'="" for do quit:(PtrFile="") . new PtrField set PtrField=$order(^DD(FileNum,0,"PT",PtrFile,"")) . if PtrField'="" for do quit:(PtrField="") . . new s set s=PtrFile_"^"_PtrField . . set s=s_"^"_$piece($get(^DD(PtrFile,PtrField,0)),"^",2) . . set Array(count)=s . . set count=count+1 . . set PtrField=$order(^DD(FileNum,0,"PT",PtrFile,PtrField)) . set PtrFile=$order(^DD(FileNum,0,"PT",PtrFile)) set result=1 PPtrsDone quit result ;"Note: Not fully debugged yet..." SAFEKILL(Array,ShowProgress) ;"Purpose: to safely kill records, including removing any pointers TO them ;"input: pArray -- PASS BY REFERENCE. Expected input Format: ;" Array(File,IEN)=0 ;" Array(File,IEN)=0 ;" ShowProgress: if 1, progress bar shown ;"Output: all pointers in linked files to OldIEN will be changed to newIEN ;"Results: none do QTMMVPTR(.Array,.ShowProgress) quit ASKKILL ;"Purpose: to interact with user and safely kill records ;"Input: none. ;"Output: Records and pointers may be deleted ;"Results: none new DIC,File,X,Y new fromIEN,toIEN new delArray kill DIC set DIC("A")="Select file to delete from: " set DIC="^DIC(" set DIC(0)="MAQE" d ^DIC ;"Get File to search set File=+Y if File'>0 goto ASKKDone new Menu,UsrSlct set Menu(0)="Pick Option for Selecting Record(s) to Safely Delete" set Menu(1)="Manually pick Record(s)"_$char(9)_"ManualPick" set Menu(2)="Select a SET (aka SORT TEMPLATE) Contianing Many Records"_$char(9)_"PickSet" M1 write # set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") if UsrSlct="ManualPick" goto ManualPick if UsrSlct="PickSet" goto PickSet if UsrSlct="^" goto ASKKDone if UsrSlct=0 set UsrSlct="" goto M1 ManualPick set DIC=File set DIC("A")="Select record to delete: " do ^DIC ;"get FROM record in File write ! set fromIEN=+Y if fromIEN'>0 goto ASKGo set delArray(File,fromIEN)=0 new % set %=2 write "Pick another record" do YN^DICN write ! if %=1 goto ManualPick if %=-1 goto ASKKDone goto ASKGo PickSet new IENArray if $$GetTemplateRecs^TMGXMLUI(File,"IENArray","",1)=0 goto ASKKDone ;"Output: Data is put into pRecs like this: @pRecs@(IEN)="" new IEN set IEN="" for set IEN=$order(IENArray(IEN)) quit:(IEN="") do . set delArray(File,IEN)=0 ASKGo if $data(delArray)=0 goto ASKKDone ;"Get list of files/fields with pointers in set result=$$PossPtrs(File,.PossPtrs) if result=0 goto ASKKDone if $data(PossPtrs)'>0 goto DelRecs do SAFEKILL(.delArray,1) DelRecs ;"Now that pointers to records are deleted, it is safe to remove records themselves set IEN="" new abort set abort=0 for set IEN=$order(IENArray(IEN)) quit:(IEN="")!(abort=1) do . if $$UserAborted^TMGUSRIF set abort=1 quit . new TMGFDA,TMGMSG . set TMGFDA(File,IEN_",",.01)="@" . do FILE^DIE("EK","TMGFDA","TMGMSG") . do ShowIfDIERR^TMGDEBUG(.TMGMSG) ASKKDone quit VerifyPtrs(File,pArray,Verbose,AutoFix) ;"Purpose: to scan a file for pointers OUT that are bad/invalid ;"Input: File : file Name or Number to scan ;" pArray : PASS BY NAME, an OUT PARAMETER. Format: ;" @pArray@(FileNum,IEN,FieldNum)=ValueOfBadPtr ;" @pArray@(FileNum,IEN,FieldNum)=ValueOfBadPtr ;" Verbose: OPTIONAL. If 1, then errors immediately written out. ;" AutoFix: OPTIONAL. If 1, then bad pointers are deleted. ;"Results: None new PtrsOUT new pPtrsOUT set pPtrsOUT="PtrsOUT" new fileNum if +File=File set fileNum=+File else set fileNum=$$GetFileNum^TMGDBAPI(File) set Verbose=+$get(Verbose) set AutoFix=+$get(AutoFix) if $$FilePtrs(fileNum,pPtrsOUT)=0 goto VPtrDone new Itr,Itr2,TMGIEN,fieldNum new TMGVALUE,code new abort set abort=0 new $etrap set $etrap="set Y=""(Invalid M code!. Error Trapped.)"" set $etrap="""",$ecode=""""" do DoVerify(File,pArray,Verbose,AutoFix) ;" Split out code to call it to call itself reentrantly VPtrDone quit DoVerify(fileNum,pArray,Verbose,AutoFix,IENS,pTMGIEN) ;"Purpose: Function allow VerifyPtrs to call reentrantly ;"Input: File : file Name or Number to scan ;" pArray : PASS BY NAME, an OUT PARAMETER. Format: ;" @pArray@(FileNum,IEN,FieldNum)=ValueOfBadPtr ;" @pArray@(FileNum,IEN,FieldNum)=ValueOfBadPtr ;" Verbose: OPTIONAL. If 1, then errors immediately written out. ;" AutoFix: OPTIONAL. If 1, then bad pointers are deleted. ;" IENS: OPTIONAL. If fileNum is a sub-file, then must supply ;" to give location of subfile in parent file. ;" pTMGIEN: "TMGIEN", or "TMGIEN(1)" etc. ;"Results: None ;"NOTICE: right now this MUST first be called from VerifyPtrs because ;" I have not moved some NEW commandes etc from there to here. ;" So this function depends on it's variables with global scope. set IENS=$get(IENS) set pTMGIEN=$get(pTMGIEN,"TMGIEN") set @pTMGIEN=$$ItrInit^TMGITR(fileNum,.Itr,.IENS) if IENS="" do PrepProgress^TMGITR(.Itr,20,0,pTMGIEN) ;" no bar for subfiles if @pTMGIEN'="" for do quit:(+$$ItrNext^TMGITR(.Itr,.@pTMGIEN)'>0)!abort . set fieldNum=$$ItrAInit^TMGITR($name(@pPtrsOUT@(fileNum)),.Itr2) . if fieldNum'="" for do quit:(+$$ItrANext^TMGITR(.Itr2,.fieldNum)'>0)!abort . . if (@pTMGIEN#10=0),$$UserAborted^TMGUSRIF set abort=1 quit . . ;"Line below handles subfiles . . if $data(@pPtrsOUT@(fileNum,fieldNum,"SUBFILE")) do quit . . . new subFile set subFile=$order(@pPtrsOUT@(fileNum,fieldNum,"SUBFILE","")) . . . set IENS=IENS_@pTMGIEN_"," . . . do DoVerify(subFile,$name(@pArray@("SUBFILE")),.Verbose,.AutoFix,IENS,$name(@pTMGIEN@(1))) . . ;"Otherwise, the usual case.... . . set code=$get(PtrsOUT(fileNum,fieldNum,"X GET")) . . if code="" quit . . xecute code . . if TMGVALUE="" quit . . set TMGVALUE=+TMGVALUE . . if TMGVALUE'>0 do quit . . . set @pArray@(fileNum,@pTMGIEN,fieldNum)=TMGVALUE . . . new setCode set setCode=$get(PtrsOUT(fileNum,fieldNum,"X SET")) quit:(setCode="") . . . new priorValue set priorValue=TMGVALUE . . . set TMGVALUE="" . . . if 'AutoFix quit . . . xecute setCode . . . if 'Verbose quit . . . write !,"File=",fileNum,"; IEN=",@pTMGIEN,"; Field=",fieldNum,"; Bad Pointer value=[",priorValue,"]",! . . . write " fixed...",! . . ;"if (fileNum=2)&(TMGVALUE=777) do quit ;"TEMP!!!! . . ;". set code=$get(PtrsOUT(fileNum,fieldNum,"X SET")) quit:(code="") . . ;". set TMGVALUE=69 . . ;". xecute code . . new PtToGref set PtToGref="^"_$get(PtrsOUT(fileNum,fieldNum,"POINTS TO","GREF")) . . if PtToGref="" do quit . . . set @pArray@(fileNum,@pTMGIEN,fieldNum)="??No reference for pointed to file??" . . . if 'Verbose quit . . . write !,"File=",fileNum,"; IEN=",@pTMGIEN,"; Field=",fieldNum,"; Pointer value=[",TMGVALUE,"] but 'No reference for pointed to file (??)'",! . . set PtToGref=PtToGref_TMGVALUE_")" . . if $data(@PtToGref)'>0 do quit . . . set @pArray@(fileNum,@pTMGIEN,fieldNum)=TMGVALUE . . . new setCode set setCode=$get(PtrsOUT(fileNum,fieldNum,"X SET")) quit:(setCode="") . . . new priorValue set priorValue=TMGVALUE . . . set TMGVALUE="" . . . if 'AutoFix quit . . . xecute setCode . . . if 'Verbose quit . . . write !,"File=",fileNum,"; IEN=",@pTMGIEN,"; Field=",fieldNum,"; Bad Pointer value=[",priorValue,"]",! . . . write " fixed...",! if IENS="" do ProgressDone^TMGITR(.Itr) quit ASKVFYPT ;"ASK VERIFY POINTERS ;"Ask user to pick file, then verify pointers for that file. write "NOTICE: this function caused corruption of the database from",! write " deletion of pointers incorrectly. Until this function",! write " (ASKVFYPT^TMGFMUT) is fixed, it may not be used.",!,! do PressToCont^TMGUSRIF goto ASKDone new DIC,X,Y new FileNum,IEN new UseDefault set UseDefault=1 ;"Pick file to dump from ASK1 set DIC=1 set DIC(0)="AEQM" set DIC("A")="SELECT FILE TO VERIFY POINTERS IN: " if UseDefault do ;"leave the redundant do loop, it protects $T, so second do ^DIC isn't called . do ^DICRW ;" has default value of user's last response else do ^DIC ;doesn't have default value... write ! if +Y'>0 write ! goto ASKDone set FileNum=+Y new BadPtrs new AutoFix,Verbose,% set %=2 write "View details of scan" do YN^DICN write ! if %=-1 goto ASKDone set Verbose=(%=1) set %=2 write "Auto-delete bad pointers (i.e. 0 value, or pointers to empty records)" do YN^DICN write ! if %=-1 goto ASKDone set AutoFix=(%=1) do VerifyPtrs(FileNum,"BadPtrs",Verbose,AutoFix) if $data(BadPtrs) do . new % set %=2 . write "View array of bad pointers" do YN^DICN write ! . if %'=1 quit . do ArrayDump^TMGDEBUG("BadPtrs") else write "No bad pointers. Great!",! do PressToCont^TMGUSRIF ASKDone quit GREP(FIELD,S) ;"The is a stub function, called by a Fileman Function (entry in file .5) new result set result="X1="_$get(FIELD)_" X2="_$get(S)_" D0="_$get(D0)_" DCC="_$get(DCC) merge ^TMG("TMP","KILL","DIQGEY")=DIQGEY set ^TMG("TMP","KILL","DA")=$get(DA) set ^TMG("TMP","KILL","DR")=$get(DR) set ^TMG("TMP","KILL","D0")=$get(D0) set ^TMG("TMP","KILL","DCC")=$get(DCC) QUIT result GETAPPT(TMGIEN) QUIT 0 FMDate(DateStr) ;"Purpose: convert string to FM date, with extended syntax handling ;"Results: returns FM date, or -1 if error new result set result=-1 ;"First try direct conversion new X,Y set DateStr=$$TRIM^XLFSTR($get(DateStr)) if DateStr="" goto FMDDone for quit:(DateStr'[" ") set DateStr=$$Substitute^TMGSTUTL(DateStr," "," ") if (DateStr'["@")&($length(DateStr," ")>3) do . set DateStr=$piece(DateStr," ",1,3)_"@"_$piece(DateStr," ",4,99) for quit:(DateStr'["@ ") set DateStr=$$Substitute^TMGSTUTL(DateStr,"@ ","@") for quit:(DateStr'[" @") set DateStr=$$Substitute^TMGSTUTL(DateStr," @","@") set %DT="T",X=DateStr do ^%DT set result=Y FMDDone quit result