• Files
• Commits
• Log
• Graph
• Stats

package LIMS::Local::GalliumData;

# for use with gallium_data.pl (supercedes GalliumTrial for use with
# gallium_data_roche.pl & gallium_data_quintiles.pl)

use Moo;
use LIMS::Local::MooX::Types qw(HashReference);

has data => ( is  => 'ro', isa => HashReference, required => 1 );

use Data::Dumper;
use LIMS::Local::Utils;

my $trim = sub { LIMS::Local::Utils::trim(@_) };

#===============================================================================
use Regexp::Common qw(pattern); # Regexp::Common patterns:

pattern # biopsy type
	name => [ qw(biopsy type) ],
	create => 'Type of biopsy\:\s*(\b\w+\b(\s\b\w+\b?)+)'; # matches 1 or more words

pattern # % lymphoma involvement
	name => [ qw(lymphoma involvement) ],
	create => 'Marrow involvement\:\s*(\d+?)%'; # capture digits before %

pattern # discrepant diagnosis
	name => [ qw(discrepant diagnosis) ],
	create => 'Discrepant diagnosis\:\s*(\b\w+\b)'; # capture word

pattern # discrepant localisation
	name => [ qw(discrepant localisation) ],
	create => 'Discrepant localisation\:\s*(\b\w+\b)'; # capture word

pattern # trial eligibility
	name => [ qw(trial eligible) ],
	create => 'Eligible for trial\:\s*(\b\w+\b)'; # capture word

pattern # lymphoma grade
	name => [ qw(lymphoma grade) ], # "Lymphoma grade: xn" OR "grade xn" :
	create => '\b(?:Lymphoma )?grade(?:[\s\:]+)?(\d\w?)\b'; # 1,2,3[ab]

pattern # dna volume
	name   => [ qw(dna volume) ],
	create => 'DNA volume\:(.*)ul'; # DNA volume\:(.*)ul

pattern # dna concentration
	name   => [ qw(dna concentration) ],
	create => 'DNA concentration\:(.*)ng';

pattern # dna purity
	name   => [ qw(dna purity) ],
	create => 'DNA purity OD260\/280\:\s*(\d*\.\d+)';

pattern # dna sections
	name   => [ qw(dna sections) ],
	create => 'DNA sections\:(.*)micron';

pattern # rna volume
	name   => [ qw(rna volume) ],
	create => 'RNA volume\:(.*)ul'; # DNA volume\:(.*)ul

pattern # rna concentration
	name   => [ qw(rna concentration) ],
	create => 'RNA concentration\:(.*)ng';

pattern # rna purity
	name   => [ qw(rna purity) ],
	create => 'RNA purity OD260\/280\:\s?(\d*\.\d+)';

pattern # rna sections
	name   => [ qw(rna sections) ],
	create => 'RNA sections\:(.*)micron';

pattern # tma status
	name   => [ qw(tma status) ],
	create => 'TMA taken\:\s*(\b\w+\b( \b\w+\b)?)'; # matches 1 or 2 words

pattern # tma position
	name   => [ qw(tma position) ], # 1st number = block, then 2 core positions:
	create => 'Position on TMA\:\s*(\d{1,2}\w\d\w\d)'; # [A1 - J5, eg 2A1B2]

pattern # tma cores
	name   => [ qw(tma cores) ],
	create => 'No. of TMA cores\:\s*(\d)'; # single digit

pattern # IgH-ASO assay
	name   => [ qw(igh_aso assay) ],
	create => 'IgH-ASO assay\:\s*(\b\w+\b( \b\w+\b)?)'; # matches 1 or 2 words

pattern # IgH-ASO result
	name   => [ qw(igh_aso result) ],
	create => 'IgH-ASO result\:\s*(not evaluable|(mono|oligo|poly)clonal)';

pattern # IgH-ASO bp length
	name   => [ qw(igh_aso bp_length) ],
	create => 'IgH-ASO bp length\:\s*(\d+)';

pattern # IgH-ASO comment
	name   => [ qw(igh_aso comment) ],
	create => 'IgH-ASO comment\:\s*(.*)';

#===============================================================================

sub get_lab_role {
    my $self = shift;

    my $source = $self->data->{source};
    my $result = $source =~ /^Kiel/i # query now exclusively source = Quintiles
		? 'Adjudicator' : 'First Time Reviewer';
    return $result;
}

# extract block ref + number of slides & blocks from external_ref:
sub get_external_reference {
    my $self = shift;

    my $exref = $self->data->{external_reference} or return 0;

    # just capture 1st item of block_ref eg (125-16696) x20uss
    my ($block_ref) = split /\sx(:?\d+)[spu]/, $exref; # warn $block_ref;

    my ($unstained_slides) = $exref =~ /x(\d+)uss/; # warn $unstained_slides
    my ($stained_slides)   = $exref =~ /x(\d+)ss/; # warn $stained_slides
    my ($blocks)           = $exref =~ /x(\d+)p/; # warn $blocks;

    my $slides = do {
        no warnings 'uninitialized';
        $unstained_slides + $stained_slides;
    }; # warn Dumper [$block_ref, $slides, $blocks];

    my %h = (
        block_id => &$trim($block_ref),
        slides   => $slides || 0,
        blocks   => $blocks || 0,
    );
    return \%h;
}

sub get_dna_results {
    my $self = shift;

    my %h = ();

	if ( my $result = $self->data->{molecular_summary} ) {
		if ( $result =~ $RE{dna}{volume}{-keep} ) { # warn $1;
			$h{dna_volume} = &$trim($1);
		}
		if ( $result =~ $RE{dna}{concentration}{-keep} ) { # warn $1;
			$h{dna_concentration} = &$trim($1);
		}
		if ( $result =~ $RE{dna}{purity}{-keep} ) { # warn $1;
			$h{dna_purity} = $1;
		}
		if ( $result =~ $RE{dna}{sections}{-keep} ) { # warn $1
			$h{dna_sections} = &$trim($1);
		}
	} # warn Dumper \%h;

    return \%h;
}

