#!/usr/bin/perl
# Source File: likert_wall_108.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 Team Trust Report",$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 Team Trust Report</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 Team 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\>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) ;
# 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 = () ;
my $Data1_Bar_count = 0 ;
$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 ;
# $Data1_Bar_count += $#{$Category_ARef} ;
# $Data1_Bar_count ++ ;
#G Drop putting the by group numbers into the chart.
#G foreach $Chart_Group (@All_Groups) {
#G # Create the graph for the Group
#G # $Category_ARef2 ;
#G $Category_ARef2 = [] ;
#G foreach $supercat (@supercats) {
#G push @{$Category_ARef2}, $ByGroup->{$Chart_Group}->{$supercat} ;
#G }
#G push @{$Category_ARef2}, $ByGroupTot->{$Chart_Group} ;
#G push @{$Data1}, $Category_ARef2 ;
#G push @{$Legend1}, $MasterGroupHash->{$Chart_Group}->{'grpnme'} ;
#G }
$Category_ARef2 = [] ;
foreach $supercat (@supercats) {
push @{$Category_ARef2}, $OverAll->{$supercat} ;
}
push @{$Category_ARef2}, $ByTotTot ;
push @{$Data1}, $Category_ARef2 ;
$Data1_Bar_count += $#{$Category_ARef2} ;
$Data1_Bar_count ++ ;
push @{$Legend1}, "Overall" ;
my $Computed_Height = ($Data1_Bar_count * 24) + 72 ;
my $Computed_Height_Max = 9 * 72 ;
$Computed_Height = ($Computed_Height > $Computed_Height_Max) ? $Computed_Height_Max : $Computed_Height ;
# $Opts = {} ;
# $Opts->{'width'} = ( 6 * 72 ) ;
$Opts->{'height'} = $Computed_Height ;
# $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 ++) {
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 = "\\keep \\widctlpar " . $lCurly . "\\keepn " ;
my $suffix = "" ;
foreach $first_array_ref (@{$Reply_Array_ref}) {
my ($Rep_Arr_Ref, $Comment_Arr_Ref) = @{$first_array_ref} ;
push @Consolidated, $prefix ;
push @Consolidated, $lCurly . "\\b Response:\\par " . $rCurly ;
if (defined $Rep_Arr_Ref && ($#{$Rep_Arr_Ref} > -1)) {
# One or more elements/paragraphs in response.
foreach $second_array_ref (@$Rep_Arr_Ref) {
push @Consolidated, $second_array_ref . "\\par " ;
}
} else {
push @Consolidated, $lCurly . "\\b No Answer.\\par " . $rCurly ;
}
push @Consolidated, "\\par " . $lCurly . "\\b Comment:\\par " . $rCurly ;
if (defined $Comment_Arr_Ref && ($#{$Comment_Arr_Ref} > -1)) {
foreach $second_array_ref (@$Comment_Arr_Ref) {
push @Consolidated, $second_array_ref . "\\par " ;
}
} else {
push @Consolidated, $lCurly . "\\b No Comment.\\par " . $rCurly ;
}
my ($last_str) ;
$last_str = pop @Consolidated ;
push @Consolidated, $rCurly, "\\keep " . $last_str , "\\par " ;
} # End foreach @{$Reply_Array_Ref}
${$QUESTIONS_AG}[$index1]->{'responses_and_comments'} =
join ($Eol, @Consolidated) ;
} # end $index1 over all questions.
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_org\<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 "\<br\>\<br\>SYSTEM HASH ARRAY\<br\>\n" ;
foreach $key (sort keys (%SYSTEM)) {
print "KEY $key VAL", &HTML_Maybe_Hash_Key_value(\%SYSTEM,$key), "\<br\>\n" ;
}
print "\<br\>\<br\>END SYSTEM HASH ARRAY\<br\>\n" ;
}
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
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}_TTS_report.rtf\n\n";
&show_template("TGWall-TTSR-Team-Trust-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 = 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 $QUESTIONS_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) ; # HBIErr Why not $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 ; # my @Collected ;
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 ;
if (ref $Hash_value ) {
my $ret1 = Dumper ($Hash_value) ;
$ret_str = join ("<BR>\n", split ("\n", $ret1)) ;
}
return $ret_str ;
} else {
$ret_str = $Bold_str . "Value of the Key in the Hash is undefined." . $End_Bold_str ;
return $ret_str ;
}
}