LRARCAM7.m

LRARCAM7 ; IHS/DIR/AAB - ARCHIVED RCS 14-4 REPORT, LMIP PAGE COUNTERS ; [ 5/23/95 ]

 ;;5.2;LR;**1002**;JUN 01, 1998

 ;;5.2;LAB SERVICE;**59**;Aug 31,1995

 ;same as LRCAPAM7 except archived wkld file

EN ;

INITSUM ;

 N LRIFN,LRREC,LRLARE,LRLDIV,I

 S LRIFN=0

 F  S LRIFN=$O(^LAB(64.21,LRIFN)) Q:'LRIFN  I LRIFN'=8 D

 .S LRREC=$G(^LAB(64.21,LRIFN,0))

 .Q:'$L(LRREC)

 .S LRLDIV=$P(LRREC,U,4)

 .Q:'$L(LRLDIV)

 .S LRLARE=$P(LRREC,U)

 .Q:'$L(LRLARE)

 .F I=1:1:20 S $P(^TMP($J,"LMIP",$P(LRMT,U,2),LRLDIV,0),U,I)=0

 .F I=1:1:20 S $P(^TMP($J,"LMIP",$P(LRMT,U,2),LRLDIV,LRLARE),U,I)=0

 .F I=1:1:20 S $P(^TMP($J,"LMIP",$P(LRMT,U,2),LRLDIV,LRLARE),U,I)=0

 F I=1:1:20 S $P(^TMP($J,"LMIP",$P(LRMT,U,2),"TOT-AP/CP"),U,I)=0

 Q

