#!/usr/bin/perl # Source File: likert_wall_105.pl # Get config # use strict; # use diagnostics ; use FileHandle; use Time::Local; use Data::Dumper; use IntegroLib; require 'sitecfg.pl'; require 'testlib.pl'; require 'tstatlib.pl'; require 'questionslib.pl'; # require 'LikertData.pl' ; # require 'grepa.pm' ; use bargraph_multi ; use vars qw(%FORM %SESSION %CLIENT %TEST_SESSION %SUBTEST_QUESTIONS %TEST %SUBTEST_SUMMARY %CANDIDATE %SUBTEST_ANSWERS %SYSTEM %REPORT %SUBTEST_RESPONSES @xlatphrase); use vars qw($testcomplete $cgiroot $pathsep $dataroot @rptparams ); use vars qw($testinprog $testpending) ; use vars qw($QUESTIONS_AG) ; # &app_initialize; if (exists $FORM{"idlist"} and $FORM{"idlist"}) { $FORM{"idlist"} =~ tr/\000/,/ ; # Change separator for multiple values from NULL to comma. HBI } # Turn on the debugging flags only when we are going to generate a report. use vars qw($HBI_Debug_idlist $HBI_Debug_grouping $HBI_Debug_FORM $HBI_Debug_Report $HBI_Debug) ; $HBI_Debug_idlist= $HBI_Debug_grouping = $HBI_Debug_FORM= $HBI_Debug_Report= 0 ; $HBI_Debug = 0 ; if (exists $FORM{'reportname'} and $FORM{'reportname'} and $FORM{'reportname'} =~ m/LikertWQ/) { $HBI_Debug_idlist = 0 ; $HBI_Debug_grouping = 0 ; $HBI_Debug_FORM = 0 ; $HBI_Debug_Report = 0 ; } $HBI_Debug = $HBI_Debug_idlist || $HBI_Debug_grouping || $HBI_Debug_FORM || $HBI_Debug_Report ; if ($HBI_Debug_idlist) { warn "INFO: FORM idlist " . $FORM{"idlist"} . " X\n" ; } # Make sure we have a valid session, and exit if we don't if ($FORM{'tid'}) { if (not &get_session($FORM{'tid'})) { die "ERROR: " . __FILE__ . " started without a valid FORM Session ID.\n" ; } } else { die "ERROR: " . __FILE__ . " started without a FORM Session ID.\n" ; } &LanguageSupportInit(); # print STDERR Dumper(\%FORM); if ($SESSION{'clid'}) { &get_client_profile($SESSION{'clid'}); } else { die "ERROR: " . __FILE__ . " started without a SESSION Client ID.\n" ; } # If a report has not been choosen, then run reportChooser. # else Prep for a report and run the report. if ((! exists $FORM{'reportname'}) or $FORM{'reportname'} !~ m/\w/) { &ReportChooser(); exit 0 ; } if ($FORM{'tstid'}) { &get_test_profile($CLIENT{'clid'}, $FORM{'tstid'}); } else { die "ERROR: " . __FILE__ . " started without a FORM Test ID.\n" ; } # Get the group filters, if any my ($idlist,$groups); use vars qw(@Report_Groups) ; if (exists $FORM{'grouping'} and $FORM{'grouping'} eq 'subset') { #my @tmp = split(/,/,$FORM{'idlist'}); @Report_Groups = param('idlist'); $FORM{'idlist'} = join(',', @Report_Groups); if ($HBI_Debug_idlist) { warn "INFO: Second FORM idlist " . $FORM{"idlist"} . " X\n" ; } @{$groups}{@Report_Groups} = @Report_Groups; $idlist = &getIdlist($CLIENT{'clid'},$FORM{'idlist'}); # $idlist is a ref to a hash. The keys are the candidate ids in the groups. # The values are all 1. if ($HBI_Debug_idlist) { warn "INFO: Third idlist " . Dumper(\$idlist) . " X\n" ; } } # Get the time stamp style my $timestamp; if ($FORM{'timestamp'} eq 'currenttime') { $timestamp = scalar(localtime(time)); } elsif ($FORM{"timestamp"} eq 'custom' and $FORM{'customtime'} ne '') { $timestamp = $FORM{'customtime'}; } elsif ($FORM{'timestamp'} eq 'mostrecent' and $FORM{'tstid'}) { my $file = join($pathsep,$testcomplete,"$CLIENT{'clid'}.$FORM{'tstid'}.history"); my $fh = new FileHandle; if ($fh->open($file)) { my @history = map([split(/(?:<<>>|&)/,$_,4)],<$fh>); # print "
".Dumper(\@history)."
"; if (defined $idlist) { foreach (reverse @history) { if (exists $idlist->{$_->[2]}) { $timestamp = scalar(localtime(toGMSeconds($_->[0]))); last; } } } else { $timestamp = scalar(localtime(toGMSeconds($history[$#history]->[0]))); } } else { print STDERR "Could not open $file in " . __FILE__ . "\n"; } } if (defined $timestamp) { $timestamp = "$timestamp

\n"; } else { $timestamp = "
\n"; } # Generate the reports # if ($FORM{'reportname'} eq 'LikertWQ') { # &LikertWQ($idlist, $groups, $timestamp); # The LikertWQ subroutine is in Likert_Gen_Groups.pl and teststats-tgwall101.pl if ($FORM{'reportname'} eq 'LikertWQG') { &LikertWQG($idlist, $groups, $timestamp); } else { die "ERROR: " . __FILE__ . " run without a valid report name. " . "Client ID $CLIENT{'clid'}, Test ID $FORM{'tstid'}, " . "Report Name $FORM{'reportname'}\n" ; } # There should only be function definitions beyond this point. exit(0); sub HTMLHeader { my $title = "" ; my $ret_str = "" ; my $JAVA_script = "" ; ($title, $JAVA_script) = @_ ; $ret_str .= "\n\n${title}\n" ; $ret_str .= "\n" ; $ret_str .= "\n\n" ; $ret_str .= "\n" ; return $ret_str ; } sub HTMLHeaderPlain { return "\n\n$_[0]\n". "\n\n". "\n"; } sub HTMLFooter { my $year = `date +%Y`; my $ionline = "" ; return "
Copyright (c) $year, ACTS Corporation$ionline\n\n"; } sub ReportChooser { # Links w/javascript for chosing report # Radio button to choose between all and select group(s) # Menu box to chose one or more groups my $groups = &getGroups($CLIENT{'clid'}); my $js = "function parmsIntegro(oform,rpt) {\n\t". "oform.reportname.value=rpt;\n\t". "oform.action='/cgi-bin/creports.pl';\n\t". "oform.submit();\n};\n"; # $js .= "\nfunction commIntegro(oform) {\n\t". "oform.rptid.value='ACT-C-004';\n\t". "oform.rptdesc.value='Test Statistics by Test'\n\t". "oform.action='/cgi-bin/IntegroTS.pl';\n\t". "oform.submit();\n};\n"; my $organizationname = $CLIENT{'clnmc'}; my $uberheader = "" ; my $TESTS = get_data_hash ("tests.$CLIENT{'clid'}") ; # print STDERR Dumper($TESTS) ; my %TESTS = %$TESTS ; my @test_list = () ; my $ids ; for $ids (keys %TESTS) { # warn "ID $ids DATADESC $TESTS{$ids}->{'desc'} X" ; push @test_list, [$TESTS{$ids}->{'desc'}, $ids] ; } # warn "test_list count $#test_list X\n" ; # print STDERR Dumper(\@test_list) ; my ($js1, $test_choice_html) = ret_test_chooser_mod(@test_list) ; #print STDERR get_data("tests.$CLIENT{'clid'}"); #print STDERR "Test ID = $tstid\n"; print HTMLHeader("TG Wall Custom Reports",$js . $js1); print "
\n"; print "\n"; # For development purposes we hardcode the survey id. # Fix this before production # print "\n"; # HBI This had a value of $tstid print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; print "
\n\n\n". "\n". "\n"; print "\n"; print ""; print "
TG Wall Custom Reports
All GroupsChoose Groups
\n". "\n"; #print "
$xlatphrase[797] $xlatphrase[279]:
\n"; print "
Organization Name:
Header Override:
Time Stamp:
    ". "
  • Most Recent Survey Taken
  • ". # "
  • Current Time
  • ". # "
  • Custom Value: ". # "
  • "
\n"; print $test_choice_html ; print "

Likert Scale Report" ; print "

