- 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 Jan 18, 2025@03:08:58 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