# cupsched - An event schedule program including budget events.
# Rick Smereka, Copyright (C) 2008.

# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.

# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.

# You should have received a copy of the GNU General Public License
# along with this program; if not, get a copy via the Internet at
# http://gnu.org/copyleft/gpl.html or write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA

# You can contact the author via email at rsmereka@future-lab.com

# Orginal tcl version. Aug/2008, Rick Smereka

# required path to library modules
set TCLDIR /gpl/tcl

# other modules
source $TCLDIR/lib/stdhead.tcl
source $TCLDIR/lib/comcode.tcl
source $TCLDIR/lib/appinit.tcl
source $TCLDIR/lib/tk/menu.tcl
source $TCLDIR/lib/tk/menubar.tcl
source $TCLDIR/lib/tk/cutcopy.tcl
source $TCLDIR/lib/tk/popupdown.tcl
const MULTIUSER 0
source $TCLDIR/dbeng/dbmess.tcl
source $TCLDIR/dbeng/dbiocode.tcl
source $TCLDIR/dbeng/dbeng.tcl
source $TCLDIR/dbeng/dbengcfg.tcl
source $TCLDIR/dbeng/dbengcat.tcl
source $TCLDIR/dbeng/dbfxp.tcl
source $TCLDIR/dbeng/dbengsrt.tcl
source $TCLDIR/dbeng/dbcomm.tcl
source $TCLDIR/apps/cupsched/yearmo.tcl
source $TCLDIR/apps/cupsched/category.tcl
source $TCLDIR/apps/cupsched/event.tcl
#
# version number
set app(version) "1.03.01-2008.08.30"
#
# application name
set app(appname) cupsched
global app

# Bbuuzzb table names
const SCHED_NAME "schedule"
const SCHED_CAT_NAME "schedule.category"
const SCHED_TMP_NAME "schedule.tmp"

# schedule table field definitions
# date field is in the form mmdd.seq
const SCHED_FIELD_DATE 1
const SCHED_FIELD_DESC 2
const SCHED_FIELD_CAT 3
const SCHED_FIELD_PLANNED 4
const SCHED_FIELD_ACTUAL 5
const SCHED_FIELD_PLANNED_BAL 6
const SCHED_FIELD_ACTUAL_BAL 7

# schedule tmp table field definitions
const SCHED_TMP_FIELD_DATE 1
const SCHED_TMP_FIELD_PLANNED_BAL 2
const SCHED_TMP_FIELD_ACTUAL_BAL 3

# schedule category table field definitions
const CAT_FIELD_NUM 1
const CAT_FIELD_DESC 2
const CAT_FIELD_TYPE 3

# category table counter record value
const CAT_COUNT_REC "count"

# category table type field values
const CAT_TYPE_CREDIT 1
const CAT_TYPE_DEBIT 2
const CAT_TYPE_NA 0

# fxp scale for all dollar amounts
const SCHED_FXP_SCALE 2

# filters for 'get_sched'
const SCHED_FILTER_ALL 0
const SCHED_FILTER_BUDGET 1
const SCHED_FILTER_OTHER 2

# global data
set year_num 0
set month_num 0
set sched_tid 0 
set sched_cat_tid 0
set sched_changed 0 
set sched_cat_changed 0

# currently displayed event list (date is stored)
set event_list ""

proc c_initialize {} {
   # Start the 'dbeng' local engine and read the config file. Returns 1 
   # upon success, 0 otherwise.
   global DBENG_OK DBENG_CONFIG_UNABLE_TO_OPEN
   set mname "c_initialize"

   set ret [db_initialize]

   # interpret code from init which may be a
   # fatal config error
   switch $ret \
      $DBENG_OK {} \
      $DBENG_CONFIG_UNABLE_TO_OPEN \
                {warning_error "$mname\n\nconfig file not found,loaded defaults"} \
      default {fatal_error "$mname\n\nfatal config error([db_io_code_string $ret])"; \
               return 0}

   return 1
}

proc file_exit {} {
   # terminate the program
   term_app
   exit
}

