;==File=================================================================;
; PO4730.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=============================================================;
;	po4730		Post to inventory files.
;==Changes==============================================================;
; 05/02/2001 tah - Change for new POSNLT file format (kits)
; 06/26/1999 tah - Allow receipt of more units than ordered.
; 09/22/1997 tah - Fix 1-step posting to inventory file.
; 11/12/1996 tah - Fix problem posting to inventory file.
; 09/24/1996 tah - Add code for $ or % freight adder from inventory.
;=======================================================================;
.subroutine po4730

.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:inabin.rec"
.include "INS:initem.rec"
.include "INS:initvc.rec"
.include "INS:inkits.rec"
.include "INS:insnlt.rec"

external function
	inabin_primary	,a
	smctrl		,a

record
	abort		,d1
	adjust_qty	,d9.3		; deallocate for excess receivings
	ducost		,d9.3		; discounted unit cost
	hold_item	,a24
	hold_qty	,d9.3
	hold_slst	,a1
	kit_units	,d9.3		; kit units to update
	pct_amt		,d18.4		; percent compute work area
	rcdqty		,d9		; received quantity
	tcost		,d18.3		; work cost
	tqty		,d18.3		; work quantity
	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
	call process_data
	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')
	clear ut_err, ut_ert
	return

	;	Shut down environment
do_shutdown,
	xcall e_exit
	return

	;	Open the needed data files
open_files,
	work_ext = ut_userid
	xcall open (work_chan,'I',work_name)
	xcall open (posnlt_chan,'U:I',posnlt_name)
	xcall open (inabin_chan,'I:I',inabin_name)
	xcall open (initem_chan,'U:I',initem_name)
	xcall open (initvc_chan,'U:I',initvc_name)
	xcall open (inlocn_chan,'U:I',inlocn_name)
	xcall open (inabin_chan,'U:I',inabin_name)
	xcall open (insnlt_chan,'U:I',insnlt_name)
	xcall open (inkits_chan,'I:I',inkits_name)
	return

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

	;	Process the data
process_data,
	abort = FALSE
	xcall status (DTEPO_UIF)
	repeat
	  begin
	    reads (work_chan,popost,process_data_eof)
	    case pop_linetype of
	      begincase
	      'I': begin
		    call update_inventory
		    if (pop_ordtype.ne.'D')		; not drop shipment
		      begin
			case pop_slst of
			  begincase
			  'K': call update_kit
			  'L': call update_serial_lot
			  'S': call update_serial_lot
			  endcase
		      end
		   end
	      endcase
	  end
process_data_eof,
	return

	;	update inventory file
update_inventory,
	ini_comp = pop_comp
	ini_item = pop_item
	xcall in_get_item (initem)
	if (.not.opcde) .and.			; Was item found
	&  (ini_controlled.eq.'Y')		; Is item controlled
	  begin
	    rcdqty = pop_acpqty * ini_uomfactor
	    ducost = (pop_tcost / rcdqty)
	    call update_itemvend		; update vendor information
	    if (po_cmrectyp.eq.1)
	      begin
		if (pop_updcost.eq.'Y')
		 then xcall instkrec (pop_item,pop_locncode,pop_abin,rcdqty,ducost,'N',opcde)
		 else xcall instkrec (pop_item,pop_locncode,pop_abin,rcdqty,0,'N',opcde)
		if (pop_rejqty.gt.0)
		  begin
		    adjust_qty = -(pop_acpqty + pop_rejqty - pop_ordqty)
		    xcall instkdok (pop_item,pop_locncode,-pop_rejqty,opcde,adjust_qty)
		  end
	      end
	    xcall instkuse ('R',pop_item,pop_locncode,rcdqty,ut_datfil,ducost,
	    &			0,1,opcde)
	  end
	return

	;	Update for received kit
