;==File=================================================================;
; PO4102.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=============================================================;
;	po4102		Purchase orders for Laser forms.
;==Changes==============================================================;
; 05/03/2001 tah - Changed for printing kit components/serial numbers.
; 09/24/1997 tah - Add fax output capability.
; 09/24/1996 tah - Rework estimated freight for % or $ option.
;=======================================================================;
.subroutine po4102

	a_type		,a	; IN  - C: confirmation
				;	P: purchase order

.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:pomail.rec"
.include "INS:incomm.gbl"
.include "INS:initem.rec"
.include "INS:initvc.rec"
.include "INS:inkits.rec"
.include "SMS:smcode.rec"

external function
	smctrl		,a

record	poprnt
	popono		,d6			; purchase order number

record	pline
		,a80
record	,X
	prorno		,a10	@70
record	,X
	prname		,a34	@5
	prshto		,a34	@45
record	,X
	prsvia		,a25	@11
	prfob		,a11	@35
	prfrt		,a7	@63
record	,X
	prrqdt		,a10	@11
	prterm		,a20	@35
	prphone		,a18	@63
record	,X
	prcfrm		,a20	@11
	prbuy		,a20	@35
	prfax		,a13	@63
record	,X
	pritem		,a24	@2
	prdesc		,a28	@15
	prorqt		,a11	@44
	prcost		,a11	@56
	  prcost_q	,a7	@56
	  prcost_s	,a1	@63
	  prcost_u	,a3	@64
	pramnt		,a13	@68
record	,X
	prdescl		,a60	@6
record	,X
	prkitd		,a4	@6
	prkiti		,a24	@10
	prkqty		,a11	@44

record	totals
	tot_dollars	,d9.2		; total cost of order
	tot_weight	,d8.2		; total weight
	tot_cubes	,d8.2		; total cubes
	tot_freight	,d8.2		; total estimated freight

record
	abort		,d1
	amount		,d10.3		; line item extended amount
	buyer		,a25		; buyer name
	cost		,d9.3		; line item cost
	item_idlen	,d2		; length of item id
	line		,d2		; item line number (not used this form)
	lines		,d2		; line counter for forms
	line_max	,d2,	32	; maximum line per form
	line_prt	,d1		; line printed switch
	loop		,d2		; loop control
	mask		,a13,	'Z,ZZZ,ZZZ.XX-'
	mask0		,a11,	'    ZZZ,ZZZ'
	mask3		,a11,	'ZZZ,ZZZ.XXX'
	ndx		,d2		; loop control
	output_type	,a1		; type of output
	page		,d2		; page counter
	print_kits	,a1		; print kits flag
	reprint_type	,a1		; control (O-order, R-remaining)
	qty_remain	,d9.3		; order quantity not received
	shname		,a30		; work area for formatting address
	shadd1		,a30		; work area for formatting address
	shadd2		,a34		; work area for formatting address
	shadd3		,a34		; work area for formatting address
	slname		,a30		; work area for formatting address
	sladd1		,a30		; work area for formatting address
	sladd2		,a34		; work area for formatting address
	sladd3		,a34		; work area for formatting address
	svia		,a25		; ship via description
	terms		,a25		; terms description
	work_chan	,d2		; work file channel
	work_name	,a*,	'WRK:po4100.ddf'
	  work_ext	,a3	@work_name+11
.start nopage,list

.proc
	;>>>>>	Main processing  <<<<<;
	call do_setup
	call open_files
	call get_destination
	if (abort.eq.FALSE)
	  begin
	    call print_report
	    call print_report_totals
	    clear shname
	    case a_type of
	      begincase
	      'C': begin
		    shname(1:13) = 'Confirmations'
		    shname(15:10) = ut_datdsp, 'XX/XX/XXXX'
		   end
	      'P': begin
		    shname(1:14) = 'Purchase Orders'
		    shname(16:10) = ut_datdsp, 'XX/XX/XXXX'
		   end
	      endcase
	    xcall clslp (shname,pom_fax,'Y',pom_name,pom_confirmed)
	  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
	print_kits = %smctrl(ut_cmcomp,'PO','PRINTKITS')
	in_cmfrttyp = %smctrl(ut_cmcomp,'IN','FRTADDTYPE')
	reprint_type = %smctrl(ut_cmcomp,'PO','REPRINTTYPE')
	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)
	if (print_kits.eq.'Y') xcall open (inkits_chan,'I:I',inkits_name)
	xcall open (pomail_chan,'I:I',pomail_name)
	return

	;	Close the data files opened for the report
close_files,
	xcall close (work_chan,DTE_CLOSE)
	if (print_kits.eq.'Y') xcall close (inkits_chan,DTE_CLOSE)
	xcall close (pomail_chan,DTE_CLOSE)
	return

	;	Get the output destination
