;==File=================================================================;
; PO8000.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=============================================================;
;	po8000		Purge purchase orders.
;==Changes==============================================================;
;=======================================================================;
.subroutine po8000

.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:initem.rec"
.include "INS:inlocn.rec"

record	scr_rec1		; input set 1
	scr_purdat	,d8		; purge thru date
	scr_option	,a1		; one or all
	scr_order	,d6		; order number
	scr_vendid	,d8		; vendor id
	scr_vendname	,a30		; vendor name
	scr_status1	,a45		; order status line
	scr_status2	,a45		; order status line
	scr_confirm	,a3		; confirmation (YES/NO)

record
	abort		,d1
	hlditm		,a24		; saved item id
	hldsnl		,a20		; saved serial/lot number
	recs_read	,d6
	set_name	,a4		; current input set name
	wdone		,d1
	wind_name	,a*,	'po8000'
	wind_no		,d2		; input window id
	wind_signal	,a31
	wrk_qty		,d9.3		; work area for units
.start nopage,list

.proc
	;>>>>>	Main processing  <<<<<;
	call do_setup
	call open_files
	repeat
	  begin
	    call get_parameters
	    if (abort.eq.TRUE) exitloop
	    call process_data
	    if (scr_order.eq.0) exitloop
	  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)
	return

	;	Shut down environment
do_shutdown,
	xcall lodtoolbar ('RB',8)
	xcall e_exit
	return

	;	Open the needed data files
open_files,
	xcall open (pohedr_chan,'U:I',pohedr_name)
	xcall open (poline_chan,'U:I',poline_name)
	xcall open (initem_chan,'I:I',initem_name)
	xcall open (inlocn_chan,'U:I',inlocn_name)
	return

	;	Close the data files opened for the report
close_files,
	xcall close (pohedr_chan,DTE_CLOSE)
	xcall close (poline_chan,DTE_CLOSE)
	xcall close (pohist_chan,DTE_CLOSE)
	xcall close (initem_chan,DTE_CLOSE)
	xcall close (inlocn_chan,DTE_CLOSE)
	return

	;	Get the report selection parameters
get_parameters,
	set_name = 'set1'
	repeat
	  begin
	    xcall get_parameters (wind_no,wind_name,set_name,scr_rec1,abort,wind_signal)
	    if (abort.eq.TRUE) exitloop
	    if (wind_signal)
	     then call process_signal
	     else
	      begin
		call verify_input_parameters
		if (wdone.eq.TRUE) exitloop
	      end
	  end
	return

	;	Process any break signals
process_signal,
	case g_entnam of
	  begincase
	  '@OPTION':begin
		      set_name = 'set1'
		      if (scr_option.eq.'A') set_name = 'set3'
		    end
	  '@ORDER': begin
		      if (scr_order.eq.0) then
			begin
			  set_name = 'set3'
			  xcall status (DTEPO_PAO)
			end
		       else
			begin
			  pom_comp = ut_cmcomp
			  pom_order = scr_order
			  xcall db_find (pohedr_chan,pom_key,0,'M',,,opcde)
			  if (opcde) then
			    begin
			      xcall message (DTEPO_ONF)
			      xcall i_init (wind_no,,,'OPTION,ORDER,CONFIRM')
			      xcall i_init (wind_no,'set2')
			      set_name = 'set1'
			    end
			   else
			    begin
			      xcall db_next (pohedr_chan,pohedr,'F','M',,,opcde)
			      scr_vendid = pom_vend
			      scr_vendname = pom_name
			      case pom_status of
				begincase
				'O': xcall gettxt (DTEPO_ONC,scr_status1)
				'C': xcall gettxt (DTEPO_OIC,scr_status1)
				'D': xcall gettxt (DTEPO_OID,scr_status1)
				'R': xcall gettxt (DTEPO_PCN,scr_status1)
				'P': xcall gettxt (DTEPO_PRC,scr_status1)
				endcase
			      if (po_cmpurg.eq.'P') .and.
			      &  (pom_totinvcd.lt.pom_totamt)
				xcall gettxt (DTEPO_NIN,scr_status2)
			      xcall i_display (wind_no,'set2',scr_rec1)
			      if (pom_status.ne.'R') set_name = 'set3'
			    end
			end
		    end
	  endcase
	return

verify_input_parameters,
	wdone = TRUE
	if (scr_confirm.ne.'YES')
	  begin
	    xcall i_init (wind_no,,,'OPTION,ORDER,CONFIRM')
	    xcall i_init (wind_no,'set2')
	    set_name = 'set1'
	    wdone = FALSE
	  end
	return

	;	Process the data
process_data,
	abort = FALSE
	xcall status (DTEM_PRC)
	if (scr_order) then
	  begin			; purge a single order
	    call delete_order
	    xcall status
	    xcall i_init (wind_no)
	    set_name = 'set1'
	  end
	 else
	  begin			; purge all orders
	    clear recs_read
	    xcall statusbar (0,pohedr_chan)
	    xcall db_find (pohedr_chan,ut_cmcomp,0,'M',,,opcde)
	    repeat
	      begin
		xcall db_next (pohedr_chan,pohedr,'F','M',,,opcde)
		if (opcde) .or.
		& (pom_comp.ne.ut_cmcomp) exitloop
		incr recs_read
		if (.not.recs_read(5:2)) xcall statusbar (recs_read)
		if (pom_reqdate.le.scr_purdat)
		  begin
		    case po_cmpurg of
		      begincase
		      'C': if (pom_status.eq.'C') call delete_order
		      'P': if (pom_totinvcd.ge.pom_totamt) call delete_order
		      endcase
		  end
	      end
	  end
	return

	;	delete an order
delete_order,
	xcall db_find (poline_chan,pom_key,0,'M',,,opcde)
	if (opcde)
	  begin
	    call delete_header
	    return
	  end
	repeat
	  begin
	    xcall db_next (poline_chan,poline,'F','M',,,opcde)
	    if (opcde) .or.
	    &  (pol_key.ne.pom_key)
	      begin
		call delete_header
		return
	      end
	    case pol_linetype of
	      begincase
	      'I': begin
		   call update_item
		   call delete_line
		   end
	      'N': call delete_line
	      'R': call delete_line
	    endcase		
	  end

	;	update inventory item file
update_item,
	if (pol_ordqty.ne.pol_recpqty)
	  begin
	    ini_comp = pom_comp
	    ini_item = pol_item
	    xcall in_get_item (initem)
	    if (.not.opcde) .and.
	    &  (ini_controlled.eq.'Y')
	      begin		; deallocate any remaining stock quantity
		wrk_qty = ((pol_ordqty - pol_recpqty) * ini_uomfactor)
		xcall instkdor (pol_item,pol_locncode,wrk_qty,opcde)
	      end
	  end
	return

	;	delete the line item
delete_line,
	xcall db_delete (poline_chan,poline,pol_key,poline_log,opcde)
	return

	;	delete the header record
delete_header,
	xcall db_delete (pohedr_chan,pohedr,pom_key,pohedr_log,opcde)
	return
.end