sub get_rna_results {
    my $self = shift;

    my %h = ();

    if ( my $result = $self->data->{molecular_summary} ) {
		if ( $result =~ $RE{rna}{volume}{-keep} ) { # warn $1;
			$h{rna_volume} = &$trim($1);
		}
		if ( $result =~ $RE{rna}{concentration}{-keep} ) { # warn $1;
			$h{rna_concentration} = &$trim($1);
		}
		if ( $result =~ $RE{rna}{purity}{-keep} ) { # warn $1;
			$h{rna_purity} = $1;
		}
		if ( $result =~ $RE{rna}{sections}{-keep} ) { # warn $1
			$h{rna_sections} = &$trim($1);
		}
	} # warn Dumper \%h;

    return \%h;
}

sub get_tma_results {
    my $self = shift;

    my %h = ();

	if ( my $result = $self->data->{immunohistochemistry_summary} ) {
		if ( $result =~ $RE{tma}{status}{-keep} ) { # warn $1;
			$h{tma_status} = &$trim($1);
		}
		if ( $result =~ $RE{tma}{position}{-keep} ) { # warn $1;
			my ($block, $core_positions) = $1 =~ /(\d{1,2})(\w\d\w\d)/; # eg 2A2A4
			$h{tma_position} = $core_positions;
			$h{tma_block} = $block; # block number
		}
		if ( $result =~ $RE{tma}{cores}{-keep} ) { # warn $1;
			$h{tma_cores} = &$trim($1);
		}
	} # warn Dumper \%h;

    return \%h;
}

sub get_igh_pcr {
    my $self = shift;

    my %h = ();

	if ( my $result = $self->data->{molecular_summary} ) {
		if ( $result =~ $RE{igh_aso}{assay}{-keep} ) { # warn $1;
			$h{igh_pcr_assay} = &$trim($1);
		}
		if ( $result =~ $RE{igh_aso}{result}{-keep}{-i} ) { # warn $1;
			$h{igh_pcr_result} = lc &$trim($1);
		}
		if ( $result =~ $RE{igh_aso}{bp_length}{-keep} ) { # warn $1;
			$h{igh_pcr_bp_length} = $1;
		}
		if ( $result =~ $RE{igh_aso}{comment}{-keep} ) { # warn $1;
			$h{igh_pcr_comment} = &$trim($1);
		}
	} # warn Dumper \%h;

    return \%h;
}

sub get_fish_break_apart_result {
    my $self = shift;
    my $col  = shift;

    my $val = $self->data->{$col} || return 0;

    my $result = $val =~ /rearranged/
		? 'Positive'
		: $val eq 'failed'
			? 'Not Evaluable' : 'Negative';
    return $result;
}

sub get_fish_fusion_assay_result {
    my $self = shift;
    my $col  = shift;

    my $val = $self->data->{$col} || return 0;

    my $result = $val =~ /translocation/
		? 'Positive'
		: $val eq 'failed'
			? 'Not Evaluable' : 'Negative';
    return $result;
}

sub get_biopsy_type { # FINE NEEDLE ASPIRATION / CORE BIOPSY / SURGICAL EXCISION / OTHER
    my $self = shift;

    if ( $self->data->{comment} =~ $RE{biopsy}{type}{-keep} ) {
		return $1;
	}
    return 0;
}

sub get_lymphoma_grade {
    my $self = shift;

    my $comment = $self->data->{comment};
    my $icdo3   = $self->data->{icdo3} || return 0;

   if ( $icdo3 =~ /^9698/ ) { # Follicular lymphoma; large cell - automatically 3B
        return '3b';
    }
    # extract grade - only if FL:
    elsif ( $icdo3 =~ /^9690/ && $comment =~ $RE{lymphoma}{grade}{-keep} ) {
        return $1;
    }
    return 0;
}

sub get_trial_elegibility { # [YES/NO/PENDING]
    my $self = shift;

    if ( $self->data->{comment} =~ $RE{trial}{eligible}{-keep} ) {
		return $1;
	}
	else { # diagnosis FL - common, SMZL or EMZL:
		no warnings 'uninitialized';
		return $self->get_icdo3 =~ /^96(89|90|99)/ ? 'YES' : 'NO';
	}
}

sub get_diagnosis {
    my $self = shift;
    return $self->data->{diagnosis}; # required to be authorised so will exist
}

sub get_icdo3 {
    my $self = shift;
    return $self->data->{icdo3} || 0;
}

sub get_lymphoma_involvement {
    my $self = shift;

    if ( $self->data->{comment} =~ $RE{lymphoma}{involvement}{-keep} ) {
		return $1; # numerical
	}
    return undef; # don't return 0 - valid result !!
}

sub get_test_results {
    my ($self, $markers) = @_; # list of IHC markers

    my %h = ();
	for my $t(@$markers) {
		my $result = $self->data->{$t};
        $h{$t} = $result if defined $result; # can be zero
    }; # warn Dumper \%h;
    return \%h;
}

sub is_discrepant_diagnosis {
    my $self = shift;

    if ( $self->data->{comment} =~ $RE{discrepant}{diagnosis}{-keep} ) {
		return $1;
	}
    return 0;
}

sub is_discrepant_localisation {
    my $self = shift;

    if ( $self->data->{comment} =~ $RE{discrepant}{localisation}{-keep} ) {
		return $1;
	}
    return 0;
}

1;