COBOL Future Date Calculation

Contributed by: Don Stafford, Director of Information Technologies, UAV Entertainment Corporation

We needed a routine to calculate a date in the future, based on business days, not on calendar days. In searching the internet, no COBOL source could be found.
However, several routines were found in various other programming languages.
I took several of those and adapted the code to MicroFocus Cobol. In Working Storage, you need the following variables:       01 CalDays                         PIC 9(3).
      01 BusDays                        PIC 9(3).
      01 DelDay                          PIC 9(3).
      01 DelWks                         PIC 9(3).
      01 WS-DAY-OF-WEEK        PIC 9(2).
      01 DAYS-TO-ADD              PIC 9(3).
      01 DATE-YMD-IN               PIC 9(8).
      01 DATE-YMD-OUT            PIC 9(8).
      01 DATE-DAY                    PIC 9(8). In the Procedure Division, you have 2 paragraphs:       ADD-BUS-DAYS-TO-DATE.          PERFORM GET-DAY-OF-WEEK-FOR-DATE.
         IF WS-DAY-OF-WEEK = 6
            MOVE 5 TO WS-DAY-OF-WEEK
            SUBTRACT 1 FROM DAYS-TO-ADD.          MOVE DAYS-TO-ADD TO CalDays,
                                                        BusDays.          COMPUTE DelDay = WS-DAY-OF-WEEK + DAYS-TO-ADD.          IF DelDay > 5
            COMPUTE BusDays = BusDays - ( 6 - WS-DAY-OF-WEEK )
            COMPUTE CalDays = CalDays + 2
            COMPUTE DelWks = BusDays / 5
            COMPUTE DAYS-TO-ADD = CalDays + (DelWks * 2).           PERFORM ADD-DAYS-TO-DATE.       ADD-DAYS-TO-DATE.          COMPUTE DATE-DAY = FUNCTION INTEGER-OF-DATE (DATE-YMD-IN).
         ADD DAYS-TO-ADD TO DATE-DAY.
         COMPUTE DATE-YMD-OUT = FUNCTION DATE-OF-INTEGER (DATE-DAY). The current (base) date is moved into DATE-YMD-IN.
The number of (business) days to add is moved into DAYS-TO-ADD.
You then call  ADD-BUS-DAYS-TO-DATE.
The resulting date is in DATE-YMD-OUT. Obvious note:  If you call ADD-DAYS-TO-DATE, it simply calculates a date in the future without regards to weekends.
Not-so-obvious note:  If you make ADD-DAYS-TO-DATE a PIC S9(3), then ADD-DAYS-TO-DATE will add or subtract days.  The ADD-BUS-DAYS-TO-DATE only works with +(positive) numbers.
------------------------------------------------------------------------
Don Stafford, Director of Information Technologies
UAV Entertainment Corporation
2200 Carolina Place
Fort Mill, SC  29708

Contributed by: James Lemmon, JWL Software, Johannesburg, South Africa Here is a program that I use for reading from a COM port. This has been used in a few different compilers so hopefully it will work for you without many amendments.

000170 SELECT SCALES ASSIGN W02-SCALES
000300 ORGANIZATION LINE SEQUENTIAL
000180 STATUS WS-STATUS
000310 ACCESS SEQUENTIAL.
.
.
.
000530 FD SCALES LABEL RECORD OMITTED.
000550 01 SCA-REC.
                     03 SCA-LINE PIC X(30).
                01 SCA-REC2.
                     03 SCA-CHAR1 PIC X(01).
                     03 SCA-CHAR2-30 PIC X(29).
                01 SCA-REC3.
                     03 SCA-KG PIC 9(03).
                     03 SCA-DEC PIC X(01).
                     03 SCA-GRAM PIC 9(03).
                     03 FILLER PIC X(23).
.
.
.
                01 W02-FILE-IDS.
                     03 W02-SCALES PIC X(04) VALUE "COM2".
