API tools faq
paste
Advertisement
Guest User

Untitled

a guest
Dec 1st, 2017
107
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
COBOL 11.67 KB | None | 0 0
raw download clone embed print report
  1.        Identification Division.
  2.        Program-Id.   BEM-DAT.
  3.  
  4.        Environment Division.
  5.        special-names.   decimal-point is comma.
  6.        input-output section.
  7.        file-control.
  8.            select BEM assign to disk
  9.            organization indexed
  10.            access mode dynamic
  11.            record key CODIGO-BEM
  12.            alternate record key desc-BEM
  13.            file status arqst-bem.
  14.            
  15.            select TIPOS assign to disk
  16.            organization indexed
  17.            access mode dynamic
  18.            record key CODIGO-TIPO
  19.            alternate record key DESCRICAO-TIPO
  20.            file status arqst-tipos.
  21.  
  22.        data division.
  23.        file section.
  24.        fd  BEM label record standard
  25.            value of file-id is "BEM.dat".
  26.        01 reg-BEM.
  27.            02 codigo-BEM    pic 9(04).
  28.            02 desc-BEM      pic x(30).
  29.            02 DT-AQUISICAO  pic 9(08).
  30.            02 cd-TIPO       pic 9(04).
  31.            02 VALOR-COMPRA  PIC 9(06)V99.
  32.            02 NOTA-FISCAL   PIC  9(15).
  33.            
  34.            
  35.        fd  TIPOS label record standard
  36.            value of file-id is "TIPOS.dat".
  37.        01 reg-TIPO.
  38.            02 CODIGO-TIPO       pic 9(04).
  39.            02 DESCRICAO-TIPO    pic x(30).
  40.  
  41.        working-storage section.
  42.        01 reg-BEM-e.
  43.            02 codigo-BEM-E    pic 9(04).
  44.            02 desc-BEM-E      pic x(30).
  45.            02 DT-AQUISICAO-E  pic 9(08).
  46.            02 cd-TIPO-E       pic 9(04).
  47.            02 VALOR-COMPRA-E  PIC ZZZZZ,ZZ.
  48.            02 NOTA-FISCAL-E   PIC  9(15).
  49.  
  50.        01 reg-TIPO-e.
  51.            02 CODIGO-TIPO-E       pic 9(04).
  52.            02 DESCRICAO-TIPO-E    pic x(30).
  53.          
  54.  
  55.        01 data-sis.
  56.            02 ano   pic 9999.
  57.            02 mes   pic 99.
  58.            02 dia   pic 99.
  59.      
  60.        01 desmes.
  61.           02 filler pic x(10) value "Janeiro".
  62.           02 filler pic x(10) value "Fevereiro".
  63.           02 filler pic x(10) value "Mar‡o".
  64.           02 filler pic x(10) value "Abril".
  65.           02 filler pic x(10) value "Maio".
  66.           02 filler pic x(10) value "Junho".
  67.           02 filler pic x(10) value "Julho".
  68.           02 filler pic x(10) value "Agosto".
  69.           02 filler pic x(10) value "Setembro".
  70.           02 filler pic x(10) value "Outubro".
  71.           02 filler pic x(10) value "Novembro".
  72.           02 filler pic x(10) value "Dezembro".
  73.        
  74.  
  75.        01 tabela-meses redefines desmes.
  76.            02 mes-t    pic x(10) occurs 12 times.
  77.        
  78.        01 arqst-bem     pic x(2).
  79.        01 arqst-tipos     pic x(2).
  80.        01 op           pic x(1) value spaces.
  81.        01 salva        pic x(1) value spaces.
  82.        01 wigual       pic 9 value zeros.
  83.        01 espaco       pic x(60) value spaces.
  84.        01 op-continua  pic x(1)  value spaces. 
  85.  
  86.        screen section.
  87.        01 tela1.
  88.           02 BLANK SCREEN.
  89.           02 line 02 col 5 value "Santos,    de            de     .".
  90.           02 line 02 col 55 value "Nome da Empresa qota".
  91.           02 line 04 col 29 value "Controle de Patrimonio" highlight.
  92.           02 line 06 col 29 value "1. Inclusao de novos BENS".
  93.           02 line 08 col 29 value "2. Alteracao de BENS Cadastrados".
  94.           02 line 10 col 29 value "3. Exclusao de BENS Cadastrados".
  95.           02 line 12 col 29 value "4. Consulta por Codigo".
  96.           02 line 14 col 29 value "4. Consulta por DESCRIÇAO".
  97.           02 line 16 col 29 value "5. Retorno".
  98.           02 line 20 col 25 value "Escolha uma Opcao:".
  99.  
  100.        01 tela2.
  101.            02 BLANK SCREEN.
  102.            02 line 02 col 05 value "Santos,    de           de     .".
  103.            02 line 03 col 19 value "Codigo BEM: ".
  104.            02 line 04 col 19 value "Codigo tipo: ".
  105.            02 line 06 col 19 value "tipo do bem ".
  106.            02 line 08 col 19 value "Nome BEM: ".
  107.            02 line 10 col 19 value "Dta de aquisicao: ".
  108.            02 line 12 col 19 value "valor da compra: ".
  109.            02 line 14 col 19 value "nota fiscal: ".
  110.            
  111.        Procedure Division.
  112.        Inicio.
  113.        
  114.            Perform abre-arq-bem.
  115.            perform abre-arq-tipo.
  116.            Perform abertura until op = "5".
  117.            CLOSE TIPOS.
  118.            CLOSE BEM.
  119.            STOP run.
  120.        
  121.        
  122.        abre-arq-tipo.
  123.            open i-o TIPOS.
  124.            if arqst-tipos not = "00"
  125.                display "erro de abertura tipos" at 2155
  126.                stop " "
  127.                close TIPOS
  128.                STOP RUN.
  129.  
  130.        abre-arq-bem.
  131.            open i-o BEM.
  132.            if arqst-bem not = "00"
  133.                display "erro de abertura bem" at 2155
  134.                close BEM
  135.                open output BEM
  136.                STOP RUN.
  137.  
  138.        abertura.
  139.            
  140.            display tela1.
  141.            Perform mostra-data.
  142.            accept op at 2045 WITH PROMPT AUTO.
  143.            move spaces to op-continua
  144.            evaluate op
  145.            when "1"
  146.                perform inclusao until op-continua = "n" or "N"
  147.                
  148.            when "2"
  149.                perform alteracao until op-continua = "n" or "N"
  150.                
  151.            when "3"
  152.                perform exclusao until op-continua = "n" or "N"
  153.            when "4"
  154.                perform consulta until op-continua = "n" or "N".
  155.  
  156.        mostra-data.
  157.            move function current-date to data-sis.
  158.            display dia at 0213.
  159.            display mes-t(mes) at 0219.
  160.            display ano at 0233.
  161.  
  162.        inclusao.
  163.            perform tela-inclusao.
  164.            move zeros to wigual.
  165.            perform inicializar.
  166.            perform testa-cod-bem until wigual = 1.
  167.            perform recebe-dados.
  168.            move zeros to wigual.
  169.            perform testa-cod-tipo until wigual = 1.
  170.            move CODIGO-TIPO to codigo-tipo-e.
  171.            display codigo-tipo-e at 0642.
  172.            perform grava.
  173.            perform continua.
  174.  
  175.  
  176.  
  177.        tela-inclusao.
  178.            display tela2.
  179.            display "Cadastro de Locais" at 0430 with highlight.
  180.            perform mostra-data.
  181.  
  182.        inicializar.
  183.            move spaces to op op-continua salva.
  184.            move spaces to DESCRICAO-TIPO-E desc-BEM-E.
  185.            move zeros  to cd-tipo-e codigo-bem-e codigo-tipo-e NOTA-FISCAL-E DT-AQUISICAO-E .
  186.            move zeros  to wigual.
  187.            display espaco at 2315.
  188.  
  189.        recebe-dados.
  190.            perform testa-desc-bem    until desc-bem-e    not = spaces.
  191.       *   perform testa-area-local    until area-local-e    not = zeros.
  192.            
  193.        testa-data-aq.
  194.            accept DT-AQUISICAO-E at 1032.
  195.            if DT-AQUISICAO-E = spaces then
  196.                 display "Digite a area do local." at 2321
  197.           else
  198.                 display espaco at 2321.
  199.       *   fazer mostra tipo depto
  200.        testa-cod-tipo.
  201.            move 1 to wigual.
  202.            move zeros to codigo-TIPO-E.
  203.            accept codigo-TIPO-E at 0442 with prompt auto.
  204.            if codigo-TIPO-E = zeros or spaces then
  205.                 display "Digite um codigo diferente de zero." at 2321
  206.                 set wigual to 0
  207.            else
  208.                move spaces to espaco.
  209.                 move codigo-TIPO-E to codigo-TIPO
  210.                 read TIPOS not invalid key move reg-TIPO to reg-TIPO-e
  211.                 move codigo-TIPO-E to cd-TIPO-E
  212.                 read TIPOS invalid key perform nao-cadastrado.
  213.                
  214.        nao-cadastrado.
  215.            display "Departamento nao cadastrado" at 2321
  216.            set wigual to 0.
  217.        
  218.        
  219.        testa-cod-bem.
  220.            move 1 to wigual.
  221.            move zeros to codigo-BEM-E.
  222.            accept codigo-BEM-E at 0332 with prompt auto.
  223.            if codigo-BEM-E = zeros or spaces then
  224.                 display "Digite um codigo diferente de zero." at 2321
  225.                 set wigual to 0
  226.            else
  227.                 move spaces to espaco.
  228.                 move codigo-BEM-E to codigo-BEM
  229.                 read BEM not invalid key perform ja-cadastrado.
  230.            
  231.        ja-cadastrado.
  232.            display "Codigo ja cadastrado" at 2321
  233.            set wigual to 0.
  234.  
  235.  
  236.  
  237.  
  238.        testa-desc-bem.
  239.            accept desc-BEM-E at 0832.
  240.            if desc-BEM-E = spaces then
  241.                 display "Digite o nome do local." at 2321
  242.           else
  243.                 display espaco at 2321.
  244.  
  245.        
  246.        grava.
  247.            display "Salvar <S/N> [ ]" at 2321.
  248.            accept salva at 2335 with prompt auto.
  249.            if salva = "S" or "s" then
  250.                 move reg-BEM-e to reg-BEM
  251.                 write reg-BEM
  252.                 if arqst-bem <> "00"                                
  253.                    display arqst-bem at 2221
  254.                    display arqst-tipos at 2321
  255.                    STOP " ".
  256.  
  257.        continua.
  258.            display espaco at 2315.
  259.            display "Continua <S/N> [ ]" at 2321.
  260.            accept op-continua at 2337 with prompt auto.
  261.        
  262.  
  263.        exclusao.
  264.            perform inicializar.
  265.            display erase at 0101.
  266.            display tela2.
  267.            display "Exclusao de bem" at 0430 with highlight.
  268.            perform inicializar.
  269.            perform le-dados.
  270.            if arqst-bem = "00" then
  271.                display "Deseja excluir o registro<S/N> [ ]" at 2319
  272.                accept salva at 2351 with prompt auto
  273.            else
  274.                perform inicializar
  275.                display espaco at 2319
  276.                display "Registro nao encontrado." at 2321.
  277.            if salva = "S" or "s" then
  278.                display espaco at 2319
  279.                Display "Registro apagado." at 2321
  280.                delete BEM.
  281.            stop " ".
  282.            display espaco at 2315.
  283.            perform continua.
  284.  
  285.        estuda-erro.
  286.            display "Codigo nao encontrado." at 2321.
  287.            stop " ".
  288.  
  289.        consulta.
  290.            display erase at 0101.
  291.            display tela2.
  292.            display "Consulta de Registro" at 0430 with highlight.
  293.            perform le-dados.
  294.            perform continua.
  295.  
  296.        le-dados.
  297.            perform inicializar.
  298.            perform mostra-data.
  299.            accept codigo-BEM-E at  0633.
  300.            move codigo-BEM-E to codigo-BEM.
  301.            read BEM key is codigo-BEM invalid key
  302.                display "Local não encontrado" at 2320
  303.                move 1 to wigual
  304.                stop " ".
  305.            if arqst-bem = "00" then
  306.                display espaco at 2319
  307.                perform mostra-tela.
  308.  
  309.  
  310.        mostra-tela.
  311.            move reg-BEM to reg-bem-e.
  312.            move cd-TIPO-E to CODIGO-TIPO.
  313.            read TIPOS key is codigo-tipo not invalid key move reg-tipo to reg-tipo-e.
  314.            display codigo-BEM-E    at 0333.
  315.            display desc-BEM-E      at 0833.  
  316.            display DT-AQUISICAO-E  at 1033.
  317.            display cd-TIPO-E       at 0442.
  318.  
  319.        altera-dados.
  320.            accept codigo-BEM-E     at 0333 with prompt auto.
  321.            accept desc-BEM-E       at 0833.
  322.            accept DT-AQUISICAO-E   at 1033.
  323.            perform testa-cod-tipo until wigual = 1.
  324.       *   move divisao-depto to divisao-depto-e.
  325.       *   display espaco at 1442.
  326.       *   display divisao-depto-e at 1442.
  327.            
  328.        alteracao.
  329.            perform inicializar.
  330.            display erase at 0101.
  331.            display tela2.
  332.            display "Alteracao de Registro" at 0425 with highlight.
  333.            perform le-dados.
  334.  
  335.            if wigual <> 1
  336.               perform altera-dados
  337.               display "Deseja salvar alteracao <S/N> [ ]" at 2319
  338.               accept salva at 2350 with prompt auto
  339.               if salva = "S" or "s" then
  340.                  move reg-BEM-e to reg-BEM
  341.                  rewrite reg-BEM invalid key perform estuda-erro
  342.                  display espaco at 2315.
  343.  
  344.            perform continua.
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!