mdldatabase5.bas

本系统可用于医院和专业体检中心的健康体检管理

    
    strExport = strExport & vbCrLf _
            & "其它类" & vbCrLf & vbCrLf
    
    '其它
    strExport = strExport & GetFixedString("姓名", lngLength) & vbTab & gtypTemplateID.name & vbCrLf _
            & GetFixedString("性别", lngLength) & vbTab & gtypTemplateID.SEX & vbCrLf _
            & GetFixedString("年龄", lngLength) & vbTab & gtypTemplateID.AGE & vbCrLf _
            & GetFixedString("体检日期", lngLength) & vbTab & gtypTemplateID.TJRQ & vbCrLf _
            & GetFixedString("打印日期", lngLength) & vbTab & gtypTemplateID.DYRQ & vbCrLf _
            & GetFixedString("总检结论", lngLength) & vbTab & gtypTemplateID.ZJJL & vbCrLf _
            & GetFixedString("总检建议", lngLength) & vbTab & gtypTemplateID.ZJJY & vbCrLf _
            & GetFixedString("档案号", lngLength) & vbTab & gtypTemplateID.HEALTHID & vbCrLf _
            & GetFixedString("查询码", lngLength) & vbTab & gtypTemplateID.CXM & vbCrLf _
            & GetFixedString("体检套餐名称", lngLength) & vbTab & gtypTemplateID.TCMC & vbCrLf _
            & GetFixedString("单位名称", lngLength) & vbTab & gtypTemplateID.DWMC & vbCrLf _
            & GetFixedString("联系地址", lngLength) & vbTab & gtypTemplateID.LXDZ & vbCrLf _
            & GetFixedString("家庭电话", lngLength) & vbTab & gtypTemplateID.JTDH & vbCrLf _
            & GetFixedString("办公电话", lngLength) & vbTab & gtypTemplateID.BGDH & vbCrLf _
            & GetFixedString("移动电话", lngLength) & vbTab & gtypTemplateID.YDDH & vbCrLf _
            & GetFixedString("自定义档案号", lngLength) & vbTab & gtypTemplateID.SELFID & vbCrLf _
            & GetFixedString("体检异常结论", lngLength) & vbTab & gtypTemplateID.TJYC & vbCrLf _
            & GetFixedString("体检分组名称", lngLength) & vbTab & gtypTemplateID.FZMC & vbCrLf _
            
    '检索是否有自定义建议
    strSQL = "select JYMC from SET_JY_INDEX" _
            & " where not (JYMC is null)" _
            & " order by JYSXH"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If Not rstemp.EOF Then
        For i = 1 To rstemp.RecordCount
            Select Case i
                Case 1
                    strExport = strExport & GetFixedString(rstemp("JYMC"), lngLength) & vbTab & gtypTemplateID.SELF_JY_1 & vbCrLf
                Case 2
                    strExport = strExport & GetFixedString(rstemp("JYMC"), lngLength) & vbTab & gtypTemplateID.SELF_JY_2 & vbCrLf
                Case 3
                    strExport = strExport & GetFixedString(rstemp("JYMC"), lngLength) & vbTab & gtypTemplateID.SELF_JY_3 & vbCrLf
                Case 4
                    strExport = strExport & GetFixedString(rstemp("JYMC"), lngLength) & vbTab & gtypTemplateID.SELF_JY_4 & vbCrLf
                Case 5
                    strExport = strExport & GetFixedString(rstemp("JYMC"), lngLength) & vbTab & gtypTemplateID.SELF_JY_5 & vbCrLf
                Case Else
                    '
            End Select
            
            rstemp.MoveNext
        Next
        rstemp.Close
    End If
    
    If gblnIsSpy Then
        strExport = strExport & GetFixedString("健康状况", lngLength) & vbTab & gtypTemplateID.HEALTH_STATUS & vbCrLf _
                & GetFixedString("健康结论", lngLength) & vbTab & gtypTemplateID.HEALTH_RESULT & vbCrLf _
                & GetFixedString("健康建议", lngLength) & vbTab & gtypTemplateID.HEALTH_SUGGESTION & vbCrLf
    End If
    
    '总检医生
    strExport = strExport & GetFixedString("总检医生", lngLength) & vbTab & gtypTemplateID.DOCTOR_ZONGJIAN & vbCrLf
    
    DoEvents
    
    strExport = strExport & vbCrLf _
            & "团体类" & vbCrLf & vbCrLf
    
    '团体类
    strExport = strExport & GetFixedString("健康问题列表", lngLength) & vbTab & gtypTuanti.PROBLEM & vbCrLf _
            & GetFixedString("各年龄段的体检人数（图）", lngLength) & vbTab & gtypTuanti.AGEGROUP & vbCrLf _
            & GetFixedString("各科室异常体征（图）", lngLength) & vbTab & gtypTuanti.KESHIYICHANG & vbCrLf _
            & GetFixedString("排列前十位的异常体征（图）", lngLength) & vbTab & gtypTuanti.FRONTTENYICHANG & vbCrLf _
            & GetFixedString("所有异常指征及人员名单（表格）", lngLength) & vbTab & gtypTuanti.UnnormalTitleAndPersonInTable & vbCrLf _
            & GetFixedString("所有异常指征不含人员名单", lngLength) & vbTab & gtypTuanti.UnnormalTitleNoPerson & vbCrLf _
            & GetFixedString("所有异常指征、人员名单，以及相应健康建议", lngLength) & vbTab & gtypTuanti.UnnormalTitleAandPersonWithSuggest & vbCrLf
    If gblnIsSpy Then
        strExport = strExport & GetFixedString("健康状况分析（不含级别）", lngLength) & vbTab & gtypTuanti.HEALTH_STATUS & vbCrLf _
                & GetFixedString("健康状况分析（含级别）", lngLength) & vbTab & gtypTuanti.HEALTH_STATUS_GRADE
    End If
    Call WriteTextFile(strFileName, strExport)
    
    Shell "notepad.exe " & strFileName, vbNormalFocus
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, "MDIForm1.SetBackground")
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

