-
Notifications
You must be signed in to change notification settings - Fork 1
/
SMP002.COB
255 lines (252 loc) · 9.29 KB
/
SMP002.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
IDENTIFICATION DIVISION.
PROGRAM-ID. SMP002.
AUTHOR. JULIO CESAR DA SILVA BARCELLOS.
**************************************
* MANUTENCAO DO CADASTRO DE CID *
**************************************
*----------------------------------------------------------------
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SPECIAL-NAMES.
DECIMAL-POINT IS COMMA.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT CADCID ASSIGN TO DISK
ORGANIZATION IS INDEXED
ACCESS MODE IS DYNAMIC
RECORD KEY IS CODCID
FILE STATUS IS ST-ERRO
ALTERNATE RECORD IS DENOMINACAO WITH DUPLICATES.
*
*-----------------------------------------------------------------
DATA DIVISION.
FILE SECTION.
FD CADCID
LABEL RECORD IS STANDARD
VALUE OF FILE-ID IS "CADCID.DAT".
01 REGCID.
03 CODCID PIC 9(04).
03 DENOMINACAO PIC X(30).
*
*-----------------------------------------------------------------
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 FLAG1 PIC 9(02) VALUE ZEROS.
*
*-------------------[ SECAO DE TELA ]------------------------
SCREEN SECTION.
01 TELACID.
05 BLANK SCREEN.
05 LINE 02 COLUMN 01
VALUE " CADASTRO DE".
05 LINE 02 COLUMN 41
VALUE "CID".
05 LINE 04 COLUMN 01
VALUE " CODIGO:".
05 LINE 06 COLUMN 01
VALUE " DENOMINACAO:".
05 LINE 23 COLUMN 01
VALUE " MENSAGEM".
05 T-CODCID
LINE 04 COLUMN 10 PIC 9(04)
USING CODCID.
05 T-DENOMINACAO
LINE 06 COLUMN 15 PIC X(30)
USING DENOMINACAO.
05 TMENS
LINE 23 COLUMN 12 PIC X(50)
USING MENS.
*
*-------------------[ DIVISAO DE PROCEDIMENTOS ]------------------
PROCEDURE DIVISION.
INICIO.
*
INC-OP0.
OPEN I-O CADCID
IF ST-ERRO NOT = "00"
IF ST-ERRO = "30"
OPEN OUTPUT CADCID
CLOSE CADCID
MOVE "* ARQUIVO CADCID SENDO CRIADO *"
TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO INC-OP0
ELSE
MOVE "ERRO NA ABERTURA DO ARQUIVO CADCID"
TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO ROT-FIM
ELSE
NEXT SENTENCE.
INC-001.
MOVE ZEROS TO CODCID
MOVE SPACES TO DENOMINACAO
DISPLAY TELACID.
INC-002.
ACCEPT T-CODCID
ACCEPT W-ACT FROM ESCAPE KEY
IF W-ACT = 02
CLOSE CADCID
GO TO ROT-FIM.
IF CODCID = ZEROS
MOVE "*** CODIGO NAO PODE SER ZERO ***" TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO INC-002.
LER-CADMED01.
MOVE 0 TO W-SEL
READ CADCID
IF ST-ERRO NOT = "23"
IF ST-ERRO = "00"
MOVE 1 TO W-SEL
DISPLAY TELACID
MOVE "*** CID 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 CADCID" TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO ROT-FIM
ELSE
NEXT SENTENCE.
INC-003.
ACCEPT T-DENOMINACAO
ACCEPT W-ACT FROM ESCAPE KEY
IF W-ACT = 02 GO TO INC-002.
IF DENOMINACAO = SPACES
MOVE "DENOMINACAO NAO PODE SER VAZIO" TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO INC-003.
*
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-003.
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 REGCID
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 "*** CID JA EXISTE *** " TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO INC-001
ELSE
MOVE "ERRO NA GRAVACAO DO ARQUIVO DE CID"
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 CADCID 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-003.
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 REGCID
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 CID" TO MENS
PERFORM ROT-MENS THRU ROT-MENS-FIM
GO TO ROT-FIM.
*
**********************
* ROTINA DE FIM *
**********************
*
ROT-FIM.
CLOSE CADCID
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.