source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRSORA3.m

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

initial load of FOIAVistA 6/30/08 version

File size: 3.4 KB
Line 
1LRSORA3 ;SLC/KCM - SEARCH LAB DATA AND PRINT REPORT ;8/28/89 12:07 ;
2 ;;5.2;LAB SERVICE;**1,344**;Sep 27, 1994
3BUILD ;
4 S LRLOG="I "
5 F %=1:1:$L(LRTST(0)) D
6 . S LRLOG=LRLOG_$S($E(LRTST(0),%)?1A:"T("_($A(LRTST(0),%)-64)_")",1:$E(LRTST(0),%))
7 S LRDFN=0,LRLDFN=0,LREND=0
8 D SHORT:'LRLONG,LONG:LRLONG
9 Q
10SHORT ;
11 S LRVDT=$P(LREDT,".",1)-.01
12 F S LRVDT=$O(^LRO(69,LRVDT)) Q:LRVDT=""!(LRVDT>LRSDT) D
13 . S LRLLOC=""
14 . F S LRLLOC=$O(^LRO(69,LRVDT,1,"AN",LRLLOC)) Q:LRLLOC="" D
15 .. S LRDFN=0
16 .. F S LRDFN=$O(^LRO(69,LRVDT,1,"AN",LRLLOC,LRDFN)) Q:LRDFN<1 D GIDT
17 Q
18GIDT ;
19 S LRIDT=0
20 F S LRIDT=$O(^LRO(69,LRVDT,1,"AN",LRLLOC,LRDFN,LRIDT)) Q:LRIDT<1 D EVTW
21 Q
22LONG ;
23 S LRSDT=9999998-LRSDT,LREDT=9999999-LREDT
24 S LRDFN=0 F S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1 D GDATA
25 Q
26GDATA ;
27 S LRIDT=LRSDT
28 F S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT=""!(LRIDT>LREDT) D
29 . D:$L($P(^LR(LRDFN,"CH",LRIDT,0),U,3)) EVTW
30 Q
31EVTW ;
32 S %=$G(^LR(LRDFN,"CH",LRIDT,0)) Q:'$L(%)
33 I LRAA S LRAAA=$P($P(%,U,6)," ") Q:'$D(LRAA(LRAAA))#2
34 K V F J=1:1:LRTST S T(J)=0
35 D EVAL Q:$G(LRNOP) X LRLOG
36 I $T S LRIDT1=0 F S LRIDT1=$O(V(LRIDT1)) Q:LRIDT1<1 D
37 . S LRSUB=0 F S LRSUB=$O(V(LRIDT1,LRSUB)) Q:LRSUB<1 D SET
38 Q
39EVAL ;
40 F J=1:1:LRTST X LRTST(J,1) D
41 . I $T S T(J)=1
42 . I S X=$P(LRTST(J,3),U,1)
43 . I S $P(V(LRIDT,X),U,1)=$P(^LR(LRDFN,"CH",LRIDT,X),U,1)
44 . I S $P(V(LRIDT,X),U,2)=$P(^LR(LRDFN,"CH",LRIDT,X),U,2)
45 . I S $P(V(LRIDT,X),U,3)=$P(LRTST(J,2),U,1)
46 Q
47SET ;
48 K LRWRD
49 S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) Q:LRDPF<1!(LRDPF=62.3) D PT^LRX
50 I LRPTS Q:'$D(LRPTS(DFN))
51 S %=^LR(LRDFN,"CH",LRIDT1,0),LRAN=$P(^(0),U,6),LRLOC=$P(^(0),U,11)
52 Q:LRLOC="" I LRLCS Q:'$D(LRLCS(LRLOC))
53 ;S LRWRD="" S:LRDPF=2 LRWRD=$S($D(^DPT(DFN,.1)):^(.1),1:"")
54 S LRWRD=$G(^DPT(DFN,.1))
55 S (Y1,LRDAT)=$P(^LR(LRDFN,"CH",LRIDT1,0),U,1),Y2=1
56 S LRCDT=$$DDDATE^LRAFUNC1(Y1,Y2) K Y1,Y2
57 S LRSUB1=$S(LRSRT="P":PNM_SSN,1:LRLOC)
58 S LRSUB2=$S(LRSRT="P":LRDAT,1:PNM_SSN)
59 S LRSUB3=$S(LRSRT="P":LRLOC,1:LRDAT)
60 S LRSPEC=$P(^LR(LRDFN,"CH",LRIDT1,0),U,5) D RRNG
61 S LRSPEC=$P($G(^LAB(61,LRSPEC,0)),U)
62 S LRTEST=LRTSTX
63 S LRVAL=$P(V(LRIDT1,LRSUB),U)
64 S LRMRK=$P(V(LRIDT1,LRSUB),U,2)
65 I LRSRT="P" S ^TMP("LR",$J,LRSUB1,LRSPEC,LRTEST,LRIDT)=PNM_U_SSN_U_LRLOC_U_U_LRSPEC_U_U_LRLO_U_LRHI_U_LRVAL_U_LRMRK_U_LRTHER_U_LRWRD_U_LRAN_U_LRDAT_U_LRTEST_U_LRUNITS
66 I LRSRT'="P" S ^TMP("LR",$J,LRLOC,LRSUB2,LRSPEC,LRTEST,LRIDT)=PNM_U_SSN_U_LRLOC_U_U_LRSPEC_U_U_LRLO_U_LRHI_U_LRVAL_U_LRMRK_U_LRTHER_U_LRWRD_U_LRAN_U_LRDAT_U_LRTEST_U_LRUNITS
67 S C=0
68 F S C=$O(^LR(LRDFN,"CH",LRIDT,1,C)) Q:'C D
69 . I LRSRT="P" S ^TMP("LR",$J,LRSUB1,LRSPEC,LRTEST,LRIDT,"COM",C)=^LR(LRDFN,"CH",LRIDT,1,C,0)
70 . I LRSRT'="P" S ^TMP("LR",$J,LRLOC,LRSUB2,LRSPEC,LRTEST,LRIDT,"COM",C)=^LR(LRDFN,"CH",LRIDT,1,C,0)
71 Q
72RRNG ;
73 N LRFLAG
74 S (LRHI,LRLO,LRTHER,LRFLAG)="",X="CH;"_LRSUB_";1",X=$O(^LAB(60,"C",X,0))
75 S LRTSTX=$P(^LAB(60,X,.1),U)
76 S LRUNITS=$P($G(^LAB(60,X,1,LRSPEC,0)),"^",7)
77 S:$L(X)&$L(LRSPEC) X=$S($D(^LAB(60,X,1,LRSPEC,0)):^(0),1:"") Q:X=""
78 ;
79 ; check for ranges in file 63
80 D CHK63
81 ;
82 S LRTHER=$P(X,U,11)'=""&($P(X,U,12)'="")
83 S LRLO=$S('LRTHER:$P(X,U,2),1:$P(X,U,11))
84 S LRHI=$S('LRTHER:$P(X,U,3),1:$P(X,U,12))
85 I 'LRFLAG D
86 . S @("LRLO="_$S($L(LRLO):LRLO,1:""""""))
87 . S @("LRHI="_$S($L(LRHI):LRHI,1:""""""))
88 Q
89 ;
90CHK63 ;
91 N LR63DAT,PC5
92 S LR63DAT=$G(^LR(LRDFN,"CH",LRIDT,LRSUB))
93 I $G(^LR(LRDFN,"CH",LRIDT,"NPC"))>1,$P(LR63DAT,U,5,12)'="" S LRFLAG=1
94 I LRFLAG D
95 .S PC5=$P(LR63DAT,U,5)
96 .S PC5=$TR(PC5,"!","^")
97 .S X=PC5
98 Q
Note: See TracBrowser for help on using the repository browser.