IBCNEHLQ ;DAOU/ALA - HL7 RQI Message ;17-JUN-2002
;;2.0;INTEGRATED BILLING;**184,271,300,361,416,438,467,497,533,516,601,621,631,737**;21-MAR-94;Build 19
;;Per VA Directive 6402, this routine should not be modified.
;
;**Program Description**
; This routine builds an eIV Verification (RQI^I01) or
; Identification (RQI^I03) request
;
;**Modified by Date Reason
; DAOU/BHS 10/04/2002 Implementing Transmit SSN logic
; DAOU/DB 03/19/2004 Stripped dashes from SSN (PID, GT1)
;
EN ; Entry Point
; Variables
; HLFS = Field Separator
; DFN = Patient IEN
; PAYR = Payer IEN
; BUFF = Buffer IEN
; FRDT = Freshness Date
;
PID ; Patient Identification Segment
N VAFSTR,ICN,NM,I,PID11,EDQ,IBWHO,IBDOB,PID19
; IB*601 & IB*621 & IB*737: All changed the line(s) below - setting 'VAFSTR'
; IB*601 Added MBI check
; IB*621/HAN added check for EICD (EXT=4)
; IB*737/DJW Added QUERY check as EICD-I needs SSN, but not allowed for EICD-V.
S VAFSTR=",1,7,8,11,",DFN=+$G(DFN)
I $$MBICHK^IBCNEUT7(BUFF)!((EXT=4)&($G(QUERY)="I")) S VAFSTR=VAFSTR_"19,"
;
S PID=$$EN^VAFHLPID(DFN,VAFSTR,1)
;
S PID11=$P(PID,HLFS,12)
I PID11'="" D
. I $P(PID11,HLECH,1)="""""" S $P(PID11,HLECH,1)=""
. I $P(PID11,HLECH,2)="""""" S $P(PID11,HLECH,2)=""
. I $P(PID11,HLECH,3)="""""" S $P(PID11,HLECH,3)="UNKNOWN"
. S $P(PID,HLFS,12)=PID11
S PID19=$P(PID,HLFS,20)
; Encode special characters into Name and address pieces
; **NOTE: If $$EN^VAFHLPID should, in the future, return more than 11 pieces than the lines below may
; need to be modified as they currently expect 11 pieces to be returned.
I DFN D
.; try to get name of insured from NAME OF INSURED
.I ";1;5;6;7;"'[(";"_EXT_";"),$G(IRIEN)'="" D
.. S IBWHO=$P($G(^DPT(DFN,.312,IRIEN,0)),U,6)
.. I IBWHO'="",IBWHO'="v" Q
..;IB*2.0*601/DM for "self" appt extract, use patient's insurance insured DOB
.. S IBDOB=$$GET1^DIQ(2.312,IRIEN_","_DFN_",","INSURED'S DOB","I")
.. I IBDOB S $P(PID,HLFS,8)=$$HLDATE^HLFNC(IBDOB)
.. S NM=$P($G(^DPT(DFN,.312,IRIEN,7)),U,1)
.I ";1;5;6;7;"[(";"_EXT_";"),BUFF,$G(NM)="" D
.. S IBWHO=$P($G(^IBA(355.33,BUFF,60)),U,5)
.. I IBWHO'="",IBWHO'="v" Q
..;IB*2.0*601/DM for "self" buffer extract, use buff's insured DOB
..;otherwise, use patient's insurance insured DOB, otherwise use patient's DOB
.. S IBDOB=$$GET1^DIQ(355.33,BUFF_",","INSURED'S DOB","I")
.. I 'IBDOB,$G(IRIEN)'="" S IBDOB=$$GET1^DIQ(2.312,IRIEN_","_DFN_",","INSURED'S DOB","I")
.. I IBDOB S $P(PID,HLFS,8)=$$HLDATE^HLFNC(IBDOB)
.. S NM=$P($G(^IBA(355.33,BUFF,91)),U)
.I $G(NM)'="" S NM=$$HLNAME^HLFNC(NM,HLECH)
.; if unsuccessful, get patient name from 2/.01
.I $G(NM)="" D
..S NM("FILE")=2,NM("IENS")=DFN,NM("FIELD")=.01
..S NM=$$HLNAME^XLFNAME(.NM,"",$E(HLECH)),NM=$S(NM]"":NM,1:HLQ)
..Q
.S I=$L(NM,HLFS),NM=$$ENCHL7(NM),$P(PID,HLFS,6,5+I)=NM
.; IB*2.0*601
.S $P(PID,HLFS,20,99)=$$ENCHL7($P(PID,HLFS,20,99))
.S ICN=$P($G(^DPT(DFN,"MPI")),U,1)
.S $P(PID,HLFS,4)=ICN_HLECH_HLECH_HLECH_"USVHA"_HLECH_"NI"_HLECH_"~"_DFN_HLECH_HLECH_HLECH_"USVHA"_HLECH_"PI"_HLECH_$P($$SITE^VASITE,U,3)_HLECH
.Q
S FRDT=$$HLDATE^HLFNC($G(FRDT))
I PID19'="" S $P(PID,HLFS,13)="",$P(PID,HLFS,20)=PID19
I EXT'=4 S $P(PID,HLFS,34)=FRDT ; IB*2.0*621 Not for A1 transaction
Q
;
GT1 ; Guarantor Segment
N WHO,NM,IDOB,ISEX,SEX,RLIEN,PER,PLIEN,RDATA,IBSDATA,IBADDR
N EICDIIEN,IBFMIEN,IBTRKDTA ; IB*2.0*621/DM variables
;
S GT1=""
I $G(QUERY)="I" Q
;
; If the data was extracted from Buffer get specifics from Buffer file
I ";1;5;6;7;"[(";"_EXT_";") D
. S WHO=$P($G(^IBA(355.33,BUFF,60)),U,5)
. I WHO="v"!(WHO="") Q
. ;S NM=$P($G(^IBA(355.33,BUFF,60)),U,7),NM=$$NAME^IBCNEHLU(NM)
. S NM=$$GET1^DIQ(355.33,BUFF,91.01),NM=$$NAME^IBCNEHLU(NM) ;Get HIPAA data from new fields - IB*2*516
. S NM=$$HLNAME^HLFNC(NM,HLECH)
. S NM=$$ENCHL7(NM)
. S $P(GT1,HLFS,3)=NM_HLECH_HLECH_HLECH
. S IDOB=$P($G(^IBA(355.33,BUFF,60)),U,8),IDOB=$$HLDATE^HLFNC(IDOB)
. S $P(GT1,HLFS,8)=IDOB
. S $P(GT1,HLFS,2)=$$SCRUB($G(SUBID))_HLECH_HLECH_HLECH_HLECH_"HC"
. Q
;
; If the data was from the appointment extract, check Patient file, IB*2.0*621/DM
I EXT=2 D
. I IRIEN="" Q
. S WHO=$P($G(^DPT(DFN,.312,IRIEN,0)),U,6)
. I WHO="v"!(WHO="") Q
. ;S NM=$P($G(^DPT(DFN,.312,IRIEN,0)),U,17) ; WCJ;IB*2.0*497
. S NM=$P($G(^DPT(DFN,.312,IRIEN,7)),U,1) ; WCJ;IB*2.0*497
. S NM=$$HLNAME^HLFNC(NM,HLECH)
. S NM=$$ENCHL7(NM)
. S $P(GT1,HLFS,3)=NM_HLECH_HLECH_HLECH
. S IDOB=$P($G(^DPT(DFN,.312,IRIEN,3)),U,1),IDOB=$$HLDATE^HLFNC(IDOB)
. S $P(GT1,HLFS,8)=IDOB
. S $P(GT1,HLFS,2)=$$SCRUB($G(SUBID))_HLECH_HLECH_HLECH_HLECH_"HC"
. ;
. S IBSDATA=$G(^DPT(DFN,.312,IRIEN,3))
. S IBADDR=$$HLADDR^HLFNC($P(IBSDATA,U,6,7),$P(IBSDATA,U,8,10))
. S $P(GT1,HLFS,5)=$$ENCHL7(IBADDR)
. ;
. D CHK
. I $P(GT1,HLFS,8)=""&(IDOB'="") S $P(GT1,HLFS,8)=$$HLDATE^HLFNC(IDOB)
. I $P(GT1,HLFS,9)=""&(ISEX'="") S $P(GT1,HLFS,9)=ISEX
. I $P(GT1,HLFS,9)="",WHO="s" D
.. S SEX=$P($G(^DPT(DFN,.312,IRIEN,3)),U,12) ; get policy holder sex
.. I SEX="" S SEX=$P(^DPT(DFN,0),U,2),SEX=$S(SEX="M":"F",1:"M") ; if null, use alternative method
.. S $P(GT1,HLFS,9)=SEX
;
; IB*2.0*621/DM add EICD Verification, use data from EIV EICD TRACKING (#365.18)
I EXT=4,$G(QUERY)="V" D
. S EICDIIEN=+$O(^IBCN(365.18,"C",IEN,0)) ; IEN is the TQ from IBCNEDEP
. I ('EICDIIEN)!(EICDVIEN="") Q
. S IBFMIEN=EICDVIEN_","_EICDIIEN_","
. K IBTRKDTA D GETS^DIQ(365.185,IBFMIEN,".04;.07;.08;.09","I","IBTRKDTA") ; grab selected fields (internal)
. ;
. S NM=IBTRKDTA(365.185,IBFMIEN,.09,"I")
. Q:NM="" ; no name means subscriber -- GT1 is not needed
. S NM=$$HLNAME^HLFNC(NM,HLECH)
. S NM=$$ENCHL7(NM)
. S $P(GT1,HLFS,3)=NM_HLECH_HLECH_HLECH
. S IDOB=IBTRKDTA(365.185,IBFMIEN,.07,"I"),IDOB=$$HLDATE^HLFNC(IDOB)
. S $P(GT1,HLFS,8)=IDOB
. ; Subscriber ID -- Guarantor Number
. S $P(GT1,HLFS,2)=$$SCRUB(IBTRKDTA(365.185,IBFMIEN,.04,"I"))_HLECH_HLECH_HLECH_HLECH_"HC"
. ; skip address data
. S ISEX=IBTRKDTA(365.185,IBFMIEN,.08,"I")
. I $P(GT1,HLFS,8)=""&(IDOB'="") S $P(GT1,HLFS,8)=$$HLDATE^HLFNC(IDOB)
. I $P(GT1,HLFS,9)=""&(ISEX'="") S $P(GT1,HLFS,9)=ISEX
;
I GT1="" Q
S $P(GT1,HLFS,1)=1
S GT1="GT1"_HLFS_GT1
Q
;
IN1 ; Insurance Segment
N EFFDT,ELIGDT,EXPDT,PREL,ADMN,ADMDT,IENS
N EICDIIEN,IBFMIEN,IBPYIEN,IBTRKDTA ; IB*2.0*621/DM variables
S IN1=""
;
; If the data was extracted from Buffer get specifics from Buffer file
I ";1;5;6;7;"[(";"_EXT_";") D
.S PREL=$P($G(^IBA(355.33,BUFF,60)),U,14)
.S ELIGDT=$P($G(TRANSR),U,12) I ELIGDT=DT S ELIGDT=""
.S $P(IN1,HLFS,2)=$S(PREL=18:$$SCRUB($G(SUBID)),PREL="":$$SCRUB($G(SUBID)),1:$$SCRUB($G(PATID)))
.S $P(IN1,HLFS,3)=$$ENCHL7($P(^IBE(365.12,PAYR,0),U,2))_HLECH_HLECH_HLECH_"USVHA"_HLECH_"VP"_HLECH
.S $P(IN1,HLFS,4)=$$ENCHL7($P(^IBE(365.12,PAYR,0),U,1))
. ;IB*2.0*516/TAZ - Use HIPAA compliant fields
.;S $P(IN1,HLFS,8)=$$ENCHL7($P($G(^IBA(355.33,BUFF,40)),U,3))
.;S $P(IN1,HLFS,9)=$$ENCHL7($P($G(^IBA(355.33,BUFF,40)),U,2))
.S $P(IN1,HLFS,8)=$$ENCHL7($$GET1^DIQ(355.33,BUFF_",",90.02))
.S $P(IN1,HLFS,9)=$$ENCHL7($$GET1^DIQ(355.33,BUFF_",",90.01))
.S EFFDT=$P($G(^IBA(355.33,BUFF,60)),U,2),EFFDT=$$HLDATE^HLFNC(EFFDT)
.S EXPDT=$P($G(^IBA(355.33,BUFF,60)),U,3),EXPDT=$$HLDATE^HLFNC(EXPDT)
.S $P(IN1,HLFS,12)=EFFDT
.S $P(IN1,HLFS,13)=EXPDT
.S $P(IN1,HLFS,17)=$$PATREL(PREL)
.S $P(IN1,HLFS,26)=$$HLDATE^HLFNC(ELIGDT)
.I $P(IN1,HLFS,17)="" S $P(IN1,HLFS,17)=18
;
; If the data was from the appointment extract, check Patient file, IB*2.0*621/DM
I EXT=2 D
. I IRIEN="" Q
. I $$SCRUB($G(SUBID))'=$$SCRUB($P($G(^DPT(DFN,.312,IRIEN,0)),U,2)) Q
. S EFFDT=$P($G(^DPT(DFN,.312,IRIEN,0)),U,8),EFFDT=$$HLDATE^HLFNC(EFFDT)
. S EXPDT=$P($G(^DPT(DFN,.312,IRIEN,0)),U,4),EXPDT=$$HLDATE^HLFNC(EXPDT)
. S $P(IN1,HLFS,12)=EFFDT
. S $P(IN1,HLFS,13)=EXPDT
. S PREL=$P($G(^DPT(DFN,.312,IRIEN,4)),U,3)
. S $P(IN1,HLFS,2)=$S(PREL=18:$$SCRUB($G(SUBID)),PREL="":$$SCRUB($G(SUBID)),1:$$SCRUB($G(PATID)))
. S $P(IN1,HLFS,3)=$$ENCHL7($P(^IBE(365.12,PAYR,0),U,2))_HLECH_HLECH_HLECH_"USVHA"_HLECH_"VP"_HLECH
. S $P(IN1,HLFS,4)=$$ENCHL7($P(^IBE(365.12,PAYR,0),U,1))
. S $P(IN1,HLFS,17)=$$PATREL(PREL)
. S IENS=IRIEN_","_DFN_","
. S $P(IN1,HLFS,8)=$$ENCHL7($$GET1^DIQ(2.312,IENS,21,"E"))
. S $P(IN1,HLFS,9)=$$ENCHL7($$GET1^DIQ(2.312,IENS,20,"E"))
. I $P(IN1,HLFS,17)="" S $P(IN1,HLFS,17)=18
;
; IB*2.0*621/DM add EICD Verification, use data from EIV EICD TRACKING (#365.18)
I EXT=4,$G(QUERY)="V" D
. S EICDIIEN=+$O(^IBCN(365.18,"C",IEN,0)) ; IEN is the TQ from IBCNEDEP
. I ('EICDIIEN)!(EICDVIEN="") Q
. S IBFMIEN=EICDVIEN_","_EICDIIEN_","
. K IBTRKDTA D GETS^DIQ(365.185,IBFMIEN,".01;.03;.05;.09","I","IBTRKDTA") ; grab selected fields (internal)
. ;
. S PREL="18" ; means self/veteran
. S:IBTRKDTA(365.185,IBFMIEN,.09,"I")'="" PREL="" ; not subscriber
. S $P(IN1,HLFS,2)=IBTRKDTA(365.185,IBFMIEN,.05,"I")
. S $P(IN1,HLFS,3)=$$ENCHL7(IBTRKDTA(365.185,IBFMIEN,.01,"I"))_HLECH_HLECH_HLECH_"USVHA"_HLECH_"VP"_HLECH ; PAYER VA ID
. S IBPYIEN=+$$FIND1^DIC(365.12,,"QX",IBTRKDTA(365.185,IBFMIEN,.01,"I"),"C") ; PAYER IEN
. S $P(IN1,HLFS,4)=$$ENCHL7($$GET1^DIQ(365.12,IBPYIEN_",",.01)) ; PAYER NAME
. S $P(IN1,HLFS,17)=$$PATREL(PREL)
. S $P(IN1,HLFS,8)=IBTRKDTA(365.185,IBFMIEN,.03,"I") ; GROUP NUMBER
I IN1="" Q
;
S $P(IN1,HLFS,1)=1
S IN1="IN1"_HLFS_IN1
Q
;
NTE(CTR) ; NTE Segment
N EICDIIEN
; TRANSR is 0 node of TQ, set in PROC^IBCNEDEP
I CTR=1 S NTE=$$EXTERNAL^DILFD(365.1,.2,,$P($G(TRANSR),U,20)) ; service code from 365.1/.2
; IB*2.0*601 - Added NTE2 and NTE3
I CTR=2 D
. S NTE=$$GET1^DIQ(365.1,IEN_",","SOURCE OF INFORMATION","I") ; IEN = ien of TQ
. S NTE=$$GET1^DIQ(355.12,NTE_",","IB BUFFER ACRONYM")
; IB*2.0*631/TAZ restructure NTE(3)
I CTR=3 D
. N TYPE,WHICH
. S NTE=$S(((EXT=4)&(QUERY="I")):"OHI",$$MBICHK^IBCNEUT7(BUFF):"MBI",1:"ELI") ; IB*2.0*621
. S WHICH=$$GET1^DIQ(365.1,IEN_",",.1,"I") ;WHICH EXTRACT
. S TYPE="" D
.. I $$GET1^DIQ(365.1,IEN_",",.04)="Retry" S TYPE="RETRY" Q
.. I WHICH=1 S TYPE="BUFFER" Q
.. I WHICH=2 S TYPE="APPT" Q
.. I EXT=4 D Q
... I QUERY="I" S TYPE="EICD-I" Q
... S TYPE="EICD-V"
.. I WHICH=5 S TYPE="REQUEST ELECTRONIC" Q
.. I WHICH=6 S TYPE="ICB/VISTA" Q
.. I WHICH=7 S TYPE="MBI REQUEST"
. S NTE=NTE_"~"_TYPE
; IB*2.0*621
I CTR=4 S NTE="" ; Reporting of known insurance information will happen at a later release
I CTR=5 S NTE=""
I CTR=5,EXT=4,QUERY="V" D
. ; on EICD Verifications, pass the TRACE # from the associated EICD Inquiry
. S EICDIIEN=+$O(^IBCN(365.18,"C",IEN,0)) ; IEN is the TQ from IBCNEDEP
. S NTE=$$GET1^DIQ(365.18,EICDIIEN_",",.04,"I") ; EICD TRACE NUMBER
S NTE="NTE"_HLFS_CTR_HLFS_HLFS_NTE
K CTR
Q
;
CHK ; Check for spouse or other information in the Patient Relation File
; DGREL = Relationship (1=Self, 2=Spouse, 3-34,99=Other)
NEW IEN,QFL
S IEN="",RLIEN="",ISEX="",QFL=0
F S IEN=$O(^DGPR(408.12,"B",DFN,IEN)) Q:IEN="" D Q:QFL
. S DGREL=$P($G(^DGPR(408.12,IEN,0)),U,2)
. ;
. ; If person is veteran, quit
. I DGREL=1 Q
. ;
. ; If person is spouse, pick that record and quit
. I WHO="s",DGREL=2 S RLIEN=IEN,QFL=1 Q
. ;
. ; Otherwise it should be an 'other' dependent
. S RLIEN=IEN
;
I RLIEN="" Q
;
; Check for Sex, SSN, DOB in INCOME PERSON File
S PER=$P(^DGPR(408.12,RLIEN,0),U,3)
I PER'["DGPR(408.13" Q
S PLIEN=$P(PER,";",1)
I PLIEN="" Q
S RDATA=$G(^DGPR(408.13,PLIEN,0)),ISEX=$P(RDATA,U,2),IDOB=$P(RDATA,U,3)
I $P(RDATA,U,4)'="" N DFN S DFN=$P(RDATA,U,4),ISEX=$P(^DPT(DFN,0),U,2),IDOB=$P(^DPT(DFN,0),U,3)
Q
;
ENCHL7(STR) ; Encode HL7 escape seqs in data fields
;
; Input:
; STR = Field data possible containing HL7 encoding chars
;
; Output Values
; Fn returns string w/converted escape seqs
;
N CHR,NEW,RPLC,CNT,LOOP
;
; Replace "\" "&" "~" "|" with \F\ \R\ \E\ \T\ respectively
F CHR="\","&","~","|" S CNT=$L(STR,CHR) I CNT>1 D
. S NEW=$P(STR,CHR)
. S RPLC="\"_$TR(CHR,"|~\&","FRET")_"\"
. F LOOP=2:1:CNT S NEW=NEW_RPLC_$P(STR,CHR,LOOP)
. S STR=NEW
;
Q STR
;
SCRUB(Z) ; remove all punctuation from the string and convert lowercase to uppercase
; IB*2*416 - used for subscriber and patient ID fields
S Z=$$NOPUNCT^IBCEF(Z,1)
S Z=$$UP^XLFSTR(Z)
SCRUBX ;
Q Z
;
PATREL(REL) ; convert pat.relationship to insured from VistA to X12 and return X12 value
; REL - VistA value
;
; VistA values of Self (18), Spouse (01), and Child (19) remain unchanged,
; anything else is converted to X12 value of Other Adult (34)
;
Q $S($G(REL)="":"",".01.18.19."[("."_REL_"."):REL,1:34)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNEHLQ 12798 printed Apr 09, 2024@21:17:48 Page 2
IBCNEHLQ ;DAOU/ALA - HL7 RQI Message ;17-JUN-2002
+1 ;;2.0;INTEGRATED BILLING;**184,271,300,361,416,438,467,497,533,516,601,621,631,737**;21-MAR-94;Build 19
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;**Program Description**
+5 ; This routine builds an eIV Verification (RQI^I01) or
+6 ; Identification (RQI^I03) request
+7 ;
+8 ;**Modified by Date Reason
+9 ; DAOU/BHS 10/04/2002 Implementing Transmit SSN logic
+10 ; DAOU/DB 03/19/2004 Stripped dashes from SSN (PID, GT1)
+11 ;
EN ; Entry Point
+1 ; Variables
+2 ; HLFS = Field Separator
+3 ; DFN = Patient IEN
+4 ; PAYR = Payer IEN
+5 ; BUFF = Buffer IEN
+6 ; FRDT = Freshness Date
+7 ;
PID ; Patient Identification Segment
+1 NEW VAFSTR,ICN,NM,I,PID11,EDQ,IBWHO,IBDOB,PID19
+2 ; IB*601 & IB*621 & IB*737: All changed the line(s) below - setting 'VAFSTR'
+3 ; IB*601 Added MBI check
+4 ; IB*621/HAN added check for EICD (EXT=4)
+5 ; IB*737/DJW Added QUERY check as EICD-I needs SSN, but not allowed for EICD-V.
+6 SET VAFSTR=",1,7,8,11,"
SET DFN=+$GET(DFN)
+7 IF $$MBICHK^IBCNEUT7(BUFF)!((EXT=4)&($GET(QUERY)="I"))
SET VAFSTR=VAFSTR_"19,"
+8 ;
+9 SET PID=$$EN^VAFHLPID(DFN,VAFSTR,1)
+10 ;
+11 SET PID11=$PIECE(PID,HLFS,12)
+12 IF PID11'=""
Begin DoDot:1
+13 IF $PIECE(PID11,HLECH,1)=""""""
SET $PIECE(PID11,HLECH,1)=""
+14 IF $PIECE(PID11,HLECH,2)=""""""
SET $PIECE(PID11,HLECH,2)=""
+15 IF $PIECE(PID11,HLECH,3)=""""""
SET $PIECE(PID11,HLECH,3)="UNKNOWN"
+16 SET $PIECE(PID,HLFS,12)=PID11
End DoDot:1
+17 SET PID19=$PIECE(PID,HLFS,20)
+18 ; Encode special characters into Name and address pieces
+19 ; **NOTE: If $$EN^VAFHLPID should, in the future, return more than 11 pieces than the lines below may
+20 ; need to be modified as they currently expect 11 pieces to be returned.
+21 IF DFN
Begin DoDot:1
+22 ; try to get name of insured from NAME OF INSURED
+23 IF ";1;5;6;7;"'[(";"_EXT_";")
IF $GET(IRIEN)'=""
Begin DoDot:2
+24 SET IBWHO=$PIECE($GET(^DPT(DFN,.312,IRIEN,0)),U,6)
+25 IF IBWHO'=""
IF IBWHO'="v"
QUIT
+26 ;IB*2.0*601/DM for "self" appt extract, use patient's insurance insured DOB
+27 SET IBDOB=$$GET1^DIQ(2.312,IRIEN_","_DFN_",","INSURED'S DOB","I")
+28 IF IBDOB
SET $PIECE(PID,HLFS,8)=$$HLDATE^HLFNC(IBDOB)
+29 SET NM=$PIECE($GET(^DPT(DFN,.312,IRIEN,7)),U,1)
End DoDot:2
+30 IF ";1;5;6;7;"[(";"_EXT_";")
IF BUFF
IF $GET(NM)=""
Begin DoDot:2
+31 SET IBWHO=$PIECE($GET(^IBA(355.33,BUFF,60)),U,5)
+32 IF IBWHO'=""
IF IBWHO'="v"
QUIT
+33 ;IB*2.0*601/DM for "self" buffer extract, use buff's insured DOB
+34 ;otherwise, use patient's insurance insured DOB, otherwise use patient's DOB
+35 SET IBDOB=$$GET1^DIQ(355.33,BUFF_",","INSURED'S DOB","I")
+36 IF 'IBDOB
IF $GET(IRIEN)'=""
SET IBDOB=$$GET1^DIQ(2.312,IRIEN_","_DFN_",","INSURED'S DOB","I")
+37 IF IBDOB
SET $PIECE(PID,HLFS,8)=$$HLDATE^HLFNC(IBDOB)
+38 SET NM=$PIECE($GET(^IBA(355.33,BUFF,91)),U)
End DoDot:2
+39 IF $GET(NM)'=""
SET NM=$$HLNAME^HLFNC(NM,HLECH)
+40 ; if unsuccessful, get patient name from 2/.01
+41 IF $GET(NM)=""
Begin DoDot:2
+42 SET NM("FILE")=2
SET NM("IENS")=DFN
SET NM("FIELD")=.01
+43 SET NM=$$HLNAME^XLFNAME(.NM,"",$EXTRACT(HLECH))
SET NM=$SELECT(NM]"":NM,1:HLQ)
+44 QUIT
End DoDot:2
+45 SET I=$LENGTH(NM,HLFS)
SET NM=$$ENCHL7(NM)
SET $PIECE(PID,HLFS,6,5+I)=NM
+46 ; IB*2.0*601
+47 SET $PIECE(PID,HLFS,20,99)=$$ENCHL7($PIECE(PID,HLFS,20,99))
+48 SET ICN=$PIECE($GET(^DPT(DFN,"MPI")),U,1)
+49 SET $PIECE(PID,HLFS,4)=ICN_HLECH_HLECH_HLECH_"USVHA"_HLECH_"NI"_HLECH_"~"_DFN_HLECH_HLECH_HLECH_"USVHA"_HLECH_"PI"_HLECH_$PIECE($$SITE^VASITE,U,3)_HLECH
+50 QUIT
End DoDot:1
+51 SET FRDT=$$HLDATE^HLFNC($GET(FRDT))
+52 IF PID19'=""
SET $PIECE(PID,HLFS,13)=""
SET $PIECE(PID,HLFS,20)=PID19
+53 ; IB*2.0*621 Not for A1 transaction
IF EXT'=4
SET $PIECE(PID,HLFS,34)=FRDT
+54 QUIT
+55 ;
GT1 ; Guarantor Segment
+1 NEW WHO,NM,IDOB,ISEX,SEX,RLIEN,PER,PLIEN,RDATA,IBSDATA,IBADDR
+2 ; IB*2.0*621/DM variables
NEW EICDIIEN,IBFMIEN,IBTRKDTA
+3 ;
+4 SET GT1=""
+5 IF $GET(QUERY)="I"
QUIT
+6 ;
+7 ; If the data was extracted from Buffer get specifics from Buffer file
+8 IF ";1;5;6;7;"[(";"_EXT_";")
Begin DoDot:1
+9 SET WHO=$PIECE($GET(^IBA(355.33,BUFF,60)),U,5)
+10 IF WHO="v"!(WHO="")
QUIT
+11 ;S NM=$P($G(^IBA(355.33,BUFF,60)),U,7),NM=$$NAME^IBCNEHLU(NM)
+12 ;Get HIPAA data from new fields - IB*2*516
SET NM=$$GET1^DIQ(355.33,BUFF,91.01)
SET NM=$$NAME^IBCNEHLU(NM)
+13 SET NM=$$HLNAME^HLFNC(NM,HLECH)
+14 SET NM=$$ENCHL7(NM)
+15 SET $PIECE(GT1,HLFS,3)=NM_HLECH_HLECH_HLECH
+16 SET IDOB=$PIECE($GET(^IBA(355.33,BUFF,60)),U,8)
SET IDOB=$$HLDATE^HLFNC(IDOB)
+17 SET $PIECE(GT1,HLFS,8)=IDOB
+18 SET $PIECE(GT1,HLFS,2)=$$SCRUB($GET(SUBID))_HLECH_HLECH_HLECH_HLECH_"HC"
+19 QUIT
End DoDot:1
+20 ;
+21 ; If the data was from the appointment extract, check Patient file, IB*2.0*621/DM
+22 IF EXT=2
Begin DoDot:1
+23 IF IRIEN=""
QUIT
+24 SET WHO=$PIECE($GET(^DPT(DFN,.312,IRIEN,0)),U,6)
+25 IF WHO="v"!(WHO="")
QUIT
+26 ;S NM=$P($G(^DPT(DFN,.312,IRIEN,0)),U,17) ; WCJ;IB*2.0*497
+27 ; WCJ;IB*2.0*497
SET NM=$PIECE($GET(^DPT(DFN,.312,IRIEN,7)),U,1)
+28 SET NM=$$HLNAME^HLFNC(NM,HLECH)
+29 SET NM=$$ENCHL7(NM)
+30 SET $PIECE(GT1,HLFS,3)=NM_HLECH_HLECH_HLECH
+31 SET IDOB=$PIECE($GET(^DPT(DFN,.312,IRIEN,3)),U,1)
SET IDOB=$$HLDATE^HLFNC(IDOB)
+32 SET $PIECE(GT1,HLFS,8)=IDOB
+33 SET $PIECE(GT1,HLFS,2)=$$SCRUB($GET(SUBID))_HLECH_HLECH_HLECH_HLECH_"HC"
+34 ;
+35 SET IBSDATA=$GET(^DPT(DFN,.312,IRIEN,3))
+36 SET IBADDR=$$HLADDR^HLFNC($PIECE(IBSDATA,U,6,7),$PIECE(IBSDATA,U,8,10))
+37 SET $PIECE(GT1,HLFS,5)=$$ENCHL7(IBADDR)
+38 ;
+39 DO CHK
+40 IF $PIECE(GT1,HLFS,8)=""&(IDOB'="")
SET $PIECE(GT1,HLFS,8)=$$HLDATE^HLFNC(IDOB)
+41 IF $PIECE(GT1,HLFS,9)=""&(ISEX'="")
SET $PIECE(GT1,HLFS,9)=ISEX
+42 IF $PIECE(GT1,HLFS,9)=""
IF WHO="s"
Begin DoDot:2
+43 ; get policy holder sex
SET SEX=$PIECE($GET(^DPT(DFN,.312,IRIEN,3)),U,12)
+44 ; if null, use alternative method
IF SEX=""
SET SEX=$PIECE(^DPT(DFN,0),U,2)
SET SEX=$SELECT(SEX="M":"F",1:"M")
+45 SET $PIECE(GT1,HLFS,9)=SEX
End DoDot:2
End DoDot:1
+46 ;
+47 ; IB*2.0*621/DM add EICD Verification, use data from EIV EICD TRACKING (#365.18)
+48 IF EXT=4
IF $GET(QUERY)="V"
Begin DoDot:1
+49 ; IEN is the TQ from IBCNEDEP
SET EICDIIEN=+$ORDER(^IBCN(365.18,"C",IEN,0))
+50 IF ('EICDIIEN)!(EICDVIEN="")
QUIT
+51 SET IBFMIEN=EICDVIEN_","_EICDIIEN_","
+52 ; grab selected fields (internal)
KILL IBTRKDTA
DO GETS^DIQ(365.185,IBFMIEN,".04;.07;.08;.09","I","IBTRKDTA")
+53 ;
+54 SET NM=IBTRKDTA(365.185,IBFMIEN,.09,"I")
+55 ; no name means subscriber -- GT1 is not needed
if NM=""
QUIT
+56 SET NM=$$HLNAME^HLFNC(NM,HLECH)
+57 SET NM=$$ENCHL7(NM)
+58 SET $PIECE(GT1,HLFS,3)=NM_HLECH_HLECH_HLECH
+59 SET IDOB=IBTRKDTA(365.185,IBFMIEN,.07,"I")
SET IDOB=$$HLDATE^HLFNC(IDOB)
+60 SET $PIECE(GT1,HLFS,8)=IDOB
+61 ; Subscriber ID -- Guarantor Number
+62 SET $PIECE(GT1,HLFS,2)=$$SCRUB(IBTRKDTA(365.185,IBFMIEN,.04,"I"))_HLECH_HLECH_HLECH_HLECH_"HC"
+63 ; skip address data
+64 SET ISEX=IBTRKDTA(365.185,IBFMIEN,.08,"I")
+65 IF $PIECE(GT1,HLFS,8)=""&(IDOB'="")
SET $PIECE(GT1,HLFS,8)=$$HLDATE^HLFNC(IDOB)
+66 IF $PIECE(GT1,HLFS,9)=""&(ISEX'="")
SET $PIECE(GT1,HLFS,9)=ISEX
End DoDot:1
+67 ;
+68 IF GT1=""
QUIT
+69 SET $PIECE(GT1,HLFS,1)=1
+70 SET GT1="GT1"_HLFS_GT1
+71 QUIT
+72 ;
IN1 ; Insurance Segment
+1 NEW EFFDT,ELIGDT,EXPDT,PREL,ADMN,ADMDT,IENS
+2 ; IB*2.0*621/DM variables
NEW EICDIIEN,IBFMIEN,IBPYIEN,IBTRKDTA
+3 SET IN1=""
+4 ;
+5 ; If the data was extracted from Buffer get specifics from Buffer file
+6 IF ";1;5;6;7;"[(";"_EXT_";")
Begin DoDot:1
+7 SET PREL=$PIECE($GET(^IBA(355.33,BUFF,60)),U,14)
+8 SET ELIGDT=$PIECE($GET(TRANSR),U,12)
IF ELIGDT=DT
SET ELIGDT=""
+9 SET $PIECE(IN1,HLFS,2)=$SELECT(PREL=18:$$SCRUB($GET(SUBID)),PREL="":$$SCRUB($GET(SUBID)),1:$$SCRUB($GET(PATID)))
+10 SET $PIECE(IN1,HLFS,3)=$$ENCHL7($PIECE(^IBE(365.12,PAYR,0),U,2))_HLECH_HLECH_HLECH_"USVHA"_HLECH_"VP"_HLECH
+11 SET $PIECE(IN1,HLFS,4)=$$ENCHL7($PIECE(^IBE(365.12,PAYR,0),U,1))
+12 ;IB*2.0*516/TAZ - Use HIPAA compliant fields
+13 ;S $P(IN1,HLFS,8)=$$ENCHL7($P($G(^IBA(355.33,BUFF,40)),U,3))
+14 ;S $P(IN1,HLFS,9)=$$ENCHL7($P($G(^IBA(355.33,BUFF,40)),U,2))
+15 SET $PIECE(IN1,HLFS,8)=$$ENCHL7($$GET1^DIQ(355.33,BUFF_",",90.02))
+16 SET $PIECE(IN1,HLFS,9)=$$ENCHL7($$GET1^DIQ(355.33,BUFF_",",90.01))
+17 SET EFFDT=$PIECE($GET(^IBA(355.33,BUFF,60)),U,2)
SET EFFDT=$$HLDATE^HLFNC(EFFDT)
+18 SET EXPDT=$PIECE($GET(^IBA(355.33,BUFF,60)),U,3)
SET EXPDT=$$HLDATE^HLFNC(EXPDT)
+19 SET $PIECE(IN1,HLFS,12)=EFFDT
+20 SET $PIECE(IN1,HLFS,13)=EXPDT
+21 SET $PIECE(IN1,HLFS,17)=$$PATREL(PREL)
+22 SET $PIECE(IN1,HLFS,26)=$$HLDATE^HLFNC(ELIGDT)
+23 IF $PIECE(IN1,HLFS,17)=""
SET $PIECE(IN1,HLFS,17)=18
End DoDot:1
+24 ;
+25 ; If the data was from the appointment extract, check Patient file, IB*2.0*621/DM
+26 IF EXT=2
Begin DoDot:1
+27 IF IRIEN=""
QUIT
+28 IF $$SCRUB($GET(SUBID))'=$$SCRUB($PIECE($GET(^DPT(DFN,.312,IRIEN,0)),U,2))
QUIT
+29 SET EFFDT=$PIECE($GET(^DPT(DFN,.312,IRIEN,0)),U,8)
SET EFFDT=$$HLDATE^HLFNC(EFFDT)
+30 SET EXPDT=$PIECE($GET(^DPT(DFN,.312,IRIEN,0)),U,4)
SET EXPDT=$$HLDATE^HLFNC(EXPDT)
+31 SET $PIECE(IN1,HLFS,12)=EFFDT
+32 SET $PIECE(IN1,HLFS,13)=EXPDT
+33 SET PREL=$PIECE($GET(^DPT(DFN,.312,IRIEN,4)),U,3)
+34 SET $PIECE(IN1,HLFS,2)=$SELECT(PREL=18:$$SCRUB($GET(SUBID)),PREL="":$$SCRUB($GET(SUBID)),1:$$SCRUB($GET(PATID)))
+35 SET $PIECE(IN1,HLFS,3)=$$ENCHL7($PIECE(^IBE(365.12,PAYR,0),U,2))_HLECH_HLECH_HLECH_"USVHA"_HLECH_"VP"_HLECH
+36 SET $PIECE(IN1,HLFS,4)=$$ENCHL7($PIECE(^IBE(365.12,PAYR,0),U,1))
+37 SET $PIECE(IN1,HLFS,17)=$$PATREL(PREL)
+38 SET IENS=IRIEN_","_DFN_","
+39 SET $PIECE(IN1,HLFS,8)=$$ENCHL7($$GET1^DIQ(2.312,IENS,21,"E"))
+40 SET $PIECE(IN1,HLFS,9)=$$ENCHL7($$GET1^DIQ(2.312,IENS,20,"E"))
+41 IF $PIECE(IN1,HLFS,17)=""
SET $PIECE(IN1,HLFS,17)=18
End DoDot:1
+42 ;
+43 ; IB*2.0*621/DM add EICD Verification, use data from EIV EICD TRACKING (#365.18)
+44 IF EXT=4
IF $GET(QUERY)="V"
Begin DoDot:1
+45 ; IEN is the TQ from IBCNEDEP
SET EICDIIEN=+$ORDER(^IBCN(365.18,"C",IEN,0))
+46 IF ('EICDIIEN)!(EICDVIEN="")
QUIT
+47 SET IBFMIEN=EICDVIEN_","_EICDIIEN_","
+48 ; grab selected fields (internal)
KILL IBTRKDTA
DO GETS^DIQ(365.185,IBFMIEN,".01;.03;.05;.09","I","IBTRKDTA")
+49 ;
+50 ; means self/veteran
SET PREL="18"
+51 ; not subscriber
if IBTRKDTA(365.185,IBFMIEN,.09,"I")'=""
SET PREL=""
+52 SET $PIECE(IN1,HLFS,2)=IBTRKDTA(365.185,IBFMIEN,.05,"I")
+53 ; PAYER VA ID
SET $PIECE(IN1,HLFS,3)=$$ENCHL7(IBTRKDTA(365.185,IBFMIEN,.01,"I"))_HLECH_HLECH_HLECH_"USVHA"_HLECH_"VP"_HLECH
+54 ; PAYER IEN
SET IBPYIEN=+$$FIND1^DIC(365.12,,"QX",IBTRKDTA(365.185,IBFMIEN,.01,"I"),"C")
+55 ; PAYER NAME
SET $PIECE(IN1,HLFS,4)=$$ENCHL7($$GET1^DIQ(365.12,IBPYIEN_",",.01))
+56 SET $PIECE(IN1,HLFS,17)=$$PATREL(PREL)
+57 ; GROUP NUMBER
SET $PIECE(IN1,HLFS,8)=IBTRKDTA(365.185,IBFMIEN,.03,"I")
End DoDot:1
+58 IF IN1=""
QUIT
+59 ;
+60 SET $PIECE(IN1,HLFS,1)=1
+61 SET IN1="IN1"_HLFS_IN1
+62 QUIT
+63 ;
NTE(CTR) ; NTE Segment
+1 NEW EICDIIEN
+2 ; TRANSR is 0 node of TQ, set in PROC^IBCNEDEP
+3 ; service code from 365.1/.2
IF CTR=1
SET NTE=$$EXTERNAL^DILFD(365.1,.2,,$PIECE($GET(TRANSR),U,20))
+4 ; IB*2.0*601 - Added NTE2 and NTE3
+5 IF CTR=2
Begin DoDot:1
+6 ; IEN = ien of TQ
SET NTE=$$GET1^DIQ(365.1,IEN_",","SOURCE OF INFORMATION","I")
+7 SET NTE=$$GET1^DIQ(355.12,NTE_",","IB BUFFER ACRONYM")
End DoDot:1
+8 ; IB*2.0*631/TAZ restructure NTE(3)
+9 IF CTR=3
Begin DoDot:1
+10 NEW TYPE,WHICH
+11 ; IB*2.0*621
SET NTE=$SELECT(((EXT=4)&(QUERY="I")):"OHI",$$MBICHK^IBCNEUT7(BUFF):"MBI",1:"ELI")
+12 ;WHICH EXTRACT
SET WHICH=$$GET1^DIQ(365.1,IEN_",",.1,"I")
+13 SET TYPE=""
Begin DoDot:2
+14 IF $$GET1^DIQ(365.1,IEN_",",.04)="Retry"
SET TYPE="RETRY"
QUIT
+15 IF WHICH=1
SET TYPE="BUFFER"
QUIT
+16 IF WHICH=2
SET TYPE="APPT"
QUIT
+17 IF EXT=4
Begin DoDot:3
+18 IF QUERY="I"
SET TYPE="EICD-I"
QUIT
+19 SET TYPE="EICD-V"
End DoDot:3
QUIT
+20 IF WHICH=5
SET TYPE="REQUEST ELECTRONIC"
QUIT
+21 IF WHICH=6
SET TYPE="ICB/VISTA"
QUIT
+22 IF WHICH=7
SET TYPE="MBI REQUEST"
End DoDot:2
+23 SET NTE=NTE_"~"_TYPE
End DoDot:1
+24 ; IB*2.0*621
+25 ; Reporting of known insurance information will happen at a later release
IF CTR=4
SET NTE=""
+26 IF CTR=5
SET NTE=""
+27 IF CTR=5
IF EXT=4
IF QUERY="V"
Begin DoDot:1
+28 ; on EICD Verifications, pass the TRACE # from the associated EICD Inquiry
+29 ; IEN is the TQ from IBCNEDEP
SET EICDIIEN=+$ORDER(^IBCN(365.18,"C",IEN,0))
+30 ; EICD TRACE NUMBER
SET NTE=$$GET1^DIQ(365.18,EICDIIEN_",",.04,"I")
End DoDot:1
+31 SET NTE="NTE"_HLFS_CTR_HLFS_HLFS_NTE
+32 KILL CTR
+33 QUIT
+34 ;
CHK ; Check for spouse or other information in the Patient Relation File
+1 ; DGREL = Relationship (1=Self, 2=Spouse, 3-34,99=Other)
+2 NEW IEN,QFL
+3 SET IEN=""
SET RLIEN=""
SET ISEX=""
SET QFL=0
+4 FOR
SET IEN=$ORDER(^DGPR(408.12,"B",DFN,IEN))
if IEN=""
QUIT
Begin DoDot:1
+5 SET DGREL=$PIECE($GET(^DGPR(408.12,IEN,0)),U,2)
+6 ;
+7 ; If person is veteran, quit
+8 IF DGREL=1
QUIT
+9 ;
+10 ; If person is spouse, pick that record and quit
+11 IF WHO="s"
IF DGREL=2
SET RLIEN=IEN
SET QFL=1
QUIT
+12 ;
+13 ; Otherwise it should be an 'other' dependent
+14 SET RLIEN=IEN
End DoDot:1
if QFL
QUIT
+15 ;
+16 IF RLIEN=""
QUIT
+17 ;
+18 ; Check for Sex, SSN, DOB in INCOME PERSON File
+19 SET PER=$PIECE(^DGPR(408.12,RLIEN,0),U,3)
+20 IF PER'["DGPR(408.13"
QUIT
+21 SET PLIEN=$PIECE(PER,";",1)
+22 IF PLIEN=""
QUIT
+23 SET RDATA=$GET(^DGPR(408.13,PLIEN,0))
SET ISEX=$PIECE(RDATA,U,2)
SET IDOB=$PIECE(RDATA,U,3)
+24 IF $PIECE(RDATA,U,4)'=""
NEW DFN
SET DFN=$PIECE(RDATA,U,4)
SET ISEX=$PIECE(^DPT(DFN,0),U,2)
SET IDOB=$PIECE(^DPT(DFN,0),U,3)
+25 QUIT
+26 ;
ENCHL7(STR) ; Encode HL7 escape seqs in data fields
+1 ;
+2 ; Input:
+3 ; STR = Field data possible containing HL7 encoding chars
+4 ;
+5 ; Output Values
+6 ; Fn returns string w/converted escape seqs
+7 ;
+8 NEW CHR,NEW,RPLC,CNT,LOOP
+9 ;
+10 ; Replace "\" "&" "~" "|" with \F\ \R\ \E\ \T\ respectively
+11 FOR CHR="\","&","~","|"
SET CNT=$LENGTH(STR,CHR)
IF CNT>1
Begin DoDot:1
+12 SET NEW=$PIECE(STR,CHR)
+13 SET RPLC="\"_$TRANSLATE(CHR,"|~\&","FRET")_"\"
+14 FOR LOOP=2:1:CNT
SET NEW=NEW_RPLC_$PIECE(STR,CHR,LOOP)
+15 SET STR=NEW
End DoDot:1
+16 ;
+17 QUIT STR
+18 ;
SCRUB(Z) ; remove all punctuation from the string and convert lowercase to uppercase
+1 ; IB*2*416 - used for subscriber and patient ID fields
+2 SET Z=$$NOPUNCT^IBCEF(Z,1)
+3 SET Z=$$UP^XLFSTR(Z)
SCRUBX ;
+1 QUIT Z
+2 ;
PATREL(REL) ; convert pat.relationship to insured from VistA to X12 and return X12 value
+1 ; REL - VistA value
+2 ;
+3 ; VistA values of Self (18), Spouse (01), and Child (19) remain unchanged,
+4 ; anything else is converted to X12 value of Other Adult (34)
+5 ;
+6 QUIT $SELECT($GET(REL)="":"",".01.18.19."[("."_REL_"."):REL,1:34)
