home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1992 March / Source_Code_CD-ROM_Walnut_Creek_March_1992.iso / usenet / altsrcs / 3 / 3433 < prev    next >
Encoding:
Internet Message Format  |  1991-05-31  |  12.0 KB
  1. From: manny@wet.UUCP (Manny Juan)
  2. Newsgroups: alt.cobol,alt.sources
  3. Subject: cobol2 pgm to convert number to words
  4. Message-ID: <2494@wet.UUCP>
  5. Date: 31 May 91 05:02:56 GMT
  6.  
  7. i wrote this program when cobol2 was "new" so i could try many of the new
  8. features of cobol2 (ie. inline performs, CASE-like Evaluate, END-IFs,etc)
  9. and i thought i'd share it.
  10.  
  11. the program runs as a standalone pgm but any cobol programmer should be able
  12. to apply surgery to it to extract its GET-NUMBER subroutine.  i've used this
  13. primitive numeric entry parser in various CICS data entry programs without
  14. any problems.  (in its current form, there is a limit to the size of the
  15.  
  16. result (GN-NUMBER-VALUE) because of its picture.  however, it may be recoded
  17. as floating point for more flexibility).
  18.  
  19. manny juan
  20. manny@wet.UUCP (also manny@tcomeng.COM)
  21. ------------- CUT HERE -------------
  22.  
  23. 000100 IDENTIFICATION DIVISION.
  24. 000200 PROGRAM-ID. NUM2WDS.
  25. 000300*AUTHOR. MANNY.
  26. 000400 DATE-WRITTEN. 11/23/90.
  27. 000500 DATE-COMPILED. 07/30/90.
  28. 000600 ENVIRONMENT DIVISION.
  29. 000700 INPUT-OUTPUT SECTION.
  30. 000800 FILE-CONTROL.
  31. 001000 DATA DIVISION.
  32. 001100 FILE SECTION.
  33. 002000 WORKING-STORAGE SECTION.
  34. 002100 01  FILLER PIC 9 VALUE 0.
  35. 002200   88  NO-MORE-NUMBERS VALUE 1.
  36. 002300 01  NBR-RECORD.
  37. 002400   03  NBR-STRING    PIC X(32).
  38. 002400   03  FILLER REDEFINES NBR-STRING.
  39. 002401     05  NBR-CH1     PIC X(01).
  40. 002402     05  FILLER      PIC X(31).
  41. 002500 01  GN-WORK-AREA.
  42. 002600   03  GN-IX                PIC S9(03) COMP.
  43. 002700   03  GN-SIGN              PIC X(01).
  44. 002800   03  GN-WHOLE-NUMBER      PIC S9(15)    COMP-3.
  45. 002900   03  GN-DIVISOR           PIC S9(13)    COMP-3.
  46. 003000
  47. 003100 01  GN-CONVERT-AREA.
  48. 003200   03  GN-INPUT.
  49. 003300     05  GN-INPUT-CHARS.
  50. 003400       07  GN-CH       PIC X(01) OCCURS 33 TIMES.
  51. 003500
  52. 003600     05  GN-INPUT-DIGITS REDEFINES GN-INPUT-CHARS.
  53. 003700       07  GN-DIGIT    PIC 9(01) OCCURS 33 TIMES.
  54. 003800
  55. 003900   03  GN-NUMBER-VALUE      PIC S9(13)V99.
  56. 004000   03  FILLER               PIC X(01).
  57. 004100     88  GN-GOOD-NUMBER     VALUE 'Y'.
  58. 004200     88  GN-BAD-NUMBER      VALUE 'N'.
  59. 004300
  60. 004400 01  NW-WORK-AREA.
  61. 004500   03  NW-CHUNK-LIT-DEF.
  62. 004600     05  FILLER PIC X(09) VALUE SPACES.
  63. 004700     05  FILLER PIC X(09) VALUE 'THOUSAND'.
  64. 004800     05  FILLER PIC X(09) VALUE 'MILLION'.
  65. 004900     05  FILLER PIC X(09) VALUE 'BILLION'.
  66. 005000     05  FILLER PIC X(09) VALUE 'TRILLION'.
  67. 005100
  68. 005200   03  FILLER REDEFINES NW-CHUNK-LIT-DEF.
  69. 005300     05  NW-CHUNK-LIT     PIC X(09) OCCURS 5 TIMES.
  70. 005400
  71. 005500   03  NW-TENS-LIT-DEF.
  72. 005600     05  FILLER           PIC X(08) VALUE SPACES.
  73. 005700     05  FILLER           PIC X(08) VALUE 'TWENTY'.
  74. 005800     05  FILLER           PIC X(08) VALUE 'THIRTY'.
  75. 005900     05  FILLER           PIC X(08) VALUE 'FORTY'.
  76. 006000     05  FILLER           PIC X(08) VALUE 'FIFTY'.
  77. 006100     05  FILLER           PIC X(08) VALUE 'SIXTY'.
  78. 006200     05  FILLER           PIC X(08) VALUE 'SEVENTY'.
  79. 006300     05  FILLER           PIC X(08) VALUE 'EIGHTY'.
  80. 006400     05  FILLER           PIC X(08) VALUE 'NINETY'.
  81. 006500
  82. 006600   03  FILLER REDEFINES NW-TENS-LIT-DEF.
  83. 006700     05  NW-TENS-LIT      PIC X(08) OCCURS 9 TIMES.
  84. 006800
  85. 006900   03  NW-UNITS-TO-20-LIT-DEF.
  86. 007000     05  FILLER           PIC X(10) VALUE 'ONE'.
  87. 007100     05  FILLER           PIC X(10) VALUE 'TWO'.
  88. 007200     05  FILLER           PIC X(10) VALUE 'THREE'.
  89. 007300     05  FILLER           PIC X(10) VALUE 'FOUR'.
  90. 007400     05  FILLER           PIC X(10) VALUE 'FIVE'.
  91. 007500     05  FILLER           PIC X(10) VALUE 'SIX'.
  92. 007600     05  FILLER           PIC X(10) VALUE 'SEVEN'.
  93. 007700     05  FILLER           PIC X(10) VALUE 'EIGHT'.
  94. 007800     05  FILLER           PIC X(10) VALUE 'NINE'.
  95. 007900     05  FILLER           PIC X(10) VALUE 'TEN'.
  96. 008000     05  FILLER           PIC X(10) VALUE 'ELEVEN'.
  97. 008100     05  FILLER           PIC X(10) VALUE 'TWELVE'.
  98. 008200     05  FILLER           PIC X(10) VALUE 'THIRTEEN'.
  99. 008300     05  FILLER           PIC X(10) VALUE 'FOURTEEN'.
  100. 008400     05  FILLER           PIC X(10) VALUE 'FIFTEEN'.
  101. 008500     05  FILLER           PIC X(10) VALUE 'SIXTEEN'.
  102. 008600     05  FILLER           PIC X(10) VALUE 'SEVENTEEN'.
  103. 008700     05  FILLER           PIC X(10) VALUE 'EIGHTEEN'.
  104. 008800     05  FILLER           PIC X(10) VALUE 'NINETEEN'.
  105. 008900
  106. 009000   03  FILLER REDEFINES NW-UNITS-TO-20-LIT-DEF.
  107. 009100     05  NW-UNITS-TO-20-LIT PIC X(10) OCCURS 19 TIMES.
  108. 009200
  109. 009300   03  NW-COUNTER             PIC 9.
  110. 009400   03  NW-CC                  PIC 9(03).
  111. 009500   03  NW-TO-20               PIC 9(02).
  112. 009600   03  NW-REM                 PIC 9(02).
  113. 009700   03  NW-WORK-STRING         PIC X(200).
  114. 009800   03  NW-CHUNK-STRING        PIC X(48).
  115. 009900   03  NW-CHUNK-CC            PIC 9(02).
  116. 010000   03  NW-CHUNK               PIC 9(03).
  117. 010100   03  FILLER REDEFINES NW-CHUNK.
  118. 010200     05  NW-HUNDREDS          PIC 9.
  119. 010300     05  NW-TENS              PIC 9.
  120. 010400     05  NW-UNITS             PIC 9.
  121. 010500
  122. 010600 01  NW-CONVERT-AREA.
  123. 010700   03  NW-INPUT             PIC 9(15).99-.
  124. 010800   03  FILLER REDEFINES NW-INPUT.
  125. 010900     05  NW-WHOLE-NUMBER    PIC 9(15).
  126. 011000     05  NW-DECIMAL-PT      PIC X(01).
  127. 011100     05  NW-CENTS           PIC 9(02).
  128. 011200     05  NW-SIGN            PIC X(01).
  129. 011300
  130. 011400   03  NW-OUTPUT     PIC X(200).
  131. 011500
  132. 011600 PROCEDURE DIVISION.
  133. 011700 0100-NUM2WDS SECTION.
  134. 011900     PERFORM 0110-GET-NUMBERS
  135. 012000     PERFORM 0120-DO-CONVERT
  136. 012100         UNTIL NO-MORE-NUMBERS
  137. 012300     GOBACK.
  138. 012400 0110-GET-NUMBERS SECTION.
  139. 012401     DISPLAY "Enter a dollar amount (or / to quit)"
  140. 012500     ACCEPT NBR-RECORD
  141. 012600     IF NBR-CH1 = "/"
  142. 012700         SET NO-MORE-NUMBERS TO TRUE
  143. 012800     END-IF
  144. 012900     CONTINUE.
  145. 013000 0120-DO-CONVERT SECTION.
  146. 013100     MOVE NBR-STRING TO GN-INPUT
  147. 013200     PERFORM 0130-GET-NUMBER
  148. 013300     DISPLAY GN-INPUT ' ' GN-NUMBER-VALUE
  149. 013500     MOVE GN-NUMBER-VALUE TO NW-INPUT
  150. 013600     PERFORM 0140-CONVERT-TO-WORDS
  151. 013700     DISPLAY 'WORDS=' NW-OUTPUT
  152. 013400     PERFORM 0110-GET-NUMBERS
  153. 013800     CONTINUE.
  154. 013900
  155. 014000 0130-GET-NUMBER SECTION.
  156. 014100     MOVE 1 TO GN-IX
  157. 014200     MOVE SPACES TO GN-SIGN
  158. 014300     IF  NOT (GN-INPUT = SPACES)
  159. 014400*      --SKIP LEADING SPACES
  160. 014500         PERFORM VARYING GN-IX FROM GN-IX BY +1
  161. 014600             UNTIL GN-CH (GN-IX) NOT = SPACE
  162. 014700         END-PERFORM
  163. 014800         MOVE ZEROES TO GN-WHOLE-NUMBER
  164. 014900         MOVE 1      TO GN-DIVISOR
  165. 015000         IF  (GN-CH (GN-IX) = '-') THEN
  166. 015100             MOVE '-' TO GN-SIGN
  167. 015200             COMPUTE GN-IX = GN-IX + 1
  168. 015300         END-IF
  169. 015400         PERFORM
  170. 015500             TEST BEFORE
  171. 015600         UNTIL GN-CH (GN-IX) NOT NUMERIC
  172. 015700         OR    GN-CH (GN-IX) = SPACE
  173. 015800         OR    GN-CH (GN-IX) = '.'
  174. 015900             COMPUTE GN-WHOLE-NUMBER
  175. 016000             =  10 * GN-WHOLE-NUMBER
  176. 016100             +       GN-DIGIT (GN-IX)
  177. 016200             COMPUTE GN-IX = GN-IX + 1
  178. 016300             PERFORM VARYING GN-IX FROM GN-IX BY +1
  179. 016400                 UNTIL NOT (GN-CH (GN-IX) = ',')
  180. 016500             END-PERFORM
  181. 016600         END-PERFORM
  182. 016700         IF   GN-CH (GN-IX) = '.'
  183. 016800             COMPUTE GN-IX = GN-IX + 1
  184. 016900             PERFORM
  185. 017000                 TEST BEFORE
  186. 017100             UNTIL GN-CH (GN-IX) NOT NUMERIC
  187. 017200             OR    GN-CH (GN-IX) = SPACE
  188. 017300                 COMPUTE GN-DIVISOR
  189. 017400                 =  10 * GN-DIVISOR
  190. 017500                 COMPUTE GN-WHOLE-NUMBER
  191. 017600                 =  10 * GN-WHOLE-NUMBER
  192. 017700                 +       GN-DIGIT (GN-IX)
  193. 017800                 COMPUTE GN-IX = GN-IX + 1
  194. 017900             END-PERFORM
  195. 018000         END-IF
  196. 018100         COMPUTE GN-NUMBER-VALUE
  197. 018200         =       GN-WHOLE-NUMBER
  198. 018300         /       GN-DIVISOR
  199. 018400         IF  GN-SIGN = '-'
  200. 018500             COMPUTE GN-NUMBER-VALUE
  201. 018600             =  0 -  GN-NUMBER-VALUE
  202. 018700         END-IF
  203. 018800         IF  GN-CH (GN-IX) = SPACE
  204. 018900             SET GN-GOOD-NUMBER TO TRUE
  205. 019000         ELSE
  206. 019100             SET GN-BAD-NUMBER  TO TRUE
  207. 019200         END-IF
  208. 019300     END-IF
  209. 019400     CONTINUE.
  210. 019500
  211. 019600 0140-CONVERT-TO-WORDS SECTION.
  212. 019700     MOVE 1 TO NW-CC
  213. 019800     MOVE SPACES TO NW-WORK-STRING
  214. 019900     MOVE SPACES TO NW-OUTPUT
  215. 020000     IF  NW-WHOLE-NUMBER = ZEROES
  216. 020100         STRING 'ZERO #' DELIMITED BY SIZE
  217. 020200             INTO NW-OUTPUT POINTER NW-CC
  218. 020300     ELSE
  219. 020400         STRING '#' DELIMITED BY SIZE
  220. 020500             INTO NW-OUTPUT POINTER NW-CC
  221. 020600     END-IF
  222. 020700
  223. 020800     PERFORM
  224. 020900         VARYING NW-COUNTER FROM 1 BY +1
  225. 021000     UNTIL NW-COUNTER > 5
  226. 021100     OR    NW-WHOLE-NUMBER = ZEROES
  227. 021200         MOVE SPACES TO NW-CHUNK-STRING
  228. 021300         MOVE 1 TO NW-CHUNK-CC
  229. 021400         DIVIDE NW-WHOLE-NUMBER BY 1000
  230. 021500             GIVING NW-WHOLE-NUMBER REMAINDER NW-CHUNK
  231. 021600
  232. 021700         IF  NW-CHUNK > ZEROES
  233. 021800             IF (NW-HUNDREDS > 0)
  234. 021900                 STRING NW-UNITS-TO-20-LIT (NW-HUNDREDS)
  235. 022000                         DELIMITED BY SPACE
  236. 022100                     ' HUNDRED' DELIMITED BY SIZE
  237. 022200                     INTO NW-CHUNK-STRING POINTER NW-CHUNK-CC
  238. 022300                 IF  NOT (NW-TENS = 0 AND NW-UNITS = 0)
  239. 022400                     STRING ' ' DELIMITED BY SIZE
  240. 022500                         INTO NW-CHUNK-STRING POINTER NW-CHUNK-CC
  241. 022600                 END-IF
  242. 022700             END-IF
  243. 022800
  244. 022900             IF (NW-TENS < '2')
  245. 023000                 COMPUTE NW-TO-20
  246. 023100                 =       10 * NW-TENS + NW-UNITS
  247. 023200                 IF  (NW-TO-20 > ZERO)
  248. 023300                     STRING NW-UNITS-TO-20-LIT (NW-TO-20)
  249. 023400                             DELIMITED BY SPACE
  250. 023500                         INTO NW-CHUNK-STRING POINTER NW-CHUNK-CC
  251. 023600                 END-IF
  252. 023700             ELSE
  253. 023800                 STRING NW-TENS-LIT (NW-TENS)
  254. 023900                         DELIMITED BY SPACE
  255. 024000                     INTO NW-CHUNK-STRING POINTER NW-CHUNK-CC
  256. 024100                 IF  (NW-UNITS > 0)
  257. 024200                     STRING '-' DELIMITED BY SIZE
  258. 024300                         NW-UNITS-TO-20-LIT (NW-UNITS)
  259. 024400                             DELIMITED BY SPACE
  260. 024500                         INTO NW-CHUNK-STRING POINTER NW-CHUNK-CC
  261. 024600                 END-IF
  262. 024700             END-IF
  263. 024800
  264. 024900             IF  (NW-COUNTER = 1)
  265. 025000                 STRING ' #' DELIMITED BY SIZE
  266. 025100                     INTO NW-CHUNK-STRING POINTER NW-CHUNK-CC
  267. 025200             ELSE
  268. 025300                 STRING ' ' DELIMITED BY SIZE
  269. 025400                     NW-CHUNK-LIT (NW-COUNTER)
  270. 025500                         DELIMITED BY SPACE
  271. 025600                     ' #' DELIMITED BY SIZE
  272. 025700                     INTO NW-CHUNK-STRING POINTER NW-CHUNK-CC
  273. 025800             END-IF
  274. 025900
  275. 026000             MOVE 1 TO NW-CC
  276. 026100             STRING NW-CHUNK-STRING DELIMITED BY '#'
  277. 026200                 NW-OUTPUT DELIMITED BY '#'
  278. 026300                 '#' DELIMITED BY SIZE
  279. 026400                 INTO NW-WORK-STRING POINTER NW-CC
  280. 026500
  281. 026600             MOVE NW-WORK-STRING TO NW-OUTPUT
  282. 026700         END-IF
  283. 026800     END-PERFORM
  284. 026900
  285. 027000     COMPUTE NW-CC = NW-CC - 1
  286. 027100     IF  (NW-CENTS = ZEROS)
  287. 027200         STRING 'DOLLARS AND NO CENTS#'
  288. 027300             DELIMITED BY SIZE
  289. 027400             INTO  NW-OUTPUT POINTER NW-CC
  290. 027500     ELSE
  291. 027600         STRING 'DOLLARS AND ' NW-CENTS ' CENTS#'
  292. 027700             DELIMITED BY SIZE
  293. 027800             INTO  NW-OUTPUT POINTER NW-CC
  294. 027900     END-IF
  295. 028000     IF  NW-SIGN = '-'
  296. 028100         STRING 'MINUS ' DELIMITED BY SIZE
  297. 028200             NW-OUTPUT DELIMITED BY '#'
  298. 028300             INTO NW-WORK-STRING
  299. 028400     ELSE
  300. 028500         STRING NW-OUTPUT DELIMITED BY '#'
  301. 028600             INTO NW-WORK-STRING
  302. 028700     END-IF
  303. 028800     MOVE NW-WORK-STRING TO NW-OUTPUT
  304. 028900
  305. 029000     CONTINUE.
  306. -- 
  307. |-------------------------------------------------------------------------|
  308. |  Manny Juan     (manny)   {decwrl,pacbell}!tcomeng!manny                |
  309. |-------------------------------------------------------------------------|
  310.