LRAPST1.m

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