frmbatchinput.frm

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

    Me.Hide
    Unload Me
End Sub

Private Sub cmdDelete_Click()
    CmbInfo.Text = ""
    CmbInfo.Visible = True
    CmbInfo.SetFocus
End Sub

Private Sub cmdSave_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim strCheck As String
    Dim strUpdate As String
    Dim strDXPYSX As String
    Dim strXXPYSX As String
    Dim rstemp As ADODB.Recordset
    Dim cmd As ADODB.Command
    Dim i As Integer
    Dim lngGUID As Long
    Dim strHealthID As String
    Dim intSN As Integer
    
    '检查网格内有无记录
    If Me.MSHFlexGrid1.TextMatrix(1, 1) = "" Then
        MsgBox "当前没有客户！请设置“批量录入条件”以选择客户！", vbInformation, "提示"
        Exit Sub
    End If
    
    '用户是否输入了体检值
    If Trim(CmbInfo.Text) = "" Then
        MsgBox "请输入体检值！", vbInformation, "提示"
        CmbInfo.SetFocus
        Exit Sub
    End If
    
    '获取条件
    If optDate.Value = True Then
        strSQL = ""
    Else
    
    End If
    
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = GCon
    
    If Len(tvwDXiang.SelectedItem.Key) > 8 Then
        '********************************************************
        '                     对小项进行操作
        '********************************************************
        '获取大项拼音缩写
        strSQL = "select DXPYSX from SET_DX" _
                & " where DXID='" & Mid(tvwDXiang.SelectedItem.Parent.Key, 2, 4) & "'"
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        strDXPYSX = rstemp(0)
        
        With Me.MSHFlexGrid1
             For i = 1 To .Rows - 1
                lngGUID = Val(.TextMatrix(i, 0))
                strHealthID = .TextMatrix(i, 1)
                intSN = Val(.TextMatrix(i, 3))
                strXXPYSX = Mid(Me.tvwDXiang.SelectedItem.Key, 13)
                
                '查看原来是否有记录
                strCheck = "select count(*) from [DATA_" & strDXPYSX & "]" _
                        & " where GUID=" & lngGUID
                '插入
                strSQL = "Insert into [DATA_" & strDXPYSX & "]" _
                        & "(GUID,TJRQ,[" & strXXPYSX & "])" _
                        & " values(" _
                        & lngGUID _
                        & ",'" & Date & "','" & CmbInfo.Text & "')"
                '更新
                strUpdate = "update [DATA_" & strDXPYSX & "]" _
                        & " set [" & strXXPYSX & "]" _
                        & "='" & CmbInfo.Text & "'" _
                        & " where GUID=" & lngGUID
    
                '更新数据库
                Set rstemp = New ADODB.Recordset
                rstemp.Open strCheck, GCon, adOpenStatic, adLockOptimistic
                If rstemp(0) < 1 Then
                    cmd.CommandText = strSQL
                Else
                    cmd.CommandText = strUpdate
                End If
                rstemp.Close
                cmd.Execute
                
                '*******************************************************
                '更新标识字段
                '*******************************************************
                SetSFTJ lngGUID, 2
            Next
        End With
    End If
    
    MsgBox "批量录入成功！", vbInformation, "祝贺"
    cmdSave.Enabled = False

    Exit Sub
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