'设置模板格式
Public Sub SetReportHeader()
    With gtypHeader
        .KESHI = "K"
        .KESHIYICHANG = "C"
        .DAXIANG = "D"
        .XIAOXIANG = "X"
        .DOCTOR = "Y"
        .DOCTORSIGN = "S" '医生签名
        .DOCTOR_KESHI = "I"
        .DOCTOR_SIGN_KESHI = "L"
        .RESULT = "J"
        .SRESULT = "W" '上次体检结果
        .OTHER = "Q"
        .TUANTI = "T"
        .KSXJ = "R"
        .ZJJL = "A"
        .ZJJY = "B"
        .PICTURE = "P"
        .BOOKMARK_NAME = "N"
        .BOOKMARK_SEX = "E"
        .BOOKMARK_AGE = "G"
        .BOOKMARK_XM = "X"
        .BOOKMARK_SELECTION = "F"
        .BOOKMARK_BM = "B"
        .BOOKMARK_JG = "J"
        .BOOKMARK_XX = "C"
        .BOOKMARK_XB = "M"
        .BOOKMARK_ZYSX = "Z"
        .BOOKMARK_TotalPrice = "T"
        .BOOKMARK_KSMC = "H"
    End With
    
    With gtypTemplateID
        .name = "1"
        .SEX = "2"
        .AGE = "3"
        .TJRQ = "4"
        .DYRQ = "5"
        .ZJJL = "6"
        .ZJJY = "7"
        .HEALTHID = "8"
        .CXM = "9"
        .TCMC = "10"
        .DWMC = "11"
        .LXDZ = "12"
        .JTDH = "13"
        .BGDH = "14"
        .YDDH = "15"
        .TJYC = "16"
        .SELFID = "17"
        .SELF_JY_1 = "18"
        .SELF_JY_2 = "19"
        .SELF_JY_3 = "20"
        .SELF_JY_4 = "21"
        .SELF_JY_5 = "22"
        .HEALTH_STATUS = "23"
        .HEALTH_RESULT = "24"
        .HEALTH_SUGGESTION = "25"
        .DOCTOR_ZONGJIAN = "30"
        .DOCTOR_SIGN_ZONGJIAN = "31"
        '***************20050524加入 闻*********************
        .FZMC = "32"
        '***************20050524加入完 闻*********************
    End With
    
    With gtypTuanti
        .PROBLEM = "1"
        .AGEGROUP = "2"
        .KESHIYICHANG = "3"
        .FRONTTENYICHANG = "4"
        .UnnormalTitleAndPersonInTable = "5"
        .UnnormalTitleNoPerson = "6"
        .UnnormalTitleAandPersonWithSuggest = "7"
        .HEALTH_STATUS = "8"
        .HEALTH_STATUS_GRADE = "9"
    End With
