Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : RRSTUFF.ZIP
Filename : RRFUNS.PRG

 
Output of file : RRFUNS.PRG contained in archive : RRSTUFF.ZIP
* Program generated by R&R Relational Report Writer Code Generator, Version 1.1

* Program Name: RRFUNS.PRG
* Program Time: 5-Jun-90 4:30 PM
* Program Language: Clipper



****************************************************
*!*********************************************************************
*!
*! Procedure: RR_CWRAP
*!
*!*********************************************************************
procedure rr_cwrap
parameters lc_string, ln_width, ln_windex, ln_format
* next wrapped character field
****************************************************
private lc_f, lc_s, ln_l, ln_k, ll_full
do while .T.
if mwrap[m->ln_windex] > len(m->lc_string)
mwrap[m->ln_windex+1] = ''
mwrap[m->ln_windex+2] = .F.
mwrap[m->ln_windex+3] = ''
return
endif
if len(mwrap[m->ln_windex+3]) = 0 .OR. substr(m->lc_string,mwrap[;
m->ln_windex],1) <> ' '
exit
endif
mwrap[m->ln_windex] = mwrap[m->ln_windex] + 1
enddo
lc_f = substr(m->lc_string,mwrap[m->ln_windex],m->ln_width+1)
ln_l = len(m->lc_f)
ln_k = at(';',m->lc_f)
ll_full = m->ln_k = 0 .AND. m->ln_l > m->ln_width
mwrap[m->ln_windex+3] = iif(m->ll_full,';','')
if m->ln_k = 0
if m->ln_l <= m->ln_width
lc_f = m->lc_f + ' '
ln_l = m->ln_l + 1
endif
ln_k = m->ln_l - 1
do while .T.
if substr(m->lc_f,m->ln_k+1,1) = ' '
mwrap[m->ln_windex] = mwrap[m->ln_windex] + m->ln_k + 1
exit
endif
if substr(m->lc_f,m->ln_k+1,1) = '-' .AND. substr(m->lc_f,m->ln_k,1) ;
<> ' ' .AND. substr(m->lc_f,m->ln_k,1) <> '('
mwrap[m->ln_windex] = mwrap[m->ln_windex] + m->ln_k + 1
ln_k = m->ln_k + 1
exit
endif
ln_k = m->ln_k - 1
if m->ln_k = 0
ln_k = m->ln_l - 1
mwrap[m->ln_windex] = mwrap[m->ln_windex] + m->ln_k
exit
endif
enddo
else
mwrap[m->ln_windex] = mwrap[m->ln_windex] + m->ln_k
ln_k = m->ln_k - 1
endif
lc_f = rtrim(left(m->lc_f,m->ln_k))
ln_k = len(m->lc_f)
do case
case m->ln_format = 0
case m->ln_format = 1
lc_s = ''
do while m->ll_full .AND. m->ln_k < m->ln_width
ln_l = at(' ',m->lc_f)
if m->ln_l = 0
if len(m->lc_s) = 0
exit
endif
lc_f = m->lc_s + m->lc_f
lc_s = ''
loop
endif
lc_s = m->lc_s + left(m->lc_f,m->ln_l)
lc_f = substr(m->lc_f,m->ln_l+1)
do while at(' ',m->lc_f)=1
lc_s = m->lc_s + ' '
lc_f = substr(m->lc_f,2)
enddo
lc_s = m->lc_s + ' '
ln_k = m->ln_k + 1
enddo
lc_f = m->lc_s + m->lc_f
case m->ln_format = 2
lc_f = space(m->ln_width - m->ln_k) + m->lc_f
endcase
mwrap[m->ln_windex + 1] = m->lc_f
mwrap[m->ln_windex+2] = .T.
return

**********************************************
*!*********************************************************************
*!
*! Procedure: RR_MFIELD
*!
*! Called by: RR_MGET (procedure in RRFUNS.PRG)
*!

