LRAPAULC ; IHS/DIR/AAB - ACCESSION COUNTS BY PATHOLOGIST 08:12 ; [ 8/14/95 ]
;;5.2;LR;**1002**;JUN 01, 1998
;;5.2;LAB SERVICE;**72**;Sep 27, 1994
D END,B^LRU G:Y<0 END S LRLDT=LRLDT+.99,LRSDT=LRSDT-.0001
S ZTRTN="QUE^LRAPAULC" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO D L^LRU,S^LRU,H S LR("F")=1 F LRO="ASP","ACY","AAU","AEM" Q:LR("Q") S LRSS=$E(LRO,2,3) D L
D C,END,END^LRUTL Q
L F LRC=LRSDT:0 S LRC=$O(^LR(LRO,LRC)) Q:'LRC!(LRC>LRLDT)!(LR("Q")) F LRP=0:0 S LRP=$O(^LR(LRO,LRC,LRP)) Q:'LRP!(LR("Q")) D @$S(LRSS="AU":"W",1:"SP")
Q
W I '$D(^LR(LRP,"AU")) K ^LR("AAU",LRC,LRP) Q
S X=$P(^LR(LRP,"AU"),"^",10) I 'X S X=^("AU") D U Q
S:'$D(LR(LRSS,X)) LR(LRSS,X)=0 S LR(LRSS,X)=LR(LRSS,X)+1 Q
;
SP F LRI=0:0 S LRI=$O(^LR(LRO,LRC,LRP,LRI)) Q:'LRI!(LR("Q")) D WR
Q
WR I '$D(^LR(LRP,LRSS,LRI,0)) K ^LR(LRO,LRC,LRP,LRI) Q
S X=$P(^LR(LRP,LRSS,LRI,0),"^",2) I 'X S X=^(0) D U Q
S:'$D(LR(LRSS,X)) LR(LRSS,X)=0 S LR(LRSS,X)=LR(LRSS,X)+1 Q
C F LRSS="SP","CY","EM","AU" Q:LR("Q") S LRI=0 D D
Q
D D:$Y>(IOSL-6) H Q:LR("Q") W !!?30 D T
F LRP=0:0 S LRP=$O(LR(LRSS,LRP)) Q:'LRP D:$Y>(IOSL-6) H1 Q:(LR("Q")) W !,$S($D(^VA(200,LRP,0)):$P(^(0),U),1:LRP)," :",?32,$J(LR(LRSS,LRP),5) S LRI=LRI+LR(LRSS,LRP)
Q:LR("Q") I $D(LR(LRSS,0)) D:$Y>(IOSL-6) H Q:LR("Q") W !,"Unassigned accessions :",?32,$J(LR(LRSS,0),5)
W !?32,"-----",!?26,"Total",?32,$J(LRI,5) Q:'$D(LR(LRSS,0))
F LRP=0:0 S LRP=$O(LR(LRSS,0,LRP)) Q:'LRP!(LR("Q")) S Y=LRP D D^LRU S LRD=Y F LRC=0:0 S LRC=$O(LR(LRSS,0,LRP,LRC)) Q:'LRC!(LR("Q")) D:$Y>(IOSL-6) H Q:LR("Q") W !?3,LRD,?30,"Accession #: ",LRC
Q
U S:'$D(LR(LRSS,0)) LR(LRSS,0)=0 S LR(LRSS,0)=LR(LRSS,0)+1,LR(LRSS,0,+X,$P(X,"^",6))="" Q
;
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,"Accession counts by Senior Pathologist",!,"From: ",LRSTR," to:",LRLST,!,LR("%") Q
H1 D H Q:LR("Q") W !?30 D T Q
T W $S(LRSS="SP":"SURGICAL PATHOLOGY",LRSS="CY":"CYTOPATHOLOGY",LRSS="EM":"ELECTRON MICROSCOPY",1:"AUTOPSY PATHOLOGY")," ACCESSION AREAS" Q
;
END D V^LRU Q
LRAPAULC ; IHS/DIR/AAB - ACCESSION COUNTS BY PATHOLOGIST 08:12 ; [ 8/14/95 ]
+1 ;;5.2;LR;**1002**;JUN 01, 1998
+2 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
+3 DO END
DO B^LRU
IF Y<0
GOTO END
SET LRLDT=LRLDT+.99
SET LRSDT=LRSDT-.0001
+4 SET ZTRTN="QUE^LRAPAULC"
DO BEG^LRUTL
IF POP!($DATA(ZTSK))
GOTO END
QUE USE IO
DO L^LRU
DO S^LRU
DO H
SET LR("F")=1
FOR LRO="ASP","ACY","AAU","AEM"
IF LR("Q")
QUIT
SET LRSS=$EXTRACT(LRO,2,3)
DO L
+1 DO C
DO END
DO END^LRUTL
QUIT
L FOR LRC=LRSDT:0
SET LRC=$ORDER(^LR(LRO,LRC))
IF 'LRC!(LRC>LRLDT)!(LR("Q"))
QUIT
FOR LRP=0:0
SET LRP=$ORDER(^LR(LRO,LRC,LRP))
IF 'LRP!(LR("Q"))
QUIT
DO @$SELECT(LRSS="AU":"W",1:"SP")
+1 QUIT
W IF '$DATA(^LR(LRP,"AU"))
KILL ^LR("AAU",LRC,LRP)
QUIT
+1 SET X=$PIECE(^LR(LRP,"AU"),"^",10)
IF 'X
SET X=^("AU")
DO U
QUIT
+2 IF '$DATA(LR(LRSS,X))
SET LR(LRSS,X)=0
SET LR(LRSS,X)=LR(LRSS,X)+1
QUIT
+3 ;
SP FOR LRI=0:0
SET LRI=$ORDER(^LR(LRO,LRC,LRP,LRI))
IF 'LRI!(LR("Q"))
QUIT
DO WR
+1 QUIT
WR IF '$DATA(^LR(LRP,LRSS,LRI,0))
KILL ^LR(LRO,LRC,LRP,LRI)
QUIT
+1 SET X=$PIECE(^LR(LRP,LRSS,LRI,0),"^",2)
IF 'X
SET X=^(0)
DO U
QUIT
+2 IF '$DATA(LR(LRSS,X))
SET LR(LRSS,X)=0
SET LR(LRSS,X)=LR(LRSS,X)+1
QUIT
C FOR LRSS="SP","CY","EM","AU"
IF LR("Q")
QUIT
SET LRI=0
DO D
+1 QUIT
D IF $Y>(IOSL-6)
DO H
IF LR("Q")
QUIT
WRITE !!?30
DO T
+1 FOR LRP=0:0
SET LRP=$ORDER(LR(LRSS,LRP))
IF 'LRP
QUIT
IF $Y>(IOSL-6)
DO H1
IF (LR("Q"))
QUIT
WRITE !,$SELECT($DATA(^VA(200,LRP,0)):$PIECE(^(0),U),1:LRP)," :",?32,$JUSTIFY(LR(LRSS,LRP),5)
SET LRI=LRI+LR(LRSS,LRP)
+2 IF LR("Q")
QUIT
IF $DATA(LR(LRSS,0))
IF $Y>(IOSL-6)
DO H
IF LR("Q")
QUIT
WRITE !,"Unassigned accessions :",?32,$JUSTIFY(LR(LRSS,0),5)
+3 WRITE !?32,"-----",!?26,"Total",?32,$JUSTIFY(LRI,5)
IF '$DATA(LR(LRSS,0))
QUIT
+4 FOR LRP=0:0
SET LRP=$ORDER(LR(LRSS,0,LRP))
IF 'LRP!(LR("Q"))
QUIT
SET Y=LRP
DO D^LRU
SET LRD=Y
FOR LRC=0:0
SET LRC=$ORDER(LR(LRSS,0,LRP,LRC))
IF 'LRC!(LR("Q"))
QUIT
IF $Y>(IOSL-6)
DO H
IF LR("Q")
QUIT
WRITE !?3,LRD,?30,"Accession #: ",LRC
+5 QUIT
U IF '$DATA(LR(LRSS,0))
SET LR(LRSS,0)=0
SET LR(LRSS,0)=LR(LRSS,0)+1
SET LR(LRSS,0,+X,$PIECE(X,"^",6))=""
QUIT
+1 ;
H IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
IF LR("Q")
QUIT
+1 DO F^LRU
WRITE !,"Accession counts by Senior Pathologist",!,"From: ",LRSTR," to:",LRLST,!,LR("%")
QUIT
H1 DO H
IF LR("Q")
QUIT
WRITE !?30
DO T
QUIT
T WRITE $SELECT(LRSS="SP":"SURGICAL PATHOLOGY",LRSS="CY":"CYTOPATHOLOGY",LRSS="EM":"ELECTRON MICROSCOPY",1:"AUTOPSY PATHOLOGY")," ACCESSION AREAS"
QUIT
+1 ;
END DO V^LRU
QUIT
