Cobol, exemplo do código fonte de um programa
Este é um programa de exemplo; a estrutura (a lógica) utilizada é muito simples, pois neste momento temos o obetivo de demonstrar com clareza apenas a diferença no tratamento ao arquivo/tabela para cada opção selecionada.$set ms"2" *----------------------------------------------------------------* * * * programa exemplo 1 * * * *----------------------------------------------------------------* identification division. program-id. ptst1. author. emporio. date-written. 10/09/2003. *last-update. 20/09/2003 - gilmar. environment division. configuration section. special-names. decimal-point is comma. input-output section. file-control. select fcat assign to disk organization indexed access dynamic record cat-key status fs-cat. select fprn assign to printer label-fprn. select fsrt assign to disk sort status fs-srt. data division. file section. *-----> arquivo categorias <-----* fd fcat label record is standard value of file-id is 'fcat.dat' record contains 096 characters. 01 reg-fcat. 02 cat-key. 006 04 cat-codigo pic 9(06). 036 02 cat-descricao pic x(30). 044 02 cat-valor pic 9(06)V99. 096 02 cat-f pic x(52). fd fprn label record is omitted. 01 reg-prn. 05 prn-linha pic x(132). sd fsrt value of file-id is label-fsrt. 01 r-srt. 02 srt-codigo pic 9(06). 02 srt-descricao pic x(30). *-----> <-----* working-storage section. 01 ws-fields. 03 ws-tot-imp pic 9(09) value zeroes. 03 ws-codigo1 pic 9(06) value zeroes. 03 ws-codigo2 pic 9(06) value zeroes. 03 ws-pagina pic 9(06) value zeroes. 03 ws-opcao pic 9(01) value zeroes. 03 ws-linha pic 9(03) value zeroes. 03 ws-class pic 9(01) value zeroes. 03 ws-conf pic x(01) value spaces. 03 fs-cat pic x(02) value spaces. 03 fs-ax1 pic x(02) value spaces. 03 fs-srt pic x(02) value spaces. 03 i1 pic 9(03) value zeroes. 03 i2 pic 9(03) value zeroes. 03 label-fprn pic x(12) value spaces. 03 label-fprn-r redefines label-fprn. 05 label-fprn-nome pic x(09). 05 label-fprn-exte pic 9(03). 03 label-fsrt pic x(12) value spaces. 03 label-fsrt-r redefines label-fsrt. 05 label-fsrt-nome pic x(09). 05 label-fsrt-exte pic 9(03). 03 wk-data pic 9(08) value zeroes. 03 wk-data-r redefines wk-data. 05 wk-ano pic 9(04). 05 wk-mes pic 9(02). 05 wk-dia pic 9(02). *-----> secao: linhas de impressao <-----* 01 linha00. 02 f pic x(10) value spaces. 02 f pic x(70) value all "-". 01 linha01. 02 f pic x(10) value spaces. 02 l01-empresa pic x(52) value "EMPORIO BRASIL.ETI". 02 f pic x(08) value "DATA..:". 02 l01-dia pic 99/. 02 l01-mes pic 99/. 02 l01-ano pic 9999. 01 linha02. 02 f pic x(10) value spaces. 02 f pic x(52) value "PCCAT-RELACAO CATEGORIAS - VERSAO 1.00". 02 f pic x(12) value "PAGINA:". 02 l02-pagina pic zz.zz9. 01 linha03. 02 f pic x(10) value spaces. 02 f pic x(07) value "CODIGO". 02 f pic x(10) value "DESCRICAO". 01 linha04. 02 f pic x(10) value spaces. 02 l04-cat-codigo pic 9(06)b. 02 l04-cat-descricao pic x(30)b. 01 linha90. 02 f pic x(10) value spaces. 02 f pic x(16) value 'TOTAL IMPRESSO:'. 02 l90-tot-imp pic zzz.zzz.zzzb. 02 f pic x(11) value 'REGISTRO(S)'. *-----> <-----* screen section. 01 tela-opcao1. 02 line 01 column 01 blank screen. 02 line 06 column 18 '+- Opcoes: -- ? - x +'. 02 line 07 column 18 '| |'. 02 line 08 column 18 '| | Inclusao |'. 02 line 09 column 18 '| | Alteracao |'. 02 line 10 column 18 '| | Exclusao |'. 02 line 11 column 18 '| | Consulta |'. 02 line 12 column 18 '| | Relacao |'. 02 line 13 column 18 '| |'. 02 line 14 column 18 '+-------------------+'. 01 accept-opcao1a auto. 02 tit-opcao1a line 08 column 20 '> Inclusao '. 02 tit-opcao1b line 09 column 20 '> Alteracao '. 02 tit-opcao1c line 10 column 20 '> Exclusao '. 02 tit-opcao1d line 11 column 20 '> Consulta '. 02 tit-opcao1e line 12 column 20 '> Relacao '. 01 help-opcao1. 02 line 08 column 25 '+------------------------------- x +'. 02 line 09 column 25 '| |'. 02 line 10 column 25 '| x sai do programa ou tela atual |'. 02 line 11 column 25 '| - opcao anterior |'. 02 line 12 column 25 '| + proxima opcao |'. 02 line 13 column 25 '| |'. 02 line 14 column 25 '| qualquer outra tecla seleciona |'. 02 line 15 column 25 '| a opcao atual |'. 02 line 16 column 25 '| |'. 02 line 17 column 25 '+----------------------------------+'. 01 tela-opcao2. 02 line 08 column 25 '+- Op‡äes: ------ x +'. 02 line 09 column 25 '| |'. 02 line 10 column 25 '| | Numerico |'. 02 line 11 column 25 '| | Alfabetico |'. 02 line 12 column 25 '| |'. 02 line 13 column 25 '+-------------------+'. 01 accept-opcao2a auto. 02 tit-opcao2a line 10 column 27 '> Numerico '. 02 tit-opcao2b line 11 column 27 '> Alfabetico '. 01 tela-manutencao1. 02 line 04 column 10 '+- Manutencao Categorias -------------------------------- x +'. 02 line 05 column 10 '| |'. 02 line 06 column 10 '| Codigo.......: ______ |'. 02 line 07 column 10 '| |'. 02 line 08 column 10 '| Descricao....: ______________________________ |'. 02 line 09 column 10 '| |'. 02 line 10 column 10 '| |'. 02 line 11 column 10 '| |'. 02 line 12 column 10 '| |'. 02 line 13 column 10 '| |'. 02 line 14 column 10 '| |'. 02 line 15 column 10 '| |'. 02 line 16 column 10 '| |'. 02 line 17 column 10 '| |'. 02 line 18 column 10 '| |'. 02 line 19 column 10 '| |'. 02 line 20 column 10 '| |'. 02 line 21 column 10 '| Confirma S/N.: _ |'. 02 line 22 column 10 '+-----------------------------------------------------------+'. 01 accept-manutencao1 auto. 02 tm1-codigo line 06 column 27 pic 9(06) using cat-codigo. 02 tm1-descri line 08 column 27 pic x(30) using cat-descricao. 02 tm1-conf line 21 column 27 pic x(01) using ws-conf. 01 tela-relacao1. 02 line 04 column 10 '+- Consulta Categorias ---------------------------------- x +'. 02 line 05 column 10 '| |'. 02 line 06 column 10 '| Codigo.......: ______ a ______ |'. 02 line 07 column 10 '| |'. 02 line 08 column 10 '| Classificacao: _ ________ |'. 02 line 09 column 10 '| |'. 02 line 10 column 10 '| |'. 02 line 11 column 10 '| |'. 02 line 12 column 10 '| |'. 02 line 13 column 10 '| |'. 02 line 14 column 10 '| |'. 02 line 15 column 10 '| |'. 02 line 16 column 10 '| |'. 02 line 17 column 10 '| |'. 02 line 18 column 10 '| |'. 02 line 19 column 10 '| |'. 02 line 20 column 10 '| |'. 02 line 21 column 10 '| Confirma S/N.: _ |'. 02 line 22 column 10 '+-----------------------------------------------------------+'. 01 accept-relacao1 auto. 02 tr1-codigo1 line 06 column 27 pic 9(06) using ws-codigo1. 02 tr1-codigo2 line 06 column 36 pic 9(06) using ws-codigo2. 02 tr1-class line 08 column 27 pic 9(01) using ws-class. 02 tr1-conf line 21 column 27 pic x(01) using ws-conf. ****************************************************************** ****************** p r o c e d u r e ************************ ****************************************************************** procedure division. *-----> <-----* r001-inicio section. r001. accept wk-data from date. r001-opcao1. display tela-opcao1. if ws-opcao = zeroes move 5 to ws-opcao. if ws-opcao > 5 move 1 to ws-opcao. if ws-opcao = 1 display tit-opcao1a. if ws-opcao = 2 display tit-opcao1b. if ws-opcao = 3 display tit-opcao1c. if ws-opcao = 4 display tit-opcao1d. if ws-opcao = 5 display tit-opcao1e. move spaces to ws-conf. accept (07, 19) ws-conf with update auto-skip. if ws-conf = 'x' or = 'X' go to r001-finalizacao. if ws-conf = '?' display help-opcao1 move 'x' to ws-conf accept (06, 36) ws-conf with update auto-skip go to r001-opcao1. if ws-conf = '-' subtract 1 from ws-opcao go to r001-opcao1. if ws-conf = '+' add 1 to ws-opcao go to r001-opcao1. r001-open-fcat. open input fcat. if fs-cat = '00' go to r001-ver-opcao. if fs-cat not = '30' and fs-cat not = '35' close fcat display (22, 12) " ERRO: abertura arquivo fcat.dat; tecle ENTER " accept (22, 69) ws-conf with prompt auto-skip go to r001-opcao1. close fcat. r001-cria-fcat. display (22, 12) " ATENCAO: Deseja criar arquivo categorias S/N: _ ". accept (22, 59) ws-conf with prompt auto-skip. if ws-conf = 'N' or = "n" go to r001-opcao1. if ws-conf not = 'S' and not = "s" go to r001-cria-fcat. open output fcat. close fcat. go to r001-open-fcat. r001-ver-opcao. if ws-opcao = 1 perform r010-inclusao. if ws-opcao = 2 perform r020-alteracao. if ws-opcao = 3 perform r030-exclusao. if ws-opcao = 4 perform r040-consulta. if ws-opcao = 5 perform r050-relacao close fcat go to r001-finalizacao. close fcat. go to r001-opcao1. r001-finalizacao. display (01, 01) erase. display (01, 01) "Final Programa". stop run. r001-fim. exit. *-----> <-----* r010-inclusao section. r010. display tela-manutencao1. display (22, 12) " informe o codigo da categoria, 0 volta menu". move zeroes to cat-codigo. accept tm1-codigo. if cat-codigo = zeroes go to r010-exit. read fcat invalid key go to r010-zera-dados. display (22, 12) " ATENCAO: Registro ja cadastrado; tecle ENTER ". accept (22, 69) ws-conf with prompt auto-skip. go to r010-inclusao. r010-zera-dados. move spaces to cat-descricao. move zeroes to cat-valor. move zeroes to cat-f. perform r080-accept-dados. if ws-conf = 'X' or = 'x' go to r010-exit. if ws-conf = 'N' or = 'n' go to r010-inclusao. close fcat. open i-o fcat. write reg-fcat. if fs-cat not = '00' display (22, 12) " ERRO: gravacao registro; tecle ENTER " accept (22, 69) ws-conf with prompt auto-skip. close fcat. open input fcat. go to r010-inclusao. r010-exit. exit. *-----> <-----* r020-alteracao section. r020. display tela-manutencao1. display (22, 12) " informe o codigo da categoria, 0 volta menu". move zeroes to cat-codigo. accept tm1-codigo. if cat-codigo = zeroes go to r020-exit. read fcat invalid key display (22, 12) " ATENCAO: Registro nao cadastrado; tecle ENTER " accept (22, 69) ws-conf with prompt auto-skip go to r020-alteracao. perform r090-mostra-dados. perform r080-accept-dados. if ws-conf = 'X' or = 'x' go to r020-exit. if ws-conf = 'N' or = 'n' go to r020-alteracao. close fcat. open i-o fcat. rewrite reg-fcat. if fs-cat not = '00' display (22, 12) " ERRO: regravacao registro; tecle ENTER " accept (22, 69) ws-conf with prompt auto-skip. close fcat. open input fcat. go to r020-alteracao. r020-exit. exit. *-----> <-----* r030-exclusao section. r030. display tela-manutencao1. display (22, 12) " informe o codigo da categoria, 0 volta menu". move zeroes to cat-codigo. accept tm1-codigo. if cat-codigo = zeroes go to r030-exit. read fcat invalid key display (22, 12) " ATENCAO: Registro nao cadastrado; tecle ENTER " accept (22, 69) ws-conf with prompt auto-skip go to r030-exclusao. perform r090-mostra-dados. accept tm1-conf. if ws-conf = 'X' or = 'x' go to r030-exit. if ws-conf not = 'S' and not = 's' go to r030-exclusao. close fcat. open i-o fcat. delete fcat. if fs-cat not = '00' display (22, 12) " ERRO: exclusao registro; tecle ENTER " accept (22, 69) ws-conf with prompt auto-skip. close fcat. open input fcat. go to r030-exclusao. r030-exit. exit. *-----> <-----* r040-consulta section. r040. display tela-manutencao1. display (22, 12) " informe o codigo da categoria, 0 volta menu". move zeroes to cat-codigo. accept tm1-codigo. if cat-codigo = zeroes go to r040-exit. read fcat invalid key display (22, 12) " ATENCAO: Registro nao cadastrado; tecle ENTER " accept (22, 69) ws-conf with prompt auto-skip go to r040-consulta. perform r090-mostra-dados. accept tm1-conf. go to r040-consulta. r040-exit. exit. *-----> <-----* r050-relacao section. r050. display tela-relacao1. move 'lstcat00.' to label-fprn-nome. move 001 to label-fprn-exte. move 'srtcat00.' to label-fsrt-nome. move 001 to label-fsrt-exte. move 1 to ws-codigo1. move all '9' to ws-codigo2. move 1 to ws-class. display (08, 32) 'NUMERICO '. move spaces to ws-conf. display accept-relacao1. display (22, 12) " informe o codigo da categoria, 0 volta menu". r050-codigo1. accept tr1-codigo1. if ws-codigo1 = zeroes go to r050-exit. r050-codigo2. accept tr1-codigo2. r050-class. display tela-opcao2. if ws-class = zeroes move 1 to ws-class. if ws-class > 2 move 1 to ws-class. if ws-class = 1 display tit-opcao2a. if ws-class = 2 display tit-opcao2b. move spaces to ws-conf. accept (09, 26) ws-conf with update auto-skip. if ws-conf = 'x' or = 'X' go to r050-relacao. if ws-conf = '-' subtract 1 from ws-class go to r050-class. if ws-conf = '+' add 1 to ws-class go to r050-class. display tela-relacao1. display accept-relacao1. if ws-class = 1 display (08, 32) 'NUMERICO '. if ws-class = 2 display (08, 32) 'ALFABETICO'. r050-conf. accept tr1-conf. if ws-conf = 'x' or = 'X' go to r050-exit. if ws-conf = 'N' or = 'n' go to r050-relacao. if ws-conf not = 'S' and not = 's' go to r050-conf. if ws-class = 1 sort fsrt on ascending key srt-codigo input procedure r060-entrada output procedure r070-saida. if ws-class = 2 sort fsrt on ascending key srt-descricao input procedure r060-entrada output procedure r070-saida. r050-exit. exit. *-----> <-----* r060-entrada section. r060. move zeroes to cat-key. move ws-codigo1 to cat-codigo. start fcat key is not less cat-key invalid key go to r060-exit. r060-ler-fcat. read fcat next at end go to r060-exit. display (22, 20) 'Classificando:'. display (22, 35) cat-codigo. if ws-codigo2 not = zeroes and cat-codigo > ws-codigo2 go to r060-exit. move cat-codigo to srt-codigo. move cat-descricao to srt-descricao. release r-srt. go to r060-ler-fcat. r060-exit. exit. *-----> <-----* r070-saida section. r070. open output fprn. move wk-dia to l01-dia. move wk-mes to l01-mes. move wk-ano to l01-ano. move zeroes to ws-tot-imp. move zeroes to ws-pagina. move 90 to ws-linha. r070-return. return fsrt at end go to r070-final-rol. display (22, 20) 'Processando..:'. display (22, 35) srt-codigo. move srt-codigo to l04-cat-codigo. move srt-descricao to l04-cat-descricao. add 1 to ws-tot-imp. add 1 to ws-linha. if ws-linha > 60 perform r070-cabecalho add 1 to ws-linha. write reg-prn from linha04. go to r070-return. r070-cabecalho. add 1 to ws-pagina. move ws-pagina to l02-pagina. if ws-pagina > 1 write reg-prn from linha00. write reg-prn from linha00 after page. write reg-prn from linha01. write reg-prn from linha02. write reg-prn from linha00. write reg-prn from linha03. write reg-prn from linha00. move spaces to reg-prn. write reg-prn. move 7 to ws-linha. r070-final-rol. move ws-tot-imp to l90-tot-imp. write reg-prn from linha90 after 02. write reg-prn from linha00 after 01. move " Final Relatorio" to reg-prn. write reg-prn. close fprn. r070-exit. exit. *-----> <-----* r080-accept-dados section. r080-descricao. display (22, 12) " informe a descricao da categoria". accept tm1-descri. if cat-descricao = spaces go to r080-descricao. r080-conf. display (22, 12) " confirme a operacao S=sim N=nao X=cancela/sai". accept tm1-conf. if ws-conf = 'x' or = 'X' go to r080-exit. if ws-conf = 'N' or = 'n' go to r080-exit. if ws-conf not = 'S' and not = 's' go to r080-conf. r080-exit. exit. *-----> <-----* r090-mostra-dados section. r090. display tm1-descri. r090-exit. exit.