LRUPAD1 ;AVAMC/REG/WTY - LAB ACCESSION LIST COND'T ;9/25/00 [ 04/15/2003 9:28 AM ]
;;5.2;LR;**1018,1030**;NOV 01, 1997
;;5.2;LAB SERVICE;**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
;
Q:'$D(^LRO(68,LRAA,1,I,1,N,0)) ; IHS/OIT/MKK - LR*5.2*1030 -- Skip malformed Accessions
;
S X=$S($D(^LRO(68,LRAA,1,I,1,N,5,1,0)):^(0),1:""),C(3)=+X
S:'C(3) C(3)=LRU(1) S C(2)=$P(X,"^",2) S:'C(2) C(2)=LRU(1)
I $D(C(1)),C(1)'=C(2) Q
Q:'$D(^LRO(68,LRAA,1,I,1,N,3)) S X=^(3),LRI=$P(X,"^",5)
S A(3)=$P(X,"^",3),X=^LRO(68,LRAA,1,I,1,N,0),LRIFN=+X
S A(7)=$P(X,"^",7),A(8)=$P(X,"^",8) S:'A(3) A(3)=$P(X,"^",3)
S A(3)=$E(A(3),4,5)_"/"_$E(A(3),6,7)
S N(6)=$S($D(^LRO(68,LRAA,1,I,1,N,6)):^(6),1:"")
Q:'$D(^LR(LRIFN,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 MODIFICATIONS LR*5.2*1018 IHS -- Ignore Lookup routine
; 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 MODIFICATIONS LR*5.2*1018 IHS
S SSN=$P(Y(0),"^",9),LRP=$P(Y(0),"^") K DIC,DA,Y
D SSN^LRU
S:LRSS="CY" Q(2)=Q(2)+N(6),Q(1)=Q(1)+$P(N(6),"^",2) D V
W:$L(LRC(5)) !?4,LRC(5)
Q
V D:$Y>(IOSL-8) H Q:LR("Q") W !,$J(N,5)
;I LRSS'="AU",'$D(^LR(LRIFN,LRSS,LRI,0)) D Q
;.W ?8,$J(A(3),5),?14 W:P(0)'="PATIENT" "#"
;.W $E(LRP,1,20),?34,SSN(1)
;.W " Data NOT in lab results file #63 !!!"
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
I LRSS'="AU",'$D(^LR(LRIFN,LRSS,LRI,0)) W ?8,$J(A(3),5),?14 W:P(0)'="VA PATIENT" "#" W $E(LRP,1,18),?33,HRCN W " Data NOT in lab results file #63 !!!" Q ;IHS/ANMC/CLS 08/18/96
;----- END IHS MODIFICATIONS
;W ?8,$J(A(3),5),?14 W:P(0)'="PATIENT" "#"
;W $E(LRP,1,20),?34,SSN(1),?40,$E(A(7),1,5)
;----- BEGIN IHS MODIFICATIONS
W ?8,$J(A(3),5),?14 W:P(0)'="VA PATIENT" "#" W $E(LRP,1,18),?33,HRCN,?40,$E(A(7),1,5) ;IHS/ANMC/CLS 08/18/96
;----- END IHS MODIFICATIONS LR*5.2*1018
I LRSS="AU" Q:'$D(^LR(LRIFN,"AU")) S X=^("AU") D Q
.W ?45,$S('$P(X,"^",3):"%",1:"")
.S Y=+X D:Y D^LRU W ?47,Y
I $L(A(8)),"CYEMSP"[LRSS D
.W ?46,$E($S($D(^VA(200,A(8),0)):$P(^(0),"^"),1:A(8)),1,10)
I "CYEMSP"[LRSS D Q:"EMSP"[LRSS
.S X=^LR(LRIFN,LRSS,LRI,0),C(6)=$S($P(X,"^",12):"*",1:"")
.W:'$P(X,"^",3) ?57,"%"
.S:$D(^LR(LRIFN,LRSS,LRI,99,1,0)) LRC(5)=^(0)
.D O
I LRSS="CY" W ?72,$J(+N(6),5) W:$P(N(6),"^",2) "b" W ?79,C(6) Q
W ?46,$S(C(2)>0&(P(0)="STERILIZER"!(P(0)="ENVIRONMENTAL")):$E($P(^LAB(62,C(2),0),"^"),1,14),$D(^LAB(61,C(3),0)):$E($P(^LAB(61,C(3),0),"^"),1,13),1:"")
W S Z(2)=$S($P(^LR(LRIFN,LRSS,LRI,0),"^",3):"",LRSS="MI":"",1:"%"),Z=0
F A=0:1 S Z=$O(^LRO(68,LRAA,1,I,1,N,4,Z)) Q:'Z!(LR("Q")) D Q:LR("Q")
.S Z(3)=$S($D(^LRO(68,LRAA,1,I,1,N,4,Z,0)):^(0),1:"")
.D:+Z(3) L
Q
L W:A>0 !
W ?61,Z(2),?62,$E($P(^LAB(60,+Z(3),0),"^"),1,13)
S TECH=$P(Z(3),"^",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) H Q:LR("Q")
Q
O S C(4)=0
F E=0:1 S C(4)=$O(^LR(LRIFN,LRSS,LRI,2,C(4))) Q:'C(4)!(LR("Q")) D
.S C(3)=+^LR(LRIFN,LRSS,LRI,2,C(4),0)
.D T
Q:LR("Q") W:E=0 ?58,"No SNOMED code" Q
T D:$Y>(IOSL-8) H Q:LR("Q") W:E>0 !
W ?58,$S($D(^LAB(61,C(3),0)):$E($P(^LAB(61,C(3),0),"^"),1,14),1:"")
Q
H D H^LRUPAD W !
Q
LRUPAD1 ;AVAMC/REG/WTY - LAB ACCESSION LIST COND'T ;9/25/00 [ 04/15/2003 9:28 AM ]
+1 ;;5.2;LR;**1018,1030**;NOV 01, 1997
+2 ;;5.2;LAB SERVICE;**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 ; IHS/OIT/MKK - LR*5.2*1030 -- Skip malformed Accessions
IF '$DATA(^LRO(68,LRAA,1,I,1,N,0))
QUIT
+9 ;
+10 SET X=$SELECT($DATA(^LRO(68,LRAA,1,I,1,N,5,1,0)):^(0),1:"")
SET C(3)=+X
+11 IF 'C(3)
SET C(3)=LRU(1)
SET C(2)=$PIECE(X,"^",2)
IF 'C(2)
SET C(2)=LRU(1)
+12 IF $DATA(C(1))
IF C(1)'=C(2)
QUIT
+13 IF '$DATA(^LRO(68,LRAA,1,I,1,N,3))
QUIT
SET X=^(3)
SET LRI=$PIECE(X,"^",5)
+14 SET A(3)=$PIECE(X,"^",3)
SET X=^LRO(68,LRAA,1,I,1,N,0)
SET LRIFN=+X
+15 SET A(7)=$PIECE(X,"^",7)
SET A(8)=$PIECE(X,"^",8)
IF 'A(3)
SET A(3)=$PIECE(X,"^",3)
+16 SET A(3)=$EXTRACT(A(3),4,5)_"/"_$EXTRACT(A(3),6,7)
+17 SET N(6)=$SELECT($DATA(^LRO(68,LRAA,1,I,1,N,6)):^(6),1:"")
+18 IF '$DATA(^LR(LRIFN,0))
QUIT
SET X=^(0)
SET DA=$PIECE(X,"^",3)
SET (LRDPF,X)=$PIECE(X,"^",2)
+19 SET DIC="^DIC("
SET DIC(0)="Z"
DO ^DIC
IF Y=-1
QUIT
+20 SET P(0)=Y(0,0)
KILL DIC,Y
+21 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018 IHS -- Ignore Lookup routine
+22 ; S DIC=^DIC(X,0,"GL"),DIC(0)="NZ",X=DA D ^DIC Q:Y=-1
+23 SET DIC=^DIC(X,0,"GL")
SET DIC(0)="CINZ"
SET X=DA
DO ^DIC
IF Y=-1
QUIT
+24 ;----- END IHS MODIFICATIONS LR*5.2*1018 IHS
+25 SET SSN=$PIECE(Y(0),"^",9)
SET LRP=$PIECE(Y(0),"^")
KILL DIC,DA,Y
+26 DO SSN^LRU
+27 IF LRSS="CY"
SET Q(2)=Q(2)+N(6)
SET Q(1)=Q(1)+$PIECE(N(6),"^",2)
DO V
+28 IF $LENGTH(LRC(5))
WRITE !?4,LRC(5)
+29 QUIT
V IF $Y>(IOSL-8)
DO H
IF LR("Q")
QUIT
WRITE !,$JUSTIFY(N,5)
+1 ;I LRSS'="AU",'$D(^LR(LRIFN,LRSS,LRI,0)) D Q
+2 ;.W ?8,$J(A(3),5),?14 W:P(0)'="PATIENT" "#"
+3 ;.W $E(LRP,1,20),?34,SSN(1)
+4 ;.W " Data NOT in lab results file #63 !!!"
+5 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+6 ;IHS/ANMC/CLS 08/18/96
IF LRSS'="AU"
IF '$DATA(^LR(LRIFN,LRSS,LRI,0))
WRITE ?8,$JUSTIFY(A(3),5),?14
IF P(0)'="VA PATIENT"
WRITE "#"
WRITE $EXTRACT(LRP,1,18),?33,HRCN
WRITE " Data NOT in lab results file #63 !!!"
QUIT
+7 ;----- END IHS MODIFICATIONS
+8 ;W ?8,$J(A(3),5),?14 W:P(0)'="PATIENT" "#"
+9 ;W $E(LRP,1,20),?34,SSN(1),?40,$E(A(7),1,5)
+10 ;----- BEGIN IHS MODIFICATIONS
+11 ;IHS/ANMC/CLS 08/18/96
WRITE ?8,$JUSTIFY(A(3),5),?14
IF P(0)'="VA PATIENT"
WRITE "#"
WRITE $EXTRACT(LRP,1,18),?33,HRCN,?40,$EXTRACT(A(7),1,5)
+12 ;----- END IHS MODIFICATIONS LR*5.2*1018
+13 IF LRSS="AU"
IF '$DATA(^LR(LRIFN,"AU"))
QUIT
SET X=^("AU")
Begin DoDot:1
+14 WRITE ?45,$SELECT('$PIECE(X,"^",3):"%",1:"")
+15 SET Y=+X
IF Y
DO D^LRU
WRITE ?47,Y
End DoDot:1
QUIT
+16 IF $LENGTH(A(8))
IF "CYEMSP"[LRSS
Begin DoDot:1
+17 WRITE ?46,$EXTRACT($SELECT($DATA(^VA(200,A(8),0)):$PIECE(^(0),"^"),1:A(8)),1,10)
End DoDot:1
+18 IF "CYEMSP"[LRSS
Begin DoDot:1
+19 SET X=^LR(LRIFN,LRSS,LRI,0)
SET C(6)=$SELECT($PIECE(X,"^",12):"*",1:"")
+20 IF '$PIECE(X,"^",3)
WRITE ?57,"%"
+21 IF $DATA(^LR(LRIFN,LRSS,LRI,99,1,0))
SET LRC(5)=^(0)
+22 DO O
End DoDot:1
IF "EMSP"[LRSS
QUIT
+23 IF LRSS="CY"
WRITE ?72,$JUSTIFY(+N(6),5)
IF $PIECE(N(6),"^",2)
WRITE "b"
WRITE ?79,C(6)
QUIT
+24 WRITE ?46,$SELECT(C(2)>0&(P(0)="STERILIZER"!(P(0)="ENVIRONMENTAL")):$EXTRACT($PIECE(^LAB(62,C(2),0),"^"),1,14),$DATA(^LAB(61,C(3),0)):$EXTRACT($PIECE(^LAB(61,C(3),0),"^"),1,13),1:"")
W SET Z(2)=$SELECT($PIECE(^LR(LRIFN,LRSS,LRI,0),"^",3):"",LRSS="MI":"",1:"%")
SET Z=0
+1 FOR A=0:1
SET Z=$ORDER(^LRO(68,LRAA,1,I,1,N,4,Z))
IF 'Z!(LR("Q"))
QUIT
Begin DoDot:1
+2 SET Z(3)=$SELECT($DATA(^LRO(68,LRAA,1,I,1,N,4,Z,0)):^(0),1:"")
+3 IF +Z(3)
DO L
End DoDot:1
IF LR("Q")
QUIT
+4 QUIT
L IF A>0
WRITE !
+1 WRITE ?61,Z(2),?62,$EXTRACT($PIECE(^LAB(60,+Z(3),0),"^"),1,13)
+2 SET TECH=$PIECE(Z(3),"^",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 H
IF LR("Q")
QUIT
+7 QUIT
O SET C(4)=0
+1 FOR E=0:1
SET C(4)=$ORDER(^LR(LRIFN,LRSS,LRI,2,C(4)))
IF 'C(4)!(LR("Q"))
QUIT
Begin DoDot:1
+2 SET C(3)=+^LR(LRIFN,LRSS,LRI,2,C(4),0)
+3 DO T
End DoDot:1
+4 IF LR("Q")
QUIT
IF E=0
WRITE ?58,"No SNOMED code"
QUIT
T IF $Y>(IOSL-8)
DO H
IF LR("Q")
QUIT
IF E>0
WRITE !
+1 WRITE ?58,$SELECT($DATA(^LAB(61,C(3),0)):$EXTRACT($PIECE(^LAB(61,C(3),0),"^"),1,14),1:"")
+2 QUIT
H DO H^LRUPAD
WRITE !
+1 QUIT
