SUBROUTINE Z980CATRA.S
* Copyright (c) 1986-2020 Advanced Data Business Systems, unpublished. All rights reserved.
* ADJUSTMENT TRANSACTION DEU SUBROUTINE
* CATALOG
* TWG 10/07/92
GOSUB 99999
INCLUDE INC.BP 999ADSCS1
INCLUDE INC.BP 999ADSDEUCV
*
** EQUATES
*
*
EQU F.CATR TO FILES(11), F.CATRD TO FILES(12), F.CATRC TO FILES(13)
EQU F.CATAB TO FILES(15), F.CACHD TO FILES(16), F.CATRHD TO FILES(17), F.CACUST TO FILES(18)
EQU F.CABTCH TO FILES(24), F.CAFUND TO FILES(27)
*
EQU CACUST TO PC(3)
** EQUATE CATR FILE
EQU CATR$CLM TO D(2), CATR$CUST TO D(3)
EQU CATR$PERN TO D(5), CATR$BTCH TO D(6), CATR$PS TO D(7), CATR$ERR TO D(8)
EQU CATR$UPDT TO D(9), CATR$WRK1 TO D(10), CATR$WRK2 TO D(11), CATR$TYPE TO D(12)
...
EQU CATR$APPAMT TO D(61), CATR$DENAMT TO D(62), CATR$RESAMT TO D(63)
EQU CATR$DENCD TO D(74), CATR$DENTEXT TO D(75)
EQU CATR$ICMNT TO D(78), CATR$ECMNT TO D(79)
...
ON TYPPR GOTO 100, 200, 300, 400, 500, 600, 700, 800, 900
100 ** AT PROGRAM ENTRY (E)
! READ IN THE PERIOD NUMBER
READ P(2) FROM F.CATAB, PCONT$COCD:'AOPT' ELSE P(2) =''
CATAB$CPERN.AOPT = P(2)<10>
IF CATAB$CPERN.AOPT EQ '' THEN PRINT 'CURRENT PERIOD NUMBER NOT SET'; STOP
READ P(5) FROM F.CATAB, PCONT$COCD:'GRPD' ELSE P(5) =''
199 RETURN
200 ** BEFORE INPUT PROCESSING (B)
BEGIN CASE
CASE ATTR EQ 0; * ID.CATR
ID = ID 'R(%6)'; IDF = ID
END CASE
299 RETURN
300 ** COMPUTATION SUBROUTINE (=)
399 RETURN
400 ** AFTER INPUT SUBROUTINE (A)
BEGIN CASE
CASE ATTR EQ 0; * ID.CATR
IF NOT(NFLAG) THEN
READ CACUST FROM F.CACUST, CATR$CUST ELSE ERRM = 'CUSTOMER ITEM NOT FOUND'; BEFLAG =1; GOTO 499
END
IF CATR$TYPE EQ '' THEN CATR$TYPE = P(1)<1,1>
IF CATR$TYPE NE P(1)<1,1> THEN ERRM = 'TRAN TYPE MUST BE A ': P(1)<1,1>: ' TO USE THIS SCREEN'; BEFLAG =1; GOTO 499
IF CATR$PS GE 16 THEN ERRM = 'TRANSACTION MAY NOT BE ENTERED AGAINST AFTER THE UPDATE'; BEFLAG =1; GOTO 499
! SAVE THE ORIGINAL AMOUNTS IN CASE THEY CHANGE
FOR LCNT = 2 TO 21
PC(1)<LCNT> = D(LCNT +50)
NEXT LCNT
IF CATR$PRTY EQ '' THEN CATR$PRTY =1
CASE ATTR EQ 3; * CATR$CUST
...
600 ** FILE PROCESSING (F)
IF TYPPR NE 6 THEN RETURN
IF CATR$PERN EQ '' THEN CATAB$CPERN.AOPT = P(2)<10>; CATR$PERN = CATAB$CPERN.AOPT
IF CATR$BTCH EQ '' THEN
IF P(4) EQ '' THEN
READVU BTCH FROM F.CATAB, 'CATR.NID', 3 ELSE BTCH =1
LOOP
PRINT @(0,23): TT$CEL: 'THE NEXT BATCH NUMBER IS ': BTCH: '. ENTER THIS OR A PREVIOUS BATCH NUMBER ':
INPUT NBTCH:
UNTIL NBTCH NE '' AND NBTCH MATCH '0N' AND NBTCH LE BTCH DO REPEAT
IF NBTCH EQ BTCH THEN WRITEV BTCH +1 ON F.CATAB, 'CATR.NID', 3 ELSE RELEASE F.CATAB, 'CATR.NID'
P(4) = NBTCH
END
CATR$BTCH = P(4)
END
! UPDATE THE AMOUNTS IN THE CATRHD FILE
...
! NO ERRORS ALLOWED AFTER THIS
IF NFLAG THEN
READVU ID FROM F.CATAB, 'CATR.NID', 2 ELSE ID =1
FFLAG =1
LOOP
ID = ID 'R(%6)'
READV TEMP FROM F.CATR, ID, 1 ELSE READV TEMP FROM F.CATRD, ID, 1 ELSE READV TEMP FROM F.CATRC, ID, 1 ELSE FFLAG =0
UNTIL NOT(FFLAG) DO ID = ID +1 REPEAT
IDF = ID; CATR$ASSTR = ID; ID = ID +1
WRITEV ID ON F.CATAB, 'CATR.NID', 2
...
899 RETURN
900 ** COMPLETION PROCESSING (X)
999 RETURN
99999 PROG = 'CA.BP 980CATRA.S 01-06-95 01:49PM JUST 011 TWG 11012 243'; RETURN
END