;==File=================================================================;
; PO6000.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=============================================================;
;	po6000		Orders entered list.
;==Changes==============================================================;
; 01/08/2007 - esc Add new Reference to function the same as Remarks
;=======================================================================;
.subroutine po6000

.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 "INS:initem.rec"
.include "SMS:smcode.rec"

record	head1
		,a*	@57,	'S'
		,a*	@74,	'QUANTITY'
		,a*	@84,	'RECEIVED'
		,a*	@95,	'QUANTITY'
		,a*	@104,	'REQUIRED'
		,a*	@125,	'UNIT'
		,a*	@130,	'UOM'
record	head2
		,a*	@1,	'ITEM-NO'
		,a*	@26,	'DESCRIPTION'
		,a*	@57,	'T'
		,a*	@59,	'VENDORS ITEM'
		,a*	@75,	'ORDERED'
		,a*	@86,	'PRIOR'
		,a*	@95,	'RECEIVED'
		,a*	@106,	'DATE'
		,a*	@113,	'DISC%'
		,a*	@125,	'COST'

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

record	pline
		,a132
record	,X
	pritem		,a24	@1
	prdesc		,a30	@26
	prstat		,a1	@57
	prvnid		,a12	@59
	prorqt		,a10	@72
	prrcvd		,a10	@82
	prrcqt		,a10	@93
	prrqdt		,a8	@104
	prdisc		,a5	@113
	prcost		,a10	@119
	prbuom		,a3	@130
record	,X
	prr1p		,a1	@1
	prr1s		,a1	@2
	prrem1		,a60	@3
	prr2p		,a1	@71
	prr2s		,a1	@72
	prrem2		,a60	@73

record	itemline
			,a*	@20,	'Pack:'
	prpack		,a6	@25
			,a*	@34,	'Wt:'
	prweight	,a7	@36
			,a*	@46,	'Tot Wt:'
	prtweight	,a9	@53
			,a*	@65,	'Cube:'
	prcubes		,a5	@70
			,a*	@77,	'Tot Cubes:'
	prtcubes	,a7	@87
	prpallet	,a3	@97
			,a*	@100,	'/Pallet'
			,a*	@109,	'Pallets:'
	prpallets	,a3	@118
			,a*	@122,	'+'
	prpunits	,a3	@124
			,a*	@128,	'units'

record	prtotal
	prdscr		,a13	@20
	prtwgt		,a13	@34
			,a*	@48,	'WEIGHT'
	prtcub		,a13	@55
			,a*	@69,	'CUBES'
	prtgrs		,a13	@76
			,a*	@90,	'GROSS'
	prtdsc		,a13	@96
			,a*	@110,	'DISC'
	prtnet		,a13	@116
			,a*	@130,	'NET'

record	scr_rec1
	scr_strdate	,d8		; starting date
	scr_enddate	,d8		; ending date
	scr_strorder	,d6		; starting order
	scr_endorder	,d6		; ending order

record	totals
	o_weight	,d8.2		; order total weight
	o_cubes		,d8.2		; order total cubes
	o_gross		,d10.2		; order total gross amount
	o_disc		,d8.2		; order total discount amount
	o_net		,d10.2		; order total net amount
	f_gross		,d10.2		; final total gross amount
	f_disc		,d8.2		; final total discount amount
	f_net		,d10.2		; final total net amount
record
	abort		,d1
	add2		,a35		; area for formatting address
	add3		,a35		; area for formatting address
	astrck		,a132		; filled with astricks
	amount		,d9.2		; work area for line item amount
	buyer		,a25		; buyer name from codes file
	discount	,d8.2		; work area for line item discount
	linprt		,a1		; detail line printed flag
	location	,a25		; location from codes file
	mask		,a10,	'ZZZZZZ.XXX'
	maskt		,a13,	'ZZ,ZZZ,ZZZ.XX'
	mask0		,a10,	'  ZZZ,ZZX-'
	mask3		,a10,	'ZZZZZX.XXX'
	pallets		,d3		; number of pallets
	svia		,a25		; ship via from codes file
	terms		,a25		; terms from codes file
	title		,a*,	'ORDERS ENTERED LIST'
	wdone		,d1
	wind_name	,a*,	'po6000'
	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 ('P/O Orders Entered List')
	      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 (initem_chan,'I:I',initem_name)
	xcall open (smcode_chan,'I:I',smcode_name)
	return

	;	Close the data files opened for the report
