source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRCAPDAR.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.8 KB
Line 
1LRCAPDAR ;DALOI/FHS/RBN - LAB DSS RESULTS EXTRACT (LAR)
2 ;;5.2;LAB SERVICE;**143,169,258,307,326**;Sep 27, 1994
3 ;
4 ; Call with Start Date (LRSDT) End Date (LREDT) FileMan format
5 ; Calling routine should have already purged ^LAR(64.036)
6EN S:$D(ZTQUEUED) ZTREQ="@"
7 I $S($G(LRSDT)'?7N:1,$G(LREDT)'?7N:1,1:0) Q
8 L +^LAR(64.036):2 G:'$T END
9 N DIR,DIC,DIE,X,I,LR3,LRAA,LRAD,LRAN,LRC,LRSPDT,LRSPTM,UID,Y,DLAYGO
10 S DLAYGO=64
11 D INIT
12 I LRSDT>LREDT S X=LRSDT,LRSDT=LREDT,LREDT=X
13 S LRX1=9999999-(LRSDT_.0001),LRX2=9999999-(LREDT_.235959)
14 S:'$D(^LAR(64.036,0))#2 ^LAR(64.036,0)="LAB DSS LAR EXTRACT^64.036^2"
15LR K LRSP
16 S LRDFN=0 F S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1 I $P($G(^LR(LRDFN,0)),U,2)=2 S LRN=^(0) D
17 . S DFN=$P(LRN,U,3),LRDPF=$P(LRN,U,2)
18 . S LRIDT=LRX2 F S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT<1!(LRIDT>LRX1) I $D(^(LRIDT,0)),$P(^(0),U,3) S LRVSPEC=$P(^(0),U,5),LRN0=^(0) D
19 . . Q:'$D(LRVSPEC(LRVSPEC)) S LRSP=$E(LRVSPEC(LRVSPEC))
20 . . S LRSB=0 F S LRSB=$O(LRSB(LRSP,LRSB)) Q:LRSB<2 I $D(^LR(LRDFN,"CH",LRIDT,LRSB)) S LRVR=^(LRSB) D SET
21 . . I $O(LRVV(0)) D FILE
22WRAP K DA,DR,DIC,DIE,DD,DO
23 S (X,DINUM)=1
24 S DIC="^LAR(64.036,",DIC(0)="LNM" D FILE^DICN S DA=+Y
25 G:Y<1 END
26 S DR="9///"_DT,DR(2,64.369)=".01///"_DT_";1///"_LRSDT_";2///"_LREDT_";3///"_$$NOW^LRAFUNC1_";4////"_$G(DUZ)
27 S DIE=DIC D ^DIE G END
28 Q
29SET S LRVV(+LRSB(LRSP,LRSB))=$P(LRVR,U)_U_$P(LRVR,U,2)_U_LRSB(LRSP,LRSB,64)
30 Q
31INIT ; ** This section modified by RBN to allow DSS to get all site/samples available from Lab
32 K LRVSPEC
33 N I,II
34 S I="B" F S I=$O(^ECX(727.2,1,I)) Q:I=""!(I>0) D
35 . S II=0 F S II=$O(^ECX(727.2,1,I,II)) Q:II<1 D
36 . . I $D(^LAB(61,II,0))#2 S LRVSPEC(II)=I_U_$P(^(0),U)
37 K LRSP
38TEST ;
39 S I=0 F S I=$O(^ECX(727.2,1,1,I)) Q:I<1 I $D(^(I,0)) S LRSP=$P(^(0),U,2) D
40 . S II=0 F S II=$O(^ECX(727.2,1,1,I,"LOC",II)) Q:II<1 S LRTS=+$G(^(II,0)) I LRTS D
41 . . S LRSB=$P($G(^LAB(60,LRTS,0)),";",2) I LRSB,$G(^(64)) S LRSB(LRSP,LRSB)=I_U_LRTS_U_$P(^(0),U),LRSB(LRSP,LRSB,64)=$P(^(64),U)
42 K LRTS Q
43TST Q ;S LRDBUG=1,LRSDT=2970100,LREDT=DT K ^LAR(64.036) G EN
44END L -^LAR(64.036)
45 K D,D0,D1,DA,DFN,DI,DIC,DIE,DR,I,II,LRDA,LRDPF,LRIDT,LRN,LRN0
46 K LRNOW,LRSB,LRSP,LRTS,LRVR,LRVSPEC,LRVV,LRX1,LRX2,X,DLAYGO
47 K LRDFN,D2,LRSP,LRTS,DINUM Q
48FILE K DR,DA,DIC,DIR,LRPROV
49 D UID
50 S LRN0T1=$P(LRN0,U),LRN0T2=$P(LRN0,U,3),LRPROV=$P(LRN0,U,10)
51 S $P(LRN0,U)=$S(LRN0T2<LRN0T1:LRN0T2,1:LRN0T1)
52 S X=$P(^LAR(64.036,0),U,3) S:X<2 X=2 F X=X:1 Q:'$D(^LAR(64.036,X))
53 S DA=X,DIC="^LAR(64.036,",DINUM=X,DIC(0)="LNMF"
54 S LRN0T1=$E($P($P(LRN0,U),".",2),1,4) S:'LRN0T1 LRN0T1=0 I LRN0T1,$E(LRN0T1,3,4)>59 S LRN0T1=$E(LRN0T1,1,2)_"59"
55 S LRN0T2=$E($P($P(LRN0,U,3),".",2),1,4) S:'LRN0T2 LRN0T2=0
56 S DIC("DR")="1///"_LRDPF_";2///"_DFN_";3///"_$P($P(LRN0,U),".")_";4///"_LRN0T1_";5///"_$P($P(LRN0,U,3),".")_";6///"_LRN0T2_";7///`"_LRVSPEC_";12///`"_LRPROV
57 K DD,DO D FILE^DICN K DA S LRDA=Y Q:LRDA<1
58 S $P(^LAR(64.036,+LRDA,0),U,9)=LRSPDT,$P(^(0),U,10)=LRSPTM
59F2 F LRTS=0:0 S LRTS=$O(LRVV(LRTS)) Q:LRTS<1 D DR1
60 K LRVV,LRN0T1,LRN0T2
61 Q
62DR1 K DR,DIC,DIR,DIE S (X,DA)=+LRDA
63 S DR="8///"_LRTS
64 S DR(2,64.368)=".01///"_LRTS_";1///"_$P(LRVV(LRTS),U)_";2///"_$P(LRVV(LRTS),U,2)_";3///`"_$P(LRVV(LRTS),U,3)
65 S DIC="^LAR(64.036,"
66 S DIE=DIC,DIC(0)="LNM" D ^DIE
67 Q
68FIX S X=$P(^LAR(64.036,0),U,1,2) K ^LAR(64.036) S ^LAR(64.036,0)=X Q
69UID ;
70 S LRN0T2=$P(LRN0,U,3)
71 S LRSPDT=$P($P(LRN0,U),"."),LRSPTM=$E($P($P(LRN0,U),".",2),1,4)
72 D
73 . I 'LRSPTM S LRSPTM=1 Q
74 . I LRSPTM,$E(LRSPTM,3,4)>59 S LRSPTM=$E(LRSPTM,1,2)_"59"
75 S LRN0T1=LRSPDT_"."_LRSPTM,$P(LRN0,U)=LRN0T1
76 S UID=$P($G(^LR(LRDFN,"CH",LRIDT,"ORU")),U) Q:'$L(UID)
77 S LRC=$Q(^LRO(68,"C",UID)) Q:$QS(LRC,3)'=UID
78 S LRAA=$QS(LRC,4),LRAD=$QS(LRC,5),LRAN=$QS(LRC,6)
79 D
80 . N LR3,LRODT,LROODT,LRSN
81 . Q:'$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) S LR3=^(0)
82 . S LRODT=$P(LR3,U,4),LRSN=$P(LR3,U,5)
83 . S LROODT=$P($G(^LRO(69,LRODT,1,LRSN,0)),U,5)
84 . I $G(LROODT) S $P(LRN0,U)=LROODT
85 Q
Note: See TracBrowser for help on using the repository browser.