.......This can be any of the com ports.
.
.
.
                01 SCALE-QUANTITY.
                     03 SCALE-PORT.
                          05 SCALE-NO PIC X(04).
                     03 SCALE-QUANT.
                          05 SCALE-WEIGHT.
                               07 SCALE-QNT PIC 9(09)V999.
                          05 SCALE-WEIGHT2 REDEFINES SCALE-WEIGHT.
                               07 SCALE-KG PIC 9(09).
                               07 SCALE-GR PIC 9(03).
.
.
.
001230 PROCEDURE DIVISION USING SCALE-QUANTITY.
001220 AA000 SECTION.
001230 AA00.
                   MOVE ZERO TO SCALE-QNT.
                   MOVE SCALE-NO TO W02-SCALES.
042140      OPEN I-O SCALES.
003050      IF NOT (WS-STATUS = "00" OR "41")
                         GO TO AA999.
001340 AA05.
                   READ SCALES.
        AA10.
                   IF NOT (SCA-CHAR1 = "+" OR "-")
                         MOVE SCA-CHAR2-30 TO SCA-REC
                   IF SCA-REC = SPACES
                         GO TO AA999
                   ELSE
                         GO TO AA10.
                   MOVE SCA-CHAR2-30 TO SCA-REC.
                   IF SCA-REC = SPACES
                         GO TO AA999.
                   MOVE SCA-KG TO SCALE-KG.
                   MOVE SCA-GRAM TO SCALE-GR.
001830           CLOSE SCALES.
AA999.
            EXIT-PROGRAM.

Contributed by: Franco Stringari Pudler, Mercosoft, Brazil

I want to suggest, a solution for accessing Mysql database using traditional Cobol commands.

Commands like OPEN, START, READ, WRITE, REWRITE, DELETE…… a solution developed for MicroFocus Cobol applications, where the only need, is to change the configurations of your programs and recompile them.

The basic consist of changing the parameter CALLFH to CALLFH”EXTMYSQL”.

EXTMYSQL is a program that will treat all file access from Cobol, translating to Mysql access commands. It use LIBMYSQL “C” API connector, that why it is very fast and secure.

This little program is very important to those who want to migrate from Cobol or need to work with mixed language, saving first investment over Cobol application.

Here you will find a link to Download a little sample.

http://www.mercosoft.com.br/DemoCep.rar

More information may be found at http://www.mercosoft.com.br .

Any question may be send to This email address is being protected from spambots. You need JavaScript enabled to view it. with subject “COBOL MYSQL”.

Thank for attention.

