- 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 Feb 18, 2025@23:34:14 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