\n" ; print "\n"; print "\n"; print "
"; print HTMLFooter(); } sub LikertWQG { # This does the Summary on the Likert Scale questions, # for everybody, or just groups, and lists group results. # $idlist is the list of candidate ids to report on. It is undef when all groups (everyone) is choosen. # It is a reference to a hash. The keys are the candidate ids, and the value is 1 for candidates in the choosen groups. # $groups is the hash of groups to report on. It is undef when all groups (everyone) is choosen. # It is a reference to a hash. The keys are the group ids, and the values are the group ids. # $FORM{'idlist'} is a comma separated list of the group ids of the selected groups. # $FORM{'grouping'} is "subset" when the report should only cover the selected groups. # $FORM{'grouping'} is "all" when the report should cover everybody. use vars qw($QUESTIONS_AG) ; my ($idlist,$groups,$timestamp) = @_; my $ResponseRequired = 1 ; # Do not count questions if there was no response. my $client = $SESSION{'clid'} ; my $testid2 = $FORM{'tstid'} ; my $all_groups = getGroups($client) ; my $group_membership_required ; if ($groups) { $group_membership_required = 1 ; my $group_p ; for $group_p (keys %{$all_groups}) { unless ($groups->{$group_p}) { undef $all_groups->{$group_p} ; } } } else { $group_membership_required = 0 ; } $SYSTEM{'FeedBackDate'} = "Date UNK" ; use vars qw($FeedBackDateTime) ; use vars qw($FULL_HISTORY) ; $FeedBackDateTime = 0 ; use vars qw($full_history_OK) ; $full_history_OK = &get_full_history($testcomplete, $client, $testid2) ; my $HBI_Debug_FeedBack = 0 ; my ($sumdata, $grpdata) = &GetTGWallLikertGrpData($client, $testid2, $all_groups, $group_membership_required, $ResponseRequired) ; my $last_index = $#{$QUESTIONS_AG} ; if ($HBI_Debug_Report ) { warn "sumdata" ; warn &Dumper(\$sumdata) ; warn "grpdata" ; warn &Dumper(\$grpdata) ; } my $MasterGroupHash = &get_group_hash($client) ; my $grplist = {} ; my $groupid ; my $HBI_Debug_Groups_800 = 0 ; warn "INFO: grplist reference " . (ref $grplist) . "\n" if ($HBI_Debug_Groups_800) ; use vars qw(@Report_Groups) ; foreach $groupid (@Report_Groups) { if (exists $MasterGroupHash->{$groupid}->{'GroupMembersA'}) { $grplist->{$groupid} = $MasterGroupHash->{$groupid}->{'GroupMembersA'} ; } else { $grplist->{$groupid} = () ; } warn "INFO: Group ID $groupid \n" if ($HBI_Debug_Groups_800) ; warn "INFO: Group members : " . join (" ", @{$grplist->{$groupid}}) . "\n" if ($HBI_Debug_Groups_800) ; } # Get the current year for the copyright. my $date_ascii = localtime ; chomp $date_ascii ; my @date_parts = split (/ +/, $date_ascii) ; $SYSTEM{'CopyRightYear'} = $date_parts[4] ; # Get the consolidated comments from all the likert questions. my @CommSuperCats = sort keys %{$sumdata} ; my @SuperCatQuestions ; my $CommSuperCategory ; my $SuperCatQuestion ; foreach $CommSuperCategory (@CommSuperCats) { @SuperCatQuestions = keys %{$sumdata->{$CommSuperCategory}->{'Questions'}} ; $SYSTEM{'ALL_Comments'} .= "\\par \\par CATEGORY - $CommSuperCategory\n" ; # $SYSTEM{'ALL_Comments'} .= "\\par \n" ; my @SortedQuestions = sort {$a <=> $b} @SuperCatQuestions ; foreach $SuperCatQuestion (@SortedQuestions) { $SYSTEM{'ALL_Comments'} .= "\\par \\par Question " ; # $SYSTEM{'ALL_Comments'} .= "\\par Question " . ($SuperCatQuestion + 1) . " - " ; $SYSTEM{'ALL_Comments'} .= ${$QUESTIONS_AG}[$SuperCatQuestion]->{'qtx'} . "\\par \n" ; my $qComm = ${$QUESTIONS_AG}[$SuperCatQuestion]->{'comments'} ; if ($qComm) { $SYSTEM{'ALL_Comments'} .= $qComm ; } else { $SYSTEM{'ALL_Comments'} .= "\\par NO Comments.\n" ; } } } $SYSTEM{'orgname_Show'} = &RTFize($FORM{'orgname'}) ; if ($HBI_Debug_Report ) { print "Content-Type: text/html\n\n"; print HTMLHeaderPlain("Likert Scale Group Results"); print "" ; print "Likert Scale Group Results
" ; print "Survey/Test $TEST{'desc'}


\n"; print "

\n" ; # print "Improvement as Perceived by Employees
\n"; # print "$FORM{'orgname'}
\n"; if ($FORM{'uberheader'} ne "") { print "".$FORM{'uberheader'}."
\n"; } if (defined $idlist) { print "Summary for Groups: " .join(", ",map($all_groups->{$_}->{'grpnme'},split(/,/,$FORM{'idlist'})))."
\n" ; } # print "$xlatphrase[798] $xlatphrase[799]
\n"; print "

Timestamp ", $timestamp, "

\n" ; print "" ; # Print HTML for heading. my $key ; print "\\n" ; if ($HBI_Debug_FeedBack) { my $FBClient; my $FBtest; my $FBcand ; print "

", "INFO: FB Clients " . (join(" ", keys %{$FULL_HISTORY})) . "\n" ; foreach $FBClient (keys %{$FULL_HISTORY}) { print "

" . "INFO: FB client $FBClient tests " . (join(" ", keys %{$FULL_HISTORY->{$FBClient}})) . "\n" ; foreach $FBtest (keys %{$FULL_HISTORY->{$FBClient}}) { print "

" . "INFO: FB client $FBClient test $FBtest candidates " . (join(" ", keys %{$FULL_HISTORY->{$FBClient}->{$FBtest}})) . "\n" ; foreach $FBcand (keys %{$FULL_HISTORY->{$FBClient}->{$FBtest}}) { print "

" . "INFO: FB times $FBClient test $FBtest candidate $FBcand " . (join(" ", keys %{$FULL_HISTORY->{$FBClient}->{$FBtest}->{$FBcand}})) . "\n" ; } } } print "

