source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRUPA2.m@ 1006

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

initial load of WorldVistAEHR

File size: 3.4 KB
Line 
1LRUPA2 ;AVAMC/REG/WTY - LAB ACCESSION LIST BY PAT ;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 ;Reference to DIC supported by IA #10006
7 ;
8 S ZTRTN="QUE^LRUPA2" D BEG^LRUTL G:POP!($D(ZTSK)) END
9QUE U IO K ^TMP($J) S (B(5),C(1))="",N=N(1)-1
10 F B=0:0 S N=$O(^LRO(68,LRAA,1,LRAD,1,N)) Q:'N!(N>N(2)) S (B(5),C(1))="" S:$D(^LRO(68,LRAA,1,LRAD,1,N,5,1,0)) X=^(0),B(5)=+X,C(1)=$P(X,"^",2) D PRT
11 D L^LRU,S^LRU,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 K ^TMP($J) D END^LRUTL,END
14 Q
15W S X=$S($D(^LR(LRDFN,LRSS,LRI,0)):^(0),1:"") I X="" W ?50,"Not in lab results file" Q
16 S Z(2)=$S($P(X,"^",3):"","CHBBMI"[LRSS:"",1:"%"),Z=0 F A=0:1 S Z=$O(^LRO(68,LRAA,1,LRAD,1,N,4,Z)) Q:'Z!(LR("Q")) S Z(3)=^(Z,0) D:+Z(3) L
17 Q
18O S C(4)=0 I '$D(^LR(LRDFN,LRSS,LRI,0)) W ?40,"Entry not in lab result file #63." Q
19 F E=0:1 S C(4)=$O(^LR(LRDFN,LRSS,LRI,2,C(4))) Q:'C(4)!(LR("Q")) S C(3)=+^(C(4),0) D:$Y>(IOSL-8) H2 Q:LR("Q") W:E>0 ! W ?43,$S($D(^LAB(61,C(3),0)):$E($P(^(0),"^"),1,35),1:"")
20 Q:LR("Q") W:E=0 ?43,"No SNOMED code" Q
21L Q:LR("Q")!($P($G(^LAB(60,Z,0)),"^",4)="WK")
22 W:A=0 ?55,Z(2) W:A>0 !?55 W $S(LRSS="BB"&($P(Z(3),"^",4)=""):"%",1:"") W ?56,$E($P(^LAB(60,Z,0),"^"),1,19),?76 S X=$P(Z(3),"^",4) W $S('X:X,1:$P($G(^VA(200,X,0)),"^",2)) Q
23 ;
24XT S M=0 F Y=0:0 S M=$O(^TMP($J,V,M)) Q:M=""!(LR("Q")) D A
25 Q
26A D:$Y>(IOSL-8) H Q:LR("Q") W !,$J(B,3),")",?6,$P(M,"-",3),?12,V I LRSS="BB" W !?12,M," " S X=$O(^TMP($J,V,M,0)) S:X X=^(X),X=$P(X,"^",2),X=^LR(X,0) W " ",$P(X,"^",5)," ",$P(X,"^",6)
27 S N=0 F B(2)=0:1 S N=$O(^TMP($J,V,M,N)) Q:'N!(LR("Q")) S B(3)=^(N),B(4)=$P(B(3),"^"),LRI=$P(B(3),"^",3),LRDFN=$P(B(3),"^",2) D C
28 Q
29C D:$Y>(IOSL-8) H1 Q:LR("Q") W:B(2)>0 ! D:LRSS="BB" D W ?33,$J(N,4),?38,B(4) D:"AUEMSPCY"[LRSS B I "SPCYEMAU"'[LRSS D W
30 Q
31B S LRDFN=$P(B(3),"^",2),LRI=$P(B(3),"^",3)
32 D:"SPCYEM"[LRSS O
33 Q:LR("Q") W:LRSS="AU" ?40,LRI Q
34PRT Q:'$D(^LRO(68,LRAA,1,LRAD,1,N,3)) S X=^(3),A(3)=$P(X,"^",3)
35 S LRI=$P(X,"^",5),X=^LRO(68,LRAA,1,LRAD,1,N,0),LRDFN=+X
36 S A(3)=$S(A(3):A(3),1:$P(X,"^",3))
37 S B(5)=$S(B(5)>0:$P(^LAB(61,B(5),0),"^"),C(1)>0:$P(^LAB(62,C(1),0),"^"),1:"")
38 S B(5)=$S(B(5)]"":B(5),1:C(1))
39 Q:'$D(^LR(LRDFN,0)) S X=^(0),DA=$P(X,"^",3),(LRDPF,X)=$P(X,"^",2)
40 S DIC="^DIC(",DIC(0)="Z" D ^DIC Q:Y=-1
41 S P(0)=Y(0,0) K DIC,Y
42 S DIC=^DIC(X,0,"GL"),DIC(0)="NZ",X=DA D ^DIC Q:Y=-1
43 S SSN=$P(Y(0),"^",9),LRP=$P(Y(0),"^") K DIC,DA,Y
44 D SSN^LRU
45 S:P(0)'="PATIENT" LRP="#"_LRP
46 I LRSS="AU",$D(^LR(LRDFN,"AU")) D
47 .S X=^("AU"),B(5)=$S($P(X,"^",3):"",1:"%") S Y=+X D D^LRU S LRI=Y
48 I "CYSPEM"[LRSS S B(5)="" D
49 .I $D(^LR(LRDFN,LRSS,LRI,0)),'$P(^(0),"^",3) S B(5)="%"
50 S ^TMP($J,$E(LRP,1,20),SSN,N)=B(5)_"^"_LRDFN_"^"_LRI
51 S (B(5),LRDFN,LRI)=""
52 Q
53D S Y=+^LR($P(B(3),"^",2),"BB",$P(B(3),"^",3),0) D DT^LRU S B(4)=Y Q
54H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
55 D F^LRU W !,LRO(68)," ACCESSIONS for ",Z(1)," BY PATIENT"
56 W !,"# =Not VA patient",?36,$S("AUBBCYEMSP"[LRSS:"% =Incomplete",1:"")
57 W !,"Count",?7,"ID",?12,"Patient",?35,"ACC#" W ?36 W:"AUBBCYEMSP"'[LRSS "Specimen" W:LRSS="BB" "Specimen date" W:"AUCYEMSP"'[LRSS ?50,"Test",?76,"Tech" W:"CYEMSP"[LRSS ?43,"Organ/tissue" W:LRSS="AU" ?40,"Date/time of Autopsy"
58 W !,LR("%") Q
59H1 D H Q:LR("Q") S B(2)=0 W !,$J(B,3),")",?6,$P(M,"-",3),?12,V Q
60H2 D H Q:LR("Q") W !,$J(B,3),")",?6,$P(M,"-",3),?12,V,?33,$J(N,4) S E=0 Q
61 ;
62END D V^LRU Q
Note: See TracBrowser for help on using the repository browser.