LRRP6A1 ;DALISC/J0 - LAB TEST SUMMARY REPORT-BUILD ;11/27/92
;;5.2;LAB SERVICE;**201**;Sep 27, 1994
EN ;
DQ ;
D INIT S:$D(ZTQUEUED) ZTREQ="@" K ZTSK
S ACCTRNS=$P(^LRO(68,LRAA,0),U,3) Q:"MDQY"'[ACCTRNS
I ACCTRNS="D" D DAILY
I ACCTRNS="Y" D YEARLY
I ACCTRNS="M"!(ACCTRNS="Q") D MONTHLY
D PRINT
D:$D(ZTQUEUED) WRAPUP^LRRP6
Q
INIT ;
S:$D(ZTQUEUED) ZTREQ="@" K ZTSK U IO
K ^TMP("LR",$J)
S LRDAT=$$Y2K^LRX(DT),(LRPAG,LREND)=0
Q
DAILY ;
S LRDT=LRSDT
F S LRDT=$O(^LRO(68,LRAA,1,LRDT)) Q:('LRDT)!(LRDT>LREDT) D
. S LRANN=+$G(LRANF)
. F S LRANN=$O(^LRO(68,LRAA,1,LRDT,1,LRANN)) Q:'LRANN!(LRANN>LRANL) S LRPDT=+$P($G(^(LRANN,3)),U,3) D ACC
Q
YEARLY ;
S LRDT=$E(LRSDT,1,3)_"0000"-.001,LREDT=LREDT_".99999"
F S LRDT=$O(^LRO(68,LRAA,1,LRDT)) Q:('LRDT)!(LRDT>LREDT) D
. S LRANN=+$G(LRANF)
. F S LRANN=$O(^LRO(68,LRAA,1,LRDT,1,LRANN)) Q:'LRANN!(LRANN>LRANL) D
. . Q:'$D(^LRO(68,LRAA,1,LRDT,1,LRANN,0))#2 S LRANN0=+$P($G(^(3)),U,3)
. . I LRANN0,LRANN0'>LREDT&(LRANN0'<LRSDT) S LRPDT=LRANN0 D ACC
Q
MONTHLY ;
S LRDT=$E(LRSDT,1,5)_"00"-.001,LREDT=LREDT_".99999"
F S LRDT=$O(^LRO(68,LRAA,1,LRDT)) Q:('LRDT)!(LRDT>LREDT) D
. S LRANN=+$G(LRANF)
. F S LRANN=$O(^LRO(68,LRAA,1,LRDT,1,LRANN)) Q:'LRANN!(LRANN>LRANL) D
. . Q:'$D(^LRO(68,LRAA,1,LRDT,1,LRANN,0))#2 S LRANN0=+$P($G(^(3)),U,3)
. . I LRANN0,LRANN0'>LREDT&(LRANN0'<LRSDT) D ACC
Q
ACC ;
S LRAN=$G(^LRO(68,LRAA,1,LRDT,1,LRANN,.2)) Q:LRAN=""
S LRTIC=$P(LRAN," ",3)
S LRTIC=$S($L(LRTIC)'>1:"00"_LRTIC,$L(LRTIC)'>2:"0"_LRTIC,1:LRTIC)
S LRAN=$E(LRAN,1,$L(LRAN)-$L($P(LRAN," ",3)))_LRTIC
S LRTST=0
F S LRTST=$O(^LRO(68,LRAA,1,LRDT,1,LRANN,4,LRTST)) Q:'LRTST D
. S LRTNAM=$E($$TST^LRCAPR2(LRTST),1,60)
. S LRCPN=0
. F S LRCPN=$O(^LRO(68,LRAA,1,LRDT,1,LRANN,4,LRTST,1,LRCPN)) Q:'LRCPN D
. . S LRNODE=$G(^LRO(68,LRAA,1,LRDT,1,LRANN,4,LRTST,1,LRCPN,0)) Q:'LRNODE
. . Q:$P(LRNODE,U,3)'=1
. . S LRMULT=+$P(LRNODE,U,4)
. . I $D(LRDIVSEL),'$D(LRDIVSEL(+$P(LRNODE,U,8)))#2 Q
. . S LRCAPNAM=$E($$WKLDNAME^LRCAPU(LRCPN),1,60)
. . Q:('$L(LRCAPNAM))!('LRCAPNUM)
. . S LRCC(LRCAPNAM)=LRCAPNUM
. . D BMPTOTS
Q
BMPTOTS ;
S LRANX=LRAN N LRAN
S LRAN=LRANX_"~"_LRDT
S:'$D(^TMP("LR",$J))#2 ^($J)=0
S ^($J)=^TMP("LR",$J)+LRMULT
S:'$D(^TMP("LR",$J,"ACCNUM",LRAN))#2 ^(LRAN)=0
S ^(LRAN)=^TMP("LR",$J,"ACCNUM",LRAN)+LRMULT
;***S:'$D(^TMP("LR",$J,"ACCNUM",LRAN,LRTNAM))#2 ^(LRTNAM)=0
;***S ^(LRTNAM)=^TMP("LR",$J,"ACCNUM",LRAN,LRTNAM)+LRMULT
S:'$D(^TMP("LR",$J,"ACCNUM",LRAN,LRTNAM,LRCAPNAM))#2 ^(LRCAPNAM)=0
S ^(LRCAPNAM)=^TMP("LR",$J,"ACCNUM",LRAN,LRTNAM,LRCAPNAM)+LRMULT
S:'$D(^TMP("LR",$J,"WKLD",LRCAPNAM))#2 ^(LRCAPNAM)=0
S ^(LRCAPNAM)=^TMP("LR",$J,"WKLD",LRCAPNAM)+LRMULT
S:'$D(^TMP("LR",$J,"TST"))#2 ^("TST")=0
S ^("TST")=^TMP("LR",$J,"TST")+LRMULT
S:'$D(^TMP("LR",$J,"TST",LRTNAM))#2 ^(LRTNAM)=0
S ^(LRTNAM)=^TMP("LR",$J,"TST",LRTNAM)+LRMULT
S:'$D(^TMP("LR",$J,"TST",LRTNAM,LRCAPNAM))#2 ^(LRCAPNAM)=0
S ^(LRCAPNAM)=^TMP("LR",$J,"TST",LRTNAM,LRCAPNAM)+LRMULT
Q
PRINT ;
W:$E(IOST,1,2)="C-" @IOF
S $P(LRDASH,"=",IOM)="",$P(LRSTAR,"*",IOM)=""
I '$D(^TMP("LR",$J)) D NOTHING Q
D:LRREPTYP="D" DET^LRRP6A3 Q:LREND
D COND^LRRP6A2
Q
NOTHING ;
S LRPAG=LRPAG+1
W LRDASH
W !,"Lab Test Summary for ",LRDATRNG
W ?62,LRDAT,?72,"PAGE ",$J(LRPAG,3)
W !,"Accession Area: ",LRX
W !,LRSTAR
W !!?18,"*** NO DATA FOR REPORT OPTIONS SELECTED ***"
I $D(LRDIVSEL) D
. W !!,"DIVISIONS SELECTED",!,$E(LRDASH,1,18)
. S LRDIV=""
. F S LRDIV=$O(LRDIVSEL(LRDIV)) Q:LRDIV="" W !,LRDIVSEL(LRDIV)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRRP6A1 3596 printed Sep 23, 2025@19:55:37 Page 2
LRRP6A1 ;DALISC/J0 - LAB TEST SUMMARY REPORT-BUILD ;11/27/92
+1 ;;5.2;LAB SERVICE;**201**;Sep 27, 1994
EN ;
DQ ;
+1 DO INIT
if $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL ZTSK
+2 SET ACCTRNS=$PIECE(^LRO(68,LRAA,0),U,3)
if "MDQY"'[ACCTRNS
QUIT
+3 IF ACCTRNS="D"
DO DAILY
+4 IF ACCTRNS="Y"
DO YEARLY
+5 IF ACCTRNS="M"!(ACCTRNS="Q")
DO MONTHLY
+6 DO PRINT
+7 if $DATA(ZTQUEUED)
DO WRAPUP^LRRP6
+8 QUIT
INIT ;
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL ZTSK
USE IO
+2 KILL ^TMP("LR",$JOB)
+3 SET LRDAT=$$Y2K^LRX(DT)
SET (LRPAG,LREND)=0
+4 QUIT
DAILY ;
+1 SET LRDT=LRSDT
+2 FOR
SET LRDT=$ORDER(^LRO(68,LRAA,1,LRDT))
if ('LRDT)!(LRDT>LREDT)
QUIT
Begin DoDot:1
+3 SET LRANN=+$GET(LRANF)
+4 FOR
SET LRANN=$ORDER(^LRO(68,LRAA,1,LRDT,1,LRANN))
if 'LRANN!(LRANN>LRANL)
QUIT
SET LRPDT=+$PIECE($GET(^(LRANN,3)),U,3)
DO ACC
End DoDot:1
+5 QUIT
YEARLY ;
+1 SET LRDT=$EXTRACT(LRSDT,1,3)_"0000"-.001
SET LREDT=LREDT_".99999"
+2 FOR
SET LRDT=$ORDER(^LRO(68,LRAA,1,LRDT))
if ('LRDT)!(LRDT>LREDT)
QUIT
Begin DoDot:1
+3 SET LRANN=+$GET(LRANF)
+4 FOR
SET LRANN=$ORDER(^LRO(68,LRAA,1,LRDT,1,LRANN))
if 'LRANN!(LRANN>LRANL)
QUIT
Begin DoDot:2
+5 if '$DATA(^LRO(68,LRAA,1,LRDT,1,LRANN,0))#2
QUIT
SET LRANN0=+$PIECE($GET(^(3)),U,3)
+6 IF LRANN0
IF LRANN0'>LREDT&(LRANN0'<LRSDT)
SET LRPDT=LRANN0
DO ACC
End DoDot:2
End DoDot:1
+7 QUIT
MONTHLY ;
+1 SET LRDT=$EXTRACT(LRSDT,1,5)_"00"-.001
SET LREDT=LREDT_".99999"
+2 FOR
SET LRDT=$ORDER(^LRO(68,LRAA,1,LRDT))
if ('LRDT)!(LRDT>LREDT)
QUIT
Begin DoDot:1
+3 SET LRANN=+$GET(LRANF)
+4 FOR
SET LRANN=$ORDER(^LRO(68,LRAA,1,LRDT,1,LRANN))
if 'LRANN!(LRANN>LRANL)
QUIT
Begin DoDot:2
+5 if '$DATA(^LRO(68,LRAA,1,LRDT,1,LRANN,0))#2
QUIT
SET LRANN0=+$PIECE($GET(^(3)),U,3)
+6 IF LRANN0
IF LRANN0'>LREDT&(LRANN0'<LRSDT)
DO ACC
End DoDot:2
End DoDot:1
+7 QUIT
ACC ;
+1 SET LRAN=$GET(^LRO(68,LRAA,1,LRDT,1,LRANN,.2))
if LRAN=""
QUIT
+2 SET LRTIC=$PIECE(LRAN," ",3)
+3 SET LRTIC=$SELECT($LENGTH(LRTIC)'>1:"00"_LRTIC,$LENGTH(LRTIC)'>2:"0"_LRTIC,1:LRTIC)
+4 SET LRAN=$EXTRACT(LRAN,1,$LENGTH(LRAN)-$LENGTH($PIECE(LRAN," ",3)))_LRTIC
+5 SET LRTST=0
+6 FOR
SET LRTST=$ORDER(^LRO(68,LRAA,1,LRDT,1,LRANN,4,LRTST))
if 'LRTST
QUIT
Begin DoDot:1
+7 SET LRTNAM=$EXTRACT($$TST^LRCAPR2(LRTST),1,60)
+8 SET LRCPN=0
+9 FOR
SET LRCPN=$ORDER(^LRO(68,LRAA,1,LRDT,1,LRANN,4,LRTST,1,LRCPN))
if 'LRCPN
QUIT
Begin DoDot:2
+10 SET LRNODE=$GET(^LRO(68,LRAA,1,LRDT,1,LRANN,4,LRTST,1,LRCPN,0))
if 'LRNODE
QUIT
+11 if $PIECE(LRNODE,U,3)'=1
QUIT
+12 SET LRMULT=+$PIECE(LRNODE,U,4)
+13 IF $DATA(LRDIVSEL)
IF '$DATA(LRDIVSEL(+$PIECE(LRNODE,U,8)))#2
QUIT
+14 SET LRCAPNAM=$EXTRACT($$WKLDNAME^LRCAPU(LRCPN),1,60)
+15 if ('$LENGTH(LRCAPNAM))!('LRCAPNUM)
QUIT
+16 SET LRCC(LRCAPNAM)=LRCAPNUM
+17 DO BMPTOTS
End DoDot:2
End DoDot:1
+18 QUIT
BMPTOTS ;
+1 SET LRANX=LRAN
NEW LRAN
+2 SET LRAN=LRANX_"~"_LRDT
+3 if '$DATA(^TMP("LR",$JOB))#2
SET ^($JOB)=0
+4 SET ^($JOB)=^TMP("LR",$JOB)+LRMULT
+5 if '$DATA(^TMP("LR",$JOB,"ACCNUM",LRAN))#2
SET ^(LRAN)=0
+6 SET ^(LRAN)=^TMP("LR",$JOB,"ACCNUM",LRAN)+LRMULT
+7 ;***S:'$D(^TMP("LR",$J,"ACCNUM",LRAN,LRTNAM))#2 ^(LRTNAM)=0
+8 ;***S ^(LRTNAM)=^TMP("LR",$J,"ACCNUM",LRAN,LRTNAM)+LRMULT
+9 if '$DATA(^TMP("LR",$JOB,"ACCNUM",LRAN,LRTNAM,LRCAPNAM))#2
SET ^(LRCAPNAM)=0
+10 SET ^(LRCAPNAM)=^TMP("LR",$JOB,"ACCNUM",LRAN,LRTNAM,LRCAPNAM)+LRMULT
+11 if '$DATA(^TMP("LR",$JOB,"WKLD",LRCAPNAM))#2
SET ^(LRCAPNAM)=0
+12 SET ^(LRCAPNAM)=^TMP("LR",$JOB,"WKLD",LRCAPNAM)+LRMULT
+13 if '$DATA(^TMP("LR",$JOB,"TST"))#2
SET ^("TST")=0
+14 SET ^("TST")=^TMP("LR",$JOB,"TST")+LRMULT
+15 if '$DATA(^TMP("LR",$JOB,"TST",LRTNAM))#2
SET ^(LRTNAM)=0
+16 SET ^(LRTNAM)=^TMP("LR",$JOB,"TST",LRTNAM)+LRMULT
+17 if '$DATA(^TMP("LR",$JOB,"TST",LRTNAM,LRCAPNAM))#2
SET ^(LRCAPNAM)=0
+18 SET ^(LRCAPNAM)=^TMP("LR",$JOB,"TST",LRTNAM,LRCAPNAM)+LRMULT
+19 QUIT
PRINT ;
+1 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+2 SET $PIECE(LRDASH,"=",IOM)=""
SET $PIECE(LRSTAR,"*",IOM)=""
+3 IF '$DATA(^TMP("LR",$JOB))
DO NOTHING
QUIT
+4 if LRREPTYP="D"
DO DET^LRRP6A3
if LREND
QUIT
+5 DO COND^LRRP6A2
+6 QUIT
NOTHING ;
+1 SET LRPAG=LRPAG+1
+2 WRITE LRDASH
+3 WRITE !,"Lab Test Summary for ",LRDATRNG
+4 WRITE ?62,LRDAT,?72,"PAGE ",$JUSTIFY(LRPAG,3)
+5 WRITE !,"Accession Area: ",LRX
+6 WRITE !,LRSTAR
+7 WRITE !!?18,"*** NO DATA FOR REPORT OPTIONS SELECTED ***"
+8 IF $DATA(LRDIVSEL)
Begin DoDot:1
+9 WRITE !!,"DIVISIONS SELECTED",!,$EXTRACT(LRDASH,1,18)
+10 SET LRDIV=""
+11 FOR
SET LRDIV=$ORDER(LRDIVSEL(LRDIV))
if LRDIV=""
QUIT
WRITE !,LRDIVSEL(LRDIV)
End DoDot:1
+12 QUIT
