LRAPSEM ;AVAMC/REG - MULTIAXIAL SNOMED SEARCH ;8/15/95 09:53 ;
;;5.2;LAB SERVICE;**72**;Sep 27, 1994
S IOP="HOME" D ^%ZIS W @IOF,!?10,LRO(68)," multiaxial SNOMED search"
I LRSS="AU" W $C(7),!!?26,"Not yet available" Q
S (LR,LRD,LRD(0),LRD(1),LR(1),LR(2),LR(3))=0
TP K A("B") W !!,"TOPOGRAPHY (Organ/Tissue)",!?5,"Select 1 or more characters of the code",!?5 R "For all sites type 'ALL' : ",X:DTIME Q:X=""!(X["^") I X["ALL" S S(2)="ALL"
E D CK^LRAUSM G:$D(A("B")) TP S S(2)=X,S(1)=$L(X)
K LRN,LRM S LRO=""
F LRX="2^MORPHOLOGY","4^PROCEDURE","1^DISEASE","3^FUNCTION" Q:X["^" W !!,$P(LRX,U,2) D:+LRX=4 POS^LRAPSM W !?5,"For all choices type 'ALL'" F B=1:1 D ASK Q:X["^"!(X="") Q:LRN(+LRX,X)="ALL"!("^")
Q:'$D(LRN) S:'$D(LRO) LRO="" W ! D B^LRU Q:Y<0 S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99
W !!,"List by accession number with specimens and microscopic dx " S %=2 D YN^LRU Q:%<1 I %=1 S (LRD(0),LRD(1))=1
D S
C R !!,"Enter SEARCH COMMENT: ",X:DTIME Q:X["^" I X["?" D R G C
I X]"",$L(X)<2!($L(X)>68)!(X'?.ANP) D R G C
W ! S LRH=X,ZTRTN="QUE^LRAPSEM" D BEG^LRUTL Q:POP!($D(ZTSK))
QUE U IO S (LR(2),LRB)=0 K ^TMP("LR",$J),^TMP($J) D EN^LRUA,L^LRU,XR^LRU F X=1:1:4 S LRSN(X)=$S(X=1:"61.4^D",X=2:"61.1^M",X=3:"61.3^F",X=4:"61.5^P",1:"")
F LRX=0:0 S LRSDT=$O(^LR(LRXR,LRSDT)) Q:'LRSDT!(LRSDT>LRLDT) D LRDFN
END D ^LRAPSEM1,END^LRUTL Q
Y I $E(X,1,Y(1))=Y(2) S LRF=1 Q
Y1 S LRF=1 F I(1)=1:1:Y(1) S I(2)=$E(Y(2),I(1)) I I(2)'="*",I(2)'=$E(X,I(1)) S LRF=0 Q
Q
LRDFN F LRDFN=0:0 S LRDFN=$O(^LR(LRXR,LRSDT,LRDFN)) Q:'LRDFN S LR(2)=LR(2)+1 D I
Q
I F LRI=0:0 S LRI=$O(^LR(LRXR,LRSDT,LRDFN,LRI)) Q:'LRI D T
Q
T Q:$P($P($G(^LR(LRDFN,LRSS,LRI,0)),U,6)," ")'=LRABV S LR(4)=^(0),LR(12)=$P(LR(4),"^",10),LRY=$E(LR(12),1,3),LRAC=$P(LR(4),"^",6),LRAN=+$P(LRAC," ",3),LR(3)=LR(3)+1
S T=0 F LR(9)=0:1 S T=$O(^LR(LRDFN,LRSS,LRI,2,T)) Q:'T S LRT=+^(T,0) D TG
S LR=LR+LR(9) Q ;Number of organ/tissues searched
TG Q:'$D(^LAB(61,LRT,0)) S X=^(0),LR(5)=$P(X,"^"),X=$P(X,"^",2) I S(2)'="ALL",$E(X,1,S(1))'=S(2) Q:S(2)'["*" S Y(1)=S(1),Y(2)=S(2) D Y1 Q:'LRF
S LRF=0,LR(1)=LR(1)+1 ;Total organ/tissue found
F V=2,4,1,3 I $D(LRN(V)) D M Q:'LRF
D:LRF PRT Q
M I $D(LRN(V,"Z")) S X=$O(^LR(LRDFN,LRSS,LRI,2,T,V,0)) S LRF=$S(X:1,1:0) D:LRF&(V=4)&(LRO]"") PR Q:V'=2 Q:'LRF D:$D(LRN(2,"Z","Z")) O Q
S LRF=0 F M=0:0 S M=$O(^LR(LRDFN,LRSS,LRI,2,T,V,M)) Q:'M S X=^(M,0),LR(8)=+X,LRM=$P(X,"^",2) D N Q:LRF
Q
N Q:'$D(^LAB(+LRSN(V),LR(8),0)) S W=$P(^(0),"^",2) I LRO]"",V=4,LRO'=LRM Q
S A=-1 F F=0:0 S A=$O(LRN(V,A)) Q:A=""!(A="Z") S X=W,Y(2)=A,Y(1)=LRN(V,A) D Y Q:LRF&(V'=2) D:LRF E Q:LRF
Q
E Q:$O(LRN(2,A,-1))="" I $D(LRN(2,A,"Z")) S X=M D O Q
S LRF=0 F E=0:0 S E=$O(^LR(LRDFN,LRSS,LRI,2,T,V,M,1,E)) Q:'E!(LRF) S LR(8)=+^(E,0) I $D(^LAB(61.2,LR(8),0)) S W=$P(^(0),"^",2) S B=-1 F G=0:0 S B=$O(LRN(V,A,B)) Q:B=""!(B="Z") S X=W,Y(2)=B,Y(1)=LRN(V,A,B) D Y Q:LRF
Q
O S LRF=0 F Y=0:0 S Y=$O(^LR(LRDFN,LRSS,LRI,2,T,2,X,1,Y)) Q:'Y I Y S LRF=1 Q
Q
PRT S X=^LR(LRDFN,0),(LRDPF,LRA)=$P(X,"^",2),Y=$P(X,"^",3),X=^DIC(LRA,0,"GL") Q:'$D(@(X_Y_",0)"))
S X=@(X_Y_",0)"),LRP=$P(X,"^"),SSN=$P(X,"^",9),SEX=$P(X,"^",2),DOB=$P(X,"^",3),X1=$P(LR(4),"^"),X2=DOB D ^%DTC,SSN^LRU S AGE=X\365.25
S ^TMP("LR",$J,LRY,LRAN)=LRAC_"^"_AGE_"^"_SEX_"^"_LRP_"^"_SSN_"^"_+$E(LR(12),4,5)_"/"_$E(LR(12),6,7)_"^"_LRA_"^"_LRDFN_"^"_LRI
S ^TMP("LR",$J,"B",LRP,LRY,LRAN)="" Q
PR S LRF=0 F X=0:0 S X=$O(^LR(LRDFN,LRSS,LRI,2,T,4,X)) Q:'X I $P(^(X,0),"^",2)=LRO S LRF=1 Q
Q
ASK K A("B") W !,$P(LRX,"^",2),?12,"choice #",$J(B,2),": Select 1 or more characters of the code: " R X:DTIME Q:X=""!(X["^") I X["ALL" S X="Z",LRN(+LRX,"Z")="ALL" D:+LRX=2 ET S:+LRX=2 X=LRE Q
D CK^LRAUSM G:$D(A("B")) ASK S LRN(+LRX,X)=$L(X) D:+LRX=2 ET S:+LRX=2 X=LRE Q
ET S LRE=X
W !?5,"ETIOLOGY (for all choices type 'ALL')" F A=1:1 D AE Q:X["^"!(X="") Q:LRN(2,LRE,X)="ALL"
Q
AE K A("B") W !?15,"Choice #",$J(A,2),": Select 1 or more characters of the code: " R X:DTIME Q:X=""!(X["^") I X["ALL" S X="Z",LRN(2,LRE,"Z")="ALL" Q
D CK^LRAUSM G:$D(A("B")) AE S LRN(2,LRE,X)=$L(X) Q
R W !,"Enter 2-68 character free text comment to appear at top of each page of search." Q
S W !!,"List special studies " S %=2 D YN^LRU S:%=1 LRD=1
S LRD(2)=0 Q:'LRD(0) W !!,"Include SNOMED CODES on report " S %=2 D YN^LRU S:%=1 LRD(2)=1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPSEM 4325 printed Oct 16, 2024@18:09:03 Page 2
LRAPSEM ;AVAMC/REG - MULTIAXIAL SNOMED SEARCH ;8/15/95 09:53 ;
+1 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
+2 SET IOP="HOME"
DO ^%ZIS
WRITE @IOF,!?10,LRO(68)," multiaxial SNOMED search"
+3 IF LRSS="AU"
WRITE $CHAR(7),!!?26,"Not yet available"
QUIT
+4 SET (LR,LRD,LRD(0),LRD(1),LR(1),LR(2),LR(3))=0
TP KILL A("B")
WRITE !!,"TOPOGRAPHY (Organ/Tissue)",!?5,"Select 1 or more characters of the code",!?5
READ "For all sites type 'ALL' : ",X:DTIME
if X=""!(X["^")
QUIT
IF X["ALL"
SET S(2)="ALL"
+1 IF '$TEST
DO CK^LRAUSM
if $DATA(A("B"))
GOTO TP
SET S(2)=X
SET S(1)=$LENGTH(X)
+2 KILL LRN,LRM
SET LRO=""
+3 FOR LRX="2^MORPHOLOGY","4^PROCEDURE","1^DISEASE","3^FUNCTION"
if X["^"
QUIT
WRITE !!,$PIECE(LRX,U,2)
if +LRX=4
DO POS^LRAPSM
WRITE !?5,"For all choices type 'ALL'"
FOR B=1:1
DO ASK
if X["^"!(X="")
QUIT
if LRN(+LRX,X)="ALL"!("^")
QUIT
+4 if '$DATA(LRN)
QUIT
if '$DATA(LRO)
SET LRO=""
WRITE !
DO B^LRU
if Y<0
QUIT
SET LRSDT=LRSDT-.01
SET LRLDT=LRLDT+.99
+5 WRITE !!,"List by accession number with specimens and microscopic dx "
SET %=2
DO YN^LRU
if %<1
QUIT
IF %=1
SET (LRD(0),LRD(1))=1
+6 DO S
C READ !!,"Enter SEARCH COMMENT: ",X:DTIME
if X["^"
QUIT
IF X["?"
DO R
GOTO C
+1 IF X]""
IF $LENGTH(X)<2!($LENGTH(X)>68)!(X'?.ANP)
DO R
GOTO C
+2 WRITE !
SET LRH=X
SET ZTRTN="QUE^LRAPSEM"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
QUIT
QUE USE IO
SET (LR(2),LRB)=0
KILL ^TMP("LR",$JOB),^TMP($JOB)
DO EN^LRUA
DO L^LRU
DO XR^LRU
FOR X=1:1:4
SET LRSN(X)=$SELECT(X=1:"61.4^D",X=2:"61.1^M",X=3:"61.3^F",X=4:"61.5^P",1:"")
+1 FOR LRX=0:0
SET LRSDT=$ORDER(^LR(LRXR,LRSDT))
if 'LRSDT!(LRSDT>LRLDT)
QUIT
DO LRDFN
END DO ^LRAPSEM1
DO END^LRUTL
QUIT
Y IF $EXTRACT(X,1,Y(1))=Y(2)
SET LRF=1
QUIT
Y1 SET LRF=1
FOR I(1)=1:1:Y(1)
SET I(2)=$EXTRACT(Y(2),I(1))
IF I(2)'="*"
IF I(2)'=$EXTRACT(X,I(1))
SET LRF=0
QUIT
+1 QUIT
LRDFN FOR LRDFN=0:0
SET LRDFN=$ORDER(^LR(LRXR,LRSDT,LRDFN))
if 'LRDFN
QUIT
SET LR(2)=LR(2)+1
DO I
+1 QUIT
I FOR LRI=0:0
SET LRI=$ORDER(^LR(LRXR,LRSDT,LRDFN,LRI))
if 'LRI
QUIT
DO T
+1 QUIT
T if $PIECE($PIECE($GET(^LR(LRDFN,LRSS,LRI,0)),U,6)," ")'=LRABV
QUIT
SET LR(4)=^(0)
SET LR(12)=$PIECE(LR(4),"^",10)
SET LRY=$EXTRACT(LR(12),1,3)
SET LRAC=$PIECE(LR(4),"^",6)
SET LRAN=+$PIECE(LRAC," ",3)
SET LR(3)=LR(3)+1
+1 SET T=0
FOR LR(9)=0:1
SET T=$ORDER(^LR(LRDFN,LRSS,LRI,2,T))
if 'T
QUIT
SET LRT=+^(T,0)
DO TG
+2 ;Number of organ/tissues searched
SET LR=LR+LR(9)
QUIT
TG if '$DATA(^LAB(61,LRT,0))
QUIT
SET X=^(0)
SET LR(5)=$PIECE(X,"^")
SET X=$PIECE(X,"^",2)
IF S(2)'="ALL"
IF $EXTRACT(X,1,S(1))'=S(2)
if S(2)'["*"
QUIT
SET Y(1)=S(1)
SET Y(2)=S(2)
DO Y1
if 'LRF
QUIT
+1 ;Total organ/tissue found
SET LRF=0
SET LR(1)=LR(1)+1
+2 FOR V=2,4,1,3
IF $DATA(LRN(V))
DO M
if 'LRF
QUIT
+3 if LRF
DO PRT
QUIT
M IF $DATA(LRN(V,"Z"))
SET X=$ORDER(^LR(LRDFN,LRSS,LRI,2,T,V,0))
SET LRF=$SELECT(X:1,1:0)
if LRF&(V=4)&(LRO]"")
DO PR
if V'=2
QUIT
if 'LRF
QUIT
if $DATA(LRN(2,"Z","Z"))
DO O
QUIT
+1 SET LRF=0
FOR M=0:0
SET M=$ORDER(^LR(LRDFN,LRSS,LRI,2,T,V,M))
if 'M
QUIT
SET X=^(M,0)
SET LR(8)=+X
SET LRM=$PIECE(X,"^",2)
DO N
if LRF
QUIT
+2 QUIT
N if '$DATA(^LAB(+LRSN(V),LR(8),0))
QUIT
SET W=$PIECE(^(0),"^",2)
IF LRO]""
IF V=4
IF LRO'=LRM
QUIT
+1 SET A=-1
FOR F=0:0
SET A=$ORDER(LRN(V,A))
if A=""!(A="Z")
QUIT
SET X=W
SET Y(2)=A
SET Y(1)=LRN(V,A)
DO Y
if LRF&(V'=2)
QUIT
if LRF
DO E
if LRF
QUIT
+2 QUIT
E if $ORDER(LRN(2,A,-1))=""
QUIT
IF $DATA(LRN(2,A,"Z"))
SET X=M
DO O
QUIT
+1 SET LRF=0
FOR E=0:0
SET E=$ORDER(^LR(LRDFN,LRSS,LRI,2,T,V,M,1,E))
if 'E!(LRF)
QUIT
SET LR(8)=+^(E,0)
IF $DATA(^LAB(61.2,LR(8),0))
SET W=$PIECE(^(0),"^",2)
SET B=-1
FOR G=0:0
SET B=$ORDER(LRN(V,A,B))
if B=""!(B="Z")
QUIT
SET X=W
SET Y(2)=B
SET Y(1)=LRN(V,A,B)
DO Y
if LRF
QUIT
+2 QUIT
O SET LRF=0
FOR Y=0:0
SET Y=$ORDER(^LR(LRDFN,LRSS,LRI,2,T,2,X,1,Y))
if 'Y
QUIT
IF Y
SET LRF=1
QUIT
+1 QUIT
PRT SET X=^LR(LRDFN,0)
SET (LRDPF,LRA)=$PIECE(X,"^",2)
SET Y=$PIECE(X,"^",3)
SET X=^DIC(LRA,0,"GL")
if '$DATA(@(X_Y_",0)"))
QUIT
+1 SET X=@(X_Y_",0)")
SET LRP=$PIECE(X,"^")
SET SSN=$PIECE(X,"^",9)
SET SEX=$PIECE(X,"^",2)
SET DOB=$PIECE(X,"^",3)
SET X1=$PIECE(LR(4),"^")
SET X2=DOB
DO ^%DTC
DO SSN^LRU
SET AGE=X\365.25
+2 SET ^TMP("LR",$JOB,LRY,LRAN)=LRAC_"^"_AGE_"^"_SEX_"^"_LRP_"^"_SSN_"^"_+$EXTRACT(LR(12),4,5)_"/"_$EXTRACT(LR(12),6,7)_"^"_LRA_"^"_LRDFN_"^"_LRI
+3 SET ^TMP("LR",$JOB,"B",LRP,LRY,LRAN)=""
QUIT
PR SET LRF=0
FOR X=0:0
SET X=$ORDER(^LR(LRDFN,LRSS,LRI,2,T,4,X))
if 'X
QUIT
IF $PIECE(^(X,0),"^",2)=LRO
SET LRF=1
QUIT
+1 QUIT
ASK KILL A("B")
WRITE !,$PIECE(LRX,"^",2),?12,"choice #",$JUSTIFY(B,2),": Select 1 or more characters of the code: "
READ X:DTIME
if X=""!(X["^")
QUIT
IF X["ALL"
SET X="Z"
SET LRN(+LRX,"Z")="ALL"
if +LRX=2
DO ET
if +LRX=2
SET X=LRE
QUIT
+1 DO CK^LRAUSM
if $DATA(A("B"))
GOTO ASK
SET LRN(+LRX,X)=$LENGTH(X)
if +LRX=2
DO ET
if +LRX=2
SET X=LRE
QUIT
ET SET LRE=X
+1 WRITE !?5,"ETIOLOGY (for all choices type 'ALL')"
FOR A=1:1
DO AE
if X["^"!(X="")
QUIT
if LRN(2,LRE,X)="ALL"
QUIT
+2 QUIT
AE KILL A("B")
WRITE !?15,"Choice #",$JUSTIFY(A,2),": Select 1 or more characters of the code: "
READ X:DTIME
if X=""!(X["^")
QUIT
IF X["ALL"
SET X="Z"
SET LRN(2,LRE,"Z")="ALL"
QUIT
+1 DO CK^LRAUSM
if $DATA(A("B"))
GOTO AE
SET LRN(2,LRE,X)=$LENGTH(X)
QUIT
R WRITE !,"Enter 2-68 character free text comment to appear at top of each page of search."
QUIT
S WRITE !!,"List special studies "
SET %=2
DO YN^LRU
if %=1
SET LRD=1
+1 SET LRD(2)=0
if 'LRD(0)
QUIT
WRITE !!,"Include SNOMED CODES on report "
SET %=2
DO YN^LRU
if %=1
SET LRD(2)=1
QUIT