*! Calls: &GC_MEMX
*!
*!*********************************************************************
procedure rr_mfield
parameters lc_name, ln_windex, ln_k
* replace data names with values in memo field
**********************************************
private lc_field, lc_edit, ln_n, ln_j
ln_n = at('\',substr(mwrap[m->ln_windex+1],m->ln_k+1))
do case
case m->ln_n > 0
lc_field = substr(mwrap[m->ln_windex+1],m->ln_k+1,m->ln_n-1)
ln_j = 0
otherwise
ln_j = at('\',substr(&lc_name,mwrap[m->ln_windex]))
if m->ln_j = 0 .or. m->ln_j >20
return
endif
lc_field = substr(mwrap[m->ln_windex+1],m->ln_k+1) + substr(&lc_name,;
mwrap[m->ln_windex], m->ln_j-1)
endcase
lc_edit = ''
do &gc_memx with lc_edit, m->lc_field
if len(m->lc_edit) = 0
return
endif
lc_edit = ltrim(rtrim(m->lc_edit))
if m->ln_j = 0
mwrap[m->ln_windex] = mwrap[m->ln_windex] - (len(mwrap[m->ln_windex+1]) - ;
(m->ln_k + m->ln_n))
else
mwrap[m->ln_windex] = mwrap[m->ln_windex] + m->ln_j
endif
mwrap[m->ln_windex+3] = left(mwrap[m->ln_windex+1],m->ln_k-1) + m->lc_edit
mwrap[m->ln_windex+1] = ''
return

***********************************
*!*********************************************************************
*!
*! Procedure: RR_MGET
*!
*! Called by: RR_MWRAP (procedure in RRFUNS.PRG)
*!
*! Calls: RR_MFIELD (procedure in RRFUNS.PRG)
*!
*!*********************************************************************
procedure rr_mget
parameters lc_name, ln_windex, ln_n
* get n bytes from memo field
***********************************
private ln_k, ln_m
if mwrap[m->ln_windex] > len(&lc_name) .and. len(mwrap[m->ln_windex+3]) = 0
mwrap[m->ln_windex+1] = ''
return
endif
do while .t.
ln_k = len(mwrap[m->ln_windex+3])
do case
case m->ln_k = 0
mwrap[m->ln_windex+1] = substr(&lc_name,mwrap[m->ln_windex],m->ln_n)
mwrap[m->ln_windex] = mwrap[m->ln_windex] + len(mwrap[;
m->ln_windex+1])
ln_m = at('\',mwrap[m->ln_windex+1])
if m->ln_m > 0
do rr_mfield with m->lc_name, m->ln_windex, m->ln_m
if len(mwrap[m->ln_windex+1]) = 0
loop
endif
endif
return
case m->ln_k >= m->ln_n
mwrap[m->ln_windex+1] = left(mwrap[m->ln_windex+3],m->ln_n)
mwrap[m->ln_windex+3] = substr(mwrap[m->ln_windex+3],m->ln_n+1)
return
otherwise
mwrap[m->ln_windex+1] = mwrap[m->ln_windex+3]
mwrap[m->ln_windex+3] = substr(&lc_name,mwrap[m->ln_windex],;
m->ln_n - m->ln_k)
mwrap[m->ln_windex] = mwrap[m->ln_windex] + len(mwrap[;
m->ln_windex+3])
mwrap[m->ln_windex+1] = mwrap[m->ln_windex+1] + mwrap[;
m->ln_windex+3]
mwrap[m->ln_windex+3] = ''
ln_m = at('\',substr(mwrap[m->ln_windex+1],m->ln_k+1))
if m->ln_m > 0
do rr_mfield with m->lc_name, m->ln_windex, m->ln_k + m->ln_m
if len(mwrap[m->ln_windex+1]) = 0
loop
endif
endif
return
endcase
enddo

************************************************
*!*********************************************************************
*!
*! Procedure: RR_MWRAP
*!
*! Called by: BODY_ASG (procedure in ASSIGN.PRG)
*!
*! Calls: RR_GO_REC() (function in RRFUNS.PRG)
*! : RR_MGET (procedure in RRFUNS.PRG)
*! : RR_MFILT() (function in RRFUNS.PRG)
*!
*!*********************************************************************
PROCEDURE rr_mwrap
PARAMETERS lc_id, ln_width, ln_windex, ln_format
* next wrapped memo field
************************************************
PRIVATE ln_area, ln_rno, lc_name, lc_f, lc_s, ln_l, ln_k, ll_full
ln_area = VAL(m->lc_id)
ln_rno = VAL(SUBSTR(m->lc_id,AT('/',m->lc_id) + 1))
lc_name = SUBSTR(m->lc_id,AT(':',m->lc_id) + 1)
ln_rno = rr_go_rec(m->ln_area,m->ln_rno)
DO rr_mget WITH m->lc_name, m->ln_windex, m->ln_width+1
lc_f = mwrap[m->ln_windex+1]
ln_l = LEN(m->lc_f)
IF m->ln_l = 0
mwrap[m->ln_windex+1] = ''
mwrap[m->ln_windex+2] = .F.
ln_rno = rr_go_rec(m->ln_area,m->ln_rno)
RETURN
ENDIF
DO WHILE .T.
ln_l = LEN(m->lc_f)
ln_k = AT(CHR(10),m->lc_f)
DO CASE
CASE m->ln_k > 1 .AND. SUBSTR(m->lc_f,m->ln_k-1,1) = CHR(141)
IF m->ln_k = 2 .OR. (m->ln_k > 2 .AND. SUBSTR(m->lc_f,m->ln_k-2,1);
= ' ')
DO rr_mget WITH m->lc_name, m->ln_windex, 2
lc_f = LEFT(m->lc_f,m->ln_k-2) + SUBSTR(m->lc_f,m->ln_k+1) + ;
mwrap[m->ln_windex+1]
ELSE
DO rr_mget WITH m->lc_name, m->ln_windex, 1
lc_f = LEFT(m->lc_f,m->ln_k-2) + ' ' + SUBSTR(m->lc_f,m->ln_k+;
1) + mwrap[m->ln_windex+1]
ENDIF
LOOP
CASE m->ln_k > 0
mwrap[m->ln_windex+3] = SUBSTR(m->lc_f,m->ln_k+1) + mwrap[;
m->ln_windex+3]
lc_f = rr_mfilt(RTRIM(LEFT(m->lc_f,m->ln_k-1)))
ll_full = .F.
IF LEN(m->lc_f) = m->ln_width
mwrap[m->ln_windex+3] = CHR(10) + mwrap[m->ln_windex+3]
ENDIF
EXIT
CASE m->ln_l <= m->ln_width
lc_f = rr_mfilt(RTRIM(m->lc_f))
ll_full = .F.
EXIT
OTHERWISE
lc_f = rr_mfilt(m->lc_f)
ln_k = LEN(m->lc_f)
IF m->ln_k < m->ln_l
DO rr_mget WITH m->lc_name, m->ln_windex, m->ln_l - m->ln_k
lc_f = m->lc_f + mwrap[m->ln_windex+1]
LOOP
ENDIF
ll_full = .T.
ln_k = m->ln_width
IF SUBSTR(m->lc_f,m->ln_k+1,1) = ' '
lc_f = RTRIM(m->lc_f)
EXIT
ENDIF
DO WHILE .T.
IF SUBSTR(m->lc_f,m->ln_k,1) = ' '
mwrap[m->ln_windex+3] = SUBSTR(m->lc_f,m->ln_k+1) + mwrap[;
m->ln_windex+3]
lc_f = RTRIM(LEFT(m->lc_f,m->ln_k-1))
EXIT
ENDIF
IF SUBSTR(m->lc_f,m->ln_k,1) = '-' .AND. m->ln_k > 1 .AND. ;
SUBSTR(m->lc_f,m->ln_k-1,1) <> ' ' .AND. SUBSTR(m->lc_f,;
m->ln_k-1,1) <> '('
mwrap[m->ln_windex+3] = SUBSTR(m->lc_f,m->ln_k+1) + mwrap[;
m->ln_windex+3]
lc_f = RTRIM(LEFT(m->lc_f,m->ln_k))
EXIT
ENDIF
ln_k = m->ln_k - 1
IF m->ln_k = 0
mwrap[m->ln_windex+3] = RIGHT(m->lc_f,1) + mwrap[;
m->ln_windex+3]
lc_f = LEFT(m->lc_f,m->ln_width)
EXIT
ENDIF
ENDDO
lc_f = RTRIM(m->lc_f)
EXIT
ENDCASE
ENDDO
ln_k = LEN(m->lc_f)
DO CASE
CASE m->ln_format = 0
CASE m->ln_format = 1
lc_s = ''
DO WHILE m->ll_full .AND. m->ln_k < m->ln_width
ln_l = AT(' ',m->lc_f)
IF m->ln_l = 0
IF LEN(m->lc_s) = 0
EXIT
ENDIF
lc_f = m->lc_s + m->lc_f
lc_s = ''
LOOP
ENDIF
lc_s = m->lc_s + LEFT(m->lc_f,m->ln_l)
lc_f = SUBSTR(m->lc_f,m->ln_l+1)
DO WHILE AT(' ',m->lc_f)=1
lc_s = m->lc_s + ' '
lc_f = SUBSTR(m->lc_f,2)
ENDDO
lc_s = m->lc_s + ' '
ln_k = m->ln_k + 1
ENDDO
lc_f = m->lc_s + m->lc_f
CASE m->ln_format = 2
lc_f = SPACE(m->ln_width - m->ln_k) + m->lc_f
CASE m->ln_format = 3
lc_f = SPACE((m->ln_width - m->ln_k)/2) + m->lc_f
ENDCASE
mwrap[m->ln_windex + 1] = m->lc_f
mwrap[m->ln_windex+2] = .T.
ln_rno = rr_go_rec(m->ln_area,m->ln_rno)
RETURN

********************
*!*********************************************************************
*!
*! Procedure: RR_OUTF
*!
*!*********************************************************************
procedure rr_outf
parameters lc_string
* output string
********************
private ln_l
ln_l = len(m->lc_string)
if m->ln_l = 0
return
endif
if m->gl_blank
if len(trim(m->lc_string)) = 0
gn_outcol = m->gn_outcol + m->ln_l
return
else
if m->gn_pno >= m->gn_startpg
if m->gc_dest <> 'D'
?? space(m->gn_indent)
endif
?? space(m->gn_outcol)
endif
gl_blank = .f.
endif
endif
if m->gn_pno >= m->gn_startpg
?? m->lc_string
endif
gn_outcol = m->gn_outcol + m->ln_l
return

******************************************
*!*********************************************************************
*!
*! Procedure: RR_OUTFS
*!
*! Calls: RR_STYLE (procedure in RRFUNS.PRG)
*!
*!*********************************************************************
procedure rr_outfs
parameters lc_string, lc_style
* output string with style/font attributes
******************************************
private ln_l, ln_n
ln_l = len(m->lc_string)
if m->ln_l = 0
return
endif
if m->gl_blank
if len(trim(m->lc_string)) = 0
gn_outcol = m->gn_outcol + m->ln_l
return
else
if m->gn_pno >= m->gn_startpg
if m->gc_dest <> 'D'
?? space(m->gn_indent)
endif
?? space(m->gn_outcol)
endif
gl_blank = .f.
endif
endif
if m->gn_pno >= m->gn_startpg
ln_n = m->ln_l - len(ltrim(m->lc_string))
?? space(m->ln_n)
do rr_style with m->lc_style
?? ltrim(m->lc_string)
do rr_style with 'bui00'
endif
gn_outcol = m->gn_outcol + m->ln_l
return

******************************************
*!*********************************************************************
*!
*! Procedure: RR_OUTFSZ
*!
*! Calls: RR_STYLE (procedure in RRFUNS.PRG)
*!
*!*********************************************************************
procedure rr_outfsz
parameters lc_string, lc_style
* output string with style/font attributes
******************************************
private ln_l, ln_n
ln_l = len(m->lc_string)
if m->ln_l = 0
return
endif
ln_n = m->ln_l - len(ltrim(m->lc_string))
?? space(m->ln_n)
do rr_style with m->lc_style
?? ltrim(m->lc_string)
do rr_style with 'bui00'
return

******************************************
*!*********************************************************************
*!
*! Procedure: RR_OUTL
*!
*! Calls: RR_WAIT (procedure in RRFUNS.PRG)
*!
*!*********************************************************************
procedure rr_outl
parameters ll_cmpress
* output line with possible blank compress
******************************************
&& IF m->gc_dest = 'P'
&& insert check for printer ready here
&& ENDIF
if .not. (m->gl_blank .and. m->gl_cmpress .and. m->ll_cmpress)
if m->gn_pno >= m->gn_startpg
?
if m->gc_dest = 'D'
do rr_wait
endif
endif
gn_lno = m->gn_lno + 1
endif
gl_blank = .t.
gn_outcol = 0
return

**************************************************
*!*********************************************************************
*!
*! Procedure: RR_STYLE
*!
*! Called by: RR_OUTFS (procedure in RRFUNS.PRG)
*! : RR_OUTFSZ (procedure in RRFUNS.PRG)
*!
*!*********************************************************************
procedure rr_style
parameters lc_style
* change print style including attributes and font
**************************************************
private lc_color, lc_font, lc_oldfon, lc_newfon
if m->gc_dest = 'D'
lc_color = 'w'
if substr(m->lc_style, 2, 1) = 'U'
lc_color = 'U'
endif
if left(m->lc_style, 1) = 'B'
lc_color = m->lc_color + '+'
endif
set color to &lc_color.
else
if m->gc_printer <> 'A'
?? iif(left(m->lc_style, 1) # left(m->gc_style, 1), iif(left(;
m->lc_style, 1) = 'B', m->gc_psbdon, m->gc_psbdoff),'')
?? iif(substr(m->lc_style, 2, 1) # substr(m->gc_style, 2, 1), iif(;
substr(m->lc_style, 2, 1) = 'U',m->gc_psulon,m->gc_psuloff),'')
?? iif(substr(m->lc_style, 3, 1) # substr(m->gc_style, 3, 1), iif(;
substr(m->lc_style, 3, 1) = 'I',m->gc_psiton,m->gc_psitoff),'')
lc_oldfon = right(m->gc_style, 2)
lc_newfon = right(m->lc_style, 2)
?? iif(m->lc_oldfon # m->lc_newfon, iif(m->lc_newfon = '00', ;
m->gc_psf&lc_oldfon.of, m->gc_psf&lc_newfon.on), '')
gc_style = m->lc_style
endif
endif
return