# create main window
proc app_create {} {
   global app

   wm withdraw .
   toplevel .main
   set_title

   # trap close other than menu
   wm protocol .main WM_DELETE_WINDOW "file_exit"

   # keyboard bindings
   bind . <Control-Key-a> {ac_event ""}
   bind . <Control-Key-m> {ac_event_change}
   bind . <Control-Key-d> {delete_event}
   bind . <Control-Key-r> {summarize_month}
   bind . <Control-Key-t> {vc_categories}
   bind . <Control-Key-c> "copy_text .main.events;break"
   bind . <Control-Key-h> {change_month}
   bind all <Double-1> {ac_event_change}
   bind . <F1> {console show}

   # set calc menus
   set frm .main.menubar   
   createmenubar .main $frm
   
   # file menu
   set menu_name [createmenu $frm \
      eventmenu "File" 0]
   $menu_name add command -label "Add Event" \
      -underline 0 -accelerator "Ctrl+A" \
      -command {ac_event ""}
   $menu_name add command -label "Modify Event" \
      -underline 0 -accelerator "Ctrl+M" \
      -command {ac_event_change}
   $menu_name add command -label "Delete Event" \
      -underline 0 -accelerator "Ctrl+D" \
      -command {delete_event}
   $menu_name add separator
   $menu_name add command -label "Re-calc Month" \
      -underline 0 -accelerator "Ctrl+R" \
      -command {summarize_month}
   $menu_name add command -label "Copy Month" \
      -underline 1 -accelerator "Ctrl+O" \
      -command {cm_dialog .main}
   $menu_name add separator
   $menu_name add command -label "Categories" \
      -underline 2 -accelerator "Ctrl+T" \
      -command {vc_categories}
   $menu_name add separator
   $menu_name add command -label "Change Month" \
      -underline 1 -accelerator "Ctrl+H" \
      -command {change_month}
   $menu_name add separator
   $menu_name add command -label "Exit" \
      -underline 1 -command {file_exit}

   # edit menu
   set menu_name [createmenu $frm \
      editmenu "Edit" 0]
   $menu_name add command -label "Copy" \
      -underline 0 -accelerator "Ctrl+C" \
      -command {copy_text .main.events}

   # help menu
   set menu_name [createmenu $frm \
      helpmenu "Help" 0]
   $menu_name add command -label "About" \
      -underline 0 \
      -command {help_about .main}

   # set font
   global listfont
   font create listfont -family courier -size 8

   # event area labels
   set line " Date"
   append line [rpad "   Description" " " 20]
   append line [rpad "   Category" " " 20]
   append line [lpad "    Planned" " " 8]
   append line [lpad " PBal " " " 8]
   append line [lpad "Actual" " " 8]
   append line [lpad "ABal" " " 8]
   frame .main.events -bd 0
   label .main.events.lab -text $line -anchor w -font listfont
   frame .main.events.frm

   # create event list box
   listbox .main.events.frm.dat -height 15 -width 81 \
      -selectmode single -exportselection true \
      -yscrollcommand ".main.events.frm.scr1 set" \
      -font listfont
   scrollbar .main.events.frm.scr1 -command ".main.events.frm.dat yview"
   pack .main.events.frm.dat -side left
   pack .main.events.frm.scr1 -side right -fill y
   pack .main.events.lab -pady 4 -side top -fill x
   pack .main.events.frm -side bottom
   pack .main.events -side left

   # popup on rightmost mouse button
   bind all <Button-3> {
      # get global X position of app
      set gx [winfo rootx %W]

      # get global Y position of app
      set gy [winfo rooty %W]

      # add to local mouse position
      set mx [expr $gx + %x]
      set my [expr $gy + %y]

      # display popup menu
      tk_popup .popup $mx $my
   }

   # create popup menu
   menu .popup
   .popup add command -label "Add Event" \
      -command {ac_event ""}
   .popup add command -label "Modify Event" \
      -command {ac_event_change}
   .popup add command -label "Delete Event" \
      -command {delete_event}
   .popup add separator
   .popup add command -label "Re-calc Month" \
      -command {summarize_month}
   .popup add command -label "Copy Month" \
      -command {cm_dialog .main}
   .popup add separator
   .popup add command -label "Categories" \
      -command {vc_categories}
   .popup add separator
   .popup add command -label "Change Month" \
      -command {change_month}
   .popup add separator
   .popup add command -label "Copy" \
      -command {copy_text .main.events}
   update
   focus .main.events.frm.dat
}

# display about box
proc help_about {toplevel} {
   global app
   set mes "$app(appname) Version $app(version)\n\n"
   append mes "An event scheduler/tracker.\n"
   append mes "by Rick Smereka\n"
   append mes "Copyright (c) 2008"
   tk_messageBox -default ok -icon info -message $mes \
      -parent $toplevel -title "About $app(appname)" -type ok
   focus .main
}

proc cm_dialog {pw} {
   # Present the 'copy month' modal dialog box. Returns nothing.
   global year_num month_num cm_year cm_month
   set mname "cm_dialog"

   # get destination year and month
   # suggest year based on current year unless this is month 12
   if {$month_num == 12} {
      set cm_year [expr $year_num + 1]
   } else {
      set cm_year $year_num
   }

   # get a list of available database years
   if {[set ylist [get_year_db_list]] == ""} {
      return
   }

   # suggest next month
   if {$month_num == 12} {
      set cm_month 1
   } else {
      set cm_month [expr [int_remove_lz $month_num] + 1]
   }

   set dlg .cmdialog
   toplevel $dlg
   wm group $dlg $pw
   wm title $dlg "Copy Month"
   wm resizable $dlg 0 0
   wm transient $dlg $pw
   grab $dlg

   set frm $dlg.fyr
   frame $frm
   label $frm.label -text "Destination year:" -anchor w
   set stmt "tk_optionMenu $frm.yr cm_year $ylist"
   eval $stmt
   pack $frm.label $frm.yr -side left

   set frm $dlg.fmo
   frame $frm
   label $frm.label -text "Destination month:" -anchor w
   set mlist [get_month "all"]
   set tmp [get_month $cm_month]
   set cm_month $tmp
   set stmt "tk_optionMenu $frm.mo cm_month $mlist"
   eval $stmt
   pack $frm.label $frm.mo -side left

   # buttons
   set frm $dlg.buttons
   frame $frm
   button $frm.ok -text "Ok" -command "copy_month" -default active
   button $frm.cancel -text "Cancel" -command "destroy $dlg"
   pack $frm.ok -fill x -side left -expand 1
   pack $frm.cancel -fill x -side left -expand 1
   pack $dlg.fyr $dlg.fmo $dlg.buttons
   bind $dlg <Key-Return> "copy_month"
   bind $dlg <Key-Escape> "destroy $dlg"
   focus $dlg.fyr.yr
}

