LRAC4.m

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