update_kit,
	inkitm.comp = pop_comp
	inkitm.item = pop_item
	clear inkitm.seqn
	xcall db_read (inkits_chan,inkitm,inkitm.key,0,'M',,,opcde)
	if (opcde) return		; not found
	repeat
	  begin
	    xcall db_next (inkits_chan,inkcmp,'F','M',,,opcde)
	    if (opcde) .or.
	    &  (inkcmp.comp.ne.pop_comp) .or.
	    &  (inkcmp.item.ne.pop_item) return
	    ini_comp = inkcmp.comp
	    ini_item = inkcmp.citem
	    xcall in_get_item (initem)
	    if (.not.opcde) .and.
	    &  (ini_controlled.eq.'Y')
	      begin
		if (inkcmp.qty.lt.0)
		 then kit_units = -inkcmp.qty
		 else kit_units = (pop_acpqty * inkcmp.qty)
		inb_bin = %inabin_primary(ini_comp,ini_item,pop_locncode)
		xcall instkrec (inkcmp.citem,pop_locncode,inb_bin,kit_units,0,'Y',opcde)
		xcall instkuse ('R',inkcmp.citem,pop_locncode,kit_units,ut_datfil,0,
		&		0,1,opcde)
		case ini_slst of
		  begincase
		  'L': call update_kit_serial_lot
		  'S': call update_kit_serial_lot
		  endcase
	      end
	  end
	return

	;	Read serial/lot file and do update
update_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
		if (pop_slst.eq.'S')
		 then rcdqty = 1.0
		 else rcdqty = (pos_qty * ini_uomfactor)
		hold_item = pop_item
		hold_qty = rcdqty
		hold_slst = pop_slst
		call do_serial_lot_update
	      end
	  end

	;	Read serial/lot file for kit components and do update
update_kit_serial_lot,
	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)
	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) return
	    if (pos_linestatus.ne.'D')
	      begin
		hold_item = inkcmp.citem
		hold_qty = pos_qty
		hold_slst = ini_slst
		call do_serial_lot_update
	      end
	  end
	return

	;	update serial/lot number file
do_serial_lot_update,
	if (hold_slst.eq.'L')
	  begin			; lot number
	    ins_comp = pop_comp
	    ins_item = hold_item
	    ins_locncode = pos_locncode
	    ins_snlt = pos_snlt
	    xcall db_read (insnlt_chan,insnlt,ins_key,0,'M',,,opcde)
	    if (.not.opcde)
	      begin
		ins_onhand = ins_onhand + hold_qty
		if (ins_onhand.gt.0) ins_status = 'A'
		xcall db_update (insnlt_chan,insnlt,ins_key,insnlt_log,opcde)
		return
	      end
	  end
	clear insnlt
	ins_comp = pos_comp
	ins_item = hold_item
	ins_snlt = pos_snlt
	ins_locncode = pos_locncode
	if (pop_abin) .and.
	&  (pop_abin.ne.'?')
	 then ins_bin = pop_abin
	 else ins_bin = %inabin_primary(pos_comp,hold_item,pos_locncode)
	ins_status = 'A'
	ins_type = 'N'
	ins_onhand = hold_qty
	clear ins_aloctd
	xcall db_add (insnlt_chan,insnlt,ins_key,insnlt_log,opcde)
	return

	;	update vendor information on item master file
update_itemvend,
	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 (pop_vendpn) inv_partno = pop_vendpn
	    if (inv_cost) then
	      begin
		clear pct_amt
		pct_amt = (((pop_ucost - inv_cost) * 100.0) / inv_cost)
		inv_costchgpct = pct_amt
	      end
	     else clear inv_costchgpct
	    inv_date = ut_datfil
	    inv_cost = pop_ucost
	    inv_qty = pop_acpqty
	    xcall db_update (initvc_chan,initvc,inv_key,initvc_log,opcde)
	    if (po_cmfrtadd.eq.'Y')
	      case in_cmfrttyp of		; up unit cost by est freight
		begincase
		'D': ducost = ducost + inv_freightin			  ; $
		'P': ducost = ducost + (ducost * inv_freightin) / 100.0 ; %
		endcase
	  end
	 else
	  begin
	    inv_comp = pop_comp
	    inv_item = pop_item
	    inv_locncode = pop_locncode
	    inv_type = 'V'
	    inv_vend_cust = pop_vend
	    inv_partno = pop_vendpn
	    inv_date = ut_datfil
	    inv_cost = pop_ucost
	    inv_qty = pop_acpqty
	    clear inv_costchgpct,inv_freightin,inv_fcost,inv_fdate
	    xcall db_add (initvc_chan,initvc,inv_key,initvc_log,opcde)
	  end
	return
.end

