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 ---[H[J[2J[HLRAPBS2 1025 printed Dec 13, 2024@02:07:07 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
