- 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
