IBECECQ1 ;BSL/DVA-BILLING - SEND/RECEIVE QRY & DSR HL7 messages FOR PATIENT ACCUMULATOR INTERFACE ; 01 Jun 2022 7:17 AM
;;2.0;INTEGRATED BILLING;**704**;21-MAR-94;Build 49
;Per VA Directive 6402, this routine should not be modified.
;
; Reference to $$STARTMSG^HLOPRS,$$NEXTSEG^HLOPRS,$$GET^HLOPRS,$$MSGID^HLOPRS in ICR #4718
; Reference to $$ADDSEG^HLOAPI,$$NEWMSG^HLOAPI,SET^HLOAPI in ICR #4722
; Reference to $$SENDONE^HLOAPI1 in ICR #4717
;
; -4200Build and send seeding of Vista data to DAS SPOE IBECEAC-QRY DSR^Q03
; Receive seeding query of Vista data from DAS SPOE IBECEAC-QRY DSR^Q03
;
; Sample message
;MSH|^~\&||695^HL7.IVMVEE.FO-ALBANY.DOMAIN.EXT:5127^DNS|IBECECQ-QRYRESP|200DAS^:^DNS|20211001094308-0500||QRY^RO2^QRY_RO2|695 1469|T^|2.3|||AL|NE|USA
;QRD|20211008123254-0500|1|1||||1|DRI^DODMORE MESSAGE|1008713999V404928
;QRF|IBECEAC-QRY|20161106|20161107
;
Q ;No direct routine calls
;
ADM ;Called from IB MEANS TEST BILLING protocol
Q:$P($G(DGPMA),"^",2)'=1
D EN(DFN)
Q
;
EDTCLCK(DFN,IBADMIT) ;Called from Billing CLock Maintenance option
N IBTRYTIL,IBECDT,IBECLDT,IBECIEN,IBECSTDT,IBECENDT,IBNOW
Q:'$$ICN^IBARXMU(DFN) ;Do not run query of patient does not have an ICN
D MTEQRY(DFN,IBADMIT) ;Run Query
W !,"Running Billing Clock Query, please wait."
S IBFLAG1=0 S IBTRYTIL=$$FMADD^XLFDT($$NOW^XLFDT,,,1),IBNOW=$$NOW^XLFDT F Q:$$NOW^XLFDT>IBTRYTIL Q:IBFLAG1 D
.H 2 W "." S IBECDT1=-(IBADMIT_.9999) F S IBECDT1=$O(^IBE(351,"AIVDT",DFN,IBECDT1)) Q:'IBECDT1 S IBECIEN=$O(^IBE(351,"AIVDT",DFN,IBECDT1,";"),-1) Q:'IBECIEN D
..S IBECLDT=$$GET1^DIQ(351,IBECIEN_",",.04,"I") Q:IBECLDT=3 D
...S IBECSTDT=$$GET1^DIQ(351,IBECIEN_",",.03,"I"),IBECENDT=$$GET1^DIQ(351,IBECIEN_",",.1,"I"),IBECENDT=$S(IBECENDT:IBECENDT,IBECLDT=2:($$CLSDT^IBECECX1(IBECSTDT)),1:DT) D
....I (IBECENDT>=IBADMIT),$$GET1^DIQ(351,IBECIEN_",",14,"I")>IBNOW,$P(^IBE(351,IBECIEN,1),U,5) S IBFLAG1=1,IBECDA=IBECIEN Q
Q
;
MTEQRY(DFN,IBADMIT) ;Query for Billing CLock Maintenance option
N IBICN,IBDISCH
S IBICN=$$ICN^IBARXMU(DFN)
I +IBICN<1 S SERROR="NO PATIENT ICN FOUND",SERR=1 Q ;quit if unable to find ICN
S IBDISCH=$$CLSDT^IBECECX1(IBADMIT)
I IBDISCH S IBDISCH=$$FMTHL7^XLFDT($P(IBDISCH,"."))
S IBADMIT=$$FMTHL7^XLFDT($P(IBADMIT,"."))
S IBOADMIT=IBADMIT
I IBDISCH S IBODISCH=IBDISCH
S:$G(SERR)="" SERR=0
D MSH,QRD,QRF,SENDQRY
Q
;
CCBILL(DFN,IBADMIT) ;OUTGOING QRY Called from CC Inpatient Bill
;
N X,PARMS,SEG,MSG,VALUE,FIELD,QRYNUM,SERROR,SERR,NAME,ERROR,XXX,WHOTO,IBACBCLK,IBADM,IBDISC,IBDISCH,IBIEN,IBICN,IBQIEN,IBC0,IBODISCH,IBOADMIN
;
;S IBC0=^IBE(351,IBCLDA,0)
;HL7 to FM - $$HL7TFM^XLFDT(DT)
;FM TO HL7 - $$FMTHL7^XLFDT(DT)
; Retrieve Admission and Discharge dates from the PTF file
;
D CCINPT^IBECECX1(DFN,.IBADMIT) ;Get admit/discharge data
S IBICN=$$ICN^IBARXMU(DFN)
I +IBICN<1 S SERROR="NO PATIENT ICN FOUND",SERR=1 Q ;quit if unable to find ICN
S:$G(SERR)="" SERR=0
D MSH,QRD,QRF,SENDQRY
Q
;-------------------------------------------------OUTGOING QRY ----------------------------------------
EN(DFN) ;OUTGOING QRY ENTRY POINT
; IBQIEN - Query Request Message IEN (#778) that initiated this response CALLED FROM CLADD^IBAUTL3
N X,PARMS,SEG,MSG,VALUE,FIELD,QRYNUM,SERROR,SERR,NAME,ERROR,XXX,WHOTO,IBACBCLK,IBADM,IBDISC,IBADMIT,IBDISCH,IBIEN,IBICN,IBQIEN,IBC0,IBODISCH,IBOADMIN
;
;S IBC0=^IBE(351,IBCLDA,0)
;HL7 to FM - $$HL7TFM^XLFDT(DT)
;FM TO HL7 - $$FMTHL7^XLFDT(DT)
; Retrieve Admission and Discharge dates from the PTF file
;
D INPT^IBECECX1(DFN) ;Get admit/discharge data
S IBICN=$$ICN^IBARXMU(DFN)
I +IBICN<1 S SERROR="NO PATIENT ICN FOUND",SERR=1 Q ;quit if unable to find ICN
S:$G(SERR)="" SERR=0
D MSH,QRD,QRF,SENDQRY
Q
;
MSH ; Build MSH Segment
N PARMS K ^TMP("DSR")
S PARMS("COUNTRY")="USA"
S PARMS("MESSAGE TYPE")="QRY"
S PARMS("EVENT")="R02"
S PARMS("VERSION")="2.3"
S PARMS("MESSAGE STRUCTURE")="QRY_R02"
S MSG="^TMP("_"QRY"
S X=$$NEWMSG^HLOAPI(.PARMS,.MSG,.ERROR)
MSA ;Build MSA Segment (OPTIONAL)
S VALUE="MSA",FIELD=0 D SET^HLOAPI(.SEG,VALUE,FIELD)
S VALUE="AL",FIELD=1 D SET^HLOAPI(.SEG,VALUE,FIELD)
;S VALUE=QRYNUM,FIELD=2 D SET^HLOAPI(.SEG,VALUE,FIELD)
S X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
Q
;
QRD ;Build QRD segment
S VALUE="QRD",FIELD=0 D SET^HLOAPI(.SEG,VALUE,FIELD)
S %P1=$$NOW^XLFDT() S %P1=$$FMTHL7^XLFDT(%P1)
S VALUE=%P1,FIELD=1 D SET^HLOAPI(.SEG,VALUE,FIELD)
S VALUE=1,FIELD=2 D SET^HLOAPI(.SEG,VALUE,FIELD)
S VALUE=1,FIELD=3 D SET^HLOAPI(.SEG,VALUE,FIELD)
;S VALUE=QRYNUM,FIELD=4 D SET^HLOAPI(.SEG,VALUE,FIELD)
S VALUE=1,FIELD=7 D SET^HLOAPI(.SEG,VALUE,FIELD)
S NAME=$$GET1^DIQ(2,DFN_",",.01)
S VALUE=$P($G(NAME),",",1),FIELD=8 D SET^HLOAPI(.SEG,VALUE,FIELD,1)
S VALUE=$P($G(NAME),",",2),FIELD=8 D SET^HLOAPI(.SEG,VALUE,FIELD,2)
S VALUE=IBICN,FIELD=9 D SET^HLOAPI(.SEG,VALUE,FIELD)
S FIELD=11 I $G(IBOADMIT) S VALUE=IBOADMIT D SET^HLOAPI(.SEG,VALUE,FIELD) ; ADMIT DATE
S FIELD=12 I $G(IBODISCH) S VALUE=IBODISCH D SET^HLOAPI(.SEG,VALUE,FIELD) ; Discharge date
S X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
Q
;
QRF ;Build QRF segment
S FIELD=0,VALUE="QRF" D SET^HLOAPI(.SEG,VALUE,FIELD)
S FIELD=1,VALUE="IBECEAC-QRY" D SET^HLOAPI(.SEG,VALUE,FIELD)
S FIELD=2 I $G(IBADMIT) S VALUE=IBADMIT D SET^HLOAPI(.SEG,VALUE,FIELD) ; ADMIT DATE
S FIELD=3 I $G(IBDISCH) S VALUE=IBDISCH D SET^HLOAPI(.SEG,VALUE,FIELD) ; Discharge date
S X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
Q
SENDQRY ;
S PARMS("SENDING APPLICATION")="IBECEAC-QRY"
S WHOTO("RECEIVING APPLICATION")="IBECEAC-RECV"
S WHOTO("STATION NUMBER")="200DAS"
S WHOTO("MIDDLEWARE LINK NAME")="IBECEC-QRY" ;File #870 entry
S XXX=$$SENDONE^HLOAPI1(.MSG,.PARMS,.WHOTO,.ERROR)
Q
;
;--------------------------------------------------INCOMING QRY --------------------------
QRYIN ; receives incoming HL7 QRY^R02 and returns a DSR
N ICN,IBECADM,IBSADMIT,IBSDISCH
S ERR=0,IBSTAT=$$STARTMSG^HLOPRS(.IBMSG,HLMSGIEN,.IBHDR)
S IBIEN=HLMSGIEN
I 'IBSTAT S HLERR="Unable to start parse of message" Q
I "QRY"'[IBHDR("MESSAGE TYPE") Q
;
; extract some incoming message data from Cerner message IBARXC-QRY - QRY^R02
F Q:'$$NEXTSEG^HLOPRS(.IBMSG,.SEG) S IBSEGT=$G(SEG("SEGMENT TYPE")) Q:IBSEGT="" D
. I IBSEGT="QRD" D QRDQI
. I IBSEGT="QRF" D QRFQI
Q:'ICN
D DSROUT(ICN,IBIEN,IBECADM)
K IBCLNDT
Q
;
QRDQI ; INCOMING QRD SEGMENT
S ICN=$$GET^HLOPRS(.SEG,9,1,1,1)
S IBSADMIT=$$GET^HLOPRS(.SEG,11,1,1,1)
S IBSDISCH=$$GET^HLOPRS(.SEG,12,1,1,1)
Q
;
QRFQI ; INCOMING QRF SEGMENT
S IBECADM=$$GET^HLOPRS(.SEG,2,1,1,1)
S IBECADM=$$HL7TFM^XLFDT(IBECADM)
Q
;
;--------------------------------------------------INCOMING DSR --------------------------
DSRIN ;MAIN ENTRY POINT - incoming DSR message
;
N IBMSG,HDR,SEG,XXX,DFN,IBAGG
S IBERR=0,IBAGG=1
S XXX=$$STARTMSG^HLOPRS(.IBMSG,HLMSGIEN,.HDR)
F Q:'$$NEXTSEG^HLOPRS(.IBMSG,.SEG) S IBSEGT=$G(SEG("SEGMENT TYPE")) Q:IBSEGT="" D
. I IBSEGT="MSA" D MSA1
. I IBSEGT="QRD" D QRDDI
. I IBSEGT="DSP" D DSPDI
. I IBSEGT="ERR" D ERR1($$GET^HLOPRS(.SEG,6,1))
Q
;
MSA1 ;PULL 351 REFERENCE NUMBER
S IBCLDA=IBMSG("HDR","MESSAGE CONTROL ID")
S IB778=$P($$GET^HLOPRS(.SEG,2,1,1)," ",2)
Q
;
QRDDI ;INCOMING QRD SEGMENT
;N IBQRYDT
S IBQRYDT=$$GET^HLOPRS(.SEG,1,1,1) ;QUERY DATE/TIME
S IBICN=$$GET^HLOPRS(.SEG,9,1,1,1) ;Pt ICN
S DFN=$$DFN^IBARXMU(IBICN)
S IBADMIT=$$GET^HLOPRS(.SEG,11,1,1,1)
S IBDISCH=$$GET^HLOPRS(.SEG,12,1,1,1)
Q
DSPDI ;INCOMING DSP SEGMENT
N IBSETID,IBCLDT,IB901,IB902,IB903,IB904,IBICLDAY,IBICLDT,IBSETID1,IBCLDT1,IB9011,IB9021,IB9031,IB9041,IBCLDAY1,IBICKDT,IBACTC,IBCKNUM,IBICNUM
N IBCNT,IBDA,IBCNDT,IBQRYS,IBCBDT,IBDA1,IBICLNDT,IBERRMSG,IBODISCH,IBOADMIN,IBQRY,IBCRTST
S IBERRMSG=$$GET^HLOPRS(.SEG,5,1) ;Result Messages/Errors
I IBERRMSG'="" D ERR1(IBERRMSG) Q
S IBCNT=$$GET^HLOPRS(.SEG,1,1)
S IBISETID=$$GET^HLOPRS(.SEG,3,1) ;FT1 Response - bjr
S IBICLDT=$$GET^HLOPRS(.SEG,3,2) ;Billing Clock start date - bjr
S IBICLDT=$$HL7TFM^XLFDT(IBICLDT) ;convert HL7 date TO FM - bjr
S IBI901=$$GET^HLOPRS(.SEG,3,3) ;1st QRT charges - bjr
S IBI902=$$GET^HLOPRS(.SEG,3,4) ;2nd QRT charges - bjr
S IBI903=$$GET^HLOPRS(.SEG,3,5) ;3rd QRT charges - bjr
S IBI904=$$GET^HLOPRS(.SEG,3,6) ;4th QRT charges - bjr
S IBICLDAY=$$GET^HLOPRS(.SEG,3,7) ;Inpatient days - bjr
S IBICLNDT=$$GET^HLOPRS(.SEG,3,8) ;Billing clock end date - bjr
S IBICLNDT=$$HL7TFM^XLFDT(IBICLNDT) ;HL7 TO FM - bjr
S IBICKDT=IBICLNDT
;RRA currently nothing passed in the 4th field - leaving for integration with Cerner
S IBSETID1=$$GET^HLOPRS(.SEG,4,1) ;FT2 set id (IF PRESENT)
S IBCLDT1=$$GET^HLOPRS(.SEG,4,2) ;Billing Clock start date
S IBCLDT1=$$HL7TFM^XLFDT(IBCLDT1) ;convert HL7 date TO FM
S IB9011=$$GET^HLOPRS(.SEG,4,3) ;1st QRT charges
S IB9021=$$GET^HLOPRS(.SEG,4,4) ;2nd QRT charges
S IB9031=$$GET^HLOPRS(.SEG,4,5) ;3rd QRT charges
S IB9041=$$GET^HLOPRS(.SEG,4,6) ;4th QRT charges
S IBCLDAY1=$$GET^HLOPRS(.SEG,4,7) ;Inpatient days
;S IBICKDT=$$GET^HLOPRS(.SEG,4,8) ;Billing clock end date
;S IBICKDT=$$HL7TFM^XLFDT(IBICKDT) ;convert HL7 date TO FM
S IBISTAT=$$GET^HLOPRS(.SEG,6,1) ;Clock Status
S IBCKNUM=$$GET^HLOPRS(.SEG,7,1) ;Number of billing clocks sent (FT1)
S IBICNUM=$$GET^HLOPRS(.SEG,8,1) ;Number of admit encounters sent (FT2) - bjr
S IBISITE=$$GET^HLOPRS(.SEG,9,1) ;Site - bjr
I 'IBISTAT D UDCL Q ;Quit if no status sent which indicates no clocks from other sites
S IBDA=";" F S IBDA=$O(^IBE(351,"AIVDT",DFN,-IBICLDT,IBDA),-1) Q:'IBDA Q:$G(IBCBDT) D
.S IBCBDT=$$GET1^DIQ(351,IBDA_",",.03,"I")
.S IBQRYS=$$GET1^DIQ(351,IBDA_",",16,"I")
.S IBCRTST=$$GET1^DIQ(351,IBDA_",",.04,"I")
.S IBDA1=IBDA
I $G(IBQRYS),IBCRTST'=3 Q
Q:(IBICLDT<1)
I $G(IBCBDT)=IBICLDT,IBCNT=1 D UPDATE^IBECECU1(IBDA1) Q ;Update record if current Billing Clock Start Date matches incoming Billing Clock Start Date
I IBCNT=1 D NEWREC^IBECECU1 ;IBCNT=1 MEANS THE DSR SEGMENT IS AGGREGATED DATA AND SHOULD BE STORED IN 351
I IBCNT>1 D EN^IBECECU2(IBICLDT,DFN) ;IBCNT>1 MEANS IT IS INDIVIDUAL SITE DATA USED FOR AGGREGATION AND NEEDS TO BE STORED IN 351.3
S IBADMIT=$$FMADD^XLFDT(IBICLNDT,1)
I ($$FMTHL7^XLFDT(IBICLNDT))<IBDISCH,IBCNT=1 D ;
.S IBQRY=$O(^IBE(351,"AIVDT",DFN,-IBADMIT,";"),-1) I IBQRY,$P(^IBE(351,IBQRY,1),U,5) Q
.S IBADMIT=$$FMADD^XLFDT(IBICLNDT,1),IBDISCH=$$FMADD^XLFDT(IBADMIT,365),IBADMIT=$$FMTHL7^XLFDT(IBADMIT),IBOADMIT=IBADMIT
.S IBDISCH=$S(IBDISCH<DT:IBDISCH,1:"") I IBDISCH S IBDISCH=$$FMTHL7^XLFDT(IBDISCH),IBODISCH=IBDISCH
.K SEG,ERROR
.D MSH,QRD,QRF,SENDQRY
Q
;
;-------------------------------------------------- OUTGOING DSR --- ---------------------------
DSROUT(ICN,IBIEN,IBADMIT) ;MAIN ENTRY POINT - Outgoing DSR message
; IBIEN - Query Request Message IEN (#778) that initiated this response
; ------ Sample message ----
;MSH|^~\&|IBECEAC-SEND|695^HL7.IVMVEE.FO-ALBANY.DOMAIN.EXT:5127^DNS|IBECEAC-RECV|200DAS^:^DNS"|20211029135630-0500||DSR^Q03^DSR_Q03|695 1480|T^|2.3|||AL|NE|USA|3211029.135631^20211029145631.228^
;MSA|AL|0"
;QRD|20211102091619|1|1|0|||1|DRI^DODMORE MESSAGE|1008713999V404928"
;DSP|1||FT1^20201101^345^0^0^0^15^-1|||1|1|1"
N PARMS,SEG,MSG,VALUE,FIELD,QRYNUM,SERROR,SERR,NAME,ERROR,XXX,WHOTO
N IBSETID,IBCLDT,IB901,IB902,IB903,IB904,IBCLDAY,IBSETID1,IBCLDT1,IB9011,IB9021,IB9031,IB9041,IBCLDAY1,IBCLNDT1,IBACTC,IBCKNUM,IBICNUM
S DFN=$$DFN^IBARXMU(ICN)
I +DFN<1 S SERROR="NO PATIENT FOUND WITH SUBMITTED ICN",SERR=1
S QRYNUM=$$MSGID^HLOPRS(IBIEN) ; Message Control ID of initiating Query
S:$G(SERR)="" SERR=0
D EN^IBECECX1(DFN),INPT^IBECECX1(DFN)
MSHO ; Outgoing MSH
N PARMS K ^TMP("DSR")
S PARMS("COUNTRY")="USA"
S PARMS("MESSAGE TYPE")="DSR"
S PARMS("EVENT")="Q03"
S PARMS("SENDING APPLICATION")="IBECEAC-QRYRESP"
S PARMS("VERSION")="2.3"
S PARMS("MESSAGE STRUCTURE")="DSR_Q03"
S MSG="^TMP("_"DSR"
S X=$$NEWMSG^HLOAPI(.PARMS,.MSG,.ERROR)
MSAO ;Outgoing MSA
D SET^HLOAPI(.SEG,"MSA",0)
D SET^HLOAPI(.SEG,"AL",1)
D SET^HLOAPI(.SEG,QRYNUM,2)
S X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
QRDO ;Outgoing QRD
D SET^HLOAPI(.SEG,"QRD",0)
S %P1=$$NOW^XLFDT() S %P1=$$FMTHL7^XLFDT(%P1)
D SET^HLOAPI(.SEG,+%P1,1)
D SET^HLOAPI(.SEG,1,2)
D SET^HLOAPI(.SEG,1,3)
D SET^HLOAPI(.SEG,+QRYNUM,4)
D SET^HLOAPI(.SEG,1,7)
S NAME=$$GET1^DIQ(2,DFN_",",.01)
D SET^HLOAPI(.SEG,$P($G(NAME),",",1),8,1)
D SET^HLOAPI(.SEG,$P($G(NAME),",",2),8,2)
D SET^HLOAPI(.SEG,ICN,9)
I $G(IBSADMIT) D SET^HLOAPI(.SEG,IBSADMIT,11)
I $G(IBSDISCH) D SET^HLOAPI(.SEG,IBSDISCH,12)
S X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
;
DSPO ;Outgoing DSP
D SET^HLOAPI(.SEG,"DSP",0)
D SET^HLOAPI(.SEG,1,1)
D SET^HLOAPI(.SEG,"FT1",3,1) ;FT1 Response
S IBCLDT=$$FMTHL7^XLFDT(+IBCLDT) D SET^HLOAPI(.SEG,$S(IBCLDT>0:IBCLDT,1:$$FMTHL7^XLFDT(DT)),3,2) ;Billing Clock start date (HL7 format)
D SET^HLOAPI(.SEG,+IB901,3,3) ;1st QRT charges
D SET^HLOAPI(.SEG,+IB902,3,4) ;2nd QRT charges
D SET^HLOAPI(.SEG,+IB903,3,5) ;3rd QRT charges
D SET^HLOAPI(.SEG,+IB904,3,6) ;4th QRT charges
D SET^HLOAPI(.SEG,+IBCLDAY,3,7) ;Inpatient days
I $G(IBCLNDT) S IBCLNDT=$$FMTHL7^XLFDT(IBCLNDT) D SET^HLOAPI(.SEG,+IBCLNDT,3,8) ;Billing Clock end date (HL7 format)
;D SET^HLOAPI(.SEG,+IBSETID1,4) ;FT2 set id (IF PRESENT)
;D SET^HLOAPI(.SEG,2,4) ;FT2 set id (IF PRESENT)
;D SET^HLOAPI(.SEG,+IBADMIT,4,1) ;Admit Date (Already HL7 format)
;D SET^HLOAPI(.SEG,+IBDISCH,4,2) ;Discharge Date (Already HL7 format)
;D SET^HLOAPI(.SEG,+IBCLDAY,4,3) ;Inpatient Days
;
D SET^HLOAPI(.SEG,+IBSTAT,6) ;Active clock sent
D SET^HLOAPI(.SEG,+IBCKNUM,7) ;Number of billing clocks sent (FT1)
D SET^HLOAPI(.SEG,+IBICNUM,8) ;Number of admit encounters sent (FT2)
S X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
;
SENDDSR ;
S PARMS("SENDING APPLICATION")="IBECEAC-QRYRESP"
S WHOTO("RECEIVING APPLICATION")="IBECEAC-RCV"
S WHOTO("STATION NUMBER")="200DAS"
S WHOTO("MIDDLEWARE LINK NAME")="IBECEC-DSR" ;File #870 entry
S XXX=$$SENDONE^HLOAPI1(.MSG,.PARMS,.WHOTO,.ERROR)
Q
;
ERR1(IBERRMSG) ;HANDLE ERROR RESPONSES
;
;XMY,XMSUB,IBL
I IBERRMSG["MVI returned no treating facilities for this patient" D UDCL ;no error message necessary - just update the query sent field
;MAIL MESSAGE GENERATION CODE ON HOLD FOR FUTURE REQUIREMENTS
;K ^TMP($J,"IBCPYAC")
;S XMSUB="COPAY PATIENT ACCUMULATOR ISSUE"
;S XMY("G.IB PATIENT ACCUMULATOR")=""
;S IBL=0
;S IBL=IBL+1,^TMP($J,"IBCPYAC",IBL)="ERROR RECEIVED BY DAS DURING QUERY ATTEMPT:"
;S IBL=IBL+1,^TMP($J,"IBCPYAC",IBL)=""
;S IBL=IBL+1,^TMP($J,"IBCPYAC",IBL)=IBERRMSG
;S XMDUZ=DUZ,XMTEXT="^TMP($J,""IBCPYAC"","
;D ^XMD
Q
UDCL ;Update original billing clock so nightly querys are not sent for patients without TFL's
N IBSTAT,IBCLK,IBDA,IBMSG,IBHDR,SEG,IBSEGT,IBDFN,IBECDAT
S IBSTAT=$$STARTMSG^HLOPRS(.IBMSG,IB778,.IBHDR)
F Q:'$$NEXTSEG^HLOPRS(.IBMSG,.SEG) S IBSEGT=$G(SEG("SEGMENT TYPE")) Q:IBSEGT="" D
. I IBSEGT="QRD" D QRDQI ;pull the ICN out of the initiating QRY message so we can update the Billing Clock
Q:'ICN
S IBDFN=$$DFN^IBARXMU(ICN)
S IBDA=";" S IBDA=$O(^IBE(351,"ACT",IBDFN,IBDA),-1) ;locate the most recent active Billing Clock for update
I 'IBDA S IBECDAT=$O(^IBE(351,"AIVDT",IBDFN,-9999999)) Q:'IBECDAT S IBDA=$O(^IBE(351,"AIVDT",IBDFN,IBECDAT,";"),-1) Q:$$GET1^DIQ(351,IBDA,.04) ;Use newest date entry when no status set
Q:'IBDA
S $P(^IBE(351,IBDA,1),"^",5)=1 ;Update QUERY SENT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBECECQ1 15991 printed Oct 16, 2024@18:22:15 Page 2
IBECECQ1 ;BSL/DVA-BILLING - SEND/RECEIVE QRY & DSR HL7 messages FOR PATIENT ACCUMULATOR INTERFACE ; 01 Jun 2022 7:17 AM
+1 ;;2.0;INTEGRATED BILLING;**704**;21-MAR-94;Build 49
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference to $$STARTMSG^HLOPRS,$$NEXTSEG^HLOPRS,$$GET^HLOPRS,$$MSGID^HLOPRS in ICR #4718
+5 ; Reference to $$ADDSEG^HLOAPI,$$NEWMSG^HLOAPI,SET^HLOAPI in ICR #4722
+6 ; Reference to $$SENDONE^HLOAPI1 in ICR #4717
+7 ;
+8 ; -4200Build and send seeding of Vista data to DAS SPOE IBECEAC-QRY DSR^Q03
+9 ; Receive seeding query of Vista data from DAS SPOE IBECEAC-QRY DSR^Q03
+10 ;
+11 ; Sample message
+12 ;MSH|^~\&||695^HL7.IVMVEE.FO-ALBANY.DOMAIN.EXT:5127^DNS|IBECECQ-QRYRESP|200DAS^:^DNS|20211001094308-0500||QRY^RO2^QRY_RO2|695 1469|T^|2.3|||AL|NE|USA
+13 ;QRD|20211008123254-0500|1|1||||1|DRI^DODMORE MESSAGE|1008713999V404928
+14 ;QRF|IBECEAC-QRY|20161106|20161107
+15 ;
+16 ;No direct routine calls
QUIT
+17 ;
ADM ;Called from IB MEANS TEST BILLING protocol
+1 if $PIECE($GET(DGPMA),"^",2)'=1
QUIT
+2 DO EN(DFN)
+3 QUIT
+4 ;
EDTCLCK(DFN,IBADMIT) ;Called from Billing CLock Maintenance option
+1 NEW IBTRYTIL,IBECDT,IBECLDT,IBECIEN,IBECSTDT,IBECENDT,IBNOW
+2 ;Do not run query of patient does not have an ICN
if '$$ICN^IBARXMU(DFN)
QUIT
+3 ;Run Query
DO MTEQRY(DFN,IBADMIT)
+4 WRITE !,"Running Billing Clock Query, please wait."
+5 SET IBFLAG1=0
SET IBTRYTIL=$$FMADD^XLFDT($$NOW^XLFDT,,,1)
SET IBNOW=$$NOW^XLFDT
FOR
if $$NOW^XLFDT>IBTRYTIL
QUIT
if IBFLAG1
QUIT
Begin DoDot:1
+6 HANG 2
WRITE "."
SET IBECDT1=-(IBADMIT_.9999)
FOR
SET IBECDT1=$ORDER(^IBE(351,"AIVDT",DFN,IBECDT1))
if 'IBECDT1
QUIT
SET IBECIEN=$ORDER(^IBE(351,"AIVDT",DFN,IBECDT1,";"),-1)
if 'IBECIEN
QUIT
Begin DoDot:2
+7 SET IBECLDT=$$GET1^DIQ(351,IBECIEN_",",.04,"I")
if IBECLDT=3
QUIT
Begin DoDot:3
+8 SET IBECSTDT=$$GET1^DIQ(351,IBECIEN_",",.03,"I")
SET IBECENDT=$$GET1^DIQ(351,IBECIEN_",",.1,"I")
SET IBECENDT=$SELECT(IBECENDT:IBECENDT,IBECLDT=2:($$CLSDT^IBECECX1(IBECSTDT)),1:DT)
Begin DoDot:4
+9 IF (IBECENDT>=IBADMIT)
IF $$GET1^DIQ(351,IBECIEN_",",14,"I")>IBNOW
IF $PIECE(^IBE(351,IBECIEN,1),U,5)
SET IBFLAG1=1
SET IBECDA=IBECIEN
QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
MTEQRY(DFN,IBADMIT) ;Query for Billing CLock Maintenance option
+1 NEW IBICN,IBDISCH
+2 SET IBICN=$$ICN^IBARXMU(DFN)
+3 ;quit if unable to find ICN
IF +IBICN<1
SET SERROR="NO PATIENT ICN FOUND"
SET SERR=1
QUIT
+4 SET IBDISCH=$$CLSDT^IBECECX1(IBADMIT)
+5 IF IBDISCH
SET IBDISCH=$$FMTHL7^XLFDT($PIECE(IBDISCH,"."))
+6 SET IBADMIT=$$FMTHL7^XLFDT($PIECE(IBADMIT,"."))
+7 SET IBOADMIT=IBADMIT
+8 IF IBDISCH
SET IBODISCH=IBDISCH
+9 if $GET(SERR)=""
SET SERR=0
+10 DO MSH
DO QRD
DO QRF
DO SENDQRY
+11 QUIT
+12 ;
CCBILL(DFN,IBADMIT) ;OUTGOING QRY Called from CC Inpatient Bill
+1 ;
+2 NEW X,PARMS,SEG,MSG,VALUE,FIELD,QRYNUM,SERROR,SERR,NAME,ERROR,XXX,WHOTO,IBACBCLK,IBADM,IBDISC,IBDISCH,IBIEN,IBICN,IBQIEN,IBC0,IBODISCH,IBOADMIN
+3 ;
+4 ;S IBC0=^IBE(351,IBCLDA,0)
+5 ;HL7 to FM - $$HL7TFM^XLFDT(DT)
+6 ;FM TO HL7 - $$FMTHL7^XLFDT(DT)
+7 ; Retrieve Admission and Discharge dates from the PTF file
+8 ;
+9 ;Get admit/discharge data
DO CCINPT^IBECECX1(DFN,.IBADMIT)
+10 SET IBICN=$$ICN^IBARXMU(DFN)
+11 ;quit if unable to find ICN
IF +IBICN<1
SET SERROR="NO PATIENT ICN FOUND"
SET SERR=1
QUIT
+12 if $GET(SERR)=""
SET SERR=0
+13 DO MSH
DO QRD
DO QRF
DO SENDQRY
+14 QUIT
+15 ;-------------------------------------------------OUTGOING QRY ----------------------------------------
EN(DFN) ;OUTGOING QRY ENTRY POINT
+1 ; IBQIEN - Query Request Message IEN (#778) that initiated this response CALLED FROM CLADD^IBAUTL3
+2 NEW X,PARMS,SEG,MSG,VALUE,FIELD,QRYNUM,SERROR,SERR,NAME,ERROR,XXX,WHOTO,IBACBCLK,IBADM,IBDISC,IBADMIT,IBDISCH,IBIEN,IBICN,IBQIEN,IBC0,IBODISCH,IBOADMIN
+3 ;
+4 ;S IBC0=^IBE(351,IBCLDA,0)
+5 ;HL7 to FM - $$HL7TFM^XLFDT(DT)
+6 ;FM TO HL7 - $$FMTHL7^XLFDT(DT)
+7 ; Retrieve Admission and Discharge dates from the PTF file
+8 ;
+9 ;Get admit/discharge data
DO INPT^IBECECX1(DFN)
+10 SET IBICN=$$ICN^IBARXMU(DFN)
+11 ;quit if unable to find ICN
IF +IBICN<1
SET SERROR="NO PATIENT ICN FOUND"
SET SERR=1
QUIT
+12 if $GET(SERR)=""
SET SERR=0
+13 DO MSH
DO QRD
DO QRF
DO SENDQRY
+14 QUIT
+15 ;
MSH ; Build MSH Segment
+1 NEW PARMS
KILL ^TMP("DSR")
+2 SET PARMS("COUNTRY")="USA"
+3 SET PARMS("MESSAGE TYPE")="QRY"
+4 SET PARMS("EVENT")="R02"
+5 SET PARMS("VERSION")="2.3"
+6 SET PARMS("MESSAGE STRUCTURE")="QRY_R02"
+7 SET MSG="^TMP("_"QRY"
+8 SET X=$$NEWMSG^HLOAPI(.PARMS,.MSG,.ERROR)
MSA ;Build MSA Segment (OPTIONAL)
+1 SET VALUE="MSA"
SET FIELD=0
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+2 SET VALUE="AL"
SET FIELD=1
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+3 ;S VALUE=QRYNUM,FIELD=2 D SET^HLOAPI(.SEG,VALUE,FIELD)
+4 SET X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
+5 QUIT
+6 ;
QRD ;Build QRD segment
+1 SET VALUE="QRD"
SET FIELD=0
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+2 SET %P1=$$NOW^XLFDT()
SET %P1=$$FMTHL7^XLFDT(%P1)
+3 SET VALUE=%P1
SET FIELD=1
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+4 SET VALUE=1
SET FIELD=2
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+5 SET VALUE=1
SET FIELD=3
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+6 ;S VALUE=QRYNUM,FIELD=4 D SET^HLOAPI(.SEG,VALUE,FIELD)
+7 SET VALUE=1
SET FIELD=7
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+8 SET NAME=$$GET1^DIQ(2,DFN_",",.01)
+9 SET VALUE=$PIECE($GET(NAME),",",1)
SET FIELD=8
DO SET^HLOAPI(.SEG,VALUE,FIELD,1)
+10 SET VALUE=$PIECE($GET(NAME),",",2)
SET FIELD=8
DO SET^HLOAPI(.SEG,VALUE,FIELD,2)
+11 SET VALUE=IBICN
SET FIELD=9
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+12 ; ADMIT DATE
SET FIELD=11
IF $GET(IBOADMIT)
SET VALUE=IBOADMIT
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+13 ; Discharge date
SET FIELD=12
IF $GET(IBODISCH)
SET VALUE=IBODISCH
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+14 SET X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
+15 QUIT
+16 ;
QRF ;Build QRF segment
+1 SET FIELD=0
SET VALUE="QRF"
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+2 SET FIELD=1
SET VALUE="IBECEAC-QRY"
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+3 ; ADMIT DATE
SET FIELD=2
IF $GET(IBADMIT)
SET VALUE=IBADMIT
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+4 ; Discharge date
SET FIELD=3
IF $GET(IBDISCH)
SET VALUE=IBDISCH
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+5 SET X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
+6 QUIT
SENDQRY ;
+1 SET PARMS("SENDING APPLICATION")="IBECEAC-QRY"
+2 SET WHOTO("RECEIVING APPLICATION")="IBECEAC-RECV"
+3 SET WHOTO("STATION NUMBER")="200DAS"
+4 ;File #870 entry
SET WHOTO("MIDDLEWARE LINK NAME")="IBECEC-QRY"
+5 SET XXX=$$SENDONE^HLOAPI1(.MSG,.PARMS,.WHOTO,.ERROR)
+6 QUIT
+7 ;
+8 ;--------------------------------------------------INCOMING QRY --------------------------
QRYIN ; receives incoming HL7 QRY^R02 and returns a DSR
+1 NEW ICN,IBECADM,IBSADMIT,IBSDISCH
+2 SET ERR=0
SET IBSTAT=$$STARTMSG^HLOPRS(.IBMSG,HLMSGIEN,.IBHDR)
+3 SET IBIEN=HLMSGIEN
+4 IF 'IBSTAT
SET HLERR="Unable to start parse of message"
QUIT
+5 IF "QRY"'[IBHDR("MESSAGE TYPE")
QUIT
+6 ;
+7 ; extract some incoming message data from Cerner message IBARXC-QRY - QRY^R02
+8 FOR
if '$$NEXTSEG^HLOPRS(.IBMSG,.SEG)
QUIT
SET IBSEGT=$GET(SEG("SEGMENT TYPE"))
if IBSEGT=""
QUIT
Begin DoDot:1
+9 IF IBSEGT="QRD"
DO QRDQI
+10 IF IBSEGT="QRF"
DO QRFQI
End DoDot:1
+11 if 'ICN
QUIT
+12 DO DSROUT(ICN,IBIEN,IBECADM)
+13 KILL IBCLNDT
+14 QUIT
+15 ;
QRDQI ; INCOMING QRD SEGMENT
+1 SET ICN=$$GET^HLOPRS(.SEG,9,1,1,1)
+2 SET IBSADMIT=$$GET^HLOPRS(.SEG,11,1,1,1)
+3 SET IBSDISCH=$$GET^HLOPRS(.SEG,12,1,1,1)
+4 QUIT
+5 ;
QRFQI ; INCOMING QRF SEGMENT
+1 SET IBECADM=$$GET^HLOPRS(.SEG,2,1,1,1)
+2 SET IBECADM=$$HL7TFM^XLFDT(IBECADM)
+3 QUIT
+4 ;
+5 ;--------------------------------------------------INCOMING DSR --------------------------
DSRIN ;MAIN ENTRY POINT - incoming DSR message
+1 ;
+2 NEW IBMSG,HDR,SEG,XXX,DFN,IBAGG
+3 SET IBERR=0
SET IBAGG=1
+4 SET XXX=$$STARTMSG^HLOPRS(.IBMSG,HLMSGIEN,.HDR)
+5 FOR
if '$$NEXTSEG^HLOPRS(.IBMSG,.SEG)
QUIT
SET IBSEGT=$GET(SEG("SEGMENT TYPE"))
if IBSEGT=""
QUIT
Begin DoDot:1
+6 IF IBSEGT="MSA"
DO MSA1
+7 IF IBSEGT="QRD"
DO QRDDI
+8 IF IBSEGT="DSP"
DO DSPDI
+9 IF IBSEGT="ERR"
DO ERR1($$GET^HLOPRS(.SEG,6,1))
End DoDot:1
+10 QUIT
+11 ;
MSA1 ;PULL 351 REFERENCE NUMBER
+1 SET IBCLDA=IBMSG("HDR","MESSAGE CONTROL ID")
+2 SET IB778=$PIECE($$GET^HLOPRS(.SEG,2,1,1)," ",2)
+3 QUIT
+4 ;
QRDDI ;INCOMING QRD SEGMENT
+1 ;N IBQRYDT
+2 ;QUERY DATE/TIME
SET IBQRYDT=$$GET^HLOPRS(.SEG,1,1,1)
+3 ;Pt ICN
SET IBICN=$$GET^HLOPRS(.SEG,9,1,1,1)
+4 SET DFN=$$DFN^IBARXMU(IBICN)
+5 SET IBADMIT=$$GET^HLOPRS(.SEG,11,1,1,1)
+6 SET IBDISCH=$$GET^HLOPRS(.SEG,12,1,1,1)
+7 QUIT
DSPDI ;INCOMING DSP SEGMENT
+1 NEW IBSETID,IBCLDT,IB901,IB902,IB903,IB904,IBICLDAY,IBICLDT,IBSETID1,IBCLDT1,IB9011,IB9021,IB9031,IB9041,IBCLDAY1,IBICKDT,IBACTC,IBCKNUM,IBICNUM
+2 NEW IBCNT,IBDA,IBCNDT,IBQRYS,IBCBDT,IBDA1,IBICLNDT,IBERRMSG,IBODISCH,IBOADMIN,IBQRY,IBCRTST
+3 ;Result Messages/Errors
SET IBERRMSG=$$GET^HLOPRS(.SEG,5,1)
+4 IF IBERRMSG'=""
DO ERR1(IBERRMSG)
QUIT
+5 SET IBCNT=$$GET^HLOPRS(.SEG,1,1)
+6 ;FT1 Response - bjr
SET IBISETID=$$GET^HLOPRS(.SEG,3,1)
+7 ;Billing Clock start date - bjr
SET IBICLDT=$$GET^HLOPRS(.SEG,3,2)
+8 ;convert HL7 date TO FM - bjr
SET IBICLDT=$$HL7TFM^XLFDT(IBICLDT)
+9 ;1st QRT charges - bjr
SET IBI901=$$GET^HLOPRS(.SEG,3,3)
+10 ;2nd QRT charges - bjr
SET IBI902=$$GET^HLOPRS(.SEG,3,4)
+11 ;3rd QRT charges - bjr
SET IBI903=$$GET^HLOPRS(.SEG,3,5)
+12 ;4th QRT charges - bjr
SET IBI904=$$GET^HLOPRS(.SEG,3,6)
+13 ;Inpatient days - bjr
SET IBICLDAY=$$GET^HLOPRS(.SEG,3,7)
+14 ;Billing clock end date - bjr
SET IBICLNDT=$$GET^HLOPRS(.SEG,3,8)
+15 ;HL7 TO FM - bjr
SET IBICLNDT=$$HL7TFM^XLFDT(IBICLNDT)
+16 SET IBICKDT=IBICLNDT
+17 ;RRA currently nothing passed in the 4th field - leaving for integration with Cerner
+18 ;FT2 set id (IF PRESENT)
SET IBSETID1=$$GET^HLOPRS(.SEG,4,1)
+19 ;Billing Clock start date
SET IBCLDT1=$$GET^HLOPRS(.SEG,4,2)
+20 ;convert HL7 date TO FM
SET IBCLDT1=$$HL7TFM^XLFDT(IBCLDT1)
+21 ;1st QRT charges
SET IB9011=$$GET^HLOPRS(.SEG,4,3)
+22 ;2nd QRT charges
SET IB9021=$$GET^HLOPRS(.SEG,4,4)
+23 ;3rd QRT charges
SET IB9031=$$GET^HLOPRS(.SEG,4,5)
+24 ;4th QRT charges
SET IB9041=$$GET^HLOPRS(.SEG,4,6)
+25 ;Inpatient days
SET IBCLDAY1=$$GET^HLOPRS(.SEG,4,7)
+26 ;S IBICKDT=$$GET^HLOPRS(.SEG,4,8) ;Billing clock end date
+27 ;S IBICKDT=$$HL7TFM^XLFDT(IBICKDT) ;convert HL7 date TO FM
+28 ;Clock Status
SET IBISTAT=$$GET^HLOPRS(.SEG,6,1)
+29 ;Number of billing clocks sent (FT1)
SET IBCKNUM=$$GET^HLOPRS(.SEG,7,1)
+30 ;Number of admit encounters sent (FT2) - bjr
SET IBICNUM=$$GET^HLOPRS(.SEG,8,1)
+31 ;Site - bjr
SET IBISITE=$$GET^HLOPRS(.SEG,9,1)
+32 ;Quit if no status sent which indicates no clocks from other sites
IF 'IBISTAT
DO UDCL
QUIT
+33 SET IBDA=";"
FOR
SET IBDA=$ORDER(^IBE(351,"AIVDT",DFN,-IBICLDT,IBDA),-1)
if 'IBDA
QUIT
if $GET(IBCBDT)
QUIT
Begin DoDot:1
+34 SET IBCBDT=$$GET1^DIQ(351,IBDA_",",.03,"I")
+35 SET IBQRYS=$$GET1^DIQ(351,IBDA_",",16,"I")
+36 SET IBCRTST=$$GET1^DIQ(351,IBDA_",",.04,"I")
+37 SET IBDA1=IBDA
End DoDot:1
+38 IF $GET(IBQRYS)
IF IBCRTST'=3
QUIT
+39 if (IBICLDT<1)
QUIT
+40 ;Update record if current Billing Clock Start Date matches incoming Billing Clock Start Date
IF $GET(IBCBDT)=IBICLDT
IF IBCNT=1
DO UPDATE^IBECECU1(IBDA1)
QUIT
+41 ;IBCNT=1 MEANS THE DSR SEGMENT IS AGGREGATED DATA AND SHOULD BE STORED IN 351
IF IBCNT=1
DO NEWREC^IBECECU1
+42 ;IBCNT>1 MEANS IT IS INDIVIDUAL SITE DATA USED FOR AGGREGATION AND NEEDS TO BE STORED IN 351.3
IF IBCNT>1
DO EN^IBECECU2(IBICLDT,DFN)
+43 SET IBADMIT=$$FMADD^XLFDT(IBICLNDT,1)
+44 ;
IF ($$FMTHL7^XLFDT(IBICLNDT))<IBDISCH
IF IBCNT=1
Begin DoDot:1
+45 SET IBQRY=$ORDER(^IBE(351,"AIVDT",DFN,-IBADMIT,";"),-1)
IF IBQRY
IF $PIECE(^IBE(351,IBQRY,1),U,5)
QUIT
+46 SET IBADMIT=$$FMADD^XLFDT(IBICLNDT,1)
SET IBDISCH=$$FMADD^XLFDT(IBADMIT,365)
SET IBADMIT=$$FMTHL7^XLFDT(IBADMIT)
SET IBOADMIT=IBADMIT
+47 SET IBDISCH=$SELECT(IBDISCH<DT:IBDISCH,1:"")
IF IBDISCH
SET IBDISCH=$$FMTHL7^XLFDT(IBDISCH)
SET IBODISCH=IBDISCH
+48 KILL SEG,ERROR
+49 DO MSH
DO QRD
DO QRF
DO SENDQRY
End DoDot:1
+50 QUIT
+51 ;
+52 ;-------------------------------------------------- OUTGOING DSR --- ---------------------------
DSROUT(ICN,IBIEN,IBADMIT) ;MAIN ENTRY POINT - Outgoing DSR message
+1 ; IBIEN - Query Request Message IEN (#778) that initiated this response
+2 ; ------ Sample message ----
+3 ;MSH|^~\&|IBECEAC-SEND|695^HL7.IVMVEE.FO-ALBANY.DOMAIN.EXT:5127^DNS|IBECEAC-RECV|200DAS^:^DNS"|20211029135630-0500||DSR^Q03^DSR_Q03|695 1480|T^|2.3|||AL|NE|USA|3211029.135631^20211029145631.228^
+4 ;MSA|AL|0"
+5 ;QRD|20211102091619|1|1|0|||1|DRI^DODMORE MESSAGE|1008713999V404928"
+6 ;DSP|1||FT1^20201101^345^0^0^0^15^-1|||1|1|1"
+7 NEW PARMS,SEG,MSG,VALUE,FIELD,QRYNUM,SERROR,SERR,NAME,ERROR,XXX,WHOTO
+8 NEW IBSETID,IBCLDT,IB901,IB902,IB903,IB904,IBCLDAY,IBSETID1,IBCLDT1,IB9011,IB9021,IB9031,IB9041,IBCLDAY1,IBCLNDT1,IBACTC,IBCKNUM,IBICNUM
+9 SET DFN=$$DFN^IBARXMU(ICN)
+10 IF +DFN<1
SET SERROR="NO PATIENT FOUND WITH SUBMITTED ICN"
SET SERR=1
+11 ; Message Control ID of initiating Query
SET QRYNUM=$$MSGID^HLOPRS(IBIEN)
+12 if $GET(SERR)=""
SET SERR=0
+13 DO EN^IBECECX1(DFN)
DO INPT^IBECECX1(DFN)
MSHO ; Outgoing MSH
+1 NEW PARMS
KILL ^TMP("DSR")
+2 SET PARMS("COUNTRY")="USA"
+3 SET PARMS("MESSAGE TYPE")="DSR"
+4 SET PARMS("EVENT")="Q03"
+5 SET PARMS("SENDING APPLICATION")="IBECEAC-QRYRESP"
+6 SET PARMS("VERSION")="2.3"
+7 SET PARMS("MESSAGE STRUCTURE")="DSR_Q03"
+8 SET MSG="^TMP("_"DSR"
+9 SET X=$$NEWMSG^HLOAPI(.PARMS,.MSG,.ERROR)
MSAO ;Outgoing MSA
+1 DO SET^HLOAPI(.SEG,"MSA",0)
+2 DO SET^HLOAPI(.SEG,"AL",1)
+3 DO SET^HLOAPI(.SEG,QRYNUM,2)
+4 SET X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
QRDO ;Outgoing QRD
+1 DO SET^HLOAPI(.SEG,"QRD",0)
+2 SET %P1=$$NOW^XLFDT()
SET %P1=$$FMTHL7^XLFDT(%P1)
+3 DO SET^HLOAPI(.SEG,+%P1,1)
+4 DO SET^HLOAPI(.SEG,1,2)
+5 DO SET^HLOAPI(.SEG,1,3)
+6 DO SET^HLOAPI(.SEG,+QRYNUM,4)
+7 DO SET^HLOAPI(.SEG,1,7)
+8 SET NAME=$$GET1^DIQ(2,DFN_",",.01)
+9 DO SET^HLOAPI(.SEG,$PIECE($GET(NAME),",",1),8,1)
+10 DO SET^HLOAPI(.SEG,$PIECE($GET(NAME),",",2),8,2)
+11 DO SET^HLOAPI(.SEG,ICN,9)
+12 IF $GET(IBSADMIT)
DO SET^HLOAPI(.SEG,IBSADMIT,11)
+13 IF $GET(IBSDISCH)
DO SET^HLOAPI(.SEG,IBSDISCH,12)
+14 SET X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
+15 ;
DSPO ;Outgoing DSP
+1 DO SET^HLOAPI(.SEG,"DSP",0)
+2 DO SET^HLOAPI(.SEG,1,1)
+3 ;FT1 Response
DO SET^HLOAPI(.SEG,"FT1",3,1)
+4 ;Billing Clock start date (HL7 format)
SET IBCLDT=$$FMTHL7^XLFDT(+IBCLDT)
DO SET^HLOAPI(.SEG,$SELECT(IBCLDT>0:IBCLDT,1:$$FMTHL7^XLFDT(DT)),3,2)
+5 ;1st QRT charges
DO SET^HLOAPI(.SEG,+IB901,3,3)
+6 ;2nd QRT charges
DO SET^HLOAPI(.SEG,+IB902,3,4)
+7 ;3rd QRT charges
DO SET^HLOAPI(.SEG,+IB903,3,5)
+8 ;4th QRT charges
DO SET^HLOAPI(.SEG,+IB904,3,6)
+9 ;Inpatient days
DO SET^HLOAPI(.SEG,+IBCLDAY,3,7)
+10 ;Billing Clock end date (HL7 format)
IF $GET(IBCLNDT)
SET IBCLNDT=$$FMTHL7^XLFDT(IBCLNDT)
DO SET^HLOAPI(.SEG,+IBCLNDT,3,8)
+11 ;D SET^HLOAPI(.SEG,+IBSETID1,4) ;FT2 set id (IF PRESENT)
+12 ;D SET^HLOAPI(.SEG,2,4) ;FT2 set id (IF PRESENT)
+13 ;D SET^HLOAPI(.SEG,+IBADMIT,4,1) ;Admit Date (Already HL7 format)
+14 ;D SET^HLOAPI(.SEG,+IBDISCH,4,2) ;Discharge Date (Already HL7 format)
+15 ;D SET^HLOAPI(.SEG,+IBCLDAY,4,3) ;Inpatient Days
+16 ;
+17 ;Active clock sent
DO SET^HLOAPI(.SEG,+IBSTAT,6)
+18 ;Number of billing clocks sent (FT1)
DO SET^HLOAPI(.SEG,+IBCKNUM,7)
+19 ;Number of admit encounters sent (FT2)
DO SET^HLOAPI(.SEG,+IBICNUM,8)
+20 SET X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
+21 ;
SENDDSR ;
+1 SET PARMS("SENDING APPLICATION")="IBECEAC-QRYRESP"
+2 SET WHOTO("RECEIVING APPLICATION")="IBECEAC-RCV"
+3 SET WHOTO("STATION NUMBER")="200DAS"
+4 ;File #870 entry
SET WHOTO("MIDDLEWARE LINK NAME")="IBECEC-DSR"
+5 SET XXX=$$SENDONE^HLOAPI1(.MSG,.PARMS,.WHOTO,.ERROR)
+6 QUIT
+7 ;
ERR1(IBERRMSG) ;HANDLE ERROR RESPONSES
+1 ;
+2 ;XMY,XMSUB,IBL
+3 ;no error message necessary - just update the query sent field
IF IBERRMSG["MVI returned no treating facilities for this patient"
DO UDCL
+4 ;MAIL MESSAGE GENERATION CODE ON HOLD FOR FUTURE REQUIREMENTS
+5 ;K ^TMP($J,"IBCPYAC")
+6 ;S XMSUB="COPAY PATIENT ACCUMULATOR ISSUE"
+7 ;S XMY("G.IB PATIENT ACCUMULATOR")=""
+8 ;S IBL=0
+9 ;S IBL=IBL+1,^TMP($J,"IBCPYAC",IBL)="ERROR RECEIVED BY DAS DURING QUERY ATTEMPT:"
+10 ;S IBL=IBL+1,^TMP($J,"IBCPYAC",IBL)=""
+11 ;S IBL=IBL+1,^TMP($J,"IBCPYAC",IBL)=IBERRMSG
+12 ;S XMDUZ=DUZ,XMTEXT="^TMP($J,""IBCPYAC"","
+13 ;D ^XMD
+14 QUIT
UDCL ;Update original billing clock so nightly querys are not sent for patients without TFL's
+1 NEW IBSTAT,IBCLK,IBDA,IBMSG,IBHDR,SEG,IBSEGT,IBDFN,IBECDAT
+2 SET IBSTAT=$$STARTMSG^HLOPRS(.IBMSG,IB778,.IBHDR)
+3 FOR
if '$$NEXTSEG^HLOPRS(.IBMSG,.SEG)
QUIT
SET IBSEGT=$GET(SEG("SEGMENT TYPE"))
if IBSEGT=""
QUIT
Begin DoDot:1
+4 ;pull the ICN out of the initiating QRY message so we can update the Billing Clock
IF IBSEGT="QRD"
DO QRDQI
End DoDot:1
+5 if 'ICN
QUIT
+6 SET IBDFN=$$DFN^IBARXMU(ICN)
+7 ;locate the most recent active Billing Clock for update
SET IBDA=";"
SET IBDA=$ORDER(^IBE(351,"ACT",IBDFN,IBDA),-1)
+8 ;Use newest date entry when no status set
IF 'IBDA
SET IBECDAT=$ORDER(^IBE(351,"AIVDT",IBDFN,-9999999))
if 'IBECDAT
QUIT
SET IBDA=$ORDER(^IBE(351,"AIVDT",IBDFN,IBECDAT,";"),-1)
if $$GET1^DIQ(351,IBDA,.04)
QUIT
+9 if 'IBDA
QUIT
+10 ;Update QUERY SENT
SET $PIECE(^IBE(351,IBDA,1),"^",5)=1
+11 QUIT
