- 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
