IBRFIHL1 ;TDM/DAL - HL7 Process Incoming EHC_E12 Messages ; 2/22/16 1:46pm
;;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 incoming EHC_E12 HL7 messages. It will
; parse and file the message into the HEALTH CARE CLAIM RFAI (277)
; (#368) file.
;
EN ; Entry Point
N AUTO,EBDA,ERFLG,ERROR,HCT,HLCMP,HLREP,HLSCMP,RIEN,SEG,DATA,IBSEG,MSH10
N DFNPTR,DFNSSN
S ERFLG=0
;
S HLCMP=$E(HL("ECH")) ; HL7 component separator
S HLSCMP=$E(HL("ECH"),4) ; HL7 subcomponent separator
S HLREP=$E(HL("ECH"),2) ; HL7 repetition separator
;
; Loop through the message and find each segment for processing
S HCT="" F S HCT=$O(^TMP($J,"IBRFIHLI",HCT)) Q:HCT="" D Q:ERFLG
.D SPAR^IBRFIHLU
.S SEG=$G(IBSEG(1))
.I SEG="MSH" D MSH^IBRFIHL2(.IBSEG) Q ;Message Header Seg
.I SEG="RFI" D RFI^IBRFIHL2(.IBSEG) Q ;Request for Info Seg
.I SEG="CTD" D CTD^IBRFIHL2(.IBSEG) Q ;Contact Segment
.I SEG="IVC" D IVC^IBRFIHL2(.IBSEG,.DFNPTR,.DFNSSN) Q ;Invoice Segment
.I SEG="PID" D PID^IBRFIHL2(.IBSEG,$G(DFNPTR),$G(DFNSSN)) Q ;Patient Segment
.I SEG="PSL" D PSL^IBRFIHL2(.IBSEG) Q ;Product/Service Ln Item
.I SEG="PYE" D PYE^IBRFIHL2(.IBSEG) Q ;Payee Info Segment
.I SEG="OBX" D OBX^IBRFIHL2(.IBSEG) ;Observation/Result
D FILE
Q
;
FILE ; File all data.
N DO,DIC,X,FLD,IEN368,DIK,DA,DIE,DR,Y,DTOUT,DUOUT,LVL0,LVL1,SID,SID1
;
;Determine Primary LOINC
S:$G(OBX013(1,1.02))'="" DATA(368,22.03)=$G(OBX013(1,1.02))
S:$G(OBX013(1,1.02))="" DATA(368,22.03)=$G(PSL2199(1,1,1.02))
;*******************************************************************
;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=DATA(368,22.03) 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
;*******************************************************************
S VAL=DATA(368,22.03) I VAL'["-" S VAL=$E(VAL,1,$L(VAL)-1)_"-"_$E(VAL,$L(VAL)) S DATA(368,22.03)=VAL
;
;Initialize Deletion Flag
S DATA(368,200.01)=0
;
;File 368 data
S LSTFLD=$O(DATA(368,""),-1),DIC("DR")=""
S FLD=0 F S FLD=$O(DATA(368,FLD)) Q:FLD="" D
.S DIC("DR")=DIC("DR")_FLD_"////^S X=DATA(368,"_FLD_")"
.I FLD'=LSTFLD S DIC("DR")=DIC("DR")_";"
K DO
S DIC="^IBA(368,",DIC(0)="",X=DATA(368,.01)
D FILE^DICN
S IEN368=Y
K DIC,X,Y,DTOUT,DUOUT
;
;File 368.013 data
I $D(OBX013) D
.S SID="" F S SID=$O(OBX013(SID)) Q:SID="" D
..S LSTFLD=$O(OBX013(SID,""),-1),DIC("DR")=""
..S FLD=0 F S FLD=$O(OBX013(SID,FLD)) Q:FLD="" D
...S DIC("DR")=DIC("DR")_FLD_"////^S X=OBX013(SID,"_FLD_")"
...I FLD'=LSTFLD S DIC("DR")=DIC("DR")_";"
..K DO
..S X=SID,DIC="^IBA(368,"_+IEN368_",13,",DIC(0)="L",DA(1)=+IEN368
..D FILE^DICN
..K DIC,DA,X,Y,DTOUT,DUOUT
;
;File 368.0113 data
I $D(OBX0113) D
.S SID="" F S SID=$O(OBX0113(SID)) Q:SID="" D
..S LSTFLD=$O(OBX0113(SID,""),-1),DIC("DR")=""
..S FLD=0 F S FLD=$O(OBX0113(SID,FLD)) Q:FLD="" D
...S DIC("DR")=DIC("DR")_FLD_"////^S X=OBX0113(SID,"_FLD_")"
...I FLD'=LSTFLD S DIC("DR")=DIC("DR")_";"
..K DO
..S X=SID,DIC="^IBA(368,"_+IEN368_",113,",DIC(0)="L",DA(1)=+IEN368
..D FILE^DICN
..K DIC,DA,X,Y,DTOUT,DUOUT
;
;File 368.021 entries
I $D(PSL021) D
.S SID="" F S SID=$O(PSL021(SID)) Q:SID="" D
..S LSTFLD=$O(PSL021(SID,""),-1),DIC("DR")=""
..S FLD="" F S FLD=$O(PSL021(SID,FLD)) Q:FLD="" D
...S DIC("DR")=DIC("DR")_FLD_"////^S X=PSL021(SID,"_FLD_")"
...I FLD'=LSTFLD S DIC("DR")=DIC("DR")_";"
..K DO
..S X=SID,DIC="^IBA(368,"_+IEN368_",21,",DIC(0)="L",DA(1)=+IEN368
..D FILE^DICN
..S IEN021=Y
..K DIC,DA,X,Y,DTOUT,DUOUT
..;
..;File 368.2199 entries
..I $D(PSL2199) D
...S SID1="" F S SID1=$O(PSL2199(SID,SID1)) Q:SID1="" D
....S LSTFLD=$O(PSL2199(SID,SID1,""),-1),DIC("DR")=""
....S FLD="" F S FLD=$O(PSL2199(SID,SID1,FLD)) Q:FLD="" D
.....S DIC("DR")=DIC("DR")_FLD_"////^S X=PSL2199(SID,SID1,"_FLD_")"
.....I FLD'=LSTFLD S DIC("DR")=DIC("DR")_";"
....K DO
....S X=SID1,DIC="^IBA(368,"_+IEN368_",21,"_+IEN021_",99,",DIC(0)="L"
....S DA(1)=+IEN021,DA(2)=+IEN368
....D FILE^DICN
....K DIC,DA,X,Y,DTOUT,DUOUT
;
;File 368.0121 entries
I $D(PSL0121) D
.S SID="" F S SID=$O(PSL0121(SID)) Q:SID="" D
..S LSTFLD=$O(PSL0121(SID,""),-1),DIC("DR")=""
..S FLD="" F S FLD=$O(PSL0121(SID,FLD)) Q:FLD="" D
...S DIC("DR")=DIC("DR")_FLD_"////^S X=PSL0121(SID,"_FLD_")"
...I FLD'=LSTFLD S DIC("DR")=DIC("DR")_";"
..K DO
..S X=SID,DIC="^IBA(368,"_+IEN368_",121,",DIC(0)="L",DA(1)=+IEN368
..D FILE^DICN
..S IEN0121=Y
..K DIC,DA,X,Y,DTOUT,DUOUT
..;
..;File 368.12199 entries
..I $D(PSL12199) D
...S SID1="" F S SID1=$O(PSL12199(SID,SID1)) Q:SID1="" D
....S LSTFLD=$O(PSL12199(SID,SID1,""),-1),DIC("DR")=""
....S FLD="" F S FLD=$O(PSL12199(SID,SID1,FLD)) Q:FLD="" D
.....S DIC("DR")=DIC("DR")_FLD_"////^S X=PSL12199(SID,SID1,"_FLD_")"
.....I FLD'=LSTFLD S DIC("DR")=DIC("DR")_";"
....K DO
....S DIC="^IBA(368,"_+IEN368_",121,"_+IEN0121_",99,",DIC(0)="L"
....S X=SID1,DA(1)=+IEN0121,DA(2)=+IEN368
....D FILE^DICN
....K DIC,DA,X,Y,DTOUT,DUOUT
;
K DATA,OBX013,OBX0113,PSL021,IEN021,PSL2199,PSL0121,IEN0121,PSL12199,IEN368,SID,SID1,FLD,LSTFLD
Q
;
PURG ; purge file 368 entries based on # of days in PURGE DAYS 277 RFAI in IB SITE PARAMETERS
; (field #52.01 in file #350.9). Called from IBAMTC (tasked option IB MT NIGHT COMP) NIGHTLY^IBTRKR
; null entry (the default) indicates the transactions will be stored forever.
;
N IBPURG,IBEND,IBSTR,IBRFI,DA,DIK
S IBPURG=$$GET1^DIQ(350.9,1,52.01) Q:IBPURG=""
S IBEND=$$FMTHL7^XLFDT($$FMADD^XLFDT(DT,-IBPURG))
S IBSTR="" F S IBSTR=$O(^IBA(368,"C",IBSTR)) Q:IBSTR=""!($E(IBSTR,1,8)>IBEND) D
.S IBRFI="" F S IBRFI=$O(^IBA(368,"C",IBSTR,IBRFI)) Q:IBRFI="" D
..; DELETE
..S DA=IBRFI,DIK="^IBA(368," D ^DIK
K IBPURG,IBEND,IBSTR,IBRFI,DA,DIK
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBRFIHL1 6146 printed Apr 09, 2024@21:24:55 Page 2
IBRFIHL1 ;TDM/DAL - HL7 Process Incoming EHC_E12 Messages ; 2/22/16 1:46pm
+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 incoming EHC_E12 HL7 messages. It will
+6 ; parse and file the message into the HEALTH CARE CLAIM RFAI (277)
+7 ; (#368) file.
+8 ;
EN ; Entry Point
+1 NEW AUTO,EBDA,ERFLG,ERROR,HCT,HLCMP,HLREP,HLSCMP,RIEN,SEG,DATA,IBSEG,MSH10
+2 NEW DFNPTR,DFNSSN
+3 SET ERFLG=0
+4 ;
+5 ; HL7 component separator
SET HLCMP=$EXTRACT(HL("ECH"))
+6 ; HL7 subcomponent separator
SET HLSCMP=$EXTRACT(HL("ECH"),4)
+7 ; HL7 repetition separator
SET HLREP=$EXTRACT(HL("ECH"),2)
+8 ;
+9 ; Loop through the message and find each segment for processing
+10 SET HCT=""
FOR
SET HCT=$ORDER(^TMP($JOB,"IBRFIHLI",HCT))
if HCT=""
QUIT
Begin DoDot:1
+11 DO SPAR^IBRFIHLU
+12 SET SEG=$GET(IBSEG(1))
+13 ;Message Header Seg
IF SEG="MSH"
DO MSH^IBRFIHL2(.IBSEG)
QUIT
+14 ;Request for Info Seg
IF SEG="RFI"
DO RFI^IBRFIHL2(.IBSEG)
QUIT
+15 ;Contact Segment
IF SEG="CTD"
DO CTD^IBRFIHL2(.IBSEG)
QUIT
+16 ;Invoice Segment
IF SEG="IVC"
DO IVC^IBRFIHL2(.IBSEG,.DFNPTR,.DFNSSN)
QUIT
+17 ;Patient Segment
IF SEG="PID"
DO PID^IBRFIHL2(.IBSEG,$GET(DFNPTR),$GET(DFNSSN))
QUIT
+18 ;Product/Service Ln Item
IF SEG="PSL"
DO PSL^IBRFIHL2(.IBSEG)
QUIT
+19 ;Payee Info Segment
IF SEG="PYE"
DO PYE^IBRFIHL2(.IBSEG)
QUIT
+20 ;Observation/Result
IF SEG="OBX"
DO OBX^IBRFIHL2(.IBSEG)
End DoDot:1
if ERFLG
QUIT
+21 DO FILE
+22 QUIT
+23 ;
FILE ; File all data.
+1 NEW DO,DIC,X,FLD,IEN368,DIK,DA,DIE,DR,Y,DTOUT,DUOUT,LVL0,LVL1,SID,SID1
+2 ;
+3 ;Determine Primary LOINC
+4 if $GET(OBX013(1,1.02))'=""
SET DATA(368,22.03)=$GET(OBX013(1,1.02))
+5 if $GET(OBX013(1,1.02))=""
SET DATA(368,22.03)=$GET(PSL2199(1,1,1.02))
+6 ;*******************************************************************
+7 ;The following code has been commented out to avoid performing a
+8 ;lookup into the LAB LOINC file (#95.3) because an Integration
+9 ;Agreement could not be obtained.
+10 ;S VAL=DATA(368,22.03) S VAL=$S(VAL["-":$P(VAL,"-"),1:$E(VAL,1,$L(VAL)-1))
+11 ;S IEN=$$FIND1^DIC(95.3,,,VAL) S:IEN>0 DATA(368,122.03)=IEN
+12 ;*******************************************************************
+13 SET VAL=DATA(368,22.03)
IF VAL'["-"
SET VAL=$EXTRACT(VAL,1,$LENGTH(VAL)-1)_"-"_$EXTRACT(VAL,$LENGTH(VAL))
SET DATA(368,22.03)=VAL
+14 ;
+15 ;Initialize Deletion Flag
+16 SET DATA(368,200.01)=0
+17 ;
+18 ;File 368 data
+19 SET LSTFLD=$ORDER(DATA(368,""),-1)
SET DIC("DR")=""
+20 SET FLD=0
FOR
SET FLD=$ORDER(DATA(368,FLD))
if FLD=""
QUIT
Begin DoDot:1
+21 SET DIC("DR")=DIC("DR")_FLD_"////^S X=DATA(368,"_FLD_")"
+22 IF FLD'=LSTFLD
SET DIC("DR")=DIC("DR")_";"
End DoDot:1
+23 KILL DO
+24 SET DIC="^IBA(368,"
SET DIC(0)=""
SET X=DATA(368,.01)
+25 DO FILE^DICN
+26 SET IEN368=Y
+27 KILL DIC,X,Y,DTOUT,DUOUT
+28 ;
+29 ;File 368.013 data
+30 IF $DATA(OBX013)
Begin DoDot:1
+31 SET SID=""
FOR
SET SID=$ORDER(OBX013(SID))
if SID=""
QUIT
Begin DoDot:2
+32 SET LSTFLD=$ORDER(OBX013(SID,""),-1)
SET DIC("DR")=""
+33 SET FLD=0
FOR
SET FLD=$ORDER(OBX013(SID,FLD))
if FLD=""
QUIT
Begin DoDot:3
+34 SET DIC("DR")=DIC("DR")_FLD_"////^S X=OBX013(SID,"_FLD_")"
+35 IF FLD'=LSTFLD
SET DIC("DR")=DIC("DR")_";"
End DoDot:3
+36 KILL DO
+37 SET X=SID
SET DIC="^IBA(368,"_+IEN368_",13,"
SET DIC(0)="L"
SET DA(1)=+IEN368
+38 DO FILE^DICN
+39 KILL DIC,DA,X,Y,DTOUT,DUOUT
End DoDot:2
End DoDot:1
+40 ;
+41 ;File 368.0113 data
+42 IF $DATA(OBX0113)
Begin DoDot:1
+43 SET SID=""
FOR
SET SID=$ORDER(OBX0113(SID))
if SID=""
QUIT
Begin DoDot:2
+44 SET LSTFLD=$ORDER(OBX0113(SID,""),-1)
SET DIC("DR")=""
+45 SET FLD=0
FOR
SET FLD=$ORDER(OBX0113(SID,FLD))
if FLD=""
QUIT
Begin DoDot:3
+46 SET DIC("DR")=DIC("DR")_FLD_"////^S X=OBX0113(SID,"_FLD_")"
+47 IF FLD'=LSTFLD
SET DIC("DR")=DIC("DR")_";"
End DoDot:3
+48 KILL DO
+49 SET X=SID
SET DIC="^IBA(368,"_+IEN368_",113,"
SET DIC(0)="L"
SET DA(1)=+IEN368
+50 DO FILE^DICN
+51 KILL DIC,DA,X,Y,DTOUT,DUOUT
End DoDot:2
End DoDot:1
+52 ;
+53 ;File 368.021 entries
+54 IF $DATA(PSL021)
Begin DoDot:1
+55 SET SID=""
FOR
SET SID=$ORDER(PSL021(SID))
if SID=""
QUIT
Begin DoDot:2
+56 SET LSTFLD=$ORDER(PSL021(SID,""),-1)
SET DIC("DR")=""
+57 SET FLD=""
FOR
SET FLD=$ORDER(PSL021(SID,FLD))
if FLD=""
QUIT
Begin DoDot:3
+58 SET DIC("DR")=DIC("DR")_FLD_"////^S X=PSL021(SID,"_FLD_")"
+59 IF FLD'=LSTFLD
SET DIC("DR")=DIC("DR")_";"
End DoDot:3
+60 KILL DO
+61 SET X=SID
SET DIC="^IBA(368,"_+IEN368_",21,"
SET DIC(0)="L"
SET DA(1)=+IEN368
+62 DO FILE^DICN
+63 SET IEN021=Y
+64 KILL DIC,DA,X,Y,DTOUT,DUOUT
+65 ;
+66 ;File 368.2199 entries
+67 IF $DATA(PSL2199)
Begin DoDot:3
+68 SET SID1=""
FOR
SET SID1=$ORDER(PSL2199(SID,SID1))
if SID1=""
QUIT
Begin DoDot:4
+69 SET LSTFLD=$ORDER(PSL2199(SID,SID1,""),-1)
SET DIC("DR")=""
+70 SET FLD=""
FOR
SET FLD=$ORDER(PSL2199(SID,SID1,FLD))
if FLD=""
QUIT
Begin DoDot:5
+71 SET DIC("DR")=DIC("DR")_FLD_"////^S X=PSL2199(SID,SID1,"_FLD_")"
+72 IF FLD'=LSTFLD
SET DIC("DR")=DIC("DR")_";"
End DoDot:5
+73 KILL DO
+74 SET X=SID1
SET DIC="^IBA(368,"_+IEN368_",21,"_+IEN021_",99,"
SET DIC(0)="L"
+75 SET DA(1)=+IEN021
SET DA(2)=+IEN368
+76 DO FILE^DICN
+77 KILL DIC,DA,X,Y,DTOUT,DUOUT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+78 ;
+79 ;File 368.0121 entries
+80 IF $DATA(PSL0121)
Begin DoDot:1
+81 SET SID=""
FOR
SET SID=$ORDER(PSL0121(SID))
if SID=""
QUIT
Begin DoDot:2
+82 SET LSTFLD=$ORDER(PSL0121(SID,""),-1)
SET DIC("DR")=""
+83 SET FLD=""
FOR
SET FLD=$ORDER(PSL0121(SID,FLD))
if FLD=""
QUIT
Begin DoDot:3
+84 SET DIC("DR")=DIC("DR")_FLD_"////^S X=PSL0121(SID,"_FLD_")"
+85 IF FLD'=LSTFLD
SET DIC("DR")=DIC("DR")_";"
End DoDot:3
+86 KILL DO
+87 SET X=SID
SET DIC="^IBA(368,"_+IEN368_",121,"
SET DIC(0)="L"
SET DA(1)=+IEN368
+88 DO FILE^DICN
+89 SET IEN0121=Y
+90 KILL DIC,DA,X,Y,DTOUT,DUOUT
+91 ;
+92 ;File 368.12199 entries
+93 IF $DATA(PSL12199)
Begin DoDot:3
+94 SET SID1=""
FOR
SET SID1=$ORDER(PSL12199(SID,SID1))
if SID1=""
QUIT
Begin DoDot:4
+95 SET LSTFLD=$ORDER(PSL12199(SID,SID1,""),-1)
SET DIC("DR")=""
+96 SET FLD=""
FOR
SET FLD=$ORDER(PSL12199(SID,SID1,FLD))
if FLD=""
QUIT
Begin DoDot:5
+97 SET DIC("DR")=DIC("DR")_FLD_"////^S X=PSL12199(SID,SID1,"_FLD_")"
+98 IF FLD'=LSTFLD
SET DIC("DR")=DIC("DR")_";"
End DoDot:5
+99 KILL DO
+100 SET DIC="^IBA(368,"_+IEN368_",121,"_+IEN0121_",99,"
SET DIC(0)="L"
+101 SET X=SID1
SET DA(1)=+IEN0121
SET DA(2)=+IEN368
+102 DO FILE^DICN
+103 KILL DIC,DA,X,Y,DTOUT,DUOUT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+104 ;
+105 KILL DATA,OBX013,OBX0113,PSL021,IEN021,PSL2199,PSL0121,IEN0121,PSL12199,IEN368,SID,SID1,FLD,LSTFLD
+106 QUIT
+107 ;
PURG ; purge file 368 entries based on # of days in PURGE DAYS 277 RFAI in IB SITE PARAMETERS
+1 ; (field #52.01 in file #350.9). Called from IBAMTC (tasked option IB MT NIGHT COMP) NIGHTLY^IBTRKR
+2 ; null entry (the default) indicates the transactions will be stored forever.
+3 ;
+4 NEW IBPURG,IBEND,IBSTR,IBRFI,DA,DIK
+5 SET IBPURG=$$GET1^DIQ(350.9,1,52.01)
if IBPURG=""
QUIT
+6 SET IBEND=$$FMTHL7^XLFDT($$FMADD^XLFDT(DT,-IBPURG))
+7 SET IBSTR=""
FOR
SET IBSTR=$ORDER(^IBA(368,"C",IBSTR))
if IBSTR=""!($EXTRACT(IBSTR,1,8)>IBEND)
QUIT
Begin DoDot:1
+8 SET IBRFI=""
FOR
SET IBRFI=$ORDER(^IBA(368,"C",IBSTR,IBRFI))
if IBRFI=""
QUIT
Begin DoDot:2
+9 ; DELETE
+10 SET DA=IBRFI
SET DIK="^IBA(368,"
DO ^DIK
End DoDot:2
End DoDot:1
+11 KILL IBPURG,IBEND,IBSTR,IBRFI,DA,DIK
+12 QUIT
+13 ;
