;==File=================================================================;
; PO4000.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=============================================================;
;       po4000          Purchase order entry.
;       po4000tb        Toolbar routine.
;	po4000_copy	Copy history invoice.
;==Changes==============================================================;
; 03/30/3009 lso - per tfc, adj clear and not clear tot fields for Copy
;		   and exclude deleted lines for new PO
; 01/08/2007 ESC - Add new Reference to function the same as Remarks
; 08/28/2006 tfc swo154 - add control for costs origin
; 08/21/2006 tfc swo154 - on copied orders, default required date to sys date
; 08/18/2006 tfc swo154 - add copy routine
; 06/12/2001 tah - Add code for company switching.
; 05/07/2001 tah - Changes to load default codes from smctrl file.
; 10/02/2000 tah - Changes for i_disable xcall.
; 09/22/2000 tah - Changed to stay in ADD mode.
;=======================================================================;
.subroutine po4000

	a_vendid        ,a      ; IN  - Vendor ID from CM

.start nopage,nolist
.include "WND:toolbar.def"
.include "WND:tools.def"
.include "WND:fldinf.def"
.include "UTS:dtb.gbl"

.include "UTS:dteut.def"
.include "POS:dtepo.def"
.include "NAS:dtena.def"
.include "INS:dtein.def"

.include "UTS:utcomm.gbl"
.include "INS:incomm.gbl"
.include "POS:pocomm.gbl"
.include "POS:poline.rec"
.include "POS:pomail.rec"
.include "NAS:nacomm.gbl"
.include "NAS:namast.rec"
.include "NAS:nacont.rec"
.include "APS:apcomm.gbl"
.include "APS:apvend.rec"
.include "SMS:smcode.rec"

external function
	inp_done        ,^val
	smctrl          ,a
	smctrl_put      ,a

.define po4000_GBL, 1
.include "POS:po4000.gbl"
.undefine po4000_GBL

.align
record
	col_id          ,i4
	load_chan       ,i4             ; transaction load channel
	poline_lchan    ,i4             ; line item load channel
	totals_id       ,i4             ; totals window id
	abort           ,d1             ; Abort flag
	beg_key         ,a8
	  beg_comp      ,a2     @beg_key
	  beg_order     ,a6     @beg_key+2
	default_buyr    ,a3             ; default buyer code
	default_locn    ,a3             ; Default location code
	default_svia    ,a3             ; Default ship via code
	default_term    ,a3             ; default terms code
	field_error     ,d3
	force_next      ,d1
	full_name       ,a40            ; Work area for formatting name
	head_on_file    ,d1             ; Header record on file flag
	hold_setname    ,a20
	invc_amt        ,d10.2          ; total invoice amount
	new_order_no    ,d6             ; Saved order no for abort processing
	next_order_no   ,d6             ; Saved order no for abort processing
	totals_name     ,a*,    'po4000d'
	wind_name       ,a7,    'po4000h'
	work_cost       ,d9.3           ; cost for call to calculate price
.start nopage,list

.proc
	call do_setup                   ; Set up environment and security
	call open_files                 ; Open needed data file tables
	call init_windows               ; Init windows routines
	call init_data_toolbar          ; Init the data toolbar
	repeat                          ; Loop to process the input window
	  begin
	    call process_input
	    if (g_entnam.eq.'END') exitloop
	  end
	call close_files                ; Close all data files
	call do_shutdown                ; Clean up
	xreturn                         ; Return to calling program

	;       Open the needed data files
open_files,
	xcall open (pohedr_chan,'U:I',pohedr_name)
	xcall open (load_chan,'I:I',pohedr_name,D_LOCAL)
	xcall open (poline_chan,'U:I',poline_name)
	xcall open (poline_lchan,'I:I',poline_name,DTE_LOCAL)
	xcall open (pomail_chan,'I:I',pomail_name)
	xcall open (namast_chan,'I:I',namast_name)
	xcall open (nacont_chan,'I:I',nacont_name)
	xcall open (apvend_chan,'I:I',apvend_name)
	xcall open (initem_chan,'I:I',initem_name)
	xcall open (inlocn_chan,'U:I',inlocn_name)
	xcall open (inabin_chan,'U:I',inabin_name)
	xcall open (initvc_chan,'I:I',initvc_name)
	xcall open (inkits_chan,'I:I',inkits_name)
	xcall open (smcode_chan,'I:I',smcode_name)
	return

	;       Close the data files
