frmaddserappointments.frm

This file came from Planet-Source-Code.com...the home millions of lines of source code You can view

      Resolution      =   4
      ScreenHeight    =   1024
      ScreenWidth     =   1280
      ScreenHeightDT  =   1024
      ScreenWidthDT   =   1280
      FormHeightDT    =   12195
      FormWidthDT     =   13860
      FormScaleHeightDT=   11685
      FormScaleWidthDT=   13740
      ResizeFormBackground=   -1  'True
      ResizePictureBoxContents=   -1  'True
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      BackColor       =   &H00FF8080&
      Caption         =   "HOSPITAL SERVICE APPOINTMENT"
      BeginProperty Font 
         Name            =   "Verdana"
         Size            =   18
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FFFFFF&
      Height          =   435
      Left            =   3600
      TabIndex        =   23
      Top             =   360
      Width           =   7035
   End
End
Attribute VB_Name = "frmAddSerAppointments"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim flex As Integer
Dim co, del_i  As Integer
Dim dupid As String
Dim rgrid, COUNT1, rs As Integer
Dim ch, ch1 As Integer

Private Sub Calendar1_Click()
DTPDate1.Value = Calendar1.Value
End Sub

Private Sub cmbHospitalServiceID_Change()
fdata.RowSel = 1
cmdSerSched_Click


Dim rsSerPat As Recordset
Set rsSerPat = New ADODB.Recordset

flex = 20
fra.Visible = True
cmdPatSel.Visible = False
cmdDocIDSel.Visible = True

If ch = 0 Then

If Trim(cmbHospitalServiceID) = "" Or Len(cmbHospitalServiceID) = 0 Then
    rsSerPat.Open "select * from Services", cnPatients, adOpenDynamic, adLockPessimistic
Else
    rsSerPat.Open "select * from Services where Channel_Service_ID like '" & UCase(Trim(cmbHospitalServiceID.Text)) & "%'", cnPatients, adOpenDynamic, adLockPessimistic
End If

If rsSerPat.RecordCount > 0 Then
    rsSerPat.MoveFirst
    fdata.clear
    fdata.FixedRows = 1
    fdata.Rows = 2
    fdata.FormatString = "Service ID" & vbTab & "Service Name" & vbTab & "Duration" & vbTab & "Charge" & vbTab & "Notes"
    fdata.ColWidth(0) = 1500
    fdata.ColWidth(1) = 1800
    fdata.ColWidth(2) = 2000
    fdata.ColWidth(3) = 2000
    'fdata.ColWidth(4) = 2000
    fdata.TextMatrix(1, 0) = rsSerPat.Fields(0)
    fdata.TextMatrix(1, 1) = rsSerPat.Fields(1)
    fdata.TextMatrix(1, 2) = rsSerPat.Fields(2)
    fdata.TextMatrix(1, 3) = rsSerPat.Fields(3)
    'fdata.TextMatrix(1, 4) = rsSerPat.Fields(4)
    rsSerPat.MoveNext
    
    While Not rsSerPat.EOF
        fdata.AddItem rsSerPat.Fields(0) & vbTab & rsSerPat.Fields(1) & vbTab & rsSerPat.Fields(2) & vbTab & rsSerPat.Fields(3) & vbTab & rsSerPat.Fields(4)
        rsSerPat.MoveNext
    Wend
Else
MsgBox "Name/ID Doesn't Exist", vbCritical + vbOKOnly, "Invalid Name/ID"
fdata.clear
fdata.FixedRows = 1
fdata.Rows = 2
fdata.FormatString = "Service ID" & vbTab & "Service Name" & vbTab & "Duration" & vbTab & "Charge" & vbTab & "Notes"
    fdata.ColWidth(0) = 1500
    fdata.ColWidth(1) = 1800
    fdata.ColWidth(2) = 2000
    fdata.ColWidth(3) = 2000
    fdata.ColWidth(4) = 2000
End If
rsSerPat.Close
End If













End Sub

Private Sub cmbHospitalServiceID_Click()
cmbHospitalServiceID_Change
cmdSerSched_Click
End Sub

