source: FOIAVistA/tag/r/FEE_BASIS-FB/FBPMRG1.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 6.9 KB
Line 
1FBPMRG1 ;WCIOFO/SAB-FEE BASIS PATIENT MERGE ROUTINE (cont) ;12/15/2001
2 ;;3.5;FEE BASIS;**19,41**;JAN 30, 1995
3 Q
4F162 ; File 162 FEE BASIS PAYMENT - The .01 field points to and is
5 ; dinumed with the PATIENT (#2) file
6 ; input
7 ; FBFR - ien of patient (files #2,162) being merged from
8 ; FBTO - ien of patient (files #2,162) being merged to
9 N FBAUTHP,FBFR1,FBFR2,FBFR3,FBFRIENS,FBTO1,FBTO2,FBTO3,FBTOIENS
10 N DA,DD,DO,DIC,DIK,DINUM,DLAYGO,X,Y
11 ;
12 Q:'$D(^FBAAC(FBFR)) ; nothing to merge from
13 ;
14 ; since a 'from ien' exists, we'll need to keep track of the old
15 ; and new 'iens' of payments that may have been reported to the
16 ; Austin Automation Center (AAC). The AAC returns data concerning the
17 ; payments and the 'iens' are used to locate the appropriate entry to
18 ; update.
19 ;
20 ; Additionally, if both the from ien and to ien are in the FEE BASIS
21 ; PAYMENT file then the SERVICE PROVIDED multiple and the TRAVEL
22 ; PAYMENT DATE multiple will need to be handled here since they
23 ; are allowed to have duplicate .01 values and a standard merge could
24 ; inappropriately combine subfile entries whose .01 values match.
25 ;
26 ; medical payments
27 ; loop thru vendor multiple
28 S FBFR1=0 F S FBFR1=$O(^FBAAC(FBFR,1,FBFR1)) Q:'FBFR1 D
29 . ; loop thru initial treatment date multiple
30 . S FBFR2=0 F S FBFR2=$O(^FBAAC(FBFR,1,FBFR1,1,FBFR2)) Q:'FBFR2 D
31 . . S FBAUTHP=$P($G(^FBAAC(FBFR,1,FBFR1,1,FBFR2,0)),U,4) ; auth pointer
32 . . ; loop thru service provided multiple
33 . . S FBFR3=0
34 . . F S FBFR3=$O(^FBAAC(FBFR,1,FBFR1,1,FBFR2,1,FBFR3)) Q:'FBFR3 D
35 . . . S FBFRIENS=FBFR3_","_FBFR2_","_FBFR1_","_FBFR_","
36 . . . ; If the 'to ien' does not exist then only the patient ien will be
37 . . . ; different on payments sent to the AAC. We just need to save
38 . . . ; the iens and the normal merge will take care of moving the data.
39 . . . I '$D(^FBAAC(FBTO)) S FBTOIENS=FBFR3_","_FBFR2_","_FBFR1_","_FBTO_","
40 . . . E D
41 . . . . ; both from ien and to ien are in the FEE BASIS PAYMENT file
42 . . . . S (FBTO1,FBTO2,FBTO3,FBTOIENS)="" ; initialize new iens
43 . . . . ;
44 . . . . ; create new service provided entry in 'to ien'
45 . . . . ; find or create vendor subentry in 'to ien'
46 . . . . I $D(^FBAAC(FBTO,1,FBFR1)) S FBTO1=FBFR1
47 . . . . E D
48 . . . . . ; need to add vendor subentry
49 . . . . . K DA,DD,DO
50 . . . . . S DA(1)=FBTO
51 . . . . . S DIC="^FBAAC("_DA(1)_",1,"
52 . . . . . S DIC(0)="L"
53 . . . . . S X=$P($G(^FBAAC(FBFR,1,FBFR1,0)),U)
54 . . . . . Q:X=""
55 . . . . . S DINUM=X,DLAYGO=162.01
56 . . . . . D FILE^DICN K DIC,DINUM,DLAYGO
57 . . . . . Q:$P(Y,U,3)'=1 ; couldn't add vendor subentry
58 . . . . . S FBTO1=+Y
59 . . . . Q:'$G(FBTO1) ; couldn't find or add the vendor in FBTO
60 . . . . ;
61 . . . . ; find or create initial treatment date subentry in 'to ien'
62 . . . . ;
63 . . . . S X=$P($G(^FBAAC(FBFR,1,FBFR1,1,FBFR2,0)),U) ; init treat date
64 . . . . Q:X=""
65 . . . . S FBTO2=$O(^FBAAC(FBTO,FBTO1,"AD",(9999999.9999-X),0))
66 . . . . I 'FBTO2 D
67 . . . . . ; need to add initial treatment date subentry
68 . . . . . K DA,DD,DO
69 . . . . . S DA(2)=FBTO
70 . . . . . S DA(1)=FBTO1
71 . . . . . S DIC="^FBAAC("_DA(2)_",1,"_DA(1)_",1,"
72 . . . . . S DIC(0)="L"
73 . . . . . S:FBAUTHP DIC("DR")="3////^S X=FBAUTHP" ;authorization pointer
74 . . . . . I $D(@(DIC_FBFR2_")"))=0 S DINUM=FBFR2 ; use same ien if avail
75 . . . . . S DLAYGO=162.02
76 . . . . . D FILE^DICN K DIC,DINUM,DLAYGO
77 . . . . . Q:$P(Y,U,3)'=1 ; couldn't add init treat date subentry
78 . . . . . S FBTO2=+Y
79 . . . . Q:'$G(FBTO2) ; couldn't find or add the init treat date in FBTO
80 . . . . ;
81 . . . . ; create new entry in service provided multiple of 'to ien'
82 . . . . K DA,DD,DO
83 . . . . S DA(3)=FBTO,DA(2)=FBTO1,DA(1)=FBTO2
84 . . . . S DIC="^FBAAC("_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",1,"
85 . . . . S DIC(0)="L"
86 . . . . S X=$P($G(^FBAAC(FBFR,1,FBFR1,1,FBFR2,1,FBFR3,0)),U)
87 . . . . Q:X="" ; can't add without a service provided
88 . . . . I $D(@(DIC_FBFR3_")"))=0 S DINUM=FBFR3 ; use same ien if avail.
89 . . . . S DLAYGO=162.03
90 . . . . D FILE^DICN K DIC,DINUM,DLAYGO
91 . . . . Q:$P(Y,U,3)'=1 ; couldn't add new subentry
92 . . . . S FBTO3=+Y
93 . . . . S FBTOIENS=FBTO3_","_FBTO2_","_FBTO1_","_FBTO_","
94 . . . . ;
95 . . . . ; move service provided data
96 . . . . M ^FBAAC(FBTO,1,FBTO1,1,FBTO2,1,FBTO3)=^FBAAC(FBFR,1,FBFR1,1,FBFR2,1,FBFR3)
97 . . . . ;
98 . . . . ; delete 'from' service provided
99 . . . . K DA S DA(3)=FBFR,DA(2)=FBFR1,DA(1)=FBFR2,DA=FBFR3
100 . . . . S DIK="^FBAAC("_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",1,"
101 . . . . D ^DIK K DA,DIK
102 . . . . ;
103 . . . . ; index 'to' service provided
104 . . . . K DA S DA(3)=FBTO,DA(2)=FBTO1,DA(1)=FBTO2,DA=FBTO3
105 . . . . S DIK="^FBAAC("_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",1,"
106 . . . . D IX1^DIK K DA,DIK
107 . . . . ;
108 . . . Q:$G(FBTOIENS)="" ; unable to move service provided to FBTO
109 . . . ; save iens (FBFRIENS and FBTOIENS) to file
110 . . . D SAVIENS(162.03,FBFRIENS,FBTOIENS)
111 . . ; if all service provided entries moved then delete the treat. date
112 . . I $P($G(^FBAAC(FBFR,1,FBFR1,1,FBFR2,1,0)),U,4)=0 D
113 . . . K DA S DA(2)=FBFR,DA(1)=FBFR1,DA=FBFR2
114 . . . S DIK="^FBAAC("_DA(2)_",1,"_DA(1)_",1,"
115 . . . D ^DIK K DA,DIK
116 . ; if all initial treatment dates moved then delete the vendor
117 . I $P($G(^FBAAC(FBFR,1,FBFR1,1,0)),U,4)=0 D
118 . . K DA S DA(1)=FBFR,DA=FBFR1
119 . . S DIK="^FBAAC("_DA(1)_",1,"
120 . . D ^DIK K DA,DIK
121 ;
122 ; travel payments
123 ; loop thru travel payment date multiple
124 S FBFR1=0 F S FBFR1=$O(^FBAAC(FBFR,3,FBFR1)) Q:'FBFR1 D
125 . S FBFRIENS=FBFR1_","_FBFR_","
126 . ; If the 'to ien' does not exist then only the patient ien will be
127 . ; different on payments sent to the AAC. We just need to save
128 . ; the iens and the normal merge will take care of moving the data.
129 . I '$D(^FBAAC(FBTO)) S FBTOIENS=FBFR1_","_FBTO_","
130 . E D
131 . . ; both from ien and to ien are in the FEE BASIS PAYMENT file
132 . . ; create travel payment date subentry in to ien
133 . . S (FBTO1,FBTOIENS)="" ; initialize new iens
134 . . K DA,DD,DO
135 . . S DA(1)=FBTO
136 . . S DIC="^FBAAC("_DA(1)_",3,"
137 . . S DIC(0)="L"
138 . . S X=$P($G(^FBAAC(FBFR,3,FBFR1,0)),U)
139 . . Q:X="" ; can't add without a travel payment date
140 . . I $D(@(DIC_FBFR1_")"))=0 S DINUM=FBFR1 ; use same ien if avail.
141 . . S DLAYGO=162.04
142 . . D FILE^DICN K DIC,DINUM,DLAYGO
143 . . Q:$P(Y,U,3)'=1 ; couldn't add new subentry
144 . . S FBTO1=+Y
145 . . S FBTOIENS=FBTO1_","_FBTO_","
146 . . ;
147 . . ; move data
148 . . M ^FBAAC(FBTO,3,FBTO1)=^FBAAC(FBFR,3,FBFR1)
149 . . ;
150 . . ; delete from ien
151 . . K DA S DA(1)=FBFR,DA=FBFR1
152 . . S DIK="^FBAAC("_DA(1)_",3,"
153 . . D ^DIK K DA,DIK
154 . . ;
155 . . ; index to ien
156 . . K DA S DA(1)=FBTO,DA=FBTO1
157 . . S DIK="^FBAAC("_DA(1)_",3,"
158 . . D IX1^DIK K DA,DIK
159 . ;
160 . Q:$G(FBTOIENS)="" ; unable to move travel payment date to FBTO
161 . ; save iens (FBFRIENS and FBTOIENS) to file
162 . D SAVIENS(162.04,FBFRIENS,FBTOIENS)
163 ;
164 Q
165 ;
166SAVIENS(FBFILE,FBOLDIEN,FBNEWIEN) ; save old & new iens in file 161.45
167 N DA,DD,DIC,DLAYGO,DO,X,Y
168 S DIC="^FBAA(161.45,",DIC(0)="L"
169 S X=FBFILE
170 Q:X="" ; can't add without a from date
171 S DIC("DR")="1////^S X=FBOLDIEN;2////^S X=FBNEWIEN"
172 S DLAYGO=161.45
173 D FILE^DICN K DIC,DLAYGO
174 Q
175 ;
176 ;FBPMRG1
Note: See TracBrowser for help on using the repository browser.