formxmzh.frm

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

        
        strSQL = "alter table DATA_" & rsXX(0) _
                & " add [" & strXXPYSX & "]"
        Select Case intXXType
            Case 0
                strSQL = strSQL & " varchar(300)"
            Case 1
                strSQL = strSQL & " varchar(10)"
            Case 2
                strSQL = strSQL & " varchar(300)"
        End Select
        strSQL = strSQL & " null"
        rsXX.Close
        cmd.CommandText = strSQL
        cmd.Execute
        
        '以下复制小项的体检标准
        strSQL = "insert into SET_TJBZDT" _
                & " select BZID,XMID='" & strXXID & "'" _
                & ",NormalVal,CKSX,CKXX,DW,HighInfo,LowInfo,MaxVal,MinVal" _
                & " from SET_TJBZDT" _
                & " where XMID='" & Mid(lvwDestination.SelectedItem.Key, 2) & "'"
        cmd.CommandText = strSQL
        cmd.Execute
        
        '以下复制小项的数据字典
        '提取源小项的数据字典
        strSQL = "select DMValue from DM_XX" _
                & " where XXID='" & Mid(lvwDestination.SelectedItem.Key, 2) & "'"
        '借用rsXX
        Set rsXX = New ADODB.Recordset
        rsXX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        If rsXX.RecordCount > 0 Then
            rsXX.MoveFirst
            Do
                If Not IsNull(rsXX("DMValue")) Then
                    '通过循环把这些数据字典复制到新的小项上
                    '首先获取当前最大的字典编号
                    strDMID = GetMaxID("DM_XX", "XXDMID", "00001")
                    
                    '构造查询语句
                    strSQL = "insert into DM_XX values(" _
                            & "'" & strDMID & "'" _
                            & ",'" & strXXID & "'" _
                            & ",'" & rsXX("DMValue") & "'" _
                            & "," & gintManagerID _
                            & ",'" & Date & "')"
                    cmd.CommandText = strSQL
                    cmd.Execute
                End If
                
                rsXX.MoveNext
            Loop Until rsXX.EOF
            rsXX.Close
        End If
        
        lvwOriginal.ListItems.Add , "W" & strXXID, lvwDestination.SelectedItem.Text
    End If
            
    
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

Private Sub cmdDelete_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim i As Integer
    Dim strSQL As String
    Dim rsXX As ADODB.Recordset
    Dim cmd As ADODB.Command
    Dim strXXID As String
    Dim intXXType As Integer
    Dim strXXPYSX As String
    Dim intSXH As Integer
    Dim strDMID As String '当前最大的数据字典编号
    
    '检查是否有可以移动的小项
    If lvwOriginal.ListItems.Count < 1 Then Exit Sub
    If lvwOriginal.SelectedItem Is Nothing Then Exit Sub
    

    
    '当前选中小项对方是否已经存在
    For i = 1 To lvwDestination.ListItems.Count
        If lvwDestination.ListItems(i).Text = lvwOriginal.SelectedItem.Text Then
            MsgBox "当前小项已经存在！", vbInformation, "提示"
            Exit Sub
        End If
    Next
    
    '获取对方大项所包含小项的最大ID号
    strXXID = GetXXID(LongToString(cmbDDXiang.ItemData(cmbDDXiang.ListIndex), 4))
    
    '获取对方大项未被占用的最小的顺序号
    strSQL = "select top 1 SXH from SET_SXH" _
            & " where SXH not in (" _
            & "select SXH from SET_XX" _
            & " where left(XXID,4)='" _
            & LongToString(cmbDDXiang.ItemData(cmbDDXiang.ListIndex), 4) & "')" _
            & " order by SXH"
    '借用rsXX
    Set rsXX = New ADODB.Recordset
    rsXX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If Not rsXX.EOF Then
        intSXH = rsXX("SXH")
        rsXX.Close
    Else
        intSXH = 300
    End If
    '添加一条空记录
    strSQL = "insert into SET_XX(XXID) values('" & strXXID & "')"
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = GCon
    cmd.CommandText = strSQL
    cmd.Execute
    
    '获取要拖动小项的全部信息
    strSQL = "select * from SET_XX" _
            & " where XXID='" & Mid(lvwOriginal.SelectedItem.Key, 2) & "'"
    Set rsXX = New ADODB.Recordset
    rsXX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rsXX.RecordCount > 0 Then
        intXXType = rsXX("XXType")
        strXXPYSX = rsXX("XXPYSX")
        '
    
        strSQL = "update SET_XX set" _
                & " XXMC='" & rsXX("XXMC") & "'" _
                & ",KSID='" & LongToString(cmbDKShi.ItemData(cmbDKShi.ListIndex), 2) & "'" _
                & ",DXID='" & LongToString(cmbDDXiang.ItemData(cmbDDXiang.ListIndex), 4) & "'" _
                & ",XXPYSX='" & rsXX("XXPYSX") & "'" _
                & ",XXWBSX='" & rsXX("XXWBSX") & "'" _
                & ",XXNNTY=" & IIf(IsNull(rsXX("XXNNTY")), 0, rsXX("XXNNTY")) _
                & ",XXType=" & IIf(IsNull(rsXX("XXType")), 0, rsXX("XXType")) _
                & ",XXCKSX='" & rsXX("XXCKSX") & "'" _
                & ",XXCKXX='" & rsXX("XXCKXX") & "'" _
                & ",XXDW='" & rsXX("XXDW") & "'" _
                & ",XXSFJRXJ=" & IIf(rsXX("XXSFJRXJ") = True, 1, 0) _
                & ",XXSFYJY=" & IIf(rsXX("XXSFYJY") = True, 1, 0) _
                & ",XXSM='" & rsXX("XXSM") & "'" _
                & ",SXH=" & intSXH _
                & " where XXID='" & strXXID & "'"
        rsXX.Close
        cmd.CommandText = strSQL
        cmd.Execute
        
        '
        strSQL = "select DXPYSX from SET_DX" _
                & " where DXID='" & LongToString(cmbDDXiang.ItemData(cmbDDXiang.ListIndex), 4) & "'"
        Set rsXX = New ADODB.Recordset
        rsXX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        
        strSQL = "alter table [DATA_" & rsXX(0) & "]" _
                & " add [" & strXXPYSX & "]"
        Select Case intXXType
            Case 0
                strSQL = strSQL & " varchar(300)"
            Case 1
                strSQL = strSQL & " varchar(10)"
            Case 2
                strSQL = strSQL & " varchar(300)"
        End Select
        strSQL = strSQL & " null"
        rsXX.Close
        cmd.CommandText = strSQL
        cmd.Execute
        
        '以下复制小项的体检标准
        strSQL = "insert into SET_TJBZDT" _
                & " select BZID,XMID='" & strXXID & "'" _
                & ",NormalVal,CKSX,CKXX,DW,HighInfo,LowInfo,MaxVal,MinVal" _
                & " from SET_TJBZDT" _
                & " where XMID='" & Mid(lvwOriginal.SelectedItem.Key, 2) & "'"
        cmd.CommandText = strSQL
        cmd.Execute
        
        '以下复制小项的数据字典
        '提取源小项的数据字典
        strSQL = "select DMValue from DM_XX" _
                & " where XXID='" & Mid(lvwOriginal.SelectedItem.Key, 2) & "'"
        '借用rsXX
        Set rsXX = New ADODB.Recordset
        rsXX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        If rsXX.RecordCount > 0 Then
            rsXX.MoveFirst
            Do
                If Not IsNull(rsXX("DMValue")) Then
                    '通过循环把这些数据字典复制到新的小项上
                    '首先获取当前最大的字典编号
                    strDMID = GetMaxID("DM_XX", "XXDMID", "00001")
                    
                    '构造查询语句
                    strSQL = "insert into DM_XX values(" _
                            & "'" & strDMID & "'" _
                            & ",'" & strXXID & "'" _
                            & ",'" & rsXX("DMValue") & "'" _
                            & "," & gintManagerID _
                            & ",'" & Date & "')"
                    cmd.CommandText = strSQL
                    cmd.Execute
                End If
                
                rsXX.MoveNext
            Loop Until rsXX.EOF
            rsXX.Close
        End If
        
        lvwDestination.ListItems.Add , "W" & strXXID, lvwOriginal.SelectedItem.Text
    End If
            
    
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

