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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRACS1 3319 printed Oct 16, 2024@18:07:18 Page 2
LRACS1 ;SLC/DCM - DAILY LAB SUMMARY REPORTS ; 2/22/87 3:06 PM ;
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
LRMH ;from LRACS, LRACS2
+1 SET DFN=$PIECE(^LR(LRDFN,0),U,3)
SET LRDPF=+$PIECE(^(0),U,2)
DO PT^LRX
+2 SET LRMH=0
FOR
SET LRMH=$ORDER(^LAC(LRXLR,LRDFN,1,LRMH))
if LRMH<1
QUIT
DO MH1
+3 QUIT
MH1 SET LRTOM=$LENGTH(LRCLUS,U)
SET LRMOM=""
FOR LRIQ=1:1:LRTOM
IF $PIECE(LRCLUS,U,LRIQ)=LRMH
SET LRMOM=$PIECE(LRCLUS,U,LRIQ)
+1 if LRMOM'=LRMH
QUIT
SET LRMHN=$PIECE(^LAC(LRXLR,LRDFN,1,LRMH,0),U,1)
SET LRSH=0
+2 DO LRSH
SET LROSH=0
+3 QUIT
LRSH SET LRSH=$ORDER(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH))
if LRSH<1
QUIT
SET X=^(LRSH,0)
if $ORDER(^(1,0))<1
GOTO LRSH
+1 SET LRSHN=$PIECE(X,U,1)
SET LRTOPP=$PIECE(X,U,2)
SET LRSHD=$PIECE(X,U,3)
SET LRTOPP=$EXTRACT($PIECE(^LAB(61,LRTOPP,0),U,1),1,13)
SET LRTOT=0
SET LRPL=1
SET LRACT=0
SET LRJS=0
SET LRTS=0
SET LRNP=0
SET LRFDT=0
SET LRLFDT=0
SET LRFFDT=0
+2 DO LRNP
LOOP GOTO LRFDT
LRNP SET LRIP=0
FOR
SET LRIP=$ORDER(^LAB(64.5,1,1,LRMH,1,LRSH,1,LRIP))
if LRIP<1
QUIT
SET LRTOT=LRTOT+$PIECE(^(LRIP,0),U,2)
IF LRTOT>(IOM-12)
SET LRPL=LRPL+1
SET LRTOT=$PIECE(^(0),U,2)
LNS ;
+1 SET LRACT=0
SET LRJS=0
+2 QUIT
LRFDT SET LRFALT=0
SET LRCTR=0
SET J=LRJS+1
SET LRCL=14
SET LRFMT=$PIECE(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,0),U,4)
+1 SET LRFFDT=LRFDT
SET LRFDT=$ORDER(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT))
if LRFDT<1
GOTO LRSH
SET X=^(LRFDT,0)
SET LRVDT=$PIECE(X,U,3)
IF LRVDT>(LRDT_.9999)!(LRVDT<LRLDT)
GOTO LRFDT
+2 SET LRACT=LRACT+1
SET LRTLOC=$PIECE(X,U,2)
if LRFDT>LRLFDT
SET LRLFDT=LRFDT
LRTS IF 'LRNAME
DO TOPLN^LRACS2
SET LRNAME=1
+1 KILL I
SET I=0
SET LRII=0
FOR
SET LRII=$ORDER(^LAB(64.5,1,1,LRMH,1,LRSH,1,LRII))
if LRII<1
QUIT
SET I=I+1
SET I(I)=LRII
+2 if J'>LRSHD
WRITE !!,LRTOPP,?LRCL
FOR I=J:1:LRSHD
SET LRCW=$PIECE(^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0),U,2)
if (IOM-LRCL)<LRCW
QUIT
SET LRCL=LRCL+LRCW
WRITE $JUSTIFY($EXTRACT($PIECE(^(0),U,3),1,(LRCW-1)),(LRCW-3)),?LRCL
+3 SET LRJS=(I-1)
if LRACT=LRPL
SET LRJS=LRJS+1
+4 SET LRCL=14
+5 SET LRFALT=0
GOUT DO QRS
IF $PIECE(^LAB(64.5,1,2,LRFULL,0),U,2)
SET LRHOLD=LRFDT
DO LRFMT
if LRFDT>1
DO QRS
SET LRFDT=LRHOLD
+1 IF LRACT'<LRPL
if $ORDER(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRLFDT))<1
GOTO LRSH
SET LRFDT=LRLFDT
SET LRACT=0
SET LRJS=0
GOTO LRFDT
+2 IF LRACT<LRPL
SET LRFDT=LRFFDT
GOTO LRFDT
+3 GOTO LRFDT
QRS SET LRCTR=LRCTR+1
FOR I=J:1:LRJS
IF $DATA(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,1,I(I),0))
if $LENGTH(^(0))
SET LRFALT=1
+1 if 'LRFALT
QUIT
SET LRFALT=0
SET LRCL=14
WRITE !,$PIECE(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,0),U,4)
+2 FOR I=J:1:LRJS
DO QRS1
+3 IF $DATA(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,"TX"))
DO TXT
+4 IF $Y>(IOSL-7)
DO EQUALS^LRX
WRITE @IOF
DO TOP^LRACS2
+5 QUIT
QRS1 WRITE ?LRCL
SET LRCW=$PIECE(^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0),U,2)
SET LRDP=$PIECE(^(0),U,6)
if (IOM-LRCL)<LRCW
QUIT
+1 SET LRCL=LRCL+LRCW
IF $DATA(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,1,I(I),0))
SET X=^(0)
DO C
if $LENGTH($PIECE(^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0),U,4))&($LENGTH(X))
WRITE @$PIECE(^(0),U,4),X1
IF '$LENGTH($PIECE(^(0),U,4))
WRITE X_X1
+2 KILL X2
QUIT
TXT ;
+1 SET LRIT=0
FOR
SET LRIT=$ORDER(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,"TX",LRIT))
if LRIT<.1
QUIT
WRITE !?2,^(LRIT,0)
+2 QUIT
C SET X1=" "_$PIECE(X,U,2)
SET X=$PIECE(X,U,1)
+1 IF $LENGTH($PIECE(^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0),U,4))
SET LRCW=LRCW-3
QUIT
+2 IF "<>"[$EXTRACT(X,1)
IF $EXTRACT(X,2,$LENGTH(X))?.N.P1N
SET X2=$EXTRACT(X,1)
SET X=$EXTRACT(X,2,$LENGTH(X))
+3 SET LRCW(1)=LRCW-3
+4 IF X?.N.P1N!(LRDP="")!(X?.N1".".N)
SET X=$SELECT(LRDP="":$JUSTIFY(X,LRCW(1)),1:$JUSTIFY(X,LRCW(1),LRDP))
IF $DATA(X2)
FOR X3=1:1:$LENGTH(X)
IF $EXTRACT(X,X3)'=" "
SET X=$EXTRACT(X,1,X3-2)_X2_$EXTRACT(X,X3,$LENGTH(X))
QUIT
+5 QUIT
LRFMT SET LRFDT=$SELECT(LRFMT["I":$ORDER(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT)),1:LRFFDT)
+1 IF LRFDT>1
if $PIECE($PIECE(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,0),U,3),".",1)=LRDT
SET LRFDT=-1
IF LRFDT>1
DO CHK
if '$DATA(LRMATCH)
SET LRFDT=-1
+2 QUIT
CHK KILL LRMATCH
SET I=0
FOR
SET I=$ORDER(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRHOLD,1,I))
if I<1
QUIT
IF $DATA(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,1,I))
SET LRMATCH=1
QUIT
+1 QUIT
