LRAPSL1 ;AVAMC/REG - ANATOMIC PATH SLIDE LABELS ;5/9/91 12:08
;;5.2;LAB SERVICE;;Sep 27, 1994
S LRAD=$E(LRY,1,3)_"0000"
I '$D(^LRO(68,LRAA,1,LRAD,0)) W $C(7),!!,"NO ",LRAA(1)," ACCESSIONS IN FILE FOR ",LRH(0),!! Q
W 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
D REST G W
REST 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
S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRDFN=+X Q:'$D(^LR(LRDFN,0)) S X=^(0) D ^LRUP
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
S Y=+LRA D D^LRU S LRE=Y,LRM=0 D H I LRSS="AU" D AU W ! D:LR E Q
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
W ! D:LR E Q
S 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
Q
T 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
Q
A 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
E 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
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)
N 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
W $C(7),!,"Enter a number from 0 to 99." G N
Q
AU 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
Q
AUS 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
Q
AUT 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
Q
M R !,"'^' TO STOP: ",LRM:DTIME S:'$T LRM=U D:LRM'[U H Q
H W @IOF,LRP," ",SSN(1)," Acc #: ",LRAN," Date: ",LRE,!?47,"Slide/Ctrl",?60,"Labels to Print" Q
;
OUT 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPSL1 2700 printed Sep 23, 2025@19:44 Page 2
LRAPSL1 ;AVAMC/REG - ANATOMIC PATH SLIDE LABELS ;5/9/91 12:08
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
+2 SET LRAD=$EXTRACT(LRY,1,3)_"0000"
+3 IF '$DATA(^LRO(68,LRAA,1,LRAD,0))
WRITE $CHAR(7),!!,"NO ",LRAA(1)," ACCESSIONS IN FILE FOR ",LRH(0),!!
QUIT
W KILL LR
SET LR=0
READ !!,"Select Accession Number: ",LRAN:DTIME
if LRAN=""!(LRAN[U)
GOTO OUT
IF LRAN'?1N.N
WRITE $CHAR(7),!!,"Enter a number."
GOTO W
+1 DO REST
GOTO W
REST WRITE " for ",LRH(0)
IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
WRITE $CHAR(7),!!,"Accession # ",LRAN," for ",LRH(0)," not in ACCESSION file",!!
QUIT
+1 SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LRDFN=+X
if '$DATA(^LR(LRDFN,0))
QUIT
SET X=^(0)
DO ^LRUP
+2 SET LRI=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",5)
SET LRA=$SELECT(LRSS'="AU":^LR(LRDFN,LRSS,LRI,0),1:^LR(LRDFN,"AU"))
IF '$DATA(IOF)
SET IOP="HOME"
DO ^%ZIS
+3 SET Y=+LRA
DO D^LRU
SET LRE=Y
SET LRM=0
DO H
IF LRSS="AU"
DO AU
WRITE !
if LR
DO E
QUIT
+4 FOR A=0:0
SET A=$ORDER(^LR(LRDFN,LRSS,LRI,.1,A))
if 'A
QUIT
SET LRB=^(A,0)
if $Y>(IOSL-3)
DO M
if LRM[U
QUIT
WRITE !,$PIECE(LRB,U)
DO S
+5 WRITE !
if LR
DO E
QUIT
S FOR E=0:0
SET E=$ORDER(^LR(LRDFN,LRSS,LRI,.1,A,E))
if 'E!(LRM[U)
QUIT
SET B=0
FOR F=1:1
SET B=$ORDER(^LR(LRDFN,LRSS,LRI,.1,A,E,B))
if 'B!(LRM[U)
QUIT
SET LRB(1)=^(B,0)
if $Y>(IOSL-3)
DO M
if LRM[U
QUIT
if F=1
WRITE !,LRSS(LRSS,E)
WRITE !?3,$PIECE(LRB(1),U),?16,"Stain/Procedure"
DO T
+1 QUIT
T FOR C=0:0
SET C=$ORDER(^LR(LRDFN,LRSS,LRI,.1,A,E,B,1,C))
if 'C!(LRM[U)
QUIT
SET Y=^(C,0)
SET X=$PIECE(Y,U,2)
SET Z=$PIECE(Y,U,3)
if $Y>(IOSL-3)
DO M
if LRM[U
QUIT
DO A
+1 QUIT
A SET LR=LR+1
SET LR(LR)=A_U_E_U_B_U_C
WRITE !,?15,"*",$JUSTIFY(LR,2),")",?20,$EXTRACT($PIECE(^LAB(60,C,0),U),1,25),?47
if X
WRITE $JUSTIFY(X,5)
if Z
WRITE ?52,"/",Z
SET Y=$PIECE(Y,U,7)
WRITE ?66,$JUSTIFY(Y,3)
QUIT
E READ !,"Select *Stain #: ",X:DTIME
if X[U!(X="")
QUIT
IF '$DATA(LR(X))
WRITE $CHAR(7)," Select a number from 1 to ",LR
GOTO E
+1 SET X=LR(X)
SET A=$PIECE(X,U)
SET E=$PIECE(X,U,2)
SET B=$PIECE(X,U,3)
SET C=$PIECE(X,U,4)
WRITE " ",$SELECT(LRSS'="AU":$PIECE(^LR(LRDFN,LRSS,LRI,.1,A,E,B,0),U),1:$PIECE(^LR(LRDFN,33,A,E,B,0),U))," ",$PIECE(^LAB(60,C,0),U)
N WRITE !,"Number of labels: ",$SELECT(LRSS'="AU":$PIECE(^LR(LRDFN,LRSS,LRI,.1,A,E,B,1,C,0),U,7),1:$PIECE(^LR(LRDFN,33,A,E,B,1,C,0),U,7)),"// "
READ X:DTIME
if '$TEST!(X[U)
QUIT
if X=""
GOTO E
IF X=+X
IF X<100
IF X>0
SET $PIECE(^(0),U,7)=X
GOTO E
+1 WRITE $CHAR(7),!,"Enter a number from 0 to 99."
GOTO N
+2 QUIT
AU FOR A=0:0
SET A=$ORDER(^LR(LRDFN,33,A))
if 'A!(LRM[U)
QUIT
SET LRB=^(A,0)
if $Y>(IOSL-3)
DO M
if LRM[U
QUIT
WRITE !,$PIECE(LRB,U)
DO AUS
+1 QUIT
AUS FOR E=0:0
SET E=$ORDER(^LR(LRDFN,33,A,E))
if 'E!(LRM[U)
QUIT
SET B=0
FOR F=1:1
SET B=$ORDER(^LR(LRDFN,33,A,E,B))
if 'B!(LRM[U)
QUIT
SET LRB(1)=^(B,0)
if $Y>(IOSL-3)
DO M
if LRM[U
QUIT
if F=1
WRITE !,LRSS(LRSS,E)
WRITE !?3,$PIECE(LRB(1),U),?16,"Stain/Procedure"
DO AUT
+1 QUIT
AUT FOR C=0:0
SET C=$ORDER(^LR(LRDFN,33,A,E,B,1,C))
if 'C!(LRM[U)
QUIT
SET Y=^(C,0)
SET X=$PIECE(Y,U,2)
SET Z=$PIECE(Y,U,3)
if $Y>(IOSL-3)
DO M
if LRM[U
QUIT
DO A
+1 QUIT
M READ !,"'^' TO STOP: ",LRM:DTIME
if '$TEST
SET LRM=U
if LRM'[U
DO H
QUIT
H WRITE @IOF,LRP," ",SSN(1)," Acc #: ",LRAN," Date: ",LRE,!?47,"Slide/Ctrl",?60,"Labels to Print"
QUIT
+1 ;
OUT DO K^LRU
KILL LR,LRAX,LRDFN,LRDPAF,LRPARAM,LRSF,LRWHO,LRA,LRB,LRD,LRE,LRI,LRP,LRM,LRU,DOB,SEX,SSN,LRAD,LRAN,LRSS(LRSS)
QUIT
