source: WorldVistAEHR/trunk/r/E_CLAIMS_MGMT_ENGINE-BPS/BPSJHLT.m@ 1006

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

initial load of WorldVistAEHR

File size: 7.9 KB
Line 
1BPSJHLT ;BHAM ISC/LJF - HL7 Process Incoming MFN Messages ;05-NOV-2003
2 ;;1.0;E CLAIMS MGMT ENGINE;**1**;JUN 2004
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 ;
9 ; Direct entry not allowed
10 Q
11 ;
12PKY(PKYNM,PKYROOT,ADD) ;Lookup ien or add using PKYNM
13 N DA,DO,DIC,DIE,DINUM,DLAYGO,DTOUT,DUOUT,Y,X
14 I $G(PKYNM)]"",$G(PKYROOT)]"" S ADD=+$G(ADD)
15 E Q 0
16 S X=PKYNM,DIC=PKYROOT
17 I 'ADD S DIC(0)="X" D ^DIC
18 I ADD S DIC(0)="L",DLAYGO=PKYROOT D FILE^DICN
19 Q +Y
20 ;
21EN(HL) ; Entry Point
22 ;
23 N BPSJACT,BPSJPKY,BPSJADT,BPSZPRER,BPSJROOT,PSIEN,APPACK
24 N ZPRS,BPSJSEG,HCT,ERRFLAG,NAFLG,NPFLG,SEG,MSG,MCT,FLN,FILE
25 N RBSTART,RBEND,RBCNT,ZPSNNAME,ZPRCNT,BPSETID,RCODE,MAXRX
26 N FS,CS,PSHTVER,NCPDPVER,NCPDPCK,BPSFILE,BPSJCNT,BPSJDEVN
27 N BPSJPROD,BPSJNAME,DIK,TCH
28 ;
29 S FS=$G(HL("FS")) I FS="" S FS="|" ; field separator
30 S CS=$E($G(HL("ECH"))) I CS="" S CS="^" ; component separator
31 ;
32 K ^TMP($J,"BPSJ-RBACK"),^TMP($J,"BPSJ-ERROR")
33 ;
34 D INITZPRS^BPSJZPR(.ZPRS)
35 S BPSFILE=9002313.92,BPSJROOT=$$ROOT^DILFD(BPSFILE)
36 S RBSTART=100,RBEND=230,NCPDPCK="51"
37 S (ZPSNNAME,BPSJPROD,NCPDPVER,BPSJACT,BPSJADT,BPSJPKY)=""
38 ;
39 ; Initialize some Application Acknowledgement data
40 D DGAPPACK^BPSJACK
41 S APPACK("MSA",1)="AE" ; Assume error
42 S APPACK("MSA",2)=$G(HL("MID")) ; Message ID
43 S APPACK("MFA",4,1)="U" ; Set flag type of "unsuccessful event"
44 S APPACK("MFA",6)="ST"
45 S APPACK("MFI",6)="NE"
46 ;
47 ; Init encoding char array
48 S TCH("\F\")="|",TCH("\R\")="~"
49 S TCH("\E\")="\",TCH("\T\")="&"
50 ;
51 S HCT=1,(MCT,NAFLG,NPFLG,ERRFLAG,ZPRCNT,MAXRX)=0
52 F D Q:'HCT I ERRFLAG Q
53 . K BPSJSEG S HCT=$O(^TMP($J,"BPSJHLI",HCT))
54 . D SPAR^BPSJUTL(.HL,.BPSJSEG,HCT) S SEG=$G(BPSJSEG(1))
55 . ;
56 . ; ; payer sheet detail (multiple)
57 . I SEG="ZPR" D Q ; Record #5+ (MSH is record #1)
58 .. ;
59 .. I ERRFLAG Q ; Fatal Error
60 .. S ZPRCNT=ZPRCNT+1,BPSETID=$G(BPSJSEG(2))
61 .. ;-If not numeric equivalent the warp engines are offline, Captain
62 .. I BPSETID'=ZPRCNT D FAKEREC(ZPRCNT)
63 .. D EN^BPSJZPR(PSIEN,.BPSJSEG,BPSJROOT,BPSFILE)
64 . ;
65 . I SEG="MFI" D Q ; Record #2
66 .. ;
67 .. ;-Required Field checks
68 .. D ERRMSG(0,"MFI","1,2,3",.BPSJSEG)
69 .. ;
70 .. S APPACK("MFI",1,1)=$P($G(BPSJSEG(2)),CS)
71 .. S APPACK("MFI",1,2)=$P($G(BPSJSEG(2)),CS,2)
72 .. I APPACK("MFI",1,1)]"",APPACK("MFI",1,2)]""
73 .. E D
74 ... ; hard code these for Version 1.0 of s/w
75 ... D FILE^DID(BPSFILE,,"NAME","BPSJNAME")
76 ... I APPACK("MFI",1,1)="" S APPACK("MFI",1,1)=BPSFILE
77 ... I APPACK("MFI",1,2)="" S APPACK("MFI",1,2)=$G(BPSJNAME("NAME"))
78 ... K BPSJNAME
79 ... ;
80 .. S APPACK("MFI",3)=$G(BPSJSEG(4))
81 . ;
82 . I SEG="MFE" D Q ; Record #3
83 .. ;
84 .. ;-Required Field checks
85 .. D ERRMSG(0,"MFE","1,2,4,5",.BPSJSEG)
86 .. ;
87 .. S BPSJADT=$$NOW^XLFDT()
88 .. S (BPSJACT,APPACK("MFA",1))=$G(BPSJSEG(2)) ; Action type
89 .. I $L(BPSJACT)=3,"^MAD^MUP^MDC^"[(U_BPSJACT_U)
90 .. E D ERRMSG(1,"MFE","1^INVALID EVENT CODE")
91 .. ;
92 .. S APPACK("MFA",2)=$G(BPSJSEG(3)) ; MFN Control ID
93 .. ;
94 .. ; Old/Current Sheet name
95 .. S (BPSJPKY,APPACK("MFA",5))=$G(BPSJSEG(5))
96 .. S APPACK("MFA",4,2)="Payer Sheet "_BPSJPKY
97 .. S BPSJPKY=$$DECODE^BPSJZPR(BPSJPKY,.TCH)
98 .. ;
99 .. ;-Get ien using sheet name, if one exists
100 .. S PSIEN=$$PKY(BPSJPKY,BPSJROOT)
101 .. ;
102 .. I PSIEN=0 D ERRMSG(91,"Fileman error") Q
103 .. ;
104 .. I PSIEN>0 D ; Exists: save current data for rollback
105 ... S APPACK("MFA",4,1)="P" ;Set flag type to "P"rior version
106 ... M ^TMP($J,"BPSJ-RBACK",PSIEN)=^BPSF(9002313.92,PSIEN)
107 ... ;-Kill appropriate existing Payer Sheet fields
108 ... F RBCNT=RBSTART:10:RBEND K ^BPSF(9002313.92,PSIEN,RBCNT)
109 .. ;
110 .. ;-Create development sheet
111 .. I PSIEN<0 S BPSJCNT=0 F S BPSJCNT=1+BPSJCNT D Q:PSIEN>0
112 ... S BPSJDEVN="BPSJ-DEV-"_$J_"-"_BPSJCNT
113 ... S PSIEN=$$PKY(BPSJDEVN,BPSJROOT) ; see if dev sheet exists
114 ... I PSIEN>-1 S PSIEN=0 Q
115 ... S PSIEN=$$PKY(BPSJDEVN,BPSJROOT,1) ; add new one
116 .. ;
117 .. I PSIEN=0 D ERRMSG(92,"Fileman error") Q
118 .. ;
119 .. ;-Flag the sheet as being in development by this process
120 .. K DA,DIE,DR S DA=PSIEN,DIE=BPSJROOT
121 .. S DR="1.06////1."_$J ;FOR DEVELOPMENT
122 .. D ^DIE
123 . ;
124 . ;payer sheet header
125 . I SEG="ZPS" D Q ; Record #4
126 .. ;
127 .. ;-Required Field checks
128 .. D ERRMSG(0,"ZPS","1,2,3,4,5,6,7",.BPSJSEG)
129 .. ;
130 .. ;-New sheet name, production status and Payer Sheet and NCPDP versions
131 .. S ZPSNNAME=$$DECODE^BPSJZPR($G(BPSJSEG(4)),.TCH) K TCH
132 .. I ZPSNNAME="" S ZPSNNAME=$G(BPSJPKY)
133 .. S BPSJPROD=$G(BPSJSEG(8)) I BPSJPROD'="P" S BPSJPROD="T"
134 .. S PSHTVER=$G(BPSJSEG(5)) I PSHTVER'=(PSHTVER\1) S ^TMP($J,"BPSJ-ERROR","ZPS",4)=""
135 .. S NCPDPVER=$G(BPSJSEG(6)) I NCPDPVER'=NCPDPCK S ^TMP($J,"BPSJ-ERROR","ZPS",5)=""
136 ;
137 I '$D(^TMP($J,"BPSJ-ERROR")) D
138 . S APPACK("MFA",4,1)="S" ; flag success
139 . S DR=".01////"_ZPSNNAME ; set the name
140 . S DA=PSIEN,DIE=BPSJROOT D ^DIE
141 . ;
142 . I BPSJACT="MDC" S BPSJACT=0 ;Disabled
143 . E D I 'BPSJACT S BPSJACT=0
144 .. I BPSJPROD="P" S BPSJACT=3 ;Production
145 .. I BPSJPROD="T" S BPSJACT=2 ;Testing
146 . S DR="1.06////"_BPSJACT,DA=PSIEN,DIE=BPSJROOT D ^DIE
147 . ; NCPDP Version
148 . S DR="1.02////"_NCPDPVER,DA=PSIEN,DIE=BPSJROOT D ^DIE
149 . ; Payer Sheet Version
150 . S DR="1.14////"_PSHTVER,DA=PSIEN,DIE=BPSJROOT D ^DIE
151 . ;
152 . I BPSJACT=2 D SETTEST(ZPSNNAME,PSIEN)
153 . ;
154 E I $G(PSIEN) D ;-Roll back
155 . ;-Remove if no prior existence
156 . I $G(^TMP($J,"BPSJ-RBACK",PSIEN,0))="" D Q
157 .. S DIK=BPSJROOT,DA=PSIEN D ^DIK
158 . ;
159 . ; Restore old data
160 . S ^BPSF(9002313.92,PSIEN,0)=$G(^TMP($J,"BPSJ-RBACK",PSIEN,0))
161 . S ^BPSF(9002313.92,PSIEN,1)=$G(^TMP($J,"BPSJ-RBACK",PSIEN,1))
162 . F RBCNT=RBSTART:10:RBEND D
163 .. K ^BPSF(9002313.92,PSIEN,RBCNT)
164 .. M ^BPSF(9002313.92,PSIEN,RBCNT)=^TMP($J,"BPSJ-RBACK",PSIEN,RBCNT)
165 ;
166 D APPACK^BPSJACK(.HL,.APPACK,PSIEN)
167 ;
168 K ^TMP($J,"BPSJ-RBACK"),^TMP($J,"BPSJ-ERROR")
169 ;
170 Q
171 ;
172FAKEREC(REF) ; Setup a fake Record ID (Set ID)
173 N IX
174 ;
175 S REF=+$G(REF)
176 S IX=$G(BPSJSEG(2)),BPSJSEG(2)=REF
177 I IX="" D Q ; Missing
178 . S ^TMP($J,"BPSJ-ERROR","ZPR",REF,1)="V631-1,"_REF
179 ;
180 I IX=+IX,IX'=0
181 E D Q ; Invalid
182 . S ^TMP($J,"BPSJ-ERROR","ZPR",REF,1)="V631-2,"_REF
183 ;
184 ; We have a valid numeric to work with, but:
185 ;
186 ; Duplicate
187 I $G(^TMP($J,"BPSJ-ERROR","ZPR",IX))=IX D Q
188 . S ^TMP($J,"BPSJ-ERROR","ZPR",REF,1)="V631-4,"_REF
189 ;
190 ; Out Of Sequence
191 S ^TMP($J,"BPSJ-ERROR","ZPR",REF,1)="V631-3,"_REF
192 S ^TMP($J,"BPSJ-ERROR","ZPR",REF)=IX
193 ;
194 Q
195 ;
196ERRMSG(SPECIAL,SEG,REQFLDS,BPSJSEG) ;
197 N FCNT,FNO,FIELD,C
198 S C=",",SPECIAL=+$G(SPECIAL),SEG=$G(SEG),REQFLDS=$G(REQFLDS)
199 I 'SPECIAL D Q
200 . ;-Evaluate required fields for non ZPR segs
201 . S FNO=$J(REQFLDS,C)
202 . F FCNT=1:1:FNO S FIELD=$P(REQFLDS,C,FCNT) I FIELD D
203 .. ;-Set flag for empty required field
204 .. I $G(BPSJSEG(FIELD+1))="" S ^TMP($J,"BPSJ-ERROR",SEG,FIELD)=""
205 ;
206 ;-"Special" handler
207 I SPECIAL=1 D Q
208 . ;-Set flag that field contains invalid value
209 . S ^TMP($J,"BPSJ-ERROR",SEG,+REQFLDS)=REQFLDS
210 ;
211 I SPECIAL>90 S ERRFLAG=1
212 Q
213 ;
214SETTEST(TESTNAME,TESTIX) ; Test payer sheet handler
215 ; Massage to look like production version
216 ;
217 N PRODNM,PCNT,PRODIX,PRODDATA,TESTDATA,REVERSE
218 ;
219 I '$G(TESTIX) Q
220 ; Derive production version name
221 ; if test version name = ABCDE-001 then Prod version name = ABCDE
222 S PCNT=$L($G(TESTNAME),"-")-1 I PCNT<1 Q
223 S PRODNM=$P(TESTNAME,"-",1,PCNT)
224 ; Find Production version & get data if exists
225 S PRODIX=$O(^BPSF(9002313.92,"B",PRODNM,"")) I 'PRODIX Q
226 S PRODDATA=$G(^BPSF(9002313.92,PRODIX,1)) I PRODDATA="" Q
227 ; Get this test version's data
228 S TESTDATA=$G(^BPSF(9002313.92,TESTIX,1))
229 ; load test fields from production
230 S $P(TESTDATA,U,3)=$P(PRODDATA,U,3) ;Maximum RX's Per Claim
231 S $P(TESTDATA,U,7)=$P(PRODDATA,U,7) ;Is A Reversal Format
232 S $P(TESTDATA,U,13)=$P(PRODDATA,U,13) ;SOFTWARE VENDOR/CERT ID
233 S ^BPSF(9002313.92,TESTIX,1)=TESTDATA
234 ; Get Reversal Format pointer
235 S REVERSE=$G(^BPSF(9002313.92,PRODIX,"REVERSAL"))
236 ; Set test sheet to itself if production sheet points to itself.
237 I REVERSE=PRODIX S REVERSE=TESTIX
238 S ^BPSF(9002313.92,TESTIX,"REVERSAL")=REVERSE
239 ;
240 Q
Note: See TracBrowser for help on using the repository browser.