Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRACS1

LRACS1.m

Go to the documentation of this file.
LRACS1 ;SLC/DCM - DAILY LAB SUMMARY REPORTS ; 2/22/87  3:06 PM ;
 ;;5.2;LAB SERVICE;;Sep 27, 1994
LRMH ;from LRACS, LRACS2
 S DFN=$P(^LR(LRDFN,0),U,3),LRDPF=+$P(^(0),U,2) D PT^LRX
 S LRMH=0 F  S LRMH=$O(^LAC(LRXLR,LRDFN,1,LRMH)) Q:LRMH<1  D MH1
 Q
MH1 S LRTOM=$L(LRCLUS,U),LRMOM="" F LRIQ=1:1:LRTOM I $P(LRCLUS,U,LRIQ)=LRMH S LRMOM=$P(LRCLUS,U,LRIQ)
 Q:LRMOM'=LRMH  S LRMHN=$P(^LAC(LRXLR,LRDFN,1,LRMH,0),U,1),LRSH=0
 D LRSH S LROSH=0
 Q
LRSH S LRSH=$O(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH)) Q:LRSH<1  S X=^(LRSH,0) G:$O(^(1,0))<1 LRSH
 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
 D LRNP
LOOP G LRFDT
LRNP 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)
LNS ;
 S LRACT=0,LRJS=0
 Q
LRFDT S LRFALT=0,LRCTR=0,J=LRJS+1,LRCL=14,LRFMT=$P(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,0),U,4)
 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
 S LRACT=LRACT+1,LRTLOC=$P(X,U,2) S:LRFDT>LRLFDT LRLFDT=LRFDT
LRTS I 'LRNAME D TOPLN^LRACS2 S LRNAME=1
 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
 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
 S LRJS=(I-1) S:LRACT=LRPL LRJS=LRJS+1
 S LRCL=14
 S LRFALT=0
GOUT D QRS I $P(^LAB(64.5,1,2,LRFULL,0),U,2) S LRHOLD=LRFDT D LRFMT,QRS:LRFDT>1 S LRFDT=LRHOLD
 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
 I LRACT<LRPL S LRFDT=LRFFDT G LRFDT
 G LRFDT
QRS 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
 Q:'LRFALT  S LRFALT=0,LRCL=14 W !,$P(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,0),U,4)
 F I=J:1:LRJS D QRS1
 I $D(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,"TX")) D TXT
 I $Y>(IOSL-7) D EQUALS^LRX W @IOF D TOP^LRACS2
 Q
QRS1 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
 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
 K X2 Q
TXT ;
 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)
 Q
C S X1=" "_$P(X,U,2),X=$P(X,U,1)
 I $L($P(^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0),U,4)) S LRCW=LRCW-3 Q
 I "<>"[$E(X,1),$E(X,2,$L(X))?.N.P1N S X2=$E(X,1),X=$E(X,2,$L(X))
 S LRCW(1)=LRCW-3
 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
 Q
LRFMT S LRFDT=$S(LRFMT["I":$O(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT)),1:LRFFDT)
 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
 Q
CHK 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
 Q