;==File=================================================================;
; PO6800.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=============================================================;
;	po6800		Purchase order history report.
;==Changes==============================================================;
; 11/12/1996 tah - Fix problem with totals ordered.
; 11/07/1996 tah - Add unit cost to report.
;=======================================================================;
.subroutine po6800

.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:pohist.rec"
.include "POS:pohsln.rec"
.include "NAS:nacomm.gbl"
.include "NAS:namast.rec"
.include "INS:incomm.gbl"

record	head1i
		,a*	@4,	'ITEM-ID'
		,a*	@29,	'DESCRIPTION'
		,a*	@64,	'ORDER'
		,a*	@72,	'RECEIVED'
		,a*	@91,	'QUANTITY'
record	head2i
		,a*	@10,	'VENDOR'
		,a*	@17,	'NAME'
		,a*	@43,	'VEND-ITEM'
		,a*	@56,	'ORDER'
		,a*	@65,	'DATE'
		,a*	@74,	'DATE'
		,a*	@81,	'LOC'
		,a*	@85,	'UOM'
		,a*	@92,	'ORDERED'
		,a*	@102,	'RECEIVED'
		,a*	@112,	'UNIT-COST'
		,a*	@122,	'TOTAL-COST'
record	head1v
		,a*	@1,	'VENDOR'
		,a*	@10,	'NAME'
		,a*	@64,	'ORDER'
		,a*	@72,	'RECEIVED'
		,a*	@91,	'QUANTITY'
		,a*	@102,	'QUANTITY'
record	head2v
		,a*	@4,	'ITEM-ID'
		,a*	@19,	'DESCRIPTION'
		,a*	@43,	'VEND-ITEM'
		,a*	@56,	'ORDER'
		,a*	@65,	'DATE'
		,a*	@74,	'DATE'
		,a*	@81,	'LOC'
		,a*	@85,	'UOM'
		,a*	@92,	'ORDERED'
		,a*	@102,	'RECEIVED'
		,a*	@112,	'UNIT-COST'
		,a*	@122,	'TOTAL-COST'

record	legnd1
		,a*	@1,	'COMPANY:'
	lcompy	,a2	@11

record	pline
		,a132
record	,X
	prvend		,a8	@1
	prname		,a30	@10
record	,X
	pritem		,a24	@4
	prdesc		,a30	@29
record	,X
	prvnum		,a6	@10
	prvnam		,a25	@17
	prvnid		,a12	@43
	prorno		,a6	@56
	prdate		,a8	@63
	prrcdt		,a8	@72
	prlocn		,a3	@81
	prbuom		,a3	@85
	prorqt		,a10	@89
	prrcqt		,a10	@100
	prucost		,a10	@110
	prcost		,a12	@121
record	,X
	prt_slno	,a20	@75
	prt_units	,a10	@100

record	totals
	vorqt		,d9.3		; vendor quantity ordered
	vrcqt		,d9.3		; vendor quantity received
	vrjqt		,d9.3		; vendor quantity rejected
	vcost		,d9.3		; vendor cost
	forqt		,d9.3		; report quantity ordered
	frcqt		,d9.3		; report quantity received
	frjqt		,d9.3		; report quantity rejected
	fcost		,d9.3		; report cost
	iorqt		,d9.3		; item quantity ordered
	ircqt		,d9.3		; item quantity received
	irjqt		,d9.3		; item quantity rejected
	icost		,d9.3		; item cost

record	scr_rec1		; input set 1
	scr_strvend	,d8		; starting vendor
	scr_endvend	,d8		; ending vendor
	scr_stritem	,a24		; starting item
	scr_enditem	,a24		; ending item
	scr_locncode	,a3		; location code
	scr_strdate	,d8		; starting date
	scr_enddate	,d8		; ending date
	scr_rptseq	,a1		; report sequence
	scr_stock	,a1		; stock/non-stock/both
	scr_incsnl	,a1		; include serial numbers

record
	abort		,d1
	cost		,d9.3		; cost amount
	eof		,d1		; end of file flag
	hldorder	,d6		; prior order number
	incitm		,a1		; item printed switch
	lstvend		,d8		; current vendor
	lstitem		,a24		; current item
	mask		,a12,	'ZZZZ,ZZZ.XX-'
	mask0		,a11,	'   ZZZ,ZZX-'
	mask3		,a11,	'ZZZZZZ.XXX-'
	price		,d9.3		; price amount
	recs_read	,d6
	title		,a*,	'PURCHASE ORDER HISTORY REPORT'
	wdone		,d1
	wind_name	,a*,	'po6800'
	wind_no		,d2		; input window id
	wind_signal	,a31
.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 print_report
		call print_report_totals
		xcall clslp ('Purchase Order History Report')
	      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 (pohist_chan,'I:I',pohist_name)
	xcall open (pohsln_chan,'I:I',pohsln_name)
	xcall open (initem_chan,'I:I',initem_name)
	xcall open (namast_chan,'I:I',namast_name)
	xcall open (smcode_chan,'I:I',smcode_name)
	return

	;	Close the data files opened for the report
