'SI       - temp - routine to check Supplier's invoice against GDS_RCVD. Also marks
'SUPP_INV - routine to check Supplier's invoice against GDS_RCVD. Also marks
'           GDS_RCVD with Due Date of Payment (DDP)

external   entryline() vloadif() dpath bpopdb() sch scw progress() messbox()
external   fgp bgp cpath navrecs() reqnpopup() messline() exception()
external   userid remove() messboxwait()
'  makeidx() addidxrec()

public     ptstr suppcode ptval

global     x y FindSupplier() suppname y1 y2 y3 y4 ReturnToMenu() S_hdr
global     ordernr ProcessInvoice() ShowCompleted() #invcost $paymth Titles()
global     #ordcost #margin #M_l #M_m #M_h cat mess prodsupp StartTitle()
global     $suppinv #invitems #L_l #L_u RemoveCheck() #totalinv #invtotal i
global     $action #rem $comment_P #item delidxrec()
' newexcepts[1] #ar_ln
global     PopComm() NavRecSuppInv() r1 r2 c1 c2 cl1 cl2 ExceptlCost()
global     #tot_diff ProcessLineItem() m1 m2 m3 m4 m5 ns #recs #nritems[1]

' #########################################################################

public   openidx()       'opens the index
public   closeidx()      'closes the index
public   totidxrecs()    'returns total number of current index records
public   wrtidxval()     'writes an integer to the index (4 byte)
public   wrtidxpad()     'writes blocks of nulls to index

public   getidxval()     'reads an integer from the index (4 byte)
public   addidxrec()     'appends a record to named index
' public   delidxrec()     'deletes record from named index
public   makeidx()       'creates a new index (empty or one record)
public   wrtidxstr()     'fills strings to length with nulls
public   getidxrecs()    'returns total number of index records (opens file)
public   nxtidxpos()     'seeks the end of an already opened index file
public   wrtidxtot()     'changes index record number of an already opened
public   wrtidxhdr()     'writes already opened idx header
public   idxappend()     'appends named indexes to a passed main idx

global   chkiext()       'checks for valid extension on OPEN and MAKE
'**** VARIABLE DECLARATIONS *********************************************
'library
' public ptval ptstr
public currlib
'core
global   ihlen

' #########################################################################

MAIN
  single-step off
  screen clear box 1 1 sch scw 0 0 no-border
  r1 = 1
  r2 = r1+2
  cl1 = 15

  repaint off
  #L_l = 100
  #L_u = 500
  #M_l = .5     ' invoice < œ100 margin is 50p
  #M_m = 1      ' invoice > œ100 & < œ500 margin is 100p
  #M_h = 2      ' invoice > œ500 margin is œ2

  suppcode = ""
  while true
'     x = FindSupplier()                   ' select supplier (GDS_RCVD)
'     if x = -1
'       ReturnToMenu()
'     end if

    x = ShowCompleted()                  ' show all uncleared orders
    if x = -1
      continue while
    end if
  end while

END MAIN


FUNCTION ShowCompleted()
  ns = 0
  $action = "N"
  vloadif(dpath|"suppinv1.vw")
