source: FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUDEM4.m@ 949

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

initial load of FOIAVistA 6/30/08 version
File size: 6.9 KB
Line 
1PSUDEM4 ;BIR/DAM - Provider Extract ; 4/26/07 4:38pm
2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**8,12**;MARCH, 2005;Build 19
3 ;
4 ;DBIA'S
5 ; Reference to file 200 supported by DBIA 10060
6 ; Reference to file 7 supported by DBIA 2495
7 ; Reference to file 49 supported by DBIA 432
8 ; Reference to file 8932.1 supported by DBIA 2091
9 ; Reference to file 4.2 supported by DBIA 2496
10 ;
11EN ;Entry point for gathering all provider information from IV, UD, Rx,
12 ;and PD modules.
13 ;
14 N PSUREC
15 S ^XTMP("PSU_"_PSUJOB,"PSUFLAG")=""
16 ;
17 D PULL^PSUCP
18 F I=1:1:$L(PSUOPTS,",") S PSUMOD($P(PSUOPTS,",",I))=""
19 ;
20 I '$D(PSUMOD(7)) D EN^PSUDEM1
21 I '$D(PSUMOD(1)) D EN^PSUV0
22 I '$D(PSUMOD(2)) D EN^PSUUD0
23 I '$D(PSUMOD(4)) D
24 .S ^XTMP("PSU_"_PSUJOB,"PSUOPFLG")="" ;Set flag
25 .D EN^PSUOP0
26 M ^XTMP("PSU_"_PSUJOB,"PSUPROM")=^XTMP("PSU_"_PSUJOB,"PSUPROV")
27 ;
28 D XMD
29 D EN^PSUSUM1 ;compose provider summary report and mail it.
30 K ^XTMP("PSU_"_PSUJOB,"PSUFLAG")
31 Q
32 ;
33PDSSN ;EN Called from PSUDEM1
34 ;Find provider SSN and IEN present in the patient demographics
35 ;extract. Note that this is the primary care provider.
36 ;
37 S PSUT=0
38 F S PSUT=$O(^XTMP("PSU_"_PSUJOB,"PSUDM",PSUT)) Q:'PSUT D
39 .N PSUIEN,PSUSSN1
40 .S PSUIEN=$P($G(^XTMP("PSU_"_PSUJOB,"PSUDM",PSUT)),U,15) I 'PSUIEN S PSUIEN="UNK"
41 .D FAC
42 .D PNAM
43 .S PSUSSN1=$P($G(^XTMP("PSU_"_PSUJOB,"PSUDM",PSUT)),U,14) I 'PSUSSN1 S PSUSSN1=""
44 .S PSUREC=PSUSSN1 D REC^PSUDEM2
45 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,3)=PSUREC ;Dem Prov SSN
46 .S PSUREC=PSUIEN D REC^PSUDEM2
47 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,4)=PSUREC D ;Dem Prov ICN
48 ..I PSUREC="UNK" K ^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN)
49 Q
50 ;
51UDSSN ;EN Called from PROV^PSUUD1. Find provider SSN and IEN in the unit
52 ;dose extract
53 ;
54 S PSUIEN=0,PSUVSSN1=0
55 F S PSUVSSN1=$O(^XTMP("PSU_"_PSUJOB,"PSUPDR",PSUVSSN1)) Q:PSUVSSN1="" D
56 .F S PSUIEN=$O(^XTMP("PSU_"_PSUJOB,"PSUPDR",PSUVSSN1,PSUIEN)) Q:PSUIEN="" D
57 ..D FAC
58 ..S PSUREC=PSUVSSN1 D REC^PSUDEM1 D
59 ...I PSUREC=999999999 S PSUREC=""
60 ...S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,3)=PSUREC ;UD Prov SSN
61 ..S PSUREC=PSUIEN D REC^PSUDEM2
62 ..S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,4)=PSUREC ;UD Prov IEN
63 ..D PNAM
64 Q
65 ;
66IVSSN ;EN Called from PSUIV1. Gives Provider within date range of extract
67 ;
68 D UDSSN
69 Q
70 ;
71OPSSN ;EN Called from PSUOP0. Gives prescription Provider
72 ;
73 D UDSSN
74 Q
75FAC ;Find provider station number. Places that info in each record.
76 ;
77 ;D INST^PSUDEM1
78 S $P(^TMP("PSUPROV",$J),U,2)=PSUSNDR
79 M ^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN)=^TMP("PSUPROV",$J)
80 Q
81 ;
82PNAM ;Find the provider's name.
83 ;
84 N PSUCLP,PSUSS,PSUSP
85 ;
86 ;Find provider name
87 S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,9)=$$GET1^DIQ(200,PSUIEN,.01,"I")
88 ;
89 S PSUCLP=$$GET1^DIQ(200,PSUIEN,53.5,"I") D CLASS ;Provider pointer
90 S PSUSS=$$GET1^DIQ(200,PSUIEN,29,"I") D SS ;Service Sctn ptr
91 ;
92 S PSUD1=999
93 S PSUD1=$O(^VA(200,PSUIEN,"USC1",PSUD1),-1) ;Find last subscript
94 I PSUD1'="" D
95 .S PSUSP=$$GET1^DIQ(200.05,PSUD1_","_PSUIEN_",",.01,"I") ;Specialty
96 .D SPEC
97 I PSUD1="" D
98 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,7)=""
99 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,8)=""
100 Q
101 ;
102CLASS ;Find provider class
103 ;
104 I '$D(PSUCLP) S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,5)="" Q
105 I PSUCLP="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,5)=""
106 I PSUCLP'="" D
107 .N PSUA
108 .S PSUA=$P($G(^DIC(7,PSUCLP,0)),U,2)
109 .I PSUA']"" S PSUA=$P($G(^DIC(7,PSUCLP,0)),U,1)
110 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,5)=PSUA ;Prov class
111 .K PSUA
112 Q
113 ;
114SS ;Find Provider Service/Section
115 ;
116 N PSUTMP
117 ;
118 I PSUSS="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,6)=""
119 I PSUSS'="" S PSUTMP=1 D
120 .S:$P($G(^DIC(49,PSUSS,0)),U)["AMBU" PSUTMP="AMB"
121 .S:$P($G(^DIC(49,PSUSS,0)),U)["ANESTH" PSUTMP="ANES"
122 .S:$P($G(^DIC(49,PSUSS,0)),U)["CARDIO" PSUTMP="CV"
123 .S:$P($G(^DIC(49,PSUSS,0)),U)["PHARM" PSUTMP="CPHAR"
124 .S:$P($G(^DIC(49,PSUSS,0)),U)["DENT" PSUTMP="DDS"
125 .S:$P($G(^DIC(49,PSUSS,0)),U)["MEDIC" PSUTMP="MED"
126 .S:$P($G(^DIC(49,PSUSS,0)),U)["INTERMED" PSUTMP="IM"
127 .S:$P($G(^DIC(49,PSUSS,0)),U)["NUCLEAR" PSUTMP="NUM"
128 .S:$P($G(^DIC(49,PSUSS,0)),U)["NURSING" PSUTMP="RN"
129 .S:$P($G(^DIC(49,PSUSS,0)),U)["ORTHOPED" PSUTMP="ORTHO"
130 .S:$P($G(^DIC(49,PSUSS,0)),U)["PSYCHIA" PSUTMP="PSY"
131 .S:$P($G(^DIC(49,PSUSS,0)),U)["MENTAL" PSUTMP="PSY"
132 .S:$P($G(^DIC(49,PSUSS,0)),U)["PRIMARY" PSUTMP="AMB"
133 .S:$P($G(^DIC(49,PSUSS,0)),U)["CBOC" PSUTMP="AMB"
134 .S:$P($G(^DIC(49,PSUSS,0)),U)["OPHTH" PSUTMP="OPH"
135 .S:$P($G(^DIC(49,PSUSS,0)),U)["PULM" PSUTMP="PUL"
136 .S:$P($G(^DIC(49,PSUSS,0)),U)["RADIOL" PSUTMP="RAD"
137 .S:$P($G(^DIC(49,PSUSS,0)),U)["SURG" PSUTMP="SUR"
138 .S:$P($G(^DIC(49,PSUSS,0)),U)["UROLOG" PSUTMP="U"
139 .S:$P($G(^DIC(49,PSUSS,0)),U)["NEUROL" PSUTMP="NEUR"
140 .S PSUREC=$G(PSUTMP) D REC^PSUDEM2
141 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,6)=$G(PSUREC) ;Prov Serv/Sec
142 Q
143 ;
144SPEC ;Find provider specialty and sub-specialty
145 ;
146 I PSUSP="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,7)=""
147 I PSUSP="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,8)=""
148 I PSUSP'="" D
149 .S PSUREC=$P($G(^USC(8932.1,PSUSP,0)),U,2) D REC^PSUDEM2
150 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,7)=PSUREC D ;Speclty
151 ..I $P(^USC(8932.1,PSUSP,0),U,2)="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,7)=""
152 .S PSUREC=$P($G(^USC(8932.1,PSUSP,0)),U,3) D REC^PSUDEM2
153 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,8)=PSUREC D ;Subspecl
154 ..I $P(^USC(8932.1,PSUSP,0),U,3)="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,8)=""
155 ;
156 Q
157 ;
158XMD ;Format mailman message and send.
159 ;
160 S PSUAA=0
161 F S PSUAA=$O(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAA)) Q:PSUAA="" D
162 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAA),U,9)="" ;Remove provider name
163 ;
164 ;Remove space in piece 8
165 S PSUAB=0
166 F S PSUAB=$O(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAB)) Q:PSUAB="" D
167 .I $P(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAB),U,8)=" " D
168 ..S $P(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAB),U,8)=""
169 ;
170 S PSUAC=0,PSUPL=1
171 F S PSUAC=$O(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAC)) Q:PSUAC="" D
172 .M ^TMP("PSUPROM",$J,PSUPL)=^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAC) ;numerical order
173 .S PSUPL=PSUPL+1
174 ;
175 NEW PSUMAX,PSULC,PSUTMC,PSUTLC,PSUMC
176 S PSUMAX=$$VAL^PSUTL(4.3,1,8.3)
177 S PSUMAX=$S(PSUMAX="":10000,PSUMAX>10000:10000,1:PSUMAX)
178 S PSUMC=1,PSUMLC=0
179 F PSULC=1:1 S X=$G(^TMP("PSUPROM",$J,PSULC)) Q:X="" D
180 .S PSUMLC=PSUMLC+1
181 .I PSUMLC>PSUMAX S PSUMC=PSUMC+1,PSUMLC=0,PSULC=PSULC-1 Q ; + message
182 .I $L(X)<235 S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=X Q
183 .F I=235:-1:1 S Z=$E(X,I) Q:Z="^"
184 .S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=$E(X,1,I)
185 .S PSUMLC=PSUMLC+1
186 .S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)="*"_$E(X,I+1,999)
187 ;
188 F PSUM=1:1:PSUMC D PROV^PSUDEM5
189 D CONF
190 Q
191CONF ;Construct globals for confirmation message
192 ;
193 ; Count Lines sent
194 S PSUTLC=0
195 F PSUM=1:1:PSUMC S X=$O(^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUM,""),-1),PSUTLC=PSUTLC+X
196 ;
197 D INST^PSUDEM1
198 N PSUDIVIS
199 S PSUDIVIS=$P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,1)
200 S PSUSUB="PSU_"_PSUJOB
201 S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,10,"M")=PSUMC
202 S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,10,"L")=PSUTLC
203 Q
Note: See TracBrowser for help on using the repository browser.