close_files,
	xcall close (pohedr_chan,DTE_CLOSE)
	xcall close (load_chan,DTE_CLOSE)
	xcall close (poline_chan,DTE_CLOSE)
	xcall close (poline_lchan,DTE_CLOSE)
	xcall close (pomail_chan,DTE_CLOSE)
	xcall close (namast_chan,DTE_CLOSE)
	xcall close (nacont_chan,DTE_CLOSE)
	xcall close (apvend_chan,DTE_CLOSE)
	xcall close (initem_chan,DTE_CLOSE)
	xcall close (inlocn_chan,DTE_CLOSE)
	xcall close (inabin_chan,DTE_CLOSE)
	xcall close (initvc_chan,DTE_CLOSE)
	xcall close (inkits_chan,DTE_CLOSE)
	xcall close (smcode_chan,DTE_CLOSE)
	return

do_setup,
	xcall e_enter                   ; Enter a new environment
	xcall lodcol ('RL')             ; remove local columns
	ut_calprg = 'po4000'
	xcall lodtoolbar ('AB',4)       ; Add notes button to main toolbar
	if (ut_windows.eq.FALSE) xcall lodcol ('LPL','inq_po4000h',col_id)
	default_buyr = %smctrl(ut_cmcomp,'PO','DEFAULT-BUYR')
	default_locn = %smctrl(ut_cmcomp,'PO','DEFAULT-LOCN')
	default_term = %smctrl(ut_cmcomp,'PO','DEFAULT-TERM')
	default_svia = %smctrl(ut_cmcomp,'PO','DEFAULT-SVIA')
	po_cmoato = %smctrl(ut_cmcomp,'PO','AUTOORDERNO')
	return

do_shutdown,
	clear g_entnam
	xcall lodinp ('D')
	xcall lodtoolbar ('RB',4)       ; Remove notes button
	xcall dtb_close                 ; Close data toolbar
	xcall e_exit                    ; Exit the current environment
	return

	;       Initialize the window information
init_windows,
	clear field_info
	xcall lodwin ('LPL',wind_name,inp_wind_no)
	field_enabled = TRUE
	xcall po4000l ('I',pohedr,apvend,poline_lchan,totals_id)
	xcall lodinp ('PD')             ; Place and disable input column
	xcall dte_able ('D','COPY',inp_wind_no,col_id)
	return

	;       Initialize the data toolbar functions
init_data_toolbar,
	dtb_add = sec_opta              ; Add per security
	dtb_chg = sec_optc              ; Change per security
	dtb_del = sec_optd              ; Delete per security
	dtb_mov = 'Y'                   ; Allow movement
	beg_comp = ut_cmcomp            ; Set up access key mask
	xcall dtb_init (pohedr_chan,inp_wind_no,beg_comp,,'po4000tb',,pohedr_log)
	xcall po4000tb ('FRST')         ; Position and display first
	call display_linked_fields      ;  record on file
	return

	;       Do input for the window
