- 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 Feb 18, 2025@23:40:59 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)