Routine: LRAPC

LRAPC ; IHS/DIR/AAB - ANAT TOPOGRAPHY COUNTS 8/14/95 08:36 ;

 ;;5.2;LR;**1002**;JUN 01, 1998

 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994

 S LRDICS="SPCYEM" D ^LRAP G:'$D(Y) END W !!,LRO(68)," (",LRABV,") TOPOGRAPHY COUNTS",!!

 D XR^LRU S S(1)=LRO(68)

 K T S T="" W !!,"TOPOGRAPHY (Organ/Tissue)" F B=1:1 D ASK Q:X[U!(X="")

 G:B<2&(T="") END S:T=""&(B=2) T=$O(T(-1)) W ! D B^LRU G:Y<0 END S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99

 S ZTRTN="QUE^LRAPC" D BEG^LRUTL G:POP!($D(ZTSK)) END

QUE U IO S (O,C,C(1),C(2))=0 K ^TMP($J) D L^LRU,S^LRU

 F A=0:0 S LRSDT=$O(^LR(LRXR,LRSDT)) Q:'LRSDT!(LRSDT>LRLDT)  D L

 D H,TOT K ^TMP($J) D END^LRUTL,END Q

TOT S LR("F")=1,T=-1 F X=1:1 S T=$O(O(T)) Q:T=""!(LR("Q"))  D:$Y>(IOSL-8) H Q:LR("Q")  W !?2,"T-",T,$E(".....",1,5-$L(T)),?14,$J(O(T),5),?22 W:C(2) $J(O(T)/C(2)*100,5,2),"%"

 S X=0 F A=0:1 S X=$O(^TMP($J,X)) Q:'X!(LR("Q"))

 Q:LR("Q")  W !!,"# Patients: ",A,!,"# accessions: ",C(1),!,"# organ/tissues: ",C(2),!,"% = % of organ/tissues" Q

L F LRDFN=0:0 S LRDFN=$O(^LR(LRXR,LRSDT,LRDFN)) Q:'LRDFN  D I

I F I=0:0 S I=$O(^LR(LRXR,LRSDT,LRDFN,I)) Q:'I  D T

T S X=$G(^LR(LRDFN,LRSS,I,0)) Q:$P($P(X,U,6)," ")'=LRABV  S ^TMP($J,LRDFN)="",C(1)=C(1)+1 ;set pt in utility global C(1)= acc # count

 S T=0 F B=0:1 S T=$O(^LR(LRDFN,LRSS,I,2,T)) Q:'T  S W=+^(T,0) D TG

 S C(2)=C(2)+B Q  ;Number of organ/tissues

TG Q:'$D(^LAB(61,W,0))  S W(1)=^(0),X=$P(W(1),"^",2),Y=-1 F C=0:1 S Y=$O(T(Y)) Q:Y=""  I $E(X,1,L(Y))=T(Y) S:'$D(O(Y)) O(Y)=0 S O(Y)=O(Y)+1

ASK K A("B") W !,"Choice #",$J(B,2),": Select 1 or more characters of the code: " R X:DTIME Q:X=""!(X[U)

 D CK^LRAUSM G:$D(A("B")) ASK S T(X)=X,L(X)=$L(X) Q

H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")

 D F^LRU W !,LRO(68)," (",LRABV,") TOPOGRAPHY COUNTS"

 W !,"Topography",?14,"Count",?22,"From:",LRSTR,"  To:",LRLST,!,LR("%") Q

END D V^LRU Q

LRAPC     ; IHS/DIR/AAB - ANAT TOPOGRAPHY COUNTS 8/14/95 08:36 ;

 +1       ;;5.2;LR;**1002**;JUN 01, 1998

 +2       ;;5.2;LAB SERVICE;**72**;Sep 27, 1994

 +3        SET LRDICS="SPCYEM"

           DO ^LRAP

           IF '$DATA(Y)

               GOTO END

           WRITE !!,LRO(68)," (",LRABV,") TOPOGRAPHY COUNTS",!!

 +4        DO XR^LRU

           SET S(1)=LRO(68)

 +5        KILL T

           SET T=""

           WRITE !!,"TOPOGRAPHY (Organ/Tissue)"

           FOR B=1:1

               DO ASK

               IF X[U!(X="")

                   QUIT

 +6        IF B<2&(T="")

               GOTO END

           IF T=""&(B=2)

               SET T=$ORDER(T(-1))

           WRITE !

           DO B^LRU

           IF Y<0

               GOTO END

           SET LRSDT=LRSDT-.01

           SET LRLDT=LRLDT+.99

 +7        SET ZTRTN="QUE^LRAPC"

           DO BEG^LRUTL

           IF POP!($DATA(ZTSK))

               GOTO END

QUE        USE IO

           SET (O,C,C(1),C(2))=0

           KILL ^TMP($JOB)

           DO L^LRU

           DO S^LRU

 +1        FOR A=0:0

               SET LRSDT=$ORDER(^LR(LRXR,LRSDT))

               IF 'LRSDT!(LRSDT>LRLDT)

                   QUIT

               DO L

 +2        DO H

           DO TOT

           KILL ^TMP($JOB)

           DO END^LRUTL

           DO END

           QUIT

TOT        SET LR("F")=1

           SET T=-1

           FOR X=1:1

               SET T=$ORDER(O(T))

               IF T=""!(LR("Q"))

                   QUIT

               IF $Y>(IOSL-8)

                   DO H

               IF LR("Q")

                   QUIT

               WRITE !?2,"T-",T,$EXTRACT(".....",1,5-$LENGTH(T)),?14,$JUSTIFY(O(T),5),?22

               IF C(2)

                   WRITE $JUSTIFY(O(T)/C(2)*100,5,2),"%"

 +1        SET X=0

           FOR A=0:1

               SET X=$ORDER(^TMP($JOB,X))

               IF 'X!(LR("Q"))

                   QUIT

 +2        IF LR("Q")

               QUIT

           WRITE !!,"# Patients: ",A,!,"# accessions: ",C(1),!,"# organ/tissues: ",C(2),!,"% = % of organ/tissues"

           QUIT

L          FOR LRDFN=0:0

               SET LRDFN=$ORDER(^LR(LRXR,LRSDT,LRDFN))

               IF 'LRDFN

                   QUIT

               DO I

 +1        QUIT

I          FOR I=0:0

               SET I=$ORDER(^LR(LRXR,LRSDT,LRDFN,I))

               IF 'I

                   QUIT

               DO T

 +1        QUIT

T         ;set pt in utility global C(1)= acc # count

           SET X=$GET(^LR(LRDFN,LRSS,I,0))

           IF $PIECE($PIECE(X,U,6)," ")'=LRABV

               QUIT

           SET ^TMP($JOB,LRDFN)=""

           SET C(1)=C(1)+1

 +1        SET T=0

           FOR B=0:1

               SET T=$ORDER(^LR(LRDFN,LRSS,I,2,T))

               IF 'T

                   QUIT

               SET W=+^(T,0)

               DO TG

 +2       ;Number of organ/tissues

           SET C(2)=C(2)+B

           QUIT

TG         IF '$DATA(^LAB(61,W,0))

               QUIT

           SET W(1)=^(0)

           SET X=$PIECE(W(1),"^",2)

           SET Y=-1

           FOR C=0:1

               SET Y=$ORDER(T(Y))

               IF Y=""

                   QUIT

               IF $EXTRACT(X,1,L(Y))=T(Y)

                   IF '$DATA(O(Y))

                       SET O(Y)=0

                   SET O(Y)=O(Y)+1

 +1        QUIT

ASK        KILL A("B")

           WRITE !,"Choice #",$JUSTIFY(B,2),": Select 1 or more characters of the code: "

           READ X:DTIME

           IF X=""!(X[U)

               QUIT

 +1        DO CK^LRAUSM

           IF $DATA(A("B"))

               GOTO ASK

           SET T(X)=X

           SET L(X)=$LENGTH(X)

           QUIT

H          IF $DATA(LR("F"))

               IF IOST?1"C".E

                   DO M^LRU

                   IF LR("Q")

                       QUIT

 +1        DO F^LRU

           WRITE !,LRO(68)," (",LRABV,") TOPOGRAPHY COUNTS"

 +2        WRITE !,"Topography",?14,"Count",?22,"From:",LRSTR,"  To:",LRLST,!,LR("%")

           QUIT

 +3       ;

END        DO V^LRU

           QUIT

LRAPC.m