frmnewttmddc.frm

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

    GCon.Execute strSQL
    
    '体检中
    strReturn = GetPersonCheckStatus(CHECKING, strYYID, , , , True)
    lngPosition = InStr(1, strReturn, HEADER)
    intCount = Left(strReturn, lngPosition - 1)
    strPeoples = Mid(strReturn, lngPosition + 1)
    
    strSQL = "insert into " & TempTable & " values(" _
            & "4,'体检中(" & intCount & " 人)','" & strPeoples & "'" _
            & ")"
    GCon.Execute strSQL
    
    '待总检
    strReturn = GetPersonCheckStatus(UNFINISHED, strYYID, , , , True)
    lngPosition = InStr(1, strReturn, HEADER)
    intCount = Left(strReturn, lngPosition - 1)
    strPeoples = Mid(strReturn, lngPosition + 1)
    
    strSQL = "insert into " & TempTable & " values(" _
            & "5,'已体检未出总检报告(" & intCount & " 人)','" & strPeoples & "'" _
            & ")"
    GCon.Execute strSQL
    
    '已总检
    strReturn = GetPersonCheckStatus(FINISHED, strYYID, , , , True)
    lngPosition = InStr(1, strReturn, HEADER)
    intCount = Left(strReturn, lngPosition - 1)
    strPeoples = Mid(strReturn, lngPosition + 1)
    
    strSQL = "insert into " & TempTable & " values(" _
            & "6,'已出总检报告(" & intCount & " 人)','" & strPeoples & "'" _
            & ")"
    GCon.Execute strSQL
    
    '写入excel文件
    If Dir(strFileName) <> "" Then
        strSQL = "select 序号,统计项目,结果 from " & TempTable _
                & " order by 序号"
        Call ExportToExcel(strSQL, strFileName, tvwDWei.SelectedItem.Text, _
                "体检状态统计", "5,28,40", 1, 3, 1, 3, False, "Sheet2")
    End If
    
    If blnPrintImmediate Then
        '调用Excel打印函数
        Call PrintOfficeDocument(strFileName, EXCEL_W, "Sheet1,Sheet2")
    End If
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub Form_Activate()
    txtName.SetFocus
End Sub

Private Sub Form_Load()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim rsDW As ADODB.Recordset
    Dim rsTeam As ADODB.Recordset
    Dim nodTemp As Node
    Dim i As Integer
    
    Screen.MousePointer = vbHourglass
    
'    '检索所有已经登记的单位
'    strSQL = "select YYID,DWMC from YY_TJDJ,SET_DW" _
'            & " where YY_TJDJ.DWID=SET_DW.DWID" _
'            & " order by TJRQ desc,DWMC"
'    Set rstemp = New ADODB.Recordset
'    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
'    If rstemp.RecordCount > 0 Then
'        rstemp.MoveFirst
'        Do While Not rstemp.EOF
'            lvwDWei.ListItems.Add , "W" & rstemp("YYID"), rstemp("DWMC")
'
'            rstemp.MoveNext
'        Loop
'        rstemp.Close
'
'        '选中第一条记录
'        Set lvwDWei.SelectedItem = lvwDWei.ListItems(1)
'        LvwDWei_Click
'    End If
'    Set rstemp = Nothing
    
    '获取所有预约的单位
    strSQL = "select YYID,TaskNumber,DWMC from YY_TJDJ,SET_DW" _
            & " where YY_TJDJ.DWID=SET_DW.DWID" _
            & " order by YY_TJDJ.TJRQ desc"
    Set rsDW = New ADODB.Recordset
    rsDW.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
    
    '显示所有单位
    With tvwDWei.Nodes
        .Clear
        '添加一个根节点
        '关键字长度：1=1
        Set nodTemp = .Add(, , "W", "体检单位")
        nodTemp.Expanded = True
        If rsDW.RecordCount > 0 Then
            rsDW.MoveFirst
            For i = 1 To rsDW.RecordCount
                '关键字长度：1+11=12
                '标题显示为：任务书编号＋单位名称
                Set nodTemp = .Add("W", tvwChild, "W" & rsDW("YYID"), rsDW("TaskNumber") & rsDW("DWMC"))
                '对每一个单位，显示其可能已经存在的分组
                strSQL = "select FZID,FZMC FROM FZ_FZSY" _
                        & " WHERE YYID='" & rsDW("YYID") & "'"
                Set rsTeam = New ADODB.Recordset
                rsTeam.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
                If rsTeam.RecordCount >= 1 Then
                    rsTeam.MoveFirst
                    Do
                        '
                        '关键字长度：1+11+未定>12
                        .Add "W" & rsDW("YYID"), tvwChild, "W" & rsDW("YYID") & rsTeam("FZID"), rsTeam("FZMC")
                        rsTeam.MoveNext
                    Loop Until rsTeam.EOF
                    rsTeam.Close
                End If
                
                rsDW.MoveNext
            Next
        End If
    End With
    rsDW.Close
    
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

