!**********************************************************************
!* *
!* MODULE: TDTREE01.SQR *
!* AUTHOR: TONY DELIA. *
!* DATE: 07/02/97. *
!* SYSTEM: TD SQR UTILITY SERIES. *
!* DESC: PSTREENODE LISTING. *
!* *
!**********************************************************************
!* *
!* TABLES: pstreenode - Select *
!* pstreedefn - Select *
!* pstreestrct - Select *
!* psrecdefn - Select *
!* psrecfield - Select *
!* pstreeleaf - Select *
!* *
!* < All other tables are accessed DYNAMICALLY >. *
!* *
!**********************************************************************
!* *
!* LEGAL: CONFIDENTIALITY INFORMATION. *
!* *
!* This module is the original work of Tony DeLia. It *
!* can be considered ShareWare under the following *
!* conditions. *
!* *
!* A - The author's name (Tony DeLia) remains on any *
!* and all versions of this module. *
!* B - Any modifications must be clearly identified. *
!* C - A "vanilla" copy of this module must be kept *
!* alongside any revised versions. *
!* *
!**********************************************************************
!* *
!* WEBSITE: http://www.sqrtools.com *
!* *
!* Questions/Comments: tdelia@erols.com *
!* *
!**********************************************************************
#include 'setenv.sqc' ! Set environment
!**********************************************************************
!* Set Up *
!**********************************************************************
begin-setup
#Include 'setup02a.sqc' ! Printer and page-size init landscape
end-setup
!**********************************************************************
!* Report Heading *
!**********************************************************************
begin-heading 8
let $TDhd1a = ' Tree: '
let $TDhd1b = $treename
let $TDhd2a = ' TreeName: '
let $TDhd2b = $tree-descr
if rtrim($setid,' ') <> ''
let $TDhd1b = $setid || '.' || $TDhd1b || $tree-effdt
end-if
#include 'stdhdg01.sqc'
print $TDhd1a ( 3, 1, 0 )
print $TDhd1b ( 0, 0, 0 )
print $TDhd2a ( 4, 1, 0 )
print $TDhd2b ( 0, 0, 0 )
print '=' ( +1, 1,175) fill
print 'Tree' ( +1, 1, 0 )
print 'Tree' ( 0, 22, 0 )
print 'Begin' ( 0, 34, 0 )
print ' End' ( 0, 47, 0 )
print 'Parent' ( 0, 59, 0 )
print '*--------------------' ( 0, 69, 0 )
print '--------------- ' ( 0, 0, 0 )
print 'Tree Level Details ' ( 0, 0, 0 )
print '--------------------' ( 0, 0, 0 )
print '----------------*' ( 0, 0, 0 )
print 'Node' ( +1, 1, 0 )
print 'Level' ( 0, 22, 0 )
print ' Node' ( 0, 34, 0 )
print ' Node' ( 0, 47, 0 )
print ' Node' ( 0, 59, 0 )
print '0 1 2 ' ( 0, 69, 0 )
print '3 4 5 ' ( 0, 0, 0 )
print '6 7 8 ' ( 0, 0, 0 )
print '9 10 11 ' ( 0, 0, 0 )
print '=' ( +1, 1,175) fill
end-heading
!**********************************************************************
!* Report Footing *
!**********************************************************************
begin-footing 2
print $warning (2, 50, 0)
let $warning = ' '
end-footing
!**********************************************************************
!* Mainline Processing *
!**********************************************************************
begin-report
do Init-DateTime
do Get-Current-DateTime
move $AsOfToday to $AsOfDate
do Enter-Tree
if $tree-ok = 'Y'
do Init-Tree
do Process-Tree
end-if
end-report
!**********************************************************************
!* Initialize Tree Data *
!**********************************************************************
begin-procedure Init-Tree
create-array name=TREEdat size=64 field=TREEnod:char -
field=TREEbeg:number -
field=TREEend:number -
field=TREEpar:number
let #tree = 0
let #tree-max = 64
let $setid = '$'
let $treename = '$'
let $TREEmsg = '*** WARNING: Children seperated from Parents ***'
let $warning = ' '
end-procedure
!**********************************************************************
!* Enter Tree *
!**********************************************************************
begin-procedure Enter-Tree
let $sw = 'Y'
while upper($sw) = 'Y'
let $sw = 'N'
input $tree_setid maxlen=5 'Enter Setid (or %)' type=char
input $tree maxlen=18 'Enter Treename' type=char
uppercase $tree_setid
uppercase $tree
do Test-Tree
if $tree-ok = 'N'
input $sw maxlen=1 'Invalid Treename. Retry? (Y/N)' type=char
end-if
end-while
end-procedure
!**********************************************************************
!* Test Tree *
!**********************************************************************
begin-procedure Test-Tree
let $tree-ok = 'N'
begin-select LOOPS=1
t.tree_name
let $tree-ok = 'Y'
from pstreedefn t
where t.setid like $tree_setid
and t.tree_name like $tree
end-select
end-procedure
!**********************************************************************
!* Process Main *
!**********************************************************************
begin-procedure Process-Tree
let $ReportId = 'TDTREE01'
let $ReportTitle = 'TD Tree Node Listing'
display $ReportId noline
display ' ' noline
display $ReportTitle
display ' '
begin-select
a.setid
a.tree_name
a.effdt
a.tree_node
a.tree_branch
a.tree_node_num
a.tree_node_num_end
a.parent_node_num
a.tree_node_type
if $treename <> &a.tree_name
or $setid <> &a.setid
do New-Tree
end-if
do Move-Tree
do Find-Tree
do Print-Tree
do Print-Leaf
from pstreenode a
where a.setid like $tree_setid
and a.tree_name like $tree
and a.effdt =
(select max(a2.effdt)
from pstreenode a2
where a2.setid = a.setid
and a2.tree_name = a.tree_name
and a2.effdt <= $AsOfDate)
order by a.setid asc,
a.tree_name asc,
a.tree_node_num asc,
a.parent_node_num asc
end-select
end-procedure
!**********************************************************************
!* New Tree *
!**********************************************************************
begin-procedure New-Tree
if $treename <> '$'
new-page
end-if
let $setid = &a.setid
let $treename = &a.tree_name
let #tree-ctr = 0
let $tree-strct-id = ' '
let $tree-descr = ' '
begin-select
d.tree_name
d.tree_strct_id
d.descr
d.effdt
s.node_recname
s.node_fieldname
s.dtl_recname
s.dtl_fieldname
let $tree-strct-id = &d.tree_strct_id
let $tree-descr = &d.descr
let $tree-node-rec = &s.node_recname
let $tree-node-field = &s.node_fieldname
let $tree-node-col = 'DESCR'
let $tree-dtl-rec = &s.dtl_recname
let $tree-dtl-field = &s.dtl_fieldname
let $tree-dtl-col = ' '
let $tree-effdt = ' ( ' || &d.effdt || ' )'
do Detail-Descr-Field
let $tree-node-rec = 'PS_' || $tree-node-rec
let $tree-dtl-rec = 'PS_' || $tree-dtl-rec
from pstreedefn d,
pstreestrct s
where d.tree_strct_id = s.tree_strct_id
and d.setid = &a.setid
and d.tree_name = &a.tree_name
and d.effdt =
(select max(d2.effdt)
from pstreedefn d2
where d2.setid = d.setid
and d2.tree_name = d.tree_name
and d2.effdt <= $AsOfDate)
end-select
display ' '
display 'TreeName: ' noline
display &a.setid noline
display '.' noline
display &a.tree_name noline
display ' Structure ID: ' noline
display $tree-strct-id noline
display ' (' noline
display $tree-descr noline
display ')'
display 'Node Record/Field/Descr: ' noline
display $tree-node-rec noline
display '.' noline
display $tree-node-field noline
display '.' noline
display $tree-node-col
if rtrim($tree-dtl-col,' ') <> ''
display 'Detail Record/Field/Descr: ' noline
display $tree-dtl-rec noline
display '.' noline
display $tree-dtl-field noline
display '.' noline
display $tree-dtl-col
end-if
end-procedure
!**********************************************************************
!* Move Tree Fields *
!**********************************************************************
begin-procedure Move-Tree
let $node = &a.tree_node
let #beg = &a.tree_node_num
let #end = &a.tree_node_num_end
let #par = &a.parent_node_num
let $type = &a.tree_node_type
end-procedure
!**********************************************************************
!* Find Tree Level *
!**********************************************************************
begin-procedure Find-Tree
let #tree = 0
let $TREEnod = ' '
let #TREEbeg = 0
let #TREEend = 0
let #TREEpar = 0
let $TREEerr = ' '
while #tree < #tree-max
if #beg = 1
or #TREEbeg = #par
put $node #beg #end #par -
into TREEdat(#tree) TREEnod TREEbeg TREEend TREEpar
let #tree-ctr = #tree
break
end-if
if #tree <= #tree-ctr
get $TREEnod #TREEbeg #TREEend #TREEpar
from TREEdat(#tree) TREEnod TREEbeg TREEend TREEpar
let #tree = #tree + 1
else
let $TREEerr = '*'
let #tree = #tree-ctr + 1
let $warning = $TREEmsg
break
end-if
end-while
end-procedure
!**********************************************************************
!* Print Tree Fields *
!**********************************************************************
begin-procedure Print-Tree
if $type = 'R'
do REC-Search
else
do DYN-Search
end-if
let $ind = ' '
let $ind = rpad($ind,(#tree*7)+1,' ')
let $data = $ind || $node
if $descr-found = 'Y'
let $data = $data || ' - ' || $node-descr
end-if
print $node ( +1, 1, 0 )
print #tree ( 0, 21, 0 ) edit B999
print $TREEerr ( 0, 0, 0 )
print #beg ( 0, 28, 0 ) edit B9999999999
print #end ( 0, 41, 0 ) edit B9999999999
print #par ( 0, 54, 0 ) edit B9999999999
print $data ( 0, 68, 0 )
end-procedure
!**********************************************************************
!* Print Leaf Fields *
!**********************************************************************
begin-procedure Print-Leaf
let #tree = #tree + 1
let $ind = ' '
let $ind = rpad($ind,(#tree*7)+1,' ')
begin-select
lf.range_from
lf.range_to
let $from = rtrim(&lf.range_from,' ')
let $to = rtrim(&lf.range_to,' ')
let $node = $from
let $node-descr = ' '
if rtrim($tree-dtl-col,' ') <> ''
do DTL-Search
end-if
let $pad = ''
if &lf.range_from <> &lf.range_to
let $node = $node || ' - ' || $to
else
let $pad = rpad($pad,length($node)+3,' ')
end-if
let $data = $ind || $node || $pad
if rtrim($node-descr,' ') <> ''
let $data = $data || ' ( ' || $node-descr || ' )'
end-if
print ' ' ( +1, 1, 0 )
print #tree ( 0, 21, 0 ) edit B999
print #beg ( 0, 54, 0 ) edit B9999999999
print $data ( 0, 68, 0 )
from pstreeleaf lf
where lf.setid = &a.setid
and lf.tree_name = &a.tree_name
and lf.tree_branch = &a.tree_branch
and lf.tree_node_num = &a.tree_node_num
and lf.effdt =
(select max(lf2.effdt)
from pstreeleaf lf2
where lf2.setid = lf.setid
and lf2.tree_name = lf.tree_name
and lf2.tree_branch = lf.tree_branch
and lf2.tree_node_num = lf.tree_node_num
and lf2.effdt <= $AsOfDate)
order by lf.range_from asc
end-select
end-procedure
!**********************************************************************
!* Dynamic Description Search - Node Level(s) *
!**********************************************************************
begin-procedure DYN-Search
let $descr-found = 'N'
let $node-descr = ' '
begin-select LOOPS=1
[$tree-node-col] &NODEdescr=char
let $descr-found = 'Y'
let $node-descr = &NODEdescr
from [$tree-node-rec]
where [$tree-node-field] = $node
end-select
end-procedure
!**********************************************************************
!* Dynamic Description Search - Detail Level *
!**********************************************************************
begin-procedure DTL-Search
let $descr-found = 'N'
let $node-descr = ' '
begin-select LOOPS=1
[$tree-dtl-col] &DTLdescr=char
let $descr-found = 'Y'
let $node-descr = &DTLdescr
from [$tree-dtl-rec]
where [$tree-dtl-field] = $node
end-select
end-procedure
!**********************************************************************
!* Record Search *
!**********************************************************************
begin-procedure REC-Search
let $descr-found = 'N'
let $node-descr = ' '
begin-select
r.recdescr
let $descr-found = 'Y'
let $node-descr = &r.recdescr
from psrecdefn r
where r.recname = $node
end-select
end-procedure
!**********************************************************************
!* Determine Detail Description Field *
!**********************************************************************
begin-procedure Detail-Descr-Field
let $descr-found = 'N'
let $tree-dtl-col = ' '
begin-select
f.fieldname
let $descr-found = 'Y'
let $tree-dtl-col = &f.fieldname
! NAME1 takes precedence over DESCR (Record could contain both)
if &f.fieldname = 'NAME1'
exit-select
end-if
from psrecfield f
where f.recname = $tree-dtl-rec
and f.fieldname in ('NAME1','DESCR')
end-select
end-procedure
!**********************************************************************
!* Include Members: *
!**********************************************************************
#Include 'curdttim.sqc' !Get-Current-DateTime procedure
#Include 'datetime.sqc' !Routines for date and time formatting
!**********************************************************************
!* End of Program *
!**********************************************************************
|
