Piper's Pit BBS/FTP: ibm 0020 - 0029/ibm0020-0029/ibm0028.tar/ibm0028/SBTAR4.ZIP/ARPOSC.PRG

Text File | 1990-07-23 | 9.8 KB | 334 lines

********************** ' MultiNet Source Code ' ***********************
** '                       SBT Corporation                         ' **
** '         One Harbor Drive, Sausalito, California 94965         ' **
** '                   Telephone [phone]                    ' **
***********************************************************************
** '   (c) Copyright 1984, Revisions 1985 - 1990 SBT Corporation   ' **
** '            All Rights Reserved by SBT Corporation             ' **
** '                                                               ' **
***********************************************************************
** ' 07/23/90 = Last Update  **  ARPOSC.PRG   **   Version 6.35.02 ' **
***********************************************************************
* ' Enter a Credit Memo for Sales Tax only - called by ARPOST
* '                                          calls ARPOSA and SYSWCOM
*
* ' Files in Use: Area a - ARCUSTnn.DBF index ARCUSTnn.NDX
* '                    b - ARINVTnn.DBF index ARINVTnn.NDX
* '                    c - Temporary file, stru = ARTRANnn (temp1)
* '                    d - ARGLACnn.DBF index ARGLACnn.NDX if linked
*
* ' The following variables are defined in ARPOST:
*
* ' totarecv totinv totminv totcash tottax minvdte mupdated mcreated
* ' mcust mcompany mscompany maddr1 msaddr1 maddr2 msaddr2 maddr3 msaddr3
* ' idisc iglarec ipdisc ipdays ipnet iterr itaxrate mckno
* ' ishipvia ifob iponum ipterms iornum iordate isalesmn itosw
*
STORE '_CREDT_MEMO_TAX' TO mitem
STORE 'Credit Memo for Tax Only' TO mdescrip
STORE a->tax TO mrate
STORE 0.00 TO mgross, mtax
STORE iglarec TO iglsale
CLEAR
@ 1,1 SAY DTOC(m0date)
@ 1,40 - INT(LEN(mhead)/2) SAY mhead
@ 1,73 SAY SUBSTR(m0company,79,6)
@ 2,1 SAY SUBSTR(m0company,1,78)
@ 4,1 SAY 'Customer Number / Name ' + SUBSTR(m0border,183,4) + mcust + ;
' / ' + TRIM(mcompany)
@ 7,1 SAY 'Amount to base credit on  ' + SUBSTR(m0border,182,4)
@ 9,1 SAY 'Tax Rate                  ' + SUBSTR(m0border,182,4)
@ 9,44 SAY '%'
@ 11,1 SAY 'Sales Tax Credit Amount   ' + SUBSTR(m0border,182,4)
DO WHILE .t.
  @ 11,31 GET mtax PICTURE '#######.##'
  @ 22,0
  @ 22,1 SAY 'Enter the Tax Amount or leave 0.00 to calculate...'
  IF SUBSTR(m0link,1,1) = 'Y'
    @ 13,1 SAY 'GL Sales Link Code        ' + SUBSTR(m0border,182,4)
    @ 13,31 GET iglsale PICTURE '!!!'
  ENDIF
  READ
  @ 22,0
  CLEAR GETS
  IF mtax = 0.00
    @ 22,1 SAY 'Enter the Taxable Total and Tax Rate...'
    @ 7,31 GET mgross PICTURE '#######.##'
    @ 9,35 GET mrate PICTURE '###.###'
    READ
    @ 21,0 CLEAR
    STORE f0extlin(mgross, mrate, 99) TO mtax
    @ 11,31 SAY mtax PICTURE '#######.##'
  ENDIF && mtax = 0.00
  CLEAR GETS
  STORE 'S' TO mans
  @ 22,0 CLEAR
  @ 22,1 SAY 'Enter Choice (Save/Edit/Cancel) ' + ;
  SUBSTR(m0border,180,7) GET mans PICTURE '!'
  READ SAVE
  DO WHILE .NOT. mans $ 'SEC'
    ?? CHR(7)
    READ SAVE
  ENDDO
  @ 22,0
  CLEAR GETS
  IF mans = 'E'
    LOOP
  ENDIF
  IF mans = 'C'
    RETURN
  ENDIF
  IF mtax <= 0.00
    ?? CHR(7)
    @ 21,1 SAY 'Credit memo total tax amount must be greater than 0.00.'
    LOOP
  ENDIF
  @ 22,0
  CLEAR GETS
  IF SUBSTR(m0link,1,1) = 'Y'
    SELECT d
    SET INDEX TO &m0glacf..ndx
    STORE .t. TO mok
    DO WHILE mok
      SEEK iglsale
      IF .NOT. EOF()
        EXIT
      ENDIF
      ?? CHR(7)