proc display_events {typ} {
   # Display all events for the current month and build the event list.
   # Returns 1 upon success, 0 otherwise.
   global sched_changed sched_tid SCHED_FIELD_DATE event_list month_num
   global DBENG_OK SCHED_FIELD_DESC SCHED_FIELD_CAT CAT_TYPE_NA
   global SCHED_FIELD_PLANNED SCHED_FXP_SCALE SCHED_FIELD_ACTUAL
   global SCHED_FIELD_PLANNED_BAL SCHED_FIELD_ACTUAL_BAL
   set mname "display_events"
   set cnt 1
   pop_up "Refreshing events. Please wait..."
   set nitems [.main.events.frm.dat size]
   log_file_date "$mname:contents before refresh"
   dump_lb_events

   # clear displayed event list if there are events currently displayed
   if {$nitems > 0} {
      .main.events.frm.dat delete 0 end
   }

   # if schedule table has changed, sort it
   if {$sched_changed} {
      db_sort $sched_tid $SCHED_FIELD_DATE
      set sched_changed 0
   }

   # if event list is not empty, clear it
   if {$event_list != ""} {
      set event_list ""
   }

   set month [lpad $month_num "0" 2]

   if {[set ret [db_top $sched_tid]] != $DBENG_OK} {
      warning_error "$mname\n\nerror going to top of event table(\
         [db_io_code_string $ret])"
      return 0
   }

   if {[set ret [get_sched $typ $sched_tid $month_num]] != $DBENG_OK} {
      info_error "$mname\n\nno existing events([db_io_code_string $ret])"
      return 1
   }

   while {$ret == $DBENG_OK} {
      if {[set ret [db_get_field $sched_tid $SCHED_FIELD_DATE date]] != \
           $DBENG_OK} {
         warning_error "$mname\n\nerror getting date field(\
                        [db_io_code_string $ret])"
         return 0
      }

      if {[set ret [db_get_field $sched_tid $SCHED_FIELD_DESC desc]] != \
           $DBENG_OK} {
         warning_error "$mname\n\nerror getting description(\
                        [db_io_code_string $ret]) ($date)"
         return 0
      }

      if {[set ret [db_get_field $sched_tid $SCHED_FIELD_CAT cat]] != \
           $DBENG_OK} {
         warning_error "$mname\n\nerror getting category field(\
                        [db_io_code_string $ret]) ($date)"
         return 0
      }

      if {![xref_category $cat cat_typ cat_desc]} {
         warning_error "$mname\n\nerror getting category type"
         return 0
      }

      if {$cat_typ != $CAT_TYPE_NA} {
         if {[set ret [dbfxp_get $sched_tid $SCHED_FIELD_PLANNED \
              $SCHED_FXP_SCALE planned]] != $DBENG_OK} {
            warning_error "$mname\n\nerror getting planned field(\
                           [db_io_code_string $ret]) ($date)"
            return 0
         }

         if {![fxp_oconv $planned $SCHED_FXP_SCALE planned_st]} {
            warning_error "$mname\n\nerror converting planned field($date)"
            return 0
         }

         if {[set ret [dbfxp_get $sched_tid $SCHED_FIELD_ACTUAL \
              $SCHED_FXP_SCALE actual]] != $DBENG_OK} {
            warning_error "$mname\n\nerror getting actual field(\
                           [db_io_code_string $ret]) ($date)"
            return 0
         }

         if {![fxp_oconv $actual $SCHED_FXP_SCALE actual_st]} {
            warning_error "$mname\n\nerror converting actual field($date)"
            return 0
         }

         set has_bal 1
      
         # only display balance fields if they are present
         if {[set ret [dbfxp_get $sched_tid $SCHED_FIELD_PLANNED_BAL \
              $SCHED_FXP_SCALE planned]] != $DBENG_OK} {
            set has_bal 0
         }

         if {$has_bal} {
            if {![fxp_oconv $planned $SCHED_FXP_SCALE planned_bal]} {
               warning_error "$mname\n\nerror converting planned bal field(\
                              $date)"
               return 0
            }

            if {[set ret [dbfxp_get $sched_tid $SCHED_FIELD_ACTUAL_BAL \
                 $SCHED_FXP_SCALE actual]] != $DBENG_OK} {
               warning_error "$mname\n\nerror getting actual bal field(\
                              [db_io_code_string $ret])($date)"
               return 0
            }

            if {![fxp_oconv $actual $SCHED_FXP_SCALE actual_bal]} {
               warning_error "$mname\n\nerror converting actual bal field(\
                              $date)"
               return 0
            }
         }
      }

      lappend event_list $date

      if {$cat_typ == $CAT_TYPE_NA} {
         append_event_line $date $desc $cat_desc "" "" "" ""
         set cnt [expr $cnt + 1]
      } else {
         if {$has_bal} {
            append_event_line $date $desc $cat_desc $planned_st $planned_bal \
                              $actual_st $actual_bal
            incr cnt
         } else {
            append_event_line $date $desc $cat_desc $planned_st "0.00" \
                              $actual_st "0.00"
            incr cnt
         }
      }

      set ret [get_sched $typ $sched_tid $month_num]
   }

   log_file_date "$mname:contents after refresh"
   dump_lb_events
   pop_down
   focus .main.events.frm.dat
   return 1
}

