LRUPAC ;AVAMC/REG - LAB ACCESSION COUNTS BY DATE ;2/18/93 13:08 ;
;;5.2;LAB SERVICE;;Sep 27, 1994
S DIC=68,DIC(0)="AEMOQZ" D ^DIC K DIC G:Y<1 END S W=+Y,W(1)=$P(Y,U,2),W(2)=$P(Y(0),U,2)
W !!?20,W(1)," ACCESSION COUNTS" D B^LRU G:Y<0 END
DEV S ZTRTN="QUE^LRUPAC" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO D EN^LRUTL,L^LRU,S^LRU
S LRLDT=LRLDT+.99,Z=$S($P(^LRO(68,W,0),U,3)="Y":$E(LRSDT,1,3)_"0000",1:LRSDT),Z(1)=$S($P(^LRO(68,W,0),U,3)="Y":$E(LRLDT,1,3)_"0000",1:LRLDT)
D Z,H S LR("F")=1 G:"AUCYEMSP"[W(2) AN
F S=0:0 S S=$O(S(S)) Q:'S!(LR("Q")) D:$Y>(IOSL-6) H Q:LR("Q") W !,$P(^LAB(61,S,0),"^"),"= ",S(S) F T=0:0 S T=$O(S(S,T)) Q:'T!(LR("Q")) D:$Y>(IOSL-6) H Q:LR("Q") W !?5,$P(^LAB(60,T,0),"^"),"= ",S(S,T)
Q:LR("Q") W !!,"TOTAL TESTS:" F T=0:0 S T=$O(T(T)) Q:'T!(LR("Q")) D:$Y>(IOSL-6) H Q:LR("Q") W !?5,$P(^LAB(60,T,0),"^"),"= ",T(T)
OUT D END^LRUTL,END Q
Z S Z=Z-1 F I=Z:0 S I=$O(^LRO(68,W,1,I)) Q:'I!(I>Z(1)) S LRSA=LRSDT-.01 F B=LRSA:0 S B=$O(^LRO(68,W,1,I,1,"AD",B)) Q:'B!(B>LRLDT) F W(6)=0:0 S W(6)=$O(^LRO(68,W,1,I,1,"AD",B,W(6))) Q:'W(6) D AC1 ;tf
Q
AC1 S S=$S($D(^LRO(68,W,1,I,1,W(6),5,1,0)):+^(0),1:0) S:S<1 S=LRU S:'$D(S(S)) S(S)=0 S S(S)=S(S)+1
F T=0:0 S T=$O(^LRO(68,W,1,I,1,W(6),4,T)) Q:'T S:'$D(T(T)) T(T)=0 S T(T)=T(T)+1 S:'$D(S(S,T)) S(S,T)=0 S S(S,T)=S(S,T)+1
Q
S Z=Z-1 F I=Z:0 S I=$O(^LRO(68,W,1,I)) Q:'I!(I>Z(1)) F W(6)=0:0 S W(6)=$O(^LRO(68,W,1,I,1,W(6))) Q:'W(6) D AC1
Q
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,"LABORATORY SERVICE ",?21,W(1)," COUNTS(",LRSTR,"-",LRLST,")",!,LR("%") Q
AN W !!,"Number of accessions: " W $S($D(S(LRU)):S(LRU),1:0) G OUT
;
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUPAC 1660 printed Apr 09, 2024@21:13:58 Page 2
LRUPAC ;AVAMC/REG - LAB ACCESSION COUNTS BY DATE ;2/18/93 13:08 ;
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
+2 SET DIC=68
SET DIC(0)="AEMOQZ"
DO ^DIC
KILL DIC
if Y<1
GOTO END
SET W=+Y
SET W(1)=$PIECE(Y,U,2)
SET W(2)=$PIECE(Y(0),U,2)
+3 WRITE !!?20,W(1)," ACCESSION COUNTS"
DO B^LRU
if Y<0
GOTO END
DEV SET ZTRTN="QUE^LRUPAC"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
DO EN^LRUTL
DO L^LRU
DO S^LRU
+1 SET LRLDT=LRLDT+.99
SET Z=$SELECT($PIECE(^LRO(68,W,0),U,3)="Y":$EXTRACT(LRSDT,1,3)_"0000",1:LRSDT)
SET Z(1)=$SELECT($PIECE(^LRO(68,W,0),U,3)="Y":$EXTRACT(LRLDT,1,3)_"0000",1:LRLDT)
+2 DO Z
DO H
SET LR("F")=1
if "AUCYEMSP"[W(2)
GOTO AN
+3 FOR S=0:0
SET S=$ORDER(S(S))
if 'S!(LR("Q"))
QUIT
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
WRITE !,$PIECE(^LAB(61,S,0),"^"),"= ",S(S)
FOR T=0:0
SET T=$ORDER(S(S,T))
if 'T!(LR("Q"))
QUIT
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
WRITE !?5,$PIECE(^LAB(60,T,0),"^"),"= ",S(S,T)
+4 if LR("Q")
QUIT
WRITE !!,"TOTAL TESTS:"
FOR T=0:0
SET T=$ORDER(T(T))
if 'T!(LR("Q"))
QUIT
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
WRITE !?5,$PIECE(^LAB(60,T,0),"^"),"= ",T(T)
OUT DO END^LRUTL
DO END
QUIT
Z ;tf
SET Z=Z-1
FOR I=Z:0
SET I=$ORDER(^LRO(68,W,1,I))
if 'I!(I>Z(1))
QUIT
SET LRSA=LRSDT-.01
FOR B=LRSA:0
SET B=$ORDER(^LRO(68,W,1,I,1,"AD",B))
if 'B!(B>LRLDT)
QUIT
FOR W(6)=0:0
SET W(6)=$ORDER(^LRO(68,W,1,I,1,"AD",B,W(6)))
if 'W(6)
QUIT
DO AC1
+1 QUIT
AC1 SET S=$SELECT($DATA(^LRO(68,W,1,I,1,W(6),5,1,0)):+^(0),1:0)
if S<1
SET S=LRU
if '$DATA(S(S))
SET S(S)=0
SET S(S)=S(S)+1
+1 FOR T=0:0
SET T=$ORDER(^LRO(68,W,1,I,1,W(6),4,T))
if 'T
QUIT
if '$DATA(T(T))
SET T(T)=0
SET T(T)=T(T)+1
if '$DATA(S(S,T))
SET S(S,T)=0
SET S(S,T)=S(S,T)+1
+2 QUIT
+3 SET Z=Z-1
FOR I=Z:0
SET I=$ORDER(^LRO(68,W,1,I))
if 'I!(I>Z(1))
QUIT
FOR W(6)=0:0
SET W(6)=$ORDER(^LRO(68,W,1,I,1,W(6)))
if 'W(6)
QUIT
DO AC1
+4 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 ",?21,W(1)," COUNTS(",LRSTR,"-",LRLST,")",!,LR("%")
QUIT
AN WRITE !!,"Number of accessions: "
WRITE $SELECT($DATA(S(LRU)):S(LRU),1:0)
GOTO OUT
+1 ;
END DO V^LRU
QUIT
