;==File=================================================================;
; PO4200.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=============================================================;
;	po4200		Print receivings worksheets.
;==Changes==============================================================;
; 01/08/2007 ESC - Add new Reference to function the same as Remarks
; 03/31/2003 kms - Do not print Qty and Loc for users without scanners.
; 05/03/2001 tah - Changed for printing kit components/serial numbers.
; 02/18/1999 tah - Added line no and do not print completed lines
; 10/24/1997 tah - Modified for bar code print module (added units)
;=======================================================================;
.subroutine po4200	; Print receivings worksheets.

	a_order		,a	; IN  - Order header record.

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

external function
	smctrl		,a

record	poordr
	opploc		,a3		; pick location
	oporno		,d6		; order number
	oplocn		,a3		; location
	opline		,d3		; line item

record	head1
			,a*	@1,	'DESCRIPTION'
			,a*	@36,	'VENDOR-ITEM-NO'
record	head2
			,a*	@3,	'ITEM-NO'
			,a*	@31,	'DATE'
			,a*	@44,	'QUANTITY'
			,a*	@55,	'QUANTITY'
			,a*	@73,	'RECEIVED'
record	head3
			,a*	@29,	'REQUIRED'
			,a*	@39,	'UOM'
			,a*	@45,	'ORDERED'
			,a*	@54,	'REMAINING'
			,a*	@65,	'BIN'
			,a*	@73,	'THIS ORD'
record	legnd1
			,a*	@1,	'COMPANY:'
	lcompy		,a2	@10
			,a*	@65,	'ORDER NO:'
	prordn		,a6	@75
record	legnd2
			,a*	@1,	'VENDOR:'
	pvend		,a8	@9
	pvname		,a30	@18
			,a*	@65,	'DATE:'
	pvdate		,a10	@71

record	location
	prbarord	,a39	@1
			,a*	@40,	'RESTOCK TO:'
	prlocn		,a3	@52
	prlcnd		,a25	@56

record	pline
		,a80
record	,X
	prdesc		,a30	@1
	prvnid		,a24	@36
record	,X
	pritem		,a24	@3
	prrqdt		,a10	@28
	pruom		,a3	@39
	prorqt		,a10	@43
	prrem		,a10	@54
	prbin		,a8	@65
	prrcqt		,a7	@74
record	,X
	prslds1		,a4	@10
	prsnlt1		,a30	@15
	prslds2		,a4	@46
	prsnlt2		,a30	@51
record	,X
	prmessage	,a40	@21
record	,X
;	prbar1		,a5	@6
;	prbar2		,a60	@12
	prbar2		,a80	@1
record	,X
	prkitd		,a4	@3
	prkiti		,a24	@8
	prkqty		,a10	@43

record	itemline
			,a*	@14,	'Wt:'
	prweight	,a9	@17
			,a*	@28,	'Cubes:'
	prcubes		,a7	@34
	prpallet_text	,a8	@43
	prpallets	,a3	@51
	prplus		,a1	@55
	prpunits	,a3	@57
	prpunits_text	,a5	@61
			,a*	@73,	'Line:'
	prline		,a3	@78

record	trail
			,a*	@21,	'RECEIVED BY:_________________'
			,a*	@61,	'ON:_____/_____/_____'

record	scr_rec1		; input set 1
	scr_orno	,d6		; order number
	scr_shpdat	,d8		; cutoff date
	scr_confirm	,a1		; confirmation switch