BMPSUM ;

 ;LRIPOT(2)=in-patient ; LROPOT(3)=outpatient ; LRNPOT(4)=other patients (REFERRAL)

 ;LRQC=qc(5) ; LRTOST=total on site ; LRMAN(8)=manual input

 ;LROTHER(12)=other ; LRSOOT(10)=send out flag ; LROSOT= total performed on-site test

 ;LRSOT(7)=total stat ; LRSOTI(6)= total inpatient stat

 ;LRTOT= total ordered test

 ;LRREP(11)=std/reps LRMII=Micro In-house LRMIO=Micro Sendout

 ;LRSUBF=suffix

 N LRREP,LRREC,LRIPOT,LROPOT,LRNPOT,LRQC,LRSOT,LRMAN,LRSOOT,LROSOT,LRTOT,LRTOST

 N LRREC2,LRREC3,LRSKIP,LRLDIV,LRLARE,LROTHER

 N LRSOTI,LRMII,LRMIO,LRSUBF

 S LRSOTI=$P(LRN,U,6),LRSUBF=$P($P(LRN,U),".",2)

 S LRIPOT=+$P(LRN,U,2),LROPOT=+$P(LRN,U,3),LRNPOT=+$P(LRN,U,4)

 S LRQC=+$P(LRN,U,5),LRSOT=+$P(LRN,U,7),LRMAN=+$P(LRN,U,8)

 S LRSOOT=+$P(LRN,U,10),LRREP=$P(LRN,U,11),LROTHER=+$P(LRN,U,12)

 S LROSOT=$S(LRSOOT:0,1:(LRIPOT+LROPOT+LRNPOT))

 S LRTOT=LRIPOT+LROPOT+LRNPOT

 S LRTOST=LRIPOT+LROPOT+LRNPOT+LRMAN+LRQC+LROTHER+LRREP

 I $E(LRSUBF,3,4)="00" D

 . I LRSUBF>8000,LRSUBF<9000,LRSUBF'=8500,LRSUBF'=8600 S LRMIO=LRTOT

 . I LRSUBF>7000,LRSUBF<8000,LRSUBF'=7500,LRSUBF'=7600 S LRMII=LRTOT

 . S:'$D(LRMIPER) LRMIPER="^"

 . S $P(LRMIPER,U)=$P(LRMIPER,U)+$G(LRMIO),$P(LRMIPER,U,2)=$P(LRMIPER,U,2)+$G(LRMII)

 D GETDA Q:LRSKIP

 ;bump div/area counts

 S LRREC=$G(^TMP($J,"LMIP",$P(LRMT,U,2),LRLDIV,LRLARE))

 S $P(LRREC,U)=$P(LRREC,U)+LRIPOT ;LMIP field #5

 S $P(LRREC,U,2)=$P(LRREC,U,2)+LROPOT ;LMIP field #6

 S $P(LRREC,U,3)=$P(LRREC,U,3)+LRNPOT ;LMIP field #7

 S $P(LRREC,U,4)=$P(LRREC,U,4)+LRTOT ;LMIP field #1

 S $P(LRREC,U,5)=$P(LRREC,U,5)+LRQC ;no LIMP field #

 S $P(LRREC,U,6)=$P(LRREC,U,6)+LRTOST ;LMIP field #2

 S $P(LRREC,U,7)=$P(LRREC,U,7)+LRSOOT ;LMIP field #4

 S $P(LRREC,U,8)=$P(LRREC,U,8)+LROSOT ;LMIP field #3

 S $P(LRREC,U,9)=$P(LRREC,U,9)+LRSOT ;LMIP field #8

 S $P(LRREC,U,12)=$P(LRREC,U,12)+LRREP ;Repeats

 S $P(LRREC,U,13)=$P(LRREC,U,13)+LRMAN ;Manual Inputs

 S $P(LRREC,U,14)=$P(LRREC,U,14)+$G(LRMII) ;Micro Inp

 S $P(LRREC,U,15)=$P(LRREC,U,15)+$G(LRMIO) ;Micro Out

 S $P(LRREC,U,16)=$P(LRREC,U,16)+LRSOTI ; In Pat stats

 S $P(LRREC,U,17)=$P(LRREC,U,17)+LROTHER ; Others

 S ^TMP($J,"LMIP",$P(LRMT,U,2),LRLDIV,LRLARE)=LRREC

 ;Also bump subtotal counts

 S LRREC2=$G(^TMP($J,"LMIP",$P(LRMT,U,2),LRLDIV,0))

 S $P(LRREC2,U)=$P(LRREC2,U)+LRIPOT

 S $P(LRREC2,U,2)=$P(LRREC2,U,2)+LROPOT

 S $P(LRREC2,U,3)=$P(LRREC2,U,3)+LRNPOT

 S $P(LRREC2,U,4)=$P(LRREC2,U,4)+LRTOT

 S $P(LRREC2,U,5)=$P(LRREC2,U,5)+LRQC

 S $P(LRREC2,U,6)=$P(LRREC2,U,6)+LRTOST

 S $P(LRREC2,U,7)=$P(LRREC2,U,7)+LRSOOT

 S $P(LRREC2,U,8)=$P(LRREC2,U,8)+LROSOT

 S $P(LRREC2,U,9)=$P(LRREC2,U,9)+LRSOT

 S $P(LRREC2,U,12)=$P(LRREC2,U,12)+LRREP ;Repeats

 S $P(LRREC2,U,13)=$P(LRREC2,U,13)+LRMAN ;Manual Inputs

 S $P(LRREC2,U,14)=$P(LRREC2,U,14)+$G(LRMII) ;Micro Inp

 S $P(LRREC2,U,15)=$P(LRREC2,U,15)+$G(LRMIO) ;Micro Out

 S $P(LRREC2,U,16)=$P(LRREC2,U,16)+LRSOTI ; In Pat stats

 S $P(LRREC2,U,17)=$P(LRREC2,U,17)+LROTHER ; Others

 S ^TMP($J,"LMIP",$P(LRMT,U,2),LRLDIV,0)=LRREC2

 ;Also bump grand total counts

 S LRREC3=$G(^TMP($J,"LMIP",$P(LRMT,U,2),"TOT-AP/CP"))

 S $P(LRREC3,U)=$P(LRREC3,U)+LRIPOT

 S $P(LRREC3,U,2)=$P(LRREC3,U,2)+LROPOT

 S $P(LRREC3,U,3)=$P(LRREC3,U,3)+LRNPOT

 S $P(LRREC3,U,4)=$P(LRREC3,U,4)+LRTOT

 S $P(LRREC3,U,5)=$P(LRREC3,U,5)+LRQC

 S $P(LRREC3,U,6)=$P(LRREC3,U,6)+LRTOST

 S $P(LRREC3,U,7)=$P(LRREC3,U,7)+LRSOOT

 S $P(LRREC3,U,8)=$P(LRREC3,U,8)+LROSOT

 S $P(LRREC3,U,9)=$P(LRREC3,U,9)+LRSOT

 S $P(LRREC3,U,12)=$P(LRREC3,U,12)+LRREP ;Repeats

 S $P(LRREC3,U,13)=$P(LRREC3,U,13)+LRMAN ;Manual Inputs

 S $P(LRREC3,U,14)=$P(LRREC3,U,14)+$G(LRMII) ;Micro Inp

 S $P(LRREC3,U,15)=$P(LRREC3,U,15)+$G(LRMIO) ;Micro Out

 S $P(LRREC3,U,16)=$P(LRREC3,U,16)+LRSOTI ; In Pat stats

 S $P(LRREC3,U,17)=$P(LRREC3,U,17)+LROTHER ; Others

 S ^TMP($J,"LMIP",$P(LRMT,U,2),"TOT-AP/CP")=LRREC3

 Q

