IBCE837 ;ALB/TMP - OUTPUT FOR 837 TRANSMISSION ;8/6/03 10:48am
;;2.0;INTEGRATED BILLING;**137,191,197,232,296,349,547,592,623,641,718**;21-MAR-94;Build 73
;;Per VA Directive 6402, this routine should not be modified.
;
EN ; Auto-txmt
N IBSITE8,IBRUN,X,X1,X2,DA,DIE,DR
K ^TMP("IBRESUBMIT",$J),^TMP("IBONE",$J)
S IBSITE8=$G(^IBE(350.9,1,8)),IBRUN=1
Q:'$P(IBSITE8,U,3)!'$P(IBSITE8,U,10)
I '$$MGCHK^IBCE(0) Q
I $P(IBSITE8,U,5) D Q:'IBRUN
. S X2=+$P(IBSITE8,U,3),X1=$P(IBSITE8,U,5) D C^%DTC
. I X>DT S IBRUN=0 Q
D QTXMT^IBCE837B(IBSITE8)
I $P(IBSITE8,U,5)'=DT S DIE="^IBE(350.9,",DR="8.05////"_DT,DA=1 D ^DIE
Q
;
SETUP(IBEXTRP) ; Txmn set up
; IBEXTRP=1 prnt 837 data
N IB
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)
; Chk extract running
Q:$G(IBEXTRP)
; Chk resubmit tst
I $P($G(^TMP("IBRESUBMIT",$J)),U,4) S ^TMP("IBEDI_TEST_BATCH",$J)=1 Q
I '$D(^TMP("IBRESUBMIT",$J)),'$D(^TMP("IBONE",$J)) D Q:$D(IBXERR)
. L +^IBA(364,0):5
. I '$T D Q
.. S IBXERR=1,^TMP("IBXERR",$J,1)="A PREVIOUS EDI EXTRACT IS RUNNING - ANOTHER CANNOT BE STARTED "_$$FMTE^XLFDT($$NOW^XLFDT(),2)
;
I $D(^TMP("IBRESUBMIT",$J)) D Q:$D(IBXERR)
.;JWS;IB*2.0*641v6;issue with resubmit of claim, batch # not generated until submitted
.; ;in FHIR, transaction does not get transmitted immediately, so no need to check batch# lock
.I $$GET1^DIQ(350.9,"1,",8.21,"I") Q
.N Z,Z0
.S Z0=$P($G(^TMP("IBRESUBMIT",$J)),U,2),Z=$$LOCK^IBCEM02(364.1,Z0)
.I 'Z D
..S IBXERR=1
..S ^TMP("IBRESUBMIT",$J,"IBXERR",1)="Another user is currently processing batch "_Z0_". Batch NOT resubmitted."
.I 'Z D
..S IBXERR=1
..S ^TMP("IBRESUBMIT",$J,"IBXERR",1)="Another user is currently processing batch "_Z0_". Batch NOT resubmitted."
..S ^TMP("IBRESUBMIT",$J,"IBXERR",2)="Resubmit was attempted by: "_$P($G(^VA(200,DUZ,0)),U)_" ("_DUZ_")"
I $D(^TMP("IBONE",$J)) S IB=$G(^($J))+1 D Q:$D(IBXERR)
.N Z,Z0
.S Z0=$O(^TMP("IBONE",$J,"")),Z=$$LOCK^IBCEM02(364,Z0)
.I 'Z D
..S IBXERR=1
..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."
..S ^TMP("IBONE",$J,"IBXERR",2)=$P("S^Res",U,IB)_"ubmit was attempted by: "_$P($G(^VA(200,DUZ,0)),U)_" ("_DUZ_")"
Q
;
FIND ; Find/sort by CMS-1500/UB-04, test/live, ins ID # & div
;
N IBX,IB0,IBCBH,IBINS,IBXIEN,IBNID,IBGBL,IBTXTEST,IBBTYP,IB837R,IBDIV,IBNOTX,IBTXST,IBTEST,IBSEC,IBNF
K ^TMP($J,"BILL"),^TMP("IBICT",$J)
;
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_")")
S IBTEST=+$G(^TMP("IBEDI_TEST_BATCH",$J))
;
S IBX="" F S IBX=$O(@IBGBL@(IBX)) Q:'IBX D
.;IB 547, If resubmitting a locally printed claim to test via RCB, there is no entry in 364 yet, so pass the NEW flag
.;S IBXIEN=+$G(^IBA(364,IBX,0)),IB0=$G(^DGCR(399,IBXIEN,0))
.;S IBTXST=$$TXMT^IBCEF4(IBXIEN,.IBNOTX)
.S IBXIEN=+$G(^IBA(364,IBX,0)),IBNF=""
.I $G(IBLOC)=1,$G(IBTYPPTC)="TEST" S IBXIEN=IBX,IBNF=1
.S IB0=$G(^DGCR(399,IBXIEN,0))
.S IBTXST=$$TXMT^IBCEF4(IBXIEN,.IBNOTX,IBNF)
.Q:IBTXST="" ; no txmt
.Q:$S(IB0="":1,$P(IB0,U,13)>4&'IBTEST:1,1:$D(^TMP($J,"BILL",$P(IB0,U))))
.S IBCBH=$P(IB0,U,21) S:"PST"'[IBCBH!(IBCBH="") IBCBH="P"
.S IBINS=$P($G(^DGCR(399,IBXIEN,"I"_($F("PST",IBCBH)-1))),U)
.S IBTXTEST=$S(IBTEST:2,1:+$$TEST^IBCEF4(IBXIEN))
.;JWS:IB*2.0*592:US131 - EDI Dental Claim
.S IBBTYP=$P("P^I^D",U,$S($$FT^IBCEF(IBXIEN)=7:3,1:($$FT^IBCEF(IBXIEN)=3)+1))_"-"_IBTXTEST
.Q:$$TESTPT^IBCEU($P(IB0,U,2))&'IBTXTEST ;Test pt
.;
.I IBTXTEST=1 D TESTLIM^IBCE837A(.IBINS)
.;
.I IBINS,$P(IB0,U,2) D
.. D SETVAR^IBCE837A(IBXIEN,IBINS,IB0,.IBSEC,.IBNID,.IB837R,.IBDIV)
..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
.;
.S ^TMP($J,"BILL",$P(IB0,U))=""
;
I $D(^TMP("IBTXMT",$J)) S ^TMP("IBXDATA",$J)=IBNID
K ^TMP($J,"BILL")
Q
;
OUTPUT ; 837
;
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
;
K ^TMP("IBCE-BATCH",$J)
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
;
I 'IB837 D Q
. N IBZ,XMBODY
. S XMBODY="IBZ"
. 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"
. D ERRMSG^IBCE837A(XMBODY)
;
S (IBCT,IBCTM,IBSIZE)=0,IBQUEUE=$P(IBSITE,U),IBTQUEUE=$P(IBSITE,U,9),IBDESC=""
;
Q:IBQUEUE=""&(IBTQUEUE="")
;
S IBQ="",IBBTYPX=""
; Sort: div_^_bill type_-_test stat,ins co transmission destination^sec status,dfn,claim #
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
. S IBDEFPRT=$S($E(IBBTYP)="P":"SPRINT",1:"SPRINT")
. S IBTXTEST=+$P(IBBTYP,"-",2),IBQ=$S('IBTXTEST:IBQUEUE,IBTXTEST=2:"MCT",1:IBTQUEUE)
. Q:IBQ="" ; Queue
. ;
. ;JWS:IB*2.0*592:US131 - EDI Dental Claim
. S IBD=$S($E(IBBTYP)="P":"PROF",$E(IBBTYP)="D":"DENT",1:"INST")_" CLAIMS-"_$$HTE^XLFDT($H,2)_" "
. S IBDESC=$S('$P(IBSITE,U,7):$S('IBTXTEST:"",1:"TEST ")_IBD,1:"")
. ;
. S IB837R=""
. F S IB837R=$O(^TMP("IBTXMT",$J,IBBTYPX,IB837R)) D:IBCTM CHKNEW^IBCE837A(IBQ,.IBBILL,.IBCTM,IBDESC,IBBTYP,"",IBSITE,.IBSIZE) Q:IB837R="" D
.. S (IBINS,IBNID)="",IBLCNT=0
.. 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
...;
...S IBDFN=0,IBINS=+$G(^TMP("IBXINS",$J,IBBTYPX,IBNID))
... ;
...I $P(IBSITE,U,7) D ; 1 ins/batch
.... S IBLCNT=0
.... S IBDESC=$E($S('IBTXTEST:"",1:"TEST ")_IBD_$P($G(^DIC(36,IBINS,0)),U),1,80)
... ;
... 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
.... I '(IBCTM#IBMAX),IBCTM D MAILIT^IBCE837A(IBQ,.IBBILL,.IBCTM,"",IBDESC,IBBTYP,IBINS) S IBSIZE=0 ;exceeds max #
.... ;JWS;IB*2.0*623;begin;if 837 FHIR is on, just set flag to begin transmit
.... I $$GET1^DIQ(350.9,"1,",8.21,"I") D Q
..... ;JWS;IB*2.0*623v24;added resubmit flag parameter to SETCLM^IBCE837I call
..... D SETCLM^IBCE837I($P(IBREF,U,2),IBQ,$S($D(^TMP("IBRESUBMIT",$J,$P(IBREF,U,2))):1,1:0))
..... S IBCT=IBCT+1,IBCTM=IBCTM+1
..... Q
.... ;IB*2.0*623;end
.... D BILLPARM^IBCEFG0(+IBREF,.IBPARMS)
.... ; JWS;EBILL-2667;add 5th parameter to output formatter call to conditionally execute FSC workarounds post execute
.... S IBSIZEM=$$EXTRACT^IBCEFG(IB837,+IBREF,1,.IBPARMS,1)
.... I (IBSIZEM+IBSIZE)>30000,IBSIZE D ; exceeds max size
..... ; JWS;EBILL-2667;add 5th parameter to output formatter call to conditionally execute FSC workarounds post execute
..... D MAILIT^IBCE837A(IBQ,.IBBILL,.IBCTM,"",IBDESC,IBBTYP,IBINS) S IBSIZE=0 K ^TMP("IBXDATA",$J) S IBSIZEM=$$EXTRACT^IBCEFG(IB837,+IBREF,1,.IBPARMS,1)
.... I 'IBSIZEM D:'IBCTM Q
..... D CHKBTCH^IBCE837A(+$G(^TMP("IBHDR",$J))) K ^TMP("IBHDR",$J)
.... S IBCT=IBCT+1,IBCTM=IBCTM+1
.... D:$D(^TMP("IBXDATA",$J)) MESSAGE(.IBLCNT,$P(IBREF,U,2),.IBBILL,.IBCTM,.IBSIZE,IBSIZEM,"",IBBTYP,IBINS)
..;
.. 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
... N DIE,DA,DR
... 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
;
I $O(^TMP("IBXERR",$J,"")) D ;Error to mail grp
.N XMTO,XMBODY,XMDUZ,XMSUBJ,IBCT,IBERR
.K ^TMP("IBXMSG",$J)
.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)=" "
.;
.S IBERR=0,IBCT=3
.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)
.S XMBODY="^TMP(""IBXMSG"","_$J_")" D ERRMSG^IBCE837A(XMBODY)
.;
.K ^TMP("IBXMSG",$J),^TMP("IBICT",$J)
;
I $O(^TMP("IBCE-BATCH",$J,"")) D
.N IB,IB0,IBL,IBT,IBX,XMTO,XMDUZ,XMSUBJ,IBRESUB,IBTESTB,XMZ
.S IBRESUB=$D(^TMP("IBRESUBMIT",$J))
.;
.S IBT(1)="The following batches were "_$S('IBRESUB:"",1:"re-")_"submitted to Austin "_$S(IBTXTEST'=2:"",1:"as TEST ")_$$HTE^XLFDT($H,"2D")_":"
.S IBT(2)=$S('IBRESUB:" ",1:" [Resubmitted by: "_$P($G(^VA(200,+DUZ,0)),U)_" (#"_DUZ_")]") S:IBRESUB IBT(3)=" "
.;
.S IBL=$S('IBRESUB:2,1:3),IB=""
.F S IB=$O(^TMP("IBCE-BATCH",$J,IB)) Q:IB="" S IBL=IBL+1,IB0=$G(^(IB)) D
.. S IBX=IB
.. I $P(IB0,U,3)'="",IBTXTEST=2 S IBX=$P(IB0,U,3)_" (AS BATCH "_IB_")"
..S IBT(IBL)=" "_IBX_" "_$P($G(^IBA(364.1,+IB0,0)),U,8),IBL=IBL+1,IBT(IBL)=" ("_+$P(IB0,U,2)_" bills)"
.;
.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")
.D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ)
.;
.S:IBRESUB ^TMP("IBRESUBMIT",$J,0)=1
Q
;
CLEANUP ; moved
D CLEANUP^IBCE837A
Q
;
MESSAGE(IBLCNT,IBIEN,IBBILL,IBCTM,IBSIZE,IBSIZEM,IBDUZ,IBBTYP,IBINS) ; Create msg in ^TMP("IBXMSG",$J)
;IBLCNT = last msg line extracted
;IBIEN = ien file 364 bill entry
;IBBILL = array file 364 ien's of bills being sent
; IBBILL(IEN)=""
;IBSIZE = # bytes in msg
;IBSIZEM = # bytes in record to be added to msg
;IBCTM = # bills in batch
;IBDUZ = user ien running extract (Postmaster if auto)
;IBBTYP = x-y where x = P for prof, I for inst, D for dental ;JWS:IB*2.0*592:US131 - EDI Dental Claim
; y = 1 for test, 0 for live txmt
;IBINS = ien of 1 ins co for batch
;
N IB,IBL,IB1,IB2,IB3,IBQ,IBREC,IBDEL
S IBDEL=$O(^IBA(364.5,"B","N-SEGMENT DELIMITER","")),IBDEL=$P($G(^IBA(364.5,+IBDEL,0)),U,8) S:IBDEL="" IBDEL="~"
S IBSIZE=IBSIZE+IBSIZEM,IB1="",IBREC=""
F S IB1=$O(^TMP("IBXDATA",$J,1,IB1)) Q:IB1="" D
.S (IBREC,IB2)=""
.F S IB2=$O(^TMP("IBXDATA",$J,1,IB1,IB2)) Q:$S(IB2="":1,IB1=1:"",1:'$O(^(IB2,1))) D
..S IB3="",IBREC=""
..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))
S IBBILL(IBIEN)=""
K ^TMP("IBXDATA",$J)
Q
;
SETHDR ; hdr for curr batch
S ^TMP("IBHDR",$J)=$G(^TMP("IBXDATA",$J,1,5,1,2))
Q
;
SETHDR1 ; hdr node for curr ins
S ^TMP("IBHDR1",$J)=$G(^TMP("IBXDATA",$J,1,20,1,8))
Q
;
SETG ; msg global for each segment
S IBREC=$TR(IBREC,IBDEL)
S IBREC=IBREC_IBDEL,IBSIZE=IBSIZE+$L(IBDEL)
S IBLCNT=IBLCNT+1,^TMP("IBXMSG",$J,IBLCNT)=IBREC
Q
;
ONE ; Txmt 1 or more bills for test or in 'X' status for live
Q:'$$MGCHK^IBCE(0)
D SETUP(0)
I '$D(IBXERR) D FIND,OUTPUT
D CLEANUP^IBCE837A
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCE837 11349 printed Apr 09, 2024@21:09:48 Page 2
IBCE837 ;ALB/TMP - OUTPUT FOR 837 TRANSMISSION ;8/6/03 10:48am
+1 ;;2.0;INTEGRATED BILLING;**137,191,197,232,296,349,547,592,623,641,718**;21-MAR-94;Build 73
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ; Auto-txmt
+1 NEW IBSITE8,IBRUN,X,X1,X2,DA,DIE,DR
+2 KILL ^TMP("IBRESUBMIT",$JOB),^TMP("IBONE",$JOB)
+3 SET IBSITE8=$GET(^IBE(350.9,1,8))
SET IBRUN=1
+4 if '$PIECE(IBSITE8,U,3)!'$PIECE(IBSITE8,U,10)
QUIT
+5 IF '$$MGCHK^IBCE(0)
QUIT
+6 IF $PIECE(IBSITE8,U,5)
Begin DoDot:1
+7 SET X2=+$PIECE(IBSITE8,U,3)
SET X1=$PIECE(IBSITE8,U,5)
DO C^%DTC
+8 IF X>DT
SET IBRUN=0
QUIT
End DoDot:1
if 'IBRUN
QUIT
+9 DO QTXMT^IBCE837B(IBSITE8)
+10 IF $PIECE(IBSITE8,U,5)'=DT
SET DIE="^IBE(350.9,"
SET DR="8.05////"_DT
SET DA=1
DO ^DIE
+11 QUIT
+12 ;
SETUP(IBEXTRP) ; Txmn set up
+1 ; IBEXTRP=1 prnt 837 data
+2 NEW IB
+3 KILL ^TMP("IBXMSG",$JOB),^TMP("IBTXMT",$JOB),^TMP("IBHDR",$JOB),^TMP("IBHDR1",$JOB),^TMP("IBXERR",$JOB),IBXERR,^TMP("IBXINS",$JOB),^TMP("IBTX",$JOB),^TMP("IBEDI_TEST_BATCH",$JOB)
+4 ; Chk extract running
+5 if $GET(IBEXTRP)
QUIT
+6 ; Chk resubmit tst
+7 IF $PIECE($GET(^TMP("IBRESUBMIT",$JOB)),U,4)
SET ^TMP("IBEDI_TEST_BATCH",$JOB)=1
QUIT
+8 IF '$DATA(^TMP("IBRESUBMIT",$JOB))
IF '$DATA(^TMP("IBONE",$JOB))
Begin DoDot:1
+9 LOCK +^IBA(364,0):5
+10 IF '$TEST
Begin DoDot:2
+11 SET IBXERR=1
SET ^TMP("IBXERR",$JOB,1)="A PREVIOUS EDI EXTRACT IS RUNNING - ANOTHER CANNOT BE STARTED "_$$FMTE^XLFDT($$NOW^XLFDT(),2)
End DoDot:2
QUIT
End DoDot:1
if $DATA(IBXERR)
QUIT
+12 ;
+13 IF $DATA(^TMP("IBRESUBMIT",$JOB))
Begin DoDot:1
+14 ;JWS;IB*2.0*641v6;issue with resubmit of claim, batch # not generated until submitted
+15 ; ;in FHIR, transaction does not get transmitted immediately, so no need to check batch# lock
+16 IF $$GET1^DIQ(350.9,"1,",8.21,"I")
QUIT
+17 NEW Z,Z0
+18 SET Z0=$PIECE($GET(^TMP("IBRESUBMIT",$JOB)),U,2)
SET Z=$$LOCK^IBCEM02(364.1,Z0)
+19 IF 'Z
Begin DoDot:2
+20 SET IBXERR=1
+21 SET ^TMP("IBRESUBMIT",$JOB,"IBXERR",1)="Another user is currently processing batch "_Z0_". Batch NOT resubmitted."
End DoDot:2
+22 IF 'Z
Begin DoDot:2
+23 SET IBXERR=1
+24 SET ^TMP("IBRESUBMIT",$JOB,"IBXERR",1)="Another user is currently processing batch "_Z0_". Batch NOT resubmitted."
+25 SET ^TMP("IBRESUBMIT",$JOB,"IBXERR",2)="Resubmit was attempted by: "_$PIECE($GET(^VA(200,DUZ,0)),U)_" ("_DUZ_")"
End DoDot:2
End DoDot:1
if $DATA(IBXERR)
QUIT
+26 IF $DATA(^TMP("IBONE",$JOB))
SET IB=$GET(^($JOB))+1
Begin DoDot:1
+27 NEW Z,Z0
+28 SET Z0=$ORDER(^TMP("IBONE",$JOB,""))
SET Z=$$LOCK^IBCEM02(364,Z0)
+29 IF 'Z
Begin DoDot:2
+30 SET IBXERR=1
+31 SET ^TMP("IBONE",$JOB,"IBXERR",1)="Another user is currently processing bill "_$PIECE($GET(^DGCR(399,+$GET(^IBA(364,Z0,0)),0)),U)_". Bill NOT "_$PIECE("^re",U,IB)_"submitted."
+32 SET ^TMP("IBONE",$JOB,"IBXERR",2)=$PIECE("S^Res",U,IB)_"ubmit was attempted by: "_$PIECE($GET(^VA(200,DUZ,0)),U)_" ("_DUZ_")"
End DoDot:2
End DoDot:1
if $DATA(IBXERR)
QUIT
+33 QUIT
+34 ;
FIND ; Find/sort by CMS-1500/UB-04, test/live, ins ID # & div
+1 ;
+2 NEW IBX,IB0,IBCBH,IBINS,IBXIEN,IBNID,IBGBL,IBTXTEST,IBBTYP,IB837R,IBDIV,IBNOTX,IBTXST,IBTEST,IBSEC,IBNF
+3 KILL ^TMP($JOB,"BILL"),^TMP("IBICT",$JOB)
+4 ;
+5 SET IBGBL=$SELECT($DATA(^TMP("IBONE",$JOB)):"^TMP(""IBONE"","_$JOB_")",$DATA(^TMP("IBSELX",$JOB)):"^TMP(""IBSELX"","_$JOB_")",'$DATA(^TMP("IBRESUBMIT",$JOB)):"^IBA(364,""ASTAT"",""X"")",1:"^TMP(""IBRESUBMIT"","_$JOB_")")
+6 SET IBTEST=+$GET(^TMP("IBEDI_TEST_BATCH",$JOB))
+7 ;
+8 SET IBX=""
FOR
SET IBX=$ORDER(@IBGBL@(IBX))
if 'IBX
QUIT
Begin DoDot:1
+9 ;IB 547, If resubmitting a locally printed claim to test via RCB, there is no entry in 364 yet, so pass the NEW flag
+10 ;S IBXIEN=+$G(^IBA(364,IBX,0)),IB0=$G(^DGCR(399,IBXIEN,0))
+11 ;S IBTXST=$$TXMT^IBCEF4(IBXIEN,.IBNOTX)
+12 SET IBXIEN=+$GET(^IBA(364,IBX,0))
SET IBNF=""
+13 IF $GET(IBLOC)=1
IF $GET(IBTYPPTC)="TEST"
SET IBXIEN=IBX
SET IBNF=1
+14 SET IB0=$GET(^DGCR(399,IBXIEN,0))
+15 SET IBTXST=$$TXMT^IBCEF4(IBXIEN,.IBNOTX,IBNF)
+16 ; no txmt
if IBTXST=""
QUIT
+17 if $SELECT(IB0=""
QUIT
+18 SET IBCBH=$PIECE(IB0,U,21)
if "PST"'[IBCBH!(IBCBH="")
SET IBCBH="P"
+19 SET IBINS=$PIECE($GET(^DGCR(399,IBXIEN,"I"_($FIND("PST",IBCBH)-1))),U)
+20 SET IBTXTEST=$SELECT(IBTEST:2,1:+$$TEST^IBCEF4(IBXIEN))
+21 ;JWS:IB*2.0*592:US131 - EDI Dental Claim
+22 SET IBBTYP=$PIECE("P^I^D",U,$SELECT($$FT^IBCEF(IBXIEN)=7:3,1:($$FT^IBCEF(IBXIEN)=3)+1))_"-"_IBTXTEST
+23 ;Test pt
if $$TESTPT^IBCEU($PIECE(IB0,U,2))&'IBTXTEST
QUIT
+24 ;
+25 IF IBTXTEST=1
DO TESTLIM^IBCE837A(.IBINS)
+26 ;
+27 IF IBINS
IF $PIECE(IB0,U,2)
Begin DoDot:2
+28 DO SETVAR^IBCE837A(IBXIEN,IBINS,IB0,.IBSEC,.IBNID,.IB837R,.IBDIV)
+29 if '$DATA(^TMP("IBXINS",$JOB,IBDIV_U_IBBTYP,IBNID))
SET ^(IBNID)=IBINS
SET ^TMP("IBTXMT",$JOB,IBDIV_U_IBBTYP,IB837R_U_IBSEC,IBNID,$PIECE(IB0,U,2),IBXIEN_U_IBX)=IBX
End DoDot:2
+30 ;
+31 SET ^TMP($JOB,"BILL",$PIECE(IB0,U))=""
End DoDot:1
+32 ;
+33 IF $DATA(^TMP("IBTXMT",$JOB))
SET ^TMP("IBXDATA",$JOB)=IBNID
+34 KILL ^TMP($JOB,"BILL")
+35 QUIT
+36 ;
OUTPUT ; 837
+1 ;
+2 NEW 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
+3 ;
+4 KILL ^TMP("IBCE-BATCH",$JOB)
+5 SET IBSITE=$GET(^IBE(350.9,1,8))
SET IBMAX=$PIECE(IBSITE,U,4)
SET IB837=+$ORDER(^IBE(353,"B","IB 837 TRANSMISSION",0))
SET IB837=$SELECT($PIECE($GET(^IBE(353,+IB837,2)),U,8):$PIECE(^(2),U,8),1:IB837)
if 'IBMAX
SET IBMAX=999
+6 ;
+7 IF 'IB837
Begin DoDot:1
+8 NEW IBZ,XMBODY
+9 SET XMBODY="IBZ"
+10 SET IBZ(1)="The transmission form for sending electronic claims is not in your form file"
SET IBZ(2)="NO CLAIMS WERE OUTPUT - FORM = IB 837 TRANSMISSION"
+11 DO ERRMSG^IBCE837A(XMBODY)
End DoDot:1
QUIT
+12 ;
+13 SET (IBCT,IBCTM,IBSIZE)=0
SET IBQUEUE=$PIECE(IBSITE,U)
SET IBTQUEUE=$PIECE(IBSITE,U,9)
SET IBDESC=""
+14 ;
+15 if IBQUEUE=""&(IBTQUEUE="")
QUIT
+16 ;
+17 SET IBQ=""
SET IBBTYPX=""
+18 ; Sort: div_^_bill type_-_test stat,ins co transmission destination^sec status,dfn,claim #
+19 FOR
SET IBBTYPX=$ORDER(^TMP("IBTXMT",$JOB,IBBTYPX))
SET IBBTYP=$PIECE(IBBTYPX,U,2)
if IBCTM
DO CHKNEW^IBCE837A(IBQ,.IBBILL,.IBCTM,IBDESC,IBBTYP,"",IBSITE,.IBSIZE)
if IBBTYPX=""
QUIT
Begin DoDot:1
+20 SET IBDEFPRT=$SELECT($EXTRACT(IBBTYP)="P":"SPRINT",1:"SPRINT")
+21 SET IBTXTEST=+$PIECE(IBBTYP,"-",2)
SET IBQ=$SELECT('IBTXTEST:IBQUEUE,IBTXTEST=2:"MCT",1:IBTQUEUE)
+22 ; Queue
if IBQ=""
QUIT
+23 ;
+24 ;JWS:IB*2.0*592:US131 - EDI Dental Claim
+25 SET IBD=$SELECT($EXTRACT(IBBTYP)="P":"PROF",$EXTRACT(IBBTYP)="D":"DENT",1:"INST")_" CLAIMS-"_$$HTE^XLFDT($HOROLOG,2)_" "
+26 SET IBDESC=$SELECT('$PIECE(IBSITE,U,7):$SELECT('IBTXTEST:"",1:"TEST ")_IBD,1:"")
+27 ;
+28 SET IB837R=""
+29 FOR
SET IB837R=$ORDER(^TMP("IBTXMT",$JOB,IBBTYPX,IB837R))
if IBCTM
DO CHKNEW^IBCE837A(IBQ,.IBBILL,.IBCTM,IBDESC,IBBTYP,"",IBSITE,.IBSIZE)
if IB837R=""
QUIT
Begin DoDot:2
+30 SET (IBINS,IBNID)=""
SET IBLCNT=0
+31 FOR
SET IBNID=$ORDER(^TMP("IBTXMT",$JOB,IBBTYPX,IB837R,IBNID))
KILL ^TMP("IBHDR1",$JOB)
if IBCTM
DO CHKNEW^IBCE837A(IBQ,.IBBILL,.IBCTM,IBDESC,IBBTYP,IBINS,IBSITE,.IBSIZE)
if IBNID=""
QUIT
Begin DoDot:3
+32 ;
+33 SET IBDFN=0
SET IBINS=+$GET(^TMP("IBXINS",$JOB,IBBTYPX,IBNID))
+34 ;
+35 ; 1 ins/batch
IF $PIECE(IBSITE,U,7)
Begin DoDot:4
+36 SET IBLCNT=0
+37 SET IBDESC=$EXTRACT($SELECT('IBTXTEST:"",1:"TEST ")_IBD_$PIECE($GET(^DIC(36,IBINS,0)),U),1,80)
End DoDot:4
+38 ;
+39 FOR
SET IBDFN=$ORDER(^TMP("IBTXMT",$JOB,IBBTYPX,IB837R,IBNID,IBDFN))
if 'IBDFN
QUIT
SET IBREF=""
FOR
SET IBREF=$ORDER(^TMP("IBTXMT",$JOB,IBBTYPX,IB837R,IBNID,IBDFN,IBREF))
if 'IBREF
QUIT
Begin DoDot:4
+40 ;exceeds max #
IF '(IBCTM#IBMAX)
IF IBCTM
DO MAILIT^IBCE837A(IBQ,.IBBILL,.IBCTM,"",IBDESC,IBBTYP,IBINS)
SET IBSIZE=0
+41 ;JWS;IB*2.0*623;begin;if 837 FHIR is on, just set flag to begin transmit
+42 IF $$GET1^DIQ(350.9,"1,",8.21,"I")
Begin DoDot:5
+43 ;JWS;IB*2.0*623v24;added resubmit flag parameter to SETCLM^IBCE837I call
+44 DO SETCLM^IBCE837I($PIECE(IBREF,U,2),IBQ,$SELECT($DATA(^TMP("IBRESUBMIT",$JOB,$PIECE(IBREF,U,2))):1,1:0))
+45 SET IBCT=IBCT+1
SET IBCTM=IBCTM+1
+46 QUIT
End DoDot:5
QUIT
+47 ;IB*2.0*623;end
+48 DO BILLPARM^IBCEFG0(+IBREF,.IBPARMS)
+49 ; JWS;EBILL-2667;add 5th parameter to output formatter call to conditionally execute FSC workarounds post execute
+50 SET IBSIZEM=$$EXTRACT^IBCEFG(IB837,+IBREF,1,.IBPARMS,1)
+51 ; exceeds max size
IF (IBSIZEM+IBSIZE)>30000
IF IBSIZE
Begin DoDot:5
+52 ; JWS;EBILL-2667;add 5th parameter to output formatter call to conditionally execute FSC workarounds post execute
+53 DO MAILIT^IBCE837A(IBQ,.IBBILL,.IBCTM,"",IBDESC,IBBTYP,IBINS)
SET IBSIZE=0
KILL ^TMP("IBXDATA",$JOB)
SET IBSIZEM=$$EXTRACT^IBCEFG(IB837,+IBREF,1,.IBPARMS,1)
End DoDot:5
+54 IF 'IBSIZEM
if 'IBCTM
Begin DoDot:5
+55 DO CHKBTCH^IBCE837A(+$GET(^TMP("IBHDR",$JOB)))
KILL ^TMP("IBHDR",$JOB)
End DoDot:5
QUIT
+56 SET IBCT=IBCT+1
SET IBCTM=IBCTM+1
+57 if $DATA(^TMP("IBXDATA",$JOB))
DO MESSAGE(.IBLCNT,$PIECE(IBREF,U,2),.IBBILL,.IBCTM,.IBSIZE,IBSIZEM,"",IBBTYP,IBINS)
End DoDot:4
End DoDot:3
+58 ;
+59 IF $GET(IBTXTEST)=1
SET IBINS=0
FOR
SET IBINS=$ORDER(^TMP("IBICT",$JOB,IBINS))
if 'IBINS
QUIT
SET IB3=$GET(^DIC(36,IBINS,3))
Begin DoDot:3
+60 NEW DIE,DA,DR
+61 SET DIE="^DIC(36,"
SET DA=IBINS
SET DR="3.05////"_DT_";3.07////"_($SELECT($PIECE(IB3,U,5)'=DT:0,1:$PIECE(IB3,U,7))+^TMP("IBICT",$JOB,IBINS))
DO ^DIE
End DoDot:3
End DoDot:2
End DoDot:1
+62 ;
+63 ;Error to mail grp
IF $ORDER(^TMP("IBXERR",$JOB,""))
Begin DoDot:1
+64 NEW XMTO,XMBODY,XMDUZ,XMSUBJ,IBCT,IBERR
+65 KILL ^TMP("IBXMSG",$JOB)
+66 SET ^TMP("IBXMSG",$JOB,1)="The following authorized bill(s) were not transmitted due to errors indicated."
SET ^(2)="Once the errors are corrected, the bill(s) will be included in the next run."
SET ^(3)=" "
+67 ;
+68 SET IBERR=0
SET IBCT=3
+69 FOR
SET IBERR=$ORDER(^TMP("IBXERR",$JOB,IBERR))
if 'IBERR
QUIT
SET IBCT=IBCT+1
SET ^TMP("IBXMSG",$JOB,IBCT)="Bill #: "_$PIECE($GET(^DGCR(399,IBERR,0)),U)
SET IBCT=IBCT+1
SET ^TMP("IBXMSG",$JOB,IBCT)=$JUSTIFY("",5)_^TMP("IBXERR",$JOB,IBERR)
+70 SET XMBODY="^TMP(""IBXMSG"","_$JOB_")"
DO ERRMSG^IBCE837A(XMBODY)
+71 ;
+72 KILL ^TMP("IBXMSG",$JOB),^TMP("IBICT",$JOB)
End DoDot:1
+73 ;
+74 IF $ORDER(^TMP("IBCE-BATCH",$JOB,""))
Begin DoDot:1
+75 NEW IB,IB0,IBL,IBT,IBX,XMTO,XMDUZ,XMSUBJ,IBRESUB,IBTESTB,XMZ
+76 SET IBRESUB=$DATA(^TMP("IBRESUBMIT",$JOB))
+77 ;
+78 SET IBT(1)="The following batches were "_$SELECT('IBRESUB:"",1:"re-")_"submitted to Austin "_$SELECT(IBTXTEST'=2:"",1:"as TEST ")_$$HTE^XLFDT($HOROLOG,"2D")_":"
+79 SET IBT(2)=$SELECT('IBRESUB:" ",1:" [Resubmitted by: "_$PIECE($GET(^VA(200,+DUZ,0)),U)_" (#"_DUZ_")]")
if IBRESUB
SET IBT(3)=" "
+80 ;
+81 SET IBL=$SELECT('IBRESUB:2,1:3)
SET IB=""
+82 FOR
SET IB=$ORDER(^TMP("IBCE-BATCH",$JOB,IB))
if IB=""
QUIT
SET IBL=IBL+1
SET IB0=$GET(^(IB))
Begin DoDot:2
+83 SET IBX=IB
+84 IF $PIECE(IB0,U,3)'=""
IF IBTXTEST=2
SET IBX=$PIECE(IB0,U,3)_" (AS BATCH "_IB_")"
+85 SET IBT(IBL)=" "_IBX_" "_$PIECE($GET(^IBA(364.1,+IB0,0)),U,8)
SET IBL=IBL+1
SET IBT(IBL)=" ("_+$PIECE(IB0,U,2)_" bills)"
End DoDot:2
+86 ;
+87 SET XMTO("I:G.IB EDI")=""
SET XMDUZ=""
SET XMBODY="IBT"
SET XMSUBJ="EDI 837 "_$SELECT('IBRESUB:"",1:"RE-")_"SUBMISSION BATCH LIST"_$SELECT(IBTXTEST'=2:"",1:" FOR TEST")
+88 DO SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ)
+89 ;
+90 if IBRESUB
SET ^TMP("IBRESUBMIT",$JOB,0)=1
End DoDot:1
+91 QUIT
+92 ;
CLEANUP ; moved
+1 DO CLEANUP^IBCE837A
+2 QUIT
+3 ;
MESSAGE(IBLCNT,IBIEN,IBBILL,IBCTM,IBSIZE,IBSIZEM,IBDUZ,IBBTYP,IBINS) ; Create msg in ^TMP("IBXMSG",$J)
+1 ;IBLCNT = last msg line extracted
+2 ;IBIEN = ien file 364 bill entry
+3 ;IBBILL = array file 364 ien's of bills being sent
+4 ; IBBILL(IEN)=""
+5 ;IBSIZE = # bytes in msg
+6 ;IBSIZEM = # bytes in record to be added to msg
+7 ;IBCTM = # bills in batch
+8 ;IBDUZ = user ien running extract (Postmaster if auto)
+9 ;IBBTYP = x-y where x = P for prof, I for inst, D for dental ;JWS:IB*2.0*592:US131 - EDI Dental Claim
+10 ; y = 1 for test, 0 for live txmt
+11 ;IBINS = ien of 1 ins co for batch
+12 ;
+13 NEW IB,IBL,IB1,IB2,IB3,IBQ,IBREC,IBDEL
+14 SET IBDEL=$ORDER(^IBA(364.5,"B","N-SEGMENT DELIMITER",""))
SET IBDEL=$PIECE($GET(^IBA(364.5,+IBDEL,0)),U,8)
if IBDEL=""
SET IBDEL="~"
+15 SET IBSIZE=IBSIZE+IBSIZEM
SET IB1=""
SET IBREC=""
+16 FOR
SET IB1=$ORDER(^TMP("IBXDATA",$JOB,1,IB1))
if IB1=""
QUIT
Begin DoDot:1
+17 SET (IBREC,IB2)=""
+18 FOR
SET IB2=$ORDER(^TMP("IBXDATA",$JOB,1,IB1,IB2))
if $SELECT(IB2=""
QUIT
Begin DoDot:2
+19 SET IB3=""
SET IBREC=""
+20 FOR
SET IB3=$ORDER(^TMP("IBXDATA",$JOB,1,IB1,IB2,IB3))
if IB3=""&($LENGTH(IBREC))
DO SETG
if IB3=""
QUIT
if $SELECT(IB3=1
SET $PIECE(IBREC,U,IB3)=$$UP^XLFSTR(^TMP("IBXDATA",$JOB,1,IB1,IB2,IB3))
End DoDot:2
End DoDot:1
+21 SET IBBILL(IBIEN)=""
+22 KILL ^TMP("IBXDATA",$JOB)
+23 QUIT
+24 ;
SETHDR ; hdr for curr batch
+1 SET ^TMP("IBHDR",$JOB)=$GET(^TMP("IBXDATA",$JOB,1,5,1,2))
+2 QUIT
+3 ;
SETHDR1 ; hdr node for curr ins
+1 SET ^TMP("IBHDR1",$JOB)=$GET(^TMP("IBXDATA",$JOB,1,20,1,8))
+2 QUIT
+3 ;
SETG ; msg global for each segment
+1 SET IBREC=$TRANSLATE(IBREC,IBDEL)
+2 SET IBREC=IBREC_IBDEL
SET IBSIZE=IBSIZE+$LENGTH(IBDEL)
+3 SET IBLCNT=IBLCNT+1
SET ^TMP("IBXMSG",$JOB,IBLCNT)=IBREC
+4 QUIT
+5 ;
ONE ; Txmt 1 or more bills for test or in 'X' status for live
+1 if '$$MGCHK^IBCE(0)
QUIT
+2 DO SETUP(0)
+3 IF '$DATA(IBXERR)
DO FIND
DO OUTPUT
+4 DO CLEANUP^IBCE837A
+5 QUIT
+6 ;
