clssickgetdrug.cls

医院门诊医生工作站,vb6 SqlServer

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsSickGetDrug"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder" ,"Yes"
Attribute VB_Ext_KEY = "Collection" ,"clsGetDrug"
Attribute VB_Ext_KEY = "Member0" ,"clsGetDrug"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit

'局部变量，保存集合
'Private mvarSkSerial As String '本地复本

Public SkSerial As String
Public OpSerial As String
Public IsOP As Boolean
Public IsBaby As Boolean
Public BedID As String
Public Name As String
Public Sex As String

Public RemFair As Currency
Public CanDeb As Boolean

Public DepCode As String
Public DcCode As String
Private mCol As Collection
Public Property Get BedNum() As String
    If BedID <> "" Then
        BedNum = Right(BedID, Len(BedID) - InStr(BedID, "#"))
    End If
End Property
Public Property Get SkID() As String
    SkID = Left(SkSerial, Len(SkSerial) - 2)
End Property

Public Function Add(ADVSerial, Num, EndDate, CPrice, Gprice, Unit, ADVFreqID, ADVUsID, _
    PreMarkDate, ModelAmount, Model, itemname, ItemCode, flag, IsTemp, BeginDate) As clsGetDrug
    '创建新对象
    Dim objNewMember As clsGetDrug
    Set objNewMember = New clsGetDrug


    '设置传入方法的属性
    objNewMember.ADVSerial = ADVSerial
    objNewMember.Num = Num
    objNewMember.EndDate = IIf(IsNull(EndDate), "", EndDate)
    objNewMember.CPrice = CPrice
    objNewMember.BeginDate = BeginDate
    objNewMember.Gprice = Gprice
    objNewMember.Unit = Unit
    objNewMember.ADVFreqID = IIf(IsNull(ADVFreqID), "ST", ADVFreqID)
    objNewMember.ADVUsID = IIf(IsNull(ADVUsID), "", ADVUsID)
    objNewMember.PreMarkDate = IIf(IsNull(PreMarkDate), "", PreMarkDate)
    objNewMember.ModelAmount = IIf(IsNull(ModelAmount), gstrSINGLE_ABORT, ModelAmount)
    objNewMember.Model = IIf(IsNull(Model), "", Model)
    objNewMember.itemname = itemname
    objNewMember.ItemCode = ItemCode
    objNewMember.flag = flag
    objNewMember.IsTemp = IsTemp
    mCol.Add objNewMember, ADVSerial & Num


    '返回已创建的对象
    Set Add = objNewMember
    Set objNewMember = Nothing
End Function

Public Property Get Item(vntIndexKey As Variant) As clsGetDrug
Attribute Item.VB_UserMemId = 0
    '引用集合中的一个元素时使用。
    'vntIndexKey 包含集合的索引或关键字，
    '这是为什么要声明为 Variant 的原因
    '语法：Set foo = x.Item(xyz) or Set foo = x.Item(5)
  Set Item = mCol(vntIndexKey)
End Property



Public Property Get Count() As Long
    '检索集合中的元素数时使用。语法：Debug.Print x.Count
    Count = mCol.Count
End Property


Public Sub Remove(vntIndexKey As Variant)
    '删除集合中的元素时使用。
    'vntIndexKey 包含索引或关键字，这是为什么要声明为 Variant 的原因
    '语法：x.Remove(xyz)


    mCol.Remove vntIndexKey
End Sub
Public Sub RemoveByKey(ByVal ADVSerial As String, ByVal Num As Integer)
    '删除集合中的元素时使用。
    'vntIndexKey 包含索引或关键字，这是为什么要声明为 Variant 的原因
    '语法：x.Remove(xyz)
    Dim i As Integer
    
    For i = 1 To Count
        If Item(i).ADVSerial = ADVSerial And Item(i).Num = Num Then
            Remove i
            Exit Sub
        End If
    Next i

End Sub


Public Property Get NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
Attribute NewEnum.VB_MemberFlags = "40"
    '本属性允许用 For...Each 语法枚举该集合。
    Set NewEnum = mCol.[_NewEnum]
End Property


Private Sub Class_Initialize()
    '创建类后创建集合
    Set mCol = New Collection
End Sub


Private Sub Class_Terminate()
    '类终止后破坏集合
    Set mCol = Nothing
End Sub
Public Function TrueNum() As Integer 'Mount 不为0 的 项数
    Dim TmpObj As clsGetDrug
    
    For Each TmpObj In mCol
        If TmpObj.Mount <> 0 Then
            TrueNum = TrueNum + 1
        End If
    Next
End Function


Public Function Save(Optional Trans As Boolean = True, Optional MarkSerial As String = "", Optional Busserial As String = "") As Boolean
    Dim TmpObj As clsGetDrug
    Dim Tserial As String
    Dim Index As Integer
    Dim TotalFair As Currency
    Dim DrugAmountsObj As clsDrugAmounts
    
