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
Q
I F I=0:0 S I=$O(^LR(LRXR,LRSDT,LRDFN,I)) Q:'I D T
Q
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
Q
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
