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

IBCE837H.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. GET(RESULT,ARG) ;get claim data for TAS Core 837
  1. ;
  1. K RESULT
  1. D CLEANP^IBCE837A
  1. 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
  1. ;JWS;IB*2.0*650v7;3/16/21; removed setting of DUZ(0)
  1. D DTNOLF^DICRW
  1. K ^TMP($J,"FHIR837")
  1. ; Get IEN for Claim File 399
  1. S IBIEN=ARG("IEN399")
  1. ;JWS;IB*2.0*623;6/26/19 - added ability to find data from claim#
  1. I IBIEN'=+IBIEN S IBIEN=$O(^DGCR(399,"B",IBIEN,0))
  1. ; Get Resource requested, '*' if all resources
  1. S RES=$$TITLE^XLFSTR($G(ARG("RES"))),RES=$$RES^IBCE837I(RES)
  1. I IBIEN="" D FINISH^IBCE837I Q
  1. I '$D(^DGCR(399,IBIEN,0)) D FINISH^IBCE837I Q
  1. ; JWS 1/1/19 - if IEN is invalid, quit
  1. ; JWS;IB*2.0*623;need to set IBRSBTST if test for patch 608 compliance
  1. ; JWS;IB*2.0*718;EBILL-2656;last 364 entry was incorrect - rewrote function for 837 only
  1. S IB364=$$LAST364(IBIEN)
  1. ; JWS;IB*2.0*641v13;changed from TEST^IBCE837I to TEST608, with no $$PROD check
  1. S IBRSBTST=$$TEST608^IBCE837I(IB364)
  1. ; create 837 array of data using Output Formatter for form 8
  1. ; JWS;EBILL-2667;add 5th parameter to output formatter call to conditionally execute FSC workarounds post execute
  1. S IBSIZE=$$EXTRACT^IBCEFG(8,IBIEN,1,.XX,1)
  1. ; do not want to include BGN record in FHIR Transaction data
  1. K ^TMP("IBXDATA",$J,1,1,1,1),^(2)
  1. S IBBNO=$P($G(^TMP("IBHDR",$J)),U)
  1. I IBBNO="" D FINISH^IBCE837I Q ;JWS 1/7/19 if for some reason batch # is null
  1. ;;JWS 3/19/19-use function to get IB364 entry
  1. ;S IB364=$O(^IBA(364,"B",IBIEN,""),-1)
  1. ; JWS;IB*2.0*718;EBILL-2656;was getting wrong 364 entry - resetting just incase it was stepped on during $$EXTRACT execution
  1. S IB364=$$LAST364(IBIEN)
  1. S IBBDA=$O(^IBA(364.1,"B",IBBNO,""))
  1. S DR=".02////"_IBBDA
  1. S DIE="^IBA(364,",DA=IB364 D ^DIE K DIE,DIC,DA,DINUM,DO,DD,DR
  1. ; loop thru 837 flat file data records and fields
  1. 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
  1. . ; do not include blank record data
  1. . I '$O(^TMP("IBXDATA",$J,1,X1,X2,1)) K ^(1) Q
  1. . ; build array of # of occurrences of each record
  1. . S XREC=$G(^(1)),XREC=$TR(XREC," ","") I XREC="" Q
  1. . S IBRECCT(XREC)=$G(IBRECCT(XREC))+1
  1. . ; for each field with data, get the Output Formatter defined field name
  1. . S X4="" F S X4=$O(^TMP("IBXDATA",$J,1,X1,X2,X4)) Q:X4="" D
  1. .. I $F(X4,".") Q
  1. .. I X4=99 Q
  1. .. ; field ien of file 364.6
  1. .. S X5=$O(^IBA(364.6,"D","8,"_X1_",1,"_X4,0)) I X5="" Q
  1. .. ; [10] field name defined in output formatter
  1. .. S FIELD=$P(^IBA(364.6,X5,0),"^",10)
  1. .. I FIELD["BLANK" Q
  1. .. I FIELD["RECORD ID" S FIELD="RECORD ID"
  1. .. ; get data from output formatter
  1. .. S X0=$G(^TMP("IBXDATA",$J,1,X1,X2,X4))
  1. .. I X0="" Q
  1. .. I X4=1 S X0=$TR(X0," ","")
  1. .. S X0=$$UP^XLFSTR(X0)
  1. .. ;JWS;IB*2.0*623;problem with embedded " in data
  1. .. I $F(X0,"""") S X0=$TR(X0,"""","'")
  1. .. ;JWS;8/17/21;IB*2.0*665;potential problem with embedded $c(13) in data
  1. .. I $F(X0,$C(13)) S X0=$TR(X0,$C(13),"")
  1. .. ;JWS;8/9/21;IB*2.0*665;DE7410;embedded backslash '\' causing VistaLink/FHIR Server issue
  1. .. I $F(X0,"\") S X0=$$ESC^XLFJSONE(X0)
  1. .. I RES'="*" D Q
  1. ... S DATA1="^TMP($J,""FHIR837"","""_RES_""")"
  1. ... D SET^IBCE837L(RES,X1,X4,FIELD,X0)
  1. .. 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
  1. .. 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
  1. .. 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
  1. .. 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
  1. .. F J="MedicationDispense","PractitionerRole","SupplyRequest" S DATA1="^TMP($J,""FHIR837"","""_J_""")" D SET^IBCE837L(J,X1,X4,FIELD,X0) I DONE Q
  1. .. Q
  1. . Q
  1. S X9="" F S X9=$O(IBRECCT(X9)) Q:X9="" D
  1. . D UP^IBCE837I
  1. . S ^TMP($J,"FHIR837","RecCount",CT,":")="{""valueString"":"_""""_X9_""""
  1. . D UP^IBCE837I
  1. . S ^TMP($J,"FHIR837","RecCount",CT,":")="""value"":"_""""_IBRECCT(X9)_"""}"
  1. ; add claim type (live or test) to JSON message
  1. ;;S IB364=$O(^IBA(364,"B",IBIEN,""),-1)
  1. ;moved up 6/27/19;S IBTYPE=$$TEST^IBCE837I(IB364)
  1. D UP^IBCE837I
  1. S ^TMP($J,"FHIR837","RecCount",CT,":")="{""valueString"":"_"""status"""
  1. D UP^IBCE837I
  1. ;JWS;IB*2.0*623v24;reset IBRSBTST just in case it's been reused somewhere
  1. S IBRSBTST=$$TEST^IBCE837I(IB364)
  1. S ^TMP($J,"FHIR837","RecCount",CT,":")="""value"":"_""""_$S(IBRSBTST=0:"live",1:"test")_"""}"
  1. ;JWS;IB*2.0*623v24;add re-submission flag, if defined
  1. ;JWS/IB*2.0*650;or check getBundle validate flag, [10]=0,[11]=1, then previous validDuplicate submission getBundle failed
  1. I $$GET1^DIQ(364,IB364_",",.1,"I")!$$GET1^DIQ(364,IB364_",",.11,"I") D
  1. . D UP^IBCE837I
  1. . S ^TMP($J,"FHIR837","RecCount",CT,":")="{""valueString"":"_"""isValidDuplicate"""
  1. . D UP^IBCE837I
  1. . S ^TMP($J,"FHIR837","RecCount",CT,":")="""value"":"_"""true""}"
  1. . D SETSUB^IBCE837I(IB364,0)
  1. . ;JWS/IB*2.0*650v5;set getBundle validate flag
  1. . D SETSUB^IBCE837I(IB364,1,.11)
  1. ; create JSON structured message
  1. D ENCODE^XLFJSONE("^TMP($J,""FHIR837"")","RESULT")
  1. D FINISH^IBCE837I
  1. ; clean up
  1. D CLEANP^IBCE837A
  1. Q
  1. ;
  1. ; JWS;IB*2.0*718;EBILL-2656;last 364 entry was incorrect - rewrote function for 837 only
  1. LAST364(IBIEN399) ;
  1. N X1,X2,XST,OK
  1. S OK=0
  1. S X1="" F S X1=$O(^IBA(364,"ABDT",IBIEN399,X1),-1) Q:X1="" D Q:OK
  1. . S X2="" F S X2=$O(^IBA(364,"ABDT",IBIEN399,X1,X2),-1) Q:X2="" D Q:OK
  1. .. S XST=$P(^IBA(364,X2,0),"^",3) I '$F(".C.R.E.Z.","."_XST_".") S OK=1 Q
  1. . Q
  1. I +X2=0 S X2=$$LAST364^IBCEF4(IBIEN399)
  1. Q +X2
  1. ;