- LRUPACT ; IHS/DIR/FJE - LAB ACC COUNTS BY TREATING SPECIALTY 9/30/93 11:57 ;
- ;;5.2;LR;;NOV 01, 1997
- ;
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- D END S DIC=68,DIC(0)="AEMQZ" D ^DIC K DIC G:Y<1 END S LRAA=+Y,LRAA(1)=$P(Y,U,2),LRSS=$P(Y(0),U,2)
- W !!?10,LRAA(1)," ACCESSION COUNTS BY TREATING SPECIALTY" D B^LRU G:Y<0 END
- S LRLDT=LRLDT+.99,T(3)=$S($P(Y(0),U,3)="Y":$E(LRSDT,1,3)_"0000","MQ"[$P(Y(0),U,3):$E(LRSDT,1,5)_"00",1:LRSDT),T(4)=$S($P(Y(0),U,3)="Y":$E(LRLDT,1,3)_"0000","MQ"[$P(Y(0),U,3):$E(LRLDT,1,5)_"00",1:LRLDT)
- DEV S ZTRTN="QUE^LRUPACT" D BEG^LRUTL G:POP!($D(ZTSK)) END
- QUE U IO K ^TMP($J) S LRT=0 D L^LRU,S^LRU,@($S($E(T(3),6,7)="00":"ACY",1:"ACD"))
- S S=0 F A=0:0 S S=$O(^TMP($J,"B",S)) Q:S="" S B=$S(S=+S&($D(^DIC(45.7,+S,0))):$P(^DIC(45.7,S,0),"^"),1:S),^TMP($J,"C",B,S)=""
- F T=0:0 S T=$O(^TMP($J,T)) Q:'T S ^TMP($J,"T",$P(^LAB(60,T,0),"^"),T)=""
- D H1 S LR("F")=1,Q(2)=0,M=-1
- F A=0:1 S M=$O(^TMP($J,"C",M)) Q:M=""!(LR("Q")) S S=0 F N=0:0 S S=$O(^TMP($J,"C",M,S)) Q:S=""!(LR("Q")) D:$Y>(IOSL-6) H1 Q:LR("Q") S T(6)=M W !,T(6),?30,$J(^TMP($J,"B",S),5) S Q(2)=Q(2)+^(S),T(5)=0 D T
- G:LR("Q") OUT W !?30,"-----",!,"Total Accessions: ",?30,$J(Q(2),5),?41,"Total tests: ",?70,$J(LRT,9) D H4
- G:LR("Q") OUT S N=0 F A=0:0 S N=$O(^TMP($J,"T",N)) Q:N=""!(LR("Q")) F T=0:0 S T=$O(^TMP($J,"T",N,T)) Q:'T!(LR("Q")) D:$Y>(IOSL-6) H4 Q:LR("Q") W !,N S V=0,S=-1 D F
- OUT W:IOST'?1"C".E @IOF D END^LRUTL,END Q
- F S M=0 F B=0:0 S M=$O(^TMP($J,"C",M)) Q:M=""!(LR("Q")) S S=0 F C=0:0 S S=$O(^TMP($J,"C",M,S)) Q:S=""!(LR("Q")) I $D(^TMP($J,T,S)) S Z=^(S) D:$Y>(IOSL-6) H4 Q:LR("Q") W !?30,M,?55,$J(Z,9) S V=V+Z W ?70,$J(V,9)
- Q:LR("Q") W !,LR("%") Q
- T S N=0 F B=0:0 S N=$O(^TMP($J,"T",N)) Q:N=""!(LR("Q")) F T=0:0 S T=$O(^TMP($J,"T",N,T)) Q:'T!(LR("Q")) I $D(^TMP($J,"B",S,T)) S T(1)=^(T) D:$Y>(IOSL-6) H1 Q:LR("Q") W !?41,N,?70,$J(T(1),9) S LRT=LRT+T(1),T(5)=T(5)+T(1)
- Q:LR("Q") D:$Y>(IOSL-6) H1 Q:LR("Q") W !?70,"---------",!?25,"Sub-total for ",T(6),":",?70,$J(T(5),9),!,LR("%") Q
- ACY S T(3)=T(3)-1 F I=T(3):0 S I=$O(^LRO(68,LRAA,1,I)) Q:'I!(I>T(4)) S LRSA=LRSDT-.01 F B=LRSA:0 S B=$O(^LRO(68,LRAA,1,I,1,"E",B)) Q:'B!(B>LRLDT) F LRAN=0:0 S LRAN=$O(^LRO(68,LRAA,1,I,1,"E",B,LRAN)) Q:'LRAN D AC1
- Q
- AC1 Q:'$D(^LRO(68,LRAA,1,I,1,LRAN,0)) S X=^(0) Q:I'=$P(X,"^",3)&("AUCYEMSP"'[LRSS) S P(9)=$P(X,"^",9) S:'P(9) P(9)=$P(X,"^",7) S:'$L(P(9)) P(9)="???" S:'$D(^TMP($J,"B",P(9))) ^(P(9))=0 S ^(P(9))=^(P(9))+1
- F T=0:0 S T=$O(^LRO(68,LRAA,1,I,1,LRAN,4,T)) Q:'T I $P($G(^LAB(60,T,0)),U,4)'="WK" S:'$D(^TMP($J,"B",P(9),T)) ^(T)=0 S ^(T)=^(T)+1 S:'$D(^TMP($J,T,P(9))) ^(P(9))=0 S ^(P(9))=^(P(9))+1
- Q
- ACD S T(3)=T(3)-1 F I=T(3):0 S I=$O(^LRO(68,LRAA,1,I)) Q:'I!(I>T(4)) F LRAN=0:0 S LRAN=$O(^LRO(68,LRAA,1,I,1,LRAN)) Q:'LRAN D AC1
- Q
- H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
- D F^LRU W !,"LABORATORY SERVICE ",LRAA(1)," COUNTS(",LRSTR,"-",LRLST,")" Q
- H1 D H Q:LR("Q") W !,"Specialty",?26,"# Accessions",?69,"Test count",!,LR("%") Q
- H2 D H Q:LR("Q") W !,S Q
- H4 D H Q:LR("Q") W !,"Test",?35,"Specialty",?55,"Test count",?70,"Cum count",!,LR("%") Q
- END D V^LRU Q
- LRUPACT ; IHS/DIR/FJE - LAB ACC COUNTS BY TREATING SPECIALTY 9/30/93 11:57 ;
- +1 ;;5.2;LR;;NOV 01, 1997
- +2 ;
- +3 ;;5.2;LAB SERVICE;;Sep 27, 1994
- +4 DO END
- SET DIC=68
- SET DIC(0)="AEMQZ"
- DO ^DIC
- KILL DIC
- IF Y<1
- GOTO END
- SET LRAA=+Y
- SET LRAA(1)=$PIECE(Y,U,2)
- SET LRSS=$PIECE(Y(0),U,2)
- +5 WRITE !!?10,LRAA(1)," ACCESSION COUNTS BY TREATING SPECIALTY"
- DO B^LRU
- IF Y<0
- GOTO END
- +6 SET LRLDT=LRLDT+.99
- SET T(3)=$SELECT($PIECE(Y(0),U,3)="Y":$EXTRACT(LRSDT,1,3)_"0000","MQ"[$PIECE(Y(0),U,3):$EXTRACT(LRSDT,1,5)_"00",1:LRSDT)
- SET T(4)=$SELECT($PIECE(Y(0),U,3)="Y":$EXTRACT(LRLDT,1,3)_"0000","MQ"[$PIECE(Y(0),U,3):$EXTRACT(LRLDT,1,5)_"00",1:LRLDT)
- DEV SET ZTRTN="QUE^LRUPACT"
- DO BEG^LRUTL
- IF POP!($DATA(ZTSK))
- GOTO END
- QUE USE IO
- KILL ^TMP($JOB)
- SET LRT=0
- DO L^LRU
- DO S^LRU
- DO @($SELECT($EXTRACT(T(3),6,7)="00":"ACY",1:"ACD"))
- +1 SET S=0
- FOR A=0:0
- SET S=$ORDER(^TMP($JOB,"B",S))
- IF S=""
- QUIT
- SET B=$SELECT(S=+S&($DATA(^DIC(45.7,+S,0))):$PIECE(^DIC(45.7,S,0),"^"),1:S)
- SET ^TMP($JOB,"C",B,S)=""
- +2 FOR T=0:0
- SET T=$ORDER(^TMP($JOB,T))
- IF 'T
- QUIT
- SET ^TMP($JOB,"T",$PIECE(^LAB(60,T,0),"^"),T)=""
- +3 DO H1
- SET LR("F")=1
- SET Q(2)=0
- SET M=-1
- +4 FOR A=0:1
- SET M=$ORDER(^TMP($JOB,"C",M))
- IF M=""!(LR("Q"))
- QUIT
- SET S=0
- FOR N=0:0
- SET S=$ORDER(^TMP($JOB,"C",M,S))
- IF S=""!(LR("Q"))
- QUIT
- IF $Y>(IOSL-6)
- DO H1
- IF LR("Q")
- QUIT
- SET T(6)=M
- WRITE !,T(6),?30,$JUSTIFY(^TMP($JOB,"B",S),5)
- SET Q(2)=Q(2)+^(S)
- SET T(5)=0
- DO T
- +5 IF LR("Q")
- GOTO OUT
- WRITE !?30,"-----",!,"Total Accessions: ",?30,$JUSTIFY(Q(2),5),?41,"Total tests: ",?70,$JUSTIFY(LRT,9)
- DO H4
- +6 IF LR("Q")
- GOTO OUT
- SET N=0
- FOR A=0:0
- SET N=$ORDER(^TMP($JOB,"T",N))
- IF N=""!(LR("Q"))
- QUIT
- FOR T=0:0
- SET T=$ORDER(^TMP($JOB,"T",N,T))
- IF 'T!(LR("Q"))
- QUIT
- IF $Y>(IOSL-6)
- DO H4
- IF LR("Q")
- QUIT
- WRITE !,N
- SET V=0
- SET S=-1
- DO F
- OUT IF IOST'?1"C".E
- WRITE @IOF
- DO END^LRUTL
- DO END
- QUIT
- F SET M=0
- FOR B=0:0
- SET M=$ORDER(^TMP($JOB,"C",M))
- IF M=""!(LR("Q"))
- QUIT
- SET S=0
- FOR C=0:0
- SET S=$ORDER(^TMP($JOB,"C",M,S))
- IF S=""!(LR("Q"))
- QUIT
- IF $DATA(^TMP($JOB,T,S))
- SET Z=^(S)
- IF $Y>(IOSL-6)
- DO H4
- IF LR("Q")
- QUIT
- WRITE !?30,M,?55,$JUSTIFY(Z,9)
- SET V=V+Z
- WRITE ?70,$JUSTIFY(V,9)
- +1 IF LR("Q")
- QUIT
- WRITE !,LR("%")
- QUIT
- T SET N=0
- FOR B=0:0
- SET N=$ORDER(^TMP($JOB,"T",N))
- IF N=""!(LR("Q"))
- QUIT
- FOR T=0:0
- SET T=$ORDER(^TMP($JOB,"T",N,T))
- IF 'T!(LR("Q"))
- QUIT
- IF $DATA(^TMP($JOB,"B",S,T))
- SET T(1)=^(T)
- IF $Y>(IOSL-6)
- DO H1
- IF LR("Q")
- QUIT
- WRITE !?41,N,?70,$JUSTIFY(T(1),9)
- SET LRT=LRT+T(1)
- SET T(5)=T(5)+T(1)
- +1 IF LR("Q")
- QUIT
- IF $Y>(IOSL-6)
- DO H1
- IF LR("Q")
- QUIT
- WRITE !?70,"---------",!?25,"Sub-total for ",T(6),":",?70,$JUSTIFY(T(5),9),!,LR("%")
- QUIT
- ACY SET T(3)=T(3)-1
- FOR I=T(3):0
- SET I=$ORDER(^LRO(68,LRAA,1,I))
- IF 'I!(I>T(4))
- QUIT
- SET LRSA=LRSDT-.01
- FOR B=LRSA:0
- SET B=$ORDER(^LRO(68,LRAA,1,I,1,"E",B))
- IF 'B!(B>LRLDT)
- QUIT
- FOR LRAN=0:0
- SET LRAN=$ORDER(^LRO(68,LRAA,1,I,1,"E",B,LRAN))
- IF 'LRAN
- QUIT
- DO AC1
- +1 QUIT
- AC1 IF '$DATA(^LRO(68,LRAA,1,I,1,LRAN,0))
- QUIT
- SET X=^(0)
- IF I'=$PIECE(X,"^",3)&("AUCYEMSP"'[LRSS)
- QUIT
- SET P(9)=$PIECE(X,"^",9)
- IF 'P(9)
- SET P(9)=$PIECE(X,"^",7)
- IF '$LENGTH(P(9))
- SET P(9)="???"
- IF '$DATA(^TMP($JOB,"B",P(9)))
- SET ^(P(9))=0
- SET ^(P(9))=^(P(9))+1
- +1 FOR T=0:0
- SET T=$ORDER(^LRO(68,LRAA,1,I,1,LRAN,4,T))
- IF 'T
- QUIT
- IF $PIECE($GET(^LAB(60,T,0)),U,4)'="WK"
- IF '$DATA(^TMP($JOB,"B",P(9),T))
- SET ^(T)=0
- SET ^(T)=^(T)+1
- IF '$DATA(^TMP($JOB,T,P(9)))
- SET ^(P(9))=0
- SET ^(P(9))=^(P(9))+1
- +2 QUIT
- ACD SET T(3)=T(3)-1
- FOR I=T(3):0
- SET I=$ORDER(^LRO(68,LRAA,1,I))
- IF 'I!(I>T(4))
- QUIT
- FOR LRAN=0:0
- SET LRAN=$ORDER(^LRO(68,LRAA,1,I,1,LRAN))
- IF 'LRAN
- QUIT
- DO AC1
- +1 QUIT
- H IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO M^LRU
- IF LR("Q")
- QUIT
- +1 DO F^LRU
- WRITE !,"LABORATORY SERVICE ",LRAA(1)," COUNTS(",LRSTR,"-",LRLST,")"
- QUIT
- H1 DO H
- IF LR("Q")
- QUIT
- WRITE !,"Specialty",?26,"# Accessions",?69,"Test count",!,LR("%")
- QUIT
- H2 DO H
- IF LR("Q")
- QUIT
- WRITE !,S
- QUIT
- H4 DO H
- IF LR("Q")
- QUIT
- WRITE !,"Test",?35,"Specialty",?55,"Test count",?70,"Cum count",!,LR("%")
- QUIT
- END DO V^LRU
- QUIT
