LRAPBS2.m

LRAPBS2 ;AVAMC/REG - BLOCK/SLIDE DATA ENTRY ;2/6/92  19:19 ;

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

 ;put date stained/block prepared/gross cutting in lab data file

 I $D(LRF) D C Q

 F A=0:0 S A=$O(^LR(LRDFN,LRSS,LRI,.1,A)) Q:'A  F B=0:0 S B=$O(^LR(LRDFN,LRSS,LRI,.1,A,B)) Q:'B  F C=0:0 S C=$O(^LR(LRDFN,LRSS,LRI,.1,A,B,C)) Q:'C  D:$D(LRK(1)) BLK D X

 Q

X F E=0:0 S E=$O(^LR(LRDFN,LRSS,LRI,.1,A,B,C,1,E)) Q:'E  S:'$P(^(E,0),"^",4) $P(^(0),"^",4)=LRK

 Q

BLK S:'$P(^LR(LRDFN,LRSS,LRI,.1,A,B,C,0),"^",2) $P(^(0),"^",2)=LRK(1) Q

 ;

C F A=0:0 S A=$O(^LR(LRDFN,LRSS,LRI,.1,A)) Q:'A  S:'$P(^(A,0),"^",3) $P(^(0),"^",3)=LRK

 Q

EN ;

 G:LRSS'="AU" LRAPBS2

 ;put date autopsy blocks/stains prepared in lab data file

 F A=0:0 S A=$O(^LR(LRDFN,33,A)) Q:'A  F B=0:0 S B=$O(^LR(LRDFN,33,A,B)) Q:'B  F C=0:0 S C=$O(^LR(LRDFN,33,A,B,C)) Q:'C  D:$D(LRK(1)) AUBLK D AUX

 Q

AUX F E=0:0 S E=$O(^LR(LRDFN,33,A,B,C,1,E)) Q:'E  S:'$P(^(E,0),"^",4) $P(^(0),"^",4)=LRK

 Q

AUBLK S:'$P(^LR(LRDFN,33,A,B,C,0),"^",2) $P(^(0),"^",2)=LRK(1) Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LRAPBS2   1025     printed  Apr 09, 2024@21:10:22                                                                                                                                                                                                     Page 2

LRAPBS2   ;AVAMC/REG - BLOCK/SLIDE DATA ENTRY ;2/6/92  19:19 ;

 +1       ;;5.2;LAB SERVICE;;Sep 27, 1994

 +2       ;put date stained/block prepared/gross cutting in lab data file

 +3        IF $DATA(LRF)

               DO C

               QUIT 

 +4        FOR A=0:0

               SET A=$ORDER(^LR(LRDFN,LRSS,LRI,.1,A))

               if 'A

                   QUIT 

               FOR B=0:0

                   SET B=$ORDER(^LR(LRDFN,LRSS,LRI,.1,A,B))

                   if 'B

                       QUIT 

                   FOR C=0:0

                       SET C=$ORDER(^LR(LRDFN,LRSS,LRI,.1,A,B,C))

                       if 'C

                           QUIT 

                       if $DATA(LRK(1))

                           DO BLK

                       DO X

 +5        QUIT 

X          FOR E=0:0

               SET E=$ORDER(^LR(LRDFN,LRSS,LRI,.1,A,B,C,1,E))

               if 'E

                   QUIT 

               if '$PIECE(^(E,0),"^",4)

                   SET $PIECE(^(0),"^",4)=LRK

 +1        QUIT 

BLK        if '$PIECE(^LR(LRDFN,LRSS,LRI,.1,A,B,C,0),"^",2)

               SET $PIECE(^(0),"^",2)=LRK(1)

           QUIT 

 +1       ;

C          FOR A=0:0

               SET A=$ORDER(^LR(LRDFN,LRSS,LRI,.1,A))

               if 'A

                   QUIT 

               if '$PIECE(^(A,0),"^",3)

                   SET $PIECE(^(0),"^",3)=LRK

 +1        QUIT 

EN        ;

 +1        if LRSS'="AU"

               GOTO LRAPBS2

 +2       ;put date autopsy blocks/stains prepared in lab data file

 +3        FOR A=0:0

               SET A=$ORDER(^LR(LRDFN,33,A))

               if 'A

                   QUIT 

               FOR B=0:0

                   SET B=$ORDER(^LR(LRDFN,33,A,B))

                   if 'B

                       QUIT 

                   FOR C=0:0

                       SET C=$ORDER(^LR(LRDFN,33,A,B,C))

                       if 'C

                           QUIT 

                       if $DATA(LRK(1))

                           DO AUBLK

                       DO AUX

 +4        QUIT 

AUX        FOR E=0:0

               SET E=$ORDER(^LR(LRDFN,33,A,B,C,1,E))

               if 'E

                   QUIT 

               if '$PIECE(^(E,0),"^",4)

                   SET $PIECE(^(0),"^",4)=LRK

 +1        QUIT 

AUBLK      if '$PIECE(^LR(LRDFN,33,A,B,C,0),"^",2)

               SET $PIECE(^(0),"^",2)=LRK(1)

           QUIT