source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRARCAM7.m@ 1783

Last change on this file since 1783 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.6 KB
Line 
1LRARCAM7 ;DALISC/CKA - ARCHIVED RCS 14-4 REPORT, LMIP PAGE COUNTERS ;5/23/95
2 ;;5.2;LAB SERVICE;**59**;Aug 31,1995
3 ;same as LRCAPAM7 except archived wkld file
4EN ;
5INITSUM ;
6 N LRIFN,LRREC,LRLARE,LRLDIV,I
7 S LRIFN=0
8 F S LRIFN=$O(^LAB(64.21,LRIFN)) Q:'LRIFN I LRIFN'=8 D
9 .S LRREC=$G(^LAB(64.21,LRIFN,0))
10 .Q:'$L(LRREC)
11 .S LRLDIV=$P(LRREC,U,4)
12 .Q:'$L(LRLDIV)
13 .S LRLARE=$P(LRREC,U)
14 .Q:'$L(LRLARE)
15 .F I=1:1:20 S $P(^TMP($J,"LMIP",$P(LRMT,U,2),LRLDIV,0),U,I)=0
16 .F I=1:1:20 S $P(^TMP($J,"LMIP",$P(LRMT,U,2),LRLDIV,LRLARE),U,I)=0
17 .F I=1:1:20 S $P(^TMP($J,"LMIP",$P(LRMT,U,2),LRLDIV,LRLARE),U,I)=0
18 F I=1:1:20 S $P(^TMP($J,"LMIP",$P(LRMT,U,2),"TOT-AP/CP"),U,I)=0
19 Q
20BMPSUM ;
21 ;LRIPOT(2)=in-patient ; LROPOT(3)=outpatient ; LRNPOT(4)=other patients (REFERRAL)
22 ;LRQC=qc(5) ; LRTOST=total on site ; LRMAN(8)=manual input
23 ;LROTHER(12)=other ; LRSOOT(10)=send out flag ; LROSOT= total performed on-site test
24 ;LRSOT(7)=total stat ; LRSOTI(6)= total inpatient stat
25 ;LRTOT= total ordered test
26 ;LRREP(11)=std/reps LRMII=Micro In-house LRMIO=Micro Sendout
27 ;LRSUBF=suffix
28 N LRREP,LRREC,LRIPOT,LROPOT,LRNPOT,LRQC,LRSOT,LRMAN,LRSOOT,LROSOT,LRTOT,LRTOST
29 N LRREC2,LRREC3,LRSKIP,LRLDIV,LRLARE,LROTHER
30 N LRSOTI,LRMII,LRMIO,LRSUBF
31 S LRSOTI=$P(LRN,U,6),LRSUBF=$P($P(LRN,U),".",2)
32 S LRIPOT=+$P(LRN,U,2),LROPOT=+$P(LRN,U,3),LRNPOT=+$P(LRN,U,4)
33 S LRQC=+$P(LRN,U,5),LRSOT=+$P(LRN,U,7),LRMAN=+$P(LRN,U,8)
34 S LRSOOT=+$P(LRN,U,10),LRREP=$P(LRN,U,11),LROTHER=+$P(LRN,U,12)
35 S LROSOT=$S(LRSOOT:0,1:(LRIPOT+LROPOT+LRNPOT))
36 S LRTOT=LRIPOT+LROPOT+LRNPOT
37 S LRTOST=LRIPOT+LROPOT+LRNPOT+LRMAN+LRQC+LROTHER+LRREP
38 I $E(LRSUBF,3,4)="00" D
39 . I LRSUBF>8000,LRSUBF<9000,LRSUBF'=8500,LRSUBF'=8600 S LRMIO=LRTOT
40 . I LRSUBF>7000,LRSUBF<8000,LRSUBF'=7500,LRSUBF'=7600 S LRMII=LRTOT
41 . S:'$D(LRMIPER) LRMIPER="^"
42 . S $P(LRMIPER,U)=$P(LRMIPER,U)+$G(LRMIO),$P(LRMIPER,U,2)=$P(LRMIPER,U,2)+$G(LRMII)
43 D GETDA Q:LRSKIP
44 ;bump div/area counts
45 S LRREC=$G(^TMP($J,"LMIP",$P(LRMT,U,2),LRLDIV,LRLARE))
46 S $P(LRREC,U)=$P(LRREC,U)+LRIPOT ;LMIP field #5
47 S $P(LRREC,U,2)=$P(LRREC,U,2)+LROPOT ;LMIP field #6
48 S $P(LRREC,U,3)=$P(LRREC,U,3)+LRNPOT ;LMIP field #7
49 S $P(LRREC,U,4)=$P(LRREC,U,4)+LRTOT ;LMIP field #1
50 S $P(LRREC,U,5)=$P(LRREC,U,5)+LRQC ;no LIMP field #
51 S $P(LRREC,U,6)=$P(LRREC,U,6)+LRTOST ;LMIP field #2
52 S $P(LRREC,U,7)=$P(LRREC,U,7)+LRSOOT ;LMIP field #4
53 S $P(LRREC,U,8)=$P(LRREC,U,8)+LROSOT ;LMIP field #3
54 S $P(LRREC,U,9)=$P(LRREC,U,9)+LRSOT ;LMIP field #8
55 S $P(LRREC,U,12)=$P(LRREC,U,12)+LRREP ;Repeats
56 S $P(LRREC,U,13)=$P(LRREC,U,13)+LRMAN ;Manual Inputs
57 S $P(LRREC,U,14)=$P(LRREC,U,14)+$G(LRMII) ;Micro Inp
58 S $P(LRREC,U,15)=$P(LRREC,U,15)+$G(LRMIO) ;Micro Out
59 S $P(LRREC,U,16)=$P(LRREC,U,16)+LRSOTI ; In Pat stats
60 S $P(LRREC,U,17)=$P(LRREC,U,17)+LROTHER ; Others
61 S ^TMP($J,"LMIP",$P(LRMT,U,2),LRLDIV,LRLARE)=LRREC
62 ;Also bump subtotal counts
63 S LRREC2=$G(^TMP($J,"LMIP",$P(LRMT,U,2),LRLDIV,0))
64 S $P(LRREC2,U)=$P(LRREC2,U)+LRIPOT
65 S $P(LRREC2,U,2)=$P(LRREC2,U,2)+LROPOT
66 S $P(LRREC2,U,3)=$P(LRREC2,U,3)+LRNPOT
67 S $P(LRREC2,U,4)=$P(LRREC2,U,4)+LRTOT
68 S $P(LRREC2,U,5)=$P(LRREC2,U,5)+LRQC
69 S $P(LRREC2,U,6)=$P(LRREC2,U,6)+LRTOST
70 S $P(LRREC2,U,7)=$P(LRREC2,U,7)+LRSOOT
71 S $P(LRREC2,U,8)=$P(LRREC2,U,8)+LROSOT
72 S $P(LRREC2,U,9)=$P(LRREC2,U,9)+LRSOT
73 S $P(LRREC2,U,12)=$P(LRREC2,U,12)+LRREP ;Repeats
74 S $P(LRREC2,U,13)=$P(LRREC2,U,13)+LRMAN ;Manual Inputs
75 S $P(LRREC2,U,14)=$P(LRREC2,U,14)+$G(LRMII) ;Micro Inp
76 S $P(LRREC2,U,15)=$P(LRREC2,U,15)+$G(LRMIO) ;Micro Out
77 S $P(LRREC2,U,16)=$P(LRREC2,U,16)+LRSOTI ; In Pat stats
78 S $P(LRREC2,U,17)=$P(LRREC2,U,17)+LROTHER ; Others
79 S ^TMP($J,"LMIP",$P(LRMT,U,2),LRLDIV,0)=LRREC2
80 ;Also bump grand total counts
81 S LRREC3=$G(^TMP($J,"LMIP",$P(LRMT,U,2),"TOT-AP/CP"))
82 S $P(LRREC3,U)=$P(LRREC3,U)+LRIPOT
83 S $P(LRREC3,U,2)=$P(LRREC3,U,2)+LROPOT
84 S $P(LRREC3,U,3)=$P(LRREC3,U,3)+LRNPOT
85 S $P(LRREC3,U,4)=$P(LRREC3,U,4)+LRTOT
86 S $P(LRREC3,U,5)=$P(LRREC3,U,5)+LRQC
87 S $P(LRREC3,U,6)=$P(LRREC3,U,6)+LRTOST
88 S $P(LRREC3,U,7)=$P(LRREC3,U,7)+LRSOOT
89 S $P(LRREC3,U,8)=$P(LRREC3,U,8)+LROSOT
90 S $P(LRREC3,U,9)=$P(LRREC3,U,9)+LRSOT
91 S $P(LRREC3,U,12)=$P(LRREC3,U,12)+LRREP ;Repeats
92 S $P(LRREC3,U,13)=$P(LRREC3,U,13)+LRMAN ;Manual Inputs
93 S $P(LRREC3,U,14)=$P(LRREC3,U,14)+$G(LRMII) ;Micro Inp
94 S $P(LRREC3,U,15)=$P(LRREC3,U,15)+$G(LRMIO) ;Micro Out
95 S $P(LRREC3,U,16)=$P(LRREC3,U,16)+LRSOTI ; In Pat stats
96 S $P(LRREC3,U,17)=$P(LRREC3,U,17)+LROTHER ; Others
97 S ^TMP($J,"LMIP",$P(LRMT,U,2),"TOT-AP/CP")=LRREC3
98 Q
99GETDA ;Get lab division and area
100 N LRPTR,LRREC3
101 S LRSKIP=1
102 Q:'$G(LRCAPIFN) Q:'$P($G(^LAM(LRCAPIFN,0)),U,5)
103 S LRPTR=+$P($G(^LAM(LRCAPIFN,0)),U,15)
104 S:'LRPTR LRPTR=1
105 S LRREC3=$G(^LAB(64.21,LRPTR,0))
106 Q:'$L(LRREC3)
107 S LRLDIV=$P(LRREC3,U,4)
108 Q:'$L(LRLDIV)
109 S LRLARE=$P(LRREC3,U)
110 Q:'$L(LRLARE)
111 S LRSKIP=0
112 Q
Note: See TracBrowser for help on using the repository browser.