- 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 Mar 13, 2025@21:10:53 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
