• Files
• Commits
• Log
• Graph
• Stats

# initialises all tables used by previous_cml_monitoring query (requests,
# patient_case, request_initial_screen, screens, request_result_summaries,
# lab_sections)

use WWW::Mechanize::TreeBuilder; # look_down()
use HTML::TreeBuilder::XPath; # findnodes()
use Test::WWW::Mechanize;
use LWP::Protocol::PSGI;
use Test::More;
use Test::Deep;

use Data::Printer alias => 'ddp';

use RequestForm::Test;
use RequestForm;

my $psgi_app = RequestForm::runner()->psgi_app;
LWP::Protocol::PSGI->register($psgi_app);

my $mech = Test::WWW::Mechanize->new;
WWW::Mechanize::TreeBuilder->meta->apply($mech);

my $args = form_tokens(); # warn $args;
my $addr = 'http://localhost/bcr-abl';

my $config = YAML::Tiny->read( 'config.yml' ) or die $!; # ddp $config;
my $required_fields = $config->[0]->{validation}->{required}; # ddp $required_fields;

my $src = patient_data(); # ddp $src;
my $cml_patient = $src->[2]; # ddp $cml_patient;

my $today = DateTime->today();

my $dbix = get_dbix();
run_schema(); # exit;

# initialise session with form tokens:
$mech->get_ok($addr . '?' . $args);                       # print_output($mech);
$mech->text_contains(
    'request for RQ-PCR BCR-ABL estimation',
    'OK: BCR-ABL request form loaded'
);

