- LRUPAD2 ;AVAMC/REG/WTY - LAB ACCESSION LIST BY PATIENT ;9/25/00 [ 04/15/2003 9:38 AM ]
- ;;5.2;LR;**1002,1018,1020,1030**;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
- ;
- 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)
- ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- D H Q:LR("Q") W !,$J(B,3),")",?5,M,?12,$E(V,1,19),?31,$J(N,5),?37 S LRX=^TMP($J,V,M,O,N) W $E($P(LRX,"^"),1,5),?44,$P(LRX,"^",5),?52,$E($P(LRX,"^",2),1,5) Q ;IHS/ANMC/CLS 08/18/96
- ;----- END IHS MODIFICATIONS
- 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
- ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- D:$Y>(IOSL-8) H Q:LR("Q") W !,$J(B,3),")",?5,M,?12,$E(V,1,19) S N=0 ;IHS/ANMC/CLS 08/18/96
- ;----- END IHS MODIFICATIONS
- 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))=""
- Q:'$D(^LRO(68,LRAA,1,I,1,N,0)) ; IHS/OIT/MKK - LR*5.2*1030 -- Skip malformed Accessions
- ;
- 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
- ;----- BEGIN IHS/OIT/MKK MOD LR*5.2*1020 - Don't use special lookup
- ;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/OIT/MKK MOD LR*5.2*1020
- S SSN=$P(Y(0),"^",9),LRP=$P(Y(0),"^") K DIC,DA,Y
- D SSN^LRU
- ;S:P(0)'="PATIENT" LRP="#"_LRP
- ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- S:P(0)'="VA PATIENT" LRP="#"_LRP ;IHS/ANMC/CLS 08/18/96
- ;----- END IHS MODIFICATIONS
- 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)=""
- ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- Q:'$L(HRCN) S ^TMP($J,$E(LRP,1,20),HRCN,I,N)=A(3)_"^"_B(5)_"^"_LRDFN_"^"_LRI_"^"_$E(LRF,1,7) S (B(5),LRDFN,LRI,DFN,HRCN)="" Q ;IHS/ANMC/CLS 08/18/96
- ;----- END IHS MODIFICATIONS
- 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:"") ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- W !,"# = Not IHS patient",?36,$S("AUBBCYEMSP"[LRSS:"% =Incomplete",1:"") ;IHS/ANMC/CLS 08/18/96
- ;----- END IHS MODIFICATIONS
- 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
- ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- D H Q:LR("Q") W !,$J(B,3),")",?5,M,?12,$E(V,1,19) Q ;IHS/ANMC/CLS 08/18/96
- ;
- END D V^LRU Q
- LRUPAD2 ;AVAMC/REG/WTY - LAB ACCESSION LIST BY PATIENT ;9/25/00 [ 04/15/2003 9:38 AM ]
- +1 ;;5.2;LR;**1002,1018,1020,1030**;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 ;
- +7 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 ;D H Q:LR("Q")
- +1 ;W !,$J(B,3),")",?6,$P(M,"-",3),?11,$E(V,1,19),?31,$J(N,5)
- +2 ;S LRX=^TMP($J,V,M,O,N)
- +3 ;W ?37,$E($PAD2_source.html#xP">PAD2_source.html#xPAD2_source.html#xP">P">PAD2_source.html#xP">P(LRX,"^"),1,5),?44,$PAD2_source.html#xP">PAD2_source.html#xPAD2_source.html#xP">P">PAD2_source.html#xP">P(LRX,"^",5),?52,$E($PAD2_source.html#xP">PAD2_source.html#xPAD2_source.html#xP">P">PAD2_source.html#xP">P(LRX,"^",2),1,5)
- +4 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- +5 ;IHS/ANMC/CLS 08/18/96
- DO H
- IF LR("Q")
- QUIT
- WRITE !,$JUSTIFY(B,3),")",?5,M,?12,$EXTRACT(V,1,19),?31,$JUSTIFY(N,5),?37
- SET LRX=^TMP($JOB,V,M,O,N)
- WRITE $EXTRACT($PIECE(LRX,"^"),1,5),?44,$PIECE(LRX,"^",5),?52,$EXTRACT($PIECE(LRX,"^",2),1,5)
- QUIT
- +6 ;----- END IHS MODIFICATIONS
- +7 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 ;D:$Y>(IOSL-8) H Q:LR("Q")
- +1 ;W !,$J(B,3),")",?6,$P(M,"-",3),?11,$E(V,1,19) S N=0
- +2 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- +3 ;IHS/ANMC/CLS 08/18/96
- IF $Y>(IOSL-8)
- DO H
- IF LR("Q")
- QUIT
- WRITE !,$JUSTIFY(B,3),")",?5,M,?12,$EXTRACT(V,1,19)
- SET N=0
- +4 ;----- END IHS MODIFICATIONS
- +5 FOR E=0:1
- SET N=$ORDER(^TMP($JOB,V,M,O,N))
- IF 'N!(LR("Q"))
- QUIT
- Begin DoDot:1
- +6 SET LRX=^TMP($JOB,V,M,O,N)
- SET LRDFN=$PIECE(LRX,"^",3)
- SET LRI=$PIECE(LRX,"^",4)
- +7 IF $Y>(IOSL-8)
- DO H2
- IF LR("Q")
- QUIT
- DO C
- End DoDot:1
- IF LR("Q")
- QUIT
- +8 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 ; IHS/OIT/MKK - LR*5.2*1030 -- Skip malformed Accessions
- IF '$DATA(^LRO(68,LRAA,1,I,1,N,0))
- QUIT
- +2 ;
- +3 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)
- +4 IF B(5)
- SET B(5)=$PIECE(^LAB(61,B(5),0),"^")
- +5 IF '$DATA(^LRO(68,LRAA,1,I,1,N,3))
- QUIT
- SET X=^(3)
- +6 SET A(3)=$PIECE(X,"^",3)
- SET LRI=$PIECE(X,"^",5)
- +7 SET X=^LRO(68,LRAA,1,I,1,N,0)
- SET LRDFN=+X
- +8 SET A(3)=$SELECT(A(3):A(3),1:$PIECE(X,"^",3))
- +9 SET A(3)=$EXTRACT(A(3),4,5)_"/"_$EXTRACT(A(3),6,7)
- +10 SET LRF=$PIECE(^LRO(68,LRAA,1,I,1,N,0),"^",7)
- +11 IF '$DATA(^LR(LRDFN,0))
- QUIT
- SET X=^(0)
- SET DA=$PIECE(X,"^",3)
- SET (LRDPF,X)=$PIECE(X,"^",2)
- +12 SET DIC="^DIC("
- SET DIC(0)="Z"
- DO ^DIC
- IF Y=-1
- QUIT
- +13 SET P(0)=Y(0,0)
- KILL DIC,Y
- +14 ;----- BEGIN IHS/OIT/MKK MOD LR*5.2*1020 - Don't use special lookup
- +15 ;S DIC=^DIC(X,0,"GL"),DIC(0)="NZ",X=DA D ^DIC Q:Y=-1
- +16 SET DIC=^DIC(X,0,"GL")
- SET DIC(0)="CINZ"
- SET X=DA
- DO ^DIC
- IF Y=-1
- QUIT
- +17 ; ----- END IHS/OIT/MKK MOD LR*5.2*1020
- +18 SET SSN=$PIECE(Y(0),"^",9)
- SET LRP=$PIECE(Y(0),"^")
- KILL DIC,DA,Y
- +19 DO SSN^LRU
- +20 ;S:P(0)'="PATIENT" LRP="#"_LRP
- +21 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- +22 ;IHS/ANMC/CLS 08/18/96
- IF P(0)'="VA PATIENT"
- SET LRP="#"_LRP
- +23 ;----- END IHS MODIFICATIONS
- +24 IF LRSS="AU"
- IF $DATA(^LR(LRDFN,"AU"))
- SET B(5)=$SELECT('$PIECE(^("AU"),"^",3):"%",1:"")
- +25 ;Q:'$L(SSN)
- +26 ;S ^TMP($J,$E(LRP,1,20),SSN,I,N)=A(3)_"^"_B(5)_"^"_LRDFN_"^"_LRI_"^"_$E(LRF,1,7)
- +27 ;S (B(5),LRDFN,LRI)=""
- +28 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- +29 ;IHS/ANMC/CLS 08/18/96
- IF '$LENGTH(HRCN)
- QUIT
- SET ^TMP($JOB,$EXTRACT(LRP,1,20),HRCN,I,N)=A(3)_"^"_B(5)_"^"_LRDFN_"^"_LRI_"^"_$EXTRACT(LRF,1,7)
- SET (B(5),LRDFN,LRI,DFN,HRCN)=""
- QUIT
- +30 ;----- END IHS MODIFICATIONS
- +31 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 ;W !,"# = Not VA patient",?36,$S("AUBBCYEMSP"[LRSS:"% =Incomplete",1:"") ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- +4 ;IHS/ANMC/CLS 08/18/96
- WRITE !,"# = Not IHS patient",?36,$SELECT("AUBBCYEMSP"[LRSS:"% =Incomplete",1:"")
- +5 ;----- END IHS MODIFICATIONS
- +6 WRITE !,"Count",?7,"ID",?11,"Patient",?32,"ACC#"
- +7 IF "AUCYEMSP"'[LRSS
- Begin DoDot:1
- +8 WRITE ?37,"Date",?44,"Loc",?52,"Specimen",?64,"Test",?76,"Tech"
- +9 WRITE !,LR("%")
- End DoDot:1
- +10 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 ;----- 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,$EXTRACT(V,1,19)
- QUIT
- +3 ;
- END DO V^LRU
- QUIT
