* PARTINDX.prg    - Generate partial index
*
*
* Version Date     Comment                                        Done by
* ======= ======== ============================================== ===========
*   1.00  05/15/90 Initial version.                               K. Foley
*


* Parameters
*
*  IdxKey       Character   - Actual expresion index file is to be based on
*  IdxFileName  Character   - Name of the index file to be built.
*                             Must specify .ntx extension
*  MaxIdxRcs    Numeric     - Best guess for upper limit on number of records
*  KeyExpr      Character   - Expression used in conjunction with KeyValue
*                             to halt indexing.
*  KeyValue     Variable    - Matching value for &KeyValue
*  UserFilter   Character   - Optional user specified filtering function
*
*  NOTE: Assumes database is already positioned at starting record.
*        The last key in the index will usually NOT belong to the
*        KeyValue.  To restrict the use of this eronius key, use SET FILTER,
*        after the partial index has been built and used.
*        Since the index being used is small, SET FILTER will not
*        dramatically impede performance, as it would have if a larger index
*        was being used.
*
*  EXAMPLE:  This example builds a partial index called BOB.NTX that only
*            contains keys for records with FILEID equal to 20555 .
*
*  use BENE2CL
*  set index to BENE2CL
*  seek " 20555"
*  PartIndex("str(FILEID,6,0)+str(SEQUENCE,2,0)","bob.ntx",75,"FILEID",20555)
*  set index to bob
*  set filter to FILEID = 20555
*
*


* PROCEDURE PARTINDX
  Private UserFilter
    UserFilter = ""
  Parameters IdxKey, IdxFileName, MaxIdxRcs, KeyExpr, KeyValue, UserFilter
  Private LoopVar, NullVar, SubScript
  Private IdxAryRcs[MaxIdxRcs], handle, Scrn, OldColor, AddIt

  * Show indexing message for progress report

  * OldColor = SETCOLOR()
  * Scrn = MsgDisp("Wait. Indexing record xxx",.f.,"w+/r","w+/r",-1)
  * SETCOLOR("W+/R")

  * Build array of record pointers

  IdxAryRcs[MaxIdxRcs] = LASTREC()

  LoopVar = 0
  do while LoopVar < MaxIdxRcs .and. !eof() .and. ;
     &KeyExpr = KeyValue
     AddIt = .F.
     if empty(UserFilter)
       AddIt = .T.
     else
       if &UserFilter
         AddIt = .T.
       endif
     endif
     if AddIt
       LoopVar = LoopVar + 1
       IdxAryRcs[LoopVar] = RECNO()

       * Show indexing status
       @ 11,49 say LoopVar picture "999"
     endif
    skip
  enddo

  * Assign EOF pointers to all unused array cells

  for NullVar= LoopVar + 1 to MaxIdxRcs
    IdxAryRcs[NullVar] = LASTREC()
  next

  * Close original index

  set index to

  * Sort pointers in numeric order to prevent an early indexing termination
  * via goto'ing an early EOF pointer.

  ASORT(IdxAryRcs)

  * Create the partial index

  SubScript = -1
  index on xFAKEOUT() to &IdxFileName.

  * Close the partial index

  set index to

  * Rewrite index file header.  Remove the index expression xFAKEOUT
  * and replace it with the actual index value expression.

  handle = FOPEN(IdxFileName,2)
  if handle > 0
    FSEEK(handle,22,0)
    FWRITE(handle,IdxKey + space(200),200)
  endif
  FCLOSE(handle)

  * SpclEfex( "TB", "P", Scrn, 20 )
  * SETCOLOR(OldColor)

  RELEASE IdxAryRcs, Scrn

  * Set the index back to the partial index,

  set index to &IdxFileName.

RETURN


FUNCTION xFAKEOUT

  SubScript = SubScript + 1
  if SubScript > 0
    GOTO IdxAryRcs[SubScript]

    * Show indexing status

    @ 11,49 say LoopVar picture "999"
    LoopVar = LoopVar - 1
  else
    GOTO IdxAryRcs[1]
  endif

RETURN &IdxKey