'Private Sub LvwDWei_Click()

'    Dim Status
'    Dim strSQL As String
'    Dim rsPeople As ADODB.Recordset
'    Dim strYYID As String
'    Dim itmTemp As ListItem
'    Dim intCount As Integer
'    Dim blnZJOnly As Boolean
'
'    Me.MousePointer = vbHourglass
'
'    cmdExportToExcel.Enabled = False
'
'    '是否有选择
'    If LvwDWei.SelectedItem Is Nothing Then GoTo ExitLab
'
'    '清除之前的查询结果
'    lvwPeople.ListItems.Clear
'
'    '记录预约编号
'    strYYID = Mid(LvwDWei.SelectedItem.Key, 2)
'    '是否只显示已总检人员
'    blnZJOnly = CBool(chkZJOnly.Value)
'
'    '检索当前单位的人员
'    strSQL = "select SET_GRXX.GUID,HealthID,SelfBH,YYRXM,SET_GRXX.SEX,Age,FZ_FZSY.FZID,FZMC,YYRJTDH,YYRBGDH,YYRYDDH,CXM,TJRQ" _
'            & " from SET_GRXX,FZ_FZSJ,FZ_FZSY" _
'            & " where SET_GRXX.YYID='" & strYYID & "'" _
'            & " and SET_GRXX.GUID=FZ_FZSJ.GUID" _
'            & " and FZ_FZSY.FZID=FZ_FZSJ.FZID" _
'            & " and FZ_FZSY.YYID='" & strYYID & "'" _
'            & " and FZ_FZSJ.YYID='" & strYYID & "'"
'    If blnZJOnly Then
'        strSQL = strSQL & " and SET_GRXX.GUID in(" _
'                    & "select GUID from DATA_ZJJL" _
'                & ")"
'    End If
'    strSQL = strSQL & " order by YYRXM"
'    Set rsPeople = New ADODB.Recordset
'    rsPeople.Open strSQL, GCon, adOpenStatic, adLockReadOnly
'    If rsPeople.RecordCount > 0 Then
'        rsPeople.MoveFirst
'        intCount = 1
'        Do While Not rsPeople.EOF
'            Set itmTemp = lvwPeople.ListItems.Add(, "W" & rsPeople("GUID"), intCount)
'            If Not g_blnSelfID Then
'                itmTemp.SubItems(1) = rsPeople("HealthID") '档案号
'            Else
'                itmTemp.SubItems(1) = rsPeople("SelfBH") & "" '档案号
'            End If
'            itmTemp.SubItems(2) = rsPeople("YYRXM") '姓名
'            itmTemp.SubItems(3) = rsPeople("SEX") '性别
'            itmTemp.SubItems(4) = rsPeople("Age") & "" '年龄
'            itmTemp.SubItems(5) = rsPeople("FZID") '分组编号
'            itmTemp.SubItems(6) = rsPeople("FZMC")          '分组名称
'            itmTemp.SubItems(7) = rsPeople("YYRJTDH") & "" '家庭电话
'            itmTemp.SubItems(8) = rsPeople("YYRBGDH") & "" '办公电话
'            itmTemp.SubItems(9) = rsPeople("YYRYDDH") & "" '移动电话
'            itmTemp.SubItems(10) = rsPeople("CXM") & ""
'            itmTemp.SubItems(11) = rsPeople("TJRQ")
'
'            intCount = intCount + 1
'            rsPeople.MoveNext
'        Loop
'        rsPeople.Close
'
'        cmdExportToExcel.Enabled = True
'    End If
'
'
'    GoTo ExitLab
'ErrMsg:
'    Status = SetError(Err.Number, Err.Description, Err.Source)
'    ErrMsg Status
'ExitLab:
'    Me.MousePointer = vbDefault
'End Sub

