Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCNEHLT

IBCNEHLT.m

Go to the documentation of this file. 
  1. 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
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  ;**Program Description**
  1.  ;  This program will process incoming MFN messages and
  1.  ;  update the appropriate tables
  1.  ;
  1. EN ;  Entry Point
  1.  ;IB*668/TAZ - Removed STAT and TRUSTED, Added NATIONAL AND AUTOUPDT to NEW Statements
  1.  NEW AIEN,APIEN,APP,AUTOUPDT,D0,D,DESC,DQ,DR,EIV,FILE,FLN,HEDI,ID,IEN
  1.  NEW PEDI,SEG,HCT,NEWID,TSSN,REQSUB,NATIONAL,NAFLG,NPFLG
  1.  NEW IBCNACT,IBCNADT,FSVDY,PSVDY
  1.  NEW CMIEN,DATA,DATAAP,DATABPS,DATACM,DATE,ERROR,FIELDNO,FILENO
  1.  NEW IBSEG,MSG,BUFF
  1.  ;IB*732/CKB&TAZ - Added ISBLUE
  1.  NEW X12TABLE,BADFMT,ISBLUE
  1.  ;
  1.  ; BADFMT is true if a site with patch 300 receives an eIV message in the previous HL7 interface structure (pre-300)
  1.  ;
  1.  ; Build local table of file numbers of DD tables that are updated by FSC for use by the eIV interface
  1.  ;
  1.  ; * Warning: Before adding a new table to be updated by FSC, one must get FSC
  1.  ;            to agree and the eIV ICD documentation has to be updated and 
  1.  ;            approved by the VA HL7 team. Just adding a table number here does
  1.  ;            absolutely nothing without involving the other teams.
  1.  ;
  1.  ;IB*2*644/DW - corrected arrays of file numbers X12TABLE array and EIV table array are for different purposes.
  1.  ;              Which modified some changes made by IB*506 and IB*549
  1.  ;IB*2.0*668/TAZ - Moved the setup of X12TABLE(365.021) to this line.
  1.  F D=11:1:18,21 S X12TABLE("365.0"_D)="" ;original set of files that FSC controlled (prior to year 2022)
  1.  ; IB*752/DTG - extended FSC control through 365.046
  1.  F D=22:1:29,31:1:39,41:1:46 S X12TABLE("365.0"_D)=""
  1.  ;IB*2.0*668/TAZ - removed EIV(365.12) node. As this file is handled differently.
  1.  S EIV(350.9)="",EIV(350.9002)=""
  1.  ;
  1.  S APP=""
  1.  S HCT=0,ERFLG=0
  1.  ;IB*668/TAZ - Restructured so more readable and can add other lines
  1.  F  S HCT=$O(^TMP($J,"IBCNEHLI",HCT)) Q:HCT=""  D
  1.  . D SPAR^IBCNEHLU
  1.  . I $G(IBSEG(1))="MFI" S FILE=$G(IBSEG(2)),FLN=$P(FILE,$E(HLECH,1),1) Q
  1.  . ;IB*668/TAZ - Added to set APP variable at beginning of routine to be used in the message below
  1.  . I $G(IBSEG(1))="ZPA" S APP=$G(IBSEG(3)) S APP=$S(APP="IIV":"EIV",1:APP) Q
  1.  I FLN=365.12 D
  1.  . S HCT=0,BADFMT=0
  1.  . F  S HCT=$O(^TMP($J,"IBCNEHLI",HCT)) Q:HCT=""  D  Q:(APP="EIV")!BADFMT
  1.  .. D SPAR^IBCNEHLU
  1.  .. I $G(IBSEG(1))="MFE",$P($G(IBSEG(5)),$E(HLECH,1),3)'="" D  Q
  1.  ... S BADFMT=1,APP=""
  1.  ... ;IB*668/TAZ - Changed Remedy to Service in the message.
  1.  ... S MSG(1)="Log a Service Ticket for this issue."
  1.  ... S MSG(2)="Please include in the Service Ticket that the Vista eIV payer tables may be out"
  1.  ... S MSG(3)="of sync with the master list and will need a new copy of the payer table"
  1.  ... S MSG(4)="update message from Austin."
  1.  ... D MSG^IBCNEUT5($$MGRP^IBCNEUT5(),"eIV payer tables may be out of synch with master list","MSG(")
  1.  .. ;I $G(IBSEG(1))="ZPA" S APP="IIV" ; IB*2*664/dw  No longer needed, added 365.12 to the EIV array
  1.  ;I $D(X12TABLE(FLN))!$D(EIV(FLN)) S APP="IIV"    ; IB*2*664/dw
  1.  ;IB*668/TAZ - Quit if not an X12 Table update, and not an EIV update, and not a PAYER Table update
  1.  I '$D(X12TABLE(FLN)),'$D(EIV(FLN)),(FLN'=365.12) Q
  1.  ;
  1.  S HCT=1,NAFLG=0,NPFLG=0,D=""
  1.  F  S HCT=$O(^TMP($J,"IBCNEHLI",HCT)) Q:HCT=""  D  Q:ERFLG
  1.  . D SPAR^IBCNEHLU
  1.  . S SEG=$G(IBSEG(1))
  1.  . ;
  1.  . ;IB*668/TAZ - Removed check on if APP=IIV, not needed. This moved everything up a level in the dot structure
  1.  . I SEG="MFI" D
  1.  .. S FILE=$G(IBSEG(2))
  1.  .. S FLN=$P(FILE,$E(HLECH,1),1)
  1.  . ;
  1.  . I SEG="MFE" D
  1.  .. I $G(FLN)="" S ERFLG=1,MSG(1)="File Number not found in MFN message" Q
  1.  .. I '$$VFILE^DILFD(FLN) S ERFLG=1,MSG(1)="File "_FLN_" not found in the Data Dictionary" Q
  1.  .. ;
  1.  .. I FLN'=365.12 D  Q
  1.  ... S DATA=$G(IBSEG(5))
  1.  ... S ID=$$DECHL7^IBCNEHL2($P(DATA,$E(HLECH,1),1)),DESC=$$DECHL7^IBCNEHL2($P(DATA,$E(HLECH,1),2))
  1.  ... D TFIL
  1.  .. ;
  1.  .. ; Pull the action code
  1.  .. S IBCNACT=$G(IBSEG(2))
  1.  .. ; Effective Date
  1.  .. S IBCNADT=$G(IBSEG(4))
  1.  . ;
  1.  . I SEG="ZP0" D
  1.  .. S ID=$$DECHL7^IBCNEHL2(IBSEG(3)),NEWID=$$DECHL7^IBCNEHL2(IBSEG(4))
  1.  .. S DESC=$$DECHL7^IBCNEHL2(IBSEG(5)),HEDI=$$DECHL7^IBCNEHL2(IBSEG(6)),PEDI=$$DECHL7^IBCNEHL2(IBSEG(7))
  1.  .. S ISBLUE=$S($G(IBSEG(8))="Y":1,1:0)  ;IB*732/CKB&TAZ
  1.  . ;
  1.  . I SEG="ZPA" D
  1.  .. ;IB*668/TAZ - Added APP logic
  1.  .. S APP=$G(IBSEG(3)) S APP=$S(APP="IIV":"EIV",1:APP)
  1.  .. S NATIONAL=$S(IBSEG(4)="Y":1,1:0)
  1.  .. ;IB*668/TAZ - Only set some variables if App is EIV
  1.  .. I APP="EIV" D
  1.  ... S REQSUB=$S(IBSEG(7)="N":0,1:1)
  1.  ... S FSVDY=IBSEG(8),PSVDY=IBSEG(9)
  1.  ... S AUTOUPDT=$S(IBSEG(10)="N":0,1:1)
  1.  .. D PFIL
  1.  Q
  1.  ;
  1. PFIL ;  Payer Table Filer (Updates file #365.12)
  1.  ;  Set the action:
  1.  ;     MAD=Add, MUP=Update, MDC=Deactivate, MAC=Reactivate
  1.  ;IB*668/TAZ - Added OLDNE and OLDAU to New Statement
  1.  N FDA,IENS,OLDNE,OLDAU
  1.  S IBCNADT=$$FMDATE^HLFNC(IBCNADT)
  1.  I IBCNADT="" S IBCNADT=$$NOW^XLFDT()
  1.  ;  If the action is MAD - Add the payer as new
  1.  ;  IB*582/TAZ if the action is MUP and the entry doesn't exist, add the payer as new
  1.  N IBNOK,IBAPP,IBID,IBDESC,IBSTR,IBCNTYPE
  1.  S IBNOK=0,IBAPP=($TR(APP," ")=""),IBID=($TR(ID," ")=""),IBDESC=($TR(DESC," ")=""),IBNOK=IBAPP!IBID!IBDESC
  1.  ;IB*668/TAZ - Check for valid Payer Application and send message if not valid.
  1.  S DIC="^IBE(365.13,",DIC(0)="X",X=APP D ^DIC S AIEN=+Y I AIEN<1 S IBNOK=1  ;Bad PAYER APPLICATION
  1.  ;IB*668/TAZ - Changed Remedy Ticket to Service Ticket in this message.
  1.  I IBNOK D  G PFILX
  1.  . S IBCNTYPE=$S(IBCNACT="MAD":"Add",IBCNACT="MUP":"Update",IBCNACT="MDC":"Deactivate",IBCNACT="MAC":"Reactivate",1:"Unknown")
  1.  . S MSG(1)=IBCNTYPE_" ("_IBCNACT_") action received. Payer and/or Application may be unknown."
  1.  . S MSG(2)=""
  1.  . S MSG(3)="VA National : "_ID
  1.  . S MSG(4)="Payer Name : "_DESC
  1.  . S MSG(5)="Application : "_APP
  1.  . S MSG(6)=""
  1.  . S MSG(7)="Log a Service Ticket for this issue."
  1.  . S MSG(8)=""
  1.  . S MSG(9)="Please include in the Service Ticket that VISTA did not receive the required"
  1.  . S MSG(10)="information or the accurate information to add/update this Payer."
  1.  . D MSG^IBCNEUT5($$MGRP^IBCNEUT5(),"eIV payer tables may be out of synch with master list","MSG(")
  1.  D FND I IEN<0 D MAD(DESC)
  1.  ;
  1.  S DESC=$E(DESC,1,80)    ;restriction of the field in the DD
  1.  S DIC=$$ROOT^DILFD(FLN)
  1.  ;IB*732/CKB&TAZ - Add field .09 to DR string
  1.  S DR=".01///^S X=DESC;.02////^S X=NEWID;.05////^S X=PEDI;.06////^S X=HEDI;.09////^S X=ISBLUE"
  1.  ;
  1.  ;IB*668/TAZ - Moved MDC/MAC logic to new file location
  1.  ;I MDC or MAC
  1.  I IBCNACT="MDC" S DR=DR_";.07///^S X=1;.08////^S X=IBCNADT;",NATIONAL=0
  1.  I IBCNACT="MAC" S DR=DR_";.07///^S X=0;.08///@;"
  1.  ;
  1.  ;  If new payer, add the Date/Time created
  1.  I NPFLG S DR=DR_";.04///^S X=$$NOW^XLFDT()"
  1.  S DIE=DIC,DA=IEN D ^DIE
  1.  ;
  1.  ;IB*687/TAZ - Note:  This adds the application to the Payer
  1.  S APIEN=$O(^IBE(365.12,IEN,1,"B",AIEN,""))
  1.  I APIEN="" D
  1.  . S DLAYGO=365.121,DIC(0)="L",DIC("P")=DLAYGO,DA(1)=IEN,X=AIEN
  1.  . S DIC="^IBE(365.12,"_DA(1)_",1,",DIE=DIC
  1.  . K DD,DO
  1.  . D FILE^DICN
  1.  . K DO
  1.  . S APIEN=+Y,NAFLG=1
  1.  ;
  1.  ;IB*668/TAZ - Updated field names and restructured filing logic for Payer File Application Level
  1.  S IENS=APIEN_","_IEN_","
  1.  ; get current values for NATIONALLY ENABLED and AUTO-UPDATE flags
  1.  S OLDNE=$$GET1^DIQ(365.121,IENS,.02,"I")
  1.  S OLDAU=$$GET1^DIQ(365.121,IENS,4.01,"I")  ;Only applied to EIV Payer Application
  1.  ;
  1.  S FDA(365.121,IENS,.02)=NATIONAL
  1.  S FDA(365.121,IENS,.06)=$$NOW^XLFDT()
  1.  I IBCNACT'="MDC",(APP="EIV") D
  1.  . S FDA(365.121,IENS,4.01)=AUTOUPDT
  1.  . S FDA(365.121,IENS,4.02)=REQSUB
  1.  . S FDA(365.121,IENS,4.03)=FSVDY
  1.  . S FDA(365.121,IENS,4.04)=PSVDY
  1.  I NAFLG D
  1.  . S FDA(365.121,IENS,.13)=$$NOW^XLFDT()
  1.  . ;IB*687/TAZ - Set Locally Enabled to YES for IIU
  1.  . I APP="IIU" S FDA(365.121,IENS,.03)=1
  1.  D FILE^DIE("","FDA")
  1.  ;
  1.  S IBACK="AA"
  1.  ; Update flag logs
  1.  ;IB*668/TAZ - Updated flags and variable names
  1.  I NATIONAL'=OLDNE D UPDLOG("NE",NATIONAL,IEN,APIEN)
  1.  I (APP="EIV"),(AUTOUPDT'=OLDAU) D UPDLOG("AU",AUTOUPDT,IEN,APIEN)
  1.  I IBCNACT="MDC" D MDC Q
  1. PFILX ;
  1.  Q
  1.  ;
  1. 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)
  1.  ;IB*668/TAZ - Removed reference to IIV
  1.  ;     (Updates file #350.9 & some of its subfiles associated with eIV)
  1.  ; Input: DESC  - Field Number
  1.  ;        ID    - Field Value
  1.  ;        FLN   - File Number
  1.  ;
  1.  ; IB*2*668/DW - In this tag, removed check on if APP=IIV as it is not needed
  1.  N DA,DIC,DIE,DLAYGO,DR,EXTRACT,IEN,MAX,XX,X,Y   ;IB*2.0*549 - Added DA,DIE,DR,EXTRACT,XX
  1.  ;
  1.  ; store the FILENAME, FIELDNAME and VALUE if the APP is IIV and FLN is 350.9.  - IB*2.0*506
  1.  ; For file #350.9, DESC represents the FIELD NUMBER and ID represents the VALUE.
  1.  ;IB*668/TAZ - Removed reference to IIV
  1.  ;I APP="IIV",FLN=350.9 D  Q
  1.  I FLN=350.9 D  Q
  1.  . S DIE=FLN,DA=1,DR=DESC_"///"_ID
  1.  . D ^DIE
  1.  . S IBACK="AA"
  1.  ;
  1.  ; IB*2.0*549 Added if statement 
  1.  ;IB*668/TAZ - Removed reference to IIV
  1.  ;I APP="IIV",FLN=350.9002 D  Q
  1.  I FLN=350.9002 D  Q
  1.  . S EXTRACT=$E(DESC,1,4)                   ; Either "Buff", "Appt" or "EICD"
  1.  . S XX=$S(EXTRACT="Buff":1,EXTRACT="Appt":2,EXTRACT="EICD":4,1:3) ; IB*2.0*621/DM add EICD 
  1.  . S DESC=$E(DESC,5,99)                     ; Field number
  1.  . S DA(1)=1
  1.  . S DA=$O(^IBE(350.9,1,51.17,"B",XX,""))   ; Find correct multiple
  1.  . ;
  1.  . ; File the new value
  1.  . S DIE="^IBE(350.9,1,51.17,"
  1.  . S DR=DESC_"///"_ID
  1.  . D ^DIE
  1.  . S IBACK="AA"
  1.  ;
  1.  ;ANYTHING below is related to updating files listed in the X12TABLE array
  1.  ;
  1.  ;IB*582/TAZ - Add new entries and update existing entries
  1.  ;
  1.  S DIC(0)="X",X=ID,DIC=$$ROOT^DILFD(FLN)
  1.  D ^DIC S IEN=+Y
  1.  ; don't update existing entries
  1.  ;I IEN>0 Q
  1.  ;Add new entry to table
  1.  I IEN<1 D  I IEN<1 Q
  1.  . S DLAYGO=FLN,DIC(0)="L"
  1.  . K DD,DO D FILE^DICN K DO
  1.  . S IEN=+Y
  1.  . I IEN<1 S IBACK="AE"
  1.  ;
  1.  ;Update fields: Description & FSC Controlled ;IB*752/CKB
  1.  ;
  1.  D FIELD^DID(FLN,.02,,"FIELD LENGTH","MAX")
  1.  I MAX("FIELD LENGTH")>0 S DESC=$E(DESC,1,MAX("FIELD LENGTH")) ; restriction of the field in the DD
  1.  ; add new entry to the table
  1.  ;S DLAYGO=FLN,DIC(0)="L",DIC("DR")=".02///"_DESC
  1.  ;S DLAYGO=FLN,DIC(0)="L",DIC("DR")=".02///^S X=DESC"
  1.  ;K DD,DO D FILE^DICN K DO
  1.  ;IB*2*601/HN corrected use of the DR variable 
  1.  ;S DIE=DIC,DA=IEN,DIC("DR")=".02///^S X=DESC" D ^DIE
  1.  S DIE=DIC,DA=IEN,DR=".02///^S X=DESC;.05///^S X=1" D ^DIE ;IB*752/DW Added field .05
  1.  S IBACK="AA"
  1.  Q
  1.  ;
  1. 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.
  1.  ;IB*687/TAZ - Note:  This adds the Payer to the file but does not add the Application
  1.  ;D FND
  1.  ;I IEN>0 G MADX
  1.  NEW DIC,DIE,DA,DLAYGO,Y,DR
  1.  S DIC=$$ROOT^DILFD(FLN)
  1.  S DLAYGO=FLN,DIC(0)="L",DIC("P")=DLAYGO,DIE=DIC
  1.  K DD,DO
  1.  D FILE^DICN
  1.  K DO
  1.  S IEN=+Y,NPFLG=1
  1. MADX ;
  1.  Q
  1.  ;
  1. FND ;  Find an existing Payer entry
  1.  NEW DIC,DIE,X,DA,DLAYGO,Y,DR
  1.  S X=ID,DIC(0)="X",D="C",DIC=$$ROOT^DILFD(FLN)
  1.  ;
  1.  ;  Do a lookup with the "C" cross-reference
  1.  D IX^DIC
  1.  S IEN=+Y
  1.  Q
  1.  ;
  1. MDC ;  Check for active transmissions and cancel
  1.  NEW STA,HIEN,RIEN,TQIEN
  1.  F STA=1,2,4,6 S TQIEN="" D
  1.  . F  S TQIEN=$O(^IBCN(365.1,"AC",STA,TQIEN)) Q:TQIEN=""  D
  1.  .. ;
  1.  .. ;  If the record doesn't match the payer, quit
  1.  .. I $P(^IBCN(365.1,TQIEN,0),U,3)'=IEN Q
  1.  .. ;
  1.  .. ;  Set the status to 'Cancelled'
  1.  .. D SST^IBCNEUT2(TQIEN,7)
  1.  .. ;
  1.  .. ;  If a buffer entry, set to ! (bang)
  1.  .. S BUFF=$P(^IBCN(365.1,TQIEN,0),U,5)
  1.  .. I BUFF'="" D BUFF^IBCNEUT2(BUFF,17)
  1.  .. ;
  1.  .. ;  Change any responses status also
  1.  .. S HIEN=0 F  S HIEN=$O(^IBCN(365.1,TQIEN,2,HIEN)) Q:'HIEN  D
  1.  ... S RIEN=$P(^IBCN(365.1,TQIEN,2,HIEN,0),U,3)
  1.  ... ;  If the Response status is 'Response Received', don't change it
  1.  ... I $P(^IBCN(365,RIEN,0),U,6)=3 Q
  1.  ... D RSP^IBCNEUT2(RIEN,7)
  1.  Q
  1.  ;
  1. UPDLOG(FLAG,VALUE,PIEN,APIEN) ; Update NATIONALLY ENABLED/AUTO-UPDATE flag logs
  1.  ;IB*668/TAZ - Updated to new flag variables
  1.  ; FLAG - "NE" for NATIONALLY ENABLED flag, "AU" for AUTO-UPDATE flag
  1.  ; VALUE - new flag value (0 or 1)
  1.  ; PIEN - ien in PAYER file (365.12)
  1.  ; APIEN - ien in APPLICATION sub-file (365.121)
  1.  ;
  1.  N FILE,IENSTR,UPDT
  1.  I $G(FLAG)=""!($G(VALUE)="") Q
  1.  I +$G(PIEN)=0!(+$G(APIEN)=0) Q
  1.  S FILE=$S(FLAG="NE":"365.1212",FLAG="AU":"365.1213",1:"") I FILE="" Q
  1.  S IENSTR="+1,"_APIEN_","_PIEN_","
  1.  S UPDT(FILE,IENSTR,.01)=$$NOW^XLFDT()
  1.  S UPDT(FILE,IENSTR,.02)=VALUE
  1.  D UPDATE^DIE("E","UPDT")
  1.  Q