- LRAPSEM2 ; IHS/DIR/AAB - SEARCH BY SNOMED CODE PRINT 3/10/98 10:16 ; [ 07/09/1998 9:11 AM ]
- ;;5.2;LR;**1002,1006**;SEP 01, 1998
- ;
- ;;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
- LRAPSEM2 ; IHS/DIR/AAB - SEARCH BY SNOMED CODE PRINT 3/10/98 10:16 ; [ 07/09/1998 9:11 AM ]
- +1 ;;5.2;LR;**1002,1006**;SEP 01, 1998
- +2 ;
- +3 ;;5.2;LAB SERVICE;**72,201**;Sep 27, 1994
- +4 DO H
- SET LR("F")=1
- SET DIWF="W"
- SET DIWL=5
- SET DIWR=IOM-5
- +5 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
- +6 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
