; PO4210.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=============================================================;
;	po4210		Print receivings label pages.
;==Changes==============================================================;
; 01/08/2007 ESC - Add new Reference to function the same as Remarks
; 03/12/1998 tah - Modified to display lines list when order no. entered
; 10/24/1997 tah - Modified for bar code print module (added units)
; 07/15/1996 tah - Original program written
;=======================================================================;
.subroutine po4210

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

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*	@1,	'ITEM-NO'
			,a*	@29,	'DATE'
			,a*	@42,	'QUANTITY'
			,a*	@53,	'QUANTITY'
			,a*	@73,	'RECEIVED'
record	head3
			,a*	@27,	'REQUIRED'
			,a*	@37,	'UOM'
			,a*	@43,	'ORDERED'
			,a*	@52,	'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	locationb
	prbarord	,a60	@1
record	locationt
			,a*	@21,	'RESTOCK TO LOCATION:'
	prlocn		,a3	@42
	prlcnd		,a25	@47

record	pline
		,a80
record	,X
	prdesc		,a60	@1
	prvnid		,a24	@36
record	,X
	pritem		,a24	@1
	prrqdt		,a10	@26
	pruom		,a3	@37
	prorqt		,a10	@41
	prrem		,a10	@52
	prbin		,a8	@63
	prrcqt		,a9	@72
record	,X
	prslds1		,a4	@10
	prsnlt1		,a30	@15
	prslds2		,a4	@46
	prsnlt2		,a30	@51
record	,X
	prmessage	,a40	@21
record	,X
	prbar1		,a40	@1
	prbar2		,a40	@41

record	itemline
			,a*	@14,	'Wt:'
	prweight	,a9	@17
			,a*	@28,	'Cubes:'
	prcubes		,a7	@34
			,a*	@43,	'Pallets:'
	prpallets	,a3	@51
			,a*	@55,	'+'
	prpunits	,a3	@57
			,a*	@61,	'units'

record	label_1
			,a*	@5,	'Part No:'
	prl1_item	,a24	@14
record	label_2
	prl2_descr	,a33	@5
record	label_3
			,a*	@5,	'Purchase Order:'
	prl3_pono	,a6	@21
			,a*	@27,	'-'
	prl3_line	,a3	@28
record	label_4
			,a*	@5,	'Stock Room Location:'
	prl4_locn	,a3	@26
	prl4_bin	,a8	@30
record	label_bar
	prl_barcode	,a60

record	scr_rec1		; input set 1
	scr_orno	,d6		; order number
	scr_allsel	,a1		; all or select

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
	dash		,a*,	'________________________________________'
	eof		,d1		; end of file flag
	iqtyrem		,d6		; quantity remaining for loop
	mask0		,a11,	'   ZZZ,ZZX'
	mask2		,a10,	'ZZZZZZ.XX'
	mask3		,a11,	'ZZZZZZ.XXX'
	ndx		,d2		; loop control
	pallets		,d3		; number of pallets
	pick_type	,a1		; selection type flag
	qtyrem		,d9.3		; quantity remaining
	recs_read	,d6
	set_name	,a4		; current input set name
	temp_name	,a14		; temp file for sort
	  temp_ext	,a3	@temp_name+11
	title		,a*,	'PURCHASE ORDER RECEIVINGS'
	wdone		,d1
	wind_name	,a*,	'po4210'
	wind_no		,d2		; screen id
	work_chan	,d2		; work file channel
	work_name	,a*,	'WRK:po4210.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
	if (%passed(a_order)) then	; Order header passed, from
	  begin				;   order entry program.
	    pohedr = a_order
	    call pull_one_line
	  end
	 else
	  repeat
	    begin
	      call get_parameters
	      if (abort.eq.TRUE) .or.
	      &  (wdone.eq.TRUE) exitloop
	      call pull_one_order
	      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:16) = 'Receiving labels'
		ut_ert(18: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)
	clear wrtcnt
	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 (inabin_chan,'I:I',inabin_name)
	    xcall open (initem_chan,'I:I',initem_name)
	    xcall open (smcode_chan,'I:I',smcode_name)
	  end
	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 (inabin_chan,DTE_CLOSE)
	    xcall close (initem_chan,DTE_CLOSE)
	    xcall close (smcode_chan,DTE_CLOSE)
	  end
	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 pull_one_order
		    if (opcde) xcall i_next (wind_no,set_name,g_fldnam)
		   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)
	eof = FALSE
	repeat
	  begin
	    reads (work_chan,poordr,print_report_eof)
	    pom_comp = ut_cmcomp
	    pom_order = oporno
	    xcall db_read (pohedr_chan,pohedr,pom_key,0,'M',,,opcde)
	    if (.not.opcde)
	      begin
		call set_header
		call print_page
		pom_flag2 = 'Y'
		xcall db_update (pohedr_chan,pohedr,pom_key,pohedr_log,opcde)
	      end
	  end
print_report_eof,
	return

	;	Print the report totals
print_report_totals,
	return

pull_one_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
	if (.not.opcde)
	  begin
	    case scr_allsel of
	      begincase
	      'A': call pull_all_lines
	      'S': begin
		    xcall po_inq_line (poline,pom_key)
		    if (poline) call pull_one_line
		   end
	      endcase
	  end
	return

	;	select all lines from one order
pull_all_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.
	    &  (pol_key.ne.pom_key) exitloop
	    if (pol_status.ne.'C') call pull_one_line
	  end
	return

	;	get line items from one order
pull_one_line,
	if (pol_linetype.eq.'I' .or. pol_linetype.eq.'N') .and.
	&  (pol_status.ne.'D')
	  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
	return

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

	;	print one label page