record
	abort		,d1
	bar_code	,a21		; bar coding
	bar_line	,a3		; alpha line number for bar code
	bar_order	,a6		; alpha order number for bar code
	bar_units	,a10		; alpha units for bar code
	cur_order	,d6		; current order number
	dash		,a*,	'______________________________'
	hold_locn	,a3		; current location code
	hold_plocn	,a3		; current picking location code
	iqtyrem		,d6		; quantity remaining for loop
	lines		,d2		; detail line counter
	mask0		,a11,	'   ZZZ,ZZX'
	mask2		,a10,	'ZZZZZZ.XX'
	mask3		,a11,	'ZZZZZZ.XXX'
	max_lines	,d2,	42	; detail lines on form
	ndx		,d2		; loop control
	pallets		,d3		; number of pallets
	pick_type	,a1		; selection type flag
	print_kits	,a1		; print kits flag
	qtyrem		,d9.3		; quantity remaining
	recs_read	,d6
	scanner_type	,a10		; scanner type 
	set_name	,a4		; current input set name
	temp_name	,a14		; temp file for sort
	  temp_ext	,a3	@temp_name+11
	title		,a*,	'PURCHASE RECEIVINGS WORKSHEET'
	wdone		,d1
	wind_name	,a*,	'po4200'
	wind_no		,d2		; screen id
	work_chan	,d2		; work file channel
	work_name	,a*,	'WRK:po4200.ddf'
	  work_ext	,a3	@work_name+11
	wrtcnt		,d6		; number of work records written
.start nopage,list

.proc
	;>>>>>	Main processing  <<<<<;
	call do_setup
	call open_files
	abort = FALSE
	if (%passed(a_order)) then	; Order header passed, from
	  begin				;   order entry program.
	    pohedr = a_order
	    call pull_one
	  end
	 else
	  repeat
	    begin
	      call get_parameters
	      if (abort.eq.TRUE) .or.
	      &  (wdone.eq.TRUE) exitloop
	      if (scr_confirm.eq.'Y')
		begin
		  case pick_type of
		    begincase
		    'O': call pull_one
		    'A': call pull_all
		    endcase
		end
	      xcall i_init (wind_no)
	    end
	xcall close (work_chan,DTE_CLOSE)
	if (wrtcnt.gt.0)
	  begin
	    call get_destination
	    if (abort.eq.FALSE)
	      begin
		call sort_data
		call print_report
		call print_report_totals
		clear ut_ert
		ut_ert(1:19) = 'Receiving worksheet'
		ut_ert(21:8) = ut_datdsp
		xcall clslp (ut_ert)
		clear ut_ert
	      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)
	print_kits = %smctrl(ut_cmcomp,'PO','PRINTKITS')
	scanner_type = %smctrl(ut_cmcomp,'PO','HHSCANNER',1)
	clear wrtcnt, cur_order
	return

	;	Shut down environment
do_shutdown,
	xcall lodtoolbar ('RB',8)
	xcall e_exit
	return

	;	Open the needed data files
open_files,
	work_ext = ut_userid
	xcall open (work_chan,'O',work_name)
	if (.not.%passed(a_order))
	  begin
	    xcall open (pohedr_chan,'U:I',pohedr_name)
	    xcall open (poline_chan,'I:I',poline_name)
	    xcall open (initem_chan,'I:I',initem_name)
	    xcall open (inabin_chan,'I:I',inabin_name)
	    xcall open (smcode_chan,'I:I',smcode_name)
	  end
	if (print_kits.eq.'Y') 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)
	if (.not.%passed(a_order))
	  begin
	    xcall close (pohedr_chan,DTE_CLOSE)
	    xcall close (poline_chan,DTE_CLOSE)
	    xcall close (initem_chan,DTE_CLOSE)
	    xcall close (inabin_chan,DTE_CLOSE)
	    xcall close (smcode_chan,DTE_CLOSE)
	  end
	if (print_kits.eq.'Y') xcall close (inkits_chan,DTE_CLOSE)
	return

	;	Get the report selection parameters
