source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRAPAULC.m@ 1806

LRAPAULC ;AVAMC/REG - ACCESSION COUNTS BY PATHOLOGIST ;8/14/95  08:12
 ;;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