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

IBCE837I.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. RES(RES) ;Set resource name correctly
  1. ;
  1. ; Get Resource requested, '*' if all resources
  1. I RES="*" Q RES
  1. ;S RES=$$TITLE^XLFSTR($G(ARG("RES")))
  1. I RES="Valueset" S RES="ValueSet" G Q
  1. I RES="Explanationofbenefit" S RES="ExplanationOfBenefit" G Q
  1. I RES="Imagingstudy" S RES="ImagingStudy" G Q
  1. I RES="Careplan" S RES="CarePlan" G Q
  1. I RES="Episodeofcare" S RES="EpisodeOfCare" G Q
  1. I RES="Documentmanifest" S RES="DocumentManifest" G Q
  1. I RES="Claimresponse" S RES="ClaimResponse" G Q
  1. I RES="Eligibilityrequest" S RES="EligibilityRequest" G Q
  1. I RES="Chargeitem" S RES="ChargeItem" G Q
  1. I RES="Procedurerequest" S RES="ProcedureRequest" G Q
  1. I RES="Healthcareservice" S RES="HealthcareService" G Q
  1. I RES="Relatedperson" S RES="RelatedPerson" G Q
  1. I RES="Paymentnotice" S RES="PaymentNotice" G Q
  1. I RES="Medicationrequest" S RES="MedicationRequest" G Q
  1. I RES="Medicationdispense" S RES="MedicationDispense" G Q
  1. I RES="Practitionerrole" S RES="PractitionerRole" G Q
  1. I RES="Supplyrequest" S RES="SupplyRequest"
  1. Q ;
  1. Q RES
  1. ;
  1. FINISH ; enclose message in '[ ]' when a Bundle
  1. N X
  1. I $G(RESULT(1))=""!($G(RESULT(1))="{}") S RESULT(1)="[{}]" Q
  1. I $G(RES)="*" D
  1. . S RESULT(1)="{""Bundle"":["_RESULT(1)
  1. . S X=$O(RESULT("A"),-1)
  1. . S RESULT(X)=RESULT(X)_"]}"
  1. S RESULT(1)="["_RESULT(1)
  1. S X=$O(RESULT("A"),-1)
  1. S RESULT(X)=RESULT(X)_"]"
  1. Q
  1. ;
  1. END ; enclose message in '[ ]'
  1. N X
  1. I $G(RESULT(1))="" S RESULT(1)="{}"
  1. S RESULT(1)="["_$G(RESULT(1))_"]"
  1. Q
  1. ;
  1. GET(RESULT,ARG) ;RPC - EDICLAIMS; get list of claims to transmit
  1. ;
  1. ;D APPERROR^%ZTER("RPC USER") ; WCJ TEMP LINE TO SEE SOME VARIABLES
  1. N CT,DUZ,IBGBL,IBX,IBTEST,IBXIEN,IB0,IBTXST,IBTXTEST,IBBTYP,IBDIV,IB837R,IBNF,IBNOTX,MCNT
  1. K ^TMP($J,"BILL"),^TMP($J,"FHIR837")
  1. ;JWS;IB*2.0*650v7;3/16/21;remove setting of DUZ(0)
  1. D DTNOLF^DICRW
  1. S IBGBL="^IBA(364,""AC"",1)",CT=1
  1. ;JWS;IB*2.0*641v8;added MCNT for maximum count of claims IENs, >20,000 breaks FHIR
  1. S IBX="" F S IBX=$O(@IBGBL@(IBX)) Q:'IBX D I $G(MCNT)>19999 Q
  1. . S IBTEST=$$GET1^DIQ(364,IBX_",",.07,"I")
  1. . S IBXIEN=+$G(^IBA(364,IBX,0)),IBNF=""
  1. . ;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. . I IBXIEN=0 D REMCLM1(IBX) Q
  1. . S IB0=$G(^DGCR(399,IBXIEN,0))
  1. . S IBTXST=$$TXMT^IBCEF4(IBXIEN,.IBNOTX,IBNF)
  1. . ;JWS;IB*2.0*623v25;if claim is invalid to send, remove from 'AC' index
  1. . I IBTXST="" D REMCLM(IBX) Q ; no txmt
  1. . I IB0="" D REMCLM(IBX) Q
  1. . I $P(IB0,U,13)>4,'IBTEST D REMCLM(IBX) Q
  1. . I $F($P(IB0,U),"-") D REMCLM(IBX) Q
  1. . ;JWS;end IB*2.0*623v25;
  1. . S IBTXTEST=$S(IBTEST:2,1:+$$TEST^IBCEF4(IBXIEN))
  1. . S IBBTYP=$P("P^I^D",U,$S($$FT^IBCEF(IBXIEN)=7:3,1:($$FT^IBCEF(IBXIEN)=3)+1))_"-"_IBTXTEST
  1. . ;JWS;IB*2.0*623v25;if not sending, remove from queue
  1. . I $$TESTPT^IBCEU($P(IB0,U,2)),'IBTXTEST D REMCLM(IBX) Q
  1. . ;JWS;IB*2.0*623v25;if not sending, remove from queue
  1. . I $D(^TMP($J,"BILL",$P(IB0,U))) D REMCLM(IBX) Q ; do not send duplicates
  1. . ;JWS;IB*2.0*641v8;added MCNT for maximum count of claims IENs, >20,000 breaks FHIR
  1. . S ^TMP($J,"BILL",$P(IB0,U))="",MCNT=$G(MCNT)+1
  1. . S IBDIV=$P($S($P(IB0,U,22):$$SITE^VASITE(DT,$P(IB0,U,22)),1:$$SITE^VASITE()),U,3)
  1. . S IB837R=$$RECVR^IBCEF2(IBXIEN)
  1. . I $L($G(RESULT(CT)))>3000 S RESULT(CT)=RESULT(CT)_",",CT=$G(CT)+1
  1. . ;;I IBDIV=442 S IBDIV=681 ; for eBilling_dev environment
  1. . S RESULT(CT)=$S($G(RESULT(CT))'="":RESULT(CT)_",",1:"")_"{""ien"":"""_IBXIEN_""",""site"":"""_IBDIV_""",""type"":"""_IB837R_""",""status"":"""_$S(IBTXTEST=0:"live",1:"test")_"""}"
  1. . Q
  1. D FINISH
  1. Q
  1. ;
  1. TESTING ;
  1. ;K (ARG,U)
  1. N I,RESOURCE
  1. S ARG("IEN399")=2113336 ; 2113336 - PROF ;2113173 - Dental (1 line) ;2113182 - dental ;211334 - INST
  1. R !,"Resource Requested: ",RESOURCE:30 Q:RESOURCE=""
  1. S ARG("RES")=RESOURCE ;"Basic" or "*"
  1. D GET^IBCE837H(.RESULT,.ARG)
  1. F I=1:1 Q:'$D(RESULT(I)) W:I=1 ! W RESULT(I)
  1. Q
  1. ;
  1. REC(REC) ;check to see which records are repeating
  1. 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
  1. I REC>180 Q 1
  1. Q 0
  1. ;
  1. SETD ; update ^TMP global
  1. S DONE=1
  1. D UP
  1. ;S @DATA1@(CT,":")=DATA_FILE_"-"_FLD_"-"_NAME_"("_X1_")""" ; includes record # for testing
  1. ;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
  1. S @DATA1@(CT,":")=DATA_FILE_"-"_FLD_$S($$REC(X1):"."_$G(IBRECCT(XREC)),1:"")_"-"_NAME_""""
  1. D UP
  1. S @DATA1@(CT,":")="""value"":"""_TASDATA_"""}"
  1. Q
  1. ;
  1. UP ;increment CT
  1. S CT=$G(CT)+1
  1. Q
  1. ;
  1. SETCLM(IBIEN,IBQ,RSUB) ; set the FHIR 837 claim for submission
  1. N DA,D0,DR,DIE,DIC
  1. S DA=IBIEN I DA="" Q
  1. ;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. I $P($G(^IBA(364,DA,0)),"^")="" Q
  1. I '$$PROD^XUPROD(1) S IBQ="MCT" ; if on a non-production server, send to test queue.
  1. ;JWS;IB*2.0*623v24;added field .10 to 364 file entry if a resubmission
  1. S DR=".09////1"_$S(IBQ="MCT":";.07////1",1:";.07////0")_$S($G(RSUB)=1:";.1////1",1:""),DIE="^IBA(364,"
  1. D ^DIE
  1. Q
  1. ;JWS;IB*2.0*623v24
  1. ;JWS;IB*2.0*650v5 - add set/clear of field .11, file 364 FHIR Bundle Validation flag [11]
  1. SETSUB(IBIEN,IBVAL,IBFLD) ; clear the resubmission flag
  1. N DA,D0,DR,DIE,DIC
  1. S DA=IBIEN I DA="" Q
  1. I $G(IBFLD)=".11" S DR=".11////"_IBVAL
  1. E S DR=".1////"_IBVAL
  1. S DIE="^IBA(364,"
  1. D ^DIE
  1. Q
  1. ;
  1. TEST(IBIEN364) ; return test flag
  1. N IBTEST,IBXIEN,IBTXTEST
  1. S IBTEST=$$GET1^DIQ(364,IBIEN364_",",.07,"I")
  1. S IBXIEN=+$G(^IBA(364,IBIEN364,0)),IBNF=""
  1. ;JWS;IB*2.0*623v24;7/19/19 - make sure non-prod claims are sent to test queue
  1. S IBTXTEST=$S(IBTEST:2,'$$PROD^XUPROD(1):1,1:+$$TEST^IBCEF4(IBXIEN))
  1. ;S IBTXTEST=$S(IBTEST:2,1:+$$TEST^IBCEF4(IBXIEN))
  1. Q $S(IBTXTEST=0:0,1:1)
  1. ;
  1. ;JWS;IB*2.0*623;v25
  1. REMCLM(IB364) ; clear the FHIR 837 claim for submission
  1. N DA,D0,DR,DIE,DIC
  1. S DA=IB364 I DA="" Q
  1. S DR=".03////Z;.09////2",DIE="^IBA(364,"
  1. D ^DIE
  1. Q
  1. ;
  1. 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
  1. N DA,D0,DR,DIE,DIC,DIK
  1. I +IB364=0 Q
  1. S DA=IB364
  1. S DIK="^IBA(364," D ^DIK
  1. Q
  1. ;
  1. ;JWS;IB*2.0*641v13
  1. TEST608(IBIEN364) ;return claim test flag;flag only for conditional inclusion of COB info on claim data
  1. N IBTEST,IBXIEN,IBTXTEST
  1. S IBTEST=$$GET1^DIQ(364,IBIEN364_",",.07,"I")
  1. S IBXIEN=+$G(^IBA(364,IBIEN364,0)),IBNF=""
  1. S IBTXTEST=$S(IBTEST:2,1:+$$TEST^IBCEF4(IBXIEN))
  1. Q $S(IBTXTEST=0:0,1:1)
  1. ;