process_input,
	head_on_file = TRUE
	repeat
	 begin
	  force_next = FALSE
	  dtb_abort = FALSE
	  dtb_setname = 'set_chg'
	  if (hold_setname) dtb_setname = hold_setname
	  if (dtb_setname.eq.'set_add')
	   then xcall i_next (inp_wind_no,dtb_setname,"*FRST*")
	   else xcall i_next (inp_wind_no,dtb_setname,"*NONE*")
	  do begin
	    if (force_next.eq.TRUE)
	      begin
		xcall i_next (inp_wind_no,dtb_setname,"*NEXT*")
		force_next = FALSE
	      end
	    xcall i_input (inp_wind_no,dtb_setname,pohedr,,ut_col_sel,,ut_windows)
	    if g_select
	      begin
		if (g_entnam.ne.'^') .and.
		&  (g_entnam.ne.'@') xcall po4000tb (g_entnam)
		case g_entnam of
		  begincase
		  'END':   if (dtb_function.ne.'A')
			    then return
			    else
			      begin
				xcall po4000tb ('CANC')
				if (head_on_file.eq.FALSE) call abort_next_no
				call display_linked_fields
				xcall lodinp ('D')
				if (.not.ut_windows)
				& xcall dte_able('D','COPY',inp_wind_no,col_id)
			      end
		  '^ADD': call set_up_for_add
		  '^CANC':begin
			    if (head_on_file.eq.FALSE) 
			      begin
				call abort_next_no
				xcall dte_able ('D','COPY',inp_wind_no,col_id)
			      end
			    call display_linked_fields
			    xcall lodinp ('D')
			  end
		  '^DEL': begin
			    call can_we_edit
			    if (opcde.eq.TRUE)
			      begin
				xcall confirm (opcde,2)
				if (opcde.eq.TRUE)
				  begin
				    call delete_alldist
				    xcall po4000tb ('^DISABLE')
				    call display_linked_fields
				    xcall lodinp ('D')
				    xcall po4000tb ('CANC')
				  end
			      end
			  end
		  '^DISP':call display_linked_fields
		  '^EDIT':begin
			    xcall dte_able ('D','COPY',inp_wind_no,col_id)
			    xcall i_next (inp_wind_no,dtb_setname,'*FRST*')
			    head_on_file = TRUE
			    call set_input_fields
			    xcall lodinp ('E')
			  end
		  '^FIND':call find_record
		  '^UPDT': if (%inp_done(inp_wind_no,dtb_setname).eq.TRUE)
			    begin
			      hold_setname = dtb_setname
			      call update_record
			      if (.not.field_error) .and. (.not.opcde) return
			    end
		  'DETL': if (dtb_function.eq.'A') .or.
			  &  (dtb_function.eq.'E')
			    begin
			      call can_we_edit
			      if (opcde.eq.TRUE) call input_detail_lines
			      if (opcde.eq.TRUE)
				begin
				  call verify_record
				  if (.not.field_error) call input_detail_lines
				end
			    end
		  'PRNT': if (pom_ordtype.ne.'H') .and.
			  &  (pom_ordtype.ne.'X') xcall po4100 (pohedr)
		  'COPY': begin
			    xcall po4000_copy
			    if (.not.opcde) then
			      begin
				xcall i_display (inp_wind_no,'set_show',pohedr)
				call display_linked_fields
				xcall dtb_update (dtb_key,dtb_table,opcde,1)
				xcall i_disable (D_ALL,inp_wind_no)
				field_enabled = FALSE
				clear hold_setname
				head_on_file = TRUE
			      end
			     else
			      if (.not.ut_windows)
				begin
				  call set_up_for_add
				  g_setsts = -1
				end
			  end
		  'NOTES':begin
			    g_entnam = 'U_NOTES'
			    xcall usr_utils (pohedr)
			  end
		  '@':    call process_signal
		  endcase
	      end
	  end until (.not.g_setsts) .and. (.not.g_select)
	  if (.not.ut_windows) .and.
	  &  (dtb_function.eq.'A' .or. dtb_function.eq.'E')
	    begin
	      call can_we_edit
	      if (opcde.eq.TRUE) call input_detail_lines
	      if (dtb_function.ne.'A') xcall lodinp ('D')
	    end 
	 end
	return

	;       Process any break signals
process_signal,
	force_next = (.not.ut_windows)
	case g_entnam of
	  begincase
	  '@PHORNO': call order_no_change
	  '@PHVEND': call vend_id_change
	  '@PHMAIL': call mail_id_change
	  '@PHSHIP': call ship_id_change
	  '@PHTYPE': call order_type_change
	  '@SWCOMP': call reset_environment
	  endcase
	return

set_up_for_add,
	call add_order_setup
	xcall lodinp ('E')
	hold_setname = 'set_add'
	head_on_file = FALSE
	if (po_cmoato.eq.'Y')
	 then xcall i_next (inp_wind_no,dtb_setname,'PHVEND')
	 else xcall i_next (inp_wind_no,dtb_setname,'PHORNO')
	xcall dte_able ('E','COPY',inp_wind_no,col_id)
	return

	;       XCall to input detail lines
input_detail_lines,
	xcall dte_able ('D','COPY',inp_wind_no,col_id)
	if (head_on_file.eq.FALSE)
	  begin
	    call update_record
	    if (field_error) return
	  end
	xcall dtb_toolbar ('DI')        ; disable toolbar
	xcall lodtoolbar ('DA',9)       ; Disable switch company button
	xcall lodwin ('LPL',totals_name,totals_id)
	xcall po4000l ('G',pohedr,apvend,poline_lchan,totals_id)
	if (pom_entstatus.eq.'H') pom_entstatus = 'L'
	xcall dtb_update (dtb_key,dtb_table,opcde,1)    ; force update
	xcall po4000tb ('^DISABLE')
	xcall lodwin ('D',,totals_id)
	xcall lodtoolbar ('EA',9)       ; Enable switch company button
	xcall dtb_toolbar ('EN')        ; enable toolbar
	;       Stay in add function
	if (dtb_function.eq.'A')
	  begin
	    xcall po4000tb ('ADD')
	    call set_up_for_add
	  end
	return

	;-------------------------- break processing for reference window
	;       Get next transaction order number
