Списки. Сортировка записи. Делфи

[TImRik]

Program Lab9;
{$APPTYPE CONSOLE}
Uses
 SysUtils;
Type
 point=^zap;
 zap=record
  det:string[10];
  diam:integer;
  p:point;
 end;

procedure SortBublInf(nach:point);
var
  tmp,rab:point;
  tmps:integer;
  stroka:string;
begin
  New(tmp);
  rab:=nach; {рабочая ссылка, становимся на вершину стека}
  while rab<>nil do {пока мы не дойдём до конца стека делать}
  begin
    tmp:=rab^.p; {перейдём на следующий элемент}
    while tmp<>nil do {пока не конец стека делать}
    begin
      if tmp^.diam<rab^.diam then {проверяем следует ли менять элементы}
      begin
        tmps:=tmp^.diam; {стандартная замена в 3 операции}
        tmp^.diam:=rab^.diam;
        rab^.diam:=tmps;
        stroka:=tmp^.det;
        tmp^.det:=rab^.det;
        rab^.det:=stroka;
      end;
      tmp:=tmp^.p {переход к следующему элементу}
    end;
    rab:=rab^.p {переход к следующему элементу}
  end
end;


Var
 r,q:point;
 a:zap;
Begin
 new(r);
 r^.p:=nil;
 Writeln('Input surnname');
 Readln(r^.det);
 writeln ('Room');
 readln (r^.diam);
 Writeln('Input surname or end');
 ReadLn(a.det);
 while a.det<>'end' do
  begin
   writeln ('Room');
   Readln(a.diam);
   q:=r;
   new(r);
   r^.det:=a.det;
   r^.diam:=a.diam;
   r^.p:=q;
   Writeln('Input surname or end');
   ReadLn(a.det);
  end;
 q:=r;
 if q=nil then
  WriteLn('No records')
 else
  while q<>nil do
   begin
    WriteLn(q^.det:11,' ',q^.diam:1);
    q:=q^.p;
   end;
 Readln;
 SortBublInf (r^.p);
 q:=r;
 if q=nil then
  WriteLn('No records')
 else
  while q<>nil do
   begin
    WriteLn(q^.det:11,' ',q^.diam:1);
    q:=q^.p;
   end;
 readln;
end.

Условие:
С клавиатуры вводятся записи, содержащие сведения о проживающих в гостинице (номер комнаты и фамилия). Сформировать и вывести список проживающих, упорядоченный по номерам комнат. Добавить новую запись, введенную с клавиатуры.
Список сортируется, но первый элемент всегда остаётся на своём месте. Не понимаю в чём ошибка. Подскажите, если кто разглядел.