LRAPSA ;AVAMC/REG - TISSUE STAIN LIST ;8/12/95 13:19 ;
;;5.2;LAB SERVICE;**72**;Sep 27, 1994
D ^LRAP G:'$D(Y) END
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
W !!,"Stain list date: ",LRD," OK " S %=1 D YN^LRU G:%<1 END
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
S LRY=$E(Y,1,3)
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
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
S ZTRTN="QUE^LRAPSA" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO D S^LRAPST,L^LRU,S^LRU,XR^LRU,H S LR("F")=1,N(1)=N(1)-1
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
D END^LRUTL,END Q
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
K LRAN S LRAN=$P(LRA(9),U,6),Y=+LRA(9) D D^LRU S LRA(6)=Y
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
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
Q
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
Q
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
Q
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
Q
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
Q
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
Q
B W !,LRSS(LRSS,E),!?3,LRA(1),?16,"Stain/Procedure" Q
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
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,LRO(68)," (",LRABV,")",$S(LRSS="SP":" BLOCKS",LRSS="CY":" PROCEDURES",1:""),"/STAINS",!,LR("%") Q
H1 D H Q:LR("Q") W !!,LRAN,?16,LRA(6)," ",LRP," ",SSN Q
H2 D H1 Q:LR("Q") W !,LRA Q
H3 D H2 Q:LR("Q") W !!?3,LRA(1),?16,"Stain/Procedure" Q
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPSA 2629 printed Dec 13, 2024@02:08:15 Page 2
LRAPSA ;AVAMC/REG - TISSUE STAIN LIST ;8/12/95 13:19 ;
+1 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
+2 DO ^LRAP
if '$DATA(Y)
GOTO END
+3 WRITE !!?20,LRO(68)," STAIN LIST"
SET X="T"
SET %DT=""
DO ^%DT
SET X=$EXTRACT(Y,2,3)
SET %DT=""
DO ^%DT
SET X=Y
DO D^LRU
SET LRD=Y
SET Y=X
+4 WRITE !!,"Stain list date: ",LRD," OK "
SET %=1
DO YN^LRU
if %<1
GOTO END
A IF %=2
WRITE !
SET %DT("A")="Select DATE: "
SET %DT="AQE"
DO ^%DT
KILL %DT
if Y<1
GOTO END
SET X=Y
DO D^LRU
SET LRD=Y
SET Y=X
+1 SET LRY=$EXTRACT(Y,1,3)
N1 READ !,"Start with Acc #: ",N(1):DTIME
if N(1)=""!(N(1)[U)
GOTO END
IF N(1)'?1N.N
WRITE $CHAR(7),!!,"NUMBERS ONLY !!"
GOTO N1
N2 READ !,"Go to Acc #: LAST // ",N(2):DTIME
if N(2)='$TEST!(N(2)[U)
GOTO END
if N(2)=""
SET N(2)=999999
IF N(2)'?1N.N
WRITE $CHAR(7),!!,"NUMBERS ONLY !!",!!
GOTO N2
+1 SET ZTRTN="QUE^LRAPSA"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
DO S^LRAPST
DO L^LRU
DO S^LRU
DO XR^LRU
DO H
SET LR("F")=1
SET N(1)=N(1)-1
+1 FOR LRA(8)=N(1):0
SET LRA(8)=$ORDER(^LR(LRXREF,LRY,LRABV,LRA(8)))
if 'LRA(8)!(LRA(8)>N(2))!(LR("Q"))
QUIT
SET LRDFN=$ORDER(^(LRA(8),0))
SET LRI=$ORDER(^(LRDFN,0))
DO W
+2 DO END^LRUTL
DO END
QUIT
W SET X=^LR(LRDFN,0)
SET LRA(9)=$SELECT(LRSS'="AU":^(LRSS,LRI,0),1:^("AU"))
SET LRTK=+LRA(9)
SET Y=$PIECE(X,"^",3)
SET (LRDPF,X)=$PIECE(X,"^",2)
SET X=^DIC(X,0,"GL")
SET X=@(X_Y_",0)")
SET LRP=$PIECE(X,"^")
SET SSN=$PIECE(X,"^",9)
DO SSN^LRU
+1 KILL LRAN
SET LRAN=$PIECE(LRA(9),U,6)
SET Y=+LRA(9)
DO D^LRU
SET LRA(6)=Y
+2 if $Y>(IOSL-4)
DO H
if LR("Q")
QUIT
WRITE !!,LRAN,?16,LRA(6)," ",LRP," ",SSN
SET LRW=$SELECT(LRA(6)'[1700:LRA(6),1:"")
IF LRSS="AU"
DO AU
QUIT
+3 FOR A=0:0
SET A=$ORDER(^LR(LRDFN,LRSS,LRI,.1,A))
if 'A!(LR("Q"))
QUIT
SET LRA=^(A,0)
if $Y>(IOSL-4)
DO H1
if LR("Q")
QUIT
WRITE !,$PIECE(LRA,"^")
DO S
+4 QUIT
S FOR E=0:0
SET E=$ORDER(^LR(LRDFN,LRSS,LRI,.1,A,E))
if 'E
QUIT
SET B=0
FOR F=1:1
SET B=$ORDER(^LR(LRDFN,LRSS,LRI,.1,A,E,B))
if 'B!(LR("Q"))
QUIT
SET LRA(1)=$PIECE(^(B,0),U)
if $Y>(IOSL-4)
DO H2
if LR("Q")
QUIT
DO B
DO T
+1 QUIT
T FOR C=0:0
SET C=$ORDER(^LR(LRDFN,LRSS,LRI,.1,A,E,B,1,C))
if 'C!(LR("Q"))
QUIT
SET LRX=^(C,0)
if $Y>(IOSL-4)
DO H3
if LR("Q")
QUIT
DO C
+1 QUIT
AU FOR A=0:0
SET A=$ORDER(^LR(LRDFN,33,A))
if 'A!(LR("Q"))
QUIT
SET LRA=$PIECE(^(A,0),U)
if $Y>(IOSL-4)
DO H1
if LR("Q")
QUIT
WRITE !,LRA
DO AUS
+1 QUIT
AUS FOR E=0:0
SET E=$ORDER(^LR(LRDFN,33,A,E))
if 'E
QUIT
SET B=0
FOR F=1:1
SET B=$ORDER(^LR(LRDFN,33,A,E,B))
if 'B!(LR("Q"))
QUIT
SET LRA(1)=$PIECE(^(B,0),U)
if $Y>(IOSL-4)
DO H2
if LR("Q")
QUIT
DO B
DO AUT
+1 QUIT
AUT FOR C=0:0
SET C=$ORDER(^LR(LRDFN,33,A,E,B,1,C))
if 'C!(LR("Q"))
QUIT
SET LRX=^(C,0)
if $Y>(IOSL-4)
DO H3
if LR("Q")
QUIT
DO C
+1 QUIT
B WRITE !,LRSS(LRSS,E),!?3,LRA(1),?16,"Stain/Procedure"
QUIT
C SET X=$PIECE(LRX,U,2)
SET Z=$PIECE(LRX,U,3)
WRITE !?16,$PIECE(^LAB(60,C,0),U),?47
if X
WRITE $JUSTIFY(X,5)
if Z
WRITE ?52,"/",Z
SET Y=$PIECE(LRX,U,4)
if Y
DO DT^LRU
WRITE ?59,Y
QUIT
H IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
if LR("Q")
QUIT
+1 DO F^LRU
WRITE !,LRO(68)," (",LRABV,")",$SELECT(LRSS="SP":" BLOCKS",LRSS="CY":" PROCEDURES",1:""),"/STAINS",!,LR("%")
QUIT
H1 DO H
if LR("Q")
QUIT
WRITE !!,LRAN,?16,LRA(6)," ",LRP," ",SSN
QUIT
H2 DO H1
if LR("Q")
QUIT
WRITE !,LRA
QUIT
H3 DO H2
if LR("Q")
QUIT
WRITE !!?3,LRA(1),?16,"Stain/Procedure"
QUIT
END DO V^LRU
QUIT
