-
Notifications
You must be signed in to change notification settings - Fork 1
/
SMP003.COB
374 lines (364 loc) · 13.7 KB
/
SMP003.COB
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
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
IDENTIFICATION DIVISION.
PROGRAM-ID. SMP003.
AUTHOR. JULIO CESAR DA SILVA BARCELLOS.
**************************************
* MANUTENCAO DO CADASTRO DE CONVENIOS *
**************************************
*----------------------------------------------------------------
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SPECIAL-NAMES.
DECIMAL-POINT IS COMMA.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT CADCONV ASSIGN TO DISK
ORGANIZATION IS INDEXED
ACCESS MODE IS DYNAMIC
RECORD KEY IS CODIGO
FILE STATUS IS ST-ERRO
ALTERNATE RECORD IS NOMEC WITH DUPLICATES.
*
*-----------------------------------------------------------------
DATA DIVISION.
FILE SECTION.
FD CADCONV
LABEL RECORD IS STANDARD
VALUE OF FILE-ID IS "CADCONV.DAT".
01 REGCONV.
03 CODIGO PIC 9(04).
03 NOMEC PIC X(30).
03 PLANO PIC 9(02).
*
*-----------------------------------------------------------------
WORKING-STORAGE SECTION.
77 W-SEL PIC 9(01) VALUE ZEROS.
77 W-CONT PIC 9(06) VALUE ZEROS.
77 W-OPCAO PIC X(01) VALUE SPACES.
77 ST-ERRO PIC X(02) VALUE "00".
77 W-ACT PIC 9(02) VALUE ZEROS.
77 MENS PIC X(50) VALUE SPACES.
77 LIMPA PIC X(50) VALUE SPACES.
77 PLAN PIC X(25) VALUE SPACES.
77 IND1 PIC 9(02) VALUE ZEROS.
01 TABUNIDADE01.
03 T01 PIC X(20) VALUE "01020304050607080910".
01 TUN1 REDEFINES TABUNIDADE01.
03 T1 PIC X(02) OCCURS 10 TIMES.
01 ALFAUN PIC 9(02) VALUE ZEROS.
01 TABPLANO.
03 P1 PIC X(25) VALUE "ENFERMARIA REGIONAL".
03 P2 PIC X(25) VALUE "ENFERMARIA NACIONAL".
03 P3 PIC X(25) VALUE "ENFERMARIA INTERNACIONAL".
03 P4 PIC X(25) VALUE "APTO PADRAO REGIONAL".
03 P5 PIC X(25) VALUE "APTO PADRAO NACIONAL".
03 P6 PIC X(25) VALUE "APTO PADRAO INTERNACIONAL".
03 P7 PIC X(25) VALUE "EMERGENCIA REGIONAL".
03 P8 PIC X(25) VALUE "EMERGENCIA NACIONAL".
03 P9 PIC X(25) VALUE "EMERGENCIA INTERNACIONAL".
03 P10 PIC X(25) VALUE "PLANO GLOBAL".
01 TUN1 REDEFINES TABPLANO.
03 TPLANO PIC X(25) OCCURS 10 TIMES.
*
*-------------------[ SECAO DE TELA ]------------------------
SCREEN SECTION.
01 TELACONV.
05 BLANK SCREEN.
05 LINE 02 COLUMN 01
VALUE " CADASTRO DE".
05 LINE 02 COLUMN 41
VALUE "CONVENIO".
05 LINE 04 COLUMN 01
VALUE " CODIGO:".
05 LINE 06 COLUMN 01
VALUE " NOME:".
05 LINE 08 COLUMN 01
VALUE " PLANO:".
05 LINE 23 COLUMN 01
VALUE " MENSAGEM".
05 T-CODIGO
LINE 04 COLUMN 10 PIC 9(04)
USING CODIGO.
05 T-NOMEC
LINE 06 COLUMN 08 PIC X(30)
USING NOMEC.
05 T-PLANO
LINE 08 COLUMN 09 PIC 9(02)
USING PLANO.
05 T-PLAN
LINE 08 COLUMN 12 PIC X(25)
USING PLAN.
05 TMENS
LINE 23 COLUMN 12 PIC X(50)
USING MENS.
*
01 TELAPLAN.
05 LINE 10 COLUMN 01
VALUE " TABELA DE".
05 LINE 10 COLUMN 41
VALUE " PLANOS".
05 LINE 12 COLUMN 01
VALUE " TECLE ESC PA".
05 LINE 12 COLUMN 41
VALUE "RA NAVEGAR".
05 LINE 14 COLUMN 01
VALUE " 1- ENFERMARIA REGIONAL 2- ENFERMARIA".
05 LINE 14 COLUMN 41
VALUE "NACIONAL 3- ENFERMARIA INTERNACIONAL".
05 LINE 16 COLUMN 01
VALUE " 4- APTO PADRAO REGIONAL 5- A".
05 LINE 16 COLUMN 41
VALUE "PTO PADRAO NACIONAL".
05 LINE 18 COLUMN 01
VALUE " 6- APTO PADRAO INTERNACIONAL 7- EMERG".
05 LINE 18 COLUMN 41
VALUE "ENCIA REGIONAL 8- EMERGENCIA NACIONAL".
05 LINE 20 COLUMN 01
VALUE " 9- EMERGENCIA INTERNACIONAL".
05 LINE 20 COLUMN 41
VALUE "10- PLANO GLOBAL".
*
*-------------------[ DIVISAO DE PROCEDIMENTOS ]------------------
PROCEDURE DIVISION.
INICIO.
*
INC-OP0.
OPEN I-O CADCONV
IF ST-ERRO NOT = "00"
IF ST-ERRO = "30"
OPEN OUTPUT CADCONV
CLOSE CADCONV
MOVE "* ARQUIVO CADCONV SENDO CRIADO *"
TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO INC-OP0
ELSE
MOVE "ERRO NA ABERTURA DO ARQUIVO CADCONV"
TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO ROT-FIM
ELSE
NEXT SENTENCE.
INC-001.
MOVE ZEROS TO CODIGO PLANO.
MOVE SPACES TO NOMEC PLAN.
DISPLAY TELACONV.
INC-002.
ACCEPT T-CODIGO
ACCEPT W-ACT FROM ESCAPE KEY
IF W-ACT = 02
CLOSE CADCONV
GO TO ROT-FIM.
IF CODIGO = ZEROS
MOVE "*** CODIGO NAO PODE SER ZERO ***" TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO INC-002.
MOVE 1 TO IND1
MOVE T1(IND1) TO PLANO.
MOVE TPLANO(IND1) TO PLAN.
DISPLAY T-PLANO T-PLAN.
LER-CADMED01.
MOVE 0 TO W-SEL
READ CADCONV
IF ST-ERRO NOT = "23"
IF ST-ERRO = "00"
MOVE 1 TO W-SEL
PERFORM INC-004A THRU INC-004B
DISPLAY TELACONV
MOVE "*** CONVENIO JA CADASTRADO ***" TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
MOVE 1 TO W-SEL
GO TO ACE-001
ELSE
MOVE "ERRO NA LEITURA DO ARQUIVO CADCONV" TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO ROT-FIM
ELSE
NEXT SENTENCE.
INC-003.
ACCEPT T-NOMEC
ACCEPT W-ACT FROM ESCAPE KEY
IF W-ACT = 02 GO TO INC-002.
IF NOMEC = SPACES
MOVE "NOME NAO PODE SER BRANCO" TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO INC-003.
INC-004.
DISPLAY TELAPLAN
ACCEPT T-PLANO
MOVE TPLANO(PLANO) TO PLAN.
DISPLAY T-PLANO T-PLAN
ACCEPT W-ACT FROM ESCAPE KEY
IF W-ACT = 02
DISPLAY TELACONV
GO TO INC-003.
IF W-ACT = 01
IF IND1 = 10
GO TO INC-100
ELSE
ADD 01 TO IND1
GO TO INC-101.
IF PLANO = ZEROS
MOVE "PLANO NAO PODE SER ZERO" TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO INC-004.
GO TO INC-004A.
INC-100.
MOVE 01 TO IND1
MOVE T1(IND1) TO PLANO
MOVE TPLANO(IND1) TO PLAN
DISPLAY T-PLANO T-PLAN
GO TO INC-004.
INC-101.
MOVE T1(IND1) TO PLANO
MOVE TPLANO(IND1) TO PLAN
DISPLAY T-PLANO T-PLAN
GO TO INC-004.
INC-004A.
MOVE 1 TO IND1.
INC-004B.
MOVE T1(IND1) TO ALFAUN
IF PLANO NOT = ALFAUN
IF IND1 < 10
ADD 1 TO IND1
GO TO INC-004B
ELSE
IF W-SEL = 0
MOVE "PLANO INVALIDO" TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO INC-004
ELSE
MOVE ALL "-" TO PLAN
ELSE
MOVE TPLANO(IND1) TO PLAN.
DISPLAY TELAPLAN.
INC-015.
ACCEPT W-ACT FROM ESCAPE KEY
IF W-ACT = 02
GO TO INC-004.
*
IF W-SEL = 1
GO TO ALT-OPC.
INC-OPC.
MOVE "S" TO W-OPCAO
DISPLAY (23, 40) "DADOS OK (S/N) : ".
ACCEPT (23, 57) W-OPCAO WITH UPDATE
ACCEPT W-ACT FROM ESCAPE KEY
IF W-ACT = 02 GO TO INC-004.
IF W-OPCAO = "N" OR "n"
MOVE "* DADOS RECUSADOS PELO OPERADOR *" TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO INC-001.
IF W-OPCAO NOT = "S" AND "s"
MOVE "*** DIGITE APENAS S=SIM e N=NAO ***" TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO INC-OPC.
INC-WR1.
WRITE REGCONV
IF ST-ERRO = "00" OR "02"
MOVE "*** DADOS GRAVADOS *** " TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO INC-001.
IF ST-ERRO = "22"
MOVE "*** CONVENIO JA EXISTE *** " TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO INC-001
ELSE
MOVE "ERRO NA GRAVACAO DO ARQUIVO DE CONVENIOS"
TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO ROT-FIM.
*
*****************************************
* ROTINA DE CONSULTA/ALTERACAO/EXCLUSAO *
*****************************************
*
ACE-001.
DISPLAY (23, 12)
"F1=NOVO REGISTRO F2=ALTERAR F3=EXCLUIR"
ACCEPT (23, 55) W-OPCAO
ACCEPT W-ACT FROM ESCAPE KEY
IF W-ACT NOT = 02 AND W-ACT NOT = 03 AND W-ACT NOT = 04
GO TO ACE-001.
MOVE SPACES TO MENS
DISPLAY (23, 12) MENS
IF W-ACT = 02
MOVE 02 TO W-SEL
GO TO INC-001.
IF W-ACT = 03
GO TO INC-003.
*
EXC-OPC.
DISPLAY (23, 40) "EXCLUIR (S/N) : ".
ACCEPT (23, 57) W-OPCAO
IF W-OPCAO = "N" OR "n"
MOVE "*** REGISTRO NAO EXCLUIDO ***" TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO INC-001.
IF W-OPCAO NOT = "S" AND "s"
MOVE "* DIGITE APENAS S=SIM e N=NAO *" TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO EXC-OPC.
EXC-DL1.
DELETE CADCONV RECORD
IF ST-ERRO = "00"
MOVE "*** REGISTRO EXCLUIDO *** " TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO INC-001.
MOVE "ERRO NA EXCLUSAO DO REGISTRO " TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO ROT-FIM.
*
ALT-OPC.
DISPLAY (23, 40) "ALTERAR (S/N) : ".
ACCEPT (23, 57) W-OPCAO
ACCEPT W-ACT FROM ESCAPE KEY
IF W-ACT = 02 GO TO INC-004.
IF W-OPCAO = "N" OR "n"
MOVE "*** INFORMACOES NAO ALTERADAS *** " TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO INC-001.
IF W-OPCAO NOT = "S" AND "s"
MOVE "* DIGITE APENAS S=SIM e N=NAO *" TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO ALT-OPC.
ALT-RW1.
REWRITE REGCONV
IF ST-ERRO = "00" OR "02"
MOVE "*** REGISTRO ALTERADO *** " TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO INC-001.
MOVE "ERRO NA EXCLUSAO DO REGISTRO PRODUTO" TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO ROT-FIM.
*
**********************
* ROTINA DE FIM *
**********************
*
ROT-FIM.
CLOSE CADCONV
DISPLAY (01, 01) ERASE
EXIT PROGRAM.
ROT-FIMP.
EXIT PROGRAM.
ROT-FIMS.
STOP RUN.
*
**********************
* ROTINA DE MENSAGEM *
**********************
*
ROT-MENS.
MOVE ZEROS TO W-CONT.
ROT-MENS1.
DISPLAY TMENS.
ROT-MENS2.
ADD 1 TO W-CONT
IF W-CONT < 3000
GO TO ROT-MENS2
ELSE
MOVE LIMPA TO MENS
DISPLAY TMENS.
ROT-MENS-FIM.
EXIT.
FIM-ROT-TEMPO.