IBRFIHL2 ;TDM/DAL - HL7 Process Incoming EHC_E12 Msgs (cont.) ;02-SEP-2015 ; 2/22/16 4:41pm
;;2.0;INTEGRATED BILLING;**547**;21-MAR-94;Build 119
;;Per VA Directive 6402, this routine should not be modified.
;
;**Program Description**
; This routine will process the individual segments of the
; incoming EHC_E12 messages.
;
; * Each of these tags are called by IBRFIHL1.
;
Q ; No direct calls
;
MSH(IBSEG) ; Process the MSH seg
N SQ,MSH
F SQ=7,10 S MSH(SQ)=$G(IBSEG(SQ))
;
S DATA(368,.01)=MSH(10) ;Message Control ID
S DATA(368,.03)=MSH(7) ;Message Date/Time
;
S DATA(368,100.03)=$$FMDATE^HLFNC(MSH(7))
Q
;
RFI(IBSEG) ; Process the RFI seg
N SQ,RFI
F SQ=1,2 S RFI(SQ)=$G(IBSEG(SQ+1))
;
S DATA(368,.02)=RFI(1) ;Transaction Set Date/Time
S DATA(368,12.01)=RFI(2) ;Response Due Date
;
S DATA(368,100.02)=$$FMDATE^HLFNC(RFI(1))
S DATA(368,112.01)=$$FMDATE^HLFNC(RFI(2))
Q
;
CTD(IBSEG) ; Process the CTD seg
N SQ,CTD,IEN,REP,CQUAL
F SQ=1:1:3,5 S CTD(SQ)=$G(IBSEG(SQ+1))
;
F REP=1:1:3 D
.S CQUAL=$P($P(CTD(5),HLREP,REP),HLCMP)
.S CQUAL(REP)=$S(CQUAL="PRN":"TE",CQUAL="NET":"EM",CQUAL="BPN":"FX",CQUAL="ORN":"UR",1:CQUAL)
;
I CTD(1)="IC" D ;IC=Information Contact
.S DATA(368,80.04)=$P(CTD(1),HLCMP) ;Contact Type
.S DATA(368,1.03)=$P(CTD(2),HLCMP) ;Contact Name
.S DATA(368,2.01)=CQUAL(1) ;Comm Qual 1
.S DATA(368,3.01)=$P($P(CTD(5),HLREP),HLCMP,8) ;Comm Number 1
.S DATA(368,2.02)=CQUAL(2) ;Comm Qual 2
.S DATA(368,4.01)=$P($P(CTD(5),HLREP,2),HLCMP,8) ;Comm Number 2
.S DATA(368,2.03)=CQUAL(3) ;Comm Qual 3
.S DATA(368,5.01)=$P($P(CTD(5),HLREP,3),HLCMP,8) ;Comm Number 3
.S DATA(368,26.01)=$P($P(CTD(5),HLREP),HLCMP,7) ;Comm Ext 1
.S DATA(368,27.01)=$P($P(CTD(5),HLREP,2),HLCMP,7) ;Comm Ext 2
.S DATA(368,28.01)=$P($P(CTD(5),HLREP,3),HLCMP,7) ;Comm Ext 2
.;
.S IEN=$$FIND1^DIC(365.021,,,CQUAL(1)) S:IEN>0 DATA(368,102.01)=IEN
.S IEN=$$FIND1^DIC(365.021,,,CQUAL(2)) S:IEN>0 DATA(368,102.02)=IEN
.S IEN=$$FIND1^DIC(365.021,,,CQUAL(3)) S:IEN>0 DATA(368,102.03)=IEN
;
I CTD(1)="RE" D ;RE=Receiving Contact
.S DATA(368,80.27)=$P(CTD(1),HLCMP) ;Contact Type
.S DATA(368,15.01)=$P(CTD(2),HLCMP) ;Contact Name
.S DATA(368,20.01)=$P($P(CTD(3),HLCMP),HLSCMP) ;Addr Line 1
.S DATA(368,20.02)=$P(CTD(3),HLCMP,2) ;Addr Line 2
.S DATA(368,20.03)=$P(CTD(3),HLCMP,3) ;City
.S DATA(368,20.04)=$P(CTD(3),HLCMP,4) ;State
.S DATA(368,20.05)=$P(CTD(3),HLCMP,5) ;Postal/Zip
.S DATA(368,20.06)=$P(CTD(3),HLCMP,6) ;Country
.S DATA(368,20.07)=$P(CTD(3),HLCMP,8) ;Country Sub
.S DATA(368,16.01)=CQUAL(1) ;Comm Qual 1
.S DATA(368,17.01)=$P($P(CTD(5),HLREP),HLCMP,8) ;Comm Number 1
.S DATA(368,16.02)=CQUAL(2) ;Comm Qual 2
.S DATA(368,18.01)=$P($P(CTD(5),HLREP,2),HLCMP,8) ;Comm Number 2
.S DATA(368,16.03)=CQUAL(3) ;Comm Qual 3
.S DATA(368,19.01)=$P($P(CTD(5),HLREP,3),HLCMP,8) ;Comm Number 3
.S DATA(368,29.01)=$P($P(CTD(5),HLREP),HLCMP,7) ;Comm Ext 1
.S DATA(368,30.01)=$P($P(CTD(5),HLREP,2),HLCMP,7) ;Comm Ext 2
.S DATA(368,31.01)=$P($P(CTD(5),HLREP,3),HLCMP,7) ;Comm Ext 3
.;
.S IEN=$$FIND1^DIC(365.021,,,CQUAL(1)) S:IEN>0 DATA(368,116.01)=IEN
.S IEN=$$FIND1^DIC(365.021,,,CQUAL(2)) S:IEN>0 DATA(368,116.02)=IEN
.S IEN=$$FIND1^DIC(365.021,,,CQUAL(3)) S:IEN>0 DATA(368,116.03)=IEN
.S IEN=+$$FIND1^DIC(5,,"X",$P(CTD(3),HLCMP,4),"C") S:IEN>0 DATA(368,120.04)=IEN
.S IEN=$$FIND1^DIC(5.11,,,$E($P(CTD(3),HLCMP,5),1,5),"B") S:IEN>0 DATA(368,120.05)=IEN
.S IEN=$$FIND1^DIC(779.004,,"X",$P(CTD(3),HLCMP,6),"B") S:IEN>0 DATA(368,120.06)=IEN
Q
;
IVC(IBSEG,DFN,DFNSSN) ; Process the IVC seg
;
; also try to get the patient file pointer from the claim and the patient SSN from that patient
; will use those to compare against PID to verify that this is the correct patient
;
N SQ,IVC,IEN,RQUAL
F SQ=1:1:3,5,7,10,11,20,26,28 S IVC(SQ)=$G(IBSEG(SQ+1))
;
S RQUAL(1.4)=$S($P(IVC(1),HLCMP,4)="GUID":"EJ",1:$P(IVC(1),HLCMP,4))
S RQUAL(3.4)=$S($P(IVC(3),HLCMP,4)="URI":"D9",1:$P(IVC(3),HLCMP,4))
;
S DATA(368,11.01)=$P(IVC(1),HLCMP) ;Pt Crtl #
S DATA(368,80.18)=RQUAL(1.4) ;Ref ID Qual
S DATA(368,11.02)=$P(IVC(2),HLCMP) ;Payer Claim #
S DATA(368,80.14)=$P(IVC(2),HLCMP,4) ;Cur Tran Trace #
S DATA(368,11.04)=$P(IVC(3),HLCMP) ;Clearinghouse Trace #
S DATA(368,80.21)=RQUAL(3.4) ;Ref ID Qualifier
S DATA(368,80.26)=$P(IVC(5),HLCMP) ;Report Trans Code
S DATA(368,14.05)=$P(IVC(7),HLCMP) ;Claim Service Period
S DATA(368,14.03)=$P($P(IVC(7),HLCMP),"-") ;Start Date
S DATA(368,114.03)=$$FMDATE^HLFNC(DATA(368,14.03)) ;Start Date FileMan format
S DATA(368,14.04)=$P($P(IVC(7),HLCMP),"-",2) ;End Date
S DATA(368,114.04)=$$FMDATE^HLFNC(DATA(368,14.04)) ;End Date FileMan format
I $P(IVC(10),HLCMP)'="" D
.;S DATA(368,80.08)=$P(IVC(10),HLCMP,3) ;Provider Entity ID
.S DATA(368,80.09)=$P(IVC(10),HLCMP,2) ;Prov Entity Type Qua
.S DATA(368,7.01)=$P(IVC(10),HLCMP) ;Provider Name
I $P(IVC(10),HLCMP)="" D
.S DATA(368,80.09)=$P(IVC(12),HLCMP,10)
.S DATA(368,7.01)=$$FMNAME^HLFNC($P(IVC(12),HLCMP,2,5),HL("ECH"))
S DATA(368,80.01)=$P(IVC(11),HLCMP,10) ;Payer Entity ID
S DATA(368,80.02)=$P(IVC(11),HLCMP,2) ;Payer Entity Type Qua
S DATA(368,1.01)=$P(IVC(11),HLCMP) ;Payer Name
S DATA(368,1.02)=$P(IVC(11),HLCMP,3) ;Payer ID
S DATA(368,80.03)=$P(IVC(11),HLCMP,7) ;ID Code Qualifier
S DATA(368,25.01)=$P(IVC(20),HLCMP) ;Reference ID
S DATA(368,80.19)=$P(IVC(20),HLCMP,5) ;Reference ID Qual
S DATA(368,8.01)=$P(IVC(26),HLCMP) ;Provider ID
S DATA(368,80.1)=$P(IVC(28),HLCMP) ;Provider ID Qualifier
;
;S IEN=$$FIND1^DIC(36,,,$P(IVC(11),HLCMP)) S:IEN>0 DATA(368,101.01)=IEN
;
S IEN=$$FIND1^DIC(399,,"X",$P($P($P(IVC(1),HLCMP),"-",2),HLSCMP)) S:IEN>0 DATA(368,111.01)=IEN ;get and file ptr to 399 BILL/CLAIMS
;
; If BILL found, get patient (FILE 2) ptr and SSN and insurance company
I IEN D
.S DFN=$$GET1^DIQ(399,IEN_",",.02,"I") ; get patient
.Q:'+DFN
.N VADM
.D DEM^VADPT
.S DFNSSN=$$NOPUNCT^IBCEF($P(VADM(2),U,2))
.I $P(IVC(11),HLCMP,3)]"" D
..N LOOP,INSURERS,INSCLAIM,INSIEN,IDFIELD,PAYERID
..; institutional or professional claim (1=IN2, 0=PRF)
..S INSCLAIM=$$INSPRF^IBCEF(IEN)
..;get correct field where ID is stored based on instituional or professional
..S IDFIELD=$S(INSCLAIM:3.04,1:3.02)
..; get all insurance companys in the claim
..F LOOP="I1","I2","I3" Q:'$G(^DGCR(399,IEN,LOOP)) D
...S INSIEN=+^DGCR(399,IEN,LOOP)
...S PAYERID=$$GET1^DIQ(36,INSIEN_",",IDFIELD,"I")
...Q:PAYERID=""
...S INSURERS(PAYERID)=INSIEN
...;Deal with a Medicare (WNR) kludge which sent out IDs not in file 36
...I $$MCRWNR^IBEFUNC(INSIEN),$S(".12M61.SMTX1."[$P(IVC(11),HLCMP,3):1,1:0) S INSURERS($P(IVC(11),HLCMP,3))=INSIEN
..I $D(INSURERS($P(IVC(11),HLCMP,3))) S DATA(368,101.01)=INSURERS($P(IVC(11),HLCMP,3))
Q
;
;
PID(IBSEG,DFNPTR,DFNSSN) ; Process the PID seg
N IDLIST,SUBCNT,SUBC,SUBCID,SUBCDATA,MRN,PID,MATCH
S IDLIST=$G(IBSEG(4)),(MRN,PID,DFN)=""
F SUBCNT=1:1:$L(IDLIST,HLREP) D
.S SUBC=$P(IDLIST,HLREP,SUBCNT)
.S SUBCID=$P(SUBC,HLCMP,5) ;Identifier Type Code
.S SUBCDATA=$P(SUBC,HLCMP,1) ;Data Value
.I SUBCID="EA" S MRN=SUBCDATA,DATA(368,80.2)=SUBCID
.I SUBCID="MI" S PID=SUBCDATA,DATA(368,80.13)=SUBCID
;
S DATA(368,10.01)=PID ;Patient Primary ID
S DATA(368,11.03)=MRN ;Medical Record #
S DATA(368,9.01)=$$FMNAME^HLFNC($P($G(IBSEG(6)),HLCMP,1,5),HL("ECH")) ;Patient Name
S DATA(368,80.11)=$S($P($G(IBSEG(6)),HLCMP,8)="A":"QC",1:$P($G(IBSEG(6)),HLCMP,8)) ;Entity ID
S DATA(368,80.12)=$P($G(IBSEG(6)),HLCMP,7) ;Entity Type Qualifier
;
;S:MRN'="" DFN=+$O(^DPT("SSN",MRN,""))
;S:DFN>0 DATA(368,109.01)=DFN
;if there is a Medical Record Number and it matches the SSN (which vista uses as an MRN), then we have the correct patient
S MATCH=0
I MRN]"",MRN=$G(DFNSSN) S DATA(368,109.01)=DFNPTR,MATCH=1
;
;if no match on MRN/SSN but Patient Name from incoming message matches the Patient Name from the Patient file (#2), then we have the correct patient.
I 'MATCH D
.N DFN,VADM
.S DFN=$G(DFNPTR) D DEM^VADPT
.I $G(VADM(1))=DATA(368,9.01) S DATA(368,109.01)=DFNPTR
Q
;
PSL(IBSEG) ; Process the PSL seg
N SQ,PSL,FN,SID,SID1,RDTTM,IEN
F SQ=1,6:1:8,10,16:1:18,20,22,26 S PSL(SQ)=$G(IBSEG(SQ+1))
;
S SID=$O(PSL021(""),-1)+1
S PSL021(SID,.01)=SID ;Seq #
S PSL021(SID,.1)=$P(PSL(1),HLCMP) ;Line item ctrl
S PSL021(SID,1.01)=$P(PSL(1),HLCMP,4) ;Ref ID Qual
S PSL021(SID,.02)=$P(PSL(6),HLCMP) ;Prod/Svc Qual
S PSL021(SID,.03)=$P(PSL(7),HLCMP) ;Svc ID Code
S PSL021(SID,.04)=$P($P(PSL(8),HLREP),HLCMP) ;Proc Mod 1
S PSL021(SID,.05)=$P($P(PSL(8),HLREP,2),HLCMP) ;Proc Mod 2
S PSL021(SID,.06)=$P($P(PSL(8),HLREP,3),HLCMP) ;Proc Mod 3
S PSL021(SID,.07)=$P($P(PSL(8),HLREP,4),HLCMP) ;Proc Mod 4
S PSL021(SID,.08)=$P($P(PSL(16),HLCMP),HLSCMP) ;Line item chg amt
S PSL021(SID,.09)=$P(PSL(22),HLCMP) ;Revenue Code
S PSL021(SID,.11)=$P(PSL(26),HLCMP) ;Svc Line Dt
;
S SID1=$O(PSL2199(SID,""),-1)+1
S PSL2199(SID,SID1,.01)=SID1 ;Seq ID
S PSL2199(SID,SID1,.02)=$P(PSL(10),HLCMP) ;Stat Eff Dt
S PSL2199(SID,SID1,1.04)=$P($P(PSL(17),HLREP),HLCMP) ;Cd List Qual 1
S PSL2199(SID,SID1,10.04)=$P($P(PSL(17),HLREP,2),HLCMP) ;Cd List Qual 2
S PSL2199(SID,SID1,11.04)=$P($P(PSL(17),HLREP,3),HLCMP) ;Cd List Qual 3
S PSL2199(SID,SID1,1.02)=$P($P(PSL(18),HLREP),HLCMP) ;Addtl Info 1
I SID=1,SID1=1 S DATA(368,22.03)=$P($P(PSL(18),HLREP),HLCMP) ;Save primiary LOINC for worklist
S PSL2199(SID,SID1,10.02)=$P($P(PSL(18),HLREP,2),HLCMP) ;Addtl Info 2
S PSL2199(SID,SID1,11.02)=$P($P(PSL(18),HLREP,3),HLCMP) ;Addtl Info 3
S PSL2199(SID,SID1,1.01)=$P($P(PSL(20),HLREP),HLCMP) ;Health Claim 1
S PSL2199(SID,SID1,10.01)=$P($P(PSL(20),HLREP,2),HLCMP) ;Health Claim 2
S PSL2199(SID,SID1,11.01)=$P($P(PSL(20),HLREP,3),HLCMP) ;Health Claim 3
;
S SID=$O(PSL0121(""),-1)+1
S PSL0121(SID,.01)=SID
S IEN=$$FIND1^DIC(368.002,,,$P(PSL(6),HLCMP)) S:IEN>0 PSL0121(SID,.02)=IEN ;Prod/Svc Qual
;
N FILE,CODETYPE
S CODETYPE=$P(PSL(6),HLCMP)
S FILE=$S(CODETYPE="HC":81,CODETYPE="NU":399.2,CODETYPE="N4":50.67,1:"")
I FILE D
.N FILELOC
.S FILELOC=$S(FILE=81:";ICPT(",FILE=399.2:";DGCR(399.2,",FILE=50.67:";PSNDF(50.67,",1:"")
.Q:FILELOC=""
.S IEN=$$FIND1^DIC(FILE,,"X",$P(PSL(7),HLCMP))
.S:IEN>0 PSL0121(SID,.03)=IEN_FILELOC
;
S IEN=$$FIND1^DIC(81.3,,,$P($P(PSL(8),HLREP),HLCMP)) S:IEN>0 PSL0121(SID,.04)=IEN ;Proc Mod 1
S IEN=$$FIND1^DIC(81.3,,,$P($P(PSL(8),HLREP,2),HLCMP)) S:IEN>0 PSL0121(SID,.05)=IEN ;Proc Mod 2
S IEN=$$FIND1^DIC(81.3,,,$P($P(PSL(8),HLREP,3),HLCMP)) S:IEN>0 PSL0121(SID,.06)=IEN ;Proc Mod 3
S IEN=$$FIND1^DIC(81.3,,,$P($P(PSL(8),HLREP,4),HLCMP)) S:IEN>0 PSL0121(SID,.07)=IEN ;Proc Mod 4
S IEN=$$FIND1^DIC(399.2,,,$P(PSL(22),HLCMP)) S:IEN>0 PSL0121(SID,.09)=IEN ;Revenue Code
S VAL=$P($P(PSL(16),HLCMP),HLSCMP)
I VAL=+VAL,VAL'["." S PSL0121(SID,.08)=$FN(VAL/100,",",2)
S PSL0121(SID,.11)=$$FMDATE^HLFNC($P(PSL(26),HLCMP)) ;Svc Line Dt [D]
;
S SID1=$O(PSL12199(SID,""),-1)+1
S PSL12199(SID,SID1,.01)=SID1 ;Seq ID
S PSL12199(SID,SID1,.02)=$$FMDATE^HLFNC($P(PSL(10),HLCMP)) ;Stat Eff Dt
S IEN=$$FIND1^DIC(368.001,,,$P($P(PSL(20),HLREP),HLCMP)) S:IEN>0 PSL12199(SID,SID1,1.01)=IEN ;Health Claim 1
S IEN=$$FIND1^DIC(368.001,,,$P($P(PSL(20),HLREP,2),HLCMP)) S:IEN>0 PSL12199(SID,SID1,10.01)=IEN ;Health Claim 2
S IEN=$$FIND1^DIC(368.001,,,$P($P(PSL(20),HLREP,3),HLCMP)) S:IEN>0 PSL12199(SID,SID1,11.01)=IEN ;Health Claim 3
;
;*******************************************************************
;The following code has been commented out to avoid performing a
;lookup into the LAB LOINC file (#95.3) because an Integration
;Agreement could not be obtained.
;S VAL=$P($P(PSL(18),HLREP),HLCMP)
;S VAL=$S(VAL["-":$P(VAL,"-"),1:$E(VAL,1,$L(VAL)-1))
;S IEN=$$FIND1^DIC(95.3,,,VAL) S:IEN>0 PSL12199(SID,SID1,1.02)=IEN
;I SID=1,SID1=1,IEN>0 S DATA(368,122.03)=IEN
;S VAL=$P($P(PSL(18),HLREP,2),HLCMP)
;S VAL=$S(VAL["-":$P(VAL,"-"),1:$E(VAL,1,$L(VAL)-1))
;S IEN=$$FIND1^DIC(95.3,,,VAL) S:IEN>0 PSL12199(SID,SID1,10.02)=IEN ;Addtl Info 2
;S VAL=$P($P(PSL(18),HLREP,3),HLCMP)
;S VAL=$S(VAL["-":$P(VAL,"-"),1:$E(VAL,1,$L(VAL)-1))
;S IEN=$$FIND1^DIC(95.3,,,VAL) S:IEN>0 PSL12199(SID,SID1,11.02)=IEN ;Addtl Info 3
;*******************************************************************
Q
;
PYE(IBSEG) ; Process the PYE seg
N SQ,PYE
F SQ=2,4,5 S PYE(SQ)=$G(IBSEG(SQ+1))
;
S DATA(368,80.05)=$P(PYE(2),HLCMP) ;Entity ID Code
S:PYE(4)'="" DATA(368,6.01)=$P(PYE(4),HLCMP) ;Organization Nm
S DATA(368,6.02)=$P(PYE(4),HLCMP,3) ;Info Rec ID #
S DATA(368,80.07)=$P(PYE(4),HLCMP,7) ;ID Code Qual
S:PYE(5)'="" DATA(368,6.01)=$$FMNAME^HLFNC($P(PYE(5),HLCMP,1,3),HL("ECH")) ;Payee Name
Q
;
OBX(IBSEG) ; Process the OBX seg
N SQ,OBX,FN,SID,OBXTYP,FLD1,FLD2,FLD3,CQUAL,VAL
F SQ=1,3,14 S OBX(SQ)=$G(IBSEG(SQ+1))
S OBXTYP=$P($P(OBX(3),HLREP),HLCMP,6)
S CQUAL=$P($P(OBX(3),HLREP),HLCMP,3)
S (FLD1,FLD2,FLD3)=""
;
I OBXTYP="STC01" D
.S SID=$O(OBX013(""),-1)+1
.S FLD1=1.01,FLD2=1.02,FLD3=1.04
.S OBX013(SID,.01)=SID
.S OBX013(SID,.02)=$P(OBX(14),HLCMP)
I (OBXTYP="STC10")!(OBXTYP="STC11") S SID=$O(OBX013(""),-1)
;
I OBXTYP="STC10" S FLD1=10.01,FLD2=10.02,FLD3=10.04
I OBXTYP="STC11" S FLD1=11.01,FLD2=11.02,FLD3=11.04
;
S:FLD1'="" OBX013(SID,FLD1)=$P($P(OBX(3),HLREP),HLCMP,4) ;Health Care Claim Status Cat
S:FLD2'="" OBX013(SID,FLD2)=$P($P(OBX(3),HLREP),HLCMP) ;Addtl Info Request Mod 2-Claim
S:FLD3'="" OBX013(SID,FLD3)=$S(CQUAL="LN":"LOI",1:CQUAL) ;Code List Qualifier Code
;
I SID=1,FLD2=1.02 D
.S DATA(368,22.03)=$P($P(OBX(3),HLREP),HLCMP) ; Save primiary LOINC for worklist
.;*******************************************************************
.;The following code has been commented out to avoid performing a
.;lookup into the LAB LOINC file (#95.3) because an Integration
.;Agreement could not be obtained.
.;S VAL=$P($P(OBX(3),HLREP),HLCMP) S VAL=$S(VAL["-":$P(VAL,"-"),1:$E(VAL,1,$L(VAL)-1))
.;S IEN=$$FIND1^DIC(95.3,,,VAL) S:IEN>0 DATA(368,122.03)=IEN ; Save primiary LOINC [D]for worklist
;*******************************************************************
;
I OBXTYP="STC01" D
.S SID=$O(OBX0113(""),-1)+1
.S OBX0113(SID,.01)=SID
.S OBX0113(SID,.02)=$$FMDATE^HLFNC($P(OBX(14),HLCMP))
I (OBXTYP="STC10")!(OBXTYP="STC11") S SID=$O(OBX0113(""),-1)
;
I FLD1'="" S IEN=$$FIND1^DIC(368.001,,,$P($P(OBX(3),HLREP),HLCMP,4)) S:IEN>0 OBX0113(SID,FLD1)=IEN
;*******************************************************************
;The following code has been commented out to avoid performing a
;lookup into the LAB LOINC file (#95.3) because an Integration
;Agreement could not be obtained.
;S VAL=$P($P(OBX(3),HLREP),HLCMP) S VAL=$S(VAL["-":$P(VAL,"-"),1:$E(VAL,1,$L(VAL)-1))
;I FLD2'="" S IEN=$$FIND1^DIC(95.3,,,VAL) S:IEN>0 OBX0113(SID,FLD2)=IEN
;*******************************************************************
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBRFIHL2 16216 printed Apr 09, 2024@21:17:16 Page 2
IBRFIHL2 ;TDM/DAL - HL7 Process Incoming EHC_E12 Msgs (cont.) ;02-SEP-2015 ; 2/22/16 4:41pm
+1 ;;2.0;INTEGRATED BILLING;**547**;21-MAR-94;Build 119
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;**Program Description**
+5 ; This routine will process the individual segments of the
+6 ; incoming EHC_E12 messages.
+7 ;
+8 ; * Each of these tags are called by IBRFIHL1.
+9 ;
+10 ; No direct calls
QUIT
+11 ;
MSH(IBSEG) ; Process the MSH seg
+1 NEW SQ,MSH
+2 FOR SQ=7,10
SET MSH(SQ)=$GET(IBSEG(SQ))
+3 ;
+4 ;Message Control ID
SET DATA(368,.01)=MSH(10)
+5 ;Message Date/Time
SET DATA(368,.03)=MSH(7)
+6 ;
+7 SET DATA(368,100.03)=$$FMDATE^HLFNC(MSH(7))
+8 QUIT
+9 ;
RFI(IBSEG) ; Process the RFI seg
+1 NEW SQ,RFI
+2 FOR SQ=1,2
SET RFI(SQ)=$GET(IBSEG(SQ+1))
+3 ;
+4 ;Transaction Set Date/Time
SET DATA(368,.02)=RFI(1)
+5 ;Response Due Date
SET DATA(368,12.01)=RFI(2)
+6 ;
+7 SET DATA(368,100.02)=$$FMDATE^HLFNC(RFI(1))
+8 SET DATA(368,112.01)=$$FMDATE^HLFNC(RFI(2))
+9 QUIT
+10 ;
CTD(IBSEG) ; Process the CTD seg
+1 NEW SQ,CTD,IEN,REP,CQUAL
+2 FOR SQ=1:1:3,5
SET CTD(SQ)=$GET(IBSEG(SQ+1))
+3 ;
+4 FOR REP=1:1:3
Begin DoDot:1
+5 SET CQUAL=$PIECE($PIECE(CTD(5),HLREP,REP),HLCMP)
+6 SET CQUAL(REP)=$SELECT(CQUAL="PRN":"TE",CQUAL="NET":"EM",CQUAL="BPN":"FX",CQUAL="ORN":"UR",1:CQUAL)
End DoDot:1
+7 ;
+8 ;IC=Information Contact
IF CTD(1)="IC"
Begin DoDot:1
+9 ;Contact Type
SET DATA(368,80.04)=$PIECE(CTD(1),HLCMP)
+10 ;Contact Name
SET DATA(368,1.03)=$PIECE(CTD(2),HLCMP)
+11 ;Comm Qual 1
SET DATA(368,2.01)=CQUAL(1)
+12 ;Comm Number 1
SET DATA(368,3.01)=$PIECE($PIECE(CTD(5),HLREP),HLCMP,8)
+13 ;Comm Qual 2
SET DATA(368,2.02)=CQUAL(2)
+14 ;Comm Number 2
SET DATA(368,4.01)=$PIECE($PIECE(CTD(5),HLREP,2),HLCMP,8)
+15 ;Comm Qual 3
SET DATA(368,2.03)=CQUAL(3)
+16 ;Comm Number 3
SET DATA(368,5.01)=$PIECE($PIECE(CTD(5),HLREP,3),HLCMP,8)
+17 ;Comm Ext 1
SET DATA(368,26.01)=$PIECE($PIECE(CTD(5),HLREP),HLCMP,7)
+18 ;Comm Ext 2
SET DATA(368,27.01)=$PIECE($PIECE(CTD(5),HLREP,2),HLCMP,7)
+19 ;Comm Ext 2
SET DATA(368,28.01)=$PIECE($PIECE(CTD(5),HLREP,3),HLCMP,7)
+20 ;
+21 SET IEN=$$FIND1^DIC(365.021,,,CQUAL(1))
if IEN>0
SET DATA(368,102.01)=IEN
+22 SET IEN=$$FIND1^DIC(365.021,,,CQUAL(2))
if IEN>0
SET DATA(368,102.02)=IEN
+23 SET IEN=$$FIND1^DIC(365.021,,,CQUAL(3))
if IEN>0
SET DATA(368,102.03)=IEN
End DoDot:1
+24 ;
+25 ;RE=Receiving Contact
IF CTD(1)="RE"
Begin DoDot:1
+26 ;Contact Type
SET DATA(368,80.27)=$PIECE(CTD(1),HLCMP)
+27 ;Contact Name
SET DATA(368,15.01)=$PIECE(CTD(2),HLCMP)
+28 ;Addr Line 1
SET DATA(368,20.01)=$PIECE($PIECE(CTD(3),HLCMP),HLSCMP)
+29 ;Addr Line 2
SET DATA(368,20.02)=$PIECE(CTD(3),HLCMP,2)
+30 ;City
SET DATA(368,20.03)=$PIECE(CTD(3),HLCMP,3)
+31 ;State
SET DATA(368,20.04)=$PIECE(CTD(3),HLCMP,4)
+32 ;Postal/Zip
SET DATA(368,20.05)=$PIECE(CTD(3),HLCMP,5)
+33 ;Country
SET DATA(368,20.06)=$PIECE(CTD(3),HLCMP,6)
+34 ;Country Sub
SET DATA(368,20.07)=$PIECE(CTD(3),HLCMP,8)
+35 ;Comm Qual 1
SET DATA(368,16.01)=CQUAL(1)
+36 ;Comm Number 1
SET DATA(368,17.01)=$PIECE($PIECE(CTD(5),HLREP),HLCMP,8)
+37 ;Comm Qual 2
SET DATA(368,16.02)=CQUAL(2)
+38 ;Comm Number 2
SET DATA(368,18.01)=$PIECE($PIECE(CTD(5),HLREP,2),HLCMP,8)
+39 ;Comm Qual 3
SET DATA(368,16.03)=CQUAL(3)
+40 ;Comm Number 3
SET DATA(368,19.01)=$PIECE($PIECE(CTD(5),HLREP,3),HLCMP,8)
+41 ;Comm Ext 1
SET DATA(368,29.01)=$PIECE($PIECE(CTD(5),HLREP),HLCMP,7)
+42 ;Comm Ext 2
SET DATA(368,30.01)=$PIECE($PIECE(CTD(5),HLREP,2),HLCMP,7)
+43 ;Comm Ext 3
SET DATA(368,31.01)=$PIECE($PIECE(CTD(5),HLREP,3),HLCMP,7)
+44 ;
+45 SET IEN=$$FIND1^DIC(365.021,,,CQUAL(1))
if IEN>0
SET DATA(368,116.01)=IEN
+46 SET IEN=$$FIND1^DIC(365.021,,,CQUAL(2))
if IEN>0
SET DATA(368,116.02)=IEN
+47 SET IEN=$$FIND1^DIC(365.021,,,CQUAL(3))
if IEN>0
SET DATA(368,116.03)=IEN
+48 SET IEN=+$$FIND1^DIC(5,,"X",$PIECE(CTD(3),HLCMP,4),"C")
if IEN>0
SET DATA(368,120.04)=IEN
+49 SET IEN=$$FIND1^DIC(5.11,,,$EXTRACT($PIECE(CTD(3),HLCMP,5),1,5),"B")
if IEN>0
SET DATA(368,120.05)=IEN
+50 SET IEN=$$FIND1^DIC(779.004,,"X",$PIECE(CTD(3),HLCMP,6),"B")
if IEN>0
SET DATA(368,120.06)=IEN
End DoDot:1
+51 QUIT
+52 ;
IVC(IBSEG,DFN,DFNSSN) ; Process the IVC seg
+1 ;
+2 ; also try to get the patient file pointer from the claim and the patient SSN from that patient
+3 ; will use those to compare against PID to verify that this is the correct patient
+4 ;
+5 NEW SQ,IVC,IEN,RQUAL
+6 FOR SQ=1:1:3,5,7,10,11,20,26,28
SET IVC(SQ)=$GET(IBSEG(SQ+1))
+7 ;
+8 SET RQUAL(1.4)=$SELECT($PIECE(IVC(1),HLCMP,4)="GUID":"EJ",1:$PIECE(IVC(1),HLCMP,4))
+9 SET RQUAL(3.4)=$SELECT($PIECE(IVC(3),HLCMP,4)="URI":"D9",1:$PIECE(IVC(3),HLCMP,4))
+10 ;
+11 ;Pt Crtl #
SET DATA(368,11.01)=$PIECE(IVC(1),HLCMP)
+12 ;Ref ID Qual
SET DATA(368,80.18)=RQUAL(1.4)
+13 ;Payer Claim #
SET DATA(368,11.02)=$PIECE(IVC(2),HLCMP)
+14 ;Cur Tran Trace #
SET DATA(368,80.14)=$PIECE(IVC(2),HLCMP,4)
+15 ;Clearinghouse Trace #
SET DATA(368,11.04)=$PIECE(IVC(3),HLCMP)
+16 ;Ref ID Qualifier
SET DATA(368,80.21)=RQUAL(3.4)
+17 ;Report Trans Code
SET DATA(368,80.26)=$PIECE(IVC(5),HLCMP)
+18 ;Claim Service Period
SET DATA(368,14.05)=$PIECE(IVC(7),HLCMP)
+19 ;Start Date
SET DATA(368,14.03)=$PIECE($PIECE(IVC(7),HLCMP),"-")
+20 ;Start Date FileMan format
SET DATA(368,114.03)=$$FMDATE^HLFNC(DATA(368,14.03))
+21 ;End Date
SET DATA(368,14.04)=$PIECE($PIECE(IVC(7),HLCMP),"-",2)
+22 ;End Date FileMan format
SET DATA(368,114.04)=$$FMDATE^HLFNC(DATA(368,14.04))
+23 IF $PIECE(IVC(10),HLCMP)'=""
Begin DoDot:1
+24 ;S DATA(368,80.08)=$P(IVC(10),HLCMP,3) ;Provider Entity ID
+25 ;Prov Entity Type Qua
SET DATA(368,80.09)=$PIECE(IVC(10),HLCMP,2)
+26 ;Provider Name
SET DATA(368,7.01)=$PIECE(IVC(10),HLCMP)
End DoDot:1
+27 IF $PIECE(IVC(10),HLCMP)=""
Begin DoDot:1
+28 SET DATA(368,80.09)=$PIECE(IVC(12),HLCMP,10)
+29 SET DATA(368,7.01)=$$FMNAME^HLFNC($PIECE(IVC(12),HLCMP,2,5),HL("ECH"))
End DoDot:1
+30 ;Payer Entity ID
SET DATA(368,80.01)=$PIECE(IVC(11),HLCMP,10)
+31 ;Payer Entity Type Qua
SET DATA(368,80.02)=$PIECE(IVC(11),HLCMP,2)
+32 ;Payer Name
SET DATA(368,1.01)=$PIECE(IVC(11),HLCMP)
+33 ;Payer ID
SET DATA(368,1.02)=$PIECE(IVC(11),HLCMP,3)
+34 ;ID Code Qualifier
SET DATA(368,80.03)=$PIECE(IVC(11),HLCMP,7)
+35 ;Reference ID
SET DATA(368,25.01)=$PIECE(IVC(20),HLCMP)
+36 ;Reference ID Qual
SET DATA(368,80.19)=$PIECE(IVC(20),HLCMP,5)
+37 ;Provider ID
SET DATA(368,8.01)=$PIECE(IVC(26),HLCMP)
+38 ;Provider ID Qualifier
SET DATA(368,80.1)=$PIECE(IVC(28),HLCMP)
+39 ;
+40 ;S IEN=$$FIND1^DIC(36,,,$P(IVC(11),HLCMP)) S:IEN>0 DATA(368,101.01)=IEN
+41 ;
+42 ;get and file ptr to 399 BILL/CLAIMS
SET IEN=$$FIND1^DIC(399,,"X",$PIECE($PIECE($PIECE(IVC(1),HLCMP),"-",2),HLSCMP))
if IEN>0
SET DATA(368,111.01)=IEN
+43 ;
+44 ; If BILL found, get patient (FILE 2) ptr and SSN and insurance company
+45 IF IEN
Begin DoDot:1
+46 ; get patient
SET DFN=$$GET1^DIQ(399,IEN_",",.02,"I")
+47 if '+DFN
QUIT
+48 NEW VADM
+49 DO DEM^VADPT
+50 SET DFNSSN=$$NOPUNCT^IBCEF($PIECE(VADM(2),U,2))
+51 IF $PIECE(IVC(11),HLCMP,3)]""
Begin DoDot:2
+52 NEW LOOP,INSURERS,INSCLAIM,INSIEN,IDFIELD,PAYERID
+53 ; institutional or professional claim (1=IN2, 0=PRF)
+54 SET INSCLAIM=$$INSPRF^IBCEF(IEN)
+55 ;get correct field where ID is stored based on instituional or professional
+56 SET IDFIELD=$SELECT(INSCLAIM:3.04,1:3.02)
+57 ; get all insurance companys in the claim
+58 FOR LOOP="I1","I2","I3"
if '$GET(^DGCR(399,IEN,LOOP))
QUIT
Begin DoDot:3
+59 SET INSIEN=+^DGCR(399,IEN,LOOP)
+60 SET PAYERID=$$GET1^DIQ(36,INSIEN_",",IDFIELD,"I")
+61 if PAYERID=""
QUIT
+62 SET INSURERS(PAYERID)=INSIEN
+63 ;Deal with a Medicare (WNR) kludge which sent out IDs not in file 36
+64 IF $$MCRWNR^IBEFUNC(INSIEN)
IF $SELECT(".12M61.SMTX1."[$PIECE(IVC(11),HLCMP,3):1,1:0)
SET INSURERS($PIECE(IVC(11),HLCMP,3))=INSIEN
End DoDot:3
+65 IF $DATA(INSURERS($PIECE(IVC(11),HLCMP,3)))
SET DATA(368,101.01)=INSURERS($PIECE(IVC(11),HLCMP,3))
End DoDot:2
End DoDot:1
+66 QUIT
+67 ;
+68 ;
PID(IBSEG,DFNPTR,DFNSSN) ; Process the PID seg
+1 NEW IDLIST,SUBCNT,SUBC,SUBCID,SUBCDATA,MRN,PID,MATCH
+2 SET IDLIST=$GET(IBSEG(4))
SET (MRN,PID,DFN)=""
+3 FOR SUBCNT=1:1:$LENGTH(IDLIST,HLREP)
Begin DoDot:1
+4 SET SUBC=$PIECE(IDLIST,HLREP,SUBCNT)
+5 ;Identifier Type Code
SET SUBCID=$PIECE(SUBC,HLCMP,5)
+6 ;Data Value
SET SUBCDATA=$PIECE(SUBC,HLCMP,1)
+7 IF SUBCID="EA"
SET MRN=SUBCDATA
SET DATA(368,80.2)=SUBCID
+8 IF SUBCID="MI"
SET PID=SUBCDATA
SET DATA(368,80.13)=SUBCID
End DoDot:1
+9 ;
+10 ;Patient Primary ID
SET DATA(368,10.01)=PID
+11 ;Medical Record #
SET DATA(368,11.03)=MRN
+12 ;Patient Name
SET DATA(368,9.01)=$$FMNAME^HLFNC($PIECE($GET(IBSEG(6)),HLCMP,1,5),HL("ECH"))
+13 ;Entity ID
SET DATA(368,80.11)=$SELECT($PIECE($GET(IBSEG(6)),HLCMP,8)="A":"QC",1:$PIECE($GET(IBSEG(6)),HLCMP,8))
+14 ;Entity Type Qualifier
SET DATA(368,80.12)=$PIECE($GET(IBSEG(6)),HLCMP,7)
+15 ;
+16 ;S:MRN'="" DFN=+$O(^DPT("SSN",MRN,""))
+17 ;S:DFN>0 DATA(368,109.01)=DFN
+18 ;if there is a Medical Record Number and it matches the SSN (which vista uses as an MRN), then we have the correct patient
+19 SET MATCH=0
+20 IF MRN]""
IF MRN=$GET(DFNSSN)
SET DATA(368,109.01)=DFNPTR
SET MATCH=1
+21 ;
+22 ;if no match on MRN/SSN but Patient Name from incoming message matches the Patient Name from the Patient file (#2), then we have the correct patient.
+23 IF 'MATCH
Begin DoDot:1
+24 NEW DFN,VADM
+25 SET DFN=$GET(DFNPTR)
DO DEM^VADPT
+26 IF $GET(VADM(1))=DATA(368,9.01)
SET DATA(368,109.01)=DFNPTR
End DoDot:1
+27 QUIT
+28 ;
PSL(IBSEG) ; Process the PSL seg
+1 NEW SQ,PSL,FN,SID,SID1,RDTTM,IEN
+2 FOR SQ=1,6:1:8,10,16:1:18,20,22,26
SET PSL(SQ)=$GET(IBSEG(SQ+1))
+3 ;
+4 SET SID=$ORDER(PSL021(""),-1)+1
+5 ;Seq #
SET PSL021(SID,.01)=SID
+6 ;Line item ctrl
SET PSL021(SID,.1)=$PIECE(PSL(1),HLCMP)
+7 ;Ref ID Qual
SET PSL021(SID,1.01)=$PIECE(PSL(1),HLCMP,4)
+8 ;Prod/Svc Qual
SET PSL021(SID,.02)=$PIECE(PSL(6),HLCMP)
+9 ;Svc ID Code
SET PSL021(SID,.03)=$PIECE(PSL(7),HLCMP)
+10 ;Proc Mod 1
SET PSL021(SID,.04)=$PIECE($PIECE(PSL(8),HLREP),HLCMP)
+11 ;Proc Mod 2
SET PSL021(SID,.05)=$PIECE($PIECE(PSL(8),HLREP,2),HLCMP)
+12 ;Proc Mod 3
SET PSL021(SID,.06)=$PIECE($PIECE(PSL(8),HLREP,3),HLCMP)
+13 ;Proc Mod 4
SET PSL021(SID,.07)=$PIECE($PIECE(PSL(8),HLREP,4),HLCMP)
+14 ;Line item chg amt
SET PSL021(SID,.08)=$PIECE($PIECE(PSL(16),HLCMP),HLSCMP)
+15 ;Revenue Code
SET PSL021(SID,.09)=$PIECE(PSL(22),HLCMP)
+16 ;Svc Line Dt
SET PSL021(SID,.11)=$PIECE(PSL(26),HLCMP)
+17 ;
+18 SET SID1=$ORDER(PSL2199(SID,""),-1)+1
+19 ;Seq ID
SET PSL2199(SID,SID1,.01)=SID1
+20 ;Stat Eff Dt
SET PSL2199(SID,SID1,.02)=$PIECE(PSL(10),HLCMP)
+21 ;Cd List Qual 1
SET PSL2199(SID,SID1,1.04)=$PIECE($PIECE(PSL(17),HLREP),HLCMP)
+22 ;Cd List Qual 2
SET PSL2199(SID,SID1,10.04)=$PIECE($PIECE(PSL(17),HLREP,2),HLCMP)
+23 ;Cd List Qual 3
SET PSL2199(SID,SID1,11.04)=$PIECE($PIECE(PSL(17),HLREP,3),HLCMP)
+24 ;Addtl Info 1
SET PSL2199(SID,SID1,1.02)=$PIECE($PIECE(PSL(18),HLREP),HLCMP)
+25 ;Save primiary LOINC for worklist
IF SID=1
IF SID1=1
SET DATA(368,22.03)=$PIECE($PIECE(PSL(18),HLREP),HLCMP)
+26 ;Addtl Info 2
SET PSL2199(SID,SID1,10.02)=$PIECE($PIECE(PSL(18),HLREP,2),HLCMP)
+27 ;Addtl Info 3
SET PSL2199(SID,SID1,11.02)=$PIECE($PIECE(PSL(18),HLREP,3),HLCMP)
+28 ;Health Claim 1
SET PSL2199(SID,SID1,1.01)=$PIECE($PIECE(PSL(20),HLREP),HLCMP)
+29 ;Health Claim 2
SET PSL2199(SID,SID1,10.01)=$PIECE($PIECE(PSL(20),HLREP,2),HLCMP)
+30 ;Health Claim 3
SET PSL2199(SID,SID1,11.01)=$PIECE($PIECE(PSL(20),HLREP,3),HLCMP)
+31 ;
+32 SET SID=$ORDER(PSL0121(""),-1)+1
+33 SET PSL0121(SID,.01)=SID
+34 ;Prod/Svc Qual
SET IEN=$$FIND1^DIC(368.002,,,$PIECE(PSL(6),HLCMP))
if IEN>0
SET PSL0121(SID,.02)=IEN
+35 ;
+36 NEW FILE,CODETYPE
+37 SET CODETYPE=$PIECE(PSL(6),HLCMP)
+38 SET FILE=$SELECT(CODETYPE="HC":81,CODETYPE="NU":399.2,CODETYPE="N4":50.67,1:"")
+39 IF FILE
Begin DoDot:1
+40 NEW FILELOC
+41 SET FILELOC=$SELECT(FILE=81:";ICPT(",FILE=399.2:";DGCR(399.2,",FILE=50.67:";PSNDF(50.67,",1:"")
+42 if FILELOC=""
QUIT
+43 SET IEN=$$FIND1^DIC(FILE,,"X",$PIECE(PSL(7),HLCMP))
+44 if IEN>0
SET PSL0121(SID,.03)=IEN_FILELOC
End DoDot:1
+45 ;
+46 ;Proc Mod 1
SET IEN=$$FIND1^DIC(81.3,,,$PIECE($PIECE(PSL(8),HLREP),HLCMP))
if IEN>0
SET PSL0121(SID,.04)=IEN
+47 ;Proc Mod 2
SET IEN=$$FIND1^DIC(81.3,,,$PIECE($PIECE(PSL(8),HLREP,2),HLCMP))
if IEN>0
SET PSL0121(SID,.05)=IEN
+48 ;Proc Mod 3
SET IEN=$$FIND1^DIC(81.3,,,$PIECE($PIECE(PSL(8),HLREP,3),HLCMP))
if IEN>0
SET PSL0121(SID,.06)=IEN
+49 ;Proc Mod 4
SET IEN=$$FIND1^DIC(81.3,,,$PIECE($PIECE(PSL(8),HLREP,4),HLCMP))
if IEN>0
SET PSL0121(SID,.07)=IEN
+50 ;Revenue Code
SET IEN=$$FIND1^DIC(399.2,,,$PIECE(PSL(22),HLCMP))
if IEN>0
SET PSL0121(SID,.09)=IEN
+51 SET VAL=$PIECE($PIECE(PSL(16),HLCMP),HLSCMP)
+52 IF VAL=+VAL
IF VAL'["."
SET PSL0121(SID,.08)=$FNUMBER(VAL/100,",",2)
+53 ;Svc Line Dt [D]
SET PSL0121(SID,.11)=$$FMDATE^HLFNC($PIECE(PSL(26),HLCMP))
+54 ;
+55 SET SID1=$ORDER(PSL12199(SID,""),-1)+1
+56 ;Seq ID
SET PSL12199(SID,SID1,.01)=SID1
+57 ;Stat Eff Dt
SET PSL12199(SID,SID1,.02)=$$FMDATE^HLFNC($PIECE(PSL(10),HLCMP))
+58 ;Health Claim 1
SET IEN=$$FIND1^DIC(368.001,,,$PIECE($PIECE(PSL(20),HLREP),HLCMP))
if IEN>0
SET PSL12199(SID,SID1,1.01)=IEN
+59 ;Health Claim 2
SET IEN=$$FIND1^DIC(368.001,,,$PIECE($PIECE(PSL(20),HLREP,2),HLCMP))
if IEN>0
SET PSL12199(SID,SID1,10.01)=IEN
+60 ;Health Claim 3
SET IEN=$$FIND1^DIC(368.001,,,$PIECE($PIECE(PSL(20),HLREP,3),HLCMP))
if IEN>0
SET PSL12199(SID,SID1,11.01)=IEN
+61 ;
+62 ;*******************************************************************
+63 ;The following code has been commented out to avoid performing a
+64 ;lookup into the LAB LOINC file (#95.3) because an Integration
+65 ;Agreement could not be obtained.
+66 ;S VAL=$P($P(PSL(18),HLREP),HLCMP)
+67 ;S VAL=$S(VAL["-":$P(VAL,"-"),1:$E(VAL,1,$L(VAL)-1))
+68 ;S IEN=$$FIND1^DIC(95.3,,,VAL) S:IEN>0 PSL12199(SID,SID1,1.02)=IEN
+69 ;I SID=1,SID1=1,IEN>0 S DATA(368,122.03)=IEN
+70 ;S VAL=$P($P(PSL(18),HLREP,2),HLCMP)
+71 ;S VAL=$S(VAL["-":$P(VAL,"-"),1:$E(VAL,1,$L(VAL)-1))
+72 ;S IEN=$$FIND1^DIC(95.3,,,VAL) S:IEN>0 PSL12199(SID,SID1,10.02)=IEN ;Addtl Info 2
+73 ;S VAL=$P($P(PSL(18),HLREP,3),HLCMP)
+74 ;S VAL=$S(VAL["-":$P(VAL,"-"),1:$E(VAL,1,$L(VAL)-1))
+75 ;S IEN=$$FIND1^DIC(95.3,,,VAL) S:IEN>0 PSL12199(SID,SID1,11.02)=IEN ;Addtl Info 3
+76 ;*******************************************************************
+77 QUIT
+78 ;
PYE(IBSEG) ; Process the PYE seg
+1 NEW SQ,PYE
+2 FOR SQ=2,4,5
SET PYE(SQ)=$GET(IBSEG(SQ+1))
+3 ;
+4 ;Entity ID Code
SET DATA(368,80.05)=$PIECE(PYE(2),HLCMP)
+5 ;Organization Nm
if PYE(4)'=""
SET DATA(368,6.01)=$PIECE(PYE(4),HLCMP)
+6 ;Info Rec ID #
SET DATA(368,6.02)=$PIECE(PYE(4),HLCMP,3)
+7 ;ID Code Qual
SET DATA(368,80.07)=$PIECE(PYE(4),HLCMP,7)
+8 ;Payee Name
if PYE(5)'=""
SET DATA(368,6.01)=$$FMNAME^HLFNC($PIECE(PYE(5),HLCMP,1,3),HL("ECH"))
+9 QUIT
+10 ;
OBX(IBSEG) ; Process the OBX seg
+1 NEW SQ,OBX,FN,SID,OBXTYP,FLD1,FLD2,FLD3,CQUAL,VAL
+2 FOR SQ=1,3,14
SET OBX(SQ)=$GET(IBSEG(SQ+1))
+3 SET OBXTYP=$PIECE($PIECE(OBX(3),HLREP),HLCMP,6)
+4 SET CQUAL=$PIECE($PIECE(OBX(3),HLREP),HLCMP,3)
+5 SET (FLD1,FLD2,FLD3)=""
+6 ;
+7 IF OBXTYP="STC01"
Begin DoDot:1
+8 SET SID=$ORDER(OBX013(""),-1)+1
+9 SET FLD1=1.01
SET FLD2=1.02
SET FLD3=1.04
+10 SET OBX013(SID,.01)=SID
+11 SET OBX013(SID,.02)=$PIECE(OBX(14),HLCMP)
End DoDot:1
+12 IF (OBXTYP="STC10")!(OBXTYP="STC11")
SET SID=$ORDER(OBX013(""),-1)
+13 ;
+14 IF OBXTYP="STC10"
SET FLD1=10.01
SET FLD2=10.02
SET FLD3=10.04
+15 IF OBXTYP="STC11"
SET FLD1=11.01
SET FLD2=11.02
SET FLD3=11.04
+16 ;
+17 ;Health Care Claim Status Cat
if FLD1'=""
SET OBX013(SID,FLD1)=$PIECE($PIECE(OBX(3),HLREP),HLCMP,4)
+18 ;Addtl Info Request Mod 2-Claim
if FLD2'=""
SET OBX013(SID,FLD2)=$PIECE($PIECE(OBX(3),HLREP),HLCMP)
+19 ;Code List Qualifier Code
if FLD3'=""
SET OBX013(SID,FLD3)=$SELECT(CQUAL="LN":"LOI",1:CQUAL)
+20 ;
+21 IF SID=1
IF FLD2=1.02
Begin DoDot:1
+22 ; Save primiary LOINC for worklist
SET DATA(368,22.03)=$PIECE($PIECE(OBX(3),HLREP),HLCMP)
+23 ;*******************************************************************
+24 ;The following code has been commented out to avoid performing a
+25 ;lookup into the LAB LOINC file (#95.3) because an Integration
+26 ;Agreement could not be obtained.
+27 ;S VAL=$P($P(OBX(3),HLREP),HLCMP) S VAL=$S(VAL["-":$P(VAL,"-"),1:$E(VAL,1,$L(VAL)-1))
+28 ;S IEN=$$FIND1^DIC(95.3,,,VAL) S:IEN>0 DATA(368,122.03)=IEN ; Save primiary LOINC [D]for worklist
End DoDot:1
+29 ;*******************************************************************
+30 ;
+31 IF OBXTYP="STC01"
Begin DoDot:1
+32 SET SID=$ORDER(OBX0113(""),-1)+1
+33 SET OBX0113(SID,.01)=SID
+34 SET OBX0113(SID,.02)=$$FMDATE^HLFNC($PIECE(OBX(14),HLCMP))
End DoDot:1
+35 IF (OBXTYP="STC10")!(OBXTYP="STC11")
SET SID=$ORDER(OBX0113(""),-1)
+36 ;
+37 IF FLD1'=""
SET IEN=$$FIND1^DIC(368.001,,,$PIECE($PIECE(OBX(3),HLREP),HLCMP,4))
if IEN>0
SET OBX0113(SID,FLD1)=IEN
+38 ;*******************************************************************
+39 ;The following code has been commented out to avoid performing a
+40 ;lookup into the LAB LOINC file (#95.3) because an Integration
+41 ;Agreement could not be obtained.
+42 ;S VAL=$P($P(OBX(3),HLREP),HLCMP) S VAL=$S(VAL["-":$P(VAL,"-"),1:$E(VAL,1,$L(VAL)-1))
+43 ;I FLD2'="" S IEN=$$FIND1^DIC(95.3,,,VAL) S:IEN>0 OBX0113(SID,FLD2)=IEN
+44 ;*******************************************************************
+45 QUIT
