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