source: WorldVistAEHR/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUDEM1.m@ 613

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

initial load of WorldVistAEHR
File size: 6.5 KB
RevLine 
[613]1PSUDEM1 ;BIR/DAM - Patient Demographics Extract ; 20 DEC 2001
2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**12**;MARCH, 2005;Build 19
3 ;
4 ;DBIA's
5 ; Reference to file #27.11 supported by DBIA 2462
6 ; Reference to file 2 supported by DBIA 10035, 3504
7 ; Reference to file 200 supported by DBIA 10060
8 ; Reference to file 55 supported by DBIA 3502
9 ; Reference to file 4.3 supported by DBIA 2496, 10091
10 ; Reference to file 4 supported by DBIA 10090
11 ;
12EN ;EN Routine control module
13 ;
14 D DAT
15 I $D(^XTMP("PSUMANL")) D DEM ;Manual entry point DAM
16 I $G(^XTMP("PSU_"_PSUJOB,"PSUPSUMFLAG")) D HL7 ;Auto entry point DAM
17 I '$D(^XTMP("PSU_"_PSUJOB,"PSUFLAG")) D XMD
18 K ^XTMP("PSU_"_PSUJOB,"PSUXMD")
19 ;
20 I $G(^XTMP("PSU_"_PSUJOB,"PSUPSUMFLAG"))=1 D
21 .S PSUOPTS="1,2,3,4,5,6,7,8,9,10,11"
22 .S PSUAUTO=1
23 ;
24 ;
25 D PULL^PSUCP
26 F I=1:1:$L(PSUOPTS,",") S PSUMOD($P(PSUOPTS,",",I))=""
27 ;
28 I $D(PSUMOD(10)) D PDSSN^PSUDEM4 ;pt. demographics provider msg
29 ;
30 K ^XTMP("PSU_"_PSUJOB,"PSUPDFLAG")
31 K ^XTMP("PSU_"_PSUJOB,"PSUDM")
32 K ^XTMP("PSU_"_PSUJOB,"PSUDMX")
33 K PSUDMDFN,PSURAC,PSURDT
34 Q
35 ;
36HL7 ;This is the Patient Demographics extract that runs only when
37 ;the PSU PBM [AUTO] option is executed. It captures demographic
38 ;information ONLY on new or updated patient.
39 ;
40 ; *** PSU*4.0*12 - BAJ -- added QUIT if NULL
41 F S PSUSDT=$O(^PSUDEM("B",PSUSDT)) Q:PSUSDT="" Q:PSUSDT>PSUEDT D
42 . S I=""
43 . S I=$O(^PSUDEM("B",PSUSDT,I)) Q:I=""
44 . S DFN=$P(^PSUDEM(I,0),U,2)
45 . S ^XTMP("PSU"_PSUJOB,"REXMT",DFN)=""
46 K DFN
47 ;
48 S DFN=""
49 F S (DFN,PSUDMDFN)=$O(^XTMP("PSU"_PSUJOB,"REXMT",DFN)) Q:DFN="" D DEM1
50 ;
51 Q
52 ;
53DAT ;Date Module
54 ;
55 ;Date extract was run
56 S %H=$H
57 D YMD^%DTC ;Converts $H to FileMan format
58 ; ** S $P(^TMP("PSUDM",$J),U,3)=X ;Set extract date in temp global
59 S PSURDT=X
60 ;
61 Q
62 ;
63INST ;EN Place institution code sending report into temp global.
64 ;Institution Mailman info is in file 4.3
65 ;
66 S X=$$VALI^PSUTL(4.3,1,217),PSUSNDR=+$$VAL^PSUTL(4,X,99)
67 S $P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,1)=PSUSNDR
68 S PSUSIT=PSUSNDR
69 ;
70 S X=PSUSNDR,DIC=40.8,DIC(0)="X",D="C" D IX^DIC ;**1
71 S X=+Y S PSUDIVNM=$$VAL^PSUTL(40.8,X,.01)
72 S $P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,2)=PSUDIVNM
73 Q
74 ;
75DEM ;PULL PATIENT DEMOGRAPHICS. This is run only when user selects
76 ;PSU PBM [MANUAL] option. It gather patient demographic information
77 ;for all patients in the PATIENT file #2.
78 ;
79 ;N PSUREC ;DAM TEST NEW CODE
80 N PSUREC
81 K PSUREC1,PSUREC2,PSUREC3,PSUREC4,PSUREC5,PSUREC6,PSUREC7
82 K PSUREC8,PSUREC9,PSUREC10,PSUREC11,PSUREC12,PSUREC13,PSUREC14
83 K PSUREC15,PSUDOD,VAEL,VADM
84 ;
85 S PSUNAM=0
86 F S PSUNAM=$O(^DPT("B",PSUNAM)) Q:PSUNAM="" D
87 .S PSUDMDFN=0
88 .F S (DFN,PSUDMDFN)=$O(^DPT("B",PSUNAM,PSUDMDFN)) Q:PSUDMDFN="" D DEM1
89 Q
90 ;
91DEM1 ;
92 K PSUREC,PSUREC1,PSUREC2,PSUREC3,PSUREC4,PSUREC5,PSUREC6,PSUREC7
93 K PSUREC8,PSUREC9,PSUREC10,PSUREC11,PSUREC12,PSUREC13,PSUREC14
94 K PSUREC15,PSUDOD,VAEL,VADM
95 S PSUDOD=$P($G(^DPT(PSUDMDFN,.35)),U,1) I PSUDOD,PSUDOD<2980701 Q
96 Q:'$D(^DPT(PSUDMDFN,0)) S PSUREC1=$G(^DPT(PSUDMDFN,0))
97 I $P(PSUREC1,U,21)=1 Q
98 I $E($P(PSUREC1,U,9),1,5)="00000" Q
99 D DEM^VADPT
100 D ELIG^VADPT
101 ;RUN DATE
102 S $P(PSUREC,U,3)=PSURDT
103 ;Gender
104 S PSUREC3=$TR($P(PSUREC1,U,2),"^","'"),$P(PSUREC,U,8)=PSUREC3
105 ;SSN
106 S PSUREC4=$TR($P(PSUREC1,U,9),"^","'"),$P(PSUREC,U,12)=PSUREC4
107 ;DOB
108 S PSUREC5=$TR($P(PSUREC1,U,3),"^","'"),$P(PSUREC,U,5)=PSUREC5
109 ;DT PT ENTERED IN FILE
110 S PSUREC6=$TR($P(PSUREC1,U,16),"^","'"),$P(PSUREC,U,16)=PSUREC6
111 S PSUREC7=$G(^PS(55,PSUDMDFN,0)),$P(PSUREC,U,17)=$TR($P(PSUREC7,U,7),"^","'")
112 ;Service Actual/Historical
113 S $P(PSUREC,U,18)=$TR($P(PSUREC7,U,8),"^","'")
114 ;PLACE "^" AT END OF RECORD
115 S $P(PSUREC,U,30)=""
116 ;SITE SENDING DATA
117 S $P(PSUREC,U,2)=PSUSNDR
118 ;RACE
119 S PSUREC8=$P($G(VADM(8)),U,2),$P(PSUREC,U,7)=PSUREC8
120 ;PRIMARY ELIG CODE
121 S PSUREC9=$P($G(VAEL(1)),U,2),$P(PSUREC,U,9)=PSUREC9
122 D PRIO
123 ;MEANS TEST STATUS
124 S PSUREC11=$P($G(VAEL(9)),U,2),$P(PSUREC,U,10)=PSUREC11
125 D MISC
126 ;FIND PATIENT ICN-VMP
127 D ICN
128 ;PATIENT CURRENT AGE
129 S PSUREC12=$G(VADM(4)),$P(PSUREC,U,6)=PSUREC12
130 D ETH
131 S ^XTMP("PSU_"_PSUJOB,"PSUDMX",PSUDMDFN)=$G(PSUREC)
132 Q
133 ;
134PRIO ;Pull Enrollment Priority
135 ;
136 S PSUEC=0
137 F S PSUEC=$O(^DGEN(27.11,"C",PSUDMDFN,PSUEC)) Q:PSUEC="" D
138 .S PSUREC10=$TR($P($G(^DGEN(27.11,PSUEC,0)),U,7),"^","'")
139 .I PSUREC10'="" S $P(PSUREC,U,11)=PSUREC10
140 Q
141 ;
142MISC ;Pulls miscellaneous additional info via EN^DIQ1 call
143 ;Pulls Date of Death, ICN, Primary Care Provider SSN,
144 ;Date patient first provided pharmacy care
145 ;
146 N PSUDATMP,PSUDDTMP,PSUDTMPA
147 ;
148 S PSUDTMPA=$$OUTPTPR^SDUTL3(PSUDMDFN) ;Prov IEN^EXTERNAL VALUE in temp variable
149 S PSUDATMP=$P($G(PSUDTMPA),U) ;Prov IEN
150 S $P(PSUREC,U,15)=PSUDATMP
151 I '$D(PSUDATMP)!PSUDATMP=0 S PSUDATMP=99999999999
152 S $P(PSUREC,U,14)=$$GET1^DIQ(200,PSUDATMP,9,"I") ;Prov SSN
153 S $P(PSUREC,U,4)=$S(PSUDOD:PSUDOD\1,1:"")
154 Q
155 ;
156ICN ;Find patient ICN
157 ;VMP - OIFO BAY PINES;ELR;PSU*3.0*24
158 ;
159 N PSUICN,PSUICN1
160 S PSUICN=$$GETICN^MPIF001(PSUDMDFN) D
161 .I PSUICN'[-1 D
162 ..S $P(PSUREC,U,13)=PSUICN ;ICN
163 Q
164 ;
165ETH ;Ethnicity and multiple race entries
166 ;
167 S PSUREC14=$P($G(VADM(11,1)),U,2),$P(PSUREC,U,19)=PSUREC14
168 ;
169 S PSURCE=0,C=20,$P(PSUREC,U,C)=""
170 F S PSURCE=$O(VADM(12,PSURCE)) Q:PSURCE="" D ;Race multiple
171 .S PSURAC=$P($G(VADM(12,PSURCE)),U,2),$P(PSUREC,U,C)=PSURAC,C=C+1
172 Q
173 ;
174XMD ;Format mailman message and send.
175 ;
176 S PSUAB=0,PSUPL=1
177 F S PSUAB=$O(^XTMP("PSU_"_PSUJOB,"PSUDMX",PSUAB)) Q:PSUAB="" D
178 .M ^XTMP("PSU_"_PSUJOB,"PSUDM",PSUPL)=^XTMP("PSU_"_PSUJOB,"PSUDMX",PSUAB) ;Global numerical order
179 .S PSUPL=PSUPL+1
180 ;
181 NEW PSUMAX,PSULC,PSUTMC,PSUTLC,PSUMC
182 S PSUMAX=$$VAL^PSUTL(4.3,1,8.3)
183 S PSUMAX=$S(PSUMAX="":10000,PSUMAX>10000:10000,1:PSUMAX)
184 S PSUMC=1,PSUMLC=0
185 F PSULC=1:1 S X=$G(^XTMP("PSU_"_PSUJOB,"PSUDM",PSULC)) Q:X="" D
186 .S PSUMLC=PSUMLC+1
187 .I PSUMLC>PSUMAX S PSUMC=PSUMC+1,PSUMLC=0,PSULC=PSULC-1 Q ; + message
188 .I $L(X)<235 S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=X Q
189 .F I=235:-1:1 S Z=$E(X,I) Q:Z="^"
190 .S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=$E(X,1,I)
191 .S PSUMLC=PSUMLC+1
192 .S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)="*"_$E(X,I+1,999)
193 ;
194 ; Count Lines sent
195 S PSUTLC=0
196 F PSUM=1:1:PSUMC S X=$O(^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUM,""),-1),PSUTLC=PSUTLC+X
197 ;
198 F PSUM=1:1:PSUMC D PDMAIL^PSUDEM5
199 D CONF
200 Q
201CONF ;Construct globals for confirmation message
202 ;
203 N PSUDIVIS
204 D INST
205 S PSUDIVIS=$P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,1)
206 S PSUSUB="PSU_"_PSUJOB
207 S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,7,"M")=PSUMC
208 S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,7,"L")=PSUTLC
209 Q
210REC ;EN If "^" is contained in any record, replace it with "'"
211 ;
212 I PSUREC["^" S PSUREC=$TR(PSUREC,"^","'")
213 Q
Note: See TracBrowser for help on using the repository browser.