source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRAPSL1.m@ 1800

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

initial load of WorldVistAEHR

File size: 2.6 KB
Line 
1LRAPSL1 ;AVAMC/REG - ANATOMIC PATH SLIDE LABELS ;5/9/91 12:08
2 ;;5.2;LAB SERVICE;;Sep 27, 1994
3 S LRAD=$E(LRY,1,3)_"0000"
4 I '$D(^LRO(68,LRAA,1,LRAD,0)) W $C(7),!!,"NO ",LRAA(1)," ACCESSIONS IN FILE FOR ",LRH(0),!! Q
5W K LR S LR=0 R !!,"Select Accession Number: ",LRAN:DTIME G:LRAN=""!(LRAN[U) OUT I LRAN'?1N.N W $C(7),!!,"Enter a number." G W
6 D REST G W
7REST W " for ",LRH(0) I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W $C(7),!!,"Accession # ",LRAN," for ",LRH(0)," not in ACCESSION file",!! Q
8 S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRDFN=+X Q:'$D(^LR(LRDFN,0)) S X=^(0) D ^LRUP
9 S LRI=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",5),LRA=$S(LRSS'="AU":^LR(LRDFN,LRSS,LRI,0),1:^LR(LRDFN,"AU")) I '$D(IOF) S IOP="HOME" D ^%ZIS
10 S Y=+LRA D D^LRU S LRE=Y,LRM=0 D H I LRSS="AU" D AU W ! D:LR E Q
11 F A=0:0 S A=$O(^LR(LRDFN,LRSS,LRI,.1,A)) Q:'A S LRB=^(A,0) D:$Y>(IOSL-3) M Q:LRM[U W !,$P(LRB,U) D S
12 W ! D:LR E Q
13S F E=0:0 S E=$O(^LR(LRDFN,LRSS,LRI,.1,A,E)) Q:'E!(LRM[U) S B=0 F F=1:1 S B=$O(^LR(LRDFN,LRSS,LRI,.1,A,E,B)) Q:'B!(LRM[U) S LRB(1)=^(B,0) D:$Y>(IOSL-3) M Q:LRM[U W:F=1 !,LRSS(LRSS,E) W !?3,$P(LRB(1),U),?16,"Stain/Procedure" D T
14 Q
15T F C=0:0 S C=$O(^LR(LRDFN,LRSS,LRI,.1,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 Q:LRM[U D A
16 Q
17A S LR=LR+1,LR(LR)=A_U_E_U_B_U_C W !,?15,"*",$J(LR,2),")",?20,$E($P(^LAB(60,C,0),U),1,25),?47 W:X $J(X,5) W:Z ?52,"/",Z S Y=$P(Y,U,7) W ?66,$J(Y,3) Q
18E R !,"Select *Stain #: ",X:DTIME Q:X[U!(X="") I '$D(LR(X)) W $C(7)," Select a number from 1 to ",LR G E
19 S X=LR(X),A=$P(X,U),E=$P(X,U,2),B=$P(X,U,3),C=$P(X,U,4) W " ",$S(LRSS'="AU":$P(^LR(LRDFN,LRSS,LRI,.1,A,E,B,0),U),1:$P(^LR(LRDFN,33,A,E,B,0),U))," ",$P(^LAB(60,C,0),U)
20N W !,"Number of labels: ",$S(LRSS'="AU":$P(^LR(LRDFN,LRSS,LRI,.1,A,E,B,1,C,0),U,7),1:$P(^LR(LRDFN,33,A,E,B,1,C,0),U,7)),"// " R X:DTIME Q:'$T!(X[U) G:X="" E I X=+X,X<100,X>0 S $P(^(0),U,7)=X G E
21 W $C(7),!,"Enter a number from 0 to 99." G N
22 Q
23AU F A=0:0 S A=$O(^LR(LRDFN,33,A)) Q:'A!(LRM[U) S LRB=^(A,0) D:$Y>(IOSL-3) M Q:LRM[U W !,$P(LRB,U) D AUS
24 Q
25AUS 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 Q:LRM[U W:F=1 !,LRSS(LRSS,E) W !?3,$P(LRB(1),U),?16,"Stain/Procedure" D AUT
26 Q
27AUT 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 Q:LRM[U D A
28 Q
29M R !,"'^' TO STOP: ",LRM:DTIME S:'$T LRM=U D:LRM'[U H Q
30H W @IOF,LRP," ",SSN(1)," Acc #: ",LRAN," Date: ",LRE,!?47,"Slide/Ctrl",?60,"Labels to Print" Q
31 ;
32OUT D K^LRU K LR,LRAX,LRDFN,LRDPAF,LRPARAM,LRSF,LRWHO,LRA,LRB,LRD,LRE,LRI,LRP,LRM,LRU,DOB,SEX,SSN,LRAD,LRAN,LRSS(LRSS) Q
Note: See TracBrowser for help on using the repository browser.