Possible Bad Branch
Posted: Tue Mar 19, 2013 5:42 pm
Hi Friends,
I am trying to run a simple program, I get POssible Bad Branch with a negative offset. I had been trying various options and rerunning my code but it ends with the same error.
Kindly share your thoughts for a solutions.
I have attached the program for reference.
Thanks,
Akila.
CEE3201S The system detected an operation exception (System Completion Code=0C1)
From compile unit FIDUPCLP at entry point FIDUPCLP at compile unit offs
at address 00000048.
Possible Bad Branch: Statement: Offset: -E9D4B514
I am trying to run a simple program, I get POssible Bad Branch with a negative offset. I had been trying various options and rerunning my code but it ends with the same error.
Kindly share your thoughts for a solutions.
I have attached the program for reference.
Thanks,
Akila.
CEE3201S The system detected an operation exception (System Completion Code=0C1)
From compile unit FIDUPCLP at entry point FIDUPCLP at compile unit offs
at address 00000048.
Possible Bad Branch: Statement: Offset: -E9D4B514
Identification Division.
Program-Id. FIDUPCLP.
******************************************************************
Replace
copy Rdbreplr.
.
******************************************************************
* 82QC9N - RDF Duplicates and Correction *
*----------------------------------------------------------------*
* This program is for Finland. *
* To Create List A and List B and List C *
******************************************************************
Environment Division.
Configuration Section.
Special-Names.
Decimal-Point is Comma.
******************************************************************
Input-Output Section.
File-Control.
Select Parmfile Assign to Parmfile
File Status is Ws-Stt-Parmfile.
Select Infile Assign to Infile
File Status is Ws-Stt-Infile.
Select ListA Assign to ListA
File Status is Ws-Stt-ListA.
Select ListB Assign to ListB
File Status is Ws-Stt-ListB.
Select ListC Assign to ListC
File Status is Ws-Stt-ListC.
******************************************************************
Data Division.
******************************************************************
File Section.
******************************************************************
*
FD ListA
Label Record Standard
Recording Mode F.
01 ListA-Rec Pic X(176).
*
FD ListB
Label Record Standard
Recording Mode F.
01 ListB-Rec Pic X(134).
*
FD ListC
Label Record Standard
Recording Mode F.
01 ListC-Rec Pic X(123).
*
FD Parmfile
Label Record Standard
Recording Mode F.
01 Parmfile-Rec.
05 Parmfile-Parm Pic X(005).
05 Filler Pic X(075).
*
FD Infile
Label Record Standard
Recording Mode F.
01 Infile-Rec.
05 Infile-Xref Pic X(011).
05 Filler Pic X(013).
*
******************************************************************
Working-Storage Section.
******************************************************************
*
Copy RDBUCPDW.
*
* Customer File Segments
*
01 FMAS-HM-AREA EXTERNAL.
02 FMAS-HM-PART.
Copy RDBHMXXS Replacing ==:PREFIX:== By ==FMAS==.
*
01 FMAS-ADDR-AREA EXTERNAL.
02 FMAS-ADDR-PART OCCURS :ADDR-OCCUR:.
Copy RDBADDRS Replacing ==:PREFIX:== By ==FMAS==.
*
* File Handler Interface and Counters
Copy FHBCUSTC.
*
01 FHBCUSTP Pic X(008) Value 'FHBCUSTP'.
*
01 Ws-Rdbnamep Pic X(008) Value 'RDBNAMEP'.
Copy Rdbnamec Replacing ==:PREFIX:== By ==WS==.
*
01 Ws-Rdbaddrp Pic X(008) Value 'RDBADDRP'.
Copy Rdbaddrc Replacing ==:PREFIX:== By ==WS==.
*
01 Ws-Rdbfdadp Pic X(008) Value 'RDBFDADP'.
Copy Rdbfdadc Replacing ==:PREFIX:== By ==Rdbfdadc==.
*
01 Ws-Prog-id Pic X(010) Value 'FIDUPCLP:'.
01 Ws-Street Pic X(050) Value Spaces.
01 Ws-pos pic s9(004) comp.
*
* Work Fileds
*
01 Ws-Stt.
05 Ws-Stt-Parmfile Pic 9(002).
05 Ws-Stt-Infile Pic 9(002).
05 Ws-Stt-ListA Pic 9(002).
05 Ws-Stt-ListB Pic 9(002).
05 Ws-Stt-ListC Pic 9(002).
*
01 Ws-Count.
05 Ws-Cust-In-ListA Pic S9(007) Comp-3 Value Zero.
05 Ws-Cust-In-ListB Pic S9(007) Comp-3 Value Zero.
05 Ws-Cust-In-ListC Pic S9(007) Comp-3 Value Zero.
05 Ws-ListA-Out Pic S9(007) Comp-3 Value Zero.
05 Ws-ListB-Out Pic S9(007) Comp-3 Value Zero.
05 Ws-ListC-Out Pic S9(007) Comp-3 Value Zero.
*
01 Ws-Swi-Eof-Parmfile Pic X(001) Value Zero.
88 Eof-Parmfile Value '1'.
*
01 Ws-Swi-Eof-Infile Pic X(001) Value Zero.
88 Eof-Infile Value '1'.
*
01 Ws-Write-Rec Pic X(001) Value 'Y'.
88 Ws-Write-Rec-Yes Value 'Y'.
88 Ws-Write-Rec-No Value 'N'.
*
01 NRNAME-FIELDS.
05 W-NAME PIC X(30).
05 FIRST-LASTNAME PIC X(30).
05 LAST-FIRSTNAME PIC X(30).
05 FIRSTNAME PIC X(30).
05 LASTNAME PIC X(30).
05 CNTRYCD PIC X VALUE 'H'.
*
01 Ws-ListA-Rec.
05 Ws-ListA-Xref Pic 9(011).
05 Ws-ListA-Fill01 Pic X(001).
05 Ws-ListA-Loc-Regs-Nr Pic X(012).
05 Ws-ListA-Fill02 Pic X(001).
05 Ws-ListA-Match-Code Pic X(034).
05 Ws-ListA-Fill03 Pic X(001).
05 Ws-ListA-Zip-Code Pic X(009).
05 Ws-ListA-Fill04 Pic X(001).
05 Ws-ListA-Street Pic X(050).
05 Ws-ListA-Fill05 Pic X(001).
05 Ws-ListA-Sur-Name Pic X(050).
05 Ws-ListA-Fill06 Pic X(001).
05 Ws-ListA-First-Name Pic X(004).
*
01 Ws-ListB-Rec.
05 Ws-ListB-Xref Pic 9(011).
05 Ws-ListB-Fill01 Pic X(001).
05 Ws-ListB-Loc-Regs-Nr Pic X(010).
05 Ws-ListB-Fill02 Pic X(001).
05 Ws-ListB-Zip-Code Pic X(003).
05 Ws-ListB-Fill03 Pic X(001).
05 Ws-ListB-Street Pic X(050).
05 Ws-ListB-Fill04 Pic X(001).
05 Ws-ListB-Sur-Name Pic X(050).
05 Ws-ListB-Fill05 Pic X(001).
05 Ws-ListB-First-Name Pic X(005).
*
01 Ws-ListC-Rec.
05 Ws-ListC-Xref Pic 9(011).
05 Ws-ListC-Fill01 Pic X(001).
05 Ws-ListC-Zip-Code Pic X(003).
05 Ws-ListC-Fill02 Pic X(001).
05 Ws-ListC-Street Pic X(050).
05 Ws-ListC-Fill03 Pic X(001).
05 Ws-ListC-Sur-Name Pic X(050).
05 Ws-ListC-Fill04 Pic X(001).
05 Ws-ListC-First-Name Pic X(005).
*
******************************************************************
Procedure Division.
******************************************************************
A000-Main Section.
******************************************************************
000.
*
Perform B000-Init
*
Display Ws-Prog-Id '+--------------------------------+'
Display Ws-Prog-Id '| 82QC9N: RDF Duplic. and Corre. |'
Display Ws-Prog-Id '| Requirement for Finland |'
Display Ws-Prog-Id '+--------------------------------+'
*
Perform C100-Read-Parmfile
*
Evaluate Parmfile-Parm
When 'LISTA'
Perform D100-Create-ListA
When 'LISTB'
Perform D200-Create-ListB
When 'LISTC'
Perform D300-Create-ListC
When Other
Display Ws-prog-id 'Input Parameter is Wrong:'
Parmfile-Parm
Perform Z999-Abend
End-Evaluate
*
Perform F000-End-Of-Program
*
.
A000-Main-Exit. STOP RUN.
******************************************************************
B000-Init Section.
******************************************************************
000.
*
Copy rdbucpdx Replacing ==:Program-Name:==
By ==Ws-Prog-Id (1:8)==.
*
Initialize Ws-Stt, Ws-Count, Ws-ListA-Rec, Ws-ListB-Rec,
Ws-ListC-Rec
*
* Open Customer File
*
Set Fhbcustc-Act-Open To True
Perform Z000-Call-File-Hnd
*
If Not Fhbcustc-Rc-Ok
Display Ws-Prog-Id
'Error When opening customer file'
'RC=' Fhbcustc-Rc
Perform Z999-Abend
End-if
*
* Open Parmfile
*
Open Input Parmfile
If Ws-Stt-Parmfile Not = Zeros
Display 'Open Error Parmfile : ' Ws-Stt-Parmfile
Perform Z999-Abend
End-If
*
* Open Infile
*
Open Input Infile
If Ws-Stt-Infile Not = Zeros
Display 'Open Error Infile: ' Ws-Stt-Infile
Perform Z999-Abend
End-If
*
* Open ListA
*
Open Output ListA
If Ws-Stt-ListA Not = Zeros
Display 'Open Error ListA : ' Ws-Stt-ListA
Perform Z999-Abend
End-If
*
* Open ListB
*
Open Output ListB
If Ws-Stt-ListB Not = Zeros
Display 'Open Error ListB : ' Ws-Stt-ListB
Perform Z999-Abend
End-If
*
* Open ListC
*
Open Output ListC
If Ws-Stt-ListC Not = Zeros
Display 'Open Error ListC : ' Ws-Stt-ListC
Perform Z999-Abend
End-If
*
.
B000-Init-Exit. Exit.
******************************************************************
C100-Read-Parmfile Section.
******************************************************************
000.
*
Read Parmfile
At End Move '1' TO Ws-Swi-Eof-Parmfile
End-Read
*
Display Ws-Prog-Id '+--------------------------------+'
Display Ws-Prog-Id '| File Created will be: '
Parmfile-Parm ' |'
Display Ws-Prog-Id '+--------------------------------+'
*
.
C100-Read-Parmfile-Exit. Exit.
******************************************************************
E100-Read-Cust-File Section.
******************************************************************
000.
*
Set Fhbcustc-Act-Read-Seq To true
Perform Z000-Call-File-Hnd
*
If fhbcustc-Rc-Ok
Add 1 To Ws-Cust-In-ListA
End-if
*
.
E100-Read-Cust-File-Exit. Exit.
******************************************************************
D100-Create-ListA Section.
******************************************************************
000.
*
Perform E100-Read-Cust-File
Perform Until Fhbcustc-Rc-Eof
Perform F000-Process
Perform G010-Write-ListA
Perform E100-Read-Cust-File
End-Perform
*
.
D100-Create-ListA-Exit. Exit.
******************************************************************
D200-Create-ListB Section.
******************************************************************
000.
*
Perform D200-Read-Infile
*
Perform Until Eof-Infile
Move Infile-Xref To Fmas-Hm-Xref
Perform E200-Read-Cust-File
Perform F000-Process
Perform G020-Write-ListB
Perform D200-Read-Infile
End-Perform
*
.
D200-Create-ListB-Exit. Exit.
******************************************************************
D300-Create-ListC Section.
******************************************************************
000.
*
Perform D200-Read-Infile
*
Perform Until Eof-Infile
Move Infile-Xref To Fmas-Hm-Xref
Perform E200-Read-Cust-File
Perform F000-Process
Perform G030-Write-ListC
Display 'Rec Completed'
Perform D200-Read-Infile
End-Perform
*
.
D300-Create-ListC-Exit. Exit.
******************************************************************
E200-Read-Cust-File Section.
******************************************************************
000.
*
Set Fhbcustc-Act-Read-Xref To True
Perform Z000-Call-File-Hnd
*
If fhbcustc-Rc-Ok
if Parmfile-Parm = 'LISTB'
Add 1 To Ws-Cust-In-ListB
End-if
if Parmfile-Parm = 'LISTC'
Add 1 To Ws-Cust-In-ListC
End-if
End-if
*
.
E200-Read-Cust-File-Exit. Exit.
******************************************************************
D200-Read-Infile Section.
******************************************************************
000.
*
Read Infile
At End Move '1' TO Ws-Swi-Eof-Infile
End-Read
*
.
D200-Read-Infile-Exit. Exit.
******************************************************************
F000-Process Section.
******************************************************************
000.
*
Perform F010-Get-Name
Perform F020-Get-Address
*
.
F000-Process-Exit. Exit.
******************************************************************
F010-Get-Name Section.
******************************************************************
000.
*
Move FMAS-HM-NAME To W-NAME
*
CALL 'NRNAME' USING CNTRYCD
W-NAME
FIRST-LASTNAME
LAST-FIRSTNAME
FIRSTNAME
LASTNAME
*
Move FIRSTNAME(2:4) To Ws-ListA-First-Name
Move FIRSTNAME(2:5) To Ws-ListB-First-Name
Ws-ListC-First-Name
*
Move LASTNAME To Ws-ListA-Sur-Name
Ws-ListB-Sur-Name
Ws-ListC-Sur-Name
.
F010-Get-Name-Exit. Exit.
******************************************************************
F020-Get-Address Section.
******************************************************************
000.
*
Initialize Rdbfdadc-Area
Move Fmas-Hm-Prom-Adrs-Ind To Rdbfdadc-Segm-Nr
Set Rdbfdadc-Addr-Actl-Cnt-Pntr
To Address Of Fhbcustc-Addr-Actl-Cnt
Set Rdbfdadc-Addr-Area-Pntr To Address Of Fmas-Addr-Area
Set Rdbfdadc-Find-By-Segm-Nr To True
Call Ws-Rdbfdadp Using Rdbfdadc-Area
If Rdbfdadc-Rc-Ok
Continue
Else
Display 'No Default Addr Seg : Xref ' Fmas-Hm-Xref
End-If
*
Initialize Ws-Addr-Area
Move Fmas-Addr-Flex-Adrs (Rdbfdadc-Segm-Sub)
To Ws-Addr-Flex-Adrs
Move 'FI' To Ws-Addr-Cntry-Cd-Iso
Set Ws-Addr-Format-Upper To True
Set Ws-Addr-Split-Adrs To True
Call Ws-Rdbaddrp Using Ws-Addr-Area
*
If Ws-Addr-Err Not = Zero
Display Ws-Rdbaddrp 'Err ' Ws-Addr-Err
Display Ws-Rdbaddrp 'Reason ' Ws-Addr-Err-Desc
Display Ws-Rdbaddrp 'Xref ' Fmas-Hm-Xref
Else
*
If Ws-Addr-Comp-Unf-Line-1(1:2) = 'PL'
Move Ws-Addr-Comp-Unf-Line-1 to Ws-ListA-Street
Ws-ListB-Street
Ws-ListC-Street
Else
move 0 to ws-pos
inspect Ws-Addr-Comp-Unf-Line-1
tallying ws-pos for characters
before initial space
If ws-pos > 0
Move Ws-Addr-Comp-Unf-Line-1(1:ws-pos) to
Ws-ListA-Street
Ws-ListB-Street
Ws-ListC-Street
Else
Move Ws-Addr-Comp-Unf-Line-1 to
Ws-ListA-Street
Ws-ListB-Street
Ws-ListC-Street
End-if
End-if
*
Move Ws-Addr-Comp-Zip To Ws-ListA-Zip-Code
Move Ws-Addr-Comp-Zip (1:3) To Ws-ListB-Zip-Code
Move Ws-Addr-Comp-Zip (1:3) To Ws-ListC-Zip-Code
End-If
*
.
F020-Get-Address-Exit. Exit.
******************************************************************
G010-Write-ListA Section.
******************************************************************
000.
*
Move Fmas-Hm-Match-Cd (1:34) To Ws-ListA-Match-Code
Move Fmas-Hm-Xref To Ws-ListA-Xref
Move Fmas-Hm-Loc-Regs-Nr To Ws-ListA-Loc-Regs-Nr
*
Move ';' To Ws-ListA-Fill01
Ws-ListA-Fill02
Ws-ListA-Fill03
Ws-ListA-Fill04
Ws-ListA-Fill05
Ws-ListA-Fill06
Move Ws-ListA-Rec To ListA-Rec
Write ListA-Rec
Add 1 To Ws-ListA-Out
*
.
G010-Write-ListA-Exit. Exit.
******************************************************************
G020-Write-ListB Section.
******************************************************************
000.
*
If Fmas-Hm-Loc-Regs-Nr(6:1) is numeric
Move Fmas-Hm-Loc-Regs-Nr(3:10) To Ws-ListB-Loc-Regs-Nr
Move ';' To Ws-ListB-Fill01
Ws-ListB-Fill02
Ws-ListB-Fill03
Ws-ListB-Fill04
Ws-ListB-Fill05
Move Fmas-Hm-Xref To Ws-ListB-Xref
Move Ws-ListB-Rec To ListB-Rec
Write ListB-Rec
Add 1 To Ws-ListB-Out
End-if
*
.
G020-Write-ListB-Exit. Exit.
******************************************************************
G030-Write-ListC Section.
******************************************************************
000.
*
Move Fmas-Hm-Xref To Ws-ListC-Xref
*
Move ';' To Ws-ListC-Fill01
Ws-ListC-Fill02
Ws-ListC-Fill03
Ws-ListC-Fill04
*
Move Ws-ListC-Rec To ListC-Rec
Write ListC-Rec
Add 1 To Ws-ListC-Out
*
.
G030-Write-ListC-Exit. Exit.
******************************************************************
Z000-Call-File-Hnd Section.
******************************************************************
000.
Call Fhbcustp
*
Evaluate true
When Fhbcustc-rc-ok
continue
When Fhbcustc-rc-eof
set Fhbcustc-rc-eof to true
When FHBCUSTC-RC-NOTFND
Display 'Customer Not Found' Infile-Xref
When other
Display Ws-prog-id
'Error after call fhbcustp: '
'Action = ' fhbcustc-act-action
';RC=' fhbcustc-rc
End-Evaluate
*
.
Z000-Call-File-Hnd-Exit. Exit.
******************************************************************
F000-End-Of-Program Section.
******************************************************************
000.
*
Set Fhbcustc-Act-Close to true
Perform Z000-Call-File-Hnd
*
If Not Fhbcustc-Rc-Ok and
Not Fhbcustc-Rc-Eof
Display Ws-Prog-Id
'Error When closing customer file(s): '
'RC = ' Fhbcustc-Rc
Perform Z999-Abend
End-if
*
Close ListA
Close ListB
Close ListC
Close Parmfile
Close Infile
*
Display Ws-prog-id
'Customer file read for ListA : ' Ws-Cust-In-ListA
Display Ws-prog-id
'Customer file read for ListB : ' Ws-Cust-In-ListB
Display Ws-prog-id
'Customer file read for ListC : ' Ws-Cust-In-ListC
Display Ws-prog-id
'Records Written to List A : ' Ws-ListA-Out
Display Ws-prog-id
'Records Written to List B : ' Ws-ListB-Out
Display Ws-prog-id
'Records Written to List C : ' Ws-ListC-Out
Display Ws-prog-id 'End of program. Normal Termination.'
*
.
F000-End-Of-Program-Exit. Exit.
******************************************************************
Z999-Abend Section.
******************************************************************
000.
*
Display ws-prog-id 'Program terminited due to error.'
Call 'ILBOABN0'
Using By Content x'0001'
End-Call
*
.
Z999-Abend-Exit. Exit.
******************************************************************
Program-Id. FIDUPCLP.
******************************************************************
Replace
copy Rdbreplr.
.
******************************************************************
* 82QC9N - RDF Duplicates and Correction *
*----------------------------------------------------------------*
* This program is for Finland. *
* To Create List A and List B and List C *
******************************************************************
Environment Division.
Configuration Section.
Special-Names.
Decimal-Point is Comma.
******************************************************************
Input-Output Section.
File-Control.
Select Parmfile Assign to Parmfile
File Status is Ws-Stt-Parmfile.
Select Infile Assign to Infile
File Status is Ws-Stt-Infile.
Select ListA Assign to ListA
File Status is Ws-Stt-ListA.
Select ListB Assign to ListB
File Status is Ws-Stt-ListB.
Select ListC Assign to ListC
File Status is Ws-Stt-ListC.
******************************************************************
Data Division.
******************************************************************
File Section.
******************************************************************
*
FD ListA
Label Record Standard
Recording Mode F.
01 ListA-Rec Pic X(176).
*
FD ListB
Label Record Standard
Recording Mode F.
01 ListB-Rec Pic X(134).
*
FD ListC
Label Record Standard
Recording Mode F.
01 ListC-Rec Pic X(123).
*
FD Parmfile
Label Record Standard
Recording Mode F.
01 Parmfile-Rec.
05 Parmfile-Parm Pic X(005).
05 Filler Pic X(075).
*
FD Infile
Label Record Standard
Recording Mode F.
01 Infile-Rec.
05 Infile-Xref Pic X(011).
05 Filler Pic X(013).
*
******************************************************************
Working-Storage Section.
******************************************************************
*
Copy RDBUCPDW.
*
* Customer File Segments
*
01 FMAS-HM-AREA EXTERNAL.
02 FMAS-HM-PART.
Copy RDBHMXXS Replacing ==:PREFIX:== By ==FMAS==.
*
01 FMAS-ADDR-AREA EXTERNAL.
02 FMAS-ADDR-PART OCCURS :ADDR-OCCUR:.
Copy RDBADDRS Replacing ==:PREFIX:== By ==FMAS==.
*
* File Handler Interface and Counters
Copy FHBCUSTC.
*
01 FHBCUSTP Pic X(008) Value 'FHBCUSTP'.
*
01 Ws-Rdbnamep Pic X(008) Value 'RDBNAMEP'.
Copy Rdbnamec Replacing ==:PREFIX:== By ==WS==.
*
01 Ws-Rdbaddrp Pic X(008) Value 'RDBADDRP'.
Copy Rdbaddrc Replacing ==:PREFIX:== By ==WS==.
*
01 Ws-Rdbfdadp Pic X(008) Value 'RDBFDADP'.
Copy Rdbfdadc Replacing ==:PREFIX:== By ==Rdbfdadc==.
*
01 Ws-Prog-id Pic X(010) Value 'FIDUPCLP:'.
01 Ws-Street Pic X(050) Value Spaces.
01 Ws-pos pic s9(004) comp.
*
* Work Fileds
*
01 Ws-Stt.
05 Ws-Stt-Parmfile Pic 9(002).
05 Ws-Stt-Infile Pic 9(002).
05 Ws-Stt-ListA Pic 9(002).
05 Ws-Stt-ListB Pic 9(002).
05 Ws-Stt-ListC Pic 9(002).
*
01 Ws-Count.
05 Ws-Cust-In-ListA Pic S9(007) Comp-3 Value Zero.
05 Ws-Cust-In-ListB Pic S9(007) Comp-3 Value Zero.
05 Ws-Cust-In-ListC Pic S9(007) Comp-3 Value Zero.
05 Ws-ListA-Out Pic S9(007) Comp-3 Value Zero.
05 Ws-ListB-Out Pic S9(007) Comp-3 Value Zero.
05 Ws-ListC-Out Pic S9(007) Comp-3 Value Zero.
*
01 Ws-Swi-Eof-Parmfile Pic X(001) Value Zero.
88 Eof-Parmfile Value '1'.
*
01 Ws-Swi-Eof-Infile Pic X(001) Value Zero.
88 Eof-Infile Value '1'.
*
01 Ws-Write-Rec Pic X(001) Value 'Y'.
88 Ws-Write-Rec-Yes Value 'Y'.
88 Ws-Write-Rec-No Value 'N'.
*
01 NRNAME-FIELDS.
05 W-NAME PIC X(30).
05 FIRST-LASTNAME PIC X(30).
05 LAST-FIRSTNAME PIC X(30).
05 FIRSTNAME PIC X(30).
05 LASTNAME PIC X(30).
05 CNTRYCD PIC X VALUE 'H'.
*
01 Ws-ListA-Rec.
05 Ws-ListA-Xref Pic 9(011).
05 Ws-ListA-Fill01 Pic X(001).
05 Ws-ListA-Loc-Regs-Nr Pic X(012).
05 Ws-ListA-Fill02 Pic X(001).
05 Ws-ListA-Match-Code Pic X(034).
05 Ws-ListA-Fill03 Pic X(001).
05 Ws-ListA-Zip-Code Pic X(009).
05 Ws-ListA-Fill04 Pic X(001).
05 Ws-ListA-Street Pic X(050).
05 Ws-ListA-Fill05 Pic X(001).
05 Ws-ListA-Sur-Name Pic X(050).
05 Ws-ListA-Fill06 Pic X(001).
05 Ws-ListA-First-Name Pic X(004).
*
01 Ws-ListB-Rec.
05 Ws-ListB-Xref Pic 9(011).
05 Ws-ListB-Fill01 Pic X(001).
05 Ws-ListB-Loc-Regs-Nr Pic X(010).
05 Ws-ListB-Fill02 Pic X(001).
05 Ws-ListB-Zip-Code Pic X(003).
05 Ws-ListB-Fill03 Pic X(001).
05 Ws-ListB-Street Pic X(050).
05 Ws-ListB-Fill04 Pic X(001).
05 Ws-ListB-Sur-Name Pic X(050).
05 Ws-ListB-Fill05 Pic X(001).
05 Ws-ListB-First-Name Pic X(005).
*
01 Ws-ListC-Rec.
05 Ws-ListC-Xref Pic 9(011).
05 Ws-ListC-Fill01 Pic X(001).
05 Ws-ListC-Zip-Code Pic X(003).
05 Ws-ListC-Fill02 Pic X(001).
05 Ws-ListC-Street Pic X(050).
05 Ws-ListC-Fill03 Pic X(001).
05 Ws-ListC-Sur-Name Pic X(050).
05 Ws-ListC-Fill04 Pic X(001).
05 Ws-ListC-First-Name Pic X(005).
*
******************************************************************
Procedure Division.
******************************************************************
A000-Main Section.
******************************************************************
000.
*
Perform B000-Init
*
Display Ws-Prog-Id '+--------------------------------+'
Display Ws-Prog-Id '| 82QC9N: RDF Duplic. and Corre. |'
Display Ws-Prog-Id '| Requirement for Finland |'
Display Ws-Prog-Id '+--------------------------------+'
*
Perform C100-Read-Parmfile
*
Evaluate Parmfile-Parm
When 'LISTA'
Perform D100-Create-ListA
When 'LISTB'
Perform D200-Create-ListB
When 'LISTC'
Perform D300-Create-ListC
When Other
Display Ws-prog-id 'Input Parameter is Wrong:'
Parmfile-Parm
Perform Z999-Abend
End-Evaluate
*
Perform F000-End-Of-Program
*
.
A000-Main-Exit. STOP RUN.
******************************************************************
B000-Init Section.
******************************************************************
000.
*
Copy rdbucpdx Replacing ==:Program-Name:==
By ==Ws-Prog-Id (1:8)==.
*
Initialize Ws-Stt, Ws-Count, Ws-ListA-Rec, Ws-ListB-Rec,
Ws-ListC-Rec
*
* Open Customer File
*
Set Fhbcustc-Act-Open To True
Perform Z000-Call-File-Hnd
*
If Not Fhbcustc-Rc-Ok
Display Ws-Prog-Id
'Error When opening customer file'
'RC=' Fhbcustc-Rc
Perform Z999-Abend
End-if
*
* Open Parmfile
*
Open Input Parmfile
If Ws-Stt-Parmfile Not = Zeros
Display 'Open Error Parmfile : ' Ws-Stt-Parmfile
Perform Z999-Abend
End-If
*
* Open Infile
*
Open Input Infile
If Ws-Stt-Infile Not = Zeros
Display 'Open Error Infile: ' Ws-Stt-Infile
Perform Z999-Abend
End-If
*
* Open ListA
*
Open Output ListA
If Ws-Stt-ListA Not = Zeros
Display 'Open Error ListA : ' Ws-Stt-ListA
Perform Z999-Abend
End-If
*
* Open ListB
*
Open Output ListB
If Ws-Stt-ListB Not = Zeros
Display 'Open Error ListB : ' Ws-Stt-ListB
Perform Z999-Abend
End-If
*
* Open ListC
*
Open Output ListC
If Ws-Stt-ListC Not = Zeros
Display 'Open Error ListC : ' Ws-Stt-ListC
Perform Z999-Abend
End-If
*
.
B000-Init-Exit. Exit.
******************************************************************
C100-Read-Parmfile Section.
******************************************************************
000.
*
Read Parmfile
At End Move '1' TO Ws-Swi-Eof-Parmfile
End-Read
*
Display Ws-Prog-Id '+--------------------------------+'
Display Ws-Prog-Id '| File Created will be: '
Parmfile-Parm ' |'
Display Ws-Prog-Id '+--------------------------------+'
*
.
C100-Read-Parmfile-Exit. Exit.
******************************************************************
E100-Read-Cust-File Section.
******************************************************************
000.
*
Set Fhbcustc-Act-Read-Seq To true
Perform Z000-Call-File-Hnd
*
If fhbcustc-Rc-Ok
Add 1 To Ws-Cust-In-ListA
End-if
*
.
E100-Read-Cust-File-Exit. Exit.
******************************************************************
D100-Create-ListA Section.
******************************************************************
000.
*
Perform E100-Read-Cust-File
Perform Until Fhbcustc-Rc-Eof
Perform F000-Process
Perform G010-Write-ListA
Perform E100-Read-Cust-File
End-Perform
*
.
D100-Create-ListA-Exit. Exit.
******************************************************************
D200-Create-ListB Section.
******************************************************************
000.
*
Perform D200-Read-Infile
*
Perform Until Eof-Infile
Move Infile-Xref To Fmas-Hm-Xref
Perform E200-Read-Cust-File
Perform F000-Process
Perform G020-Write-ListB
Perform D200-Read-Infile
End-Perform
*
.
D200-Create-ListB-Exit. Exit.
******************************************************************
D300-Create-ListC Section.
******************************************************************
000.
*
Perform D200-Read-Infile
*
Perform Until Eof-Infile
Move Infile-Xref To Fmas-Hm-Xref
Perform E200-Read-Cust-File
Perform F000-Process
Perform G030-Write-ListC
Display 'Rec Completed'
Perform D200-Read-Infile
End-Perform
*
.
D300-Create-ListC-Exit. Exit.
******************************************************************
E200-Read-Cust-File Section.
******************************************************************
000.
*
Set Fhbcustc-Act-Read-Xref To True
Perform Z000-Call-File-Hnd
*
If fhbcustc-Rc-Ok
if Parmfile-Parm = 'LISTB'
Add 1 To Ws-Cust-In-ListB
End-if
if Parmfile-Parm = 'LISTC'
Add 1 To Ws-Cust-In-ListC
End-if
End-if
*
.
E200-Read-Cust-File-Exit. Exit.
******************************************************************
D200-Read-Infile Section.
******************************************************************
000.
*
Read Infile
At End Move '1' TO Ws-Swi-Eof-Infile
End-Read
*
.
D200-Read-Infile-Exit. Exit.
******************************************************************
F000-Process Section.
******************************************************************
000.
*
Perform F010-Get-Name
Perform F020-Get-Address
*
.
F000-Process-Exit. Exit.
******************************************************************
F010-Get-Name Section.
******************************************************************
000.
*
Move FMAS-HM-NAME To W-NAME
*
CALL 'NRNAME' USING CNTRYCD
W-NAME
FIRST-LASTNAME
LAST-FIRSTNAME
FIRSTNAME
LASTNAME
*
Move FIRSTNAME(2:4) To Ws-ListA-First-Name
Move FIRSTNAME(2:5) To Ws-ListB-First-Name
Ws-ListC-First-Name
*
Move LASTNAME To Ws-ListA-Sur-Name
Ws-ListB-Sur-Name
Ws-ListC-Sur-Name
.
F010-Get-Name-Exit. Exit.
******************************************************************
F020-Get-Address Section.
******************************************************************
000.
*
Initialize Rdbfdadc-Area
Move Fmas-Hm-Prom-Adrs-Ind To Rdbfdadc-Segm-Nr
Set Rdbfdadc-Addr-Actl-Cnt-Pntr
To Address Of Fhbcustc-Addr-Actl-Cnt
Set Rdbfdadc-Addr-Area-Pntr To Address Of Fmas-Addr-Area
Set Rdbfdadc-Find-By-Segm-Nr To True
Call Ws-Rdbfdadp Using Rdbfdadc-Area
If Rdbfdadc-Rc-Ok
Continue
Else
Display 'No Default Addr Seg : Xref ' Fmas-Hm-Xref
End-If
*
Initialize Ws-Addr-Area
Move Fmas-Addr-Flex-Adrs (Rdbfdadc-Segm-Sub)
To Ws-Addr-Flex-Adrs
Move 'FI' To Ws-Addr-Cntry-Cd-Iso
Set Ws-Addr-Format-Upper To True
Set Ws-Addr-Split-Adrs To True
Call Ws-Rdbaddrp Using Ws-Addr-Area
*
If Ws-Addr-Err Not = Zero
Display Ws-Rdbaddrp 'Err ' Ws-Addr-Err
Display Ws-Rdbaddrp 'Reason ' Ws-Addr-Err-Desc
Display Ws-Rdbaddrp 'Xref ' Fmas-Hm-Xref
Else
*
If Ws-Addr-Comp-Unf-Line-1(1:2) = 'PL'
Move Ws-Addr-Comp-Unf-Line-1 to Ws-ListA-Street
Ws-ListB-Street
Ws-ListC-Street
Else
move 0 to ws-pos
inspect Ws-Addr-Comp-Unf-Line-1
tallying ws-pos for characters
before initial space
If ws-pos > 0
Move Ws-Addr-Comp-Unf-Line-1(1:ws-pos) to
Ws-ListA-Street
Ws-ListB-Street
Ws-ListC-Street
Else
Move Ws-Addr-Comp-Unf-Line-1 to
Ws-ListA-Street
Ws-ListB-Street
Ws-ListC-Street
End-if
End-if
*
Move Ws-Addr-Comp-Zip To Ws-ListA-Zip-Code
Move Ws-Addr-Comp-Zip (1:3) To Ws-ListB-Zip-Code
Move Ws-Addr-Comp-Zip (1:3) To Ws-ListC-Zip-Code
End-If
*
.
F020-Get-Address-Exit. Exit.
******************************************************************
G010-Write-ListA Section.
******************************************************************
000.
*
Move Fmas-Hm-Match-Cd (1:34) To Ws-ListA-Match-Code
Move Fmas-Hm-Xref To Ws-ListA-Xref
Move Fmas-Hm-Loc-Regs-Nr To Ws-ListA-Loc-Regs-Nr
*
Move ';' To Ws-ListA-Fill01
Ws-ListA-Fill02
Ws-ListA-Fill03
Ws-ListA-Fill04
Ws-ListA-Fill05
Ws-ListA-Fill06
Move Ws-ListA-Rec To ListA-Rec
Write ListA-Rec
Add 1 To Ws-ListA-Out
*
.
G010-Write-ListA-Exit. Exit.
******************************************************************
G020-Write-ListB Section.
******************************************************************
000.
*
If Fmas-Hm-Loc-Regs-Nr(6:1) is numeric
Move Fmas-Hm-Loc-Regs-Nr(3:10) To Ws-ListB-Loc-Regs-Nr
Move ';' To Ws-ListB-Fill01
Ws-ListB-Fill02
Ws-ListB-Fill03
Ws-ListB-Fill04
Ws-ListB-Fill05
Move Fmas-Hm-Xref To Ws-ListB-Xref
Move Ws-ListB-Rec To ListB-Rec
Write ListB-Rec
Add 1 To Ws-ListB-Out
End-if
*
.
G020-Write-ListB-Exit. Exit.
******************************************************************
G030-Write-ListC Section.
******************************************************************
000.
*
Move Fmas-Hm-Xref To Ws-ListC-Xref
*
Move ';' To Ws-ListC-Fill01
Ws-ListC-Fill02
Ws-ListC-Fill03
Ws-ListC-Fill04
*
Move Ws-ListC-Rec To ListC-Rec
Write ListC-Rec
Add 1 To Ws-ListC-Out
*
.
G030-Write-ListC-Exit. Exit.
******************************************************************
Z000-Call-File-Hnd Section.
******************************************************************
000.
Call Fhbcustp
*
Evaluate true
When Fhbcustc-rc-ok
continue
When Fhbcustc-rc-eof
set Fhbcustc-rc-eof to true
When FHBCUSTC-RC-NOTFND
Display 'Customer Not Found' Infile-Xref
When other
Display Ws-prog-id
'Error after call fhbcustp: '
'Action = ' fhbcustc-act-action
';RC=' fhbcustc-rc
End-Evaluate
*
.
Z000-Call-File-Hnd-Exit. Exit.
******************************************************************
F000-End-Of-Program Section.
******************************************************************
000.
*
Set Fhbcustc-Act-Close to true
Perform Z000-Call-File-Hnd
*
If Not Fhbcustc-Rc-Ok and
Not Fhbcustc-Rc-Eof
Display Ws-Prog-Id
'Error When closing customer file(s): '
'RC = ' Fhbcustc-Rc
Perform Z999-Abend
End-if
*
Close ListA
Close ListB
Close ListC
Close Parmfile
Close Infile
*
Display Ws-prog-id
'Customer file read for ListA : ' Ws-Cust-In-ListA
Display Ws-prog-id
'Customer file read for ListB : ' Ws-Cust-In-ListB
Display Ws-prog-id
'Customer file read for ListC : ' Ws-Cust-In-ListC
Display Ws-prog-id
'Records Written to List A : ' Ws-ListA-Out
Display Ws-prog-id
'Records Written to List B : ' Ws-ListB-Out
Display Ws-prog-id
'Records Written to List C : ' Ws-ListC-Out
Display Ws-prog-id 'End of program. Normal Termination.'
*
.
F000-End-Of-Program-Exit. Exit.
******************************************************************
Z999-Abend Section.
******************************************************************
000.
*
Display ws-prog-id 'Program terminited due to error.'
Call 'ILBOABN0'
Using By Content x'0001'
End-Call
*
.
Z999-Abend-Exit. Exit.
******************************************************************