FS/FS/cust_credit.pm

   1 package FS::cust_credit;
   2 use base qw( FS::otaker_Mixin FS::cust_main_Mixin FS::reason_Mixin
   3              FS::Record );
   4
   5 use strict;
   6 use vars qw( $conf $unsuspendauto $me $DEBUG
   7              $otaker_upgrade_kludge $ignore_empty_reasonnum
   8            );
   9 use List::Util qw( min );
  10 use Date::Format;
  11 use FS::UID qw( dbh );
  12 use FS::Record qw( qsearch qsearchs dbdef );
  13 use FS::CurrentUser;
  14 use FS::cust_pkg;
  15 use FS::cust_refund;
  16 use FS::cust_credit_bill;
  17 use FS::part_pkg;
  18 use FS::reason_type;
  19 use FS::reason;
  20 use FS::cust_event;
  21 use FS::agent;
  22 use FS::sales;
  23 use FS::cust_credit_void;
  24 use FS::cust_bill_pkg;
  25 use FS::upgrade_journal;
  26
  27 $me = '[ FS::cust_credit ]';
  28 $DEBUG = 0;
  29
  30 $otaker_upgrade_kludge = 0;
  31 $ignore_empty_reasonnum = 0;
  32
  33 #ask FS::UID to run this stuff for us later
  34 $FS::UID::callback{'FS::cust_credit'} = sub {
  35
  36   $conf = new FS::Conf;
  37   $unsuspendauto = $conf->exists('unsuspendauto');
  38
  39 };
  40
  41 our %reasontype_map = ( 'referral_credit_type' => 'Referral Credit',
  42                         'cancel_credit_type'   => 'Cancellation Credit',
  43                       );
  44
  45 =head1 NAME
  46
  47 FS::cust_credit - Object methods for cust_credit records
  48
  49 =head1 SYNOPSIS
  50
  51   use FS::cust_credit;
  52
  53   $record = new FS::cust_credit \%hash;
  54   $record = new FS::cust_credit { 'column' => 'value' };
  55
  56   $error = $record->insert;
  57
  58   $error = $new_record->replace($old_record);
  59
  60   $error = $record->delete;
  61
  62   $error = $record->check;
  63
  64 =head1 DESCRIPTION
  65
  66 An FS::cust_credit object represents a credit; the equivalent of a negative
  67 B<cust_bill> record (see L<FS::cust_bill>).  FS::cust_credit inherits from
  68 FS::Record.  The following fields are currently supported:
  69
  70 =over 4
  71
  72 =item crednum
  73
  74 Primary key (assigned automatically for new credits)
  75
  76 =item custnum
  77
  78 Customer (see L<FS::cust_main>)
  79
  80 =item amount
  81
  82 Amount of the credit
  83
  84 =item _date
  85
  86 Specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
  87 L<Time::Local> and L<Date::Parse> for conversion functions.
  88
  89 =item usernum
  90
  91 Order taker (see L<FS::access_user>)
  92
  93 =item reason
  94
  95 Text ( deprecated )
  96
  97 =item reasonnum
  98
  99 Reason (see L<FS::reason>)
 100
 101 =item addlinfo
 102
 103 Text
 104
 105 =item closed
 106
 107 Books closed flag, empty or `Y'
 108
 109 =item pkgnum
 110
 111 Desired pkgnum when using experimental package balances.
 112
 113 =back
 114
 115 =head1 METHODS
 116
 117 =over 4
 118
 119 =item new HASHREF
 120
 121 Creates a new credit.  To add the credit to the database, see L<"insert">.
 122
 123 =cut
 124
 125 sub table { 'cust_credit'; }
 126 sub cust_linked { $_[0]->cust_main_custnum || $_[0]->custnum }
 127 sub cust_unlinked_msg {
 128   my $self = shift;
 129   "WARNING: can't find cust_main.custnum ". $self->custnum.
 130   ' (cust_credit.crednum '. $self->crednum. ')';
 131 }
 132
 133 =item insert [ OPTION => VALUE ... ]
 134
 135 Adds this credit to the database ("Posts" the credit).  If there is an error,
 136 returns the error, otherwise returns false.
 137
 138 Ooptions are passed as a list of keys and values.  Available options:
 139
 140 =over 4
 141
 142 =item reason_type
 143
 144 L<FS::reason_type|Reason> type for newly-inserted reason
 145
 146 =item cust_credit_source_bill_pkg
 147
 148 An arrayref of
 149 L<FS::cust_credit_source_bill_pkg|FS::cust_credit_source_bilL_pkg> objects.
 150 They will have their crednum set and will be inserted along with this credit.
 151
 152 =back
 153
 154 =cut
 155
 156 sub insert {
 157   my ($self, %options) = @_;
 158
 159   local $SIG{HUP} = 'IGNORE';
 160   local $SIG{INT} = 'IGNORE';
 161   local $SIG{QUIT} = 'IGNORE';
 162   local $SIG{TERM} = 'IGNORE';
 163   local $SIG{TSTP} = 'IGNORE';
 164   local $SIG{PIPE} = 'IGNORE';
 165
 166   my $oldAutoCommit = $FS::UID::AutoCommit;
 167   local $FS::UID::AutoCommit = 0;
 168   my $dbh = dbh;
 169
 170   my $cust_main = qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
 171   my $old_balance = $cust_main->balance;
 172
 173   if (!$self->reasonnum) {
 174     my $reason_text = $self->get('reason')
 175       or return "reason text or existing reason required";
 176     my $reason_type = $options{'reason_type'}
 177       or return "reason type required";
 178
 179     local $@;
 180     my $reason = FS::reason->new_or_existing(
 181       reason => $reason_text,
 182       type   => $reason_type,
 183       class  => 'R',
 184     );
 185     if ($@) {
 186       $dbh->rollback if $oldAutoCommit;
 187       return "failed to set credit reason: $@";
 188     }
 189     $self->set('reasonnum', $reason->reasonnum);
 190   }
 191
 192   $self->setfield('reason', '');
 193
 194   my $error = $self->SUPER::insert;
 195   if ( $error ) {
 196     $dbh->rollback if $oldAutoCommit;
 197     return "error inserting $self: $error";
 198   }
 199
 200   if ( $options{'cust_credit_source_bill_pkg'} ) {
 201     foreach my $ccsbr ( @{ $options{'cust_credit_source_bill_pkg'} } ) {
 202       $ccsbr->crednum( $self->crednum );
 203       $error = $ccsbr->insert;
 204       if ( $error ) {
 205         $dbh->rollback if $oldAutoCommit;
 206         return "error inserting $ccsbr: $error";
 207       }
 208     }
 209   }
 210
 211   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 212
 213   #false laziness w/ cust_pay::insert
 214   if ( $unsuspendauto && $old_balance && $cust_main->balance <= 0 ) {
 215     my @errors = $cust_main->unsuspend;
 216     #return
 217     # side-fx with nested transactions?  upstack rolls back?
 218     warn "WARNING:Errors unsuspending customer ". $cust_main->custnum. ": ".
 219          join(' / ', @errors)
 220       if @errors;
 221   }
 222   #eslaf
 223
 224   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 225
 226   '';
 227
 228 }
 229
 230 =item delete
 231
 232 Unless the closed flag is set, deletes this credit and all associated
 233 applications (see L<FS::cust_credit_bill>).  In most cases, you want to use
 234 the void method instead to leave a record of the deleted credit.
 235
 236 =cut
 237
 238 # very similar to FS::cust_pay::delete
 239 sub delete {
 240   my $self = shift;
 241   my %opt = @_;
 242
 243   return "Can't delete closed credit" if $self->closed =~ /^Y/i;
 244
 245   local $SIG{HUP} = 'IGNORE';
 246   local $SIG{INT} = 'IGNORE';
 247   local $SIG{QUIT} = 'IGNORE';
 248   local $SIG{TERM} = 'IGNORE';
 249   local $SIG{TSTP} = 'IGNORE';
 250   local $SIG{PIPE} = 'IGNORE';
 251
 252   my $oldAutoCommit = $FS::UID::AutoCommit;
 253   local $FS::UID::AutoCommit = 0;
 254   my $dbh = dbh;
 255
 256   foreach my $cust_credit_bill ( $self->cust_credit_bill ) {
 257     my $error = $cust_credit_bill->delete;
 258     if ( $error ) {
 259       $dbh->rollback if $oldAutoCommit;
 260       return $error;
 261     }
 262   }
 263
 264   foreach my $cust_credit_refund ( $self->cust_credit_refund ) {
 265     my $error = $cust_credit_refund->delete;
 266     if ( $error ) {
 267       $dbh->rollback if $oldAutoCommit;
 268       return $error;
 269     }
 270   }
 271
 272   my $error = $self->SUPER::delete(@_);
 273   if ( $error ) {
 274     $dbh->rollback if $oldAutoCommit;
 275     return $error;
 276   }
 277
 278   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 279
 280   '';
 281
 282 }
 283
 284 =item replace [ OLD_RECORD ]
 285
 286 You can, but probably shouldn't modify credits...
 287
 288 Replaces the OLD_RECORD with this one in the database, or, if OLD_RECORD is not
 289 supplied, replaces this record.  If there is an error, returns the error,
 290 otherwise returns false.
 291
 292 =cut
 293
 294 sub replace {
 295   my $self = shift;
 296   return "Can't modify closed credit" if $self->closed =~ /^Y/i;
 297   $self->SUPER::replace(@_);
 298 }
 299
 300 =item check
 301
 302 Checks all fields to make sure this is a valid credit.  If there is an error,
 303 returns the error, otherwise returns false.  Called by the insert and replace
 304 methods.
 305
 306 =cut
 307
 308 sub check {
 309   my $self = shift;
 310
 311   $self->usernum($FS::CurrentUser::CurrentUser->usernum) unless $self->usernum;
 312
 313   my $error =
 314     $self->ut_numbern('crednum')
 315     || $self->ut_number('custnum')
 316     || $self->ut_numbern('_date')
 317     || $self->ut_money('amount')
 318     || $self->ut_alphan('otaker')
 319     || $self->ut_textn('reason')
 320     || $self->ut_textn('addlinfo')
 321     || $self->ut_enum('closed', [ '', 'Y' ])
 322     || $self->ut_foreign_keyn('pkgnum', 'cust_pkg', 'pkgnum')
 323     || $self->ut_foreign_keyn('eventnum', 'cust_event', 'eventnum')
 324     || $self->ut_foreign_keyn('commission_agentnum',  'agent', 'agentnum')
 325     || $self->ut_foreign_keyn('commission_salesnum',  'sales', 'salesnum')
 326     || $self->ut_foreign_keyn('commission_pkgnum', 'cust_pkg', 'pkgnum')
 327   ;
 328   return $error if $error;
 329
 330   my $method = $ignore_empty_reasonnum ? 'ut_foreign_keyn' : 'ut_foreign_key';
 331   $error = $self->$method('reasonnum', 'reason', 'reasonnum');
 332   return $error if $error;
 333
 334   return "amount must be > 0 " if $self->amount <= 0;
 335
 336   return "amount must be greater or equal to amount applied"
 337     if $self->unapplied < 0 && ! $otaker_upgrade_kludge;
 338
 339   return "Unknown customer"
 340     unless qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
 341
 342   $self->_date(time) unless $self->_date;
 343
 344   $self->SUPER::check;
 345 }
 346
 347 =item void [ REASON ]
 348
 349 Voids this credit: deletes the credit and all associated applications and
 350 adds a record of the voided credit to the cust_credit_void table.
 351
 352 =cut
 353
 354 sub void {
 355   my $self = shift;
 356   my $reason = shift;
 357
 358   unless (ref($reason) || !$reason) {
 359     $reason = FS::reason->new_or_existing(
 360       'class'  => 'X',
 361       'type'   => 'Void credit',
 362       'reason' => $reason
 363     );
 364   }
 365
 366   local $SIG{HUP} = 'IGNORE';
 367   local $SIG{INT} = 'IGNORE';
 368   local $SIG{QUIT} = 'IGNORE';
 369   local $SIG{TERM} = 'IGNORE';
 370   local $SIG{TSTP} = 'IGNORE';
 371   local $SIG{PIPE} = 'IGNORE';
 372
 373   my $oldAutoCommit = $FS::UID::AutoCommit;
 374   local $FS::UID::AutoCommit = 0;
 375   my $dbh = dbh;
 376
 377   my $cust_credit_void = new FS::cust_credit_void ( {
 378       map { $_ => $self->get($_) } $self->fields
 379     } );
 380   $cust_credit_void->set('void_reasonnum', $reason->reasonnum);
 381   my $error = $cust_credit_void->insert;
 382   if ( $error ) {
 383     $dbh->rollback if $oldAutoCommit;
 384     return $error;
 385   }
 386
 387   $error = $self->delete();
 388   if ( $error ) {
 389     $dbh->rollback if $oldAutoCommit;
 390     return $error;
 391   }
 392
 393   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 394
 395   '';
 396
 397 }
 398
 399 =item cust_credit_refund
 400
 401 Returns all refund applications (see L<FS::cust_credit_refund>) for this credit.
 402
 403 =cut
 404
 405 sub cust_credit_refund {
 406   my $self = shift;
 407   map { $_ } #return $self->num_cust_credit_refund unless wantarray;
 408   sort { $a->_date <=> $b->_date }
 409     qsearch( 'cust_credit_refund', { 'crednum' => $self->crednum } )
 410   ;
 411 }
 412
 413 =item cust_credit_bill
 414
 415 Returns all application to invoices (see L<FS::cust_credit_bill>) for this
 416 credit.
 417
 418 =cut
 419
 420 sub cust_credit_bill {
 421   my $self = shift;
 422   map { $_ } #return $self->num_cust_credit_bill unless wantarray;
 423   sort { $a->_date <=> $b->_date }
 424     qsearch( 'cust_credit_bill', { 'crednum' => $self->crednum } )
 425   ;
 426 }
 427
 428 =item unapplied
 429
 430 Returns the amount of this credit that is still unapplied/outstanding;
 431 amount minus all refund applications (see L<FS::cust_credit_refund>) and
 432 applications to invoices (see L<FS::cust_credit_bill>).
 433
 434 =cut
 435
 436 sub unapplied {
 437   my $self = shift;
 438   my $amount = $self->amount;
 439   $amount -= $_->amount foreach ( $self->cust_credit_refund );
 440   $amount -= $_->amount foreach ( $self->cust_credit_bill );
 441   sprintf( "%.2f", $amount );
 442 }
 443
 444 =item credited
 445
 446 Deprecated name for the unapplied method.
 447
 448 =cut
 449
 450 sub credited {
 451   my $self = shift;
 452   #carp "cust_credit->credited deprecated; use ->unapplied";
 453   $self->unapplied(@_);
 454 }
 455
 456 =item cust_main
 457
 458 Returns the customer (see L<FS::cust_main>) for this credit.
 459
 460 =cut
 461
 462 # _upgrade_data
 463 #
 464 # Used by FS::Upgrade to migrate to a new database.
 465
 466 sub _upgrade_data {  # class method
 467   my ($class, %opts) = @_;
 468
 469   warn "$me upgrading $class\n" if $DEBUG;
 470
 471   $class->_upgrade_reasonnum(%opts);
 472
 473   if (defined dbdef->table($class->table)->column('reason')) {
 474
 475     warn "$me Ensuring existance of auto reasons\n" if $DEBUG;
 476
 477     foreach ( keys %reasontype_map ) {
 478       unless ($conf->config($_)) {       # hmmmm
 479 #       warn "$me Found $_ reason type lacking\n" if $DEBUG;
 480 #       my $hashref = { 'class' => 'R', 'type' => $reasontype_map{$_} };
 481         my $hashref = { 'class' => 'R', 'type' => 'Legacy' };
 482         my $reason_type = qsearchs( 'reason_type', $hashref );
 483         unless ($reason_type) {
 484           $reason_type  = new FS::reason_type( $hashref );
 485           my $error   = $reason_type->insert();
 486           die "$class had error inserting FS::reason_type into database: $error\n"
 487             if $error;
 488         }
 489         $conf->set($_, $reason_type->typenum);
 490       }
 491     }
 492
 493     warn "$me Ensuring commission packages have a reason type\n" if $DEBUG;
 494
 495     my $hashref = { 'class' => 'R', 'type' => 'Legacy' };
 496     my $reason_type = qsearchs( 'reason_type', $hashref );
 497     unless ($reason_type) {
 498       $reason_type  = new FS::reason_type( $hashref );
 499       my $error   = $reason_type->insert();
 500       die "$class had error inserting FS::reason_type into database: $error\n"
 501         if $error;
 502     }
 503
 504     my @plans = qw( flat_comission flat_comission_cust flat_comission_pkg );
 505     foreach my $plan ( @plans ) {
 506       foreach my $pkg ( qsearch('part_pkg', { 'plan' => $plan } ) ) {
 507         unless ($pkg->option('reason_type', 1) ) {
 508           my $plandata = $pkg->plandata.
 509                         "reason_type=". $reason_type->typenum. "\n";
 510           $pkg->plandata($plandata);
 511           my $error =
 512             $pkg->replace( undef,
 513                            'pkg_svc' => { map { $_->svcpart => $_->quantity }
 514                                           $pkg->pkg_svc
 515                                         },
 516                            'primary_svc' => $pkg->svcpart,
 517                          );
 518             die "failed setting reason_type option: $error"
 519               if $error;
 520         }
 521       }
 522     }
 523   }
 524
 525   local($otaker_upgrade_kludge) = 1;
 526   local($ignore_empty_reasonnum) = 1;
 527   $class->_upgrade_otaker(%opts);
 528
 529   if ( !FS::upgrade_journal->is_done('cust_credit__tax_link')
 530       and !$conf->config('tax_data_vendor') ) {
 531     # RT#25458: fix credit line item applications that should refer to a
 532     # specific tax allocation
 533     my @cust_credit_bill_pkg = qsearch({
 534         table     => 'cust_credit_bill_pkg',
 535         select    => 'cust_credit_bill_pkg.*',
 536         addl_from => ' LEFT JOIN cust_bill_pkg USING (billpkgnum)',
 537         extra_sql =>
 538           'WHERE cust_credit_bill_pkg.billpkgtaxlocationnum IS NULL '.
 539           'AND cust_bill_pkg.pkgnum = 0', # is a tax
 540     });
 541     my %tax_items;
 542     my %credits;
 543     foreach (@cust_credit_bill_pkg) {
 544       my $billpkgnum = $_->billpkgnum;
 545       $tax_items{$billpkgnum} ||= FS::cust_bill_pkg->by_key($billpkgnum);
 546       $credits{$billpkgnum} ||= [];
 547       push @{ $credits{$billpkgnum} }, $_;
 548     }
 549     TAX_ITEM: foreach my $tax_item (values %tax_items) {
 550       my $billpkgnum = $tax_item->billpkgnum;
 551       # get all pkg/location/taxrate allocations of this tax line item
 552       my @allocations = sort {$b->amount <=> $a->amount}
 553                         qsearch('cust_bill_pkg_tax_location', {
 554                             billpkgnum => $billpkgnum
 555                         });
 556       # and these are all credit applications to it
 557       my @credits = sort {$b->amount <=> $a->amount}
 558                     @{ $credits{$billpkgnum} };
 559       my $c = shift @credits;
 560       my $a = shift @allocations; # we will NOT modify these
 561       while ($c and $a) {
 562         if ( abs($c->amount - $a->amount) < 0.005 ) {
 563           # by far the most common case: the tax line item is for a single
 564           # tax, so we just fill in the billpkgtaxlocationnum
 565           $c->set('billpkgtaxlocationnum', $a->billpkgtaxlocationnum);
 566           my $error = $c->replace;
 567           if ($error) {
 568             warn "error fixing credit application to tax item #$billpkgnum:\n$error\n";
 569             next TAX_ITEM;
 570           }
 571           $c = shift @credits;
 572           $a = shift @allocations;
 573         } elsif ( $c->amount > $a->amount ) {
 574           # fairly common: the tax line contains tax for multiple packages
 575           # (or multiple taxes) but the credit isn't divided up
 576           my $new_link = FS::cust_credit_bill_pkg->new({
 577               creditbillnum         => $c->creditbillnum,
 578               billpkgnum            => $c->billpkgnum,
 579               billpkgtaxlocationnum => $a->billpkgtaxlocationnum,
 580               amount                => $a->amount,
 581               setuprecur            => 'setup',
 582           });
 583           my $error = $new_link->insert;
 584           if ($error) {
 585             warn "error fixing credit application to tax item #$billpkgnum:\n$error\n";
 586             next TAX_ITEM;
 587           }
 588           $c->set(amount => sprintf('%.2f', $c->amount - $a->amount));
 589           $a = shift @allocations;
 590         } elsif ( $c->amount < 0.005 ) {
 591           # also fairly common; we can delete these with no harm
 592           my $error = $c->delete;
 593           warn "error removing zero-amount credit application (probably harmless):\n$error\n" if $error;
 594           $c = shift @credits;
 595         } elsif ( $c->amount < $a->amount ) {
 596           # should never happen, but if it does, handle it gracefully
 597           $c->set('billpkgtaxlocationnum', $a->billpkgtaxlocationnum);
 598           my $error = $c->replace;
 599           if ($error) {
 600             warn "error fixing credit application to tax item #$billpkgnum:\n$error\n";
 601             next TAX_ITEM;
 602           }
 603           $a->set(amount => $a->amount - $c->amount);
 604           $c = shift @credits;
 605         }
 606       } # while $c and $a
 607       if ( $c ) {
 608         if ( $c->amount < 0.005 ) {
 609           my $error = $c->delete;
 610           warn "error removing zero-amount credit application (probably harmless):\n$error\n" if $error;
 611         } elsif ( $c->modified ) {
 612           # then we've allocated part of it, so reduce the nonspecific
 613           # application by that much
 614           my $error = $c->replace;
 615           warn "error fixing credit application to tax item #$billpkgnum:\n$error\n" if $error;
 616         }
 617         # else there are probably no allocations, i.e. this is a pre-3.x
 618         # record that was never migrated over, so leave it alone
 619       } # if $c
 620     } # foreach $tax_item
 621     FS::upgrade_journal->set_done('cust_credit__tax_link');
 622   }
 623 }
 624
 625 =back
 626
 627 =head1 CLASS METHODS
 628
 629 =over 4
 630
 631 =item unapplied_sql
 632
 633 Returns an SQL fragment to retreive the unapplied amount.
 634
 635 =cut
 636
 637 sub unapplied_sql {
 638   my ($class, $start, $end) = @_;
 639
 640   my $bill_start   = $start ? "AND cust_credit_bill._date <= $start"   : '';
 641   my $bill_end     = $end   ? "AND cust_credit_bill._date > $end"     : '';
 642   my $refund_start = $start ? "AND cust_credit_refund._date <= $start" : '';
 643   my $refund_end   = $end   ? "AND cust_credit_refund._date > $end"   : '';
 644
 645   "amount
 646         - COALESCE(
 647                     ( SELECT SUM(amount) FROM cust_credit_refund
 648                         WHERE cust_credit.crednum = cust_credit_refund.crednum
 649                         $refund_start $refund_end )
 650                     ,0
 651                   )
 652         - COALESCE(
 653                     ( SELECT SUM(amount) FROM cust_credit_bill
 654                         WHERE cust_credit.crednum = cust_credit_bill.crednum
 655                         $bill_start $bill_end )
 656                     ,0
 657                   )
 658   ";
 659
 660 }
 661
 662 =item credited_sql
 663
 664 Deprecated name for the unapplied_sql method.
 665
 666 =cut
 667
 668 sub credited_sql {
 669   #my $class = shift;
 670
 671   #carp "cust_credit->credited_sql deprecated; use ->unapplied_sql";
 672
 673   #$class->unapplied_sql(@_);
 674   unapplied_sql();
 675 }
 676
 677 =item calculate_tax_adjustment PARAMS
 678
 679 Calculate the amount of tax that needs to be credited as part of a lineitem
 680 credit.
 681
 682 PARAMS must include:
 683
 684 - billpkgnums: arrayref identifying the line items to credit
 685 - setuprecurs: arrayref of 'setup' or 'recur', indicating which part of
 686   the lineitem charge is being credited
 687 - amounts: arrayref of the amounts to credit on each line item
 688 - custnum: the customer all of these invoices belong to, for error checking
 689
 690 Returns a hash containing:
 691 - subtotal: the total non-tax amount to be credited (the sum of the 'amounts')
 692 - taxtotal: the total tax amount to be credited
 693 - taxlines: an arrayref of hashrefs for each tax line to be credited, each with:
 694   - table: "cust_bill_pkg_tax_location" or "cust_bill_pkg_tax_rate_location"
 695   - num: the key within that table
 696   - credit: the credit amount to apply to that line
 697
 698 =cut
 699
 700 sub calculate_tax_adjustment {
 701   my ($class, %arg) = @_;
 702
 703   my $error;
 704   my @taxlines;
 705   my $subtotal = 0;
 706   my $taxtotal = 0;
 707
 708   my (%cust_bill_pkg, %cust_bill);
 709
 710   for (my $i = 0; ; $i++) {
 711     my $billpkgnum = $arg{billpkgnums}[$i]
 712       or last;
 713     my $setuprecur = $arg{setuprecurs}[$i];
 714     my $amount = $arg{amounts}[$i];
 715     next if $amount == 0;
 716     $subtotal += $amount;
 717     my $cust_bill_pkg = $cust_bill_pkg{$billpkgnum}
 718                     ||= FS::cust_bill_pkg->by_key($billpkgnum)
 719       or die "lineitem #$billpkgnum not found\n";
 720
 721     my $invnum = $cust_bill_pkg->invnum;
 722     $cust_bill{ $invnum } ||= FS::cust_bill->by_key($invnum);
 723     $cust_bill{ $invnum}->custnum == $arg{custnum}
 724       or die "lineitem #$billpkgnum not found\n";
 725
 726     # calculate credit ratio.
 727     # (First deduct any existing credits applied to this line item, to avoid
 728     # rounding errors.)
 729     my $charged = $cust_bill_pkg->get($setuprecur);
 730     my $previously_credited =
 731       $cust_bill_pkg->credited( '', '', setuprecur => $setuprecur) || 0;
 732
 733     $charged -= $previously_credited;
 734     if ($charged < $amount) {
 735       $error = "invoice #$invnum: tried to credit $amount, but only $charged was charged";
 736       last;
 737     }
 738     my $ratio = $amount / $charged;
 739
 740     # gather taxes that apply to the selected item
 741     foreach my $table (
 742       qw(cust_bill_pkg_tax_location cust_bill_pkg_tax_rate_location)
 743     ) {
 744       foreach my $tax_link (
 745         qsearch($table, { taxable_billpkgnum => $billpkgnum })
 746       ) {
 747         my $tax_amount = $tax_link->amount;
 748         # deduct existing credits applied to the tax, for the same reason as
 749         # above
 750         foreach ($tax_link->cust_credit_bill_pkg) {
 751           $tax_amount -= $_->amount;
 752         }
 753         my $tax_credit = sprintf('%.2f', $tax_amount * $ratio);
 754         my $pkey = $tax_link->get($tax_link->primary_key);
 755         push @taxlines, {
 756           table   => $table,
 757           num     => $pkey,
 758           credit  => $tax_credit,
 759         };
 760         $taxtotal += $tax_credit;
 761
 762       } #foreach cust_bill_pkg_tax_(rate_)?location
 763     }
 764   } # foreach $billpkgnum
 765
 766   return (
 767     subtotal => sprintf('%.2f', $subtotal),
 768     taxtotal => sprintf('%.2f', $taxtotal),
 769     taxlines => \@taxlines,
 770   );
 771 }
 772
 773 =item credit_lineitems
 774
 775 Example:
 776
 777   my $error = FS::cust_credit->credit_lineitems(
 778
 779     #the lineitems to credit
 780     'billpkgnums'       => \@billpkgnums,
 781     'setuprecurs'       => \@setuprecurs,
 782     'amounts'           => \@amounts,
 783     'apply'             => 1, #0 leaves the credit unapplied
 784
 785     #the credit
 786     map { $_ => scalar($cgi->param($_)) }
 787       #fields('cust_credit')
 788       qw( custnum _date amount reasonnum addlinfo ), #pkgnum eventnum
 789
 790   );
 791
 792 =cut
 793
 794 #maybe i should just be an insert with extra args instead of a class method
 795 sub credit_lineitems {
 796   my( $class, %arg ) = @_;
 797   my $curuser = $FS::CurrentUser::CurrentUser;
 798
 799   #some false laziness w/misc/xmlhttp-cust_bill_pkg-calculate_taxes.html
 800
 801   my $cust_main = qsearchs({
 802     'table'     => 'cust_main',
 803     'hashref'   => { 'custnum' => $arg{custnum} },
 804     'extra_sql' => ' AND '. $curuser->agentnums_sql,
 805   }) or return 'unknown customer';
 806
 807
 808   local $SIG{HUP} = 'IGNORE';
 809   local $SIG{INT} = 'IGNORE';
 810   local $SIG{QUIT} = 'IGNORE';
 811   local $SIG{TERM} = 'IGNORE';
 812   local $SIG{TSTP} = 'IGNORE';
 813   local $SIG{PIPE} = 'IGNORE';
 814
 815   my $oldAutoCommit = $FS::UID::AutoCommit;
 816   local $FS::UID::AutoCommit = 0;
 817   my $dbh = dbh;
 818
 819   #my @cust_bill_pkg = qsearch({
 820   #  'select'    => 'cust_bill_pkg.*',
 821   #  'table'     => 'cust_bill_pkg',
 822   #  'addl_from' => ' LEFT JOIN cust_bill USING (invnum)  '.
 823   #                 ' LEFT JOIN cust_main USING (custnum) ',
 824   #  'extra_sql' => ' WHERE custnum = $custnum AND billpkgnum IN ('.
 825   #                     join( ',', @{$arg{billpkgnums}} ). ')',
 826   #  'order_by'  => 'ORDER BY invnum ASC, billpkgnum ASC',
 827   #});
 828
 829   my $error = '';
 830
 831   my $cust_credit = new FS::cust_credit ( {
 832     map { $_ => $arg{$_} }
 833       #fields('cust_credit')
 834       qw( custnum _date amount reasonnum addlinfo ), #pkgnum eventnum
 835   } );
 836   $error = $cust_credit->insert;
 837   if ( $error ) {
 838     $dbh->rollback if $oldAutoCommit;
 839     return "Error inserting credit: $error";
 840   }
 841
 842   unless ( $arg{'apply'} ) {
 843     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 844     return '';
 845   }
 846
 847   #my $subtotal = 0;
 848   # keys in all of these are invoice numbers
 849   my %cust_credit_bill = ();
 850   my %cust_bill_pkg = ();
 851   my %cust_credit_bill_pkg = ();
 852   my %unapplied_payments = (); #invoice numbers, and then billpaynums
 853
 854   # determine the tax adjustments
 855   my %tax_adjust = $class->calculate_tax_adjustment(%arg);
 856
 857   foreach my $billpkgnum ( @{$arg{billpkgnums}} ) {
 858     my $setuprecur = shift @{$arg{setuprecurs}};
 859     my $amount = shift @{$arg{amounts}};
 860
 861     my $cust_bill_pkg = qsearchs({
 862       'table'     => 'cust_bill_pkg',
 863       'hashref'   => { 'billpkgnum' => $billpkgnum },
 864       'addl_from' => 'LEFT JOIN cust_bill USING (invnum)',
 865       'extra_sql' => 'AND custnum = '. $cust_main->custnum,
 866     }) or die "unknown billpkgnum $billpkgnum";
 867
 868     my $invnum = $cust_bill_pkg->invnum;
 869
 870     push @{$cust_bill_pkg{$invnum}}, $cust_bill_pkg;
 871
 872     $cust_credit_bill{$invnum} += $amount;
 873     push @{ $cust_credit_bill_pkg{$invnum} },
 874       new FS::cust_credit_bill_pkg {
 875         'billpkgnum' => $billpkgnum,
 876         'amount'     => sprintf('%.2f',$amount),
 877         'setuprecur' => $setuprecur,
 878         'sdate'      => $cust_bill_pkg->sdate,
 879         'edate'      => $cust_bill_pkg->edate,
 880       };
 881     # unapply payments (but not other credits) from this line item
 882     foreach my $cust_bill_pay_pkg (
 883       $cust_bill_pkg->cust_bill_pay_pkg($setuprecur)
 884     ) {
 885       $error = $cust_bill_pay_pkg->delete;
 886       if ( $error ) {
 887         $dbh->rollback if $oldAutoCommit;
 888         return "Error unapplying payment: $error";
 889       }
 890       $unapplied_payments{$invnum}{$cust_bill_pay_pkg->billpaynum}
 891         += $cust_bill_pay_pkg->amount;
 892     }
 893   }
 894
 895   # do the same for taxes
 896   foreach my $tax_credit ( @{ $tax_adjust{taxlines} } ) {
 897     my $table = $tax_credit->{table};
 898     my $tax_link = "FS::$table"->by_key( $tax_credit->{num} )
 899       or die "tried to credit $table #$tax_credit->{num} but it doesn't exist";
 900
 901     my $billpkgnum = $tax_link->billpkgnum;
 902     my $cust_bill_pkg = qsearchs({
 903       'table'     => 'cust_bill_pkg',
 904       'hashref'   => { 'billpkgnum' => $billpkgnum },
 905       'addl_from' => 'LEFT JOIN cust_bill USING (invnum)',
 906       'extra_sql' => 'AND custnum = '. $cust_main->custnum,
 907     }) or die "unknown billpkgnum $billpkgnum";
 908
 909     my $invnum = $cust_bill_pkg->invnum;
 910     push @{$cust_bill_pkg{$invnum}}, $cust_bill_pkg;
 911
 912     my $amount = $tax_credit->{credit};
 913     $cust_credit_bill{$invnum} += $amount;
 914
 915     # create a credit application record to the tax line item, earmarked
 916     # to the specific cust_bill_pkg_Xlocation
 917     push @{ $cust_credit_bill_pkg{$invnum} },
 918       new FS::cust_credit_bill_pkg {
 919         'billpkgnum' => $billpkgnum,
 920         'amount'     => sprintf('%.2f', $amount),
 921         'setuprecur' => 'setup',
 922         $tax_link->primary_key, $tax_credit->{num}
 923       };
 924     # unapply any payments from the tax
 925     foreach my $cust_bill_pay_pkg (
 926       $cust_bill_pkg->cust_bill_pay_pkg('setup')
 927     ) {
 928       $error = $cust_bill_pay_pkg->delete;
 929       if ( $error ) {
 930         $dbh->rollback if $oldAutoCommit;
 931         return "Error unapplying payment: $error";
 932       }
 933       $unapplied_payments{$invnum}{$cust_bill_pay_pkg->billpaynum}
 934         += $cust_bill_pay_pkg->amount;
 935     }
 936   }
 937
 938   ###
 939   # now loop through %cust_credit_bill and insert those
 940   ###
 941
 942   # (hack to prevent cust_credit_bill_pkg insertion)
 943   local($FS::cust_bill_ApplicationCommon::skip_apply_to_lineitems_hack) = 1;
 944
 945   foreach my $invnum ( sort { $a <=> $b } keys %cust_credit_bill ) {
 946
 947     # if we unapplied any payments from line items, also unapply that
 948     # amount from the invoice
 949     foreach my $billpaynum (keys %{$unapplied_payments{$invnum}}) {
 950       my $cust_bill_pay = FS::cust_bill_pay->by_key($billpaynum)
 951         or die "broken payment application $billpaynum";
 952       my @subapps = $cust_bill_pay->lineitem_applications;
 953       $error = $cust_bill_pay->delete; # can't replace
 954
 955       my $new_cust_bill_pay = FS::cust_bill_pay->new({
 956           $cust_bill_pay->hash,
 957           billpaynum => '',
 958           amount => sprintf('%.2f',
 959               $cust_bill_pay->amount
 960               - $unapplied_payments{$invnum}{$billpaynum}),
 961       });
 962
 963       if ( $new_cust_bill_pay->amount > 0 ) {
 964         $error ||= $new_cust_bill_pay->insert;
 965         # Also reapply it to everything it was applied to before.
 966         # Note that we've already deleted cust_bill_pay_pkg records for the
 967         # items we're crediting, so they aren't on this list.
 968         foreach my $cust_bill_pay_pkg (@subapps) {
 969           $cust_bill_pay_pkg->billpaypkgnum('');
 970           $cust_bill_pay_pkg->billpaynum($new_cust_bill_pay->billpaynum);
 971           $error ||= $cust_bill_pay_pkg->insert;
 972         }
 973       }
 974       if ( $error ) {
 975         $dbh->rollback if $oldAutoCommit;
 976         return "Error unapplying payment: $error";
 977       }
 978     }
 979     #insert cust_credit_bill
 980
 981     my $cust_credit_bill = new FS::cust_credit_bill {
 982       'crednum' => $cust_credit->crednum,
 983       'invnum'  => $invnum,
 984       'amount'  => sprintf('%.2f', $cust_credit_bill{$invnum}),
 985     };
 986     $error = $cust_credit_bill->insert;
 987     if ( $error ) {
 988       $dbh->rollback if $oldAutoCommit;
 989       return "Error applying credit of $cust_credit_bill{$invnum} ".
 990              " to invoice $invnum: $error";
 991     }
 992
 993     #and then insert cust_credit_bill_pkg for each cust_bill_pkg
 994     foreach my $cust_credit_bill_pkg ( @{$cust_credit_bill_pkg{$invnum}} ) {
 995       $cust_credit_bill_pkg->creditbillnum( $cust_credit_bill->creditbillnum );
 996       $error = $cust_credit_bill_pkg->insert;
 997       if ( $error ) {
 998         $dbh->rollback if $oldAutoCommit;
 999         return "Error applying credit to line item: $error";
1000       }
1001     }
1002
1003   }
1004
1005   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1006   '';
1007
1008 }
1009
1010 =back
1011
1012 =head1 SUBROUTINES
1013
1014 =over 4
1015
1016 =item process_batch_import
1017
1018 =cut
1019
1020 use List::Util qw( min );
1021 use FS::cust_bill;
1022 use FS::cust_credit_bill;
1023 sub process_batch_import {
1024   my $job = shift;
1025
1026   my $opt = { 'table'   => 'cust_credit',
1027               'params'  => [ '_date', 'credbatch' ],
1028               'formats' => { 'simple' =>
1029                                [ 'custnum', 'amount', 'reasonnum', 'invnum' ],
1030                            },
1031               'default_csv' => 1,
1032               'postinsert_callback' => sub {
1033                 my $cust_credit = shift; #my ($cust_credit, $param ) = @_;
1034
1035                 if ( $cust_credit->invnum ) {
1036
1037                   my $cust_bill = qsearchs('cust_bill', { invnum=>$cust_credit->invnum } );
1038                   my $amount = min( $cust_credit->credited, $cust_bill->owed );
1039
1040                   my $cust_credit_bill = new FS::cust_credit_bill ( {
1041                     'crednum' => $cust_credit->crednum,
1042                     'invnum'  => $cust_bill->invnum,
1043                     'amount'  => $amount,
1044                   } );
1045                   my $error = $cust_credit_bill->insert;
1046                   return '' unless $error;
1047
1048                 }
1049
1050                 #apply_payments_and_credits ?
1051                 $cust_credit->cust_main->apply_credits;
1052
1053                 return '';
1054
1055               },
1056             };
1057
1058   FS::Record::process_batch_import( $job, $opt, @_ );
1059
1060 }
1061
1062 =back
1063
1064 =head1 BUGS
1065
1066 The delete method.  The replace method.
1067
1068 B<credited> and B<credited_sql> are now called B<unapplied> and
1069 B<unapplied_sql>.  The old method names should start to give warnings.
1070
1071 =head1 SEE ALSO
1072
1073 L<FS::Record>, L<FS::cust_credit_refund>, L<FS::cust_refund>,
1074 L<FS::cust_credit_bill> L<FS::cust_bill>, schema.html from the base
1075 documentation.
1076
1077 =cut
1078
1079 1;
1080