IBCNIUH1 ;AITC/TAZ - IIU RECEIVE AND PROCESS INSURANCE TRANSMISSIONS ; 04/06/21 12:46p.m.
;;2.0;INTEGRATED BILLING;**687,702,804**;21-MAR-94;Build 6
;;Per VA Directive 6402, this routine should not be modified.
;
; ICR #2171 for the usage of $$IEN^XUAF4
Q
;
;**Program Description**
; This routine is the driver routine for receiving an Interfacility Insurance Update message.
;
REC ;Receive data from remote system
N BIN,CNT,COB,DFN,DOB,ECODE,EFFDT,ERFLG,ERROR,EVENT,FDATA,FLD
N GNAME,GNUM,GT1,HLECH,HLFS,IBACK,IBDFA,IBPRTCL,ICN,IDLIST,IDUZ
N IIUERR,IIUIEN,INAME,INSNAME,MSG,PATDFN,PATICN,PATID,PATNAME,PCN,PTYPE,REL
N SEGCNT,SEGMT,SITE,STATUS,SUBC,SUBCID,SUBCNT,SUBCDATA,SUBCID,SUBID
N VAID,WHOSE,XDFN
;
;Store the incoming message into a TMP global
K ^TMP("IBCNIUH1",$J)
S ^TMP("IBCNIUH1",$J)=$$NOW^XLFDT
F SEGCNT=1:1 X HLNEXT Q:HLQUIT'>0 D
. S CNT=0
. S ^TMP("IBCNIUH1",$J,SEGCNT,CNT)=HLNODE
. F S CNT=$O(HLNODE(CNT)) Q:'CNT D
. . S ^TMP("IBCNIUH1",$J,SEGCNT,CNT)=HLNODE(CNT)
;
;Initialize the HL7 variables
N HLCMP,HLECH,HLFS
S HLCMP=$E(HL("ECH")) ;HL7 component separator
S HLECH=HL("ECH") ;HL7 encoding characters
S HLFS=HL("FS") ;HL7 field separator
;
;Received HL7 message & save to file INTERFACILITY INSURANCE UPDATE (#365.19)
D RECEIVE
I $G(IIUERR)!ERFLG G RECX
;
D GETSTAT
I IIUERR G RECX
;
; Attempt to file to the "Buffer", INSURANCE VERIFICATION PROCESSOR (#355.33)
D FILEBUF
I IIUERR G RECX
;
;Update the receiving STATUS of the IIU entry to "S" SAVED TO BUFFER
S STATUS="S"
D FILESTAT
;
RECX ;
K ^TMP("IBCNIUH1",$J)
K HLNEXT,HLNODE,HLQUIT
Q
;
RECEIVE ;Entry Point
N DATA,DFN,ERROR,HCT,IBDFDA,IBSEG,ICN,IENSTR,ISCT
N SEG,STATUS,SUBC,SUBCDATA,SUBCID,SUBCNT,UPD,XDFN
;
S (ERFLG,GT1,IIUERR)=0
;
S HCT=0 F S HCT=$O(^TMP("IBCNIUH1",$J,HCT)) Q:HCT="" D Q:ERFLG
. D SPAR
. S SEG=$G(IBSEG(1))
. ;
. Q:SEG="PRD" ; PRD segment carries no data to store
. ;
. ;Message Segment
. I SEG="MSH" D Q
. . ;SITE will get stored during the processing of the PID segment
. . ;IB*702/CKB - get the IEN not the Site number of Sending/Originating VAMC
. . S SITE=$$IEN^XUAF4($P($G(IBSEG(4)),HLCMP))
. ;
. ;Patient Segment
. I SEG="PID" D Q
. . K DATA
. . S (ICN,DFN)=""
. . S IDLIST=$G(IBSEG(4))
. . F SUBCNT=1:1:$L(IDLIST,$E(HLECH,2,2)) D
. . . S SUBC=$P(IDLIST,$E(HLECH,2,2),SUBCNT)
. . . S SUBCID=$P(SUBC,$E(HLECH),5) ; Identifier Type Code
. . . S SUBCDATA=$P(SUBC,$E(HLECH),1) ; Data Value
. . . I SUBCID="NI" S ICN=SUBCDATA
. . ; Use ICN to find the patients DFN at this site
. . I ICN'="" S XDFN=$$GETDFN^MPIF001(ICN)
. . I +$G(XDFN)'>0,+$G(ICN)>0 S ERFLG=1 Q
. . ;
. . I +ICN>0 S (PATDFN,DFN)=XDFN
. . S PATICN=SUBCDATA
. . ; Get PATIENT NAME (if GT1, NAME OF INSURED). This is needed for the Duplicate Check, STATD.
. . S INAME=$G(IBSEG(6))
. . S INAME=$$DECHL7($$FMNAME^HLFNC(INAME,HLECH))
. . ;
. . S DATA(.01)=PATDFN
. . S DATA(.02)=$$NOW^XLFDT
. . S DATA(.03)="R" ;DIRECTION, R for RECEIVER
. . ; Create new entry in IIU File #365.19, get IEN
. . S IIUIEN=$$ADD^IBDFDBS(365.19,,.DATA)
. . I 'IIUIEN S ERFLG=1 Q ; couldn't create record
. . S IBDFDA(1)=IIUIEN
. . K DATA
. . ;
. . ; We got the variable SITE from the MSH segment
. . S DATA(.01)=SITE ;ORIGINATING VAMC
. . S DATA(.02)=PATICN ;PATIENT'S ICN
. . ; Create new entry in IIU, ORIGINATING VAMC sub-file #365.192, get IBDFDA which = IEN
. . S IBDFDA=$$ADD^IBDFDBS(365.192,.IBDFDA,.DATA)
. . I 'IBDFDA D STATE ;Error Saving to the IIU file
. ;
. I '$G(IIUIEN) S ERFLG=1 Q ;missing PID, abort process
. ;
. ;Guarantor Segment
. I SEG="GT1" D Q
. . K DATA,ERROR,UPD
. . S GT1=1
. . S SUBID=$P($G(IBSEG(3)),HLCMP)
. . S INAME=$G(IBSEG(4))
. . S INAME=$$DECHL7($$FMNAME^HLFNC(INAME,HLECH))
. . ;
. . S DATA(1.02)=INAME ;NAME OF INSURED
. . S DATA(1.03)=SUBID ;SUBSCRIBER ID
. . ;Update IIU file with data from GT1
. . S UPD=$$UPD^IBDFDBS(365.192,.IBDFDA,.DATA,.ERROR)
. . I ERROR=0 D STATE ;Error Saving to the IIU file
. ;
. ;Insurance Segment
. I SEG="IN1" D Q
. . K DATA,ERROR,UPD
. . I 'GT1 S SUBID=$G(IBSEG(3))
. . I GT1 S PATID=$G(IBSEG(3))
. . S VAID=$P($G(IBSEG(4)),HLCMP)
. . S INSNAME=$G(IBSEG(5))
. . S INSNAME=$$DECHL7(INSNAME)
. . S GNUM=$$DECHL7($G(IBSEG(9)))
. . S GNAME=$$DECHL7($G(IBSEG(10)))
. . S EFFDT=$G(IBSEG(13))
. . S EFFDT=$$FMDATE^HLFNC(EFFDT)
. . S PTYPE=$G(IBSEG(16))
. . S REL=$G(IBSEG(18))
. . S DOB=$G(IBSEG(19))
. . S DOB=$$FMDATE^HLFNC(DOB)
. . S COB=$G(IBSEG(23))
. . ;
. . S DATA(.03)=INSNAME ;INSURANCE COMPANY NAME
. . S DATA(.04)=GNAME ;GROUP NAME
. . S DATA(.05)=GNUM ;GROUP NUMBER
. . S DATA(.08)=PTYPE ;PLAN TYPE
. . S DATA(.09)=EFFDT ;EFFECTIVE DATE
. . S DATA(.1)=REL ;PT. RELATIONSHIP - HIPAA
. . S DATA(1.04)=DOB ;INSURED'S DOB
. . S DATA(1.05)=COB ;COORDINATION OF BENEFITS
. . S DATA(1.07)=VAID ;PAYER'S VA NATIONAL ID
. . ;If not a Guarantor, the Patient ID is the same as the Subscriber ID
. . I 'GT1 S DATA(1.01)=SUBID,DATA(1.03)=SUBID ;PATIENT ID/SUBSCRIBER ID
. . I GT1 S DATA(1.01)=PATID ;PATIENT ID
. . ;
. . ;Update IIU file with data from IN1
. . S UPD=$$UPD^IBDFDBS(365.192,.IBDFDA,.DATA,.ERROR)
. . I ERROR=0 D STATE ;Error Saving to the IIU file
. ;
. ;NTE Segment
. I SEG="NTE" D Q
. . K DATA,ERROR,UPD
. . S WHOSE=$P($G(IBSEG(4)),HLCMP)
. . S BIN=$$DECHL7($P($G(IBSEG(4)),HLCMP,2))
. . S PCN=$$DECHL7($P($G(IBSEG(4)),HLCMP,3))
. . ;
. . S DATA(.06)=BIN ;BANKING IDENTIFICATION NUMBER
. . S DATA(.07)=PCN ;PROCESSOR CONTROL NUMBER
. . S DATA(1.06)=WHOSE ;WHOSE INSURANCE
. . ;Update IIU file with data from NTE
. . S UPD=$$UPD^IBDFDBS(365.192,.IBDFDA,.DATA,.ERROR)
. . I ERROR=0 D STATE ;error saving to the IIU file
;
Q
;
GETSTAT ;Get the RECEIVER STATUS (365.19,2.01) by performing various checks
S IIUERR=0
D STATI I IIUERR=1 G GETSTATQ ;I=IIU ENABLED IS OFF
D STATR I IIUERR=1 G GETSTATQ ;R=RECEIVE IIU DATA IS OFF
D STATV I IIUERR=1 G GETSTATQ ;V=VISITED TOO LONG AGO
D STATD I IIUERR=1 G GETSTATQ ;D=DUPLICATE
S STATUS="S" ;S=SAVED TO THE BUFFER
;
GETSTATQ ;
D FILESTAT ; files STATUS into #365.19
Q
;
FILEBUF ;File IIU data file #365.19 into the Buffer file #355.33
N IBBUFDA,IBDATA,SOURCE
;
S SOURCE=$$FIND1^DIC(355.12,"","X","INTERFACILITY INS UPDATE","C")
;Get the non-human user
S IDUZ=$$FIND1^DIC(200,"","X","INTERFACE,IB IIU")
;Add a new buffer file entry (#355.33), sets only status (0) node data
S IBBUFDA=+$$ADD^IBCNBEE(SOURCE)
;There was an error saving the Buffer, set IIU RECEIVER STATUS to 'B' ERROR SAVING TO BUFFER
I (IDUZ="")!('IBBUFDA) D STATB Q
;
;IB*804/DTG lock buffer entry
; Lock the buffer entry
S BUFLOCK=$$BUFLOCK^IBCNEHL6(IBBUFDA,1)
;
S IBDATA(.02)=IDUZ ; Entered By
; Source of Information was set above in $$ADD^IBCNBEE
S IBDATA(.14)=SITE ; Remote Location (the site that sent the IIU record)
S IBDATA(20.01)=INSNAME ; Insurance Company/Payer Name
S IBDATA(40.09)=PTYPE ; Plan Type
S IBDATA(40.1)=BIN ; Banking Identification Number
S IBDATA(40.11)=PCN ; Processor Control Number
S IBDATA(60.01)=PATDFN ; Patient IEN
S IBDATA(60.02)=EFFDT ; Effective Date
S IBDATA(60.05)=WHOSE ; Whose Insurance
S IBDATA(60.08)=DOB ; Insured's DOB
S IBDATA(60.12)=COB ; Coordination of Benefits
S IBDATA(60.14)=REL ; Patient Relationship
S IBDATA(90.01)=GNAME ; Group Name
S IBDATA(90.02)=GNUM ; Group Number
S IBDATA(90.03)=SUBID ; Subscriber ID
;
I GT1 D
. S IBDATA(62.01)=$G(PATID) ; Patient/Member ID
. S IBDATA(91.01)=INAME ; Name of Insured
I 'GT1 D
. ;If not a Guarantor, the Patient/Member ID is the same as the Subscriber ID
. S IBDATA(62.01)=SUBID ; Patient/Member ID
. S IBDATA(91.01)=PATDFN ; Patient IEN
;
;Add IBDATA to the buffer entry. EDITSTF ensures that Subscriber ID is saved to the buffer last.
D EDITSTF^IBCNBES(IBBUFDA,.IBDATA)
;Set buffer symbol to the buffer
D BUFF^IBCNEUT2(IBBUFDA,+$$INSERROR^IBCNEUT3("B",IBBUFDA))
;
;IB*804/DTG un-lock buffer entry
; remove Lock on the buffer entry
N BUFLOCK S BUFLOCK=$$BUFLOCK^IBCNEHL6(IBBUFDA,0)
;
;Add BUFFER IEN to the IIU file
N DATA,ERROR,UPD
S DATA(2.03)=IBBUFDA
S UPD=$$UPD^IBDFDBS(365.19,IIUIEN,.DATA,.ERROR)
I ERROR=0 D STATB ;Error Saving to the Buffer
Q
;
STATI ;If the IIU ENABLED field is off, set RECEIVER STATUS to "I" IIU ENABLED IS OFF
N IIUEN
S IIUEN=$$GET1^DIQ(350.9,"1,",53.02,"I")
I 'IIUEN S IIUERR=1,STATUS="I"
Q
;
STATR ;If the RECEIVE IIU DATA is off, set RECEIVER STATUS to "R" RECEIVE IIU DATA IS OFF
N PIEN,IIUARR,IIUIENS
; Get the Payer IEN
S PIEN=$O(^IBE(365.12,"C",VAID,""))
; Get the IIU Payer data
D PAYER^IBCNINSU(PIEN,"IIU","*","E",.IIUARR)
S IIUIENS=$O(IIUARR(365.121,""))
; Check field 5.01 RECEIVE IIU DATA for the Payer
I $G(IIUARR(365.121,IIUIENS,5.01,"E"))'="YES" S IIUERR=1,STATUS="R"
Q
;
STATV ;If the last event date is greater then the site parameter IIU RECENT VISIT DAYS,
; set RECEIVER STATUS to "V" VISITED TOO LONG AGO
N IBS,IIUDAYS,LV,SITE
; Get current site
;IB*702 CKB - get the IEN not the Site number of Receiving VAMC
S IBS=$$IEN^XUAF4($P($$SITE^VASITE,U,3))
; Get last visit
I $$TFL^IBCNIUF(PATDFN,.SITE,"R") S LV=$P(SITE(IBS),U,3)
; If no last visit, set error and quit
I '$G(LV) S IIUERR=1,STATUS="V" G STATVQ
; Get IIU RECENT VISIT DAYS
S IIUDAYS=$$GET1^DIQ(350.9,"1,",53.03,"I")
; Compare last visit to IIU RECENT VISIT DAYS
I +$G(LV),$$FMDIFF^XLFDT(DT,LV)>IIUDAYS S IIUERR=1,STATUS="V"
STATVQ ;
Q
;
STATD ;Check for Duplicate IIU entry, if found set RECEIVER STATUS to "D" DUPLICATE
K ^TMP("IBCNRDV",$J)
;
; Build index of Buffer entries and Insurance Type subfile entries.
D INDEX^IBCNRDV(PATDFN)
;
; Build array for checking
N IBARY
S IBARY(20.01)=$G(INSNAME)
S IBARY(40.03)=$G(GNUM)
S IBARY(60.04)=$G(SUBID)
S IBARY(60.07)=$P($G(INAME)," ",1)
S IBARY(60.08)=$G(DOB)
;
;If Duplicate, set IIUERR and STATUS=D and quit
I $$DUP^IBCNRDV(.IBARY) S IIUERR=1,STATUS="D"
;
K ^TMP("IBCNRDV",$J)
Q
;
STATE ;If a error occurs during the creation of the entry into the IIU file (365.19),
;set RECEIVER STATUS to "E" ERROR SAVING TO IIU
S IIUERR=1,STATUS="E"
D FILESTAT
Q
;
STATB ;If a error occurs during the creation of the entry into the Buffer file (355.33),
;set RECEIVER STATUS in the IIU file to "B" ERROR SAVING TO THE BUFFER
S IIUERR=1,STATUS="B"
D FILESTAT
Q
;
FILESTAT ;File STATUS in File #365.19
N DATA
S DATA(2.01)=STATUS
I $$UPD^IBDFDBS(365.19,IIUIEN,.DATA)
Q
;
DECHL7(STR,HL) ;Decode HL7 characters
;INPUT:
; STR - String to be encoded
; HL - Array containing HL components returned from INIT^HLFNC2
;
; Returns an decoded string
; The encoded characters are:
; /F/ - Field Separator
; /C/ - Component Separator
; /R/ - Repetition Separator
; /E/ - Escape Character
; /S/ - Sub-component Separator
;
;NOTE: This tag uses RECURSION. Be careful how you edit it.
;
I STR']"" G DECHL7Q ;Nothing to decode
I '$D(HL) G DECHL7Q ;No decoding characters defined
;
LP ;Continue to loop through the string until all instances of encoding is decoded then exit.
I STR'?.E1"/".A1"/".E G DECHL7Q
I STR["/F/" S STR=$P(STR,"/",1)_HL("FS")_$P(STR,"/",3,9999)
I STR["/C/" S STR=$P(STR,"/",1)_$E(HL("ECH"),1)_$P(STR,"/",3,9999)
I STR["/R/" S STR=$P(STR,"/",1)_$E(HL("ECH"),2)_$P(STR,"/",3,9999)
I STR["/E/" S STR=$P(STR,"/",1)_$E(HL("ECH"),3)_$P(STR,"/",3,9999)
I STR["/S/" S STR=$P(STR,"/",1)_$E(HL("ECH"),4)_$P(STR,"/",3,9999)
G LP
;
DECHL7Q ; Exit
Q STR
;
SPAR ;Segment Parsing (logic from SPAR^IBCNEHLU)
;This tag will parse the current segment referenced by the HCT index
;and place the results in the IBSEG array.
;
;Input Variables
; HCT
;Output Variables
; IBSEG (ARRAY of fields in segment)
N II,IJ,IK,IM,IS,ISCT,ISDATA,ISEND,ISPEC,LSDATA,NPC
;
;Reset IBSEG
K IBSEG
;
S ISCT="",II=0,IS=0
F S ISCT=$O(^TMP("IBCNIUH1",$J,HCT,ISCT)) Q:ISCT="" D
. S IS=IS+1
. S ISDATA(IS)=$G(^TMP("IBCNIUH1",$J,HCT,ISCT))
. I $O(^TMP("IBCNIUH1",$J,HCT,ISCT))="" S ISDATA(IS)=ISDATA(IS)_HLFS
. S ISPEC(IS)=$L(ISDATA(IS),HLFS)
;
S IM=0,LSDATA=""
LP1 S IM=IM+1 Q:IM>IS
S LSDATA=LSDATA_ISDATA(IM),NPC=ISPEC(IM)
F IJ=1:1:NPC-1 D
. S II=II+1,IBSEG(II)=$$CLNSTR^IBCNEHLU($P(LSDATA,HLFS,IJ),$E(HL("ECH"),1,2)_$E(HL("ECH"),4),$E(HL("ECH")))
;
S LSDATA=$P(LSDATA,HLFS,NPC)
G LP1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNIUH1 12845 printed Sep 23, 2025@19:52:12 Page 2
IBCNIUH1 ;AITC/TAZ - IIU RECEIVE AND PROCESS INSURANCE TRANSMISSIONS ; 04/06/21 12:46p.m.
+1 ;;2.0;INTEGRATED BILLING;**687,702,804**;21-MAR-94;Build 6
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; ICR #2171 for the usage of $$IEN^XUAF4
+5 QUIT
+6 ;
+7 ;**Program Description**
+8 ; This routine is the driver routine for receiving an Interfacility Insurance Update message.
+9 ;
REC ;Receive data from remote system
+1 NEW BIN,CNT,COB,DFN,DOB,ECODE,EFFDT,ERFLG,ERROR,EVENT,FDATA,FLD
+2 NEW GNAME,GNUM,GT1,HLECH,HLFS,IBACK,IBDFA,IBPRTCL,ICN,IDLIST,IDUZ
+3 NEW IIUERR,IIUIEN,INAME,INSNAME,MSG,PATDFN,PATICN,PATID,PATNAME,PCN,PTYPE,REL
+4 NEW SEGCNT,SEGMT,SITE,STATUS,SUBC,SUBCID,SUBCNT,SUBCDATA,SUBCID,SUBID
+5 NEW VAID,WHOSE,XDFN
+6 ;
+7 ;Store the incoming message into a TMP global
+8 KILL ^TMP("IBCNIUH1",$JOB)
+9 SET ^TMP("IBCNIUH1",$JOB)=$$NOW^XLFDT
+10 FOR SEGCNT=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+11 SET CNT=0
+12 SET ^TMP("IBCNIUH1",$JOB,SEGCNT,CNT)=HLNODE
+13 FOR
SET CNT=$ORDER(HLNODE(CNT))
if 'CNT
QUIT
Begin DoDot:2
+14 SET ^TMP("IBCNIUH1",$JOB,SEGCNT,CNT)=HLNODE(CNT)
End DoDot:2
End DoDot:1
+15 ;
+16 ;Initialize the HL7 variables
+17 NEW HLCMP,HLECH,HLFS
+18 ;HL7 component separator
SET HLCMP=$EXTRACT(HL("ECH"))
+19 ;HL7 encoding characters
SET HLECH=HL("ECH")
+20 ;HL7 field separator
SET HLFS=HL("FS")
+21 ;
+22 ;Received HL7 message & save to file INTERFACILITY INSURANCE UPDATE (#365.19)
+23 DO RECEIVE
+24 IF $GET(IIUERR)!ERFLG
GOTO RECX
+25 ;
+26 DO GETSTAT
+27 IF IIUERR
GOTO RECX
+28 ;
+29 ; Attempt to file to the "Buffer", INSURANCE VERIFICATION PROCESSOR (#355.33)
+30 DO FILEBUF
+31 IF IIUERR
GOTO RECX
+32 ;
+33 ;Update the receiving STATUS of the IIU entry to "S" SAVED TO BUFFER
+34 SET STATUS="S"
+35 DO FILESTAT
+36 ;
RECX ;
+1 KILL ^TMP("IBCNIUH1",$JOB)
+2 KILL HLNEXT,HLNODE,HLQUIT
+3 QUIT
+4 ;
RECEIVE ;Entry Point
+1 NEW DATA,DFN,ERROR,HCT,IBDFDA,IBSEG,ICN,IENSTR,ISCT
+2 NEW SEG,STATUS,SUBC,SUBCDATA,SUBCID,SUBCNT,UPD,XDFN
+3 ;
+4 SET (ERFLG,GT1,IIUERR)=0
+5 ;
+6 SET HCT=0
FOR
SET HCT=$ORDER(^TMP("IBCNIUH1",$JOB,HCT))
if HCT=""
QUIT
Begin DoDot:1
+7 DO SPAR
+8 SET SEG=$GET(IBSEG(1))
+9 ;
+10 ; PRD segment carries no data to store
if SEG="PRD"
QUIT
+11 ;
+12 ;Message Segment
+13 IF SEG="MSH"
Begin DoDot:2
+14 ;SITE will get stored during the processing of the PID segment
+15 ;IB*702/CKB - get the IEN not the Site number of Sending/Originating VAMC
+16 SET SITE=$$IEN^XUAF4($PIECE($GET(IBSEG(4)),HLCMP))
End DoDot:2
QUIT
+17 ;
+18 ;Patient Segment
+19 IF SEG="PID"
Begin DoDot:2
+20 KILL DATA
+21 SET (ICN,DFN)=""
+22 SET IDLIST=$GET(IBSEG(4))
+23 FOR SUBCNT=1:1:$LENGTH(IDLIST,$EXTRACT(HLECH,2,2))
Begin DoDot:3
+24 SET SUBC=$PIECE(IDLIST,$EXTRACT(HLECH,2,2),SUBCNT)
+25 ; Identifier Type Code
SET SUBCID=$PIECE(SUBC,$EXTRACT(HLECH),5)
+26 ; Data Value
SET SUBCDATA=$PIECE(SUBC,$EXTRACT(HLECH),1)
+27 IF SUBCID="NI"
SET ICN=SUBCDATA
End DoDot:3
+28 ; Use ICN to find the patients DFN at this site
+29 IF ICN'=""
SET XDFN=$$GETDFN^MPIF001(ICN)
+30 IF +$GET(XDFN)'>0
IF +$GET(ICN)>0
SET ERFLG=1
QUIT
+31 ;
+32 IF +ICN>0
SET (PATDFN,DFN)=XDFN
+33 SET PATICN=SUBCDATA
+34 ; Get PATIENT NAME (if GT1, NAME OF INSURED). This is needed for the Duplicate Check, STATD.
+35 SET INAME=$GET(IBSEG(6))
+36 SET INAME=$$DECHL7($$FMNAME^HLFNC(INAME,HLECH))
+37 ;
+38 SET DATA(.01)=PATDFN
+39 SET DATA(.02)=$$NOW^XLFDT
+40 ;DIRECTION, R for RECEIVER
SET DATA(.03)="R"
+41 ; Create new entry in IIU File #365.19, get IEN
+42 SET IIUIEN=$$ADD^IBDFDBS(365.19,,.DATA)
+43 ; couldn't create record
IF 'IIUIEN
SET ERFLG=1
QUIT
+44 SET IBDFDA(1)=IIUIEN
+45 KILL DATA
+46 ;
+47 ; We got the variable SITE from the MSH segment
+48 ;ORIGINATING VAMC
SET DATA(.01)=SITE
+49 ;PATIENT'S ICN
SET DATA(.02)=PATICN
+50 ; Create new entry in IIU, ORIGINATING VAMC sub-file #365.192, get IBDFDA which = IEN
+51 SET IBDFDA=$$ADD^IBDFDBS(365.192,.IBDFDA,.DATA)
+52 ;Error Saving to the IIU file
IF 'IBDFDA
DO STATE
End DoDot:2
QUIT
+53 ;
+54 ;missing PID, abort process
IF '$GET(IIUIEN)
SET ERFLG=1
QUIT
+55 ;
+56 ;Guarantor Segment
+57 IF SEG="GT1"
Begin DoDot:2
+58 KILL DATA,ERROR,UPD
+59 SET GT1=1
+60 SET SUBID=$PIECE($GET(IBSEG(3)),HLCMP)
+61 SET INAME=$GET(IBSEG(4))
+62 SET INAME=$$DECHL7($$FMNAME^HLFNC(INAME,HLECH))
+63 ;
+64 ;NAME OF INSURED
SET DATA(1.02)=INAME
+65 ;SUBSCRIBER ID
SET DATA(1.03)=SUBID
+66 ;Update IIU file with data from GT1
+67 SET UPD=$$UPD^IBDFDBS(365.192,.IBDFDA,.DATA,.ERROR)
+68 ;Error Saving to the IIU file
IF ERROR=0
DO STATE
End DoDot:2
QUIT
+69 ;
+70 ;Insurance Segment
+71 IF SEG="IN1"
Begin DoDot:2
+72 KILL DATA,ERROR,UPD
+73 IF 'GT1
SET SUBID=$GET(IBSEG(3))
+74 IF GT1
SET PATID=$GET(IBSEG(3))
+75 SET VAID=$PIECE($GET(IBSEG(4)),HLCMP)
+76 SET INSNAME=$GET(IBSEG(5))
+77 SET INSNAME=$$DECHL7(INSNAME)
+78 SET GNUM=$$DECHL7($GET(IBSEG(9)))
+79 SET GNAME=$$DECHL7($GET(IBSEG(10)))
+80 SET EFFDT=$GET(IBSEG(13))
+81 SET EFFDT=$$FMDATE^HLFNC(EFFDT)
+82 SET PTYPE=$GET(IBSEG(16))
+83 SET REL=$GET(IBSEG(18))
+84 SET DOB=$GET(IBSEG(19))
+85 SET DOB=$$FMDATE^HLFNC(DOB)
+86 SET COB=$GET(IBSEG(23))
+87 ;
+88 ;INSURANCE COMPANY NAME
SET DATA(.03)=INSNAME
+89 ;GROUP NAME
SET DATA(.04)=GNAME
+90 ;GROUP NUMBER
SET DATA(.05)=GNUM
+91 ;PLAN TYPE
SET DATA(.08)=PTYPE
+92 ;EFFECTIVE DATE
SET DATA(.09)=EFFDT
+93 ;PT. RELATIONSHIP - HIPAA
SET DATA(.1)=REL
+94 ;INSURED'S DOB
SET DATA(1.04)=DOB
+95 ;COORDINATION OF BENEFITS
SET DATA(1.05)=COB
+96 ;PAYER'S VA NATIONAL ID
SET DATA(1.07)=VAID
+97 ;If not a Guarantor, the Patient ID is the same as the Subscriber ID
+98 ;PATIENT ID/SUBSCRIBER ID
IF 'GT1
SET DATA(1.01)=SUBID
SET DATA(1.03)=SUBID
+99 ;PATIENT ID
IF GT1
SET DATA(1.01)=PATID
+100 ;
+101 ;Update IIU file with data from IN1
+102 SET UPD=$$UPD^IBDFDBS(365.192,.IBDFDA,.DATA,.ERROR)
+103 ;Error Saving to the IIU file
IF ERROR=0
DO STATE
End DoDot:2
QUIT
+104 ;
+105 ;NTE Segment
+106 IF SEG="NTE"
Begin DoDot:2
+107 KILL DATA,ERROR,UPD
+108 SET WHOSE=$PIECE($GET(IBSEG(4)),HLCMP)
+109 SET BIN=$$DECHL7($PIECE($GET(IBSEG(4)),HLCMP,2))
+110 SET PCN=$$DECHL7($PIECE($GET(IBSEG(4)),HLCMP,3))
+111 ;
+112 ;BANKING IDENTIFICATION NUMBER
SET DATA(.06)=BIN
+113 ;PROCESSOR CONTROL NUMBER
SET DATA(.07)=PCN
+114 ;WHOSE INSURANCE
SET DATA(1.06)=WHOSE
+115 ;Update IIU file with data from NTE
+116 SET UPD=$$UPD^IBDFDBS(365.192,.IBDFDA,.DATA,.ERROR)
+117 ;error saving to the IIU file
IF ERROR=0
DO STATE
End DoDot:2
QUIT
End DoDot:1
if ERFLG
QUIT
+118 ;
+119 QUIT
+120 ;
GETSTAT ;Get the RECEIVER STATUS (365.19,2.01) by performing various checks
+1 SET IIUERR=0
+2 ;I=IIU ENABLED IS OFF
DO STATI
IF IIUERR=1
GOTO GETSTATQ
+3 ;R=RECEIVE IIU DATA IS OFF
DO STATR
IF IIUERR=1
GOTO GETSTATQ
+4 ;V=VISITED TOO LONG AGO
DO STATV
IF IIUERR=1
GOTO GETSTATQ
+5 ;D=DUPLICATE
DO STATD
IF IIUERR=1
GOTO GETSTATQ
+6 ;S=SAVED TO THE BUFFER
SET STATUS="S"
+7 ;
GETSTATQ ;
+1 ; files STATUS into #365.19
DO FILESTAT
+2 QUIT
+3 ;
FILEBUF ;File IIU data file #365.19 into the Buffer file #355.33
+1 NEW IBBUFDA,IBDATA,SOURCE
+2 ;
+3 SET SOURCE=$$FIND1^DIC(355.12,"","X","INTERFACILITY INS UPDATE","C")
+4 ;Get the non-human user
+5 SET IDUZ=$$FIND1^DIC(200,"","X","INTERFACE,IB IIU")
+6 ;Add a new buffer file entry (#355.33), sets only status (0) node data
+7 SET IBBUFDA=+$$ADD^IBCNBEE(SOURCE)
+8 ;There was an error saving the Buffer, set IIU RECEIVER STATUS to 'B' ERROR SAVING TO BUFFER
+9 IF (IDUZ="")!('IBBUFDA)
DO STATB
QUIT
+10 ;
+11 ;IB*804/DTG lock buffer entry
+12 ; Lock the buffer entry
+13 SET BUFLOCK=$$BUFLOCK^IBCNEHL6(IBBUFDA,1)
+14 ;
+15 ; Entered By
SET IBDATA(.02)=IDUZ
+16 ; Source of Information was set above in $$ADD^IBCNBEE
+17 ; Remote Location (the site that sent the IIU record)
SET IBDATA(.14)=SITE
+18 ; Insurance Company/Payer Name
SET IBDATA(20.01)=INSNAME
+19 ; Plan Type
SET IBDATA(40.09)=PTYPE
+20 ; Banking Identification Number
SET IBDATA(40.1)=BIN
+21 ; Processor Control Number
SET IBDATA(40.11)=PCN
+22 ; Patient IEN
SET IBDATA(60.01)=PATDFN
+23 ; Effective Date
SET IBDATA(60.02)=EFFDT
+24 ; Whose Insurance
SET IBDATA(60.05)=WHOSE
+25 ; Insured's DOB
SET IBDATA(60.08)=DOB
+26 ; Coordination of Benefits
SET IBDATA(60.12)=COB
+27 ; Patient Relationship
SET IBDATA(60.14)=REL
+28 ; Group Name
SET IBDATA(90.01)=GNAME
+29 ; Group Number
SET IBDATA(90.02)=GNUM
+30 ; Subscriber ID
SET IBDATA(90.03)=SUBID
+31 ;
+32 IF GT1
Begin DoDot:1
+33 ; Patient/Member ID
SET IBDATA(62.01)=$GET(PATID)
+34 ; Name of Insured
SET IBDATA(91.01)=INAME
End DoDot:1
+35 IF 'GT1
Begin DoDot:1
+36 ;If not a Guarantor, the Patient/Member ID is the same as the Subscriber ID
+37 ; Patient/Member ID
SET IBDATA(62.01)=SUBID
+38 ; Patient IEN
SET IBDATA(91.01)=PATDFN
End DoDot:1
+39 ;
+40 ;Add IBDATA to the buffer entry. EDITSTF ensures that Subscriber ID is saved to the buffer last.
+41 DO EDITSTF^IBCNBES(IBBUFDA,.IBDATA)
+42 ;Set buffer symbol to the buffer
+43 DO BUFF^IBCNEUT2(IBBUFDA,+$$INSERROR^IBCNEUT3("B",IBBUFDA))
+44 ;
+45 ;IB*804/DTG un-lock buffer entry
+46 ; remove Lock on the buffer entry
+47 NEW BUFLOCK
SET BUFLOCK=$$BUFLOCK^IBCNEHL6(IBBUFDA,0)
+48 ;
+49 ;Add BUFFER IEN to the IIU file
+50 NEW DATA,ERROR,UPD
+51 SET DATA(2.03)=IBBUFDA
+52 SET UPD=$$UPD^IBDFDBS(365.19,IIUIEN,.DATA,.ERROR)
+53 ;Error Saving to the Buffer
IF ERROR=0
DO STATB
+54 QUIT
+55 ;
STATI ;If the IIU ENABLED field is off, set RECEIVER STATUS to "I" IIU ENABLED IS OFF
+1 NEW IIUEN
+2 SET IIUEN=$$GET1^DIQ(350.9,"1,",53.02,"I")
+3 IF 'IIUEN
SET IIUERR=1
SET STATUS="I"
+4 QUIT
+5 ;
STATR ;If the RECEIVE IIU DATA is off, set RECEIVER STATUS to "R" RECEIVE IIU DATA IS OFF
+1 NEW PIEN,IIUARR,IIUIENS
+2 ; Get the Payer IEN
+3 SET PIEN=$ORDER(^IBE(365.12,"C",VAID,""))
+4 ; Get the IIU Payer data
+5 DO PAYER^IBCNINSU(PIEN,"IIU","*","E",.IIUARR)
+6 SET IIUIENS=$ORDER(IIUARR(365.121,""))
+7 ; Check field 5.01 RECEIVE IIU DATA for the Payer
+8 IF $GET(IIUARR(365.121,IIUIENS,5.01,"E"))'="YES"
SET IIUERR=1
SET STATUS="R"
+9 QUIT
+10 ;
STATV ;If the last event date is greater then the site parameter IIU RECENT VISIT DAYS,
+1 ; set RECEIVER STATUS to "V" VISITED TOO LONG AGO
+2 NEW IBS,IIUDAYS,LV,SITE
+3 ; Get current site
+4 ;IB*702 CKB - get the IEN not the Site number of Receiving VAMC
+5 SET IBS=$$IEN^XUAF4($PIECE($$SITE^VASITE,U,3))
+6 ; Get last visit
+7 IF $$TFL^IBCNIUF(PATDFN,.SITE,"R")
SET LV=$PIECE(SITE(IBS),U,3)
+8 ; If no last visit, set error and quit
+9 IF '$GET(LV)
SET IIUERR=1
SET STATUS="V"
GOTO STATVQ
+10 ; Get IIU RECENT VISIT DAYS
+11 SET IIUDAYS=$$GET1^DIQ(350.9,"1,",53.03,"I")
+12 ; Compare last visit to IIU RECENT VISIT DAYS
+13 IF +$GET(LV)
IF $$FMDIFF^XLFDT(DT,LV)>IIUDAYS
SET IIUERR=1
SET STATUS="V"
STATVQ ;
+1 QUIT
+2 ;
STATD ;Check for Duplicate IIU entry, if found set RECEIVER STATUS to "D" DUPLICATE
+1 KILL ^TMP("IBCNRDV",$JOB)
+2 ;
+3 ; Build index of Buffer entries and Insurance Type subfile entries.
+4 DO INDEX^IBCNRDV(PATDFN)
+5 ;
+6 ; Build array for checking
+7 NEW IBARY
+8 SET IBARY(20.01)=$GET(INSNAME)
+9 SET IBARY(40.03)=$GET(GNUM)
+10 SET IBARY(60.04)=$GET(SUBID)
+11 SET IBARY(60.07)=$PIECE($GET(INAME)," ",1)
+12 SET IBARY(60.08)=$GET(DOB)
+13 ;
+14 ;If Duplicate, set IIUERR and STATUS=D and quit
+15 IF $$DUP^IBCNRDV(.IBARY)
SET IIUERR=1
SET STATUS="D"
+16 ;
+17 KILL ^TMP("IBCNRDV",$JOB)
+18 QUIT
+19 ;
STATE ;If a error occurs during the creation of the entry into the IIU file (365.19),
+1 ;set RECEIVER STATUS to "E" ERROR SAVING TO IIU
+2 SET IIUERR=1
SET STATUS="E"
+3 DO FILESTAT
+4 QUIT
+5 ;
STATB ;If a error occurs during the creation of the entry into the Buffer file (355.33),
+1 ;set RECEIVER STATUS in the IIU file to "B" ERROR SAVING TO THE BUFFER
+2 SET IIUERR=1
SET STATUS="B"
+3 DO FILESTAT
+4 QUIT
+5 ;
FILESTAT ;File STATUS in File #365.19
+1 NEW DATA
+2 SET DATA(2.01)=STATUS
+3 IF $$UPD^IBDFDBS(365.19,IIUIEN,.DATA)
+4 QUIT
+5 ;
DECHL7(STR,HL) ;Decode HL7 characters
+1 ;INPUT:
+2 ; STR - String to be encoded
+3 ; HL - Array containing HL components returned from INIT^HLFNC2
+4 ;
+5 ; Returns an decoded string
+6 ; The encoded characters are:
+7 ; /F/ - Field Separator
+8 ; /C/ - Component Separator
+9 ; /R/ - Repetition Separator
+10 ; /E/ - Escape Character
+11 ; /S/ - Sub-component Separator
+12 ;
+13 ;NOTE: This tag uses RECURSION. Be careful how you edit it.
+14 ;
+15 ;Nothing to decode
IF STR']""
GOTO DECHL7Q
+16 ;No decoding characters defined
IF '$DATA(HL)
GOTO DECHL7Q
+17 ;
LP ;Continue to loop through the string until all instances of encoding is decoded then exit.
+1 IF STR'?.E1"/".A1"/".E
GOTO DECHL7Q
+2 IF STR["/F/"
SET STR=$PIECE(STR,"/",1)_HL("FS")_$PIECE(STR,"/",3,9999)
+3 IF STR["/C/"
SET STR=$PIECE(STR,"/",1)_$EXTRACT(HL("ECH"),1)_$PIECE(STR,"/",3,9999)
+4 IF STR["/R/"
SET STR=$PIECE(STR,"/",1)_$EXTRACT(HL("ECH"),2)_$PIECE(STR,"/",3,9999)
+5 IF STR["/E/"
SET STR=$PIECE(STR,"/",1)_$EXTRACT(HL("ECH"),3)_$PIECE(STR,"/",3,9999)
+6 IF STR["/S/"
SET STR=$PIECE(STR,"/",1)_$EXTRACT(HL("ECH"),4)_$PIECE(STR,"/",3,9999)
+7 GOTO LP
+8 ;
DECHL7Q ; Exit
+1 QUIT STR
+2 ;
SPAR ;Segment Parsing (logic from SPAR^IBCNEHLU)
+1 ;This tag will parse the current segment referenced by the HCT index
+2 ;and place the results in the IBSEG array.
+3 ;
+4 ;Input Variables
+5 ; HCT
+6 ;Output Variables
+7 ; IBSEG (ARRAY of fields in segment)
+8 NEW II,IJ,IK,IM,IS,ISCT,ISDATA,ISEND,ISPEC,LSDATA,NPC
+9 ;
+10 ;Reset IBSEG
+11 KILL IBSEG
+12 ;
+13 SET ISCT=""
SET II=0
SET IS=0
+14 FOR
SET ISCT=$ORDER(^TMP("IBCNIUH1",$JOB,HCT,ISCT))
if ISCT=""
QUIT
Begin DoDot:1
+15 SET IS=IS+1
+16 SET ISDATA(IS)=$GET(^TMP("IBCNIUH1",$JOB,HCT,ISCT))
+17 IF $ORDER(^TMP("IBCNIUH1",$JOB,HCT,ISCT))=""
SET ISDATA(IS)=ISDATA(IS)_HLFS
+18 SET ISPEC(IS)=$LENGTH(ISDATA(IS),HLFS)
End DoDot:1
+19 ;
+20 SET IM=0
SET LSDATA=""
LP1 SET IM=IM+1
if IM>IS
QUIT
+1 SET LSDATA=LSDATA_ISDATA(IM)
SET NPC=ISPEC(IM)
+2 FOR IJ=1:1:NPC-1
Begin DoDot:1
+3 SET II=II+1
SET IBSEG(II)=$$CLNSTR^IBCNEHLU($PIECE(LSDATA,HLFS,IJ),$EXTRACT(HL("ECH"),1,2)_$EXTRACT(HL("ECH"),4),$EXTRACT(HL("ECH")))
End DoDot:1
+4 ;
+5 SET LSDATA=$PIECE(LSDATA,HLFS,NPC)
+6 GOTO LP1
+7 QUIT
