source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRAPSA.m@ 724

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

initial load of WorldVistAEHR

File size: 2.5 KB
Line 
1LRAPSA ;AVAMC/REG - TISSUE STAIN LIST ;8/12/95 13:19 ;
2 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
3 D ^LRAP G:'$D(Y) END
4 W !!?20,LRO(68)," STAIN LIST" S X="T",%DT="" D ^%DT S X=$E(Y,2,3),%DT="" D ^%DT S X=Y D D^LRU S LRD=Y,Y=X
5 W !!,"Stain list date: ",LRD," OK " S %=1 D YN^LRU G:%<1 END
6A I %=2 W ! S %DT("A")="Select DATE: ",%DT="AQE" D ^%DT K %DT G:Y<1 END S X=Y D D^LRU S LRD=Y,Y=X
7 S LRY=$E(Y,1,3)
8N1 R !,"Start with Acc #: ",N(1):DTIME G:N(1)=""!(N(1)[U) END I N(1)'?1N.N W $C(7),!!,"NUMBERS ONLY !!" G N1
9N2 R !,"Go to Acc #: LAST // ",N(2):DTIME G:N(2)='$T!(N(2)[U) END S:N(2)="" N(2)=999999 I N(2)'?1N.N W $C(7),!!,"NUMBERS ONLY !!",!! G N2
10 S ZTRTN="QUE^LRAPSA" D BEG^LRUTL G:POP!($D(ZTSK)) END
11QUE U IO D S^LRAPST,L^LRU,S^LRU,XR^LRU,H S LR("F")=1,N(1)=N(1)-1
12 F LRA(8)=N(1):0 S LRA(8)=$O(^LR(LRXREF,LRY,LRABV,LRA(8))) Q:'LRA(8)!(LRA(8)>N(2))!(LR("Q")) S LRDFN=$O(^(LRA(8),0)),LRI=$O(^(LRDFN,0)) D W
13 D END^LRUTL,END Q
14W S X=^LR(LRDFN,0),LRA(9)=$S(LRSS'="AU":^(LRSS,LRI,0),1:^("AU")),LRTK=+LRA(9),Y=$P(X,"^",3),(LRDPF,X)=$P(X,"^",2),X=^DIC(X,0,"GL"),X=@(X_Y_",0)"),LRP=$P(X,"^"),SSN=$P(X,"^",9) D SSN^LRU
15 K LRAN S LRAN=$P(LRA(9),U,6),Y=+LRA(9) D D^LRU S LRA(6)=Y
16 D:$Y>(IOSL-4) H Q:LR("Q") W !!,LRAN,?16,LRA(6)," ",LRP," ",SSN S LRW=$S(LRA(6)'[1700:LRA(6),1:"") I LRSS="AU" D AU Q
17 F A=0:0 S A=$O(^LR(LRDFN,LRSS,LRI,.1,A)) Q:'A!(LR("Q")) S LRA=^(A,0) D:$Y>(IOSL-4) H1 Q:LR("Q") W !,$P(LRA,"^") D S
18 Q
19S F E=0:0 S E=$O(^LR(LRDFN,LRSS,LRI,.1,A,E)) Q:'E S B=0 F F=1:1 S B=$O(^LR(LRDFN,LRSS,LRI,.1,A,E,B)) Q:'B!(LR("Q")) S LRA(1)=$P(^(B,0),U) D:$Y>(IOSL-4) H2 Q:LR("Q") D B,T
20 Q
21T F C=0:0 S C=$O(^LR(LRDFN,LRSS,LRI,.1,A,E,B,1,C)) Q:'C!(LR("Q")) S LRX=^(C,0) D:$Y>(IOSL-4) H3 Q:LR("Q") D C
22 Q
23AU F A=0:0 S A=$O(^LR(LRDFN,33,A)) Q:'A!(LR("Q")) S LRA=$P(^(A,0),U) D:$Y>(IOSL-4) H1 Q:LR("Q") W !,LRA D AUS
24 Q
25AUS F E=0:0 S E=$O(^LR(LRDFN,33,A,E)) Q:'E S B=0 F F=1:1 S B=$O(^LR(LRDFN,33,A,E,B)) Q:'B!(LR("Q")) S LRA(1)=$P(^(B,0),U) D:$Y>(IOSL-4) H2 Q:LR("Q") D B,AUT
26 Q
27AUT F C=0:0 S C=$O(^LR(LRDFN,33,A,E,B,1,C)) Q:'C!(LR("Q")) S LRX=^(C,0) D:$Y>(IOSL-4) H3 Q:LR("Q") D C
28 Q
29B W !,LRSS(LRSS,E),!?3,LRA(1),?16,"Stain/Procedure" Q
30C S X=$P(LRX,U,2),Z=$P(LRX,U,3) W !?16,$P(^LAB(60,C,0),U),?47 W:X $J(X,5) W:Z ?52,"/",Z S Y=$P(LRX,U,4) D:Y DT^LRU W ?59,Y Q
31H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
32 D F^LRU W !,LRO(68)," (",LRABV,")",$S(LRSS="SP":" BLOCKS",LRSS="CY":" PROCEDURES",1:""),"/STAINS",!,LR("%") Q
33H1 D H Q:LR("Q") W !!,LRAN,?16,LRA(6)," ",LRP," ",SSN Q
34H2 D H1 Q:LR("Q") W !,LRA Q
35H3 D H2 Q:LR("Q") W !!?3,LRA(1),?16,"Stain/Procedure" Q
36END D V^LRU Q
Note: See TracBrowser for help on using the repository browser.