End Sub

'数据字典导出
Public Sub ExportDictionary(ByRef dlgCommonDialog As CommonDialog)
On Error GoTo ErrMsg
    Dim fsoOut As New Scripting.FileSystemObject
    Dim TxtStream As Scripting.TextStream
    Dim strOutFileName As String
    Dim i, j, K As Integer
    Dim strSQL As String
    Dim strTempResult As String
    
    Dim rsKS As ADODB.Recordset
    Dim rsXX As ADODB.Recordset
    Dim rsDic As ADODB.Recordset
    Dim rsModel As ADODB.Recordset
    Dim strDic As String
    Dim strModel As String
    
    Screen.MousePointer = vbHourglass
    
    strOutFileName = GetFileName(dlgCommonDialog, "文本文件(*.txt)|*.txt", _
            "另存为", "BTTJ_数据字典导出文件.txt", WRITEFILE)
    If strOutFileName = "" Then GoTo ExitLab
    
    If MsgBox("确实要导出数据字典到文件“" & strOutFileName & "吗？", _
            vbQuestion + vbYesNo + vbDefaultButton1, "询问") = vbNo Then
        GoTo ExitLab
    End If
    
    Set TxtStream = fsoOut.CreateTextFile(strOutFileName, True, True)
    '执行导出操作
    TxtStream.WriteLine Space(30) & "数据字典导出结果"
    TxtStream.WriteLine
    
    strSQL = "select KSID,KSMC from SET_KSSZ order by SXH"
    Set rsKS = New ADODB.Recordset
    rsKS.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If Not rsKS.EOF Then
        rsKS.MoveFirst
        Do
            '科室
            TxtStream.WriteLine "****************" & rsKS("KSMC") & "****************"
            
            '提取当前科室下的小项
            strSQL = "SELECT XXID,XXMC FROM SET_XX" _
                    & " where KSID='" & rsKS("KSID") & "'" _
                    & " order by SXH"
            Set rsXX = New ADODB.Recordset
            rsXX.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
            If Not rsXX.EOF Then
                Do
                    TxtStream.WriteLine "***项目名称(" & rsXX("xXMC") & ")***"
                    
                    strDic = ""
                    strModel = ""
                    '提取该小项的数据字典
                    strSQL = "select DMValue from DM_Dictionary" _
                            & " where XMID='" & rsXX("XXID") & "'" _
                            & " order by SXH"
                    Set rsDic = New ADODB.Recordset
                    rsDic.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
                    If Not rsDic.EOF Then
                        Do
                            strDic = strDic & "，" & rsDic("DMValue")
                            
                            rsDic.MoveNext
                        Loop Until rsDic.EOF
                        strDic = Mid(strDic, 2)
                        '写入文件
                        Call TxtStream.WriteLine("数据字典：")
                        Call TxtStream.WriteLine(strDic)
                        
                        
                        rsDic.Close
                    End If
                    
                    '提取该小项下的数据模板
                    strSQL = "select DMValue from DM_Model" _
                            & " where XMID='" & rsXX("XXID") & "'" _
                            & " order by SXH"
                    Set rsModel = New ADODB.Recordset
                    rsModel.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
                    If Not rsModel.EOF Then
                        Do
                            strModel = strModel & "，" & rsModel("DMValue")
                            
                            rsModel.MoveNext
                        Loop Until rsModel.EOF
                        strModel = Mid(strModel, 2)
                        '写入文件
                        Call TxtStream.WriteLine("数据模板：")
                        Call TxtStream.WriteLine(strModel)
                        
                        rsModel.Close
                    End If
                    
                    rsXX.MoveNext
                Loop Until rsXX.EOF
                rsXX.Close
            End If
            
            TxtStream.WriteLine
            TxtStream.WriteLine
            
            rsKS.MoveNext
        Loop Until rsKS.EOF
    End If
    
    TxtStream.Close
    Set TxtStream = Nothing
    Set fsoOut = Nothing
    MsgBox "已保存完毕", vbInformation, "成功"
         
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