get_next_no,
	if (po_cmoato.eq.'Y') then
	  begin
	    xcall i_disable (inp_wind_no,'PHORNO')
	    new_order_no = %smctrl_put(ut_cmcomp,'PO','NEXTORDERNO',,,1,'+')
	    pom_order = new_order_no
	    xcall i_dspfld (inp_wind_no,'PHORNO',pom_order)
	  end
	 else xcall i_enable (inp_wind_no,'PHORNO')
	return

	;        Break on order number (add process)
order_no_change,
	xcall db_find (pohedr_chan,pom_key,0,'M',,,opcde)
	if (.not.opcde)
	  begin
	    xcall message (DTEPO_HOF)
	    xcall po4000tb ('CANC')
	  end
	return

	;       Break on vendor ID
vend_id_change,
	nam_comp = na_cmuseco           ; Read name record
	nam_id = pom_vend
	xcall na_get_name (namast,inp_wind_no,'PHVEND','PHVEND_DESCR',
	&       'PHVEND_ADDR1','PHVEND_ADDR2','PHVEND_CITY','PHVEND_STATE',
	&       'PHVEND_ZIP')
	if (opcde)                      ; name not found
	  begin
	    call reset_vendor_field
	    return
	  end
	if (nam_type(1).ne.'Y')         ; name is not a VENDOR
	  begin
	    xcall message (DTENA_NNV)
	    call reset_vendor_field
	    return
	  end
	if (nam_status.eq.'I')          ; name is inactive
	  begin
	    xcall message (DTEPO_VIA)
	    call reset_vendor_field
	    return
	  end
	apv_comp = na_cmuseco           ; get vendor record
	apv_id = nam_id
	xcall ap_get_vend(apvend)
	if (apv_stus.eq.'I')            ; vendor is inactive
	  begin
	    xcall message (DTEPO_VIA)
	    call reset_vendor_field
	    return
	  end

	pom_name = nam_name
	pom_addr1 = nam_addr1
	pom_addr2 = nam_addr2
	pom_city = nam_city
	pom_state = nam_state
	pom_zip = nam_zip
	pom_phone = nam_phone
	pom_fax = nam_fax
	pom_termcode = apv_term         ; set vendor defaults
	pom_viacode = default_svia
	pom_locncode = default_locn
	if (apv_contact)                ; read contact name
	  begin
	    nac_comp = nam_comp
	    nac_id = nam_id
	    nac_contno = apv_contact
	    xcall na_get_cont (nacont,inp_wind_no,,'PHCFRM')
	    if (.not.opcde)
	      begin
		xcall s_bld (full_name,,'%a %a',nac_firstname,nac_lastname)
		pom_confirmed = full_name
		pom_phone = nac_phone
		pom_fax = nac_fax
	      end
	  end
	return

	;       Mail to ID changed
mail_id_change,
	if (pom_mail.eq.0) return
	nam_comp = na_cmuseco                   ; Get name address record
	nam_id = pom_mail
	xcall na_get_name (namast)
	if (opcde)
	  begin
	    call reset_mail_field
	    return
	  end

	if (nam_type(4).ne.'Y')         ; name is not a MAIL TO
	  begin
	    xcall message (DTENA_NNM)
	    call reset_mail_field
	    return
	  end

	pom_name = nam_name                     ; Set name address information
	pom_addr1 = nam_addr1
	pom_addr2 = nam_addr2
	pom_city = nam_city
	pom_state = nam_state
	pom_zip = nam_zip
	pom_phone = nam_phone
	pom_fax = nam_fax

	poa_comp = nam_comp                     ; Get mail to record
	poa_id = nam_id
	xcall po_get_mail (pomail)
	if (.not.opcde) .and.                   ; Mail record found
	&  (poa_contact)                        ;  and contact is non zero
	  begin
	    nac_comp = ut_cmcomp                ; Get contact record
	    nac_id = nam_id
	    nac_contno = poa_contact
	    xcall na_get_cont (nacont)
	    if (.not.opcde)                     ; Contact record found
	      begin                             ;  set phone and fax
		pom_phone = nac_phone
		pom_fax = nac_fax
	      end
	  end
	xcall i_dspfld (inp_wind_no,'PHVEND_DESCR',pom_name)
	xcall i_dspfld (inp_wind_no,'PHVEND_ADDR1',pom_addr1)
	xcall i_dspfld (inp_wind_no,'PHVEND_ADDR2',pom_addr2)
	xcall i_dspfld (inp_wind_no,'PHVEND_CITY',pom_city)
	xcall i_dspfld (inp_wind_no,'PHVEND_STATE',pom_state)
	xcall i_dspfld (inp_wind_no,'PHVEND_ZIP',pom_zip)
	xcall i_dspfld (inp_wind_no,'PHPHON',pom_phone)
	xcall i_dspfld (inp_wind_no,'PHFAX',pom_fax)
	return

	;       Ship to ID changed
