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,668,687,732,752**;21-MAR-94;Build 20
;;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
;IB*668/TAZ - Removed STAT and TRUSTED, Added NATIONAL AND AUTOUPDT to NEW Statements
NEW AIEN,APIEN,APP,AUTOUPDT,D0,D,DESC,DQ,DR,EIV,FILE,FLN,HEDI,ID,IEN
NEW PEDI,SEG,HCT,NEWID,TSSN,REQSUB,NATIONAL,NAFLG,NPFLG
NEW IBCNACT,IBCNADT,FSVDY,PSVDY
NEW CMIEN,DATA,DATAAP,DATABPS,DATACM,DATE,ERROR,FIELDNO,FILENO
NEW IBSEG,MSG,BUFF
;IB*732/CKB&TAZ - Added ISBLUE
NEW X12TABLE,BADFMT,ISBLUE
;
; 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.
;
;IB*2*644/DW - corrected arrays of file numbers X12TABLE array and EIV table array are for different purposes.
; Which modified some changes made by IB*506 and IB*549
;IB*2.0*668/TAZ - Moved the setup of X12TABLE(365.021) to this line.
F D=11:1:18,21 S X12TABLE("365.0"_D)="" ;original set of files that FSC controlled (prior to year 2022)
; IB*752/DTG - extended FSC control through 365.046
F D=22:1:29,31:1:39,41:1:46 S X12TABLE("365.0"_D)=""
;IB*2.0*668/TAZ - removed EIV(365.12) node. As this file is handled differently.
S EIV(350.9)="",EIV(350.9002)=""
;
S APP=""
S HCT=0,ERFLG=0
;IB*668/TAZ - Restructured so more readable and can add other lines
F S HCT=$O(^TMP($J,"IBCNEHLI",HCT)) Q:HCT="" D
. D SPAR^IBCNEHLU
. I $G(IBSEG(1))="MFI" S FILE=$G(IBSEG(2)),FLN=$P(FILE,$E(HLECH,1),1) Q
. ;IB*668/TAZ - Added to set APP variable at beginning of routine to be used in the message below
. I $G(IBSEG(1))="ZPA" S APP=$G(IBSEG(3)) S APP=$S(APP="IIV":"EIV",1:APP) Q
I FLN=365.12 D
. S HCT=0,BADFMT=0
. F S HCT=$O(^TMP($J,"IBCNEHLI",HCT)) Q:HCT="" D Q:(APP="EIV")!BADFMT
.. D SPAR^IBCNEHLU
.. I $G(IBSEG(1))="MFE",$P($G(IBSEG(5)),$E(HLECH,1),3)'="" D Q
... S BADFMT=1,APP=""
... ;IB*668/TAZ - Changed Remedy to Service in the message.
... S MSG(1)="Log a Service Ticket for this issue."
... S MSG(2)="Please include in the Service 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
;IB*668/TAZ - Quit if not an X12 Table update, and not an EIV update, and not a PAYER Table update
I '$D(X12TABLE(FLN)),'$D(EIV(FLN)),(FLN'=365.12) Q
;
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))
. ;
. ;IB*668/TAZ - Removed check on if APP=IIV, not needed. This moved everything up a level in the dot structure
. 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))
.. S ISBLUE=$S($G(IBSEG(8))="Y":1,1:0) ;IB*732/CKB&TAZ
. ;
. I SEG="ZPA" D
.. ;IB*668/TAZ - Added APP logic
.. S APP=$G(IBSEG(3)) S APP=$S(APP="IIV":"EIV",1:APP)
.. S NATIONAL=$S(IBSEG(4)="Y":1,1:0)
.. ;IB*668/TAZ - Only set some variables if App is EIV
.. I APP="EIV" D
... S REQSUB=$S(IBSEG(7)="N":0,1:1)
... S FSVDY=IBSEG(8),PSVDY=IBSEG(9)
... S AUTOUPDT=$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
;IB*668/TAZ - Added OLDNE and OLDAU to New Statement
N FDA,IENS,OLDNE,OLDAU
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
;IB*668/TAZ - Check for valid Payer Application and send message if not valid.
S DIC="^IBE(365.13,",DIC(0)="X",X=APP D ^DIC S AIEN=+Y I AIEN<1 S IBNOK=1 ;Bad PAYER APPLICATION
;IB*668/TAZ - Changed Remedy Ticket to Service Ticket in this message.
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 Service Ticket for this issue."
. S MSG(8)=""
. S MSG(9)="Please include in the Service 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)
;IB*732/CKB&TAZ - Add field .09 to DR string
S DR=".01///^S X=DESC;.02////^S X=NEWID;.05////^S X=PEDI;.06////^S X=HEDI;.09////^S X=ISBLUE"
;
;IB*668/TAZ - Moved MDC/MAC logic to new file location
;I MDC or MAC
I IBCNACT="MDC" S DR=DR_";.07///^S X=1;.08////^S X=IBCNADT;",NATIONAL=0
I IBCNACT="MAC" S DR=DR_";.07///^S X=0;.08///@;"
;
; 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
;
;IB*687/TAZ - Note: This adds the application to the Payer
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
. K DD,DO
. D FILE^DICN
. K DO
. S APIEN=+Y,NAFLG=1
;
;IB*668/TAZ - Updated field names and restructured filing logic for Payer File Application Level
S IENS=APIEN_","_IEN_","
; get current values for NATIONALLY ENABLED and AUTO-UPDATE flags
S OLDNE=$$GET1^DIQ(365.121,IENS,.02,"I")
S OLDAU=$$GET1^DIQ(365.121,IENS,4.01,"I") ;Only applied to EIV Payer Application
;
S FDA(365.121,IENS,.02)=NATIONAL
S FDA(365.121,IENS,.06)=$$NOW^XLFDT()
I IBCNACT'="MDC",(APP="EIV") D
. S FDA(365.121,IENS,4.01)=AUTOUPDT
. S FDA(365.121,IENS,4.02)=REQSUB
. S FDA(365.121,IENS,4.03)=FSVDY
. S FDA(365.121,IENS,4.04)=PSVDY
I NAFLG D
. S FDA(365.121,IENS,.13)=$$NOW^XLFDT()
. ;IB*687/TAZ - Set Locally Enabled to YES for IIU
. I APP="IIU" S FDA(365.121,IENS,.03)=1
D FILE^DIE("","FDA")
;
S IBACK="AA"
; Update flag logs
;IB*668/TAZ - Updated flags and variable names
I NATIONAL'=OLDNE D UPDLOG("NE",NATIONAL,IEN,APIEN)
I (APP="EIV"),(AUTOUPDT'=OLDAU) D UPDLOG("AU",AUTOUPDT,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)
;IB*668/TAZ - Removed reference to IIV
; (Updates file #350.9 & some of its subfiles associated with eIV)
; Input: DESC - Field Number
; ID - Field Value
; FLN - File Number
;
; IB*2*668/DW - In this tag, removed check on if APP=IIV as it is not needed
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.
;IB*668/TAZ - Removed reference to IIV
;I APP="IIV",FLN=350.9 D Q
I 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
;IB*668/TAZ - Removed reference to IIV
;I APP="IIV",FLN=350.9002 D Q
I 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"
;
;ANYTHING below is related to updating files listed in the X12TABLE array
;
;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 I IEN<1 Q
. S DLAYGO=FLN,DIC(0)="L"
. K DD,DO D FILE^DICN K DO
. S IEN=+Y
. I IEN<1 S IBACK="AE"
;
;Update fields: Description & FSC Controlled ;IB*752/CKB
;
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;.05///^S X=1" D ^DIE ;IB*752/DW Added field .05
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.
;IB*687/TAZ - Note: This adds the Payer to the file but does not add the Application
;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 NATIONALLY ENABLED/AUTO-UPDATE flag logs
;IB*668/TAZ - Updated to new flag variables
; FLAG - "NE" for NATIONALLY ENABLED flag, "AU" for AUTO-UPDATE 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="NE":"365.1212",FLAG="AU":"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 12685 printed Apr 09, 2024@21:33: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,668,687,732,752**;21-MAR-94;Build 20
+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 ;IB*668/TAZ - Removed STAT and TRUSTED, Added NATIONAL AND AUTOUPDT to NEW Statements
+2 NEW AIEN,APIEN,APP,AUTOUPDT,D0,D,DESC,DQ,DR,EIV,FILE,FLN,HEDI,ID,IEN
+3 NEW PEDI,SEG,HCT,NEWID,TSSN,REQSUB,NATIONAL,NAFLG,NPFLG
+4 NEW IBCNACT,IBCNADT,FSVDY,PSVDY
+5 NEW CMIEN,DATA,DATAAP,DATABPS,DATACM,DATE,ERROR,FIELDNO,FILENO
+6 NEW IBSEG,MSG,BUFF
+7 ;IB*732/CKB&TAZ - Added ISBLUE
+8 NEW X12TABLE,BADFMT,ISBLUE
+9 ;
+10 ; BADFMT is true if a site with patch 300 receives an eIV message in the previous HL7 interface structure (pre-300)
+11 ;
+12 ; Build local table of file numbers of DD tables that are updated by FSC for use by the eIV interface
+13 ;
+14 ; * Warning: Before adding a new table to be updated by FSC, one must get FSC
+15 ; to agree and the eIV ICD documentation has to be updated and
+16 ; approved by the VA HL7 team. Just adding a table number here does
+17 ; absolutely nothing without involving the other teams.
+18 ;
+19 ;IB*2*644/DW - corrected arrays of file numbers X12TABLE array and EIV table array are for different purposes.
+20 ; Which modified some changes made by IB*506 and IB*549
+21 ;IB*2.0*668/TAZ - Moved the setup of X12TABLE(365.021) to this line.
+22 ;original set of files that FSC controlled (prior to year 2022)
FOR D=11:1:18,21
SET X12TABLE("365.0"_D)=""
+23 ; IB*752/DTG - extended FSC control through 365.046
+24 FOR D=22:1:29,31:1:39,41:1:46
SET X12TABLE("365.0"_D)=""
+25 ;IB*2.0*668/TAZ - removed EIV(365.12) node. As this file is handled differently.
+26 SET EIV(350.9)=""
SET EIV(350.9002)=""
+27 ;
+28 SET APP=""
+29 SET HCT=0
SET ERFLG=0
+30 ;IB*668/TAZ - Restructured so more readable and can add other lines
+31 FOR
SET HCT=$ORDER(^TMP($JOB,"IBCNEHLI",HCT))
if HCT=""
QUIT
Begin DoDot:1
+32 DO SPAR^IBCNEHLU
+33 IF $GET(IBSEG(1))="MFI"
SET FILE=$GET(IBSEG(2))
SET FLN=$PIECE(FILE,$EXTRACT(HLECH,1),1)
QUIT
+34 ;IB*668/TAZ - Added to set APP variable at beginning of routine to be used in the message below
+35 IF $GET(IBSEG(1))="ZPA"
SET APP=$GET(IBSEG(3))
SET APP=$SELECT(APP="IIV":"EIV",1:APP)
QUIT
End DoDot:1
+36 IF FLN=365.12
Begin DoDot:1
+37 SET HCT=0
SET BADFMT=0
+38 FOR
SET HCT=$ORDER(^TMP($JOB,"IBCNEHLI",HCT))
if HCT=""
QUIT
Begin DoDot:2
+39 DO SPAR^IBCNEHLU
+40 IF $GET(IBSEG(1))="MFE"
IF $PIECE($GET(IBSEG(5)),$EXTRACT(HLECH,1),3)'=""
Begin DoDot:3
+41 SET BADFMT=1
SET APP=""
+42 ;IB*668/TAZ - Changed Remedy to Service in the message.
+43 SET MSG(1)="Log a Service Ticket for this issue."
+44 SET MSG(2)="Please include in the Service Ticket that the Vista eIV payer tables may be out"
+45 SET MSG(3)="of sync with the master list and will need a new copy of the payer table"
+46 SET MSG(4)="update message from Austin."
+47 DO MSG^IBCNEUT5($$MGRP^IBCNEUT5(),"eIV payer tables may be out of synch with master list","MSG(")
End DoDot:3
QUIT
+48 ;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="EIV")!BADFMT
QUIT
End DoDot:1
+49 ;I $D(X12TABLE(FLN))!$D(EIV(FLN)) S APP="IIV" ; IB*2*664/dw
+50 ;IB*668/TAZ - Quit if not an X12 Table update, and not an EIV update, and not a PAYER Table update
+51 IF '$DATA(X12TABLE(FLN))
IF '$DATA(EIV(FLN))
IF (FLN'=365.12)
QUIT
+52 ;
+53 SET HCT=1
SET NAFLG=0
SET NPFLG=0
SET D=""
+54 FOR
SET HCT=$ORDER(^TMP($JOB,"IBCNEHLI",HCT))
if HCT=""
QUIT
Begin DoDot:1
+55 DO SPAR^IBCNEHLU
+56 SET SEG=$GET(IBSEG(1))
+57 ;
+58 ;IB*668/TAZ - Removed check on if APP=IIV, not needed. This moved everything up a level in the dot structure
+59 IF SEG="MFI"
Begin DoDot:2
+60 SET FILE=$GET(IBSEG(2))
+61 SET FLN=$PIECE(FILE,$EXTRACT(HLECH,1),1)
End DoDot:2
+62 ;
+63 IF SEG="MFE"
Begin DoDot:2
+64 IF $GET(FLN)=""
SET ERFLG=1
SET MSG(1)="File Number not found in MFN message"
QUIT
+65 IF '$$VFILE^DILFD(FLN)
SET ERFLG=1
SET MSG(1)="File "_FLN_" not found in the Data Dictionary"
QUIT
+66 ;
+67 IF FLN'=365.12
Begin DoDot:3
+68 SET DATA=$GET(IBSEG(5))
+69 SET ID=$$DECHL7^IBCNEHL2($PIECE(DATA,$EXTRACT(HLECH,1),1))
SET DESC=$$DECHL7^IBCNEHL2($PIECE(DATA,$EXTRACT(HLECH,1),2))
+70 DO TFIL
End DoDot:3
QUIT
+71 ;
+72 ; Pull the action code
+73 SET IBCNACT=$GET(IBSEG(2))
+74 ; Effective Date
+75 SET IBCNADT=$GET(IBSEG(4))
End DoDot:2
+76 ;
+77 IF SEG="ZP0"
Begin DoDot:2
+78 SET ID=$$DECHL7^IBCNEHL2(IBSEG(3))
SET NEWID=$$DECHL7^IBCNEHL2(IBSEG(4))
+79 SET DESC=$$DECHL7^IBCNEHL2(IBSEG(5))
SET HEDI=$$DECHL7^IBCNEHL2(IBSEG(6))
SET PEDI=$$DECHL7^IBCNEHL2(IBSEG(7))
+80 ;IB*732/CKB&TAZ
SET ISBLUE=$SELECT($GET(IBSEG(8))="Y":1,1:0)
End DoDot:2
+81 ;
+82 IF SEG="ZPA"
Begin DoDot:2
+83 ;IB*668/TAZ - Added APP logic
+84 SET APP=$GET(IBSEG(3))
SET APP=$SELECT(APP="IIV":"EIV",1:APP)
+85 SET NATIONAL=$SELECT(IBSEG(4)="Y":1,1:0)
+86 ;IB*668/TAZ - Only set some variables if App is EIV
+87 IF APP="EIV"
Begin DoDot:3
+88 SET REQSUB=$SELECT(IBSEG(7)="N":0,1:1)
+89 SET FSVDY=IBSEG(8)
SET PSVDY=IBSEG(9)
+90 SET AUTOUPDT=$SELECT(IBSEG(10)="N":0,1:1)
End DoDot:3
+91 DO PFIL
End DoDot:2
End DoDot:1
if ERFLG
QUIT
+92 QUIT
+93 ;
PFIL ; Payer Table Filer (Updates file #365.12)
+1 ; Set the action:
+2 ; MAD=Add, MUP=Update, MDC=Deactivate, MAC=Reactivate
+3 ;IB*668/TAZ - Added OLDNE and OLDAU to New Statement
+4 NEW FDA,IENS,OLDNE,OLDAU
+5 SET IBCNADT=$$FMDATE^HLFNC(IBCNADT)
+6 IF IBCNADT=""
SET IBCNADT=$$NOW^XLFDT()
+7 ; If the action is MAD - Add the payer as new
+8 ; IB*582/TAZ if the action is MUP and the entry doesn't exist, add the payer as new
+9 NEW IBNOK,IBAPP,IBID,IBDESC,IBSTR,IBCNTYPE
+10 SET IBNOK=0
SET IBAPP=($TRANSLATE(APP," ")="")
SET IBID=($TRANSLATE(ID," ")="")
SET IBDESC=($TRANSLATE(DESC," ")="")
SET IBNOK=IBAPP!IBID!IBDESC
+11 ;IB*668/TAZ - Check for valid Payer Application and send message if not valid.
+12 ;Bad PAYER APPLICATION
SET DIC="^IBE(365.13,"
SET DIC(0)="X"
SET X=APP
DO ^DIC
SET AIEN=+Y
IF AIEN<1
SET IBNOK=1
+13 ;IB*668/TAZ - Changed Remedy Ticket to Service Ticket in this message.
+14 IF IBNOK
Begin DoDot:1
+15 SET IBCNTYPE=$SELECT(IBCNACT="MAD":"Add",IBCNACT="MUP":"Update",IBCNACT="MDC":"Deactivate",IBCNACT="MAC":"Reactivate",1:"Unknown")
+16 SET MSG(1)=IBCNTYPE_" ("_IBCNACT_") action received. Payer and/or Application may be unknown."
+17 SET MSG(2)=""
+18 SET MSG(3)="VA National : "_ID
+19 SET MSG(4)="Payer Name : "_DESC
+20 SET MSG(5)="Application : "_APP
+21 SET MSG(6)=""
+22 SET MSG(7)="Log a Service Ticket for this issue."
+23 SET MSG(8)=""
+24 SET MSG(9)="Please include in the Service Ticket that VISTA did not receive the required"
+25 SET MSG(10)="information or the accurate information to add/update this Payer."
+26 DO MSG^IBCNEUT5($$MGRP^IBCNEUT5(),"eIV payer tables may be out of synch with master list","MSG(")
End DoDot:1
GOTO PFILX
+27 DO FND
IF IEN<0
DO MAD(DESC)
+28 ;
+29 ;restriction of the field in the DD
SET DESC=$EXTRACT(DESC,1,80)
+30 SET DIC=$$ROOT^DILFD(FLN)
+31 ;IB*732/CKB&TAZ - Add field .09 to DR string
+32 SET DR=".01///^S X=DESC;.02////^S X=NEWID;.05////^S X=PEDI;.06////^S X=HEDI;.09////^S X=ISBLUE"
+33 ;
+34 ;IB*668/TAZ - Moved MDC/MAC logic to new file location
+35 ;I MDC or MAC
+36 IF IBCNACT="MDC"
SET DR=DR_";.07///^S X=1;.08////^S X=IBCNADT;"
SET NATIONAL=0
+37 IF IBCNACT="MAC"
SET DR=DR_";.07///^S X=0;.08///@;"
+38 ;
+39 ; If new payer, add the Date/Time created
+40 IF NPFLG
SET DR=DR_";.04///^S X=$$NOW^XLFDT()"
+41 SET DIE=DIC
SET DA=IEN
DO ^DIE
+42 ;
+43 ;IB*687/TAZ - Note: This adds the application to the Payer
+44 SET APIEN=$ORDER(^IBE(365.12,IEN,1,"B",AIEN,""))
+45 IF APIEN=""
Begin DoDot:1
+46 SET DLAYGO=365.121
SET DIC(0)="L"
SET DIC("P")=DLAYGO
SET DA(1)=IEN
SET X=AIEN
+47 SET DIC="^IBE(365.12,"_DA(1)_",1,"
SET DIE=DIC
+48 KILL DD,DO
+49 DO FILE^DICN
+50 KILL DO
+51 SET APIEN=+Y
SET NAFLG=1
End DoDot:1
+52 ;
+53 ;IB*668/TAZ - Updated field names and restructured filing logic for Payer File Application Level
+54 SET IENS=APIEN_","_IEN_","
+55 ; get current values for NATIONALLY ENABLED and AUTO-UPDATE flags
+56 SET OLDNE=$$GET1^DIQ(365.121,IENS,.02,"I")
+57 ;Only applied to EIV Payer Application
SET OLDAU=$$GET1^DIQ(365.121,IENS,4.01,"I")
+58 ;
+59 SET FDA(365.121,IENS,.02)=NATIONAL
+60 SET FDA(365.121,IENS,.06)=$$NOW^XLFDT()
+61 IF IBCNACT'="MDC"
IF (APP="EIV")
Begin DoDot:1
+62 SET FDA(365.121,IENS,4.01)=AUTOUPDT
+63 SET FDA(365.121,IENS,4.02)=REQSUB
+64 SET FDA(365.121,IENS,4.03)=FSVDY
+65 SET FDA(365.121,IENS,4.04)=PSVDY
End DoDot:1
+66 IF NAFLG
Begin DoDot:1
+67 SET FDA(365.121,IENS,.13)=$$NOW^XLFDT()
+68 ;IB*687/TAZ - Set Locally Enabled to YES for IIU
+69 IF APP="IIU"
SET FDA(365.121,IENS,.03)=1
End DoDot:1
+70 DO FILE^DIE("","FDA")
+71 ;
+72 SET IBACK="AA"
+73 ; Update flag logs
+74 ;IB*668/TAZ - Updated flags and variable names
+75 IF NATIONAL'=OLDNE
DO UPDLOG("NE",NATIONAL,IEN,APIEN)
+76 IF (APP="EIV")
IF (AUTOUPDT'=OLDAU)
DO UPDLOG("AU",AUTOUPDT,IEN,APIEN)
+77 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 ;IB*668/TAZ - Removed reference to IIV
+3 ; (Updates file #350.9 & some of its subfiles associated with eIV)
+4 ; Input: DESC - Field Number
+5 ; ID - Field Value
+6 ; FLN - File Number
+7 ;
+8 ; IB*2*668/DW - In this tag, removed check on if APP=IIV as it is not needed
+9 ;IB*2.0*549 - Added DA,DIE,DR,EXTRACT,XX
NEW DA,DIC,DIE,DLAYGO,DR,EXTRACT,IEN,MAX,XX,X,Y
+10 ;
+11 ; store the FILENAME, FIELDNAME and VALUE if the APP is IIV and FLN is 350.9. - IB*2.0*506
+12 ; For file #350.9, DESC represents the FIELD NUMBER and ID represents the VALUE.
+13 ;IB*668/TAZ - Removed reference to IIV
+14 ;I APP="IIV",FLN=350.9 D Q
+15 IF FLN=350.9
Begin DoDot:1
+16 SET DIE=FLN
SET DA=1
SET DR=DESC_"///"_ID
+17 DO ^DIE
+18 SET IBACK="AA"
End DoDot:1
QUIT
+19 ;
+20 ; IB*2.0*549 Added if statement
+21 ;IB*668/TAZ - Removed reference to IIV
+22 ;I APP="IIV",FLN=350.9002 D Q
+23 IF FLN=350.9002
Begin DoDot:1
+24 ; Either "Buff", "Appt" or "EICD"
SET EXTRACT=$EXTRACT(DESC,1,4)
+25 ; IB*2.0*621/DM add EICD
SET XX=$SELECT(EXTRACT="Buff":1,EXTRACT="Appt":2,EXTRACT="EICD":4,1:3)
+26 ; Field number
SET DESC=$EXTRACT(DESC,5,99)
+27 SET DA(1)=1
+28 ; Find correct multiple
SET DA=$ORDER(^IBE(350.9,1,51.17,"B",XX,""))
+29 ;
+30 ; File the new value
+31 SET DIE="^IBE(350.9,1,51.17,"
+32 SET DR=DESC_"///"_ID
+33 DO ^DIE
+34 SET IBACK="AA"
End DoDot:1
QUIT
+35 ;
+36 ;ANYTHING below is related to updating files listed in the X12TABLE array
+37 ;
+38 ;IB*582/TAZ - Add new entries and update existing entries
+39 ;
+40 SET DIC(0)="X"
SET X=ID
SET DIC=$$ROOT^DILFD(FLN)
+41 DO ^DIC
SET IEN=+Y
+42 ; don't update existing entries
+43 ;I IEN>0 Q
+44 ;Add new entry to table
+45 IF IEN<1
Begin DoDot:1
+46 SET DLAYGO=FLN
SET DIC(0)="L"
+47 KILL DD,DO
DO FILE^DICN
KILL DO
+48 SET IEN=+Y
+49 IF IEN<1
SET IBACK="AE"
End DoDot:1
IF IEN<1
QUIT
+50 ;
+51 ;Update fields: Description & FSC Controlled ;IB*752/CKB
+52 ;
+53 DO FIELD^DID(FLN,.02,,"FIELD LENGTH","MAX")
+54 ; restriction of the field in the DD
IF MAX("FIELD LENGTH")>0
SET DESC=$EXTRACT(DESC,1,MAX("FIELD LENGTH"))
+55 ; add new entry to the table
+56 ;S DLAYGO=FLN,DIC(0)="L",DIC("DR")=".02///"_DESC
+57 ;S DLAYGO=FLN,DIC(0)="L",DIC("DR")=".02///^S X=DESC"
+58 ;K DD,DO D FILE^DICN K DO
+59 ;IB*2*601/HN corrected use of the DR variable
+60 ;S DIE=DIC,DA=IEN,DIC("DR")=".02///^S X=DESC" D ^DIE
+61 ;IB*752/DW Added field .05
SET DIE=DIC
SET DA=IEN
SET DR=".02///^S X=DESC;.05///^S X=1"
DO ^DIE
+62 SET IBACK="AA"
+63 QUIT
+64 ;
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 ;IB*687/TAZ - Note: This adds the Payer to the file but does not add the Application
+3 ;D FND
+4 ;I IEN>0 G MADX
+5 NEW DIC,DIE,DA,DLAYGO,Y,DR
+6 SET DIC=$$ROOT^DILFD(FLN)
+7 SET DLAYGO=FLN
SET DIC(0)="L"
SET DIC("P")=DLAYGO
SET DIE=DIC
+8 KILL DD,DO
+9 DO FILE^DICN
+10 KILL DO
+11 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 NATIONALLY ENABLED/AUTO-UPDATE flag logs
+1 ;IB*668/TAZ - Updated to new flag variables
+2 ; FLAG - "NE" for NATIONALLY ENABLED flag, "AU" for AUTO-UPDATE flag
+3 ; VALUE - new flag value (0 or 1)
+4 ; PIEN - ien in PAYER file (365.12)
+5 ; APIEN - ien in APPLICATION sub-file (365.121)
+6 ;
+7 NEW FILE,IENSTR,UPDT
+8 IF $GET(FLAG)=""!($GET(VALUE)="")
QUIT
+9 IF +$GET(PIEN)=0!(+$GET(APIEN)=0)
QUIT
+10 SET FILE=$SELECT(FLAG="NE":"365.1212",FLAG="AU":"365.1213",1:"")
IF FILE=""
QUIT
+11 SET IENSTR="+1,"_APIEN_","_PIEN_","
+12 SET UPDT(FILE,IENSTR,.01)=$$NOW^XLFDT()
+13 SET UPDT(FILE,IENSTR,.02)=VALUE
+14 DO UPDATE^DIE("E","UPDT")
+15 QUIT
