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

IBY549PO.m

Go to the documentation of this file. 
  1. IBY549PO ;ALB/VD - IB*2*549 POST-INSTALL ;21-APR-2015
  1.  ;;2.0;INTEGRATED BILLING;**549**;21-MAR-94;Build 54
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1. EN ;Entry point
  1.  N IBXPD,XPDIDTOT
  1.  S XPDIDTOT=7
  1.  ;
  1.  ; Send site registration message to FSC
  1.  S IBXPD=1
  1.  D RMSG
  1.  ;
  1.  ; Req# 2.6.4.10
  1.  ; Remove the IP Address if it exists in the IIV EC HL7 Logical Link.
  1.  S IBXPD=2
  1.  D IIVEC(IBXPD,XPDIDTOT)
  1.  ;
  1.  ; Req# 2.6.8.1
  1.  ; Add a new Type of Coverage record in the ^IBE(355.2) file.
  1.  S IBXPD=3
  1.  D NEWCVTY(IBXPD,XPDIDTOT)
  1.  ;
  1.  ; Req# 2.6.8.2
  1.  ; Add a new Type of Plan record in the ^IBE(355.1) file.
  1.  S IBXPD=4
  1.  D NEWPLTY(IBXPD,XPDIDTOT)
  1.  ;
  1.  ; Req# 2.6.2.2
  1.  ; Update Policy expiration dates for deceased patients
  1.  S IBXPD=5
  1.  D POLCYUPD(IBXPD,XPDIDTOT)
  1.  ;
  1.  ; Req# 2.6.10.6
  1.  ; Remove the contact field value
  1.  S IBXPD=6
  1.  D DELCONT(IBXPD,XPDIDTOT)
  1.  ;
  1.  ; Req# 2.6.10.21
  1.  ; Set MESSAGES MAILGROUP field in Site parameters
  1.  S IBXPD=7
  1.  D MGROUP(IBXPD,XPDIDTOT)
  1.  ;
  1.  ; File a 'Y' for new Master Realtime and Nightly switches
  1.  D FSWITCH
  1.  D DONE
  1.  Q
  1.  ;
  1. RMSG ; send site registration message to FSC
  1.  D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
  1.  D MES^XPDUTL("-------------")
  1.  D MES^XPDUTL("Sending site registration message to FSC ... ")
  1.  I '$$PROD^XUPROD(1) D  Q                   ; only sent reg. message from production account
  1.  . D MES^XPDUTL(" N/A - Not a production account - No site registration message sent")
  1.  D MES^XPDUTL("Sending site registration message to FSC ... ")
  1.  D ^IBCNEHLM
  1.  Q
  1.  ;
  1. IIVEC(IBXPD,XPDIDTOT) ; Remove the IP address if it exists in the IIV EC HL7
  1.  ; Logical Link.
  1.  ; Input:   XBXPD       - Post Installation Step
  1.  ;          XPDIDTOT    - Total # of Post Installation steps
  1.  N DA,DIE,DLAYGO,DR,IBPRD,X,Y
  1.  D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
  1.  D MES^XPDUTL("-------------")
  1.  D MES^XPDUTL("Remove the IP Address in 'IIV EC' HL7 Logical Link.")
  1.  ;
  1.  S IBPRD=$S($$PROD^XUPROD(1)=1:"P",1:"T")
  1.  S DIC="^HLCS(870,",DLAYGO=870,DIC(0)="LS",X="IIV EC" D ^DIC
  1.  ;
  1.  ; For Test environments
  1.  I IBPRD="T",Y'=-1 D
  1.  . S DIE=DIC,DA=+Y,DR=".08///IIV.VITRIA-EDI-TEST.AAC.DOMAIN.EXT;400.01///@"
  1.  . K DIC D ^DIE
  1.  ;
  1.  ; For Production environments, use the FSC PRD domain
  1.  I IBPRD="P",Y'=-1 D
  1.  . S DIE=DIC,DA=+Y,DR=".08///IIV.VITRIA-EDI.AAC.DOMAIN.EXT;400.01///@"
  1.  . K DIC D ^DIE
  1.  Q
  1.  ;
  1. MGROUP(IBXPD,XPDIDTOT) ; Set the MESSAGES MAILGROUP in site parameters if wrong value
  1.  ; Input:   XBXPD       - Post Installation Step
  1.  ;          XPDIDTOT    - Total # of Post Installation steps
  1.  N XX
  1.  D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
  1.  D MES^XPDUTL("-------------")
  1.  D MES^XPDUTL("Checking current MESSAGE MAILGROUP value ... ")
  1.  S XX=$$GET1^DIQ(350.9,"1,",51.04,"E")
  1.  I XX'="IBCNE EIV MESSAGE" D  Q
  1.  . S XX=$O(^XMB(3.8,"B","IBCNE EIV MESSAGE",0))
  1.  . ;
  1.  . ; If the IBCNE EIV MESSAGE mail group doesn't exist, create and send a
  1.  . ; message to VHAeInsuranceRapidResponse@domain.ext 
  1.  . I XX="" D ADDMGRP
  1.  . E  D MES^XPDUTL(" Mail group IBCNE EIV MESSAGE already exists")
  1.  . ;
  1.  . N DA,DIE,DR
  1.  . D MES^XPDUTL(" Setting mail group to IBCNE EIV MESSAGE")
  1.  . S XX=$O(^XMB(3.8,"B","IBCNE EIV MESSAGE",""))
  1.  . S DIE=350.9,DA=1
  1.  . S DR="51.04///"_XX
  1.  . D ^DIE
  1.  ;
  1.  D MES^XPDUTL("MESSAGE MAILGROUP already set to IBCNE EIV MESSAGE - nothing done")
  1.  Q
  1.  ;
  1. ADDMGRP ; Create the IBCNE EIV MESSAGE mail group with no users
  1.  N MGDESC,MGNM,MSG,SUBJECT,XMY
  1.  S MGNM="IBCNE EIV MESSAGE"
  1.  S MGDESC(1)="This mail group will be used to deliver notifications for"
  1.  S MGDESC(2)="the Insurance Verification process."
  1.  I $$MG^XMBGRP(MGNM,0,$G(DUZ),0,,.MGDESC,1) D
  1.  . D MES^XPDUTL("     Mail Group "_MGNM_" was successfully created.")
  1.  . ;
  1.  . ; Notify the VA eInsurance Rapid Response Group
  1.  . S XMY("VHAeInsuranceRapidResponse@domain.ext")=""
  1.  . S MSG(1)="The Mail Group IBCNE EIV MESSAGE was created"
  1.  . S SUBJECT="Mail Group IBCNE EIV MESSAGE created"
  1.  . D MSG^IBCNEUT5(,SUBJECT,"MSG(",,.XMY)
  1.  E  D
  1.  . D MES^XPDUTL("     ERROR: Mail Group "_MGNM_" was not created!")
  1.  . D MES^XPDUTL("     Please enter a support ticket for assistance.")
  1.  Q
  1.  ;
  1. FSWITCH ; File 'YES' values for new realtime switches
  1.  N DA,DIE,DR,DTOUT,XX
  1.  S XX=$$GET1^DIQ(350.9,"1,",51.27,"I")
  1.  ;
  1.  ; If null set to "YES"
  1.  I XX="" D
  1.  . S DIE=350.9,DA=1,DR="51.27///Y"
  1.  . D ^DIE
  1.  ;
  1.  S XX=$$GET1^DIQ(350.9,"1,",51.28,"I")
  1.  ;
  1.  ; If null set to "YES"
  1.  I XX="" D
  1.  . S DIE=350.9,DA=1,DR="51.28///Y"
  1.  . D ^DIE
  1.  Q
  1.  ;
  1. NEWPLTY(IBXPD,XPDIDTOT) ; Add a new code to the TYPE OF PLAN TABLE (#355.1)
  1.  ; for VA SPECIAL CLASS
  1.  ; Input:   XBXPD       - Post Installation Step
  1.  ;          XPDIDTOT    - Total # of Post Installation steps
  1.  N IBDATA,IBDESC,IBERR,IBIEN
  1.  D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
  1.  D MES^XPDUTL("-------------")
  1.  D MES^XPDUTL("Add a new VA SPECIAL CLASS code to the TYPE OF PLAN TABLE")
  1.  I $D(^IBE(355.1,"D","VA SP CL")) D   Q
  1.  . D BMES^XPDUTL("*** NEW 'VA SP CL' CODE NOT ADDED TO TYPE OF PLAN TABLE...ALREADY EXISTS ***")
  1.  ;
  1.  ; Set up WP Arrays
  1.  S IBDESC("WP",1)="Pseudo plan - DO NOT BILL"
  1.  ;
  1.  ; Set up File Nodes
  1.  S IBDATA(.01)="VA SPECIAL CLASS"
  1.  S IBDATA(.02)="VA SP CL"
  1.  S IBDATA(.03)="12"
  1.  S IBDATA(10)=$NA(IBDESC("WP"))
  1.  S IBIEN=$$ADD^IBDFDBS(355.1,,.IBDATA,.IBERR)
  1.  I IBERR D  Q
  1.  . D BMES^XPDUTL("*** ERROR ADDING 'VSC' CODE TO THE TYPE OF PLAN TABLE (#355.1) ***")
  1.  Q
  1.  ;
  1. NEWCVTY(IBXPD,XPDIDTOT) ; Add a new code to the TYPE OF COVERAGE TABLE (#355.2)
  1.  ; for VA SPECIAL CLASS
  1.  ; Input:   XBXPD       - Post Installation Step
  1.  ;          XPDIDTOT    - Total # of Post Installation steps
  1.  N IBDATA,IBDESC,IBERR,IBIEN
  1.  D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
  1.  D MES^XPDUTL("-------------")
  1.  D MES^XPDUTL("Add a new VA SPECIAL CLASS code to the TYPE OF COVERAGE TABLE")
  1.  I $D(^IBE(355.2,"C","VA SP CL")) D  Q
  1.  . D BMES^XPDUTL("*** NEW 'VA SP CL' CODE NOT ADDED TO TYPE OF COVERAGE TABLE...ALREADY EXISTS ***")
  1.  ;
  1.  ; Set up WP Arrays
  1.  S IBDESC("WP",1)="Pseudo type of coverage - DO NOT USE"
  1.  ;
  1.  ; Set up File Nodes
  1.  S IBDATA(.01)="VA SPECIAL CLASS"
  1.  S IBDATA(.02)="VA SP CL"
  1.  S IBDATA(10)=$NA(IBDESC("WP"))
  1.  S IBIEN=$$ADD^IBDFDBS(355.2,,.IBDATA,.IBERR)
  1.  I IBERR D  Q
  1.  . D BMES^XPDUTL("*** ERROR ADDING 'VA SP CL' CODE TO THE TYPE OF COVERAGE TABLE (#355.2) ***")
  1.  Q
  1.  ;
  1. DELCONT(IBXPD,XPDIDTOT) ; Remove the contact field value
  1.  ; Input:   XBXPD       - Post Installation Step
  1.  ;          XPDIDTOT    - Total # of Post Installation steps
  1.  ;
  1.  N FDA,DA,IBERR
  1.  D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
  1.  D MES^XPDUTL("-------------")
  1.  D MES^XPDUTL("Removing Contact Person from eIV Site Parameters.")
  1.  S DA=1
  1.  S FDA(350.9,"1,",51.16)="@"
  1.  D FILE^DIE("","FDA","IBERR")
  1.  Q
  1.  ;
  1. POLCYUPD(IBXPD,XPDIDTOT) ; Update Policy Expiration Dates for deceased patients
  1.  ; Input:   XBXPD       - Post Installation Step
  1.  ;          XPDIDTOT    - Total # of Post Installation steps
  1.  D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
  1.  D MES^XPDUTL("-------------")
  1.  D MES^XPDUTL("Update Policy Expiration Dates for deceased patients.")
  1.  ; 1 - For every patient in the patient file check if the patient is deceased field
  1.  ;    (file 2, field .351)
  1.  ; 2 - Quit if the patient is not deceased
  1.  ; 3 - Quit if the policy expiration is non-null
  1.  ; 4 - Change the policy expiration date to (Date of Death +1)
  1.  ; 5 - Add this patient and policy to a list of patient/policies  being modified
  1.  ; 6 - Email the list of patient/policies modified to xxx
  1.  ;
  1.  N MTIME,ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC,ZTSK
  1.  S MTIME=$$NOW^XLFDT()                      ; Fileman date/time
  1.  S MTIME=$$FMADD^XLFDT(MTIME,0,4)           ; Set to queue 4 hours later
  1.  S ZTDTH=$$FMTH^XLFDT(MTIME)                ; Convert to $H format
  1.  ;
  1.  ; Set up the other TaskManager variables
  1.  S ZTRTN="POLCUP2^IBY549PO"
  1.  S ZTDESC="IB*2.8*549 Auto Termination of Policies for deceased patients"
  1.  S ZTIO=""
  1.  D ^%ZTLOAD ; Call TaskManager
  1.  Q
  1.  ;
  1. POLCUP2 ;EP
  1.  ; Called from Task Manager
  1.  N CURSIZE,DFN,DOD,EMAIL,EXPDT,IIEN,LNCTR,MAXSIZE,MLGRP,MSG,NPAT
  1.  N PNM,SSN,SUBJECT,XMY,XX
  1.  K ^TMP($J,"PATLIST"),^TMP($J,"ERRLIST")
  1.  S DFN=0
  1.  F  D  Q:'+DFN
  1.  . S DFN=$O(^DPT(DFN))
  1.  . Q:'+DFN
  1.  . S DOD=$$GET1^DIQ(2,DFN_",",.351,"I")     ; Date of Death
  1.  . Q:DOD=""                                 ; Patient is not Deceased
  1.  . S IIEN=0
  1.  . F  D  Q:'+IIEN
  1.  . . S IIEN=$O(^DPT(DFN,.312,IIEN))
  1.  . . Q:'+IIEN
  1.  . . S EXPDT=$$GET1^DIQ(2.312,IIEN_","_DFN_",",3,"I")   ; Policy Expiration Date
  1.  . . Q:EXPDT'=""                                    ; Policy has an expiration date
  1.  . . D UPDTEDT(DFN,IIEN,DOD)                        ; Update the expiration date
  1.  . . Q:$D(^TMP($J,"ERRLIST",DFN,IIEN))              ; On error list
  1.  . . S ^TMP($J,"PATLIST",DFN,IIEN)=""               ; Add Patient Policy to list
  1.  Q:'$D(^TMP($J,"PATLIST"))                          ; No patients to update
  1.  ;
  1.  ; Get array of users with the 'IB SUPERVISOR' security key
  1.  D GETPER^IBCNEUT7("IB SUPERVISOR",.XMY)
  1.  ;
  1.  ; Begin email set up
  1.  S MAXSIZE=300000,CURSIZE=0,LNCTR=0
  1.  S MLGRP=$$MGRP^IBCNEUT5
  1.  S SUBJECT="eIV: Policy Expiration for deceased patient - Post Install Task"
  1.  ;
  1.  ; First add any patients that had filing errors
  1.  I $D(^TMP($J,"ERRLIST")) D
  1.  . S LNCTR=LNCTR+1
  1.  . S XX="The following patients will need to be manually updated: "
  1.  . ;
  1.  . ; Is the mail message getting too big?
  1.  . I CURSIZE+$L(XX)>MAXSIZE D
  1.  . . D MSG^IBCNEUT5(MLGRP,SUBJECT,"MSG(",,.XMY)
  1.  . . K MSG
  1.  . . S CURSIZE=0,LNCTR=1
  1.  . ;
  1.  . S MSG(LNCTR)=XX,CURSIZE=CURSIZE+$L(XX)
  1.  . S DFN=""
  1.  . F  D  Q:DFN=""
  1.  . . S DFN=$O(^TMP($J,"ERRLIST",DFN))
  1.  . . Q:DFN=""
  1.  . . S PNM=$$GET1^DIQ(2,DFN,.01)
  1.  . . S SSN=$$GET1^DIQ(2,DFN,.09),SSN=$E(SSN,6,9)
  1.  . . S NPAT="      "_PNM_"  "_SSN
  1.  . . ;
  1.  . . ; Is the mail message getting too big?
  1.  . . I CURSIZE+$L(NPAT)>MAXSIZE D
  1.  . . . D MSG^IBCNEUT5(MLGRP,SUBJECT,"MSG(",,.XMY)
  1.  . . . K MSG
  1.  . . . S LNCTR=1,MSG(1)=XX,CURSIZE=$L(XX)
  1.  . . S LNCTR=LNCTR+1
  1.  . . S MSG(LNCTR)=NPAT
  1.  . . S CURSIZE=CURSIZE+$L(NPAT)
  1.  . S LNCTR=LNCTR+1,MSG(LNCTR)="",LNCTR=LNCTR+1,MSG(LNCTR)=""
  1.  ;
  1.  ; Next add the patients who were updated to the email
  1.  S LNCTR=LNCTR+1
  1.  S MSG(LNCTR)="The policy expiration dates of active policies for the following deceased"
  1.  S CURSIZE=CURSIZE+$L(MSG(LNCTR))
  1.  S LNCTR=LNCTR+1
  1.  S MSG(LNCTR)="patients were updated to be the patient's date of death+1:"
  1.  S CURSIZE=CURSIZE+$L(MSG(LNCTR))
  1.  S DFN=""
  1.  F  D  Q:DFN=""
  1.  . S DFN=$O(^TMP($J,"PATLIST",DFN))
  1.  . Q:DFN=""
  1.  . S PNM=$$GET1^DIQ(2,DFN,.01)
  1.  . S SSN=$$GET1^DIQ(2,DFN,.09),SSN=$E(SSN,6,9)
  1.  . S NPAT="      "_PNM_"  "_SSN
  1.  . ;
  1.  . ; Is the mail message getting too big?
  1.  . I CURSIZE+$L(NPAT)>MAXSIZE D
  1.  . . D MSG^IBCNEUT5(MLGRP,SUBJECT,"MSG(",,.XMY)
  1.  . . K MSG
  1.  . . S CURSIZE=0,LNCTR=2
  1.  . . S MSG(1)="The policy expiration dates of active policies for the following deceased"
  1.  . . S CURSIZE=CURSIZE+$L(MSG(1))
  1.  . . S MSG(2)="patients were updated to be the patient's date of death+1:"
  1.  . . S CURSIZE=CURSIZE+$L(MSG(2))
  1.  . S LNCTR=LNCTR+1
  1.  . S MSG(LNCTR)=NPAT
  1.  . S CURSIZE=CURSIZE+$L(NPAT)
  1.  ;
  1.  D MSG^IBCNEUT5(MLGRP,SUBJECT,"MSG(",,.XMY)
  1.  K ^TMP($J,"PATLIST"),^TMP($J,"ERRLIST")
  1.  Q
  1.  ;
  1. UPDTEDT(DFN,IIEN,DOD) ; Update the Expiration for the specified patient policy
  1.  ; Input:   DFN                 - IEN of the patient whose policy is being
  1.  ;                                updated
  1.  ;          IIEN                - IEN of the patient policy multiple being
  1.  ;                                updated
  1.  ;          DOD                 - Internal Date of Death of the specified
  1.  ;                                patient
  1.  ;          ^TMP($J,"ERRLIST")  - Current array of Patient Policy update errors
  1.  ; Output:  ^TMP($J,"ERRLIST")  - Updated array of Patient Policy update errors
  1.  N DA,FDA,IBERR
  1.  N $ESTACK,$ETRAP
  1.  S $ETRAP="D POLERR^IBY549PO"
  1.  S DA=IIEN,DA(1)=DFN
  1.  S FDA(2.312,DA_","_DA(1)_",",1.05)=$$NOW^XLFDT()               ; Date Last Edited
  1.  S FDA(2.312,DA_","_DA(1)_",",1.06)=.5                          ; Last Edited By
  1.  S FDA(2.312,DA_","_DA(1)_",",3)=$P($$FMADD^XLFDT(DOD,1),".",1) ; Date of Death +1
  1.  N A,D,X,Y
  1.  D FILE^DIE("","FDA","IBERR")
  1.  I $D(IBERR) D
  1.  . S ^TMP($J,"ERRLIST",DFN,IIEN)=""
  1.  Q
  1.  ;
  1. POLERR ; Called when an error occurs terminating active policies for deceased
  1.  ; patients.  Note:  This usually occurs because of a known fileman error and a
  1.  ; collision of a post-filing routine updating file 2.312 with a nightly KPAS
  1.  ; extract doing inquiries into the 2.312 file at the same time.
  1.  ;
  1.  ; If an error occurs, this method will add the patient where the error occured
  1.  ; onto the error list for manual processing and move on to the next patient.
  1.  ; Input:   DFN                 - IIEN of the patient that was being worked 
  1.  ;                                when the error occured
  1.  ;          ^TMP($J,"ERRLIST")  - Current array of patients that had filing 
  1.  ;                                errors
  1.  ;          IIEN                - IEN of the patient policy multiple being 
  1.  ;                                updated when the error occured
  1.  ; Output:  ^TMP($J,"ERRLIST") - Updated array of patients that had filing errors
  1.  S ^TMP($J,"ERRLIST",DFN,IIEN)=""           ; Log collision error
  1.  S $ECODE=""                                ; Ignore error and continue
  1.  Q
  1.  ;
  1. DONE ; Displays the 'Done' message and finishes the progress bar
  1.  ; Input: IBXPD - Post-Installation step being performed
  1.  D MES^XPDUTL(" Done.")
  1.  Q
  1.  ;