What wrong with my program? Please help me...
Program n1085;
Const MaxN = 100;
MaxM = 100;
MaxK = 100;
Var n,m,k,step : integer;
i,j,q,w : integer;
money : array [1..MaxK] of integer;
a : array [1..MaxM,1..MaxN] of byte;
b : array [1..MaxK,1..MaxN] of Record
sum : integer;
step,t : byte;
End;
lost,num : longint;
Procedure Init;
Var stop,l : byte;
sum : integer;
Begin
Read(n,m);
FillChar(a,SizeOf(a),0);
For i:=1 to m Do Begin
Read(l);
For j:=1 to l Do Begin
Read(stop);
a[i,stop]:=1;
End;
End;
Read(k);
For i:=1 to k Do
For j:=1 to n Do Begin
b[i,j].sum:=0;
b[i,j].step:=0;
b[i,j].t:=0;
End;
For i:=1 to k Do Begin
Read(sum,stop,l);
money[i]:=sum;
b[i,stop].sum:=sum;
b[i,stop].step:=1;
b[i,stop].t:=l;
End;
End;
Procedure Solve;
Var yes : boolean;
Begin
step:=1;
While true Do Begin
yes:=true;
For i:=1 to k Do
For j:=1 to n Do
If (b[i,j].step=step) and (b[i,j].sum>=4) Then Begin
yes:=false;
For q:=1 to m Do
If a[q,j]=1 Then
For w:=1 to n Do
If (a[q,w]=1) and (b[i,w].step=0) Then Begin
b[i,w].step:=step+1;
b[i,w].t:=b[i,j].t;
If b[i,j].t=0 Then b[i,w].sum:=b[i,j].sum-4
Else b[i,w].sum:=b[i,j].sum;
End;
End;
If yes Then Break;
step:=step+1;
End;
End;
Procedure SearchAns;
Var yes : boolean;
los : longint;
Begin
lost:=MaxLongInt;
num:=0;
For i:=1 to n Do Begin
yes:=true;
los:=0;
For j:=1 to k Do
If b[j,i].step=0 Then Begin
yes:=false;
Break;
End
Else los:=los+money[j]-b[j,i].sum;
If yes and (los<lost) Then Begin
lost:=los;
num:=i;
End;
End;
End;
Procedure WriteIt;
Begin
If num<>0 Then Write(num,' ',lost)
Else Write('0');
End;
Begin
Init;
Solve;
SearchAns;
WriteIt;
End.