jk_unit_frmpacscommunication.pas

a program written by delphi about middle layer

unit jk_Unit_frmPacsCommunication;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, ScktComp, DB, DBClient, MConnect, StdCtrls, ComCtrls,
  Menus;

type
  TfrmPacsCommunication = class(TForm)
    Panel2: TPanel;
    btnConnect: TButton;
    Label1: TLabel;
    lblStatus: TLabel;
    pclog: TPageControl;
    TabSheet1: TTabSheet;
    lbcomm: TListBox;
    TabSheet2: TTabSheet;
    lbconn: TListBox;
    dmc_query: TDCOMConnection;
    cds_query: TClientDataSet;
    cds_port: TClientDataSet;
    pacsClient: TClientSocket;
    tmPacsConn: TTimer;
    PopupMenu1: TPopupMenu;
    N1: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure pacsClientConnect(Sender: TObject; Socket: TCustomWinSocket);
    procedure pacsClientError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure pacsClientDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure tmPacsConnTimer(Sender: TObject);
    procedure btnConnectClick(Sender: TObject);
    procedure N1Click(Sender: TObject);
    procedure FormShortCut(var Msg: TWMKey; var Handled: Boolean);
  private
    { Private declarations }
    isPacsNode: boolean;
    procedure setconnstatus(Connected: boolean);
    procedure settmstatus(Connected: boolean);
    procedure init;
    function pacs_disp_capt(pchkcard: string; ppart: string; pt: integer): integer;  //0 success, -1 failure
    function pacs_frmae_checksum(s: string): string;
    function pacs_frmae_pack(s: string): string;
    function set_pacs_socket(node: string): boolean;
    function pacs_connect(): boolean;
    procedure SetPacsNode(b: boolean);
    function readPacsNode(): boolean;
    procedure commlog(code: string; desc: string);
    procedure connlog(code: string; desc: string);
  public
    { Public declarations }
    function pacs_display(pchkcard: string; ppart: string): integer;
    function pacs_capture(pchkcard: string; ppart: string): integer;
  end;

var
  frmPacsCommunication: TfrmPacsCommunication;
implementation

uses Unit_global_variant;

{$R *.dfm}

function TfrmPacsCommunication.set_pacs_socket(node: string): boolean;
begin
    with cds_query do
    begin
        Close;
        FetchParams;
        Params.ParamByName('node').AsString := node;
        Open;
        pacsClient.Host := FieldByName('pacs_ip').AsString;
        if FieldByName('pacs_need').AsString = '1' then
            isPacsNode := true
        else
            isPacsNode := false;
        Close;
    end;
    with cds_port do
    begin
        Close;
        Open;
        pacsClient.Port := FieldByName('param_value').AsInteger;
        Close;
    end;
    result := true;
end;

function TfrmPacsCommunication.pacs_connect(): boolean;
begin
    settmstatus(false);
    try
        with pacsClient do
        begin
            Close;
            Open;
        end;
        result := true;
    except
        result := false;
    end;
    connlog('CONN:', '开始连接');
end;

function TfrmPacsCommunication.pacs_frmae_pack(s: string): string;
begin
    s := #02 + s + #03;
    result := s;
end;

function TfrmPacsCommunication.pacs_frmae_checksum(s: string): string;
var
    i, j, k: integer;
    sbit: string;
begin
    j := 0;
    k := 256;
    for i := 1 to length(s) do
        j := j + ord(s[i]);
    j := j mod k;

    result := IntToHex(j, 2);
end;

function TfrmPacsCommunication.pacs_disp_capt(pchkcard: string; ppart: string; pt: integer): integer;
var
    strFrame: string;
begin
    if not ReadPacsNode then exit;
    //strFrame := '|F|' + IntToStr(pt) + '|A|' + FormatDatetime('yyyymmdd',now) + trim(pchkcard) + '|D|' + ppart;
    strFrame := '|F|' + IntToStr(pt) + '|A|' + FormatDatetime('yyyymmdd',now) + trim(pchkcard);
    strFrame := pacs_frmae_pack(strFrame) + pacs_frmae_checksum(strFrame);

    case pt of
      2 : commlog('DSP', strFrame);
      3 : commlog('CPT', strFrame);
    else  commlog('ERR', strFrame);
    end;

    with pacsClient do
    begin
        try
            Socket.SendText(strFrame);
        except
            result := -1;
            exit;
            //raise;
        end;
    end;
    //commlog('SND', strFrame);
    result := 0;
end;

function TfrmPacsCommunication.pacs_capture(pchkcard: string; ppart: string): integer;
begin
    result := pacs_disp_capt(pchkcard, ppart, 2);
end;

function TfrmPacsCommunication.pacs_display(pchkcard: string; ppart: string): integer;
begin
    result := pacs_disp_capt(pchkcard, ppart, 3);
end;

procedure TfrmPacsCommunication.init;
begin
    settmstatus(false);
    setconnstatus(false);
end;

procedure TfrmPacsCommunication.FormCreate(Sender: TObject);
begin
    inherited;
    dmc_query.Connected := false;
    dmc_query.ComputerName := gv_appserver;
    dmc_query.Connected := true;
    pclog.ActivePageIndex := 0;
    tmPacsConn.Enabled := false;
    set_pacs_socket(gv_node_no);
    if ReadPacsNode then pacs_connect;
end;

procedure TfrmPacsCommunication.pacsClientConnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
    inherited;
    setconnstatus(true);
    settmstatus(false);
    connlog('CONN','连接建立');
end;

procedure TfrmPacsCommunication.setconnstatus(Connected: boolean);
begin
    inherited;
    with lblStatus do
    begin
        if Connected then
        begin
            Caption := '已连接';
            Font.Color := clGreen;
        end else begin
            Caption := '未连接';
            Font.Color := clRed;
        end;
    end;
end;

procedure TfrmPacsCommunication.settmstatus(Connected: boolean);
begin
    tmpacsconn.Enabled := Connected;
end;

procedure TfrmPacsCommunication.pacsClientError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
begin
    inherited;
    connlog('ERR',IntToStr(ErrorCode));
    ErrorCode := 0;
    setconnstatus(false);
    settmstatus(true);
    //tmPacsConn.Enabled := true;
end;

procedure TfrmPacsCommunication.pacsClientDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
    inherited;
    connlog('ERR','连接关闭');
    setconnstatus(false);
    settmstatus(true);
    //tmPacsConn.Enabled := true;
end;

procedure TfrmPacsCommunication.tmPacsConnTimer(Sender: TObject);
begin
    //settmstatus(false);
    pacs_connect;
end;

function TfrmPacsCommunication.ReadPacsNode(): boolean;
begin
    result := isPacsNode;
end;

procedure TfrmPacsCommunication.SetPacsNode(b: boolean);
begin
    isPacsNode := b;
end;

procedure TfrmPacsCommunication.btnConnectClick(Sender: TObject);
begin
    pacs_connect;
end;

procedure TfrmPacsCommunication.commlog(code: string; desc: string);
begin
    lbcomm.Items.Add(code + '-' + DatetimeToStr(now) + '-:' + desc);
end;

procedure TfrmPacsCommunication.connlog(code: string; desc: string);
begin
    lbconn.Items.Add(code + '-' + DatetimeToStr(now) + ':-' + desc);
end;

procedure TfrmPacsCommunication.N1Click(Sender: TObject);
begin
    lbconn.Clear;
end;

procedure TfrmPacsCommunication.FormShortCut(var Msg: TWMKey;
  var Handled: Boolean);
begin
    if Msg.CharCode = VK_F1 then Close;
end;

end.