| 1 | LRAPSA ;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
|
|---|
| 6 | A 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)
|
|---|
| 8 | N1 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
|
|---|
| 9 | N2 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
|
|---|
| 11 | QUE 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
|
|---|
| 14 | W 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
|
|---|
| 19 | S 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
|
|---|
| 21 | T 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
|
|---|
| 23 | AU 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
|
|---|
| 25 | AUS 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
|
|---|
| 27 | AUT 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
|
|---|
| 29 | B W !,LRSS(LRSS,E),!?3,LRA(1),?16,"Stain/Procedure" Q
|
|---|
| 30 | C 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
|
|---|
| 31 | H 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
|
|---|
| 33 | H1 D H Q:LR("Q") W !!,LRAN,?16,LRA(6)," ",LRP," ",SSN Q
|
|---|
| 34 | H2 D H1 Q:LR("Q") W !,LRA Q
|
|---|
| 35 | H3 D H2 Q:LR("Q") W !!?3,LRA(1),?16,"Stain/Procedure" Q
|
|---|
| 36 | END D V^LRU Q
|
|---|