get_parameters,
	abort = FALSE	
	wdone = FALSE	
	xcall lodwin ('LPL',wind_name,wind_no)
	xcall i_init (wind_no)
	set_name = 'set1'
	do begin
	  xcall i_input (wind_no,set_name,scr_rec1,ut_col_inp,ut_col_sel,,1)
	  if g_select then
	    begin
	      case g_entnam of
		begincase
		'END':	begin
			  abort = TRUE
			  return
			end
		'GO':	begin
			  wdone = TRUE
			  return
			end
		'@':	call process_signal
		endcase
	    end
	end until (.not.g_setsts) .and. (.not.g_select)
	return

	;	Process any break signals
process_signal,
	case g_entnam of
	  begincase
	  '@ORDER': begin
		      call break_on_order
		      pick_type = 'O'
		      if (.not.opcde)
			begin
			  xcall i_next (wind_no,set_name,'*DONE*')
			  set_name = 'set2'
			end
		    end
	  '@CUTDAT':begin
		      pick_type = 'A'
		      xcall i_next (wind_no,set_name,'*DONE*')
		      set_name = 'set2'
		    end
	  endcase
	return

	;	Get the output destination
get_destination,
	abort = FALSE
	lcompy = ut_cmcomp
	clear lp_sel
	xcall askpr (ut_cmname,80,61,0,ut_cmdefp)
	if (lp_sel.eq.'E') abort = TRUE
	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=poordr,
	&  key=(opploc,oporno,oplocn,opline),tempfile=temp_name)
	return

	;	Print the report
print_report,
	xcall status (DTEM_PRT)
	xcall open (work_chan,'I',work_name)
	repeat
	  begin
	    reads (work_chan,poordr,print_report_eof)
	    if (cur_order.ne.oporno)
	      begin
		if (cur_order)
		  begin
		    call end_of_lines
		  end
		pom_comp = ut_cmcomp
		pom_order = oporno
		xcall db_read (pohedr_chan,pohedr,pom_key,0,'M',,,opcde)
		if (.not.opcde)
		  begin
		    call print_header
		    pom_flag2 = 'Y'
		    xcall db_update (pohedr_chan,pohedr,pom_key,pohedr_log,opcde)
		  end
		cur_order = oporno
		clear lines
		hold_locn = '???'
		hold_plocn = opploc
	      end
	    call print_detail
	  end
print_report_eof,
	return

	;	Print the report totals
print_report_totals,
	return

break_on_order,
	pom_comp = ut_cmcomp
	pom_order = scr_orno
	xcall db_read (pohedr_chan,pohedr,pom_key,0,'M',,,opcde)
	if (opcde)
	  begin
	    xcall message (DTEPO_ONF)
	    xcall i_init (wind_no)
	    return
	  end
	xcall i_dspfld (wind_no,'VEND',pom_vend)
	xcall i_dspfld (wind_no,'VEND_DESCR',pom_name)
	case pom_status of
	  begincase
	  'C': begin
		xcall message (DTEPO_OIC)
		xcall i_init (wind_no)
		opcde = -1
	       end
	  'D': begin
		xcall message (DTEPO_OID)
		xcall i_init (wind_no)
		opcde = -1
	       end
	  endcase
	case pom_ordtype of
	  begincase
	  'H': begin
		xcall message (DTEPO_OIH)
		xcall i_init (wind_no)
		opcde = -1
	       end
	  endcase
	return

	;	select all outstanding orders
pull_all,
	xcall status (DTEM_PRC)
	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)
	      begin
		xcall status
		if (wrtcnt.eq.0) xcall message (DTEPO_NOI,D_ERROR)
		return
	      end
	    if (pom_status.eq.'O') .and.
	    &  (pom_flag2.ne.'Y') .and.
	    &  (pom_flag3.ne.'Y') .and.
	    &  (pom_reqdate.le.scr_shpdat) call pull_one
	  end

	;	get line items from one order
