You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
2536 lines
81 KiB
2536 lines
81 KiB
4 months ago
|
#!/usr/bin/perl
|
||
|
|
#
|
||
|
|
# Source File: likert_wall_107.pl
|
||
|
|
#
|
||
|
|
|
||
|
|
# Get config
|
||
|
|
require 'sitecfg.pl';
|
||
|
|
require 'testlib.pl';
|
||
|
|
require 'tstatlib.pl';
|
||
|
|
require 'questionslib.pl';
|
||
|
|
use Data::Dumper;
|
||
|
|
require bargraph_multi ;
|
||
|
|
|
||
|
|
# use strict;
|
||
|
|
# use warnings ;
|
||
|
|
# use diagnostics ;
|
||
|
|
use vars qw(%FORM %SESSION %CLIENT %TEST_SESSION %SUBTEST_QUESTIONS %TEST
|
||
|
|
%SUBTEST_SUMMARY %CANDIDATE %SUBTEST_ANSWERS %SYSTEM %REPORT %GRPFIELD
|
||
|
|
%SUBTEST_RESPONSES @xlatphrase);
|
||
|
|
use vars qw($testcomplete $cgiroot $pathsep $dataroot @rptparams );
|
||
|
|
use vars qw($testinprog $testpending) ;
|
||
|
|
use vars qw($QUESTIONS_AH $QUESTIONS_AG) ;
|
||
|
|
use vars qw($urlroot) ;
|
||
|
|
use vars qw($FULL_HISTORY) ;
|
||
|
|
|
||
|
|
|
||
|
|
my ($last_index, $HBI_Debug) ;
|
||
|
|
$HBI_Debug = 1 ; # Controls output of Debugging Data.
|
||
|
|
my $HBI_Debug_Sample_Numbers = 0 ;
|
||
|
|
$FORM{'frm'}="";
|
||
|
|
|
||
|
|
my %Month_Full =
|
||
|
|
("Jan" => "January", "Feb" => "February", "Mar" => "March",
|
||
|
|
"Apr" => "April", "May" => "May", "Jun" => "June",
|
||
|
|
"Jul" => "July", "Aug" => "August", "Sep" => "September",
|
||
|
|
"Oct" => "October", "Nov" => "November", "Dec" => "December") ;
|
||
|
|
|
||
|
|
&app_initialize;
|
||
|
|
|
||
|
|
if ($HBI_Debug) {warn "INFO: " . __FILE__ . " running frm IS $FORM{'frm'} " ;}
|
||
|
|
|
||
|
|
# Frames
|
||
|
|
# Row-Col-Name -frm- Description and new data field(s)
|
||
|
|
# * - * - - 0 - Display blank frame.
|
||
|
|
# 1 - 1 - rptindx003 - 1 - Pick Candidate - FORM{'cndid'}
|
||
|
|
# 2 - 1 - rpttidx003 - 2 - Pick first Test ID - FORM{'tstid', 'multiple'}
|
||
|
|
# 2 - 2 - rptdtl003 - 3 - Pick Execution date of first test - ?
|
||
|
|
# 3 - 1 - rpttidx004 - 4 - Pick follow up Test ID - ?
|
||
|
|
# 3 - 2 - rptdtl004 - 5 - Pick Execution date of follow up test - ?
|
||
|
|
# X - X - XXXXXXXXX - 6 - Print Automated Report - None
|
||
|
|
|
||
|
|
# frm == 6 code will print all Content info,
|
||
|
|
# and pick its own content type.
|
||
|
|
unless ($FORM{'frm'} == '6') {
|
||
|
|
print "Content-Type: text/html\n\n";
|
||
|
|
$bDisplay = 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
# LIKERT Scale Test Reports by Candidate
|
||
|
|
if (&get_session($FORM{'tid'})) {
|
||
|
|
&LanguageSupportInit();
|
||
|
|
$REPORT{'rptid'}="";
|
||
|
|
@rptdefs = &get_data("reports.$SESSION{'clid'}");
|
||
|
|
@lbls = split(/&/, $rptdefs[0]);
|
||
|
|
my $i ;
|
||
|
|
foreach $rptdef (@rptdefs) {
|
||
|
|
chomp ($rptdef);
|
||
|
|
@flds = split(/&/, $rptdef);
|
||
|
|
if ($flds[0] eq $FORM{'rptno'}) {
|
||
|
|
for $i (0 .. $#lbls) {
|
||
|
|
$REPORT{$lbls[$i]} = $flds[$i];
|
||
|
|
$i++;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if ($FORM{'frm'} == '1') {
|
||
|
|
&show_index_candidates;
|
||
|
|
} elsif ($FORM{'frm'} == '2') {
|
||
|
|
&show_index_tests;
|
||
|
|
} elsif ($FORM{'frm'} == '3') {
|
||
|
|
&show_filter_options;
|
||
|
|
} elsif ($FORM{'frm'} == '4') {
|
||
|
|
&show_2nd_index_tests ;
|
||
|
|
} elsif ($FORM{'frm'} == '5') {
|
||
|
|
&show_2nd_filter_options;
|
||
|
|
} elsif ($FORM{'frm'} == '6') {
|
||
|
|
&show_detail;
|
||
|
|
} else {
|
||
|
|
print "<HTML>\n";
|
||
|
|
# Most likely, this is frm == 0
|
||
|
|
print "<HEAD></HEAD>\n";
|
||
|
|
print "<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\"
|
||
|
|
TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\"
|
||
|
|
VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\">
|
||
|
|
</BODY>\n";
|
||
|
|
print "</HTML>\n";
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
warn __FILE__ . " running without a SESSION." ;
|
||
|
|
&show_illegal_access_warning() ;
|
||
|
|
}
|
||
|
|
|
||
|
|
# ($FORM{'frm'} == '1')
|
||
|
|
sub show_index_candidates {
|
||
|
|
# This shows all of the candidates, even if they have not completed a relevant test.
|
||
|
|
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Exec Report $FORM{'rptno'}");
|
||
|
|
&get_client_profile($SESSION{'clid'});
|
||
|
|
|
||
|
|
print "<HTML>
|
||
|
|
<HEAD>
|
||
|
|
<TITLE>$REPORT{'rptid'} - $REPORT{'rptdesc'}</TITLE>
|
||
|
|
<SCRIPT language=\"JavaScript\">
|
||
|
|
<!--
|
||
|
|
window.onload=onWdwLoad;
|
||
|
|
function onWdwLoad() {
|
||
|
|
document.rptform1.cndnamesort.selectedIndex = -1;
|
||
|
|
document.rptform1.cndidsort.selectedIndex = -1;
|
||
|
|
}
|
||
|
|
function right(e) {
|
||
|
|
if (navigator.appName == 'Netscape' && (e.which == 3 || e.which == 2)) {
|
||
|
|
alert(\"$xlatphrase[473]\");
|
||
|
|
return false;
|
||
|
|
} else {
|
||
|
|
if (navigator.appName == 'Microsoft Internet Explorer' && (event.button == 2 || event.button == 3)) {
|
||
|
|
alert(\"$xlatphrase[473]\");
|
||
|
|
return false;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return true;
|
||
|
|
}
|
||
|
|
function nameSelect(f) {
|
||
|
|
var w=top.detail.rptdtl003.document.location;
|
||
|
|
f.cndidsort.selectedIndex = -1;
|
||
|
|
if (f.cndnamesort.selectedIndex != -1) {
|
||
|
|
w.replace(\"$urlroot/likert_wall_107.pl?lang=$SESSION{'lang'}&tid=$SESSION{'tid'}&frm=0\");
|
||
|
|
i=f.cndnamesort.selectedIndex;
|
||
|
|
f.cndid.value=f.cndnamesort.options[i].value;
|
||
|
|
f.submit();
|
||
|
|
return true;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
function idSelect(f) {
|
||
|
|
var w=top.detail.rptdtl003.document.location;
|
||
|
|
f.cndnamesort.selectedIndex = -1;
|
||
|
|
if (f.cndidsort.selectedIndex != -1) {
|
||
|
|
w.replace(\"$urlroot/likert_wall_107.pl?lang=$SESSION{'lang'}&tid=$SESSION{'tid'}&frm=0\");
|
||
|
|
i=f.cndidsort.selectedIndex;
|
||
|
|
f.cndid.value=f.cndidsort.options[i].value;
|
||
|
|
f.submit();
|
||
|
|
return true;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
document.onmousedown=right;
|
||
|
|
document.onmouseup=right;
|
||
|
|
if (document.layers) window.captureEvents(Event.MOUSEDOWN);
|
||
|
|
if (document.layers) window.captureEvents(Event.MOUSEUP);
|
||
|
|
window.onmousedown=right;
|
||
|
|
window.onmouseup=right;
|
||
|
|
// -->
|
||
|
|
</SCRIPT>
|
||
|
|
</HEAD>
|
||
|
|
<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\"
|
||
|
|
TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\"
|
||
|
|
VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\">
|
||
|
|
<FORM name=\"rptform1\" action=\"$cgiroot/likert_wall_107.pl\" METHOD=GET target=\"rpttidx003\">
|
||
|
|
<CENTER>
|
||
|
|
<TABLE cellpadding=0 cellspacing=0 border=0 width=100\%>
|
||
|
|
<input type=hidden name=\"tid\" value=\"$SESSION{'tid'}\">
|
||
|
|
<input type=hidden name=\"frm\" value=\"2\">
|
||
|
|
<input type=hidden name=\"rptno\" value=\"$FORM{'rptno'}\">
|
||
|
|
<input type=hidden name=\"cndid\" value=\"\">
|
||
|
|
<TR>
|
||
|
|
<TD ALIGN=\"center\">
|
||
|
|
<nobr>
|
||
|
|
<FONT COLOR=\"$SYSTEM{'HEADERCOLOR'}\">
|
||
|
|
<B>$REPORT{'rptid'} - $REPORT{'rptdesc'}</B><BR>
|
||
|
|
</FONT>
|
||
|
|
";
|
||
|
|
|
||
|
|
my @clrecs = &get_client_cnd_list($CLIENT{'clid'});
|
||
|
|
my @clnamesort=();
|
||
|
|
my @clidsort=();
|
||
|
|
my $namesort;
|
||
|
|
my $idsort;
|
||
|
|
my $mycreator;
|
||
|
|
my $imaregistrar = &get_a_key("cnd.$SESSION{'clid'}", $SESSION{'uid'}, "registrar");
|
||
|
|
for (1 .. $#clrecs) {
|
||
|
|
$clrecs[$_] =~ s/\n//g;
|
||
|
|
@cndrecs = split(/&/, $clrecs[$_]);
|
||
|
|
my $id = $cndrecs[0];
|
||
|
|
my $nmf = $cndrecs[3];
|
||
|
|
my $nmm = $cndrecs[4];
|
||
|
|
my $nml = $cndrecs[5];
|
||
|
|
$mycreator = $cndrecs[15];
|
||
|
|
|
||
|
|
unless (($id eq '') || ($nml eq '')) {
|
||
|
|
$namesort=join('&',$nml,$nmf,$nmm,$id);
|
||
|
|
if ($imaregistrar eq 'Y') {
|
||
|
|
if ($SESSION{'uid'} eq $mycreator) {
|
||
|
|
push @clnamesort, $namesort;
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
push @clnamesort, $namesort;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
@clrecs = sort @clnamesort;
|
||
|
|
@clnamesort=();
|
||
|
|
print "Name:<SELECT name=\"cndnamesort\" onChange=\"return nameSelect(this.form)\">\n";
|
||
|
|
print "<OPTION value=\"-1\"> </OPTION>\n";
|
||
|
|
for (0 .. $#clrecs) {
|
||
|
|
($nml, $nmf, $nmm, $id) = split(/&/, $clrecs[$_]);
|
||
|
|
$idsort=join('&',$id,$nml,$nmf,$nmm);
|
||
|
|
push @clidsort, $idsort;
|
||
|
|
print "<OPTION value=\"$id\">$nml, $nmf $nmm ($id)</OPTION>\n";
|
||
|
|
}
|
||
|
|
print "</SELECT>\n";
|
||
|
|
@clrecs = sort @clidsort;
|
||
|
|
@clidsort=();
|
||
|
|
print "\ ID:<SELECT name=\"cndidsort\" onChange=\"return idSelect(this.form)\">\n";
|
||
|
|
print "<OPTION value=\"-1\"> </OPTION>\n";
|
||
|
|
for (0 .. $#clrecs) {
|
||
|
|
($id,$nml,$nmf,$nmm) = split(/&/, $clrecs[$_]);
|
||
|
|
print "<OPTION value=\"$id\">$id - $nml, $nmf $nmm\n";
|
||
|
|
}
|
||
|
|
print "</SELECT>\n";
|
||
|
|
@clrecs=();
|
||
|
|
print "</nobr>
|
||
|
|
</TD>
|
||
|
|
</TR>
|
||
|
|
</TABLE>
|
||
|
|
</FORM>
|
||
|
|
</CENTER>
|
||
|
|
</BODY>
|
||
|
|
</HTML>
|
||
|
|
";
|
||
|
|
}
|
||
|
|
|
||
|
|
# ($FORM{'frm'} == '2')
|
||
|
|
sub show_index_tests {
|
||
|
|
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Exec Report $FORM{'rptno'}");
|
||
|
|
&get_client_profile($SESSION{'clid'});
|
||
|
|
&get_candidate_profile( $SESSION{'clid'}, $FORM{'cndid'});
|
||
|
|
|
||
|
|
my $style = "SELECT {\"width: 200px;height: 200px;font-size: 8pt;\"}";
|
||
|
|
print "<HTML>
|
||
|
|
<HEAD>
|
||
|
|
<TITLE>$REPORT{'rptid'} - $REPORT{'rptdesc'}</TITLE>
|
||
|
|
<SCRIPT language=\"JavaScript\">
|
||
|
|
<!--
|
||
|
|
window.onload=onWdwLoad;
|
||
|
|
function onWdwLoad() {
|
||
|
|
document.rptform1.tstid.selectedIndex = -1;
|
||
|
|
}
|
||
|
|
function right(e) {
|
||
|
|
if (navigator.appName == 'Netscape' && (e.which == 3 || e.which == 2)) {
|
||
|
|
alert(\"This source and all graphics are proprietary and may not be viewed or copied.\");
|
||
|
|
return false;
|
||
|
|
} else {
|
||
|
|
if (navigator.appName == 'Microsoft Internet Explorer' && (event.button == 2 || event.button == 3)) {
|
||
|
|
alert(\"This source and all graphics are proprietary and may not be viewed or copied.\");
|
||
|
|
return false;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return true;
|
||
|
|
}
|
||
|
|
function testSelect(f) {
|
||
|
|
if (f.tstsel.selectedIndex != -1) {
|
||
|
|
f.submit();
|
||
|
|
return true;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
function clearOptions(f) {
|
||
|
|
var i,s,u,c;
|
||
|
|
u=\"\";
|
||
|
|
c=0;
|
||
|
|
f.multiple.value=\"0\";
|
||
|
|
for (i=0; i < f.tstsel.options.length; i++) {
|
||
|
|
if (f.tstsel.options[i].selected) {
|
||
|
|
if (u != \"\") {
|
||
|
|
u += \",\";
|
||
|
|
f.multiple.value=\"1\";
|
||
|
|
}
|
||
|
|
u += f.tstsel.options[i].value;
|
||
|
|
c++;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
f.tstid.value=u;
|
||
|
|
if (c == 0) {
|
||
|
|
top.detail.rptdtl003.document.location.replace(\"$urlroot/likert_wall_107.pl?lang=$SESSION{'lang'}&tid=$SESSION{'tid'}&frm=0\");
|
||
|
|
return false;
|
||
|
|
} else {
|
||
|
|
f.submit();
|
||
|
|
return true;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
document.onmousedown=right;
|
||
|
|
document.onmouseup=right;
|
||
|
|
if (document.layers) window.captureEvents(Event.MOUSEDOWN);
|
||
|
|
if (document.layers) window.captureEvents(Event.MOUSEUP);
|
||
|
|
window.onmousedown=right;
|
||
|
|
window.onmouseup=right;
|
||
|
|
// -->
|
||
|
|
</SCRIPT>
|
||
|
|
</HEAD>
|
||
|
|
<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\"
|
||
|
|
TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\"
|
||
|
|
VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\">
|
||
|
|
<FORM name=\"rptform1\" action=\"$cgiroot/likert_wall_107.pl\"
|
||
|
|
METHOD=GET target=\"rptdtl003\">
|
||
|
|
<CENTER>
|
||
|
|
<TABLE cellpadding=0 cellspacing=0 border=0 width=100\%>
|
||
|
|
<input type=hidden name=\"tid\" value=\"$SESSION{'tid'}\">
|
||
|
|
<input type=hidden name=\"frm\" value=\"3\">
|
||
|
|
<input type=hidden name=\"rptno\" value=\"$FORM{'rptno'}\">
|
||
|
|
<input type=hidden name=\"cndid\" value=\"$FORM{'cndid'}\">
|
||
|
|
<input type=hidden name=\"clid\" value=\"$CLIENT{'clid'}\">
|
||
|
|
<input type=hidden name=\"tstid\" value=\"\">
|
||
|
|
<input type=hidden name=\"multiple\" value=\"0\">
|
||
|
|
<TR>
|
||
|
|
<TD ALIGN=\"center\">
|
||
|
|
<nobr>
|
||
|
|
<FONT COLOR=\"$SYSTEM{'HEADERCOLOR'}\" SIZE=2>
|
||
|
|
<B>$CANDIDATE{'nml'}, $CANDIDATE{'nmf'} $CANDIDATE{'nmm'}</B><BR>
|
||
|
|
</FONT>
|
||
|
|
<nobr>
|
||
|
|
</TD>
|
||
|
|
</TR>
|
||
|
|
<TR>
|
||
|
|
<TD ALIGN=\"center\">
|
||
|
|
";
|
||
|
|
my @trecs = &get_test_list($CLIENT{'clid'});
|
||
|
|
my @tmptrecs = ();
|
||
|
|
for (1 .. $#trecs) {
|
||
|
|
($id, $desc) = split(/&/, $trecs[$_]);
|
||
|
|
$trecs[$_] = join('&', "$desc", "$id");
|
||
|
|
push @tmptrecs, $trecs[$_];
|
||
|
|
}
|
||
|
|
@trecs = sort @tmptrecs;
|
||
|
|
print "\t\t<SELECT name=\"tstsel\" size=\"8\" Height=200 Width=200 onChange=\"return clearOptions(this.form)\">\n";
|
||
|
|
for (0 .. $#trecs) {
|
||
|
|
($desc,$id) = split(/&/, $trecs[$_]);
|
||
|
|
$testscompleted = CountHistoricTests($testcomplete,$CLIENT{'clid'},$id,$FORM{'cndid'});
|
||
|
|
if ($testscompleted == 0) {
|
||
|
|
$testscompleted = CountTestFilesByCnd($testcomplete,$CLIENT{'clid'},$id,$FORM{'cndid'});
|
||
|
|
}
|
||
|
|
$testsinprogress = CountTestFilesByCnd($testinprog, $CLIENT{'clid'},$id,$FORM{'cndid'});
|
||
|
|
$testspending = CountTestFilesByCnd($testpending, $CLIENT{'clid'},$id,$FORM{'cndid'});
|
||
|
|
if (($testsinprogress != 0) || ($testspending != 0) || ($testscompleted != 0)) {
|
||
|
|
print "\t\t\t<OPTION value=\"$id\">$testscompleted-$testsinprogress-$testspending $desc\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
print "\t\t</SELECT>
|
||
|
|
</TD>
|
||
|
|
</TR>
|
||
|
|
<TR>
|
||
|
|
<TD ALIGN=\"center\">
|
||
|
|
<FONT COLOR=\"$SYSTEM{'HEADERCOLOR'}\" SIZE=2>
|
||
|
|
<!-- Text under the list of tests taken by the candidate. -->
|
||
|
|
</FONT>
|
||
|
|
<!--
|
||
|
|
<INPUT TYPE=BUTTON name=\"show\" value=\"$xlatphrase[27]\" onClick=\"return testSelect(this.form)\">
|
||
|
|
-->
|
||
|
|
</TD>
|
||
|
|
</TR>
|
||
|
|
</TABLE>
|
||
|
|
</FORM>
|
||
|
|
</BODY>
|
||
|
|
</HTML>
|
||
|
|
";
|
||
|
|
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "3", "Exec Report $FORM{'rptno'} completed");
|
||
|
|
}
|
||
|
|
|
||
|
|
# ($FORM{'frm'} == '3')
|
||
|
|
sub show_filter_options {
|
||
|
|
my $cndid;
|
||
|
|
my $cndname;
|
||
|
|
my @testdates;
|
||
|
|
my $iopt;
|
||
|
|
my $optval;
|
||
|
|
my $optdesc;
|
||
|
|
my $lstdates;
|
||
|
|
my $qcor;
|
||
|
|
my $qinc;
|
||
|
|
my $tscore;
|
||
|
|
my $trash;
|
||
|
|
my $j;
|
||
|
|
my $i;
|
||
|
|
my @tests;
|
||
|
|
my @tmpdates;
|
||
|
|
my $jscript;
|
||
|
|
my $colspan;
|
||
|
|
|
||
|
|
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Report Options $FORM{'rptno'}");
|
||
|
|
&get_client_profile($SESSION{'clid'});
|
||
|
|
&get_candidate_profile( $SESSION{'clid'}, $FORM{'cndid'});
|
||
|
|
@tests = split(/\,/,$FORM{'tstid'});
|
||
|
|
|
||
|
|
$cndname = join('', $CANDIDATE{'nml'}, ", ", $CANDIDATE{'nmf'}, " ", $CANDIDATE{'nmm'});
|
||
|
|
$cndid = $CANDIDATE{'uid'};
|
||
|
|
$lstdates = "<SELECT name=tdatesel size=10 >\n";
|
||
|
|
$jscript="var s=new Array();\n";
|
||
|
|
if ($FORM{'multiple'} ne '1') {
|
||
|
|
&get_test_profile($CLIENT{'clid'}, $FORM{'tstid'});
|
||
|
|
$testdescriptions = "$FORM{'tstid'} - $TEST{'desc'}\<br\>";
|
||
|
|
@testdates = getHistoricTests($testcomplete,$CLIENT{'clid'},$FORM{'tstid'},$FORM{'cndid'});
|
||
|
|
for $iopt (0 .. $#testdates) {
|
||
|
|
$j=$#testdates-$iopt;
|
||
|
|
($optval,$qcor,$qinc,$tscore) = split(/&/, $testdates[$j]);
|
||
|
|
$optdesc = $optval;
|
||
|
|
$optval =~ s/ /_/g;
|
||
|
|
#$optdesc =~ s/ GMT//g;
|
||
|
|
if ($TEST{'seq'} eq 'std') {
|
||
|
|
$lstdates = join('',$lstdates,"<OPTION value=\"$optval\">$optdesc\ ($tscore)\n");
|
||
|
|
$jscript = join('',$jscript,"s[$iopt]=$tscore;\n");
|
||
|
|
} else {
|
||
|
|
$lstdates = join('',$lstdates,"<OPTION value=\"$optval\">$optdesc</OPTION>\n");
|
||
|
|
}
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
$iopt=0;
|
||
|
|
$testdescriptions = "";
|
||
|
|
for $i (0 .. $#tests) {
|
||
|
|
if ($tests[$i] ne '') {
|
||
|
|
&get_test_profile($CLIENT{'clid'}, $tests[$i]);
|
||
|
|
@tmpdates = getHistoricTests($testcomplete,$CLIENT{'clid'},$tests[$i],$FORM{'cndid'});
|
||
|
|
if ($iopt > 0) {
|
||
|
|
$testdescriptions = join(', ',$testdescriptions,"<nobr>$tests[$i] - $TEST{'desc'}</nobr>");
|
||
|
|
} else {
|
||
|
|
$testdescriptions = join('',$testdescriptions,"<nobr>$tests[$i] - $TEST{'desc'}</nobr>");
|
||
|
|
}
|
||
|
|
if ($#tmpdates != -1) {
|
||
|
|
$j=$#tmpdates;
|
||
|
|
$testdates[$iopt]=$tmpdates[$j];
|
||
|
|
($optval,$qcor,$qinc,$tscore) = split(/&/, $tmpdates[$j]);
|
||
|
|
$optdesc = $optval;
|
||
|
|
$optval =~ s/ /_/g;
|
||
|
|
$optval = join('+',$optval,$TEST{'id'});
|
||
|
|
#$optdesc =~ s/ GMT//g;
|
||
|
|
$optdesc = join(' ',$optdesc,$TEST{'id'});
|
||
|
|
if ($TEST{'seq'} eq 'std') {
|
||
|
|
$lstdates = join('',$lstdates,"<OPTION value=\"$optval\">$optdesc\ ($tscore)\n");
|
||
|
|
$jscript = join('',$jscript,"s[$iopt]=$tscore;\n");
|
||
|
|
$iopt++;
|
||
|
|
} else {
|
||
|
|
$lstdates = join('',$lstdates,"<OPTION value=\"$optval\">$optdesc\n");
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$lstdates = join('',$lstdates,"</SELECT>\n");
|
||
|
|
$styles = "SELECT {\"font-size: 8pt;\"}\n";
|
||
|
|
$styles = join('',$styles,"INPUT {\"font-size: 8pt;height: 20px;\"}\n");
|
||
|
|
print "<HTML>
|
||
|
|
<HEAD>
|
||
|
|
<TITLE>$REPORT{'rptid'} - $REPORT{'rptdesc'}</TITLE>
|
||
|
|
<SCRIPT language=\"JavaScript\">
|
||
|
|
<!--
|
||
|
|
$jscript
|
||
|
|
function wdwOnLoad() {
|
||
|
|
var f;
|
||
|
|
f=document.rptform1;
|
||
|
|
f.onsubmit=submitMe;
|
||
|
|
f.tdatesel.focus();
|
||
|
|
selall(f);
|
||
|
|
}
|
||
|
|
function submitMe() {
|
||
|
|
var f;
|
||
|
|
var bok = false;
|
||
|
|
f = document.rptform1;
|
||
|
|
f.testdates.value=\"\";
|
||
|
|
for (i=0; i < f.tdatesel.options.length; i++) {
|
||
|
|
if (f.tdatesel.options[i].selected) {
|
||
|
|
bok = true;
|
||
|
|
f.testdates.value += \",\";
|
||
|
|
f.testdates.value += f.tdatesel.options[i].value;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if (bok) {
|
||
|
|
f.testdates.value += \",\";
|
||
|
|
} else {
|
||
|
|
alert(\"You must select at least one test date.\");
|
||
|
|
f.tdatesel.focus();
|
||
|
|
}
|
||
|
|
return bok;
|
||
|
|
}
|
||
|
|
function selall(f) {
|
||
|
|
var i;
|
||
|
|
for (i=0; i < f.tdatesel.options.length; i++) {
|
||
|
|
f.tdatesel.options[i].selected = true;
|
||
|
|
}
|
||
|
|
return false;
|
||
|
|
}
|
||
|
|
function deselall(f) {
|
||
|
|
var i;
|
||
|
|
for (i=0; i < f.tdatesel.options.length; i++) {
|
||
|
|
f.tdatesel.options[i].selected = false;
|
||
|
|
}
|
||
|
|
return false;
|
||
|
|
}
|
||
|
|
function selscores(f,j) {
|
||
|
|
var i,n,h,l,nh,nl;
|
||
|
|
if (j == 11) {
|
||
|
|
n=0;
|
||
|
|
j=0;
|
||
|
|
for (i=0; i < f.tdatesel.options.length; i++) {
|
||
|
|
if (s[i] > n) {
|
||
|
|
j=i;
|
||
|
|
n=s[i];
|
||
|
|
}
|
||
|
|
}
|
||
|
|
f.tdatesel.selectedIndex=j;
|
||
|
|
} else {
|
||
|
|
selall(f);
|
||
|
|
if (j == 12) {
|
||
|
|
nl=101;
|
||
|
|
for (i=f.tdatesel.options.length-1; i >= 0; i--) {
|
||
|
|
if (s[i] < nl) {
|
||
|
|
l=i;
|
||
|
|
nl=s[i];
|
||
|
|
}
|
||
|
|
}
|
||
|
|
f.tdatesel.options[l].selected=false;
|
||
|
|
} else {
|
||
|
|
nh=0;
|
||
|
|
nl=101;
|
||
|
|
for (i=f.tdatesel.options.length-1; i >= 0; i--) {
|
||
|
|
if (s[i] > nh) {
|
||
|
|
h=i;
|
||
|
|
nh=s[i];
|
||
|
|
}
|
||
|
|
}
|
||
|
|
for (i=f.tdatesel.options.length-1; i >= 0; i--) {
|
||
|
|
if (i != h) {
|
||
|
|
if (s[i] < nl) {
|
||
|
|
l=i;
|
||
|
|
nl=s[i];
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
f.tdatesel.options[l].selected=false;
|
||
|
|
f.tdatesel.options[h].selected=false;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return false;
|
||
|
|
}
|
||
|
|
function right(e) {
|
||
|
|
if (navigator.appName == 'Netscape' && (e.which == 3 || e.which == 2)) {
|
||
|
|
alert(\"This source and all graphics are proprietary and may not be viewed or copied.\");
|
||
|
|
return false;
|
||
|
|
} else {
|
||
|
|
if (navigator.appName == 'Microsoft Internet Explorer' && (event.button == 2 || event.button == 3)) {
|
||
|
|
alert(\"This source and all graphics are proprietary and may not be viewed or copied.\");
|
||
|
|
return false;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return true;
|
||
|
|
}
|
||
|
|
document.onmousedown=right;
|
||
|
|
document.onmouseup=right;
|
||
|
|
if (document.layers) window.captureEvents(Event.MOUSEDOWN);
|
||
|
|
if (document.layers) window.captureEvents(Event.MOUSEUP);
|
||
|
|
window.onmousedown=right;
|
||
|
|
window.onmouseup=right;
|
||
|
|
window.onload=wdwOnLoad;
|
||
|
|
// -->
|
||
|
|
</SCRIPT>
|
||
|
|
</HEAD>
|
||
|
|
<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\"
|
||
|
|
TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\"
|
||
|
|
VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\">
|
||
|
|
<FORM name=\"rptform1\" action=\"$cgiroot/likert_wall_107.pl\" METHOD=GET TARGET=\"rpttidx004\">
|
||
|
|
<input type=hidden name=\"tid\" value=\"$SESSION{'tid'}\">
|
||
|
|
<input type=hidden name=\"frm\" value=\"4\">
|
||
|
|
<input type=hidden name=\"rptno\" value=\"$FORM{'rptno'}\">
|
||
|
|
<input type=hidden name=\"tstid\" value=\"$FORM{'tstid'}\">
|
||
|
|
<input type=hidden name=\"cndid\" value=\"$FORM{'cndid'}\">
|
||
|
|
<input type=hidden name=\"clid\" value=\"$FORM{'clid'}\">
|
||
|
|
<input type=hidden name=\"testdates\" value=\"\">
|
||
|
|
<input type=hidden name=\"multiple\" value=\"$FORM{'multiple'}\">
|
||
|
|
<CENTER>
|
||
|
|
<TABLE cellpadding=0 cellspacing=0 border=0 width=100\%>
|
||
|
|
<TR>
|
||
|
|
<TD ALIGN=\"left\" valign=\"top\">
|
||
|
|
<FONT COLOR=\"$SYSTEM{'HEADERCOLOR'}\" SIZE=1>
|
||
|
|
$testdescriptions
|
||
|
|
</FONT>
|
||
|
|
</TD>
|
||
|
|
</TABLE>
|
||
|
|
<TABLE cellpadding=0 cellspacing=0 border=1 width=100\%>
|
||
|
|
";
|
||
|
|
if ($TEST{'seq'} eq 'std') {
|
||
|
|
print "<TR>
|
||
|
|
<TD rowspan=4>
|
||
|
|
<TABLE cellpadding=0 cellspacing=0 border=0 width=100\%>
|
||
|
|
<TR>
|
||
|
|
<TD align=\"center\">
|
||
|
|
<FONT COLOR=\"$SYSTEM{'HEADERCOLOR'}\" SIZE=2>
|
||
|
|
$xlatphrase[687]<br>
|
||
|
|
</font>
|
||
|
|
</TD>
|
||
|
|
</TR>
|
||
|
|
<TR>
|
||
|
|
<TD align=\"center\">
|
||
|
|
<FONT SIZE=2>
|
||
|
|
$lstdates</br>
|
||
|
|
</font>
|
||
|
|
</TD>
|
||
|
|
</TR>
|
||
|
|
</TABLE>
|
||
|
|
</TD>
|
||
|
|
</TR>
|
||
|
|
";
|
||
|
|
$colspan="colspan=2";
|
||
|
|
} else {
|
||
|
|
print "<TR>
|
||
|
|
<TD>
|
||
|
|
<TABLE cellpadding=0 cellspacing=0 border=0 width=100\%>
|
||
|
|
<TR>
|
||
|
|
<TD align=\"center\">
|
||
|
|
<FONT COLOR=\"$SYSTEM{'HEADERCOLOR'}\" SIZE=2>
|
||
|
|
$xlatphrase[687]<br>
|
||
|
|
</font>
|
||
|
|
</TD>
|
||
|
|
</TR>
|
||
|
|
<TR>
|
||
|
|
<TD align=\"center\">
|
||
|
|
<FONT SIZE=2>
|
||
|
|
$lstdates</br>
|
||
|
|
</font>
|
||
|
|
</TD>
|
||
|
|
</TR>
|
||
|
|
</TABLE>
|
||
|
|
</TD>
|
||
|
|
</TR>
|
||
|
|
";
|
||
|
|
$colspan="";
|
||
|
|
}
|
||
|
|
print "<TR>
|
||
|
|
<TD $colspan ALIGN=\"center\">
|
||
|
|
<font size=2>
|
||
|
|
";
|
||
|
|
$testspending = CountTestFilesByCnd($testpending, $CLIENT{'clid'},$id,$FORM{'cndid'});
|
||
|
|
if ($testspending > 0) {
|
||
|
|
print "
|
||
|
|
Print\ \; <A HREF=\"$cgiroot/tmaster.pl?tid=$SESSION{'tid'}&clid=$CLIENT{'clid'}&cndid=$CANDIDATE{'uid'}&tstid=$TEST{'id'}\" TARGET=\"rpttidx004\">Master/Key</A>";
|
||
|
|
}
|
||
|
|
print "\ <br>
|
||
|
|
<INPUT type=\"submit\" name=\"submit\" value=\"$xlatphrase[709]\">
|
||
|
|
\ <br>
|
||
|
|
</font>
|
||
|
|
</TD>
|
||
|
|
</TR>
|
||
|
|
</TABLE>
|
||
|
|
</FORM>
|
||
|
|
</CENTER>
|
||
|
|
</BODY>
|
||
|
|
</HTML>
|
||
|
|
";
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ($FORM{'frm'} == '4')
|
||
|
|
sub show_2nd_index_tests {
|
||
|
|
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Exec Report $FORM{'rptno'}");
|
||
|
|
&get_client_profile($SESSION{'clid'});
|
||
|
|
&get_candidate_profile( $SESSION{'clid'}, $FORM{'cndid'});
|
||
|
|
|
||
|
|
my $style = "SELECT {\"width: 200px;height: 200px;font-size: 8pt;\"}";
|
||
|
|
print "<HTML>
|
||
|
|
<HEAD>
|
||
|
|
<TITLE>$REPORT{'rptid'} - $REPORT{'rptdesc'}</TITLE>
|
||
|
|
<SCRIPT language=\"JavaScript\">
|
||
|
|
<!--
|
||
|
|
window.onload=onWdwLoad;
|
||
|
|
function onWdwLoad() {
|
||
|
|
document.rptform1.tstid.selectedIndex = -1;
|
||
|
|
}
|
||
|
|
function right(e) {
|
||
|
|
if (navigator.appName == 'Netscape' && (e.which == 3 || e.which == 2)) {
|
||
|
|
alert(\"This source and all graphics are proprietary and may not be viewed or copied.\");
|
||
|
|
return false;
|
||
|
|
} else {
|
||
|
|
if (navigator.appName == 'Microsoft Internet Explorer' && (event.button == 2 || event.button == 3)) {
|
||
|
|
alert(\"This source and all graphics are proprietary and may not be viewed or copied.\");
|
||
|
|
return false;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return true;
|
||
|
|
}
|
||
|
|
function testSelect(f) {
|
||
|
|
if (f.tstsel2.selectedIndex != -1) {
|
||
|
|
f.submit();
|
||
|
|
return true;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
function clearOptions(f) {
|
||
|
|
var i,s,u,c;
|
||
|
|
u=\"\";
|
||
|
|
c=0;
|
||
|
|
f.multiple.value=\"0\";
|
||
|
|
for (i=0; i < f.tstsel2.options.length; i++) {
|
||
|
|
if (f.tstsel2.options[i].selected) {
|
||
|
|
if (u != \"\") {
|
||
|
|
u += \",\";
|
||
|
|
f.multiple.value=\"1\";
|
||
|
|
}
|
||
|
|
u += f.tstsel2.options[i].value;
|
||
|
|
c++;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
f.tstid2.value=u;
|
||
|
|
if (c == 0) {
|
||
|
|
top.detail.rptdtl004.document.location.replace(\"$urlroot/likert_wall_107.pl?lang=$SESSION{'lang'}&tid=$SESSION{'tid'}&frm=0\");
|
||
|
|
return false;
|
||
|
|
} else {
|
||
|
|
f.submit();
|
||
|
|
return true;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
document.onmousedown=right;
|
||
|
|
document.onmouseup=right;
|
||
|
|
if (document.layers) window.captureEvents(Event.MOUSEDOWN);
|
||
|
|
if (document.layers) window.captureEvents(Event.MOUSEUP);
|
||
|
|
window.onmousedown=right;
|
||
|
|
window.onmouseup=right;
|
||
|
|
// -->
|
||
|
|
</SCRIPT>
|
||
|
|
</HEAD>
|
||
|
|
<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\"
|
||
|
|
TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\"
|
||
|
|
VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\">
|
||
|
|
<FORM name=\"rptform1\" action=\"$cgiroot/likert_wall_107.pl\"
|
||
|
|
METHOD=GET target=\"rptdtl004\">
|
||
|
|
<CENTER>
|
||
|
|
<TABLE cellpadding=0 cellspacing=0 border=0 width=100\%>
|
||
|
|
<input type=hidden name=\"tid\" value=\"$SESSION{'tid'}\">
|
||
|
|
<input type=hidden name=\"frm\" value=\"5\">
|
||
|
|
<input type=hidden name=\"rptno\" value=\"$FORM{'rptno'}\">
|
||
|
|
<input type=hidden name=\"cndid\" value=\"$FORM{'cndid'}\">
|
||
|
|
<input type=hidden name=\"clid\" value=\"$CLIENT{'clid'}\">
|
||
|
|
<input type=hidden name=\"tstid\" value=\"$FORM{'tstid'}\">
|
||
|
|
<input type=hidden name=\"tdatesel\" value=\"$FORM{'tdatesel'}\">
|
||
|
|
<input type=hidden name=\"tstid2\" value=\"UNK\">
|
||
|
|
<input type=hidden name=\"multiple\" value=\"0\">
|
||
|
|
<TR>
|
||
|
|
<TD ALIGN=\"center\">
|
||
|
|
<nobr>
|
||
|
|
<FONT COLOR=\"$SYSTEM{'HEADERCOLOR'}\" SIZE=2>
|
||
|
|
<B>$CANDIDATE{'nml'}, $CANDIDATE{'nmf'} $CANDIDATE{'nmm'}</B><BR>
|
||
|
|
</FONT>
|
||
|
|
<nobr>
|
||
|
|
</TD>
|
||
|
|
</TR>
|
||
|
|
<TR>
|
||
|
|
<TD ALIGN=\"center\">
|
||
|
|
";
|
||
|
|
my @trecs = &get_test_list($CLIENT{'clid'});
|
||
|
|
my @tmptrecs = ();
|
||
|
|
for (1 .. $#trecs) {
|
||
|
|
($id, $desc) = split(/&/, $trecs[$_]);
|
||
|
|
$trecs[$_] = join('&', "$desc", "$id");
|
||
|
|
push @tmptrecs, $trecs[$_];
|
||
|
|
}
|
||
|
|
@trecs = sort @tmptrecs;
|
||
|
|
print "\t\t<SELECT name=\"tstsel2\" size=\"8\" Height=200 Width=200 onChange=\"return clearOptions(this.form)\">\n";
|
||
|
|
for (0 .. $#trecs) {
|
||
|
|
($desc,$id) = split(/&/, $trecs[$_]);
|
||
|
|
$testscompleted = CountHistoricTests($testcomplete,$CLIENT{'clid'},$id,$FORM{'cndid'});
|
||
|
|
if ($testscompleted == 0) {
|
||
|
|
$testscompleted = CountTestFilesByCnd($testcomplete,$CLIENT{'clid'},$id,$FORM{'cndid'});
|
||
|
|
}
|
||
|
|
$testsinprogress = CountTestFilesByCnd($testinprog, $CLIENT{'clid'},$id,$FORM{'cndid'});
|
||
|
|
$testspending = CountTestFilesByCnd($testpending, $CLIENT{'clid'},$id,$FORM{'cndid'});
|
||
|
|
if (($testsinprogress != 0) || ($testspending != 0) || ($testscompleted != 0)) {
|
||
|
|
print "\t\t\t<OPTION value=\"$id\">$testscompleted-$testsinprogress-$testspending $desc\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
print "\t\t</SELECT>
|
||
|
|
</TD>
|
||
|
|
</TR>
|
||
|
|
<TR>
|
||
|
|
<TD ALIGN=\"center\">
|
||
|
|
<FONT COLOR=\"$SYSTEM{'HEADERCOLOR'}\" SIZE=2>
|
||
|
|
<!-- Text under the list of tests taken by the candidate. -->
|
||
|
|
</FONT>
|
||
|
|
<!--
|
||
|
|
<INPUT TYPE=BUTTON name=\"show\" value=\"$xlatphrase[27]\" onClick=\"return testSelect(this.form)\">
|
||
|
|
-->
|
||
|
|
</TD>
|
||
|
|
</TR>
|
||
|
|
</TABLE>
|
||
|
|
</FORM>
|
||
|
|
</BODY>
|
||
|
|
</HTML>
|
||
|
|
";
|
||
|
|
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "3", "Exec Report $FORM{'rptno'} completed");
|
||
|
|
}
|
||
|
|
|
||
|
|
# ($FORM{'frm'} == '5')
|
||
|
|
sub show_2nd_filter_options {
|
||
|
|
my $cndid;
|
||
|
|
my $cndname;
|
||
|
|
my @testdates;
|
||
|
|
my $iopt;
|
||
|
|
my $optval;
|
||
|
|
my $optdesc;
|
||
|
|
my $lstdates;
|
||
|
|
my $qcor;
|
||
|
|
my $qinc;
|
||
|
|
my $tscore;
|
||
|
|
my $trash;
|
||
|
|
my $j;
|
||
|
|
my $i;
|
||
|
|
my @tests;
|
||
|
|
my @tmpdates;
|
||
|
|
my $jscript;
|
||
|
|
my $colspan;
|
||
|
|
|
||
|
|
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Report Options $FORM{'rptno'}");
|
||
|
|
&get_client_profile($SESSION{'clid'});
|
||
|
|
&get_candidate_profile( $SESSION{'clid'}, $FORM{'cndid'});
|
||
|
|
@tests = split(/\,/,$FORM{'tstid2'});
|
||
|
|
|
||
|
|
$cndname = join('', $CANDIDATE{'nml'}, ", ", $CANDIDATE{'nmf'}, " ", $CANDIDATE{'nmm'});
|
||
|
|
$cndid = $CANDIDATE{'uid'};
|
||
|
|
$lstdates = "<SELECT name=tdatesel2 size=10 >\n";
|
||
|
|
$jscript="var s=new Array();\n";
|
||
|
|
if ($FORM{'multiple'} ne '1') {
|
||
|
|
&get_test_profile($CLIENT{'clid'}, $FORM{'tstid2'});
|
||
|
|
$testdescriptions = "$FORM{'tstid2'} - $TEST{'desc'}\<br\>";
|
||
|
|
@testdates = getHistoricTests($testcomplete,$CLIENT{'clid'},$FORM{'tstid2'},$FORM{'cndid'});
|
||
|
|
for $iopt (0 .. $#testdates) {
|
||
|
|
$j=$#testdates-$iopt;
|
||
|
|
($optval,$qcor,$qinc,$tscore) = split(/&/, $testdates[$j]);
|
||
|
|
$optdesc = $optval;
|
||
|
|
$optval =~ s/ /_/g;
|
||
|
|
#$optdesc =~ s/ GMT//g;
|
||
|
|
if ($TEST{'seq'} eq 'std') {
|
||
|
|
$lstdates = join('',$lstdates,"<OPTION value=\"$optval\">$optdesc\ ($tscore)\n");
|
||
|
|
$jscript = join('',$jscript,"s[$iopt]=$tscore;\n");
|
||
|
|
} else {
|
||
|
|
$lstdates = join('',$lstdates,"<OPTION value=\"$optval\">$optdesc</OPTION>\n");
|
||
|
|
}
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
$iopt=0;
|
||
|
|
$testdescriptions = "";
|
||
|
|
for $i (0 .. $#tests) {
|
||
|
|
if ($tests[$i] ne '') {
|
||
|
|
&get_test_profile($CLIENT{'clid'}, $tests[$i]);
|
||
|
|
@tmpdates = getHistoricTests($testcomplete,$CLIENT{'clid'},$tests[$i],$FORM{'cndid'});
|
||
|
|
if ($iopt > 0) {
|
||
|
|
$testdescriptions = join(', ',$testdescriptions,"<nobr>$tests[$i] - $TEST{'desc'}</nobr>");
|
||
|
|
} else {
|
||
|
|
$testdescriptions = join('',$testdescriptions,"<nobr>$tests[$i] - $TEST{'desc'}</nobr>");
|
||
|
|
}
|
||
|
|
if ($#tmpdates != -1) {
|
||
|
|
$j=$#tmpdates;
|
||
|
|
$testdates[$iopt]=$tmpdates[$j];
|
||
|
|
($optval,$qcor,$qinc,$tscore) = split(/&/, $tmpdates[$j]);
|
||
|
|
$optdesc = $optval;
|
||
|
|
$optval =~ s/ /_/g;
|
||
|
|
$optval = join('+',$optval,$TEST{'id'});
|
||
|
|
#$optdesc =~ s/ GMT//g;
|
||
|
|
$optdesc = join(' ',$optdesc,$TEST{'id'});
|
||
|
|
if ($TEST{'seq'} eq 'std') {
|
||
|
|
$lstdates = join('',$lstdates,"<OPTION value=\"$optval\">$optdesc\ ($tscore)\n");
|
||
|
|
$jscript = join('',$jscript,"s[$iopt]=$tscore;\n");
|
||
|
|
$iopt++;
|
||
|
|
} else {
|
||
|
|
$lstdates = join('',$lstdates,"<OPTION value=\"$optval\">$optdesc\n");
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$lstdates = join('',$lstdates,"</SELECT>\n");
|
||
|
|
$styles = "SELECT {\"font-size: 8pt;\"}\n";
|
||
|
|
$styles = join('',$styles,"INPUT {\"font-size: 8pt;height: 20px;\"}\n");
|
||
|
|
print "<HTML>
|
||
|
|
<HEAD>
|
||
|
|
<TITLE>$REPORT{'rptid'} - $REPORT{'rptdesc'}</TITLE>
|
||
|
|
<SCRIPT language=\"JavaScript\">
|
||
|
|
<!--
|
||
|
|
$jscript
|
||
|
|
function wdwOnLoad() {
|
||
|
|
var f;
|
||
|
|
f=document.rptform1;
|
||
|
|
f.onsubmit=submitMe;
|
||
|
|
f.tdatesel2.focus();
|
||
|
|
selall(f);
|
||
|
|
}
|
||
|
|
function submitMe() {
|
||
|
|
var f;
|
||
|
|
var bok = false;
|
||
|
|
f = document.rptform1;
|
||
|
|
f.testdates.value=\"\";
|
||
|
|
for (i=0; i < f.tdatesel2.options.length; i++) {
|
||
|
|
if (f.tdatesel2.options[i].selected) {
|
||
|
|
bok = true;
|
||
|
|
f.testdates.value += \",\";
|
||
|
|
f.testdates.value += f.tdatesel2.options[i].value;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if (bok) {
|
||
|
|
f.testdates.value += \",\";
|
||
|
|
} else {
|
||
|
|
alert(\"You must select at least one test date.\");
|
||
|
|
f.tdatesel2.focus();
|
||
|
|
}
|
||
|
|
return bok;
|
||
|
|
}
|
||
|
|
function selall(f) {
|
||
|
|
var i;
|
||
|
|
for (i=0; i < f.tdatesel2.options.length; i++) {
|
||
|
|
f.tdatesel2.options[i].selected = true;
|
||
|
|
}
|
||
|
|
return false;
|
||
|
|
}
|
||
|
|
function deselall(f) {
|
||
|
|
var i;
|
||
|
|
for (i=0; i < f.tdatesel2.options.length; i++) {
|
||
|
|
f.tdatesel2.options[i].selected = false;
|
||
|
|
}
|
||
|
|
return false;
|
||
|
|
}
|
||
|
|
function selscores(f,j) {
|
||
|
|
var i,n,h,l,nh,nl;
|
||
|
|
if (j == 11) {
|
||
|
|
n=0;
|
||
|
|
j=0;
|
||
|
|
for (i=0; i < f.tdatesel2.options.length; i++) {
|
||
|
|
if (s[i] > n) {
|
||
|
|
j=i;
|
||
|
|
n=s[i];
|
||
|
|
}
|
||
|
|
}
|
||
|
|
f.tdatesel2.selectedIndex=j;
|
||
|
|
} else {
|
||
|
|
selall(f);
|
||
|
|
if (j == 12) {
|
||
|
|
nl=101;
|
||
|
|
for (i=f.tdatesel2.options.length-1; i >= 0; i--) {
|
||
|
|
if (s[i] < nl) {
|
||
|
|
l=i;
|
||
|
|
nl=s[i];
|
||
|
|
}
|
||
|
|
}
|
||
|
|
f.tdatesel2.options[l].selected=false;
|
||
|
|
} else {
|
||
|
|
nh=0;
|
||
|
|
nl=101;
|
||
|
|
for (i=f.tdatesel2.options.length-1; i >= 0; i--) {
|
||
|
|
if (s[i] > nh) {
|
||
|
|
h=i;
|
||
|
|
nh=s[i];
|
||
|
|
}
|
||
|
|
}
|
||
|
|
for (i=f.tdatesel2.options.length-1; i >= 0; i--) {
|
||
|
|
if (i != h) {
|
||
|
|
if (s[i] < nl) {
|
||
|
|
l=i;
|
||
|
|
nl=s[i];
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
f.tdatesel2.options[l].selected=false;
|
||
|
|
f.tdatesel2.options[h].selected=false;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return false;
|
||
|
|
}
|
||
|
|
function right(e) {
|
||
|
|
if (navigator.appName == 'Netscape' && (e.which == 3 || e.which == 2)) {
|
||
|
|
alert(\"This source and all graphics are proprietary and may not be viewed or copied.\");
|
||
|
|
return false;
|
||
|
|
} else {
|
||
|
|
if (navigator.appName == 'Microsoft Internet Explorer' && (event.button == 2 || event.button == 3)) {
|
||
|
|
alert(\"This source and all graphics are proprietary and may not be viewed or copied.\");
|
||
|
|
return false;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return true;
|
||
|
|
}
|
||
|
|
document.onmousedown=right;
|
||
|
|
document.onmouseup=right;
|
||
|
|
if (document.layers) window.captureEvents(Event.MOUSEDOWN);
|
||
|
|
if (document.layers) window.captureEvents(Event.MOUSEUP);
|
||
|
|
window.onmousedown=right;
|
||
|
|
window.onmouseup=right;
|
||
|
|
window.onload=wdwOnLoad;
|
||
|
|
// -->
|
||
|
|
</SCRIPT>
|
||
|
|
</HEAD>
|
||
|
|
<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\"
|
||
|
|
TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\"
|
||
|
|
VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\">
|
||
|
|
<FORM name=\"rptform1\" action=\"$cgiroot/likert_wall_107.pl\" METHOD=GET TARGET=\"rptTGWALL107\">
|
||
|
|
<input type=hidden name=\"tid\" value=\"$SESSION{'tid'}\">
|
||
|
|
<input type=hidden name=\"frm\" value=\"6\">
|
||
|
|
<input type=hidden name=\"rptno\" value=\"$FORM{'rptno'}\">
|
||
|
|
<input type=hidden name=\"tstid\" value=\"$FORM{'tstid'}\">
|
||
|
|
<input type=hidden name=\"tdatesel\" value=\"$FORM{'tdatesel'}\">
|
||
|
|
<input type=hidden name=\"tstid2\" value=\"$FORM{'tstid2'}\">
|
||
|
|
<input type=hidden name=\"cndid\" value=\"$FORM{'cndid'}\">
|
||
|
|
<input type=hidden name=\"clid\" value=\"$FORM{'clid'}\">
|
||
|
|
<input type=hidden name=\"testdates\" value=\"\">
|
||
|
|
<input type=hidden name=\"multiple\" value=\"0\">
|
||
|
|
<CENTER>
|
||
|
|
<TABLE cellpadding=0 cellspacing=0 border=0 width=100\%>
|
||
|
|
<TR>
|
||
|
|
<TD ALIGN=\"left\" valign=\"top\">
|
||
|
|
<FONT COLOR=\"$SYSTEM{'HEADERCOLOR'}\" SIZE=1>
|
||
|
|
$testdescriptions
|
||
|
|
</FONT>
|
||
|
|
</TD>
|
||
|
|
</TABLE>
|
||
|
|
<TABLE cellpadding=0 cellspacing=0 border=1 width=100\%>
|
||
|
|
";
|
||
|
|
if ($TEST{'seq'} eq 'std') {
|
||
|
|
print "<TR>
|
||
|
|
<TD rowspan=4>
|
||
|
|
<TABLE cellpadding=0 cellspacing=0 border=0 width=100\%>
|
||
|
|
<TR>
|
||
|
|
<TD align=\"center\">
|
||
|
|
<FONT COLOR=\"$SYSTEM{'HEADERCOLOR'}\" SIZE=2>
|
||
|
|
$xlatphrase[687]<br>
|
||
|
|
</font>
|
||
|
|
</TD>
|
||
|
|
</TR>
|
||
|
|
<TR>
|
||
|
|
<TD align=\"center\">
|
||
|
|
<FONT SIZE=2>
|
||
|
|
$lstdates</br>
|
||
|
|
</font>
|
||
|
|
</TD>
|
||
|
|
</TR>
|
||
|
|
</TABLE>
|
||
|
|
</TD>
|
||
|
|
</TR>
|
||
|
|
";
|
||
|
|
$colspan="colspan=2";
|
||
|
|
} else {
|
||
|
|
print "<TR>
|
||
|
|
<TD>
|
||
|
|
<TABLE cellpadding=0 cellspacing=0 border=0 width=100\%>
|
||
|
|
<TR>
|
||
|
|
<TD align=\"center\">
|
||
|
|
<FONT COLOR=\"$SYSTEM{'HEADERCOLOR'}\" SIZE=2>
|
||
|
|
$xlatphrase[687]<br>
|
||
|
|
</font>
|
||
|
|
</TD>
|
||
|
|
</TR>
|
||
|
|
<TR>
|
||
|
|
<TD align=\"center\">
|
||
|
|
<FONT SIZE=2>
|
||
|
|
$lstdates</br>
|
||
|
|
</font>
|
||
|
|
</TD>
|
||
|
|
</TR>
|
||
|
|
</TABLE>
|
||
|
|
</TD>
|
||
|
|
</TR>
|
||
|
|
";
|
||
|
|
$colspan="";
|
||
|
|
}
|
||
|
|
print "<TR>
|
||
|
|
<TD $colspan ALIGN=\"center\">
|
||
|
|
<font size=2>
|
||
|
|
";
|
||
|
|
$testspending = CountTestFilesByCnd($testpending, $CLIENT{'clid'},$id,$FORM{'cndid'});
|
||
|
|
if ($testspending > 0) {
|
||
|
|
print "
|
||
|
|
Print\ \; <A HREF=\"$cgiroot/tmaster.pl?tid=$SESSION{'tid'}&clid=$CLIENT{'clid'}&cndid=$CANDIDATE{'uid'}&tstid=$TEST{'id'}\" TARGET=\"prtwindow\">Master/Key</A>";
|
||
|
|
}
|
||
|
|
print "\ <br>
|
||
|
|
<INPUT type=\"submit\" name=\"submit\" value=\"$xlatphrase[709]\">
|
||
|
|
\ <br>
|
||
|
|
</font>
|
||
|
|
</TD>
|
||
|
|
</TR>
|
||
|
|
</TABLE>
|
||
|
|
</FORM>
|
||
|
|
</CENTER>
|
||
|
|
</BODY>
|
||
|
|
</HTML>
|
||
|
|
";
|
||
|
|
}
|
||
|
|
|
||
|
|
# elsif ($FORM{'frm'} == '6')
|
||
|
|
sub show_detail {
|
||
|
|
my @tentries;
|
||
|
|
my @tcols;
|
||
|
|
my $i;
|
||
|
|
my $j;
|
||
|
|
my $k;
|
||
|
|
my $loidx;
|
||
|
|
my $hiidx;
|
||
|
|
my $loscore;
|
||
|
|
my $hiscore;
|
||
|
|
my $avgscore;
|
||
|
|
my $avgcount;
|
||
|
|
my @testdates;
|
||
|
|
my @found;
|
||
|
|
my $sgrepfor;
|
||
|
|
my $bDisplay;
|
||
|
|
my $timetaken;
|
||
|
|
my $testtitle;
|
||
|
|
my $tstdate;
|
||
|
|
my $testid;
|
||
|
|
my @tmparray;
|
||
|
|
my @tmpdates;
|
||
|
|
my $RTF_PNG_Begin ;
|
||
|
|
my $RTF_PNG_Close ;
|
||
|
|
my $Eol = "\r\n" ; my $lCurly = "\x7b" ; my $rCurly = "\x7d" ;
|
||
|
|
# $lCurly, and $rCurly are used as curly braces, so vim is not confused
|
||
|
|
# about matching perl code curly braces.
|
||
|
|
|
||
|
|
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Exec Report $FORM{'rptno'}");
|
||
|
|
if ($HBI_Debug) {
|
||
|
|
print "Content-Type: text/html\n\n";
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
print "\<br\>\<br\>SESSION HASH ARRAY\<br\>\n" ;
|
||
|
|
foreach $key (sort keys (%SESSION)) {
|
||
|
|
print "KEY $key VAL $SESSION{$key}\<br\>\n" ;
|
||
|
|
}
|
||
|
|
print "\<br\>\<br\>FORM HASH ARRAY\<br\>\n" ;
|
||
|
|
foreach $key (sort keys (%FORM)) {
|
||
|
|
print "KEY $key VAL $FORM{$key}\<br\>\n" ;
|
||
|
|
}
|
||
|
|
print "\<br\>Dumper of \$FORM\{idlist\} " ;
|
||
|
|
print Dumper($FORM{'idlist'}) ;
|
||
|
|
print "\<br\>\<br\>\n" ;
|
||
|
|
my $lookatit = $FORM{'idlist'} ;
|
||
|
|
$lookatit =~ tr/\000/,/ ;
|
||
|
|
print Dumper($lookatit) ;
|
||
|
|
print "\<br\>\<br\>\n" ;
|
||
|
|
}
|
||
|
|
unless ($SESSION{'clid'}) {
|
||
|
|
warn "No Client ID in the session.\n" ;
|
||
|
|
warn "Client ID in the FORM is $FORM{'clid'}\n" ;
|
||
|
|
unless ($HBI_Debug) {
|
||
|
|
print "Content-Type: text/html\n\n";
|
||
|
|
&show_illegal_access_warning() ;
|
||
|
|
exit 0 ;
|
||
|
|
}
|
||
|
|
print "No Client ID in the session.\n" ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
print "</BODY>\n";
|
||
|
|
print "</HTML>\n";
|
||
|
|
exit 0 ;
|
||
|
|
}
|
||
|
|
&get_client_profile($SESSION{'clid'});
|
||
|
|
# populates the Assoc. array %CLIENT with data for the client id.
|
||
|
|
if ($HBI_Debug) {
|
||
|
|
print "\<br\>\<br\>CLIENT HASH ARRAY\<br\>\n" ;
|
||
|
|
foreach $key (sort keys (%CLIENT)) {
|
||
|
|
print "KEY $key VAL $CLIENT{$key}\<br\>\n" ;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
unless ($FORM{'cndid'}) {
|
||
|
|
warn "No Candidate ID in the form.\n" ;
|
||
|
|
unless ($HBI_Debug) {
|
||
|
|
print "Content-Type: text/html\n\n";
|
||
|
|
&show_illegal_access_warning() ;
|
||
|
|
exit 0 ;
|
||
|
|
}
|
||
|
|
print "No Candidate ID in the form.\n" ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
print "</BODY>\n";
|
||
|
|
print "</HTML>\n";
|
||
|
|
exit 0 ;
|
||
|
|
}
|
||
|
|
&get_candidate_profile( $SESSION{'clid'}, $FORM{'cndid'});
|
||
|
|
$CANDIDATE{'full_name'} = $CANDIDATE{'nmf'} . " " ;
|
||
|
|
$CANDIDATE{'full_name'} .= $CANDIDATE{'nmm'} . ". " if ($CANDIDATE{'nmm'}) ;
|
||
|
|
$CANDIDATE{'full_name'} .= $CANDIDATE{'nml'} ;
|
||
|
|
$CANDIDATE{'File_Name'} = $CANDIDATE{'full_name'} ;
|
||
|
|
# warn "INFO: full name is X$CANDIDATE{'full_name'}X\n" ;
|
||
|
|
$CANDIDATE{'full_name'} = &RTFize($CANDIDATE{'full_name'}) ;
|
||
|
|
# warn "INFO: full name is X$CANDIDATE{'full_name'}X\n" ;
|
||
|
|
if ($HBI_Debug) {
|
||
|
|
print "\<br\>\<br\>CANDIDATE HASH ARRAY\<br\>\n" ;
|
||
|
|
foreach $key (sort keys (%CANDIDATE)) {
|
||
|
|
print "KEY $key VAL $CANDIDATE{$key}\<br\>\n" ;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# populates the Assoc. array %CANDIDATE with data for the candidate/user/student who took the test/survey.
|
||
|
|
# HBI - Go find the format of the test results.
|
||
|
|
# The original code supported multiple selected tests.
|
||
|
|
# This report does not support multiple tests.
|
||
|
|
unless ($CLIENT{'clid'}) {
|
||
|
|
warn "No Client ID in the CLIENT data.\n" ;
|
||
|
|
print "No Client ID in the CLIENT data.\n" ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
exit 0 ;
|
||
|
|
}
|
||
|
|
unless ($FORM{'tstid'}) {
|
||
|
|
warn "No Test ID in the form.\n" ;
|
||
|
|
print "No Test ID in the form.\n" ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
exit 0 ;
|
||
|
|
}
|
||
|
|
unless ($FORM{'tstid2'}) {
|
||
|
|
warn "No Follow Up related Test ID in the form.\n" ;
|
||
|
|
print "No Follow Up related Test ID in the form.\n" ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
exit 0 ;
|
||
|
|
}
|
||
|
|
&get_test_profile($CLIENT{'clid'}, $FORM{'tstid'});
|
||
|
|
# populates the Assoc. array %TEST with the characteristics of the test (but not the questions or answers).
|
||
|
|
unless ($FORM{'cndid'}) {
|
||
|
|
warn "No Candidate ID in the form.\n" ;
|
||
|
|
print "No Candidate ID in the form.\n" ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
exit 0 ;
|
||
|
|
}
|
||
|
|
$foo = &get_test_sequence_for_reports($CLIENT{'clid'},$FORM{'cndid'}, $FORM{'tstid'});
|
||
|
|
# populates the Assoc. arrays %TEST_SESSION, %SUBTEST_QUESTIONS, %SUBTEST_ANSWERS, %SUBTEST_RESPONSES,
|
||
|
|
# and %SUBTEST_SUMMARY.
|
||
|
|
# Alternate ???
|
||
|
|
# $foo = &get_test_sequence_from_history($CLIENT{'clid'},$FORM{'cndid'}, $FORM{'tstid'},$FORM{'tdatesel'});
|
||
|
|
if ($HBI_Debug) {
|
||
|
|
print "\<br\>\<br\>SYSTEM HASH ARRAY\<br\>\n" ;
|
||
|
|
foreach $key (sort keys (%SYSTEM)) {
|
||
|
|
print "KEY $key VAL $SYSTEM{$key}\<br\>\n" ;
|
||
|
|
}
|
||
|
|
print "\<br\>\<br\>CLIENT HASH ARRAY\<br\>\n" ;
|
||
|
|
foreach $key (sort keys (%CLIENT)) {
|
||
|
|
print "KEY $key VAL $CLIENT{$key}\<br\>\n" ;
|
||
|
|
}
|
||
|
|
print "\<br\>\<br\>TEST HASH ARRAY\<br\>\n" ;
|
||
|
|
foreach $key (sort keys (%TEST)) {
|
||
|
|
print "KEY $key VAL $TEST{$key}\<br\>\n" ;
|
||
|
|
}
|
||
|
|
print "\<br\>\<br\>TEST_SESSION HASH ARRAY\<br\>\n" ;
|
||
|
|
foreach $key (sort keys (%TEST_SESSION)) {
|
||
|
|
print "KEY $key VAL $TEST_SESSION{$key}\<br\>\n" ;
|
||
|
|
}
|
||
|
|
print "\<br\>\<br\>SUBTEST_QUESTIONS HASH ARRAY\<br\>\n" ;
|
||
|
|
foreach $key (sort keys (%SUBTEST_QUESTIONS)) {
|
||
|
|
print "KEY $key VAL $SUBTEST_QUESTIONS{$key}\<br\>\n" ;
|
||
|
|
}
|
||
|
|
print "\<br\>\<br\>SUBTEST_ANSWERS HASH ARRAY\<br\>\n" ;
|
||
|
|
foreach $key (sort keys (%SUBTEST_ANSWERS)) {
|
||
|
|
print "KEY $key VAL $SUBTEST_ANSWERS{$key}\<br\>\n" ;
|
||
|
|
}
|
||
|
|
print "\<br\>\<br\>SUBTEST_RESPONSES HASH ARRAY\<br\>\n" ;
|
||
|
|
foreach $key (sort keys (%SUBTEST_RESPONSES)) {
|
||
|
|
print "KEY $key VAL $SUBTEST_RESPONSES{$key}\<br\>\n" ;
|
||
|
|
}
|
||
|
|
print "\<br\>\<br\>SUBTEST_SUMMARY XXX HASH ARRAY\<br\>\n" ;
|
||
|
|
foreach $key (sort keys (%SUBTEST_SUMMARY)) {
|
||
|
|
print "KEY $key VAL $SUBTEST_SUMMARY{$key}\<br\>\n" ;
|
||
|
|
}
|
||
|
|
} # end of if $HBI_Debug
|
||
|
|
|
||
|
|
my %supercat_total = () ; # Total points available for a category.
|
||
|
|
my %supercat_earned = () ; # Points earned for a category.
|
||
|
|
my %TGWall_Comments = () ; # Collected Text for questions and comments in a category.
|
||
|
|
my %TGWall_Comments_fnd = () ; # Collected Text for questions and comments in a category.
|
||
|
|
# The following values have a similar name, and are logically connected.
|
||
|
|
my $SUPERCAT_TOTAL = 0 ; # Total points available in all categories.
|
||
|
|
my $SUPERCAT_EARNED = 0 ; # Total points earned in all categories.
|
||
|
|
my ($points, $weight, @scores, @correct_ans, @incorrect_ans, @all_ans) ;
|
||
|
|
my ($ques_type, $supercat, $scores, @responses, $responses) ;
|
||
|
|
my (@individ, $individ, @img_labels, @img_data , @Response_parts) ;
|
||
|
|
my $client = $SESSION{'clid'} ;
|
||
|
|
$testid = $FORM{'tstid'} ;
|
||
|
|
my $candidate = $FORM{'cndid'} ;
|
||
|
|
my $testid2 = $FORM{'tstid2'} ;
|
||
|
|
my $PreSeminarTestDate = $FORM{'tdatesel'} ;
|
||
|
|
my $PostSeminarTestDate = $FORM{'tdatesel2'} ;
|
||
|
|
|
||
|
|
$SYSTEM{'FeedBackDate'} = "Date UNK" ;
|
||
|
|
$FeedBackDateTime = $PostSeminarTestDate ;
|
||
|
|
if ($HBI_Debug) {
|
||
|
|
print "\<br\>\<br\>compute FeedBackDate\<br\>\n" ;
|
||
|
|
print "PostSeminarTestDate $PostSeminarTestDate SYSTEM $SYSTEM{FeedBackDate}\<br\>\n" ;
|
||
|
|
}
|
||
|
|
|
||
|
|
# $FeedBackDateTime looks like 14-May-2013_22:47:00_GMT
|
||
|
|
# Get the feed back date.
|
||
|
|
my $FeedBackDateTime_OK = 0 ;
|
||
|
|
if ($FeedBackDateTime) {
|
||
|
|
my ($mon_name, $year, $day_month) ;
|
||
|
|
if ($FeedBackDateTime =~ m/^(\d{1,2})\-([A-Za-z]{3,4})\-(\d{2,4})\_\d{1,2}\:\d{1,2}\:\d{1,2}\_\w+$/) {
|
||
|
|
$mon_name = $2 ;
|
||
|
|
$year = $3 ;
|
||
|
|
$day_month = $1 ;
|
||
|
|
if (exists $Month_Full{$mon_name}) {
|
||
|
|
$mon_name = $Month_Full{$mon_name} ;
|
||
|
|
} else {
|
||
|
|
warn "ERROR: Did not find full month name for $mon_name.\n" ;
|
||
|
|
}
|
||
|
|
$FeedBackDateTime_OK = 1 ;
|
||
|
|
}
|
||
|
|
$SYSTEM{'FeedBackDate'} = "$mon_name $day_month, $year" ;
|
||
|
|
if ($HBI_Debug) {
|
||
|
|
print "\<br\>\<br\>compute FeedBackDate\<br\>\n" ;
|
||
|
|
print "PostSeminarTestDate $PostSeminarTestDate SYSTEM $SYSTEM{FeedBackDate}\<br\>\n" ;
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
warn "ERROR: FeedBackDateTime is unknown. Field in Automated Report is bogus." ;
|
||
|
|
if ($HBI_Debug) {
|
||
|
|
print "\<br\>\<br\>compute FeedBackDate\<br\>\n" ;
|
||
|
|
print "ERROR: FeedBackDateTime is unknown. Field in Automated Report is bogus." ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Get the current year for the copyright.
|
||
|
|
my $date_ascii = localtime ;
|
||
|
|
chomp $date_ascii ;
|
||
|
|
my @date_parts = split (/ +/, $date_ascii) ;
|
||
|
|
$SYSTEM{'CopyRightYear'} = $date_parts[4] ;
|
||
|
|
if ($HBI_Debug) {
|
||
|
|
print "\<br\>\<br\>CopyRightYear\<br\>\n" ;
|
||
|
|
print "CopyRightYear: $SYSTEM{'CopyRightYear'}" ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
}
|
||
|
|
|
||
|
|
my $All_Comment_Coll = [] ; # An array of arrays of comments.
|
||
|
|
my $Comment_Together = [] ; # An array of strings of comments that should be on the same page.
|
||
|
|
my ($ret1, $ret2) ;
|
||
|
|
($ret1, $QUESTIONS_AH) = &GetLikertData_from_preloaded_Globals($SESSION{'clid'}, $FORM{'tstid'}, 1 ) ;
|
||
|
|
|
||
|
|
&get_test_profile($CLIENT{'clid'}, $FORM{'tstid2'});
|
||
|
|
# populates the Assoc. array %TEST with the characteristics of the test (but not the questions or answers).
|
||
|
|
$foo = &get_test_sequence_for_reports($CLIENT{'clid'},$FORM{'cndid'}, $FORM{'tstid2'});
|
||
|
|
# populates the Assoc. arrays %TEST_SESSION, %SUBTEST_QUESTIONS, %SUBTEST_ANSWERS, %SUBTEST_RESPONSES,
|
||
|
|
# and %SUBTEST_SUMMARY.
|
||
|
|
# Alternate ???
|
||
|
|
# $foo = &get_test_sequence_from_history($CLIENT{'clid'},$FORM{'cndid'}, $FORM{'tstid'},$FORM{'tdatesel'});
|
||
|
|
|
||
|
|
($ret2, $QUESTIONS_AG) =
|
||
|
|
&GetLikertData_from_preloaded_Globals($SESSION{'clid'}, $FORM{'tstid2'}, 1 ) ;
|
||
|
|
|
||
|
|
#
|
||
|
|
# Build arrays of comments.
|
||
|
|
#
|
||
|
|
my $work_str ; my $work1_str ;
|
||
|
|
|
||
|
|
$work_str = &RTFize("Question: " . ${$QUESTIONS_AH}[0]->{'qtx'}) ;
|
||
|
|
push @{$Comment_Together}, "\\par " . $work_str ;
|
||
|
|
if (${$QUESTIONS_AH}[0]->{'comments'}) {
|
||
|
|
push @{$Comment_Together}, "\\par " . &RTFize(${$QUESTIONS_AH}[0]->{'comments'}) ;
|
||
|
|
} else {
|
||
|
|
push @{$Comment_Together}, "\\par " . "No comment." ;
|
||
|
|
}
|
||
|
|
push @{$All_Comment_Coll}, $Comment_Together ;
|
||
|
|
$Comment_Together = [] ;
|
||
|
|
|
||
|
|
$work_str = &RTFize("Question: " . ${$QUESTIONS_AG}[0]->{'qtx'}) ;
|
||
|
|
push @{$Comment_Together}, "\\par " . $work_str ;
|
||
|
|
if (${$QUESTIONS_AG}[0]->{'comments'}) {
|
||
|
|
push @{$Comment_Together}, "\\par " . &RTFize(${$QUESTIONS_AG}[0]->{'comments'}) ;
|
||
|
|
} else {
|
||
|
|
push @{$Comment_Together}, "\\par " . "No comment." ;
|
||
|
|
}
|
||
|
|
push @{$All_Comment_Coll}, $Comment_Together ;
|
||
|
|
$Comment_Together = [] ;
|
||
|
|
|
||
|
|
# build the Likert question comments from the last test.
|
||
|
|
my @Sorted_Categories = sort keys %{$ret2} ;
|
||
|
|
my $Category_i ;
|
||
|
|
$Comment_Together = [] ;
|
||
|
|
foreach $Category_i (@Sorted_Categories) {
|
||
|
|
my $Cat_Title = $Category_i ;
|
||
|
|
if ($Category_i =~ m/presentation/i) {
|
||
|
|
$Cat_Title = "Delivery" ;
|
||
|
|
}
|
||
|
|
push @{$Comment_Together}, "\\par \\par " . &RTFize("CATEGORY - $Cat_Title") ;
|
||
|
|
foreach $work_str (@{$ret2->{$Category_i}->{'Comments'}}) {
|
||
|
|
push @{$Comment_Together}, "\\par " ;
|
||
|
|
foreach $work1_str (@{$work_str}) {
|
||
|
|
push @{$Comment_Together}, $work1_str ;
|
||
|
|
}
|
||
|
|
push @{$All_Comment_Coll}, $Comment_Together ; $Comment_Together = [] ;
|
||
|
|
}
|
||
|
|
push @{$All_Comment_Coll}, $Comment_Together ; $Comment_Together = [] ;
|
||
|
|
}
|
||
|
|
$Comment_Together = [] ;
|
||
|
|
$last_index = $#{$QUESTIONS_AG} ;
|
||
|
|
# $i ;
|
||
|
|
for ($i = $last_index -2 ; $i <= $last_index; $i ++ ) {
|
||
|
|
$work_str = "\\par \\par " . &RTFize("Question: " . ${$QUESTIONS_AG}[$i]->{'qtx'}) ;
|
||
|
|
# warn "INFO:CC work_str $work_str CC\n" ;
|
||
|
|
push @{$Comment_Together}, $work_str ;
|
||
|
|
$work_str = ${$QUESTIONS_AG}[$i]->{'comments'} ;
|
||
|
|
$work1_str = ${$QUESTIONS_AG}[$i]->{'responses'} ;
|
||
|
|
if ($work1_str) {
|
||
|
|
push @{$Comment_Together}, "\\par " . &RTFize($work1_str) ;
|
||
|
|
} else {
|
||
|
|
push @{$Comment_Together},"\\par No response." ;
|
||
|
|
}
|
||
|
|
if ($work_str) {
|
||
|
|
push @{$Comment_Together}, "\\par " . &RTFize($work_str) ;
|
||
|
|
} else {
|
||
|
|
push @{$Comment_Together},"\\par No comment." ;
|
||
|
|
}
|
||
|
|
push @{$All_Comment_Coll}, $Comment_Together ;
|
||
|
|
$Comment_Together = [] ;
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
my $first_array_ref ; my $second_array_ref ;
|
||
|
|
my $prefix = "" ; my $suffix = "" ;
|
||
|
|
$prefix = "\\keep \\widctlpar " . $Eol . $lCurly . "\\keepn " ;
|
||
|
|
# warn "INFO: All_Comment_Coll elements $#{$All_Comment_Coll} ref All_Comment_Coll " . (ref $All_Comment_Coll) . " X" ;
|
||
|
|
foreach $first_array_ref (@{$All_Comment_Coll}) {
|
||
|
|
$SYSTEM{'ALL_Comments'} .= $prefix ;
|
||
|
|
# warn "INFO: first_array_ref elements $#{$first_array_ref} ref first_array_ref " . (ref $first_array_ref) . " Z" ;
|
||
|
|
$suffix = pop @{$first_array_ref} ;
|
||
|
|
$SYSTEM{'ALL_Comments'} .= join ($Eol,@{$first_array_ref}) ;
|
||
|
|
$SYSTEM{'ALL_Comments'} .= $Eol . $rCurly . $suffix . $Eol ;
|
||
|
|
unless ($suffix =~ m/\\par/) {$SYSTEM{'ALL_Comments'} .= '\par ' . $Eol ; }
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Build a bar chart for pre- and post-seminar self evaluation for KPSS.
|
||
|
|
#
|
||
|
|
my $HBI_Debug_Graph_Data = 0 ;
|
||
|
|
my $Data1 = [] ; # The data for the chart.
|
||
|
|
my $Category_ARef = [] ;
|
||
|
|
my $category ;
|
||
|
|
my %Categorys_fnd = () ;
|
||
|
|
my $Legend1 = [] ; # The legends for the chart.
|
||
|
|
# load the labels for the x-axis.
|
||
|
|
foreach $category (sort keys %{$ret1}) {
|
||
|
|
if ($category =~ m/presentation/i) {
|
||
|
|
push @{$Category_ARef}, "Delivery" ;
|
||
|
|
} else {
|
||
|
|
push @{$Category_ARef}, $category ;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
push @{$Category_ARef}, "Total" ;
|
||
|
|
push @{$Data1}, $Category_ARef ;
|
||
|
|
my $HBI_Debug_numbers = 0 ;
|
||
|
|
# Load the data for the pretest.
|
||
|
|
my $Category_ARef2 ;
|
||
|
|
$Category_ARef2 = [] ;
|
||
|
|
my $totavail = 0 ; my $totscore = 0 ;
|
||
|
|
foreach $category (sort keys %{$ret1}) {
|
||
|
|
$Categorys_fnd{$category} = 1 ;
|
||
|
|
my $piavail = $ret1->{$category}->{'PointsAvail'} ;
|
||
|
|
$totavail += $piavail ;
|
||
|
|
my $piscore = $ret1->{$category}->{'PointsEarned'} ;
|
||
|
|
$totscore += $piscore ;
|
||
|
|
my $piaver = $piavail ? ($piscore/$piavail) : 0 ;
|
||
|
|
my $pinum = (int(100*$piaver + 0.5)) ;
|
||
|
|
if ($HBI_Debug) {
|
||
|
|
print "INFO: category $category piavail $piavail piscore $piscore piaver $piaver pinum $pinum X\<br\>\n" ;
|
||
|
|
}
|
||
|
|
warn "INFO: category $category piavail $piavail piscore $piscore piaver $piaver pinum $pinum \n"
|
||
|
|
if ($HBI_Debug_numbers) ;
|
||
|
|
push @{$Category_ARef2}, $pinum ;
|
||
|
|
}
|
||
|
|
$piaver = $totavail ? ($totscore/$totavail) : 0 ;
|
||
|
|
$pinum = (int(100*$piaver + 0.5)) ;
|
||
|
|
warn "INFO: TOTAL totavail $totavail totscore $totscore piaver $piaver pinum $pinum \n"
|
||
|
|
if ($HBI_Debug_numbers) ;
|
||
|
|
if ($HBI_Debug) {
|
||
|
|
print "INFO: Pre-Seminar TOTAL totavail $totavail totscore $totscore piaver $piaver pinum $pinum X\<br\>\n" ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
}
|
||
|
|
push @{$Category_ARef2}, $pinum ;
|
||
|
|
push @{$Data1}, $Category_ARef2 ;
|
||
|
|
push @{$Legend1 }, "Pre-Seminar" ;
|
||
|
|
|
||
|
|
# Load the data for the Post-Seminar evaluation.
|
||
|
|
$Category_ARef2 = [] ;
|
||
|
|
my $Unmatched_Categorys = "" ;
|
||
|
|
$totavail = 0 ; $totscore = 0 ;
|
||
|
|
foreach $category (sort keys %{$ret2}) {
|
||
|
|
unless ($Categorys_fnd{$category}) {
|
||
|
|
$Unmatched_Categorys .= $category . ", " ;
|
||
|
|
}
|
||
|
|
$piavail = $ret2->{$category}->{'PointsAvail'} ;
|
||
|
|
$totavail += $piavail ;
|
||
|
|
$piscore = $ret2->{$category}->{'PointsEarned'} ;
|
||
|
|
$totscore += $piscore ;
|
||
|
|
$piaver = $piavail ? ($piscore/$piavail) : 0 ;
|
||
|
|
$pinum = (int(100*$piaver + 0.5)) ;
|
||
|
|
warn "INFO: category $category piavail $piavail piscore $piscore piaver $piaver pinum $pinum \n"
|
||
|
|
if ($HBI_Debug_numbers) ;
|
||
|
|
if ($HBI_Debug) {
|
||
|
|
print "INFO: category $category piavail $piavail piscore $piscore piaver $piaver pinum $pinum X\<br\>\n" ;
|
||
|
|
}
|
||
|
|
push @{$Category_ARef2}, $pinum ;
|
||
|
|
}
|
||
|
|
$piaver = $totavail ? ($totscore/$totavail) : 0 ;
|
||
|
|
$pinum = (int(100*$piaver + 0.5)) ;
|
||
|
|
warn "INFO: TOTAL totavail $totavail totscore $totscore piaver $piaver pinum $pinum \n"
|
||
|
|
if ($HBI_Debug_numbers) ;
|
||
|
|
if ($HBI_Debug) {
|
||
|
|
print "INFO: Post-Seminar TOTAL totavail $totavail totscore $totscore piaver $piaver pinum $pinum X\<br\>\n" ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
}
|
||
|
|
push @{$Category_ARef2}, $pinum ;
|
||
|
|
push @{$Data1}, $Category_ARef2 ;
|
||
|
|
push @{$Legend1 }, "Post-seminar" ;
|
||
|
|
|
||
|
|
if ($Unmatched_Categorys) {
|
||
|
|
warn "ERROR: Unmatched Categories in the tests.\n" ;
|
||
|
|
warn "ERROR: INFO: $Unmatched_Categorys." ;
|
||
|
|
unless ($HBI_Debug) {
|
||
|
|
print "Content-Type: text/html\n\n";
|
||
|
|
&show_illegal_access_warning() ;
|
||
|
|
exit 0 ;
|
||
|
|
}
|
||
|
|
print "Unmatched Categories in the tests.\<br\>ERROR: INFO: $Unmatched_Categorys.\n" ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
print "</BODY>\n";
|
||
|
|
print "</HTML>\n";
|
||
|
|
exit 0 ;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Set up the graphing options.
|
||
|
|
my ($xdim, $ydim, $hbar, $title, $xlabel, $ylabel,
|
||
|
|
$ymax, $ymin, $yticknum, $t_margin, $b_margin, $l_margin, $r_margin,
|
||
|
|
$colorscheme, $bar_spacing, $bargroup_spacing,
|
||
|
|
$show_values, $transparent,
|
||
|
|
$interlaced, $bgclr, $fgclr, $boxclr, $accentclr, $shadowclr, $shadow_depth,
|
||
|
|
$labelclr, $axislabelclr, $legendclr, $valuesclr, $textclr, $dclrs, $borderclrs,
|
||
|
|
$cycle_clrs, $accent_treshold, $long_ticks, $tick_length, $x_ticks, $y_number_format,
|
||
|
|
$x_label_skip, $y_label_skip, $x_last_label_skip, $x_tick_offset, $x_all_ticks,
|
||
|
|
$x_label_position, $y_label_position, $x_labels_vertical, $x_plot_values, $y_plot_values,
|
||
|
|
$box_axis, $no_axes, $two_axes, $use_axis, $zero_axis, $zero_axis_only, $axis_space,
|
||
|
|
$text_space, $cumulate, $overwrite, $correct_width, $values_vertical, $values_space,
|
||
|
|
$values_format, $legend_placement, $legend_marker_width, $legend_marker_height, $lg_cols ) ;
|
||
|
|
$xdim = ( 6 * 72 ) ;
|
||
|
|
$ydim = ( 5 * 72 ) ;
|
||
|
|
$hbar = 1 ;
|
||
|
|
$title = "" ; # The title is in the text of the report above the chart.
|
||
|
|
$xlabel = "" ;
|
||
|
|
$ylabel = "Percentage" ;
|
||
|
|
$ymax = 100 ;
|
||
|
|
$ymin = 0 ;
|
||
|
|
$yticknum = 10 ;
|
||
|
|
$t_margin = 10 ;
|
||
|
|
$b_margin = 10 ;
|
||
|
|
$l_margin = 10 ;
|
||
|
|
$r_margin = 30 ;
|
||
|
|
$colorscheme = "lblue:lred" ;
|
||
|
|
$bar_spacing = 0 ;
|
||
|
|
$bargroup_spacing = 6 ;
|
||
|
|
$show_values = 1 ;
|
||
|
|
$x_label_position = undef ;
|
||
|
|
$y_label_position = undef ;
|
||
|
|
$transparent = undef ;
|
||
|
|
$overwrite = 0 ;
|
||
|
|
$interlaced = undef ;
|
||
|
|
$bgclr = undef ;
|
||
|
|
$fgclr = undef ;
|
||
|
|
$boxclr = "lgray" ;
|
||
|
|
$accentclr = undef ;
|
||
|
|
$shadowclr = undef ;
|
||
|
|
$shadow_depth = undef ;
|
||
|
|
$labelclr = undef ;
|
||
|
|
$axislabelclr = undef ;
|
||
|
|
$legendclr = undef ;
|
||
|
|
$valuesclr = undef ;
|
||
|
|
$textclr = undef ;
|
||
|
|
$dclrs = undef ; # Also handled by the $colorscheme string.
|
||
|
|
$borderclrs = undef ;
|
||
|
|
$cycle_clrs = undef ;
|
||
|
|
$accent_treshold = undef ;
|
||
|
|
$long_ticks = undef ;
|
||
|
|
$tick_length = undef ;
|
||
|
|
$x_ticks = undef ;
|
||
|
|
$y_number_format = undef ;
|
||
|
|
$x_label_skip = undef ;
|
||
|
|
$y_label_skip = undef ;
|
||
|
|
$x_last_label_skip = undef ;
|
||
|
|
$x_tick_offset = undef ;
|
||
|
|
$x_all_ticks = undef ;
|
||
|
|
$x_label_position = undef ;
|
||
|
|
$y_label_position = undef ;
|
||
|
|
$x_labels_vertical = undef ;
|
||
|
|
$x_plot_values = undef ;
|
||
|
|
$y_plot_values = undef ;
|
||
|
|
$box_axis = undef ;
|
||
|
|
$no_axes = undef ;
|
||
|
|
$two_axes = undef ;
|
||
|
|
$use_axis = undef ;
|
||
|
|
$zero_axis = undef ;
|
||
|
|
$zero_axis_only = undef ;
|
||
|
|
$axis_space = undef ;
|
||
|
|
$text_space = undef ;
|
||
|
|
$cumulate = undef ;
|
||
|
|
$overwrite = 0 ;
|
||
|
|
$correct_width = undef ;
|
||
|
|
$values_vertical = undef ;
|
||
|
|
$values_space = undef ;
|
||
|
|
$values_format = undef ;
|
||
|
|
$legend_placement = undef ;
|
||
|
|
$legend_marker_width = undef ;
|
||
|
|
$legend_marker_height = undef ;
|
||
|
|
$lg_cols = undef ;
|
||
|
|
|
||
|
|
warn "INFO: Dumping Data1\n" if ($HBI_Debug_Graph_Data) ;
|
||
|
|
warn Dumper($Data1) if ($HBI_Debug_Graph_Data) ;
|
||
|
|
# Draw the graph
|
||
|
|
my ($Graph1_obj, $Graph1_str) = &bargraph_multi::Build_Labeled_X_Axis_Graph_Str
|
||
|
|
($Data1, $Legend1, "png", $xdim, $ydim, $hbar, $title, $xlabel, $ylabel,
|
||
|
|
$ymax, $ymin, $yticknum, $t_margin, $b_margin, $l_margin, $r_margin,
|
||
|
|
$colorscheme, $bar_spacing, $bargroup_spacing,
|
||
|
|
$show_values, $x_label_position, $y_label_position, $transparent, $overwrite,
|
||
|
|
$interlaced, $bgclr, $fgclr, $boxclr, $accentclr, $shadowclr, $shadow_depth,
|
||
|
|
$labelclr, $axislabelclr, $legendclr, $valuesclr, $textclr, $dclrs, $borderclrs,
|
||
|
|
$cycle_clrs, $accent_treshold, $long_ticks, $tick_length, $x_ticks, $y_number_format,
|
||
|
|
$x_label_skip, $y_label_skip, $x_last_label_skip, $x_tick_offset, $x_all_ticks,
|
||
|
|
$x_labels_vertical, $x_plot_values, $y_plot_values,
|
||
|
|
$box_axis, $no_axes, $two_axes, $use_axis, $zero_axis, $zero_axis_only, $axis_space,
|
||
|
|
$text_space, $cumulate, $correct_width, $values_vertical, $values_space,
|
||
|
|
$values_format, $legend_placement, $legend_marker_width, $legend_marker_height, $lg_cols ) ;
|
||
|
|
|
||
|
|
$RTF_PNG_Begin = $lCurly . '\\*\\shppict' ;
|
||
|
|
$RTF_PNG_Begin .= $lCurly . '\\pict\\pngblip' ;
|
||
|
|
$RTF_PNG_Begin .= "\\picw" . (${xdim} + 0) . " " ; # Width in pixels
|
||
|
|
$RTF_PNG_Begin .= "\\pich" . (${ydim} + 0) . " " ; # Height in pixels
|
||
|
|
$RTF_PNG_Begin .= "\\picwgoal" . (${xdim}*20) ; # width on the page in twips
|
||
|
|
$RTF_PNG_Begin .= "\\pichgoal" . (${ydim}*20) ; # Height on the page in twips.
|
||
|
|
$RTF_PNG_Begin .= $Eol ;
|
||
|
|
# I am using a pixel in a point. A point is 1/72 inches.
|
||
|
|
# A twip is 1/20 of a point.
|
||
|
|
$RTF_PNG_Begin .= "\\bliptag10000" ; # Unique identifier for the image.
|
||
|
|
$RTF_PNG_Begin .= $lCurly . '\\*\\blipuid ' ;
|
||
|
|
$RTF_PNG_Begin .= "00000000000000000000000000002710" ; # 32 numeric digits
|
||
|
|
$RTF_PNG_Begin .= $rCurly . $Eol ; # Ends blipuid.
|
||
|
|
$RTF_PNG_Close = $rCurly . $rCurly ; # Ends pict and shppict commands.
|
||
|
|
$RTF_PNG_Close .= $Eol ;
|
||
|
|
|
||
|
|
my $HBI_Debug_msg_str = "" ;
|
||
|
|
my $T_colors = "" ; # Normally this is a colon separated string of color names.
|
||
|
|
my $offset = 0 ;
|
||
|
|
my $length_line = 40 ;
|
||
|
|
my $len_left ;
|
||
|
|
my $part_data = "" ;
|
||
|
|
my $Hex_image ;
|
||
|
|
my $All_data_len = length $Graph1_str ;
|
||
|
|
do {
|
||
|
|
$len_left = $All_data_len - $offset ;
|
||
|
|
if ($len_left < $length_line) {$length_line = $len_left;}
|
||
|
|
$part_data .= unpack ("H*", substr($Graph1_str, $offset, $length_line)) ;
|
||
|
|
$part_data .= $Eol ;
|
||
|
|
$offset += $length_line ;
|
||
|
|
} while ($offset < $All_data_len ) ;
|
||
|
|
|
||
|
|
$SYSTEM{'Bargraph1'} = $RTF_PNG_Begin . $part_data . $RTF_PNG_Close ;
|
||
|
|
|
||
|
|
if ($HBI_Debug) {
|
||
|
|
$last_index = $#{$QUESTIONS_AH} ;
|
||
|
|
if ($last_index == -1) {
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
print "\<br\>\<br\>QUESTIONS_AH HASH ARRAY is empty.\<br\>\n" ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
} else {
|
||
|
|
print "\<br\>\<br\>QUESTIONS_AH HASH ARRAY Dump.\<br\>\n" ;
|
||
|
|
foreach $index (0 .. $last_index) {
|
||
|
|
print "\<br\>\n" ; # HBI
|
||
|
|
print "\<br\>\<br\>QUESTIONS_AH HASH ARRAY Element $index \<br\>\n" ;
|
||
|
|
foreach $key (sort keys (%{${$QUESTIONS_AH}[$index]})) {
|
||
|
|
print "KEY $key VAL " ;
|
||
|
|
print "${$QUESTIONS_AH}[$index]->{$key}" ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
} # end foreach $key
|
||
|
|
} # end foreach $index
|
||
|
|
} # end of if $last_index
|
||
|
|
} # end of if $HBI_Debug
|
||
|
|
|
||
|
|
if ($HBI_Debug) {
|
||
|
|
$last_index = $#{$QUESTIONS_AG} ;
|
||
|
|
if ($last_index == -1) {
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
print "\<br\>\<br\>QUESTIONS_AG HASH ARRAY is empty.\<br\>\n" ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
} else {
|
||
|
|
print "\<br\>\<br\>QUESTIONS_AG HASH ARRAY Dump.\<br\>\n" ;
|
||
|
|
foreach $index (0 .. $last_index) {
|
||
|
|
print "\<br\>\n" ; # HBI
|
||
|
|
print "\<br\>\<br\>QUESTIONS_AG HASH ARRAY Element $index \<br\>\n" ;
|
||
|
|
foreach $key (sort keys (%{${$QUESTIONS_AG}[$index]})) {
|
||
|
|
print "KEY $key VAL " ;
|
||
|
|
print "${$QUESTIONS_AG}[$index]->{$key}" ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
} # end foreach $key
|
||
|
|
} # end foreach $index
|
||
|
|
} # end of if $last_index
|
||
|
|
} # end of if $HBI_Debug
|
||
|
|
|
||
|
|
# Now we are going to format the date the test was taken. <%=FORM.tdatesel%>
|
||
|
|
# Original text is like 05-Jul-2013_19:37:35_GMT
|
||
|
|
my $given_date_str = $FORM{'tdatesel'} ;
|
||
|
|
my $new_fmt_date ;
|
||
|
|
my ($day_month, $month_str, $cent_year) ;
|
||
|
|
if ($given_date_str =~ m/^(\d+)\-([^\-]+)\-(\d+)/ ) {
|
||
|
|
$day_month = $1 ;
|
||
|
|
$month_str = $2 ;
|
||
|
|
$cent_year = $3 ;
|
||
|
|
$month_str = $Month_Full{$month_str} if ($Month_Full{$month_str}) ;
|
||
|
|
$FORM{'tdatesel'} = &RTFize("$month_str $day_month, $cent_year") ;
|
||
|
|
}
|
||
|
|
$SYSTEM{'FeedBackDate'} = &RTFize($SYSTEM{'FeedBackDate'}) ;
|
||
|
|
if ($HBI_Debug) {
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
print "full name\<br\>\n" ;
|
||
|
|
print $CANDIDATE{'full_name'} ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
print "Test Date\<br\>\n" ;
|
||
|
|
print $FORM{'tdatesel'} ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
print "FeedBack Date\<br\>\n" ;
|
||
|
|
print $SYSTEM{'FeedBackDate'} ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
print "Graphic Text\<br\>\n" ;
|
||
|
|
print $SYSTEM{'Graphic_Text'} ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
print "Comments\<br\>\n" ;
|
||
|
|
print $SYSTEM{'ALL_Comments'} ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
print "SYSTEM First Barchart\<br\>\n" ;
|
||
|
|
print $SYSTEM{'Bargraph1'} ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
print "SYSTEM Second Barchart\<br\>\n" ;
|
||
|
|
print $SYSTEM{'Bargraph2'} ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
print "</BODY>\n";
|
||
|
|
print "</HTML>\n";
|
||
|
|
exit 0 ;
|
||
|
|
}
|
||
|
|
|
||
|
|
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "3", "Exec Report $FORM{'rptno'} completed");
|
||
|
|
$OUTPUT_Format = "RTF" ;
|
||
|
|
print "Content-Type: text/rtf\n" ;
|
||
|
|
my $FName = $CANDIDATE{'File_Name'} ;
|
||
|
|
$FName =~ s/\W/_/g ;
|
||
|
|
print "Content-Disposition: attachment;filename=${FName}_KPSS_Follow_Up_report.rtf\n\n";
|
||
|
|
&show_template("TGWall_KPSS_Follow_Up_Report.rtf") ;
|
||
|
|
$OUTPUT_Format = "HTML" ;
|
||
|
|
}
|
||
|
|
|
||
|
|
################################################################################
|
||
|
|
#
|
||
|
|
# Subroutine Name
|
||
|
|
# GetTestHeader
|
||
|
|
#
|
||
|
|
# Description
|
||
|
|
# This subroutine returns the header of the test file
|
||
|
|
#
|
||
|
|
# Inputs
|
||
|
|
# $clientId -- The id of the client to search through
|
||
|
|
#
|
||
|
|
# Outputs
|
||
|
|
# None
|
||
|
|
#
|
||
|
|
# Returns
|
||
|
|
# @testFields -- An array of fields in the header
|
||
|
|
#
|
||
|
|
#adt080401###############################################################################
|
||
|
|
sub GetTestHeader
|
||
|
|
{
|
||
|
|
my $clientId = $_[0];
|
||
|
|
my @testList = &get_data("tests.$clientId");
|
||
|
|
my $testHdr = $testList[0];
|
||
|
|
my $testFields;
|
||
|
|
|
||
|
|
chop( $testHdr );
|
||
|
|
@testFields = split( /&/, $testHdr );
|
||
|
|
|
||
|
|
return @testFields;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
#adt080401###############################################################################
|
||
|
|
#
|
||
|
|
# Subroutine Name
|
||
|
|
# GetTestsByOwner
|
||
|
|
#
|
||
|
|
# Description
|
||
|
|
# This subroutine searches through the test definition file of the given
|
||
|
|
# client for all the tests that are owned by the given user id or are public
|
||
|
|
#
|
||
|
|
# Inputs
|
||
|
|
# $clientId -- The id of the client to search through
|
||
|
|
# $ownedBy -- The name of the owner of the test to search for
|
||
|
|
#
|
||
|
|
# Outputs
|
||
|
|
# None
|
||
|
|
#
|
||
|
|
# Returns
|
||
|
|
# @tests -- An array of tests owned by the given user id
|
||
|
|
#
|
||
|
|
################################################################################
|
||
|
|
sub GetTestsByOwner
|
||
|
|
{
|
||
|
|
my $clientId = $_[0];
|
||
|
|
my $ownedBy = $_[1];
|
||
|
|
my %currHash;
|
||
|
|
my @testList = &get_data("tests.$clientId");
|
||
|
|
my @currField;
|
||
|
|
my @tests;
|
||
|
|
my $testHdr = $testList[0];
|
||
|
|
my $testFields;
|
||
|
|
my $testCntr;
|
||
|
|
|
||
|
|
@testFields = &GetTestHeader( $clientId );
|
||
|
|
|
||
|
|
for( $testCntr = 1; $testCntr < $#testList; $testCntr++ )
|
||
|
|
{
|
||
|
|
#print "<b>$testList[$testCntr]</b><br>\n";
|
||
|
|
chop( $testList[$testCntr] );
|
||
|
|
@currField = split( '&', $testList[$testCntr] );
|
||
|
|
for( 0 .. $#testFields )
|
||
|
|
{
|
||
|
|
$currHash{$testFields[$_]} = $currField[$_];
|
||
|
|
}
|
||
|
|
|
||
|
|
#print "$currHash{'ownedby'} - $ownedBy<p>";
|
||
|
|
if( ( $currHash{'ownedby'} eq $ownedBy ) || ( $currHash{'ownedby'} eq "" ) )
|
||
|
|
{
|
||
|
|
push( @tests, $testList[$testCntr] );
|
||
|
|
#print "<font color=\"#ff0000\"><b>$testList[$testCntr]</b></font><br>\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
return @tests;
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Return: Count of test result files in $dir matching regex with $clid
|
||
|
|
# and $testid, OR -1 if there was an error.
|
||
|
|
#
|
||
|
|
sub CountTestFilesByCnd {
|
||
|
|
my ($dir, $clid, $testid, $cndid) = @_;
|
||
|
|
|
||
|
|
if ( ! defined($dir) ) {
|
||
|
|
&logger::logerr("Undefined directory for client ID '$clid', testid '$testid'");
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( ! defined($clid) ) {
|
||
|
|
&logger::logerr("Undefined client ID for directory '$dir', testid '$testid'");
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( ! defined($testid) ) {
|
||
|
|
&logger::logerr("Undefined test ID for directory '$dir', client ID '$clid'");
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
|
||
|
|
my $tstcount = scalar(get_matching_files($dir, "^$clid".'\.'."$cndid".'\.'."$testid\$"));
|
||
|
|
return $tstcount;
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Return: Count of test result files in $dir matching regex with $clid
|
||
|
|
# and $testid, OR -1 if there was an error.
|
||
|
|
#
|
||
|
|
sub CountHistoricTests {
|
||
|
|
my ($dir, $clid, $testid, $cndid) = @_;
|
||
|
|
|
||
|
|
if ( ! defined($dir) ) {
|
||
|
|
&logger::logerr("Undefined directory for client ID '$clid', testid '$testid'");
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( ! defined($clid) ) {
|
||
|
|
&logger::logerr("Undefined client ID for directory '$dir', testid '$testid'");
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( ! defined($testid) ) {
|
||
|
|
&logger::logerr("Undefined test ID for directory '$dir', client ID '$clid'");
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
|
||
|
|
my $historyfile = join($pathsep,$dir,"$clid.$testid.history");
|
||
|
|
open (HISTFILE,"<$historyfile") or return 0;
|
||
|
|
my @histentries = <HISTFILE>;
|
||
|
|
close HISTFILE;
|
||
|
|
my $sgrepfor=join('&',"\<\<\>\>$clid","$cndid","$testid","");
|
||
|
|
my @cndidentries = grep( /$sgrepfor/,@histentries);
|
||
|
|
my $tstcount = $#cndidentries + 1;
|
||
|
|
return $tstcount;
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Return: Count of cnd result files in $dir matching regex with $clid
|
||
|
|
# and $cndid, OR -1 if there was an error.
|
||
|
|
#
|
||
|
|
sub CountCndFiles {
|
||
|
|
my ($dir, $clid, $cndid) = @_;
|
||
|
|
|
||
|
|
if ( ! defined($dir) ) {
|
||
|
|
&logger::logerr("Undefined directory for client ID '$clid', cndid '$cndid'");
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( ! defined($clid) ) {
|
||
|
|
&logger::logerr("Undefined client ID for directory '$dir', cndid '$cndid'");
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( ! defined($cndid) ) {
|
||
|
|
&logger::logerr("Undefined cnd ID for directory '$dir', client ID '$clid'");
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
|
||
|
|
return scalar(get_matching_files($dir, "^$clid".'\.'."$cndid".'\.\S+$'));
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Return: Sum of times taken during a test in seconds.
|
||
|
|
#
|
||
|
|
sub computeTestTime {
|
||
|
|
my ($dir, $clid, $testid, $cndid, $tstkey) = @_;
|
||
|
|
|
||
|
|
if ( ! defined($dir) ) {
|
||
|
|
&logger::logerr("Undefined directory for client ID '$clid', testid '$testid'");
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( ! defined($clid) ) {
|
||
|
|
&logger::logerr("Undefined client ID for directory '$dir', testid '$testid'");
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( ! defined($testid) ) {
|
||
|
|
&logger::logerr("Undefined test ID for directory '$dir', client ID '$clid'");
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
|
||
|
|
my $timefile = join($pathsep,$dir,"$clid.$cndid.$testid.tim");
|
||
|
|
open (TLOGFILE,"<$timefile") or return 0;
|
||
|
|
my @tlogentries = <TLOGFILE>;
|
||
|
|
close TLOGFILE;
|
||
|
|
my $sgrepfor="^$tstkey\&(1)\.(2)\.(.*)\&$clid\&$cndid\&$testid\&(.*)";
|
||
|
|
my @cndidentries = grep( /$sgrepfor/,@tlogentries);
|
||
|
|
@tlogentries = ();
|
||
|
|
my $iidx;
|
||
|
|
my @tentrycols;
|
||
|
|
my $tottime;
|
||
|
|
|
||
|
|
$tottime = 0;
|
||
|
|
for $iidx (0 .. $#cndidentries) {
|
||
|
|
@tentrycols = split(/&/,$cndidentries[$iidx]);
|
||
|
|
$tottime += $tentrycols[7];
|
||
|
|
}
|
||
|
|
@tentrycols = ();
|
||
|
|
return $tottime;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub formatTimeFromSeconds {
|
||
|
|
my ($t, $fmt) = @_;
|
||
|
|
my $h;
|
||
|
|
my $m;
|
||
|
|
my $s;
|
||
|
|
my $r;
|
||
|
|
my $j;
|
||
|
|
|
||
|
|
$m = int($t/60);
|
||
|
|
$s = $t - ($m * 60);
|
||
|
|
$h = int($m/60);
|
||
|
|
$m = $m - ($h * 60);
|
||
|
|
if ($fmt =~ m/h/i) {
|
||
|
|
$r = "00000$h";
|
||
|
|
$j=length($r)-2;
|
||
|
|
$r = substr($r,$j,2);
|
||
|
|
$fmt =~ s/h/$r/g;
|
||
|
|
}
|
||
|
|
if ($fmt =~ m/m/i) {
|
||
|
|
$r = "00000$m";
|
||
|
|
$j=length($r)-2;
|
||
|
|
$r = substr($r,$j,2);
|
||
|
|
$fmt =~ s/m/$r/g;
|
||
|
|
}
|
||
|
|
if ($fmt =~ m/s/i) {
|
||
|
|
$r = "00000$s";
|
||
|
|
$j=length($r)-2;
|
||
|
|
$r = substr($r,$j,2);
|
||
|
|
$fmt =~ s/s/$r/g;
|
||
|
|
}
|
||
|
|
return $fmt;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Normally xdim was 400 and ydim was 100.
|
||
|
|
|
||
|
|
sub BuildBarGraph {
|
||
|
|
# This subroutine builds the HTML to get an image from an URL.
|
||
|
|
# The URL is a cgi-bin PERL script, with several parameters.
|
||
|
|
# The list parameters are: labels, values, and values2.
|
||
|
|
# The scalar parameters are: xdim, ydim, hbar, title, xlabel, ylabel, ymax, ymin, yticknum, colorscheme, $t_margin, $b_margin, $l_margin, $r_margin
|
||
|
|
|
||
|
|
# The first 3 parameters are references to three lists, which are mandatory.
|
||
|
|
# The values2 list may be an empty list. (and ignored.)
|
||
|
|
# The rest of the parameters are optional, but are order specific.
|
||
|
|
# Any parameter that is an empty string will be effectively ignored,
|
||
|
|
# but may be required to fill the list of parameters to a needed parm.
|
||
|
|
my (@label_names, @value_points, @value2_points) ;
|
||
|
|
my ($labels_ref, $values_ref, $values2_ref) ;
|
||
|
|
$labels_ref = $_[0] ;
|
||
|
|
@label_names = @{$labels_ref} ;
|
||
|
|
# @label_names is an array of character strings of the names of the bars on the graph.
|
||
|
|
$values_ref = $_[1] ;
|
||
|
|
@value_points = @{$values_ref} ;
|
||
|
|
# @value_points is an array of numeric values for each of the names in the first array.
|
||
|
|
# The sizes of the two arrays should be the same.
|
||
|
|
$values2_ref = $_[2] ;
|
||
|
|
@value2_points = @{$values2_ref} ;
|
||
|
|
shift ; shift ; shift ; # Remove the first 3 parms, to set up the next statement.
|
||
|
|
my ($xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum, $colorscheme, $t_margin, $b_margin, $l_margin, $r_margin) = @_ ;
|
||
|
|
my ($labels, $values, $values2) ;
|
||
|
|
# print '<br> label_names ' . "@label_names" . ' <br>' ;
|
||
|
|
# print '<br> value_points ' . "@value_points" . ' <br>' ;
|
||
|
|
if ($#label_names != $#value_points) {
|
||
|
|
print '<br>ERROR BuildBarGraph has different number of labels and data values.<br>' ;
|
||
|
|
}
|
||
|
|
$labels = join (":", map {munge($_)} @label_names ) ;
|
||
|
|
$values = join (":", map {munge($_)} @value_points ) ;
|
||
|
|
$values2 = join (":", map {munge($_)} @value2_points ) ;
|
||
|
|
# my $baseurl = "/cgi-bin/bargraph.pl?labels=$labels&title=Trust%20Level&ylabel=Respondents";
|
||
|
|
my $baseurl = "/cgi-bin/bargraph.pl?labels=$labels&values=$values" ;
|
||
|
|
if ($xdim or $xdim == 0) { $baseurl .= "&xdim=" . $xdim ; }
|
||
|
|
if ($ydim or $ydim == 0) { $baseurl .= "&ydim=" . $ydim ; }
|
||
|
|
if ($hbar or $hbar == 0) { $baseurl .= "&hbar=" . $hbar ; }
|
||
|
|
if ($title or $title == 0) { $baseurl .= "&title=" . munge( $title) ; }
|
||
|
|
if ($xlabel or $xlabel == 0) { $baseurl .= "&xlabel=" . munge( $xlabel) ; }
|
||
|
|
if ($ylabel or $ylabel == 0) { $baseurl .= "&ylabel=" . munge( $ylabel) ; }
|
||
|
|
if ($ymax or $ymax == 0) { $baseurl .= "&ymax=" . $ymax ; }
|
||
|
|
if ($ymin or $ymin == 0) { $baseurl .= "&ymin=" . $ymin ; }
|
||
|
|
if ($t_margin or $t_margin == 0) { $baseurl .= "&t_margin=" . $t_margin ; }
|
||
|
|
if ($b_margin or $b_margin == 0) { $baseurl .= "&b_margin=" . $b_margin ; }
|
||
|
|
if ($l_margin or $l_margin == 0) { $baseurl .= "&l_margin=" . $l_margin ; }
|
||
|
|
if ($r_margin or $r_margin == 0) { $baseurl .= "&r_margin=" . $r_margin ; }
|
||
|
|
if ($colorscheme) { $baseurl .= "&colorscheme=" . $colorscheme ; }
|
||
|
|
if ($yticknum or $yticknum == 0) { $baseurl .= "&yticknum=" . $yticknum ; }
|
||
|
|
return "<img src=\"$baseurl&values2=$values2\">";
|
||
|
|
}
|
||
|
|
|
||
|
|
############################################################################
|
||
|
|
#
|
||
|
|
# Function: munge( $string )
|
||
|
|
# Description: Do the normal munging to replace non-normal chars with %XX.
|
||
|
|
# Returns: a modified string with %XX patterns inserted
|
||
|
|
# Author: HBI, 2008/09/30
|
||
|
|
#
|
||
|
|
# The process is performed on strings that are sent as literal text,
|
||
|
|
# as part of an URL to be re-analyzed by a WEB server. The higher
|
||
|
|
# level application must do this once, and only once. This function
|
||
|
|
# assumes that the character string contains only 7 or 8 bit characters.
|
||
|
|
# This function cannot deal with multi-byte UTF-8 characters.
|
||
|
|
#
|
||
|
|
############################################################################
|
||
|
|
sub munge( $ ) {
|
||
|
|
my ($string) = @_;
|
||
|
|
$string =~ s/([^a-zA-Z0-9])/join('', '%', uc(unpack("H*",$1)))/eg;
|
||
|
|
return $string;
|
||
|
|
}
|
||
|
|
|
||
|
|
############################################################################
|
||
|
|
#
|
||
|
|
# Function: unmunge( $string )
|
||
|
|
# Description: Inverse operation of munge(), replace %XX with the real ascii.
|
||
|
|
# Returns: a modified string with %XX patterns replaced
|
||
|
|
# Author: efl, 11/2001
|
||
|
|
#
|
||
|
|
############################################################################
|
||
|
|
sub unmunge( $ ) {
|
||
|
|
my ($string) = @_;
|
||
|
|
$string =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
|
||
|
|
return $string;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub HTMLHeader {
|
||
|
|
return "<html>\n<head>\n<title>$_[0]</title>\n".
|
||
|
|
"<script language=\"JavaScript\">\n<!-- \n$_[1]\n -->\n</script>\n</head>\n".
|
||
|
|
"<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\"".
|
||
|
|
" TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\"".
|
||
|
|
" VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\">\n";
|
||
|
|
}
|
||
|
|
|
||
|
|
sub HTMLHeaderPlain {
|
||
|
|
return "<html>\n<head>\n<title>$_[0]</title>\n".
|
||
|
|
"<script language=\"JavaScript\">\n<!-- \n$_[1]\n -->\n</script>\n</head>\n".
|
||
|
|
"<BODY>\n";
|
||
|
|
}
|
||
|
|
|
||
|
|
sub HTMLFooter {
|
||
|
|
my $year = `date +%Y`;
|
||
|
|
my $ionline;
|
||
|
|
if ($ENV{'SERVER_NAME'} =~ "integroonline.com") {
|
||
|
|
$ionline = "<br>Copyright (c) $year, Integro Learning Company";
|
||
|
|
}
|
||
|
|
return "<br><center><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\">Copyright (c) $year, ACTS Corporation$ionline<center></font></body>\n</html>\n";
|
||
|
|
}
|
||
|
|
|
||
|
|
sub get_full_history {
|
||
|
|
# Parameters
|
||
|
|
# $dir
|
||
|
|
# $clientID
|
||
|
|
# $testID
|
||
|
|
# Side Effect
|
||
|
|
# All of the data is placed into the global variable %FULL_HISTORY
|
||
|
|
# Returned Value
|
||
|
|
# $ret - 0 implies failure, 1 implies success.
|
||
|
|
# %FULL_HISTORY format.
|
||
|
|
# Key is the Client ID.
|
||
|
|
# value is an anon. hash.
|
||
|
|
# Its key is the Test ID.
|
||
|
|
# value is an anon. hash.
|
||
|
|
# Its key is the Candidate ID.
|
||
|
|
# value is an anon. hash.
|
||
|
|
# Its key is the time of the test in seconds for the GMT time zone.
|
||
|
|
# value is the raw character string of the data.
|
||
|
|
# To access a single test's data:
|
||
|
|
# $FULL_HISTORY->{$clientID}->{$testID}->{$candidateID}->{$GMTsec}
|
||
|
|
my ($dir,$clientID,$testID) = @_;
|
||
|
|
my $trash = join($pathsep, $dir, "$clientID.$testID.history");
|
||
|
|
my $HBI_Debug_get_full_history = 0 ;
|
||
|
|
my $Open_state = 1 ;
|
||
|
|
open(TESTFILE, "<$trash") or $Open_state = 0 ;
|
||
|
|
unless ($Open_state) {
|
||
|
|
# The open failed.
|
||
|
|
warn "ERROR: Failed to open $trash " ;
|
||
|
|
return 0 ;
|
||
|
|
}
|
||
|
|
# The open succeeded.
|
||
|
|
my @seqlines = ();
|
||
|
|
@seqlines = <TESTFILE>;
|
||
|
|
close TESTFILE;
|
||
|
|
if ($HBI_Debug_get_full_history) {
|
||
|
|
warn "INFO: History file $clientID.$testID.history line count is " .
|
||
|
|
($#seqlines + 1) . " \n" ;
|
||
|
|
}
|
||
|
|
my $testline ; my $Line_cnt = 0 ;
|
||
|
|
foreach $testline (@seqlines) {
|
||
|
|
my $match_state ; $Line_cnt ++ ;
|
||
|
|
if ($testline =~ m/^([^\<]+)\<\<\>\>([^\&]+)&([^\&]+)&([^\&]+)&/) {
|
||
|
|
my $time_ascii = $1 ;
|
||
|
|
my $Client_id_str = $2 ;
|
||
|
|
my $candidateID = $3 ;
|
||
|
|
my $Test_id_str = $4 ;
|
||
|
|
if ($Client_id_str ne $clientID) {
|
||
|
|
warn "ERROR: Bad test history file data ${clientID}.${testID}.history " .
|
||
|
|
"line $Line_cnt has mismatched client id.\n" ;
|
||
|
|
}
|
||
|
|
if ($Test_id_str ne $testID) {
|
||
|
|
warn "ERROR: Bad test history file data ${clientID}.${testID}.history " .
|
||
|
|
"line $Line_cnt has mismatched test id.\n" ;
|
||
|
|
}
|
||
|
|
my $timestamp = &toGMSeconds($time_ascii) ;
|
||
|
|
unless ($timestamp) {
|
||
|
|
warn "ERROR: Bad test history file data ${clientID}.${testID}.history " .
|
||
|
|
"line $Line_cnt has bad time stamp.\n" ;
|
||
|
|
$timestamp = "UNK $Line_cnt" ; # Unique value for the file.
|
||
|
|
}
|
||
|
|
if ($HBI_Debug_get_full_history and ($Line_cnt <= 4 )) {
|
||
|
|
warn "INFO: History file $clientID.$testID.history time_ascii $time_ascii timestamp $timestamp\n" ;
|
||
|
|
}
|
||
|
|
$FULL_HISTORY->{$clientID}->{$testID}->{$candidateID}->{$timestamp} = $testline ;
|
||
|
|
} else {
|
||
|
|
warn "ERROR: get_full_history failed to match a valid format in a test history file.\n" ;
|
||
|
|
warn "ERROR: get_full_history file ${clientID}.${testID}.history line $Line_cnt \n" ;
|
||
|
|
next ;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if ($HBI_Debug_get_full_history) {
|
||
|
|
warn "INFO: History file $clientID.$testID.history RETURN 1, line_cnt $Line_cnt \n" ;
|
||
|
|
}
|
||
|
|
return 1 ;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub get_group_hash {
|
||
|
|
# Parameters
|
||
|
|
# $client - Client ID string.
|
||
|
|
# Returned value.
|
||
|
|
# $Group_hash - A scalar reference to an anonymous hash.
|
||
|
|
# The keys of the hash are the group ids.
|
||
|
|
# The values are another hash of data for the group.
|
||
|
|
# The keys are the field ids: grpowner, grpid, grpnme, grplist, validfrom, validto
|
||
|
|
# and GroupMembersA.
|
||
|
|
# The value of GroupMembersA is an anon array of the candidate ids of the members.
|
||
|
|
# The other values are the raw data of the fields in the group file.
|
||
|
|
my ($clientID) = @_ ;
|
||
|
|
my $HBI_Debug_get_group_hash = 0 ;
|
||
|
|
my @GroupData = &get_client_groups($clientID);
|
||
|
|
my $GroupID_HREF = {} ;
|
||
|
|
my $idxid = $GRPFIELD{'grpid'};
|
||
|
|
my @GroupFieldIDs = keys %GRPFIELD ;
|
||
|
|
warn "INFO: idxid $idxid Field IDS " . (join(" ", @GroupFieldIDs)) . "\n" if ($HBI_Debug_get_group_hash) ;
|
||
|
|
my ($FieldID, $GroupID ) ;
|
||
|
|
my $orig_data ; my @split_orig_data ; my $raw_data ;
|
||
|
|
foreach $orig_data (@GroupData) {
|
||
|
|
chomp $orig_data ;
|
||
|
|
@split_orig_data = split(/&/, $orig_data) ;
|
||
|
|
$GroupID = $split_orig_data[$idxid] ;
|
||
|
|
warn "INFO: Simple group ID $GroupID raw data $raw_data\n" if ($HBI_Debug_get_group_hash) ;
|
||
|
|
# Populate the raw data.
|
||
|
|
foreach $FieldID (@GroupFieldIDs) {
|
||
|
|
$GroupID_HREF->{$GroupID}->{$FieldID} = $split_orig_data[$GRPFIELD{$FieldID}] ;
|
||
|
|
warn "INFO: group ID $GroupID FieldID $FieldID " .
|
||
|
|
"Value " . $GroupID_HREF->{$GroupID}->{$FieldID} . "\n" if ($HBI_Debug_get_group_hash) ;
|
||
|
|
}
|
||
|
|
$candidates = $GroupID_HREF->{$GroupID}->{'grplist'} ;
|
||
|
|
chomp $candidates ;
|
||
|
|
$GroupID_HREF->{$GroupID}->{'GroupMembersA'} = [ split (/\,/, $candidates) ] ;
|
||
|
|
warn "INFO: group ID $GroupID Candidates "
|
||
|
|
. join (" ", $GroupID_HREF->{$GroupID}->{'GroupMembersA'} )
|
||
|
|
. "\n" if ($HBI_Debug_get_group_hash) ;
|
||
|
|
}
|
||
|
|
return $GroupID_HREF ;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub RTFHexEscape {
|
||
|
|
# Return the RTF Hex Escape of the first character in $_.
|
||
|
|
my $oldstr = shift(@_) ;
|
||
|
|
my $retstr = unpack ("H*", substr($oldstr, 0, 1)) ;
|
||
|
|
if ($retstr) {
|
||
|
|
return "\\\'" . $retstr ;
|
||
|
|
} else {
|
||
|
|
return "" ;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub RTFize {
|
||
|
|
# Parameter
|
||
|
|
# $textStr - An ASCII text string, not to be modified.
|
||
|
|
# Returned value
|
||
|
|
# $retStr - the $textStr with all special characters converted to special RTF sequences.
|
||
|
|
# Control Characters 0-31, or 0x00 to 0x1F
|
||
|
|
# tab, 0x09, becomes "\tab ".
|
||
|
|
# carriage returns, 0x0D; and line feeds, 0x0A; are left alone.
|
||
|
|
# Other control characters are deleted.
|
||
|
|
# Left Curly Brace becomes \'7b.
|
||
|
|
# Right Curly Brace becomes \'7d.
|
||
|
|
# Back slash becomes \'5c.
|
||
|
|
# Characters 128 to 255 become the hex escaped equivalent.
|
||
|
|
my ($retStr) = @_ ;
|
||
|
|
# Delete special control characters.
|
||
|
|
$retStr =~ s/[\x00-\x08\x0B\x0C\x0E-\x1F]//g ;
|
||
|
|
# Convert the back slash.
|
||
|
|
$retStr =~ s/\\/\\\'5C/g ;
|
||
|
|
# Convert tab.
|
||
|
|
$retStr =~ s/\x09/\\tab /g ;
|
||
|
|
# Convert characters that become the hex escaped value.
|
||
|
|
$retStr =~ s/([\x7b\x7d\x80-\xFF])/&RTFHexEscape($1)/ge ;
|
||
|
|
return $retStr ;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
sub GetLikertData_from_preloaded_Globals {
|
||
|
|
# Parameters
|
||
|
|
# $ClientID - required
|
||
|
|
# $TestID - required
|
||
|
|
# $respRequired - optional, default false, Response is required to count as available points.
|
||
|
|
# The routines assume that the following hashs are already loaded.
|
||
|
|
# %TEST, TEST_SESSION, SUBTEST_QUESTIONS, SUBTEST_ANSWERS, SUBTEST_RESPONSES, and SUBTEST_SUMMARY
|
||
|
|
# Returned value.
|
||
|
|
# $ret - reference to a Hash of a Hash. The keys of the first hash are the supercategories
|
||
|
|
# of the likert questions in the test. The keys of the second hash are 'PointsAvail',
|
||
|
|
# 'Responses', 'NoResponses', 'PointsEarned', 'ScoreCount', and 'Comments'. The values of the first
|
||
|
|
# four keys are numeric counts, or score totals. The value of the 'ScoreCount' is
|
||
|
|
# another hash. Its keys are the scores, and the values are the counts of the number
|
||
|
|
# of times each score was a response.
|
||
|
|
# $QUESTIONS - Reference to an array of hash data on questions.
|
||
|
|
# $Likert_Comments - Reference to a Hash of an Array of Arrays of Comments.
|
||
|
|
warn "Running GetLikertData_from_preloaded_Globals" ;
|
||
|
|
my ($ClientID, $TestID, $respRequired ) ;
|
||
|
|
$respRequired = 0 ;
|
||
|
|
($ClientID, $TestID, $respRequired ) = @_ ;
|
||
|
|
if ($HBI_Debug) {
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
print "Running GetLikertData_from_preloaded_Globals" ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
print "ClientID $ClientID TestID $TestID respRequired $respRequired X\<br\>\n" ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
}
|
||
|
|
my $ret = {} ;
|
||
|
|
my %supercat_found = () ; # hash of categories found and initialized in the hash of hashes.
|
||
|
|
|
||
|
|
my $inact_ques = 0 ; # This is an offset for the inactive questions.
|
||
|
|
# The inactive questions are still listed, but without an answer.
|
||
|
|
my $QUESTIONS_ZZ = &get_question_definitions ($ClientID, $TestID);
|
||
|
|
# Populates an array of hashs that contains all of the questions and the answers.
|
||
|
|
# $QUESTIONS_ZZ is a reference to the arrays of hashs.
|
||
|
|
my $last_index = $#{$QUESTIONS_ZZ} ; # Last index of the Array of Hashs of the Q&A.
|
||
|
|
# warn "INFO: last_index $last_index BB\n" ;
|
||
|
|
my ($points, $weight, @scores, @correct_ans, @incorrect_ans, @all_ans) ;
|
||
|
|
my ($ques_type, $supercat, $scores, @responses, $responses) ;
|
||
|
|
$responses = $SUBTEST_RESPONSES{2} ;
|
||
|
|
# warn "user $user testid $testid resp $responses .\n" ;
|
||
|
|
@responses = split (/\&/, $responses) ;
|
||
|
|
shift @responses ; # Drop the empty element in front of the list.
|
||
|
|
my $index1 ;
|
||
|
|
foreach $index1 (0 .. $last_index) {
|
||
|
|
# Skip the question if it is inactive.
|
||
|
|
if (${$QUESTIONS_ZZ}[$index1]->{'qil'} eq "Y") {
|
||
|
|
if ($HBI_Debug) {
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
print "Skipping index1 $index1 as an inactive question.\<br\>\n" ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
}
|
||
|
|
$inact_ques++ ; next ;
|
||
|
|
}
|
||
|
|
# Get the data for a single question.
|
||
|
|
$points = ${$QUESTIONS_ZZ}[$index1]->{'pts'} ;
|
||
|
|
$weight = ${$QUESTIONS_ZZ}[$index1]->{'wght'} ;
|
||
|
|
$ques_type = ${$QUESTIONS_ZZ}[$index1]->{'qtp'} ;
|
||
|
|
$scores = ${$QUESTIONS_ZZ}[$index1]->{'scores'} ;
|
||
|
|
# warn "INFO: index1 $index1 inact_ques $inact_ques RESPONSE Str $responses[$index1-$inact_ques] AA\n" ;
|
||
|
|
my @Response_parts = split ('::', $responses[$index1-$inact_ques], 2) ; # Get just the first questions from the pretest.
|
||
|
|
${$QUESTIONS_ZZ}[$index1]->{'responses'} = $Response_parts[0] ;
|
||
|
|
${$QUESTIONS_ZZ}[$index1]->{'comments'} = $Response_parts[1] ;
|
||
|
|
${$QUESTIONS_ZZ}[$index1]->{'responses'} =~ s/\s*\<br\>\s*/ /isg ;
|
||
|
|
${$QUESTIONS_ZZ}[$index1]->{'comments'} =~ s/\s*\<br\>\s*/ /isg ;
|
||
|
|
unless ($ques_type eq "lik") {
|
||
|
|
if ($HBI_Debug) {
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
print "Skipping index1 $index1 question Num. "
|
||
|
|
. ($index1-$inact_ques+1) . " as a non-likert question.\<br\>\n" ;
|
||
|
|
print "Question Type: $ques_type X\<br\>\n" ;
|
||
|
|
print "Response: $Response_parts[0] X\<br\>\n" ;
|
||
|
|
print "Comment: $Response_parts[1] X\<br\>\n" ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
}
|
||
|
|
next ;
|
||
|
|
}
|
||
|
|
@scores = split (/\,/ , $scores) ;
|
||
|
|
$supercat = ${$QUESTIONS_ZZ}[$index1]->{'supercat'} ;
|
||
|
|
unless ($supercat_found{$supercat}) {
|
||
|
|
# Initialize counters.
|
||
|
|
$ret->{$supercat}->{'PointsAvail'} = 0 ;
|
||
|
|
$ret->{$supercat}->{'NoResponses'} = 0 ;
|
||
|
|
$ret->{$supercat}->{'Responses'} = 0 ;
|
||
|
|
$ret->{$supercat}->{'PointsEarned'} = 0 ;
|
||
|
|
$ret->{$supercat}->{'ScoreCount'} = {} ;
|
||
|
|
$ret->{$supercat}->{'Comments'} = [] ;
|
||
|
|
$supercat_found{$supercat} = 1 ;
|
||
|
|
}
|
||
|
|
my $Ques_Comment = [] ;
|
||
|
|
my $Lik_Ques_Text = ${$QUESTIONS_ZZ}[$index1]->{'qtx'} ;
|
||
|
|
# warn "INFO:FF index1 $index1 inact_ques $inact_ques QTX $Lik_Ques_Text \n" ;
|
||
|
|
push @{$Ques_Comment}, ("Question: " . &RTFize($Lik_Ques_Text)) ;
|
||
|
|
if (${$QUESTIONS_ZZ}[$index1]->{'comments'}) {
|
||
|
|
push @{$Ques_Comment}, "\\par " . &RTFize(${$QUESTIONS_ZZ}[$index1]->{'comments'}) ;
|
||
|
|
} else {
|
||
|
|
push @{$Ques_Comment}, "\\par " . "No comment." ;
|
||
|
|
}
|
||
|
|
push @{$ret->{$supercat}->{'Comments'}}, $Ques_Comment ;
|
||
|
|
|
||
|
|
$responses = $Response_parts[0] ;
|
||
|
|
@individ = split(/\?/, $responses) ;
|
||
|
|
shift @individ ;
|
||
|
|
my $no_response = 1 ;
|
||
|
|
$ret->{$supercat}->{'PointsAvail'} += $points ;
|
||
|
|
foreach $index2 (0 .. $#scores) {
|
||
|
|
# Add the key for the score count to the hash.
|
||
|
|
unless (exists $ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]}) {
|
||
|
|
$ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]} = 0 ;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if ($HBI_Debug) {
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
print "Processing index1 $index1 Question Num. "
|
||
|
|
. ($index1-$inact_ques+1) . " as a likert question.\<br\>\n" ;
|
||
|
|
print "Question Type: $ques_type X\<br\>\n" ;
|
||
|
|
print "Category: $supercat X\<br\>\n" ;
|
||
|
|
print "Response: $Response_parts[0] X\<br\>\n" ;
|
||
|
|
print "Comment: $Response_parts[1] X\<br\>\n" ;
|
||
|
|
print "Scores: $scores X\<br\>\n" ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
}
|
||
|
|
foreach $index2 (0 .. $#scores) {
|
||
|
|
# warn "index2 $index2 individ $individ[$index2] .\n" ;
|
||
|
|
if ($individ[$index2] ne "xxx" and $individ[$index2] ne "" and $individ[$index2] == $index2) {
|
||
|
|
# Answered this question.
|
||
|
|
$ret->{$supercat}->{'PointsEarned'} += $scores[$index2] ;
|
||
|
|
if ($HBI_Debug) {
|
||
|
|
print "Scored as: $scores[$index2] X\<br\>\n" ;
|
||
|
|
}
|
||
|
|
$ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]} ++ ;
|
||
|
|
# warn "Likert Answer supercat $supercat index2 $index2 scores $scores[$index2] \n" ;
|
||
|
|
$no_response = 0 ;
|
||
|
|
} # If answered.
|
||
|
|
} # foreach $index2
|
||
|
|
if ($HBI_Debug) {
|
||
|
|
print "No_response: $no_response X\<br\>\n" ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
}
|
||
|
|
if ($no_response) {
|
||
|
|
# Add to the no response count.
|
||
|
|
$ret->{$supercat}->{'NoResponses'} ++ ;
|
||
|
|
# If the response is required, and there is none. Take out the points available.
|
||
|
|
if ($respRequired) {$ret->{$supercat}->{'PointsAvail'} -= $points ;}
|
||
|
|
# warn "Likert Answer supercat $supercat No Response \n" ;
|
||
|
|
} else {
|
||
|
|
# Add to the response count.
|
||
|
|
$ret->{$supercat}->{'Responses'} ++ ;
|
||
|
|
# warn "Likert Answer supercat $supercat Response \n" ;
|
||
|
|
}
|
||
|
|
} # foreach question.
|
||
|
|
return ($ret, $QUESTIONS_ZZ) ; # Return reference.
|
||
|
|
} # End of GetLikertData_from_preloaded_Globals
|
||
|
|
|
||
|
|
sub HTML_Maybe_Hash_Key_value {
|
||
|
|
# Return an HTML formatted string for a hash key value that may not exist.
|
||
|
|
# Parameters
|
||
|
|
# $HashRef - A Reference to a hash array.
|
||
|
|
# $key_str - The key value.
|
||
|
|
# Return a string in HTML format that describes the issues or value.
|
||
|
|
my ($HashRef, $key_str, $ret_str) ;
|
||
|
|
($HashRef, $key_str) = @_ ;
|
||
|
|
my $Bold_str = "<B>" ;
|
||
|
|
my $End_Bold_str = "</B>" ;
|
||
|
|
# Validate the hash reference.
|
||
|
|
unless (defined $HashRef) {
|
||
|
|
$ret_str = $Bold_str . "Hash Reference is undefined." . $End_Bold_str ;
|
||
|
|
return $ret_str ;
|
||
|
|
}
|
||
|
|
my $HashRefP = ref $HashRef ;
|
||
|
|
if ($HashRefP) {
|
||
|
|
unless ($HashRefP eq "HASH") {
|
||
|
|
$ret_str = $Bold_str . "Hash Reference is a reference to a $HashRefP." . $End_Bold_str ;
|
||
|
|
return $ret_str ;
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
$ret_str = $Bold_str . "Hash Reference is not a reference." . $End_Bold_str ;
|
||
|
|
return $ret_str ;
|
||
|
|
}
|
||
|
|
# The Hash reference is good.
|
||
|
|
# validate the key.
|
||
|
|
unless (defined $key_str) {
|
||
|
|
$ret_str = $Bold_str . "Key is undefined." . $End_Bold_str ;
|
||
|
|
return $ret_str ;
|
||
|
|
}
|
||
|
|
unless (exists $HashRef->{$key_str}) {
|
||
|
|
$ret_str = $Bold_str . "Key is not in the Hash." . $End_Bold_str ;
|
||
|
|
return $ret_str ;
|
||
|
|
}
|
||
|
|
my $Hash_value = $HashRef->{$key_str} ;
|
||
|
|
if (defined $Hash_value) {
|
||
|
|
$ret_str = $Hash_value ;
|
||
|
|
return $ret_str ;
|
||
|
|
} else {
|
||
|
|
$ret_str = $Bold_str . "Value of the Key in the Hash is undefined." . $End_Bold_str ;
|
||
|
|
return $ret_str ;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub HTML_Maybe_Array_Hash_Key_value {
|
||
|
|
# Return an HTML formatted string for an array of hash key value that may not exist.
|
||
|
|
# Parameters
|
||
|
|
# $ArrayRef - A reference to an array of references to a hash.
|
||
|
|
# $ArrayIndex - Numeric index to the array.
|
||
|
|
# $key_str - The key value.
|
||
|
|
# Return a string in HTML format that describes the issues or value.
|
||
|
|
my ($ArrayRef, $ArrayIndex, $key_str) ;
|
||
|
|
my ($HashRef, $ret_str) ;
|
||
|
|
($ArrayRef, $ArrayIndex, $key_str) = @_ ;
|
||
|
|
my $Bold_str = "<B>" ;
|
||
|
|
my $End_Bold_str = "</B>" ;
|
||
|
|
# Validate the Array Reference.
|
||
|
|
unless (defined $ArrayRef) {
|
||
|
|
$ret_str = $Bold_str . "Array Reference is undefined." . $End_Bold_str ;
|
||
|
|
return $ret_str ;
|
||
|
|
}
|
||
|
|
my $ArrayRefP = ref $ArrayRef ;
|
||
|
|
if ($ArrayRefP) {
|
||
|
|
unless ($ArrayRefP eq "ARRAY") {
|
||
|
|
$ret_str = $Bold_str . "Array Reference is a reference to a $ArrayRefP." . $End_Bold_str ;
|
||
|
|
return $ret_str ;
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
$ret_str = $Bold_str . "Array Reference is not a reference." . $End_Bold_str ;
|
||
|
|
return $ret_str ;
|
||
|
|
}
|
||
|
|
# The Array reference is good.
|
||
|
|
# Validate the index. $ArrayIndex
|
||
|
|
unless (defined $ArrayIndex) {
|
||
|
|
$ret_str = $Bold_str . "Array Index is undefined." . $End_Bold_str ;
|
||
|
|
return $ret_str ;
|
||
|
|
}
|
||
|
|
if (ref $ArrayIndex) {
|
||
|
|
$ret_str = $Bold_str . "Array Index is a reference." . $End_Bold_str ;
|
||
|
|
return $ret_str ;
|
||
|
|
} elsif ($ArrayIndex !~ m/^\d+$/) {
|
||
|
|
$ret_str = $Bold_str . "Array Index is non-numeric." . $End_Bold_str ;
|
||
|
|
return $ret_str ;
|
||
|
|
}
|
||
|
|
# The $ArrayIndex is a numeric scalar.
|
||
|
|
# Validate the range.
|
||
|
|
unless (($ArrayIndex >= 0) and ($ArrayIndex <= $#{$ArrayRef})) {
|
||
|
|
$ret_str = $Bold_str . "Array Index is out of range." . $End_Bold_str ;
|
||
|
|
return $ret_str ;
|
||
|
|
}
|
||
|
|
$HashRef = ${$ArrayRef}[$ArrayIndex] ;
|
||
|
|
# Validate the hash reference.
|
||
|
|
unless (defined $HashRef) {
|
||
|
|
$ret_str = $Bold_str . "Hash Reference is undefined." . $End_Bold_str ;
|
||
|
|
return $ret_str ;
|
||
|
|
}
|
||
|
|
my $HashRefP = ref $HashRef ;
|
||
|
|
if ($HashRefP) {
|
||
|
|
unless ($HashRefP eq "HASH") {
|
||
|
|
$ret_str = $Bold_str . "Hash Reference is a reference to a $HashRefP." . $End_Bold_str ;
|
||
|
|
return $ret_str ;
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
$ret_str = $Bold_str . "Hash Reference is not a reference." . $End_Bold_str ;
|
||
|
|
return $ret_str ;
|
||
|
|
}
|
||
|
|
# The Hash reference is good.
|
||
|
|
# validate the key.
|
||
|
|
unless (defined $key_str) {
|
||
|
|
$ret_str = $Bold_str . "Key to the Hash is undefined." . $End_Bold_str ;
|
||
|
|
return $ret_str ;
|
||
|
|
}
|
||
|
|
unless (exists $HashRef->{$key_str}) {
|
||
|
|
$ret_str = $Bold_str . "Key to the Hash does not exist." . $End_Bold_str ;
|
||
|
|
return $ret_str ;
|
||
|
|
}
|
||
|
|
my $Hash_value = $HashRef->{$key_str} ;
|
||
|
|
if (defined $Hash_value) {
|
||
|
|
$ret_str = $Hash_value ;
|
||
|
|
return $ret_str ;
|
||
|
|
} else {
|
||
|
|
$ret_str = $Bold_str . "Value of the Key in the Hash is undefined." . $End_Bold_str ;
|
||
|
|
return $ret_str ;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|