close_files,
	xcall close (pohist_chan,DTE_CLOSE)
	xcall close (pohsln_chan,DTE_CLOSE)
	xcall close (initem_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_rptseq.eq.ut_blanks) scr_rptseq = 'V'
	if ((scr_enditem.ne.UT_ALL .and. scr_stritem.gt.scr_enditem) .or.
	&   (scr_strvend.gt.scr_endvend) .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

	;	Print the report
print_report,
	xcall status (DTEM_PRT)
	clear recs_read
	xcall statusbar (0,pohist_chan)
	clear totals, poh_key
	incitm = FALSE
	eof = FALSE
	lstitem = UT_ALL
	lstvend = -1
	hldorder = -1

	poh_comp = ut_cmcomp
	poh_vend = scr_strvend
	poh_item = scr_stritem
	clear poh_order
	case scr_rptseq of
	  begincase
	  'V': xcall db_find (pohist_chan,poh_key,0,'M',,,opcde)
	  'I': xcall db_find (pohist_chan,scr_stritem,1,'M',,,opcde)
	  endcase
	repeat
	  begin
	    xcall db_next (pohist_chan,pohist,'F','M',,,opcde)
	    if (opcde) .or.
	    &  (scr_rptseq.eq.'V' .and.
	    &   (poh_comp.ne.ut_cmcomp .or. poh_vend.gt.scr_endvend)) .or.
	    &  (scr_rptseq.eq.'I' .and.
	    &   (scr_enditem.ne.UT_ALL .and. poh_item.gt.scr_enditem)) return
	    incr recs_read
	    if (.not.recs_read(5:2)) xcall statusbar (recs_read)

	    if (poh_linetype.eq.'I') incitm = 'N'
	    if (poh_comp.eq.ut_cmcomp) .and.
	    &  (poh_vend.ge.scr_strvend) .and.
	    &  (poh_vend.le.scr_endvend) .and.
	    &  (scr_stritem.eq.UT_ALL .or. poh_item.ge.scr_stritem) .and.
	    &  (scr_enditem.eq.UT_ALL .or. poh_item.le.scr_enditem) .and.
	    &  (scr_locncode.eq.UT_ALL .or. poh_locncode.eq.scr_locncode) .and.
	    &  (poh_recdate.ge.scr_strdate .and. poh_recdate.le.scr_enddate) .and.
	    &  (scr_stock.eq.'B' .or. scr_stock.eq.poh_linetype)
	      begin
		call print_line
		hldorder = poh_order
	      end
	  end

	;	Print the report totals
print_report_totals,
	eof = TRUE
	case scr_rptseq of
	  begincase
	  'V': call vendor_totals
	  'I': call item_totals
	  endcase
	prdesc = 'FINAL TOTALS:'
	case in_cmqdec of
	  begincase
	  0: begin
	      if (scr_rptseq.eq.'I') prorqt = forqt, mask0
	      prrcqt = frcqt, mask0
	     end
	  3: begin
	      if (scr_rptseq.eq.'I') prorqt = forqt, mask3
	      prrcqt = frcqt, mask3
	     end
	  endcase
	prcost = fcost, mask
	call print
	if (frjqt)			; print rejects
	  begin
	    case in_cmqdec of
	      begincase
	      0: prrcqt = frjqt, mask0
	      3: prrcqt = frjqt, mask3
	      endcase
	    prrcqt(10:1) = 'X'
	    call print
	  end
	return

print_line,
	case scr_rptseq of
	  begincase
	  'V': begin
		if (poh_vend.ne.lstvend)
		  begin
		    call vendor_totals
		    if (nam_id.ne.poh_vend)
		      begin
			nam_comp = na_cmuseco
			nam_id = poh_vend
			xcall na_get_name (namast)
		      end
		    prvend = poh_vend, 'XXXXXXXX'
		    prname = nam_name
		    call print
		    pritem = poh_item
		    prdesc = poh_descr
		    call print
		  end
		if (poh_item.ne.lstitem)
		  begin
		    call item_totals
		    pritem = poh_item
		    prdesc = poh_descr
		    call print
		  end
	       end
	  'I': begin
		if (poh_item.ne.lstitem)
		  begin
		    call item_totals
		    pritem = poh_item
		    prdesc = poh_descr
		    call print
		  end
	       end
	  endcase
	call print_item
	if (scr_incsnl.eq.'Y') call print_serial_lot
	return

	;	print the item
print_item,
	if (scr_rptseq.eq.'I')
	  begin
	    if (nam_id.ne.poh_vend)
	      begin
		nam_comp = na_cmuseco
		nam_id = poh_vend
		xcall na_get_name (namast)
	      end
	    prvnum = poh_vend
	    prvnam = nam_name
	  end
	prvnid = poh_vendpn
	prorno = poh_order, 'XXXXXX'
	xcall dtdsp (poh_orddate,prdate)
	xcall dtdsp (poh_recdate,prrcdt)
	prlocn = poh_locncode
	prbuom = poh_buomcode
	case in_cmqdec of
	  begincase
	  0: begin
	      prorqt = poh_ordqty, mask0
	      prrcqt = poh_recqty, mask0
	      if (poh_recqty.lt.0) prrcqt(10:1) = 'X'
	     end
	  3: begin
	      prorqt = poh_ordqty, mask3
	      prrcqt = poh_recqty, mask3
	      if (poh_recqty.lt.0) prrcqt(10:1) = 'X'
	     end
	  endcase
	prucost = poh_ucost, mask3
	if (poh_recqty.gt.0) then
	  begin
	    cost = (poh_recqty * poh_ucost)
	    cost = cost - ((cost * poh_discpct) / 100.0)
	    prcost = cost, mask
	  end
	 else clear cost
	call print
	if (poh_recqty.gt.0) then
	  begin
	    vrcqt = vrcqt + poh_recqty
	    frcqt = frcqt + poh_recqty
	    ircqt = ircqt + poh_recqty
	  end
	 else
	  begin
	    vrjqt = vrjqt - poh_recqty
	    frjqt = frjqt - poh_recqty
	    irjqt = irjqt - poh_recqty
	  end
	if (scr_rptseq.eq.'I') .and.
	&  (hldorder.ne.poh_order)
	  begin
	    vorqt = vorqt + poh_ordqty
	    forqt = forqt + poh_ordqty
	    iorqt = iorqt + poh_ordqty
	  end
	vcost = vcost + cost
	fcost = fcost + cost
	icost = icost + cost
	return

print_serial_lot,
	pohs_comp = poh_comp
	pohs_item = poh_item
	xcall db_find (pohsln_chan,pohs_key(1:26),0,'M',,,opcde)
	if (opcde) return
	repeat
	  begin
	    xcall db_next (pohsln_chan,pohsln,'F','M',,,opcde)
	    if (opcde) .or.
	    &  (pohs_comp.ne.poh_comp) .or.
	    &  (pohs_item.ne.poh_item) return

	    if (pohs_order.eq.poh_order) .and.
	    &  (pohs_lineno.eq.poh_lineno) .and.
	    &  (pohs_recvdate.ge.scr_strdate .and. pohs_recvdate.le.scr_enddate)
	      begin
		prt_slno = pohs_snlt
		prt_units = pohs_recqty, mask3
		call print
	      end
	  end

	;	print item totals
item_totals,
	if (lstitem.ne.UT_ALL)
	  begin
	    prdesc = 'ITEM TOTALS:'
	    case in_cmqdec of
	      begincase
	      0: begin
		  if (scr_rptseq.eq.'I') prorqt = iorqt, mask0
		  prrcqt = ircqt, mask0
		 end
	      3: begin
		  if (scr_rptseq.eq.'I') prorqt = iorqt, mask3
		  prrcqt = ircqt, mask3
		 end
	      endcase
	    prcost = icost, mask
	    call print
	    if (irjqt)			; print rejects
	      begin
		case in_cmqdec of
		  begincase
		  0: prrcqt = irjqt, mask0
		  3: prrcqt = irjqt, mask3
		  endcase
		prrcqt(10:1) = 'X'
		call print
	      end
	  end
	lstitem = poh_item
	clear iorqt,ircqt,irjqt,icost
	call print
	return

	;	print vendor totals
vendor_totals,
	call item_totals
	if (lstvend.ne.-1)
	  begin
	    prdesc = 'VENDOR TOTALS:'
	    case in_cmqdec of
	      begincase
	      0: begin
		  if (scr_rptseq.eq.'I') prorqt = vorqt, mask0
		  prrcqt = vrcqt, mask0
		 end
	      3: begin
		  if (scr_rptseq.eq.'I') prorqt = vorqt, mask3
		  prrcqt = vrcqt, mask3
		 end
	      endcase
	    prcost = vcost, mask
	    call print
	    if (vrjqt)			; print rejects
	      begin
		case in_cmqdec of
		  begincase
		  0: prrcqt = vrjqt, mask0
		  3: prrcqt = vrjqt, mask3
		  endcase
		prrcqt(10:1) = 'X'
		call print
	      end
	  end
	if (eof.eq.TRUE) return
	lstvend = poh_vend
	clear vorqt,vrcqt,vrjqt,vcost
	return

	;	Print a detail line of the report
print,
	case scr_rptseq of
	  begincase
	  'V': xcall print (pline,title,head1v,head2v,,legnd1)
	  'I': xcall print (pline,title,head1i,head2i,,legnd1)
	  endcase
	clear pline
	if (lp_cnt.eq.-1)
	  begin
	    call close_files
	    call do_shutdown
	    xreturn		; to calling program
	  end
	return
.end

