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