ship_id_change,
	if (pom_shipid.eq.0)                    ; allow entry of address
	  begin
	    call find_ship_to
	    return
	  end
	if (pom_shipid.lt.0)                    ; ship to id
	  begin
	    call get_ship_to
	    xcall i_next (inp_wind_no,dtb_setname,'PHPHON')
	    force_next = FALSE
	    return
	  end
	nam_comp = na_cmuseco                   ; some name id
	nam_id = pom_shipid
	xcall na_get_name (namast)
	if (opcde) then
	  begin
	    xcall i_next (inp_wind_no,dtb_setname,'PHSHIP')
	    force_next = FALSE
	  end
	 else
	  begin
	    pom_shipid = nam_id
	    pom_shipname = nam_name
	    pom_shipaddr1 = nam_addr1
	    pom_shipaddr2 = nam_addr2
	    pom_shipcity = nam_city
	    pom_shipstate = nam_state
	    pom_shipzip = nam_zip
	    xcall i_display (inp_wind_no,'SET_SHTO',pohedr)
	    xcall i_next (inp_wind_no,dtb_setname,'PHPHON')
	    force_next = FALSE
	  end
	return

find_ship_to,
	xcall ut_find ('smcode',smcode_chan,smcode,'H',0,0)
	if (smcode) then
	  begin
	    pom_shipid = smc_code
	    pom_shipid = -pom_shipid
	    call set_ship_to
	  end
	 else
	  begin
	    clear pom_shipname,pom_shipaddr1,pom_shipaddr2,pom_shipcity,
	    &     pom_shipstate,pom_shipzip
	    xcall i_display (inp_wind_no,'SET_SHTO',pohedr)
	  end
	return

get_ship_to,
	smc_type = 'H'
	smc_code = pom_shipid, 'XXX'
	xcall numrt (smc_code,'0')
	xcall sm_get_code (smcode)
	call set_ship_to
	return

set_ship_to,
	pom_shipname = ut_cmname
	pom_shipaddr1 = smch_addr1
	pom_shipaddr2 = smch_addr2
	pom_shipcity = smch_city
	pom_shipstate = smch_stat
	pom_shipzip = smch_zip
	xcall i_display (inp_wind_no,'SET_SHTO',pohedr)
	return

	;       Order type changed
order_type_change,
;;;     xcall u_message ('Order type change')
	return

	;       Transaction aborted, try to decrease next order no
abort_next_no,
	if (po_cmoato.eq.'Y')
	  begin
	    next_order_no = %smctrl(ut_cmcomp,'PO','NEXTORDERNO')
	    if (next_order_no .eq. new_order_no+1)
		new_order_no = %smctrl_put(ut_cmcomp,'PO','NEXTORDERNO',,,1,'-')
	  end
	return

reset_vendor_field,
	xcall i_init (inp_wind_no,,,'PHVEND')
	xcall i_next (inp_wind_no,dtb_setname,'PHVEND')
	force_next = FALSE
	return

reset_mail_field,
	xcall i_init (inp_wind_no,,,'PHMAIL')
	xcall i_next (inp_wind_no,dtb_setname,"PHMAIL")
	force_next = FALSE
	return

	;       Add new order
add_order_setup,
	pom_comp = ut_cmcomp
	pom_shipid = -1
	xcall i_putfld (inp_wind_no,dtb_setname,pohedr,'PHSHIP',pom_shipid)
	call get_ship_to
	clear pom_flag1,pom_flag2,pom_flag3,pom_flag4,pom_totamt,
	&     pom_totrcvd,pom_totinvcd,pom_invcdate,pom_invcno,
	&     pom_ordwgt,pom_ordcubes
	pom_buyrcode = default_buyr
	pom_termcode = default_term
	pom_viacode = default_svia
	pom_locncode = default_locn
	pom_entstatus = 'H'
	if %passed (a_vendid)
	  begin
	    xcall i_putfld (inp_wind_no,dtb_setname,pohedr,'PHVEND',a_vendid)
	    call vend_id_change
	  end
	call get_next_no
	return

	;       Set up input fields for data input
set_input_fields,
	call can_we_edit
	if (opcde.eq.FALSE) xcall po4000tb ('CANC')
	return

	;       Check to see if order can be edited