proc copy_month {} {
   # Copy the current month records to a new year/month.
   global month_num year_num SCHED_NAME DBENG_OK SCHED_FILTER_ALL sched_tid
   global SCHED_FIELD_DATE SCHED_FIELD_DESC SCHED_FIELD_CAT
   global SCHED_FIELD_PLANNED SCHED_FIELD_ACTUAL SCHED_FIELD_PLANNED_BAL
   global SCHED_FIELD_ACTUAL_BAL cm_year cm_month
   set mname "copy_month"
   set dest_year $cm_year

   # extract only month number from chosen selection
   if {![word $cm_month dest_month 1]} {
      warning_error "$mname\n\nError extracting month number"
      return
   }

   # don't allow copy to current year/month
   if {$dest_year == $year_num && $dest_month == [int_remove_lz $month_num]} {
      warning_error "$mname\n\nCannot copy to current month."
      return
   }

   # open destination table, ok if it is current year
   set value [format "%s.%d" $SCHED_NAME $dest_year]

   if {[set ret [db_open $value dest_tid]] != $DBENG_OK} {
      warning_error "$mname\n\nopen of $value failed(\
                     [db_io_code_string $ret])"
      return
   }

   # attempt to find existing destination records and ask to delete
   # if they exist
   if {[set ret [db_top $dest_tid]] != $DBENG_OK} {
      warning_error "$mname\n\nerror going to top of event table(\
            [db_io_code_string $ret])"
      db_close $dest_tid
      return
   }

   if {[set ret [get_sched $SCHED_FILTER_ALL $dest_tid $dest_month]] == \
       $DBENG_OK} {
      set resp [tk_messageBox -message "Destination month record(s) exist,\
                              ok to delete?" -icon question -type yesno]

      if {$resp == "no"} {
         db_close $dest_tid
         destroy .cmdialog
         return
      }

      while {$ret == $DBENG_OK} {
         if {[set ret [db_delete $dest_tid]] != $DBENG_OK} {
            warning_error "$mname\n\nerror deleting sched record(\
                           [db_io_code_string $ret])"
            db_close $dest_tid
            return
         }

         if {[set ret [db_top $dest_tid]] != $DBENG_OK} {
            warning_error "$mname\n\nerror going to top of event table(\
                           [db_io_code_string $ret])"
            db_close $dest_tid
            return
         }

         set ret [get_sched $SCHED_FILTER_ALL $dest_tid $dest_month]
      }
   }

   pop_up "Copying month records. Please wait..."

   # get each source record, change it's ID, zero out balances and write
   # it as a destination record
   if {[set ret [db_top $sched_tid]] != $DBENG_OK} {
      warning_error "$mname\n\nerror going to top of event table(\
                     [db_io_code_string $ret])"
      db_close $dest_tid
      return
   }

   if {[set ret [get_sched $SCHED_FILTER_ALL $sched_tid $month_num]] != \
       $DBENG_OK} {
      warning_error "$mname\n\nno existing source events?(\
                     [db_io_code_string $ret])"
      db_close $dest_tid
      return
   }

   set value [format "%02d" $dest_month]

   while {$ret == $DBENG_OK} {
      if {[set ret [db_new $dest_tid]] != $DBENG_OK} {
         warning_error "$mname\n\nerror setting up new event record(\
                        [db_io_code_string $ret])"
         db_close $dest_tid
         return
      }

      if {[set ret [db_get_field $sched_tid $SCHED_FIELD_DATE buf]] != \
          $DBENG_OK} {
         warning_error "$mname\n\nerror get date field(\
                        [db_io_code_string $ret])"
         db_close $dest_tid
         return
      }

      set buf [string replace $buf 0 1 $value]

      if {[set ret [db_put_field $dest_tid $SCHED_FIELD_DATE $buf]] != \
          $DBENG_OK} {
         warning_error "$mname\n\nerror putting event date(\
                        [db_io_code_string $ret])"
         db_close $dest_tid
         return
      }

      if {[set ret [db_get_field $sched_tid $SCHED_FIELD_DESC buf]] != \
          $DBENG_OK} {
         warning_error "$mname\n\nerror getting desc field(\
                        [db_io_code_string $ret])"
         db_close $dest_tid
         return
      }

      if {[set ret [db_put_field $dest_tid $SCHED_FIELD_DESC $buf]] != \
          $DBENG_OK} {
         warning_error "$mname\n\nerror putting event desc(\
                        [db_io_code_string $ret])"
         db_close $dest_tid
         return
      }

      if {[set ret [db_get_field $sched_tid $SCHED_FIELD_CAT buf]] != \
          $DBENG_OK} {
         warning_error "$mname\n\nerror getting category field(\
                        [db_io_code_string $ret])"
         db_close $dest_tid
         return
      }

      if {[set ret [db_put_field $dest_tid $SCHED_FIELD_CAT $buf]] != \
          $DBENG_OK} {
         warning_error "$mname\n\nerror putting event category(\
                        [db_io_code_string $ret])"
         db_close $dest_tid
         return
      }

      if {[set ret [db_get_field $sched_tid $SCHED_FIELD_PLANNED buf]] != \
          $DBENG_OK} {
         warning_error "$mname\n\nerror getting planned field(\
                        [db_io_code_string $ret])"
         db_close $dest_tid
         return
      }

      if {[set ret [db_put_field $dest_tid $SCHED_FIELD_PLANNED $buf]] != \
          $DBENG_OK} {
         warning_error "$mname\n\nerror putting event planned(\
                        [db_io_code_string $ret])"
         db_close $dest_tid
         return
      }

      if {[set ret [db_put_field $dest_tid $SCHED_FIELD_ACTUAL "000"]] != \
          $DBENG_OK} {
         warning_error "$mname\n\nerror putting event actual value(\
                        [db_io_code_string $ret])"
         db_close $dest_tid
         return
      }

      if {[set ret [db_put_field $dest_tid $SCHED_FIELD_PLANNED_BAL "000"]] \
          != $DBENG_OK} {
         warning_error "$mname\n\nerror putting event planned bal(\
                        [db_io_code_string $ret])"
         db_close $dest_tid
         return
      }

      if {[set ret [db_put_field $dest_tid $SCHED_FIELD_ACTUAL_BAL "000"]] \
          != $DBENG_OK} {
         warning_error "$mname\n\nerror putting event actual bal(\
                        [db_io_code_string $ret])"
         db_close $dest_tid
         return
      }

      if {[set ret [db_write $dest_tid]] != $DBENG_OK} {
         warning_error "$mname\n\nerror writing destination record(\
                        [db_io_code_string $ret])"
         db_close $dest_tid
         return
      }

      set ret [get_sched $SCHED_FILTER_ALL $sched_tid $month_num]
   }

   db_close $dest_tid
   pop_down
   destroy .cmdialog
   focus .main.events.frm.dat
}