Private Sub dtpBegin_Change()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim i As Integer
    
    If dtpBegin.Value > dtpStop.Value Then Exit Sub
    
    strSQL = "select SET_GRXX.GUID as 流水号,HealthID as " & g_strSystemIDTitle _
            & ",SelfBH as " & g_strSelfIDTitle _
            & ",TJSerialNum as 体检序号,YYRXM as 姓名,SET_GRXX.TJRQ as 体检日期" _
            & " from SET_GRXX,YY_SJDJ" _
            & " where YYID is null"
    If genuVersion = WLB Then
        strSQL = strSQL & " and (SFTJ=1 or SFTJ=2)" _
                & " and SET_GRXX.QRDJ=1"
    End If
    strSQL = strSQL & " and (SFTJ=1 or SFTJ=2)" _
            & " and SET_GRXX.TJRQ>='" & dtpBegin.Value & "'" _
            & " and SET_GRXX.TJRQ<='" & dtpStop.Value & " 23:59:00'" _
            & " and SET_GRXX.GUID=YY_SJDJ.GUID" _
            & " and SET_GRXX.GUID not in (select GUID from DATA_ZJJL)" _
            & " union " _
            & "select SET_GRXX.GUID as 流水号,HealthID as " & g_strSystemIDTitle _
            & ",SelfBH as " & g_strSelfIDTitle _
            & ",TJSerialNum as 体检序号,YYRXM as 姓名,SET_GRXX.TJRQ as 体检日期" _
            & " from SET_GRXX,YY_TJDJ" _
            & " where not (SET_GRXX.YYID is null)"
    If genuVersion = WLB Then
        strSQL = strSQL & " and (SFTJ=1 or SFTJ=2)" _
                & " and SET_GRXX.QRDJ=1"
    End If
    strSQL = strSQL & " and SET_GRXX.TJRQ>='" & dtpBegin.Value & "'" _
            & " and SET_GRXX.TJRQ<='" & dtpStop.Value & " 23:59:00'" _
            & " and SET_GRXX.YYID=YY_TJDJ.YYID" _
            & " and SET_GRXX.GUID not in (select GUID from DATA_ZJJL)"
    strSQL = strSQL & " order by 体检日期,YYRXM"
            
    RefreshGrid Me, Me.MSHFlexGrid1, strSQL
    
    Exit Sub
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

Private Sub dtpStop_Change()
    dtpBegin_Change
End Sub

Private Sub Form_Load()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim strKSMC As String
    Dim rsDX As ADODB.Recordset
    Dim rsXX As ADODB.Recordset
    Dim rsKShi As ADODB.Recordset
    Dim rstemp As ADODB.Recordset
    Dim blnFirst As Boolean
    Dim nodTemp As Node
    Dim i As Integer

    Screen.MousePointer = vbArrowHourglass
    
    Call VersionControl
    
    '刷新团体信息
    strSQL = "select YYID,TaskNumber,DWMC" _
            & " from YY_TJDJ,SET_DW" _
            & " where YY_TJDJ.DWID=SET_DW.DWID" _
            & " order by YYID desc"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
    cmbDWei.Clear
    If rstemp.RecordCount > 0 Then
        ReDim marrYYID(rstemp.RecordCount)
        '添加已经预约过的团体
        rstemp.MoveFirst
        For i = 1 To rstemp.RecordCount
            cmbDWei.AddItem rstemp("DWMC")
            cmbDWei.ItemData(cmbDWei.NewIndex) = i
            marrYYID(i) = rstemp("YYID") 'YYID字段太长，ItemData属性无法存放，只能存入数组
            rstemp.MoveNext
        Next
        rstemp.Close
    End If

    '添加一个根节点
    Set nodTemp = tvwDXiang.Nodes.Add(, , "W", "项目")
    nodTemp.Expanded = True
    
    '如果是科室医生，则只显示本科室的项目
    '科室医生只能设置本科室内的模板
    If gstrClassifyID = GManager.SystemKSYS Then
        '添加本科室
        Set nodTemp = tvwDXiang.Nodes.Add("W", tvwChild, "W" & gstrKSID, gstrKSMC)
        nodTemp.Expanded = True
        '显示当前科室的项目
        strSQL = "select DXID,DXMC,DXSFYZX from SET_DX" _
                & " where left(DXID,2)='" & gstrKSID & "'"
        '按顺序号排序
        strSQL = strSQL & " order by SXH"
        Set rsDX = New ADODB.Recordset
        rsDX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        If rsDX.RecordCount > 0 Then
            rsDX.MoveFirst
            Do
                '添加大项
                '大项的关键字采用："W"+DXID+DXType，长度为1＋4＋1＝6
                Set nodTemp = tvwDXiang.Nodes.Add("W" & gstrKSID, tvwChild, "W" & rsDX("DXID") & rsDX("DXSFYZX"), rsDX("DXMC"))
                nodTemp.Expanded = True
                
                If rsDX("DXSFYZX") = 1 Then '有子项
                    strSQL = "select XXID,XXMC,XXPYSX from SET_XX" _
                            & " where XXID in (" _
                                & "select XXID from SET_ZH_Data" _
                                & " where DXID='" & rsDX("DXID") & "'" _
                            & ")"
                    '按顺序号排序
                    strSQL = strSQL & " order by SXH"
                    Set rsXX = New ADODB.Recordset
                    rsXX.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
                    If rsXX.RecordCount > 0 Then
                        rsXX.MoveFirst
                        Do
                            '添加小项
                            '小项的关键字采用："W"+XXID+XXPYSX，长度为1＋4＋7＋(未知)>12
                            Set nodTemp = tvwDXiang.Nodes.Add("W" & rsDX("DXID") & rsDX("DXSFYZX"), tvwChild, "W" & rsDX("DXID") & rsXX("XXID") & rsXX("XXPYSX"), rsXX("XXMC"))

                            rsXX.MoveNext
                        Loop Until rsXX.EOF
                        rsXX.Close
                    End If
                End If
                 
                rsDX.MoveNext
            Loop Until rsDX.EOF
            rsDX.Close
        End If
    Else
        '这个时候只有系统管理员和终检医生可以进来
        '所以显示所有科室
        '显示所有科室
        strSQL = "select KSID,KSMC from SET_KSSZ"
        '按顺序号排序
        strSQL = strSQL & " order by SXH"
        Set rsKShi = New ADODB.Recordset
        rsKShi.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        If rsKShi.RecordCount > 0 Then
            rsKShi.MoveFirst
            Do
                '添加科室
                '关键字长度：1＋2＝3
                Set nodTemp = tvwDXiang.Nodes.Add("W", tvwChild, "W" & rsKShi("KSID"), rsKShi("KSMC"))
