frmoutdrugget.frm

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

      EndProperty
      Height          =   285
      Left            =   3390
      TabIndex        =   27
      Top             =   30
      Width           =   1815
   End
   Begin VB.Line Line2 
      BorderColor     =   &H80000003&
      X1              =   2895
      X2              =   5745
      Y1              =   345
      Y2              =   345
   End
   Begin VB.Line Line3 
      BorderColor     =   &H80000005&
      X1              =   2880
      X2              =   5730
      Y1              =   330
      Y2              =   330
   End
   Begin VB.Label Label10 
      AutoSize        =   -1  'True
      Caption         =   "病案号:"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   210
      Left            =   45
      TabIndex        =   26
      Top             =   585
      Width           =   735
   End
End
Attribute VB_Name = "frmOutDrugGet"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private SickObj As clsSick
Private WithEvents CmnHlp As frmInputHelp
Attribute CmnHlp.VB_VarHelpID = -1
Private OldSkID As String
Private Sub InitForm()
    Init
End Sub
Private Sub Init()
    hisFormClear Me
    spd.MaxRows = 0
    If Not (SickObj Is Nothing) Then
        Set SickObj = Nothing
    End If
End Sub
Private Sub PutSpread(ByVal Row As Integer, ByVal ItemCode, ByVal ItemName, ByVal Model, _
        ByVal Unit, ByVal Amount, ByVal CPrice, ByVal Factor, ByVal Gprice, ByVal MarkSerial, ByVal Baby)
    Dim i As Integer
    
    gUnitobj.Add ItemCode

    spd.Redraw = False
    spd.Row = Row
    spd.Col = 1
    spd.Text = ItemName
    spd.Col = 2
    spd.Text = Model & " * " & Int(Factor)
    spd.Col = 3
    If gUnitobj(ItemCode).Count = 1 Then
        spd.CellType = SS_CELL_TYPE_EDIT
        spd.Text = Unit
        spd.Lock = True
    Else
        spd.CellType = SS_CELL_TYPE_COMBOBOX
        spd.Lock = False
        For i = 1 To gUnitobj(ItemCode).Count
            spd.TypeComboBoxIndex = -1
            spd.TypeComboBoxString = gUnitobj(ItemCode).Item(i).Unit
            If gUnitobj(ItemCode).Item(i).Unit = Unit Then
                spd.TypeComboBoxCurSel = i - 1
            End If
        Next i
    End If
    spd.Col = 4
    spd.Text = Amount / Factor
    spd.Col = 5
    If CPrice = 0 Then
        spd.Lock = False
    Else
        spd.Lock = True
    End If
    
    spd.Text = CPrice * Factor
    spd.Col = 6
    spd.Text = CPrice * Amount
    spd.Col = 7
    spd.Text = ItemCode
    spd.Col = 8
    spd.Text = Factor
    spd.Col = 9
    spd.Text = Gprice
    spd.Col = 10
    spd.Text = MarkSerial
    spd.Col = 11
    spd.Value = Baby
    spd.Redraw = True
End Sub


Private Sub Form_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn And Me.ActiveControl.Name <> "spd" Then
        hisToActiveCtl(Me).SetFocus
    End If
End Sub

Private Sub Form_Load()
    hisFormToCenter Me, frmMain
    InitForm
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set frmOutDrugGet = Nothing
End Sub

Private Sub lct_PosChanged(ByVal Pos As Long, ByVal OldPos As Long)
   ' FillData
End Sub



Private Sub mcr_Click(ByVal WhichB As UseMaintainCtl.BUTTONKEY)
    Dim ErrDes As String
    Dim TmpObj As Object
    
    Select Case WhichB
        Case BK_ADD
            Set TmpObj = ValidInput(ErrDes)
            If Not (TmpObj Is Nothing) Then
                MsgBox ErrDes, vbCritical
                TmpObj.SetFocus
                Exit Sub
            End If
            If Save Then
                Init
                txtSkID.SetFocus
            Else
                MsgBox gDbObj.ErrDes, vbCritical
            End If
        Case BK_CLEAR
            Init
            txtSkID.SetFocus
        Case BK_EXIT
            Unload Me
        
    End Select
End Sub



Private Sub txtSkID_GotFocus()
    OldSkID = txtSkID
End Sub

Private Sub txtSkID_LostFocus()
    Dim mStr As String
    
    If txtSkID = OldSkID Then Exit Sub
    If txtSkID = "" Then
        Init
        Exit Sub
    End If
    If SickObj Is Nothing Then
        Set SickObj = New clsSick
    End If
    SickObj.SkIDByQuery = txtSkID
    If Not SickObj.IfRegInfo Then
        MsgBox "病案号> " & txtSkID & " <不存在", vbCritical
        Init
        txtSkID.SetFocus
        Exit Sub
    Else
        
        If SickObj.Num <= 0 Then
            MsgBox "病人未住过院!", vbCritical
            Init
            txtSkID.SetFocus
            Exit Sub
        End If
    End If
    Call gfnFillDataBySickRegInfo(Me, SickObj)
    If SickObj.OutDate = "" Then
        lblOutDate = ""
    Else
        lblOutDate = Format(SickObj.OutDate, gstrCOMN_DATE)
    End If
    FillData
