#!/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; require bargraph_multi ; use vars qw(%FORM %SESSION %CLIENT %TEST_SESSION %SUBTEST_QUESTIONS %TEST %SUBTEST_SUMMARY %CANDIDATE %SUBTEST_ANSWERS %SYSTEM %REPORT %GRPFIELD %SUBTEST_RESPONSES @xlatphrase); use vars qw($testcomplete $cgiroot $pathsep $dataroot @rptparams ); use vars qw($testinprog $testpending) ; my $last_index, $HBI_Debug ; $HBI_Debug = 0 ; # Controls output of Debugging Data. $FORM{'frm'}=""; my %Month_Full = ("Jan" => "January", "Feb" => "February", "Mar" => "March", "Apr" => "April", "May" => "May", "Jun" => "June", "Jul" => "July", "Aug" => "August", "Sep" => "September", "Oct" => "October", "Nov" => "November", "Dec" => "December") ; &app_initialize; if ($HBI_Debug) {warn "INFO: " . __FILE__ . " running frm IS $FORM{'frm'} " ;} # 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'}); $CANDIDATE{'full_name'} = $CANDIDATE{'nmf'} . " " ; $CANDIDATE{'full_name'} .= $CANDIDATE{'nmm'} . ". " if ($CANDIDATE{'nmm'}) ; $CANDIDATE{'full_name'} .= $CANDIDATE{'nml'} ; # warn "INFO: full name is X$CANDIDATE{'full_name'}X\n" ; $CANDIDATE{'full_name'} = &RTFize($CANDIDATE{'full_name'}) ; # warn "INFO: full name is X$CANDIDATE{'full_name'}X\n" ; if ($HBI_Debug) { print "\<br\>\<br\>CANDIDATE HASH ARRAY\<br\>\n" ; foreach $key (sort keys (%CANDIDATE)) { print "KEY $key VAL $CANDIDATE{$key}\<br\>\n" ; } } # populates the Assoc. array %CANDIDATE with data for the candidate/user/student who took the test/survey. # HBI - Go find the format of the test results. # The original code supported multiple selected tests. # This report does not support multiple tests. unless ($CLIENT{'clid'}) { warn "No Client ID in the CLIENT data.\n" ; print "No Client ID in the CLIENT data.\n" ; print "\<br\>\n" ; exit 0 ; } unless ($FORM{'tstid'}) { warn "No Test ID in the form.\n" ; print "No Test ID in the form.\n" ; print "\<br\>\n" ; exit 0 ; } unless ($FORM{'tstid2'}) { warn "No 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 XXX HASH ARRAY\<br\>\n" ; foreach $key (sort keys (%SUBTEST_SUMMARY)) { print "KEY $key VAL $SUBTEST_SUMMARY{$key}\<br\>\n" ; } } # end of if $HBI_Debug my %supercat_total = () ; # Total points available for a category. my %supercat_earned = () ; # Points earned for a category. my %TGWall_Comments = () ; # Collected Text for questions and comments in a category. my %TGWall_Comments_fnd = () ; # Collected Text for questions and comments in a category. # The following values have a similar name, and are logically connected. my $SUPERCAT_TOTAL = 0 ; # Total points available in all categories. my $SUPERCAT_EARNED = 0 ; # Total points earned in all categories. my $points, $weight, @scores, @correct_ans, @incorrect_ans, @all_ans ; my $ques_type, $supercat, $scores, @responses, $responses ; my @individ, $individ, @img_labels, @img_data , @Response_parts; my $client = $SESSION{'clid'} ; my $testid = $FORM{'tstid'} ; my $candidate = $FORM{'cndid'} ; my $testid2 = $FORM{'tstid2'} ; 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) ; foreach $groupid (@Report_Groups) { $grplist->{$groupid} = $MasterGroupHash->{$groupid}->{'GroupMembersA'} ; warn "INFO: Group ID $groupid \n" if ($HBI_Debug_Groups_800) ; warn "INFO: Group members : " . join (" ", @{$grplist->{$groupid}}) . "\n" if ($HBI_Debug_Groups_800) ; } $SYSTEM{'FeedBackDate'} = "Date UNK" ; $FeedBackDateTime = 0 ; $full_history_OK = &get_full_history($testcomplete, $client, $testid2) ; my $HBI_Debug_FeedBack = 0 ; if ($HBI_Debug_FeedBack) { my $FBClient; my $FBtest; my $FBcand ; warn "INFO: FB Clients " . (join(" ", keys %{$FULL_HISTORY})) . "\n" ; foreach $FBClient (keys %{$FULL_HISTORY}) { warn "INFO: FB client $FBClient tests " . (join(" ", keys %{$FULL_HISTORY->{$FBClient}})) . "\n" ; foreach $FBtest (keys %{$FULL_HISTORY->{$FBClient}}) { warn "INFO: FB client $FBClient test $FBtest candidates " . (join(" ", keys %{$FULL_HISTORY->{$FBClient}->{$FBtest}})) . "\n" ; foreach $FBcand (keys %{$FULL_HISTORY->{$FBClient}->{$FBtest}}) { warn "INFO: FB times $FBClient test $FBtest candidate $FBcand " . (join(" ", keys %{$FULL_HISTORY->{$FBClient}->{$FBtest}->{$FBcand}})) . "\n" ; } } } } my ($ret_all, $ret_grp, $ret_one, $ret_err) = &GetTGWallLikertGrpData($client, $testid, $candidate, $testid2, $grplist, 1) ; warn "ERROR: ", $ret_err, "\n" if ($ret_err) ; # # Build a bar chart for Candidates self evaluation vs the groups evaluation. # my $Data1 = [] ; # The data for the chart. my $Category_ARef = [] ; my $category ; my $Legend1 = [] ; # The legends for the chart. # load the labels for the x-axis. push @{$Category_ARef}, (sort keys %{$ret_one}) ; push @{$Category_ARef}, "Total" ; push @{$Data1}, $Category_ARef ; # Load the data for the self-evaluation. my $Category_ARef2 ; $Category_ARef2 = [] ; my $totavail = 0 ; my $totscore = 0 ; foreach $category (sort keys %{$ret_one}) { my $piavail = $ret_one->{$category}->{'PointsAvail'} ; $totavail += $piavail ; my $piscore = $ret_one->{$category}->{'PointsEarned'} ; $totscore += $piscore ; my $piaver = $piavail ? ($piscore/$piavail) : 0 ; my $pinum = (int(100*$piaver + 0.5)) ; push @{$Category_ARef2}, $pinum ; } $piaver = $totavail ? ($totscore/$totavail) : 0 ; $pinum = (int(100*$piaver + 0.5)) ; push @{$Category_ARef2}, $pinum ; push @{$Data1}, $Category_ARef2 ; push @{$Legend1 }, $CANDIDATE{'nml'} ; # Load the data for the Others evaluation. $Category_ARef2 = [] ; $totavail = 0 ; $totscore = 0 ; foreach $category (sort keys %{$ret_all}) { $piavail = $ret_all->{$category}->{'PointsAvail'} ; $totavail += $piavail ; $piscore = $ret_all->{$category}->{'PointsEarned'} ; $totscore += $piscore ; $piaver = $piavail ? ($piscore/$piavail) : 0 ; $pinum = (int(100*$piaver + 0.5)) ; push @{$Category_ARef2}, $pinum ; } $piaver = $totavail ? ($totscore/$totavail) : 0 ; $pinum = (int(100*$piaver + 0.5)) ; push @{$Category_ARef2}, $pinum ; push @{$Data1}, $Category_ARef2 ; push @{$Legend1 }, "360 Participants" ; # Set up the graphing options. my ($xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum, $t_margin, $b_margin, $l_margin, $r_margin, $colorscheme, $bar_spacing, $bargroup_spacing, $show_values, $x_label_position, $y_label_position, $transparent, $overwrite, $interlaced, $bgclr, $fgclr, $boxclr, $accentclr, $shadowclr, $shadow_depth, $labelclr, $axislabelclr, $legendclr, $valuesclr, $textclr, $dclrs, $borderclrs, $cycle_clrs, $accent_treshold, $long_ticks, $tick_length, $x_ticks, $y_number_format, $x_label_skip, $y_label_skip, $x_last_label_skip, $x_tick_offset, $x_all_ticks, $x_label_position, $y_label_position, $x_labels_vertical, $x_plot_values, $y_plot_values, $box_axis, $no_axes, $two_axes, $use_axis, $zero_axis, $zero_axis_only, $axis_space, $text_space, $cumulate, $overwrite, $correct_width, $values_vertical, $values_space, $values_format, $legend_placement, $legend_marker_width, $legend_marker_height, $lg_cols ) ; $xdim = ( 6 * 72 ) ; $ydim = ( 5 * 72 ) ; $hbar = 1 ; $title = "" ; # The title is in the text of the report above the chart. $xlabel = "" ; $ylabel = "Percentage" ; $ymax = 100 ; $ymin = 0 ; $yticknum = 10 ; $t_margin = 10 ; $b_margin = 10 ; $l_margin = 10 ; $r_margin = 30 ; $colorscheme = "lblue:lred" ; $bar_spacing = 0 ; $bargroup_spacing = 6 ; $show_values = 1 ; $x_label_position = undef ; $y_label_position = undef ; $transparent = undef ; $overwrite = 0 ; $interlaced = undef ; $bgclr = undef ; $fgclr = undef ; $boxclr = "lgray" ; $accentclr = undef ; $shadowclr = undef ; $shadow_depth = undef ; $labelclr = undef ; $axislabelclr = undef ; $legendclr = undef ; $valuesclr = undef ; $textclr = undef ; $dclrs = undef ; # Also handled by the $colorscheme string. $borderclrs = undef ; $cycle_clrs = undef ; $accent_treshold = undef ; $long_ticks = undef ; $tick_length = undef ; $x_ticks = undef ; $y_number_format = undef ; $x_label_skip = undef ; $y_label_skip = undef ; $x_last_label_skip = undef ; $x_tick_offset = undef ; $x_all_ticks = undef ; $x_label_position = undef ; $y_label_position = undef ; $x_labels_vertical = undef ; $x_plot_values = undef ; $y_plot_values = undef ; $box_axis = undef ; $no_axes = undef ; $two_axes = undef ; $use_axis = undef ; $zero_axis = undef ; $zero_axis_only = undef ; $axis_space = undef ; $text_space = undef ; $cumulate = undef ; $overwrite = 0 ; $correct_width = undef ; $values_vertical = undef ; $values_space = undef ; $values_format = undef ; $legend_placement = undef ; $legend_marker_width = undef ; $legend_marker_height = undef ; $lg_cols = undef ; # Draw the graph my ($Graph1_obj, $Graph1_str) = &bargraph_multi::Build_Labeled_X_Axis_Graph_Str ($Data1, $Legend1, "png", $xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum, $t_margin, $b_margin, $l_margin, $r_margin, $colorscheme, $bar_spacing, $bargroup_spacing, $show_values, $x_label_position, $y_label_position, $transparent, $overwrite, $interlaced, $bgclr, $fgclr, $boxclr, $accentclr, $shadowclr, $shadow_depth, $labelclr, $axislabelclr, $legendclr, $valuesclr, $textclr, $dclrs, $borderclrs, $cycle_clrs, $accent_treshold, $long_ticks, $tick_length, $x_ticks, $y_number_format, $x_label_skip, $y_label_skip, $x_last_label_skip, $x_tick_offset, $x_all_ticks, $x_label_position, $y_label_position, $x_labels_vertical, $x_plot_values, $y_plot_values, $box_axis, $no_axes, $two_axes, $use_axis, $zero_axis, $zero_axis_only, $axis_space, $text_space, $cumulate, $overwrite, $correct_width, $values_vertical, $values_space, $values_format, $legend_placement, $legend_marker_width, $legend_marker_height, $lg_cols ) ; 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' ; $RTF_PNG_Begin .= "\\picw" . (${xdim} + 0) . " " ; # Width in pixels $RTF_PNG_Begin .= "\\pich" . (${ydim} + 0) . " " ; # Height in pixels $RTF_PNG_Begin .= "\\picwgoal" . (${xdim}*20) ; # width on the page in twips $RTF_PNG_Begin .= "\\pichgoal" . (${ydim}*20) ; # Height on the page in twips. $RTF_PNG_Begin .= $Eol ; # I am using a pixel in a point. A point is 1/72 inches. # A twip is 1/20 of a point. $RTF_PNG_Begin .= "\\bliptag10000" ; # Unique identifier for the image. $RTF_PNG_Begin .= $lCurly . '\\*\\blipuid ' ; $RTF_PNG_Begin .= "00000000000000000000000000002710" ; # 32 numeric digits $RTF_PNG_Begin .= $rCurly . $Eol ; # Ends blipuid. $RTF_PNG_Close = $rCurly . $rCurly ; # Ends pict and shppict commands. $RTF_PNG_Close .= $Eol ; my $HBI_Debug_msg_str = "" ; my $T_colors = "" ; # Normally this is a colon separated string of color names. my $offset = 0 ; my $length_line = 40 ; my $len_left ; my $part_data = "" ; my $Hex_image ; my $All_data_len = length $Graph1_str ; do { $len_left = $All_data_len - $offset ; if ($len_left < $length_line) {$length_line = $len_left;} $part_data .= unpack ("H*", substr($Graph1_str, $offset, $length_line)) ; $part_data .= $Eol ; $offset += $length_line ; } while ($offset < $All_data_len ) ; $SYSTEM{'Bargraph1'} = $RTF_PNG_Begin . $part_data . $RTF_PNG_Close ; # Get the feed back date. if ($FeedBackDateTime) { my $date_ascii = gmtime($FeedBackDateTime) ; chomp $date_ascii ; my @date_parts = split (/ +/, $date_ascii) ; my $mon_name = $date_parts[1] ; if (exists $Month_Full{$mon_name}) { $mon_name = $Month_Full{$mon_name} ; } else { warn "ERROR: Did not find full month name for $mon_name.\n" ; } my $year = $date_parts[4] ; $SYSTEM{'FeedBackDate'} = $mon_name . " " . $year ; } else { warn "ERROR: FeedBackDateTime is unknown. Field in Automated Report is bogus." ; } # 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] ; # Build the Feedback Comments. my @CommSuperCats = sort keys %{$ret_all} ; my @SuperCatQuestions ; my $CommSuperCategory ; my $SuperCatQuestion ; foreach $CommSuperCategory (@CommSuperCats) { @SuperCatQuestions = keys %{$ret_all->{$CommSuperCategory}->{'Questions'}} ; $SYSTEM{'ALL_Comments'} .= "\\par CATEGORY - $CommSuperCategory\n" ; $SYSTEM{'ALL_Comments'} .= "\\par \n" ; my @SortedQuestions = sort {$a <=> $b} @SuperCatQuestions ; foreach $SuperCatQuestion (@SortedQuestions) { $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.\\par \n" ; } } } # # Build a bar chart for Candidates self evaluation vs the groups evaluation. # my $Data2 = [] ; # The data for the chart. my @HBI_Debug_retall = (0, 0, 0, 0, 0) ; $Category_ARef = [] ; $category ; my $Legend2 = [] ; # The legends for the chart. # load the labels for the x-axis. push @{$Category_ARef}, (sort keys %{$ret_one}) ; push @{$Category_ARef}, "Total" ; push @{$Data2}, $Category_ARef ; # Load the data for the self-evaluation. $Category_ARef2 = [] ; my $group_review ; $totavail = 0 ; $totscore = 0 ; my $tot_G_avail ; my $tot_G_score ; my @Categories = (sort keys %{$ret_one}) ; my @Groupies = (sort keys %{$ret_grp}) ; if ($HBI_Debug_retall[0]) { warn "INFO: ret_one Categories " . join(" ", @Categories) . "\n" ; warn "INFO: ret_all Groups " . join(" ", @Groupies) . "\n" ; } my %Graph2_nums = () ; my $Overall_Group = "Overall" ; my $Overall_Category = "Total" ; my %Graph2_by_Group_nums = () ; foreach $category (@Categories) { $tot_G_avail = 0 ; $tot_G_score = 0 ; foreach $group (@Groupies) { $piavail = $ret_grp->{$group}->{$category}->{'PointsAvail'} ; $piscore = $ret_grp->{$group}->{$category}->{'PointsEarned'} ; $piaver = $piavail ? ($piscore/$piavail) : 0 ; $pinum = (int(100*$piaver + 0.5)) ; $Graph2_nums->{$category}->{$group} = $pinum ; $totavail += $piavail ; $totscore += $piscore ; $tot_G_avail += $piavail ; $tot_G_score += $piscore ; $Graph2_by_Group_nums->{$group}->{'PointsAvail'} += $piavail ; $Graph2_by_Group_nums->{$group}->{'PointsEarned'} += $piscore ; } $piaver = $tot_G_avail ? ($tot_G_score/$tot_G_avail) : 0 ; $pinum = (int(100*$piaver + 0.5)) ; $Graph2_nums->{$category}->{$Overall_Group} = $pinum ; } $category = $Overall_Category ; $tot_G_avail = 0 ; $tot_G_score = 0 ; foreach $group (@Groupies) { $piavail = $Graph2_by_Group_nums->{$group}->{'PointsAvail'} ; $piscore = $Graph2_by_Group_nums->{$group}->{'PointsEarned'} ; $piaver = $piavail ? ($piscore/$piavail) : 0 ; $pinum = (int(100*$piaver + 0.5)) ; $tot_G_avail += $piavail ; $tot_G_score += $piscore ; $Graph2_by_Group_nums->{$group}->{'pinum'} = $pinum ; $Graph2_nums->{$category}->{$group} = $pinum ; } $piavail = $Graph2_by_Group_nums->{$Overall_Group}->{'PointsAvail'} = $tot_G_avail ; $piscore = $Graph2_by_Group_nums->{$Overall_Group}->{'PointsEarned'} = $tot_G_score ; $piaver = $piavail ? ($piscore/$piavail) : 0 ; $pinum = (int(100*$piaver + 0.5)) ; $Graph2_by_Group_nums->{$Overall_Group}->{'pinum'} = $pinum ; $Graph2_nums->{$Overall_Category}->{$Overall_Group} = $pinum ; my $HBI_Debug_Load_Data = 0 ; if ($HBI_Debug_Load_Data) { warn "INFO: Load_Data Groups cnt " . ($#Groupies +1) . "\n" ; warn "INFO: Groups " . (join " ", @Groupies) . "\n" ; warn "INFO: Load_Data Categories cnt " . ($#Categories +1) . "\n" ; warn "INFO: Categories " . (join " ", @Categories) . "\n" ; } foreach $group (@Groupies, $Overall_Group) { $Category_ARef2 = [] ; foreach $category (@Categories, $Overall_Category) { push @{$Category_ARef2}, $Graph2_nums->{$category}->{$group} ; } push @{$Data2}, $Category_ARef2 ; } foreach $group (@Groupies ) { push @{$Legend2 }, $MasterGroupHash->{$group}->{'grpnme'} ; } push @{$Legend2 }, $Overall_Group ; # Set up the graphing options. $xdim = ( 6 * 72 ) ; $ydim = ( 7 * 72 ) ; $hbar = 1 ; $title = "" ; $xlabel = "" ; $ylabel = "" ; $ymax = 100 ; $ymin = 0 ; $yticknum = 10 ; $t_margin = 20 ; $b_margin = 10 ; $l_margin = 10 ; $r_margin = 10 ; $colorscheme = "red:blue:green:yellow:gray" ; $bar_spacing = 0 ; $bargroup_spacing = 2 ; $show_values = 1 ; $x_label_position = undef ; $y_label_position = undef ; $transparent = undef ; $overwrite = undef ; $interlaced = undef ; $bgclr = undef ; $fgclr = undef ; $boxclr = "lgray" ; $accentclr = undef ; $shadowclr = undef ; $shadow_depth = undef ; $labelclr = undef ; $axislabelclr = undef ; $legendclr = undef ; $valuesclr = undef ; $textclr = undef ; $dclrs = undef ; # Also handled by the $colorscheme string. $borderclrs = undef ; $cycle_clrs = undef ; $accent_treshold = undef ; $long_ticks = undef ; $tick_length = undef ; $x_ticks = undef ; $y_number_format = undef ; $x_label_skip = undef ; $y_label_skip = undef ; $x_last_label_skip = undef ; $x_tick_offset = undef ; $x_all_ticks = undef ; $x_label_position = undef ; $y_label_position = undef ; $x_labels_vertical = undef ; $x_plot_values = undef ; $y_plot_values = undef ; $box_axis = undef ; $no_axes = undef ; $two_axes = undef ; $use_axis = undef ; $zero_axis = undef ; $zero_axis_only = undef ; $axis_space = undef ; $text_space = undef ; $cumulate = undef ; $overwrite = undef ; $correct_width = undef ; $values_vertical = undef ; $values_space = undef ; $values_format = undef ; $legend_placement = "BC" ; $legend_marker_width = undef ; $legend_marker_height = undef ; $lg_cols = undef ; # Draw the graph my ($Graph2_obj, $Graph2_str) = &bargraph_multi::Build_Labeled_X_Axis_Graph_Str ($Data2, $Legend2, "png", $xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum, $t_margin, $b_margin, $l_margin, $r_margin, $colorscheme, $bar_spacing, $bargroup_spacing, $show_values, $x_label_position, $y_label_position, $transparent, $overwrite, $interlaced, $bgclr, $fgclr, $boxclr, $accentclr, $shadowclr, $shadow_depth, $labelclr, $axislabelclr, $legendclr, $valuesclr, $textclr, $dclrs, $borderclrs, $cycle_clrs, $accent_treshold, $long_ticks, $tick_length, $x_ticks, $y_number_format, $x_label_skip, $y_label_skip, $x_last_label_skip, $x_tick_offset, $x_all_ticks, $x_label_position, $y_label_position, $x_labels_vertical, $x_plot_values, $y_plot_values, $box_axis, $no_axes, $two_axes, $use_axis, $zero_axis, $zero_axis_only, $axis_space, $text_space, $cumulate, $overwrite, $correct_width, $values_vertical, $values_space, $values_format, $legend_placement, $legend_marker_width, $legend_marker_height, $lg_cols ) ; # $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' ; $RTF_PNG_Begin .= "\\picw" . (${xdim} + 0) . " " ; # Width in pixels $RTF_PNG_Begin .= "\\pich" . (${ydim} + 0) . " " ; # Height in pixels $RTF_PNG_Begin .= "\\picwgoal" . (${xdim}*20) ; # width on the page in twips $RTF_PNG_Begin .= "\\pichgoal" . (${ydim}*20) ; # Height on the page in twips. $RTF_PNG_Begin .= $Eol ; # I am using a pixel in a point. A point is 1/72 inches. # A twip is 1/20 of a point. $RTF_PNG_Begin .= "\\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. $RTF_PNG_Close = $rCurly . $rCurly ; # Ends pict and shppict commands. $RTF_PNG_Close .= $Eol ; $HBI_Debug_msg_str = "" ; $offset = 0 ; $length_line = 40 ; $len_left ; $part_data = "" ; $Hex_image ; $All_data_len = length $Graph2_str ; do { $len_left = $All_data_len - $offset ; if ($len_left < $length_line) {$length_line = $len_left;} $part_data .= unpack ("H*", substr($Graph2_str, $offset, $length_line)) ; $part_data .= $Eol ; $offset += $length_line ; } while ($offset < $All_data_len ) ; $SYSTEM{'Bargraph2'} = $RTF_PNG_Begin . $part_data . $RTF_PNG_Close ; if ($HBI_Debug) { $last_index = $#{$QUESTIONS_AH} ; if ($last_index == -1) { print "\<br\>\n" ; print "\<br\>\<br\>QUESTIONS_AH HASH ARRAY is empty.\<br\>\n" ; print "\<br\>\n" ; } else { print "\<br\>\<br\>QUESTIONS_AH HASH ARRAY Dump.\<br\>\n" ; foreach $index (0 .. $last_index) { print "\<br\>\n" ; # HBI print "\<br\>\<br\>QUESTIONS_AH HASH ARRAY Element $index \<br\>\n" ; foreach $key (sort keys (%{${$QUESTIONS_AH}[$index]})) { print "KEY $key VAL " ; print "${$QUESTIONS_AH}[$index]->{$key}" ; print "\<br\>\n" ; } # end foreach $key } # end foreach $index } # end of if $last_index } # end of if $HBI_Debug if ($HBI_Debug) { $last_index = $#{$QUESTIONS_AG} ; if ($last_index == -1) { print "\<br\>\n" ; print "\<br\>\<br\>QUESTIONS_AG HASH ARRAY is empty.\<br\>\n" ; print "\<br\>\n" ; } else { print "\<br\>\<br\>QUESTIONS_AG HASH ARRAY Dump.\<br\>\n" ; foreach $index (0 .. $last_index) { print "\<br\>\n" ; # HBI print "\<br\>\<br\>QUESTIONS_AG HASH ARRAY Element $index \<br\>\n" ; foreach $key (sort keys (%{${$QUESTIONS_AG}[$index]})) { print "KEY $key VAL " ; print "${$QUESTIONS_AG}[$index]->{$key}" ; print "\<br\>\n" ; } # end foreach $key } # end foreach $index } # end of if $last_index } # end of if $HBI_Debug # Now we are going to format the date the test was taken. <%=FORM.tdatesel%> # Original text is like 05-Jul-2013_19:37:35_GMT my $given_date_str = $FORM{'tdatesel'} ; my $new_fmt_date ; my ($day_month, $month_str, $cent_year) ; if ($given_date_str =~ m/^(\d+)\-([^\-]+)\-(\d+)/ ) { $day_month = $1 ; $month_str = $2 ; $cent_year = $3 ; $month_str = $Month_Full{$month_str} if ($Month_Full{$month_str}) ; $FORM{'tdatesel'} = &RTFize("$month_str $day_month, $cent_year") ; } $SYSTEM{'FeedBackDate'} = &RTFize($SYSTEM{'FeedBackDate'}) ; if ($HBI_Debug) { print "\<br\>\n" ; print "full name\<br\>\n" ; print $CANDIDATE{'full_name'} ; print "\<br\>\n" ; print "Test Date\<br\>\n" ; print $FORM{'tdatesel'} ; print "\<br\>\n" ; print "FeedBack Date\<br\>\n" ; print $SYSTEM{'FeedBackDate'} ; print "\<br\>\n" ; print "Graphic Text\<br\>\n" ; print $SYSTEM{'Graphic_Text'} ; print "\<br\>\n" ; print "Comments\<br\>\n" ; print $SYSTEM{'ALL_Comments'} ; print "\<br\>\n" ; print "SYSTEM First Barchart\<br\>\n" ; print $SYSTEM{'Bargraph1'} ; print "\<br\>\n" ; print "SYSTEM Second Barchart\<br\>\n" ; print $SYSTEM{'Bargraph2'} ; print "\<br\>\n" ; 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("TGWall_360_Blank_Report.rtf") ; $OUTPUT_Format = "HTML" ; } ################################################################################ # # Subroutine Name # GetTestHeader # # Description # This subroutine returns the header of the test file # # Inputs # $clientId -- The id of the client to search through # # Outputs # None # # Returns # @testFields -- An array of fields in the header # #adt080401############################################################################### sub GetTestHeader { my $clientId = $_[0]; my @testList = &get_data("tests.$clientId"); my $testHdr = $testList[0]; my $testFields; chop( $testHdr ); @testFields = split( /&/, $testHdr ); return @testFields; } #adt080401############################################################################### # # Subroutine Name # GetTestsByOwner # # Description # This subroutine searches through the test definition file of the given # client for all the tests that are owned by the given user id or are public # # Inputs # $clientId -- The id of the client to search through # $ownedBy -- The name of the owner of the test to search for # # Outputs # None # # Returns # @tests -- An array of tests owned by the given user id # ################################################################################ sub GetTestsByOwner { my $clientId = $_[0]; my $ownedBy = $_[1]; my %currHash; my @testList = &get_data("tests.$clientId"); my @currField; my @tests; my $testHdr = $testList[0]; my $testFields; my $testCntr; @testFields = &GetTestHeader( $clientId ); for( $testCntr = 1; $testCntr < $#testList; $testCntr++ ) { #print "<b>$testList[$testCntr]</b><br>\n"; chop( $testList[$testCntr] ); @currField = split( '&', $testList[$testCntr] ); for( 0 .. $#testFields ) { $currHash{$testFields[$_]} = $currField[$_]; } #print "$currHash{'ownedby'} - $ownedBy<p>"; if( ( $currHash{'ownedby'} eq $ownedBy ) || ( $currHash{'ownedby'} eq "" ) ) { push( @tests, $testList[$testCntr] ); #print "<font color=\"#ff0000\"><b>$testList[$testCntr]</b></font><br>\n"; } } return @tests; } # # Return: Count of test result files in $dir matching regex with $clid # and $testid, OR -1 if there was an error. # sub CountTestFilesByCnd { my ($dir, $clid, $testid, $cndid) = @_; if ( ! defined($dir) ) { &logger::logerr("Undefined directory for client ID '$clid', testid '$testid'"); return -1; } if ( ! defined($clid) ) { &logger::logerr("Undefined client ID for directory '$dir', testid '$testid'"); return -1; } if ( ! defined($testid) ) { &logger::logerr("Undefined test ID for directory '$dir', client ID '$clid'"); return -1; } my $tstcount = scalar(get_matching_files($dir, "^$clid".'\.'."$cndid".'\.'."$testid\$")); return $tstcount; } # # Return: Count of test result files in $dir matching regex with $clid # and $testid, OR -1 if there was an error. # sub CountHistoricTests { my ($dir, $clid, $testid, $cndid) = @_; if ( ! defined($dir) ) { &logger::logerr("Undefined directory for client ID '$clid', testid '$testid'"); return -1; } if ( ! defined($clid) ) { &logger::logerr("Undefined client ID for directory '$dir', testid '$testid'"); return -1; } if ( ! defined($testid) ) { &logger::logerr("Undefined test ID for directory '$dir', client ID '$clid'"); return -1; } my $historyfile = join($pathsep,$dir,"$clid.$testid.history"); open (HISTFILE,"<$historyfile") or return 0; my @histentries = <HISTFILE>; close HISTFILE; my $sgrepfor=join('&',"\<\<\>\>$clid","$cndid","$testid",""); my @cndidentries = grep( /$sgrepfor/,@histentries); my $tstcount = $#cndidentries + 1; return $tstcount; } # # Return: Count of cnd result files in $dir matching regex with $clid # and $cndid, OR -1 if there was an error. # sub CountCndFiles { my ($dir, $clid, $cndid) = @_; if ( ! defined($dir) ) { &logger::logerr("Undefined directory for client ID '$clid', cndid '$cndid'"); return -1; } if ( ! defined($clid) ) { &logger::logerr("Undefined client ID for directory '$dir', cndid '$cndid'"); return -1; } if ( ! defined($cndid) ) { &logger::logerr("Undefined cnd ID for directory '$dir', client ID '$clid'"); return -1; } return scalar(get_matching_files($dir, "^$clid".'\.'."$cndid".'\.\S+$')); } # # Return: Sum of times taken during a test in seconds. # sub computeTestTime { my ($dir, $clid, $testid, $cndid, $tstkey) = @_; if ( ! defined($dir) ) { &logger::logerr("Undefined directory for client ID '$clid', testid '$testid'"); return -1; } if ( ! defined($clid) ) { &logger::logerr("Undefined client ID for directory '$dir', testid '$testid'"); return -1; } if ( ! defined($testid) ) { &logger::logerr("Undefined test ID for directory '$dir', client ID '$clid'"); return -1; } my $timefile = join($pathsep,$dir,"$clid.$cndid.$testid.tim"); open (TLOGFILE,"<$timefile") or return 0; my @tlogentries = <TLOGFILE>; close TLOGFILE; my $sgrepfor="^$tstkey\&(1)\.(2)\.(.*)\&$clid\&$cndid\&$testid\&(.*)"; my @cndidentries = grep( /$sgrepfor/,@tlogentries); @tlogentries = (); my $iidx; my @tentrycols; my $tottime; $tottime = 0; for $iidx (0 .. $#cndidentries) { @tentrycols = split(/&/,$cndidentries[$iidx]); $tottime += $tentrycols[7]; } @tentrycols = (); return $tottime; } sub formatTimeFromSeconds { my ($t, $fmt) = @_; my $h; my $m; my $s; my $r; my $j; $m = int($t/60); $s = $t - ($m * 60); $h = int($m/60); $m = $m - ($h * 60); if ($fmt =~ m/h/i) { $r = "00000$h"; $j=length($r)-2; $r = substr($r,$j,2); $fmt =~ s/h/$r/g; } if ($fmt =~ m/m/i) { $r = "00000$m"; $j=length($r)-2; $r = substr($r,$j,2); $fmt =~ s/m/$r/g; } if ($fmt =~ m/s/i) { $r = "00000$s"; $j=length($r)-2; $r = substr($r,$j,2); $fmt =~ s/s/$r/g; } return $fmt; } # Normally xdim was 400 and ydim was 100. sub BuildBarGraph { # This subroutine builds the HTML to get an image from an URL. # The URL is a cgi-bin PERL script, with several parameters. # The list parameters are: labels, values, and values2. # The scalar parameters are: xdim, ydim, hbar, title, xlabel, ylabel, ymax, ymin, yticknum, colorscheme, $t_margin, $b_margin, $l_margin, $r_margin # The first 3 parameters are references to three lists, which are mandatory. # The values2 list may be an empty list. (and ignored.) # The rest of the parameters are optional, but are order specific. # Any parameter that is an empty string will be effectively ignored, # but may be required to fill the list of parameters to a needed parm. my @label_names, @value_points, @value2_points ; my $labels_ref, $values_ref, $values2_ref ; 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 = 0 ; 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 get_full_history { # Parameters # $dir # $clientID # $testID # Side Effect # All of the data is placed into the global variable %FULL_HISTORY # Returned Value # $ret - 0 implies failure, 1 implies success. # %FULL_HISTORY format. # Key is the Client ID. # value is an anon. hash. # Its key is the Test ID. # value is an anon. hash. # Its key is the Candidate ID. # value is an anon. hash. # Its key is the time of the test in seconds for the GMT time zone. # value is the raw character string of the data. # To access a single test's data: # $FULL_HISTORY->{$clientID}->{$testID}->{$candidateID}->{$GMTsec} my ($dir,$clientID,$testID) = @_; my $trash = join($pathsep, $dir, "$clientID.$testID.history"); my $HBI_Debug_get_full_history = 1 ; my $Open_state = 1 ; open(TESTFILE, "<$trash") or $Open_state = 0 ; unless ($Open_state) { # The open failed. warn "ERROR: Failed to open $trash " ; return 0 ; } # The open succeeded. my @seqlines = (); @seqlines = <TESTFILE>; close TESTFILE; if ($HBI_Debug_get_full_history) { warn "INFO: History file $clientID.$testID.history line count is " . ($#seqlines + 1) . " \n" ; } my $testline ; my $Line_cnt = 0 ; foreach $testline (@seqlines) { my $match_state ; $Line_cnt ++ ; if ($testline =~ m/^([^\<]+)\<\<\>\>([^\&]+)&([^\&]+)&([^\&]+)&/) { my $time_ascii = $1 ; my $Client_id_str = $2 ; my $candidateID = $3 ; my $Test_id_str = $4 ; if ($Client_id_str ne $clientID) { warn "ERROR: Bad test history file data ${clientID}.${testID}.history " . "line $Line_cnt has mismatched client id.\n" ; } if ($Test_id_str ne $testID) { warn "ERROR: Bad test history file data ${clientID}.${testID}.history " . "line $Line_cnt has mismatched test id.\n" ; } my $timestamp = &toGMSeconds($time_ascii) ; unless ($timestamp) { warn "ERROR: Bad test history file data ${clientID}.${testID}.history " . "line $Line_cnt has bad time stamp.\n" ; $timestamp = "UNK $Line_cnt" ; # Unique value for the file. } if ($HBI_Debug_get_full_history and ($Line_cnt <= 4 )) { warn "INFO: History file $clientID.$testID.history time_ascii $time_ascii timestamp $timestamp\n" ; } $FULL_HISTORY->{$clientID}->{$testID}->{$candidateID}->{$timestamp} = $testline ; } else { warn "ERROR: get_full_history failed to match a valid format in a test history file.\n" ; warn "ERROR: get_full_history file ${clientID}.${testID}.history line $Line_cnt \n" ; next ; } } if ($HBI_Debug_get_full_history) { warn "INFO: History file $clientID.$testID.history RETURN 1, line_cnt $Line_cnt \n" ; } return 1 ; } sub get_group_hash { # Parameters # $client - Client ID string. # Returned value. # $Group_hash - A scalar reference to an anonymous hash. # The keys of the hash are the group ids. # The values are another hash of data for the group. # The keys are the field ids: grpowner, grpid, grpnme, grplist, validfrom, validto # and GroupMembersA. # The value of GroupMembersA is an anon array of the candidate ids of the members. # The other values are the raw data of the fields in the group file. my ($clientID) = @_ ; my $HBI_Debug_get_group_hash = 0 ; my @GroupData = &get_client_groups($clientID); my $GroupID_HREF = {} ; my $idxid = $GRPFIELD{'grpid'}; my @GroupFieldIDs = keys %GRPFIELD ; warn "INFO: idxid $idxid Field IDS " . (join(" ", @GroupFieldIDs)) . "\n" if ($HBI_Debug_get_group_hash) ; my ($FieldID, $GroupID ) ; my $orig_data ; my @split_orig_data ; my $raw_data ; foreach $orig_data (@GroupData) { chomp $orig_data ; @split_orig_data = split(/&/, $orig_data) ; $GroupID = $split_orig_data[$idxid] ; warn "INFO: Simple group ID $GroupID raw data $raw_data\n" if ($HBI_Debug_get_group_hash) ; # Populate the raw data. foreach $FieldID (@GroupFieldIDs) { $GroupID_HREF->{$GroupID}->{$FieldID} = $split_orig_data[$GRPFIELD{$FieldID}] ; warn "INFO: group ID $GroupID FieldID $FieldID " . "Value " . $GroupID_HREF->{$GroupID}->{$FieldID} . "\n" if ($HBI_Debug_get_group_hash) ; } $candidates = $GroupID_HREF->{$GroupID}->{'grplist'} ; chomp $candidates ; $GroupID_HREF->{$GroupID}->{'GroupMembersA'} = [ split (/\,/, $candidates) ] ; warn "INFO: group ID $GroupID Candidates " . join (" ", $GroupID_HREF->{$GroupID}->{'GroupMembersA'} ) . "\n" if ($HBI_Debug_get_group_hash) ; } return $GroupID_HREF ; } sub RTFHexEscape { # Return the RTF Hex Escape of the first character in $_. my $oldstr = shift(@_) ; my $retstr = unpack ("H*", substr($oldstr, 0, 1)) ; if ($retstr) { return "\\\'" . $retstr ; } else { return "" ; } } sub RTFize { # Parameter # $textStr - An ASCII text string, not to be modified. # Returned value # $retStr - the $textStr with all special characters converted to special RTF sequences. # Control Characters 0-31, or 0x00 to 0x1F # tab, 0x09, becomes "\tab ". # carriage returns, 0x0D; and line feeds, 0x0A; are left alone. # Other control characters are deleted. # Left Curly Brace becomes \'7b. # Right Curly Brace becomes \'7d. # Back slash becomes \'5c. # Characters 128 to 255 become the hex escaped equivalent. my ($retStr) = @_ ; # Delete special control characters. $retStr =~ s/[\x00-\x08\x0B\x0C\x0E-\x1F]//g ; # Convert the back slash. $retStr =~ s/\\/\\\'5C/g ; # Convert tab. $retStr =~ s/\x09/\\tab /g ; # Convert characters that become the hex escaped value. $retStr =~ s/([\x7b\x7d\x80-\xFF])/&RTFHexEscape($1)/ge ; return $retStr ; } sub 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) = @_ ; my $HBI_Debug_Groups = 0 ; 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}}) { 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_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. ${$QUESTIONS_AH}[$index1]->{'qtx'} = &RTFize(${$QUESTIONS_AH}[$index1]->{'qtx'}) ; ${$QUESTIONS_AH}[$index1]->{'qtx'} =~ s/\s*(\<br\>)+\s*/\\par /isg ; $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'} = &RTFize(${$QUESTIONS_AH}[$index1]->{'responses'}) ; ${$QUESTIONS_AH}[$index1]->{'comments'} = &RTFize(${$QUESTIONS_AH}[$index1]->{'comments'}) ; ${$QUESTIONS_AH}[$index1]->{'responses'} =~ s/\s*\<br\>\s*/\\par /isg ; ${$QUESTIONS_AH}[$index1]->{'comments'} =~ s/\s*\<br\>\s*/\\par /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 ; 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 ; $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. if ($full_history_OK) { my @FeedBack_test_times ; my $FeedBack_Test_Time ; @FeedBack_test_times = keys %{$FULL_HISTORY->{$client}->{$testid2}->{$user}} ; 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. $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] ; chomp $response_g ; chomp $comment_g ; $response_g = &RTFize($response_g) ; $comment_g = &RTFize($comment_g) ; $response_g =~ s/\s*(\<br\>)+\s*/\\par /isg ; $comment_g =~ s/\s*(\<br\>)+\s*/\\par /isg ; ${$QUESTIONS_AG}[$index1]->{'responses'} .= $response_g . "\\par \n" if ($response_g) ; ${$QUESTIONS_AG}[$index1]->{'comments'} .= $comment_g . "\\par \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 ; } if ($ques_type eq "lik") { @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 $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 ; } 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 GRP @group \n" if ($HBI_Debug_Feedback[3]) ; $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