pull_one,
	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.eq.'I' .or.
	    &   pol_linetype.eq.'N') .and.
	    &  (pol_status.ne.'D' .and. pol_status.ne.'C') .and.
	    &  (pol_ordqty - pol_recpqty.gt.0)
	      begin
		if (smc_type.ne.'L') .or.
		&  (smc_code.ne.pol_locncode)
		  begin
		    smc_type = 'L'
		    smc_code = pol_locncode
		    xcall sm_get_code (smcode)
		    if (opcde) smcl_pickloc = '???'
		  end
		opploc = smcl_pickloc
		oporno = pom_order
		oplocn = pol_locncode
		opline = pol_lineno
		writes (work_chan,poordr)
		incr wrtcnt
	      end
	  end

	;	print header
print_header,
	lp_cnt = 61
	prordn = pom_order, 'XXXXXX'
	pvend = pom_vend, 'XXXXXXXX'
	pvname= pom_name
	xcall dtdsp (pom_orddate,pvdate)
	return

	;	print detail lines
print_detail,
	pol_comp = pom_comp
	pol_order = pom_order
	pol_lineno = opline
	xcall db_read (poline_chan,poline,pol_key,0,'M',,,opcde)
	if (.not.opcde) call print_one_line
	return

print_one_line,
	if (lines.ge.max_lines) call continued
	if (hold_locn.ne.pol_locncode)
	  begin				; new location within order
	    smc_type = 'L'
	    smc_code = pol_locncode
	    xcall sm_get_code (smcode)
	    if (opcde) clear smc_descr
	    xcall fill ('-',pline)
	    call print
	    incr lines
	    prlocn = pol_locncode
	    prlcnd = smc_descr
	    clear prbarord
	    if (lp_bar_on)
	      begin
		clear bar_code
		bar_order = pol_order, 'XXXXXX'
		xcall s_bld (prbarord,,lp_bar_on,100,180)
		ndx = %trim(prbarord)
		xcall s_bld (prbarord,ndx,"%&%a%a",bar_order,lp_bar_off)
	      end
	    pline = location
	    call print
	    incr lines
	    call print
	    incr lines
	  end
	hold_locn = pol_locncode

	prdesc = pol_descr
	prvnid = pol_vendpn
	call print
	incr lines

	pritem = pol_item
	xcall dtdsp (pol_reqdate,prrqdt)
	pruom = pol_buomcode
	qtyrem = pol_ordqty - pol_recpqty
	case in_cmqdec of
	  begincase
	  0: begin
	      prorqt = pol_ordqty, mask0
	      prrem = qtyrem, mask0
	     end
	  3: begin
	      prorqt = pol_ordqty, mask3
	      prrem = qtyrem, mask3
	     end
	  endcase
	ini_comp = pol_comp			; get bin number
	ini_item = pol_item
	xcall in_get_item (initem)
	if (opcde) clear initem

	inb_comp = ini_comp
	inb_item = pol_item
	inb_locncode = pol_locncode
	inb_bin = '?'
	xcall in_get_abin (inabin)
	prbin = inb_bin

	prrcqt = dash
	call print
	incr lines
	case pol_slst of
	  begincase
	  'S': begin
		qtyrem = qtyrem
		if (qtyrem.gt.999) qtyrem = 999
		iqtyrem = qtyrem
		for ndx from 1 thru iqtyrem by 2
		  begin
		    prslds1 = 'S/N:'
		    prsnlt1 = dash
		    prslds2 = 'S/N:'
		    prsnlt2 = dash
		    call print
		    incr lines
		  end
	       end
	  'L': begin
		prslds2 = 'Lot:'
		prsnlt2 = dash
		prrcqt = dash
		call print
		incr lines
	       end
	  endcase

	call print_bar_codes

	prweight = (qtyrem * pol_weight), mask2
	prcubes = (qtyrem * pol_cubes), mask2
	if (ini_pallet) then
	  begin
	    pallets = (qtyrem / ini_pallet)
	    prpallets = pallets, 'ZZX'
	    prpunits = (qtyrem - (pallets * ini_pallet)), 'ZZX'
	    prpallet_text = 'Pallets:'
	    prplus = '+'
	    prpunits_text = 'units'
	  end
	 else clear prpallets,prpunits
	prline = pol_lineno
	pline = itemline
	call print
	incr lines

	if (pol_extdescr[1])
	  begin
	    if (lines.ge.max_lines) call continued
	    pline(21:60) = pol_extdescr[1]
	    call print
	    incr lines
	  end
	if (pol_extdescr[2].ne.ut_blanks)
	  begin
	    pline(21:60) = pol_extdescr[2]
	    call print
	    incr lines
	  end
	if (pol_rem1prt.eq.'W' .or. pol_rem1prt.eq.'B') .and.
	&  (pol_remark1)
	  begin
	    if (lines.ge.max_lines) call continued
	    pline(21:60) = pol_remark1
	    call print
	    incr lines
	  end
	if (pol_rem2prt.eq.'W' .or. pol_rem2prt.eq.'B') .and.
	&  (pol_remark2)
	  begin
	    if (lines.ge.max_lines) call continued
	    pline(21:60) = pol_remark2
	    call print
	    incr lines
	  end
	if (pol_ref1prt.eq.'W' .or. pol_ref1prt.eq.'B') .and.
	&  (pol_refrnce1)
	  begin
	    if (lines.ge.max_lines) call continued
	    pline(21:60) = pol_refrnce1
	    call print
	    incr lines
	  end
        if (pol_ref2prt.eq.'W' .or. pol_ref2prt.eq.'B') .and.
        &  (pol_refrnce2)
	  begin
	    if (lines.ge.max_lines) call continued
            pline(21:60) = pol_refrnce2
	    call print
	    incr lines
	  end
	if (pol_slst.eq.'K') .and.
	&  (print_kits.eq.'Y') call print_kit
	call print
	incr lines
	return

	;	print line item bar codes for order/line and quantity
