LRUPA2 ;AVAMC/REG/WTY - LAB ACCESSION LIST BY PAT ;MAY 06, 2009 9:58 AM
;;5.2T1;LAB SERVICE;**1002,1018,1026**;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
;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)
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
D:$Y>(IOSL-8) H Q:LR("Q") W !,$J(B,3),")",?5,M,?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) ;IHS/ANMC/CLS 08/18/96
;----- END IHS MODIFICATIONS
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,$E(B(4),1,17) D:"AUEMSPCY"[LRSS B I "SPCYEMAU"'[LRSS D W
; ----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1026
D:$Y>(IOSL-8) H1 Q:LR("Q")
W:B(2)>0 !
D:LRSS="BB" D
W ?33,$J(N,4),?38,$E(B(4),1,17) ; SITE/SPEC cannot be > 17 characters
D:"AUEMSPCY"[LRSS B
I "SPCYEMAU"'[LRSS D W
; ----- END IHS/OIT/MKK MODIFICATION LR*5.2*1026
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
; ----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1026 -- DO NOT use special lookup
S DIC=^DIC(X,0,"GL"),DIC(0)="INZ",X=DA D ^DIC Q:Y=-1
; ----- END IHS/OIT/MKK MODIFICATION LR*5.2*1026
S SSN=$P(Y(0),"^",9),LRP=$P(Y(0),"^") K DIC,DA,Y
D SSN^LRU
; ----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1026
; S:P(0)'="PATIENT" LRP="#"_LRP ; Comment out this line
; ----- END IHS/OIT/MKK MODIFICATION LR*5.2*1026
;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
;----- BEGIN IHS MODIFICATIONS ;R*5.2*1018
S:P(0)'="VA PATIENT" LRP="#"_LRP I LRSS="AU",$D(^LR(LRDFN,"AU")) S X=^("AU"),B(5)=$S($P(X,"^",3):"",1:"%") S Y=+X D D^LRU S LRI=Y ;IHS/ANMC/CLS 08/18/96
;----- END IHS MODIFICATIONS
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)=""
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
; S ^TMP($J,$E(LRP,1,20),HRCN,N)=B(5)_"^"_LRDFN_"^"_LRI S (B(5),LRDFN,LRI,DFN,HRCN)="" Q ;IHS/ANMC/CLS 08/18/96
;----- END IHS MODIFICATIONS
; ----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1026 -- SITE/SPEC should only 16 Chars
S ^TMP($J,$E(LRP,1,20),HRCN,N)=$E(B(5),1,16)_"^"_LRDFN_"^"_LRI
S (B(5),LRDFN,LRI,DFN,HRCN)="" Q ;IHS/ANMC/CLS 08/18/96
; ----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1026
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:"")
; ----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1026 -- Don't use VA heading
W !,"# =Not IHS patient",?36,$S("AUBBCYEMSP"[LRSS:"% =Incomplete",1:"")
; ----- END IHS/OIT/MKK MODIFICATION LR*5.2*1026
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
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
D H Q:LR("Q") S B(2)=0 W !,$J(B,3),")",?5,M,?12,V Q ;IHS/ANMC/CLS 08/18/96
;----- END IHS MODIFICATIONS
H2 ;D H Q:LR("Q") W !,$J(B,3),")",?6,$P(M,"-",3),?12,V,?33,$J(N,4) S E=0 Q
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
D H Q:LR("Q") W !,$J(B,3),")",?5,M,?12,V,?33,$J(N,4) S E=0 Q ;IHS/ANMC/CLS 08/18/96
;----- END IHS MODIFICATIONS
;
END D V^LRU Q
LRUPA2 ;AVAMC/REG/WTY - LAB ACCESSION LIST BY PAT ;MAY 06, 2009 9:58 AM
+1 ;;5.2T1;LAB SERVICE;**1002,1018,1026**;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 ;Reference to DIC supported by IA #10006
+7 ;
+8 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 ;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)
+1 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+2 ;IHS/ANMC/CLS 08/18/96
IF $Y>(IOSL-8)
DO H
IF LR("Q")
QUIT
WRITE !,$JUSTIFY(B,3),")",?5,M,?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)
+3 ;----- END IHS MODIFICATIONS
+4 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
+5 QUIT
C ; D:$Y>(IOSL-8) H1 Q:LR("Q") W:B(2)>0 ! D:LRSS="BB" D W ?33,$J(N,4),?38,$E(B(4),1,17) D:"AUEMSPCY"[LRSS B I "SPCYEMAU"'[LRSS D W
+1 ; ----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1026
+2 IF $Y>(IOSL-8)
DO H1
IF LR("Q")
QUIT
+3 IF B(2)>0
WRITE !
+4 IF LRSS="BB"
DO D
+5 ; SITE/SPEC cannot be > 17 characters
WRITE ?33,$JUSTIFY(N,4),?38,$EXTRACT(B(4),1,17)
+6 IF "AUEMSPCY"[LRSS
DO B
+7 IF "SPCYEMAU"'[LRSS
DO W
+8 ; ----- END IHS/OIT/MKK MODIFICATION LR*5.2*1026
+9 QUIT
+10 ;
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 ; S DIC=^DIC(X,0,"GL"),DIC(0)="NZ",X=DA D ^DIC Q:Y=-1
+9 ; ----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1026 -- DO NOT use special lookup
+10 SET DIC=^DIC(X,0,"GL")
SET DIC(0)="INZ"
SET X=DA
DO ^DIC
IF Y=-1
QUIT
+11 ; ----- END IHS/OIT/MKK MODIFICATION LR*5.2*1026
+12 SET SSN=$PIECE(Y(0),"^",9)
SET LRP=$PIECE(Y(0),"^")
KILL DIC,DA,Y
+13 DO SSN^LRU
+14 ; ----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1026
+15 ; S:P(0)'="PATIENT" LRP="#"_LRP ; Comment out this line
+16 ; ----- END IHS/OIT/MKK MODIFICATION LR*5.2*1026
+17 ;I LRSS="AU",$D(^LR(LRDFN,"AU")) D
+18 ;.S X=^("AU"),B(5)=$S($P(X,"^",3):"",1:"%") S Y=+X D D^LRU S LRI=Y
+19 ;----- BEGIN IHS MODIFICATIONS ;R*5.2*1018
+20 ;IHS/ANMC/CLS 08/18/96
IF P(0)'="VA PATIENT"
SET LRP="#"_LRP
IF LRSS="AU"
IF $DATA(^LR(LRDFN,"AU"))
SET X=^("AU")
SET B(5)=$SELECT($PIECE(X,"^",3):"",1:"%")
SET Y=+X
DO D^LRU
SET LRI=Y
+21 ;----- END IHS MODIFICATIONS
+22 IF "CYSPEM"[LRSS
SET B(5)=""
Begin DoDot:1
+23 IF $DATA(^LR(LRDFN,LRSS,LRI,0))
IF '$PIECE(^(0),"^",3)
SET B(5)="%"
End DoDot:1
+24 ;S ^TMP($J,$E(LRP,1,20),SSN,N)=B(5)_"^"_LRDFN_"^"_LRI
+25 ;S (B(5),LRDFN,LRI)=""
+26 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+27 ; S ^TMP($J,$E(LRP,1,20),HRCN,N)=B(5)_"^"_LRDFN_"^"_LRI S (B(5),LRDFN,LRI,DFN,HRCN)="" Q ;IHS/ANMC/CLS 08/18/96
+28 ;----- END IHS MODIFICATIONS
+29 ; ----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1026 -- SITE/SPEC should only 16 Chars
+30 SET ^TMP($JOB,$EXTRACT(LRP,1,20),HRCN,N)=$EXTRACT(B(5),1,16)_"^"_LRDFN_"^"_LRI
+31 ;IHS/ANMC/CLS 08/18/96
SET (B(5),LRDFN,LRI,DFN,HRCN)=""
QUIT
+32 ; ----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1026
+33 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 ; W !,"# =Not VA patient",?36,$S("AUBBCYEMSP"[LRSS:"% =Incomplete",1:"")
+3 ; ----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1026 -- Don't use VA heading
+4 WRITE !,"# =Not IHS patient",?36,$SELECT("AUBBCYEMSP"[LRSS:"% =Incomplete",1:"")
+5 ; ----- END IHS/OIT/MKK MODIFICATION LR*5.2*1026
+6 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"
+7 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
+1 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+2 ;IHS/ANMC/CLS 08/18/96
DO H
IF LR("Q")
QUIT
SET B(2)=0
WRITE !,$JUSTIFY(B,3),")",?5,M,?12,V
QUIT
+3 ;----- END IHS MODIFICATIONS
H2 ;D H Q:LR("Q") W !,$J(B,3),")",?6,$P(M,"-",3),?12,V,?33,$J(N,4) S E=0 Q
+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,V,?33,$JUSTIFY(N,4)
SET E=0
QUIT
+3 ;----- END IHS MODIFICATIONS
+4 ;
END DO V^LRU
QUIT
