;==File=================================================================;
; PO4320.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=============================================================;
;	po4320		Print receivings price labels.
;==Changes==============================================================;
; 06/26/2006 tfc - use bin from po4300 if sent
; 07/11/2001 tah - Change print method for Bartender
; 05/02/2001 tah - Change for new POSNLT file format (kits)
;=======================================================================;
.subroutine po4320

	a_order		,n	; IN  - Optional, order number to print.
	a_lineno	,n	; IN  - Optional, order line to print.
	a_bin		,a	; IN  - Optional, porecv bin

.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 "POS:posnlt.rec"
.include "INS:incomm.gbl"
.include "INS:initem.rec"
.include "INS:inlocn.rec"
.include "INS:inabin.rec"
.include "INS:inkits.rec"
.include "SMS:smcode.rec"

external function
	smctrl		,a

record	export
	exp_item	,a24		; Item ID
	exp_descr	,a30		; Item description
	exp_locncode	,a3		; Location code
	exp_locndescr	,a25		; Location name
	exp_slst	,a4		; Serial/Lot type
	exp_snlt	,a20		; Serial/Lot number
	exp_bin		,a8		; Bin
	exp_date	,a10		; Received date
	exp_price	,a12		; Price
	exp_upc		,a14		; UPC

record	poordr
	oplocn		,a3		; location
	oporno		,d6		; order number
	opline		,d3		; line item
	oppric		,a1		; price type

record	scr_rec1		; input set 1
	scr_price	,a1		; price to print
	scr_order	,d6		; order number
	scr_shpdat	,d8		; cutoff date
	scr_confirm	,a1		; confirmation switch

record
	abort		,d1
	bin_passed	,a8	; bin number passed
	cformat		,a*,	'A1:24|A25:30|A55:3|A58:25|A83:4|A87:20|'
	&			'A107:8|A115:10|A125:12|A137:14|'
	label_chan	,d3		; label records channel
	label_name	,a*,	'WRK:po4320.ddf'
	  label_extn	,a3	@label_name+11
	lbllim		,d6		; number of labels to print
	lblkit		,d6		; number of labels to print for kit
	line_passed	,d1		; order line number passed
	ndx		,d6		; loop control
	non_stock	,a1		; labels for non-stock items
	order_passed	,d1		; order number passed
	pick_type	,a1		; selection type flag
	price		,d9.3		; price to print on label
	recs_read	,d6
	set_name	,a6		; input set name
	slno_key	,a25
	  slno_comp	,a2	@slno_key
	  slno_order	,d6	@slno_key+2
	  slno_lineno	,d3	@slno_key+8
	  slno_item	,a24	@slno_key+11
	slno_qty	,d6	
	temp_name	,a14		; temp file for sort
	  temp_ext	,a3	@temp_name+11
	wdone		,d1
	wind_name	,a*,	'po4320'
	wind_no		,d2		; screen id
	work_chan	,d2		; work file channel
	work_name	,a*,	'WRK:po4320s.ddf'
	  work_ext	,a3	@work_name+12
	wrk_ctrld	,a1		; controlled flag from initem
	wrk_upc		,a14		; UPC from initem
	wrtcnt		,d5		; number of work records written
.start nopage,list

.proc
	;>>>>>	Main processing  <<<<<;
	order_passed = %passed(a_order)
	line_passed = %passed(a_lineno)
	if %passed(a_bin) bin_passed = a_bin

	call do_setup
	call open_files
	repeat
	  begin
	    if (order_passed.eq.TRUE) then
	      begin
		scr_price = '1'
		scr_order = a_order
		scr_shpdat = ut_datfil
		scr_confirm = 'Y'
		pick_type = 'O'
		pom_comp = ut_cmcomp
		pom_order = scr_order
	      end
	     else
	      begin
		call get_parameters
		if (abort.eq.TRUE) .or.
		&  (wdone.eq.TRUE) exitloop
	      end
	    if (scr_confirm.eq.'Y')
	      begin
		case pick_type of
		  begincase
		  'O': begin
			if (line_passed.eq.TRUE)
			 then call pull_one_line
			 else call pull_one
			if (%passed(a_order).eq.TRUE) exitloop
		       end
		  'A': call pull_all
		  endcase
	      end
	    xcall i_init (wind_no)
	  end
	xcall close (work_chan,DTE_CLOSE)
	if (abort.eq.FALSE)
	  begin
	    call sort_data
	    call print_report
	  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)
	ut_dummy = %smctrl(ut_cmcomp,'PO','RECVGSTYPE')
	po_cmrectyp = %d(ut_dummy(1:1))
	non_stock = %smctrl(ut_cmcomp,'PO','NONSTKLABELS')
	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 (order_passed.eq.FALSE)
	  begin
	    xcall open (pohedr_chan,'U:I',pohedr_name)
	    xcall open (poline_chan,'I:I',poline_name)
	    xcall open (posnlt_chan,'I:I',posnlt_name)
	    xcall open (initem_chan,'I:I',initem_name)
	    xcall open (inlocn_chan,'I:I',inlocn_name)
	    xcall open (inabin_chan,'I:I',inabin_name)
	    xcall open (inkits_chan,'I:I',inkits_name)
	    xcall open (smcode_chan,'I:I',smcode_name)
	  end
	label_extn = ut_userid
	xcall ascfil ('I',label_name,'OUTPUT',,,,,,,opcde)
	exp_item = 'Item ID'
	exp_descr = 'Description'
	exp_locncode = 'Loc'
	exp_locndescr = 'Loc Description'
	exp_slst = 'S/L'
	exp_snlt = 'Serial/Lot'
	exp_bin = 'Bin'
	exp_date = 'Date'
	exp_price = 'Price'
	exp_upc = 'UPC'
	xcall ascfil ('D',,export,cformat,'"','"',',','Y','Y',opcde)
	return

	;	Close the data files opened for the report
