module1.bas

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

                    Do While Not rstemp.EOF
                        strSQL = "insert into YY_SJDJDX(GUID,DXID,SFTJ) values('" & lngGUID & "'" _
                                & ",'" & rstemp("DXID") & "',0)"
                        GCon.Execute strSQL
                        
                        rstemp.MoveNext
                    Loop
                    
                    rstemp.Close
                End If
                
                '获取客户所进入分组的体检日期
                strSQL = "select FZTJRQ from FZ_FZSY" _
                        & " where YYID='" & inYYID & "'" _
                        & " and FZID=" & tmpFZID
                Set rstemp = New ADODB.Recordset
                rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
                If Not rstemp.EOF Then
                    '设为所选分组的体检日期
                    datFZTJRQ = rstemp("FZTJRQ")
                    rstemp.Close
                Else
                    datFZTJRQ = inTJRQ '否则设为传入的日期
                End If
                
                '为填入SET_GRXX表准备SQL语句
                strSQL = "insert into SET_GRXX(GUID,HealthID,SelfBH,TJSerialNum,YYID,TJRQ" _
                        & ",YYRXM,Sex,Age,YYRJTDH,YYRBGDH,YYRYDDH,YYRSFZH,LisAccept,Export,QRDJ) " _
                        & " values(" & lngGUID _
                        & ",'" & strTmpHealthID & "'" _
                        & ",'" & strSelfBH & "'" _
                        & "," & intTJXH _
                        & ",'" & inYYID & "'" _
                        & ",'" & datFZTJRQ & "'" _
                        & ",'" & Trim(.Cells(i, intNameCol)) & "'" _
                        & ",'" & Trim(.Cells(i, intSexCol)) & "'" _
                        & "," & IIf(IsNull(.Cells(i, intAgeCol)), 0, CInt(Val(.Cells(i, intAgeCol)))) _
                        & ",'" & Trim(.Cells(i, intJTDHCol)) & "'" _
                        & ",'" & Trim(.Cells(i, intBGDHCol)) & "'" _
                        & ",'" & Trim(.Cells(i, intYDDHCol)) & "'" _
                        & ",'" & Trim(.Cells(i, intSFZHCol)) & "'" _
                        & ",0,0,0)"
                '在SET_GRXX中写入该人数据
                GCon.Execute strSQL
                '是否新到客户
                If blnNewPerson Then
                    '填入新生成的HealthID的健康档案记录
                    strSQL = "insert into JKDA_BASIC(HealthID) values('" & strTmpHealthID & "')"
                    GCon.Execute strSQL
                    strSQL = "insert into JKDA_XYS(HealthID) values('" & strTmpHealthID & "')"
                    GCon.Execute strSQL
                    strSQL = "insert into JKDA_YJS(HealthID) values('" & strTmpHealthID & "')"
                    GCon.Execute strSQL
                End If
                
                '把生日写入健康档案
                If Not IsNull(.Cells(i, intBirthdayCol)) And Trim(.Cells(i, intBirthdayCol)) <> "" Then
                    '写入健康档案
                    strSQL = "update JKDA_BASIC set" _
                            & " BirthDate='" & CDate(Trim(.Cells(i, intBirthdayCol))) & "'" _
                            & " where HealthID='" & strTmpHealthID & "'"
                    GCon.Execute strSQL
                End If
                
                '发卡
                If strSelfBH <> "" Then
                    strSQL = "select Count(*) from SET_ICKGL_Index" _
                            & " where HealthID='" & strTmpHealthID & "'" _
                            & " and ICKNum='" & strSelfBH & "'"
                    Set rstemp = New ADODB.Recordset
                    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
                    If rstemp(0) < 1 Then
                        '原来不存在
                        strSQL = "insert into SET_ICKGL_Index(ICKNum,HealthID,FKRQ,Status) values(" _
                                & "'" & strSelfBH & "'" _
                                & ",'" & strTmpHealthID & "'" _
                                & ",'" & Date & "'" _
                                & ",0)" '0表示在用
                    Else
                        strSQL = "update SET_ICKGL_Index set" _
                                & " ICKNum='" & strSelfBH & "'" _
                                & " where HealthID='" & strTmpHealthID & "'"
                    End If
                    GCon.Execute strSQL
                    rstemp.Close
                End If
            End If
        Next i
    End With 'ObjSheet
    '▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲
    '                               提交事务
    '▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲
    GCon.CommitTrans
    ImportFromExcel = True
    GoTo ExitLab
    '▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲
RollBack:       '回滚事务
    GCon.RollbackTrans
ErrMsg:
    Status = SetError(Err.Number, Err.Description, "MDIForm1.SetBackground")
    ErrMsg Status
ExitLab:
    Set ObjSheet = Nothing
    Set ObjWorkBook = Nothing
    ObjExcel.Quit
    Set ObjExcel = Nothing
    Screen.MousePointer = vbDefault
End Function
'******************20040516加入完 闻********************************

Public Function CheckFZIDValue(inYYID, inFZID As String) As Boolean
    Dim i As Integer
    Dim strSQL As String
    Dim rsTmp As ADODB.Recordset
    
    CheckFZIDValue = False
    For i = 1 To Len(inFZID)
        If Asc(Mid(inFZID, i, 1)) < vbKey0 Or Asc(Mid(inFZID, i, 1)) > vbKey9 Then
            Exit Function
        End If
    Next
    '查找是否该inYYID单位存在着inFZID这个分组
    strSQL = "select FZID from FZ_FZSY" _
            & " where YYID='" & inYYID & "'" _
            & " and FZID=" & CInt(Val(inFZID))
    Set rsTmp = New ADODB.Recordset
    rsTmp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If Not rsTmp.EOF Then
        CheckFZIDValue = True
    End If
End Function

'******************20040516加入 闻**********************************
'获取当前可用的GUID
Public Function GetGUID() As Long
    Dim rstemp As ADODB.Recordset
    Dim strSQL As String
    Dim conTemp As ADODB.Connection '新建一个连接
    Dim lngGUID As Long
    
    Screen.MousePointer = vbHourglass
    If ConnectDatabase(conTemp, adUseServer) = False Then GoTo ExitLab
    
    '以下获取当前最大的唯一编号，然后加1
    strSQL = "select GUID from SET_GUID"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, conTemp, adOpenStatic, adLockPessimistic
    If Not rstemp.EOF Then '有记录
        lngGUID = rstemp(0) + 1
    Else '无记录
        rstemp.AddNew
        lngGUID = 1
    End If
    '写入新的最大编号
    rstemp("GUID") = lngGUID
    rstemp.Update '更新数据库
    Set rstemp = Nothing
    Call DisConnectDatabase(conTemp)
    
    GetGUID = lngGUID
    GoTo ExitLab
ExitLab:
    Screen.MousePointer = vbDefault
End Function
'******************20040516加入完 闻**********************************

'********************20040519加入 闻**********************************
'根据入口参数(某人的GUID)查看是否选择了体检套餐，如选择了，则返回套餐名称
Public Function GetTCName(inGUID As Long) As String
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim strYYID As String
    
    Set rstemp = New ADODB.Recordset
    strSQL = "select * from SET_GRXX where GUID=" & inGUID
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If IsNull(rstemp("YYID")) Or rstemp("YYID") = "" Then
        '不属于团体
        '构建查询选择套餐信息的查询语句
        strSQL = "select BZID,XZTC,YY_SJDJ.TCID,TCMC from YY_SJDJ,SET_TC" _
                & " where GUID=" & inGUID _
                & " and YY_SJDJ.TCID=SET_TC.TCID"
                
    Else
        '属于团体
        strYYID = rstemp("YYID")
        '构建查询选择套餐信息的查询语句
        strSQL = "select XZTC,YY_TJDJTC.TCID,TCMC from YY_TJDJTC,FZ_FZSJ,SET_TC" _
                & " where YY_TJDJTC.YYID='" & strYYID & "'" _
                & " and FZ_FZSJ.YYID='" & strYYID & "'" _
                & " and FZ_FZSJ.GUID=" & inGUID _
                & " and YY_TJDJTC.FZID=FZ_FZSJ.FZID" _
                & " and YY_TJDJTC.TCID=SET_TC.TCID"
    End If
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
    If rstemp.RecordCount > 0 Then
        '体检标准
        '是否选择了套餐
        If rstemp("XZTC") = True Then
            GetTCName = rstemp("TCMC")
            rstemp.Close
            Exit Function
        Else
            GetTCName = ""
            rstemp.Close
            Exit Function
        End If
    End If
