;==File=================================================================;
; PO4109.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=============================================================;
;	po4109		Custom Purchase orders / form 9.
;			NEBS form:      9055
;			MOORE series:   4030
;==Changes==============================================================;
; 01/08/2007 ESC - Add new Reference to function the same as Remarks
; 07/06/2006 lso - customize PO Form lines for TechForce, per Ed
; 05/03/2001 tah - Changed for printing kit components/serial numbers.
;=======================================================================;
.subroutine po4109

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

external function
	smctrl		,a

record  poprnt
	popono          ,d6                     ; purchase order number

record  pline
                ,a85
record  ,X
	prorno          ,a6     @67
record  ,X
	prvend          ,a8     @67
record  ,X
	prname          ,a35    @6
	prshto          ,a35    @46
record  ,X
	prdate          ,a8     @1
	prsvia          ,a15    @11
	prfob           ,a11    @30
	prterm          ,a25    @53
record  ,X
	prbuyr          ,a3     @1
	prclpd          ,a7     @11
	prrqdt          ,a8     @25
	prcfrm          ,a20    @35
record  ,X
        prorqt          ,a7     @1
        pritem          ,a20    @9
        prdesc          ,a30    @30
        prcost          ,a10    @61
          prcost_q      ,a8     @61
        pramnt          ,a11    @70
record	,X
	prkitd		,a4	@10
	prkiti		,a24	@14
	prkqty		,a8	@1

record
	abort		,d1
	amount          ,d9.3		; line item extended amount
	buyer           ,a25		; buyer name
	cost            ,d9.3		; line item cost
	line            ,d2		; item line number (not used this form)
	lines           ,d2		; line counter for forms
	line_max        ,d2,	30	; maximum lines per form
	loop            ,d2		; loop control
	mask0           ,a8,    'ZZZZ,ZZZ'
	mask            ,a11,   'ZZZZZZZ.XX-'
	mask3           ,a10,   'ZZZZZZ.XXX'
	mask3q          ,a8,    'ZZZZ.XXX'
	ndx		,d2		; loop control
	page		,d2		; page counter
	print_kits	,a1		; print kits flag
	qty_remain	,d9.3		; quantity remaining
	reprint_type	,a1		; control (O-order, R-remaining)
	shname		,a25		; work area for formatting address
	shadd1		,a25		; work area for formatting address
	shadd2		,a35		; work area for formatting address
	shadd3		,a35		; work area for formatting address
	slname		,a25		; work area for formatting address
	sladd1		,a25		; work area for formatting address
	sladd2		,a35		; work area for formatting address
	sladd3		,a35		; work area for formatting address
	svia		,a25		; ship via description
	terms		,a25		; terms description
	tot_order       ,d9.3		; total cost of order
	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)
	  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')
	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)
	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)
	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,85,60,-2,po_cmpolp)
         else xcall askpr (ut_cmname,85,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) call print_one_order
	  end
print_report_eof,
	return

	;	Print the report totals
print_report_totals,
	return

print_one_order,
	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, tot_order

	call print_header
	call print_lines
	call print_trailer
	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 top of order
print_header,
	lp_cnt = 61
	case a_type of
	  begincase
	  'C': pline(59:22) = '* ORDER CONFIRMATION *'
	  'P': prorno = pom_order, 'XXXXXX'
	  endcase
	call print
	call print
	prvend = pom_vend, 'XXXXXXXX'
	for loop from 1 thru 8 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
	call print

	for loop from 1 thru 6 by 1 call print
	xcall dtdsp (pom_orddate,prdate)
	prsvia = svia
	case pom_fobc of
	  begincase
	  'O': prfob = 'Origin'
	  'D': prfob = 'Destination'
	  endcase
	prterm = terms
	call print
	call print

	prbuyr = pom_buyrcode
	case pom_colppd of
	  begincase
	  'C': prclpd = 'Collect'
	  'P': prclpd = 'Prepaid'
	  endcase
	xcall dtdsp (pom_reqdate,prrqdt)
	prcfrm = pom_confirmed
	call print
	for loop from 1 thru 2 by 1 call print
	return

	;       Print order detail lines
print_lines,
	lines = 1
	clear line
	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) exitloop
	    end
	return

	;       Print bottom of invoice
print_trailer,
	for loop from 1 thru line_max-lines by 1 call print
	prdesc = 'PURCHASE ORDER TOTAL:'
	pramnt = tot_order, mask
	call print
	pline(1:40) = pom_comment1
	call print
	pline(1:40) = pom_comment2
	call print
	if (lp_sel.eq.'S')
	 then call print
	 else
	  begin
	    xcall ds_store ('PO1',pom_order,page)
	    lp_cnt = 98
	    xcall print
	  end
	return

	;       Print a line item
print_item,
	if (pol_status.eq.'D') .or.
	&  (reprint_type.eq.'R' .and. pol_status.eq.'C') return
	if (lines.gt.line_max) call continued
	incr line
	case reprint_type of
	  begincase
	  'O': qty_remain = pol_ordqty
	  'R': qty_remain = pol_ordqty - pol_recpqty
	  endcase
	case in_cmqdec of
	  begincase
	  0: prorqt = qty_remain, mask0
	  3: prorqt = qty_remain, mask3q
	  endcase
	case pol_linetype of
	  begincase
	  'I': if (pol_vendpn.ne.ut_blanks)
		then pritem = pol_vendpn
		else pritem = pol_item
	  'N': pritem = pol_item
	  endcase
	prdesc = pol_descr
	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
	tot_order = tot_order + amount

	if (pol_extdescr[1])
	  begin
	    if (lines.gt.line_max) call continued
	    pline(11:60) = pol_extdescr[1]
	    call print
	    incr lines
	  end
	if (pol_extdescr[2].ne.ut_blanks)
	  begin
	    pline(11:60) = pol_extdescr[2]
	    call print
	    incr lines
	  end
	if (pol_rem1prt.eq.'P' .or. pol_rem1prt.eq.'B')
	  begin
	    if (lines.gt.line_max) call continued
	    pline(11:60) = pol_remark1
	    call print
	    incr lines
	  end
	if (pol_rem2prt.eq.'P' .or. pol_rem2prt.eq.'B')
	  begin
	    if (lines.gt.line_max) call continued
	    pline(11:60) = pol_remark2
	    call print
	    incr lines
	  end
        if (pol_ref1prt.eq.'P' .or. pol_ref1prt.eq.'B')
          begin
            if (lines.gt.line_max) call continued
            pline(11:60) = pol_refrnce1
            call print
            incr lines
          end
        if (pol_ref2prt.eq.'P' .or. pol_ref2prt.eq.'B')
          begin
            if (lines.gt.line_max) call continued
            pline(11:60) = pol_refrnce2
            call print
            incr lines
          end
	if (pol_slst.eq.'K') .and.
	&  (print_kits.eq.'Y') call print_kit
	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
	prdesc = '***** CONTINUED *****'
	call print
	if (lp_sel.eq.'S')
	 then call print
	 else
	  begin
	    xcall ds_store ('PO1',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

