LRCKF62 ;SLC/RWF - CHECK FILE'S ACC TEST FILE ; 2/22/87 1:46 PM ;
;;5.2;LAB SERVICE;**272,293**;Sep 27, 1994
S ZTRTN="ENT^LRCKF62" D LOG^LRCKF Q:LREND D ENT W !! W:$E(IOST,1,2)="P-" @IOF D ^%ZISC Q
ENT ;from LRCKF
U IO W !," Checking the Accession test group file." S U="^",LRPA=0
F LRA=0:0 S LRA=$O(^LAB(62.6,LRA)) Q:LRA'>0 S Z0=^LAB(62.6,LRA,0),LRB=0 D ATF
END K LRB,LRPA,LRPB W !! W:$E(IOST,1,2)="P-" @IOF Q
Q
ATF S LRB=$O(^LAB(62.6,LRA,1,LRB)) Q:LRB'>0!('$D(^(+LRB,0))#2) S Z1=^(0)
S Z2=$S($D(^LAB(60,+Z1,0)):^(0),1:"") I Z2="" D NAME1 W !?5,"F- Pointer ",+Z1," doesn't point to a test in file 60."
I '$P(Z2,U,9),$P(Z0,U,4) D NAME1 W !,?5,"F- Test doesn't have a LAB COLLECTION SAMPLE."
G ATF
NAME1 I LRPA'=LRA W !!,$P(Z0,U) S LRPA=LRA,LRPB=0
I LRPB'=LRB W !?2,$P(Z2,U) S LRPB=LRB
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCKF62 817 printed Oct 16, 2024@18:14:26 Page 2
LRCKF62 ;SLC/RWF - CHECK FILE'S ACC TEST FILE ; 2/22/87 1:46 PM ;
+1 ;;5.2;LAB SERVICE;**272,293**;Sep 27, 1994
+2 SET ZTRTN="ENT^LRCKF62"
DO LOG^LRCKF
if LREND
QUIT
DO ENT
WRITE !!
if $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
DO ^%ZISC
QUIT
ENT ;from LRCKF
+1 USE IO
WRITE !," Checking the Accession test group file."
SET U="^"
SET LRPA=0
+2 FOR LRA=0:0
SET LRA=$ORDER(^LAB(62.6,LRA))
if LRA'>0
QUIT
SET Z0=^LAB(62.6,LRA,0)
SET LRB=0
DO ATF
END KILL LRB,LRPA,LRPB
WRITE !!
if $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
QUIT
+1 QUIT
ATF SET LRB=$ORDER(^LAB(62.6,LRA,1,LRB))
if LRB'>0!('$DATA(^(+LRB,0))#2)
QUIT
SET Z1=^(0)
+1 SET Z2=$SELECT($DATA(^LAB(60,+Z1,0)):^(0),1:"")
IF Z2=""
DO NAME1
WRITE !?5,"F- Pointer ",+Z1," doesn't point to a test in file 60."
+2 IF '$PIECE(Z2,U,9)
IF $PIECE(Z0,U,4)
DO NAME1
WRITE !,?5,"F- Test doesn't have a LAB COLLECTION SAMPLE."
+3 GOTO ATF
NAME1 IF LRPA'=LRA
WRITE !!,$PIECE(Z0,U)
SET LRPA=LRA
SET LRPB=0
+1 IF LRPB'=LRB
WRITE !?2,$PIECE(Z2,U)
SET LRPB=LRB
+2 QUIT
