;==File=================================================================;
; AP6900.DBL
;=======================================================================;
; Copyright 1999 by TAH Software Systems (TAH), Oklahoma City, Oklahoma ;
;									;
;	TAH provides this software under a license and may only be	;
;	used in accordance with the terms and conditions of such	;
;	license and with the inclusion of the above Copyright notice.	;
;==Function=============================================================;
;	ap6900		A/P balancing report.
;==Changes==============================================================;
; 04/03/2009 wmc - Fix discounts to look at cut-off date, too
; 08/23/2000 tah - Lengthen invoice number to 12 characters.
; 01/16/1996 tah - Add discounts on checks from history.
; 03/04/1996 tah - Fix report for partial payments.
; 12/11/1997 tah - Fix discounts and future distribution dates.
; 12/18/1997 tah - Fix summary future invoices and current payments.
;=======================================================================;
.subroutine ap6900

.start nopage,nolist
.include "UTL:tools.def"
.include "UTS:dteut.def"
.include "APS:dteap.def"

.include "UTS:utcomm.gbl"
.include "NAS:nacomm.gbl"
.include "NAS:namast.rec"
.include "APS:apcomm.gbl"
.include "APS:apopen.rec"
.include "APS:aphist.rec"

record	apoidx
	apox_vend	,d8		; vendor id
	apox_sort	,a10		; vendor sort name
	apox_dist	,d8		; distribution date
	apox_file	,a1		; open or history file
	apox_vch	,d6		; voucher number
	apox_inno	,a12		; invoice number
	apox_indt	,d8		; invoice date
	apox_dudt	,d8		; due date
	apox_amnt	,d9.2		; invoice amount
	apox_damt	,d8.2		; discount amount
	apox_ckdt	,d8		; check date
	apox_ckno	,d6		; check number
	apox_pamt	,d9.2		; payment amount
	apox_void	,d9.2		; void amount
	apox_pdist	,d8		; payment distribution date

record	head1
		,a*	@3,	'VOUCHER'
		,a*	@14,	'INVOICE'
		,a*	@29,	'DISTRIB'
		,a*	@40,	'INVOICE'
		,a*	@54,	'INVOICE'
		,a*	@67,	'DISCOUNT'
		,a*	@86,	'NET'
		,a*	@92,	'------------CHECK------------'
record	head2
		,a*	@5,	'NO'
		,a*	@16,	'NO'
		,a*	@30,	'DATE'
		,a*	@41,	'DATE'
		,a*	@55,	'AMOUNT'
		,a*	@69,	'AMOUNT'
		,a*	@83,	'AMOUNT'
		,a*	@95,	'DATE'
		,a*	@105,	'NO'
		,a*	@116,	'AMOUNT'

record	head3
		,a*	@3,	'VOUCHER'
		,a*	@14,	'INVOICE'
		,a*	@29,	'DISTRIB'
		,a*	@40,	'INVOICE'
		,a*	@53,	'DUE'
		,a*	@69,	'INVOICE'
		,a*	@81,	'-------------------AGED TOTALS-------------------'
record	head4
		,a*	@5,	'NO'
		,a*	@16,	'NO'
		,a*	@30,	'DATE'
		,a*	@41,	'DATE'
		,a*	@52,	'DATE'
		,a*	@70,	'AMOUNT'
	hage1a	,a3	@82
		,a*	@86,	'-'
	hage1b	,a3	@88
	hage2a	,a3	@95
		,a*	@99,	'-'
	hage2b	,a3	@101
	hage3a	,a3	@108
		,a*	@112,	'-'
	hage3b	,a3	@114
		,a*	@121,	'OVER'
	hage4	,a3	@127

record	legnd1
		,a*	@1,     'AS OF:'
	ldate1	,a10	@8
record	legnd2
		,a*	@1,     'COMPANY:'
	lcompy	,a2	@11

record	pline
		,a132
record	,X
	prvend		,a8	@1
	prname		,a30	@10
record	,X
	prvch		,a6	@4
	prinno		,a12	@12
	prdist		,a10	@27
	prindt		,a10	@38
	pramnt		,a13	@49
	prdamt		,a13	@63
	prnet		,a13	@77
	prckdt		,a10	@92
	prckno		,a6	@103
	prpamt		,a13	@110
record	,X
	prdudt		,a10	@49
	prtotl		,a12	@65
	pramt1		,a12	@80
	pramt2		,a12	@93
	pramt3		,a12	@106
	pramt4		,a12	@119
	prpaid		,a1	@132

