- LRCAPAM7 ;DALISC/J0 - RCS 14-4 REPORT, LMIP PAGE COUNTERS ;5/10/93
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- 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[HLRCAPAM7 4797 printed Feb 18, 2025@23:38:34 Page 2
- LRCAPAM7 ;DALISC/J0 - RCS 14-4 REPORT, LMIP PAGE COUNTERS ;5/10/93
- +1 ;;5.2;LAB SERVICE;;Sep 27, 1994
- 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