I deliberately got rid of thrible cycles like
for i:=
 for j:=
  for k:=
replacing the last one with while cycle. But I still get WA.
I think my alogorythm is correct, because it's very simple - although
it's O(n^4). I first find the minimal number of changes I have to do
to get from one route to another, and then choose the best stop.
Could anyone help me?

Program Meeting;
 Const Max=100; Const BB=MaxLongInt Div 2; Price=4;
 Type TPer=Record
       Mon:Longint;
       Stop:Longint;
       Tick:Boolean;
      End;
 Var n,m,k:Longint;
     rt:Array[1..Max,1..Max] Of Boolean; {routes description}
     pr:Array[1..Max] Of TPer; {people description}
     rm:Array[1..Max,1..Max] Of Longint;{edges between routes}
     br:Array[1..Max,1..Max] Of Longint;{min ways between routes}
 Procedure ReadData;
  Var i,j,l:Longint;
 Begin
  Read(n,m);
  FillChar(rt,SizeOf(rt),False);
  For i:=1 To m Do Begin
   Read(l);
   For j:=1 To l Do Begin
    Read(k);
    rt[i,k]:=True;
   End;
  End;
  Read(k);
  For i:=1 To k Do
   With pr[i] Do Begin
    Read(Mon,Stop,l);
    Tick:=l=1;
   End;
 End;
 Procedure FillRM;
  Var i,j,k:Longint;
 Begin
  For i:=1 To m Do
   For j:=1 To m Do
    rm[i,j]:=BB;
  For i:=1 To m Do
   For j:=1 To m Do Begin
    If i=j Then
     rm[i,j]:=0
    Else Begin
     k:=0;
     While  k<n Do Begin
      Inc(k);
      If ((rt[i,k]) And (rt[j,k])) Then Begin
       rm[i,j]:=Price;
       Break;
      End;
     End;
    End;
   End;
 End;
 Procedure Floyd;
  Var i,j,k:Longint;
 Begin
  Move(rm,br,SizeOf(br));
  For k:=1 To m Do
   For i:=1 To m Do Begin
    j:=0;
    While j<m Do Begin
     Inc(j);
     If br[i,j]>br[i,k]+br[k,j] Then
      br[i,j]:=br[i,k]+br[k,j];
    End;
   End;
 End;
 Procedure Choose;
  Label 1;
  Var i,j,bi,bp,s,ds:Longint;
  Function D(x,y:Longint):Longint;
   {Minimal price between two stops}
   Var i,j,bp:Longint;
  Begin
   If x=y Then Begin
    D:=0;
    Exit;
   End;
   bp:=BB;
   For i:=1 To m Do
    For j:=1 To m Do
     If ((rt[i,x]) And (rt[j,y])) Then
      If br[i,j]+Price<bp Then
       bp:=br[i,j]+Price;
   D:=bp;
  End;
 Begin
  bi:=0; bp:=BB;
  For i:=1 To n Do Begin
   s:=0;
   For j:=1 To k Do
    If pr[j].Stop<>i Then Begin
     ds:=D(pr[j].Stop,i);
     If ds>pr[j].Mon Then
      Goto 1;
     If Not pr[j].Tick Then
      s:=s+ds;
    End;
   If s<bp Then Begin
    bp:=s;
    bi:=i;
   End;
   1:
  End;
  If bp=BB Then
   Writeln(0)
  Else
   Writeln(bi,' ',bp);
 End;
Begin
 ReadData;
 FillRM;
 Floyd;
 Choose;
End.