mdldatabase3.bas

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

        Do While Not rstemp.EOF
            cmbDoctor.AddItem rstemp("Name")
            cmbDoctor.ItemData(cmbDoctor.NewIndex) = rstemp("EmployeeID")
            
            '是否当前医生
            If rstemp("EmployeeID") = gintManagerID Then
                cmbDoctor.ListIndex = cmbDoctor.NewIndex
            End If
            
            rstemp.MoveNext
        Loop
        rstemp.Close
    End If
    Set rstemp = Nothing
    
    LoadAllManager = True
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Function

'显示指定的管理员
Public Sub ShowSpecifyManager(ByRef cmbDoctor As ComboBox, ByVal intManagerID As Integer)
    Dim i As Integer
    
    If cmbDoctor.ListCount < 1 Then Exit Sub
    
    For i = 0 To cmbDoctor.ListCount - 1
        If cmbDoctor.ItemData(i) = CLng(intManagerID) Then
            cmbDoctor.ListIndex = i
            Exit For
        End If
    Next i
End Sub

'**********************************************************************
'打印导引单，决定用哪种模式打印
'参数1：表示某个客户的唯一编号
'返回值：无
'**********************************************************************
Public Function PrintPersonGuider(ByVal lngGUID As Long, _
        Optional ByVal strPreviousSelection As String) As String
    Select Case g_enuGuiderType
        Case PuYa
            Call PrintPersonGuider_PuYa(lngGUID)
        Case QingDaoUniversity
            PrintPersonGuider = PrintPersonGuider_QDU(lngGUID, strPreviousSelection)
        Case Else
            '
    End Select
End Function


