- LRAPST ; IHS/DIR/AAB - TISSUE STAIN LOOK-UP 8/12/95 14:15 ;
- ;;5.2;LR;**1002**;JUN 01, 1998
- ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- D ^LRAP G:'$D(Y) END D S
- GETP W ! D ^LRDPA G:LRDFN<1 END D I G GETP
- I I LRSS="AU" S A=0 D AU^LRAPST1 Q:A G EN
- S (LRI,E)=0
- S C=0 F S LRI=$O(^LR(LRDFN,LRSS,LRI)) Q:'LRI S X=^(LRI,0) I $P($P(X,U,6)," ")=LRABV D WT:C#5=0 Q:E S C=C+1,LREP=$P(X,U,6),LREP(C)=LRI_U_LREP,Y=$P(X,U),LRST=$P(X,U,5) D:C=1 P D D^LRU,SEL
- I 'C W !,"No ",LRO(68)," specimens entered" Q
- ACC W !?11,"Choose Count #(1-",C,"): " R X:DTIME Q:X=""!(X[U)
- I X'?1N.N W $C(7),!!,"Enter numbers only",!! G ACC
- OK I '$D(LREP(X)) W " Doesn't exist for ",LRP G ACC
- GOT S LRI=+LREP(X),LRA=^LR(LRDFN,LRSS,LRI,0),LRTK=+LRA
- EN I '$D(IOF) S IOP="HOME" D ^%ZIS
- K LREP S LREP=$P(LRA,U,6),Y=+LRA D D^LRU S LRY=Y,LRW=$S(Y'[1700:Y,1:"")
- S LRM=0 D H I LRSS="AU" D ^LRAPST1 Q
- F A=0:0 S A=$O(^LR(LRDFN,LRSS,LRI,.1,A)) Q:'A!(LRM[U) S LRB=^(A,0) D:$Y>(IOSL-3) M Q:LRM[U W !,$P(LRB,U) D SP
- W ! Q
- SP I $D(LRF) S Z=$P(LRB,U,4)_":",Y=$P(LRB,U,3) S:Z=":" Z="" D:Y DD^%DT W:$L($P(LRB,U))>29 ! W ?30,Y,?50,$P($P(LR(1),Z,2),";") Q
- 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 D T
- Q
- T W:F=1 !,LRSS(LRSS,E) W !?3,$P(LRB(1),U),?21,"Stain/Procedure" S Y=$P(LRB(1),U,2) D D^LRU W:Y]"" ?59,Y
- 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=$S("SPCY"[LRSS:$P(Y,U,3),1:"") D:$Y>(IOSL-3) M Q:LRM[U D W
- Q
- W W !?16,$S($D(^LAB(60,C,0)):$P(^(0),U),1:C),?47 W:X $J(X,5) W:Z ?52,"/",Z S Y=$P(Y,U,4) D:Y D^LRU W ?59,Y Q
- P W !!,"Specimen(s)",?30,"Count #",?40,"Accession #",?55,"Date" Q
- ;
- WT I C>0 W !,"More accessions " S %=2 D YN^LRU W $C(13),$J("",30),$C(13) S E=$S(%=1:0,1:1) Q
- Q
- SEL W !?30,"(",$J(C,2),")",?40,$J(LREP,7),?55,Y
- S LRST=0 F A=1:1 S LRST=$O(^LR(LRDFN,LRSS,LRI,.1,LRST)) Q:'LRST W:$D(^(LRST,0)) !?3,$P(^(0),U) I A#5=0 W !?3,"More specimens " S %=2 D YN^LRU W:%=1 $C(13),$J("",33),$C(13) Q:%'=1
- Q
- H ;W @IOF,LRP," ",SSN(1)," Acc #: ",LREP," Date: ",LRY I $D(LRF) W !?34,"Date Gross Description/Cutting Type" Q
- W @IOF,LRP," ",HRCN," Acc #: ",LREP," Date: ",LRY I $D(LRF) W !?34,"Date Gross Description/Cutting Type" Q ;IHS/ANMC/CLS 11/1/95
- W !?46,$S("AUSPCY"[LRSS:"Slide/Ctrl",1:"Count"),?57,"Last " W $S(LRSS="EM":"section",1:"stain") W:"AUSPEM"[LRSS "/block" W " date" Q
- M R !,"'^' TO STOP: ",LRM:DTIME S:'$T LRM=U D:LRM'[U H Q
- S ;called by LRAPBS,LRAPSA,LRAPSL,LRAPWR
- D @(LRSS_1) Q
- SP1 S LRSS("SP",1)="Paraffin Block",LRSS("SP",2)="Plastic Block",LRSS("SP",3)="Frozen Tissue" Q
- CY1 S LRSS("CY",1)="Smear Prep",LRSS("CY",2)="Cell Block",LRSS("CY",3)="Membrane Filter",LRSS("CY",4)="Prepared Slides",LRSS("CY",5)="Cytospin" Q
- EM1 S LRSS("EM",1)="Epon Block" Q
- AU1 S LRSS("AU",1)="Paraffin Block" Q
- ;
- END D V^LRU Q
- LRAPST ; IHS/DIR/AAB - TISSUE STAIN LOOK-UP 8/12/95 14:15 ;
- +1 ;;5.2;LR;**1002**;JUN 01, 1998
- +2 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- +3 DO ^LRAP
- IF '$DATA(Y)
- GOTO END
- DO S
- GETP WRITE !
- DO ^LRDPA
- IF LRDFN<1
- GOTO END
- DO I
- GOTO GETP
- I IF LRSS="AU"
- SET A=0
- DO AU^LRAPST1
- IF A
- QUIT
- GOTO EN
- +1 SET (LRI,E)=0
- +2 SET C=0
- FOR
- SET LRI=$ORDER(^LR(LRDFN,LRSS,LRI))
- IF 'LRI
- QUIT
- SET X=^(LRI,0)
- IF $PIECE($PIECE(X,U,6)," ")=LRABV
- IF C#5=0
- DO WT
- IF E
- QUIT
- SET C=C+1
- SET LREP=$PIECE(X,U,6)
- SET LREP(C)=LRI_U_LREP
- SET Y=$PIECE(X,U)
- SET LRST=$PIECE(X,U,5)
- IF C=1
- DO P
- DO D^LRU
- DO SEL
- +3 IF 'C
- WRITE !,"No ",LRO(68)," specimens entered"
- QUIT
- ACC WRITE !?11,"Choose Count #(1-",C,"): "
- READ X:DTIME
- IF X=""!(X[U)
- QUIT
- +1 IF X'?1N.N
- WRITE $CHAR(7),!!,"Enter numbers only",!!
- GOTO ACC
- OK IF '$DATA(LREP(X))
- WRITE " Doesn't exist for ",LRP
- GOTO ACC
- GOT SET LRI=+LREP(X)
- SET LRA=^LR(LRDFN,LRSS,LRI,0)
- SET LRTK=+LRA
- EN IF '$DATA(IOF)
- SET IOP="HOME"
- DO ^%ZIS
- +1 KILL LREP
- SET LREP=$PIECE(LRA,U,6)
- SET Y=+LRA
- DO D^LRU
- SET LRY=Y
- SET LRW=$SELECT(Y'[1700:Y,1:"")
- +2 SET LRM=0
- DO H
- IF LRSS="AU"
- DO ^LRAPST1
- QUIT
- +3 FOR A=0:0
- SET A=$ORDER(^LR(LRDFN,LRSS,LRI,.1,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 SP
- +4 WRITE !
- QUIT
- SP IF $DATA(LRF)
- SET Z=$PIECE(LRB,U,4)_":"
- SET Y=$PIECE(LRB,U,3)
- IF Z="
- SET Z=""
- IF Y
- DO DD^%DT
- IF $LENGTH($PIECE(LRB,U))>29
- WRITE !
- WRITE ?30,Y,?50,$PIECE($PIECE(LR(1),Z,2),";")
- QUIT
- +1 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
- DO T
- +2 QUIT
- T IF F=1
- WRITE !,LRSS(LRSS,E)
- WRITE !?3,$PIECE(LRB(1),U),?21,"Stain/Procedure"
- SET Y=$PIECE(LRB(1),U,2)
- DO D^LRU
- IF Y]""
- WRITE ?59,Y
- +1 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=$SELECT("SPCY"[LRSS:$PIECE(Y,U,3),1:"")
- IF $Y>(IOSL-3)
- DO M
- IF LRM[U
- QUIT
- DO W
- +2 QUIT
- W WRITE !?16,$SELECT($DATA(^LAB(60,C,0)):$PIECE(^(0),U),1:C),?47
- IF X
- WRITE $JUSTIFY(X,5)
- IF Z
- WRITE ?52,"/",Z
- SET Y=$PIECE(Y,U,4)
- IF Y
- DO D^LRU
- WRITE ?59,Y
- QUIT
- P WRITE !!,"Specimen(s)",?30,"Count #",?40,"Accession #",?55,"Date"
- QUIT
- +1 ;
- WT IF C>0
- WRITE !,"More accessions "
- SET %=2
- DO YN^LRU
- WRITE $CHAR(13),$JUSTIFY("",30),$CHAR(13)
- SET E=$SELECT(%=1:0,1:1)
- QUIT
- +1 QUIT
- SEL WRITE !?30,"(",$JUSTIFY(C,2),")",?40,$JUSTIFY(LREP,7),?55,Y
- +1 SET LRST=0
- FOR A=1:1
- SET LRST=$ORDER(^LR(LRDFN,LRSS,LRI,.1,LRST))
- IF 'LRST
- QUIT
- IF $DATA(^(LRST,0))
- WRITE !?3,$PIECE(^(0),U)
- IF A#5=0
- WRITE !?3,"More specimens "
- SET %=2
- DO YN^LRU
- IF %=1
- WRITE $CHAR(13),$JUSTIFY("",33),$CHAR(13)
- IF %'=1
- QUIT
- +2 QUIT
- H ;W @IOF,LRP," ",SSN(1)," Acc #: ",LREP," Date: ",LRY I $D(LRF) W !?34,"Date Gross Description/Cutting Type" Q
- +1 ;IHS/ANMC/CLS 11/1/95
- WRITE @IOF,LRP," ",HRCN," Acc #: ",LREP," Date: ",LRY
- IF $DATA(LRF)
- WRITE !?34,"Date Gross Description/Cutting Type"
- QUIT
- +2 WRITE !?46,$SELECT("AUSPCY"[LRSS:"Slide/Ctrl",1:"Count"),?57,"Last "
- WRITE $SELECT(LRSS="EM":"section",1:"stain")
- IF "AUSPEM"[LRSS
- WRITE "/block"
- WRITE " date"
- QUIT
- M READ !,"'^' TO STOP: ",LRM:DTIME
- IF '$TEST
- SET LRM=U
- IF LRM'[U
- DO H
- QUIT
- S ;called by LRAPBS,LRAPSA,LRAPSL,LRAPWR
- +1 DO @(LRSS_1)
- QUIT
- SP1 SET LRSS("SP",1)="Paraffin Block"
- SET LRSS("SP",2)="Plastic Block"
- SET LRSS("SP",3)="Frozen Tissue"
- QUIT
- CY1 SET LRSS("CY",1)="Smear Prep"
- SET LRSS("CY",2)="Cell Block"
- SET LRSS("CY",3)="Membrane Filter"
- SET LRSS("CY",4)="Prepared Slides"
- SET LRSS("CY",5)="Cytospin"
- QUIT
- EM1 SET LRSS("EM",1)="Epon Block"
- QUIT
- AU1 SET LRSS("AU",1)="Paraffin Block"
- QUIT
- +1 ;
- END DO V^LRU
- QUIT