can_we_edit,
	opcde = TRUE
	if (pom_status.eq.'C')
	  begin
	    xcall status (DTEPO_OCN)
	    opcde = FALSE
	    return
	  end
	if (pom_ordtype.eq.'X')
	  begin
	    xcall message (DTEPO_OIX)
	    opcde = FALSE
	    return
	  end
	if (pom_flag3.eq.'Y') xcall message (DTEPO_RPD)
	return

	;       Reset the environment
reset_environment,
	call do_shutdown        ; Shutdown current environment
	xcall set_coname_header ; Set company name into header
	call do_setup           ; Enter new environmenu
	call open_files         ; Open needed data file tables
	call init_windows       ; Init windows routines
	call init_data_toolbar  ; Init the data toolbar
	return

	;       Find a record by key or as a lookup list window
	;               (this is coded however needed)
find_record,
	xcall pohedr_lookup(dtb_inwindno,dtb_chan,dtb_table,dtb_key)
	call display_linked_fields
	return

	;       Write the record to the file
update_record,
	call verify_record
	if (field_error)
	 then xcall message (DTEM_RCERR)
	 else
	  begin
	    xcall dtb_update (dtb_key,dtb_table,opcde)
	    if (.not.opcde)
	      begin
		xcall i_disable (D_ALL,inp_wind_no)
		field_enabled = FALSE
		clear hold_setname
		head_on_file = TRUE
	      end
	  end
	return

	;       Display all linked fields
display_linked_fields,
	if (pom_vend.ne.0)              ; Not a cash sale
	  begin
	    nam_comp = na_cmuseco
	    nam_id = pom_vend
	    xcall na_get_name (namast,inp_wind_no,'PHVEND','PHVEND_DESCR',
	    &   'PHVEND_ADDR1','PHVEND_ADDR2','PHVEND_CITY','PHVEND_STATE',
	    &   'PHVEND_ZIP')
	    apv_comp = na_cmuseco
	    apv_id = nam_id
	    xcall ap_get_vend (apvend)
	  end
	smc_type = 'V'
	smc_code = pom_viacode
	xcall sm_get_code (smcode,inp_wind_no,,'PHSVIA_DESCR')
	smc_type = 'L'
	smc_code = pom_locncode
	xcall sm_get_code (smcode,inp_wind_no,,'PHLOCN_DESCR')
	smc_type = 'Y'
	smc_code = pom_termcode
	xcall sm_get_code (smcode,inp_wind_no,,'PHTERM_DESCR')
	smc_type = 'B'
	smc_code = pom_buyrcode
	xcall sm_get_code (smcode,inp_wind_no,,'PHBUYR_DESCR')
	xcall i_next (inp_wind_no,,'*NEXTCTL*')
	return

	;       display order totals
display_totals,
	xcall i_dspfld (totals_id,'ORDTOT',pom_totamt)
	xcall i_dspfld (totals_id,'ORDWGT',pom_ordwgt)
	xcall i_dspfld (totals_id,'ORDCUB',pom_ordcubes)
	xcall i_dspfld (totals_id,'ORDUNT',pom_ordqty)
	return

	;       Check the record for valid information
verify_record,
	clear field_error
	if (pom_order.eq.0) incr field_error
	return

	;       delete all distribution records for a reference
delete_alldist,
	xcall db_read (pohedr_chan,pohedr,pom_key,0,'M',,,opcde)
	xcall po4000l ('D',pohedr,apvend,poline_lchan,totals_id)
	pom_ordtype = 'X'
	xcall db_update (pohedr_chan,pohedr,pom_key,pohedr_log,opcde)
	xcall message (DTEPO_OIX)
	return
.end
;=======================================================================;
.subroutine po4000tb

	a_param         ,a

.start nopage,nolist
.include "UTL:tools.def"
.include "UTS:dtb.gbl"
.include "UTS:utcomm.gbl"
.include "POS:po4000.gbl"
.start nopage,list

.proc

.include "UTS:dtbfunct.inc"

.end
;=======================================================================;

.subroutine po4000_copy

.start nopage,nolist
.include "WND:tools.def"
.include "UTS:utcomm.gbl"
.include "POS:pocomm.gbl"
.include "INS:incomm.gbl"
.include "POS:poline.rec"
.include "POS:pohist.rec"
.include "POS:po4000.gbl"
.include "INS:initem.rec"
.include "INS:inlocn.rec"
.include "NAS:namast.rec"
.include "SMS:smcomm.gbl"
.include "SMS:smcode.rec"

external function
	smctrl          ,a