record	totals
	vamt1		,d10.2		; vendor age 1 total
	vamt2		,d10.2		; vendor age 2 total
	vamt3		,d10.2		; vendor age 3 total
	vamt4		,d10.2		; vendor age 4 total
	vamnt		,d10.2		; vendor total
	vdamt		,d10.2		; vendor discount total
	vpamt		,d10.2		; vendor payment total
	vlines		,d4		; vendor items printed
	tamt1		,d10.2		; report age 1 total
	tamt2		,d10.2		; report age 2 total
	tamt3		,d10.2		; report age 3 total
	tamt4		,d10.2		; report age 4 total
	tamnt		,d10.2		; report total
	tdamt		,d10.2		; report discount total
	tpamt		,d10.2		; report payment total

record	scr_rec1		; input set 1
	scr_cutoff	,d8		; cut off date for records
	scr_rpttyp	,a1		; Summary or Detail
	scr_agerpt	,a1		; Aged report (Y/N)
	scr_sortby	,a1		; Id or Name

record
	abort		,d1
	age_date	,d8		; work area for invoice/due date
	amt1		,d10.2		; work area for age 1
	amt2		,d10.2		; work area for age 2
	amt3		,d10.2		; work area for age 3
	amt4		,d10.2		; work area for age 4
	cur_vend	,d8		; current vendor id
	cycle1		,d8		; age 1 cutoff date
	cycle2		,d8		; age 2 cutoff date
	cycle3		,d8		; age 3 cutoff date
	cycle4		,d8		; age 4 cutoff date
	days		,d3		; work area
	eof		,d1		; end of file switch
        iamnt   	,d9.2		; net invoice amount
	mask		,a12,	'ZZZZZZZZ.XX-'
	novend		,d5		; number of vendors printed
	print_line	,d1		; print the line switch
	recs_read	,d6
	save_key	,a16		; history file key
	temp_name	,a14		; temp file for sort
	  temp_ext	,a3	@temp_name+11
	trxs		,d5		; transaction count
	title		,a*,	'ACCOUNTS PAYABLE BALANCING REPORT'
	wdone		,d1
	wind_name	,a*,	'ap6900'
	wind_no		,d2		; input window id
	wind_signal	,a31
	work_chan	,d2		; channel for work/sort file
	work_name	,a14,	'WRK:ap6900.ddf'
	  work_ext	,a3	@work_name+11
	wrtcnt		,d5		; count of records written to work file
.start nopage,list

.proc
	;>>>>>	Main processing  <<<<<;
	call do_setup
	call open_files
	call get_parameters
	if (abort.eq.FALSE)
	  begin
	    call get_destination
	    if (abort.eq.FALSE)
	      begin
		call pull_data
		if (abort.eq.FALSE)
		  begin
		    call sort_data
		    call print_report
		    call print_report_totals
		    xcall clslp ('A/P Balancing Report')
		  end
	      end
	  end
	call close_files
	call do_shutdown
	xreturn		; to calling program

	;>>>>>	End of main processing  <<<<<;

	;	Set up environment
do_setup,
	xcall e_enter
	xcall lodcol ('RL')		; remove local columns
	xcall lodtoolbar ('AB',8)
	return

	;	Shut down environment
do_shutdown,
	xcall lodtoolbar ('RB',8)
	xcall e_exit
	return

	;	Open the needed data files
open_files,
	xcall open (apopen_chan,'I:I',apopen_name)
	xcall open (aphist_chan,'I:I',aphist_name)
	xcall open (namast_chan,'I:I',namast_name)
	return

	;	Close the data files opened for the report
close_files,
	xcall close (work_chan,DTE_CLOSE)
	xcall close (apopen_chan,DTE_CLOSE)
	xcall close (aphist_chan,DTE_CLOSE)
	xcall close (namast_chan,DTE_CLOSE)
	return

	;	Get the report selection parameters
get_parameters,
	repeat
	  begin
	    xcall get_parameters (wind_no,wind_name,'set1',scr_rec1,abort,wind_signal)
	    if (abort.eq.TRUE) exitloop
	    if (wind_signal)
	     then call process_signal
	     else
	      begin
		call verify_input_parameters
		if (wdone.eq.TRUE) exitloop
	      end
	  end
	return

	;	Process any break signals
process_signal,
	case g_entnam of
	  begincase
	  '@': nop
	  endcase
	return

verify_input_parameters,
	wdone = TRUE
	return

	;	Get the output destination
