source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRAPST1.m@ 1271

Last change on this file since 1271 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 1.0 KB
RevLine 
[613]1LRAPST1 ;AVAMC/REG/WTY - AUTOPSY TISSUE STAIN LOOK-UP ;9/25/00
2 ;;5.2;LAB SERVICE;**72,248**;Sep 27, 1994
3 ;
4 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
5 W ! Q
6A 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
7 Q
8T 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
9 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
10 Q
11W 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
12 ;
13AU I $P($P($G(^LR(LRDFN,"AU")),U,6)," ")'=LRABV D Q
14 .W $C(7),!!,"No autopsy entry for ",LRP,!! S A=1
15 S LRA=^LR(LRDFN,"AU"),LREP=$P(LRA,U,6)
16 I LREP']"" W $C(7),!!,"No autopsy # for ",LRP S A=1 Q
17 S Y=+LRA D D^LRU W !,"Autopsy performed: ",Y," Acc # ",LREP
18 W !!,"Is this the patient " S %=1 D YN^LRU S:%'=1 A=1
19 Q
Note: See TracBrowser for help on using the repository browser.