'                nodTemp.Expanded = True
                
                strSQL = "select DXID,DXMC,DXSFYZX from SET_DX" _
                        & " where left(DXID,2)='" & rsKShi("KSID") & "'"
                '按顺序号排序
                strSQL = strSQL & " order by SXH"
                Set rsDX = New ADODB.Recordset
                rsDX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
                If rsDX.RecordCount > 0 Then
                    rsDX.MoveFirst
                    Do
                        '添加大项
                        '大项的关键字采用："W"+DXID+DXType，长度为1＋4＋1＝6
                        Set nodTemp = tvwDXiang.Nodes.Add("W" & rsKShi("KSID"), tvwChild, "W" & rsDX("DXID") & rsDX("DXSFYZX"), rsDX("DXMC"))
'                        nodTemp.Expanded = True
                        
                        If rsDX("DXSFYZX") = 1 Then '有子项
                            strSQL = "select XXID,XXMC,XXPYSX from SET_XX" _
                                    & " where XXID in (" _
                                        & "select XXID from SET_ZH_Data" _
                                        & " where DXID='" & rsDX("DXID") & "'" _
                                    & ")"
                            '按顺序号排序
                            strSQL = strSQL & " order by SXH"
                            Set rsXX = New ADODB.Recordset
                            rsXX.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
                            If rsXX.RecordCount > 0 Then
                                rsXX.MoveFirst
                                Do
                                    '添加小项
                                    '小项的关键字采用："W"+XXID+XXPYSX，长度为1＋4＋7＋(未知)>12
                                    Set nodTemp = tvwDXiang.Nodes.Add("W" & rsDX("DXID") & rsDX("DXSFYZX"), tvwChild, "W" & rsDX("DXID") & rsXX("XXID") & rsXX("XXPYSX"), rsXX("XXMC"))

                                    rsXX.MoveNext
                                Loop Until rsXX.EOF
                                rsXX.Close
                            End If
                        End If
                         
                        rsDX.MoveNext
                    Loop Until rsDX.EOF
                    rsDX.Close
                End If
                
                rsKShi.MoveNext
            Loop Until rsKShi.EOF
            rsKShi.Close
        End If
    End If
    
    If tvwDXiang.Nodes.Count > 1 Then
        Set tvwDXiang.SelectedItem = tvwDXiang.Nodes(2)
    Else
        Set tvwDXiang.SelectedItem = tvwDXiang.Nodes(1)
    End If
    
    '初始化日期