LRAPQAR ;DALOI/STAFF - 10% SURG PATH REVIEW ;02/24/11 15:45
;;5.2;LAB SERVICE;**72,173,350**;Sep 27, 1994;Build 230
;
EN ;
N LRDICS
S LRDICS="SPCYEM" D ^LRAP G:'$D(Y) END
W !!?25,"10% ",LRO(68)," Review"
D ASK^LRAPQAFS G:%<1 END
W ! D B^LRU G:Y<0 END S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99
S ZTRTN="QUE^LRAPQAR" D BEG^LRUTL G:POP!($D(ZTSK)) END
;
QUE ;
U IO
K ^TMP($J),^TMP("LRAP",$J)
S LRN="ALL",(LRQ(9),LRS(5),LRS(99))=1,LR("DIWF")="W",(LR,LR("A"),LR(1),LR(2),LR(3),LRQ(2),LRG,LRJ)=0
D L^LRU,S^LRU,L1^LRU,XR^LRU,H S LR("F")=1 W !,LR("%")
F S LRSDT=$O(^LR(LRXR,LRSDT)) Q:'LRSDT!(LRSDT>LRLDT) D
. S LRDFN=0
. F S LRDFN=$O(^LR(LRXR,LRSDT,LRDFN)) Q:'LRDFN D
. . S LRI=0
. . F S LRI=$O(^LR(LRXR,LRSDT,LRDFN,LRI)) Q:'LRI D T
;
W !,"Total accessions:",?23,$J(LRG,5),!
D A,EN2^LRUA,SET^LRUA
S LRQ=0,LRA=1
D W
K ^TMP("LRAP",$J)
D END^LRUTL,END
Q
;
;
T ;
I $P($P($G(^LR(LRDFN,LRSS,LRI,0)),U,6)," ")=LRABV S X=^(0),Z=$E($P(X,U,10),1,3),A=+$P($P(X,U,6)," ",3) D T1
Q
;
;
T1 ; Parse topographies by first digit of SNOMED I code if no SNOMED I code then use first digit of SNOMED CT code if mapped.
S X=0
F S X=$O(^LR(LRDFN,LRSS,LRI,2,X)) Q:'X D
. S Y=+^LR(LRDFN,LRSS,LRI,2,X,0)
. I Y,$D(^LAB(61,Y,0)) D
. . N LRSNMD
. . S LRSNMD=$E($P(^LAB(61,Y,0),U,2))
. . I LRSNMD="" S LRSNMD=$E($G(^LAB(61,Y,"SCT")))
. . I LRSNMD'="",Z S ^TMP($J,"B",LRSNMD,Z,A)="",LRG=LRG+1
Q
;
;
A ;
F X=0,1,2,3,4,5,6,7,8,9,0,"X","Y" I $D(^TMP($J,"B",X)) D C
K ^TMP($J,"B")
S X=-1 F S X=$O(^TMP($J,X)) Q:X="" W !?3,"Topography ",X,": ",$J(^(X),4)
F X=0,1,2,3,4,5,6,7,8,9,"X","Y" I $D(^TMP($J,X)) S T=^(X),C=0 D S
Q
;
;
W W !!,"Accessions for review: ",$J(LRJ,5) W:LRG&(LRJ) " (",$J(LRJ/LRG*100,5,2),"%)" I 'LRQA D H1 Q:LR("Q")
S LRY=0
F S LRY=$O(^TMP("LRAP",$J,LRY)) Q:'LRY!(LR("Q")) D
. S LRAN=0
. F S LRAN=$O(^TMP("LRAP",$J,LRY,LRAN)) Q:'LRAN!(LR("Q")) D D
;
S:LRQA LRQ=0
S LRY=0
F S LRY=$O(^TMP("LRAP",$J,LRY)) Q:'LRY!(LR("Q")) D B
Q
;
;
D ;
S LRDFN=$O(^LR(LRXREF,LRY,LRABV,LRAN,0)),LRI=$O(^(LRDFN,0)),LRAC=$P($G(^LR(LRDFN,LRSS,LRI,0)),U,6)
D:LRQA EN^LRSPRPT
D:'LRQA ^LRUA
S ^TMP("LRAP",$J,LRY,LRAN)=LRP_U_SSN_U_LRI_U_LRDFN_U_LRAC
D:LRC L^LRAPQAMR
Q
;
;
B ;
S LRAN=0
F S LRAN=$O(^TMP("LRAP",$J,LRY,LRAN)) Q:'LRAN!(LR("Q")) S X=^(LRAN),LRP=$P(X,"^"),SSN=$P(X,"^",2),LRI=$P(X,"^",3),LRDFN=$P(X,"^",4),LRAC=$P(X,U,5) D:$Y>(IOSL-6) H1 Q:LR("Q") D R
Q
;
;
R W !,LRAC,?18,LRP,?50,SSN
I LRI F LRT=0:0 S LRT=$O(^LR(LRDFN,LRSS,LRI,2,LRT)) Q:'LRT!(LR("Q")) S X=+^(LRT,0),LRX=$P(^LAB(61,X,0),"^") D:$Y>(IOSL-6) H2 Q:LR("Q") W !?5,LRX D M
W !,LR("%")
Q
;
;
M ;
S LRM=0
F S LRM=$O(^LR(LRDFN,LRSS,LRI,2,LRT,2,LRM)) Q:'LRM!(LR("Q")) S X=+^(LRM,0),M=$P(^LAB(61.1,X,0),"^") D:$Y>(IOSL-6) H3 Q:LR("Q") W !?10,M
Q
;
;
C ;
S (A,C)=0
F S A=$O(^TMP($J,"B",X,A)) Q:'A D
. S B=0
. F S B=$O(^TMP($J,"B",X,A,B)) Q:'B S C=C+1,^TMP($J,X,C)=A_"^"_B
S ^TMP($J,X)=C
Q
;
;
S S N=T*.1 S:N<1 N=1 I N["." S N=N_"00",A=$E($P(N,".",2),1,3),B=$P(N,"."),N=$S(A>499:B+1,1:B)
I T=1 S F=^TMP($J,X,1),^TMP("LRAP",$J,$P(F,"^"),$P(F,"^",2))="",LRJ=LRJ+1 K ^TMP($J,X,1) Q
F Q:C=N S E=$R(T)+1 I $D(^TMP($J,X,E)) S F=^(E),^TMP("LRAP",$J,$P(F,"^"),$P(F,"^",2))="",C=C+1,LRJ=LRJ+1 K ^TMP($J,X,E)
Q
;
;
H ;
I $D(LR("F")),$E(IOST,1,2)="C-" D M^LRU Q:LR("Q")
D F^LRU W !,"10% ",LRAA(1)," Review from ",LRSTR," to ",LRLST
Q
;
;
H1 D H Q:LR("Q") W !,"ACC #",?20,"NAME",?55,"SSN",!,LR("%") Q
;
;
H2 D H1 Q:LR("Q") W !,LRAC,?18,LRP,?50,SSN Q
;
;
H3 D H2 Q:LR("Q") W !?5,LRX Q
;
;
END ;
D V^LRU
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPQAR 3671 printed Nov 22, 2024@17:18:05 Page 2
LRAPQAR ;DALOI/STAFF - 10% SURG PATH REVIEW ;02/24/11 15:45
+1 ;;5.2;LAB SERVICE;**72,173,350**;Sep 27, 1994;Build 230
+2 ;
EN ;
+1 NEW LRDICS
+2 SET LRDICS="SPCYEM"
DO ^LRAP
if '$DATA(Y)
GOTO END
+3 WRITE !!?25,"10% ",LRO(68)," Review"
+4 DO ASK^LRAPQAFS
if %<1
GOTO END
+5 WRITE !
DO B^LRU
if Y<0
GOTO END
SET LRSDT=LRSDT-.01
SET LRLDT=LRLDT+.99
+6 SET ZTRTN="QUE^LRAPQAR"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
+7 ;
QUE ;
+1 USE IO
+2 KILL ^TMP($JOB),^TMP("LRAP",$JOB)
+3 SET LRN="ALL"
SET (LRQ(9),LRS(5),LRS(99))=1
SET LR("DIWF")="W"
SET (LR,LR("A"),LR(1),LR(2),LR(3),LRQ(2),LRG,LRJ)=0
+4 DO L^LRU
DO S^LRU
DO L1^LRU
DO XR^LRU
DO H
SET LR("F")=1
WRITE !,LR("%")
+5 FOR
SET LRSDT=$ORDER(^LR(LRXR,LRSDT))
if 'LRSDT!(LRSDT>LRLDT)
QUIT
Begin DoDot:1
+6 SET LRDFN=0
+7 FOR
SET LRDFN=$ORDER(^LR(LRXR,LRSDT,LRDFN))
if 'LRDFN
QUIT
Begin DoDot:2
+8 SET LRI=0
+9 FOR
SET LRI=$ORDER(^LR(LRXR,LRSDT,LRDFN,LRI))
if 'LRI
QUIT
DO T
End DoDot:2
End DoDot:1
+10 ;
+11 WRITE !,"Total accessions:",?23,$JUSTIFY(LRG,5),!
+12 DO A
DO EN2^LRUA
DO SET^LRUA
+13 SET LRQ=0
SET LRA=1
+14 DO W
+15 KILL ^TMP("LRAP",$JOB)
+16 DO END^LRUTL
DO END
+17 QUIT
+18 ;
+19 ;
T ;
+1 IF $PIECE($PIECE($GET(^LR(LRDFN,LRSS,LRI,0)),U,6)," ")=LRABV
SET X=^(0)
SET Z=$EXTRACT($PIECE(X,U,10),1,3)
SET A=+$PIECE($PIECE(X,U,6)," ",3)
DO T1
+2 QUIT
+3 ;
+4 ;
T1 ; Parse topographies by first digit of SNOMED I code if no SNOMED I code then use first digit of SNOMED CT code if mapped.
+1 SET X=0
+2 FOR
SET X=$ORDER(^LR(LRDFN,LRSS,LRI,2,X))
if 'X
QUIT
Begin DoDot:1
+3 SET Y=+^LR(LRDFN,LRSS,LRI,2,X,0)
+4 IF Y
IF $DATA(^LAB(61,Y,0))
Begin DoDot:2
+5 NEW LRSNMD
+6 SET LRSNMD=$EXTRACT($PIECE(^LAB(61,Y,0),U,2))
+7 IF LRSNMD=""
SET LRSNMD=$EXTRACT($GET(^LAB(61,Y,"SCT")))
+8 IF LRSNMD'=""
IF Z
SET ^TMP($JOB,"B",LRSNMD,Z,A)=""
SET LRG=LRG+1
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
+11 ;
A ;
+1 FOR X=0,1,2,3,4,5,6,7,8,9,0,"X","Y"
IF $DATA(^TMP($JOB,"B",X))
DO C
+2 KILL ^TMP($JOB,"B")
+3 SET X=-1
FOR
SET X=$ORDER(^TMP($JOB,X))
if X=""
QUIT
WRITE !?3,"Topography ",X,": ",$JUSTIFY(^(X),4)
+4 FOR X=0,1,2,3,4,5,6,7,8,9,"X","Y"
IF $DATA(^TMP($JOB,X))
SET T=^(X)
SET C=0
DO S
+5 QUIT
+6 ;
+7 ;
W WRITE !!,"Accessions for review: ",$JUSTIFY(LRJ,5)
if LRG&(LRJ)
WRITE " (",$JUSTIFY(LRJ/LRG*100,5,2),"%)"
IF 'LRQA
DO H1
if LR("Q")
QUIT
+1 SET LRY=0
+2 FOR
SET LRY=$ORDER(^TMP("LRAP",$JOB,LRY))
if 'LRY!(LR("Q"))
QUIT
Begin DoDot:1
+3 SET LRAN=0
+4 FOR
SET LRAN=$ORDER(^TMP("LRAP",$JOB,LRY,LRAN))
if 'LRAN!(LR("Q"))
QUIT
DO D
End DoDot:1
+5 ;
+6 if LRQA
SET LRQ=0
+7 SET LRY=0
+8 FOR
SET LRY=$ORDER(^TMP("LRAP",$JOB,LRY))
if 'LRY!(LR("Q"))
QUIT
DO B
+9 QUIT
+10 ;
+11 ;
D ;
+1 SET LRDFN=$ORDER(^LR(LRXREF,LRY,LRABV,LRAN,0))
SET LRI=$ORDER(^(LRDFN,0))
SET LRAC=$PIECE($GET(^LR(LRDFN,LRSS,LRI,0)),U,6)
+2 if LRQA
DO EN^LRSPRPT
+3 if 'LRQA
DO ^LRUA
+4 SET ^TMP("LRAP",$JOB,LRY,LRAN)=LRP_U_SSN_U_LRI_U_LRDFN_U_LRAC
+5 if LRC
DO L^LRAPQAMR
+6 QUIT
+7 ;
+8 ;
B ;
+1 SET LRAN=0
+2 FOR
SET LRAN=$ORDER(^TMP("LRAP",$JOB,LRY,LRAN))
if 'LRAN!(LR("Q"))
QUIT
SET X=^(LRAN)
SET LRP=$PIECE(X,"^")
SET SSN=$PIECE(X,"^",2)
SET LRI=$PIECE(X,"^",3)
SET LRDFN=$PIECE(X,"^",4)
SET LRAC=$PIECE(X,U,5)
if $Y>(IOSL-6)
DO H1
if LR("Q")
QUIT
DO R
+3 QUIT
+4 ;
+5 ;
R WRITE !,LRAC,?18,LRP,?50,SSN
+1 IF LRI
FOR LRT=0:0
SET LRT=$ORDER(^LR(LRDFN,LRSS,LRI,2,LRT))
if 'LRT!(LR("Q"))
QUIT
SET X=+^(LRT,0)
SET LRX=$PIECE(^LAB(61,X,0),"^")
if $Y>(IOSL-6)
DO H2
if LR("Q")
QUIT
WRITE !?5,LRX
DO M
+2 WRITE !,LR("%")
+3 QUIT
+4 ;
+5 ;
M ;
+1 SET LRM=0
+2 FOR
SET LRM=$ORDER(^LR(LRDFN,LRSS,LRI,2,LRT,2,LRM))
if 'LRM!(LR("Q"))
QUIT
SET X=+^(LRM,0)
SET M=$PIECE(^LAB(61.1,X,0),"^")
if $Y>(IOSL-6)
DO H3
if LR("Q")
QUIT
WRITE !?10,M
+3 QUIT
+4 ;
+5 ;
C ;
+1 SET (A,C)=0
+2 FOR
SET A=$ORDER(^TMP($JOB,"B",X,A))
if 'A
QUIT
Begin DoDot:1
+3 SET B=0
+4 FOR
SET B=$ORDER(^TMP($JOB,"B",X,A,B))
if 'B
QUIT
SET C=C+1
SET ^TMP($JOB,X,C)=A_"^"_B
End DoDot:1
+5 SET ^TMP($JOB,X)=C
+6 QUIT
+7 ;
+8 ;
S SET N=T*.1
if N<1
SET N=1
IF N["."
SET N=N_"00"
SET A=$EXTRACT($PIECE(N,".",2),1,3)
SET B=$PIECE(N,".")
SET N=$SELECT(A>499:B+1,1:B)
+1 IF T=1
SET F=^TMP($JOB,X,1)
SET ^TMP("LRAP",$JOB,$PIECE(F,"^"),$PIECE(F,"^",2))=""
SET LRJ=LRJ+1
KILL ^TMP($JOB,X,1)
QUIT
+2 FOR
if C=N
QUIT
SET E=$RANDOM(T)+1
IF $DATA(^TMP($JOB,X,E))
SET F=^(E)
SET ^TMP("LRAP",$JOB,$PIECE(F,"^"),$PIECE(F,"^",2))=""
SET C=C+1
SET LRJ=LRJ+1
KILL ^TMP($JOB,X,E)
+3 QUIT
+4 ;
+5 ;
H ;
+1 IF $DATA(LR("F"))
IF $EXTRACT(IOST,1,2)="C-"
DO M^LRU
if LR("Q")
QUIT
+2 DO F^LRU
WRITE !,"10% ",LRAA(1)," Review from ",LRSTR," to ",LRLST
+3 QUIT
+4 ;
+5 ;
H1 DO H
if LR("Q")
QUIT
WRITE !,"ACC #",?20,"NAME",?55,"SSN",!,LR("%")
QUIT
+1 ;
+2 ;
H2 DO H1
if LR("Q")
QUIT
WRITE !,LRAC,?18,LRP,?50,SSN
QUIT
+1 ;
+2 ;
H3 DO H2
if LR("Q")
QUIT
WRITE !?5,LRX
QUIT
+1 ;
+2 ;
END ;
+1 DO V^LRU
+2 QUIT
