package LIMS::Local::GenomicsValidation; use Moo; use Local::Utils; use Clone qw(clone); use Data::Printer alias => 'p'; use XML::SAX::ParserFactory; use XML::Validator::Schema; has xsd_src => ( is => 'ro', required => 1 ); has dbix => ( is => 'ro', required => 1 ); has cfg => ( is => 'ro', required => 1 ); has rare_disease_base => ( is => 'lazy' ); has family_id_prefix => ( is => 'lazy' ); has cancer_increment => ( is => 'lazy' ); has lab_tests_map => ( is => 'lazy' ); sub _build_cancer_increment { shift->cfg->{genomics}->{uat}->{cancer_incr} } sub _build_rare_disease_base { shift->cfg->{genomics}->{uat}->{rare_disease} } sub _build_family_id_prefix { my $self = shift; # family_id_prefix = 1st 3 digits of rare_disease participant id base: my ($family_id_prefix) = $self->rare_disease_base =~ /^(\d{3})/; # p $family_id_prefix; return $family_id_prefix; } sub _build_lab_tests_map { # warn '=' x 30; my $self = shift; my $sql = q!SELECT lt.test_name, lt.field_label, ls.section_name FROM lab_tests lt JOIN lab_sections ls on lt.lab_section_id = ls.id!; $self->dbix->query($sql)->hash_map('test_name'); } no autovivification; sub validate_params { my ($self, $data) = @_; # p $data; # hashref my %errors; my $c = clone $data; # to prevent auto-vivification # family ID (is RD-specific) is 9 digits & begins with 1st 3 digits of # rare_disease participant id base (122xxxxxx): if ( my $family_id = $c->{Approach}->{family_id} ) { # warn $family_id; =begin # family_id should be participant_id + max 9 individuals, but doesn't # work in practice as family_id just has to match a participant_id which # could be any number of requests different my $participant_id = $c->{Demographics}->{participant_id}; unless ( $participant_id - $family_id ~~ [0..9] ) { # p [ $participant_id, $family_id ]; $h{family_id} = $family_id; } =cut # check family_id belongs to an existing participant_id (unit_number): $self->dbix->query('select 1 from patient_case where unit_number = ?', $family_id)->into(my $pid_match_ok); # family_id_prefix is 1st 3 digits of rare_disease participant id base: my $family_id_prefix = $self->family_id_prefix; # p $pid_match_ok; p $family_id; p $family_id_prefix; unless ( $pid_match_ok && $family_id =~ /^$family_id_prefix/ ) { $errors{family_id} = $family_id; } } # participant ID is 9 digits and matches allocated RD or Cancer block: if ( my $participant_id = $c->{Demographics}->{participant_id} ) { # p $participant_id; my $request_id = $c->{Demographics}->{request_id}; my $expected = $self->rare_disease_base + $request_id; if ( my $arm = $c->{Demographics}->{arm} ) { $expected += $self->cancer_increment if lc $arm eq 'cancer'; } # p $expected; else { # not screened: $expected = 0; # ensures failure even if length = 9 } my $match_ok = _matches($participant_id, $expected); unless ( length $participant_id == 9 and $match_ok ) { $errors{participant_id} = $participant_id; # need to add participant_id (ie unit number) manually to # $self->lab_test_map for error decode for notification: my $map = $self->lab_tests_map; $map->{participant_id} ||= { # unless already added section_name => 'Patient demographics', # not strictly a lab-section field_label => 'Unit number', }; # p $map; } } # nhs number: unless ( $c->{Demographics}->{nhs_number} ) { $errors{nhs_number} = undef; } =begin # validated in validate_xml_against_xsd() using XML libs now # DNA/volume_stored is xs:small (integer): if ( my $val = $data->{DNA}->{volume_stored} ) { unless ($val =~ /^\d+$/) { # warn 'here'; $data->{DNA}->{volume_stored} = int($val); } } # DNA/edta1_fluidx_vol is xs:small (integer): if ( my $val = $data->{DNA}->{edta1_fluidx_vol} ) { unless ($val =~ /^\d+$/) { # warn 'here'; $data->{DNA}->{edta1_fluidx_vol} = int($val); } } =cut { # sample ID's (9-digits, decimal, 1/2-digits: # Specimens - blood section: my %data = map { $_ => $c->{SpecimensBlood}->{$_} } qw( paxgene_rna edta1 edta2 sst pst ); # add tumour specimen ID: $data{sample_id} = $c->{SpecimensTumour}->{sample_id}; # p \%data; while ( my ($test, $val) = each %data ) { # warn $test; next unless $val && $val !~ /^\d{9}\.\d{1,2}$/; $errors{$test} = $val; # warn $val; } } # p \%errors; my $map = $self->lab_tests_map; # p $map; my @errs = map { # same format as genomics_xml.pl notify_admin msg: ( $errors{$_} ? ( sprintf qq!Illegal value '%s' !, $errors{$_} ) : 'Illegal NULL value ' ) # . "in element <$_>, does not match required definition"; # changed to: . sprintf q!for '%s' in '%s' section, does not match required definition.!, $map->{$_}{field_label}, $map->{$_}{section_name} } keys %errors; return @errs ? \@errs : 0; # don't return empty arrayref (evals 'true' for caller) } #------------------------------------------------------------------------------- sub validate_xml_against_xsd { my ($self, $xml) = @_; # warn $xml; my $xsd_src = $self->xsd_src; # switch debug on to show data structure: my $validator = XML::Validator::Schema->new(file => $xsd_src, debug => 0); # p $validator; my $parser = XML::SAX::ParserFactory->parser(Handler => $validator); eval { $parser->parse_string($xml); }; return $@; } #------------------------------------------------------------------------------- sub reformat_error { my ($self, $error) = @_; my ($lab_test) = $error =~ m!element <(.*)>!; # p $lab_test; my $lab_tests_map = $self->lab_tests_map; # p $lab_tests_map; if ( my $ref = $lab_tests_map->{$lab_test} ) { # get field label & section my $section = $ref->{section_name}; my $label = $ref->{field_label}; $error =~ s/in element <$lab_test>/for '$label' in '$section' section/; # p $error; } return $error; } sub _matches { Local::Utils::matches(@_) } 1;