LRUPAD2 ;AVAMC/REG/WTY - LAB ACCESSION LIST BY PATIENT ;9/25/00 [ 04/15/2003 9:38 AM ]
;;5.2;LR;**1002,1018,1020,1030**;NOV 01, 1997
;;5.2;LAB SERVICE;**72,248**;Sep 27, 1994
;
;Reference to ^DIC( supported by IA #916
;Reference to ^VA(200 supported by IA #10060
;
S ZTRTN="QUE^LRUPAD2" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO K ^TMP($J) D L^LRU,S^LRU D:IOST?1"C".E WAIT^LRU
S V(1)=V(1)-1,LRI=""
F I=V(1):0 S I=$O(^LRO(68,LRAA,1,I)) Q:'I!(I>V) S LRSA=LRSDT-.01 F B=LRSA:0 S B=$O(^LRO(68,LRAA,1,I,1,"E",B)) Q:'B!(B>LRLDT) F N=0:0 S N=$O(^LRO(68,LRAA,1,I,1,"E",B,N)) Q:'N D P
D H S LR("F")=1,V=0 F B=1:1 S V=$O(^TMP($J,V)) Q:V=""!(LR("Q")) D XT
W:IOST'?1"C".E&($E(IOST,1,2)'="P-"!($D(LR("FORM")))) @IOF
D END,END^LRUTL Q
NEW ;D H Q:LR("Q")
;W !,$J(B,3),")",?6,$P(M,"-",3),?11,$E(V,1,19),?31,$J(N,5)
;S LRX=^TMP($J,V,M,O,N)
;W ?37,$E($P(LRX,"^"),1,5),?44,$P(LRX,"^",5),?52,$E($P(LRX,"^",2),1,5)
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
D H Q:LR("Q") W !,$J(B,3),")",?5,M,?12,$E(V,1,19),?31,$J(N,5),?37 S LRX=^TMP($J,V,M,O,N) W $E($P(LRX,"^"),1,5),?44,$P(LRX,"^",5),?52,$E($P(LRX,"^",2),1,5) Q ;IHS/ANMC/CLS 08/18/96
;----- END IHS MODIFICATIONS
Q
W S Z(2)=$S('$D(^LR(LRDFN,LRSS,LRI,0)):"",$P(^(0),"^",3):"",LRSS="MI":"",1:"%"),Z=0
F A=0:1 S Z=$O(^LRO(68,LRAA,1,O,1,N,4,Z)) Q:'Z!(LR("Q")) D
.S Z(1)=^LRO(68,LRAA,1,O,1,N,4,Z,0) D:+Z(1) T
Q
O Q:LR("Q") Q:LRSS="AU"
I '$D(^LR(LRDFN,LRSS,LRI,0)) W ?40,"Entry not in lab data file." Q
S Z(2)=$S($P(^LR(LRDFN,LRSS,LRI,0),"^",3):"",1:"%")
S C(4)=0
F F=0:1 S C(4)=$O(^LR(LRDFN,LRSS,LRI,2,C(4))) Q:'C(4)!(LR("Q")) D
.S C(3)=+^LR(LRDFN,LRSS,LRI,2,C(4),0) D L
Q:LR("Q") W:F=0 ?46,"No SNOMED code" Q
L D:$Y>(IOSL-8) H2 Q:LR("Q") W:F>0 !
W ?44,Z(2)
W ?45,$S($D(^LAB(61,C(3),0)):$E($P(^LAB(61,C(3),0),"^"),1,26),1:"")
Q
T W:A>0 !
W ?59,$E($P(^LAB(60,+Z(1),0),"^"),1,15)
S TECH=$P(Z(1),"^",4)
S:TECH?1N.N TECH=$P($G(^VA(200,TECH,0)),"^",2)
W ?76,$E(TECH,1,4)
K TECH
D:$Y>(IOSL-8) NEW Q:LR("Q")
Q
XT S M=0 F Y=0:0 S M=$O(^TMP($J,V,M)) Q:M=""!(LR("Q")) D A
Q
A F O=0:0 S O=$O(^TMP($J,V,M,O)) Q:'O!(LR("Q")) D B
Q
B ;D:$Y>(IOSL-8) H Q:LR("Q")
;W !,$J(B,3),")",?6,$P(M,"-",3),?11,$E(V,1,19) S N=0
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
D:$Y>(IOSL-8) H Q:LR("Q") W !,$J(B,3),")",?5,M,?12,$E(V,1,19) S N=0 ;IHS/ANMC/CLS 08/18/96
;----- END IHS MODIFICATIONS
F E=0:1 S N=$O(^TMP($J,V,M,O,N)) Q:'N!(LR("Q")) D Q:LR("Q")
.S LRX=^TMP($J,V,M,O,N),LRDFN=$P(LRX,"^",3),LRI=$P(LRX,"^",4)
.D:$Y>(IOSL-8) H2 Q:LR("Q") D C
Q
C W:E>0 ! W ?31,$J(N,5),?37,$J($P(LRX,"^"),5),?44,$P(LRX,"^",5)
W ?52,$E($P(LRX,"^",2),1,5) D W:"MICHBL"[LRSS,O:"AUCYEMSP"[LRSS
Q
P S (B(5),C(1))=""
Q:'$D(^LRO(68,LRAA,1,I,1,N,0)) ; IHS/OIT/MKK - LR*5.2*1030 -- Skip malformed Accessions
;
S:$D(^LRO(68,LRAA,1,I,1,N,5,1,0)) X=^(0),B(5)=+X,C(1)=$P(X,"^",2)
S:B(5) B(5)=$P(^LAB(61,B(5),0),"^")
Q:'$D(^LRO(68,LRAA,1,I,1,N,3)) S X=^(3)
S A(3)=$P(X,"^",3),LRI=$P(X,"^",5)
S X=^LRO(68,LRAA,1,I,1,N,0),LRDFN=+X
S A(3)=$S(A(3):A(3),1:$P(X,"^",3))
S A(3)=$E(A(3),4,5)_"/"_$E(A(3),6,7)
S LRF=$P(^LRO(68,LRAA,1,I,1,N,0),"^",7)
Q:'$D(^LR(LRDFN,0)) S X=^(0),DA=$P(X,"^",3),(LRDPF,X)=$P(X,"^",2)
S DIC="^DIC(",DIC(0)="Z" D ^DIC Q:Y=-1
S P(0)=Y(0,0) K DIC,Y
;----- BEGIN IHS/OIT/MKK MOD LR*5.2*1020 - Don't use special lookup
;S DIC=^DIC(X,0,"GL"),DIC(0)="NZ",X=DA D ^DIC Q:Y=-1
S DIC=^DIC(X,0,"GL"),DIC(0)="CINZ",X=DA D ^DIC Q:Y=-1
; ----- END IHS/OIT/MKK MOD LR*5.2*1020
S SSN=$P(Y(0),"^",9),LRP=$P(Y(0),"^") K DIC,DA,Y
D SSN^LRU
;S:P(0)'="PATIENT" LRP="#"_LRP
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
S:P(0)'="VA PATIENT" LRP="#"_LRP ;IHS/ANMC/CLS 08/18/96
;----- END IHS MODIFICATIONS
I LRSS="AU",$D(^LR(LRDFN,"AU")) S B(5)=$S('$P(^("AU"),"^",3):"%",1:"")
;Q:'$L(SSN)
;S ^TMP($J,$E(LRP,1,20),SSN,I,N)=A(3)_"^"_B(5)_"^"_LRDFN_"^"_LRI_"^"_$E(LRF,1,7)
;S (B(5),LRDFN,LRI)=""
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
Q:'$L(HRCN) S ^TMP($J,$E(LRP,1,20),HRCN,I,N)=A(3)_"^"_B(5)_"^"_LRDFN_"^"_LRI_"^"_$E(LRF,1,7) S (B(5),LRDFN,LRI,DFN,HRCN)="" Q ;IHS/ANMC/CLS 08/18/96
;----- END IHS MODIFICATIONS
Q
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU
W !,LRO(68)," ACCESSIONS(",LRSTR,"-",LRLST,")"
;W !,"# = Not VA patient",?36,$S("AUBBCYEMSP"[LRSS:"% =Incomplete",1:"") ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
W !,"# = Not IHS patient",?36,$S("AUBBCYEMSP"[LRSS:"% =Incomplete",1:"") ;IHS/ANMC/CLS 08/18/96
;----- END IHS MODIFICATIONS
W !,"Count",?7,"ID",?11,"Patient",?32,"ACC#"
I "AUCYEMSP"'[LRSS D
.W ?37,"Date",?44,"Loc",?52,"Specimen",?64,"Test",?76,"Tech"
.W !,LR("%")
Q
H1 D H W ! Q
H2 D H Q:LR("Q") W !,$J(B,3),")",?6,$P(M,"-",3),?11,$E(V,1,19) Q
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
D H Q:LR("Q") W !,$J(B,3),")",?5,M,?12,$E(V,1,19) Q ;IHS/ANMC/CLS 08/18/96
;
END D V^LRU Q
LRUPAD2 ;AVAMC/REG/WTY - LAB ACCESSION LIST BY PATIENT ;9/25/00 [ 04/15/2003 9:38 AM ]
+1 ;;5.2;LR;**1002,1018,1020,1030**;NOV 01, 1997
+2 ;;5.2;LAB SERVICE;**72,248**;Sep 27, 1994
+3 ;
+4 ;Reference to ^DIC( supported by IA #916
+5 ;Reference to ^VA(200 supported by IA #10060
+6 ;
+7 SET ZTRTN="QUE^LRUPAD2"
DO BEG^LRUTL
IF POP!($DATA(ZTSK))
GOTO END
QUE USE IO
KILL ^TMP($JOB)
DO L^LRU
DO S^LRU
IF IOST?1"C".E
DO WAIT^LRU
+1 SET V(1)=V(1)-1
SET LRI=""
+2 FOR I=V(1):0
SET I=$ORDER(^LRO(68,LRAA,1,I))
IF 'I!(I>V)
QUIT
SET LRSA=LRSDT-.01
FOR B=LRSA:0
SET B=$ORDER(^LRO(68,LRAA,1,I,1,"E",B))
IF 'B!(B>LRLDT)
QUIT
FOR N=0:0
SET N=$ORDER(^LRO(68,LRAA,1,I,1,"E",B,N))
IF 'N
QUIT
DO P
+3 DO H
SET LR("F")=1
SET V=0
FOR B=1:1
SET V=$ORDER(^TMP($JOB,V))
IF V=""!(LR("Q"))
QUIT
DO XT
+4 IF IOST'?1"C".E&($EXTRACT(IOST,1,2)'="P-"!($DATA(LR("FORM"))))
WRITE @IOF
+5 DO END
DO END^LRUTL
QUIT
NEW ;D H Q:LR("Q")
+1 ;W !,$J(B,3),")",?6,$P(M,"-",3),?11,$E(V,1,19),?31,$J(N,5)
+2 ;S LRX=^TMP($J,V,M,O,N)
+3 ;W ?37,$E($PAD2_source.html#xP">PAD2_source.html#xPAD2_source.html#xP">P">PAD2_source.html#xP">P(LRX,"^"),1,5),?44,$PAD2_source.html#xP">PAD2_source.html#xPAD2_source.html#xP">P">PAD2_source.html#xP">P(LRX,"^",5),?52,$E($PAD2_source.html#xP">PAD2_source.html#xPAD2_source.html#xP">P">PAD2_source.html#xP">P(LRX,"^",2),1,5)
+4 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+5 ;IHS/ANMC/CLS 08/18/96
DO H
IF LR("Q")
QUIT
WRITE !,$JUSTIFY(B,3),")",?5,M,?12,$EXTRACT(V,1,19),?31,$JUSTIFY(N,5),?37
SET LRX=^TMP($JOB,V,M,O,N)
WRITE $EXTRACT($PIECE(LRX,"^"),1,5),?44,$PIECE(LRX,"^",5),?52,$EXTRACT($PIECE(LRX,"^",2),1,5)
QUIT
+6 ;----- END IHS MODIFICATIONS
+7 QUIT
W SET Z(2)=$SELECT('$DATA(^LR(LRDFN,LRSS,LRI,0)):"",$PIECE(^(0),"^",3):"",LRSS="MI":"",1:"%")
SET Z=0
+1 FOR A=0:1
SET Z=$ORDER(^LRO(68,LRAA,1,O,1,N,4,Z))
IF 'Z!(LR("Q"))
QUIT
Begin DoDot:1
+2 SET Z(1)=^LRO(68,LRAA,1,O,1,N,4,Z,0)
IF +Z(1)
DO T
End DoDot:1
+3 QUIT
O IF LR("Q")
QUIT
IF LRSS="AU"
QUIT
+1 IF '$DATA(^LR(LRDFN,LRSS,LRI,0))
WRITE ?40,"Entry not in lab data file."
QUIT
+2 SET Z(2)=$SELECT($PIECE(^LR(LRDFN,LRSS,LRI,0),"^",3):"",1:"%")
+3 SET C(4)=0
+4 FOR F=0:1
SET C(4)=$ORDER(^LR(LRDFN,LRSS,LRI,2,C(4)))
IF 'C(4)!(LR("Q"))
QUIT
Begin DoDot:1
+5 SET C(3)=+^LR(LRDFN,LRSS,LRI,2,C(4),0)
DO L
End DoDot:1
+6 IF LR("Q")
QUIT
IF F=0
WRITE ?46,"No SNOMED code"
QUIT
L IF $Y>(IOSL-8)
DO H2
IF LR("Q")
QUIT
IF F>0
WRITE !
+1 WRITE ?44,Z(2)
+2 WRITE ?45,$SELECT($DATA(^LAB(61,C(3),0)):$EXTRACT($PIECE(^LAB(61,C(3),0),"^"),1,26),1:"")
+3 QUIT
T IF A>0
WRITE !
+1 WRITE ?59,$EXTRACT($PIECE(^LAB(60,+Z(1),0),"^"),1,15)
+2 SET TECH=$PIECE(Z(1),"^",4)
+3 IF TECH?1N.N
SET TECH=$PIECE($GET(^VA(200,TECH,0)),"^",2)
+4 WRITE ?76,$EXTRACT(TECH,1,4)
+5 KILL TECH
+6 IF $Y>(IOSL-8)
DO NEW
IF LR("Q")
QUIT
+7 QUIT
XT SET M=0
FOR Y=0:0
SET M=$ORDER(^TMP($JOB,V,M))
IF M=""!(LR("Q"))
QUIT
DO A
+1 QUIT
A FOR O=0:0
SET O=$ORDER(^TMP($JOB,V,M,O))
IF 'O!(LR("Q"))
QUIT
DO B
+1 QUIT
B ;D:$Y>(IOSL-8) H Q:LR("Q")
+1 ;W !,$J(B,3),")",?6,$P(M,"-",3),?11,$E(V,1,19) S N=0
+2 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+3 ;IHS/ANMC/CLS 08/18/96
IF $Y>(IOSL-8)
DO H
IF LR("Q")
QUIT
WRITE !,$JUSTIFY(B,3),")",?5,M,?12,$EXTRACT(V,1,19)
SET N=0
+4 ;----- END IHS MODIFICATIONS
+5 FOR E=0:1
SET N=$ORDER(^TMP($JOB,V,M,O,N))
IF 'N!(LR("Q"))
QUIT
Begin DoDot:1
+6 SET LRX=^TMP($JOB,V,M,O,N)
SET LRDFN=$PIECE(LRX,"^",3)
SET LRI=$PIECE(LRX,"^",4)
+7 IF $Y>(IOSL-8)
DO H2
IF LR("Q")
QUIT
DO C
End DoDot:1
IF LR("Q")
QUIT
+8 QUIT
C IF E>0
WRITE !
WRITE ?31,$JUSTIFY(N,5),?37,$JUSTIFY($PIECE(LRX,"^"),5),?44,$PIECE(LRX,"^",5)
+1 WRITE ?52,$EXTRACT($PIECE(LRX,"^",2),1,5)
IF "MICHBL"[LRSS
DO W
IF "AUCYEMSP"[LRSS
DO O
+2 QUIT
P SET (B(5),C(1))=""
+1 ; IHS/OIT/MKK - LR*5.2*1030 -- Skip malformed Accessions
IF '$DATA(^LRO(68,LRAA,1,I,1,N,0))
QUIT
+2 ;
+3 IF $DATA(^LRO(68,LRAA,1,I,1,N,5,1,0))
SET X=^(0)
SET B(5)=+X
SET C(1)=$PIECE(X,"^",2)
+4 IF B(5)
SET B(5)=$PIECE(^LAB(61,B(5),0),"^")
+5 IF '$DATA(^LRO(68,LRAA,1,I,1,N,3))
QUIT
SET X=^(3)
+6 SET A(3)=$PIECE(X,"^",3)
SET LRI=$PIECE(X,"^",5)
+7 SET X=^LRO(68,LRAA,1,I,1,N,0)
SET LRDFN=+X
+8 SET A(3)=$SELECT(A(3):A(3),1:$PIECE(X,"^",3))
+9 SET A(3)=$EXTRACT(A(3),4,5)_"/"_$EXTRACT(A(3),6,7)
+10 SET LRF=$PIECE(^LRO(68,LRAA,1,I,1,N,0),"^",7)
+11 IF '$DATA(^LR(LRDFN,0))
QUIT
SET X=^(0)
SET DA=$PIECE(X,"^",3)
SET (LRDPF,X)=$PIECE(X,"^",2)
+12 SET DIC="^DIC("
SET DIC(0)="Z"
DO ^DIC
IF Y=-1
QUIT
+13 SET P(0)=Y(0,0)
KILL DIC,Y
+14 ;----- BEGIN IHS/OIT/MKK MOD LR*5.2*1020 - Don't use special lookup
+15 ;S DIC=^DIC(X,0,"GL"),DIC(0)="NZ",X=DA D ^DIC Q:Y=-1
+16 SET DIC=^DIC(X,0,"GL")
SET DIC(0)="CINZ"
SET X=DA
DO ^DIC
IF Y=-1
QUIT
+17 ; ----- END IHS/OIT/MKK MOD LR*5.2*1020
+18 SET SSN=$PIECE(Y(0),"^",9)
SET LRP=$PIECE(Y(0),"^")
KILL DIC,DA,Y
+19 DO SSN^LRU
+20 ;S:P(0)'="PATIENT" LRP="#"_LRP
+21 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+22 ;IHS/ANMC/CLS 08/18/96
IF P(0)'="VA PATIENT"
SET LRP="#"_LRP
+23 ;----- END IHS MODIFICATIONS
+24 IF LRSS="AU"
IF $DATA(^LR(LRDFN,"AU"))
SET B(5)=$SELECT('$PIECE(^("AU"),"^",3):"%",1:"")
+25 ;Q:'$L(SSN)
+26 ;S ^TMP($J,$E(LRP,1,20),SSN,I,N)=A(3)_"^"_B(5)_"^"_LRDFN_"^"_LRI_"^"_$E(LRF,1,7)
+27 ;S (B(5),LRDFN,LRI)=""
+28 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+29 ;IHS/ANMC/CLS 08/18/96
IF '$LENGTH(HRCN)
QUIT
SET ^TMP($JOB,$EXTRACT(LRP,1,20),HRCN,I,N)=A(3)_"^"_B(5)_"^"_LRDFN_"^"_LRI_"^"_$EXTRACT(LRF,1,7)
SET (B(5),LRDFN,LRI,DFN,HRCN)=""
QUIT
+30 ;----- END IHS MODIFICATIONS
+31 QUIT
H IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
IF LR("Q")
QUIT
+1 DO F^LRU
+2 WRITE !,LRO(68)," ACCESSIONS(",LRSTR,"-",LRLST,")"
+3 ;W !,"# = Not VA patient",?36,$S("AUBBCYEMSP"[LRSS:"% =Incomplete",1:"") ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+4 ;IHS/ANMC/CLS 08/18/96
WRITE !,"# = Not IHS patient",?36,$SELECT("AUBBCYEMSP"[LRSS:"% =Incomplete",1:"")
+5 ;----- END IHS MODIFICATIONS
+6 WRITE !,"Count",?7,"ID",?11,"Patient",?32,"ACC#"
+7 IF "AUCYEMSP"'[LRSS
Begin DoDot:1
+8 WRITE ?37,"Date",?44,"Loc",?52,"Specimen",?64,"Test",?76,"Tech"
+9 WRITE !,LR("%")
End DoDot:1
+10 QUIT
H1 DO H
WRITE !
QUIT
H2 DO H
IF LR("Q")
QUIT
WRITE !,$JUSTIFY(B,3),")",?6,$PIECE(M,"-",3),?11,$EXTRACT(V,1,19)
QUIT
+1 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+2 ;IHS/ANMC/CLS 08/18/96
DO H
IF LR("Q")
QUIT
WRITE !,$JUSTIFY(B,3),")",?5,M,?12,$EXTRACT(V,1,19)
QUIT
+3 ;
END DO V^LRU
QUIT