GETDA ;Get lab division and area

 N LRPTR,LRREC3

 S LRSKIP=1

 Q:'$G(LRCAPIFN)  Q:'$P($G(^LAM(LRCAPIFN,0)),U,5)

 S LRPTR=+$P($G(^LAM(LRCAPIFN,0)),U,15)

 S:'LRPTR LRPTR=1

 S LRREC3=$G(^LAB(64.21,LRPTR,0))

 Q:'$L(LRREC3)

 S LRLDIV=$P(LRREC3,U,4)

 Q:'$L(LRLDIV)

 S LRLARE=$P(LRREC3,U)

 Q:'$L(LRLARE)

 S LRSKIP=0

 Q

LRARCAM7  ; IHS/DIR/AAB - ARCHIVED RCS 14-4 REPORT, LMIP PAGE COUNTERS ; [ 5/23/95 ]

 +1       ;;5.2;LR;**1002**;JUN 01, 1998

 +2       ;;5.2;LAB SERVICE;**59**;Aug 31,1995

 +3       ;same as LRCAPAM7 except archived wkld file

EN        ;

INITSUM   ;

 +1        NEW LRIFN,LRREC,LRLARE,LRLDIV,I

 +2        SET LRIFN=0

 +3        FOR 

               SET LRIFN=$ORDER(^LAB(64.21,LRIFN))

               IF 'LRIFN

                   QUIT 

               IF LRIFN'=8

                   Begin DoDot:1

 +4                    SET LRREC=$GET(^LAB(64.21,LRIFN,0))

 +5                    IF '$LENGTH(LRREC)

                           QUIT 

 +6                    SET LRLDIV=$PIECE(LRREC,U,4)

 +7                    IF '$LENGTH(LRLDIV)

                           QUIT 

 +8                    SET LRLARE=$PIECE(LRREC,U)

 +9                    IF '$LENGTH(LRLARE)

                           QUIT 

 +10                   FOR I=1:1:20

                           SET $PIECE(^TMP($JOB,"LMIP",$PIECE(LRMT,U,2),LRLDIV,0),U,I)=0

 +11                   FOR I=1:1:20

                           SET $PIECE(^TMP($JOB,"LMIP",$PIECE(LRMT,U,2),LRLDIV,LRLARE),U,I)=0

 +12                   FOR I=1:1:20

                           SET $PIECE(^TMP($JOB,"LMIP",$PIECE(LRMT,U,2),LRLDIV,LRLARE),U,I)=0

                   End DoDot:1

 +13       FOR I=1:1:20

               SET $PIECE(^TMP($JOB,"LMIP",$PIECE(LRMT,U,2),"TOT-AP/CP"),U,I)=0

 +14       QUIT 

