- 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 Feb 18, 2025@23:34:19 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