get_destination,
	abort = FALSE
	lcompy = ut_cmcomp
	clear lp_sel
	xcall askpr (ut_cmname,132,61,0,ut_cmdefp)
	if (lp_sel.eq.'E') abort = TRUE
	xcall dtdsp (scr_cutoff,ldate1)
	return

	;	Extract data for the report
pull_data,
	abort = FALSE
	xcall status (DTEM_BWF)
	clear wrtcnt
	work_ext = ut_userid
	xcall open (work_chan,'O',work_name)
	call pull_apopen_data
	call pull_aphist_data
	xcall close (work_chan,DTE_CLOSE)
	if (wrtcnt.eq.0)
	  begin
	    xcall message (DTEAP_NTF,D_ERROR)
	    abort = TRUE
	  end
	return

	;	Sort the extracted data
sort_data,
	xcall status (DTEM_SRT)
	temp_name = work_name
	temp_ext = ut_cmterm, 'XXX'
	case scr_sortby of
	  begincase
	  'I': sort (in=work_name,record=apoidx,
	      & key=(apox_vend,apox_vch,apox_dist),tempfile=temp_name)
	  'N': sort (in=work_name,record=apoidx,
	      & key=(apox_sort,apox_vend,apox_vch,apox_dist),tempfile=temp_name)
	  endcase
	return

	;	Print the report
print_report,
	xcall status (DTEM_PRT)
	xcall open (work_chan,'I',work_name)
	eof = FALSE
	clear totals,cur_vend
	if (scr_agerpt.eq.'Y') call create_heads

	repeat
	  begin
	    reads (work_chan,apoidx,print_report_eof)
	    print_line = FALSE
	    if (apox_pdist.ne.0)
	     then
	      begin
	        if ((apox_pdist.gt.scr_cutoff) .and. (apox_dist.gt.scr_cutoff))
		 & nextloop
	      end
	     else
	      begin
		if (apox_dist.gt.scr_cutoff) nextloop
	      end
	    if (apox_vend.ne.cur_vend) call new_vendor

	    prvch = apox_vch, 'XXXXXX'
	    prinno = apox_inno
	    xcall dtdsp (apox_indt,prindt)
	    xcall dtdsp (apox_dist,prdist)
	    clear iamnt
	    case scr_agerpt of
	      begincase
	      'N': begin
		    if (apox_dist.le.scr_cutoff)
		      begin
			iamnt = apox_amnt			;;; 2/5/96
			pramnt = iamnt, mask
			prdamt = apox_damt, mask
			prnet = (iamnt - apox_damt), mask
			print_line = TRUE
		      end
		    if (apox_pamt.ne.0)
		      begin
			xcall dtdsp (apox_ckdt,prckdt)
			prckno = apox_ckno
			prpamt = apox_pamt, mask
			print_line = TRUE
		      end
		   end
	      'Y': begin
		    if (apox_dist.le.scr_cutoff) then
		      begin
			iamnt = apox_amnt - apox_pamt	;;; 2/5/96
			call age_amounts
			xcall dtdsp (apox_dudt,prdudt)
			if (amt1) pramt1 = amt1, mask
			if (amt2) pramt2 = amt2, mask
			if (amt3) pramt3 = amt3, mask
			if (amt4) pramt4 = amt4, mask
			if (apox_pamt.ne.0) prpaid = '*'
			print_line = TRUE
		      end
		     else
		      begin			; future payment
			iamnt = -apox_pamt
			call age_amounts
			if (amt1) pramt1 = amt1, mask
			if (amt2) pramt2 = amt2, mask
			if (amt3) pramt3 = amt3, mask
			if (amt4) pramt4 = amt4, mask
			print_line = TRUE
		      end
		   end
	      endcase
	    if (scr_rpttyp.eq.'D')
	      begin
		if (print_line.eq.TRUE) then
		  begin
		    call print
		    incr vlines
		  end
		 else clear pline
	      end
	    incr trxs
	    vamnt = vamnt + iamnt
	    tamnt = tamnt + iamnt
	    vpamt = vpamt + apox_pamt
	    tpamt = tpamt + apox_pamt
	    vdamt = vdamt + apox_damt
	    tdamt = tdamt + apox_damt
	  end
print_report_eof,
	return

	;	Print the report totals
