frmttmddc.frm

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

    If Not g_blnSelfID Then
        strSQL = strSQL & "SET_GRXX.HealthID"
    Else
        strSQL = strSQL & "SET_GRXX.SelfBH"
    End If
    strSQL = strSQL & ",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"
    GCon.Execute strSQL
    
    '设置“序号”列
    strSQL = "select GUID,序号 from " & TempTable
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenKeyset, adLockBatchOptimistic
    If rstemp.RecordCount > 0 Then
        rstemp.MoveFirst
        intCount = 1
        Do While Not rstemp.EOF
            rstemp("序号") = intCount
            
            intCount = intCount + 1
            rstemp.MoveNext
        Loop
        rstemp.UpdateBatch
        
        rstemp.Close
    End If
    Set rstemp = Nothing
    
    strSQL = "select 序号,档案号,姓名,性别,年龄,分组,分组名称,家庭电话,办公电话,移动电话,查询码,体检日期" _
            & " from " & TempTable
    Call ExportToExcel(strSQL, strFileName, lvwDWei.SelectedItem.Text, _
            "团体名单导出", "4,8.5,7.4,5.1,5.1,4.3,10,10,10,10,14.5,15", blnClose:=True)
    
    '导出统计Sheet页
    '创建临时表
    strSQL = "CREATE TABLE " & TempTable _
            & " (序号 int,统计项目 Varchar(30)" _
            & ",结果 Varchar(8000)" _
            & ")"
    If CreateTable(TempTable, True, strSQL) = False Then GoTo ExitLab
    
    '总人数
    strReturn = GetPersonCheckStatus(ALL_PERSON, strYYID)
    intCount = CInt(Val(strReturn))
    strSQL = "insert into " & TempTable & " values(" _
            & "1,'总人数','" & CStr(intCount) & "'" _
            & ")"
    GCon.Execute strSQL
    
    '待登记人员
    strReturn = GetPersonCheckStatus(UNREGISTER, strYYID, , , , True)
    lngPosition = InStr(1, strReturn, HEADER)
    intCount = Left(strReturn, lngPosition - 1)
    strPeoples = Mid(strReturn, lngPosition + 1)
    
    strSQL = "insert into " & TempTable & " values(" _
            & "2,'待登记(" & intCount & " 人)','" & strPeoples & "'" _
            & ")"
    GCon.Execute strSQL
    
    '待体检人员
    strReturn = GetPersonCheckStatus(UNCHECK, strYYID, , , , True)
    lngPosition = InStr(1, strReturn, HEADER)
    intCount = Left(strReturn, lngPosition - 1)
    strPeoples = Mid(strReturn, lngPosition + 1)
    
    strSQL = "insert into " & TempTable & " values(" _
            & "3,'已登记未体检(" & intCount & " 人)','" & strPeoples & "'" _
            & ")"
    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, lvwDWei.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
    
    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
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

Private Sub LvwDWei_Click()
On Error GoTo ErrMsg
    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 txtName_KeyPress(KeyAscii As Integer)
    Dim i As Integer
    Dim strSearch As String
    
    '是否有单位
    If lvwDWei.ListItems.Count < 1 Then Exit Sub
    
    If KeyAscii = vbKeyReturn Then
        '回车时定位到匹配的第一条记录
        txtName.Text = Trim(txtName.Text)
        strSearch = txtName.Text
        
        For i = 1 To lvwDWei.ListItems.Count
            If lvwDWei.ListItems(i).Text Like strSearch & "*" Then
                Set lvwDWei.SelectedItem = lvwDWei.ListItems(i)
                LvwDWei_Click
                Exit For
            End If
        Next i
        KeyAscii = 0
        txtName.SetFocus
    End If
End Sub