- LRAPST1 ;AVAMC/REG/WTY - AUTOPSY TISSUE STAIN LOOK-UP ;9/25/00
- ;;5.2T9;LR;**72,248,1018**;Nov 17, 2004
- ;
- 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
- LRAPST1 ;AVAMC/REG/WTY - AUTOPSY TISSUE STAIN LOOK-UP ;9/25/00
- +1 ;;5.2T9;LR;**72,248,1018**;Nov 17, 2004
- +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