***************************
*!*********************************************************************
*!
*! Procedure: RR_WAIT
*!
*! Called by: RR_OUTL (procedure in RRFUNS.PRG)
*!
*!*********************************************************************
procedure rr_wait
* wait after each screenful
***************************
gn_slno = m->gn_slno + 1
if m->gn_slno >= 24
wait
@ row(),0
@ row()-1, 0
gn_slno = 1
endif
return

******************
*!*********************************************************************
*!
*! Function: MLABEL()
*!
*! Called by: GFR_ASG (procedure in ASSIGN.PRG)
*! : GFR_FE (procedure in FE.PRG)
*! : GFR_LEA (procedure in LEASE.PRG)
*!
*!*********************************************************************
function mlabel
parameters ld_date
******************
return iif(month(m->ld_date)=1,"JAN",iif(month(m->ld_date)=2,"FEB",iif(month(;
m->ld_date)=3,"MAR",iif(month(m->ld_date)=4,"APR",iif(month(m->ld_date)=5,;
"MAY",iif(month(m->ld_date)=6,"JUN",iif(month(m->ld_date)=7,"JUL",iif(;
month(m->ld_date)=8,"AUG",iif(month(m->ld_date)=9,"SEP",iif(month(;
m->ld_date)=10,"OCT",iif(month(m->ld_date)=11,"NOV",iif(month(m->ld_date)=;
12,"DEC",""))))))))))))

******************
*!*********************************************************************
*!
*! Function: GLBK_LINE()
*!
*!*********************************************************************
FUNCTION glbk_line
******************
RETURN SPACE(70)

******************************
*!*********************************************************************
*!
*! Function: PICOUT()
*!
*!*********************************************************************
function picout
parameters lc_instr, lc_outstr
******************************
return transform(m->lc_instr,m->lc_outstr)

***************************
*!*********************************************************************
*!
*! Function: ADDDAYS()
*!
*!*********************************************************************
function adddays
parameters ld_date, ln_days
* add days to date
***************************
return m->ld_date + m->ln_days

***************************
*!*********************************************************************
*!
*! Function: ADDMONS()
*!
*! Called by: SUBMONS() (function in RRFUNS.PRG)
*!
*! Calls: RR_CTOD() (function in RRFUNS.PRG)
*! : LN_MONS%IIF() (function in ?)
*! : RR_DAYMAX() (function in RRFUNS.PRG)
*!
*!*********************************************************************
function addmons
parameters ld_date, ln_mons
* add months to date
***************************
private ln_newmon, ln_newday, ln_newyr, ld_ret
ld_ret = rr_ctod('','','')
if .not.(m->ld_date = rr_ctod('','',''))
ln_newmon = month(m->ld_date)+m->ln_mons%iif(m->ln_mons>0,12,-12)
ln_newyr = year(m->ld_date)+int(m->ln_mons/12)+iif(m->ln_newmon<1,-1,iif(;
m->ln_newmon>12,1,0))
ln_newmon = m->ln_newmon+iif(m->ln_newmon<1,12,iif(m->ln_newmon>12,-12,0))
ln_newday = min(day(m->ld_date),rr_daymax(m->ln_newmon,m->ln_newyr))
ld_ret = rr_ctod(str(m->ln_newmon,2),str(m->ln_newday,2),str(m->ln_newyr,4))
endif
return m->ld_ret

**************************
*!*********************************************************************
*!
*! Function: ADDWKS()
*!
*! Called by: SUBWKS() (function in RRFUNS.PRG)
*!
*!*********************************************************************
FUNCTION addwks
PARAMETERS ld_date, ln_wks
* add weeks to date
**************************
RETURN m->ld_date + 7*m->ln_wks

**************************
*!*********************************************************************
*!
*! Function: ADDYRS()
*!
*! Called by: SUBYRS() (function in RRFUNS.PRG)
*!
*! Calls: RR_CTOD() (function in RRFUNS.PRG)
*! : RR_DAYMAX() (function in RRFUNS.PRG)
*!
*!*********************************************************************
FUNCTION addyrs
PARAMETERS ld_date, ln_yrs
* add years to date
**************************
PRIVATE ld_ret
ld_ret = IIF(m->ld_date = rr_ctod('','',''),rr_ctod('','',''),rr_ctod(STR(;
MONTH(m->ld_date),2),STR(MIN(DAY(m->ld_date),rr_daymax(MONTH(m->ld_date),;
year(m->ld_date)+m->ln_yrs)),2),STR(year(m->ld_date)+m->ln_yrs,4)))
RETURN m->ld_ret

***********************************************
*!*********************************************************************
*!
*! Function: CAPFIRST()
*!
*!*********************************************************************
function capfirst
parameters lc_str, lc_bstr
* capitalize only the first letter in each word
***********************************************
private lc_ret, ln_ptr, ll_inword, lc_chr
lc_ret = ''
lc_str = trim(m->lc_str)
if len(m->lc_str) > 0
ln_ptr = 1
ll_inword=.f.
do while m->ln_ptr <= len(m->lc_str)
lc_chr = substr(lc_str,m->ln_ptr,1)
if m->ll_inword
if m->lc_chr$lc_bstr
ll_inword = .f.
endif
lc_ret = m->lc_ret + lower(m->lc_chr)
else
if .not.(m->lc_chr$lc_bstr)
ll_inword = .t.
endif
lc_ret = m->lc_ret + upper(m->lc_chr)
endif
ln_ptr = m->ln_ptr + 1
enddo
endif
return m->lc_ret

**************************
*!*********************************************************************
*!
*! Function: CEILING()
*!
*!*********************************************************************
function ceiling
parameters ln_num
* emulates dBASE CEILING()
**************************
private ln_ret
ln_ret = iif(int(m->ln_num)=m->ln_num,m->ln_num,int(m->ln_num+1))
return m->ln_ret

*********************************************
*!*********************************************************************
*!
*! Function: DATELIKE()
*!
*!*********************************************************************
function datelike
parameters lc_month, lc_day, lc_year, ld_date
* compare date to wildcard
*********************************************
return (m->lc_month='*'.or.(val(m->lc_month)=month(m->ld_date)).or.;
(m->lc_month='@'.and.month(date())=month(m->ld_date))).and.;
(m->lc_day='*'.or.(val(m->lc_day)=day(m->ld_date)).or.;
(m->lc_day='@'.and.day(date())=day(m->ld_date))).and.;
(m->lc_year='*'.or.(val(m->lc_year)=year(m->ld_date)).or.;
(m->lc_year='@'.and.year(date())=year(m->ld_date)))

*****************************
*!*********************************************************************
*!
*! Function: DAYSBTWN()
*!
*!*********************************************************************
function daysbtwn
parameters ld_date1, ld_date2
* days between dates
*****************************
return m->ld_date1 - m->ld_date2

******************************
*!*********************************************************************
*!
*! Function: DQTR()
*!
*! Calls: RR_CTOD() (function in RRFUNS.PRG)
*! : QTR() (function in RRFUNS.PRG)
*!
*!*********************************************************************
function dqtr
parameters ld_date
* first day of quarter of date
******************************
private ld_ret
ld_ret = rr_ctod(str(qtr(m->ld_date)*3-2,2), '01', str(year(m->ld_date),4))
return m->ld_ret

********************************************
*!*********************************************************************
*!
*! Function: EDIT_CC()
*!
*! Called by: BODY_ASG (procedure in ASSIGN.PRG)
*! : MEMX_ASG() (function in ASSIGN.PRG)
*! : BODY_FE (procedure in FE.PRG)
*! : BODY_LEA (procedure in LEASE.PRG)
*!
*!*********************************************************************
function edit_cc
parameters ln_num, ln_ints, ln_decs, lc_type
* edit number to Currency or Comma format
********************************************
private lc_ret, ln_ptr, ln_decpos
ln_num = round(m->ln_num,m->ln_decs)
do case
case m->ln_num = 0 .and. m->ln_ints = 0
lc_ret = ' ' + m->gc_point + replicate('0', m->ln_decs) + ' '
otherwise
lc_ret = transform(m->ln_num, ('@( ' + iif(m->ln_ints > 0, right('99' ;
+ replicate(',999', 6), m->ln_ints + ceiling((m->ln_ints - 3)/ 3));
, '') + iif(m->ln_decs > 0, '.' + replicate('9',m->ln_decs), '')))
do case
case m->gc_point # '.' .and. m->gc_tsep # ','
ln_decpos = at('.',m->lc_ret)
if m->ln_decpos > 0
lc_ret = stuff(m->lc_ret, m->ln_decpos, 1, '')
endif
lc_ret = strtran(m->lc_ret, ',', m->gc_tsep)
if m->ln_decpos > 0
lc_ret = stuff(m->lc_ret, m->ln_decpos, 0, m->gc_point)
endif
case m->gc_point # '.'
ln_decpos = at('.',m->lc_ret)
if m->ln_decpos > 0
lc_ret = stuff(m->lc_ret, m->ln_decpos, 1, m->gc_point)
endif
case m->gc_tsep # ','
lc_ret = strtran(m->lc_ret, ',', m->gc_tsep)
endcase
endcase
if m->ln_num<1 .and. m->ln_num>-1 .and. m->ln_ints>0 .and. m->ln_decs>0
if substr(m->lc_ret,at(m->gc_point,m->lc_ret)-1,1) <> '0'
lc_ret = stuff(m->lc_ret, at(m->gc_point, m->lc_ret), 0, '0')
if ' ' $ m->lc_ret
lc_ret = stuff(m->lc_ret, at(' ', m->lc_ret), 1, '')
endif
endif
endif
if left(m->lc_ret, 1) = '('
lc_ret = stuff(m->lc_ret, 1, 1, ' ')
ln_ptr = 1
do while substr(m->lc_ret, m->ln_ptr, 1) = ' '
ln_ptr = m->ln_ptr + 1
enddo
ln_num = val(m->lc_ret)
lc_ret = stuff(m->lc_ret, m->ln_ptr, 0, '(')
else
ln_num = val(m->lc_ret)
lc_ret = ' ' + m->lc_ret + ' '
endif
if m->ln_num = 0 .and. (left(m->lc_type,1) = ' ')
return replicate(' ', len(m->lc_ret))
endif
lc_ret = rtrim(m->lc_ret)
if right(m->lc_type,1) = 'C'
if m->gc_cpos = 'R'
ln_ptr = len(m->lc_ret) + 1
if right(m->lc_ret,1) = ')'
ln_ptr = m->ln_ptr - 1
endif
else
ln_ptr = 1
do while substr(m->lc_ret, m->ln_ptr, 1) $ ' ('
ln_ptr = m->ln_ptr + 1
enddo
endif
lc_ret = stuff(m->lc_ret, m->ln_ptr, 0, m->gc_csign)
endif
return m->lc_ret

