กระทู้เมื่อเร็วๆ นี้

Delphi / Pascal / DUE Script

« กระทู้ล่าสุด โดย cil เมื่อ กันยายน 03, 2024, 15:33:25 PM »

ใช้แทน DUE + UE-Form ที่ไม่ขึ้น pop-up auto ถ้า remed ครับ
เปลี่ยน icode และตั้งค่าให้ run ใน SYS_VN_SCRIPT ด้วยครับ

Source

โค๊ด: [Select]

unit DUE;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, ActnList, DBCtrls, dblookup, DB, DBClient, Grids,
  DBGrids, SQLDB;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    pdxLabel: TLabel;
    Label1: TLabel;
    Shape1: TShape;
    Label8: TLabel;
    Label9: TLabel;
    Label10: TLabel;
    Label12: TLabel;
    Label13: TLabel;
    Label14: TLabel;
    Panel1: TPanel;
    Label5: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    Year: TLabel;
    age_yLabel: TLabel;
    //DoctorLabel: TLabel
    ListBox2: TListBox;
    Shape2: TShape;

  private
    procedure CheckBoxClick(Sender: TObject);
    procedure SaveCheckedItemsToDatabase;
    procedure showdata(Sender: TObject);

    // Store dynamically created checkboxes and their indications


  public
    procedure showdata(Sender: TObject);

  end;

var
  Form1: TForm1;
  genericNameList: TStringList; // Declare TStringList
  drugName: TLabel;
   CheckBoxList: TStringList; // Stores CheckBox names and indications


implementation

{$R *.dfm}

procedure TForm1.showdata(Sender: TObject);
var
  hn, vn, fullname, SQLQuery,pttype,age_y,pdx,doctor_name: string;
  tc, tc0: TClientDataSet;
  i, CheckBoxTop, RowCount: Integer;
  CheckBox: TCheckBox;
begin
  vn := GetGlobalValue('VN');
  if vn = '' then
    //vn := '670821080117';
      vn := '670903082755';
  // Retrieve patient information
  hn := getsqldata('SELECT hn FROM vn_stat WHERE vn="' + vn + '"');
  fullname := getsqldata('SELECT CONCAT(pname, fname, " ", lname) FROM patient WHERE hn="' + hn + '"');
  pttype := getsqldata('SELECT p.name FROM opitemrece o inner join pttype p on o.pttype = p.pttype WHERE vn="' + vn + '"');
  age_y := getsqldata('SELECT age_y FROM vn_stat WHERE vn="' + vn + '"');
  pdx := getsqldata('SELECT CONCAT(vs.pdx," : ",i.name) FROM vn_stat vs inner join icd101 i on vs.pdx = i.code WHERE vn="' + vn + '"');

  // Assign patient information
  Label10.Caption := hn;
  Label12.Caption := fullname;
  Label14.Caption := pttype ;
  age_yLabel.caption := age_y;
  pdxLabel.caption := pdx;
  //DoctorLabel := GetCurrentUser//getsqldata('select name from opduser where loginname="'+GetCurrentUser+'" ');

  // Initialize TStringList to store generic names and checkbox indications
  genericNameList := TStringList.Create;
  CheckBoxList := TStringList.Create;

  try
    // Create and initialize the dataset to get distinct generic names
    tc0 := TClientDataset.Create(nil);
    try
      tc0.Data := hosxp_getdataset('SELECT DISTINCT d.generic_name FROM opitemrece o ' +
          'INNER JOIN drugitems d ON o.icode = d.icode ' +
          'WHERE o.vn="' + vn + '" AND d.icode IN ("1540117", "1580125", "1000013", "1660170", "1000014", "1620180", "1520803", "1540113", "1660168", "1560131")');


      // Populate the TStringList with generic names
      tc0.First;
      while not tc0.Eof do
      begin
        genericNameList.Add(tc0.FieldByName('generic_name').AsString);
        tc0.Next;
      end;

    finally
      tc0.Free;
    end;

    // Create and initialize the second dataset for checkboxes
    tc := TClientDataset.Create(nil);           
    try
      // Check if genericNameList has at least one item
      if genericNameList.Count > 0 then
      begin
        // Process each generic name
        CheckBoxTop := 150;
        for i := 0 to genericNameList.Count - 1 do
        begin
          // Create a label for the generic name
          drugName := TLabel.Create(Self);
          drugName.Parent := Self; // Set the parent to the form or container
          drugName.Top := CheckBoxTop;
          drugName.Left := 30;
          drugName.Caption := genericNameList[i];

          // Prepare the SQL query with proper string concatenation
          SQLQuery := 'SELECT universal_item_value_name, universal_item_value_code FROM universal_item_value_list ' +
                      'WHERE universal_item_value_code LIKE ' + QuotedStr(genericNameList[i] + '%');

          // Retrieve dataset based on the SQL query
          tc.Data := hosxp_getdataset(SQLQuery);

          // Check if the dataset is not empty
          if not tc.IsEmpty then
          begin
            RowCount := tc.RecordCount;

            // Create checkboxes based on universal_item_value_name
            tc.First;
            while not tc.Eof do
            begin
              CheckBox := TCheckBox.Create(Self);
              CheckBox.Parent := Self;
              CheckBox.Left := 150;
              CheckBox.Top := CheckBoxTop;
              CheckBox.Width := 600;
              CheckBox.Caption := tc.FieldByName('universal_item_value_name').AsString;
              CheckBox.Tag := i + 1; // Store index or ID
              CheckBox.Checked := False; // Default to unchecked
              CheckBox.Name := tc.FieldByName('universal_item_value_code').AsString;
              CheckBox.OnClick := CheckBoxClick; // Assign event handler

              // Add the checkbox to the list
              CheckBoxList.AddObject(CheckBox.Name, CheckBox);

              CheckBoxTop := CheckBoxTop + 25; // Increment position for the next checkbox
              tc.Next;
            end;
          end
          else
          begin                               
            ShowMessage('No data found for ' + genericNameList[i]);
          end;

          // Increment CheckBoxTop to prevent overlap
          CheckBoxTop := CheckBoxTop + 15;
        end;
      end
      else
      begin
        ShowMessage('The genericNameList is empty.');
      end;
    finally
      tc.Free;
    end;

  finally
    // Clean up code if necessary
    // If you had TClientDataSet instances or other resources, free them here
  end;
