| [896] | 1 | TMGFMUT2 ;TMG/kst/Fileman utility functions ;02/19/10
|
|---|
| 2 | ;;1.0;TMG-LIB;**1**;02/19/10
|
|---|
| 3 | ;
|
|---|
| 4 | ;"TMG FILEMAN-UTILITY FUNCTIONS
|
|---|
| 5 | ;"(c) Kevin Toppenberg MD
|
|---|
| 6 | ;"Released under: GNU General Public License (GPL)
|
|---|
| 7 | ;"2/19/10
|
|---|
| 8 | ;
|
|---|
| 9 | ;"=======================================================================
|
|---|
| 10 | ;"NOTE: This module will provide pointer tools that are different than found
|
|---|
| 11 | ;" if ^TMGFMUT. The approach here will be to create tables of pointer
|
|---|
| 12 | ;" relationships, and then allow faster analysis from the tables. This
|
|---|
| 13 | ;" recognizes that such tables can rapidly become out of sync with the
|
|---|
| 14 | ;" actual data. Thus the tools will only be valid on a system at rest (i.e.
|
|---|
| 15 | ;" no users on the system). They could be used for system maint. overnight
|
|---|
| 16 | ;" etc.
|
|---|
| 17 | ;" Several of the routines here are called from ^TMGSIPH*
|
|---|
| 18 | ;"Data is stored here:
|
|---|
| 19 | ;"^TMG("PTXREF","OUT",FROMFILE,IENS,FROMFLD,P2FILE,PT)=""
|
|---|
| 20 | ;"^TMG("PTXREF","IN",P2FILE,PT,FROMFILE,IENS,FROMFLD)=""
|
|---|
| 21 | ;"=======================================================================
|
|---|
| 22 | ;" API -- Public Functions.
|
|---|
| 23 | ;"=======================================================================
|
|---|
| 24 | ;"PREPPTO(FILENUM,FLD,ARRAY) -- set up an easy to use array of potential pointers out from a file.
|
|---|
| 25 | ;"SETPTOUT(FILENUM,DESTREF,PGFN,PGFREQ,LIMITS) -- scan a given file and create an array with all pointers INTO that file.
|
|---|
| 26 | ;"KILLPTIX -- delete the last run of PT XREF, so it can be refreshened.
|
|---|
| 27 | ;"GETPTIN(PARAMS,OUT,PGFN) --get a listing of all pointers INTO requested record
|
|---|
| 28 | ;"BAKXREF(PARAMS,PGFN) --Make a xref of cross-references (a backward xref)
|
|---|
| 29 | ;"BAKSXREF(PARAMS,PGFN)-- Make a xref of cross-references (a backward xref) **OF SUBFILES**
|
|---|
| 30 | ;"GETXRAGE --Return, in HOURS, the time since the ^TMG("PTXREF") array has had any modification
|
|---|
| 31 | ;"GETGL(SUBFILENUM,IENDEPTH) --return a reference 'GL' string for subfiles.
|
|---|
| 32 | ;"GETGREF(FILENUM,IENS) -- To return a reference to a ** SUBFILE **
|
|---|
| 33 | ;"IENCOMBO(REF,IENDEPTH,IEN) --set up global vars IEN(2),IEN(3),... etc, as needed for next combo when cycling through subfile arrays.
|
|---|
| 34 | ;"TOPFILEN(FILENUM) -- Return the highest level of filenumber.
|
|---|
| 35 | ;"ISSUBFIL(FILENUM) -- Return if a file is a subfile.
|
|---|
| 36 | ;"GETIENS(IEN) --Turn IEN Array into IENS
|
|---|
| 37 | ;"IENS2IEN(IENS,IEN) -- Turn IENS into IEN Array, opposite of GETIENS function
|
|---|
| 38 | ;"GETSPFN(FILENUM) -- Turn a subfile number into 'SubFileNum{ParentFileNum{GrandParentFileNum....'
|
|---|
| 39 | ;"HASPTR(FILENUM) --Return if file contains fields that are pointers to other files
|
|---|
| 40 | ;"HASPTRSF(FILENUM) -- Return if file contains subfiles (or sub-subfiles) that contain pointers to other files)
|
|---|
| 41 | ;"FILENAME(FILENUM) -- turn a (SUB)File number into a file name.
|
|---|
| 42 | ;"=======================================================================
|
|---|
| 43 | ;" API - Private Functions
|
|---|
| 44 | ;"=======================================================================
|
|---|
| 45 | ;"TESTSPTO -- test out PT XREF setup.
|
|---|
| 46 | ;"HNDLPTIX(FILENUM,PGFN) -- prepair PT XREF for all records pointing INTO specified file.
|
|---|
| 47 | ;"=======================================================================
|
|---|
| 48 | ;"Dependancies
|
|---|
| 49 | ;"=======================================================================
|
|---|
| 50 | ;"TMGKERN2, TMGUSRIF
|
|---|
| 51 | ;"=======================================================================
|
|---|
| 52 | ;
|
|---|
| 53 | PREPPTO(FILENUM,FLD,ARRAY) ;
|
|---|
| 54 | ;"Purpose: To set up an easy to use array of potential pointers out from a file.
|
|---|
| 55 | ;"Input: FILENUM-- the filenumber to evaluate
|
|---|
| 56 | ;" FLD -- the field to check for.
|
|---|
| 57 | ;" ARRAY -- PASS BY REFERENCE. An OUT PARAMETER. Format
|
|---|
| 58 | ;" ARRAY(GREF,ENTRY)
|
|---|
| 59 | ;" Note: ENTRY=DataPiece^PointedToFile^PointedToReference^IENDepth^[V]^FromFile^Fromfield^ONEREF
|
|---|
| 60 | ;" ONEREF will have multipe IEN entries if IENDepth>1, e.g. '^SC(IEN,"S",IEN(2),1,IEN(3),"C")'
|
|---|
| 61 | ;" with order of IEN, IEN(2), IEN(3), ... etc.
|
|---|
| 62 | ;"NOTE: This function was originally coppied from SETPTOUT^TMGSIPH1
|
|---|
| 63 | ;
|
|---|
| 64 | IF +$GET(FILENUM)'=FILENUM GOTO SPODN
|
|---|
| 65 | NEW IENDEPTH SET IENDEPTH=1
|
|---|
| 66 | NEW REF SET REF=$GET(^DIC(FILENUM,0,"GL"))
|
|---|
| 67 | IF (REF=""),$DATA(^DD(FILENUM,0,"UP")) DO
|
|---|
| 68 | . SET REF=$$GETGL(FILENUM,.IENDEPTH)
|
|---|
| 69 | IF REF="" GOTO SPODN
|
|---|
| 70 | NEW GREF SET GREF=REF
|
|---|
| 71 | IF GREF["IEN," SET GREF=$PIECE(GREF,"IEN,",1)
|
|---|
| 72 | NEW ZNODE SET ZNODE=$GET(^DD(FILENUM,FLD,0))
|
|---|
| 73 | NEW FLDTYPE SET FLDTYPE=$PIECE(ZNODE,"^",2)
|
|---|
| 74 | IF (FLDTYPE'["P")&(FLDTYPE'["V") GOTO SPODN
|
|---|
| 75 | NEW LOC SET LOC=$PIECE(ZNODE,"^",4)
|
|---|
| 76 | NEW NODE SET NODE=$PIECE(LOC,";",1)
|
|---|
| 77 | NEW PCE SET PCE=+$PIECE(LOC,";",2)
|
|---|
| 78 | IF +NODE'=NODE SET NODE=""""_NODE_""""
|
|---|
| 79 | NEW ONEREF,SUBSCR
|
|---|
| 80 | SET SUBSCR=$SELECT((IENDEPTH>1):"("_IENDEPTH_")",1:"")
|
|---|
| 81 | SET ONEREF=REF_"IEN"_SUBSCR_","_NODE_")"
|
|---|
| 82 | NEW P2FILE SET P2FILE=0
|
|---|
| 83 | NEW VREC SET VREC=0
|
|---|
| 84 | NEW DONE SET DONE=0
|
|---|
| 85 | FOR DO QUIT:(DONE=1)
|
|---|
| 86 | . NEW ISVIRT SET ISVIRT=""
|
|---|
| 87 | . NEW P2REF
|
|---|
| 88 | . IF FLDTYPE["V" DO QUIT:(DONE=1)
|
|---|
| 89 | . . SET VREC=+$ORDER(^DD(FILENUM,FLD,"V",VREC))
|
|---|
| 90 | . . IF VREC=0 SET DONE=1 QUIT
|
|---|
| 91 | . . SET P2FILE=+$GET(^DD(FILENUM,FLD,"V",VREC,0))
|
|---|
| 92 | . . SET ISVIRT="V"
|
|---|
| 93 | . . SET P2REF=$PIECE($GET(^DIC(P2FILE,0,"GL")),"^",2)
|
|---|
| 94 | . ELSE DO
|
|---|
| 95 | . . SET P2FILE=+$PIECE(FLDTYPE,"P",2)
|
|---|
| 96 | . . SET P2REF=$PIECE(ZNODE,"^",3)
|
|---|
| 97 | . . SET DONE=1
|
|---|
| 98 | . NEW ENTRY
|
|---|
| 99 | . SET ENTRY=PCE_"^"_P2FILE_"^"_P2REF_"^"_IENDEPTH_"^"_ISVIRT_"^"_FILENUM_"^"_FLD_"^"_ONEREF
|
|---|
| 100 | . SET ARRAY(GREF,ENTRY)=""
|
|---|
| 101 | SPODN QUIT
|
|---|
| 102 | ;
|
|---|
| 103 | ;
|
|---|
| 104 | GETIENS(IEN) ;"Turn IEN Array into IENS
|
|---|
| 105 | NEW RESULT SET RESULT=IEN
|
|---|
| 106 | NEW I SET I=1
|
|---|
| 107 | FOR SET I=$ORDER(IEN(I)) QUIT:(+I'>0) DO
|
|---|
| 108 | . SET RESULT=$GET(IEN(I))_","_RESULT
|
|---|
| 109 | IF RESULT["," SET RESULT=RESULT_","
|
|---|
| 110 | QUIT RESULT
|
|---|
| 111 | ;
|
|---|
| 112 | ;
|
|---|
| 113 | IENS2IEN(IENS,IEN) ;
|
|---|
| 114 | ;"Purpose: Turn IENS into IEN Array, opposite of GETIENS function
|
|---|
| 115 | ;"Input: IENS - an IENS string to convert. E.g. '7,2342,"
|
|---|
| 116 | ;" IEN -- PASS BY REFERENCE. An OUT PARAMETER.
|
|---|
| 117 | ;"Results: None.
|
|---|
| 118 | KILL IEN
|
|---|
| 119 | SET IENS=$GET(IENS)
|
|---|
| 120 | NEW LEN SET LEN=$LENGTH(IENS,",")-1
|
|---|
| 121 | NEW I FOR I=1:1:LEN DO
|
|---|
| 122 | . NEW IDX SET IDX=(LEN-I+1)
|
|---|
| 123 | . NEW VALUE SET VALUE=$PIECE(IENS,",",I)
|
|---|
| 124 | . IF IDX>1 SET IEN(IDX)=VALUE
|
|---|
| 125 | . ELSE SET IEN=VALUE
|
|---|
| 126 | QUIT
|
|---|
| 127 | ;
|
|---|
| 128 | ;
|
|---|
| 129 | SETPTOUT(FILENUM,DESTREF,PGFN,PGFREQ,LIMITS)
|
|---|
| 130 | ;"Purpose: To scan a given file and create an array with all pointers INTO that file.
|
|---|
| 131 | ;" NOTE: The output will be a snapshot of the database that will quickly be out
|
|---|
| 132 | ;" of date if/when the database changes.
|
|---|
| 133 | ;"Input: FILENUM -- the Fileman file number to test. This is that file that other records will point TO
|
|---|
| 134 | ;" DESTREF -- OPTIONAL. PASS BY NAME. The name of an array to store output into.
|
|---|
| 135 | ;" MUST BE IN CLOSED FORMAT. If not specified, then ^TMG("PTXREF" will be used.
|
|---|
| 136 | ;" PGFN -- OPTIONAL. <Progress Function Code>
|
|---|
| 137 | ;" A string of mumps code that will be executed once for every 100 records that are scanned.
|
|---|
| 138 | ;" The following variables will be defined for use.
|
|---|
| 139 | ;" TMGCT -- The total number of that have been scanned so far.
|
|---|
| 140 | ;" TMGFNAME -- The file that is currently begin scanned.
|
|---|
| 141 | ;" TMGIEN -- Record number in the current file being scanned.
|
|---|
| 142 | ;" TMGMAX -- Max record number in the current file being scanned.
|
|---|
| 143 | ;" TMGMIN -- Min record number in the current file being scanned.
|
|---|
| 144 | ;" PGFREQ --OPTIONAL. The number of records that must be scanned before the Progress Fn
|
|---|
| 145 | ;" code is called. Default = 100.
|
|---|
| 146 | ;" LIMITS -- OPTIONAL. If $DATA(LIMITS("REF"))'=0 then REF should be an array with format:
|
|---|
| 147 | ;" LIMITS("REF")=<aREF>
|
|---|
| 148 | ;" @aREF@(FILENUM,IEN)="" <-- Forms a set that will limit search. Only these entries are considered.
|
|---|
| 149 | ;" @aREF@(FILENUM,IEN)="" <--
|
|---|
| 150 | ;"Result: none.
|
|---|
| 151 | NEW RESULT SET RESULT=0
|
|---|
| 152 | SET FILENUM=+$GET(FILENUM) GOTO:(FILENUM=0) SPODN
|
|---|
| 153 | SET DESTREF=$GET(DESTREF,$NAME(^TMG("PTXREF")))
|
|---|
| 154 | SET PGFN=$GET(PGFN,"QUIT")
|
|---|
| 155 | SET PGFREQ=+$GET(PGFREQ) IF PGFREQ'>0 SET PGFREQ=100
|
|---|
| 156 | NEW LIMITREF SET LIMITREF=$GET(LIMITS("REF"))
|
|---|
| 157 | SET LIMITS=(LIMITREF'="")
|
|---|
| 158 | ;
|
|---|
| 159 | ;"Build up ARRAY, an easy to use array of potential pointers OUT from a file.
|
|---|
| 160 | ;"NOTE: Only files that point INTO FILENUM will be put into this array.
|
|---|
| 161 | NEW ARRAY
|
|---|
| 162 | NEW FROMFILE SET FROMFILE=0 ;"OtherFile
|
|---|
| 163 | FOR SET FROMFILE=$ORDER(^DD(FILENUM,0,"PT",FROMFILE)) QUIT:(+FROMFILE'>0) DO
|
|---|
| 164 | . NEW FLD SET FLD=0
|
|---|
| 165 | . FOR SET FLD=$ORDER(^DD(FILENUM,0,"PT",FROMFILE,FLD)) QUIT:(+FLD'>0) DO
|
|---|
| 166 | . . DO PREPPTO(FROMFILE,FLD,.ARRAY) ;
|
|---|
| 167 | ;
|
|---|
| 168 | ;"Now, cycle through possible pointers to look for real pointers.
|
|---|
| 169 | SET @DESTREF@("TIMESTAMP")=$H
|
|---|
| 170 | NEW ABORT SET ABORT=0
|
|---|
| 171 | NEW TMGCT SET TMGCT=0
|
|---|
| 172 | NEW GREF SET GREF=""
|
|---|
| 173 | FOR SET GREF=$ORDER(ARRAY(GREF)) QUIT:(GREF="")!ABORT DO
|
|---|
| 174 | . NEW TEMPN SET TEMPN=0
|
|---|
| 175 | . NEW SKIP SET SKIP=0
|
|---|
| 176 | . NEW FOUND SET FOUND=0
|
|---|
| 177 | . FOR SET TEMPN=$ORDER(^DIC(TEMPN)) QUIT:(+TEMPN'>0)!FOUND DO ;"Get filenumber of GREF
|
|---|
| 178 | . . IF $GET(^DIC(TEMPN,0,"GL"))'=GREF QUIT
|
|---|
| 179 | . . SET FOUND=1
|
|---|
| 180 | . . SET @DESTREF@("OUT",TEMPN)=$H
|
|---|
| 181 | . IF SKIP QUIT
|
|---|
| 182 | . NEW REF SET REF=$$CREF^DILF(GREF)
|
|---|
| 183 | . NEW TMGMAX SET TMGMAX=$ORDER(@REF@("+"),-1)
|
|---|
| 184 | . NEW TMGMIN SET TMGMIN=$ORDER(@REF@(0))
|
|---|
| 185 | . NEW SKIP SET SKIP=0
|
|---|
| 186 | . NEW IEN SET IEN=0
|
|---|
| 187 | . FOR SET IEN=$ORDER(@REF@(IEN)) QUIT:(+IEN'>0)!ABORT!SKIP DO
|
|---|
| 188 | . . IF LIMITS DO QUIT:SKIP ;"If running on client side, only look at downloaded records.
|
|---|
| 189 | . . . IF $DATA(@LIMITREF@(TEMPN,IEN))'=0 QUIT
|
|---|
| 190 | . . . SET SKIP=1
|
|---|
| 191 | . . NEW INFO SET INFO=""
|
|---|
| 192 | . . FOR SET INFO=$ORDER(ARRAY(GREF,INFO)) QUIT:(INFO="")!ABORT DO
|
|---|
| 193 | . . . NEW PCE SET PCE=$PIECE(INFO,"^",1)
|
|---|
| 194 | . . . NEW IENDEPTH SET IENDEPTH=$PIECE(INFO,"^",4)
|
|---|
| 195 | . . . NEW ONREF SET ONEREF=$PIECE(INFO,"^",8,99)
|
|---|
| 196 | . . . NEW TEMP SET TEMP=IEN KILL IEN SET IEN=TEMP ;"clear subscripts
|
|---|
| 197 | . . . FOR QUIT:($$IENCOMBO(ONEREF,IENDEPTH,.IEN)'=1)!ABORT DO
|
|---|
| 198 | . . . . NEW FROMFILE SET FROMFILE=$PIECE(INFO,"^",6)
|
|---|
| 199 | . . . . SET TMGCT=TMGCT+1
|
|---|
| 200 | . . . . IF TMGCT#PGFREQ=0 DO
|
|---|
| 201 | . . . . . SET ABORT=$$UserAborted^TMGUSRIF() QUIT:ABORT
|
|---|
| 202 | . . . . . NEW TMGFNAME SET TMGFNAME=$PIECE($GET(^DIC(FROMFILE,0)),"^",1)
|
|---|
| 203 | . . . . . NEW TMGIEN SET TMGIEN=IEN
|
|---|
| 204 | . . . . . NEW $ETRAP SET $ETRAP="W ""(Invalid M Code!. Error Trapped.)"" S $ETRAP="""",$ECODE="""""
|
|---|
| 205 | . . . . . XECUTE PGFN
|
|---|
| 206 | . . . . NEW PT SET PT=$PIECE($GET(@ONEREF),"^",PCE) ;"$$IENCOMBO sets up IEN(n).. needed for @REF
|
|---|
| 207 | . . . . NEW ISVIRT SET ISVIRT=($PIECE(INFO,"^",5)="V")
|
|---|
| 208 | . . . . NEW P2REF SET P2REF=$PIECE(INFO,"^",3)
|
|---|
| 209 | . . . . IF ISVIRT,$PIECE(PT,";",2)'=P2REF QUIT ;"Loop to handle PTR with different INFO entry (V-Ptrs stored as IEN;OREF)
|
|---|
| 210 | . . . . SET PT=+PT QUIT:(PT'>0)
|
|---|
| 211 | . . . . NEW IENS SET IENS=$$GETIENS(.IEN)
|
|---|
| 212 | . . . . NEW P2FILE SET P2FILE=$PIECE(INFO,"^",2)
|
|---|
| 213 | . . . . NEW FROMFLD SET FROMFLD=$PIECE(INFO,"^",7)
|
|---|
| 214 | . . . . SET @DESTREF@("OUT",FROMFILE,IENS,FROMFLD,P2FILE,PT)=""
|
|---|
| 215 | . . . . SET @DESTREF@("IN",P2FILE,PT,FROMFILE,IENS,FROMFLD)=""
|
|---|
| 216 | QUIT
|
|---|
| 217 | ;
|
|---|
| 218 | ;
|
|---|
| 219 | TESTSPTO
|
|---|
| 220 | ;"Purpose: test out PT XREF setup.
|
|---|
| 221 | NEW X,Y,DIC
|
|---|
| 222 | SET DIC=1,DIC(0)="MAEQ"
|
|---|
| 223 | DO ^DIC WRITE !
|
|---|
| 224 | IF +Y'>0 QUIT
|
|---|
| 225 | NEW TMGSTIME SET TMGSTIME=$H
|
|---|
| 226 | NEW PGFN SET PGFN="DO ProgressBar^TMGUSRIF(TMGIEN,TMGFNAME,TMGMIN,TMGMAX,60,TMGSTIME)"
|
|---|
| 227 | DO SETPTOUT(+Y,$NAME(^TMG("PTXREF")),PGFN,500)
|
|---|
| 228 | WRITE !,"Quitting normally.",!
|
|---|
| 229 | QUIT
|
|---|
| 230 | ;
|
|---|
| 231 | ;
|
|---|
| 232 | KILLPTIX ;
|
|---|
| 233 | ;"Purpose: To delete the last run of PT XREF, so it can be refreshened.
|
|---|
| 234 | KILL ^TMG("PTXREF")
|
|---|
| 235 | QUIT
|
|---|
| 236 | ;
|
|---|
| 237 | ;
|
|---|
| 238 | HNDLPTIX(FILENUM,PGFN) ;
|
|---|
| 239 | ;"Purpose: To prepair PT XREF for all records pointing INTO specified file.
|
|---|
| 240 | ;"Input: FILENUM -- The fileman file number to get pointers INTO.
|
|---|
| 241 | ;" PGFN -- OPTIONAL -- M Code that wil be periodically executed to show progress.
|
|---|
| 242 | ;"Result: None
|
|---|
| 243 | SET FILENUM=+$GET(FILENUM) IF FILENUM'>0 QUIT
|
|---|
| 244 | NEW TMGSTIME SET TMGSTIME=$H
|
|---|
| 245 | DO SETPTOUT(FILENUM,$NAME(^TMG("PTXREF")),.PGFN,3000,CLSIDE)
|
|---|
| 246 | SET ^TMG("PTXREF","IN",FILENUM)=$H
|
|---|
| 247 | SET ^TMG("PTXREF")=$H
|
|---|
| 248 | QUIT
|
|---|
| 249 | ;
|
|---|
| 250 | ;
|
|---|
| 251 | GETPTIN(PARAMS,OUT,PGFN) ;
|
|---|
| 252 | ;"Purpose: To get a listing of all pointers INTO requested record
|
|---|
| 253 | ;"Input: PARAMS -- this is FILENUM^IEN
|
|---|
| 254 | ;" OUT -- PASS BY REFERNCE. Will be filled as with format:
|
|---|
| 255 | ;" OUT(1)=FROMFILE^FROMIENS^FROMFLD
|
|---|
| 256 | ;" OUT(2)=FROMFILE^FROMIENS^FROMFLD
|
|---|
| 257 | ;" PGFN -- OPTIONAL -- M Code that wil be periodically executed to show progress.
|
|---|
| 258 | ;" ...
|
|---|
| 259 | NEW FILENUM SET FILENUM=+$PIECE(PARAMS,"^",1)
|
|---|
| 260 | NEW TMGCT SET TMGCT=1
|
|---|
| 261 | NEW IEN SET IEN=+$PIECE(PARAMS,"^",2)
|
|---|
| 262 | IF $DATA(^TMG("PTXREF","IN",FILENUM))'>0 DO HNDLPTIX(FILENUM,.PGFN)
|
|---|
| 263 | NEW FROMFILE,FROMIENS,FROMFLD
|
|---|
| 264 | SET (FROMFILE,FROMIENS,FROMFLD)=0
|
|---|
| 265 | FOR SET FROMFILE=$ORDER(^TMG("PTXREF","IN",FILENUM,IEN,FROMFILE)) QUIT:(+FROMFILE'>0) DO
|
|---|
| 266 | . FOR SET FROMIENS=$ORDER(^TMG("PTXREF","IN",FILENUM,IEN,FROMFILE,FROMIENS)) QUIT:(+FROMIENS'>0) DO
|
|---|
| 267 | . . FOR SET FROMFLD=$ORDER(^TMG("PTXREF","IN",FILENUM,IEN,FROMFILE,FROMIENS,FROMFLD)) QUIT:(+FROMFLD'>0) DO
|
|---|
| 268 | . . . SET OUT(TMGCT)=FROMFILE_"^"_FROMIENS_"^"_FROMFLD
|
|---|
| 269 | . . . SET TMGCT=TMGCT+1
|
|---|
| 270 | QUIT
|
|---|
| 271 | ;
|
|---|
| 272 | ;
|
|---|
| 273 | BAKXREF(PARAMS,PGFN) ;
|
|---|
| 274 | ;"Purpose: Make a xref of cross-references (a backward xref)
|
|---|
| 275 | ;"Input: PARAMS -- This is FILENUM^[KEEP]
|
|---|
| 276 | ;" FILENUM -- The fileman file to work with
|
|---|
| 277 | ;" KEEP -- optional. DEFAULT=0; If '1', then nothing done if xref already exists.
|
|---|
| 278 | ;" PGFN -- OPTIONAL -- M Code that wil be periodically executed to show progress.
|
|---|
| 279 | ;" The following globally-scoped variables will be available for use:
|
|---|
| 280 | ;" FILENUM,INDEX
|
|---|
| 281 | ;"Output: ^TMG("PTXREF","XREFS",FILENUM,IEN,REF)=<xref value>
|
|---|
| 282 | ;" e.g. ^TMG("PTXREF","XREFS",FILENUM,113,"^VA(200,""A"",8870804679,113)")=6188
|
|---|
| 283 | ;"Result: none.
|
|---|
| 284 | SET PARAMS=$GET(PARAMS)
|
|---|
| 285 | SET FILENUM=$PIECE(PARAMS,"^",1) IF +FILENUM'>0 GOTO BXDN
|
|---|
| 286 | IF FILENUM["{" DO BAKSXREF(.PARAMS,.PGFN) GOTO BXDN
|
|---|
| 287 | IF $DATA(^TMG("PTXREF","XREFS",FILENUM))>0 GOTO BXDN
|
|---|
| 288 | SET PGFN=$GET(PGFN)
|
|---|
| 289 | NEW STIME SET STIME=$H
|
|---|
| 290 | NEW GREF SET GREF=$GET(^DIC(FILENUM,0,"GL"))
|
|---|
| 291 | IF GREF="" QUIT ;"Happened for file 799.6
|
|---|
| 292 | NEW GRLEN SET GRLEN=$LENGTH(GREF)
|
|---|
| 293 | NEW CGREF SET CGREF=$$CREF^DILF(GREF)
|
|---|
| 294 | NEW GREFQLEN SET GREFQLEN=$QLENGTH(CGREF)
|
|---|
| 295 | NEW REF SET REF=$QUERY(@CGREF@("@"))
|
|---|
| 296 | NEW INDEX,LASTINDEX SET LASTINDEX=""
|
|---|
| 297 | NEW DELAYCT SET DELAYCT=500 ;"ensure fires at least once to avoid timeout with many quick XREFS
|
|---|
| 298 | NEW DONE SET DONE=0
|
|---|
| 299 | KILL ^TMG("PTXREF","XREFS",FILENUM)
|
|---|
| 300 | IF $GET(^TMG("PTXREF"))="" SET ^TMG("PTXREF")=$H
|
|---|
| 301 | SET ^TMG("PTXREF","XREFS",FILENUM)=$H
|
|---|
| 302 | FOR QUIT:(REF="") DO
|
|---|
| 303 | . SET DELAYCT=DELAYCT+1
|
|---|
| 304 | . IF (DELAYCT>500),(PGFN'="") DO
|
|---|
| 305 | . . SET DELAYCT=0
|
|---|
| 306 | . . IF ($PIECE($H,",",2)-STIME)<5 QUIT
|
|---|
| 307 | . . SET STIME=$PIECE($H,",",2)
|
|---|
| 308 | . . NEW $ETRAP SET $ETRAP="SET $ETRAP="""",$ECODE="""""
|
|---|
| 309 | . . XECUTE PGFN
|
|---|
| 310 | . IF $EXTRACT(REF,1,GRLEN)'=GREF SET REF="" QUIT
|
|---|
| 311 | . NEW IEN SET IEN=$QSUBSCRIPT(REF,$QLENGTH(REF))
|
|---|
| 312 | . SET ^TMG("PTXREF","XREFS",FILENUM,IEN,REF)=$GET(@REF)
|
|---|
| 313 | . SET INDEX=$QSUBSCRIPT(REF,GREFQLEN+1)
|
|---|
| 314 | . IF INDEX'=LASTINDEX DO
|
|---|
| 315 | . . SET LASTINDEX=INDEX
|
|---|
| 316 | . . SET STIME=$PIECE($H,",",2)
|
|---|
| 317 | . . SET DELAYCT=0
|
|---|
| 318 | . . NEW $ETRAP SET $ETRAP="SET $ETRAP="""",$ECODE="""""
|
|---|
| 319 | . . XECUTE PGFN
|
|---|
| 320 | . SET REF=$QUERY(@REF)
|
|---|
| 321 | BXDN QUIT
|
|---|
| 322 | ;
|
|---|
| 323 | ;
|
|---|
| 324 | BAKSXREF(PARAMS,PGFN) ;
|
|---|
| 325 | ;"Purpose: Make a xref of cross-references (a backward xref) **OF SUBFILES**
|
|---|
| 326 | ;"Input: PARAMS -- This is FILENUM^[KEEP]
|
|---|
| 327 | ;" FILENUM -- subfilenum{parentfilenum{grandparent....
|
|---|
| 328 | ;" KEEP -- optional. DEFAULT=0; If '1', then nothing done if xref already exists.
|
|---|
| 329 | ;" PGFN -- OPTIONAL -- M Code that wil be periodically executed to show progress.
|
|---|
| 330 | ;" The following globally-scoped variables will be available for use:
|
|---|
| 331 | ;" FILENUM,INDEX
|
|---|
| 332 | ;"Output: ^TMG("PTXREF","XREFS",SUBFILENUM,IENS,REF)=<xref value>
|
|---|
| 333 | ;"Result: none.
|
|---|
| 334 | SET PARAMS=$GET(PARAMS)
|
|---|
| 335 | SET FILENUM=+$PIECE(PARAMS,"^",1) ;"Just get the subfile number.
|
|---|
| 336 | IF FILENUM'>0 GOTO BXSDN
|
|---|
| 337 | IF $DATA(^TMG("PTXREF","XREFS",FILENUM))>0 GOTO BXSDN
|
|---|
| 338 | SET PGFN=$GET(PGFN)
|
|---|
| 339 | NEW IEN SET IEN=0
|
|---|
| 340 | NEW INDEX SET INDEX=""
|
|---|
| 341 | NEW IENDEPTH SET IENDEPTH=""
|
|---|
| 342 | NEW GREF SET GREF=$$GETGL(FILENUM,.IENDEPTH) ;" e.g. file 44.003 --> ^SC(IEN,"S",IEN(2),1, (open format)
|
|---|
| 343 | IF GREF="" QUIT ;"Happened for file 799.6
|
|---|
| 344 | NEW CGREF SET CGREF=$$CREF^DILF(GREF)
|
|---|
| 345 | NEW J FOR J=1:1:IENDEPTH SET IEN(J)=1 ;"dummy values to satisfy $QLENGTH on line below
|
|---|
| 346 | NEW GREFQLEN SET GREFQLEN=$QLENGTH($NAME(@CGREF))
|
|---|
| 347 | NEW DELAYCT SET DELAYCT=999
|
|---|
| 348 | ;"NOTE: IENCOMBO is only for getting subfile combos. It doesn't modify IEN. So I need
|
|---|
| 349 | ;"to manually cycle between all the records of the top-most file. Use GETTOPFILEN^TMGFMUT2 to get this.
|
|---|
| 350 | NEW TOPFILE SET TOPFILE=+$$TOPFILEN(FILENUM)
|
|---|
| 351 | NEW TOPREF SET TOPREF=$GET(^DIC(TOPFILE,0,"GL"))
|
|---|
| 352 | IF TOPREF="" GOTO BXSDN
|
|---|
| 353 | KILL IEN SET IEN=0
|
|---|
| 354 | SET TOPREF=$$CREF^DILF(TOPREF)
|
|---|
| 355 | FOR SET IEN=$ORDER(@TOPREF@(IEN)) QUIT:(+IEN'>0) DO
|
|---|
| 356 | . FOR DO QUIT:(OKCOMBO=0)
|
|---|
| 357 | . . SET DELAYCT=DELAYCT+1
|
|---|
| 358 | . . IF (DELAYCT>500),(PGFN'="") DO
|
|---|
| 359 | . . . SET DELAYCT=0
|
|---|
| 360 | . . . NEW $ETRAP SET $ETRAP="SET $ETRAP="""",$ECODE="""""
|
|---|
| 361 | . . . XECUTE PGFN
|
|---|
| 362 | . . SET OKCOMBO=$$IENCOMBO^TMGFMUT2(CGREF,IENDEPTH,.IEN) ;"Sets up IEN(n).. needed for @CGREF
|
|---|
| 363 | . . QUIT:(OKCOMBO=0)
|
|---|
| 364 | . . NEW GREF SET GREF=$$OREF^DILF($NAME(@CGREF)) ;"resolve IEN vars into actual numbers
|
|---|
| 365 | . . NEW GRLEN SET GRLEN=$LENGTH(GREF)
|
|---|
| 366 | . . NEW REF SET REF=$NAME(@CGREF@("@"))
|
|---|
| 367 | . . FOR DO QUIT:(REF="")
|
|---|
| 368 | . . . SET REF=$QUERY(@REF)
|
|---|
| 369 | . . . IF $EXTRACT(REF,1,GRLEN)'=GREF SET REF="" QUIT
|
|---|
| 370 | . . . SET INDEX=$QSUBSCRIPT(REF,GREFQLEN+1) ;"set up for use by PGFN
|
|---|
| 371 | . . . NEW PTR SET PTR=$QSUBSCRIPT(REF,$QLENGTH(REF))
|
|---|
| 372 | . . . NEW TMPIEN MERGE TMPIEN=IEN
|
|---|
| 373 | . . . SET TMPIEN(IENDEPTH+1)=PTR
|
|---|
| 374 | . . . NEW IENS SET IENS=$$GETIENS(.TMPIEN)
|
|---|
| 375 | . . . SET ^TMG("PTXREF","XREFS",FILENUM,IENS,REF)=$GET(@REF)
|
|---|
| 376 | . KILL IEN("DONE"),IEN("INIT")
|
|---|
| 377 | BXSDN QUIT
|
|---|
| 378 | ;
|
|---|
| 379 | ;
|
|---|
| 380 | GETXRAGE() ;
|
|---|
| 381 | ;"Purpose: Return, in HOURS, the time since the ^TMG("PTXREF") array has had any modification
|
|---|
| 382 | ;"Results: 0 if not currently defined, otherwise number of HOURS since setup.
|
|---|
| 383 | NEW LASTT SET LASTT=$GET(^TMG("PTXREF","TIMESTAMP"))
|
|---|
| 384 | NEW DELTAT SET DELTAT=0
|
|---|
| 385 | IF LASTT'="" SET DELTAT=$$HDIFF^XLFDT($H,LASTT,2)\(60*60)
|
|---|
| 386 | QUIT DELTAT
|
|---|
| 387 | ;
|
|---|
| 388 | ;
|
|---|
| 389 | GETGL(SUBFILENUM,IENDEPTH) ;
|
|---|
| 390 | ;"Purpose: To return a reference 'GL' string for subfiles.
|
|---|
| 391 | ;" E.g. file 44.003 --> ^SC(IEN,"S",IEN(2),1,
|
|---|
| 392 | ;"INPUT: SUBFILENUM -- The sub file number
|
|---|
| 393 | ;" IENDEPTH -- PASS BY REFERENCE. Should be 1 on first call
|
|---|
| 394 | ;"Results: Returns an OPEN reference.
|
|---|
| 395 | NEW RESULT SET RESULT=""
|
|---|
| 396 | SET IENDEPTH=+$GET(IENDEPTH)+1
|
|---|
| 397 | NEW UPFILE SET UPFILE=+$GET(^DD(SUBFILENUM,0,"UP"))
|
|---|
| 398 | IF UPFILE'>0 DO GOTO IDN
|
|---|
| 399 | . SET RESULT=$GET(^DIC(SUBFILENUM,0,"GL"))
|
|---|
| 400 | NEW UPFLD SET UPFLD=+$ORDER(^DD(UPFILE,"SB",SUBFILENUM,""))
|
|---|
| 401 | IF UPFLD'>0 GOTO IDN
|
|---|
| 402 | NEW NODE SET NODE=$PIECE(^DD(UPFILE,UPFLD,0),"^",4)
|
|---|
| 403 | SET NODE=$PIECE(NODE,";",1)
|
|---|
| 404 | IF +NODE'=NODE SET NODE=""""_NODE_""""
|
|---|
| 405 | SET RESULT=NODE_","
|
|---|
| 406 | NEW GREF SET GREF=$GET(^DIC(UPFILE,0,"GL"))
|
|---|
| 407 | NEW NUM2 SET NUM2=IENDEPTH
|
|---|
| 408 | IF GREF="" SET GREF=$$GETGL(UPFILE,.IENDEPTH)
|
|---|
| 409 | SET RESULT=GREF_"#"_$CHAR(64+NUM2)_"#,"_RESULT
|
|---|
| 410 | IDN NEW I,TMGSPEC
|
|---|
| 411 | FOR I=1:1:IENDEPTH DO
|
|---|
| 412 | . IF I=IENDEPTH SET TMGSPEC("#"_$CHAR(64+I)_"#")="IEN"
|
|---|
| 413 | . ELSE SET TMGSPEC("#"_$CHAR(64+I)_"#")="IEN("_(IENDEPTH-I+1)_")"
|
|---|
| 414 | SET RESULT=$$REPLACE^XLFSTR(RESULT,.TMGSPEC)
|
|---|
| 415 | IDN2 QUIT RESULT
|
|---|
| 416 | ;
|
|---|
| 417 | ;
|
|---|
| 418 | GETGREF(FILENUM,IENS) ;
|
|---|
| 419 | ;"Purpose: To return a reference to a file or a subfile
|
|---|
| 420 | ;" This function differs from GETGL in that REF from GETGREFhere has actual record numbers
|
|---|
| 421 | ;" put in, while REF from GETGL has variable names (e.g. IEN(2)) in it.
|
|---|
| 422 | ;"Input: IENS -- A standard IENS string to locate subfile. Not used unless FILENUM is a subfile.
|
|---|
| 423 | ;" NOTE: the lowest level IEN is not used. e.g. '7,22345,' --> 7 is not used
|
|---|
| 424 | ;"Returns : an OPEN format reference.
|
|---|
| 425 | NEW GREF
|
|---|
| 426 | NEW IENDEPTH SET IENDEPTH=1
|
|---|
| 427 | SET GREF=$$GETGL(FILENUM,.IENDEPTH)
|
|---|
| 428 | IF $$ISSUBFIL(FILENUM)=0 GOTO GGRDN
|
|---|
| 429 | SET GREF=$$CREF^DILF(GREF)
|
|---|
| 430 | NEW IEN DO IENS2IEN(.IENS,.IEN)
|
|---|
| 431 | SET GREF=$NAME(@GREF) ;"Lock IEN value(s) from IENS into GREF
|
|---|
| 432 | SET GREF=$$OREF^DILF(GREF)
|
|---|
| 433 | GGRDN QUIT GREF
|
|---|
| 434 | ;
|
|---|
| 435 | ;
|
|---|
| 436 | IENCOMBO(REF,IENDEPTH,IEN) ;
|
|---|
| 437 | ;"Purpose: To set up global vars IEN(2),IEN(3),... etc, as needed for next combo when
|
|---|
| 438 | ;" cycling through subfile arrays.
|
|---|
| 439 | ;"Input: REF -- the is the potential pointer reference, as stored in ^TMG("TMGSIPH","DD",FILENUM,"PTR OUT",REF,INFO)
|
|---|
| 440 | ;" e.g. '^SC(IEN,"S",IEN(2),1,IEN(3),"C") (and IENDEPTH would be 3 for this example)
|
|---|
| 441 | ;" IENDEPTH -- The number of variables to consider. I.e if value=3, then REF will
|
|---|
| 442 | ;" contain IEN,IEN(2),IEN(3)
|
|---|
| 443 | ;" IEN -- PASS BY REFERENCE. This variable will serve as an array to store the
|
|---|
| 444 | ;" information needed to create the next valid set of variables needed
|
|---|
| 445 | ;" to make use of the reference. NOTE: The value of IEN itself (e.g. IEN=4),
|
|---|
| 446 | ;" is not modified.
|
|---|
| 447 | ;"Results: 1 if a new valid IEN combo has been set up.
|
|---|
| 448 | ;" 0 if there are no more subfile entries.
|
|---|
| 449 | ;"
|
|---|
| 450 | ;"NOTE!!!: If IENDEPTH=3, then this function will fail if there are records for depth 1,2, but not 3
|
|---|
| 451 | ;" Needs debugging...
|
|---|
| 452 | ;"
|
|---|
| 453 | ;
|
|---|
| 454 | NEW RESULT SET RESULT=0 ;"Default to invalid
|
|---|
| 455 | IF $DATA(IEN("DONE")) GOTO ICODN
|
|---|
| 456 | IF IENDEPTH=1 DO GOTO ICODN
|
|---|
| 457 | . SET IEN("DONE")=1
|
|---|
| 458 | . SET RESULT=1
|
|---|
| 459 | NEW I
|
|---|
| 460 | SET RESULT=1 ;"Default to valid
|
|---|
| 461 | IF $DATA(IEN("ORDS"))=0 DO
|
|---|
| 462 | . FOR I=2:1:IENDEPTH SET IEN("ORDS",I)=$$CREF^DILF($PIECE(REF,"IEN("_I_")",1))
|
|---|
| 463 | IF +$GET(IEN("INIT"))=0 DO
|
|---|
| 464 | . SET IEN("INIT")=1
|
|---|
| 465 | . NEW INVALID SET INVALID=0
|
|---|
| 466 | . NEW POS FOR POS=2:1:IENDEPTH DO QUIT:(INVALID=1)
|
|---|
| 467 | . . IF $GET(IEN(POS))'="" QUIT
|
|---|
| 468 | . . NEW TEMPREF SET TEMPREF=IEN("ORDS",POS)
|
|---|
| 469 | . . SET IEN(POS)=+$ORDER(@TEMPREF@(0))
|
|---|
| 470 | . . IF IEN(POS)'>0 SET INVALID=1
|
|---|
| 471 | . IF (POS=IENDEPTH),(INVALID=0) SET RESULT=1
|
|---|
| 472 | ELSE DO ;"At this point, IEN(n),IEN(n+1),... vars should be set to last valid combo.
|
|---|
| 473 | . SET I=IENDEPTH
|
|---|
| 474 | . NEW REF,NODE
|
|---|
| 475 | . FOR DO QUIT:(I<2)!(I=IENDEPTH)
|
|---|
| 476 | . . SET REF=IEN("ORDS",I)
|
|---|
| 477 | . . SET IEN(I)=$ORDER(@REF@(IEN(I)))
|
|---|
| 478 | . . IF (IEN(I)="") SET I=I-1 QUIT ;"reached last record at this level, so backup up level
|
|---|
| 479 | . . IF (I<IENDEPTH) DO ;"We have a valid record, now get next subrecord
|
|---|
| 480 | . . . NEW J FOR J=(I+1):1:IENDEPTH DO QUIT:(IEN(J)="")
|
|---|
| 481 | . . . . SET REF=IEN("ORDS",J)
|
|---|
| 482 | . . . . SET IEN(J)=$ORDER(@REF@(""))
|
|---|
| 483 | FOR I=2:1:IENDEPTH IF +$GET(IEN(I))'>0 SET RESULT=0
|
|---|
| 484 | ICODN QUIT RESULT
|
|---|
| 485 | ;
|
|---|
| 486 | ;
|
|---|
| 487 | TOPFILEN(FILENUM) ;
|
|---|
| 488 | ;"Purpose: Return the highest level of filenumber. I.e. if subfile, then return parent
|
|---|
| 489 | ;" parent filenumber. If sub-sub-file, then return higest file number that is
|
|---|
| 490 | ;" not a sub file.
|
|---|
| 491 | ;" If FILENUM is not a subfile, then just return same FILENUM
|
|---|
| 492 | ;"Results: 0 if problem, or Top-most filenumber.
|
|---|
| 493 | NEW RESULT SET RESULT=0
|
|---|
| 494 | IF +$GET(FILENUM)'=FILENUM GOTO TFNDN
|
|---|
| 495 | FOR QUIT:$DATA(^DD(FILENUM,0,"UP"))=0 DO
|
|---|
| 496 | . SET FILENUM=+$GET(^DD(FILENUM,0,"UP"))
|
|---|
| 497 | SET RESULT=FILENUM
|
|---|
| 498 | TFNDN QUIT RESULT
|
|---|
| 499 | ;
|
|---|
| 500 | ;
|
|---|
| 501 | ISSUBFIL(FILENUM) ;
|
|---|
| 502 | ;"Purpose: Return if a file is a subfile.
|
|---|
| 503 | ;"Input: FILENUM -- a File, or Subfile, number
|
|---|
| 504 | ;"Result: 1 if file is a subfile
|
|---|
| 505 | QUIT ($DATA(^DD(FILENUM,0,"UP"))>0)
|
|---|
| 506 | ;
|
|---|
| 507 | ;
|
|---|
| 508 | HASPTRSF(FILENUM) ;" HAS POINTER-CONTAINING SUBFILES
|
|---|
| 509 | ;"Purpose: Return if file contains subfiles (or sub-subfiles) that contain pointers to other files)
|
|---|
| 510 | ;"Input: FILENUM -- The file number to investigatge
|
|---|
| 511 | ;"Results: 1 if has pointer subfiles.
|
|---|
| 512 | ;";
|
|---|
| 513 | NEW RESULT SET RESULT=0
|
|---|
| 514 | NEW FLD SET FLD=0
|
|---|
| 515 | FOR SET FLD=$ORDER(^DD(FILENUM,FLD)) QUIT:(+FLD'>0)!(RESULT=1) DO
|
|---|
| 516 | . NEW ZNODE SET ZNODE=$GET(^DD(FILENUM,FLD,0))
|
|---|
| 517 | . NEW FLDTYPE SET FLDTYPE=$PIECE(ZNODE,"^",2)
|
|---|
| 518 | . IF (+FLDTYPE'>0) QUIT
|
|---|
| 519 | . NEW SUBFILEN SET SUBFILEN=+FLDTYPE
|
|---|
| 520 | . IF $GET(^DD(SUBFILEN,0,"UP"))'=FILENUM QUIT
|
|---|
| 521 | . SET RESULT=$$HASPTR(SUBFILEN)
|
|---|
| 522 | QUIT RESULT
|
|---|
| 523 | ;
|
|---|
| 524 | ;
|
|---|
| 525 | HASPTR(FILENUM) ;" HAS POINTER fields
|
|---|
| 526 | ;"Purpose: Return if file contains fields that are pointers to other files
|
|---|
| 527 | ;"Input: FILENUM -- The file number to investigatge
|
|---|
| 528 | ;"Results: 1 if has pointer subfiles.
|
|---|
| 529 | ;"
|
|---|
| 530 | NEW RESULT SET RESULT=($DATA(^DD(FILENUM,0,"PT"))'=0)
|
|---|
| 531 | IF RESULT GOTO HPDN
|
|---|
| 532 | NEW FLD SET FLD=0
|
|---|
| 533 | FOR SET FLD=$ORDER(^DD(FILENUM,FLD)) QUIT:(+FLD'>0)!(RESULT=1) DO
|
|---|
| 534 | . NEW ZNODE SET ZNODE=$GET(^DD(FILENUM,FLD,0))
|
|---|
| 535 | . NEW FLDTYPE SET FLDTYPE=$PIECE(ZNODE,"^",2)
|
|---|
| 536 | . IF +$PIECE(FLDTYPE,"P",2)>0 SET RESULT=1 QUIT
|
|---|
| 537 | . IF (+FLDTYPE'>0) QUIT
|
|---|
| 538 | . NEW SUBFILEN SET SUBFILEN=+FLDTYPE
|
|---|
| 539 | . IF $GET(^DD(SUBFILEN,0,"UP"))'=FILENUM QUIT
|
|---|
| 540 | . SET RESULT=$$HASPTRSF(SUBFILEN)
|
|---|
| 541 | HPDN QUIT RESULT
|
|---|
| 542 | ;
|
|---|
| 543 | ;
|
|---|
| 544 | FILENAME(FILENUM) ;
|
|---|
| 545 | ;"Purpose: to turn a File number into a file name. ALSO, turn input with format of
|
|---|
| 546 | ;" SubfileNumber{ParentFileNumber into a meaningful name too.
|
|---|
| 547 | ;"Input: FILENUM: A file number, or a SubfileNumber{ParentFileNumber
|
|---|
| 548 | ;"Result: returns name or name{name{name
|
|---|
| 549 | ;"
|
|---|
| 550 | IF (FILENUM'["{"),$$ISSUBFIL(+FILENUM) DO
|
|---|
| 551 | . SET FILENUM=$$GETSPFN(FILENUM)
|
|---|
| 552 | NEW RESULT SET RESULT=""
|
|---|
| 553 | NEW I
|
|---|
| 554 | FOR I=1:1:$LENGTH(FILENUM,"{") DO
|
|---|
| 555 | . NEW ANUM SET ANUM=$PIECE(FILENUM,"{",I)
|
|---|
| 556 | . NEW PFILE SET PFILE=+$GET(^DD(ANUM,0,"UP"))
|
|---|
| 557 | . NEW ANAME
|
|---|
| 558 | . IF PFILE=0 DO
|
|---|
| 559 | . . SET ANAME=$PIECE($GET(^DIC(ANUM,0)),"^",1)
|
|---|
| 560 | . ELSE DO
|
|---|
| 561 | . . SET ANAME=$PIECE($GET(^DD(ANUM,0)),"^",1)
|
|---|
| 562 | . . SET ANAME=$PIECE(ANAME,"SUB-FIELD",1)
|
|---|
| 563 | . . SET ANAME=$$TRIM^XLFSTR(ANAME)
|
|---|
| 564 | . IF RESULT'="" SET RESULT=RESULT_"{"
|
|---|
| 565 | . SET RESULT=RESULT_ANAME
|
|---|
| 566 | QUIT RESULT
|
|---|
| 567 | ;
|
|---|
| 568 | ;
|
|---|
| 569 | GETSPFN(FILENUM) ;" Get Special Filenum
|
|---|
| 570 | ;"Purpose: Turn a subfile number into a 'special' subfilenumber, in format of:
|
|---|
| 571 | ;" SubFileNum{ParentFileNum{GrandParentFileNum....
|
|---|
| 572 | ;"Results: 0 if problem, or Top-most filenumber.
|
|---|
| 573 | NEW RESULT SET RESULT=""
|
|---|
| 574 | NEW FN SET FN=FILENUM
|
|---|
| 575 | FOR DO QUIT:FN=0
|
|---|
| 576 | . IF RESULT'="" SET RESULT=RESULT_"{"
|
|---|
| 577 | . SET RESULT=RESULT_FN
|
|---|
| 578 | . SET FN=+$GET(^DD(FN,0,"UP"))
|
|---|
| 579 | QUIT RESULT
|
|---|
| 580 | ;
|
|---|
| 581 | ;
|
|---|
