*~  Program...........: MATXTAB.PRG
*~  Author............: Valdis Matison
*~  Version...........: 2.5
*~} Project...........:
*~  Created...........: 11/01/93
*~  Copyright.........: (c) Matison Consulting Group Inc., 1993
*~                          187 Dunblaine Avenue
*~                          Toronto, Ontario
*~                          M5M 2S6
*~
*~                          416-256-4495
*~
*~) Description.......: Replacement for GENXTAB.prg that ships with FoxPro
*~] Dependencies......:
*~  Calling Samples...: do MATXTAB with "XTAB", 1, .t., .f., 1, 4, 5, .t., 2, 3, 0, 0, .t., .t., .t., .t.
*~                      do MATXTAB with "XTAB", 1, .t., .f., 1, 2, 6, .t., 3, 4, 5, 0, .t., .t., .t., .t., la_fldlist, 2, 0, 1
*~  Returns...........: If you initialize a variable named LN_RETURN in the calling program
*~                      this program will return a value in that variable
*~                      This functionality is incomplete
*~
*~                      0 = Success!
*~                      - 1 = Unique column count greater than 256
*~                      - 2 = Escape pressed, procedure cancelled
*~                      - 3 = No dbf in current area
*~                      - 4 = Less than three fields in input dbf
*~                      - 5 = Too many fields in results table
*~                      - 6 = Row field must be character
*~                      - 7 = Column field must be character
*~                      > 0 returns Foxpro's error code generated by error()
*~
*~  Major change list.:
*~  Future............: Create a front end, DOS/Windows/MAC
*~  Notes:............: The error handling is incomplete, the user should decide what errors to trap.
*~                      Naming convention: First letter "l" denotes local variable
*~                                         Second letter denotes type
*~
*~  Parameter List....: lc_outfile : Name of the output file
*~                      lu_struct  : 1 means cursor, 2 means table, 3 means array,
*~                                  .t. means cursor, .f. means table
*~                                   if blank, same format as input
*~                      ll_closein : .t. means close input file, else keep open
*~                      ll_therm   : Included for compatibility with GENXTAB, not used by MATXTAB
*~                      ln_rowfld  : Number of field used for rows - field number
*~                      ln_cellfld : Column used for individual totals in results table  field number
*~                      ln_colhead : Field used for column headings in XTAB report field number
*~                      ll_xtotal  :.t. means create cross totals, else don't bother
*~
*~                      Differences from Genxtab begin here
*~
*~                      ln_extfld1 : First extra field to go into output
*~                      ln_extfld2 : Second extra field to go into output
*~                      ln_extfld3 : Third extra field to go into output
*~                      ln_extfld4 : Fourth extra field to go into output
*~                      ll_cnt     : Display count for each unique row
*~                      ll_avg     : Display average
*~                      ll_min     : Display minimum
*~                      ll_max     : Display maximum
*~                      la_uniqcol : name of array passed that has the uniqe column names already in list
*~                      ln_rowcol  : Number of dimensions in the array that's sent down
*~                      ln_colsort : 0 means smallest to largest
*~                                   1 means largest to smallest
*~                      ln_rowsort : 0 means ascending
*~                                   1 means descending
*~

Parameters lc_outfile, lu_struct, ll_closein, ll_therm, ln_rowfld, ;
	ln_colhead, ln_cellfld, ll_xtotal, ln_extfld1, ln_extfld2, ;
	ln_extfld3, ln_extfld4, ll_cnt, ll_avg, ll_min, ll_max, ;
	la_uniqcol, ln_rowcol, ln_colsort, ln_rowsort

External Array la_uniqcol

Private lc_colsort, lc_dbfname, lc_colhead, lc_cellfld, ;
	ln_dimens, lc_error, lc_escasta, lc_escape, lc_group, ;
	ln_params, lc_program, lc_rowfld, lc_rowsort, lc_safesta, ;
	lc_talksta, lc_type, lc_where, ln_uniqcnt

lc_dbfname = Alias()			&& Source file taken from alias name
lc_error   = On( "ERROR" )
lc_escasta = Set( "ESCAPE" )
lc_escape  = On( "ESCAPE" )
ln_params  = Pcount()
lc_safesta = Set( "SAFETY" )
lc_talksta = Set( "TALK" )

lcOutputDir = ADDBS(SYS(2023))

*On Error Do lo_exit With Error()
Set Escape On
On Escape Do lo_exit With -2
Set Safety Off
Set Talk Off

If Empty( Alias() )		&& A file must be open in the selected area
	Do lo_exit With -3
Endif

If Fcount() < 3			&& At least three fields required
	Do lo_exit With -4
Endif

If ln_params < 1	&& Nothing sent down - Determine filename for output
	lc_outfile = 'XTABX.DBF'