proc summarize_month {} {
   # Perform calcs on current month and display.
   global month_num sched_tid DBENG_OK SCHED_FILTER_BUDGET SCHED_FIELD_DATE
   global SCHED_FIELD_CAT SCHED_FIELD_PLANNED SCHED_FXP_SCALE SCHED_TMP_NAME
   global SCHED_FIELD_ACTUAL SCHED_TMP_FIELD_DATE CAT_TYPE_CREDIT
   global SCHED_TMP_FIELD_PLANNED_BAL SCHED_TMP_FIELD_ACTUAL_BAL
   global SCHED_FIELD_PLANNED_BAL SCHED_FIELD_ACTUAL_BAL TRUE FALSE
   set mname "summarize_month"

   set month [format "%02d" [int_remove_lz $month_num]]
   pop_up "Recalculating month amounts. Please wait..."

   if {[set ret [db_top $sched_tid]] != $DBENG_OK} {
      warning_error "$mname\n\nerror going to top of event table(\
                     [db_io_code_string $ret])"
      return $FALSE
   }

   # error getting the first record is assumed to be no records,ok
   if {[set ret [get_sched $SCHED_FILTER_BUDGET $sched_tid $month_num]] != \
       $DBENG_OK} {
      warning_error "$mname\n\nno existing events([db_io_code_string $ret])"
      return $TRUE
   }

   # load planned and actual open balance
   set found_open_bal $FALSE

   while {$ret == $DBENG_OK} {
      if {[set ret [db_get_field $sched_tid $SCHED_FIELD_DATE date]] != \
          $DBENG_OK} {
         warning_error "$mname\n\nerror getting date field(\
                        [db_io_code_string $ret])"
         return $FALSE
      }

      # open balance is the only record in the month with category 6
      if {[set ret [db_get_field $sched_tid $SCHED_FIELD_CAT cat]] != \
          $DBENG_OK} {
         warning_error "$mname\n\nerror getting category field(\
                        [db_io_code_string $ret])($date)"
         return $FALSE
      }

      if {$cat != "6"} {
         set ret [get_sched $SCHED_FILTER_BUDGET $sched_tid $month_num]
         continue
      }

      if {[set ret [dbfxp_get $sched_tid $SCHED_FIELD_PLANNED \
          $SCHED_FXP_SCALE bal_planned]] != $DBENG_OK} {
         warning_error "$mname\n\nerror getting planned field(\
                        [db_io_code_string $ret])($date)"
         return $FALSE
      }

      if {[set ret [dbfxp_get $sched_tid $SCHED_FIELD_ACTUAL $SCHED_FXP_SCALE \
          bal_actual]] != $DBENG_OK} {
         warning_error "$mname\n\nerror getting actual field(\
                        [db_io_code_string $ret])($date)"
         return $FALSE
      }

      set found_open_bal $TRUE
      break
   }

   # cannot calc if no open balance for the month
   if {!$found_open_bal} {
      warning_error "$mname\n\nopen balance record not found,cannot calculate"
      return $FALSE
   }

   if {[set ret [db_top $sched_tid]] != $DBENG_OK} {
      warning_error "$mname\n\nerror going to top of event table([db_io_code_string $ret])"
      return $FALSE
   }

   if {[set ret [get_sched $SCHED_FILTER_BUDGET $sched_tid $month_num]] != \
       $DBENG_OK} {
      warning_error "$mname\n\nno existing events([db_io_code_string $ret])"
      return $FALSE
   }

   # clear schedule temporary table
   if {[set ret [db_clear_table $SCHED_TMP_NAME]] != $DBENG_OK} {
      warning_error "$mname\n\nunable to clear schedule tmp table\
                     ([db_io_code_string $ret])"
      return $FALSE
   }

   # open schedule temporary table
   if {[set ret [db_open $SCHED_TMP_NAME tmp_tid]] != $DBENG_OK} {
      warning_error "$mname\n\nunable to open schedule tmp table\
                     ([db_io_code_string $ret])"
      return $FALSE
   }

   # initialize all total accumulators
   if {[set ptot_credit [fxp_iconv "0.00"]] == ""} {
      warning_error "$mname\n\nerror initializing ptot_credit"
      return $FALSE
   }

   if {[set atot_credit [fxp_iconv "0.00"]] == ""} {
      warning_error "$mname\n\nerror initializing atot_credit"
      return $FALSE
   }

   if {[set ptot_debit [fxp_iconv "0.00"]] == ""} {
      warning_error "$mname\n\nerror initializing ptot_debit"
      return $FALSE
   }

   if {[set atot_debit [fxp_iconv "0.00"]] == ""} {
      warning_error "$mname\n\nerror initializing atot_debit"
      return $FALSE
   }

   set credit_cnt 0
   set debit_cnt 0

   # loop through all month event records calculating while ignoring
   # the open balance record, write balances to the temporary table
   while {$ret == $DBENG_OK} {
      if {[set ret [db_get_field $sched_tid $SCHED_FIELD_DATE date]] !=
          $DBENG_OK} {
         warning_error "$mname\n\nerror getting date field(\
                        [db_io_code_string $ret])"
         db_close $tmp_tid
         return $FALSE
      }

      if {[set ret [db_get_field $sched_tid $SCHED_FIELD_CAT cat]] !=
          $DBENG_OK} {
         warning_error "$mname\n\nerror getting category field(\
                        [db_io_code_string $ret])"
         db_close $tmp_tid
         return $FALSE
      }

      # ignore balance record
      if {$cat == "6"} {
         set ret [get_sched $SCHED_FILTER_BUDGET $sched_tid $month_num]
         continue
      }

      # lookup category type
      if {![xref_category $cat cat_typ cat_desc]} {
         db_close $tmp_tid
         return $FALSE
      }

      if {[set ret [dbfxp_get $sched_tid $SCHED_FIELD_PLANNED \
          $SCHED_FXP_SCALE planned]] != $DBENG_OK} {
         warning_error "$mname\n\nerror getting planned field(\
                        [db_io_code_string $ret])($date)"
         db_close $tmp_tid
         return $FALSE
      }

      if {[set ret [dbfxp_get $sched_tid $SCHED_FIELD_ACTUAL \
          $SCHED_FXP_SCALE actual]] != $DBENG_OK} {
         warning_error "$mname\n\nerror getting actual field(\
                        [db_io_code_string $ret])($date)"
         db_close $tmp_tid
         return $FALSE
      }

      if {[set ret [db_put_field $tmp_tid $SCHED_TMP_FIELD_DATE $date]] != \
          $DBENG_OK} {
         warning_error "$mname\n\nerror putting date field(\
                        [db_io_code_string $ret])($date)"
         db_close $tmp_tid
         return $FALSE
      }

      if {$cat_typ == $CAT_TYPE_CREDIT} {
         set credit_cnt [expr $credit_cnt + 1]

         if {[set ftmp [fxp_add $bal_planned $planned]] == ""} {
            warning_error "$mname\n\nerror adding planned and balance planned"
            db_close $tmp_tid
            return $FALSE
         }

         set bal_planned $ftmp

         if {[set ftmp [fxp_add $ptot_credit $planned]] == ""} {
            warning_error "$mname\n\nerror adding planned and total \
                           credit planned"
            db_close $tmp_tid
            return $FALSE
         }

         set ptot_credit $ftmp
   
         if {[set ret [dbfxp_put $tmp_tid $SCHED_TMP_FIELD_PLANNED_BAL \
             $SCHED_FXP_SCALE $bal_planned]] != $DBENG_OK} {
            warning_error "$mname\n\nerror putting planned balance amount\
                           ([db_io_code_string $ret])"
            db_close $tmp_tid
            return $FALSE
         }

         if {[set ftmp [fxp_add $bal_actual $actual]] == ""} {
            warning_error "$mname\n\nerror adding actual and balance actual"
            db_close $tmp_tid
            return $FALSE
         }

         set bal_actual $ftmp

         if {[set ftmp [fxp_add $atot_credit $actual]] == ""} {
            warning_error "$mname\n\nerror adding actual and total \
                           credit actual"
            db_close $tmp_tid
            return $FALSE
         }

         set atot_credit $ftmp

         if {[set ret [dbfxp_put $tmp_tid $SCHED_TMP_FIELD_ACTUAL_BAL \
             $SCHED_FXP_SCALE $bal_actual]] != $DBENG_OK} {
            warning_error "$mname\n\nerror putting actual balance amount\
                           ([db_io_code_string $ret])"
            db_close $tmp_tid
            return $FALSE
         }
      } else {
         set debit_cnt [expr $debit_cnt + 1]

         if {[set ftmp [fxp_sub $bal_planned $planned]] == ""} {
            warning_error "$mname\n\nerror subtracting planned and \
                           balance planned"
            db_close $tmp_tid
            return $FALSE
         }

         set bal_planned $ftmp

         if {[set ftmp [fxp_add $ptot_debit $planned]] == ""} {
            warning_error "$mname\n\nerror adding planned and total \
                           debit planned"
            db_close $tmp_tid
            return $FALSE
         }

         set ptot_debit $ftmp

         if {[set ret [dbfxp_put $tmp_tid $SCHED_TMP_FIELD_PLANNED_BAL \
              $SCHED_FXP_SCALE $bal_planned]] != $DBENG_OK} {
            warning_error "$mname\n\nerror putting planned balance amount(\
                           [db_io_code_string $ret])"
            db_close $tmp_tid
            return $FALSE
         }

         if {[set ftmp [fxp_sub $bal_actual $actual]] == ""} {
            warning_error "$mname\n\nerror subtracting actual and \
                           balance actual"
            db_close $tmp_tid
            return $FALSE
         }

         set bal_actual $ftmp

         if {[set ftmp [fxp_add $atot_debit $actual]] == ""} {
            warning_error "$mname\n\nerror adding actual and total \
                           debit actual"
            db_close $tmp_tid
            return $FALSE
         }

         set atot_debit $ftmp

         if {[set ret [dbfxp_put $tmp_tid $SCHED_TMP_FIELD_ACTUAL_BAL \
              $SCHED_FXP_SCALE $bal_actual]] != $DBENG_OK} {
            warning_error "$mname\n\nerror putting actual balance amount(\
                           [db_io_code_string $ret])"
            db_close $tmp_tid
            return $FALSE
         }
      }

      if {[set ret [db_write $tmp_tid]] != $DBENG_OK} {
         warning_error "$mname\n\nerror writing tmp schedule record(\
                        [db_io_code_string $ret])"
         db_close $tmp_tid
         return $FALSE
      }

      set ret [get_sched $SCHED_FILTER_BUDGET $sched_tid $month_num]
   }

   db_top $tmp_tid
   db_next $tmp_tid
   set ret $DBENG_OK

   # copy temporary table balances to schedule table
   while {$ret == $DBENG_OK} {
      if {[set ret [db_get_field $tmp_tid $SCHED_TMP_FIELD_DATE date]] != \
          $DBENG_OK} {
         warning_error "$mname\n\nerror getting date field\
                        ([db_io_code_string $ret])"
         db_close $tmp_tid
         return $FALSE
      }

      if {[set ret [db_top $sched_tid]] != $DBENG_OK} {
         warning_error "$mname\n\nerror going to top of schedule table(\
                        [db_io_code_string $ret])"
         db_close $tmp_tid
         return $FALSE
      }

      if {[set ret [db_find_field $sched_tid 0 $date $SCHED_FIELD_DATE]] != \
          $DBENG_OK} {
         warning_error "$mname\n\nerror locating schedule table record(\
                        [db_io_code_string $ret])"
         db_close $tmp_tid
         return $FALSE
      }

      if {[set ret [db_get_field $tmp_tid $SCHED_TMP_FIELD_PLANNED_BAL mes]] \
          != $DBENG_OK} {
         warning_error "$mname\n\nerror getting tmp sched planned bal field(\
                        [db_io_code_string $ret])"
         db_close $tmp_tid
         return $FALSE
      }

      if {[set ret [db_put_field $sched_tid $SCHED_FIELD_PLANNED_BAL $mes]] \
          != $DBENG_OK} {
         warning_error "$mname\n\nerror putting sched planned bal field(\
                        [db_io_code_string $ret])"
         db_close $tmp_tid
         return $FALSE
      }

      if {[set ret [db_get_field $tmp_tid $SCHED_TMP_FIELD_ACTUAL_BAL mes]] \
          != $DBENG_OK} {
         warning_error "$mname\n\nerror getting tmp sched actual bal field(\
                        [db_io_code_string $ret])"
         db_close $tmp_tid
         return $FALSE
      }

      if {[set ret [db_put_field $sched_tid $SCHED_FIELD_ACTUAL_BAL $mes]] \
          != $DBENG_OK} {
         warning_error "$mname\n\nerror putting sched actual bal field(\
                        [db_io_code_string $ret])"
         db_close $tmp_tid
         return $FALSE
      }

      if {[set ret [db_write $sched_tid]] != $DBENG_OK} {
         warning_error "$mname\n\nerror writing schedule record\
                        ([db_io_code_string $ret])"
         db_close $tmp_tid
         return $FALSE
      }

      set ret [db_next $tmp_tid]
   }   

   db_close $tmp_tid
   db_sort $sched_tid $SCHED_FIELD_DATE
   display_events $SCHED_FILTER_BUDGET

   # calc and display monthly summary
   if {![fxp_oconv $ptot_credit $SCHED_FXP_SCALE sptot_credit]} {
      warning_error "$mname\n\nerror converting planned total credit"
      return $FALSE
   }

   if {![fxp_oconv $atot_credit $SCHED_FXP_SCALE satot_credit]} {
      warning_error "$mname\n\nerror converting actual total credit"
      return $FALSE
   }

   if {![fxp_oconv $ptot_debit $SCHED_FXP_SCALE sptot_debit]} {
      warning_error "$mname\n\nerror converting planned total debit"
      return $FALSE
   }

   if {![fxp_oconv $atot_debit $SCHED_FXP_SCALE satot_debit]} {
      warning_error "$mname\n\nerror converting actual total debit"
      return $FALSE
   }

   set mes "$credit_cnt credit event(s),$debit_cnt debit event(s)\n"
   append mes "totals\n"
   append mes "credit:planned=$sptot_credit,actual=$satot_credit\n"
   append mes "debit:planned=$sptot_debit,actual=$satot_debit\n"
   info_error $mes
   return $TRUE
}

