• Files
• Commits
• Log
• Graph
• Stats

package LIMS::Model::Outreach;

use Moose;
with (
	'LIMS::Model::Roles::DBIxSimple',
);
extends 'LIMS::Model::Base';
use namespace::clean -except => 'meta';

has actions => (
    is         => 'ro',
    isa        => 'ArrayRef[Str]',
    default    => sub { [] },
    lazy    => 1,
	traits  => ['Array'],
	handles => {
		add_to_actions => 'push',
		all_actions    => 'elements',
	},
);
__PACKAGE__->meta->make_immutable;

use LIMS::Local::Utils;
use Lingua::EN::Words2Nums;
use Data::Dumper;

#-------------------------------------------------------------------------------
sub get_all_data {
    my ($self, $args) = @_; # warn $request_id;
    
    my $request_id = $args->{request_id};
    my $patient_id = $args->{patient_id}; # warn Dumper $patient_id;
    
    my $dbix = $self->lims_dbix;
    
    # get request object for request_date for data summary section:
    my $request = LIMS::DB::Request->new(id => $request_id)->load;

    my %data = ();    

    { # first get list of all departments, lab_tests, defaults & ranges:
        my $sql = $self->sql_lib->retr('outreach_lab_params');
        my $query = $dbix->query($sql);
        
        # get list of cols from defaults_and_ranges table:
        my $meta = $self->get_meta('outreach.defaults_and_ranges'); # warn Dumper $meta;
        my @cols = grep {
            $meta->{$_}->{key} ne 'PRI' # skip primary key
        } keys %$meta; # warn Dumper \@cols;        

        while ( my $vars = $query->hash ) {
            my $param = $vars->{param_name};
            my $dept  = $vars->{description};
            
            my %params = (
                field_label => $vars->{field_label},
                field_type  => $vars->{field_type},
                result      => undef, # initialise placeholder
            );
            
            $data{$dept}{$param} = \%params;
            
            # add any (optional) default & ranges cols:
            map {
                $data{$dept}{$param}{$_} = $vars->{$_};
            } grep $vars->{$_}, @cols;
        }        
    }
    { # add lab_test results:
        my $sql = $self->sql_lib->retr('outreach_lab_results');
        my $query = $dbix->query($sql, $request_id);
        
        # get epoch value of current request for data summary:
        my $epoch = $request->created_at->epoch;
        
        while ( my $vals = $query->hash ) {
            my $result = $vals->{result};
            my $param  = $vals->{param_name};
            my $dept   = $vals->{description};
            
            # for individual sections (haem, immunol, etc):
            $data{$dept}{$param}{result} = $result;
            # for data summary:
            $data{datasets}{$epoch}{$param}{result} = $result;
        }
    }
    { # add patient demographics data:
        my $sql = $self->sql_lib->retr('outreach_patient_demographics');
        my $demographics = $dbix->query($sql, $patient_id)->hash;
        $data{demographics} = $demographics;        
    }
    { # questionnaire details:
        # my $sql = $self->sql_lib->retr('outreach_patient_questionnaire');
        # my $data = $dbix->query($sql, $request_id)->hash;
        my $data = LIMS::DB::Outreach::QuestionnaireLocality->new(
            request_id => $request_id
        )->load(speculative => 1);
        $data{questionnaire} = $data;        
    }
    { # followup data:
        my $follow_up = $self->get_followup_data($request_id);
        $data{followup} = $follow_up;        
    }
    { # patient notes:
        my $sql = $self->sql_lib->retr('outreach_patient_notes');
        my $data = $dbix->query($sql, $patient_id)->list;
        $data{demographics}{patient_notes} = $data;
    }
    # get GP's for practice:
    if ( my $practice_id = $data{demographics}{practice_id} ) {
        my $GPs = $self->_get_practitioners($practice_id);
        $data{demographics}{practitioners} = $GPs;
    }
    { # get unknown practitioner id:
        my $o = LIMS::DB::ReferralType->new(description => 'practitioner')->load;
        my $ref
            = LIMS::DB::Referrer->new(national_code => $o->default_unknown)->load;
        $data{demographics}{unknown_gp_id} = $ref->id;
    }
    { # non-participating practices:
        my $sql = 'select practice_id, 1 from outreach.non_participant_practice';
        my $ids = $dbix->query($sql)->map;
        $data{demographics}{non_participant_practices} = $ids;        
    }
    { # get menu options:
        my $sql = $self->sql_lib->retr('outreach_menu_options');
        my $query = $dbix->query($sql);
        my %opts;
        while ( my $vars = $query->array ) {
            my ($field_name, $detail) = @$vars;
            push @{ $opts{$field_name} }, $detail;
        }
        
        { # add follow_up options:
            my $followup_options = $self->get_followup_options;
            $opts{followup_options} = $followup_options;
        }
        
        $data{menu_options} = \%opts; # warn Dumper \%opts;
    }
    
    return \%data;
}
    
