LRARCAM7 ;DALISC/CKA - ARCHIVED RCS 14-4 REPORT, LMIP PAGE COUNTERS ;5/23/95
;;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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRARCAM7 4858 printed Nov 22, 2024@17:19:04 Page 2
LRARCAM7 ;DALISC/CKA - ARCHIVED RCS 14-4 REPORT, LMIP PAGE COUNTERS ;5/23/95
+1 ;;5.2;LAB SERVICE;**59**;Aug 31,1995
+2 ;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
