Attribute VB_Name = "mRptGen"
Option Explicit
Option Compare Text
Option Base 0

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Enum SubStatus
    SubCatastrophic = &H1
    SubNoTemplate = 2
    SubNoSpan = 4
    SubSpanNoID = 8
    SubSpanIDNoReport = 16
    SubSpanIDNoEm = 32
    SubSpanIDEmNoField = 64
    SubSpanIDEmOK = 128
End Enum
Public msubOutcome As SubStatus
''Private mobjRepMan As EIREPMAN.EpiReportManager              '   report manager
Private mstrRepDir As String
Public mbolPrintImage As Boolean           '   True for printing graphs and maps
Public mstrWhere As String                 '   For selecting facilities
Public mstraFacs() As String

Private mstraSources() As String            '   Data sources built (0=params)

'   The methods in this module expect that an parameter/type record is current in mrsIndex

Public Sub GenReport()
Dim lstrTemplate As String
Dim lrsFacil As DAO.Recordset
Dim lstrSQL As String
Dim lfrmSelRpt As Form
Dim i As Integer
Dim j As Integer

    If mrsIndex!repttype = "F" Then         '   Facility reports
        lstrSQL = "SELECT f.FacilityCode, f.FacilityName, Count(*) as N FROM " & FACILTBL & " AS F INNER JOIN " & DATATBL _
          & " AS D ON f.PredecesorCode=d.ReptLev AND f.FacilityCode=left(d.Row,6) WHERE d.ReportName LIKE""" & mrsIndex!ReptID & "*"" AND d.ReptYrQtr=""" _
          & mrsIndex!reptyrqtr & """ AND d.ReptLev=""" & mrsIndex!ReptLev & """ GROUP BY f.FacilityCode, f.FacilityName ORDER BY f.FacilityCode"
        Set lrsFacil = mobjDB.DB.OpenRecordSet(lstrSQL, dbOpenSnapshot, dbReadOnly)   '   Get all the facilities for which there is data
        If lrsFacil.EOF Then
            MsgBox "No data found", vbMsgBoxSetForeground, "TB Register"
            GoTo Cleanup
        End If
        Load fSelRpt        '   Load the form and fill its list
        Set lfrmSelRpt = Forms(Forms.Count - 1)
        With lfrmSelRpt
            .lstRpt.AddItem "-- ALL FACILITIES --"
            Do While Not lrsFacil.EOF
                .lstRpt.AddItem lrsFacil(1) & " (" & lrsFacil(0) & ")"
                lrsFacil.MoveNext
            Loop
            .Show vbModal       '   Show the form
            If (.lstRpt.SelCount = 0) Or .mbolExit Then GoTo Cleanup     '   If none selected or cancel
            mstrWhere = " AND LEFT(ROW,6) IN ("
            If .lstRpt.Selected(0) Then
                ReDim mstraFacs(.lstRpt.ListCount - 2)
                For i = 1 To .lstRpt.ListCount - 1
                    mstraFacs(i - 1) = Mid$(.lstRpt.List(i), Len(.lstRpt.List(i)) - 6, 6)
                    mstrWhere = mstrWhere & """" & mstraFacs(i - 1) & ""","
                Next i
            Else
                ReDim mstraFacs(.lstRpt.SelCount - 1)
                j = 0
                For i = 1 To .lstRpt.ListCount - 1
                    If .lstRpt.Selected(i) Then
                        mstraFacs(j) = Mid$(.lstRpt.List(i), Len(.lstRpt.List(i)) - 6, 6)
                        mstrWhere = mstrWhere & """" & mstraFacs(j) & ""","
                        j = j + 1
                    End If
                Next i
            End If
            Mid$(mstrWhere, Len(mstrWhere), 1) = ")"
        End With
        Unload lfrmSelRpt
        Set lfrmSelRpt = Nothing
    Else
        mstrWhere = ""
    End If
    
    InitializeData
    
'   Get the appropriate template
    If mbolPrintImage Then
        lstrTemplate = mrsIndex!AltTemplate
    Else
        lstrTemplate = mrsIndex!ReptTemplate
    End If
    If Len(Dir$(mstrTemplates & lstrTemplate)) = 0 Then
        MsgBox "HTML Template does not exist", vbMsgBoxSetForeground, "TB Registry"
        GoTo Cleanup
    End If

'   Load it into the viewer
    CreateDataTables mstrTemplates & lstrTemplate
    fReports.web1.Navigate2 mstrTemplates & lstrTemplate
    
Cleanup:
End Sub

