IBY687PO ;AITC/VD - Post-Installation for IB patch 687; OCT 02, 2020
;;2.0;INTEGRATED BILLING;**687**;MAR 21,1994;Build 88
;;Per VA Directive 6402, this routine should not be modified.
;
; ICR #1367 for the usage of ^XPDKEY.
; ICR #10141 for the usage of ^XPDUTL.
; ICR #4677 for the usage of CREATE^XUSAP.
; ICR #10007 for the usage of DO^DIC1.
; ICR #2052 for the usage of FIELD^DID.
; ICR #2916 for the usage of FILESEC^DDMOD.
Q
;
POST ; POST-INSTALL
N IBXPD,PRODENV,SITE,SITENAME,SITENUM,XPDIDTOT
S XPDIDTOT=13
S SITE=$$SITE^VASITE,SITENAME=$P(SITE,U,2),SITENUM=$P(SITE,U,3)
;
S PRODENV=$$PROD^XUPROD(1) ; 1=Production Environment, 0=Test Environment
D MES^XPDUTL("")
;
D IIU(1) ; Add new payer application to PAYER APPLICATION file (#365.13)
;
D SITEFIL(2) ; Set initial value for the IIU MASTER SWITCH field (#350.9,53.01)
D SITEFIL(3) ; Set initial value for the IIU ENABLED field (#350.9,53.02)
D SITEFIL(4) ; Set initial value for the IIU RECENT VISIT DAYS field (#350.9,53.03)
D SITEFIL(5) ; Set initial value for the IIU MIN DAYS BEFORE SHARING field (#350.9,53.04)
D SITEFIL(6) ; Set initial value for the IIU PURGE SENT RECORDS field (#350.9,53.05)
D SITEFIL(7) ; Set initial value for the IIU PURGE CANDIDATE RECORDS field (#350.9,53.06)
D SITEFIL(8) ; Set initial value for the IIU PURGE RECEIVED RECORDS field (#350.9,53.07)
;
D RENAMKY(9) ; Rename the IBCNE EIV MAINTENANCE security key to IBCNE EIV IIU MAINTENANCE
;
D ADDPROXY(10) ; Create "INTERFACE,IB IIU" in file New Person (#200)
;
D CLNIB668(11) ; Clean up Files & Fields that should have been deleted during IB*668 pre-install
;
D FILESEC(12) ;Set Security on INTERFACILITY INSURANCE UPDATE (#365.19) File
;
D SITEREG(13,SITENUM) ; Send site registration message to FSC
;
D MES^XPDUTL("") ; Displays the 'Done' message and finishes the progress bar
D MES^XPDUTL("POST-Install for IB*2.0*687 Completed.")
Q
;============================
IIU(IBXPD) ; Add new payer application to PAYER APPLICATION file (#365.13)
N IBERR,IBIEN,DATA
D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
D MES^XPDUTL("-------------")
D MES^XPDUTL("Adding ""IIU"" as a new Payer Application in PAYER APPLICATION file (#365.13)")
;
S DATA(.01)="IIU"
;
I $$FIND1^DIC(365.13,,,"IIU") D G IIUQ ; IIU already exists in file.
. D MES^XPDUTL("IIU already exists in the Payer Application file (#355.13).")
;
S IBIEN=$$ADD^IBDFDBS(365.13,,.DATA,.IBERR)
;
I IBERR D G IIUQ
. D BMES^XPDUTL("")
. D BMES^XPDUTL("*** ERROR ADDING ""IIU"" TO THE PAYER APPLICATION FILE (#365.13) - Log a Service Ticket! ***")
;
D MES^XPDUTL("Payer Application: IIU added successfully")
;
IIUQ ;
Q
;
SITEFIL(IBXPD) ; Set initial value of the new IB Site Parameter fields (US23559)
N DA,DIE,DR
D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
D MES^XPDUTL("-------------")
;
I IBXPD=2 D Q
. D MES^XPDUTL("Initialize value of IIU MASTER SWITCH field to NULL in IB SITE PARAMETERS file...")
. I $$GET1^DIQ(350.9,"1,",53.01)'="" D Q ; Skip if this field is already set.
. . D BMES^XPDUTL(" Patch IB*2.0*687 has been previously installed...")
. . D MES^XPDUTL(" ...Skipping the initialization of the IIU MASTER SWITCH field.") Q
. S DA=1,DIE=350.9,DR="53.01///" D ^DIE ; Set to NULL because FSC controls this setting.
. K DA,DIE,DR
;
I IBXPD=3 D Q
. D MES^XPDUTL("Initialize value of IIU ENABLED to YES in IB SITE PARAMETERS file...")
. I $$GET1^DIQ(350.9,"1,",53.02)'="" D Q ; Skip if this field is already set.
. . D BMES^XPDUTL(" Patch IB*2.0*687 has been previously installed...")
. . D MES^XPDUTL(" ...Skipping the initialization of the IIU ENABLED field.") Q
. S DIE=350.9,DA=1,DR="53.02///"_"Y" D ^DIE
. K DA,DIE,DR
;
I IBXPD=4 D Q
. D MES^XPDUTL("Initialize value of IIU RECENT VISIT DAYS field to 335 in IB SITE PARAMETERS file...")
. I $$GET1^DIQ(350.9,"1,",53.03)'="" D Q ; Skip if this field is already set.
. . D BMES^XPDUTL(" Patch IB*2.0*687 has been previously installed...")
. . D MES^XPDUTL(" ...Skipping the initialization of the IIU RECENT VISIT DAYS field.") Q
. S DA=1,DIE=350.9,DR="53.03///335" D ^DIE
. K DA,DIE,DR
;
I IBXPD=5 D Q
. D MES^XPDUTL("Initialize value of IIU MIN DAYS BEFORE SHARING field to 170 in IB SITE PARAMETERS file...")
. I $$GET1^DIQ(350.9,"1,",53.04)'="" D Q ; Skip if this field is already set.
. . D BMES^XPDUTL(" Patch IB*2.0*687 has been previously installed...")
. . D MES^XPDUTL(" ...Skipping the initialization of the IIU MIN DAYS BEFORE SHARING field.") Q
. S DA=1,DIE=350.9,DR="53.04///170" D ^DIE
. K DA,DIE,DR
;
I IBXPD=6 D Q
. D MES^XPDUTL("Initialize value of IIU PURGE SENT RECORDS field to 180 in IB SITE PARAMETERS file...")
. I $$GET1^DIQ(350.9,"1,",53.05)'="" D Q ; Skip if this field is already set.
. . D BMES^XPDUTL(" Patch IB*2.0*687 has been previously installed...")
. . D MES^XPDUTL(" ...Skipping the initialization of the IIU PURGE SENT RECORDS field.") Q
. S DA=1,DIE=350.9,DR="53.05///180" D ^DIE
. K DA,DIE,DR
;
I IBXPD=7 D Q
. D MES^XPDUTL("Initialize value of IIU PURGE CANDIDATE RECORDS field to 7 in IB SITE PARAMETERS file...")
. I $$GET1^DIQ(350.9,"1,",53.06)'="" D Q ; Skip if this field is already set.
. . D BMES^XPDUTL(" Patch IB*2.0*687 has been previously installed...")
. . D MES^XPDUTL(" ...Skipping the initialization of the IIU PURGE CANDIDATE RECORDS field.") Q
. S DA=1,DIE=350.9,DR="53.06///7" D ^DIE
. K DA,DIE,DR
;
I IBXPD=8 D Q
. D MES^XPDUTL("Initialize value of IIU PURGE RECEIVED RECORDS field to 30 in IB SITE PARAMETERS file...")
. I $$GET1^DIQ(350.9,"1,",53.07)'="" D Q ; Skip if this field is already set.
. . D BMES^XPDUTL(" Patch IB*2.0*687 has been previously installed...")
. . D MES^XPDUTL(" ...Skipping the initialization of the IIU PURGE RECEIVED RECORDS field.") Q
. S DA=1,DIE=350.9,DR="53.07///30" D ^DIE
. K DA,DIE,DR
Q
;
RENAMKY(IBXPD) ; Rename the IBCNE EIV MAINTENANCE security key to IBCNE EIV IIU MAINTENANCE
N IBFLAG
D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
D MES^XPDUTL("-------------")
D MES^XPDUTL("Renaming the IBCNE EIV MAINTENANCE security key...")
;
; Check whether the security key has already been renamed.
I $O(^DIC(19.1,"B","IBCNE EIV MAINTENANCE",0))'>0,+$O(^DIC(19.1,"B","IBCNE EIV IIU MAINTENANCE",0)) D Q
. D MES^XPDUTL("The IBCNE EIV MAINTENANCE security key was previously renamed")
. D MES^XPDUTL("to IBCNE EIV IIU MAINTENANCE. No change made.")
;
; Rename the security key.
S IBFLAG=$$RENAME^XPDKEY("IBCNE EIV MAINTENANCE","IBCNE EIV IIU MAINTENANCE") ; ICR # 1367
I 'IBFLAG D MES^XPDUTL("The IBCNE EIV MAINTENANCE security key was not renamed!"),MES^XPDUTL("Aborting security key update.") Q
;
D MES^XPDUTL("The IBCNE EIV MAINTENANCE security key has been successfully renamed")
D MES^XPDUTL("to IBCNE EIV IIU MAINTENANCE!")
Q
;
ADDPROXY(IBXPD) ;Add APPLICATION PROXY user to file 200. Supported by IA#4677.
D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
D MES^XPDUTL("-------------")
D MES^XPDUTL("Adding entry 'INTERFACE,IB IIU' to the New Person file (#200)")
N IEN200
S IEN200=$$CREATE^XUSAP("INTERFACE,IB IIU","")
I +IEN200=0 D MES^XPDUTL("........'INTERFACE,IB IIU' already exists.")
I +IEN200>0 D MES^XPDUTL("........'INTERFACE,IB IIU' added.")
I IEN200<0 D MES^XPDUTL("........ERROR: 'INTERFACE,IB IIU' NOT added.")
Q
;
CLNIB668(IBXPD) ;Clean up Files & Fields that weren't deleted during the IB*668 pre-install.
D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
D MES^XPDUTL("-------------")
D DELFILES ; delete files
D DFLDS ; delete fields
Q
;
DELFILES ; Delete files and sub-files.
D BMES^XPDUTL("Checking for SSVI Related Files and Sub-files for possible deletion.")
;
N DIC,DO,FILE,FOUND,SUBFILE
; According to the Developer Guide, you can use a file # or global root to delete the file
; This module of code will delete the following Files and their related Sub-files:
S FOUND=0
;
; IB SSVI PIN/HL7 PIVOT File #366 and it's related sub-files #366.04 and #366.05
S FILE=366
S DIC="^IBCN(366," D DO^DIC1 ; ICR # 10007
I $P(DO,"^")="IB SSVI PIN/HL7 PIVOT" D DFILE(FILE)
K DIC,DO
;
;IB INSURANCE INCONSISTENT DATA File #366.1 and it's related sub-file #366.16
S FILE=366.1
S DIC="^IBCN(366.1," D DO^DIC1
I $P(DO,"^")="IB INSURANCE INCONSISTENT DATA" D DFILE(FILE)
K DIC,DO
;
;IB INSURANCE CONSISTENCY ELEMENTS File #366.2 and it's related sub-file #366.21
S FILE=366.2
S DIC="^IBCN(366.2," D DO^DIC1
I $P(DO,"^")="IB INSURANCE CONSISTENCY ELEMENTS" D DFILE(FILE)
;I $P(DO,"^")="IB INSURANCE INCONSISTENCY ELEMENTS" D DFILE(FILE)
K DIC,DO
;
I FOUND D BMES^XPDUTL("SSVI Related Files and Sub-files Deleted.")
I 'FOUND D BMES^XPDUTL("No SSVI Related Files and Sub-files were deleted.")
Q
;
DFILE(FILE) ;Delete a File
N DIU
S FOUND=1
S DIU=FILE,DIU(0)="D" ; "D"elete the data dictionary along with it's data.
D EN^DIU2
K DIU
D BMES^XPDUTL(" ....Deleted File #"_FILE_" it's data and related sub-files")
Q
;
DFLDS ; Delete fields and data when needed.
D BMES^XPDUTL("Checking for IB Site Parameter File (#350.9) SSVI Fields for possible deletion.")
;
N DA,DIC,DIK,DO,FLD,FLD100,FLD101,FLD102,FLD103,FLDNO,FOUND
; This module of code deletes the data and the definitions
; for the following fields in the IB SITE PARAMETERS File (#350.9):
; - Field # 100 IB SSVI DISABLE/ENABLE
; - Field # 101 IB SSVI LAST INS DATE XFER
; - Field # 102 IB CURRENT PIVOT ENTRY HL7
; - Field # 103 IB PIVOT FILE DAYS TO RETAIN
;
; Delete the data.
S (FLD100,FLD101,FLD102,FLD103,FOUND)=0
;
S DA=0 F S DA=$O(^IBE(350.9,DA)) Q:'DA D
. N DIE,DR,FNAME
. F FLDNO=100,101,102,103 D
. . D FIELD^DID(350.9,FLDNO,,"LABEL","FNAME") ;ICR # 2052
. . S FLD="FLD"_FLDNO
. . I FLDNO=100 I $G(FNAME("LABEL"))="IB SSVI DISABLE/ENABLE" S @FLD=1
. . I FLDNO=101 I $G(FNAME("LABEL"))="IB SSVI LAST INS DATE XFER" S @FLD=1
. . ;I FLDNO=102 I $G(FNAME("LABEL"))="IB CURRENT PIVOT ENTRY HL7" S @FLD=1
. . I FLDNO=102 I $G(FNAME("LABEL"))="IB CURRENT PIVOT ENTRY" S @FLD=1
. . I FLDNO=103 I $G(FNAME("LABEL"))="IB PIVOT FILE DAYS TO RETAIN" S @FLD=1
. . K FNAME
. . I @FLD=1 D
. . . S FOUND=1
. . . S DR=FLDNO_"////@",DIE="^IBE(350.9," D ^DIE
. . . D BMES^XPDUTL(" ....Deleted Data for Field (#350.9,"_FLDNO_").")
;
; Delete the field definitions.
F FLDNO=100,101,102,103 D
. S FLD="FLD"_FLDNO
. I @FLD=1 D
. . K DA
. . S DIK="^DD(350.9,",DA=FLDNO,DA(1)=350.9 D ^DIK
. . D BMES^XPDUTL(" .......Deleted Definition for Field (#350.9,"_FLDNO_").")
;
I FOUND D BMES^XPDUTL("IB Site Parameter File (#350.9) SSVI Fields Deleted.")
I 'FOUND D BMES^XPDUTL("No IB Site Parameter File (#350.9) SSVI Fields were deleted.")
Q
;
FILESEC(IBXPD) ;Update File Security on INTERFACILITY INSURANCE UPDATE file (#365.19)
D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
D MES^XPDUTL("-------------")
D MES^XPDUTL("Updating file security on the INTERFACILITY INSURANCE UPDATE (#365.19) file ... ")
N CODES,ERROR
;
S CODES("AUDIT")="@"
S CODES("DD")="@"
S CODES("DEL")="@"
S CODES("LAYGO")="@"
S CODES("WR")="@"
;
D FILESEC^DDMOD(365.19,.CODES,"ERROR")
;
I $D(ERROR) D MES^XPDUTL("File security was NOT updated.") G FILESECQ
;
D MES^XPDUTL("File security has been updated.")
FILESECQ ;
Q
;
SITEREG(IBXPD,SITENUM) ; send site registration message to FSC
D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
D MES^XPDUTL("-------------")
D MES^XPDUTL("Send eIV site registration message to FSC ... ")
;
I '$$PROD^XUPROD(1) D MES^XPDUTL("N/A - Not a production account - No site registration message sent") G SITEREGQ
I SITENUM=358 D MES^XPDUTL("Current Site is MANILA - NO eIV site registration message sent") G SITEREGQ
D ^IBCNEHLM
D MES^XPDUTL("eIV site registration message was successfully sent")
;
SITEREGQ ;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBY687PO 12224 printed Apr 09, 2024@21:12:33 Page 2
IBY687PO ;AITC/VD - Post-Installation for IB patch 687; OCT 02, 2020
+1 ;;2.0;INTEGRATED BILLING;**687**;MAR 21,1994;Build 88
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; ICR #1367 for the usage of ^XPDKEY.
+5 ; ICR #10141 for the usage of ^XPDUTL.
+6 ; ICR #4677 for the usage of CREATE^XUSAP.
+7 ; ICR #10007 for the usage of DO^DIC1.
+8 ; ICR #2052 for the usage of FIELD^DID.
+9 ; ICR #2916 for the usage of FILESEC^DDMOD.
+10 QUIT
+11 ;
POST ; POST-INSTALL
+1 NEW IBXPD,PRODENV,SITE,SITENAME,SITENUM,XPDIDTOT
+2 SET XPDIDTOT=13
+3 SET SITE=$$SITE^VASITE
SET SITENAME=$PIECE(SITE,U,2)
SET SITENUM=$PIECE(SITE,U,3)
+4 ;
+5 ; 1=Production Environment, 0=Test Environment
SET PRODENV=$$PROD^XUPROD(1)
+6 DO MES^XPDUTL("")
+7 ;
+8 ; Add new payer application to PAYER APPLICATION file (#365.13)
DO IIU(1)
+9 ;
+10 ; Set initial value for the IIU MASTER SWITCH field (#350.9,53.01)
DO SITEFIL(2)
+11 ; Set initial value for the IIU ENABLED field (#350.9,53.02)
DO SITEFIL(3)
+12 ; Set initial value for the IIU RECENT VISIT DAYS field (#350.9,53.03)
DO SITEFIL(4)
+13 ; Set initial value for the IIU MIN DAYS BEFORE SHARING field (#350.9,53.04)
DO SITEFIL(5)
+14 ; Set initial value for the IIU PURGE SENT RECORDS field (#350.9,53.05)
DO SITEFIL(6)
+15 ; Set initial value for the IIU PURGE CANDIDATE RECORDS field (#350.9,53.06)
DO SITEFIL(7)
+16 ; Set initial value for the IIU PURGE RECEIVED RECORDS field (#350.9,53.07)
DO SITEFIL(8)
+17 ;
+18 ; Rename the IBCNE EIV MAINTENANCE security key to IBCNE EIV IIU MAINTENANCE
DO RENAMKY(9)
+19 ;
+20 ; Create "INTERFACE,IB IIU" in file New Person (#200)
DO ADDPROXY(10)
+21 ;
+22 ; Clean up Files & Fields that should have been deleted during IB*668 pre-install
DO CLNIB668(11)
+23 ;
+24 ;Set Security on INTERFACILITY INSURANCE UPDATE (#365.19) File
DO FILESEC(12)
+25 ;
+26 ; Send site registration message to FSC
DO SITEREG(13,SITENUM)
+27 ;
+28 ; Displays the 'Done' message and finishes the progress bar
DO MES^XPDUTL("")
+29 DO MES^XPDUTL("POST-Install for IB*2.0*687 Completed.")
+30 QUIT
+31 ;============================
IIU(IBXPD) ; Add new payer application to PAYER APPLICATION file (#365.13)
+1 NEW IBERR,IBIEN,DATA
+2 DO BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
+3 DO MES^XPDUTL("-------------")
+4 DO MES^XPDUTL("Adding ""IIU"" as a new Payer Application in PAYER APPLICATION file (#365.13)")
+5 ;
+6 SET DATA(.01)="IIU"
+7 ;
+8 ; IIU already exists in file.
IF $$FIND1^DIC(365.13,,,"IIU")
Begin DoDot:1
+9 DO MES^XPDUTL("IIU already exists in the Payer Application file (#355.13).")
End DoDot:1
GOTO IIUQ
+10 ;
+11 SET IBIEN=$$ADD^IBDFDBS(365.13,,.DATA,.IBERR)
+12 ;
+13 IF IBERR
Begin DoDot:1
+14 DO BMES^XPDUTL("")
+15 DO BMES^XPDUTL("*** ERROR ADDING ""IIU"" TO THE PAYER APPLICATION FILE (#365.13) - Log a Service Ticket! ***")
End DoDot:1
GOTO IIUQ
+16 ;
+17 DO MES^XPDUTL("Payer Application: IIU added successfully")
+18 ;
IIUQ ;
+1 QUIT
+2 ;
SITEFIL(IBXPD) ; Set initial value of the new IB Site Parameter fields (US23559)
+1 NEW DA,DIE,DR
+2 DO BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
+3 DO MES^XPDUTL("-------------")
+4 ;
+5 IF IBXPD=2
Begin DoDot:1
+6 DO MES^XPDUTL("Initialize value of IIU MASTER SWITCH field to NULL in IB SITE PARAMETERS file...")
+7 ; Skip if this field is already set.
IF $$GET1^DIQ(350.9,"1,",53.01)'=""
Begin DoDot:2
+8 DO BMES^XPDUTL(" Patch IB*2.0*687 has been previously installed...")
+9 DO MES^XPDUTL(" ...Skipping the initialization of the IIU MASTER SWITCH field.")
QUIT
End DoDot:2
QUIT
+10 ; Set to NULL because FSC controls this setting.
SET DA=1
SET DIE=350.9
SET DR="53.01///"
DO ^DIE
+11 KILL DA,DIE,DR
End DoDot:1
QUIT
+12 ;
+13 IF IBXPD=3
Begin DoDot:1
+14 DO MES^XPDUTL("Initialize value of IIU ENABLED to YES in IB SITE PARAMETERS file...")
+15 ; Skip if this field is already set.
IF $$GET1^DIQ(350.9,"1,",53.02)'=""
Begin DoDot:2
+16 DO BMES^XPDUTL(" Patch IB*2.0*687 has been previously installed...")
+17 DO MES^XPDUTL(" ...Skipping the initialization of the IIU ENABLED field.")
QUIT
End DoDot:2
QUIT
+18 SET DIE=350.9
SET DA=1
SET DR="53.02///"_"Y"
DO ^DIE
+19 KILL DA,DIE,DR
End DoDot:1
QUIT
+20 ;
+21 IF IBXPD=4
Begin DoDot:1
+22 DO MES^XPDUTL("Initialize value of IIU RECENT VISIT DAYS field to 335 in IB SITE PARAMETERS file...")
+23 ; Skip if this field is already set.
IF $$GET1^DIQ(350.9,"1,",53.03)'=""
Begin DoDot:2
+24 DO BMES^XPDUTL(" Patch IB*2.0*687 has been previously installed...")
+25 DO MES^XPDUTL(" ...Skipping the initialization of the IIU RECENT VISIT DAYS field.")
QUIT
End DoDot:2
QUIT
+26 SET DA=1
SET DIE=350.9
SET DR="53.03///335"
DO ^DIE
+27 KILL DA,DIE,DR
End DoDot:1
QUIT
+28 ;
+29 IF IBXPD=5
Begin DoDot:1
+30 DO MES^XPDUTL("Initialize value of IIU MIN DAYS BEFORE SHARING field to 170 in IB SITE PARAMETERS file...")
+31 ; Skip if this field is already set.
IF $$GET1^DIQ(350.9,"1,",53.04)'=""
Begin DoDot:2
+32 DO BMES^XPDUTL(" Patch IB*2.0*687 has been previously installed...")
+33 DO MES^XPDUTL(" ...Skipping the initialization of the IIU MIN DAYS BEFORE SHARING field.")
QUIT
End DoDot:2
QUIT
+34 SET DA=1
SET DIE=350.9
SET DR="53.04///170"
DO ^DIE
+35 KILL DA,DIE,DR
End DoDot:1
QUIT
+36 ;
+37 IF IBXPD=6
Begin DoDot:1
+38 DO MES^XPDUTL("Initialize value of IIU PURGE SENT RECORDS field to 180 in IB SITE PARAMETERS file...")
+39 ; Skip if this field is already set.
IF $$GET1^DIQ(350.9,"1,",53.05)'=""
Begin DoDot:2
+40 DO BMES^XPDUTL(" Patch IB*2.0*687 has been previously installed...")
+41 DO MES^XPDUTL(" ...Skipping the initialization of the IIU PURGE SENT RECORDS field.")
QUIT
End DoDot:2
QUIT
+42 SET DA=1
SET DIE=350.9
SET DR="53.05///180"
DO ^DIE
+43 KILL DA,DIE,DR
End DoDot:1
QUIT
+44 ;
+45 IF IBXPD=7
Begin DoDot:1
+46 DO MES^XPDUTL("Initialize value of IIU PURGE CANDIDATE RECORDS field to 7 in IB SITE PARAMETERS file...")
+47 ; Skip if this field is already set.
IF $$GET1^DIQ(350.9,"1,",53.06)'=""
Begin DoDot:2
+48 DO BMES^XPDUTL(" Patch IB*2.0*687 has been previously installed...")
+49 DO MES^XPDUTL(" ...Skipping the initialization of the IIU PURGE CANDIDATE RECORDS field.")
QUIT
End DoDot:2
QUIT
+50 SET DA=1
SET DIE=350.9
SET DR="53.06///7"
DO ^DIE
+51 KILL DA,DIE,DR
End DoDot:1
QUIT
+52 ;
+53 IF IBXPD=8
Begin DoDot:1
+54 DO MES^XPDUTL("Initialize value of IIU PURGE RECEIVED RECORDS field to 30 in IB SITE PARAMETERS file...")
+55 ; Skip if this field is already set.
IF $$GET1^DIQ(350.9,"1,",53.07)'=""
Begin DoDot:2
+56 DO BMES^XPDUTL(" Patch IB*2.0*687 has been previously installed...")
+57 DO MES^XPDUTL(" ...Skipping the initialization of the IIU PURGE RECEIVED RECORDS field.")
QUIT
End DoDot:2
QUIT
+58 SET DA=1
SET DIE=350.9
SET DR="53.07///30"
DO ^DIE
+59 KILL DA,DIE,DR
End DoDot:1
QUIT
+60 QUIT
+61 ;
RENAMKY(IBXPD) ; Rename the IBCNE EIV MAINTENANCE security key to IBCNE EIV IIU MAINTENANCE
+1 NEW IBFLAG
+2 DO BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
+3 DO MES^XPDUTL("-------------")
+4 DO MES^XPDUTL("Renaming the IBCNE EIV MAINTENANCE security key...")
+5 ;
+6 ; Check whether the security key has already been renamed.
+7 IF $ORDER(^DIC(19.1,"B","IBCNE EIV MAINTENANCE",0))'>0
IF +$ORDER(^DIC(19.1,"B","IBCNE EIV IIU MAINTENANCE",0))
Begin DoDot:1
+8 DO MES^XPDUTL("The IBCNE EIV MAINTENANCE security key was previously renamed")
+9 DO MES^XPDUTL("to IBCNE EIV IIU MAINTENANCE. No change made.")
End DoDot:1
QUIT
+10 ;
+11 ; Rename the security key.
+12 ; ICR # 1367
SET IBFLAG=$$RENAME^XPDKEY("IBCNE EIV MAINTENANCE","IBCNE EIV IIU MAINTENANCE")
+13 IF 'IBFLAG
DO MES^XPDUTL("The IBCNE EIV MAINTENANCE security key was not renamed!")
DO MES^XPDUTL("Aborting security key update.")
QUIT
+14 ;
+15 DO MES^XPDUTL("The IBCNE EIV MAINTENANCE security key has been successfully renamed")
+16 DO MES^XPDUTL("to IBCNE EIV IIU MAINTENANCE!")
+17 QUIT
+18 ;
ADDPROXY(IBXPD) ;Add APPLICATION PROXY user to file 200. Supported by IA#4677.
+1 DO BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
+2 DO MES^XPDUTL("-------------")
+3 DO MES^XPDUTL("Adding entry 'INTERFACE,IB IIU' to the New Person file (#200)")
+4 NEW IEN200
+5 SET IEN200=$$CREATE^XUSAP("INTERFACE,IB IIU","")
+6 IF +IEN200=0
DO MES^XPDUTL("........'INTERFACE,IB IIU' already exists.")
+7 IF +IEN200>0
DO MES^XPDUTL("........'INTERFACE,IB IIU' added.")
+8 IF IEN200<0
DO MES^XPDUTL("........ERROR: 'INTERFACE,IB IIU' NOT added.")
+9 QUIT
+10 ;
CLNIB668(IBXPD) ;Clean up Files & Fields that weren't deleted during the IB*668 pre-install.
+1 DO BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
+2 DO MES^XPDUTL("-------------")
+3 ; delete files
DO DELFILES
+4 ; delete fields
DO DFLDS
+5 QUIT
+6 ;
DELFILES ; Delete files and sub-files.
+1 DO BMES^XPDUTL("Checking for SSVI Related Files and Sub-files for possible deletion.")
+2 ;
+3 NEW DIC,DO,FILE,FOUND,SUBFILE
+4 ; According to the Developer Guide, you can use a file # or global root to delete the file
+5 ; This module of code will delete the following Files and their related Sub-files:
+6 SET FOUND=0
+7 ;
+8 ; IB SSVI PIN/HL7 PIVOT File #366 and it's related sub-files #366.04 and #366.05
+9 SET FILE=366
+10 ; ICR # 10007
SET DIC="^IBCN(366,"
DO DO^DIC1
+11 IF $PIECE(DO,"^")="IB SSVI PIN/HL7 PIVOT"
DO DFILE(FILE)
+12 KILL DIC,DO
+13 ;
+14 ;IB INSURANCE INCONSISTENT DATA File #366.1 and it's related sub-file #366.16
+15 SET FILE=366.1
+16 SET DIC="^IBCN(366.1,"
DO DO^DIC1
+17 IF $PIECE(DO,"^")="IB INSURANCE INCONSISTENT DATA"
DO DFILE(FILE)
+18 KILL DIC,DO
+19 ;
+20 ;IB INSURANCE CONSISTENCY ELEMENTS File #366.2 and it's related sub-file #366.21
+21 SET FILE=366.2
+22 SET DIC="^IBCN(366.2,"
DO DO^DIC1
+23 IF $PIECE(DO,"^")="IB INSURANCE CONSISTENCY ELEMENTS"
DO DFILE(FILE)
+24 ;I $P(DO,"^")="IB INSURANCE INCONSISTENCY ELEMENTS" D DFILE(FILE)
+25 KILL DIC,DO
+26 ;
+27 IF FOUND
DO BMES^XPDUTL("SSVI Related Files and Sub-files Deleted.")
+28 IF 'FOUND
DO BMES^XPDUTL("No SSVI Related Files and Sub-files were deleted.")
+29 QUIT
+30 ;
DFILE(FILE) ;Delete a File
+1 NEW DIU
+2 SET FOUND=1
+3 ; "D"elete the data dictionary along with it's data.
SET DIU=FILE
SET DIU(0)="D"
+4 DO EN^DIU2
+5 KILL DIU
+6 DO BMES^XPDUTL(" ....Deleted File #"_FILE_" it's data and related sub-files")
+7 QUIT
+8 ;
DFLDS ; Delete fields and data when needed.
+1 DO BMES^XPDUTL("Checking for IB Site Parameter File (#350.9) SSVI Fields for possible deletion.")
+2 ;
+3 NEW DA,DIC,DIK,DO,FLD,FLD100,FLD101,FLD102,FLD103,FLDNO,FOUND
+4 ; This module of code deletes the data and the definitions
+5 ; for the following fields in the IB SITE PARAMETERS File (#350.9):
+6 ; - Field # 100 IB SSVI DISABLE/ENABLE
+7 ; - Field # 101 IB SSVI LAST INS DATE XFER
+8 ; - Field # 102 IB CURRENT PIVOT ENTRY HL7
+9 ; - Field # 103 IB PIVOT FILE DAYS TO RETAIN
+10 ;
+11 ; Delete the data.
+12 SET (FLD100,FLD101,FLD102,FLD103,FOUND)=0
+13 ;
+14 SET DA=0
FOR
SET DA=$ORDER(^IBE(350.9,DA))
if 'DA
QUIT
Begin DoDot:1
+15 NEW DIE,DR,FNAME
+16 FOR FLDNO=100,101,102,103
Begin DoDot:2
+17 ;ICR # 2052
DO FIELD^DID(350.9,FLDNO,,"LABEL","FNAME")
+18 SET FLD="FLD"_FLDNO
+19 IF FLDNO=100
IF $GET(FNAME("LABEL"))="IB SSVI DISABLE/ENABLE"
SET @FLD=1
+20 IF FLDNO=101
IF $GET(FNAME("LABEL"))="IB SSVI LAST INS DATE XFER"
SET @FLD=1
+21 ;I FLDNO=102 I $G(FNAME("LABEL"))="IB CURRENT PIVOT ENTRY HL7" S @FLD=1
+22 IF FLDNO=102
IF $GET(FNAME("LABEL"))="IB CURRENT PIVOT ENTRY"
SET @FLD=1
+23 IF FLDNO=103
IF $GET(FNAME("LABEL"))="IB PIVOT FILE DAYS TO RETAIN"
SET @FLD=1
+24 KILL FNAME
+25 IF @FLD=1
Begin DoDot:3
+26 SET FOUND=1
+27 SET DR=FLDNO_"////@"
SET DIE="^IBE(350.9,"
DO ^DIE
+28 DO BMES^XPDUTL(" ....Deleted Data for Field (#350.9,"_FLDNO_").")
End DoDot:3
End DoDot:2
End DoDot:1
+29 ;
+30 ; Delete the field definitions.
+31 FOR FLDNO=100,101,102,103
Begin DoDot:1
+32 SET FLD="FLD"_FLDNO
+33 IF @FLD=1
Begin DoDot:2
+34 KILL DA
+35 SET DIK="^DD(350.9,"
SET DA=FLDNO
SET DA(1)=350.9
DO ^DIK
+36 DO BMES^XPDUTL(" .......Deleted Definition for Field (#350.9,"_FLDNO_").")
End DoDot:2
End DoDot:1
+37 ;
+38 IF FOUND
DO BMES^XPDUTL("IB Site Parameter File (#350.9) SSVI Fields Deleted.")
+39 IF 'FOUND
DO BMES^XPDUTL("No IB Site Parameter File (#350.9) SSVI Fields were deleted.")
+40 QUIT
+41 ;
FILESEC(IBXPD) ;Update File Security on INTERFACILITY INSURANCE UPDATE file (#365.19)
+1 DO BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
+2 DO MES^XPDUTL("-------------")
+3 DO MES^XPDUTL("Updating file security on the INTERFACILITY INSURANCE UPDATE (#365.19) file ... ")
+4 NEW CODES,ERROR
+5 ;
+6 SET CODES("AUDIT")="@"
+7 SET CODES("DD")="@"
+8 SET CODES("DEL")="@"
+9 SET CODES("LAYGO")="@"
+10 SET CODES("WR")="@"
+11 ;
+12 DO FILESEC^DDMOD(365.19,.CODES,"ERROR")
+13 ;
+14 IF $DATA(ERROR)
DO MES^XPDUTL("File security was NOT updated.")
GOTO FILESECQ
+15 ;
+16 DO MES^XPDUTL("File security has been updated.")
FILESECQ ;
+1 QUIT
+2 ;
SITEREG(IBXPD,SITENUM) ; send site registration message to FSC
+1 DO BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
+2 DO MES^XPDUTL("-------------")
+3 DO MES^XPDUTL("Send eIV site registration message to FSC ... ")
+4 ;
+5 IF '$$PROD^XUPROD(1)
DO MES^XPDUTL("N/A - Not a production account - No site registration message sent")
GOTO SITEREGQ
+6 IF SITENUM=358
DO MES^XPDUTL("Current Site is MANILA - NO eIV site registration message sent")
GOTO SITEREGQ
+7 DO ^IBCNEHLM
+8 DO MES^XPDUTL("eIV site registration message was successfully sent")
+9 ;
SITEREGQ ;
+1 QUIT
