LRAPST1 ;AVAMC/REG/WTY - AUTOPSY TISSUE STAIN LOOK-UP ;9/25/00
;;5.2;LAB SERVICE;**72,248**;Sep 27, 1994
;
F A=0:0 S A=$O(^LR(LRDFN,33,A)) Q:'A!(LRM[U) S LRB=^(A,0) D:$Y>(IOSL-3) M^LRAPST Q:LRM[U W !,$P(LRB,U) D A
W ! Q
A F E=0:0 S E=$O(^LR(LRDFN,33,A,E)) Q:'E!(LRM[U) S B=0 F F=1:1 S B=$O(^LR(LRDFN,33,A,E,B)) Q:'B!(LRM[U) S LRB(1)=^(B,0) D:$Y>(IOSL-3) M^LRAPST Q:LRM[U D T
Q
T W:F=1 !,LRSS(LRSS,E) W !?3,$P(LRB(1),U),?21,"Stain/Procedure" S Y=$P(LRB(1),U,2) D D^LRU W ?59,Y
F C=0:0 S C=$O(^LR(LRDFN,33,A,E,B,1,C)) Q:'C!(LRM[U) S Y=^(C,0),X=$P(Y,U,2),Z=$P(Y,U,3) D:$Y>(IOSL-3) M^LRAPST Q:LRM[U D W
Q
W W !?16,$S($D(^LAB(60,C,0)):$P(^(0),U),1:C),?47 W:X $J(X,5) W:Z ?52,"/",Z S Y=$P(Y,U,4) D:Y D^LRU W ?59,Y Q
;
AU I $P($P($G(^LR(LRDFN,"AU")),U,6)," ")'=LRABV D Q
.W $C(7),!!,"No autopsy entry for ",LRP,!! S A=1
S LRA=^LR(LRDFN,"AU"),LREP=$P(LRA,U,6)
I LREP']"" W $C(7),!!,"No autopsy # for ",LRP S A=1 Q
S Y=+LRA D D^LRU W !,"Autopsy performed: ",Y," Acc # ",LREP
W !!,"Is this the patient " S %=1 D YN^LRU S:%'=1 A=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPST1 1064 printed Nov 22, 2024@17:18:31 Page 2
LRAPST1 ;AVAMC/REG/WTY - AUTOPSY TISSUE STAIN LOOK-UP ;9/25/00
+1 ;;5.2;LAB SERVICE;**72,248**;Sep 27, 1994
+2 ;
+3 FOR A=0:0
SET A=$ORDER(^LR(LRDFN,33,A))
if 'A!(LRM[U)
QUIT
SET LRB=^(A,0)
if $Y>(IOSL-3)
DO M^LRAPST
if LRM[U
QUIT
WRITE !,$PIECE(LRB,U)
DO A
+4 WRITE !
QUIT
A FOR E=0:0
SET E=$ORDER(^LR(LRDFN,33,A,E))
if 'E!(LRM[U)
QUIT
SET B=0
FOR F=1:1
SET B=$ORDER(^LR(LRDFN,33,A,E,B))
if 'B!(LRM[U)
QUIT
SET LRB(1)=^(B,0)
if $Y>(IOSL-3)
DO M^LRAPST
if LRM[U
QUIT
DO T
+1 QUIT
T if F=1
WRITE !,LRSS(LRSS,E)
WRITE !?3,$PIECE(LRB(1),U),?21,"Stain/Procedure"
SET Y=$PIECE(LRB(1),U,2)
DO D^LRU
WRITE ?59,Y
+1 FOR C=0:0
SET C=$ORDER(^LR(LRDFN,33,A,E,B,1,C))
if 'C!(LRM[U)
QUIT
SET Y=^(C,0)
SET X=$PIECE(Y,U,2)
SET Z=$PIECE(Y,U,3)
if $Y>(IOSL-3)
DO M^LRAPST
if LRM[U
QUIT
DO W
+2 QUIT
W WRITE !?16,$SELECT($DATA(^LAB(60,C,0)):$PIECE(^(0),U),1:C),?47
if X
WRITE $JUSTIFY(X,5)
if Z
WRITE ?52,"/",Z
SET Y=$PIECE(Y,U,4)
if Y
DO D^LRU
WRITE ?59,Y
QUIT
+1 ;
AU IF $PIECE($PIECE($GET(^LR(LRDFN,"AU")),U,6)," ")'=LRABV
Begin DoDot:1
+1 WRITE $CHAR(7),!!,"No autopsy entry for ",LRP,!!
SET A=1
End DoDot:1
QUIT
+2 SET LRA=^LR(LRDFN,"AU")
SET LREP=$PIECE(LRA,U,6)
+3 IF LREP']""
WRITE $CHAR(7),!!,"No autopsy # for ",LRP
SET A=1
QUIT
+4 SET Y=+LRA
DO D^LRU
WRITE !,"Autopsy performed: ",Y," Acc # ",LREP
+5 WRITE !!,"Is this the patient "
SET %=1
DO YN^LRU
if %'=1
SET A=1
+6 QUIT
