- 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
