摘要:LIBNameSpace.vb
LIBNamespace.vbImports ...System.Data.OleDb 
Imports System.Windows.Forms 
"nsForm"#Region "nsForm" 
Namespace nsForm ' In this Namespace, ' Contains functions that call a new screen. Public Module mForm ' Used in : Forgot ' Desc : Easy call DoctorInquiry Screen, Standard Code ' History : ' 2009-XX-XX - Create this function 
Public Sub DoctorInquiry() Sub DoctorInquiry(ByVal psDoctorCode As String) Try SetWaitMouseCursor() Dim scrDoctor As New frmDoctor scrDoctor.msDoctorCode = psDoctorCode SetDefaultMouseCursor() Call scrDoctor.ShowDialog() Call scrDoctor.Dispose() Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try 
End Sub ' Used in : Forgot ' Desc : Easy call PDFReader Screen, Standard Code ' History : ' 2009-XX-XX - Create this function Public Sub PDFReader() Sub PDFReader(ByVal psFilePath As String) Try Dim scrPDFReader As New frmPDFReader scrPDFReader.msFileName = psFilePath Call scrPDFReader.ShowDialog() Call scrPDFReader.Dispose() Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub End Module End Namespace #End Region "nsControlEnable"#Region "nsControlEnable" Namespace nsControlEnable ' In this Namespace, ' Contains functions that enable or disblae control Public Module mControlEnable ' Used in : Forgot, seems RRR ' Desc : When user key in Text in psTxtBox, then enable the psObject ' else , disable the psObject ' History : ' 2009-XX-XX - Create this function Public Sub KeyInTextThenEnableObject() Sub KeyInTextThenEnableObject(ByVal psTxtBox As Object, ByVal psObject As Object) Try If TypeOf psObject Is C1.Win.C1List.C1Combo Then If psTxtBox.text <> BLANK Then psObject.Enabled = True Else psObject.Enabled = False psObject.text = BLANK End If Else Select Case psObject.GetType.Name Case "TextBox" If psTxtBox.text <> BLANK Then psObject.Enabled = True Else psObject.Enabled = False psObject.text = BLANK End If End Select End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub End Module End Namespace #End Region "nsCodeToDesc"#Region "nsCodeToDesc" Namespace nsCodeToDesc ' In this Namespace, ' Contains functions that translate Code to Description Public Module mCodeToDesc ' Used in : Forgot ' Desc : Easy & Standard Code ' e.g. Input - sSex("M") ' Return - "Male" ' History : ' 2009-XX-XX - Create this function Public Function sSex() Function sSex(ByVal psCode As String) As String sSex = BLANK Try Select Case psCode Case "M" sSex = "Male" Case "F" sSex = "Female" End Select Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function End Module End Namespace #End Region "nsSQL"#Region "nsSQL" Namespace nsSQL ' In this Namespace, ' Contains functions that About SQL execute/ SQLString/ Checking/ Loading . Public Module mSQL ' Used in : Forgot ' Desc : Check the DB having 1 row record or not. ' Has record = true ' History : ' 2009-02-23 - Create this function Public Function bSQLExistRecord() Function bSQLExistRecord(ByVal psSQLString As String) As Boolean ' bSQLExistRecord : bSQLExistRecord = False Try Dim drSQL As OleDbDataReader Dim cmSQL As OleDbCommand cmSQL = New OleDbCommand(psSQLString, gcnOLEDBHIS) drSQL = cmSQL.ExecuteReader() Try While drSQL.Read bSQLExistRecord = True Exit Function End While Finally Call drSQL.Close() Call cmSQL.Dispose() End Try Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function ' Used in : Many Projects ' Desc : Easy to Execute 1 SQL. ' if need to execute more than 1 ' We should use the ClassSQLExecuteHelper directly. ' History : ' 2009-XX-XX - Create this function Public Function bSQLExecute() Function bSQLExecute(ByVal psSQLString As String) As Boolean bSQLExecute = False Try Dim clsSQLExecuteHelper As New ClassSQLExecuteHelper clsSQLExecuteHelper.AddSQL(psSQLString) bSQLExecute = clsSQLExecuteHelper.bExecute() Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function ' Used in : Many Projects ' Desc : Used to check DBconnection. ' Hoi think it can be enhanced, as i still do not clear about how is it work. ' History : ' 2009-XX-XX - Create this function Public Function bCheckDBConnection() Function bCheckDBConnection() As Boolean bCheckDBConnection = False Try If My.Computer.Network.IsAvailable Then If gcnOLEDBHIS.State = ConnectionState.Open Then bCheckDBConnection = True Else gcnOLEDBHIS.Open() End If End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function ' Used in : Many Projects ' Desc : Load 1 field from database. ' History : ' 2009-XX-XX - Create this function Public Function oSQLLoadOneField() Function oSQLLoadOneField(ByVal psSQLString As String, ByVal psFieldName As String) As Object oSQLLoadOneField = BLANK Try Dim ClsRecordLoadHelper As New ClassRecordLoadHelper With ClsRecordLoadHelper .SetConnection(psSQLString) Try If .bReadStart Then oSQLLoadOneField = .oLoadSQLField(psFieldName) End If Finally .bReadEnd() End Try End With Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function ' Used in : Many Projects ' Desc : Login Log ' History : ' 2009-XX-XX - Create this function Public Function bUpdateLoginInfo() Function bUpdateLoginInfo(ByVal psUserCode As String) As Boolean bUpdateLoginInfo = False Try Dim lsSQLString As String = BLANK Dim ClsSQLSaveHelper As New ClassSQLSaveHelper With ClsSQLSaveHelper .TableName = "HIS_User" .AddSearchKey("User_Code", psUserCode) .SQLExtraCriteria = BLANK .AddField("Last_Func_Code", APP_CODE) .AddField("Last_Login", Now) .AddField("Last_Logout", System.DBNull.Value) .AddField("LastUpdate", Now) lsSQLString = .sGenerateSQLUpdate End With bUpdateLoginInfo = nsSQL.bSQLExecute(lsSQLString) If bUpdateLoginInfo = False Then MsgBoxOkOnly("Error in UpdateLoginInfo") End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function ' Used in : Many Projects ' Desc : Logout Log ' History : ' 2009-XX-XX - Create this function Public Function bUpdateLogoutInfo() Function bUpdateLogoutInfo(ByVal psUserCode As String) As Boolean bUpdateLogoutInfo = False Try Dim lsSQLString As String = BLANK Dim ClsSQLSaveHelper As New ClassSQLSaveHelper With ClsSQLSaveHelper .TableName = "HIS_User" .AddSearchKey("User_Code", psUserCode) .SQLExtraCriteria = BLANK .AddField("Last_Logout", Now) .AddField("LastUpdate", Now) lsSQLString = .sGenerateSQLUpdate End With bUpdateLogoutInfo = nsSQL.bSQLExecute(lsSQLString) If bUpdateLogoutInfo = False Then MsgBoxOkOnly("Error in UpdateLogoutInfo") End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function ' Used in : LOE...forgot XD ' Desc : Login Checking , used for some security function. ' History : ' 2009-XX-XX - Create this function Public Function bLogin() Function bLogin() As Boolean bLogin = False Try Dim scrLogin As New frmLoginNoDB scrLogin.Text = scrLogin.Text & " - " & APP_NAME If scrLogin.ShowDialog = DialogResult.OK Then bLogin = True End If scrLogin.Dispose() Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function ' Used in : Forgot ' Desc : Relogin? May be OPD use it. ' History : ' 2009-07-23 - Create this function Public Function bRelogin() Function bRelogin() As Boolean bRelogin = False Try Dim scrRelogin As New frmReLogin Call scrRelogin.ShowDialog() If scrRelogin.DialogResult = Windows.Forms.DialogResult.OK Then bRelogin = True End If scrRelogin.Dispose() Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function ' Used in : Cath lab reporting system ' Desc : Easy Code, just pass field, value and condition. ' e.g. Input - sSQLCriteria_And_XX_LikeOrEqual_YY("Patient_No","PH200806000123",True) ' Return - " And Patient_no = '%PH200806000123%' " ' History : ' 2009-XX-XX - Create this function Public Function sSQLCriteria_And_XX_LikeOrEqual_YY() Function sSQLCriteria_And_XX_LikeOrEqual_YY(ByVal psSQLFieldName As String, ByVal psFieldValue As String, Optional ByVal pblike As Boolean = False, Optional ByVal pbSingleLike As Boolean = False) As String sSQLCriteria_And_XX_LikeOrEqual_YY = BLANK Try If psFieldValue = BLANK Then Exit Function End If psFieldValue = Trim(psFieldValue) If pblike = True Then If pbSingleLike = True Then sSQLCriteria_And_XX_LikeOrEqual_YY = " And " & psSQLFieldName & " like " & VarSQLString(psFieldValue & "%") Else sSQLCriteria_And_XX_LikeOrEqual_YY = " And " & psSQLFieldName & " like " & VarSQLString("%" & psFieldValue & "%") End If Else sSQLCriteria_And_XX_LikeOrEqual_YY = " And " & psSQLFieldName & " = " & VarSQLString(psFieldValue) End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function End Module End Namespace #End Region "nsSQLGet"#Region "nsSQLGet" Namespace nsSQLGet ' In this Namespace, ' Contains functions that Getting Data from SQL. Public Module mSQLGet ' Used in : Forgot ' Desc : pass Usercode to get Fullname ' e.g. Input - sUserFullName("MOLH") ' Return - " MO LAM HOI" ' History : ' 2009-XX-XX - Create this function Public Function sUserFullName() Function sUserFullName(ByVal psUserCode As String) As String sUserFullName = BLANK Try Dim lsSQLString As String = BLANK Dim ClsSQLLoadHelper As New ClassSQLLoadHelper With ClsSQLLoadHelper .TableName = "HIS_User a " .SQLExtraSelect = BLANK .SQLExtraCriteria += " a.User_Code = " & VarSQLString(psUserCode) .AddRequiredField("a.User_Full_Name") .SQLOrder = BLANK lsSQLString = .sGenerateSqlSelect sUserFullName = .oSQLLoadOneField("User_Full_Name") End With Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function ' Used in : Forgot ' Desc : pass Doctor code to get Fullname ' e.g. Input - sDoctorFullName("1234") ' Return - " CHAN TAI MAN 陳大文" ' History : ' 2009-XX-XX - Create this function Public Function sDoctorFullName() Function sDoctorFullName(ByVal psUserCode As String) As String sDoctorFullName = BLANK Try Dim ClsSQLLoadHelper As New ClassSQLLoadHelper With ClsSQLLoadHelper .TableName = "Doctor" .SQLExtraSelect = BLANK .SQLExtraCriteria = " Doctor_Code = " & VarSQLString(psUserCode) .AddRequiredField("Doctor_Name = LTrim(Rtrim(Doctor_Surname)) + ' '+ Doctor_GivenName+' '+ Chiname") .SQLOrder = BLANK sDoctorFullName = .oSQLLoadOneField("Doctor_Name") End With Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function End Module End Namespace #End Region "nsC1Grid"#Region "nsC1Grid" Namespace nsC1Grid ' In this Namespace, ' Contains functions that related to C1Grid Public Module mC1Grid ' Used in : Forgot ' Desc : return Row count Desc ' used in selectedChanged / refresh grid. ' e.g. Input - sRowCount(C1Grid) ' Return - "1 / 21" ' History : ' 2009-XX-XX - Create this function Public Function sRowCount() Function sRowCount(ByVal pGrid As C1.Win.C1FlexGrid.C1FlexGrid) As String sRowCount = BLANK Try Dim liRecordNumber As Integer If pGrid.Rows.Count > 1 Then liRecordNumber = pGrid.Rows.Count - pGrid.Rows.Fixed sRowCount = pGrid.RowSel.ToString & " / " & liRecordNumber.ToString Else sRowCount = "0 / 0" End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function ' Used in : Forgot ' Desc : Auto Size Grid Row and Col ' 1) If col is AllowResizing and Visible, then autosize it. ' Max Row Height is 66.As bug of C1 autosize, something it is very long. ' History : ' 2009-XX-XX - Create this function Public Sub AutoSize() Sub AutoSize(ByVal pGrid As C1.Win.C1FlexGrid.C1FlexGrid) Try pGrid.ScrollBars = ScrollBars.Both ' autosize Col For liRow As Integer = 0 To pGrid.Cols.Count - 1 If pGrid.Cols(liRow).AllowResizing = True Then If pGrid.Cols(liRow).Visible = True Then pGrid.AutoSizeCol(liRow) End If End If Next ' autosize Row pGrid.AutoSizeRow(0) If pGrid.Rows(0).Height > 65 Then pGrid.Rows(0).Height = 66 End If ' autosize Col For liRow As Integer = 0 To pGrid.Cols.Count - 1 If pGrid.Cols(liRow).AllowResizing = True Then If pGrid.Cols(liRow).Visible = True Then pGrid.AutoSizeCol(liRow) End If End If Next Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub ' Used in : Forgot ' Desc : Sum Column Value ' 1) sum all column ' 2) or only those psTrueColumn = true ' e.g. Input - iSumColumn(C1Grid,"SumColumn") ' Return - "19922" ' History : ' 2009-XX-XX - Create this function Public Function iSumColumn() Function iSumColumn(ByVal pGrid As C1.Win.C1FlexGrid.C1FlexGrid, ByVal psColumn As String, Optional ByVal psTrueColumn As String = BLANK) As Integer Try Dim liRowCount As Integer = pGrid.Rows.Count - pGrid.Rows.Fixed() For liRow As Integer = 1 To liRowCount If psTrueColumn <> BLANK Then If pGrid.Item(liRow, psTrueColumn) = True Then iSumColumn += CInt(pGrid.Item(liRow, psColumn).ToString) End If Else iSumColumn += CInt(pGrid.Item(liRow, psColumn).ToString) End If Next Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function ' Used in : Forgot ' Desc : ClearGrid ' History : ' 2009-XX-XX - Create this function Public Sub ClearGrid() Sub ClearGrid(ByVal pGrid As C1.Win.C1FlexGrid.C1FlexGrid) Try ' autosize Row pGrid.Rows.RemoveRange(1, pGrid.Rows.Count - 1) pGrid.Select(Nothing) Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub ' Used in : Forgot ' Desc : bHasSelectedRow - Check is there any selected row. ' History : ' 2009-XX-XX - Create this function Public Function bHasSelectedRow() Function bHasSelectedRow(ByVal pGrid As C1.Win.C1FlexGrid.C1FlexGrid) As Boolean bHasSelectedRow = False Try If pGrid.RowSel < pGrid.Rows.Fixed Then Exit Function bHasSelectedRow = True Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function "HideDuplicate"#Region "HideDuplicate" ' Used in : OPD ' Desc : Hide the row with duplicated information ' The column name of grid will store in psArraylist ' e.g. Input - Dim aa as new arraylist ' aa.add("ColumnName1") ' aa.add("ColumnName2") ' Input - HideDuplicateBottomUp(C1Grid,aa) ' Return - If the content of those columns in current row = previous row ' then hide the current row. ' History : ' 2009-08-09 - Create this function Public Sub HideDuplicateBottomUp() Sub HideDuplicateBottomUp(ByVal pGrid As C1.Win.C1FlexGrid.C1FlexGrid, ByVal psArraylist As ArrayList) Try Dim liRow As Integer Dim lsPreviousRowString As String = BLANK Dim lsCurrentRowString As String = BLANK Dim liRowCount As Integer = pGrid.Rows.Count - pGrid.Rows.Fixed() While liRowCount >= 1 liRow = liRowCount lsCurrentRowString = sRowString(pGrid, liRow, psArraylist) If lsPreviousRowString = lsCurrentRowString Then pGrid.Rows(liRow).Visible = False End If lsPreviousRowString = lsCurrentRowString liRowCount = liRowCount - 1 End While Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub Public Sub HideDuplicateTopDown() Sub HideDuplicateTopDown(ByVal pGrid As C1.Win.C1FlexGrid.C1FlexGrid, ByVal psArraylist As ArrayList) Try Dim lsPreviousRowString As String = BLANK Dim lsCurrentRowString As String = BLANK Dim liRowCount As Integer = pGrid.Rows.Count - pGrid.Rows.Fixed() For liRow As Integer = 1 To liRowCount lsCurrentRowString = sRowString(pGrid, liRow, psArraylist) If lsPreviousRowString = lsCurrentRowString Then pGrid.Rows(liRow).Visible = False End If lsPreviousRowString = lsCurrentRowString liRowCount = liRowCount - 1 Next Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub Private Function sRowString() Function sRowString(ByVal pGrid As C1.Win.C1FlexGrid.C1FlexGrid, ByVal piRow As Integer, ByVal psArraylist As ArrayList) As String sRowString = BLANK Try For Each lsItem As String In psArraylist sRowString += pGrid.Item(piRow, lsItem) Next Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function #End Region End Module End Namespace #End Region "nsPatient"#Region "nsPatient" Namespace nsPatient ' In this Namespace, ' Contains functions that get Patient information using VisitNo Public Module mPatient ' Used in : LOE ' Desc : Get a string desc of Patient Name,BedNo,Class ' e.g. Input - sGetPatientInfo("OP20090600001") ' Return - "Patient Name : CHAN TAI MAN 陳大文, Bed No : 123 Bed Class : SSS" ' History : ' 2009-XX-XX - Create this function Public Function sGetPatientInfo() Function sGetPatientInfo(ByVal psVisitNo As String) As String sGetPatientInfo = BLANK Try Dim lsSQLString As String = BLANK Dim ClsSQLLoadHelper As New ClassSQLLoadHelper With ClsSQLLoadHelper .TableName = "Patient_Visit PV" .SQLExtraSelect = " ,Bed_Allocation BA " .SQLExtraCriteria += " PV.Visit_No = " & VarSQLString(psVisitNo) .SQLExtraCriteria += " AND PV.Visit_No = BA.Visit_No " .SQLExtraCriteria += " AND BA.Current_Bed = " & CURRENT_BED_YES ' Construct the select fields for SQL statement .AddRequiredField(" BA.Bed_No") .AddRequiredField(" PV.Visit_No") .AddRequiredField(" Name = rtrim(PV.PV_Surname) + ' ' + rtrim(PV.PV_Given_Name) + ' ' + rtrim(isNull(PV.Chiname,''))") .AddRequiredField(" PV.Patient_No") .AddRequiredField(" BA.Hosp_Class_Code") .AddRequiredField(" PV.PV_Sex") lsSQLString = .sGenerateSqlSelect End With Dim ClsRecordLoadHelper As New ClassRecordLoadHelper With ClsRecordLoadHelper .SetConnection(lsSQLString) Try If .bReadStart Then sGetPatientInfo = " Patient Name : " & .oLoadSQLField("Name") _ & ", Bed No : " & .oLoadSQLField("Bed_No") _ & ", Bed Class : " & .oLoadSQLField("Hosp_Class_Code") End If Finally .bReadEnd() End Try End With Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function ' Used in : LOE ' Desc : Get a string desc of Patient Name ' I want to remove it. Because it can be replaced by sGetPatientFullName ' e.g. Input - sGetPatientName("OP20090600001") ' Return - "Patient Name : CHAN TAI MAN 陳大文" ' History : ' 2009-XX-XX - Create this function Public Function sGetPatientName() Function sGetPatientName(ByVal psVisitNo As String) As String sGetPatientName = BLANK Try sGetPatientName = " Patient Name : " & sGetPatientFullName(psVisitNo) Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function ' Used in : LOE ' Desc : Get a Patient FullName ' e.g. Input - sGetPatientName("OP20090600001") ' Return - "CHAN TAI MAN 陳大文" ' History : ' 2009-XX-XX - Create this function Public Function sGetPatientFullName() Function sGetPatientFullName(ByVal psVisitNo As String) As String sGetPatientFullName = BLANK Try Dim lsSQLString As String = BLANK Dim ClsSQLLoadHelper As New ClassSQLLoadHelper With ClsSQLLoadHelper .TableName = "Patient_Visit PV" .SQLExtraSelect = BLANK .SQLExtraCriteria += " PV.Visit_No = " & VarSQLString(psVisitNo) ' Construct the select fields for SQL statement .AddRequiredField(" Name = rtrim(PV.PV_Surname) + ' ' + rtrim(PV.PV_Given_Name) + ' ' + rtrim(isNull(PV.Chiname,''))") lsSQLString = .sGenerateSqlSelect sGetPatientFullName = .oSQLLoadOneField("Name") End With Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function "sGetPatientSex"#Region "sGetPatientSex" ' Used in : LOE ' Desc : Get a Patient Sex ' e.g. Input - sGetPatientSex("OP20090600001") ' Return - "M" ' History : ' 2009-XX-XX - Create this function Public Function sGetPatientSex() Function sGetPatientSex(ByVal psVisitNo As String) As String sGetPatientSex = BLANK Try If psVisitNo = BLANK Then Exit Function Dim lsSQLString As String = BLANK Dim ClsSQLLoadHelper As New ClassSQLLoadHelper With ClsSQLLoadHelper .TableName = "Patient_Visit PV" .SQLExtraSelect = BLANK .SQLExtraCriteria += " PV.Visit_No = " & VarSQLString(psVisitNo) .AddRequiredField("PV.PV_Sex") .SQLOrder = BLANK lsSQLString = .sGenerateSqlSelect sGetPatientSex = .oSQLLoadOneField("PV_Sex") End With Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function ' Used in : LOE ' Desc : Get a Patient Sex ' e.g. Input - sGetPatientSex("OP20090600001",True) ' Return - "Male" ' History : ' 2009-XX-XX - Create this function Public Function sGetPatientSex() Function sGetPatientSex(ByVal psVisitNo As String, ByVal pbFullDesc As Boolean) As String sGetPatientSex = BLANK Try If pbFullDesc Then sGetPatientSex = nsCodeToDesc.sSex(sGetPatientSex(psVisitNo)) Else sGetPatientSex = sGetPatientSex(psVisitNo) End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function #End Region ' Used in : LOE ' Desc : Get a Patient DOB ' e.g. Input - sGetPatientSex("OP20090600001") ' Return - "2009-06-01 22:11:33" ' History : ' 2009-XX-XX - Create this function Public Function sGetPatientDOB() Function sGetPatientDOB(ByVal psVisitNo As String) As String sGetPatientDOB = BLANK Try If psVisitNo = BLANK Then Exit Function Dim lsSQLString As String = BLANK Dim ClsSQLLoadHelper As New ClassSQLLoadHelper With ClsSQLLoadHelper .TableName = "Patient_Visit PV" .SQLExtraSelect = BLANK .SQLExtraCriteria += " PV.Visit_No = " & VarSQLString(psVisitNo) .AddRequiredField("PV.PV_DOB") .SQLOrder = BLANK lsSQLString = .sGenerateSqlSelect sGetPatientDOB = .oSQLLoadOneField("PV_DOB") End With Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function ' Used in : LOE ' Desc : Get a Patient Age ' e.g. Input - sGetPatientSex("OP20090600001") ' Return - "33Yrs10M21Days" ' History : ' 2009-XX-XX - Create this function Public Function sGetPatientAge() Function sGetPatientAge(ByVal psVisitNo As String) As String sGetPatientAge = BLANK Try If psVisitNo = BLANK Then Exit Function sGetPatientAge = sCalculateAge(nsPatient.sGetPatientDOB(psVisitNo), False) Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function ' Used in : LOE ' Desc : Get a Patient Number ' e.g. Input - sGetPatientSex("OP20090600001") ' Return - "PH20080600001" ' History : ' 2009-XX-XX - Create this function Public Function sFindPatientNo() Function sFindPatientNo(ByVal psVisitNo As String) As String sFindPatientNo = BLANK Try Dim ClsSQLLoadHelper As New ClassSQLLoadHelper With ClsSQLLoadHelper .TableName = "Patient_Visit" .SQLExtraSelect = BLANK .SQLExtraCriteria = "Visit_No = " & VarSQLString(psVisitNo) .AddRequiredField("Patient_No") .sGenerateSqlSelect() sFindPatientNo = .oSQLLoadOneField("Patient_No") End With Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function ' Used in : LOE ' Desc : Get a Patient Incharge Doctor ' e.g. Input - sGetPatientSex("OP20090600001") ' Return - "1234" ' History : ' 2009-XX-XX - Create this function Public Function sPatientInchargeDoctor() Function sPatientInchargeDoctor(ByVal psVisitNo As String) As String sPatientInchargeDoctor = BLANK Try If psVisitNo = BLANK Then Exit Function Dim lsSQLString As String = BLANK Dim ClsSQLLoadHelper As New ClassSQLLoadHelper With ClsSQLLoadHelper .TableName = "Doctor_Allocation" .SQLExtraSelect = BLANK .SQLExtraCriteria += " Visit_No = " & VarSQLString(psVisitNo) .SQLExtraCriteria += " and Attend_Doctor = " & DOC_ATTEND_DOCTOR_YES .AddRequiredField("Doctor_Code") .SQLOrder = BLANK lsSQLString = .sGenerateSqlSelect() sPatientInchargeDoctor = .oSQLLoadOneField("Doctor_Code") End With Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function End Module End Namespace #End Region "nsCombine"#Region "nsCombine" Namespace nsCombine ' In this Namespace, ' Contains functions that combine 2 strings Public Module mCombine ' Used in : LOE ' Desc : Add psChildItem into psAllItem ' e.g. Input - sCombineItem("aaa","bbb") ' Return - "aaa, bbb" ' History : ' 2009-XX-XX - Create this function Public Function sCombineItem() Function sCombineItem(ByVal psAllItem As String, ByVal psChildItem As String) As String sCombineItem = BLANK ' sCombineCode : Try If psChildItem = BLANK Then sCombineItem = psAllItem Exit Function End If If psAllItem = BLANK Then sCombineItem = psChildItem Else If psAllItem.IndexOf(psChildItem) = -1 Then sCombineItem = psAllItem + ", " + psChildItem Else sCombineItem = psAllItem End If End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function ' Used in : MRTS ' Desc : Add psChildItem into psAllItem ' e.g. Input - sCombinePara("aaa","bbb") ' Return - "aaa ' bbb" ' History : ' 2009-XX-XX - Create this function Public Function sCombinePara() Function sCombinePara(ByVal psAllItem As String, ByVal psChildItem As String) As String sCombinePara = BLANK Try If psChildItem = BLANK Then sCombinePara = psAllItem Exit Function End If If psAllItem = BLANK Then sCombinePara = psChildItem Else If psAllItem.IndexOf(psChildItem) = -1 Then sCombinePara = psAllItem + vbNewLine + psChildItem Else sCombinePara = psAllItem End If End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function ' Used in : MRTS ' Desc : ' e.g. Input - sCombinePosition("leg","right") ' Return - "right leg" ' History : ' 2009-XX-XX - Create this function Public Function sCombinePosition() Function sCombinePosition(ByVal psItem As String, ByVal psPosition As String) As String sCombinePosition = BLANK ' eg : Try If psItem = BLANK Then Exit Function If psPosition = BLANK Then sCombinePosition = psItem Else sCombinePosition = psPosition + " " + psItem End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function End Module End Namespace #End Region "nsDateTime"#Region "nsDateTime" Namespace nsDateTime Public Module mDateTime "sWithin2DateRange"#Region "sWithin2DateRange" ' Used in : Many ' Desc : return SQL String ' History : ' 2009-XX-XX - Create this function Public Function sWithin2DateRange() Function sWithin2DateRange(ByVal pDT As Date, ByVal pDT2 As Date, Optional ByVal pbWithTime As Boolean = True) As String sWithin2DateRange = BLANK Try If pDT.ToString = BLANK Then Exit Function End If If pbWithTime Then sWithin2DateRange = " between " _ & VarSQLString(FormatDate(pDT) & " " & "00:00:00") _ & " And " _ & VarSQLString(FormatDate(pDT2) & " " & "23:59:59") Else sWithin2DateRange = " between " _ & VarSQLString(FormatDate(pDT)) _ & " And " _ & VarSQLString(FormatDate(pDT2)) End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function Public Function sWithin2DateRange() Function sWithin2DateRange(ByVal pDT As DateTimePicker, ByVal pDT2 As DateTimePicker, Optional ByVal pbWithTime As Boolean = True) As String sWithin2DateRange = BLANK Try sWithin2DateRange = sWithin2DateRange(pDT.Text, pDT2.Text) Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function #End Region "sAfterYesterday"#Region "sAfterYesterday" ' Used in : Many ' Desc : return SQL String ' History : ' 2009-XX-XX - Create this function Public Function sAfterYesterday() Function sAfterYesterday() As String sAfterYesterday = BLANK Try sAfterYesterday = " >= " _ & VarSQLString(FormatDate(Now) & " " & "00:00:00") Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function #End Region "Within"#Region "Within" Public Function sWithinToday() Function sWithinToday() As String sWithinToday = BLANK Try sWithinToday = " between " _ & VarSQLString(FormatDate(Now) & " " & "00:00:00") _ & " And " _ & VarSQLString(FormatDate(Now) & " " & "23:59:59") Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function Public Function sWithinDay() Function sWithinDay(ByVal pDT As DateTimePicker) As String sWithinDay = BLANK Try sWithinDay = sWithinDay(pDT.Text) Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function Public Function sWithinDay() Function sWithinDay(ByVal pDT As Date) As String sWithinDay = BLANK Try If pDT.ToString = BLANK Then Exit Function End If sWithinDay = " between " _ & VarSQLString(FormatDate(pDT) & " " & "00:00:00") _ & " And " _ & VarSQLString(FormatDate(pDT) & " " & "23:59:59") Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function Public Function sWithinTomorrow() Function sWithinTomorrow() As String sWithinTomorrow = BLANK Try Dim lDate As Object = DateAdd(DateInterval.Day, 1, FormatDate(Now)) sWithinTomorrow = sWithinDay(lDate) Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function #End Region "sDateOnly"#Region "sDateOnly" ' Used in : Many ' Desc : ' History : ' 2009-XX-XX - Create this function Public Function sDateOnly() Function sDateOnly(ByVal pdtDate As DateTimePicker) As String ' reviewed sDateOnly = BLANK Try sDateOnly = BLANK If pdtDate.Enabled = True Then sDateOnly = sDateOnly(pdtDate.Value) End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function Public Function sDateOnly() Function sDateOnly(ByVal pdtDate As Date) As String ' reviewed sDateOnly = BLANK Try sDateOnly = FormatDate(pdtDate) Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function #End Region Public Function bAfterNDay() Function bAfterNDay(ByVal pDT As DateTimePicker, ByVal piN As Integer, Optional ByVal pbShowMsgBox As Boolean = False) As Boolean bAfterNDay = False Try bAfterNDay = bAfterNDay(pDT.Value, piN, pbShowMsgBox) If bAfterNDay = False Then pDT.Value = DateAdd(DateInterval.Day, piN, Now) End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function Public Function bAfterNDay() Function bAfterNDay(ByVal pDT As Date, ByVal piN As Integer, Optional ByVal pbShowMsgBox As Boolean = False) As Boolean bAfterNDay = False Try If DateDiff(DateInterval.Day, FormatDate(Now), FormatDate(pDT)) >= piN Then bAfterNDay = True Else If pbShowMsgBox Then MsgBoxOkOnly("The date should not be before " & FormatDate(DateAdd(DateInterval.Day, piN, Now))) End If bAfterNDay = False End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function Public Function bWithin24Hours() Function bWithin24Hours(ByVal pDT As Date) As Boolean bWithin24Hours = False Try If DateDiff(DateInterval.Hour, FormatDate(Now), pDT) <= 24 And _ DateDiff(DateInterval.Hour, FormatDate(Now), pDT) >= 0 Then bWithin24Hours = True End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function Public Function bBeforeNDay() Function bBeforeNDay(ByVal pDT As DateTimePicker, ByVal piN As Integer, Optional ByVal pbShowMsgBox As Boolean = False) As Boolean bBeforeNDay = False Try bBeforeNDay = bBeforeNDay(pDT.Value, piN) If bBeforeNDay = False Then pDT.Value = DateAdd(DateInterval.Day, piN, Now) End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function Public Function bBeforeNDay() Function bBeforeNDay(ByVal pDT As Date, ByVal piN As Integer, Optional ByVal pbShowMsgBox As Boolean = False) As Boolean bBeforeNDay = False Try If DateDiff(DateInterval.Day, FormatDate(Now), FormatDate(pDT)) <= piN Then bBeforeNDay = True Else If pbShowMsgBox Then MsgBoxOkOnly("The date should not be after " & FormatDate(DateAdd(DateInterval.Day, piN, Now))) End If bBeforeNDay = False End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function "bCheck2date"#Region "bCheck2date" ' check the pStartDT can not be greater than the pEndDT Public Function bCheck2date() Function bCheck2date(ByVal pStartDT As Date, ByVal pEndDT As Date) As Boolean bCheck2date = False Try If DateDiff(DateInterval.Day, pEndDT, pStartDT) > 0 Then MsgBoxOkOnly("Sorry, the start date can not be greater than the end date.") bCheck2date = False Else bCheck2date = True End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function Public Function bCheck2Date() Function bCheck2Date(ByRef pStartDT As DateTimePicker, ByRef pEndDT As DateTimePicker) As Boolean bCheck2Date = False Try If bCheck2Date(pStartDT.Value, pEndDT.Value) = True Then bCheck2Date = True Else ' pEndDT.Value = pStartDT.Value bCheck2Date = False End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function #End Region "bCheck2dateRange"#Region "bCheck2dateRange" ' check 2 date range is within psNoOfDays Public Function bCheck2dateRange() Function bCheck2dateRange(ByVal pStartDT As Date, ByVal pEndDT As Date, _ ByVal psNoOfDays As Integer, _ Optional ByVal pbShowMsg As Boolean = False) As Boolean bCheck2dateRange = False Try If nsDateTime.bCheck2date(pStartDT, pEndDT) = False Then Exit Function If DateDiff(DateInterval.Day, pStartDT, pEndDT) >= psNoOfDays Then If pbShowMsg = True Then MsgBoxOkOnly("Sorry, the range of 2 dates can not be greater than " & psNoOfDays & " days.") End If bCheck2dateRange = False Else bCheck2dateRange = True End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function Public Function bCheck2dateRange() Function bCheck2dateRange(ByRef pStartDT As DateTimePicker, ByRef pEndDT As DateTimePicker, _ ByVal psNoOfDays As Integer, _ Optional ByVal pbShowMsg As Boolean = False) As Boolean bCheck2dateRange = False Try If bCheck2dateRange(pStartDT.Value, pEndDT.Value, psNoOfDays, pbShowMsg) = True Then bCheck2dateRange = True Else bCheck2dateRange = False End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function #End Region Public Function sGetDateAndTime() Function sGetDateAndTime(ByVal pdtDate As DateTimePicker, ByVal pdtTime As DateTimePicker) As String sGetDateAndTime = BLANK ' reviewed Try sGetDateAndTime = FormatDate(pdtDate.Value) + " " + FormatTimeMin(pdtTime.Value) Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function Public Function sNowWithDefaultTime() Function sNowWithDefaultTime() As String sNowWithDefaultTime = BLANK ' reviewed Try sNowWithDefaultTime = FormatDate(Now) + " " + "00:00" Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function End Module End Namespace #End Region "nsCheckBox"#Region "nsCheckBox" Namespace nsCheckBox Public Module mCheckBox "CheckedChkBoxThenEnableObject"#Region "CheckedChkBoxThenEnableObject" Public Sub CheckedChkBoxThenEnableObject() Sub CheckedChkBoxThenEnableObject(ByVal psChkBox As Object, ByVal psObject As Object) ' reviewed ' psChkBox is checked then enable psObject Try Select Case psObject.GetType.Name Case "TextBox" If psChkBox.Checked = True Then psObject.Enabled = True psObject.focus() Else psObject.Enabled = False psObject.text = BLANK End If Case "RadioButton", "CheckBox" If psChkBox.Checked = True Then psObject.Enabled = True Else psObject.Enabled = False psObject.checked = False End If Case "DateTimePicker" If psChkBox.Checked = True Then psObject.Enabled = True Else psObject.Enabled = False End If Case Else If psChkBox.Checked = True Then psObject.Enabled = True Else psObject.Enabled = False End If End Select Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub #End Region "CheckedChkBoxThenCheckedObject"#Region "CheckedChkBoxThenCheckedObject" Public Sub CheckedChkBoxThenCheckedObject() Sub CheckedChkBoxThenCheckedObject(ByVal psChkBox As Object, ByVal psObject As Object) ' reviewed ' psChkBox is checked then enable psObject Try Select Case psObject.GetType.Name Case "CheckBox" If psChkBox.Checked = True Then psObject.checked = True Else psObject.checked = False End If End Select Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub #End Region "CheckedChkThenDisableOject"#Region "CheckedChkThenDisableOject" Public Sub CheckedChkThenDisableOject() Sub CheckedChkThenDisableOject(ByVal psChkBox As Object, ByVal psObject As Object) ' reviewed ' psChkBox is checked then disable psObject Try Select Case psObject.GetType.Name Case "TextBox" If psChkBox.Checked = True Then psObject.Enabled = False psObject.text = BLANK Else psObject.Enabled = True End If Case "RadioButton", "CheckBox" If psChkBox.Checked = True Then psObject.Enabled = False psObject.checked = False Else psObject.Enabled = True End If Case "DateTimePicker" If psChkBox.Checked = True Then psObject.Enabled = False Else psObject.Enabled = True End If End Select Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub #End Region Public Function CheckedChkBoxThenUncheckedOtherChkBox() Function CheckedChkBoxThenUncheckedOtherChkBox(ByVal psChkBox As CheckBox, ByVal psOtherChk1 As CheckBox, Optional ByVal psOtherChk2 As CheckBox = Nothing) As Boolean ' reviewed Try If psChkBox.Checked = True Then psOtherChk1.Checked = False If psOtherChk2 Is Nothing Then Exit Function psOtherChk2.Checked = False End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function End Module End Namespace #End Region "nsComboBox"#Region "nsComboBox" Namespace nsComboBox Public Module mComboBox Public Sub FillComboWard() Sub FillComboWard(ByRef pcboAny As C1.Win.C1List.C1Combo) Try Dim ClsSQLLoadHelper As New ClassSQLLoadHelper Dim lsSQLString As String = BLANK With ClsSQLLoadHelper .TableName = "Bed BE" .SQLExtraSelect = ", Department DE" .SQLExtraCriteria = " BE.Bed_Available = " & BED_AVAILABLE_YES .SQLExtraCriteria += " And BE.Dept_Code = DE.Dept_Code" .AddRequiredField("Distinct Dept_Code = rtrim(DE.Dept_Code)") .AddRequiredField("Dept_EngName = rtrim(DE.Dept_EngName)") .SQLOrder = "Dept_Code" lsSQLString = .sGenerateSqlSelect .fFillComboDataSet(pcboAny, True) End With With pcboAny .HScrollBar.Style = C1.Win.C1List.ScrollBarStyleEnum.None .Splits(0).DisplayColumns(0).Width = 50 .Splits(0).DisplayColumns(1).Width = 300 .ValueMember = "Dept_Code" .DisplayMember = "Dept_Code" End With Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub Public Sub FillComboWardWithPatientInfo() Sub FillComboWardWithPatientInfo(ByRef pcboAny As C1.Win.C1List.C1Combo, ByVal psDeptCode As String) 'reviewed Try Dim lsSQLString As String = BLANK Dim ClsSQLLoadHelper As New ClassSQLLoadHelper With ClsSQLLoadHelper .TableName = "Patient_Visit PV" .SQLExtraSelect = " ,Bed_Allocation BA " .SQLExtraCriteria = " PV.Visit_No = BA.Visit_No " .SQLExtraCriteria += " AND BA.Dept_Code = " & VarSQLString(psDeptCode) .SQLExtraCriteria += " AND BA.Current_Bed = " & CURRENT_BED_YES .SQLExtraCriteria += " AND PV.PV_Discharge_DT IS NULL " .AddRequiredField(" BA.Bed_No") .AddRequiredField(" PV.Visit_No") .AddRequiredField(" Name = rtrim(PV.PV_Surname) + ' ' + rtrim(PV.PV_Given_Name) + ' ' + rtrim(isNull(PV.Chiname,''))") .AddRequiredField(" PV.Patient_No") .AddRequiredField(" BA.Hosp_Class_Code") .AddRequiredField(" PV.PV_Sex") .SQLOrder = "BA.Bed_No" lsSQLString = .sGenerateSqlSelect() .fFillComboDataSet(pcboAny, False) End With With pcboAny .DisplayMember = "Bed_No" .ValueMember = "Bed_No" .Splits(0).DisplayColumns.Item(0).Width = 60 .Splits(0).DisplayColumns.Item(1).Width = 140 .Splits(0).DisplayColumns.Item(2).Width = 350 .Splits(0).DisplayColumns.Item(3).Width = 0 .Splits(0).DisplayColumns.Item(4).Width = 0 .Splits(0).DisplayColumns.Item(5).Width = 0 .DropDownWidth = 550 .MaxDropDownItems = 20 End With Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub Public Sub FillComboDoctorName() Sub FillComboDoctorName(ByRef pcboAny As C1.Win.C1List.C1Combo, ByVal piDrStatus As Integer) 'reviewed Try Dim lsSQLString As String = BLANK Dim ClsSQLLoadHelper As New ClassSQLLoadHelper With ClsSQLLoadHelper .TableName = "Doctor" .SQLExtraSelect = BLANK If piDrStatus <> DOC_STATUS_ALL Then .SQLExtraCriteria = " Doctor_Status= " & VarSQLString(piDrStatus) End If .AddRequiredField("Doctor_Name = LTrim(Rtrim(Doctor_Surname)) + ' '+ Doctor_GivenName+' '+Doctor_Engname+' '+ Chiname") .AddRequiredField("Doctor_Code") .AddRequiredField("Dr_Remarks") .SQLOrder = "Doctor_Name,Doctor_Code" lsSQLString = .sGenerateSqlSelect() .fFillComboDataSet(pcboAny, False) End With With pcboAny .HScrollBar.Style = C1.Win.C1List.ScrollBarStyleEnum.None .DisplayMember = "Doctor_Name" .ValueMember = "Doctor_Code" .Splits(0).DisplayColumns(0).Width = 350 .Splits(0).DisplayColumns(1).Width = 70 .Splits(0).DisplayColumns(2).Width = 180 .DropDownWidth = 600 End With Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub Public Sub FillComboDoctorEngName() Sub FillComboDoctorEngName(ByRef pcboAny As C1.Win.C1List.C1Combo, ByVal pbAll As Boolean) 'reviewed Try Dim ClsSQLLoadHelper As New ClassSQLLoadHelper With ClsSQLLoadHelper .TableName = "Doctor" .SQLExtraSelect = BLANK .SQLExtraCriteria = " Doctor_Status= " & DOC_STATUS_ACTIVE .AddRequiredField("Doctor_Name = rtrim(Doctor_Surname) + ' ' + rtrim(Doctor_GivenName)") .AddRequiredField("Doctor_Code") .SQLOrder = "Doctor_Name,Doctor_Code" .sGenerateSqlSelect() .fFillComboDataSet(pcboAny, pbAll) End With With pcboAny .HScrollBar.Style = C1.Win.C1List.ScrollBarStyleEnum.None .DisplayMember = "Doctor_Name" .ValueMember = "Doctor_Code" .Splits(0).DisplayColumns(0).Width = 250 .Splits(0).DisplayColumns(1).Width = 70 .DropDownWidth = 320 End With Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub Public Sub FillComboResidentDoctorName() Sub FillComboResidentDoctorName(ByRef pcboAny As C1.Win.C1List.C1Combo, ByVal pbAll As Boolean) 'reviewed Try Dim lsSQLString As String = BLANK Dim ClsSQLLoadHelper As New ClassSQLLoadHelper With ClsSQLLoadHelper .TableName = "Doctor" .SQLExtraSelect = BLANK .SQLExtraCriteria += " Doctor_Status= " & DOC_STATUS_ACTIVE If pbAll Then .SQLExtraCriteria = BLANK Else .SQLExtraCriteria += " and Resident_Doctor = 1 " End If .AddRequiredField("Doctor_Name = LTrim(Rtrim(Doctor_Surname)) + ' '+ Doctor_GivenName+' '+Doctor_Engname+' '+ Chiname") .AddRequiredField("Doctor_Code") .AddRequiredField("Dr_Remarks") .SQLOrder = "Doctor_Name,Doctor_Code" lsSQLString = .sGenerateSqlSelect() .fFillComboDataSet(pcboAny, False) End With pcboAny.HScrollBar.Style = C1.Win.C1List.ScrollBarStyleEnum.None pcboAny.DisplayMember = "Doctor_Name" pcboAny.ValueMember = "Doctor_Code" pcboAny.Splits(0).DisplayColumns(0).Width = 350 pcboAny.Splits(0).DisplayColumns(1).Width = 70 pcboAny.Splits(0).DisplayColumns(2).Width = 180 pcboAny.DropDownWidth = 600 Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub Enum enLabRequestReasonType Amend = 1 Acknowledge = 2 End Enum ''' <summary> ''' Fills the combo lab request reason. ''' </summary> ''' <param name="pCombo">The p combo.</param> ''' <param name="piReasonType">use <c>enLabRequestReasonType</c> </param> Public Sub FillComboLabRequestReason() Sub FillComboLabRequestReason(ByRef pCombo As C1.Win.C1List.C1Combo, ByVal piReasonType As Integer) ' reviewed Try Dim lsSQLString As String = BLANK Dim ClsSQLLoadHelper As New ClassSQLLoadHelper With ClsSQLLoadHelper .TableName = "Lab_Request_Reason" .SQLExtraCriteria = " Reason_Type = " & VarSQLString(piReasonType) .AddRequiredField("Reason") .AddRequiredField("Seq_No") .SQLOrder = "Seq_No" lsSQLString = .sGenerateSqlSelect End With Call FillComboSingleCoulmn(pCombo, lsSQLString) Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub Public Sub FillComboCancelReason() Sub FillComboCancelReason(ByRef pCombo As C1.Win.C1List.C1Combo) ' reviewed Try Dim lsSQLString As String = BLANK Dim ClsSQLLoadHelper As New ClassSQLLoadHelper With ClsSQLLoadHelper .TableName = "Lab_Request_Cancel_Reason" .SQLExtraSelect = BLANK .AddRequiredField("Cancel_Reason") .AddRequiredField("Seq_No") .SQLOrder = "Seq_No" lsSQLString = .sGenerateSqlSelect End With Call FillComboSingleCoulmn(pCombo, lsSQLString) Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub Public Sub FillComboSingleCoulmn() Sub FillComboSingleCoulmn(ByRef pCombo As C1.Win.C1List.C1Combo, ByVal psTable As System.Data.DataTable) ' use datatable Try With pCombo .DataMode = C1.Win.C1List.DataModeEnum.Normal .DataSource = psTable.DefaultView .DisplayMember = vntFixNull(psTable.Columns(0).ToString) .ValueMember = vntFixNull(psTable.Columns(0).ToString) .HScrollBar.Style = C1.Win.C1List.ScrollBarStyleEnum.None .Splits(0).DisplayColumns(0).Width = pCombo.Width .DropDownWidth = pCombo.Width .AutoDropDown = True .AutoCompletion = True .AutoSize = True .RowTracking = True End With Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub ''' <summary> ''' Fills the combo single coulmn. ''' </summary> ''' <param name="pCombo">The p combo.</param> ''' <param name="psSQLString">The ps SQL string.</param> Public Sub FillComboSingleCoulmn() Sub FillComboSingleCoulmn(ByRef pCombo As C1.Win.C1List.C1Combo, ByVal psSQLString As String) ' use SQLString ' only take the first column Try Dim daSQL As New OleDbDataAdapter Dim dsDataSet As DataSet = New DataSet daSQL.SelectCommand = New OleDbCommand(psSQLString, gcnOLEDBHIS) daSQL.Fill(dsDataSet, "First_Table") daSQL.SelectCommand.Dispose() daSQL.Dispose() With pCombo .DataMode = C1.Win.C1List.DataModeEnum.Normal .DataSource = dsDataSet.Tables(0).DefaultView .DisplayMember = vntFixNull(dsDataSet.Tables(0).Columns(0).ToString) .ValueMember = vntFixNull(dsDataSet.Tables(0).Columns(0).ToString) .HScrollBar.Style = C1.Win.C1List.ScrollBarStyleEnum.None .Splits(0).DisplayColumns(0).Width = pCombo.Width .DropDownWidth = pCombo.Width .AutoDropDown = True .AutoCompletion = True .AutoSize = True .RowTracking = True End With Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub ''' <summary> ''' Fills the combo data set. ''' </summary> ''' <param name="pcboAny">The pcbo any.</param> ''' <param name="psSQLString">The ps SQL string.</param> ''' <param name="pbAll">if set to <c>true</c> [pb all].</param> Public Sub FillComboDataSet() Sub FillComboDataSet(ByRef pcboAny As C1.Win.C1List.C1Combo, ByVal psSQLString As String, Optional ByVal pbAll As Boolean = False) Try Dim cmdSQL As OleDbCommand = New OleDbCommand(psSQLString, gcnOLEDBHIS) Dim daSQL As OleDbDataAdapter = New OleDbDataAdapter(cmdSQL) Dim dsSQL As DataSet = New DataSet daSQL.Fill(dsSQL, "TempTable") pcboAny.DataMode = C1.Win.C1List.DataModeEnum.Normal pcboAny.DataSource = dsSQL.Tables.Item(0) If pbAll = True Then Dim drNew As System.Data.DataRow = dsSQL.Tables.Item(0).NewRow For liCol As Integer = 0 To drNew.Table.Columns.Count - 1 Try drNew.Item(liCol) = "ALL" Catch drNew.Item(liCol) = DBNull.Value End Try Next pcboAny.DataSource.rows.add(drNew) End If Call dsSQL.Dispose() Call daSQL.Dispose() Call cmdSQL.Dispose() Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub ''' <summary> ''' Fills the combo by value. ''' </summary> ''' <param name="pCombo">The p combo.</param> ''' <param name="poValue">The po value.</param> Public Sub FillComboByValue() Sub FillComboByValue(ByVal pCombo As C1.Win.C1List.C1Combo, ByVal poValue As Object) ' reviewed Try If poValue = BLANK Then Exit Sub pCombo.SelectedValue = poValue Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub End Module End Namespace #End Region "nsLocation"#Region "nsLocation" Namespace nsLocation Public Module mLocation "sGetLocation,sAutoLocation"#Region "sGetLocation,sAutoLocation" Public Function sGetLocation() Function sGetLocation(ByVal pControl As Object) As Point ' Get the Location of pControl Dim lPoint As Point Try If pControl.parent Is Nothing Then lPoint.X = pControl.location.x ' why add 44 lPoint.Y = pControl.location.y + 44 Else lPoint = sGetLocation(pControl.parent) lPoint.X += pControl.location.X lPoint.Y += pControl.location.Y End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try Return lPoint End Function Public Function sAutoLocation() Function sAutoLocation(ByVal pParentSize As Size, ByVal pMe As Object) As Point ' auto Reset the location when it is outbound. Try sAutoLocation = pMe.Location Dim lPoint As Point lPoint.X = pMe.Location.X + pMe.Width lPoint.Y = pMe.Location.Y + pMe.Height If lPoint.Y > pParentSize.Height Then sAutoLocation.Y = pMe.Location.Y - pMe.Height - 20 End If If lPoint.X > pParentSize.Width Then sAutoLocation.X = pParentSize.Width - pMe.Width End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function Public Function sAutoLocation() Function sAutoLocation(ByVal pParentSize As Size, ByVal psParentPoint As Point, ByVal pMe As Object) As Point ' auto Reset the location when it is outbound. Try pMe.Location = psParentPoint sAutoLocation = pMe.Location Dim lPoint As Point lPoint.X = pMe.Location.X + pMe.Width lPoint.Y = pMe.Location.Y + pMe.Height If lPoint.Y > pParentSize.Height Then sAutoLocation.Y = pMe.Location.Y - pMe.Height - 20 End If If lPoint.X > pParentSize.Width Then sAutoLocation.X = pParentSize.Width - pMe.Width End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function #End Region End Module End Namespace #End Region "nsKey"#Region "nsKey" Namespace nsKey Public Module mKey Private Declare Sub keybd_event Lib "user32" () Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, _ ByVal bScan As Byte, _ ByVal dwFlags As Long, _ ByVal dwExtraInfo As Long) Private Enum enKeyAction KeyDown = &H1 KeyUp = &H2 End Enum Public Sub KeyDown() Sub KeyDown(ByVal vKey As Keys) Try Call keybd_event(vKey, 0, enKeyAction.KeyDown, 0) Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub Public Sub KeyUp() Sub KeyUp(ByVal vKey As Keys) Try keybd_event(vKey, 0, enKeyAction.KeyDown Or enKeyAction.KeyUp, 0) Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub Public Sub KeyClick() Sub KeyClick(ByVal vKey As Keys) Try KeyDown(vKey) KeyUp(vKey) Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub Public Sub hkCopy() Sub hkCopy() Try Call KeyDown(Keys.LControlKey) Call KeyClick(Keys.C) Call KeyUp(Keys.LControlKey) Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub Public Sub hkPaste() Sub hkPaste() Try Call KeyDown(Keys.LControlKey) Call KeyClick(Keys.V) Call KeyUp(Keys.LControlKey) Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub Public Sub hkUndo() Sub hkUndo() Try Call KeyDown(Keys.LControlKey) Call KeyClick(Keys.Z) Call KeyUp(Keys.LControlKey) Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub Public Sub hkRedo() Sub hkRedo() Try Call KeyDown(Keys.LControlKey) Call KeyClick(Keys.Y) Call KeyUp(Keys.LControlKey) Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Sub End Module End Namespace #End Region "OldCode"#Region "OldCode" Module mOldCode ' RRR old code. Private Function sAgeSQL() Function sAgeSQL(ByVal psTextBox As TextBox, ByVal psTextBoxTo As TextBox) As String sAgeSQL = BLANK Try Dim lsAge As String = BLANK Dim lsOperator As String = BLANK Select Case True Case psTextBox.ToString.Contains(">") Or psTextBox.ToString.Contains("<") If psTextBox.Text.IndexOf(">") = 0 Then lsAge = psTextBox.Text.Substring(1) lsOperator = ">" End If If psTextBox.Text.IndexOf("<") = 0 Then lsAge = psTextBox.Text.Substring(1) lsOperator = "<" End If If bIsNumber(lsAge) Then sAgeSQL = lsOperator & " " & sGetDate(lsAge) Exit Function End If Case psTextBox.Text <> BLANK And psTextBoxTo.Text = BLANK sAgeSQL = nsDateTime.sWithin2DateRange(sGetDate(CInt(psTextBox.Text) + 1), sGetDate(psTextBox.Text)) Case Else sAgeSQL = nsDateTime.sWithin2DateRange(sGetDate(psTextBoxTo.Text), sGetDate(psTextBox.Text)) End Select Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function "Age Description"#Region "Age Description" Public Function sAge() Function sAge(ByVal pTxtBox As TextBox, ByVal pTxtBoxTo As TextBox) As String sAge = BLANK Try sAge = sAgeGreaterLesser(pTxtBox, pTxtBoxTo) If sAge = BLANK And pTxtBoxTo.Enabled = True Then sAge = sAgeBetween(pTxtBox, pTxtBoxTo) End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function Private Function sAgeGreaterLesser() Function sAgeGreaterLesser(ByVal pTxtBox As TextBox, ByVal pTxtBoxTo As TextBox) As String sAgeGreaterLesser = BLANK Try If pTxtBox.Text = BLANK Then pTxtBoxTo.Text = BLANK Exit Function End If Dim lsAge As String = pTxtBox.Text Dim lsOperator As String = BLANK If lsAge.ToString.Contains(">") Or lsAge.ToString.Contains("<") Then pTxtBoxTo.Enabled = False pTxtBoxTo.Text = BLANK If lsAge.IndexOf(">") = 0 Then lsAge = lsAge.Substring(1) lsOperator = "Birth date before" End If If lsAge.IndexOf("<") = 0 Then lsAge = lsAge.Substring(1) lsOperator = "Birth date after" End If If bIsNumber(lsAge) Then sAgeGreaterLesser = lsOperator & " " & sGetDate(lsAge) Else If lsAge = BLANK Then Exit Function MsgBoxOkOnly("Please key in valid age to continue") pTxtBox.Text = BLANK pTxtBox.Focus() Exit Function End If Else pTxtBoxTo.Enabled = True End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function Private Function sAgeBetweenLocalizeMsg() Function sAgeBetweenLocalizeMsg(ByVal sAgeBetween As String, ByVal lsAge As String, ByVal lsAgeTo As String) As String sAgeBetweenLocalizeMsg = BLANK If sAgeBetween <> BLANK Then sAgeBetweenLocalizeMsg = "Birth date between " & sGetDate(lsAgeTo) & " and " & sGetDate(lsAge) End If End Function Private Function sAgeBetween() Function sAgeBetween(ByVal pTxtBox As TextBox, ByVal pTxtBoxTo As TextBox) As String sAgeBetween = BLANK Try Dim lsAge As String = pTxtBox.Text Dim lsAgeTo As String = pTxtBoxTo.Text If lsAge = BLANK Then Exit Function If lsAgeTo = BLANK And lsAge <> BLANK Then If bIsNumber(lsAge) Then sAgeBetween = nsDateTime.sWithin2DateRange(sGetDate(CInt(lsAge) + 1), sGetDate(lsAge)) sAgeBetween = sAgeBetweenLocalizeMsg(sAgeBetween, lsAge, CInt(lsAge) + 1) Else MsgBoxOkOnly("Please key in valid age.") pTxtBox.Text = BLANK pTxtBox.Focus() End If Exit Function End If If bIsNumber(lsAgeTo) Then sAgeBetween = nsDateTime.sWithin2DateRange(sGetDate(lsAgeTo), sGetDate(lsAge)) sAgeBetween = sAgeBetweenLocalizeMsg(sAgeBetween, lsAge, lsAgeTo) Else If lsAgeTo = BLANK Then Exit Function MsgBoxOkOnly("Please key in valid age") pTxtBox.Text = BLANK pTxtBoxTo.Focus() Exit Function End If Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function Public Function sGetDate() Function sGetDate(ByVal psYear As Integer) As String sGetDate = BLANK Try sGetDate = DateAdd(DateInterval.Year, -(psYear), FormatDate(Now)) Catch Err As Exception Call ErrHandler(Err.Message, APP_NAME) End Try End Function #End Region End Module #End Region
------------------
熱愛生命 喜愛新奇 有趣的事物
過去 是無法改變
將來 卻能夠創造
希望使大家生活更便利
世界更美好
a guy who loves IT and life