end;

procedure TForm1.CheckBoxClick(Sender: TObject);
var
  CheckBox: TCheckBox;
  CheckBoxName: string;
begin
  CheckBox := TCheckBox(Sender);
  CheckBoxName := CheckBox.Name;  // Use the Name value of the checkbox

  if CheckBox.Checked then
  begin
    // Store indication directly
    if CheckBoxList.IndexOf(CheckBoxName) = -1 then
      CheckBoxList.AddObject(CheckBoxName, CheckBox);
  end
  else
  begin
    // Remove indication if checkbox is unchecked
    CheckBoxList.Delete(CheckBoxList.IndexOf(CheckBoxName));
  end;
end;

procedure TForm1.SaveCheckedItemsToDatabase;
var
  i: Integer;
  vn, doctor: string;
  fcdsDUE: TClientDataSet;
  CheckBox: TCheckBox;
  OriginalName, ModifiedName: string;
  UnderscorePos: Integer;
  RecordExists: Boolean;
  ShouldInsert: Boolean;
begin
  // Retrieve global values
  vn := GetGlobalValue('VN');
  if vn = '' then
    vn := '670903082755';
  doctor := getsqldata('SELECT o.doctor FROM opitemrece o WHERE vn="' + vn + '" LIMIT 1');
  
  try
    if CheckBoxList.Count > 0 then
    begin
      // Iterate through the list of checkboxes
      for i := 0 to CheckBoxList.Count - 1 do
      begin
        CheckBox := TCheckBox(CheckBoxList.Objects[i]);

        if CheckBox.Checked then
        begin
          // Initialize and set up the TClientDataSet for inserting data
          fcdsDUE := TClientDataSet.Create(nil);
          try
            fcdsDUE.Data := hosxp_getdataset('SELECT * FROM drug_due_list');
            
            if not fcdsDUE.Active then
              fcdsDUE.Open;

            // Extract and modify the CheckBox name
            OriginalName := CheckBox.Name;
            UnderscorePos := Pos('_', OriginalName);
            if UnderscorePos > 0 then
            begin
              ModifiedName := Copy(OriginalName, 1, UnderscorePos - 1);
            end
            else
            begin
              ModifiedName := OriginalName;
            end;

            // Check if the record already exists
            fcdsDUE.First;
            RecordExists := False;
            while not fcdsDUE.Eof do
            begin
              if (fcdsDUE.FieldByName('vn').AsString = vn) and
                 (fcdsDUE.FieldByName('generic_name').AsString = ModifiedName) and
                 (fcdsDUE.FieldByName('indication').AsString = CheckBox.Caption) then
              begin
                RecordExists := True;
                Break;
              end;
              fcdsDUE.Next;
            end;

            // Determine if the record should be inserted
            ShouldInsert := not RecordExists; // Adjust condition as needed

            if ShouldInsert then
            begin
              // Insert new record into the dataset
              fcdsDUE.Insert;
              fcdsDUE.FieldByName('drug_due_id').AsString := getsqldata('SELECT get_serialnumber("drug_due_list")');
              fcdsDUE.FieldByName('generic_name').AsString := ModifiedName;
              fcdsDUE.FieldByName('vn').AsString := vn;
              fcdsDUE.FieldByName('doctor').AsString := doctor;
              fcdsDUE.FieldByName('entry_date').AsDateTime := Now;
              fcdsDUE.FieldByName('indication').AsString := CheckBox.Caption;
              fcdsDUE.Post;

              // Update database
              hosxp_updatedelta(fcdsDUE.Delta, 'SELECT * FROM drug_due_list');
            end
            else
            begin
              // If the record should not be inserted, you can log or handle this case here
              ShowMessage('Record already exists for ' + ModifiedName + ' with indication ' + CheckBox.Caption);
            end;

          finally
            fcdsDUE.Free;
          end;
        end;
      end;

      //ShowMessage('Records successfully saved.');
    end
    else
    begin
      ShowMessage('No checkboxes are selected.');
    end;
  except
    on E: Exception do
      ShowMessage('Error saving data: ' + E.Message);
  end;
