IBECECU1 ;BSL/DVA-BILLING SEND/RECEIVE DFT HL7 MESSAGES PATIENT ACCUMULATOR INTERFACE - SEND/RECEIVE A DFT UPDATE TO/FROM OTHER SITES ; 08 Jul 2022 9:21 AM
;;2.0;INTEGRATED BILLING;**704**;21-MAR-94;Build 49
;Per VA Directive 6402, this routine should not be modified.
; This routine will manage the 365 Inpatient stay clock
;
;IA# Supports
;------ -------------------------------------------------
; Reference to $STARTMSG^HLOPRS,$$NEXTSEG^HLOPRS,$$GET^HLOPRS in ICR #4718
; Reference to $$ADDSEG^HLOAPI,SET^HLOAPI in ICR #4722
; Reference to $$SENDONE^HLOAPI1 in ICR #4717
; Reference to $$GETDFN^MPIF001 in ICR #2701
;
; ; ; This will fire off an update (active 365 day clock) entry in file #351,
; - First when a new entry (clock) is started
; - Every quarter when the income amounts are entered
; - then when the Pt is discharged.
;Sample message:
; MSH|^~\&|IBECEAC-SEND|695^HL7.IVMVEE.FO-ALBANY.DOMAIN.EXT:5127^DNS|IBECEAC-RECV|200CRNR^:^DNS|20211008123507-0500||DFT^P03^DFT_P03|695 1471|T^|2.3|||AL|NE|USA
; EVN|P03|20211013143704-0500
; PID|1008713999V404928|DRI|^DODMORE MESSAGE
; FT1|2|3201101|1|345||||15|3211101
; FT2|
;
Q ;No direct routine calls
;
EN(DFN,IBCLDA) ; OUTGOING DFT PRIMARY ENTRY POINT
; IBCLDA - IEN FROM 351
;CALLED FROM ^IBAUTL3 (CLADD [new] AND CLUPD [updates])
N X,PARMS,SEG,MSG,VALUE,FIELD,QRYNUM,SERROR,SERR,NAME,ERROR,XXX,WHOTO,IBACBCLK,IBADM,IBDISCH,IBADMIT,IBIEN,IBICN,IBQIEN
N IBCLDT,IBSTAT,IB901,IB902,IB903,IB904,IBCLDAY,IBCLNDT,IBNADM,IBNAME,IBSITE,IBSOC
;
I $P($G(^IBE(351,IBCLDA,1)),U,5)="" Q
D INPT^IBECECX1(DFN) ;Get admit/discharge dates
S NAME=$$GET1^DIQ(2,DFN_",",.01)
D MSH,PARSE,EVN,PID Q:'IBICN ;Do not send Message if no Patient ICN
D FT1,FT2,SEND
Q
;
;
MSH ; Build outgoing MSH Segment
N PARMS K ^TMP("DFT")
S PARMS("COUNTRY")="USA"
S PARMS("MESSAGE TYPE")="DFT"
S PARMS("EVENT")="P03"
S PARMS("SENDING APPLICATION")="IBECEAC-SEND"
S PARMS("VERSION")="2.3"
S PARMS("MESSAGE STRUCTURE")="DFT_P03"
S MSG="^TMP(DFT"
S X=$$NEWMSG^HLOAPI(.PARMS,.MSG,.ERROR)
Q
EVN ; Build outgoing EVN Segment
S VALUE="EVN",FIELD=0 D SET^HLOAPI(.SEG,VALUE,FIELD)
;S VALUE="P03",FIELD=1 D SET^HLOAPI(.SEG,VALUE,FIELD) ;We were asked to remove this value until further notice
D NOW^%DTC S VALUE=$$FMTHL7^XLFDT(%),FIELD=2
D SET^HLOAPI(.SEG,VALUE,FIELD)
;
S VALUE=IBSTAT,FIELD=3 D SET^HLOAPI(.SEG,VALUE,FIELD) ;Billing clock status
S VALUE=1,FIELD=4 D SET^HLOAPI(.SEG,VALUE,FIELD) ;Number of billing clocks sent (0-3)
;
;BL;Cerner wants Encounter info sent. VistA is not using it. This is left until Cerner interface
S VALUE=$G(IBNADM),FIELD=5 D SET^HLOAPI(.SEG,VALUE,FIELD) ;Number of encounters sent
S VALUE=$G(IBEVFAC),FIELD=6 D SET^HLOAPI(.SEG,VALUE,FIELD) ;Event Facility
S X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
Q
PID ; Build outgoing PID Segment
S VALUE="PID",FIELD=0 D SET^HLOAPI(.SEG,VALUE,FIELD)
S IBICN=$$ICN^IBARXMU(DFN) Q:'IBICN ;Do not send Message if no Patient ICN
S VALUE=DFN,FIELD=1 D SET^HLOAPI(.SEG,VALUE,FIELD)
I +IBICN<1 S SERROR="NO PATIENT ICN FOUND",SERR=1
S VALUE=IBICN,FIELD=2 D SET^HLOAPI(.SEG,VALUE,FIELD)
S VALUE=NAME,FIELD=4 D SET^HLOAPI(.SEG,VALUE,FIELD)
;S VALUE=$P(NAME,",",1),FIELD=2 D SET^HLOAPI(.SEG,VALUE,FIELD,1)
;S VALUE=$P(NAME,",",2),FIELD=3 D SET^HLOAPI(.SEG,VALUE,FIELD,2)
S X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
Q
;
FT1 ; Build FT1 Outgoing segment
D SET^HLOAPI(.SEG,"FT1",0)
D SET^HLOAPI(.SEG,+IBCLDA,1) ;file 351 IEN
D SET^HLOAPI(.SEG,+IBCLDT,2) ;Billing clock begin date
D SET^HLOAPI(.SEG,+IBSTAT,3) ;Billing clock Status
D SET^HLOAPI(.SEG,+IB901,4) ;1ST QTR CHARGES
D SET^HLOAPI(.SEG,+IB902,5) ;2ND QTR CHARGES
D SET^HLOAPI(.SEG,+IB903,6) ;3RD QTR CHARGES
D SET^HLOAPI(.SEG,+IB904,7) ;4TH QTR CHARGES
D SET^HLOAPI(.SEG,+IBCLDAY,8) ;Number of Inpatient days
D SET^HLOAPI(.SEG,+IBCLNDT,9) ;End of 365 day clock
S X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
Q
FT2 ;BUILD OUTGOING FT2 SEGMENT
;FT2 Segment not populated until Cerner interface is designed
;D SET^HLOAPI(.SEG,"FT2",0)
;S X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
Q
;
SEND ;SEND MESSAGE AND QUIT
S WHOTO("RECEIVING APPLICATION")="IBECEAC-RCV"
S WHOTO("STATION NUMBER")="200DAS"
S WHOTO("MIDDLEWARE LINK NAME")="IBECEC-DFT"
S PARMS("SENDING APPLICATION")="IBECEAC-SEND"
S XXX=$$SENDONE^HLOAPI1(.MSG,.PARMS,.WHOTO,.ERROR)
Q
;
;-----------------------------------------------INCOMING DFT ------------------
RECV ; INCOMING DFT PRIMARY ENTRY POINT
N DFN,IBHDR,IBMSG,SEG,IBSEGT,IBSTAT,IBWHAT,ICN,MSGTYPE,IBIEN,DATEQ,ERR,HLERR,IBAEVNT,IBEVFAC,IBEVOCC,IBQRYS
N IBI901,IBI902,IBI903,IBI904,IBICKDT,IBICLDAY,IBICLDT,IBICNAL,IBISTAT,IBACTC,IBCKNUM,IBICNUM,IBDA,IBCBDT,IBSNDST,IBDA1
S ERR=0,IBSTAT=$$STARTMSG^HLOPRS(.IBMSG,HLMSGIEN,.IBHDR)
S IBIEN=HLMSGIEN
I 'IBSTAT S HLERR="Unable to start parse of message" Q
I "DFT"'[IBHDR("MESSAGE TYPE") Q
;
F Q:'$$NEXTSEG^HLOPRS(.IBMSG,.SEG) S IBSEGT=$G(SEG("SEGMENT TYPE")) Q:IBSEGT="" D
. I IBSEGT="EVN" D EVNI
. I IBSEGT="PID" D PIDI
. I IBSEGT="FT1" D FT1I
. I IBSEGT="FT2" D FT2I
Q:'$G(IBICLDT) ;Quit if no billing clocks returned
S IBSNDST=$G(IBMSG("HDR","SENDING FACILITY",1))
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 IBDA1=IBDA
I $G(IBCBDT)=IBICLDT D UPDATE(IBDA1) Q ;Update record if current Billing Clock Start Date matches incoming Billing Clock Start Date
D NEWREC ;FILE DATA IN FILE 351
Q
;
EVNI ;Parse Incoming EVN Segment
S IBAEVNT=$$GET^HLOPRS(.SEG,1,1) ;Date/time of event
S IBAEVNT=$$FMTHL7^XLFDT(IBAEVNT) ;convert date to FM
S IBACTC=$$GET^HLOPRS(.SEG,2,1) ;Active billing clock sent
S IBCKNUM=$$GET^HLOPRS(.SEG,3,1) ;Number of clocks sent
S IBICNUM=$$GET^HLOPRS(.SEG,4,1) ;Number of admit encounters sent
S IBEVFAC=$$GET^HLOPRS(.SEG,5,1) ;Event Facility
Q
;
PIDI ;Parse Incoming PID Segment
S IBICN=$$GET^HLOPRS(.SEG,1,1) ;Alternate Patient ID (DFN)
S IBICNAL=$$GET^HLOPRS(.SEG,2,1) ;Patient ICN
S DFN=$$GETDFN^MPIF001(IBICNAL) ;Patient DFN
S IBNAME=$$GET^HLOPRS(.SEG,4,1) ;Pt name
Q
;Get data from HL7 message from QRD and DSP
FT1I ;Parse Incoming FT1 Segment, assumes one record only
; Get new 365 day clock data
S IBCLDA=$$GET^HLOPRS(.SEG,1,1) ;Reference number
S IBICLDT=$$GET^HLOPRS(.SEG,2,1) ;Billing clock start date
S IBICLDT=$$HL7TFM^XLFDT(IBICLDT) ;convert HL7 date to FM
S IBISTAT=$$GET^HLOPRS(.SEG,3,1) ;Status of clock
S IBI901=$$GET^HLOPRS(.SEG,4,1) ;1ST QTR CHARGES
S IBI902=$$GET^HLOPRS(.SEG,5,1) ;2ND QTR CHARGES
S IBI903=$$GET^HLOPRS(.SEG,6,1) ;3RD QTR CHARGES
S IBI904=$$GET^HLOPRS(.SEG,7,1) ;4TH QTR CHARGES
S IBICLDAY=$$GET^HLOPRS(.SEG,8,1) ;Inpatient Days on the received clock
S IBICKDT=$$GET^HLOPRS(.SEG,9,1) ;Clock end date
S:IBICKDT IBICKDT=$$HL7TFM^XLFDT(IBICKDT) ;convert HL7 date to FM
Q
FT2I ;Parse Incoming FT1 Segment,
;For future expansion to Cerner
Q
;
PARSE ; Get the updated clock data to send via DFT
N IBARRAY,IBERR
; Get the values of the new IBE(351) entry
D GETS^DIQ(351,IBCLDA_",","**","I","IBARRAY","IBERR")
S IBSITE=$$SITE^IBATUTL ;Site number
S IBCLDT=IBARRAY(351,IBCLDA_",",.03,"I") ;Clock start date
S IBCLDT=$$FMTHL7^XLFDT(IBCLDT) ;convert HL7 date to FM
S IBSTAT=IBARRAY(351,IBCLDA_",",.04,"I") ;Status
S IB901=IBARRAY(351,IBCLDA_",",.05,"I") ;1st QTR CHARGES
S IB902=IBARRAY(351,IBCLDA_",",.06,"I") ;2nd QTR CHARGES
S IB903=IBARRAY(351,IBCLDA_",",.07,"I") ;3rd QTR CHARGES
S IB904=IBARRAY(351,IBCLDA_",",.08,"I") ;4th QTR CHARGES
S IBCLDAY=IBARRAY(351,IBCLDA_",",.09,"I") ;Number of inpatient days
S IBCLNDT=IBARRAY(351,IBCLDA_",",.1,"I") ;End date of the clock
S IBCLNDT=$$FMTHL7^XLFDT(IBCLNDT) ;convert HL7 date to FM
Q
;
NEWREC ;Create a new entry in file 351
L +^IBE(351,0):$G(DILOCKTM,5) Q:'$T
N DIC,IBFDA,IEN,IENS,X,Y,IEN351,IBDUZ,IBDTUP,IBREASON,DIE,DA,DR
S DIC="^IBE(351,",DIC(0)=""
S X=$P(^IBE(351,$P(^IBE(351,0),U,3),0),U,1)+1
D FILE^DICN S (IENS,IEN)=$P(Y,U,1),DA=$P(Y,U,1) S IENS=IENS_","
;IBFDA(FILE#,"IENS",FIELD#)="VALUE"
I $G(IBICNAL)'="" S DFN=$$GETDFN^MPIF001(IBICNAL)
I DFN="" L -^IBE(351,0) Q
S IBFDA(351,IENS,.02)=DFN
;
;Need to do aggregation of incoming clock with local data on Query Responses (DSR)
I $G(IBAGG)=1 D AGGR ;Has this data been aggregated with local data
S IBFDA(351,IENS,.03)=$G(IBICLDT)
S IEN351=0 F S IEN351=$O(^IBE(351,"ACT",DFN,IEN351)) Q:IEN351="" D ;loop through "current" clock xref
. Q:$G(IBICLNDT) ;Quit if incoming clock is closed
. I $$GET1^DIQ(351,IEN351_",",.04,"I")=1 D
.. S DIE="^IBE(351,",DA=IEN351,DR=".04///3;"
.. S IBDUZ=$G(DUZ,.5),DR=DR_";13///^S X=IBDUZ"
.. S IBDTUP=$$NOW^XLFDT,DR=DR_";14///^S X=IBDTUP",DR=DR_";14///^S X=IBDTUP"
.. I $G(IBCNT) S IBREASON=$S($G(IBSNDST)'="":"Billing Clock update from Sta #"_IBSNDST,1:"Billing Clock update from Query"),DR=DR_";15///^S X=IBREASON"
.. I '$G(IBCNT) S IBREASON="Billing Clock update from Query"
.. D ^DIE ;Use fileman to properly delete ACT x-ref
.. K DIE,DA,DR
S IBFDA(351,IENS,.04)=$G(IBISTAT)
S IBFDA(351,IENS,.05)=$G(IBI901)
S IBFDA(351,IENS,.06)=$G(IBI902)
S IBFDA(351,IENS,.07)=$G(IBI903)
S IBFDA(351,IENS,.08)=$G(IBI904)
S IBFDA(351,IENS,.09)=$G(IBICLDAY)
S:$G(IBICKDT) IBFDA(351,IENS,.1)=IBICKDT
S IBFDA(351,IENS,15)=$S($G(IBSNDST)'="":"Billing Clock update from Sta #"_IBSNDST,1:"Billing Clock update from Query")
S IBFDA(351,IENS,11)=.5
S IBFDA(351,IENS,12)=$$NOW^XLFDT
S IBFDA(351,IENS,13)=.5
S IBFDA(351,IENS,14)=$$NOW^XLFDT
S IBFDA(351,IENS,16)=1 ;Set query sent field for aggregated date stored
D FILE^DIE(,"IBFDA","IBERR")
L -^IBE(351,0)
Q
;
AGGR ;Data has been aggregated at DAS, but may not have taken into account local data
;
N NODE,IBDA,NODE0,AGG,IBSTDT,IBFLG
S AGG=0
;1. If no active local clock quit
;2. If local active clock and the start dates are not the same, aggregate
;3. If local active clock and start dates are the same, and days inpatient are Less than query, aggregate
;4. If local active clock and start dates are the same, and days inpatient are greater than query, quit
;
;get local clock data (#351)
S NODE=$S(IBICLNDT:-IBICLNDT_.9999,1:-DT_.9999)
F S NODE=$O(^IBE(351,"AIVDT",DFN,NODE)) Q:'NODE Q:$G(IBFLG) D
.S IBDA=";" F S IBDA=$O(^IBE(351,"AIVDT",DFN,NODE,IBDA),-1) Q:'IBDA I $P(^IBE(351,IBDA,0),U,4),$P(^IBE(351,IBDA,0),U,4)<3 S IBFLG=1 Q
Q:'$G(IBDA)
S NODE0=^IBE(351,IBDA,0)
Q:$P(NODE0,"^",3)<IBICLDT
S IBSTDT=$P(NODE0,"^",3) ;use earliest billing clock if local
I $P(NODE0,"^",3)'=IBICLDT S AGG=1
I $P(NODE0,"^",3)=IBICLDT D
. I $P(NODE0,"^",9)<IBICLDAY S AGG=1 Q
Q:'AGG
I $G(IBICLNDT)<DT ;D MULTCLK - For future Cerner work
;Aggregate the incoming clock and the active clock
S IBICLDAY=IBICLDAY+($P(NODE0,"^",9))
S IBI901=IBI901+($P(NODE0,"^",5))
S IBI902=IBI902+($P(NODE0,"^",6))
S IBI903=IBI903+($P(NODE0,"^",7))
S IBI904=IBI904+($P(NODE0,"^",8))
I IBSTDT<IBICLDT S IBICLDT=IBSTDT ;use earliest billing clock if local
Q
;
MULTCLK ;Need to create multiple clocks - For future Cerner work
;If billing clock closed date < today
;use the PTF to determine billing days
;Q:'IBICLNDT
;N IBECDT,IBECDA,IBCLKST,IBCLKED,IBADMIT,IBADM1,IBIEN,IBDISCH
;S IBECDT="" F S IBECDT=$O(^IBE(351,"AIVDT",DFN,IBECDT)) Q:'IBECDT Q:(IBECDT>IBICLNDT) D
;.S IBECDA=";" F S IBECDA=$O(^IBE(351,"AIVDT",DFN,IBECDT,IBECDA),-1) Q:'IBECDA Q:$$GET1^DIQ(351,IBECDA_",",.04,"I")=3 D
;..S IBCLKST=$$GET1^DIQ(351,IBECDA_",",.03,"I"),IBCLKED=$$GET1^DIQ(351,IBECDA_",",.1,"I")
;..S IBDAY=$$FMDIFF^XLFDT($S(IBCLKED:IBCLKED,1:DT),IBCLKST)+1 S IBMTBC(DFN,IBCLKST)=IBCLKST_U_IBCLKED_U_IBDAY
;..I IBCLKST<IBICLNDT,(IBCLKST>IBICLDT) D
;...S IBADMIT=-IBECDT_".9999",IBADMIT=$O(^DGPT("AAD",DFN,IBADMIT),-1),IBADM1=IBADMIT I IBADMIT S IBIEN=$O(^DGPT("AAD",DFN,IBADMIT,0)),IBDISCH=$P($G(^DGPT(IBIEN,70)),U)
;...;I IBDISCH>IBICLNDT D CHCKDAYS - For future Cerner work
;Q
;
CHCKDAYS ;Check days for each clock - For future Cerner work
;N IBICLDT1
;S IBICLDT1=IBICLNDT-.0001 F S IBICLDT1=$O(^DGPT("AAD",DFN,IBICLDT1)) Q:'IBICLDT1 S IBIEN=$O(^DGPT("AAD",DFN,IBICLDT1,0)),IBADMIT=$P($G(^DGPT(IBIEN,0)),U,2),IBDISCH=$P($G(^DGPT(IBIEN,70)),U) D
;.S IBDAYS=$$FMDIFF^XLFDT($S(IBDISCH:IBDISCH,1:DT),IBADMIT)+1 S IBPTF(DFN,IBADMIT)=IBADMIT_U_IBDISCH_U_IBDAYS
;Q
;
UPDATE(IBDA) ;Update records when Billing Clock start date is the same
N DIE,DA,IBDTUP,IBDUZ
L +^IBE(351,IBDA):$G(DILOCKTM,5) Q:'$T
S DIE="^IBE(351,",DA=IBDA,DR=".04///^S X=IBISTAT"
S DR=DR_";.05///"_+IBI901
S DR=DR_";.06///"_+IBI902
S DR=DR_";.07///"_+IBI903
S DR=DR_";.08///"_+IBI904
S DR=DR_";.09///"_+IBICLDAY
S:IBICKDT DR=DR_";.1///^S X=IBICKDT"
S IBDUZ=$G(DUZ,.5),DR=DR_";13///^S X=IBDUZ"
S IBDTUP=$$NOW^XLFDT,DR=DR_";14///^S X=IBDTUP"
S IBREASON=$S($G(IBSNDST)'="":"Billing Clock update from Sta #"_IBSNDST,1:"Billing Clock update from Query"),DR=DR_";15///^S X=IBREASON"
S DR=DR_";16///1" ;Set query sent field for aggregated date stored
D ^DIE
L -^IBE(351,DA)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBECECU1 13506 printed Sep 15, 2024@21:45:40 Page 2
IBECECU1 ;BSL/DVA-BILLING SEND/RECEIVE DFT HL7 MESSAGES PATIENT ACCUMULATOR INTERFACE - SEND/RECEIVE A DFT UPDATE TO/FROM OTHER SITES ; 08 Jul 2022 9:21 AM
+1 ;;2.0;INTEGRATED BILLING;**704**;21-MAR-94;Build 49
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ; This routine will manage the 365 Inpatient stay clock
+4 ;
+5 ;IA# Supports
+6 ;------ -------------------------------------------------
+7 ; Reference to $STARTMSG^HLOPRS,$$NEXTSEG^HLOPRS,$$GET^HLOPRS in ICR #4718
+8 ; Reference to $$ADDSEG^HLOAPI,SET^HLOAPI in ICR #4722
+9 ; Reference to $$SENDONE^HLOAPI1 in ICR #4717
+10 ; Reference to $$GETDFN^MPIF001 in ICR #2701
+11 ;
+12 ; ; ; This will fire off an update (active 365 day clock) entry in file #351,
+13 ; - First when a new entry (clock) is started
+14 ; - Every quarter when the income amounts are entered
+15 ; - then when the Pt is discharged.
+16 ;Sample message:
+17 ; MSH|^~\&|IBECEAC-SEND|695^HL7.IVMVEE.FO-ALBANY.DOMAIN.EXT:5127^DNS|IBECEAC-RECV|200CRNR^:^DNS|20211008123507-0500||DFT^P03^DFT_P03|695 1471|T^|2.3|||AL|NE|USA
+18 ; EVN|P03|20211013143704-0500
+19 ; PID|1008713999V404928|DRI|^DODMORE MESSAGE
+20 ; FT1|2|3201101|1|345||||15|3211101
+21 ; FT2|
+22 ;
+23 ;No direct routine calls
QUIT
+24 ;
EN(DFN,IBCLDA) ; OUTGOING DFT PRIMARY ENTRY POINT
+1 ; IBCLDA - IEN FROM 351
+2 ;CALLED FROM ^IBAUTL3 (CLADD [new] AND CLUPD [updates])
+3 NEW X,PARMS,SEG,MSG,VALUE,FIELD,QRYNUM,SERROR,SERR,NAME,ERROR,XXX,WHOTO,IBACBCLK,IBADM,IBDISCH,IBADMIT,IBIEN,IBICN,IBQIEN
+4 NEW IBCLDT,IBSTAT,IB901,IB902,IB903,IB904,IBCLDAY,IBCLNDT,IBNADM,IBNAME,IBSITE,IBSOC
+5 ;
+6 IF $PIECE($GET(^IBE(351,IBCLDA,1)),U,5)=""
QUIT
+7 ;Get admit/discharge dates
DO INPT^IBECECX1(DFN)
+8 SET NAME=$$GET1^DIQ(2,DFN_",",.01)
+9 ;Do not send Message if no Patient ICN
DO MSH
DO PARSE
DO EVN
DO PID
if 'IBICN
QUIT
+10 DO FT1
DO FT2
DO SEND
+11 QUIT
+12 ;
+13 ;
MSH ; Build outgoing MSH Segment
+1 NEW PARMS
KILL ^TMP("DFT")
+2 SET PARMS("COUNTRY")="USA"
+3 SET PARMS("MESSAGE TYPE")="DFT"
+4 SET PARMS("EVENT")="P03"
+5 SET PARMS("SENDING APPLICATION")="IBECEAC-SEND"
+6 SET PARMS("VERSION")="2.3"
+7 SET PARMS("MESSAGE STRUCTURE")="DFT_P03"
+8 SET MSG="^TMP(DFT"
+9 SET X=$$NEWMSG^HLOAPI(.PARMS,.MSG,.ERROR)
+10 QUIT
EVN ; Build outgoing EVN Segment
+1 SET VALUE="EVN"
SET FIELD=0
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+2 ;S VALUE="P03",FIELD=1 D SET^HLOAPI(.SEG,VALUE,FIELD) ;We were asked to remove this value until further notice
+3 DO NOW^%DTC
SET VALUE=$$FMTHL7^XLFDT(%)
SET FIELD=2
+4 DO SET^HLOAPI(.SEG,VALUE,FIELD)
+5 ;
+6 ;Billing clock status
SET VALUE=IBSTAT
SET FIELD=3
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+7 ;Number of billing clocks sent (0-3)
SET VALUE=1
SET FIELD=4
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+8 ;
+9 ;BL;Cerner wants Encounter info sent. VistA is not using it. This is left until Cerner interface
+10 ;Number of encounters sent
SET VALUE=$GET(IBNADM)
SET FIELD=5
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+11 ;Event Facility
SET VALUE=$GET(IBEVFAC)
SET FIELD=6
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+12 SET X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
+13 QUIT
PID ; Build outgoing PID Segment
+1 SET VALUE="PID"
SET FIELD=0
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+2 ;Do not send Message if no Patient ICN
SET IBICN=$$ICN^IBARXMU(DFN)
if 'IBICN
QUIT
+3 SET VALUE=DFN
SET FIELD=1
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+4 IF +IBICN<1
SET SERROR="NO PATIENT ICN FOUND"
SET SERR=1
+5 SET VALUE=IBICN
SET FIELD=2
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+6 SET VALUE=NAME
SET FIELD=4
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+7 ;S VALUE=$P(NAME,",",1),FIELD=2 D SET^HLOAPI(.SEG,VALUE,FIELD,1)
+8 ;S VALUE=$P(NAME,",",2),FIELD=3 D SET^HLOAPI(.SEG,VALUE,FIELD,2)
+9 SET X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
+10 QUIT
+11 ;
FT1 ; Build FT1 Outgoing segment
+1 DO SET^HLOAPI(.SEG,"FT1",0)
+2 ;file 351 IEN
DO SET^HLOAPI(.SEG,+IBCLDA,1)
+3 ;Billing clock begin date
DO SET^HLOAPI(.SEG,+IBCLDT,2)
+4 ;Billing clock Status
DO SET^HLOAPI(.SEG,+IBSTAT,3)
+5 ;1ST QTR CHARGES
DO SET^HLOAPI(.SEG,+IB901,4)
+6 ;2ND QTR CHARGES
DO SET^HLOAPI(.SEG,+IB902,5)
+7 ;3RD QTR CHARGES
DO SET^HLOAPI(.SEG,+IB903,6)
+8 ;4TH QTR CHARGES
DO SET^HLOAPI(.SEG,+IB904,7)
+9 ;Number of Inpatient days
DO SET^HLOAPI(.SEG,+IBCLDAY,8)
+10 ;End of 365 day clock
DO SET^HLOAPI(.SEG,+IBCLNDT,9)
+11 SET X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
+12 QUIT
FT2 ;BUILD OUTGOING FT2 SEGMENT
+1 ;FT2 Segment not populated until Cerner interface is designed
+2 ;D SET^HLOAPI(.SEG,"FT2",0)
+3 ;S X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
+4 QUIT
+5 ;
SEND ;SEND MESSAGE AND QUIT
+1 SET WHOTO("RECEIVING APPLICATION")="IBECEAC-RCV"
+2 SET WHOTO("STATION NUMBER")="200DAS"
+3 SET WHOTO("MIDDLEWARE LINK NAME")="IBECEC-DFT"
+4 SET PARMS("SENDING APPLICATION")="IBECEAC-SEND"
+5 SET XXX=$$SENDONE^HLOAPI1(.MSG,.PARMS,.WHOTO,.ERROR)
+6 QUIT
+7 ;
+8 ;-----------------------------------------------INCOMING DFT ------------------
RECV ; INCOMING DFT PRIMARY ENTRY POINT
+1 NEW DFN,IBHDR,IBMSG,SEG,IBSEGT,IBSTAT,IBWHAT,ICN,MSGTYPE,IBIEN,DATEQ,ERR,HLERR,IBAEVNT,IBEVFAC,IBEVOCC,IBQRYS
+2 NEW IBI901,IBI902,IBI903,IBI904,IBICKDT,IBICLDAY,IBICLDT,IBICNAL,IBISTAT,IBACTC,IBCKNUM,IBICNUM,IBDA,IBCBDT,IBSNDST,IBDA1
+3 SET ERR=0
SET IBSTAT=$$STARTMSG^HLOPRS(.IBMSG,HLMSGIEN,.IBHDR)
+4 SET IBIEN=HLMSGIEN
+5 IF 'IBSTAT
SET HLERR="Unable to start parse of message"
QUIT
+6 IF "DFT"'[IBHDR("MESSAGE TYPE")
QUIT
+7 ;
+8 FOR
if '$$NEXTSEG^HLOPRS(.IBMSG,.SEG)
QUIT
SET IBSEGT=$GET(SEG("SEGMENT TYPE"))
if IBSEGT=""
QUIT
Begin DoDot:1
+9 IF IBSEGT="EVN"
DO EVNI
+10 IF IBSEGT="PID"
DO PIDI
+11 IF IBSEGT="FT1"
DO FT1I
+12 IF IBSEGT="FT2"
DO FT2I
End DoDot:1
+13 ;Quit if no billing clocks returned
if '$GET(IBICLDT)
QUIT
+14 SET IBSNDST=$GET(IBMSG("HDR","SENDING FACILITY",1))
+15 SET IBDA=";"
FOR
SET IBDA=$ORDER(^IBE(351,"AIVDT",DFN,-IBICLDT,IBDA),-1)
if 'IBDA
QUIT
if $GET(IBCBDT)
QUIT
Begin DoDot:1
+16 SET IBCBDT=$$GET1^DIQ(351,IBDA_",",.03,"I")
+17 SET IBQRYS=$$GET1^DIQ(351,IBDA_",",16,"I")
+18 SET IBDA1=IBDA
End DoDot:1
+19 ;Update record if current Billing Clock Start Date matches incoming Billing Clock Start Date
IF $GET(IBCBDT)=IBICLDT
DO UPDATE(IBDA1)
QUIT
+20 ;FILE DATA IN FILE 351
DO NEWREC
+21 QUIT
+22 ;
EVNI ;Parse Incoming EVN Segment
+1 ;Date/time of event
SET IBAEVNT=$$GET^HLOPRS(.SEG,1,1)
+2 ;convert date to FM
SET IBAEVNT=$$FMTHL7^XLFDT(IBAEVNT)
+3 ;Active billing clock sent
SET IBACTC=$$GET^HLOPRS(.SEG,2,1)
+4 ;Number of clocks sent
SET IBCKNUM=$$GET^HLOPRS(.SEG,3,1)
+5 ;Number of admit encounters sent
SET IBICNUM=$$GET^HLOPRS(.SEG,4,1)
+6 ;Event Facility
SET IBEVFAC=$$GET^HLOPRS(.SEG,5,1)
+7 QUIT
+8 ;
PIDI ;Parse Incoming PID Segment
+1 ;Alternate Patient ID (DFN)
SET IBICN=$$GET^HLOPRS(.SEG,1,1)
+2 ;Patient ICN
SET IBICNAL=$$GET^HLOPRS(.SEG,2,1)
+3 ;Patient DFN
SET DFN=$$GETDFN^MPIF001(IBICNAL)
+4 ;Pt name
SET IBNAME=$$GET^HLOPRS(.SEG,4,1)
+5 QUIT
+6 ;Get data from HL7 message from QRD and DSP
FT1I ;Parse Incoming FT1 Segment, assumes one record only
+1 ; Get new 365 day clock data
+2 ;Reference number
SET IBCLDA=$$GET^HLOPRS(.SEG,1,1)
+3 ;Billing clock start date
SET IBICLDT=$$GET^HLOPRS(.SEG,2,1)
+4 ;convert HL7 date to FM
SET IBICLDT=$$HL7TFM^XLFDT(IBICLDT)
+5 ;Status of clock
SET IBISTAT=$$GET^HLOPRS(.SEG,3,1)
+6 ;1ST QTR CHARGES
SET IBI901=$$GET^HLOPRS(.SEG,4,1)
+7 ;2ND QTR CHARGES
SET IBI902=$$GET^HLOPRS(.SEG,5,1)
+8 ;3RD QTR CHARGES
SET IBI903=$$GET^HLOPRS(.SEG,6,1)
+9 ;4TH QTR CHARGES
SET IBI904=$$GET^HLOPRS(.SEG,7,1)
+10 ;Inpatient Days on the received clock
SET IBICLDAY=$$GET^HLOPRS(.SEG,8,1)
+11 ;Clock end date
SET IBICKDT=$$GET^HLOPRS(.SEG,9,1)
+12 ;convert HL7 date to FM
if IBICKDT
SET IBICKDT=$$HL7TFM^XLFDT(IBICKDT)
+13 QUIT
FT2I ;Parse Incoming FT1 Segment,
+1 ;For future expansion to Cerner
+2 QUIT
+3 ;
PARSE ; Get the updated clock data to send via DFT
+1 NEW IBARRAY,IBERR
+2 ; Get the values of the new IBE(351) entry
+3 DO GETS^DIQ(351,IBCLDA_",","**","I","IBARRAY","IBERR")
+4 ;Site number
SET IBSITE=$$SITE^IBATUTL
+5 ;Clock start date
SET IBCLDT=IBARRAY(351,IBCLDA_",",.03,"I")
+6 ;convert HL7 date to FM
SET IBCLDT=$$FMTHL7^XLFDT(IBCLDT)
+7 ;Status
SET IBSTAT=IBARRAY(351,IBCLDA_",",.04,"I")
+8 ;1st QTR CHARGES
SET IB901=IBARRAY(351,IBCLDA_",",.05,"I")
+9 ;2nd QTR CHARGES
SET IB902=IBARRAY(351,IBCLDA_",",.06,"I")
+10 ;3rd QTR CHARGES
SET IB903=IBARRAY(351,IBCLDA_",",.07,"I")
+11 ;4th QTR CHARGES
SET IB904=IBARRAY(351,IBCLDA_",",.08,"I")
+12 ;Number of inpatient days
SET IBCLDAY=IBARRAY(351,IBCLDA_",",.09,"I")
+13 ;End date of the clock
SET IBCLNDT=IBARRAY(351,IBCLDA_",",.1,"I")
+14 ;convert HL7 date to FM
SET IBCLNDT=$$FMTHL7^XLFDT(IBCLNDT)
+15 QUIT
+16 ;
NEWREC ;Create a new entry in file 351
+1 LOCK +^IBE(351,0):$GET(DILOCKTM,5)
if '$TEST
QUIT
+2 NEW DIC,IBFDA,IEN,IENS,X,Y,IEN351,IBDUZ,IBDTUP,IBREASON,DIE,DA,DR
+3 SET DIC="^IBE(351,"
SET DIC(0)=""
+4 SET X=$PIECE(^IBE(351,$PIECE(^IBE(351,0),U,3),0),U,1)+1
+5 DO FILE^DICN
SET (IENS,IEN)=$PIECE(Y,U,1)
SET DA=$PIECE(Y,U,1)
SET IENS=IENS_","
+6 ;IBFDA(FILE#,"IENS",FIELD#)="VALUE"
+7 IF $GET(IBICNAL)'=""
SET DFN=$$GETDFN^MPIF001(IBICNAL)
+8 IF DFN=""
LOCK -^IBE(351,0)
QUIT
+9 SET IBFDA(351,IENS,.02)=DFN
+10 ;
+11 ;Need to do aggregation of incoming clock with local data on Query Responses (DSR)
+12 ;Has this data been aggregated with local data
IF $GET(IBAGG)=1
DO AGGR
+13 SET IBFDA(351,IENS,.03)=$GET(IBICLDT)
+14 ;loop through "current" clock xref
SET IEN351=0
FOR
SET IEN351=$ORDER(^IBE(351,"ACT",DFN,IEN351))
if IEN351=""
QUIT
Begin DoDot:1
+15 ;Quit if incoming clock is closed
if $GET(IBICLNDT)
QUIT
+16 IF $$GET1^DIQ(351,IEN351_",",.04,"I")=1
Begin DoDot:2
+17 SET DIE="^IBE(351,"
SET DA=IEN351
SET DR=".04///3;"
+18 SET IBDUZ=$GET(DUZ,.5)
SET DR=DR_";13///^S X=IBDUZ"
+19 SET IBDTUP=$$NOW^XLFDT
SET DR=DR_";14///^S X=IBDTUP"
SET DR=DR_";14///^S X=IBDTUP"
+20 IF $GET(IBCNT)
SET IBREASON=$SELECT($GET(IBSNDST)'="":"Billing Clock update from Sta #"_IBSNDST,1:"Billing Clock update from Query")
SET DR=DR_";15///^S X=IBREASON"
+21 IF '$GET(IBCNT)
SET IBREASON="Billing Clock update from Query"
+22 ;Use fileman to properly delete ACT x-ref
DO ^DIE
+23 KILL DIE,DA,DR
End DoDot:2
End DoDot:1
+24 SET IBFDA(351,IENS,.04)=$GET(IBISTAT)
+25 SET IBFDA(351,IENS,.05)=$GET(IBI901)
+26 SET IBFDA(351,IENS,.06)=$GET(IBI902)
+27 SET IBFDA(351,IENS,.07)=$GET(IBI903)
+28 SET IBFDA(351,IENS,.08)=$GET(IBI904)
+29 SET IBFDA(351,IENS,.09)=$GET(IBICLDAY)
+30 if $GET(IBICKDT)
SET IBFDA(351,IENS,.1)=IBICKDT
+31 SET IBFDA(351,IENS,15)=$SELECT($GET(IBSNDST)'="":"Billing Clock update from Sta #"_IBSNDST,1:"Billing Clock update from Query")
+32 SET IBFDA(351,IENS,11)=.5
+33 SET IBFDA(351,IENS,12)=$$NOW^XLFDT
+34 SET IBFDA(351,IENS,13)=.5
+35 SET IBFDA(351,IENS,14)=$$NOW^XLFDT
+36 ;Set query sent field for aggregated date stored
SET IBFDA(351,IENS,16)=1
+37 DO FILE^DIE(,"IBFDA","IBERR")
+38 LOCK -^IBE(351,0)
+39 QUIT
+40 ;
AGGR ;Data has been aggregated at DAS, but may not have taken into account local data
+1 ;
+2 NEW NODE,IBDA,NODE0,AGG,IBSTDT,IBFLG
+3 SET AGG=0
+4 ;1. If no active local clock quit
+5 ;2. If local active clock and the start dates are not the same, aggregate
+6 ;3. If local active clock and start dates are the same, and days inpatient are Less than query, aggregate
+7 ;4. If local active clock and start dates are the same, and days inpatient are greater than query, quit
+8 ;
+9 ;get local clock data (#351)
+10 SET NODE=$SELECT(IBICLNDT:-IBICLNDT_.9999,1:-DT_.9999)
+11 FOR
SET NODE=$ORDER(^IBE(351,"AIVDT",DFN,NODE))
if 'NODE
QUIT
if $GET(IBFLG)
QUIT
Begin DoDot:1
+12 SET IBDA=";"
FOR
SET IBDA=$ORDER(^IBE(351,"AIVDT",DFN,NODE,IBDA),-1)
if 'IBDA
QUIT
IF $PIECE(^IBE(351,IBDA,0),U,4)
IF $PIECE(^IBE(351,IBDA,0),U,4)<3
SET IBFLG=1
QUIT
End DoDot:1
+13 if '$GET(IBDA)
QUIT
+14 SET NODE0=^IBE(351,IBDA,0)
+15 if $PIECE(NODE0,"^",3)<IBICLDT
QUIT
+16 ;use earliest billing clock if local
SET IBSTDT=$PIECE(NODE0,"^",3)
+17 IF $PIECE(NODE0,"^",3)'=IBICLDT
SET AGG=1
+18 IF $PIECE(NODE0,"^",3)=IBICLDT
Begin DoDot:1
+19 IF $PIECE(NODE0,"^",9)<IBICLDAY
SET AGG=1
QUIT
End DoDot:1
+20 if 'AGG
QUIT
+21 ;D MULTCLK - For future Cerner work
IF $GET(IBICLNDT)<DT
+22 ;Aggregate the incoming clock and the active clock
+23 SET IBICLDAY=IBICLDAY+($PIECE(NODE0,"^",9))
+24 SET IBI901=IBI901+($PIECE(NODE0,"^",5))
+25 SET IBI902=IBI902+($PIECE(NODE0,"^",6))
+26 SET IBI903=IBI903+($PIECE(NODE0,"^",7))
+27 SET IBI904=IBI904+($PIECE(NODE0,"^",8))
+28 ;use earliest billing clock if local
IF IBSTDT<IBICLDT
SET IBICLDT=IBSTDT
+29 QUIT
+30 ;
MULTCLK ;Need to create multiple clocks - For future Cerner work
+1 ;If billing clock closed date < today
+2 ;use the PTF to determine billing days
+3 ;Q:'IBICLNDT
+4 ;N IBECDT,IBECDA,IBCLKST,IBCLKED,IBADMIT,IBADM1,IBIEN,IBDISCH
+5 ;S IBECDT="" F S IBECDT=$O(^IBE(351,"AIVDT",DFN,IBECDT)) Q:'IBECDT Q:(IBECDT>IBICLNDT) D
+6 ;.S IBECDA=";" F S IBECDA=$O(^IBE(351,"AIVDT",DFN,IBECDT,IBECDA),-1) Q:'IBECDA Q:$$GET1^DIQ(351,IBECDA_",",.04,"I")=3 D
+7 ;..S IBCLKST=$$GET1^DIQ(351,IBECDA_",",.03,"I"),IBCLKED=$$GET1^DIQ(351,IBECDA_",",.1,"I")
+8 ;..S IBDAY=$$FMDIFF^XLFDT($S(IBCLKED:IBCLKED,1:DT),IBCLKST)+1 S IBMTBC(DFN,IBCLKST)=IBCLKST_U_IBCLKED_U_IBDAY
+9 ;..I IBCLKST<IBICLNDT,(IBCLKST>IBICLDT) D
+10 ;...S IBADMIT=-IBECDT_".9999",IBADMIT=$O(^DGPT("AAD",DFN,IBADMIT),-1),IBADM1=IBADMIT I IBADMIT S IBIEN=$O(^DGPT("AAD",DFN,IBADMIT,0)),IBDISCH=$P($G(^DGPT(IBIEN,70)),U)
+11 ;...;I IBDISCH>IBICLNDT D CHCKDAYS - For future Cerner work
+12 ;Q
+13 ;
CHCKDAYS ;Check days for each clock - For future Cerner work
+1 ;N IBICLDT1
+2 ;S IBICLDT1=IBICLNDT-.0001 F S IBICLDT1=$O(^DGPT("AAD",DFN,IBICLDT1)) Q:'IBICLDT1 S IBIEN=$O(^DGPT("AAD",DFN,IBICLDT1,0)),IBADMIT=$P($G(^DGPT(IBIEN,0)),U,2),IBDISCH=$P($G(^DGPT(IBIEN,70)),U) D
+3 ;.S IBDAYS=$$FMDIFF^XLFDT($S(IBDISCH:IBDISCH,1:DT),IBADMIT)+1 S IBPTF(DFN,IBADMIT)=IBADMIT_U_IBDISCH_U_IBDAYS
+4 ;Q
+5 ;
UPDATE(IBDA) ;Update records when Billing Clock start date is the same
+1 NEW DIE,DA,IBDTUP,IBDUZ
+2 LOCK +^IBE(351,IBDA):$GET(DILOCKTM,5)
if '$TEST
QUIT
+3 SET DIE="^IBE(351,"
SET DA=IBDA
SET DR=".04///^S X=IBISTAT"
+4 SET DR=DR_";.05///"_+IBI901
+5 SET DR=DR_";.06///"_+IBI902
+6 SET DR=DR_";.07///"_+IBI903
+7 SET DR=DR_";.08///"_+IBI904
+8 SET DR=DR_";.09///"_+IBICLDAY
+9 if IBICKDT
SET DR=DR_";.1///^S X=IBICKDT"
+10 SET IBDUZ=$GET(DUZ,.5)
SET DR=DR_";13///^S X=IBDUZ"
+11 SET IBDTUP=$$NOW^XLFDT
SET DR=DR_";14///^S X=IBDTUP"
+12 SET IBREASON=$SELECT($GET(IBSNDST)'="":"Billing Clock update from Sta #"_IBSNDST,1:"Billing Clock update from Query")
SET DR=DR_";15///^S X=IBREASON"
+13 ;Set query sent field for aggregated date stored
SET DR=DR_";16///1"
+14 DO ^DIE
+15 LOCK -^IBE(351,DA)
+16 QUIT