print_report_totals,
	eof = TRUE
	call new_vendor
	call print
	prname = 'GRAND TOTALS:'
	case scr_agerpt of
	  begincase
	  'N': begin
		pramnt = tamnt, mask
		prdamt = tdamt, mask
		prnet = (tamnt - tdamt), mask
		prpamt = tpamt, mask
	       end
	  'Y': begin
		prtotl = tamnt, mask
		pramt1 = tamt1, mask
		pramt2 = tamt2, mask
		pramt3 = tamt3, mask
		pramt4 = tamt4, mask
	       end
	  endcase
	call print
	case scr_agerpt of
	  begincase
	  'N': begin
		prname = 'OUTSTANDING:'
		pramnt = tamnt - tpamt, mask
		prnet = (tamnt - tdamt) - tpamt, mask
		call print
	       end
	  endcase
	return

	;	pull open records to work file
pull_apopen_data,
	clear recs_read
	xcall statusbar (0,apopen_chan)
	xcall db_find (apopen_chan,ut_cmcomp,0,'M',,,opcde)
	repeat
	  begin
	    xcall db_next (apopen_chan,apopen,'F','M',,,opcde)
	    incr recs_read
	    if (.not.recs_read(5:2)) xcall statusbar (recs_read)
	    if (opcde) .or.
	    &  (apo_comp.gt.ut_cmcomp) return

	    if (apo_date.le.scr_cutoff) .and.
	    &  (apo_ckdt.le.scr_cutoff)		;;; added 2/13/1997
	      begin
		apox_vend = apo_vend
		if (nam_id.ne.apo_vend)
		  begin
		    nam_comp = na_cmuseco
		    nam_id = apox_vend
		    xcall na_get_name (namast,,,,,,,,,1)
		    if (opcde) nam_sort = apox_vend
		  end
		apox_sort = nam_sort
		apox_dist = apo_date
		apox_file = 'O'
		apox_vch = apo_vch
		apox_inno = apo_inno
		apox_indt = apo_indt
		apox_dudt = apo_due
		apox_amnt = apo_amnt
		apox_damt = apo_damt
		clear apox_ckdt,apox_ckno,apox_pamt
		incr wrtcnt
		writes (work_chan,apoidx)
	      end
	  end

	;	pull history records to work file
pull_aphist_data,
	clear recs_read
	xcall statusbar (0,aphist_chan)
	clear save_key
	xcall db_find (aphist_chan,ut_cmcomp,0,'M',,,opcde)
	repeat
	  begin
	    xcall db_next (aphist_chan,aphist,'F','M',,,opcde)
	    incr recs_read
	    if (.not.recs_read(5:2)) xcall statusbar (recs_read)
	    if (opcde) .or.
	    &  (aph_comp.gt.ut_cmcomp)
	      begin
		if (apox_pdist.gt.scr_cutoff) .and.	; process last record
		&  (apox_dist.le.scr_cutoff)
		  begin
		    writes (work_chan,apoidx)
		    incr wrtcnt
		  end
		return
	      end
	    if (aph_key.ne.save_key)
	      begin
		if ((apox_pdist.gt.scr_cutoff) .and.
		&   (apox_dist.le.scr_cutoff)) .or.
		&  ((apox_pdist.le.scr_cutoff) .and.	;;; new
		&   (apox_dist.gt.scr_cutoff))		;;; new
		  begin
		    writes (work_chan,apoidx)
		    incr wrtcnt
		  end
		clear apoidx
		save_key = aph_key
	      end
	    case aph_type of
	      begincase
	      1: begin			; invoice
		  call set_hist_work
		  apox_amnt = apox_amnt + aph_amnt
		  apox_damt = apox_damt + aph_damt
		 end
	      3: begin			; DR memo
		  if (apox_vend.eq.0) call set_hist_work
		  apox_amnt = apox_amnt + aph_amnt
		  apox_damt = apox_damt + aph_damt
		 end
	      4: begin			; check
		  if (apox_vend.eq.0) call set_hist_work
		  if (aph_dist.gt.apox_pdist) apox_pdist = aph_dist
		  if (aph_dist.le.scr_cutoff)
		    begin
		      if (aph_ckdt.gt.apox_ckdt) apox_ckdt = aph_ckdt
		      apox_ckno = aph_ckno
		      apox_pamt = apox_pamt + aph_amnt
		    end
		 end
	      9: begin			; void check
		  if (apox_vend.eq.0) call set_hist_work
		  apox_void = apox_void + aph_amnt
		  apox_pdist = aph_dist
		  if (apox_pdist.gt.scr_cutoff)
			apox_amnt = apox_amnt + aph_amnt
		 end
	      endcase
	  end

	;	set history record into work record
