;==File=================================================================;
; PO4720.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=============================================================;
;	po4720		Purchase Order posting register.
;==Changes==============================================================;
; 05/09/2001 tah - Add option for serial number sequence.
; 09/24/1996 tah - Added columns for frt-add, total cost, and vendor ID.
;=======================================================================;
.subroutine po4720

.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:popost.rec"
.include "POS:posnlt.rec"
.include "INS:incomm.gbl"
.include "INS:initvc.rec"
.include "INS:inkits.rec"

external function
	smctrl		,a

record	head1
		,a*	@1,	'LOC'
		,a*	@5,	'CAT'
		,a*	@9,	'ITEM'
		,a*	@34,	'ORDER'
		,a*	@41,	'LINE'
		,a*	@48,	'QUANTITY'
		,a*	@59,	'UNIT COST'
		,a*	@71,	'ITEM COST'
		,a*	@82,	'FRT-ADD'
		,a*	@92,	'TOTAL COST'
		,a*	@105,	'VEND-ID'
record	legnd1
		,a*	@1,	'COMPANY:'
	lcompy	,a2	@11

record	pline
		,a132
record	,X
	prlocn		,a3	@1
	prcatg		,a3	@5
	pritem		,a24	@9
	prorno		,a6	@34
	prline		,a3	@41
	prrcqt		,a11	@46
	prcost		,a11	@58
	prtotl		,a11	@70
	prfrta		,a8	@82
	prtotf		,a11	@92
	prvend		,a8	@104
record	,X
	prslty		,a3	@5
	prslit		,a24	@9
	prslqt		,a11	@46
	prslno		,a20	@58

record
	abort		,d1
	frtcost		,d9.2		; cost with freight added
	mask		,a11,	'ZZZ,ZZX.XX-'
	mask0		,a11,	'   ZZZ,ZZX-'
	mask3		,a11,	'ZZZZZX.XXX-'
	title		,a*,	'RECEIVINGS POSTING REGISTER'
	tot_qty		,d9.3		; total quantity
	tot_cost	,d9.2		; total cost
	tot_fcost	,d9.2		; total freight added cost
	work_chan	,d2		; work file channel
	work_name	,a14,	'WRK:po4710.ddf'
	  work_ext	,a3	@work_name+11
.start nopage,list

.proc
	;>>>>>	Main processing  <<<<<;
	call do_setup
	call open_files
	if (abort.eq.FALSE)
	  begin
	    call get_destination
	    if (abort.eq.FALSE)
	      begin
		call print_report
		call print_report_totals
		xcall clslp ('PO Posting Register')
	      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
	po_cmfrtadd = %smctrl(ut_cmcomp,'PO','ADDFRGTIN')
	in_cmfrttyp = %smctrl(ut_cmcomp,'IN','FRTADDTYPE')
	return

	;	Shut down environment
do_shutdown,
	xcall e_exit
	return

	;	Open the needed data files
open_files,
	abort = FALSE
	work_ext = ut_userid
	xcall open (work_chan,'I',work_name)
	xcall open (initvc_chan,'I:I',initvc_name)
	xcall open (inkits_chan,'I:I',inkits_name)
	xcall open (posnlt_chan,'I:I',posnlt_name)
	return

	;	Close the data files opened for the report
close_files,
	xcall close (work_chan,DTE_CLOSE)
	xcall close (initvc_chan,DTE_CLOSE)
	xcall close (inkits_chan,DTE_CLOSE)
	xcall close (posnlt_chan,DTE_CLOSE)
	return

	;	Get the output destination
get_destination,
	abort = FALSE
	lcompy = ut_cmcomp
	clear lp_sel
	lp_noabort = TRUE		; turn off abort
	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)
	repeat
	  begin
	    reads (work_chan,popost,print_report_eof)
	    if (pop_acpqty)
	      begin
		prlocn = pop_locncode
		prcatg = pop_catgcode
		pritem = pop_item
		prorno = pop_order, 'XXXXXX'
		prline = pop_lineno, 'ZZX'
		prrcqt = pop_acpqty, mask3
		prcost = pop_ucost, mask3
		prtotl = pop_tcost, mask
		call get_vend_part
		if (.not.opcde)
		  begin
		    prfrta = inv_freightin, mask3
		    prtotf = frtcost, mask
		  end
		prvend = pop_vend, 'XXXXXXXX'
		call print
		tot_qty = tot_qty + pop_acpqty
		tot_cost = tot_cost + pop_tcost
		tot_fcost = tot_fcost + frtcost
		case pop_slst of
		  begincase
		  'K': call print_kit
		  'S': call print_serial_lot
		  'L': call print_serial_lot
		  endcase
	      end
	  end
