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

IBCE837K.m

Go to the documentation of this file.
  1. IBCE837K ;EDE/JWS - ACK FOR 837 FHIR TRANSMISSION ;8/6/18 10:48am
  1. ;;2.0;INTEGRATED BILLING;**623,641,650**;21-MAR-94;Build 21
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. GET(RESULT,ARG) ;RPC - EDIACKCLAIMS; ack queue posting
  1. ;
  1. N IBIEN,IBRES,IB364,IBTEST,IBBILL,IBTXTEST,IBBTYP,IBDESC,IBBATCH,RES,DUZ
  1. K RESULT
  1. ;JWS;IB*2.0*650v7;3/16/21;remove setting of DUZ(0)
  1. D DTNOLF^DICRW
  1. ; Get IEN for Claim File 399
  1. S IBIEN=$G(ARG("IEN399")) ;$G not necessary for VistaLink provides the parameters defined
  1. ; Get IBRES which is the statusCode value of the write to Rabbit MQ 837Transactions queue
  1. ; 837 Business service will not attempt to execute this RPC unless this value = 200, so value will always
  1. ; be = 200
  1. S IBRES=$G(ARG("RES")) ;$G not necessary for VistaLink provides the parameters defined
  1. ; execute code to set claim status as received at FSC
  1. I IBRES'=200 S RES=0 G R
  1. ;;S IB364=$O(^IBA(364,"B",IBIEN,""),-1)
  1. S IB364=$$LAST364^IBCEF4(IBIEN)
  1. ;JWS;IB*2.0*623v24;in case there is a newer entry in file 364... seen once @ IOC vegas 7/22/19
  1. ;JWS;IB*2.0*641v8;after request, 2nd 364 entry was created and transmitted, 1st one errored
  1. I IB364 D
  1. . I '$D(^IBA(364,"AC",1,IB364)) D
  1. .. N X1,OK S X1="A",OK=0 F S X1=$O(^IBA(364,"B",IBIEN,X1),-1) Q:X1="" D I OK Q
  1. ... I $D(^IBA(364,"AC",1,X1)) D
  1. .... I $P(^IBA(364,X1,0),"^",2)="" S DA=X1,DIE="^IBA(364,",DR=".03///C;.09////0" D ^DIE Q
  1. .... S IB364=X1,OK=1 Q
  1. .. I OK Q
  1. .. S X1="A" F S X1=$O(^IBA(364,"B",IBIEN,X1),-1) Q:X1="" I $P(^IBA(364,X1,0),"^",2)'="" S IB364=X1 Q
  1. . ;JWS;IB*2.0*623;7/24/19 make sure non-prod systems are reported posted to test queue
  1. . S IBTEST=$G(^IBA(364,"AC",1,IB364)),IBBILL(IB364)="",IBTXTEST=$S(IBTEST:2,'$$PROD^XUPROD(1):1,1:+$$TEST^IBCEF4(IBIEN)),IBBTYP=$P("P^I^D",U,$S($$FT^IBCEF(IBIEN)=7:3,1:($$FT^IBCEF(IBIEN)=3)+1))_"-"_IBTXTEST
  1. . S IBDESC=$S('IBTXTEST:"",1:"TEST ")_$S($E(IBBTYP)="P":"PROF",$E(IBBTYP)="D":"DENT",1:"INST")_" CLAIM-"_$$HTE^XLFDT($H,2)
  1. . S IBBATCH=$$GET1^DIQ(364,IB364_",",.02,"E")
  1. . D UPD^IBCE837A("",IBBATCH,1,.IBBILL,IBDESC,IBBTYP,"")
  1. . K DIE
  1. . ;JWS/IB*2.0*650v5;clear getBundle validate flag [11] in file 364
  1. . D SETSUB^IBCE837I(IB364,0,.11)
  1. . D EMAIL(IBIEN,IBTXTEST,IBBATCH)
  1. . Q
  1. S RES=1
  1. ;
  1. R ; setup return JSON
  1. ; create JSON structured message
  1. S RES("ien")=IBIEN
  1. S RES("status")=RES ;result of update
  1. D ENCODE^XLFJSONE("RES","RESULT")
  1. D FINISH^IBCE837I
  1. Q
  1. ;
  1. EMAIL(IBIEN,IBTXTEST,IBBATCH) ; Send an email message to MCT mail group - to emulate existing functionality
  1. N ODUZ,IBCLAIM,IBTQ,IBLQ,IBEQ,SUBJ,MSG,XMTO,XMINSTR,IBBATCHN,X
  1. S ODUZ=DUZ,DUZ=.5
  1. S IBCLAIM=$$GET1^DIQ(399,IBIEN_",",.01)
  1. S IBTQ=$$GET1^DIQ(350.9,"1,",8.09)
  1. S IBLQ=$$GET1^DIQ(350.9,"1,",8.01)
  1. ;JWS;IB*2.0*623;6/5/19 - display claim IEN to force uniqueness
  1. ;S X=$P($H,",",2)
  1. S IBEQ=$S(IBTXTEST:IBTQ,1:IBLQ)
  1. S SUBJ="AEG"_IBIEN_" "_IBEQ_" Confirmation"
  1. ;;JWS;IB*2.0*641;2/29/20;display claim IEN, not file 364 ien, subscript error at IOC site
  1. ;;S IBBATCHN=$O(^IBA(364.1,"B",IBBATCH,""))
  1. S MSG(1)="Ref: Your "_IBEQ_" claim ("_IBCLAIM_" #"_IBIEN_")"_" ("_IBBATCH_")"
  1. S MSG(2)="was placed successfully onto the 837Transactions"_$S(IBEQ="MCT":"Test",1:"")
  1. S MSG(3)="queue for Austin to process."
  1. ; ***testing email vs live*** must change back to live before putting in build ***
  1. ;S XMTO("john.smith5@domain.ext")=""
  1. ;S XMTO("william.jutzi@domain.ext")=""
  1. ;S XMTO("VHAeBillingRR@domain.ext")=""
  1. ;;S XMTO("SMITH.JOHN@TAS-EBIL-DEV.AAC.DOMAIN.EXT")=""
  1. S XMTO("G.CLAIMS4US")=""
  1. S XMTO("G."_IBEQ)=""
  1. S XMINSTR("FROM")="VistA-eBilling 837 FHIR Submission Process"
  1. D SENDMSG^XMXAPI(DUZ,SUBJ,"MSG",.XMTO,.XMINSTR)
  1. ;
  1. EMAILX ;
  1. ;
  1. D CLEAN^DILF
  1. S DUZ=ODUZ
  1. Q
  1. ;