Google
 

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.