Routine: LRAC6

LRAC6 ;SLC/DCM/MIWL/JMC - PRINT CUMULATIVE REPORT CONT. (MISC.) ; 1/31/89  15:02 ;

 ;;5.2;LAB SERVICE;**174,225**;Sep 27, 1994

LRFD1 S LRFD1=0 F  S LRFD1=$O(^TMP($J,"K",K,LRFD,LRFD1)) Q:LRFD1<1  S ^LAC("LRKILL",LRDFN,LRMH,K,LRFD,LRFD1)=^TMP($J,"K",K,LRFD,LRFD1)

 Q:'$D(^LR(LRDFN,"CH",K(3),0))  S P=$P(^(0),U,9)

 S $P(^LR(LRDFN,"CH",K(3),0),U,9)=$S(P[LRMH_":"_LRPG:P,P[":":P_","_LRMH_":"_LRPG,1:LRMH_":"_LRPG)

HEAD1 I 'LRFULL!(LRPERM=1) S LRKL=1

 E  I 'LRRE S ^LR(LRDFN,"PG",LRMH)=LRMH_U_LRPG S K=0 F  S K=$O(^TMP($J,"K",K)) Q:K<1  S LRFD=0 F  S LRFD=$O(^TMP($J,"K",K,LRFD)) Q:LRFD<1  S Z=^(LRFD,0),K(2)=$P(Z,U,2),K(3)=$P(Z,U,3),^LAC("LRKILL",LRDFN,LRMH,K,LRFD,0)=Z D LRFD1

 K LRFD,K Q

HEAD ;from LRAC3, LRAC4, LRAC5, LRAC7

 D LRBOT D TOP Q

TOP ;from LRAC3

 W:$G(LRJ02)!($E(IOST,1,2)="C-") @IOF

 S LRJ02=1

 W !,PNM,?20,SSN,?33,"AGE: ",AGE

 I +LRDPF=2,$L($G(LRWRD)) W ?(IOM-42)," LOC: ",LRWRD

 W ?(IOM-22),$S($D(LRCDT):LRCDT,1:"??"),?(IOM-13),"PAGE: "

 W $S($D(LRMISC):"MISC",1:LRMH),":",LRPG W:LRBOT="T" !

 W !,$S($D(^LAB(64.5,1,1,LRMH,0)):$P(^(0),U,2),1:$P(^LAB(64.5,1,0),U,9))

 K ^TMP($J,"K") S LRKL=1,LRAG=0 Q

LRBOT ;from LRAC3

W !

Y I $Y'>(IOSL-6) W ! G Y

 W $E(PNM,1,20),?21,SSN,?(IOM-46),"ROUTING: ",$E(LRLLOC,1,15),?(IOM-26)

 W $S(LRFULL!(LRPERM):" **PERMANENT**",1:"              ")

 W "  CHART COPY"

 W:LRBOT="B" !

 W $S($D(^LAB(64.5,1,1,LRMH,0)):$P(^(0),U,2),1:$P(^LAB(64.5,1,0),U,9))

 W:LRBOT'="B" !

 W ?(IOM-22),$S($D(LRCDT):LRCDT,1:"??"),?(IOM-13),"PAGE: "

 W $S($D(LRMISC):"MISC",1:LRMH),":",LRPG

 S LRTAB=(LRMH-1)*10#80 W !?LRTAB,$E(LRMHN,1,IOM-LRTAB)

 S:'$D(LRPG1) LRPG=LRPG+1

LRUDT S LRTIM=$E(LRFDT,9,12) F I=0:0 Q:$L(LRTIM)=4  S LRTIM=LRTIM_0

 S LRTIM=$S(LRTIM?4"0":"     ",1:$E(LRTIM,1,2)_":"_$E(LRTIM,3,4))

 S LRUDT=$E(LRFDT,4,5)_"/"_$E(LRFDT,6,7)_"/"_$E(LRFDT,2,3)_" "_$J(LRTIM,5)_" "

LRKILL D HEAD1,HEAD Q

LRMISC I LRPERM=0 Q:'$D(^LAC("LGOT",LRDFN,"MISC"))  S:'$D(LRPG1) LRPG=LRPG+1 K ^TMP($J,"K")

 S LRFDT=0 D TOP

MHI S LRMHN=$P(^LAC(LRXLR,LRDFN,LRMH,1,0),U,1),LRCNT=12 D WR

MDT S LRFDT=$O(^LAC(LRXLR,LRDFN,"MISC",1,1,LRFDT)) G:LRFDT<1 END

 I $D(DUZ("AG")),$L(DUZ("AG")),"ARMYAFN"[DUZ("AG"),LRDPF=2 D REG^LRAC9

 D LRUDT,LRCNT,WR:($Y>(IOSL-LRCNT))

 S ^TMP($J,"K",LRFDT,0)=^LAC(LRXLR,LRDFN,"MISC",1,1,LRFDT,0),LRMIT=0

LRMIT S LRMIT=$O(^LAC(LRXLR,LRDFN,"MISC",1,1,LRFDT,1,LRMIT)) G:LRMIT<1 TXT

 S ^TMP($J,"K",LRFDT,LRMIT)=$P(^LAC(LRXLR,LRDFN,"MISC",1,1,LRFDT,1,LRMIT,0),U,5)

 S LRLO="",LRHI=""

 S LRVAL=$P(^LAC(LRXLR,LRDFN,"MISC",1,1,LRFDT,1,LRMIT,0),U,1),LRX19=^(0)

 S X1=$P(LRX19,U,4),LRSPE=$P(LRX19,U,2),LRTEST=$P(LRX19,U,3)

 S LRSPEM=$S($L(LRSPE):$P(^LAB(61,LRSPE,0),U,1),1:"")

 I 'LRTEST W !,"COMMENT: ",LRVAL G LRMIT

 S LRUNT="",LRNAME=$P(^LAB(60,LRTEST,.1),U,1),LRPC=$P(^(.1),U,3)

 I $L(LRSPE),$D(^LAB(60,LRTEST,1,LRSPE,0)) S @("LRLO="_$S($L($P(^(0),U,2)):$P(^(0),U,2),1:"""""")),@("LRHI="_$S($L($P(^(0),U,3)):$P(^(0),U,3),1:"""""")),LRUNT=$P(^(0),U,7)

WR1 S:'$D(LRCW) LRCW=13 S X=LRVAL

 W !!,LRUDT,?15,LRSPEM,?36,LRNAME,":",?50,@$S(LRPC="":"X",1:LRPC)," "

 W X1,"  ",LRUNT,?67 W:$L(LRLO) LRLO,"-",LRHI

 I $D(IA) W !,IA K IA,IAX,IARNO,IADA

 G LRMIT

WR I $Y>(IOSL-LRCNT) D EQUALS^LRX S LRFULL=1 D ENT^LRAC7,HEAD K ^TMP($J,"K") S LRFULL=0

 S LRCL=21-$L(LRMHN) W !!!?LRCL F I=1:1:8 W "* "

 F I=1:1:$L(LRMHN) W " ",$E(LRMHN,I)

 W " " F I=1:1:8 W " *"

 W !!,"  Date   Time   Specimen",?37,"Test",?50,"Results"

 W ?64,"Ref ranges" D DASH^LRX

TXT S I=0

 F  S I=$O(^LAC(LRXLR,LRDFN,"MISC",1,1,LRFDT,"TX",I)) Q:'I  W !,^(I,0)

 G MDT

END D EQUALS^LRX

 D LRBOT S LRLO="" K LRSB,LRMISC Q

PRE ;from LRAC3

 Q:$O(^LAC(LRXLR,LRDFN,"MISC",1,0))'>0  S LRX21=^(0)

 S LRMISC=1

 I '$D(LRPG1) S LRPG=$S($L($P(LRX21,U,2))&($G(LRRE)):$P(LRX21,U,2),$D(^LR(LRDFN,"PG",LRMH)):$P(^(LRMH),U,2),1:0)

 S LRMH="MISC"

 S:'$L($P(^LAC(LRXLR,LRDFN,"MISC",1,0),U,2))!'$G(LRRE) $P(^(0),U,2)=LRPG

 G LRMISC

LRCNT S LRCNT=0,I=0

 F  S I=$O(^LAC(LRXLR,LRDFN,LRMH,1,1,LRFDT,1,I)) Q:I<1  S LRCNT=LRCNT+1

 S LRCTN=0 I $D(^LAC(LRXLR,LRDFN,LRMH,1,1,LRFDT,"TX")) S J=0 F  S J=$O(^LAC(LRXLR,LRDFN,LRMH,1,1,LRFDT,"TX",J)) Q:'J  S LRCTN=LRCTN+1

 S LRCNT=LRCNT*2+5+LRCTN

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAC6   4149     printed  Feb 18, 2025@23:32:04                                                                                                                                                                                                       Page 2

LRAC6     ;SLC/DCM/MIWL/JMC - PRINT CUMULATIVE REPORT CONT. (MISC.) ; 1/31/89  15:02 ;

 +1       ;;5.2;LAB SERVICE;**174,225**;Sep 27, 1994

LRFD1      SET LRFD1=0

FOR

               SET LRFD1=$ORDER(^TMP($JOB,"K",K,LRFD,LRFD1))

               if LRFD1<1

                   QUIT

               SET ^LAC("LRKILL",LRDFN,LRMH,K,LRFD,LRFD1)=^TMP($JOB,"K",K,LRFD,LRFD1)

 +1        if '$DATA(^LR(LRDFN,"CH",K(3),0))

               QUIT

           SET P=$PIECE(^(0),U,9)

 +2        SET $PIECE(^LR(LRDFN,"CH",K(3),0),U,9)=$SELECT(P[LRMH_":"_LRPG:P,P[":":P_","_LRMH_":"_LRPG,1:LRMH_":"_LRPG)

 +3        QUIT

HEAD1      IF 'LRFULL!(LRPERM=1)

               SET LRKL=1

 +1       IF '$TEST

               IF 'LRRE

                   SET ^LR(LRDFN,"PG",LRMH)=LRMH_U_LRPG

                   SET K=0

FOR

                       SET K=$ORDER(^TMP($JOB,"K",K))

                       if K<1

                           QUIT

                       SET LRFD=0

FOR

                           SET LRFD=$ORDER(^TMP($JOB,"K",K,LRFD))

                           if LRFD<1

                               QUIT

                           SET Z=^(LRFD,0)

                           SET K(2)=$PIECE(Z,U,2)

                           SET K(3)=$PIECE(Z,U,3)

                           SET ^LAC("LRKILL",LRDFN,LRMH,K,LRFD,0)=Z

                           DO LRFD1

 +2        KILL LRFD,K

           QUIT

HEAD      ;from LRAC3, LRAC4, LRAC5, LRAC7

 +1        DO LRBOT

           DO TOP

           QUIT

TOP       ;from LRAC3

 +1        if $GET(LRJ02)!($EXTRACT(IOST,1,2)="C-")

               WRITE @IOF

 +2        SET LRJ02=1

 +3        WRITE !,PNM,?20,SSN,?33,"AGE: ",AGE

 +4        IF +LRDPF=2

               IF $LENGTH($GET(LRWRD))

                   WRITE ?(IOM-42)," LOC: ",LRWRD

 +5        WRITE ?(IOM-22),$SELECT($DATA(LRCDT):LRCDT,1:"??"),?(IOM-13),"PAGE: "

 +6        WRITE $SELECT($DATA(LRMISC):"MISC",1:LRMH),":",LRPG

           if LRBOT="T"

               WRITE !

 +7        WRITE !,$SELECT($DATA(^LAB(64.5,1,1,LRMH,0)):$PIECE(^(0),U,2),1:$PIECE(^LAB(64.5,1,0),U,9))

 +8        KILL ^TMP($JOB,"K")

           SET LRKL=1

           SET LRAG=0

           QUIT

LRBOT     ;from LRAC3

 +1        WRITE !

Y          IF $Y'>(IOSL-6)

               WRITE !

               GOTO Y

 +1        WRITE $EXTRACT(PNM,1,20),?21,SSN,?(IOM-46),"ROUTING: ",$EXTRACT(LRLLOC,1,15),?(IOM-26)

 +2        WRITE $SELECT(LRFULL!(LRPERM):" **PERMANENT**",1:"              ")

 +3        WRITE "  CHART COPY"

 +4        if LRBOT="B"

               WRITE !

 +5        WRITE $SELECT($DATA(^LAB(64.5,1,1,LRMH,0)):$PIECE(^(0),U,2),1:$PIECE(^LAB(64.5,1,0),U,9))

 +6        if LRBOT'="B"

               WRITE !

 +7        WRITE ?(IOM-22),$SELECT($DATA(LRCDT):LRCDT,1:"??"),?(IOM-13),"PAGE: "

 +8        WRITE $SELECT($DATA(LRMISC):"MISC",1:LRMH),":",LRPG

 +9        SET LRTAB=(LRMH-1)*10#80

           WRITE !?LRTAB,$EXTRACT(LRMHN,1,IOM-LRTAB)

 +10       if '$DATA(LRPG1)

               SET LRPG=LRPG+1

 +11       QUIT

LRUDT      SET LRTIM=$EXTRACT(LRFDT,9,12)

           FOR I=0:0

               if $LENGTH(LRTIM)=4

                   QUIT

               SET LRTIM=LRTIM_0

 +1        SET LRTIM=$SELECT(LRTIM?4"0":"     ",1:$EXTRACT(LRTIM,1,2)_":"_$EXTRACT(LRTIM,3,4))

 +2        SET LRUDT=$EXTRACT(LRFDT,4,5)_"/"_$EXTRACT(LRFDT,6,7)_"/"_$EXTRACT(LRFDT,2,3)_" "_$JUSTIFY(LRTIM,5)_" "

 +3        QUIT

LRKILL     DO HEAD1

           DO HEAD

           QUIT

 +1        QUIT

LRMISC     IF LRPERM=0

               if '$DATA(^LAC("LGOT",LRDFN,"MISC"))

                   QUIT

               if '$DATA(LRPG1)

                   SET LRPG=LRPG+1

               KILL ^TMP($JOB,"K")

 +1        SET LRFDT=0

           DO TOP

MHI        SET LRMHN=$PIECE(^LAC(LRXLR,LRDFN,LRMH,1,0),U,1)

           SET LRCNT=12

           DO WR

MDT        SET LRFDT=$ORDER(^LAC(LRXLR,LRDFN,"MISC",1,1,LRFDT))

           if LRFDT<1

               GOTO END

 +1        IF $DATA(DUZ("AG"))

               IF $LENGTH(DUZ("AG"))

                   IF "ARMYAFN"[DUZ("AG")

                       IF LRDPF=2

                           DO REG^LRAC9

 +2        DO LRUDT

           DO LRCNT

           if ($Y>(IOSL-LRCNT))

               DO WR

 +3        SET ^TMP($JOB,"K",LRFDT,0)=^LAC(LRXLR,LRDFN,"MISC",1,1,LRFDT,0)

           SET LRMIT=0

LRMIT      SET LRMIT=$ORDER(^LAC(LRXLR,LRDFN,"MISC",1,1,LRFDT,1,LRMIT))

           if LRMIT<1

               GOTO TXT

 +1        SET ^TMP($JOB,"K",LRFDT,LRMIT)=$PIECE(^LAC(LRXLR,LRDFN,"MISC",1,1,LRFDT,1,LRMIT,0),U,5)

 +2        SET LRLO=""

           SET LRHI=""

 +3        SET LRVAL=$PIECE(^LAC(LRXLR,LRDFN,"MISC",1,1,LRFDT,1,LRMIT,0),U,1)

           SET LRX19=^(0)

 +4        SET X1=$PIECE(LRX19,U,4)

           SET LRSPE=$PIECE(LRX19,U,2)

           SET LRTEST=$PIECE(LRX19,U,3)

 +5        SET LRSPEM=$SELECT($LENGTH(LRSPE):$PIECE(^LAB(61,LRSPE,0),U,1),1:"")

 +6        IF 'LRTEST

               WRITE !,"COMMENT: ",LRVAL

               GOTO LRMIT

 +7        SET LRUNT=""

           SET LRNAME=$PIECE(^LAB(60,LRTEST,.1),U,1)

           SET LRPC=$PIECE(^(.1),U,3)

 +8        IF $LENGTH(LRSPE)

               IF $DATA(^LAB(60,LRTEST,1,LRSPE,0))

                   SET @("LRLO="_$SELECT($LENGTH($PIECE(^(0),U,2)):$PIECE(^(0),U,2),1:""""""))

                   SET @("LRHI="_$SELECT($LENGTH($PIECE(^(0),U,3)):$PIECE(^(0),U,3),1:""""""))

                   SET LRUNT=$PIECE(^(0),U,7)

WR1        if '$DATA(LRCW)

               SET LRCW=13

           SET X=LRVAL

 +1        WRITE !!,LRUDT,?15,LRSPEM,?36,LRNAME,":",?50,@$SELECT(LRPC="":"X",1:LRPC)," "

 +2        WRITE X1,"  ",LRUNT,?67

           if $LENGTH(LRLO)

               WRITE LRLO,"-",LRHI

 +3        IF $DATA(IA)

               WRITE !,IA

               KILL IA,IAX,IARNO,IADA

 +4        GOTO LRMIT

WR         IF $Y>(IOSL-LRCNT)

               DO EQUALS^LRX

               SET LRFULL=1

               DO ENT^LRAC7

               DO HEAD

               KILL ^TMP($JOB,"K")

               SET LRFULL=0

 +1        SET LRCL=21-$LENGTH(LRMHN)

           WRITE !!!?LRCL

           FOR I=1:1:8

               WRITE "* "

 +2        FOR I=1:1:$LENGTH(LRMHN)

               WRITE " ",$EXTRACT(LRMHN,I)

 +3        WRITE " "

           FOR I=1:1:8

               WRITE " *"

 +4        WRITE !!,"  Date   Time   Specimen",?37,"Test",?50,"Results"

 +5        WRITE ?64,"Ref ranges"

           DO DASH^LRX

 +6        QUIT

TXT        SET I=0

 +1        FOR

               SET I=$ORDER(^LAC(LRXLR,LRDFN,"MISC",1,1,LRFDT,"TX",I))

               if 'I

                   QUIT

               WRITE !,^(I,0)

 +2        GOTO MDT

END        DO EQUALS^LRX

 +1        DO LRBOT

           SET LRLO=""

           KILL LRSB,LRMISC

           QUIT

PRE       ;from LRAC3

 +1        if $ORDER(^LAC(LRXLR,LRDFN,"MISC",1,0))'>0

               QUIT

           SET LRX21=^(0)

 +2        SET LRMISC=1

 +3        IF '$DATA(LRPG1)

               SET LRPG=$SELECT($LENGTH($PIECE(LRX21,U,2))&($GET(LRRE)):$PIECE(LRX21,U,2),$DATA(^LR(LRDFN,"PG",LRMH)):$PIECE(^(LRMH),U,2),1:0)

 +4        SET LRMH="MISC"

 +5        if '$LENGTH($PIECE(^LAC(LRXLR,LRDFN,"MISC",1,0),U,2))!'$GET(LRRE)

               SET $PIECE(^(0),U,2)=LRPG

 +6        GOTO LRMISC

LRCNT      SET LRCNT=0

           SET I=0

 +1        FOR

               SET I=$ORDER(^LAC(LRXLR,LRDFN,LRMH,1,1,LRFDT,1,I))

               if I<1

                   QUIT

               SET LRCNT=LRCNT+1

 +2        SET LRCTN=0

           IF $DATA(^LAC(LRXLR,LRDFN,LRMH,1,1,LRFDT,"TX"))

               SET J=0

FOR

                   SET J=$ORDER(^LAC(LRXLR,LRDFN,LRMH,1,1,LRFDT,"TX",J))

                   if 'J

                       QUIT

                   SET LRCTN=LRCTN+1

 +3        SET LRCNT=LRCNT*2+5+LRCTN

 +4        QUIT

LRAC6.m