#-------------------------------------------------------------------------------
sub update_followup {
    my ($self, $args) = @_; # warn Dumper $args;
    
    my $option_id  = $args->{followup_option_id}; # required
    my $request_id = $args->{_request_id};        # required
    my $return_due = $args->{return_due};         # optional
    
    # get follow-up options table data:
    my $options_map = $self->get_followup_options; # warn Dumper $options;
    
    # map of followup option name => duration (months):
    my $followup_durations = $self->_followup_durations($options_map);
    
    # get existing data for this request:
    my @tbls = qw( outreach_request_followup outreach_request_pack_dispatch );
    my $data = LIMS::DB::Request->new(id => $request_id)
        ->load( with => \@tbls ); # warn Dumper $data->as_tree;

    # 1) where follow-up option has changed:
    if ( $option_id != $data->outreach_request_followup->followup_option_id ) {
        # get value of new duration (will be undef if not a duration choice):
        my $followup_option_name = $options_map->{$option_id}->{option}; # eg six_month
        my $new_duration = $followup_durations->{$followup_option_name}; # eg 6
        
        # where new follow-up option is a duration (including '0'):
        if ( defined $new_duration ) { # warn Dumper $new_duration;
            # calculate new pack due date - add new_duration to today:
            my $pack_due_date = $self->time_now->add( months => $new_duration );
            
            # if existing entry in request_pack_dispatch table, update:
            if ( $data->outreach_request_pack_dispatch ) {
                $data->outreach_request_pack_dispatch->pack_due($pack_due_date);
            }
            else { # else add a new request_pack_dispatch row:
                $data->outreach_request_pack_dispatch(
                    request_id => $request_id,
                    pack_due   => $pack_due_date,
                );
            }
        }
        # new follow-up not a duration - check existing pack dispatch:
        elsif ( my $pack_dispatch = $data->outreach_request_pack_dispatch ) {
            # set all dates to null:
            #$data->outreach_request_pack_dispatch->pack_due($null_date);
            #$data->outreach_request_pack_dispatch->return_due($null_date);
        }
        
        # register the follow-up option change (AFTER changing pack_due date):
        $data->outreach_request_followup->followup_option_id($option_id);
    }

	my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
    
    my $update = sub {
        $data->outreach_request_pack_dispatch->save(changes_only => 1);
        $data->outreach_request_followup->save(changes_only => 1);
    };
    
	my $ok = $db->do_transaction($update); return 1;
    
	# don't need return value unless error:
    return $ok ? 0 : 'update_followup() error - ' . $db->error;
}

#-------------------------------------------------------------------------------
sub update_patient_notes {
    my ($self, $args) = @_;
    
    my $dbix = $self->lims_dbix;

    my $tbl = 'outreach.patient_notes';
    
    my $patient_id = $args->{patient_id};
    my $form_param = $args->{detail};    

	my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;

	my $update = sub {
        my $sql = qq!select `detail` from $tbl where patient_id = ?!;
        if ( $dbix->query($sql, $patient_id)->into(my $detail) ) { # update or delete:
            if ($form_param) { # update:
                return 0 if $form_param eq $detail; # skip if no change
                $dbix->update($tbl,
                    { detail => $form_param },
                    { patient_id => $patient_id }
                );
                $self->add_to_actions('updated patient notes');
            }
            else { # delete:
                $dbix->delete($tbl, { patient_id => $patient_id });
                $self->add_to_actions('deleted patient notes');
            }
        }
        else { # new insert:
            $dbix->insert($tbl,
                { detail => $form_param, patient_id => $patient_id }
            );
            $self->add_to_actions('added new patient notes');
        }
		$self->do_history($patient_id);
    };
    
	my $ok = $db->do_transaction($update);
	
	# don't need return value unless error:
    return $ok ? 0 : 'update_patient_notes() error - ' . $db->error;    
}

#-------------------------------------------------------------------------------
sub update_dispatch_detail {
    my ($self, $args) = @_;
    
    my $patient_id  = $args->{patient_id};
    my $dispatch_to = $args->{dispatch_to};
    
	my $user_id = $self->user_profile->{id};

	my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;

    my $update = sub {
        my $o = LIMS::DB::Outreach::PatientDispatchDetail
            ->new(patient_id => $patient_id);
        # do patient demographic history if dispatch_to changed:
        if ( $o->load_speculative && $o->dispatch_to ne $args->{dispatch_to} ) {
			my $action = sprintf q!updated 'dispatch_to' from '%s'!, $o->dispatch_to;
			my %data = (
				patient_id => $patient_id,
				user_id    => $user_id,
				action 	   => $action,
			);
            LIMS::DB::PatientDemographicHistory->new(%data)->save;
        }
        $o->dispatch_to($dispatch_to);
        $o->save(changes_only => 1); # doesn't do changes_only
    };
    
	my $ok = $db->do_transaction($update);
	
	# don't need return value unless error:
    return $ok ? 0 : 'update_dispatch_detail() error - ' . $db->error;    
}