'   order change key "[Supplier_Code]"
'   data query execute "supp_inv.dfq" index "supp_inv.idx"
' ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄŋ
'   [Supplier_Code] = suppcode and len([Invoice_Nr])=0 and not(deleted)
' ĀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄŲ
'   if cerror
'     messbox(" No Goods Received to check for"&suppname,0,0,1)
'     screen clear box 1 1 sch scw 0 0 no-border
'     return (1)
'   end if
order change index "supp_inv.idx"
x=records
message "total records:"&str(x)
  $suppinv = ""
  #invitems = 0
  #rem = 0
  while true
    StartTitle()
    ptval = NavRecSuppInv()
    if ptval = {Esc}
      screen clear box 1 1 sch scw 0 0 no-border
      repaint off
      return (-1)

    elseif ptval = {S} or ptval = {s}
      #totalinv = 0
      while true
        x = entryline(" Enter Supplier's Invoice Nr ",10,"","",21,5,72)
        if x = -1
          ns = 1
          exit while
        end if
        if len(ptstr)=0
          continue while
        end if
        $suppinv = upper(ptstr)
        exit while
      end while
      if ns = 1
        ns = 0
        continue while
      end if
      ns = 0

      while true
        x = entryline(" Total of Supplier's invoice (net of VAT) ",8,"","",21,5,72)
        if x = -1
          ns = 1
          exit while
        end if
        if len(ptstr)=0
          continue while
        end if
        #invtotal = value(ptstr)       'message "#invtotal) is:"&str(#invtotal)
        exit while
      end while
      if ns = 1
        ns = 0
        continue while
      end if
      ns = 0

      while true
        x = entryline(" Enter Nr of items on Invoice to check ",4,"","",21,5,72)
        if x = -1
          continue while
        end if
        if len(ptstr)=0
          continue while
        end if
        #invitems = value(ptstr)
        #rem = #invitems
        redimension #nritems[#invitems]
        #item = 0
        exit while
      end while
    else
      continue while
    end if
    x = ProcessInvoice()
  end while
END FUNCTION 'ShowCompleted()