End Sub


Public Function Save()
    Dim i As Integer, J As Integer
    Dim MarkSerial As String, ItemName As String
    Dim ItemCode As String, Amount As Integer, CPrice As Currency, GMoney As Currency
    Dim Gprice As Currency, Unit As String, Factor As Integer, Fair As Currency, TotalFair As Currency
    Dim Flag As Integer
    Dim DrugAmountsObj As clsDrugAmounts, MarkSerialSQL As String

  
On Error GoTo errlbl

    If gtydSysConfig.IfDecStore Then
        Set DrugAmountsObj = New clsDrugAmounts
        DrugAmountsObj.Direct = -1
        DrugAmountsObj.DtType = tsH_PATIENT_OUT
        DrugAmountsObj.DsCode = gtydSysConfig.DepCode
        For i = 1 To spd.MaxRows
            spd.Row = i
            spd.Col = 7
            ItemCode = spd.Text
            spd.Col = 1
            ItemName = spd.Text
            spd.Col = 8
            Factor = Val(spd.Text)
            spd.Col = 4
            Amount = Val(spd.Text) * Factor
            spd.Col = 10
            If InStr(MarkSerialSQL, "'" & spd.Text & "',") <= 0 Then
                MarkSerialSQL = MarkSerialSQL & "'" & spd.Text & "',"
            End If
            DrugAmountsObj.Add ItemCode, ItemName, CLng(Amount)
        Next i
        DrugAmountsObj.GetStorage
        If Not DrugAmountsObj.JugeStorageForOut Then
            gDbObj.ErrDes = DrugAmountsObj.Info
            Exit Function
        End If
    End If
    If MarkSerialSQL <> "" Then
        MarkSerialSQL = Left(MarkSerialSQL, Len(MarkSerialSQL) - 1)
    End If
    gDbObj.CNExe.BeginTrans
    If gtydSysConfig.IfDecStore Then
        If Not DrugAmountsObj.UpDateStorage Then
            GoTo errlbl
        End If
    End If
    If MarkSerialSQL <> "" Then
        If Not gDbObj.DBExec("UPDATE FairMarkMain Set Flag =Flag & (255-8), " _
            & " FetchDate = '" & gfnGetTime() & "',FetchHdCode = '" & gtydSysConfig.HdCode _
            & "' WHERE MarkSerial In (" & MarkSerialSQL & ")") Then
            
            GoTo errlbl
        End If
        If Not gDbObj.DBExec("UPDATE FairMarkSub Set DsCode ='" & gtydSysConfig.DepCode & "' " _
            & " WHERE MarkSerial In (" & MarkSerialSQL & ")") Then
            
            GoTo errlbl
        End If
    End If
    Save = True
    gDbObj.CNExe.CommitTrans
    Exit Function
errlbl:
    gDbObj.CNExe.RollbackTrans
End Function


Private Sub Sum()
    Dim i As Integer
    Dim TotalFair As Currency
    
    spd.Col = 6
    For i = 1 To spd.MaxRows
        spd.Row = i
        TotalFair = TotalFair + spd.Text
    Next i
    lblTotalFair = Format(TotalFair, gstrMONEY_FORMAT)
End Sub

Public Function ValidInput(ErrDes As String) As Object
    If SickObj Is Nothing Then
        ErrDes = "必须输入病人信息!"
        Set ValidInput = Me.txtSkID
        Exit Function
    End If
    If spd.MaxRows = 0 Then
        ErrDes = "请输入出院带药项目!"
        Set ValidInput = spd
    End If
    
End Function
Private Sub FillData()
    Dim Sql As String, i As Integer
    
    Sql = "SELECT FairMarkSub.MarkSerial,FairMarkSub.ItemCode,ItemName,Model,FairMarkSub.Unit,FairMarkSub.CPrice," _
        & "FairMarkSub.Amount,FairMarkSub.Factor,FairMarkMain.Flag " _
        & "FROM (FairMarkMain INNER JOIN FairMarkSub ON FairMarkMain.MarkSerial =FairMarkSub.MarkSerial) " _
        & "INNER JOIN m_Drug ON FairMarkSub.ItemCode=m_drug.ItemCode " _
        & " where FairMarkSub.dscode is null AND SkSerial = '" & SickObj.SkSerial & "'" _
        & gfnMakeLimit(gtydSysConfig.ItemCode, "m_drug.Itemcode")
'       & " WHERE FairMarkMain.Flag & 4 =4 AND FairMarkMain.Flag & 8 =8 "
        
    spd.MaxRows = 0
    i = 1
    If gDbObj.GetRs(Sql) > 0 Then
        Do Until gDbObj.Rs.EOF
            spd.MaxRows = spd.MaxRows + 1
            PutSpread i, gDbObj.Rs!ItemCode, gDbObj.Rs!ItemName, gDbObj.Rs!Model, _
                gDbObj.Rs!Unit, gDbObj.Rs!Amount, gDbObj.Rs!CPrice, gDbObj.Rs!Factor, _
                0#, gDbObj.Rs!MarkSerial, IIf((gDbObj.Rs!Flag And 2) = 2, True, False)
            gDbObj.Rs.MoveNext
            i = i + 1
        Loop
        Sum
    End If
End Sub