On Error GoTo Errlbl
    If Trans Then
        If gtydSysConfig.IfDecStore Then
            Set DrugAmountsObj = New clsDrugAmounts
            DrugAmountsObj.Direct = -1
            DrugAmountsObj.DtType = tsH_SICK_OUT
            DrugAmountsObj.DsCode = gtydSysConfig.DepCode
            For Each TmpObj In mCol
                If TmpObj.Status = 1 Then
                    DrugAmountsObj.Add TmpObj.ItemCode, TmpObj.itemname, TmpObj.Mount
                End If
            Next
            DrugAmountsObj.GetStorage
            If Not DrugAmountsObj.JugeStorageForOut Then
                gDbObj.ErrDes = DrugAmountsObj.Info
                Exit Function
            End If
        End If
        gDbObj.CNExe.BeginTrans
        Tserial = gFnGetSerial(stFairMark)
        If gtydSysConfig.IfDecStore Then
            If Not DrugAmountsObj.UpDateStorage Then
                GoTo Errlbl
            End If
        End If
        
    Else
        Tserial = MarkSerial
    End If
    If Busserial = "" Then Busserial = gFnGetSerial(stHouseBusSerial)
    If Not Update_FairMarkMain(HISDbInsert, Tserial, SkSerial, gfnGetTime, _
        gtydSysConfig.HdCode, DepCode, DcCode, _
        flag:=IIf(IsBaby, 2, 0), FetchDate:=gfnGetTime(), FetchHdCode:=gtydSysConfig.HdCode) Then
        
        GoTo Errlbl
    End If
    If gtydSysConfig.IFFoot Then
        If Not Update_House_BusMain(HISDbInsert, Busserial, gtydSysConfig.DepCode, "17", -1, gfnGetTime(), gtydSysConfig.HdCode, _
                SkSerial, "", 0, "摆药", Name) Then
            GoTo Errlbl
        End If
    End If
    Index = 1
    TotalFair = 0
    For Each TmpObj In mCol
        If TmpObj.Status = 1 Then
            TotalFair = TotalFair + TmpObj.InFair
    
            If Not Update_FairMarkSub(HISDbInsert, Tserial, Index, TmpObj.ItemCode, _
                gtydSysConfig.DepCode, TmpObj.Mount, TmpObj.CPrice, _
                1#, TmpObj.Unit, TmpObj.Fair, TmpObj.InFair, _
                gtydSysConfig.DepCode, TmpObj.ADVSerial, TmpObj.Num, TmpObj.Gprice, TmpObj.GMoney) Then
                
                GoTo Errlbl
            End If
            If gtydSysConfig.IFFoot Then
                If Not Update_House_BusSub(HISDbInsert, Busserial, Index, TmpObj.ItemCode, TmpObj.Mount, TmpObj.Gprice, _
                    TmpObj.Mount, TmpObj.CPrice, TmpObj.Fair, TmpObj.Unit, 1#) Then
                    GoTo Errlbl
                End If
            End If
            If IsOP Then
                If Not Update_Operate_ADVDetail(HISDBUpdate, PrevEndDate:=Format(TmpObj.PreMarkDate, _
                    gstrCOMN_DATE_LONG), _
                    UpdateCondition:=" ADVSerial='" & TmpObj.ADVSerial & "'" _
                    & "AND Num=" & TmpObj.Num) Then
                
                    GoTo Errlbl
                End If
            Else
                If Not Update_ADVDetail(HISDBUpdate, PrevEndDate:=Format(TmpObj.PreMarkDate, _
                    gstrCOMN_DATE_LONG), MarkDate:=gfnGetTime(), _
                    UpdateCondition:=" ADVSerial='" & TmpObj.ADVSerial & "'" _
                    & "AND Num=" & TmpObj.Num) Then
                
                    GoTo Errlbl
                End If
            End If
            
            If TmpObj.IsTemp Then  '表明临时医嘱记过帐（不一定都记帐)
                If IsOP Then
                    If Not gDbObj.DBExec(" Update Operate_ADVMain SET Kind=Kind+16" _
                        & " WHERE ADVSerial  = '" & TmpObj.ADVSerial & "' AND Kind & 16 = 0") Then
                        
                        GoTo Errlbl
                    End If
                Else
                    If Not gDbObj.DBExec(" Update ADVMain SET Flag=Flag+16" _
                        & " WHERE ADVSerial  = '" & TmpObj.ADVSerial & "' AND Flag & 16 = 0") Then
                        
                        GoTo Errlbl
                    End If
                End If
            End If
    
            Index = Index + 1
        End If
    Next
    If Not gDbObj.DBExec(" Update SickInfo SET Fair=Fair +" & TotalFair _
        & " WHERE skserial = '" & SkSerial & "'") Then
        
        GoTo Errlbl
    End If
    If Trans Then
        gDbObj.CNExe.CommitTrans
        SetStatus
    End If
    Save = True
    Exit Function
Errlbl:
    If Trans Then
        gDbObj.CNExe.RollbackTrans
    End If
End Function
Public Sub ClearStatus() '只对选中项
    Dim TmpObj As clsGetDrug
    
    For Each TmpObj In mCol
        If TmpObj.Status = 1 Then
            TmpObj.Status = 0
        End If
    Next
End Sub
Public Sub SetStatus() '只对选中项
    Dim TmpObj As clsGetDrug
    
    For Each TmpObj In mCol
        If TmpObj.Status = 1 Then
            TmpObj.Status = 2
        End If
    Next
End Sub

Public Property Get Having() As Boolean
    Dim TmpObj As clsGetDrug
    
    For Each TmpObj In mCol
        If TmpObj.Status = 1 Then
            Having = True '有选中项
            Exit Property
        End If
    Next
End Property
Public Property Get CanKeep() As Boolean
    
    CanKeep = True
    If Not gtydSysConfig.CanKeepBeyondFair And _
        (RemFair - Fair) < gtydSysConfig.DebLimit And Not CanDeb Then
        CanKeep = False
    End If
End Property
Public Property Get Fair() As Currency
    Dim TmpObj As clsGetDrug
    
    For Each TmpObj In mCol
        Fair = Fair + TmpObj.Fair
    Next
End Property