close_files,
	xcall close (work_chan,DTE_CLOSE)
	if (order_passed.eq.FALSE)
	  begin
	    xcall close (pohedr_chan,DTE_CLOSE)
	    xcall close (poline_chan,DTE_CLOSE)
	    xcall close (posnlt_chan,DTE_CLOSE)
	    xcall close (initem_chan,DTE_CLOSE)
	    xcall close (inlocn_chan,DTE_CLOSE)
	    xcall close (inabin_chan,DTE_CLOSE)
	    xcall close (inkits_chan,DTE_CLOSE)
	    xcall close (smcode_chan,DTE_CLOSE)
	  end
	if (abort.eq.FALSE)
	  begin
	    xcall ascfil ('F',,,,,,,,,opcde)
	    xcall copy (label_name,'LBL:po4320.txt')
	  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
	    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

break_on_order,
	pom_comp = ut_cmcomp
	pom_order = scr_order
	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,'VENDID',pom_vend)
	xcall i_dspfld (wind_no,'VENDID_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

	;	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=(oplocn,oporno),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)
	    pom_comp = ut_cmcomp
	    pom_order = oporno
	    xcall db_read (pohedr_chan,pohedr,pom_key,0,'M',,,opcde)
	    if (.not.opcde)
	      begin
		call print_one_label
		pom_flag4 = 'Y'
		xcall db_update (pohedr_chan,pohedr,pom_key,pohedr_log,opcde)
	      end
	  end
print_report_eof,
	return

	;	select all orders