\n" ; } print "\\SESSION HASH ARRAY\\n" ; foreach $key (sort keys (%SESSION)) { print "KEY $key VAL $SESSION{$key}\\n" ; } print "\\FORM HASH ARRAY\\n" ; foreach $key (sort keys (%FORM)) { print "KEY $key VAL $FORM{$key}\\n" ; } # use vars qw(@Report_Groups) ; print "\\idlist ARRAY \@Report_Groups\\n" ; print "Length of \@Report_Groups is " . ($#Report_Groups + 1) . "\\n" ; foreach $key (@Report_Groups) { print "Array element $key \\n" ; } print "\Dumper of \$FORM\{idlist\} " ; print Dumper($FORM{'idlist'}) ; print "\\\n" ; print "\\CLIENT HASH ARRAY\\n" ; foreach $key (sort keys (%CLIENT)) { # print "KEY $key VAL $CLIENT{$key}\\n" ; print ("KEY $key VAL ", &HTML_Maybe_Hash_Key_value(\%CLIENT, $key) , "\\n") ; } print "\\SYSTEM HASH ARRAY\\n" ; foreach $key (sort keys (%SYSTEM)) { print "KEY $key VAL $SYSTEM{$key}\\n" ; } print "\\TEST HASH ARRAY\\n" ; foreach $key (sort keys (%TEST)) { # print "KEY $key VAL $TEST{$key}\\n" ; print ("KEY $key VAL ", &HTML_Maybe_Hash_Key_value(\%TEST, $key) , "\\n") ; } print "\\TEST_SESSION HASH ARRAY\\n" ; foreach $key (sort keys (%TEST_SESSION)) { print "KEY $key VAL $TEST_SESSION{$key}\\n" ; } print "\\SUBTEST_QUESTIONS HASH ARRAY\\n" ; foreach $key (sort keys (%SUBTEST_QUESTIONS)) { print "KEY $key VAL $SUBTEST_QUESTIONS{$key}\\n" ; } print "\\SUBTEST_ANSWERS HASH ARRAY\\n" ; foreach $key (sort keys (%SUBTEST_ANSWERS)) { print "KEY $key VAL $SUBTEST_ANSWERS{$key}\\n" ; } print "\\SUBTEST_RESPONSES HASH ARRAY\\n" ; foreach $key (sort keys (%SUBTEST_RESPONSES)) { print "KEY $key VAL $SUBTEST_RESPONSES{$key}\\n" ; } print "\\SUBTEST_SUMMARY XXX HASH ARRAY\\n" ; foreach $key (sort keys (%SUBTEST_SUMMARY)) { print "KEY $key VAL $SUBTEST_SUMMARY{$key}\\n" ; } } print "\n" if ($HBI_Debug_Report ) ; # Set up Hashs for the data. my $OverAll = {} ; # Hash Reference. Keys are categories/Trust Components. my $ByGroup = {} ; # Hash Ref. keys {Group}->{Category}, value rounded percent. my $ByGroupTot = {} ; # Hash Ref. keys {Group} value PerCent all Cat. my $ByTotTot = 0 ; # Scalar percent of all groups and categories. my @supercats = sort keys %{$sumdata} ; my $cat_count = $#supercats + 1 ; # Number of categories. # # Print first row. print "" if ($HBI_Debug_Report ) ; print "" if ($HBI_Debug_Report ) ; my $supercat ; foreach $supercat (@supercats) { print "\n" if ($HBI_Debug_Report ) ; } print "" if ($HBI_Debug_Report ) ; print "\n" if ($HBI_Debug_Report ) ; # Print second row. Heading for each column. # Loop for Categories. my $tot_poss = 0 ; my $tot_earned = 0 ; print "" if ($HBI_Debug_Report ) ; print "\n" if ($HBI_Debug_Report ) ; for $supercat (@supercats) { # my $questions = "" ; my $possible = 0 ; my $earned = 0 ; # $questions = join(", ", sort keys %{$sumdata->{$supercat}->{'Questions'}}) ; $possible = $sumdata->{$supercat}->{'PointsAvail'} ; $earned = $sumdata->{$supercat}->{'PointsEarned'} ; $tot_poss += $possible ; $tot_earned += $earned ; $OverAll->{$supercat} = &Round_Per_Cent($earned, $possible) ; print &rep_cell_str($earned, $possible, 1) if ($HBI_Debug_Report ) ; } $ByTotTot = &Round_Per_Cent($tot_earned, $tot_poss) ; print &rep_cell_str($tot_earned, $tot_poss, 1) if ($HBI_Debug_Report ) ; print "\n" if ($HBI_Debug_Report ) ; # Print heading for Groups. my $col_count = $cat_count + 2 ; print "\n" if ($HBI_Debug_Report ) ; print "" if ($HBI_Debug_Report ) ; for $supercat (@supercats) { print "" if ($HBI_Debug_Report ) ; } print "\n" if ($HBI_Debug_Report ) ; unless ($grpdata) { print "\n" if ($HBI_Debug_Report ) ; } else { my $group ; foreach $group (sort keys %{$grpdata}) { if ($group) { print "" if ($HBI_Debug_Report ) ; print "" if ($HBI_Debug_Report ) ; my $tot_poss = 0 ; my $tot_earned = 0 ; for $supercat (@supercats) { my $possible = $grpdata->{$group}->{$supercat}->{'PointsAvail'} ; my $earned = $grpdata->{$group}->{$supercat}->{'PointsEarned'} ; $tot_poss += $possible ; $tot_earned += $earned ; $ByGroup->{$group}->{$supercat} = &Round_Per_Cent($earned, $possible) ; print &rep_cell_str($earned, $possible, 1) if ($HBI_Debug_Report ) ; } $ByGroupTot->{$group} = &Round_Per_Cent($tot_earned, $tot_poss) ; print &rep_cell_str($tot_earned, $tot_poss, 1) if ($HBI_Debug_Report ) ; print "\n" if ($HBI_Debug_Report ) ; } } } print "
$supercatTotal
Overall
Group Breakdown
Supervisor$supercatTotal
Pick Groups for more detail
" if ($HBI_Debug_Report ) ; # print "$group " if ($HBI_Debug_Report ) ; print $all_groups->{$group}->{'grpnme'} if ($HBI_Debug_Report ) ; print "
\n" if ($HBI_Debug_Report ) ; if ($HBI_Debug_Report ) { print "
sumdata
" ; print &Dumper(\$sumdata) ; print "
grpdata
" ; print &Dumper(\$grpdata) ; } my ($key, $index) ; if ($HBI_Debug) { if ($last_index == -1) { print "\\n" ; print "\\QUESTIONS_AG HASH ARRAY is empty.\\n" ; print "\\n" ; } else { foreach $index (0 .. $last_index) { print "\\n" ; # HBI print "\\QUESTIONS_AG HASH ARRAY Element $index \\n" ; foreach $key (sort keys (%{${$QUESTIONS_AG}[$index]})) { print "KEY $key VAL " ; # print "${$QUESTIONS_AG}[$index]->{$key}" ; print &HTML_Maybe_Array_Hash_Key_value($QUESTIONS_AG, $index, $key) ; print "\\n" ; } # end foreach $key } # end foreach $index } # end of if $last_index } # end of if $HBI_Debug # Lets go compute the stuff we need for the bar charts. my $Data1 = [] ; # The data for the chart. my $Category_ARef = [] ; my $category ; my $Legend1 = [ "Overall Organization" ] ; # The legends for the chart. my @All_Groups = sort keys %{$grpdata} ; my @Master_Color_Scheme_Array = qw(red blue lgreen yellow gray dgreen pink lbrown lred purple dblue lpurple green white gold dyellow marine dred cyan lblue orange lgray dbrown lyellow black dpink dgray lorange dpurple ) ; # Create the graph for the Overall Graph first. push @{$Category_ARef}, @supercats ; push @{$Category_ARef}, "Total" ; push @{$Data1}, $Category_ARef ; my $Category_ARef2 ; foreach $supercat (@supercats) { push @{$Category_ARef2}, $OverAll->{$supercat} ; } push @{$Category_ARef2}, $ByTotTot ; push @{$Data1}, $Category_ARef2 ; my $Opts = {} ; $Opts->{'width'} = ( 6 * 72 ) ; $Opts->{'height'} = ( 3 * 72 ) ; $Opts->{'title'} = "" ; $Opts->{'hbar'} = 1 ; $Opts->{'x_label'} = "" ; $Opts->{'y_label'} = "" ; $Opts->{'y_max_value'} = 100 ; $Opts->{'y_min_value'} = 0 ; $Opts->{'y_tick_number'} = 10 ; $Opts->{'t_margin'} = 20 ; $Opts->{'b_margin'} = 10 ; $Opts->{'l_margin'} = 10 ; $Opts->{'r_margin'} = 30 ; my $Consolidated_Color_index = $#Report_Groups + 1 ; $Opts->{'colorscheme'} = $Master_Color_Scheme_Array[$Consolidated_Color_index] ; # Get the last color. $Opts->{'bar_spacing'} = 0 ; $Opts->{'bargroup_spacing'} = 2 ; $Opts->{'show_values'} = 1 ; $Opts->{'transparent'} = 0 ; $Opts->{'x_label_position'} = 0.5 ; $Opts->{'overwrite'} = 0 ; $Opts->{'boxclr'} = "lgray" ; $Opts->{'legend_placement'} = "BC" ; $Opts->{'Graphic_Mode'} = "png" ; # $Legend1 = [ "a", "b", "c" ] ; # my $array_row ; # $array_row = [ "H", "I", "J", "K", "L", "Tot" ] ; # $Data1 = [ $array_row ] ; # $array_row = [ 11, 12, 13, 14, 15, 16 ] ; # push (@$Data1 , $array_row) ; # $array_row = [ 21, 22, 23, 24, 25, 26 ] ; # push (@$Data1 , $array_row) ; # $array_row = [ 31, 32, 33, 34, 35, 36 ] ; # push (@$Data1 , $array_row) ; my ($Graph1_obj, $Graph1_str) = &Build_Labeled_X_Axis_Graph_Str_opts($Data1, $Legend1, $Opts) ; my $Eol = "\r\n" ; my $lCurly = "\x7b" ; my $rCurly = "\x7d" ; # $lCurly, and $rCurly are used as curly braces, so vim is not confused # about matching perl code curly braces. my $RTF_PNG_Begin = $lCurly . '\\*\\shppict' ; $RTF_PNG_Begin .= $lCurly . '\\pict\\pngblip' ; # $Opts->{'xdim'} $RTF_PNG_Begin .= "\\picw" . ($Opts->{'width'} + 0) . " " ; # Width in pixels $RTF_PNG_Begin .= "\\pich" . ($Opts->{'height'} + 0) . " " ; # Height in pixels $RTF_PNG_Begin .= "\\picwgoal" . ($Opts->{'width'}*20) ; # width on the page in twips $RTF_PNG_Begin .= "\\pichgoal" . ($Opts->{'height'}*20) ; # Height on the page in twips. $RTF_PNG_Begin .= $Eol ; # I am using a pixel in a point. A point is 1/72 inches. # A twip is 1/20 of a point. $RTF_PNG_Begin .= "\\bliptag20000" ; # Unique identifier for the image. $RTF_PNG_Begin .= $lCurly . '\\*\\blipuid ' ; $RTF_PNG_Begin .= "00000000000000000000000000022710" ; # 32 numeric digits $RTF_PNG_Begin .= $rCurly . $Eol ; # Ends blipuid. my $RTF_PNG_Close = $rCurly . $rCurly ; # Ends pict and shppict commands. $RTF_PNG_Close .= $Eol ; my $HBI_Debug_msg_str = "" ; my $offset = 0 ; my $length_line = 40 ; my $len_left ; my $part_data = "" ; my $Hex_image ; my $All_data_len = length $Graph1_str ; if ($HBI_Debug_Report ) { print "\Graphical Data Info.\\n" ; # HBI print "Graph1_str length is $All_data_len \\n" ; if (defined $Graph1_obj) { print "Graph1_obj defined.\\n" ; print "Graph1_obj reference X", (ref $Graph1_obj), "X\\n" ; print "Graph1_obj X", $Graph1_obj, "X\\n" ; } else { print "Graph1_obj NOT defined.\\n" ; } print "\END SYSTEM Graph1_obj and string.\\\n" ; # HBI } do { $len_left = $All_data_len - $offset ; if ($len_left < $length_line) {$length_line = $len_left;} $part_data .= unpack ("H*", substr($Graph1_str, $offset, $length_line)) ; $part_data .= $Eol ; $offset += $length_line ; } while ($offset < $All_data_len ) ; $SYSTEM{'Barchart_org'} = $RTF_PNG_Begin . $part_data . $RTF_PNG_Close ; # Lets go compute the stuff we need for the Group bar charts. my $Chart_Group ; my $Chart_Group_cnt = 0 ; my $Chart_Group_Desc ; my @Group_Chart_Array = () ; foreach $Chart_Group (@Report_Groups) { $Data1 = [] ; # The data for the chart. $Category_ARef = [] ; my $Group_Name = $MasterGroupHash->{$Chart_Group}->{'grpnme'} ; $Legend1 = [ $Group_Name ] ; # The legends for the chart. # Create the graph for the Group push @{$Category_ARef}, @supercats ; push @{$Category_ARef}, "Total" ; push @{$Data1}, $Category_ARef ; # $Category_ARef2 ; $Category_ARef2 = [] ; foreach $supercat (@supercats) { push @{$Category_ARef2}, $ByGroup->{$Chart_Group}->{$supercat} ; } push @{$Category_ARef2}, $ByGroupTot->{$Chart_Group} ; push @{$Data1}, $Category_ARef2 ; # $Opts = {} ; # $Opts->{'width'} = ( 6 * 72 ) ; # $Opts->{'height'} = ( 5 * 72 ) ; # $Opts->{'title'} = "" ; # $Opts->{'hbar'} = 1 ; # $Opts->{'x_label'} = "" ; # $Opts->{'y_label'} = "" ; # $Opts->{'y_max_value'} = 100 ; # $Opts->{'y_min_value'} = 0 ; # $Opts->{'y_tick_number'} = 10 ; # $Opts->{'t_margin'} = 20 ; # $Opts->{'b_margin'} = 10 ; # $Opts->{'l_margin'} = 10 ; # $Opts->{'r_margin'} = 10 ; $Opts->{'colorscheme'} = $Master_Color_Scheme_Array[$Chart_Group_cnt] ; # Get the group color. # $Opts->{'bar_spacing'} = 0 ; # $Opts->{'bargroup_spacing'} = 2 ; # $Opts->{'show_values'} = 1 ; # $Opts->{'transparent'} = 0 ; # $Opts->{'x_label_position'} = 0.5 ; # $Opts->{'overwrite'} = 0 ; # $Opts->{'boxclr'} = "lgray" ; # $Opts->{'legend_placement'} = "BC" ; # $Opts->{'Graphic_Mode'} = "png" ; ($Graph1_obj, $Graph1_str) = &Build_Labeled_X_Axis_Graph_Str_opts($Data1, $Legend1, $Opts) ; # my $Eol = "\r\n" ; my $lCurly = "\x7b" ; my $rCurly = "\x7d" ; # $lCurly, and $rCurly are used as curly braces, so vim is not confused # about matching perl code curly braces. $RTF_PNG_Begin = $lCurly . '\\*\\shppict' ; $RTF_PNG_Begin .= $lCurly . '\\pict\\pngblip' ; # $Opts->{'xdim'} $RTF_PNG_Begin .= "\\picw" . ($Opts->{'width'} + 0) . " " ; # Width in pixels $RTF_PNG_Begin .= "\\pich" . ($Opts->{'height'} + 0) . " " ; # Height in pixels $RTF_PNG_Begin .= "\\picwgoal" . ($Opts->{'width'}*20) ; # width on the page in twips $RTF_PNG_Begin .= "\\pichgoal" . ($Opts->{'height'}*20) ; # Height on the page in twips. $RTF_PNG_Begin .= $Eol ; # I am using a pixel in a point. A point is 1/72 inches. # A twip is 1/20 of a point. my $bliptag_id = 20000 + 1 + $Chart_Group_cnt ; $RTF_PNG_Begin .= "\\bliptag" ; # Unique identifier for the image. $RTF_PNG_Begin .= $bliptag_id ; $RTF_PNG_Begin .= $lCurly . '\\*\\blipuid ' ; $RTF_PNG_Begin .= "000000000000000000000000000" ; # 32 numeric digits $RTF_PNG_Begin .= $bliptag_id ; $RTF_PNG_Begin .= $rCurly . $Eol ; # Ends blipuid. $RTF_PNG_Close = $rCurly . $rCurly ; # Ends pict and shppict commands. $RTF_PNG_Close .= $Eol ; $HBI_Debug_msg_str = "" ; $offset = 0 ; $length_line = 40 ; $part_data = "" ; $All_data_len = length $Graph1_str ; if ($HBI_Debug_Report ) { print "\Graphical Data Info - Group $Chart_Group.\\n" ; # HBI print "Graph1_str length is $All_data_len \\n" ; if (defined $Graph1_obj) { print "Graph1_obj defined.\\n" ; print "Graph1_obj reference X", (ref $Graph1_obj), "X\\n" ; print "Graph1_obj X", $Graph1_obj, "X\\n" ; } else { print "Graph1_obj NOT defined.\\n" ; } print "\END SYSTEM Graph1_obj and string.\\\n" ; # HBI } do { $len_left = $All_data_len - $offset ; if ($len_left < $length_line) {$length_line = $len_left;} $part_data .= unpack ("H*", substr($Graph1_str, $offset, $length_line)) ; $part_data .= $Eol ; $offset += $length_line ; } while ($offset < $All_data_len ) ; push @Group_Chart_Array , ($RTF_PNG_Begin . $part_data . $RTF_PNG_Close) ; $Chart_Group_cnt ++ ; } $SYSTEM{'Barchart_groups'} = join ("\n\\par \n" , @Group_Chart_Array ) ; # Lets go compute the stuff we need for the Consolidated bar charts. # my $Chart_Group ; my $Chart_Group_cnt = 0 ; my $Chart_Group_Desc ; my @All_Chart_Array = () ; $Data1 = [] ; # The data for the chart. $Legend1 = [ ] ; # The legends for the chart. $Category_ARef = [] ; push @{$Category_ARef}, @supercats ; push @{$Category_ARef}, "Total" ; push @{$Data1}, $Category_ARef ; foreach $Chart_Group ( sort {$MasterGroupHash->{$a}->{'grpnme'} cmp $MasterGroupHash->{$b}->{'grpnme'};} @All_Groups) { # Create the graph for the Group # $Category_ARef2 ; $Category_ARef2 = [] ; foreach $supercat (@supercats) { push @{$Category_ARef2}, $ByGroup->{$Chart_Group}->{$supercat} ; } push @{$Category_ARef2}, $ByGroupTot->{$Chart_Group} ; push @{$Data1}, $Category_ARef2 ; push @{$Legend1}, $MasterGroupHash->{$Chart_Group}->{'grpnme'} ; # warn "HBI chart_group $Chart_Group group name $MasterGroupHash->{$Chart_Group}->{'grpnme'} \n" ; } $Category_ARef2 = [] ; foreach $supercat (@supercats) { push @{$Category_ARef2}, $OverAll->{$supercat} ; } push @{$Category_ARef2}, $ByTotTot ; push @{$Data1}, $Category_ARef2 ; push @{$Legend1}, "Overall" ; # $Opts = {} ; # $Opts->{'width'} = ( 6 * 72 ) ; $Opts->{'height'} = ( 9 * 72 ) ; # $Opts->{'title'} = "" ; # $Opts->{'hbar'} = 1 ; # $Opts->{'x_label'} = "" ; # $Opts->{'y_label'} = "" ; # $Opts->{'y_max_value'} = 100 ; # $Opts->{'y_min_value'} = 0 ; # $Opts->{'y_tick_number'} = 10 ; # $Opts->{'t_margin'} = 20 ; # $Opts->{'b_margin'} = 10 ; # $Opts->{'l_margin'} = 10 ; # $Opts->{'r_margin'} = 10 ; $Opts->{'colorscheme'} = join (":", @Master_Color_Scheme_Array ) ; # Get the group color. # $Opts->{'bar_spacing'} = 0 ; # $Opts->{'bargroup_spacing'} = 2 ; # $Opts->{'show_values'} = 1 ; # $Opts->{'transparent'} = 0 ; # $Opts->{'x_label_position'} = 0.5 ; # $Opts->{'overwrite'} = 0 ; # $Opts->{'boxclr'} = "lgray" ; # $Opts->{'legend_placement'} = "BC" ; # $Opts->{'Graphic_Mode'} = "png" ; ($Graph1_obj, $Graph1_str) = &Build_Labeled_X_Axis_Graph_Str_opts($Data1, $Legend1, $Opts) ; # my $Eol = "\r\n" ; my $lCurly = "\x7b" ; my $rCurly = "\x7d" ; # $lCurly, and $rCurly are used as curly braces, so vim is not confused # about matching perl code curly braces. $RTF_PNG_Begin = $lCurly . '\\*\\shppict' ; $RTF_PNG_Begin .= $lCurly . '\\pict\\pngblip' ; # $Opts->{'xdim'} $RTF_PNG_Begin .= "\\picw" . ($Opts->{'width'} + 0) . " " ; # Width in pixels $RTF_PNG_Begin .= "\\pich" . ($Opts->{'height'} + 0) . " " ; # Height in pixels $RTF_PNG_Begin .= "\\picwgoal" . ($Opts->{'width'}*20) ; # width on the page in twips $RTF_PNG_Begin .= "\\pichgoal" . ($Opts->{'height'}*20) ; # Height on the page in twips. $RTF_PNG_Begin .= $Eol ; # I am using a pixel in a point. A point is 1/72 inches. # A twip is 1/20 of a point. my $bliptag_id = 20000 + 1 + $Chart_Group_cnt + 1 ; $RTF_PNG_Begin .= "\\bliptag" ; # Unique identifier for the image. $RTF_PNG_Begin .= $bliptag_id ; $RTF_PNG_Begin .= $lCurly . '\\*\\blipuid ' ; $RTF_PNG_Begin .= "000000000000000000000000000" ; # 32 numeric digits $RTF_PNG_Begin .= $bliptag_id ; $RTF_PNG_Begin .= $rCurly . $Eol ; # Ends blipuid. $RTF_PNG_Close = $rCurly . $rCurly ; # Ends pict and shppict commands. $RTF_PNG_Close .= $Eol ; $HBI_Debug_msg_str = "" ; $offset = 0 ; $length_line = 40 ; $part_data = "" ; $All_data_len = length $Graph1_str ; if ($HBI_Debug_Report ) { print "\Graphical Data Info - Consolidated Report.\\n" ; # HBI print "Graph1_str length is $All_data_len \\n" ; if (defined $Graph1_obj) { print "Graph1_obj defined.\\n" ; print "Graph1_obj reference X", (ref $Graph1_obj), "X\\n" ; print "Graph1_obj X", $Graph1_obj, "X\\n" ; } else { print "Graph1_obj NOT defined.\\n" ; } print "\END SYSTEM Graph1_obj and string.\\\n" ; # HBI } do { $len_left = $All_data_len - $offset ; if ($len_left < $length_line) {$length_line = $len_left;} $part_data .= unpack ("H*", substr($Graph1_str, $offset, $length_line)) ; $part_data .= $Eol ; $offset += $length_line ; } while ($offset < $All_data_len ) ; $SYSTEM{'Barchart_consolidated'} = $RTF_PNG_Begin . $part_data . $RTF_PNG_Close ; # Compute the last date of the test taken. $FeedBackDateTime my %Month_Full = ("Jan" => "January", "Feb" => "February", "Mar" => "March", "Apr" => "April", "May" => "May", "Jun" => "June", "Jul" => "July", "Aug" => "August", "Sep" => "September", "Oct" => "October", "Nov" => "November", "Dec" => "December") ; my @Month_Full_A = ("January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December") ; my ($day_month, $month_str, $cent_year) ; if ($FeedBackDateTime > 0 ) { my (@Time_array) = gmtime ($FeedBackDateTime) ; $day_month = $Time_array[3] ; $month_str = $Month_Full_A[($Time_array[4])] ; $cent_year = $Time_array[5] + 1900 ; $SYSTEM{'FeedBackDate'} = &RTFize("$month_str $day_month, $cent_year") ; } else { warn "ERROR: FeedBackDateTime is Unknown.\n" ; } my $index1 ; # Compute the RTF format of the Collected Replies for a non-Likert question. for ($index1 = 0; $index1 <= $last_index ; $index1 ++) { ${$QUESTIONS_AG}[$index1]->{'Collected_RTF_Replies'} = "" ; next if (${$QUESTIONS_AG}[$index1]->{'qtp'} eq "lik") ; my $Reply_Array_ref = ${$QUESTIONS_AG}[$index1]->{'Collected_Replies'} ; my $first_array_ref ; my @Consolidated = () ; my $second_array_ref ; my $prefix = "" ; my $suffix = "" ; foreach $first_array_ref (@{$Reply_Array_ref}) { my ($Rep_Arr_Ref, $Comment_Arr_Ref) = @{$first_array_ref} ; $prefix = "\\keep \\widctlpar " . $lCurly . "\\keepn " ; push @Consolidated, $prefix ; if (defined $Rep_Arr_Ref) { foreach $second_array_ref (@$Rep_Arr_Ref) { push @Consolidated, $second_array_ref . "\\par " ; } } else { push @Consolidated, $lCurly . "\bNo Answer.\\par " . $rCurly ; } if (defined $Comment_Arr_Ref) { foreach $second_array_ref (@$Comment_Arr_Ref) { push @Consolidated, $second_array_ref . "\\par " ; } } else { push @Consolidated, $lCurly . "\bNo Comment.\\par " . $rCurly ; } my ($last_str) ; $last_str = pop @Consolidated ; push @Consolidated, $rCurly, $last_str ; } ${$QUESTIONS_AG}[$index1]->{'responses_and_comments'} = join ($Eol, @Consolidated) ; } if ($HBI_Debug_Report ) { print "\\n" ; print "FeedBack Date\\n" ; print $SYSTEM{'FeedBackDate'} ; print "\\n" ; print "\SYSTEM Barchart_org\\n" ; # HBI my $debug_line ; foreach $debug_line (split /\n/, $SYSTEM{'Barchart_org'}) { print ($debug_line, "\\n") ; } print "\END SYSTEM Barchart_groups\\\n" ; # HBI print "\SYSTEM Barchart_groups\\n" ; # HBI foreach $debug_line (split /\n/, $SYSTEM{'Barchart_groups'}) { print ($debug_line, "\\n") ; } print "\END SYSTEM Barchart_groups\\\n" ; # HBI print "\SYSTEM Barchart_consolidated\\n" ; # HBI foreach $debug_line (split /\n/, $SYSTEM{'Barchart_consolidated'}) { print ($debug_line, "\\n") ; } print "\END SYSTEM Barchart_consolidated\\\n" ; # HBI } print HTMLFooter() if ($HBI_Debug_Report ) ; exit 0 if ($HBI_Debug_Report ) ; use vars qw($OUTPUT_Format) ; $OUTPUT_Format = "RTF" ; print "Content-Type: text/rtf\n"; my $FName = ($FORM{'orgname'}) ? $FORM{'orgname'} : "Org-Name" ; $FName =~ s/\W/_/g ; # print "Content-Disposition: attachment;filename=report.rtf\n\n"; print "Content-Disposition: attachment;filename=${FName}_OTS_report.rtf\n\n"; &show_template("TGWALL_Org_Trust_Blank_Report.rtf") ; $OUTPUT_Format = "HTML" ; } sub rep_cell_str { # Parameters # $count - required, number for the cell, integer. # $total - dividend for the percent, integer. # $skip_tot - Optional, default false. # If true, do not print total. # Returned Value # $html_str - html string to print for the cell. my ($count, $total, $skip_tot) = @_ ; my $html_str ; $html_str .= "" unless ($skip_tot) ; my ($percent, $percent_str, $count_str) ; $count_str = sprintf("%4i", $count) ; if ($total == 0) { # total is 0, percent is undefined. $percent_str = "-   - %" ; } else { $percent = 100.0 * $count / $total ; $percent_str = sprintf("%5.1f %%", $percent) ; } $html_str .= "$count_str" unless ($skip_tot) ; $html_str .= "" ; $html_str .= "$percent_str" ; return $html_str ; } sub Round_Per_Cent { # Parameters # $count - required, number for the cell, integer. # $total - dividend for the percent, integer. # Returned Value # $PerCent - as an integer 0 to 100. my ($count, $total) = @_ ; my $PerCent ; if ($total == 0) { # total is 0, percent is undefined. return 0 ; } else { $PerCent = ( int(((100.0 * $count) / $total) + 0.5 )) ; } return $PerCent ; } sub ret_test_chooser_mod { # Return strings of html to pick a survey. # The parameter is an array of arrays with test descriptions and ids. # The returned value is an array with two strings. # The first string is JavaScript for the test chooser. # The second string is html for the tables to drive the test chooser. my @trecs = @_; # print STDERR Dumper(\@trecs) ; my ($testscompleted, $testsinprogress, $testspending, $href, $tstoption, $tstoptions); $tstoptions = "" ; my $html_str = "" ; my $js = "function setTest(oform,test) {\n\t". "oform.tstid.value=test;\n\t". "oform.submit();\n};\n"; for (0 .. $#trecs) { my ($desc,$id) ; $desc = $trecs[$_][0] ; $id = $trecs[$_][1] ; # warn "RET_TEST_CHOOSER_MOD ID $id DESC $desc X" ; $testscompleted = CountTestFiles($testcomplete,$CLIENT{'clid'},$id); $testsinprogress = CountTestFiles($testinprog, $CLIENT{'clid'},$id); $testspending = CountTestFiles($testpending, $CLIENT{'clid'},$id); $href="javascript:setTest(document.testform1,\'$id\')\;"; my $radio_tst_button ; $radio_tst_button = ' ' . $id ; $tstoption = " " . # "$id" . "$radio_tst_button" . "$desc" . "$testscompleted" . "$testsinprogress" . "$testspending \n"; # $tstoptions = join('', $tstoptions, $tstoption); $tstoptions .= $tstoption ; } $html_str = "
Please choose the survey for which you would like reports:
" . # "
" . # "" . # "" . # "" . # "
" . "" . "" . "" . "" . "" . "" . "" . "" . "" . "" . $tstoptions . "" . "

Test IDDescriptionCmpInPPnd


" ; return ($js, $html_str) ; } sub get_full_history { # Parameters # $dir # $clientID # $testID # Side Effect # All of the data is placed into the global variable %FULL_HISTORY # Returned Value # $ret - 0 implies failure, 1 implies success. # %FULL_HISTORY format. # Key is the Client ID. # value is an anon. hash. # Its key is the Test ID. # value is an anon. hash. # Its key is the Candidate ID. # value is an anon. hash. # Its key is the time of the test in seconds for the GMT time zone. # value is the raw character string of the data. # To access a single test's data: # $FULL_HISTORY->{$clientID}->{$testID}->{$candidateID}->{$GMTsec} use vars qw($FULL_HISTORY) ; my ($dir,$clientID,$testID) = @_; my $trash = join($pathsep, $dir, "$clientID.$testID.history"); my $HBI_Debug_get_full_history = 0 ; my $Open_state = 1 ; open(TESTFILE, "<$trash") or $Open_state = 0 ; unless ($Open_state) { # The open failed. warn "ERROR: Failed to open $trash " ; return 0 ; } # The open succeeded. my @seqlines = (); @seqlines = ; close TESTFILE; if ($HBI_Debug_get_full_history) { warn "INFO: History file $clientID.$testID.history line count is " . ($#seqlines + 1) . " \n" ; } my $testline ; my $Line_cnt = 0 ; foreach $testline (@seqlines) { my $match_state ; $Line_cnt ++ ; if ($testline =~ m/^([^\<]+)\<\<\>\>([^\&]+)&([^\&]+)&([^\&]+)&/) { my $time_ascii = $1 ; my $Client_id_str = $2 ; my $candidateID = $3 ; my $Test_id_str = $4 ; if ($Client_id_str ne $clientID) { warn "ERROR: Bad test history file data ${clientID}.${testID}.history " . "line $Line_cnt has mismatched client id.\n" ; } if ($Test_id_str ne $testID) { warn "ERROR: Bad test history file data ${clientID}.${testID}.history " . "line $Line_cnt has mismatched test id.\n" ; } my $timestamp = &toGMSeconds($time_ascii) ; unless ($timestamp) { warn "ERROR: Bad test history file data ${clientID}.${testID}.history " . "line $Line_cnt has bad time stamp.\n" ; $timestamp = "UNK $Line_cnt" ; # Unique value for the file. } if ($HBI_Debug_get_full_history and ($Line_cnt <= 4 )) { warn "INFO: History file $clientID.$testID.history time_ascii $time_ascii timestamp $timestamp\n" ; } $FULL_HISTORY->{$clientID}->{$testID}->{$candidateID}->{$timestamp} = $testline ; } else { warn "ERROR: get_full_history failed to match a valid format in a test history file.\n" ; warn "ERROR: get_full_history file ${clientID}.${testID}.history line $Line_cnt \n" ; next ; } } if ($HBI_Debug_get_full_history) { warn "INFO: History file $clientID.$testID.history RETURN 1, line_cnt $Line_cnt \n" ; } return 1 ; } sub get_group_hash { # Parameters # $client - Client ID string. # Returned value. # $Group_hash - A scalar reference to an anonymous hash. # The keys of the hash are the group ids. # The values are another hash of data for the group. # The keys are the field ids: grpowner, grpid, grpnme, grplist, validfrom, validto # and GroupMembersA. # The value of GroupMembersA is an anon array of the candidate ids of the members. # The other values are the raw data of the fields in the group file. my ($clientID) = @_ ; my $HBI_Debug_get_group_hash = 0 ; my @GroupData = &get_client_groups($clientID); use vars qw(%GRPFIELD) ; # Global variable set by get_client_groups. my $GroupID_HREF = {} ; my $idxid = $GRPFIELD{'grpid'}; my @GroupFieldIDs = sort keys %GRPFIELD ; warn "INFO: idxid $idxid Field IDS " . (join(" ", @GroupFieldIDs)) . "\n" if ($HBI_Debug_get_group_hash) ; my ($FieldID, $GroupID ) ; my $orig_data ; my @split_orig_data ; my $raw_data ; my $candidates ; foreach $orig_data (@GroupData) { chomp $orig_data ; @split_orig_data = split(/&/, $orig_data) ; $GroupID = $split_orig_data[$idxid] ; warn "INFO: Simple group ID $GroupID raw data $raw_data\n" if ($HBI_Debug_get_group_hash) ; # Populate the raw data. foreach $FieldID (@GroupFieldIDs) { $GroupID_HREF->{$GroupID}->{$FieldID} = $split_orig_data[$GRPFIELD{$FieldID}] ; warn "INFO: group ID $GroupID FieldID $FieldID " . "Value " . $GroupID_HREF->{$GroupID}->{$FieldID} . "\n" if ($HBI_Debug_get_group_hash) ; } $candidates = $GroupID_HREF->{$GroupID}->{'grplist'} ; chomp $candidates ; $GroupID_HREF->{$GroupID}->{'GroupMembersA'} = [ split (/\,/, $candidates) ] ; warn "INFO: group ID $GroupID Candidates " . join (" ", $GroupID_HREF->{$GroupID}->{'GroupMembersA'} ) . "\n" if ($HBI_Debug_get_group_hash) ; } return $GroupID_HREF ; } sub RTFHexEscape { # Return the RTF Hex Escape of the first character in $_. my $oldstr = shift(@_) ; my $retstr = unpack ("H*", substr($oldstr, 0, 1)) ; if ($retstr) { return "\\\'" . $retstr ; } else { return "" ; } } sub RTFize { # Parameter # $textStr - An ASCII text string, not to be modified. # Returned value # $retStr - the $textStr with all special characters converted to special RTF sequences. # Control Characters 0-31, or 0x00 to 0x1F # tab, 0x09, becomes "\tab ". # carriage returns, 0x0D; and line feeds, 0x0A; are left alone. # Other control characters are deleted. # Left Curly Brace becomes \'7b. # Right Curly Brace becomes \'7d. # Back slash becomes \'5c. # Characters 128 to 255 become the hex escaped equivalent. my ($retStr) = @_ ; # Delete special control characters. $retStr =~ s/[\x00-\x08\x0B\x0C\x0E-\x1F]//g ; # Convert the back slash. $retStr =~ s/\\/\\\'5C/g ; # Convert tab. $retStr =~ s/\x09/\\tab /g ; # Convert characters that become the hex escaped value. $retStr =~ s/([\x7b\x7d\x80-\xFF])/&RTFHexEscape($1)/ge ; return $retStr ; } sub GetTGWallLikertGrpData { # Parameters # $client - required String, client id. # VOID $testid1 - required String, test id. # VOID $candidate1 - required String, candidate id, testid1 is candidate1's self evaluation. # $testid2 - required String, test id of the evaluation of candidate1 by others; the members of the # groups in grplist. # $grplist - required Hash reference, keys are group ids, values are like getGroups function. # The values contain the candidate ids in the group. # if undef. then only one returned value. # $respRequired - optional boolean, default is false. If true then do not count unanswered questions # as points available. # Returned values - $ret_all, $ret_grp, $ret_err # $ret_all - reference to a Hash of a Hash. The keys of the first hash are the supercategories # of the likert questions in the test. The keys of the second hash are 'PointsAvail', # 'Responses', 'NoResponses', 'PointsEarned', 'ScoreCount', and 'Questions'. The values of the first # four keys are numeric counts, or score totals. The value of the 'ScoreCount' is # another hash. Its keys are the scores, and the values are the counts of the number # of times each score was a response. Values for candidates will be counted here regardless of # group membership. The value of 'Questions' is an un-named hash. The keys of the un-named # hash are the question numbers for the supercategory. The value is always 1. # $ret_grp - reference to a Hash of a Hash of a Hash. The keys of the first hash are # the group ids. The values are structured like $ret_all. This is not returned if # the parameter $grplist is not provided, or undef. # $ret_all, and $ret_grp contain results and scores for $testid2 taken by members of $grplist. # $ret_err - string. - It is either an empty string or text about likert categoies not matching, # or question counts not matching. # Populate $QUESTION_AG with questions, responses, and comments for $testid2 and $grplist. my ($client, $testid2, $grplist, $respRequired) = @_ ; my $HBI_Debug_Groups = 0 ; warn "INFO: GetTGWallLikertGrpData parms client $client, testid2 $testid2, respRequired $respRequired \n" if ($HBI_Debug_Groups) ; warn "INFO: grplist\n" if ($HBI_Debug_Groups) ; warn &Dumper(\$grplist) if ($HBI_Debug_Groups) ; my $grp_req = 1 ; # warn "grp_req $grp_req X\n" ; my $ret_all = {} ; my $ret_grp = {} ; my $ret_one = {} ; my $ret_err = "" ; my %Group_Xref = () ; # List of groups that each member belongs to. # The hash key is a member id, the value is an array of the groups he is in. # Build the cross reference. my %Group_XrefP = () ; # Hash of groups that each member belongs to. # It is a hash of a hash. my $Group = "" ; my $Member = "" ; warn "INFO: grplist SIMPLE.\n" if ($HBI_Debug_Groups) ; foreach $Group (keys %{$grplist}) { warn "INFO: Processing group $Group\n" if ($HBI_Debug_Groups) ; foreach $Member (@{${$grplist}{$Group}{'grplist'}}) { warn "INFO: $Member is a member of group $Group\n" if ($HBI_Debug_Groups) ; push @{$Group_Xref{$Member}} , $Group ; $Group_XrefP{$Member}->{$Group} = 1 ; } } # warn Dumper(\%Group_Xref) ; my %supercat_foundg = () ; # hash of categories found and initialized in the hash of hashes for groups. # PROCESS GROUPS and testid2 my %supercat_found_in_G = () ; # hash of categories found and initialized in the hash of hashes in test2 for groups. &get_test_profile($client, $testid2) ; # Populates %TEST $QUESTIONS_AG = &get_question_definitions ($client, $testid2) ; # Populates an array of hashs that contains all of the questions and the answers. # $QUESTIONS_AG is a reference to the arrays of hashs. my $last_index_g = $#{$QUESTIONS_AG} ; # Last index of the Array of Hashs of the Q&A. my @filelist = &main::get_test_result_files($main::testcomplete, $client,$testid2); # warn "INFO: QUESTIONS_AG\n" if ($HBI_Debug_Groups) ; # warn &Dumper(\$QUESTIONS_AG) if ($HBI_Debug_Groups) ; warn "INFO: filelist\n" if ($HBI_Debug_Groups) ; warn &Dumper(\@filelist) if ($HBI_Debug_Groups) ; my $file ; my @HBI_Debug_Feedback = (0, 0, 0, 0, 0) ; warn "INFO: Group Required flag is $grp_req.\n" if ($HBI_Debug_Feedback[0]) ; foreach $file (@filelist) { my $user = $file; # warn "length file is " . (length $file) . "\n" ; $user =~ s/\s+$// ; $user =~ s/\.$testid2$//; # Strip the test id off the end of the file name. $user =~ s/^$client\.//; # Strip the client id off the start of the file name. warn "file is $file user is $user testid2 is $testid2 client is $client \n" if ($HBI_Debug_Feedback[1]) ; my $user_grp = undef ; my $inact_ques = 0; # Count of the inactive questions found. # Do not process this user if group membership is required and not a member. if ($grp_req and not $Group_Xref{$user}) { warn "Skipped User $user X" if ($HBI_Debug_Feedback[1]) ; next ; } # Update the FeedBack date if this user has taken the test later # than the recorded time. use vars qw($full_history_OK $FeedBackDateTime) ; if ($full_history_OK) { my @FeedBack_test_times ; my $FeedBack_Test_Time ; @FeedBack_test_times = keys %{$FULL_HISTORY->{$client}->{$testid2}->{$user}} ; # warn "INFO: There are " . ($#FeedBack_test_times + 1) . " History times.\n"; foreach $FeedBack_Test_Time (@FeedBack_test_times) { warn "FULL_HISTORY Error $FeedBack_Test_Time is not all numeric.\n" if ($FeedBack_Test_Time =~ m/\D/) ; $FeedBackDateTime = $FeedBack_Test_Time if ($FeedBack_Test_Time > $FeedBackDateTime) ; } } else { warn "FULL_HISTORY Error full_history_OK is false.\n" ; } # Process this desired candidate's test answers. # warn "Process User $user X" ; &get_test_sequence_for_reports($client, $user, $testid2) ; # populates the Assoc. arrays %TEST_SESSION, %SUBTEST_QUESTIONS, # %SUBTEST_ANSWERS, %SUBTEST_RESPONSES, and %SUBTEST_SUMMARY. my ($responses , @responses, $index1) ; $responses = $SUBTEST_RESPONSES{2} ; @responses = split (/\&/, $responses) ; shift @responses ; # Drop the empty element in front of the list. foreach $index1 (0 .. $last_index_g) { my ($response_g, $comment_g) ; my $group ; my ($points, $weight, $ques_type, $scores, @Response_parts) ; # Skip the question if it is inactive. if (${$QUESTIONS_AG}[$index1]->{'qil'} eq "Y") {$inact_ques++ ; next ;} # Get the data for a single question. $points = ${$QUESTIONS_AG}[$index1]->{'pts'} ; $weight = ${$QUESTIONS_AG}[$index1]->{'wght'} ; $ques_type = ${$QUESTIONS_AG}[$index1]->{'qtp'} ; $scores = ${$QUESTIONS_AG}[$index1]->{'scores'} ; @Response_parts = split ('::', $responses[$index1], 2) ; $response_g = $Response_parts[0] ; $comment_g = $Response_parts[1] ; chomp $response_g ; chomp $comment_g ; $response_g = &RTFize($response_g) ; $comment_g = &RTFize($comment_g) ; my @Response_array ; my $Response_array_ref ; my @Comment_array ; my $Comment_array_ref ; my @Collected ; my $Collected_ref ; if ($response_g =~ /^\s*$/) { # Only White space. @Response_array = () ; } else { # text for response. @Response_array = split (/\/, $response_g) ; } if ($comment_g =~ /^\s*$/) { # Only White space. @Comment_array = () ; } else { # text for response. @Comment_array = split (/\/, $comment_g) ; } $response_g =~ s/\s*(\)+\s*/\\par /isg ; $comment_g =~ s/\s*(\)+\s*/\\par /isg ; ${$QUESTIONS_AG}[$index1]->{'responses'} .= $response_g . "\n" if ($response_g) ; ${$QUESTIONS_AG}[$index1]->{'comments'} .= $comment_g . "\n" if ($comment_g) ; unless (${$QUESTIONS_AG}[$index1]->{'QTX_Processed'}) { my $testid2_qtx = ${$QUESTIONS_AG}[$index1]->{'qtx'} ; chomp $testid2_qtx ; $testid2_qtx = &RTFize($testid2_qtx) ; $testid2_qtx =~ s/\s*(\)+\s*/\\par /isg ; ${$QUESTIONS_AG}[$index1]->{'qtx'} = $testid2_qtx ; ${$QUESTIONS_AG}[$index1]->{'QTX_Processed'} = 1 ; } my @scores ; if ($ques_type eq "lik") { # Likert style question. my ($supercat) ; @scores = split (/\,/ , $scores) ; $supercat = ${$QUESTIONS_AG}[$index1]->{'supercat'} ; unless ($supercat_foundg{$supercat}) { # Initialize counters. warn "Init all Cat $supercat\n" if ($HBI_Debug_Feedback[2]) ; $ret_all->{$supercat}->{'PointsAvail'} = 0 ; $ret_all->{$supercat}->{'NoResponses'} = 0 ; $ret_all->{$supercat}->{'Responses'} = 0 ; $ret_all->{$supercat}->{'PointsEarned'} = 0 ; $ret_all->{$supercat}->{'ScoreCount'} = {} ; $supercat_foundg{$supercat} = 1 ; } $ret_all->{$supercat}->{'Questions'}->{$index1-$inact_ques} = 1 ; my @Groups = @{$Group_Xref{$user}} ; warn "INFO: Groups cnt " . ($#Groups + 1) . "\n" if ($HBI_Debug_Feedback[2]) ; foreach $group (@Groups) { unless (defined $ret_grp->{$group}->{$supercat}) { warn "Init all Cat $supercat Group $group user $user.\n" if ($HBI_Debug_Feedback[2]) ; $ret_grp->{$group}->{$supercat}->{'PointsAvail'} = 0 ; $ret_grp->{$group}->{$supercat}->{'NoResponses'} = 0 ; $ret_grp->{$group}->{$supercat}->{'Responses'} = 0 ; $ret_grp->{$group}->{$supercat}->{'PointsEarned'} = 0 ; $ret_grp->{$group}->{$supercat}->{'ScoreCount'} = {} ; } } # foreach $group my @Ans_Comment = split ('::', $responses[$index1-$inact_ques], 2) ; $responses = $Ans_Comment[0] ; my @individ ; @individ = split(/\?/, $responses) ; shift @individ ; my $no_response = 1 ; $ret_all->{$supercat}->{'PointsAvail'} += $points ; foreach $group (@Groups) { $ret_grp->{$group}->{$supercat}->{'PointsAvail'} += $points ; } my $index2 ; foreach $index2 (0 .. $#scores) { # Add the key for the score count to the hash. unless (exists $ret_all->{$supercat}->{'ScoreCount'}->{$scores[$index2]}) { $ret_all->{$supercat}->{'ScoreCount'}->{$scores[$index2]} = 0 ; } foreach $group (@Groups) { unless (exists $ret_grp->{$group}->{$supercat}->{'ScoreCount'}->{$scores[$index2]}) { $ret_grp->{$group}->{$supercat}->{'ScoreCount'}->{$scores[$index2]} = 0 ; } } } # warn "CHECKING CAT $supercat USER $user GRP @group RESP $responses \n" if $supercat eq "Improvement" ; foreach $index2 (0 .. $#scores) { if ($individ[$index2] ne "xxx" and $individ[$index2] ne "" and $individ[$index2] == $index2) { # Answered this question. warn "Scored CAT $supercat POINTS $scores[$index2] USER $user \n" if ($HBI_Debug_Feedback[3]) ; $ret_all->{$supercat}->{'PointsEarned'} += $scores[$index2] ; $ret_all->{$supercat}->{'ScoreCount'}->{$scores[$index2]} ++ ; foreach $group (@Groups) { warn "Scored CAT $supercat POINTS $scores[$index2] USER $user GRP $group \n" if ($HBI_Debug_Feedback[3]) ; $ret_grp->{$group}->{$supercat}->{'PointsEarned'} += $scores[$index2] ; $ret_grp->{$group}->{$supercat}->{'ScoreCount'}->{$scores[$index2]} ++ ; } $no_response = 0 ; } # If answered. } # foreach $index2 if ($no_response) { # Add to the no response count. $ret_all->{$supercat}->{'NoResponses'} ++ ; foreach $group (@Groups) { $ret_grp->{$group}->{$supercat}->{'NoResponses'} ++ ; } if ($respRequired) { # Reduce the points avail if a response is required to count. $ret_all->{$supercat}->{'PointsAvail'} -= $points ; foreach $group (@Groups) { $ret_grp->{$group}->{$supercat}->{'PointsAvail'} -= $points ; } } } else { # Add to the response count. $ret_all->{$supercat}->{'Responses'} ++ ; foreach $group (@Groups) { $ret_grp->{$group}->{$supercat}->{'Responses'} ++ ; } } # Add comment to Collected_Replies. if ($#Comment_array == -1) { @Collected = () ; } else { push @Collected, undef ; push @Collected, \@Comment_array ; } } else { # Non-likert question. @Collected = () ; if ($#Response_array == -1) { push @Collected, undef ; } else { push @Collected, \@Response_array ; } if ($#Comment_array == -1) { push @Collected, undef ; } else { push @Collected, \@Comment_array ; } @Collected = () if (($#Response_array == -1) and ($#Comment_array == -1)) ; } # Save the collected references for all questions. if ($#Collected > -1) { $Collected_ref = \@Collected ; push @{${$QUESTIONS_AG}[$index1]->{'Collected_Replies'}}, $Collected_ref ; } } # foreach question. } # foreach file (i.e. candidate) return ($ret_all, $ret_grp, $ret_err) ; # Return reference. } # End of GetTGWallLikertGrpData sub HTML_Maybe_Hash_Key_value { # Return an HTML formatted string for a hash key value that may not exist. # Parameters # $HashRef - A Reference to a hash array. # $key_str - The key value. # Return a string in HTML format that describes the issues or value. my ($HashRef, $key_str, $ret_str) ; ($HashRef, $key_str) = @_ ; my $Bold_str = "" ; my $End_Bold_str = "" ; # Validate the hash reference. unless (defined $HashRef) { $ret_str = $Bold_str . "Hash Reference is undefined." . $End_Bold_str ; return $ret_str ; } my $HashRefP = ref $HashRef ; if ($HashRefP) { unless ($HashRefP eq "HASH") { $ret_str = $Bold_str . "Hash Reference is a reference to a $HashRefP." . $End_Bold_str ; return $ret_str ; } } else { $ret_str = $Bold_str . "Hash Reference is not a reference." . $End_Bold_str ; return $ret_str ; } # The Hash reference is good. # validate the key. unless (defined $key_str) { $ret_str = $Bold_str . "Key is undefined." . $End_Bold_str ; return $ret_str ; } unless (exists $HashRef->{$key_str}) { $ret_str = $Bold_str . "Key is not in the Hash." . $End_Bold_str ; return $ret_str ; } my $Hash_value = $HashRef->{$key_str} ; if (defined $Hash_value) { $ret_str = $Hash_value ; return $ret_str ; } else { $ret_str = $Bold_str . "Value of the Key in the Hash is undefined." . $End_Bold_str ; return $ret_str ; } } sub HTML_Maybe_Array_Hash_Key_value { # Return an HTML formatted string for an array of hash key value that may not exist. # Parameters # $ArrayRef - A reference to an array of references to a hash. # $ArrayIndex - Numeric index to the array. # $key_str - The key value. # Return a string in HTML format that describes the issues or value. my ($ArrayRef, $ArrayIndex, $key_str) ; my ($HashRef, $ret_str) ; ($ArrayRef, $ArrayIndex, $key_str) = @_ ; my $Bold_str = "" ; my $End_Bold_str = "" ; # Validate the Array Reference. unless (defined $ArrayRef) { $ret_str = $Bold_str . "Array Reference is undefined." . $End_Bold_str ; return $ret_str ; } my $ArrayRefP = ref $ArrayRef ; if ($ArrayRefP) { unless ($ArrayRefP eq "ARRAY") { $ret_str = $Bold_str . "Array Reference is a reference to a $ArrayRefP." . $End_Bold_str ; return $ret_str ; } } else { $ret_str = $Bold_str . "Array Reference is not a reference." . $End_Bold_str ; return $ret_str ; } # The Array reference is good. # Validate the index. $ArrayIndex unless (defined $ArrayIndex) { $ret_str = $Bold_str . "Array Index is undefined." . $End_Bold_str ; return $ret_str ; } if (ref $ArrayIndex) { $ret_str = $Bold_str . "Array Index is a reference." . $End_Bold_str ; return $ret_str ; } elsif ($ArrayIndex !~ m/^\d+$/) { $ret_str = $Bold_str . "Array Index is non-numeric." . $End_Bold_str ; return $ret_str ; } # The $ArrayIndex is a numeric scalar. # Validate the range. unless (($ArrayIndex >= 0) and ($ArrayIndex <= $#{$ArrayRef})) { $ret_str = $Bold_str . "Array Index is out of range." . $End_Bold_str ; return $ret_str ; } $HashRef = ${$ArrayRef}[$ArrayIndex] ; # Validate the hash reference. unless (defined $HashRef) { $ret_str = $Bold_str . "Hash Reference is undefined." . $End_Bold_str ; return $ret_str ; } my $HashRefP = ref $HashRef ; if ($HashRefP) { unless ($HashRefP eq "HASH") { $ret_str = $Bold_str . "Hash Reference is a reference to a $HashRefP." . $End_Bold_str ; return $ret_str ; } } else { $ret_str = $Bold_str . "Hash Reference is not a reference." . $End_Bold_str ; return $ret_str ; } # The Hash reference is good. # validate the key. unless (defined $key_str) { $ret_str = $Bold_str . "Key to the Hash is undefined." . $End_Bold_str ; return $ret_str ; } unless (exists $HashRef->{$key_str}) { $ret_str = $Bold_str . "Key to the Hash does not exist." . $End_Bold_str ; return $ret_str ; } my $Hash_value = $HashRef->{$key_str} ; if (defined $Hash_value) { $ret_str = $Hash_value ; return $ret_str ; } else { $ret_str = $Bold_str . "Value of the Key in the Hash is undefined." . $End_Bold_str ; return $ret_str ; } }