end;


procedure TForm1.Button1Click(Sender: TObject);
var
  i, j: Integer;
  CheckBox: TCheckBox;
  AtLeastOneChecked: Boolean;
begin
  // Iterate over each generic name in the list
  for i := 0 to genericNameList.Count - 1 do
  begin
    AtLeastOneChecked := False;

    // Check if at least one checkbox associated with the current generic name is checked
    for j := 0 to CheckBoxList.Count - 1 do
    begin
      CheckBox := TCheckBox(CheckBoxList.Objects[j]);
      
      // Assume CheckBox.Tag stores the index corresponding to the generic name in genericNameList
      if (CheckBox.Tag = i + 1) and CheckBox.Checked then
      begin
        AtLeastOneChecked := True;
        Break; // Exit the loop as soon as we find one checked checkbox for the current generic name
      end;
    end;

    // If no checkbox is checked for the current generic name, show a message and exit
    if not AtLeastOneChecked then
    begin
      ShowMessage('Please select at least one item for ' + genericNameList[i] + ' before saving.');
      Exit;
    end;
  end;

  // If all checks pass, proceed to save
  try
    SaveCheckedItemsToDatabase;
    Close; // Close the form if everything is valid
  except
    on E: Exception do
      ShowMessage('Error saving data: ' + E.Message);
  end;
end;



procedure TForm1.FormDestroy(Sender: TObject);
begin
  CheckBoxList.Free; // Free CheckBoxList when the form is destroyed
  genericNameList.Free;
end;

end.



}

DFM

โค๊ด: [Select]

