- LRUPAC ;VA/AVAMC/REG - LAB ACCESSION COUNTS BY DATE ;JUL 06, 2010 3:14 PM;
- ;;5.2;LAB SERVICE;**1022,1027**;NOV 01, 1997
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- ;
- EP ; EP - Begin -- IHS/OIT/MKK - Patch 1027
- NEW COMPLDT,LRAS
- K ^TMP("LRUPAC",$J) ; IHS/OIT/MKK - Patch 1027 Modification
- ; END -- IHS/OIT/MKK - Patch 1022
- ;
- 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
- K ^TMP("LRUPAC",$J) ; IHS/OIT/MKK - Patch 1027 Modification
- 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
- ; BEGIN -- IHS/OIT/MKK - Patch 1022
- F T=0:0 S T=$O(^LRO(68,W,1,I,1,W(6),4,T)) Q:'T D
- . S COMPLDT=+$P($G(^LRO(68,W,1,I,1,W(6),4,T,0)),"^",5) ; Completed Date
- . I COMPLDT<LRSDT!(COMPLDT>LRLDT) Q ; Make sure test completed in time frame
- . ;
- . ; Make sure Accession is different
- . ;I $D(LRAS(W,1,I,1,W(6),T))>0 Q ; If accession's been done, skip
- . ;
- . ; S LRAS(W,1,I,1,W(6),T)="" ; Set accession array
- . ;
- . ; ----- Begin IHS/OIT/MKK - Patch 1027 Modification
- . ; Make sure Accession & Test are different
- . I $D(^TMP("LRUPAC",$J,"LRAS",W,1,I,1,W(6),T))>0 Q
- . ;
- . S ^TMP("LRUPAC",$J,"LRAS",W,1,I,1,W(6),T)="" ; Set accession & Test
- . ; ----- End IHS/OIT/MKK - Patch 1027 Modification
- . ;
- . 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
- ; END -- IHS/OIT/MKK -- Patch 1022
- 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
- LRUPAC ;VA/AVAMC/REG - LAB ACCESSION COUNTS BY DATE ;JUL 06, 2010 3:14 PM;
- +1 ;;5.2;LAB SERVICE;**1022,1027**;NOV 01, 1997
- +2 ;;5.2;LAB SERVICE;;Sep 27, 1994
- +3 ;
- EP ; EP - Begin -- IHS/OIT/MKK - Patch 1027
- +1 NEW COMPLDT,LRAS
- +2 ; IHS/OIT/MKK - Patch 1027 Modification
- KILL ^TMP("LRUPAC",$JOB)
- +3 ; END -- IHS/OIT/MKK - Patch 1022
- +4 ;
- +5 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)
- +6 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 ; IHS/OIT/MKK - Patch 1027 Modification
- KILL ^TMP("LRUPAC",$JOB)
- +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))
- SET S(S)=0
- SET S(S)=S(S)+1
- +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
- +2 ; BEGIN -- IHS/OIT/MKK - Patch 1022
- +3 FOR T=0:0
- SET T=$ORDER(^LRO(68,W,1,I,1,W(6),4,T))
- IF 'T
- QUIT
- Begin DoDot:1
- +4 ; Completed Date
- SET COMPLDT=+$PIECE($GET(^LRO(68,W,1,I,1,W(6),4,T,0)),"^",5)
- +5 ; Make sure test completed in time frame
- IF COMPLDT<LRSDT!(COMPLDT>LRLDT)
- QUIT
- +6 ;
- +7 ; Make sure Accession is different
- +8 ;I $D(LRAS(W,1,I,1,W(6),T))>0 Q ; If accession's been done, skip
- +9 ;
- +10 ; S LRAS(W,1,I,1,W(6),T)="" ; Set accession array
- +11 ;
- +12 ; ----- Begin IHS/OIT/MKK - Patch 1027 Modification
- +13 ; Make sure Accession & Test are different
- +14 IF $DATA(^TMP("LRUPAC",$JOB,"LRAS",W,1,I,1,W(6),T))>0
- QUIT
- +15 ;
- +16 ; Set accession & Test
- SET ^TMP("LRUPAC",$JOB,"LRAS",W,1,I,1,W(6),T)=""
- +17 ; ----- End IHS/OIT/MKK - Patch 1027 Modification
- +18 ;
- +19 IF '$DATA(T(T))
- SET T(T)=0
- +20 SET T(T)=T(T)+1
- +21 IF '$DATA(S(S,T))
- SET S(S,T)=0
- +22 SET S(S,T)=S(S,T)+1
- End DoDot:1
- +23 ; END -- IHS/OIT/MKK -- Patch 1022
- +24 QUIT
- +25 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
- +26 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
