• Files
• Commits
• Log
• Graph
• Stats

package RequestForm::DB;

use LIMS::Local::QueryLibrary;
use DateTime::Format::MySQL;
use LIMS::Local::Utils;
use Clone 'clone';
use Data::Dumper;
use Path::Tiny;
use FindBin;

use lib '/home/raj/perl-lib';
use Local::DB;
# switch off auto-date-inflation until all apps date handling updated:
$Local::DBIx::Simple::Result::NO_AUTO_DATE_INFLATION = 1;

use RequestForm::Class; # provides Moo, Local::MooX::Types & LIMS::Local::Debug::p

has dbname  => ( is => 'ro', isa => String, required => 1 ); # uclh, hilis4, etc
has sql_lib => ( is => 'lazy' ); # returns SQL::Library obj
has dbix    => ( is => 'lazy' ); # returns DBIx::Simple object

sub _build_dbix {
    my $self = shift;

    my $db = $self->dbname; # dbname = uclh, leeds, etc
    $db =~ s/leeds/hilis4/; # leeds -> hilis4 symlink doesn't work on innodb tables

    my %args = ();
    $db eq 'test' # return in memory sqlite dbix object
        ? ( $args{dsn} = 'dbi:SQLite:dbname=:memory:' )
        : ( $args{dbname} = $db ); # warn Dumper \%args;
    my $dbix = Local::DB->dbix(\%args);
    return $dbix;
}

sub _build_sql_lib {
	my $lib = path($FindBin::Bin, '..', 'sql.lib')->realpath;
	LIMS::Local::QueryLibrary->new({ lib => $lib });
}

sub save_params {
    my $self = shift;
    my $vars = shift; # p $vars;

    # get field names from request_form table:
    my $cols = $self->get_cols('request_form'); # p $cols;
    my %h = map +($_ => $vars->{$_}), @$cols; # p %h;

    my $db = $self->dbix();
    $db->insert('request_form', \%h);
}

sub bcr_abl_monitoring { # bcr_abl_monitoring table:
    my $self = shift;
    my $vars = shift; # p $vars;

	# clone $vars to localise datetime transformation of date cols:
	my $data = clone($vars);

	my $db = $self->dbix();

	my $datetime_func =
		sub { LIMS::Local::Utils::to_datetime_using_datecalc(@_) };
	my $tbl  = 'patient_bcr_abl';
	my $cols = $self->get_cols($tbl); # p $cols;

	my @date_cols = grep $_ =~ /date/, @$cols; # p @date_cols;

	# this action changes date_col vals so needs to be performed on cloned vars:
	$data->{$_} = &$datetime_func($data->{$_})->ymd
        for grep $data->{$_}, @date_cols; # p $data;

	my %h = map +($_ => $data->{$_}), @$cols; # p %h;
	my %row_id = ( nhs_number => $data->{nhs_number} );

	if ( $db->select($tbl, 1, \%row_id)->list ) { # update:
        delete $data->{nhs_number}; # primary key (not strictly necessary to delete)
		$db->update($tbl, \%h, \%row_id);
	}
	else { # insert new:
		$db->insert($tbl, \%h);
	} # my $ref = $db->select($tbl, '*')->hashes; warn Dumper $ref;
}

sub search_patient {
    my ($self, $nhs_number) = @_; # p $nhs_number;

    my $db = $self->dbix();
    my $data = $db->select('patients', '*', { nhs_number => $nhs_number })->hash;
    return $data;
}

sub get_referrers {
    my ($self, $str, $id) = @_; # part of referrer (string)

    my $db  = $self->dbix();
    my $lib = $self->sql_lib;
    my $sql = $lib->retr('referrers');

    my $data = $db->query( $sql, $str, $id )->hashes; # p $vars;
    return $data;
}

sub get_referral_sources {
    my ($self, $str) = @_; # part of referral_location (string)

    my $db  = $self->dbix();
	my $lib = $self->sql_lib;
	my $sql = $lib->retr('referral_sources');

    my $data = $db->query( $sql, $str )->hashes; # p $vars;
    return $data;
}

sub get_previous_cml_monitoring {
    my ($self, $nhs_number) = @_;

    my $db  = $self->dbix();
	my $lib = $self->sql_lib;
	my $sql = $lib->retr('previous_cml_monitoring');

    my $query = $db->query( $sql, $nhs_number );

    my (@data, $last_result);
    # get bcr-abl results in reverse chronological order:
    while ( my $ref = $query->hash ) { # p $ref;
        # registration date to DT object:
        my $reg_date = DateTime::Format::MySQL->parse_date($ref->{registered});
        # extract bcr-abl:abl ratio if exists:
        my ($ratio)  = $ref->{result} =~ /(BCR-ABL : ABL ratio = .*%)/;

        # date of last result is reg date of most recent bcr-abl ratio:
        $last_result = $reg_date if ( $ratio and ! $last_result );

        # set result to bcr-abl:abl ratio, otherwise keep original:
        push @data, {
            registered => $reg_date,
            result     => $ratio || $ref->{result},
        };
    }
    my %h = (
        date_last => $last_result,
        results   => \@data,
    );

    { # get date of diagnosis & date 1st-line tx (if exists):
        my @cols = qw( diagnosis_date first_line_date );
        my $dates = $db->select( 'patient_bcr_abl', \@cols,
            { nhs_number => $nhs_number } )->hash;
        # dates to datetime objects:
        map {
            $dates->{$_} = DateTime::Format::MySQL->parse_date($dates->{$_});
        } grep $dates->{$_}, @cols;
        $h{dates} = $dates;
    } # p %h;
    return \%h;
}

sub get_user {
    my ($self, $username) = @_;

    my $db = $self->dbix();
    my @cols = qw( id first_name last_name );
    my $user = $db->select('users', \@cols, { username => $username })->hash;
    return $user;
}

sub get_cols {
	my ($self, $table) = @_;

    my $db = $self->dbname;

	my $meta = $db eq 'test'
        ? $self->get_meta_for_sqlite($table)
        : $self->get_meta_for_mysql($table); # p $meta;

	return [ keys %$meta ];
}

sub get_meta_for_mysql {
	my ($self, $table) = @_;

	my $dbh = $self->dbix;

	my $t = $dbh->query("show columns from $table")->hashes; # p $t;
	my %meta = map { $_->{field} => $_ } @$t; # p %meta;
	return \%meta;
}

sub get_meta_for_sqlite {
	my ($self, $table) = @_; # warn $table;

	my $dbh = $self->dbix;

	my $t = $dbh->query("PRAGMA table_info($table)")->hashes;
	my %meta = map { $_->{name} => $_ } @$t; # warn Dumper \%meta;
	return \%meta;
}

1;