'Private Sub lvwDWei_KeyUp(KeyCode As Integer, Shift As Integer)
'    If (KeyCode = vbKeyDown) Or (KeyCode = vbKeyUp) Then
'        LvwDWei_Click
'    End If
'End Sub

Private Sub tvwDWei_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsPeople As ADODB.Recordset
    Dim strKey As String
    Dim strYYID As String
    Dim itmTemp As ListItem
    Dim intCount As Integer
    Dim blnZJOnly As Boolean
    
    Me.MousePointer = vbHourglass
    
    cmdExportToExcel.Enabled = False
    
    '是否有选择
    If tvwDWei.SelectedItem Is Nothing Then GoTo ExitLab
    
    '清除之前的查询结果
    lvwPeople.ListItems.Clear
    
    strKey = tvwDWei.SelectedItem.Key
    
    
    '是否只显示已总检人员
    blnZJOnly = CBool(chkZJOnly.Value)
    
    If Len(strKey) = 1 Then
        strYYID = ""
    ElseIf Len(strKey) = 12 Then
    '单击了单位，列出该单位的所有人员
        strYYID = Mid(strKey, 2)
        '检索当前单位的人员
        strSQL = "select SET_GRXX.GUID,HealthID,SelfBH,YYRXM,SET_GRXX.SEX,Age,FZ_FZSY.FZID,FZMC,YYRJTDH,YYRBGDH,YYRYDDH,CXM,TJRQ" _
                & " from SET_GRXX,FZ_FZSJ,FZ_FZSY" _
                & " where SET_GRXX.YYID='" & strYYID & "'" _
                & " and SET_GRXX.GUID=FZ_FZSJ.GUID" _
                & " and FZ_FZSY.FZID=FZ_FZSJ.FZID" _
                & " and FZ_FZSY.YYID='" & strYYID & "'" _
                & " and FZ_FZSJ.YYID='" & strYYID & "'"
        If blnZJOnly Then
            strSQL = strSQL & " and SET_GRXX.GUID in(" _
                        & "select GUID from DATA_ZJJL" _
                    & ")"
        End If
        strSQL = strSQL & " order by YYRXM"
        Set rsPeople = New ADODB.Recordset
        rsPeople.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If rsPeople.RecordCount > 0 Then
            rsPeople.MoveFirst
            intCount = 1
            Do While Not rsPeople.EOF
                Set itmTemp = lvwPeople.ListItems.Add(, "W" & rsPeople("GUID"), intCount)
                If Not g_blnSelfID Then
                    itmTemp.SubItems(1) = rsPeople("HealthID") '档案号
                Else
                    itmTemp.SubItems(1) = rsPeople("SelfBH") & "" '档案号
                End If
                itmTemp.SubItems(2) = rsPeople("YYRXM") '姓名
                itmTemp.SubItems(3) = rsPeople("SEX") '性别
                itmTemp.SubItems(4) = rsPeople("Age") & "" '年龄
                itmTemp.SubItems(5) = rsPeople("FZID") '分组编号
                itmTemp.SubItems(6) = rsPeople("FZMC")          '分组名称
                itmTemp.SubItems(7) = rsPeople("YYRJTDH") & "" '家庭电话
                itmTemp.SubItems(8) = rsPeople("YYRBGDH") & "" '办公电话
                itmTemp.SubItems(9) = rsPeople("YYRYDDH") & "" '移动电话
                itmTemp.SubItems(10) = rsPeople("CXM") & ""
                itmTemp.SubItems(11) = rsPeople("TJRQ")
                
                intCount = intCount + 1
                rsPeople.MoveNext
            Loop
            rsPeople.Close
            
            cmdExportToExcel.Enabled = True
        End If
    Else
    '单击了分组，列出该分组的所有人员
        '检索当前分组的人员
        strYYID = Mid(tvwDWei.SelectedItem.Parent.Key, 2)
        strSQL = "select SET_GRXX.GUID,HealthID,SelfBH,YYRXM,SET_GRXX.SEX,Age,FZ_FZSY.FZID,FZMC,YYRJTDH,YYRBGDH,YYRYDDH,CXM,TJRQ" _
                & " from SET_GRXX,FZ_FZSJ,FZ_FZSY" _
                & " where SET_GRXX.YYID='" & strYYID & "'" _
                & " and SET_GRXX.GUID=FZ_FZSJ.GUID" _
                & " and FZ_FZSY.FZID=FZ_FZSJ.FZID" _
                & " and FZ_FZSY.FZID=" & Val(Mid(tvwDWei.SelectedItem.Key, 13)) _
                & " and FZ_FZSY.YYID='" & strYYID & "'" _
                & " and FZ_FZSJ.YYID='" & strYYID & "'"
                
        If blnZJOnly Then
            strSQL = strSQL & " and SET_GRXX.GUID in(" _
                        & "select GUID from DATA_ZJJL" _
                    & ")"
        End If
        strSQL = strSQL & " order by YYRXM"
        Set rsPeople = New ADODB.Recordset
        rsPeople.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If rsPeople.RecordCount > 0 Then
            rsPeople.MoveFirst
            intCount = 1
            Do While Not rsPeople.EOF
                Set itmTemp = lvwPeople.ListItems.Add(, "W" & rsPeople("GUID"), intCount)
                If Not g_blnSelfID Then
                    itmTemp.SubItems(1) = rsPeople("HealthID") '档案号
                Else
                    itmTemp.SubItems(1) = rsPeople("SelfBH") & "" '档案号
                End If
                itmTemp.SubItems(2) = rsPeople("YYRXM") '姓名
                itmTemp.SubItems(3) = rsPeople("SEX") '性别
                itmTemp.SubItems(4) = rsPeople("Age") & "" '年龄
                itmTemp.SubItems(5) = rsPeople("FZID") '分组编号
                itmTemp.SubItems(6) = rsPeople("FZMC")          '分组名称
                itmTemp.SubItems(7) = rsPeople("YYRJTDH") & "" '家庭电话
                itmTemp.SubItems(8) = rsPeople("YYRBGDH") & "" '办公电话
                itmTemp.SubItems(9) = rsPeople("YYRYDDH") & "" '移动电话
                itmTemp.SubItems(10) = rsPeople("CXM") & ""
                itmTemp.SubItems(11) = rsPeople("TJRQ")
                
                intCount = intCount + 1
                rsPeople.MoveNext
            Loop
            rsPeople.Close
            
            cmdExportToExcel.Enabled = True
        End If
    
    End If
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub tvwDWei_KeyUp(KeyCode As Integer, Shift As Integer)
    If (KeyCode = vbKeyDown) Or (KeyCode = vbKeyUp) Then
        tvwDWei_Click
    End If

End Sub

Private Sub txtName_KeyPress(KeyAscii As Integer)
    Dim i As Integer
    Dim strSearch As String
    
    '是否有单位
    If tvwDWei.Nodes.Count < 2 Then Exit Sub
    
    If KeyAscii = vbKeyReturn Then
        '回车时定位到匹配的第一条记录
        txtName.Text = Trim(txtName.Text)
        strSearch = txtName.Text
        
        For i = 1 To tvwDWei.Nodes.Count
            If tvwDWei.Nodes(i).Text Like strSearch & "*" Then
                Set tvwDWei.SelectedItem = tvwDWei.Nodes(i)
                tvwDWei_Click
                Exit For
            End If
        Next i
        KeyAscii = 0
        txtName.SetFocus
    End If
End Sub