'体检建议导出
Public Sub ExportSuggestion(ByRef dlgCommonDialog As CommonDialog, _
        Optional ByVal strZDJL As String = "")
On Error GoTo ErrMsg
    Dim fsoOut As New Scripting.FileSystemObject
    Dim TxtStream As Scripting.TextStream
    Dim strOutFileName As String
    Dim i, j, K As Integer
    Dim strSQL As String
    Dim strTempResult As String
    Dim strXMMC As String
    
    Dim rsJY As ADODB.Recordset
    Dim rstemp As ADODB.Recordset
    Dim rsKS As ADODB.Recordset
    
    strOutFileName = GetFileName(dlgCommonDialog, "文本文件(*.txt)|*.txt", "另存为", _
            "BTTJ_体检建议导出文件.txt", WRITEFILE)
    If strOutFileName = "" Then GoTo ExitLab
    
    If MsgBox("确实要导出体检建议到文件“" & strOutFileName & "吗？", _
            vbQuestion + vbYesNo + vbDefaultButton1, "询问") = vbNo Then
        GoTo ExitLab
    End If
    
    If strZDJL = "" Then
        strZDJL = "DMValue"
    End If
    
    Set TxtStream = fsoOut.CreateTextFile(strOutFileName, True, True)
    '执行导出操作
    TxtStream.WriteLine Space(30) & "体检建议导出结果"
    TxtStream.WriteLine
    
    strSQL = "select KSID,KSMC from SET_KSSZ order by SXH"
    Set rsKS = New ADODB.Recordset
    rsKS.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rsKS.RecordCount > 0 Then
        rsKS.MoveFirst
        Do While Not rsKS.EOF
            TxtStream.WriteLine "********* " & rsKS("KSMC") & " 体检建议导出结果 *********"
            strSQL = "select " & strZDJL & ",JYNR from DM_ZJJY" _
                    & " where KSID='" & rsKS("KSID") & "'" _
                    & " order by " & strZDJL
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            If rstemp.RecordCount > 0 Then
                rstemp.MoveFirst
                Do While Not rstemp.EOF
                    TxtStream.WriteLine rstemp(strZDJL) & "："
                    TxtStream.WriteLine rstemp("JYNR") & ""
                    TxtStream.WriteLine
                    rstemp.MoveNext
                Loop
            End If
            rsKS.MoveNext
            TxtStream.WriteLine
            TxtStream.WriteLine
        Loop
    End If
    
    TxtStream.Close
    Set TxtStream = Nothing
    Set fsoOut = Nothing
    MsgBox "已保存完毕", vbInformation, "成功"
         
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err
ExitLab:
    Screen.MousePointer = vbDefault
End Sub