IBCNEHL5 ;DALOI/KML - HL7 Process Incoming RPI Msgs (cont.) ; 1-APRIL-2013
;;2.0;INTEGRATED BILLING;**497,549,702,743,752**;21-MAR-94;Build 20
;;Per VA Directive 6402, this routine should not be modified.
;
;**Program Description**
Q ; No direct calls
;
GZRF(ERROR,IBSEG,RIEN) ; Process Group level ZRF Reference identification segment (x12 loops 2100C and 2100D)
;
; Input:
; IBSEG,RIEN
;
; Output:
; ERROR
;
N IENSTR,RSUPDT,QUAL,VALUE
S IENSTR="+1,"_RIEN_","
S RSUPDT(365.09,IENSTR,.01)=+$O(^IBCN(365,RIEN,9,"B",""),-1)+1 ; node 9 sequence #
; Reference id & qualifier
S QUAL=$P($G(IBSEG(3)),HLCMP),VALUE=$G(IBSEG(4))
I VALUE'="",QUAL'="" S RSUPDT(365.09,IENSTR,.02)=VALUE,RSUPDT(365.09,IENSTR,.03)=QUAL
S RSUPDT(365.09,IENSTR,.04)=$G(IBSEG(5)) ; Description
D CODECHK^IBCNEHLU(.RSUPDT) ;check for new coded values
D UPDATE^DIE("E","RSUPDT",,"ERROR")
Q
;
ZMP(ERROR,IBSEG,RIEN) ; Process Military Personnel Information that comes from X12 271 MPI segment of the 2100C and 2100D loops
;
; Input:
; IBSEG,RIEN
;
; Output:
; ERROR
;
N IENSTR,RSUPDT,QUAL,VALUE
S IENSTR=RIEN_","
S RSUPDT(365,IENSTR,12.01)=$G(IBSEG(3)) ; information status code
S RSUPDT(365,IENSTR,12.02)=$G(IBSEG(4)) ; employment status code
S RSUPDT(365,IENSTR,12.03)=$G(IBSEG(5)) ; government service affiliation code
S RSUPDT(365,IENSTR,12.04)=$G(IBSEG(6)) ; description
S RSUPDT(365,IENSTR,12.05)=$G(IBSEG(7)) ; Military service rank code
;Date time period format qualifier and Date time period
S QUAL=$P($G(IBSEG(8)),HLCMP),VALUE=$G(IBSEG(9))
I VALUE'="",QUAL'="" S RSUPDT(365,IENSTR,12.06)=QUAL,RSUPDT(365,IENSTR,12.07)=VALUE
D CODECHK^IBCNEHLU(.RSUPDT) ;check for new coded values
D UPDATE^DIE("E","RSUPDT",,"ERROR")
Q
;
ROL(ERROR,IBSEG,RIEN) ; process group level Provider Information in the X12 271 PRV segment of X12 loops: 2100B, 2100C, 2100D
;
; Input:
; IBSEG,RIEN
;
; Output:
; ERROR
;
N IENSTR,RSUPDT,QUAL,VALUE
S IENSTR="+1,"_RIEN_","
S RSUPDT(365.04,IENSTR,.01)=+$O(^IBCN(365,RIEN,10,"B",""),-1)+1 ; node 10 sequence #
S RSUPDT(365.04,IENSTR,.02)=$P($G(IBSEG(4)),HLCMP) ; provider code
S RSUPDT(365.04,IENSTR,.03)=$P($G(IBSEG(5)),HLCMP) ; reference ID
D CODECHK^IBCNEHLU(.RSUPDT) ;check for new coded values
D UPDATE^DIE("E","RSUPDT",,"ERROR")
Q
;
DG1(ERROR,IBSEG,RIEN) ; process DIAGNOSIS codes in the X12 271 HI segment of X12 loops: 2100C, 2100D
;
; Input:
; IBSEG,RIEN
;
; Output:
; ERROR
;
N IENSTR,RSUPDT,DCODE
S IENSTR="+1,"_RIEN_","
S RSUPDT(365.01,IENSTR,.01)=+$O(^IBCN(365,RIEN,11,"B",""),-1)+1 ; node 11 sequence #
S DCODE=$P($G(IBSEG(4)),HLCMP)
S RSUPDT(365.01,IENSTR,.02)=$E(DCODE,1,3)_"."_$E(DCODE,4,99) ; diagnosis code
S RSUPDT(365.01,IENSTR,.03)=$P($G(IBSEG(4)),HLCMP,3) ; diagnosis code qualifier
S RSUPDT(365.01,IENSTR,.04)=$S($P($G(IBSEG(16)),HLCMP)=1:"P",1:"S") ; primary or secondary diagnosis code
I $D(RSUPDT) D UPDATE^DIE("E","RSUPDT",,"ERROR")
Q
;
EBFILE(DFN,IEN312,RIEN,AFLG) ;EP
; File eligibility/benefit data from file 365 into file 2.312
; IB*2.0*549 moved method from IBCNEHL1 because of routine size limitations
; Input: DFN - Internal Patient IEN
; IEN312 - Insurance multiple #
; RIEN - file 365 ien
; AFLG - 1 if called from autoupdate
; 0 if called from ins. buffer process entry
; Returns: "" on success, ERFLG on failure. Also called from ACCEPT^IBCNBAR
; for manual processing of ins. buffer entry.
;
;
N DA,DIK,DATA,DATA1,EBIENS,ERFLG,ERROR,GIEN,GSKIP,IENROOT,IENS,IENSTR,TYPE,TYPE1,Z,Z1,Z2
; delete existing EB data
S DIK="^DPT("_DFN_",.312,"_IEN312_",6,",DA(2)=DFN,DA(1)=IEN312
S DA=0 F S DA=$O(^DPT(DFN,.312,IEN312,6,DA)) Q:DA=""!(DA?1.A) D ^DIK
;
; /IB*2.0*506 Beginning
; File the new Requested Service Date field (file #2.312,8.01) from the file #365,1.1 field,
; if the Service Date is not present, then use the Eligibility Date which would be from the file #365,1.11 field
; ALSO, file the new Requested Service Type field (file #2.312,8.02) from the file #365.02,.04 field.
N DIE,DR,NODE0,RSRVDT,RSTYPE,TQIEN
S TQIEN=$P($G(^IBCN(365,RIEN,0)),U,5),NODE0=$G(^IBCN(365.1,TQIEN,0))
S RSTYPE=$P(NODE0,U,20),RSRVDT=$P($G(^IBCN(365,RIEN,1)),U,10)
I RSRVDT="" S RSRVDT=$P(NODE0,U,12)
S DIE="^DPT("_DFN_",.312,",DA(1)=DFN,DA=IEN312
;
; IB*2.0*549 - File the pointer to the IIV RESPONSE (file 365)
D UPDT365(RIEN,IEN312_","_DFN_",")
;IB*752/DW-TAZ use //// for field 8.02 since /// changes the IEN of the code found in file #365.1
; to an IEN of another code since it treats it as an external value (corrupts data)
S DR="8.01///"_RSRVDT_";8.02////"_RSTYPE_";8.03///"_RIEN
D ^DIE
; /IB*2.0*506 End
;
; file new EB data
S IENSTR=IEN312_","_DFN_","
S GIEN=+$P($G(^DPT(DFN,.312,IEN312,0)),U,18)
S Z="" F S Z=$O(^IBCN(365,RIEN,2,"B",Z)) Q:Z=""!$G(ERFLG) D
.S EBIENS=$O(^IBCN(365,RIEN,2,"B",Z,""))_","_RIEN_","
.; if filing Medicare Part A/B data, make sure we only file the correct EB group
.S GSKIP=0 I GIEN>0 D
..S TYPE=$$GET1^DIQ(365.02,EBIENS,.05)
..S TYPE1=$P($G(^IBA(355.3,GIEN,0)),U,14)
..I TYPE="MA",TYPE1="B" S GSKIP=1
..I TYPE="MB",TYPE1="A" S GSKIP=1
..Q
.I GSKIP Q ; wrong Medicare Part A/B EB group - skip it
.D GETS^DIQ(365.02,EBIENS,"**",,"DATA","ERROR") I $D(ERROR) D:AFLG WARN^IBCNEHL3 Q
.; make sure we have data to file
.I '$D(DATA(365.02)) Q
.S IENS="+1,"_IENSTR,Z1=$O(DATA(365.02,"")) M DATA1(2.322,IENS)=DATA(365.02,Z1)
.D UPDATE^DIE("E","DATA1","IENROOT","ERROR") I $D(ERROR) D:AFLG WARN^IBCNEHL3 Q
.S IENS="+1,"_IENROOT(1)_","_IENSTR K DATA1,IENROOT
.S Z2="" F S Z2=$O(DATA(365.26,Z2)) Q:Z2=""!$G(ERFLG) D
..M DATA1(2.3226,IENS)=DATA(365.26,Z2) D UPDATE^DIE("E","DATA1",,"ERROR") K DATA1 I $D(ERROR) D:AFLG WARN^IBCNEHL3
..Q
.S Z2="" F S Z2=$O(DATA(365.27,Z2)) Q:Z2=""!$G(ERFLG) D
..M DATA1(2.3227,IENS)=DATA(365.27,Z2) D UPDATE^DIE("E","DATA1",,"ERROR") K DATA1 I $D(ERROR) D:AFLG WARN^IBCNEHL3
..Q
.S Z2="" F S Z2=$O(DATA(365.28,Z2)) Q:Z2=""!$G(ERFLG) D
..M DATA1(2.3228,IENS)=DATA(365.28,Z2) D UPDATE^DIE("E","DATA1",,"ERROR") K DATA1 I $D(ERROR) D:AFLG WARN^IBCNEHL3
..Q
.S Z2="" F S Z2=$O(DATA(365.29,Z2)) Q:Z2=""!$G(ERFLG) D
..M DATA1(2.3229,IENS)=DATA(365.29,Z2) D UPDATE^DIE("E","DATA1",,"ERROR") K DATA1 I $D(ERROR) D:AFLG WARN^IBCNEHL3
..Q
.S Z2="" F S Z2=$O(DATA(365.291,Z2)) Q:Z2=""!$G(ERFLG) D
..M DATA1(2.32291,IENS)=DATA(365.291,Z2) D UPDATE^DIE("E","DATA1",,"ERROR") K DATA1 I $D(ERROR) D:AFLG WARN^IBCNEHL3
..Q
.S Z2="" F S Z2=$O(DATA(365.292,Z2)) Q:Z2=""!$G(ERFLG) D
..M DATA1(2.32292,IENS)=DATA(365.292,Z2) D UPDATE^DIE("E","DATA1",,"ERROR") K DATA1 I $D(ERROR) D:AFLG WARN^IBCNEHL3
..Q
.K DATA
.Q
Q $G(ERFLG)
;
UPDT365(RIEN,IEN312) ; Sets the DO NOT PURGE flag in file 365
; Input: RIEN - IEN of the entry in file 365 to be set
; IEN312 - IENS of the Insurance multiple entry
; IB*2.0*549 added method
N DA,DIE,DR,XX
S XX=$$GET1^DIQ(2.312,IEN312,8.03,"I") ; Get current file 365 pointer
I XX'="" D ; Remove the DO NOT PURGE flag
. S DIE=365,DA=XX
. S DR=".11///0"
. D ^DIE
;
; Set the DO NOT PURGE Flag
S DIE=365,DA=RIEN
S DR=".11///1"
D ^DIE
Q
;
; IB*702/DTG - moved AUTOFIL from IBCNEHL1 for SAC space size.
AUTOFIL(DFN,IEN312,ISSUB) ;Finish processing the response message - file directly into patient insurance
;
N BUFF,DATA,ERROR,IENS,MIL,OKAY,PREL,RDATA0,RDATA1,RDATA5,RDATA13,RSTYPE,TQN,TSTAMP,XX ;IB*2*497 (vd)
N IBARR,IBIFN ;IB*702/DTG need for auto eiv user name
;
S TSTAMP=$$NOW^XLFDT(),IENS=IEN312_","_DFN_","
S RDATA0=$G(^IBCN(365,RIEN,0)),RDATA1=$G(^IBCN(365,RIEN,1)),RDATA5=$G(^IBCN(365,RIEN,5))
S RDATA13=$G(^IBCN(365,RIEN,13)) ;IB*2*497 (vd)
S TQN=$P(RDATA0,U,5),RSTYPE=$P(RDATA0,U,10)
;\Beginning IB*2*549 - Modified the following lines
S XX=$$GET1^DIQ(2.312,IENS,7.01,"I")
I ISSUB,XX="" S DATA(2.312,IENS,7.01)=$P(RDATA13,U) ;Name
S XX=$$GET1^DIQ(2.312,IENS,3.01,"I")
I XX="" S DATA(2.312,IENS,3.01)=$P(RDATA1,U,2) ;DOB
S XX=$$GET1^DIQ(2.312,IENS,3.05,"I")
I XX="" S DATA(2.312,IENS,3.05)=$P(RDATA1,U,3) ;SSN
S XX=$$GET1^DIQ(2.312,IENS,6,"I")
I ISSUB,XX="" S DATA(2.312,IENS,6)=$P(RDATA1,U,8) ;Whose insurance
;pt. relationship (365,8.01) IB*2*497 code from 365,8.01 needs evaluation & possible conversion
S PREL=$$GET1^DIQ(365,RIEN,8.01)
S XX=$$GET1^DIQ(2.312,IENS,4.03,"I")
I ISSUB,XX="",PREL'="" D
. S DATA(2.312,IENS,4.03)=$$PREL^IBCNEHLU(2.312,4.03,PREL)
;\End of IB*2*549 changes.
;
;Moved the setting of fields 1.03 through 1.06 plus 1.09
; persist the original Source of Information
;note: external values are used to populate DATA
I $$GET1^DIQ(2.312,IENS,1.09,"I")="" D
. S XX=$$GET1^DIQ(365.1,TQN_",1,",3.02)
. I XX="" S XX="eIV"
. S DATA(2.312,IENS,1.09)=XX
;
;Set Subscriber address Fields if none of the fields are currently defined
;\Beginning IB*2*549 - Modified the following lines
S XX=$$GET1^DIQ(2.312,IENS,3.06,"I") ;Current Ins Street Line 1
I XX="" D
. S XX=$$GET1^DIQ(2.312,IENS,3.07,"I") ;Current Ins Street Line 2
. Q:XX'=""
. S XX=$$GET1^DIQ(2.312,IENS,3.08,"I") ;Current Ins City
. Q:XX'=""
. S XX=$$GET1^DIQ(2.312,IENS,3.09,"I") ;Current Ins State
. Q:XX'=""
. S XX=$$GET1^DIQ(2.312,IENS,3.1,"I") ;Current Ins Zip
. Q:XX'=""
. S XX=$$GET1^DIQ(2.312,IENS,3.13,"I") ;Current Ins Country
. Q:XX'=""
. S XX=$$GET1^DIQ(2.312,IENS,3.14,"I") ;Current Ins Country Subdivision
. Q:XX'=""
. S DATA(2.312,IENS,3.06)=$P(RDATA5,U) ;Street line 1
. S DATA(2.312,IENS,3.07)=$P(RDATA5,U,2) ;Street line 2
. S DATA(2.312,IENS,3.08)=$P(RDATA5,U,3) ;City
. S DATA(2.312,IENS,3.09)=$P(RDATA5,U,4) ;State
. S DATA(2.312,IENS,3.1)=$P(RDATA5,U,5) ;Zip
. S DATA(2.312,IENS,3.13)=$P(RDATA5,U,6) ;Country
. S DATA(2.312,IENS,3.14)=$P(RDATA5,U,7) ;Country subdivision
;\End of IB*2*549 changes.
;
L +^DPT(DFN,.312,IEN312):15 I '$T D LCKERR^IBCNEHL3 D FIL^IBCNEHL1 Q
I $D(DATA) D FILE^DIE("ET","DATA","ERROR") ; make sure DATA has data
I $D(ERROR) D WARN^IBCNEHL3 K ERROR D FIL^IBCNEHL1 G AUTOFILX
K DATA
S DATA(2.312,IENS,1.03)=TSTAMP ;Date last verified
S DATA(2.312,IENS,1.04)=IBEIVUSR ;Last verified by ;IB*702/DTG - use variable for user name (auto update user)
S DATA(2.312,IENS,1.05)=TSTAMP ;Date last edited
S DATA(2.312,IENS,1.06)=IBEIVUSR ;Last edited by ;IB*702/DTG - use variable for user name (auto update user)
D FILE^DIE("ET","DATA","ERROR")
I $D(ERROR) D WARN^IBCNEHL3 G AUTOFILX
; set the insurance record IEN in the IIV Response file
;to track which policy was updated based on the response
D UPDIREC^IBCNEHL3(RIEN,IEN312)
; set the EIV AUTO-UPDATE in the response file to signal auto-update
K DATA
S DATA(365,RIEN_",",.13)="YES"
D FILE^DIE("ET","DATA")
;
;IB*2*497 file data at 2.312, 9, 10 & 11 subfiles; if error is produced update buffer entry & then quit processing
S ERFLG=$$GRPFILE^IBCNEHL1(DFN,IEN312,RIEN,1)
I $G(ERFLG) G AUTOFILX
;
;file new EB data
S ERFLG=$$EBFILE^IBCNEHL1(DFN,IEN312,RIEN,1)
I $G(ERFLG) G AUTOFILX ;bail out if something went wrong during filing of EB data
;
;update insurance record ien in transmission queue
D UPDIREC^IBCNEHL3(RIEN,IEN312)
;
;For an original response, set the Transmission Queue Status to 'Response Received' &
;update remaining retries to comm failure (5)
;IB*743/CKB - called earlier when saving the MSA segment
;I $G(RSTYPE)="O" D SST^IBCNEUT2(TQN,3),RSTA^IBCNEUT7(TQN)
;
;File Auto Updated policy in INTERFACILITY INSURANCE UPDATE File (#365.19)
; IBCNBAR added a field the param list when calling LOC^IBCNIUF. For consistency we added a 'null'.
D LOC^IBCNIUF(DFN,$$GET1^DIQ(2.312,IEN312_","_DFN_",",.01,"I"),IEN312,$$GET1^DIQ(365,RIEN_",",.13,"I"),"",$$GET1^DIQ(365.1,TQN_",",3.02,"E"),"")
;
;Get the buffer entry from the IIV RESPONSE File (#365)
S BUFF=+$P($G(^IBCN(365,RIEN,0)),U,4)
;
;IB*743/TAZ - If there is a Buffer entry associated with the Response and it is already processed,
; DO NOT touch/update files #355.33 or #355.36
I BUFF,$$GET1^DIQ(355.33,BUFF,.04,"I")'="E" G AUTOFILX
;
;Update the buffer status to ACCEPTED, then call DELDATA^IBCNBED so only the stub remains
I BUFF D
. D STATUS^IBCNBEE(BUFF,"A",0,0,0) ;update status to accepted
. ;IB*702/DTG - save auto update user to buffer
. S IBIFN=BUFF_"," K IBARR
. S IBARR(355.33,IBIFN,.06)=$G(IBEIVUSR)
. D FILE^DIE("E","IBARR") ;file with the 'E' allows for external input, name vs ien
. D DELDATA^IBCNBED(BUFF) ;delete buffer's insurance/patient data
. ;
; File data to #355.36 file.
N BUFF,ERROR,FDA,WE
S WE=$$GET1^DIQ(365.1,TQN_",",.1,"I")
S BUFF=$$GET1^DIQ(365,RIEN_",",.04,"I")
S FDA(355.36,"+1,",.01)=$$NOW^XLFDT ;Date Processed
S FDA(355.36,"+1,",.02)=$S("^5^6^"[(U_WE_U):3,"^1^2^"[(U_WE_U):1,1:"") ;"WE" Should never be 4 or 7 at this point
S FDA(355.36,"+1,",.03)=$$GET1^DIQ(365.1,TQN_",",3.02,"I") ;Source of Information
S FDA(355.36,"+1,",.04)=$$GET1^DIQ(365,RIEN_",",.13,"I") ;EIV Auto-Update
S FDA(355.36,"+1,",.05)=TQN ;EIV Inquiry
S FDA(355.36,"+1,",.06)=RIEN ;EIV Response
S FDA(355.36,"+1,",.07)=BUFF ;Buffer
S FDA(355.36,"+1,",.08)=WE ;Source of Request (Which Extract)
D UPDATE^DIE("","FDA",,"ERROR")
I $D(ERROR) D
. D MSG003^IBCNEMS1(.IBMSG,.ERROR,TQN,RIEN,BUFF)
. D MSG^IBCNEUT5($$MGRP^IBCNEUT5(),"eIV Problem: Error writing to the CREATION TO PROCESSING TRACKING File (#355.36)","IBMSG(")
;
AUTOFILX ;
L -^DPT(DFN,.312,IEN312)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNEHL5 13981 printed Mar 13, 2025@21:19:27 Page 2
IBCNEHL5 ;DALOI/KML - HL7 Process Incoming RPI Msgs (cont.) ; 1-APRIL-2013
+1 ;;2.0;INTEGRATED BILLING;**497,549,702,743,752**;21-MAR-94;Build 20
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;**Program Description**
+5 ; No direct calls
QUIT
+6 ;
GZRF(ERROR,IBSEG,RIEN) ; Process Group level ZRF Reference identification segment (x12 loops 2100C and 2100D)
+1 ;
+2 ; Input:
+3 ; IBSEG,RIEN
+4 ;
+5 ; Output:
+6 ; ERROR
+7 ;
+8 NEW IENSTR,RSUPDT,QUAL,VALUE
+9 SET IENSTR="+1,"_RIEN_","
+10 ; node 9 sequence #
SET RSUPDT(365.09,IENSTR,.01)=+$ORDER(^IBCN(365,RIEN,9,"B",""),-1)+1
+11 ; Reference id & qualifier
+12 SET QUAL=$PIECE($GET(IBSEG(3)),HLCMP)
SET VALUE=$GET(IBSEG(4))
+13 IF VALUE'=""
IF QUAL'=""
SET RSUPDT(365.09,IENSTR,.02)=VALUE
SET RSUPDT(365.09,IENSTR,.03)=QUAL
+14 ; Description
SET RSUPDT(365.09,IENSTR,.04)=$GET(IBSEG(5))
+15 ;check for new coded values
DO CODECHK^IBCNEHLU(.RSUPDT)
+16 DO UPDATE^DIE("E","RSUPDT",,"ERROR")
+17 QUIT
+18 ;
ZMP(ERROR,IBSEG,RIEN) ; Process Military Personnel Information that comes from X12 271 MPI segment of the 2100C and 2100D loops
+1 ;
+2 ; Input:
+3 ; IBSEG,RIEN
+4 ;
+5 ; Output:
+6 ; ERROR
+7 ;
+8 NEW IENSTR,RSUPDT,QUAL,VALUE
+9 SET IENSTR=RIEN_","
+10 ; information status code
SET RSUPDT(365,IENSTR,12.01)=$GET(IBSEG(3))
+11 ; employment status code
SET RSUPDT(365,IENSTR,12.02)=$GET(IBSEG(4))
+12 ; government service affiliation code
SET RSUPDT(365,IENSTR,12.03)=$GET(IBSEG(5))
+13 ; description
SET RSUPDT(365,IENSTR,12.04)=$GET(IBSEG(6))
+14 ; Military service rank code
SET RSUPDT(365,IENSTR,12.05)=$GET(IBSEG(7))
+15 ;Date time period format qualifier and Date time period
+16 SET QUAL=$PIECE($GET(IBSEG(8)),HLCMP)
SET VALUE=$GET(IBSEG(9))
+17 IF VALUE'=""
IF QUAL'=""
SET RSUPDT(365,IENSTR,12.06)=QUAL
SET RSUPDT(365,IENSTR,12.07)=VALUE
+18 ;check for new coded values
DO CODECHK^IBCNEHLU(.RSUPDT)
+19 DO UPDATE^DIE("E","RSUPDT",,"ERROR")
+20 QUIT
+21 ;
ROL(ERROR,IBSEG,RIEN) ; process group level Provider Information in the X12 271 PRV segment of X12 loops: 2100B, 2100C, 2100D
+1 ;
+2 ; Input:
+3 ; IBSEG,RIEN
+4 ;
+5 ; Output:
+6 ; ERROR
+7 ;
+8 NEW IENSTR,RSUPDT,QUAL,VALUE
+9 SET IENSTR="+1,"_RIEN_","
+10 ; node 10 sequence #
SET RSUPDT(365.04,IENSTR,.01)=+$ORDER(^IBCN(365,RIEN,10,"B",""),-1)+1
+11 ; provider code
SET RSUPDT(365.04,IENSTR,.02)=$PIECE($GET(IBSEG(4)),HLCMP)
+12 ; reference ID
SET RSUPDT(365.04,IENSTR,.03)=$PIECE($GET(IBSEG(5)),HLCMP)
+13 ;check for new coded values
DO CODECHK^IBCNEHLU(.RSUPDT)
+14 DO UPDATE^DIE("E","RSUPDT",,"ERROR")
+15 QUIT
+16 ;
DG1(ERROR,IBSEG,RIEN) ; process DIAGNOSIS codes in the X12 271 HI segment of X12 loops: 2100C, 2100D
+1 ;
+2 ; Input:
+3 ; IBSEG,RIEN
+4 ;
+5 ; Output:
+6 ; ERROR
+7 ;
+8 NEW IENSTR,RSUPDT,DCODE
+9 SET IENSTR="+1,"_RIEN_","
+10 ; node 11 sequence #
SET RSUPDT(365.01,IENSTR,.01)=+$ORDER(^IBCN(365,RIEN,11,"B",""),-1)+1
+11 SET DCODE=$PIECE($GET(IBSEG(4)),HLCMP)
+12 ; diagnosis code
SET RSUPDT(365.01,IENSTR,.02)=$EXTRACT(DCODE,1,3)_"."_$EXTRACT(DCODE,4,99)
+13 ; diagnosis code qualifier
SET RSUPDT(365.01,IENSTR,.03)=$PIECE($GET(IBSEG(4)),HLCMP,3)
+14 ; primary or secondary diagnosis code
SET RSUPDT(365.01,IENSTR,.04)=$SELECT($PIECE($GET(IBSEG(16)),HLCMP)=1:"P",1:"S")
+15 IF $DATA(RSUPDT)
DO UPDATE^DIE("E","RSUPDT",,"ERROR")
+16 QUIT
+17 ;
EBFILE(DFN,IEN312,RIEN,AFLG) ;EP
+1 ; File eligibility/benefit data from file 365 into file 2.312
+2 ; IB*2.0*549 moved method from IBCNEHL1 because of routine size limitations
+3 ; Input: DFN - Internal Patient IEN
+4 ; IEN312 - Insurance multiple #
+5 ; RIEN - file 365 ien
+6 ; AFLG - 1 if called from autoupdate
+7 ; 0 if called from ins. buffer process entry
+8 ; Returns: "" on success, ERFLG on failure. Also called from ACCEPT^IBCNBAR
+9 ; for manual processing of ins. buffer entry.
+10 ;
+11 ;
+12 NEW DA,DIK,DATA,DATA1,EBIENS,ERFLG,ERROR,GIEN,GSKIP,IENROOT,IENS,IENSTR,TYPE,TYPE1,Z,Z1,Z2
+13 ; delete existing EB data
+14 SET DIK="^DPT("_DFN_",.312,"_IEN312_",6,"
SET DA(2)=DFN
SET DA(1)=IEN312
+15 SET DA=0
FOR
SET DA=$ORDER(^DPT(DFN,.312,IEN312,6,DA))
if DA=""!(DA?1.A)
QUIT
DO ^DIK
+16 ;
+17 ; /IB*2.0*506 Beginning
+18 ; File the new Requested Service Date field (file #2.312,8.01) from the file #365,1.1 field,
+19 ; if the Service Date is not present, then use the Eligibility Date which would be from the file #365,1.11 field
+20 ; ALSO, file the new Requested Service Type field (file #2.312,8.02) from the file #365.02,.04 field.
+21 NEW DIE,DR,NODE0,RSRVDT,RSTYPE,TQIEN
+22 SET TQIEN=$PIECE($GET(^IBCN(365,RIEN,0)),U,5)
SET NODE0=$GET(^IBCN(365.1,TQIEN,0))
+23 SET RSTYPE=$PIECE(NODE0,U,20)
SET RSRVDT=$PIECE($GET(^IBCN(365,RIEN,1)),U,10)
+24 IF RSRVDT=""
SET RSRVDT=$PIECE(NODE0,U,12)
+25 SET DIE="^DPT("_DFN_",.312,"
SET DA(1)=DFN
SET DA=IEN312
+26 ;
+27 ; IB*2.0*549 - File the pointer to the IIV RESPONSE (file 365)
+28 DO UPDT365(RIEN,IEN312_","_DFN_",")
+29 ;IB*752/DW-TAZ use //// for field 8.02 since /// changes the IEN of the code found in file #365.1
+30 ; to an IEN of another code since it treats it as an external value (corrupts data)
+31 SET DR="8.01///"_RSRVDT_";8.02////"_RSTYPE_";8.03///"_RIEN
+32 DO ^DIE
+33 ; /IB*2.0*506 End
+34 ;
+35 ; file new EB data
+36 SET IENSTR=IEN312_","_DFN_","
+37 SET GIEN=+$PIECE($GET(^DPT(DFN,.312,IEN312,0)),U,18)
+38 SET Z=""
FOR
SET Z=$ORDER(^IBCN(365,RIEN,2,"B",Z))
if Z=""!$GET(ERFLG)
QUIT
Begin DoDot:1
+39 SET EBIENS=$ORDER(^IBCN(365,RIEN,2,"B",Z,""))_","_RIEN_","
+40 ; if filing Medicare Part A/B data, make sure we only file the correct EB group
+41 SET GSKIP=0
IF GIEN>0
Begin DoDot:2
+42 SET TYPE=$$GET1^DIQ(365.02,EBIENS,.05)
+43 SET TYPE1=$PIECE($GET(^IBA(355.3,GIEN,0)),U,14)
+44 IF TYPE="MA"
IF TYPE1="B"
SET GSKIP=1
+45 IF TYPE="MB"
IF TYPE1="A"
SET GSKIP=1
+46 QUIT
End DoDot:2
+47 ; wrong Medicare Part A/B EB group - skip it
IF GSKIP
QUIT
+48 DO GETS^DIQ(365.02,EBIENS,"**",,"DATA","ERROR")
IF $DATA(ERROR)
if AFLG
DO WARN^IBCNEHL3
QUIT
+49 ; make sure we have data to file
+50 IF '$DATA(DATA(365.02))
QUIT
+51 SET IENS="+1,"_IENSTR
SET Z1=$ORDER(DATA(365.02,""))
MERGE DATA1(2.322,IENS)=DATA(365.02,Z1)
+52 DO UPDATE^DIE("E","DATA1","IENROOT","ERROR")
IF $DATA(ERROR)
if AFLG
DO WARN^IBCNEHL3
QUIT
+53 SET IENS="+1,"_IENROOT(1)_","_IENSTR
KILL DATA1,IENROOT
+54 SET Z2=""
FOR
SET Z2=$ORDER(DATA(365.26,Z2))
if Z2=""!$GET(ERFLG)
QUIT
Begin DoDot:2
+55 MERGE DATA1(2.3226,IENS)=DATA(365.26,Z2)
DO UPDATE^DIE("E","DATA1",,"ERROR")
KILL DATA1
IF $DATA(ERROR)
if AFLG
DO WARN^IBCNEHL3
+56 QUIT
End DoDot:2
+57 SET Z2=""
FOR
SET Z2=$ORDER(DATA(365.27,Z2))
if Z2=""!$GET(ERFLG)
QUIT
Begin DoDot:2
+58 MERGE DATA1(2.3227,IENS)=DATA(365.27,Z2)
DO UPDATE^DIE("E","DATA1",,"ERROR")
KILL DATA1
IF $DATA(ERROR)
if AFLG
DO WARN^IBCNEHL3
+59 QUIT
End DoDot:2
+60 SET Z2=""
FOR
SET Z2=$ORDER(DATA(365.28,Z2))
if Z2=""!$GET(ERFLG)
QUIT
Begin DoDot:2
+61 MERGE DATA1(2.3228,IENS)=DATA(365.28,Z2)
DO UPDATE^DIE("E","DATA1",,"ERROR")
KILL DATA1
IF $DATA(ERROR)
if AFLG
DO WARN^IBCNEHL3
+62 QUIT
End DoDot:2
+63 SET Z2=""
FOR
SET Z2=$ORDER(DATA(365.29,Z2))
if Z2=""!$GET(ERFLG)
QUIT
Begin DoDot:2
+64 MERGE DATA1(2.3229,IENS)=DATA(365.29,Z2)
DO UPDATE^DIE("E","DATA1",,"ERROR")
KILL DATA1
IF $DATA(ERROR)
if AFLG
DO WARN^IBCNEHL3
+65 QUIT
End DoDot:2
+66 SET Z2=""
FOR
SET Z2=$ORDER(DATA(365.291,Z2))
if Z2=""!$GET(ERFLG)
QUIT
Begin DoDot:2
+67 MERGE DATA1(2.32291,IENS)=DATA(365.291,Z2)
DO UPDATE^DIE("E","DATA1",,"ERROR")
KILL DATA1
IF $DATA(ERROR)
if AFLG
DO WARN^IBCNEHL3
+68 QUIT
End DoDot:2
+69 SET Z2=""
FOR
SET Z2=$ORDER(DATA(365.292,Z2))
if Z2=""!$GET(ERFLG)
QUIT
Begin DoDot:2
+70 MERGE DATA1(2.32292,IENS)=DATA(365.292,Z2)
DO UPDATE^DIE("E","DATA1",,"ERROR")
KILL DATA1
IF $DATA(ERROR)
if AFLG
DO WARN^IBCNEHL3
+71 QUIT
End DoDot:2
+72 KILL DATA
+73 QUIT
End DoDot:1
+74 QUIT $GET(ERFLG)
+75 ;
UPDT365(RIEN,IEN312) ; Sets the DO NOT PURGE flag in file 365
+1 ; Input: RIEN - IEN of the entry in file 365 to be set
+2 ; IEN312 - IENS of the Insurance multiple entry
+3 ; IB*2.0*549 added method
+4 NEW DA,DIE,DR,XX
+5 ; Get current file 365 pointer
SET XX=$$GET1^DIQ(2.312,IEN312,8.03,"I")
+6 ; Remove the DO NOT PURGE flag
IF XX'=""
Begin DoDot:1
+7 SET DIE=365
SET DA=XX
+8 SET DR=".11///0"
+9 DO ^DIE
End DoDot:1
+10 ;
+11 ; Set the DO NOT PURGE Flag
+12 SET DIE=365
SET DA=RIEN
+13 SET DR=".11///1"
+14 DO ^DIE
+15 QUIT
+16 ;
+17 ; IB*702/DTG - moved AUTOFIL from IBCNEHL1 for SAC space size.
AUTOFIL(DFN,IEN312,ISSUB) ;Finish processing the response message - file directly into patient insurance
+1 ;
+2 ;IB*2*497 (vd)
NEW BUFF,DATA,ERROR,IENS,MIL,OKAY,PREL,RDATA0,RDATA1,RDATA5,RDATA13,RSTYPE,TQN,TSTAMP,XX
+3 ;IB*702/DTG need for auto eiv user name
NEW IBARR,IBIFN
+4 ;
+5 SET TSTAMP=$$NOW^XLFDT()
SET IENS=IEN312_","_DFN_","
+6 SET RDATA0=$GET(^IBCN(365,RIEN,0))
SET RDATA1=$GET(^IBCN(365,RIEN,1))
SET RDATA5=$GET(^IBCN(365,RIEN,5))
+7 ;IB*2*497 (vd)
SET RDATA13=$GET(^IBCN(365,RIEN,13))
+8 SET TQN=$PIECE(RDATA0,U,5)
SET RSTYPE=$PIECE(RDATA0,U,10)
+9 ;\Beginning IB*2*549 - Modified the following lines
+10 SET XX=$$GET1^DIQ(2.312,IENS,7.01,"I")
+11 ;Name
IF ISSUB
IF XX=""
SET DATA(2.312,IENS,7.01)=$PIECE(RDATA13,U)
+12 SET XX=$$GET1^DIQ(2.312,IENS,3.01,"I")
+13 ;DOB
IF XX=""
SET DATA(2.312,IENS,3.01)=$PIECE(RDATA1,U,2)
+14 SET XX=$$GET1^DIQ(2.312,IENS,3.05,"I")
+15 ;SSN
IF XX=""
SET DATA(2.312,IENS,3.05)=$PIECE(RDATA1,U,3)
+16 SET XX=$$GET1^DIQ(2.312,IENS,6,"I")
+17 ;Whose insurance
IF ISSUB
IF XX=""
SET DATA(2.312,IENS,6)=$PIECE(RDATA1,U,8)
+18 ;pt. relationship (365,8.01) IB*2*497 code from 365,8.01 needs evaluation & possible conversion
+19 SET PREL=$$GET1^DIQ(365,RIEN,8.01)
+20 SET XX=$$GET1^DIQ(2.312,IENS,4.03,"I")
+21 IF ISSUB
IF XX=""
IF PREL'=""
Begin DoDot:1
+22 SET DATA(2.312,IENS,4.03)=$$PREL^IBCNEHLU(2.312,4.03,PREL)
End DoDot:1
+23 ;\End of IB*2*549 changes.
+24 ;
+25 ;Moved the setting of fields 1.03 through 1.06 plus 1.09
+26 ; persist the original Source of Information
+27 ;note: external values are used to populate DATA
+28 IF $$GET1^DIQ(2.312,IENS,1.09,"I")=""
Begin DoDot:1
+29 SET XX=$$GET1^DIQ(365.1,TQN_",1,",3.02)
+30 IF XX=""
SET XX="eIV"
+31 SET DATA(2.312,IENS,1.09)=XX
End DoDot:1
+32 ;
+33 ;Set Subscriber address Fields if none of the fields are currently defined
+34 ;\Beginning IB*2*549 - Modified the following lines
+35 ;Current Ins Street Line 1
SET XX=$$GET1^DIQ(2.312,IENS,3.06,"I")
+36 IF XX=""
Begin DoDot:1
+37 ;Current Ins Street Line 2
SET XX=$$GET1^DIQ(2.312,IENS,3.07,"I")
+38 if XX'=""
QUIT
+39 ;Current Ins City
SET XX=$$GET1^DIQ(2.312,IENS,3.08,"I")
+40 if XX'=""
QUIT
+41 ;Current Ins State
SET XX=$$GET1^DIQ(2.312,IENS,3.09,"I")
+42 if XX'=""
QUIT
+43 ;Current Ins Zip
SET XX=$$GET1^DIQ(2.312,IENS,3.1,"I")
+44 if XX'=""
QUIT
+45 ;Current Ins Country
SET XX=$$GET1^DIQ(2.312,IENS,3.13,"I")
+46 if XX'=""
QUIT
+47 ;Current Ins Country Subdivision
SET XX=$$GET1^DIQ(2.312,IENS,3.14,"I")
+48 if XX'=""
QUIT
+49 ;Street line 1
SET DATA(2.312,IENS,3.06)=$PIECE(RDATA5,U)
+50 ;Street line 2
SET DATA(2.312,IENS,3.07)=$PIECE(RDATA5,U,2)
+51 ;City
SET DATA(2.312,IENS,3.08)=$PIECE(RDATA5,U,3)
+52 ;State
SET DATA(2.312,IENS,3.09)=$PIECE(RDATA5,U,4)
+53 ;Zip
SET DATA(2.312,IENS,3.1)=$PIECE(RDATA5,U,5)
+54 ;Country
SET DATA(2.312,IENS,3.13)=$PIECE(RDATA5,U,6)
+55 ;Country subdivision
SET DATA(2.312,IENS,3.14)=$PIECE(RDATA5,U,7)
End DoDot:1
+56 ;\End of IB*2*549 changes.
+57 ;
+58 LOCK +^DPT(DFN,.312,IEN312):15
IF '$TEST
DO LCKERR^IBCNEHL3
DO FIL^IBCNEHL1
QUIT
+59 ; make sure DATA has data
IF $DATA(DATA)
DO FILE^DIE("ET","DATA","ERROR")
+60 IF $DATA(ERROR)
DO WARN^IBCNEHL3
KILL ERROR
DO FIL^IBCNEHL1
GOTO AUTOFILX
+61 KILL DATA
+62 ;Date last verified
SET DATA(2.312,IENS,1.03)=TSTAMP
+63 ;Last verified by ;IB*702/DTG - use variable for user name (auto update user)
SET DATA(2.312,IENS,1.04)=IBEIVUSR
+64 ;Date last edited
SET DATA(2.312,IENS,1.05)=TSTAMP
+65 ;Last edited by ;IB*702/DTG - use variable for user name (auto update user)
SET DATA(2.312,IENS,1.06)=IBEIVUSR
+66 DO FILE^DIE("ET","DATA","ERROR")
+67 IF $DATA(ERROR)
DO WARN^IBCNEHL3
GOTO AUTOFILX
+68 ; set the insurance record IEN in the IIV Response file
+69 ;to track which policy was updated based on the response
+70 DO UPDIREC^IBCNEHL3(RIEN,IEN312)
+71 ; set the EIV AUTO-UPDATE in the response file to signal auto-update
+72 KILL DATA
+73 SET DATA(365,RIEN_",",.13)="YES"
+74 DO FILE^DIE("ET","DATA")
+75 ;
+76 ;IB*2*497 file data at 2.312, 9, 10 & 11 subfiles; if error is produced update buffer entry & then quit processing
+77 SET ERFLG=$$GRPFILE^IBCNEHL1(DFN,IEN312,RIEN,1)
+78 IF $GET(ERFLG)
GOTO AUTOFILX
+79 ;
+80 ;file new EB data
+81 SET ERFLG=$$EBFILE^IBCNEHL1(DFN,IEN312,RIEN,1)
+82 ;bail out if something went wrong during filing of EB data
IF $GET(ERFLG)
GOTO AUTOFILX
+83 ;
+84 ;update insurance record ien in transmission queue
+85 DO UPDIREC^IBCNEHL3(RIEN,IEN312)
+86 ;
+87 ;For an original response, set the Transmission Queue Status to 'Response Received' &
+88 ;update remaining retries to comm failure (5)
+89 ;IB*743/CKB - called earlier when saving the MSA segment
+90 ;I $G(RSTYPE)="O" D SST^IBCNEUT2(TQN,3),RSTA^IBCNEUT7(TQN)
+91 ;
+92 ;File Auto Updated policy in INTERFACILITY INSURANCE UPDATE File (#365.19)
+93 ; IBCNBAR added a field the param list when calling LOC^IBCNIUF. For consistency we added a 'null'.
+94 DO LOC^IBCNIUF(DFN,$$GET1^DIQ(2.312,IEN312_","_DFN_",",.01,"I"),IEN312,$$GET1^DIQ(365,RIEN_",",.13,"I"),"",$$GET1^DIQ(365.1,TQN_",",3.02,"E"),"")
+95 ;
+96 ;Get the buffer entry from the IIV RESPONSE File (#365)
+97 SET BUFF=+$PIECE($GET(^IBCN(365,RIEN,0)),U,4)
+98 ;
+99 ;IB*743/TAZ - If there is a Buffer entry associated with the Response and it is already processed,
+100 ; DO NOT touch/update files #355.33 or #355.36
+101 IF BUFF
IF $$GET1^DIQ(355.33,BUFF,.04,"I")'="E"
GOTO AUTOFILX
+102 ;
+103 ;Update the buffer status to ACCEPTED, then call DELDATA^IBCNBED so only the stub remains
+104 IF BUFF
Begin DoDot:1
+105 ;update status to accepted
DO STATUS^IBCNBEE(BUFF,"A",0,0,0)
+106 ;IB*702/DTG - save auto update user to buffer
+107 SET IBIFN=BUFF_","
KILL IBARR
+108 SET IBARR(355.33,IBIFN,.06)=$GET(IBEIVUSR)
+109 ;file with the 'E' allows for external input, name vs ien
DO FILE^DIE("E","IBARR")
+110 ;delete buffer's insurance/patient data
DO DELDATA^IBCNBED(BUFF)
+111 ;
End DoDot:1
+112 ; File data to #355.36 file.
+113 NEW BUFF,ERROR,FDA,WE
+114 SET WE=$$GET1^DIQ(365.1,TQN_",",.1,"I")
+115 SET BUFF=$$GET1^DIQ(365,RIEN_",",.04,"I")
+116 ;Date Processed
SET FDA(355.36,"+1,",.01)=$$NOW^XLFDT
+117 ;"WE" Should never be 4 or 7 at this point
SET FDA(355.36,"+1,",.02)=$SELECT("^5^6^"[(U_WE_U):3,"^1^2^"[(U_WE_U):1,1:"")
+118 ;Source of Information
SET FDA(355.36,"+1,",.03)=$$GET1^DIQ(365.1,TQN_",",3.02,"I")
+119 ;EIV Auto-Update
SET FDA(355.36,"+1,",.04)=$$GET1^DIQ(365,RIEN_",",.13,"I")
+120 ;EIV Inquiry
SET FDA(355.36,"+1,",.05)=TQN
+121 ;EIV Response
SET FDA(355.36,"+1,",.06)=RIEN
+122 ;Buffer
SET FDA(355.36,"+1,",.07)=BUFF
+123 ;Source of Request (Which Extract)
SET FDA(355.36,"+1,",.08)=WE
+124 DO UPDATE^DIE("","FDA",,"ERROR")
+125 IF $DATA(ERROR)
Begin DoDot:1
+126 DO MSG003^IBCNEMS1(.IBMSG,.ERROR,TQN,RIEN,BUFF)
+127 DO MSG^IBCNEUT5($$MGRP^IBCNEUT5(),"eIV Problem: Error writing to the CREATION TO PROCESSING TRACKING File (#355.36)","IBMSG(")
End DoDot:1
+128 ;
AUTOFILX ;
+1 LOCK -^DPT(DFN,.312,IEN312)
+2 QUIT