close_files,
	xcall close (pohedr_chan,DTE_CLOSE)
	xcall close (poline_chan,DTE_CLOSE)
	xcall close (initem_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_strdate.gt.scr_enddate) .or.
	&  (scr_strorder.gt.scr_endorder)
	  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)
	xcall fill ('*',astrck)
	clear totals
	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
	    if (pom_orddate.ge.scr_strdate .and. pom_orddate.le.scr_enddate) .and.
	    &  (pom_order.ge.scr_strorder .and. pom_order.le.scr_endorder)
	      begin
		call print_order_header
		call print_order_lines
	      end
	  end

	;	Print the report totals
print_report_totals,
	prdscr = 'FINAL TOTAL:'
	clear prtwgt,prtcub
	prtgrs = f_gross, maskt
	prtdsc = f_disc, maskt
	prtnet = f_net, maskt
	pline = prtotal
	call print
	return

print_order_header,
	smc_type = 'B'
	smc_code = pom_buyrcode
	xcall db_read (smcode_chan,smcode,smc_key,0,'M',,,opcde)
	if (opcde) clear smc_descr
	buyer = smc_descr

	smc_type = 'Y'
	smc_code = pom_termcode
	xcall db_read (smcode_chan,smcode,smc_key,0,'M',,,opcde)
	if (opcde) clear smc_descr
	terms = smc_descr

	smc_type = 'L'
	smc_code = pom_locncode
	xcall db_read (smcode_chan,smcode,smc_key,0,'M',,,opcde)
	if (opcde) clear smc_descr
	location = smc_descr

	smc_type = 'V'
	smc_code = pom_viacode
	xcall db_read (smcode_chan,smcode,smc_key,0,'M',,,opcde)
	if (opcde) clear smc_descr
	svia = smc_descr

	;	print order header information

	pline = astrck
	call print

	pline(2:15) = 'Purchase Order:'
	pline(18:6) = pom_order, 'XXXXXX'
	pline(55:9) = 'P/O Date:'
	xcall dtdsp (pom_orddate,pline(65:10))
	call print

	pline(10:7) = 'Vendor:'
	pline(18:8) = pom_vend, 'XXXXXXXX'
	pline(28:8) = 'Mail To:'
	pline(37:5) = pom_mail
	pline(55:9) = 'Ship Via:'
	pline(65:3) = pom_viacode
	pline(70:25) = svia
	pline(98:9) = 'Location:'
	pline(108:3) = pom_locncode
	pline(112:21) = location
	call print

	pline(12:5) = 'Name:'
	pline(18:25) = pom_name
	pline(58:6) = 'Buyer:'
	pline(65:3) = pom_buyrcode
	pline(70:25) = buyer
	pline(100:7) = 'Status:'
	pline(108:1) = pom_status
	call print

	pline(7:10) = 'Address 1:'
	pline(18:25) = pom_addr1
	pline(58:6) = 'Terms:'
	pline(65:3) = pom_termcode
	pline(70:25) = terms
	pline(98,132) = '--------------SHIP TO--------------'
	call print

	pline(7:10) = 'Address 2:'
	pline(18:25) = pom_addr2
	pline(49,63) = 'Confirmed With:'
	pline(65:20) = pom_confirmed
	pline(98:25) = pom_shipname
	call print

	pline(12:5) = 'City:'
	pline(18:20) = pom_city
	pline(60:4) = 'FOB:'
	pline(65:1) = pom_fobc
	pline(98:25) = pom_shipaddr1
	call print

	pline(11:6) = 'State:'
	pline(18:2) = pom_state
	pline(48:16) = 'Collect/Prepaid:'
	pline(65:1) = pom_colppd
	pline(98:25) = pom_shipaddr2
	call print

	pline(8:9) = 'Zip Code:'
	pline(18:10) = pom_zip
	pline(98:20) = pom_shipcity
	pline(119:2) = pom_shipstate
	pline(122:10) = pom_shipzip
	call print

	if (pom_comment1.ne.ut_blanks) .or.
	&  (pom_comment2.ne.ut_blanks)
	  begin
	    call print
	    pline(18:40) = pom_comment1
	    pline(65:40) = pom_comment2
	    call print
	  end

	call print
	pline = head1
	call print
	pline = head2
	call print
	call print
	return

