dicom.~pas

CT DCOM源代码

  WriteGroupElement(lDICOM3,-1,-1,lPos,$0028,$0030,'D','S',floattostrf(pDicomData.XYZmm[2],ffFixed,8,2)+'\'+floattostrf(pDicomData.XYZmm[2],ffFixed,8,2));//pixel spacing
  WriteGroupElement(lDICOM3,pDicomData.Allocbits_per_pixel,-1,lPos,$0028,$0100,'U','S',' ');//inttostr(lDicomData.Allocbits_per_pixel));//bitds alloc
  WriteGroupElement(lDICOM3,pDicomData.Storedbits_per_pixel,-1,lPos,$0028,$0101,'U','S',' ');//inttostr(lDicomData.Storedbits_per_pixel));//bits stored
  if pDicomData.little_endian <> 1 then
     lHiBit := 0
  else
      lHiBit := pDicomData.Storedbits_per_pixel -1;
  WriteGroupElement(lDICOM3,lHiBit,-1,lPos,$0028,$0102,'U','S',' ');//inttostr(lDicomData.Storedbits_per_pixel -1));//high bit
  WriteGroupElement(lDICOM3,0,-1,lPos,$0028,$0103,'U','S',' ');//pixel representation//inttostr(lDicomData.Storedbits_per_pixel -1));//high bit
  WriteGroupElement(lDICOM3,-1,-1,lPos,$0028,$1052,'D','S',floattostrf(0,ffFixed,8,2));//rescale intercept
  WriteGroupElement(lDICOM3,-1,-1,lPos,$0028,$1053,'D','S',floattostrf(pDicomData.IntenScale,ffFixed,8,2));//slice thickness

  lEnd := lPos;
  lPos := lStart;
  WriteGroupElement(lDICOM3,-1,lEnd-lStart-lGrpError,lPos,$0028,$0000,'U','L','');//length
  lPos := lEnd;

  WriteGroupElement(lDICOM3,-1,pDicomData.ImageSz+12,lPos,($7FE0),$0000,'U','L','');//data size
  WriteGroupElement(lDICOM3,-1,pDicomData.ImageSz,lPos,($7FE0),$0010,'O','B','');//data size
  if lFileName <> '' then begin
     AssignFile(fp, lFileName);
     Rewrite(fp, 1);
     blockwrite(fp,lP^,lPos);
     close(fp);
  end;
  freemem(lP);
  lSz := lPos;
end;
procedure read_dicom_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean;  var lDynStr: string; lFileName: string{var fp:File} );
label 666,777;
type
  dicom_types = (unknown, i8, i16, i32, ui8, ui16, ui32, _string );
var
 buff : PChar;
   FP: file;
   lT0,lT1,lT2,lT3:byte;
   lFirstPass,lrOK,lBig,lBigSet,lGrp,explicitVR,first_one    : Boolean;
  time_to_quit : Boolean;
  group, element, dummy, e_len, remaining,{} tmp : uint32;
  lgrpstr,tmpstr,lStr,info   : string;
  t      : dicom_types;
  lfloat1,lfloat2: double;
  slicesz,filesz,where,lStart  : LongInt;
  tx     : array [0..3] of Char;
  n, i   : Integer;
procedure readfloats (var fp: file; remaining: integer; var lOutStr: string; var lf1, lf2: double; var lReadOK: boolean);
var  lDigit : boolean;
   li,lLen,n: integer;
    lfStr: string;
begin
    lf1 := 1;
    lf2 := 2;
if (FilePos(fp) > (filesz-remaining)) or (remaining < 1) then begin
   lOutStr := '';
   lReadOK := false;
   exit;