record
	costorigin	,a1		; origin of P/O cost
					; I - Item record
					; P - Original P/O
					; Z - Zero cost
	default_buyr    ,a3             ; default buyer code
	default_locn    ,a3             ; Default location code
	default_svia    ,a3             ; Default ship via code
	default_term    ,a3             ; default terms code
	ndx		,d2
	order_id	,d2		; invoice screen id
	order_name	,a*,	'po4000v'
	order_no	,d6
	order_type	,a1
	pokey		,a8
	  comp		,a2	@pokey
	  order		,d6	@pokey+2
	save_order	,d6		; order assigned in po4000

.start nopage,list

.proc
	call open_files			; Open needed data file tables
	call do_copy
	call close_files		; Close all data files
	xreturn				; Return to calling program

	;	Open the needed data files
open_files,
	xcall open (pohist_chan,'I:I',pohist_name)
	default_buyr = %smctrl(ut_cmcomp,'PO','DEFAULT-BUYR')
	default_locn = %smctrl(ut_cmcomp,'PO','DEFAULT-LOCN')
	default_term = %smctrl(ut_cmcomp,'PO','DEFAULT-TERM')
	default_svia = %smctrl(ut_cmcomp,'PO','DEFAULT-SVIA')
	costorigin = %smctrl(ut_cmcomp,'PO','COSTORIGIN')
	return

	;	Close the data files
close_files,
	xcall close (pohist_chan,DTE_CLOSE)
	return

do_copy,
	opcde = -1
	call get_order 
	if (order_no)
	  begin
	    if (order_type.eq.'P') then call get_hist 
	     else call get_hedr
	    if (opcde) then
	      if (.not.ut_windows) xcall message (DTEPO_HNF,D_ERROR)
	  end
	return

	;	Get the order to copy
get_order,
	xcall lodwin ('LPL',order_name,order_id)
	clear order_no 
	xcall lodinp ('E')
	do begin
	  xcall i_input (order_id,'set1',order_no,,,,1)
	  if g_select
	    begin
	      case g_entnam of
		begincase
		'END':  begin
			  opcde = -1
			  exitloop
			end
		endcase
	    end
	 end until (.not.g_setsts) .and. (.not.g_select)
	xcall lodinp ('D')
	xcall lodwin ('D',,order_id)
	return

get_hist,			; get first pohist record
	clear pom_totamt, pom_ordqty, pom_ordwgt, pom_ordcubes
	comp = pom_comp
	order = order_no
	xcall db_read (pohist_chan,pohist,pokey,3,'M',1,,opcde)
	if (opcde) return

;	po number already assigned in po4000

	pom_ordtype = 'O'
	pom_vend = poh_vend
	pom_mail = poh_vend
	nam_comp = ut_cmcomp
	nam_id = pom_vend
	xcall na_get_name (namast)

	pom_name = nam_name
	pom_addr1 = nam_addr1
	pom_addr2 = nam_addr2
	pom_city = nam_city
	pom_state = nam_state
	pom_zip = nam_zip
	pom_phone = nam_phone
	pom_fax	 = nam_fax
	pom_orddate = ut_datfil
	pom_reqdate = ut_datfil
	pom_viacode = default_svia
	pom_buyrcode = default_buyr
	pom_termcode = default_term
	clear pom_confirmed
	pom_fobc = 'O'
	pom_colppd = 'P'
	pom_locncode = default_locn
	pom_status = 'O'
	clear pom_comment1
	clear pom_comment2
	clear pom_cust
	clear pom_custord
	pom_shipid = -1
	call get_ship_to
	clear pom_flag1, pom_flag2, pom_flag3, pom_flag4
	clear pom_totamt, pom_totrcvd, pom_totinvcd, pom_invcdate, pom_invcno
	clear pom_ordwgt, pom_ordcubes, pom_ordcubes, pom_ordqty, pom_entstatus
	
	call write_histline

;	now get the rest of the lines for the order
;
	repeat
	  begin
	    xcall db_next (pohist_chan,pohist,'F','M',,,opcde)
	    if (opcde .or. poh_order .ne. order_no) 
 	      begin
		xcall db_add (pohedr_chan,pohedr,pom_key,pohedr_log,opcde)
		return
	      end
	    call write_histline
	  end

	return