set_hist_work,
	apox_vend = aph_vend
	if (nam_id.ne.apox_vend)
	  begin
	    nam_comp = na_cmuseco
	    nam_id = apox_vend
	    xcall na_get_name (namast,,,,,,,,,1)
	    if (opcde) nam_sort = apox_vend
	  end
	apox_sort = nam_sort
	apox_dist = aph_dist
	apox_file = 'H'
	apox_vch = aph_vch
	apox_inno = aph_inno
	apox_indt = aph_indt
	apox_dudt = aph_due
	clear apox_amnt,apox_damt,apox_ckdt,apox_ckno,apox_pamt,apox_pdist
	return

new_vendor,
	if (cur_vend)
	  begin
	    if (scr_rpttyp.eq.'D')
	     then prname = 'VENDOR TOTALS:'
	     else
	      begin
		clear pline
		prvend = nam_id
		prname = nam_name
	      end
	    case scr_agerpt of
	      begincase
	      'N': begin
		    vlines = 1
		    pramnt = vamnt, mask
		    prdamt = vdamt, mask
		    prnet = (vamnt - vdamt), mask
		    prpamt = vpamt, mask
		   end
	      'Y': begin
		    vlines = 1
		    prtotl = vamnt, mask
		    pramt1 = vamt1, mask
		    pramt2 = vamt2, mask
		    pramt3 = vamt3, mask
		    pramt4 = vamt4, mask
		    if (vamt1.eq.0) .and.
		    &  (vamt2.eq.0) .and.
		    &  (vamt3.eq.0) .and.
		    &  (vamt4.eq.0) clear vlines
		   end
	      endcase
	    if (vlines) .or.			; lines printed
	    &  (scr_rpttyp.eq.'S') 		; summary report
	      begin
		if (vlines)
		  begin
		    call print			; print data line
		    call print			; print blank line
		  end
	      end
	    clear pline
	  end
	clear vamt1, vamt2, vamt3, vamt4, vamnt, vdamt, vpamt, vlines
	if (eof.eq.FALSE)
	  begin
	    nam_comp = na_cmuseco
	    nam_id = apox_vend
	    xcall na_get_name (namast,,,,,,,,,1)
	    if (opcde) nam_id = apox_vend
	    if (scr_rpttyp.eq.'D')
	      begin
		prvend = nam_id
		prname = nam_name
		call print
	      end
	    cur_vend = apox_vend
	  end
	return

	;	create report headings
create_heads,
	hage1a = '  1'
	days = ap_cmage1
	if (days.eq.0) days = 30
	hage1b = days, 'ZZX'
	hage2a = days + 1, 'ZZX'
	days = -days
	xcall dyadd (scr_cutoff,days,cycle1)

	days = ap_cmage2
	if (days.eq.0) days = 60
	hage2b = days, 'ZZX'
	hage3a = days+1, 'ZZX'
	days = -days
	xcall dyadd (scr_cutoff,days,cycle2)

	days = ap_cmage3
	if (days.eq.0) days = 90
	hage3b = days, 'ZZX'
	hage4 = days, 'ZZX'
	days = -days
	xcall dyadd (scr_cutoff,days,cycle3)

	days = ap_cmage4
	if (days.eq.0) days = 91
	days = -(days-1)
	xcall dyadd (scr_cutoff,days,cycle4)
	return

	;	place invoice amount into correct aging period
age_amounts,
	clear amt1, amt2, amt3, amt4

	age_date = apox_dudt
	if (ap_cmageby.eq.'I') age_date = apox_indt
	if (age_date.ge.cycle1) then
	  begin
	    amt1 = iamnt
	    vamt1 = vamt1 + iamnt
	    tamt1 = tamt1 + iamnt
	  end
	 else
	  if (age_date.ge.cycle2) then
	    begin
	      amt2 = iamnt
	      vamt2 = vamt2 + iamnt
	      tamt2 = tamt2 + iamnt
	    end
	   else
	    if (age_date.ge.cycle3) then
	      begin
		amt3 = iamnt
		vamt3 = vamt3 + iamnt
		tamt3 = tamt3 + iamnt
	      end
	     else
	      begin
		amt4 = iamnt
		vamt4 = vamt4 + iamnt
		tamt4 = tamt4 + iamnt
	      end
	return

	;	Print a detail line of the report
print,
	case scr_agerpt of
	  begincase
	  'N': xcall print (pline,title,head1,head2,,legnd1,legnd2)
	  'Y': xcall print (pline,title,head3,head4,,legnd1,legnd2)
	  endcase
	clear pline
	if (lp_cnt.eq.-1)
	  begin
	    call close_files
	    call do_shutdown
	    xreturn		; to calling program
	  end
	return
.end