#!/usr/bin/env perl =begin -------------------------------------------------------------------------------- generates NCRS XML data file for all authorised requests with diagnosis either ICDO3 '/3', or 'see comments' with a non-null comment section, where authorisation date or diagnosis revision date during previous 1 month TODO: referrer name, location name TODO: reporters for all 3 centres test mode skips file transfer & archive, dumps data to file (/tmp dir) SCP file transfer (broken, replaced by email July 2016) usage: CENTRE= $0 [-m - optional (defaults to 1)][-t - testing] # scp /tmp/ hmds@163.160.247.17: # broken ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !! for new server: need to manually ssh into server once to add key to known_hosts ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ online reference: Using ICD-O-3 online: http://codes.iarc.fr/usingicdo.php ICDO3 topographical codes: http://codes.iarc.fr/topography ICDO3 morphological codes: http://codes.iarc.fr/codegroup/2 ICD-O-3 to ICD-10 conversion for hemato-oncological diseases: All leukemias have a site-specific code of bone marrow (C42.1) except myeloid sarcoma Multiple myeloma – code site to C42.1 RULE D. Topography codes for lymphomas: If a lymphoma involves multiple lymph node regions, code to C77.8 (lymph nodes of multiple regions). Code extranodal lymphomas to the site of origin, which may not be the site of the biopsy. If no site is indicated for a lymphoma, code to C77.9 (lymph node, NOS). C80.9 if suspected to be extranodal but site is not stated. -------------------------------------------------------------------------------- * HaematologyContent/LaboratoryResults for results summaries - not part of v8 * filename: COSD_____.xml = PATH ? for HMDS, UCLH & NBT? - can't have colons * SNOMED coding of TopographySNOMEDPathology, PrimaryDiagnosisICDPath, SpecimenNature, etc * "pathology providers must submit all data relating to patients for whom they have either reported on and authorised the original pathology report or commented on (second opinion) as a specialist centre (creating a supplementary report)" include all reports, not just Y&H? * "Monthly data submissions are required from each provider within 25 working days of the relevant month end" move data upload from 28th? * xmlns for xml & xsd files - https://www.datadictionary.nhs.uk/messages/COSD-v8-0 doesn't exist =cut use Getopt::Std; getopts('m:t'); # months, testing our($opt_m,$opt_t); # warn $opt_m; exit; use charnames ':full'; # for perl < 5.16 - to use unicode names (eg LINE FEED) use lib '/home/raj/perl5/lib/perl5'; use Data::GUID qw(guid_string); use XML::Simple qw(:strict); # need to specify ForceArray & KeyAttr if using :strict here use SQL::Abstract::More; use Data::Printer; use Config::Auto; use Modern::Perl; use DateTime; # last_day_of_month() use IO::All; use FindBin qw($Bin); # warn $Bin; use lib $Bin . '/../../../lib'; use LIMS::Local::ScriptHelpers; use lib '/home/raj/perl-lib'; use Local::DB; # switch off date auto-inflation: $Local::DBIx::Simple::Result::NO_AUTO_DATE_INFLATION = 1; my $centre = $ENV{CENTRE} || die 'no centre param supplied'; #=============================================================================== my $JUST_TESTING = $opt_t || 0; # skips file transfer & file archive my $duration = $opt_m || 1; # months ago my $new_line_marker = '[~~]'; # using CDATA now #=============================================================================== # supply 'SuppressEmpty' arg (1 or undef) to XMLOut: --------------------------- =begin # SuppressEmpty => 1:
# SuppressEmpty => undef:
=cut my $suppress_empty = 1; # options 1 or undef to suppress warning, 0 gives warning #------------------------------------------------------------------------------- my $cfg_file = "$Bin/../lib/settings.cfg"; my $settings = Config::Auto::parse($cfg_file); # p $settings; my $ncrs_cfg = $settings->{ncrs_data}->{$centre} || die "can't find settings for $centre in $cfg_file"; # p $ncrs_cfg; # organisation code where service (HMDS, NBT, UCLH, etc) located: my $service_org_code = $ncrs_cfg->{org_code} || die 'service org code not configured'; my $hmds_org_code = 'RR8F4'; # apparently # get tools from LIMS::Local::ScriptHelpers: my $tools = LIMS::Local::ScriptHelpers->new(); my $config = $tools->config(); my $dbname = $centre eq 'leeds' ? 'hilis4' : $centre; my $dbix = Local::DB->dbix({ dbname => $dbname }); # warn $dbix->dbh->{Name}; # dates ======================================================================== my $timestamp = $tools->time_now->datetime; # get date last month - handles BST: my $ref_date = $tools->date_subtract(months => $duration); # format for ReportingPeriodStartDate & ReportingPeriodEndDate my $start_date = $ref_date->strftime('%Y-%m-01'); my $end_date = DateTime->last_day_of_month( year => $ref_date->year, month => $ref_date->month, )->ymd; # p $start_date; p $end_date; # ============================================================================== my @lab_sections = $dbix->select('lab_sections','section_name')->column; # remove non-word chars to match result_summary data from get_data_map(): $_ = to_camel_case($_) for @lab_sections; # p @lab_sections; exit; # The submission file must be named using the following convention: # COSD____ # _.xml my $data_filename = sprintf 'COSD_PATH_%s_%s_%s_%s.xml', $service_org_code, $start_date, $end_date, $timestamp; # p $data_filename; # $data_filename = 'hmds_test_cosd.xml'; my @skip_screens = ( # not very maintainable as new ones added!! 'Inappropriate/unsuitable sample', 'Myeloma trial follow-up', 'Myeloma XI follow-up', 'Follow-up CML (PB)', 'Follow-up CML (BM)', 'CLL trial follow-up', 'Chimerism (CHIA/CHIB)', 'Chimerism (CHIM)', 'ACE-WM follow-up', 'HIV monitoring', 'NCG PNH (PB)', 'NCG PNH (BM)', 'Outreach', ); use constant TMP_DIR => '/tmp'; # where to create temp data file my %all_guids; # GUID counter to ensure uniqueness my @data = (); { # go: # get requests 1-to-1 data: my @requests = do { my ($sql, @bind) = _ncrs_data(); $dbix->query($sql, @bind)->hashes; }; # p @requests; exit; my @request_ids = map $_->{request_id}, @requests; # p @request_ids; # get data maps of vertical tables - much faster than tying into main query: my $data_map = get_data_map(\@request_ids); # p $data_map; for my $r (@requests) { # p $r; next; my $request_id = $r->{request_id}; # merge vertical table data with $r: my $vars = combine_data($r, $data_map->{$request_id}); # p $r; push @data, $vars; } # p @data; } # enable hash counter in new_guid() for debugging: say "$_ is not unique" for grep { $all_guids{$_} > 1 } keys %all_guids; { # create output file & push to remote server: my $file_path = join '/', TMP_DIR, $data_filename; my $content = to_xml(\@data); # p $content; $content > io($file_path); # transfer file: unless ($JUST_TESTING) { my %args = ( local_filename => $file_path ); transfer_file(\%args); } } #------------------------------------------------------------------------------- sub to_xml { my $data = shift; # arrayref of request datasets my $count = @$data; # p $count; # options for XMLout (needs array or hash): my %xs_opts = xs_options(); # p %xs_opts; my $xs = XML::Simple->new(%xs_opts); my $ref = { OrganisationIdentifierCodeOfSubmittingOrganisation => { # always Leeds/HMDS: extension => $hmds_org_code, }, Id => { root => new_guid() }, # returns new Data::GUID as_string RecordCount => { value => $count }, ReportingPeriodStartDate => $start_date, ReportingPeriodEndDate => $end_date, FileCreationDateTime => $timestamp, }; # p $ref; push @{ $ref->{COSDRecord} }, format_cosd_unit($_) for @$data; # p $ref; my $xml_out = $xs->XMLout($ref); # p $xml_out; # add namespace data - not supported by XML::Simple: chomp( my $namespace = namespace_data() ); # remove trailing new-line $xml_out =~ s/(COSD:COSD)/$1\n$namespace/; # don't use 'g', only want start-tag return $xml_out; } #------------------------------------------------------------------------------- # formats repeating COSDRecord blocks: sub format_cosd_unit { my $v = shift; my %COSDRecord = ( Id => { root => new_guid(), # returns new Data::GUID as_string }, ); my %HAEM; { # COSDRecord/Haematology/HaematologyCore: my $labno = $ncrs_cfg->{labno_prefix} . $v->{request_number} . '/' . ( $v->{year} - 2000 ); my %h = ( HaematologicalCoreLinkagePatientId => { NHSNumber => { extension => $v->{nhs_number}, }, NHSNumberStatusIndicator => { code => '02', # Number present but not traced }, LocalPatientIdExtended => $v->{unit_number}, Birthdate => $v->{dob}, OrganisationIdentifierCodeOfProvider => { extension => $v->{organisation_code}, }, }, HaematologicalCoreDemographics => { PersonFamilyName => { family => $v->{last_name}, }, PersonGivenName => { given => given_name($v), }, Address => { UnstructuredAddress => { streetAddressLine => $v->{address}, }, }, Postcode => { postalCode => $v->{post_code}, }, Gender => { code => gender_code($v->{gender}), }, }, HaematologicalCorePathology => { OrganisationSiteIdentifierOfPathologyTestRequest => { extension => $v->{organisation_code} }, OrganisationIdentifierOfReportingPathologist => { extension => $service_org_code }, PathologistConsultantCode => { extension => $v->{reporter_code} }, PathTestReqCareProfCode => { extension => $v->{referrer_code} }, SampleCollectionDate => { extension => $v->{sample_date} }, MorphologySNOMEDPathology => { # ICDO3 code => icdo3_to_snomed($v->{icdo3}) }, ServiceReportStatus => { code => report_status($v->{diagnosis}) }, InvestigationResultDate => $v->{authorisation_date}, PathologyReportText => free_text_report($v), SampleReceiptDate => $v->{request_date}, ServiceReportId => $labno, # morphology code if needed is 3 or 1 (from ICDO3 /3 or /1 suffix) # useless for haematology - refers to solid tumours: # 1 = primary, 4 = region LN, 5 = metastatic, 9 = not known # SpecimenNature => { code => 9 }, # One of TOPOGRAPHY (SNOMED), TOPOGRAPHY (SNOMED CT) or PRIMARY # DIAGNOSIS (ICD PATHOLOGICAL) is required for the schema. It is # expected that most submissions will include TOPOGRAPHY (SNOMED). # PRIMARY DIAGNOSIS (ICD PATHOLOGICAL) is the PRIMARY DIAGNOSIS # based on the evidence from a pathological examination. Format # CXX.X or DXX.X # PrimaryDiagnosisICDPath => sample_to_snomed($v), # topography code (primary site of origin): TopographySNOMEDPathology => { code => topography_code($v) }, }, ); $HAEM{HaematologicalCore} = \%h; } #TODO: this name will have changed - not part of v8 schema { # COSDRecord/Haematology/HeamatologyContent/LaboratoryResults: my %h = map +( $_ => $v->{$_} ), @lab_sections; $HAEM{HaematologicalContent}{LaboratoryResults} = \%h; } $COSDRecord{Haematological} = \%HAEM; return \%COSDRecord; } #------------------------------------------------------------------------------- sub report_status { # 1 = Final (Complete); 2 = Preliminary (Interim) my $diagnosis = shift; # p $diagnosis; my @interim_terms = ( 'awaiting final (diagnosis|review)', 'interim result', # NBT ); return ( grep { lc $diagnosis =~ /^$_/ } @interim_terms ) ? 2 : 1; } #------------------------------------------------------------------------------- # free-text specimen/biopsy_site/morphology/comment, etc: sub free_text_report { my $vars = shift; # p $vars; my @rows; push @rows, ( 'SPECIMEN(S): ' . $vars->{specimen_decode} ); if ( my $biopsy_site = $vars->{biopsy_site} ) { push @rows, ( 'ANATOMICAL SITE(S): ' . $biopsy_site ); } push @rows, ( 'SPECIMEN QUALITY: ' . $vars->{specimen_quality} ); if ( my $gross_desc = $vars->{gross_description} ) { push @rows, ( 'GROSS DESCRIPTION: ' . $gross_desc ); } if ( my $details = $vars->{clinical_details} ) { push @rows, ( 'CLINICAL DETAILS: ' . $details ); } if ( my $morphology = $vars->{morphology} ) { push @rows, ( 'MORPHOLOGY: ' . $morphology ); } if ( my $comment = $vars->{comment} ) { push @rows, ( 'COMMENT: ' . $comment ); } push @rows, ( 'DIAGNOSIS: ' . $vars->{diagnosis} ); push @rows, ( 'REPORTED BY: ' . $vars->{reporter_name} . ' on ' . $vars->{report_datetime} ); my $str = join "\n", @rows; # enclose text in CDATA tags: return as_cdata($str); } #------------------------------------------------------------------------------- # merge vertical table data with $vars sub combine_data { my ($vars, $supplimentary_data) = @_; # p $supplimentary_data; { # add data-map fields: # result summaries (enclose text in CDATA tags): for (@lab_sections) { my $result = $supplimentary_data->{result_summary}->{$_} || next; # can't be '0' $vars->{$_} = as_cdata($result); } # reporter: $vars->{$_} = $supplimentary_data->{reporter_data}->{$_}, for qw(reporter_name reporter_code report_datetime); # specimen code(s) & decode(s): $vars->{specimen_code} = $supplimentary_data->{specimen}->{specimen_code}; $vars->{specimen_decode} = $supplimentary_data->{specimen}->{description}; } # p $vars; $vars->{gender} ||= 'U'; # p $vars; return $vars; } #------------------------------------------------------------------------------- sub topography_code { my $vars = shift; # C80.9 / Unknown primary site: return 'C80.9' unless $vars->{icdo3}; my ($icdo3) = $vars->{icdo3} =~ /^(\d{4})/; # capture 1st 4 digits; # plasmacytomas? CLL? EMZL? - check the MZL & MYD88-mutated entries!! my %topo_code = ( 8720 => 'C44._', # metastatic melanoma 9689 => 'C42.2', # splenic MZL 9699 => 'C80.9', # extranodal MZL (Rule D) 9700 => 'C44._', # MF 9709 => 'C44._', # cuteneous TCL 9718 => 'C44._', # primary cuteneous CD30+ LPD # 9731 => 'C40._', # plasmacytoma (only of bone; C40 is bones, joints, etc) 9732 => 'C42.1', # myeloma 9733 => 'C42.1', # plasma-cell leukaemia ); return $topo_code{$icdo3} if $topo_code{$icdo3}; # primary non-haematological tumour/metastatic carcinoma: return 'C80.9' if in_num($icdo3, 8000, 8010); # rhabdomyosarcoma/pnet/neuroblastoma: return 'C80.9' if in_num($icdo3, 8900, 9260, 9500); # mastocytosis, histiocytosis, langerhans: return 'C80.9' if between($icdo3, 9741 => 9755); # lymphomatoid granulomatosis, amyloidosis: return 'C80.9' if between($icdo3, 9766 => 9769); # Rule E: all leukaemias (9801/3 .. 9989/3): return 'C42.1' if between($icdo3, 9801 => 9990); # Rule D: default for lymphomas (9591/3 .. 9739/3) return 'C77._' if between($icdo3, 9591 => 9739); # escaped all above returns so output for debugging: p $vars->{diagnosis}; } #------------------------------------------------------------------------------- sub between { # adapated from Acme::Tools my ($test, $lower, $upper) = @_; return $lower < $upper ? $test >= $lower && $test <= $upper : $test >= $upper && $test <= $lower; } #------------------------------------------------------------------------------- sub in_num { # lifted from Acme::Tools my $val = shift || return 0; # shift 1st val, remaining in @_ for (@_) { return 1 if $_ == $val } return 0; } #------------------------------------------------------------------------------- sub icdo3_to_snomed { # eg 9960/3 -> M99603 local $_ = shift || return undef; # p $icdo3; s{/}{}; # remove slash return 'M' . $_; } #------------------------------------------------------------------------------- sub gender_code { my $gender = shift; return 1 if lc $gender eq 'm'; return 2 if lc $gender eq 'f'; return 9; # x = not known, 9 = not specified } #------------------------------------------------------------------------------- # first + optional middle names sub given_name { my $vars = shift; return join ' ', grep $_, @{$vars}{ qw/first_name middle_name/ }; } #------------------------------------------------------------------------------- sub xs_options { my %opts = ( SuppressEmpty => $suppress_empty, RootName => 'COSD:COSD', NoEscape => 1, # to preserve tags XMLDecl => q!!, KeyAttr => [], NoAttr => 1, # gives inline (scalar) AND nested (arrayref) attributes ); return %opts; } #------------------------------------------------------------------------------- # scp function broken, replaced by email 07/2016 sub transfer_file { # only called if not $JUST_TESTING my $args = shift; my $cfg = $settings->{nycris_server}; my %params = ( local_filename => $args->{local_filename}, server_addr => $cfg->{remote_address}, username => $cfg->{username}, password => $cfg->{password}, ); # p %params; # scp file (returns str on failure, undef on success): # my $rtn = $tools->scp_file(\%params); # broken my $rtn = email_file(); # 05/07/2016 my $script = $tools->script_filename; if ($rtn) { $tools->mail_admin({ script => $0, msg => $rtn }); warn "$script - $rtn\n"; # dump to logs but don't die!! } else { archive_and_delete_file($args->{local_filename}); my $month = $ref_date->month_name; # for cron log: print "$script reports data for $month succesfully uploaded\n"; } } #------------------------------------------------------------------------------- sub email_file { # email a password-protected file: ( my $zip_filename = $data_filename ) =~ s/txt$/zip/; # warn $zip_filename; ( my $subject = $data_filename ) =~ s/\.txt$//; # warn $subject; my @cmd = ('/usr/bin/zip'); push @cmd, '-q'; # quiet push @cmd, '-j'; # junk dir name push @cmd, '--password'; push @cmd, ucfirst $subject; # using subject title as passwd # -------------------------------------------------------------------------- push @cmd, '-'; # only needed to allow piping of content if using capture() # -------------------------------------------------------------------------- push @cmd, TMP_DIR . '/' . $zip_filename; push @cmd, TMP_DIR . '/' . $data_filename; # p @cmd; =begin # method to save zip file to disk & then use io() for $content: # system(@cmd); # my $content = io->file(TMP_DIR . '/' . $zip_filename)->all; =cut # use IPC::System::Simple to cature zip output: my $content = capture(@cmd); my %mail = ( config => $config, subject => $subject, filename => $zip_filename, attachment => $content, ); # p %mail; # p @recipients; my $ok = $tools->send_mail(\%mail, [ 'nycris.secure' ]); # returns 0 if msg fails # for compatibility with scp_file(): return 'message(s) failed to send' if not $ok; return 0; # don't return true unless msg fails } #------------------------------------------------------------------------------- # archive data file (only called if not $JUST_TESTING): sub archive_and_delete_file { my $src_file = shift; # p $src_file; my $path_to_archive = $settings->{nycris_server}->{path_to_archive}; # make sure it exists otherwise get error trying to tar non-existant file if (-e $src_file ) { # warn 'it exists'; my $tar_file = sprintf '%s/%s.tar', $path_to_archive, $data_filename; # p $tar_file; chdir TMP_DIR; # so we can use relative path for source directory system( sprintf 'tar -cf %s %s', $tar_file, $data_filename ); # using relative $data_file.* not full path system( sprintf "gzip $tar_file" ); # compress tar file # delete source file: io($src_file)->unlink; } } #------------------------------------------------------------------------------- sub get_data_map { my $request_ids = shift; # p $request_ids; my $map = {}; { # request_specimens: my $result = do { my ($sql, @bind) = _request_specimens($request_ids); $dbix->query($sql, @bind); }; while ( my $vars = $result->hash ) { # p $vars; my $request_id = $vars->{request_id}; my %data = ( specimen_code => $vars->{code}, description => $vars->{description}, ); # p %data; $map->{$request_id}->{specimen} = \%data; } } { # reporter data: my $result = do { my ($sql, @bind) = _reporters($request_ids); $dbix->query($sql, @bind); }; while ( my $vars = $result->hash ) { # p $vars; my $request_id = $vars->{request_id}; my $reporter = join ' ', ucfirst $vars->{first_name}, ucfirst $vars->{last_name}; my $reporter_code = $vars->{registration_number} || 'H9999998'; # OTHER HEALTH CARE PROFESSIONAL; my %data = ( reporter_name => $reporter, reporter_code => $reporter_code, report_datetime => $vars->{report_datetime}, ); $map->{$request_id}->{reporter_data} = \%data; } } { # result summaries: my $result = do { my ($sql, @bind) = _result_summaries($request_ids); $dbix->query($sql, @bind); }; while ( my $vars = $result->hash ) { # p $vars; my $request_id = $vars->{request_id}; my $section = to_camel_case($vars->{section_name}); my $result = $vars->{results_summary}; $map->{$request_id}->{result_summary}->{$section} = $result; } # p $map->{result_summary}; } # p $map; return $map; } #------------------------------------------------------------------------------- sub tidy { # not in use, replaced by as_cdata() my $str = shift; # p $str; # trim: $str =~ s/\A\s+//; # leading $str =~ s/\s+\Z//; # trailing #$str =~ s/\r?\n/$new_line_marker/g; # captures both \r\n & \n $str =~ s/\N{CARRIAGE RETURN}?\N{LINE FEED}/$new_line_marker/g; } #------------------------------------------------------------------------------- # need to use NoEscape => 1 in opts to preserve CDATA tags: sub as_cdata { "" } #------------------------------------------------------------------------------- sub to_camel_case { my $ref = shift; # p $ref; $ref =~ s/_/ /g; # convert underscores to spaces for camelCasing $ref = join '', map { ucfirst $_ } split '\W', $ref; # p $ref; return $ref; } #------------------------------------------------------------------------------- sub namespace_data { # TODO: confirm uri's return <{report_status}; my @cols = ( qw/ DISTINCT(r.id)|request_id DATE(r.created_at)|request_date r.request_number r.year p.last_name p.first_name p.middle_name p.nhs_number pc.unit_number p.dob p.gender pd.address pd.post_code ref.national_code|referrer_code rs.organisation_code rr.biopsy_site rr.gross_description rr.specimen_quality DATE(rr.specimen_date)|sample_date rr.clinical_details rr.morphology rr.comment d.name|diagnosis d.icdo3 DATE(rh.time)|authorisation_date / ); my @rels = ( 'requests|r' => q{r.patient_case_id=pc.id} , 'patient_case|pc' => q{pc.patient_id=p.id} , 'patients|p' => q{r.referrer_department_id=rd.id} , 'referrer_department|rd' => q{rd.referrer_id=ref.id} , 'referrers|ref' => q{pc.referral_source_id=rs.id} , 'referral_sources|rs' => q{rh.request_id=r.id} , 'request_history|rh' => q{rr.request_id=r.id} , 'request_report_view|rr' => q{rr.diagnosis_id=d.id} , 'diagnoses|d' => q{ris.request_id=r.id} , 'request_initial_screen|ris' => q{ris.screen_id=s.id} , 'screens|s' => q{=>rdh.request_id=r.id} , 'request_diagnosis_history|rdh' => q{=>pd.patient_id=p.id} , 'patient_demographics|pd' ); # local_network_locations: push @rels, ( 'lnl.parent_id=rs.parent_organisation_id' => 'local_network_locations|lnl' ) if $centre eq 'leeds'; my %where = ( -and => [ { # is reported/authorised & not excluded screens: 'rh.action' => $report_status, 's.description' => { -not_in => \@skip_screens }, }, -or => [ # reported/authorised or diagnosis history dates: { 'MONTH(rh.time)' => $ref_date->month, 'YEAR(rh.time)' => $ref_date->year, }, { 'MONTH(rdh.time)' => $ref_date->month, 'YEAR(rdh.time)' => $ref_date->year, }, ], -or => [ # diagnosis is not MGUS or is 'see coments' 'd.icdo3' => { '!=' => '9765/1' }, { 'd.name' => 'see comments', 'rr.comment' => { '!=' => undef } }, ], ], ); my @args = ( -columns => \@cols, -from => [ -join => @rels ], -where => \%where, -order_by => 'r.id', ); # p @args; my ($sql, @bind) = SQL::Abstract::More->new->select(@args); # p $sql; p \@bind; # $dbix->dump_query($sql, @bind); exit; return ($sql, @bind); } =begin # alternative to _ncrs_data(), but can't use for NBT as they don't authorise sub _query { my @dates = ($start_date, $end_date); my @cols = qw( r.id|request_id arv.request_number arv.year arv.reg_date|request_date p.last_name p.first_name p.middle_name p.nhs_number pc.unit_number p.dob p.gender arv.organisation_code pd.address pd.post_code ref.national_code|referrer_code rr.clinical_details rr.biopsy_site rr.gross_description rr.specimen_quality DATE(rr.specimen_date)|sample_date rr.morphology rr.comment arv.diagnosis arv.icdo3 arv.auth_date|authorisation_date ); my @rels = ( 'requests|r' => 'r.id=arv.id' , 'authorised_reports_view|arv' => 'r.patient_case_id=pc.id' , # ensures it's authorised 'patient_case|pc' => 'pc.patient_id=p.id' , 'patients|p' => 'pc.referral_source_id=rs.id' , 'referral_sources|rs' => 'rs.parent_organisation_id=po.id' , 'parent_organisations|po' => 'lnl.parent_id=po.id' , 'local_network_locations|lnl' => 'r.referrer_department_id=rd.id' , 'referrer_department|rd' => 'rd.referrer_id=ref.id' , 'referrers|ref' => 'ris.request_id=r.id' , 'request_initial_screen|ris' => 'ris.screen_id=s2.id' , 'screens|s2' => 'rs2.request_id=r.id' , 'request_specimen|rs2' => 'rs2.specimen_id=s1.id' , 'specimens|s1' => 'rr.request_id=r.id' , 'request_report_view|rr' => '=>pd.patient_id=pc.patient_id' , 'patient_demographics|pd' => '=>rdh.request_id=r.id' , 'request_diagnosis_history|rdh' ); my %where = ( -and => [ 's2.description' => { -not_in => \@skip_screens }, -or => { 'DATE(rdh.time)' => { -between => \@dates }, 'arv.auth_date' => { -between => \@dates }, }, -or => [ 'arv.icdo3' => { '!=' => '9765/1' }, # not MGUS { 'arv.diagnosis' => 'see comments', 'rr.comment' => { -is_not => undef } }, ], ], ); my @args = ( -columns => \@cols, -from => [ -join => @rels ], -where => \%where, -group_by => 'r.id', -order_by => 'r.id', ); my ($sql, @bind) = SQL::Abstract::More->new->select(@args); # p $sql; # p \@bind; $dbix->dump_query($sql, @bind); exit; return ($sql, @bind); } =cut sub _request_specimens { my $request_ids = shift; my @cols = ( 'rs.request_id', "GROUP_CONCAT(s.description separator '; ')|description", 'GROUP_CONCAT(s.sample_code)|code', ); my @rels = ( 'request_specimen|rs', 'rs.specimen_id=s.id', 'specimens|s' ); my %where = ( 'rs.request_id' => { -in => $request_ids } ); my @args = ( -columns => \@cols, -from => [ -join => @rels ], -where => \%where, -group_by => 'rs.request_id', ); # p @args; # need to supply own injection_guard to override build-in sql injection attack # prevention - detects ';' in group_concat; modified from SQL::Abstract new() my @args_to_new = ( injection_guard => qr/^ \s* go \s/mi ); my ($sql, @bind) = SQL::Abstract::More->new(@args_to_new)->select(@args); # p $sql; p \@bind; # $dbix->dump_query($sql, @bind); exit; return ($sql, @bind); } sub _reporters { my $request_ids = shift; my @cols = qw( rh.request_id rh.time|report_datetime u.username u.first_name u.last_name ur.registration_number ); my @rels = ( 'request_history|rh' => 'rh.user_id=u.id', 'users|u' => '=>ur.user_id=u.id', 'user_registration|ur' ); my %where = ( 'rh.request_id' => { -in => $request_ids }, 'rh.action' => 'reported', ); my @args = ( -columns => \@cols, -from => [ -join => @rels ], -where => \%where, ); # p @args; my ($sql, @bind) = SQL::Abstract::More->new->select(@args); # p $sql; p \@bind; # $dbix->dump_query($sql, @bind); exit; return ($sql, @bind); } sub _result_summaries { my $request_ids = shift; my @cols = qw( rs.request_id rs.results_summary ls.section_name ); my @rels = qw( request_result_summaries|rs rs.lab_section_id=ls.id lab_sections|ls ); my %where = ( 'rs.request_id' => { -in => $request_ids } ); my @args = ( -columns => \@cols, -from => [ -join => @rels ], -where => \%where, ); # p @args; my ($sql, @bind) = SQL::Abstract::More->new->select(@args); # p $sql; p \@bind; # $dbix->dump_query($sql, @bind); exit; return ($sql, @bind); } #------------------------------------------------------------------------------- =begin # not mapping samples to snomed # decode for biopsy_site info: my $anatomical_site_map = $dbix->select('anatomical_sites', [qw(site_name snomed)])->map; # p $anatomical_site_map; sub sample_to_snomed { my $vars = shift; my @snomed; # get info from biopsy_site if available, otherwise specimen code(s): if ( my $biopsy_site = $vars->{biopsy_site} ) { # optional my @sites = split '; ', $biopsy_site; # maybe multiple push @snomed, $anatomical_site_map->{$_} for @sites; } else { my @specimens = split ',', $vars->{specimen_code}; push @snomed, $specimen_topography{$_} for @specimens; } # p @snomed; # legacy biopsy site that doesn't match anatomical_sites.site_name: return { code => 'C80.9' } unless @snomed; # site unknown return scalar @snomed == 1 ? { code => $snomed[0] } : [ map { code => $_ }, @snomed ]; } # for non-histology specimens (sample_code NOT RLIKE '[DGLRX]([BS]L|F|U)'): # NB these are ICDO3 topography codes for site of tumour origin my %specimen_topography = ( BMA => 'C42.1', BMAT => 'C42.1', CF => '', CHIA => 'C42.0', # should never issue new diagnosis on CHIA CHIB => 'C42.0', # should never issue new diagnosis on CHIB CHIM => 'C42.0', # should never issue new diagnosis on CHIM CMP => '', # should never issue new diagnosis on CMP EF => '', # HS => '', # require biopsy_site now # LA => 'C77.9', # require biopsy_site now PB => 'C42.0', SE => '', # never issue new diagnosis on SE TBL => 'C42.1', TBP => 'C42.1', TSL => 'C42.1', URI => '', # never issue new diagnosis on URI # XA => '', # require biopsy_site now RXPB => 'C42.0', # should never issue new diagnosis on RXPB TSM => '', # never issue new diagnosis on TSM ); =cut