LRUPACA ;IHS/DIR/FJE - LAB ACC COUNTS BY LOC 2/18/93 13:09 ;JUL 06, 2010 3:14 PM
;;5.2;LAB SERVICE;**1007,1013,1015,1022,1027,1030**;NOV 01, 1997
;;5.2;LR;;NOV 01, 1997
;
;;5.2;LAB SERVICE;;Sep 27, 1994
;;
EP ; Begin -- IHS/OIT/MKK - Patch 1022
NEW LRAS
; END -- IHS/OIT/MKK - Patch 1022
;
D END S DIC=68,DIC(0)="AEQMZ",DIC("S")="I ""AUCYEMSP""'[$P(^(0),U,2)&($P(^(0),U,2)]"""")" D ^DIC K DIC G:Y=-1 END S LRAA=+Y,LRAA(1)=$P(Y,U,2),LRSS=$P(Y(0),U,2)
K T S (Z(4),T(2))=0
W !!?20,LRAA(1)," ACCESSION COUNTS" D B^LRU G:Y<0 END
S LRLDT=LRLDT+.99,T(3)=$S($P(^LRO(68,LRAA,0),U,3)="Y":$E(LRSDT,1,3)_"0000",1:LRSDT),T(4)=$S($P(^LRO(68,LRAA,0),U,3)="Y":$E(LRLDT,1,3)_"0000",1:LRLDT)
DEV S ZTRTN="QUE^LRUPACA" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO K ^TMP($J) D:IOST?1"C".E WAIT^LRU D L^LRU,S^LRU,@($S(T(3)["0000":"ACY",1:"ACD"))
S Y=$S($D(^TMP($J,"S")):^("S"),1:"") D D^LRU S LRB=Y,Y=$S($D(^TMP($J,"E")):^("E"),1:"") D D^LRU S LRE=Y
D H1 S LR("F")=1,Q(2)=0,S=-1 F A=0:1 S S=$O(^TMP($J,"B",S)) Q:S=""!(LR("Q")) D:$Y>(IOSL-6) H1 Q:LR("Q") W !,S,?30,$J(^TMP($J,"B",S),5) S Q(2)=Q(2)+^(S) D T
;G:LR("Q") OUT W !?30,"-----",!,"Total Accessions: ",?30,$J(Q(2),5),?41,"Total tests: ",?70,$J(T(2),9) D H3 Q:LR("Q")
; G:LR("Q") OUT W !?30,"-----",?70,"_________",!,"Total Accessions: ",?30,$J(Q(2),5),?41,"Total tests: ",?70,$J(T(2),9) D H3 Q:LR("Q") ;IHS/ANMC/CLS 08/18/96
G:LR("Q") OUT W !?30,"-----",?70,"---------",!,"Total Accessions: ",?30,$J(Q(2),5),?41,"Total tests: ",?70,$J(T(2),9) D H3 Q:LR("Q") ;IHS/OIT/MKK 05/20/2009 -- Patch 1027
NEW TESTCNT,CUMCNT ; IHS/OIT/MKK 05/20/2009 -- Patch 1027
F T=0:0 S T=$O(^TMP($J,T)) Q:'T!(LR("Q")) D:$Y>(IOSL-6) H3 Q:LR("Q") W !,$S($D(^LAB(60,T,0)):$P(^(0),"^"),1:T) D B Q:LR("Q")
; ------ BEGIN IHS/OIT/MKK PATCH 1027 MODIFICATIONS
; W !
; W ?56,"---------"
; W !
; W ?36,"Total tests:"
; W ?56,$J(TESTCNT,9)
; W !
; ------ END IHS/OIT/MKK PATCH 1027 MODIFICATIONS
; ------ BEGIN IHS/OIT/MKK LR*5.2*1030 -- make sure TESTCNT variable > zero.
I +$G(TESTCNT)>0 D
. W !,?56,"---------",!
. W ?36,"Total tests:",?56,$J(TESTCNT,9),!
; ------ END IHS/OIT/MKK LR*5.2*1030
OUT D END^LRUTL,END Q
T F T=0:0 S T=$O(^TMP($J,"B",S,T)) Q:'T!(LR("Q")) D:$Y>(IOSL-6) H1 Q:LR("Q") S T(1)=^TMP($J,"B",S,T) W !?41,$S($D(^LAB(60,T,0)):$P(^(0),"^"),1:T),?70,$J(T(1),9) S T(2)=T(2)+T(1)
Q
B ; S V=0,S=0 F A=0:1 S S=$O(^TMP($J,T,S)) Q:S=""!(LR("Q")) D:$Y>(IOSL-6) H3 Q:LR("Q") S Z=^TMP($J,T,S) W !?30,S,?55,$J(Z,9) S V=V+Z W ?70,$J(V,9)
; Q
; ------ BEGIN IHS/OIT/MKK PATCH 1027 MODIFICATIONS
NEW HEDIT
S V=0,S=0
F S S=$O(^TMP($J,T,S)) Q:S=""!(LR("Q")) D
. S HEDIT=1
. D:$Y>(IOSL-6) H3,TESTHEAD Q:LR("Q")
. S Z=$G(^TMP($J,T,S))
. W:HEDIT !
. W ?35,S
. W ?56,$J(Z,9)
. S V=V+Z
. W ?70,$J(V,9)
. S TESTCNT=Z+$G(TESTCNT)
. S CUMCNT=V+$G(CUMCNT)
Q
;
TESTHEAD ; EP
W !,$S($D(^LAB(60,T,0)):$P(^(0),"^"),1:T)
S HEDIT=0
Q
; ------ END IHS/OIT/MKK PATCH 1027 MODIFICATIONS
;
ACY S T(3)=T(3)-1,LRB=$O(^LRO(68,LRAA,1,T(3))) F I=T(3):0 S I=$O(^LRO(68,LRAA,1,I)) Q:'I!(I>T(4)) S LRSA=LRSDT-.01,^TMP($J,"S")=$O(^LRO(68,LRAA,1,I,1,"E",LRSA)) D ACY1
Q
ACY1 S LRE="" F B=LRSA:0 S B=$O(^LRO(68,LRAA,1,I,1,"E",B)) Q:'B!(B>LRLDT) S LRE=B F LRAN=0:0 S LRAN=$O(^LRO(68,LRAA,1,I,1,"E",B,LRAN)) Q:'LRAN D AC1
S ^TMP($J,"E")=LRE Q
AC1 ;Q:'$D(^LRO(68,LRAA,1,I,1,LRAN,0)) Q:I'=$P(^(0),U,3) S X=^(0),LRLLOC=$S($L($P(X,U,7)):$P(X,U,7),$P(X,U,2)=62.3:"QC--"_$P(^LAB(62.3,$P(^LR($P(X,"^"),0),U,3),0),"^"),1:"???")
Q:'$D(^LRO(68,LRAA,1,I,1,LRAN,0)) Q:I'=$P(^(0),U,3) S X=^(0),LRLLOC=$S($L($P(X,U,7)):$P(X,U,7),$P(X,U,2)=62.3:"QC--"_$P($G(^LAB(62.3,$P(^LR($P(X,"^"),0),U,3),0),"DELETED CONTROL"),"^"),1:"???") ;IHS/ITSC/TPF 10/1/01 PATCH **1013*
S:'$D(^TMP($J,"B",LRLLOC)) ^(LRLLOC)=0 S ^(LRLLOC)=^(LRLLOC)+1
; F T=0:0 S T=$O(^LRO(68,LRAA,1,I,1,LRAN,4,T)) Q:'T S:'$D(^TMP($J,"B",LRLLOC,T)) ^(T)=0 S ^(T)=^(T)+1 S:'$D(^TMP($J,T,LRLLOC)) ^(LRLLOC)=0 S ^(LRLLOC)=^(LRLLOC)+1
; Begin -- IHS/OIT/MKK - Patch 1022
F T=0:0 S T=$O(^LRO(68,LRAA,1,I,1,LRAN,4,T)) Q:'T D
. I $P($G(^LRO(68,LRAA,1,I,1,LRAN,4,T,0)),"^",5)="" Q ; Must have Completed Date
. ;
. ; Make sure Accession is different
. ; I $D(LRAS(LRAA,1,I,1,LRAN,T))>0 Q ; If accession's test has already been done, skip
. I $D(^TMP("LRUPACA",$J,LRAA,1,I,1,LRAN,T))>0 Q ; IHS/OIT/MKK Lab Patch 1027
. ;
. ; S LRAS(LRAA,1,I,1,LRAN,T)="" ; Set accession array
. S ^TMP("LRUPACA",$J,LRAA,1,I,1,LRAN,T)="" ; IHS/OIT/MKK Lab Patch 1027
. ;
. ; Get rid of naked references
. ; S:'$D(^TMP($J,"B",LRLLOC,T)) ^(T)=0
. ; S ^(T)=^(T)+1
. ; S:'$D(^TMP($J,T,LRLLOC)) ^(LRLLOC)=0
. ; S ^(LRLLOC)=^(LRLLOC)+1
. ;
. S ^TMP($J,"B",LRLLOC,T)=1+$G(^TMP($J,"B",LRLLOC,T))
. S ^TMP($J,T,LRLLOC)=1+$G(^TMP($J,T,LRLLOC))
; End -- IHS/OIT/MKK - Patch 1022
Q
ACD S LRE="",T(3)=T(3)-1,^TMP($J,"S")=$O(^LRO(68,LRAA,1,T(3))) F I=T(3):0 S I=$O(^LRO(68,LRAA,1,I)) Q:'I!(I>T(4)) S LRE=I F LRAN=0:0 S LRAN=$O(^LRO(68,LRAA,1,I,1,LRAN)) Q:'LRAN D AC1
S ^TMP($J,"E")=LRE Q
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
S LRQ=LRQ+1,X="N",%DT="T" D ^%DT,D^LRU W @IOF,!,Y,?22,LRQ(1),?(IOM-10),"Pg: ",LRQ ;IHS/DIRT/FJE 4/5/99
W !,"LABORATORY SERVICE ",LRAA(1)," COUNTS (",LRSTR,"-",LRLST,")",!,"INCLUSIVE DATES WITH DATA: ",LRB W:LRE]"" " TO ",LRE Q ;IHS/DIRT/FJE 4/5/99 REMOVED D F^LRU
H1 D H Q:LR("Q") W !,"Location",?26,"# Accessions",?69,"Test count",!,LR("%") Q
H2 D H Q:LR("Q") W !,S Q
H3 D H Q:LR("Q") W !,"Test",?35,"Location",?55,"Test count",?70,"Cum count",!,LR("%") Q
;
END ; D V^LRU Q
D V^LRU K ^TMP("LRUPACA",$J) Q ; IHS/OIT/MKK - Lab Patch 1027
LRUPACA ;IHS/DIR/FJE - LAB ACC COUNTS BY LOC 2/18/93 13:09 ;JUL 06, 2010 3:14 PM
+1 ;;5.2;LAB SERVICE;**1007,1013,1015,1022,1027,1030**;NOV 01, 1997
+2 ;;5.2;LR;;NOV 01, 1997
+3 ;
+4 ;;5.2;LAB SERVICE;;Sep 27, 1994
+5 ;;
EP ; Begin -- IHS/OIT/MKK - Patch 1022
+1 NEW LRAS
+2 ; END -- IHS/OIT/MKK - Patch 1022
+3 ;
+4 DO END
SET DIC=68
SET DIC(0)="AEQMZ"
SET DIC("S")="I ""AUCYEMSP""'[$P(^(0),U,2)&($P(^(0),U,2)]"""")"
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 KILL T
SET (Z(4),T(2))=0
+6 WRITE !!?20,LRAA(1)," ACCESSION COUNTS"
DO B^LRU
IF Y<0
GOTO END
+7 SET LRLDT=LRLDT+.99
SET T(3)=$SELECT($PIECE(^LRO(68,LRAA,0),U,3)="Y":$EXTRACT(LRSDT,1,3)_"0000",1:LRSDT)
SET T(4)=$SELECT($PIECE(^LRO(68,LRAA,0),U,3)="Y":$EXTRACT(LRLDT,1,3)_"0000",1:LRLDT)
DEV SET ZTRTN="QUE^LRUPACA"
DO BEG^LRUTL
IF POP!($DATA(ZTSK))
GOTO END
QUE USE IO
KILL ^TMP($JOB)
IF IOST?1"C".E
DO WAIT^LRU
DO L^LRU
DO S^LRU
DO @($SELECT(T(3)["0000":"ACY",1:"ACD"))
+1 SET Y=$SELECT($DATA(^TMP($JOB,"S")):^("S"),1:"")
DO D^LRU
SET LRB=Y
SET Y=$SELECT($DATA(^TMP($JOB,"E")):^("E"),1:"")
DO D^LRU
SET LRE=Y
+2 DO H1
SET LR("F")=1
SET Q(2)=0
SET S=-1
FOR A=0:1
SET S=$ORDER(^TMP($JOB,"B",S))
IF S=""!(LR("Q"))
QUIT
IF $Y>(IOSL-6)
DO H1
IF LR("Q")
QUIT
WRITE !,S,?30,$JUSTIFY(^TMP($JOB,"B",S),5)
SET Q(2)=Q(2)+^(S)
DO T
+3 ;G:LR("Q") OUT W !?30,"-----",!,"Total Accessions: ",?30,$J(Q(2),5),?41,"Total tests: ",?70,$J(T(2),9) D H3 Q:LR("Q")
+4 ; G:LR("Q") OUT W !?30,"-----",?70,"_________",!,"Total Accessions: ",?30,$J(Q(2),5),?41,"Total tests: ",?70,$J(T(2),9) D H3 Q:LR("Q") ;IHS/ANMC/CLS 08/18/96
+5 ;IHS/OIT/MKK 05/20/2009 -- Patch 1027
IF LR("Q")
GOTO OUT
WRITE !?30,"-----",?70,"---------",!,"Total Accessions: ",?30,$JUSTIFY(Q(2),5),?41,"Total tests: ",?70,$JUSTIFY(T(2),9)
DO H3
IF LR("Q")
QUIT
+6 ; IHS/OIT/MKK 05/20/2009 -- Patch 1027
NEW TESTCNT,CUMCNT
+7 FOR T=0:0
SET T=$ORDER(^TMP($JOB,T))
IF 'T!(LR("Q"))
QUIT
IF $Y>(IOSL-6)
DO H3
IF LR("Q")
QUIT
WRITE !,$SELECT($DATA(^LAB(60,T,0)):$PIECE(^(0),"^"),1:T)
DO B
IF LR("Q")
QUIT
+8 ; ------ BEGIN IHS/OIT/MKK PATCH 1027 MODIFICATIONS
+9 ; W !
+10 ; W ?56,"---------"
+11 ; W !
+12 ; W ?36,"Total tests:"
+13 ; W ?56,$J(TESTCNT,9)
+14 ; W !
+15 ; ------ END IHS/OIT/MKK PATCH 1027 MODIFICATIONS
+16 ; ------ BEGIN IHS/OIT/MKK LR*5.2*1030 -- make sure TESTCNT variable > zero.
+17 IF +$GET(TESTCNT)>0
Begin DoDot:1
+18 WRITE !,?56,"---------",!
+19 WRITE ?36,"Total tests:",?56,$JUSTIFY(TESTCNT,9),!
End DoDot:1
+20 ; ------ END IHS/OIT/MKK LR*5.2*1030
OUT DO END^LRUTL
DO END
QUIT
T FOR T=0:0
SET T=$ORDER(^TMP($JOB,"B",S,T))
IF 'T!(LR("Q"))
QUIT
IF $Y>(IOSL-6)
DO H1
IF LR("Q")
QUIT
SET T(1)=^TMP($JOB,"B",S,T)
WRITE !?41,$SELECT($DATA(^LAB(60,T,0)):$PIECE(^(0),"^"),1:T),?70,$JUSTIFY(T(1),9)
SET T(2)=T(2)+T(1)
+1 QUIT
B ; S V=0,S=0 F A=0:1 S S=$O(^TMP($J,T,S)) Q:S=""!(LR("Q")) D:$Y>(IOSL-6) H3 Q:LR("Q") S Z=^TMP($J,T,S) W !?30,S,?55,$J(Z,9) S V=V+Z W ?70,$J(V,9)
+1 ; Q
+2 ; ------ BEGIN IHS/OIT/MKK PATCH 1027 MODIFICATIONS
+3 NEW HEDIT
+4 SET V=0
SET S=0
+5 FOR
SET S=$ORDER(^TMP($JOB,T,S))
IF S=""!(LR("Q"))
QUIT
Begin DoDot:1
+6 SET HEDIT=1
+7 IF $Y>(IOSL-6)
DO H3
DO TESTHEAD
IF LR("Q")
QUIT
+8 SET Z=$GET(^TMP($JOB,T,S))
+9 IF HEDIT
WRITE !
+10 WRITE ?35,S
+11 WRITE ?56,$JUSTIFY(Z,9)
+12 SET V=V+Z
+13 WRITE ?70,$JUSTIFY(V,9)
+14 SET TESTCNT=Z+$GET(TESTCNT)
+15 SET CUMCNT=V+$GET(CUMCNT)
End DoDot:1
+16 QUIT
+17 ;
TESTHEAD ; EP
+1 WRITE !,$SELECT($DATA(^LAB(60,T,0)):$PIECE(^(0),"^"),1:T)
+2 SET HEDIT=0
+3 QUIT
+4 ; ------ END IHS/OIT/MKK PATCH 1027 MODIFICATIONS
+5 ;
ACY SET T(3)=T(3)-1
SET LRB=$ORDER(^LRO(68,LRAA,1,T(3)))
FOR I=T(3):0
SET I=$ORDER(^LRO(68,LRAA,1,I))
IF 'I!(I>T(4))
QUIT
SET LRSA=LRSDT-.01
SET ^TMP($JOB,"S")=$ORDER(^LRO(68,LRAA,1,I,1,"E",LRSA))
DO ACY1
+1 QUIT
ACY1 SET LRE=""
FOR B=LRSA:0
SET B=$ORDER(^LRO(68,LRAA,1,I,1,"E",B))
IF 'B!(B>LRLDT)
QUIT
SET LRE=B
FOR LRAN=0:0
SET LRAN=$ORDER(^LRO(68,LRAA,1,I,1,"E",B,LRAN))
IF 'LRAN
QUIT
DO AC1
+1 SET ^TMP($JOB,"E")=LRE
QUIT
AC1 ;Q:'$D(^LRO(68,LRAA,1,I,1,LRAN,0)) Q:I'=$P(^(0),U,3) S X=^(0),LRLLOC=$S($L($P(X,U,7)):$P(X,U,7),$P(X,U,2)=62.3:"QC--"_$P(^LAB(62.3,$P(^LR($P(X,"^"),0),U,3),0),"^"),1:"???")
+1 ;IHS/ITSC/TPF 10/1/01 PATCH **1013*
IF '$DATA(^LRO(68,LRAA,1,I,1,LRAN,0))
QUIT
IF I'=$PIECE(^(0),U,3)
QUIT
SET X=^(0)
SET LRLLOC=$SELECT($LENGTH($PIECE(X,U,7)):$PIECE(X,U,7),$PIECE(X,U,2)=62.3:"QC--"_$PIECE($GET(^LAB(62.3,$PIECE(^LR($PIECE(X,"^"),0),U,3),0),"DELETED CONTROL"),"^"),1:"???")
+2 IF '$DATA(^TMP($JOB,"B",LRLLOC))
SET ^(LRLLOC)=0
SET ^(LRLLOC)=^(LRLLOC)+1
+3 ; F T=0:0 S T=$O(^LRO(68,LRAA,1,I,1,LRAN,4,T)) Q:'T S:'$D(^TMP($J,"B",LRLLOC,T)) ^(T)=0 S ^(T)=^(T)+1 S:'$D(^TMP($J,T,LRLLOC)) ^(LRLLOC)=0 S ^(LRLLOC)=^(LRLLOC)+1
+4 ; Begin -- IHS/OIT/MKK - Patch 1022
+5 FOR T=0:0
SET T=$ORDER(^LRO(68,LRAA,1,I,1,LRAN,4,T))
IF 'T
QUIT
Begin DoDot:1
+6 ; Must have Completed Date
IF $PIECE($GET(^LRO(68,LRAA,1,I,1,LRAN,4,T,0)),"^",5)=""
QUIT
+7 ;
+8 ; Make sure Accession is different
+9 ; I $D(LRAS(LRAA,1,I,1,LRAN,T))>0 Q ; If accession's test has already been done, skip
+10 ; IHS/OIT/MKK Lab Patch 1027
IF $DATA(^TMP("LRUPACA",$JOB,LRAA,1,I,1,LRAN,T))>0
QUIT
+11 ;
+12 ; S LRAS(LRAA,1,I,1,LRAN,T)="" ; Set accession array
+13 ; IHS/OIT/MKK Lab Patch 1027
SET ^TMP("LRUPACA",$JOB,LRAA,1,I,1,LRAN,T)=""
+14 ;
+15 ; Get rid of naked references
+16 ; S:'$D(^TMP($J,"B",LRLLOC,T)) ^(T)=0
+17 ; S ^(T)=^(T)+1
+18 ; S:'$D(^TMP($J,T,LRLLOC)) ^(LRLLOC)=0
+19 ; S ^(LRLLOC)=^(LRLLOC)+1
+20 ;
+21 SET ^TMP($JOB,"B",LRLLOC,T)=1+$GET(^TMP($JOB,"B",LRLLOC,T))
+22 SET ^TMP($JOB,T,LRLLOC)=1+$GET(^TMP($JOB,T,LRLLOC))
End DoDot:1
+23 ; End -- IHS/OIT/MKK - Patch 1022
+24 QUIT
ACD SET LRE=""
SET T(3)=T(3)-1
SET ^TMP($JOB,"S")=$ORDER(^LRO(68,LRAA,1,T(3)))
FOR I=T(3):0
SET I=$ORDER(^LRO(68,LRAA,1,I))
IF 'I!(I>T(4))
QUIT
SET LRE=I
FOR LRAN=0:0
SET LRAN=$ORDER(^LRO(68,LRAA,1,I,1,LRAN))
IF 'LRAN
QUIT
DO AC1
+1 SET ^TMP($JOB,"E")=LRE
QUIT
H IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
IF LR("Q")
QUIT
+1 ;IHS/DIRT/FJE 4/5/99
SET LRQ=LRQ+1
SET X="N"
SET %DT="T"
DO ^%DT
DO D^LRU
WRITE @IOF,!,Y,?22,LRQ(1),?(IOM-10),"Pg: ",LRQ
+2 ;IHS/DIRT/FJE 4/5/99 REMOVED D F^LRU
WRITE !,"LABORATORY SERVICE ",LRAA(1)," COUNTS (",LRSTR,"-",LRLST,")",!,"INCLUSIVE DATES WITH DATA: ",LRB
IF LRE]""
WRITE " TO ",LRE
QUIT
H1 DO H
IF LR("Q")
QUIT
WRITE !,"Location",?26,"# Accessions",?69,"Test count",!,LR("%")
QUIT
H2 DO H
IF LR("Q")
QUIT
WRITE !,S
QUIT
H3 DO H
IF LR("Q")
QUIT
WRITE !,"Test",?35,"Location",?55,"Test count",?70,"Cum count",!,LR("%")
QUIT
+1 ;
END ; D V^LRU Q
+1 ; IHS/OIT/MKK - Lab Patch 1027
DO V^LRU
KILL ^TMP("LRUPACA",$JOB)
QUIT