Franco Stringari Pudler

 
      **************************************************************************
      *  IMEDIATA INFORMATICA EMPRESARIAL LTDA                                 *
      *  PROGRAMA - CnvMfMy - Converte arquivo gerado originalmente em COBOL   *
      *                       para Banco de dados Mysql                        *
      **************************************************************************
       IDENTIFICATION DIVISION.
       PROGRAM-ID.    CnvMfMy.
       AUTHOR.        Franco Stringari Pudler.
       ENVIRONMENT    DIVISION.
       CONFIGURATION  SECTION.
       SPECIAL-NAMES. DECIMAL-POINT IS COMMA.
       INPUT-OUTPUT   SECTION.
       FILE-CONTROL.        *> Informa que o arquivo é padrão MYSQL            SELECT ARQMYS ASSIGN TO DYNAMIC W-LABMSQ
                   ORGANIZATION IS INDEXED
                   ACCESS MODE  IS DYNAMIC
                   LOCK MODE    IS MANUAL
                   FILE STATUS  IS W-STATUS
                   RECORD KEY   IS MY-LAN
                   ALTERNATE RECORD KEY IS MY-CTA
                                WITH DUPLICATES.        *> Informa que próximo arquivo é padrão DEFAULT MF            SELECT ARQMFS ASSIGN TO DYNAMIC W-LABMFS
                   ORGANIZATION IS INDEXED
                   ACCESS MODE  IS DYNAMIC
                   LOCK MODE    IS MANUAL
                   FILE STATUS  IS W-STATUS
                   RECORD KEY   IS MF-LAN
                   ALTERNATE RECORD KEY IS MF-CTA
                                WITH DUPLICATES.        DATA DIVISION.
       FILE SECTION.       *> Definição do registro do arquivo que será gerado no MySql
       FD  ARQMYS.
       01  MY-REG.
           02 MY-SIT   PIC  X(01).
           02 MY-LAN   PIC S9(09)    COMP-3.
           02 MY-CTA   PIC S9(15)    COMP-3.
           02 MY-CDH   PIC S9(05)    COMP-3.
           02 MY-HST   PIC  X(30).
           02 MY-DTA   PIC S9(09)    COMP-3.
           02 MY-VAL   PIC S9(13)V99 COMP-3.       *> Definição do registro do arquivo com os dados originalmente gerados no padrão MF
       FD  ARQMFS.
       01  MF-REG.
           02 MF-SIT   PIC  X(01).
           02 MF-LAN   PIC S9(09)    COMP-3.
           02 MF-CTA   PIC S9(15)    COMP-3.
           02 MF-CDH   PIC S9(05)    COMP-3.
           02 MF-HST   PIC  X(30).
           02 MF-DTA   PIC S9(09)    COMP-3.
           02 MF-VAL   PIC S9(13)V99 COMP-3.        WORKING-STORAGE SECTION.
       77  W-LABMFS    PIC  X(60) VALUE "ARQMFS".
       77  W-LABMSQ    PIC  X(60) VALUE SPACES.
       77  W-STATUS    PIC  X(02).
       88  STAT-ERRO            VALUE X"3100" THRU X"3943"
                                      X"3945" THRU X"39EE".        88  DUPLICADO            VALUE "22".        77  W-MSG       PIC  X(80) VALUE SPACES.        LINKAGE SECTION.        PROCEDURE DIVISION.
       INICIO.            MOVE  "ARQMFS"    TO W-LABMFS.  *> Define onde estão os dados            OPEN INPUT ARQMFS.              *> Abre arquivo MF
           IF STAT-ERRO                    *> Verifica se abertura foi OK
              STRING  "Abrindo Lote[" W-LABMFS "] Status"
                     W-STATUS DELIMITED BY "  " INTO W-MSG
              DISPLAY W-MSG                *> Comunica causa do problema
              STOP RUN.            MOVE  "@127.0.0.1@3306@root@1234@imediata@ARQMYS"
                             TO W-LABMSQ.  *> Define parametros para o MySql            OPEN I-O ARQMYS.                *> Abre arquivo no MySql
           IF STAT-ERRO
              DISPLAY "Criando Arquivo de destino"
              STOP RUN.            MOVE  ZEROS       TO MF-LAN.    *> Define ponto de partida
           START ARQMFS KEY IS NOT LESS THAN MF-LAN.  *> Posiciona no registro Cf definido acima
           PERFORM UNTIL STAT-ERRO                    *> Loop para geração do arquivo
              READ ARQMFS NEXT RECORD                 *> Recupera registro no arquivo Micro Focus
                 AT END DISPLAY "Fim conversão sem problemas" *> Termino sem problemas
                 NOT AT END                           *> Encontrou registro
                    MOVE  MF-REG  TO MY-REG           *> Move estrutura MF para Mysql
                    WRITE MY-REG                      *> Grava registro na tabela Mysql
                    IF DUPLICADO                      *> Teste se registro já estava cadastrado
                       MOVE  ZEROS TO W-STATUS        *> Evita encerramento prematuro caso registro já exista
                    ELSE
                       IF STAT-ERRO
                          DISPLAY "Erro gerando registro no Mysql, Staus  *> Não conseguiu gerar o registro
      -                           "[" W-STATUS "]"    *> Retorna possível causa do erro
                          STOP RUN                    *> Encerra processo
                       END-IF
                    END-IF
              END-READ
           END-PERFORM.            CLOSE ARQMFS.       *> Fecha os arquivos
           CLOSE ARQMYS.            STOP RUN.
         ----------------------------------------------------------------------------------------

This website uses cookies to manage authentication, navigation, and other functions. By using our website, you agree that we can place these types of cookies on your device.

View e-Privacy Directive Documents

You have declined cookies. This decision can be reversed.

You have allowed cookies to be placed on your computer. This decision can be reversed.

Login

Who's Online

Member Login