IntenseFinance/gnucash
3
0
Fork 0
mirror of https://github.com/Gnucash/gnucash.git synced 2025-02-25 18:55:30 -06:00
Code Issues Packages Projects Releases Wiki Activity

[new-aging] new receivable/payable aging reports

Browse Source
This commit is contained in:
Christopher Lam 2019-10-27 14:11:13 +08:00
parent 6eab852f1c
commit 0ef11d16e1
4 changed files with 380 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
gnucash/report/business-reports/CMakeLists.txt
View File

@ -7,6 +7,7 @@ set (business_reports_SCHEME
receipt.scm
invoice.scm
job-report.scm
new-aging.scm
owner-report.scm
payables.scm
receivables.scm

1
gnucash/report/business-reports/business-reports.scm
View File

@ -116,6 +116,7 @@
(use-modules (gnucash report receipt))
(use-modules (gnucash report owner-report))
(use-modules (gnucash report job-report))
(use-modules (gnucash report new-aging))
(use-modules (gnucash report payables))
(use-modules (gnucash report receivables))
(use-modules (gnucash report customer-summary))

377
gnucash/report/business-reports/new-aging.scm Normal file
View File

@ -0,0 +1,377 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; new-aging.scm : accounts payable/receivable aging report
;;
;; By Christopher Lam, rewrite and debug
;; By Derek Atkins <warlord@MIT.EDU> taken from the original...
;; By Robert Merkel (rgmerk@mira.net)
;; Copyright (c) 2002, 2003 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
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
;; Boston, MA 02110-1301, USA gnu@gnu.org
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (gnucash report new-aging))
(use-modules (srfi srfi-1))
(use-modules (srfi srfi-11)) ;let-values
(use-modules (gnucash utilities))
(use-modules (gnucash gnc-module))
(use-modules (gnucash gettext))
(gnc:module-load "gnucash/report/report-system" 0)
(use-modules (gnucash report standard-reports))
(use-modules (gnucash report business-reports))
(define optname-to-date (N_ "To"))
(define optname-sort-order (N_ "Sort Order"))
(define optname-report-currency (N_ "Report's currency"))
(define optname-price-source (N_ "Price Source"))
(define optname-show-zeros (N_ "Show zero balance items"))
(define optname-date-driver (N_ "Due or Post Date"))
(define no-APAR-account (_ "No valid A/Payable or A/Receivable \
account found. Please ensure valid AP/AR account exists."))
(define empty-APAR-accounts (_ "A/Payable or A/Receivable accounts \
exist but have no suitable transactions."))
(define num-buckets 6)
(define (setup-query query accounts date)
(qof-query-set-book query (gnc-get-current-book))
(gnc:query-set-match-non-voids-only! query (gnc-get-current-book))
(xaccQueryAddAccountMatch query accounts QOF-GUID-MATCH-ANY QOF-QUERY-AND)
(xaccQueryAddDateMatchTT query #f 0 #t date QOF-QUERY-AND)
(qof-query-set-sort-order query (list SPLIT-TRANS TRANS-DATE-POSTED) '() '())
(qof-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")
;; Use a default report date of 'today'
(gnc:option-set-default-value
(gnc:lookup-option options gnc:pagename-general optname-to-date)
(cons 'relative 'today))
(add-option
(gnc:make-multichoice-option
gnc:pagename-general optname-sort-order "ia" (N_ "Sort order.") 'increasing
(list
(vector 'increasing (N_ "Increasing") (N_ "Alphabetical order"))
(vector 'decreasing (N_ "Decreasing") (N_ "Reverse alphabetical order")))))
(add-option
(gnc:make-simple-boolean-option
gnc:pagename-general optname-show-zeros "j"
(N_ "Show all vendors/customers even if they have a zero balance.")
#f))
(add-option
(gnc:make-multichoice-option
gnc:pagename-general optname-date-driver "k" (N_ "Leading date.") 'duedate
(list
;; Should be using standard label for due date?
(vector 'duedate
(N_ "Due Date")
(N_ "Due date is leading."))
;; Should be using standard label for post date?
(vector 'postdate
(N_ "Post Date")
(N_ "Post date is leading.")))))
(gnc:options-set-default-section options "General")
options))
(define (make-interval-list to-date)
(let* ((begindate to-date)
(begindate (decdate begindate ThirtyDayDelta))
(begindate (decdate begindate ThirtyDayDelta))
(begindate (decdate begindate ThirtyDayDelta)))
(gnc:make-date-list begindate to-date ThirtyDayDelta)))
;; Have make-list create a stepped list, then add a date in the future
;; for the "current" bucket
(define (make-extended-interval-list to-date)
(append (make-interval-list to-date)
(list +inf.0)))
(define (txn-is-invoice? txn)
(eqv? (xaccTransGetTxnType txn) TXN-TYPE-INVOICE))
(define (txn-is-payment? txn)
(eqv? (xaccTransGetTxnType txn) TXN-TYPE-PAYMENT))
(define (gnc-owner-equal? a b)
(string=? (gncOwnerReturnGUID a) (gncOwnerReturnGUID b)))
(define (split-has-owner? split owner)
(let* ((split-owner (split->owner split))
(retval (gnc-owner-equal? split-owner owner)))
(gncOwnerFree split-owner)
retval))
(define (split-from-acct? split acct)
(equal? acct (xaccSplitGetAccount split)))
(define (list-split lst fn cmp)
(let-values (((list-yes list-no) (partition (lambda (elt) (fn elt cmp)) lst)))
(cons list-yes list-no)))
;; simpler version of gnc:owner-from-split. must be gncOwnerFree after
;; use! see split-has-owner? above...
(define (split->owner split)
(let* ((lot (xaccSplitGetLot (gnc-lot-get-earliest-split (xaccSplitGetLot split))))
(owner (gncOwnerNew))
(use-lot-owner? (gncOwnerGetOwnerFromLot lot owner)))
(unless use-lot-owner?
(gncOwnerCopy (gncOwnerGetEndOwner
(gncInvoiceGetOwner (gncInvoiceGetInvoiceFromLot lot)))
owner))
owner))
(define (owner-splits->aging-list splits to-date date-type receivable)
(gnc:debug 'processing: (qof-print-date to-date) date-type 'receivable receivable)
(for-each gnc:debug splits)
(let ((bucket-dates (make-extended-interval-list to-date))
(buckets (make-vector num-buckets 0)))
(define (addbucket! idx amt)
(vector-set! buckets idx (+ amt (vector-ref buckets idx))))
(let lp ((splits splits))
(cond
((null? splits)
(vector->list buckets))
;; next split is an invoice posting split. note we don't need
;; to handle invoice payments because these payments will
;; reduce the lot balance automatically.
((txn-is-invoice? (xaccSplitGetParent (car splits)))
(let* ((lot (gncInvoiceGetPostedLot
(gncInvoiceGetInvoiceFromTxn
(xaccSplitGetParent (car splits)))))
(invoice (gncInvoiceGetInvoiceFromLot lot))
(bal (gnc-lot-get-balance lot))
(bal (if receivable bal (- bal)))
(date (if (eq? date-type 'postdate)
(gncInvoiceGetDatePosted invoice)
(gncInvoiceGetDateDue invoice))))
(gnc:pk 'next=invoice (car splits) invoice bal)
(let loop ((idx 0)
(bucket-dates bucket-dates))
(gnc:debug idx buckets bal invoice date)
(if (< date (car bucket-dates))
(addbucket! idx bal)
(loop (1+ idx) (cdr bucket-dates))))
(gnc:debug '* buckets bal invoice date))
(lp (cdr splits)))
;; next split is a prepayment
((and (txn-is-payment? (xaccSplitGetParent (car splits)))
(null? (gncInvoiceGetInvoiceFromLot (xaccSplitGetLot (car splits)))))
(let* ((prepay (xaccSplitGetAmount (car splits)))
(prepay (if receivable prepay (- prepay))))
(gnc:pk 'next=prepay (car splits) prepay)
(addbucket! (1- num-buckets) prepay))
(lp (cdr splits)))
;; not invoice/prepayment. regular or payment split.
(else
(gnc:pk 'next=skipped (car splits))
(lp (cdr splits)))))))
(define (aging-renderer report-obj receivable)
(define (op-value section name)
(gnc:option-value
(gnc:lookup-option (gnc:report-options report-obj) section name)))
(define make-heading-list
(list ""
(_ "Company")
(_ "Prepayments")
(_ "Current")
(_ "0-30 days")
(_ "31-60 days")
(_ "61-90 days")
(_ "91+ days")
(_ "Total")))
(let* ((type (if receivable ACCT-TYPE-RECEIVABLE ACCT-TYPE-PAYABLE))
(accounts (filter (lambda (acc) (eqv? (xaccAccountGetType acc) type))
(gnc-account-get-descendants-sorted
(gnc-get-current-root-account))))
(report-title (op-value gnc:pagename-general gnc:optname-reportname))
(report-date (gnc:time64-end-day-time
(gnc:date-option-absolute-time
(op-value gnc:pagename-general optname-to-date))))
(sort-order (op-value gnc:pagename-general optname-sort-order))
(show-zeros (op-value gnc:pagename-general optname-show-zeros))
(date-type (op-value gnc:pagename-general optname-date-driver))
(query (qof-query-create-for-splits))
(document (gnc:make-html-document)))
;; for sorting and delete-duplicates. compare GUIDs
(define (ownerGUID<? a b)
(string<? (gncOwnerGetGUID a) (gncOwnerGetGUID b)))
;; for presentation. compare names.
(define (owner<? a b)
((if (eq? sort-order 'increasing) string<? string>?)
(gncOwnerGetName a) (gncOwnerGetName b)))
;; set default title
(gnc:html-document-set-title! document report-title)
(cond
((null? accounts)
(gnc:html-document-add-object!
document (gnc:make-html-text no-APAR-account)))
(else
(setup-query query accounts report-date)
(let* ((splits (qof-query-run query))
(accounts (sort-and-delete-duplicates (map xaccSplitGetAccount splits)
gnc:account-path-less-p equal?))
(table (gnc:make-html-table)))
(qof-query-destroy query)
;; loop into each APAR account
(let loop ((accounts accounts)
(splits (filter
(lambda (split)
(or (txn-is-invoice? (xaccSplitGetParent split))
(txn-is-payment? (xaccSplitGetParent split))))
splits)))
(cond
((null? accounts)
(gnc:html-table-set-col-headers! table make-heading-list)
(gnc:html-document-add-object!
document (if (null? (gnc:html-table-data table))
(gnc:make-html-text empty-APAR-accounts)
table)))
(else
(let* ((account (car accounts))
(comm (xaccAccountGetCommodity account))
(splits-acc-others (list-split splits split-from-acct? account))
(acc-splits (car splits-acc-others))
(other-acc-splits (cdr splits-acc-others)))
(gnc:debug 'account account)
(gnc:html-table-append-row!
table (list (gnc:make-html-table-cell/size
1 (+ 2 num-buckets) (xaccAccountGetName account))))
(let* ((split-owners (map split->owner acc-splits))
(acc-owners (sort (sort-and-delete-duplicates
split-owners ownerGUID<? gnc-owner-equal?)
owner<?)))
(gnc:debug 'owners acc-owners)
;; loop into each APAR account split
(let lp ((acc-owners acc-owners)
(acc-splits acc-splits)
(acc-totals (make-list (1+ num-buckets) 0)))
(cond
((null? acc-owners)
(for-each gncOwnerFree split-owners)
(gnc:html-table-append-row!
table
(cons* #f
(gnc:make-html-table-cell/markup
"total-label-cell" (_ "Total"))
(map
(lambda (amt)
(gnc:make-html-table-cell/markup
"total-number-cell" (gnc:make-gnc-monetary comm amt)))
acc-totals)))
(loop (cdr accounts)
other-acc-splits))
(else
(let* ((owner (car acc-owners))
(splits-own-others (list-split acc-splits split-has-owner?
owner))
(owner-splits (car splits-own-others))
(other-owner-splits (cdr splits-own-others))
(aging (owner-splits->aging-list
owner-splits report-date date-type receivable))
(aging-total (apply + aging)))
(when (or show-zeros (not (every zero? aging)))
(gnc:html-table-append-row!
table
(append
(list #f)
(cons
(gnc:make-html-text
(gnc:html-markup-anchor
(gnc:owner-anchor-text owner)
(gncOwnerGetName owner)))
(map
(lambda (amt)
(gnc:make-html-table-cell/markup
"number-cell" (gnc:make-gnc-monetary comm amt)))
(reverse aging)))
(list
(gnc:make-html-table-cell/markup
"number-cell"
(gnc:make-html-text
(gnc:html-markup-anchor
(gnc:owner-report-text owner account)
(gnc:make-gnc-monetary comm aging-total))))))))
(lp (cdr acc-owners)
other-owner-splits
(map + acc-totals
(reverse (cons aging-total aging))))))))))))))))
(gnc:report-finished)
document))
(define (payable-options-generator)
(aging-options-generator (gnc:new-options)))
(define (receivable-options-generator)
(aging-options-generator (gnc:new-options)))
(define (payables-renderer report-obj)
(aging-renderer report-obj #f))
(define (receivables-renderer report-obj)
(aging-renderer report-obj #t))
(gnc:define-report
'version 1
'name (N_ "Payable Aging (beta)")
'report-guid "e57770f2dbca46619d6dac4ac5469b50-new"
'menu-path (list gnc:menuname-experimental)
'options-generator payable-options-generator
'renderer payables-renderer
'in-menu? #t)
(gnc:define-report
'version 1
'name (N_ "Receivable Aging (beta)")
'report-guid "9cf76bed17f14401b8e3e22d0079cb98-new"
'menu-path (list gnc:menuname-experimental)
'options-generator receivable-options-generator
'renderer receivables-renderer
'in-menu? #t)

1
po/POTFILES.in
View File

@ -418,6 +418,7 @@ gnucash/report/business-reports/business-reports.scm
gnucash/report/business-reports/customer-summary.scm
gnucash/report/business-reports/invoice.scm
gnucash/report/business-reports/job-report.scm
gnucash/report/business-reports/new-aging.scm
gnucash/report/business-reports/owner-report.scm
gnucash/report/business-reports/payables.scm
gnucash/report/business-reports/receipt.eguile.scm