print_order_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.
	    &  (pom_key.ne.pol_key)
	      begin
		call print
		prdscr = ' ORDER TOTAL:'
		prtwgt = o_weight, maskt
		prtcub = o_cubes, maskt
		prtgrs = o_gross, maskt
		prtdsc = o_disc, maskt
		prtnet = o_net, maskt
		pline = prtotal
		call print
		call print
		f_gross = f_gross + o_gross
		f_disc = f_disc + o_disc
		f_net = f_net + o_net
		clear o_gross,o_disc,o_net,o_weight,o_cubes
		return
	      end
	    pritem = pol_item
	    prdesc = pol_descr
	    prstat = pol_status
	    prvnid = pol_vendpn
	    prbuom = pol_buomcode
	    case in_cmqdec of
	      begincase
	      0: begin
		  prorqt = pol_ordqty, mask0
		  prrcvd = pol_recpqty, mask0
		  prrcqt = pol_recuqty, mask0
		 end
	      3: begin
		  prorqt = pol_ordqty, mask3
		  prrcvd = pol_recpqty, mask3
		  prrcqt = pol_recuqty, mask3
		 end
	      endcase
	    xcall dtdsp (pol_reqdate,prrqdt)
	    prdisc = pol_discpct, 'ZX.XX'
	    prcost= pol_ucost, mask
	    amount = (pol_ucost * pol_ordqty)		; gross amount
	    o_gross = o_gross + amount
	    discount = (amount * pol_discpct)		; discount amt
	    o_disc = o_disc + discount
	    o_net = o_net + (amount - discount)
	    o_weight = o_weight + (pol_ordqty * pol_weight)
	    o_cubes = o_cubes + (pol_ordqty * pol_cubes)
	    call print

	    ini_comp = pol_comp			; get item record
	    ini_item = pol_item
	    xcall in_get_item (initem)
	    if (opcde) clear initem

	    prpack = ini_packsize
	    prweight = pol_weight, maskt
	    prtweight = (pol_ordqty * pol_weight), maskt
	    prcubes = pol_cubes, maskt
	    prtcubes = (pol_ordqty * pol_cubes), maskt
	    prpallet = ini_pallet, 'ZZX'
	    if (ini_pallet) then
	      begin
		pallets = (pol_ordqty / ini_pallet)
		prpallets = pallets, 'ZZX'
		prpunits = pol_ordqty - (pallets * ini_pallet), 'ZZX'
	      end
	     else clear prpallets,prpunits
	    pline = itemline
	    call print

	    if (pol_extdescr[1]) .or.
	    &  (pol_extdescr[2])
	      begin
		prrem1 = pol_extdescr(1)
		prrem2 = pol_extdescr(2)
		call print
	      end

	    if (pol_remark1) .or.
	    &  (pol_remark2)
	      begin
		prrem1 = pol_remark1
		prr1s = ':'
		prr1p = pol_rem1prt
		prrem2 = pol_remark2
		prr2s = ':'
		prr2p = pol_rem2prt
		call print
	      end
	    if (pol_refrnce1) .or.
	    &  (pol_refrnce2)
	      begin
		prrem1 = pol_refrnce1
		prr1s = ':'
		prr1p = pol_ref1prt
		prrem2 = pol_refrnce2
		prr2s = ':'
		prr2p = pol_ref2prt
		call print
	      end
	  end

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

