LRAPTT ;AVAMC/REG/CYM - TURNAROUND TIME PATH 2/13/98 09:36 ; 13-Aug-2013 09:10 ; MKK
;;5.2;LAB SERVICE;**1,72,1006,201,1018,397,1033**;NOV 01, 1997
;
D ^LRAP Q:'$D(Y)
J I LRSS="AU" W !?15,"1. Turnaround time for PAD",!?15,"2. Turnaround time for FAD",!,"Select 1 or 2: " R X:DTIME G:X=""!(X[U) END S LR("AU")=X I X'=1&(X'=2) D H G J
D B^LRU G:Y<0 END S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99,LRL=0
W !,"Identify cases exceeding turnaround time limit " S %=2 D YN^LRU I %=1 D T^LRAPTT1 G:X[U END
S ZTRTN="QUE^LRAPTT" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO K ^TMP($J) S LRD="",(LRE,LRF,LRA,LRM)=0 D XR^LRU,L^LRU,S^LRU,^LRAPTT1 S LR("F")=1 F A=0:0 S A=$O(^DIC("AC","LR",A)) Q:'A S (LRE(A),LRF(A),LRM(A),LRA(A))=0
F X=0:0 S LRSDT=$O(^LR(LRXR,LRSDT)) Q:'LRSDT!(LRSDT>LRLDT) D I
F LRH=0:0 S LRH=$O(^TMP($J,LRH)) Q:'LRH!(LR("Q")) D N
G:LR("Q") OUT S B=0 F A=0:0 S A=$O(LRM(A)) Q:'A I A'=2,LRM(A) S B=1 Q
I B D:$Y>(IOSL-8) ^LRAPTT1 Q:LR("Q") W !!,"If '#', '*' or '?' is after Acc # then demographic data is in file indicated:",!?7,"# = Referral file * = Research file ? = Other file listed below"
I LRSS="AU" W !?6,"F= FULL AUTOPSY H= HEAD ONLY T= TRUNK ONLY O=OTHER LIMITATION"
D:$Y>(IOSL-8) ^LRAPTT1 Q:LR("Q") S X=LRM-LRF W !!,"Total cases:",$J(LRM,4) W:X !?3,"Incomplete cases:",$J(X,4) W !?3,"Complete cases:",$J(LRF,4)
W:LRF !?5,"Average turnaround time (days): ",$J(LRE/LRF,2,2) W:LRL&(LRF) ?44,"Cases exceeding limit: ",LRA," (",$J(LRA/LRF*100,2,2),"%)" D F^LRAPTT1
OUT K ^TMP($J) W:IOST'?1"C".E @IOF D END^LRUTL,V^LRU Q
N S LRZ=0 F S LRZ=$O(^TMP($J,LRH,LRZ)) Q:LRZ=""!(LR("Q")) D:$Y>(IOSL-6) ^LRAPTT1 Q:LR("Q") S Y=^TMP($J,LRH,LRZ) D B
Q
B W !,$J(LRZ,5),?5,$P(Y,U,8),?6,$P(Y,U,9),?8,$P(Y,U),?19,$E($P(Y,U,2),1,20),?40,$P(Y,U,3),?46,$P(Y,U,5),?51,$P(Y,U,4),?62,$J($P(Y,U,6),3),?66,$E($P(Y,U,7),1,13) Q
I F LRDFN=0:0 S LRDFN=$O(^LR(LRXR,LRSDT,LRDFN)) Q:'LRDFN S M(2)="" D @($S("CYEMSP"[LRSS:"L",1:"A"))
Q
L Q:'$D(^LR(LRDFN,0))
F LRI=0:0 S LRI=$O(^LR(LRXR,LRSDT,LRDFN,LRI)) Q:'LRI I $D(^LR(LRDFN,LRSS,LRI,0)) S X=^(0) D G:$P($P(X,"^",6)," ")=LRABV
S LREND=0 Q
G S Y=$P(X,U,11),Z=+$P($P(X,U,6)," ",3),W=$P(X,U,15),LRC=$S(W>1:W,Y>1:Y,Y=1:$P(X,U,3),1:""),H(4)=$P(X,U,2),LRR=$P(X,U,10),H(9)=$P(X,U,9),X=^LR(LRDFN,0) S:Z="" Z="??" D S Q
S D ^LRUP Q:$G(LREND) S LRX=P("F") S:'$D(LRF(LRX))#2 LRF(LRX)=0
S:LRC LRF=LRF+1,LRF(LRX)=LRF(LRX)+1 S LRM=LRM+1,LRM(LRX)=LRM(LRX)+1,X1=LRC,X2=LRR D ^%DTC S:X=0 X="<1" S LRT=X I X>1 S LRY=X-1,Y=0,X=$P(LRR,".") D D
S LRE=LRE+LRT,LRE(LRX)=LRE(LRX)+LRT I LRC,LRL,LRT<LRL Q
I H(4),$D(^VA(200,H(4),0)) S X=$P(^(0),U),H(4)=$S(X[",":$E($P(X,","),1,16),1:$E(X,1,16))
S H(5)=$$Y2K^LRX(LRR,"5D"),H("F")=$S(+LRC:$$Y2K^LRX(LRC,"5D"),1:""),X=$S(LRX=2:"",LRX=67:"#",LRX=67.1:"*",1:"?")
S:'LRR LRR="?" S ^TMP($J,$E(LRR,1,3),Z)=H(5)_U_LRP_U_SSN(1)_U_H("F")_U_H(9)_U_LRT_U_H(4)_U_X_U_LRD S:LRC LRA=LRA+1,LRA(LRX)=LRA(LRX)+1 Q
A S X=$G(^LR(LRDFN,"AU")) Q:$P($P(X,U,6)," ")'=LRABV S LRR=$P(X,U),Z=$P($P(X,U,6)," ",3),LRC=$S(LR("AU")=1:$P(X,U,17),1:$P(X,U,3)),LRD=$P(X,U,11),H(4)=$P(X,U,10),H(9)=$P(X,U,13),X=^LR(LRDFN,0)
D S Q
;
D F K=1:1:LRY S X1=X,X2=1 D C^%DTC,H^%DTC S K(X)=%Y
F K=0:0 S K=$O(K(K)) Q:'K D C
S LRT=LRT-Y K K Q
C I "06"[K(K) S Y=Y+1 Q
S:$D(^HOLIDAY(K)) Y=Y+1 Q
;
H W !!,"Enter 1 for Provisional Anatomic Diagnoses (PAD)",!,"Enter 2 for Final Anatomic Diagnoses (FAD)" Q
END D V^LRU Q
LRAPTT ;AVAMC/REG/CYM - TURNAROUND TIME PATH 2/13/98 09:36 ; 13-Aug-2013 09:10 ; MKK
+1 ;;5.2;LAB SERVICE;**1,72,1006,201,1018,397,1033**;NOV 01, 1997
+2 ;
+3 DO ^LRAP
IF '$DATA(Y)
QUIT
J IF LRSS="AU"
WRITE !?15,"1. Turnaround time for PAD",!?15,"2. Turnaround time for FAD",!,"Select 1 or 2: "
READ X:DTIME
IF X=""!(X[U)
GOTO END
SET LR("AU")=X
IF X'=1&(X'=2)
DO H
GOTO J
+1 DO B^LRU
IF Y<0
GOTO END
SET LRSDT=LRSDT-.01
SET LRLDT=LRLDT+.99
SET LRL=0
+2 WRITE !,"Identify cases exceeding turnaround time limit "
SET %=2
DO YN^LRU
IF %=1
DO T^LRAPTT1
IF X[U
GOTO END
+3 SET ZTRTN="QUE^LRAPTT"
DO BEG^LRUTL
IF POP!($DATA(ZTSK))
GOTO END
QUE USE IO
KILL ^TMP($JOB)
SET LRD=""
SET (LRE,LRF,LRA,LRM)=0
DO XR^LRU
DO L^LRU
DO S^LRU
DO ^LRAPTT1
SET LR("F")=1
FOR A=0:0
SET A=$ORDER(^DIC("AC","LR",A))
IF 'A
QUIT
SET (LRE(A),LRF(A),LRM(A),LRA(A))=0
+1 FOR X=0:0
SET LRSDT=$ORDER(^LR(LRXR,LRSDT))
IF 'LRSDT!(LRSDT>LRLDT)
QUIT
DO I
+2 FOR LRH=0:0
SET LRH=$ORDER(^TMP($JOB,LRH))
IF 'LRH!(LR("Q"))
QUIT
DO N
+3 IF LR("Q")
GOTO OUT
SET B=0
FOR A=0:0
SET A=$ORDER(LRM(A))
IF 'A
QUIT
IF A'=2
IF LRM(A)
SET B=1
QUIT
+4 IF B
IF $Y>(IOSL-8)
DO ^LRAPTT1
IF LR("Q")
QUIT
WRITE !!,"If '#', '*' or '?' is after Acc # then demographic data is in file indicated:",!?7,"# = Referral file * = Research file ? = Other file listed below"
+5 IF LRSS="AU"
WRITE !?6,"F= FULL AUTOPSY H= HEAD ONLY T= TRUNK ONLY O=OTHER LIMITATION"
+6 IF $Y>(IOSL-8)
DO ^LRAPTT1
IF LR("Q")
QUIT
SET X=LRM-LRF
WRITE !!,"Total cases:",$JUSTIFY(LRM,4)
IF X
WRITE !?3,"Incomplete cases:",$JUSTIFY(X,4)
WRITE !?3,"Complete cases:",$JUSTIFY(LRF,4)
+7 IF LRF
WRITE !?5,"Average turnaround time (days): ",$JUSTIFY(LRE/LRF,2,2)
IF LRL&(LRF)
WRITE ?44,"Cases exceeding limit: ",LRA," (",$JUSTIFY(LRA/LRF*100,2,2),"%)"
DO F^LRAPTT1
OUT KILL ^TMP($JOB)
IF IOST'?1"C".E
WRITE @IOF
DO END^LRUTL
DO V^LRU
QUIT
N SET LRZ=0
FOR
SET LRZ=$ORDER(^TMP($JOB,LRH,LRZ))
IF LRZ=""!(LR("Q"))
QUIT
IF $Y>(IOSL-6)
DO ^LRAPTT1
IF LR("Q")
QUIT
SET Y=^TMP($JOB,LRH,LRZ)
DO B
+1 QUIT
B WRITE !,$JUSTIFY(LRZ,5),?5,$PIECE(Y,U,8),?6,$PIECE(Y,U,9),?8,$PIECE(Y,U),?19,$EXTRACT($PIECE(Y,U,2),1,20),?40,$PIECE(Y,U,3),?46,$PIECE(Y,U,5),?51,$PIECE(Y,U,4),?62,$JUSTIFY($PIECE(Y,U,6),3),?66,$EXTRACT($PIECE(Y,U,7),1,13)
QUIT
I FOR LRDFN=0:0
SET LRDFN=$ORDER(^LR(LRXR,LRSDT,LRDFN))
IF 'LRDFN
QUIT
SET M(2)=""
DO @($SELECT("CYEMSP"[LRSS:"L",1:"A"))
+1 QUIT
L IF '$DATA(^LR(LRDFN,0))
QUIT
+1 FOR LRI=0:0
SET LRI=$ORDER(^LR(LRXR,LRSDT,LRDFN,LRI))
IF 'LRI
QUIT
IF $DATA(^LR(LRDFN,LRSS,LRI,0))
SET X=^(0)
IF $PIECE($PIECE(X,"^",6)," ")=LRABV
DO G
+2 SET LREND=0
QUIT
G SET Y=$PIECE(X,U,11)
SET Z=+$PIECE($PIECE(X,U,6)," ",3)
SET W=$PIECE(X,U,15)
SET LRC=$SELECT(W>1:W,Y>1:Y,Y=1:$PIECE(X,U,3),1:"")
SET H(4)=$PIECE(X,U,2)
SET LRR=$PIECE(X,U,10)
SET H(9)=$PIECE(X,U,9)
SET X=^LR(LRDFN,0)
IF Z=""
SET Z="??"
DO S
QUIT
S DO ^LRUP
IF $GET(LREND)
QUIT
SET LRX=P("F")
IF '$DATA(LRF(LRX))#2
SET LRF(LRX)=0
+1 IF LRC
SET LRF=LRF+1
SET LRF(LRX)=LRF(LRX)+1
SET LRM=LRM+1
SET LRM(LRX)=LRM(LRX)+1
SET X1=LRC
SET X2=LRR
DO ^%DTC
IF X=0
SET X="<1"
SET LRT=X
IF X>1
SET LRY=X-1
SET Y=0
SET X=$PIECE(LRR,".")
DO D
+2 SET LRE=LRE+LRT
SET LRE(LRX)=LRE(LRX)+LRT
IF LRC
IF LRL
IF LRT<LRL
QUIT
+3 IF H(4)
IF $DATA(^VA(200,H(4),0))
SET X=$PIECE(^(0),U)
SET H(4)=$SELECT(X[",":$EXTRACT($PIECE(X,","),1,16),1:$EXTRACT(X,1,16))
+4 SET H(5)=$$Y2K^LRX(LRR,"5D")
SET H("F")=$SELECT(+LRC:$$Y2K^LRX(LRC,"5D"),1:"")
SET X=$SELECT(LRX=2:"",LRX=67:"#",LRX=67.1:"*",1:"?")
+5 IF 'LRR
SET LRR="?"
SET ^TMP($JOB,$EXTRACT(LRR,1,3),Z)=H(5)_U_LRP_U_SSN(1)_U_H("F")_U_H(9)_U_LRT_U_H(4)_U_X_U_LRD
IF LRC
SET LRA=LRA+1
SET LRA(LRX)=LRA(LRX)+1
QUIT
A SET X=$GET(^LR(LRDFN,"AU"))
IF $PIECE($PIECE(X,U,6)," ")'=LRABV
QUIT
SET LRR=$PIECE(X,U)
SET Z=$PIECE($PIECE(X,U,6)," ",3)
SET LRC=$SELECT(LR("AU")=1:$PIECE(X,U,17),1:$PIECE(X,U,3))
SET LRD=$PIECE(X,U,11)
SET H(4)=$PIECE(X,U,10)
SET H(9)=$PIECE(X,U,13)
SET X=^LR(LRDFN,0)
+1 DO S
QUIT
+2 ;
D FOR K=1:1:LRY
SET X1=X
SET X2=1
DO C^%DTC
DO H^%DTC
SET K(X)=%Y
+1 FOR K=0:0
SET K=$ORDER(K(K))
IF 'K
QUIT
DO C
+2 SET LRT=LRT-Y
KILL K
QUIT
C IF "06"[K(K)
SET Y=Y+1
QUIT
+1 IF $DATA(^HOLIDAY(K))
SET Y=Y+1
QUIT
+2 ;
H WRITE !!,"Enter 1 for Provisional Anatomic Diagnoses (PAD)",!,"Enter 2 for Final Anatomic Diagnoses (FAD)"
QUIT
END DO V^LRU
QUIT