proc get_selected_event {} {
   # Obtain the event number of the currently selected event.
   # Returns the event number upon success, an empty string
   # otherwise.
   set mname "get_selected_event"
   set buf [.main.events.frm.dat curselection]

   if {$buf == ""} {
      warning_error "$mname\n\n An event must be selected first."
      return ""
   }

   if {[set the_event [ll_locate $buf]] == ""} {
      warning_error "$mname\n\nNo such event."
      return ""
   }

   # info_error "$mname\n\nbuf=$buf,the_event=$the_event"
   return $the_event
}

proc get_sched {filter tid amonth} {
   # Get next record from the schedule table 'tid' and make sure it
   # applies only to the month 'amonth' and apply the 'filter'
   # (see 'SCHED_FILTER' types). Returns a 'bbuuzzb' code.
   global DBENG_OK SCHED_FIELD_DATE SCHED_FIELD_CAT SCHED_FILTER_ALL
   global DBENG_INVALID_FUNCTION SCHED_FILTER_BUDGET CAT_TYPE_CREDIT
   global SCHED_FILTER_OTHER CAT_TYPE_DEBIT CAT_TYPE_NA
   set mname "get_sched"

   set month [lpad $amonth 0 2]
   set ret [db_next $tid]


   if {$ret != $DBENG_OK} {
      return $ret
   }

   while {$ret == $DBENG_OK} {
      set ret [db_get_field $tid $SCHED_FIELD_DATE date]

      if {$ret != $DBENG_OK} {
         warning_error "$mname\n\nerror getting date field(\
                        [db_io_code_string $ret])"
         return $ret
      }

      # only include current month events
      if {[string range $month 0 1] != [string range $date 0 1]} {
         set ret [db_next $tid]
         continue
      }

      # if filter is set to all in this month,exit
      if {$filter == $SCHED_FILTER_ALL} {
         return $DBENG_OK
      }

      set ret [db_get_field $tid $SCHED_FIELD_CAT cat]

      if {$ret != $DBENG_OK} {
         warning_error "$mname\n\nerror getting category field(\
                        [db_io_code_string $ret]) ($date)"
         return $ret
      }

      if {![xref_category $cat cat_typ desc]} {
         warning_error "$mname\n\nerror getting category type"
         return $DBENG_INVALID_FUNCTION
      }

      switch $filter \
         $SCHED_FILTER_BUDGET {if {$cat_typ == $CAT_TYPE_CREDIT || \
                                  $cat_typ == $CAT_TYPE_DEBIT} \
                                  {return $DBENG_OK}} \
         $SCHED_FILTER_OTHER {if {$cat_typ == $CAT_TYPE_NA} \
                                 {return $DBENG_OK}} \
         default {warning_error "$mname\n\nunknown filter";\
                                 return $DBENG_INVALID_FUNCTION}

      set ret [db_next $tid]
   }

   return $ret
}

