;==File=================================================================;
; PO6100.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=============================================================;
;	po6100		Open orders report by vendor.
;==Changes==============================================================;
; 10/30/1996 tah - Fix problem of some items not being printed.
;=======================================================================;
.subroutine po6100

.start nopage,nolist
.include "UTL:tools.def"
.include "UTS:dteut.def"
.include "POS:dtepo.def"

.include "UTS:utcomm.gbl"
.include "POS:pocomm.gbl"
.include "POS:pohedr.rec"
.include "POS:poline.rec"
.include "INS:incomm.gbl"
.include "NAS:nacomm.gbl"

record	ordidx
	oxvend		,d8		; customer id
	oxlocn		,a3		; location code
	oxitem		,a24		; item number
	oxorno		,d6		; order number
	oxline		,d3		; line number

record	scr_rec1		; input set 1
	scr_strvend	,d8		; starting vendor id
	scr_endvend	,d8		; ending vendor id
	scr_strbuyr	,a3		; starting buyer
	scr_endbuyr	,a3		; ending buyer
	scr_strdate	,d8		; starting date
	scr_enddate	,d8		; ending date
	scr_dayslate	,d3		; days late

record	head1
		,a*	@1,	'----------------VENDOR----------------'
		,a*	@78,	'P.O.'
		,a*	@86,	'DATE'
		,a*	@93,	'REQUIRED'
		,a*	@109,	'QUANTITY'
		,a*	@121,	'QUANTITY'
record	head2
		,a*	@18,	'ITEM-NO'
		,a*	@43,	'DESCRIPTION'
		,a*	@73,	'LOC'
		,a*	@79,	'NO'
		,a*	@85,	'ORDERED'
		,a*	@95,	'DATE'
		,a*	@102,	'UOM'
		,a*	@110,	'ORDERED'
		,a*	@121,	'RECEIVED'
record	legnd1
		,a*	@1,	'COMPANY:'
	lcompy	,a2	@11
record	legnd2
		,a*	@1,	'* DENOTES 1-7 DAYS LATE,'
		,a*	@26,	'** 8-14 DAYS LATE, *** 15+ DAYS LATE'

record	pline
		,a132
record	,X
	prvend		,a8	@1
	prname		,a25	@10
	prphone		,a20	@37
record	,X
	pritem		,a24	@17
	prdesc		,a30	@42
	prlocn		,a3	@73
	prorno		,a6	@77
	prdate		,a8	@84
	prrqdt		,a8	@93
	prbuom		,a3	@102
	prorqt		,a11	@106
	prrcvd		,a11	@118
	prlate		,a3	@130

record	totals
	lorqt		,d9.3		; location total order quantity
	lrcvd		,d9.3		; location total received quantity
	iorqt		,d9.3		; item total order quantity
	ircvd		,d9.3		; item total received quantity
	forqt		,d9.3		; report total order quantity
	frcvd		,d9.3		; report total received quantity
	vorqt		,d9.3		; vendor total order quantity
	vrcvd		,d9.3		; vendor total received quantity

record
	abort		,d1
	amount		,d9.2		; line item dollar amount
	daysw		,d4		; work for computing late days
	eof		,d1		; end of file switch
	latdat		,d8		; work for computing late days
	lines1		,d3		; line item counter 1
	lines2		,d3		; line item counter 2
	lstitm		,a24		; current item id
	lstloc		,a3		; current location code
	lstvnd		,d8		; current vendor id
	mask		,a12,	'Z,ZZZ,ZZZ.XX'
	mask0		,a11,	'ZZZ,ZZZ,ZZX'
	mask3		,a11,	'ZZZ,ZZZ.XXX'
	nocust		,d6		; number of customers printed
	qty		,d9.3		; work area for computing quantity
	recs_read	,d6
	temp_name	,a14		; temp file for sort
	  temp_ext	,a3	@temp_name+11
	trxs		,d6		; transaction count
	title		,a*,	'OPEN PURCHASE ORDERS REPORT - BY VENDOR'
	wdone		,d1
	wind_name	,a*,	'po6100'
	wind_no		,d2		; input window id
	wind_signal	,a31
	work_chan	,d2		; channel for work/sort file
	work_name	,a14,	'WRK:ordidx.ddf'
	  work_ext	,a3	@work_name+11
	wrtcnt		,d6		; 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 ('Open Purchase Orders by Vendor')
		  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 (pohedr_chan,'I:I',pohedr_name)
	xcall open (poline_chan,'I:I',poline_name)
	xcall open (namast_chan,'I:I',namast_name)
	xcall open (smcode_chan,'I:I',smcode_name)
	work_ext = ut_userid
	xcall open (work_chan,'O',work_name)
	return

	;	Close the data files opened for the report
