source: FOIAVistA/trunk/r/FEE_BASIS-FB/FBPMRG.m@ 1274

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

initial load of FOIAVistA 6/30/08 version
File size: 6.7 KB
Line 
1FBPMRG ;WCIOFO/SAB-FEE BASIS PATIENT MERGE ROUTINE ;12/15/2001
2 ;;3.5;FEE BASIS;**19,41,59**;JAN 30, 1995
3EN(ARRAY) ; Entry point
4 ; Called during patient (file #2) merge due to AFFECTS RECORD MERGE
5 ; in PACKAGE (#9.4) file.
6 ; Input
7 ; ARRAY - name of array with the PATIENT (#2) From IENs and To IENs
8 ; format: name(ien_from,ien_to,"ien_from;DPT(","ien_to;DPT(")
9 ; example: TEST(1000,500,"1000;DPT(","500;DPT(")=""
10 ;
11 N FBFR,FBTO
12 ; loop thru from ien of patients (file #2) being merged
13 S FBFR=0 F S FBFR=$O(@ARRAY@(FBFR)) Q:FBFR'>0 D
14 . S FBTO=$O(@ARRAY@(FBFR,0)) ; to ien
15 . ; check/update some Fee Basis files that normal merge can't handle
16 . D F161
17 . D F162^FBPMRG1
18 Q
19 ;
20F161 ; File 161 FEE BASIS PATIENT - The .01 field points to and is
21 ; dinumed with the PATIENT (#2) file
22 ; input
23 ; FBFR - ien of patient (files #2,161) being merged from
24 ; FBTO - ien of patient (files #2,161) being merged to
25 N FBFR1,FBTO1
26 N DA,DD,DIC,DIK,DINUM,DLAYGO,DO,X,Y
27 ;
28 Q:'$D(^FBAAA(FBFR)) ; nothing to merge from
29 ;
30 ;
31IDCARD ; if both records have id card numbers the pairs are removed from merge.
32 ; all other cases will be handled by merge.
33 ;
34 I $P($G(^FBAAA(FBFR,4)),U) D
35 .I $P($G(^FBAAA(FBTO,4)),U) D
36 ..; remove pair from merge when there is a id number in the from and to
37 ..S IENFRM=$O(@ARRAY@(FBFR,FBTO,""))
38 ..S IENTO=$O(@ARRAY@(FBFR,FBTO,IENFRM,""))
39 ..S IEN=""
40 ..S IEN=+$G(@ARRAY@(FBFR,FBTO,IENFRM,IENTO))
41 ..D RMOVPAIR^XDRDVAL1(FBFR,FBTO,IEN,ARRAY)
42 ..N XMSUB,XMTEXT
43 ..S XMSUB="MERGE PAIRS EXCLUDED DUE TO BOTH HAVE FEE BASIS ID CARDS"
44 ..S ^TMP("DDB",$J,1)=" MERGE PAIR Patient records "_FBFR_" AND "_FBTO_" both have FB ID card numbers. Please cancel one of the IDs and resubmit the Merge Pair"
45 ..S XMTEXT="^TMP(""DDB"",$J,"
46 ..D SENDMESG^XDRDVAL1(XMSUB,XMTEXT)
47 ..K IEN,IENTO,IENFRM
48 ;
49 ;
50 Q:'$D(^FBAAA(FBTO)) ; if only from ien exists then standard process OK
51 ;
52 ; both from ien and to ien are in the FEE BASIS PATIENT file.
53 ; The AUTHORIZATION multiple and REPORT OF CONTACT multiple can have
54 ; duplicate .01 values so they need to be handled here since the
55 ; standard merge would inappropriately combine subfile entries whose
56 ; .01 values match. Additionally, if the ien of an AUTHORIZATION must
57 ; be changed when moved from the 'from ien' to the 'to ien', then
58 ; the free-text pointers that reference that AUTHORIZATION will need
59 ; to be updated.
60 ;
61 ; loop thru authorization multiple in 'from ien'
62 S FBFR1=0 F S FBFR1=$O(^FBAAA(FBFR,1,FBFR1)) Q:'FBFR1 D
63 . ;
64 . ; create new entry in authorization multiple of 'to ien'
65 . K DD,DO,DA
66 . S DIC="^FBAAA("_FBTO_",1,",DIC(0)="L"
67 . S DA(1)=FBTO
68 . S X=$P($G(^FBAAA(FBFR,1,FBFR1,0)),U)
69 . Q:X="" ; can't add without a from date
70 . I $D(@(DIC_FBFR1_")"))=0 S DINUM=FBFR1 ; use same ien if available
71 . S DLAYGO=161.01
72 . D FILE^DICN K DIC,DINUM,DLAYGO
73 . Q:$P(Y,U,3)'=1 ; couldn't add new authorization
74 . S FBTO1=+Y
75 . ;
76 . ; move data
77 . M ^FBAAA(FBTO,1,FBTO1)=^FBAAA(FBFR,1,FBFR1)
78 . ;
79 . ; delete 'from authorization'
80 . S DIK="^FBAAA("_FBFR_",1,"
81 . S DA(1)=FBFR,DA=FBFR1
82 . D ^DIK K DA,DIK
83 . ;
84 . ; index 'to authorization'
85 . S DIK="^FBAAA("_FBTO_",1,"
86 . S DA(1)=FBTO,DA=FBTO1
87 . D IX1^DIK K DA,DIK
88 . ;
89 . ; if authorization ien was changed then update any pointers to it
90 . I FBFR1'=FBTO1 D UAUTHP
91 ;
92 ; loop thru report of contact multiple in 'from ien'
93 S FBFR1=0 F S FBFR1=$O(^FBAAA(FBFR,2,FBFR1)) Q:'FBFR1 D
94 . ;
95 . ; create new entry in report of contact multiple of 'to ien'
96 . K DD,DO,DA
97 . S DIC="^FBAAA("_FBTO_",2,",DIC(0)="L"
98 . S DA(1)=FBTO
99 . S X=$P($G(^FBAAA(FBFR,1,FBFR1,0)),U)
100 . Q:X="" ; can't add without a date of contact
101 . I $D(@(DIC_FBFR1_")"))=0 S DINUM=FBFR1 ; use same ien if available
102 . S DLAYGO=161.02
103 . D FILE^DICN K DIC,DINUM,DLAYGO
104 . Q:$P(Y,U,3)'=1 ; couldn't add new report of contact
105 . S FBTO1=+Y
106 . ;
107 . ; move data
108 . M ^FBAAA(FBTO,2,FBTO1)=^FBAAA(FBFR,2,FBFR1)
109 . ;
110 . ; delete 'from report of contact'
111 . S DIK="^FBAAA("_FBFR_",2,"
112 . S DA(1)=FBFR,DA=FBFR1
113 . D ^DIK K DA,DIK
114 . ;
115 . ; index 'to report of contact'
116 . S DIK="^FBAAA("_FBTO_",2,"
117 . S DA(1)=FBTO,DA=FBTO1
118 . D IX1^DIK
119 ;
120 Q
121 ;
122UAUTHP ; Update 'free-text' pointers to authorization
123 ; input
124 ; FBFR - ien of patient (files #2,161) being merged from
125 ; FBFR1 - ien of authorization in FBFR
126 ; FBTO - ien of patient (files #2,161) being merged to
127 ; FBTO1 - ien of authorization in FBTO
128 N AUTHP,DA,DIE,DR,X,X1,Y
129 ;
130 Q:FBFR1=FBTO1 ; same value so nothing to update
131 ;
132 ; update file 161.26 FEE BASIS PATIENT MRA
133 ; use "B" x-ref to find patient
134 K DA S DA=0 F S DA=$O(^FBAA(161.26,"B",FBFR,DA)) Q:'DA D
135 . ; if existing authorization pointer refers to the authorization
136 . ; that was changed then update it
137 . S AUTHP=$P($G(^FBAA(161.26,DA,0)),U,3)
138 . I AUTHP=FBFR1 D
139 . . S DIE="^FBAA(161.26,"
140 . . S DR="2////^S X=FBTO1"
141 . . D ^DIE
142 ;
143 ; update file 162 FEE BASIS PAYMENT
144 ; use dinum relationship to find patient
145 K DA S DA(2)=FBFR
146 ; loop thru vendor multiple
147 S DA(1)=0 F S DA(1)=$O(^FBAAC(DA(2),1,DA(1))) Q:'DA(1) D
148 . ; loop thru initial treatment date multiple
149 . S DA=0 F S DA=$O(^FBAAC(DA(2),1,DA(1),1,DA)) Q:'DA D
150 . . ; if existing authorization pointer refers to the authorization
151 . . ; that was changed then update it
152 . . S AUTHP=$P($G(^FBAAC(DA(2),1,DA(1),1,DA,0)),U,4)
153 . . I AUTHP=FBFR1 D
154 . . . S DIE="^FBAAC("_DA(2)_",1,"_DA(1)_",1,"
155 . . . S DR="3////^S X=FBTO1"
156 . . . D ^DIE
157 ;
158 ; update file 162.1 FEE BASIS PHARMACY INVOICE
159 ; use "AD" x-ref to find patient
160 ; loop thru inverse dates for 'from patient'
161 K DA S X1="" F S X1=$O(^FBAA(162.1,"AD",FBFR,X1)) Q:X1="" D
162 . ; loop thru invoices
163 . S DA(1)=0 F S DA(1)=$O(^FBAA(162.1,"AD",FBFR,X1,DA(1))) Q:'DA(1) D
164 . . ; loop thru prescriptions
165 . . S DA=0 F S DA=$O(^FBAA(162.1,"AD",FBFR,X1,DA(1),DA)) Q:'DA D
166 . . . ; if existing authorization pointer refers to the authorization
167 . . . ; that was changed then update it
168 . . . S AUTHP=$P($G(^FBAA(162.1,DA(1),"RX",DA,2)),U,7)
169 . . . I AUTHP=FBFR1 D
170 . . . . S DIE="^FBAA(162.1,"_DA(1)_",""RX"","
171 . . . . S DR="27////^S X=FBTO1"
172 . . . . D ^DIE
173 ;
174 ; update file 162.3 FEE CNH ACTIVITY
175 ; use "AE" x-ref to find patient
176 K DA S DA="" F S DA=$O(^FBAACNH("AE",FBFR,DA)) Q:'DA D
177 . ; if existing authorization pointer refers to the authorization
178 . ; that was changed then update it
179 . S AUTHP=$P($G(^FBAACNH(DA,0)),U,10)
180 . I AUTHP=FBFR1 D
181 . . S DIE="^FBAACNH("
182 . . S DR="9////^S X=FBTO1"
183 . . D ^DIE
184 ;
185 ; update file 162.7 FEE BASIS UNAUTHORIZED CLAIM
186 ; using "D" x-ref to find patient
187 ; loop thru claims for patient
188 K DA S DA=0 F S DA=$O(^FB583("D",FBFR,DA)) Q:'DA D
189 . ; if existing authorization pointer refers to the authorization
190 . ; that was changed then update it
191 . S AUTHP=$P($G(^FB583(DA,0)),U,27)
192 . I AUTHP=FBFR1 D
193 . . S DIE="^FB583("
194 . . S DR="30////^S X=FBTO1"
195 . . D ^DIE
196 Q
197 ;
198 ;FBPMRG
Note: See TracBrowser for help on using the repository browser.