- IBCE837H ;EDE/JWS - OUTPUT FOR 837 FHIR TRANSMISSION ;5/23/18 10:48am
- ;;2.0;INTEGRATED BILLING;**623,641,650,665,718**;23-MAY-18;Build 73
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- GET(RESULT,ARG) ;get claim data for TAS Core 837
- ;
- K RESULT
- D CLEANP^IBCE837A
- N IBIEN,RES,IBSIZE,X0,X1,X2,X3,X4,X5,X9,DATA1,FIELD,FIELDS,J,I,DONE,FILE,CT,XREC,IBRECCT,IB364,IBTYPE,IBBDA,IBBNO,XX,IBRSBTST
- ;JWS;IB*2.0*650v7;3/16/21; removed setting of DUZ(0)
- D DTNOLF^DICRW
- K ^TMP($J,"FHIR837")
- ; Get IEN for Claim File 399
- S IBIEN=ARG("IEN399")
- ;JWS;IB*2.0*623;6/26/19 - added ability to find data from claim#
- I IBIEN'=+IBIEN S IBIEN=$O(^DGCR(399,"B",IBIEN,0))
- ; Get Resource requested, '*' if all resources
- S RES=$$TITLE^XLFSTR($G(ARG("RES"))),RES=$$RES^IBCE837I(RES)
- I IBIEN="" D FINISH^IBCE837I Q
- I '$D(^DGCR(399,IBIEN,0)) D FINISH^IBCE837I Q
- ; JWS 1/1/19 - if IEN is invalid, quit
- ; JWS;IB*2.0*623;need to set IBRSBTST if test for patch 608 compliance
- ; JWS;IB*2.0*718;EBILL-2656;last 364 entry was incorrect - rewrote function for 837 only
- S IB364=$$LAST364(IBIEN)
- ; JWS;IB*2.0*641v13;changed from TEST^IBCE837I to TEST608, with no $$PROD check
- S IBRSBTST=$$TEST608^IBCE837I(IB364)
- ; create 837 array of data using Output Formatter for form 8
- ; JWS;EBILL-2667;add 5th parameter to output formatter call to conditionally execute FSC workarounds post execute
- S IBSIZE=$$EXTRACT^IBCEFG(8,IBIEN,1,.XX,1)
- ; do not want to include BGN record in FHIR Transaction data
- K ^TMP("IBXDATA",$J,1,1,1,1),^(2)
- S IBBNO=$P($G(^TMP("IBHDR",$J)),U)
- I IBBNO="" D FINISH^IBCE837I Q ;JWS 1/7/19 if for some reason batch # is null
- ;;JWS 3/19/19-use function to get IB364 entry
- ;S IB364=$O(^IBA(364,"B",IBIEN,""),-1)
- ; JWS;IB*2.0*718;EBILL-2656;was getting wrong 364 entry - resetting just incase it was stepped on during $$EXTRACT execution
- S IB364=$$LAST364(IBIEN)
- S IBBDA=$O(^IBA(364.1,"B",IBBNO,""))
- S DR=".02////"_IBBDA
- S DIE="^IBA(364,",DA=IB364 D ^DIE K DIE,DIC,DA,DINUM,DO,DD,DR
- ; loop thru 837 flat file data records and fields
- S X1="" F S X1=$O(^TMP("IBXDATA",$J,1,X1)) Q:X1="" S X2="" F S X2=$O(^TMP("IBXDATA",$J,1,X1,X2)) Q:X2="" D
- . ; do not include blank record data
- . I '$O(^TMP("IBXDATA",$J,1,X1,X2,1)) K ^(1) Q
- . ; build array of # of occurrences of each record
- . S XREC=$G(^(1)),XREC=$TR(XREC," ","") I XREC="" Q
- . S IBRECCT(XREC)=$G(IBRECCT(XREC))+1
- . ; for each field with data, get the Output Formatter defined field name
- . S X4="" F S X4=$O(^TMP("IBXDATA",$J,1,X1,X2,X4)) Q:X4="" D
- .. I $F(X4,".") Q
- .. I X4=99 Q
- .. ; field ien of file 364.6
- .. S X5=$O(^IBA(364.6,"D","8,"_X1_",1,"_X4,0)) I X5="" Q
- .. ; [10] field name defined in output formatter
- .. S FIELD=$P(^IBA(364.6,X5,0),"^",10)
- .. I FIELD["BLANK" Q
- .. I FIELD["RECORD ID" S FIELD="RECORD ID"
- .. ; get data from output formatter
- .. S X0=$G(^TMP("IBXDATA",$J,1,X1,X2,X4))
- .. I X0="" Q
- .. I X4=1 S X0=$TR(X0," ","")
- .. S X0=$$UP^XLFSTR(X0)
- .. ;JWS;IB*2.0*623;problem with embedded " in data
- .. I $F(X0,"""") S X0=$TR(X0,"""","'")
- .. ;JWS;8/17/21;IB*2.0*665;potential problem with embedded $c(13) in data
- .. I $F(X0,$C(13)) S X0=$TR(X0,$C(13),"")
- .. ;JWS;8/9/21;IB*2.0*665;DE7410;embedded backslash '\' causing VistaLink/FHIR Server issue
- .. I $F(X0,"\") S X0=$$ESC^XLFJSONE(X0)
- .. I RES'="*" D Q
- ... S DATA1="^TMP($J,""FHIR837"","""_RES_""")"
- ... D SET^IBCE837L(RES,X1,X4,FIELD,X0)
- .. F J="Basic","Organization","ValueSet","Coverage","Claim","Practitioner","Patient","Observation" S DATA1="^TMP($J,""FHIR837"","""_J_""")" D SET^IBCE837L(J,X1,X4,FIELD,X0) I DONE Q
- .. F J="Location","ExplanationOfBenefit","Condition","Encounter","Procedure","ImagingStudy","CarePlan","EpisodeOfCare" S DATA1="^TMP($J,""FHIR837"","""_J_""")" D SET^IBCE837L(J,X1,X4,FIELD,X0) I DONE Q
- .. F J="DocumentManifest","Communication","ClaimResponse","EligibilityRequest","ChargeItem","ProcedureRequest" S DATA1="^TMP($J,""FHIR837"","""_J_""")" D SET^IBCE837L(J,X1,X4,FIELD,X0) I DONE Q
- .. F J="HealthcareService","RelatedPerson","Person","PaymentNotice","MedicationRequest","Medication" S DATA1="^TMP($J,""FHIR837"","""_J_""")" D SET^IBCE837L(J,X1,X4,FIELD,X0) I DONE Q
- .. F J="MedicationDispense","PractitionerRole","SupplyRequest" S DATA1="^TMP($J,""FHIR837"","""_J_""")" D SET^IBCE837L(J,X1,X4,FIELD,X0) I DONE Q
- .. Q
- . Q
- S X9="" F S X9=$O(IBRECCT(X9)) Q:X9="" D
- . D UP^IBCE837I
- . S ^TMP($J,"FHIR837","RecCount",CT,":")="{""valueString"":"_""""_X9_""""
- . D UP^IBCE837I
- . S ^TMP($J,"FHIR837","RecCount",CT,":")="""value"":"_""""_IBRECCT(X9)_"""}"
- ; add claim type (live or test) to JSON message
- ;;S IB364=$O(^IBA(364,"B",IBIEN,""),-1)
- ;moved up 6/27/19;S IBTYPE=$$TEST^IBCE837I(IB364)
- D UP^IBCE837I
- S ^TMP($J,"FHIR837","RecCount",CT,":")="{""valueString"":"_"""status"""
- D UP^IBCE837I
- ;JWS;IB*2.0*623v24;reset IBRSBTST just in case it's been reused somewhere
- S IBRSBTST=$$TEST^IBCE837I(IB364)
- S ^TMP($J,"FHIR837","RecCount",CT,":")="""value"":"_""""_$S(IBRSBTST=0:"live",1:"test")_"""}"
- ;JWS;IB*2.0*623v24;add re-submission flag, if defined
- ;JWS/IB*2.0*650;or check getBundle validate flag, [10]=0,[11]=1, then previous validDuplicate submission getBundle failed
- I $$GET1^DIQ(364,IB364_",",.1,"I")!$$GET1^DIQ(364,IB364_",",.11,"I") D
- . D UP^IBCE837I
- . S ^TMP($J,"FHIR837","RecCount",CT,":")="{""valueString"":"_"""isValidDuplicate"""
- . D UP^IBCE837I
- . S ^TMP($J,"FHIR837","RecCount",CT,":")="""value"":"_"""true""}"
- . D SETSUB^IBCE837I(IB364,0)
- . ;JWS/IB*2.0*650v5;set getBundle validate flag
- . D SETSUB^IBCE837I(IB364,1,.11)
- ; create JSON structured message
- D ENCODE^XLFJSONE("^TMP($J,""FHIR837"")","RESULT")
- D FINISH^IBCE837I
- ; clean up
- D CLEANP^IBCE837A
- Q
- ;
- ; JWS;IB*2.0*718;EBILL-2656;last 364 entry was incorrect - rewrote function for 837 only
- LAST364(IBIEN399) ;
- N X1,X2,XST,OK
- S OK=0
- S X1="" F S X1=$O(^IBA(364,"ABDT",IBIEN399,X1),-1) Q:X1="" D Q:OK
- . S X2="" F S X2=$O(^IBA(364,"ABDT",IBIEN399,X1,X2),-1) Q:X2="" D Q:OK
- .. S XST=$P(^IBA(364,X2,0),"^",3) I '$F(".C.R.E.Z.","."_XST_".") S OK=1 Q
- . Q
- I +X2=0 S X2=$$LAST364^IBCEF4(IBIEN399)
- Q +X2
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCE837H 6244 printed Feb 18, 2025@23:35:52 Page 2
- IBCE837H ;EDE/JWS - OUTPUT FOR 837 FHIR TRANSMISSION ;5/23/18 10:48am
- +1 ;;2.0;INTEGRATED BILLING;**623,641,650,665,718**;23-MAY-18;Build 73
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- GET(RESULT,ARG) ;get claim data for TAS Core 837
- +1 ;
- +2 KILL RESULT
- +3 DO CLEANP^IBCE837A
- +4 NEW IBIEN,RES,IBSIZE,X0,X1,X2,X3,X4,X5,X9,DATA1,FIELD,FIELDS,J,I,DONE,FILE,CT,XREC,IBRECCT,IB364,IBTYPE,IBBDA,IBBNO,XX,IBRSBTST
- +5 ;JWS;IB*2.0*650v7;3/16/21; removed setting of DUZ(0)
- +6 DO DTNOLF^DICRW
- +7 KILL ^TMP($JOB,"FHIR837")
- +8 ; Get IEN for Claim File 399
- +9 SET IBIEN=ARG("IEN399")
- +10 ;JWS;IB*2.0*623;6/26/19 - added ability to find data from claim#
- +11 IF IBIEN'=+IBIEN
- SET IBIEN=$ORDER(^DGCR(399,"B",IBIEN,0))
- +12 ; Get Resource requested, '*' if all resources
- +13 SET RES=$$TITLE^XLFSTR($GET(ARG("RES")))
- SET RES=$$RES^IBCE837I(RES)
- +14 IF IBIEN=""
- DO FINISH^IBCE837I
- QUIT
- +15 IF '$DATA(^DGCR(399,IBIEN,0))
- DO FINISH^IBCE837I
- QUIT
- +16 ; JWS 1/1/19 - if IEN is invalid, quit
- +17 ; JWS;IB*2.0*623;need to set IBRSBTST if test for patch 608 compliance
- +18 ; JWS;IB*2.0*718;EBILL-2656;last 364 entry was incorrect - rewrote function for 837 only
- +19 SET IB364=$$LAST364(IBIEN)
- +20 ; JWS;IB*2.0*641v13;changed from TEST^IBCE837I to TEST608, with no $$PROD check
- +21 SET IBRSBTST=$$TEST608^IBCE837I(IB364)
- +22 ; create 837 array of data using Output Formatter for form 8
- +23 ; JWS;EBILL-2667;add 5th parameter to output formatter call to conditionally execute FSC workarounds post execute
- +24 SET IBSIZE=$$EXTRACT^IBCEFG(8,IBIEN,1,.XX,1)
- +25 ; do not want to include BGN record in FHIR Transaction data
- +26 KILL ^TMP("IBXDATA",$JOB,1,1,1,1),^(2)
- +27 SET IBBNO=$PIECE($GET(^TMP("IBHDR",$JOB)),U)
- +28 ;JWS 1/7/19 if for some reason batch # is null
- IF IBBNO=""
- DO FINISH^IBCE837I
- QUIT
- +29 ;;JWS 3/19/19-use function to get IB364 entry
- +30 ;S IB364=$O(^IBA(364,"B",IBIEN,""),-1)
- +31 ; JWS;IB*2.0*718;EBILL-2656;was getting wrong 364 entry - resetting just incase it was stepped on during $$EXTRACT execution
- +32 SET IB364=$$LAST364(IBIEN)
- +33 SET IBBDA=$ORDER(^IBA(364.1,"B",IBBNO,""))
- +34 SET DR=".02////"_IBBDA
- +35 SET DIE="^IBA(364,"
- SET DA=IB364
- DO ^DIE
- KILL DIE,DIC,DA,DINUM,DO,DD,DR
- +36 ; loop thru 837 flat file data records and fields
- +37 SET X1=""
- FOR
- SET X1=$ORDER(^TMP("IBXDATA",$JOB,1,X1))
- if X1=""
- QUIT
- SET X2=""
- FOR
- SET X2=$ORDER(^TMP("IBXDATA",$JOB,1,X1,X2))
- if X2=""
- QUIT
- Begin DoDot:1
- +38 ; do not include blank record data
- +39 IF '$ORDER(^TMP("IBXDATA",$JOB,1,X1,X2,1))
- KILL ^(1)
- QUIT
- +40 ; build array of # of occurrences of each record
- +41 SET XREC=$GET(^(1))
- SET XREC=$TRANSLATE(XREC," ","")
- IF XREC=""
- QUIT
- +42 SET IBRECCT(XREC)=$GET(IBRECCT(XREC))+1
- +43 ; for each field with data, get the Output Formatter defined field name
- +44 SET X4=""
- FOR
- SET X4=$ORDER(^TMP("IBXDATA",$JOB,1,X1,X2,X4))
- if X4=""
- QUIT
- Begin DoDot:2
- +45 IF $FIND(X4,".")
- QUIT
- +46 IF X4=99
- QUIT
- +47 ; field ien of file 364.6
- +48 SET X5=$ORDER(^IBA(364.6,"D","8,"_X1_",1,"_X4,0))
- IF X5=""
- QUIT
- +49 ; [10] field name defined in output formatter
- +50 SET FIELD=$PIECE(^IBA(364.6,X5,0),"^",10)
- +51 IF FIELD["BLANK"
- QUIT
- +52 IF FIELD["RECORD ID"
- SET FIELD="RECORD ID"
- +53 ; get data from output formatter
- +54 SET X0=$GET(^TMP("IBXDATA",$JOB,1,X1,X2,X4))
- +55 IF X0=""
- QUIT
- +56 IF X4=1
- SET X0=$TRANSLATE(X0," ","")
- +57 SET X0=$$UP^XLFSTR(X0)
- +58 ;JWS;IB*2.0*623;problem with embedded " in data
- +59 IF $FIND(X0,"""")
- SET X0=$TRANSLATE(X0,"""","'")
- +60 ;JWS;8/17/21;IB*2.0*665;potential problem with embedded $c(13) in data
- +61 IF $FIND(X0,$CHAR(13))
- SET X0=$TRANSLATE(X0,$CHAR(13),"")
- +62 ;JWS;8/9/21;IB*2.0*665;DE7410;embedded backslash '\' causing VistaLink/FHIR Server issue
- +63 IF $FIND(X0,"\")
- SET X0=$$ESC^XLFJSONE(X0)
- +64 IF RES'="*"
- Begin DoDot:3
- +65 SET DATA1="^TMP($J,""FHIR837"","""_RES_""")"
- +66 DO SET^IBCE837L(RES,X1,X4,FIELD,X0)
- End DoDot:3
- QUIT
- +67 FOR J="Basic","Organization","ValueSet","Coverage","Claim","Practitioner","Patient","Observation"
- SET DATA1="^TMP($J,""FHIR837"","""_J_""")"
- DO SET^IBCE837L(J,X1,X4,FIELD,X0)
- IF DONE
- QUIT
- +68 FOR J="Location","ExplanationOfBenefit","Condition","Encounter","Procedure","ImagingStudy","CarePlan","EpisodeOfCare"
- SET DATA1="^TMP($J,""FHIR837"","""_J_""")"
- DO SET^IBCE837L(J,X1,X4,FIELD,X0)
- IF DONE
- QUIT
- +69 FOR J="DocumentManifest","Communication","ClaimResponse","EligibilityRequest","ChargeItem","ProcedureRequest"
- SET DATA1="^TMP($J,""FHIR837"","""_J_""")"
- DO SET^IBCE837L(J,X1,X4,FIELD,X0)
- IF DONE
- QUIT
- +70 FOR J="HealthcareService","RelatedPerson","Person","PaymentNotice","MedicationRequest","Medication"
- SET DATA1="^TMP($J,""FHIR837"","""_J_""")"
- DO SET^IBCE837L(J,X1,X4,FIELD,X0)
- IF DONE
- QUIT
- +71 FOR J="MedicationDispense","PractitionerRole","SupplyRequest"
- SET DATA1="^TMP($J,""FHIR837"","""_J_""")"
- DO SET^IBCE837L(J,X1,X4,FIELD,X0)
- IF DONE
- QUIT
- +72 QUIT
- End DoDot:2
- +73 QUIT
- End DoDot:1
- +74 SET X9=""
- FOR
- SET X9=$ORDER(IBRECCT(X9))
- if X9=""
- QUIT
- Begin DoDot:1
- +75 DO UP^IBCE837I
- +76 SET ^TMP($JOB,"FHIR837","RecCount",CT,":")="{""valueString"":"_""""_X9_""""
- +77 DO UP^IBCE837I
- +78 SET ^TMP($JOB,"FHIR837","RecCount",CT,":")="""value"":"_""""_IBRECCT(X9)_"""}"
- End DoDot:1
- +79 ; add claim type (live or test) to JSON message
- +80 ;;S IB364=$O(^IBA(364,"B",IBIEN,""),-1)
- +81 ;moved up 6/27/19;S IBTYPE=$$TEST^IBCE837I(IB364)
- +82 DO UP^IBCE837I
- +83 SET ^TMP($JOB,"FHIR837","RecCount",CT,":")="{""valueString"":"_"""status"""
- +84 DO UP^IBCE837I
- +85 ;JWS;IB*2.0*623v24;reset IBRSBTST just in case it's been reused somewhere
- +86 SET IBRSBTST=$$TEST^IBCE837I(IB364)
- +87 SET ^TMP($JOB,"FHIR837","RecCount",CT,":")="""value"":"_""""_$SELECT(IBRSBTST=0:"live",1:"test")_"""}"
- +88 ;JWS;IB*2.0*623v24;add re-submission flag, if defined
- +89 ;JWS/IB*2.0*650;or check getBundle validate flag, [10]=0,[11]=1, then previous validDuplicate submission getBundle failed
- +90 IF $$GET1^DIQ(364,IB364_",",.1,"I")!$$GET1^DIQ(364,IB364_",",.11,"I")
- Begin DoDot:1
- +91 DO UP^IBCE837I
- +92 SET ^TMP($JOB,"FHIR837","RecCount",CT,":")="{""valueString"":"_"""isValidDuplicate"""
- +93 DO UP^IBCE837I
- +94 SET ^TMP($JOB,"FHIR837","RecCount",CT,":")="""value"":"_"""true""}"
- +95 DO SETSUB^IBCE837I(IB364,0)
- +96 ;JWS/IB*2.0*650v5;set getBundle validate flag
- +97 DO SETSUB^IBCE837I(IB364,1,.11)
- End DoDot:1
- +98 ; create JSON structured message
- +99 DO ENCODE^XLFJSONE("^TMP($J,""FHIR837"")","RESULT")
- +100 DO FINISH^IBCE837I
- +101 ; clean up
- +102 DO CLEANP^IBCE837A
- +103 QUIT
- +104 ;
- +105 ; JWS;IB*2.0*718;EBILL-2656;last 364 entry was incorrect - rewrote function for 837 only
- LAST364(IBIEN399) ;
- +1 NEW X1,X2,XST,OK
- +2 SET OK=0
- +3 SET X1=""
- FOR
- SET X1=$ORDER(^IBA(364,"ABDT",IBIEN399,X1),-1)
- if X1=""
- QUIT
- Begin DoDot:1
- +4 SET X2=""
- FOR
- SET X2=$ORDER(^IBA(364,"ABDT",IBIEN399,X1,X2),-1)
- if X2=""
- QUIT
- Begin DoDot:2
- +5 SET XST=$PIECE(^IBA(364,X2,0),"^",3)
- IF '$FIND(".C.R.E.Z.","."_XST_".")
- SET OK=1
- QUIT
- End DoDot:2
- if OK
- QUIT
- +6 QUIT
- End DoDot:1
- if OK
- QUIT
- +7 IF +X2=0
- SET X2=$$LAST364^IBCEF4(IBIEN399)
- +8 QUIT +X2
- +9 ;