From 0ee2ad8e172c18b711bcb65d3d52387b6a327a35 Mon Sep 17 00:00:00 2001 From: Rene Krenn Date: Wed, 29 Jul 2026 17:31:07 +0200 Subject: [PATCH 1/5] Add optional eCRF importer file converter modules. Support --task=convert with --converter to normalize input (e.g. Interfast3 lab CSV) into EcrfDataHorizontal intermediate files before import. Co-authored-by: Cursor --- .../BulkProcessor/Projects/ETL/EcrfImport.pm | 46 ++++- .../Converter/Interfast3LabData.pm | 195 ++++++++++++++++++ .../Projects/ETL/EcrfImporter/process.pl | 37 ++++ 3 files changed, 277 insertions(+), 1 deletion(-) create mode 100644 CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/Converter/Interfast3LabData.pm diff --git a/CTSMS/BulkProcessor/Projects/ETL/EcrfImport.pm b/CTSMS/BulkProcessor/Projects/ETL/EcrfImport.pm index 3439558..f265b6f 100644 --- a/CTSMS/BulkProcessor/Projects/ETL/EcrfImport.pm +++ b/CTSMS/BulkProcessor/Projects/ETL/EcrfImport.pm @@ -55,10 +55,12 @@ use CTSMS::BulkProcessor::Logging qw ( getlogger processing_info processing_debug + scriptinfo ); use CTSMS::BulkProcessor::LogError qw( rowprocessingerror rowprocessingwarn + scripterror ); use CTSMS::BulkProcessor::RestRequests::ctsms::trial::TrialService::Trial qw(); @@ -128,16 +130,20 @@ use CTSMS::BulkProcessor::Projects::ETL::Import qw( ); use CTSMS::BulkProcessor::Array qw(array_to_map contains); -use CTSMS::BulkProcessor::Utils qw( stringtobool trim chopstring ); +use CTSMS::BulkProcessor::Utils qw( stringtobool trim chopstring getscriptpath ); use CTSMS::BulkProcessor::ConnectorPool qw( get_ctsms_restapi_last_error ); +use File::Basename qw(); +use Cwd qw(); + require Exporter; our @ISA = qw(Exporter); our @EXPORT_OK = qw( import_ecrf_data_horizontal + convert_ecrf_data ); my @header_row :shared = (); @@ -149,6 +155,44 @@ my $value_count :shared = 0; my $comment_char = '#'; +sub convert_ecrf_data { + my ($file,$converter) = @_; + + my $convert_code = _load_converter($converter); + my $infile = get_input_filename($file,$ecrf_import_filename); + my $outfile = &$convert_code($infile); + if (length($outfile)) { + scriptinfo("converter '$converter' wrote intermediate file $outfile",getlogger(__PACKAGE__)); + } + return $outfile; +} + +sub _load_converter { + my ($spec) = @_; + scripterror('converter module required (e.g. --converter=Converter::Interfast3LabData)',getlogger(getscriptpath())) + unless length($spec); + + # Converters live next to process.pl: EcrfImporter/Converter/*.pm + my $importer_dir = Cwd::abs_path(File::Basename::dirname(__FILE__) . '/EcrfImporter'); + (my $rel_path = $spec) =~ s|::|/|g; + my $module_file = $importer_dir . '/' . $rel_path . '.pm'; + scripterror("converter module not found: $module_file",getlogger(getscriptpath())) + unless -f $module_file; + + unshift(@INC,$importer_dir) unless grep { $_ eq $importer_dir } @INC; + eval { + require $rel_path . '.pm'; + 1; + } or do { + scripterror("failed to load converter '$spec': " . ($@ // 'unknown error'),getlogger(getscriptpath())); + }; + + my $convert_code = $spec->can('convert') || $spec->can('process'); + scripterror("converter '$spec' must expose convert() or process()",getlogger(getscriptpath())) + unless $convert_code; + return $convert_code; +} + sub import_ecrf_data_horizontal { my ($file) = @_; diff --git a/CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/Converter/Interfast3LabData.pm b/CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/Converter/Interfast3LabData.pm new file mode 100644 index 0000000..2042c11 --- /dev/null +++ b/CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/Converter/Interfast3LabData.pm @@ -0,0 +1,195 @@ +package Converter::Interfast3LabData; +use strict; + +## no critic + +use File::Basename qw(basename); + +use CTSMS::BulkProcessor::FileProcessors::CSVFileSimple qw(); + +use CTSMS::BulkProcessor::Projects::ETL::EcrfSettings qw( + get_proband_columns + get_probandlistentry_columns +); +use CTSMS::BulkProcessor::Projects::ETL::EcrfConnectorPool qw( + get_csv_db + destroy_all_dbs +); +use CTSMS::BulkProcessor::Projects::ETL::Dao::EcrfDataHorizontal qw(); +use CTSMS::BulkProcessor::Projects::ETL::Job qw( + @job_file +); + +use CTSMS::BulkProcessor::SqlConnectors::CSVDB qw( + $mimetype + sanitize_column_name +); + +use CTSMS::BulkProcessor::Utils qw(trim); +use CTSMS::BulkProcessor::Logging qw( + getlogger + processing_info + scriptinfo +); +use CTSMS::BulkProcessor::LogError qw( + rowprocessingerror +); + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw( + convert + process +); + +# Interfast3 lab exports: metadata line, then header, then data. Separator is ';'. +# Qualifier columns KZ1/KZ2/VKZ repeat after each analyte — rename to _KZ1 etc. + +sub process { + return convert(@_); +} + +sub convert { + my ($file) = @_; + + rowprocessingerror(undef,'no input file specified',getlogger(__PACKAGE__)) unless length($file); + scriptinfo("Interfast3LabData: converting $file",getlogger(__PACKAGE__)); + + my $result = 1; + my $outfile; + my $header_found = 0; + + my $processor = CTSMS::BulkProcessor::FileProcessors::CSVFileSimple->new( + field_separator => ';', + numofthreads => 1, + blocksize => 100, + ); + + $result = $processor->process( + file => $file, + multithreading => 0, + static_context => { header_found_ref => \$header_found }, + process_code => sub { + my ($context,$rows,$row_offset) = @_; + my @out = (); + + foreach my $row (@$rows) { + next unless (scalar @$row); + next unless (scalar grep { length(trim($_ // '')) > 0; } @$row); + + unless ($context->{colnames}) { + next unless _is_header_row($row); + my @colnames = _normalize_colnames($row); + $context->{colnames} = \@colnames; + ${$context->{header_found_ref}} = 1; + $context->{prefix_count} = _prefix_column_count(); + $context->{db} = &get_csv_db(); + unless (CTSMS::BulkProcessor::Projects::ETL::Dao::EcrfDataHorizontal::create_table(1,\@colnames,{})) { + rowprocessingerror($context->{tid},'failed to create ecrf_data_horizontal intermediate table',getlogger(__PACKAGE__)); + return 0; + } + processing_info($context->{tid},'created intermediate table with ' . (scalar @colnames) . ' value column(s)',getlogger(__PACKAGE__)); + next; + } + + my $col_count = scalar @{$context->{colnames}}; + my @values = (); + for (my $i = 0; $i < $col_count; $i++) { + push(@values,trim($row->[$i] // '')); + } + my @out_row = ((undef) x $context->{prefix_count}, @values); + push(@out,\@out_row); + } + + if ((scalar @out) > 0) { + eval { + $context->{db}->db_do_begin(CTSMS::BulkProcessor::Projects::ETL::Dao::EcrfDataHorizontal::getinsertstatement(0)); + $context->{db}->db_do_rowblock(\@out); + $context->{db}->db_finish(); + }; + my $err = $@; + if ($err) { + eval { + $context->{db}->db_finish(1); + }; + rowprocessingerror($context->{tid},$err,getlogger(__PACKAGE__)); + return 0; + } + processing_info($context->{tid},(scalar @out) . ' row(s) written',getlogger(__PACKAGE__)); + } + + return 1; + }, + init_process_context_code => sub { + my ($context) = @_; + $context->{colnames} = undef; + $context->{prefix_count} = 0; + $context->{db} = undef; + }, + uninit_process_context_code => sub { + my ($context) = @_; + undef $context->{db}; + }, + ); + + unless ($result and $header_found) { + destroy_all_dbs(); + rowprocessingerror(undef,'Interfast3LabData: no AnfoNr header row found in ' . $file,getlogger(__PACKAGE__)) + unless $header_found; + return undef; + } + + my $db = &get_csv_db(); + $outfile = $db->_gettablefilename(CTSMS::BulkProcessor::Projects::ETL::Dao::EcrfDataHorizontal::gettablename()); + destroy_all_dbs(); + @job_file = ( + $outfile, + basename($outfile), + $mimetype, + ); + scriptinfo("Interfast3LabData: intermediate file $outfile",getlogger(__PACKAGE__)); + + return $outfile; +} + +sub _prefix_column_count { + return 1 + (scalar get_proband_columns()) + (scalar get_probandlistentry_columns()); +} + +sub _is_header_row { + my ($row) = @_; + return (trim($row->[0] // '') =~ /^AnfoNr$/i) ? 1 : 0; +} + +sub _normalize_colnames { + my ($header) = @_; + my @colnames = (); + my %seen = (); + my $last_analyte; + + foreach my $raw (@$header) { + my $name = trim($raw // ''); + $name = 'col' unless length($name); + + if ($name =~ /^(KZ[12]|VKZ)$/i and length($last_analyte)) { + $name = $last_analyte . '_' . $name; + } elsif ($name !~ /^(KZ[12]|VKZ)$/i) { + $last_analyte = $name; + } + + $name = sanitize_column_name($name); + + my $base = $name; + my $n = 1; + while (exists $seen{lc($name)}) { + $n++; + $name = $base . '_' . $n; + } + $seen{lc($name)} = 1; + push(@colnames,$name); + } + + return @colnames; +} + +1; diff --git a/CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/process.pl b/CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/process.pl index 3e33ca8..f876999 100644 --- a/CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/process.pl +++ b/CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/process.pl @@ -80,16 +80,21 @@ use CTSMS::BulkProcessor::Projects::ETL::EcrfImport qw( import_ecrf_data_horizontal + convert_ecrf_data ); my @TASK_OPTS = (); my $tasks = []; my $file; +my $converter; my $cleanup_task_opt = 'cleanup'; push(@TASK_OPTS,$cleanup_task_opt); +my $convert_task_opt = 'convert'; +push(@TASK_OPTS,$convert_task_opt); + my $import_ecrf_data_horizontal_task_opt = 'import_ecrf_data_horizontal'; push(@TASK_OPTS,$import_ecrf_data_horizontal_task_opt); @@ -118,6 +123,7 @@ sub init { "jid=i" => \$job_id, "auth=s" => \$auth, "file=s" => \$file, + "converter=s" => \$converter, "tz=s" => \$timezone, ); @@ -167,6 +173,12 @@ sub main { if (lc($cleanup_task_opt) eq lc($task)) { $result &= cleanup_task(\@messages) if taskinfo($cleanup_task_opt,\$result); + } elsif (lc($convert_task_opt) eq lc($task)) { + $result &= convert_task(\@messages) if taskinfo($convert_task_opt,\$result, + check_force => 1, + messages => \@messages, + ); + } elsif (lc($import_ecrf_data_horizontal_task_opt) eq lc($task)) { $result &= import_ecrf_data_horizontal_task(\@messages) if taskinfo($import_ecrf_data_horizontal_task_opt,\$result, ecrf_data_trial_id_required => 1, @@ -269,6 +281,31 @@ sub cleanup_task { } } +sub convert_task { + my ($messages) = @_; + my $result = 0; + my $outfile; + eval { + $outfile = convert_ecrf_data($file,$converter); + $result = length($outfile) ? 1 : 0; + if ($result) { + # subsequent import_ecrf_data_horizontal uses the converted intermediate file + $file = $outfile; + } + }; + my $err = $@; + if ($err) { + push(@$messages,'convert error: ' . $err); + return 0; + } elsif (!$result) { + push(@$messages,'convert error: no intermediate file produced'); + return 0; + } else { + push(@$messages,"- convert ok ($converter → $outfile)"); + return 1; + } +} + sub import_ecrf_data_horizontal_task { my ($messages) = @_; my ($result, $warning_count) = (0,0); From 8738255370ac930beb73f5835a61b42063d576fe Mon Sep 17 00:00:00 2001 From: Rene Krenn Date: Thu, 30 Jul 2026 02:40:24 +0200 Subject: [PATCH 2/5] Route Interfast3 lab CSV into multi-sheet Excel via Proband search. Match columns by eCRF field externalId, add CompleteEcrfField client, and let CSV FileProcessors report a single sheet. Co-authored-by: Cursor --- CTSMS/BulkProcessor/FileProcessor.pm | 7 + .../BulkProcessor/Projects/ETL/EcrfImport.pm | 2 +- .../Converter/Interfast3LabData.pm | 364 +++++++++++++++--- .../Projects/ETL/EcrfImporter/process.pl | 5 +- .../shared/ToolsService/CompleteEcrfField.pm | 96 +++++ 5 files changed, 413 insertions(+), 61 deletions(-) create mode 100644 CTSMS/BulkProcessor/RestRequests/ctsms/shared/ToolsService/CompleteEcrfField.pm diff --git a/CTSMS/BulkProcessor/FileProcessor.pm b/CTSMS/BulkProcessor/FileProcessor.pm index 3872da3..020f792 100644 --- a/CTSMS/BulkProcessor/FileProcessor.pm +++ b/CTSMS/BulkProcessor/FileProcessor.pm @@ -96,6 +96,13 @@ sub init_reader_context { } +sub get_sheet_names { + # CSV and other single-stream formats have no worksheets; + # return one undef entry so callers can foreach once. + my ($self,$file) = @_; + return (undef); +} + sub _extractlines { my ($context,$buffer_ref,$lines) = @_; my $separator = $context->{instance}->{line_separator}; diff --git a/CTSMS/BulkProcessor/Projects/ETL/EcrfImport.pm b/CTSMS/BulkProcessor/Projects/ETL/EcrfImport.pm index f265b6f..f9d1ebf 100644 --- a/CTSMS/BulkProcessor/Projects/ETL/EcrfImport.pm +++ b/CTSMS/BulkProcessor/Projects/ETL/EcrfImport.pm @@ -169,7 +169,7 @@ sub convert_ecrf_data { sub _load_converter { my ($spec) = @_; - scripterror('converter module required (e.g. --converter=Converter::Interfast3LabData)',getlogger(getscriptpath())) + scripterror('converter module required (e.g. --converter=Converter::MyConverter)',getlogger(getscriptpath())) unless length($spec); # Converters live next to process.pl: EcrfImporter/Converter/*.pm diff --git a/CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/Converter/Interfast3LabData.pm b/CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/Converter/Interfast3LabData.pm index 2042c11..17ec069 100644 --- a/CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/Converter/Interfast3LabData.pm +++ b/CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/Converter/Interfast3LabData.pm @@ -4,28 +4,53 @@ use strict; ## no critic use File::Basename qw(basename); +use Excel::Writer::XLSX; use CTSMS::BulkProcessor::FileProcessors::CSVFileSimple qw(); use CTSMS::BulkProcessor::Projects::ETL::EcrfSettings qw( - get_proband_columns - get_probandlistentry_columns + $ecrf_data_trial_id + $output_path + $skip_errors ); -use CTSMS::BulkProcessor::Projects::ETL::EcrfConnectorPool qw( - get_csv_db - destroy_all_dbs + +use CTSMS::BulkProcessor::Projects::ETL::Ecrf qw( + get_ecrf_map + get_horizontal_cols +); + +use CTSMS::BulkProcessor::Projects::ETL::Import qw( + init_context ); -use CTSMS::BulkProcessor::Projects::ETL::Dao::EcrfDataHorizontal qw(); + use CTSMS::BulkProcessor::Projects::ETL::Job qw( @job_file ); +use CTSMS::BulkProcessor::RestRequests::ctsms::trial::TrialService::Trial qw(); +use CTSMS::BulkProcessor::RestRequests::ctsms::trial::TrialService::ProbandListEntry qw(); +use CTSMS::BulkProcessor::RestRequests::ctsms::trial::TrialService::EcrfFieldValues qw(); +use CTSMS::BulkProcessor::RestRequests::ctsms::proband::ProbandService::Proband qw(); +use CTSMS::BulkProcessor::RestRequests::ctsms::shared::ToolsService::CompleteEcrfField qw( + complete_ecrf_field +); +use CTSMS::BulkProcessor::RestRequests::ctsms::shared::SelectionSetService::CriterionTie qw( + $AND +); +use CTSMS::BulkProcessor::RestRequests::ctsms::shared::SelectionSetService::CriterionRestriction qw( + $EQ + $GE +); +use CTSMS::BulkProcessor::RestRequests::ctsms::shared::SelectionSetService::DBModule qw( + $PROBAND_DB +); + use CTSMS::BulkProcessor::SqlConnectors::CSVDB qw( - $mimetype + sanitize_spreadsheet_name sanitize_column_name ); -use CTSMS::BulkProcessor::Utils qw(trim); +use CTSMS::BulkProcessor::Utils qw(trim timestampdigits); use CTSMS::BulkProcessor::Logging qw( getlogger processing_info @@ -33,6 +58,8 @@ use CTSMS::BulkProcessor::Logging qw( ); use CTSMS::BulkProcessor::LogError qw( rowprocessingerror + rowprocessingwarn + fileerror ); require Exporter; @@ -42,6 +69,11 @@ our @EXPORT_OK = qw( process ); +my $xlsxextension = '.xlsx'; +my $xlsxmimetype = 'application/vnd.openxmlformats-officedocument.spreadsheetml.sheet'; + +my $lab_request_name_infix = '[Interfast3] lab request number'; + # Interfast3 lab exports: metadata line, then header, then data. Separator is ';'. # Qualifier columns KZ1/KZ2/VKZ repeat after each analyte — rename to _KZ1 etc. @@ -53,25 +85,45 @@ sub convert { my ($file) = @_; rowprocessingerror(undef,'no input file specified',getlogger(__PACKAGE__)) unless length($file); + rowprocessingerror(undef,'trial id required',getlogger(__PACKAGE__)) + unless (defined $ecrf_data_trial_id and length($ecrf_data_trial_id)); + scriptinfo("Interfast3LabData: converting $file",getlogger(__PACKAGE__)); - my $result = 1; - my $outfile; + my $static = _init_convert_context(); + my $outfile = $output_path . 'interfast3_lab_data_' . timestampdigits() . $xlsxextension; + + my $workbook = Excel::Writer::XLSX->new($outfile); + unless ($workbook) { + fileerror($!,getlogger(__PACKAGE__)); + return undef; + } + my $header_format = $workbook->add_format(); + $header_format->set_bold(); + + $static->{workbook} = $workbook; + $static->{header_format} = $header_format; + $static->{outfile} = $outfile; + my $header_found = 0; + my $result = 1; my $processor = CTSMS::BulkProcessor::FileProcessors::CSVFileSimple->new( field_separator => ';', numofthreads => 1, - blocksize => 100, + blocksize => 50, ); $result = $processor->process( file => $file, multithreading => 0, - static_context => { header_found_ref => \$header_found }, + static_context => { + %$static, + header_found_ref => \$header_found, + skip_errors => $skip_errors, + }, process_code => sub { my ($context,$rows,$row_offset) = @_; - my @out = (); foreach my $row (@$rows) { next unless (scalar @$row); @@ -82,40 +134,12 @@ sub convert { my @colnames = _normalize_colnames($row); $context->{colnames} = \@colnames; ${$context->{header_found_ref}} = 1; - $context->{prefix_count} = _prefix_column_count(); - $context->{db} = &get_csv_db(); - unless (CTSMS::BulkProcessor::Projects::ETL::Dao::EcrfDataHorizontal::create_table(1,\@colnames,{})) { - rowprocessingerror($context->{tid},'failed to create ecrf_data_horizontal intermediate table',getlogger(__PACKAGE__)); - return 0; - } - processing_info($context->{tid},'created intermediate table with ' . (scalar @colnames) . ' value column(s)',getlogger(__PACKAGE__)); + _create_lab_sheets($context,\@colnames); + processing_info($context->{tid},'CSV header with ' . (scalar @colnames) . ' column(s); lab sheets created',getlogger(__PACKAGE__)); next; } - my $col_count = scalar @{$context->{colnames}}; - my @values = (); - for (my $i = 0; $i < $col_count; $i++) { - push(@values,trim($row->[$i] // '')); - } - my @out_row = ((undef) x $context->{prefix_count}, @values); - push(@out,\@out_row); - } - - if ((scalar @out) > 0) { - eval { - $context->{db}->db_do_begin(CTSMS::BulkProcessor::Projects::ETL::Dao::EcrfDataHorizontal::getinsertstatement(0)); - $context->{db}->db_do_rowblock(\@out); - $context->{db}->db_finish(); - }; - my $err = $@; - if ($err) { - eval { - $context->{db}->db_finish(1); - }; - rowprocessingerror($context->{tid},$err,getlogger(__PACKAGE__)); - return 0; - } - processing_info($context->{tid},(scalar @out) . ' row(s) written',getlogger(__PACKAGE__)); + next unless _process_data_row($context,$row); } return 1; @@ -123,37 +147,265 @@ sub convert { init_process_context_code => sub { my ($context) = @_; $context->{colnames} = undef; - $context->{prefix_count} = 0; - $context->{db} = undef; + $context->{error_count} = 0; + $context->{warning_count} = 0; }, uninit_process_context_code => sub { - my ($context) = @_; - undef $context->{db}; }, ); unless ($result and $header_found) { - destroy_all_dbs(); + $workbook->close() if $workbook; + unlink $outfile if length($outfile) and -f $outfile; rowprocessingerror(undef,'Interfast3LabData: no AnfoNr header row found in ' . $file,getlogger(__PACKAGE__)) unless $header_found; return undef; } - my $db = &get_csv_db(); - $outfile = $db->_gettablefilename(CTSMS::BulkProcessor::Projects::ETL::Dao::EcrfDataHorizontal::gettablename()); - destroy_all_dbs(); + $workbook->close(); @job_file = ( $outfile, basename($outfile), - $mimetype, + $xlsxmimetype, ); scriptinfo("Interfast3LabData: intermediate file $outfile",getlogger(__PACKAGE__)); - return $outfile; } -sub _prefix_column_count { - return 1 + (scalar get_proband_columns()) + (scalar get_probandlistentry_columns()); +sub _init_convert_context { + my $context = { + ecrf_data_trial => CTSMS::BulkProcessor::RestRequests::ctsms::trial::TrialService::Trial::get_item($ecrf_data_trial_id), + }; + rowprocessingerror(undef,"error loading trial id $ecrf_data_trial_id",getlogger(__PACKAGE__)) + unless $context->{ecrf_data_trial}; + + unless (init_context($context)) { + rowprocessingerror(undef,'error initializing convert context',getlogger(__PACKAGE__)); + } + + $context->{ecrf_map} = get_ecrf_map($context,0); + + my @lab_ecrfs = (); + my %lab_columns_by_name = (); + foreach my $ecrfid (keys %{$context->{ecrf_map}}) { + my $ecrf = $context->{ecrf_map}->{$ecrfid}->{ecrf}; + next unless (defined $ecrf->{name} and $ecrf->{name} =~ /lab/i); + $context->{ecrf} = $ecrf; + my $columns = get_horizontal_cols($context,0); + my @prepared = (); + foreach my $column (@$columns) { + my $external_id = _external_id_of($column->{ecrffield}); + next unless length($external_id); + push(@prepared,{ + colname => $column->{colname}, + external_id => $external_id, + ecrffield => $column->{ecrffield}, + }); + } + push(@lab_ecrfs,$ecrf); + $lab_columns_by_name{$ecrf->{name}} = \@prepared; + processing_info(undef,"lab eCRF '$ecrf->{name}': " . (scalar @prepared) . ' column(s) with externalId',getlogger(__PACKAGE__)); + } + delete $context->{ecrf}; + $context->{lab_ecrfs} = \@lab_ecrfs; + $context->{lab_columns_by_name} = \%lab_columns_by_name; + + rowprocessingerror(undef,'no eCRFs with "lab" in the name found for this trial',getlogger(__PACKAGE__)) + unless (scalar @lab_ecrfs); + + my $matches = complete_ecrf_field($lab_request_name_infix,20); + $matches = [] unless (defined $matches and ref $matches eq 'ARRAY'); + my $lab_request_field = _pick_lab_request_field($matches); + rowprocessingerror(undef,"no eCRF field found for nameInfix '$lab_request_name_infix'",getlogger(__PACKAGE__)) + unless $lab_request_field; + $context->{lab_request_ecrffield_id} = $lab_request_field->{id} // $lab_request_field->{value}; + rowprocessingerror(undef,"complete ecrffield '$lab_request_name_infix' returned no id",getlogger(__PACKAGE__)) + unless length($context->{lab_request_ecrffield_id}); + scriptinfo("Interfast3LabData: lab request eCRF field id $context->{lab_request_ecrffield_id}",getlogger(__PACKAGE__)); + + return $context; +} + +sub _pick_lab_request_field { + my ($matches) = @_; + return undef unless (scalar @$matches); + my $needle = lc($lab_request_name_infix); + foreach my $item (@$matches) { + foreach my $key (qw/uniqueName title titleL10nKey name label/) { + if (defined $item->{$key} and lc($item->{$key}) eq $needle) { + return $item; + } + } + } + return $matches->[0]; +} + +sub _external_id_of { + my ($ecrffield) = @_; + return undef unless $ecrffield; + if (defined $ecrffield->{externalId} and length($ecrffield->{externalId})) { + return $ecrffield->{externalId}; + } + if (defined $ecrffield->{field} and defined $ecrffield->{field}->{externalId} and length($ecrffield->{field}->{externalId})) { + return $ecrffield->{field}->{externalId}; + } + return undef; +} + +sub _create_lab_sheets { + my ($context,$csv_colnames) = @_; + + my %csv_index_by_lc = (); + for (my $i = 0; $i < scalar @$csv_colnames; $i++) { + $csv_index_by_lc{lc($csv_colnames->[$i])} = $i; + } + + $context->{sheets_by_name} = {}; + $context->{anfonr_index} = $csv_index_by_lc{lc('AnfoNr')}; + + foreach my $ecrf (@{$context->{lab_ecrfs}}) { + my $name = $ecrf->{name}; + my @header = ('proband_id'); + my @matched = (); + foreach my $col (@{$context->{lab_columns_by_name}->{$name} // []}) { + my $csv_index = $csv_index_by_lc{lc($col->{external_id})}; + next unless defined $csv_index; + push(@header,$col->{colname}); + push(@matched,{ + colname => $col->{colname}, + csv_index => $csv_index, + external_id => $col->{external_id}, + }); + } + + my $sheetname = sanitize_spreadsheet_name($name); + my $worksheet = $context->{workbook}->add_worksheet($sheetname); + for (my $c = 0; $c < scalar @header; $c++) { + $worksheet->write_string(0,$c,$header[$c],$context->{header_format}); + } + + $context->{sheets_by_name}->{$name} = { + worksheet => $worksheet, + header => \@header, + matched => \@matched, + next_row => 1, + ecrf => $ecrf, + }; + processing_info($context->{tid},"sheet '$sheetname': " . (scalar @matched) . ' matched column(s)',getlogger(__PACKAGE__)); + } +} + +sub _process_data_row { + my ($context,$row) = @_; + + my $anfonr; + if (defined $context->{anfonr_index}) { + $anfonr = trim($row->[$context->{anfonr_index}] // ''); + } + unless (length($anfonr)) { + _warn_or_error($context,'skipping row without AnfoNr'); + return 0; + } + + my $probands; + eval { + $probands = CTSMS::BulkProcessor::RestRequests::ctsms::proband::ProbandService::Proband::search({ + module => $PROBAND_DB, + criterions => [{ + position => 1, + restrictionId => $context->{criterionrestriction_map}->{$EQ}, + propertyId => $context->{criterionproperty_map}->{'proband.trialParticipations.ecrfValues.ecrfField.id'}, + longValue => $context->{lab_request_ecrffield_id}, + },{ + position => 2, + tieId => $context->{criteriontie_map}->{$AND}, + restrictionId => $context->{criterionrestriction_map}->{$GE}, + propertyId => $context->{criterionproperty_map}->{'proband.trialParticipations.ecrfValues.value.stringValue'}, + floatValue => $anfonr, + }], + }); + }; + if ($@) { + _warn_or_error($context,"AnfoNr $anfonr: error searching proband: $@"); + return 0; + } + $probands //= []; + if ((scalar @$probands) == 0) { + _warn_or_error($context,"AnfoNr $anfonr: no proband found"); + return 0; + } + if ((scalar @$probands) > 1) { + _warn_or_error($context,"AnfoNr $anfonr: " . (scalar @$probands) . ' probands found, expected 1'); + return 0; + } + my $proband = $probands->[0]; + + my $listentries; + eval { + $listentries = CTSMS::BulkProcessor::RestRequests::ctsms::trial::TrialService::ProbandListEntry::get_trial_list( + $context->{ecrf_data_trial}->{id},undef,$proband->{id},1); + }; + if ($@) { + _warn_or_error($context,"AnfoNr $anfonr: error loading listentry: $@"); + return 0; + } + $listentries //= []; + if ((scalar @$listentries) != 1) { + _warn_or_error($context,"AnfoNr $anfonr: expected 1 listentry for proband $proband->{id}, got " . (scalar @$listentries)); + return 0; + } + my $listentry = $listentries->[0]; + + my $ecrf_value; + eval { + my $values = CTSMS::BulkProcessor::RestRequests::ctsms::trial::TrialService::EcrfFieldValues::get_item( + $listentry->{id},undef,$context->{lab_request_ecrffield_id},undef); + $ecrf_value = $values->{rows}->[0] if $values; + }; + if ($@) { + _warn_or_error($context,"AnfoNr $anfonr: error loading eCRF field value: $@"); + return 0; + } + unless ($ecrf_value and $ecrf_value->{ecrfField} and $ecrf_value->{ecrfField}->{ecrf}) { + _warn_or_error($context,"AnfoNr $anfonr: no eCRF field value for lab request field"); + return 0; + } + + my $source_ecrf_name = $ecrf_value->{ecrfField}->{ecrf}->{name}; + my $target_sheet_name = $source_ecrf_name . '_lab'; + my $sheet = $context->{sheets_by_name}->{$target_sheet_name}; + unless ($sheet) { + _warn_or_error($context,"AnfoNr $anfonr: no lab sheet for eCRF '$source_ecrf_name' (expected '$target_sheet_name')"); + return 0; + } + + my @out = ($proband->{id}); + foreach my $matched (@{$sheet->{matched}}) { + push(@out,trim($row->[$matched->{csv_index}] // '')); + } + + my $r = $sheet->{next_row}; + for (my $c = 0; $c < scalar @out; $c++) { + my $val = $out[$c]; + if (defined $val and length($val)) { + $sheet->{worksheet}->write_string($r,$c,$val); + } else { + $sheet->{worksheet}->write_blank($r,$c); + } + } + $sheet->{next_row} = $r + 1; + return 1; +} + +sub _warn_or_error { + my ($context,$message) = @_; + if ($context->{skip_errors}) { + $context->{warning_count} = ($context->{warning_count} // 0) + 1; + rowprocessingwarn($context->{tid},$message,getlogger(__PACKAGE__)); + } else { + $context->{error_count} = ($context->{error_count} // 0) + 1; + rowprocessingerror($context->{tid},$message,getlogger(__PACKAGE__)); + } } sub _is_header_row { diff --git a/CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/process.pl b/CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/process.pl index f876999..ff2c901 100644 --- a/CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/process.pl +++ b/CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/process.pl @@ -174,10 +174,7 @@ sub main { $result &= cleanup_task(\@messages) if taskinfo($cleanup_task_opt,\$result); } elsif (lc($convert_task_opt) eq lc($task)) { - $result &= convert_task(\@messages) if taskinfo($convert_task_opt,\$result, - check_force => 1, - messages => \@messages, - ); + $result &= convert_task(\@messages) if taskinfo($convert_task_opt,\$result); } elsif (lc($import_ecrf_data_horizontal_task_opt) eq lc($task)) { $result &= import_ecrf_data_horizontal_task(\@messages) if taskinfo($import_ecrf_data_horizontal_task_opt,\$result, diff --git a/CTSMS/BulkProcessor/RestRequests/ctsms/shared/ToolsService/CompleteEcrfField.pm b/CTSMS/BulkProcessor/RestRequests/ctsms/shared/ToolsService/CompleteEcrfField.pm new file mode 100644 index 0000000..e601096 --- /dev/null +++ b/CTSMS/BulkProcessor/RestRequests/ctsms/shared/ToolsService/CompleteEcrfField.pm @@ -0,0 +1,96 @@ +package CTSMS::BulkProcessor::RestRequests::ctsms::shared::ToolsService::CompleteEcrfField; +use strict; + +## no critic + +use CTSMS::BulkProcessor::ConnectorPool qw( + get_ctsms_restapi +); + +use CTSMS::BulkProcessor::RestProcessor qw( + copy_row + get_query_string +); + +use CTSMS::BulkProcessor::RestConnectors::CtsmsRestApi qw(_get_api); +use CTSMS::BulkProcessor::RestItem qw(); + +require Exporter; +our @ISA = qw(Exporter CTSMS::BulkProcessor::RestItem); +our @EXPORT_OK = qw( + complete_ecrf_field +); + +my $default_restapi = \&get_ctsms_restapi; +my $get_complete_path_query = sub { + my ($name_infix, $limit) = @_; + my %params = (); + $params{nameInfix} = $name_infix if defined $name_infix; + $params{limit} = $limit if defined $limit; + return 'tools/complete/ecrffield/' . get_query_string(\%params); +}; + +my $fieldnames = [ + 'id', + 'name', + 'uniqueName', + 'title', + 'titleL10nKey', + 'externalId', + 'value', + 'label', +]; + +sub new { + + my $class = shift; + my $self = CTSMS::BulkProcessor::RestItem->new($class,$fieldnames); + + copy_row($self,shift,$fieldnames); + + return $self; + +} + +sub complete_ecrf_field { + + my ($name_infix, $limit, $load_recursive,$restapi,$headers) = @_; + my $api = _get_api($restapi,$default_restapi); + return builditems_fromrows($api->get(&$get_complete_path_query($name_infix, $limit),$headers),$load_recursive,$restapi); + +} + +sub builditems_fromrows { + + my ($rows,$load_recursive,$restapi) = @_; + + my $item; + + if (defined $rows and ref $rows eq 'ARRAY') { + my @items = (); + foreach my $row (@$rows) { + $item = __PACKAGE__->new($row); + push @items,$item; + } + return \@items; + } elsif (defined $rows and ref $rows eq 'HASH') { + $item = __PACKAGE__->new($rows); + return $item; + } + return undef; + +} + +sub TO_JSON { + + my $self = shift; + my $label = $self->{label} // $self->{uniqueName} // $self->{title} // $self->{name} // $self->{id}; + my $value = $self->{value} // $self->{id}; + return { + value => $value, + label => $label, + }; + +} + +1; From 5c2de662242d2ee1023800b479c1606223f3d1ec Mon Sep 17 00:00:00 2001 From: Rene Krenn Date: Thu, 30 Jul 2026 02:42:59 +0200 Subject: [PATCH 3/5] Prefer JWT username claim when resolving the REST API user. Stop falling back to the sub claim in get_username_from_jwt. Co-authored-by: Cursor --- CTSMS/BulkProcessor/RestConnector.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CTSMS/BulkProcessor/RestConnector.pm b/CTSMS/BulkProcessor/RestConnector.pm index 7800b08..d83688b 100644 --- a/CTSMS/BulkProcessor/RestConnector.pm +++ b/CTSMS/BulkProcessor/RestConnector.pm @@ -704,7 +704,7 @@ sub get_username_from_jwt { my ($jwt) = @_; my $payload = _decode_jwt_payload($jwt); return undef unless defined $payload && 'HASH' eq ref $payload; - return $payload->{sub} // $payload->{username}; + return $payload->{username}; # // $payload->{sub}; } sub jwt_needs_refresh { From 821c9c7589cd0ec22e3d66d820fc77fcebb165b7 Mon Sep 17 00:00:00 2001 From: Rene Krenn Date: Thu, 30 Jul 2026 23:31:54 +0200 Subject: [PATCH 4/5] Publish convert intermediates via FileService and move Interfast3 out of core. Converters may return a File %in scaffold to upload input and outfile; Interfast3LabData now lives in site config. Co-authored-by: Cursor --- .../BulkProcessor/Projects/ETL/EcrfImport.pm | 67 ++- .../Converter/Interfast3LabData.pm | 447 ------------------ .../Projects/ETL/EcrfImporter/process.pl | 10 +- .../CompleteEcrfFieldInputField.pm | 95 ++++ 4 files changed, 168 insertions(+), 451 deletions(-) delete mode 100644 CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/Converter/Interfast3LabData.pm create mode 100644 CTSMS/BulkProcessor/RestRequests/ctsms/shared/ToolsService/CompleteEcrfFieldInputField.pm diff --git a/CTSMS/BulkProcessor/Projects/ETL/EcrfImport.pm b/CTSMS/BulkProcessor/Projects/ETL/EcrfImport.pm index f9d1ebf..bf9a144 100644 --- a/CTSMS/BulkProcessor/Projects/ETL/EcrfImport.pm +++ b/CTSMS/BulkProcessor/Projects/ETL/EcrfImport.pm @@ -9,6 +9,13 @@ use threads::shared qw(); use utf8; use Encode qw(); +use CTSMS::BulkProcessor::Globals qw( + $system_name + $system_version + $system_instance_label + $local_fqdn +); + use CTSMS::BulkProcessor::Projects::ETL::EcrfSettings qw( $skip_errors $timezone @@ -75,6 +82,7 @@ use CTSMS::BulkProcessor::RestRequests::ctsms::trial::TrialService::ProbandListE use CTSMS::BulkProcessor::RestRequests::ctsms::proband::ProbandService::Proband qw(); use CTSMS::BulkProcessor::RestRequests::ctsms::shared::SelectionSetService::ProbandCategory qw(); +use CTSMS::BulkProcessor::RestRequests::ctsms::shared::FileService::File qw(); use CTSMS::BulkProcessor::RestRequests::ctsms::shared::SelectionSetService::CriterionTie qw(); use CTSMS::BulkProcessor::RestRequests::ctsms::shared::SelectionSetService::CriterionRestriction qw(); @@ -144,6 +152,7 @@ our @ISA = qw(Exporter); our @EXPORT_OK = qw( import_ecrf_data_horizontal convert_ecrf_data + publish_converted_intermediate_file ); my @header_row :shared = (); @@ -160,11 +169,65 @@ sub convert_ecrf_data { my $convert_code = _load_converter($converter); my $infile = get_input_filename($file,$ecrf_import_filename); - my $outfile = &$convert_code($infile); + # convert() returns $outfile (no upload), or ($outfile, $file_in) to upload both + # the original job/input file and the intermediate outfile with the same File %in scaffold. + my ($outfile,$file_in) = &$convert_code($infile); + my @uploaded; if (length($outfile)) { scriptinfo("converter '$converter' wrote intermediate file $outfile",getlogger(__PACKAGE__)); + if (ref($file_in) eq 'HASH') { + push(@uploaded,publish_converted_intermediate_file($infile,$file_in)); + push(@uploaded,publish_converted_intermediate_file($outfile,$file_in)); + } } - return $outfile; + return ($outfile,@uploaded); +} + +sub publish_converted_intermediate_file { + my ($outfile,$file_in) = @_; + + scripterror('no intermediate file to publish',getlogger(getscriptpath())) + unless length($outfile); + scripterror("intermediate file not found: $outfile",getlogger(getscriptpath())) + unless -f $outfile; + scripterror('File %in scaffold required to publish intermediate file',getlogger(getscriptpath())) + unless (ref($file_in) eq 'HASH'); + my $logical_path = $file_in->{logicalPath}; + scripterror('logicalPath required to publish intermediate file',getlogger(getscriptpath())) + unless length($logical_path); + scripterror('trial id required to publish intermediate file',getlogger(getscriptpath())) + unless (defined $ecrf_data_trial_id and length($ecrf_data_trial_id)); + + my $filename = File::Basename::basename($outfile); + my $mimetype = _converted_file_mimetype($outfile); + my $in = { + "active" => \0, + "publicFile" => (exists $file_in->{publicFile} ? $file_in->{publicFile} : \0), + "comment" => $system_name . ' ' . $system_version . ' (' . $system_instance_label . ') [' . $local_fqdn . ']', + "trialId" => $ecrf_data_trial_id, + "module" => $CTSMS::BulkProcessor::RestRequests::ctsms::shared::FileService::File::TRIAL_FILE_MODULE, + "logicalPath" => $logical_path, + "title" => $filename, + }; + my $out = CTSMS::BulkProcessor::RestRequests::ctsms::shared::FileService::File::upload( + $in, + $outfile, + $filename, + $mimetype, + ); + scripterror("failed to upload intermediate file '$filename'",getlogger(getscriptpath())) + unless $out; + scriptinfo("uploaded intermediate file '$filename' (file ID $out->{id}) to trial id $ecrf_data_trial_id path '$logical_path'",getlogger(__PACKAGE__)); + return $out; +} + +sub _converted_file_mimetype { + my ($outfile) = @_; + return 'application/vnd.openxmlformats-officedocument.spreadsheetml.sheet' if $outfile =~ /\.xlsx$/i; + return 'application/vnd.ms-excel' if $outfile =~ /\.xls$/i; + return 'text/csv' if $outfile =~ /\.csv$/i; + return 'text/plain' if $outfile =~ /\.txt$/i; + return 'application/octet-stream'; } sub _load_converter { diff --git a/CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/Converter/Interfast3LabData.pm b/CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/Converter/Interfast3LabData.pm deleted file mode 100644 index 17ec069..0000000 --- a/CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/Converter/Interfast3LabData.pm +++ /dev/null @@ -1,447 +0,0 @@ -package Converter::Interfast3LabData; -use strict; - -## no critic - -use File::Basename qw(basename); -use Excel::Writer::XLSX; - -use CTSMS::BulkProcessor::FileProcessors::CSVFileSimple qw(); - -use CTSMS::BulkProcessor::Projects::ETL::EcrfSettings qw( - $ecrf_data_trial_id - $output_path - $skip_errors -); - -use CTSMS::BulkProcessor::Projects::ETL::Ecrf qw( - get_ecrf_map - get_horizontal_cols -); - -use CTSMS::BulkProcessor::Projects::ETL::Import qw( - init_context -); - -use CTSMS::BulkProcessor::Projects::ETL::Job qw( - @job_file -); - -use CTSMS::BulkProcessor::RestRequests::ctsms::trial::TrialService::Trial qw(); -use CTSMS::BulkProcessor::RestRequests::ctsms::trial::TrialService::ProbandListEntry qw(); -use CTSMS::BulkProcessor::RestRequests::ctsms::trial::TrialService::EcrfFieldValues qw(); -use CTSMS::BulkProcessor::RestRequests::ctsms::proband::ProbandService::Proband qw(); -use CTSMS::BulkProcessor::RestRequests::ctsms::shared::ToolsService::CompleteEcrfField qw( - complete_ecrf_field -); -use CTSMS::BulkProcessor::RestRequests::ctsms::shared::SelectionSetService::CriterionTie qw( - $AND -); -use CTSMS::BulkProcessor::RestRequests::ctsms::shared::SelectionSetService::CriterionRestriction qw( - $EQ - $GE -); -use CTSMS::BulkProcessor::RestRequests::ctsms::shared::SelectionSetService::DBModule qw( - $PROBAND_DB -); - -use CTSMS::BulkProcessor::SqlConnectors::CSVDB qw( - sanitize_spreadsheet_name - sanitize_column_name -); - -use CTSMS::BulkProcessor::Utils qw(trim timestampdigits); -use CTSMS::BulkProcessor::Logging qw( - getlogger - processing_info - scriptinfo -); -use CTSMS::BulkProcessor::LogError qw( - rowprocessingerror - rowprocessingwarn - fileerror -); - -require Exporter; -our @ISA = qw(Exporter); -our @EXPORT_OK = qw( - convert - process -); - -my $xlsxextension = '.xlsx'; -my $xlsxmimetype = 'application/vnd.openxmlformats-officedocument.spreadsheetml.sheet'; - -my $lab_request_name_infix = '[Interfast3] lab request number'; - -# Interfast3 lab exports: metadata line, then header, then data. Separator is ';'. -# Qualifier columns KZ1/KZ2/VKZ repeat after each analyte — rename to _KZ1 etc. - -sub process { - return convert(@_); -} - -sub convert { - my ($file) = @_; - - rowprocessingerror(undef,'no input file specified',getlogger(__PACKAGE__)) unless length($file); - rowprocessingerror(undef,'trial id required',getlogger(__PACKAGE__)) - unless (defined $ecrf_data_trial_id and length($ecrf_data_trial_id)); - - scriptinfo("Interfast3LabData: converting $file",getlogger(__PACKAGE__)); - - my $static = _init_convert_context(); - my $outfile = $output_path . 'interfast3_lab_data_' . timestampdigits() . $xlsxextension; - - my $workbook = Excel::Writer::XLSX->new($outfile); - unless ($workbook) { - fileerror($!,getlogger(__PACKAGE__)); - return undef; - } - my $header_format = $workbook->add_format(); - $header_format->set_bold(); - - $static->{workbook} = $workbook; - $static->{header_format} = $header_format; - $static->{outfile} = $outfile; - - my $header_found = 0; - my $result = 1; - - my $processor = CTSMS::BulkProcessor::FileProcessors::CSVFileSimple->new( - field_separator => ';', - numofthreads => 1, - blocksize => 50, - ); - - $result = $processor->process( - file => $file, - multithreading => 0, - static_context => { - %$static, - header_found_ref => \$header_found, - skip_errors => $skip_errors, - }, - process_code => sub { - my ($context,$rows,$row_offset) = @_; - - foreach my $row (@$rows) { - next unless (scalar @$row); - next unless (scalar grep { length(trim($_ // '')) > 0; } @$row); - - unless ($context->{colnames}) { - next unless _is_header_row($row); - my @colnames = _normalize_colnames($row); - $context->{colnames} = \@colnames; - ${$context->{header_found_ref}} = 1; - _create_lab_sheets($context,\@colnames); - processing_info($context->{tid},'CSV header with ' . (scalar @colnames) . ' column(s); lab sheets created',getlogger(__PACKAGE__)); - next; - } - - next unless _process_data_row($context,$row); - } - - return 1; - }, - init_process_context_code => sub { - my ($context) = @_; - $context->{colnames} = undef; - $context->{error_count} = 0; - $context->{warning_count} = 0; - }, - uninit_process_context_code => sub { - }, - ); - - unless ($result and $header_found) { - $workbook->close() if $workbook; - unlink $outfile if length($outfile) and -f $outfile; - rowprocessingerror(undef,'Interfast3LabData: no AnfoNr header row found in ' . $file,getlogger(__PACKAGE__)) - unless $header_found; - return undef; - } - - $workbook->close(); - @job_file = ( - $outfile, - basename($outfile), - $xlsxmimetype, - ); - scriptinfo("Interfast3LabData: intermediate file $outfile",getlogger(__PACKAGE__)); - return $outfile; -} - -sub _init_convert_context { - my $context = { - ecrf_data_trial => CTSMS::BulkProcessor::RestRequests::ctsms::trial::TrialService::Trial::get_item($ecrf_data_trial_id), - }; - rowprocessingerror(undef,"error loading trial id $ecrf_data_trial_id",getlogger(__PACKAGE__)) - unless $context->{ecrf_data_trial}; - - unless (init_context($context)) { - rowprocessingerror(undef,'error initializing convert context',getlogger(__PACKAGE__)); - } - - $context->{ecrf_map} = get_ecrf_map($context,0); - - my @lab_ecrfs = (); - my %lab_columns_by_name = (); - foreach my $ecrfid (keys %{$context->{ecrf_map}}) { - my $ecrf = $context->{ecrf_map}->{$ecrfid}->{ecrf}; - next unless (defined $ecrf->{name} and $ecrf->{name} =~ /lab/i); - $context->{ecrf} = $ecrf; - my $columns = get_horizontal_cols($context,0); - my @prepared = (); - foreach my $column (@$columns) { - my $external_id = _external_id_of($column->{ecrffield}); - next unless length($external_id); - push(@prepared,{ - colname => $column->{colname}, - external_id => $external_id, - ecrffield => $column->{ecrffield}, - }); - } - push(@lab_ecrfs,$ecrf); - $lab_columns_by_name{$ecrf->{name}} = \@prepared; - processing_info(undef,"lab eCRF '$ecrf->{name}': " . (scalar @prepared) . ' column(s) with externalId',getlogger(__PACKAGE__)); - } - delete $context->{ecrf}; - $context->{lab_ecrfs} = \@lab_ecrfs; - $context->{lab_columns_by_name} = \%lab_columns_by_name; - - rowprocessingerror(undef,'no eCRFs with "lab" in the name found for this trial',getlogger(__PACKAGE__)) - unless (scalar @lab_ecrfs); - - my $matches = complete_ecrf_field($lab_request_name_infix,20); - $matches = [] unless (defined $matches and ref $matches eq 'ARRAY'); - my $lab_request_field = _pick_lab_request_field($matches); - rowprocessingerror(undef,"no eCRF field found for nameInfix '$lab_request_name_infix'",getlogger(__PACKAGE__)) - unless $lab_request_field; - $context->{lab_request_ecrffield_id} = $lab_request_field->{id} // $lab_request_field->{value}; - rowprocessingerror(undef,"complete ecrffield '$lab_request_name_infix' returned no id",getlogger(__PACKAGE__)) - unless length($context->{lab_request_ecrffield_id}); - scriptinfo("Interfast3LabData: lab request eCRF field id $context->{lab_request_ecrffield_id}",getlogger(__PACKAGE__)); - - return $context; -} - -sub _pick_lab_request_field { - my ($matches) = @_; - return undef unless (scalar @$matches); - my $needle = lc($lab_request_name_infix); - foreach my $item (@$matches) { - foreach my $key (qw/uniqueName title titleL10nKey name label/) { - if (defined $item->{$key} and lc($item->{$key}) eq $needle) { - return $item; - } - } - } - return $matches->[0]; -} - -sub _external_id_of { - my ($ecrffield) = @_; - return undef unless $ecrffield; - if (defined $ecrffield->{externalId} and length($ecrffield->{externalId})) { - return $ecrffield->{externalId}; - } - if (defined $ecrffield->{field} and defined $ecrffield->{field}->{externalId} and length($ecrffield->{field}->{externalId})) { - return $ecrffield->{field}->{externalId}; - } - return undef; -} - -sub _create_lab_sheets { - my ($context,$csv_colnames) = @_; - - my %csv_index_by_lc = (); - for (my $i = 0; $i < scalar @$csv_colnames; $i++) { - $csv_index_by_lc{lc($csv_colnames->[$i])} = $i; - } - - $context->{sheets_by_name} = {}; - $context->{anfonr_index} = $csv_index_by_lc{lc('AnfoNr')}; - - foreach my $ecrf (@{$context->{lab_ecrfs}}) { - my $name = $ecrf->{name}; - my @header = ('proband_id'); - my @matched = (); - foreach my $col (@{$context->{lab_columns_by_name}->{$name} // []}) { - my $csv_index = $csv_index_by_lc{lc($col->{external_id})}; - next unless defined $csv_index; - push(@header,$col->{colname}); - push(@matched,{ - colname => $col->{colname}, - csv_index => $csv_index, - external_id => $col->{external_id}, - }); - } - - my $sheetname = sanitize_spreadsheet_name($name); - my $worksheet = $context->{workbook}->add_worksheet($sheetname); - for (my $c = 0; $c < scalar @header; $c++) { - $worksheet->write_string(0,$c,$header[$c],$context->{header_format}); - } - - $context->{sheets_by_name}->{$name} = { - worksheet => $worksheet, - header => \@header, - matched => \@matched, - next_row => 1, - ecrf => $ecrf, - }; - processing_info($context->{tid},"sheet '$sheetname': " . (scalar @matched) . ' matched column(s)',getlogger(__PACKAGE__)); - } -} - -sub _process_data_row { - my ($context,$row) = @_; - - my $anfonr; - if (defined $context->{anfonr_index}) { - $anfonr = trim($row->[$context->{anfonr_index}] // ''); - } - unless (length($anfonr)) { - _warn_or_error($context,'skipping row without AnfoNr'); - return 0; - } - - my $probands; - eval { - $probands = CTSMS::BulkProcessor::RestRequests::ctsms::proband::ProbandService::Proband::search({ - module => $PROBAND_DB, - criterions => [{ - position => 1, - restrictionId => $context->{criterionrestriction_map}->{$EQ}, - propertyId => $context->{criterionproperty_map}->{'proband.trialParticipations.ecrfValues.ecrfField.id'}, - longValue => $context->{lab_request_ecrffield_id}, - },{ - position => 2, - tieId => $context->{criteriontie_map}->{$AND}, - restrictionId => $context->{criterionrestriction_map}->{$GE}, - propertyId => $context->{criterionproperty_map}->{'proband.trialParticipations.ecrfValues.value.stringValue'}, - floatValue => $anfonr, - }], - }); - }; - if ($@) { - _warn_or_error($context,"AnfoNr $anfonr: error searching proband: $@"); - return 0; - } - $probands //= []; - if ((scalar @$probands) == 0) { - _warn_or_error($context,"AnfoNr $anfonr: no proband found"); - return 0; - } - if ((scalar @$probands) > 1) { - _warn_or_error($context,"AnfoNr $anfonr: " . (scalar @$probands) . ' probands found, expected 1'); - return 0; - } - my $proband = $probands->[0]; - - my $listentries; - eval { - $listentries = CTSMS::BulkProcessor::RestRequests::ctsms::trial::TrialService::ProbandListEntry::get_trial_list( - $context->{ecrf_data_trial}->{id},undef,$proband->{id},1); - }; - if ($@) { - _warn_or_error($context,"AnfoNr $anfonr: error loading listentry: $@"); - return 0; - } - $listentries //= []; - if ((scalar @$listentries) != 1) { - _warn_or_error($context,"AnfoNr $anfonr: expected 1 listentry for proband $proband->{id}, got " . (scalar @$listentries)); - return 0; - } - my $listentry = $listentries->[0]; - - my $ecrf_value; - eval { - my $values = CTSMS::BulkProcessor::RestRequests::ctsms::trial::TrialService::EcrfFieldValues::get_item( - $listentry->{id},undef,$context->{lab_request_ecrffield_id},undef); - $ecrf_value = $values->{rows}->[0] if $values; - }; - if ($@) { - _warn_or_error($context,"AnfoNr $anfonr: error loading eCRF field value: $@"); - return 0; - } - unless ($ecrf_value and $ecrf_value->{ecrfField} and $ecrf_value->{ecrfField}->{ecrf}) { - _warn_or_error($context,"AnfoNr $anfonr: no eCRF field value for lab request field"); - return 0; - } - - my $source_ecrf_name = $ecrf_value->{ecrfField}->{ecrf}->{name}; - my $target_sheet_name = $source_ecrf_name . '_lab'; - my $sheet = $context->{sheets_by_name}->{$target_sheet_name}; - unless ($sheet) { - _warn_or_error($context,"AnfoNr $anfonr: no lab sheet for eCRF '$source_ecrf_name' (expected '$target_sheet_name')"); - return 0; - } - - my @out = ($proband->{id}); - foreach my $matched (@{$sheet->{matched}}) { - push(@out,trim($row->[$matched->{csv_index}] // '')); - } - - my $r = $sheet->{next_row}; - for (my $c = 0; $c < scalar @out; $c++) { - my $val = $out[$c]; - if (defined $val and length($val)) { - $sheet->{worksheet}->write_string($r,$c,$val); - } else { - $sheet->{worksheet}->write_blank($r,$c); - } - } - $sheet->{next_row} = $r + 1; - return 1; -} - -sub _warn_or_error { - my ($context,$message) = @_; - if ($context->{skip_errors}) { - $context->{warning_count} = ($context->{warning_count} // 0) + 1; - rowprocessingwarn($context->{tid},$message,getlogger(__PACKAGE__)); - } else { - $context->{error_count} = ($context->{error_count} // 0) + 1; - rowprocessingerror($context->{tid},$message,getlogger(__PACKAGE__)); - } -} - -sub _is_header_row { - my ($row) = @_; - return (trim($row->[0] // '') =~ /^AnfoNr$/i) ? 1 : 0; -} - -sub _normalize_colnames { - my ($header) = @_; - my @colnames = (); - my %seen = (); - my $last_analyte; - - foreach my $raw (@$header) { - my $name = trim($raw // ''); - $name = 'col' unless length($name); - - if ($name =~ /^(KZ[12]|VKZ)$/i and length($last_analyte)) { - $name = $last_analyte . '_' . $name; - } elsif ($name !~ /^(KZ[12]|VKZ)$/i) { - $last_analyte = $name; - } - - $name = sanitize_column_name($name); - - my $base = $name; - my $n = 1; - while (exists $seen{lc($name)}) { - $n++; - $name = $base . '_' . $n; - } - $seen{lc($name)} = 1; - push(@colnames,$name); - } - - return @colnames; -} - -1; diff --git a/CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/process.pl b/CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/process.pl index ff2c901..630e6e9 100644 --- a/CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/process.pl +++ b/CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/process.pl @@ -174,7 +174,9 @@ sub main { $result &= cleanup_task(\@messages) if taskinfo($cleanup_task_opt,\$result); } elsif (lc($convert_task_opt) eq lc($task)) { - $result &= convert_task(\@messages) if taskinfo($convert_task_opt,\$result); + $result &= convert_task(\@messages) if taskinfo($convert_task_opt,\$result, + ecrf_data_trial_id_required => 1, + ); } elsif (lc($import_ecrf_data_horizontal_task_opt) eq lc($task)) { $result &= import_ecrf_data_horizontal_task(\@messages) if taskinfo($import_ecrf_data_horizontal_task_opt,\$result, @@ -282,8 +284,9 @@ sub convert_task { my ($messages) = @_; my $result = 0; my $outfile; + my @uploaded; eval { - $outfile = convert_ecrf_data($file,$converter); + ($outfile,@uploaded) = convert_ecrf_data($file,$converter); $result = length($outfile) ? 1 : 0; if ($result) { # subsequent import_ecrf_data_horizontal uses the converted intermediate file @@ -299,6 +302,9 @@ sub convert_task { return 0; } else { push(@$messages,"- convert ok ($converter → $outfile)"); + foreach my $uploaded (@uploaded) { + push(@$messages,"- file '$uploaded->{title}' (file ID $uploaded->{id}) added to the '$uploaded->{trial}->{name}' trial"); + } return 1; } } diff --git a/CTSMS/BulkProcessor/RestRequests/ctsms/shared/ToolsService/CompleteEcrfFieldInputField.pm b/CTSMS/BulkProcessor/RestRequests/ctsms/shared/ToolsService/CompleteEcrfFieldInputField.pm new file mode 100644 index 0000000..3d94767 --- /dev/null +++ b/CTSMS/BulkProcessor/RestRequests/ctsms/shared/ToolsService/CompleteEcrfFieldInputField.pm @@ -0,0 +1,95 @@ +package CTSMS::BulkProcessor::RestRequests::ctsms::shared::ToolsService::CompleteEcrfFieldInputField; +use strict; + +## no critic + +use CTSMS::BulkProcessor::ConnectorPool qw( + get_ctsms_restapi +); + +use CTSMS::BulkProcessor::RestProcessor qw( + copy_row + get_query_string +); + +use CTSMS::BulkProcessor::RestConnectors::CtsmsRestApi qw(_get_api); +use CTSMS::BulkProcessor::RestItem qw(); + +require Exporter; +our @ISA = qw(Exporter CTSMS::BulkProcessor::RestItem); +our @EXPORT_OK = qw( + complete_ecrf_field_input_field +); + +my $default_restapi = \&get_ctsms_restapi; +my $get_complete_path_query = sub { + my ($field_name_infix, $limit) = @_; + my %params = (); + $params{fieldNameInfix} = $field_name_infix if defined $field_name_infix; + $params{limit} = $limit if defined $limit; + return 'tools/complete/ecrffieldinputfield/' . get_query_string(\%params); +}; + +my $fieldnames = [ + 'id', + 'name', + 'nameL10nKey', + 'externalId', + 'category', + 'value', + 'label', +]; + +sub new { + + my $class = shift; + my $self = CTSMS::BulkProcessor::RestItem->new($class,$fieldnames); + + copy_row($self,shift,$fieldnames); + + return $self; + +} + +sub complete_ecrf_field_input_field { + + my ($name_infix, $limit, $load_recursive,$restapi,$headers) = @_; + my $api = _get_api($restapi,$default_restapi); + return builditems_fromrows($api->get(&$get_complete_path_query($name_infix, $limit),$headers),$load_recursive,$restapi); + +} + +sub builditems_fromrows { + + my ($rows,$load_recursive,$restapi) = @_; + + my $item; + + if (defined $rows and ref $rows eq 'ARRAY') { + my @items = (); + foreach my $row (@$rows) { + $item = __PACKAGE__->new($row); + push @items,$item; + } + return \@items; + } elsif (defined $rows and ref $rows eq 'HASH') { + $item = __PACKAGE__->new($rows); + return $item; + } + return undef; + +} + +sub TO_JSON { + + my $self = shift; + my $label = $self->{label} // $self->{nameL10nKey} // $self->{name} // $self->{id}; + my $value = $self->{value} // $self->{id}; + return { + value => $value, + label => $label, + }; + +} + +1; From 8ac2d35f4b72a3964d5a3a19352eb6aa8cc5ff3a Mon Sep 17 00:00:00 2001 From: Rene Krenn Date: Thu, 30 Jul 2026 23:51:47 +0200 Subject: [PATCH 5/5] Harden convert output and converter module loading. Require a real non-empty outfile before import, and load converters by validated package name via absolute path without mutating @INC. Co-authored-by: Cursor --- CTSMS/BulkProcessor/Projects/ETL/EcrfImport.pm | 8 ++++++-- CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/process.pl | 2 +- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/CTSMS/BulkProcessor/Projects/ETL/EcrfImport.pm b/CTSMS/BulkProcessor/Projects/ETL/EcrfImport.pm index bf9a144..fb7fa2f 100644 --- a/CTSMS/BulkProcessor/Projects/ETL/EcrfImport.pm +++ b/CTSMS/BulkProcessor/Projects/ETL/EcrfImport.pm @@ -234,6 +234,8 @@ sub _load_converter { my ($spec) = @_; scripterror('converter module required (e.g. --converter=Converter::MyConverter)',getlogger(getscriptpath())) unless length($spec); + scripterror("invalid converter module name '$spec'",getlogger(getscriptpath())) + unless $spec =~ /\A[A-Za-z_][A-Za-z0-9_]*(?:::[A-Za-z_][A-Za-z0-9_]*)*\z/; # Converters live next to process.pl: EcrfImporter/Converter/*.pm my $importer_dir = Cwd::abs_path(File::Basename::dirname(__FILE__) . '/EcrfImporter'); @@ -241,10 +243,12 @@ sub _load_converter { my $module_file = $importer_dir . '/' . $rel_path . '.pm'; scripterror("converter module not found: $module_file",getlogger(getscriptpath())) unless -f $module_file; + $module_file = Cwd::abs_path($module_file); + scripterror("converter module not found: $spec",getlogger(getscriptpath())) + unless (defined $module_file and length($module_file) and -f $module_file); - unshift(@INC,$importer_dir) unless grep { $_ eq $importer_dir } @INC; eval { - require $rel_path . '.pm'; + require $module_file; 1; } or do { scripterror("failed to load converter '$spec': " . ($@ // 'unknown error'),getlogger(getscriptpath())); diff --git a/CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/process.pl b/CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/process.pl index 630e6e9..5745413 100644 --- a/CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/process.pl +++ b/CTSMS/BulkProcessor/Projects/ETL/EcrfImporter/process.pl @@ -287,7 +287,7 @@ sub convert_task { my @uploaded; eval { ($outfile,@uploaded) = convert_ecrf_data($file,$converter); - $result = length($outfile) ? 1 : 0; + $result = (length($outfile) and -f $outfile and -r $outfile and -s $outfile) ? 1 : 0; if ($result) { # subsequent import_ecrf_data_horizontal uses the converted intermediate file $file = $outfile;