*********************************
*!*********************************************************************
*!
*! Function: EDIT_DA()
*!
*! Called by: BODY_ASG (procedure in ASSIGN.PRG)
*! : MEMX_ASG() (function in ASSIGN.PRG)
*! : BODY_FE (procedure in FE.PRG)
*! : BODY_LEA (procedure in LEASE.PRG)
*!
*!*********************************************************************
function edit_da
parameters ld_date, ln_format
* edit date to abbreviated format
*********************************
if m->ld_date = ctod(' / / ')
return ''
endif
private lc_ret, lc_month, lc_year, lc_day
lc_year = right('000' + ltrim(str(year(m->ld_date),4)),4)
if m->ln_format > 5
lc_year = right(m->lc_year,2)
ln_format = m->ln_format - 5
endif
lc_day = right('0' + ltrim(str(day(m->ld_date),2)),2)
do case
case m->ln_format < 4
lc_month = left(cmonth(m->ld_date),3)
do case
case m->ln_format = 1
lc_ret = m->lc_day + '-' + m->lc_month + '-' + m->lc_year
case m->ln_format = 2
lc_ret = m->lc_day + '-' + m->lc_month
case m->ln_format = 3
lc_ret = m->lc_month + '-' + m->lc_year
endcase
otherwise
lc_month = right('0' + ltrim(str(month(m->ld_date),2)),2)
do case
case m->gc_idate = 'A'
lc_ret = m->lc_month + '/' + m->lc_day + iif(m->ln_format=4,;
'/' + m->lc_year,'')
case m->gc_idate = 'B'
lc_ret = m->lc_day + '/' + m->lc_month + iif(m->ln_format=4,;
'/' + m->lc_year,'')
case m->gc_idate = 'C'
lc_ret = m->lc_day + '.' + m->lc_month + iif(m->ln_format=4,;
'.' + m->lc_year,'')
case m->gc_idate = 'D'
lc_ret = + iif(m->ln_format=4,m->lc_year+'-','') + ;
m->lc_month + '-' + m->lc_day
endcase
endcase
return m->lc_ret

*****************************
*!*********************************************************************
*!
*! Function: EDIT_DF()
*!
*!*********************************************************************
function edit_df
parameters ld_date, ln_format
* edit date to full format
*****************************
if m->ld_date = ctod(' / / ')
return ''
endif
private lc_ret, lc_month, lc_year, lc_day
lc_month = cmonth(m->ld_date)
lc_year = right('000' + ltrim(str(year(m->ld_date),4)),4)
lc_day = ltrim(str(day(m->ld_date),2))
do case
case m->ln_format = 1
lc_ret = m->lc_month + ' ' + m->lc_day + ', ' + m->lc_year
case m->ln_format = 2
lc_ret = m->lc_day + ' ' + m->lc_month + ' ' + m->lc_year
case m->ln_format = 3
lc_ret = m->lc_month + ' ' + m->lc_year
case m->ln_format = 4
lc_ret = m->lc_month + ' ' + m->lc_day
case m->ln_format = 5
lc_ret = m->lc_day + ' ' + m->lc_month
endcase
return m->lc_ret

********************************************
*!*********************************************************************
*!
*! Function: EDIT_FP()
*!
*! Called by: HEAD_ASG (procedure in ASSIGN.PRG)
*! : BODY_ASG (procedure in ASSIGN.PRG)
*! : MEMX_ASG() (function in ASSIGN.PRG)
*! : HEAD_FE (procedure in FE.PRG)
*! : BODY_FE (procedure in FE.PRG)
*! : HEAD_LEA (procedure in LEASE.PRG)
*! : BODY_LEA (procedure in LEASE.PRG)
*!
*!*********************************************************************
function edit_fp
parameters ln_num, ln_ints, ln_decs, lc_type
* edit number to Fixed or Percent format
********************************************
private lc_ret
if right(m->lc_type,1) = 'P'
ln_num = m->ln_num * 100
endif
ln_num = round(m->ln_num,m->ln_decs)
do case
case m->ln_num = 0 .and. m->ln_ints = 0
lc_ret = '.' + replicate('0', m->ln_decs)
case m->ln_num < 0
lc_ret = transform(m->ln_num, (replicate('9', m->ln_ints + 1) + iif(;
m->ln_decs > 0, '.' + replicate('9', m->ln_decs), '')))
if left(m->lc_ret,1) # '-'
lc_ret = stuff(m->lc_ret, 1, 1, '')
endif
otherwise
lc_ret = transform(m->ln_num, (iif(m->ln_ints>0, replicate('9',;
m->ln_ints), '') + iif(m->ln_decs > 0, '.' + replicate('9',;
m->ln_decs), '')))
endcase
if m->gc_point # '.' .and. at('.',m->lc_ret) > 0
lc_ret = strtran(m->lc_ret, '.', m->gc_point)
endif
if right(m->lc_type,1) = 'P'
lc_ret = m->lc_ret + '%'
endif
if right(m->lc_type,1) = 'F' .and. m->ln_decs = 0 .and. left(m->lc_type,1) = '0'
lc_ret = replicate('0',len(m->lc_ret) - len(ltrim(m->lc_ret))) + ltrim(;
m->lc_ret)
if '-'$m->lc_ret
lc_ret = '-' + stuff(m->lc_ret, at('-', m->lc_ret), 1, '')
endif
endif
if m->ln_num<1 .and. m->ln_num>-1 .and. m->ln_ints>0 .and. m->ln_decs>0
if substr(m->lc_ret,at(m->gc_point,m->lc_ret)-1,1) <> '0'
lc_ret = stuff(m->lc_ret, at(m->gc_point, m->lc_ret), 0, '0')
if left(m->lc_ret, 1) = ' '
lc_ret = stuff(m->lc_ret, 1, 1, '')
endif
endif
endif
if val(m->lc_ret) = 0
do case
case substr(m->lc_type,2,1) = ' '
lc_ret = replicate(' ', len(m->lc_ret))
case '-' $ m->lc_ret
lc_ret = stuff(m->lc_ret, at('-', m->lc_ret), 1, '')
endcase
endif
return m->lc_ret

******************************
*!*********************************************************************
*!
*! Function: EDIT_L()
*!
*! Called by: MEMX_ASG() (function in ASSIGN.PRG)
*!
*!*********************************************************************
function edit_l
parameters ll_value
* edit value to logical format
******************************
return iif(m->ll_value,m->gc_true,m->gc_false)

