- LRUPAD2 ;AVAMC/REG/WTY - LAB ACCESSION LIST BY PATIENT ;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
- ;
- 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)
- 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
- 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))=""
- 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
- 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")) 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)=""
- 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:"")
- 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
- ;
- END D V^LRU Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUPAD2 3472 printed Mar 13, 2025@21:26:28 Page 2
- LRUPAD2 ;AVAMC/REG/WTY - LAB ACCESSION LIST BY PATIENT ;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 ;
- +6 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 DO H
- if LR("Q")
- QUIT
- +1 WRITE !,$JUSTIFY(B,3),")",?6,$PIECE(M,"-",3),?11,$EXTRACT(V,1,19),?31,$JUSTIFY(N,5)
- +2 SET LRX=^TMP($JOB,V,M,O,N)
- +3 WRITE ?37,$EXTRACT($PIECE(LRX,"^"),1,5),?44,$PIECE(LRX,"^",5),?52,$EXTRACT($PIECE(LRX,"^",2),1,5)
- +4 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 if $Y>(IOSL-8)
- DO H
- if LR("Q")
- QUIT
- +1 WRITE !,$JUSTIFY(B,3),")",?6,$PIECE(M,"-",3),?11,$EXTRACT(V,1,19)
- SET N=0
- +2 FOR E=0:1
- SET N=$ORDER(^TMP($JOB,V,M,O,N))
- if 'N!(LR("Q"))
- QUIT
- Begin DoDot:1
- +3 SET LRX=^TMP($JOB,V,M,O,N)
- SET LRDFN=$PIECE(LRX,"^",3)
- SET LRI=$PIECE(LRX,"^",4)
- +4 if $Y>(IOSL-8)
- DO H2
- if LR("Q")
- QUIT
- DO C
- End DoDot:1
- if LR("Q")
- QUIT
- +5 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 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)
- +2 if B(5)
- SET B(5)=$PIECE(^LAB(61,B(5),0),"^")
- +3 if '$DATA(^LRO(68,LRAA,1,I,1,N,3))
- QUIT
- SET X=^(3)
- +4 SET A(3)=$PIECE(X,"^",3)
- SET LRI=$PIECE(X,"^",5)
- +5 SET X=^LRO(68,LRAA,1,I,1,N,0)
- SET LRDFN=+X
- +6 SET A(3)=$SELECT(A(3):A(3),1:$PIECE(X,"^",3))
- +7 SET A(3)=$EXTRACT(A(3),4,5)_"/"_$EXTRACT(A(3),6,7)
- +8 SET LRF=$PIECE(^LRO(68,LRAA,1,I,1,N,0),"^",7)
- +9 if '$DATA(^LR(LRDFN,0))
- QUIT
- SET X=^(0)
- SET DA=$PIECE(X,"^",3)
- SET (LRDPF,X)=$PIECE(X,"^",2)
- +10 SET DIC="^DIC("
- SET DIC(0)="Z"
- DO ^DIC
- if Y=-1
- QUIT
- +11 SET P(0)=Y(0,0)
- KILL DIC,Y
- +12 SET DIC=^DIC(X,0,"GL")
- SET DIC(0)="NZ"
- SET X=DA
- DO ^DIC
- if Y=-1
- QUIT
- +13 SET SSN=$PIECE(Y(0),"^",9)
- SET LRP=$PIECE(Y(0),"^")
- KILL DIC,DA,Y
- +14 DO SSN^LRU
- +15 if P(0)'="PATIENT"
- SET LRP="#"_LRP
- +16 IF LRSS="AU"
- IF $DATA(^LR(LRDFN,"AU"))
- SET B(5)=$SELECT('$PIECE(^("AU"),"^",3):"%",1:"")
- +17 if '$LENGTH(SSN)
- QUIT
- +18 SET ^TMP($JOB,$EXTRACT(LRP,1,20),SSN,I,N)=A(3)_"^"_B(5)_"^"_LRDFN_"^"_LRI_"^"_$EXTRACT(LRF,1,7)
- +19 SET (B(5),LRDFN,LRI)=""
- +20 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 WRITE !,"# = Not VA patient",?36,$SELECT("AUBBCYEMSP"[LRSS:"% =Incomplete",1:"")
- +4 WRITE !,"Count",?7,"ID",?11,"Patient",?32,"ACC#"
- +5 IF "AUCYEMSP"'[LRSS
- Begin DoDot:1
- +6 WRITE ?37,"Date",?44,"Loc",?52,"Specimen",?64,"Test",?76,"Tech"
- +7 WRITE !,LR("%")
- End DoDot:1
- +8 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 ;
- END DO V^LRU
- QUIT