FUNCTION ProcessInvoice()
  x = remove("inv_list.idx")
  if x = -1
  ' message "remove() failed"
  end if

  x = makeidx("gds_rcvd","inv_list.idx","0",1)
  if x = -1
  ' message "makeidx() failed"
  end if

  screen clear box 21 1 22 scw 0 0 no-border
  y3 = format("  > = Checked - {C}heck item - {F10} finish - {Esc} to restart","L72")
  screen print 21 5 fgp bgp y3
  ptval=0
  while true
    ptval = navrecs()
    if ptval = {C} or ptval = {c}
      if [Check] = ">"
        x = messline(" Already Checked!! ",0,0,1,21,5,72)
        screen clear box 21 1 22 scw 0 0 no-border
        y3 = format("  > = Checked - {C}heck item - {F10} finish - {Esc} to restart","L72")
        screen print 21 5 fgp bgp y3
        y4 = format("Items to be checked:"&str(#rem)&" - total of items so far"&currency(#totalinv),"M72")
        screen print 22 5 fgp bgp y4
        continue while
      end if
      #ordcost = [Total_Cost]
' message "record is:"&str(record)
'       x=delidxrec("supp_inv.idx",record,5)
' message "x) is:"&str(x)
      x = ProcessLineItem()
      $action = "Y"
      if x = 0
        Titles()
        y4 = format("Items to be checked:"&str(#rem)&" - total of items so far"&currency(#totalinv),"M72")
        screen print 22 5 fgp bgp y4
      elseif x = -1
        continue while
      end if

      elseif ptval = {F10}
' message "records) is:"&str(records)
        m1 = upper(mid(addmonths(date1(today),-1),3,4))|"˙"|right(addmonths(date1(today),-1),2)
        m2 = upper(mid(addmonths(date1(today),0),3,4))|"˙"|right(addmonths(date1(today),0),2)
        m3 = upper(mid(addmonths(date1(today),1),3,4))|"˙"|right(addmonths(date1(today),1),2)
        m4 = upper(mid(addmonths(date1(today),2),3,4))|"˙"|right(addmonths(date1(today),2),2)
        m5 = format("Select Due Month for Payment","M72")
        screen print 21 5 15 1 m5
        screen clear box 22 7 22 75 0 0 no-border
        x = reqnpopup(18,58,23,m1&m2&m3&m4,"",1,0,2,15,1)  'message "x is:"&str(x)
        if x = 0
          $paymth = ptstr
        end if
        x = messline(" Invoice nr"&$suppinv&"for"&currency(#invtotal)&"to be paid in"&$paymth|"? (y/n) ",1,1,1,21,5,72)
        if ptstr == "n"
          continue while
        end if
message "records is:"&str(records)
message "#nritems[1]) is:"&str(#nritems[1])
message "#nritems[2]) is:"&str(#nritems[2])
message "#nritems[3]) is:"&str(#nritems[3])
        repaint off
        order change index "inv_list.idx"
        #recs = records
        for i = 1 to #recs
          lock-record
            [Invoice_Cost] = #invcost
            [Invoice_Nr]  = $suppinv
            [DueDate]     = $paymth
            [Last_Update] = today
            [Updated_By]  = userid
          write-record
message "records is:"&str(records)
message "#nritems[i]) is:"&str(#nritems[i])
          x=delidxrec("supp_inv.idx",#nritems[i],5)
message "x) is:"&str(x)
          data goto record next
        end for
        order change index "supp_inv.idx"
' message "records) is:"&str(records)
        return (0)

      elseif ptval = {Esc}
'         if $action = "Y"
'           messbox(" Must complete current transaction first! ",0,0,1)
'           continue while
'         end if
message "Clear check mark from all supp_inv.idx items"
        screen clear box 1 1 sch scw 0 0 no-border
        repaint off
        return (-1)
      end if
    end while
END FUNCTION ' ProcessInvoice()


FUNCTION ProcessLineItem()
local m1 m2 m3 m4 m5 m6 r1 r2 c1 c2 cl1 cl2 lmsg c3 c4
  r1 = 3
  r2 = r1+2
  cl1 = 15
  cl2 = 12
  if #rem = 0
    messline(" ALL checked - {F10} to finish ",0,0,1,21,5,72)
    return (0)
  end if

  while true
    ordernr  = [Order_Nr]
    #ordcost = [Total_Cost]              ' message "#ordcost is:"&str(#ordcost)
    $comment_P = [Comments]

    case
      when (#ordcost<=#L_l)
        #margin = #M_l
      when ((#ordcost>#L_l) and (#ordcost<=#L_u))
        #margin = #M_m
      otherwise
        #margin = #M_h
    end case                           ' message "#margin is:"&str(#margin)

    if $comment_P = ""
      lmsg = len($comment_P)
      c3 = int((scw-lmsg)/2)+1
      c2 = c3 + lmsg + 1
      c1 = c3-2
      screen clear box r1 c1 r2 c2 cl1 cl2
      y1 = $comment_P
      screen print r1+1 c1+2 cl1 cl2 y1
    elseif $comment_P <> "None"
'     if $comment_P <> "None"
      lmsg = len($comment_P)
      c3 = int((scw-lmsg)/2)+1
      c2 = c3 + lmsg + 1
      c1 = c3-2
      screen clear box r1 c1 r2 c2 cl1 cl2
      y1 = $comment_P
      screen print r1+1 c1+2 cl1 cl2 y1
    end if

    x = entryline(" Enter invoiced cost (s.b."&currency(#ordcost)|")",8,"","",21,5,72)
    if x = -1
      y3 = format("  > = Checked - {C}heck/{R}emove item - {F10} finish - {Esc} quit","L72")
      screen print 21 5 fgp bgp y3
      return (-1)
    end if
    #invcost = value(ptstr)            'message "#invcost is:"&str(#invcost)

    if #invcost < (#ordcost-#margin)   'message "inv < ord"
      messline(" Price difference - re-enter invoice cost of"&currency(#invcost)|"? (y/n)",1,0,1,21,5,72)
      if ptstr == "n"
        prodSUPP = [Product_Supplier]
        ExceptlCost()
        vloadif(dpath|"suppinv1.vw")
      else
        continue while
      end if

    elseif #invcost > (#ordcost+#margin) 'message "inv > ord"
      messline(" Price difference - re-enter invoice cost of"&currency(#invcost)|"? (y/n)",1,0,1,21,5,72)
      if ptstr == "n"
        repaint off
        prodSUPP = [Product_Supplier]  ' message "prodSUPP is:"&str(prodSUPP)
        ExceptlCost()
        vloadif(dpath|"suppinv1.vw")
      else
        continue while
      end if
    end if

    lock-record
      [Check] = ">"
    write-record
#item = #item+1
message "#item is:"&str(#item)
message "record is:"&str(record)
#nritems[#item]=record
message "#nritems[#item]) is:"&str(#nritems[#item])
    x = addidxrec("inv_list.idx",precord,7)   ' add to temp index
' check o/s total of inv's to be
    #rem = #rem - 1                    'message "#invitems is:"&str(#invitems)
' show total of orders checked
    #totalinv = #totalinv + #invcost   'message "#totalinv!!! is:"&str(#totalinv)
    return (0)
  end while
END FUNCTION ' ProcessLineItem()


FUNCTION ExceptlCost()
' message "ExceptlCost()"
  cat = "PUR_INVC"
  mess = left(suppname,15)&left(prodsupp,15)&"diff. on invoice (is"&currency(#invcost)&"s.b."&currency(#ordcost)|")"
  x = exception(userid,today,time24,cat,mess)
END FUNCTION 'ExceptlCost()


FUNCTION RemoveCheck()
' to be re-written
  #invcost = [Invoice_Cost]
  lock-record
    [Check] = ""
'     [Invoice_Cost] = 0
  write-record
  x = delidxrec("inv_list.idx",record,2)
  #invitems = #invitems + 1            ' message "#invitems is:"&str(#invitems)
  #totalinv = #totalinv - #invcost     ' message "#totalinv is:"&str(#totalinv)
  return (0)
END FUNCTION 'RemoveCheck()


FUNCTION ReturnToMenu()
  screen clear box 1 1 sch scw 0 0 no-border
  repaint off
  error off
  window close
  file unload all
  transfer cpath|"pm_menu.psl" in-memory
END FUNCTION ' ReturnToMenu()


FUNCTION FindSupplier()
  vloadif(dpath|"supplier.vws")
  order change physical
  order sort now dictionary "suppname" fields "[Name]" ascending
  repaint off
  while true
    y = format(" Choose Supplier and press {Enter} ","M38")
    screen print 7 21 15 1 y
    screen print 20 21 15 1 (format(" {Enter} views orders - {Esc} exits ","M38"))
    if len(suppcode)=0
      x = bpopdb("supplier",6,"","[Name]","l35","[Supplier_Code]","L6","[Supplier_Code]",8,21,19,58,"",0)
    else
      x = bpopdb("supplier",6,"fp"&suppcode,"[Name]","l35","[Supplier_Code]","L6","[Supplier_Code]",8,21,19,58,"",0)
    end if
    if x = 0
      exit while
    elseif x = -1
      screen clear box 1 1 sch scw 0 0 no-border
      return (-1)
    end if
  end while

  suppcode = ptstr
  suppname = [Name]
  screen clear box 1 1 sch scw 0 0 no-border
  repaint off
  progress(15,10," Finding Orders from"&suppname|" ",0)
  return (0)
END FUNCTION 'FindSupplier()


FUNCTION Titles()
  repaint on
  repaint
  y1 = format("Completed deliveries from"&suppname,"M70")
  y2 = format("   Order Nr  Description                     Del'd     Length    Cost ","L72")
  y3 = format("  > = Checked  -  {C}heck item  -  {F10} finishes  -  {Esc} restart","L72")
  screen clear box 3 5 5 76 fgp bgp
  screen print 4 6 fgp bgp y1
  screen print 6 5 fgp bgp y2
  screen print 21 5 fgp bgp y3
END FUNCTION ' Titles()


FUNCTION StartTitle()
  repaint on
  repaint
  y1 = format("Completed deliveries from"&suppname,"M70")
  y2 = format("   Order Nr  Description                     Del'd     Length    Cost ","L72")
  y3 = format(" "|chr(24)&chr(25)&"to scroll   -   {S}tart   -   {Esc} restarts ","M72")
  screen clear box 3 5 5 76 fgp bgp
  screen print 4 6 fgp bgp y1
  screen print 6 5 fgp bgp y2
  screen print 21 5 fgp bgp y3
END FUNCTION ' StartTitle()


FUNCTION NavRecSuppInv()
local x bot psmode
  screen save scrheight 1 scrheight scrwidth bot
  smartpeek $_spndmes psmode
  if psmode = 1
    smartpoke $_spndmes 0
  end if
  PopComm()
  while TRUE
    x = inchar
    if x = {Down}
      screen shortrestore S_hdr
      data goto record next
      PopComm()
    elseif x = {Up}
      screen shortrestore S_hdr
      data goto record previous
      PopComm()
    elseif x = {PgDn}
      screen shortrestore S_hdr
      data goto page next
      PopComm()
    elseif x = {PgUp}
      screen shortrestore S_hdr
      data goto page previous
      PopComm()
    elseif x = {^End}
      screen shortrestore S_hdr
      data goto record last
      PopComm()
    elseif x = {^Home}
      screen shortrestore S_hdr
      data goto record first
      PopComm()
    elseif x = {Home}
      screen shortrestore S_hdr
      suspendone
      keys Home,F8
      PopComm()
      screen shortrestore bot
    elseif x = {End}
      screen shortrestore S_hdr
      suspendone
      keys End,F8
      PopComm()
      screen shortrestore bot
    else
      exit while
    end if
  end while
  if psmode = 1
    smartpoke $_spndmes 1
  end if
  return (x)
END FUNCTION ' NavRecSuppInv()


FUNCTION PopComm()
  error off
  if [Status] = "A"
    cl2 = 10
    if len([Comments]) <> 0
      y1 = " "|[Comments]
      c1 = 40-(len(y1)/2)-1
      c2 = c1+(len(y1))+2
      screen save r1 c1 r2 c2 S_hdr
      screen clear box r1 c1 r2 c2 cl1 cl2
      screen print r1+1 c1+1 cl1 cl2 y1
    end if
  else
    cl2 = 12
    if len([Comments]) <> 0
      y1 = " REJECTED -"&[Comments]
      c1 = 40-(len(y1)/2)
      c2 = c1+(len(y1))+2
      screen save r1 c1 r2 c2 S_hdr
      screen clear box r1 c1 r2 c2 cl1 cl2
      screen print r1+1 c1+1 cl1 cl2 y1
    end if
  end if
END FUNCTION ' PopComm()


function delidxrec(ipidx,recnum,fnum)
local bpos epos temp r blk rlen tpos vsize
  r = openidx(ipidx,fnum)
  if r = 0
    if totidxrecs(fnum) = 0
      if recnum <= ptval and ptval > 0 and recnum > 0
        error off
        clearerror
        fseek fnum ((ihlen)+(ptval*4))
        fposition fnum into epos
        fseek fnum (ihlen+(recnum*4))
        fposition fnum into bpos
        vsize = epos-bpos
        if memleft >= vsize + 2048
          fseek fnum bpos
          fread fnum binary (vsize) into temp
          fseek fnum bpos-4
          fwrite fnum binary varlength(temp) from temp
        else
          clearerror
          blk = ptval
          rlen = 0
          while blk > memleft+2048
            blk = blk/4
          end while
          while rlen < vsize
            tpos = bpos
            fseek fnum bpos
            fread fnum binary blk into temp
            fposition fnum into tpos
            fseek fnum bpos-4
            fwrite fnum binary varlength(temp) from temp
            bpos = tpos
            rlen = rlen+blk
            if blk < (vsize - rlen)
              blk = vsize - rlen
            end if
          end while
        end if
        fseek fnum 0
        wrtidxval(ptval-1,fnum)
        fseek fnum epos-4
        wrtidxpad(fnum)
        closeidx(fnum)
        error on
        if lerror <> 0
          r = -4
        end if
      else
        closeidx(fnum)
        r = -3
      end if
    else
      r = -2
    end if
  else
    r = -1
  end if
  return (r)
end function  'delidxrec()


'    openidx is passed the path/name (without .idx) and desired handle number
'    of the target index.  It appends ".idx" to the pathname, then attempts
'    to open.  failure returns cerror | general type of failure.
function openidx(ipidx,fnum)
local f r
     r = 0
     f = chkiext(ipidx)
     if f > null
          error off
          clearerror
          fopen f as fnum
          if lerror <> 0
               r = -2
          end if
          error on
     else
          r = -1
     end if
return (r)
end function


'    closeidx simply closes the file handle number and returns cerror

function closeidx(fnum)
local r
     r = 0
     error off
     clearerror
     fclose fnum
     if lerror <> 0
          r = -1
     end if
     error on
return (r)
end function


'    totidxrecs uses the getidxval function to read the number of current records

function totidxrecs(fnum)
local r
     r = 0
     error off
     clearerror
     fseek fnum 0
     if lerror <> 0
          r = -1
     else
          if getidxval(fnum) <> 0
               r = -2
          end if
     end if
     error on
return (r)
end function


'    getidxval reads the four byte integer at the passed byte position, then
'    returns the actual integer value that is written there.

function getidxval(fnum)
   local r bp
   r = 0
   ptval = blank
   clearerror
   fread fnum binary 4 into bp
   if lerror = 0
        ptval = int(bp[1]+((bp[2]*256)+(bp[3]*65536)+(bp[4]*16777216)))
   else
        r = -1
   end if
   return(r)
end function


'    wrtidxval will write the passed value as a four byte integer at the current
'    file position

function wrtidxval(val,fnum)
local bp1 bp2 bp3 bp4 r
   r = 0
   bp4 = chr(int(val / 16777216))
   bp3 = chr(int(val / 65536))
   bp2 = chr(int(val / 256))
   bp1 = chr(int(val - ((bp2 * 256)+(bp3 * 65536)+(bp4 * 16777216))))
   clearerror
   fwrite fnum length 1 from bp1
   fwrite fnum length 1 from bp2
   fwrite fnum length 1 from bp3
   fwrite fnum length 1 from bp4
   if lerror <> 0
     r = -1
   end if
return (r)
end function


'    addidxrec will append the passed precord number to the indicated index,

function addidxrec(ipidx,prec,fnum)
local r sprec pr i j
     r = openidx(ipidx,fnum)
     if r = 0
          if totidxrecs(fnum) = 0
               sprec = str(prec)
               i = 1
               j = 0
               error off
               clearerror
               fseek fnum (ihlen+(ptval*4))
               while true
                    pr = group(sprec,i)
                    if pr = null
                         exit while
                    end if
                    pr = val(pr)
                    if pr > 0
                         wrtidxval(pr,fnum)
                         j = j + 1
                    end if
                    i = i + 1
               end while
               wrtidxpad(fnum)
               fseek fnum 0
               wrtidxval(ptval+j,fnum)
               closeidx(fnum)
               if lerror <> 0
                    r = -3
               end if
               error on
          else
               r = -2
          end if
     else
          r = -1
     end if
return (r)
end function



'    makeidx creates an index.  if desired, passing makeidx a precord of 0
'    preps the newly created index for addidxrec.  otherwise, a one record
'    index will be created, containing the record having the passed precord.

function makeidx(fname,idx,prec,fnum)
local c f r i j sprec pr
     r = 0
     f = chkiext(idx)
     if file(idx) = 1
          return (-4)
     end if
     if f > null
          error off
          clearerror
          if openidx(idx,fnum) < 0
               r = -2
          else
               if wrtidxhdr(fname,0,fnum) < 0
                    closeidx(fnum)
                    r = -2
               else
                    if prec = null
                         if wrtidxpad(fnum) < 0
                              closeidx(fnum)
                              r = -2
                         end if
                    else
                         closeidx(fnum)
                         if addidxrec(idx,prec,fnum) < 0
                              r = -3
                         end if
                    end if
               end if
          end if
          error on
     else
          r = -1
     end if
return (r)
end function


'    wrtidxstr is used to write blocks of data to an index header, where nulls
'    are required after the info, in order to maintain the index header
'    structure

function wrtidxstr(ilim,strn,fnum)
local i rc
   for i = 1  to ilim
      if i > len(strn)
          fwrite fnum length 1 from chr(0)
      else
          rc = asc(mid(strn,i,1))
          fwrite fnum length 1 from chr(rc)
      end if
   end for
end function


'    (nullvar) writes blocks of nulls to an index as required by chkblock

function wrtidxpad(fnum)
local x c n memsize mem nullblk
fposition fnum into n
nullblk=512-mod(n,512)
if nullblk > 0
     memsize = 50
     n = 0x00
     if nullblk > 75
          buffer mem size memsize
          for x = 1 to memsize
               pack mem[x] "C" n
          end for
          while nullblk >= memsize
               fwrite fnum binary varlength(mem) from mem
               nullblk=nullblk-memsize
          end while
     end if
     for x = 1 to nullblk step 1
         fwrite fnum binary 1 from mem[1]
     end for
end if
end function


function getidxrecs(idx,f#)
local r
     error off
     clearerror
     r = openidx(idx,f#)
     error on
     if r = 0
          if totidxrecs(f#) <> 0
               r = -2
          end if
          error off
          closeidx(f#)
          error on
     else
          r = -1
     end if
return (r)
end function  ' getidxrecs


function nxtidxpos(f#)
local r iend
     r = 0
     if totidxrecs(f#) = 0
          iend = ptval * 4
          error off
          clearerror
          fseek f# (ihlen+iend)
          error on
          if lerror <> 0
               r = -2
          end if
     else
          r = -1
     end if
return (r)
end function
'changes index record number of an already opened index file

function wrtidxtot(recs,f#)
local r
     r = 0
     if totidxrecs(f#) = 0
          error off
          clearerror
          fseek f# 0
          wrtidxval(ptval+recs,f#)
          error on
          if lerror <> 0
               r = -2
          else
               ptval = ptval + recs
          end if
     else
          r = -1
     end if
return (r)
end function


'writes an index header record to an already opened index file

function wrtidxhdr(fname,p,fnum)
local c pos r
r = 0
error off
clearerror
fposition fnum into pos
if lerror = 0
     clearerror
     if pos = 0
          wrtidxval(p,fnum)
          wrtidxstr(15,fname,fnum)
          wrtidxstr(9,"querynow",fnum)
          wrtidxstr(36,today,fnum)
          if lerror <> 0
               r = -3
          end if
     else
          r = -2
     end if
else
     r = -1
end if
return (r)
end function




function chkiext(f)
local ext lext rext c err
err = 0
if f > null
     rext = right(f,4)
     if rext ! "."
          lext = "db doc key vw vws ws dfr dfw dfs dfq dfx aif exe com bat psl "
          ext = mid(rext,find(".",rext,0)+2)|chr(32)
          if lext ! ext
               f = null
          end if
     else
          f = f|".idx"
     end if
else
     f = null
end if
return (f)
end function


function idxappend(midx,mf#,aidx,af#,dfname)
local o r rt df f i pb

' returns
'    success =  0
'               ptval = total records
'    failure = -1 bad parameter
'              -2 unable to open named index file
'              -3 "main.idx" listed in the append index list
'              -4 error reading/writing named index
'              -5 data file name in append index does not match main
'              -6 named file does not exist

'regarding error returns
     '    ptstr will contain a narrative description of the exact error

'parameters
'midx     =    main index file <path>name
'mf#      =    int 1-20 for opening main index file for read/write
'aidx     =    "append" index file <path>name (string group)
'dfname   =    if a SmartWare II data file name is here, a new index
'              will be created (if it does not already exist)
'locals
'o        =    store whether main file exists
'r        =    temporary storage of index precords total
'ot       =    original index file total of precords
'rt       =    running total of number of index precords
'df       =    main data file name as read from main index (verification)
'f        =    temporary name for "append index" file read
'i        =    counter to step through the "append list" string group
'pb       =    binary read buffer for storage of "precords" table

'do the standard function setup

ptstr = NULL
r = 0
rt = 0

     '1.  see if the midx exists

o = file(midx)

if (mf#<1 or mf#>20)
     ptstr = "Main index file handle# ("&str(mf#)&") out of range"
     return (-1)
end if

if (af#<1 or af#>20)
     ptstr = "Append index file handle# ("&str(mf#)&") out of range"
     return (-1)
end if

if af# = mf#
     ptstr = "Main and append index file handles (" & str(mf#) & ") are the same"
     return (-1)
end if

if not(o) and ( (len(dfname)>8) or (len(dfname)=0) )
     ptstr = "Needed data file name bad, or does not exist"
     return (-1)
end if


     '2.  check parameters and prepare main index file
     '    if it exists already, verify the main data file name
     '         get the total number of existing precords
     '         store the record total for a running total
     '         seek to the byte position after the last precord
     '    else
     '         open a new index and write the header

if openidx(midx,mf#) < 0
          ptstr = "Unable to open named main index file"
          return (-2)
end if
if o
     if getidxval(mf#) = 0
          r = ptval
          error off
          clearerror
          fread mf# length 9 into dfname
          fseek mf# ihlen + (r*4)
          error on
          if lerror
               ptstr = "Error reading main index data file name"
               return (-4)
          end if
     else
          ptstr = "Error reading main index total precords"
          return (-4)
     end if
else
     if wrtidxhdr(dfname,0,mf#) < 0
          ptstr = "Error writing main index file header"
          return (-4)
     else
          rt = 0
     end if
end if


'3   while there are items in the string group "aidx"

'         open the aidx, if the file exists
'         get total precords
'         verify the main data file name
'              if good
'                   fseek 64 (ihlen), then read length (precs * 4) into buffer
'                   write the buffer to main index
'              else
'                   store the error description in ptstr and return
'
i = 1
while TRUE
     f = group(aidx,i)
     if exact(f,NULL)
          exit while
     end if
     if not(file(f))
          ptstr = "Append index file name" & f & "does not exist"
          return (-6)
     end if
     if openidx(f,af#) < 0
          ptstr = "Unable to open append index file" & f
          return (-2)
     end if
     if getidxval(af#) = 0
          r = ptval
          error off
          clearerror
          fread af# length 9 into df
          if trim(df) == dfname
               fseek af# ihlen
               if r > 0
                    fread af# binary (r*4) into pb
                    if cerror = 0
                         fwrite mf# binary varlength(pb) from pb
                         if cerror = 0
                              rt = rt + r
                         end if
                    end if
               end if
               error on
               if lerror
                    ptstr = "Error reading named append index file" & f
                    closeidx(mf#)
                    closeidx(af#)
                    return (-4)
               end if
          else
               ptstr = "Data file name mismatch:" & dfname & df & "in" & f
               closeidx(mf#)
               closeidx(af#)
               return (-5)
          end if
     else
          ptstr = "Error reading append index file" & f
          closeidx(mf#)
          closeidx(af#)
          return (-4)
end if
closeidx(af#)
i=i+1
end while

closeidx(af#)
wrtidxtot(rt,mf#)
closeidx(mf#)
return (0)
end function 'idxappend()