📄 dicom.~pas

📁 CT DCOM源代码
💻 ~PAS
📖 第 1 页 / 共 4 页
字号:
12 3 4 下一页
unit DICOM;
// Limitations
//- only reads data with 8/16 bit data_alloc
//- compiling for Pascal other than Delphi 2.0+: gDynStr gets VERY big
//- does not extract encapsulated/compressed images
//- write_dicom: currently only writes little endian, data should be little_endian
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, ComCtrls, ClipView, Buttons;
{$H+} //use long, dynamic strings

type
ByteRA = array [1..1] of byte;
Bytep = ^ByteRA;

  DICOMdata = record
   XYZdim: array [1..3] of integer;
   XYZori: array [1..3] of integer;
   XYZmm: array [1..3] of double;
   IntenScale: double;
   ImageStart: integer;
   little_endian   : Integer;//1;  //1 for pre-swapped
	Allocbits_per_pixel : Integer;
	Storedbits_per_pixel : Integer;
     ImageSz: integer;
  end;
//type
	int32  = LongInt;
	uint32 = Cardinal;
	int16  = SmallInt;
	uint16 = Word;
	int8   = ShortInt;
	uint8  = Byte;
const
     kCR = chr (13);
kA = ord('A');
kB = ord('B');
kC = ord('C');
kD = ord('D');
kE = ord('E');
kF = ord('F');
kG = ord('G');
kH = ord('H');
kI = ord('I');
kJ = ord('J');
kK = ord('K');
kL = ord('L');
kM = ord('M');
kN = ord('N');
kO = ord('O');
kP = ord('P');
kQ = ord('Q');
kR = ord('R');
kS = ord('S');
kT = ord('T');
kU = ord('U');
kV = ord('V');
kW = ord('W');
kX = ord('X');
kY= ord('Y');
kZ= ord('Z');
procedure read_dicom_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string; lFileName: string{var fp:File} );
procedure write_dicom (lFileName: string; var pDICOMdata: DICOMdata;var lSz: integer; lDICOM3: boolean);
implementation

procedure write_dicom (lFileName: string; var pDICOMdata: DICOMdata;var lSz: integer; lDICOM3: boolean);
var
   fp: file;
   lHiBit,lGrpError,lStart,lEnd,lInc,lPos: integer;
   lP: bytep;
//     WriteGroupElement(lDICOM3,-1,lPos,$0002,$0010,'U','I','1.2.840.10008.1.2')//implicit xfer syntax
procedure WriteGroupElement(lExplicit: boolean; lInt2,lInt4: integer; var lPos: integer;lGrp,lEle: integer;lChar1,lChar2: char;lInStr: string);
var
     lStr: string;
//	t1, t2 : uint8;
     lPad: boolean;
  n,lStrLen      : Integer;
     lT0,lT1: byte;
