LRAPTT ;DALOI/STAFF - TURNAROUND TIME PATH ;09/09/11 11:39
;;5.2;LAB SERVICE;**1,72,201,397,350**;Sep 27, 1994;Build 230
;
EN ; Entry point for TAT report setup
;
D ^LRAP Q:'$D(Y)
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LRPROC,LRSPEC
I LRSS="AU" D Q:'$G(LR("AU"))
. S DIR(0)="S^1:Turnaround time for PAD;2:Turnaround time for FAD"
. S DIR("?",1)="Enter 1 for Provisional Anatomic Diagnoses (PAD)"
. S DIR("?")="Enter 2 for Final Anatomic Diagnoses (FAD)"
. D ^DIR
. I $D(DIRUT) D END Q
. S LR("AU")=+Y
;
D B^LRU
G:Y<0 END
S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99,LRL=0
K DIR,DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="Y",DIR("A")="Identify cases exceeding turnaround time limit",DIR("B")="NO"
D ^DIR
I $D(DIRUT) D END Q
I Y=1 D Q:'$G(LRB)
. K DIR,DIROUT,DIRUT,DTOUT,DUOUT
. S DIR(0)="N^1:120:0",DIR("A")="Enter limit in days"
. D ^DIR
. I $D(DIRUT) D END Q
. S LRB=+Y,LRL=LRB+1
;
K DIR,DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="S^0:Include All;1:Include Selected;2:Exclude Selected",DIR("A")="Include/Exclude Specimens",DIR("B")=0
D ^DIR
I $D(DIRUT) D END Q
S LRSPEC=+Y
I LRSPEC>0 D
. N DIC
. S DIC="^LAB(61,",DIC(0)="AEQM",DIC("A")="Select SPECIMEN: ",LRSPEC=+Y
. F D ^DIC Q:Y<1 S LRSPEC(+Y)=""
;
K DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="S^0:Include All;1:Include Selected;2:Exclude Selected",DIR("A")="Include/Exclude Procedures",DIR("B")=0
D ^DIR
I $D(DIRUT) D END Q
S LRPROC=+Y
I LRPROC>0 D
. N DIC
. S DIC="^LAB(61.5,",DIC(0)="AEQM",DIC("A")="Select PROCEDURE: ",LRPROC=+Y
. F D ^DIC Q:Y<1 S LRPROC(+Y)=""
;
I LRPROC>0 D I $D(DIRUT) D END Q
. K DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
. S DIR(0)="Y",DIR("A")="Count multiple procedure occurrence/case",DIR("B")="NO"
. S DIR("?",1)="Answer 'yes' if you want to count each occurrence of the same procedure/case."
. S DIR("?",2)="Answer 'no' if you want a procedure counted only once per case."
. S DIR("?",3)="This applies when a given accession (case) has the same procedure"
. S DIR("?")="specified for multiple topographies."
. D ^DIR
. I $D(DIRUT) Q
. S $P(LRPROC,"^",2)=+Y
;
S ZTRTN="QUE^LRAPTT" D BEG^LRUTL
G:POP!($D(ZTSK)) END
;
;
QUE ;
N LRPROCI,LRSPECI
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 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
I LRSPEC>0 D SPECTOT
;
I LRPROC>0 D PROCTOT
;
OUT ;
K ^TMP($J)
W:IOST'?1"C".E @IOF
K LRSPEC
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 ;
S LRDFN=0
F 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))
S LRI=0
F 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 ;
N LR61,LR615,LROK,LRJ,LRK
;
; Check if include/exclude specific specimens
I LRSPEC>0 D Q:'LROK
. S LRJ=0,LROK=$S(LRSPEC=1:0,1:1)
. F S LRJ=$O(^LR(LRDFN,LRSS,LRI,.1,LRJ)) Q:'LRJ D
. . S LR61=+$P(^LR(LRDFN,LRSS,LRI,.1,LRJ,0),"^",6)
. . I LR61<1 S:LRSPEC=2 LRSPECI(LR61)=$G(LRSPECI(LR61))+1
. . I $D(LRSPEC(LR61)) S LRSPEC(LR61)=LRSPEC(LR61)+1
. . I LRSPEC=1,'LROK S LROK=$S($D(LRSPEC(LR61)):1,1:0) Q
. . I LRSPEC=2,LROK S LROK=$S($D(LRSPEC(LR61)):0,1:1) S:LROK LRSPECI(LR61)=$G(LRSPECI(LR61))+1
;
; Check if include/exclude specific procedures
I LRPROC>0 D Q:'LROK
. N LRDUP
. S LRJ=0,LROK=$S($P(LRPROC,"^")=1:0,1:1)
. F S LRJ=$O(^LR(LRDFN,LRSS,LRI,2,LRJ)) Q:'LRJ D
. . S LRK=0
. . F S LRK=$O(^LR(LRDFN,LRSS,LRI,2,LRJ,4,LRK)) Q:'LRK D
. . . S LR615=+^LR(LRDFN,LRSS,LRI,2,LRJ,4,LRK,0)
. . . I '$P(LRPROC,"^",2),$D(LRDUP(LR615)) Q ; Already counted one and no duplicates
. . . S LRDUP(LR615)=""
. . . I $D(LRPROC(LR615)) S LRPROC(LR615)=LRPROC(LR615)+1
. . . I $P(LRPROC,"^")=1,'LROK S LROK=$S($D(LRPROC(LR615)):1,1:0) Q
. . . I $P(LRPROC,"^")=2,LROK S LROK=$S($D(LRPROC(LR615)):0,1:1) S:LROK LRPROCI(LR615)=$G(LRPROCI(LR615))+1
;
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
S 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="?"
I $D(^TMP($J,$E(LRR,1,3),Z))!(LRR="?") D
.S LRM=LRM-1,LRM(LRX)=LRM(LRX)-1
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 ;
N K
F K=1:1:LRY S X1=X,X2=1 D C^%DTC,H^%DTC S K(X)=%Y
S K=0
F S K=$O(K(K)) Q:'K D
. I "06"[K(K) S Y=Y+1 Q
. S:$D(^HOLIDAY(K)) Y=Y+1
S LRT=LRT-Y
Q
;
;
SPECTOT ; Print specimen totals section
N LR61,LRCNT,LRHLEN,LRPSNM,LRSHDR
;
S LRPSNM=$$GET^XPAR("DIV^PKG","LR AP SNOMED SYSTEM PRINT",1,"Q")
I LRPSNM<1 S LRPSNM=2
I $Y>(IOSL-6) D ^LRAPTT1 Q:LR("Q")
S (LRCNT,LRJ)=0
F S LRJ=$O(LRSPEC(LRJ)) Q:LRJ="" S LRCNT=LRCNT+LRSPEC(LRJ)
S LRSHDR="Specimens "_$S(LRSPEC=1:"included on",1:"excluded from")_" report",LRHLEN=40
W !!,$$LJ^XLFSTR(LRSHDR,LRHLEN,"."),": ",$J(LRCNT,5)
;
S LR61=""
F S LR61=$O(LRSPEC(LR61)) Q:LR61="" D Q:LR("Q")
. I $Y>(IOSL-3) D ^LRAPTT1 Q:LR("Q") W !,$$LJ^XLFSTR(LRSHDR,LRHLEN,".")," (cont'd)"
. I LR61 S LR61(0)=^LAB(61,LR61,0),LRX=$P(LR61(0),"^")
. E S LRX="Specimen not specified"
. I $L(LRX)>(LRHLEN) D
. . I $Y>(IOSL-6) D ^LRAPTT1 Q:LR("Q") W !,$$LJ^XLFSTR(LRSHDR,LRHLEN,".")," (cont'd)"
. . F W !,$E(LRX,1,(LRHLEN)) S LRX=$E(LRX,LRHLEN+1,999) Q:$L(LRX)<(LRHLEN)
. W !,$$LJ^XLFSTR(LRX,LRHLEN,"."),": ",$J(LRSPEC(LR61),5)
. I LR61,LRPSNM D
. . I LRPSNM?1(1"1",1"3") W !,"T-",$P(LR61(0),"^",2)," (SNM)"
. . I LRPSNM>1,$D(^LAB(61,LR61,"SCT")) W:LRPSNM=2 ! W:LRPSNM=3 " / " W $P(^LAB(61,LR61,"SCT"),"^")," (SCT)"
. . W !
;
I LRSPEC=2,$D(LRSPECI) D
. I $Y>(IOSL-6) D ^LRAPTT1 Q:LR("Q")
. S LRCNT=0,LR61=""
. F S LR61=$O(LRSPECI(LR61)) Q:LR61="" S LRCNT=LRCNT+LRSPECI(LR61)
. S LRSHDR="Specimens included on report"
. W !!,$$LJ^XLFSTR(LRSHDR,LRHLEN,"."),": ",$J(LRCNT,5)
. S LR61=""
. F S LR61=$O(LRSPECI(LR61)) Q:LR61="" D Q:LR("Q")
. . I $Y>(IOSL-3) D ^LRAPTT1 Q:LR("Q") W !,$$LJ^XLFSTR(LRSHDR,LRHLEN,".")," (cont'd)"
. . I LR61 S LR61(0)=^LAB(61,LR61,0),LRX=$P(LR61(0),"^")
. . E S LRX="Specimen not specified"
. . I $L(LRX)>(LRHLEN) D
. . . I $Y>(IOSL-6) D ^LRAPTT1 Q:LR("Q") W !,$$LJ^XLFSTR(LRSHDR,LRHLEN,".")," (cont'd)"
. . . F W !,$E(LRX,1,(LRHLEN)) S LRX=$E(LRX,LRHLEN+1,999) Q:$L(LRX)<(LRHLEN)
. . W !,$$LJ^XLFSTR(LRX,LRHLEN,"."),": ",$J(LRSPECI(LR61),5)
. . I LR61,LRPSNM D
. . . I LRPSNM?1(1"1",1"3") W !,"T-",$P(LR61(0),"^",2)," (SNM)"
. . . I LRPSNM>1,$D(^LAB(61,LR61,"SCT")) W:LRPSNM=2 ! W:LRPSNM=3 " / " W $P(^LAB(61,LR61,"SCT"),"^")," (SCT)"
. . . W !
Q
;
;
PROCTOT ; Print procedure totals section
N LR61,LRCNT,LRHLEN,LRPSNM,LRSHDR
;
S LRPSNM=$$GET^XPAR("DIV^PKG","LR AP SNOMED SYSTEM PRINT",1,"Q")
I LRPSNM<1 S LRPSNM=2
I $Y>(IOSL-6) D ^LRAPTT1 Q:LR("Q")
S (LRCNT,LRJ)=0
F S LRJ=$O(LRPROC(LRJ)) Q:LRJ="" S LRCNT=LRCNT+LRPROC(LRJ)
S LRSHDR="Procedures "_$S($P(LRPROC,"^")=1:"included on",1:"excluded from")_" report",LRHLEN=40
W !!,$$LJ^XLFSTR(LRSHDR,LRHLEN,"."),": ",$J(LRCNT,5)
;
S LR615=""
F S LR615=$O(LRPROC(LR615)) Q:LR615="" D Q:LR("Q")
. I $Y>(IOSL-3) D ^LRAPTT1 Q:LR("Q") W !,$$LJ^XLFSTR(LRSHDR,LRHLEN,".")," (cont'd)"
. I LR615 S LR615(0)=^LAB(61.5,LR615,0),LRX=$P(LR615(0),"^")
. E S LRX="Procedure not specified"
. I $L(LRX)>(LRHLEN) D
. . I $Y>(IOSL-6) D ^LRAPTT1 Q:LR("Q") W !,$$LJ^XLFSTR(LRSHDR,LRHLEN,".")," (cont'd)"
. . F W !,$E(LRX,1,(LRHLEN)) S LRX=$E(LRX,LRHLEN+1,999) Q:$L(LRX)<(LRHLEN)
. W !,$$LJ^XLFSTR(LRX,LRHLEN,"."),": ",$J(LRPROC(LR615),5)
. I LR615,LRPSNM D
. . I LRPSNM?1(1"1",1"3") W !,"P-",$P(LR615(0),"^",2)," (SNM)"
. . I LRPSNM>1,$D(^LAB(61.5,LR615,"SCT")) W:LRPSNM=2 ! W:LRPSNM=3 " / " W $P(^LAB(61.5,LR615,"SCT"),"^")," (SCT)"
. . W !
;
I $P(LRPROC,"^")=2,$D(LRPROCI) D
. I $Y>(IOSL-6) D ^LRAPTT1 Q:LR("Q")
. S LRCNT=0,LR615=""
. F S LR615=$O(LRPROCI(LR615)) Q:LR615="" S LRCNT=LRCNT+LRPROCI(LR615)
. S LRSHDR="Procedures included on report"
. W !!,$$LJ^XLFSTR(LRSHDR,LRHLEN,"."),": ",$J(LRCNT,5)
. S LR615=""
. F S LR615=$O(LRPROCI(LR615)) Q:LR615="" D Q:LR("Q")
. . I $Y>(IOSL-3) D ^LRAPTT1 Q:LR("Q") W !,$$LJ^XLFSTR(LRSHDR,LRHLEN,".")," (cont'd)"
. . I LR615 S LR615(0)=^LAB(61.5,LR615,0),LRX=$P(LR615(0),"^")
. . E S LRX="Procedure not specified"
. . I $L(LRX)>(LRHLEN) D
. . . I $Y>(IOSL-6) D ^LRAPTT1 Q:LR("Q") W !,$$LJ^XLFSTR(LRSHDR,LRHLEN,".")," (cont'd)"
. . . F W !,$E(LRX,1,(LRHLEN)) S LRX=$E(LRX,LRHLEN+1,999) Q:$L(LRX)<(LRHLEN)
. . W !,$$LJ^XLFSTR(LRX,LRHLEN,"."),": ",$J(LRPROCI(LR615),5)
. . I LR615,LRPSNM D
. . . I LRPSNM?1(1"1",1"3") W !,"P-",$P(LR615(0),"^",2)," (SNM)"
. . . I LRPSNM>1,$D(^LAB(61.5,LR615,"SCT")) W:LRPSNM=2 ! W:LRPSNM=3 " / " W $P(^LAB(61.5,LR615,"SCT"),"^")," (SCT)"
. . . W !
;
W !!,"Count multiple procedure occurrence/case.: ",$S($P(LRPROC,"^",2):"YES",1:"NO")
;
Q
;
;
END ;
D V^LRU
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPTT 10908 printed Nov 22, 2024@17:18:37 Page 2
LRAPTT ;DALOI/STAFF - TURNAROUND TIME PATH ;09/09/11 11:39
+1 ;;5.2;LAB SERVICE;**1,72,201,397,350**;Sep 27, 1994;Build 230
+2 ;
EN ; Entry point for TAT report setup
+1 ;
+2 DO ^LRAP
if '$DATA(Y)
QUIT
+3 ;
+4 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,LRPROC,LRSPEC
+5 IF LRSS="AU"
Begin DoDot:1
+6 SET DIR(0)="S^1:Turnaround time for PAD;2:Turnaround time for FAD"
+7 SET DIR("?",1)="Enter 1 for Provisional Anatomic Diagnoses (PAD)"
+8 SET DIR("?")="Enter 2 for Final Anatomic Diagnoses (FAD)"
+9 DO ^DIR
+10 IF $DATA(DIRUT)
DO END
QUIT
+11 SET LR("AU")=+Y
End DoDot:1
if '$GET(LR("AU"))
QUIT
+12 ;
+13 DO B^LRU
+14 if Y<0
GOTO END
+15 SET LRSDT=LRSDT-.01
SET LRLDT=LRLDT+.99
SET LRL=0
+16 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
+17 SET DIR(0)="Y"
SET DIR("A")="Identify cases exceeding turnaround time limit"
SET DIR("B")="NO"
+18 DO ^DIR
+19 IF $DATA(DIRUT)
DO END
QUIT
+20 IF Y=1
Begin DoDot:1
+21 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
+22 SET DIR(0)="N^1:120:0"
SET DIR("A")="Enter limit in days"
+23 DO ^DIR
+24 IF $DATA(DIRUT)
DO END
QUIT
+25 SET LRB=+Y
SET LRL=LRB+1
End DoDot:1
if '$GET(LRB)
QUIT
+26 ;
+27 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
+28 SET DIR(0)="S^0:Include All;1:Include Selected;2:Exclude Selected"
SET DIR("A")="Include/Exclude Specimens"
SET DIR("B")=0
+29 DO ^DIR
+30 IF $DATA(DIRUT)
DO END
QUIT
+31 SET LRSPEC=+Y
+32 IF LRSPEC>0
Begin DoDot:1
+33 NEW DIC
+34 SET DIC="^LAB(61,"
SET DIC(0)="AEQM"
SET DIC("A")="Select SPECIMEN: "
SET LRSPEC=+Y
+35 FOR
DO ^DIC
if Y<1
QUIT
SET LRSPEC(+Y)=""
End DoDot:1
+36 ;
+37 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+38 SET DIR(0)="S^0:Include All;1:Include Selected;2:Exclude Selected"
SET DIR("A")="Include/Exclude Procedures"
SET DIR("B")=0
+39 DO ^DIR
+40 IF $DATA(DIRUT)
DO END
QUIT
+41 SET LRPROC=+Y
+42 IF LRPROC>0
Begin DoDot:1
+43 NEW DIC
+44 SET DIC="^LAB(61.5,"
SET DIC(0)="AEQM"
SET DIC("A")="Select PROCEDURE: "
SET LRPROC=+Y
+45 FOR
DO ^DIC
if Y<1
QUIT
SET LRPROC(+Y)=""
End DoDot:1
+46 ;
+47 IF LRPROC>0
Begin DoDot:1
+48 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+49 SET DIR(0)="Y"
SET DIR("A")="Count multiple procedure occurrence/case"
SET DIR("B")="NO"
+50 SET DIR("?",1)="Answer 'yes' if you want to count each occurrence of the same procedure/case."
+51 SET DIR("?",2)="Answer 'no' if you want a procedure counted only once per case."
+52 SET DIR("?",3)="This applies when a given accession (case) has the same procedure"
+53 SET DIR("?")="specified for multiple topographies."
+54 DO ^DIR
+55 IF $DATA(DIRUT)
QUIT
+56 SET $PIECE(LRPROC,"^",2)=+Y
End DoDot:1
IF $DATA(DIRUT)
DO END
QUIT
+57 ;
+58 SET ZTRTN="QUE^LRAPTT"
DO BEG^LRUTL
+59 if POP!($DATA(ZTSK))
GOTO END
+60 ;
+61 ;
QUE ;
+1 NEW LRPROCI,LRSPECI
+2 USE IO
KILL ^TMP($JOB)
+3 SET LRD=""
SET (LRE,LRF,LRA,LRM)=0
+4 DO XR^LRU
DO L^LRU
DO S^LRU
DO ^LRAPTT1
+5 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
+6 FOR
SET LRSDT=$ORDER(^LR(LRXR,LRSDT))
if 'LRSDT!(LRSDT>LRLDT)
QUIT
DO I
+7 FOR LRH=0:0
SET LRH=$ORDER(^TMP($JOB,LRH))
if 'LRH!(LR("Q"))
QUIT
DO N
+8 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
+9 ;
+10 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"
+11 ;
+12 IF LRSS="AU"
WRITE !?6,"F= FULL AUTOPSY H= HEAD ONLY T= TRUNK ONLY O=OTHER LIMITATION"
+13 if $Y>(IOSL-8)
DO ^LRAPTT1
if LR("Q")
QUIT
+14 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)
+15 if LRF
WRITE !?5,"Average turnaround time (days): ",$JUSTIFY(LRE/LRF,2,2)
+16 if LRL&(LRF)
WRITE ?44,"Cases exceeding limit: ",LRA," (",$JUSTIFY(LRA/LRF*100,2,2),"%)"
+17 DO F^LRAPTT1
+18 IF LRSPEC>0
DO SPECTOT
+19 ;
+20 IF LRPROC>0
DO PROCTOT
+21 ;
OUT ;
+1 KILL ^TMP($JOB)
+2 if IOST'?1"C".E
WRITE @IOF
+3 KILL LRSPEC
+4 DO END^LRUTL
DO V^LRU
+5 QUIT
+6 ;
+7 ;
N ;
+1 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
+2 QUIT
+3 ;
+4 ;
B ;
+1 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)
+2 QUIT
+3 ;
+4 ;
I ;
+1 SET LRDFN=0
+2 FOR
SET LRDFN=$ORDER(^LR(LRXR,LRSDT,LRDFN))
if 'LRDFN
QUIT
SET M(2)=""
DO @($SELECT("CYEMSP"[LRSS:"L",1:"A"))
+3 QUIT
+4 ;
+5 ;
L ;
+1 if '$DATA(^LR(LRDFN,0))
QUIT
+2 SET LRI=0
+3 FOR
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
+4 SET LREND=0
+5 QUIT
+6 ;
+7 ;
G ;
+1 NEW LR61,LR615,LROK,LRJ,LRK
+2 ;
+3 ; Check if include/exclude specific specimens
+4 IF LRSPEC>0
Begin DoDot:1
+5 SET LRJ=0
SET LROK=$SELECT(LRSPEC=1:0,1:1)
+6 FOR
SET LRJ=$ORDER(^LR(LRDFN,LRSS,LRI,.1,LRJ))
if 'LRJ
QUIT
Begin DoDot:2
+7 SET LR61=+$PIECE(^LR(LRDFN,LRSS,LRI,.1,LRJ,0),"^",6)
+8 IF LR61<1
if LRSPEC=2
SET LRSPECI(LR61)=$GET(LRSPECI(LR61))+1
+9 IF $DATA(LRSPEC(LR61))
SET LRSPEC(LR61)=LRSPEC(LR61)+1
+10 IF LRSPEC=1
IF 'LROK
SET LROK=$SELECT($DATA(LRSPEC(LR61)):1,1:0)
QUIT
+11 IF LRSPEC=2
IF LROK
SET LROK=$SELECT($DATA(LRSPEC(LR61)):0,1:1)
if LROK
SET LRSPECI(LR61)=$GET(LRSPECI(LR61))+1
End DoDot:2
End DoDot:1
if 'LROK
QUIT
+12 ;
+13 ; Check if include/exclude specific procedures
+14 IF LRPROC>0
Begin DoDot:1
+15 NEW LRDUP
+16 SET LRJ=0
SET LROK=$SELECT($PIECE(LRPROC,"^")=1:0,1:1)
+17 FOR
SET LRJ=$ORDER(^LR(LRDFN,LRSS,LRI,2,LRJ))
if 'LRJ
QUIT
Begin DoDot:2
+18 SET LRK=0
+19 FOR
SET LRK=$ORDER(^LR(LRDFN,LRSS,LRI,2,LRJ,4,LRK))
if 'LRK
QUIT
Begin DoDot:3
+20 SET LR615=+^LR(LRDFN,LRSS,LRI,2,LRJ,4,LRK,0)
+21 ; Already counted one and no duplicates
IF '$PIECE(LRPROC,"^",2)
IF $DATA(LRDUP(LR615))
QUIT
+22 SET LRDUP(LR615)=""
+23 IF $DATA(LRPROC(LR615))
SET LRPROC(LR615)=LRPROC(LR615)+1
+24 IF $PIECE(LRPROC,"^")=1
IF 'LROK
SET LROK=$SELECT($DATA(LRPROC(LR615)):1,1:0)
QUIT
+25 IF $PIECE(LRPROC,"^")=2
IF LROK
SET LROK=$SELECT($DATA(LRPROC(LR615)):0,1:1)
if LROK
SET LRPROCI(LR615)=$GET(LRPROCI(LR615))+1
End DoDot:3
End DoDot:2
End DoDot:1
if 'LROK
QUIT
+26 ;
+27 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="??"
+28 DO S
+29 QUIT
+30 ;
+31 ;
S ;
+1 DO ^LRUP
if $GET(LREND)
QUIT
SET LRX=P("F")
if '$DATA(LRF(LRX))#2
SET LRF(LRX)=0
+2 if LRC
SET LRF=LRF+1
SET LRF(LRX)=LRF(LRX)+1
+3 SET LRM=LRM+1
SET LRM(LRX)=LRM(LRX)+1
+4 SET X1=LRC
SET X2=LRR
DO ^%DTC
if X=0
SET X="<1"
SET LRT=X
+5 IF X>1
SET LRY=X-1
SET Y=0
SET X=$PIECE(LRR,".")
DO D
+6 SET LRE=LRE+LRT
SET LRE(LRX)=LRE(LRX)+LRT
+7 IF LRC
IF LRL
IF LRT<LRL
QUIT
+8 ;
+9 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))
+10 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:"?")
+11 if 'LRR
SET LRR="?"
+12 IF $DATA(^TMP($JOB,$EXTRACT(LRR,1,3),Z))!(LRR="?")
Begin DoDot:1
+13 SET LRM=LRM-1
SET LRM(LRX)=LRM(LRX)-1
End DoDot:1
+14 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
+15 if LRC
SET LRA=LRA+1
SET LRA(LRX)=LRA(LRX)+1
+16 QUIT
+17 ;
+18 ;
A ;
+1 SET X=$GET(^LR(LRDFN,"AU"))
if $PIECE($PIECE(X,U,6)," ")'=LRABV
QUIT
+2 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)
+3 DO S
+4 QUIT
+5 ;
+6 ;
D ;
+1 NEW K
+2 FOR K=1:1:LRY
SET X1=X
SET X2=1
DO C^%DTC
DO H^%DTC
SET K(X)=%Y
+3 SET K=0
+4 FOR
SET K=$ORDER(K(K))
if 'K
QUIT
Begin DoDot:1
+5 IF "06"[K(K)
SET Y=Y+1
QUIT
+6 if $DATA(^HOLIDAY(K))
SET Y=Y+1
End DoDot:1
+7 SET LRT=LRT-Y
+8 QUIT
+9 ;
+10 ;
SPECTOT ; Print specimen totals section
+1 NEW LR61,LRCNT,LRHLEN,LRPSNM,LRSHDR
+2 ;
+3 SET LRPSNM=$$GET^XPAR("DIV^PKG","LR AP SNOMED SYSTEM PRINT",1,"Q")
+4 IF LRPSNM<1
SET LRPSNM=2
+5 IF $Y>(IOSL-6)
DO ^LRAPTT1
if LR("Q")
QUIT
+6 SET (LRCNT,LRJ)=0
+7 FOR
SET LRJ=$ORDER(LRSPEC(LRJ))
if LRJ=""
QUIT
SET LRCNT=LRCNT+LRSPEC(LRJ)
+8 SET LRSHDR="Specimens "_$SELECT(LRSPEC=1:"included on",1:"excluded from")_" report"
SET LRHLEN=40
+9 WRITE !!,$$LJ^XLFSTR(LRSHDR,LRHLEN,"."),": ",$JUSTIFY(LRCNT,5)
+10 ;
+11 SET LR61=""
+12 FOR
SET LR61=$ORDER(LRSPEC(LR61))
if LR61=""
QUIT
Begin DoDot:1
+13 IF $Y>(IOSL-3)
DO ^LRAPTT1
if LR("Q")
QUIT
WRITE !,$$LJ^XLFSTR(LRSHDR,LRHLEN,".")," (cont'd)"
+14 IF LR61
SET LR61(0)=^LAB(61,LR61,0)
SET LRX=$PIECE(LR61(0),"^")
+15 IF '$TEST
SET LRX="Specimen not specified"
+16 IF $LENGTH(LRX)>(LRHLEN)
Begin DoDot:2
+17 IF $Y>(IOSL-6)
DO ^LRAPTT1
if LR("Q")
QUIT
WRITE !,$$LJ^XLFSTR(LRSHDR,LRHLEN,".")," (cont'd)"
+18 FOR
WRITE !,$EXTRACT(LRX,1,(LRHLEN))
SET LRX=$EXTRACT(LRX,LRHLEN+1,999)
if $LENGTH(LRX)<(LRHLEN)
QUIT
End DoDot:2
+19 WRITE !,$$LJ^XLFSTR(LRX,LRHLEN,"."),": ",$JUSTIFY(LRSPEC(LR61),5)
+20 IF LR61
IF LRPSNM
Begin DoDot:2
+21 IF LRPSNM?1(1"1",1"3")
WRITE !,"T-",$PIECE(LR61(0),"^",2)," (SNM)"
+22 IF LRPSNM>1
IF $DATA(^LAB(61,LR61,"SCT"))
if LRPSNM=2
WRITE !
if LRPSNM=3
WRITE " / "
WRITE $PIECE(^LAB(61,LR61,"SCT"),"^")," (SCT)"
+23 WRITE !
End DoDot:2
End DoDot:1
if LR("Q")
QUIT
+24 ;
+25 IF LRSPEC=2
IF $DATA(LRSPECI)
Begin DoDot:1
+26 IF $Y>(IOSL-6)
DO ^LRAPTT1
if LR("Q")
QUIT
+27 SET LRCNT=0
SET LR61=""
+28 FOR
SET LR61=$ORDER(LRSPECI(LR61))
if LR61=""
QUIT
SET LRCNT=LRCNT+LRSPECI(LR61)
+29 SET LRSHDR="Specimens included on report"
+30 WRITE !!,$$LJ^XLFSTR(LRSHDR,LRHLEN,"."),": ",$JUSTIFY(LRCNT,5)
+31 SET LR61=""
+32 FOR
SET LR61=$ORDER(LRSPECI(LR61))
if LR61=""
QUIT
Begin DoDot:2
+33 IF $Y>(IOSL-3)
DO ^LRAPTT1
if LR("Q")
QUIT
WRITE !,$$LJ^XLFSTR(LRSHDR,LRHLEN,".")," (cont'd)"
+34 IF LR61
SET LR61(0)=^LAB(61,LR61,0)
SET LRX=$PIECE(LR61(0),"^")
+35 IF '$TEST
SET LRX="Specimen not specified"
+36 IF $LENGTH(LRX)>(LRHLEN)
Begin DoDot:3
+37 IF $Y>(IOSL-6)
DO ^LRAPTT1
if LR("Q")
QUIT
WRITE !,$$LJ^XLFSTR(LRSHDR,LRHLEN,".")," (cont'd)"
+38 FOR
WRITE !,$EXTRACT(LRX,1,(LRHLEN))
SET LRX=$EXTRACT(LRX,LRHLEN+1,999)
if $LENGTH(LRX)<(LRHLEN)
QUIT
End DoDot:3
+39 WRITE !,$$LJ^XLFSTR(LRX,LRHLEN,"."),": ",$JUSTIFY(LRSPECI(LR61),5)
+40 IF LR61
IF LRPSNM
Begin DoDot:3
+41 IF LRPSNM?1(1"1",1"3")
WRITE !,"T-",$PIECE(LR61(0),"^",2)," (SNM)"
+42 IF LRPSNM>1
IF $DATA(^LAB(61,LR61,"SCT"))
if LRPSNM=2
WRITE !
if LRPSNM=3
WRITE " / "
WRITE $PIECE(^LAB(61,LR61,"SCT"),"^")," (SCT)"
+43 WRITE !
End DoDot:3
End DoDot:2
if LR("Q")
QUIT
End DoDot:1
+44 QUIT
+45 ;
+46 ;
PROCTOT ; Print procedure totals section
+1 NEW LR61,LRCNT,LRHLEN,LRPSNM,LRSHDR
+2 ;
+3 SET LRPSNM=$$GET^XPAR("DIV^PKG","LR AP SNOMED SYSTEM PRINT",1,"Q")
+4 IF LRPSNM<1
SET LRPSNM=2
+5 IF $Y>(IOSL-6)
DO ^LRAPTT1
if LR("Q")
QUIT
+6 SET (LRCNT,LRJ)=0
+7 FOR
SET LRJ=$ORDER(LRPROC(LRJ))
if LRJ=""
QUIT
SET LRCNT=LRCNT+LRPROC(LRJ)
+8 SET LRSHDR="Procedures "_$SELECT($PIECE(LRPROC,"^")=1:"included on",1:"excluded from")_" report"
SET LRHLEN=40
+9 WRITE !!,$$LJ^XLFSTR(LRSHDR,LRHLEN,"."),": ",$JUSTIFY(LRCNT,5)
+10 ;
+11 SET LR615=""
+12 FOR
SET LR615=$ORDER(LRPROC(LR615))
if LR615=""
QUIT
Begin DoDot:1
+13 IF $Y>(IOSL-3)
DO ^LRAPTT1
if LR("Q")
QUIT
WRITE !,$$LJ^XLFSTR(LRSHDR,LRHLEN,".")," (cont'd)"
+14 IF LR615
SET LR615(0)=^LAB(61.5,LR615,0)
SET LRX=$PIECE(LR615(0),"^")
+15 IF '$TEST
SET LRX="Procedure not specified"
+16 IF $LENGTH(LRX)>(LRHLEN)
Begin DoDot:2
+17 IF $Y>(IOSL-6)
DO ^LRAPTT1
if LR("Q")
QUIT
WRITE !,$$LJ^XLFSTR(LRSHDR,LRHLEN,".")," (cont'd)"
+18 FOR
WRITE !,$EXTRACT(LRX,1,(LRHLEN))
SET LRX=$EXTRACT(LRX,LRHLEN+1,999)
if $LENGTH(LRX)<(LRHLEN)
QUIT
End DoDot:2
+19 WRITE !,$$LJ^XLFSTR(LRX,LRHLEN,"."),": ",$JUSTIFY(LRPROC(LR615),5)
+20 IF LR615
IF LRPSNM
Begin DoDot:2
+21 IF LRPSNM?1(1"1",1"3")
WRITE !,"P-",$PIECE(LR615(0),"^",2)," (SNM)"
+22 IF LRPSNM>1
IF $DATA(^LAB(61.5,LR615,"SCT"))
if LRPSNM=2
WRITE !
if LRPSNM=3
WRITE " / "
WRITE $PIECE(^LAB(61.5,LR615,"SCT"),"^")," (SCT)"
+23 WRITE !
End DoDot:2
End DoDot:1
if LR("Q")
QUIT
+24 ;
+25 IF $PIECE(LRPROC,"^")=2
IF $DATA(LRPROCI)
Begin DoDot:1
+26 IF $Y>(IOSL-6)
DO ^LRAPTT1
if LR("Q")
QUIT
+27 SET LRCNT=0
SET LR615=""
+28 FOR
SET LR615=$ORDER(LRPROCI(LR615))
if LR615=""
QUIT
SET LRCNT=LRCNT+LRPROCI(LR615)
+29 SET LRSHDR="Procedures included on report"
+30 WRITE !!,$$LJ^XLFSTR(LRSHDR,LRHLEN,"."),": ",$JUSTIFY(LRCNT,5)
+31 SET LR615=""
+32 FOR
SET LR615=$ORDER(LRPROCI(LR615))
if LR615=""
QUIT
Begin DoDot:2
+33 IF $Y>(IOSL-3)
DO ^LRAPTT1
if LR("Q")
QUIT
WRITE !,$$LJ^XLFSTR(LRSHDR,LRHLEN,".")," (cont'd)"
+34 IF LR615
SET LR615(0)=^LAB(61.5,LR615,0)
SET LRX=$PIECE(LR615(0),"^")
+35 IF '$TEST
SET LRX="Procedure not specified"
+36 IF $LENGTH(LRX)>(LRHLEN)
Begin DoDot:3
+37 IF $Y>(IOSL-6)
DO ^LRAPTT1
if LR("Q")
QUIT
WRITE !,$$LJ^XLFSTR(LRSHDR,LRHLEN,".")," (cont'd)"
+38 FOR
WRITE !,$EXTRACT(LRX,1,(LRHLEN))
SET LRX=$EXTRACT(LRX,LRHLEN+1,999)
if $LENGTH(LRX)<(LRHLEN)
QUIT
End DoDot:3
+39 WRITE !,$$LJ^XLFSTR(LRX,LRHLEN,"."),": ",$JUSTIFY(LRPROCI(LR615),5)
+40 IF LR615
IF LRPSNM
Begin DoDot:3
+41 IF LRPSNM?1(1"1",1"3")
WRITE !,"P-",$PIECE(LR615(0),"^",2)," (SNM)"
+42 IF LRPSNM>1
IF $DATA(^LAB(61.5,LR615,"SCT"))
if LRPSNM=2
WRITE !
if LRPSNM=3
WRITE " / "
WRITE $PIECE(^LAB(61.5,LR615,"SCT"),"^")," (SCT)"
+43 WRITE !
End DoDot:3
End DoDot:2
if LR("Q")
QUIT
End DoDot:1
+44 ;
+45 WRITE !!,"Count multiple procedure occurrence/case.: ",$SELECT($PIECE(LRPROC,"^",2):"YES",1:"NO")
+46 ;
+47 QUIT
+48 ;
+49 ;
END ;
+1 DO V^LRU
+2 QUIT
