Я пытался уменьшить беспорядок. Во-первых, определяемые вами константы создают много беспорядка, а не помогают с удобочитаемостью. Если у вас было что-то вроде
use constant LICENSE_NO => 42;
Я бы понял, но если константы просто будут соответствовать индексам целочисленных массивов, то я не вижу смысла.
Я также поместил всю печать в отдельную подпрограмму и добавил проверку ошибок в операторы print и close.
Я не утверждаю, что все это является решением вашей проблемы, но именно здесь я бы начал отлаживать. Здесь могут быть некоторые опечатки, так что будьте осторожны.
#!/usr/bin/perl
use warnings; use strict;
use DBI;
use File::Spec::Functions qw( catfile );
my @proc = qw(ccr1 ccr2 ccr3 ccr4 ccr5);
# Capture Directory Path from Environment Variable:
my $DIRECTORY = $ENV{DATADIR};
# Process Counters:
my %fileCntr = map { $_ => 0 } @proc;
# Process Control Hashes:
my %xref = ();
# Process Control Variables:
my $diag = 0;
my $proc = 0;
my $ndcc = 0;
my $previous = "";
# Claims Extract array:
my @arr = ();
my $hdr = "";
# Accept/Parse DSS Connection String:
my ($USER, $PASS, $CONN) = ($ENV{PSWD} =~ m{^(.+)/(.+)\@(.+)});
# ALTER Date format:
my $ATL = qq(ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD');
# Database Connection:
my $dbh = DBI->connect(
"DBI::Oracle:$CONN", $USER, $PASS,
{ RaiseError => 1, AutoCommit => 0 },
);
$dbh->do($ATL); # Execute ALTER session.
my $SQL = qq(
SELECT ... here is a big sql query
);
my %outh;
for my $proc ( @proc ) {
my $fn = catfile $DIRECTORY, "$proc.dat";
open $outh{ $proc }, '>', $fn
or die "Cannot open '$fn' for writing: $!";
}
# Redirect STDOUT to log file:
open STDOUT, '>', catfile($DIRECTORY, 'ccr.log')
or die "Unable to open LOG file: $!";
# Prepare $SQL for execution:
my $sth = $dbh->prepare($SQL);
$sth->execute();
# Produce out files:
while (my @arr = $sth->fetchrow_array) {
# Direct Write of CCR1&2 records:
BuildCCR12(\@arr);
# Write and Wipe CCR3 HASH Table:
WriteCCR3(\@arr) unless ($arr[0] == $previous);
BuildCCR3(\@arr);
# Loop processing for CCR4:
BuildCCR4(\@arr);
# Loop processing for CCR5:
BuildCCR5(\@arr);
}
# Print Record Counts for OUTPUT files:
foreach my $key (keys %fileCntr) {
printf "%s: %s\n", $key, $fileCntr{$key};
}
# Terminate DB connection:
$sth->finish();
$dbh->disconnect();
for my $proc (keys %outh) {
close $outh{ $proc } or die "Cannot close filehandle for '$proc': $!";
}
sub print_to {
my ($dest, $data) = @_;
my $fh = $outh{$dest};
print $fh join('|', @$data), "\n"
or die "Error writing to '$dest' file: $!";
$fileCntr{$dest}++;
return;
}
sub BuildCCR12 {
my ($arr) = @_;
print_to(ccr1 =>
[@{$arr}[6, 7, 5, 0, 8, 9, 10, 13, 2, 3, 40, 16]]);
if ($arr->[17] ne '###########') {
print_to(ccr2 =>
[++$ndcc, @{ $arr }[0, 6, 7, 17, 19, 18, 2, 3, 39]]);
}
return;
}
sub WriteCCR3 {
my ($arr) = @_;
unless ($previous) {
# Produce ccr3 from DISTINCT combo listing:
print_to(ccr3 => [ keys %xref ]);
%xref = ();
}
return;
}
sub BuildCCR3 {
my ($arr) = @_;
# Spin off relationship:
for my $i (8 .. 13) {
unless ($arr->[$i] == -1) {
my $k = join '|', @{ $arr }[0, $i];
$xref{ $k } = $k;
}
}
$previous = $arr->[0];
return;
}
sub BuildCCR4 {
my ($arr) = @_;
# Spin off relationship:
for my $i (26 .. 37) {
my $sak = join '|', @{ $arr }[0, 6, 7, $i];
my $v = $arr->[$i];
unless ( $v =~ /^#{6,7}\z/ ) {
print_to(ccr4 => [++$diag, @{ $arr }[0, 6, 7, $v]]);
}
}
return;
}
sub BuildCCR5 {
my ($arr) = @_;
# Spin off field0/Procedure relationship:
for my $i (20 .. 23) {
my $v = $arr[$i];
my $sak = join('', @{ $arr }[0, 6, 7], $v);
unless ($v eq '######' or $v eq '####') {
print_to(ccr5 => [++$proc, @{ $arr }[0, 6, 7], $v]);
}
}
return;
}