end else
    lReadOK := true;
    lOutStr := '';
    GetMem( buff, e_len);
    BlockRead(fp, buff^, e_len, n);
    for li := 0 to e_len-1 do
        if Char(buff[li]) in ['/','\','e','E','+','-','.','0'..'9']
           then lOutStr := lOutStr +(Char(buff[li]))
        else lOutStr := lOutStr + ' ';
    FreeMem( buff);
    lfStr := '';
    lLen := length(lOutStr);
    li := 1;
    lDigit := false;
    repeat
      if (lOutStr[li] in ['-','e','E','.','0'..'9']) then
         lfStr := lfStr + lOutStr[li];
      if lOutStr[li] in ['0'..'9'] then lDigit := true;
      inc(li);
    until (li > lLen) or (lDigit);
    if not lDigit then exit;
    if li <= li then begin
       repeat
             if not (lOutStr[li] in ['e','E','.','0'..'9']) then lDigit := false
             else
                          lfStr := lfStr + lOutStr[li];
             inc(li);
       until (li > lLen) or (not lDigit);
    end;
//showmessage(lfStr);
    try
       lf1 := strtofloat(lfStr);
    except
          on EConvertError do begin
             showmessage('Unable to convert the string '+lfStr+' to a real number');
             lf1 := 1;
             exit;
          end;
    end; {except}

    lfStr := '';
    if li > llen then exit;

    repeat
             if (lOutStr[li] in ['E','e','.','-','0'..'9']) then
                lfStr := lfStr + lOutStr[li];
             if (lOutStr[li] in ['0'..'9']) then lDigit := true;
             inc(li);
    until (li > lLen);
    if not lDigit then exit;
    try
       lf2 := strtofloat(lfStr);
    except
          on EConvertError do begin
             showmessage('Unable to convert the string '+lfStr+' to a real number');
             exit;
          end;
    end;

end;
function read16( var fp : File; var lReadOK: boolean ): uint16;
var
	t1, t2 : uint8;
  n      : Integer;
begin
if FilePos(fp) > (filesz-2) then begin
   lReadOK := false;
   exit;
end else
    lReadOK := true;
	BlockRead(fp, t1, SizeOf(uint8), n);
	BlockRead(fp, t2, SizeOf(uint8), n);
  if lDICOMdata.little_endian <> 0
  	then Result := (t1 + t2*256) AND $FFFF
  	else Result := (t1*256 + t2) AND $FFFF;
end;

function  ReadStr(var fp: file; remaining: integer; var lReadOK: boolean) : string;
var lInc, lN,Val,n: integer;
	t1, t2 : uint8;
     lStr : String;
begin
if FilePos(fp) > (filesz-remaining) then begin
   lReadOK := false;
   exit;
end else
    lReadOK := true;
    Result := '';
    lN := remaining div 2;
    if lN < 1 then exit;
    lStr := '';
    for lInc := 1 to lN do begin
	BlockRead(fp, t1, SizeOf(uint8), n);
	BlockRead(fp, t2, SizeOf(uint8), n);
     if lDICOMdata.little_endian <> 0 then
        Val := (t1 + t2*256) AND $FFFF
     else
         Val := (t1*256 + t2) AND $FFFF;
     if lInc < lN then lStr := lStr + inttostr(Val)+ ', '
     else lStr := lStr + inttostr(Val);
//     if Inc > 1 then  lStr := lStr + ', ';
    end;
    Result := lStr;
    if odd(remaining) then BlockRead(fp, t1, SizeOf(uint8), n);
end;
function  ReadStrHex(var fp: file; remaining: integer; var lReadOK: boolean) : string;
var lInc, lN,Val,n: integer;
	t1, t2 : uint8;
     lStr : String;
begin
if FilePos(fp) > (filesz-remaining) then begin
   lReadOK := false;
   exit;
end else
    lReadOK := true;
    Result := '';
    lN := remaining div 2;
    if lN < 1 then exit;
    lStr := '';
    for lInc := 1 to lN do begin
	BlockRead(fp, t1, SizeOf(uint8), n);
	BlockRead(fp, t2, SizeOf(uint8), n);
     if lDICOMdata.little_endian <> 0 then
        Val := (t1 + t2*256) AND $FFFF
     else
         Val := (t1*256 + t2) AND $FFFF;
     if lInc < lN then lStr := lStr + 'x'+inttohex(Val,4)+ ', '
     else lStr := lStr + 'x'+inttohex(Val,4);
//     if Inc > 1 then  lStr := lStr + ', ';
    end;
    Result := lStr;
    if odd(remaining) then BlockRead(fp, t1, SizeOf(uint8), n);
end;

function read32 ( var fp : File; var lReadOK: boolean ): uint32;
var
	t1, t2, t3, t4 : byte;
  n : Integer;
begin
if FilePos(fp) > (filesz-4) then begin
   lReadOK := false;
   exit;
end else
    lReadOK := true;
	BlockRead(fp, t1, SizeOf(uint8), n);
	BlockRead(fp, t2, SizeOf(uint8), n);
	BlockRead(fp, t3, SizeOf(uint8), n);
	BlockRead(fp, t4, SizeOf(uint8), n);
  if lDICOMdata.little_endian <> 0
  	then Result := (t1 + t2*256 + t3*256*256 + t4*256*256*256) AND $FFFFFFFF
    else Result := (t1*256*256*256 + t2*256*256 + t3*256 + t4) AND $FFFFFFFF;
end;

begin
  lImageFormatOK := true;
  lHdrOK := false;
  if not fileexists(lFileName) then begin
     lImageFormatOK := false;
     exit;
  end;
  FileMode := 0; //set to readonly
  AssignFile(fp, lFileName);
  Reset(fp, 1);
     lDICOMdata.XYZmm[1] := 1;
     lDICOMdata.XYZmm[2] := 1;
     lDICOMdata.XYZmm[3] := 1;
     lDICOMdata.XYZdim[1] := 1;
     lDICOMdata.XYZdim[2] := 1;
     lDICOMdata.XYZdim[3] := 1;
     lDICOMdata.ImageStart := 0;
     lDICOMdata.Little_Endian := 1;
  lDynStr := '';
  first_one    := true;
  info := '';
  lGrp:= false;
  lBigSet := false;
    //lGrp := true;
  FIleSz := FileSize(fp);
  t := unknown;
		// try DICOM part 10 i.e. a 128 byte file preamble followed by "DICM"
  if filesz <= 8 then goto 666;
  seek(fp, 0);
  where := FilePos(fp);
  BlockRead(fp, tx, 4*SizeOf(Char), n);
  if (tx[0] <> 'D') OR (tx[1] <> 'I') OR (tx[2] <> 'C') OR (tx[3] <> 'M') then begin
     if filesz > 132 then begin
        seek(fp, 128); //skip the preamble - next 4 bytes should be 'DICM'
  	   where := FilePos(fp);
        BlockRead(fp, tx, 4*SizeOf(Char), n);
     end;
     if (tx[0] <> 'D') OR (tx[1] <> 'I') OR (tx[2] <> 'C') OR (tx[3] <> 'M') then begin
        seek(fp, 0);
        group   := read16(fp,lrOK);
        if not lrOK then goto 666;
        element := read16(fp,lrOK);
        if not lrOK then goto 666;
        if NOT (group in [$0000, $0002, $0004, $0008]) then begin
           goto 666;
        end;
        seek(fp, 0);
     end; //else showmessage('DICM at 128');
  end; //else showmessage('DICM at 0');;
		// Read DICOM Tags
	time_to_quit := FALSE;
     explicitVR := false;
    tmpstr := '';
while NOT time_to_quit do begin
  t := unknown;
  	where     := FilePos(fp);
     lFirstPass := true;
777:
   	group     := read16(fp,lrOK);
     if not lrOK then goto 666;

     if (lFirstPass) and (group = 2048) then begin
         if lDicomData.little_endian = 1 then lDicomData.Little_endian := 0
         else lDicomData.little_endian := 1;
         seek(fp,where);
//         showmessage(inttohex(group,8));
         lFirstPass := false;
         goto 777;
     end;
     element   := read16(fp,lrOK);
     if not lrOK then goto 666;
     e_len:= read32(fp,lrOK);