get_destination,
	abort = FALSE
	clear lp_sel
	po_cmpolp = %smctrl(ut_cmcomp,'PO','PURCHPRINTER')
	if (po_cmpolp)
	 then xcall askpr (ut_cmname,80,60,-2,po_cmpolp)
	 else xcall askpr (ut_cmname,80,60,-2,ut_cmdefp)
	if (lp_sel.eq.'E') abort = TRUE
	return

	;	Print the report
print_report,
	xcall status (DTEM_PRT)
	repeat
	  begin
	    reads (work_chan,poprnt,print_report_eof)
	    pom_comp = ut_cmcomp
	    pom_order = popono
	    xcall db_read (pohedr_chan,pohedr,pom_key,0,'M',,,opcde)
	    if (.not.opcde)
	      begin
		if (pom_mail)
		  begin
		    poa_comp = ut_cmcomp
		    poa_id = pom_mail
		    xcall po_get_mail (pomail)
		  end
		if (.not.poa_potype)
		 then output_type = 'P'
		 else output_type = poa_potype
		call print_one_order
	      end
	  end
print_report_eof,
	return

	;	Print the report totals
print_report_totals,
	return

	;	Print one order
print_one_order,
	smc_type = 'B'
	smc_code = pom_buyrcode
	xcall db_read (smcode_chan,smcode,smc_key,0,'M',,,opcde)
	if (opcde) clear smc_descr
	buyer= smc_descr

	smc_type = 'Y'
	smc_code = pom_termcode
	xcall db_read (smcode_chan,smcode,smc_key,0,'M',,,opcde)
	if (opcde) clear smc_descr
	terms = smc_descr

	smc_type = 'V'
	smc_code = pom_viacode
	xcall db_read (smcode_chan,smcode,smc_key,0,'M',,,opcde)
	if (opcde) clear smc_descr
	svia = smc_descr

	slname = pom_name
	sladd1 = pom_addr1
	clear sladd2, sladd3
	if (pom_addr2) then
	  begin
	    sladd2 = pom_addr2
	    sladd3(1:20) = pom_city
	    sladd3(22:2) = pom_state
	    sladd3(25:10) = pom_zip
	  end
	 else
	  begin
	    sladd2(1:20) = pom_city
	    sladd2(22:2) = pom_state
	    sladd2(25:10) = pom_zip
	    clear sladd3
	  end
	shname = pom_shipname
	shadd1 = pom_shipaddr1
	if (pom_shipaddr2) then
	  begin
	    shadd2 = pom_shipaddr2
	    shadd3 = pom_shipcity
	    shadd3(22:2) = pom_shipstate
	    shadd3(25:10) = pom_shipzip
	  end
	 else
	  begin
	    shadd2 = pom_shipcity
	    shadd2(22:2) = pom_shipstate
	    shadd2(25:10) = pom_shipzip
	    clear shadd3
	  end
	clear page, totals

	case output_type of
	  begincase
	  'P': begin
		call print_header
		call print_lines
		call print_trailer
	       end
	  'M': xcall u_message ('Email')	; email (formatted output)
	  'E': xcall u_message ('Electronic')	; electronic (text output)
	  endcase
	 else xcall u_message ('Invalid PO mail type code:' + output_type)

	case a_type of
	  begincase
;;;;	  'C': pom_flag1 = 'Y'
	  'P': pom_flag1 = 'Y'
	  endcase
	xcall db_update (pohedr_chan,pohedr,pom_key,pohedr_log,opcde)
	return

	;	 Print the order header
print_header,
	incr page
	for loop from 1 thru 3 by 1 call print

	prorno(1:6) = pom_order, 'XXXXXX'
	call print
	prorno(1:8) = pom_vend, 'XXXXXXXX'
	call print
	xcall dtdsp (pom_orddate,prorno)
	call print

	for loop from 1 thru 2 by 1 call print

	prname = slname
	prshto = shname
	call print
	prname = sladd1
	prshto = shadd1
	call print
	prname = sladd2
	prshto = shadd2
	call print
	prname = sladd3
	prshto = shadd3
	for loop from 1 thru 2 by 1 call print

	prsvia = svia
	case pom_fobc of
	  begincase
	  'D': prfob = 'Destination'
	  'O': prfob = 'Origin'
	  endcase
	case pom_colppd of
	  begincase
	  'C': prfrt = 'Collect'
	  'P': prfrt = 'Prepaid'
	  endcase
	call print

	xcall dtdsp (pom_reqdate,prrqdt)
	prterm = terms
	xcall phone (pom_phone,prphone)
	call print

	prcfrm = pom_confirmed
	prbuy = buyer
	xcall phone (pom_fax,prfax)
	for loop from 1 thru 4 by 1 call print
	return

	;	Print order detail lines
print_lines,
	lines = 1
	clear line
	line_prt = FALSE
	if (pom_ordtype.eq.'C')
	  begin
	    prdescl = '***** CREDIT *****'
	    call print
	    incr lines
	  end
	xcall db_read (poline_chan,poline,pom_key,0,'M',,,opcde)
	if (.not.opcde)
	  repeat
	    begin
	      case pol_linetype of
		begincase
		'I': call print_item		; stock item
		'N': call print_item		; non stock item
		endcase
	      xcall db_next (poline_chan,poline,'F','M',,,opcde)
	      if (opcde) .or.
	      &  (pol_key.ne.pom_key) return
	    end

	;	Print bottom of order
print_trailer,
	for loop from 1 thru (line_max+3)-lines by 1 call print
	pramnt = tot_dollars, mask
	call print
	pline(3:40) = pom_comment1
	call print
	pline(3:40) = pom_comment2
	pramnt = tot_weight, mask
	call print
	pramnt = tot_cubes, mask
	call print
	pramnt = tot_freight, mask
	call print
	if (lp_sel.eq.'S')
	 then call print
	 else
	  begin
	    xcall ds_store ('POO',pom_order,page)
	    lp_cnt = 98
	    xcall print
	  end
	return

	;	print a line item
print_item,
	line_prt = FALSE
	if (pol_status.eq.'D') .or.
	&  (reprint_type.eq.'R' .and. pol_status.eq.'C') return
	line_prt = TRUE
	if (lines.gt.line_max) call continued
	incr line
	case pol_linetype of
	  begincase
	  'I': begin
		if (pol_vendpn.ne.ut_blanks)
		 then pritem = pol_vendpn
		 else pritem = pol_item
		ini_comp = pol_comp
		ini_item = pol_item
		xcall in_get_item (initem)
		if (opcde)
		 then clear initem
		 else
		  begin
		    inv_comp = ini_comp
		    inv_item = ini_item
		    inv_locncode = pol_locncode
		    inv_type = 'V'
		    inv_vend_cust = pom_vend
		    xcall db_read (initvc_chan,initvc,inv_key,0,'M',,,opcde)
		    if (opcde) clear initvc
		  end
	       end
	  'N': pritem = pol_item
	  endcase
	item_idlen = %trim(pritem)
	if (item_idlen.le.12) prdesc = pol_descr
	case reprint_type of
	  begincase
	  'O': qty_remain = pol_ordqty
	  'R': qty_remain = pol_ordqty - pol_recpqty
	  endcase
	prorqt = qty_remain, mask0
	cost = pol_ucost - (pol_ucost * (pol_discpct / 100.0))
	amount = (qty_remain * cost)
	if (in_cmqtyprice.eq.'Y') then
	  begin
	    prcost_q = cost, mask3
	    prcost_s = '/'
	    prcost_u = pol_buomcode
	  end
	 else prcost = cost, mask3
	pramnt = amount, mask
	call print
	incr lines
	if (item_idlen.gt.12)
	  begin
	    prdescl = pol_descr
	    call print
	    incr lines
	  end
	for ndx from 1 thru 4
	  begin
	    if (pol_extdescr[ndx])
	      begin
		if (lines.gt.line_max) call continued
		prdescl = pol_extdescr[ndx]
		call print
		incr lines
	      end
	  end
	if (pol_rem1prt.eq.'P' .or. pol_rem1prt.eq.'B') .and.
	&  (pol_remark1)
	  begin
	    if (lines.gt.line_max) call continued
	    prdescl = pol_remark1
	    call print
	    incr lines
	  end
	if (pol_rem2prt.eq.'P' .or. pol_rem2prt.eq.'B') .and.
	&  (pol_remark2)
	  begin
	    if (lines.gt.line_max) call continued
	    prdescl = pol_remark2
	    call print
	    incr lines
	  end
	if (pol_slst.eq.'K') .and.
	&  (print_kits.eq.'Y') call print_kit
	tot_dollars = tot_dollars + amount
	tot_cubes = tot_cubes + (pol_cubes * qty_remain)
	tot_weight = tot_weight + (pol_weight * qty_remain)
	case in_cmfrttyp of
	  begincase
	  'D': tot_freight = tot_freight + (inv_freightin * qty_remain)
	  'P': tot_freight = tot_freight + ((amount * inv_freightin) / 100.0)
	  endcase
	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 * qty_remain), mask0
	    call print
	    incr lines
	    if (lines.gt.line_max) call continued
	  end
	return

	;	print continued and start a new page
continued,
	for loop from 1 thru 3 by 1 call print
	prdescl = '***** CONTINUED *****'
	call print
	if (lp_sel.eq.'S')
	 then call print
	 else
	  begin
	    xcall ds_store ('POO',pom_order,page)
	    lp_cnt = 98
	    xcall print
	  end
	call print_header
	lines = 1
	clear line
	return

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