Private Sub cmbHospitalServiceID_KeyPress(KeyAscii As Integer)

flex = 20
If KeyAscii = 13 Then
fra.Visible = True
fdata.SetFocus
fdata.RowSel = 1
ElseIf KeyAscii = 27 Then
fra.Visible = False
End If


End Sub

Private Sub cmbPatientID_Change()
fdata.RowSel = 1


Dim rsSerPat As Recordset
Set rsSerPat = New ADODB.Recordset

flex = 10
fra.Visible = True
cmdPatSel.Visible = True
cmdDocIDSel.Visible = False



If ch = 0 Then

If Trim(cmbPatientID.Text) = "" Or Len(cmbPatientID.Text) = 0 Then
    rsSerPat.Open "select * from Patient_Details", cnPatients, adOpenDynamic, adLockPessimistic
Else
    rsSerPat.Open "select * from Patient_Details where Patient_ID like '" & UCase(Trim(cmbPatientID.Text)) & "%'", cnPatients, adOpenDynamic, adLockPessimistic
End If

If rsSerPat.RecordCount > 0 Then
    rsSerPat.MoveFirst
    fdata.clear
    fdata.FixedRows = 1
    fdata.Rows = 2
    fdata.FormatString = "Patient ID" & vbTab & "First Name" & vbTab & "Last Name" & vbTab & "Gender" & vbTab & "Address"
    fdata.ColWidth(0) = 1500
    fdata.ColWidth(1) = 1800
    fdata.ColWidth(2) = 1800
    fdata.ColWidth(3) = 1600
    fdata.ColWidth(4) = 1600
    fdata.TextMatrix(1, 0) = rsSerPat.Fields(0)
    fdata.TextMatrix(1, 1) = rsSerPat.Fields(1)
    fdata.TextMatrix(1, 2) = rsSerPat.Fields(2)
    fdata.TextMatrix(1, 3) = rsSerPat.Fields(3)
    fdata.TextMatrix(1, 4) = rsSerPat.Fields(4)
    rsSerPat.MoveNext
    
    While Not rsSerPat.EOF
        fdata.AddItem rsSerPat.Fields(0) & vbTab & rsSerPat.Fields(1) & vbTab & rsSerPat.Fields(2) & vbTab & rsSerPat.Fields(3) & vbTab & rsSerPat.Fields(4)
        rsSerPat.MoveNext
    Wend
Else
MsgBox "Name/ID Doesn't Exist", vbCritical + vbOKOnly, "Invalid Name/ID"
fdata.clear
fdata.FixedRows = 1
fdata.Rows = 2
fdata.FormatString = "Patient ID" & vbTab & "First Name" & vbTab & "Last Name" & vbTab & "Gender" & vbTab & "Address"
fdata.ColWidth(0) = 1500
fdata.ColWidth(1) = 1800
fdata.ColWidth(2) = 1800
fdata.ColWidth(3) = 1000
fdata.ColWidth(4) = 1100
End If
rsSerPat.Close
End If





End Sub

Private Sub cmbPatientID_Click()
cmbPatientID_Change
End Sub

Private Sub cmbPatientID_KeyPress(KeyAscii As Integer)
flex = 10
If KeyAscii = 13 Then
fra.Visible = True
fdata.SetFocus
fdata.RowSel = 1
ElseIf KeyAscii = 27 Then
fra.Visible = False

End If
End Sub

Private Sub cmdAddApointment_Click()

'On Error GoTo AddErr

Dim rsAddBill As Recordset
Dim rsAddAppointment As Recordset
Dim rsInfo As New Recordset
Dim rsSched As Recordset
Dim rsPrevApp As Recordset

Dim StrDoctorID As String
Dim StrServiceID As String
Dim PID As String
Dim strTime As String
Dim BID As String
Dim strAvailDays As String
Dim strDocIn As String
Dim strDocOut As String
Dim strDate As String
Dim strAll As String
Dim strDIn() As String
Dim strDOut() As String
Dim arrDays() As String

Dim ID As Boolean
Dim flag As Boolean
Dim proceed As Boolean
Dim AppPos As Boolean