*\ ARPOSC02 01 07/23/90 KH Field Overwrites Field direction arrow.
      @ 13,31 GET iglsale PICTURE '!!!'
      @ 22,1 SAY 'Invalid Ledger linking code. Reenter or ' + ;
      'blanks to cancel...'
      READ
      @ 22,0
      IF iglsale = '   '
        STORE .f. TO mok
      ENDIF
    ENDDO
    CLEAR GETS
    IF .NOT. mok
      LOOP
    ENDIF
    @ 22,0
  ENDIF && SUBSTR(m0link,1,1) = 'Y'
  EXIT
ENDDO && WHILE .t.
STORE a->company TO mcompany
STORE .t. TO mupdated, mcreated
SET ESCAPE OFF
SELECT f
USE &m0sysdr.sysdata
LOCATE FOR UPPER(sysid) = m0pgmid + SUBSTR(m0comp,1,2)
DO p0rlockn
STORE IIF(int1 + 1 < 100000000, STR(int1 + 1,8,0), STR(1,8,0)) TO minvno
@ 22,0 CLEAR
SELECT a
USE &m0armastf INDEX &m0armastf..ndx
SEEK minvno
IF mincr = 'Y'
  @ 22,0 CLEAR
  SELECT a
  DO WHILE .t.
    UNLOCK ALL
    STORE SUBSTR(LTRIM(minvno) + SPACE(8),1,8) TO minvno
    @ 22,0 SAY 'Enter Credit Memo Number ' + SUBSTR(m0border,182,5) ;
    GET minvno PICTURE '########'
    READ
    @ 22,0 CLEAR
    IF VAL(minvno) <= 0
      LOOP
    ENDIF
    STORE STR(VAL(minvno),8,0) TO minvno
    DO p0flockn
    SEEK minvno
    IF .NOT. EOF()
      ?? CHR(7)
      @ 23,0 SAY '*****  Number ' + LTRIM(minvno) + ;
      ' already in use.  *****'
    ELSE
      EXIT
    ENDIF
  ENDDO && WHILE .t.
  SELECT f
  DO p0rlockn
ELSE
  @ 22,0
  SELECT a
  SEEK minvno
  DO WHILE .NOT. EOF()
    @ 22,0 SAY '*****  Number ' + LTRIM(minvno) + ;
    ' found. Searching for Unused Number.  *****'
    SELECT f
    IF int1 + 1 = VAL(minvno) .OR. (int1 = 99999999 .AND. VAL(minvno) = 1)
      REPLACE int1 WITH VAL(minvno)
    ENDIF
    STORE IIF(int1 + 1 < 100000000, STR(int1 + 1,8,0), STR(1,8,0)) ;
    TO minvno
    SELECT a
    SEEK minvno
  ENDDO
ENDIF && mincr = 'Y'
SELECT f
*\ ARPOSC01 02 06/18/90 AV Tax only CMs do not affect PTD billings
REPLACE int1 WITH VAL(minvno), num1 WITH num1 - mtax, ;
num7 WITH num7 - mtax
STORE SUBSTR(STR(1000 + VAL(SUBSTR(link,37,3)),4,0),2,3) TO mbatch
USE
STORE tottax - mtax TO tottax
SELECT b
@ 22,0
@ 22,1 SAY '*****  Credit Memo ' + LTRIM(minvno) + ;
', Updating Inventory File  *****'
SEEK mitem
IF EOF()
  DO p0flockn
  APPEND BLANK
  REPLACE item WITH mitem, descrip WITH mdescrip, decnum WITH 0, ;
  gllink WITH m0deflink, stkcode WITH 'N', taxcode WITH 'N'
  UNLOCK
