Código de Cobol - RUTINA DE MONTO ESCRITO

<<>>
Imágen de perfil

RUTINA DE MONTO ESCRITOgráfica de visualizaciones


Cobol

estrellaestrellaestrellaestrellaestrella(2)
Publicado el 03 de Noviembre del 2014 por Sergio
1.662 visualizaciones desde el 03 de Noviembre del 2014. Una media de 21 por semana
Hola, comparto con ustedes un programa COBOL que traduce un monto en números a su correspondiente monto escrito. Ejemplo:

Monto Numerico: 360321, 98
Monto Escrito : TRESCIENTOS SESENTA MIL TRESCIENTOS VEINTIUNO CON 98 CTVOS

Soporta hasta 999 miles de millones y devuelve un texto de 170 caracteres que pueden usar como mejor les convenga (separa en dos o más lineas).

Espero les sea de utilidad.

Saludos,


Sergio

1.00
estrellaestrellaestrellaestrellaestrella(2)

Publicado el 03 de Noviembre del 2014gráfica de visualizaciones de la versión: 1.00
1.663 visualizaciones desde el 03 de Noviembre del 2014. Una media de 21 por semana
estrellaestrellaestrellaestrellaestrella
estrellaestrellaestrellaestrella
estrellaestrellaestrella
estrellaestrella
estrella

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
IDENTIFICATION DIVISION.
       PROGRAM-ID. MONES.
       DATE-WRITTEN. 31-10-2014.
       ENVIRONMENT DIVISION.
       CONFIGURATION SECTION.
       SOURCE-COMPUTER. IBM-AT.
       OBJECT-COMPUTER. IBM-AT.
       DATA DIVISION.
       FILE SECTION.
       WORKING-STORAGE SECTION.
       01  VARIABLES.
           02 FRASE	PIC X(15).
           02 FW REDEFINES FRASE OCCURS 15 TIMES PIC X.
           02 TODO	PIC 999.
           02 TODOX REDEFINES TODO.
              03 A	PIC 9.
              03 B	PIC 9.
              03 C	PIC 9.
           02 TODO-X REDEFINES TODO.
              03 FILLER PIC X.
              03 DOS	PIC 99.
           02 VER-VAL   PIC 9(12)V99.
           02 VERVAL REDEFINES VER-VAL.
              03 MILMILLON PIC 999.
              03 MILLON	PIC 999.
              03 MILCIEN.
                 04 MILES	PIC 999.
                 04 CIEN	PIC 999.
              03 CHIVOS	PIC 99.
           02 CENTAVOS.
              03 FILLER	PIC X(4) VALUE "CON".
              03 CTAVOS	PIC 99.
              03 FILLER PIC X(8) VALUE " CTVOS*".
           02 UNO PIC X(4) VALUE "UNO*".
           02 I	PIC 999 VALUE 0.
           02 J PIC 999 VALUE 0.
           02 K PIC 999 VALUE 0.
           02 L PIC 999	VALUE 0.
           02 M PIC 999 VALUE 0.
           02 S PIC 9 VALUE 0.
           02 P PIC 9 VALUE 0.
           02 sn pic x.
           02 NOM-VALORES.
              03 FILLER PIC X(15) VALUE "UN*".
              03 FILLER PIC X(15) VALUE "DOS*".
              03 FILLER PIC X(15) VALUE "TRES*".
              03 FILLER PIC X(15) VALUE "CUATRO*".
              03 FILLER PIC X(15) VALUE "CINCO*".
              03 FILLER PIC X(15) VALUE "SEIS*".
              03 FILLER PIC X(15) VALUE "SIETE*".
              03 FILLER PIC X(15) VALUE "OCHO*".
              03 FILLER PIC X(15) VALUE "NUEVE*".
              03 FILLER PIC X(15) VALUE "DIEZ*".
              03 FILLER PIC X(15) VALUE "ONCE*".
              03 FILLER PIC X(15) VALUE "DOCE*".
              03 FILLER PIC X(15) VALUE "TRECE*".
              03 FILLER PIC X(15) VALUE "CATORCE*".
              03 FILLER PIC X(15) VALUE "QUINCE*".
              03 FILLER PIC X(15) VALUE "DIECISEIS*".
              03 FILLER PIC X(15) VALUE "DIECISIETE*".
              03 FILLER PIC X(15) VALUE "DIECIOCHO*".
              03 FILLER PIC X(15) VALUE "DIECINUEVE*".
              03 FILLER PIC X(15) VALUE "VEINTE*".
              03 FILLER PIC X(15) VALUE "VEINTI*".
              03 FILLER PIC X(15) VALUE "TREINTA*".
              03 FILLER PIC X(15) VALUE "CUARENTA*".
              03 FILLER PIC X(15) VALUE "CINCUENTA*".
              03 FILLER PIC X(15) VALUE "SESENTA*".
              03 FILLER PIC X(15) VALUE "SETENTA*".
              03 FILLER PIC X(15) VALUE "OCHENTA*".
              03 FILLER PIC X(15) VALUE "NOVENTA*".
              03 FILLER PIC X(15) VALUE "CIEN*".
              03 FILLER PIC X(15) VALUE "CIENTO*".
              03 FILLER PIC X(15) VALUE "DOSCIENTOS*".
              03 FILLER PIC X(15) VALUE "TRESCIENTOS*".
              03 FILLER PIC X(15) VALUE "CUATROCIENTOS*".
              03 FILLER PIC X(15) VALUE "QUINIENTOS*".
              03 FILLER PIC X(15) VALUE "SEISCIENTOS*".
              03 FILLER PIC X(15) VALUE "SETECIENTOS*".
              03 FILLER PIC X(15) VALUE "OCHOCIENTOS*".
              03 FILLER PIC X(15) VALUE "NOVECIENTOS*".
           02 NOM-VAL REDEFINES NOM-VALORES PIC X(15) OCCURS 38 TIMES.
       LINKAGE SECTION.
       01 LS-DATOS.
        02 VALOR	PIC 9(12)V99.
        02 MONTO-LETRAS PIC X(170).
        02 LINEA REDEFINES MONTO-LETRAS PIC X OCCURS 170.
       PROCEDURE DIVISION USING LS-DATOS.
 
       INICIO SECTION.
       01. INITIALIZE VER-VAL FRASE MONTO-LETRAS.
           MOVE VALOR TO VER-VAL IF VER-VAL > 0
             PERFORM PROCESO.
       90. EXIT PROGRAM.
           STOP RUN.
 
       PROCESO SECTION.
       01. MOVE 1 TO K MOVE 0 TO S
      *miles de millones
           MOVE 1 TO P.
           IF MILMILLON > 0 MOVE MILMILLON TO TODO
              PERFORM LLENAR
              MOVE "MIL*" TO FRASE
              PERFORM LETRAS
              MOVE "MILLONES*" TO FRASE
              PERFORM LETRAS.
      *millones
           MOVE 2 TO P.
           IF MILLON > 0 MOVE MILLON TO TODO
              PERFORM LLENAR
              IF MILLON = 1 AND MILMILLON = 0 MOVE "MILLON*" TO FRASE
              ELSE MOVE "MILLONES*" TO FRASE
              END-IF
              PERFORM LETRAS.
      *miles
           MOVE 3 TO P.
           IF MILES > 0 MOVE MILES TO TODO
              PERFORM LLENAR
              MOVE "MIL*" TO FRASE
              PERFORM LETRAS.
      *cientos / unidades
           MOVE 4 TO P.
           MOVE CIEN TO TODO.
           PERFORM LLENAR.
      *decimales.
           MOVE 5 TO P.
           MOVE 0 TO TODO, PERFORM LLENAR.
       90. EXIT.
 
       LLENAR SECTION.
       01. IF TODO = 0
            IF P = 5
             IF CHIVOS > 0 MOVE CHIVOS TO CTAVOS
               MOVE CENTAVOS TO FRASE
               PERFORM LETRAS go 90
             else go 90
            else go 90.
      *si A > 0 posiciona el indice L en "ciento" (29)
           IF A > 0 MOVE 29 TO L
              IF DOS > 0 ADD A TO L MOVE NOM-VAL (L) TO FRASE
              ELSE
              IF A > 1 ADD A TO L MOVE NOM-VAL (L) TO FRASE
              ELSE MOVE NOM-VAL (L) TO FRASE.
           PERFORM LETRAS.
           IF DOS = 0 GO 90.
           IF DOS < 21 MOVE NOM-VAL (DOS) TO FRASE
              PERFORM LETRAS GO 90.
           IF B = 2 MOVE 21 TO L MOVE NOM-VAL (L) TO FRASE
           ELSE MOVE 19 TO L ADD B TO L MOVE NOM-VAL (L) TO FRASE.
           PERFORM LETRAS.
           IF B > 2 IF C > 0 MOVE "Y*" TO FRASE
              PERFORM LETRAS.
           IF C > 0 MOVE NOM-VAL (C) TO FRASE
              PERFORM LETRAS.
       90. Exit.
 
       LETRAS SECTION.
       01. if frase = spaces go 90.
           IF P = 4 AND FRASE = "UN*" MOVE UNO TO FRASE.
           STRING FRASE DELIMITED BY "*" INTO MONTO-LETRAS POINTER K.
           STRING " " DELIMITED BY SIZE INTO MONTO-LETRAS POINTER K.
           IF FRASE = "VEINTI*" SUBTRACT 1 FROM K.
           INITIALIZE FRASE.
       90. exit.



Comentarios sobre la versión: 1.00 (2)

Imágen de perfil
Jorge Eduardo
08 de Julio del 2015
estrellaestrellaestrellaestrellaestrella
FANTASTICO... AGRADECIDO.
Responder
Imágen de perfil
Jorge Eduardo
23 de Mayo del 2016
estrellaestrellaestrellaestrellaestrella
Estimado.
Podrias ayudarme; necesito convertir mis programas cobol de 32 bit a 64...!
donde puedo comprar el nuevo compilador,
agradecido.
Responder

Comentar la versión: 1.00

Nombre
Correo (no se visualiza en la web)
Valoración
Comentarios

http://lwp-l.com/s2830