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;