- 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 Feb 18, 2025@23:35:54 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 ;