Callable routine to convert a dollar amount to words

IDENTIFICATION DIVISION.
PROGRAM-ID. CWAMTWRD.
AUTHOR. CLIVE CUMMINS.
INSTALLATION. http://tubularity.com
DATE-WRITTEN. JAN 15,1993.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 PROGRAM-DETAILS.
05 PROGRAM-RELEASE.
10 PROGRAM-NAME PIC X(08) VALUE "CWAMTWRD".
10 PROGRAM-REL PIC X(08) VALUE " 3.2.10".
01 TABLE-AREAS.
05 NUMBER-WORD-XREF-AREA.
10 FILLER PIC X(12) VALUE "01One# ".
10 FILLER PIC X(12) VALUE "02Two# ".
10 FILLER PIC X(12) VALUE "03Three# ".
10 FILLER PIC X(12) VALUE "04Four# ".
10 FILLER PIC X(12) VALUE "05Five# ".
10 FILLER PIC X(12) VALUE "06Six# ".
10 FILLER PIC X(12) VALUE "07Seven# ".
10 FILLER PIC X(12) VALUE "08Eight# ".
10 FILLER PIC X(12) VALUE "09Nine# ".
10 FILLER PIC X(12) VALUE "10Ten# ".
10 FILLER PIC X(12) VALUE "11Eleven# ".
10 FILLER PIC X(12) VALUE "12Twelve# ".
10 FILLER PIC X(12) VALUE "13Thirteen# ".
10 FILLER PIC X(12) VALUE "14Fourteen# ".
10 FILLER PIC X(12) VALUE "15Fifteen# ".
10 FILLER PIC X(12) VALUE "16Sixteen# ".
10 FILLER PIC X(12) VALUE "17Seventeen#".
10 FILLER PIC X(12) VALUE "18Eighteen# ".
10 FILLER PIC X(12) VALUE "19Nineteen# ".
10 FILLER PIC X(12) VALUE "20Twenty# ".
10 FILLER PIC X(12) VALUE "30Thirty# ".
10 FILLER PIC X(12) VALUE "40Forty# ".
10 FILLER PIC X(12) VALUE "50Fifty# ".
10 FILLER PIC X(12) VALUE "60Sixty# ".
10 FILLER PIC X(12) VALUE "70Seventy# ".
10 FILLER PIC X(12) VALUE "80Eighty# ".
10 FILLER PIC X(12) VALUE "90Ninety# ".
05 NUMBER-WORD-XREF-TABLE REDEFINES NUMBER-WORD-XREF-AREA
OCCURS 28 TIMES INDEXED BY NWX-IDX.
10 XREF-NUMBER PIC X(02).
10 XREF-WORD PIC X(10).
05 WORD-AREA-TABLE.
10 WORD-AREA OCCURS 9 TIMES INDEXED BY WORD-IDX
PIC X(10).
01 CONSTANTS.
05 C-HUNDRED PIC X(8) VALUE "Hundred#".
05 C-THOUSAND PIC X(9) VALUE "Thousand#".
05 C-20 PIC X(2) VALUE "20".
01 WORK-AREAS.
05 TESTNUM-VALUE-D PIC 99999V99.
05 TESTNUM-VALUE-X REDEFINES TESTNUM-VALUE-D.
10 TESTNUM-DOLLARS.
15 TESTNUM-DOLLAR-1 PIC X(1).
15 TESTNUM-DOLLAR-2 PIC X(1).
15 TESTNUM-DOLLAR-3 PIC X(1).
15 TESTNUM-DOLLAR-4 PIC X(1).
15 TESTNUM-DOLLAR-5 PIC X(1).
10 TESTNUM-CENTS PIC X(2).
05 TESTNUM-SEARCH-SAVE PIC X(2).
05 TESTNUM-SEARCH-VALUE.
10 TESTNUM-SEARCH-1 PIC X(1).
10 TESTNUM-SEARCH-2 PIC X(1).
05 STRING-AREA PIC X(60).
05 CENTS-AREA.
10 FILLER PIC X(2) VALUE "&#".
10 CENTS-VALUE PIC X(2).
10 FILLER PIC X(5) VALUE "/100#".
LINKAGE SECTION.
01 CWAMTWRD-VALUE PIC S9(5)V99.
01 CWAMTWRD-VALUE-EDITED PIC ****9.99-.
01 CWAMTWRD-WORDS PIC X(60).
PROCEDURE DIVISION USING CWAMTWRD-VALUE CWAMTWRD-VALUE-EDITED
CWAMTWRD-WORDS.
1000-CONTROL.
SET WORD-IDX TO +1.
MOVE CWAMTWRD-VALUE TO TESTNUM-VALUE-D.
MOVE CWAMTWRD-VALUE TO CWAMTWRD-VALUE-EDITED.
MOVE SPACES TO WORD-AREA-TABLE STRING-AREA.
MOVE TESTNUM-DOLLAR-1 TO TESTNUM-SEARCH-1.
MOVE TESTNUM-DOLLAR-2 TO TESTNUM-SEARCH-2.
IF TESTNUM-SEARCH-VALUE GREATER THAN ZERO
PERFORM 2000-GET-THOUSANDS.
MOVE ZERO TO TESTNUM-SEARCH-1.
MOVE TESTNUM-DOLLAR-3 TO TESTNUM-SEARCH-2.
IF TESTNUM-SEARCH-VALUE GREATER THAN ZERO
PERFORM 3000-GET-HUNDREDS.
MOVE TESTNUM-DOLLAR-4 TO TESTNUM-SEARCH-1.
MOVE TESTNUM-DOLLAR-5 TO TESTNUM-SEARCH-2.
IF TESTNUM-SEARCH-VALUE GREATER THAN ZERO
PERFORM 4000-GET-TENS.
PERFORM 9000-STRING-WORDS.
GOBACK.
2000-GET-THOUSANDS.
PERFORM 4000-GET-TENS.
MOVE C-THOUSAND TO WORD-AREA (WORD-IDX).
SET WORD-IDX UP BY +1.
3000-GET-HUNDREDS.
PERFORM 8000-SEARCH-XREF.
MOVE XREF-WORD (NWX-IDX) TO WORD-AREA (WORD-IDX).
SET WORD-IDX UP BY +1.
MOVE C-HUNDRED TO WORD-AREA (WORD-IDX).
SET WORD-IDX UP BY +1.
4000-GET-TENS.
MOVE TESTNUM-SEARCH-VALUE TO TESTNUM-SEARCH-SAVE.
IF TESTNUM-SEARCH-2 EQUAL ZERO
OR TESTNUM-SEARCH-VALUE LESS THAN C-20
PERFORM 8000-SEARCH-XREF
MOVE XREF-WORD (NWX-IDX) TO WORD-AREA (WORD-IDX)
SET WORD-IDX UP BY +1
ELSE
MOVE ZERO TO TESTNUM-SEARCH-2
PERFORM 8000-SEARCH-XREF
MOVE XREF-WORD (NWX-IDX) TO WORD-AREA (WORD-IDX)
SET WORD-IDX UP BY +1
MOVE TESTNUM-SEARCH-SAVE TO TESTNUM-SEARCH-VALUE
MOVE ZERO TO TESTNUM-SEARCH-1
PERFORM 8000-SEARCH-XREF
MOVE XREF-WORD (NWX-IDX) TO WORD-AREA (WORD-IDX)
SET WORD-IDX UP BY +1.
8000-SEARCH-XREF.
SET NWX-IDX TO +1.
SEARCH NUMBER-WORD-XREF-TABLE
WHEN TESTNUM-SEARCH-VALUE EQUAL XREF-NUMBER (NWX-IDX)
NEXT SENTENCE.
9000-STRING-WORDS.
MOVE ALL "*" TO STRING-AREA.
IF TESTNUM-CENTS NOT EQUAL ZERO
MOVE TESTNUM-CENTS TO CENTS-VALUE
MOVE CENTS-AREA TO WORD-AREA (WORD-IDX).
STRING WORD-AREA (1) WORD-AREA (2) WORD-AREA (3)
WORD-AREA (4) WORD-AREA (5) WORD-AREA (6)
WORD-AREA (7) WORD-AREA (8) WORD-AREA (9)
DELIMITED BY " " INTO STRING-AREA.
INSPECT STRING-AREA REPLACING ALL "#" BY " ".
MOVE STRING-AREA TO CWAMTWRD-WORDS.