Public Sub CreateDataTables(pstrTemplate As String)
Dim lfh As Integer
Dim s As String
Dim i As Integer
Dim j As Integer
Dim lbolOpen As Boolean
Dim mintImages As Integer

    On Error GoTo ErrCreateDataTables
    lfh = FreeFile
    Open pstrTemplate For Input As #lfh     '   Read the template
    lbolOpen = True
    Do Until EOF(lfh)
        Line Input #lfh, s
        If mrsIndex!AltMode = "F" Then
            i = InStr(s, "doc.load")
            If i <> 0 Then
                s = Mid$(s, InStr(s, """") + 1)
                s = Left$(s, InStrRev(s, ".") - 1)
                i = InStrRev(s, "/")
                If i <> 0 Then s = Mid$(s, i + 1)
            Else
                s = ""
            End If
        Else
            i = InStr(s, "DataURL")             '   Look for the data file name
            If i <> 0 Then
                i = InStr(i, s, "VALUE=")       '   Strip out the table name
                If i <> 0 Then
                    j = InStr(i, s, ">")
                    If j <> 0 Then
                        s = Mid$(s, i, j - i)
                        i = InStrRev(s, ".")
                        j = InStrRev(s, "\")
                        If j = 0 Then j = InStrRev(s, "/")
                        s = Mid$(s, j + 1, i - j - 1)
                    Else
                        s = ""
                    End If
                Else
                    s = ""
                End If
            Else
                s = ""
            End If
        End If
        If Len(s) <> 0 Then
            For i = UBound(mstraSources) To 0 Step -1   '   Is there an existing source?
                If mstraSources(i) = s Then Exit For
            Next i
            If i < 0 Then
                If InvertTable(s) Then                  '   No, try to create it
                    i = UBound(mstraSources) + 1
                    ReDim Preserve mstraSources(i)
                    mstraSources(i) = s
                Else
                    msubOutcome = msubOutcome Or SubSpanIDNoReport      '   Failure
                    GoTo Cleanup1
                End If
            End If
        End If
    Loop
Cleanup1:
    Close #lfh
Cleanup2:
    Exit Sub
ErrCreateDataTables:
    Debug.Print Err.Number, Err.Description
    Debug.Assert False
    If lbolOpen Then
        Resume Cleanup1
    Else
        Resume Cleanup2
    End If
    Resume
End Sub


Private Function InvertTable(pstrSource As String) As Boolean
Dim lbolChecking As Boolean
Dim ltdSource As DAO.TableDef
Dim fd As DAO.Field
Dim s As String
Dim lrsTemplate As DAO.Recordset
Dim lrsData As DAO.Recordset
Dim lstrSQL As String
Dim lstrCalcSQL As String
Dim lbolMap As Boolean
Dim lbolGraph As Boolean
Dim lbolFacil As Boolean
Dim lstrDataSQL As String
Dim lstrLastVal As String
Dim lvarQtrs As Variant         '   Contains array of quarters for facility reports
Dim lintMinSource As Integer
Dim lintMaxSource As Integer
Dim lstrSource As String
Dim lrsXML() As DAO.Recordset
Dim lfh As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer

    On Error GoTo ErrInvertTable
    
    With mobjDB.DB
        If mrsIndex!AltMode = "F" Then
            lintMinSource = 1
            lintMaxSource = mrsIndex!AltCount
        Else
            lintMinSource = 0
            lintMaxSource = 0
            lstrSource = pstrSource
        End If
        For k = lintMinSource To lintMaxSource
            If k <> 0 Then lstrSource = pstrSource & Format$(k, "#")
            
            lbolChecking = True
            .TableDefs.Delete lstrSource            '   delete any old table
            lbolChecking = False
            lstrSQL = "SELECT * FROM " & TPLTTBL & " WHERE ReptID=""" & lstrSource & """" '   Get the fields
            Set lrsTemplate = .OpenRecordSet(lstrSQL, dbOpenSnapshot, dbReadOnly)
            If lrsTemplate.EOF Then         '   If no records
                lrsTemplate.Close
                GoTo Cleanup
            End If
            
            Set ltdSource = .CreateTableDef(lstrSource)     '   Create the new source table
            Set fd = ltdSource.CreateField("Row", dbText, 15)   '   Create the row field
            fd.Properties("AllowZeroLength") = False
            fd.Properties("Required") = False
            ltdSource.Fields.Append fd
            Select Case mrsIndex!AltMode           '   Add the RowEntity field if necessary
            Case "M"
                Set fd = ltdSource.CreateField("RowEntity", dbText, 255)
                fd.Properties("AllowZeroLength") = False
                fd.Properties("Required") = False
                ltdSource.Fields.Append fd
                lbolMap = True
            Case "G"
                lbolGraph = True
            Case "F"
                Set fd = ltdSource.CreateField("RowEntity", dbText, 255)
                fd.Properties("AllowZeroLength") = False
                fd.Properties("Required") = False
                ltdSource.Fields.Append fd
                lbolFacil = True
            Case Else
            End Select
            
            lstrSQL = ""        '   Accumulate the sum SQL
            lstrCalcSQL = ""    '   Accumulate the calculated SQL
            Do While Not lrsTemplate.EOF
                Select Case lrsTemplate!FldType
                Case "S"        '   String
                    Set fd = ltdSource.CreateField(lrsTemplate!cell, dbText, 255)
                    fd.Properties("AllowZeroLength") = True
                    fd.Properties("Required") = True
                    fd.Properties("DefaultValue") = ""
                    lstrSQL = lstrSQL & ","""" AS " & lrsTemplate!cell
                    ltdSource.Fields.Append fd
                Case "N"        '   Number (long)
                    Set fd = ltdSource.CreateField(lrsTemplate!cell, dbLong)
                    fd.Properties("Required") = True
                    fd.Properties("DefaultValue") = 0
                    If IsNull(lrsTemplate!formula) Then
                        lstrSQL = lstrSQL & ",SUM(A." & lrsTemplate!cell & ") AS " & lrsTemplate!cell
                    End If
                    ltdSource.Fields.Append fd
                Case "F"        '   Number (double)
                    Set fd = ltdSource.CreateField(lrsTemplate!cell, dbDouble)
                    fd.Properties("Required") = True
                    fd.Properties("DefaultValue") = 0
                    If IsNull(lrsTemplate!formula) Then
                        lstrSQL = lstrSQL & ",SUM(A." & lrsTemplate!cell & ") AS " & lrsTemplate!cell
                    End If
                    ltdSource.Fields.Append fd
                Case "D"        '   Date
                    Set fd = ltdSource.CreateField(lrsTemplate!cell, dbDate)
                    fd.Properties("Required") = False
                    ltdSource.Fields.Append fd
                Case Else
                End Select
                If Not IsNull(lrsTemplate!formula) Then
                    lstrCalcSQL = lstrCalcSQL & "," & lrsTemplate!cell & "=" & lrsTemplate!formula
                End If
                lrsTemplate.MoveNext
            Loop
            lrsTemplate.Close
            .TableDefs.Append ltdSource
            .TableDefs.Refresh
            
    '       Now select the the data
            lstrDataSQL = "SELECT * FROM " & DATATBL & " WHERE ReportName=""" & lstrSource _
            & """ And ReptLev = """ & mrsIndex!ReptLev & """ AND ReptYrQtr=""" & mrsIndex!reptyrqtr _
            & """" & mstrWhere & " ORDER BY Row"
            
            Set lrsData = .OpenRecordSet(lstrDataSQL, dbOpenSnapshot, dbReadOnly)
            If lrsData.EOF Then         '   If no records
                lrsData.Close
                GoTo Cleanup
            End If
            
    '       Add the data
            Set lrsTemplate = .OpenRecordSet("select * from " & lstrSource, dbOpenDynaset, dbDenyWrite)
            lstrLastVal = ""
            Do While Not lrsData.EOF
                If (lbolMap Or lbolGraph Or lbolFacil) And Not IsNull(lrsData!Row) Then        '   For map or graph, check for a control break
                    If (Len(lstrLastVal) = 0) Or (lstrLastVal <> lrsData!Row) Then
                        If Len(lstrLastVal) <> 0 Then
                            For i = lrsTemplate.Fields.Count - 1 To 0 Step -1
                                If lrsTemplate.Fields(i).Required And IsNull(lrsTemplate.Fields(i).Value) Then lrsTemplate.Fields(i).Value = lrsTemplate.Fields(i).defaultValue
                            Next i
                            lrsTemplate.Update
                        End If
                        lrsTemplate.AddNew
                        lrsTemplate!Row = lrsData!Row
                        lstrLastVal = lrsData!Row
                    End If
                ElseIf Len(lstrLastVal) = 0 Then
                    lrsTemplate.AddNew
                    lstrLastVal = "*"
                End If
                lbolChecking = True
                lrsTemplate(lrsData!cell) = lrsData!Count
'Debug.Print lrsData!cell, lrsData!Count
                lbolChecking = False
                lrsData.MoveNext
            Loop
            For i = lrsTemplate.Fields.Count - 1 To 0 Step -1
                If lrsTemplate.Fields(i).Required And IsNull(lrsTemplate.Fields(i).Value) Then lrsTemplate.Fields(i).Value = lrsTemplate.Fields(i).defaultValue
            Next i
            lrsTemplate.Update
            lrsTemplate.Close
            lrsData.Close
            
    '       Zero fill the table
            If lstrLastVal <> "*" Then
                If lbolMap Then
                    ZeroFill lstrSource, True
                ElseIf lbolGraph Then
                    ZeroFill lstrSource, False
                Else
                    lvarQtrs = ZeroFillFacility(lstrSource, mrsIndex!reptyrqtr)
                End If
            End If
            
    '       Add the entity names for maps and facility reports
            If lbolMap Or lbolFacil Then
                If lbolMap Then
                    lstrDataSQL = "UPDATE " & lstrSource & " AS A INNER JOIN " & ENTTBL & " AS B ON A.Row=B.Rept_Lev SET A.RowEntity=right(A.Row,3) &"" - "" &B.Entity_Name"
                Else
                    lstrDataSQL = "UPDATE " & lstrSource & " AS A INNER JOIN " & FACILTBL & " AS B ON LEFT(A.Row,6)=B.FacilityCode SET A.RowEntity=B.FacilityCode &"" - "" &B.FacilityName WHERE B.PredecesorCode=""" & mrsIndex!ReqReptLev & """"
                End If
                mobjDB.qd.SQL = lstrDataSQL
                mobjDB.qd.Execute
            End If
    
    '       Add the totals for facility reports
            If lbolFacil Then
                lstrSQL = "INSERT INTO " & lstrSource & " SELECT " & Mid$(lstrSQL, 2) & ",left(a.RowEntity,6) &""TOTALS"" AS Row,a.RowEntity FROM " & lstrSource & " AS A GROUP BY a.RowEntity"
                mobjDB.qd.SQL = lstrSQL
                mobjDB.qd.Execute
            End If
            
    '       Add the calculated fields
            If Len(lstrCalcSQL) <> 0 Then
                lstrCalcSQL = "UPDATE " & lstrSource & " SET " & Mid$(lstrCalcSQL, 2)
                mobjDB.qd.SQL = lstrCalcSQL
                mobjDB.qd.Execute
            End If
        Next k
    End With
    Set lrsTemplate = Nothing
        
'   Export the data
    If Not lbolFacil Then
        Set lrsTemplate = mobjDB.DB.OpenRecordSet("select * from " & pstrSource & " ORDER BY ROW", dbOpenSnapshot, dbReadOnly)
        lfh = FreeFile          '   Create the table
        Open mstrTemplates & pstrSource & ".txt" For Output As #lfh
        With lrsTemplate
            For i = .Fields.Count - 1 To 0 Step -1      '   Label line
                If i <> 0 Then
                    Print #lfh, """" & .Fields(i).Name & """" & vbTab;
                Else
                    Print #lfh, """" & .Fields(i).Name & """"
                End If
            Next i
            Do While Not .EOF
                For i = .Fields.Count - 1 To 0 Step -1      '   Data line
                    If i <> 0 Then
                        Print #lfh, .Fields(i).Value & vbTab;
                    Else
                        Print #lfh, .Fields(i).Value
                    End If
                Next i
                .MoveNext
            Loop
        End With
        Close #lfh
        lfh = 0
    Else        '   Facil report
        lfh = FreeFile          '   Create the table
        Open mstrTemplates & pstrSource & ".xml" For Output As #lfh
        Print #lfh, "<?xml version = ""1.0"" encoding=""iso-8859-1""?>"
        Print #lfh, "<HFR>"
        ReDim lrsXML(mrsIndex!AltCount - 1)
        For k = 1 To mrsIndex!AltCount
            Set lrsXML(k - 1) = mobjDB.DB.OpenRecordSet("SELECT * FROM " & pstrSource & k & " ORDER BY ROW", dbOpenSnapshot, dbReadOnly)
        Next k
        Do
            Print #lfh, "<FACILITY>"
            Print #lfh, "  <" & lrsXML(0).Fields(1).Name & ">" & lrsXML(0).Fields(1).Value & "</" & lrsXML(0).Fields(1).Name & ">"   '   RowEntity
'Debug.Print lrsXML(0).Fields(1).Name, lrsXML(0).Fields(1).Value
            For j = 1 To 5
                For k = 0 To mrsIndex!AltCount - 1
                    With lrsXML(k)
                        For i = .Fields.Count - 1 To 2 Step -1      '   Data fields
                            Print #lfh, "  <" & .Fields(i).Name & j & ">" & .Fields(i).Value & "</" & .Fields(i).Name & j & ">"
                        Next i
                        .MoveNext
                    End With
                Next k
            Next j
            For j = 1 To 4
                Print #lfh, "  <Qtr" & j & ">" & Replace$(lvarQtrs(j), "/", "&#47;") & "</Qtr" & j & ">"
            Next j
            With mrsIndex
                For i = .Fields.Count - 1 To 0 Step -1      '   params/repttypes fields
                    Print #lfh, "  <" & .Fields(i).Name & ">" & .Fields(i).Value & "</" & .Fields(i).Name & ">"
                Next i
            End With
            Print #lfh, "</FACILITY>"
        Loop Until lrsXML(0).EOF
        Print #lfh, "</HFR>"
        For k = 1 To mrsIndex!AltCount
            lrsXML(k - 1).Close
        Next k
        Close #lfh
        lfh = 0
    End If
        
    InvertTable = True
        
Cleanup:
    On Error Resume Next
    If lfh <> 0 Then Close #lfh
    For k = 1 To mrsIndex!AltCount
        Set lrsXML(k - 1) = Nothing
    Next k
    Erase lrsXML
    Set lrsTemplate = Nothing
    Set lrsData = Nothing
    Set ltdSource = Nothing
    Exit Function
ErrInvertTable:
    If lbolChecking Then
        lbolChecking = False
        Resume Next
    End If
    Debug.Print Err.Number, Err.Description
    Debug.Assert False
    msubOutcome = msubOutcome Or SubCatastrophic
    Resume Cleanup
    Resume
End Function


''Public Sub GenListing()
''Const RGINTBL1 = "PatientList"
''Const RGINTBL2 = "DataCheck"
''Const GETDENOM = "TBPLDen1"
''Dim lbolChecking As Boolean
''Dim i As Integer
''Dim j As Integer
''Dim s As String
''Dim fh As Integer
''Dim lstrLine As String
''Dim lstrDenom As String
''Dim ldatCatDate As Date
''Dim llngNumRecs As Long
''Dim llngNumSel As Long
''Dim lstrSQL As String
''Dim lrs As DAO.Recordset
''Dim lstrErrMsg As String
''
''    On Error GoTo ErrGenListing
'''    If mobjRepMan Is Nothing Then                   '   Initialization
'''        Set mobjRepMan = New EIREPMAN.EpiReportManager
'''    End If
''
''    lbolChecking = True                 '   Delete any existing table
''    mobjDB.DB.TableDefs.Delete IIf(mrsIndex!ReptType = "L", RGINTBL1, RGINTBL2)
''    lbolChecking = False
''
''    If (mrsIndex!ReptType = "L") Then   '   Get the denom number of records for lists
'''MsgBox "Generating the denominator", vbMsgBoxSetForeground, "GenListing"
''        With mobjDB.DB.QueryDefs(GETDENOM)
''            .Parameters.Refresh
''            .Parameters!RptLvl = mrsIndex(PARVARENT) & "*"
''            .Parameters!SelYrQtr = mrsIndex(PARVARDAT)
''            Set lrs = .OpenRecordSet(dbOpenSnapshot, dbReadOnly)
''            llngNumRecs = lrs(0)
''            lrs.Close
''            Set lrs = Nothing
''        End With
''    End If
''
'''   Create the temporary table
'''MsgBox "Creating the temporary table", vbMsgBoxSetForeground, "GenListing"
''    lstrSQL = mobjDB.DB.QueryDefs(mrsIndex!AltTemplate).SQL  '   Get the query
''    If (Len(mrsIndex!WhereClause) <> 0) Then           '   If it's a patient listing, get ready for the real query
''        i = InStr(lstrSQL, "ORDER BY")
''        If i = 0 Then
'''MsgBox "No ORDER BY clause", vbMsgBoxSetForeground, "GenListing"
''            GoTo Cleanup
''        End If
''        lstrSQL = Left$(lstrSQL, i - 1) & " AND (" & mrsIndex!WhereClause & ") " & Mid$(lstrSQL, i)
''    End If
''    With mobjDB.qd
''Clipboard.Clear
''Clipboard.SetText lstrSQL
''        .SQL = lstrSQL
''        .Parameters.Refresh
''        lbolChecking = True
''        .Parameters!RptLvl = mrsIndex(PARVARENT) & "*"
''        lbolChecking = True
''       .Parameters!SelYrQtr = mrsIndex(PARVARDAT)
''        lbolChecking = False
''        .Execute
''        llngNumSel = .RecordsAffected
''    End With
''    mobjDB.DB.TableDefs.Refresh
''    If llngNumSel = 0 Then
''        MsgBox "No records meet selection criteria", vbMsgBoxSetForeground, "TB Registry"
''        GoTo Cleanup
''    End If
''    With mrsIndex                               '   set the values for substitution
'''MsgBox "Updating the report parameters table", vbMsgBoxSetForeground, "GenListing"
''        .Edit
''        !NMatch = llngNumSel
''        If (mrsIndex!ReptType = "L") Then           '   if it's a patient listing
''            !NSearch = llngNumRecs
''            If llngNumRecs = 0 Then
''                !PMatch = ""
''            Else
''                !PMatch = Format$(llngNumSel / llngNumRecs * 100, "0")
''            End If
''        End If
''        .Update
''    End With
''
''    If Not ProcessEpiReport(mrsIndex!ReptTemplate) Then     '   Do the substitution
''        MsgBox "Cannot prepare report template", , "TB Registry"
''        GoTo Cleanup
''    End If
''
''    s = mrsIndex!ReptTemplate
''    mobjDB.DbClose                  '   Close the DB to avoid ADO/DAO issues
''    DoEvents
'''MsgBox "Creating the report manager object", vbMsgBoxSetForeground, "GenListing"
''    Set mobjRepMan = New EIREPMAN.EpiReportManager
''    With mobjRepMan                 '   Open the report in print preview
''        lstrErrMsg = "Open Template"
''        .OpenReportTemplate s
''        lstrErrMsg = "Preview Report"
''        .PreviewReportTemplate s
''        lstrErrMsg = "Wait for Preview"
''        .WaitForPreviewClose s, 0
''        lstrErrMsg = ""
''        .CloseReportTemplate s
''    End With
''
''Cleanup:
'''   Deal with the RepMan object
''    If Len(lstrErrMsg) <> 0 Then
''        MsgBox "Error in Report Generator: " & lstrErrMsg, vbMsgBoxSetForeground, "TB Registry"
''    End If
''    Set mobjRepMan = Nothing
'''   Reopen the DB if it got closed
''    On Error Resume Next
''    If Not mobjDB.flagDbOpen Then
''        If mobjDB.DbOpen(Left$(mstrTemplates, Len(mstrTemplates) - Len(TEMPLATES) - 1) & "Data\" & REPORTS) Then
''            s = "SELECT * from " & PARTBL & " as P INNER JOIN " & TYPETBL & " AS T ON P.ReptID=T.ReptCode"
''            Set mrsIndex = mobjDB.DB.OpenRecordSet(s, dbOpenDynaset)
''        End If
''    End If
''    Exit Sub
''ErrGenListing:
''    If lbolChecking Then
''        lbolChecking = False
''        Resume Next
''    End If
'''MsgBox "Error " & Err.Number & ": " & Err.Description, vbMsgBoxSetForeground, "GenListing"
''    Debug.Print Err.Number, Err.Description
''    Debug.Assert False
''    Resume Cleanup
''    Resume
''End Sub

Private Sub InitializeData()
Dim lfh As Integer
Dim i As Integer
Dim s As String
Dim lbolOpen As Boolean
Dim lstrImage As String
Dim lintImage As Integer
Dim lstrSuffix As String
    On Error GoTo ErrInitializeData
    msubOutcome = 0
    ReDim mstraSources(0)
    mstraSources(0) = "PARAMS"
    
    lfh = FreeFile          '   Create the params table
    Open mstrTemplates & "params.txt" For Output As #lfh
    lbolOpen = True
    With mrsIndex
        If Len(!FileLoc) <> 0 Then
            lstrImage = Mid$(!FileLoc, InStrRev(!FileLoc, "IMAGE") + 5)
            i = InStr(lstrImage, ".")
            If i <> 0 Then
                lstrSuffix = Mid$(lstrImage, i)
                lstrImage = Left$(lstrImage, i - 1)
            End If
            If IsNumeric(lstrImage) Then lintImage = Val(lstrImage)
        End If
        For i = .Fields.Count - 1 To 0 Step -1      '   Label line
            If i <> 0 Then
                Print #lfh, """" & .Fields(i).Name & """" & vbTab;
            ElseIf !AltCount = 0 Then
                Print #lfh, """" & .Fields(i).Name & """"
            Else
                Print #lfh, """" & .Fields(i).Name & """" & vbTab;
            End If
        Next i
        For i = 1 To !AltCount              '   Labels for images
            If i <> !AltCount Then
                Print #lfh, """IMAGE" & i & """" & vbTab;
            Else
                Print #lfh, """IMAGE" & i & """"
            End If
        Next i
        For i = .Fields.Count - 1 To 0 Step -1      '   Data line
            If i <> 0 Then
                Print #lfh, .Fields(i).Value & vbTab;
            ElseIf !AltCount = 0 Then
                Print #lfh, .Fields(i).Value
            Else
                Print #lfh, .Fields(i).Value & vbTab;
            End If
        Next i
        If lintImage <> 0 Then
            s = Left$(mstrTemplates, InStrRev(mstrTemplates, "\", Len(mstrTemplates) - 1)) & "IMAGES\IMAGE"
            For i = 1 To !AltCount              '   Image files
                If i <> !AltCount Then
                    Print #lfh, s & lintImage & lstrSuffix & vbTab;
                Else
                    Print #lfh, s & lintImage & lstrSuffix
                End If
                lintImage = lintImage + 1
            Next i
        Else
            For i = 1 To !AltCount              '   Image files
                If i <> !AltCount Then
                    Print #lfh, vbTab;
                Else
                    Print #lfh,
                End If
            Next i
        End If
    End With
Cleanup1:
    Close #lfh
Cleanup2:
    Exit Sub
ErrInitializeData:
    Debug.Print Err.Number, Err.Description
    Debug.Assert False
    If lbolOpen Then
        Resume Cleanup1
    Else
        Resume Cleanup2
    End If
    Resume
End Sub

'Public Sub Finalize()
'    Set mobjRepMan = Nothing
'End Sub

'--------------------------------------------------------
'mRptGen.bas : ProcessRTFFile
'Description: Substitutes in RTF file
'Arguments: pstrFile - RTF file path
'Return: True for success, false for error
'Side Effects: Existing file is renamed .bak, new substituted file is .rtf
'--------------------------------------------------------
'Private Function ProcessRTFFile(pstrFile As String) As Boolean
'Const INSTTAG = "\fldinst"
'Const RSLTTAG = "\fldrslt"
'Dim lbolChecking As Boolean
'Dim i As Integer
'Dim j As Integer
'Dim s As String
'Dim fhin As Integer
'Dim fhout As Integer
'Dim lstrSub As String
'
'    On Error GoTo ErrProcessRTFFile
'
''   Name the backup file, kill it if it exists, and open the two files
'    s = Left$(pstrFile, Len(pstrFile) - 3) & "bak"
'    lbolChecking = True
'    Kill s
'    Name pstrFile As s
'    fhin = FreeFile
'    Open s For Input As #fhin
'    fhout = FreeFile
'    Open pstrFile For Output As #fhout
'
''   Step through the file, performing substitutions as necessary
'    Do While Not EOF(fhin)
'        Line Input #fhin, s
'        i = InStr(s, INSTTAG)
'        Do While i <> 0             '   For each field instance tag
'            j = InStr(i, s, "}")    '   Find the end of the tag
'            If j = 0 Then
'                j = Len(s)          '   Unterminated tag
'            Else
'                lstrSub = Trim$(Mid$(s, i + Len(INSTTAG) + 2, j - i - Len(INSTTAG) - 3)) '   Get the field name
'                lstrSub = IIf(IsNull(mrsIndex(lstrSub)), "", mrsIndex(lstrSub))       '   Get its value
'                i = InStr(j + 1, s, RSLTTAG)    '   Find the instance tag
'                If i = 0 Then
'                    j = Len(s)      '   Instance tag without result tag
'                Else
'                    j = InStr(i, s, "}") '   Find end of result tag
'                    If j = 0 Then
'                        j = Len(s)      '   Unterminated tag
'                    Else
'                        s = Left$(s, i + Len(RSLTTAG) + 1) & lstrSub & Mid$(s, j)
''                        Mid$(s, i + Len(RSLTTAG) + 2, j - i - Len(RSLTTAG) - 2) = lstrSub
'                        j = InStr(i, s, "}") '   Find new end of result tag
'                    End If
'                End If
'            End If
'            i = InStr(j + 1, s, INSTTAG)    '   On to the next tag
'        Loop
'        Print #fhout, s
'    Loop
'    Close #fhin
'    Close #fhout
'    ProcessRTFFile = True
'
'Cleanup:
'    Exit Function
'
'ErrProcessRTFFile:
'    If lbolChecking Then
'        lbolChecking = False
'        Resume Next
'    End If
'    Debug.Print Err.Number, Err.Description
'    Debug.Assert False
'    Resume Cleanup
'    Resume
'End Function
'
''--------------------------------------------------------
''mRptGen.bas : ProcessEpiReport
''Description: Does one-time setup of report template if necessary, does substitutions in rtf files
''Arguments: pstrEpiReport - name of the epireport (just the name, no path or suffix)
''Return: True for success, false for error
''Side Effects: Rewrites report template if necessary, creates dir in etr\reports to show it's done
''--------------------------------------------------------
'Private Function ProcessEpiReport(pstrEpiReport As String) As Boolean
'Dim lbolChecking As Boolean
'Dim i As Integer
'Dim j As Integer
'Dim s As String
'Dim fh As Integer
'Dim lstrHold As String
'Dim lstrPath As String
'Dim lstrFile As String
'Dim lbolPhase2 As Boolean
'
'    On Error GoTo ErrProcessEpiReport
'    lstrPath = mstrReportTemplates & pstrEpiReport & "\"            '   Get oriented
'    lstrFile = lstrPath & pstrEpiReport & ".ept"
'    s = Left$(mstrTemplates, InStrRev(mstrTemplates, "\", Len(mstrTemplates) - 1)) & pstrEpiReport
'    If Len(Dir$(s, vbDirectory)) = 0 Then '   Do we have to do the one-time stuff?
'        If Len(Dir$(lstrPath, vbDirectory)) = 0 Then GoTo Cleanup        '   Directory doesn't exist
'        If Len(Dir$(lstrFile)) = 0 Then GoTo Cleanup '   Template doesn't exist
'        fh = FreeFile
'        Open lstrFile For Input As #fh       '   read up to the filename element
'        Do While Not EOF(fh)
'            Line Input #fh, s
'Debug.Print s
'            If Not lbolPhase2 Then
'                i = InStr(s, "filename=")
'                If i <> 0 Then
'                    i = i + 10                          '   expect to find filename="file"
'                    If InStr(i, s, lstrFile) <> i Then  '   pointing to another file
'                        j = InStr(i, s, """")           '   find the end of the filename tag
'                        If j = 0 Then
'                            Close #fh
'                            GoTo Cleanup
'                        End If
'                        Mid$(s, i, j - i - 1) = lstrFile  '   insert the right filename
'                    End If
'                    lbolPhase2 = True
'                End If
'            End If
'            s = Replace(s, "@@ETR_Path", mstrETRPath)   '   replace any path references
'            lstrHold = lstrHold & IIf(Len(lstrHold) = 0, "", vbCrLf) & s
'        Loop
'        Close #fh
'        Kill lstrFile                       '   replace the existing version
'        Open lstrFile For Output As #fh
'        Print #fh, lstrHold
'        Close #fh
'        s = Left$(mstrTemplates, InStrRev(mstrTemplates, "\", Len(mstrTemplates) - 1)) & pstrEpiReport
'        MkDir s     '   indicate replacement is done
'    End If
'
'    s = Dir$(lstrPath & "*.rtf")                     '   Process all the RTFs
'    Do While Len(s) <> 0
'        If Not ProcessRTFFile(lstrPath & s) Then Exit Do
'        s = Dir$()
'    Loop
'
'    ProcessEpiReport = (Len(s) = 0)
'
'Cleanup:
'    Exit Function
'
'ErrProcessEpiReport:
'    If lbolChecking Then
'        lbolChecking = False
'        Resume Next
'    End If
'    Debug.Print Err.Number, Err.Description
'    Debug.Assert False
'    Resume Cleanup
'    Resume
'End Function
'
'Public Function testrtf(pstrFile As String) As Boolean
'    testrtf = ProcessRTFFile(pstrFile)
'End Function

Private Function ZeroFill(pstrTable As String, pbolMap As Boolean) As Boolean
Const YQTABLE = "TBMakeYQ"
Const QRYNAME24 = "TBMakeLev"
Const QRYSQL24 = "PARAMETERS RptLvl Text; " _
    & "SELECT A.Rept_lev,A.Entity_name FROM [RStTbl] as A, [RStTbl] as B " _
    & "WHERE A.Rept_Lev LIKE [RptLvl] &""*"" AND B.Rept_Lev LIKE A.Rept_Lev &""*"" " _
    & "GROUP BY A.Rept_lev,A.Entity_name HAVING Count(*)=1"
Dim lbolChecking As Boolean
Dim i As Integer
Dim j As Integer
Dim s As String
Dim lstrSQL As String
Dim lstrTblB As String
Dim lrs As DAO.Recordset
Dim lstraRows() As String

    On Error GoTo ErrZeroFill
    If pbolMap Then           '   If it's a map
        lbolChecking = True
        s = mobjDB.DB.QueryDefs(QRYNAME24).Name
        If lbolChecking Then
            lbolChecking = False
        Else
            With mobjDB.DB
                .QueryDefs.Append .CreateQueryDef(QRYNAME24, Replace$(QRYSQL24, "RStTbl", ENTTBL))
                .QueryDefs.Refresh
            End With
        End If
        With mobjDB.DB.QueryDefs(QRYNAME24).Parameters
            .Refresh
            !RptLvl = mrsIndex!ReptLev
        End With
        lstrTblB = QRYNAME24        '   Data will come from TBMakeLev query
    Else
        lbolChecking = True             '   See if the YQ table exists
        s = "SELECT Max(YrQtr) FROM " & YQTABLE
        Set lrs = mobjDB.DB.OpenRecordSet(s, dbOpenSnapshot, dbReadOnly)
        If lbolChecking Then
            If Left$(lrs(0), 4) <> Left$(mrsIndex!reptyrqtr, 4) Then '   Yes, is it current?
                mobjDB.qd.SQL = "DELETE * FROM " & YQTABLE      '   No, prepare to clear it
                lbolChecking = False
            End If
            lrs.Close
            Set lrs = Nothing
        Else
            mobjDB.qd.SQL = "CREATE TABLE " & YQTABLE & " (YrQtr Text(6))"  '   Doesn't exist, prepare to create it
        End If
        If Not lbolChecking Then
            mobjDB.qd.Execute           '   Create the table or delete the records
            mobjDB.DB.TableDefs.Refresh
            For i = 2 To 0 Step -1      '   Insert new records
                s = "INSERT INTO " & YQTABLE & " VALUES(""" & Format$(Val(Left$(mrsIndex!reptyrqtr, 4)) - i) & "/0"")"
                For j = 1 To 4
                    Mid$(s, Len(s) - 2, 1) = Chr$(48 + j)
                    mobjDB.qd.SQL = s
                    mobjDB.qd.Execute
                Next j
            Next i
        Else
            lbolChecking = False
        End If
        lstrTblB = YQTABLE          '   Data will come from YQ table
        i = 1                       '   First field is 1
    End If
    
    lstrSQL = "SELECT C." & IIf(pbolMap, "Rept_Lev", "YrQtr") & " FROM " _
      & lstrTblB & " AS C LEFT JOIN " & pstrTable & " AS D ON C." & IIf(pbolMap, "Rept_Lev", "YrQtr") & "=D.Row WHERE D.Row IS NULL"
    mobjDB.qd.SQL = lstrSQL
    If pbolMap Then
        With mobjDB.qd.Parameters
            .Refresh
            !RptLvl = mrsIndex!ReptLev
        End With
    End If
    Set lrs = mobjDB.qd.OpenRecordSet(dbOpenSnapshot, dbReadOnly)                        '   Make the temp table
    ReDim lstraRows(0)
    Do While Not lrs.EOF
        If Len(lstraRows(0)) <> 0 Then ReDim Preserve lstraRows(UBound(lstraRows) + 1)
        lstraRows(UBound(lstraRows)) = lrs(0)
        lrs.MoveNext
    Loop
    lrs.Close
    If Len(lstraRows(0)) <> 0 Then                          '   If there are rows to be added
        Set lrs = mobjDB.DB.OpenRecordSet(pstrTable, dbOpenDynaset, dbDenyWrite)
        For i = 0 To UBound(lstraRows)
            lrs.AddNew
            For j = lrs.Fields.Count - 1 To 0 Step -1
                If lrs.Fields(j).Name = "Row" Then
                    lrs.Fields(j) = lstraRows(i)
                ElseIf lrs.Fields(j).Required Then
                    lrs.Fields(j) = lrs.Fields(j).defaultValue
                End If
            Next j
            lrs.Update
        Next i
        lrs.Close
    End If
    
    ZeroFill = True
    
ExitZeroFill:
    Exit Function

ErrZeroFill:
    Debug.Print Err.Number, Err.Description
    Debug.Assert False
    If lbolChecking Then
        lbolChecking = False
        Resume Next
    Else
        Resume ExitZeroFill
    End If
End Function

Private Function ZeroFillFacility(pstrSource As String, pstrYrQtr As String) As Variant
Dim s As String
Dim i As Integer
Dim j As Integer
Dim v As Variant
Dim lintQtr As Integer
Dim lintYear As Integer
Dim lbolChecking As Boolean
Dim lstraRows() As String
Const FACYQTABLE = "FacYQ"
Dim lrs As DAO.Recordset

    On Error GoTo ErrZeroFillFacility
    lintQtr = Asc(Right$(pstrYrQtr, 1)) - 48    '   Separate the year and quarter
    If lintQtr < 0 Then lintQtr = 4
    lintYear = Val(Left$(pstrYrQtr, 4))
    s = ";TOTALS"
    For i = 1 To 4                              '   Make the quarters in the report
        s = ";" & lintYear & "/" & lintQtr & s
        lintQtr = lintQtr - 1
        If lintQtr = 0 Then
            lintQtr = 4
            lintYear = lintYear - 1
        End If
    Next i
    v = Split(s, ";")
    ZeroFillFacility = v

    lbolChecking = True             '   See if the YQ table exists
    s = "SELECT Max(Row) FROM " & FACYQTABLE
    Set lrs = mobjDB.DB.OpenRecordSet(s, dbOpenSnapshot, dbReadOnly)
    If lbolChecking Then
        mobjDB.qd.SQL = "DELETE * FROM " & FACYQTABLE      '   No, prepare to clear it
        lbolChecking = False
        lrs.Close
        Set lrs = Nothing
    Else
        mobjDB.qd.SQL = "CREATE TABLE " & FACYQTABLE & " (Row Text(15))"  '   Doesn't exist, prepare to create it
    End If
    mobjDB.qd.Execute           '   Create the table or delete the records
    mobjDB.DB.TableDefs.Refresh
    
'   Insert Rows
    s = "PARAMETERS FacQtr Text(16);INSERT INTO " & FACYQTABLE & " VALUES([FacQtr])"
    mobjDB.qd.SQL = s
    mobjDB.qd.Parameters.Refresh
    For j = 0 To UBound(mstraFacs)
        For i = 1 To 4
            mobjDB.qd.Parameters(0) = mstraFacs(j) & v(i)
            mobjDB.qd.Execute
        Next i
    Next j
    
    s = "SELECT C.Row FROM " & FACYQTABLE & " AS C LEFT JOIN " & pstrSource & " AS D ON C.Row=D.Row WHERE D.Row IS NULL"
    Set lrs = mobjDB.DB.OpenRecordSet(s, dbOpenSnapshot, dbReadOnly)                       '   Make the temp table
    ReDim lstraRows(0)
    Do While Not lrs.EOF
        If Len(lstraRows(0)) <> 0 Then ReDim Preserve lstraRows(UBound(lstraRows) + 1)
        lstraRows(UBound(lstraRows)) = lrs(0)
        lrs.MoveNext
    Loop
    lrs.Close
    If Len(lstraRows(0)) <> 0 Then                          '   If there are rows to be added
        Set lrs = mobjDB.DB.OpenRecordSet(pstrSource, dbOpenDynaset, dbDenyWrite)
        For i = 0 To UBound(lstraRows)
            lrs.AddNew
            For j = lrs.Fields.Count - 1 To 0 Step -1
                If lrs.Fields(j).Name = "Row" Then
                    lrs.Fields(j) = lstraRows(i)
                ElseIf lrs.Fields(j).Required Then
                    lrs.Fields(j) = lrs.Fields(j).defaultValue
                End If
            Next j
            lrs.Update
        Next i
        lrs.Close
    End If
Cleanup:
    Set lrs = Nothing
    Exit Function
ErrZeroFillFacility:
    If lbolChecking Then
        lbolChecking = False
        Resume Next
    End If
    Debug.Print Err.Number, Err.Description
    Debug.Assert False
    Resume Cleanup
    Resume
End Function