print_report_eof,
	return

print_kit,
	inkitm.comp = pop_comp
	inkitm.item = pop_item
	clear inkitm.seqn
	xcall db_read (inkits_chan,inkitm,inkitm.key,0,'M',,,opcde)
	if (.not.opcde)
	  repeat
	    begin
	      xcall db_next (inkits_chan,inkcmp,'F','M',,,opcde)
	      if (opcde) .or.
	      &  (inkcmp.comp .ne. inkitm.comp) .or.
	      &  (inkcmp.item .ne. inkitm.item) exitloop
	      if (inkcmp.status .ne. 'D') .and.
	      &  (inkcmp.status .ne. 'I')
		begin
		  pos_comp = pop_comp
		  pos_order = pop_order
		  pos_lineno = pop_lineno
		  pos_item = inkcmp.citem
		  pos_seqno = 1
		  xcall db_find (posnlt_chan,pos_key,0,'M',,,opcde)
		  if (opcde) then
		    begin		; No serial numbers for component
		      prslty = 'Kit'
		      prslit = pos_item
		      prslqt = pos_qty, mask3
		      clear prslno
		      call print
		    end
		   else
		    begin		; Component has serial numbers
		      repeat
			begin
			  xcall db_next (posnlt_chan,posnlt,'F','M',,,opcde)
			  if (opcde) .or.
			  &  (pos_comp.ne.pop_comp) .or.
			  &  (pos_order.ne.pop_order) .or.
			  &  (pos_lineno.ne.pop_lineno) .or.
			  &  (pos_item.ne.inkcmp.citem) exitloop
			  if (pos_linestatus.ne.'D')
			    begin
			      prslty = 'Kit'
			      prslit = pos_item
			      prslqt = pos_qty, mask3
			      prslno = pos_snlt
			      call print
			    end
			end
		    end
		end
	    end
	return

print_serial_lot,
	pos_comp = pop_comp
	pos_order = pop_order
	pos_lineno = pop_lineno
	clear pos_item
	pos_seqno = 1
	xcall db_find (posnlt_chan,pos_key,0,'M',,,opcde)
	repeat
	  begin
	    xcall db_next (posnlt_chan,posnlt,'F','M',,,opcde)
	    if (opcde) .or.
	    &  (pos_comp.ne.pop_comp) .or.
	    &  (pos_order.ne.pop_order) .or.
	    &  (pos_lineno.ne.pop_lineno) .or.
	    &  (pos_item.ne.UT_BLANKS) return
	    if (pos_linestatus.ne.'D')
	      begin
		prslty = 'S/L'
		clear prslit
		prslqt = pos_qty, mask3
		prslno = pos_snlt
		call print
	      end
	  end
	return

	;	Print the report totals
print_report_totals,
	call print
	pritem = '>> REPORT TOTALS >>'
	prrcqt = tot_qty, mask3
	prtotl = tot_cost, mask
	prtotf = tot_fcost, mask
	call print
	return

get_vend_part,
	inv_comp = pop_comp
	inv_item = pop_item
	inv_locncode = pop_locncode
	inv_type = 'V'
	inv_vend_cust = pop_vend
	xcall db_read (initvc_chan,initvc,inv_key,0,'M',,,opcde)
	if (.not.opcde) then
	  begin
	    if (po_cmfrtadd.eq.'Y')
	      begin			; up unit cost by est freight
		case in_cmfrttyp of
		  begincase
		  'D': frtcost = pop_tcost + inv_freightin
		  'P': frtcost = pop_tcost + ((pop_tcost * inv_freightin) / 100.0)
		  endcase
	      end
	  end
	 else clear frtcost
	return

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

