LRAC4 ; IHS/DIR/AAB - PRINT CUMULATIVE REPORT 5/16/88 10:49 ; [ 07/22/2002 12:27 PM ]
;;5.2;LR;**201,1006,1013,1021,1024**;May 02, 2008
;
BS1 S ^TMP($J,"TY",K,"L")=$P(Z,U,2),^TMP($J,"K",LRSH,LRFDT,0)=LRSH_U_$P(Z,U,1)_U_$P(Z,U,5),LRTT=LRTT+1 S ^TMP($J,"Y2K",K)=$E($P($P($$Y2K^LRX(LRFDT),"."),"/",3),1,4)
S:LRFDT>LRLFDT LRLFDT=LRFDT D IA,UDT^LRAC3 S ^TMP($J,"TY",K,0)=$P(LRUDT," ",1),^TMP($J,"TY",K,"T")=$P(LRUDT," ",2)
;
F J=1:1:LRSHD I $D(I(J)) S:$D(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,1,I(J),0)) T1=$P(^(0),U,1,2),T3=$P(^(0),U,3),^TMP($J,"TY",K,J)=T1,^TMP($J,"K",LRSH,LRFDT,LRKL)=T3,LRKL=LRKL+1 D BS3
K T1,T3 Q
BS3 S:$D(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,"TX"))&'$D(LRTX(LRTT)) LRTX(LRTT)=LRFDT
Q
BS2 S X=$S($D(^TMP($J,"TY",J,I)):$P(^(I),U,1),1:""),X1=$S($L(X):$P(^(I),U,2),1:""),LRDP=$S($D(^TMP($J,"TY",I,"D")):^("D"),1:""),LRCL=LRCL+10
Q
BS4 F J=0:1:(LRTT+1) W:J=0 ^TMP($J,"TY",J,I) W ?LRCL I J>0 D BS2 I $L(X) S LRCW=10 D:J<LRTT C1^LRAC9 W:$L($P(LRG,U,4))&(J<LRTT) @$P(LRG,U,4),X1 W:'$L($P(LRG,U,4))!(J'<LRTT) $J(X,LRCW)
Q
BS ;EP - from LRAC3
;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1021
NEW P3,P6
;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1021
K I,^TMP($J,"TY") S LRCW=10,LRHI="",LRLO="",LRTT=1,I=0,LRTY=IOM-20\10,LRMU=LRMU+1
S LRII=0 F S LRII=$O(^LAB(64.5,1,1,LRMH,1,LRSH,1,LRII)) Q:LRII<1 S Z=^(LRII,0),P3=$P(Z,U,3),P6=$P(Z,U,6),I=I+1,I(I)=LRII,^TMP($J,"TY",0,I)=P3 S:P6 ^TMP($J,"TY",I,"D")=P6
;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1021
; K P3,P6
;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1021
; F K=1:1:(LRTY-1) S LRFDT=$O(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT)) Q:LRFDT<1 S Z=^(LRFDT,0) D BS1
;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1024
;The Naked reference has caused <UNDEFINED> Errors. Fix it
F K=1:1:(LRTY-1) S LRFDT=$O(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT)) Q:LRFDT<1 S Z=$G(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,0)) I $L(Z)>0 D BS1
;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1024
S:LRTT>(LRTY-1)&(LRMULT=1) LRFULL=1 S:LRTT>(LRTY-1)&(LRMU=(LRMULT-1)) LRFULL=1 F I=1:1:LRSHD I $D(I(I)) D LRLO^LRAC9 S:$L(LRLOHI) ^TMP($J,"TY",(LRTT+1),I)=LRLOHI S:$L(P7) ^TMP($J,"TY",LRTT,I)=P7 K P7
S ^TMP($J,"TY",LRTT,"T")="Units",^TMP($J,"TY",(LRTT+1),"T")="Ranges",^TMP($J,"TY",(LRTT+1),0)=$S($L($P(^LAB(64.5,"A",1,LRMH,LRSH,I(1)),U,11)):"Therapeutic",1:"Reference"),^TMP($J,"TY",LRTT,0)=""
W ! I $D(IA(0)) W IA(0) F I=1:1:(LRTT+1) W $S($D(IA(I)):$J(IA(I),10),1:$J("",10))
K IA,IAX,IARNO,IADA
; I $D(LRCALE(LRMH,LRSH)) W !,"Locale " F I=1:1:(LRTT-1) W $J(^TMP($J,"TY",I,"L"),10)
;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1024
I $D(LRCALE(LRMH,LRSH)) W !,"Locale " F I=1:1:(LRTT-1) W:$G(^TMP($J,"TY",I,"L"))'="" $J($G(^TMP($J,"TY",I,"L")),10)
;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1024
;
Y2K ;
; W !,$E(LRTOPP,1,7),?6 F I=1:1:(LRTT+1) W $J(^TMP($J,"TY",I,0),10)
;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1024
W !,$E(LRTOPP,1,7),?6 F I=1:1:(LRTT+1) W:$G(^TMP($J,"TY",I,0))'="" $J(^TMP($J,"TY",I,0),10)
;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1024
YEAR ;
; W !?5 F I=1:1:(LRTT-1) W $J(^TMP($J,"Y2K",I),10)
; W !?6 F I=1:1:(LRTT+1) W $J(^TMP($J,"TY",I,"T"),10)
;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1024
W !?5 F I=1:1:(LRTT-1) W:$G(^TMP($J,"Y2K",I))'="" $J(^TMP($J,"Y2K",I),10)
W !?6 F I=1:1:(LRTT+1) W:$G(^TMP($J,"TY",I,"T"))'="" $J(^TMP($J,"TY",I,"T"),10)
;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1024
;W !,$E(LRTOPP,1,7),?7 F I=1:1:(LRTT+1) W $J(^TMP($J,"TY",I,0),6)," "
;W !,$E(LRTOPP,1,7),?7 F I=1:1:(LRTT+1) W ^TMP($J,"TY",I,0)_" "
;
;W !?6 F I=1:1:(LRTT+1) W $J(^TMP($J,"TY",I,"T"),10) F LRC19=1:1:I W " "
;W !?11 F I=1:1:(LRTT+1) W ^TMP($J,"TY",I,"T")_" "
D DASH^LRX
; F I=1:1:LRSHD I $D(I(I)) S LRCL=8,LRG=^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0) W ! D BS4
;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1024
F I=1:1:LRSHD I $D(I(I)) S LRCL=8,LRG=$G(^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0)) W ! D BS4
;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1024
I $D(LRTX) S LRTX="" W !,"Comments: " F I=1:1 S LRTX=$O(LRTX(LRTX)) Q:LRTX="" W ?(10*LRTX-6),$C(96+I)
D TXT1^LRAC9 S LROFDT=LRFDT I $D(LRTX) S LRTX="" F I=1:1 S LRTX=$O(LRTX(LRTX)) Q:LRTX="" S LRFDT=LRTX(LRTX) D:$Y>(IOSL-8) OVFL^LRAC7 W !,$C(96+I),". " D TXT^LRAC9
S LRFDT=LROFDT K LRTY,LRTX,^TMP($J,"TY") I 'LRFDT D HEAD1^LRAC6 G LRSH^LRAC3
I $O(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT))<1 D HEAD1^LRAC6 G LRSH^LRAC3
S LRFDT=LRLFDT I LRFULL D HEAD1^LRAC6,HEAD^LRAC6,LRNP^LRAC3 S LRFULL=0,LRMU=0
G BS
IA I $D(DUZ("AG")),$L(DUZ("AG")),"ARMYAFN"[DUZ("AG"),LRDPF=2 S IADA=$P(^LR(LRDFN,0),U,3) I IADA'="",$D(^DPT(IADA,0)) S IAX=LRFDT D ^LRAIRNUM I IARNO'="" S:'$D(IA(0)) IA(0)="INPAT #" S IA(K)=IARNO
Q
LRAC4 ; IHS/DIR/AAB - PRINT CUMULATIVE REPORT 5/16/88 10:49 ; [ 07/22/2002 12:27 PM ]
+1 ;;5.2;LR;**201,1006,1013,1021,1024**;May 02, 2008
+2 ;
BS1 SET ^TMP($JOB,"TY",K,"L")=$PIECE(Z,U,2)
SET ^TMP($JOB,"K",LRSH,LRFDT,0)=LRSH_U_$PIECE(Z,U,1)_U_$PIECE(Z,U,5)
SET LRTT=LRTT+1
SET ^TMP($JOB,"Y2K",K)=$EXTRACT($PIECE($PIECE($$Y2K^LRX(LRFDT),"."),"/",3),1,4)
+1 IF LRFDT>LRLFDT
SET LRLFDT=LRFDT
DO IA
DO UDT^LRAC3
SET ^TMP($JOB,"TY",K,0)=$PIECE(LRUDT," ",1)
SET ^TMP($JOB,"TY",K,"T")=$PIECE(LRUDT," ",2)
+2 ;
+3 FOR J=1:1:LRSHD
IF $DATA(I(J))
IF $DATA(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,1,I(J),0))
SET T1=$PIECE(^(0),U,1,2)
SET T3=$PIECE(^(0),U,3)
SET ^TMP($JOB,"TY",K,J)=T1
SET ^TMP($JOB,"K",LRSH,LRFDT,LRKL)=T3
SET LRKL=LRKL+1
DO BS3
+4 KILL T1,T3
QUIT
BS3 IF $DATA(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,"TX"))&'$DATA(LRTX(LRTT))
SET LRTX(LRTT)=LRFDT
+1 QUIT
BS2 SET X=$SELECT($DATA(^TMP($JOB,"TY",J,I)):$PIECE(^(I),U,1),1:"")
SET X1=$SELECT($LENGTH(X):$PIECE(^(I),U,2),1:"")
SET LRDP=$SELECT($DATA(^TMP($JOB,"TY",I,"D")):^("D"),1:"")
SET LRCL=LRCL+10
+1 QUIT
BS4 FOR J=0:1:(LRTT+1)
IF J=0
WRITE ^TMP($JOB,"TY",J,I)
WRITE ?LRCL
IF J>0
DO BS2
IF $LENGTH(X)
SET LRCW=10
IF J<LRTT
DO C1^LRAC9
IF $LENGTH($PIECE(LRG,U,4))&(J<LRTT)
WRITE @$PIECE(LRG,U,4),X1
IF '$LENGTH($PIECE(LRG,U,4))!(J'<LRTT)
WRITE $JUSTIFY(X,LRCW)
+1 QUIT
BS ;EP - from LRAC3
+1 ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1021
+2 NEW P3,P6
+3 ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1021
+4 KILL I,^TMP($JOB,"TY")
SET LRCW=10
SET LRHI=""
SET LRLO=""
SET LRTT=1
SET I=0
SET LRTY=IOM-20\10
SET LRMU=LRMU+1
+5 SET LRII=0
FOR
SET LRII=$ORDER(^LAB(64.5,1,1,LRMH,1,LRSH,1,LRII))
IF LRII<1
QUIT
SET Z=^(LRII,0)
SET P3=$PIECE(Z,U,3)
SET P6=$PIECE(Z,U,6)
SET I=I+1
SET I(I)=LRII
SET ^TMP($JOB,"TY",0,I)=P3
IF P6
SET ^TMP($JOB,"TY",I,"D")=P6
+6 ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1021
+7 ; K P3,P6
+8 ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1021
+9 ; F K=1:1:(LRTY-1) S LRFDT=$O(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT)) Q:LRFDT<1 S Z=^(LRFDT,0) D BS1
+10 ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1024
+11 ;The Naked reference has caused <UNDEFINED> Errors. Fix it
+12 FOR K=1:1:(LRTY-1)
SET LRFDT=$ORDER(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT))
IF LRFDT<1
QUIT
SET Z=$GET(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,0))
IF $LENGTH(Z)>0
DO BS1
+13 ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1024
+14 IF LRTT>(LRTY-1)&(LRMULT=1)
SET LRFULL=1
IF LRTT>(LRTY-1)&(LRMU=(LRMULT-1))
SET LRFULL=1
FOR I=1:1:LRSHD
IF $DATA(I(I))
DO LRLO^LRAC9
IF $LENGTH(LRLOHI)
SET ^TMP($JOB,"TY",(LRTT+1),I)=LRLOHI
IF $LENGTH(P7)
SET ^TMP($JOB,"TY",LRTT,I)=P7
KILL P7
+15 SET ^TMP($JOB,"TY",LRTT,"T")="Units"
SET ^TMP($JOB,"TY",(LRTT+1),"T")="Ranges"
SET ^TMP($JOB,"TY",(LRTT+1),0)=$SELECT($LENGTH($PIECE(^LAB(64.5,"A",1,LRMH,LRSH,I(1)),U,11)):"Therapeutic",1:"Reference")
SET ^TMP($JOB,"TY",LRTT,0)=""
+16 WRITE !
IF $DATA(IA(0))
WRITE IA(0)
FOR I=1:1:(LRTT+1)
WRITE $SELECT($DATA(IA(I)):$JUSTIFY(IA(I),10),1:$JUSTIFY("",10))
+17 KILL IA,IAX,IARNO,IADA
+18 ; I $D(LRCALE(LRMH,LRSH)) W !,"Locale " F I=1:1:(LRTT-1) W $J(^TMP($J,"TY",I,"L"),10)
+19 ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1024
+20 IF $DATA(LRCALE(LRMH,LRSH))
WRITE !,"Locale "
FOR I=1:1:(LRTT-1)
IF $GET(^TMP($JOB,"TY",I,"L"))'=""
WRITE $JUSTIFY($GET(^TMP($JOB,"TY",I,"L")),10)
+21 ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1024
+22 ;
Y2K ;
+1 ; W !,$E(LRTOPP,1,7),?6 F I=1:1:(LRTT+1) W $J(^TMP($J,"TY",I,0),10)
+2 ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1024
+3 WRITE !,$EXTRACT(LRTOPP,1,7),?6
FOR I=1:1:(LRTT+1)
IF $GET(^TMP($JOB,"TY",I,0))'=""
WRITE $JUSTIFY(^TMP($JOB,"TY",I,0),10)
+4 ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1024
YEAR ;
+1 ; W !?5 F I=1:1:(LRTT-1) W $J(^TMP($J,"Y2K",I),10)
+2 ; W !?6 F I=1:1:(LRTT+1) W $J(^TMP($J,"TY",I,"T"),10)
+3 ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1024
+4 WRITE !?5
FOR I=1:1:(LRTT-1)
IF $GET(^TMP($JOB,"Y2K",I))'=""
WRITE $JUSTIFY(^TMP($JOB,"Y2K",I),10)
+5 WRITE !?6
FOR I=1:1:(LRTT+1)
IF $GET(^TMP($JOB,"TY",I,"T"))'=""
WRITE $JUSTIFY(^TMP($JOB,"TY",I,"T"),10)
+6 ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1024
+7 ;W !,$E(LRTOPP,1,7),?7 F I=1:1:(LRTT+1) W $J(^TMP($J,"TY",I,0),6)," "
+8 ;W !,$E(LRTOPP,1,7),?7 F I=1:1:(LRTT+1) W ^TMP($J,"TY",I,0)_" "
+9 ;
+10 ;W !?6 F I=1:1:(LRTT+1) W $J(^TMP($J,"TY",I,"T"),10) F LRC19=1:1:I W " "
+11 ;W !?11 F I=1:1:(LRTT+1) W ^TMP($J,"TY",I,"T")_" "
+12 DO DASH^LRX
+13 ; F I=1:1:LRSHD I $D(I(I)) S LRCL=8,LRG=^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0) W ! D BS4
+14 ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1024
+15 FOR I=1:1:LRSHD
IF $DATA(I(I))
SET LRCL=8
SET LRG=$GET(^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0))
WRITE !
DO BS4
+16 ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1024
+17 IF $DATA(LRTX)
SET LRTX=""
WRITE !,"Comments: "
FOR I=1:1
SET LRTX=$ORDER(LRTX(LRTX))
IF LRTX=""
QUIT
WRITE ?(10*LRTX-6),$CHAR(96+I)
+18 DO TXT1^LRAC9
SET LROFDT=LRFDT
IF $DATA(LRTX)
SET LRTX=""
FOR I=1:1
SET LRTX=$ORDER(LRTX(LRTX))
IF LRTX=""
QUIT
SET LRFDT=LRTX(LRTX)
IF $Y>(IOSL-8)
DO OVFL^LRAC7
WRITE !,$CHAR(96+I),". "
DO TXT^LRAC9
+19 SET LRFDT=LROFDT
KILL LRTY,LRTX,^TMP($JOB,"TY")
IF 'LRFDT
DO HEAD1^LRAC6
GOTO LRSH^LRAC3
+20 IF $ORDER(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT))<1
DO HEAD1^LRAC6
GOTO LRSH^LRAC3
+21 SET LRFDT=LRLFDT
IF LRFULL
DO HEAD1^LRAC6
DO HEAD^LRAC6
DO LRNP^LRAC3
SET LRFULL=0
SET LRMU=0
+22 GOTO BS
IA IF $DATA(DUZ("AG"))
IF $LENGTH(DUZ("AG"))
IF "ARMYAFN"[DUZ("AG")
IF LRDPF=2
SET IADA=$PIECE(^LR(LRDFN,0),U,3)
IF IADA'=""
IF $DATA(^DPT(IADA,0))
SET IAX=LRFDT
DO ^LRAIRNUM
IF IARNO'=""
IF '$DATA(IA(0))
SET IA(0)="INPAT #"
SET IA(K)=IARNO
+1 QUIT