print_bar_codes,
	if (lp_bar_on)
	  begin
	    clear bar_code
	    bar_order = pol_order, 'XXXXXX'
	    bar_line = pol_lineno, 'XXX'

	    xcall s_bld (prbar2,,lp_bar_on,80,180)
	    ndx = %trim(prbar2)
	    xcall s_bld (prbar2,ndx,"%&%a%a%a",bar_order,bar_line,lp_bar_off)
	    call print
	    incr lines

	    bar_units = pol_ordqty, 'XXXXXX.XXX'
	    if (scanner_type) then
	      begin
	       xcall s_bld (prbar2,,lp_bar_on,1600,180)
	       ndx = %trim(prbar2)
	       xcall s_bld (prbar2,ndx,"%&%a%a",bar_units,lp_bar_off)
	       call print
	       incr lines

	       xcall s_bld (prbar2,,lp_bar_on,3200,180)
	       ndx = %trim(prbar2)
	       xcall s_bld (prbar2,ndx,"%&%a%a%a",pol_locncode,inb_bin,lp_bar_off)
	       call print
	       incr lines
	      end
	    call print
	    incr lines
	  end
	return

print_kit,
	inkitm.comp = pol_comp
	inkitm.item = pol_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.pol_comp) .or.
	    &  (inkcmp.item.ne.pol_item) return

	    prkitd = 'Kit:'
	    prkiti = inkcmp.citem
	    if (inkcmp.qty .lt. 0)
	     then prkqty = -inkcmp.qty, mask0
	     else prkqty = (inkcmp.qty * pol_ordqty), mask0
	    call print
	    incr lines
	    if (lines.gt.max_lines) call continued
	  end
	return

	;	page overflow, print continued line
continued,
	call print
	prdesc = '***** CONTINUED *****'
	call print
	call print_header
	clear lines
	return

end_of_lines,
	for ndx from 1 thru (max_lines + 2 - lines) by 1 call print
	prmessage = pom_comment1
	call print
	prmessage = pom_comment2
	call print
	call print
	pline = trail
	call print
	return

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

