modulejkdamain.bas

医院管理方面的例子

Attribute VB_Name = "ModuleJkdaMain"
Option Explicit
Public PStrVer          As String           '系统版本 : 0-网络版；  1-单机版

Public PStrFlDLID       As String           '大类ID
Public PStrFlYPDW       As String           '药品单位
Public PStrFlZLDW       As String           '诊疗单位
Public PStrFlYPJX       As String           '药品剂型
Public PStrFlMZ         As String           '民族
Public PStrFlJG         As String           '籍贯
Public PStrFlGJ         As String           '国籍
Public PStrFlZY         As String           '职业
Public PStrFlHYZK       As String           '婚姻状况
Public PStrFlQQGX       As String           '亲情关系
Public PStrFlDZ         As String           '地址
Public PStrFlMZFP       As String           '门诊发票项目
Public PStrFlZYFP       As String           '住院发票项目
Public PStrFlZYMX       As String           '住院明细项目
Public PStrFlCWTJ       As String           '财务统计项目
Public PStrFlGHFL       As String           '挂号分类项目

Public PStrUserID       As String           '操作员编号
Public PStrUserName     As String           '操作员姓名
Public PStrCjyhbh       As String           '超级用户

Public PStrSqzID        As String           '社区站编号
Public PStrSqzMC        As String           '社区站名称

Public PStrSqzxID       As String           '社区中心编号
Public PStrSqzxMC       As String           '社区中心名称
Public PcnnHisDb        As ADODB.Connection

Public Sub Main()

    '数据库连接
    Set PcnnHisDb = New ADODB.Connection
    Dim CnnDB   As cls_base_cnndb.ClassCnnDB
    Set CnnDB = New cls_base_cnndb.ClassCnnDB
    Set PcnnHisDb = CnnDB.PropGetDbCnn
    PStrVer = CnnDB.PropVerFlag
    
    '系统登录
    FrmBase_Pwd.Show
End Sub

Public Sub ProcAddCmbItem(CmbSend As ComboBox, AdoRsSend As ADODB.Recordset)
    CmbSend.Clear
    If Not (AdoRsSend.EOF Or AdoRsSend.BOF) Then AdoRsSend.MoveLast: AdoRsSend.MoveFirst
    Do While Not AdoRsSend.EOF
        CmbSend.AddItem AdoRsSend.Fields(1)
        CmbSend.ItemData(CmbSend.NewIndex) = AdoRsSend.Fields(0)
        AdoRsSend.MoveNext
    Loop
    If CmbSend.ListCount > 0 Then CmbSend.ListIndex = CmbSend.ListCount - 1
End Sub

Public Function FunGetItemName(CmbTemp As ComboBox, SStrTemp As String) As String
    Dim IntTemp As Integer
    For IntTemp = 0 To CmbTemp.ListCount - 1
        If CStr(CmbTemp.ItemData(IntTemp)) = SStrTemp Then
            FunGetItemName = CmbTemp.List(IntTemp)
            Exit For
        End If
    Next IntTemp
End Function

'清除垃圾数据
Public Sub ProcDelRubbish()
    '开始事务
    PcnnHisDb.BeginTrans
    'PcnnHisDb.Execute "DELETE FROM aqgl_yhqx WHERE "
    '判断事务状态
    If CBool(PcnnHisDb.State And adStateExecuting) Then
        PcnnHisDb.Cancel
        PcnnHisDb.RollbackTrans
        MsgBox "操作失败，请重试。", vbCritical, "提示"
        Exit Sub
    Else
        PcnnHisDb.CommitTrans
    End If
End Sub

Public Sub ProCopyMhflexToMsflex(MhFlexSend As MSHFlexGrid, MsflexSend As MSFlexGrid)
    Dim IntRow  As Integer
    Dim IntCol  As Integer
    
    With MsflexSend
        .Rows = MhFlexSend.Rows
        .Cols = MhFlexSend.Cols
        For IntRow = 0 To .Rows - 1
            For IntCol = 0 To .Cols - 1
                .TextMatrix(IntRow, IntCol) = MhFlexSend.TextMatrix(IntRow, IntCol)
            Next IntCol
        Next IntRow
    End With
End Sub

Public Function FunGetDateTime() As String  '获取系统时间
    
    Dim AdoRsDateTime As ADODB.Recordset
    Set AdoRsDateTime = New ADODB.Recordset
    
    If PStrVer = "0" Then
        AdoRsDateTime.Open "SELECT GetDate() ", PcnnHisDb, adOpenDynamic
        FunGetDateTime = Format(CStr(AdoRsDateTime.Fields(0)), "yyyy-mm-dd hh:mm:ss")
        AdoRsDateTime.Close: Set AdoRsDateTime = Nothing
    Else
        FunGetDateTime = Format(CStr(Now), "yyyy-mm-dd hh:mm:ss")
    End If
