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 Apr 09, 2024@21:22:36 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 ;
