Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCE837

IBCE837.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. EN ; Auto-txmt
  1. N IBSITE8,IBRUN,X,X1,X2,DA,DIE,DR
  1. K ^TMP("IBRESUBMIT",$J),^TMP("IBONE",$J)
  1. S IBSITE8=$G(^IBE(350.9,1,8)),IBRUN=1
  1. Q:'$P(IBSITE8,U,3)!'$P(IBSITE8,U,10)
  1. I '$$MGCHK^IBCE(0) Q
  1. I $P(IBSITE8,U,5) D Q:'IBRUN
  1. . S X2=+$P(IBSITE8,U,3),X1=$P(IBSITE8,U,5) D C^%DTC
  1. . I X>DT S IBRUN=0 Q
  1. D QTXMT^IBCE837B(IBSITE8)
  1. I $P(IBSITE8,U,5)'=DT S DIE="^IBE(350.9,",DR="8.05////"_DT,DA=1 D ^DIE
  1. Q
  1. ;
  1. SETUP(IBEXTRP) ; Txmn set up
  1. ; IBEXTRP=1 prnt 837 data
  1. N IB
  1. 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)
  1. ; Chk extract running
  1. Q:$G(IBEXTRP)
  1. ; Chk resubmit tst
  1. I $P($G(^TMP("IBRESUBMIT",$J)),U,4) S ^TMP("IBEDI_TEST_BATCH",$J)=1 Q
  1. I '$D(^TMP("IBRESUBMIT",$J)),'$D(^TMP("IBONE",$J)) D Q:$D(IBXERR)
  1. . L +^IBA(364,0):5
  1. . I '$T D Q
  1. .. S IBXERR=1,^TMP("IBXERR",$J,1)="A PREVIOUS EDI EXTRACT IS RUNNING - ANOTHER CANNOT BE STARTED "_$$FMTE^XLFDT($$NOW^XLFDT(),2)
  1. ;
  1. I $D(^TMP("IBRESUBMIT",$J)) D Q:$D(IBXERR)
  1. .;JWS;IB*2.0*641v6;issue with resubmit of claim, batch # not generated until submitted
  1. .; ;in FHIR, transaction does not get transmitted immediately, so no need to check batch# lock
  1. .I $$GET1^DIQ(350.9,"1,",8.21,"I") Q
  1. .N Z,Z0
  1. .S Z0=$P($G(^TMP("IBRESUBMIT",$J)),U,2),Z=$$LOCK^IBCEM02(364.1,Z0)
  1. .I 'Z D
  1. ..S IBXERR=1
  1. ..S ^TMP("IBRESUBMIT",$J,"IBXERR",1)="Another user is currently processing batch "_Z0_". Batch NOT resubmitted."
  1. .I 'Z D
  1. ..S IBXERR=1
  1. ..S ^TMP("IBRESUBMIT",$J,"IBXERR",1)="Another user is currently processing batch "_Z0_". Batch NOT resubmitted."
  1. ..S ^TMP("IBRESUBMIT",$J,"IBXERR",2)="Resubmit was attempted by: "_$P($G(^VA(200,DUZ,0)),U)_" ("_DUZ_")"
  1. I $D(^TMP("IBONE",$J)) S IB=$G(^($J))+1 D Q:$D(IBXERR)
  1. .N Z,Z0
  1. .S Z0=$O(^TMP("IBONE",$J,"")),Z=$$LOCK^IBCEM02(364,Z0)
  1. .I 'Z D
  1. ..S IBXERR=1
  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."
  1. ..S ^TMP("IBONE",$J,"IBXERR",2)=$P("S^Res",U,IB)_"ubmit was attempted by: "_$P($G(^VA(200,DUZ,0)),U)_" ("_DUZ_")"
  1. Q
  1. ;
  1. FIND ; Find/sort by CMS-1500/UB-04, test/live, ins ID # & div
  1. ;
  1. N IBX,IB0,IBCBH,IBINS,IBXIEN,IBNID,IBGBL,IBTXTEST,IBBTYP,IB837R,IBDIV,IBNOTX,IBTXST,IBTEST,IBSEC,IBNF
  1. K ^TMP($J,"BILL"),^TMP("IBICT",$J)
  1. ;
  1. 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_")")
  1. S IBTEST=+$G(^TMP("IBEDI_TEST_BATCH",$J))
  1. ;
  1. S IBX="" F S IBX=$O(@IBGBL@(IBX)) Q:'IBX D
  1. .;IB 547, If resubmitting a locally printed claim to test via RCB, there is no entry in 364 yet, so pass the NEW flag
  1. .;S IBXIEN=+$G(^IBA(364,IBX,0)),IB0=$G(^DGCR(399,IBXIEN,0))
  1. .;S IBTXST=$$TXMT^IBCEF4(IBXIEN,.IBNOTX)
  1. .S IBXIEN=+$G(^IBA(364,IBX,0)),IBNF=""
  1. .I $G(IBLOC)=1,$G(IBTYPPTC)="TEST" S IBXIEN=IBX,IBNF=1
  1. .S IB0=$G(^DGCR(399,IBXIEN,0))
  1. .S IBTXST=$$TXMT^IBCEF4(IBXIEN,.IBNOTX,IBNF)
  1. .Q:IBTXST="" ; no txmt
  1. .Q:$S(IB0="":1,$P(IB0,U,13)>4&'IBTEST:1,1:$D(^TMP($J,"BILL",$P(IB0,U))))
  1. .S IBCBH=$P(IB0,U,21) S:"PST"'[IBCBH!(IBCBH="") IBCBH="P"
  1. .S IBINS=$P($G(^DGCR(399,IBXIEN,"I"_($F("PST",IBCBH)-1))),U)
  1. .S IBTXTEST=$S(IBTEST:2,1:+$$TEST^IBCEF4(IBXIEN))
  1. .;JWS:IB*2.0*592:US131 - EDI Dental Claim
  1. .S IBBTYP=$P("P^I^D",U,$S($$FT^IBCEF(IBXIEN)=7:3,1:($$FT^IBCEF(IBXIEN)=3)+1))_"-"_IBTXTEST
  1. .Q:$$TESTPT^IBCEU($P(IB0,U,2))&'IBTXTEST ;Test pt
  1. .;
  1. .I IBTXTEST=1 D TESTLIM^IBCE837A(.IBINS)
  1. .;
  1. .I IBINS,$P(IB0,U,2) D
  1. .. D SETVAR^IBCE837A(IBXIEN,IBINS,IB0,.IBSEC,.IBNID,.IB837R,.IBDIV)
  1. ..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
  1. .;
  1. .S ^TMP($J,"BILL",$P(IB0,U))=""
  1. ;
  1. I $D(^TMP("IBTXMT",$J)) S ^TMP("IBXDATA",$J)=IBNID
  1. K ^TMP($J,"BILL")
  1. Q
  1. ;
  1. OUTPUT ; 837
  1. ;
  1. 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
  1. ;
  1. K ^TMP("IBCE-BATCH",$J)
  1. 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
  1. ;
  1. I 'IB837 D Q
  1. . N IBZ,XMBODY
  1. . S XMBODY="IBZ"
  1. . 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"
  1. . D ERRMSG^IBCE837A(XMBODY)
  1. ;
  1. S (IBCT,IBCTM,IBSIZE)=0,IBQUEUE=$P(IBSITE,U),IBTQUEUE=$P(IBSITE,U,9),IBDESC=""
  1. ;
  1. Q:IBQUEUE=""&(IBTQUEUE="")
  1. ;
  1. S IBQ="",IBBTYPX=""
  1. ; Sort: div_^_bill type_-_test stat,ins co transmission destination^sec status,dfn,claim #
  1. 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
  1. . S IBDEFPRT=$S($E(IBBTYP)="P":"SPRINT",1:"SPRINT")
  1. . S IBTXTEST=+$P(IBBTYP,"-",2),IBQ=$S('IBTXTEST:IBQUEUE,IBTXTEST=2:"MCT",1:IBTQUEUE)
  1. . Q:IBQ="" ; Queue
  1. . ;
  1. . ;JWS:IB*2.0*592:US131 - EDI Dental Claim
  1. . S IBD=$S($E(IBBTYP)="P":"PROF",$E(IBBTYP)="D":"DENT",1:"INST")_" CLAIMS-"_$$HTE^XLFDT($H,2)_" "
  1. . S IBDESC=$S('$P(IBSITE,U,7):$S('IBTXTEST:"",1:"TEST ")_IBD,1:"")
  1. . ;
  1. . S IB837R=""
  1. . F S IB837R=$O(^TMP("IBTXMT",$J,IBBTYPX,IB837R)) D:IBCTM CHKNEW^IBCE837A(IBQ,.IBBILL,.IBCTM,IBDESC,IBBTYP,"",IBSITE,.IBSIZE) Q:IB837R="" D
  1. .. S (IBINS,IBNID)="",IBLCNT=0
  1. .. 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
  1. ...;
  1. ...S IBDFN=0,IBINS=+$G(^TMP("IBXINS",$J,IBBTYPX,IBNID))
  1. ... ;
  1. ...I $P(IBSITE,U,7) D ; 1 ins/batch
  1. .... S IBLCNT=0
  1. .... S IBDESC=$E($S('IBTXTEST:"",1:"TEST ")_IBD_$P($G(^DIC(36,IBINS,0)),U),1,80)
  1. ... ;
  1. ... 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
  1. .... I '(IBCTM#IBMAX),IBCTM D MAILIT^IBCE837A(IBQ,.IBBILL,.IBCTM,"",IBDESC,IBBTYP,IBINS) S IBSIZE=0 ;exceeds max #
  1. .... ;JWS;IB*2.0*623;begin;if 837 FHIR is on, just set flag to begin transmit
  1. .... I $$GET1^DIQ(350.9,"1,",8.21,"I") D Q
  1. ..... ;JWS;IB*2.0*623v24;added resubmit flag parameter to SETCLM^IBCE837I call
  1. ..... D SETCLM^IBCE837I($P(IBREF,U,2),IBQ,$S($D(^TMP("IBRESUBMIT",$J,$P(IBREF,U,2))):1,1:0))
  1. ..... S IBCT=IBCT+1,IBCTM=IBCTM+1
  1. ..... Q
  1. .... ;IB*2.0*623;end
  1. .... D BILLPARM^IBCEFG0(+IBREF,.IBPARMS)
  1. .... ; JWS;EBILL-2667;add 5th parameter to output formatter call to conditionally execute FSC workarounds post execute
  1. .... S IBSIZEM=$$EXTRACT^IBCEFG(IB837,+IBREF,1,.IBPARMS,1)
  1. .... I (IBSIZEM+IBSIZE)>30000,IBSIZE D ; exceeds max size
  1. ..... ; JWS;EBILL-2667;add 5th parameter to output formatter call to conditionally execute FSC workarounds post execute
  1. ..... 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)
  1. .... I 'IBSIZEM D:'IBCTM Q
  1. ..... D CHKBTCH^IBCE837A(+$G(^TMP("IBHDR",$J))) K ^TMP("IBHDR",$J)
  1. .... S IBCT=IBCT+1,IBCTM=IBCTM+1
  1. .... D:$D(^TMP("IBXDATA",$J)) MESSAGE(.IBLCNT,$P(IBREF,U,2),.IBBILL,.IBCTM,.IBSIZE,IBSIZEM,"",IBBTYP,IBINS)
  1. ..;
  1. .. 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
  1. ... N DIE,DA,DR
  1. ... 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
  1. ;
  1. I $O(^TMP("IBXERR",$J,"")) D ;Error to mail grp
  1. .N XMTO,XMBODY,XMDUZ,XMSUBJ,IBCT,IBERR
  1. .K ^TMP("IBXMSG",$J)
  1. .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)=" "
  1. .;
  1. .S IBERR=0,IBCT=3
  1. .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)
  1. .S XMBODY="^TMP(""IBXMSG"","_$J_")" D ERRMSG^IBCE837A(XMBODY)
  1. .;
  1. .K ^TMP("IBXMSG",$J),^TMP("IBICT",$J)
  1. ;
  1. I $O(^TMP("IBCE-BATCH",$J,"")) D
  1. .N IB,IB0,IBL,IBT,IBX,XMTO,XMDUZ,XMSUBJ,IBRESUB,IBTESTB,XMZ
  1. .S IBRESUB=$D(^TMP("IBRESUBMIT",$J))
  1. .;
  1. .S IBT(1)="The following batches were "_$S('IBRESUB:"",1:"re-")_"submitted to Austin "_$S(IBTXTEST'=2:"",1:"as TEST ")_$$HTE^XLFDT($H,"2D")_":"
  1. .S IBT(2)=$S('IBRESUB:" ",1:" [Resubmitted by: "_$P($G(^VA(200,+DUZ,0)),U)_" (#"_DUZ_")]") S:IBRESUB IBT(3)=" "
  1. .;
  1. .S IBL=$S('IBRESUB:2,1:3),IB=""
  1. .F S IB=$O(^TMP("IBCE-BATCH",$J,IB)) Q:IB="" S IBL=IBL+1,IB0=$G(^(IB)) D
  1. .. S IBX=IB
  1. .. I $P(IB0,U,3)'="",IBTXTEST=2 S IBX=$P(IB0,U,3)_" (AS BATCH "_IB_")"
  1. ..S IBT(IBL)=" "_IBX_" "_$P($G(^IBA(364.1,+IB0,0)),U,8),IBL=IBL+1,IBT(IBL)=" ("_+$P(IB0,U,2)_" bills)"
  1. .;
  1. .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")
  1. .D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ)
  1. .;
  1. .S:IBRESUB ^TMP("IBRESUBMIT",$J,0)=1
  1. Q
  1. ;
  1. CLEANUP ; moved
  1. D CLEANUP^IBCE837A
  1. Q
  1. ;
  1. MESSAGE(IBLCNT,IBIEN,IBBILL,IBCTM,IBSIZE,IBSIZEM,IBDUZ,IBBTYP,IBINS) ; Create msg in ^TMP("IBXMSG",$J)
  1. ;IBLCNT = last msg line extracted
  1. ;IBIEN = ien file 364 bill entry
  1. ;IBBILL = array file 364 ien's of bills being sent
  1. ; IBBILL(IEN)=""
  1. ;IBSIZE = # bytes in msg
  1. ;IBSIZEM = # bytes in record to be added to msg
  1. ;IBCTM = # bills in batch
  1. ;IBDUZ = user ien running extract (Postmaster if auto)
  1. ;IBBTYP = x-y where x = P for prof, I for inst, D for dental ;JWS:IB*2.0*592:US131 - EDI Dental Claim
  1. ; y = 1 for test, 0 for live txmt
  1. ;IBINS = ien of 1 ins co for batch
  1. ;
  1. N IB,IBL,IB1,IB2,IB3,IBQ,IBREC,IBDEL
  1. S IBDEL=$O(^IBA(364.5,"B","N-SEGMENT DELIMITER","")),IBDEL=$P($G(^IBA(364.5,+IBDEL,0)),U,8) S:IBDEL="" IBDEL="~"
  1. S IBSIZE=IBSIZE+IBSIZEM,IB1="",IBREC=""
  1. F S IB1=$O(^TMP("IBXDATA",$J,1,IB1)) Q:IB1="" D
  1. .S (IBREC,IB2)=""
  1. .F S IB2=$O(^TMP("IBXDATA",$J,1,IB1,IB2)) Q:$S(IB2="":1,IB1=1:"",1:'$O(^(IB2,1))) D
  1. ..S IB3="",IBREC=""
  1. ..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))
  1. S IBBILL(IBIEN)=""
  1. K ^TMP("IBXDATA",$J)
  1. Q
  1. ;
  1. SETHDR ; hdr for curr batch
  1. S ^TMP("IBHDR",$J)=$G(^TMP("IBXDATA",$J,1,5,1,2))
  1. Q
  1. ;
  1. SETHDR1 ; hdr node for curr ins
  1. S ^TMP("IBHDR1",$J)=$G(^TMP("IBXDATA",$J,1,20,1,8))
  1. Q
  1. ;
  1. SETG ; msg global for each segment
  1. S IBREC=$TR(IBREC,IBDEL)
  1. S IBREC=IBREC_IBDEL,IBSIZE=IBSIZE+$L(IBDEL)
  1. S IBLCNT=IBLCNT+1,^TMP("IBXMSG",$J,IBLCNT)=IBREC
  1. Q
  1. ;
  1. ONE ; Txmt 1 or more bills for test or in 'X' status for live
  1. Q:'$$MGCHK^IBCE(0)
  1. D SETUP(0)
  1. I '$D(IBXERR) D FIND,OUTPUT
  1. D CLEANUP^IBCE837A
  1. Q
  1. ;