IBECECQ1 ;BSL/DVA-BILLING - SEND/RECEIVE QRY & DSR HL7 messages FOR PATIENT ACCUMULATOR INTERFACE ; 10/11/23 7:41am
;;2.0;INTEGRATED BILLING;**704,769**;21-MAR-94;Build 42
;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 VDIF IBECEAC-QRY DSR^Q03
; Receive seeding query of Vista data from VDIF IBECEAC-QRY DSR^Q03
;
; Sample message
;MSH|^~\&|IBECEAC-QRY|578^HL7.HINES.DOMAIN.EXT:5584^DNS|IBECEAC-RECV|200VDIF^:^DNS|20250507142653-0500||QRY^R02^QRY_R02|578 31288716|T^|2.3|||AL|NE|USA
;QRD|20250507142653-0500|1|1|371168||1|LNAME^FNAME|1013734284V140030||20250501
;QRF|IBECEAC-QRY|20250501
;
Q ;No direct routine calls
;
ADM ;Called from IB MEANS TEST BILLING protocol
Q:$P($G(DGPMA),"^",2)'=1
D EN(DFN)
Q
;
MTEQRY(DFN,IBADMIT) ;Query for Billing Clock Maintenance option
N IBICN,IBDISCH,IB351IEN,IBODISCH,IBCSTCMT
I $G(IBADMIT),'$G(IBCURIEN) S IB351IEN=$$GETIEN^IBECECX1(DFN,IBADMIT)
I $G(IBCURIEN) S IB351IEN=IBCURIEN
S IBICN=$$ICN^IBARXMU(DFN)
I +IBICN<1 S IBERROR="NO PATIENT ICN FOUND",IBERR=1 Q ;quit if unable to find ICN
S IBDISCH=$$FMADD^XLFDT(IBADMIT,364) ;IB*2*769 - Clock end = clock start +364
I IBDISCH S IBDISCH=$$FMTHL7^XLFDT($P(IBDISCH,"."))
S IBADMIT=$$FMTHL7^XLFDT($P(IBADMIT,"."))
S IBOADMIT=IBADMIT
I IBDISCH S IBODISCH=IBDISCH
S:$G(IBERR)="" IBERR=0
I $G(IBCLSTDT),$G(IBCLKCHG) S IBCSTCMT=IBCLSTDT_"-Edit Begin Date via CLOCK MAINT",DIE="^IBE(351,",DA=IB351IEN,DR="15///^S X=IBCSTCMT" D ^DIE ;IB*2.0*769 - Save off clock start date for aggr comp
D MSH,QRD,QRF,SENDQRY
Q
;
CCBILL(DFN,IBADMIT) ;OUTGOING QRY Called from CC Inpatient Bill
;
N X,PARMS,SEG,MSG,VALUE,FIELD,QRYNUM,IBERROR,IBERR,NAME,ERROR,XXX,WHOTO,IBACBCLK,IBADM,IBDISC,IBDISCH,IBLIST,IBERR
N IBIEN,IBICN,IBQIEN,IBC0,IBODISCH,IBOADMIN,IB351IEN,IBSTATION,IBADM1,IBCLDT,IBOADMIT,IBSTAT,IBMES,IBSEGT,IBTRYTIL,IBTFL
;
;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
I $G(IBADM1) S IB351IEN=$$GETIEN^IBECECX1(DFN,IBADM1)
S IBICN=$$ICN^IBARXMU(DFN)
I +IBICN<1 S IBERROR="NO PATIENT ICN FOUND",IBERR=1 Q ;quit if unable to find ICN
S IBTFL=$$TFL^IBARXMU(DFN,.IBTFL,2) I 'IBTFL S IBFLAG1=1 Q ;Quit if patient has no other TFL's
S:$G(IBERR)="" IBERR=0
D MSH,QRD,QRF,SENDQRY
N IBMSG,HDR,SEG,XXX,DFN,IBVARRY,IBECERR,IBECNIEN,IBID,IBICLDTS,IBDISCH
;Wait clock for up to 2 minutes until DSR returned from billing clock query
S IBFLAG1=0,IBTRYTIL=$$FMADD^XLFDT($$NOW^XLFDT,,,2) F Q:$$NOW^XLFDT>IBTRYTIL Q:IBFLAG1 D
.H 2 W "." Q:IBFLAG1 S HLMSGIEN=MSG("IEN"),IBMES=$$STARTMSG^HLOPRS(.IBMSG,HLMSGIEN,.HDR) S HLMSGIEN=$G(IBMSG("ACK BY IEN")) I HLMSGIEN D
..S IBERR=0,IBERRMSG=""
..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
....I $$GET^HLOPRS(.SEG,5,1)["Billing Clock found at site #" S IBERRMSG=$$GET^HLOPRS(.SEG,5,1),IBOVERLAP=1
....S IBCNT=$$GET^HLOPRS(.SEG,1,1)
....S IBISTN=$$GET^HLOPRS(.SEG,3,9,0,1) ;Station Number
....S IBIVRSN=$$GET^HLOPRS(.SEG,3,9,0,2) ;Billing Clock Version
....S IBFVRSN1=IBISTN_" "_IBIVRSN I 'IBFVRSN1 S IBFVRSN1=0 ;Full billing clock version
....S IBSTATION=$$GET^HLOPRS(.SEG,9,1)
....I IBSTATION'="",IBCNT>1 D FIND^DIC(4,,.01,"MX",IBSTATION,,"D",,,"IBLIST","IBERR") D
.....S IBINST=IBLIST("DILIST",1,1),IBECARY(IBINST)="" ;Institution array for error messaging
..H 4 I $G(IBADM1),'IB351IEN S IB351IEN=$$GETIEN^IBECECX1(DFN,IBADM1)
..;I IBERRMSG["MVI returned no treating facilities for this patient" S IBERRMSG="",IBFLAG1=1 Q ;IB*2.0*769 - MVI message returned from VDIF when no active clocks found per HBM request
..I IBERRMSG'="" S IBFLAG1=1 Q
..S IBECERR=0 ;IBECERR - FLAG TO DETERMINE IF VERSIONING OUT OF SYNC
..I IBERRMSG="" S IBECDA=$S(+IB351IEN:IB351IEN,1:$G(IBECNIEN)) I IBECDA S IBECERR=$$GET1^DIQ(351,IBECDA,18,"I") I IBECERR D ;DSR returned with query results - now validate the results based on clock version
...S IBERRMSG="Query results contain inconsistent versioning - indicating MEANS TEST BILLING CLOCKs may be out of sync."
..S IBFLAG1=1
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,IBERROR,IBERR,NAME,ERROR,XXX,WHOTO,IBACBCLK,IBADM,IBDISC,IBADMIT,IBDISCH
N IBIEN,IBICN,IBQIEN,IBC0,IBODISCH,IBOADMIN,IBSTATION,IBADM1,IBCLDT,IBOADMIT,IBSTAT
;
;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
I $G(IBADM1),'$G(IB351IEN) S IB351IEN=$$GETIEN^IBECECX1(DFN,IBADM1)
S IBICN=$$ICN^IBARXMU(DFN)
I +IBICN<1 S IBERROR="NO PATIENT ICN FOUND",IBERR=1 Q ;quit if unable to find ICN
S IBTFL=$$TFL^IBARXMU(DFN,.IBTFL,2) I 'IBTFL Q ;Quit if patient has no other TFL's
S:$G(IBERR)="" IBERR=0
D MSH,QRD,QRF,SENDQRY
K IB351IEN
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 MSG="^TMP("_"QRY"
S PARMS("MESSAGE STRUCTURE")="QRY_R02" ;IB*2.0*769 - Add per VDIF
S X=$$NEWMSG^HLOAPI(.PARMS,.MSG,.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=$G(IB351IEN),FIELD=4 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(IBADMIT) S VALUE=$P(IBADMIT,".") D SET^HLOAPI(.SEG,VALUE,FIELD) ; ADMIT DATE - bjr ib*769
S FIELD=12 I $G(IBDISCH) S VALUE=$P(IBDISCH,".") D SET^HLOAPI(.SEG,VALUE,FIELD) ; Discharge date - bjr ib*769
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")="200VDIF"
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,IBQRYDT,IBEDIPI
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^IBECECQ2(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)
S IB351IEN=$$GET^HLOPRS(.SEG,4,1,1,1)
S IBQRYDT=$$GET^HLOPRS(.SEG,1,1) ;RRA IB*769
S IBEDIPI=$$GET^HLOPRS(.SEG,10,1,1,1) ;BJR IB*769
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,IBVARRY,IBERRMSG,IBECERR,IBECDA,IBECNIEN,IBID,IBICLDTS,IBDISCH,IB3513,IBFDA,IBECVSRN
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
S IBECERR=0 ;IBECERR - FLAG TO DETERMINE IF VERSIONING OUT OF SYNC
I IBERRMSG="" S IBECDA=$S(+IB351IEN:IB351IEN,1:$G(IBECNIEN)) I IBECDA S IBECERR=$$VRSNCHK^IBECECX1(IBECDA) ;DSR returned with query results - now validate the results based on clock version
I 'IBECERR,$G(IBECDA) S IBECVSRN=$O(IBVARRY("")) I IBECVSRN D
.S IENS=IBECDA_",",IBFDA(351,IENS,17)=IBECVSRN D FILE^DIE(,"IBFDA","IBERR")
I IBECERR D Q
.L +^IBE(351,IBECDA):$G(DILOCKTM,5) Q:'$T
.S DIE="^IBE(351,",DA=IBECDA,DR="18///YES" D ^DIE
.L -^IBE(351,IBECDA)
.S IBERRMSG="Query results contain inconsistent versioning - indicating MEANS TEST BILLING CLOCKs may be out of sync."
.S IBID=$G(IBCLDA)
.S:$G(IB351IEN) IBICLDTS=$$GET1^DIQ(351,IB351IEN_",",.03,"E") ;Use billing clock start date from local entry
.D ERR2^IBECECX1(IBERRMSG)
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 IBADMIT=$$HL7TFM^XLFDT(IBADMIT)
S IBDISCH=$$GET^HLOPRS(.SEG,12,1,1,1)
S IBDISCH=$$HL7TFM^XLFDT(IBDISCH)
S IB351IEN=$$GET^HLOPRS(.SEG,4,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,IBODISCH,IBOADMIN,IBQRY,IBCRTST,IBISTN,IBIVRSN,IBFVRSN1,IBDAYS,IBADTSV,IBISETID,IBISITE
S IBERRMSG=$$GET^HLOPRS(.SEG,5,1) ;Result Messages/Errors
;if error occurred call error handling and quit processing
I IBERRMSG["MVI returned no treating facilities for this patient" S IBERRMSG="" ;IB*2.0*769 - MVI message returned from VDIF when no active clocks found per HBM request
I IBERRMSG["NO MEANS TEST BILLING CLOCK FOUND" S IBERRMSG="" ;IB*2.0*769 - Clear error message for VistA when no clock found
I IBERRMSG["No Member found" S IBERRMSG="" ;IB*2.0*769 Clear error message for HBM no Member response
I IBERRMSG["No clock found for Parameters" S IBERRMSG="" ;IB*2.0*769 Clear error message for HBM No clock found for Parameters
I IBERRMSG'="" D Q
.S IBID=$G(IBCLDA)
.;S IBICLDTS=$G(IBADMIT)
.S:IB351IEN IBICLDTS=$$GET1^DIQ(351,IB351IEN_",",.03,"E") ;Use billing clock start date from local entry
.I IBERRMSG["Billing Clock found at site #" D Q
..D ERR2^IBECECX1(IBERRMSG) ;Call ERR2 for Clock discrepancy issues
.S IBERRMSG="Query attempt failed - "_IBERRMSG D ERR1^IBECECX1(IBERRMSG)
.I IB351IEN S DIE="^IBE(351,",DA=IB351IEN,DR="16///@" D ^DIE
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 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 IBISTN=$$GET^HLOPRS(.SEG,3,9,1) ;Station Number
S IBIVRSN=$$GET^HLOPRS(.SEG,3,9,2) ;Billing Clock Version
S IBFVRSN1=IBISTN_" "_IBIVRSN ;Full billing clock version
I +IBFVRSN1=0 S IBFVRSN1=0 ;if no version, set to 0
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 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 'IBICLDT D UDCL^IBECECX1 Q ;Quit if no clock start date sent which indicates no clocks from other sites
I $G(IB351IEN),IBCNT=1 D
.S IBCBDT=$$GET1^DIQ(351,IB351IEN_",",.03,"I")
.S IBQRYS=$$GET1^DIQ(351,IB351IEN_",",16,"I")
.S IBCRTST=$$GET1^DIQ(351,IB351IEN_",",.04,"I")
.S IBDAYS=$$GET1^DIQ(351,IB351IEN_",",.09,"I")
.S IBDA1=IB351IEN
Q:(IBICLDT<1)
I (($G(IBCBDT)=IBICLDT)!($G(IB351IEN))),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,$G(IB351IEN) S:$P(IBFVRSN1," ",2) IBVARRY(IBFVRSN1)="" D EN^IBECECU2(IB351IEN,DFN) ;IBCNT>1 MEANS IT IS INDIVIDUAL SITE DATA USED FOR AGGREGATION UPDATE CLOCK VERSION ARRAY AND NEEDS TO BE STORED IN 351.3
I IBCNT>1,'$G(IB351IEN),$G(IBECNIEN) S:$P(IBFVRSN1," ",2) IBVARRY(IBFVRSN1)="" D EN^IBECECU2(IBECNIEN,DFN) ;Use new clock IEN when one is created
S IBADTSV=IBADMIT S:$G(IBICLNDT) 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
S IBADMIT=IBADTSV
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBECECQ1 15389 printed Sep 23, 2025@19:57:53 Page 2
IBECECQ1 ;BSL/DVA-BILLING - SEND/RECEIVE QRY & DSR HL7 messages FOR PATIENT ACCUMULATOR INTERFACE ; 10/11/23 7:41am
+1 ;;2.0;INTEGRATED BILLING;**704,769**;21-MAR-94;Build 42
+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 VDIF IBECEAC-QRY DSR^Q03
+9 ; Receive seeding query of Vista data from VDIF IBECEAC-QRY DSR^Q03
+10 ;
+11 ; Sample message
+12 ;MSH|^~\&|IBECEAC-QRY|578^HL7.HINES.DOMAIN.EXT:5584^DNS|IBECEAC-RECV|200VDIF^:^DNS|20250507142653-0500||QRY^R02^QRY_R02|578 31288716|T^|2.3|||AL|NE|USA
+13 ;QRD|20250507142653-0500|1|1|371168||1|LNAME^FNAME|1013734284V140030||20250501
+14 ;QRF|IBECEAC-QRY|20250501
+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 ;
MTEQRY(DFN,IBADMIT) ;Query for Billing Clock Maintenance option
+1 NEW IBICN,IBDISCH,IB351IEN,IBODISCH,IBCSTCMT
+2 IF $GET(IBADMIT)
IF '$GET(IBCURIEN)
SET IB351IEN=$$GETIEN^IBECECX1(DFN,IBADMIT)
+3 IF $GET(IBCURIEN)
SET IB351IEN=IBCURIEN
+4 SET IBICN=$$ICN^IBARXMU(DFN)
+5 ;quit if unable to find ICN
IF +IBICN<1
SET IBERROR="NO PATIENT ICN FOUND"
SET IBERR=1
QUIT
+6 ;IB*2*769 - Clock end = clock start +364
SET IBDISCH=$$FMADD^XLFDT(IBADMIT,364)
+7 IF IBDISCH
SET IBDISCH=$$FMTHL7^XLFDT($PIECE(IBDISCH,"."))
+8 SET IBADMIT=$$FMTHL7^XLFDT($PIECE(IBADMIT,"."))
+9 SET IBOADMIT=IBADMIT
+10 IF IBDISCH
SET IBODISCH=IBDISCH
+11 if $GET(IBERR)=""
SET IBERR=0
+12 ;IB*2.0*769 - Save off clock start date for aggr comp
IF $GET(IBCLSTDT)
IF $GET(IBCLKCHG)
SET IBCSTCMT=IBCLSTDT_"-Edit Begin Date via CLOCK MAINT"
SET DIE="^IBE(351,"
SET DA=IB351IEN
SET DR="15///^S X=IBCSTCMT"
DO ^DIE
+13 DO MSH
DO QRD
DO QRF
DO SENDQRY
+14 QUIT
+15 ;
CCBILL(DFN,IBADMIT) ;OUTGOING QRY Called from CC Inpatient Bill
+1 ;
+2 NEW X,PARMS,SEG,MSG,VALUE,FIELD,QRYNUM,IBERROR,IBERR,NAME,ERROR,XXX,WHOTO,IBACBCLK,IBADM,IBDISC,IBDISCH,IBLIST,IBERR
+3 NEW IBIEN,IBICN,IBQIEN,IBC0,IBODISCH,IBOADMIN,IB351IEN,IBSTATION,IBADM1,IBCLDT,IBOADMIT,IBSTAT,IBMES,IBSEGT,IBTRYTIL,IBTFL
+4 ;
+5 ;S IBC0=^IBE(351,IBCLDA,0)
+6 ;HL7 to FM - $$HL7TFM^XLFDT(DT)
+7 ;FM TO HL7 - $$FMTHL7^XLFDT(DT)
+8 ; Retrieve Admission and Discharge dates from the PTF file
+9 ;
+10 ;Get admit/discharge data
DO CCINPT^IBECECX1(DFN,.IBADMIT)
+11 IF $GET(IBADM1)
SET IB351IEN=$$GETIEN^IBECECX1(DFN,IBADM1)
+12 SET IBICN=$$ICN^IBARXMU(DFN)
+13 ;quit if unable to find ICN
IF +IBICN<1
SET IBERROR="NO PATIENT ICN FOUND"
SET IBERR=1
QUIT
+14 ;Quit if patient has no other TFL's
SET IBTFL=$$TFL^IBARXMU(DFN,.IBTFL,2)
IF 'IBTFL
SET IBFLAG1=1
QUIT
+15 if $GET(IBERR)=""
SET IBERR=0
+16 DO MSH
DO QRD
DO QRF
DO SENDQRY
+17 NEW IBMSG,HDR,SEG,XXX,DFN,IBVARRY,IBECERR,IBECNIEN,IBID,IBICLDTS,IBDISCH
+18 ;Wait clock for up to 2 minutes until DSR returned from billing clock query
+19 SET IBFLAG1=0
SET IBTRYTIL=$$FMADD^XLFDT($$NOW^XLFDT,,,2)
FOR
if $$NOW^XLFDT>IBTRYTIL
QUIT
if IBFLAG1
QUIT
Begin DoDot:1
+20 HANG 2
WRITE "."
if IBFLAG1
QUIT
SET HLMSGIEN=MSG("IEN")
SET IBMES=$$STARTMSG^HLOPRS(.IBMSG,HLMSGIEN,.HDR)
SET HLMSGIEN=$GET(IBMSG("ACK BY IEN"))
IF HLMSGIEN
Begin DoDot:2
+21 SET IBERR=0
SET IBERRMSG=""
+22 SET XXX=$$STARTMSG^HLOPRS(.IBMSG,HLMSGIEN,.HDR)
+23 FOR
if '$$NEXTSEG^HLOPRS(.IBMSG,.SEG)
QUIT
SET IBSEGT=$GET(SEG("SEGMENT TYPE"))
if IBSEGT=""
QUIT
Begin DoDot:3
+24 IF IBSEGT="MSA"
DO MSA1
+25 IF IBSEGT="QRD"
DO QRDDI
+26 IF IBSEGT="DSP"
Begin DoDot:4
+27 IF $$GET^HLOPRS(.SEG,5,1)["Billing Clock found at site #"
SET IBERRMSG=$$GET^HLOPRS(.SEG,5,1)
SET IBOVERLAP=1
+28 SET IBCNT=$$GET^HLOPRS(.SEG,1,1)
+29 ;Station Number
SET IBISTN=$$GET^HLOPRS(.SEG,3,9,0,1)
+30 ;Billing Clock Version
SET IBIVRSN=$$GET^HLOPRS(.SEG,3,9,0,2)
+31 ;Full billing clock version
SET IBFVRSN1=IBISTN_" "_IBIVRSN
IF 'IBFVRSN1
SET IBFVRSN1=0
+32 SET IBSTATION=$$GET^HLOPRS(.SEG,9,1)
+33 IF IBSTATION'=""
IF IBCNT>1
DO FIND^DIC(4,,.01,"MX",IBSTATION,,"D",,,"IBLIST","IBERR")
Begin DoDot:5
+34 ;Institution array for error messaging
SET IBINST=IBLIST("DILIST",1,1)
SET IBECARY(IBINST)=""
End DoDot:5
End DoDot:4
End DoDot:3
+35 HANG 4
IF $GET(IBADM1)
IF 'IB351IEN
SET IB351IEN=$$GETIEN^IBECECX1(DFN,IBADM1)
+36 ;I IBERRMSG["MVI returned no treating facilities for this patient" S IBERRMSG="",IBFLAG1=1 Q ;IB*2.0*769 - MVI message returned from VDIF when no active clocks found per HBM request
+37 IF IBERRMSG'=""
SET IBFLAG1=1
QUIT
+38 ;IBECERR - FLAG TO DETERMINE IF VERSIONING OUT OF SYNC
SET IBECERR=0
+39 ;DSR returned with query results - now validate the results based on clock version
IF IBERRMSG=""
SET IBECDA=$SELECT(+IB351IEN:IB351IEN,1:$GET(IBECNIEN))
IF IBECDA
SET IBECERR=$$GET1^DIQ(351,IBECDA,18,"I")
IF IBECERR
Begin DoDot:3
+40 SET IBERRMSG="Query results contain inconsistent versioning - indicating MEANS TEST BILLING CLOCKs may be out of sync."
End DoDot:3
+41 SET IBFLAG1=1
End DoDot:2
End DoDot:1
+42 QUIT
+43 ;-------------------------------------------------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,IBERROR,IBERR,NAME,ERROR,XXX,WHOTO,IBACBCLK,IBADM,IBDISC,IBADMIT,IBDISCH
+3 NEW IBIEN,IBICN,IBQIEN,IBC0,IBODISCH,IBOADMIN,IBSTATION,IBADM1,IBCLDT,IBOADMIT,IBSTAT
+4 ;
+5 ;S IBC0=^IBE(351,IBCLDA,0)
+6 ;HL7 to FM - $$HL7TFM^XLFDT(DT)
+7 ;FM TO HL7 - $$FMTHL7^XLFDT(DT)
+8 ; Retrieve Admission and Discharge dates from the PTF file
+9 ;
+10 ;Get admit/discharge data
DO INPT^IBECECX1(DFN)
+11 IF $GET(IBADM1)
IF '$GET(IB351IEN)
SET IB351IEN=$$GETIEN^IBECECX1(DFN,IBADM1)
+12 SET IBICN=$$ICN^IBARXMU(DFN)
+13 ;quit if unable to find ICN
IF +IBICN<1
SET IBERROR="NO PATIENT ICN FOUND"
SET IBERR=1
QUIT
+14 ;Quit if patient has no other TFL's
SET IBTFL=$$TFL^IBARXMU(DFN,.IBTFL,2)
IF 'IBTFL
QUIT
+15 if $GET(IBERR)=""
SET IBERR=0
+16 DO MSH
DO QRD
DO QRF
DO SENDQRY
+17 KILL IB351IEN
+18 QUIT
+19 ;
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 MSG="^TMP("_"QRY"
+7 ;IB*2.0*769 - Add per VDIF
SET PARMS("MESSAGE STRUCTURE")="QRY_R02"
+8 SET X=$$NEWMSG^HLOAPI(.PARMS,.MSG,.ERROR)
+9 QUIT
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 SET VALUE=$GET(IB351IEN)
SET FIELD=4
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+7 ;S VALUE=QRYNUM,FIELD=4 D SET^HLOAPI(.SEG,VALUE,FIELD)
+8 SET VALUE=1
SET FIELD=7
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+9 SET NAME=$$GET1^DIQ(2,DFN_",",.01)
+10 SET VALUE=$PIECE($GET(NAME),",",1)
SET FIELD=8
DO SET^HLOAPI(.SEG,VALUE,FIELD,1)
+11 SET VALUE=$PIECE($GET(NAME),",",2)
SET FIELD=8
DO SET^HLOAPI(.SEG,VALUE,FIELD,2)
+12 SET VALUE=IBICN
SET FIELD=9
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+13 ; ADMIT DATE - bjr ib*769
SET FIELD=11
IF $GET(IBADMIT)
SET VALUE=$PIECE(IBADMIT,".")
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+14 ; Discharge date - bjr ib*769
SET FIELD=12
IF $GET(IBDISCH)
SET VALUE=$PIECE(IBDISCH,".")
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+15 SET X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
+16 QUIT
+17 ;
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")="200VDIF"
+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,IBQRYDT,IBEDIPI
+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^IBECECQ2(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 SET IB351IEN=$$GET^HLOPRS(.SEG,4,1,1,1)
+5 ;RRA IB*769
SET IBQRYDT=$$GET^HLOPRS(.SEG,1,1)
+6 ;BJR IB*769
SET IBEDIPI=$$GET^HLOPRS(.SEG,10,1,1,1)
+7 QUIT
+8 ;
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,IBVARRY,IBERRMSG,IBECERR,IBECDA,IBECNIEN,IBID,IBICLDTS,IBDISCH,IB3513,IBFDA,IBECVSRN
+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
End DoDot:1
+9 ;IBECERR - FLAG TO DETERMINE IF VERSIONING OUT OF SYNC
SET IBECERR=0
+10 ;DSR returned with query results - now validate the results based on clock version
IF IBERRMSG=""
SET IBECDA=$SELECT(+IB351IEN:IB351IEN,1:$GET(IBECNIEN))
IF IBECDA
SET IBECERR=$$VRSNCHK^IBECECX1(IBECDA)
+11 IF 'IBECERR
IF $GET(IBECDA)
SET IBECVSRN=$ORDER(IBVARRY(""))
IF IBECVSRN
Begin DoDot:1
+12 SET IENS=IBECDA_","
SET IBFDA(351,IENS,17)=IBECVSRN
DO FILE^DIE(,"IBFDA","IBERR")
End DoDot:1
+13 IF IBECERR
Begin DoDot:1
+14 LOCK +^IBE(351,IBECDA):$GET(DILOCKTM,5)
if '$TEST
QUIT
+15 SET DIE="^IBE(351,"
SET DA=IBECDA
SET DR="18///YES"
DO ^DIE
+16 LOCK -^IBE(351,IBECDA)
+17 SET IBERRMSG="Query results contain inconsistent versioning - indicating MEANS TEST BILLING CLOCKs may be out of sync."
+18 SET IBID=$GET(IBCLDA)
+19 ;Use billing clock start date from local entry
if $GET(IB351IEN)
SET IBICLDTS=$$GET1^DIQ(351,IB351IEN_",",.03,"E")
+20 DO ERR2^IBECECX1(IBERRMSG)
End DoDot:1
QUIT
+21 QUIT
+22 ;
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 IBADMIT=$$HL7TFM^XLFDT(IBADMIT)
+7 SET IBDISCH=$$GET^HLOPRS(.SEG,12,1,1,1)
+8 SET IBDISCH=$$HL7TFM^XLFDT(IBDISCH)
+9 SET IB351IEN=$$GET^HLOPRS(.SEG,4,1,1,1)
+10 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,IBODISCH,IBOADMIN,IBQRY,IBCRTST,IBISTN,IBIVRSN,IBFVRSN1,IBDAYS,IBADTSV,IBISETID,IBISITE
+3 ;Result Messages/Errors
SET IBERRMSG=$$GET^HLOPRS(.SEG,5,1)
+4 ;if error occurred call error handling and quit processing
+5 ;IB*2.0*769 - MVI message returned from VDIF when no active clocks found per HBM request
IF IBERRMSG["MVI returned no treating facilities for this patient"
SET IBERRMSG=""
+6 ;IB*2.0*769 - Clear error message for VistA when no clock found
IF IBERRMSG["NO MEANS TEST BILLING CLOCK FOUND"
SET IBERRMSG=""
+7 ;IB*2.0*769 Clear error message for HBM no Member response
IF IBERRMSG["No Member found"
SET IBERRMSG=""
+8 ;IB*2.0*769 Clear error message for HBM No clock found for Parameters
IF IBERRMSG["No clock found for Parameters"
SET IBERRMSG=""
+9 IF IBERRMSG'=""
Begin DoDot:1
+10 SET IBID=$GET(IBCLDA)
+11 ;S IBICLDTS=$G(IBADMIT)
+12 ;Use billing clock start date from local entry
if IB351IEN
SET IBICLDTS=$$GET1^DIQ(351,IB351IEN_",",.03,"E")
+13 IF IBERRMSG["Billing Clock found at site #"
Begin DoDot:2
+14 ;Call ERR2 for Clock discrepancy issues
DO ERR2^IBECECX1(IBERRMSG)
End DoDot:2
QUIT
+15 SET IBERRMSG="Query attempt failed - "_IBERRMSG
DO ERR1^IBECECX1(IBERRMSG)
+16 IF IB351IEN
SET DIE="^IBE(351,"
SET DA=IB351IEN
SET DR="16///@"
DO ^DIE
End DoDot:1
QUIT
+17 SET IBCNT=$$GET^HLOPRS(.SEG,1,1)
+18 ;FT1 Response - bjr
SET IBISETID=$$GET^HLOPRS(.SEG,3,1)
+19 ;Billing Clock start date - bjr
SET IBICLDT=$$GET^HLOPRS(.SEG,3,2)
+20 ;convert HL7 date TO FM - bjr
if IBICLDT
SET IBICLDT=$$HL7TFM^XLFDT(IBICLDT)
+21 ;1st QRT charges - bjr
SET IBI901=$$GET^HLOPRS(.SEG,3,3)
+22 ;2nd QRT charges - bjr
SET IBI902=$$GET^HLOPRS(.SEG,3,4)
+23 ;3rd QRT charges - bjr
SET IBI903=$$GET^HLOPRS(.SEG,3,5)
+24 ;4th QRT charges - bjr
SET IBI904=$$GET^HLOPRS(.SEG,3,6)
+25 ;Inpatient days - bjr
SET IBICLDAY=$$GET^HLOPRS(.SEG,3,7)
+26 ;Billing clock end date - bjr
SET IBICLNDT=$$GET^HLOPRS(.SEG,3,8)
+27 ;Station Number
SET IBISTN=$$GET^HLOPRS(.SEG,3,9,1)
+28 ;Billing Clock Version
SET IBIVRSN=$$GET^HLOPRS(.SEG,3,9,2)
+29 ;Full billing clock version
SET IBFVRSN1=IBISTN_" "_IBIVRSN
+30 ;if no version, set to 0
IF +IBFVRSN1=0
SET IBFVRSN1=0
+31 ;HL7 TO FM - bjr
SET IBICLNDT=$$HL7TFM^XLFDT(IBICLNDT)
+32 SET IBICKDT=IBICLNDT
+33 ;RRA currently nothing passed in the 4th field - leaving for integration with Cerner
+34 ;FT2 set id (IF PRESENT)
SET IBSETID1=$$GET^HLOPRS(.SEG,4,1)
+35 ;Billing Clock start date
SET IBCLDT1=$$GET^HLOPRS(.SEG,4,2)
+36 ;convert HL7 date TO FM
if IBCLDT1
SET IBCLDT1=$$HL7TFM^XLFDT(IBCLDT1)
+37 ;1st QRT charges
SET IB9011=$$GET^HLOPRS(.SEG,4,3)
+38 ;2nd QRT charges
SET IB9021=$$GET^HLOPRS(.SEG,4,4)
+39 ;3rd QRT charges
SET IB9031=$$GET^HLOPRS(.SEG,4,5)
+40 ;4th QRT charges
SET IB9041=$$GET^HLOPRS(.SEG,4,6)
+41 ;Inpatient days
SET IBCLDAY1=$$GET^HLOPRS(.SEG,4,7)
+42 ;S IBICKDT=$$GET^HLOPRS(.SEG,4,8) ;Billing clock end date
+43 ;S IBICKDT=$$HL7TFM^XLFDT(IBICKDT) ;convert HL7 date TO FM
+44 ;Clock Status
SET IBISTAT=$$GET^HLOPRS(.SEG,6,1)
+45 ;Number of billing clocks sent (FT1)
SET IBCKNUM=$$GET^HLOPRS(.SEG,7,1)
+46 ;Number of admit encounters sent (FT2) - bjr
SET IBICNUM=$$GET^HLOPRS(.SEG,8,1)
+47 ;Site - bjr
SET IBISITE=$$GET^HLOPRS(.SEG,9,1)
+48 ;Quit if no clock start date sent which indicates no clocks from other sites
IF 'IBICLDT
DO UDCL^IBECECX1
QUIT
+49 IF $GET(IB351IEN)
IF IBCNT=1
Begin DoDot:1
+50 SET IBCBDT=$$GET1^DIQ(351,IB351IEN_",",.03,"I")
+51 SET IBQRYS=$$GET1^DIQ(351,IB351IEN_",",16,"I")
+52 SET IBCRTST=$$GET1^DIQ(351,IB351IEN_",",.04,"I")
+53 SET IBDAYS=$$GET1^DIQ(351,IB351IEN_",",.09,"I")
+54 SET IBDA1=IB351IEN
End DoDot:1
+55 if (IBICLDT<1)
QUIT
+56 ;Update record if current Billing Clock Start Date matches incoming Billing Clock Start Date
IF (($GET(IBCBDT)=IBICLDT)!($GET(IB351IEN)))
IF IBCNT=1
DO UPDATE^IBECECU1(IBDA1)
QUIT
+57 ;IBCNT=1 MEANS THE DSR SEGMENT IS AGGREGATED DATA AND SHOULD BE STORED IN 351
IF IBCNT=1
DO NEWREC^IBECECU1
+58 ;IBCNT>1 MEANS IT IS INDIVIDUAL SITE DATA USED FOR AGGREGATION UPDATE CLOCK VERSION ARRAY AND NEEDS TO BE STORED IN 351.3
IF IBCNT>1
IF $GET(IB351IEN)
if $PIECE(IBFVRSN1," ",2)
SET IBVARRY(IBFVRSN1)=""
DO EN^IBECECU2(IB351IEN,DFN)
+59 ;Use new clock IEN when one is created
IF IBCNT>1
IF '$GET(IB351IEN)
IF $GET(IBECNIEN)
if $PIECE(IBFVRSN1," ",2)
SET IBVARRY(IBFVRSN1)=""
DO EN^IBECECU2(IBECNIEN,DFN)
+60 SET IBADTSV=IBADMIT
if $GET(IBICLNDT)
SET IBADMIT=$$FMADD^XLFDT(IBICLNDT,1)
+61 ;
IF ($$FMTHL7^XLFDT(IBICLNDT))<IBDISCH
IF IBCNT=1
Begin DoDot:1
+62 SET IBQRY=$ORDER(^IBE(351,"AIVDT",DFN,-IBADMIT,";"),-1)
IF IBQRY
IF $PIECE(^IBE(351,IBQRY,1),U,5)
QUIT
+63 SET IBADMIT=$$FMADD^XLFDT(IBICLNDT,1)
SET IBDISCH=$$FMADD^XLFDT(IBADMIT,365)
SET IBADMIT=$$FMTHL7^XLFDT(IBADMIT)
SET IBOADMIT=IBADMIT
+64 SET IBDISCH=$SELECT(IBDISCH<DT:IBDISCH,1:"")
IF IBDISCH
SET IBDISCH=$$FMTHL7^XLFDT(IBDISCH)
SET IBODISCH=IBDISCH
+65 KILL SEG,ERROR
+66 DO MSH
DO QRD
DO QRF
DO SENDQRY
End DoDot:1
+67 SET IBADMIT=IBADTSV
+68 QUIT
+69 ;
