LRAPSEM1 ; IHS/DIR/AAB - SEARCH BY SNOMED CODE PRINT 8/15/95 10:51 ;
;;5.2;LR;**1002**;JUN 01, 1998
;;5.2;LAB SERVICE;**72**;Sep 27, 1994
S LRP=0,LRJ(1)=$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"") D S^LRU I LRD(1) D ^LRAPSEM2,F Q
D H1 S LR("F")=1
F LRB=0:1 S LRP=$O(^TMP("LR",$J,"B",LRP)) Q:LRP=""!(LR("Q")) S X=$O(^(LRP,0)),Y=$O(^(X,0)),LRW=^TMP("LR",$J,X,Y) D:$Y>(IOSL-6) H1 Q:LR("Q") W ! W:$P(LRW,"^",7)'=2 "#" W LRP,?32,$P(LRW,"^",5),?46,$P(LRW,"^",3) D Y
Q:LR("Q") S LRY=1 D H2 Q:LR("Q") D L,F Q
;
Y S LRY=0 F B=0:0 S LRY=$O(^TMP("LR",$J,"B",LRP,LRY)) Q:'LRY!(LR("Q")) D A
Q:LR("Q") W !,LR("%") Q
A S (LRC,LRAN)=0 F S LRAN=$O(^TMP("LR",$J,"B",LRP,LRY,LRAN)) Q:'LRAN!(LR("Q")) S LRC=LRC+1 W:LRC>1 ! D P
Q
P S LRW=^TMP("LR",$J,LRY,LRAN),LRW(2)=$P(LRW,"^",2),LRW(1)=$P(LRW,"^")
S LRDFN=$P(LRW,"^",8),LRI=$P(LRW,"^",9),LRT=0 F LRG=0:1 S LRT=$O(^LR(LRDFN,LRSS,LRI,2,LRT)) Q:'LRT!(LR("Q")) S LRT(1)=$P(^LAB(61,+^(LRT,0),0),"^") D S
Q
S D:$Y>(IOSL-6) H3 Q:LR("Q") W !?5,LRT(1) W:'LRG ?50,LRW(2),?58,$J(LRW(1),7) F V=2,4,1,3 I $D(LRN(V)) D T
Q
T F LRM=0:0 S LRM=$O(^LR(LRDFN,LRSS,LRI,2,LRT,V,LRM)) Q:'LRM!(LR("Q")) S X=^(LRM,0),LRX=+X,LRX(1)=$P(X,"^",2) D U
I LRD F LRM=0:0 S LRM=$O(^LR(LRDFN,LRSS,LRI,2,LRT,5,LRM)) Q:'LRM!(LR("Q")) S LRX=^(LRM,0) D:$Y>(IOSL-6) H4 Q:LR("Q") D G
Q
G S X=LRX,Y=$P(X,"^",2),W=$P(X,"^",3),Z=$P(X,"^")_":",Z=$P($P(LR(LRSS),Z,2),";") D D^LRU W !?10,Z," ",W," Date: ",Y Q
Q
U Q:'$D(^LAB(+LRSN(V),LRX,0)) S LRM(1)=$P(^(0),"^") D:$Y>(IOSL-6) H4 Q:LR("Q") W !?10,LRM(1) W:LRX(1)]"" " (",$S(LRX(1)=1:"Positive",LRX(1)=0:"Negative",1:"?"),")" D:V=2 E
Q
E F LRE=0:0 S LRE=$O(^LR(LRDFN,LRSS,LRI,2,LRT,2,LRM,1,LRE)) Q:'LRE!(LR("Q")) S LRX=+^(LRE,0) I $D(^LAB(61.2,LRX,0)) S LRX=$P(^(0),"^") D:$Y>(IOSL-6) H5 Q:LR("Q") W !?15,LRX
Q
L F B=0:1 S LRY=$O(^TMP("LR",$J,LRY)) Q:'LRY!(LR("Q")) D W
Q
W S LRAN=0 F C=0:1 S LRAN=$O(^TMP("LR",$J,LRY,LRAN)) Q:'LRAN!(LR("Q")) D B
Q
B D:$Y>(IOSL-6) H2 Q:LR("Q")
S LRW=^TMP("LR",$J,LRY,LRAN) W !,$P(LRW,U),?12 W:$P(LRW,"^",7)'=2 "#" W $P(LRW,"^",4),?40,$P(LRW,"^",5),?53,$P(LRW,"^",3),?56,$J($P(LRW,"^",2),3),?60,$J($P(LRW,"^",6),5)
Q
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,LRO(68)," SEARCH (",LRSTR,"-",LRLST,")"
W !,"# = Not VA patient",?25,"SNOMED FIELDS",?45,"For:",LRJ(1) W:LRH]"" !,"Comment: ",LRH Q
H1 D H Q:LR("Q") W !?8,"NAME",?36,"ID",?45,"SEX",?49,"AGE",?60,"ACC #",!,LR("%") Q
H2 D H Q:LR("Q") W !,"ACC #",?11,"NAME",?44,"ID",?52,"SEX",?56,"AGE",?60,"MO/DA",!,LR("%") Q
H3 D H1 Q:LR("Q") W !,LRP,?32,$P(LRW,"^",5),?46,$P(LRW,"^",3) Q
H4 D H3 Q:LR("Q") W !?5,LRT(1),?50,$P(LRW,"^",2),?58,$J($P(LRW,"^"),7) Q
H5 D H4 Q:LR("Q") W !?10,LRM(1) Q
F D H Q:LR("Q") W !,LR("%"),!?5,"RESULT OF ",LRO(68)," (",LRABV,") SEARCH: "
W !,LRAA(1)," PATIENTS WITHIN PERIOD SEARCHED: ",LR(2) W:LRSS'="AU" !,LRO(68)," ACCESSIONS WITHIN PERIOD SEARCHED: ",LR(3)
I LR W !,LRO(68)," ORGAN/TISSUE SPECIMENS WITHIN PERIOD SEARCHED: ",LR
I 'LRD(0),LR(2) W !!,$J(LRB,5)," OF ",$J(LR(2),5)," ",LRAA(1)," PATIENTS(",$J(LRB*100/LR(2),5,2),"%) FOUND"
W !!,"The following fields were used for the search :",!?5,"TOPOGRAPHY FIELD: ",S(2)
F V=2,4,1,3 I $D(LRN(V)) D C
Q
C S A=-1 F F=0:0 S A=$O(LRN(V,A)) Q:A="" W !?10,$O(^DD(+LRSN(V),0,"NM",0)),?26,": ",$S(A'="Z":A,1:"ALL") D:V=2 D
Q
D S B=-1 F G=0:0 S B=$O(LRN(2,A,B)) Q:B="" W !?15,"ETIOLOGY FIELD: ",$S(B'="Z":B,1:"ALL")
Q
LRAPSEM1 ; IHS/DIR/AAB - SEARCH BY SNOMED CODE PRINT 8/15/95 10:51 ;
+1 ;;5.2;LR;**1002**;JUN 01, 1998
+2 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
+3 SET LRP=0
SET LRJ(1)=$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"")
DO S^LRU
IF LRD(1)
DO ^LRAPSEM2
DO F
QUIT
+4 DO H1
SET LR("F")=1
+5 FOR LRB=0:1
SET LRP=$ORDER(^TMP("LR",$JOB,"B",LRP))
IF LRP=""!(LR("Q"))
QUIT
SET X=$ORDER(^(LRP,0))
SET Y=$ORDER(^(X,0))
SET LRW=^TMP("LR",$JOB,X,Y)
IF $Y>(IOSL-6)
DO H1
IF LR("Q")
QUIT
WRITE !
IF $PIECE(LRW,"^",7)'=2
WRITE "#"
WRITE LRP,?32,$PIECE(LRW,"^",5),?46,$PIECE(LRW,"^",3)
DO Y
+6 IF LR("Q")
QUIT
SET LRY=1
DO H2
IF LR("Q")
QUIT
DO L
DO F
QUIT
+7 ;
Y SET LRY=0
FOR B=0:0
SET LRY=$ORDER(^TMP("LR",$JOB,"B",LRP,LRY))
IF 'LRY!(LR("Q"))
QUIT
DO A
+1 IF LR("Q")
QUIT
WRITE !,LR("%")
QUIT
A SET (LRC,LRAN)=0
FOR
SET LRAN=$ORDER(^TMP("LR",$JOB,"B",LRP,LRY,LRAN))
IF 'LRAN!(LR("Q"))
QUIT
SET LRC=LRC+1
IF LRC>1
WRITE !
DO P
+1 QUIT
P SET LRW=^TMP("LR",$JOB,LRY,LRAN)
SET LRW(2)=$PIECE(LRW,"^",2)
SET LRW(1)=$PIECE(LRW,"^")
+1 SET LRDFN=$PIECE(LRW,"^",8)
SET LRI=$PIECE(LRW,"^",9)
SET LRT=0
FOR LRG=0:1
SET LRT=$ORDER(^LR(LRDFN,LRSS,LRI,2,LRT))
IF 'LRT!(LR("Q"))
QUIT
SET LRT(1)=$PIECE(^LAB(61,+^(LRT,0),0),"^")
DO S
+2 QUIT
S IF $Y>(IOSL-6)
DO H3
IF LR("Q")
QUIT
WRITE !?5,LRT(1)
IF 'LRG
WRITE ?50,LRW(2),?58,$JUSTIFY(LRW(1),7)
FOR V=2,4,1,3
IF $DATA(LRN(V))
DO T
+1 QUIT
T FOR LRM=0:0
SET LRM=$ORDER(^LR(LRDFN,LRSS,LRI,2,LRT,V,LRM))
IF 'LRM!(LR("Q"))
QUIT
SET X=^(LRM,0)
SET LRX=+X
SET LRX(1)=$PIECE(X,"^",2)
DO U
+1 IF LRD
FOR LRM=0:0
SET LRM=$ORDER(^LR(LRDFN,LRSS,LRI,2,LRT,5,LRM))
IF 'LRM!(LR("Q"))
QUIT
SET LRX=^(LRM,0)
IF $Y>(IOSL-6)
DO H4
IF LR("Q")
QUIT
DO G
+2 QUIT
G SET X=LRX
SET Y=$PIECE(X,"^",2)
SET W=$PIECE(X,"^",3)
SET Z=$PIECE(X,"^")_":"
SET Z=$PIECE($PIECE(LR(LRSS),Z,2),";")
DO D^LRU
WRITE !?10,Z," ",W," Date: ",Y
QUIT
+1 QUIT
U IF '$DATA(^LAB(+LRSN(V),LRX,0))
QUIT
SET LRM(1)=$PIECE(^(0),"^")
IF $Y>(IOSL-6)
DO H4
IF LR("Q")
QUIT
WRITE !?10,LRM(1)
IF LRX(1)]""
WRITE " (",$SELECT(LRX(1)=1:"Positive",LRX(1)=0:"Negative",1:"?"),")"
IF V=2
DO E
+1 QUIT
E FOR LRE=0:0
SET LRE=$ORDER(^LR(LRDFN,LRSS,LRI,2,LRT,2,LRM,1,LRE))
IF 'LRE!(LR("Q"))
QUIT
SET LRX=+^(LRE,0)
IF $DATA(^LAB(61.2,LRX,0))
SET LRX=$PIECE(^(0),"^")
IF $Y>(IOSL-6)
DO H5
IF LR("Q")
QUIT
WRITE !?15,LRX
+1 QUIT
L FOR B=0:1
SET LRY=$ORDER(^TMP("LR",$JOB,LRY))
IF 'LRY!(LR("Q"))
QUIT
DO W
+1 QUIT
W SET LRAN=0
FOR C=0:1
SET LRAN=$ORDER(^TMP("LR",$JOB,LRY,LRAN))
IF 'LRAN!(LR("Q"))
QUIT
DO B
+1 QUIT
B IF $Y>(IOSL-6)
DO H2
IF LR("Q")
QUIT
+1 SET LRW=^TMP("LR",$JOB,LRY,LRAN)
WRITE !,$PIECE(LRW,U),?12
IF $PIECE(LRW,"^",7)'=2
WRITE "#"
WRITE $PIECE(LRW,"^",4),?40,$PIECE(LRW,"^",5),?53,$PIECE(LRW,"^",3),?56,$JUSTIFY($PIECE(LRW,"^",2),3),?60,$JUSTIFY($PIECE(LRW,"^",6),5)
+2 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)," SEARCH (",LRSTR,"-",LRLST,")"
+2 WRITE !,"# = Not VA patient",?25,"SNOMED FIELDS",?45,"For:",LRJ(1)
IF LRH]""
WRITE !,"Comment: ",LRH
QUIT
H1 DO H
IF LR("Q")
QUIT
WRITE !?8,"NAME",?36,"ID",?45,"SEX",?49,"AGE",?60,"ACC #",!,LR("%")
QUIT
H2 DO H
IF LR("Q")
QUIT
WRITE !,"ACC #",?11,"NAME",?44,"ID",?52,"SEX",?56,"AGE",?60,"MO/DA",!,LR("%")
QUIT
H3 DO H1
IF LR("Q")
QUIT
WRITE !,LRP,?32,$PIECE(LRW,"^",5),?46,$PIECE(LRW,"^",3)
QUIT
H4 DO H3
IF LR("Q")
QUIT
WRITE !?5,LRT(1),?50,$PIECE(LRW,"^",2),?58,$JUSTIFY($PIECE(LRW,"^"),7)
QUIT
H5 DO H4
IF LR("Q")
QUIT
WRITE !?10,LRM(1)
QUIT
F DO H
IF LR("Q")
QUIT
WRITE !,LR("%"),!?5,"RESULT OF ",LRO(68)," (",LRABV,") SEARCH: "
+1 WRITE !,LRAA(1)," PATIENTS WITHIN PERIOD SEARCHED: ",LR(2)
IF LRSS'="AU"
WRITE !,LRO(68)," ACCESSIONS WITHIN PERIOD SEARCHED: ",LR(3)
+2 IF LR
WRITE !,LRO(68)," ORGAN/TISSUE SPECIMENS WITHIN PERIOD SEARCHED: ",LR
+3 IF 'LRD(0)
IF LR(2)
WRITE !!,$JUSTIFY(LRB,5)," OF ",$JUSTIFY(LR(2),5)," ",LRAA(1)," PATIENTS(",$JUSTIFY(LRB*100/LR(2),5,2),"%) FOUND"
+4 WRITE !!,"The following fields were used for the search :",!?5,"TOPOGRAPHY FIELD: ",S(2)
+5 FOR V=2,4,1,3
IF $DATA(LRN(V))
DO C
+6 QUIT
C SET A=-1
FOR F=0:0
SET A=$ORDER(LRN(V,A))
IF A=""
QUIT
WRITE !?10,$ORDER(^DD(+LRSN(V),0,"NM",0)),?26,": ",$SELECT(A'="Z":A,1:"ALL")
IF V=2
DO D
+1 QUIT
D SET B=-1
FOR G=0:0
SET B=$ORDER(LRN(2,A,B))
IF B=""
QUIT
WRITE !?15,"ETIOLOGY FIELD: ",$SELECT(B'="Z":B,1:"ALL")
+1 QUIT
