LRAC3 ;SLC/DCM - PRINT CUMULATIVE REPORT ;3/3/88 13:23 ;
;;5.2;LR;**201,225,1018,1024**;May 02, 2008
LRSH ; EP - from LRAC5, LRAC5
S LRSH=$O(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH)) Q:LRSH=""
I $O(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,0))="" K ^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH) G LRSH
I $O(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,0))="" K ^(0) G LRSH
S X=^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,0),LRSHN=$P(X,U,1),LRTOPP=$P(X,U,2),LRSHD=$P(X,U,3),LRFMT=$P(X,U,4),LRFMT(1)=$E(LRFMT,1),LROFMT(1)=$E(LROFMT,1)
I (LROFMT["V"&(LRFMT["V"))!(LROFMT(1)'=""&(LRFMT(1)'=LROFMT(1))) S LROFMT="" D HEAD1^LRAC6,HEAD^LRAC6
S LROFMT=LRFMT,LRTOPP=$E($P(^LAB(61,LRTOPP,0),U,1),1,13),LRTOT=0,LRPL=1,LRACT=0,LRJS=0,LRTS=0,LRFDE=0,LRNP=0,LRFDT=0,LRLFDT=0,LRFFDT=0 D LRNP
LOOP ; EP - from LRAC5
I LRACT<LRPL S LRFDT=LRFFDT G:LRFMT["H" TS^LRAC5 I LRFMT["V" S LRMULT=1,LRMU=0 D MUL G BS^LRAC4
D TXT1^LRAC9 I LRCTR'<LRLNS!(IOSL-18<$Y) S LRFULL=1 S:'LRFDT LRFDE=1 D HEAD1^LRAC6 D:LRFDE LRBOT^LRAC6 D:'LRFDE HEAD^LRAC6 S LRFULL=0 G LRSH
G LRSH
MUL F I=0:0 Q:LRMULT*(LRSHD+15)>(IOSL-9) S LRMULT=LRMULT+1
Q
LRNP ; EP - from LRAC3
S I=0 F S I=$O(^LAB(64.5,1,1,LRMH,1,LRSH,1,I)) Q:I<1 S LRTOT=LRTOT+$P(^(I,0),U,2) I LRTOT>(IOM-20) S LRPL=LRPL+1,LRTOT=$P(^(0),U,2)
LRLNS ; EP - from LRAC5
K LRTM,^TMP($J,"TM") S LRTM=0,LRLNS=((IOSL-18)-($Y+(6*LRPL)))\LRPL,LRCL=(IOM/2)-(5+($L(LRSHN)/2)),LRACT=0,LRJS=0,LRNP=1 W !!?LRCL,"----",LRSHN,"----"
Q
MH1 I LRXLR="LRAC"&(LRPERM=0) Q:'$D(^LAC("LGOT",LRDFN,LRMH))
S LRMHN=$P(X,U,1),LRSH=0
I '$D(LRPG1) S LRPG=$S($L($P(X,U,2))&LRRE:$P(X,U,2),$D(^LR(LRDFN,"PG",LRMH)):$P(^(LRMH),U,2),1:0) S:'$L($P(X,U,2))!('LRRE) $P(^LAC(LRXLR,LRDFN,1,LRMH,0),U,2)=LRPG S LRPG=LRPG+1
D TOP^LRAC6 S LROFMT="",LRFDE=0 D LRSH,HEAD1^LRAC6,LRBOT^LRAC6:'LRFDE K LRTM,^TMP($J,"TM") S LRFULL=0,LRTM=0,LROFMT="",LRFDE=0
Q
ENT ; EP - from LRAC1,LRACM2
K ^TMP($J,"K"),LRMISC S LRAG=0,LRYESCOM=0,LRIL=0,LRFULL=0 D LRMH S LRMH="MISC" G PRE^LRAC6
LRMH ; S LRMH=0 F S LRMH=$O(^LAC(LRXLR,LRDFN,1,LRMH)) Q:LRMH<1 S X=^(LRMH,0) D MH1
; ----- BEGIN IHS/OIT/MKK -- Patch 1024 Modification
; The Naked reference [S X=^(LRMH,0)] has caused <UNDEFINED> Errors. Fix it
S LRMH=0
F S LRMH=$O(^LAC(LRXLR,LRDFN,1,LRMH)) Q:LRMH<1 D
. S X=$G(^LAC(LRXLR,LRDFN,1,LRMH,0))
. I X="" Q
. D MH1
; ----- END IHS/OIT/MKK -- Patch 1024 Modification
Q
UDT ; EP - from LRAC4, LRAC9
S LRBDT=LRFDT,LRFDT=$S($P(^LAB(64.5,1,1,LRMH,1,LRSH,0),U,3)["I":$P(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,0),U,1),1:LRFDT),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($$Y2K^LRX($P(LRFDT,".")),1,5)_" "_$J(LRTIM,4)_" "
S LRFDT=LRBDT D:LRTM LRTM
Q
LRTM S LRNXSW=0 S:'$D(LRTM(0)) LRTM(0)=96
I $D(^TMP($J,"TM",LRFDT)) S LRNXSW=1
E I $D(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,"TX")) S LRTM(0)=LRTM(0)+1,LRNX=$C(LRTM(0)),^TMP($J,"TM",LRFDT)=LRNX,LRNXSW=1 S I=0 F S I=$O(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,"TX",I)) Q:'I S ^TMP($J,"TM",LRFDT,I)=^(I,0)
;
;
Y2KALT ; EP
;03/03/1998@14:58:07
;S:LRNXSW LRUDT=$P(^TMP($J,"TM",LRFDT),U,1)_" "_LRUDT
;S LRUDT7=$$Y2K^LRX(LRFDT) ;Removed to prevent 4 digit year
S LRUDT7=$$FMTE^XLFDT(LRFDT,"2Z")
S LRUDT7=$P(LRUDT7,"@")_" "_$E($P(LRUDT7,"@",2),1,5)
S LRUDT=$S(LRNXSW:$P(^TMP($J,"TM",LRFDT),U,1)_" ",1:"")_LRUDT7
;S:LRNXSW LRUDT=$P(^TMP($J,"TM",LRFDT),U,1)_" "_LRUDT7
;I LRUDT'=LRUDT7 S LRUDT=LRUDT7
Q
LRAC3 ;SLC/DCM - PRINT CUMULATIVE REPORT ;3/3/88 13:23 ;
+1 ;;5.2;LR;**201,225,1018,1024**;May 02, 2008
LRSH ; EP - from LRAC5, LRAC5
+1 SET LRSH=$ORDER(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH))
IF LRSH=""
QUIT
+2 IF $ORDER(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,0))=""
KILL ^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH)
GOTO LRSH
+3 IF $ORDER(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,0))=""
KILL ^(0)
GOTO LRSH
+4 SET X=^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,0)
SET LRSHN=$PIECE(X,U,1)
SET LRTOPP=$PIECE(X,U,2)
SET LRSHD=$PIECE(X,U,3)
SET LRFMT=$PIECE(X,U,4)
SET LRFMT(1)=$EXTRACT(LRFMT,1)
SET LROFMT(1)=$EXTRACT(LROFMT,1)
+5 IF (LROFMT["V"&(LRFMT["V"))!(LROFMT(1)'=""&(LRFMT(1)'=LROFMT(1)))
SET LROFMT=""
DO HEAD1^LRAC6
DO HEAD^LRAC6
+6 SET LROFMT=LRFMT
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 LRFDE=0
SET LRNP=0
SET LRFDT=0
SET LRLFDT=0
SET LRFFDT=0
DO LRNP
LOOP ; EP - from LRAC5
+1 IF LRACT<LRPL
SET LRFDT=LRFFDT
IF LRFMT["H"
GOTO TS^LRAC5
IF LRFMT["V"
SET LRMULT=1
SET LRMU=0
DO MUL
GOTO BS^LRAC4
+2 DO TXT1^LRAC9
IF LRCTR'<LRLNS!(IOSL-18<$Y)
SET LRFULL=1
IF 'LRFDT
SET LRFDE=1
DO HEAD1^LRAC6
IF LRFDE
DO LRBOT^LRAC6
IF 'LRFDE
DO HEAD^LRAC6
SET LRFULL=0
GOTO LRSH
+3 GOTO LRSH
MUL FOR I=0:0
IF LRMULT*(LRSHD+15)>(IOSL-9)
QUIT
SET LRMULT=LRMULT+1
+1 QUIT
LRNP ; EP - from LRAC3
+1 SET I=0
FOR
SET I=$ORDER(^LAB(64.5,1,1,LRMH,1,LRSH,1,I))
IF I<1
QUIT
SET LRTOT=LRTOT+$PIECE(^(I,0),U,2)
IF LRTOT>(IOM-20)
SET LRPL=LRPL+1
SET LRTOT=$PIECE(^(0),U,2)
LRLNS ; EP - from LRAC5
+1 KILL LRTM,^TMP($JOB,"TM")
SET LRTM=0
SET LRLNS=((IOSL-18)-($Y+(6*LRPL)))\LRPL
SET LRCL=(IOM/2)-(5+($LENGTH(LRSHN)/2))
SET LRACT=0
SET LRJS=0
SET LRNP=1
WRITE !!?LRCL,"----",LRSHN,"----"
+2 QUIT
MH1 IF LRXLR="LRAC"&(LRPERM=0)
IF '$DATA(^LAC("LGOT",LRDFN,LRMH))
QUIT
+1 SET LRMHN=$PIECE(X,U,1)
SET LRSH=0
+2 IF '$DATA(LRPG1)
SET LRPG=$SELECT($LENGTH($PIECE(X,U,2))&LRRE:$PIECE(X,U,2),$DATA(^LR(LRDFN,"PG",LRMH)):$PIECE(^(LRMH),U,2),1:0)
IF '$LENGTH($PIECE(X,U,2))!('LRRE)
SET $PIECE(^LAC(LRXLR,LRDFN,1,LRMH,0),U,2)=LRPG
SET LRPG=LRPG+1
+3 DO TOP^LRAC6
SET LROFMT=""
SET LRFDE=0
DO LRSH
DO HEAD1^LRAC6
IF 'LRFDE
DO LRBOT^LRAC6
KILL LRTM,^TMP($JOB,"TM")
SET LRFULL=0
SET LRTM=0
SET LROFMT=""
SET LRFDE=0
+4 QUIT
ENT ; EP - from LRAC1,LRACM2
+1 KILL ^TMP($JOB,"K"),LRMISC
SET LRAG=0
SET LRYESCOM=0
SET LRIL=0
SET LRFULL=0
DO LRMH
SET LRMH="MISC"
GOTO PRE^LRAC6
LRMH ; S LRMH=0 F S LRMH=$O(^LAC(LRXLR,LRDFN,1,LRMH)) Q:LRMH<1 S X=^(LRMH,0) D MH1
+1 ; ----- BEGIN IHS/OIT/MKK -- Patch 1024 Modification
+2 ; The Naked reference [S X=^(LRMH,0)] has caused <UNDEFINED> Errors. Fix it
+3 SET LRMH=0
+4 FOR
SET LRMH=$ORDER(^LAC(LRXLR,LRDFN,1,LRMH))
IF LRMH<1
QUIT
Begin DoDot:1
+5 SET X=$GET(^LAC(LRXLR,LRDFN,1,LRMH,0))
+6 IF X=""
QUIT
+7 DO MH1
End DoDot:1
+8 ; ----- END IHS/OIT/MKK -- Patch 1024 Modification
+9 QUIT
UDT ; EP - from LRAC4, LRAC9
+1 SET LRBDT=LRFDT
SET LRFDT=$SELECT($PIECE(^LAB(64.5,1,1,LRMH,1,LRSH,0),U,3)["I":$PIECE(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,0),U,1),1:LRFDT)
SET LRTIM=$EXTRACT(LRFDT,9,12)
FOR I=0:0
IF $LENGTH(LRTIM)=4
QUIT
SET LRTIM=LRTIM_0
+2 SET LRTIM=$SELECT(LRTIM?4"0":" ",1:$EXTRACT(LRTIM,1,2)_":"_$EXTRACT(LRTIM,3,4))
+3 SET LRUDT=$EXTRACT($$Y2K^LRX($PIECE(LRFDT,".")),1,5)_" "_$JUSTIFY(LRTIM,4)_" "
+4 SET LRFDT=LRBDT
IF LRTM
DO LRTM
+5 QUIT
LRTM SET LRNXSW=0
IF '$DATA(LRTM(0))
SET LRTM(0)=96
+1 IF $DATA(^TMP($JOB,"TM",LRFDT))
SET LRNXSW=1
+2 IF '$TEST
IF $DATA(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,"TX"))
SET LRTM(0)=LRTM(0)+1
SET LRNX=$CHAR(LRTM(0))
SET ^TMP($JOB,"TM",LRFDT)=LRNX
SET LRNXSW=1
SET I=0
FOR
SET I=$ORDER(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,"TX",I))
IF 'I
QUIT
SET ^TMP($JOB,"TM",LRFDT,I)=^(I,0)
+3 ;
+4 ;
Y2KALT ; EP
+1 ;03/03/1998@14:58:07
+2 ;S:LRNXSW LRUDT=$P(^TMP($J,"TM",LRFDT),U,1)_" "_LRUDT
+3 ;S LRUDT7=$$Y2K^LRX(LRFDT) ;Removed to prevent 4 digit year
+4 SET LRUDT7=$$FMTE^XLFDT(LRFDT,"2Z")
+5 SET LRUDT7=$PIECE(LRUDT7,"@")_" "_$EXTRACT($PIECE(LRUDT7,"@",2),1,5)
+6 SET LRUDT=$SELECT(LRNXSW:$PIECE(^TMP($JOB,"TM",LRFDT),U,1)_" ",1:"")_LRUDT7
+7 ;S:LRNXSW LRUDT=$P(^TMP($J,"TM",LRFDT),U,1)_" "_LRUDT7
+8 ;I LRUDT'=LRUDT7 S LRUDT=LRUDT7
+9 QUIT
