source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRACS1.m@ 862

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

initial load of WorldVistAEHR

File size: 3.2 KB
Line 
1LRACS1 ;SLC/DCM - DAILY LAB SUMMARY REPORTS ; 2/22/87 3:06 PM ;
2 ;;5.2;LAB SERVICE;;Sep 27, 1994
3LRMH ;from LRACS, LRACS2
4 S DFN=$P(^LR(LRDFN,0),U,3),LRDPF=+$P(^(0),U,2) D PT^LRX
5 S LRMH=0 F S LRMH=$O(^LAC(LRXLR,LRDFN,1,LRMH)) Q:LRMH<1 D MH1
6 Q
7MH1 S LRTOM=$L(LRCLUS,U),LRMOM="" F LRIQ=1:1:LRTOM I $P(LRCLUS,U,LRIQ)=LRMH S LRMOM=$P(LRCLUS,U,LRIQ)
8 Q:LRMOM'=LRMH S LRMHN=$P(^LAC(LRXLR,LRDFN,1,LRMH,0),U,1),LRSH=0
9 D LRSH S LROSH=0
10 Q
11LRSH S LRSH=$O(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH)) Q:LRSH<1 S X=^(LRSH,0) G:$O(^(1,0))<1 LRSH
12 S LRSHN=$P(X,U,1),LRTOPP=$P(X,U,2),LRSHD=$P(X,U,3),LRTOPP=$E($P(^LAB(61,LRTOPP,0),U,1),1,13),LRTOT=0,LRPL=1,LRACT=0,LRJS=0,LRTS=0,LRNP=0,LRFDT=0,LRLFDT=0,LRFFDT=0
13 D LRNP
14LOOP G LRFDT
15LRNP S LRIP=0 F S LRIP=$O(^LAB(64.5,1,1,LRMH,1,LRSH,1,LRIP)) Q:LRIP<1 S LRTOT=LRTOT+$P(^(LRIP,0),U,2) I LRTOT>(IOM-12) S LRPL=LRPL+1,LRTOT=$P(^(0),U,2)
16LNS ;
17 S LRACT=0,LRJS=0
18 Q
19LRFDT S LRFALT=0,LRCTR=0,J=LRJS+1,LRCL=14,LRFMT=$P(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,0),U,4)
20 S LRFFDT=LRFDT,LRFDT=$O(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT)) G:LRFDT<1 LRSH S X=^(LRFDT,0),LRVDT=$P(X,U,3) I LRVDT>(LRDT_.9999)!(LRVDT<LRLDT) G LRFDT
21 S LRACT=LRACT+1,LRTLOC=$P(X,U,2) S:LRFDT>LRLFDT LRLFDT=LRFDT
22LRTS I 'LRNAME D TOPLN^LRACS2 S LRNAME=1
23 K I S I=0,LRII=0 F S LRII=$O(^LAB(64.5,1,1,LRMH,1,LRSH,1,LRII)) Q:LRII<1 S I=I+1,I(I)=LRII
24 W:J'>LRSHD !!,LRTOPP,?LRCL F I=J:1:LRSHD S LRCW=$P(^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0),U,2) Q:(IOM-LRCL)<LRCW S LRCL=LRCL+LRCW W $J($E($P(^(0),U,3),1,(LRCW-1)),(LRCW-3)),?LRCL
25 S LRJS=(I-1) S:LRACT=LRPL LRJS=LRJS+1
26 S LRCL=14
27 S LRFALT=0
28GOUT D QRS I $P(^LAB(64.5,1,2,LRFULL,0),U,2) S LRHOLD=LRFDT D LRFMT,QRS:LRFDT>1 S LRFDT=LRHOLD
29 I LRACT'<LRPL G:$O(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRLFDT))<1 LRSH S LRFDT=LRLFDT,LRACT=0,LRJS=0 G LRFDT
30 I LRACT<LRPL S LRFDT=LRFFDT G LRFDT
31 G LRFDT
32QRS S LRCTR=LRCTR+1 F I=J:1:LRJS I $D(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,1,I(I),0)) S:$L(^(0)) LRFALT=1
33 Q:'LRFALT S LRFALT=0,LRCL=14 W !,$P(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,0),U,4)
34 F I=J:1:LRJS D QRS1
35 I $D(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,"TX")) D TXT
36 I $Y>(IOSL-7) D EQUALS^LRX W @IOF D TOP^LRACS2
37 Q
38QRS1 W ?LRCL S LRCW=$P(^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0),U,2),LRDP=$P(^(0),U,6) Q:(IOM-LRCL)<LRCW
39 S LRCL=LRCL+LRCW I $D(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,1,I(I),0)) S X=^(0) D C W:$L($P(^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0),U,4))&($L(X)) @$P(^(0),U,4),X1 I '$L($P(^(0),U,4)) W X_X1
40 K X2 Q
41TXT ;
42 S LRIT=0 F S LRIT=$O(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,"TX",LRIT)) Q:LRIT<.1 W !?2,^(LRIT,0)
43 Q
44C S X1=" "_$P(X,U,2),X=$P(X,U,1)
45 I $L($P(^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0),U,4)) S LRCW=LRCW-3 Q
46 I "<>"[$E(X,1),$E(X,2,$L(X))?.N.P1N S X2=$E(X,1),X=$E(X,2,$L(X))
47 S LRCW(1)=LRCW-3
48 I X?.N.P1N!(LRDP="")!(X?.N1".".N) S X=$S(LRDP="":$J(X,LRCW(1)),1:$J(X,LRCW(1),LRDP)) I $D(X2) F X3=1:1:$L(X) I $E(X,X3)'=" " S X=$E(X,1,X3-2)_X2_$E(X,X3,$L(X)) Q
49 Q
50LRFMT S LRFDT=$S(LRFMT["I":$O(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT)),1:LRFFDT)
51 I LRFDT>1 S:$P($P(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,0),U,3),".",1)=LRDT LRFDT=-1 I LRFDT>1 D CHK S:'$D(LRMATCH) LRFDT=-1
52 Q
53CHK K LRMATCH S I=0 F S I=$O(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRHOLD,1,I)) Q:I<1 I $D(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,1,I)) S LRMATCH=1 Q
54 Q
Note: See TracBrowser for help on using the repository browser.