IBCE837I ;EDE/JWS - OUTPUT FOR 837 FHIR TRANSMISSION ;5/23/18 10:48am
;;2.0;INTEGRATED BILLING;**623,641,650,665,742**;23-MAY-18;Build 36
;;Per VA Directive 6402, this routine should not be modified.
;
RES(RES) ;Set resource name correctly
;
; Get Resource requested, '*' if all resources
I RES="*" Q RES
;S RES=$$TITLE^XLFSTR($G(ARG("RES")))
I RES="Valueset" S RES="ValueSet" G Q
I RES="Explanationofbenefit" S RES="ExplanationOfBenefit" G Q
I RES="Imagingstudy" S RES="ImagingStudy" G Q
I RES="Careplan" S RES="CarePlan" G Q
I RES="Episodeofcare" S RES="EpisodeOfCare" G Q
I RES="Documentmanifest" S RES="DocumentManifest" G Q
I RES="Claimresponse" S RES="ClaimResponse" G Q
I RES="Eligibilityrequest" S RES="EligibilityRequest" G Q
I RES="Chargeitem" S RES="ChargeItem" G Q
I RES="Procedurerequest" S RES="ProcedureRequest" G Q
I RES="Healthcareservice" S RES="HealthcareService" G Q
I RES="Relatedperson" S RES="RelatedPerson" G Q
I RES="Paymentnotice" S RES="PaymentNotice" G Q
I RES="Medicationrequest" S RES="MedicationRequest" G Q
I RES="Medicationdispense" S RES="MedicationDispense" G Q
I RES="Practitionerrole" S RES="PractitionerRole" G Q
I RES="Supplyrequest" S RES="SupplyRequest"
Q ;
Q RES
;
FINISH ; enclose message in '[ ]' when a Bundle
N X
I $G(RESULT(1))=""!($G(RESULT(1))="{}") S RESULT(1)="[{}]" Q
I $G(RES)="*" D
. S RESULT(1)="{""Bundle"":["_RESULT(1)
. S X=$O(RESULT("A"),-1)
. S RESULT(X)=RESULT(X)_"]}"
S RESULT(1)="["_RESULT(1)
S X=$O(RESULT("A"),-1)
S RESULT(X)=RESULT(X)_"]"
Q
;
END ; enclose message in '[ ]'
N X
I $G(RESULT(1))="" S RESULT(1)="{}"
S RESULT(1)="["_$G(RESULT(1))_"]"
Q
;
GET(RESULT,ARG) ;RPC - EDICLAIMS; get list of claims to transmit
;
;D APPERROR^%ZTER("RPC USER") ; WCJ TEMP LINE TO SEE SOME VARIABLES
N CT,DUZ,IBGBL,IBX,IBTEST,IBXIEN,IB0,IBTXST,IBTXTEST,IBBTYP,IBDIV,IB837R,IBNF,IBNOTX,MCNT
K ^TMP($J,"BILL"),^TMP($J,"FHIR837")
;JWS;IB*2.0*650v7;3/16/21;remove setting of DUZ(0)
D DTNOLF^DICRW
S IBGBL="^IBA(364,""AC"",1)",CT=1
;JWS;IB*2.0*641v8;added MCNT for maximum count of claims IENs, >20,000 breaks FHIR
S IBX="" F S IBX=$O(@IBGBL@(IBX)) Q:'IBX D I $G(MCNT)>19999 Q
. S IBTEST=$$GET1^DIQ(364,IBX_",",.07,"I")
. S IBXIEN=+$G(^IBA(364,IBX,0)),IBNF=""
. ;JWS;IB*2.0*665v17;EBILL-2241;11/2/21;found at Miami; again at Miami 12/3/21 (similar at Tongus, Orlando, West Palm) - bad entry in 364 file
. I IBXIEN=0 D REMCLM1(IBX) Q
. S IB0=$G(^DGCR(399,IBXIEN,0))
. S IBTXST=$$TXMT^IBCEF4(IBXIEN,.IBNOTX,IBNF)
. ;JWS;IB*2.0*623v25;if claim is invalid to send, remove from 'AC' index
. I IBTXST="" D REMCLM(IBX) Q ; no txmt
. I IB0="" D REMCLM(IBX) Q
. I $P(IB0,U,13)>4,'IBTEST D REMCLM(IBX) Q
. I $F($P(IB0,U),"-") D REMCLM(IBX) Q
. ;JWS;end IB*2.0*623v25;
. S IBTXTEST=$S(IBTEST:2,1:+$$TEST^IBCEF4(IBXIEN))
. S IBBTYP=$P("P^I^D",U,$S($$FT^IBCEF(IBXIEN)=7:3,1:($$FT^IBCEF(IBXIEN)=3)+1))_"-"_IBTXTEST
. ;JWS;IB*2.0*623v25;if not sending, remove from queue
. I $$TESTPT^IBCEU($P(IB0,U,2)),'IBTXTEST D REMCLM(IBX) Q
. ;JWS;IB*2.0*623v25;if not sending, remove from queue
. I $D(^TMP($J,"BILL",$P(IB0,U))) D REMCLM(IBX) Q ; do not send duplicates
. ;JWS;IB*2.0*641v8;added MCNT for maximum count of claims IENs, >20,000 breaks FHIR
. S ^TMP($J,"BILL",$P(IB0,U))="",MCNT=$G(MCNT)+1
. S IBDIV=$P($S($P(IB0,U,22):$$SITE^VASITE(DT,$P(IB0,U,22)),1:$$SITE^VASITE()),U,3)
. S IB837R=$$RECVR^IBCEF2(IBXIEN)
. I $L($G(RESULT(CT)))>3000 S RESULT(CT)=RESULT(CT)_",",CT=$G(CT)+1
. ;;I IBDIV=442 S IBDIV=681 ; for eBilling_dev environment
. S RESULT(CT)=$S($G(RESULT(CT))'="":RESULT(CT)_",",1:"")_"{""ien"":"""_IBXIEN_""",""site"":"""_IBDIV_""",""type"":"""_IB837R_""",""status"":"""_$S(IBTXTEST=0:"live",1:"test")_"""}"
. Q
D FINISH
Q
;
TESTING ;
;K (ARG,U)
N I,RESOURCE
S ARG("IEN399")=2113336 ; 2113336 - PROF ;2113173 - Dental (1 line) ;2113182 - dental ;211334 - INST
R !,"Resource Requested: ",RESOURCE:30 Q:RESOURCE=""
S ARG("RES")=RESOURCE ;"Basic" or "*"
D GET^IBCE837H(.RESULT,.ARG)
F I=1:1 Q:'$D(RESULT(I)) W:I=1 ! W RESULT(I)
Q
;
REC(REC) ;check to see which records are repeating
I $F(",63,104.8,104.91,105,107,110,112,113,114,115,120,125,130,135,170,170.5,171,172,173,176,177,178,178.1,180,",","_REC_",") Q 1
I REC>180 Q 1
Q 0
;
SETD ; update ^TMP global
S DONE=1
D UP
;S @DATA1@(CT,":")=DATA_FILE_"-"_FLD_"-"_NAME_"("_X1_")""" ; includes record # for testing
;JWS;6/20/23;EBILL-3508;IB*2.0*742v13;issue with multiple record counter and workaround record deletions. Use IBRECCT(XREC) instead of X2 variable
S @DATA1@(CT,":")=DATA_FILE_"-"_FLD_$S($$REC(X1):"."_$G(IBRECCT(XREC)),1:"")_"-"_NAME_""""
D UP
S @DATA1@(CT,":")="""value"":"""_TASDATA_"""}"
Q
;
UP ;increment CT
S CT=$G(CT)+1
Q
;
SETCLM(IBIEN,IBQ,RSUB) ; set the FHIR 837 claim for submission
N DA,D0,DR,DIE,DIC
S DA=IBIEN I DA="" Q
;JWS;IB*2.0*665v17;EBILL-2241;11/2/21;found at Miami; again at Miami 12/3/21 (similar at Tongus, Orlando, West Palm) - bad entry in 364 file
I $P($G(^IBA(364,DA,0)),"^")="" Q
I '$$PROD^XUPROD(1) S IBQ="MCT" ; if on a non-production server, send to test queue.
;JWS;IB*2.0*623v24;added field .10 to 364 file entry if a resubmission
S DR=".09////1"_$S(IBQ="MCT":";.07////1",1:";.07////0")_$S($G(RSUB)=1:";.1////1",1:""),DIE="^IBA(364,"
D ^DIE
Q
;JWS;IB*2.0*623v24
;JWS;IB*2.0*650v5 - add set/clear of field .11, file 364 FHIR Bundle Validation flag [11]
SETSUB(IBIEN,IBVAL,IBFLD) ; clear the resubmission flag
N DA,D0,DR,DIE,DIC
S DA=IBIEN I DA="" Q
I $G(IBFLD)=".11" S DR=".11////"_IBVAL
E S DR=".1////"_IBVAL
S DIE="^IBA(364,"
D ^DIE
Q
;
TEST(IBIEN364) ; return test flag
N IBTEST,IBXIEN,IBTXTEST
S IBTEST=$$GET1^DIQ(364,IBIEN364_",",.07,"I")
S IBXIEN=+$G(^IBA(364,IBIEN364,0)),IBNF=""
;JWS;IB*2.0*623v24;7/19/19 - make sure non-prod claims are sent to test queue
S IBTXTEST=$S(IBTEST:2,'$$PROD^XUPROD(1):1,1:+$$TEST^IBCEF4(IBXIEN))
;S IBTXTEST=$S(IBTEST:2,1:+$$TEST^IBCEF4(IBXIEN))
Q $S(IBTXTEST=0:0,1:1)
;
;JWS;IB*2.0*623;v25
REMCLM(IB364) ; clear the FHIR 837 claim for submission
N DA,D0,DR,DIE,DIC
S DA=IB364 I DA="" Q
S DR=".03////Z;.09////2",DIE="^IBA(364,"
D ^DIE
Q
;
REMCLM1(IB364) ;;JWS;IB*2.0*665v17;EBILL-2241;11/2/21;found at Miami; again at Miami 12/3/21 (similar at Tongus, Orlando, West Palm) - bad entry in 364 file
;remove bad 364 entry
N DA,D0,DR,DIE,DIC,DIK
I +IB364=0 Q
S DA=IB364
S DIK="^IBA(364," D ^DIK
Q
;
;JWS;IB*2.0*641v13
TEST608(IBIEN364) ;return claim test flag;flag only for conditional inclusion of COB info on claim data
N IBTEST,IBXIEN,IBTXTEST
S IBTEST=$$GET1^DIQ(364,IBIEN364_",",.07,"I")
S IBXIEN=+$G(^IBA(364,IBIEN364,0)),IBNF=""
S IBTXTEST=$S(IBTEST:2,1:+$$TEST^IBCEF4(IBXIEN))
Q $S(IBTXTEST=0:0,1:1)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCE837I 6916 printed Apr 09, 2024@21:28:17 Page 2
IBCE837I ;EDE/JWS - OUTPUT FOR 837 FHIR TRANSMISSION ;5/23/18 10:48am
+1 ;;2.0;INTEGRATED BILLING;**623,641,650,665,742**;23-MAY-18;Build 36
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
RES(RES) ;Set resource name correctly
+1 ;
+2 ; Get Resource requested, '*' if all resources
+3 IF RES="*"
QUIT RES
+4 ;S RES=$$TITLE^XLFSTR($G(ARG("RES")))
+5 IF RES="Valueset"
SET RES="ValueSet"
GOTO Q
+6 IF RES="Explanationofbenefit"
SET RES="ExplanationOfBenefit"
GOTO Q
+7 IF RES="Imagingstudy"
SET RES="ImagingStudy"
GOTO Q
+8 IF RES="Careplan"
SET RES="CarePlan"
GOTO Q
+9 IF RES="Episodeofcare"
SET RES="EpisodeOfCare"
GOTO Q
+10 IF RES="Documentmanifest"
SET RES="DocumentManifest"
GOTO Q
+11 IF RES="Claimresponse"
SET RES="ClaimResponse"
GOTO Q
+12 IF RES="Eligibilityrequest"
SET RES="EligibilityRequest"
GOTO Q
+13 IF RES="Chargeitem"
SET RES="ChargeItem"
GOTO Q
+14 IF RES="Procedurerequest"
SET RES="ProcedureRequest"
GOTO Q
+15 IF RES="Healthcareservice"
SET RES="HealthcareService"
GOTO Q
+16 IF RES="Relatedperson"
SET RES="RelatedPerson"
GOTO Q
+17 IF RES="Paymentnotice"
SET RES="PaymentNotice"
GOTO Q
+18 IF RES="Medicationrequest"
SET RES="MedicationRequest"
GOTO Q
+19 IF RES="Medicationdispense"
SET RES="MedicationDispense"
GOTO Q
+20 IF RES="Practitionerrole"
SET RES="PractitionerRole"
GOTO Q
+21 IF RES="Supplyrequest"
SET RES="SupplyRequest"
Q ;
+1 QUIT RES
+2 ;
FINISH ; enclose message in '[ ]' when a Bundle
+1 NEW X
+2 IF $GET(RESULT(1))=""!($GET(RESULT(1))="{}")
SET RESULT(1)="[{}]"
QUIT
+3 IF $GET(RES)="*"
Begin DoDot:1
+4 SET RESULT(1)="{""Bundle"":["_RESULT(1)
+5 SET X=$ORDER(RESULT("A"),-1)
+6 SET RESULT(X)=RESULT(X)_"]}"
End DoDot:1
+7 SET RESULT(1)="["_RESULT(1)
+8 SET X=$ORDER(RESULT("A"),-1)
+9 SET RESULT(X)=RESULT(X)_"]"
+10 QUIT
+11 ;
END ; enclose message in '[ ]'
+1 NEW X
+2 IF $GET(RESULT(1))=""
SET RESULT(1)="{}"
+3 SET RESULT(1)="["_$GET(RESULT(1))_"]"
+4 QUIT
+5 ;
GET(RESULT,ARG) ;RPC - EDICLAIMS; get list of claims to transmit
+1 ;
+2 ;D APPERROR^%ZTER("RPC USER") ; WCJ TEMP LINE TO SEE SOME VARIABLES
+3 NEW CT,DUZ,IBGBL,IBX,IBTEST,IBXIEN,IB0,IBTXST,IBTXTEST,IBBTYP,IBDIV,IB837R,IBNF,IBNOTX,MCNT
+4 KILL ^TMP($JOB,"BILL"),^TMP($JOB,"FHIR837")
+5 ;JWS;IB*2.0*650v7;3/16/21;remove setting of DUZ(0)
+6 DO DTNOLF^DICRW
+7 SET IBGBL="^IBA(364,""AC"",1)"
SET CT=1
+8 ;JWS;IB*2.0*641v8;added MCNT for maximum count of claims IENs, >20,000 breaks FHIR
+9 SET IBX=""
FOR
SET IBX=$ORDER(@IBGBL@(IBX))
if 'IBX
QUIT
Begin DoDot:1
+10 SET IBTEST=$$GET1^DIQ(364,IBX_",",.07,"I")
+11 SET IBXIEN=+$GET(^IBA(364,IBX,0))
SET IBNF=""
+12 ;JWS;IB*2.0*665v17;EBILL-2241;11/2/21;found at Miami; again at Miami 12/3/21 (similar at Tongus, Orlando, West Palm) - bad entry in 364 file
+13 IF IBXIEN=0
DO REMCLM1(IBX)
QUIT
+14 SET IB0=$GET(^DGCR(399,IBXIEN,0))
+15 SET IBTXST=$$TXMT^IBCEF4(IBXIEN,.IBNOTX,IBNF)
+16 ;JWS;IB*2.0*623v25;if claim is invalid to send, remove from 'AC' index
+17 ; no txmt
IF IBTXST=""
DO REMCLM(IBX)
QUIT
+18 IF IB0=""
DO REMCLM(IBX)
QUIT
+19 IF $PIECE(IB0,U,13)>4
IF 'IBTEST
DO REMCLM(IBX)
QUIT
+20 IF $FIND($PIECE(IB0,U),"-")
DO REMCLM(IBX)
QUIT
+21 ;JWS;end IB*2.0*623v25;
+22 SET IBTXTEST=$SELECT(IBTEST:2,1:+$$TEST^IBCEF4(IBXIEN))
+23 SET IBBTYP=$PIECE("P^I^D",U,$SELECT($$FT^IBCEF(IBXIEN)=7:3,1:($$FT^IBCEF(IBXIEN)=3)+1))_"-"_IBTXTEST
+24 ;JWS;IB*2.0*623v25;if not sending, remove from queue
+25 IF $$TESTPT^IBCEU($PIECE(IB0,U,2))
IF 'IBTXTEST
DO REMCLM(IBX)
QUIT
+26 ;JWS;IB*2.0*623v25;if not sending, remove from queue
+27 ; do not send duplicates
IF $DATA(^TMP($JOB,"BILL",$PIECE(IB0,U)))
DO REMCLM(IBX)
QUIT
+28 ;JWS;IB*2.0*641v8;added MCNT for maximum count of claims IENs, >20,000 breaks FHIR
+29 SET ^TMP($JOB,"BILL",$PIECE(IB0,U))=""
SET MCNT=$GET(MCNT)+1
+30 SET IBDIV=$PIECE($SELECT($PIECE(IB0,U,22):$$SITE^VASITE(DT,$PIECE(IB0,U,22)),1:$$SITE^VASITE()),U,3)
+31 SET IB837R=$$RECVR^IBCEF2(IBXIEN)
+32 IF $LENGTH($GET(RESULT(CT)))>3000
SET RESULT(CT)=RESULT(CT)_","
SET CT=$GET(CT)+1
+33 ;;I IBDIV=442 S IBDIV=681 ; for eBilling_dev environment
+34 SET RESULT(CT)=$SELECT($GET(RESULT(CT))'="":RESULT(CT)_",",1:"")_"{""ien"":"""_IBXIEN_""",""site"":"""_IBDIV_""",""type"":"""_IB837R_""",""status"":"""_$SELECT(IBTXTEST=0:"live",1:"test")_"""}"
+35 QUIT
End DoDot:1
IF $GET(MCNT)>19999
QUIT
+36 DO FINISH
+37 QUIT
+38 ;
TESTING ;
+1 ;K (ARG,U)
+2 NEW I,RESOURCE
+3 ; 2113336 - PROF ;2113173 - Dental (1 line) ;2113182 - dental ;211334 - INST
SET ARG("IEN399")=2113336
+4 READ !,"Resource Requested: ",RESOURCE:30
if RESOURCE=""
QUIT
+5 ;"Basic" or "*"
SET ARG("RES")=RESOURCE
+6 DO GET^IBCE837H(.RESULT,.ARG)
+7 FOR I=1:1
if '$DATA(RESULT(I))
QUIT
if I=1
WRITE !
WRITE RESULT(I)
+8 QUIT
+9 ;
REC(REC) ;check to see which records are repeating
+1 IF $FIND(",63,104.8,104.91,105,107,110,112,113,114,115,120,125,130,135,170,170.5,171,172,173,176,177,178,178.1,180,",","_REC_",")
QUIT 1
+2 IF REC>180
QUIT 1
+3 QUIT 0
+4 ;
SETD ; update ^TMP global
+1 SET DONE=1
+2 DO UP
+3 ;S @DATA1@(CT,":")=DATA_FILE_"-"_FLD_"-"_NAME_"("_X1_")""" ; includes record # for testing
+4 ;JWS;6/20/23;EBILL-3508;IB*2.0*742v13;issue with multiple record counter and workaround record deletions. Use IBRECCT(XREC) instead of X2 variable
+5 SET @DATA1@(CT,":")=DATA_FILE_"-"_FLD_$SELECT($$REC(X1):"."_$GET(IBRECCT(XREC)),1:"")_"-"_NAME_""""
+6 DO UP
+7 SET @DATA1@(CT,":")="""value"":"""_TASDATA_"""}"
+8 QUIT
+9 ;
UP ;increment CT
+1 SET CT=$GET(CT)+1
+2 QUIT
+3 ;
SETCLM(IBIEN,IBQ,RSUB) ; set the FHIR 837 claim for submission
+1 NEW DA,D0,DR,DIE,DIC
+2 SET DA=IBIEN
IF DA=""
QUIT
+3 ;JWS;IB*2.0*665v17;EBILL-2241;11/2/21;found at Miami; again at Miami 12/3/21 (similar at Tongus, Orlando, West Palm) - bad entry in 364 file
+4 IF $PIECE($GET(^IBA(364,DA,0)),"^")=""
QUIT
+5 ; if on a non-production server, send to test queue.
IF '$$PROD^XUPROD(1)
SET IBQ="MCT"
+6 ;JWS;IB*2.0*623v24;added field .10 to 364 file entry if a resubmission
+7 SET DR=".09////1"_$SELECT(IBQ="MCT":";.07////1",1:";.07////0")_$SELECT($GET(RSUB)=1:";.1////1",1:"")
SET DIE="^IBA(364,"
+8 DO ^DIE
+9 QUIT
+10 ;JWS;IB*2.0*623v24
+11 ;JWS;IB*2.0*650v5 - add set/clear of field .11, file 364 FHIR Bundle Validation flag [11]
SETSUB(IBIEN,IBVAL,IBFLD) ; clear the resubmission flag
+1 NEW DA,D0,DR,DIE,DIC
+2 SET DA=IBIEN
IF DA=""
QUIT
+3 IF $GET(IBFLD)=".11"
SET DR=".11////"_IBVAL
+4 IF '$TEST
SET DR=".1////"_IBVAL
+5 SET DIE="^IBA(364,"
+6 DO ^DIE
+7 QUIT
+8 ;
TEST(IBIEN364) ; return test flag
+1 NEW IBTEST,IBXIEN,IBTXTEST
+2 SET IBTEST=$$GET1^DIQ(364,IBIEN364_",",.07,"I")
+3 SET IBXIEN=+$GET(^IBA(364,IBIEN364,0))
SET IBNF=""
+4 ;JWS;IB*2.0*623v24;7/19/19 - make sure non-prod claims are sent to test queue
+5 SET IBTXTEST=$SELECT(IBTEST:2,'$$PROD^XUPROD(1):1,1:+$$TEST^IBCEF4(IBXIEN))
+6 ;S IBTXTEST=$S(IBTEST:2,1:+$$TEST^IBCEF4(IBXIEN))
+7 QUIT $SELECT(IBTXTEST=0:0,1:1)
+8 ;
+9 ;JWS;IB*2.0*623;v25
REMCLM(IB364) ; clear the FHIR 837 claim for submission
+1 NEW DA,D0,DR,DIE,DIC
+2 SET DA=IB364
IF DA=""
QUIT
+3 SET DR=".03////Z;.09////2"
SET DIE="^IBA(364,"
+4 DO ^DIE
+5 QUIT
+6 ;
REMCLM1(IB364) ;;JWS;IB*2.0*665v17;EBILL-2241;11/2/21;found at Miami; again at Miami 12/3/21 (similar at Tongus, Orlando, West Palm) - bad entry in 364 file
+1 ;remove bad 364 entry
+2 NEW DA,D0,DR,DIE,DIC,DIK
+3 IF +IB364=0
QUIT
+4 SET DA=IB364
+5 SET DIK="^IBA(364,"
DO ^DIK
+6 QUIT
+7 ;
+8 ;JWS;IB*2.0*641v13
TEST608(IBIEN364) ;return claim test flag;flag only for conditional inclusion of COB info on claim data
+1 NEW IBTEST,IBXIEN,IBTXTEST
+2 SET IBTEST=$$GET1^DIQ(364,IBIEN364_",",.07,"I")
+3 SET IBXIEN=+$GET(^IBA(364,IBIEN364,0))
SET IBNF=""
+4 SET IBTXTEST=$SELECT(IBTEST:2,1:+$$TEST^IBCEF4(IBXIEN))
+5 QUIT $SELECT(IBTXTEST=0:0,1:1)
+6 ;
