mwhitman52
Technical User
I am looking for sample code to read & write DBF files utilizing Realia.
Can anyone help me out?
Thank you,
Mike
Can anyone help me out?
Thank you,
Mike
Tek-Tips is the largest IT community on the Internet today!
Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!
-
Congratulations Mike Lewis on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!
Realia code for DBF 1
- Thread starter mwhitman52
- Start date
- Status
-
1
- #3
Truusvlugindewind
Programmer
Hee Crox! Wake up! This is your cup-of-tea.
Hi,
I think it is somewhere here on the board, but I give you a source to read it. Write it is the other way around....
Kisses for Truus, I would like to drink a cup of tea with you like in the old times ....
Regards,
Crox
These programs are a little bit old. They are from the time that COBOL didn't know pointers, but Realia did. You can define the dialect with a statement on the first line like:
000001$DIALECT-REALIA3
That will work.
My personal email can be found in my profile.
Regards,
Crox
I think it is somewhere here on the board, but I give you a source to read it. Write it is the other way around....
Kisses for Truus, I would like to drink a cup of tea with you like in the old times ....
Regards,
Crox
Code:
TO MAKE A WORKING-STORAGE DEFINITION OUT OF THE DBF HEADER:
000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID. DBFCOB.
000300 ENVIRONMENT DIVISION.
000400 CONFIGURATION SECTION.
000500 SOURCE-COMPUTER. IBM-PC.
000600 OBJECT-COMPUTER. IBM-PC.
000700 INPUT-OUTPUT SECTION.
000800 FILE-CONTROL.
000900 SELECT DBF-IN ASSIGN TO VARYING A FILE STATUS FILE-STATUS1.
000910 SELECT COBOLWSUIT ASSIGN TO
000920 VARYING B FILE STATUS FILE-STATUS2.
001000 DATA DIVISION.
001100 FILE SECTION.
001110 FD COBOLWSUIT
001120 LABEL RECORD STANDARD.
001130 01 WORKS-REGEL PIC X(80).
001200 FD DBF-IN
001300 LABEL RECORD STANDARD.
001400 01 FILE-HEADER.
001500 03 DBASE-FIRST-BYTE PIC X.
001600 03 DBASE-DATE-LAST-UPDATE.
001700 05 DBASE-JJ-LAST-UPDATE PIC X.
001800 05 DBASE-MM-LAST-UPDATE PIC X.
001900 05 DBASE-DD-LAST-UPDATE PIC X.
002000 03 DBASE-NUMBER-OF-RECORDS PIC S9(9) COMP-5.
002100 03 DBASE-LENGTH-HEADER PIC S9(4) COMP-5.
002200 03 DBASE-LENGTH-RECORD PIC S9(4) COMP-5.
002300 03 DBASE-RESERVED-1 PIC XX.
002400 03 DBASE-FLAG-INCOMPLETE-TRANS PIC X.
002500 03 DBASE-ENCRYPTION-FLAG PIC X.
002600 03 DBASE-LOCAL-AREA-INFO PIC X(12).
002700 03 DBASE-INDICATOR-MDX-FILE PIC X.
002800 03 DBASE-RESERVED-2 PIC X(3).
002900 01 DBASE-FIELD-DESCRIPTOR.
003000 03 DBASE-ASCII-FIELD-NAME PIC X(11).
003100 03 DBASE-FIELD-TYPE PIC X.
003200 03 DBASE-RESERVED-3 PIC X(4).
003300 03 DBASE-FIELD-LENGTH PIC X.
003400 03 DBASE-FIELD-DECIMAL-COUNT PIC X.
003500 03 DBASE-RESERVED-4 PIC XX.
003600 03 DBASE-WORK-AREA-ID PIC X.
003700 03 DBASE-RESERVED-5 PIC X(11).
003800
003900
004000 WORKING-STORAGE SECTION.
004100 01 WAARDE-DERTIEN PIC S9(4) COMP-5 VALUE 13.
004200 01 FILLER REDEFINES WAARDE-DERTIEN.
004300 03 NEW-LINE PIC X.
004400 03 FILLER PIC X.
004410 01 WAARDE-ZESENTWINTIG PIC S9(4) COMP-5 VALUE 26.
004420 01 FILLER REDEFINES WAARDE-ZESENTWINTIG.
004430 03 END-OF-FILE PIC X.
004440 03 FILLER PIC X.
004500 01 HULPVELDEN.
004600 03 AANTAL-VELDEN PIC S9(4) COMP-5.
004700 03 BINAIR-VELD-ALFA.
004800 05 BINAIR-ALFA PIC X.
004900 05 FILLER PIC X VALUE LOW-VALUE.
005000 03 BINAIR-NUMERIEK REDEFINES BINAIR-VELD-ALFA
005100 PIC S9(4) COMP-5.
005200 03 FIRST-BYTE-DEFINITIES.
005300 05 FB-BITS.
005400 07 FB-BIT-0 PIC S9(4) COMP-5.
005500 07 FB-BIT-1 PIC S9(4) COMP-5.
005600 07 FB-BIT-2 PIC S9(4) COMP-5.
005700 07 FB-BIT-3 PIC S9(4) COMP-5.
005800 07 FB-BIT-4 PIC S9(4) COMP-5.
005900 07 FB-BIT-5 PIC S9(4) COMP-5.
006000 07 FB-BIT-6 PIC S9(4) COMP-5.
006100 07 FB-BIT-7 PIC S9(4) COMP-5.
006200 05 FB-VERSIE-NR PIC S9(4) COMP-5.
006300 05 FB-SQL-INDICATIE PIC S9(4) COMP-5.
006400 05 FB-MEMO-INDICATIE PIC S9(4) COMP-5.
006500 03 DBASE-DATUM.
006600 05 DBASE-DAG PIC 99.
006700 05 FILLER PIC X VALUE '-'.
006800 05 DBASE-MAAND PIC 99.
006900 05 FILLER PIC X VALUE '-'.
007000 05 DBASE-JAAR PIC 99.
007100
007200 03 A PIC X(85) VALUE SPACE.
007210 03 B PIC X(85) VALUE SPACE.
007300 03 FILE-STATUS1 PIC XX.
007310 03 FILE-STATUS2 PIC XX.
007400 03 EDIT-GETAL PIC -ZZZZ9.
007410 01 DBF-RECORDS.
007420 02 DBF-EERSTE-REGEL VALUE
007430 ' 01 DBF-REC.
007440- ' '.
007450 03 FILLER PIC X(80).
007451 02 DBF-TWEEDE-REGEL VALUE
007452 ' 03 DBF-DELETE-MARKER
007454- ' PIC X. '.
007455 03 FILLER PIC X(80).
007460 02 DBF-CHR VALUE
007470 ' 03 DBF-XXXXXXXX
007480- ' PIC X(999). '.
007490 03 FILLER PIC X(19).
007491 03 DBF-CHR-VELDNAAM PIC X(11).
007492 03 FILLER PIC X(19).
007493 03 DBF-CHR-LENGTE PIC 9(03).
007494 03 FILLER PIC X(28).
007495 02 DBF-NUM-KOMMA1 VALUE
007496 ' 03 DBF1-XXXXXXXX
007497- ' PIC 9(99). '.
007498 03 FILLER PIC X(20).
007499 03 DBF-NUM-KOMMA-VELDNAAM1 PIC X(11).
007500 03 FILLER PIC X(18).
007503 03 DBF-NUM-KOMMA-LENGTE-VOOR PIC 9(02).
007504 03 FILLER PIC X(29).
007505 02 DBF-NUM-KOMMA-FILL PIC X(80) VALUE
007506 ' 03 FILLER
007507- ' PIC X. '.
007508 02 DBF-NUM-KOMMA2 VALUE
007509 ' 03 DBF2-XXXXXXXX-NA
007510- ' PIC V9(99). '.
007511 03 FILLER PIC X(20).
007512 03 DBF-NUM-KOMMA-VELDNAAM2 PIC X(11).
007513 03 FILLER PIC X(24).
007514 03 DBF-NUM-KOMMA-LENGTE-ACHTER PIC 9(02).
007515 03 FILLER PIC X(23).
007516 02 DBF-NUM VALUE
007517 ' 03 DBF-XXXXXXXX
007518- ' PIC 9(99). '.
007519 03 FILLER PIC X(19).
007520 03 DBF-NUM-VELDNAAM PIC X(11).
007521 03 FILLER PIC X(19).
007522 03 DBF-NUM-LENGTE PIC 9(02).
007523 03 FILLER PIC X(29).
007530 PROCEDURE DIVISION.
007600 DISPLAY '****************************************'.
007700 DISPLAY '* *'.
007800 DISPLAY '* DIT PROGRAMMA LEEST DE HEADER VAN *'.
007900 DISPLAY '* EEN DBASE .DBF FILE EN TRANSFOR- *'.
008000 DISPLAY '* MEERT DEZE TOT EEN COBOL DEFINITIE *'.
008100 DISPLAY '* *'.
008200 DISPLAY '* COPYRIGHT (C) R.G. WOUTERSON 1989 *'.
008300 DISPLAY '* *'.
008400 DISPLAY '****************************************'.
008500 0001.
008600 DISPLAY 'INPUT FILE ?'.
008700 MOVE SPACE TO A.
008800 ACCEPT A FROM CONSOLE.
008900 STRING A DELIMITED BY SPACE '[B:63]'
009000 DELIMITED BY SIZE INTO A.
009100 OPEN INPUT DBF-IN.
009200 IF FILE-STATUS1 NOT = ZERO THEN
009300 DISPLAY '* FOUTIEF OPGEGEVEN, DOE ''T NOG EENS *'
009400 GO TO 0001.
009500 READ DBF-IN AT END DISPLAY '*** LEEG BESTAND ***'
009600 GO TO 9999.
009700
009701 0002.
009702 DISPLAY 'COBOL FILE ?'.
009703 MOVE SPACE TO B.
009704 ACCEPT B FROM CONSOLE.
009705 STRING B DELIMITED BY SPACE '[N]' DELIMITED BY SIZE INTO B.
009706 OPEN OUTPUT COBOLWSUIT.
009707 IF FILE-STATUS2 NOT = ZERO
009708 DISPLAY '* FOUTIEF OPGEGEVEN, DOE ''T NOG EENS *'
009709 GO TO 0002.
009800
009900 0001-HEADER.
009910 WRITE WORKS-REGEL FROM DBF-EERSTE-REGEL.
009920 WRITE WORKS-REGEL FROM DBF-TWEEDE-REGEL.
016400 COMPUTE AANTAL-VELDEN = (DBASE-LENGTH-HEADER - 32) / 32.
016500 DISPLAY 'AANTAL VELDEN : ' AANTAL-VELDEN.
016600 READ DBF-IN AT END DISPLAY '*** GEEN VELDEN GEDEFINIEERD ***'
016700 GO TO 9999.
016800 0002-FIELDS.
016900 MOVE ZERO TO BINAIR-NUMERIEK.
017200 SUBTRACT +1 FROM AANTAL-VELDEN.
017710 MOVE DBASE-FIELD-LENGTH TO BINAIR-ALFA.
017720 INSPECT DBASE-ASCII-FIELD-NAME REPLACING ALL '_' BY '-'.
017800 IF DBASE-FIELD-TYPE = 'N'
017900 IF DBASE-FIELD-DECIMAL-COUNT = LOW-VALUE OR SPACE
017920 MOVE DBASE-ASCII-FIELD-NAME TO DBF-NUM-VELDNAAM
017930 MOVE BINAIR-NUMERIEK TO DBF-NUM-LENGTE
017940 WRITE WORKS-REGEL FROM DBF-NUM
017950 ELSE
017960 MOVE DBASE-ASCII-FIELD-NAME TO DBF-NUM-KOMMA-VELDNAAM1
017961 DBF-NUM-KOMMA-VELDNAAM2
017970 MOVE BINAIR-NUMERIEK TO
017972 DBF-NUM-KOMMA-LENGTE-VOOR
017973 MOVE ZERO TO BINAIR-NUMERIEK
017975 MOVE DBASE-FIELD-DECIMAL-COUNT TO BINAIR-ALFA
017976 MOVE BINAIR-NUMERIEK TO
017977 DBF-NUM-KOMMA-LENGTE-ACHTER
017978 ADD +1 TO BINAIR-NUMERIEK
017979 SUBTRACT BINAIR-NUMERIEK FROM
017981 DBF-NUM-KOMMA-LENGTE-VOOR
017982 WRITE WORKS-REGEL FROM DBF-NUM-KOMMA1
017983 WRITE WORKS-REGEL FROM DBF-NUM-KOMMA-FILL
017984 WRITE WORKS-REGEL FROM DBF-NUM-KOMMA2
017990 ELSE
017991 MOVE DBASE-ASCII-FIELD-NAME TO DBF-CHR-VELDNAAM
017992 MOVE BINAIR-NUMERIEK TO DBF-CHR-LENGTE
017993 WRITE WORKS-REGEL FROM DBF-CHR.
020600 READ DBF-IN AT END
020700 GO TO 9999.
020800
020900 IF DBASE-FIRST-BYTE = NEW-LINE OR END-OF-FILE
021000 DISPLAY 'EINDE VELDBESCHRIJVINGEN'
021100 GO TO 9999
021200 ELSE
021300 IF AANTAL-VELDEN NOT > 0
021400 DISPLAY 'EINDE VELDBESCHRIJVINGEN VOLGENS TELLING'
021500 GO TO 9999.
021600
021700 GO TO 0002-FIELDS.
021800 9999.
021900 CLOSE DBF-IN COBOLWSUIT.
022000 STOP RUN.
THE PROGRAM HEREAFTER MAKES A SEQUENTIAL FILE OUT OF A DBF FILE.
000100*$CALL
000200 IDENTIFICATION DIVISION.
000300 PROGRAM-ID. DBFCOPY.
000400******************************************************************
000500* SEQUENTIEEL MAKEN V. DBF FILES COPYRIGHT(C) R.G. WOUTERSON*
000600******************************************************************
000700 ENVIRONMENT DIVISION.
000800 CONFIGURATION SECTION.
000900 SOURCE-COMPUTER. IBM-PC.
001000 OBJECT-COMPUTER. IBM-PC.
001100 SPECIAL-NAMES.
001200 DECIMAL-POINT IS COMMA.
001300 INPUT-OUTPUT SECTION.
001400 FILE-CONTROL.
001710 SELECT DBFUIT ASSIGN TO VARYING DBASE-OUTPUT-FILE
001800 FILE STATUS FILE-STATUS-DBFUIT.
001810 SELECT DBFIN ASSIGN TO VARYING DBASE-INPUT-FILE
001820 FILE STATUS FILE-STATUS-DBFIN.
001900 DATA DIVISION.
002000 FILE SECTION.
002100 FD DBFIN
002200 LABEL RECORD STANDARD.
002300 01 DBFIN-RECORD.
002400 03 DBFIN-TEKEN OCCURS 32767 PIC X.
002500 FD DBFUIT
002600 LABEL RECORD STANDARD.
002700 01 DBASE-REC.
002800 03 DBASE-REC-TEKEN OCCURS 1 TO 10000 DEPENDING ON
002900 DBFIN-LENGTH-RECORD PIC X.
013900 WORKING-STORAGE SECTION.
014000 01 ADRES-START-DBASE-BUFFER.
014100 03 ADRES-START-DBASE-OFFSET PIC S9(4) COMP-5.
014200 03 ADRES-START-DBASE-SEGMENT PIC S9(4) COMP-5.
014300 01 ADRES-SET-LINK.
014400 03 ADRES-SET-LINK-OFFSET PIC S9(4) COMP-5.
014500 03 ADRES-SET-LINK-SEGMENT PIC S9(4) COMP-5.
014600 01 DBFIN-LABEL-REC.
014700 03 DBFIN-FIRST-BYTE PIC X.
014800 03 DBFIN-DATE-LAST-UPDATE.
014900 05 DBFIN-JJ-LAST-UPDATE PIC X.
015000 05 DBFIN-MM-LAST-UPDATE PIC X.
015100 05 DBFIN-DD-LAST-UPDATE PIC X.
015200 03 DBFIN-NUMBER-OF-RECORDS PIC S9(9) COMP-5.
015300 03 DBFIN-LENGTH-HEADER PIC S9(4) COMP-5.
015310 03 DBFIN-LENGTH-RECORD-ALF PIC XX VALUE HIGH-VALUE.
015400 03 DBFIN-LENGTH-RECORD REDEFINES DBFIN-LENGTH-RECORD-ALF
015410 PIC S9(4) COMP-5.
015500 03 DBFIN-RESERVED-1 PIC XX.
015600 03 DBFIN-FLAG-INCOMPLETE-TRANS PIC X.
015700 03 DBFIN-ENCRYPTION-FLAG PIC X.
015800 03 DBFIN-LOCAL-AREA-INFO PIC X(12).
015900 03 DBFIN-INDICATOR-MDX-FILE PIC X.
016000 03 DBFIN-RESERVED-2 PIC X(3).
016100 01 HULPVELDEN.
016200 03 QS-LEES-DBASE VALUE 1 PIC S9(4) COMP-5.
016300 03 FILE-STATUS-DBFIN PIC XX.
016310 03 FILE-STATUS-DBFUIT PIC XX.
016320 03 LENGTH-MINUS-RECDBFIN-ALF PIC XX VALUE HIGH-VALUE.
016400 03 LENGTH-MINUS-RECDBFIN REDEFINES LENGTH-MINUS-RECDBFIN-ALF
016410 PIC S9(4) COMP-5.
016500 03 AANTAL-GEHELE-BLOKKEN PIC S9(4) COMP-5.
016510 03 AANTAL-DBASE-BYTES PIC S9(9) COMP-5.
016600 03 RESTANT-LAATSTE-BLOK PIC S9(4) COMP-5.
016700 03 DBFIN-LENGTH-RESTANT-ALF PIC XX VALUE HIGH-VALUE.
016710 03 DBFIN-LENGTH-RESTANT REDEFINES DBFIN-LENGTH-RESTANT-ALF
016720 PIC S9(4) COMP-5.
016800 03 DBFIN-INPUT-LOKATIE PIC S9(4) COMP-5.
017000 03 DBASE-OUTPUT-FILE PIC X(83) VALUE SPACE.
017001 03 DBASE-INPUT-FILE PIC X(83) VALUE SPACE.
017040
017100 LINKAGE SECTION.
018000 01 POINTR-OUTP-FULL-LENGTH.
018100 03 FILLER OCCURS 1 TO 10000 DEPENDING ON
018200 DBFIN-LENGTH-RECORD PIC X.
018300
018400 01 POINTR-FIRST-PART-REC.
018500 03 FILLER OCCURS 1 TO 10000 DEPENDING ON
018600 DBFIN-LENGTH-RESTANT PIC X.
018700
018800 01 POINTR-SCND-PART-REC.
018900 03 FILLER OCCURS 1 TO 10000 DEPENDING ON
019000 LENGTH-MINUS-RECDBFIN PIC X.
019100
019200 PROCEDURE DIVISION.
019300
019400 MAIN SECTION.
019410 0001.
019420 DISPLAY 'INPUT FILE ?'.
019430 MOVE SPACE TO DBASE-INPUT-FILE.
019440 ACCEPT DBASE-INPUT-FILE FROM CONSOLE.
019450 STRING DBASE-INPUT-FILE DELIMITED BY SPACE '[B:63]'
019460 DELIMITED BY SIZE INTO DBASE-INPUT-FILE.
019470 OPEN INPUT DBFIN.
019480 IF FILE-STATUS-DBFIN NOT = ZERO THEN
019490 DISPLAY '* FOUTIEF OPGEGEVEN, DOE ''T NOG EENS *'
019491 EXHIBIT NAMED FILE-STATUS-DBFIN
019492 EXHIBIT NAMED DBASE-INPUT-FILE
019493 GO TO 0001.
019498 READ DBFIN INTO DBFIN-LABEL-REC
019499 AT END DISPLAY '*** LEEG BESTAND ***'
019500 STOP RUN.
019501 IF FILE-STATUS-DBFIN NOT = ZERO
019502 DISPLAY '*** DBASE FILE IS NIET LEESBAAR ***'
019503 EXHIBIT NAMED FILE-STATUS-DBFIN
019504 EXHIBIT NAMED DBASE-INPUT-FILE
019505 DISPLAY '*** EINDE PROGRAMMA ***'
019506 STOP RUN.
019507 0002.
019508 DISPLAY 'OUTPUT FILE ?'.
019509 MOVE SPACE TO DBASE-OUTPUT-FILE.
019510 ACCEPT DBASE-OUTPUT-FILE FROM CONSOLE.
019511 STRING DBASE-OUTPUT-FILE DELIMITED BY SPACE '[N:63]'
019512 DELIMITED BY SIZE INTO DBASE-OUTPUT-FILE.
019513 OPEN OUTPUT DBFUIT.
019514 IF FILE-STATUS-DBFUIT NOT = ZERO THEN
019515 DISPLAY '* FOUTIEF OPGEGEVEN, DOE ''T NOG EENS *'
019516 GO TO 0002.
019517 0003.
022200 COMPUTE AANTAL-DBASE-BYTES = DBFIN-LENGTH-HEADER
022300 + DBFIN-NUMBER-OF-RECORDS * DBFIN-LENGTH-RECORD.
022400 DIVIDE AANTAL-DBASE-BYTES BY 32767
022500 GIVING AANTAL-GEHELE-BLOKKEN
022600 REMAINDER RESTANT-LAATSTE-BLOK.
022900 MOVE DBFIN-LENGTH-HEADER TO DBFIN-INPUT-LOKATIE.
023000 ADD +1 TO DBFIN-INPUT-LOKATIE.
023100 CALL 'MLI_GETADDR' USING DBFIN-TEKEN(DBFIN-INPUT-LOKATIE)
023200 ADRES-START-DBASE-BUFFER.
023300 CALL 'MLI_SETLINK' USING ADRES-START-DBASE-BUFFER
023400 POINTR-OUTP-FULL-LENGTH.
023500**** WRITE DBASE-RECORD
023600 MOVE POINTR-OUTP-FULL-LENGTH TO DBASE-REC.
023900 WRITE DBASE-REC.
024100 SUBTRACT 1 FROM DBFIN-NUMBER-OF-RECORDS.
024200 ADD DBFIN-LENGTH-RECORD TO DBFIN-INPUT-LOKATIE.
024300 BUFFER-ITR.
024400 IF DBFIN-NUMBER-OF-RECORDS < 1
024500 GO TO BUFFER-END.
024600 RECORD-ITR.
024700 IF 32767 - DBFIN-INPUT-LOKATIE < DBFIN-LENGTH-RECORD
024800 OR DBFIN-NUMBER-OF-RECORDS < 1
024900 GO TO RECORD-END.
025000 CALL 'MLI_GETADDR' USING
025100 DBFIN-TEKEN (DBFIN-INPUT-LOKATIE)
025200 ADRES-START-DBASE-BUFFER.
025300 CALL 'MLI_SETLINK' USING ADRES-START-DBASE-BUFFER
025400 POINTR-OUTP-FULL-LENGTH.
025600 MOVE POINTR-OUTP-FULL-LENGTH TO DBASE-REC.
025700 SUBTRACT 1 FROM DBFIN-NUMBER-OF-RECORDS.
026000 WRITE DBASE-REC.
026200 ADD DBFIN-LENGTH-RECORD TO DBFIN-INPUT-LOKATIE.
026300 GO TO RECORD-ITR.
026400 RECORD-END.
026410 IF DBFIN-NUMBER-OF-RECORDS < 1
026420 GO TO BUFFER-END.
026430**** GEDEELTELIJK RECORD IN HET OUDE BLOK ****
026500 COMPUTE DBFIN-LENGTH-RESTANT = 32768 - DBFIN-INPUT-LOKATIE.
026600 COMPUTE LENGTH-MINUS-RECDBFIN = DBFIN-LENGTH-RECORD -
026700 DBFIN-LENGTH-RESTANT.
026800 CALL 'MLI_GETADDR' USING
026900 DBFIN-TEKEN (DBFIN-INPUT-LOKATIE)
027000 ADRES-START-DBASE-BUFFER.
027100 CALL 'MLI_SETLINK' USING ADRES-START-DBASE-BUFFER
027200 POINTR-FIRST-PART-REC.
027300 MOVE POINTR-FIRST-PART-REC TO DBASE-REC.
027310 ADD +1 TO DBFIN-LENGTH-RESTANT.
027400 CALL 'MLI_GETADDR' USING
027500 DBASE-REC-TEKEN (DBFIN-LENGTH-RESTANT)
027600 ADRES-SET-LINK.
027700 CALL 'MLI_SETLINK' USING ADRES-SET-LINK
027800 POINTR-SCND-PART-REC.
027900 READ DBFIN INTO POINTR-SCND-PART-REC.
027920 IF FILE-STATUS-DBFIN NOT = ZERO
027930 GO TO BUFFER-END.
028000 SUBTRACT 1 FROM DBFIN-NUMBER-OF-RECORDS.
028600 WRITE DBASE-REC.
028900 MOVE LENGTH-MINUS-RECDBFIN TO DBFIN-INPUT-LOKATIE.
029000 ADD 1 TO DBFIN-INPUT-LOKATIE.
029100 GO TO BUFFER-ITR.
029200 BUFFER-END.
029300 CLOSE DBFIN.
029400**** WRITE DBASE-RECORD
029700 STOP RUN.
029800 DUMMY SECTION.
029900 DUMM-001.
030000 ENTRY 'DUMMY' USING POINTR-SCND-PART-REC
030100 POINTR-OUTP-FULL-LENGTH
030200 POINTR-FIRST-PART-REC.
030300 DUMM-999.
030400 EXIT.These programs are a little bit old. They are from the time that COBOL didn't know pointers, but Realia did. You can define the dialect with a statement on the first line like:
000001$DIALECT-REALIA3
That will work.
My personal email can be found in my profile.
Regards,
Crox
- Status
Similar threads
- Locked
- Question
- Locked
- Question
- Locked
- Question