$mech->field(nhs_number => $cml_patient->{nhs_number});
$mech->submit_form();                                     # print_output($mech);
{
    $mech->text_contains(
        'Matching patient details found',
        'OK: nhs number submitted, matching details found',
    );
    # check loaded fields:
    my %formatted = (
        nhs_number => $cml_patient->{nhs_number},
        last_name  => uc $cml_patient->{last_name},
        first_name => $cml_patient->{first_name},
        previous   => $cml_patient->{previous},
        gender     => $cml_patient->{gender},
        day        => $cml_patient->{day},
        month      => $cml_patient->{month},
        year       => $cml_patient->{year},
    );

    while ( my ($key, $val) = each %formatted ) {
        is( $mech->field($key), $val, "OK: $key field set" );
    }

    $mech->text_contains(
        'Previous BCR-ABL results ',
        'OK: previous BCR-ABL results retrieved',
    );

    $mech->text_contains(
        'Last result < 90 days ago',
        'OK: last result within minimum time required',
    );

    $mech->text_contains(
        'Reason for request',
        'OK: reason for request required',
    );
}
{ # submit cml form (without reason):
    my $reason = $cml_patient->{reason};
    delete $cml_patient->{reason};

    $mech->submit_form(fields => $cml_patient);           # print_output($mech);

    $mech->text_contains(
        'Form validation failed',
        'OK: form validation failed',
    ); # warn $mech->text;

    $mech->text_contains( # can't localise 'Missing' div tag to reason - use text_contains
        'Reason for request Missing',
        'OK: missing field identified',
    );

    # recreate reason for request:
    $cml_patient->{reason} = $reason;
    $mech->submit_form(fields => $cml_patient);           # print_output($mech);
    $mech->has_tag_like(
        p => qr/Form passed validation/,
        'OK: validation passed',
    );

    # put _skip_pds back in (not retained in form):
    $mech->field( _skip_pds => 1 );
    # submit form to generate pdf (or HTML for non-deployment env):
    $mech->submit_form();                                 # print_output($mech);

    $mech->has_tag_like(
        h3 => 'BCR-ABL Monitoring Request Form',
        'OK: request form title field',
    );

    ok( # barcode class table:
       $mech->look_down(_tag => 'table', class => 'hbc'), # table class="hbc"
       'OK: has barcode table element',
    );

    { # look for unique ref (eg 1428054818SILVERO):
        my $ref = uc( $cml_patient->{last_name}
            . substr($cml_patient->{first_name}, 0, 1) ); # ddp $ref;
        $mech->has_tag_like(
            td => qr/\d+$ref/,
            'OK: unique ref id found',
        );
    }
    # look for each required field (except special format fields):
    for my $field (@$required_fields) { # warn Dumper [$field, $cml_patient->{$field}]; # next;
        # defer testing fields with special formatting (tested below):
        next if grep $field eq $_, # location_id not present at pdf generation stage:
            qw(last_name nhs_number day month year location_id treatment);
        $mech->has_tag( span => $cml_patient->{$field}, "OK: $field field found" );
    }

    { # look for special format fields (dob, last_name, nhs_number) & cml_specific:
        my $nhs_number = join ' ', # amazingly, this works:
            ( $cml_patient->{nhs_number} =~ /(\d{3})(\d{3})(\d{4})/ ); # ddp $nhs_number;
        my $current_treament = sprintf '%s %s commenced %s',
            @{ $cml_patient }{ qw(line_number treatment first_line_date) };
        my $last_name = uc $cml_patient->{last_name};
        my $dob = sprintf '%02d-%02d-%s', @{$cml_patient}{ qw(day month year) };

        my %pre_formatted = (
            diagnosis_date  => $cml_patient->{diagnosis_date},
            nhs_number      => $nhs_number,
            last_name       => $last_name,
            treatment       => $current_treament,
            reason          => $cml_patient->{reason},
            phase           => $cml_patient->{phase},
            dob             => $dob,
        );
        while ( my ($key, $val) = each %pre_formatted ) {
            $mech->has_tag( span => $val, "OK: $key field found" );
        }
    }

    { # compare content of request_form table with cml_patient data:
        my $data = $dbix->select('request_form', '*')->hash; # ddp $data;
        # delete keys not expected in cmp_patient data:
        delete $data->{$_} for qw(id pds_code user_id created imported);
        # get cols from request_form table:
        my $cols = RequestForm::DB->new(dbname => 'test')
            ->get_cols('request_form'); # ddp $cols;

        my %ref; # create new ref data stucture from cml_patient data:
        $ref{$_} = $cml_patient->{$_} for grep $cml_patient->{$_}, @$cols;
        my %dob = map +($_ => $cml_patient->{$_}), qw(year month day);
        $ref{dob} = DateTime->new(%dob)->datetime;
        $ref{last_name} = uc $ref{last_name}; # ddp %ref;
        is_deeply( $data, \%ref, 'OK: request_form data matches patient data' );
    }
    { # compare content of patient_bcr_abl table with cml_patient data:
        my $tbl = $dbix->select('patient_bcr_abl', '*')->hash; # ddp $tbl;
        my $src = clone($cml_patient); # ddp $src;

        for ( qw/diagnosis_date first_line_date/ ) { # warn $src->{$date};
            my $dt = _to_datetime_using_datecalc($src->{$_}); # warn $dt;
            $src->{$_} = $dt->ymd('-');
        } # ddp $src;
        delete $tbl->{timestamp}; # not in $cml_patient
        cmp_deeply( $src, superhashof($tbl), 'OK: db data is superhashof patient');
    }
}
{ # change treatment details to 2nd line and phase to acute:
    my $data = clone($cml_patient);
    $data->{phase} = 'acute phase';
    $data->{line_number} = '2nd line';
    $data->{treatment_date} = '10/06/2012'; # for non-1st-line tx

    $mech->get_ok($addr);                                 # print_output($mech);
    $mech->field(nhs_number => $data->{nhs_number});
    $mech->submit_form();                                 # print_output($mech);

    # check first_line_date & diagnosis_date fields set (picked up from db table):
    is( $mech->field($_), $data->{$_}, "OK: $_ data retrieved" ) for
        qw(first_line_date diagnosis_date);

    # '** check this is correct **' - expect 4 instances of '*' for each date entry
    # is( $mech->text =~ y/*/*/, 8, "OK: 'check this' flags set" ); # y/// same as tr///
    { # same thing using HTML::TreeBuilder::XPath::findnodes():
        my @nodes = $mech->tree->findnodes( q!//div[@class='dfv-err']! ); # ddp @nodes;
        my $phrase = '** check this is correct **';
        # have 1 div with same classname (id=nhsno_result) but empty, so $_->content
        # undef so use empty arrayref, in scalar context will get array count:
        my $count = grep { ($_->content || [''])->[0] eq $phrase } @nodes; # ddp $count;
        is( $count, 2, "OK: 'check this' flags set" );
    }
    $mech->submit_form(fields => $data);                  # print_output($mech);
    $mech->has_tag_like(
        p => qr/Form passed validation/,
        'OK: validation passed',
    );

    # put _skip_pds back in (not retained in form):
    $mech->field( _skip_pds => 1 );
    # submit form to generate pdf (or HTML for non-deployment env):
    $mech->submit_form();                                 # print_output($mech);

    { # just check for fields changed from original 1st line treatment submission:
        my $current_treament = sprintf '%s %s commenced %s',
            @{ $data }{ qw(line_number treatment treatment_date) };

        my %fields = (
            diagnosis_date  => $data->{diagnosis_date},
            treatment       => $current_treament,
            phase           => $data->{phase},
        );
        while ( my ($key, $val) = each %fields ) {
            $mech->has_tag( span => $val, "OK: $key field found" );
        }
    }

    { # compare content of patient_bcr_abl table with cml_patient data:
        my $tbl = $dbix->select('patient_bcr_abl', '*')->hash; # ddp $tbl;
        my $src = clone($data); # ddp $src;

        for ( qw/diagnosis_date first_line_date/ ) { # warn $src->{$_};
            my $dt = _to_datetime_using_datecalc($src->{$_}); # warn $dt;
            $src->{$_} = $dt->ymd('-');
        } # ddp $src;
        delete $tbl->{timestamp}; # not in $cml_patient
        cmp_deeply( $src, superhashof($tbl), 'OK: db data is superhashof patient');
    }
}

done_testing(51);

#===============================================================================
sub run_schema {
    my @schema = _schema();
    do { $dbix->dbh->do($_) || die $dbix->error } foreach @schema; # $dbix->error doesn't work here
    { # initialise patients table with patient #3 from patients.conf:
        my $info = $dbix->query("PRAGMA table_info(patients)")->hashes; # warn Dumper $info;
        my @cols = grep { $_ ne 'id' } map $_->{name}, @$info; # warn Dumper \@cols;

        my %h;
        $h{$_} = $cml_patient->{$_} for @cols; # warn Dumper \%data;
        # dob from components:
        $h{dob} = join '-', @{$cml_patient}{qw(year month day)}; # warn Dumper \%h;
        $dbix->insert('patients', \%h);
    }
    { # requests, request_initial_screen, request_result_summaries:
        my %h = (
            2 => 0.004,
            4 => 0.014,
            6 => 0.018,
            8 => 0.023,
        );

        for my $i ( reverse sort keys %h ) { # warn $i;
            $dbix->dbh->do( qq!
                INSERT INTO requests(patient_case_id, created_at)
                SELECT 1, date('now', "-$i months")! ) || die $dbix->error;

            my $ratio = $h{$i}; # eg 0.004%
            $dbix->dbh->do(
                qq!INSERT INTO request_result_summaries(lab_section_id,
                    results_summary, time)
                SELECT 1, "BCR-ABL : ABL ratio = ${ratio}%",
                    date('now', "-$i months")! ) || die $dbix->error;

            $dbix->dbh->do( q!INSERT INTO request_initial_screen(screen_id)
                VALUES(1)! ) || die $dbix->error; # doesn't need auto-increment
        }
        # my $t1 = $dbix->select('requests','*')->hashes; ddp $t1;
        # my $t2 = $dbix->select('request_initial_screen','*')->hashes; ddp $t2;
        # my $t3 = $dbix->select('request_result_summaries','*')->hashes; ddp $t3;
        # _previous_cml_monitoring() # complex query
    }


sub _schema {
    return (
        # don't need full table schemas, just enough for previous_cml_monitoring query:
        q{
            CREATE TABLE requests (
                id INTEGER PRIMARY KEY AUTOINCREMENT,
                patient_case_id INTEGER,
                created_at INTEGER
            )
        },
        q{
            CREATE TABLE patient_case (
                id INTEGER PRIMARY KEY AUTOINCREMENT,
                patient_id INTEGER
            )
        },
        q{
            INSERT INTO patient_case(patient_id) VALUES(1)
        },
        # request_initial_screen.request_id AUTOINCREMENT for sync with requests
        q{
            CREATE TABLE request_initial_screen (
                request_id INTEGER PRIMARY KEY AUTOINCREMENT,
                screen_id INTEGER
            )
        },
        q{
            CREATE TABLE screens (
                id INTEGER PRIMARY KEY AUTOINCREMENT,
                description TEXT
            )
        },
        q{
            INSERT INTO screens(description) VALUES('Follow-up CML (PB)')
        },
        # request_result_summaries.request_id AUTOINCREMENT for sync with requests
        q{
            CREATE TABLE request_result_summaries (
                request_id INTEGER PRIMARY KEY AUTOINCREMENT,
                lab_section_id INTEGER,
                results_summary TEXT,
                time TEXT
            )
        },
        q{
            CREATE TABLE lab_sections (
                id INTEGER PRIMARY KEY AUTOINCREMENT,
                section_name TEXT
            )
        },
        q{
            INSERT INTO lab_sections(section_name) VALUES('Molecular')
        },
        q{
            CREATE TABLE patient_bcr_abl (
                nhs_number INTEGER PRIMARY KEY,
                diagnosis_date TEXT,
                first_line_date TEXT,
                treatment TEXT,
                line_number TEXT,
                phase TEXT,
                timestamp TEXT
            )
        },
    );
}

sub _to_datetime_using_datecalc {
    LIMS::Local::Utils::to_datetime_using_datecalc(@_);
}

sub _previous_cml_monitoring { # check data:
    my $nhs_number = $cml_patient->{nhs_number};
    my $sql = qq!
        select date(r.created_at) as 'registered', rrs.results_summary as 'result'
        from requests r
            join ( patient_case pc join patients p on pc.patient_id = p.id )
                on r.patient_case_id = pc.id
            join ( request_initial_screen ris join screens s
                on ris.screen_id = s.id ) on ris.request_id = r.id
            join ( request_result_summaries rrs join lab_sections ls
                on rrs.lab_section_id = ls.id ) on rrs.request_id = r.id
        where s.description = 'Follow-up CML (PB)'
            and ls.section_name = 'Molecular'
            and p.nhs_number = ?
        order by r.created_at desc!;

        my $data = $dbix->query($sql, $nhs_number)->hashes; ddp $data;
    }
}