Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCNEHL2

IBCNEHL2.m

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