IBCNERTQ ;ALB/BI - Real-time Insurance Verification ;15-OCT-2015
;;2.0;INTEGRATED BILLING;**438,467,497,549,582,593,601,631,659,664,668,713**;21-MAR-94;Build 12
;;Per VA Directive 6402, this routine should not be modified.
Q
;
TRIG(N2) ; Called by triggers in the INSURANCE BUFFER FILE Dictionary (355.33)
; Fields: 20.01 - INSURANCE COMPANY NAME
; 90.01 - GROUP NAME
; 90.02 - GROUP NUMBER
; 60.01 - PATIENT NAME
; 90.03 - SUBSCRIBER ID
; 60.08 - INSURED'S DOB
; 62.01 - PATIENT ID
;
; To make a request for Real Time Verification
; The following fields must contain data.
; 20.01 - INSURANCE COMPANY NAME
; 60.01 - PATIENT NAME
; 90.03 - SUBSCRIBER ID (if patient is the subscriber)
; 60.08 - INSURED'S DOB (if patient is not the subscriber)
; 62.01 - PATIENT ID (if patient is not the subscriber)
;
;
N TQIEN,TQN0,NODE20,NODE60,NODE90,QF,N4,PTID,SUBID,MGRP,DFN,PREL
N RESPONSE S RESPONSE=0
; Protect the FileMan variables.
N DA,DB,DC,DH,DI,DK,DL,DM,DP,DQ,DR,INI,MR,NX,UP
;
I N2="" Q RESPONSE
;IB*582/HAN - Do not allow entries to process if the user is INTERFACE,IB EIV
N EIVDUZ S EIVDUZ=$$FIND1^DIC(200,"","X","INTERFACE,IB EIV")
;IB*2.0*593/HN - Added to allow nightly extract entries to go out immediately.
I $G(IDUZ)'="",IDUZ=EIVDUZ,$G(CALLEDBY)'="",CALLEDBY="IBCNEHL1" Q RESPONSE
;IB*582 - End
S MGRP=$$MGRP^IBCNEUT5()
S NODE20=$G(^IBA(355.33,N2,20))
S NODE60=$G(^IBA(355.33,N2,60))
S NODE90=$G(^IBA(355.33,N2,90))
S PREL=$P(NODE60,U,14)
I $P(NODE20,U,1)="" Q RESPONSE ;INSURANCE COMPANY NAME
I $P(NODE60,U,1)="" Q RESPONSE ;PATIENT NAME
I $P(NODE90,U,3)="" Q RESPONSE ;SUBSCRIBER ID
; exclude dependent inquiries w/o patient id or DOB
I PREL'=18,PREL'="",($P($G(^IBA(355.33,N2,62)),U)=""!($P(NODE60,U,8)="")) Q RESPONSE
; exclude ePharmacy buffer entries
I $G(IBNCPDPELIG) Q RESPONSE ; variable set in ^IBNCPDP3
I $P($G(^IBA(355.33,N2,0)),U,17)'="" Q RESPONSE
;
; ** Prevent creating inquiries based on Source of Information (SOI) **
N PTR S PTR=+$P($G(^IBA(355.33,N2,0)),U,3)
I PTR,$P($G(^IBE(355.12,PTR,0)),U,2)="HMS",PREL="" Q RESPONSE
I PTR,$$GET1^DIQ(355.12,PTR_",",.03)="EHR" Q RESPONSE ;/vd-IB*2*664
I PTR,$$GET1^DIQ(355.12,PTR_",",.03)="AMCMS" Q RESPONSE ;IB*668/DW
;
; Quit if a waiting transaction exists in file #365.1
S PTID=$P(NODE60,U,1)
S SUBID=$P(NODE90,U,3)
S QF=0,N4=""
F S N4=$O(^IBCN(365.1,"E",PTID,N4)) Q:N4="" Q:QF=1 D
.S TQN0=$G(^IBCN(365.1,N4,0))
.; don't send again if there's an entry in the queue with the same subscriber id, same buffer entry, and
.; transmission status other than "response received" or "cancelled"
.I $P(TQN0,U,5)=N2,".3.7."'[("."_$P(TQN0,U,4)_"."),$P(TQN0,U,16)=SUBID S QF=1 Q
.Q
I QF=1 Q RESPONSE ; DON'T SEND AGAIN.
;
; Quit if there is a lock on patient and policy in file #355.33
L +^IBA(355.33,N2):1 I '$T Q RESPONSE ; RECORD LOCKED By Another Process
;
;Store Service Type Code in BUFFER file #355.33 just before sending to EIV TRANSMISSION QUEUE
I +$G(^IBA(355.33,N2,80))'>0 D SETSTC(N2)
;
; Save and clear the dictionary 355.33 temporary error global, ^TMP("DIERR",$J)
K ^TMP("IBCNERTQ","DIERR",$J)
M ^TMP("IBCNERTQ","DIERR",$J)=^TMP("DIERR",$J)
K ^TMP("DIERR",$J)
;
; if buffer entry is currently being edited, set the flag and quit
I $G(^TMP("IBCNERTQ",$J,N2,"LOCK"))=1 S ^TMP("IBCNERTQ",$J,N2,"TRIGGER")=1 G ENDTRIG
;
; Sending to the EIV TRANSMISION QUEUE.
S TQIEN=$$IBE(N2) I 'TQIEN G ENDTRIG
; Load and Send HL7 Message
S RESPONSE=$$PROCSEND(TQIEN)
;
ENDTRIG ; Final Clean Up.
;
; Restore the dictionary 355.33 temporary error global, ^TMP("DIERR",$J)
K ^TMP("DIERR",$J)
M ^TMP("DIERR",$J)=^TMP("IBCNERTQ","DIERR",$J)
K ^TMP("IBCNERTQ","DIERR",$J)
;
; Remove Dictionary Entry Lock.
L -^IBA(355.33,N2)
Q RESPONSE
;
IBE(IEN) ; Insurance Buffer Extract
N FRESHDAY,FRESHDT,INSNAME,ISMBI,ISYMBOL,MCAREFLG,OVRFRESH,PAYERID,PAYERSTR
N PDOD,PIEN,QUEUED,SRVICEDT,STATIEN,SYMBOL,TQDT,TQIENS,TQOK
;
S QUEUED=0
S FRESHDAY=$P($G(^IBE(350.9,1,51)),U,1) ;System freshness days
;
; Get symbol, if symbol'=" " OR "!" OR "#" then quit
S ISYMBOL=$$SYMBOL^IBCNBLL(IEN) ;Insurance buffer symbol
I (ISYMBOL'=" ")&(ISYMBOL'="!")&(ISYMBOL'="#") Q QUEUED
;
;/vd-IB*2.0*659 - Quit if VAMC Site is MANILA (#358) & EIV is disabled for MANILA.
I $P($$SITE^VASITE,U,3)=358,$$GET1^DIQ(350.9,"1,",51.33,"I")="N" Q 0
;
; IB*2.0*549 - Quit if Realtime Extract Master switch is off
; Note: Checking here instead of the top of TRIG to check for above error conditions first
Q:$$GET1^DIQ(350.9,"1,",51.27,"I")="N" 0
;
; Get the eIV STATUS IEN and quit for response related errors
S STATIEN=+$P($G(^IBA(355.33,IEN,0)),U,12)
I ",11,12,15,"[(","_STATIEN_",") Q QUEUED ;Prevent update for response errors
;
S OVRFRESH=$P($G(^IBA(355.33,IEN,0)),U,13) ;Freshness OvrRd flag
S DFN=$P($G(^IBA(355.33,IEN,60)),U,1) ;Patient DFN
Q:DFN="" QUEUED
I $P($G(^DPT(DFN,0)),U,21) Q QUEUED ;Exclude if test patient
;
S PDOD=$P($G(^DPT(DFN,.35)),U,1)\1 ;Patient's date of death
S SRVICEDT=+$P($G(^IBA(355.33,IEN,0)),U,18) S:'SRVICEDT SRVICEDT=DT ; Service Date
;
; IB*2.0*549 Removed following line
;I PDOD,PDOD<SRVICEDT S SRVICEDT=PDOD
S FRESHDT=$$FMADD^XLFDT(SRVICEDT,-FRESHDAY)
S PAYERSTR=$$INSERROR^IBCNEUT3("B",IEN) ;Payer String
S PAYERID=$P(PAYERSTR,U,3),PIEN=$P(PAYERSTR,U,2) ;Payer ID
S SYMBOL=+PAYERSTR ;Payer Symbol
I '$$PYRACTV^IBCNEDE7(PIEN) Q QUEUED ;Payer is not nationally active
;
; If payer symbol is returned set symbol in Ins. Buffer and quit
I SYMBOL D BUFF^IBCNEUT2(IEN,SYMBOL) Q QUEUED
;
D CLEAR^IBCNEUT4(IEN) ;Remove any existing symbol
;
; If no payer ID or no payer IEN is returned quit
I (PAYERID="")!('PIEN) Q QUEUED
;
; Update service date and freshness date based on payer's allowed
; date range
D UPDDTS^IBCNEDE6(PIEN,.SRVICEDT,.FRESHDT)
;
; Update service dates for inquiries to be transmitted
D TQUPDSV^IBCNEUT5(DFN,PIEN,SRVICEDT)
;
; Allow only one MEDICARE transmission per patient
; IB*2*601/DM
;S INSNAME=$P($G(^IBA(355.33,IEN,20)),U)
;I INSNAME["MEDICARE",$G(MCAREFLG(DFN)) Q QUEUED
S INSNAME=$$GET1^DIQ(355.33,IEN_",","INSURANCE COMPANY NAME")
S ISMBI=$$MBICHK^IBCNEUT7(IEN) ;IB*2.0*631/TAZ - Set the MBI Check into a variable since it is used in multiple places.
I 'ISMBI,INSNAME["MEDICARE",$G(MCAREFLG(DFN)) Q QUEUED
; make sure that entries have pat. relationship set to "self"
D SETREL^IBCNEDE1(IEN)
;
; If freshness override flag is set, file to TQ and quit
I OVRFRESH=1!ISMBI D Q $G(TQIEN)
. ;IB*2.0*631/TAZ - Changed logic to call new TQ
. ;N DIE,DISYS,SUBID,WHICH,X,Y
. ;S SUBID=$$GET1^DIQ(365.1,TQIEN_",",.16,"I"),WHICH=$S(SUBID="MBIRequest":7,1:5)
. N DIE,DISYS,WHICH,X,Y
. S WHICH=$S(ISMBI:7,1:5)
. S FDA(355.33,IEN_",",.13)="" D FILE^DIE("","FDA") K FDA
. S:INSNAME["MEDICARE" MCAREFLG(DFN)=1 D TQ^IBCNERTU(WHICH,IEN,FRESHDT,DFN,PIEN,OVRFRESH,SRVICEDT)
; Check the existing TQ entries to confirm that this buffer IEN is
; not included
S (TQDT,TQIENS)="",TQOK=1
I ISYMBOL'="#" F S TQDT=$O(^IBCN(365.1,"AD",DFN,PIEN,TQDT)) Q:'TQDT!'TQOK D
. F S TQIENS=$O(^IBCN(365.1,"AD",DFN,PIEN,TQDT,TQIENS)) Q:'TQIENS!'TQOK D
.. I $P($G(^IBCN(365.1,TQIENS,0)),U,5)=IEN S TQOK=0 Q
I TQOK S:INSNAME["MEDICARE" MCAREFLG(DFN)=1 D TQ^IBCNERTU(6,IEN,FRESHDT,DFN,PIEN,OVRFRESH,SRVICEDT) ;IB*2.0*631/TAZ
Q $G(TQIEN)
;
PROCSEND(TQIEN) ; Make call to PROC^IBCNEDEP to build the HL7 message. Then send the Message.
N BUFF,CNT,D,D0,DFN,DIC,DIE,DILOCKTM,DISYS,EXT
N FRDT,GT1,HCT,HL,HLCDOM,HLCINS,HLCS,HLCSTCP,HLDOM,HLECH
N HLFS,HLHDR,HLINST,HLIP,HLN,HLP,HLPARAM,HLPROD,HLQ,HLRESLT
N HLSAN,HLTYPE,HLX,IBCNHLP,IEN,IHCNT,IN1,IRIEN,MSGID,TOT
N NRETR,NTRAN,OVRIDE,PATID,PAYR,PID,QUERY,RSTYPE,SRVDT,STA
N SUB4,SUBID,TRANSR,U,VACNTRY,VNUM,X,ZMID
;
K ^TMP("HLS",$J)
S IEN=TQIEN
I $D(DT)=0 N DT S DT=$$DT^XLFDT
S U="^",CNT=0,TOT=0,IHCNT=0
S QUERY=$P($G(^IBCN(365.1,IEN,0)),U,11)
I QUERY="V" S VNUM=3
I $D(VNUM)=0 Q 0
;
; IB*2.0*549 - quit if test site and not a valid test case
Q:'$$XMITOK^IBCNETST(IEN) 0
;
; Initialize HL7 variables protocol for Verifications
S IBCNHLP="IBCNE IIV RQV OUT"
D INIT^IBCNEHLO
;
;IB*713/TAZ - Change to function call and quit if 0 is returned.
I '$$PROC^IBCNEDEP Q 0
;
D GENERATE^HLMA(IBCNHLP,"GM",1,.HLRESLT,"",.HLP)
; If not successful
I $P(HLRESLT,U,2)]"" D HLER^IBCNEDEQ Q 0
; If successful
D SCC^IBCNEDEQ
K ^TMP("HLS",$J)
;
I $G(^TMP("IBCNEQUDTS",$J)) D
. S DA=IEN,DIE="^IBCN(365.1,",DR="3.01////^S X=$$NOW^XLFDT" D ^DIE
;
Q 1
;
SETSTC(BUFF) ; set service type code
N DIE,DA,DR,X,Y
I '+$G(BUFF) Q
; Define Service Type Code (STC) to be sent with Insurance Inquiry
S DIE="^IBA(355.33,",DA=BUFF
S DR="80.01////"_$P($G(^IBE(350.9,1,60)),U)
D ^DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNERTQ 9343 printed Mar 13, 2025@21:20:08 Page 2
IBCNERTQ ;ALB/BI - Real-time Insurance Verification ;15-OCT-2015
+1 ;;2.0;INTEGRATED BILLING;**438,467,497,549,582,593,601,631,659,664,668,713**;21-MAR-94;Build 12
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
TRIG(N2) ; Called by triggers in the INSURANCE BUFFER FILE Dictionary (355.33)
+1 ; Fields: 20.01 - INSURANCE COMPANY NAME
+2 ; 90.01 - GROUP NAME
+3 ; 90.02 - GROUP NUMBER
+4 ; 60.01 - PATIENT NAME
+5 ; 90.03 - SUBSCRIBER ID
+6 ; 60.08 - INSURED'S DOB
+7 ; 62.01 - PATIENT ID
+8 ;
+9 ; To make a request for Real Time Verification
+10 ; The following fields must contain data.
+11 ; 20.01 - INSURANCE COMPANY NAME
+12 ; 60.01 - PATIENT NAME
+13 ; 90.03 - SUBSCRIBER ID (if patient is the subscriber)
+14 ; 60.08 - INSURED'S DOB (if patient is not the subscriber)
+15 ; 62.01 - PATIENT ID (if patient is not the subscriber)
+16 ;
+17 ;
+18 NEW TQIEN,TQN0,NODE20,NODE60,NODE90,QF,N4,PTID,SUBID,MGRP,DFN,PREL
+19 NEW RESPONSE
SET RESPONSE=0
+20 ; Protect the FileMan variables.
+21 NEW DA,DB,DC,DH,DI,DK,DL,DM,DP,DQ,DR,INI,MR,NX,UP
+22 ;
+23 IF N2=""
QUIT RESPONSE
+24 ;IB*582/HAN - Do not allow entries to process if the user is INTERFACE,IB EIV
+25 NEW EIVDUZ
SET EIVDUZ=$$FIND1^DIC(200,"","X","INTERFACE,IB EIV")
+26 ;IB*2.0*593/HN - Added to allow nightly extract entries to go out immediately.
+27 IF $GET(IDUZ)'=""
IF IDUZ=EIVDUZ
IF $GET(CALLEDBY)'=""
IF CALLEDBY="IBCNEHL1"
QUIT RESPONSE
+28 ;IB*582 - End
+29 SET MGRP=$$MGRP^IBCNEUT5()
+30 SET NODE20=$GET(^IBA(355.33,N2,20))
+31 SET NODE60=$GET(^IBA(355.33,N2,60))
+32 SET NODE90=$GET(^IBA(355.33,N2,90))
+33 SET PREL=$PIECE(NODE60,U,14)
+34 ;INSURANCE COMPANY NAME
IF $PIECE(NODE20,U,1)=""
QUIT RESPONSE
+35 ;PATIENT NAME
IF $PIECE(NODE60,U,1)=""
QUIT RESPONSE
+36 ;SUBSCRIBER ID
IF $PIECE(NODE90,U,3)=""
QUIT RESPONSE
+37 ; exclude dependent inquiries w/o patient id or DOB
+38 IF PREL'=18
IF PREL'=""
IF ($PIECE($GET(^IBA(355.33,N2,62)),U)=""!($PIECE(NODE60,U,8)=""))
QUIT RESPONSE
+39 ; exclude ePharmacy buffer entries
+40 ; variable set in ^IBNCPDP3
IF $GET(IBNCPDPELIG)
QUIT RESPONSE
+41 IF $PIECE($GET(^IBA(355.33,N2,0)),U,17)'=""
QUIT RESPONSE
+42 ;
+43 ; ** Prevent creating inquiries based on Source of Information (SOI) **
+44 NEW PTR
SET PTR=+$PIECE($GET(^IBA(355.33,N2,0)),U,3)
+45 IF PTR
IF $PIECE($GET(^IBE(355.12,PTR,0)),U,2)="HMS"
IF PREL=""
QUIT RESPONSE
+46 ;/vd-IB*2*664
IF PTR
IF $$GET1^DIQ(355.12,PTR_",",.03)="EHR"
QUIT RESPONSE
+47 ;IB*668/DW
IF PTR
IF $$GET1^DIQ(355.12,PTR_",",.03)="AMCMS"
QUIT RESPONSE
+48 ;
+49 ; Quit if a waiting transaction exists in file #365.1
+50 SET PTID=$PIECE(NODE60,U,1)
+51 SET SUBID=$PIECE(NODE90,U,3)
+52 SET QF=0
SET N4=""
+53 FOR
SET N4=$ORDER(^IBCN(365.1,"E",PTID,N4))
if N4=""
QUIT
if QF=1
QUIT
Begin DoDot:1
+54 SET TQN0=$GET(^IBCN(365.1,N4,0))
+55 ; don't send again if there's an entry in the queue with the same subscriber id, same buffer entry, and
+56 ; transmission status other than "response received" or "cancelled"
+57 IF $PIECE(TQN0,U,5)=N2
IF ".3.7."'[("."_$PIECE(TQN0,U,4)_".")
IF $PIECE(TQN0,U,16)=SUBID
SET QF=1
QUIT
+58 QUIT
End DoDot:1
+59 ; DON'T SEND AGAIN.
IF QF=1
QUIT RESPONSE
+60 ;
+61 ; Quit if there is a lock on patient and policy in file #355.33
+62 ; RECORD LOCKED By Another Process
LOCK +^IBA(355.33,N2):1
IF '$TEST
QUIT RESPONSE
+63 ;
+64 ;Store Service Type Code in BUFFER file #355.33 just before sending to EIV TRANSMISSION QUEUE
+65 IF +$GET(^IBA(355.33,N2,80))'>0
DO SETSTC(N2)
+66 ;
+67 ; Save and clear the dictionary 355.33 temporary error global, ^TMP("DIERR",$J)
+68 KILL ^TMP("IBCNERTQ","DIERR",$JOB)
+69 MERGE ^TMP("IBCNERTQ","DIERR",$JOB)=^TMP("DIERR",$JOB)
+70 KILL ^TMP("DIERR",$JOB)
+71 ;
+72 ; if buffer entry is currently being edited, set the flag and quit
+73 IF $GET(^TMP("IBCNERTQ",$JOB,N2,"LOCK"))=1
SET ^TMP("IBCNERTQ",$JOB,N2,"TRIGGER")=1
GOTO ENDTRIG
+74 ;
+75 ; Sending to the EIV TRANSMISION QUEUE.
+76 SET TQIEN=$$IBE(N2)
IF 'TQIEN
GOTO ENDTRIG
+77 ; Load and Send HL7 Message
+78 SET RESPONSE=$$PROCSEND(TQIEN)
+79 ;
ENDTRIG ; Final Clean Up.
+1 ;
+2 ; Restore the dictionary 355.33 temporary error global, ^TMP("DIERR",$J)
+3 KILL ^TMP("DIERR",$JOB)
+4 MERGE ^TMP("DIERR",$JOB)=^TMP("IBCNERTQ","DIERR",$JOB)
+5 KILL ^TMP("IBCNERTQ","DIERR",$JOB)
+6 ;
+7 ; Remove Dictionary Entry Lock.
+8 LOCK -^IBA(355.33,N2)
+9 QUIT RESPONSE
+10 ;
IBE(IEN) ; Insurance Buffer Extract
+1 NEW FRESHDAY,FRESHDT,INSNAME,ISMBI,ISYMBOL,MCAREFLG,OVRFRESH,PAYERID,PAYERSTR
+2 NEW PDOD,PIEN,QUEUED,SRVICEDT,STATIEN,SYMBOL,TQDT,TQIENS,TQOK
+3 ;
+4 SET QUEUED=0
+5 ;System freshness days
SET FRESHDAY=$PIECE($GET(^IBE(350.9,1,51)),U,1)
+6 ;
+7 ; Get symbol, if symbol'=" " OR "!" OR "#" then quit
+8 ;Insurance buffer symbol
SET ISYMBOL=$$SYMBOL^IBCNBLL(IEN)
+9 IF (ISYMBOL'=" ")&(ISYMBOL'="!")&(ISYMBOL'="#")
QUIT QUEUED
+10 ;
+11 ;/vd-IB*2.0*659 - Quit if VAMC Site is MANILA (#358) & EIV is disabled for MANILA.
+12 IF $PIECE($$SITE^VASITE,U,3)=358
IF $$GET1^DIQ(350.9,"1,",51.33,"I")="N"
QUIT 0
+13 ;
+14 ; IB*2.0*549 - Quit if Realtime Extract Master switch is off
+15 ; Note: Checking here instead of the top of TRIG to check for above error conditions first
+16 if $$GET1^DIQ(350.9,"1,",51.27,"I")="N"
QUIT 0
+17 ;
+18 ; Get the eIV STATUS IEN and quit for response related errors
+19 SET STATIEN=+$PIECE($GET(^IBA(355.33,IEN,0)),U,12)
+20 ;Prevent update for response errors
IF ",11,12,15,"[(","_STATIEN_",")
QUIT QUEUED
+21 ;
+22 ;Freshness OvrRd flag
SET OVRFRESH=$PIECE($GET(^IBA(355.33,IEN,0)),U,13)
+23 ;Patient DFN
SET DFN=$PIECE($GET(^IBA(355.33,IEN,60)),U,1)
+24 if DFN=""
QUIT QUEUED
+25 ;Exclude if test patient
IF $PIECE($GET(^DPT(DFN,0)),U,21)
QUIT QUEUED
+26 ;
+27 ;Patient's date of death
SET PDOD=$PIECE($GET(^DPT(DFN,.35)),U,1)\1
+28 ; Service Date
SET SRVICEDT=+$PIECE($GET(^IBA(355.33,IEN,0)),U,18)
if 'SRVICEDT
SET SRVICEDT=DT
+29 ;
+30 ; IB*2.0*549 Removed following line
+31 ;I PDOD,PDOD<SRVICEDT S SRVICEDT=PDOD
+32 SET FRESHDT=$$FMADD^XLFDT(SRVICEDT,-FRESHDAY)
+33 ;Payer String
SET PAYERSTR=$$INSERROR^IBCNEUT3("B",IEN)
+34 ;Payer ID
SET PAYERID=$PIECE(PAYERSTR,U,3)
SET PIEN=$PIECE(PAYERSTR,U,2)
+35 ;Payer Symbol
SET SYMBOL=+PAYERSTR
+36 ;Payer is not nationally active
IF '$$PYRACTV^IBCNEDE7(PIEN)
QUIT QUEUED
+37 ;
+38 ; If payer symbol is returned set symbol in Ins. Buffer and quit
+39 IF SYMBOL
DO BUFF^IBCNEUT2(IEN,SYMBOL)
QUIT QUEUED
+40 ;
+41 ;Remove any existing symbol
DO CLEAR^IBCNEUT4(IEN)
+42 ;
+43 ; If no payer ID or no payer IEN is returned quit
+44 IF (PAYERID="")!('PIEN)
QUIT QUEUED
+45 ;
+46 ; Update service date and freshness date based on payer's allowed
+47 ; date range
+48 DO UPDDTS^IBCNEDE6(PIEN,.SRVICEDT,.FRESHDT)
+49 ;
+50 ; Update service dates for inquiries to be transmitted
+51 DO TQUPDSV^IBCNEUT5(DFN,PIEN,SRVICEDT)
+52 ;
+53 ; Allow only one MEDICARE transmission per patient
+54 ; IB*2*601/DM
+55 ;S INSNAME=$P($G(^IBA(355.33,IEN,20)),U)
+56 ;I INSNAME["MEDICARE",$G(MCAREFLG(DFN)) Q QUEUED
+57 SET INSNAME=$$GET1^DIQ(355.33,IEN_",","INSURANCE COMPANY NAME")
+58 ;IB*2.0*631/TAZ - Set the MBI Check into a variable since it is used in multiple places.
SET ISMBI=$$MBICHK^IBCNEUT7(IEN)
+59 IF 'ISMBI
IF INSNAME["MEDICARE"
IF $GET(MCAREFLG(DFN))
QUIT QUEUED
+60 ; make sure that entries have pat. relationship set to "self"
+61 DO SETREL^IBCNEDE1(IEN)
+62 ;
+63 ; If freshness override flag is set, file to TQ and quit
+64 IF OVRFRESH=1!ISMBI
Begin DoDot:1
+65 ;IB*2.0*631/TAZ - Changed logic to call new TQ
+66 ;N DIE,DISYS,SUBID,WHICH,X,Y
+67 ;S SUBID=$$GET1^DIQ(365.1,TQIEN_",",.16,"I"),WHICH=$S(SUBID="MBIRequest":7,1:5)
+68 NEW DIE,DISYS,WHICH,X,Y
+69 SET WHICH=$SELECT(ISMBI:7,1:5)
+70 SET FDA(355.33,IEN_",",.13)=""
DO FILE^DIE("","FDA")
KILL FDA
+71 if INSNAME["MEDICARE"
SET MCAREFLG(DFN)=1
DO TQ^IBCNERTU(WHICH,IEN,FRESHDT,DFN,PIEN,OVRFRESH,SRVICEDT)
End DoDot:1
QUIT $GET(TQIEN)
+72 ; Check the existing TQ entries to confirm that this buffer IEN is
+73 ; not included
+74 SET (TQDT,TQIENS)=""
SET TQOK=1
+75 IF ISYMBOL'="#"
FOR
SET TQDT=$ORDER(^IBCN(365.1,"AD",DFN,PIEN,TQDT))
if 'TQDT!'TQOK
QUIT
Begin DoDot:1
+76 FOR
SET TQIENS=$ORDER(^IBCN(365.1,"AD",DFN,PIEN,TQDT,TQIENS))
if 'TQIENS!'TQOK
QUIT
Begin DoDot:2
+77 IF $PIECE($GET(^IBCN(365.1,TQIENS,0)),U,5)=IEN
SET TQOK=0
QUIT
End DoDot:2
End DoDot:1
+78 ;IB*2.0*631/TAZ
IF TQOK
if INSNAME["MEDICARE"
SET MCAREFLG(DFN)=1
DO TQ^IBCNERTU(6,IEN,FRESHDT,DFN,PIEN,OVRFRESH,SRVICEDT)
+79 QUIT $GET(TQIEN)
+80 ;
PROCSEND(TQIEN) ; Make call to PROC^IBCNEDEP to build the HL7 message. Then send the Message.
+1 NEW BUFF,CNT,D,D0,DFN,DIC,DIE,DILOCKTM,DISYS,EXT
+2 NEW FRDT,GT1,HCT,HL,HLCDOM,HLCINS,HLCS,HLCSTCP,HLDOM,HLECH
+3 NEW HLFS,HLHDR,HLINST,HLIP,HLN,HLP,HLPARAM,HLPROD,HLQ,HLRESLT
+4 NEW HLSAN,HLTYPE,HLX,IBCNHLP,IEN,IHCNT,IN1,IRIEN,MSGID,TOT
+5 NEW NRETR,NTRAN,OVRIDE,PATID,PAYR,PID,QUERY,RSTYPE,SRVDT,STA
+6 NEW SUB4,SUBID,TRANSR,U,VACNTRY,VNUM,X,ZMID
+7 ;
+8 KILL ^TMP("HLS",$JOB)
+9 SET IEN=TQIEN
+10 IF $DATA(DT)=0
NEW DT
SET DT=$$DT^XLFDT
+11 SET U="^"
SET CNT=0
SET TOT=0
SET IHCNT=0
+12 SET QUERY=$PIECE($GET(^IBCN(365.1,IEN,0)),U,11)
+13 IF QUERY="V"
SET VNUM=3
+14 IF $DATA(VNUM)=0
QUIT 0
+15 ;
+16 ; IB*2.0*549 - quit if test site and not a valid test case
+17 if '$$XMITOK^IBCNETST(IEN)
QUIT 0
+18 ;
+19 ; Initialize HL7 variables protocol for Verifications
+20 SET IBCNHLP="IBCNE IIV RQV OUT"
+21 DO INIT^IBCNEHLO
+22 ;
+23 ;IB*713/TAZ - Change to function call and quit if 0 is returned.
+24 IF '$$PROC^IBCNEDEP
QUIT 0
+25 ;
+26 DO GENERATE^HLMA(IBCNHLP,"GM",1,.HLRESLT,"",.HLP)
+27 ; If not successful
+28 IF $PIECE(HLRESLT,U,2)]""
DO HLER^IBCNEDEQ
QUIT 0
+29 ; If successful
+30 DO SCC^IBCNEDEQ
+31 KILL ^TMP("HLS",$JOB)
+32 ;
+33 IF $GET(^TMP("IBCNEQUDTS",$JOB))
Begin DoDot:1
+34 SET DA=IEN
SET DIE="^IBCN(365.1,"
SET DR="3.01////^S X=$$NOW^XLFDT"
DO ^DIE
End DoDot:1
+35 ;
+36 QUIT 1
+37 ;
SETSTC(BUFF) ; set service type code
+1 NEW DIE,DA,DR,X,Y
+2 IF '+$GET(BUFF)
QUIT
+3 ; Define Service Type Code (STC) to be sent with Insurance Inquiry
+4 SET DIE="^IBA(355.33,"
SET DA=BUFF
+5 SET DR="80.01////"_$PIECE($GET(^IBE(350.9,1,60)),U)
+6 DO ^DIE
+7 QUIT
