LRUQ.m

LRUQ ;AVAMC/REG - CHECK FOR BAD POINTERS TO LAB FILE ;2/18/93  13:13

 ;;5.2T9;LR;**1018**;Nov 17, 2004

 ;;5.2;LAB SERVICE;**242**;Sep 27, 1994

 D END W !!,"Check parent file for bad pointers to lab file."

 S X="?" D FILE^LRDPA G:Y<1 END S LRF=+Y,LRN=$P(Y,U,2),LR=^DIC(LRF,0,"GL")

 D BEG^LRUTL G:POP!($D(ZTSK)) END

QUE U IO D L^LRU,S^LRU,H S LR("F")=1

 F DFN=0:0 S DFN=$O(@(LR_DFN_")")) Q:'DFN!(LR("Q"))  D

 .S LRDFN=$$LRDFN^LR7OR1(DFN) Q:LRDFN=""  D LR

 D END^LRUTL,END Q

LR S X=$S($D(^LR(LRDFN,0)):^(0),1:"") I X="" D:$Y>(IOSL-6) H Q:LR("Q")  W !,DFN,?15,LRDFN," no entry in lab data file" Q

 S LR(2)=$P(X,"^",2),LR(3)=$P(X,"^",3) I DFN'=LR(3)!(LR(2)'=LRF) D:$Y>(IOSL-6) H Q:LR("Q")  W !,DFN,?15,LRDFN,?30,LR(3),?45,LR(2)

 Q

 ;

H I $D(LR("F")),IOST?1"C".E D M^LRU Q

 D F^LRU W !,"Bad lab pointers from ",LRN," file (global ",LR," )"

 W !,"Parent DFN",?15,"Parent LRDFN",?30,"Lab DFN",?45,"Lab pointer to parent file",!,LR("%") Q

 ;

END D V^LRU Q

LRUQ      ;AVAMC/REG - CHECK FOR BAD POINTERS TO LAB FILE ;2/18/93  13:13

 +1       ;;5.2T9;LR;**1018**;Nov 17, 2004

 +2       ;;5.2;LAB SERVICE;**242**;Sep 27, 1994

 +3        DO END

           WRITE !!,"Check parent file for bad pointers to lab file."

 +4        SET X="?"

           DO FILE^LRDPA

           IF Y<1

               GOTO END

           SET LRF=+Y

           SET LRN=$PIECE(Y,U,2)

           SET LR=^DIC(LRF,0,"GL")

 +5        DO BEG^LRUTL

           IF POP!($DATA(ZTSK))

               GOTO END

QUE        USE IO

           DO L^LRU

           DO S^LRU

           DO H

           SET LR("F")=1

 +1        FOR DFN=0:0

               SET DFN=$ORDER(@(LR_DFN_")"))

               IF 'DFN!(LR("Q"))

                   QUIT 

               Begin DoDot:1

 +2                SET LRDFN=$$LRDFN^LR7OR1(DFN)

                   IF LRDFN=""

                       QUIT 

                   DO LR

               End DoDot:1

 +3        DO END^LRUTL

           DO END

           QUIT 

LR         SET X=$SELECT($DATA(^LR(LRDFN,0)):^(0),1:"")

           IF X=""

               IF $Y>(IOSL-6)

                   DO H

               IF LR("Q")

                   QUIT 

               WRITE !,DFN,?15,LRDFN," no entry in lab data file"

               QUIT 

 +1        SET LR(2)=$PIECE(X,"^",2)

           SET LR(3)=$PIECE(X,"^",3)

           IF DFN'=LR(3)!(LR(2)'=LRF)

               IF $Y>(IOSL-6)

                   DO H

               IF LR("Q")

                   QUIT 

               WRITE !,DFN,?15,LRDFN,?30,LR(3),?45,LR(2)

 +2        QUIT 

 +3       ;

H          IF $DATA(LR("F"))

               IF IOST?1"C".E

                   DO M^LRU

                   QUIT 

 +1        DO F^LRU

           WRITE !,"Bad lab pointers from ",LRN," file (global ",LR," )"

 +2        WRITE !,"Parent DFN",?15,"Parent LRDFN",?30,"Lab DFN",?45,"Lab pointer to parent file",!,LR("%")

           QUIT 

 +3       ;

END        DO V^LRU

           QUIT