print_page,
	pol_comp = pom_comp
	pol_order = pom_order
	pol_lineno = opline
	xcall db_read (poline_chan,poline,pol_key,0,'M',,,opcde)
	if (opcde) return

	smc_type = 'L'
	smc_code = pol_locncode
	xcall sm_get_code (smcode)
	if (opcde) clear 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 = locationb
	call print

	prlocn = pol_locncode
	prlcnd = smc_descr
	pline = locationt
	call print

	prvnid = pol_vendpn
	call print

	if (ini_edesc[1])
	 then prdesc = ini_edesc[1]
	 else prdesc = pol_descr
	call print

	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

	inb_comp = pol_comp
	inb_item = pol_item
	inb_locncode = pol_locncode
	inb_bin = '?'
	xcall in_get_abin (inabin)
	prbin = inb_bin
	prrcqt = dash
	call print
	case pol_slst of
	  begincase
	  'S': begin
		iqtyrem = qtyrem
		if (iqtyrem.gt.999) iqtyrem = 999
		for ndx from 1 thru iqtyrem by 2
		  begin
		    prslds1 = 'S/N:'
		    prsnlt1 = dash
		    prslds2 = 'S/N:'
		    prsnlt2 = dash
		    call print
		  end
	       end
	  'L': begin
		prslds2 = 'Lot:'
		prsnlt2 = dash
		prrcqt = dash
		call print
	       end
	  endcase

	call print_bar_codes

	prweight = (qtyrem * pol_weight), mask2
	prcubes = (qtyrem * pol_cubes), mask2

	ini_comp = pol_comp
	ini_item = pol_item
	xcall in_get_item (initem)
	if (opcde) clear initem
	if (ini_pallet) then
	  begin
	    pallets = (qtyrem / ini_pallet)
	    prpallets = pallets, 'ZZX'
	    prpunits = (qtyrem - (pallets * ini_pallet)), 'ZZX'
	  end
	 else clear prpallets,prpunits
	pline = itemline
	call print

	;	print any comments

	if (pol_extdescr[1])
	  begin
	    pline(21:60) = pol_extdescr[1]
	    call print
	  end
	if (pol_extdescr[2])
	  begin
	    pline(21:60) = pol_extdescr[2]
	    call print
	  end
	if (pol_rem1prt.eq.'W' .or. pol_rem1prt.eq.'B') .and.
	&  (pol_remark1)
	  begin
	    pline(21:60) = pol_remark1
	    call print
	  end
	if (pol_rem2prt.eq.'W' .or. pol_rem2prt.eq.'B') .and.
	&  (pol_remark2)
	  begin
	    pline(21:60) = pol_remark2
	    call print
	  end
        if (pol_ref1prt.eq.'W' .or. pol_ref1prt.eq.'B') .and.
        &  (pol_refrnce1)
          begin
            pline(21:60) = pol_refrnce1
            call print
          end
        if (pol_ref2prt.eq.'W' .or. pol_ref2prt.eq.'B') .and.
        &  (pol_refrnce2)
          begin
            pline(21:60) = pol_refrnce2
            call print
          end

	clear pline
	call print
	prmessage = pom_comment1
	call print
	prmessage = pom_comment2
	call print

	;	print text block

	pline(10:18) = 'Quantity Accepted:'
	pline(29:20) = dash
	call print
	call print

	pline(10:18) = 'Quantity Rejected:'
	pline(29:20) = dash
	call print
	call print

	pline(10:5) = 'MDR #'
	pline(16:38) = dash
	call print
	call print

	pline(10:10) = 'Inspector:'
	pline(21:28) = dash
	call print
	call print

	pline(10:5) = 'Date:'
	pline(16:40) = dash
	call print
	call print

	;	print peel-off label

	for ndx from 1 thru (47 - lp_cnt) by 1 call print

	prl2_descr = '*********** ACCEPTED ***********'
	pline = label_2
	call print

	prl2_descr = 'QUALITY ASSURANCE INSPECTION'
	pline = label_2
	call print

	prl1_item = pol_item
	pline = label_1
	call print
	if (lp_bar_on)
	  begin
	    xcall s_bld (prl_barcode,,lp_bar_on,360,120)
	    ndx = %trim(prl_barcode)
	    xcall s_bld (prl_barcode,ndx,"%&%a%a",pol_item,lp_bar_off)
	    pline = label_bar
	  end
	call print

	prl2_descr = 'Quantity Accepted:_______________'
	pline = label_2
	call print

	prl4_locn = pol_locncode
	prl4_bin = inb_bin
	pline = label_4
	call print
	if (lp_bar_on)
	  begin
	    xcall s_bld (prl_barcode,,lp_bar_on,360,120)
	    ndx = %trim(prl_barcode)
	    xcall s_bld (prl_barcode,ndx,"%&%a%a",pol_locncode,lp_bar_off)
	    pline = label_bar
	  end
	call print

	prl3_pono = oporno, 'XXXXXX'
	prl3_line = opline, 'XXX'
	pline = label_3
	call print

	prl2_descr = 'Accepted By:_____________________'
	pline = label_2
	call print

	prl2_descr = 'Date:       _____________________'
	pline = label_2
	call print
	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 (prbar1,,lp_bar_on,100,180)
	    ndx = %trim(prbar1)
	    xcall s_bld (prbar1,ndx,"%&%a%a%a",bar_order,bar_line,lp_bar_off)

	    bar_units = pol_ordqty, 'XXXXXX.XXX'
	    xcall s_bld (prbar2,,lp_bar_on,2800,180)
	    ndx = %trim(prbar2)
	    xcall s_bld (prbar2,ndx,"%&%a%a",bar_units,lp_bar_off)

	    call print
	    call print
	  end
	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