End Function

Public Function FunGetLsh() As String  '获取流水号
    
    Dim StrDateTime As String
    Dim AdoRsLsh    As ADODB.Recordset
    Set AdoRsLsh = New ADODB.Recordset
    
    StrDateTime = FunGetDateTime
    
    If PStrVer = "0" Then
        AdoRsLsh.Open " SELECT lsh FROM base_lsh " _
                    & " WHERE czyid='" + PStrUserID + "' AND " _
                    & " CONVERT(Char(10),czsj,21)='" + Format(StrDateTime, "yyyy-mm-dd") + "' ", PcnnHisDb, adOpenDynamic
    End If
    
    If PStrVer = "1" Then
        AdoRsLsh.Open " SELECT lsh FROM base_lsh " _
                    & " WHERE czyid='" + PStrUserID + "' AND " _
                    & " Format(czsj,'yyyy-mm-dd')='" + Format(StrDateTime, "yyyy-mm-dd") + "' ", PcnnHisDb, adOpenDynamic

    End If
        
    '启动事务
    PcnnHisDb.BeginTrans
    
    If (AdoRsLsh.EOF Or AdoRsLsh.BOF) Or IsNull(AdoRsLsh.Fields(0)) Then
        FunGetLsh = Format(StrDateTime, "yyyymmdd") & Format(PStrUserID, "000") & "001"
        PcnnHisDb.Execute "INSERT INTO base_lsh(czsj,czyid,lsh) VALUES(" _
                      & " '" + StrDateTime + "','" + PStrUserID + "',1)"
    Else
    
        FunGetLsh = Format(StrDateTime, "yyyymmdd") & Format(PStrUserID, "000") & Format(AdoRsLsh.Fields(0), "000")
        If PStrVer = "0" Then
            PcnnHisDb.Execute " Update base_lsh SET lsh = lsh + 1 " _
                            & " WHERE czyid = '" + PStrUserID + "' AND CONVERT(Char(10),czsj,21)='" + Format(StrDateTime, "yyyy-mm-dd") + "' "
        Else
            PcnnHisDb.Execute " Update base_lsh SET lsh = lsh + 1 " _
                            & " WHERE czyid = '" + PStrUserID + "' AND Format(czsj,'yyyy-mm-dd')='" + Format(StrDateTime, "yyyy-mm-dd") + "' "
        End If
        
    End If
    AdoRsLsh.Close: Set AdoRsLsh = Nothing
    
    '判断事务状态
    If CBool(PcnnHisDb.State And adStateExecuting) Then
        PcnnHisDb.Cancel
        PcnnHisDb.RollbackTrans
        MsgBox "产生流水号失败，请重试。", vbCritical, "提示"
        FunGetLsh = ""
    Else
        PcnnHisDb.CommitTrans
    End If
End Function


Public Sub ProcAdoRsToMsFlex(SAdoRs As ADODB.Recordset, MsFlex As MSFlexGrid)
    
    Dim IntRow  As Integer, IntCol  As Integer
    
    With MsFlex
        .Clear
        If Not (SAdoRs.EOF Or SAdoRs.BOF) Then SAdoRs.MoveLast: SAdoRs.MoveFirst
        
        '字段
        .Rows = SAdoRs.Fields.Count
        .Cols = SAdoRs.RecordCount + 1
        For IntRow = 0 To SAdoRs.Fields.Count - 1
            .TextMatrix(IntRow, 0) = IIf(IsNull(SAdoRs.Fields(IntRow).Name), "", Trim(SAdoRs.Fields(IntRow).Name))
        Next IntRow
        .ColWidth(0) = 1500
        
        '记录
        IntCol = 1
        Do While Not SAdoRs.EOF
            For IntRow = 0 To SAdoRs.Fields.Count - 1
                .TextMatrix(IntRow, IntCol) = IIf(IsNull(SAdoRs.Fields(IntRow)), "", Trim(SAdoRs.Fields(IntRow)))
            Next IntRow
            IntCol = IntCol + 1
            SAdoRs.MoveNext
        Loop
    
        '行编辑
        For IntRow = 0 To .Rows - 1
            .RowHeight(IntRow) = 300
        Next IntRow
        
        '列编辑
        For IntCol = 0 To .Cols - 1
            .ColWidth(IntCol) = 1300
        Next IntCol
    End With
End Sub