source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCESRV.m@ 1608

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

initial load of FOIAVistA 6/30/08 version
File size: 9.1 KB
Line 
1IBCESRV ;ALB/TMP - Server interface to IB from Austin ;8/6/03 10:04am
2 ;;2.0;INTEGRATED BILLING;**137,181,196,232,296,320**;21-MAR-94
3 ;
4SERVER ; Entry point for server option to process EDI msgs received from Austin
5 ;
6 N IBEFLG,IBERR,IBTDA,XMER,IBXMZ,IBHOLDCT
7 K ^TMP("IBERR",$J),^TMP("IBMSG",$J),^TMP("IBMSGH",$J),^TMP("IB-HOLD",$J),^TMP("IBMSG-H",$J)
8 S IBXMZ=$G(XMZ)
9 S IBEFLG=$$MSG(.XMER,.IBTDA,IBXMZ)
10 D:$G(IBEFLG) PERROR^IBCESRV1(.IBERR,.IBTDA,"G.IB EDI",IBXMZ)
11 N ZTREQ
12 D DKILL^IBCESRV1(IBXMZ) S ZTREQ="@"
13 K ^TMP("IBERR",$J),^TMP("IBMSG",$J),^TMP("IBMSGH",$J),^TMP("IB-HOLD",$J),^TMP("IBMSG-H",$J)
14 Q
15 ;
16MSG(XMER,IBTDA,IBXMZ) ; Read/Store message lines
17 ; Return message formats:
18 ; Ref: Your <queue name> message #<msg#> with Austin ID #<id #>,
19 ; is assigned confirmation number <confirmation #>.
20 ; Generates an 837REC0 message
21 ; 277STAT - claim status messages - Generates one or more 837REC1
22 ; 837REC2 or 837REJ1 messages
23 ; 837DEL - bill entry # from File 364
24 ; 835EOB - Explanation of Benefits messages
25 ; REPORT - Free text Envoy report file - may contain one or more
26 ; reports that are turned into bulletins
27 ;
28 ; OUTPUT:
29 ; Function returns flag ... 0 = no errors 1 = errors
30 ; IBTDA - array subscripted by ien of message file entries created
31 ; If array entry = 1, the message was only partially stored
32 ;
33 N IBLAST,IBTYP,IBTYP1,IB0,IBBTCH,IBDATE,IBHD,IBMG,IBRTN,IBTXN,IBTXND,XMDUZ,IBGBL,IBD,IBEFLG,IBHOLDCT,IBWANT,X,Y,Z
34 K ^TMP("IBERR",$J),^TMP("IBMSG",$J),^TMP("IBMSGH",$J),^TMP("IB-HOLD",$J)
35 ;
36 S (IBEFLG,IBERR,IBTXN)="",IBGBL="IBTXN",IBLAST=0
37 S IBD("MSG#")=IBXMZ
38 S IBHD=$$NET^XMRENT(IBXMZ)
39 S IBD("SUBJ")=$P(IBHD,U,6)
40 S (X,IBDATE)=$P(IBHD,U)
41 I X'="" D ;Reformat date, if needed
42 . I X'["@" S X=$P(X," ",1,3)_"@"_$P(X," ",4)
43 . N %DT
44 . S %DT="XTS" D ^%DT S:Y>0 IBDATE=Y\.0001*.0001
45 ;
46 K ^TMP("IB-HOLD",$J) N IBHOLDCT S IBHOLDCT=0
47 S IBD("Q")=$E(IBD("SUBJ"),1,3)
48 I $G(IBD("SUBJ"))?.E1(1" MCR",1" MCT",1" MCH")1" Confirmation" D G MSGQ:$G(IBERR),MSG1
49 . S IBD("Q")="MC"_$E($P(IBD("SUBJ")," MC",2))
50 . ;Austin confirmation
51 . X XMREC ; Line 1 of message
52 . S:XMER'<0 IBHOLDCT=IBHOLDCT+1,^TMP("IB-HOLD",$J,IBHOLDCT)=XMRG
53 . I XMER<0 D Q
54 .. S IBERR=3
55 .. S ^TMP("IBERR",$J,"MSG",1)=IBHD
56 .. S ^TMP("IBERR",$J,"MSG",2)=$G(XMRG)
57 . S IBTXN=XMRG
58 . S IBBTCH=+$O(^IBA(364.1,"MSG",+$P(IBTXN,"#",2)\1,""))
59 . I 'IBBTCH S IBERR=6 D REST(.IBTXN,IBGBL) Q ;No msgs match conf recpt
60 . S IBTXN("BATCH",IBBTCH,0)="837REC0^"_IBD("MSG#")_U_+$E($P(IBD("SUBJ")," "),4,14)_"^^"_IBBTCH_U_IBDATE
61 . ;
62 . X XMREC ;Get second line of the message
63 . I XMER<0 S IBERR=2 Q
64 . S IBTXN("BATCH",IBBTCH,1)=IBTXN_" "_XMRG_"$",IBTXN=IBTXN("BATCH",IBBTCH,0)
65 . S IBHOLDCT=IBHOLDCT+1,^TMP("IB-HOLD",$J,IBHOLDCT)=XMRG
66 . S IBLAST=1
67 ;
68 ; Read header line of non-confirmation message (line 1)
69 F X XMREC Q:$S(XMER<0:1,1:$E(XMRG,1,13)'="RACUBOTH RUCH")
70 S:XMER'<0 IBHOLDCT=IBHOLDCT+1,^TMP("IB-HOLD",$J,IBHOLDCT)=XMRG
71 I XMER<0 D G MSGQ
72 . S IBERR=3
73 . S ^TMP("IBERR",$J,"MSG",1)=IBHD
74 . S ^TMP("IBERR",$J,"MSG",2)=$G(XMRG)
75 ;
76 S IBTXN=XMRG
77MSG1 I $E(IBTXN,$L(IBTXN)-3,$L(IBTXN))?3A1"."!(IBTXN="NNNN"),IBHOLDCT>1 S XMER=-1,IBLAST=1 G MSGQ
78 ;
79 S IBTYP1=$S($P(IBTXN,U)="277STAT":"837REC1",1:$P(IBTXN,U))
80 S IBTYP=$S(IBTYP1="":"",1:$O(^IBE(364.3,"B",IBTYP1,"")))
81 I IBTYP="" S IBERR=1 D REST(.IBTXN,IBGBL) G MSGQ ;Bad msg type
82 ;
83 S IB0=$G(^IBE(364.3,IBTYP,0)),IBRTN=$P(IB0,U,3,4),IBMG=$P(IB0,U,2)
84 I $TR(IBRTN,U)="" S IBERR=5 D REST(.IBTXN,IBGBL) G MSGQ ;No routine defined
85 ;
86 S IBWANT=1
87 I 'IBLAST,XMER'<0 D G:IBLAST&(XMER<0) MSGQ ;Message is other than Austin confirmation
88 . S IBGBL="^TMP(""IBMSG"","_$J_")"
89 . S @IBGBL=$P(IBTXN,U),^TMP("IBMSGH",$J,0)=IBTXN
90 . ;
91 . I $P(IBTXN,U)="277STAT" D Q ;Claim status message
92 .. F X XMREC Q:XMER<0 D Q:IBLAST ;Extract rest of message
93 ... S IBHOLDCT=IBHOLDCT+1,^TMP("IB-HOLD",$J,IBHOLDCT)=XMRG
94 ... I +XMRG=99,$P(XMRG,U,2)="$" S IBLAST=1 Q
95 ... S IBD=XMRG,Z=+XMRG_"^IBCE277(.IBD)"
96 ... S IBTXN=XMRG
97 ... I '$$CKLABEL(Z,.IBTXN,IBGBL) S IBLAST=1,IBWANT=0,XMER=-1,IBERR=7 Q
98 ... D @Z
99 . ;
100 . I $P(IBTXN,U)="835EOB" D Q ;Explanation of Benefits message
101 .. F X XMREC Q:XMER<0 D Q:IBLAST ;Extract rest of message
102 ... S IBHOLDCT=IBHOLDCT+1,^TMP("IB-HOLD",$J,IBHOLDCT)=XMRG
103 ... I +XMRG=99,$P(XMRG,U,2)="$" S IBLAST=1 Q
104 ... S IBD=XMRG,Z=+XMRG_"^IBCE835(.IBD)"
105 ... S IBTXN=XMRG
106 ... I '$$CKLABEL(Z,.IBTXN,IBGBL) S IBLAST=1,IBWANT=0,XMER=-1,IBERR=7 Q
107 ... D @Z
108 . ;
109 . I $P(IBTXN,U)="REPORT" D Q ; Report file
110 .. D REPORT^IBCERPT(IBHD,IBDATE,.IBD,IBTXN)
111 .. I '$O(^TMP("IBMSG",$J,"REPORT",0,"D",0,0)) S IBWANT=0
112 . ;
113 . ; ****** Insert code for additional message types here and in ^IBCEM
114 ;
115 I IBLAST,IBWANT D ADD(IBGBL,.IBTDA,.IBERR)
116 ;
117 I 'IBLAST,'$G(IBERR) K @IBGBL S IBERR=2 ;No $ as last character of message
118MSGQ I $G(IBERR) D ERRUPD^IBCESRV1(IBGBL,.IBERR) S IBEFLG=1
119 Q IBEFLG
120 ;
121REST(IBTXN,IBGBL) ;Extract raw message data if not id-ed or can't process
122 N CT,Z
123 S CT=0
124 S Z=0 F S Z=$O(^TMP("IB-HOLD",$J,Z)) Q:'Z S CT=CT+1,@IBGBL@("BATCH",0,"D",0,CT)="##RAW DATA: "_$G(^TMP("IB-HOLD",$J,Z))
125 F X XMREC Q:XMER<0 S:XMRG'="" CT=CT+1,@IBGBL@("BATCH",0,"D",0,CT)="##RAW DATA: "_XMRG
126 Q
127 ;
128ADD(IBGBL,IBTDA,IBERR) ; Add message(s) in @IBGBL to file #364.2
129 ; Errors returned in IBERR
130 ; Message entry #'s are returned in IBTDA(ien)=""
131 ;
132 N IB,IBA,IBB,IBC,IBDATA,IBHDR,IBLINE,IBTYP,IBRTN
133 S IBA="" F S IBA=$O(@IBGBL@(IBA)) Q:IBA=""!(IBERR=3) S IBB="" F S IBB=$O(@IBGBL@(IBA,IBB)) Q:IBB=""!(IBERR=3) D
134 . S IBHDR=$G(@IBGBL@(IBA,IBB,0))
135 . Q:IBHDR=""
136 . S IBTYP=$S($P(IBHDR,U)="":"",1:$O(^IBE(364.3,"B",$P(IBHDR,U),""))),IBRTN=$P($G(^IBE(364.3,IBTYP,0)),U,3,4)
137 . S IBTDA=$$ADDTXN(IBHDR) ;File message hdr data
138 . I IBTDA'>0 S IBERR=3 Q ;msg hdr can't be filed
139 . S IBTDA(IBTDA)=""
140 . D LOADDET(IBA,IBB,.IBTDA,IBGBL,.IBERR,$P(IBHDR,U,1))
141 . Q:$G(IBERR) ;Message not completely filed
142 . D TRTN^IBCESRV1(IBTDA):$TR(IBRTN,U)'="" ;Task update to run
143 Q
144 ;
145ADDTXN(IBDATA,REPORT) ; Add a trxn for msg in IBDATA to file 364.2
146 ; REPORT = 1 if storing a report format message
147 ;Function returns ien of the new entry in file 364.2 or "" if an error
148 ;
149 N A,IBDA,IBBTCH,IBBILL,IBDT,IBTEST,DLAYGO,DIC,DD,DO,X,Y,Z,IBIFN
150 ;
151 S IBDA="",IBBTCH=$P(IBDATA,U,5),IBBILL=$P(IBDATA,U,4),IBIFN=0
152 I IBBILL S IBIFN=+$G(^IBA(364,IBBILL,0))
153 S IBDT=$P(IBDATA,U,6)
154 S IBTEST=0
155 I $E($G(IBD("Q")),1,3)="MCT" D
156 . I IBBILL,'$P($G(^IBA(364,IBBILL,0)),U,7),$D(^IBM(361.4,IBIFN,0)) S IBTEST=1 Q ; Resubmit live claim for test (make sure 361.4 exists)
157 . I IBBTCH,$O(^IBM(361.4,"C",IBBTCH,0)) S IBTEST=1 Q ; Resubmit live claim as test batch
158 ;
159 S (X,A)=$G(IBD("MSG#")) ; Use msg ID for .01 field
160 F Z=1:1 Q:'$D(^IBA(364.2,"B",A)) S A=X_"."_Z
161 S X=A
162 S DIC(0)="L",DIC="^IBA(364.2,",DLAYGO=364.2
163 S DIC("DR")=".02///"_$P(IBDATA,U)_";.03///^S X=""NOW"";.08////"_($P(IBDATA,U,7)="Y")_";.13////"_$P(IBDATA,U,8)_$S(IBBILL="":"",1:";.05////"_IBBILL)_";.06////P;.1////"_IBDT_$S(IBBTCH="":"",1:";.04////"_IBBTCH)_";.14////"_IBTEST
164 D FILE^DICN
165 S:Y>0 IBDA=+Y
166 ;
167 Q IBDA
168 ;
169LOADDET(IB1,IB2,IBTDA,IBGBL,IBERR,IBTNM) ; Load the rest of the message text into the message
170 ; IB1 = "BATCH" or "CLAIM" or "REPORT"
171 ; IB2 = batch # or claim # or 0
172 ; IBTDA = ien in file 364.2 being updated
173 ; IBGBL = name of the array holding the detail message text to be loaded
174 ; IBTNM = message name (i.e. "835EOB","837REC0","REPORT",etc.)
175 ;
176 ; OUTPUT: IBERR if any errors found, pass by reference
177 ; IBTDA(IBTDA)=1 if errors - pass by reference
178 ;
179 S IBTDA=+$G(IBTDA)
180 N CT,IB3,IBE,IBZ,Q
181 ;
182 K ^TMP("IBTEXT",$J)
183 ;
184 S (CT,IB3)=0 ;Put formatted data into msg
185 F S IB3=$O(@IBGBL@(IB1,IB2,IB3)) Q:'IB3 S CT=CT+1,^TMP("IBTEXT",$J,CT)=@IBGBL@(IB1,IB2,IB3)
186 ; Add identifying data from hdr record
187 S IB3=0 F S IB3=$O(^TMP("IBMSG-H",$J,IB1,IB2,IB3)) Q:'IB3 S CT=CT+1,^TMP("IBTEXT",$J,CT)=^TMP("IBMSG-H",$J,IB1,IB2,IB3)
188 ;
189 ; Put raw data into msg
190 I $G(IBTNM)'="835EOB" D
191 . S IBZ="" F S IBZ=$O(@IBGBL@(IB1,IB2,"D",IBZ)) Q:IBZ="" S IB3=0 F S IB3=$O(@IBGBL@(IB1,IB2,"D",IBZ,IB3)) Q:'IB3 S CT=CT+1,^TMP("IBTEXT",$J,CT)=@IBGBL@(IB1,IB2,"D",IBZ,IB3)
192 I $G(IBTNM)="835EOB" D
193 . S IB3=0 F S IB3=$O(@IBGBL@(IB1,IB2,"D1",IB3)) Q:'IB3 S IBZ="" F S IBZ=$O(@IBGBL@(IB1,IB2,"D1",IB3,IBZ)) Q:IBZ="" S CT=CT+1,^TMP("IBTEXT",$J,CT)=@IBGBL@(IB1,IB2,"D1",IB3,IBZ)
194 ;
195 D STOREM^IBCESRV2(IBTDA,"^TMP(""IBTEXT"",$J)",.IBE)
196 ;
197 I $D(IBE("DIERR")) D S:$L($G(IBE)) IBERR(IBTDA,IB1,IB2)=IBE ; Extract error
198 . D EXTERR^IBCESRV1(.IBERR,.IBTDA,.IBE)
199 K ^TMP("IBTEXT",$J)
200 Q
201 ;
202CKLABEL(Z,IBTXN,IBGBL) ; Checks to be sure label in Z exists.
203 ; If it doesn't exist, files an error and returns 0
204 ; OR returns 1 if it does exist
205 N X,LAB
206 S X=1,LAB=$P(Z,"(")
207 I $S('LAB!($L($P(LAB,U))>8):1,1:$T(@LAB)="") S X=0 D REST(.IBTXN,IBGBL)
208 Q X
209 ;
210ERROR ; Error condition messages
211 ;;Message code does not exist in IB MESSAGE ROUTER file (364.3).
212 ;;This message has no ending $.
213 ;;Message file problem - no message stored.
214 ;;Message file problem - message partially stored.
215 ;;Routine to process this message type does not exist.
216 ;;Batch does not exist for this confirmation message.
217 ;;Bad message format found - cannot store message.
218 ;
Note: See TracBrowser for help on using the repository browser.