Private Sub cmdOK_Click()
    Unload Me
End Sub

Private Sub Form_Load()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsKShi As ADODB.Recordset
    
    '获取所有科室
    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
            cmbOKShi.AddItem rsKShi("KSMC")
            cmbOKShi.ItemData(cmbOKShi.NewIndex) = rsKShi("KSID")
            
            cmbDKShi.AddItem rsKShi("KSMC")
            cmbDKShi.ItemData(cmbDKShi.NewIndex) = rsKShi("KSID")
            
            rsKShi.MoveNext
        Loop Until rsKShi.EOF
        
        cmbOKShi.ListIndex = 0
        cmbDKShi.ListIndex = 0
    End If
    
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

'根据大项id获取其包含小项的最大id
Private Function GetMaxXX(ByVal strDXID As String) As String
On Error GoTo ErrMsg
    Dim Status
    Dim i As Integer
    Dim strSQL As String
    Dim strXXID As String
    Dim rsXX As ADODB.Recordset
    
    '获取对方大项所包含小项的最大ID号
    strSQL = "select max(XXID) from SET_XX" _
            & " where left(XXID,4)='" & strDXID & "'"
    Set rsXX = New ADODB.Recordset
    rsXX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rsXX.RecordCount > 0 Then
        '原来有小项的情况，最后三位加1
        If IsNull(rsXX(0)) Then
            strXXID = strDXID & "001"
        Else
            strXXID = Right(rsXX(0), 3)
            strXXID = LongToString(Val(strXXID) + 1, 3)
            
            strXXID = strDXID & strXXID
        End If
        rsXX.Close
    Else
        '原来没有的情况，最后加001
        strXXID = strDXID & "001"
    End If
    
    GetMaxXX = strXXID
    Exit Function
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Function

'Private Sub lvwDestination_DragDrop(Source As Control, X As Single, Y As Single)
'    If Source.name = "lvwOriginal" Then
'        cmdDelete_Click
'    End If
'End Sub
'
'Private Sub lvwDestination_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'    lvwDestination.Drag vbBeginDrag
'End Sub
'
'Private Sub lvwOriginal_DragDrop(Source As Control, X As Single, Y As Single)
'    If Source.name = "lvwDestination" Then
'        cmdAdd_Click
'    End If
'End Sub
'
'Private Sub lvwOriginal_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'    lvwOriginal.Drag vbBeginDrag
'End Sub