End Function
'******************20040519加入完 闻************************************

'********************20040520加入 闻************************************
'判断某人在某科室中是否全部的项目都已录入完
Public Function CheckKSInput(inGUID As Long, inKSID As String, inSEX As Integer) As Boolean
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim strTemp As String
    Dim strInsert As String
    Dim strCheck As String
    Dim rstemp As ADODB.Recordset
    Dim rsData As ADODB.Recordset
    Dim rsHZ As ADODB.Recordset
    Dim cmd As ADODB.Command
    Dim i As Integer
    Dim strResult As String '科室小结
    Dim strTempJYi As String
    
    Dim strDXPYSX As String
    Dim strXXPYSX As String
    Dim intType As Integer
    Dim strXMID As String
    Dim strXMMC As String
    
    Dim strID As String
    Dim strXJie As String
    Dim strJYi As String '辅助建议
    Dim strValue As String '字符型数字
    Dim strKSID As String '当前选择科室的ID
    Dim strDXID As String
    
    '**********************20040520加入 闻********************************
    '在GetTJResult中标识当要取的值是否为空，如为空说明当前项目未录入，则不允许生成小结(千福要求)
    Dim blXMValueisNull As Boolean
    blXMValueisNull = False      '初始化为false
    '**********************20040520加入完 闻******************************
    
    '初始化设置返回值为true
    CheckKSInput = True
    
    '截取科室ID
    strKSID = inKSID
    
    '获取当前科室下的所有大项
    strSQL = "select * from SET_DX" _
            & " where KSID='" & strKSID & "'" _
            & " and DXNNTY<>" & inSEX _
            & " and DXID in (select DXID from YY_SJDJDX where GUID='" & inGUID & "')"

    '按顺序号排序
    strSQL = strSQL & " order by SXH"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rstemp.RecordCount > 0 Then
        rstemp.MoveFirst
        Do
            strDXPYSX = rstemp("DXPYSX")
            strDXID = rstemp("DXID")
            strJYi = ""
            
            '是否包含小项
            If rstemp("DXSFYZX") = 0 Then
                '无子项
                strXMID = rstemp("DXID")
                strXMMC = rstemp("DXMC")
                intType = rstemp("DXType")
                strTempJYi = "" '清空
                GoSub GetTJResult
                '如果该项目还未录入，则不能生成小结
                If blXMValueisNull = True Then
                    CheckKSInput = False
                    GoTo ExitLab
                End If
                If strTempJYi <> "" Then
                    strJYi = strTempJYi
                End If
            Else
                '有子项
                strSQL = "select * from SET_XX" _
                        & " where XXID in (" _
                            & "select XXID from SET_ZH_Data" _
                            & " where DXID='" & rstemp("DXID") & "'" _
                        & ")" _
                        & " and XXNNTY<>" & inSEX
                '按顺序号排序
                strSQL = strSQL & " order by SXH"
                Set rsData = New ADODB.Recordset
                rsData.Open strSQL, GCon, adOpenStatic, adLockOptimistic
                If rsData.RecordCount >= 1 Then
                    rsData.MoveFirst
                    Do
                        strXMID = rsData("XXID")
                        strXMMC = rsData("XXMC")
                        strXXPYSX = rsData("XXPYSX")
                        intType = rsData("XXType")
                        strTempJYi = "" '清空
                        GoSub GetTJResult
                        '如果该项目还未录入，则不能生成小结
                        If blXMValueisNull = True Then
                            CheckKSInput = False
                            GoTo ExitLab
                        End If