Endif

If ln_params < 2	&& No format given for output

	If Isdigit( Left( Justfname( Dbf() ) ,1 ) )
		lu_struct = 1		&& Cursor
	Else
		lu_struct = 2		&& Table
	Endif

Else

	If Type("lu_struct") = "L"	&& Logical value
		If lu_struct				&& True means create a cursor
			lu_struct = 1
		Else						&& False means table
			lu_struct = 2
		Endif						&&
	Endif						&& Logical or numeric value

Endif				&& No format given for output


If ln_params < 3	&& Close input defaults to yes
	ll_closein = .T.
Endif

If ln_params < 5	&& Number of field for cross tab rows
	ln_rowfld = 1
Endif

If Type( Field( ln_rowfld ) ) <> "C"
	On Escape Do lo_exit With -6
Endif


If ln_params < 6	&& Number of field for columns
	ln_colhead = 2
Endif

If Type( Field( ln_colhead ) ) <> "C"
	On Escape Do lo_exit With -7
Endif

If ln_params < 7	&& Number of field for cross tab cells
	ln_cellfld = 3
Endif

If ln_params < 8
	ll_xtotal = .F.
Endif

If ln_params < 17
	Private la_uniqcol
	Dime la_uniqcol(1)
Endif

If ln_params > 17
	ln_dimens  = ln_rowcol
Else
	ln_dimens  = 1
Endif

If ln_params > 18
	Do Case
		Case ln_colsort = 1
			lc_colsort = "DESC"

		Otherwise
			lc_colsort = "ASC"
	Endcase

Else
	lc_colsort = "ASC"
Endif

If ln_params = 20
	Do Case
		Case ln_rowsort = 1
			lc_rowsort = "DESC"

		Otherwise
			lc_rowsort = "ASC"
	Endcase

Else
	lc_rowsort = "ASC"
Endif

lc_colhead = Field( ln_colhead )
lc_cellfld = lc_dbfname + "." + Field( ln_cellfld )
lc_group   = lc_dbfname + "." + Field( ln_rowfld )
lc_program = Program( 1 )
ln_return  = 0
lc_rowfld  = lc_group
lc_where   = "ZZ" + "." + ;
	lc_colhead + "=" + ;
	lc_dbfname + "." + ;
	lc_colhead


*do matshow

If ln_params < 17

	lc_type = Type( (lc_colhead) )
	Do Case
		Case lc_type = "C"

			Select &lc_colhead ;
				from ( lc_dbfname ) ;
				order By 1 &lc_colsort ;
				group By 1 ;
				into Array la_uniqcol

		Case lc_type = "D"

			Select "D"+Dtoc( &lc_colhead, 1 ) ;
				from (lc_dbfname) ;
				order By 1 &lc_colsort ;
				group By 1 ;
				into Array la_uniqcol

			lc_where = "ZZ" + "." + ;
				lc_colhead + "=" + ;
				"'D' +dtoc(" + ;
				lc_dbfname + "." + ;
				"&lc_colhead, 1 )"

	Endcase

	ln_uniqcnt = Alen( la_uniqcol )
	* If empty cursor
	IF RECCOUNT(lc_dbfname) = 0
		ln_uniqcnt = 0
	ENDIF 

Else

	ln_uniqcnt = Alen( la_uniqcol, ln_dimens )

Endif

If ln_uniqcnt >256
	Do lo_exit With -1
Endif

Dime la_colname[ ln_uniqcnt + 1, 4 ]
la_colname[1,1] = lc_colhead
la_colname[1,2] = "C"

If ln_params < 17 		&& no array sent down
	la_colname[ 1,3 ] = Len( &lc_colhead )
Else
	la_colname[ 1,3 ] = Len( la_uniqcol[ 1,1 ] )	&& What about width ?
Endif

la_colname[1,4] = 0


For ln_k = 2 To ln_uniqcnt + 1
	la_colname[ ln_k, 1 ] = la_uniqcol[ 1, ln_k-1 ]
	la_colname[ ln_k, 2 ] = "N"
	la_colname[ ln_k, 3 ] = 1
	la_colname[ ln_k, 4 ] = 0
Endfor

Create Cursor ZZ From Array la_colname

*--Now populate the table with 1's
For ln_k = 2 To ln_uniqcnt + 1
	Insert Into ZZ ( (lc_colhead), (Field(ln_k)) ) ;
		VALUES (la_colname[ ln_k, 1 ], 1 )
Endfor

*--
*-- Now create the cross tab
*--

lc_sqlxtab  = "SELECT " + lc_rowfld


If ln_params > 8
	If ln_extfld1 > 0
		lc_sqlxtab = lc_sqlxtab + ", " + lc_dbfname + "." + field( ln_extfld1, lc_dbfname )
		lc_group = lc_group + ", " + lc_dbfname + "." + field( ln_extfld1, lc_dbfname )
	Endif
