LRUPAD2 ;AVAMC/REG/WTY - LAB ACCESSION LIST BY PATIENT ;9/25/00
;;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)
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
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))=""
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
S DIC=^DIC(X,0,"GL"),DIC(0)="NZ",X=DA D ^DIC Q:Y=-1
S SSN=$P(Y(0),"^",9),LRP=$P(Y(0),"^") K DIC,DA,Y
D SSN^LRU
S:P(0)'="PATIENT" LRP="#"_LRP
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)=""
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:"")
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
;
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUPAD2 3472 printed Oct 16, 2024@18:22:42 Page 2
LRUPAD2 ;AVAMC/REG/WTY - LAB ACCESSION LIST BY PATIENT ;9/25/00
+1 ;;5.2;LAB SERVICE;**72,248**;Sep 27, 1994
+2 ;
+3 ;Reference to ^DIC( supported by IA #916
+4 ;Reference to ^VA(200 supported by IA #10060
+5 ;
+6 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 DO H
if LR("Q")
QUIT
+1 WRITE !,$JUSTIFY(B,3),")",?6,$PIECE(M,"-",3),?11,$EXTRACT(V,1,19),?31,$JUSTIFY(N,5)
+2 SET LRX=^TMP($JOB,V,M,O,N)
+3 WRITE ?37,$EXTRACT($PIECE(LRX,"^"),1,5),?44,$PIECE(LRX,"^",5),?52,$EXTRACT($PIECE(LRX,"^",2),1,5)
+4 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 if $Y>(IOSL-8)
DO H
if LR("Q")
QUIT
+1 WRITE !,$JUSTIFY(B,3),")",?6,$PIECE(M,"-",3),?11,$EXTRACT(V,1,19)
SET N=0
+2 FOR E=0:1
SET N=$ORDER(^TMP($JOB,V,M,O,N))
if 'N!(LR("Q"))
QUIT
Begin DoDot:1
+3 SET LRX=^TMP($JOB,V,M,O,N)
SET LRDFN=$PIECE(LRX,"^",3)
SET LRI=$PIECE(LRX,"^",4)
+4 if $Y>(IOSL-8)
DO H2
if LR("Q")
QUIT
DO C
End DoDot:1
if LR("Q")
QUIT
+5 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 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)
+2 if B(5)
SET B(5)=$PIECE(^LAB(61,B(5),0),"^")
+3 if '$DATA(^LRO(68,LRAA,1,I,1,N,3))
QUIT
SET X=^(3)
+4 SET A(3)=$PIECE(X,"^",3)
SET LRI=$PIECE(X,"^",5)
+5 SET X=^LRO(68,LRAA,1,I,1,N,0)
SET LRDFN=+X
+6 SET A(3)=$SELECT(A(3):A(3),1:$PIECE(X,"^",3))
+7 SET A(3)=$EXTRACT(A(3),4,5)_"/"_$EXTRACT(A(3),6,7)
+8 SET LRF=$PIECE(^LRO(68,LRAA,1,I,1,N,0),"^",7)
+9 if '$DATA(^LR(LRDFN,0))
QUIT
SET X=^(0)
SET DA=$PIECE(X,"^",3)
SET (LRDPF,X)=$PIECE(X,"^",2)
+10 SET DIC="^DIC("
SET DIC(0)="Z"
DO ^DIC
if Y=-1
QUIT
+11 SET P(0)=Y(0,0)
KILL DIC,Y
+12 SET DIC=^DIC(X,0,"GL")
SET DIC(0)="NZ"
SET X=DA
DO ^DIC
if Y=-1
QUIT
+13 SET SSN=$PIECE(Y(0),"^",9)
SET LRP=$PIECE(Y(0),"^")
KILL DIC,DA,Y
+14 DO SSN^LRU
+15 if P(0)'="PATIENT"
SET LRP="#"_LRP
+16 IF LRSS="AU"
IF $DATA(^LR(LRDFN,"AU"))
SET B(5)=$SELECT('$PIECE(^("AU"),"^",3):"%",1:"")
+17 if '$LENGTH(SSN)
QUIT
+18 SET ^TMP($JOB,$EXTRACT(LRP,1,20),SSN,I,N)=A(3)_"^"_B(5)_"^"_LRDFN_"^"_LRI_"^"_$EXTRACT(LRF,1,7)
+19 SET (B(5),LRDFN,LRI)=""
+20 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 WRITE !,"# = Not VA patient",?36,$SELECT("AUBBCYEMSP"[LRSS:"% =Incomplete",1:"")
+4 WRITE !,"Count",?7,"ID",?11,"Patient",?32,"ACC#"
+5 IF "AUCYEMSP"'[LRSS
Begin DoDot:1
+6 WRITE ?37,"Date",?44,"Loc",?52,"Specimen",?64,"Test",?76,"Tech"
+7 WRITE !,LR("%")
End DoDot:1
+8 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 ;
END DO V^LRU
QUIT
