IBCNEHL2 ;DAOU/ALA - HL7 Process Incoming RPI Msgs (cont.) ;26-JUN-2002 ; Compiled December 16, 2004 15:29:37
;;2.0;INTEGRATED BILLING;**300,345,416,438,497,621**;21-MAR-94;Build 14
;;Per VHA Directive 6402, this routine should not be modified.
;
;**Program Description**
; This pgm will process the indiv segments of the
; incoming eIV response msgs.
;
; * Each of these tags are called by IBCNEHL1.
;
; This routine is based on IBCNEHLP which was introduced with patch 184, and subsequently
; patched with patches 252 and 271. IBCNEHLP is obsolete and deleted with patch 300.
;
; Variables
; SEG = HL7 Seg Name
; MSGID = Original Msg Control ID
; ACK = Acknowledgment (AA=Accepted, AE=Error)
; ERTXT = Error Msg Text
; ERFLG = Error quit flag
; ERACT = Error Action
; ERCON = Error Condition
; RIEN = Response Record IEN
; IBSEG = Array of the segment
;
Q ; No direct calls
;
MSA(ERACT,ERCON,ERROR,ERTXT,IBSEG,MGRP,RIEN,TRACE,EVENTYP) ; Process the MSA seg
;
; Input:
; IBSEG,MGRP
;
; Output:
; ERACT,ERCON,ERROR,ERTXT,RIEN,TRACE,ACK
;
D MSA^IBCNEHL4
Q
;
CTD(ERROR,IBSEG,RIEN) ; Process the CTD seg
;
; Input:
; IBSEG,RIEN
;
; Output:
; ERROR
;
N CTNAME,CTQUAL,CTNUM,CTQIEN,D1,DA,DATA,DIC,DILN,DISYS,DLAYGO,FFL,FLD,IENS,II,RSUPDT,X,Y
;
; Parse out data from seg
S CTNAME=$G(IBSEG(3)),CTQUAL=$P($G(IBSEG(6)),$E(HLECH),9),CTNUM=$P($G(IBSEG(6)),$E(HLECH))
I $TR(CTNAME," ")="" S CTNAME="NOT SPECIFIED"
S CTQIEN=$$FIND1^DIC(365.021,"","X",CTQUAL)
I CTNAME[$E(HLECH) S CTNAME=$$DECHL7($$FMNAME^HLFNC(CTNAME,HLECH))
S CTNAME=$E(CTNAME,1,32)
;
; Look up contact person
S DA(1)=RIEN,DIC="^IBCN(365,"_DA(1)_",3,",DIC(0)="LZ",DLAYGO=365.03
I '$D(^IBCN(365,DA(1),3,0)) S ^IBCN(365,DA(1),3,0)="^365.03^^"
S X=CTNAME D ^DIC
S DA=+Y,DATA=^IBCN(365,DA(1),3,DA,0),FLD=2,FFL=0
;
; Check if contact already has this communication qualifier on file
F II=2,4,6 I $P(DATA,U,II)=CTQIEN S FLD=II,FFL=1 Q
I 'FFL F II=2,4,6 I $P(DATA,U,II)="" S FLD=II Q
;
S IENS=$$IENS^DILF(.DA)
S RSUPDT(365.03,IENS,(FLD/2))=CTNUM ;stuffs the communication # in the correct field ;IB*2.0*497
S RSUPDT(365.03,IENS,".0"_FLD)=CTQIEN
D FILE^DIE("I","RSUPDT","ERROR")
CTDX ;
Q
;
PID(ERFLG,ERROR,IBSEG,RIEN) ; Process the PID seg
;
; Input:
; IBSEG,RIEN
;
; Output:
; ERFLG,ERROR
;
D PID^IBCNEHL4
Q
;
GT1(ERROR,IBSEG,RIEN,SUBID,EVENTYP) ; Process the GT1 Guarantor seg
;
; Input:
; IBSEG,RIEN
;
; Output:
; ERROR,SUBID
;
D GT1^IBCNEHL4
Q
;
IN1(ERROR,IBSEG,RIEN,SUBID,EVENTYP) ; Process the IN1 Insurance seg
;
; Input:
; IBSEG,RIEN,SUBID,ACK
;
; Output:
; ERROR
;
N COB,EFFDT,EXPDT,GNAME,GNUMB,MBRID,PAYRID,PYRNM,RSUPDT,SRVDT
N PYLEDT,CERDT,RELTN
;
; Austin sending responses with an error indicator will populate IBSEG(3) w/
;9 zeros in order to send the HL7 required field when the payer does not
;send a value for this field
S MBRID=$$DECHL7($G(IBSEG(3))) I ACK="AE",($TR(MBRID,0)="") S MBRID=""
S PAYRID=$G(IBSEG(4)),PYRNM=$G(IBSEG(5))
S GNAME=$$DECHL7($G(IBSEG(10))),GNUMB=$$DECHL7($G(IBSEG(9)))
; make sure group number is not longer than 17 chars, send mailman notification
; if truncation is necessary
I $L(GNUMB)>17 D TRNCWARN^IBCNEHLU(GNUMB,$G(TRACE)) S GNUMB=$E(GNUMB,1,17)
;IB*2.0*621/TAZ - Process EICD Discovery Response and Quit
I EVENTYP=1 D G IN1X
. N SETID
. S SETID=$G(IBSEG(2))
. S IBTRACK(SETID,.01)=PAYRID ;PAYER VA ID
. S IBTRACK(SETID,.02)=PYRNM ;PAYER NAME
. S IBTRACK(SETID,.03)=GNUMB ;GROUP NUMBER
. I $G(IBTRACK(SETID,.04))="" S IBTRACK(SETID,.04)=MBRID ;SUBSCRIBER ID
. S IBTRACK(SETID,.05)=MBRID ;MEMBER ID
S EFFDT=$G(IBSEG(13)),EXPDT=$G(IBSEG(14))
S COB=$G(IBSEG(23)),SRVDT=$G(IBSEG(27))
S PYLEDT=$G(IBSEG(30)),RELTN=$G(IBSEG(18))
;
; Relationship codes sent through the HL7 msg are X12 codes
; X12 codes from the interface that are special cases: "21"=unknown, "40"=cadaver donor
S RELTN=$S(RELTN="21":"",RELTN="40":"G8",1:RELTN)
S EFFDT=$$FMDATE^HLFNC(EFFDT),EXPDT=$$FMDATE^HLFNC(EXPDT)
S SRVDT=$$FMDATE^HLFNC(SRVDT),PYLEDT=$$FMDATE^HLFNC(PYLEDT)
;
S RSUPDT(365,RIEN_",",1.11)=EFFDT
S RSUPDT(365,RIEN_",",1.12)=EXPDT,RSUPDT(365,RIEN_",",1.1)=SRVDT
S RSUPDT(365,RIEN_",",1.19)=PYLEDT
S RSUPDT(365,RIEN_",",1.13)=COB,RSUPDT(365,RIEN_",",1.18)=MBRID
D FILE^DIE("","RSUPDT","ERROR") Q:$D(ERROR) ; data needs to filed as internal values
; IB*2*497 - add the following lines
; data at 365, 8.01,13.02,14.01, 14.02 needs to be validated before it can be filed; pass the 'E' flag to DBS filer
K RSUPDT
S RSUPDT(365,RIEN_",",8.01)=RELTN D CODECHK^IBCNEHLU(.RSUPDT) ; IB*2*497 check for new coded values
S RSUPDT(365,RIEN_",",13.02)=$S($G(SUBID)'="":SUBID,1:MBRID)
S RSUPDT(365,RIEN_",",14.01)=GNAME
S RSUPDT(365,RIEN_",",14.02)=GNUMB
D FILE^DIE("E","RSUPDT","ERROR")
IN1X ;
Q
;
IN3(ERROR,IBSEG,RIEN) ; Process IN3 Addt'l Insurance - Cert Seg
;
; Input:
; IBSEG,RIEN
;
; Output:
; ERROR
;
N CRDT,RSUPDT
;
S CRDT=$G(IBSEG(7))
S CRDT=$$FMDATE^HLFNC(CRDT)
S RSUPDT(365,RIEN_",",1.17)=CRDT
D FILE^DIE("I","RSUPDT","ERROR")
IN3X ;
Q
;
ZEB(EBDA,ERROR,IBSEG,RIEN) ; Process the ZEB Elig/Benefit seg
;
; Input:
; IBSEG,IIVSTAT,RIEN
;
; Output:
; EBDA,ERROR
;
N D1,DA,DIC,DILN,DISYS,DLAYGO,EBN,IENS,II,MSG,PRMODS,RSUPDT,STC,STCSTR,SUBJECT,X,XMY,Y,MA,CODES
;
; Set a default eIV Status value of # ("V")
I IIVSTAT="" D
. I IBSEG(7)'="eIV Eligibility Determination" S IIVSTAT="V" Q
. I $F("_1_6_V_","_"_IBSEG(3)_"_") S IIVSTAT=IBSEG(3) Q
. ; Unknown code received from the EC
. S SUBJECT="eIV: Invalid Eligibility Status flag"
. S MSG(1)="An invalid Eligibility Status flag '"_$G(IBSEG(3))_"' was received for site "_$P($$SITE^VASITE,"^",3)_","
. S MSG(2)="trace number "_$G(TRACE,"unknown")_" and message control id "_$G(MSGID,"unknown")_"."
. S MSG(3)="It has been interpreted as an ambiguous response in VistA."
. S XMY("FSCECADMIN@mail.domain.ext")=""
. D MSG^IBCNEUT5("",SUBJECT,"MSG(",,.XMY)
. S IIVSTAT="V"
;
; Process the ZEB
S EBN=$G(IBSEG(2))
S DA(1)=RIEN,DIC="^IBCN(365,"_DA(1)_",2,",DIC(0)="L",DLAYGO=365.02
I '$D(^IBCN(365,DA(1),2,0)) S ^IBCN(365,DA(1),2,0)="^365.02^^"
S X=EBN D ^DIC
S DA=+Y,EBDA=DA
;
S IENS=$$IENS^DILF(.DA)
;
; decode plan description ZEB segment
S IBSEG(7)=$$DECHL7($G(IBSEG(7)))
S RSUPDT(365.02,IENS,".02")=$P($G(IBSEG(3)),HLCMP) ; elig/benefit info
S RSUPDT(365.02,IENS,".03")=$P($G(IBSEG(4)),HLCMP) ; coverage level
S RSUPDT(365.02,IENS,".05")=$P($G(IBSEG(6)),HLCMP) ; insurance type
S RSUPDT(365.02,IENS,".06")=$G(IBSEG(7)) ; plan coverage
S RSUPDT(365.02,IENS,".07")=$P($G(IBSEG(8)),HLCMP) ; time period qualifier
S MA=$G(IBSEG(9)) I $TR(MA," ","")'="" S MA=$J(MA,0,2)
S RSUPDT(365.02,IENS,".08")=$$NUMCHK(MA) ; Monetary amt
S RSUPDT(365.02,IENS,".09")=$$NUMCHK($G(IBSEG(10))) ; Percent
S RSUPDT(365.02,IENS,".1")=$G(IBSEG(11)) ; Quantity Qual.
F II=11:1:13 S RSUPDT(365.02,IENS,"."_II)=$G(IBSEG(II+1))
S RSUPDT(365.02,IENS,"1.01")=$P($G(IBSEG(15)),HLCMP) ; Procedure coding method
S RSUPDT(365.02,IENS,"1.02")=$G(IBSEG(16)) ; Procedure code
; Procedure modifiers
S PRMODS=$G(IBSEG(17)) F II=1:1:4 S RSUPDT(365.02,IENS,"1.0"_(II+2))=$TR($P(PRMODS,HLREP,II),HL("ECH"))
D CODECHK^IBCNEHLU(.RSUPDT) ; IB*2*497 check for new coded values
D FILE^DIE("ET","RSUPDT","ERROR") I $D(ERROR) Q
; service type codes
K RSUPDT S STCSTR=$P($G(IBSEG(5)),HLCMP)
F II=1:1 S STC=$P(STCSTR,HLREP,II) Q:STC="" S RSUPDT(365.292,"+"_II_","_IENS,".01")=STC,CODES(365.292,II,.01)=STC ; IB*2*497 set up CODES array
D CODECHK^IBCNEHLU(.CODES) ;IB*2*497
I $D(RSUPDT) D UPDATE^DIE("E","RSUPDT",,"ERROR")
ZEBX ;
Q
;
EBNTE(EBDA,IBSEG,RIEN) ; Process NTE Benefit related entity Notes segment (in Eligibility/Benefit group)
;
; Input:
; EBDA,IBSEG,RIEN
;
; Output:
; ERROR
;
N DA,IENS,NOTES
I $G(EBDA)="" G EBNTEX
S NOTES(1)=$$DECHL7($G(IBSEG(4)))
S DA(1)=RIEN,DA=EBDA
S IENS=$$IENS^DILF(.DA)
D WP^DIE(365.02,IENS,2,"A","NOTES","ERROR")
EBNTEX ;
Q
;
DECHL7(STR,HLSEP,ECHARS) ; Decode HL7 escape seqs in data fields
;
; Input:
; STR = Field data possible containing HL7 escape seqs for encoding chars
; HLSEP (opt) = HL7 Field sep. char - assumes HLFS if not passed
; ECHARS (opt) = HL7 encoding chars being used, assumes HL("ECH") if not passed
;
; Output Values
; Fn returns string w/converted escape seqs
;
N ESC,PAT,REPL,ECODE,PCE
; Initialize opt. params.
I $G(HLSEP)="" S HLSEP=HLFS
I $G(ECHARS)="" S ECHARS=HL("ECH")
;
S ESC=$E(ECHARS,3) ; Escape char.
; Check for escape seqs, quit if not
I STR'[ESC G DECHL7X
; Replace ^ w/{sp} (if any) to prevent filing problems
S ECHARS=$TR(ECHARS,"^"," ")
;
; Array of rep. chars
S REPL("F")=$TR(HLSEP,"^"," ") ;Field Sep
S REPL("S")=$E(ECHARS) ;Comp Sep
S REPL("R")=$E(ECHARS,2) ;Rep. sep
; Temp. replace w/ASC 26, until after other ESC are stripped
S REPL("E")=$C(26) ;Esc. sep
S REPL("T")=$E(ECHARS,4) ;Subcomp. sep
;
; Translate out escape seqs left->right
F PCE=1:1:($L(STR,ESC)-1)\2 D
. ; Ignore empty esc. or unrec. esc. seq.
. S ECODE=$P(STR,ESC,2) I ECODE="" S ECODE="XXXX"
. I $D(REPL(ECODE))'>0 S STR=$P(STR,ESC)_$C(26)_$P(STR,ESC,2)_$C(26)_$P(STR,ESC,3,99999) Q
. ; Else, replace esc. seq. w/ char.
. S STR=$P(STR,ESC)_$G(REPL(ECODE))_$P(STR,ESC,3,99999)
;
;Replace the decoded ESC chars that were actually sent
S STR=$TR(STR,$C(26),ESC)
;
DECHL7X ; Exit w/return values
Q STR
;
NUMCHK(N) ; make sure that numeric value N is not greater than 99999
Q $S(+N>99999:99999,1:N)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNEHL2 9891 printed Dec 13, 2024@02:14:35 Page 2
IBCNEHL2 ;DAOU/ALA - HL7 Process Incoming RPI Msgs (cont.) ;26-JUN-2002 ; Compiled December 16, 2004 15:29:37
+1 ;;2.0;INTEGRATED BILLING;**300,345,416,438,497,621**;21-MAR-94;Build 14
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 ;**Program Description**
+5 ; This pgm will process the indiv segments of the
+6 ; incoming eIV response msgs.
+7 ;
+8 ; * Each of these tags are called by IBCNEHL1.
+9 ;
+10 ; This routine is based on IBCNEHLP which was introduced with patch 184, and subsequently
+11 ; patched with patches 252 and 271. IBCNEHLP is obsolete and deleted with patch 300.
+12 ;
+13 ; Variables
+14 ; SEG = HL7 Seg Name
+15 ; MSGID = Original Msg Control ID
+16 ; ACK = Acknowledgment (AA=Accepted, AE=Error)
+17 ; ERTXT = Error Msg Text
+18 ; ERFLG = Error quit flag
+19 ; ERACT = Error Action
+20 ; ERCON = Error Condition
+21 ; RIEN = Response Record IEN
+22 ; IBSEG = Array of the segment
+23 ;
+24 ; No direct calls
QUIT
+25 ;
MSA(ERACT,ERCON,ERROR,ERTXT,IBSEG,MGRP,RIEN,TRACE,EVENTYP) ; Process the MSA seg
+1 ;
+2 ; Input:
+3 ; IBSEG,MGRP
+4 ;
+5 ; Output:
+6 ; ERACT,ERCON,ERROR,ERTXT,RIEN,TRACE,ACK
+7 ;
+8 DO MSA^IBCNEHL4
+9 QUIT
+10 ;
CTD(ERROR,IBSEG,RIEN) ; Process the CTD seg
+1 ;
+2 ; Input:
+3 ; IBSEG,RIEN
+4 ;
+5 ; Output:
+6 ; ERROR
+7 ;
+8 NEW CTNAME,CTQUAL,CTNUM,CTQIEN,D1,DA,DATA,DIC,DILN,DISYS,DLAYGO,FFL,FLD,IENS,II,RSUPDT,X,Y
+9 ;
+10 ; Parse out data from seg
+11 SET CTNAME=$GET(IBSEG(3))
SET CTQUAL=$PIECE($GET(IBSEG(6)),$EXTRACT(HLECH),9)
SET CTNUM=$PIECE($GET(IBSEG(6)),$EXTRACT(HLECH))
+12 IF $TRANSLATE(CTNAME," ")=""
SET CTNAME="NOT SPECIFIED"
+13 SET CTQIEN=$$FIND1^DIC(365.021,"","X",CTQUAL)
+14 IF CTNAME[$EXTRACT(HLECH)
SET CTNAME=$$DECHL7($$FMNAME^HLFNC(CTNAME,HLECH))
+15 SET CTNAME=$EXTRACT(CTNAME,1,32)
+16 ;
+17 ; Look up contact person
+18 SET DA(1)=RIEN
SET DIC="^IBCN(365,"_DA(1)_",3,"
SET DIC(0)="LZ"
SET DLAYGO=365.03
+19 IF '$DATA(^IBCN(365,DA(1),3,0))
SET ^IBCN(365,DA(1),3,0)="^365.03^^"
+20 SET X=CTNAME
DO ^DIC
+21 SET DA=+Y
SET DATA=^IBCN(365,DA(1),3,DA,0)
SET FLD=2
SET FFL=0
+22 ;
+23 ; Check if contact already has this communication qualifier on file
+24 FOR II=2,4,6
IF $PIECE(DATA,U,II)=CTQIEN
SET FLD=II
SET FFL=1
QUIT
+25 IF 'FFL
FOR II=2,4,6
IF $PIECE(DATA,U,II)=""
SET FLD=II
QUIT
+26 ;
+27 SET IENS=$$IENS^DILF(.DA)
+28 ;stuffs the communication # in the correct field ;IB*2.0*497
SET RSUPDT(365.03,IENS,(FLD/2))=CTNUM
+29 SET RSUPDT(365.03,IENS,".0"_FLD)=CTQIEN
+30 DO FILE^DIE("I","RSUPDT","ERROR")
CTDX ;
+1 QUIT
+2 ;
PID(ERFLG,ERROR,IBSEG,RIEN) ; Process the PID seg
+1 ;
+2 ; Input:
+3 ; IBSEG,RIEN
+4 ;
+5 ; Output:
+6 ; ERFLG,ERROR
+7 ;
+8 DO PID^IBCNEHL4
+9 QUIT
+10 ;
GT1(ERROR,IBSEG,RIEN,SUBID,EVENTYP) ; Process the GT1 Guarantor seg
+1 ;
+2 ; Input:
+3 ; IBSEG,RIEN
+4 ;
+5 ; Output:
+6 ; ERROR,SUBID
+7 ;
+8 DO GT1^IBCNEHL4
+9 QUIT
+10 ;
IN1(ERROR,IBSEG,RIEN,SUBID,EVENTYP) ; Process the IN1 Insurance seg
+1 ;
+2 ; Input:
+3 ; IBSEG,RIEN,SUBID,ACK
+4 ;
+5 ; Output:
+6 ; ERROR
+7 ;
+8 NEW COB,EFFDT,EXPDT,GNAME,GNUMB,MBRID,PAYRID,PYRNM,RSUPDT,SRVDT
+9 NEW PYLEDT,CERDT,RELTN
+10 ;
+11 ; Austin sending responses with an error indicator will populate IBSEG(3) w/
+12 ;9 zeros in order to send the HL7 required field when the payer does not
+13 ;send a value for this field
+14 SET MBRID=$$DECHL7($GET(IBSEG(3)))
IF ACK="AE"
IF ($TRANSLATE(MBRID,0)="")
SET MBRID=""
+15 SET PAYRID=$GET(IBSEG(4))
SET PYRNM=$GET(IBSEG(5))
+16 SET GNAME=$$DECHL7($GET(IBSEG(10)))
SET GNUMB=$$DECHL7($GET(IBSEG(9)))
+17 ; make sure group number is not longer than 17 chars, send mailman notification
+18 ; if truncation is necessary
+19 IF $LENGTH(GNUMB)>17
DO TRNCWARN^IBCNEHLU(GNUMB,$GET(TRACE))
SET GNUMB=$EXTRACT(GNUMB,1,17)
+20 ;IB*2.0*621/TAZ - Process EICD Discovery Response and Quit
+21 IF EVENTYP=1
Begin DoDot:1
+22 NEW SETID
+23 SET SETID=$GET(IBSEG(2))
+24 ;PAYER VA ID
SET IBTRACK(SETID,.01)=PAYRID
+25 ;PAYER NAME
SET IBTRACK(SETID,.02)=PYRNM
+26 ;GROUP NUMBER
SET IBTRACK(SETID,.03)=GNUMB
+27 ;SUBSCRIBER ID
IF $GET(IBTRACK(SETID,.04))=""
SET IBTRACK(SETID,.04)=MBRID
+28 ;MEMBER ID
SET IBTRACK(SETID,.05)=MBRID
End DoDot:1
GOTO IN1X
+29 SET EFFDT=$GET(IBSEG(13))
SET EXPDT=$GET(IBSEG(14))
+30 SET COB=$GET(IBSEG(23))
SET SRVDT=$GET(IBSEG(27))
+31 SET PYLEDT=$GET(IBSEG(30))
SET RELTN=$GET(IBSEG(18))
+32 ;
+33 ; Relationship codes sent through the HL7 msg are X12 codes
+34 ; X12 codes from the interface that are special cases: "21"=unknown, "40"=cadaver donor
+35 SET RELTN=$SELECT(RELTN="21":"",RELTN="40":"G8",1:RELTN)
+36 SET EFFDT=$$FMDATE^HLFNC(EFFDT)
SET EXPDT=$$FMDATE^HLFNC(EXPDT)
+37 SET SRVDT=$$FMDATE^HLFNC(SRVDT)
SET PYLEDT=$$FMDATE^HLFNC(PYLEDT)
+38 ;
+39 SET RSUPDT(365,RIEN_",",1.11)=EFFDT
+40 SET RSUPDT(365,RIEN_",",1.12)=EXPDT
SET RSUPDT(365,RIEN_",",1.1)=SRVDT
+41 SET RSUPDT(365,RIEN_",",1.19)=PYLEDT
+42 SET RSUPDT(365,RIEN_",",1.13)=COB
SET RSUPDT(365,RIEN_",",1.18)=MBRID
+43 ; data needs to filed as internal values
DO FILE^DIE("","RSUPDT","ERROR")
if $DATA(ERROR)
QUIT
+44 ; IB*2*497 - add the following lines
+45 ; data at 365, 8.01,13.02,14.01, 14.02 needs to be validated before it can be filed; pass the 'E' flag to DBS filer
+46 KILL RSUPDT
+47 ; IB*2*497 check for new coded values
SET RSUPDT(365,RIEN_",",8.01)=RELTN
DO CODECHK^IBCNEHLU(.RSUPDT)
+48 SET RSUPDT(365,RIEN_",",13.02)=$SELECT($GET(SUBID)'="":SUBID,1:MBRID)
+49 SET RSUPDT(365,RIEN_",",14.01)=GNAME
+50 SET RSUPDT(365,RIEN_",",14.02)=GNUMB
+51 DO FILE^DIE("E","RSUPDT","ERROR")
IN1X ;
+1 QUIT
+2 ;
IN3(ERROR,IBSEG,RIEN) ; Process IN3 Addt'l Insurance - Cert Seg
+1 ;
+2 ; Input:
+3 ; IBSEG,RIEN
+4 ;
+5 ; Output:
+6 ; ERROR
+7 ;
+8 NEW CRDT,RSUPDT
+9 ;
+10 SET CRDT=$GET(IBSEG(7))
+11 SET CRDT=$$FMDATE^HLFNC(CRDT)
+12 SET RSUPDT(365,RIEN_",",1.17)=CRDT
+13 DO FILE^DIE("I","RSUPDT","ERROR")
IN3X ;
+1 QUIT
+2 ;
ZEB(EBDA,ERROR,IBSEG,RIEN) ; Process the ZEB Elig/Benefit seg
+1 ;
+2 ; Input:
+3 ; IBSEG,IIVSTAT,RIEN
+4 ;
+5 ; Output:
+6 ; EBDA,ERROR
+7 ;
+8 NEW D1,DA,DIC,DILN,DISYS,DLAYGO,EBN,IENS,II,MSG,PRMODS,RSUPDT,STC,STCSTR,SUBJECT,X,XMY,Y,MA,CODES
+9 ;
+10 ; Set a default eIV Status value of # ("V")
+11 IF IIVSTAT=""
Begin DoDot:1
+12 IF IBSEG(7)'="eIV Eligibility Determination"
SET IIVSTAT="V"
QUIT
+13 IF $FIND("_1_6_V_","_"_IBSEG(3)_"_")
SET IIVSTAT=IBSEG(3)
QUIT
+14 ; Unknown code received from the EC
+15 SET SUBJECT="eIV: Invalid Eligibility Status flag"
+16 SET MSG(1)="An invalid Eligibility Status flag '"_$GET(IBSEG(3))_"' was received for site "_$PIECE($$SITE^VASITE,"^",3)_","
+17 SET MSG(2)="trace number "_$GET(TRACE,"unknown")_" and message control id "_$GET(MSGID,"unknown")_"."
+18 SET MSG(3)="It has been interpreted as an ambiguous response in VistA."
+19 SET XMY("FSCECADMIN@mail.domain.ext")=""
+20 DO MSG^IBCNEUT5("",SUBJECT,"MSG(",,.XMY)
+21 SET IIVSTAT="V"
End DoDot:1
+22 ;
+23 ; Process the ZEB
+24 SET EBN=$GET(IBSEG(2))
+25 SET DA(1)=RIEN
SET DIC="^IBCN(365,"_DA(1)_",2,"
SET DIC(0)="L"
SET DLAYGO=365.02
+26 IF '$DATA(^IBCN(365,DA(1),2,0))
SET ^IBCN(365,DA(1),2,0)="^365.02^^"
+27 SET X=EBN
DO ^DIC
+28 SET DA=+Y
SET EBDA=DA
+29 ;
+30 SET IENS=$$IENS^DILF(.DA)
+31 ;
+32 ; decode plan description ZEB segment
+33 SET IBSEG(7)=$$DECHL7($GET(IBSEG(7)))
+34 ; elig/benefit info
SET RSUPDT(365.02,IENS,".02")=$PIECE($GET(IBSEG(3)),HLCMP)
+35 ; coverage level
SET RSUPDT(365.02,IENS,".03")=$PIECE($GET(IBSEG(4)),HLCMP)
+36 ; insurance type
SET RSUPDT(365.02,IENS,".05")=$PIECE($GET(IBSEG(6)),HLCMP)
+37 ; plan coverage
SET RSUPDT(365.02,IENS,".06")=$GET(IBSEG(7))
+38 ; time period qualifier
SET RSUPDT(365.02,IENS,".07")=$PIECE($GET(IBSEG(8)),HLCMP)
+39 SET MA=$GET(IBSEG(9))
IF $TRANSLATE(MA," ","")'=""
SET MA=$JUSTIFY(MA,0,2)
+40 ; Monetary amt
SET RSUPDT(365.02,IENS,".08")=$$NUMCHK(MA)
+41 ; Percent
SET RSUPDT(365.02,IENS,".09")=$$NUMCHK($GET(IBSEG(10)))
+42 ; Quantity Qual.
SET RSUPDT(365.02,IENS,".1")=$GET(IBSEG(11))
+43 FOR II=11:1:13
SET RSUPDT(365.02,IENS,"."_II)=$GET(IBSEG(II+1))
+44 ; Procedure coding method
SET RSUPDT(365.02,IENS,"1.01")=$PIECE($GET(IBSEG(15)),HLCMP)
+45 ; Procedure code
SET RSUPDT(365.02,IENS,"1.02")=$GET(IBSEG(16))
+46 ; Procedure modifiers
+47 SET PRMODS=$GET(IBSEG(17))
FOR II=1:1:4
SET RSUPDT(365.02,IENS,"1.0"_(II+2))=$TRANSLATE($PIECE(PRMODS,HLREP,II),HL("ECH"))
+48 ; IB*2*497 check for new coded values
DO CODECHK^IBCNEHLU(.RSUPDT)
+49 DO FILE^DIE("ET","RSUPDT","ERROR")
IF $DATA(ERROR)
QUIT
+50 ; service type codes
+51 KILL RSUPDT
SET STCSTR=$PIECE($GET(IBSEG(5)),HLCMP)
+52 ; IB*2*497 set up CODES array
FOR II=1:1
SET STC=$PIECE(STCSTR,HLREP,II)
if STC=""
QUIT
SET RSUPDT(365.292,"+"_II_","_IENS,".01")=STC
SET CODES(365.292,II,.01)=STC
+53 ;IB*2*497
DO CODECHK^IBCNEHLU(.CODES)
+54 IF $DATA(RSUPDT)
DO UPDATE^DIE("E","RSUPDT",,"ERROR")
ZEBX ;
+1 QUIT
+2 ;
EBNTE(EBDA,IBSEG,RIEN) ; Process NTE Benefit related entity Notes segment (in Eligibility/Benefit group)
+1 ;
+2 ; Input:
+3 ; EBDA,IBSEG,RIEN
+4 ;
+5 ; Output:
+6 ; ERROR
+7 ;
+8 NEW DA,IENS,NOTES
+9 IF $GET(EBDA)=""
GOTO EBNTEX
+10 SET NOTES(1)=$$DECHL7($GET(IBSEG(4)))
+11 SET DA(1)=RIEN
SET DA=EBDA
+12 SET IENS=$$IENS^DILF(.DA)
+13 DO WP^DIE(365.02,IENS,2,"A","NOTES","ERROR")
EBNTEX ;
+1 QUIT
+2 ;
DECHL7(STR,HLSEP,ECHARS) ; Decode HL7 escape seqs in data fields
+1 ;
+2 ; Input:
+3 ; STR = Field data possible containing HL7 escape seqs for encoding chars
+4 ; HLSEP (opt) = HL7 Field sep. char - assumes HLFS if not passed
+5 ; ECHARS (opt) = HL7 encoding chars being used, assumes HL("ECH") if not passed
+6 ;
+7 ; Output Values
+8 ; Fn returns string w/converted escape seqs
+9 ;
+10 NEW ESC,PAT,REPL,ECODE,PCE
+11 ; Initialize opt. params.
+12 IF $GET(HLSEP)=""
SET HLSEP=HLFS
+13 IF $GET(ECHARS)=""
SET ECHARS=HL("ECH")
+14 ;
+15 ; Escape char.
SET ESC=$EXTRACT(ECHARS,3)
+16 ; Check for escape seqs, quit if not
+17 IF STR'[ESC
GOTO DECHL7X
+18 ; Replace ^ w/{sp} (if any) to prevent filing problems
+19 SET ECHARS=$TRANSLATE(ECHARS,"^"," ")
+20 ;
+21 ; Array of rep. chars
+22 ;Field Sep
SET REPL("F")=$TRANSLATE(HLSEP,"^"," ")
+23 ;Comp Sep
SET REPL("S")=$EXTRACT(ECHARS)
+24 ;Rep. sep
SET REPL("R")=$EXTRACT(ECHARS,2)
+25 ; Temp. replace w/ASC 26, until after other ESC are stripped
+26 ;Esc. sep
SET REPL("E")=$CHAR(26)
+27 ;Subcomp. sep
SET REPL("T")=$EXTRACT(ECHARS,4)
+28 ;
+29 ; Translate out escape seqs left->right
+30 FOR PCE=1:1:($LENGTH(STR,ESC)-1)\2
Begin DoDot:1
+31 ; Ignore empty esc. or unrec. esc. seq.
+32 SET ECODE=$PIECE(STR,ESC,2)
IF ECODE=""
SET ECODE="XXXX"
+33 IF $DATA(REPL(ECODE))'>0
SET STR=$PIECE(STR,ESC)_$CHAR(26)_$PIECE(STR,ESC,2)_$CHAR(26)_$PIECE(STR,ESC,3,99999)
QUIT
+34 ; Else, replace esc. seq. w/ char.
+35 SET STR=$PIECE(STR,ESC)_$GET(REPL(ECODE))_$PIECE(STR,ESC,3,99999)
End DoDot:1
+36 ;
+37 ;Replace the decoded ESC chars that were actually sent
+38 SET STR=$TRANSLATE(STR,$CHAR(26),ESC)
+39 ;
DECHL7X ; Exit w/return values
+1 QUIT STR
+2 ;
NUMCHK(N) ; make sure that numeric value N is not greater than 99999
+1 QUIT $SELECT(+N>99999:99999,1:N)
