;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; qif-to-gnc.scm ;;; this is where QIF transactions are transformed into a ;;; Gnucash account tree. ;;; ;;; Copyright 2000-2001 Bill Gribble ;;; $Id: qif-to-gnc.scm,v 1.11 2003/01/17 03:18:31 warlord Exp $ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; find-or-make-acct: ;; given a colon-separated account path, return an Account* to ;; an existing or new account. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (qif-import:find-or-make-acct acct-info check-types? commodity check-commodity? default-currency gnc-acct-hash old-group new-group) (let* ((separator (string-ref (gnc:account-separator-char) 0)) (gnc-name (qif-map-entry:gnc-name acct-info)) (existing-account (hash-ref gnc-acct-hash gnc-name)) (same-gnc-account (gnc:get-account-from-full-name old-group gnc-name separator)) (allowed-types (qif-map-entry:allowed-types acct-info)) (make-new-acct #f) (incompatible-acct #f)) (define (compatible? account) (let ((acc-type (gnc:account-get-type account)) (acc-commodity (gnc:account-get-commodity account))) (and (if check-types? (and (list? allowed-types) (memv acc-type allowed-types)) #t) (if check-commodity? (gnc:commodity-equiv? acc-commodity commodity) #t)))) (define (make-unique-name-variant long-name short-name) (if (gnc:get-account-from-full-name old-group long-name separator) (let loop ((count 2)) (let* ((test-name (string-append long-name (sprintf #f " %a" count))) (test-acct (gnc:get-account-from-full-name old-group test-name separator))) (if (and test-acct (not (compatible? test-acct))) (loop (+ 1 count)) (string-append short-name (sprintf #f " %a" count))))) short-name)) ;; just because we found an account doesn't mean we can use it. ;; if the name is in use but the commodity, or type are ;; incompatible, we need to create a new account with a modified ;; name. (if same-gnc-account (if (compatible? same-gnc-account) (begin ;; everything is ok, so we can just use the same ;; account. Make sure we make the same type. (set! make-new-acct #f) (set! incompatible-acct #f) (set! allowed-types (list (gnc:account-get-type same-gnc-account)))) (begin ;; there's an existing account with that name, so we ;; have to make a new acct with different properties and ;; something to indicate that it's different (set! make-new-acct #t) (set! incompatible-acct #t))) (begin ;; otherwise, there is no existing account with the same ;; name. (set! make-new-acct #t) (set! incompatible-acct #f))) ;; here, existing-account means a previously *created* account ;; (possibly a new account, possibly a copy of an existing gnucash ;; acct) (if (and existing-account (compatible? existing-account)) existing-account (let ((new-acct (gnc:malloc-account (gnc:get-current-book))) (parent-acct #f) (parent-name #f) (acct-name #f) (last-colon #f)) (set! last-colon (string-rindex gnc-name separator)) (gnc:account-begin-edit new-acct) ;; if this is a copy of an existing gnc account, copy the ;; account properties. For incompatible existing accts, ;; we'll do something different later. (if same-gnc-account (begin (gnc:account-set-name new-acct (gnc:account-get-name same-gnc-account)) (gnc:account-set-description new-acct (gnc:account-get-description same-gnc-account)) (gnc:account-set-type new-acct (gnc:account-get-type same-gnc-account)) (gnc:account-set-commodity new-acct (gnc:account-get-commodity same-gnc-account)) (gnc:account-set-notes new-acct (gnc:account-get-notes same-gnc-account)) (gnc:account-set-code new-acct (gnc:account-get-code same-gnc-account)))) ;; make sure that if this is a nested account foo:bar:baz, ;; foo:bar and foo exist also. (if last-colon (begin (set! parent-name (substring gnc-name 0 last-colon)) (set! acct-name (substring gnc-name (+ 1 last-colon) (string-length gnc-name)))) (begin (set! acct-name gnc-name))) ;; if this is a new account, use the ;; parameters passed in (if make-new-acct (begin ;; set the name, description, etc. (gnc:account-set-name new-acct acct-name) (if (qif-map-entry:description acct-info) (gnc:account-set-description new-acct (qif-map-entry:description acct-info))) (gnc:account-set-commodity new-acct commodity) ;; if it's an incompatible account, set the ;; name to be unique, and a description that ;; hints what's happening (if incompatible-acct (let ((new-name (make-unique-name-variant gnc-name acct-name))) (gnc:account-set-name new-acct new-name) (gnc:account-set-description new-acct (_ "QIF import: Name conflict with another account.")))) ;; set the account type. this could be smarter. (if (qif-map-entry:allowed-types acct-info) (gnc:account-set-type new-acct (car (qif-map-entry:allowed-types acct-info)))))) (gnc:account-commit-edit new-acct) (if last-colon (let ((pinfo (make-qif-map-entry))) (qif-map-entry:set-qif-name! pinfo parent-name) (qif-map-entry:set-gnc-name! pinfo parent-name) (qif-map-entry:set-allowed-types! acct-info (list (gnc:account-get-type new-acct))) (qif-map-entry:set-allowed-types! pinfo (qif-map-entry:allowed-parent-types acct-info)) (set! parent-acct (qif-import:find-or-make-acct pinfo #t default-currency #f default-currency gnc-acct-hash old-group new-group)))) (if parent-acct (gnc:account-insert-subaccount parent-acct new-acct) (gnc:group-insert-account new-group new-acct)) (hash-set! gnc-acct-hash gnc-name new-acct) new-acct)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; qif-import:qif-to-gnc ;; this is the top-level of the back end conversion from ;; QIF to GNC. all the account mappings and so on should be ;; done before this is called. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (qif-import:qif-to-gnc qif-files-list qif-acct-map qif-cat-map qif-memo-map stock-map default-currency-name) (gnc:backtrace-if-exception (lambda () (let* ((old-group (gnc:get-current-group)) (new-group (gnc:malloc-account-group (gnc:get-current-book))) (gnc-acct-hash (make-hash-table 20)) (separator (string-ref (gnc:account-separator-char) 0)) (default-currency (gnc:commodity-table-find-full (gnc:book-get-commodity-table (gnc:get-current-book)) GNC_COMMODITY_NS_ISO default-currency-name)) (sorted-accounts-list '()) (markable-xtns '()) (sorted-qif-files-list (sort qif-files-list (lambda (a b) (> (length (qif-file:xtns a)) (length (qif-file:xtns b)))))) (progress-dialog #f) (work-to-do 0) (work-done 0)) ;; first, build a local account tree that mirrors the gnucash ;; accounts in the mapping data. we need to iterate over the ;; cat-map and the acct-map to build the list (hash-fold (lambda (k v p) (if (qif-map-entry:display? v) (set! sorted-accounts-list (cons v sorted-accounts-list))) #t) #t qif-acct-map) (hash-fold (lambda (k v p) (if (qif-map-entry:display? v) (set! sorted-accounts-list (cons v sorted-accounts-list))) #t) #t qif-cat-map) (hash-fold (lambda (k v p) (if (qif-map-entry:display? v) (set! sorted-accounts-list (cons v sorted-accounts-list))) #t) #t qif-memo-map) ;; sort the account info on the depth of the account path. if a ;; short part is explicitly mentioned, make sure it gets created ;; before the deeper path, which will create the parent accounts ;; without the information about their type. (set! sorted-accounts-list (sort sorted-accounts-list (lambda (a b) (let ((a-depth (length (string-split (qif-map-entry:gnc-name a) separator))) (b-depth (length (string-split (qif-map-entry:gnc-name b) separator)))) (< a-depth b-depth))))) ;; make all the accounts (for-each (lambda (acctinfo) (let* ((security (and stock-map (hash-ref stock-map (qif-import:get-account-name (qif-map-entry:qif-name acctinfo))))) (ok-types (qif-map-entry:allowed-types acctinfo)) (equity? (memv GNC-EQUITY-TYPE ok-types)) (stock? (or (memv GNC-STOCK-TYPE ok-types) (memv GNC-MUTUAL-TYPE ok-types)))) ;; Debug ;; (for-each ;; (lambda (expr) ;; (display expr)) ;; (list "Account: " acctinfo "\nsecurity = " security ;; "\nequity? = " equity? ;; "\n")) (cond ((and equity? security) ;; a "retained holdings" acct (qif-import:find-or-make-acct acctinfo #f security #t default-currency gnc-acct-hash old-group new-group)) ((and security (or stock? (gnc:commodity-is-currency? security))) (qif-import:find-or-make-acct acctinfo #f security #t default-currency gnc-acct-hash old-group new-group)) (#t (qif-import:find-or-make-acct acctinfo #f default-currency #t default-currency gnc-acct-hash old-group new-group))))) sorted-accounts-list) ;; before trying to mark transactions, prune down the list of ;; ones to match. (for-each (lambda (qif-file) (for-each (lambda (xtn) (set! work-to-do (+ 1 work-to-do)) (let splitloop ((splits (qif-xtn:splits xtn))) (if (qif-split:category-is-account? (car splits)) (begin (set! markable-xtns (cons xtn markable-xtns)) (set! work-to-do (+ 1 work-to-do))) (if (not (null? (cdr splits))) (splitloop (cdr splits)))))) (qif-file:xtns qif-file))) qif-files-list) (if (> work-to-do 100) (begin (set! progress-dialog (gnc:progress-dialog-new #f #f)) (gnc:progress-dialog-set-title progress-dialog (_ "Progress")) (gnc:progress-dialog-set-heading progress-dialog (_ "Importing transactions...")) (gnc:progress-dialog-set-limits progress-dialog 0.0 100.0))) ;; now run through the markable transactions marking any ;; duplicates. marked transactions/splits won't get imported. (if (> (length markable-xtns) 1) (let xloop ((xtn (car markable-xtns)) (rest (cdr markable-xtns))) (set! work-done (+ 1 work-done)) (if progress-dialog (begin (gnc:progress-dialog-set-value progress-dialog (* 100 (/ work-done work-to-do))) (gnc:progress-dialog-update progress-dialog))) (if (not (qif-xtn:mark xtn)) (qif-import:mark-matching-xtns xtn rest)) (if (not (null? (cdr rest))) (xloop (car rest) (cdr rest))))) ;; iterate over files. Going in the sort order by number of ;; transactions should give us a small speed advantage. (for-each (lambda (qif-file) (for-each (lambda (xtn) (set! work-done (+ 1 work-done)) (if progress-dialog (begin (gnc:progress-dialog-set-value progress-dialog (* 100 (/ work-done work-to-do))) (gnc:progress-dialog-update progress-dialog))) (if (not (qif-xtn:mark xtn)) (begin ;; create and fill in the GNC transaction (let ((gnc-xtn (gnc:transaction-create (gnc:get-current-book)))) (gnc:transaction-begin-edit gnc-xtn) ;; FIXME. This is probably wrong (gnc:transaction-set-currency gnc-xtn (gnc:default-currency)) ;; build the transaction (qif-import:qif-xtn-to-gnc-xtn xtn qif-file gnc-xtn gnc-acct-hash qif-acct-map qif-cat-map qif-memo-map) ;; rebalance and commit everything (gnc:transaction-commit-edit gnc-xtn))))) (qif-file:xtns qif-file))) sorted-qif-files-list) ;; get rid of the progress dialog (if progress-dialog (gnc:progress-dialog-destroy progress-dialog)) new-group)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; qif-import:qif-xtn-to-gnc-xtn ;; translate a single transaction to a set of gnucash splits and ;; a gnucash transaction structure. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (qif-import:qif-xtn-to-gnc-xtn qif-xtn qif-file gnc-xtn gnc-acct-hash qif-acct-map qif-cat-map qif-memo-map) (let ((splits (qif-xtn:splits qif-xtn)) (gnc-near-split (gnc:split-create (gnc:get-current-book))) (near-split-total (gnc:numeric-zero)) (near-acct-info #f) (near-acct-name #f) (near-acct #f) (qif-payee (qif-xtn:payee qif-xtn)) (qif-number (qif-xtn:number qif-xtn)) (qif-action (qif-xtn:action qif-xtn)) (qif-security (qif-xtn:security-name qif-xtn)) (qif-memo (qif-split:memo (car (qif-xtn:splits qif-xtn)))) (qif-from-acct (qif-xtn:from-acct qif-xtn)) (qif-cleared (qif-xtn:cleared qif-xtn)) (n- (lambda (n) (gnc:numeric-neg n))) (nsub (lambda (a b) (gnc:numeric-sub a b 0 GNC-DENOM-LCD))) (n+ (lambda (a b) (gnc:numeric-add a b 0 GNC-DENOM-LCD))) (n* (lambda (a b) (gnc:numeric-mul a b 0 GNC-DENOM-REDUCE))) (n/ (lambda (a b) (gnc:numeric-div a b 0 GNC-DENOM-REDUCE)))) ;; set properties of the whole transaction (apply gnc:transaction-set-date gnc-xtn (qif-xtn:date qif-xtn)) ;; fixme: bug #105 (if qif-payee (gnc:transaction-set-description gnc-xtn qif-payee)) (if qif-number (gnc:transaction-set-xnum gnc-xtn qif-number)) (if qif-memo (begin (gnc:split-set-memo gnc-near-split qif-memo) (if (or (not qif-payee) (equal? qif-payee "")) (gnc:transaction-set-description gnc-xtn qif-memo)))) (if (eq? qif-cleared 'cleared) (gnc:split-set-reconcile gnc-near-split #\c)) (if (eq? qif-cleared 'reconciled) (gnc:split-set-reconcile gnc-near-split #\y)) (if (not qif-security) (begin ;; NON-STOCK TRANSACTIONS: the near account is the current ;; bank-account or the default associated with the file. ;; the far account is the one associated with the split ;; category. (set! near-acct-info (hash-ref qif-acct-map qif-from-acct)) (set! near-acct-name (qif-map-entry:gnc-name near-acct-info)) (set! near-acct (hash-ref gnc-acct-hash near-acct-name)) ;; iterate over QIF splits. Each split defines one "far ;; end" for the transaction. (for-each (lambda (qif-split) (if (not (qif-split:mark qif-split)) (let ((gnc-far-split (gnc:split-create (gnc:get-current-book))) (far-acct-info #f) (far-acct-name #f) (far-acct-type #f) (far-acct #f) (split-amt (qif-split:amount qif-split)) (memo (qif-split:memo qif-split)) (cat (qif-split:category qif-split))) (if (not split-amt) (set! split-amt (gnc:numeric-zero))) ;; fill the splits in (near first). This handles ;; files in multiple currencies by pulling the ;; currency value from the file import. (set! near-split-total (n+ near-split-total split-amt)) (gnc:split-set-value gnc-far-split (n- split-amt)) (gnc:split-set-amount gnc-far-split (n- split-amt)) (if memo (gnc:split-set-memo gnc-far-split memo)) ;; figure out what the far acct is (cond ;; if the category is valid, use that. look it up ;; in the acct-hash if it's an account. ((and (not (string=? cat "")) (qif-split:category-is-account? qif-split)) (set! far-acct-info (hash-ref qif-acct-map cat))) ;; .. look it up in the cat-hash if it's a category ((not (string=? cat "")) (set! far-acct-info (hash-ref qif-cat-map cat))) ;; otherwise, try to find the payee in the ;; memo-map if it's likely to have been used (only ;; 1 split). then try the memo. if neither ;; works, go back to the Unspecified account. (#t (set! far-acct-info (or (and (string? qif-payee) (not (string=? qif-payee "")) (= (length splits) 1) (hash-ref qif-memo-map qif-payee)) (and (string? memo) (not (string=? memo "")) (hash-ref qif-memo-map memo)))) (if (not far-acct-info) (set! far-acct-info (hash-ref qif-cat-map cat))))) (set! far-acct-name (qif-map-entry:gnc-name far-acct-info)) (set! far-acct (hash-ref gnc-acct-hash far-acct-name)) ;; set the reconcile status. (let ((cleared (qif-split:matching-cleared qif-split))) (if (eq? 'cleared cleared) (gnc:split-set-reconcile gnc-far-split #\c)) (if (eq? 'reconciled cleared) (gnc:split-set-reconcile gnc-far-split #\y))) ;; finally, plug the split into the account (gnc:account-insert-split far-acct gnc-far-split) (gnc:transaction-append-split gnc-xtn gnc-far-split)))) splits) ;; the value of the near split is the total of the far splits. (gnc:split-set-value gnc-near-split near-split-total) (gnc:split-set-amount gnc-near-split near-split-total) (gnc:transaction-append-split gnc-xtn gnc-near-split) (gnc:account-insert-split near-acct gnc-near-split)) ;; STOCK TRANSACTIONS: the near/far accounts depend on the ;; "action" encoded in the Number field. It's generally the ;; security account (for buys, sells, and reinvests) but can ;; also be an interest, dividend, or SG/LG account. (let* ((share-price (qif-xtn:share-price qif-xtn)) (num-shares (qif-xtn:num-shares qif-xtn)) (split-amt #f) (xtn-amt (qif-split:amount (car (qif-xtn:splits qif-xtn)))) (qif-accts #f) (qif-near-acct #f) (qif-far-acct #f) (qif-commission-acct #f) (far-acct-info #f) (far-acct-name #f) (far-acct #f) (commission-acct #f) (commission-amt (qif-xtn:commission qif-xtn)) (commission-split #f) (defer-share-price #f) (gnc-far-split (gnc:split-create (gnc:get-current-book)))) (if (not num-shares) (set! num-shares (gnc:numeric-zero))) (if (not share-price) (set! share-price (gnc:numeric-zero))) (if (not split-amt) (set! split-amt (n* num-shares share-price))) ;; I don't think this should ever happen, but I want ;; to keep this check just in case. (if (> (length splits) 1) (begin (display "qif-import:qif-xtn-to-gnc-xtn : ") (display "splits in stock transaction!") (newline))) (set! qif-accts (qif-split:accounts-affected (car (qif-xtn:splits qif-xtn)) qif-xtn)) (set! qif-near-acct (car qif-accts)) (set! qif-far-acct (cadr qif-accts)) (set! qif-commission-acct (caddr qif-accts)) ;; translate the QIF account names into Gnucash accounts (if (and qif-near-acct qif-far-acct) (begin (set! near-acct-info (or (hash-ref qif-acct-map qif-near-acct) (hash-ref qif-cat-map qif-near-acct))) (set! near-acct-name (qif-map-entry:gnc-name near-acct-info)) (set! near-acct (hash-ref gnc-acct-hash near-acct-name)) (set! far-acct-info (or (hash-ref qif-acct-map qif-far-acct) (hash-ref qif-cat-map qif-far-acct))) (set! far-acct-name (qif-map-entry:gnc-name far-acct-info)) (set! far-acct (hash-ref gnc-acct-hash far-acct-name)))) ;; the amounts and signs: are shares going in or out? ;; are amounts currency or shares? (case qif-action ((buy buyx reinvint reinvdiv reinvsg reinvsh reinvmd reinvlg) (if (not share-price) (set! share-price (gnc:numeric-zero))) (gnc:split-set-amount gnc-near-split num-shares) (gnc:split-set-value gnc-near-split split-amt) (gnc:split-set-value gnc-far-split (n- xtn-amt)) (gnc:split-set-amount gnc-far-split (n- xtn-amt))) ((sell sellx) (if (not share-price) (set! share-price (gnc:numeric-zero))) (gnc:split-set-amount gnc-near-split (n- num-shares)) (gnc:split-set-value gnc-near-split (n- split-amt)) (gnc:split-set-value gnc-far-split xtn-amt) (gnc:split-set-amount gnc-far-split xtn-amt)) ((cgshort cgshortx cgmid cgmidx cglong cglongx intinc intincx div divx miscinc miscincx xin rtrncap rtrncapx) (gnc:split-set-value gnc-near-split xtn-amt) (gnc:split-set-amount gnc-near-split xtn-amt) (gnc:split-set-value gnc-far-split (n- xtn-amt)) (gnc:split-set-amount gnc-far-split (n- xtn-amt))) ((xout miscexp miscexpx margint margintx) (gnc:split-set-value gnc-near-split (n- xtn-amt)) (gnc:split-set-amount gnc-near-split (n- xtn-amt)) (gnc:split-set-value gnc-far-split xtn-amt) (gnc:split-set-amount gnc-far-split xtn-amt)) ((shrsin) ;; getting rid of the old equity-acct-per-stock trick. ;; you must now have a cash/basis value for the stock. (gnc:split-set-amount gnc-near-split num-shares) (gnc:split-set-value gnc-near-split split-amt) (gnc:split-set-value gnc-far-split (n- xtn-amt)) (gnc:split-set-amount gnc-far-split (n- xtn-amt))) ((shrsout) ;; shrsout is like shrsin (gnc:split-set-amount gnc-near-split (n- num-shares)) (gnc:split-set-value gnc-near-split (n- split-amt)) (gnc:split-set-value gnc-far-split xtn-amt) (gnc:split-set-amount gnc-far-split xtn-amt)) ;; stock splits: QIF just specifies the split ratio, not ;; the number of shares in and out, so we have to fetch ;; the number of shares from the security account ;; FIXME : this could be wrong. Make sure the ;; share-amount is at the correct time. ((stksplit) (let* ((splitratio (n/ num-shares (gnc:numeric-create 10 1))) (in-shares (gnc:account-get-balance near-acct)) (out-shares (n* in-shares splitratio))) (gnc:split-set-amount gnc-near-split out-shares) (gnc:split-set-amount gnc-far-split (n- in-shares)) (gnc:split-set-value gnc-near-split (n- split-amt)) (gnc:split-set-value gnc-far-split split-amt)))) (let ((cleared (qif-split:matching-cleared (car (qif-xtn:splits qif-xtn))))) (if (eq? 'cleared cleared) (gnc:split-set-reconcile gnc-far-split #\c)) (if (eq? 'reconciled cleared) (gnc:split-set-reconcile gnc-far-split #\y))) (if qif-commission-acct (let* ((commission-acct-info (or (hash-ref qif-acct-map qif-commission-acct) (hash-ref qif-cat-map qif-commission-acct))) (commission-acct-name (qif-map-entry:gnc-name commission-acct-info))) (set! commission-acct (hash-ref gnc-acct-hash commission-acct-name)))) (if (and commission-amt commission-acct) (begin (set! commission-split (gnc:split-create (gnc:get-current-book))) (gnc:split-set-value commission-split commission-amt) (gnc:split-set-amount commission-split commission-amt))) (if (and qif-near-acct qif-far-acct) (begin (gnc:transaction-append-split gnc-xtn gnc-near-split) (gnc:account-insert-split near-acct gnc-near-split) (gnc:transaction-append-split gnc-xtn gnc-far-split) (gnc:account-insert-split far-acct gnc-far-split) (if commission-split (begin (gnc:transaction-append-split gnc-xtn commission-split) (gnc:account-insert-split commission-acct commission-split))))))) ;; return the modified transaction (though it's ignored). gnc-xtn)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; qif-import:mark-matching-xtns ;; find transactions that are the "opposite half" of xtn and ;; mark them so they won't be imported. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (qif-import:mark-matching-xtns xtn candidate-xtns) (let splitloop ((splits-left (qif-xtn:splits xtn))) ;; splits-left starts out as all the splits of this transaction. ;; if multiple splits match up with a single split on the other ;; end, we may remove more than one split from splits-left with ;; each call to mark-some-splits. (if (not (null? splits-left)) (if (and (not (qif-split:mark (car splits-left))) (qif-split:category-is-account? (car splits-left))) (set! splits-left (qif-import:mark-some-splits splits-left xtn candidate-xtns)) (set! splits-left (cdr splits-left)))) (if (not (null? splits-left)) (splitloop splits-left)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; qif-import:mark-some-splits ;; find split(s) matching elements of splits and mark them so they ;; don't get imported. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (qif-import:mark-some-splits splits xtn candidate-xtns) (let* ((n- (lambda (n) (gnc:numeric-neg n))) (nsub (lambda (a b) (gnc:numeric-sub a b 0 GNC-DENOM-LCD))) (n+ (lambda (a b) (gnc:numeric-add a b 0 GNC-DENOM-LCD))) (n* (lambda (a b) (gnc:numeric-mul a b 0 GNC-DENOM-REDUCE))) (n/ (lambda (a b) (gnc:numeric-div a b 0 GNC-DENOM-REDUCE))) (split (car splits)) (near-acct-name #f) (far-acct-name #f) (date (qif-xtn:date xtn)) (amount (n- (qif-split:amount split))) (group-amount #f) (memo (qif-split:memo split)) (security-name (qif-xtn:security-name xtn)) (action (qif-xtn:action xtn)) (bank-xtn? (not security-name)) (cleared? #f) (different-acct-splits '()) (same-acct-splits '()) (how #f) (done #f)) (if bank-xtn? (begin (set! near-acct-name (qif-xtn:from-acct xtn)) (set! far-acct-name (qif-split:category split)) (set! group-amount (gnc:numeric-zero)) ;; group-amount is the sum of all the splits in this xtn ;; going to the same account as 'split'. We might be able ;; to match this whole group to a single matching opposite ;; split. (for-each (lambda (s) (if (and (qif-split:category-is-account? s) (string=? far-acct-name (qif-split:category s))) (begin (set! same-acct-splits (cons s same-acct-splits)) (set! group-amount (nsub group-amount (qif-split:amount s)))) (set! different-acct-splits (cons s different-acct-splits)))) splits) (set! same-acct-splits (reverse same-acct-splits)) (set! different-acct-splits (reverse different-acct-splits))) ;; stock transactions. they can't have splits as far as I can ;; tell, so the 'different-acct-splits' is always '() (let ((qif-accts (qif-split:accounts-affected split xtn))) (set! near-acct-name (car qif-accts)) (set! far-acct-name (cadr qif-accts)) (set! same-acct-splits (list split)) (if action ;; we need to do some special massaging to get ;; transactions to match up. Quicken thinks the near ;; and far accounts are different than we do. (case action ((intincx divx cglongx cgmidx cgshortx rtrncapx margintx sellx) (set! amount (n- amount)) (set! near-acct-name (qif-xtn:from-acct xtn)) (set! far-acct-name (qif-split:category split))) ((miscincx miscexpx) (set! amount (n- amount)) (set! near-acct-name (qif-xtn:from-acct xtn)) (set! far-acct-name (qif-split:miscx-category split))) ((buyx) (set! near-acct-name (qif-xtn:from-acct xtn)) (set! far-acct-name (qif-split:category split))) ((xout) (set! amount (n- amount))))))) ;; this is the grind loop. Go over every unmarked transaction in ;; the candidate-xtns list. (let xtn-loop ((xtns candidate-xtns)) (if (not (qif-xtn:mark (car xtns))) (begin (set! how (qif-import:xtn-has-matches? (car xtns) near-acct-name date amount group-amount)) (if how (begin (qif-import:merge-and-mark-xtns xtn same-acct-splits (car xtns) how) (set! done #t))))) ;; iterate with the next transaction (if (and (not done) (not (null? (cdr xtns)))) (xtn-loop (cdr xtns)))) ;; return the rest of the splits to iterate on (if (not how) (cdr splits) (case (car how) ((one-to-one many-to-one) (cdr splits)) ((one-to-many) different-acct-splits))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; qif-import:xtn-has-matches? ;; check for one-to-one, many-to-one, one-to-many split matches. ;; returns either #f (no match) or a cons cell with the car being one ;; of 'one-to-one 'one-to-many 'many-to-one, the cdr being a list of ;; splits that were part of the matching group. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (qif-import:xtn-has-matches? xtn acct-name date amount group-amt) (let ((matching-splits '()) (same-acct-splits '()) (this-group-amt (gnc:numeric-zero)) (how #f) (date-matches (let ((self-date (qif-xtn:date xtn))) (and (pair? self-date) (pair? date) (eq? (length self-date) 3) (eq? (length date) 3) (= (car self-date) (car date)) (= (cadr self-date) (cadr date)) (= (caddr self-date) (caddr date))))) (n- (lambda (n) (gnc:numeric-neg n))) (nsub (lambda (a b) (gnc:numeric-sub a b 0 GNC-DENOM-LCD))) (n+ (lambda (a b) (gnc:numeric-add a b 0 GNC-DENOM-LCD))) (n* (lambda (a b) (gnc:numeric-mul a b 0 GNC-DENOM-REDUCE))) (n/ (lambda (a b) (gnc:numeric-div a b 0 GNC-DENOM-REDUCE)))) (if date-matches (begin ;; calculate a group total for splits going to acct-name (let split-loop ((splits-left (qif-xtn:splits xtn))) (let ((split (car splits-left))) ;; does the account match up? (if (and (qif-split:category-is-account? split) (string? acct-name) (string=? (qif-split:category split) acct-name)) ;; if so, get the amount (let ((this-amt (qif-split:amount split)) (stock-xtn (qif-xtn:security-name xtn)) (action (qif-xtn:action xtn))) ;; need to change the sign of the amount for some ;; stock transactions (buy/sell both positive in ;; QIF) (if (and stock-xtn action) (case action ((xout sellx intincx divx cglongx cgshortx miscincx miscexpx) (set! this-amt (n- this-amt))))) ;; we might be done if this-amt is either equal ;; to the split amount or the group amount. (cond ((gnc:numeric-equal this-amt amount) (set! how (cons 'one-to-one (list split)))) ((and group-amt (gnc:numeric-equal this-amt group-amt)) (set! how (cons 'one-to-many (list split)))) (#t (set! same-acct-splits (cons split same-acct-splits)) (set! this-group-amt (n+ this-group-amt this-amt)))))) ;; if 'how' is non-#f, we are ready to return. (if (and (not how) (not (null? (cdr splits-left)))) (split-loop (cdr splits-left))))) ;; now we're out of the loop. if 'how' isn't set, ;; we can still have a many-to-one match. (if (and (not how) (gnc:numeric-equal this-group-amt amount)) (begin (set! how (cons 'many-to-one same-acct-splits)))))) ;; we're all done. 'how' either is #f or a ;; cons of the way-it-matched and a list of the matching ;; splits. how)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; (qif-split:accounts-affected split xtn) ;; Get the near and far ends of a split, returned as a list ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (qif-split:accounts-affected split xtn) (let ((near-acct-name #f) (far-acct-name #f) (commission-acct-name #f) (security (qif-xtn:security-name xtn)) (action (qif-xtn:action xtn)) (from-acct (qif-xtn:from-acct xtn))) ;; for non-security transactions, the near account is the ;; acct in which the xtn is, and the far is the account ;; linked by the category line. (if (not security) ;; non-security transactions (begin (set! near-acct-name from-acct) (set! far-acct-name (qif-split:category split))) ;; security transactions : the near end is either the ;; brokerage, the stock, or the category (begin (case action ((buy buyx sell sellx reinvint reinvdiv reinvsg reinvsh reinvlg reinvmd shrsin shrsout stksplit) (set! near-acct-name (default-stock-acct from-acct security))) ((div cgshort cglong cgmid intinc miscinc miscexp rtrncap margint xin xout) (set! near-acct-name from-acct)) ((divx cgshortx cglongx cgmidx intincx rtrncapx margintx) (set! near-acct-name (qif-split:category (car (qif-xtn:splits xtn))))) ((miscincx miscexpx) (set! near-acct-name (qif-split:miscx-category (car (qif-xtn:splits xtn)))))) ;; the far split: where is the money coming from? ;; Either the brokerage account, the category, ;; or an external account (case action ((buy sell) (set! far-acct-name from-acct)) ((buyx sellx miscinc miscincx miscexp miscexpx xin xout) (set! far-acct-name (qif-split:category (car (qif-xtn:splits xtn))))) ((stksplit) (set! far-acct-name (default-stock-acct from-acct security))) ((cgshort cgshortx reinvsg reinvsh) (set! far-acct-name (default-cgshort-acct from-acct security))) ((cglong cglongx reinvlg) (set! far-acct-name (default-cglong-acct from-acct security))) ((cgmid cgmidx reinvmd) (set! far-acct-name (default-cgmid-acct from-acct security))) ((intinc intincx reinvint) (set! far-acct-name (default-interest-acct from-acct security))) ((margint margintx) (set! far-acct-name (default-margin-interest-acct from-acct))) ((rtrncap rtrncapx) (set! far-acct-name (default-capital-return-acct from-acct security))) ((div divx reinvdiv) (set! far-acct-name (default-dividend-acct from-acct security))) ((shrsin shrsout) (set! far-acct-name (default-equity-holding security)))) ;; the commission account, if it exists (if (qif-xtn:commission xtn) (set! commission-acct-name (default-commission-acct from-acct))))) (list near-acct-name far-acct-name commission-acct-name))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; qif-import:merge-and-mark-xtns ;; we know that the splits match. Pick one to mark and ;; merge the information into the other one. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (qif-import:merge-and-mark-xtns xtn splits other-xtn how) ;; merge transaction fields (let ((action (qif-xtn:action xtn)) (o-action (qif-xtn:action other-xtn)) (security (qif-xtn:security-name xtn)) (o-security (qif-xtn:security-name other-xtn)) (split (car splits)) (match-type (car how)) (match-splits (cdr how))) (case match-type ;; many-to-one: the other-xtn has several splits that total ;; in amount to 'split'. We want to preserve the multi-split ;; transaction. ((many-to-one) (qif-xtn:mark-split xtn split) (qif-import:merge-xtn-info xtn other-xtn) (for-each (lambda (s) (qif-split:set-matching-cleared! s (qif-xtn:cleared xtn))) match-splits)) ;; one-to-many: 'split' is just one of a set of splits in xtn ;; that total up to the split in match-splits. ((one-to-many) (qif-xtn:mark-split other-xtn (car match-splits)) (qif-import:merge-xtn-info other-xtn xtn) (for-each (lambda (s) (qif-split:set-matching-cleared! s (qif-xtn:cleared other-xtn))) splits)) ;; otherwise: one-to-one, a normal single split match. (else (cond ;; this is a transfer involving a security xtn. Let the ;; security xtn dominate the way it's handled. ((and (not action) o-action o-security) (qif-xtn:mark-split xtn split) (qif-import:merge-xtn-info xtn other-xtn) (qif-split:set-matching-cleared! (car match-splits) (qif-xtn:cleared xtn))) ((and action (not o-action) security) (qif-xtn:mark-split other-xtn (car match-splits)) (qif-import:merge-xtn-info other-xtn xtn) (qif-split:set-matching-cleared! split (qif-xtn:cleared other-xtn))) ;; this is a security transaction from one brokerage to another ;; or within a brokerage. The "foox" xtn has the most ;; information about what went on, so use it. ((and action o-action o-security) (case o-action ((buyx sellx cgshortx cgmidx cglongx intincx divx margintx rtrncapx miscincx miscexpx) (qif-xtn:mark-split xtn split) (qif-import:merge-xtn-info xtn other-xtn) (qif-split:set-matching-cleared! (car match-splits) (qif-xtn:cleared xtn))) (else (qif-xtn:mark-split other-xtn (car match-splits)) (qif-import:merge-xtn-info other-xtn xtn) (qif-split:set-matching-cleared! split (qif-xtn:cleared other-xtn))))) ;; otherwise, this is a normal no-frills split match. if one ;; transaction has more splits than the other one, ;; (heuristically) mark the one with less splits. (#t (if (< (length (qif-xtn:splits xtn)) (length (qif-xtn:splits other-xtn))) (begin (qif-xtn:mark-split xtn split) (qif-import:merge-xtn-info xtn other-xtn) (qif-split:set-matching-cleared! (car match-splits) (qif-xtn:cleared xtn))) (begin (qif-xtn:mark-split other-xtn (car match-splits)) (qif-import:merge-xtn-info other-xtn xtn) (qif-split:set-matching-cleared! split (qif-xtn:cleared other-xtn)))))))))) (define (qif-import:merge-xtn-info from-xtn to-xtn) (if (and (qif-xtn:payee from-xtn) (not (qif-xtn:payee to-xtn))) (qif-xtn:set-payee! to-xtn (qif-xtn:payee from-xtn))) (if (and (qif-xtn:address from-xtn) (not (qif-xtn:address to-xtn))) (qif-xtn:set-address! to-xtn (qif-xtn:address from-xtn))) (if (and (qif-xtn:number from-xtn) (not (qif-xtn:number to-xtn))) (qif-xtn:set-number! to-xtn (qif-xtn:number from-xtn)))) (define (qif-xtn:mark-split xtn split) (qif-split:set-mark! split #t) (let ((all-marked #t)) (let loop ((splits (qif-xtn:splits xtn))) (if (not (qif-split:mark (car splits))) (set! all-marked #f) (if (not (null? (cdr splits))) (loop (cdr splits))))) (if all-marked (qif-xtn:set-mark! xtn #t))))