******************************************
*!*********************************************************************
*!
*! Function: EDIT_SG()
*!
*!*********************************************************************
function edit_sg
parameters ln_num, ln_wid, lc_type
* edit number to scientific/general format
******************************************
private lc_ret, ln_rw, ln_len, ln_dec, ln_exp, ln_dot, ln_sign
private ln_ptr1, ln_ptr2
ln_sign = iif(m->ln_num < 0,1,0)
ln_num = abs(m->ln_num)
ln_rw = m->ln_wid + iif(right(m->lc_type,1)='S',iif(m->ln_wid=0,5,6) + ;
m->ln_sign,0)
if m->ln_num = 0
if left(m->lc_type,1) = '0'
lc_ret = '0'
if right(m->lc_type,1) = 'S'
lc_ret = m->lc_ret + iif(m->ln_wid>0,m->gc_point,'') + replicate(;
'0',m->ln_wid)+'E+00'
endif
else
lc_ret = ''
endif
else
lc_ret = str(m->ln_num,20,max(19-len(ltrim(str(int(m->ln_num),20,0))),0))
lc_ret = ltrim(rtrim(m->lc_ret))
ln_ptr1 = 1
do while substr(m->lc_ret,m->ln_ptr1,1) = '0'
ln_ptr1 = m->ln_ptr1+1
enddo
ln_ptr2 = len(m->lc_ret)
if '.' $ m->lc_ret
do while substr(m->lc_ret,m->ln_ptr2,1) = '0'
ln_ptr2 = m->ln_ptr2-1
enddo
endif
ln_ptr2 = iif(substr(m->lc_ret,m->ln_ptr2,1) = '.',m->ln_ptr2-1,m->ln_ptr2)
lc_ret = substr(m->lc_ret,m->ln_ptr1,m->ln_ptr2-m->ln_ptr1+1)
ln_len = len(m->lc_ret)
ln_dot = at('.',m->lc_ret)
ln_int = iif(m->ln_dot=0,m->ln_len,m->ln_dot-1)
ln_dec = iif(m->ln_dot=0,0,m->ln_len-m->ln_dot)
if right(m->lc_type,1) = 'G' .and. m->ln_int + m->ln_sign <= m->ln_wid
lc_ret = ltrim(str(val(m->lc_ret),m->ln_wid,min(m->ln_dec,max(;
m->ln_wid-(max(1,m->ln_int)+1+m->ln_sign),0))))
do case
case val(m->lc_ret) = 0
lc_ret = '0'
case left(m->lc_ret,1) = '.'
lc_ret = '0'+m->lc_ret
endcase
else
ln_wid = m->ln_wid+iif(right(m->lc_type,1)='S',iif(m->ln_wid=0,5,6)+;
m->ln_sign,0)
if (m->ln_sign#0.and.m->ln_wid>=6).or.(m->ln_sign=;
0.and.m->ln_wid>=5)
ln_exp = at('.',m->lc_ret)
do case
case m->ln_exp = 0
ln_exp = len(m->lc_ret)-1
case m->ln_exp = 1
do while substr(m->lc_ret,m->ln_exp+1,1) = '0'
ln_exp = m->ln_exp+1
enddo
ln_exp = -m->ln_exp
otherwise
ln_exp = m->ln_exp-2
endcase
lc_ret = iif('.'$m->lc_ret,stuff(m->lc_ret,at('.',m->lc_ret),;
1,''),m->lc_ret)
ln_ptr1 = 1
do while substr(m->lc_ret,m->ln_ptr1,1) = '0'
ln_ptr1 = m->ln_ptr1+1
enddo
lc_ret = substr(m->lc_ret,m->ln_ptr1)
lc_ret = stuff(m->lc_ret,2,0,'.')
ln_len = m->ln_wid - (4 + m->ln_sign)
ln_dec = max(m->ln_len-2,0)
lc_ret = ltrim(str(round(val(m->lc_ret),m->ln_dec),max(;
m->ln_len,1),m->ln_dec))
lc_ret = m->lc_ret+'E'+iif(m->ln_exp<0,'-','+') + iif(abs(;
m->ln_exp)<10,'0','')+ltrim(str(abs(m->ln_exp),2,0))
else
lc_ret = replicate('*',m->ln_wid)
endif
endif
endif
lc_ret = iif(m->ln_sign#0.and.left(m->lc_ret,1)#'*'.and.'0'#m->lc_ret,'-','')+;
m->lc_ret
if m->gc_point # '.' .and. at('.',m->lc_ret) > 0
lc_ret = strtran(m->lc_ret, '.', m->gc_point)
endif
if m->ln_rw > len(m->lc_ret)
lc_ret = space(m->ln_rw - len(m->lc_ret)) + m->lc_ret
endif
return m->lc_ret

**************************
*!*********************************************************************
*!
*! Function: FLIP()
*!
*!*********************************************************************
function flip
parameters lc_str, lc_fstr
* exchange character data
**************************
private lc_ret, lc_fchr
lc_ret = m->lc_str
if len(m->lc_fstr) > 0
do case
case left(m->lc_fstr,1) = '*'
lc_fchr = substr(m->lc_fstr,2,1)
if len(m->lc_fchr) > 0 .and. m->lc_fchr$m->lc_str
lc_ret = trim(substr(m->lc_str,1,at(m->lc_fchr,m->lc_str)-1))
endif
otherwise
if len(m->lc_fstr) > 1
if (substr(m->lc_fstr,2,1) = '*')
lc_fchr = left(m->lc_fstr,1)
if len(m->lc_fchr) > 0
lc_ret = ltrim(trim(substr(m->lc_str,at(m->lc_fchr,;
m->lc_str)+1)))
endif
return lc_ret
endif
endif
lc_fchr = left(m->lc_fstr,1)
if m->lc_fchr$m->lc_str
lc_ret = ltrim(ltrim(trim(substr(m->lc_str,at(m->lc_fchr,;
m->lc_str)+1))) + space(1) + trim(substr(m->lc_str,1,at(;
m->lc_fchr,m->lc_str)-1)))
endif
endcase
endif
return m->lc_ret

******************
*!*********************************************************************
*!
*! Function: HISCOPE()
*!
*!*********************************************************************
function hiscope
* high scope value
******************


*****************************************
*!*********************************************************************
*!
*! Function: INRANGE()
*!
*!*********************************************************************
FUNCTION inrange
PARAMETERS lx_val, lx_low, lx_hi
* Determine if value between low and high
*****************************************
RETURN m->lx_val >= m->lx_low .AND. m->lx_val <= m->lx_hi

******************************************************
*!*********************************************************************
*!
*! Function: LIKE()
*!
*!*********************************************************************
function like
parameters lc_pat, lc_str
* Determine if pattern (with wildcards) matches string
******************************************************
private ln_pptr, ln_sptr, ln_pctr, ln_pend, lc_pchr, lc_schr
private ln_qctr, ln_qend
lc_str = rtrim(m->lc_str)
ln_pptr = 1
ln_sptr = 1
ln_pctr = 1
ln_pend = 1
ln_qend = 1
ln_qctr = 1
lc_pchr = substr(m->lc_pat,m->ln_pptr,1)
lc_schr = substr(m->lc_str,m->ln_sptr,1)
do while .t.
if m->lc_pchr = '*'
do while .t.
ln_pptr = m->ln_pptr + 1
if m->ln_pptr > len(m->lc_pat)
return .t.
endif
lc_pchr = substr(m->lc_pat,m->ln_pptr,1)
if m->lc_pchr <> '*' .and. m->lc_pchr <> '?'
exit
endif
enddo
ln_pctr = at('*', substr(m->lc_pat,m->ln_pptr))
if m->ln_pctr = 0
ln_pend = 1 && LEN(lc_pat) - m->ln_pptr
else
ln_pend = m->ln_pctr - 1
endif
ln_qctr = at('?', substr(m->lc_pat,m->ln_pptr))
if m->ln_qctr <> 0
ln_qend = m->ln_qctr - 1
ln_pend = min(m->ln_pend, m->ln_qend)
endif
do while .t.
if upper(substr(m->lc_pat,m->ln_pptr,m->ln_pend)) = upper(substr(;
m->lc_str,m->ln_sptr,m->ln_pend))
if m->ln_qctr = 0
return .t.
else
ln_pptr = m->ln_pptr + m->ln_pend
ln_sptr = m->ln_sptr + m->ln_pend
if .not. (m->ln_pptr > len(m->lc_pat)) .and. .not. (;
m->ln_sptr > len(m->lc_str))
lc_pchr = substr(m->lc_pat,m->ln_pptr,1)
lc_schr = substr(m->lc_str,m->ln_sptr,1)
endif
exit
endif
else
ln_sptr = m->ln_sptr+1
if m->ln_sptr > len(m->lc_str)
return .f.
endif
endif
enddo
endif
if m->ln_sptr > len(m->lc_str)
return .f.
endif
if m->lc_pchr = '?' .and. (m->ln_sptr > len(m->lc_str))
return .f.
endif
if m->lc_pchr = '?' .or. upper(m->lc_pchr) = upper(m->lc_schr)
ln_pptr = m->ln_pptr+1
ln_sptr = m->ln_sptr+1
if .not. (m->ln_pptr > len(m->lc_pat))
lc_pchr = substr(m->lc_pat,m->ln_pptr,1)
endif
if .not. (m->ln_sptr > len(m->lc_str))
lc_schr = substr(m->lc_str,m->ln_sptr,1)
endif
else
return .f.
endif
if m->ln_pptr > len(m->lc_pat)
return .t.
endif
enddo
return .t.

*****************
*!*********************************************************************
*!
*! Function: LOSCOPE()
*!
*!*********************************************************************
function loscope
* low scope value
*****************


**************************
*!*********************************************************************
*!
*! Function: MEMOLIKE()
*!
*!*********************************************************************
function memolike
parameters lc_pat, lm_memo
* compare memo field
**************************
private lc_s, ln_i
ln_i = 1
do while m->ln_i <= len(m->lm_memo)
lc_s = lower(substr(m->lm_memo,m->ln_i,254))
if like(m->lc_pat,m->lc_s)
return .t.
endif
ln_i = m->ln_i + 254
enddo
return .f.

*****************************
*!*********************************************************************
*!
*! Function: MONSBTWN()
*!
*! Called by: YRSBTWN() (function in RRFUNS.PRG)
*!
*!*********************************************************************
function monsbtwn
parameters ld_date1, ld_date2
* months between dates
*****************************
private ln_ret
ln_ret = abs(((year(m->ld_date1)*12) + month(m->ld_date1)) - ((year(;
m->ld_date2)*12) + month(m->ld_date2)))
ln_ret = m->ln_ret - iif(max(day(m->ld_date1),day(m->ld_date2)) < min(day(;
m->ld_date1),day(m->ld_date2)),1,0)
ln_ret = iif(m->ld_date2>m->ld_date1, -m->ln_ret, m->ln_ret)
return m->ln_ret

***************
*!*********************************************************************
*!
*! Function: PAGENO()
*!
*! Called by: ASSIGN.PRG
*! : FE.PRG
*! : LEASE.PRG
*! : TOPM_ASG (procedure in ASSIGN.PRG)
*! : GFR0_ASG (procedure in ASSIGN.PRG)
*! : GNR0_ASG (procedure in ASSIGN.PRG)
*! : TOPM_FE (procedure in FE.PRG)
*! : GFR0_FE (procedure in FE.PRG)
*! : GNR0_FE (procedure in FE.PRG)
*! : TOPM_LEA (procedure in LEASE.PRG)
*! : GFR0_LEA (procedure in LEASE.PRG)
*! : GNR0_LEA (procedure in LEASE.PRG)
*!
*!*********************************************************************
FUNCTION pageno
* page number
***************
return m->gn_lpno

************************
*!*********************************************************************
*!
*! Function: QTR()
*!
*! Called by: DQTR() (function in RRFUNS.PRG)
*!
*!*********************************************************************
function qtr
parameters ld_date
* quarter number of date
************************
return int((month(m->ld_date)+2)/3)

*******************************
*!*********************************************************************
*!
*! Function: RRUNIN()
*!
*!*********************************************************************
function rrunin
* current record of Runtime job
*******************************
return 0

***********************
*!*********************************************************************
*!
*! Function: SCANNING()
*!
*!*********************************************************************
FUNCTION scanning
PARAMETERS ln_alias
* .T. if scanning alias
***********************
RETURN .T.

**************************************************
*!*********************************************************************
*!
*! Function: SPELLNUM()
*!
*! Calls: RR_STRIP() (function in RRFUNS.PRG)
*! : RR_GTRIP() (function in RRFUNS.PRG)
*!
*!*********************************************************************
function spellnum
parameters ln_num
* spells (integer portion of) a numeric expression
**************************************************
private lc_ret, lc_nstr, ln_trips, ln_trip, lc_strip
lc_ret = ''
if m->ln_num < 1 .and. m->ln_num > -1
lc_ret = 'zero'
else
if m->ln_num < 0
lc_ret = 'minus'
endif
lc_nstr = ltrim(str(abs(int(m->ln_num)),20))
ln_trips = ceiling(len(m->lc_nstr)/3)
ln_trip = m->ln_trips
do while m->ln_trip > 0
lc_strip = rr_strip(rr_gtrip(m->lc_nstr,m->ln_trip,m->ln_trips),;
m->ln_trip)
if len(m->lc_strip) > 0
lc_ret = m->lc_ret + iif(len(m->lc_ret) > 0,' ','') + m->lc_strip
endif
ln_trip = m->ln_trip - 1
enddo
endif
lc_ret = iif(len(m->lc_ret) > 0,upper(left(m->lc_ret,1)) + substr(m->lc_ret,2);
,'')
return m->lc_ret

***************************
*!*********************************************************************
*!
*! Function: SUBDAYS()
*!
*!*********************************************************************
FUNCTION subdays
PARAMETERS ld_date, ln_days
* months between dates
***************************
RETURN m->ld_date - m->ln_days

***************************
*!*********************************************************************
*!
*! Function: SUBMONS()
*!
*! Calls: ADDMONS() (function in RRFUNS.PRG)
*!
*!*********************************************************************
function submons
parameters ld_date, ln_mons
* months between dates
***************************
private ld_ret
ld_ret = addmons(m->ld_date,-m->ln_mons)
return m->ld_ret

**************************
*!*********************************************************************
*!
*! Function: SUBWKS()
*!
*! Calls: ADDWKS() (function in RRFUNS.PRG)
*!
*!*********************************************************************
function subwks
parameters ld_date, ln_wks
* months between dates
**************************
private ld_ret
ld_ret = addwks(m->ld_date,-m->ln_wks)
return m->ld_ret

**************************
*!*********************************************************************
*!
*! Function: SUBYRS()
*!
*! Calls: ADDYRS() (function in RRFUNS.PRG)
*!
*!*********************************************************************
function subyrs
parameters ld_date, ln_yrs
* months between dates
**************************
private ld_ret
ld_ret = addyrs(m->ld_date,-m->ln_yrs)
return m->ld_ret

*****************************************
*!*********************************************************************
*!
*! Function: WDCOUNT()
*!
*! Called by: RR_WORD() (function in RRFUNS.PRG)
*!
*!*********************************************************************
function wdcount
parameters lc_str, lc_bstr
* number of words in character expression
*****************************************
private ln_ret, ln_ptr, ll_inword, lc_chr
ln_ret = 0
if .not. (empty(m->lc_str))
ln_ptr = 1
ll_inword = .f.
do while m->ln_ptr <= len(m->lc_str)
lc_chr = substr(lc_str,m->ln_ptr,1)
if m->ll_inword
if m->lc_chr$lc_bstr
ll_inword = .f.
endif
else
if .not. (m->lc_chr$lc_bstr)
ll_inword = .t.
ln_ret = m->ln_ret + 1
endif
endif
ln_ptr = m->ln_ptr + 1
enddo
endif
return m->ln_ret

*******************
*!*********************************************************************
*!
*! Function: WEEK()
*!
*! Calls: RR_CTOD() (function in RRFUNS.PRG)
*!
*!*********************************************************************
function week
parameters ld_date
* week of the month
*******************
private ln_ret
ln_ret = int((day(m->ld_date) + dow(rr_ctod(str(month(m->ld_date),2),'01',str(;
year(m->ld_date),4))) + 5)/7)
return m->ln_ret

*****************************
*!*********************************************************************
*!
*! Function: WKSBTWN()
*!
*!*********************************************************************
function wksbtwn
parameters ld_date1, ld_date2
* weeks between dates
*****************************
return int((m->ld_date1 - m->ld_date2)/7)

*****************************
*!*********************************************************************
*!
*! Function: YRSBTWN()
*!
*! Calls: MONSBTWN() (function in RRFUNS.PRG)
*!
*!*********************************************************************
function yrsbtwn
parameters ld_date1, ld_date2
* years between dates
*****************************
private ln_ret
ln_ret = int(monsbtwn(m->ld_date1,m->ld_date2)/12)
return m->ln_ret

**********************************************
*!*********************************************************************
*!
*! Function: RR_ALIGN()
*!
*!*********************************************************************
function rr_align
parameters lc_string, ln_width, lc_align
* align string within field width Center/Right
**********************************************
private lc_ret, ln_k
lc_ret = trim(m->lc_string)
ln_k = len(m->lc_ret)
if m->ln_k > 0
if m->lc_align = 'C'
lc_ret = space((m->ln_width - m->ln_k + 1)/2) + m->lc_ret
else
lc_ret = space(m->ln_width - m->ln_k) + m->lc_ret
endif
endif
return m->lc_ret

************************************
*!*********************************************************************
*!
*! Function: RR_CTOD()
*!
*! Called by: ADDMONS() (function in RRFUNS.PRG)
*! : ADDYRS() (function in RRFUNS.PRG)
*! : DQTR() (function in RRFUNS.PRG)
*! : WEEK() (function in RRFUNS.PRG)
*!
*!*********************************************************************
FUNCTION rr_ctod
PARAMETERS lc_month, lc_day, lc_year
* a ctod for all seasons
************************************
PRIVATE ld_ret
DO CASE
CASE m->gc_idate = 'A'
ld_ret = CTOD(m->lc_month + '/' + m->lc_day + '/' + m->lc_year)
CASE m->gc_idate = 'B'
ld_ret = CTOD(m->lc_day + '/' + m->lc_month + '/' + m->lc_year)
CASE m->gc_idate = 'C'
ld_ret = CTOD(m->lc_day + '.' + m->lc_month + '.' + m->lc_year)
CASE m->gc_idate = 'D'
ld_ret = CTOD(m->lc_year + '-' + m->lc_month + '-' + m->lc_day)
ENDCASE
RETURN m->ld_ret

*********************************
*!*********************************************************************
*!
*! Function: RR_DAYMAX()
*!
*! Called by: ADDMONS() (function in RRFUNS.PRG)
*! : ADDYRS() (function in RRFUNS.PRG)
*!
*! Calls: RR_LEAP() (function in RRFUNS.PRG)
*!
*!*********************************************************************
FUNCTION rr_daymax
PARAMETERS ln_month, ln_year
* number of days in month of year
*********************************
PRIVATE ln_ret
ln_ret = IIF(str(m->ln_month,2)$' 1 3 5 7 81012',31,;
IIF(str(m->ln_month,2)$' 4 6 911',30,IIF(rr_leap(m->ln_year),29,28)))
RETURN m->ln_ret

*************************
*!*********************************************************************
*!
*! Function: RR_DTOC()
*!
*!*********************************************************************
function rr_dtoc
parameters ld_date
* date to yyyymmdd format
*************************
return transform(year(m->ld_date),'@L 9999') + transform(month(m->ld_date),'@';
+'L 99') + transform(day(m->ld_date),'@L 99')

****************************
*!*********************************************************************
*!
*! Function: RR_GO_REC()
*!
*! Called by: RR_MWRAP (procedure in RRFUNS.PRG)
*!
*!*********************************************************************
function rr_go_rec
parameters ln_area, ln_recno
* GOTO recno in area
****************************
private ln_ret
select (m->ln_area)
ln_ret = recno()
goto ln_recno
return m->ln_ret

*************************************
*!*********************************************************************
*!
*! Function: RR_GTRIP()
*!
*! Called by: SPELLNUM() (function in RRFUNS.PRG)
*!
*!*********************************************************************
function rr_gtrip
parameters lc_nstr, ln_trip, ln_trips
* extract triplet from numeric string
*************************************
private lc_ret
lc_ret = substr(m->lc_nstr,len(m->lc_nstr)-min(m->ln_trip*3,len(m->lc_nstr))+;
1,iif(m->ln_trip=m->ln_trips,len(m->lc_nstr)-(3*(m->ln_trips-1)),3))
return m->lc_ret

******************
*!*********************************************************************
*!
*! Function: RR_LEAP()
*!
*! Called by: RR_DAYMAX() (function in RRFUNS.PRG)
*!
*!*********************************************************************
FUNCTION rr_leap
PARAMETERS ln_year
* is a leap year
******************
RETURN m->ln_year%4=0 .AND. (.NOT.(m->ln_year%100=0 .AND. m->ln_year%400>0))

*******************************************
*!*********************************************************************
*!
*! Function: RR_MFILT()
*!
*! Called by: RR_MWRAP (procedure in RRFUNS.PRG)
*!
*!*********************************************************************
function rr_mfilt
parameters lc_s
* filter non-graphic characters from string
*******************************************
private ln_c, ln_i, ln_n
ln_n = len(m->lc_s)
ln_i = 1
do while m->ln_i <= m->ln_n
ln_c = asc(substr(m->lc_s,m->ln_i,1))
do case
case m->ln_c = 9
lc_s = stuff(m->lc_s,m->ln_i,1,' ')
case m->ln_c < 32
lc_s = stuff(m->lc_s,m->ln_i,1,'')
ln_n = m->ln_n - 1
loop
endcase
ln_i = m->ln_i + 1
enddo
return m->lc_s

*******************
*!*********************************************************************
*!
*! Function: RR_NONE()
*!
*! Called by: RR_STRIP() (function in RRFUNS.PRG)
*!
*!*********************************************************************
FUNCTION rr_none
PARAMETERS lc_str
* cardinal name 1-9
*******************
PRIVATE lc_ret
lc_ret = IIF(m->lc_str='1','one',IIF(m->lc_str='2','two',;
IIF(m->lc_str='3','three',IIF(m->lc_str='4','four',;
IIF(m->lc_str='5','five',IIF(m->lc_str='6','six',;
IIF(m->lc_str='7','seven',IIF(m->lc_str='8','eight',;
IIF(m->lc_str='9','nine','')))))))))
RETURN m->lc_ret

*********************
*!*********************************************************************
*!
*! Function: RR_NTEEN()
*!
*! Called by: RR_STRIP() (function in RRFUNS.PRG)
*!
*!*********************************************************************
FUNCTION rr_nteen
PARAMETERS lc_str
* cardinal name 10-19
*********************
PRIVATE lc_ret
lc_ret = IIF(m->lc_str='0','ten',IIF(m->lc_str='1','eleven',;
IIF(m->lc_str='2','twelve',IIF(m->lc_str='3','thirteen',;
IIF(m->lc_str='4','fourteen',IIF(m->lc_str='5','fifteen',;
IIF(m->lc_str='6','sixteen',IIF(m->lc_str='7','seventeen',;
IIF(m->lc_str='8','eighteen',IIF(m->lc_str='9','nineteen',''))))))))))
RETURN m->lc_ret

*****************************
*!*********************************************************************
*!
*! Function: RR_NTEN()
*!
*! Called by: RR_STRIP() (function in RRFUNS.PRG)
*!
*!*********************************************************************
function rr_nten
parameters lc_str
* cardinal name 20-90 (by 10)
*****************************
private lc_ret
lc_ret = iif(m->lc_str='2','twenty',iif(m->lc_str='3','thirty',;
iif(m->lc_str='4','forty',iif(m->lc_str='5','fifty',;
iif(m->lc_str='6','sixty',iif(m->lc_str='7','seventy',;
iif(m->lc_str='8','eighty',iif(m->lc_str='9','ninety',''))))))))
return m->lc_ret

*******************
*!*********************************************************************
*!
*! Function: RR_NTRIP()
*!
*! Called by: RR_STRIP() (function in RRFUNS.PRG)
*!
*!*********************************************************************
function rr_ntrip
parameters ln_trip
* name of a triplet
*******************
private lc_ret
lc_ret = iif(m->ln_trip=7,'quintillion',iif(m->ln_trip=6,'quadrillion',;
iif(m->ln_trip=5,'trillion',iif(m->ln_trip=4,'billion',;
iif(m->ln_trip=3,'million',iif(m->ln_trip=2,'thousand',''))))))
return m->lc_ret

*************************************
*!*********************************************************************
*!
*! Function: RR_SEEK()
*!
*!*********************************************************************
function rr_seek
parameters lc_string, ln_fl, ln_kl
* adjust seek string to proper length
*************************************
private ln_k
ln_k = len(m->lc_string)
if m->ln_k < m->ln_fl
lc_string = lc_string + space(m->ln_fl - m->ln_k)
endif
lc_string = left(m->lc_string,m->ln_kl)
return lc_string

***************************
*!*********************************************************************
*!
*! Function: RR_STRIP()
*!
*! Called by: SPELLNUM() (function in RRFUNS.PRG)
*!
*! Calls: RR_NONE() (function in RRFUNS.PRG)
*! : RR_NTEN() (function in RRFUNS.PRG)
*! : RR_NTEEN() (function in RRFUNS.PRG)
*! : RR_NTRIP() (function in RRFUNS.PRG)
*!
*!*********************************************************************
function rr_strip
parameters lc_nstr, ln_trip
* spell triplet
***************************
private lc_ret, ln_ptr
lc_ret = ''
ln_ptr = 1
do while left(m->lc_nstr,1) = '0'
lc_nstr = stuff(m->lc_nstr,1,1,'')
enddo
if len(m->lc_nstr) > 0
if len(m->lc_nstr) = 3
lc_ret = rr_none(substr(m->lc_nstr,1,1))+' hundred'
ln_ptr = m->ln_ptr+1
endif
if len(m->lc_nstr) >= 2
do case
case substr(m->lc_nstr,m->ln_ptr,1) > '1'
lc_ret = m->lc_ret + iif(len(m->lc_ret) > 0,' ','') + rr_nten(;
substr(m->lc_nstr,m->ln_ptr,1)) + iif(substr(m->lc_nstr,;
m->ln_ptr+1,1) > '0','-','') + rr_none(substr(m->lc_nstr,;
m->ln_ptr+1,1))
case substr(m->lc_nstr,m->ln_ptr,1) = '1'
lc_ret = m->lc_ret + iif(len(m->lc_ret) > 0,' ','') + ;
rr_nteen(substr(m->lc_nstr,m->ln_ptr+1,1))
case substr(m->lc_nstr,m->ln_ptr,1) = '0'
lc_ret = m->lc_ret + iif(len(m->lc_ret) > 0 .and. substr(;
m->lc_nstr,m->ln_ptr+1,1) > '0',' ','') + rr_none(substr(;
m->lc_nstr,m->ln_ptr+1,1))
endcase
else
lc_ret = rr_none(left(m->lc_nstr,1))
endif
lc_ret = m->lc_ret + iif(m->ln_trip>1,' '+rr_ntrip(m->ln_trip),'')
endif
return m->lc_ret

***************************
*!*********************************************************************
*!
*! Function: RR_ST_EQ()
*!
*! Called by: MEMX_ASG() (function in ASSIGN.PRG)
*!
*!*********************************************************************
function rr_st_eq
parameters lc_str1, lc_str2
* R&R string compare equal
***************************
private ll_ret
set exact on
do case
case len(m->lc_str1) = 0
ll_ret = len(trim(m->lc_str2)) = 0
case len(m->lc_str2) = 0
ll_ret = len(trim(m->lc_str1)) = 0
otherwise
ll_ret = lower(m->lc_str1) = lower(m->lc_str2)
endcase
set exact off
return m->ll_ret

***************************************
*!*********************************************************************
*!
*! Function: RR_ST_LE()
*!
*!*********************************************************************
function rr_st_le
parameters lc_str1, lc_str2
* R&R string compare less than or equal
***************************************
private ll_ret
set exact on
do case
case len(m->lc_str1) = 0
ll_ret = .t.
case len(m->lc_str2) = 0
ll_ret = len(trim(m->lc_str1)) = 0
otherwise
ll_ret = lower(m->lc_str1) <= lower(m->lc_str2)
endcase
set exact off
return m->ll_ret

******************************
*!*********************************************************************
*!
*! Function: RR_ST_LT()
*!
*!*********************************************************************
function rr_st_lt
parameters lc_str1, lc_str2
* R&R string compare less than
******************************
private ll_ret
set exact on
do case
case len(m->lc_str1) = 0
ll_ret = len(trim(m->lc_str2)) > 0
case len(m->lc_str2) = 0
ll_ret = .f.
otherwise
ll_ret = lower(m->lc_str1) < lower(m->lc_str2)
endcase
set exact off
return m->ll_ret

***************************************
*!*********************************************************************
*!
*! Function: RR_WORD()
*!
*! Calls: WDCOUNT() (function in RRFUNS.PRG)
*!
*!*********************************************************************
function rr_word
parameters lc_str, ln_n, lc_bstr
* find nth word in character expression
***************************************
private lc_ret, ll_inword, ll_done, ln_ptr, ln_wcnt, lc_chr
lc_ret = ''
if .not. (empty(m->lc_str)) .and. m->ln_n # 0
ll_inword = .f.
ln_n = iif(m->ln_n > 0,ln_n,ln_n + wdcount(lc_str,lc_bstr) + 1)
ll_done = .f.
ln_wcnt = 0
ln_ptr = 1
do while m->ln_ptr <= len(lc_str) .and. (.not.(m->ll_done))
lc_chr = substr(lc_str,m->ln_ptr,1)
if m->ll_inword
if m->lc_chr$lc_bstr
ll_inword = .f.
if m->ln_n = m->ln_wcnt
ll_done = .t.
endif
else
if ln_n = m->ln_wcnt
lc_ret = m->lc_ret + m->lc_chr
endif
endif
else
if .not.(m->lc_chr$m->lc_bstr)
ll_inword = .t.
ln_wcnt = m->ln_wcnt + 1
if m->ln_n = m->ln_wcnt
lc_ret = m->lc_ret + m->lc_chr
endif
endif
endif
ln_ptr = m->ln_ptr + 1
enddo
endif
return m->lc_ret


*!*********************************************************************
*!
*! Function: STATUS1()
*!
*! Called by: ASSIGN.PRG
*! : FE.PRG
*! : LEASE.PRG
*!
*!*********************************************************************
function status1

private prt_state
private con_state

prt_state = setprint()
con_state = setconsole()

setprint(.f.)
setconsole(.t.)
setcursor(.f.)
setcolor("W+/B")
blindclose(4)

setcolor(clr_frame)
scroll(0,0,0,79,0)
@ 0, 0 say "Report Printing"
@ 0,60 say date()

setcolor("W+/B")

center(06," ÚÄÄÄÄÄÄÄÄÄÄÄÄ¿ ")
center(07," ³: Print :³ ")
center(08," ³: -O- :³ ")
center(09," ³: Matic :³ ")
center(10,"ÚÄÄÄÐÄÄÄÄÄÄÄÄÄÄÐÄÄÄ¿ ")
center(11,"³ ±±±±±±± þþþþþ ³µ")
center(12,"ÀÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÙ ")
center(13," ÄÁÄ ÄÁÄ ")

@ 15,28 say"ÚÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄ¿"
@ 16,28 say"³Page: ³Line: ³"
@ 17,28 say"ÀÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÙ"

setcolor("Gr+/B")

setprint(prt_state)
setconsole(con_state)

return ''


*!*********************************************************************
*!
*! Function: STATUS2()
*!
*! Called by: ASSIGN.PRG
*! : FE.PRG
*! : LEASE.PRG
*!
*!*********************************************************************
function status2

parameters page_num,line_num

private prt_state
private con_state
private cur_state
private oldcolor

prt_state = setprint()
con_state = setconsole()

setprint(.f.)
setconsole(.t.)


oldcolor = setcolor()
setcolor('*GR+/B')
@ 14,28 say" Printing... "
setcolor(oldcolor)

@ 16,34 say page_num picture '9999'
@ 16,45 say line_num picture '9999'

setprint(prt_state)
setconsole(con_state)

return ''



*!*********************************************************************
*!
*! Function: GET_DEST()
*!
*! Called by: RETRAK2.PRG
*!
*! Calls: CLR_BOX() (function in MISC.PRG)
*! : UNIQUE_FILE() (function in RRFUNS.PRG)
*!
*!*********************************************************************
function get_dest

private savescrn
private oldcolor
private ret_dest
private prompt1,prompt2,prompt3,prompt4
private dest
private mfile

prompt1 = "Printer"
prompt2 = "Screen "
prompt3 = "File "
prompt4 = "Exit "
mfile = space(12)

oldcolor = setcolor()

savescrn = savescreen(0,0,24,79)

clr_box()
@ 08,2 say "ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿"
@ 09,2 say "³ The report will be printed on 8 1/2 X 11 inch paper, in compressed ³"
@ 10,2 say "³ mode. Please be sure the printer is turned on and ready. You will be ³"
@ 11,2 say "³ allowed to select output to the printer, screen, or a file which can be ³"
@ 12,2 say "³ printed later. ³"
@ 13,2 say "ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ"


shadowbox(16,20,18,60,2,"Output Destination")


@ 17,22 prompt prompt1
@ 17,32 prompt prompt2
@ 17,42 prompt prompt3
@ 17,52 prompt prompt4

menu to dest


do case
case dest = 1
ret_dest = 'P' + space(12)
case dest = 2
mfile = unique_file(".TXT")
ret_dest = 'S'+mfile
case dest = 3
savescrn = savescreen(15, 19, 19, 62)

shadowbox(16,20,18,60,2,"Output Destination")
@ 17, 22 say "Enter File Name " get mfile valid len(trim(mfile))>0
set cursor on
read
set cursor off
restscreen(15,19,19,62,savescrn)
if lastkey() != 27
ret_dest = "F"+mfile
else
ret_dest = ''
endif
otherwise
ret_dest = ''
endcase

restscreen(0,0,24,79)

return ret_dest



*!*********************************************************************
*!
*! Function: UNIQUE_FILE()
*!
*! Called by: GET_DEST() (function in RRFUNS.PRG)
*!
*!*********************************************************************
function unique_file

external rand

parameters extension

if pcount() < 1
_fil = "???"
retu _fil
endif

private _fil, _tries, _unique

_unique = .f.
_tries = 0

do while !_unique

_tries = _tries + 1

if _tries > 100
if !yes_no('More than 100 attempts to generate a unique file name. Continue')
_unique = .t.
_fil = 'NUL' && Point to Null Device to prevent overwriting file.
loop
endif
endif

_fil = strtran(str(rand(100000000),8),' ','0')+extension

_unique = !file('&_fil.')

enddo

return _fil


*!*********************************************************************
*!
*! Function: PRINTOK()
*!
*!*********************************************************************
function printok
param sez
private ret_val, oldcolor, oldscrn
sez = (pcount() = 0) && if no parameter passed, assume use of @...SAYs
ret_val = .T.
if ! isprinter()
oldcolor = setcolor(if(iscolor(), '+W/R', '+W/N'))
oldscrn = savescreen(09, 11, 15, 69, 2)
shadowbox(09, 11, 14, 67, 3, 'Printer Error')
@ 10, 13 say 'Common problems include: out of paper, paper jammed,'
@ 11, 13 say 'off-line, printer unplugged, cable loose or unplugged'
@ 12, 13 say 'Please check your printer and press any key to resume'
@ 13, 17 say '(Press Esc key to abort this print operation)'
set console off
do while ! isprinter() .AND. lastkey() != 27
tone(660,1)
tone(660,1)
wait ''
enddo
set console on
restscreen(09, 11, 15, 69, oldscrn)
setcolor(oldcolor)
if lastkey() = 27
ret_val = .F.
endif
endif
if ret_val
if sez
set console off && Added by D.Forcier 06/06/90
set device to print
else
set print on
endif
endif
return(ret_val)


function center_it

parameters str, length

if pcount() < 2
length = 80 && Default to 80 columns
endif

* Center a string within an 80 column string, padding left and right.

midpoint = length/2

str = ltrim(rtrim(str)) && Make sure no bonehead strings passed..

col = int( midpoint - len(str)/2 )

str = space(col-1)+str

return str

****************************************************************************
* Printer selection function
* Note: Exbox() and Apick() are Grumpfish Library functions. If you don't
* own this fantastic library, you should! Call Grumpfish Inc. at
* 503-588-1815 and tell 'em Darren sent ya! (Yeah, I'm plugging, but
* believe me, the Grumpfish Library deserves it!
****************************************************************************
function rrprsel

parameters pass_color

private savearea
private oldcolor
private oldalias
private item_pick


oldalias = alias()
savearea = savescreen(06,24,18,57)
oldcolor = setcolor()
setcolor(pass_color)

select 0
use rrprint index rrprint

waiton('Building Printer List... Please wait')
declare names[ reccount() ]

for i = 1 to reccount()
names[i] = rrprint->gc_psname
skip
next

waitoff()

exbox(6,25,17,55,2,10,chr(32),.t.,"Printer Selections")

item_pick = apick(07,26,16,54,names,"Gr+/B","Gr","Gr")

use

if oldalias # ''
select &oldalias
endif

restscreen(06,24,18,57,savearea)
setcolor(oldcolor)

return iif (item_pick > 0, names[item_pick], '')




*: EOF: RRFUNS.PRG


  3 Responses to “Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : RRSTUFF.ZIP
Filename : RRFUNS.PRG

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/