frmxmzh.frm

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

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Object = "{0B81E4A9-BE4E-4AEF-9272-33AB5B51C6FC}#1.0#0"; "XPControls.ocx"
Begin VB.Form frmXMZH 
   BackColor       =   &H00D3DABC&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "项目组合"
   ClientHeight    =   7365
   ClientLeft      =   45
   ClientTop       =   435
   ClientWidth     =   10155
   Icon            =   "frmXMZH.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   7365
   ScaleWidth      =   10155
   StartUpPosition =   2  '屏幕中心
   Begin VB.Frame Frame3 
      BackColor       =   &H00D3DABC&
      Caption         =   "项目组合"
      Height          =   7185
      Left            =   90
      TabIndex        =   9
      Top             =   120
      Width           =   3555
      Begin MSComctlLib.TreeView tvwXMu 
         Height          =   6885
         Left            =   60
         TabIndex        =   10
         Top             =   240
         Width           =   3450
         _ExtentX        =   6085
         _ExtentY        =   12144
         _Version        =   393217
         HideSelection   =   0   'False
         LabelEdit       =   1
         Style           =   7
         Appearance      =   1
      End
   End
   Begin XPControls.XPCommandButton cmdDeleteAll 
      Height          =   375
      Left            =   6570
      TabIndex        =   7
      Top             =   4335
      Width           =   600
      _ExtentX        =   1058
      _ExtentY        =   661
      Caption         =   ">>"
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin XPControls.XPCommandButton cmdAddAll 
      Height          =   375
      Left            =   6570
      TabIndex        =   6
      Top             =   3495
      Width           =   600
      _ExtentX        =   1058
      _ExtentY        =   661
      Caption         =   "<<"
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin XPControls.XPCommandButton cmdDelete 
      Height          =   375
      Left            =   6570
      TabIndex        =   5
      Top             =   2655
      Width           =   600
      _ExtentX        =   1058
      _ExtentY        =   661
      Caption         =   ">"
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin XPControls.XPCommandButton cmdAdd 
      Height          =   375
      Left            =   6570
      TabIndex        =   4
      Top             =   1815
      Width           =   600
      _ExtentX        =   1058
      _ExtentY        =   661
      Caption         =   "<"
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin VB.Frame Frame2 
      BackColor       =   &H00D3DABC&
      Caption         =   "可选项目"
      Height          =   7185
      Left            =   7245
      TabIndex        =   1
      Top             =   120
      Width           =   2850
      Begin MSComctlLib.ListView lvwUnchecked 
         Height          =   6780
         Left            =   75
         TabIndex        =   3
         Top             =   285
         Width           =   2670
         _ExtentX        =   4710
         _ExtentY        =   11959
         View            =   3
         LabelEdit       =   1
         MultiSelect     =   -1  'True
         LabelWrap       =   -1  'True
         HideSelection   =   0   'False
         FullRowSelect   =   -1  'True
         GridLines       =   -1  'True
         _Version        =   393217
         ForeColor       =   -2147483640
         BackColor       =   16777152
         BorderStyle     =   1
         Appearance      =   1
         NumItems        =   1
         BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
            Text            =   "可选项目"
            Object.Width           =   3598
         EndProperty
      End
   End
   Begin VB.Frame Frame1 
      BackColor       =   &H00D3DABC&
      Caption         =   "已选项目"
      Height          =   7185
      Left            =   3690
      TabIndex        =   0
      Top             =   120
      Width           =   2820
      Begin MSComctlLib.ListView lvwChecked 
         Height          =   6780
         Left            =   90
         TabIndex        =   2
         Top             =   285
         Width           =   2610
         _ExtentX        =   4604
         _ExtentY        =   11959
         View            =   3
         LabelEdit       =   1
         MultiSelect     =   -1  'True
         LabelWrap       =   -1  'True
         HideSelection   =   0   'False
         FullRowSelect   =   -1  'True
         GridLines       =   -1  'True
         _Version        =   393217
         ForeColor       =   -2147483640
         BackColor       =   16777152
         BorderStyle     =   1
         Appearance      =   1
         NumItems        =   1
         BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
            Text            =   "已选项目"
            Object.Width           =   3598
         EndProperty
      End
   End
   Begin XPControls.XPCommandButton cmdExit 
      Height          =   375
      Left            =   6570
      TabIndex        =   8
      Top             =   6000
      Width           =   600
      _ExtentX        =   1058
      _ExtentY        =   661
      Caption         =   "退出"
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
End
Attribute VB_Name = "frmXMZH"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim m_strMenu As String

Public Sub ShowForm(ByVal strMenu As String)
    m_strMenu = strMenu
    Me.Show vbModal
End Sub

