• Files
• Commits
• Log
• Graph
• Stats

package ULISA;

# !!!!!!!!!!!!!!!!! not in use - replaced by C::R::ULISA !!!!!!!!!!!!!!!!

use strict;

use Local::Debug;
use Data::Dumper;
use DBIx::Simple;
use XML::Simple qw(:strict); # need to specify ForceArray & KeyAttr if using :strict here

my $xs = XML::Simple->new();

# generate list of specimens equivalent to [DGLRX][BL|F|SL|U]|T[B.|S.]|BMAT in _get_histology_specimens()
my $histology_tissues = join '|', qw(trephine block fixed);

# don't generate ULISA if requests restricted to:
my $ignored_fields = join '|', qw( Hist_ID TBCulture ZAP70 Hist(Details|Result)
    TimeStamp CutUp HandE Req(Rec|Out) );

my %xs_options = (
    RootName        => 'ulisa',
    NoAttr          => 1,
    XMLDecl         => 1,
    SuppressEmpty   => 1, # ? only works for xml_in
    KeyAttr         => [],
);

my %sql_for = (
  histology_fields => q!show columns from HistoPanel!,
  specimens        => q!select sample_code, sample_type from Specimens!,
  request_data     => q!select LName as last_name, FName as first_name, DoB as dob,
    Specimen as specimen, BlockRef as block_ref,
    concat('H',HMDS,'/',date_format(Date,'%y')) as lab_number
			from Main left join PID on P_ID = Pat_ID
    where DBID = ?!,
);

sub new {
	my ($class, $args) = @_;  Local::Debug::DEBUG $args;

	my $dbi = DBIx::Simple->new( $args->{dbh} ) or die DBIx::Simple->error;

	bless {
		dbi 				=> $dbi,
    query				=> $args->{query},
	 }, $class;
}

sub parse_data {
	my $self = shift;

  my $query = $self->{query};
  my $id    = $self->{query}->{ID}; # Local::Debug::DEBUG( 'ID: ' . $self->{query}->{ID} );

  my $histology_specimen_types = $self->_get_histology_specimen_types(); # arrayref
	my $requested_panels         = $self->_get_requests_from_query(); # arrayref
  my $request_data             = $self->_dbi($sql_for{request_data}, 'hash', $id); # hashref

  my @specimens = split /,\s?/, $request_data->{specimen};

  # add H&E to list if it's a Screen of histology specimen type(s), & Geimsa if it's a BMAT:
  if ($query->{screen_record}) {
    SPECIMEN: foreach my $specimen ( @specimens ) {
	    push @{ $requested_panels }, 'H and E' and last SPECIMEN if grep $specimen eq $_, @{ $histology_specimen_types };
    }
	  push @{ $requested_panels }, 'Giemsa'  if $request_data->{specimen} =~ /BMAT/;
  } # Local::Debug::DEBUG( @requested_panels );

  # return if nothing to generate:
  return unless @{ $requested_panels };

	my %xml;
  $xml{case} = $self->_format_case_data($request_data);
  $xml{specimens}{specimen} = []; # initialise for SPECIMEN block

  # only need this if decoding specimens:
#	my $specimen_details = $self->_get_specimen_details();

	SPECIMEN: foreach my $specimen ( @specimens ) { # Local::Debug::DEBUG( 'Specimen: ' . $specimen );
    # only need histology tissues:
    next SPECIMEN unless grep $specimen eq $_, @{ $histology_specimen_types };
#		my $tissue_type = $specimen_details->{$specimen};

    PANEL: foreach my $panel ( @{ $requested_panels } ) { # Local::Debug::DEBUG( 'Panel: ' . $panel );
		  push @{ $xml{specimens}{specimen} }, {
        block      => $request_data->{block_ref} || 'none',
#		    tissuetype => $tissue_type || 'unknown', # not decoding specimens
		    tissuetype => $specimen,
        protocol   => $panel,
        notes      => {},
		  };
  	}
  }

	$xml{specimens}{caseid} = $request_data->{lab_number};

	my $xml_out = $xs->XMLout( \%xml, %xs_options );

	return $xml_out;
}

sub _format_case_data {
  my $self = shift;
  my $data = shift;

	my ($first_name, $middle_name) = split ' ', $data->{first_name}
		unless $data->{first_name} =~ /^\d/; # ignore numerical entries

  return {
    accessionnum    => $self->{query}->{ID},
    caseid          => $data->{lab_number},
    firstname       => $first_name || $data->{first_name}, # if first_name is numerical
    middlename      => $middle_name || {},
    lastname        => $data->{last_name},
    birthdate       => $data->{dob} || {},
    MRN             => {},
  }
}

sub _get_histology_specimen_types {
	my $self = shift;

  my $specimen_details = $self->_get_specimen_details;

  my @specimens = grep {
      $specimen_details->{$_} =~ /$histology_tissues/;
  } keys %{ $specimen_details }; # Local::Debug::DEBUG( sort @specimens );

  return \@specimens;
}

sub _get_histology_data_fields {
	my $self = shift;

  my $histology_columns = $self->_dbi($sql_for{histology_fields}, 'arrays');

  my @panels = map {
      $_->[0];
  } grep {
      $_->[0] !~ /$ignored_fields/
  } @{ $histology_columns }; # Local::Debug::DEBUG( @panels );

  return \@panels;
}

sub _get_requests_from_query {
	my $self = shift;

  my $histology_data_fields = $self->_get_histology_data_fields; # arrayref

  my @requested_panels = grep $self->{query}->{$_} eq 'x', @{ $histology_data_fields };

  return \@requested_panels;
}

sub _get_specimen_details {
	my $self = shift;

  my $specimens = $self->_dbi($sql_for{specimens}, 'arrays');

	my %specimens = map {
		$_->[0] => $_->[1];
	} @{ $specimens };

	return \%specimens;
}

sub _dbi {
    my $self = shift;

    my $dbi = $self->{dbi};

    my ($sql, $format, $modifier) = @_;

    my $data = $modifier ? # precedence important here:
      $dbi->query( $sql, $modifier )->$format || $dbi->error
         :
      $dbi->query( $sql )->$format || $dbi->error;

		return $data;
}

1;