- 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 Feb 18, 2025@23:35:49 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 ;