pull_all,
	xcall db_find (pohedr_chan,ut_cmcomp,0,'M',,,opcde)
	if (opcde)
	  begin
	    xcall message (DTEPO_NOI)
	    return
	  end
	xcall status (DTEM_PRC)
	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.eq.'Y') .and.
	    &  (pom_flag3.eq.'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_status.ne.'D') .and.
	    &  ((pol_linetype.eq.'I') .or.
	    &   (non_stock.eq.'Y'))
	      begin
		oplocn = pol_locncode
		oporno = pom_order
		opline = pol_lineno
		oppric = scr_price
		writes (work_chan,poordr)
		incr wrtcnt
	      end
	  end

	;	get line items from one line
pull_one_line,
	pol_key = pom_key
	pol_lineno = a_lineno
	xcall db_read (poline_chan,poline,pol_key,0,'M',,,opcde)
	if (.not.opcde) .and.
	&  (pol_status.ne.'D') .and.
	&  ((pol_linetype.eq.'I') .or.
	&   (non_stock.eq.'Y'))
	  begin
	    oplocn = pol_locncode
	    oporno = pom_order
	    opline = pol_lineno
	    oppric = scr_price
	    writes (work_chan,poordr)
	    incr wrtcnt
	  end
	return

	;	print label for line items
print_one_label,
	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

	inl_comp = pol_comp		; Get location record
	inl_item = pol_item
	inl_locncode = pol_locncode
	xcall in_get_locn (inlocn)
	if (opcde) clear inlocn

	inb_comp = pol_comp		; Get primary bin
	inb_item = pol_item
	inb_locncode = pol_locncode
	inb_bin = '?'
	xcall in_get_abin (inabin)

	clear price
	case oppric of
	  begincase
	  'N': nop
	  '1': price = inl_price[1]
	  '2': price = inl_price[2]
	  '3': price = inl_price[3]
	  '4': price = inl_price[4]
	  '5': price = inl_price[5]
	  'A': if (inl_margin) price = (inl_acost / inl_margin)
	  'L': if (inl_margin) price = (inl_lcost / inl_margin)
	  endcase
	case po_cmrectyp of
	  begincase
	  1: lbllim = pol_recdqty
	  2: lbllim = pol_recuqty
	  endcase
	case pol_slst of
	  begincase
	  'L': begin
		slno_key = pol_key
		clear slno_item
		slno_qty = pol_recuqty
		call print_serial
	       end
	  'S': begin
		slno_key = pol_key
		clear slno_item
		slno_qty = pol_recuqty
		call print_serial
	       end
	  'K': begin
		ini_comp = pol_comp
		ini_item = pol_item
		xcall in_get_item_dat (ini_key,'CONTROLLED',wrk_ctrld)
		if (wrk_ctrld.eq.'Y') call print_normal
		call print_kit
	       end
	  endcase
	 else call print_normal
	return

	    ;	print labels for non-serial/lot numbered items
print_normal,
	ini_comp = pol_comp
	ini_item = pol_item
	xcall in_get_item_dat (ini_key,'UPC',wrk_upc)
	for ndx from 1 thru lbllim by 1
	  begin
	    exp_item = pol_item
	    exp_descr = pol_descr
	    exp_locncode = pol_locncode
	    smc_type = 'L'
	    smc_code = pol_locncode
	    xcall sm_get_code (smcode)
	    exp_locndescr = smc_descr
	    clear exp_snlt,exp_price
	    exp_bin = inb_bin
	    if %passed(a_bin) exp_bin = a_bin		; 6/26
	    xcall dtdsp (pol_recdate,exp_date)
	    if (oppric.ne.'N') exp_price = price, '$ZZZ,ZZZ.XXX'
	    exp_upc = wrk_upc
	    xcall ascfil ('D',,export,cformat,'"','"',',','Y','Y',opcde)
	  end
	return

	;	print labels for serial/lot numbered items
print_serial,
	xcall db_find (posnlt_chan,slno_key,0,'M',,,opcde)
	if (opcde)
	  begin
	    case pos_slst of
	      begincase
	      'L': lbllim = 1
	      'S': lbllim = slno_qty
	      endcase
	    call print_normal
	    return
	  end
	repeat
	  begin
	    xcall db_next (posnlt_chan,posnlt,'F','M',,,opcde)
	    if (opcde) .or.
	    &  (pos_comp.ne.slno_comp) .or.
	    &  (pos_order.ne.slno_order) .or.
	    &  (pos_lineno.ne.slno_lineno) .or.
	    &  (pos_item.ne.slno_item) return

	    if (pos_item) then		; Is this a kit component
	      begin
		exp_item = pos_item
		ini_comp = pos_comp
		ini_item = pos_item
		xcall in_get_item (initem)
		exp_descr = ini_desc
	      end
	     else
	      begin
		exp_item = pol_item
		exp_descr = pol_descr
	      end
	    exp_locncode = pol_locncode
	    smc_type = 'L'
	    smc_code = pol_locncode
	    xcall sm_get_code (smcode)
	    exp_locndescr = smc_descr
	    case pos_slst of		;;;
	      begincase
	      'S': exp_slst = 'S/N:'
	      'L': exp_slst = 'Lot:'
	      endcase
	    exp_snlt = pos_snlt
	    exp_bin = inb_bin		;;*;;
	    if %passed(a_bin) exp_bin = a_bin		; 6/26
	    clear exp_price
	    xcall dtdsp (pol_recdate,exp_date)
	    if (oppric.ne.'N') exp_price = price, '$ZZZ,ZZZ.XXX'
	    ini_comp = pos_comp
	    ini_item = exp_item
	    xcall in_get_item_dat (ini_key,'UPC',wrk_upc)
	    exp_upc = wrk_upc
	    xcall ascfil ('D',,export,cformat,'"','"',',','Y','Y',opcde)
	  end

	;	print labels for kit items
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 (.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
		  ini_comp = pol_comp
		  ini_item = inkcmp.citem
		  xcall in_get_item (initem)
		  if (ini_controlled.eq.'Y')	; Only print if controlled
		    begin
		      if (inkcmp.qty .lt. 0)
		       then lblkit = -inkcmp.qty
		       else lblkit = (lbllim * inkcmp.qty)
		      if (ini_slst.eq.'S') .or.
		      &  (ini_slst.eq.'L') then
			begin
			  slno_comp = pol_key
			  slno_order = pol_order
			  slno_lineno = pol_lineno
			  slno_item = inkcmp.citem
			  if (inkcmp.qty .lt. 0)
			   then slno_qty = -inkcmp.qty
			   else slno_qty = (lbllim * inkcmp.qty)
			  call print_serial
			end
		       else call print_kit_labels
		    end
		end
	    end
	return

print_kit_labels,
	if (inkcmp.qty .lt. 0)
	 then lblkit = -inkcmp.qty
	 else lblkit = (lbllim * inkcmp.qty)
	for ndx from 1 thru lblkit by 1
	  begin
	    exp_item = inkcmp.citem
	    exp_descr = ini_desc
	    exp_locncode = pol_locncode
	    smc_type = 'L'
	    smc_code = pol_locncode
	    xcall sm_get_code (smcode)
	    exp_locndescr = smc_descr
	    clear exp_snlt,exp_price
	    exp_bin = inb_bin
	    if %passed(a_bin) exp_bin = a_bin		; 6/26
	    xcall dtdsp (pol_recdate,exp_date)
	    if (oppric.ne.'N') exp_price = price, '$ZZZ,ZZZ.XXX'
	    exp_upc = wrk_upc
	    xcall ascfil ('D',,export,cformat,'"','"',',','Y','Y',opcde)
	  end
	return

.end

