LRCYPCT ; IHS/DIR/AAB - CYTOPATH %POS,NEG,SUSP, & UNSAT 8/13/95 15:41 ; [ 07/22/2002 1:16 PM ]
;;5.2;LR;**1002,1013**;JUL 15, 2002
;;5.2;LAB SERVICE;**72**;Sep 27, 1994
S LRDICS="CY" D ^LRAP G:'$D(Y) END S IOP="HOME" D ^%ZIS W @IOF,!,LRO(68)," (",LRABV,") Cytology Specimens:"
I $O(^LRO(69.2,LRAA,12,0)) W !,"Use morphology list " S %=1 D YN^LRU G:%<1 END I %=1 D M G:$D(LRA) TO
F X=80013,69760,"09460","09010" S Y=$O(^LAB(61.1,"C",X,0)) W !?25,$S(Y:"% "_$P(^LAB(61.1,Y,0),"^"),1:"No entry in Morphology file for SNOMED code: "_X) G:'Y OUT S LRA(Y)=$P(^(0),"^")
TO W ! K LRN,LRM I $O(^LRO(69.2,LRAA,11,0)) W !,"Use topography category list " S %=1 D YN^LRU G:%<1 END I %=1 D SET G:$D(LRN) DATE
W ! F B=1:1 D ASK Q:X[U!(X="")
DATE G:B<2 END W ! D B^LRU G:Y<0 END S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99 W !!,"Include locations for each morphology " S %=2 D YN^LRU G:%<1 END S LRP=$S(%=1:1,1:0)
S ZTRTN="QUE^LRCYPCT" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO K ^TMP($J) S LR=0 D L^LRU,S^LRU,XR^LRU,H S LR("F")=1
F X=0:0 S LRSDT=$O(^LR(LRXR,LRSDT)) Q:'LRSDT!(LRSDT>LRLDT) D LRDFN
D P K ^TMP($J) D END^LRUTL,END Q
LRDFN F LRDFN=0:0 S LRDFN=$O(^LR(LRXR,LRSDT,LRDFN)) Q:'LRDFN D I
Q
I F LRI=0:0 S LRI=$O(^LR(LRXR,LRSDT,LRDFN,LRI)) Q:'LRI I $P($P($G(^LR(LRDFN,LRSS,LRI,0)),U,6)," ")=LRABV D T
Q
T F O=0:0 S O=$O(^LR(LRDFN,LRSS,LRI,2,O)) Q:'O S T=^(O,0) D TG
Q
TG Q:'$D(^LAB(61,T,0)) S T=$P(^(0),"^",2) S A=0 F E=0:0 S A=$O(LRN(A)) Q:A="" I A=$E(T,1,LRM(A)) D G Q
Q
G S:'$D(^TMP($J,A)) ^(A)=0 S X=^(A),^(A)=X+1 S LRL=$P(^LR(LRDFN,LRSS,LRI,0),"^",8) S:LRL="" LRL="??"
F M=0:0 S M=$O(^LR(LRDFN,LRSS,LRI,2,O,2,M)) Q:'M S M(1)=^(M,0) I $D(LRA(M(1))) S:'$D(^TMP($J,A,M(1))) ^(M(1))=0 S X=^(M(1)),^(M(1))=X+1 S:'$D(^TMP($J,A,M(1),LRL)) ^(LRL)=0 S X=^(LRL),^(LRL)=X+1 Q
Q
P S LRN=0 F A=0:0 S LRN=$O(^TMP($J,LRN)) Q:LRN=""!(LR("Q")) S S=^(LRN),LR=LR+S D:$Y>(IOSL-6) H Q:LR("Q") W !!,LRN(LRN,0)," (",LRN,"): ",?55,$J(S,5) D S
Q:LR("Q") D:$Y>(IOSL-10) H Q:LR("Q") W !!,"Total specimens found: ",?55,$J(LR,5) F B=0:0 S B=$O(LRA(B)) Q:'B!(LR("Q")) W !?3,$P(LRA(B),"^") S X=$P(LRA(B),"^",2) Q:'LR W ?36,$J(X,5)," (",$J(X/LR*100,4,1),"%)"
Q
S F B=0:0 S B=$O(^TMP($J,LRN,B)) Q:'B!(LR("Q")) S T=^(B) D:$Y>(IOSL-6) H1 Q:LR("Q") W !?3,$P(LRA(B),"^"),?36,$J(T,5)," (",$J(T/S*100,4,1),"%)" S $P(LRA(B),"^",2)=$P(LRA(B),"^",2)+T D:LRP L
Q
L S LRL=0 F C=0:0 S LRL=$O(^TMP($J,LRN,B,LRL)) Q:LRL=""!(LR("Q")) S L=^(LRL) D:$Y>(IOSL-6) H2 Q:LR("Q") W !?5,$E(LRL,1,23),?30,$J(L,3)
Q
ASK K A("B") W !,"Select 1 or more characters of SNOMED TOPOGRAPHY code (Choice# ",B,"): " R X:DTIME Q:X=""!(X[U)
D CK G:$D(A("B")) ASK S LRN(X)="",LRM(X)=$L(X)
C R !,"ENTER IDENTIFYING COMMENT: ",X(1):DTIME I X(1)=""!(X[U) K LRN(X),LRM(X) W $C(7),!!,"You must enter an identifying comment <ENTRY DELETED>",! G ASK
I X(1)'?1ANP.ANP!($L(X(1))<2)!($L(X(1))>30)!(X(1)["?") W $C(7),!!,"Enter free text 2-30 characters",!," (Ex. for 2 you may want to enter Respiratory System)",! G C
S LRN(X,0)=X(1) Q
;
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,LRO(68)," Counts From ",LRSTR," To ",LRLST,! W:LRP ?5,"Location",?25,"Location Count" W ?55,"Count",!,LR("%") Q
H1 D H Q:LR("Q") W !,LRN(LRN,0),?55,$J(S,5) Q
H2 D H1 Q:LR("Q") W !?3,$P(LRA(B),U),?36,$J(T,5)," (",$J(T/S*100,4,1),"%)" Q
OUT W !!,$C(7),?12,"Please have appropriate person enter missing SNOMED code",!?24,"in the MORPHOLOGY FIELD file (#61.1)" D V^LRU Q
CK I X'?1UN.UN!($L(X)>6) S A("B")=1 G SHW
S I=0 F I(1)=1:1:$L(X) I "0123456789ABCDEFXY"'[$E(X,I(1)) S A("B")=1 Q
SHW Q:'$D(A("B")) W $C(7),!!,"Enter up to 6 characters.",!,"Entry can only contain digits, letters 'X' and 'Y'.",!,"One character entered -> most general All 6 characters -> most specific",! Q
;
SET S X=0 F B=0:0 S X=$O(^LRO(69.2,LRAA,11,"B",X)) Q:X="" F C=0:0 S C=$O(^LRO(69.2,LRAA,11,"B",X,C)) Q:'C S E=$P(^LRO(69.2,LRAA,11,C,0),"^",2),LRN(X)="",LRM(X)=$L(X),LRN(X,0)=E W !,X," ",E
S:$D(LRN) B=2 Q
M F B=0:0 S B=$O(^LRO(69.2,LRAA,12,B)) Q:'B S LRA(B)=$P(^LAB(61.1,B,0),"^") W !,LRA(B)
Q
;
END D V^LRU Q
LRCYPCT ; IHS/DIR/AAB - CYTOPATH %POS,NEG,SUSP, & UNSAT 8/13/95 15:41 ; [ 07/22/2002 1:16 PM ]
+1 ;;5.2;LR;**1002,1013**;JUL 15, 2002
+2 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
+3 SET LRDICS="CY"
DO ^LRAP
IF '$DATA(Y)
GOTO END
SET IOP="HOME"
DO ^%ZIS
WRITE @IOF,!,LRO(68)," (",LRABV,") Cytology Specimens:"
+4 IF $ORDER(^LRO(69.2,LRAA,12,0))
WRITE !,"Use morphology list "
SET %=1
DO YN^LRU
IF %<1
GOTO END
IF %=1
DO M
IF $DATA(LRA)
GOTO TO
+5 FOR X=80013,69760,"09460","09010"
SET Y=$ORDER(^LAB(61.1,"C",X,0))
WRITE !?25,$SELECT(Y:"% "_$PIECE(^LAB(61.1,Y,0),"^"),1:"No entry in Morphology file for SNOMED code: "_X)
IF 'Y
GOTO OUT
SET LRA(Y)=$PIECE(^(0),"^")
TO WRITE !
KILL LRN,LRM
IF $ORDER(^LRO(69.2,LRAA,11,0))
WRITE !,"Use topography category list "
SET %=1
DO YN^LRU
IF %<1
GOTO END
IF %=1
DO SET
IF $DATA(LRN)
GOTO DATE
+1 WRITE !
FOR B=1:1
DO ASK
IF X[U!(X="")
QUIT
DATE IF B<2
GOTO END
WRITE !
DO B^LRU
IF Y<0
GOTO END
SET LRSDT=LRSDT-.01
SET LRLDT=LRLDT+.99
WRITE !!,"Include locations for each morphology "
SET %=2
DO YN^LRU
IF %<1
GOTO END
SET LRP=$SELECT(%=1:1,1:0)
+1 SET ZTRTN="QUE^LRCYPCT"
DO BEG^LRUTL
IF POP!($DATA(ZTSK))
GOTO END
QUE USE IO
KILL ^TMP($JOB)
SET LR=0
DO L^LRU
DO S^LRU
DO XR^LRU
DO H
SET LR("F")=1
+1 FOR X=0:0
SET LRSDT=$ORDER(^LR(LRXR,LRSDT))
IF 'LRSDT!(LRSDT>LRLDT)
QUIT
DO LRDFN
+2 DO P
KILL ^TMP($JOB)
DO END^LRUTL
DO END
QUIT
LRDFN FOR LRDFN=0:0
SET LRDFN=$ORDER(^LR(LRXR,LRSDT,LRDFN))
IF 'LRDFN
QUIT
DO I
+1 QUIT
I FOR LRI=0:0
SET LRI=$ORDER(^LR(LRXR,LRSDT,LRDFN,LRI))
IF 'LRI
QUIT
IF $PIECE($PIECE($GET(^LR(LRDFN,LRSS,LRI,0)),U,6)," ")=LRABV
DO T
+1 QUIT
T FOR O=0:0
SET O=$ORDER(^LR(LRDFN,LRSS,LRI,2,O))
IF 'O
QUIT
SET T=^(O,0)
DO TG
+1 QUIT
TG IF '$DATA(^LAB(61,T,0))
QUIT
SET T=$PIECE(^(0),"^",2)
SET A=0
FOR E=0:0
SET A=$ORDER(LRN(A))
IF A=""
QUIT
IF A=$EXTRACT(T,1,LRM(A))
DO G
QUIT
+1 QUIT
G IF '$DATA(^TMP($JOB,A))
SET ^(A)=0
SET X=^(A)
SET ^(A)=X+1
SET LRL=$PIECE(^LR(LRDFN,LRSS,LRI,0),"^",8)
IF LRL=""
SET LRL="??"
+1 FOR M=0:0
SET M=$ORDER(^LR(LRDFN,LRSS,LRI,2,O,2,M))
IF 'M
QUIT
SET M(1)=^(M,0)
IF $DATA(LRA(M(1)))
IF '$DATA(^TMP($JOB,A,M(1)))
SET ^(M(1))=0
SET X=^(M(1))
SET ^(M(1))=X+1
IF '$DATA(^TMP($JOB,A,M(1),LRL))
SET ^(LRL)=0
SET X=^(LRL)
SET ^(LRL)=X+1
QUIT
+2 QUIT
P SET LRN=0
FOR A=0:0
SET LRN=$ORDER(^TMP($JOB,LRN))
IF LRN=""!(LR("Q"))
QUIT
SET S=^(LRN)
SET LR=LR+S
IF $Y>(IOSL-6)
DO H
IF LR("Q")
QUIT
WRITE !!,LRN(LRN,0)," (",LRN,"): ",?55,$JUSTIFY(S,5)
DO S
+1 IF LR("Q")
QUIT
IF $Y>(IOSL-10)
DO H
IF LR("Q")
QUIT
WRITE !!,"Total specimens found: ",?55,$JUSTIFY(LR,5)
FOR B=0:0
SET B=$ORDER(LRA(B))
IF 'B!(LR("Q"))
QUIT
WRITE !?3,$PIECE(LRA(B),"^")
SET X=$PIECE(LRA(B),"^",2)
IF 'LR
QUIT
WRITE ?36,$JUSTIFY(X,5)," (",$JUSTIFY(X/LR*100,4,1),"%)"
+2 QUIT
S FOR B=0:0
SET B=$ORDER(^TMP($JOB,LRN,B))
IF 'B!(LR("Q"))
QUIT
SET T=^(B)
IF $Y>(IOSL-6)
DO H1
IF LR("Q")
QUIT
WRITE !?3,$PIECE(LRA(B),"^"),?36,$JUSTIFY(T,5)," (",$JUSTIFY(T/S*100,4,1),"%)"
SET $PIECE(LRA(B),"^",2)=$PIECE(LRA(B),"^",2)+T
IF LRP
DO L
+1 QUIT
L SET LRL=0
FOR C=0:0
SET LRL=$ORDER(^TMP($JOB,LRN,B,LRL))
IF LRL=""!(LR("Q"))
QUIT
SET L=^(LRL)
IF $Y>(IOSL-6)
DO H2
IF LR("Q")
QUIT
WRITE !?5,$EXTRACT(LRL,1,23),?30,$JUSTIFY(L,3)
+1 QUIT
ASK KILL A("B")
WRITE !,"Select 1 or more characters of SNOMED TOPOGRAPHY code (Choice# ",B,"): "
READ X:DTIME
IF X=""!(X[U)
QUIT
+1 DO CK
IF $DATA(A("B"))
GOTO ASK
SET LRN(X)=""
SET LRM(X)=$LENGTH(X)
C READ !,"ENTER IDENTIFYING COMMENT: ",X(1):DTIME
IF X(1)=""!(X[U)
KILL LRN(X),LRM(X)
WRITE $CHAR(7),!!,"You must enter an identifying comment <ENTRY DELETED>",!
GOTO ASK
+1 IF X(1)'?1ANP.ANP!($LENGTH(X(1))<2)!($LENGTH(X(1))>30)!(X(1)["?")
WRITE $CHAR(7),!!,"Enter free text 2-30 characters",!," (Ex. for 2 you may want to enter Respiratory System)",!
GOTO C
+2 SET LRN(X,0)=X(1)
QUIT
+3 ;
H IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
IF LR("Q")
QUIT
+1 DO F^LRU
WRITE !,LRO(68)," Counts From ",LRSTR," To ",LRLST,!
IF LRP
WRITE ?5,"Location",?25,"Location Count"
WRITE ?55,"Count",!,LR("%")
QUIT
H1 DO H
IF LR("Q")
QUIT
WRITE !,LRN(LRN,0),?55,$JUSTIFY(S,5)
QUIT
H2 DO H1
IF LR("Q")
QUIT
WRITE !?3,$PIECE(LRA(B),U),?36,$JUSTIFY(T,5)," (",$JUSTIFY(T/S*100,4,1),"%)"
QUIT
OUT WRITE !!,$CHAR(7),?12,"Please have appropriate person enter missing SNOMED code",!?24,"in the MORPHOLOGY FIELD file (#61.1)"
DO V^LRU
QUIT
CK IF X'?1UN.UN!($LENGTH(X)>6)
SET A("B")=1
GOTO SHW
+1 SET I=0
FOR I(1)=1:1:$LENGTH(X)
IF "0123456789ABCDEFXY"'[$EXTRACT(X,I(1))
SET A("B")=1
QUIT
SHW IF '$DATA(A("B"))
QUIT
WRITE $CHAR(7),!!,"Enter up to 6 characters.",!,"Entry can only contain digits, letters 'X' and 'Y'.",!,"One character entered -> most general All 6 characters -> most specific",!
QUIT
+1 ;
SET SET X=0
FOR B=0:0
SET X=$ORDER(^LRO(69.2,LRAA,11,"B",X))
IF X=""
QUIT
FOR C=0:0
SET C=$ORDER(^LRO(69.2,LRAA,11,"B",X,C))
IF 'C
QUIT
SET E=$PIECE(^LRO(69.2,LRAA,11,C,0),"^",2)
SET LRN(X)=""
SET LRM(X)=$LENGTH(X)
SET LRN(X,0)=E
WRITE !,X," ",E
+1 IF $DATA(LRN)
SET B=2
QUIT
M FOR B=0:0
SET B=$ORDER(^LRO(69.2,LRAA,12,B))
IF 'B
QUIT
SET LRA(B)=$PIECE(^LAB(61.1,B,0),"^")
WRITE !,LRA(B)
+1 QUIT
+2 ;
END DO V^LRU
QUIT
