- LRUPACS ;AVAMC/REG - LAB ACCESSION COUNTS BY SHIFT ;2/18/93 13:09 ;
- ;;5.2;LAB SERVICE;**503**;Sep 27, 1994;Build 11
- D END S DIC=68,DIC(0)="AEMOQZ",DIC("S")="I ""AUCYEMSP""'[$P(^(0),U,2)&($P(^(0),U,2)]"""")" D ^DIC K DIC G:Y<1 END S W=+Y,W(1)=$P(Y,U,2)
- W !!?20,W(1)," ACCESSION & TEST COUNTS BY SHIFT" D B G:Y<0 END
- K X,Y,XY S ZTRTN="QUE^LRUPACS" D BEG^LRUTL G:POP!($D(ZTSK)) END
- QUE U IO D L^LRU,S^LRU,EN^LRUTL
- ;LR*5.2*503 add handling of monthly accession areas
- S LRLDT=LRLDT+.99
- S Z=$S($P(^LRO(68,W,0),U,3)="Y":$E(LRSDT,1,3)_"0000",$P(^LRO(68,W,0),U,3)="M":$E(LRSDT,1,5)_"00",1:LRSDT)
- S Z(1)=$S($P(^LRO(68,W,0),U,3)="Y":$E(LRLDT,1,3)_"0000",$P(^LRO(68,W,0),U,3)="M":$E(LRLDT,1,5)_"00",1:LRLDT)
- D H,Z S LR("F")=1 F S=4:1:8 S A(S)=0
- F S=0:0 S S=$O(S(S)) Q:'S!(LR("Q")) D:$Y>(IOSL-6) H Q:LR("Q") W !,$E($P(^LAB(61,S,0),"^"),1,19) S A(1)=$S($D(S(S,1)):S(S,1),1:0),A(2)=$S($D(S(S,2)):S(S,2),1:0),A(3)=$S($D(S(S,0)):S(S,0),1:0) D SUM
- G:LR("Q") OUT D TOT K A,S D TST Q:LR("Q") D TOT
- OUT W:IOST'?1"C".E @IOF D END^LRUTL,END Q
- TOT D:$Y>(IOSL-6) H Q:LR("Q") W !,?20,"-----",?35,"-----",?50,"-----",?65,"-------",!,"Total",$S($D(S):" Accessions",1:" Tests"),?20,$J(A(7),5),?35,$J(A(5),5),?50,$J(A(6),5),?65,$J(A(8),7)
- W:A(8) !?5,"%",?20,$J(A(7)/A(8)*100,5,1),?35,$J(A(5)/A(8)*100,5,1),?50,$J(A(6)/A(8)*100,5,1) Q
- SUM S A(4)=A(1)+A(2)+A(3),A(5)=A(5)+A(1),A(6)=A(6)+A(2),A(7)=A(7)+A(3),A(8)=A(8)+A(4)
- W ?20,$J(A(3),5),?35,$J(A(1),5),?50,$J(A(2),5),?65,$J(A(4),7) Q
- TST D:$Y>(IOSL-6) H Q:LR("Q") W !! F T=5:1:8 S A(T)=0
- F T=0:0 S T=$O(T(T)) Q:'T!(LR("Q")) D:$Y>(IOSL-6) H Q:LR("Q") W !,$E($P(^LAB(60,T,0),"^"),1,19) S A(1)=$S($D(T(T,1)):T(T,1),1:0),A(2)=$S($D(T(T,2)):T(T,2),1:0),A(3)=$S($D(T(T,0)):T(T,0),1:0) D SUM
- Q
- Q
- Z S Z=Z-1
- F I=Z:0 S I=$O(^LRO(68,W,1,I)) Q:'I!(I>Z(1)) S Z(3)=LRSDT-.01 F B=Z(3):0 S B=$O(^LRO(68,W,1,I,1,"AC",B)) Q:'B!(B>LRLDT) S Y=B#1*10000\800 F W(6)=0:0 S W(6)=$O(^LRO(68,W,1,I,1,"AC",B,W(6))) Q:'W(6) D AC1
- 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,Y)) S(S,Y)=0 S S(S,Y)=S(S,Y)+1
- F T=0:0 S T=$O(^LRO(68,W,1,I,1,W(6),4,T)) Q:'T S:'$D(T(T,Y)) T(T,Y)=0 S T(T,Y)=T(T,Y)+1 ;S:'$D(S(S,T,Y)) S(S,T,Y)=0 S S(S,T,Y)=S(S,T,Y)+1
- Q
- H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
- D F^LRU W !,"LABORATORY SERVICE ",W(1)," COUNTS",!?21,"From:",LRSTR," To:",LRLST
- W !,?20,"12am-8am",?35,"8am-4pm",?50,"4pm-midnight",?65,"Total count",!,LR("%") Q
- ;
- B D ^LRU S %DT="AEX",%DT(0)="-N",%DT("A")="Start with Date: T-1// " D ^%DT K %DT I X="" S X="T-1" D ^%DT S X=Y D D^LRU W Y S Y=X
- Q:Y<1 S LRSDT=Y I Y=DT D N G B
- S %DT="AEX",%DT("A")="Go to Date: T-1// " D ^%DT K %DT I X="" S X="T-1" D ^%DT S X=Y D D^LRU W Y S Y=X
- Q:Y<1 S LRLDT=Y I Y=DT D N G B
- I LRSDT>LRLDT S X=LRSDT,LRSDT=LRLDT,LRLDT=X
- S Y=LRSDT D D^LRU S LRSTR=Y,Y=LRLDT D D^LRU S LRLST=Y Q
- N W $C(7),!?3,"Date cannot be TODAY." Q
- ;
- END D V^LRU Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUPACS 2922 printed Feb 18, 2025@23:47:46 Page 2
- LRUPACS ;AVAMC/REG - LAB ACCESSION COUNTS BY SHIFT ;2/18/93 13:09 ;
- +1 ;;5.2;LAB SERVICE;**503**;Sep 27, 1994;Build 11
- +2 DO END
- SET DIC=68
- SET DIC(0)="AEMOQZ"
- SET DIC("S")="I ""AUCYEMSP""'[$P(^(0),U,2)&($P(^(0),U,2)]"""")"
- DO ^DIC
- KILL DIC
- if Y<1
- GOTO END
- SET W=+Y
- SET W(1)=$PIECE(Y,U,2)
- +3 WRITE !!?20,W(1)," ACCESSION & TEST COUNTS BY SHIFT"
- DO B
- if Y<0
- GOTO END
- +4 KILL X,Y,XY
- SET ZTRTN="QUE^LRUPACS"
- DO BEG^LRUTL
- if POP!($DATA(ZTSK))
- GOTO END
- QUE USE IO
- DO L^LRU
- DO S^LRU
- DO EN^LRUTL
- +1 ;LR*5.2*503 add handling of monthly accession areas
- +2 SET LRLDT=LRLDT+.99
- +3 SET Z=$SELECT($PIECE(^LRO(68,W,0),U,3)="Y":$EXTRACT(LRSDT,1,3)_"0000",$PIECE(^LRO(68,W,0),U,3)="M":$EXTRACT(LRSDT,1,5)_"00",1:LRSDT)
- +4 SET Z(1)=$SELECT($PIECE(^LRO(68,W,0),U,3)="Y":$EXTRACT(LRLDT,1,3)_"0000",$PIECE(^LRO(68,W,0),U,3)="M":$EXTRACT(LRLDT,1,5)_"00",1:LRLDT)
- +5 DO H
- DO Z
- SET LR("F")=1
- FOR S=4:1:8
- SET A(S)=0
- +6 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 !,$EXTRACT($PIECE(^LAB(61,S,0),"^"),1,19)
- SET A(1)=$SELECT($DATA(S(S,1)):S(S,1),1:0)
- SET A(2)=$SELECT($DATA(S(S,2)):S(S,2),1:0)
- SET A(3)=$SELECT($DATA(S(S,0)):S(S,0),1:0)
- DO SUM
- +7 if LR("Q")
- GOTO OUT
- DO TOT
- KILL A,S
- DO TST
- if LR("Q")
- QUIT
- DO TOT
- OUT if IOST'?1"C".E
- WRITE @IOF
- DO END^LRUTL
- DO END
- QUIT
- TOT if $Y>(IOSL-6)
- DO H
- if LR("Q")
- QUIT
- WRITE !,?20,"-----",?35,"-----",?50,"-----",?65,"-------",!,"Total",$SELECT($DATA(S):" Accessions",1:" Tests"),?20,$JUSTIFY(A(7),5),?35,$JUSTIFY(A(5),5),?50,$JUSTIFY(A(6),5),?65,$JUSTIFY(A(8),7)
- +1 if A(8)
- WRITE !?5,"%",?20,$JUSTIFY(A(7)/A(8)*100,5,1),?35,$JUSTIFY(A(5)/A(8)*100,5,1),?50,$JUSTIFY(A(6)/A(8)*100,5,1)
- QUIT
- SUM SET A(4)=A(1)+A(2)+A(3)
- SET A(5)=A(5)+A(1)
- SET A(6)=A(6)+A(2)
- SET A(7)=A(7)+A(3)
- SET A(8)=A(8)+A(4)
- +1 WRITE ?20,$JUSTIFY(A(3),5),?35,$JUSTIFY(A(1),5),?50,$JUSTIFY(A(2),5),?65,$JUSTIFY(A(4),7)
- QUIT
- TST if $Y>(IOSL-6)
- DO H
- if LR("Q")
- QUIT
- WRITE !!
- FOR T=5:1:8
- SET A(T)=0
- +1 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 !,$EXTRACT($PIECE(^LAB(60,T,0),"^"),1,19)
- SET A(1)=$SELECT($DATA(T(T,1)):T(T,1),1:0)
- SET A(2)=$SELECT($DATA(T(T,2)):T(T,2),1:0)
- SET A(3)=$SELECT($DATA(T(T,0)):T(T,0),1:0)
- DO SUM
- +2 QUIT
- +3 QUIT
- Z SET Z=Z-1
- +1 FOR I=Z:0
- SET I=$ORDER(^LRO(68,W,1,I))
- if 'I!(I>Z(1))
- QUIT
- SET Z(3)=LRSDT-.01
- FOR B=Z(3):0
- SET B=$ORDER(^LRO(68,W,1,I,1,"AC",B))
- if 'B!(B>LRLDT)
- QUIT
- SET Y=B#1*10000\800
- FOR W(6)=0:0
- SET W(6)=$ORDER(^LRO(68,W,1,I,1,"AC",B,W(6)))
- if 'W(6)
- QUIT
- DO AC1
- +2 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,Y))
- SET S(S,Y)=0
- SET S(S,Y)=S(S,Y)+1
- +1 ;S:'$D(S(S,T,Y)) S(S,T,Y)=0 S S(S,T,Y)=S(S,T,Y)+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,Y))
- SET T(T,Y)=0
- SET T(T,Y)=T(T,Y)+1
- +2 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 ",W(1)," COUNTS",!?21,"From:",LRSTR," To:",LRLST
- +2 WRITE !,?20,"12am-8am",?35,"8am-4pm",?50,"4pm-midnight",?65,"Total count",!,LR("%")
- QUIT
- +3 ;
- B DO ^LRU
- SET %DT="AEX"
- SET %DT(0)="-N"
- SET %DT("A")="Start with Date: T-1// "
- DO ^%DT
- KILL %DT
- IF X=""
- SET X="T-1"
- DO ^%DT
- SET X=Y
- DO D^LRU
- WRITE Y
- SET Y=X
- +1 if Y<1
- QUIT
- SET LRSDT=Y
- IF Y=DT
- DO N
- GOTO B
- +2 SET %DT="AEX"
- SET %DT("A")="Go to Date: T-1// "
- DO ^%DT
- KILL %DT
- IF X=""
- SET X="T-1"
- DO ^%DT
- SET X=Y
- DO D^LRU
- WRITE Y
- SET Y=X
- +3 if Y<1
- QUIT
- SET LRLDT=Y
- IF Y=DT
- DO N
- GOTO B
- +4 IF LRSDT>LRLDT
- SET X=LRSDT
- SET LRSDT=LRLDT
- SET LRLDT=X
- +5 SET Y=LRSDT
- DO D^LRU
- SET LRSTR=Y
- SET Y=LRLDT
- DO D^LRU
- SET LRLST=Y
- QUIT
- N WRITE $CHAR(7),!?3,"Date cannot be TODAY."
- QUIT
- +1 ;
- END DO V^LRU
- QUIT
