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

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

initial load of WorldVistAEHR
File size: 9.5 KB
RevLine 
[613]1IBCE837 ;ALB/TMP - OUTPUT FOR 837 TRANSMISSION ;8/6/03 10:48am
2 ;;2.0;INTEGRATED BILLING;**137,191,197,232,296,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5EN ; Auto-txmt
6 N IBSITE8,IBRUN,X,X1,X2,DA,DIE,DR
7 K ^TMP("IBRESUBMIT",$J),^TMP("IBONE",$J)
8 S IBSITE8=$G(^IBE(350.9,1,8)),IBRUN=1
9 Q:'$P(IBSITE8,U,3)!'$P(IBSITE8,U,10)
10 I '$$MGCHK^IBCE(0) Q
11 I $P(IBSITE8,U,5) D Q:'IBRUN
12 . S X2=+$P(IBSITE8,U,3),X1=$P(IBSITE8,U,5) D C^%DTC
13 . I X>DT S IBRUN=0 Q
14 D QTXMT^IBCE837B(IBSITE8)
15 I $P(IBSITE8,U,5)'=DT S DIE="^IBE(350.9,",DR="8.05////"_DT,DA=1 D ^DIE
16 Q
17 ;
18SETUP(IBEXTRP) ; Txmn set up
19 ; IBEXTRP=1 prnt 837 data
20 N IB
21 K ^TMP("IBXMSG",$J),^TMP("IBTXMT",$J),^TMP("IBHDR",$J),^TMP("IBHDR1",$J),^TMP("IBXERR",$J),IBXERR,^TMP("IBXINS",$J),^TMP("IBTX",$J),^TMP("IBEDI_TEST_BATCH",$J)
22 ; Chk extract running
23 Q:$G(IBEXTRP)
24 ; Chk resubmit tst
25 I $P($G(^TMP("IBRESUBMIT",$J)),U,4) S ^TMP("IBEDI_TEST_BATCH",$J)=1 Q
26 I '$D(^TMP("IBRESUBMIT",$J)),'$D(^TMP("IBONE",$J)) D Q:$D(IBXERR)
27 . L +^IBA(364,0):5
28 . I '$T D Q
29 .. S IBXERR=1,^TMP("IBXERR",$J,1)="A PREVIOUS EDI EXTRACT IS RUNNING - ANOTHER CANNOT BE STARTED "_$$FMTE^XLFDT($$NOW^XLFDT(),2)
30 ;
31 I $D(^TMP("IBRESUBMIT",$J)) D Q:$D(IBXERR)
32 .N Z,Z0
33 .S Z0=$P($G(^TMP("IBRESUBMIT",$J)),U,2),Z=$$LOCK^IBCEM02(364.1,Z0)
34 .I 'Z D
35 ..S IBXERR=1
36 ..S ^TMP("IBRESUBMIT",$J,"IBXERR",1)="Another user is currently processing batch "_Z0_". Batch NOT resubmitted."
37 .I 'Z D
38 ..S IBXERR=1
39 ..S ^TMP("IBRESUBMIT",$J,"IBXERR",1)="Another user is currently processing batch "_Z0_". Batch NOT resubmitted."
40 ..S ^TMP("IBRESUBMIT",$J,"IBXERR",2)="Resubmit was attempted by: "_$P($G(^VA(200,DUZ,0)),U)_" ("_DUZ_")"
41 I $D(^TMP("IBONE",$J)) S IB=$G(^($J))+1 D Q:$D(IBXERR)
42 .N Z,Z0
43 .S Z0=$O(^TMP("IBONE",$J,"")),Z=$$LOCK^IBCEM02(364,Z0)
44 .I 'Z D
45 ..S IBXERR=1
46 ..S ^TMP("IBONE",$J,"IBXERR",1)="Another user is currently processing bill "_$P($G(^DGCR(399,+$G(^IBA(364,Z0,0)),0)),U)_". Bill NOT "_$P("^re",U,IB)_"submitted."
47 ..S ^TMP("IBONE",$J,"IBXERR",2)=$P("S^Res",U,IB)_"ubmit was attempted by: "_$P($G(^VA(200,DUZ,0)),U)_" ("_DUZ_")"
48 Q
49 ;
50FIND ; Find/sort by CMS-1500/UB-04, test/live, ins ID # & div
51 ;
52 N IBX,IB0,IBCBH,IBINS,IBXIEN,IBNID,IBGBL,IBTXTEST,IBBTYP,IB837R,IBDIV,IBNOTX,IBTXST,IBTEST,IBSEC
53 K ^TMP($J,"BILL"),^TMP("IBICT",$J)
54 ;
55 S IBGBL=$S($D(^TMP("IBONE",$J)):"^TMP(""IBONE"","_$J_")",$D(^TMP("IBSELX",$J)):"^TMP(""IBSELX"","_$J_")",'$D(^TMP("IBRESUBMIT",$J)):"^IBA(364,""ASTAT"",""X"")",1:"^TMP(""IBRESUBMIT"","_$J_")")
56 S IBTEST=+$G(^TMP("IBEDI_TEST_BATCH",$J))
57 ;
58 S IBX="" F S IBX=$O(@IBGBL@(IBX)) Q:'IBX D
59 .S IBXIEN=+$G(^IBA(364,IBX,0)),IB0=$G(^DGCR(399,IBXIEN,0))
60 .S IBTXST=$$TXMT^IBCEF4(IBXIEN,.IBNOTX)
61 .Q:IBTXST="" ; no txmt
62 .Q:$S(IB0="":1,$P(IB0,U,13)>4&'IBTEST:1,1:$D(^TMP($J,"BILL",$P(IB0,U))))
63 .S IBCBH=$P(IB0,U,21) S:"PST"'[IBCBH!(IBCBH="") IBCBH="P"
64 .S IBINS=$P($G(^DGCR(399,IBXIEN,"I"_($F("PST",IBCBH)-1))),U)
65 .S IBTXTEST=$S(IBTEST:2,1:+$$TEST^IBCEF4(IBXIEN))
66 .S IBBTYP=$P("P^I",U,($$FT^IBCEF(IBXIEN)=3)+1)_"-"_IBTXTEST
67 .Q:$$TESTPT^IBCEU($P(IB0,U,2))&'IBTXTEST ;Test pt
68 .;
69 .I IBTXTEST=1 D TESTLIM^IBCE837A(.IBINS)
70 .;
71 .I IBINS,$P(IB0,U,2) D
72 .. D SETVAR^IBCE837A(IBXIEN,IBINS,IB0,.IBSEC,.IBNID,.IB837R,.IBDIV)
73 ..S:'$D(^TMP("IBXINS",$J,IBDIV_U_IBBTYP,IBNID)) ^(IBNID)=IBINS S ^TMP("IBTXMT",$J,IBDIV_U_IBBTYP,IB837R_U_IBSEC,IBNID,$P(IB0,U,2),IBXIEN_U_IBX)=IBX
74 .;
75 .S ^TMP($J,"BILL",$P(IB0,U))=""
76 ;
77 I $D(^TMP("IBTXMT",$J)) S ^TMP("IBXDATA",$J)=IBNID
78 K ^TMP($J,"BILL")
79 Q
80 ;
81OUTPUT ; 837
82 ;
83 N IB837,IBSITE,IBMAX,IBQUEUE,IBTQUEUE,IBNID,IBCT,IBCTM,IBSIZE,IBBILL,IBLCNT,IBDFN,IBREF,IBSIZEM,IBPARMS,IBD,IBDESC,IBINS,IBQ,IB3,IBBTYP,IBTXTEST,IBDEFPRT,IB837R,IBBTYPX
84 ;
85 K ^TMP("IBCE-BATCH",$J)
86 S IBSITE=$G(^IBE(350.9,1,8)),IBMAX=$P(IBSITE,U,4),IB837=+$O(^IBE(353,"B","IB 837 TRANSMISSION",0)),IB837=$S($P($G(^IBE(353,+IB837,2)),U,8):$P(^(2),U,8),1:IB837) S:'IBMAX IBMAX=999
87 ;
88 I 'IB837 D Q
89 . N IBZ,XMBODY
90 . S XMBODY="IBZ"
91 . S IBZ(1)="The transmission form for sending electronic claims is not in your form file",IBZ(2)="NO CLAIMS WERE OUTPUT - FORM = IB 837 TRANSMISSION"
92 . D ERRMSG^IBCE837A(XMBODY)
93 ;
94 S (IBCT,IBCTM,IBSIZE)=0,IBQUEUE=$P(IBSITE,U),IBTQUEUE=$P(IBSITE,U,9),IBDESC=""
95 ;
96 Q:IBQUEUE=""&(IBTQUEUE="")
97 ;
98 S IBQ="",IBBTYPX=""
99 ; Sort: div_^_bill type_-_test stat,ins co transmission destination^sec status,dfn,claim #
100 F S IBBTYPX=$O(^TMP("IBTXMT",$J,IBBTYPX)),IBBTYP=$P(IBBTYPX,U,2) D:IBCTM CHKNEW^IBCE837A(IBQ,.IBBILL,.IBCTM,IBDESC,IBBTYP,"",IBSITE,.IBSIZE) Q:IBBTYPX="" D
101 . S IBDEFPRT=$S($E(IBBTYP)="P":"SPRINT",1:"SPRINT")
102 . S IBTXTEST=+$P(IBBTYP,"-",2),IBQ=$S('IBTXTEST:IBQUEUE,IBTXTEST=2:"MCT",1:IBTQUEUE)
103 . Q:IBQ="" ; Queue
104 . ;
105 . S IBD=$S($E(IBBTYP)="P":"PROF",1:"INST")_" CLAIMS-"_$$HTE^XLFDT($H,2)_" "
106 . S IBDESC=$S('$P(IBSITE,U,7):$S('IBTXTEST:"",1:"TEST ")_IBD,1:"")
107 . ;
108 . S IB837R=""
109 . F S IB837R=$O(^TMP("IBTXMT",$J,IBBTYPX,IB837R)) D:IBCTM CHKNEW^IBCE837A(IBQ,.IBBILL,.IBCTM,IBDESC,IBBTYP,"",IBSITE,.IBSIZE) Q:IB837R="" D
110 .. S (IBINS,IBNID)="",IBLCNT=0
111 .. F S IBNID=$O(^TMP("IBTXMT",$J,IBBTYPX,IB837R,IBNID)) K ^TMP("IBHDR1",$J) D:IBCTM CHKNEW^IBCE837A(IBQ,.IBBILL,.IBCTM,IBDESC,IBBTYP,IBINS,IBSITE,.IBSIZE) Q:IBNID="" D
112 ...;
113 ...S IBDFN=0,IBINS=+$G(^TMP("IBXINS",$J,IBBTYPX,IBNID))
114 ... ;
115 ...I $P(IBSITE,U,7) D ; 1 ins/batch
116 .... S IBLCNT=0
117 .... S IBDESC=$E($S('IBTXTEST:"",1:"TEST ")_IBD_$P($G(^DIC(36,IBINS,0)),U),1,80)
118 ... ;
119 ...F S IBDFN=$O(^TMP("IBTXMT",$J,IBBTYPX,IB837R,IBNID,IBDFN)) Q:'IBDFN S IBREF="" F S IBREF=$O(^TMP("IBTXMT",$J,IBBTYPX,IB837R,IBNID,IBDFN,IBREF)) Q:'IBREF D
120 ....I '(IBCTM#IBMAX),IBCTM D MAILIT^IBCE837A(IBQ,.IBBILL,.IBCTM,"",IBDESC,IBBTYP,IBINS) S IBSIZE=0 ;exceeds max #
121 ....D BILLPARM^IBCEFG0(+IBREF,.IBPARMS)
122 ....S IBSIZEM=$$EXTRACT^IBCEFG(IB837,+IBREF,1,.IBPARMS)
123 ....I (IBSIZEM+IBSIZE)>30000,IBSIZE D ; exceeds max size
124 .....D MAILIT^IBCE837A(IBQ,.IBBILL,.IBCTM,"",IBDESC,IBBTYP,IBINS) S IBSIZE=0 K ^TMP("IBXDATA",$J) S IBSIZEM=$$EXTRACT^IBCEFG(IB837,+IBREF,1,.IBPARMS)
125 ....I 'IBSIZEM D:'IBCTM Q
126 ..... D CHKBTCH^IBCE837A(+$G(^TMP("IBHDR",$J))) K ^TMP("IBHDR",$J)
127 ....S IBCT=IBCT+1,IBCTM=IBCTM+1
128 ....D:$D(^TMP("IBXDATA",$J)) MESSAGE(.IBLCNT,$P(IBREF,U,2),.IBBILL,.IBCTM,.IBSIZE,IBSIZEM,"",IBBTYP,IBINS)
129 ..;
130 ..I $G(IBTXTEST)=1 S IBINS=0 F S IBINS=$O(^TMP("IBICT",$J,IBINS)) Q:'IBINS S IB3=$G(^DIC(36,IBINS,3)) D
131 ... N DIE,DA,DR
132 ...S DIE="^DIC(36,",DA=IBINS,DR="3.05////"_DT_";3.07////"_($S($P(IB3,U,5)'=DT:0,1:$P(IB3,U,7))+^TMP("IBICT",$J,IBINS)) D ^DIE
133 ;
134 I $O(^TMP("IBXERR",$J,"")) D ;Error to mail grp
135 .N XMTO,XMBODY,XMDUZ,XMSUBJ,IBCT,IBERR
136 .K ^TMP("IBXMSG",$J)
137 .S ^TMP("IBXMSG",$J,1)="The following authorized bill(s) were not transmitted due to errors indicated.",^(2)="Once the errors are corrected, the bill(s) will be included in the next run.",^(3)=" "
138 .;
139 .S IBERR=0,IBCT=3
140 .F S IBERR=$O(^TMP("IBXERR",$J,IBERR)) Q:'IBERR S IBCT=IBCT+1,^TMP("IBXMSG",$J,IBCT)="Bill #: "_$P($G(^DGCR(399,IBERR,0)),U),IBCT=IBCT+1,^TMP("IBXMSG",$J,IBCT)=$J("",5)_^TMP("IBXERR",$J,IBERR)
141 .S XMBODY="^TMP(""IBXMSG"","_$J_")" D ERRMSG^IBCE837A(XMBODY)
142 .;
143 .K ^TMP("IBXMSG",$J),^TMP("IBICT",$J)
144 ;
145 I $O(^TMP("IBCE-BATCH",$J,"")) D
146 .N IB,IB0,IBL,IBT,IBX,XMTO,XMDUZ,XMSUBJ,IBRESUB,IBTESTB,XMZ
147 .S IBRESUB=$D(^TMP("IBRESUBMIT",$J))
148 .;
149 .S IBT(1)="The following batches were "_$S('IBRESUB:"",1:"re-")_"submitted to Austin "_$S(IBTXTEST'=2:"",1:"as TEST ")_$$HTE^XLFDT($H,"2D")_":"
150 .S IBT(2)=$S('IBRESUB:" ",1:" [Resubmitted by: "_$P($G(^VA(200,+DUZ,0)),U)_" (#"_DUZ_")]") S:IBRESUB IBT(3)=" "
151 .;
152 .S IBL=$S('IBRESUB:2,1:3),IB=""
153 .F S IB=$O(^TMP("IBCE-BATCH",$J,IB)) Q:IB="" S IBL=IBL+1,IB0=$G(^(IB)) D
154 .. S IBX=IB
155 .. I $P(IB0,U,3)'="",IBTXTEST=2 S IBX=$P(IB0,U,3)_" (AS BATCH "_IB_")"
156 ..S IBT(IBL)=" "_IBX_" "_$P($G(^IBA(364.1,+IB0,0)),U,8),IBL=IBL+1,IBT(IBL)=" ("_+$P(IB0,U,2)_" bills)"
157 .;
158 .S XMTO("I:G.IB EDI")="",XMDUZ="",XMBODY="IBT",XMSUBJ="EDI 837 "_$S('IBRESUB:"",1:"RE-")_"SUBMISSION BATCH LIST"_$S(IBTXTEST'=2:"",1:" FOR TEST")
159 .D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ)
160 .;
161 .S:IBRESUB ^TMP("IBRESUBMIT",$J,0)=1
162 Q
163 ;
164CLEANUP ; moved
165 D CLEANUP^IBCE837A
166 Q
167 ;
168MESSAGE(IBLCNT,IBIEN,IBBILL,IBCTM,IBSIZE,IBSIZEM,IBDUZ,IBBTYP,IBINS) ; Create msg in ^TMP("IBXMSG",$J)
169 ;IBLCNT = last msg line extracted
170 ;IBIEN = ien file 364 bill entry
171 ;IBBILL = array file 364 ien's of bills being sent
172 ; IBBILL(IEN)=""
173 ;IBSIZE = # bytes in msg
174 ;IBSIZEM = # bytes in record to be added to msg
175 ;IBCTM = # bills in batch
176 ;IBDUZ = user ien running extract (Postmaster if auto)
177 ;IBBTYP = x-y where x = P for prof, I for inst
178 ; y = 1 for test, 0 for live txmt
179 ;IBINS = ien of 1 ins co for batch
180 ;
181 N IB,IBL,IB1,IB2,IB3,IBQ,IBREC,IBDEL
182 S IBDEL=$O(^IBA(364.5,"B","N-SEGMENT DELIMITER","")),IBDEL=$P($G(^IBA(364.5,+IBDEL,0)),U,8) S:IBDEL="" IBDEL="~"
183 S IBSIZE=IBSIZE+IBSIZEM,IB1="",IBREC=""
184 F S IB1=$O(^TMP("IBXDATA",$J,1,IB1)) Q:IB1="" D
185 .S (IBREC,IB2)=""
186 .F S IB2=$O(^TMP("IBXDATA",$J,1,IB1,IB2)) Q:$S(IB2="":1,IB1=1:"",1:'$O(^(IB2,1))) D
187 ..S IB3="",IBREC=""
188 ..F S IB3=$O(^TMP("IBXDATA",$J,1,IB1,IB2,IB3)) D:IB3=""&($L(IBREC)) SETG Q:IB3="" S:$S(IB3=1:1,1:$P(IBREC,U)'="") $P(IBREC,U,IB3)=$$UP^XLFSTR(^TMP("IBXDATA",$J,1,IB1,IB2,IB3))
189 S IBBILL(IBIEN)=""
190 K ^TMP("IBXDATA",$J)
191 Q
192 ;
193SETHDR ; hdr for curr batch
194 S ^TMP("IBHDR",$J)=$G(^TMP("IBXDATA",$J,1,5,1,2))
195 Q
196 ;
197SETHDR1 ; hdr node for curr ins
198 S ^TMP("IBHDR1",$J)=$G(^TMP("IBXDATA",$J,1,20,1,8))
199 Q
200 ;
201SETG ; msg global for each segment
202 S IBREC=$TR(IBREC,IBDEL)
203 S IBREC=IBREC_IBDEL,IBSIZE=IBSIZE+$L(IBDEL)
204 S IBLCNT=IBLCNT+1,^TMP("IBXMSG",$J,IBLCNT)=IBREC
205 Q
206 ;
207ONE ; Txmt 1 or more bills for test or in 'X' status for live
208 Q:'$$MGCHK^IBCE(0)
209 D SETUP(0)
210 I '$D(IBXERR) D FIND,OUTPUT
211 D CLEANUP^IBCE837A
212 Q
213 ;
Note: See TracBrowser for help on using the repository browser.