package LIMS::Model::Roles::Outreach;
use Moose::Role;
use Data::Dumper;
has $_ => ( is => 'ro', isa => 'HashRef', lazy_build => 1 )
for qw(pain_options_map nodal_options_map followup_options_map);
has overdue_notification => (
is => 'ro',
isa => 'HashRef[LIMS::DB::Outreach::RequestNotification]',
default => sub { {} },
lazy => 1,
traits => ['Hash'],
handles => {
set_notifications => 'set',
get_notification_event => 'get',
has_notification_event => 'exists',
},
);
has notification_events => (
is => 'ro',
isa => 'ArrayRef[Str]',
lazy_build => 1,
traits => ['Array'],
handles => {
all_events => 'elements',
get_event => 'get',
# final_event => 'pop', # can't do this in a loop !!
},
);
use Lingua::EN::Words2Nums;
#-------------------------------------------------------------------------------
sub do_outreach_request_pack_dispatch {
my ($self, $data) = @_;
my $followup_option_id = $data->{followup_option_id};
my $request_id = $data->{_request_id};
{ # request_followup table:
my @args = (
followup_option_id => $followup_option_id,
request_id => $request_id,
); # warn Dumper \@args;
LIMS::DB::Outreach::RequestFollowup->new(@args)->save;
}
# returns { period => duration } if option_id is a chronological one (eg six_week):
my $pack_dispatch_args = $self->get_pack_dispatch_args($followup_option_id); # href
if ( $pack_dispatch_args ) { # warn Dumper $pack_dispatch_args;
my $request = LIMS::DB::Request->new(id => $request_id)->load;
# warn $request->created_at->ymd;
# add ref_date:
$pack_dispatch_args->{ref_date} = $request->created_at;
my $pack_dispatch_date =
$self->calculate_pack_dispatch_date($pack_dispatch_args);
# warn $pack_dispatch_date->ymd;
do {
my %h = (
request_id => $request_id,
pack_due => $pack_dispatch_date,
);
LIMS::DB::Outreach::RequestPackDispatch->new(%h)->save;
};
}
}
#-------------------------------------------------------------------------------
# returns { duration_type => number } if option_id is a chronological one (eg six_week)
sub get_pack_dispatch_args {
my ($self, $option_id) = @_;
my $options_map = $self->followup_options_map; # warn Dumper $options_map;
my $followup_option_name = $options_map->{$option_id}->{option};
# warn $followup_option_name; # eg six_month
my ($numerical_word, $duration_type)
= $followup_option_name =~ /^(\w+)_(week|month)$/;
# warn Dumper [$numerical_word, $duration_type]; # eg six, month
return 0 unless $numerical_word && $duration_type
&& grep $duration_type =~ /$_\Z/, qw(week month);
$duration_type .= 's'; # week => weeks, month => months
my $number = words2nums($numerical_word); # warn $number;
die qq!cannot extract a number from "$numerical_word"!
unless defined $number; # could be 0 (zero_month)
return { duration_type => $duration_type, number => $number };
}
# shared with do_outreach_request_pack_dispatch() & M::Outreach::update_followup
sub calculate_pack_dispatch_date {
my $self = shift;
my $args = shift; # href of ref_date, period & integer
# duration_type = weeks / months, ref_date = datetime, num = 0, 1, 2, 3, etc
my ($duration_type, $ref_date, $number) = map $args->{$_},
qw(duration_type ref_date number);
my $dispatch_due_date = $ref_date->clone # clone to avoid changing it
->add($duration_type => $number) # + no. of weeks / months (could be 0)
->subtract(days => 14); # - 14 days
return $dispatch_due_date;
}
#-------------------------------------------------------------------------------
sub calculate_pack_return_date { # returns datetime object
my ($self, $ref_date) = @_; # datetime object
# return date = pack dispatch date + 40 days:
my $return_date = $ref_date->clone->add(days => 40); # clone otherwise updates orig!!
return $return_date;
}
=begin
#------------------------------------------------------------------------
sub get_followup_option_duration { # no longer in use
my ($self, $option_id) = @_;
my $options_map = $self->followup_options_map;
my $followup_durations = $self->followup_durations_map;
my $followup_option_name = $options_map->{$option_id}->{option}; # eg six_month
my $int = $followup_durations->{$followup_option_name}; # eg 0, 3, 6, etc
return $int;
}
#------------------------------------------------------------------------
sub followup_durations_map { # no longer in use
my $self = shift;
my $opts = $self->followup_options_map;
# get list of 'option' col:
my @follow_up_opts = map $opts->{$_}->{option}, keys %$opts;
# warn Dumper \@follow_up_opts;
my %map;
for my $option (@follow_up_opts) {
if ( $option =~ /(\w+)_month/ ) {
my $num = words2nums($1); # warn Dumper $num;
$map{$option} = $num if defined $num; # could be zero
}
} # warn Dumper \%map;
return \%map;
}
=cut
#-------------------------------------------------------------------------------
sub get_overdue_pack_notifications {
my $self = shift;
my $o = LIMS::DB::Outreach::RequestNotification::Manager
->get_request_notifications( require_objects => 'event' );
return $o;
}
#-------------------------------------------------------------------------------
# skip notification if final notification already sent, or less overdue than next event date:
sub skip_notification {
my ($self, $data) = @_;
my $today = LIMS::Local::Utils::time_now();
my $dfm = DateTime::Format::MySQL->new();
my $notification_event = $self->get_notification_event($data->{request_id});
my $pack_sent_date = $dfm->parse_date($data->{pack_sent});
my $event_id = $notification_event->event_id;
my $prev_event = $notification_event->event->days; # most recent notification
my $next_event = $self->get_event($event_id) || 0; # works due to array pos
my $final_event = $self->get_event(-1); # last entry in events list
my $delta_days = $pack_sent_date->delta_days($today)->delta_days;
# warn Dumper [$delta_days, $prev_event, $next_event, $final_event];
return ( $prev_event == $final_event || $delta_days < $next_event );
}
#-------------------------------------------------------------------------------
sub questionnaire_options {
my $self = shift;
my %h = (
followup_options => $self->followup_options_map,
nodal_options => $self->nodal_options_map,
pain_options => $self->pain_options_map,
);
return \%h;
}
#-------------------------------------------------------------------------------
# method shared by C::Outreach::edit_followup & M::Outreach (get_menu_options & update_followup)
sub _build_followup_options_map {
my $self = shift;
my $db_name = $self->lims_db->database eq 'lims_test' ? 'outreach_test' : 'outreach';
return $self->lims_dbix->select("${db_name}.followup_options", # backtick keywords:
[ qw(id label `option` `position`) ] )->map_hashes('id');
}
#-------------------------------------------------------------------------------
sub _build_pain_options_map {
my $self = shift;
my $dbix = $self->lims_dbix;
my $sql = q!select id, `option` from outreach.pain_options!;
my $map = $dbix->query($sql)->map;
return $map;
}
#-------------------------------------------------------------------------------
sub _build_nodal_options_map {
my $self = shift;
my $dbix = $self->lims_dbix;
my $sql = q!select id, `option` from outreach.nodal_options!;
my $map = $dbix->query($sql)->map;
return $map;
}
#-------------------------------------------------------------------------------
sub _build_notification_events {
my $self = shift;
my $dbix = $self->lims_dbix;
my $sql = 'select `days` from outreach.notification_events order by id';
my $o = $dbix->query($sql)->flat; # warn Dumper $o;
return $o;
}
1;
