LRAPBS2.m

LRAPBS2 ; IHS/DIR/FJE - BLOCK/SLIDE DATA ENTRY 2/6/92 19:19 ;

 ;;5.2;LR;;NOV 01, 1997

 ;

 ;;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

LRAPBS2   ; IHS/DIR/FJE - BLOCK/SLIDE DATA ENTRY 2/6/92 19:19 ;

 +1       ;;5.2;LR;;NOV 01, 1997

 +2       ;

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

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

 +5        IF $DATA(LRF)

               DO C

               QUIT 

 +6        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

 +7        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