source: WorldVistAEHR/trunk/r/QUASAR-ACKQ/ACKQDWL1.m@ 703

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

initial load of WorldVistAEHR
File size: 8.2 KB
Line 
1ACKQDWL1 ;AUG/JLTP HCIOFO/BH-Compile A&SP Capitation Data - CONTINUED ; [ 12/05/95 12:03 PM ]
2 ;;3.0;QUASAR;**1**;Feb 11, 2000
3 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
4 ;
5 N CPT,DFN,DIE,DR,I,ICD,VAPA,VAERR,CPTIEN,ICDIEN
6 K ^TMP("ACKQWL",$J) D FYSTATS,MONTH,STUFF
7 Q
8 ;
9FYSTATS ;
10 ; Create array of Selected Divisions
11 N ACKQQK6,ACK1,ACKQQEC,EC
12 S ACK1=""
13 F S ACK1=$O(ACKDIV(ACK1)) Q:ACK1="" D
14 . S ACKDIVS($P(ACKDIV(ACK1),U,1))=""
15 ;
16 ; Gather uniques from begin of FY to now to screen against.
17 F ACKD=ACKBFY:0 S ACKD=$O(^ACK(509850.6,"B",ACKD)) Q:'ACKD!(ACKD>ACKM) D
18 .S ACKV=0 F S ACKV=$O(^ACK(509850.6,"B",ACKD,ACKV)) Q:'ACKV D
19 ..S ACKV(0)=$G(^ACK(509850.6,ACKV,0)) Q:ACKV(0)=""
20 ..S DFN=$P(ACKV(0),U,2) Q:'DFN
21 ..S ACKSTOP=$$GET1^DIQ(509850.6,ACKV_",",4,"I") Q:ACKSTOP=""
22 ..S ACKREDIT=$S(ACKSTOP="A"!(ACKSTOP="AT"):"A",ACKSTOP="S"!(ACKSTOP="ST"):"S")
23 ..S ACKVDVN=$$GET1^DIQ(509850.6,ACKV_",",60,"I") I ACKVDVN="" Q
24 ..Q:'$D(ACKDIVS(ACKVDVN))
25 ..;
26 ..S ACKZIP=$$ZIP(DFN)
27 ..; Unique Visit this FY PRE this month
28 ..S ^TMP("ACKQWL",$J,"PRE",ACKVDVN,3,ACKREDIT,ACKZIP,DFN)=""
29 ..S ICD="" F S ICD=$O(^ACK(509850.6,ACKV,1,"B",ICD)) Q:ICD="" D
30 ...; Unique PTS W/ICD FY PRE this Month
31 ...S ^TMP("ACKQWL",$J,"PRE",ACKVDVN,1,ACKREDIT,ACKZIP,ICD,DFN)=""
32 ..S CPT="" F S CPT=$O(^ACK(509850.6,ACKV,3,"B",CPT)) Q:CPT="" D
33 ...; Unique PTS W/CPT FY PRE this Month
34 ...S ACKQQK6="" S ACKQQK6=$O(^ACK(509850.6,ACKV,3,"B",CPT,ACKQQK6))
35 ...I ACKQQK6="" Q
36 ...S ACKQQEC=$$GET1^DIQ(509850.61,ACKQQK6_","_ACKV_",",.07)
37 ...I ACKQQEC'="" Q ; Entry created by EC code
38 ...S ^TMP("ACKQWL",$J,"PRE",ACKVDVN,2,ACKREDIT,ACKZIP,CPT,DFN)=""
39 ..S EC="" F S EC=$O(^ACK(509850.6,ACKV,7,"B",EC)) Q:EC="" D
40 ...; Unique PTS W/EC FY PRE this Month
41 ...S ^TMP("ACKQWL",$J,"PRE",ACKVDVN,5,ACKREDIT,ACKZIP,EC,DFN)=""
42 Q
43 ;
44ZIP(DFN) ; Pass back ZIP code for patient
45 D ADD^VADPT S ACKZIP=$S(VAPA(6):VAPA(6),1:0)
46 K VAPA
47 Q ACKZIP
48 ;
49MONTH ; Gather stats from selected month.
50 F ACKD=ACKM:0 S ACKD=$O(^ACK(509850.6,"B",ACKD)) Q:'ACKD!(ACKD>ACKEM) D
51 .S ACKV=0 F S ACKV=$O(^ACK(509850.6,"B",ACKD,ACKV)) Q:'ACKV D
52 ..S ACKV(0)=$G(^ACK(509850.6,ACKV,0)) Q:ACKV(0)=""
53 ..S DFN=$P(ACKV(0),U,2) Q:'DFN
54 ..S ACKVDVN=$$GET1^DIQ(509850.6,ACKV_",",60,"I") Q:'$D(ACKDIVS(ACKVDVN))
55 ..S ACKSTOP=$$GET1^DIQ(509850.6,ACKV_",",4,"I") Q:ACKSTOP=""
56 ..S ACKREDIT=$S(ACKSTOP="A"!(ACKSTOP="AT"):"A",ACKSTOP="S"!(ACKSTOP="ST"):"S")
57 ..S ACKTELE=0 I ACKSTOP="AT"!(ACKSTOP="ST") S ACKTELE=1
58 ..S ACKZIP=$$ZIP(DFN)
59 ..;
60 ..; Add to the clinic counts within stop code if not telephone
61 ..I 'ACKTELE S $P(^TMP("ACKQWL",$J,ACKVDVN,3,ACKREDIT,ACKZIP),U,1)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,3,ACKREDIT,ACKZIP)),U,1)+1
62 ..; ....and if telephone
63 ..I ACKTELE S $P(^TMP("ACKQWL",$J,ACKVDVN,3,ACKREDIT,ACKZIP),U,2)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,3,ACKREDIT,ACKZIP)),U,2)+1
64 ..; If C&P add one to the count within Audiology or Speech
65 ..I $P(ACKV(0),U,5) D
66 ...S $P(^TMP("ACKQWL",$J,ACKVDVN,3,ACKREDIT,ACKZIP),U,4)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,3,ACKREDIT,ACKZIP)),U,4)+1
67 ...;
68 ..;
69 ..; Add Unique entry if not on the previous Fiscal Year list
70 ..I '$D(^TMP("ACKQWL",$J,"PRE",ACKVDVN,3,ACKREDIT,ACKZIP,DFN)),'$D(^TMP("ACKQWL",$J,"U",ACKVDVN,3,ACKREDIT,ACKZIP,DFN)) D
71 ...S $P(^TMP("ACKQWL",$J,ACKVDVN,3,ACKREDIT,ACKZIP),U,3)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,3,ACKREDIT,ACKZIP)),U,3)+1,^TMP("ACKQWL",$J,"U",ACKVDVN,3,ACKREDIT,ACKZIP,DFN)=""
72 ..;
73 ..;
74 ..;
75 ..S ICD="" F S ICD=$O(^ACK(509850.6,ACKV,1,"B",ICD)) Q:ICD="" D
76 ...S ICDIEN=""
77 ...F S ICDIEN=$O(^ACK(509850.6,ACKV,1,"B",ICD,ICDIEN)) Q:ICDIEN="" D
78 ....I 'ACKTELE S $P(^TMP("ACKQWL",$J,ACKVDVN,1,ACKREDIT,ICD),U,1)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,1,ACKREDIT,ICD)),U,1)+1
79 ....;
80 ....I ACKTELE S $P(^TMP("ACKQWL",$J,ACKVDVN,1,ACKREDIT,ICD),U,2)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,1,ACKREDIT,ICD)),U,2)+1
81 ....;
82 ...I '$D(^TMP("ACKQWL",$J,"PRE",ACKVDVN,1,ACKREDIT,ACKZIP,ICD,DFN)),'$D(^TMP("ACKQWL",$J,"U",ACKVDVN,1,ACKREDIT,ACKZIP,ICD,DFN)) D
83 ....S $P(^TMP("ACKQWL",$J,ACKVDVN,1,ACKREDIT,ICD),U,3)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,1,ACKREDIT,ICD)),U,3)+1,^TMP("ACKQWL",$J,"U",ACKVDVN,1,ACKREDIT,ACKZIP,ICD,DFN)=""
84 ..;
85 ..S CPT="" N ACKQQUIT
86 ..F S CPT=$O(^ACK(509850.6,ACKV,3,"B",CPT)) Q:CPT="" D
87 ...S CPTIEN="",ACKQQUIT=""
88 ...F S CPTIEN=$O(^ACK(509850.6,ACKV,3,"B",CPT,CPTIEN)) Q:CPTIEN="" D
89 ....S ACKQQUIT=$$GET1^DIQ(509850.61,CPTIEN_","_ACKV_",",.07)
90 ....I ACKQQUIT'="" Q ; Entry created by EC code
91 ....I 'ACKTELE S $P(^TMP("ACKQWL",$J,ACKVDVN,2,ACKREDIT,CPT),U,1)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,2,ACKREDIT,CPT)),U,1)+$$GET1^DIQ(509850.61,CPTIEN_","_ACKV_",",.03,"I")
92 ....;
93 ....I ACKTELE S $P(^TMP("ACKQWL",$J,ACKVDVN,2,ACKREDIT,CPT),U,2)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,2,ACKREDIT,CPT)),U,2)+$$GET1^DIQ(509850.61,CPTIEN_","_ACKV_",",.03,"I")
94 ....;
95 ...I ACKQQUIT="",'$D(^TMP("ACKQWL",$J,"PRE",ACKVDVN,2,ACKREDIT,ACKZIP,CPT,DFN)),'$D(^TMP("ACKQWL",$J,"U",ACKVDVN,2,ACKREDIT,ACKZIP,CPT,DFN)) D
96 ....S $P(^TMP("ACKQWL",$J,ACKVDVN,2,ACKREDIT,CPT),U,3)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,2,ACKREDIT,CPT)),U,3)+1,^TMP("ACKQWL",$J,"U",ACKVDVN,2,ACKREDIT,ACKZIP,CPT,DFN)=""
97 ...S ACKQQUIT=""
98 ..;
99 ..;
100 ..S EC=""
101 ..F S EC=$O(^ACK(509850.6,ACKV,7,"B",EC)) Q:EC="" D
102 ...S ECIEN=""
103 ...F S ECIEN=$O(^ACK(509850.6,ACKV,7,"B",EC,ECIEN)) Q:ECIEN="" D
104 ....I 'ACKTELE S $P(^TMP("ACKQWL",$J,ACKVDVN,5,ACKREDIT,EC),U,1)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,5,ACKREDIT,EC)),U,1)+$$GET1^DIQ(509850.615,ECIEN_","_ACKV_",",.03,"I")
105 ....;
106 ....I ACKTELE S $P(^TMP("ACKQWL",$J,ACKVDVN,5,ACKREDIT,EC),U,2)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,5,ACKREDIT,EC)),U,2)+$$GET1^DIQ(509850.615,ECIEN_","_ACKV_",",.03,"I")
107 ....;
108 ...I '$D(^TMP("ACKQWL",$J,"PRE",ACKVDVN,5,ACKREDIT,ACKZIP,EC,DFN)),'$D(^TMP("ACKQWL",$J,"U",ACKVDVN,5,ACKREDIT,ACKZIP,EC,DFN)) D
109 ....S $P(^TMP("ACKQWL",$J,ACKVDVN,5,ACKREDIT,EC),U,3)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,5,ACKREDIT,EC)),U,3)+1,^TMP("ACKQWL",$J,"U",ACKVDVN,5,ACKREDIT,ACKZIP,EC,DFN)=""
110 Q
111 ;
112STUFF ;
113 ;
114 K ^TMP("ACKQWL",$J,"U")
115 K ^TMP("ACKQWL",$J,"PRE")
116 N ACKD,ACKTYPE,ACKCLIN,ACKCODE,ACKSTR
117 ;
118 S (ACKD,ACKTYPE,ACKCLIN,ACKCODE)=""
119 ;
120 F S ACKD=$O(^TMP("ACKQWL",$J,ACKD)) Q:ACKD="" D
121 .F S ACKTYPE=$O(^TMP("ACKQWL",$J,ACKD,ACKTYPE)) Q:ACKTYPE="" D
122 ..F S ACKCLIN=$O(^TMP("ACKQWL",$J,ACKD,ACKTYPE,ACKCLIN)) Q:ACKCLIN="" D
123 ...F S ACKCODE=$O(^TMP("ACKQWL",$J,ACKD,ACKTYPE,ACKCLIN,ACKCODE)) Q:ACKCODE="" D
124 ....;
125 ....S ACKSTR=^TMP("ACKQWL",$J,ACKD,ACKTYPE,ACKCLIN,ACKCODE)
126 ....S ACKC=ACKCODE
127 ....;
128 ....; Create new Workload file level to write data to.
129 .... S DIC="^ACK(509850.7,"_ACKDA_",5,"_ACKD_","_ACKTYPE_","
130 .... S DIC(0)="L",DIC("P")="509850.75"_ACKTYPE_"A"
131 .... S DA=ACKC,DA(2)=ACKDA,DA(1)=ACKD,X=ACKC ; DINUM=ACKC
132 .... K DD,DO D FILE^DICN
133 .... S ACKC=+$P(Y,U,1)
134 ....;
135 ....I ACKTYPE=1!(ACKTYPE=2)!(ACKTYPE=5) D Q
136 .....; File away results for ICD9 (ACKTYPE=1), CPT (ACKTYPE=2)
137 .....; and EC (ACKTYPE=5)
138 .....I ACKCLIN="A" D Q
139 ......N ACKA
140 ......S ACKA(509850.75_ACKTYPE,ACKC_","_ACKD_","_ACKDA_",",10)=$P(ACKSTR,U,1)
141 ......S ACKA(509850.75_ACKTYPE,ACKC_","_ACKD_","_ACKDA_",",20)=$P(ACKSTR,U,2)
142 ......S ACKA(509850.75_ACKTYPE,ACKC_","_ACKD_","_ACKDA_",",30)=$P(ACKSTR,U,3)
143 ......D FILE^DIE("","ACKA")
144 .....I ACKCLIN="S" D Q
145 ......N ACKA
146 ......S ACKA(509850.75_ACKTYPE,ACKC_","_ACKD_","_ACKDA_",",40)=$P(ACKSTR,U,1)
147 ......S ACKA(509850.75_ACKTYPE,ACKC_","_ACKD_","_ACKDA_",",50)=$P(ACKSTR,U,2)
148 ......S ACKA(509850.75_ACKTYPE,ACKC_","_ACKD_","_ACKDA_",",60)=$P(ACKSTR,U,3)
149 ......D FILE^DIE("","ACKA")
150 .....Q
151 .....;
152 ....I ACKTYPE=3 D Q
153 .....; File away results for ZIP Codes (ACKTYPE=3)
154 .....I ACKCLIN="A" D Q
155 ......N ACKA
156 ......S ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",10)=$P(ACKSTR,U,1)
157 ......S ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",20)=$P(ACKSTR,U,2)
158 ......S ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",30)=$P(ACKSTR,U,3)
159 ......S ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",40)=$P(ACKSTR,U,4)
160 ......D FILE^DIE("","ACKA")
161 .....I ACKCLIN="S" D Q
162 ......N ACKA
163 ......S ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",50)=$P(ACKSTR,U,1)
164 ......S ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",60)=$P(ACKSTR,U,2)
165 ......S ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",70)=$P(ACKSTR,U,3)
166 ......S ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",80)=$P(ACKSTR,U,4)
167 ......D FILE^DIE("","ACKA")
168 Q
169 ;
Note: See TracBrowser for help on using the repository browser.