LRUPA2 ;AVAMC/REG/WTY - LAB ACCESSION LIST BY PAT ;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
;Reference to DIC supported by IA #10006
;
S ZTRTN="QUE^LRUPA2" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO K ^TMP($J) S (B(5),C(1))="",N=N(1)-1
F B=0:0 S N=$O(^LRO(68,LRAA,1,LRAD,1,N)) Q:'N!(N>N(2)) S (B(5),C(1))="" S:$D(^LRO(68,LRAA,1,LRAD,1,N,5,1,0)) X=^(0),B(5)=+X,C(1)=$P(X,"^",2) D PRT
D L^LRU,S^LRU,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
K ^TMP($J) D END^LRUTL,END
Q
W S X=$S($D(^LR(LRDFN,LRSS,LRI,0)):^(0),1:"") I X="" W ?50,"Not in lab results file" Q
S Z(2)=$S($P(X,"^",3):"","CHBBMI"[LRSS:"",1:"%"),Z=0 F A=0:1 S Z=$O(^LRO(68,LRAA,1,LRAD,1,N,4,Z)) Q:'Z!(LR("Q")) S Z(3)=^(Z,0) D:+Z(3) L
Q
O S C(4)=0 I '$D(^LR(LRDFN,LRSS,LRI,0)) W ?40,"Entry not in lab result file #63." Q
F E=0:1 S C(4)=$O(^LR(LRDFN,LRSS,LRI,2,C(4))) Q:'C(4)!(LR("Q")) S C(3)=+^(C(4),0) D:$Y>(IOSL-8) H2 Q:LR("Q") W:E>0 ! W ?43,$S($D(^LAB(61,C(3),0)):$E($P(^(0),"^"),1,35),1:"")
Q:LR("Q") W:E=0 ?43,"No SNOMED code" Q
L Q:LR("Q")!($P($G(^LAB(60,Z,0)),"^",4)="WK")
W:A=0 ?55,Z(2) W:A>0 !?55 W $S(LRSS="BB"&($P(Z(3),"^",4)=""):"%",1:"") W ?56,$E($P(^LAB(60,Z,0),"^"),1,19),?76 S X=$P(Z(3),"^",4) W $S('X:X,1:$P($G(^VA(200,X,0)),"^",2)) Q
;
XT S M=0 F Y=0:0 S M=$O(^TMP($J,V,M)) Q:M=""!(LR("Q")) D A
Q
A D:$Y>(IOSL-8) H Q:LR("Q") W !,$J(B,3),")",?6,$P(M,"-",3),?12,V I LRSS="BB" W !?12,M," " S X=$O(^TMP($J,V,M,0)) S:X X=^(X),X=$P(X,"^",2),X=^LR(X,0) W " ",$P(X,"^",5)," ",$P(X,"^",6)
S N=0 F B(2)=0:1 S N=$O(^TMP($J,V,M,N)) Q:'N!(LR("Q")) S B(3)=^(N),B(4)=$P(B(3),"^"),LRI=$P(B(3),"^",3),LRDFN=$P(B(3),"^",2) D C
Q
C D:$Y>(IOSL-8) H1 Q:LR("Q") W:B(2)>0 ! D:LRSS="BB" D W ?33,$J(N,4),?38,B(4) D:"AUEMSPCY"[LRSS B I "SPCYEMAU"'[LRSS D W
Q
B S LRDFN=$P(B(3),"^",2),LRI=$P(B(3),"^",3)
D:"SPCYEM"[LRSS O
Q:LR("Q") W:LRSS="AU" ?40,LRI Q
PRT Q:'$D(^LRO(68,LRAA,1,LRAD,1,N,3)) S X=^(3),A(3)=$P(X,"^",3)
S LRI=$P(X,"^",5),X=^LRO(68,LRAA,1,LRAD,1,N,0),LRDFN=+X
S A(3)=$S(A(3):A(3),1:$P(X,"^",3))
S B(5)=$S(B(5)>0:$P(^LAB(61,B(5),0),"^"),C(1)>0:$P(^LAB(62,C(1),0),"^"),1:"")
S B(5)=$S(B(5)]"":B(5),1:C(1))
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")) D
.S X=^("AU"),B(5)=$S($P(X,"^",3):"",1:"%") S Y=+X D D^LRU S LRI=Y
I "CYSPEM"[LRSS S B(5)="" D
.I $D(^LR(LRDFN,LRSS,LRI,0)),'$P(^(0),"^",3) S B(5)="%"
S ^TMP($J,$E(LRP,1,20),SSN,N)=B(5)_"^"_LRDFN_"^"_LRI
S (B(5),LRDFN,LRI)=""
Q
D S Y=+^LR($P(B(3),"^",2),"BB",$P(B(3),"^",3),0) D DT^LRU S B(4)=Y Q
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,LRO(68)," ACCESSIONS for ",Z(1)," BY PATIENT"
W !,"# =Not VA patient",?36,$S("AUBBCYEMSP"[LRSS:"% =Incomplete",1:"")
W !,"Count",?7,"ID",?12,"Patient",?35,"ACC#" W ?36 W:"AUBBCYEMSP"'[LRSS "Specimen" W:LRSS="BB" "Specimen date" W:"AUCYEMSP"'[LRSS ?50,"Test",?76,"Tech" W:"CYEMSP"[LRSS ?43,"Organ/tissue" W:LRSS="AU" ?40,"Date/time of Autopsy"
W !,LR("%") Q
H1 D H Q:LR("Q") S B(2)=0 W !,$J(B,3),")",?6,$P(M,"-",3),?12,V Q
H2 D H Q:LR("Q") W !,$J(B,3),")",?6,$P(M,"-",3),?12,V,?33,$J(N,4) S E=0 Q
;
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUPA2 3538 printed Apr 09, 2024@21:14:12 Page 2
LRUPA2 ;AVAMC/REG/WTY - LAB ACCESSION LIST BY PAT ;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 ;Reference to DIC supported by IA #10006
+6 ;
+7 SET ZTRTN="QUE^LRUPA2"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
KILL ^TMP($JOB)
SET (B(5),C(1))=""
SET N=N(1)-1
+1 FOR B=0:0
SET N=$ORDER(^LRO(68,LRAA,1,LRAD,1,N))
if 'N!(N>N(2))
QUIT
SET (B(5),C(1))=""
if $DATA(^LRO(68,LRAA,1,LRAD,1,N,5,1,0))
SET X=^(0)
SET B(5)=+X
SET C(1)=$PIECE(X,"^",2)
DO PRT
+2 DO L^LRU
DO S^LRU
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
+3 if IOST'?1"C".E&($EXTRACT(IOST,1,2)'="P-"!($DATA(LR("FORM"))))
WRITE @IOF
+4 KILL ^TMP($JOB)
DO END^LRUTL
DO END
+5 QUIT
W SET X=$SELECT($DATA(^LR(LRDFN,LRSS,LRI,0)):^(0),1:"")
IF X=""
WRITE ?50,"Not in lab results file"
QUIT
+1 SET Z(2)=$SELECT($PIECE(X,"^",3):"","CHBBMI"[LRSS:"",1:"%")
SET Z=0
FOR A=0:1
SET Z=$ORDER(^LRO(68,LRAA,1,LRAD,1,N,4,Z))
if 'Z!(LR("Q"))
QUIT
SET Z(3)=^(Z,0)
if +Z(3)
DO L
+2 QUIT
O SET C(4)=0
IF '$DATA(^LR(LRDFN,LRSS,LRI,0))
WRITE ?40,"Entry not in lab result file #63."
QUIT
+1 FOR E=0:1
SET C(4)=$ORDER(^LR(LRDFN,LRSS,LRI,2,C(4)))
if 'C(4)!(LR("Q"))
QUIT
SET C(3)=+^(C(4),0)
if $Y>(IOSL-8)
DO H2
if LR("Q")
QUIT
if E>0
WRITE !
WRITE ?43,$SELECT($DATA(^LAB(61,C(3),0)):$EXTRACT($PIECE(^(0),"^"),1,35),1:"")
+2 if LR("Q")
QUIT
if E=0
WRITE ?43,"No SNOMED code"
QUIT
L if LR("Q")!($PIECE($GET(^LAB(60,Z,0)),"^",4)="WK")
QUIT
+1 if A=0
WRITE ?55,Z(2)
if A>0
WRITE !?55
WRITE $SELECT(LRSS="BB"&($PIECE(Z(3),"^",4)=""):"%",1:"")
WRITE ?56,$EXTRACT($PIECE(^LAB(60,Z,0),"^"),1,19),?76
SET X=$PIECE(Z(3),"^",4)
WRITE $SELECT('X:X,1:$PIECE($GET(^VA(200,X,0)),"^",2))
QUIT
+2 ;
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 if $Y>(IOSL-8)
DO H
if LR("Q")
QUIT
WRITE !,$JUSTIFY(B,3),")",?6,$PIECE(M,"-",3),?12,V
IF LRSS="BB"
WRITE !?12,M," "
SET X=$ORDER(^TMP($JOB,V,M,0))
if X
SET X=^(X)
SET X=$PIECE(X,"^",2)
SET X=^LR(X,0)
WRITE " ",$PIECE(X,"^",5)," ",$PIECE(X,"^",6)
+1 SET N=0
FOR B(2)=0:1
SET N=$ORDER(^TMP($JOB,V,M,N))
if 'N!(LR("Q"))
QUIT
SET B(3)=^(N)
SET B(4)=$PIECE(B(3),"^")
SET LRI=$PIECE(B(3),"^",3)
SET LRDFN=$PIECE(B(3),"^",2)
DO C
+2 QUIT
C if $Y>(IOSL-8)
DO H1
if LR("Q")
QUIT
if B(2)>0
WRITE !
if LRSS="BB"
DO D
WRITE ?33,$JUSTIFY(N,4),?38,B(4)
if "AUEMSPCY"[LRSS
DO B
IF "SPCYEMAU"'[LRSS
DO W
+1 QUIT
B SET LRDFN=$PIECE(B(3),"^",2)
SET LRI=$PIECE(B(3),"^",3)
+1 if "SPCYEM"[LRSS
DO O
+2 if LR("Q")
QUIT
if LRSS="AU"
WRITE ?40,LRI
QUIT
PRT if '$DATA(^LRO(68,LRAA,1,LRAD,1,N,3))
QUIT
SET X=^(3)
SET A(3)=$PIECE(X,"^",3)
+1 SET LRI=$PIECE(X,"^",5)
SET X=^LRO(68,LRAA,1,LRAD,1,N,0)
SET LRDFN=+X
+2 SET A(3)=$SELECT(A(3):A(3),1:$PIECE(X,"^",3))
+3 SET B(5)=$SELECT(B(5)>0:$PIECE(^LAB(61,B(5),0),"^"),C(1)>0:$PIECE(^LAB(62,C(1),0),"^"),1:"")
+4 SET B(5)=$SELECT(B(5)]"":B(5),1:C(1))
+5 if '$DATA(^LR(LRDFN,0))
QUIT
SET X=^(0)
SET DA=$PIECE(X,"^",3)
SET (LRDPF,X)=$PIECE(X,"^",2)
+6 SET DIC="^DIC("
SET DIC(0)="Z"
DO ^DIC
if Y=-1
QUIT
+7 SET P(0)=Y(0,0)
KILL DIC,Y
+8 SET DIC=^DIC(X,0,"GL")
SET DIC(0)="NZ"
SET X=DA
DO ^DIC
if Y=-1
QUIT
+9 SET SSN=$PIECE(Y(0),"^",9)
SET LRP=$PIECE(Y(0),"^")
KILL DIC,DA,Y
+10 DO SSN^LRU
+11 if P(0)'="PATIENT"
SET LRP="#"_LRP
+12 IF LRSS="AU"
IF $DATA(^LR(LRDFN,"AU"))
Begin DoDot:1
+13 SET X=^("AU")
SET B(5)=$SELECT($PIECE(X,"^",3):"",1:"%")
SET Y=+X
DO D^LRU
SET LRI=Y
End DoDot:1
+14 IF "CYSPEM"[LRSS
SET B(5)=""
Begin DoDot:1
+15 IF $DATA(^LR(LRDFN,LRSS,LRI,0))
IF '$PIECE(^(0),"^",3)
SET B(5)="%"
End DoDot:1
+16 SET ^TMP($JOB,$EXTRACT(LRP,1,20),SSN,N)=B(5)_"^"_LRDFN_"^"_LRI
+17 SET (B(5),LRDFN,LRI)=""
+18 QUIT
D SET Y=+^LR($PIECE(B(3),"^",2),"BB",$PIECE(B(3),"^",3),0)
DO DT^LRU
SET B(4)=Y
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)," ACCESSIONS for ",Z(1)," BY PATIENT"
+2 WRITE !,"# =Not VA patient",?36,$SELECT("AUBBCYEMSP"[LRSS:"% =Incomplete",1:"")
+3 WRITE !,"Count",?7,"ID",?12,"Patient",?35,"ACC#"
WRITE ?36
if "AUBBCYEMSP"'[LRSS
WRITE "Specimen"
if LRSS="BB"
WRITE "Specimen date"
if "AUCYEMSP"'[LRSS
WRITE ?50,"Test",?76,"Tech"
if "CYEMSP"[LRSS
WRITE ?43,"Organ/tissue"
if LRSS="AU"
WRITE ?40,"Date/time of Autopsy"
+4 WRITE !,LR("%")
QUIT
H1 DO H
if LR("Q")
QUIT
SET B(2)=0
WRITE !,$JUSTIFY(B,3),")",?6,$PIECE(M,"-",3),?12,V
QUIT
H2 DO H
if LR("Q")
QUIT
WRITE !,$JUSTIFY(B,3),")",?6,$PIECE(M,"-",3),?12,V,?33,$JUSTIFY(N,4)
SET E=0
QUIT
+1 ;
END DO V^LRU
QUIT
