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;