ENDIF
DO p0rlockn
REPLACE ldate WITH minvdte, ptdqty WITH ptdqty + 1, ytdqty WITH ytdqty + 1, ;
ptdsls WITH ptdsls - mtax, ytdsls WITH ytdsls - mtax
UNLOCK
@ 22,0
@ 22,1 SAY '*****  Credit Memo ' + LTRIM(minvno) + ;
', Updating Invoice Transaction File  *****'
SELECT a
USE
SELECT c
USE &m0artranf INDEX &m0artranf..ndx, &m0artracf..ndx, &m0artraif..ndx, ;
&m0artradf..ndx
DO p0flockn
APPEND BLANK
REPLACE invno WITH minvno, custno WITH mcust, item WITH mitem, descrip WITH ;
mdescrip, qtyord WITH 1.0, qtyshp WITH 1.0, terr WITH iterr, invdte WITH ;
minvdte, ponum WITH iponum, salesmn WITH isalesmn, glsale WITH iglsale
REPLACE glasst WITH iglsale, extprice WITH 0.00 - mtax, ;
class WITH b->class, batch WITH mbatch, taxable WITH 'Y', artype WITH 'T', ;
taxrate WITH mrate, taxdist WITH idist
USE
SELECT b
USE
SELECT a
@ 22,0
@ 22,1 SAY '*****  Credit Memo ' + LTRIM(minvno) + ;
', Updating Invoice Master File  *****'
USE &m0armastf INDEX &m0armastf..ndx, &m0armascf..ndx, &m0armasdf..ndx
DO p0flockn
APPEND BLANK
REPLACE invno WITH minvno, invdte WITH minvdte, custno WITH mcust, ;
salesmn WITH isalesmn, ponum WITH iponum, taxrate WITH mrate, shipvia WITH ;
ishipvia, fob WITH ifob, ordate WITH iordate, taxdist WITH idist
REPLACE ornum WITH iornum, tosw WITH itosw, pterms WITH ipterms, pdisc WITH ;
ipdisc, pdays WITH ipdays, pnet WITH ipnet, glarec WITH iglarec, refno WITH ;
mckno, refno WITH 'CR. MEMO', artype WITH 'T'
REPLACE tax WITH 0 - mtax, invamt WITH 0 - mtax, balance WITH 0 - mtax, ;
batch WITH mbatch
UNLOCK
@ 22,0
IF itosw <> ' '
  @ 22,1 SAY '*****  Credit Memo ' + LTRIM(minvno) + ;
  ', Updating Shipping Address File  *****'
  USE &m0araddrf INDEX &m0araddrf..ndx
  DO p0flockn
  APPEND BLANK
  REPLACE custno WITH mcust, invno WITH minvno, company WITH mscompany, ;
  address1 WITH msaddr1, address2 WITH msaddr2, address3 WITH msaddr3
  UNLOCK
ENDIF
SELECT a
@ 22,0
@ 22,1 SAY '*****  Credit Memo ' + LTRIM(minvno) + ;
', Updating Customer File  *****'
USE &m0custf INDEX &m0custf..ndx
SEEK mcust
DO p0rlockn
STORE 0.00 TO tcash, tarecv
STORE 0 - mtax TO tarecv
STORE totarecv - mtax TO totarecv
REPLACE credit WITH credit + mtax, balance WITH balance - mtax, ;
ptdsls WITH ptdsls - mtax, ytdsls WITH ytdsls - mtax
IF m0ldate
  REPLACE ldate WITH minvdte, lsale WITH 0 - mtax
ENDIF
UNLOCK
SELECT f
IF SUBSTR(m0link,1,1) = 'Y'
  @ 22,0
  @ 22,1 SAY '*****  Credit Memo ' + LTRIM(minvno) + ;
  ', Updating General Ledger Linking File  *****'
  USE &m0gllkf INDEX &m0gllkf..ndx
  DO p0flockn
  SELECT d
  SET INDEX TO &m0glacf..ndx
  DO p0flockn
  SEEK iglarec
  IF activity <> 'Y'
    REPLACE activity WITH 'Y'
  ENDIF
  SELECT f
  IF tcash <> 0.00
    STORE d->cashr TO mact
    SEEK mact
    IF EOF()
      APPEND BLANK
      REPLACE account WITH mact
    ENDIF
    REPLACE amount WITH amount + tcash
  ENDIF
  IF tarecv <> 0.00
    STORE d->arecv TO mact
    SEEK mact
    IF EOF()
      APPEND BLANK
      REPLACE account WITH mact
    ENDIF
    REPLACE amount WITH amount + tarecv
  ENDIF
  SELECT d
  SEEK iglsale
  IF activity <> 'Y'
    REPLACE activity WITH 'Y'
  ENDIF
  SELECT f
  STORE d->liabt TO mact
  SEEK mact
  IF EOF()
    APPEND BLANK
    REPLACE account WITH mact
  ENDIF
  REPLACE amount WITH amount + mtax
ENDIF && SUBSTR(m0link,1,1) = 'Y'
CLOSE DATABASES
SET ESCAPE ON
STORE mtax TO minvamt
@ 20,0 CLEAR
IF mwcom = 'Y'
  STORE ' ' TO mans
  CLEAR GETS
  @ 22,1 SAY 'Do you want to write a Comment on Credit Memo ' + ;
  LTRIM(minvno) + ' ? (Y/N) ' + SUBSTR(m0border,180,7) GET mans PICTURE 'Y'
  READ
  @ 22,0
  IF mans = 'Y'
    @ 22,1 SAY '*****  Preparing to write Comment on Credit Memo ' + ;
    LTRIM(minvno) + '  *****'
    CLOSE DATABASES
    DO syswcom
  ENDIF
ENDIF
* ' Call Apply Credit Memo program
DO arposa
@ 22,0 CLEAR
@ 22,1 SAY '*****  Setting up files for next entry  *****'
STORE .t. TO merase, mupdated
RETURN
*
* ' $Revision:   1.22  $
* ' $Date:   23 Jul 1990 15:28:04  $
*********************
** ' ARPOSC.PRG  ' **
** ' 332 Lines   ' **
*********************