Dim i As Integer
Dim NoOfSchedules As Integer
Dim fl As Integer

Dim newTime As Double
Dim newTime2 As Double
Dim strInTime As Date
Dim strOutTime As Date




Set rsAddAppointment = New ADODB.Recordset
Set rsInfo = New ADODB.Recordset
Set rsSched = New ADODB.Recordset
Set rsAddBill = New ADODB.Recordset
Set rsPrevApp = New ADODB.Recordset


        ' Adding data to the Service_Appointment_Bill table
        strTime = DTPTime1.Value
        
                
        BID = Functions.UID(6, "OPBID_")    'Generate random Bill ID
        rsAddBill.Open "Select * from Service_Appointment_Bill", cnPatients, adOpenKeyset, adLockPessimistic
        While rsAddBill.EOF = False
            If rsAddBill(0) = BID Then  ' If Bill ID found Generate Another Bill ID
                BID = Functions.UID(6, "OPBID_")
                rsAddBill.MoveFirst
            End If
            rsAddBill.MoveNext
        Wend

            StrServiceID = cmbHospitalServiceID.Text
    
            rsAddAppointment.Open "Select * from Service_Appointment", cnPatients, adOpenKeyset, adLockPessimistic
            rsInfo.Open "Select * from Services where Channel_Service_ID='" & StrServiceID & "'", cnPatients, adOpenKeyset, adLockPessimistic
    
            If rsInfo.EOF = False Then
                strAmount = rsInfo![Charge_For_Service]
            End If

            
                    ' Assigning temporary Values
                    HospitalCharge = 200
                    Discount = 20
                    Debug.Print strAmount
                    GrandTotal = HospitalCharge + strAmount
                    NetValue = GrandTotal - Discount
                    AppBillID = BID
                    BillPatientID = cmbPatientID
        
                    ' End of BillData
            
            
            
    
            PID = Functions.UID(6, "SApp_")
            While rsAddAppointment.EOF = False
                If rsAddAppointment(0) = PID Then
                    PID = Functions.UID(6, "SApp_")
                    rsAddAppointment.MoveFirst
                    flag = True
                Else
                    flag = False
                End If
      
                rsAddAppointment.MoveNext
    
            Wend
        
            If cmbPatientID = "" Then
                MsgBox "Please enter a valid patient ID", vbCritical, "Out Patient Details"
                Exit Sub
            End If
            If cmbHospitalServiceID = "" Then
                MsgBox "Please enter a valid Service ID", vbCritical, "Out Patient Details"
                Exit Sub
            End If
            
            If DTPDate1.Value < Date Then
                MsgBox "Appointment Date Should Be Greater Than Current Date", vbCritical, "Invalid Date"
                Exit Sub
            End If
            If DTPDate1.Value = Date And strTime < Time Then
                MsgBox "Appointment Time Should Be Greater Than Current Time", vbCritical, "Invalid Date"
                rsAddBill.Close
                rsAddAppointment.Close
                rsInfo.Close
                Exit Sub
            End If
        
            Debug.Print StrServiceID
            rsSched.Open "Select * from Service_Schedule_Details where Service_ID='" & StrServiceID & "'", cnPatients, adOpenKeyset, adLockPessimistic
            
            ' Retreive Doctor Available days from the table
            While rsSched.EOF = False
                strAvailDays = strAvailDays & rsSched![Service_AvaiDate] & "..."
                strDocIn = strDocIn & rsSched![Service_Starts] & "..."
                strDocOut = strDocOut & rsSched![Service_Ends] & "..."
                rsSched.MoveNext
            Wend
            
            arrDays() = Split(strAvailDays, "...")
            strDIn() = Split(strDocIn, "...")
            strDOut() = Split(strDocOut, "...")
            
                   
            
            strDate = Left(Format(DTPDate1.Value, "dddd"), 3)
                       
            For i = 0 To UBound(arrDays)
                If InStr(1, arrDays(i), Left(Format(DTPDate1.Value, "dddd"), 3)) > 0 Then
                    AppPos = True ' Service is available on the selected date
                End If
            Next i