package LIMS::Controller::Ajax;
use Moose;
BEGIN { extends 'LIMS::Base'; }
with (
'LIMS::Controller::Roles::Aspell',
# 'LIMS::Controller::Roles::SearchConstraint', # enable for quick_search function
);
__PACKAGE__->meta->make_immutable(inline_constructor => 0);
use IO::All;
use Data::Dumper;
use Regexp::Common;
use LIMS::Local::Utils;
use Data::FormValidator;
use FormValidator::Simple;
use CGI::Application::Plugin::JSON ':all';
=begin # this causes problems, and doesn't work anyway - a) cannot modify
$tt_config and then hand back to $self, or get circular ref when tt_process()
called; b) deletion of WRAPPER persists across all requests until server is
restarted; c) doesn't have any effect on tt rendering anyway as the original
config at server startup is used; solution is to use [% content_only %] in all
class templates
# override base cgiapp_init, remove TT wrapper for templates:
sub cgiapp_init {
my $self = shift;
# get tt_config:
my $tt_config = $self->cfg('tt_config');
# delete wrapper option:
$tt_config->{TEMPLATE_OPTIONS}->{WRAPPER} = undef; # modification of hashref persists
# load modified tt_config (don't use $self, causes circular ref when tt_process() used)
# __PACKAGE__->tt_config( $tt_config ); # ? superfluous - $tt_config is hashref
# load cgiapp_init:
$self->SUPER::cgiapp_init; # doesn't seem to matter where this is called !!
}
=cut
# only uses dfv_msgs for errors, formatted as dfv-style in _format_as_dfv():
sub err_msg {
my $self = shift;
my $msg = shift;
return $self->messages('dfv_msgs')->{$msg};
}
# ------------------------------------------------------------------------------
# expects query string: /ajax?fname=do_ajax&args=<value>&<field_name>=<value> if
# <field_name> matches 'is_valid_' send query->vars to _validate_param(), otherwise
# to _db_lookup()
sub do_ajax : StartRunmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
# ajax query string has 3 params - fname, args & <field_name>
my $vars = $self->query->Vars; # $self->debug($vars);
# delete keys fname & args, leaving only <field_name>:
map delete $vars->{$_}, qw(fname args); # $self->debug($vars);
# if one (or more) Vars() = is_valid_*, needs validating
if ( grep $_ =~ /^is_valid_/, keys %$vars ) {
return $self->_validate_param($vars);
}
# else needs a db lookup to see if param exists:
else {
return $self->_db_lookup($vars);
}
}
# ------------------------------------------------------------------------------
sub quick_search : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
# var can be name, nhs number, lab number, dob, patient/unit number:
my $var = $self->query->param('qs');
my $search_constraints = $self->quick_search_constraints($var);
# M::Requests::find_requests needs $search_constraints to be hashref but we
# want an 'OR' search here so needs to be an arrayref for RDBO:
# my @ary = map +($_ => $data{$_}), keys %$search_constraints;
my %args = (
search_constraints => $search_constraints,
args_for_search => {}, # sort_by => 'foo', sort_order => 'bar'
); # warn Dumper \%args;
my $data = $self->model('Request')->find_requests(\%args); # warn Dumper $data;
return $self->dump_html;
}
# ------------------------------------------------------------------------------
sub get_email_addresses : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $param = $self->query->Vars(); # $self->debug($param);
my $addr = $self->model('Ajax')->get_email_addresses($param);
my $xml = $self->_format_as_xml({ type => 'email_addresses', data => $addr });
# set header type to xml:
$self->header_props(-type=>'text/xml');
return $xml;
}
# ------------------------------------------------------------------------------
sub seek_new_messages : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $tt = $self->query->param('tt'); # warn Dumper $tt;
return undef if grep $tt =~ /$_\.tt\Z/, qw(hello user_messages); # can already see them!!
my $username = $self->authen->username || return undef; # maybe not logged in
my $i = $self->model('User')->any_new_messages($username) || return undef;
return $self->tt_process('user/new_msg_alert.tt', { count => $i });
}
# ------------------------------------------------------------------------------
sub get_referral_sources : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
# string submitted from new clinician (as 'hospital') or new request (as 'location'):
my $location
= $self->query->param('location') || $self->query->param('hospital');
# hospital (optional):
my $hospital = $self->query->param('hospital') || 0;
# active only (optional):
my $active_only = $self->query->param('is_active') || 0;
return unless $location &&
length $location >= $self->cfg('settings')->{min_char_length};
my %args = (
location => $location,
active_only => $active_only,
# only want hospitals for new clinician entry
hospitals_only => $hospital,
);
my $sources = $self->model('Ajax')->get_referral_sources(\%args);
my $xml = $self->_format_as_xml({ type => 'sources', data => $sources });
# set header type to xml:
$self->header_props(-type=>'text/xml');
return $xml;
}
# ------------------------------------------------------------------------------
sub get_parent_organisations : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $vars = $self->query->Vars();
my $entry = $vars->{organisation} || $vars->{practice};
my $min_length = $self->cfg('settings')->{min_char_length};
return unless $entry && length $entry >= $min_length;
my $data = $self->model('Ajax')->get_parent_organisations($vars);
my $xml = $self->_format_as_xml({ type => 'parent_orgs', data => $data });
# set header type to xml:
$self->header_props(-type=>'text/xml');
return $xml;
}
# ------------------------------------------------------------------------------
sub get_practice_from_gp : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $gp_name = $self->query->param('name');
$gp_name =~ s/\,(\s+)?/ /g; # remove comma
return unless $gp_name && length $gp_name >= 3;
my $practices = $self->model('Ajax')->get_practice_by_practitioner($gp_name);
my $xml = $self->_format_as_xml({ type => 'practices', data => $practices });
# set header type to xml:
$self->header_props(-type=>'text/xml');
return $xml;
}
# ------------------------------------------------------------------------------
sub get_users_for_location : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $location_id = $self->query->param('location_id');
my $users = $self->model('User')->get_users_for_location_id($location_id);
return $self->tt_process('user/location_users.tt', { users => $users });
}
# ------------------------------------------------------------------------------
sub get_username : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $username = $self->query->param('username'); # warn Dumper $username;
my $o = $self->model('Ajax')->get_user_by_username($username); # warn Dumper $o;
my $xml = $self->_format_as_xml({ type => 'user', data => $o });
# set header type to xml:
$self->header_props(-type=>'text/xml');
return $xml;
}
# ------------------------------------------------------------------------------
sub get_diagnoses : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $vars = $self->query->Vars(); # warn Dumper $vars;
my $diagnoses = $self->model('Ajax')->get_diagnoses($vars); # warn Dumper $diagnoses;
my $xml = $self->_format_as_xml({ type => 'diagnoses', data => $diagnoses });
# set header type to xml:
$self->header_props(-type=>'text/xml');
return $xml;
}
# ------------------------------------------------------------------------------
sub get_clinicians : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $param = $self->query->Vars(); # $self->debug($param);
# must be integer only:
return unless $param->{source_id} && $param->{source_id} =~ /^\d+$/;
my $referrers
= $self->model('Ajax')->get_clinicians_for_source($param);
my $xml = $self->_format_as_xml({ type => 'clinicians', data => $referrers });
# set header type to xml:
$self->header_props(-type=>'text/xml');
return $xml;
}
=begin # for vialId multiple vials ---------------------------------------------
sub check_storage_vialId : Runmode { # using jQuery $.get(), plain text return OK
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $msgs = $self->messages('ajax')->{storage_vial_id}; # warn Dumper $msgs;
my $id = $self->query->param('id') || return $msgs->{empty}; # warn Dumper $id;
# multiples of 10 chars:
my $length = length $id; # warn $length % 10;
return $msgs->{length} if $length % 10; # or will throw error in model
my $vials = LIMS::Local::Utils::extract_storage_vial_ids($id); # arrayref
my %seen; # in case same vial re-scanned
for my $str(@$vials) {
# check vialID, function returns true if exists, otherwise 0:
my $i = $self->model('Validation')->has_storage_vialId($str); # warn Dumper $i;
return sprintf '%s %s', $str, $msgs->{duplicate} if $i || $seen{$str}++;
}
return 'OK';
}
=cut
# ------------------------------------------------------------------------------
sub check_storage_vialId : Runmode { # using jQuery $.get(), plain text return OK
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $msgs = $self->messages('ajax')->{storage_vial_id}; # warn Dumper $msgs;
my $id = $self->query->param('id') || return $msgs->{empty}; # warn Dumper $id;
return $msgs->{length} if length($id) != 10; # using partnum so require singlicates
# check vialID, function returns true if exists:
my $result = $self->model('Ajax')->check_storage_vialId($id); # warn Dumper $result;
return $result ? $msgs->{duplicate} : 'OK';
}
# ------------------------------------------------------------------------------
sub load_template : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
$self->query->param('template')
# TODO: this will load in iframe - might be better to just die():
|| return $self->error(q!no such query param 'template'!);
# create unique filename (username + time-based entity):
my $filename = join '.',
$self->authen->username, ( unpack "H*", pack "NS", time, $$ );
my $temp_file = join '/', $self->cfg->{tmpdir}, $filename; # warn Dumper $temp_file;
my $fh = $self->query->upload('template'); # CGI method
{ # create temp file:
my $buffer;
while ( read( $fh, $buffer, 16_384 ) ) {
io($temp_file)->append($buffer);
}
close $fh;
}
# read temp file into $contents:
my $contents = io($temp_file)->slurp;
# delete temp file:
io($temp_file)->unlink;
=begin # causes circular ref - why ?? - see local cgiapp_init() above
$self->tt_params( file_contents => $contents );
my $tt = $self->tt_process('result/template.tt');
# $self->debug($contents); $self->debug(${$tt}); # both same, so return $contents
return $tt;
=cut
return $contents;
}
# ------------------------------------------------------------------------------
sub add_word : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $word = $self->param('id'); # warn $word;
# force to lowercase if word begins with CAPS eg Myeloma:
if ( $word =~ /^[A-Z][a-z]+/ ) {
$word = lc $word;
}
my $speller = $self->speller(); # fails with errstr
my $src = $self->get_speller_tempfile($speller); # warn $src;
# my $result = (
# $speller->add_to_personal($word) &&
# $speller->save_all_word_lists
# ) ? 'OK' : $speller->errstr;
# adding word to temp dictionary for manual update now:
eval { io($src)->append($word . "\n") }; # how to get error from io() ??
my $result = $@ || 'OK';
return $self->tt_process('report/speller_update.tt', { result => $result });
}
# ------------------------------------------------------------------------------
sub check_date_valid : Runmode { # jQuery validation ajax call
my $self = shift; $self->_debug_path($self->get_current_runmode);
# key is field name, which is variable (eg start_date => 1/1/1900)
my ($v, $date) = $self->query->Vars(); # warn Dumper [$v,$date];
return LIMS::Local::Utils::check_date($date); # true if valid date
}
# ------------------------------------------------------------------------------
# jQuery validationEngine.js ajax call - returns JSON:
sub jquery_check_value : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $vars = $self->query->Vars(); # warn Dumper $vars;
my $field = $vars->{validateId}; # pack_due, first_appointment, etc
my $value = $vars->{validateValue} # will get invalid flag on empty field unless:
|| return $self->_format_json('true', $vars);
my $check_date = sub { LIMS::Local::Utils::check_date(@_) };
my $check_zip = sub { LIMS::Local::Utils::format_postcode(@_) };
my $check_any_date # add flag to check_date() to allow future dates:
= sub { LIMS::Local::Utils::check_date(@_, 1) };
my %validation_method = ( # methods must return true if valid:
return_due => $check_any_date, # allow future date
pack_due => $check_any_date,
deceased => $check_date,
diagnosis => $check_date,
palliative_care => $check_date,
first_appointment => $check_date,
post_code => $check_zip,
);
my $validator = ( $field =~ /date/ ) # assumed to be a date field
? $check_date
: $validation_method{$field}; # warn Dumper $validator;
if (! $validator) {
warn "no validation method available for field = $field"; # can't pass to form ??
return $self->_format_json('false', $vars); # persistent fail until fixed
}
my $result = &$validator($value) ? 'true' : 'false'; # method returns true if valid
# formats json return & resets header_type to text/html:
my $json = $self->_format_json($result, $vars); # warn Dumper $json;
return $json;
}
# ------------------------------------------------------------------------------
sub jquery_within_range : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $vars = $self->query->Vars(); # warn Dumper $vars;
my ($field) = $vars->{validateId} =~ /\w+?_(.*)/; # warn $vars->{validateId};
my $value = $vars->{validateValue}; # warn Dumper [$field,$value];
my $d = $self->model('HMRN')->get_defaults_and_ranges($field); # warn Dumper $d;
my $result = (
$value =~ /^$RE{num}{real}\Z/ # catches eg 2..6 - common HMRN input error !!
&& ( # value within permitted range, or equal to not done/stated defaults:
( $value >= $d->{min_value} && $value <= $d->{max_value} )
|| grep $value == $_, ($d->{not_stated}, $d->{not_done})
)
) ? 'true' : 'false';
# formats json return & resets header_type to text/html:
my $json = $self->_format_json($result, $vars); # warn Dumper $json;
return $json;
}
# ------------------------------------------------------------------------------
# jQuery validationEngine.js ajax call for 'always pass' fields - returns JSON:
sub jquery_dummy_pass : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $vars = $self->query->Vars();
return $self->_format_json('true', $vars);
}
# ------------------------------------------------------------------------------
sub _format_json {
my ($self, $result, $vars) = @_; $self->_debug_path();
my $err = $vars->{validateError}; # warn $err;
my $field = $vars->{validateId}; # warn $field;
my $json = $self->json_body({ jsonValidateReturn => [$field, $err, $result] } );
# validateEngine.js expects plain content from php, not json:
$self->header_add( type => 'text/html' ); # warn Dumper $json;
return $json;
}
# ------------------------------------------------------------------------------
sub _db_lookup {
my $self = shift; $self->_debug_path();
my $vars = shift; # $self->debug($vars);
my ($field_name, $val) = %$vars;
# create lookup table for $field_name to get class/method:
# if field_name is unique in db (eg group_detail), hash value
# is scalar (class/method), but for ambiguous field_names (eg name),
# hash value is arrayref of field_name & class/method:
my %index = (
# field_name LIMS::DB::class & ::Manager method
audit_options => [ qw(description audit_request_option) ],
consent_label => 'consent_option',
consent_name => 'consent_option',
data_type => [ qw(description lab_test_result_data_type) ],
detail => 'lab_section_status_option',
# diagnostic_category => [ qw(description diagnostic_categories) ], # plurals !!
diagnosis_change => [ qw(option_name diagnosis_change_option) ],
error_code => [ qw(code error_code) ],
# field_label => 'lab_test', # uses 3-col key so can't test
function_detail => 'user_function',
function_name => 'user_function',
group_detail => 'user_group',
group_label => 'user_group',
group_name => 'user_group',
location_name => 'user_location',
national_code => 'referrer',
new_diagnosis => [ qw(name diagnosis) ], # non-unique col name
option_label => 'additional_option',
option_name => 'additional_option',
organisation_code => 'referral_source',
parent_code => 'parent_organisation',
parent_description => [ qw(description parent_organisation) ],
ref_source_name => [ qw(display_name referral_source) ],
sample_code => 'specimen',
screen_category => [ qw(name screen_category) ], # non-unique col name
# screen_description => [ qw(description screen) ], # uses 2-col key so can't test
section_name => 'lab_section',
site_name => 'anatomical_site',
test_status_option => [ qw( description lab_test_status_option ) ],
trial_name => 'clinical_trial',
username => 'user',
);
my $class_name = $index{$field_name} # or die otherwise error msg ends up in span.ajax_error in tmpl
|| die "no field_name '$field_name' found in Ajax::do_ajax() index table";
# args for check_exists():
my %args = (
vars => $vars,
func => $class_name,
);
my $i = $self->model('Ajax')->check_exists(\%args); # DEBUG $i;
my $msg = $self->err_msg('not_unique');
return $i ? $self->_format_as_dfv($msg) : '';
}
# ------------------------------------------------------------------------------
sub _format_as_dfv {
my $self = shift; $self->_debug_path();
my $str = shift;
my $tmpl = $self->cfg->{dfv_defaults}->{msgs}->{format};
return sprintf $tmpl, $str;
}
# ------------------------------------------------------------------------------
sub _format_as_xml {
my $self = shift; $self->_debug_path();
my $args = shift; # warn Dumper $args;
my $data = $args->{data};
my $type = $args->{type};
my %h = ( # dispatch table for all param types
email_addresses => sub { $self->_format_contact_addr(@_) },
parent_orgs => sub { $self->_format_parent_orgs(@_) },
clinicians => sub { $self->_format_clinicians(@_) },
diagnoses => sub { $self->_format_diagnoses(@_) },
practices => sub { $self->_format_practices(@_) },
sources => sub { $self->_format_sources(@_) },
user => sub { $self->_format_user(@_) },
);
my @rs = $h{$type} # return error formatted as <rs> if no method found:
? $h{$type}->($data)
: _format_undef($type); # warn Dumper \@rs;
my $results =
sprintf q!<?xml version="1.0" encoding="utf-8" ?><results>%s</results>!,
( join '', @rs );
return $results;
}
# format <rs id="?" info="??">??</rs>
sub _format_rs_html { sprintf q!<rs id="%s" info="%s">%s</rs>!, @_ }
# need to escape any chars like '&' ($q->escapeHTML) or output silently fails:
sub _escape { shift->query->escapeHTML(@_) }
sub _format_undef { # in case method for $type not defined
my $type = shift;
return _format_rs_html("", "", qq!ERROR: method undefined for "$type"!);
}
sub _format_practices {
my ($self, $data) = @_;
map {
_format_rs_html(
'', # id - don't need it
'', # info - don't need it
$self->_escape( sprintf '%s, %s [%s]', @$_ ),
);
} @$data;
}
sub _format_user {
my ($self, $data) = @_;
map {
_format_rs_html(
$_->id,
$self->_escape( sprintf '%s, %s',
uc $_->last_name, ucfirst $_->first_name ),
uc $_->username,
);
} @$data;
}
sub _format_contact_addr {
my ($self, $data) = @_;
map {
_format_rs_html(
$_->address,
'', # info - don't need it
$self->_escape($_->address),
);
} @$data;
}
sub _format_parent_orgs {
my ($self, $data) = @_;
map {
_format_rs_html(
$_->id,
$_->parent_code,
$self->_escape($_->description),
);
} @$data;
}
sub _format_diagnoses {
my ($self, $data) = @_;
map {
my $icdo3 = $_->icdo3 || 'NULL';
my $category = $_->diagnostic_category->description;
_format_rs_html(
$_->id,
$self->_escape("$category [$icdo3]"),
$self->_escape($_->name),
);
} @$data;
}
sub _format_clinicians {
my ($self, $data) = @_;
my @ary = map {
_format_rs_html(
$_->referrer->national_code,
$self->_escape($_->hospital_department->display_name),
$_->referrer->name,
);
} @$data;
# add default unknown clinician code:
my $referral_type = $self->model('Referrer')->get_referral_type('clinician');
push @ary, _format_rs_html(
$referral_type->default_unknown,
'Unknown department',
'Unknown clinician',
);
return @ary;
}
sub _format_sources {
my ($self, $data) = @_;
map {
_format_rs_html(
$_->id,
$_->organisation_code,
$self->_escape($_->display_name),
);
} @$data;
}
# ------------------------------------------------------------------------------
sub _validate_param {
my $self = shift; $self->_debug_path();
my $vars = shift; # $self->debug($vars);
# unit number:
if ( $vars->{unit_number} ) {
my %data = map {
$_ => $vars->{$_};
} qw(last_name first_name unit_number);
$data{nhs_number} = $vars->{is_valid_nhsno};
$data{dob} = join '-', map $vars->{'is_valid_'.$_}, qw(year month day);
my $valid = $self->model('PatientCase')->validate_patient_case(\%data);
}
# date fields (request_date or dob):
elsif (grep $_ =~ /^is_valid_date/, keys %$vars) {
my %date; # capture is_valid_date_* params, eg is_valid_date_dob_day, etc
while ( my ($param_name, $val) = each %$vars ) {
map {
$date{$_} = $val if $param_name =~ /$_/; # eg is_valid_date_dob_year =~ /year/
} qw(day month year hour min);
} # warn Dumper \%date;
return $self->_validate_date_fields(\%date);
}
# request number:
elsif ( $vars->{is_valid_request_no} ) {
my $constraints = $self->validate('get_request_number_constraints');
my $messages = $self->validate('get_request_number_messages');
my $field_name = 'is_valid_request_no';
my $dfv_profile = {
required => $field_name,
constraint_methods => {
$field_name => $constraints,
},
msgs => $messages,
};
my $result = $self->_dfv_check($dfv_profile);
return $result;
}
# specimen:
elsif ( $vars->{is_valid_specimen} ) {
my $constraints = $self->validate('get_specimen_constraints');
my $field_name = 'is_valid_specimen';
my $dfv_profile = {
required => $field_name,
constraint_methods => {
$field_name => $constraints,
},
}; # warn Dumper $dfv_profile;
my $result = $self->_dfv_check($dfv_profile);
return $result;
}
# post_code:
elsif ( my $post_code = $vars->{is_valid_post_code} ) {
my $ok = LIMS::Local::Utils::format_postcode( $post_code );
my $msg = $self->err_msg('invalid_entry');
return ! $ok ? $self->_format_as_dfv($msg) : 'OK';
}
# nhs number:
elsif ( defined $vars->{is_valid_nhsno} ) {
my $result = $self->_check_nhs_number('is_valid_nhsno'); # DFV object
my $data = $result->valid;
if ( $result->has_invalid ) {
my $msg = $self->err_msg('invalid_entry');
return $self->_format_as_dfv($msg);
}
# test for a value in case null value sent after clearing previous content:
return $data->{is_valid_nhsno} ? 'OK' : undef;
}
# nhs number unique (and valid):
elsif ( defined $vars->{is_valid_and_unique_nhsno} ) {
my $field_name = 'is_valid_and_unique_nhsno';
my $result = $self->_check_nhs_number($field_name); # DFV object
if ( $result->has_invalid ) { # don't try check_patient_nhs_number_count()
my $msg = $self->err_msg('invalid_entry');
return $self->_format_as_dfv($msg);
}
my $data = $result->valid; # warn Dumper $data;
# test for a value in case null value sent after clearing previous content:
my $nhs_number = $data->{$field_name} || return undef;
# returns true value if already exists:
my $nhs_number_exists = $self->model('Patient')
->check_patient_nhs_number_count($nhs_number);
if ( $nhs_number_exists ) {
my $msg = $self->err_msg('not_unique');
return $self->_format_as_dfv($msg);
}
return 'OK'; # all OK
}
# no idea what to do with it:
else {
return 'unknown input';
}
}
# ------------------------------------------------------------------------------
sub _check_nhs_number {
my ($self, $field_name) = @_;
my $constraints = $self->validate('check_nhsno_is_valid');
my $dfv_profile = {
required => $field_name,
field_filters => {
$field_name => 'digit', # remove spaces & non-digits
},
constraint_methods => {
$field_name => $constraints,
},
};
my $dfv = $self->_data_formvalidator($dfv_profile); # warn Dumper $dfv;
return $dfv;
}
# ------------------------------------------------------------------------------
sub _validate_date_fields {
my $self = shift; $self->_debug_path();
my $date = shift; # hashref of year, month, day
return if grep $date->{$_} =~ /(dd|mm|yyyy)/, qw(year month day); # JQuery watermark
# return 'dd-mm-yyyy' if grep ! $date->{$_}, qw(year month day); # require all 3
{ # force $date{min} && $date{hour} to undef unless int:
no warnings 'uninitialized'; # hr & min may not always be passed
map { $date->{$_} = undef unless $date->{$_} =~ /\d+/ } qw(min hour);
} # warn Dumper $date;
{ # require 4-digit year:
my $msg = $self->err_msg('year_digits'); # check for \d{4}, not length here:
return $self->_format_as_dfv($msg) if $date->{year} !~ /\d{4}/; # maxlength 4 in tt
}
{ # check date is valid:
my $result = FormValidator::Simple->check(
$date => [
{ datetime => [ qw(year month day hour min) ] } => ['DATETIME'],
]
); # warn Dumper $result;
if ($result->has_error) {
my $err = ( grep $date->{$_}, qw/hour min/ )
? 'invalid_datetime' : 'invalid_date'; # warn $err;
my $msg = $self->err_msg($err);
return $self->_format_as_dfv($msg);
}
}
{ # OK, now test for date in future, or date > 100 yrs ago:
my $dt = LIMS::Local::Utils::to_datetime($date); # warn Dumper $dt->datetime;
if ( $dt > LIMS::Local::Utils::today() ) { # future
return $self->err_msg('future_date');
}
elsif ( LIMS::Local::Utils::this_year() - $dt->year > 100 ) { # old !!
return $self->err_msg('centurian');
}
}
# data is OK:
return 'OK';
}
# ------------------------------------------------------------------------------
# uses Data::FormValidator::check directly:
sub _data_formvalidator {
my ($self, $profile) = @_; $self->_debug_path();
my $dfv_defaults = $self->cfg('dfv_defaults');
my $dfv = Data::FormValidator->new({}, $dfv_defaults)
->check($self->query, $profile); # $self->debug($dfv->msgs);
return $dfv;
}
# ------------------------------------------------------------------------------
# uses Data::FormValidator::check directly:
sub _dfv_check {
my ($self, $profile) = @_; $self->_debug_path();
my $field_name = $profile->{required};
my $dfv = $self->_data_formvalidator($profile); # $self->debug($dfv);
return $dfv->has_invalid ? $dfv->msgs->{'error_'.$field_name} : 'OK';
}
=begin # done in Request controller now:
# ------------------------------------------------------------------------------
sub get_practitioners {
my %args = (
object_class => 'GeneralPractitioner',
args_for_search => {
query => [
practice_code => $location->organisation_code,
name => { like => $self->query->param('referrer_name') . '%'},
],
sort_by => 'name',
},
);
my $referrers = $self->model('Base')->get_objects(\%args);
@rs = map {
sprintf q!<rs id="%s" info="%s">%s</rs>!,
$_->national_code,
$_->practice_code,
$_->name,
} @$referrers;
push @rs, q!<rs id="G9999998" info="">[ Unlisted GP ]</rs>!;
}
}
=cut
=begin
# ------------------------------------------------------------------------------
sub _get_referrers : Runmode {
my $self = shift;
my $source_id = $self->query->param('source_id');
# must be integer only:
return unless $source_id && $source_id =~ /^\d+$/;
my $location = $self->model('ReferralSource')->get_referral_source($source_id);
my %args;
if ( $location->location_type eq 'hospital' ) {
my @organisation_code_chars = split '', $location->organisation_code;
# take 1st 3 chars:
my $region_prefix = join '', @organisation_code_chars[0..2];
$args{args_for_search} = {
query => [ region_prefix => { like => $region_prefix . '%' } ],
with_objects => [ qw(clinician hospital_department) ],
sort_by => [ qw(clinician.surname clinician.initials) ],
};
$args{object_class} = 'ClinicianOrganisation';
}
else {
$args{args_for_search} = {
query => [ practice_code => $location->organisation_code ],
sort_by => 'name',
};
$args{object_class} = 'GeneralPractitioner';
}
my $referrers = $self->model('Base')->get_objects(\%args);
my $tmpl = $args{object_class} eq 'ClinicianOrganisation' ?
'clinicians_list' : 'practitioners_list';
$self->tt_process('referrer/'.$tmpl.'.tt', { referrers => $referrers });
}
=cut
1;