'**********************************************************************
'打印导引单，采用普亚模式
'参数1：表示某个客户的唯一编号
'返回值：无
'**********************************************************************
Public Sub PrintPersonGuider_PuYa(ByVal lngGUID As Long, Optional ByVal blnCompose As Boolean = False, _
        Optional ByRef tvwXMu As TreeView, Optional ByVal curTotal As Currency)
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim rsKS As ADODB.Recordset
    Dim blnPrintMoney As Boolean
    '标题坐标及页面设置
    Dim intPage As Integer
    Dim sngTitleTop  As Single          '标题纵坐标
    Dim sngHospitalTop As Single        '单位名称纵坐标
    Dim sngLineInterval As Single       '行间距
    Dim sngCurrX, sngCurrY As Single    '当前打印机横纵坐标
    Dim intLineCount As Integer         '当前页已打印的行数
    Dim i As Integer
    Dim sngContentBeginTop As Single    '项目打印的起始纵坐标
    Dim fntCurrFont As StdFont
    Dim strOldKShi As String            '上次打印的科室
    Dim sngPageBottomTop As Single      '页面最底端线条的坐标
    Dim intContentFontSize As Integer   '内容所用字体的大小
    '客户单位
    Dim sngPersonUnitLeft As Single
    Dim sngPersonUnitTop As Single
    '线条
    Dim sngLineTop As Single
    Dim sngLineLeft As Single
    Dim sngLineWidth As Single
    '控制两列打印
    Dim sngFlag_First As Single
    Dim sngFlag_Second As Single
    Dim sngKShi_First As Single
    Dim sngKShi_Second As Single
    Dim sngXMu_First As Single
    Dim sngXMu_Second As Single
    Dim intCurrentCol As Integer '当前列
    '个人信息坐标
    Dim sngPersonInfoTop As Single
    Dim sngPersonNameLeft As Single
    Dim sngPersonSexLeft As Single
    Dim sngPersonAgeLeft As Single
    Dim sngPersonCardLeft As Single
    Dim sngPersonArchiveLeft As Single
    '个人信息内容
    Dim strPersonName As String
    Dim strPersonSex As String
    Dim strPersonAge As String
    Dim strPersonCard As String
    Dim strPersonArchive As String
    Dim strPersonUnit As String
    '网格坐标
    Dim sngTopLineTop As Single
    Dim sngBottomLineTop As Single
    '组单工具
    Dim lngCount As Long
    Dim strKey As String
    Dim arrDX() As String
    
    If DetectPrinter() = False Then
        MsgBox "您还未安装打印机", vbInformation, "提示"
        Exit Sub
    End If
    
    '设成A4纸
    Printer.ScaleMode = vbMillimeters
    Printer.ScaleWidth = 210
    Printer.ScaleHeight = 297
    '页面参数
    sngTitleTop = 25
    sngHospitalTop = 33
    sngLineInterval = 2
    sngContentBeginTop = 54
    sngLineLeft = 19
    sngLineTop = 52
    sngLineWidth = Printer.ScaleWidth - 2 * sngLineLeft
    sngPageBottomTop = Printer.ScaleHeight - 30
    intContentFontSize = 12
    '标志、科室、项目横坐标
    sngFlag_First = 20: sngFlag_Second = 105
    sngKShi_First = 26: sngKShi_Second = 111
    sngXMu_First = 59: sngXMu_Second = 144
    '个人信息坐标
    sngPersonInfoTop = 40
    sngPersonNameLeft = 20
    sngPersonSexLeft = 50
    sngPersonAgeLeft = 70
    sngPersonCardLeft = 89
    sngPersonArchiveLeft = 147
    '客户单位
    sngPersonUnitLeft = 20
    sngPersonUnitTop = 46
    
    If Not blnCompose Then
        '******************************************************************
        '                       打印个人的导引单
        '******************************************************************
        '检索个人信息
        strSQL = "select * from SET_GRXX" _
                & " where GUID=" & lngGUID
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If rstemp.EOF Then
           MsgBox "当前客户的信息已被损坏，请联系系统管理员！", vbExclamation, "提示"
           GoTo ExitLab
        End If
        strPersonName = rstemp("YYRXM")
        strPersonSex = rstemp("SEX")
        strPersonAge = rstemp("AGE") & ""
        If Val(strPersonAge) <= 0 Then
            strPersonAge = ""
        End If
        strPersonCard = rstemp("YYRSFZH") & ""
        If Not g_blnSelfID Then
            strPersonArchive = rstemp("HealthID")
        Else
            strPersonArchive = rstemp("SelfBH") & ""
        End If
        
        '是否团体人员
        If (IsNull(rstemp("YYID"))) Or (rstemp("YYID") = "") Then
            blnPrintMoney = True
            curTotal = GetTotalMoney_GR(lngGUID)
        Else
            blnPrintMoney = False
        End If
        rstemp.Close
        
        '获取客户单位名称
        strPersonUnit = GetPersonUnit(lngGUID)
        
        '找出当前体检人登记了什么科室的项目
        strSQL = "select GUID,YY_SJDJDX.DXID,DXMC,KSMC" _
                & " from YY_SJDJDX,SET_DX,SET_KSSZ" _
                & " where YY_SJDJDX.GUID=" & lngGUID _
                & " and YY_SJDJDX.DXID=SET_DX.DXID" _
                & " and SET_DX.KSID=SET_KSSZ.KSID" _
                & " order by SET_KSSZ.SXH,SET_DX.SXH"
    Else
        '******************************************************************
        '                             打印组单
        '******************************************************************
        blnPrintMoney = True
        With tvwXMu
            lngCount = 0
            For i = 1 To .Nodes.Count
                If .Nodes(i).Checked = True Then
                    strKey = Mid(.Nodes(i).Key, 2)
                    If Len(strKey) = 4 Then '是组合
                        lngCount = lngCount + 1
                        Exit For
                    End If
                End If
            Next i
        End With
        '检查是否有选择
        If lngCount = 0 Then
            MsgBox "当前尚未选择项目，无需打印！", vbInformation, "提示"
            GoTo ExitLab
        End If
        '创建临时表用于保存项目
        strSQL = "CREATE TABLE " & TempTable _
                & " (DXID Varchar(4))"
        If CreateTable(TempTable, True, strSQL) = False Then GoTo ExitLab
        '把用户选择的项目添加到表中
        With tvwXMu
            For lngCount = 1 To tvwXMu.Nodes.Count
                strKey = Mid(.Nodes(lngCount).Key, 2)
                If .Nodes(lngCount).Checked = True Then
                    If Len(strKey) = 4 Then '说明是大项
                        strSQL = "insert into " & TempTable & "(DXID) values(" _
                                & "'" & strKey & "'" _
                                & ")"
                        GCon.Execute strSQL
                    End If
                End If
            Next lngCount
        End With
        '构建查询语句
        strSQL = "select SET_DX.DXID,DXMC,KSMC from " & TempTable & ",SET_DX,SET_KSSZ" _
                & " where " & TempTable & ".DXID=SET_DX.DXID" _
                & " and SET_DX.KSID=SET_KSSZ.KSID"
    End If
    
    '提取记录
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount = 0 Then
        MsgBox "当前人员未选择项目，无法打印导引单", vbInformation, "提示"
        GoTo ExitLab
    End If
    rstemp.MoveFirst
    
    '初始为第一页
    intPage = 1
    '打印起始信息
    GoSub PrintTitle
    If Not blnCompose Then
        GoSub PrintPersonInfo
    End If
    GoSub PrintLine
    GoSub DrawGrid
    
    '调整字体，准备打印项目
    With Printer
        .FontName = "宋体"
        .FontSize = intContentFontSize
        .FontBold = False
        .FontItalic = False
        .FontUnderline = False
    End With
    
    '设置内容字体
    Set fntCurrFont = New StdFont
    With fntCurrFont
        .Bold = False
        .Italic = False
        .Size = intContentFontSize
        .name = "宋体"
        .Strikethrough = False
        .Underline = False
    End With
        
    intLineCount = 1 '第一行
    sngCurrY = sngContentBeginTop '纵坐标初始化
    intCurrentCol = 1 '初始化为第一列
    Do While Not rstemp.EOF
        If sngCurrY > sngPageBottomTop Then
            intLineCount = 1 '初始化为第一行
            sngCurrY = sngContentBeginTop '纵坐标初始化
            '检查当前是否第一列
            If intCurrentCol = 1 Then
                '不用换页
                intCurrentCol = 2
            Else
                '需要换页
                Printer.NewPage
                intPage = intPage + 1
                intCurrentCol = 1
                GoSub PrintTitle
                If Not blnCompose Then
                    GoSub PrintPersonInfo
                End If
                GoSub PrintLine
                GoSub DrawGrid
                '调整字体
                With Printer
                    .FontName = "宋体"
                    .FontSize = intContentFontSize
                    .FontBold = False
                    .FontItalic = False
                    .FontUnderline = False
                End With
            End If
        End If
        '打印复选框
        If intCurrentCol = 1 Then
            sngCurrX = sngFlag_First
        Else
            sngCurrX = sngFlag_Second
        End If
        Call PrintContents(fntCurrFont, "□", sngCurrX, sngCurrY)