IBCNEHL4 ;DAOU/ALA - HL7 Process Incoming RPI Msgs (cont.) ;26-JUN-2002
;;2.0;INTEGRATED BILLING;**300,416,438,497,506,519,621,743**;21-MAR-94;Build 18
;;Per VA Directive 6402, this routine should not be modified.
;
;**Program Description**
; This pgm will process the non-repeating segments of the
; incoming eIV response msgs.
; It was separated out from IBCNEHL2 to conserve space.
;
; 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.
;
; * Each of these tags are called by IBCNEHL2.
;
; 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
;
; IB*2*519 Only fixed line 2 of the routine. Changed "..497*506" to "..497,506"
;
MSA ; Process the MSA seg
;
; Input:
; IBSEG,MGRP
;
; Output:
; ERACT,ERCON,ERROR,ERTXT,RIEN,TRACE,ACK
;
N MSGID,RSUPDT,VRFDT
S ACK=$G(IBSEG(2)),MSGID=$G(IBSEG(3)),TRACE=$G(IBSEG(4))
S ERTXT=$$DECHL7^IBCNEHL2($P($G(IBSEG(7)),$E(HLECH),2)),ERACT=$G(IBSEG(6)),ERCON=$P($G(IBSEG(7)),$E(HLECH),1)
;
; If no Control Id, send Mailman error msg
I MSGID="" D ERRMSA(TRACE,MGRP) S ERFLG=1 G MSAX
;
; Check for msg id/payer combination and get response IEN
D PCK^IBCNEHL3
;
; If no record IEN, quit
I $G(RIEN)="" G MSAX
;
;IB*2.0*621/TAZ - Process EICD Error messages
I EVENTYP=1 D
. N DFN
. S DFN=$$GET1^DIQ(365,RIEN_",",.02,"I")
. S IBTRACK(0,.04)=TRACE
. S IBTRACK(0,.06)=RIEN
. I ERTXT="" S IBTRACK(0,.07)=1 Q
. I $$UP^XLFSTR(ERTXT)["NO ACTIVE POLICIES" S IBTRACK(0,.07)=2 Q
. I $$UP^XLFSTR(ERTXT)["TIMEOUT" D Q
.. S IBTRACK(0,.07)=3
.. ;Need to remove (EICD Last Date Run) from Patient File #2 - IB*2.0*621
.. S DA=DFN,DIE="^DPT(",DR="2001///@"
.. D ^DIE
.. K DA,DIE,DR
. S IBTRACK(0,.07)=0
; Update record w/info
S RSUPDT(365,RIEN_",",.09)=TRACE,RSUPDT(365,RIEN_",",.06)=3 ;set TRANSMISSION STATUS to 'Response Received'
S RSUPDT(365,RIEN_",",4.01)=ERTXT
S VRFDT=$$NOW^XLFDT(),RSUPDT(365,RIEN_",",.07)=VRFDT ;update 'DATE/TIME RECEIVED'
;
; Update w/internal values
D FILE^DIE("I","RSUPDT","ERROR")
;
S RSUPDT(365,RIEN_",",1.14)=ERCON,RSUPDT(365,RIEN_",",1.15)=ERACT
;
; Update w/external values
D FILE^DIE("ET","RSUPDT","ERROR")
;
D TQCLOSE
MSAX ;
Q
;
TQCLOSE ;IB*743/CKB
;For an original response, set the Transmission Queue Status to 'Response Received' &
; update remaining retries to comm failure (5)
N RDAT0,RSTYPE,TQN
S RDAT0=$G(^IBCN(365,RIEN,0))
S TQN=$P(RDAT0,U,5),RSTYPE=$P(RDAT0,U,10)
I $G(RSTYPE)="O" D SST^IBCNEUT2(TQN,3),RSTA^IBCNEUT7(TQN)
Q
;
ERRMSA(TRACE,MGRP) ; Msg Control Id is blank - Send Mailman error msg
;
N HCT,ICN,MSG,MSGCT,NAME,XMSUB
;
;1st find the PID seg to extract ICN and patient name
D GTICNM^IBCNEHLU(.ICN,.NAME)
;
;Send the Mailman error msg
S XMSUB="Message Control Id Field is Blank",MSGCT=$S(TRACE="":4,1:3)
S MSG(1)="A response was received w/a blank Message Control Id"
I TRACE="" S MSG(1)=MSG(1)_" and Trace #"
S MSG(2)="for "_$S(TRACE'="":"Trace #: "_TRACE_", ",1:"")_"ICN #: "_ICN_", Patient: "_NAME_"."
I TRACE="" D
. S MSG(3)="It is likely that there are communication issues with the EC."
S MSG(MSGCT)="This response cannot be processed. Please contact the Help Desk."
D MSG^IBCNEUT5(MGRP,XMSUB,"MSG(")
Q
;
PID ; Process the PID seg
N DFN,DOB,DOD,FLD,ICN,IENSTR,LFAC,LUPDT,NAME,RSUPDT,SEX,SSN,STATE,XDFN,IDLIST
N SUBCNT,SUBC,SUBCID,SUBCDATA,IERN
;
S ERFLG=0
S DOB=$G(IBSEG(8)),SEX=$G(IBSEG(9))
S NAME=$G(IBSEG(6))
S DOD=$G(IBSEG(30)),LUPDT=$G(IBSEG(34)),LFAC=$G(IBSEG(35))
;
; Parse Repeating ID field to fill in other identifiers
S (ICN,SSN,DFN)=""
S IDLIST=$G(IBSEG(4))
F SUBCNT=1:1:$L(IDLIST,$E(HLECH,2,2)) D
. S SUBC=$P(IDLIST,$E(HLECH,2,2),SUBCNT)
. S SUBCID=$P(SUBC,$E(HLECH),5) ; Identifier Type Code
. S SUBCDATA=$P(SUBC,$E(HLECH),1) ; Data Value
. I SUBCID="PI" S DFN=SUBCDATA
. I SUBCID="SS" S SSN=SUBCDATA
. I SUBCID="NI" S ICN=SUBCDATA
;
; Convert data from HL7 format to VistA format
S NAME=$$DECHL7^IBCNEHL2($$FMNAME^HLFNC(NAME,HLECH))
S DOD=$$FMDATE^HLFNC(DOD),DOB=$$FMDATE^HLFNC(DOB),LUPDT=$$FMDATE^HLFNC(LUPDT)
;
; Use ICN to find the patients DFN at this site
I ICN'="" D
.S XDFN=$$GETDFN^MPIF001(ICN)
.; if unsuccessful, wait 5 sec and try one more time
.I +$G(XDFN)'>0 H 5 S XDFN=$$GETDFN^MPIF001(ICN)
.Q
I +$G(XDFN)'>0,+$G(ICN)>0 D Q
. S ERFLG=1,IERN=$$ERRN^IBCNEUT7("ERROR(""DIERR"")")
. S ERROR("DIERR",IERN,"TEXT",1)="Unable to determine the patient's DFN value for this site."
. S ERROR("DIERR",IERN,"TEXT",2)=" The ICN for the patient in this response is ICN: "_ICN
. S ERROR("DIERR",IERN,"TEXT",3)=" eIV was unable to file the response information."
;
I +ICN>0 S DFN=XDFN
;
; Perform date of death check
I DOD'="" D DODCK^IBCNEHLU(DFN,DOD,MGRP,NAME,RIEN,SSN)
;
S IENSTR=RIEN_","
I $P(^IBCN(365,RIEN,0),U,2)="" S RSUPDT(365,IENSTR,.02)=DFN
;IB*2.0*621/TAZ - Only file DOB, SEX, SSN, PT RELATIONSHIP and ADDRESS on regular 271s
I EVENTYP'=1 D
. S RSUPDT(365,IENSTR,1.02)=DOB,RSUPDT(365,IENSTR,1.04)=SEX
. S RSUPDT(365,IENSTR,1.09)="01"
. S RSUPDT(365,IENSTR,1.03)=SSN
. ; Subscriber address
. S FLD=$G(IBSEG(12))
. S RSUPDT(365,IENSTR,5.01)=$P($P(FLD,HLCMP),HLSCMP) ; line 1
. S RSUPDT(365,IENSTR,5.02)=$P(FLD,HLCMP,2) ; line 2
. S RSUPDT(365,IENSTR,5.03)=$P(FLD,HLCMP,3) ; city
. S STATE=+$$FIND1^DIC(5,,"X",$P(FLD,HLCMP,4),"C") I STATE>0 S RSUPDT(365,IENSTR,5.04)=STATE ; state
. S RSUPDT(365,IENSTR,5.05)=$P(FLD,HLCMP,5) ; zip
. S RSUPDT(365,IENSTR,5.06)=$P(FLD,HLCMP,6) ; country
. S RSUPDT(365,IENSTR,5.07)=$P(FLD,HLCMP,8) ; country subdivision
S RSUPDT(365,IENSTR,1.16)=DOD
S RSUPDT(365,IENSTR,1.08)="v"
D FILE^DIE("I","RSUPDT","ERROR") Q:$D(ERROR)
; IB*2*497 - the value at NAME OF INSURED (365,13.01) must be validated before it can be filed; pass
; the 'E' flag to DBS filer
; IB*2.0*621/TAZ Only file NAME OF INSURED on regular 271's (check for EVENTYP)
I EVENTYP'=1 D
. K RSUPDT
. S RSUPDT(365,IENSTR,13.01)=NAME
. D FILE^DIE("E","RSUPDT","ERROR")
PIDX ;
Q
;
GT1 ; Process the GT1 Guarantor seg
;
; Input:
; IBSEG,RIEN
;
; Output:
; ERROR,SUBID
;
N DOB,IENSTR,NAME,RSUPDT,SEX,SSN,SUBIDC
S NAME=$G(IBSEG(4)),DOB=$G(IBSEG(9)),SEX=$G(IBSEG(10))
S SSN=$G(IBSEG(13)) ; FSC NO LONGER SENDS SSN for regular 271's
;
S SUBIDC=$G(IBSEG(3)) ; Raw field with sub-comp.
S SUBID=$P(SUBIDC,$E(HLECH),1)
S SUBID=$$DECHL7^IBCNEHL2(SUBID)
;
S DOB=$$FMDATE^HLFNC(DOB),NAME=$$DECHL7^IBCNEHL2($$FMNAME^HLFNC(NAME,HLECH))
;
;IB*2.0*621/TAZ - Process EICD Identification Response and Quit
I EVENTYP=1 D G GT1X
. N FLG,SETID,STATE
. S SETID=$G(IBSEG(2))
. S IBTRACK(SETID,.04)=SUBID
. S IBTRACK(SETID,.06)=SSN
. S:DOB'="" IBTRACK(SETID,.07)=DOB
. S IBTRACK(SETID,.08)=SEX
. S IBTRACK(SETID,.09)=NAME
. S FLD=$G(IBSEG(6))
. S IBTRACK(SETID,.1)=$P($P(FLD,HLCMP),HLSCMP) ;Subscriber Address 1
. S IBTRACK(SETID,.11)=$P(FLD,HLCMP,2) ;Subscriber Address 2
. S IBTRACK(SETID,.12)=$P(FLD,HLCMP,3) ;Subscriber City
. S STATE=+$$FIND1^DIC(5,,"X",$P(FLD,HLCMP,4),"C") I STATE>0 S IBTRACK(SETID,.13)=STATE ;Subscriber State
. S IBTRACK(SETID,.14)=$P(FLD,HLCMP,5) ;Subscriber Zip
. S IBTRACK(SETID,.15)=1
S IENSTR=RIEN_","
S RSUPDT(365,RIEN_",",1.08)=""
S:DOB'="" RSUPDT(365,IENSTR,1.02)=DOB
S RSUPDT(365,RIEN_",",1.04)=SEX
S RSUPDT(365,IENSTR,1.03)=SSN
S RSUPDT(365,IENSTR,1.18)=SUBID
; Subscriber address
S FLD=$G(IBSEG(6))
S RSUPDT(365,IENSTR,5.01)=$P($P(FLD,HLCMP),HLSCMP) ; line 1
S RSUPDT(365,IENSTR,5.02)=$P(FLD,HLCMP,2) ; line 2
S RSUPDT(365,IENSTR,5.03)=$P(FLD,HLCMP,3) ; city
S STATE=+$$FIND1^DIC(5,,"X",$P(FLD,HLCMP,4),"C") I STATE>0 S RSUPDT(365,IENSTR,5.04)=STATE ; state
S RSUPDT(365,IENSTR,5.05)=$P(FLD,HLCMP,5) ; zip
S RSUPDT(365,IENSTR,5.06)=$P(FLD,HLCMP,6) ; country
S RSUPDT(365,IENSTR,5.07)=$P(FLD,HLCMP,8) ; country subdivision
D FILE^DIE("I","RSUPDT","ERROR") Q:$D(ERROR)
; IB*2*497 - the value at NAME OF INSURED (365,13.01) must be validated before it can be filed; pass
; the 'E' flag to DBS filer
K RSUPDT
S RSUPDT(365,IENSTR,13.01)=NAME
D FILE^DIE("E","RSUPDT","ERROR")
GT1X ;
Q
;
ZHS(EBDA,ERROR,IBSEG,RIEN) ; Process ZHS Healthcare services delivery segment
N IENSTR,RSUPDT,QUAL,VALUE
Q:$G(EBDA)="" ; Quit if EB multiple ien is missing
S IENSTR="+1,"_EBDA_","_RIEN_","
S RSUPDT(365.27,IENSTR,.01)=+$O(^IBCN(365,RIEN,2,EBDA,7,"B",""),-1)+1 ; ZHS sequence
; Benefit quantity & qualifier
S QUAL=$P($G(IBSEG(3)),HLCMP),VALUE=$G(IBSEG(4))
I VALUE'="",QUAL'="" S RSUPDT(365.27,IENSTR,.02)=$$NUMCHK^IBCNEHL2(VALUE),RSUPDT(365.27,IENSTR,.03)=QUAL
; Sampling frequency & qualifier
S QUAL=$P($G(IBSEG(5)),HLCMP),VALUE=$G(IBSEG(6))
I VALUE'="",QUAL'="" S RSUPDT(365.27,IENSTR,.04)=VALUE,RSUPDT(365.27,IENSTR,.05)=QUAL
; Time period & qualifier
S QUAL=$P($G(IBSEG(7)),HLCMP),VALUE=$G(IBSEG(8))
I VALUE'="",QUAL'="" S RSUPDT(365.27,IENSTR,.06)=$$NUMCHK^IBCNEHL2(VALUE),RSUPDT(365.27,IENSTR,.07)=QUAL
S RSUPDT(365.27,IENSTR,.08)=$P($G(IBSEG(9)),HLCMP) ; Delivery frequency
S RSUPDT(365.27,IENSTR,.09)=$P($G(IBSEG(10)),HLCMP) ; Delivery pattern
D CODECHK^IBCNEHLU(.RSUPDT) ; IB*2*497 check for new coded values
D UPDATE^DIE("E","RSUPDT",,"ERROR")
Q
;
ZRF(EBDA,ERROR,IBSEG,RIEN) ; Process ZRF Reference identification segment
N IENSTR,RSUPDT,QUAL,VALUE
Q:$G(EBDA)="" ; Quit if EB multiple ien is missing
S IENSTR="+1,"_EBDA_","_RIEN_","
S RSUPDT(365.291,IENSTR,.01)=+$O(^IBCN(365,RIEN,2,EBDA,10,"B",""),-1)+1 ; ZRF sequence
; Reference id & qualifier
S QUAL=$P($G(IBSEG(3)),HLCMP),VALUE=$G(IBSEG(4))
I VALUE'="",QUAL'="" S RSUPDT(365.291,IENSTR,.02)=VALUE,RSUPDT(365.291,IENSTR,.03)=QUAL
S RSUPDT(365.291,IENSTR,.04)=$G(IBSEG(5)) ; Description
D CODECHK^IBCNEHLU(.RSUPDT) ; IB*2*497 check for new coded values
D UPDATE^DIE("E","RSUPDT",,"ERROR")
Q
;
ZSD(EBDA,ERROR,IBSEG,RIEN) ; Process ZSD Subscriber date segment
N IENSTR,RSUPDT,QUAL,VALUE
Q:$G(EBDA)="" ; Quit if EB multiple ien is missing
S IENSTR="+1,"_EBDA_","_RIEN_","
S RSUPDT(365.28,IENSTR,.01)=+$O(^IBCN(365,RIEN,2,EBDA,8,"B",""),-1)+1 ; ZSD sequence
; Date & qualifier
S QUAL=$P($G(IBSEG(3)),HLCMP),VALUE=$P($G(IBSEG(5)),HLCMP)
I VALUE'="",QUAL'="" S RSUPDT(365.28,IENSTR,.02)=VALUE,RSUPDT(365.28,IENSTR,.03)=QUAL
S RSUPDT(365.28,IENSTR,.04)=$P($G(IBSEG(4)),HLCMP) ; Date format
D CODECHK^IBCNEHLU(.RSUPDT) ; IB*2*497 check for new coded values
D UPDATE^DIE("E","RSUPDT",,"ERROR")
Q
;
ZII(EBDA,ERROR,IBSEG,RIEN) ; Process ZII Subscriber additional info segment
N IENSTR,RSUPDT,QUAL,VALUE
Q:$G(EBDA)="" ; Quit if EB multiple ien is missing
S IENSTR="+1,"_EBDA_","_RIEN_","
S RSUPDT(365.29,IENSTR,.01)=+$O(^IBCN(365,RIEN,2,EBDA,9,"B",""),-1)+1 ; ZII sequence
; place of service or diagnosis (if qualifier is "BF" or "BK") & qualifier
S QUAL=$P($G(IBSEG(3)),HLCMP)
; IB*2*497 set up for Nature of Injury type qualifiers "GR", "NI", or null value
I (QUAL="")!(".GR.NI."[("."_QUAL_".")) D
. S RSUPDT(365.29,IENSTR,.05)=$P($G(IBSEG(5)),U,2) ;nature of injury code
. S RSUPDT(365.29,IENSTR,.06)=$P($G(IBSEG(6)),U,2) ; nature of injury code category
. S RSUPDT(365.29,IENSTR,.07)=$G(IBSEG(7)) ; nature of injury code free text description
E S RSUPDT(365.29,IENSTR,$S(".BF.BK."[("."_QUAL_"."):.03,1:.02))=$P($G(IBSEG(4)),HLCMP)
S RSUPDT(365.29,IENSTR,.04)=QUAL
D CODECHK^IBCNEHLU(.RSUPDT) ; IB*2*497 check for new coded values
D UPDATE^DIE("E","RSUPDT",,"ERROR")
Q
;
ZTY(EBDA,ERROR,IBSEG,RIEN) ; Process ZTY Benefit related entity segment
N FLD,IENSTR,RSUPDT,QUAL,VALUE
Q:$G(EBDA)="" ; Quit if EB multiple ien is missing
S IENSTR=EBDA_","_RIEN_","
; Entity id code & qualifier
S QUAL=$P($G(IBSEG(4)),HLCMP),VALUE=$P($G(IBSEG(3)),HLCMP)
I VALUE'="",QUAL'="" S RSUPDT(365.02,IENSTR,3.01)=VALUE,RSUPDT(365.02,IENSTR,3.02)=QUAL
; Entity name
S FLD=$G(IBSEG(5))
;S RSUPDT(365.02,IENSTR,3.03)=$P($P(FLD,HLCMP),HLSCMP)_","_$P(FLD,HLCMP,2)_" "_$P(FLD,HLCMP,3)_" "_$P(FLD,HLCMP,4)
S RSUPDT(365.02,IENSTR,3.03)=$P($P(FLD,HLCMP),HLSCMP)_" "_$P(FLD,HLCMP,2)_" "_$P(FLD,HLCMP,3)_" "_$P(FLD,HLCMP,4) ;ib*2*497 prevent orphan commas
; make sure that name is not empty
;I $TR(RSUPDT(365.02,IENSTR,3.03),", ")="" K RSUPDT(365.02,IENSTR,3.03)
I $TR(RSUPDT(365.02,IENSTR,3.03)," ")="" K RSUPDT(365.02,IENSTR,3.03) ;ib*2*497 remove comma from $TR statement
; Entity id & qualifier
S QUAL=$P($G(IBSEG(6)),HLCMP),VALUE=$G(IBSEG(7))
I VALUE'="",QUAL'="" S RSUPDT(365.02,IENSTR,3.04)=VALUE,RSUPDT(365.02,IENSTR,3.05)=QUAL
; IB*2*497 - entity relationship code
S RSUPDT(365.02,IENSTR,3.06)=$G(IBSEG(14))
; Entity address
S FLD=$G(IBSEG(8))
S RSUPDT(365.02,IENSTR,4.01)=$P($P(FLD,HLCMP),HLSCMP) ; line 1
S RSUPDT(365.02,IENSTR,4.02)=$P(FLD,HLCMP,2) ; line 2
S RSUPDT(365.02,IENSTR,4.03)=$P(FLD,HLCMP,3) ; city
S VALUE=+$$FIND1^DIC(5,,"X",$P(FLD,HLCMP,4),"C") I VALUE>0 S RSUPDT(365.02,IENSTR,4.04)=VALUE ; state
S RSUPDT(365.02,IENSTR,4.05)=$P(FLD,HLCMP,5) ; zip / postal code
S RSUPDT(365.02,IENSTR,4.06)=$P(FLD,HLCMP,6) ; country code
S RSUPDT(365.02,IENSTR,4.09)=$P(FLD,HLCMP,8) ; country subdivision code
; Entity location & qualifier
S QUAL=$G(IBSEG(9)),VALUE=$G(IBSEG(10))
I VALUE'="",QUAL'="" S RSUPDT(365.02,IENSTR,4.07)=VALUE,RSUPDT(365.02,IENSTR,4.08)=QUAL
; Provider code
S RSUPDT(365.02,IENSTR,5.01)=$P($G(IBSEG(11)),HLCMP)
; Reference id & qualifier
S QUAL=$P($G(IBSEG(12)),HLCMP),VALUE=$G(IBSEG(13))
I VALUE'="",QUAL'="" S RSUPDT(365.02,IENSTR,5.02)=VALUE,RSUPDT(365.02,IENSTR,5.03)=QUAL
D CODECHK^IBCNEHLU(.RSUPDT) ; IB*2*497 check for new coded values
D FILE^DIE("ET","RSUPDT","ERROR")
Q
;
G2OCTD(EBDA,ERROR,IBSEG,RIEN) ; Process G2O.CTD Benefit related entity contact data segment
N FLD,IENSTR,RSUPDT,QUAL,VALUE
Q:$G(EBDA)="" ; Quit if EB multiple ien is missing
S IENSTR="+1,"_EBDA_","_RIEN_","
S RSUPDT(365.26,IENSTR,.01)=+$O(^IBCN(365,RIEN,2,EBDA,6,"B",""),-1)+1 ; G2O.CTD sequence
; Contact name
S FLD=$G(IBSEG(3))
S RSUPDT(365.26,IENSTR,.02)=$P(FLD,HLCMP,5)_" "_$P($P(FLD,HLCMP),HLSCMP)_","_$P(FLD,HLCMP,2)_" "_$P(FLD,HLCMP,3)_" "_$P(FLD,HLCMP,4)_" "_$P(FLD,HLCMP,6)
; make sure that name is not empty
I $TR(RSUPDT(365.26,IENSTR,.02),", ")="" K RSUPDT(365.26,IENSTR,.02)
; Contact number & qualifier
S FLD=$G(IBSEG(6)),QUAL=$P(FLD,HLCMP,9),VALUE=$P(FLD,HLCMP)
I VALUE'="",QUAL'="" S RSUPDT(365.26,IENSTR,1)=VALUE,RSUPDT(365.26,IENSTR,.04)=QUAL ;ib*2*497 stuff COMMUNICATION NUMBER data into its new location (365.26,1)
D CODECHK^IBCNEHLU(.RSUPDT) ; IB*2*497 check for new coded values
D UPDATE^DIE("E","RSUPDT",,"ERROR")
Q
;
ERR(ERDA,ERROR,IBSEG,RIEN) ; Process ERR Reject reasons segment
N I,IENARR,IENSTR,FLD,LOC,RSUPDT,VAL
S IENSTR="+1,"_RIEN_","
S RSUPDT(365.06,IENSTR,.01)=+$O(^IBCN(365,RIEN,6,"B",""),-1)+1 ; ERR sequence
S FLD=$G(IBSEG(3)),LOC=$P(FLD,HLCMP)
F I=2:1:6 S VAL=$P(FLD,HLCMP,2) I VAL'="" S LOC=LOC_$S(I=2!(I=4):"("_VAL_")",1:"."_VAL_".")
S RSUPDT(365.06,IENSTR,.02)=LOC ; Error location (HL7)
S RSUPDT(365.06,IENSTR,.03)=$P($G(IBSEG(6)),HLCMP) ; Reject reason
S RSUPDT(365.06,IENSTR,.04)=$G(IBSEG(9)) ; Action code
S RSUPDT(365.06,IENSTR,.05)=$G(IBSEG(8)) ; Loop id
S RSUPDT(365.06,IENSTR,.06)=$P($G(IBSEG(6)),HLCMP,3) ; Source
D CODECHK^IBCNEHLU(.RSUPDT) ; IB*2*497 check for new coded values
D UPDATE^DIE("E","RSUPDT","IENARR","ERROR")
S ERDA=IENARR(1)
Q
;
NTE(ERDA,ERROR,IBSEG,RIEN) ; Process NTE segment
N DA,IENS,MSG,MSGSTR,RSUPDT,Z
S DA(1)=RIEN,DA=ERDA
S IENS=$$IENS^DILF(.DA)
S MSGSTR=$G(IBSEG(4))
F Z=1:1 S MSG=$P(MSGSTR,HLREP,Z) Q:MSG="" S RSUPDT(365.061,"+"_Z_","_IENS,".01")=MSG ;IB*506 Q:'MSG
I $D(RSUPDT) D UPDATE^DIE("E","RSUPDT",,"ERROR")
Q
;
ZTP(ERROR,IBSEG,RIEN) ; Process ZTP Subscriber date (subscriber level) segment
N IENSTR,QUAL,RSUPDT,VALUE,Z
S IENSTR="+1,"_RIEN_","
S RSUPDT(365.07,IENSTR,.01)=+$O(^IBCN(365,RIEN,7,"B",""),-1)+1 ; ZTP sequence
; Date & qualifier
S QUAL=$P($G(IBSEG(3)),HLCMP),VALUE=$P($P($G(IBSEG(4)),HLCMP),HLSCMP)
S Z=$P($P($G(IBSEG(4)),HLCMP,2),HLSCMP) I Z'="" S VALUE=VALUE_" - "_Z
I VALUE'="",QUAL'="" S RSUPDT(365.07,IENSTR,.02)=VALUE,RSUPDT(365.07,IENSTR,.03)=QUAL
S RSUPDT(365.07,IENSTR,.04)=$G(IBSEG(5)) ; Loop id
D CODECHK^IBCNEHLU(.RSUPDT) ; IB*2*497 check for new coded values
D UPDATE^DIE("E","RSUPDT",,"ERROR")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNEHL4 16979 printed Oct 16, 2024@18:15:17 Page 2
IBCNEHL4 ;DAOU/ALA - HL7 Process Incoming RPI Msgs (cont.) ;26-JUN-2002
+1 ;;2.0;INTEGRATED BILLING;**300,416,438,497,506,519,621,743**;21-MAR-94;Build 18
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;**Program Description**
+5 ; This pgm will process the non-repeating segments of the
+6 ; incoming eIV response msgs.
+7 ; It was separated out from IBCNEHL2 to conserve space.
+8 ;
+9 ; This routine is based on IBCNEHLP which was introduced with patch 184, and subsequently
+10 ; patched with patches 252 and 271. IBCNEHLP is obsolete and deleted with patch 300.
+11 ;
+12 ; * Each of these tags are called by IBCNEHL2.
+13 ;
+14 ; Variables
+15 ; SEG = HL7 Seg Name
+16 ; MSGID = Original Msg Control ID
+17 ; ACK = Acknowledgment (AA=Accepted, AE=Error)
+18 ; ERTXT = Error Msg Text
+19 ; ERFLG = Error quit flag
+20 ; ERACT = Error Action
+21 ; ERCON = Error Condition
+22 ; RIEN = Response Record IEN
+23 ; IBSEG = Array of the segment
+24 ;
+25 ; No direct calls
QUIT
+26 ;
+27 ; IB*2*519 Only fixed line 2 of the routine. Changed "..497*506" to "..497,506"
+28 ;
MSA ; Process the MSA seg
+1 ;
+2 ; Input:
+3 ; IBSEG,MGRP
+4 ;
+5 ; Output:
+6 ; ERACT,ERCON,ERROR,ERTXT,RIEN,TRACE,ACK
+7 ;
+8 NEW MSGID,RSUPDT,VRFDT
+9 SET ACK=$GET(IBSEG(2))
SET MSGID=$GET(IBSEG(3))
SET TRACE=$GET(IBSEG(4))
+10 SET ERTXT=$$DECHL7^IBCNEHL2($PIECE($GET(IBSEG(7)),$EXTRACT(HLECH),2))
SET ERACT=$GET(IBSEG(6))
SET ERCON=$PIECE($GET(IBSEG(7)),$EXTRACT(HLECH),1)
+11 ;
+12 ; If no Control Id, send Mailman error msg
+13 IF MSGID=""
DO ERRMSA(TRACE,MGRP)
SET ERFLG=1
GOTO MSAX
+14 ;
+15 ; Check for msg id/payer combination and get response IEN
+16 DO PCK^IBCNEHL3
+17 ;
+18 ; If no record IEN, quit
+19 IF $GET(RIEN)=""
GOTO MSAX
+20 ;
+21 ;IB*2.0*621/TAZ - Process EICD Error messages
+22 IF EVENTYP=1
Begin DoDot:1
+23 NEW DFN
+24 SET DFN=$$GET1^DIQ(365,RIEN_",",.02,"I")
+25 SET IBTRACK(0,.04)=TRACE
+26 SET IBTRACK(0,.06)=RIEN
+27 IF ERTXT=""
SET IBTRACK(0,.07)=1
QUIT
+28 IF $$UP^XLFSTR(ERTXT)["NO ACTIVE POLICIES"
SET IBTRACK(0,.07)=2
QUIT
+29 IF $$UP^XLFSTR(ERTXT)["TIMEOUT"
Begin DoDot:2
+30 SET IBTRACK(0,.07)=3
+31 ;Need to remove (EICD Last Date Run) from Patient File #2 - IB*2.0*621
+32 SET DA=DFN
SET DIE="^DPT("
SET DR="2001///@"
+33 DO ^DIE
+34 KILL DA,DIE,DR
End DoDot:2
QUIT
+35 SET IBTRACK(0,.07)=0
End DoDot:1
+36 ; Update record w/info
+37 ;set TRANSMISSION STATUS to 'Response Received'
SET RSUPDT(365,RIEN_",",.09)=TRACE
SET RSUPDT(365,RIEN_",",.06)=3
+38 SET RSUPDT(365,RIEN_",",4.01)=ERTXT
+39 ;update 'DATE/TIME RECEIVED'
SET VRFDT=$$NOW^XLFDT()
SET RSUPDT(365,RIEN_",",.07)=VRFDT
+40 ;
+41 ; Update w/internal values
+42 DO FILE^DIE("I","RSUPDT","ERROR")
+43 ;
+44 SET RSUPDT(365,RIEN_",",1.14)=ERCON
SET RSUPDT(365,RIEN_",",1.15)=ERACT
+45 ;
+46 ; Update w/external values
+47 DO FILE^DIE("ET","RSUPDT","ERROR")
+48 ;
+49 DO TQCLOSE
MSAX ;
+1 QUIT
+2 ;
TQCLOSE ;IB*743/CKB
+1 ;For an original response, set the Transmission Queue Status to 'Response Received' &
+2 ; update remaining retries to comm failure (5)
+3 NEW RDAT0,RSTYPE,TQN
+4 SET RDAT0=$GET(^IBCN(365,RIEN,0))
+5 SET TQN=$PIECE(RDAT0,U,5)
SET RSTYPE=$PIECE(RDAT0,U,10)
+6 IF $GET(RSTYPE)="O"
DO SST^IBCNEUT2(TQN,3)
DO RSTA^IBCNEUT7(TQN)
+7 QUIT
+8 ;
ERRMSA(TRACE,MGRP) ; Msg Control Id is blank - Send Mailman error msg
+1 ;
+2 NEW HCT,ICN,MSG,MSGCT,NAME,XMSUB
+3 ;
+4 ;1st find the PID seg to extract ICN and patient name
+5 DO GTICNM^IBCNEHLU(.ICN,.NAME)
+6 ;
+7 ;Send the Mailman error msg
+8 SET XMSUB="Message Control Id Field is Blank"
SET MSGCT=$SELECT(TRACE="":4,1:3)
+9 SET MSG(1)="A response was received w/a blank Message Control Id"
+10 IF TRACE=""
SET MSG(1)=MSG(1)_" and Trace #"
+11 SET MSG(2)="for "_$SELECT(TRACE'="":"Trace #: "_TRACE_", ",1:"")_"ICN #: "_ICN_", Patient: "_NAME_"."
+12 IF TRACE=""
Begin DoDot:1
+13 SET MSG(3)="It is likely that there are communication issues with the EC."
End DoDot:1
+14 SET MSG(MSGCT)="This response cannot be processed. Please contact the Help Desk."
+15 DO MSG^IBCNEUT5(MGRP,XMSUB,"MSG(")
+16 QUIT
+17 ;
PID ; Process the PID seg
+1 NEW DFN,DOB,DOD,FLD,ICN,IENSTR,LFAC,LUPDT,NAME,RSUPDT,SEX,SSN,STATE,XDFN,IDLIST
+2 NEW SUBCNT,SUBC,SUBCID,SUBCDATA,IERN
+3 ;
+4 SET ERFLG=0
+5 SET DOB=$GET(IBSEG(8))
SET SEX=$GET(IBSEG(9))
+6 SET NAME=$GET(IBSEG(6))
+7 SET DOD=$GET(IBSEG(30))
SET LUPDT=$GET(IBSEG(34))
SET LFAC=$GET(IBSEG(35))
+8 ;
+9 ; Parse Repeating ID field to fill in other identifiers
+10 SET (ICN,SSN,DFN)=""
+11 SET IDLIST=$GET(IBSEG(4))
+12 FOR SUBCNT=1:1:$LENGTH(IDLIST,$EXTRACT(HLECH,2,2))
Begin DoDot:1
+13 SET SUBC=$PIECE(IDLIST,$EXTRACT(HLECH,2,2),SUBCNT)
+14 ; Identifier Type Code
SET SUBCID=$PIECE(SUBC,$EXTRACT(HLECH),5)
+15 ; Data Value
SET SUBCDATA=$PIECE(SUBC,$EXTRACT(HLECH),1)
+16 IF SUBCID="PI"
SET DFN=SUBCDATA
+17 IF SUBCID="SS"
SET SSN=SUBCDATA
+18 IF SUBCID="NI"
SET ICN=SUBCDATA
End DoDot:1
+19 ;
+20 ; Convert data from HL7 format to VistA format
+21 SET NAME=$$DECHL7^IBCNEHL2($$FMNAME^HLFNC(NAME,HLECH))
+22 SET DOD=$$FMDATE^HLFNC(DOD)
SET DOB=$$FMDATE^HLFNC(DOB)
SET LUPDT=$$FMDATE^HLFNC(LUPDT)
+23 ;
+24 ; Use ICN to find the patients DFN at this site
+25 IF ICN'=""
Begin DoDot:1
+26 SET XDFN=$$GETDFN^MPIF001(ICN)
+27 ; if unsuccessful, wait 5 sec and try one more time
+28 IF +$GET(XDFN)'>0
HANG 5
SET XDFN=$$GETDFN^MPIF001(ICN)
+29 QUIT
End DoDot:1
+30 IF +$GET(XDFN)'>0
IF +$GET(ICN)>0
Begin DoDot:1
+31 SET ERFLG=1
SET IERN=$$ERRN^IBCNEUT7("ERROR(""DIERR"")")
+32 SET ERROR("DIERR",IERN,"TEXT",1)="Unable to determine the patient's DFN value for this site."
+33 SET ERROR("DIERR",IERN,"TEXT",2)=" The ICN for the patient in this response is ICN: "_ICN
+34 SET ERROR("DIERR",IERN,"TEXT",3)=" eIV was unable to file the response information."
End DoDot:1
QUIT
+35 ;
+36 IF +ICN>0
SET DFN=XDFN
+37 ;
+38 ; Perform date of death check
+39 IF DOD'=""
DO DODCK^IBCNEHLU(DFN,DOD,MGRP,NAME,RIEN,SSN)
+40 ;
+41 SET IENSTR=RIEN_","
+42 IF $PIECE(^IBCN(365,RIEN,0),U,2)=""
SET RSUPDT(365,IENSTR,.02)=DFN
+43 ;IB*2.0*621/TAZ - Only file DOB, SEX, SSN, PT RELATIONSHIP and ADDRESS on regular 271s
+44 IF EVENTYP'=1
Begin DoDot:1
+45 SET RSUPDT(365,IENSTR,1.02)=DOB
SET RSUPDT(365,IENSTR,1.04)=SEX
+46 SET RSUPDT(365,IENSTR,1.09)="01"
+47 SET RSUPDT(365,IENSTR,1.03)=SSN
+48 ; Subscriber address
+49 SET FLD=$GET(IBSEG(12))
+50 ; line 1
SET RSUPDT(365,IENSTR,5.01)=$PIECE($PIECE(FLD,HLCMP),HLSCMP)
+51 ; line 2
SET RSUPDT(365,IENSTR,5.02)=$PIECE(FLD,HLCMP,2)
+52 ; city
SET RSUPDT(365,IENSTR,5.03)=$PIECE(FLD,HLCMP,3)
+53 ; state
SET STATE=+$$FIND1^DIC(5,,"X",$PIECE(FLD,HLCMP,4),"C")
IF STATE>0
SET RSUPDT(365,IENSTR,5.04)=STATE
+54 ; zip
SET RSUPDT(365,IENSTR,5.05)=$PIECE(FLD,HLCMP,5)
+55 ; country
SET RSUPDT(365,IENSTR,5.06)=$PIECE(FLD,HLCMP,6)
+56 ; country subdivision
SET RSUPDT(365,IENSTR,5.07)=$PIECE(FLD,HLCMP,8)
End DoDot:1
+57 SET RSUPDT(365,IENSTR,1.16)=DOD
+58 SET RSUPDT(365,IENSTR,1.08)="v"
+59 DO FILE^DIE("I","RSUPDT","ERROR")
if $DATA(ERROR)
QUIT
+60 ; IB*2*497 - the value at NAME OF INSURED (365,13.01) must be validated before it can be filed; pass
+61 ; the 'E' flag to DBS filer
+62 ; IB*2.0*621/TAZ Only file NAME OF INSURED on regular 271's (check for EVENTYP)
+63 IF EVENTYP'=1
Begin DoDot:1
+64 KILL RSUPDT
+65 SET RSUPDT(365,IENSTR,13.01)=NAME
+66 DO FILE^DIE("E","RSUPDT","ERROR")
End DoDot:1
PIDX ;
+1 QUIT
+2 ;
GT1 ; Process the GT1 Guarantor seg
+1 ;
+2 ; Input:
+3 ; IBSEG,RIEN
+4 ;
+5 ; Output:
+6 ; ERROR,SUBID
+7 ;
+8 NEW DOB,IENSTR,NAME,RSUPDT,SEX,SSN,SUBIDC
+9 SET NAME=$GET(IBSEG(4))
SET DOB=$GET(IBSEG(9))
SET SEX=$GET(IBSEG(10))
+10 ; FSC NO LONGER SENDS SSN for regular 271's
SET SSN=$GET(IBSEG(13))
+11 ;
+12 ; Raw field with sub-comp.
SET SUBIDC=$GET(IBSEG(3))
+13 SET SUBID=$PIECE(SUBIDC,$EXTRACT(HLECH),1)
+14 SET SUBID=$$DECHL7^IBCNEHL2(SUBID)
+15 ;
+16 SET DOB=$$FMDATE^HLFNC(DOB)
SET NAME=$$DECHL7^IBCNEHL2($$FMNAME^HLFNC(NAME,HLECH))
+17 ;
+18 ;IB*2.0*621/TAZ - Process EICD Identification Response and Quit
+19 IF EVENTYP=1
Begin DoDot:1
+20 NEW FLG,SETID,STATE
+21 SET SETID=$GET(IBSEG(2))
+22 SET IBTRACK(SETID,.04)=SUBID
+23 SET IBTRACK(SETID,.06)=SSN
+24 if DOB'=""
SET IBTRACK(SETID,.07)=DOB
+25 SET IBTRACK(SETID,.08)=SEX
+26 SET IBTRACK(SETID,.09)=NAME
+27 SET FLD=$GET(IBSEG(6))
+28 ;Subscriber Address 1
SET IBTRACK(SETID,.1)=$PIECE($PIECE(FLD,HLCMP),HLSCMP)
+29 ;Subscriber Address 2
SET IBTRACK(SETID,.11)=$PIECE(FLD,HLCMP,2)
+30 ;Subscriber City
SET IBTRACK(SETID,.12)=$PIECE(FLD,HLCMP,3)
+31 ;Subscriber State
SET STATE=+$$FIND1^DIC(5,,"X",$PIECE(FLD,HLCMP,4),"C")
IF STATE>0
SET IBTRACK(SETID,.13)=STATE
+32 ;Subscriber Zip
SET IBTRACK(SETID,.14)=$PIECE(FLD,HLCMP,5)
+33 SET IBTRACK(SETID,.15)=1
End DoDot:1
GOTO GT1X
+34 SET IENSTR=RIEN_","
+35 SET RSUPDT(365,RIEN_",",1.08)=""
+36 if DOB'=""
SET RSUPDT(365,IENSTR,1.02)=DOB
+37 SET RSUPDT(365,RIEN_",",1.04)=SEX
+38 SET RSUPDT(365,IENSTR,1.03)=SSN
+39 SET RSUPDT(365,IENSTR,1.18)=SUBID
+40 ; Subscriber address
+41 SET FLD=$GET(IBSEG(6))
+42 ; line 1
SET RSUPDT(365,IENSTR,5.01)=$PIECE($PIECE(FLD,HLCMP),HLSCMP)
+43 ; line 2
SET RSUPDT(365,IENSTR,5.02)=$PIECE(FLD,HLCMP,2)
+44 ; city
SET RSUPDT(365,IENSTR,5.03)=$PIECE(FLD,HLCMP,3)
+45 ; state
SET STATE=+$$FIND1^DIC(5,,"X",$PIECE(FLD,HLCMP,4),"C")
IF STATE>0
SET RSUPDT(365,IENSTR,5.04)=STATE
+46 ; zip
SET RSUPDT(365,IENSTR,5.05)=$PIECE(FLD,HLCMP,5)
+47 ; country
SET RSUPDT(365,IENSTR,5.06)=$PIECE(FLD,HLCMP,6)
+48 ; country subdivision
SET RSUPDT(365,IENSTR,5.07)=$PIECE(FLD,HLCMP,8)
+49 DO FILE^DIE("I","RSUPDT","ERROR")
if $DATA(ERROR)
QUIT
+50 ; IB*2*497 - the value at NAME OF INSURED (365,13.01) must be validated before it can be filed; pass
+51 ; the 'E' flag to DBS filer
+52 KILL RSUPDT
+53 SET RSUPDT(365,IENSTR,13.01)=NAME
+54 DO FILE^DIE("E","RSUPDT","ERROR")
GT1X ;
+1 QUIT
+2 ;
ZHS(EBDA,ERROR,IBSEG,RIEN) ; Process ZHS Healthcare services delivery segment
+1 NEW IENSTR,RSUPDT,QUAL,VALUE
+2 ; Quit if EB multiple ien is missing
if $GET(EBDA)=""
QUIT
+3 SET IENSTR="+1,"_EBDA_","_RIEN_","
+4 ; ZHS sequence
SET RSUPDT(365.27,IENSTR,.01)=+$ORDER(^IBCN(365,RIEN,2,EBDA,7,"B",""),-1)+1
+5 ; Benefit quantity & qualifier
+6 SET QUAL=$PIECE($GET(IBSEG(3)),HLCMP)
SET VALUE=$GET(IBSEG(4))
+7 IF VALUE'=""
IF QUAL'=""
SET RSUPDT(365.27,IENSTR,.02)=$$NUMCHK^IBCNEHL2(VALUE)
SET RSUPDT(365.27,IENSTR,.03)=QUAL
+8 ; Sampling frequency & qualifier
+9 SET QUAL=$PIECE($GET(IBSEG(5)),HLCMP)
SET VALUE=$GET(IBSEG(6))
+10 IF VALUE'=""
IF QUAL'=""
SET RSUPDT(365.27,IENSTR,.04)=VALUE
SET RSUPDT(365.27,IENSTR,.05)=QUAL
+11 ; Time period & qualifier
+12 SET QUAL=$PIECE($GET(IBSEG(7)),HLCMP)
SET VALUE=$GET(IBSEG(8))
+13 IF VALUE'=""
IF QUAL'=""
SET RSUPDT(365.27,IENSTR,.06)=$$NUMCHK^IBCNEHL2(VALUE)
SET RSUPDT(365.27,IENSTR,.07)=QUAL
+14 ; Delivery frequency
SET RSUPDT(365.27,IENSTR,.08)=$PIECE($GET(IBSEG(9)),HLCMP)
+15 ; Delivery pattern
SET RSUPDT(365.27,IENSTR,.09)=$PIECE($GET(IBSEG(10)),HLCMP)
+16 ; IB*2*497 check for new coded values
DO CODECHK^IBCNEHLU(.RSUPDT)
+17 DO UPDATE^DIE("E","RSUPDT",,"ERROR")
+18 QUIT
+19 ;
ZRF(EBDA,ERROR,IBSEG,RIEN) ; Process ZRF Reference identification segment
+1 NEW IENSTR,RSUPDT,QUAL,VALUE
+2 ; Quit if EB multiple ien is missing
if $GET(EBDA)=""
QUIT
+3 SET IENSTR="+1,"_EBDA_","_RIEN_","
+4 ; ZRF sequence
SET RSUPDT(365.291,IENSTR,.01)=+$ORDER(^IBCN(365,RIEN,2,EBDA,10,"B",""),-1)+1
+5 ; Reference id & qualifier
+6 SET QUAL=$PIECE($GET(IBSEG(3)),HLCMP)
SET VALUE=$GET(IBSEG(4))
+7 IF VALUE'=""
IF QUAL'=""
SET RSUPDT(365.291,IENSTR,.02)=VALUE
SET RSUPDT(365.291,IENSTR,.03)=QUAL
+8 ; Description
SET RSUPDT(365.291,IENSTR,.04)=$GET(IBSEG(5))
+9 ; IB*2*497 check for new coded values
DO CODECHK^IBCNEHLU(.RSUPDT)
+10 DO UPDATE^DIE("E","RSUPDT",,"ERROR")
+11 QUIT
+12 ;
ZSD(EBDA,ERROR,IBSEG,RIEN) ; Process ZSD Subscriber date segment
+1 NEW IENSTR,RSUPDT,QUAL,VALUE
+2 ; Quit if EB multiple ien is missing
if $GET(EBDA)=""
QUIT
+3 SET IENSTR="+1,"_EBDA_","_RIEN_","
+4 ; ZSD sequence
SET RSUPDT(365.28,IENSTR,.01)=+$ORDER(^IBCN(365,RIEN,2,EBDA,8,"B",""),-1)+1
+5 ; Date & qualifier
+6 SET QUAL=$PIECE($GET(IBSEG(3)),HLCMP)
SET VALUE=$PIECE($GET(IBSEG(5)),HLCMP)
+7 IF VALUE'=""
IF QUAL'=""
SET RSUPDT(365.28,IENSTR,.02)=VALUE
SET RSUPDT(365.28,IENSTR,.03)=QUAL
+8 ; Date format
SET RSUPDT(365.28,IENSTR,.04)=$PIECE($GET(IBSEG(4)),HLCMP)
+9 ; IB*2*497 check for new coded values
DO CODECHK^IBCNEHLU(.RSUPDT)
+10 DO UPDATE^DIE("E","RSUPDT",,"ERROR")
+11 QUIT
+12 ;
ZII(EBDA,ERROR,IBSEG,RIEN) ; Process ZII Subscriber additional info segment
+1 NEW IENSTR,RSUPDT,QUAL,VALUE
+2 ; Quit if EB multiple ien is missing
if $GET(EBDA)=""
QUIT
+3 SET IENSTR="+1,"_EBDA_","_RIEN_","
+4 ; ZII sequence
SET RSUPDT(365.29,IENSTR,.01)=+$ORDER(^IBCN(365,RIEN,2,EBDA,9,"B",""),-1)+1
+5 ; place of service or diagnosis (if qualifier is "BF" or "BK") & qualifier
+6 SET QUAL=$PIECE($GET(IBSEG(3)),HLCMP)
+7 ; IB*2*497 set up for Nature of Injury type qualifiers "GR", "NI", or null value
+8 IF (QUAL="")!(".GR.NI."[("."_QUAL_"."))
Begin DoDot:1
+9 ;nature of injury code
SET RSUPDT(365.29,IENSTR,.05)=$PIECE($GET(IBSEG(5)),U,2)
+10 ; nature of injury code category
SET RSUPDT(365.29,IENSTR,.06)=$PIECE($GET(IBSEG(6)),U,2)
+11 ; nature of injury code free text description
SET RSUPDT(365.29,IENSTR,.07)=$GET(IBSEG(7))
End DoDot:1
+12 IF '$TEST
SET RSUPDT(365.29,IENSTR,$SELECT(".BF.BK."[("."_QUAL_"."):.03,1:.02))=$PIECE($GET(IBSEG(4)),HLCMP)
+13 SET RSUPDT(365.29,IENSTR,.04)=QUAL
+14 ; IB*2*497 check for new coded values
DO CODECHK^IBCNEHLU(.RSUPDT)
+15 DO UPDATE^DIE("E","RSUPDT",,"ERROR")
+16 QUIT
+17 ;
ZTY(EBDA,ERROR,IBSEG,RIEN) ; Process ZTY Benefit related entity segment
+1 NEW FLD,IENSTR,RSUPDT,QUAL,VALUE
+2 ; Quit if EB multiple ien is missing
if $GET(EBDA)=""
QUIT
+3 SET IENSTR=EBDA_","_RIEN_","
+4 ; Entity id code & qualifier
+5 SET QUAL=$PIECE($GET(IBSEG(4)),HLCMP)
SET VALUE=$PIECE($GET(IBSEG(3)),HLCMP)
+6 IF VALUE'=""
IF QUAL'=""
SET RSUPDT(365.02,IENSTR,3.01)=VALUE
SET RSUPDT(365.02,IENSTR,3.02)=QUAL
+7 ; Entity name
+8 SET FLD=$GET(IBSEG(5))
+9 ;S RSUPDT(365.02,IENSTR,3.03)=$P($P(FLD,HLCMP),HLSCMP)_","_$P(FLD,HLCMP,2)_" "_$P(FLD,HLCMP,3)_" "_$P(FLD,HLCMP,4)
+10 ;ib*2*497 prevent orphan commas
SET RSUPDT(365.02,IENSTR,3.03)=$PIECE($PIECE(FLD,HLCMP),HLSCMP)_" "_$PIECE(FLD,HLCMP,2)_" "_$PIECE(FLD,HLCMP,3)_" "_$PIECE(FLD,HLCMP,4)
+11 ; make sure that name is not empty
+12 ;I $TR(RSUPDT(365.02,IENSTR,3.03),", ")="" K RSUPDT(365.02,IENSTR,3.03)
+13 ;ib*2*497 remove comma from $TR statement
IF $TRANSLATE(RSUPDT(365.02,IENSTR,3.03)," ")=""
KILL RSUPDT(365.02,IENSTR,3.03)
+14 ; Entity id & qualifier
+15 SET QUAL=$PIECE($GET(IBSEG(6)),HLCMP)
SET VALUE=$GET(IBSEG(7))
+16 IF VALUE'=""
IF QUAL'=""
SET RSUPDT(365.02,IENSTR,3.04)=VALUE
SET RSUPDT(365.02,IENSTR,3.05)=QUAL
+17 ; IB*2*497 - entity relationship code
+18 SET RSUPDT(365.02,IENSTR,3.06)=$GET(IBSEG(14))
+19 ; Entity address
+20 SET FLD=$GET(IBSEG(8))
+21 ; line 1
SET RSUPDT(365.02,IENSTR,4.01)=$PIECE($PIECE(FLD,HLCMP),HLSCMP)
+22 ; line 2
SET RSUPDT(365.02,IENSTR,4.02)=$PIECE(FLD,HLCMP,2)
+23 ; city
SET RSUPDT(365.02,IENSTR,4.03)=$PIECE(FLD,HLCMP,3)
+24 ; state
SET VALUE=+$$FIND1^DIC(5,,"X",$PIECE(FLD,HLCMP,4),"C")
IF VALUE>0
SET RSUPDT(365.02,IENSTR,4.04)=VALUE
+25 ; zip / postal code
SET RSUPDT(365.02,IENSTR,4.05)=$PIECE(FLD,HLCMP,5)
+26 ; country code
SET RSUPDT(365.02,IENSTR,4.06)=$PIECE(FLD,HLCMP,6)
+27 ; country subdivision code
SET RSUPDT(365.02,IENSTR,4.09)=$PIECE(FLD,HLCMP,8)
+28 ; Entity location & qualifier
+29 SET QUAL=$GET(IBSEG(9))
SET VALUE=$GET(IBSEG(10))
+30 IF VALUE'=""
IF QUAL'=""
SET RSUPDT(365.02,IENSTR,4.07)=VALUE
SET RSUPDT(365.02,IENSTR,4.08)=QUAL
+31 ; Provider code
+32 SET RSUPDT(365.02,IENSTR,5.01)=$PIECE($GET(IBSEG(11)),HLCMP)
+33 ; Reference id & qualifier
+34 SET QUAL=$PIECE($GET(IBSEG(12)),HLCMP)
SET VALUE=$GET(IBSEG(13))
+35 IF VALUE'=""
IF QUAL'=""
SET RSUPDT(365.02,IENSTR,5.02)=VALUE
SET RSUPDT(365.02,IENSTR,5.03)=QUAL
+36 ; IB*2*497 check for new coded values
DO CODECHK^IBCNEHLU(.RSUPDT)
+37 DO FILE^DIE("ET","RSUPDT","ERROR")
+38 QUIT
+39 ;
G2OCTD(EBDA,ERROR,IBSEG,RIEN) ; Process G2O.CTD Benefit related entity contact data segment
+1 NEW FLD,IENSTR,RSUPDT,QUAL,VALUE
+2 ; Quit if EB multiple ien is missing
if $GET(EBDA)=""
QUIT
+3 SET IENSTR="+1,"_EBDA_","_RIEN_","
+4 ; G2O.CTD sequence
SET RSUPDT(365.26,IENSTR,.01)=+$ORDER(^IBCN(365,RIEN,2,EBDA,6,"B",""),-1)+1
+5 ; Contact name
+6 SET FLD=$GET(IBSEG(3))
+7 SET RSUPDT(365.26,IENSTR,.02)=$PIECE(FLD,HLCMP,5)_" "_$PIECE($PIECE(FLD,HLCMP),HLSCMP)_","_$PIECE(FLD,HLCMP,2)_" "_$PIECE(FLD,HLCMP,3)_" "_$PIECE(FLD,HLCMP,4)_" "_$PIECE(FLD,HLCMP,6)
+8 ; make sure that name is not empty
+9 IF $TRANSLATE(RSUPDT(365.26,IENSTR,.02),", ")=""
KILL RSUPDT(365.26,IENSTR,.02)
+10 ; Contact number & qualifier
+11 SET FLD=$GET(IBSEG(6))
SET QUAL=$PIECE(FLD,HLCMP,9)
SET VALUE=$PIECE(FLD,HLCMP)
+12 ;ib*2*497 stuff COMMUNICATION NUMBER data into its new location (365.26,1)
IF VALUE'=""
IF QUAL'=""
SET RSUPDT(365.26,IENSTR,1)=VALUE
SET RSUPDT(365.26,IENSTR,.04)=QUAL
+13 ; IB*2*497 check for new coded values
DO CODECHK^IBCNEHLU(.RSUPDT)
+14 DO UPDATE^DIE("E","RSUPDT",,"ERROR")
+15 QUIT
+16 ;
ERR(ERDA,ERROR,IBSEG,RIEN) ; Process ERR Reject reasons segment
+1 NEW I,IENARR,IENSTR,FLD,LOC,RSUPDT,VAL
+2 SET IENSTR="+1,"_RIEN_","
+3 ; ERR sequence
SET RSUPDT(365.06,IENSTR,.01)=+$ORDER(^IBCN(365,RIEN,6,"B",""),-1)+1
+4 SET FLD=$GET(IBSEG(3))
SET LOC=$PIECE(FLD,HLCMP)
+5 FOR I=2:1:6
SET VAL=$PIECE(FLD,HLCMP,2)
IF VAL'=""
SET LOC=LOC_$SELECT(I=2!(I=4):"("_VAL_")",1:"."_VAL_".")
+6 ; Error location (HL7)
SET RSUPDT(365.06,IENSTR,.02)=LOC
+7 ; Reject reason
SET RSUPDT(365.06,IENSTR,.03)=$PIECE($GET(IBSEG(6)),HLCMP)
+8 ; Action code
SET RSUPDT(365.06,IENSTR,.04)=$GET(IBSEG(9))
+9 ; Loop id
SET RSUPDT(365.06,IENSTR,.05)=$GET(IBSEG(8))
+10 ; Source
SET RSUPDT(365.06,IENSTR,.06)=$PIECE($GET(IBSEG(6)),HLCMP,3)
+11 ; IB*2*497 check for new coded values
DO CODECHK^IBCNEHLU(.RSUPDT)
+12 DO UPDATE^DIE("E","RSUPDT","IENARR","ERROR")
+13 SET ERDA=IENARR(1)
+14 QUIT
+15 ;
NTE(ERDA,ERROR,IBSEG,RIEN) ; Process NTE segment
+1 NEW DA,IENS,MSG,MSGSTR,RSUPDT,Z
+2 SET DA(1)=RIEN
SET DA=ERDA
+3 SET IENS=$$IENS^DILF(.DA)
+4 SET MSGSTR=$GET(IBSEG(4))
+5 ;IB*506 Q:'MSG
FOR Z=1:1
SET MSG=$PIECE(MSGSTR,HLREP,Z)
if MSG=""
QUIT
SET RSUPDT(365.061,"+"_Z_","_IENS,".01")=MSG
+6 IF $DATA(RSUPDT)
DO UPDATE^DIE("E","RSUPDT",,"ERROR")
+7 QUIT
+8 ;
ZTP(ERROR,IBSEG,RIEN) ; Process ZTP Subscriber date (subscriber level) segment
+1 NEW IENSTR,QUAL,RSUPDT,VALUE,Z
+2 SET IENSTR="+1,"_RIEN_","
+3 ; ZTP sequence
SET RSUPDT(365.07,IENSTR,.01)=+$ORDER(^IBCN(365,RIEN,7,"B",""),-1)+1
+4 ; Date & qualifier
+5 SET QUAL=$PIECE($GET(IBSEG(3)),HLCMP)
SET VALUE=$PIECE($PIECE($GET(IBSEG(4)),HLCMP),HLSCMP)
+6 SET Z=$PIECE($PIECE($GET(IBSEG(4)),HLCMP,2),HLSCMP)
IF Z'=""
SET VALUE=VALUE_" - "_Z
+7 IF VALUE'=""
IF QUAL'=""
SET RSUPDT(365.07,IENSTR,.02)=VALUE
SET RSUPDT(365.07,IENSTR,.03)=QUAL
+8 ; Loop id
SET RSUPDT(365.07,IENSTR,.04)=$GET(IBSEG(5))
+9 ; IB*2*497 check for new coded values
DO CODECHK^IBCNEHLU(.RSUPDT)
+10 DO UPDATE^DIE("E","RSUPDT",,"ERROR")
+11 QUIT
