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.
1597 lines
64 KiB
1597 lines
64 KiB
4 months ago
|
#!/usr/bin/perl
|
||
|
|
|
||
|
|
# Source File: likert_wall_105.pl
|
||
|
|
|
||
|
|
# Get config
|
||
|
|
# use strict;
|
||
|
|
# use diagnostics ;
|
||
|
|
use FileHandle;
|
||
|
|
use Time::Local;
|
||
|
|
use Data::Dumper;
|
||
|
|
use IntegroLib;
|
||
|
|
require 'sitecfg.pl';
|
||
|
|
require 'testlib.pl';
|
||
|
|
require 'tstatlib.pl';
|
||
|
|
require 'questionslib.pl';
|
||
|
|
# require 'LikertData.pl' ;
|
||
|
|
# require 'grepa.pm' ;
|
||
|
|
use bargraph_multi ;
|
||
|
|
|
||
|
|
use vars qw(%FORM %SESSION %CLIENT %TEST_SESSION %SUBTEST_QUESTIONS %TEST
|
||
|
|
%SUBTEST_SUMMARY %CANDIDATE %SUBTEST_ANSWERS %SYSTEM %REPORT
|
||
|
|
%SUBTEST_RESPONSES @xlatphrase);
|
||
|
|
use vars qw($testcomplete $cgiroot $pathsep $dataroot @rptparams );
|
||
|
|
use vars qw($testinprog $testpending) ;
|
||
|
|
use vars qw($QUESTIONS_AG) ;
|
||
|
|
|
||
|
|
# &app_initialize;
|
||
|
|
if (exists $FORM{"idlist"} and $FORM{"idlist"}) {
|
||
|
|
$FORM{"idlist"} =~ tr/\000/,/ ; # Change separator for multiple values from NULL to comma. HBI
|
||
|
|
}
|
||
|
|
|
||
|
|
# Turn on the debugging flags only when we are going to generate a report.
|
||
|
|
use vars qw($HBI_Debug_idlist $HBI_Debug_grouping $HBI_Debug_FORM $HBI_Debug_Report $HBI_Debug) ;
|
||
|
|
$HBI_Debug_idlist= $HBI_Debug_grouping = $HBI_Debug_FORM= $HBI_Debug_Report= 0 ;
|
||
|
|
$HBI_Debug = 0 ;
|
||
|
|
if (exists $FORM{'reportname'} and $FORM{'reportname'} and $FORM{'reportname'} =~ m/LikertWQ/) {
|
||
|
|
$HBI_Debug_idlist = 0 ;
|
||
|
|
$HBI_Debug_grouping = 0 ;
|
||
|
|
$HBI_Debug_FORM = 0 ;
|
||
|
|
$HBI_Debug_Report = 0 ;
|
||
|
|
}
|
||
|
|
$HBI_Debug = $HBI_Debug_idlist || $HBI_Debug_grouping || $HBI_Debug_FORM || $HBI_Debug_Report ;
|
||
|
|
|
||
|
|
if ($HBI_Debug_idlist) {
|
||
|
|
warn "INFO: FORM idlist " . $FORM{"idlist"} . " X\n" ;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Make sure we have a valid session, and exit if we don't
|
||
|
|
if ($FORM{'tid'}) {
|
||
|
|
if (not &get_session($FORM{'tid'})) {
|
||
|
|
die "ERROR: " . __FILE__ . " started without a valid FORM Session ID.\n" ;
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
die "ERROR: " . __FILE__ . " started without a FORM Session ID.\n" ;
|
||
|
|
}
|
||
|
|
|
||
|
|
&LanguageSupportInit();
|
||
|
|
# print STDERR Dumper(\%FORM);
|
||
|
|
if ($SESSION{'clid'}) {
|
||
|
|
&get_client_profile($SESSION{'clid'});
|
||
|
|
} else {
|
||
|
|
die "ERROR: " . __FILE__ . " started without a SESSION Client ID.\n" ;
|
||
|
|
}
|
||
|
|
|
||
|
|
# If a report has not been choosen, then run reportChooser.
|
||
|
|
# else Prep for a report and run the report.
|
||
|
|
|
||
|
|
if ((! exists $FORM{'reportname'}) or $FORM{'reportname'} !~ m/\w/) {
|
||
|
|
&ReportChooser();
|
||
|
|
exit 0 ;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ($FORM{'tstid'}) {
|
||
|
|
&get_test_profile($CLIENT{'clid'}, $FORM{'tstid'});
|
||
|
|
} else {
|
||
|
|
die "ERROR: " . __FILE__ . " started without a FORM Test ID.\n" ;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Get the group filters, if any
|
||
|
|
my ($idlist,$groups);
|
||
|
|
use vars qw(@Report_Groups) ;
|
||
|
|
if (exists $FORM{'grouping'} and $FORM{'grouping'} eq 'subset') {
|
||
|
|
#my @tmp = split(/,/,$FORM{'idlist'});
|
||
|
|
@Report_Groups = param('idlist');
|
||
|
|
$FORM{'idlist'} = join(',', @Report_Groups);
|
||
|
|
if ($HBI_Debug_idlist) {
|
||
|
|
warn "INFO: Second FORM idlist " . $FORM{"idlist"} . " X\n" ;
|
||
|
|
}
|
||
|
|
@{$groups}{@Report_Groups} = @Report_Groups;
|
||
|
|
$idlist = &getIdlist($CLIENT{'clid'},$FORM{'idlist'});
|
||
|
|
# $idlist is a ref to a hash. The keys are the candidate ids in the groups.
|
||
|
|
# The values are all 1.
|
||
|
|
if ($HBI_Debug_idlist) {
|
||
|
|
warn "INFO: Third idlist " . Dumper(\$idlist) . " X\n" ;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Get the time stamp style
|
||
|
|
my $timestamp;
|
||
|
|
if ($FORM{'timestamp'} eq 'currenttime') {
|
||
|
|
$timestamp = scalar(localtime(time));
|
||
|
|
} elsif ($FORM{"timestamp"} eq 'custom' and $FORM{'customtime'} ne '') {
|
||
|
|
$timestamp = $FORM{'customtime'};
|
||
|
|
} elsif ($FORM{'timestamp'} eq 'mostrecent' and $FORM{'tstid'}) {
|
||
|
|
my $file = join($pathsep,$testcomplete,"$CLIENT{'clid'}.$FORM{'tstid'}.history");
|
||
|
|
my $fh = new FileHandle;
|
||
|
|
if ($fh->open($file)) {
|
||
|
|
my @history = map([split(/(?:<<>>|&)/,$_,4)],<$fh>);
|
||
|
|
# print "<pre>".Dumper(\@history)."</pre>";
|
||
|
|
if (defined $idlist) {
|
||
|
|
foreach (reverse @history) {
|
||
|
|
if (exists $idlist->{$_->[2]}) {
|
||
|
|
$timestamp = scalar(localtime(toGMSeconds($_->[0])));
|
||
|
|
last;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
$timestamp = scalar(localtime(toGMSeconds($history[$#history]->[0])));
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
print STDERR "Could not open $file in " . __FILE__ . "\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if (defined $timestamp) {
|
||
|
|
$timestamp = "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$timestamp</b></font><br><BR>\n";
|
||
|
|
} else {
|
||
|
|
$timestamp = "<br>\n";
|
||
|
|
}
|
||
|
|
|
||
|
|
# Generate the reports
|
||
|
|
# if ($FORM{'reportname'} eq 'LikertWQ') {
|
||
|
|
# &LikertWQ($idlist, $groups, $timestamp);
|
||
|
|
# The LikertWQ subroutine is in Likert_Gen_Groups.pl and teststats-tgwall101.pl
|
||
|
|
if ($FORM{'reportname'} eq 'LikertWQG') {
|
||
|
|
&LikertWQG($idlist, $groups, $timestamp);
|
||
|
|
} else {
|
||
|
|
die "ERROR: " . __FILE__ . " run without a valid report name. " .
|
||
|
|
"Client ID $CLIENT{'clid'}, Test ID $FORM{'tstid'}, " .
|
||
|
|
"Report Name $FORM{'reportname'}\n" ;
|
||
|
|
}
|
||
|
|
|
||
|
|
# There should only be function definitions beyond this point.
|
||
|
|
exit(0);
|
||
|
|
|
||
|
|
sub HTMLHeader {
|
||
|
|
my $title = "" ; my $ret_str = "" ;
|
||
|
|
my $JAVA_script = "" ;
|
||
|
|
($title, $JAVA_script) = @_ ;
|
||
|
|
$ret_str .= "<html>\n<head>\n<title>${title}</title>\n" ;
|
||
|
|
$ret_str .= "<!-- " . __FILE__ . " -->\n" ;
|
||
|
|
$ret_str .= "<script language=\"JavaScript\">\n<!-- \n${JAVA_script}\n -->\n</script>\n</head>\n" ;
|
||
|
|
$ret_str .= "<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\"" ;
|
||
|
|
$ret_str .= " TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\"" ;
|
||
|
|
$ret_str .= " VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\">\n" ;
|
||
|
|
return $ret_str ;
|
||
|
|
}
|
||
|
|
|
||
|
|
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 = "" ;
|
||
|
|
return "<br><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\">Copyright (c) $year, ACTS Corporation$ionline</font></body>\n</html>\n";
|
||
|
|
}
|
||
|
|
|
||
|
|
sub ReportChooser {
|
||
|
|
# Links w/javascript for chosing report
|
||
|
|
# Radio button to choose between all and select group(s)
|
||
|
|
# Menu box to chose one or more groups
|
||
|
|
my $groups = &getGroups($CLIENT{'clid'});
|
||
|
|
my $js = "function parmsIntegro(oform,rpt) {\n\t".
|
||
|
|
"oform.reportname.value=rpt;\n\t".
|
||
|
|
"oform.action='/cgi-bin/creports.pl';\n\t".
|
||
|
|
"oform.submit();\n};\n";
|
||
|
|
# $js .= "\nfunction commIntegro(oform) {\n\t". "oform.rptid.value='ACT-C-004';\n\t". "oform.rptdesc.value='Test Statistics by Test'\n\t". "oform.action='/cgi-bin/IntegroTS.pl';\n\t". "oform.submit();\n};\n";
|
||
|
|
my $organizationname = $CLIENT{'clnmc'};
|
||
|
|
my $uberheader = "" ;
|
||
|
|
my $TESTS = get_data_hash ("tests.$CLIENT{'clid'}") ;
|
||
|
|
# print STDERR Dumper($TESTS) ;
|
||
|
|
my %TESTS = %$TESTS ;
|
||
|
|
my @test_list = () ;
|
||
|
|
my $ids ;
|
||
|
|
for $ids (keys %TESTS) {
|
||
|
|
# warn "ID $ids DATADESC $TESTS{$ids}->{'desc'} X" ;
|
||
|
|
push @test_list, [$TESTS{$ids}->{'desc'}, $ids] ;
|
||
|
|
}
|
||
|
|
# warn "test_list count $#test_list X\n" ;
|
||
|
|
# print STDERR Dumper(\@test_list) ;
|
||
|
|
my ($js1, $test_choice_html) = ret_test_chooser_mod(@test_list) ;
|
||
|
|
|
||
|
|
#print STDERR get_data("tests.$CLIENT{'clid'}");
|
||
|
|
#print STDERR "Test ID = $tstid\n";
|
||
|
|
print HTMLHeader("TG Wall Custom Reports",$js . $js1);
|
||
|
|
print "<form name=\"integrorpt\" action=\"/cgi-bin/creports.pl\" method=\"Post\" target=\"rptwindow\" enctype=\"multipart/form-data\" >\n";
|
||
|
|
print "<input type=\"hidden\" name=\"tid\" value=\"$SESSION{'tid'}\">\n";
|
||
|
|
# For development purposes we hardcode the survey id.
|
||
|
|
# Fix this before production
|
||
|
|
# print "<input type=hidden name=\"tstid\" value=\"\">\n"; # HBI This had a value of $tstid
|
||
|
|
print "<input type=hidden name=\"rptno\" value=\"$FORM{'rptno'}\">\n";
|
||
|
|
print "<input type=hidden name=\"rptdesc\" value=\"$REPORT{'rptdesc'}\">\n";
|
||
|
|
print "<input type=hidden name=\"rptid\" value=\"$REPORT{'rptid'}\">\n";
|
||
|
|
print "<input type=\"hidden\" name=\"reportname\" value=\"\">\n";
|
||
|
|
print "<input type=hidden name=\"CustomFormat\" value=\"Yes\">\n";
|
||
|
|
|
||
|
|
print "<center>\n<table border>\n<caption>TG Wall Custom Reports</Caption>\n".
|
||
|
|
"<tr><td valign=\"top\"><input type=\"radio\" name=\"grouping\" value=\"all\" checked>All Groups</td>\n".
|
||
|
|
"<td valign=\"top\"><input type=\"radio\" name=\"grouping\" value=\"subset\">Choose Groups<br>\n".
|
||
|
|
"<select name=\"idlist\" onchange='this.form.grouping[1].click();' multiple>\n";
|
||
|
|
foreach (sort {$a->{'grpnme'} cmp $b->{'grpnme'}} values %$groups) {
|
||
|
|
print "<option value=\"$_->{'grpid'}\">$_->{'grpnme'}</option>\n";
|
||
|
|
}
|
||
|
|
print "</select>\n";
|
||
|
|
#print "<tr><td colspan=\"2\">$xlatphrase[797] $xlatphrase[279]: <input type=\"text\" name=\"orgname\" value=\"$organizationname\"></td></tr>\n";
|
||
|
|
print "<tr><td colspan=\"3\"><table border=0><tr><td>Organization Name:</td><td><input type=\"text\" name=\"orgname\" value=\"$organizationname\"></td></tr>\n";
|
||
|
|
print "<tr><td>Header Override:</td><td><input type=\"text\" name=\"uberheader\" value=\"$uberheader\"></td></tr></table></tr></td>\n";
|
||
|
|
print "<tr><td colspan=\"2\">Time Stamp:<ul style=\"list-style: none\">".
|
||
|
|
"<li><input type=\"radio\" name=\"timestamp\" value=\"mostrecent\" checked>Most Recent Survey Taken</li>".
|
||
|
|
# "<li><input type=\"radio\" name=\"timestamp\" value=\"currenttime\">Current Time</li>".
|
||
|
|
# "<li><input type=\"radio\" name=\"timestamp\" value=\"custom\">Custom Value: ".
|
||
|
|
# "<input type=\"text\" name=\"customtime\"></li>
|
||
|
|
"</tr></td>";
|
||
|
|
print "</table></center>\n";
|
||
|
|
print $test_choice_html ;
|
||
|
|
print "<p>Likert Scale Report" ;
|
||
|
|
print "<ul style=\"list-style: none\">" ;
|
||
|
|
# print "<li><a href=\"javascript:parmsIntegro(document.integrorpt,'LikertWQ');\">Likert Scale</a> - No Response is ignored, Question Numbers listed.</li>\n" ;
|
||
|
|
print "<li><a href=\"javascript:parmsIntegro(document.integrorpt,'LikertWQG');\">Automated Organizational Trust Report</a> No Response is ignored, Detail by Groups.</li>\n" ;
|
||
|
|
print "</ul></p>\n" ;
|
||
|
|
print "<input type=hidden name=\"testsummary\" value=\"composite\">\n";
|
||
|
|
print "<input type=hidden name=\"showcmts\" value=\"donot\">\n";
|
||
|
|
print "</form>";
|
||
|
|
print HTMLFooter();
|
||
|
|
}
|
||
|
|
|
||
|
|
sub LikertWQG {
|
||
|
|
# This does the Summary on the Likert Scale questions,
|
||
|
|
# for everybody, or just groups, and lists group results.
|
||
|
|
# $idlist is the list of candidate ids to report on. It is undef when all groups (everyone) is choosen.
|
||
|
|
# It is a reference to a hash. The keys are the candidate ids, and the value is 1 for candidates in the choosen groups.
|
||
|
|
# $groups is the hash of groups to report on. It is undef when all groups (everyone) is choosen.
|
||
|
|
# It is a reference to a hash. The keys are the group ids, and the values are the group ids.
|
||
|
|
# $FORM{'idlist'} is a comma separated list of the group ids of the selected groups.
|
||
|
|
# $FORM{'grouping'} is "subset" when the report should only cover the selected groups.
|
||
|
|
# $FORM{'grouping'} is "all" when the report should cover everybody.
|
||
|
|
use vars qw($QUESTIONS_AG) ;
|
||
|
|
my ($idlist,$groups,$timestamp) = @_;
|
||
|
|
my $ResponseRequired = 1 ; # Do not count questions if there was no response.
|
||
|
|
my $client = $SESSION{'clid'} ;
|
||
|
|
my $testid2 = $FORM{'tstid'} ;
|
||
|
|
my $all_groups = getGroups($client) ;
|
||
|
|
my $group_membership_required ;
|
||
|
|
if ($groups) {
|
||
|
|
$group_membership_required = 1 ;
|
||
|
|
my $group_p ;
|
||
|
|
for $group_p (keys %{$all_groups}) {
|
||
|
|
unless ($groups->{$group_p}) {
|
||
|
|
undef $all_groups->{$group_p} ;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
$group_membership_required = 0 ;
|
||
|
|
}
|
||
|
|
|
||
|
|
$SYSTEM{'FeedBackDate'} = "Date UNK" ;
|
||
|
|
use vars qw($FeedBackDateTime) ;
|
||
|
|
use vars qw($FULL_HISTORY) ;
|
||
|
|
$FeedBackDateTime = 0 ;
|
||
|
|
use vars qw($full_history_OK) ;
|
||
|
|
$full_history_OK = &get_full_history($testcomplete, $client, $testid2) ;
|
||
|
|
my $HBI_Debug_FeedBack = 0 ;
|
||
|
|
|
||
|
|
my ($sumdata, $grpdata) = &GetTGWallLikertGrpData($client, $testid2,
|
||
|
|
$all_groups, $group_membership_required, $ResponseRequired) ;
|
||
|
|
my $last_index = $#{$QUESTIONS_AG} ;
|
||
|
|
if ($HBI_Debug_Report ) {
|
||
|
|
warn "sumdata" ;
|
||
|
|
warn &Dumper(\$sumdata) ;
|
||
|
|
warn "grpdata" ;
|
||
|
|
warn &Dumper(\$grpdata) ;
|
||
|
|
}
|
||
|
|
my $MasterGroupHash = &get_group_hash($client) ;
|
||
|
|
my $grplist = {} ;
|
||
|
|
my $groupid ; my $HBI_Debug_Groups_800 = 0 ;
|
||
|
|
warn "INFO: grplist reference " . (ref $grplist) . "\n" if ($HBI_Debug_Groups_800) ;
|
||
|
|
use vars qw(@Report_Groups) ;
|
||
|
|
foreach $groupid (@Report_Groups) {
|
||
|
|
if (exists $MasterGroupHash->{$groupid}->{'GroupMembersA'}) {
|
||
|
|
$grplist->{$groupid} = $MasterGroupHash->{$groupid}->{'GroupMembersA'} ;
|
||
|
|
} else {
|
||
|
|
$grplist->{$groupid} = () ;
|
||
|
|
}
|
||
|
|
warn "INFO: Group ID $groupid \n" if ($HBI_Debug_Groups_800) ;
|
||
|
|
warn "INFO: Group members : " . join (" ", @{$grplist->{$groupid}}) . "\n" if ($HBI_Debug_Groups_800) ;
|
||
|
|
}
|
||
|
|
|
||
|
|
# 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] ;
|
||
|
|
|
||
|
|
# Get the consolidated comments from all the likert questions.
|
||
|
|
my @CommSuperCats = sort keys %{$sumdata} ;
|
||
|
|
my @SuperCatQuestions ;
|
||
|
|
my $CommSuperCategory ; my $SuperCatQuestion ;
|
||
|
|
foreach $CommSuperCategory (@CommSuperCats) {
|
||
|
|
@SuperCatQuestions = keys %{$sumdata->{$CommSuperCategory}->{'Questions'}} ;
|
||
|
|
$SYSTEM{'ALL_Comments'} .= "\\par \\par CATEGORY - $CommSuperCategory\n" ;
|
||
|
|
# $SYSTEM{'ALL_Comments'} .= "\\par \n" ;
|
||
|
|
my @SortedQuestions = sort {$a <=> $b} @SuperCatQuestions ;
|
||
|
|
foreach $SuperCatQuestion (@SortedQuestions) {
|
||
|
|
$SYSTEM{'ALL_Comments'} .= "\\par \\par Question " ;
|
||
|
|
# $SYSTEM{'ALL_Comments'} .= "\\par Question " . ($SuperCatQuestion + 1) . " - " ;
|
||
|
|
$SYSTEM{'ALL_Comments'} .= ${$QUESTIONS_AG}[$SuperCatQuestion]->{'qtx'} . "\\par \n" ;
|
||
|
|
my $qComm = ${$QUESTIONS_AG}[$SuperCatQuestion]->{'comments'} ;
|
||
|
|
if ($qComm) {
|
||
|
|
$SYSTEM{'ALL_Comments'} .= $qComm ;
|
||
|
|
} else {
|
||
|
|
$SYSTEM{'ALL_Comments'} .= "\\par NO Comments.\n" ;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
$SYSTEM{'orgname_Show'} = &RTFize($FORM{'orgname'}) ;
|
||
|
|
|
||
|
|
if ($HBI_Debug_Report ) {
|
||
|
|
print "Content-Type: text/html\n\n";
|
||
|
|
print HTMLHeaderPlain("Likert Scale Group Results");
|
||
|
|
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"5\">" ;
|
||
|
|
print "<b>Likert Scale Group Results<br>" ;
|
||
|
|
print "Survey/Test $TEST{'desc'}</b></font><br><br>\n";
|
||
|
|
print "<P ALIGN=Left>\n" ;
|
||
|
|
# print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"4\"><b>Improvement as Perceived by Employees</b></font><br>\n";
|
||
|
|
# print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$FORM{'orgname'}</b></font><br>\n";
|
||
|
|
if ($FORM{'uberheader'} ne "") {
|
||
|
|
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>".$FORM{'uberheader'}."</b></font><br>\n";
|
||
|
|
}
|
||
|
|
if (defined $idlist) {
|
||
|
|
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>Summary for Groups: "
|
||
|
|
.join(", ",map($all_groups->{$_}->{'grpnme'},split(/,/,$FORM{'idlist'})))."</b></font><br>\n" ;
|
||
|
|
}
|
||
|
|
# print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$xlatphrase[798] $xlatphrase[799]</b></font><br>\n";
|
||
|
|
print "<P>Timestamp ", $timestamp, "</p>\n" ;
|
||
|
|
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\">" ;
|
||
|
|
# Print HTML for heading.
|
||
|
|
my $key ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
|
||
|
|
if ($HBI_Debug_FeedBack) {
|
||
|
|
my $FBClient; my $FBtest; my $FBcand ;
|
||
|
|
print "<P>", "INFO: FB Clients " . (join(" ", keys %{$FULL_HISTORY})) . "\n" ;
|
||
|
|
foreach $FBClient (keys %{$FULL_HISTORY}) {
|
||
|
|
print "</P><P>" . "INFO: FB client $FBClient tests " . (join(" ", keys %{$FULL_HISTORY->{$FBClient}})) . "\n" ;
|
||
|
|
foreach $FBtest (keys %{$FULL_HISTORY->{$FBClient}}) {
|
||
|
|
print "</P><P>" . "INFO: FB client $FBClient test $FBtest candidates " .
|
||
|
|
(join(" ", keys %{$FULL_HISTORY->{$FBClient}->{$FBtest}})) . "\n" ;
|
||
|
|
foreach $FBcand (keys %{$FULL_HISTORY->{$FBClient}->{$FBtest}}) {
|
||
|
|
print "</P><P>" . "INFO: FB times $FBClient test $FBtest candidate $FBcand " .
|
||
|
|
(join(" ", keys %{$FULL_HISTORY->{$FBClient}->{$FBtest}->{$FBcand}})) . "\n" ;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
print "</P>\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" ;
|
||
|
|
}
|
||
|
|
# use vars qw(@Report_Groups) ;
|
||
|
|
print "\<br\>\<br\>idlist ARRAY \@Report_Groups\<br\>\n" ;
|
||
|
|
print "Length of \@Report_Groups is " . ($#Report_Groups + 1) . "\<br\>\n" ;
|
||
|
|
foreach $key (@Report_Groups) {
|
||
|
|
print "Array element $key \<br\>\n" ;
|
||
|
|
}
|
||
|
|
print "\<br\>Dumper of \$FORM\{idlist\} " ;
|
||
|
|
print Dumper($FORM{'idlist'}) ;
|
||
|
|
print "\<br\>\<br\>\n" ;
|
||
|
|
|
||
|
|
print "\<br\>\<br\>CLIENT HASH ARRAY\<br\>\n" ;
|
||
|
|
foreach $key (sort keys (%CLIENT)) {
|
||
|
|
# print "KEY $key VAL $CLIENT{$key}\<br\>\n" ;
|
||
|
|
print ("KEY $key VAL ", &HTML_Maybe_Hash_Key_value(\%CLIENT, $key) , "\<br\>\n") ;
|
||
|
|
}
|
||
|
|
print "\<br\>\<br\>SYSTEM HASH ARRAY\<br\>\n" ;
|
||
|
|
foreach $key (sort keys (%SYSTEM)) {
|
||
|
|
print "KEY $key VAL $SYSTEM{$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 ("KEY $key VAL ", &HTML_Maybe_Hash_Key_value(\%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" ;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
print "<b><table border>\n" if ($HBI_Debug_Report ) ;
|
||
|
|
|
||
|
|
# Set up Hashs for the data.
|
||
|
|
my $OverAll = {} ; # Hash Reference. Keys are categories/Trust Components.
|
||
|
|
my $ByGroup = {} ; # Hash Ref. keys {Group}->{Category}, value rounded percent.
|
||
|
|
my $ByGroupTot = {} ; # Hash Ref. keys {Group} value PerCent all Cat.
|
||
|
|
my $ByTotTot = 0 ; # Scalar percent of all groups and categories.
|
||
|
|
my @supercats = sort keys %{$sumdata} ;
|
||
|
|
my $cat_count = $#supercats + 1 ; # Number of categories.
|
||
|
|
#
|
||
|
|
|
||
|
|
# Print first row.
|
||
|
|
print "<tr>" if ($HBI_Debug_Report ) ;
|
||
|
|
print "<th ></th>" if ($HBI_Debug_Report ) ;
|
||
|
|
my $supercat ;
|
||
|
|
foreach $supercat (@supercats) {
|
||
|
|
print "<th >$supercat</th>\n" if ($HBI_Debug_Report ) ;
|
||
|
|
}
|
||
|
|
print "<th >Total</th>" if ($HBI_Debug_Report ) ;
|
||
|
|
print "</tr>\n" if ($HBI_Debug_Report ) ;
|
||
|
|
|
||
|
|
# Print second row. Heading for each column.
|
||
|
|
# Loop for Categories.
|
||
|
|
my $tot_poss = 0 ; my $tot_earned = 0 ;
|
||
|
|
print "<tr>" if ($HBI_Debug_Report ) ;
|
||
|
|
print "<td >Overall</td >\n" if ($HBI_Debug_Report ) ;
|
||
|
|
for $supercat (@supercats) {
|
||
|
|
# my $questions = "" ;
|
||
|
|
my $possible = 0 ;
|
||
|
|
my $earned = 0 ;
|
||
|
|
# $questions = join(", ", sort keys %{$sumdata->{$supercat}->{'Questions'}}) ;
|
||
|
|
$possible = $sumdata->{$supercat}->{'PointsAvail'} ;
|
||
|
|
$earned = $sumdata->{$supercat}->{'PointsEarned'} ;
|
||
|
|
$tot_poss += $possible ;
|
||
|
|
$tot_earned += $earned ;
|
||
|
|
$OverAll->{$supercat} = &Round_Per_Cent($earned, $possible) ;
|
||
|
|
print &rep_cell_str($earned, $possible, 1) if ($HBI_Debug_Report ) ;
|
||
|
|
}
|
||
|
|
$ByTotTot = &Round_Per_Cent($tot_earned, $tot_poss) ;
|
||
|
|
print &rep_cell_str($tot_earned, $tot_poss, 1) if ($HBI_Debug_Report ) ;
|
||
|
|
print "</tr>\n" if ($HBI_Debug_Report ) ;
|
||
|
|
|
||
|
|
# Print heading for Groups.
|
||
|
|
my $col_count = $cat_count + 2 ;
|
||
|
|
print "<tr><th colspan=\"${col_count}\">Group Breakdown</th ></tr >\n" if ($HBI_Debug_Report ) ;
|
||
|
|
|
||
|
|
print "<tr><th >Supervisor</th >" if ($HBI_Debug_Report ) ;
|
||
|
|
for $supercat (@supercats) {
|
||
|
|
print "<th >$supercat</th >" if ($HBI_Debug_Report ) ;
|
||
|
|
}
|
||
|
|
print "<th >Total</th ></tr >\n" if ($HBI_Debug_Report ) ;
|
||
|
|
|
||
|
|
unless ($grpdata) {
|
||
|
|
print "<tr><td colspan=\"${col_count}\">Pick Groups for more detail</td ></tr >\n" if ($HBI_Debug_Report ) ;
|
||
|
|
} else {
|
||
|
|
my $group ;
|
||
|
|
foreach $group (sort keys %{$grpdata}) {
|
||
|
|
if ($group) {
|
||
|
|
print "<tr >" if ($HBI_Debug_Report ) ;
|
||
|
|
print "<td >" if ($HBI_Debug_Report ) ;
|
||
|
|
# print "$group " if ($HBI_Debug_Report ) ;
|
||
|
|
print $all_groups->{$group}->{'grpnme'} if ($HBI_Debug_Report ) ;
|
||
|
|
print "</td >" if ($HBI_Debug_Report ) ;
|
||
|
|
my $tot_poss = 0 ; my $tot_earned = 0 ;
|
||
|
|
for $supercat (@supercats) {
|
||
|
|
my $possible = $grpdata->{$group}->{$supercat}->{'PointsAvail'} ;
|
||
|
|
my $earned = $grpdata->{$group}->{$supercat}->{'PointsEarned'} ;
|
||
|
|
$tot_poss += $possible ;
|
||
|
|
$tot_earned += $earned ;
|
||
|
|
$ByGroup->{$group}->{$supercat} = &Round_Per_Cent($earned, $possible) ;
|
||
|
|
print &rep_cell_str($earned, $possible, 1) if ($HBI_Debug_Report ) ;
|
||
|
|
}
|
||
|
|
$ByGroupTot->{$group} = &Round_Per_Cent($tot_earned, $tot_poss) ;
|
||
|
|
print &rep_cell_str($tot_earned, $tot_poss, 1) if ($HBI_Debug_Report ) ;
|
||
|
|
print "</tr>\n" if ($HBI_Debug_Report ) ;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
print "</table>\n" if ($HBI_Debug_Report ) ;
|
||
|
|
if ($HBI_Debug_Report ) {
|
||
|
|
print "<br>sumdata<br>" ;
|
||
|
|
print &Dumper(\$sumdata) ;
|
||
|
|
print "<br>grpdata<br>" ;
|
||
|
|
print &Dumper(\$grpdata) ;
|
||
|
|
}
|
||
|
|
my ($key, $index) ;
|
||
|
|
if ($HBI_Debug) {
|
||
|
|
if ($last_index == -1) {
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
print "\<br\>\<br\>QUESTIONS_AG HASH ARRAY is empty.\<br\>\n" ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
} else {
|
||
|
|
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 &HTML_Maybe_Array_Hash_Key_value($QUESTIONS_AG, $index, $key) ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
} # end foreach $key
|
||
|
|
} # end foreach $index
|
||
|
|
} # end of if $last_index
|
||
|
|
} # end of if $HBI_Debug
|
||
|
|
|
||
|
|
# Lets go compute the stuff we need for the bar charts.
|
||
|
|
my $Data1 = [] ; # The data for the chart.
|
||
|
|
my $Category_ARef = [] ;
|
||
|
|
my $category ;
|
||
|
|
my $Legend1 = [ "Overall Organization" ] ; # The legends for the chart.
|
||
|
|
my @All_Groups = sort keys %{$grpdata} ;
|
||
|
|
my @Master_Color_Scheme_Array =
|
||
|
|
qw(red blue lgreen yellow gray dgreen pink lbrown lred purple
|
||
|
|
dblue lpurple green white gold dyellow marine dred cyan lblue orange lgray dbrown lyellow
|
||
|
|
black dpink dgray lorange dpurple ) ;
|
||
|
|
|
||
|
|
# Create the graph for the Overall Graph first.
|
||
|
|
push @{$Category_ARef}, @supercats ;
|
||
|
|
push @{$Category_ARef}, "Total" ;
|
||
|
|
push @{$Data1}, $Category_ARef ;
|
||
|
|
my $Category_ARef2 ;
|
||
|
|
foreach $supercat (@supercats) {
|
||
|
|
push @{$Category_ARef2}, $OverAll->{$supercat} ;
|
||
|
|
}
|
||
|
|
push @{$Category_ARef2}, $ByTotTot ;
|
||
|
|
push @{$Data1}, $Category_ARef2 ;
|
||
|
|
my $Opts = {} ;
|
||
|
|
$Opts->{'width'} = ( 6 * 72 ) ;
|
||
|
|
$Opts->{'height'} = ( 3 * 72 ) ;
|
||
|
|
$Opts->{'title'} = "" ;
|
||
|
|
$Opts->{'hbar'} = 1 ;
|
||
|
|
$Opts->{'x_label'} = "" ;
|
||
|
|
$Opts->{'y_label'} = "" ;
|
||
|
|
$Opts->{'y_max_value'} = 100 ;
|
||
|
|
$Opts->{'y_min_value'} = 0 ;
|
||
|
|
$Opts->{'y_tick_number'} = 10 ;
|
||
|
|
$Opts->{'t_margin'} = 20 ;
|
||
|
|
$Opts->{'b_margin'} = 10 ;
|
||
|
|
$Opts->{'l_margin'} = 10 ;
|
||
|
|
$Opts->{'r_margin'} = 30 ;
|
||
|
|
my $Consolidated_Color_index = $#Report_Groups + 1 ;
|
||
|
|
$Opts->{'colorscheme'} = $Master_Color_Scheme_Array[$Consolidated_Color_index] ;
|
||
|
|
# Get the last color.
|
||
|
|
$Opts->{'bar_spacing'} = 0 ;
|
||
|
|
$Opts->{'bargroup_spacing'} = 2 ;
|
||
|
|
$Opts->{'show_values'} = 1 ;
|
||
|
|
$Opts->{'transparent'} = 0 ;
|
||
|
|
$Opts->{'x_label_position'} = 0.5 ;
|
||
|
|
$Opts->{'overwrite'} = 0 ;
|
||
|
|
$Opts->{'boxclr'} = "lgray" ;
|
||
|
|
$Opts->{'legend_placement'} = "BC" ;
|
||
|
|
$Opts->{'Graphic_Mode'} = "png" ;
|
||
|
|
|
||
|
|
# $Legend1 = [ "a", "b", "c" ] ;
|
||
|
|
# my $array_row ;
|
||
|
|
# $array_row = [ "H", "I", "J", "K", "L", "Tot" ] ;
|
||
|
|
# $Data1 = [ $array_row ] ;
|
||
|
|
# $array_row = [ 11, 12, 13, 14, 15, 16 ] ;
|
||
|
|
# push (@$Data1 , $array_row) ;
|
||
|
|
# $array_row = [ 21, 22, 23, 24, 25, 26 ] ;
|
||
|
|
# push (@$Data1 , $array_row) ;
|
||
|
|
# $array_row = [ 31, 32, 33, 34, 35, 36 ] ;
|
||
|
|
# push (@$Data1 , $array_row) ;
|
||
|
|
|
||
|
|
my ($Graph1_obj, $Graph1_str) = &Build_Labeled_X_Axis_Graph_Str_opts($Data1, $Legend1, $Opts) ;
|
||
|
|
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.
|
||
|
|
my $RTF_PNG_Begin = $lCurly . '\\*\\shppict' ;
|
||
|
|
$RTF_PNG_Begin .= $lCurly . '\\pict\\pngblip' ; # $Opts->{'xdim'}
|
||
|
|
$RTF_PNG_Begin .= "\\picw" . ($Opts->{'width'} + 0) . " " ; # Width in pixels
|
||
|
|
$RTF_PNG_Begin .= "\\pich" . ($Opts->{'height'} + 0) . " " ; # Height in pixels
|
||
|
|
$RTF_PNG_Begin .= "\\picwgoal" . ($Opts->{'width'}*20) ; # width on the page in twips
|
||
|
|
$RTF_PNG_Begin .= "\\pichgoal" . ($Opts->{'height'}*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 .= "\\bliptag20000" ; # Unique identifier for the image.
|
||
|
|
$RTF_PNG_Begin .= $lCurly . '\\*\\blipuid ' ;
|
||
|
|
$RTF_PNG_Begin .= "00000000000000000000000000022710" ; # 32 numeric digits
|
||
|
|
$RTF_PNG_Begin .= $rCurly . $Eol ; # Ends blipuid.
|
||
|
|
my $RTF_PNG_Close = $rCurly . $rCurly ; # Ends pict and shppict commands.
|
||
|
|
$RTF_PNG_Close .= $Eol ;
|
||
|
|
|
||
|
|
my $HBI_Debug_msg_str = "" ;
|
||
|
|
my $offset = 0 ;
|
||
|
|
my $length_line = 40 ;
|
||
|
|
my $len_left ;
|
||
|
|
my $part_data = "" ;
|
||
|
|
my $Hex_image ;
|
||
|
|
my $All_data_len = length $Graph1_str ;
|
||
|
|
|
||
|
|
if ($HBI_Debug_Report ) {
|
||
|
|
print "\<br\>Graphical Data Info.\<br\>\n" ; # HBI
|
||
|
|
print "Graph1_str length is $All_data_len \<br\>\n" ;
|
||
|
|
if (defined $Graph1_obj) {
|
||
|
|
print "Graph1_obj defined.\<br\>\n" ;
|
||
|
|
print "Graph1_obj reference X", (ref $Graph1_obj), "X\<br\>\n" ;
|
||
|
|
print "Graph1_obj X", $Graph1_obj, "X\<br\>\n" ;
|
||
|
|
} else {
|
||
|
|
print "Graph1_obj NOT defined.\<br\>\n" ;
|
||
|
|
}
|
||
|
|
print "\<br\>END SYSTEM Graph1_obj and string.\<br\>\<br\>\n" ; # HBI
|
||
|
|
}
|
||
|
|
|
||
|
|
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{'Barchart_org'} = $RTF_PNG_Begin . $part_data . $RTF_PNG_Close ;
|
||
|
|
|
||
|
|
# Lets go compute the stuff we need for the Group bar charts.
|
||
|
|
my $Chart_Group ; my $Chart_Group_cnt = 0 ; my $Chart_Group_Desc ;
|
||
|
|
my @Group_Chart_Array = () ;
|
||
|
|
foreach $Chart_Group (@Report_Groups) {
|
||
|
|
$Data1 = [] ; # The data for the chart.
|
||
|
|
$Category_ARef = [] ;
|
||
|
|
my $Group_Name = $MasterGroupHash->{$Chart_Group}->{'grpnme'} ;
|
||
|
|
$Legend1 = [ $Group_Name ] ; # The legends for the chart.
|
||
|
|
# Create the graph for the Group
|
||
|
|
push @{$Category_ARef}, @supercats ;
|
||
|
|
push @{$Category_ARef}, "Total" ;
|
||
|
|
push @{$Data1}, $Category_ARef ;
|
||
|
|
# $Category_ARef2 ;
|
||
|
|
$Category_ARef2 = [] ;
|
||
|
|
foreach $supercat (@supercats) {
|
||
|
|
push @{$Category_ARef2}, $ByGroup->{$Chart_Group}->{$supercat} ;
|
||
|
|
}
|
||
|
|
push @{$Category_ARef2}, $ByGroupTot->{$Chart_Group} ;
|
||
|
|
push @{$Data1}, $Category_ARef2 ;
|
||
|
|
# $Opts = {} ;
|
||
|
|
# $Opts->{'width'} = ( 6 * 72 ) ;
|
||
|
|
# $Opts->{'height'} = ( 5 * 72 ) ;
|
||
|
|
# $Opts->{'title'} = "" ;
|
||
|
|
# $Opts->{'hbar'} = 1 ;
|
||
|
|
# $Opts->{'x_label'} = "" ;
|
||
|
|
# $Opts->{'y_label'} = "" ;
|
||
|
|
# $Opts->{'y_max_value'} = 100 ;
|
||
|
|
# $Opts->{'y_min_value'} = 0 ;
|
||
|
|
# $Opts->{'y_tick_number'} = 10 ;
|
||
|
|
# $Opts->{'t_margin'} = 20 ;
|
||
|
|
# $Opts->{'b_margin'} = 10 ;
|
||
|
|
# $Opts->{'l_margin'} = 10 ;
|
||
|
|
# $Opts->{'r_margin'} = 10 ;
|
||
|
|
$Opts->{'colorscheme'} = $Master_Color_Scheme_Array[$Chart_Group_cnt] ;
|
||
|
|
# Get the group color.
|
||
|
|
# $Opts->{'bar_spacing'} = 0 ;
|
||
|
|
# $Opts->{'bargroup_spacing'} = 2 ;
|
||
|
|
# $Opts->{'show_values'} = 1 ;
|
||
|
|
# $Opts->{'transparent'} = 0 ;
|
||
|
|
# $Opts->{'x_label_position'} = 0.5 ;
|
||
|
|
# $Opts->{'overwrite'} = 0 ;
|
||
|
|
# $Opts->{'boxclr'} = "lgray" ;
|
||
|
|
# $Opts->{'legend_placement'} = "BC" ;
|
||
|
|
# $Opts->{'Graphic_Mode'} = "png" ;
|
||
|
|
|
||
|
|
($Graph1_obj, $Graph1_str) = &Build_Labeled_X_Axis_Graph_Str_opts($Data1, $Legend1, $Opts) ;
|
||
|
|
# 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.
|
||
|
|
$RTF_PNG_Begin = $lCurly . '\\*\\shppict' ;
|
||
|
|
$RTF_PNG_Begin .= $lCurly . '\\pict\\pngblip' ; # $Opts->{'xdim'}
|
||
|
|
$RTF_PNG_Begin .= "\\picw" . ($Opts->{'width'} + 0) . " " ; # Width in pixels
|
||
|
|
$RTF_PNG_Begin .= "\\pich" . ($Opts->{'height'} + 0) . " " ; # Height in pixels
|
||
|
|
$RTF_PNG_Begin .= "\\picwgoal" . ($Opts->{'width'}*20) ; # width on the page in twips
|
||
|
|
$RTF_PNG_Begin .= "\\pichgoal" . ($Opts->{'height'}*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.
|
||
|
|
my $bliptag_id = 20000 + 1 + $Chart_Group_cnt ;
|
||
|
|
$RTF_PNG_Begin .= "\\bliptag" ; # Unique identifier for the image.
|
||
|
|
$RTF_PNG_Begin .= $bliptag_id ;
|
||
|
|
$RTF_PNG_Begin .= $lCurly . '\\*\\blipuid ' ;
|
||
|
|
$RTF_PNG_Begin .= "000000000000000000000000000" ; # 32 numeric digits
|
||
|
|
$RTF_PNG_Begin .= $bliptag_id ;
|
||
|
|
$RTF_PNG_Begin .= $rCurly . $Eol ; # Ends blipuid.
|
||
|
|
$RTF_PNG_Close = $rCurly . $rCurly ; # Ends pict and shppict commands.
|
||
|
|
$RTF_PNG_Close .= $Eol ;
|
||
|
|
|
||
|
|
$HBI_Debug_msg_str = "" ;
|
||
|
|
$offset = 0 ;
|
||
|
|
$length_line = 40 ;
|
||
|
|
$part_data = "" ;
|
||
|
|
$All_data_len = length $Graph1_str ;
|
||
|
|
|
||
|
|
if ($HBI_Debug_Report ) {
|
||
|
|
print "\<br\>Graphical Data Info - Group $Chart_Group.\<br\>\n" ; # HBI
|
||
|
|
print "Graph1_str length is $All_data_len \<br\>\n" ;
|
||
|
|
if (defined $Graph1_obj) {
|
||
|
|
print "Graph1_obj defined.\<br\>\n" ;
|
||
|
|
print "Graph1_obj reference X", (ref $Graph1_obj), "X\<br\>\n" ;
|
||
|
|
print "Graph1_obj X", $Graph1_obj, "X\<br\>\n" ;
|
||
|
|
} else {
|
||
|
|
print "Graph1_obj NOT defined.\<br\>\n" ;
|
||
|
|
}
|
||
|
|
print "\<br\>END SYSTEM Graph1_obj and string.\<br\>\<br\>\n" ; # HBI
|
||
|
|
}
|
||
|
|
|
||
|
|
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 ) ;
|
||
|
|
push @Group_Chart_Array , ($RTF_PNG_Begin . $part_data . $RTF_PNG_Close) ;
|
||
|
|
$Chart_Group_cnt ++ ;
|
||
|
|
}
|
||
|
|
$SYSTEM{'Barchart_groups'} = join ("\n\\par \n" , @Group_Chart_Array ) ;
|
||
|
|
|
||
|
|
# Lets go compute the stuff we need for the Consolidated bar charts.
|
||
|
|
# my $Chart_Group ; my $Chart_Group_cnt = 0 ; my $Chart_Group_Desc ;
|
||
|
|
my @All_Chart_Array = () ;
|
||
|
|
$Data1 = [] ; # The data for the chart.
|
||
|
|
$Legend1 = [ ] ; # The legends for the chart.
|
||
|
|
$Category_ARef = [] ;
|
||
|
|
push @{$Category_ARef}, @supercats ;
|
||
|
|
push @{$Category_ARef}, "Total" ;
|
||
|
|
push @{$Data1}, $Category_ARef ;
|
||
|
|
foreach $Chart_Group ( sort {$MasterGroupHash->{$a}->{'grpnme'} cmp $MasterGroupHash->{$b}->{'grpnme'};} @All_Groups) {
|
||
|
|
# Create the graph for the Group
|
||
|
|
# $Category_ARef2 ;
|
||
|
|
$Category_ARef2 = [] ;
|
||
|
|
foreach $supercat (@supercats) {
|
||
|
|
push @{$Category_ARef2}, $ByGroup->{$Chart_Group}->{$supercat} ;
|
||
|
|
}
|
||
|
|
push @{$Category_ARef2}, $ByGroupTot->{$Chart_Group} ;
|
||
|
|
push @{$Data1}, $Category_ARef2 ;
|
||
|
|
push @{$Legend1}, $MasterGroupHash->{$Chart_Group}->{'grpnme'} ;
|
||
|
|
# warn "HBI chart_group $Chart_Group group name $MasterGroupHash->{$Chart_Group}->{'grpnme'} \n" ;
|
||
|
|
}
|
||
|
|
$Category_ARef2 = [] ;
|
||
|
|
foreach $supercat (@supercats) {
|
||
|
|
push @{$Category_ARef2}, $OverAll->{$supercat} ;
|
||
|
|
}
|
||
|
|
push @{$Category_ARef2}, $ByTotTot ;
|
||
|
|
push @{$Data1}, $Category_ARef2 ;
|
||
|
|
push @{$Legend1}, "Overall" ;
|
||
|
|
# $Opts = {} ;
|
||
|
|
# $Opts->{'width'} = ( 6 * 72 ) ;
|
||
|
|
$Opts->{'height'} = ( 9 * 72 ) ;
|
||
|
|
# $Opts->{'title'} = "" ;
|
||
|
|
# $Opts->{'hbar'} = 1 ;
|
||
|
|
# $Opts->{'x_label'} = "" ;
|
||
|
|
# $Opts->{'y_label'} = "" ;
|
||
|
|
# $Opts->{'y_max_value'} = 100 ;
|
||
|
|
# $Opts->{'y_min_value'} = 0 ;
|
||
|
|
# $Opts->{'y_tick_number'} = 10 ;
|
||
|
|
# $Opts->{'t_margin'} = 20 ;
|
||
|
|
# $Opts->{'b_margin'} = 10 ;
|
||
|
|
# $Opts->{'l_margin'} = 10 ;
|
||
|
|
# $Opts->{'r_margin'} = 10 ;
|
||
|
|
$Opts->{'colorscheme'} = join (":", @Master_Color_Scheme_Array ) ;
|
||
|
|
# Get the group color.
|
||
|
|
# $Opts->{'bar_spacing'} = 0 ;
|
||
|
|
# $Opts->{'bargroup_spacing'} = 2 ;
|
||
|
|
# $Opts->{'show_values'} = 1 ;
|
||
|
|
# $Opts->{'transparent'} = 0 ;
|
||
|
|
# $Opts->{'x_label_position'} = 0.5 ;
|
||
|
|
# $Opts->{'overwrite'} = 0 ;
|
||
|
|
# $Opts->{'boxclr'} = "lgray" ;
|
||
|
|
# $Opts->{'legend_placement'} = "BC" ;
|
||
|
|
# $Opts->{'Graphic_Mode'} = "png" ;
|
||
|
|
|
||
|
|
($Graph1_obj, $Graph1_str) = &Build_Labeled_X_Axis_Graph_Str_opts($Data1, $Legend1, $Opts) ;
|
||
|
|
# 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.
|
||
|
|
$RTF_PNG_Begin = $lCurly . '\\*\\shppict' ;
|
||
|
|
$RTF_PNG_Begin .= $lCurly . '\\pict\\pngblip' ; # $Opts->{'xdim'}
|
||
|
|
$RTF_PNG_Begin .= "\\picw" . ($Opts->{'width'} + 0) . " " ; # Width in pixels
|
||
|
|
$RTF_PNG_Begin .= "\\pich" . ($Opts->{'height'} + 0) . " " ; # Height in pixels
|
||
|
|
$RTF_PNG_Begin .= "\\picwgoal" . ($Opts->{'width'}*20) ; # width on the page in twips
|
||
|
|
$RTF_PNG_Begin .= "\\pichgoal" . ($Opts->{'height'}*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.
|
||
|
|
my $bliptag_id = 20000 + 1 + $Chart_Group_cnt + 1 ;
|
||
|
|
$RTF_PNG_Begin .= "\\bliptag" ; # Unique identifier for the image.
|
||
|
|
$RTF_PNG_Begin .= $bliptag_id ;
|
||
|
|
$RTF_PNG_Begin .= $lCurly . '\\*\\blipuid ' ;
|
||
|
|
$RTF_PNG_Begin .= "000000000000000000000000000" ; # 32 numeric digits
|
||
|
|
$RTF_PNG_Begin .= $bliptag_id ;
|
||
|
|
$RTF_PNG_Begin .= $rCurly . $Eol ; # Ends blipuid.
|
||
|
|
$RTF_PNG_Close = $rCurly . $rCurly ; # Ends pict and shppict commands.
|
||
|
|
$RTF_PNG_Close .= $Eol ;
|
||
|
|
|
||
|
|
$HBI_Debug_msg_str = "" ;
|
||
|
|
$offset = 0 ;
|
||
|
|
$length_line = 40 ;
|
||
|
|
$part_data = "" ;
|
||
|
|
$All_data_len = length $Graph1_str ;
|
||
|
|
|
||
|
|
if ($HBI_Debug_Report ) {
|
||
|
|
print "\<br\>Graphical Data Info - Consolidated Report.\<br\>\n" ; # HBI
|
||
|
|
print "Graph1_str length is $All_data_len \<br\>\n" ;
|
||
|
|
if (defined $Graph1_obj) {
|
||
|
|
print "Graph1_obj defined.\<br\>\n" ;
|
||
|
|
print "Graph1_obj reference X", (ref $Graph1_obj), "X\<br\>\n" ;
|
||
|
|
print "Graph1_obj X", $Graph1_obj, "X\<br\>\n" ;
|
||
|
|
} else {
|
||
|
|
print "Graph1_obj NOT defined.\<br\>\n" ;
|
||
|
|
}
|
||
|
|
print "\<br\>END SYSTEM Graph1_obj and string.\<br\>\<br\>\n" ; # HBI
|
||
|
|
}
|
||
|
|
|
||
|
|
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{'Barchart_consolidated'} = $RTF_PNG_Begin . $part_data . $RTF_PNG_Close ;
|
||
|
|
|
||
|
|
# Compute the last date of the test taken. $FeedBackDateTime
|
||
|
|
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") ;
|
||
|
|
my @Month_Full_A =
|
||
|
|
("January", "February", "March", "April", "May", "June", "July",
|
||
|
|
"August", "September", "October", "November", "December") ;
|
||
|
|
my ($day_month, $month_str, $cent_year) ;
|
||
|
|
if ($FeedBackDateTime > 0 ) {
|
||
|
|
my (@Time_array) = gmtime ($FeedBackDateTime) ;
|
||
|
|
$day_month = $Time_array[3] ;
|
||
|
|
$month_str = $Month_Full_A[($Time_array[4])] ;
|
||
|
|
$cent_year = $Time_array[5] + 1900 ;
|
||
|
|
$SYSTEM{'FeedBackDate'} = &RTFize("$month_str $day_month, $cent_year") ;
|
||
|
|
} else {
|
||
|
|
warn "ERROR: FeedBackDateTime is Unknown.\n" ;
|
||
|
|
}
|
||
|
|
my $index1 ;
|
||
|
|
# Compute the RTF format of the Collected Replies for a non-Likert question.
|
||
|
|
for ($index1 = 0; $index1 <= $last_index ; $index1 ++) {
|
||
|
|
${$QUESTIONS_AG}[$index1]->{'Collected_RTF_Replies'} = "" ;
|
||
|
|
next if (${$QUESTIONS_AG}[$index1]->{'qtp'} eq "lik") ;
|
||
|
|
my $Reply_Array_ref = ${$QUESTIONS_AG}[$index1]->{'Collected_Replies'} ;
|
||
|
|
my $first_array_ref ; my @Consolidated = () ; my $second_array_ref ;
|
||
|
|
my $prefix = "" ; my $suffix = "" ;
|
||
|
|
foreach $first_array_ref (@{$Reply_Array_ref}) {
|
||
|
|
my ($Rep_Arr_Ref, $Comment_Arr_Ref) = @{$first_array_ref} ;
|
||
|
|
$prefix = "\\keep \\widctlpar " . $lCurly . "\\keepn " ;
|
||
|
|
push @Consolidated, $prefix ;
|
||
|
|
if (defined $Rep_Arr_Ref) {
|
||
|
|
foreach $second_array_ref (@$Rep_Arr_Ref) {
|
||
|
|
push @Consolidated, $second_array_ref . "\\par " ;
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
push @Consolidated, $lCurly . "\bNo Answer.\\par " . $rCurly ;
|
||
|
|
}
|
||
|
|
if (defined $Comment_Arr_Ref) {
|
||
|
|
foreach $second_array_ref (@$Comment_Arr_Ref) {
|
||
|
|
push @Consolidated, $second_array_ref . "\\par " ;
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
push @Consolidated, $lCurly . "\bNo Comment.\\par " . $rCurly ;
|
||
|
|
}
|
||
|
|
my ($last_str) ;
|
||
|
|
$last_str = pop @Consolidated ;
|
||
|
|
push @Consolidated, $rCurly, $last_str ;
|
||
|
|
}
|
||
|
|
${$QUESTIONS_AG}[$index1]->{'responses_and_comments'} =
|
||
|
|
join ($Eol, @Consolidated) ;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ($HBI_Debug_Report ) {
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
print "FeedBack Date\<br\>\n" ;
|
||
|
|
print $SYSTEM{'FeedBackDate'} ;
|
||
|
|
print "\<br\>\n" ;
|
||
|
|
print "\<br\>SYSTEM Barchart_org\<br\>\n" ; # HBI
|
||
|
|
my $debug_line ;
|
||
|
|
foreach $debug_line (split /\n/, $SYSTEM{'Barchart_org'}) {
|
||
|
|
print ($debug_line, "\<br\>\n") ;
|
||
|
|
}
|
||
|
|
print "\<br\>END SYSTEM Barchart_groups\<br\>\<br\>\n" ; # HBI
|
||
|
|
print "\<br\>SYSTEM Barchart_groups\<br\>\n" ; # HBI
|
||
|
|
foreach $debug_line (split /\n/, $SYSTEM{'Barchart_groups'}) {
|
||
|
|
print ($debug_line, "\<br\>\n") ;
|
||
|
|
}
|
||
|
|
print "\<br\>END SYSTEM Barchart_groups\<br\>\<br\>\n" ; # HBI
|
||
|
|
print "\<br\>SYSTEM Barchart_consolidated\<br\>\n" ; # HBI
|
||
|
|
foreach $debug_line (split /\n/, $SYSTEM{'Barchart_consolidated'}) {
|
||
|
|
print ($debug_line, "\<br\>\n") ;
|
||
|
|
}
|
||
|
|
print "\<br\>END SYSTEM Barchart_consolidated\<br\>\<br\>\n" ; # HBI
|
||
|
|
}
|
||
|
|
|
||
|
|
print HTMLFooter() if ($HBI_Debug_Report ) ;
|
||
|
|
exit 0 if ($HBI_Debug_Report ) ;
|
||
|
|
use vars qw($OUTPUT_Format) ;
|
||
|
|
$OUTPUT_Format = "RTF" ;
|
||
|
|
print "Content-Type: text/rtf\n";
|
||
|
|
my $FName = ($FORM{'orgname'}) ? $FORM{'orgname'} : "Org-Name" ;
|
||
|
|
$FName =~ s/\W/_/g ;
|
||
|
|
# print "Content-Disposition: attachment;filename=report.rtf\n\n";
|
||
|
|
print "Content-Disposition: attachment;filename=${FName}_OTS_report.rtf\n\n";
|
||
|
|
&show_template("TGWALL_Org_Trust_Blank_Report.rtf") ;
|
||
|
|
$OUTPUT_Format = "HTML" ;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub rep_cell_str {
|
||
|
|
# Parameters
|
||
|
|
# $count - required, number for the cell, integer.
|
||
|
|
# $total - dividend for the percent, integer.
|
||
|
|
# $skip_tot - Optional, default false.
|
||
|
|
# If true, do not print total.
|
||
|
|
# Returned Value
|
||
|
|
# $html_str - html string to print for the cell.
|
||
|
|
my ($count, $total, $skip_tot) = @_ ;
|
||
|
|
my $html_str ;
|
||
|
|
$html_str .= "<td align=\"center\">" unless ($skip_tot) ;
|
||
|
|
my ($percent, $percent_str, $count_str) ;
|
||
|
|
$count_str = sprintf("%4i", $count) ;
|
||
|
|
if ($total == 0) {
|
||
|
|
# total is 0, percent is undefined.
|
||
|
|
$percent_str = "- - %" ;
|
||
|
|
} else {
|
||
|
|
$percent = 100.0 * $count / $total ;
|
||
|
|
$percent_str = sprintf("%5.1f %%", $percent) ;
|
||
|
|
}
|
||
|
|
$html_str .= "$count_str</td>" unless ($skip_tot) ;
|
||
|
|
$html_str .= "<td align=\"right\">" ;
|
||
|
|
$html_str .= "$percent_str</td>" ;
|
||
|
|
return $html_str ;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub Round_Per_Cent {
|
||
|
|
# Parameters
|
||
|
|
# $count - required, number for the cell, integer.
|
||
|
|
# $total - dividend for the percent, integer.
|
||
|
|
# Returned Value
|
||
|
|
# $PerCent - as an integer 0 to 100.
|
||
|
|
my ($count, $total) = @_ ;
|
||
|
|
my $PerCent ;
|
||
|
|
if ($total == 0) {
|
||
|
|
# total is 0, percent is undefined.
|
||
|
|
return 0 ;
|
||
|
|
} else {
|
||
|
|
$PerCent = ( int(((100.0 * $count) / $total) + 0.5 )) ;
|
||
|
|
}
|
||
|
|
return $PerCent ;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub ret_test_chooser_mod {
|
||
|
|
# Return strings of html to pick a survey.
|
||
|
|
# The parameter is an array of arrays with test descriptions and ids.
|
||
|
|
# The returned value is an array with two strings.
|
||
|
|
# The first string is JavaScript for the test chooser.
|
||
|
|
# The second string is html for the tables to drive the test chooser.
|
||
|
|
my @trecs = @_;
|
||
|
|
# print STDERR Dumper(\@trecs) ;
|
||
|
|
my ($testscompleted, $testsinprogress, $testspending, $href, $tstoption, $tstoptions);
|
||
|
|
$tstoptions = "" ;
|
||
|
|
my $html_str = "" ;
|
||
|
|
my $js = "function setTest(oform,test) {\n\t".
|
||
|
|
"oform.tstid.value=test;\n\t".
|
||
|
|
"oform.submit();\n};\n";
|
||
|
|
for (0 .. $#trecs) {
|
||
|
|
my ($desc,$id) ;
|
||
|
|
$desc = $trecs[$_][0] ;
|
||
|
|
$id = $trecs[$_][1] ;
|
||
|
|
# warn "RET_TEST_CHOOSER_MOD ID $id DESC $desc X" ;
|
||
|
|
$testscompleted = CountTestFiles($testcomplete,$CLIENT{'clid'},$id);
|
||
|
|
$testsinprogress = CountTestFiles($testinprog, $CLIENT{'clid'},$id);
|
||
|
|
$testspending = CountTestFiles($testpending, $CLIENT{'clid'},$id);
|
||
|
|
$href="javascript:setTest(document.testform1,\'$id\')\;";
|
||
|
|
my $radio_tst_button ;
|
||
|
|
$radio_tst_button = '<input type="radio" name="tstid" value="' . $id .
|
||
|
|
'" > ' . $id ;
|
||
|
|
$tstoption = " <TR>" .
|
||
|
|
# "<TD valign=top><FONT SIZE=2><a href=\"$href\">$id</a></FONT></TD>" .
|
||
|
|
"<TD valign=top><FONT SIZE=2>$radio_tst_button</FONT></TD>" .
|
||
|
|
"<TD valign=top><FONT SIZE=2>$desc</FONT></TD>" .
|
||
|
|
"<TD align=right valign=top><FONT SIZE=2>$testscompleted</FONT></TD>" .
|
||
|
|
"<TD align=right valign=top><FONT SIZE=2>$testsinprogress</FONT></TD>" .
|
||
|
|
"<TD align=right valign=top><FONT SIZE=2>$testspending</FONT></TD> </TR>\n";
|
||
|
|
# $tstoptions = join('', $tstoptions, $tstoption);
|
||
|
|
$tstoptions .= $tstoption ;
|
||
|
|
}
|
||
|
|
$html_str = "<CENTER><B>Please choose the survey for which you would like reports:</B><br>" .
|
||
|
|
# "<form name=\"testform1\" action=\"/cgi-bin/creports.pl\" method=\"Post\">" .
|
||
|
|
# "<input type=\"hidden\" name=\"tid\" value=\"$SESSION{'tid'}\">" .
|
||
|
|
# "<input type=\"hidden\" name=\"tstid\" value=\"\">" .
|
||
|
|
# "<input type=hidden name=\"rptno\" value=\"$FORM{'rptno'}\">" .
|
||
|
|
# "</form>" .
|
||
|
|
"<TABLE cellpadding=1 cellspacing=1 border=0 width=\"100\%\">" .
|
||
|
|
"<TR><TD colspan=5><HR WIDTH=\"100\%\"></TD></TR>" .
|
||
|
|
"<TR>" .
|
||
|
|
"<TD valign=top><B><FONT SIZE=1>Test ID</FONT></B></TD>" .
|
||
|
|
"<TD valign=top><B><FONT SIZE=1>Description</FONT></B></TD>" .
|
||
|
|
"<TD align=right valign=top><B><FONT SIZE=1>Cmp</FONT></B></TD>" .
|
||
|
|
"<TD align=right valign=top><B><FONT SIZE=1>InP</FONT></B></TD>" .
|
||
|
|
"<TD align=right valign=top><B><FONT SIZE=1>Pnd</FONT></B></TD>" .
|
||
|
|
"</TR>" .
|
||
|
|
"<TR><TD colspan=5><HR WIDTH=\"100\%\"></TD></TR>" .
|
||
|
|
$tstoptions .
|
||
|
|
"<TR><TD colspan=5><HR WIDTH=\"100\%\"></TD></TR>" .
|
||
|
|
"</TABLE> " ;
|
||
|
|
return ($js, $html_str) ;
|
||
|
|
}
|
||
|
|
|
||
|
|
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}
|
||
|
|
use vars qw($FULL_HISTORY) ;
|
||
|
|
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);
|
||
|
|
use vars qw(%GRPFIELD) ; # Global variable set by get_client_groups.
|
||
|
|
my $GroupID_HREF = {} ;
|
||
|
|
my $idxid = $GRPFIELD{'grpid'};
|
||
|
|
my @GroupFieldIDs = sort 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 ; my $candidates ;
|
||
|
|
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 GetTGWallLikertGrpData {
|
||
|
|
# Parameters
|
||
|
|
# $client - required String, client id.
|
||
|
|
# VOID $testid1 - required String, test id.
|
||
|
|
# VOID $candidate1 - required String, candidate id, testid1 is candidate1's self evaluation.
|
||
|
|
# $testid2 - required String, test id of the evaluation of candidate1 by others; the members of the
|
||
|
|
# groups in grplist.
|
||
|
|
# $grplist - required Hash reference, keys are group ids, values are like getGroups function.
|
||
|
|
# The values contain the candidate ids in the group.
|
||
|
|
# if undef. then only one returned value.
|
||
|
|
# $respRequired - optional boolean, default is false. If true then do not count unanswered questions
|
||
|
|
# as points available.
|
||
|
|
|
||
|
|
# Returned values - $ret_all, $ret_grp, $ret_err
|
||
|
|
# $ret_all - 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 'Questions'. 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. Values for candidates will be counted here regardless of
|
||
|
|
# group membership. The value of 'Questions' is an un-named hash. The keys of the un-named
|
||
|
|
# hash are the question numbers for the supercategory. The value is always 1.
|
||
|
|
# $ret_grp - reference to a Hash of a Hash of a Hash. The keys of the first hash are
|
||
|
|
# the group ids. The values are structured like $ret_all. This is not returned if
|
||
|
|
# the parameter $grplist is not provided, or undef.
|
||
|
|
# $ret_all, and $ret_grp contain results and scores for $testid2 taken by members of $grplist.
|
||
|
|
# $ret_err - string. - It is either an empty string or text about likert categoies not matching,
|
||
|
|
# or question counts not matching.
|
||
|
|
# Populate $QUESTION_AG with questions, responses, and comments for $testid2 and $grplist.
|
||
|
|
|
||
|
|
my ($client, $testid2, $grplist, $respRequired) = @_ ;
|
||
|
|
my $HBI_Debug_Groups = 0 ;
|
||
|
|
warn "INFO: GetTGWallLikertGrpData parms client $client, testid2 $testid2, respRequired $respRequired \n" if ($HBI_Debug_Groups) ;
|
||
|
|
warn "INFO: grplist\n" if ($HBI_Debug_Groups) ;
|
||
|
|
warn &Dumper(\$grplist) if ($HBI_Debug_Groups) ;
|
||
|
|
my $grp_req = 1 ;
|
||
|
|
# warn "grp_req $grp_req X\n" ;
|
||
|
|
my $ret_all = {} ; my $ret_grp = {} ; my $ret_one = {} ; my $ret_err = "" ;
|
||
|
|
my %Group_Xref = () ; # List of groups that each member belongs to.
|
||
|
|
# The hash key is a member id, the value is an array of the groups he is in.
|
||
|
|
# Build the cross reference.
|
||
|
|
my %Group_XrefP = () ; # Hash of groups that each member belongs to.
|
||
|
|
# It is a hash of a hash.
|
||
|
|
my $Group = "" ; my $Member = "" ;
|
||
|
|
warn "INFO: grplist SIMPLE.\n" if ($HBI_Debug_Groups) ;
|
||
|
|
foreach $Group (keys %{$grplist}) {
|
||
|
|
warn "INFO: Processing group $Group\n" if ($HBI_Debug_Groups) ;
|
||
|
|
foreach $Member (@{${$grplist}{$Group}{'grplist'}}) {
|
||
|
|
warn "INFO: $Member is a member of group $Group\n" if ($HBI_Debug_Groups) ;
|
||
|
|
push @{$Group_Xref{$Member}} , $Group ;
|
||
|
|
$Group_XrefP{$Member}->{$Group} = 1 ;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# warn Dumper(\%Group_Xref) ;
|
||
|
|
my %supercat_foundg = () ;
|
||
|
|
# hash of categories found and initialized in the hash of hashes for groups.
|
||
|
|
# PROCESS GROUPS and testid2
|
||
|
|
|
||
|
|
my %supercat_found_in_G = () ;
|
||
|
|
# hash of categories found and initialized in the hash of hashes in test2 for groups.
|
||
|
|
&get_test_profile($client, $testid2) ; # Populates %TEST
|
||
|
|
$QUESTIONS_AG = &get_question_definitions ($client, $testid2) ;
|
||
|
|
# Populates an array of hashs that contains all of the questions and the answers.
|
||
|
|
# $QUESTIONS_AG is a reference to the arrays of hashs.
|
||
|
|
my $last_index_g = $#{$QUESTIONS_AG} ; # Last index of the Array of Hashs of the Q&A.
|
||
|
|
my @filelist = &main::get_test_result_files($main::testcomplete, $client,$testid2);
|
||
|
|
# warn "INFO: QUESTIONS_AG\n" if ($HBI_Debug_Groups) ;
|
||
|
|
# warn &Dumper(\$QUESTIONS_AG) if ($HBI_Debug_Groups) ;
|
||
|
|
warn "INFO: filelist\n" if ($HBI_Debug_Groups) ;
|
||
|
|
warn &Dumper(\@filelist) if ($HBI_Debug_Groups) ;
|
||
|
|
my $file ;
|
||
|
|
my @HBI_Debug_Feedback = (0, 0, 0, 0, 0) ;
|
||
|
|
warn "INFO: Group Required flag is $grp_req.\n" if ($HBI_Debug_Feedback[0]) ;
|
||
|
|
foreach $file (@filelist) {
|
||
|
|
my $user = $file;
|
||
|
|
# warn "length file is " . (length $file) . "\n" ;
|
||
|
|
$user =~ s/\s+$// ;
|
||
|
|
$user =~ s/\.$testid2$//; # Strip the test id off the end of the file name.
|
||
|
|
$user =~ s/^$client\.//; # Strip the client id off the start of the file name.
|
||
|
|
warn "file is $file user is $user testid2 is $testid2 client is $client \n"
|
||
|
|
if ($HBI_Debug_Feedback[1]) ;
|
||
|
|
my $user_grp = undef ;
|
||
|
|
my $inact_ques = 0; # Count of the inactive questions found.
|
||
|
|
# Do not process this user if group membership is required and not a member.
|
||
|
|
if ($grp_req and not $Group_Xref{$user}) {
|
||
|
|
warn "Skipped User $user X" if ($HBI_Debug_Feedback[1]) ;
|
||
|
|
next ;
|
||
|
|
}
|
||
|
|
# Update the FeedBack date if this user has taken the test later
|
||
|
|
# than the recorded time.
|
||
|
|
|
||
|
|
use vars qw($full_history_OK $FeedBackDateTime) ;
|
||
|
|
if ($full_history_OK) {
|
||
|
|
my @FeedBack_test_times ;
|
||
|
|
my $FeedBack_Test_Time ;
|
||
|
|
@FeedBack_test_times = keys %{$FULL_HISTORY->{$client}->{$testid2}->{$user}} ;
|
||
|
|
# warn "INFO: There are " . ($#FeedBack_test_times + 1) . " History times.\n";
|
||
|
|
foreach $FeedBack_Test_Time (@FeedBack_test_times) {
|
||
|
|
warn "FULL_HISTORY Error $FeedBack_Test_Time is not all numeric.\n" if ($FeedBack_Test_Time =~ m/\D/) ;
|
||
|
|
$FeedBackDateTime = $FeedBack_Test_Time if ($FeedBack_Test_Time > $FeedBackDateTime) ;
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
warn "FULL_HISTORY Error full_history_OK is false.\n" ;
|
||
|
|
}
|
||
|
|
# Process this desired candidate's test answers.
|
||
|
|
# warn "Process User $user X" ;
|
||
|
|
&get_test_sequence_for_reports($client, $user, $testid2) ;
|
||
|
|
# populates the Assoc. arrays %TEST_SESSION, %SUBTEST_QUESTIONS,
|
||
|
|
# %SUBTEST_ANSWERS, %SUBTEST_RESPONSES, and %SUBTEST_SUMMARY.
|
||
|
|
my ($responses , @responses, $index1) ;
|
||
|
|
$responses = $SUBTEST_RESPONSES{2} ;
|
||
|
|
@responses = split (/\&/, $responses) ;
|
||
|
|
shift @responses ; # Drop the empty element in front of the list.
|
||
|
|
foreach $index1 (0 .. $last_index_g) {
|
||
|
|
my ($response_g, $comment_g) ;
|
||
|
|
my $group ; my ($points, $weight, $ques_type, $scores, @Response_parts) ;
|
||
|
|
# Skip the question if it is inactive.
|
||
|
|
if (${$QUESTIONS_AG}[$index1]->{'qil'} eq "Y") {$inact_ques++ ; next ;}
|
||
|
|
# Get the data for a single question.
|
||
|
|
$points = ${$QUESTIONS_AG}[$index1]->{'pts'} ;
|
||
|
|
$weight = ${$QUESTIONS_AG}[$index1]->{'wght'} ;
|
||
|
|
$ques_type = ${$QUESTIONS_AG}[$index1]->{'qtp'} ;
|
||
|
|
$scores = ${$QUESTIONS_AG}[$index1]->{'scores'} ;
|
||
|
|
@Response_parts = split ('::', $responses[$index1], 2) ;
|
||
|
|
$response_g = $Response_parts[0] ;
|
||
|
|
$comment_g = $Response_parts[1] ;
|
||
|
|
chomp $response_g ; chomp $comment_g ;
|
||
|
|
$response_g = &RTFize($response_g) ;
|
||
|
|
$comment_g = &RTFize($comment_g) ;
|
||
|
|
my @Response_array ; my $Response_array_ref ;
|
||
|
|
my @Comment_array ; my $Comment_array_ref ;
|
||
|
|
my @Collected ; my $Collected_ref ;
|
||
|
|
if ($response_g =~ /^\s*$/) {
|
||
|
|
# Only White space.
|
||
|
|
@Response_array = () ;
|
||
|
|
} else {
|
||
|
|
# text for response.
|
||
|
|
@Response_array = split (/\<br\>/, $response_g) ;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ($comment_g =~ /^\s*$/) {
|
||
|
|
# Only White space.
|
||
|
|
@Comment_array = () ;
|
||
|
|
} else {
|
||
|
|
# text for response.
|
||
|
|
@Comment_array = split (/\<br\>/, $comment_g) ;
|
||
|
|
}
|
||
|
|
|
||
|
|
$response_g =~ s/\s*(\<br\>)+\s*/\\par /isg ;
|
||
|
|
$comment_g =~ s/\s*(\<br\>)+\s*/\\par /isg ;
|
||
|
|
${$QUESTIONS_AG}[$index1]->{'responses'} .= $response_g . "\n" if ($response_g) ;
|
||
|
|
${$QUESTIONS_AG}[$index1]->{'comments'} .= $comment_g . "\n" if ($comment_g) ;
|
||
|
|
unless (${$QUESTIONS_AG}[$index1]->{'QTX_Processed'}) {
|
||
|
|
my $testid2_qtx = ${$QUESTIONS_AG}[$index1]->{'qtx'} ;
|
||
|
|
chomp $testid2_qtx ;
|
||
|
|
$testid2_qtx = &RTFize($testid2_qtx) ;
|
||
|
|
$testid2_qtx =~ s/\s*(\<br\>)+\s*/\\par /isg ;
|
||
|
|
${$QUESTIONS_AG}[$index1]->{'qtx'} = $testid2_qtx ;
|
||
|
|
${$QUESTIONS_AG}[$index1]->{'QTX_Processed'} = 1 ;
|
||
|
|
}
|
||
|
|
my @scores ;
|
||
|
|
if ($ques_type eq "lik") {
|
||
|
|
# Likert style question.
|
||
|
|
my ($supercat) ;
|
||
|
|
@scores = split (/\,/ , $scores) ;
|
||
|
|
$supercat = ${$QUESTIONS_AG}[$index1]->{'supercat'} ;
|
||
|
|
unless ($supercat_foundg{$supercat}) {
|
||
|
|
# Initialize counters.
|
||
|
|
warn "Init all Cat $supercat\n" if ($HBI_Debug_Feedback[2]) ;
|
||
|
|
$ret_all->{$supercat}->{'PointsAvail'} = 0 ;
|
||
|
|
$ret_all->{$supercat}->{'NoResponses'} = 0 ;
|
||
|
|
$ret_all->{$supercat}->{'Responses'} = 0 ;
|
||
|
|
$ret_all->{$supercat}->{'PointsEarned'} = 0 ;
|
||
|
|
$ret_all->{$supercat}->{'ScoreCount'} = {} ;
|
||
|
|
$supercat_foundg{$supercat} = 1 ;
|
||
|
|
}
|
||
|
|
$ret_all->{$supercat}->{'Questions'}->{$index1-$inact_ques} = 1 ;
|
||
|
|
my @Groups = @{$Group_Xref{$user}} ;
|
||
|
|
warn "INFO: Groups cnt " . ($#Groups + 1) . "\n" if ($HBI_Debug_Feedback[2]) ;
|
||
|
|
foreach $group (@Groups) {
|
||
|
|
unless (defined $ret_grp->{$group}->{$supercat}) {
|
||
|
|
warn "Init all Cat $supercat Group $group user $user.\n" if ($HBI_Debug_Feedback[2]) ;
|
||
|
|
$ret_grp->{$group}->{$supercat}->{'PointsAvail'} = 0 ;
|
||
|
|
$ret_grp->{$group}->{$supercat}->{'NoResponses'} = 0 ;
|
||
|
|
$ret_grp->{$group}->{$supercat}->{'Responses'} = 0 ;
|
||
|
|
$ret_grp->{$group}->{$supercat}->{'PointsEarned'} = 0 ;
|
||
|
|
$ret_grp->{$group}->{$supercat}->{'ScoreCount'} = {} ;
|
||
|
|
}
|
||
|
|
} # foreach $group
|
||
|
|
my @Ans_Comment = split ('::', $responses[$index1-$inact_ques], 2) ;
|
||
|
|
$responses = $Ans_Comment[0] ;
|
||
|
|
my @individ ;
|
||
|
|
@individ = split(/\?/, $responses) ;
|
||
|
|
shift @individ ;
|
||
|
|
my $no_response = 1 ;
|
||
|
|
$ret_all->{$supercat}->{'PointsAvail'} += $points ;
|
||
|
|
foreach $group (@Groups) {
|
||
|
|
$ret_grp->{$group}->{$supercat}->{'PointsAvail'} += $points ;
|
||
|
|
}
|
||
|
|
my $index2 ;
|
||
|
|
foreach $index2 (0 .. $#scores) {
|
||
|
|
# Add the key for the score count to the hash.
|
||
|
|
unless (exists $ret_all->{$supercat}->{'ScoreCount'}->{$scores[$index2]}) {
|
||
|
|
$ret_all->{$supercat}->{'ScoreCount'}->{$scores[$index2]} = 0 ;
|
||
|
|
}
|
||
|
|
foreach $group (@Groups) {
|
||
|
|
unless (exists $ret_grp->{$group}->{$supercat}->{'ScoreCount'}->{$scores[$index2]}) {
|
||
|
|
$ret_grp->{$group}->{$supercat}->{'ScoreCount'}->{$scores[$index2]} = 0 ;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# warn "CHECKING CAT $supercat USER $user GRP @group RESP $responses \n" if $supercat eq "Improvement" ;
|
||
|
|
foreach $index2 (0 .. $#scores) {
|
||
|
|
if ($individ[$index2] ne "xxx" and $individ[$index2] ne "" and $individ[$index2] == $index2) {
|
||
|
|
# Answered this question.
|
||
|
|
warn "Scored CAT $supercat POINTS $scores[$index2] USER $user \n"
|
||
|
|
if ($HBI_Debug_Feedback[3]) ;
|
||
|
|
$ret_all->{$supercat}->{'PointsEarned'} += $scores[$index2] ;
|
||
|
|
$ret_all->{$supercat}->{'ScoreCount'}->{$scores[$index2]} ++ ;
|
||
|
|
foreach $group (@Groups) {
|
||
|
|
warn "Scored CAT $supercat POINTS $scores[$index2] USER $user GRP $group \n"
|
||
|
|
if ($HBI_Debug_Feedback[3]) ;
|
||
|
|
$ret_grp->{$group}->{$supercat}->{'PointsEarned'} += $scores[$index2] ;
|
||
|
|
$ret_grp->{$group}->{$supercat}->{'ScoreCount'}->{$scores[$index2]} ++ ;
|
||
|
|
}
|
||
|
|
$no_response = 0 ;
|
||
|
|
} # If answered.
|
||
|
|
} # foreach $index2
|
||
|
|
if ($no_response) {
|
||
|
|
# Add to the no response count.
|
||
|
|
$ret_all->{$supercat}->{'NoResponses'} ++ ;
|
||
|
|
foreach $group (@Groups) {
|
||
|
|
$ret_grp->{$group}->{$supercat}->{'NoResponses'} ++ ;
|
||
|
|
}
|
||
|
|
if ($respRequired) {
|
||
|
|
# Reduce the points avail if a response is required to count.
|
||
|
|
$ret_all->{$supercat}->{'PointsAvail'} -= $points ;
|
||
|
|
foreach $group (@Groups) {
|
||
|
|
$ret_grp->{$group}->{$supercat}->{'PointsAvail'} -= $points ;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
# Add to the response count.
|
||
|
|
$ret_all->{$supercat}->{'Responses'} ++ ;
|
||
|
|
foreach $group (@Groups) {
|
||
|
|
$ret_grp->{$group}->{$supercat}->{'Responses'} ++ ;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# Add comment to Collected_Replies.
|
||
|
|
if ($#Comment_array == -1) {
|
||
|
|
@Collected = () ;
|
||
|
|
} else {
|
||
|
|
push @Collected, undef ;
|
||
|
|
push @Collected, \@Comment_array ;
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
# Non-likert question.
|
||
|
|
@Collected = () ;
|
||
|
|
if ($#Response_array == -1) {
|
||
|
|
push @Collected, undef ;
|
||
|
|
} else {
|
||
|
|
push @Collected, \@Response_array ;
|
||
|
|
}
|
||
|
|
if ($#Comment_array == -1) {
|
||
|
|
push @Collected, undef ;
|
||
|
|
} else {
|
||
|
|
push @Collected, \@Comment_array ;
|
||
|
|
}
|
||
|
|
@Collected = () if (($#Response_array == -1) and ($#Comment_array == -1)) ;
|
||
|
|
}
|
||
|
|
# Save the collected references for all questions.
|
||
|
|
if ($#Collected > -1) {
|
||
|
|
$Collected_ref = \@Collected ;
|
||
|
|
push @{${$QUESTIONS_AG}[$index1]->{'Collected_Replies'}}, $Collected_ref ;
|
||
|
|
}
|
||
|
|
} # foreach question.
|
||
|
|
} # foreach file (i.e. candidate)
|
||
|
|
return ($ret_all, $ret_grp, $ret_err) ; # Return reference.
|
||
|
|
} # End of GetTGWallLikertGrpData
|
||
|
|
|
||
|
|
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 ;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
|