IBCNEDEP ;DAOU/ALA - Process Transaction Records ;14-OCT-2015
;;2.0;INTEGRATED BILLING;**184,271,300,416,438,506,533,549,601,621,713,737,778**;21-MAR-94;Build 28
;;Per VA Directive 6402, this routine should not be modified.
;
; This program finds records needing HL7 msg creation
; Periodically check for stop request for background task
;
; Variables
; RETR = # retries allowed
; RETRYFLG = determines if a Transmitted message can be resent
; MGRP = Msg Mailgroup
; FAIL = # of days before failure
; FMSG = Failure Mailman flag
; TMSG = Timeout Mailman flag
; FLDT = Failure date
; FUTDT = Future transmission date
; DFN = Patient IEN
; PAYR = Payer IEN
; DTCRT = Date Created
; BUFF = Buffer File IEN
; NRETR = # of retries accomplished
; IHCNT = Count of successful HL7 msgs
; QUERY = Type of msg
; EXT = Which extract produced record
; SRVDT = Service Date
; IRIEN = Insurance Record IEN
; NTRAN = # of transmissions accomplished
; OVRIDE = Override Flag
; BNDL = Bundle Verification Flag
;
EN ; Entry point
;
; Start processing of data
K ^TMP("HLS",$J),^TMP("IBQUERY",$J)
; Initialize count for periodic TaskMan check
;IB*533 RRA CREATE VARIABLES TO ACCOUNT FOR MAX SENT LIMITATIONS
N IBMAXCNT,IBSENT
S IBCNETOT=0,IBSENT=0
;
S C1CODE=$O(^IBE(365.15,"B","C1",""))
; Get IB Site Parameters
S IBCNEP=$G(^IBE(350.9,1,51))
S RETR=+$P(IBCNEP,U,6),BNDL=$P(IBCNEP,U,23)
S MGRP=$$MGRP^IBCNEUT5()
S FAIL=$P(IBCNEP,U,5),TMSG=$P(IBCNEP,U,7),FMSG=$P(IBCNEP,U,20)
S RETRYFLG=$P(IBCNEP,U,26) ;set value to (#350.9, 51.26) - IB*2.0*506
S IBMAXCNT=$P(IBCNEP,U,15) ;get HL7 MAXIMUM NUMBER - IB*533
S FLDT=$$FMADD^XLFDT(DT,-FAIL)
; Statuses
; 1 = Ready To Transmit
; 2 = Transmitted
; 4 = Hold
; 6 = Retry
;
; If the status is 'HOLD' is this a 'Retry'? - IB*2.0*506
; DO HLD ; this is not to be called unless the status of HOLD is reinstated...see HLD tag
; below and the code within ERROR^IBCNEHL3
;
; Exit based on stop request
I $G(ZTSTOP) G EXIT
;
TMT ; If the status is 'Transmitted' - is this a 'Retry' or
; 'Comm Failure'
S IEN=""
F S IEN=$O(^IBCN(365.1,"AC",2,IEN)) Q:IEN="" D Q:$G(ZTSTOP)
. ; Update count for periodic check
. S IBCNETOT=IBCNETOT+1
. ; Check for request to stop background job, periodically
. I $D(ZTQUEUED),IBCNETOT#100=0,$$S^%ZTLOAD() S ZTSTOP=1 Q
. ;
. NEW TDATA,DTCRT,BUFF,DFN,PAYR,XMSUB,VERID,EXT
. S TDATA=$G(^IBCN(365.1,IEN,0))
. S DFN=$P(TDATA,U,2),PAYR=$P(TDATA,U,3)
. S DTCRT=$P(TDATA,U,6)\1,BUFF=$P(TDATA,U,5)
. S VERID=$P(TDATA,U,11)
. S EXT=$P(TDATA,U,10)
. ;
. ; Check against the Failure Date
. I (VERID="I")&(EXT=4) Q:DT<$$FMADD^XLFDT(DTCRT+30) ; IB*2.0*621 ; HAN
. I (VERID'="I")&(EXT'=4)&(DTCRT>FLDT) Q
. ;
. ; If retries are defined
. I (VERID'="I"&(EXT'=4))&(RETRYFLG="Y") D Q ; IB*2.0*506 ; IB*2.0*621
.. ;
.. I '$$PYRACTV^IBCNEDE7(PAYR) Q ; If Payer is not Nationally Active skip record - IB*2.0*506
.. ;
.. D SST^IBCNEUT2(IEN,6) ; mark TQ entry status as 'retry'
.. Q
. ;
. D SST^IBCNEUT2(IEN,5) ; if RETRYFLG=NO set TQ record to 'communication failure'
. ;
. ; For msg in the Response file set the status to
. ; 'Comm Failure'
. D RSTA^IBCNEUT7(IEN)
. I (VERID="I")&(EXT=4) D
.. N IENS,RSUPDT,TRKIEN
.. S TRKIEN=$O(^IBCN(365.18,"B",IEN,"")),IENS=TRKIEN_","
.. S RSUPDT(365.18,IENS,.06)=$$GET1^DIQ(365.16,"1,"_IEN_",",.03) ;There is only one occurance for EICD Identification
.. S RSUPDT(365.18,IENS,.07)=0 ;Set status to "Error"
.. D FILE^DIE("","RSUPDT","ERROR")
. ;
. ; Set Buffer symbol to 'C1' (Comm Failure) ; used to be 'B12' - ien of 15
. I BUFF'="" D BUFF^IBCNEUT2(BUFF,C1CODE) ; set to "#" communication failure - IB*2.0*506
. ;
. ; Issue comm fail MailMan msg only for ver'ns
. I VERID="V" D CERR^IBCNEDEQ
;
; Exit for stop request
I $G(ZTSTOP) G EXIT
;
RET ; If status is 'Retry' ; retries only exist if the RETRYFLG=YES - IB*2.0*506
S IEN=""
F S IEN=$O(^IBCN(365.1,"AC",6,IEN)) Q:IEN="" D Q:$G(ZTSTOP)
. ; Update count for periodic check
. S IBCNETOT=IBCNETOT+1
. ; Check for request to stop background job, periodically
. I $D(ZTQUEUED),IBCNETOT#100=0,$$S^%ZTLOAD() S ZTSTOP=1 Q
. ;
. NEW TDATA,NRETR,PAYR,BUFF,DFN,MSG,RIEN,HIEN,XMSUB,VERID
. S TDATA=$G(^IBCN(365.1,IEN,0))
. S NRETR=$P(TDATA,U,8),PAYR=$P(TDATA,U,3)
. S BUFF=$P(TDATA,U,5),DFN=$P(TDATA,U,2)
. S VERID=$P(TDATA,U,11)
. S NRETR=NRETR+1
. ;
. ; If retries are finished, set to communication failure - IB*2.0*506
. I NRETR>RETR D Q
.. D SST^IBCNEUT2(IEN,5)
.. ;
.. ; Set Buffer symbol to 'C1' (Comm Failure) ; used to be 'B12' - ien of 15
.. I BUFF'="" D BUFF^IBCNEUT2(BUFF,C1CODE) ; set to "#" communication failure - IB*2.0*506
.. ;
.. ; For msg in the Response file set the status to
.. ; 'Comm Failure'
.. D RSTA^IBCNEUT7(IEN)
.. ;
.. ;I VERID="V" D CERE^IBCNEDEQ ; removed IB*2.0*506
. ; If generating retry, set eIV status to comm failure (5) for
. ; remaining related responses
. D RSTA^IBCNEUT7(IEN)
;
; Exit for stop request
I $G(ZTSTOP) G EXIT
;
FIN ; Prioritize requests for statuses 'Retry' and 'Ready to Transmit'
;
; Separate inquiries into verifications, identifications,
; and "fishes" - VNUM = Priority of output
F STA=1,6 S IEN="" D
. F S IEN=$O(^IBCN(365.1,"AC",STA,IEN)) Q:IEN="" D
.. S IBDATA=$G(^IBCN(365.1,IEN,0)) Q:IBDATA=""
.. S QUERY=$P(IBDATA,U,11),DFN=$P(IBDATA,U,2),OVRIDE=$P(IBDATA,U,14)
.. S PAYR=$P(IBDATA,U,3)
.. I QUERY="V" S VNUM=3
.. I QUERY'="V" D
... S VNUM=4
.. I OVRIDE'="" D
... S VNUM=1
.. S ^TMP("IBQUERY",$J,VNUM,DFN,IEN)="" ; VNUM = Priority of output
;
LP ; Loop through priorities, process as either verifications
; or identifications
;IB*713/DW add GOOGMSG variable to skip & cancel bad msgs (foreign chars)
N IHCNT,IBSTOP
S VNUM="",IHCNT=0 ; VNUM = Priority of output
F S VNUM=$O(^TMP("IBQUERY",$J,VNUM)) Q:VNUM="" D Q:$G(ZTSTOP)!$G(QFL)=1!($G(IBSTOP)=1)
. I VNUM=1!(VNUM=3) D VER Q
. D ID
;
EXIT ; Finish
K BUFF,CNT,D,D0,DA,DFN,DI,DIC,DIE,DISYS,DQ,DR,DTCRT,EICDVIEN,EXT,FAIL,FLDT,FUTDT
K FRDT,FMSG,GT1,HCT,HIEN,HL,HLCDOM,HLCINS,HLCS,HLCSTCP,HLDOM,HLECH,%I,%H
K HLEID,HLFS,HLHDR,HLINST,HLIP,HLN,HLPARAM,HLPROD,HLQ,HLRESLT,XMSUB
K HLSAN,HLTYPE,HLX,IBCNEP,IBCNHLP,IEN,IHCNT,IN1,IRIEN,MDTM,MGRP,MSGID,TOT
K NRETR,NTRAN,OVRIDE,PAYR,PID,QFL,QUERY,RETR,RETRYFLG,RSIEN,SRVDT,STA,TRANSR,X
K ZMID,^TMP("IBQUERY",$J),Y,DOD,DGREL,TMSG,RSTYPE,OMSGID,QFL
K IBCNETOT,HLP,SUBID,VNUM,BNDL,IBDATA,PATID,C1CODE
K GRPNUM,GRPNAM,TRANSR1 ;IB*778/CKB - clean up variables
Q
;
VER ; Initialize HL7 variables protocol for Verifications
S IBCNHLP="IBCNE IIV RQV OUT"
D INIT^IBCNEHLO
;
S DFN=""
; VNUM = Priority of output
F S DFN=$O(^TMP("IBQUERY",$J,VNUM,DFN)) Q:DFN="" D Q:$G(ZTSTOP)!($G(IBSTOP)=1)
. ;
. ; If the INQUIRE SECONDARY INSURANCES flag is 'yes',
. ; bundle verifications together, send a continuation pointer
. I VNUM=3,BNDL D Q:QFL
.. S TOT=0,IEN="",QFL=0
.. F S IEN=$O(^TMP("IBQUERY",$J,VNUM,DFN,IEN)) Q:IEN="" S TOT=TOT+1
. ;
. S IEN="",OMSGID="",QFL=0,CNT=0
. F S IEN=$O(^TMP("IBQUERY",$J,VNUM,DFN,IEN)) Q:IEN="" D Q:$G(ZTSTOP)!($G(IBSTOP)=1)
.. ;
.. ; IB*2.0*549 - quit if test site and not a valid test case
.. Q:'$$XMITOK^IBCNETST(IEN)
.. ; Update count for periodic check
.. S IBCNETOT=IBCNETOT+1
.. ; Check for request to stop background job, periodically
.. I $D(ZTQUEUED),IBCNETOT#100=0,$$S^%ZTLOAD() S ZTSTOP=1 Q
.. ;
.. ;IB*713/TAZ - Convert to function and quit if no HL7 message created
.. I '$$PROC Q
.. ;
.. I BNDL S HLP("CONTPTR")=$G(OMSGID)
.. D GENERATE^HLMA(IBCNHLP,"GM",1,.HLRESLT,"",.HLP)
.. K ^TMP("HLS",$J),HLP
.. ;
.. ; If not successful
.. I $P(HLRESLT,U,2)]"" D HLER^IBCNEDEQ Q
.. ; If successful
.. ; increment counter and quit if reached IBMAXCNT IB*533
.. S IBSENT=IBSENT+1
.. I IBMAXCNT'="",IBSENT+1>IBMAXCNT S IBSTOP=1
.. D SCC^IBCNEDEQ
.. I BNDL D
... I CNT=1 S OMSGID=MSGID
;
K HL,IN1,GT1,PID,DFN,^TMP($J,"HLS")
Q
;
ID ; Send Identification Msgs
;
; Initialize the HL7 variables based on the HL7 protocol
S IBCNHLP="IBCNE EIV RQP OUT"
D INIT^IBCNEHLO
;
S DFN=""
; VNUM = Priority of output
F S DFN=$O(^TMP("IBQUERY",$J,VNUM,DFN)) Q:DFN="" D Q:$G(ZTSTOP)!QFL
. ; Update count for periodic check
. S IBCNETOT=IBCNETOT+1
. ; Check for request to stop background job, periodically
. I $D(ZTQUEUED),IBCNETOT#100=0,$$S^%ZTLOAD() S ZTSTOP=1 Q
. ;
. S TOT=0,IEN="",CNT=0,OMSGID="",QFL=0
. ;
. ; Get the total # of identification msgs for a patient
. F S IEN=$O(^TMP("IBQUERY",$J,VNUM,DFN,IEN)) Q:IEN="" S TOT=TOT+1
. ;
. ; For each identification transaction generate an HL7 msg
. F S IEN=$O(^TMP("IBQUERY",$J,VNUM,DFN,IEN)) Q:IEN="" D
.. ;IB*2.0*621 - quit if test site and not a valid test case
.. Q:'$$XMITOK^IBCNETST(IEN)
.. ;
.. ;IB*713/TAZ - Convert to function call and quit if no HL7 message created
.. I '$$PROC Q
.. ;
.. ;I VNUM=4 S HLP("CONTPTR")=$G(OMSGID) ; IB*621 - HAN
.. D GENERATE^HLMA(IBCNHLP,"GM",1,.HLRESLT,"",.HLP)
.. K ^TMP("HLS",$J),HLP
.. ;
.. ; If not successful
.. I $P(HLRESLT,U,2)]"" D HLER^IBCNEDEQ Q
.. ;
.. ; If successful
.. D SCC^IBCNEDEQ
.. ; IB*621 - HAN Set DATE LAST EICD RUN
.. S DA=DFN,DIE="^DPT(",DR="2001///"_DT
.. D ^DIE
;
Q
;
XMIT1(IEN) ; Transmit one transaction at time. Currently only used for Appointment Extract.
; created tag with IB*778/TAZ
; Input: IEN - the Transaction Queue entry
;
; Note: IHCNT and VNUM are used for subsequent calls. It is not needed for this functionality.
;
N DFN,GT1,HL,IHCNT,IN1,PID,QUERYFLG,VNUM
K ^TMP("HLS",$J)
;
S IHCNT=0
;
I '$G(IEN) G XMIT1Q
S QUERYFLG=$$GET1^DIQ(365.1,IEN_",",.11,"I") ;I or V
;
; If not I or V set TQ entry to Communication Failure, then quit
I QUERYFLG="" D SST^IBCNEUT2(IEN,5) G XMIT1Q
;
; Set up outbound HL7 protocol
S IBCNHLP=$S(QUERYFLG="V":"IBCNE IIV RQV OUT",1:"IBCNE EIV RQP OUT")
D INIT^IBCNEHLO
;
; Quit if test site and not a valid test case
I '$$XMITOK^IBCNETST(IEN) G XMIT1Q
;
; Process TQ record and quit if errors
I '$$PROC G XMIT1Q
;
D GENERATE^HLMA(IBCNHLP,"GM",1,.HLRESLT,"",.HLP)
K ^TMP("HLS",$J),HLP
;
; If not successful
I $P(HLRESLT,U,2)]"" D HLER^IBCNEDEQ G XMIT1Q
;
; If successful
D SCC^IBCNEDEQ
;
; Update LAST EICD RUN for ID transactions
I QUERYFLG="I" D
. S DA=DFN,DIE="^DPT(",DR="2001///"_DT
. D ^DIE
;
XMIT1Q ;Exit
Q
;
;IB*713/TAZ - Convert to function call
PROC() ; Process TQ record
;Output:
; 1 - OK to create HL7 message
; 0 - Do not create hl7 message
;
S TRANSR=$G(^IBCN(365.1,IEN,0))
S DFN=$P(TRANSR,U,2),PAYR=$P(TRANSR,U,3),BUFF=$P(TRANSR,U,5)
S QUERY=$P(TRANSR,U,11),EXT=$P(TRANSR,U,10),SRVDT=$P(TRANSR,U,12)
S IRIEN=$P(TRANSR,U,13),HCT=0,NTRAN=$P(TRANSR,U,7),NRETR=$P(TRANSR,U,8)
S SUBID=$P(TRANSR,U,16),OVRIDE=$P(TRANSR,U,14),STA=$P(TRANSR,U,4)
S FRDT=$P(TRANSR,U,17),PATID=$P(TRANSR,U,19),EICDVIEN=$P(TRANSR,U,21)
;IB*778/CKB - added TRANSR1,GRPNUM,GRPNAM. GRPNUM,GRPNAM will be used to build HL7 msg
S TRANSR1=$G(^IBCN(365.1,IEN,1))
S GRPNUM=$P(TRANSR1,U,3),GRPNAM=$P(TRANSR1,U,4)
;
; Build the HL7 msg
S VNUM=$G(VNUM,1) ;Default is "1" if VNUM is "" ; IB*778/TAZ
S HCT=HCT+1,^TMP("HLS",$J,HCT)="PRD|NA"
D PID^IBCNEHLQ I PID=""!(PID?."*") Q
S HCT=HCT+1,^TMP("HLS",$J,HCT)=$TR(PID,"*","")
D GT1^IBCNEHLQ I GT1'="",GT1'?."*" S HCT=HCT+1,^TMP("HLS",$J,HCT)=$TR(GT1,"*","")
D IN1^IBCNEHLQ I IN1'="",IN1'?."*" D
. S HCT=HCT+1
. I VNUM=1 S ^TMP("HLS",$J,HCT)=$TR(IN1,"*","") Q ; VNUM = Priority of output
. I VNUM=2,'BNDL S ^TMP("HLS",$J,HCT)=$TR(IN1,"*","") Q
. S CNT=CNT+1 I TOT=0 S TOT=1
. S $P(IN1,HLFS,22)=TOT,$P(IN1,HLFS,21)=CNT
. S ^TMP("HLS",$J,HCT)=$TR(IN1,"*","")
;
;IB*713/TAZ - Check to see if we should continue building HL7 message
;NOTE: BADMSG Returns 1 if processing is to stop.
;
I $$BADMSG^IBCNEUT2(EXT,QUERY) D Q 0
. N STIEN
. D SST^IBCNEUT2(IEN,7) ; set TQ status to 'Cancelled'
. ;If BUFF is defined, set Buffer Symbol to B17 to force manual processing of entry.
. I $G(BUFF) D
. . S STIEN=$$FIND1^DIC(365.15,,"X","B17","B")
. . D BUFF^IBCNEUT2(BUFF,STIEN)
;
; Build multi-field NTE segment
D NTE^IBCNEHLQ(1)
; If build successful
I NTE'="",$E(NTE,1)'="*" S HCT=HCT+1,^TMP("HLS",$J,HCT)=$TR(NTE,"*","")
; IB*2.0*601 - Added NTE 2 & 3
D NTE^IBCNEHLQ(2)
; If build successful Second NTE segment
I NTE'="",$E(NTE,1)'="*" S HCT=HCT+1,^TMP("HLS",$J,HCT)=$TR(NTE,"*","")
D NTE^IBCNEHLQ(3)
; set the third NTE segment
I NTE'="",$E(NTE,1)'="*" S HCT=HCT+1,^TMP("HLS",$J,HCT)=$TR(NTE,"*","")
; IB*601 - End HAN
; IB*2.0*621
D NTE^IBCNEHLQ(4)
; set the fourth NTE segment
S HCT=HCT+1,^TMP("HLS",$J,HCT)=$TR(NTE,"*","")
D NTE^IBCNEHLQ(5)
; set the fifth NTE segment
S HCT=HCT+1,^TMP("HLS",$J,HCT)=$TR(NTE,"*","")
; IB*621 - End HAN
K NTE
Q 1
;
; The tag HLD was found at the top of this routine. It was moved
; to its own procedure because it isn't needed anymore at this time.
; Responses will not have the status of HOLD starting with patch IB*2.0*506.
; If HOLD is reinstated, then the logic below must be rewritten for the
; appropriate retry logic at that time.
HLD ; Go through the 'Hold' statuses, see if ready to be 'retried'
Q ; Quit added as safety valve
;S IEN=""
;F S IEN=$O(^IBCN(365.1,"AC",4,IEN)) Q:IEN="" D Q:$G(ZTSTOP)
;. ; Update count for periodic check
;. S IBCNETOT=IBCNETOT+1
;. ; Check for request to stop background job, periodically
;. I $D(ZTQUEUED),IBCNETOT#100=0,$$S^%ZTLOAD() S ZTSTOP=1 Q
;. ;
;. S FUTDT=$P($G(^IBCN(365.1,IEN,0)),U,9)
;. ;
;. ; If the future date is today, set status to 'Retry',
;. ; DON'T clear future transmission date. (Need date to see if this is the first
;. ; time that the payer asked us to resubmit this inquiry.)
;. I FUTDT'>DT D SST^IBCNEUT2(IEN,6) ;D
;. ;. NEW DA,DIE,DR
;. ;. S DA=IEN,DIE="^IBCN(365.1,",DR=".09///@" D ^DIE
;.. ;
;.. D SST^IBCNEUT2(IEN,6) ; set TQ status to 'retry'
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNEDEP 14498 printed Sep 23, 2025@19:50:45 Page 2
IBCNEDEP ;DAOU/ALA - Process Transaction Records ;14-OCT-2015
+1 ;;2.0;INTEGRATED BILLING;**184,271,300,416,438,506,533,549,601,621,713,737,778**;21-MAR-94;Build 28
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; This program finds records needing HL7 msg creation
+5 ; Periodically check for stop request for background task
+6 ;
+7 ; Variables
+8 ; RETR = # retries allowed
+9 ; RETRYFLG = determines if a Transmitted message can be resent
+10 ; MGRP = Msg Mailgroup
+11 ; FAIL = # of days before failure
+12 ; FMSG = Failure Mailman flag
+13 ; TMSG = Timeout Mailman flag
+14 ; FLDT = Failure date
+15 ; FUTDT = Future transmission date
+16 ; DFN = Patient IEN
+17 ; PAYR = Payer IEN
+18 ; DTCRT = Date Created
+19 ; BUFF = Buffer File IEN
+20 ; NRETR = # of retries accomplished
+21 ; IHCNT = Count of successful HL7 msgs
+22 ; QUERY = Type of msg
+23 ; EXT = Which extract produced record
+24 ; SRVDT = Service Date
+25 ; IRIEN = Insurance Record IEN
+26 ; NTRAN = # of transmissions accomplished
+27 ; OVRIDE = Override Flag
+28 ; BNDL = Bundle Verification Flag
+29 ;
EN ; Entry point
+1 ;
+2 ; Start processing of data
+3 KILL ^TMP("HLS",$JOB),^TMP("IBQUERY",$JOB)
+4 ; Initialize count for periodic TaskMan check
+5 ;IB*533 RRA CREATE VARIABLES TO ACCOUNT FOR MAX SENT LIMITATIONS
+6 NEW IBMAXCNT,IBSENT
+7 SET IBCNETOT=0
SET IBSENT=0
+8 ;
+9 SET C1CODE=$ORDER(^IBE(365.15,"B","C1",""))
+10 ; Get IB Site Parameters
+11 SET IBCNEP=$GET(^IBE(350.9,1,51))
+12 SET RETR=+$PIECE(IBCNEP,U,6)
SET BNDL=$PIECE(IBCNEP,U,23)
+13 SET MGRP=$$MGRP^IBCNEUT5()
+14 SET FAIL=$PIECE(IBCNEP,U,5)
SET TMSG=$PIECE(IBCNEP,U,7)
SET FMSG=$PIECE(IBCNEP,U,20)
+15 ;set value to (#350.9, 51.26) - IB*2.0*506
SET RETRYFLG=$PIECE(IBCNEP,U,26)
+16 ;get HL7 MAXIMUM NUMBER - IB*533
SET IBMAXCNT=$PIECE(IBCNEP,U,15)
+17 SET FLDT=$$FMADD^XLFDT(DT,-FAIL)
+18 ; Statuses
+19 ; 1 = Ready To Transmit
+20 ; 2 = Transmitted
+21 ; 4 = Hold
+22 ; 6 = Retry
+23 ;
+24 ; If the status is 'HOLD' is this a 'Retry'? - IB*2.0*506
+25 ; DO HLD ; this is not to be called unless the status of HOLD is reinstated...see HLD tag
+26 ; below and the code within ERROR^IBCNEHL3
+27 ;
+28 ; Exit based on stop request
+29 IF $GET(ZTSTOP)
GOTO EXIT
+30 ;
TMT ; If the status is 'Transmitted' - is this a 'Retry' or
+1 ; 'Comm Failure'
+2 SET IEN=""
+3 FOR
SET IEN=$ORDER(^IBCN(365.1,"AC",2,IEN))
if IEN=""
QUIT
Begin DoDot:1
+4 ; Update count for periodic check
+5 SET IBCNETOT=IBCNETOT+1
+6 ; Check for request to stop background job, periodically
+7 IF $DATA(ZTQUEUED)
IF IBCNETOT#100=0
IF $$S^%ZTLOAD()
SET ZTSTOP=1
QUIT
+8 ;
+9 NEW TDATA,DTCRT,BUFF,DFN,PAYR,XMSUB,VERID,EXT
+10 SET TDATA=$GET(^IBCN(365.1,IEN,0))
+11 SET DFN=$PIECE(TDATA,U,2)
SET PAYR=$PIECE(TDATA,U,3)
+12 SET DTCRT=$PIECE(TDATA,U,6)\1
SET BUFF=$PIECE(TDATA,U,5)
+13 SET VERID=$PIECE(TDATA,U,11)
+14 SET EXT=$PIECE(TDATA,U,10)
+15 ;
+16 ; Check against the Failure Date
+17 ; IB*2.0*621 ; HAN
IF (VERID="I")&(EXT=4)
if DT<$$FMADD^XLFDT(DTCRT+30)
QUIT
+18 IF (VERID'="I")&(EXT'=4)&(DTCRT>FLDT)
QUIT
+19 ;
+20 ; If retries are defined
+21 ; IB*2.0*506 ; IB*2.0*621
IF (VERID'="I"&(EXT'=4))&(RETRYFLG="Y")
Begin DoDot:2
+22 ;
+23 ; If Payer is not Nationally Active skip record - IB*2.0*506
IF '$$PYRACTV^IBCNEDE7(PAYR)
QUIT
+24 ;
+25 ; mark TQ entry status as 'retry'
DO SST^IBCNEUT2(IEN,6)
+26 QUIT
End DoDot:2
QUIT
+27 ;
+28 ; if RETRYFLG=NO set TQ record to 'communication failure'
DO SST^IBCNEUT2(IEN,5)
+29 ;
+30 ; For msg in the Response file set the status to
+31 ; 'Comm Failure'
+32 DO RSTA^IBCNEUT7(IEN)
+33 IF (VERID="I")&(EXT=4)
Begin DoDot:2
+34 NEW IENS,RSUPDT,TRKIEN
+35 SET TRKIEN=$ORDER(^IBCN(365.18,"B",IEN,""))
SET IENS=TRKIEN_","
+36 ;There is only one occurance for EICD Identification
SET RSUPDT(365.18,IENS,.06)=$$GET1^DIQ(365.16,"1,"_IEN_",",.03)
+37 ;Set status to "Error"
SET RSUPDT(365.18,IENS,.07)=0
+38 DO FILE^DIE("","RSUPDT","ERROR")
End DoDot:2
+39 ;
+40 ; Set Buffer symbol to 'C1' (Comm Failure) ; used to be 'B12' - ien of 15
+41 ; set to "#" communication failure - IB*2.0*506
IF BUFF'=""
DO BUFF^IBCNEUT2(BUFF,C1CODE)
+42 ;
+43 ; Issue comm fail MailMan msg only for ver'ns
+44 IF VERID="V"
DO CERR^IBCNEDEQ
End DoDot:1
if $GET(ZTSTOP)
QUIT
+45 ;
+46 ; Exit for stop request
+47 IF $GET(ZTSTOP)
GOTO EXIT
+48 ;
RET ; If status is 'Retry' ; retries only exist if the RETRYFLG=YES - IB*2.0*506
+1 SET IEN=""
+2 FOR
SET IEN=$ORDER(^IBCN(365.1,"AC",6,IEN))
if IEN=""
QUIT
Begin DoDot:1
+3 ; Update count for periodic check
+4 SET IBCNETOT=IBCNETOT+1
+5 ; Check for request to stop background job, periodically
+6 IF $DATA(ZTQUEUED)
IF IBCNETOT#100=0
IF $$S^%ZTLOAD()
SET ZTSTOP=1
QUIT
+7 ;
+8 NEW TDATA,NRETR,PAYR,BUFF,DFN,MSG,RIEN,HIEN,XMSUB,VERID
+9 SET TDATA=$GET(^IBCN(365.1,IEN,0))
+10 SET NRETR=$PIECE(TDATA,U,8)
SET PAYR=$PIECE(TDATA,U,3)
+11 SET BUFF=$PIECE(TDATA,U,5)
SET DFN=$PIECE(TDATA,U,2)
+12 SET VERID=$PIECE(TDATA,U,11)
+13 SET NRETR=NRETR+1
+14 ;
+15 ; If retries are finished, set to communication failure - IB*2.0*506
+16 IF NRETR>RETR
Begin DoDot:2
+17 DO SST^IBCNEUT2(IEN,5)
+18 ;
+19 ; Set Buffer symbol to 'C1' (Comm Failure) ; used to be 'B12' - ien of 15
+20 ; set to "#" communication failure - IB*2.0*506
IF BUFF'=""
DO BUFF^IBCNEUT2(BUFF,C1CODE)
+21 ;
+22 ; For msg in the Response file set the status to
+23 ; 'Comm Failure'
+24 DO RSTA^IBCNEUT7(IEN)
+25 ;
+26 ;I VERID="V" D CERE^IBCNEDEQ ; removed IB*2.0*506
End DoDot:2
QUIT
+27 ; If generating retry, set eIV status to comm failure (5) for
+28 ; remaining related responses
+29 DO RSTA^IBCNEUT7(IEN)
End DoDot:1
if $GET(ZTSTOP)
QUIT
+30 ;
+31 ; Exit for stop request
+32 IF $GET(ZTSTOP)
GOTO EXIT
+33 ;
FIN ; Prioritize requests for statuses 'Retry' and 'Ready to Transmit'
+1 ;
+2 ; Separate inquiries into verifications, identifications,
+3 ; and "fishes" - VNUM = Priority of output
+4 FOR STA=1,6
SET IEN=""
Begin DoDot:1
+5 FOR
SET IEN=$ORDER(^IBCN(365.1,"AC",STA,IEN))
if IEN=""
QUIT
Begin DoDot:2
+6 SET IBDATA=$GET(^IBCN(365.1,IEN,0))
if IBDATA=""
QUIT
+7 SET QUERY=$PIECE(IBDATA,U,11)
SET DFN=$PIECE(IBDATA,U,2)
SET OVRIDE=$PIECE(IBDATA,U,14)
+8 SET PAYR=$PIECE(IBDATA,U,3)
+9 IF QUERY="V"
SET VNUM=3
+10 IF QUERY'="V"
Begin DoDot:3
+11 SET VNUM=4
End DoDot:3
+12 IF OVRIDE'=""
Begin DoDot:3
+13 SET VNUM=1
End DoDot:3
+14 ; VNUM = Priority of output
SET ^TMP("IBQUERY",$JOB,VNUM,DFN,IEN)=""
End DoDot:2
End DoDot:1
+15 ;
LP ; Loop through priorities, process as either verifications
+1 ; or identifications
+2 ;IB*713/DW add GOOGMSG variable to skip & cancel bad msgs (foreign chars)
+3 NEW IHCNT,IBSTOP
+4 ; VNUM = Priority of output
SET VNUM=""
SET IHCNT=0
+5 FOR
SET VNUM=$ORDER(^TMP("IBQUERY",$JOB,VNUM))
if VNUM=""
QUIT
Begin DoDot:1
+6 IF VNUM=1!(VNUM=3)
DO VER
QUIT
+7 DO ID
End DoDot:1
if $GET(ZTSTOP)!$GET(QFL)=1!($GET(IBSTOP)=1)
QUIT
+8 ;
EXIT ; Finish
+1 KILL BUFF,CNT,D,D0,DA,DFN,DI,DIC,DIE,DISYS,DQ,DR,DTCRT,EICDVIEN,EXT,FAIL,FLDT,FUTDT
+2 KILL FRDT,FMSG,GT1,HCT,HIEN,HL,HLCDOM,HLCINS,HLCS,HLCSTCP,HLDOM,HLECH,%I,%H
+3 KILL HLEID,HLFS,HLHDR,HLINST,HLIP,HLN,HLPARAM,HLPROD,HLQ,HLRESLT,XMSUB
+4 KILL HLSAN,HLTYPE,HLX,IBCNEP,IBCNHLP,IEN,IHCNT,IN1,IRIEN,MDTM,MGRP,MSGID,TOT
+5 KILL NRETR,NTRAN,OVRIDE,PAYR,PID,QFL,QUERY,RETR,RETRYFLG,RSIEN,SRVDT,STA,TRANSR,X
+6 KILL ZMID,^TMP("IBQUERY",$JOB),Y,DOD,DGREL,TMSG,RSTYPE,OMSGID,QFL
+7 KILL IBCNETOT,HLP,SUBID,VNUM,BNDL,IBDATA,PATID,C1CODE
+8 ;IB*778/CKB - clean up variables
KILL GRPNUM,GRPNAM,TRANSR1
+9 QUIT
+10 ;
VER ; Initialize HL7 variables protocol for Verifications
+1 SET IBCNHLP="IBCNE IIV RQV OUT"
+2 DO INIT^IBCNEHLO
+3 ;
+4 SET DFN=""
+5 ; VNUM = Priority of output
+6 FOR
SET DFN=$ORDER(^TMP("IBQUERY",$JOB,VNUM,DFN))
if DFN=""
QUIT
Begin DoDot:1
+7 ;
+8 ; If the INQUIRE SECONDARY INSURANCES flag is 'yes',
+9 ; bundle verifications together, send a continuation pointer
+10 IF VNUM=3
IF BNDL
Begin DoDot:2
+11 SET TOT=0
SET IEN=""
SET QFL=0
+12 FOR
SET IEN=$ORDER(^TMP("IBQUERY",$JOB,VNUM,DFN,IEN))
if IEN=""
QUIT
SET TOT=TOT+1
End DoDot:2
if QFL
QUIT
+13 ;
+14 SET IEN=""
SET OMSGID=""
SET QFL=0
SET CNT=0
+15 FOR
SET IEN=$ORDER(^TMP("IBQUERY",$JOB,VNUM,DFN,IEN))
if IEN=""
QUIT
Begin DoDot:2
+16 ;
+17 ; IB*2.0*549 - quit if test site and not a valid test case
+18 if '$$XMITOK^IBCNETST(IEN)
QUIT
+19 ; Update count for periodic check
+20 SET IBCNETOT=IBCNETOT+1
+21 ; Check for request to stop background job, periodically
+22 IF $DATA(ZTQUEUED)
IF IBCNETOT#100=0
IF $$S^%ZTLOAD()
SET ZTSTOP=1
QUIT
+23 ;
+24 ;IB*713/TAZ - Convert to function and quit if no HL7 message created
+25 IF '$$PROC
QUIT
+26 ;
+27 IF BNDL
SET HLP("CONTPTR")=$GET(OMSGID)
+28 DO GENERATE^HLMA(IBCNHLP,"GM",1,.HLRESLT,"",.HLP)
+29 KILL ^TMP("HLS",$JOB),HLP
+30 ;
+31 ; If not successful
+32 IF $PIECE(HLRESLT,U,2)]""
DO HLER^IBCNEDEQ
QUIT
+33 ; If successful
+34 ; increment counter and quit if reached IBMAXCNT IB*533
+35 SET IBSENT=IBSENT+1
+36 IF IBMAXCNT'=""
IF IBSENT+1>IBMAXCNT
SET IBSTOP=1
+37 DO SCC^IBCNEDEQ
+38 IF BNDL
Begin DoDot:3
+39 IF CNT=1
SET OMSGID=MSGID
End DoDot:3
End DoDot:2
if $GET(ZTSTOP)!($GET(IBSTOP)=1)
QUIT
End DoDot:1
if $GET(ZTSTOP)!($GET(IBSTOP)=1)
QUIT
+40 ;
+41 KILL HL,IN1,GT1,PID,DFN,^TMP($JOB,"HLS")
+42 QUIT
+43 ;
ID ; Send Identification Msgs
+1 ;
+2 ; Initialize the HL7 variables based on the HL7 protocol
+3 SET IBCNHLP="IBCNE EIV RQP OUT"
+4 DO INIT^IBCNEHLO
+5 ;
+6 SET DFN=""
+7 ; VNUM = Priority of output
+8 FOR
SET DFN=$ORDER(^TMP("IBQUERY",$JOB,VNUM,DFN))
if DFN=""
QUIT
Begin DoDot:1
+9 ; Update count for periodic check
+10 SET IBCNETOT=IBCNETOT+1
+11 ; Check for request to stop background job, periodically
+12 IF $DATA(ZTQUEUED)
IF IBCNETOT#100=0
IF $$S^%ZTLOAD()
SET ZTSTOP=1
QUIT
+13 ;
+14 SET TOT=0
SET IEN=""
SET CNT=0
SET OMSGID=""
SET QFL=0
+15 ;
+16 ; Get the total # of identification msgs for a patient
+17 FOR
SET IEN=$ORDER(^TMP("IBQUERY",$JOB,VNUM,DFN,IEN))
if IEN=""
QUIT
SET TOT=TOT+1
+18 ;
+19 ; For each identification transaction generate an HL7 msg
+20 FOR
SET IEN=$ORDER(^TMP("IBQUERY",$JOB,VNUM,DFN,IEN))
if IEN=""
QUIT
Begin DoDot:2
+21 ;IB*2.0*621 - quit if test site and not a valid test case
+22 if '$$XMITOK^IBCNETST(IEN)
QUIT
+23 ;
+24 ;IB*713/TAZ - Convert to function call and quit if no HL7 message created
+25 IF '$$PROC
QUIT
+26 ;
+27 ;I VNUM=4 S HLP("CONTPTR")=$G(OMSGID) ; IB*621 - HAN
+28 DO GENERATE^HLMA(IBCNHLP,"GM",1,.HLRESLT,"",.HLP)
+29 KILL ^TMP("HLS",$JOB),HLP
+30 ;
+31 ; If not successful
+32 IF $PIECE(HLRESLT,U,2)]""
DO HLER^IBCNEDEQ
QUIT
+33 ;
+34 ; If successful
+35 DO SCC^IBCNEDEQ
+36 ; IB*621 - HAN Set DATE LAST EICD RUN
+37 SET DA=DFN
SET DIE="^DPT("
SET DR="2001///"_DT
+38 DO ^DIE
End DoDot:2
End DoDot:1
if $GET(ZTSTOP)!QFL
QUIT
+39 ;
+40 QUIT
+41 ;
XMIT1(IEN) ; Transmit one transaction at time. Currently only used for Appointment Extract.
+1 ; created tag with IB*778/TAZ
+2 ; Input: IEN - the Transaction Queue entry
+3 ;
+4 ; Note: IHCNT and VNUM are used for subsequent calls. It is not needed for this functionality.
+5 ;
+6 NEW DFN,GT1,HL,IHCNT,IN1,PID,QUERYFLG,VNUM
+7 KILL ^TMP("HLS",$JOB)
+8 ;
+9 SET IHCNT=0
+10 ;
+11 IF '$GET(IEN)
GOTO XMIT1Q
+12 ;I or V
SET QUERYFLG=$$GET1^DIQ(365.1,IEN_",",.11,"I")
+13 ;
+14 ; If not I or V set TQ entry to Communication Failure, then quit
+15 IF QUERYFLG=""
DO SST^IBCNEUT2(IEN,5)
GOTO XMIT1Q
+16 ;
+17 ; Set up outbound HL7 protocol
+18 SET IBCNHLP=$SELECT(QUERYFLG="V":"IBCNE IIV RQV OUT",1:"IBCNE EIV RQP OUT")
+19 DO INIT^IBCNEHLO
+20 ;
+21 ; Quit if test site and not a valid test case
+22 IF '$$XMITOK^IBCNETST(IEN)
GOTO XMIT1Q
+23 ;
+24 ; Process TQ record and quit if errors
+25 IF '$$PROC
GOTO XMIT1Q
+26 ;
+27 DO GENERATE^HLMA(IBCNHLP,"GM",1,.HLRESLT,"",.HLP)
+28 KILL ^TMP("HLS",$JOB),HLP
+29 ;
+30 ; If not successful
+31 IF $PIECE(HLRESLT,U,2)]""
DO HLER^IBCNEDEQ
GOTO XMIT1Q
+32 ;
+33 ; If successful
+34 DO SCC^IBCNEDEQ
+35 ;
+36 ; Update LAST EICD RUN for ID transactions
+37 IF QUERYFLG="I"
Begin DoDot:1
+38 SET DA=DFN
SET DIE="^DPT("
SET DR="2001///"_DT
+39 DO ^DIE
End DoDot:1
+40 ;
XMIT1Q ;Exit
+1 QUIT
+2 ;
+3 ;IB*713/TAZ - Convert to function call
PROC() ; Process TQ record
+1 ;Output:
+2 ; 1 - OK to create HL7 message
+3 ; 0 - Do not create hl7 message
+4 ;
+5 SET TRANSR=$GET(^IBCN(365.1,IEN,0))
+6 SET DFN=$PIECE(TRANSR,U,2)
SET PAYR=$PIECE(TRANSR,U,3)
SET BUFF=$PIECE(TRANSR,U,5)
+7 SET QUERY=$PIECE(TRANSR,U,11)
SET EXT=$PIECE(TRANSR,U,10)
SET SRVDT=$PIECE(TRANSR,U,12)
+8 SET IRIEN=$PIECE(TRANSR,U,13)
SET HCT=0
SET NTRAN=$PIECE(TRANSR,U,7)
SET NRETR=$PIECE(TRANSR,U,8)
+9 SET SUBID=$PIECE(TRANSR,U,16)
SET OVRIDE=$PIECE(TRANSR,U,14)
SET STA=$PIECE(TRANSR,U,4)
+10 SET FRDT=$PIECE(TRANSR,U,17)
SET PATID=$PIECE(TRANSR,U,19)
SET EICDVIEN=$PIECE(TRANSR,U,21)
+11 ;IB*778/CKB - added TRANSR1,GRPNUM,GRPNAM. GRPNUM,GRPNAM will be used to build HL7 msg
+12 SET TRANSR1=$GET(^IBCN(365.1,IEN,1))
+13 SET GRPNUM=$PIECE(TRANSR1,U,3)
SET GRPNAM=$PIECE(TRANSR1,U,4)
+14 ;
+15 ; Build the HL7 msg
+16 ;Default is "1" if VNUM is "" ; IB*778/TAZ
SET VNUM=$GET(VNUM,1)
+17 SET HCT=HCT+1
SET ^TMP("HLS",$JOB,HCT)="PRD|NA"
+18 DO PID^IBCNEHLQ
IF PID=""!(PID?."*")
QUIT
+19 SET HCT=HCT+1
SET ^TMP("HLS",$JOB,HCT)=$TRANSLATE(PID,"*","")
+20 DO GT1^IBCNEHLQ
IF GT1'=""
IF GT1'?."*"
SET HCT=HCT+1
SET ^TMP("HLS",$JOB,HCT)=$TRANSLATE(GT1,"*","")
+21 DO IN1^IBCNEHLQ
IF IN1'=""
IF IN1'?."*"
Begin DoDot:1
+22 SET HCT=HCT+1
+23 ; VNUM = Priority of output
IF VNUM=1
SET ^TMP("HLS",$JOB,HCT)=$TRANSLATE(IN1,"*","")
QUIT
+24 IF VNUM=2
IF 'BNDL
SET ^TMP("HLS",$JOB,HCT)=$TRANSLATE(IN1,"*","")
QUIT
+25 SET CNT=CNT+1
IF TOT=0
SET TOT=1
+26 SET $PIECE(IN1,HLFS,22)=TOT
SET $PIECE(IN1,HLFS,21)=CNT
+27 SET ^TMP("HLS",$JOB,HCT)=$TRANSLATE(IN1,"*","")
End DoDot:1
+28 ;
+29 ;IB*713/TAZ - Check to see if we should continue building HL7 message
+30 ;NOTE: BADMSG Returns 1 if processing is to stop.
+31 ;
+32 IF $$BADMSG^IBCNEUT2(EXT,QUERY)
Begin DoDot:1
+33 NEW STIEN
+34 ; set TQ status to 'Cancelled'
DO SST^IBCNEUT2(IEN,7)
+35 ;If BUFF is defined, set Buffer Symbol to B17 to force manual processing of entry.
+36 IF $GET(BUFF)
Begin DoDot:2
+37 SET STIEN=$$FIND1^DIC(365.15,,"X","B17","B")
+38 DO BUFF^IBCNEUT2(BUFF,STIEN)
End DoDot:2
End DoDot:1
QUIT 0
+39 ;
+40 ; Build multi-field NTE segment
+41 DO NTE^IBCNEHLQ(1)
+42 ; If build successful
+43 IF NTE'=""
IF $EXTRACT(NTE,1)'="*"
SET HCT=HCT+1
SET ^TMP("HLS",$JOB,HCT)=$TRANSLATE(NTE,"*","")
+44 ; IB*2.0*601 - Added NTE 2 & 3
+45 DO NTE^IBCNEHLQ(2)
+46 ; If build successful Second NTE segment
+47 IF NTE'=""
IF $EXTRACT(NTE,1)'="*"
SET HCT=HCT+1
SET ^TMP("HLS",$JOB,HCT)=$TRANSLATE(NTE,"*","")
+48 DO NTE^IBCNEHLQ(3)
+49 ; set the third NTE segment
+50 IF NTE'=""
IF $EXTRACT(NTE,1)'="*"
SET HCT=HCT+1
SET ^TMP("HLS",$JOB,HCT)=$TRANSLATE(NTE,"*","")
+51 ; IB*601 - End HAN
+52 ; IB*2.0*621
+53 DO NTE^IBCNEHLQ(4)
+54 ; set the fourth NTE segment
+55 SET HCT=HCT+1
SET ^TMP("HLS",$JOB,HCT)=$TRANSLATE(NTE,"*","")
+56 DO NTE^IBCNEHLQ(5)
+57 ; set the fifth NTE segment
+58 SET HCT=HCT+1
SET ^TMP("HLS",$JOB,HCT)=$TRANSLATE(NTE,"*","")
+59 ; IB*621 - End HAN
+60 KILL NTE
+61 QUIT 1
+62 ;
+63 ; The tag HLD was found at the top of this routine. It was moved
+64 ; to its own procedure because it isn't needed anymore at this time.
+65 ; Responses will not have the status of HOLD starting with patch IB*2.0*506.
+66 ; If HOLD is reinstated, then the logic below must be rewritten for the
+67 ; appropriate retry logic at that time.
HLD ; Go through the 'Hold' statuses, see if ready to be 'retried'
+1 ; Quit added as safety valve
QUIT
+2 ;S IEN=""
+3 ;F S IEN=$O(^IBCN(365.1,"AC",4,IEN)) Q:IEN="" D Q:$G(ZTSTOP)
+4 ;. ; Update count for periodic check
+5 ;. S IBCNETOT=IBCNETOT+1
+6 ;. ; Check for request to stop background job, periodically
+7 ;. I $D(ZTQUEUED),IBCNETOT#100=0,$$S^%ZTLOAD() S ZTSTOP=1 Q
+8 ;. ;
+9 ;. S FUTDT=$P($G(^IBCN(365.1,IEN,0)),U,9)
+10 ;. ;
+11 ;. ; If the future date is today, set status to 'Retry',
+12 ;. ; DON'T clear future transmission date. (Need date to see if this is the first
+13 ;. ; time that the payer asked us to resubmit this inquiry.)
+14 ;. I FUTDT'>DT D SST^IBCNEUT2(IEN,6) ;D
+15 ;. ;. NEW DA,DIE,DR
+16 ;. ;. S DA=IEN,DIE="^IBCN(365.1,",DR=".09///@" D ^DIE
+17 ;.. ;
+18 ;.. D SST^IBCNEUT2(IEN,6) ; set TQ status to 'retry'
+19 QUIT