BMPSUM    ;

 +1       ;LRIPOT(2)=in-patient ; LROPOT(3)=outpatient ; LRNPOT(4)=other patients (REFERRAL)

 +2       ;LRQC=qc(5) ; LRTOST=total on site ; LRMAN(8)=manual input

 +3       ;LROTHER(12)=other ; LRSOOT(10)=send out flag ; LROSOT= total performed on-site test

 +4       ;LRSOT(7)=total stat ; LRSOTI(6)= total inpatient stat

 +5       ;LRTOT= total ordered test

 +6       ;LRREP(11)=std/reps LRMII=Micro In-house LRMIO=Micro Sendout

 +7       ;LRSUBF=suffix

 +8        NEW LRREP,LRREC,LRIPOT,LROPOT,LRNPOT,LRQC,LRSOT,LRMAN,LRSOOT,LROSOT,LRTOT,LRTOST

 +9        NEW LRREC2,LRREC3,LRSKIP,LRLDIV,LRLARE,LROTHER

 +10       NEW LRSOTI,LRMII,LRMIO,LRSUBF

 +11       SET LRSOTI=$PIECE(LRN,U,6)

           SET LRSUBF=$PIECE($PIECE(LRN,U),".",2)

 +12       SET LRIPOT=+$PIECE(LRN,U,2)

           SET LROPOT=+$PIECE(LRN,U,3)

           SET LRNPOT=+$PIECE(LRN,U,4)

 +13       SET LRQC=+$PIECE(LRN,U,5)

           SET LRSOT=+$PIECE(LRN,U,7)

           SET LRMAN=+$PIECE(LRN,U,8)

 +14       SET LRSOOT=+$PIECE(LRN,U,10)

           SET LRREP=$PIECE(LRN,U,11)

           SET LROTHER=+$PIECE(LRN,U,12)

 +15       SET LROSOT=$SELECT(LRSOOT:0,1:(LRIPOT+LROPOT+LRNPOT))

 +16       SET LRTOT=LRIPOT+LROPOT+LRNPOT

 +17       SET LRTOST=LRIPOT+LROPOT+LRNPOT+LRMAN+LRQC+LROTHER+LRREP

 +18       IF $EXTRACT(LRSUBF,3,4)="00"

               Begin DoDot:1

 +19               IF LRSUBF>8000

                       IF LRSUBF<9000

                           IF LRSUBF'=8500

                               IF LRSUBF'=8600

                                   SET LRMIO=LRTOT

 +20               IF LRSUBF>7000

                       IF LRSUBF<8000

                           IF LRSUBF'=7500

                               IF LRSUBF'=7600

                                   SET LRMII=LRTOT

 +21               IF '$DATA(LRMIPER)

                       SET LRMIPER="^"

 +22               SET $PIECE(LRMIPER,U)=$PIECE(LRMIPER,U)+$GET(LRMIO)

                   SET $PIECE(LRMIPER,U,2)=$PIECE(LRMIPER,U,2)+$GET(LRMII)

               End DoDot:1

 +23       DO GETDA

           IF LRSKIP

               QUIT 

 +24      ;bump div/area counts

 +25       SET LRREC=$GET(^TMP($JOB,"LMIP",$PIECE(LRMT,U,2),LRLDIV,LRLARE))

 +26      ;LMIP field #5

           SET $PIECE(LRREC,U)=$PIECE(LRREC,U)+LRIPOT

 +27      ;LMIP field #6

           SET $PIECE(LRREC,U,2)=$PIECE(LRREC,U,2)+LROPOT

 +28      ;LMIP field #7

           SET $PIECE(LRREC,U,3)=$PIECE(LRREC,U,3)+LRNPOT

 +29      ;LMIP field #1

           SET $PIECE(LRREC,U,4)=$PIECE(LRREC,U,4)+LRTOT

 +30      ;no LIMP field #

           SET $PIECE(LRREC,U,5)=$PIECE(LRREC,U,5)+LRQC

 +31      ;LMIP field #2

           SET $PIECE(LRREC,U,6)=$PIECE(LRREC,U,6)+LRTOST

 +32      ;LMIP field #4

           SET $PIECE(LRREC,U,7)=$PIECE(LRREC,U,7)+LRSOOT

 +33      ;LMIP field #3

           SET $PIECE(LRREC,U,8)=$PIECE(LRREC,U,8)+LROSOT

 +34      ;LMIP field #8

           SET $PIECE(LRREC,U,9)=$PIECE(LRREC,U,9)+LRSOT

 +35      ;Repeats

           SET $PIECE(LRREC,U,12)=$PIECE(LRREC,U,12)+LRREP

 +36      ;Manual Inputs

           SET $PIECE(LRREC,U,13)=$PIECE(LRREC,U,13)+LRMAN

 +37      ;Micro Inp

           SET $PIECE(LRREC,U,14)=$PIECE(LRREC,U,14)+$GET(LRMII)

 +38      ;Micro Out

           SET $PIECE(LRREC,U,15)=$PIECE(LRREC,U,15)+$GET(LRMIO)

 +39      ; In Pat stats

           SET $PIECE(LRREC,U,16)=$PIECE(LRREC,U,16)+LRSOTI

 +40      ; Others

           SET $PIECE(LRREC,U,17)=$PIECE(LRREC,U,17)+LROTHER

 +41       SET ^TMP($JOB,"LMIP",$PIECE(LRMT,U,2),LRLDIV,LRLARE)=LRREC

 +42      ;Also bump subtotal counts

 +43       SET LRREC2=$GET(^TMP($JOB,"LMIP",$PIECE(LRMT,U,2),LRLDIV,0))

 +44       SET $PIECE(LRREC2,U)=$PIECE(LRREC2,U)+LRIPOT

 +45       SET $PIECE(LRREC2,U,2)=$PIECE(LRREC2,U,2)+LROPOT

 +46       SET $PIECE(LRREC2,U,3)=$PIECE(LRREC2,U,3)+LRNPOT

 +47       SET $PIECE(LRREC2,U,4)=$PIECE(LRREC2,U,4)+LRTOT

 +48       SET $PIECE(LRREC2,U,5)=$PIECE(LRREC2,U,5)+LRQC

 +49       SET $PIECE(LRREC2,U,6)=$PIECE(LRREC2,U,6)+LRTOST

 +50       SET $PIECE(LRREC2,U,7)=$PIECE(LRREC2,U,7)+LRSOOT

 +51       SET $PIECE(LRREC2,U,8)=$PIECE(LRREC2,U,8)+LROSOT

 +52       SET $PIECE(LRREC2,U,9)=$PIECE(LRREC2,U,9)+LRSOT

 +53      ;Repeats

           SET $PIECE(LRREC2,U,12)=$PIECE(LRREC2,U,12)+LRREP

 +54      ;Manual Inputs

           SET $PIECE(LRREC2,U,13)=$PIECE(LRREC2,U,13)+LRMAN

 +55      ;Micro Inp

           SET $PIECE(LRREC2,U,14)=$PIECE(LRREC2,U,14)+$GET(LRMII)

 +56      ;Micro Out

           SET $PIECE(LRREC2,U,15)=$PIECE(LRREC2,U,15)+$GET(LRMIO)

 +57      ; In Pat stats

           SET $PIECE(LRREC2,U,16)=$PIECE(LRREC2,U,16)+LRSOTI

 +58      ; Others

           SET $PIECE(LRREC2,U,17)=$PIECE(LRREC2,U,17)+LROTHER

 +59       SET ^TMP($JOB,"LMIP",$PIECE(LRMT,U,2),LRLDIV,0)=LRREC2

 +60      ;Also bump grand total counts

 +61       SET LRREC3=$GET(^TMP($JOB,"LMIP",$PIECE(LRMT,U,2),"TOT-AP/CP"))

 +62       SET $PIECE(LRREC3,U)=$PIECE(LRREC3,U)+LRIPOT

 +63       SET $PIECE(LRREC3,U,2)=$PIECE(LRREC3,U,2)+LROPOT

 +64       SET $PIECE(LRREC3,U,3)=$PIECE(LRREC3,U,3)+LRNPOT

 +65       SET $PIECE(LRREC3,U,4)=$PIECE(LRREC3,U,4)+LRTOT

 +66       SET $PIECE(LRREC3,U,5)=$PIECE(LRREC3,U,5)+LRQC

 +67       SET $PIECE(LRREC3,U,6)=$PIECE(LRREC3,U,6)+LRTOST

 +68       SET $PIECE(LRREC3,U,7)=$PIECE(LRREC3,U,7)+LRSOOT

 +69       SET $PIECE(LRREC3,U,8)=$PIECE(LRREC3,U,8)+LROSOT

 +70       SET $PIECE(LRREC3,U,9)=$PIECE(LRREC3,U,9)+LRSOT

 +71      ;Repeats

           SET $PIECE(LRREC3,U,12)=$PIECE(LRREC3,U,12)+LRREP

 +72      ;Manual Inputs

           SET $PIECE(LRREC3,U,13)=$PIECE(LRREC3,U,13)+LRMAN

 +73      ;Micro Inp

           SET $PIECE(LRREC3,U,14)=$PIECE(LRREC3,U,14)+$GET(LRMII)

 +74      ;Micro Out

           SET $PIECE(LRREC3,U,15)=$PIECE(LRREC3,U,15)+$GET(LRMIO)

 +75      ; In Pat stats

           SET $PIECE(LRREC3,U,16)=$PIECE(LRREC3,U,16)+LRSOTI

 +76      ; Others

           SET $PIECE(LRREC3,U,17)=$PIECE(LRREC3,U,17)+LROTHER

 +77       SET ^TMP($JOB,"LMIP",$PIECE(LRMT,U,2),"TOT-AP/CP")=LRREC3

 +78       QUIT 

GETDA     ;Get lab division and area

 +1        NEW LRPTR,LRREC3

 +2        SET LRSKIP=1

 +3        IF '$GET(LRCAPIFN)

               QUIT 

           IF '$PIECE($GET(^LAM(LRCAPIFN,0)),U,5)

               QUIT 

 +4        SET LRPTR=+$PIECE($GET(^LAM(LRCAPIFN,0)),U,15)

 +5        IF 'LRPTR

               SET LRPTR=1

 +6        SET LRREC3=$GET(^LAB(64.21,LRPTR,0))

 +7        IF '$LENGTH(LRREC3)

               QUIT 

 +8        SET LRLDIV=$PIECE(LRREC3,U,4)

 +9        IF '$LENGTH(LRLDIV)

               QUIT 

 +10       SET LRLARE=$PIECE(LRREC3,U)

 +11       IF '$LENGTH(LRLARE)

               QUIT 

 +12       SET LRSKIP=0

 +13       QUIT