close_files,
	xcall close (work_chan,DTE_PURGE)
	xcall close (pohedr_chan,DTE_CLOSE)
	xcall close (poline_chan,DTE_CLOSE)
	xcall close (namast_chan,DTE_CLOSE)
	xcall close (smcode_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
	if (scr_strvend.gt.scr_endvend) .or.
	&  (scr_endbuyr.ne.ut_all .and. scr_strbuyr.gt.scr_endbuyr) .or.
	&  (scr_strdate.gt.scr_enddate)
	  begin
	    xcall message (DTER_ERR)
	    wdone = FALSE
	  end
	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
	return

	;	Extract data for the report
pull_data,
	abort = FALSE
	xcall status (DTEM_PRC)
	clear recs_read
	xcall statusbar (0,pohedr_chan)
	call pull_work_data
	xcall close (work_chan,DTE_CLOSE)
	if (wrtcnt.eq.0)
	  begin
	    xcall message (DTEPO_OOF,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'
	sort (in=work_name,record=ordidx,
	&  key=(oxvend,oxlocn,oxitem,oxorno,oxline),tempfile=temp_name)
	return

	;	Print the report
print_report,
	xcall status (DTEM_PRT)
	xcall open (work_chan,'I',work_name)
	eof = FALSE
	clear totals
	lstvnd = -1
	lines1 = 1
	repeat
	  begin
	    reads (work_chan,ordidx,print_report_eof)
	    if (oxorno.ne.pom_order)
	      begin
		pom_comp = ut_cmcomp
		pom_order = oxorno
		xcall db_read (pohedr_chan,pohedr,pom_key,0,'M',,,opcde)
		if (opcde.eq.0)
		  begin
		    if (lines1.eq.1)
		      begin
			lstvnd = oxvend
			lstitm = oxitem
			lstloc = oxlocn
			prvend = pom_vend, 'XXXXXXXX'
			prname = pom_name
			xcall phone (pom_phone,prphone)
			call print
			lines1 = 2
		      end
		  end
	      end
	    if (oxvend.ne.lstvnd) call new_vendor
	    if (oxlocn.ne.lstloc) call new_location
	    if (oxitem.ne.lstitm) call new_item
	    pol_comp = pom_comp
	    pol_order = pom_order
	    pol_lineno = oxline
	    xcall db_read (poline_chan,poline,pol_key,0,'M',,,opcde)
	    if (opcde.eq.0) call print_line
	  end
print_report_eof,
	return

	;	Print the report totals
print_report_totals,
	lstvnd = -1
	lstitm = ']]]]]]]]]]]]'
	lstloc = ']]]'
	call new_vendor
	clear pline
	prdesc = 'FINAL TOTALS:'
	case in_cmqdec of
	  begincase
	  0: begin
	      prorqt = forqt, mask0
	      prrcvd = frcvd, mask0
	     end
	  3: begin
	      prorqt = forqt, mask3
	      prrcvd = frcvd, mask3
	     end
	  endcase
	call print
	return

	;	pull records to work file
pull_work_data,
	clear wrtcnt
	xcall db_find (pohedr_chan,ut_cmcomp,0,'M',,,opcde)
	repeat
	  begin
	    xcall db_next (pohedr_chan,pohedr,'F','M',,,opcde)
	    if (opcde) .or.
	    &  (pom_comp.ne.ut_cmcomp) return
	    incr recs_read
	    if (.not.recs_read(5:2)) xcall statusbar (recs_read)
	    if (pom_status.ne.'C' .and. pom_status.ne.'D') .and.
	    &  (pom_vend.ge.scr_strvend) .and.
	    &  (pom_vend.le.scr_endvend) .and.
	    &  (scr_strbuyr.eq.ut_all .or. pom_buyrcode.ge.scr_strbuyr) .and.
	    &  (scr_endbuyr.eq.ut_all .or. pom_buyrcode.le.scr_endbuyr) .and.
	    &  (pom_orddate.ge.scr_strdate .and. pom_orddate.le.scr_enddate)
		call pull_lines
	  end

pull_lines,
	xcall db_find (poline_chan,pom_key,0,'M',,,opcde)
	repeat
	  begin
	    xcall db_next (poline_chan,poline,'F','M',,,opcde)
	    if (opcde) .or.
	    &  (pol_key.ne.pom_key) return
	    if (pol_linetype.ne.'R') .and.
	    &  (pol_status.ne.'C' .and. pol_status.ne.'D') .and.
	    &  (pol_ordqty - pol_recpqty - pol_recuqty.gt.0)
	      begin
		daysw = scr_dayslate
		clear latdat
		xcall dyadd (pol_reqdate,daysw,latdat)
		if (daysw.le.0 .or. latdat.le.ut_datfil)
		  begin
		    oxvend = pom_vend
		    oxlocn = pol_locncode
		    oxitem = pol_item
		    oxorno = pom_order
		    oxline = pol_lineno
		    incr wrtcnt
		    writes (work_chan,ordidx)
		  end
	      end
	  end

print_line,
	pritem = pol_item
	prdesc = pol_descr
	prlocn = pol_locncode
	prorno = pom_order, 'XXXXXX'
	xcall dtdsp (pom_orddate,prdate)
	xcall dtdsp (pol_reqdate,prrqdt)
	prbuom = pol_buomcode
	case in_cmqdec of
	  begincase
	  0: begin
	      prorqt = pol_ordqty, mask0
	      prrcvd = (pol_recpqty + pol_recuqty), mask0
	     end
	  3: begin
	      prorqt = pol_ordqty, mask3
	      prrcvd = (pol_recpqty + pol_recuqty), mask3
	     end
	  endcase
	if (pol_reqdate.lt.ut_datfil)
	  begin
	    clear daysw
	    xcall dyadd (pol_reqdate,daysw,ut_datfil)
	    if (daysw.gt.0) prlate = '*'
	    if (daysw.gt.7) prlate = '**'
	    if (daysw.gt.14) prlate = '***'
	  end
	call print
	incr lines1
	incr lines2
	lorqt = lorqt + pol_ordqty
	lrcvd = lrcvd + (pol_recpqty + pol_recuqty)
	iorqt = iorqt + pol_ordqty
	ircvd = ircvd + (pol_recpqty + pol_recuqty)
	vorqt = vorqt + pol_ordqty
	vrcvd = vrcvd + (pol_recpqty + pol_recuqty)
	forqt = forqt + pol_ordqty
	frcvd = frcvd + (pol_recpqty + pol_recuqty)
	return

	;	new item number
new_item,
	if (lstitm.ne.oxitem .and. lines2.gt.1)
	  begin
	    prdesc = 'ITEM TOTAL:'
	    case in_cmqdec of
	      begincase
	      0: begin
		  prorqt = iorqt, mask0
		  prrcvd = ircvd, mask0
		 end
	      3: begin
		  prorqt = iorqt, mask3
		  prrcvd = ircvd, mask3
		 end
	      endcase
	    call print
	  end
	clear iorqt, ircvd, lines2
	lstitm = oxitem
	return

	;	new location
new_location,
	call new_item
	if (lstloc.ne.oxlocn .or. lstitm.ne.oxitem .or. lstvnd.ne.oxvend)
	  begin
	    prdesc = 'LOCATION TOTAL:'
	    case in_cmqdec of
	      begincase
	      0: begin
		  prorqt = lorqt, mask0
		  prrcvd = lrcvd, mask0
		 end
	      3: begin
		  prorqt = lorqt, mask3
		  prrcvd = lrcvd, mask3
		 end
	      endcase
	    call print
	  end
	clear lorqt, lrcvd
	lstloc = oxlocn
	return

	;	new vendor
new_vendor,
	call new_location
	if (lstvnd.eq.oxvend) return
	if (vorqt.gt.0 .or. vrcvd.gt.0)
	  begin
	    prdesc = 'VENDOR TOTAL:'
	    case in_cmqdec of
	      begincase
	      0: begin
	    	  prorqt = vorqt, mask0
		  prrcvd = vrcvd, mask0
		 end
	      3: begin
		  prorqt = vorqt, mask3
		  prrcvd = vrcvd, mask3
		 end
	      endcase
	    call print
	    call print
	  end
	clear vorqt, vrcvd
	prvend = pom_vend, 'XXXXXXXX'
	prname = pom_name
	xcall phone (pom_phone,prphone)
	if (lstvnd.ne.-1) call print
	lstvnd = oxvend
	return

	;	Print a detail line of the report
print,
	xcall print (pline,title,head1,head2,,legnd1,legnd2)
	clear pline
	if (lp_cnt.eq.-1)
	  begin
	    call close_files
	    call do_shutdown
	    xreturn		; to calling program
	  end
	return
.end