proc xref_category {cat typ desc} {
   # Lookup a category and return the category type. Returns
   # 1 upon success with the category type loaded into 'typ'
   # and the category description loaded into 'desc'.
   # Returns 0 otherwise.
   global sched_cat_tid DBENG_OK CAT_FIELD_NUM CAT_FIELD_TYPE CAT_FIELD_DESC
   upvar $typ u_typ
   upvar $desc u_desc
   set mname "xref_category"
   set lk -1

   if {[set ret [db_top $sched_cat_tid]] != $DBENG_OK} {
      warning_error "$mname\n\nerror going to top of category table(\
           [db_io_code_string $ret])"
      return 0
   }

   if {[set ret [db_find_field $sched_cat_tid 0 $cat $CAT_FIELD_NUM]] \
       != $DBENG_OK} {
      warning_error "$mname\n\nerror locating category record(\
                     [db_io_code_string $ret])"
      return 0
   }

   if {[set ret [db_get_field $sched_cat_tid $CAT_FIELD_TYPE buf]] \
       != $DBENG_OK} {
      warning_error "$mname\n\nerror getting category type(\
                     [db_io_code_string $ret])"
      return 0
   }

   if {![num $buf]} {
      warning_error "$mname\n\ncategory type is not numeric"
      return 0
   }

   set u_typ $buf

   if {[set ret [db_get_field $sched_cat_tid $CAT_FIELD_DESC buf]] \
       != $DBENG_OK} {
      warning_error "$mname\n\nerror getting category description(\
                     [db_io_code_string $ret])"
      return 0
   }

   set u_desc $buf
   return 1
}