object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Drug Use Evaluation (DUE)'
  ClientHeight = 600
  ClientWidth = 800
  Color = clWindow
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnShow = showdata                  
  PixelsPerInch = 96
  TextHeight = 13
  object Shape1: TShape
    Left = 10
    Top = 10
    Width = 780
    Height = 85
    Pen.Color = clWindowFrame
  end
    object Shape2: TShape
    Left = 10
    Top = 105
    Width = 780
    Height = 485
    Pen.Color = clWindowFrame
  end
  object Label2: TLabel
    Left = 168
    Top = 48
    Width = 33
    Height = 16
    Caption = 'ª×èÍ - Ê¡ØÅ'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -13
    Font.Name = 'Tahoma'
    Font.Style = []
    ParentFont = False
  end
  object Label3: TLabel
    Left = 400
    Top = 48
    Width = 22
    Height = 16
    Caption = 'ÍÒÂØ'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -13
    Font.Name = 'Tahoma'
    Font.Style = []
    ParentFont = False
  end
   object Year: TLabel
    Left = 450
    Top = 48
    Width = 22
    Height = 16
    Caption = '»Õ'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -13
    Font.Name = 'Tahoma'
    Font.Style = []
    ParentFont = False
  end
    object age_yLabel: TLabel
    Left = 430
    Top = 48
    Width = 22
    Height = 16
    Caption = '»Õ'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -13
    Font.Name = 'Tahoma'
    Font.Style = []
    ParentFont = False
  end
  object Label4: TLabel
    Left = 32
    Top = 68
    Width = 54
    Height = 16
    Caption = 'Diagnosis'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -13
    Font.Name = 'Tahoma'
    Font.Style = []
    ParentFont = False
  end
  object pdxLabel: TLabel
    Left = 100
    Top = 68
    Width = 20
    Height = 16
    Caption = 'pdx'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -13
    Font.Name = 'Tahoma'
    Font.Style = []
    ParentFont = False
  end
  object Label1: TLabel
    Left = 32
    Top = 48
    Width = 16
    Height = 16
    Caption = 'HN'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -13
    Font.Name = 'Tahoma'
    Font.Style = []
    ParentFont = False
  end
  object Label8: TLabel
    Left = 30
    Top = 16
    Width = 108
    Height = 16
    Caption = 'Patient information'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -13
    Font.Name = 'Tahoma'
    Font.Style = []
    ParentFont = False
  end

  object Label10: TLabel
    Left = 55
    Top = 48
    Width = 14
    Height = 16
    Caption = 'hn'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -13
    Font.Name = 'Tahoma'
    Font.Style = []
    ParentFont = False
  end
  object Label12: TLabel
    Left = 230
    Top = 48
    Width = 49
    Height = 16
    Caption = 'fullname'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -13
    Font.Name = 'Tahoma'
    Font.Style = []
    ParentFont = False
  end
  object Label13: TLabel
    Left = 500
    Top = 48
    Width = 35
    Height = 16
    Caption = 'ÊÔ·¸Ô¡ÒÃÃÑ¡ÉÒ'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -13
    Font.Name = 'Tahoma'
    Font.Style = []
    ParentFont = False
  end
  object Label14: TLabel
    Left = 580
    Top = 48
    Width = 35
    Height = 16
    Caption = 'Pttype'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -13
    Font.Name = 'Tahoma'
    Font.Style = []
    ParentFont = False
  end

  object DoctorLabel: TLabel
    Left = 480
    Top = 532
    Width = 35
    Height = 16
    Caption = ''
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -13
    Font.Name = 'Tahoma'
    Font.Style = []
    ParentFont = False
  end

  object Button1: TButton
    Left = 660
    Top = 530
    Width = 75
    Height = 25
    Caption = 'ºÑ¹·Ö¡'
    TabOrder = 0
    OnClick = Button1Click
  end


end

กระทู้เมื่อเร็วๆ นี้

แจ้งข้อผิดพลาดการทำงานของ HOSxP V3 / hosxp XE pcu upstructure แล้วerror 42000 row size too large แก้ไขยังไงครับ

Delphi / Pascal / DUE Script

แจ้งปัญหา / ขอความช่วยเหลือ / Re: ขอสอบถามเกี่ยวกับระบบสแกนนิ้วคนไข้ที่ห้องบัตรครับ

แจ้งปัญหา / ขอความช่วยเหลือ / Re: ค่า Adj.rw ไม่คำนวณ แก้ไขยังครับ

HOSxP : XE / Re: เพิ่มขนาดfontโปรแกรม

HOSxP : XE / Re: เพิ่มขนาดfontโปรแกรม

แจ้งปัญหา / ขอความช่วยเหลือ / ค่า Adj.rw ไม่คำนวณ แก้ไขยังครับ

HOSxP : XE / เพิ่มขนาดfontโปรแกรม

HOSxP : XE / Re: AI Dx

แจ้งปัญหา / ขอความช่วยเหลือ / Re: lock icd10