mirror of
https://github.com/Gnucash/gnucash.git
synced 2025-02-25 18:55:30 -06:00
Refactor payables report into a generic aging report (really just
the aging report framework) and then create a payables aging report and receivables aging report which use it. git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@6151 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Derek Atkins
parent
f224d041ad
commit
04eb2a6d6d
@ -21,6 +21,7 @@ gncscmmoddir = ${GNC_SHAREDIR}/guile-modules/gnucash/report/
|
||||
gncscmmod_DATA = \
|
||||
account-piecharts.scm \
|
||||
account-summary.scm \
|
||||
aging.scm \
|
||||
average-balance.scm \
|
||||
balance-sheet.scm \
|
||||
category-barchart.scm \
|
||||
@ -29,6 +30,7 @@ gncscmmod_DATA = \
|
||||
pnl.scm \
|
||||
portfolio.scm \
|
||||
price-scatter.scm \
|
||||
receivables.scm \
|
||||
register.scm \
|
||||
standard-reports.scm \
|
||||
transaction.scm
|
||||
|
||||
559
src/report/standard-reports/aging.scm
Normal file
559
src/report/standard-reports/aging.scm
Normal file
@ -0,0 +1,559 @@
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; aging.scm : accounts payable/receivable aging report utilities
|
||||
;;
|
||||
;; By Derek Atkins <warlord@MIT.EDU> taken from the original...
|
||||
;; By Robert Merkel (rgmerk@mira.net)
|
||||
;;
|
||||
;; 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, contact:
|
||||
;;
|
||||
;; Free Software Foundation Voice: +1-617-542-5942
|
||||
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
|
||||
;; Boston, MA 02111-1307, USA gnu@gnu.org
|
||||
;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-module (gnucash report aging))
|
||||
|
||||
(use-modules (ice-9 slib))
|
||||
(use-modules (gnucash bootstrap))
|
||||
(use-modules (gnucash gnc-module))
|
||||
|
||||
(require 'hash-table)
|
||||
(require 'record)
|
||||
|
||||
(gnc:module-load "gnucash/report/report-system" 0)
|
||||
|
||||
(define sect-acc (N_ "Accounts"))
|
||||
(define optname-to-date (N_ "To"))
|
||||
(define optname-use-description (N_ "Use Description?"))
|
||||
(define optname-sort-by (N_ "Sort By"))
|
||||
(define optname-sort-order (N_ "Sort Order"))
|
||||
(define optname-report-currency (N_ "Report's currency"))
|
||||
(define optname-price-source (N_ "Price Source"))
|
||||
(define optname-multicurrency-totals (N_ "Show Multi-currency Totals?"))
|
||||
|
||||
;; The idea is: have a hash with the key being the contact name
|
||||
;; (In future this might be GUID'ed, but for now it's a string
|
||||
;; from the description or the split memo.
|
||||
;; The value is a record which contains the currency that contact
|
||||
;; is stored in (you can only owe a particular contact one
|
||||
;; currency, it just gets far too difficult otherwise), and a list
|
||||
;; of buckets containing the money owed for each interval,
|
||||
;; oldest first.
|
||||
;; overpayment is just that - it stores the current overpayment,
|
||||
;; if any. Any bills get taken out of the overpayment before
|
||||
;; incurring debt.
|
||||
|
||||
(define company-info (make-record-type "ComanyInfo"
|
||||
'(currency
|
||||
bucket-vector
|
||||
overpayment)))
|
||||
|
||||
(define num-buckets 4)
|
||||
(define (new-bucket-vector)
|
||||
(make-vector num-buckets (gnc:numeric-zero)))
|
||||
|
||||
(define make-company-private
|
||||
(record-constructor company-info '(currency bucket-vector overpayment)))
|
||||
|
||||
(define (make-company currency)
|
||||
(make-company-private currency (new-bucket-vector) (gnc:numeric-zero)))
|
||||
|
||||
(define company-get-currency
|
||||
(record-accessor company-info 'currency))
|
||||
|
||||
(define company-get-buckets
|
||||
(record-accessor company-info 'bucket-vector))
|
||||
|
||||
(define company-set-buckets
|
||||
(record-modifier company-info 'bucket-vector))
|
||||
|
||||
(define company-get-overpayment
|
||||
(record-accessor company-info 'overpayment))
|
||||
|
||||
(define company-set-overpayment
|
||||
(record-modifier company-info 'overpayment))
|
||||
|
||||
;; Put an invoice in the appropriate bucket
|
||||
|
||||
(define (process-invoice company amount bucket-intervals date)
|
||||
(define (in-interval this-date current-bucket)
|
||||
(gnc:timepair-lt this-date current-bucket))
|
||||
|
||||
(define (find-bucket current-bucket bucket-intervals date)
|
||||
(begin
|
||||
(gnc:debug "current bucket" current-bucket)
|
||||
(gnc:debug "bucket-intervals" bucket-intervals)
|
||||
(gnc:debug "date" date)
|
||||
(if (> current-bucket (vector-length bucket-intervals))
|
||||
(gnc:error "sanity check failed in find-bucket")
|
||||
(if (in-interval date (vector-ref bucket-intervals current-bucket))
|
||||
current-bucket
|
||||
(find-bucket (+ current-bucket 1) bucket-intervals date)))))
|
||||
|
||||
(define (calculate-adjusted-values amount overpayment)
|
||||
(if (>= (gnc:numeric-compare amount overpayment) 0)
|
||||
(cons (gnc:numeric-sub-fixed amount overpayment)
|
||||
(gnc:numeric-zero))
|
||||
(cons (gnc:numeric-zero)
|
||||
(gnc:numeric-sub-fixed overpayment amount))))
|
||||
|
||||
(let* ((current-overpayment (company-get-overpayment company))
|
||||
(adjusted-values (calculate-adjusted-values amount current-overpayment))
|
||||
(adjusted-amount (car adjusted-values))
|
||||
(adjusted-overpayment (cdr adjusted-values))
|
||||
(bucket-index (find-bucket 0 bucket-intervals date))
|
||||
(buckets (company-get-buckets company))
|
||||
(new-bucket-value
|
||||
(gnc:numeric-add-fixed adjusted-amount (vector-ref buckets bucket-index))))
|
||||
(vector-set! buckets bucket-index new-bucket-value)
|
||||
(company-set-buckets company buckets)
|
||||
(company-set-overpayment company adjusted-overpayment)))
|
||||
|
||||
|
||||
;; NOTE: We assume that bill payments occur in a FIFO manner - ie
|
||||
;; any payment to a company goes towards the *oldest* bill first
|
||||
|
||||
|
||||
(define (process-payment company amount)
|
||||
(define (process-payment-driver amount buckets current-bucket-index)
|
||||
(if (>= current-bucket-index (vector-length buckets))
|
||||
amount
|
||||
(let ((current-bucket-amt (vector-ref buckets current-bucket-index)))
|
||||
(if (>= (gnc:numeric-compare current-bucket-amt amount) 0)
|
||||
(begin
|
||||
(vector-set! buckets current-bucket-index (gnc:numeric-sub-fixed
|
||||
current-bucket-amt amount))
|
||||
(gnc:numeric-zero))
|
||||
(begin
|
||||
(vector-set! buckets current-bucket-index (gnc:numeric-zero))
|
||||
(process-payment-driver
|
||||
(gnc:numeric-sub-fixed amount current-bucket-amt)
|
||||
buckets
|
||||
(+ current-bucket-index 1)))))))
|
||||
|
||||
(let ((overpayment (company-get-overpayment company)))
|
||||
;; if there's already an overpayment, make it bigger
|
||||
(if (gnc:numeric-positive-p overpayment)
|
||||
(company-set-overpayment company (gnc:numeric-add-fixed overpayment amount))
|
||||
|
||||
(let ((result (process-payment-driver amount (company-get-buckets company) 0)))
|
||||
(company-set-overpayment company result)))))
|
||||
|
||||
|
||||
|
||||
|
||||
;; deal with a transaction - figure out if we've seen the company before
|
||||
;; if so, either process it as a bill or a payment, if not, create
|
||||
;; a new company record in the hash
|
||||
|
||||
(define (update-company-hash hash split bucket-intervals
|
||||
use-description? reverse?)
|
||||
(let* ((transaction (gnc:split-get-parent split))
|
||||
(company-name (if use-description?
|
||||
(gnc:transaction-get-description transaction)
|
||||
(gnc:split-get-memo split)))
|
||||
(this-currency (gnc:transaction-get-currency transaction))
|
||||
(value (gnc:split-get-value split))
|
||||
(this-date (gnc:transaction-get-date-posted transaction))
|
||||
(company-info (hash-ref hash company-name)))
|
||||
|
||||
(gnc:debug "update-company-hash called")
|
||||
(gnc:debug "company-name" company-name)
|
||||
(gnc:debug "split-value" value)
|
||||
(if reverse? (set! value (gnc:numeric-neg value)))
|
||||
(if company-info
|
||||
;; if it's an existing company, first check currencies match
|
||||
(if (not (gnc:commodity-equiv? this-currency
|
||||
(company-get-currency company-info)))
|
||||
(cons #f (sprintf (_ "Transactions relating to company %d contain \
|
||||
more than one currency. This report is not designed to cope with this possibility.")))
|
||||
(begin
|
||||
(gnc:debug "it's an old company")
|
||||
(if (gnc:numeric-negative-p value)
|
||||
(process-invoice company-info (gnc:numeric-neg value) bucket-intervals this-date)
|
||||
(process-payment company-info value))
|
||||
(hash-set! hash company-name company-info)
|
||||
(cons #t company-name)))
|
||||
|
||||
;; if it's a new company
|
||||
(begin
|
||||
(gnc:debug "value" value)
|
||||
(if (gnc:numeric-negative-p value) ;; if it's a new debt
|
||||
;; if not ignore it
|
||||
;;; XXX: is this right ?
|
||||
(let ((new-company (make-company this-currency)))
|
||||
(process-invoice new-company (gnc:numeric-neg value) bucket-intervals this-date)
|
||||
(hash-set! hash company-name new-company)))
|
||||
(cons #t company-name)))))
|
||||
|
||||
|
||||
;; get the total debt from the buckets
|
||||
(define (buckets-get-total buckets)
|
||||
(let ((running-total (gnc:numeric-zero))
|
||||
(buckets-list (vector->list buckets)))
|
||||
(for-each (lambda (bucket)
|
||||
(set! running-total
|
||||
(gnc:numeric-add-fixed bucket running-total)))
|
||||
buckets-list)
|
||||
running-total))
|
||||
|
||||
|
||||
;; compare by the total in the buckets
|
||||
|
||||
(define (compare-total litem-a litem-b)
|
||||
(let* ((company-a (cdr litem-a))
|
||||
(bucket-a (company-get-buckets company-a))
|
||||
(company-b (cdr litem-b))
|
||||
(bucket-b (company-get-buckets company-b))
|
||||
(total-a (buckets-get-total bucket-a))
|
||||
(total-b (buckets-get-total bucket-b))
|
||||
(difference-sign (gnc:numeric-compare (gnc:numeric-sub-fixed total-a total-b) (gnc:numeric-zero))))
|
||||
;; if same totals, compare by name
|
||||
(if (= difference-sign 0)
|
||||
(gnc:safe-strcmp (car litem-a) (car litem-b))
|
||||
difference-sign)))
|
||||
|
||||
;; compare by buckets, oldest first.
|
||||
|
||||
(define (compare-buckets litem-a litem-b)
|
||||
(define (driver buckets-a buckets-b)
|
||||
(if (null? buckets-a)
|
||||
0
|
||||
(let ((diff (gnc:numeric-compare
|
||||
(gnc:numeric-sub-fixed
|
||||
(car buckets-a)
|
||||
(car buckets-b))
|
||||
(gnc:numeric-zero))))
|
||||
(if (= diff 0)
|
||||
(driver (cdr buckets-a) (cdr buckets-b))
|
||||
diff))))
|
||||
|
||||
(let* ((company-a (cdr litem-a))
|
||||
(bucket-a (vector->list (company-get-buckets company-a)))
|
||||
(company-b (cdr litem-b))
|
||||
(bucket-b (vector->list (company-get-buckets company-b)))
|
||||
|
||||
(difference (driver bucket-a bucket-b)))
|
||||
;; if same totals, compare by name
|
||||
(if (= difference 0)
|
||||
(gnc:safe-strcmp (car litem-a) (car litem-b))
|
||||
difference)))
|
||||
|
||||
|
||||
;; set up the query to get the splits in the chosen account
|
||||
;; XXX: Need a better method to actually sort through the 'active'
|
||||
;; transactions. Currently go back a year, but obviously we need
|
||||
;; a way to tell that a transaction is 'paid'
|
||||
;;; FIXME: begindate is a hack
|
||||
(define (setup-query query account date)
|
||||
(define (date-copy date)
|
||||
(cons (car date) (cdr date)))
|
||||
(let ((begindate (date-copy date)))
|
||||
; (gnc:debug "Account: " account)
|
||||
(set! begindate (decdate begindate NinetyDayDelta))
|
||||
(set! begindate (decdate begindate NinetyDayDelta))
|
||||
(set! begindate (decdate begindate NinetyDayDelta))
|
||||
(set! begindate (decdate begindate NinetyDayDelta)) ;XXX - 360 days!?!
|
||||
(gnc:debug "begindate" begindate)
|
||||
(gnc:debug "date" date)
|
||||
(gnc:query-set-group query (gnc:get-current-group))
|
||||
(gnc:query-set-match-non-voids-only! query (gnc:get-current-group))
|
||||
(gnc:query-add-single-account-match query account 'query-and)
|
||||
(gnc:query-add-date-match-timepair query #t begindate #t date 'query-and)
|
||||
(gnc:query-set-sort-order query 'by-date 'by-none 'by-none)
|
||||
(gnc:query-set-sort-increasing query #t #t #t)))
|
||||
|
||||
|
||||
(define (aging-options-generator options)
|
||||
(let* ((add-option
|
||||
(lambda (new-option)
|
||||
(gnc:register-option options new-option))))
|
||||
|
||||
(gnc:options-add-report-date!
|
||||
options gnc:pagename-general
|
||||
optname-to-date "a")
|
||||
|
||||
;; all about currencies
|
||||
(gnc:options-add-currency!
|
||||
options gnc:pagename-general
|
||||
optname-report-currency "b")
|
||||
|
||||
(gnc:options-add-price-source!
|
||||
options gnc:pagename-general
|
||||
optname-price-source "c" 'weighted-average)
|
||||
|
||||
(add-option
|
||||
(gnc:make-multichoice-option
|
||||
gnc:pagename-general
|
||||
optname-sort-by
|
||||
"i"
|
||||
(N_ "Sort companys by")
|
||||
'name
|
||||
(list
|
||||
(vector 'name (N_ "Name") (N_ "Name of the company"))
|
||||
(vector 'total (N_ "Total Owed") (N_ "Total amount owed to/from Company"))
|
||||
(vector 'oldest-bracket (N_ "Bracket Total Owed") (N_ "Amount owed in oldest bracket - if same go to next oldest")))))
|
||||
|
||||
(add-option
|
||||
(gnc:make-multichoice-option
|
||||
gnc:pagename-general
|
||||
optname-sort-order
|
||||
"ia"
|
||||
(N_ "Sort order")
|
||||
'increasing
|
||||
(list
|
||||
(vector 'increasing (N_ "Increasing") (N_ "0 -> $999,999.99, A->Z"))
|
||||
(vector 'decreasing (N_ "Decreasing") (N_ "$999,999.99 -> $0, Z->A")))))
|
||||
|
||||
(add-option
|
||||
(gnc:make-simple-boolean-option
|
||||
gnc:pagename-general
|
||||
optname-use-description
|
||||
"h"
|
||||
(N_ "Use the description to identify individual companys.\
|
||||
If false, use split memo")
|
||||
#t))
|
||||
|
||||
|
||||
(add-option
|
||||
(gnc:make-simple-boolean-option
|
||||
gnc:pagename-general
|
||||
optname-multicurrency-totals
|
||||
"i"
|
||||
(N_ "Show multi-currency totals. If not selected, convert all\
|
||||
totals to report currency")
|
||||
#f))
|
||||
(gnc:options-set-default-section options "General")
|
||||
options))
|
||||
|
||||
(define (make-interval-list to-date)
|
||||
(let ((begindate to-date))
|
||||
(set! begindate (decdate begindate ThirtyDayDelta))
|
||||
(set! begindate (decdate begindate ThirtyDayDelta))
|
||||
(set! begindate (decdate begindate ThirtyDayDelta))
|
||||
(gnc:make-date-list begindate to-date ThirtyDayDelta)))
|
||||
|
||||
(define (aging-renderer report-obj account reverse?)
|
||||
|
||||
;; Predicates for sorting the companys once the data has been collected
|
||||
|
||||
;; Format: (cons 'sort-key (cons 'increasing-pred 'decreasing-pred))
|
||||
(define sort-preds
|
||||
(list
|
||||
(cons 'name (cons (lambda (a b)
|
||||
(string<? (car a) (car b)))
|
||||
(lambda (a b)
|
||||
(string>? (car a) (car b)))))
|
||||
(cons 'total (cons (lambda (a b)
|
||||
(< (compare-total a b) 0))
|
||||
(lambda (a b)
|
||||
(> (compare-total a b) 0))))
|
||||
(cons 'oldest-bracket (cons
|
||||
(lambda (a b)
|
||||
(< (compare-buckets a b) 0))
|
||||
(lambda (a b)
|
||||
(> (compare-buckets a b) 0))))))
|
||||
|
||||
|
||||
|
||||
(define (get-sort-pred sort-criterion sort-order)
|
||||
(let ((choice (assq-ref sort-preds sort-criterion)))
|
||||
(gnc:debug "sort-criterion" sort-criterion)
|
||||
(gnc:debug "sort-order" sort-order)
|
||||
(gnc:debug "choice: " choice)
|
||||
(if choice
|
||||
(if (eq? sort-order 'increasing)
|
||||
(car choice)
|
||||
(cdr choice))
|
||||
(begin
|
||||
(gnc:warn "internal sorting option errorin aging.scm")
|
||||
(lambda (a b)
|
||||
(string<? (car a) (car b)))))))
|
||||
|
||||
(define (get-op section name)
|
||||
(gnc:lookup-option (gnc:report-options report-obj) section name))
|
||||
|
||||
(define (op-value section name)
|
||||
(gnc:option-value (get-op section name)))
|
||||
|
||||
|
||||
;; XXX: This is a hack - will be fixed when we move to a
|
||||
;; more general interval scheme in this report
|
||||
(define (make-heading-list)
|
||||
(list
|
||||
(N_ "Company")
|
||||
(N_ "0-30 days")
|
||||
(N_ "31-60 days")
|
||||
(N_ "61-90 days")
|
||||
(N_ "91+ days")
|
||||
(N_ "Total")))
|
||||
|
||||
|
||||
;; Make a list of commodity collectors for column totals
|
||||
|
||||
(define (make-collector-list)
|
||||
(define (make-collector-driver done total)
|
||||
(if (< done total)
|
||||
(cons
|
||||
(gnc:make-commodity-collector)
|
||||
(make-collector-driver (+ done 1) total))
|
||||
'()))
|
||||
(make-collector-driver 0 (+ num-buckets 1)))
|
||||
|
||||
|
||||
;; update the column totals
|
||||
|
||||
(define (add-to-column-totals column-totals monetary-list)
|
||||
(begin
|
||||
(gnc:debug "column-totals" column-totals)
|
||||
(gnc:debug "monetary-list" monetary-list)
|
||||
(map (lambda (amount collector)
|
||||
(begin
|
||||
(gnc:debug "amount" amount)
|
||||
(gnc:debug "collector" collector)
|
||||
(collector 'add
|
||||
(gnc:gnc-monetary-commodity amount)
|
||||
(gnc:gnc-monetary-amount amount))))
|
||||
monetary-list
|
||||
column-totals)))
|
||||
|
||||
;; convert the buckets in the header data structure
|
||||
(define (convert-to-monetary-list bucket-list currency)
|
||||
(let* ((running-total (gnc:numeric-zero))
|
||||
(monetised-buckets
|
||||
(map (lambda (bucket-list-entry)
|
||||
(begin
|
||||
(set! running-total
|
||||
(gnc:numeric-add-fixed running-total bucket-list-entry))
|
||||
(gnc:make-gnc-monetary currency bucket-list-entry)))
|
||||
(vector->list bucket-list))))
|
||||
(append (reverse monetised-buckets)
|
||||
(list (gnc:make-gnc-monetary currency running-total)))))
|
||||
|
||||
|
||||
;; convert the collectors to the right output format
|
||||
|
||||
(define (convert-collectors collector-list report-currency
|
||||
exchange-fn
|
||||
multi-currencies-p)
|
||||
(define (fmt-one-currency collector)
|
||||
(let ((monetary (gnc:sum-collector-commodity collector report-currency exchange-fn)))
|
||||
(if monetary
|
||||
monetary
|
||||
(begin
|
||||
(gnc:warn "Exchange-lookup failed in fmt-one-currency")
|
||||
#f))))
|
||||
|
||||
(define (fmt-multiple-currencies collector)
|
||||
(let ((mini-table (gnc:make-html-table)))
|
||||
(collector 'format
|
||||
(lambda (commodity amount)
|
||||
(gnc:html-table-append-row!
|
||||
mini-table
|
||||
(list (gnc:make-gnc-monetary
|
||||
commodity amount))))
|
||||
#f)
|
||||
mini-table))
|
||||
|
||||
(let ((fmt-function
|
||||
(if multi-currencies-p
|
||||
fmt-multiple-currencies
|
||||
fmt-one-currency)))
|
||||
(map fmt-function collector-list)))
|
||||
|
||||
|
||||
(let* ((companys (make-hash-table 23))
|
||||
(report-title (op-value gnc:pagename-general
|
||||
gnc:optname-reportname))
|
||||
;; document will be the HTML document that we return.
|
||||
(report-date (gnc:timepair-end-day-time
|
||||
(gnc:date-option-absolute-time
|
||||
(op-value gnc:pagename-general (N_ "To")))))
|
||||
(use-description? (op-value gnc:pagename-general optname-use-description))
|
||||
(interval-vec (list->vector (make-interval-list report-date)))
|
||||
(sort-pred (get-sort-pred
|
||||
(op-value gnc:pagename-general optname-sort-by)
|
||||
(op-value gnc:pagename-general optname-sort-order)))
|
||||
(report-currency (op-value gnc:pagename-general optname-report-currency))
|
||||
(price-source (op-value gnc:pagename-general optname-price-source))
|
||||
(multi-totals-p (op-value gnc:pagename-general optname-multicurrency-totals))
|
||||
(heading-list (make-heading-list))
|
||||
(exchange-fn (gnc:case-exchange-fn price-source report-currency report-date))
|
||||
(total-collector-list (make-collector-list))
|
||||
(table (gnc:make-html-table))
|
||||
(query (gnc:malloc-query))
|
||||
(company-list '())
|
||||
(document (gnc:make-html-document)))
|
||||
; (gnc:debug "Account: " account)
|
||||
(gnc:html-document-set-title! document report-title)
|
||||
(gnc:html-table-set-col-headers! table heading-list)
|
||||
|
||||
(if account
|
||||
(begin
|
||||
(setup-query query account report-date)
|
||||
;; get the appropriate splits
|
||||
(let ((splits (gnc:glist->list (gnc:query-get-splits query) <gnc:Split*>)))
|
||||
; (gnc:debug "splits" splits)
|
||||
|
||||
;; build the table
|
||||
(for-each (lambda (split)
|
||||
(update-company-hash companys
|
||||
split
|
||||
interval-vec
|
||||
use-description?
|
||||
reverse?))
|
||||
splits)
|
||||
; (gnc:debug "companys" companys)
|
||||
;; turn the hash into a list
|
||||
(hash-for-each (lambda (key value)
|
||||
(set! company-list
|
||||
(cons (cons key value) company-list)))
|
||||
companys)
|
||||
; (gnc:debug "company list" company-list)
|
||||
|
||||
(set! company-list (sort-list! company-list
|
||||
sort-pred))
|
||||
|
||||
;; build the table
|
||||
(for-each (lambda (company-list-entry)
|
||||
(let ((monetary-list (convert-to-monetary-list
|
||||
(company-get-buckets
|
||||
(cdr company-list-entry))
|
||||
(company-get-currency
|
||||
(cdr company-list-entry)))))
|
||||
(add-to-column-totals total-collector-list monetary-list)
|
||||
(gnc:html-table-append-row!
|
||||
table (cons (car company-list-entry) monetary-list))))
|
||||
company-list)
|
||||
|
||||
;; add the totals
|
||||
(gnc:html-table-append-row!
|
||||
table
|
||||
(cons (_ "Total") (convert-collectors total-collector-list
|
||||
report-currency
|
||||
exchange-fn
|
||||
multi-totals-p)))
|
||||
|
||||
(gnc:html-document-add-object!
|
||||
document table)))
|
||||
(gnc:html-document-add-object!
|
||||
document
|
||||
(gnc:make-html-text
|
||||
"No Valid Account Selected")))
|
||||
(gnc:free-query query)
|
||||
document))
|
||||
|
||||
(export aging-options-generator)
|
||||
(export aging-renderer)
|
||||
@ -1,7 +1,7 @@
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; payables.scm : accounts payable report
|
||||
;; payables.scm : accounts payable aging report
|
||||
;;
|
||||
;; By Robert Merkel (rgmerk@mira.net)
|
||||
;; By Derek Atkins <warlord@MIT.EDU>
|
||||
;;
|
||||
;; This program is free software; you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU General Public License as
|
||||
@ -25,255 +25,15 @@
|
||||
(define-module (gnucash report payables))
|
||||
|
||||
(use-modules (ice-9 slib))
|
||||
(use-modules (gnucash bootstrap) (g-wrapped gw-gnc)) ;; FIXME: delete after we finish modularizing.
|
||||
(use-modules (gnucash bootstrap))
|
||||
(use-modules (gnucash gnc-module))
|
||||
|
||||
(require 'hash-table)
|
||||
(require 'record)
|
||||
|
||||
(gnc:module-load "gnucash/report/report-system" 0)
|
||||
|
||||
(use-modules (gnucash report aging))
|
||||
|
||||
(define opt-pay-acc (N_ "Payables Account"))
|
||||
(define sect-acc (N_ "Accounts"))
|
||||
(define optname-to-date (N_ "To"))
|
||||
(define optname-use-description (N_ "Use Description?"))
|
||||
(define optname-sort-by (N_ "Sort By"))
|
||||
(define optname-sort-order (N_ "Sort Order"))
|
||||
(define optname-report-currency (N_ "Report's currency"))
|
||||
(define optname-price-source (N_ "Price Source"))
|
||||
(define optname-multicurrency-totals (N_ "Show Multi-currency Totals?"))
|
||||
|
||||
;; The idea is: have a hash with the key being the creditor name
|
||||
;; (In future this might be GUID'ed, but for now it's a string
|
||||
;; from the description or the split memo.
|
||||
;; The value is a record which contains the currency that creditor
|
||||
;; is stored in (you can only owe a particular creditor one
|
||||
;; currency, it just gets far too difficult otherwise), and a list
|
||||
;; of buckets containing the money owed for each interval,
|
||||
;; oldest first.
|
||||
;; overpayment is just that - it stores the current overpayment,
|
||||
;; if any. Any bills get taken out of the overpayment before
|
||||
;; incurring debt.
|
||||
|
||||
(define creditor-info (make-record-type "CreditorInfo"
|
||||
'(currency
|
||||
bucket-vector
|
||||
overpayment)))
|
||||
|
||||
(define num-buckets 4)
|
||||
(define (new-bucket-vector)
|
||||
(make-vector num-buckets (gnc:numeric-zero)))
|
||||
|
||||
(define make-creditor-private
|
||||
(record-constructor creditor-info '(currency bucket-vector
|
||||
overpayment)))
|
||||
|
||||
(define (make-creditor currency)
|
||||
(make-creditor-private currency (new-bucket-vector)
|
||||
(gnc:numeric-zero)))
|
||||
|
||||
(define creditor-get-currency
|
||||
(record-accessor creditor-info 'currency))
|
||||
|
||||
(define creditor-get-buckets
|
||||
(record-accessor creditor-info 'bucket-vector))
|
||||
|
||||
(define creditor-set-buckets
|
||||
(record-modifier creditor-info 'bucket-vector))
|
||||
|
||||
(define creditor-get-overpayment
|
||||
(record-accessor creditor-info 'overpayment))
|
||||
|
||||
(define creditor-set-overpayment
|
||||
(record-modifier creditor-info 'overpayment))
|
||||
|
||||
;; Put a bill in the appropriate bucket
|
||||
|
||||
(define (process-bill creditor amount bucket-intervals date)
|
||||
(define (in-interval this-date current-bucket)
|
||||
(gnc:timepair-lt this-date current-bucket))
|
||||
|
||||
(define (find-bucket current-bucket bucket-intervals date)
|
||||
(begin
|
||||
(gnc:debug "current bucket" current-bucket)
|
||||
(gnc:debug "bucket-intervals" bucket-intervals)
|
||||
(gnc:debug "date" date)
|
||||
(if (> current-bucket (vector-length bucket-intervals))
|
||||
(gnc:error "sanity check failed in find-bucket")
|
||||
(if (in-interval date (vector-ref bucket-intervals current-bucket))
|
||||
current-bucket
|
||||
(find-bucket (+ current-bucket 1) bucket-intervals date)))))
|
||||
|
||||
(define (calculate-adjusted-values amount overpayment)
|
||||
(if (>= (gnc:numeric-compare amount overpayment) 0)
|
||||
(cons (gnc:numeric-sub-fixed amount overpayment)
|
||||
(gnc:numeric-zero))
|
||||
(cons (gnc:numeric-zero)
|
||||
(gnc:numeric-sub-fixed overpayment amount))))
|
||||
|
||||
(let* ((current-overpayment (creditor-get-overpayment creditor))
|
||||
(adjusted-values (calculate-adjusted-values amount current-overpayment))
|
||||
(adjusted-amount (car adjusted-values))
|
||||
(adjusted-overpayment (cdr adjusted-values))
|
||||
(bucket-index (find-bucket 0 bucket-intervals date))
|
||||
(buckets (creditor-get-buckets creditor))
|
||||
(new-bucket-value
|
||||
(gnc:numeric-add-fixed adjusted-amount (vector-ref buckets bucket-index))))
|
||||
(vector-set! buckets bucket-index new-bucket-value)
|
||||
(creditor-set-buckets creditor buckets)
|
||||
(creditor-set-overpayment creditor adjusted-overpayment)))
|
||||
|
||||
|
||||
;; NOTE: We assume that bill payments occur in a FIFO manner - ie
|
||||
;; any payment to a creditor goes towards the *oldest* bill first
|
||||
|
||||
|
||||
(define (process-payment creditor amount)
|
||||
(define (process-payment-driver amount buckets current-bucket-index)
|
||||
(if (>= current-bucket-index (vector-length buckets))
|
||||
amount
|
||||
(let ((current-bucket-amt (vector-ref buckets current-bucket-index)))
|
||||
(if (>= (gnc:numeric-compare current-bucket-amt amount) 0)
|
||||
(begin
|
||||
(vector-set! buckets current-bucket-index (gnc:numeric-sub-fixed
|
||||
current-bucket-amt amount))
|
||||
(gnc:numeric-zero))
|
||||
(begin
|
||||
(vector-set! buckets current-bucket-index (gnc:numeric-zero))
|
||||
(process-payment-driver
|
||||
(gnc:numeric-sub-fixed amount current-bucket-amt)
|
||||
buckets
|
||||
(+ current-bucket-index 1)))))))
|
||||
|
||||
(let ((overpayment (creditor-get-overpayment creditor)))
|
||||
;; if there's already an overpayment, make it bigger
|
||||
(if (gnc:numeric-positive-p overpayment)
|
||||
(creditor-set-overpayment creditor (gnc:numeric-add-fixed overpayment amount))
|
||||
|
||||
(let ((result (process-payment-driver amount (creditor-get-buckets creditor) 0)))
|
||||
(creditor-set-overpayment creditor result)))))
|
||||
|
||||
|
||||
|
||||
|
||||
;; deal with a transaction - figure out if we've seen the creditor before
|
||||
;; if so, either process it as a bill or a payment, if not, create
|
||||
;; a new creditor record in the hash
|
||||
|
||||
(define (update-creditor-hash hash split bucket-intervals use-description?)
|
||||
(let* ((transaction (gnc:split-get-parent split))
|
||||
(creditor-name (if use-description?
|
||||
(gnc:transaction-get-description transaction)
|
||||
(gnc:split-get-memo split)))
|
||||
(this-currency (gnc:transaction-get-currency transaction))
|
||||
(value (gnc:split-get-value split))
|
||||
(this-date (gnc:transaction-get-date-posted transaction))
|
||||
(creditor-info (hash-ref hash creditor-name)))
|
||||
|
||||
(gnc:debug "update-creditor-hash called")
|
||||
(gnc:debug "creditor-name" creditor-name)
|
||||
(gnc:debug "split-value" value)
|
||||
(if creditor-info
|
||||
;; if it's an existing creditor, first check currencies match
|
||||
(if (not (gnc:commodity-equiv? this-currency
|
||||
(creditor-get-currency creditor-info)))
|
||||
(cons #f (sprintf (_ "Transactions relating to creditor %d contain \
|
||||
more than one currency. This report is not designed to cope with this possibility.")))
|
||||
(begin
|
||||
(gnc:debug "it's an old creditor")
|
||||
(if (gnc:numeric-negative-p value)
|
||||
(process-bill creditor-info (gnc:numeric-neg value) bucket-intervals this-date)
|
||||
(process-payment creditor-info value))
|
||||
(hash-set! hash creditor-name creditor-info)
|
||||
(cons #t creditor-name)))
|
||||
|
||||
;; if it's a new creditor
|
||||
(begin
|
||||
(gnc:debug "value" value)
|
||||
(if (gnc:numeric-negative-p value) ;; if it's a new debt
|
||||
;; if not ignore it
|
||||
;;; XXX: is this right ?
|
||||
(let ((new-creditor (make-creditor this-currency)))
|
||||
(process-bill new-creditor (gnc:numeric-neg value) bucket-intervals this-date)
|
||||
(hash-set! hash creditor-name new-creditor)))
|
||||
(cons #t creditor-name)))))
|
||||
|
||||
|
||||
;; get the total debt from the buckets
|
||||
(define (buckets-get-total buckets)
|
||||
(let ((running-total (gnc:numeric-zero))
|
||||
(buckets-list (vector->list buckets)))
|
||||
(for-each (lambda (bucket)
|
||||
(set! running-total
|
||||
(gnc:numeric-add-fixed bucket running-total)))
|
||||
buckets-list)
|
||||
running-total))
|
||||
|
||||
|
||||
;; compare by the total in the buckets
|
||||
|
||||
(define (compare-total litem-a litem-b)
|
||||
(let* ((creditor-a (cdr litem-a))
|
||||
(bucket-a (creditor-get-buckets creditor-a))
|
||||
(creditor-b (cdr litem-b))
|
||||
(bucket-b (creditor-get-buckets creditor-b))
|
||||
(total-a (buckets-get-total bucket-a))
|
||||
(total-b (buckets-get-total bucket-b))
|
||||
(difference-sign (gnc:numeric-compare (gnc:numeric-sub-fixed total-a total-b) (gnc:numeric-zero))))
|
||||
;; if same totals, compare by name
|
||||
(if (= difference-sign 0)
|
||||
(gnc:safe-strcmp (car litem-a) (car litem-b))
|
||||
difference-sign)))
|
||||
|
||||
;; compare by buckets, oldest first.
|
||||
|
||||
(define (compare-buckets litem-a litem-b)
|
||||
(define (driver buckets-a buckets-b)
|
||||
(if (null? buckets-a)
|
||||
0
|
||||
(let ((diff (gnc:numeric-compare
|
||||
(gnc:numeric-sub-fixed
|
||||
(car buckets-a)
|
||||
(car buckets-b))
|
||||
(gnc:numeric-zero))))
|
||||
(if (= diff 0)
|
||||
(driver (cdr buckets-a) (cdr buckets-b))
|
||||
diff))))
|
||||
|
||||
(let* ((creditor-a (cdr litem-a))
|
||||
(bucket-a (vector->list (creditor-get-buckets creditor-a)))
|
||||
(creditor-b (cdr litem-b))
|
||||
(bucket-b (vector->list (creditor-get-buckets creditor-b)))
|
||||
|
||||
(difference (driver bucket-a bucket-b)))
|
||||
;; if same totals, compare by name
|
||||
(if (= difference 0)
|
||||
(gnc:safe-strcmp (car litem-a) (car litem-b))
|
||||
difference)))
|
||||
|
||||
|
||||
;; set up the query to get the splits in the payables account
|
||||
;; XXX: Need a better method to actually sort through the 'active'
|
||||
;; transactions. Currently go back a year, but obviously we need
|
||||
;; a way to tell that a transaction is 'paid'
|
||||
(define (setup-query query account date)
|
||||
(define (date-copy date)
|
||||
(cons (car date) (cdr date)))
|
||||
(let ((begindate (date-copy date)))
|
||||
; (gnc:debug "Account: " account)
|
||||
(set! begindate (decdate begindate NinetyDayDelta))
|
||||
(set! begindate (decdate begindate NinetyDayDelta))
|
||||
(set! begindate (decdate begindate NinetyDayDelta))
|
||||
(set! begindate (decdate begindate NinetyDayDelta)) ;XXX - 360 days!?!
|
||||
(gnc:debug "begindate" begindate)
|
||||
(gnc:debug "date" date)
|
||||
(gnc:query-set-group query (gnc:get-current-group))
|
||||
(gnc:query-set-match-non-voids-only! query (gnc:get-current-group))
|
||||
(gnc:query-add-single-account-match query account 'query-and)
|
||||
(gnc:query-add-date-match-timepair query #t begindate #t date 'query-and)
|
||||
(gnc:query-set-sort-order query 'by-date 'by-none 'by-none)
|
||||
(gnc:query-set-sort-increasing query #t #t #t)))
|
||||
|
||||
|
||||
(define (options-generator)
|
||||
(let* ((options (gnc:new-options))
|
||||
@ -281,19 +41,6 @@ more than one currency. This report is not designed to cope with this possibili
|
||||
(lambda (new-option)
|
||||
(gnc:register-option options new-option))))
|
||||
|
||||
(gnc:options-add-report-date!
|
||||
options gnc:pagename-general
|
||||
optname-to-date "a")
|
||||
|
||||
;; all about currencies
|
||||
(gnc:options-add-currency!
|
||||
options gnc:pagename-general
|
||||
optname-report-currency "b")
|
||||
|
||||
(gnc:options-add-price-source!
|
||||
options gnc:pagename-general
|
||||
optname-price-source "c" 'weighted-average)
|
||||
|
||||
(add-option
|
||||
(gnc:make-account-list-option
|
||||
sect-acc opt-pay-acc
|
||||
@ -349,268 +96,18 @@ more than one currency. This report is not designed to cope with this possibili
|
||||
(#t '()))))
|
||||
#f))
|
||||
|
||||
(add-option
|
||||
(gnc:make-multichoice-option
|
||||
gnc:pagename-general
|
||||
optname-sort-by
|
||||
"i"
|
||||
(N_ "Sort creditors by")
|
||||
'name
|
||||
(list
|
||||
(vector 'name (N_ "Name") (N_ "Name of the creditor"))
|
||||
(vector 'total (N_ "Total Owed") (N_ "Total amount owed to Creditor"))
|
||||
(vector 'oldest-bracket (N_ "Bracket Total Owed") (N_ "Amount owed in oldest bracket - if same go to next oldest")))))
|
||||
|
||||
(add-option
|
||||
(gnc:make-multichoice-option
|
||||
gnc:pagename-general
|
||||
optname-sort-order
|
||||
"ia"
|
||||
(N_ "Sort order")
|
||||
'increasing
|
||||
(list
|
||||
(vector 'increasing (N_ "Increasing") (N_ "0 -> $999,999.99, A->Z"))
|
||||
(vector 'decreasing (N_ "Decreasing") (N_ "$999,999.99 -> $0, Z->A")))))
|
||||
|
||||
(add-option
|
||||
(gnc:make-simple-boolean-option
|
||||
gnc:pagename-general
|
||||
optname-use-description
|
||||
"h"
|
||||
(N_ "Use the description to identify individual creditors.\
|
||||
If false, use split memo")
|
||||
#t))
|
||||
|
||||
|
||||
(add-option
|
||||
(gnc:make-simple-boolean-option
|
||||
gnc:pagename-general
|
||||
optname-multicurrency-totals
|
||||
"i"
|
||||
(N_ "Show multi-currency totals. If not selected, convert all\
|
||||
totals to report currency")
|
||||
#f))
|
||||
(gnc:options-set-default-section options "General")
|
||||
options))
|
||||
|
||||
(define (make-interval-list to-date)
|
||||
(let ((begindate to-date))
|
||||
(set! begindate (decdate begindate ThirtyDayDelta))
|
||||
(set! begindate (decdate begindate ThirtyDayDelta))
|
||||
(set! begindate (decdate begindate ThirtyDayDelta))
|
||||
(gnc:make-date-list begindate to-date ThirtyDayDelta)))
|
||||
(aging-options-generator options)))
|
||||
|
||||
(define (payables-renderer report-obj)
|
||||
|
||||
;; Predicates for sorting the creditors once the data has been collected
|
||||
|
||||
;; Format: (cons 'sort-key (cons 'increasing-pred 'decreasing-pred))
|
||||
(define sort-preds
|
||||
(list
|
||||
(cons 'name (cons (lambda (a b)
|
||||
(string<? (car a) (car b)))
|
||||
(lambda (a b)
|
||||
(string>? (car a) (car b)))))
|
||||
(cons 'total (cons (lambda (a b)
|
||||
(< (compare-total a b) 0))
|
||||
(lambda (a b)
|
||||
(> (compare-total a b) 0))))
|
||||
(cons 'oldest-bracket (cons
|
||||
(lambda (a b)
|
||||
(< (compare-buckets a b) 0))
|
||||
(lambda (a b)
|
||||
(> (compare-buckets a b) 0))))))
|
||||
|
||||
|
||||
|
||||
(define (get-sort-pred sort-criterion sort-order)
|
||||
(let ((choice (assq-ref sort-preds sort-criterion)))
|
||||
(gnc:debug "sort-criterion" sort-criterion)
|
||||
(gnc:debug "sort-order" sort-order)
|
||||
(gnc:debug "choice: " choice)
|
||||
(if choice
|
||||
(if (eq? sort-order 'increasing)
|
||||
(car choice)
|
||||
(cdr choice))
|
||||
(begin
|
||||
(gnc:warn "internal sorting option errorin payables.scm")
|
||||
(lambda (a b)
|
||||
(string<? (car a) (car b)))))))
|
||||
|
||||
(define (get-op section name)
|
||||
(gnc:lookup-option (gnc:report-options report-obj) section name))
|
||||
|
||||
(define (op-value section name)
|
||||
(gnc:option-value (get-op section name)))
|
||||
|
||||
|
||||
;; XXX: This is a hack - will be fixed when we move to a
|
||||
;; more general interval scheme in this report
|
||||
(define (make-heading-list)
|
||||
(list
|
||||
(N_ "Creditor Name")
|
||||
(N_ "0-30 days")
|
||||
(N_ "31-60 days")
|
||||
(N_ "61-90 days")
|
||||
(N_ "91+ days")
|
||||
(N_ "Total")))
|
||||
|
||||
|
||||
;; Make a list of commodity collectors for column totals
|
||||
|
||||
;; XXX: Magic number is a hack
|
||||
(define (make-collector-list)
|
||||
(define (make-collector-driver done total)
|
||||
(if (< done total)
|
||||
(cons
|
||||
(gnc:make-commodity-collector)
|
||||
(make-collector-driver (+ done 1) total))
|
||||
'()))
|
||||
(make-collector-driver 0 5))
|
||||
|
||||
|
||||
;; update the column totals
|
||||
|
||||
(define (add-to-column-totals column-totals monetary-list)
|
||||
(begin
|
||||
(gnc:debug "column-totals" column-totals)
|
||||
(gnc:debug "monetary-list" monetary-list)
|
||||
(map (lambda (amount collector)
|
||||
(begin
|
||||
(gnc:debug "amount" amount)
|
||||
(gnc:debug "collector" collector)
|
||||
(collector 'add
|
||||
(gnc:gnc-monetary-commodity amount)
|
||||
(gnc:gnc-monetary-amount amount))))
|
||||
monetary-list
|
||||
column-totals)))
|
||||
|
||||
;; convert the buckets in the header data structure
|
||||
(define (convert-to-monetary-list bucket-list currency)
|
||||
(let* ((running-total (gnc:numeric-zero))
|
||||
(monetised-buckets
|
||||
(map (lambda (bucket-list-entry)
|
||||
(begin
|
||||
(set! running-total
|
||||
(gnc:numeric-add-fixed running-total bucket-list-entry))
|
||||
(gnc:make-gnc-monetary currency bucket-list-entry)))
|
||||
(vector->list bucket-list))))
|
||||
(append (reverse monetised-buckets)
|
||||
(list (gnc:make-gnc-monetary currency running-total)))))
|
||||
|
||||
|
||||
;; convert the collectors to the right output format
|
||||
|
||||
(define (convert-collectors collector-list report-currency
|
||||
exchange-fn
|
||||
multi-currencies-p)
|
||||
(define (fmt-one-currency collector)
|
||||
(let ((monetary (gnc:sum-collector-commodity collector report-currency exchange-fn)))
|
||||
(if monetary
|
||||
monetary
|
||||
(begin
|
||||
(gnc:warn "Exchange-lookup failed in fmt-one-currency")
|
||||
#f))))
|
||||
|
||||
(define (fmt-multiple-currencies collector)
|
||||
(let ((mini-table (gnc:make-html-table)))
|
||||
(collector 'format
|
||||
(lambda (commodity amount)
|
||||
(gnc:html-table-append-row!
|
||||
mini-table
|
||||
(list (gnc:make-gnc-monetary
|
||||
commodity amount))))
|
||||
#f)
|
||||
mini-table))
|
||||
|
||||
(let ((fmt-function
|
||||
(if multi-currencies-p
|
||||
fmt-multiple-currencies
|
||||
fmt-one-currency)))
|
||||
(map fmt-function collector-list)))
|
||||
|
||||
|
||||
(let* ((payables-account (car (op-value sect-acc opt-pay-acc)))
|
||||
(creditors (make-hash-table 23))
|
||||
|
||||
(report-title (op-value gnc:pagename-general
|
||||
gnc:optname-reportname))
|
||||
;; document will be the HTML document that we return.
|
||||
(report-date (gnc:timepair-end-day-time
|
||||
(gnc:date-option-absolute-time
|
||||
(op-value gnc:pagename-general (N_ "To")))))
|
||||
(use-description? (op-value gnc:pagename-general optname-use-description))
|
||||
(interval-vec (list->vector (make-interval-list report-date)))
|
||||
(sort-pred (get-sort-pred
|
||||
(op-value gnc:pagename-general optname-sort-by)
|
||||
(op-value gnc:pagename-general optname-sort-order)))
|
||||
(report-currency (op-value gnc:pagename-general optname-report-currency))
|
||||
(price-source (op-value gnc:pagename-general optname-price-source))
|
||||
(multi-totals-p (op-value gnc:pagename-general optname-multicurrency-totals))
|
||||
(heading-list (make-heading-list))
|
||||
(exchange-fn (gnc:case-exchange-fn price-source report-currency report-date))
|
||||
(total-collector-list (make-collector-list))
|
||||
(table (gnc:make-html-table))
|
||||
(query (gnc:malloc-query))
|
||||
(creditor-list '())
|
||||
(document (gnc:make-html-document)))
|
||||
; (gnc:debug "Payables-account: " payables-account)
|
||||
(gnc:html-document-set-title! document report-title)
|
||||
(gnc:html-table-set-col-headers! table heading-list)
|
||||
|
||||
(if payables-account
|
||||
(begin
|
||||
(setup-query query payables-account report-date)
|
||||
;; get the appropriate splits
|
||||
(let ((splits (gnc:glist->list (gnc:query-get-splits query) <gnc:Split*>)))
|
||||
; (gnc:debug "splits" splits)
|
||||
|
||||
;; build the table
|
||||
(for-each (lambda (split)
|
||||
(update-creditor-hash creditors
|
||||
split
|
||||
interval-vec
|
||||
use-description?))
|
||||
splits)
|
||||
; (gnc:debug "creditors" creditors)
|
||||
;; turn the hash into a list
|
||||
(hash-for-each (lambda (key value)
|
||||
(set! creditor-list
|
||||
(cons (cons key value) creditor-list)))
|
||||
creditors)
|
||||
; (gnc:debug "creditor list" creditor-list)
|
||||
|
||||
(set! creditor-list (sort-list! creditor-list
|
||||
sort-pred))
|
||||
|
||||
;; build the table
|
||||
(for-each (lambda (creditor-list-entry)
|
||||
(let ((monetary-list (convert-to-monetary-list
|
||||
(creditor-get-buckets
|
||||
(cdr creditor-list-entry))
|
||||
(creditor-get-currency
|
||||
(cdr creditor-list-entry)))))
|
||||
(add-to-column-totals total-collector-list monetary-list)
|
||||
(gnc:html-table-append-row!
|
||||
table (cons (car creditor-list-entry) monetary-list))))
|
||||
creditor-list)
|
||||
|
||||
;; add the totals
|
||||
(gnc:html-table-append-row!
|
||||
table
|
||||
(cons (_ "Total") (convert-collectors total-collector-list
|
||||
report-currency
|
||||
exchange-fn
|
||||
multi-totals-p)))
|
||||
|
||||
(gnc:html-document-add-object!
|
||||
document table)))
|
||||
(gnc:html-document-add-object!
|
||||
document
|
||||
(gnc:make-html-text
|
||||
"No Valid Account Selected")))
|
||||
(gnc:free-query query)
|
||||
document))
|
||||
(let* ((payables-account (car (op-value sect-acc opt-pay-acc))))
|
||||
(aging-renderer report-obj payables-account #f)))
|
||||
|
||||
;; Here we define the actual report with gnc:define-report
|
||||
(gnc:define-report
|
||||
@ -621,11 +118,11 @@ totals to report currency")
|
||||
;; The name of this report. This will be used, among other things,
|
||||
;; for making its menu item in the main menu. You need to use the
|
||||
;; untranslated value here!
|
||||
'name (N_ "Accounts Payable")
|
||||
'name (N_ "Payable Aging")
|
||||
|
||||
;; A tip that is used to provide additional information about the
|
||||
;; report to the user.
|
||||
'menu-tip (N_ "Amount owing, grouped by debtors and age.")
|
||||
'menu-tip (N_ "Amount owed, grouped by creditors and age.")
|
||||
|
||||
;; A path describing where to put the report in the menu system.
|
||||
;; In this case, it's going under the utility menu.
|
||||
|
||||
135
src/report/standard-reports/receivables.scm
Normal file
135
src/report/standard-reports/receivables.scm
Normal file
@ -0,0 +1,135 @@
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; receivables.scm : accounts receivable aging report
|
||||
;;
|
||||
;; By Derek Atkins <warlord@MIT.EDU>
|
||||
;;
|
||||
;; 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, contact:
|
||||
;;
|
||||
;; Free Software Foundation Voice: +1-617-542-5942
|
||||
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
|
||||
;; Boston, MA 02111-1307, USA gnu@gnu.org
|
||||
;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-module (gnucash report receivables))
|
||||
|
||||
(use-modules (ice-9 slib))
|
||||
(use-modules (gnucash bootstrap))
|
||||
(use-modules (gnucash gnc-module))
|
||||
|
||||
(gnc:module-load "gnucash/report/report-system" 0)
|
||||
|
||||
(use-modules (gnucash report aging))
|
||||
|
||||
(define opt-rec-acc (N_ "Receivables Account"))
|
||||
(define sect-acc (N_ "Accounts"))
|
||||
|
||||
(define (options-generator)
|
||||
(let* ((options (gnc:new-options))
|
||||
(add-option
|
||||
(lambda (new-option)
|
||||
(gnc:register-option options new-option))))
|
||||
|
||||
(add-option
|
||||
(gnc:make-account-list-option
|
||||
sect-acc opt-rec-acc
|
||||
"a" (N_ "Account where receivables are stored.")
|
||||
;; FIXME: Have a global preference for the receivables account??
|
||||
;; default-getter
|
||||
(lambda ()
|
||||
(define (find-first-receivable current-group num-accounts this-account-ind)
|
||||
(if
|
||||
(>= this-account-ind num-accounts)
|
||||
#f
|
||||
(let*
|
||||
((this-account
|
||||
(gnc:group-get-account current-group this-account-ind))
|
||||
(account-type (gw:enum-<gnc:AccountType>-val->sym
|
||||
(gnc:account-get-type this-account) #f)))
|
||||
(begin
|
||||
(gnc:debug "this-account" this-account)
|
||||
(gnc:debug "account-type" account-type)
|
||||
(if (eq? account-type 'receivable)
|
||||
(begin
|
||||
(gnc:debug "this-account selected" this-account)
|
||||
this-account)
|
||||
(find-first-receivable
|
||||
current-group num-accounts (+ this-account-ind 1)))))))
|
||||
|
||||
(let* ((current-group (gnc:get-current-group))
|
||||
(num-accounts (gnc:group-get-num-accounts
|
||||
current-group)))
|
||||
(if (> num-accounts 0)
|
||||
(let ((first-receivable (find-first-receivable
|
||||
current-group
|
||||
num-accounts
|
||||
0)))
|
||||
(gnc:debug "first-receivable" first-receivable)
|
||||
(if first-receivable
|
||||
(list first-receivable)
|
||||
(list (gnc:group-get-account current-group 0))))
|
||||
'())))
|
||||
;; value-validator
|
||||
(lambda (account-list)
|
||||
(let ((first-account) (car account-list))
|
||||
(gnc:debug "account-list" account-list)
|
||||
(if first-account
|
||||
(let ((account-type (gw:enum-<gnc:AccountType>-val->sym
|
||||
(gnc:account-get-type first-account))))
|
||||
(if (eq? 'receivable account-type)
|
||||
|
||||
(cons #t (list first-account))
|
||||
(cons #f (_ "The receivables account must be a receivable account"))))
|
||||
;; FIXME: until we can select a default account I need
|
||||
;; to catch this at the report-writing stage
|
||||
(#t '()))))
|
||||
#f))
|
||||
|
||||
(aging-options-generator options)))
|
||||
|
||||
(define (receivables-renderer report-obj)
|
||||
|
||||
(define (get-op section name)
|
||||
(gnc:lookup-option (gnc:report-options report-obj) section name))
|
||||
|
||||
(define (op-value section name)
|
||||
(gnc:option-value (get-op section name)))
|
||||
|
||||
(let* ((receivables-account (car (op-value sect-acc opt-rec-acc))))
|
||||
(aging-renderer report-obj receivables-account #t)))
|
||||
|
||||
;; Here we define the actual report with gnc:define-report
|
||||
(gnc:define-report
|
||||
|
||||
;; The version of this report.
|
||||
'version 1
|
||||
|
||||
;; The name of this report. This will be used, among other things,
|
||||
;; for making its menu item in the main menu. You need to use the
|
||||
;; untranslated value here!
|
||||
'name (N_ "Receivable Aging")
|
||||
|
||||
;; A tip that is used to provide additional information about the
|
||||
;; report to the user.
|
||||
'menu-tip (N_ "Amount owed, grouped by creditors and age.")
|
||||
|
||||
;; A path describing where to put the report in the menu system.
|
||||
;; In this case, it's going under the utility menu.
|
||||
'menu-path (list gnc:menuname-asset-liability)
|
||||
|
||||
;; The options generator function defined above.
|
||||
'options-generator options-generator
|
||||
|
||||
;; The rendering function defined above.
|
||||
'renderer receivables-renderer)
|
||||
@ -17,10 +17,11 @@
|
||||
(use-modules (gnucash report balance-sheet))
|
||||
(use-modules (gnucash report category-barchart))
|
||||
(use-modules (gnucash report net-barchart))
|
||||
(use-modules (gnucash report payables))
|
||||
(use-modules (gnucash report pnl))
|
||||
(use-modules (gnucash report portfolio))
|
||||
(use-modules (gnucash report price-scatter))
|
||||
(use-modules (gnucash report payables))
|
||||
(use-modules (gnucash report receivables))
|
||||
(use-modules (gnucash report register))
|
||||
(use-modules (gnucash report transaction))
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user