source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNEHLT.m@ 1259

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

initial load of WorldVistAEHR

File size: 8.2 KB
Line 
1IBCNEHLT ;DAOU/ALA - HL7 Process Incoming MFN Messages ; 09 Dec 2005 3:30 PM
2 ;;2.0;INTEGRATED BILLING;**184,251,271,300**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;**Program Description**
6 ; This program will process incoming MFN messages and
7 ; update the appropriate tables
8 ;
9EN ; Entry Point
10 NEW AIEN,APIEN,APP,D0,D,DESC,DQ,DR,FILE,FLN,HEDI,ID,IEN
11 NEW PEDI,SEG,STAT,HCT,NEWID,TSSN,USSN,REQSUB,NAFLG,NPFLG
12 NEW IBCNACT,IBCNADT,FSVDY,PSVDY
13 NEW BPSIEN,CMIEN,DATA,DATAAP,DATABPS,DATACM,DATE,ERROR,FIELDNO,FILENO
14 NEW IBSEG,MSG,BUFF
15 NEW X12TABLE,BADFMT
16 ;
17 ; BADFMT is true if a site with patch 300 receives an IIV message in the previous HL7 interface structure (pre-300)
18 ;
19 ; Build local table of file numbers to determine if response is IIV or ePHARM
20 F D=11:1:18,21 S X12TABLE("365.0"_D)=""
21 ;
22 ; Decide if message belongs to "E-Pharm" or "IIV"
23 S APP=""
24 S HCT=0,ERFLG=0
25 F S HCT=$O(^TMP($J,"IBCNEHLI",HCT)) Q:HCT="" D SPAR^IBCNEHLU I $G(IBSEG(1))="MFI" S FILE=$G(IBSEG(2)),FLN=$P(FILE,$E(HLECH,1),1) Q
26 I ",366.01,366.02,366.03,365.12,355.3,"[(","_FLN_",") S APP="E-PHARM"
27 I FLN=365.12 D
28 . S HCT=0,BADFMT=0
29 . F S HCT=$O(^TMP($J,"IBCNEHLI",HCT)) Q:HCT="" D Q:(APP="IIV")!BADFMT
30 .. D SPAR^IBCNEHLU
31 .. I $G(IBSEG(1))="MFE",$P($G(IBSEG(5)),$E(HLECH,1),3)'="" D Q
32 ... S BADFMT=1,APP=""
33 ... S MSG(1)="Log a Remedy Ticket for this issue."
34 ... S MSG(2)="Please include in the Remedy Ticket that the IIV payer tables may be out"
35 ... S MSG(3)="of sync with the master list and will need a new copy of the payer table"
36 ... S MSG(4)="from Austin."
37 ... D MSG^IBCNEUT5($$MGRP^IBCNEUT5(),"IIV payer tables may be out of synch with master list","MSG(")
38 .. I $G(IBSEG(1))="ZPA" S APP="IIV"
39 I $D(X12TABLE(FLN)) S APP="IIV"
40 ; If neither IIV or ePHARM then quit
41 I APP="" Q
42 ;
43 S HCT=1,NAFLG=0,NPFLG=0,D=""
44 F S HCT=$O(^TMP($J,"IBCNEHLI",HCT)) Q:HCT="" D Q:ERFLG
45 . D SPAR^IBCNEHLU
46 . S SEG=$G(IBSEG(1))
47 . ;
48 . I APP="E-PHARM" D
49 .. I SEG="MFI" D
50 ... S FILE=$G(IBSEG(2))
51 ... S FLN=$P(FILE,$E(HLECH,1),1)
52 ... ;
53 ... ; Initialize MFK Message (Application Acknowledgement) variables
54 ... ; Master File Identifier
55 ... S DATAMFK("MFI-1")=$G(IBSEG(2))
56 ... ;
57 ... ; File-Level Event Code
58 ... S DATAMFK("MFI-3")=$G(IBSEG(4))
59 .. ;
60 .. I SEG="MFE" D
61 ... I $G(FLN)="" S ERFLG=1,MSG(1)="File Number not found in MFN message" Q
62 ... I '$$VFILE^DILFD(FLN) S ERFLG=1,MSG(1)="File "_FLN_" not found in the Data Dictionary" Q
63 ... ;
64 ... ; Initialize MFK Message (Application Acknowledgement) variables
65 ... ; Record-Level Event Code
66 ... S DATAMFK("MFE-1")=$G(IBSEG(2))
67 ... ;
68 ... ; Primary Key Value
69 ... S DATAMFK("MFE-4")=$G(IBSEG(5))
70 ... ;
71 ... ; Primary Key Value Type
72 ... S DATAMFK("MFE-5")=$G(IBSEG(6))
73 ... ;
74 ... ; Transfer control to e-Pharmacy
75 ... D ^IBCNRHLT Q
76 .. ;
77 .. ; Transfer control on other segments
78 .. I ",ZCM,ZP0,ZPB,ZPL,ZPT,ZRX,"[(","_SEG_",") D ^IBCNRHLT
79 . ;
80 . ;
81 . I APP="IIV" D
82 .. I SEG="MFI" D
83 ... S FILE=$G(IBSEG(2))
84 ... S FLN=$P(FILE,$E(HLECH,1),1)
85 .. ;
86 .. I SEG="MFE" D
87 ... I $G(FLN)="" S ERFLG=1,MSG(1)="File Number not found in MFN message" Q
88 ... I '$$VFILE^DILFD(FLN) S ERFLG=1,MSG(1)="File "_FLN_" not found in the Data Dictionary" Q
89 ... ;
90 ... I FLN'=365.12 D Q
91 .... S DATA=$G(IBSEG(5))
92 .... S ID=$$DECHL7^IBCNEHL2($P(DATA,$E(HLECH,1),1)),DESC=$$DECHL7^IBCNEHL2($P(DATA,$E(HLECH,1),2))
93 .... D TFIL
94 ... ;
95 ... ; Pull the action code
96 ... S IBCNACT=$G(IBSEG(2))
97 ... ; Effective Date
98 ... S IBCNADT=$G(IBSEG(4))
99 .. ;
100 .. I SEG="ZP0" D
101 ... S ID=$$DECHL7^IBCNEHL2(IBSEG(3)),NEWID=$$DECHL7^IBCNEHL2(IBSEG(4))
102 ... S DESC=$$DECHL7^IBCNEHL2(IBSEG(5)),HEDI=$$DECHL7^IBCNEHL2(IBSEG(6)),PEDI=$$DECHL7^IBCNEHL2(IBSEG(7))
103 .. ;
104 .. I SEG="ZPA" D
105 ... S STAT=IBSEG(4),STAT=$S(STAT="Y":"Active",1:"Not Active")
106 ... S TSSN=IBSEG(5),USSN=IBSEG(6),REQSUB=IBSEG(7)
107 ... S FSVDY=IBSEG(8),PSVDY=IBSEG(9)
108 ... D PFIL
109 Q
110 ;
111PFIL ; Payer Table Filer
112 ; Set the action:
113 ; MAD=Add, MUP=Update, MDC=Deactivate, MAC=Reactivate
114 S IBCNADT=$$FMDATE^HLFNC(IBCNADT)
115 I IBCNADT="" S IBCNADT=$$NOW^XLFDT()
116 ; If the action is MAD - Add the payer as new
117 N IBNOK,IBAPP,IBID,IBDESC,IBSTR
118 S IBNOK=0,IBAPP=($TR(APP," ")="")
119 I IBCNACT="MAD" D I IBNOK G PFILX
120 . ; Check certain required fields: Application, VA National & Payer Name
121 . ; If not populated, send MailMan message.
122 . S IBID=($TR(ID," ")=""),IBDESC=($TR(DESC," ")="")
123 . S IBNOK=IBAPP!IBID!IBDESC
124 . I 'IBNOK D MAD(DESC) Q
125 . S IBSTR="" I IBAPP S IBSTR="Application"
126 . I IBID S:IBSTR]"" IBSTR=IBSTR_", " S IBSTR=IBSTR_"VA National"
127 . I IBDESC S:IBSTR]"" IBSTR=IBSTR_", " S IBSTR=IBSTR_"Payer Name"
128 . S MSG(1)="MAD action received. "_IBSTR_" unknown."
129 I IBCNACT'="MAD" D FND
130 N IBCNTYPE
131 I IEN<1!IBAPP D G PFILX
132 . S IBCNTYPE=$S(IBCNACT="MAD":"Add",IBCNACT="MUP":"Update",IBCNACT="MDC":"Deactivate",IBCNACT="MAC":"Reactivate",1:"Unknown")
133 . S MSG(1)=IBCNTYPE_" ("_IBCNACT_") action received. Payer and/or Application may be unknown."
134 . S MSG(2)=""
135 . S MSG(3)="VA National : "_ID
136 . S MSG(4)="Payer Name : "_DESC
137 . S MSG(5)="Application : "_APP
138 . S MSG(6)=""
139 . S MSG(7)="Log a Remedy Ticket for this issue."
140 . S MSG(8)=""
141 . S MSG(9)="Please include in the Remedy Ticket that VISTA did not receive the required"
142 . S MSG(10)="information or the accurate information to add/update this Payer."
143 . D MSG^IBCNEUT5($$MGRP^IBCNEUT5(),"IIV payer tables may be out of synch with master list","MSG(")
144 ;
145 S DESC=$E(DESC,1,80) ;restriction of the field in the DD
146 S DIC=$$ROOT^DILFD(FLN)
147 S DR=".01///^S X=DESC;.02////^S X=NEWID;.05////^S X=PEDI;.06////^S X=HEDI"
148 ;
149 ; If new payer, add the Date/Time created
150 I NPFLG S DR=DR_";.04///^S X=$$NOW^XLFDT()"
151 S DIE=DIC,DA=IEN D ^DIE
152 ;
153 ; Check for application
154 S DIC="^IBE(365.13,",DIC(0)="X",X=APP D ^DIC
155 S AIEN=+Y I AIEN<1 D
156 . S DLAYGO=365.13,DIC(0)="L",DIC("P")=DLAYGO
157 . S DIE=DIC,X=APP
158 . K DD,DO
159 . D FILE^DICN
160 . K DO
161 . S AIEN=+Y
162 ;
163 S APIEN=$O(^IBE(365.12,IEN,1,"B",AIEN,""))
164 I APIEN="" D
165 . S DLAYGO=365.121,DIC(0)="L",DIC("P")=DLAYGO,DA(1)=IEN,X=AIEN
166 . S DIC="^IBE(365.12,"_DA(1)_",1,",DIE=DIC
167 . I '$D(^IBE(365.12,IEN,1,0)) S ^IBE(365.12,IEN,1,0)="^365.121P^^"
168 . K DD,DO
169 . D FILE^DICN
170 . K DO
171 . S APIEN=+Y,NAFLG=1
172 ;
173 I $G(STAT)="" S STAT=$P(^IBE(365.12,IEN,1,APIEN,0),U,2)
174 ;
175 S DA(1)=IEN,DA=APIEN,DIC="^IBE(365.12,"_DA(1)_",1,",DR=""
176 ;
177 I IBCNACT="MDC" S DR=DR_".11///^S X=1;.12////^S X=IBCNADT;",STAT=0
178 I IBCNACT="MAC" S DR=DR_".11///^S X=0;.12///@;"
179 S DR=DR_".02///^S X=STAT;.06///^S X=$$NOW^XLFDT()"
180 I IBCNACT'="MDC" S DR=DR_";.08///^S X=REQSUB;.09///^S X=USSN;.1///^S X=TSSN;.14///^S X=FSVDY;.15///^S X=PSVDY"
181 ;
182 ; If new application, add the Date/Time created
183 I NAFLG S DR=DR_";.13///^S X=$$NOW^XLFDT()"
184 ;
185 S DIE=DIC D ^DIE
186 I IBCNACT="MDC" D MDC Q
187PFILX ;
188 Q
189 ;
190TFIL ; Non Payer Tables Filer
191 NEW DIC,DIE,X,DA,DLAYGO,Y,DR,IEN
192 S DIC(0)="X",X=ID,DIC=$$ROOT^DILFD(FLN)
193 D ^DIC S IEN=+Y
194 ;
195 S DESC=$E(DESC,1,80) ;restriction of the field in the DD
196 ;
197 ; If no matching entry found, add it to table
198 I IEN<1 D
199 . S DLAYGO=FLN,DIC(0)="L",DIC("P")=DLAYGO,DIE=DIC
200 . K DD,DO
201 . D FILE^DICN S IEN=+Y
202 . K DO
203 ;
204 S DR=".02///^S X=DESC",DA=IEN,DIE=DIC D ^DIE
205 Q
206 ;
207MAD(X) ; Add an entry
208 D FND
209 I IEN>0 G MADX
210 NEW DIC,DIE,DA,DLAYGO,Y,DR
211 S DIC=$$ROOT^DILFD(FLN)
212 S DLAYGO=FLN,DIC(0)="L",DIC("P")=DLAYGO,DIE=DIC
213 K DD,DO
214 D FILE^DICN
215 K DO
216 S IEN=+Y,NPFLG=1
217MADX ;
218 Q
219 ;
220FND ; Find an existing Payer entry
221 NEW DIC,DIE,X,DA,DLAYGO,Y,DR
222 S X=ID,DIC(0)="X",D="C",DIC=$$ROOT^DILFD(FLN)
223 ;
224 ; Do a lookup with the "C" cross-reference
225 D IX^DIC
226 S IEN=+Y
227 Q
228 ;
229MDC ; Check for active transmissions and cancel
230 NEW STA,HIEN,RIEN,TQIEN
231 F STA=1,2,4,6 S TQIEN="" D
232 . F S TQIEN=$O(^IBCN(365.1,"AC",STA,TQIEN)) Q:TQIEN="" D
233 .. ;
234 .. ; If the record doesn't match the payer, quit
235 .. I $P(^IBCN(365.1,TQIEN,0),U,3)'=IEN Q
236 .. ;
237 .. ; Set the status to 'Cancelled'
238 .. D SST^IBCNEUT2(TQIEN,7)
239 .. ;
240 .. ; If a buffer entry, set to ! (bang)
241 .. S BUFF=$P(^IBCN(365.1,TQIEN,0),U,5)
242 .. I BUFF'="" D BUFF^IBCNEUT2(BUFF,17)
243 .. ;
244 .. ; Change any responses status also
245 .. S HIEN=0 F S HIEN=$O(^IBCN(365.1,TQIEN,2,HIEN)) Q:'HIEN D
246 ... S RIEN=$P(^IBCN(365.1,TQIEN,2,HIEN,0),U,3)
247 ... ; If the Response status is 'Response Received', don't change it
248 ... I $P(^IBCN(365,RIEN,0),U,6)=3 Q
249 ... D RSP^IBCNEUT2(RIEN,7)
250 Q
Note: See TracBrowser for help on using the repository browser.