IBCNEHLT ;DAOU/ALA - HL7 Process Incoming MFN Messages ; 15 Mar 2016 3:00 PM
;;2.0;INTEGRATED BILLING;**184,251,271,300,416,438,506,549,582,601,621,664**;21-MAR-94;Build 29
;;Per VA Directive 6402, this routine should not be modified.
;
;**Program Description**
; This program will process incoming MFN messages and
; update the appropriate tables
;
EN ; Entry Point
NEW AIEN,APIEN,APP,D0,D,DESC,DQ,DR,EIV,FILE,FLN,HEDI,ID,IEN
NEW PEDI,SEG,STAT,HCT,NEWID,TSSN,REQSUB,NAFLG,NPFLG,TRUSTED
NEW IBCNACT,IBCNADT,FSVDY,PSVDY
NEW CMIEN,DATA,DATAAP,DATABPS,DATACM,DATE,ERROR,FIELDNO,FILENO
NEW IBSEG,MSG,BUFF
NEW X12TABLE,BADFMT
;
; BADFMT is true if a site with patch 300 receives an eIV message in the previous HL7 interface structure (pre-300)
;
; Build local table of file numbers of DD tables that are updated by FSC for use by the eIV interface
;
; * Warning: Before adding a new table to be updated by FSC, one must get FSC
; to agree and the eIV ICD documentation has to be updated and
; approved by the VA HL7 team. Just adding a table number here does
; absolutely nothing without involving the other teams.
;
F D=11:1:18 S X12TABLE("365.0"_D)=""
;F D=21:1:28 S X12TABLE("365.0"_D)="" ; FSC does not update files #365.022 through #365.028
; IB*2*664/dw fixed typo on file number
;S X12TABLE(350.021)=""
S X12TABLE(365.021)=""
;
;S X12TABLE(350.9)="" ; IB*2.0*506 ; IB*2*664/dw moved to different array as it is not a X12 file
;S X12TABLE(350.9002)="" ; IB*2.0*549 ; IB*2*664/dw moved to different array as it is not a X12 file
S EIV(350.9)="",EIV(350.9002)="",EIV(365.12)="" ; IB*2*664/dw
;
S APP=""
S HCT=0,ERFLG=0
F S HCT=$O(^TMP($J,"IBCNEHLI",HCT)) Q:HCT="" D SPAR^IBCNEHLU I $G(IBSEG(1))="MFI" S FILE=$G(IBSEG(2)),FLN=$P(FILE,$E(HLECH,1),1) Q
I FLN=365.12 D
. S HCT=0,BADFMT=0
. F S HCT=$O(^TMP($J,"IBCNEHLI",HCT)) Q:HCT="" D Q:(APP="IIV")!BADFMT
.. D SPAR^IBCNEHLU
.. I $G(IBSEG(1))="MFE",$P($G(IBSEG(5)),$E(HLECH,1),3)'="" D Q
... S BADFMT=1,APP=""
... S MSG(1)="Log a Remedy Ticket for this issue."
... S MSG(2)="Please include in the Remedy Ticket that the Vista eIV payer tables may be out"
... S MSG(3)="of sync with the master list and will need a new copy of the payer table"
... S MSG(4)="update message from Austin."
... D MSG^IBCNEUT5($$MGRP^IBCNEUT5(),"eIV payer tables may be out of synch with master list","MSG(")
.. ;I $G(IBSEG(1))="ZPA" S APP="IIV" ; IB*2*664/dw No longer needed, added 365.12 to the EIV array
I $D(X12TABLE(FLN))!$D(EIV(FLN)) S APP="IIV" ; IB*2*664/dw
;
I APP="" Q ; If APP is not IIV then quit (IIV is the former name for EIV)
;
S HCT=1,NAFLG=0,NPFLG=0,D=""
F S HCT=$O(^TMP($J,"IBCNEHLI",HCT)) Q:HCT="" D Q:ERFLG
. D SPAR^IBCNEHLU
. S SEG=$G(IBSEG(1))
. ;
. ; APP should always be IIV at this point but leaving it in as a safety valve.
. I APP="IIV" D
.. I SEG="MFI" D
... S FILE=$G(IBSEG(2))
... S FLN=$P(FILE,$E(HLECH,1),1)
.. ;
.. I SEG="MFE" D
... I $G(FLN)="" S ERFLG=1,MSG(1)="File Number not found in MFN message" Q
... I '$$VFILE^DILFD(FLN) S ERFLG=1,MSG(1)="File "_FLN_" not found in the Data Dictionary" Q
... ;
... I FLN'=365.12 D Q
.... S DATA=$G(IBSEG(5))
.... S ID=$$DECHL7^IBCNEHL2($P(DATA,$E(HLECH,1),1)),DESC=$$DECHL7^IBCNEHL2($P(DATA,$E(HLECH,1),2))
.... D TFIL
... ;
... ; Pull the action code
... S IBCNACT=$G(IBSEG(2))
... ; Effective Date
... S IBCNADT=$G(IBSEG(4))
.. ;
.. I SEG="ZP0" D
... S ID=$$DECHL7^IBCNEHL2(IBSEG(3)),NEWID=$$DECHL7^IBCNEHL2(IBSEG(4))
... S DESC=$$DECHL7^IBCNEHL2(IBSEG(5)),HEDI=$$DECHL7^IBCNEHL2(IBSEG(6)),PEDI=$$DECHL7^IBCNEHL2(IBSEG(7))
.. ;
.. I SEG="ZPA" D
... S STAT=$S(IBSEG(4)="Y":1,1:0)
... S TSSN=IBSEG(5),REQSUB=IBSEG(7)
... S FSVDY=IBSEG(8),PSVDY=IBSEG(9)
... S TRUSTED=$S(IBSEG(10)="N":0,1:1)
... D PFIL
Q
;
PFIL ; Payer Table Filer (Updates file #365.12)
; Set the action:
; MAD=Add, MUP=Update, MDC=Deactivate, MAC=Reactivate
N OLDAF,OLDTF
S IBCNADT=$$FMDATE^HLFNC(IBCNADT)
I IBCNADT="" S IBCNADT=$$NOW^XLFDT()
; If the action is MAD - Add the payer as new
; IB*582/TAZ if the action is MUP and the entry doesn't exist, add the payer as new
N IBNOK,IBAPP,IBID,IBDESC,IBSTR,IBCNTYPE
S IBNOK=0,IBAPP=($TR(APP," ")=""),IBID=($TR(ID," ")=""),IBDESC=($TR(DESC," ")=""),IBNOK=IBAPP!IBID!IBDESC
I IBNOK D G PFILX
. S IBCNTYPE=$S(IBCNACT="MAD":"Add",IBCNACT="MUP":"Update",IBCNACT="MDC":"Deactivate",IBCNACT="MAC":"Reactivate",1:"Unknown")
. S MSG(1)=IBCNTYPE_" ("_IBCNACT_") action received. Payer and/or Application may be unknown."
. S MSG(2)=""
. S MSG(3)="VA National : "_ID
. S MSG(4)="Payer Name : "_DESC
. S MSG(5)="Application : "_APP
. S MSG(6)=""
. S MSG(7)="Log a Remedy Ticket for this issue."
. S MSG(8)=""
. S MSG(9)="Please include in the Remedy Ticket that VISTA did not receive the required"
. S MSG(10)="information or the accurate information to add/update this Payer."
. D MSG^IBCNEUT5($$MGRP^IBCNEUT5(),"eIV payer tables may be out of synch with master list","MSG(")
D FND I IEN<0 D MAD(DESC)
;
S DESC=$E(DESC,1,80) ;restriction of the field in the DD
S DIC=$$ROOT^DILFD(FLN)
S DR=".01///^S X=DESC;.02////^S X=NEWID;.05////^S X=PEDI;.06////^S X=HEDI"
;
; If new payer, add the Date/Time created
I NPFLG S DR=DR_";.04///^S X=$$NOW^XLFDT()"
S DIE=DIC,DA=IEN D ^DIE
;
; Check for application
S DIC="^IBE(365.13,",DIC(0)="X",X=APP D ^DIC
S AIEN=+Y I AIEN<1 D
. S DLAYGO=365.13,DIC(0)="L",DIC("P")=DLAYGO
. S DIE=DIC,X=APP
. K DD,DO
. D FILE^DICN
. K DO
. S AIEN=+Y
;
S APIEN=$O(^IBE(365.12,IEN,1,"B",AIEN,""))
I APIEN="" D
. S DLAYGO=365.121,DIC(0)="L",DIC("P")=DLAYGO,DA(1)=IEN,X=AIEN
. S DIC="^IBE(365.12,"_DA(1)_",1,",DIE=DIC
. I '$D(^IBE(365.12,IEN,1,0)) S ^IBE(365.12,IEN,1,0)="^365.121P^^"
. K DD,DO
. D FILE^DICN
. K DO
. S APIEN=+Y,NAFLG=1
; get current values for Active and Trusted flags
S OLDAF=$P(^IBE(365.12,IEN,1,APIEN,0),U,2),OLDTF=$P(^IBE(365.12,IEN,1,APIEN,0),U,7)
S DA(1)=IEN,DA=APIEN,DIC="^IBE(365.12,"_DA(1)_",1,",DR=""
;
I IBCNACT="MDC" S DR=DR_".11///^S X=1;.12////^S X=IBCNADT;",STAT=0
I IBCNACT="MAC" S DR=DR_".11///^S X=0;.12///@;"
S DR=DR_".02///^S X=STAT;.06///^S X=$$NOW^XLFDT();.07///^S X=TRUSTED"
I IBCNACT'="MDC" S DR=DR_";.08///^S X=REQSUB;.1///^S X=TSSN;.14///^S X=FSVDY;.15///^S X=PSVDY"
;
; If new application, add the Date/Time created
I NAFLG S DR=DR_";.13///^S X=$$NOW^XLFDT()"
;
S DIE=DIC D ^DIE
S IBACK="AA"
; Update flag logs
I STAT'=OLDAF D UPDLOG("A",STAT,IEN,APIEN)
I TRUSTED'=OLDTF D UPDLOG("T",TRUSTED,IEN,APIEN)
I IBCNACT="MDC" D MDC Q
PFILX ;
Q
;
TFIL ; eIV Site Parameter table filer & X12 Code List table filer
; (Updates X12 Code lists - Refer to the X12TABLE array at the top of this routine for file #s)
; (Updates file #350.9 & some of its subfiles associated with eIV - aka IIV)
; Input: DESC - Field Number
; ID - Field Value
; FLN - File Number
N DA,DIC,DIE,DLAYGO,DR,EXTRACT,IEN,MAX,XX,X,Y ;IB*2.0*549 - Added DA,DIE,DR,EXTRACT,XX
;
; store the FILENAME, FIELDNAME and VALUE if the APP is IIV and FLN is 350.9. - IB*2.0*506
; For file #350.9, DESC represents the FIELD NUMBER and ID represents the VALUE.
I APP="IIV",FLN=350.9 D Q
. S DIE=FLN,DA=1,DR=DESC_"///"_ID
. D ^DIE
. S IBACK="AA"
;
; IB*2.0*549 Added if statement
I APP="IIV",FLN=350.9002 D Q
. S EXTRACT=$E(DESC,1,4) ; Either "Buff", "Appt" or "EICD"
. S XX=$S(EXTRACT="Buff":1,EXTRACT="Appt":2,EXTRACT="EICD":4,1:3) ; IB*2.0*621/DM add EICD
. S DESC=$E(DESC,5,99) ; Field number
. S DA(1)=1
. S DA=$O(^IBE(350.9,1,51.17,"B",XX,"")) ; Find correct multiple
. ;
. ; File the new value
. S DIE="^IBE(350.9,1,51.17,"
. S DR=DESC_"///"_ID
. D ^DIE
. S IBACK="AA"
;
;IB*582/TAZ - Add new entries and update existing entries
;
S DIC(0)="X",X=ID,DIC=$$ROOT^DILFD(FLN)
D ^DIC S IEN=+Y
; don't update existing entries
;I IEN>0 Q
;Add new entry to table
I IEN<1 D
. S DLAYGO=FLN,DIC(0)="L"
. K DD,DO D FILE^DICN K DO
;
;Update Description
;
D FIELD^DID(FLN,.02,,"FIELD LENGTH","MAX")
I MAX("FIELD LENGTH")>0 S DESC=$E(DESC,1,MAX("FIELD LENGTH")) ; restriction of the field in the DD
; add new entry to the table
;S DLAYGO=FLN,DIC(0)="L",DIC("DR")=".02///"_DESC
;S DLAYGO=FLN,DIC(0)="L",DIC("DR")=".02///^S X=DESC"
;K DD,DO D FILE^DICN K DO
;IB*2*601/HN corrected use of the DR variable
;S DIE=DIC,DA=IEN,DIC("DR")=".02///^S X=DESC" D ^DIE
S DIE=DIC,DA=IEN,DR=".02///^S X=DESC" D ^DIE
S IBACK="AA"
Q
;
MAD(X) ; Add an entry
;IB*582/TAZ - Moved check to PFIL MAD is called for any record that is not found in the file.
;D FND
;I IEN>0 G MADX
NEW DIC,DIE,DA,DLAYGO,Y,DR
S DIC=$$ROOT^DILFD(FLN)
S DLAYGO=FLN,DIC(0)="L",DIC("P")=DLAYGO,DIE=DIC
K DD,DO
D FILE^DICN
K DO
S IEN=+Y,NPFLG=1
MADX ;
Q
;
FND ; Find an existing Payer entry
NEW DIC,DIE,X,DA,DLAYGO,Y,DR
S X=ID,DIC(0)="X",D="C",DIC=$$ROOT^DILFD(FLN)
;
; Do a lookup with the "C" cross-reference
D IX^DIC
S IEN=+Y
Q
;
MDC ; Check for active transmissions and cancel
NEW STA,HIEN,RIEN,TQIEN
F STA=1,2,4,6 S TQIEN="" D
. F S TQIEN=$O(^IBCN(365.1,"AC",STA,TQIEN)) Q:TQIEN="" D
.. ;
.. ; If the record doesn't match the payer, quit
.. I $P(^IBCN(365.1,TQIEN,0),U,3)'=IEN Q
.. ;
.. ; Set the status to 'Cancelled'
.. D SST^IBCNEUT2(TQIEN,7)
.. ;
.. ; If a buffer entry, set to ! (bang)
.. S BUFF=$P(^IBCN(365.1,TQIEN,0),U,5)
.. I BUFF'="" D BUFF^IBCNEUT2(BUFF,17)
.. ;
.. ; Change any responses status also
.. S HIEN=0 F S HIEN=$O(^IBCN(365.1,TQIEN,2,HIEN)) Q:'HIEN D
... S RIEN=$P(^IBCN(365.1,TQIEN,2,HIEN,0),U,3)
... ; If the Response status is 'Response Received', don't change it
... I $P(^IBCN(365,RIEN,0),U,6)=3 Q
... D RSP^IBCNEUT2(RIEN,7)
Q
;
UPDLOG(FLAG,VALUE,PIEN,APIEN) ; Update active/trusted flag logs
; FLAG - "A" for Active flag, "T" for Trusted flag
; VALUE - new flag value (0 or 1)
; PIEN - ien in PAYER file (365.12)
; APIEN - ien in APPLICATION sub-file (365.121)
;
N FILE,IENSTR,UPDT
I $G(FLAG)=""!($G(VALUE)="") Q
I +$G(PIEN)=0!(+$G(APIEN)=0) Q
S FILE=$S(FLAG="A":"365.1212",FLAG="T":"365.1213",1:"") I FILE="" Q
S IENSTR="+1,"_APIEN_","_PIEN_","
S UPDT(FILE,IENSTR,.01)=$$NOW^XLFDT()
S UPDT(FILE,IENSTR,.02)=VALUE
D UPDATE^DIE("E","UPDT")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNEHLT 10662 printed Apr 07, 2021@15:11:34 Page 2
IBCNEHLT ;DAOU/ALA - HL7 Process Incoming MFN Messages ; 15 Mar 2016 3:00 PM
+1 ;;2.0;INTEGRATED BILLING;**184,251,271,300,416,438,506,549,582,601,621,664**;21-MAR-94;Build 29
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;**Program Description**
+5 ; This program will process incoming MFN messages and
+6 ; update the appropriate tables
+7 ;
EN ; Entry Point
+1 NEW AIEN,APIEN,APP,D0,D,DESC,DQ,DR,EIV,FILE,FLN,HEDI,ID,IEN
+2 NEW PEDI,SEG,STAT,HCT,NEWID,TSSN,REQSUB,NAFLG,NPFLG,TRUSTED
+3 NEW IBCNACT,IBCNADT,FSVDY,PSVDY
+4 NEW CMIEN,DATA,DATAAP,DATABPS,DATACM,DATE,ERROR,FIELDNO,FILENO
+5 NEW IBSEG,MSG,BUFF
+6 NEW X12TABLE,BADFMT
+7 ;
+8 ; BADFMT is true if a site with patch 300 receives an eIV message in the previous HL7 interface structure (pre-300)
+9 ;
+10 ; Build local table of file numbers of DD tables that are updated by FSC for use by the eIV interface
+11 ;
+12 ; * Warning: Before adding a new table to be updated by FSC, one must get FSC
+13 ; to agree and the eIV ICD documentation has to be updated and
+14 ; approved by the VA HL7 team. Just adding a table number here does
+15 ; absolutely nothing without involving the other teams.
+16 ;
+17 FOR D=11:1:18
SET X12TABLE("365.0"_D)=""
+18 ;F D=21:1:28 S X12TABLE("365.0"_D)="" ; FSC does not update files #365.022 through #365.028
+19 ; IB*2*664/dw fixed typo on file number
+20 ;S X12TABLE(350.021)=""
+21 SET X12TABLE(365.021)=""
+22 ;
+23 ;S X12TABLE(350.9)="" ; IB*2.0*506 ; IB*2*664/dw moved to different array as it is not a X12 file
+24 ;S X12TABLE(350.9002)="" ; IB*2.0*549 ; IB*2*664/dw moved to different array as it is not a X12 file
+25 ; IB*2*664/dw
SET EIV(350.9)=""
SET EIV(350.9002)=""
SET EIV(365.12)=""
+26 ;
+27 SET APP=""
+28 SET HCT=0
SET ERFLG=0
+29 FOR
SET HCT=$ORDER(^TMP($JOB,"IBCNEHLI",HCT))
if HCT=""
QUIT
DO SPAR^IBCNEHLU
IF $GET(IBSEG(1))="MFI"
SET FILE=$GET(IBSEG(2))
SET FLN=$PIECE(FILE,$EXTRACT(HLECH,1),1)
QUIT
+30 IF FLN=365.12
Begin DoDot:1
+31 SET HCT=0
SET BADFMT=0
+32 FOR
SET HCT=$ORDER(^TMP($JOB,"IBCNEHLI",HCT))
if HCT=""
QUIT
Begin DoDot:2
+33 DO SPAR^IBCNEHLU
+34 IF $GET(IBSEG(1))="MFE"
IF $PIECE($GET(IBSEG(5)),$EXTRACT(HLECH,1),3)'=""
Begin DoDot:3
+35 SET BADFMT=1
SET APP=""
+36 SET MSG(1)="Log a Remedy Ticket for this issue."
+37 SET MSG(2)="Please include in the Remedy Ticket that the Vista eIV payer tables may be out"
+38 SET MSG(3)="of sync with the master list and will need a new copy of the payer table"
+39 SET MSG(4)="update message from Austin."
+40 DO MSG^IBCNEUT5($$MGRP^IBCNEUT5(),"eIV payer tables may be out of synch with master list","MSG(")
End DoDot:3
QUIT
+41 ;I $G(IBSEG(1))="ZPA" S APP="IIV" ; IB*2*664/dw No longer needed, added 365.12 to the EIV array
End DoDot:2
if (APP="IIV")!BADFMT
QUIT
End DoDot:1
+42 ; IB*2*664/dw
IF $DATA(X12TABLE(FLN))!$DATA(EIV(FLN))
SET APP="IIV"
+43 ;
+44 ; If APP is not IIV then quit (IIV is the former name for EIV)
IF APP=""
QUIT
+45 ;
+46 SET HCT=1
SET NAFLG=0
SET NPFLG=0
SET D=""
+47 FOR
SET HCT=$ORDER(^TMP($JOB,"IBCNEHLI",HCT))
if HCT=""
QUIT
Begin DoDot:1
+48 DO SPAR^IBCNEHLU
+49 SET SEG=$GET(IBSEG(1))
+50 ;
+51 ; APP should always be IIV at this point but leaving it in as a safety valve.
+52 IF APP="IIV"
Begin DoDot:2
+53 IF SEG="MFI"
Begin DoDot:3
+54 SET FILE=$GET(IBSEG(2))
+55 SET FLN=$PIECE(FILE,$EXTRACT(HLECH,1),1)
End DoDot:3
+56 ;
+57 IF SEG="MFE"
Begin DoDot:3
+58 IF $GET(FLN)=""
SET ERFLG=1
SET MSG(1)="File Number not found in MFN message"
QUIT
+59 IF '$$VFILE^DILFD(FLN)
SET ERFLG=1
SET MSG(1)="File "_FLN_" not found in the Data Dictionary"
QUIT
+60 ;
+61 IF FLN'=365.12
Begin DoDot:4
+62 SET DATA=$GET(IBSEG(5))
+63 SET ID=$$DECHL7^IBCNEHL2($PIECE(DATA,$EXTRACT(HLECH,1),1))
SET DESC=$$DECHL7^IBCNEHL2($PIECE(DATA,$EXTRACT(HLECH,1),2))
+64 DO TFIL
End DoDot:4
QUIT
+65 ;
+66 ; Pull the action code
+67 SET IBCNACT=$GET(IBSEG(2))
+68 ; Effective Date
+69 SET IBCNADT=$GET(IBSEG(4))
End DoDot:3
+70 ;
+71 IF SEG="ZP0"
Begin DoDot:3
+72 SET ID=$$DECHL7^IBCNEHL2(IBSEG(3))
SET NEWID=$$DECHL7^IBCNEHL2(IBSEG(4))
+73 SET DESC=$$DECHL7^IBCNEHL2(IBSEG(5))
SET HEDI=$$DECHL7^IBCNEHL2(IBSEG(6))
SET PEDI=$$DECHL7^IBCNEHL2(IBSEG(7))
End DoDot:3
+74 ;
+75 IF SEG="ZPA"
Begin DoDot:3
+76 SET STAT=$SELECT(IBSEG(4)="Y":1,1:0)
+77 SET TSSN=IBSEG(5)
SET REQSUB=IBSEG(7)
+78 SET FSVDY=IBSEG(8)
SET PSVDY=IBSEG(9)
+79 SET TRUSTED=$SELECT(IBSEG(10)="N":0,1:1)
+80 DO PFIL
End DoDot:3
End DoDot:2
End DoDot:1
if ERFLG
QUIT
+81 QUIT
+82 ;
PFIL ; Payer Table Filer (Updates file #365.12)
+1 ; Set the action:
+2 ; MAD=Add, MUP=Update, MDC=Deactivate, MAC=Reactivate
+3 NEW OLDAF,OLDTF
+4 SET IBCNADT=$$FMDATE^HLFNC(IBCNADT)
+5 IF IBCNADT=""
SET IBCNADT=$$NOW^XLFDT()
+6 ; If the action is MAD - Add the payer as new
+7 ; IB*582/TAZ if the action is MUP and the entry doesn't exist, add the payer as new
+8 NEW IBNOK,IBAPP,IBID,IBDESC,IBSTR,IBCNTYPE
+9 SET IBNOK=0
SET IBAPP=($TRANSLATE(APP," ")="")
SET IBID=($TRANSLATE(ID," ")="")
SET IBDESC=($TRANSLATE(DESC," ")="")
SET IBNOK=IBAPP!IBID!IBDESC
+10 IF IBNOK
Begin DoDot:1
+11 SET IBCNTYPE=$SELECT(IBCNACT="MAD":"Add",IBCNACT="MUP":"Update",IBCNACT="MDC":"Deactivate",IBCNACT="MAC":"Reactivate",1:"Unknown")
+12 SET MSG(1)=IBCNTYPE_" ("_IBCNACT_") action received. Payer and/or Application may be unknown."
+13 SET MSG(2)=""
+14 SET MSG(3)="VA National : "_ID
+15 SET MSG(4)="Payer Name : "_DESC
+16 SET MSG(5)="Application : "_APP
+17 SET MSG(6)=""
+18 SET MSG(7)="Log a Remedy Ticket for this issue."
+19 SET MSG(8)=""
+20 SET MSG(9)="Please include in the Remedy Ticket that VISTA did not receive the required"
+21 SET MSG(10)="information or the accurate information to add/update this Payer."
+22 DO MSG^IBCNEUT5($$MGRP^IBCNEUT5(),"eIV payer tables may be out of synch with master list","MSG(")
End DoDot:1
GOTO PFILX
+23 DO FND
IF IEN<0
DO MAD(DESC)
+24 ;
+25 ;restriction of the field in the DD
SET DESC=$EXTRACT(DESC,1,80)
+26 SET DIC=$$ROOT^DILFD(FLN)
+27 SET DR=".01///^S X=DESC;.02////^S X=NEWID;.05////^S X=PEDI;.06////^S X=HEDI"
+28 ;
+29 ; If new payer, add the Date/Time created
+30 IF NPFLG
SET DR=DR_";.04///^S X=$$NOW^XLFDT()"
+31 SET DIE=DIC
SET DA=IEN
DO ^DIE
+32 ;
+33 ; Check for application
+34 SET DIC="^IBE(365.13,"
SET DIC(0)="X"
SET X=APP
DO ^DIC
+35 SET AIEN=+Y
IF AIEN<1
Begin DoDot:1
+36 SET DLAYGO=365.13
SET DIC(0)="L"
SET DIC("P")=DLAYGO
+37 SET DIE=DIC
SET X=APP
+38 KILL DD,DO
+39 DO FILE^DICN
+40 KILL DO
+41 SET AIEN=+Y
End DoDot:1
+42 ;
+43 SET APIEN=$ORDER(^IBE(365.12,IEN,1,"B",AIEN,""))
+44 IF APIEN=""
Begin DoDot:1
+45 SET DLAYGO=365.121
SET DIC(0)="L"
SET DIC("P")=DLAYGO
SET DA(1)=IEN
SET X=AIEN
+46 SET DIC="^IBE(365.12,"_DA(1)_",1,"
SET DIE=DIC
+47 IF '$DATA(^IBE(365.12,IEN,1,0))
SET ^IBE(365.12,IEN,1,0)="^365.121P^^"
+48 KILL DD,DO
+49 DO FILE^DICN
+50 KILL DO
+51 SET APIEN=+Y
SET NAFLG=1
End DoDot:1
+52 ; get current values for Active and Trusted flags
+53 SET OLDAF=$PIECE(^IBE(365.12,IEN,1,APIEN,0),U,2)
SET OLDTF=$PIECE(^IBE(365.12,IEN,1,APIEN,0),U,7)
+54 SET DA(1)=IEN
SET DA=APIEN
SET DIC="^IBE(365.12,"_DA(1)_",1,"
SET DR=""
+55 ;
+56 IF IBCNACT="MDC"
SET DR=DR_".11///^S X=1;.12////^S X=IBCNADT;"
SET STAT=0
+57 IF IBCNACT="MAC"
SET DR=DR_".11///^S X=0;.12///@;"
+58 SET DR=DR_".02///^S X=STAT;.06///^S X=$$NOW^XLFDT();.07///^S X=TRUSTED"
+59 IF IBCNACT'="MDC"
SET DR=DR_";.08///^S X=REQSUB;.1///^S X=TSSN;.14///^S X=FSVDY;.15///^S X=PSVDY"
+60 ;
+61 ; If new application, add the Date/Time created
+62 IF NAFLG
SET DR=DR_";.13///^S X=$$NOW^XLFDT()"
+63 ;
+64 SET DIE=DIC
DO ^DIE
+65 SET IBACK="AA"
+66 ; Update flag logs
+67 IF STAT'=OLDAF
DO UPDLOG("A",STAT,IEN,APIEN)
+68 IF TRUSTED'=OLDTF
DO UPDLOG("T",TRUSTED,IEN,APIEN)
+69 IF IBCNACT="MDC"
DO MDC
QUIT
PFILX ;
+1 QUIT
+2 ;
TFIL ; eIV Site Parameter table filer & X12 Code List table filer
+1 ; (Updates X12 Code lists - Refer to the X12TABLE array at the top of this routine for file #s)
+2 ; (Updates file #350.9 & some of its subfiles associated with eIV - aka IIV)
+3 ; Input: DESC - Field Number
+4 ; ID - Field Value
+5 ; FLN - File Number
+6 ;IB*2.0*549 - Added DA,DIE,DR,EXTRACT,XX
NEW DA,DIC,DIE,DLAYGO,DR,EXTRACT,IEN,MAX,XX,X,Y
+7 ;
+8 ; store the FILENAME, FIELDNAME and VALUE if the APP is IIV and FLN is 350.9. - IB*2.0*506
+9 ; For file #350.9, DESC represents the FIELD NUMBER and ID represents the VALUE.
+10 IF APP="IIV"
IF FLN=350.9
Begin DoDot:1
+11 SET DIE=FLN
SET DA=1
SET DR=DESC_"///"_ID
+12 DO ^DIE
+13 SET IBACK="AA"
End DoDot:1
QUIT
+14 ;
+15 ; IB*2.0*549 Added if statement
+16 IF APP="IIV"
IF FLN=350.9002
Begin DoDot:1
+17 ; Either "Buff", "Appt" or "EICD"
SET EXTRACT=$EXTRACT(DESC,1,4)
+18 ; IB*2.0*621/DM add EICD
SET XX=$SELECT(EXTRACT="Buff":1,EXTRACT="Appt":2,EXTRACT="EICD":4,1:3)
+19 ; Field number
SET DESC=$EXTRACT(DESC,5,99)
+20 SET DA(1)=1
+21 ; Find correct multiple
SET DA=$ORDER(^IBE(350.9,1,51.17,"B",XX,""))
+22 ;
+23 ; File the new value
+24 SET DIE="^IBE(350.9,1,51.17,"
+25 SET DR=DESC_"///"_ID
+26 DO ^DIE
+27 SET IBACK="AA"
End DoDot:1
QUIT
+28 ;
+29 ;IB*582/TAZ - Add new entries and update existing entries
+30 ;
+31 SET DIC(0)="X"
SET X=ID
SET DIC=$$ROOT^DILFD(FLN)
+32 DO ^DIC
SET IEN=+Y
+33 ; don't update existing entries
+34 ;I IEN>0 Q
+35 ;Add new entry to table
+36 IF IEN<1
Begin DoDot:1
+37 SET DLAYGO=FLN
SET DIC(0)="L"
+38 KILL DD,DO
DO FILE^DICN
KILL DO
End DoDot:1
+39 ;
+40 ;Update Description
+41 ;
+42 DO FIELD^DID(FLN,.02,,"FIELD LENGTH","MAX")
+43 ; restriction of the field in the DD
IF MAX("FIELD LENGTH")>0
SET DESC=$EXTRACT(DESC,1,MAX("FIELD LENGTH"))
+44 ; add new entry to the table
+45 ;S DLAYGO=FLN,DIC(0)="L",DIC("DR")=".02///"_DESC
+46 ;S DLAYGO=FLN,DIC(0)="L",DIC("DR")=".02///^S X=DESC"
+47 ;K DD,DO D FILE^DICN K DO
+48 ;IB*2*601/HN corrected use of the DR variable
+49 ;S DIE=DIC,DA=IEN,DIC("DR")=".02///^S X=DESC" D ^DIE
+50 SET DIE=DIC
SET DA=IEN
SET DR=".02///^S X=DESC"
DO ^DIE
+51 SET IBACK="AA"
+52 QUIT
+53 ;
MAD(X) ; Add an entry
+1 ;IB*582/TAZ - Moved check to PFIL MAD is called for any record that is not found in the file.
+2 ;D FND
+3 ;I IEN>0 G MADX
+4 NEW DIC,DIE,DA,DLAYGO,Y,DR
+5 SET DIC=$$ROOT^DILFD(FLN)
+6 SET DLAYGO=FLN
SET DIC(0)="L"
SET DIC("P")=DLAYGO
SET DIE=DIC
+7 KILL DD,DO
+8 DO FILE^DICN
+9 KILL DO
+10 SET IEN=+Y
SET NPFLG=1
MADX ;
+1 QUIT
+2 ;
FND ; Find an existing Payer entry
+1 NEW DIC,DIE,X,DA,DLAYGO,Y,DR
+2 SET X=ID
SET DIC(0)="X"
SET D="C"
SET DIC=$$ROOT^DILFD(FLN)
+3 ;
+4 ; Do a lookup with the "C" cross-reference
+5 DO IX^DIC
+6 SET IEN=+Y
+7 QUIT
+8 ;
MDC ; Check for active transmissions and cancel
+1 NEW STA,HIEN,RIEN,TQIEN
+2 FOR STA=1,2,4,6
SET TQIEN=""
Begin DoDot:1
+3 FOR
SET TQIEN=$ORDER(^IBCN(365.1,"AC",STA,TQIEN))
if TQIEN=""
QUIT
Begin DoDot:2
+4 ;
+5 ; If the record doesn't match the payer, quit
+6 IF $PIECE(^IBCN(365.1,TQIEN,0),U,3)'=IEN
QUIT
+7 ;
+8 ; Set the status to 'Cancelled'
+9 DO SST^IBCNEUT2(TQIEN,7)
+10 ;
+11 ; If a buffer entry, set to ! (bang)
+12 SET BUFF=$PIECE(^IBCN(365.1,TQIEN,0),U,5)
+13 IF BUFF'=""
DO BUFF^IBCNEUT2(BUFF,17)
+14 ;
+15 ; Change any responses status also
+16 SET HIEN=0
FOR
SET HIEN=$ORDER(^IBCN(365.1,TQIEN,2,HIEN))
if 'HIEN
QUIT
Begin DoDot:3
+17 SET RIEN=$PIECE(^IBCN(365.1,TQIEN,2,HIEN,0),U,3)
+18 ; If the Response status is 'Response Received', don't change it
+19 IF $PIECE(^IBCN(365,RIEN,0),U,6)=3
QUIT
+20 DO RSP^IBCNEUT2(RIEN,7)
End DoDot:3
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
UPDLOG(FLAG,VALUE,PIEN,APIEN) ; Update active/trusted flag logs
+1 ; FLAG - "A" for Active flag, "T" for Trusted flag
+2 ; VALUE - new flag value (0 or 1)
+3 ; PIEN - ien in PAYER file (365.12)
+4 ; APIEN - ien in APPLICATION sub-file (365.121)
+5 ;
+6 NEW FILE,IENSTR,UPDT
+7 IF $GET(FLAG)=""!($GET(VALUE)="")
QUIT
+8 IF +$GET(PIEN)=0!(+$GET(APIEN)=0)
QUIT
+9 SET FILE=$SELECT(FLAG="A":"365.1212",FLAG="T":"365.1213",1:"")
IF FILE=""
QUIT
+10 SET IENSTR="+1,"_APIEN_","_PIEN_","
+11 SET UPDT(FILE,IENSTR,.01)=$$NOW^XLFDT()
+12 SET UPDT(FILE,IENSTR,.02)=VALUE
+13 DO UPDATE^DIE("E","UPDT")
+14 QUIT