#-------------------------------------------------------------------------------
sub get_overdue_packs {
    my $self = shift;
    
    my $dbix = $self->lims_dbix;
    
    # get nhs_numbers of all request_ids where return_date < today:
    my $sql = $self->sql_lib->retr('outreach_overdue_packs_one');
    my $query = $dbix->query($sql);

    # query to find if follow-up sample registered after pack_sent date:
    my $follow_up = $self->sql_lib->retr('outreach_overdue_packs_two');
    
    my @overdue;
    
    my $today = LIMS::Local::Utils::time_now();

    REQ:
    while ( my $row = $query->hash ) { # nhs_number, pack_sent
        # skip if follow-up sample received after pack_sent date: 
        next REQ if $dbix->query( $follow_up,
            $row->{nhs_number}, $row->{pack_sent} )->list; # warn Dumper $row;
        
        # get details for overdue request:
        my $o = LIMS::DB::Request->new(id => $row->{request_id})
            ->load( with => 'patient_case.patient' );
        my $data = $o->as_tree(deflate => 0); # preserve DateTime
        # add pack_sent date:
        $data->{pack_sent} = $row->{pack_sent};
        $self->inflate_mysql_dates_to_datetime($data, ['pack_sent']);
        
        { # calculate delta_days (from pack_dispatch to current_date):
            my $delta = $data->{pack_sent}->delta_days($today)->delta_days;
            $data->{delta_days} = $delta;
        }
        
        push @overdue, $data;
    }
    
    return \@overdue;
}

#-------------------------------------------------------------------------------
sub get_packs_due_details {
    my $self = shift;
    
    my $dbix = $self->lims_dbix;    

    my $sql = $self->sql_lib->retr('outreach_packs_due_details');
    my $query = $dbix->query($sql);
    
    my @packs;
    
    while ( my $row = $query->hash ) {
        $self->inflate_mysql_dates_to_datetime($row, ['dob']);
        # re-arrange GP name:
        $row->{practitioner} = join ' ', reverse split ' ', $row->{practitioner};
        push @packs, $row;
    }
    
    return \@packs;
}

#-------------------------------------------------------------------------------
sub get_packs_due_summary {
    my $self = shift;
    
    my $dbix = $self->lims_dbix;    

    my $sql = $self->sql_lib->retr('outreach_packs_due_summary');
    my $query = $dbix->query($sql);
    
    my @packs;
    
    while ( my $row = $query->hash ) {
        $self->inflate_mysql_dates_to_datetime($row, ['pack_due']);
        $self->inflate_mysql_timestamp_to_datetime($row, ['created_at']);
        push @packs, $row;
    }
    
    return \@packs;
}

#-------------------------------------------------------------------------------
sub pack_labels {
    my $self = shift;
    my $dbix = $self->lims_dbix;    

    my $sql = $self->sql_lib->retr('outreach_pack_labels');
    
    my $data = $dbix->query($sql)->hashes;
    return $data;
}

#-------------------------------------------------------------------------------
sub get_outreach_practices {
    my $self = shift;
    
    my $dbix = $self->lims_dbix;    

    my $sql = $self->sql_lib->retr('outreach_practices');
    
    my $practices = $dbix->query($sql)->hashes;
    return $practices;
}

#-------------------------------------------------------------------------------
sub get_practice_blood_tube {
    my ($self, $practice_id) = @_;
    
    my $data
        = LIMS::DB::ReferralSource->new(id => $practice_id )
        ->load(with => 'outreach_practice_blood_tube');
    return $data;
}

#-------------------------------------------------------------------------------
sub update_practice_blood_tube {
    my ($self, $args) = @_;
    
    my $practice_id = $args->{practice_id};
    my $tube_type   = $args->{tube_type}; # optional
    
    my $o = LIMS::DB::Outreach::PracticeBloodTube->new(practice_id => $practice_id);
    
    # if row exists, only valid action is to delete:
    if ( $o->load(speculative => 1) ) {
        $o->delete;
    }
    elsif ($tube_type) { # insert new entry:
        $o->tube_type($tube_type);
        $o->save;
    }        

    return 0;  # or could return error, but will already propagate 
}

