- LRAPSM ;VA/AVAMC/REG - SNOMED SEARCH ;8/14/95 09:49
- ;;5.2;LAB SERVICE;**1002,1027,1031**;NOV 1, 1997
- ;
- ;;VA LR Patche(s): 72,253,355,362
- ;
- S IOP="HOME" D ^%ZIS W @IOF,!?20,LRO(68)," search by ",S(7)," code"
- S (LR,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[U) 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,LRN)="" W !!,S(7) I LRSN=61.5 D POS Q:'$D(LRO)
- W !?5,"For all choices type 'ALL'" F B=1:1 D ASK Q:X[U!(X="")!(LRN="ALL")
- Q:B<2&(LRN="") S:LRN=""&(B=2) LRN=$O(LRN(0)) W ! D B^LRU Q:Y<0 S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99
- S ZTRTN="QUE^LRAPSM" D BEG^LRUTL Q:POP!($D(ZTSK))
- QUE U IO K ^TMP($J) D L^LRU,S^LRU,XR^LRU
- S ^TMP($J,0)=S(2)_U_LRN_U_LRO(68)_U_S(7)
- F X=0:0 S LRSDT=$O(^LR(LRXR,LRSDT)) Q:'LRSDT!(LRSDT>LRLDT) D LRDFN
- END D ^LRAPSM1,END^LRUTL,V^LRU Q
- Y I $E(X,1,Y(1))=Y(2) S I=1 Q
- Y1 S I=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 I=0 Q
- Q
- LRDFN S LRDFN=0 F 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)=^LR(LRDFN,LRSS,LRI,0),LR(12)=$P(LR(4),"^",10)
- S H(2)=$E(LR(12),1,3),LRAC=$P(LR(4),"^",6),LRAN=+$P(LRAC," ",3)
- S 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 LR(7)=+^(T,0) D TG
- S LR=LR+LR(9) Q ;Number of organ/tissues
- TG Q:'$D(^LAB(61,LR(7),0)) S LR(11)=^(0),LR(5)=$P(LR(11),"^"),LR(11)=$P(LR(11),"^",2) I S(2)'="ALL",$E(LR(11),1,S(1))'=S(2) Q:S(2)'["*" S Y(1)=S(1),X=LR(11),Y(2)=S(2) D Y1 Q:'I
- S LR(1)=LR(1)+1 D M Q ;Total of the organ/tissue searched for
- M 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 @($S(LRSN'=61.2:"MX",1:"E"))
- Q
- E F E=0:0 S E=$O(^LR(LRDFN,LRSS,LRI,2,T,V,M,1,E)) Q:'E S LR(8)=+^(E,0) D MX
- Q
- MX Q:'$D(^LAB(LRSN,LR(8),0)) S W=^(0) I $D(LRO),LRO]"",LRO'=LRM Q
- I LRN="ALL" S:'$D(^TMP($J,H(2),LRAN,LR(7),0)) ^(0)=LR(5) S ^($S($P(W,"^",2)'="":$P(W,"^",2),1:"99999999"))=$P(W,"^")_"^"_LRM G PRT
- S X=$P(W,"^",2),Y=0 F Z=1:1 S Y=$O(LRN(Y)) Q:Y="" S Y(1)=LRM(Y),Y(2)=LRN(Y) D Y I I S:'$D(^TMP($J,H(2),LRAN,LR(7),0)) ^(0)=LR(5) S ^(X)=$P(W,"^")_"^"_LRM
- Q:'$D(^TMP($J,H(2),LRAN))
- PRT S X=^LR(LRDFN,0),(LRDPF,LR(14))=$P(X,"^",2),LRPF=^DIC(LR(14),0,"GL"),DFN=$P(X,"^",3) Q:'$D(@(LRPF_DFN_",0)"))
- S X=@(LRPF_DFN_",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:AGE>130 AGE="?"
- ; S ^TMP($J,H(2),LRAN)=LRAC_"^"_AGE_"^"_SEX_"^"_LRP_"^"_SSN(1)_"^"_+$E(LR(12),4,5)_"/"_$E(LR(12),6,7)_"^"_LR(14)
- S ^TMP($J,H(2),LRAN)=LRAC_"^"_AGE_"^"_SEX_"^"_LRP_"^"_HRCN_"^"_+$E(LR(12),4,5)_"/"_$E(LR(12),6,7)_"^"_LR(14) ; IHS/OIT/MKK - LR*5.2*1027
- S ^TMP($J,"B",LRP,H(2),LRAN)=""
- 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) I X["ALL" S LRN="ALL" Q
- D CK^LRAUSM G:$D(A("B")) ASK S LRN(X)=X,LRM(X)=$L(X) Q
- POS ;also from LRAPSEM
- W !,"Select only procedures with results " S %=2 D YN^LRU I %<1 K LRO Q
- I %=2 S LRO="" Q
- C W !,"Enter 1 for positive results or 0 for negative results: " R X:DTIME Q:X=""!(X[U) I X'=1,X'=0 W $C(7)," Enter '1' or '0'" G C
- S LRO=X Q
- LRAPSM ;VA/AVAMC/REG - SNOMED SEARCH ;8/14/95 09:49
- +1 ;;5.2;LAB SERVICE;**1002,1027,1031**;NOV 1, 1997
- +2 ;
- +3 ;;VA LR Patche(s): 72,253,355,362
- +4 ;
- +5 SET IOP="HOME"
- DO ^%ZIS
- WRITE @IOF,!?20,LRO(68)," search by ",S(7)," code"
- +6 SET (LR,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[U)
- 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,LRN)=""
- WRITE !!,S(7)
- IF LRSN=61.5
- DO POS
- IF '$DATA(LRO)
- QUIT
- +3 WRITE !?5,"For all choices type 'ALL'"
- FOR B=1:1
- DO ASK
- IF X[U!(X="")!(LRN="ALL")
- QUIT
- +4 IF B<2&(LRN="")
- QUIT
- IF LRN=""&(B=2)
- SET LRN=$ORDER(LRN(0))
- WRITE !
- DO B^LRU
- IF Y<0
- QUIT
- SET LRSDT=LRSDT-.01
- SET LRLDT=LRLDT+.99
- +5 SET ZTRTN="QUE^LRAPSM"
- DO BEG^LRUTL
- IF POP!($DATA(ZTSK))
- QUIT
- QUE USE IO
- KILL ^TMP($JOB)
- DO L^LRU
- DO S^LRU
- DO XR^LRU
- +1 SET ^TMP($JOB,0)=S(2)_U_LRN_U_LRO(68)_U_S(7)
- +2 FOR X=0:0
- SET LRSDT=$ORDER(^LR(LRXR,LRSDT))
- IF 'LRSDT!(LRSDT>LRLDT)
- QUIT
- DO LRDFN
- END DO ^LRAPSM1
- DO END^LRUTL
- DO V^LRU
- QUIT
- Y IF $EXTRACT(X,1,Y(1))=Y(2)
- SET I=1
- QUIT
- Y1 SET I=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 I=0
- QUIT
- +1 QUIT
- LRDFN SET LRDFN=0
- FOR
- 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
- +1 SET LR(4)=^LR(LRDFN,LRSS,LRI,0)
- SET LR(12)=$PIECE(LR(4),"^",10)
- +2 SET H(2)=$EXTRACT(LR(12),1,3)
- SET LRAC=$PIECE(LR(4),"^",6)
- SET LRAN=+$PIECE(LRAC," ",3)
- +3 SET LR(3)=LR(3)+1
- +4 SET T=0
- FOR LR(9)=0:1
- SET T=$ORDER(^LR(LRDFN,LRSS,LRI,2,T))
- IF 'T
- QUIT
- SET LR(7)=+^(T,0)
- DO TG
- +5 ;Number of organ/tissues
- SET LR=LR+LR(9)
- QUIT
- TG IF '$DATA(^LAB(61,LR(7),0))
- QUIT
- SET LR(11)=^(0)
- SET LR(5)=$PIECE(LR(11),"^")
- SET LR(11)=$PIECE(LR(11),"^",2)
- IF S(2)'="ALL"
- IF $EXTRACT(LR(11),1,S(1))'=S(2)
- IF S(2)'["*"
- QUIT
- SET Y(1)=S(1)
- SET X=LR(11)
- SET Y(2)=S(2)
- DO Y1
- IF 'I
- QUIT
- +1 ;Total of the organ/tissue searched for
- SET LR(1)=LR(1)+1
- DO M
- QUIT
- M 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 @($SELECT(LRSN'=61.2:"MX",1:"E"))
- +1 QUIT
- E FOR E=0:0
- SET E=$ORDER(^LR(LRDFN,LRSS,LRI,2,T,V,M,1,E))
- IF 'E
- QUIT
- SET LR(8)=+^(E,0)
- DO MX
- +1 QUIT
- MX IF '$DATA(^LAB(LRSN,LR(8),0))
- QUIT
- SET W=^(0)
- IF $DATA(LRO)
- IF LRO]""
- IF LRO'=LRM
- QUIT
- +1 IF LRN="ALL"
- IF '$DATA(^TMP($JOB,H(2),LRAN,LR(7),0))
- SET ^(0)=LR(5)
- SET ^($SELECT($PIECE(W,"^",2)'="":$PIECE(W,"^",2),1:"99999999"))=$PIECE(W,"^")_"^"_LRM
- GOTO PRT
- +2 SET X=$PIECE(W,"^",2)
- SET Y=0
- FOR Z=1:1
- SET Y=$ORDER(LRN(Y))
- IF Y=""
- QUIT
- SET Y(1)=LRM(Y)
- SET Y(2)=LRN(Y)
- DO Y
- IF I
- IF '$DATA(^TMP($JOB,H(2),LRAN,LR(7),0))
- SET ^(0)=LR(5)
- SET ^(X)=$PIECE(W,"^")_"^"_LRM
- +3 IF '$DATA(^TMP($JOB,H(2),LRAN))
- QUIT
- PRT SET X=^LR(LRDFN,0)
- SET (LRDPF,LR(14))=$PIECE(X,"^",2)
- SET LRPF=^DIC(LR(14),0,"GL")
- SET DFN=$PIECE(X,"^",3)
- IF '$DATA(@(LRPF_DFN_",0)"))
- QUIT
- +1 SET X=@(LRPF_DFN_",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 IF AGE>130
- SET AGE="?"
- +3 ; S ^TMP($J,H(2),LRAN)=LRAC_"^"_AGE_"^"_SEX_"^"_LRP_"^"_SSN(1)_"^"_+$E(LR(12),4,5)_"/"_$E(LR(12),6,7)_"^"_LR(14)
- +4 ; IHS/OIT/MKK - LR*5.2*1027
- SET ^TMP($JOB,H(2),LRAN)=LRAC_"^"_AGE_"^"_SEX_"^"_LRP_"^"_HRCN_"^"_+$EXTRACT(LR(12),4,5)_"/"_$EXTRACT(LR(12),6,7)_"^"_LR(14)
- +5 SET ^TMP($JOB,"B",LRP,H(2),LRAN)=""
- +6 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
- IF X["ALL"
- SET LRN="ALL"
- QUIT
- +1 DO CK^LRAUSM
- IF $DATA(A("B"))
- GOTO ASK
- SET LRN(X)=X
- SET LRM(X)=$LENGTH(X)
- QUIT
- POS ;also from LRAPSEM
- +1 WRITE !,"Select only procedures with results "
- SET %=2
- DO YN^LRU
- IF %<1
- KILL LRO
- QUIT
- +2 IF %=2
- SET LRO=""
- QUIT
- C WRITE !,"Enter 1 for positive results or 0 for negative results: "
- READ X:DTIME
- IF X=""!(X[U)
- QUIT
- IF X'=1
- IF X'=0
- WRITE $CHAR(7)," Enter '1' or '0'"
- GOTO C
- +1 SET LRO=X
- QUIT
