source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRUPAD2.m@ 1398

Last change on this file since 1398 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.3 KB
Line 
1LRUPAD2 ;AVAMC/REG/WTY - LAB ACCESSION LIST BY PATIENT ;9/25/00
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 S ZTRTN="QUE^LRUPAD2" D BEG^LRUTL G:POP!($D(ZTSK)) END
8QUE U IO K ^TMP($J) D L^LRU,S^LRU D:IOST?1"C".E WAIT^LRU
9 S V(1)=V(1)-1,LRI=""
10 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
11 D H S LR("F")=1,V=0 F B=1:1 S V=$O(^TMP($J,V)) Q:V=""!(LR("Q")) D XT
12 W:IOST'?1"C".E&($E(IOST,1,2)'="P-"!($D(LR("FORM")))) @IOF
13 D END,END^LRUTL Q
14NEW D H Q:LR("Q")
15 W !,$J(B,3),")",?6,$P(M,"-",3),?11,$E(V,1,19),?31,$J(N,5)
16 S LRX=^TMP($J,V,M,O,N)
17 W ?37,$E($P(LRX,"^"),1,5),?44,$P(LRX,"^",5),?52,$E($P(LRX,"^",2),1,5)
18 Q
19W S Z(2)=$S('$D(^LR(LRDFN,LRSS,LRI,0)):"",$P(^(0),"^",3):"",LRSS="MI":"",1:"%"),Z=0
20 F A=0:1 S Z=$O(^LRO(68,LRAA,1,O,1,N,4,Z)) Q:'Z!(LR("Q")) D
21 .S Z(1)=^LRO(68,LRAA,1,O,1,N,4,Z,0) D:+Z(1) T
22 Q
23O Q:LR("Q") Q:LRSS="AU"
24 I '$D(^LR(LRDFN,LRSS,LRI,0)) W ?40,"Entry not in lab data file." Q
25 S Z(2)=$S($P(^LR(LRDFN,LRSS,LRI,0),"^",3):"",1:"%")
26 S C(4)=0
27 F F=0:1 S C(4)=$O(^LR(LRDFN,LRSS,LRI,2,C(4))) Q:'C(4)!(LR("Q")) D
28 .S C(3)=+^LR(LRDFN,LRSS,LRI,2,C(4),0) D L
29 Q:LR("Q") W:F=0 ?46,"No SNOMED code" Q
30L D:$Y>(IOSL-8) H2 Q:LR("Q") W:F>0 !
31 W ?44,Z(2)
32 W ?45,$S($D(^LAB(61,C(3),0)):$E($P(^LAB(61,C(3),0),"^"),1,26),1:"")
33 Q
34T W:A>0 !
35 W ?59,$E($P(^LAB(60,+Z(1),0),"^"),1,15)
36 S TECH=$P(Z(1),"^",4)
37 S:TECH?1N.N TECH=$P($G(^VA(200,TECH,0)),"^",2)
38 W ?76,$E(TECH,1,4)
39 K TECH
40 D:$Y>(IOSL-8) NEW Q:LR("Q")
41 Q
42XT S M=0 F Y=0:0 S M=$O(^TMP($J,V,M)) Q:M=""!(LR("Q")) D A
43 Q
44A F O=0:0 S O=$O(^TMP($J,V,M,O)) Q:'O!(LR("Q")) D B
45 Q
46B D:$Y>(IOSL-8) H Q:LR("Q")
47 W !,$J(B,3),")",?6,$P(M,"-",3),?11,$E(V,1,19) S N=0
48 F E=0:1 S N=$O(^TMP($J,V,M,O,N)) Q:'N!(LR("Q")) D Q:LR("Q")
49 .S LRX=^TMP($J,V,M,O,N),LRDFN=$P(LRX,"^",3),LRI=$P(LRX,"^",4)
50 .D:$Y>(IOSL-8) H2 Q:LR("Q") D C
51 Q
52C W:E>0 ! W ?31,$J(N,5),?37,$J($P(LRX,"^"),5),?44,$P(LRX,"^",5)
53 W ?52,$E($P(LRX,"^",2),1,5) D W:"MICHBL"[LRSS,O:"AUCYEMSP"[LRSS
54 Q
55P S (B(5),C(1))=""
56 S:$D(^LRO(68,LRAA,1,I,1,N,5,1,0)) X=^(0),B(5)=+X,C(1)=$P(X,"^",2)
57 S:B(5) B(5)=$P(^LAB(61,B(5),0),"^")
58 Q:'$D(^LRO(68,LRAA,1,I,1,N,3)) S X=^(3)
59 S A(3)=$P(X,"^",3),LRI=$P(X,"^",5)
60 S X=^LRO(68,LRAA,1,I,1,N,0),LRDFN=+X
61 S A(3)=$S(A(3):A(3),1:$P(X,"^",3))
62 S A(3)=$E(A(3),4,5)_"/"_$E(A(3),6,7)
63 S LRF=$P(^LRO(68,LRAA,1,I,1,N,0),"^",7)
64 Q:'$D(^LR(LRDFN,0)) S X=^(0),DA=$P(X,"^",3),(LRDPF,X)=$P(X,"^",2)
65 S DIC="^DIC(",DIC(0)="Z" D ^DIC Q:Y=-1
66 S P(0)=Y(0,0) K DIC,Y
67 S DIC=^DIC(X,0,"GL"),DIC(0)="NZ",X=DA D ^DIC Q:Y=-1
68 S SSN=$P(Y(0),"^",9),LRP=$P(Y(0),"^") K DIC,DA,Y
69 D SSN^LRU
70 S:P(0)'="PATIENT" LRP="#"_LRP
71 I LRSS="AU",$D(^LR(LRDFN,"AU")) S B(5)=$S('$P(^("AU"),"^",3):"%",1:"")
72 Q:'$L(SSN)
73 S ^TMP($J,$E(LRP,1,20),SSN,I,N)=A(3)_"^"_B(5)_"^"_LRDFN_"^"_LRI_"^"_$E(LRF,1,7)
74 S (B(5),LRDFN,LRI)=""
75 Q
76H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
77 D F^LRU
78 W !,LRO(68)," ACCESSIONS(",LRSTR,"-",LRLST,")"
79 W !,"# = Not VA patient",?36,$S("AUBBCYEMSP"[LRSS:"% =Incomplete",1:"")
80 W !,"Count",?7,"ID",?11,"Patient",?32,"ACC#"
81 I "AUCYEMSP"'[LRSS D
82 .W ?37,"Date",?44,"Loc",?52,"Specimen",?64,"Test",?76,"Tech"
83 .W !,LR("%")
84 Q
85H1 D H W ! Q
86H2 D H Q:LR("Q") W !,$J(B,3),")",?6,$P(M,"-",3),?11,$E(V,1,19) Q
87 ;
88END D V^LRU Q
Note: See TracBrowser for help on using the repository browser.