proc get_year_db_list {} {
   # Build and return a space delimited list of database years.
   # Returns a list of years upon success, an empty string otherwise.
   global DBENG_OK DBENG_LIST_DELIM
   set mname "get_year_db_list"

   if {[set ret [db_get_catalog_list "schedule*" tlist]] != $DBENG_OK} {
      warning_error "$mname\n\nNo schedule tables exist."
      destroy $dlg
      return
   }

   # number of table entries returned
   set nitems [ll_words $tlist $DBENG_LIST_DELIM]

   # output year list (space before each entry)
   set ylist ""

   for {set i 1} {$i <= $nitems} {incr i} {
      # get single complete catalog entry
      if {![ll_word $tlist entry $i $DBENG_LIST_DELIM]} {
         warning_error "$mname\n\nError getting schedule table name(1,$i)"
      } else {
         # get first comma delimited word (logical table name)
         if {![ll_word $entry tname 1 ","]} {
            warning_error "$mname\n\nError getting schedule table name(2,$i)"
         } else {
            # get second period delimited word
            if {![ll_word $tname tyear 2 "."]} {
               warning_error "$mname\n\nError getting schedule table name\
                              (3,$i)"
            } else {
               # ignore tables not having a number as the second word
               if {[num $tyear]} {
                  # add to year list
                  append ylist " " $tyear
               }
            }
         }
      }
   }

   return $ylist
}

proc get_month {which} {
   # Build and return the month number followed by its name from
   # the month number in 'which' or if 'which' is 'a', return
   # a string containg every month number and name (each quoted).
   # Returns an empty string upon error.
   set mname "get_month"
   set mlist [list "1 January" "2 February" "3 March" "4 April" "5 May" \
                   "6 June" "7 July" "8 August" "9 September" \
                   "10 October" "11 November" "12 December"]

   if {[num $which]} {
      if {$which < 1 || $which > 12} {
         warning_error "$mname\n\nmonth number out of range"
         return ""
      }

      return [lindex $mlist [expr $which - 1]]
   }

   if {[string toupper [string range $which 0 0]] == "A"} {
      set ret ""

      for {set i 0} {$i < 12} {incr i} {
         if {$i > 0} {
            append ret " "
         }

         append ret "\""
         append ret [lindex $mlist $i]
         append ret "\""
      }

      return $ret
   }

   return ""
}

proc ll_locate {seq} {
   # Locate an entry in the event list by its sequence number. Returns
   # the list entry upon success, an empty string otherwise.
   global event_list

   return [lindex $event_list $seq]
}

proc append_event_line {id desc category planned \
                        actual planned_bal actual_bal} {
   # append a line to the end of the listbox
   set line "$id  "
   append line [string range [rpad $desc " " 20] 0 19]
   append line [string range [rpad $category " " 20] 0 19]
   append line [string range [lpad $planned " " 8] 0 7]
   append line [string range [lpad $actual " " 8] 0 7]
   append line [string range [lpad $planned_bal " " 8] 0 7]
   append line [string range [lpad $actual_bal " " 8] 0 7]
   .main.events.frm.dat insert end $line
}

proc get_date {} {
   # Load globals with the current year and month.
   global year_num month_num

   set tmp [get_time]
   set year_num [string range $tmp 0 3]
   set month_num [string range $tmp 4 5]
}

proc set_title {} {
   # set main window title
   global app year_num month_num

   set title "$app(appname) - $year_num/$month_num"
   wm title .main $title
}

proc warning_error {mes} {
   # Display a warning error message window.
   # first, remove any popup window
   pop_down
   tk_messageBox -default ok -icon warning -message $mes \
      -parent .main -title "Warning" -type ok
   focus .main.events.frm.dat
}

proc fatal_error {mes} {
   # Display a fatal error message window and exit.
   pop_down
   tk_messageBox -default ok -icon error -message $mes \
      -parent .main -title "Fatal Error" -type ok
   term_app
   exit
}

proc info_error {mes} {
   # Display a information error message window and exit.
   pop_down
   tk_messageBox -default ok -icon info -message $mes \
      -parent .main -title "Information" -type ok
   focus .main.events.frm.dat
}

proc open_tables {} {
   # Open application tables.
   global SCHED_NAME DBENG_OK SCHED_CAT_NAME sched_changed
   global sched_cat_changed year_num sched_tid sched_cat_tid
   set mname "open_tables"

   set table "$SCHED_NAME.$year_num"

   if {[set ret [db_open $table sched_tid]] != $DBENG_OK} {
      fatal_error "$mname:open of $table failed([db_io_code_string $ret])"
      return
   }

   if {[set ret [db_open $SCHED_CAT_NAME sched_cat_tid]] != $DBENG_OK} {
      fatal_error "$mname:open of $SCHED_CAT_NAME failed([db_io_code_string $ret])"
      db_close $sched_tid
      return
   }

   set sched_changed 0
   set sched_cat_changed 0
}

proc close_tables {} {
   # Sort table (if changed) and close them.
   global sched_changed sched_cat_changed sched_tid SHCED_FIELD_DATE
   global sched_cat_tid CAT_FIELD_NUM

   if {$sched_changed} {
      puts "sorting schedule table"
      db_sort $sched_tid $SCHED_FIELD_DATE
      set sched_changed 0
   }

   if {$sched_cat_changed} {
      puts "sorting schedule category table"
      db_sort $sched_cat_tid $CAT_FIELD_NUM
      set sched_cat_changed 0
   }

   db_close $sched_tid
   db_close $sched_cat_tid
}

proc dump_lb_events {} {
   # Write listbox content messages to a log file.
   set mname "dump_lb_events"
   set nitems [.main.events.frm.dat size]
   log_file_date "$mname:$nitems in listbox"
   log_file_date "$mname:listbox contents"

   for {set i 0} {$i < $nitems} {incr i} {
      set item [.main.events.frm.dat get $i $i]
      log_file_date "$mname:element($i)=$item"
   }
}

proc term_app {} {
   # Prepare to terminate the application. Shutdown all IPC API's.

   db_end

   if {[logman_is_active]} {
      logman_end
   }

   appinit_remove_name
}

# app main line
tk appname $app(appname)
get_date
app_create

# register application name with 'appinit'
if {![appinit_register_name $app(appname)]} {
   set mes "$app(appname)\n\nfatal error registering app name "
   append mes "with appinit"
   fatal_error
}

# initialize local engine if we are running locally or
# startup the 'socloc' interface and connect to a
# Bbuuzzb database server if we are running in
# client/server mode
if {![c_initialize]} {
   exit
}

open_tables

#if {![log_start "/logs/cupsched.log"]} {
#   fatal_error "Unable to start logger"
#}

display_events $SCHED_FILTER_ALL

