- 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 Mar 13, 2025@21:12:21 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