begin
     lStr := lInStr;
     lPad := false;
     lT0 := ord(lChar1);
     lT1 := ord(lChar2);
     if (lInt2 >= 0) then
        lStrLen := 2
     else if (lInt4 >= 0) then
        lStrLen := 4
     else begin
          lStrLen := length(lStr);
          if odd(lStrLen) then begin
             inc(lStrLen);
             lPad := true;
             //lStr := lStr + ' ';
          end;
     end;
     lP[lPos+1] := lGrp and $00FF;
     lP[lPos+2] := (lGrp and $FF00) shr 8;
     lP[lPos+3] := lEle and $00FF;
     lP[lPos+4] := (lEle and $FF00) shr 8;
     lInc := 4; //how many bytes have we added;

     if (lExplicit) and ( ((lT0=kO) and (lT1=kB)) or ((lT0=kO) and (lT1=kW))
      or ((lT0=kS) and (lT1=kQ)) )
      then begin

           lP[lPos+5] := lT0;
           lP[lPos+6] := lT1;
           lP[lPos+7] := 0;
           lP[lPos+8] := 0;
           lInc := lInc + 4;
           if lgrp <> $7FE0 then begin
              lP[lPos+9] := lStrLen and $000000FF;
              lP[lPos+10] := lStrLen and $0000FF00;
              lP[lPos+11] := lStrLen and $00FF0000;
              lP[lPos+12] := lStrLen and $FF000000;
              lInc := lInc + 4;
           end;
   end else
   if (lExplicit) and ( ((lT0=kA) and (lT1=kE)) or ((lT0=kA) and (lT1=kS))
      or ((lT0=kA) and (lT1=kT)) or ((lT0=kC) and (lT1=kS)) or ((lT0=kD) and (lT1=kA))
      or ((lT0=kD) and (lT1=kS))
      or ((lT0=kD) and (lT1=kT)) or ((lT0=kF) and (lT1=kL)) or ((lT0=kF) and (lT1=kD))
      or ((lT0=kI) and (lT1=kS)) or ((lT0=kL) and (lT1=kO))or ((lT0=kL) and (lT1=kT))
      or ((lT0=kP) and (lT1=kN)) or ((lT0=kS) and (lT1=kH)) or ((lT0=kS) and (lT1=kL))
      or ((lT0=kS) and (lT1=kS)) or ((lT0=kS) and (lT1=kT)) or ((lT0=kT) and (lT1=kM))
      or ((lT0=kU) and (lT1=kI)) or ((lT0=kU) and (lT1=kL)) or ((lT0=kU) and (lT1=kS))
      or ((lT0=kA) and (lT1=kE)) or ((lT0=kA) and (lT1=kS)) )
      then begin
           lP[lPos+5] := lT0;
           lP[lPos+6] := lT1;
           lP[lPos+7] := lStrLen and $000000FF;
           lP[lPos+8] := lStrLen and $00000FF00;
           lInc := lInc + 4;
   end else if (not ( ((lT0=kO) and (lT1=kB)) or ((lT0=kO) and (lT1=kW))
      or ((lT0=kS) and (lT1=kQ)) )) then begin {Not explicit}
           lP[lPos+5] := lStrLen and $000000FF;
           lP[lPos+6] := lStrLen and $0000FF00;
           lP[lPos+7] := lStrLen and $00FF0000;
           lP[lPos+8] := lStrLen and $FF000000;
           lInc := lInc + 4;
   end;
   if lstrlen = 0 then exit;
   lPos := lPos + lInc;
   if lInt2 >= 0 then begin
       inc(lPos);
       lP[lPos] := lInt2 and $00FF;
       inc(lPos);
       lP[lPos] := (lInt2 and $FF00) shr 8;
//       showmessage(inttostr(lInt2));
       exit;
   end;
   if lInt4 >= 0 then begin
       inc(lPos);
       lP[lPos] := lInt4 and $000000FF;
       inc(lPos);
       lP[lPos] := (lInt4 and $0000FF00) shr 8;
       inc(lPos);
       lP[lPos] := (lInt4 and $00FF0000) shr 16;
       inc(lPos);
       lP[lPos] := (lInt4 and $FF000000) shr 24;
       exit;
   end;
   if lPad then begin
       for n := 1 to (lstrlen-1) do begin
            lPos := lPos + 1;
            lP[lPos] := ord(lStr[n]);
       end;
       lPos := lPos + 1;
       lP[lPos] := 0;
   end else begin
       for n := 1 to lstrlen do begin
            lPos := lPos + 1;
            lP[lPos] := ord(lStr[n]);
       end;
   end;
//   lInc := lInc + lStrLen;

end;

begin
     lSz := 0;
  getmem(lP,1024);
  if lDiCOM3 then begin
     for lInc := 1 to 127 do
      lP[lInc] := 0;
     lP[lInc+1] := ord('D');
     lP[lInc+2] := ord('I');
     lP[lInc+3] := ord('C');
     lP[lInc+4] := ord('M');
     lPos := 128 + 4;
     lGrpError := 12;
  end else begin
      lPos := 0;
      lGrpError := 12;
  end;
