Trailing-Edge
-
PDP-10 Archives
-
tops20tools_v6_9-jan-86_dumper
-
tools/cbldoc1/accnum.cob
There are 5 other files named accnum.cob in the archive. Click here to see a list.
IDENTIFICATION DIVISION.
PROGRAM-ID . ACCNUM.
AUTHOR. D. VISSER.
DATE-WRITTEN. 05-May-83.
DATE-COMPILED.
************************************************************************
*****
***** PROGRAM NAME: ACCNUM
*****
***** PURPOSE:
***** Transfer and validate the, assumed numeric, input
***** ( which will be alfanumeric, left justified ) into
***** a numeric field, right justified.
*****
***** NOTES:
***** VAX-11 COBOL accepts as alfanumeric-fields,
***** left-justified, regardless of the picture specified
***** for the receiving field ( accept actually overwrites
***** this picture). No error will occur displaying
***** the receiving field ( which is now alfanumeric ),
***** but invalid data is transfered when moved into
***** another numeric- or numeric-edited field.
*****
***** Parameters to be passed on to this subroutine and will
***** be handed back are (in this order to be passed on) :
*****
***** WK-ALFANUMERIC : 18 characters alfanumeric, containing
***** the input to be transfered.
***** WK-NUMERIC : 13 digits and 5 decimals numeric,
***** containing the return value.
***** WK-ERRORFLAG : 1 character alfanumeric containing
***** the return-status (error-indicator).
***** This field can contain :
*****
***** " " : successfull transfer.
***** "1" : too many delimeters specified.
***** "2" : use either ',' or '.', not both.
***** "3" : input is non-numeric.
***** "4" : too many digits ( max. is 13 ).
***** "5" : to many decimals ( max. is 5 ).
*****
***** This routine will validate the accepted (alfa-
***** numeric) field 'WK-ALFANUMERIC', respect decimal-input
***** and/or negative values, reformat the input-string to
***** a numeric-field 'WK-NUMERIC', which is linked back to
***** the program. In case an error is encountered in the
***** process, the error-indicator, 'WK-ERRORFLAG', will be
***** set to the right value. If no error occurs, this field
***** will contain a space.
***** No messages are displayed in this sub-routine, but the
***** calling program can inspect the 'WK-ERRORFLAG'-setting
***** to generate the right message ( if wanted ).
*****
************************************************************************
*****
***** HISTORY CURRENT VERSION = 001
*****
***** VERSION DATE PROGRAMMER CHANGES
*****
************************************************************************
ENVIRONMENT DIVISION.
DATA DIVISION.
WORKING-STORAGE SECTION.
77 WK-PROGRAM-NAME PIC X(6) VALUE "ACCNUM".
77 WK-VERSION PIC 999 VALUE 001.
77 WK-TALLY-1 PIC 9(2).
77 WK-TALLY-2 PIC 9(2).
77 WK-TALLY-3 PIC 9(2).
77 T-A PIC 9(2).
77 T-N PIC 9(2).
77 T-D PIC 9(2).
77 WK-DECCOUNT PIC 9(2).
77 WK-ADDDEC PIC 9V9(5).
77 WK-NEGATIVE PIC S9 VALUE -1.
77 WK-ERR-OK PIC X VALUE " ".
77 WK-ERR-1 PIC X VALUE "1".
77 WK-ERR-2 PIC X VALUE "2".
77 WK-ERR-3 PIC X VALUE "3".
77 WK-ERR-4 PIC X VALUE "4".
77 WK-ERR-5 PIC X VALUE "5".
01 WK-DIVIDETABLE.
05 FILLER PIC 9(6) VALUE 10.
05 FILLER PIC 9(6) VALUE 100.
05 FILLER PIC 9(6) VALUE 1000.
05 FILLER PIC 9(6) VALUE 10000.
05 FILLER PIC 9(6) VALUE 100000.
01 WK-DIVTAB REDEFINES WK-DIVIDETABLE.
05 WK-DIV PIC 9(6) OCCURS 5.
01 WK-ALFATABLE PIC X(18).
01 WK-A-TAB REDEFINES WK-ALFATABLE.
05 WK-ALF PIC X OCCURS 18.
01 WK-NUMTABLE PIC 9(13).
01 WK-N-TAB REDEFINES WK-NUMTABLE.
05 WK-NUM PIC 9 OCCURS 13.
01 WK-DECIMALS PIC 9(5).
01 WK-D-TAB REDEFINES WK-DECIMALS.
05 WK-DEC PIC 9 OCCURS 5.
LINKAGE SECTION.
01 WK-ALFANUMERIC PIC X(18).
01 WK-NUMERIC PIC S9(13)V9(5).
01 WK-ERRORFLAG PIC X.
PROCEDURE DIVISION USING WK-ALFANUMERIC
WK-NUMERIC
WK-ERRORFLAG.
A-010-MAINLINE.
MOVE WK-ERR-OK TO WK-ERRORFLAG.
MOVE 0 TO WK-TALLY-1
WK-TALLY-2
WK-TALLY-3
WK-DECCOUNT
WK-NUMTABLE
WK-DECIMALS
WK-NUMERIC.
MOVE WK-ALFANUMERIC TO WK-ALFATABLE.
IF WK-ALFATABLE = ALL SPACES
GO TO Z-999-RETURN.
INSPECT WK-ALFATABLE TALLYING WK-TALLY-1 FOR ALL ","
WK-TALLY-2 FOR ALL "."
WK-TALLY-3 FOR LEADING "-"
REPLACING LEADING "-" BY "0".
IF WK-TALLY-1 > 1
OR WK-TALLY-2 > 1
MOVE WK-ERR-1 TO WK-ERRORFLAG
GO TO Z-999-RETURN.
IF WK-TALLY-1 > 0
AND WK-TALLY-2 NOT = 0
MOVE WK-ERR-2 TO WK-ERRORFLAG
GO TO Z-999-RETURN.
IF WK-TALLY-2 > 0
AND WK-TALLY-1 NOT = 0
MOVE WK-ERR-2 TO WK-ERRORFLAG
GO TO Z-999-RETURN.
MOVE 13 TO T-N.
MOVE 5 TO T-D.
IF WK-TALLY-1 = 0 AND WK-TALLY-2 = 0
PERFORM A-110-NODECIMALS THRU A-110-NODECIMALS-EX
VARYING T-A FROM 18 BY WK-NEGATIVE
UNTIL T-A < 1
ELSE
PERFORM A-120-DECIMALS THRU A-120-DECIMALS-EX
VARYING T-A FROM 18 BY WK-NEGATIVE
UNTIL WK-ALF (T-A) = "."
OR = ","
OR T-A < 1
IF WK-ERRORFLAG = WK-ERR-OK
SUBTRACT 1 FROM T-A GIVING T-D
PERFORM A-110-NODECIMALS THRU A-110-NODECIMALS-EX
VARYING T-A FROM T-D BY WK-NEGATIVE
UNTIL T-A < 1.
IF WK-ERRORFLAG NOT = WK-ERR-OK
GO TO Z-999-RETURN.
MOVE WK-NUMTABLE TO WK-NUMERIC.
IF WK-DECCOUNT > 0
DIVIDE WK-DECIMALS BY WK-DIV (WK-DECCOUNT)
GIVING WK-ADDDEC
ADD WK-ADDDEC TO WK-NUMERIC.
IF WK-TALLY-3 > 0
MULTIPLY WK-NEGATIVE BY WK-NUMERIC.
GO TO Z-999-RETURN.
A-110-NODECIMALS.
IF WK-ALF (T-A) NOT = SPACE
IF WK-ALF (T-A) NOT NUMERIC
MOVE WK-ERR-3 TO WK-ERRORFLAG
MOVE 1 TO T-A
ELSE
MOVE WK-ALF (T-A) TO WK-NUM (T-N)
SUBTRACT 1 FROM T-N
IF T-N < 1
MOVE 1 TO T-A
MOVE WK-ERR-4 TO WK-ERRORFLAG.
A-110-NODECIMALS-EX.
EXIT.
A-120-DECIMALS.
IF WK-ALF (T-A) NOT = SPACE
IF WK-ALF (T-A) NOT NUMERIC
MOVE WK-ERR-3 TO WK-ERRORFLAG
MOVE 1 TO T-A
ELSE
MOVE WK-ALF (T-A) TO WK-DEC (T-D)
ADD 1 TO WK-DECCOUNT
SUBTRACT 1 FROM T-D
IF T-D < 1
MOVE WK-ERR-5 TO WK-ERRORFLAG
MOVE 1 TO T-A.
A-120-DECIMALS-EX.
EXIT.
Z-999-RETURN.
EXIT PROGRAM.