source: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX1.m@ 1796

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

initial load of FOIAVistA 6/30/08 version

File size: 7.3 KB
Line 
1XUSNPIX1 ;OAK_BP/CMW - NPI EXTRACT REPORT ;01-OCT-06
2 ;;8.0;KERNEL;**438,452,453**; Jul 10, 1995;Build 36
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; NPI Extract Report
6 ;
7 ; Input parameter: N/A
8 ;
9 ; Other relevant variables:
10 ; XUSRTN="XUSNPIX1" (current routine name, used for ^XTMP and ^TMP
11 ; storage subscript)
12 ; Storage Global:
13 ; ^XTMP("XUSNPIX1",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6
14 ; where:
15 ; Piece 1 => Purge Date - 1 year in future
16 ; Piece 2 => Create Date - Today
17 ; Piece 3 => Description
18 ; Piece 4 => Last Date Compiled
19 ; Piece 5 => $H last run start time
20 ; Piece 6 => $H last run completion time
21 ;
22 ; ^XTMP("XUSNPIX1",1) = DATA
23 ;
24 ; XUSNPI => Unique NPI of entry
25 ; LDT => Last Date Run, VA Fileman Format
26 ;
27 ; Entry Point - TASKMAN => Run report in background using TASKMAN
28 ;
29 Q
30 ;
31TASKMAN ;TASKMAN ENTRY POINT
32 ; Process Report
33 N XUSRTN,DTTM
34 ; Check for required variables
35 I $G(U)=""!($G(DT)="") G EXIT
36 S XUSRTN="XUSNPIX1"
37 S DTTM=$$HTE^XLFDT($H,"2")
38 ; Check to see if report is in use
39 L +^XTMP(XUSRTN):5 I '$T G EXIT
40 ;
41 D INIT(XUSRTN)
42 ; Pull Station(Institution) data
43 D INST(XUSRTN)
44 ;
45 D PROC1(XUSRTN)
46 ; Send the message
47 D EMAIL^XUSNPIX5(XUSRTN)
48 D VMAIL^XUSNPIX5(XUSRTN)
49 ;
50 ; Process Institution File
51 D ENT^XUSNPIX2
52 ;
53 ; Process Non VA File
54 D ENT^XUSNPIX3
55 ;
56 ; Send summary message
57 D SMAIL^XUSNPIX5("XUSNPIXT")
58 ;
59 ;Standard EXIT point
60EXIT ;
61 K XUSEOL,DTTM,MAXSIZE,XUSVER,XUSHDR,XUSPROD
62 K MSGCNT,TOTREC,COUNT
63 K ^TMP("XUSNPIXU",$J)
64 ; Log Run Completion Time
65 S $P(^XTMP(XUSRTN,0),U,6)=$H
66 L -^XTMP(XUSRTN)
67 ;
68 Q
69 ;
70INIT(XUSRTN) ; check/init variables
71 N XUSDESC
72 ; Set to NEXT release version from NPM
73 S XUSVER="453.16"
74 ; Get production/test account flag
75 S XUSPROD=$S($$PROD^XUPROD(1):"PROD",1:"TEST")
76 ; Set end of line character
77 S XUSEOL="~~"
78 ; Set to 300000 for live
79 S MAXSIZE=300000
80 ; Reset Temporary Scratch Global
81 D INIT^XUSNPIXU
82 K ^TMP(XUSRTN)
83 S XUSDESC="NPI EXTRACT TYPE 1 - Do Not Delete"
84 S ^XTMP(XUSRTN,0)=(DT+10000)_U_DT_U_XUSDESC_U_DT_U_$H
85 ; Generate TMP BCBS Array
86 D BCBSID^XUSNPIXU
87 ;
88 Q
89 ;
90INST(XUSRTN) ;Pull station and Institution info
91 N INST,SINFO,DIC4
92 ; Pull site info
93 S SINFO=$$SITE^VASITE
94 ; Station Number
95 S SITE=$P(SINFO,U,3)
96 ; Institution
97 S INST=$P(SINFO,U)
98 ;
99 ; Get institution mailing address
100 I INST D
101 . S DIC4=$G(^DIC(4,INST,4))
102 . S XUSNP(7)=$P(DIC4,U)
103 . S XUSNP(8)=$P(DIC4,U,2)
104 . S XUSNP(9)=$P(DIC4,U,3)
105 . S XUSNP(10)=$P(DIC4,U,4)
106 . I XUSNP(10) S XUSNP(10)=$P($G(^DIC(5,XUSNP(10),0)),U,2)
107 . S XUSNP(11)=$P(DIC4,U,5)
108 . S INSMAIL=XUSNP(7)_U_XUSNP(8)_U_XUSNP(9)_U_XUSNP(10)_U_XUSNP(11)
109 S XUSHDR="Station: "_SITE_U_XUSNP(9)_U_XUSNP(10)_U_XUSNP(11)_U_"TYPE 1"_U_XUSVER
110 ;
111 Q
112 ;
113PROC1(XUSRTN) ;Process all New Person records
114 N XUSNPI,XUSDT,XUSNEW,XUSI,XUSDATA,XUSVA0,XUSVA0,XUSVA1,XUSNAME,XUSDOB,XUSDIV,XUSSTL,XUSSTLN,XUSOPN
115 N XUSPER,XUSSPC,XUSTAX,XUSTAXID,XUSIZE,NPIEN,DIC4,SPDIV,VA12,VA13
116 ; set counter
117 S COUNT=1,(TOTREC,MSGCNT,XUSIZE)=0
118 ; Loop through NEW PERSON NPI records NPI cross ref
119 S XUSNPI=0
120 F S XUSNPI=$O(^VA(200,"ANPI",XUSNPI)) Q:'XUSNPI D
121 . S NPIEN=$O(^VA(200,"ANPI",XUSNPI,""))
122 . ;
123 . ; Init columns
124 . F XUSI=1:1:29 S XUSNP(XUSI)=""
125 . S XUSNP(1)=XUSNPI S XUSDATA1=XUSNP(1)
126 . ;
127 . S XUSVA0=$G(^VA(200,NPIEN,0))
128 . S XUSVA1=$G(^VA(200,NPIEN,1))
129 . S XUSNAME=$P(XUSVA0,U)
130 . ; BREAK NAME INTO COMPONENTS
131 . I XUSNAME'="" D
132 . . S XLFNC=XUSNAME D FORMAT^XLFNAME7(.XLFNC,,,,0)
133 . . S XUSNP(2)=XLFNC("GIVEN"),XUSNP(3)=XLFNC("MIDDLE"),XUSNP(4)=XLFNC("FAMILY")
134 . . I XLFNC("SUFFIX")'="" S XUSNP(4)=XUSNP(4)_" "_XLFNC("SUFFIX")
135 . . K XLFNC
136 . S XUSDATA1=XUSDATA1_U_XUSNP(2)_U_XUSNP(3)_U_XUSNP(4)
137 . S XUSNP(5)=1 ;TYPE
138 . S XUSDOB=$P(XUSVA1,U,3)
139 . ; dob formatted as mm/dd/yyyy
140 . I XUSDOB D
141 . . S XUSNP(6)=$$FMTE^XLFDT(XUSDOB,5)
142 . S XUSDATA1=XUSDATA1_U_XUSNP(5)_U_XUSNP(6)
143 . ;
144 . ; Pay to Provider Address Use primary institution mailing address NP7-11
145 . S XUSDATA1=XUSDATA1_U_INSMAIL
146 . ;
147 . ; Servicing Provider Address
148 . S (XUSDIV)=0
149 . ; Loop through Division multiple
150 . F S XUSDIV=$O(^VA(200,NPIEN,2,XUSDIV)) Q:'XUSDIV D
151 . . S DIC4=$G(^DIC(4,XUSDIV,4))
152 . . S XUSNP(12)=$P(DIC4,U)
153 . . S XUSNP(13)=$P(DIC4,U,2)
154 . . S XUSNP(14)=$P(DIC4,U,3)
155 . . S XUSNP(15)=$P(DIC4,U,4)
156 . . I XUSNP(15) S XUSNP(15)=$P($G(^DIC(5,XUSNP(15),0)),U,2)
157 . . S XUSNP(16)=$P(DIC4,U,5)
158 . . S XUSSTA(XUSDIV)=$P($G(^DIC(4,XUSDIV,99)),U)
159 . . S SPADR(XUSDIV)=XUSNP(12)_U_XUSNP(13)_U_XUSNP(14)_U_XUSNP(15)_U_XUSNP(16)
160 . ; If no divisions found
161 . I '$D(SPADR) D
162 . . S XUSSTA(9999)="N/A",SPADR(9999)=XUSNP(12)_U_XUSNP(13)_U_XUSNP(14)_U_XUSNP(15)_U_XUSNP(16)
163 . ;
164 . ; Office Phone number
165 . S XUSOPN=$P($G(^VA(200,NPIEN,.13)),U,2)
166 . I XUSOPN'="" S XUSNP(17)=XUSOPN
167 . ;
168 . ; Degree
169 . S XUSNP(18)=$P($G(^VA(200,NPIEN,3.1)),U,6)
170 . ; Degree Code (place holder)
171 . S XUSNP(19)=""
172 . ;
173 . ; get taxonomy and specialty
174 . S XUSPER=0
175 . F S XUSPER=$O(^VA(200,NPIEN,"USC1","B",XUSPER)) Q:'XUSPER D
176 . . S XUSSPC=$P($G(^USC(8932.1,XUSPER,0)),U,9)
177 . . S XUSTAX=$P($G(^USC(8932.1,XUSPER,0)),U,7)
178 . . I XUSSPC'="" D
179 . . . I XUSNP(20)="" S XUSNP(20)=XUSSPC Q
180 . . . S XUSNP(20)=XUSNP(20)_";"_XUSSPC
181 . . I XUSTAX'="" D
182 . . . I XUSNP(21)="" S XUSNP(21)=XUSTAX Q
183 . . . S XUSNP(21)=XUSNP(21)_";"_XUSTAX
184 . ;
185 . ; Tax ID
186 . S XUSTAXID=$P($G(^VA(200,NPIEN,"TPB")),U,2)
187 . I XUSTAXID="" S XUSTAXID=$P($G(^VA(200,NPIEN,1)),U,9)
188 . S XUSNP(22)=XUSTAXID
189 . ;
190 . S XUSDATA2=XUSNP(17)_U_XUSNP(18)_U_XUSNP(19)_U_XUSNP(20)_U_XUSNP(21)_U_XUSNP(22)
191 . ;
192 . ; Medicare Part A/B
193 . S XUSNP(23)=670899
194 . S XUSNP(24)="VA"_$E(SITE+10000,2,5)
195 . ;
196 . ; State License
197 . S XUSSTL=0
198 . F S XUSSTL=$O(^VA(200,NPIEN,"PS1",XUSSTL)) Q:'XUSSTL D
199 . . S XUSSTLN=$P($G(^VA(200,NPIEN,"PS1",XUSSTL,0)),U,2)
200 . . I XUSSTLN'="" D
201 . . . I XUSNP(25)="" S XUSNP(25)=XUSSTLN Q
202 . . . S XUSNP(25)=XUSNP(25)_";"_XUSSTLN
203 . ; DEA #
204 . S XUSNP(26)=$P($G(^VA(200,NPIEN,"PS")),U,2)
205 . ;
206 . S XUSDATA2=XUSDATA2_U_XUSNP(23)_U_XUSNP(24)_U_XUSNP(25)_U_XUSNP(26)
207 . ;
208 . ; Station #
209 . S XUSNP(27)=""
210 . ;
211 . ; Get BCBS Payer ID Array
212 . K XUSBXID
213 . D PRACID^XUSNPIXU(NPIEN,.XUSBXID)
214 . ;
215 . ; Save entry to ^TMP and update count
216 . N XUSB
217 . S XUSDIV=0
218 . F S XUSDIV=$O(SPADR(XUSDIV)) Q:'XUSDIV D
219 . . S COUNT=COUNT+1,TOTREC=TOTREC+1
220 . . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_SPADR(XUSDIV)_U_XUSDATA2_U_XUSSTA(XUSDIV)_U_XUSEOL
221 . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT))
222 . . ; Check BCBS Id array
223 . . I $D(XUSBXID) D
224 . . . S XUSB=""
225 . . . F S XUSB=$O(XUSBXID(XUSB)) Q:XUSB="" D
226 . . . . S COUNT=COUNT+1,TOTREC=TOTREC+1
227 . . . . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_SPADR(XUSDIV)_U_XUSDATA2_U_XUSSTA(XUSDIV)_U_XUSB_U_XUSEOL
228 . . . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT))
229 . K XUSNP,XUSDATA1,XUSDATA2,XUSDATA3,SPADR,XUSBXID,CNT,XUSSTA
230 . I XUSIZE>MAXSIZE D
231 . . D EOF(XUSRTN)
232 . . D EMAIL^XUSNPIX5(XUSRTN)
233 . . D VMAIL^XUSNPIX5(XUSRTN)
234 . . S ^TMP(XUSRTN,$J,1)=XUSHDR
235 . . S COUNT=1,XUSIZE=0
236 D EOF(XUSRTN)
237 ; set summary totals
238 S ^XTMP("XUSNPIXT",0)=(DT+10000)_U_DT_U_"NPI EXTRACT SUMMARY TOTALS"_U_DT_U_$H
239 S ^XTMP("XUSNPIXT","H")=$P(XUSHDR,U,1,4)
240 S ^XTMP("XUSNPIXT",1)=MSGCNT_U_TOTREC_U_DTTM
241 K INSMAIL,SITE
242 Q
243 ;
244EOF(XUSRTN) ;
245 S MSGCNT=MSGCNT+1
246 S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_COUNT_U_DTTM_U_$G(XUSPROD)_U_XUSEOL
247 S COUNT=COUNT+1
248 S ^TMP(XUSRTN,$J,COUNT)="END OF FILE"_U_XUSEOL
249 Q
Note: See TracBrowser for help on using the repository browser.