if lDICOM3 then begin
  lStart := lPos;
  WriteGroupElement(lDICOM3,-1,2,lPos,$0002,$0000,'U','L','');//length
 //xx  WriteGroupElement(lDICOM3,256,-1,lPos,$0002,$0001,'O','B','');//meta info
  WriteGroupElement(lDICOM3,256,-1,lPos,$0002,$0001,'O','B',' ');//256
  WriteGroupElement(lDICOM3,-1,-1,lPos,$0002,$0002,'U','I','1.2.840.10008.5.1.4.1.1.4');//implicit xfer syntax
  WriteGroupElement(lDICOM3,-1,-1,lPos,$0002,$0003,'U','I','999.999.2.19960619.163000.1.103');//implicit xfer syntax
  if not lDICOM3 then
     WriteGroupElement(lDICOM3,-1,-1,lPos,$0002,$0010,'U','I','1.2.840.10008.1.2')//implicit xfer syntax
  else if pDicomData.little_endian = 1 then
     WriteGroupElement(lDICOM3,-1,-1,lPos,$0002,$0010,'U','I','1.2.840.10008.1.2.1')//little xfer syntax
  else
     WriteGroupElement(lDICOM3,-1,-1,lPos,$0002,$0010,'U','I','1.2.840.10008.1.2.2');//furezx should be 2//big xfer syntax
  WriteGroupElement(lDICOM3,-1,-1,lPos,$0002,$0012,'U','I','999.999');//implicit xfer syntax
  lEnd := lPos;
  lPos := lStart;
  WriteGroupElement(lDICOM3,-1,lEnd-lStart-lGrpError,lPos,$0002,$0000,'U','L','');//length
  lPos := lEnd;
end;
  lStart := lPos;
  WriteGroupElement(lDICOM3,-1,18,lPos,$0008,$0000,'U','L','');//length
 if not lDICOM3 then
     WriteGroupElement(lDICOM3,-1,2,lPos,$0008,$0010,'L','O','ACR-NEMA 2.0');//length
  WriteGroupElement(lDICOM3,-1,-1,lPos,$0008,$0008,'C','S','ORIGINAL\PRIMARY');//
  WriteGroupElement(lDICOM3,-1,-1,lPos,$0008,$0016,'U','I','1.2.840.10008.5.1.4.1.1.4');//
  WriteGroupElement(lDICOM3,-1,-1,lPos,$0008,$0018,'U','I','999.999.2.19960619.163000.1.103');
//a  WriteGroupElement(lDICOM3,-1,-1,lPos,$0008,$0020,'D','A','1995.06.26');//implicit xfer syntax
//a  WriteGroupElement(lDICOM3,-1,-1,lPos,$0008,$0023,'D','A','1995.06.26');//implicit xfer syntax
//a  WriteGroupElement(lDICOM3,-1,-1,lPos,$0008,$0030,'T','M','11:20:00');//implicit xfer syntax
  WriteGroupElement(lDICOM3,-1,-1,lPos,$0008,$0060,'C','S','MR');//modality
  WriteGroupElement(lDICOM3,-1,-1,lPos,$0008,$0070,'L','O','MRIcro');//modality
//a  WriteGroupElement(lDICOM3,-1,-1,lPos,$0008,$0080,'L','O','Community Hospital');//modality
//a  WriteGroupElement(lDICOM3,-1,-1,lPos,$0008,$0081,'S','T','Anytown');//modality
  WriteGroupElement(lDICOM3,-1,-1,lPos,$0008,$0090,'P','N','Anonymized');//name
  WriteGroupElement(lDICOM3,-1,-1,lPos,$0008,$1030,'L','O','MRI');//modality
  lEnd := lPos;
  lPos := lStart;
  WriteGroupElement(lDICOM3,-1,lEnd-lStart-lGrpError,lPos,$0008,$0000,'U','L','');//length
  lPos := lEnd;

  lStart := lPos;
  WriteGroupElement(lDICOM3,-1,18,lPos,$0010,$0000,'U','L','');//length
  WriteGroupElement(lDICOM3,-1,-1,lPos,$0010,$0010,'P','N','Anonymized');//name
  lEnd := lPos;
  lPos := lStart;
  WriteGroupElement(lDICOM3,-1,lEnd-lStart-lGrpError,lPos,$0010,$0000,'U','L','');//length
  lPos := lEnd;

  lStart := lPos;
  WriteGroupElement(lDICOM3,-1,18,lPos,$0018,$0000,'U','L','');//length
  WriteGroupElement(lDICOM3,-1,-1,lPos,$0018,$0050,'D','S',floattostrf(pDicomData.XYZmm[3],ffFixed,8,2));//slice thickness