write_histline,
	pol_key = pom_key
	pol_lineno = poh_lineno
	pol_linetype = poh_linetype
	pol_item = poh_item
	pol_locncode = poh_locncode
	pol_descr = poh_descr
	pol_vendpn = poh_vendpn
	pol_buomcode = poh_buomcode
	call get_item		; pick up ucost, weights, cubes
	case costorigin of			; 8/28 vv
	begincase
	'I': pol_ucost = inl_lcost
	'P': pol_ucost = poh_ucost
	'Z': clear pol_ucost
	endcase
	pol_catgcode = ini_catgcode
	pol_ordqty = poh_ordqty
	clear pol_recuqty, pol_recdqty, pol_recrqty, pol_recpqty
	pol_discpct = poh_discpct
	pol_reqdate = ut_datfil
	clear pol_recdate
	pol_slst =  ini_slst
	pol_updcost = 'Y'
	pol_pfactor = poh_pfactor
	clear pol_rejcode
	clear pol_rem1prt, pol_remark1, pol_rem2prt, pol_remark2
	for ndx from 1 thru 4 clear pol_extdescr [ndx]
	clear pol_refrnce1, pol_ref1prt, pol_refrnce2, pol_ref2prt
	call update_inventory
	xcall db_add (poline_chan,poline,pol_key,poline_log,opcde)

	pom_totamt = pom_totamt + (pol_ordqty * pol_ucost)
	pom_ordwgt = pom_ordwgt + (pol_ordqty * pol_weight)
	pom_ordcubes = pom_ordcubes + (pol_ordqty * pol_cubes)
	pom_ordqty = pom_ordqty + pol_ordqty

	return

get_hedr,			; get header record
	save_order = pom_order
	comp = pom_comp
	order = order_no
	xcall db_read (pohedr_chan,pohedr,pokey,0,'M',1,,opcde)
	if (opcde) return

;	po number already assigned

	pom_order = save_order
	pom_orddate = ut_datfil
	pom_reqdate = ut_datfil
	clear pom_confirmed
	pom_status = 'O'
	clear pom_flag1, pom_flag2, pom_flag3, pom_flag4
	clear pom_totamt, pom_totrcvd, pom_totinvcd                   ; 3/30
        clear pom_totinvcd, pom_invcdate, pom_invcno, pom_ordqty, pom_ordwgt, pom_ordcubes    ; 3/30


	
;	now get the lines for the order
;
	xcall db_find (poline_chan,pokey,0,'M',,,opcde)

	repeat
	  begin
	    xcall db_next (poline_chan,poline,'F','M',,,opcde)
	    if (opcde .or. pol_key(1:8) .ne. pokey) 
 	      begin
		xcall db_add (pohedr_chan,pohedr,pom_key,pohedr_log,opcde)
		return
	      end
	    if (pol_status .ne. 'D')call write_poline	   ; 3/30
	  end

	return

write_poline,
	pol_order = save_order 
	call get_item		; pick up ucost, weights, cubes
	case costorigin of			; 8/28 vv
	begincase
	'I': pol_ucost = inl_lcost
	'P': pol_ucost = pol_ucost		; leave as is
	'Z': clear pol_ucost
	endcase
	clear pol_recuqty, pol_recdqty, pol_recrqty, pol_recpqty
	pol_reqdate = ut_datfil
	clear pol_recdate
	clear pol_status
	pol_slst =  ini_slst
	pol_updcost = 'Y'
	clear pol_rejcode
	call update_inventory
	xcall db_add (poline_chan,poline,pol_key,poline_log,opcde)

	pom_totamt = pom_totamt + (pol_ordqty * pol_ucost)
	pom_ordwgt = pom_ordwgt + (pol_ordqty * pol_weight)
	pom_ordcubes = pom_ordcubes + (pol_ordqty * pol_cubes)
	pom_ordqty = pom_ordqty + pol_ordqty
	return

get_ship_to,
	smc_type = 'H'
	smc_code = pom_shipid, 'XXX'
	xcall numrt (smc_code,'0')
	xcall sm_get_code (smcode)
	pom_shipname = ut_cmname
	pom_shipaddr1 = smch_addr1
	pom_shipaddr2 = smch_addr2
	pom_shipcity = smch_city
	pom_shipstate = smch_stat
	pom_shipzip = smch_zip
	return

update_inventory,
	if (pol_linetype.eq.'I') .or.		; Stock item
	&  (pol_linetype.eq.'J')		; No update
	  begin
	    pol_weight = ini_weight
	    pol_cubes = ini_cubes
;;	    pol_ucost = inl_lcost
	  
	    if (pol_linetype.eq.'I') .and.	; Item record
	    &  (ini_controlled.eq.'Y')	; Controlled item
	      begin
		xcall instkord (pol_item,pol_locncode,pol_ordqty,opcde)
	      end
	  end
	return

	;	Get inventory item and location records
get_item,
	ini_comp = pom_comp
	ini_item = pol_item
	xcall in_get_item (initem)
	inl_comp = pom_comp
	inl_item = pol_item
	inl_locncode = pol_locncode
	xcall in_get_locn (inlocn)
	return
.end
;=======================================================================;