Private Sub cmdAdd_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strKey As String
    Dim i As Long
    Dim blnSel As Boolean
    
    Me.MousePointer = vbHourglass
    
    '权限验证
    If g_blnIsNew Then
        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, INSERT_W) Then GoTo ExitLab
    End If
    '验证完毕
    
    If cmdAdd.Enabled = False Then GoTo ExitLab
    
    If tvwXMu.SelectedItem Is Nothing Then GoTo ExitLab
    
    strKey = Mid(tvwXMu.SelectedItem.Key, 2)
    Select Case Len(strKey)
        Case 0, 2 '选择了根节点，或者科室
            GoTo ExitLab
        Case 4 '选择了项目组合
            '是否有项目
            If lvwUnchecked.ListItems.Count < 1 Then GoTo ExitLab
            
            '是否有选择
            If lvwUnchecked.SelectedItem Is Nothing Then
                MsgBox "请在可选项目中选择要添加的项目", vbInformation, "提示"
                GoTo ExitLab
            End If
            
            '添加
            With lvwUnchecked
                For i = .ListItems.Count To 1 Step -1
                    If .ListItems(i).Selected = True Then
                        blnSel = True
                        If AddXMuToZH(Mid(.ListItems(i).Key, 2), strKey) = True Then
                            '添加到目的列表
                            lvwChecked.ListItems.Add , .ListItems(i).Key, .ListItems(i).Text
                            
                            '从源列表中删除
                            .ListItems.Remove (i)
                        End If
                    End If
                Next i
            End With
            
            If Not blnSel Then
                MsgBox "请在可选项目中选择要添加的项目", vbInformation, "提示"
            End If
    End Select
    
    EnableCommand
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

'从可选项目中添加指定项目到已选项目中
'参数1：可选项目中的XXID
'参数2：目的组合的DXID
Private Function AddXMuToZH(ByVal strXXID As String, ByVal strDXID As String) As Boolean
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim strDXPYSX As String
    Dim strXXPYSX As String
    Dim intXXType As Integer
    Dim blnHavePhoto As Boolean
    
    AddXMuToZH = False
    
    '首先检查目的组合中是否包含制定项目
    strSQL = "select Count(*) from SET_ZH_Data" _
            & " where XXID='" & strXXID & "'" _
            & " and DXID='" & strDXID & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp(0) > 0 Then GoTo ExitLab
    rstemp.Close
    
    '获取大项拼音缩写
    strSQL = "select DXPYSX from SET_DX" _
            & " where DXID='" & strDXID & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    strDXPYSX = rstemp("DXPYSX")
   ' MsgBox strDXPYSX
    rstemp.Close
    
    '获取小项拼音缩写
    '  MsgBox strXXID
    strSQL = "select XXPYSX,XXType,HavePhoto from SET_XX" _
            & " where XXID='" & strXXID & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    strXXPYSX = rstemp("XXPYSX")
    intXXType = rstemp("XXType")
    blnHavePhoto = CBool(rstemp("HavePhoto"))
  
    rstemp.Close
    
    Set rstemp = Nothing
    
    '开启事务
    GCon.BeginTrans
    On Error GoTo RollBack
    '添加项目到组合数据表中
    strSQL = "insert into SET_ZH_Data(DXID,XXID) values(" _
            & "'" & strDXID & "'" _
            & ",'" & strXXID & "'" _
            & ")"
    GCon.Execute strSQL
    
    '添加数据表字段
    strSQL = "ALTER TABLE " & "[DATA_" & strDXPYSX & "] ADD [" & strXXPYSX & "]"
    If intXXType = 0 Then '说明型小项
        strSQL = strSQL & " VARCHAR(300) NULL"
    Else '数值型小项
        strSQL = strSQL & " VARCHAR(10) NULL"
    End If
    
    If blnHavePhoto Then
        strSQL = strSQL & ",[" & strXXPYSX & PHOTO_FIELD & "] image"
    End If
    
    GCon.Execute strSQL
    '提交事务
    GCon.CommitTrans
    AddXMuToZH = True
    
On Error GoTo 0
    GoTo ExitLab
    
RollBack:
    GCon.RollbackTrans
ErrMsg:
    MsgBoxW Err, vbExclamation
ExitLab:
    '
End Function

Private Sub cmdAddAll_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strKey As String
    Dim i As Long
    
    Me.MousePointer = vbHourglass
    
    '权限验证
    If g_blnIsNew Then
        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, INSERT_W) Then GoTo ExitLab
    End If
    '验证完毕
    
    If cmdAddAll.Enabled = False Then GoTo ExitLab
    
    If tvwXMu.SelectedItem Is Nothing Then GoTo ExitLab
    
    strKey = Mid(tvwXMu.SelectedItem.Key, 2)
    Select Case Len(strKey)
        Case 0, 2 '选择了根节点，或者科室
            GoTo ExitLab
        Case 4 '选择了项目组合
            '是否有项目
            If lvwUnchecked.ListItems.Count < 1 Then GoTo ExitLab
            
            '是否有选择
            If lvwUnchecked.SelectedItem Is Nothing Then
                MsgBox "请在可选项目中选择要添加的项目", vbInformation, "提示"
                GoTo ExitLab
            End If
            
            '添加
            With lvwUnchecked
                For i = .ListItems.Count To 1 Step -1
                    If AddXMuToZH(Mid(.ListItems(i).Key, 2), strKey) = True Then
                        '添加到目的列表
                        lvwChecked.ListItems.Add , .ListItems(i).Key, .ListItems(i).Text
                        
                        '从源列表中删除
                        .ListItems.Remove (i)
                    End If
                Next i
            End With
    End Select
    
    EnableCommand
    
    GoTo ExitLab