LRAPSEM2 ;AVAMC/REG/CYM- SEARCH BY SNOMED CODE PRINT ;3/10/98 10:16 ;
;;5.2;LAB SERVICE;**72,201**;Sep 27, 1994
D H S LR("F")=1,DIWF="W",DIWL=5,DIWR=IOM-5
F LRY=0:0 S LRY=$O(^TMP("LR",$J,LRY)) Q:'LRY!(LR("Q")) F LRAN=0:0 S LRAN=$O(^TMP("LR",$J,LRY,LRAN)) Q:'LRAN!(LR("Q")) S LRW=^(LRAN) D:$Y>(IOSL-6) H Q:LR("Q") D Y
Q
Y S LRP=$E($P(LRW,"^",4),1,20),LRI=$P(LRW,"^",9),LRDFN=$P(LRW,"^",8),LRW(7)=$S($P(LRW,"^",7)=2:"",1:"#"),LRA=^LR(LRDFN,LRSS,LRI,0),LRA(1)=+LRA,LRA(8)=$E($P(LRA,"^",8),1,5),LRA(7)=$E($P($G(^VA(200,+$P(LRA,"^",7),0)),"^"),1,12)
S LRA(2)=$E($P($G(^VA(200,+$P(LRA,"^",2),0)),"^"),1,13),LRW(1)=$P(LRW,"^"),LRW(2)=$P(LRW,"^",2) D A
S A=0 F A(2)=0:1 S A=$O(^LR(LRDFN,LRSS,LRI,.1,A)) Q:'A!(LR("Q")) S A(1)=$P(^(A,0),"^") D:$Y>(IOSL-6) H1 Q:LR("Q") W ! W:'A(2) "Specimen(s):" W ?15,A(1)
Q:LR("Q") K ^TMP($J) S LRZ=0 F LRZ(2)=0:1 S LRZ=$O(^LR(LRDFN,LRSS,LRI,1.1,LRZ)) Q:'LRZ!(LR("Q")) S LRZ(1)=^(LRZ,0) D:$Y>(IOSL-6) H1 Q:LR("Q") S X=LRZ(1) D ^DIWP
Q:LR("Q") D:LRZ(2) ^DIWW
Q:LR("Q") K ^TMP($J) S LRZ=0 F LRZ(2)=0:1 S LRZ=$O(^LR(LRDFN,LRSS,LRI,1.4,LRZ)) Q:'LRZ!(LR("Q")) S LRZ(1)=^(LRZ,0) D:$Y>(IOSL-6) H1 Q:LR("Q") S X=LRZ(1) D ^DIWP
Q:LR("Q") D:LRZ(2) ^DIWW I 'LRD(2) W !,LR("%") Q
F LRT=0:0 S LRT=$O(^LR(LRDFN,LRSS,LRI,2,LRT)) Q:'LRT!(LR("Q")) S X=$G(^LAB(61,+^(LRT,0),0)),LRT(1)=$P(X,"^"),LRT(2)=$P(X,"^",2) D S
W !,LR("%") Q
S D:$Y>(IOSL-6) H1 Q:LR("Q") W !?5,"T-",LRT(2)," ",LRT(1) F V=2,4,1,3 I $D(LRN(V)) D T
Q:LR("Q") 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
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
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 D B Q
;
U Q:'$D(^LAB(+LRSN(V),LRX,0)) S X=^(0),LRM(1)=$P(X,"^"),LRM(2)=$P(X,"^",2) D:$Y>(IOSL-6) H4 Q:LR("Q") W !?10,$P(LRSN(V),"^",2),"-",LRM(2)," ",LRM(1) W:LRX(1)]"" " (",$S(LRX(1)=1:"Positive",LRX(1)=0:"Negative",1:"?"),")" D:V=2 E
Q
B K ^TMP($J) S LRZ=0 F LRZ(2)=0:0 S LRZ=$O(^LR(LRDFN,LRSS,LRI,2,LRT,5,LRM,1,LRZ)) Q:'LRZ!(LR("Q")) S LRZ(1)=^(LRZ,0) D:$Y>(IOSL-6) H4 Q:LR("Q") S X=LRZ(1) D ^DIWP
D:LRZ(2) ^DIWW 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 X=^(0),LRX=$P(X,"^"),LRX(2)=$P(X,"^",2) D:$Y>(IOSL-6) H5 Q:LR("Q") W !?15,"E-",LRX(2)," ",LRX
Q
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,LRO(68)," (",LRABV,") SEARCH (",LRSTR,"-",LRLST,")" W !,"Date",?8,"# = Not VA patient",?35,"For:",LRJ(1)
W !,"Taken",?11,"Patient",?30,"ID",?35,"Physician",?48,"LOC",?55,"Acc#",?67,"PATHOLOGIST",!,LR("%") Q
H1 D H Q:LR("Q") D A S A(2)=0 Q
H4 D H1 Q:LR("Q") W !?5,LRT(1) Q
H5 D H4 Q:LR("Q") W !?10,LRM(1) Q
A W !,$$Y2K^LRX(LRA(1),"5D"),?10,LRW(7),?11,LRP,?32,$P($P(LRW,"^",5),"-",3),?37,LRA(7),?50,LRA(8),?57,$P(LRA,"^",6),?69,LRA(2) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPSEM2 3000 printed Apr 09, 2024@21:16:53 Page 2
LRAPSEM2 ;AVAMC/REG/CYM- SEARCH BY SNOMED CODE PRINT ;3/10/98 10:16 ;
+1 ;;5.2;LAB SERVICE;**72,201**;Sep 27, 1994
+2 DO H
SET LR("F")=1
SET DIWF="W"
SET DIWL=5
SET DIWR=IOM-5
+3 FOR LRY=0:0
SET LRY=$ORDER(^TMP("LR",$JOB,LRY))
if 'LRY!(LR("Q"))
QUIT
FOR LRAN=0:0
SET LRAN=$ORDER(^TMP("LR",$JOB,LRY,LRAN))
if 'LRAN!(LR("Q"))
QUIT
SET LRW=^(LRAN)
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
DO Y
+4 QUIT
Y SET LRP=$EXTRACT($PIECE(LRW,"^",4),1,20)
SET LRI=$PIECE(LRW,"^",9)
SET LRDFN=$PIECE(LRW,"^",8)
SET LRW(7)=$SELECT($PIECE(LRW,"^",7)=2:"",1:"#")
SET LRA=^LR(LRDFN,LRSS,LRI,0)
SET LRA(1)=+LRA
SET LRA(8)=$EXTRACT($PIECE(LRA,"^",8),1,5)
SET LRA(7)=$EXTRACT($PIECE($GET(^VA(200,+$PIECE(LRA,"^",7),0)),"^"),1,12)
+1 SET LRA(2)=$EXTRACT($PIECE($GET(^VA(200,+$PIECE(LRA,"^",2),0)),"^"),1,13)
SET LRW(1)=$PIECE(LRW,"^")
SET LRW(2)=$PIECE(LRW,"^",2)
DO A
+2 SET A=0
FOR A(2)=0:1
SET A=$ORDER(^LR(LRDFN,LRSS,LRI,.1,A))
if 'A!(LR("Q"))
QUIT
SET A(1)=$PIECE(^(A,0),"^")
if $Y>(IOSL-6)
DO H1
if LR("Q")
QUIT
WRITE !
if 'A(2)
WRITE "Specimen(s):"
WRITE ?15,A(1)
+3 if LR("Q")
QUIT
KILL ^TMP($JOB)
SET LRZ=0
FOR LRZ(2)=0:1
SET LRZ=$ORDER(^LR(LRDFN,LRSS,LRI,1.1,LRZ))
if 'LRZ!(LR("Q"))
QUIT
SET LRZ(1)=^(LRZ,0)
if $Y>(IOSL-6)
DO H1
if LR("Q")
QUIT
SET X=LRZ(1)
DO ^DIWP
+4 if LR("Q")
QUIT
if LRZ(2)
DO ^DIWW
+5 if LR("Q")
QUIT
KILL ^TMP($JOB)
SET LRZ=0
FOR LRZ(2)=0:1
SET LRZ=$ORDER(^LR(LRDFN,LRSS,LRI,1.4,LRZ))
if 'LRZ!(LR("Q"))
QUIT
SET LRZ(1)=^(LRZ,0)
if $Y>(IOSL-6)
DO H1
if LR("Q")
QUIT
SET X=LRZ(1)
DO ^DIWP
+6 if LR("Q")
QUIT
if LRZ(2)
DO ^DIWW
IF 'LRD(2)
WRITE !,LR("%")
QUIT
+7 FOR LRT=0:0
SET LRT=$ORDER(^LR(LRDFN,LRSS,LRI,2,LRT))
if 'LRT!(LR("Q"))
QUIT
SET X=$GET(^LAB(61,+^(LRT,0),0))
SET LRT(1)=$PIECE(X,"^")
SET LRT(2)=$PIECE(X,"^",2)
DO S
+8 WRITE !,LR("%")
QUIT
S if $Y>(IOSL-6)
DO H1
if LR("Q")
QUIT
WRITE !?5,"T-",LRT(2)," ",LRT(1)
FOR V=2,4,1,3
IF $DATA(LRN(V))
DO T
+1 if LR("Q")
QUIT
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
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 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
DO B
QUIT
+1 ;
U if '$DATA(^LAB(+LRSN(V),LRX,0))
QUIT
SET X=^(0)
SET LRM(1)=$PIECE(X,"^")
SET LRM(2)=$PIECE(X,"^",2)
if $Y>(IOSL-6)
DO H4
if LR("Q")
QUIT
WRITE !?10,$PIECE(LRSN(V),"^",2),"-",LRM(2)," ",LRM(1)
if LRX(1)]""
WRITE " (",$SELECT(LRX(1)=1:"Positive",LRX(1)=0:"Negative",1:"?"),")"
if V=2
DO E
+1 QUIT
B KILL ^TMP($JOB)
SET LRZ=0
FOR LRZ(2)=0:0
SET LRZ=$ORDER(^LR(LRDFN,LRSS,LRI,2,LRT,5,LRM,1,LRZ))
if 'LRZ!(LR("Q"))
QUIT
SET LRZ(1)=^(LRZ,0)
if $Y>(IOSL-6)
DO H4
if LR("Q")
QUIT
SET X=LRZ(1)
DO ^DIWP
+1 if LRZ(2)
DO ^DIWW
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 X=^(0)
SET LRX=$PIECE(X,"^")
SET LRX(2)=$PIECE(X,"^",2)
if $Y>(IOSL-6)
DO H5
if LR("Q")
QUIT
WRITE !?15,"E-",LRX(2)," ",LRX
+1 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,") SEARCH (",LRSTR,"-",LRLST,")"
WRITE !,"Date",?8,"# = Not VA patient",?35,"For:",LRJ(1)
+2 WRITE !,"Taken",?11,"Patient",?30,"ID",?35,"Physician",?48,"LOC",?55,"Acc#",?67,"PATHOLOGIST",!,LR("%")
QUIT
H1 DO H
if LR("Q")
QUIT
DO A
SET A(2)=0
QUIT
H4 DO H1
if LR("Q")
QUIT
WRITE !?5,LRT(1)
QUIT
H5 DO H4
if LR("Q")
QUIT
WRITE !?10,LRM(1)
QUIT
A WRITE !,$$Y2K^LRX(LRA(1),"5D"),?10,LRW(7),?11,LRP,?32,$PIECE($PIECE(LRW,"^",5),"-",3),?37,LRA(7),?50,LRA(8),?57,$PIECE(LRA,"^",6),?69,LRA(2)
QUIT
