package LIMS::Model::PrintRun;
use Moose;
extends 'LIMS::Model::Base';
with 'LIMS::Model::Roles::Query';
use namespace::clean -except => 'meta';
__PACKAGE__->meta->make_immutable;
use Data::Dumper;
use LIMS::Local::Utils;
#-------------------------------------------------------------------------------
sub get_print_run_size {
my ($self, $h) = @_; # warn Dumper $h; # hashref of start & end datetimes + optional cfg
# just forward to get_print_run_request_ids and return count:
my $ids = $self->get_print_run_request_ids($h);
my $i = scalar @$ids; # warn $i;
return $i;
}
#-------------------------------------------------------------------------------
sub get_print_run_request_ids {
my ($self, $h) = @_; # warn Dumper $h; # hashref of start & end datetimes + optional cfg
my ($start_date, $end_date, $type) = @{$h}{ qw(start_date end_date type) };
my %print_run_args = (
start => $start_date,
type => $type,
end => $end_date,
);
if ( defined $h->{offset} ) { # can be zero
$print_run_args{$_} = $h->{$_} for qw(offset limit);
}
my @request_ids = do {
my ($sql, @bind) = $self->get_query_params(\%print_run_args);
# $self->lims_dbix->dump_query($sql, @bind);
$self->lims_dbix->query($sql, @bind)->flat; # warn Dumper $results;
};
# get copy-to's:
my @copy_tos = do {
my ($sql, @bind) = $self->get_cc_request_ids(\%print_run_args);
# $self->lims_dbix->dump_query($sql, @bind);
$self->lims_dbix->query($sql, @bind)->flat;
}; # warn Dumper \@copy_tos;
# combine @request_ids & @copy_tos as list of unique request ids:
my %h = map { $_ => undef } ( @request_ids, @copy_tos ); # warn Dumper \%h;
my @all_request_ids = keys %h;
# return separate request_ids & copy_tos if required, otherwise all_request_ids:
return wantarray
? ( \@request_ids, \@copy_tos )
: \@all_request_ids;
}
#-------------------------------------------------------------------------------
sub get_cc_request_ids {
my $self = shift;
my $args = shift;
my $start = $args->{start}; # DT object
my $type = $args->{type};
my $end = $args->{end}; # DT object
my @rels = (
# table|alias # FK-PK relationship
'requests|r' , 'rr.request_id = r.id' ,
'request_report_view|rr' , 'ro.request_id = r.id' ,
'request_option|ro' , 'ro.option_id = ao.id' ,
'additional_options|ao' , 'r.status_option_id = so.id' ,
'status_options|so' ,
);
# set status level required for printing reports:
my $status = $self->does_authorisation() ? 'authorised' : 'reported'; # warn $status;
my %query = (
'so.description' => { -in => [ $status, 'complete' ] },
'ao.option_name' => 'copy_to',
'DATE(rr.updated_at)' => ( $start->ymd eq $end->ymd )
? $start->ymd # or $end->ymd, both same date
: { -between => [ $start->ymd, $end->ymd ] },
);
my %h = (
cols => 'r.id',
joins => \@rels,
where => \%query,
);
if ( $type eq 'clinical-trial' ) { # include request_trial/clinical_trials:
push @rels, ( 'rt.request_id=r.id' => 'request_trial|rt' ,
'rt.trial_id=ct.id' => 'clinical_trials|ct' );
}
elsif ( $type eq 'non-trial' ) { # left join request_trial to exclude:
push @rels, ( '=>rt.request_id=r.id' => 'request_trial|rt' );
$query{'rt.request_id'} = undef;
}
my ($sql, @bind) = $self->sqla_query(\%h);
# $self->lims_dbix->dump_query($sql, @bind);
return ($sql, @bind);
}
#-------------------------------------------------------------------------------
sub get_query_params { # returns $sql & @bind params - shared with print_run.pl
my $self = shift; # warn ref $self;
my $args = shift; # trial or non-trial cases, start & end dates
my $start = $args->{start}; # DT object
my $type = $args->{type}; # trial or non-trial
my $end = $args->{end}; # DT object
my $settings = $self->lims_cfg->{settings}; # warn Dumper $settings;
my $tbl_rels = get_tbl_rels($type);
# set status level required for printing reports:
my $status = $self->does_authorisation() ? 'authorised' : 'reported'; # warn $status;
my %query = ( 'so.description' => { -in => [ $status, 'complete' ] } );
$query{'DATE(rr.updated_at)'} = ( $start->ymd eq $end->ymd )
? $start->ymd # or $end->ymd, both same date
: { -between => [ $start->ymd, $end->ymd ] }; # warn Dumper \%query;
my @sort_by;
if ( $type eq 'clinical-trial' ) { # don't exclude any locations
@sort_by = qw(ct.trial_name r.year r.request_number);
}
elsif ( $type eq 'non-trial' ) {
if ( $settings->{print_run_skip_trials} ) { # skip trial cases if configured
$query{'rt.request_id'} = undef;
}
=begin # skip_paper_reports.yml - replaced by get_email_report_details() using email_contacts table:
if ( my $cfg = $self->get_yaml_file('skip_paper_reports') ) { # p $cfg;
if ( my $org_codes = $cfg->{organisation} ) { # p $org_codes;
$query{'po.parent_code'} = { -not_in => $org_codes };
}
if ( my $hospitals = $cfg->{hospital} ) { # p $hospitals;
$query{'rs.organisation_code'} = { -not_in => $hospitals };
}
if ( my $departments = $cfg->{department} ) { # p $departments;
for (@$departments) { # eg RWA/823
my ($location, $department) = split '/'; # p $location; p $department;
# 5-digits (hospital) or 3-digits (organisation) code:
my $site_type = length $location > 3
? 'rs.organisation_code'
: 'po.parent_code';
my %h = (
$site_type => $location,
'rd.hospital_department_code' => $department,
);
push @{ $query{-not_bool} }, \%h;
}
}
}
=cut
{ # exclude any locations/departments configured for email (email_contacts table):
my $ref = $self->get_email_report_details; # warn Dumper $ref; # hashref
my %all_depts; # set in 1st 2 blocks below, used for skipping location departments
# organisations - all departments:
if ( my $org_codes = $ref->{organisation_all} ) { # aref
my $parent_ids = $all_depts{parent} = $org_codes;
$query{'rs.parent_organisation_id'} = { -not_in => $parent_ids };
}
# hospitals - all departments:
if ( my $org_codes = $ref->{hospital_all} ) { # aref
my $hospital_ids = $all_depts{hospital} = $org_codes;
$query{'rs.id'} = { -not_in => $hospital_ids };
}
# specific organisation/department combinations:
if ( my $organisation = $ref->{organisation_dept} ) { # HoA
while ( my($parent_id, $dept_ref) = each %$organisation ) {
# skip if already in organisation/all-departments list:
next if grep $parent_id == $_, @{ $all_depts{parent} };
push @{ $query{-not_bool} }, {
'rs.parent_organisation_id' => $parent_id,
'rd.hospital_department_code' => $_,
} for @$dept_ref;
}
}
# specific hospital/department combinations:
if ( my $hospital = $ref->{hospital_dept} ) {
while ( my($source_id, $dept_ref) = each %$hospital ) {
# skip if already in hospital/all-departments list:
next if grep $source_id == $_, @{ $all_depts{hospital} };
push @{ $query{-not_bool} }, {
'rs.id' => $source_id,
'rd.hospital_department_code' => $_,
} for @$dept_ref;
}
}
} # warn Dumper \%query;
@sort_by = qw(ref.name r.year r.request_number);
}
my %sqla_args = (
cols => 'r.id',
joins => $tbl_rels,
where => \%query,
order_by => \@sort_by,
);
if ( defined $args->{offset} ) { # can be zero
$sqla_args{$_} = $args->{$_} for qw(offset limit);
} # warn Dumper \%sqla_args;
my ($sql, @bind) = $self->sqla_query(\%sqla_args);
# $self->lims_dbix->dump_query($sql, @bind);
return ($sql, @bind);
}
sub get_tbl_rels {
my $type = shift; # trial or non-trial cases
my @rels = (
# table|alias # FK-PK relationship
'requests|r' , 'r.referrer_department_id = rd.id' ,
'referrer_department|rd' , 'rd.referrer_id = ref.id' ,
'referrers|ref' , 'r.patient_case_id = pc.id' ,
'patient_case|pc' , 'rr.request_id = r.id' ,
'request_report_view|rr' , 'r.status_option_id = so.id' ,
'status_options|so' , 'pc.referral_source_id = rs.id' ,
'referral_sources|rs' ,
);
if ( $type eq 'clinical-trial' ) { # include request_trial/clinical_trials:
push @rels, ( 'rt.request_id=r.id' => 'request_trial|rt' ,
'rt.trial_id=ct.id' => 'clinical_trials|ct' );
}
elsif ( $type eq 'non-trial' ) { # left join request_trial to exclude:
push @rels, ( '=>rt.request_id=r.id' => 'request_trial|rt' );
}
return \@rels;
}
sub get_email_report_details {
my $self = shift;
my @contacts = do {
my @cols = qw(
ec.display_name
ec.referral_source_id|source_id
rs.parent_organisation_id|parent_id
ec.scope
ec.department_id
ec.status
);
my @rels = (
'email_contacts|ec' => 'ec.referral_source_id=rs.id',
'referral_sources|rs'
);
my %args = (
cols => \@cols,
joins => \@rels,
where => {
'ec.is_active' => 'yes',
'ec.type' => 'report',
'ec.display_name' => { -not_rlike => 'CWT$' }, # cancer waiting times
},
); # p @args;
my ($sql, @bind) = $self->sqla_query(\%args); # warn $sql; warn Dumper \@bind;
# $self->lims_dbix->dump_query($sql, @bind);
$self->lims_dbix->query($sql, @bind)->hashes;
};
my @contact_cols = qw( scope parent_id department_id source_id status );
my %h; # HoH to provide unique location/department entries if multiple contact addresses
for my $contact (@contacts) { # warn Dumper $contact; next;
my ($scope, $parent_id, $department_id, $source_id, $want_status)
= @{$contact}{@contact_cols};
# warn Dumper [$scope, $parent_id, $department_id, $source_id, $want_status];
if ( $scope eq 'organisation' ) {
$department_id
? $h{organisation_dept}{$parent_id}{$department_id}++ # organisation/department
: $h{organisation_all}{$parent_id}++ # entire organisation
}
else { # scope = 'hospital'
$department_id
? $h{hospital_dept}{$source_id}{$department_id}++ # hospital/department
: $h{hospital_all}{$source_id}++ # entire hospital
}
} # warn Dumper \%h;
my @all_organisation_ids = keys %{ $h{organisation_all} };
my @all_hospital_ids = keys %{ $h{hospital_all} };
my $organisation_dept_ref = do { # transform $h{organisation_dept} internal hashrefs to arrayrefs:
my $o = $h{organisation_dept};
+{ map +($_ => [ keys %{$o->{$_}} ]), keys %$o }
}; # warn Dumper $organisation_dept_ref;
my $hospital_dept_ref = do { # transform $h{hospital_dept} internal hashrefs to arrayrefs:
my $o = $h{hospital_dept};
+{ map +($_ => [ keys %{$o->{$_}} ]), keys %$o }
}; # warn Dumper $hospital_dept_ref;
my %data = (
organisation_dept => $organisation_dept_ref, # HoA
organisation_all => \@all_organisation_ids, # aref
hospital_dept => $hospital_dept_ref, # HoA
hospital_all => \@all_hospital_ids, # aref
); # warn Dumper \%data;
return \%data;
# flatten organisation and hospital location_id hashrefs to array(ref) so
# $data just contains lists of arrayrefs (generates same as above %data):
my $data = LIMS::Local::Utils::convert_hashrefs_to_arrayrefs(\%h); # warn Dumper $data;
# return $data
}
1;