//a  WriteGroupElement(lDICOM3,-1,-1,lPos,$0018,$0080,'D','S',floattostrf(1333.33,ffFixed,8,2));//
//a  WriteGroupElement(lDICOM3,-1,-1,lPos,$0018,$0081,'D','S',floattostrf(11.98,ffFixed,8,2));//
//a  WriteGroupElement(lDICOM3,-1,-1,lPos,$0018,$0089,'I','S','16');//Study UID
//a  WriteGroupElement(lDICOM3,-1,-1,lPos,$0018,$1063,'D','S',floattostrf(69.47,ffFixed,8,2));//
  WriteGroupElement(lDICOM3,-1,-1,lPos,$0018,$1020,'L','O',inttostr(pDicomData.XYZori[1])+'\'+inttostr(pDicomData.XYZori[2])+'\'+inttostr(pDicomData.XYZori[3]));//software version
//a  WriteGroupElement(lDICOM3,-1,-1,lPos,$0018,$1149,'I','S','350');//Study UID
//a  WriteGroupElement(lDICOM3,-1,-1,lPos,$0018,$1314,'D','S','50');//slice thickness
  lEnd := lPos;                                                                            
  lPos := lStart;
  WriteGroupElement(lDICOM3,-1,lEnd-lStart-lGrpError,lPos,$0018,$0000,'U','L','');//length
  lPos := lEnd;


  lStart := lPos;
  WriteGroupElement(lDICOM3,-1,18,lPos,$0020,$0000,'U','L','');//length
  WriteGroupElement(lDICOM3,-1,-1,lPos,$0020,$000D,'U','I','999.999.2.19960619.163000');//Study UID
  WriteGroupElement(lDICOM3,-1,-1,lPos,$0020,$000E,'U','I','999.999.2.19960619.163000.1');//Study UID
  WriteGroupElement(lDICOM3,-1,-1,lPos,$0020,$0011,'I','S','1');//Study UID
  WriteGroupElement(lDICOM3,-1,-1,lPos,$0020,$0013,'I','S','103');//Study UID
//  WriteGroupElement(lDICOM3,-1,-1,lPos,$0020,$1041,'D','S',floattostrf(1-pDicomData.XYZdim[3],ffFixed,8,2));//$1041: info := 'Slice Location';
  lEnd := lPos;
  lPos := lStart;
  WriteGroupElement(lDICOM3,-1,lEnd-lStart-lGrpError,lPos,$0020,$0000,'U','L','');//length
  lPos := lEnd;

  lStart := lPos;
  WriteGroupElement(lDICOM3,-1,28,lPos,$0028,$0000,'U','L','');//length
  WriteGroupElement(lDICOM3,1,-1,lPos,$0028,$0002,'U','S','');
  WriteGroupElement(lDICOM3,-1,-1,lPos,$0028,$0004,'C','S','MONOCHROME2');
  WriteGroupElement(lDICOM3,-1,-1,lPos,$0028,$0008,'I','S',inttostr(pDicomData.XYZdim[3]));//num frames
//a  WriteGroupElement(lDICOM3,-1,($1063 shl 16)+($18 ),lPos,$0028,$0009,'A','T','');//frame ptr

  WriteGroupElement(lDICOM3,pDicomData.XYZdim[2],-1,lPos,$0028,$0010,'U','S',' ');//inttostr(lDicomData.XYZdim[2]));//row
  WriteGroupElement(lDICOM3,pDicomData.XYZdim[1],-1,lPos,$0028,$0011,'U','S',' ');//inttostr(lDicomData.XYZdim[1]));//col
12 3 4 下一页
💿 文件大小 240 K
👤 上传用户 szdoudou
📂 所属分类 Delphi控件源码
🏷️ 相关标签

#DCOM #CT #源代码
⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -