frmdataexport.frm

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

        rstemp.Close
    End If
    Set rstemp = Nothing
    
    ExportDX = True
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    '
End Function

'导出所有小项
Private Function ExportXX() As Boolean
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    
    '提取所有小项
    strSQL = "select * from SET_XX"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If Not rstemp.EOF Then
        Do While Not rstemp.EOF
            '循环把所以数据导出
            strSQL = "insert into SET_XX(XXID,XXMC,KSID,XXPYSX,XXWBSX" _
                    & ",XXNNTY,XXType,XXSFJRXJ,XXSFYJY,XXSM,SXH,XXPrice)" _
                    & " values(" _
                    & "'" & rstemp("XXID") & "'" _
                    & ",'" & rstemp("XXMC") & "'" _
                    & ",'" & rstemp("KSID") & "'" _
                    & ",'" & rstemp("XXPYSX") & "'" _
                    & ",'" & rstemp("XXWBSX") & "'" _
                    & "," & rstemp("XXNNTY") _
                    & "," & rstemp("XXType") _
                    & "," & rstemp("XXSFJRXJ") _
                    & "," & rstemp("XXSFYJY")
            If Not IsNull(rstemp("XXSM")) Then
                strSQL = strSQL & ",'" & rstemp("XXSM") & "'"
            Else
                strSQL = strSQL & ",null"
            End If
            strSQL = strSQL & "" _
                    & "," & rstemp("SXH")
            If Not IsNull(rstemp("XXPrice")) Then
                strSQL = strSQL & "," & rstemp("XXPrice")
            Else
                strSQL = strSQL & ",null"
            End If
            strSQL = strSQL & ")"
            ExportCon.Execute strSQL
            rstemp.MoveNext
        Loop
        rstemp.Close
    End If
    Set rstemp = Nothing
    
    ExportXX = True
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    '
End Function

'导出SET_ZH_Data
Private Function ExportZH() As Boolean
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    
    '提取所有对应关系
    strSQL = "select * from SET_ZH_Data"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If Not rstemp.EOF Then
        Do While Not rstemp.EOF
            '循环把所以数据导出
            strSQL = "insert into SET_ZH_Data(DXID,XXID)" _
                    & " values(" _
                    & "'" & rstemp("DXID") & "'" _
                    & ",'" & rstemp("XXID") & "'" _
                    & ")"
            ExportCon.Execute strSQL
            rstemp.MoveNext
        Loop
        rstemp.Close
    End If
    Set rstemp = Nothing
    
    ExportZH = True
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    '
End Function

'导出SET_TJBZDT
Private Function ExportTJBZ() As Boolean
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    
    '提取所有体检标准
    strSQL = "select * from SET_TJBZDT"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If Not rstemp.EOF Then
        Do While Not rstemp.EOF
            '循环把所以数据导出
            strSQL = "insert into SET_TJBZDT(BZID,XMID,NormalVal,CKSX,CKXX,DW,Sex)" _
                    & " values(" _
                    & rstemp("BZID") _
                    & ",'" & rstemp("XMID") & "'" _
                    & ",'" & rstemp("NormalVal") & "'" _
                    & ",'" & rstemp("CKSX") & "'" _
                    & ",'" & rstemp("CKXX") & "'" _
                    & ",'" & rstemp("DW") & "'" _
                    & "," & rstemp("Sex") _
                    & ")"
            ExportCon.Execute strSQL
            rstemp.MoveNext
        Loop
        rstemp.Close
    End If
    Set rstemp = Nothing
    
    ExportTJBZ = True
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    '
End Function

'导出个人相关数据
Private Function ExportPersonData(ByVal lngGUID As Long) As Boolean
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim rsPerson As ADODB.Recordset
    Dim rsData As ADODB.Recordset
    Dim rsPYSX As ADODB.Recordset
    Dim strXXPYSX As String
    Dim strDXPYSX As String
    Dim strTemp As String
    Dim intSex As Integer
    Dim strZJJL As String
    Dim strZJJY As String
    
    '检索个人信息
    strSQL = "select * from SET_GRXX" _
            & " where GUID=" & lngGUID
    Set rsPerson = New ADODB.Recordset
    rsPerson.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If Not rsPerson.EOF Then
        '第一步，导出个人信息
        strSQL = "insert into Person_XX([GUID],QueryCode,HealthID,TJSerialNum,SelfBH,Name" _
                & ",Sex,Age,HF,DanWei,Pas,TJRQ,Email,LXDZ,YZBM)" _
                & " values(" _
                & rsPerson("GUID")
        '查询码
        If Not IsNull(rsPerson("CXM")) Then
            strSQL = strSQL & ",'" & rsPerson("CXM") & "'"
        Else
            strSQL = strSQL & ",null"
        End If
        '系统档案号，体检序号
        strSQL = strSQL & ",'" & rsPerson("HealthID") & "'," & rsPerson("TJSerialNum")
        '自定义档案号
        If Not IsNull(rsPerson("SelfBH")) Then
            strSQL = strSQL & ",'" & rsPerson("SelfBH") & "'"
        Else
            strSQL = strSQL & ",null"
        End If
        '姓名，性别
        strSQL = strSQL & ",'" & rsPerson("YYRXM") & "'" _
                & ",'" & rsPerson("SEX") & "'"
        '年龄
        If Not IsNull(rsPerson("AGE")) Then
            strSQL = strSQL & "," & CInt(Val(rsPerson("AGE")))
        Else
            strSQL = strSQL & ",null"
        End If
        '婚否
        If Not IsNull(rsPerson("HF")) Then
            strSQL = strSQL & ",'" & rsPerson("HF") & "'"
        Else
            strSQL = strSQL & ",null"
        End If
        '单位
        If IsNull(rsPerson("YYID")) Or (rsPerson("YYID") = "") Then
            strSQL = strSQL & ",null"
        Else
            '获取单位名称
            strTemp = "select DWMC from YY_TJDJ,SET_DW where" _
                    & " YY_TJDJ.YYID='" & rsPerson("YYID") & "'" _
                    & " and YY_TJDJ.DWID=SET_DW.DWID"
            Set rstemp = New ADODB.Recordset
            rstemp.Open strTemp, GCon, adOpenForwardOnly, adLockReadOnly
            If Not rstemp.EOF Then
                strSQL = strSQL & ",'" & rstemp("DWMC") & "'"
                rstemp.Close
            Else
                strSQL = strSQL & ",null"
            End If
        End If
        strSQL = strSQL & ",''" '密码
        '体检日期
        strSQL = strSQL & ",#" & rsPerson("TJRQ") & "#"
        'EMail
        If Not IsNull("EMail") Then
            strSQL = strSQL & ",'" & rsPerson("EMail") & "'"
        Else
            strSQL = strSQL & ",null"
        End If
        '联系地址
        If Not IsNull("LXDZ") Then
            strSQL = strSQL & ",'" & rsPerson("LXDZ") & "'"
        Else
            strSQL = strSQL & ",null"
        End If
        '邮政编码
        If Not IsNull("YZBM") Then
            strSQL = strSQL & ",'" & rsPerson("YZBM") & "'"
        Else
            strSQL = strSQL & ",null"
        End If
        '括号
        strSQL = strSQL & ")"
        '写入数据库
        ExportCon.Execute strSQL
        
        '记录性别
        intSex = IIf(rsPerson("SEX") = "男", 2, 1)
        '第二步，导出选择的项目
        strSQL = "select DXID from YY_SJDJDX" _
                & " where GUID=" & lngGUID
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
        If Not rstemp.EOF Then
            Do While Not rstemp.EOF
                strSQL = "insert into YY_SJDJDX([GUID],DXID)" _
                        & " values(" _
                        & lngGUID _
                        & ",'" & rstemp("DXID") & "'" _
                        & ")"
                ExportCon.Execute strSQL
                
                '第三步，导出体检项目值
                strSQL = "select SET_DX.DXPYSX,SET_XX.XXPYSX,SET_XX.XXID" _
                        & " from SET_DX,SET_ZH_DATA,SET_XX" _
                        & " where SET_DX.DXID='" & rstemp("DXID") & "'" _
                        & " and SET_DX.DXID=SET_ZH_DATA.DXID" _
                        & " and SET_ZH_DATA.XXID=SET_XX.XXID" _
                        & " and SET_DX.DXNNTY<>" & intSex _
                        & " and SET_XX.XXNNTY<>" & intSex _
                        & " order by SET_DX.SXH,SET_XX.SXH"
                Set rsPYSX = New ADODB.Recordset
                rsPYSX.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
                If Not rsPYSX.EOF Then
                    Do While Not rsPYSX.EOF
                        strDXPYSX = rsPYSX("DXPYSX")
                        strXXPYSX = rsPYSX("XXPYSX")
                        strSQL = "select [" & strXXPYSX & "],TJRQ" _
                                & " from [DATA_" & strDXPYSX & "]" _
                                & " where GUID=" & lngGUID
                        Set rsData = New ADODB.Recordset
                        rsData.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
                        If Not rsData.EOF Then
                            If Not IsNull(rsData(strXXPYSX)) Then
                                strSQL = "insert into XMResult([GUID],QueryCode,XMID,XMValue,TJRQ)" _
                                        & " values(" _
                                        & lngGUID
                                If Not IsNull(rsPerson("CXM")) Then
                                    strSQL = strSQL & ",'" & rsPerson("CXM") & "'"
                                Else
                                    strSQL = strSQL & ",null"
                                End If
                                strSQL = strSQL & ",'" & rsPYSX("XXID") & "'" _
                                        & ",'" & rsData(strXXPYSX) & "'" _
                                        & ",#" & rsData("TJRQ") & "#" _
                                        & ")"
                                ExportCon.Execute strSQL
                            End If
                            
                            rsData.Close
                        End If
                        
                        rsPYSX.MoveNext
                    Loop
                    rsPYSX.Close
                End If
                
                rstemp.MoveNext
            Loop
            rstemp.Close
        End If
        
        '第四步，导出总检结论
        strSQL = "select JLValue from DATA_ZJJL" _
                & " where GUID=" & lngGUID
        Set rsData = New ADODB.Recordset
        rsData.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
        strZJJL = ""
        If Not rsData.EOF Then
            If Not IsNull(rsData("JLValue")) Then
                strZJJL = rsData("JLValue")
            End If
            rsData.Close
        End If
        '第五步，导出总检建议
        strSQL = "select JYValue,TJRQ from DATA_ZJJY" _
                & " where GUID=" & lngGUID
        Set rsData = New ADODB.Recordset
        rsData.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
        strZJJY = ""
        If Not rsData.EOF Then
            If Not IsNull(rsData("JYValue")) Then
                strZJJY = rsData("JYValue")
            End If
        End If
        '构建更新语句
        strSQL = "insert into ZJResult([GUID],QueryCode,ZJJL,ZJJY,TJRQ)" _
                & " values(" _
                & lngGUID
        If Not IsNull(rsPerson("CXM")) Then
            strSQL = strSQL & ",'" & rsPerson("CXM") & "'"
        Else
            strSQL = strSQL & ",null"
        End If
        strSQL = strSQL & ",'" & strZJJL & "','" & strZJJY & "'"
        If Not rsData.EOF Then
            strSQL = strSQL & ",#" & rsData("TJRQ") & "#"
        Else
            '没有做总检建议时，使用登记的体检日期
            strSQL = strSQL & ",#" & rsPerson("TJRQ") & "#"
        End If
        strSQL = strSQL & ")"
        ExportCon.Execute strSQL
        If Not rsData.EOF Then
            rsData.Close '关闭记录集
        End If
        
        '第六步，设置已导出标志
        strSQL = "update SET_GRXX set Export=1 where GUID=" & lngGUID
        GCon.Execute strSQL
        '关闭记录集
        rsPerson.Close
    End If
    
    ExportPersonData = True
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    '
End Function

'Public Sub ExportData(ByVal dtpStart As Date, ByVal dtpEnd As Date, ByVal ExportPath As String)

'    Dim Status
'    Dim rsTemp As ADODB.Recordset
'    Dim rsTempDX As ADODB.Recordset
'    Dim rsTempXX As ADODB.Recordset
'
'    Dim strTmpYYID As String
'    Dim strTmpDXPYSX As String
'    Dim strSQL As String
'
'    Dim lngExportCount As Long          '当前导出的人的数量
'
''    '查找可供导出的人的数量，供进度条使用
''    strSQL = "select count(*) as 导出人数 from SET_GRXX" _
''            & " where TJRQ>='" & dtpStart & "'" _
''            & " and TJRQ<='" & dtpEnd & "'"
''    Set rsTemp = New ADODB.Recordset
''    rsTemp.Open strSQL, GCon, adOpenDynamic, adLockOptimistic
''    If rsTemp("导出人数") > 0 Then
''        pgbDataExport.Max = rsTemp("导出人数")
''        pgbDataExport.Min = 0
''        LblJD.Caption = "当前进度  0/" & rsTemp("导出人数")
''    End If
'
'    strSQL = "select GUID from SET_GRXX" _
'            & " where TJRQ>='" & dtpStart & "'" _
'            & " and TJRQ<='" & dtpEnd & "'"