#!/usr/bin/perl
#
# Source File: likert_wall_103.pl
#
# use strict;
# Get config
require 'sitecfg.pl';
require 'testlib.pl';
require 'tstatlib.pl';
require 'questionslib.pl';
use Data::Dumper;
use bargraph_pnm ;
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) ;
my $last_index, $HBI_Debug ;
$HBI_Debug = 1 ; # Controls output of Debugging Data.
$FORM{'frm'}="";
&app_initialize;
if ($HBI_Debug) {warn "INFO: " . __FILE__ . " running frm IS $FORM{'frm'} " ;}
# frm == 3 code will print all Content info.
unless ($FORM{'frm'} == '3') {
print "Content-Type: text/html\n\n";
$bDisplay = 1;
}
# LIKERT Scale Test Reports by Candidate
if (&get_session($FORM{'tid'})) {
&LanguageSupportInit();
$REPORT{'rptid'}="";
@rptdefs = &get_data("reports.$SESSION{'clid'}");
@lbls = split(/&/, $rptdefs[0]);
foreach $rptdef (@rptdefs) {
chomp ($rptdef);
@flds = split(/&/, $rptdef);
if ($flds[0] eq $FORM{'rptno'}) {
for $i (0 .. $#lbls) {
$REPORT{$lbls[$i]} = $flds[$i];
$i++;
}
}
}
if ($FORM{'frm'} == '1') {
&show_index_candidates;
} elsif ($FORM{'frm'} == '2') {
&show_index_tests;
} elsif ($FORM{'frm'} == '3') {
&show_detail;
} elsif ($FORM{'frm'} == '4') {
&show_filter_options;
} elsif ($FORM{'frm'} == '5') {
&ReportChooser ;
} else {
print "<HTML>\n";
# Most likely, this is frm == 0
print "<HEAD></HEAD>\n";
print "<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\"
TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\"
VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\">
</BODY>\n";
print "</HTML>\n";
}
} else {
warn __FILE__ . " running without a SESSION." ;
}
sub show_index_candidates {
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Exec Report $FORM{'rptno'}");
&get_client_profile($SESSION{'clid'});
print "<HTML>
<HEAD>
<TITLE>$REPORT{'rptid'} - $REPORT{'rptdesc'}</TITLE>
<SCRIPT language=\"JavaScript\">
<!--
window.onload=onWdwLoad;
function onWdwLoad() {
document.rptform1.cndnamesort.selectedIndex = -1;
document.rptform1.cndidsort.selectedIndex = -1;
}
function right(e) {
if (navigator.appName == 'Netscape' && (e.which == 3 || e.which == 2)) {
alert(\"$xlatphrase[473]\");
return false;
} else {
if (navigator.appName == 'Microsoft Internet Explorer' && (event.button == 2 || event.button == 3)) {
alert(\"$xlatphrase[473]\");
return false;
}
}
return true;
}
function nameSelect(f) {
var w=top.detail.rptdtl003.document.location;
f.cndidsort.selectedIndex = -1;
if (f.cndnamesort.selectedIndex != -1) {
w.replace(\"$urlroot/likert_wall_103.pl?lang=$SESSION{'lang'}&tid=$SESSION{'tid'}&frm=0\");
i=f.cndnamesort.selectedIndex;
f.cndid.value=f.cndnamesort.options[i].value;
f.submit();
return true;
}
}
function idSelect(f) {
var w=top.detail.rptdtl003.document.location;
f.cndnamesort.selectedIndex = -1;
if (f.cndidsort.selectedIndex != -1) {
w.replace(\"$urlroot/likert_wall_103.pl?lang=$SESSION{'lang'}&tid=$SESSION{'tid'}&frm=0\");
i=f.cndidsort.selectedIndex;
f.cndid.value=f.cndidsort.options[i].value;
f.submit();
return true;
}
}
document.onmousedown=right;
document.onmouseup=right;
if (document.layers) window.captureEvents(Event.MOUSEDOWN);
if (document.layers) window.captureEvents(Event.MOUSEUP);
window.onmousedown=right;
window.onmouseup=right;
// -->
</SCRIPT>
</HEAD>
<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\"
TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\"
VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\">
<FORM name=\"rptform1\" action=\"$cgiroot/likert_wall_103.pl\" METHOD=GET target=\"rpttidx003\">
<CENTER>
<TABLE cellpadding=0 cellspacing=0 border=0 width=100\%>
<input type=hidden name=\"tid\" value=\"$SESSION{'tid'}\">
<input type=hidden name=\"frm\" value=\"2\">
<input type=hidden name=\"rptno\" value=\"$FORM{'rptno'}\">
<input type=hidden name=\"cndid\" value=\"\">
<TR>
<TD ALIGN=\"center\">
<nobr>
<FONT COLOR=\"$SYSTEM{'HEADERCOLOR'}\">
<B>$REPORT{'rptid'} - $REPORT{'rptdesc'}</B><BR>
</FONT>
";
my @clrecs = &get_client_cnd_list($CLIENT{'clid'});
my @clnamesort=();
my @clidsort=();
my $namesort;
my $idsort;
my $mycreator;
my $imaregistrar = &get_a_key("cnd.$SESSION{'clid'}", $SESSION{'uid'}, "registrar");
for (1 .. $#clrecs) {
$clrecs[$_] =~ s/\n//g;
@cndrecs = split(/&/, $clrecs[$_]);
$id = $cndrecs[0];
$nmf = $cndrecs[3];
$nmm = $cndrecs[4];
$nml = $cndrecs[5];
$mycreator = $cndrecs[15];
unless (($id eq '') || ($nml eq '')) {
$namesort=join('&',$nml,$nmf,$nmm,$id);
if ($imaregistrar eq 'Y') {
if ($SESSION{'uid'} eq $mycreator) {
push @clnamesort, $namesort;
}
} else {
push @clnamesort, $namesort;
}
}
}
@clrecs = sort @clnamesort;
@clnamesort=();
print "Name:<SELECT name=\"cndnamesort\" onChange=\"return nameSelect(this.form)\">\n";
print "<OPTION value=\"-1\"> </OPTION>\n";
for (0 .. $#clrecs) {
($nml, $nmf, $nmm, $id) = split(/&/, $clrecs[$_]);
$idsort=join('&',$id,$nml,$nmf,$nmm);
push @clidsort, $idsort;
print "<OPTION value=\"$id\">$nml, $nmf $nmm ($id)</OPTION>\n";
}
print "</SELECT>\n";
@clrecs = sort @clidsort;
@clidsort=();
print "\ ID:<SELECT name=\"cndidsort\" onChange=\"return idSelect(this.form)\">\n";
print "<OPTION value=\"-1\"> </OPTION>\n";
for (0 .. $#clrecs) {
($id,$nml,$nmf,$nmm) = split(/&/, $clrecs[$_]);
print "<OPTION value=\"$id\">$id - $nml, $nmf $nmm\n";
}
print "</SELECT>\n";
@clrecs=();
print "</nobr>
</TD>
</TR>
</TABLE>
</FORM>
</CENTER>
</BODY>
</HTML>
";
}
sub show_index_tests {
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Exec Report $FORM{'rptno'}");
&get_client_profile($SESSION{'clid'});
&get_candidate_profile( $SESSION{'clid'}, $FORM{'cndid'});
my $style = "SELECT {\"width: 200px;height: 200px;font-size: 8pt;\"}";
print "<HTML>
<HEAD>
<TITLE>$REPORT{'rptid'} - $REPORT{'rptdesc'}</TITLE>
<SCRIPT language=\"JavaScript\">
<!--
window.onload=onWdwLoad;
function onWdwLoad() {
document.rptform1.tstid.selectedIndex = -1;
}
function right(e) {
if (navigator.appName == 'Netscape' && (e.which == 3 || e.which == 2)) {
alert(\"This source and all graphics are proprietary and may not be viewed or copied.\");
return false;
} else {
if (navigator.appName == 'Microsoft Internet Explorer' && (event.button == 2 || event.button == 3)) {
alert(\"This source and all graphics are proprietary and may not be viewed or copied.\");
return false;
}
}
return true;
}
function testSelect(f) {
if (f.tstsel.selectedIndex != -1) {
f.submit();
return true;
}
}
function clearOptions(f) {
var i,s,u,c;
u=\"\";
c=0;
f.multiple.value=\"0\";
for (i=0; i < f.tstsel.options.length; i++) {
if (f.tstsel.options[i].selected) {
if (u != \"\") {
u += \",\";
f.multiple.value=\"1\";
}
u += f.tstsel.options[i].value;
c++;
}
}
f.tstid.value=u;
if (c == 0) {
top.detail.rptdtl003.document.location.replace(\"$urlroot/likert_wall_103.pl?lang=$SESSION{'lang'}&tid=$SESSION{'tid'}&frm=0\");
return false;
} else {
f.submit();
return true;
}
}
document.onmousedown=right;
document.onmouseup=right;
if (document.layers) window.captureEvents(Event.MOUSEDOWN);
if (document.layers) window.captureEvents(Event.MOUSEUP);
window.onmousedown=right;
window.onmouseup=right;
// -->
</SCRIPT>
</HEAD>
<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\"
TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\"
VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\">
<FORM name=\"rptform1\" action=\"$cgiroot/likert_wall_103.pl\"
METHOD=GET target=\"rptdtl003\">
<CENTER>
<TABLE cellpadding=0 cellspacing=0 border=0 width=100\%>
<input type=hidden name=\"tid\" value=\"$SESSION{'tid'}\">
<input type=hidden name=\"frm\" value=\"4\">
<input type=hidden name=\"rptno\" value=\"$FORM{'rptno'}\">
<input type=hidden name=\"cndid\" value=\"$FORM{'cndid'}\">
<input type=hidden name=\"clid\" value=\"$CLIENT{'clid'}\">
<input type=hidden name=\"tstid\" value=\"\">
<input type=hidden name=\"multiple\" value=\"0\">
<TR>
<TD ALIGN=\"center\">
<nobr>
<FONT COLOR=\"$SYSTEM{'HEADERCOLOR'}\" SIZE=2>
<B>$CANDIDATE{'nml'}, $CANDIDATE{'nmf'} $CANDIDATE{'nmm'}</B><BR>
</FONT>
<nobr>
</TD>
</TR>
<TR>
<TD ALIGN=\"center\">
";
my @trecs = &get_test_list($CLIENT{'clid'});
my @tmptrecs = ();
for (1 .. $#trecs) {
($id, $desc) = split(/&/, $trecs[$_]);
$trecs[$_] = join('&', "$desc", "$id");
push @tmptrecs, $trecs[$_];
}
@trecs = sort @tmptrecs;
print "\t\t<SELECT name=\"tstsel\" size=\"8\" Height=200 Width=200 onChange=\"return clearOptions(this.form)\">\n";
for (0 .. $#trecs) {
($desc,$id) = split(/&/, $trecs[$_]);
$testscompleted = CountHistoricTests($testcomplete,$CLIENT{'clid'},$id,$FORM{'cndid'});
if ($testscompleted == 0) {
$testscompleted = CountTestFilesByCnd($testcomplete,$CLIENT{'clid'},$id,$FORM{'cndid'});
}
$testsinprogress = CountTestFilesByCnd($testinprog, $CLIENT{'clid'},$id,$FORM{'cndid'});
$testspending = CountTestFilesByCnd($testpending, $CLIENT{'clid'},$id,$FORM{'cndid'});
if (($testsinprogress != 0) || ($testspending != 0) || ($testscompleted != 0)) {
print "\t\t\t<OPTION value=\"$id\">$testscompleted-$testsinprogress-$testspending $desc\n";
}
}
print "\t\t</SELECT>
</TD>
</TR>
<TR>
<TD ALIGN=\"center\">
<FONT COLOR=\"$SYSTEM{'HEADERCOLOR'}\" SIZE=2>
<!-- Text under the list of tests taken by the candidate. -->
</FONT>
<!--
<INPUT TYPE=BUTTON name=\"show\" value=\"$xlatphrase[27]\" onClick=\"return testSelect(this.form)\">
-->
</TD>
</TR>
</TABLE>
</FORM>
</BODY>
</HTML>
";
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "3", "Exec Report $FORM{'rptno'} completed");
}
sub show_filter_options {
my $cndid;
my $cndname;
my @testdates;
my $iopt;
my $optval;
my $optdesc;
my $lstdates;
my $qcor;
my $qinc;
my $tscore;
my $trash;
my $j;
my $i;
my @tests;
my @tmpdates;
my $jscript;
my $colspan;
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Report Options $FORM{'rptno'}");
&get_client_profile($SESSION{'clid'});
&get_candidate_profile( $SESSION{'clid'}, $FORM{'cndid'});
@tests = split(/\,/,$FORM{'tstid'});
$cndname = join('', $CANDIDATE{'nml'}, ", ", $CANDIDATE{'nmf'}, " ", $CANDIDATE{'nmm'});
$cndid = $CANDIDATE{'uid'};
$lstdates = "<SELECT name=tdatesel size=10 >\n";
$jscript="var s=new Array();\n";
if ($FORM{'multiple'} ne '1') {
$testdescriptions = "$FORM{'tstid'} - $TEST{'desc'}\<br\>";
&get_test_profile($CLIENT{'clid'}, $FORM{'tstid'});
@testdates = getHistoricTests($testcomplete,$CLIENT{'clid'},$FORM{'tstid'},$FORM{'cndid'});
for $iopt (0 .. $#testdates) {
$j=$#testdates-$iopt;
($optval,$qcor,$qinc,$tscore) = split(/&/, $testdates[$j]);
$optdesc = $optval;
$optval =~ s/ /_/g;
#$optdesc =~ s/ GMT//g;
if ($TEST{'seq'} eq 'std') {
$lstdates = join('',$lstdates,"<OPTION value=\"$optval\">$optdesc\ ($tscore)\n");
$jscript = join('',$jscript,"s[$iopt]=$tscore;\n");
} else {
$lstdates = join('',$lstdates,"<OPTION value=\"$optval\">$optdesc</OPTION>\n");
}
}
} else {
$iopt=0;
$testdescriptions = "";
for $i (0 .. $#tests) {
if ($tests[$i] ne '') {
&get_test_profile($CLIENT{'clid'}, $tests[$i]);
@tmpdates = getHistoricTests($testcomplete,$CLIENT{'clid'},$tests[$i],$FORM{'cndid'});
if ($iopt > 0) {
$testdescriptions = join(', ',$testdescriptions,"<nobr>$tests[$i] - $TEST{'desc'}</nobr>");
} else {
$testdescriptions = join('',$testdescriptions,"<nobr>$tests[$i] - $TEST{'desc'}</nobr>");
}
if ($#tmpdates != -1) {
$j=$#tmpdates;
$testdates[$iopt]=$tmpdates[$j];
($optval,$qcor,$qinc,$tscore) = split(/&/, $tmpdates[$j]);
$optdesc = $optval;
$optval =~ s/ /_/g;
$optval = join('+',$optval,$TEST{'id'});
#$optdesc =~ s/ GMT//g;
$optdesc = join(' ',$optdesc,$TEST{'id'});
if ($TEST{'seq'} eq 'std') {
$lstdates = join('',$lstdates,"<OPTION value=\"$optval\">$optdesc\ ($tscore)\n");
$jscript = join('',$jscript,"s[$iopt]=$tscore;\n");
$iopt++;
} else {
$lstdates = join('',$lstdates,"<OPTION value=\"$optval\">$optdesc\n");
}
}
}
}
}
$lstdates = join('',$lstdates,"</SELECT>\n");
$styles = "SELECT {\"font-size: 8pt;\"}\n";
$styles = join('',$styles,"INPUT {\"font-size: 8pt;height: 20px;\"}\n");
print "<HTML>
<HEAD>
<TITLE>$REPORT{'rptid'} - $REPORT{'rptdesc'}</TITLE>
<SCRIPT language=\"JavaScript\">
<!--
$jscript
function wdwOnLoad() {
var f;
f=document.rptform1;
f.onsubmit=submitMe;
f.tdatesel.focus();
selall(f);
}
function submitMe() {
var f;
var bok = false;
f = document.rptform1;
f.testdates.value=\"\";
for (i=0; i < f.tdatesel.options.length; i++) {
if (f.tdatesel.options[i].selected) {
bok = true;
f.testdates.value += \",\";
f.testdates.value += f.tdatesel.options[i].value;
}
}
if (bok) {
f.testdates.value += \",\";
} else {
alert(\"You must select at least one test date.\");
f.tdatesel.focus();
}
return bok;
}
function selall(f) {
var i;
for (i=0; i < f.tdatesel.options.length; i++) {
f.tdatesel.options[i].selected = true;
}
return false;
}
function deselall(f) {
var i;
for (i=0; i < f.tdatesel.options.length; i++) {
f.tdatesel.options[i].selected = false;
}
return false;
}
function selscores(f,j) {
var i,n,h,l,nh,nl;
if (j == 11) {
n=0;
j=0;
for (i=0; i < f.tdatesel.options.length; i++) {
if (s[i] > n) {
j=i;
n=s[i];
}
}
f.tdatesel.selectedIndex=j;
} else {
selall(f);
if (j == 12) {
nl=101;
for (i=f.tdatesel.options.length-1; i >= 0; i--) {
if (s[i] < nl) {
l=i;
nl=s[i];
}
}
f.tdatesel.options[l].selected=false;
} else {
nh=0;
nl=101;
for (i=f.tdatesel.options.length-1; i >= 0; i--) {
if (s[i] > nh) {
h=i;
nh=s[i];
}
}
for (i=f.tdatesel.options.length-1; i >= 0; i--) {
if (i != h) {
if (s[i] < nl) {
l=i;
nl=s[i];
}
}
}
f.tdatesel.options[l].selected=false;
f.tdatesel.options[h].selected=false;
}
}
return false;
}
function right(e) {
if (navigator.appName == 'Netscape' && (e.which == 3 || e.which == 2)) {
alert(\"This source and all graphics are proprietary and may not be viewed or copied.\");
return false;
} else {
if (navigator.appName == 'Microsoft Internet Explorer' && (event.button == 2 || event.button == 3)) {
alert(\"This source and all graphics are proprietary and may not be viewed or copied.\");
return false;
}
}
return true;
}
document.onmousedown=right;
document.onmouseup=right;
if (document.layers) window.captureEvents(Event.MOUSEDOWN);
if (document.layers) window.captureEvents(Event.MOUSEUP);
window.onmousedown=right;
window.onmouseup=right;
window.onload=wdwOnLoad;
// -->
</SCRIPT>
</HEAD>
<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\"
TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\"
VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\">
<FORM name=\"rptform1\" action=\"$cgiroot/likert_wall_103.pl\" METHOD=GET TARGET=\"rptTstGroups003\">
<input type=hidden name=\"tid\" value=\"$SESSION{'tid'}\">
<input type=hidden name=\"frm\" value=\"5\">
<input type=hidden name=\"rptno\" value=\"$FORM{'rptno'}\">
<input type=hidden name=\"tstid\" value=\"$FORM{'tstid'}\">
<input type=hidden name=\"cndid\" value=\"$FORM{'cndid'}\">
<input type=hidden name=\"clid\" value=\"$FORM{'clid'}\">
<input type=hidden name=\"testdates\" value=\"\">
<input type=hidden name=\"multiple\" value=\"$FORM{'multiple'}\">
<CENTER>
<TABLE cellpadding=0 cellspacing=0 border=0 width=100\%>
<TR>
<TD ALIGN=\"left\" valign=\"top\">
<FONT COLOR=\"$SYSTEM{'HEADERCOLOR'}\" SIZE=1>
$testdescriptions
</FONT>
</TD>
</TABLE>
<TABLE cellpadding=0 cellspacing=0 border=1 width=100\%>
";
if ($TEST{'seq'} eq 'std') {
print "<TR>
<TD rowspan=4>
<TABLE cellpadding=0 cellspacing=0 border=0 width=100\%>
<TR>
<TD align=\"center\">
<FONT COLOR=\"$SYSTEM{'HEADERCOLOR'}\" SIZE=2>
$xlatphrase[687]<br>
</font>
</TD>
</TR>
<TR>
<TD align=\"center\">
<FONT SIZE=2>
$lstdates</br>
</font>
</TD>
</TR>
</TABLE>
</TD>
</TR>
";
$colspan="colspan=2";
} else {
print "<TR>
<TD>
<TABLE cellpadding=0 cellspacing=0 border=0 width=100\%>
<TR>
<TD align=\"center\">
<FONT COLOR=\"$SYSTEM{'HEADERCOLOR'}\" SIZE=2>
$xlatphrase[687]<br>
</font>
</TD>
</TR>
<TR>
<TD align=\"center\">
<FONT SIZE=2>
$lstdates</br>
</font>
</TD>
</TR>
</TABLE>
</TD>
</TR>
";
$colspan="";
}
print "<TR>
<TD $colspan ALIGN=\"center\">
<font size=2>
";
$testspending = CountTestFilesByCnd($testpending, $CLIENT{'clid'},$id,$FORM{'cndid'});
if ($testspending > 0) {
print "
Print\ \; <A HREF=\"$cgiroot/tmaster.pl?tid=$SESSION{'tid'}&clid=$CLIENT{'clid'}&cndid=$CANDIDATE{'uid'}&tstid=$TEST{'id'}\" TARGET=\"prtwindow\">Master/Key</A>";
}
print "\ <br>
<INPUT type=\"submit\" name=\"submit\" value=\"$xlatphrase[709]\">
\ <br>
</font>
</TD>
</TR>
</TABLE>
</FORM>
</CENTER>
</BODY>
</HTML>
";
}
sub show_detail {
my @tentries;
my @tcols;
my $i;
my $j;
my $k;
my $loidx;
my $hiidx;
my $loscore;
my $hiscore;
my $avgscore;
my $avgcount;
my @testdates;
my @found;
my $sgrepfor;
my $bDisplay;
my $timetaken;
my $testtitle;
my $tstdate;
my $testid;
my @tmparray;
my @tmpdates;
my @Report_Groups ;
my $RTF_PNG_Begin ;
my $RTF_PNG_Close ;
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Exec Report $FORM{'rptno'}");
@Report_Groups = split(/\000/, $FORM{'idlist'}) ;
if ($HBI_Debug) {
print "Content-Type: text/html\n\n";
print "\<br\>\n" ;
print "\<br\>\<br\>SESSION HASH ARRAY\<br\>\n" ;
foreach $key (sort keys (%SESSION)) {
print "KEY $key VAL $SESSION{$key}\<br\>\n" ;
}
print "\<br\>\<br\>FORM HASH ARRAY\<br\>\n" ;
foreach $key (sort keys (%FORM)) {
print "KEY $key VAL $FORM{$key}\<br\>\n" ;
}
print "\<br\>\<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" ;
my $lookatit = $FORM{'idlist'} ;
$lookatit =~ tr/\000/,/ ;
print Dumper($lookatit) ;
print "\<br\>\<br\>\n" ;
}
unless ($SESSION{'clid'}) {
warn "No Client ID in the session.\n" ;
warn "Client ID in the FORM is $FORM{'clid'}\n" ;
print "No Client ID in the session.\n" ;
print "\<br\>\n" ;
exit 0 ;
}
&get_client_profile($SESSION{'clid'});
# populates the Assoc. array %CLIENT with data for the client id.
if ($HBI_Debug) {
print "\<br\>\<br\>CLIENT HASH ARRAY\<br\>\n" ;
foreach $key (sort keys (%CLIENT)) {
print "KEY $key VAL $CLIENT{$key}\<br\>\n" ;
}
}
unless ($FORM{'cndid'}) {
warn "No Candidate ID in the form.\n" ;
print "No Candidate ID in the form.\n" ;
print "\<br\>\n" ;
exit 0 ;
}
&get_candidate_profile( $SESSION{'clid'}, $FORM{'cndid'});
if ($HBI_Debug) {
print "\<br\>\<br\>CANDIDATE HASH ARRAY\<br\>\n" ;
foreach $key (sort keys (%CANDIDATE)) {
print "KEY $key VAL $CANDIDATE{$key}\<br\>\n" ;
}
}
# populates the Assoc. array %CANDIDATE with data for the candidate/user/student who took the test/survey.
# HBI - Go find the format of the test results.
# The original code supported multiple selected tests.
# This report does not support multiple tests.
unless ($CLIENT{'clid'}) {
warn "No Client ID in the CLIENT data.\n" ;
print "No Client ID in the CLIENT data.\n" ;
print "\<br\>\n" ;
exit 0 ;
}
unless ($FORM{'tstid'}) {
warn "No Test ID in the form.\n" ;
print "No Test ID in the form.\n" ;
print "\<br\>\n" ;
exit 0 ;
}
unless ($FORM{'tstid2'}) {
warn "No Group related Test ID in the form.\n" ;
print "No Group related Test ID in the form.\n" ;
print "\<br\>\n" ;
exit 0 ;
}
&get_test_profile($CLIENT{'clid'}, $FORM{'tstid'});
# populates the Assoc. array %TEST with the characteristics of the test (but not the questions or answers).
unless ($FORM{'cndid'}) {
warn "No Candidate ID in the form.\n" ;
print "No Candidate ID in the form.\n" ;
print "\<br\>\n" ;
exit 0 ;
}
$foo = get_test_sequence_for_reports($CLIENT{'clid'},$FORM{'cndid'}, $FORM{'tstid'});
# populates the Assoc. arrays %TEST_SESSION, %SUBTEST_QUESTIONS, %SUBTEST_ANSWERS, %SUBTEST_RESPONSES,
# and %SUBTEST_SUMMARY.
if ($HBI_Debug) {
print "\<br\>\<br\>SYSTEM HASH ARRAY\<br\>\n" ;
foreach $key (sort keys (%SYSTEM)) {
print "KEY $key VAL $SYSTEM{$key}\<br\>\n" ;
}
print "\<br\>\<br\>CLIENT HASH ARRAY\<br\>\n" ;
foreach $key (sort keys (%CLIENT)) {
print "KEY $key VAL $CLIENT{$key}\<br\>\n" ;
}
print "\<br\>\<br\>TEST HASH ARRAY\<br\>\n" ;
foreach $key (sort keys (%TEST)) {
print "KEY $key VAL $TEST{$key}\<br\>\n" ;
}
print "\<br\>\<br\>TEST_SESSION HASH ARRAY\<br\>\n" ;
foreach $key (sort keys (%TEST_SESSION)) {
print "KEY $key VAL $TEST_SESSION{$key}\<br\>\n" ;
}
print "\<br\>\<br\>SUBTEST_QUESTIONS HASH ARRAY\<br\>\n" ;
foreach $key (sort keys (%SUBTEST_QUESTIONS)) {
print "KEY $key VAL $SUBTEST_QUESTIONS{$key}\<br\>\n" ;
}
print "\<br\>\<br\>SUBTEST_ANSWERS HASH ARRAY\<br\>\n" ;
foreach $key (sort keys (%SUBTEST_ANSWERS)) {
print "KEY $key VAL $SUBTEST_ANSWERS{$key}\<br\>\n" ;
}
print "\<br\>\<br\>SUBTEST_RESPONSES HASH ARRAY\<br\>\n" ;
foreach $key (sort keys (%SUBTEST_RESPONSES)) {
print "KEY $key VAL $SUBTEST_RESPONSES{$key}\<br\>\n" ;
}
print "\<br\>\<br\>SUBTEST_SUMMARY HASH ARRAY\<br\>\n" ;
foreach $key (sort keys (%SUBTEST_SUMMARY)) {
print "KEY $key VAL $SUBTEST_SUMMARY{$key}\<br\>\n" ;
}
} # end of if $HBI_Debug
my %supercat_total = () ; # Total points available for a category.
my %supercat_earned = () ; # Points earned for a category.
my %TGWall_Comments = () ; # Collected Text for questions and comments in a category.
my %TGWall_Comments_fnd = () ; # Collected Text for questions and comments in a category.
# The following values have a similar name, and are logically connected.
my $SUPERCAT_TOTAL = 0 ; # Total points available in all categories.
my $SUPERCAT_EARNED = 0 ; # Total points earned in all categories.
my $points, $weight, @scores, @correct_ans, @incorrect_ans, @all_ans ;
my $ques_type, $supercat, $scores, @responses, $responses ;
my @individ, $individ, @img_labels, @img_data , @Response_parts;
my $client = $SESSION{'clid'} ;
my $testid = $FORM{'tstid'} ;
my $candidate = $FORM{'cndid'} ;
my $testid2 = $FORM{'tstid2'} ;
my $grplist = () ;
my $groupid ;
foreach $groupid (@Report_Groups) {
$grplist{$groupid} = [ &get_group_cnds($client,$groupid)] ;
}
my ($ret_all, $ret_grp, $ret_one, $ret_err) =
&GetTGWallLikertGrpData($client, $testid, $candidate, $testid2, $grplist, 1) ;
$SYSTEM{'ALL_Comments'} = "" ;
$responses = $SUBTEST_RESPONSES{2} ;
@responses = split (/\&/, $responses) ;
shift @responses ; # Drop the empty element in front of the list.
$last_index = $#{$QUESTIONS_AH} ; # Last index of the Array of Hashs of the Q&A.
if ($last_index == -1) {
print "\<br\>\n" if ($HBI_DEBUG) ;
print "\<br\>\<br\>No Questions in the test.\<br\>\n" if ($HBI_DEBUG) ;
print "\<br\>\n" if ($HBI_DEBUG) ;
warn "ERROR: No Questions in the test." ;
} else {
foreach $index1 (0 .. $last_index) {
# Get the data for a single question.
$points = ${$QUESTIONS_AH}[$index1]->{'pts'} ;
$weight = ${$QUESTIONS_AH}[$index1]->{'wght'} ;
$ques_type = ${$QUESTIONS_AH}[$index1]->{'qtp'} ;
$scores = ${$QUESTIONS_AH}[$index1]->{'scores'} ;
@scores = split (/\,/ , $scores) ;
$supercat = ${$QUESTIONS_AH}[$index1]->{'supercat'} ;
# Populate the responses for all the questions.
@Response_parts = split ('::', $responses[$index1], 2) ;
${$QUESTIONS_AH}[$index1]->{'responses'} = $Response_parts[0] ;
${$QUESTIONS_AH}[$index1]->{'comments'} = $Response_parts[1] ;
# Parse out any HTML line breaks.
${$QUESTIONS_AH}[$index1]->{'responses'} =~ s/\s*\<br\>\s*/ /isg ;
${$QUESTIONS_AH}[$index1]->{'comments'} =~ s/\s*\<br\>\s*/ /isg ;
if ($ques_type eq "lik") {
$supercat_total{$supercat} += $points ;
$SUPERCAT_TOTAL += $points ;
$responses = $responses[$index1] ;
@individ = split(/\?/, $responses) ;
shift @individ ;
foreach $index2 (0 .. $#scores) {
print "\<br\>index2 $index2 individ elem $individ[$index2] scores elem $scores[$index2]\n" if $HBI_Debug ;
if ($individ[$index2] ne "xxx" and $individ[$index2] ne "" and $individ[$index2] == $index2) {
$supercat_earned{$supercat} += $scores[$index2] ;
$SUPERCAT_EARNED += $scores[$index2] ;
print "\<br\>supercat $supercat responses $responses index1 $index1 index2 $index2 \<br\>\n" if $HBI_Debug ;
}
}
# Collect the questions and comments.
unless ($TGWall_Comments{$supercat}) {
# First time found the category.
$TGWall_Comments{$supercat} = "\\par CATEGORY - $supercat\n" ;
$TGWall_Comments{$supercat} .= "\\par \n" ;
}
if ($Response_parts[1] =~ m/\S/) {
# The question has a comment.
$TGWall_Comments{$supercat} .= "\\par Question " . ($index1 + 1) . " - " ;
$TGWall_Comments{$supercat} .= ${$QUESTIONS_AH}[$index1]->{'qtx'} . "\n" ;
$TGWall_Comments{$supercat} .= "\\par " . ${$QUESTIONS_AH}[$index1]->{'comments'} . "\n" ;
$TGWall_Comments_fnd{$supercat} = 1 ;
}
} # end of if $ques_type
} # end foreach $index1
foreach $supercat (sort keys %TGWall_Comments) {
unless ($TGWall_Comments_fnd{$supercat}) {
$TGWall_Comments{$supercat} .= "\\par NO Comments.\n" ;
}
$SYSTEM{'ALL_Comments'} .= $TGWall_Comments{$supercat} ;
}
$SYSTEM{'Graphic_Text'} = "\\par \n" ;
$SYSTEM{'Graphic_Text'} .= "Candidate: $CANDIDATE{'nmf'} " ;
if ($CANDIDATE{'nmm'}) {$SYSTEM{'Graphic_Text'} .= "$CANDIDATE{'nmm'} " ;}
$SYSTEM{'Graphic_Text'} .= "$CANDIDATE{'nml'}\n" ;
$CANDIDATE{'full_name'} = $CANDIDATE{'nmf'} . " " ;
$CANDIDATE{'full_name'} .= $CANDIDATE{'nmm'} . ". " if ($CANDIDATE{'nmm'}) ;
$CANDIDATE{'full_name'} .= $CANDIDATE{'nml'} ;
my $percent ;
@img_labels = () ;
@img_data = () ;
my $category_count = keys %supercat_total ; # The number of elements of %supercat_total
if ($category_count) {
foreach $rep (sort keys %supercat_total) {
$percent = int ((100.0 * $supercat_earned{$rep} / $supercat_total{$rep}) +0.5) ;
$SYSTEM{'Graphic_Text'} .= "\\par $rep Score: $percent\%\n" ;
push @img_labels, $rep ;
push @img_data, $percent ;
} # end of foreach $rep
push @img_labels, "Total" ;
$percent = int ((100.0 * $SUPERCAT_EARNED / $SUPERCAT_TOTAL) +0.5) ;
push @img_data, $percent ;
$SYSTEM{'Graphic_Text'} .= "\\par Total Score: $percent\%\n" ;
} else {
# $category_count is zero. No categories.
$SYSTEM{'Graphic_Text'} .= "\\par No Likert Scale Questions in the test.\n" ;
}
$SYSTEM{'Graphic_Text'} .= "\\par \n" ;
# The list parameters are: labels, values, and values2.
my (@values2, $xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum) ;
# The scalar parameters are: xdim, ydim, hbar, title, xlabel, ylabel, ymax, ymin, yticknum
@values2 = () ;
($xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum, $colorscheme) =
(500, 300, 1, "Scores", "Category", "Percent for Category", 100, 0, 10, 1) ;
($t_margin, $b_margin, $l_margin, $r_margin) = (0, 0, 0, 30) ;
$ydim = 150 + 30 * $#img_labels ;
my $Eol = "\r\n" ; my $lCurly = "\x7b" ; my $rCurly = "\x7d" ;
$RTF_PNG_Begin = $lCurly . '\\*\\shppict' ;
$RTF_PNG_Begin .= $lCurly . '\\pict\\pngblip' ;
$RTF_PNG_Begin .= "\\picw${xdim} " ; # Width in pixels
$RTF_PNG_Begin .= "\\pich${ydim} " ; # Height in pixels
$RTF_PNG_Begin .= "\\picwgoal" . (${xdim}*20) ; # width on the page in twips
$RTF_PNG_Begin .= "\\pichgoal" . (${ydim}*20) ; # Height on the page in twips.
$RTF_PNG_Begin .= $Eol ;
# I am using a pixel in a point. A point is 1/72 inches.
# A twip is 1/20 of a point.
$RTF_PNG_Begin .= "\\bliptag10000" ; # Unique identifier for the image.
$RTF_PNG_Begin .= $lCurly . '\\*\\blipuid ' ;
$RTF_PNG_Begin .= "00000000000000000000000000002710" ; # 32 numeric digits
$RTF_PNG_Begin .= $rCurly . $Eol ; # Ends blipuid.
$RTF_PNG_Close = $rCurly . $rCurly ; # Ends pict and shppict commands.
$RTF_PNG_Close .= $Eol ;
my $HBI_Debug_msg_str = "" ;
my $T_colors = "" ; # Normally this is a colon separated string of color names.
my $png_data = "" ;
$png_data = &Build_Graph_PNM(\@img_labels, $T_colors, \@img_data, undef,
$xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin,
$yticknum, $t_margin, $b_margin, $l_margin, $r_margin, $colorscheme)
unless ($HBI_Debug) ;
my $offset = 0 ;
my $length_line = 80 ;
my $len_left ;
my $part_data = "" ;
my $Hex_image = unpack ("H*", $png_data) ;
my $All_data_len = length $Hex_image ;
do {$len_left = $All_data_len - $offset ;
if ($len_left < $length_line) {$length_line = $len_left;}
$part_data .= substr($Hex_image, $offset, $length_line) ;
$part_data .= $Eol ;
$offset += $length_line ;
} while ($offset < $All_data_len ) ;
$HBI_Debug_msg_str .= " Graph HBI \\par \n" ;
$HBI_Debug_msg_str .= "Num. of labels " . $#img_labels . "\\par \n" ;
$HBI_Debug_msg_str .= "Num. of points " . $#img_data . "\\par \n" ;
$HBI_Debug_msg_str .= "Num. of phg data chars " . (length $png_data) . "\\par \n" ;
$HBI_Debug_msg_str .= "Num. of part data chars " . (length $part_data) . "\\par \n" ;
$SYSTEM{'Bargraph1'} = $RTF_PNG_Begin . $part_data . $RTF_PNG_Close ;
} # end of if $last_index
$testtitle="$FORM{'tstid'} - $TEST{'desc'}";
if ($HBI_Debug) {
$last_index = $#{$QUESTIONS_AH} ;
if ($last_index == -1) {
print "\<br\>\n" ;
print "\<br\>\<br\>QUESTIONS_AH HASH ARRAY is empty.\<br\>\n" ;
print "\<br\>\n" ;
} else {
foreach $index (0 .. $last_index) {
print "\<br\>\n" ; # HBI
print "\<br\>\<br\>QUESTIONS_AH HASH ARRAY Element $index \<br\>\n" ;
foreach $key (sort keys (%{${$QUESTIONS_AH}[$index]})) {
print "KEY $key VAL " ;
print "${$QUESTIONS_AH}[$index]->{$key}" ;
print "\<br\>\n" ;
} # end foreach $key
} # end foreach $index
} # end of if $last_index
} # end of if $HBI_Debug
if ($HBI_Debug) {
$last_index = $#{$QUESTIONS_AG} ;
if ($last_index == -1) {
print "\<br\>\n" ;
print "\<br\>\<br\>QUESTIONS_AG HASH ARRAY is empty.\<br\>\n" ;
print "\<br\>\n" ;
} else {
foreach $index (0 .. $last_index) {
print "\<br\>\n" ; # HBI
print "\<br\>\<br\>QUESTIONS_AG HASH ARRAY Element $index \<br\>\n" ;
foreach $key (sort keys (%{${$QUESTIONS_AG}[$index]})) {
print "KEY $key VAL " ;
print "${$QUESTIONS_AG}[$index]->{$key}" ;
print "\<br\>\n" ;
} # end foreach $key
} # end foreach $index
} # end of if $last_index
} # end of if $HBI_Debug
# Now we are going to format the date the test was taken. <%=FORM.tdatesel%>
# Original text is like 05-Jul-2013_19:37:35_GMT
my %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 $given_date_str = $FORM{'tdatesel'} ;
my $new_fmt_date ;
my ($day_month, $month_str, $cent_year) ;
if ($given_date_str =~ m/^(\d+)\-([^\-]+)\-(\d+)/ ) {
$day_month = $1 ;
$month_str = $2 ;
$cent_year = $3 ;
$month_str = $Month_Full{$month_str} if ($Month_Full{$month_str}) ;
$FORM{'tdatesel'} = "$month_str $day_month, $cent_year" ;
}
if ($HBI_Debug) {
print "\<br\>\n" ;
print "full name\<br\>\n" ;
print $CANDIDATE{'full_name'} ;
print "\<br\>\n" ;
print "Test Date\<br\>\n" ;
print $FORM{'tdatesel'} ;
print "\<br\>\n" ;
print "Graphic Text\<br\>\n" ;
print $SYSTEM{'Graphic_Text'} ;
print "\<br\>\n" ;
print "Comments\<br\>\n" ;
print $SYSTEM{'ALL_Comments'} ;
print "\<br\>\n" ;
exit 0 ;
}
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "3", "Exec Report $FORM{'rptno'} completed");
$OUTPUT_Format = "RTF" ;
print "Content-Type: text/rtf\n";
print "Content-Disposition: attachment;filename=report.rtf\n\n";
&show_template("LAP_Blank_Report_Hank.rtf") ;
$OUTPUT_Format = "HTML" ;
}
################################################################################
#
# Subroutine Name
# GetTestHeader
#
# Description
# This subroutine returns the header of the test file
#
# Inputs
# $clientId -- The id of the client to search through
#
# Outputs
# None
#
# Returns
# @testFields -- An array of fields in the header
#
#adt080401###############################################################################
sub GetTestHeader
{
my $clientId = $_[0];
my @testList = &get_data("tests.$clientId");
my $testHdr = $testList[0];
my $testFields;
chop( $testHdr );
@testFields = split( /&/, $testHdr );
return @testFields;
}
#adt080401###############################################################################
#
# Subroutine Name
# GetTestsByOwner
#
# Description
# This subroutine searches through the test definition file of the given
# client for all the tests that are owned by the given user id or are public
#
# Inputs
# $clientId -- The id of the client to search through
# $ownedBy -- The name of the owner of the test to search for
#
# Outputs
# None
#
# Returns
# @tests -- An array of tests owned by the given user id
#
################################################################################
sub GetTestsByOwner
{
my $clientId = $_[0];
my $ownedBy = $_[1];
my %currHash;
my @testList = &get_data("tests.$clientId");
my @currField;
my @tests;
my $testHdr = $testList[0];
my $testFields;
my $testCntr;
@testFields = &GetTestHeader( $clientId );
for( $testCntr = 1; $testCntr < $#testList; $testCntr++ )
{
#print "<b>$testList[$testCntr]</b><br>\n";
chop( $testList[$testCntr] );
@currField = split( '&', $testList[$testCntr] );
for( 0 .. $#testFields )
{
$currHash{$testFields[$_]} = $currField[$_];
}
#print "$currHash{'ownedby'} - $ownedBy<p>";
if( ( $currHash{'ownedby'} eq $ownedBy ) || ( $currHash{'ownedby'} eq "" ) )
{
push( @tests, $testList[$testCntr] );
#print "<font color=\"#ff0000\"><b>$testList[$testCntr]</b></font><br>\n";
}
}
return @tests;
}
#
# Return: Count of test result files in $dir matching regex with $clid
# and $testid, OR -1 if there was an error.
#
sub CountTestFilesByCnd {
my ($dir, $clid, $testid, $cndid) = @_;
if ( ! defined($dir) ) {
&logger::logerr("Undefined directory for client ID '$clid', testid '$testid'");
return -1;
}
if ( ! defined($clid) ) {
&logger::logerr("Undefined client ID for directory '$dir', testid '$testid'");
return -1;
}
if ( ! defined($testid) ) {
&logger::logerr("Undefined test ID for directory '$dir', client ID '$clid'");
return -1;
}
my $tstcount = scalar(get_matching_files($dir, "^$clid".'\.'."$cndid".'\.'."$testid\$"));
return $tstcount;
}
#
# Return: Count of test result files in $dir matching regex with $clid
# and $testid, OR -1 if there was an error.
#
sub CountHistoricTests {
my ($dir, $clid, $testid, $cndid) = @_;
if ( ! defined($dir) ) {
&logger::logerr("Undefined directory for client ID '$clid', testid '$testid'");
return -1;
}
if ( ! defined($clid) ) {
&logger::logerr("Undefined client ID for directory '$dir', testid '$testid'");
return -1;
}
if ( ! defined($testid) ) {
&logger::logerr("Undefined test ID for directory '$dir', client ID '$clid'");
return -1;
}
my $historyfile = join($pathsep,$dir,"$clid.$testid.history");
open (HISTFILE,"<$historyfile") or return 0;
my @histentries = <HISTFILE>;
close HISTFILE;
my $sgrepfor=join('&',"\<\<\>\>$clid","$cndid","$testid","");
my @cndidentries = grep( /$sgrepfor/,@histentries);
my $tstcount = $#cndidentries + 1;
return $tstcount;
}
#
# Return: Count of cnd result files in $dir matching regex with $clid
# and $cndid, OR -1 if there was an error.
#
sub CountCndFiles {
my ($dir, $clid, $cndid) = @_;
if ( ! defined($dir) ) {
&logger::logerr("Undefined directory for client ID '$clid', cndid '$cndid'");
return -1;
}
if ( ! defined($clid) ) {
&logger::logerr("Undefined client ID for directory '$dir', cndid '$cndid'");
return -1;
}
if ( ! defined($cndid) ) {
&logger::logerr("Undefined cnd ID for directory '$dir', client ID '$clid'");
return -1;
}
return scalar(get_matching_files($dir, "^$clid".'\.'."$cndid".'\.\S+$'));
}
#
# Return: Sum of times taken during a test in seconds.
#
sub computeTestTime {
my ($dir, $clid, $testid, $cndid, $tstkey) = @_;
if ( ! defined($dir) ) {
&logger::logerr("Undefined directory for client ID '$clid', testid '$testid'");
return -1;
}
if ( ! defined($clid) ) {
&logger::logerr("Undefined client ID for directory '$dir', testid '$testid'");
return -1;
}
if ( ! defined($testid) ) {
&logger::logerr("Undefined test ID for directory '$dir', client ID '$clid'");
return -1;
}
my $timefile = join($pathsep,$dir,"$clid.$cndid.$testid.tim");
open (TLOGFILE,"<$timefile") or return 0;
my @tlogentries = <TLOGFILE>;
close TLOGFILE;
my $sgrepfor="^$tstkey\&(1)\.(2)\.(.*)\&$clid\&$cndid\&$testid\&(.*)";
my @cndidentries = grep( /$sgrepfor/,@tlogentries);
@tlogentries = ();
my $iidx;
my @tentrycols;
my $tottime;
$tottime = 0;
for $iidx (0 .. $#cndidentries) {
@tentrycols = split(/&/,$cndidentries[$iidx]);
$tottime += $tentrycols[7];
}
@tentrycols = ();
return $tottime;
}
sub formatTimeFromSeconds {
my ($t, $fmt) = @_;
my $h;
my $m;
my $s;
my $r;
my $j;
$m = int($t/60);
$s = $t - ($m * 60);
$h = int($m/60);
$m = $m - ($h * 60);
if ($fmt =~ m/h/i) {
$r = "00000$h";
$j=length($r)-2;
$r = substr($r,$j,2);
$fmt =~ s/h/$r/g;
}
if ($fmt =~ m/m/i) {
$r = "00000$m";
$j=length($r)-2;
$r = substr($r,$j,2);
$fmt =~ s/m/$r/g;
}
if ($fmt =~ m/s/i) {
$r = "00000$s";
$j=length($r)-2;
$r = substr($r,$j,2);
$fmt =~ s/s/$r/g;
}
return $fmt;
}
# Normally xdim was 400 and ydim was 100.
sub BuildBarGraph {
# This subroutine builds the HTML to get an image from an URL.
# The URL is a cgi-bin PERL script, with several parameters.
# The list parameters are: labels, values, and values2.
# The scalar parameters are: xdim, ydim, hbar, title, xlabel, ylabel, ymax, ymin, yticknum, colorscheme, $t_margin, $b_margin, $l_margin, $r_margin
# The first 3 parameters are references to three lists, which are mandatory.
# The values2 list may be an empty list. (and ignored.)
# The rest of the parameters are optional, but are order specific.
# Any parameter that is an empty string will be effectively ignored,
# but may be required to fill the list of parameters to a needed parm.
my @label_names, @value_points, @value2_points ;
my $labels_ref, $values_ref, $values2_ref ;
my $xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum ;
my $colorscheme ;
my $t_margin, $b_margin, $l_margin, $r_margin ;
$labels_ref = $_[0] ;
@label_names = @{$labels_ref} ;
# @label_names is an array of character strings of the names of the bars on the graph.
$values_ref = $_[1] ;
@value_points = @{$values_ref} ;
# @value_points is an array of numeric values for each of the names in the first array.
# The sizes of the two arrays should be the same.
$values2_ref = $_[2] ;
@value2_points = @{$values2_ref} ;
shift ; shift ; shift ; # Remove the first 3 parms, to set up the next statement.
my ($xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum, $colorscheme, $t_margin, $b_margin, $l_margin, $r_margin) = @_ ;
my $labels, $values, $values2 ;
# print '<br> label_names ' . "@label_names" . ' <br>' ;
# print '<br> value_points ' . "@value_points" . ' <br>' ;
if ($#label_names != $#value_points) {
print '<br>ERROR BuildBarGraph has different number of labels and data values.<br>' ;
}
$labels = join (":", map {munge($_)} @label_names ) ;
$values = join (":", map {munge($_)} @value_points ) ;
$values2 = join (":", map {munge($_)} @value2_points ) ;
# my $baseurl = "/cgi-bin/bargraph.pl?labels=$labels&title=Trust%20Level&ylabel=Respondents";
my $baseurl = "/cgi-bin/bargraph.pl?labels=$labels&values=$values" ;
if ($xdim or $xdim == 0) { $baseurl .= "&xdim=" . $xdim ; }
if ($ydim or $ydim == 0) { $baseurl .= "&ydim=" . $ydim ; }
if ($hbar or $hbar == 0) { $baseurl .= "&hbar=" . $hbar ; }
if ($title or $title == 0) { $baseurl .= "&title=" . munge( $title) ; }
if ($xlabel or $xlabel == 0) { $baseurl .= "&xlabel=" . munge( $xlabel) ; }
if ($ylabel or $ylabel == 0) { $baseurl .= "&ylabel=" . munge( $ylabel) ; }
if ($ymax or $ymax == 0) { $baseurl .= "&ymax=" . $ymax ; }
if ($ymin or $ymin == 0) { $baseurl .= "&ymin=" . $ymin ; }
if ($t_margin or $t_margin == 0) { $baseurl .= "&t_margin=" . $t_margin ; }
if ($b_margin or $b_margin == 0) { $baseurl .= "&b_margin=" . $b_margin ; }
if ($l_margin or $l_margin == 0) { $baseurl .= "&l_margin=" . $l_margin ; }
if ($r_margin or $r_margin == 0) { $baseurl .= "&r_margin=" . $r_margin ; }
if ($colorscheme) { $baseurl .= "&colorscheme=" . $colorscheme ; }
if ($yticknum or $yticknum == 0) { $baseurl .= "&yticknum=" . $yticknum ; }
return "<img src=\"$baseurl&values2=$values2\">";
}
############################################################################
#
# Function: munge( $string )
# Description: Do the normal munging to replace non-normal chars with %XX.
# Returns: a modified string with %XX patterns inserted
# Author: HBI, 2008/09/30
#
# The process is performed on strings that are sent as literal text,
# as part of an URL to be re-analyzed by a WEB server. The higher
# level application must do this once, and only once. This function
# assumes that the character string contains only 7 or 8 bit characters.
# This function cannot deal with multi-byte UTF-8 characters.
#
############################################################################
sub munge( $ ) {
my ($string) = @_;
$string =~ s/([^a-zA-Z0-9])/join('', '%', uc(unpack("H*",$1)))/eg;
return $string;
}
############################################################################
#
# Function: unmunge( $string )
# Description: Inverse operation of munge(), replace %XX with the real ascii.
# Returns: a modified string with %XX patterns replaced
# Author: efl, 11/2001
#
############################################################################
sub unmunge( $ ) {
my ($string) = @_;
$string =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
return $string;
}
sub HTMLHeader {
return "<html>\n<head>\n<title>$_[0]</title>\n".
"<script language=\"JavaScript\">\n<!-- \n$_[1]\n -->\n</script>\n</head>\n".
"<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\"".
" TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\"".
" VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\">\n";
}
sub HTMLHeaderPlain {
return "<html>\n<head>\n<title>$_[0]</title>\n".
"<script language=\"JavaScript\">\n<!-- \n$_[1]\n -->\n</script>\n</head>\n".
"<BODY>\n";
}
sub HTMLFooter {
my $year = `date +%Y`;
my $ionline;
if ($ENV{'SERVER_NAME'} =~ "integroonline.com") {
$ionline = "<br>Copyright (c) $year, Integro Learning Company";
}
return "<br><center><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\">Copyright (c) $year, ACTS Corporation$ionline<center></font></body>\n</html>\n";
}
sub ReportChooser {
warn "INFO: ReportChooser Running " ;
my $HBI_Debug_ReportChooser = 1 ;
unless ($SESSION{'clid'}) {
warn "ERROR: No Client ID for the session.\n" ;
&show_illegal_access_warning ;
exit 0 ;
}
&get_client_profile($SESSION{'clid'});
unless (%CLIENT) {
warn "ERROR: No Client Data for the session. " ;
&show_illegal_access_warning ;
exit 0 ;
}
# 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'});
if ($HBI_Debug_ReportChooser) {
; # warn Dumper($groups) ;
}
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";
my $organizationname = $CLIENT{'clnmc'};
my $uberheader;
my $TESTS = get_data_hash ("tests.$CLIENT{'clid'}") ;
if ($HBI_Debug_ReportChooser) {
; # 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] ;
}
if ($HBI_Debug_ReportChooser) {
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("Learning Custom Reports",$js . $js1);
print "<form name=\"integrorpt\" action=\"$cgiroot/likert_wall_103.pl\" method=\"Post\" target=\"reportdetail\" 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=\"frm\" value=\"3\">\n" ;
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=\"tstid\" value=\"$FORM{'tstid'}\">\n";
print "<input type=hidden name=\"cndid\" value=\"$FORM{'cndid'}\">\n" ;
print "<input type=hidden name=\"tdatesel\" value=\"$FORM{'tdatesel'}\">\n" ;
print "<input type=hidden name=\"rptid\" value=\"$REPORT{'rptid'}\">\n";
print "<input type=\"hidden\" name=\"reportname\" value=\"\">\n";
print "<center>\n<table border>\n<caption>Learning 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 $test_choice_html ;
print "<p>Automated 360 Degree 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');\">Likert Scale by Group</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 "\ <br>
<INPUT type=\"submit\" name=\"submit\" value=\"$xlatphrase[709]\">
\ <br>\n" ;
print "</form>";
print HTMLFooter();
}
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);
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="tstid2" 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);
}
$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 GetTGWallLikertGrpData {
# Parameters
# $client - required String, client id.
# $testid1 - required String, test id.
# $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_one, $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_one - reference to a Hash of a Hash like ret_all. It contains the
# results and scores for $testid1 taken by $candidate1.
# $ret_err - string. - It is either an empty string or text about likert categoies not matching,
# or question counts not matching.
# Populate $QUESTION_AH with questions, responses, and comments for $testid1 and $candidate1.
# Populate $QUESTION_AG with questions, responses, and comments for $testid2 and $grplist.
my ($client, $testid1, $candidate1, $testid2, $grplist, $respRequired) = @_ ;
# warn "grplist" ;
# warn &Dumper(\$grplist) ;
# 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 = "" ;
foreach $Group (keys %{${grplist}}) {
foreach $Member (@{${grplist}->{$Group}->{'grplist'}}) {
push @{$Group_Xref->{$Member}} , $Group ;
$Group_XrefP{$Member}->{$Group} = 1 ;
}
}
# warn Dumper(\%Group_Xref) ;
my %supercat_found = () ;
# hash of categories found and initialized in the hash of hashes for single candidate
my %supercat_foundg = () ;
# hash of categories found and initialized in the hash of hashes for groups.
# PROCESS $test1, and $candidate1
&get_test_profile($client, $testid1) ; # Populates %TEST
$QUESTIONS_AH = &get_question_definitions ($client, $testid1 );
my $inact_ques = 0; # Count of the inactive questions found.
# Populates an array of hashs that contains all of the questions and the answers.
# $QUESTIONS_AH is a reference to the arrays of hashs.
my $last_index = $#{$QUESTIONS_AH} ; # Last index of the Array of Hashs of the Q&A.
&get_test_sequence_for_reports($client, $candidate1, $testid1) ;
# populates the Assoc. arrays %TEST_SESSION, %SUBTEST_QUESTIONS,
# %SUBTEST_ANSWERS, %SUBTEST_RESPONSES, and %SUBTEST_SUMMARY.
my $points, $weight, @scores, @correct_ans, @incorrect_ans, @all_ans ;
my $ques_type, $supercat, $scores, @responses, $responses ;
$responses = $SUBTEST_RESPONSES{2} ;
warn Dumper(\%SUBTEST_RESPONSES) ;
@responses = split (/\&/, $responses) ;
shift @responses ; # Drop the empty element in front of the list.
foreach $index1 (0 .. $last_index) {
# Skip the question if it is inactive.
if (${$QUESTIONS_AH}[$index1]->{'qil'} eq "Y") {$inact_ques++ ; next ;}
# Get the data for a single question.
$points = ${$QUESTIONS_AH}[$index1]->{'pts'} ;
$weight = ${$QUESTIONS_AH}[$index1]->{'wght'} ;
$ques_type = ${$QUESTIONS_AH}[$index1]->{'qtp'} ;
$scores = ${$QUESTIONS_AH}[$index1]->{'scores'} ;
@Response_parts = split ('::', $responses[$index1], 2) ;
${$QUESTIONS_AH}[$index1]->{'responses'} = $Response_parts[0] ;
${$QUESTIONS_AH}[$index1]->{'comments'} = $Response_parts[1] ;
${$QUESTIONS_AH}[$index1]->{'responses'} =~ s/\s*\<br\>\s*/ /isg ;
${$QUESTIONS_AH}[$index1]->{'comments'} =~ s/\s*\<br\>\s*/ /isg ;
if ($ques_type eq "lik") {
@scores = split (/\,/ , $scores) ;
$supercat = ${$QUESTIONS_AH}[$index1]->{'supercat'} ;
unless ($supercat_found{$supercat}) {
# Initialize counters.
# warn "Init all Cat $supercat" if $supercat eq "Employee Passion" ;
$ret_one->{$supercat}->{'PointsAvail'} = 0 ;
$ret_one->{$supercat}->{'NoResponses'} = 0 ;
$ret_one->{$supercat}->{'Responses'} = 0 ;
$ret_one->{$supercat}->{'PointsEarned'} = 0 ;
$ret_one->{$supercat}->{'ScoreCount'} = {} ;
$supercat_found{$supercat} = 1 ;
}
$ret_one->{$supercat}->{'Questions'}->{$index1-$inact_ques} = 1 ;
$responses = $responses[$index1-$inact_ques] ;
@individ = split(/\?/, $responses) ;
shift @individ ;
my $no_response = 1 ;
$ret_one->{$supercat}->{'PointsAvail'} += $points ;
foreach $index2 (0 .. $#scores) {
# Add the key for the score count to the hash.
unless (exists $ret_one->{$supercat}->{'ScoreCount'}->{$scores[$index2]}) {
$ret_one->{$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 GRP @group \n" if $supercat eq "Improvement" ;
$ret_one->{$supercat}->{'PointsEarned'} += $scores[$index2] ;
$ret_one->{$supercat}->{'ScoreCount'}->{$scores[$index2]} ++ ;
$no_response = 0 ;
} # If answered.
} # foreach $index2
if ($no_response) {
# Add to the no response count.
$ret_one->{$supercat}->{'NoResponses'} ++ ;
if ($respRequired) {
# Reduce the points avail if a response is required to count.
$ret_one->{$supercat}->{'PointsAvail'} -= $points ;
}
} else {
# Add to the response count.
$ret_one->{$supercat}->{'Responses'} ++ ;
}
} # for Likert questions.
} # foreach question in testid1
# 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);
my $file ;
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" ;
my $user_grp = undef ;
$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" ;
next ;
}
# 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.
$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) ;
# 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] ;
$response_g =~ s/\s*\<br\>\s*/ /isg ;
$response_g =~ s/\\/\\\'5c/sg ; # Convert a text backslash to a RTF backslash.
$comment_g =~ s/\s*\<br\>\s*/ /isg ;
$comment_g =~ s/\\/\\\'5c/sg ; # Convert a text backslash to a RTF backslash.
${$QUESTIONS_AG}[$index1]->{'responses'} .= $response_g . "\\par \n" ;
${$QUESTIONS_AG}[$index1]->{'comments'} .= $comment_g . "\\par \n" ;
if ($ques_type eq "lik") {
@scores = split (/\,/ , $scores) ;
$supercat = ${$QUESTIONS_AG}[$index1]->{'supercat'} ;
unless ($supercat_foundg{$supercat}) {
# Initialize counters.
# warn "Init all Cat $supercat" if $supercat eq "Employee Passion" ;
$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_found{$supercat} = 1 ;
}
$ret_all->{$supercat}->{'Questions'}->{$index1-$inact_ques} = 1 ;
my @Groups = @{$Group_Xref->{$user}} ;
foreach $group (@Groups) {
unless (defined $ret_grp->{$group}->{$supercat}) {
# warn "Init all Cat $supercat Group $group.\n" if $supercat eq "Improvement" ;
$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
$responses = $responses[$index1-$inact_ques] ;
@individ = split(/\?/, $responses) ;
shift @individ ;
my $no_response = 1 ;
$ret_all->{$supercat}->{'PointsAvail'} += $points ;
foreach $group (@Groups) {
$ret_grp->{$group}->{$supercat}->{'PointsAvail'} += $points ;
}
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 ;
}
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 GRP @group \n" if $supercat eq "Improvement" ;
$ret_all->{$supercat}->{'PointsEarned'} += $scores[$index2] ;
$ret_all->{$supercat}->{'ScoreCount'}->{$scores[$index2]} ++ ;
foreach $group (@Groups) {
$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'} ++ ;
}
}
}
} # foreach question.
} # foreach file (i.e. candidate)
return ($ret_all, $ret_grp, $ret_one, $ret_err) ; # Return reference.
} # End of GetFullLikertGrpData