source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRAPBS2.m@ 846

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

initial load of WorldVistAEHR

File size: 1005 bytes
Line 
1LRAPBS2 ;AVAMC/REG - BLOCK/SLIDE DATA ENTRY ;2/6/92 19:19 ;
2 ;;5.2;LAB SERVICE;;Sep 27, 1994
3 ;put date stained/block prepared/gross cutting in lab data file
4 I $D(LRF) D C Q
5 F A=0:0 S A=$O(^LR(LRDFN,LRSS,LRI,.1,A)) Q:'A F B=0:0 S B=$O(^LR(LRDFN,LRSS,LRI,.1,A,B)) Q:'B F C=0:0 S C=$O(^LR(LRDFN,LRSS,LRI,.1,A,B,C)) Q:'C D:$D(LRK(1)) BLK D X
6 Q
7X F E=0:0 S E=$O(^LR(LRDFN,LRSS,LRI,.1,A,B,C,1,E)) Q:'E S:'$P(^(E,0),"^",4) $P(^(0),"^",4)=LRK
8 Q
9BLK S:'$P(^LR(LRDFN,LRSS,LRI,.1,A,B,C,0),"^",2) $P(^(0),"^",2)=LRK(1) Q
10 ;
11C F A=0:0 S A=$O(^LR(LRDFN,LRSS,LRI,.1,A)) Q:'A S:'$P(^(A,0),"^",3) $P(^(0),"^",3)=LRK
12 Q
13EN ;
14 G:LRSS'="AU" LRAPBS2
15 ;put date autopsy blocks/stains prepared in lab data file
16 F A=0:0 S A=$O(^LR(LRDFN,33,A)) Q:'A F B=0:0 S B=$O(^LR(LRDFN,33,A,B)) Q:'B F C=0:0 S C=$O(^LR(LRDFN,33,A,B,C)) Q:'C D:$D(LRK(1)) AUBLK D AUX
17 Q
18AUX F E=0:0 S E=$O(^LR(LRDFN,33,A,B,C,1,E)) Q:'E S:'$P(^(E,0),"^",4) $P(^(0),"^",4)=LRK
19 Q
20AUBLK S:'$P(^LR(LRDFN,33,A,B,C,0),"^",2) $P(^(0),"^",2)=LRK(1) Q
Note: See TracBrowser for help on using the repository browser.