LRUR ;AVAMC/REG - LAB TEST COUNTS BY SPECIMEN ;2/18/93 13:14 ;
;;5.2;LAB SERVICE;;Sep 27, 1994
D END W !?20,"Lab test counts by specimen type"
D B^LRU G:Y<0 END S LRLDT=9999999-LRLDT-.01,LRSDT=9999999-LRSDT+.99
S ZTRTN="QUE^LRUR" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO K ^TMP($J) D L^LRU,S^LRU,EN^LRUTL,H S LR("F")=1
F LRDFN=0:0 S LRDFN=$O(^LR(LRDFN)) Q:'LRDFN F A=LRLDT:0 S A=$O(^LR(LRDFN,"CH",A)) Q:'A!(A>LRSDT) S S=$P(^(A,0),"^",5) S:'S S=LRU D C
F A=0:0 S A=$O(^TMP($J,A)) Q:'A!(LR("Q")) S X=$P(^LAB(61,A,0),"^"),^TMP($J,"B",X,A)="" F B=0:0 S B=$O(^TMP($J,A,B)) Q:'B!(LR("Q")) S X=$S($D(^DD(63.04,B,0)):$P(^(0),"^"),1:B),^TMP($J,"C",X,B)=""
S LRS=0 F LRA=0:0 S LRS=$O(^TMP($J,"B",LRS)) Q:LRS=""!(LR("Q")) F LRI=0:0 S LRI=$O(^TMP($J,"B",LRS,LRI)) Q:'LRI!(LR("Q")) D:$Y>(IOSL-6) H Q:LR("Q") W !,"Specimen: ",LRS," (",^TMP($J,LRI),")" D T
D END^LRUTL,END Q
T S LRT=0 F LRB=0:0 S LRT=$O(^TMP($J,"C",LRT)) Q:LRT=""!(LR("Q")) F LRJ=0:0 S LRJ=$O(^TMP($J,"C",LRT,LRJ)) Q:'LRJ!(LR("Q")) D:$Y>(IOSL-6) H1 Q:LR("Q") I $D(^TMP($J,LRI,LRJ)) W !?3,LRT,?40,$J(^(LRJ),6)
Q
C S:'$D(^TMP($J,S)) ^(S)=0 S X=^(S),^(S)=X+1 F B=1:0 S B=$O(^LR(LRDFN,"CH",A,B)) Q:'B S:'$D(^TMP($J,S,B)) ^(B)=0 S X=^(B),^(B)=X+1
Q
;
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,"LABORATORY SERVICE ",!?9,"TEST COUNTS FROM ",LRSTR," TO ",LRLST,!,LR("%") Q
H1 D H Q:LR("Q") W !,"Specimen: ",LRS Q
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUR 1432 printed Apr 09, 2024@21:11:50 Page 2
LRUR ;AVAMC/REG - LAB TEST COUNTS BY SPECIMEN ;2/18/93 13:14 ;
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
+2 DO END
WRITE !?20,"Lab test counts by specimen type"
+3 DO B^LRU
if Y<0
GOTO END
SET LRLDT=9999999-LRLDT-.01
SET LRSDT=9999999-LRSDT+.99
+4 SET ZTRTN="QUE^LRUR"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
KILL ^TMP($JOB)
DO L^LRU
DO S^LRU
DO EN^LRUTL
DO H
SET LR("F")=1
+1 FOR LRDFN=0:0
SET LRDFN=$ORDER(^LR(LRDFN))
if 'LRDFN
QUIT
FOR A=LRLDT:0
SET A=$ORDER(^LR(LRDFN,"CH",A))
if 'A!(A>LRSDT)
QUIT
SET S=$PIECE(^(A,0),"^",5)
if 'S
SET S=LRU
DO C
+2 FOR A=0:0
SET A=$ORDER(^TMP($JOB,A))
if 'A!(LR("Q"))
QUIT
SET X=$PIECE(^LAB(61,A,0),"^")
SET ^TMP($JOB,"B",X,A)=""
FOR B=0:0
SET B=$ORDER(^TMP($JOB,A,B))
if 'B!(LR("Q"))
QUIT
SET X=$SELECT($DATA(^DD(63.04,B,0)):$PIECE(^(0),"^"),1:B)
SET ^TMP($JOB,"C",X,B)=""
+3 SET LRS=0
FOR LRA=0:0
SET LRS=$ORDER(^TMP($JOB,"B",LRS))
if LRS=""!(LR("Q"))
QUIT
FOR LRI=0:0
SET LRI=$ORDER(^TMP($JOB,"B",LRS,LRI))
if 'LRI!(LR("Q"))
QUIT
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
WRITE !,"Specimen: ",LRS," (",^TMP($JOB,LRI),")"
DO T
+4 DO END^LRUTL
DO END
QUIT
T SET LRT=0
FOR LRB=0:0
SET LRT=$ORDER(^TMP($JOB,"C",LRT))
if LRT=""!(LR("Q"))
QUIT
FOR LRJ=0:0
SET LRJ=$ORDER(^TMP($JOB,"C",LRT,LRJ))
if 'LRJ!(LR("Q"))
QUIT
if $Y>(IOSL-6)
DO H1
if LR("Q")
QUIT
IF $DATA(^TMP($JOB,LRI,LRJ))
WRITE !?3,LRT,?40,$JUSTIFY(^(LRJ),6)
+1 QUIT
C if '$DATA(^TMP($JOB,S))
SET ^(S)=0
SET X=^(S)
SET ^(S)=X+1
FOR B=1:0
SET B=$ORDER(^LR(LRDFN,"CH",A,B))
if 'B
QUIT
if '$DATA(^TMP($JOB,S,B))
SET ^(B)=0
SET X=^(B)
SET ^(B)=X+1
+1 QUIT
+2 ;
H IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
if LR("Q")
QUIT
+1 DO F^LRU
WRITE !,"LABORATORY SERVICE ",!?9,"TEST COUNTS FROM ",LRSTR," TO ",LRLST,!,LR("%")
QUIT
H1 DO H
if LR("Q")
QUIT
WRITE !,"Specimen: ",LRS
QUIT
END DO V^LRU
QUIT