#-------------------------------------------------------------------------------
sub update_alternate_address {
    my $self = shift;
    my $data = shift; # warn Dumper $data;
    
    my $patient_id = $data->{patient_id};
    my $post_code  = $data->{post_code};
    my $address    = $data->{address};
    
    my $o = LIMS::DB::Outreach::PatientAlternateAddress
        ->new(patient_id => $patient_id)->load(speculative => 1);
    $o->address($address);
    $o->post_code($post_code);
    
    $o->save(changes_only => 1); # doesn't do changes_only, but ok as only 2 cols

    return 0;  # or could return error, but will already propagate 
}

#-------------------------------------------------------------------------------
sub get_packs_due_future {
    my $self = shift;
    
    my $dbix = $self->lims_dbix;    

    my $sql = $self->sql_lib->retr('outreach_packs_due_summary');
    # change pack_due <= CURRENT_DATE() to > CURRENT_DATE():
    $sql =~ s/<= (CURRENT_DATE)/> $1/; # warn $sql;    
    
    my @packs;
    
    my $today = LIMS::Local::Utils::time_now();

    my $query = $dbix->query($sql);
    while ( my $row = $query->hash ) {
        $self->inflate_mysql_dates_to_datetime($row, ['pack_due']);
        $self->inflate_mysql_timestamp_to_datetime($row, ['created_at']);
        { # calculate delta_days (from current_date to pack_dispatch):
            my $delta = $today->delta_days($row->{pack_due})->delta_days;
            $row->{delta_days} = $delta;
        }
        push @packs, $row;
    }
    
    return \@packs;
}

#-------------------------------------------------------------------------------
sub do_pack_dispatch {
    my ($self, $request_ids) = @_; # arrayref

	my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
    
    my $today = LIMS::Local::Utils::time_now();
    
    my $update = sub {
        for my $id(@$request_ids) {
            my $o = LIMS::DB::Outreach::RequestPackDispatch
                ->new(request_id => $id)->load;
            $o->pack_sent($today->ymd);
            $o->return_due( $today->add(months => 1)->ymd );
            $o->save(changes_only => 1);
        }
    };
    
	my $ok = $db->do_transaction($update);
    
	# don't need return value unless error:
    return $ok ? 0 : 'do_pack_dispatch() error - ' . $db->error;
}

#-------------------------------------------------------------------------------
# method shared by get_all_data & C::Outreach::edit_followup:
sub get_followup_data {
    my ($self, $request_id) = @_;
    
    my $dbix = $self->lims_dbix;

    my $sql = $self->sql_lib->retr('outreach_followup_data');
    my $data = $dbix->query($sql, $request_id)->hash;

	my $meta = $self->get_meta('outreach.request_pack_dispatch'); # warn Dumper $meta;
	my @date_fields = grep { $meta->{$_}->{type} eq 'date' } keys %$meta; # warn Dumper \@date_cols;

    $self->inflate_mysql_dates_to_datetime($data, \@date_fields);
    
    return $data;
}

#-------------------------------------------------------------------------------
# method shared by get_all_data & C::Outreach::edit_followup:
sub get_followup_options {
    my $self = shift;
    
    my $dbix = $self->lims_dbix;

    my $sql = 'select `id`, `label`, `option` from outreach.followup_options';
    my $options = $dbix->query($sql)->map_hashes('id');
    
    return $options;
}

#-------------------------------------------------------------------------------
sub get_diagnosis_ids {
    my $self = shift;
    
    my $dbix = $self->lims_dbix;
    
    my $ids = $dbix->query('select diagnosis_id from outreach.diagnoses')->flat;
    return $ids;    
}

#-------------------------------------------------------------------------------
sub do_history {
	my ($self, $patient_id) = @_;
	
	my @actions = $self->all_actions;
	
	my $dbix = $self->lims_dbix;

	my $user_id = $self->user_profile->{id};
	
	for my $action(@actions) {
		my %data = (
			patient_id => $patient_id,
			user_id    => $user_id,
			action 	   => $action,
		); # warn Dumper \%data;
		$dbix->insert('some_table', \%data); # request_history
	}	
}

#-------------------------------------------------------------------------------
sub _followup_durations {
    my $self = shift;
    my $opts = shift;
    
    # 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;
}

#-------------------------------------------------------------------------------
sub _get_practitioners { # from M::Referrer::get_referrers_by_source_id
    my ($self, $source_id) = @_;
    
    my @args = (
        query => [ 'referral_sources.id' => $source_id ],
        require_objects => [
            'referrer',
            'parent_organisation.referral_source'
        ],
    );

    # use ReferrerDepartment - easier to retrieve data from object:
    my $referrers = LIMS::DB::ReferrerDepartment::Manager
        ->get_referrer_department(@args);

    my @data = map { # warn Dumper $_->as_tree;
        [ $_->referrer->id, $_->referrer->name ];
    } sort { $a->referrer->name cmp $b->referrer->name } @$referrers;
    
    return \@data;
}

1;