Endif

If ln_params > 9
	If ln_extfld2 > 0
		lc_sqlxtab = lc_sqlxtab + ", " + lc_dbfname + "." + field( ln_extfld2, lc_dbfname )
		lc_group = lc_group + ", " + lc_dbfname + "." + field( ln_extfld2, lc_dbfname )
	Endif
Endif

If ln_params > 10
	If ln_extfld3 > 0
		lc_sqlxtab = lc_sqlxtab + ", " + lc_dbfname + "." + field( ln_extfld3, lc_dbfname )
		lc_group = lc_group + ", " + lc_dbfname + "." + field( ln_extfld3, lc_dbfname )		
	Endif
Endif

If ln_params > 11
	If ln_extfld4 > 0
		lc_sqlxtab = lc_sqlxtab + ", " + lc_dbfname + "." + field( ln_extfld4, lc_dbfname )
		lc_group = lc_group + ", " + lc_dbfname + "." + field( ln_extfld4, lc_dbfname )		
	Endif
Endif

For ln_k = 1 To ln_uniqcnt
	lc_sqlxtab = lc_sqlxtab + ", " + ;
		"SUM( " + lc_cellfld + ;
		"*ZZ." + ;
		la_uniqcol[ 1, ln_k ] + ") as " + ;
		la_uniqcol[ ln_dimens, ln_k ]
Endfor

*--
*-- Add totals column if required.
*-- Add count, average, min, max functions as well
*--

If ll_cnt
	lc_sqlxtab = lc_sqlxtab + ;
		", COUNT( " + lc_rowfld + " ) as 'XCNT' "
Endif

If ll_avg
	lc_sqlxtab = lc_sqlxtab + ;
		", AVG( " + lc_cellfld + " ) as 'XAVG' "
Endif

If ll_min
	lc_sqlxtab = lc_sqlxtab + ;
		", MIN( " + lc_cellfld + " ) as 'XMIN' "
Endif

If ll_max
	lc_sqlxtab = lc_sqlxtab + ;
		", MAX( " + lc_cellfld + " ) as 'XMAX' "
Endif

If ll_xtotal
	lc_sqlxtab = lc_sqlxtab + ;
		", SUM( " + lc_cellfld + " ) as 'XTOT' "
Endif

lc_sqlxtab = lc_sqlxtab + ;
	" FROM (lc_dbfname), ZZ " + ;
	" WHERE &lc_where " + ;
	" GROUP BY &lc_group " + ;
	" Order by &lc_group &lc_rowsort " + ;
	" INTO "

Do Case
	Case lu_struct = 2			&& output to table
		lc_sqlxtab = m.lc_sqlxtab + "TABLE " + m.lcOutputDir + lc_outfile

	Case lu_struct = 3			&& output to array
		lc_sqlxtab = lc_sqlxtab + "ARRAY _XTABX "

		Public _xtabx
		Dime _xtabx[ 1,1 ]

	Otherwise					&& output to cursor DEFAULT
		lc_sqlxtab = lc_sqlxtab + "CURSOR " + lc_outfile
Endcase

*-- Run the query

&lc_sqlxtab

Do lo_exit With ln_return
*-- eop MATXTAB


*~!*********************************************
*~!
*~!       Procedure: lo_exit
*~!
*~!*********************************************
Procedure lo_exit
	*~  Author............: Valdis Matison
	*~  Modified by.......:
	*~} Project...........:
	*~  Created...........: 11/01/93
	*~  Copyright.........: (c) Matison Consulting Group Inc., 1993
	*~) Description.......: Shutdown procedure for MATXTAB
	*~)
	*~] Dependencies......:
	*~  Calling Samples...:
	*~  Parameter List....: ln_ret : Error code
	*~  Returns...........:
	*~  Future ideas......:
	*~  Major change list.:

	Parameters ln_ret
	ln_return = ln_ret

	If lc_talksta = "ON"
		Set Talk On
	Endif

	If lc_safesta = "ON"
		Set Safety On
	Endif

	If lc_escasta = "OFF"
		Set Escape Off
	Endif

	*release windows lw_mat
	Clear Typeahead

	*-- Close input files only if successful
	If ln_ret = 0
		USE IN (SELECT('ZZ'))

		If ll_closein			&& close the input file
			USE IN (Select(lc_dbfname))
		Endif
		IF USED(JUSTSTEM(lc_outfile))
			Select (lc_outfile)
		ENDIF 	
	Endif

	* On Error &lc_error
	On Escape &lc_escape

	Return ln_ret

	*--
	*-- eop lo_exit
ENDPROC && lo_exit