BPS10P7 ;OAK/ELZ - BPS*1*7 PRE/POST INSTALL ROUTINE ;6/9/08 11:02
;;1.0;E CLAIMS MGMT ENGINE;**7**;JUN 2004;Build 46
;;Per VHA Directive 2004-038, this routine should not be modified.
;
PRE ; pre-install of BPS*1*7
;
; delete the following files (leaving the data), the actual
; install of BPS*1*7 will re-install the updated files.
; 9002313.91 -- BPS NCPDP FIELD DEFS
; 9002313.92 -- BPS NCPDP FORMATS
; 9002313.93 -- BPS NCPDP REJECT CODES ** REMOVE DATA **
; 9002313.59 -- BPS TRANSACTION
; 9002313.02 -- BPS CLAIMS
; 9002313.03 -- BPS RESPONSES
; 9002313.56 -- BPS PHARMACIES
; 9002313.57 -- BPS LOG OF TRANSACTIONS
; 9002313.77 -- BPS REQUESTS
; 9002313.78 -- BPS INSURER DATA
; 9002313.99 -- BPS SETUP
;
; DBIA2172,DBIA10141,DBIA10014
;
N BPSX,DIU,XPDIDTOT,BPSC,BPSP
D MES^XPDUTL(" Starting pre-install of BPS*1*7")
S XPDIDTOT=11,BPSC=0
D MES^XPDUTL(" - Deleting files to be restored during install.")
F BPSX=9002313.91,9002313.92,9002313.93,9002313.59,9002313.02,9002313.03,9002313.56,9002313.57,9002313.77,9002313.78,9002313.99 D
. S BPSP=$G(DILOCKTM,3)
. D MES^XPDUTL(" - Deleting file #"_BPSX_", Waiting for hardware "_BPSP_" seconds...")
. S DIU=BPSX
. S DIU(0)=$S(BPSX=9002313.93:"DE",1:"E")
. D EN^DIU2
. S BPSC=BPSC+1
. D UPDATE^XPDID(BPSC)
. H BPSP ; need to pause so we don't hit the globals too hard
D MES^XPDUTL(" Finished pre-install of BPS*1*7")
Q
;
POST ; post install for BPS*1*7
; - need to build the new AD cross reference on Status
; of the BPS LOG OF TRANSACTIONS so it matches the
; BPS TRANSACTION file.
;
; DBIA2172,DBIA10141
;
N BPSX,BPSY,BPSC,XPDIDTOT,ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK,BPSTIME,DIU,BPSP
D MES^XPDUTL(" Starting post-install of BPS*1*7")
D MES^XPDUTL(" - Building AD xref on BPS LOG OF TRANSACTIONS file")
S XPDIDTOT=$P($G(^BPST(0)),"^",4)
S (BPSC,BPSX)=0
F S BPSX=$O(^BPST(BPSX)) Q:'BPSX S BPSC=BPSC+1,BPSY=$P($G(^BPST(BPSX,0)),"^",2) D:'(BPSC#500) UPDATE^XPDID(BPSC) I $L(BPSY) S ^BPST("AD",$E(BPSY,1,30),BPSX)=""
;
; need to clean up old fields from BPS Pharmacies 9002313.56
D MES^XPDUTL(" - Cleaning out old data from BPS PHARMACIES")
S BPSX=0 F S BPSX=$O(^BPS(9002313.56,BPSX)) Q:'BPSX K ^BPS(9002313.56,BPSX,"HOURS"),^("TCLOSE"),^("TOPEN")
D MES^XPDUTL(" - Done cleaning out old data from BPS PHARMACIES")
;
; Clean up the old field being removed with tasked job 9002313.0301,508Sales Tax Paid
D MES^XPDUTL(" - Queing task to clean up old data")
S ZTRTN="DQ^BPS10P7",ZTDESC="Post Install BPS*1*7, Clean-up of Data"
S (BPSTIME,ZTDTH)=$$FMADD^XLFDT($$NOW^XLFDT,,,5),ZTIO=""
D ^%ZTLOAD
I $G(ZTSK) D
. D MES^XPDUTL(" - Task Queued, #"_ZTSK_" to run at "_$$FMTE^XLFDT(BPSTIME))
E D MES^XPDUTL(" - ERROR: Task not queued!!!")
;
; populate new fields in setup file
D MES^XPDUTL(" - Setting up New Insurer Asleep fields in site param file")
S:$P($G(^BPS(9002313.99,1,0)),"^",5)="" $P(^(0),"^",5)=20
S:$P($G(^BPS(9002313.99,1,0)),"^",6)="" $P(^(0),"^",6)=10
D MES^XPDUTL(" - New Insurer Asleep fields set")
;
; delete the following obsolete files leaving no data
; 9002313.82103 BPS NCPDP FIELD 103
; 9002313.82305 BPS NCPDP FIELD 305
; 9002313.82306 BPS NCPDP FIELD 306
; 9002313.82307 BPS NCPDP FIELD 307
; 9002313.82308 BPS NCPDP FIELD 308
; 9002313.82309 BPS NCPDP FIELD 309
; 9002313.82406 BPS NCPDP FIELD 406
; 9002313.82408 BPS NCPDP FIELD 408
; 9002313.82416 BPS NCPDP FIELD 416
; 9002313.82419 BPS NCPDP FIELD 419
; 9002313.8242 BPS NCPDP FIELD 420
; 9002313.82423 BPS NCPDP FIELD 423
; 9002313.82425 BPS NCPDP FIELD 425
; 9002313.82429 BPS NCPDP FIELD 429
; 9002313.82432 BPS NCPDP FIELD 432
; 9002313.82436 BPS NCPDP FIELD 436
; 9002313.82439 BPS NCPDP FIELD 439
; 9002313.8244 BPS NCPDP FIELD 440
; 9002313.82441 BPS NCPDP FIELD 441
; 9002313.82461 BPS NCPDP FIELD 461
; 9002313.82501 BPS NCPDP FIELD 501
; 9002313.82522 BPS NCPDP FIELD 522
; 9002313.82528 BPS NCPDP FIELD 528
; 9002313.82529 BPS NCPDP FIELD 529
; 9002313.82532 BPS NCPDP FIELD 532
; 9002313.82533 BPS NCPDP FIELD 533
; 9002313.82535 BPS NCPDP FIELD 535
;
; DBIA2172,DBIA10141,DBIA10014
;
D MES^XPDUTL(" - Deleting obsolete files.")
S XPDIDTOT=27,BPSC=0
F BPSY=1:1 S BPSX=$P($T(DELFILE+BPSY),";",3) Q:BPSX="" D
. S BPSP=$G(DILOCKTM,3)
. D MES^XPDUTL(" - Deleting obsolete file #"_BPSX_", Waiting for hardware "_BPSP_" seconds...")
. S DIU=BPSX,DIU(0)="EDT"
. D EN^DIU2
. S BPSC=BPSC+1
. D UPDATE^XPDID(BPSC)
. H BPSP ; need to pause so we don't hit the globals too hard
;
D MES^XPDUTL(" Finished post-install of BPS*1*7")
Q
;
DQ ; taskman entry to clean up data
N BPSX,BPSY,Y,%DT,X
S BPSX=0 F S BPSX=$O(^BPSR(BPSX)) Q:'BPSX S BPSY=0 F S BPSY=$O(^BPSR(BPSX,1000,BPSY)) Q:'BPSY D
. I $D(^BPSR(BPSX,1000,BPSY,500)) S $P(^(500),"^",8)=""
;
; reset *M Vendor field to be null if a date is not stored there
I $L($P($G(^BPS(9002313.99,1,0)),"^",4)),$E($P(^(0),"^",4),1,7)'?7N S $P(^(0),"^",4)=""
;
; Cleaning up BPS Claims file, Date Reopened field (906)
; some data stored in there is in external format, like 8-31-2006@13:20:04
S BPSX=0 F S BPSX=$O(^BPSC(BPSX)) Q:'BPSX D
. S BPSY=$P($G(^BPSC(BPSX,900)),"^",6)
. I '$L(BPSY) Q
. I $E(BPSY,1,7)?7N Q
. S %DT="PT",X=$P(BPSY,"@")
. D ^%DT
. I Y>0 S $P(^BPSC(BPSX,900),"^",6)=+(Y_$S(BPSY["@":"."_$TR($P(BPSY,"@",2),":"),1:""))
;
; clean out the data for:
; ^BPSC(ien,400,"AC")
; $P(^BPSC(BPS(9002313.02),400,0),"^",3)
S BPSX=0 F S BPSX=$O(^BPSC(BPSX)) Q:'BPSX K ^BPSC(BPSX,400,"AC") S BPSY=0 F S BPSY=$O(^BPSC(BPSX,400,BPSY)) Q:'BPSY I $L($G(^BPSC(BPSX,400,BPSY,0))) S $P(^(0),"^",3)=""
;
Q
DELFILE ; list of files to go bye bye with their data
;;9002313.82103
;;9002313.82305
;;9002313.82306
;;9002313.82307
;;9002313.82308
;;9002313.82309
;;9002313.82406
;;9002313.82408
;;9002313.82416
;;9002313.82419
;;9002313.82423
;;9002313.82425
;;9002313.82429
;;9002313.82432
;;9002313.82436
;;9002313.8244
;;9002313.82441
;;9002313.82501
;;9002313.82522
;;9002313.82528
;;9002313.82529
;;9002313.82532
;;9002313.82533
;;9002313.82535
;;9002313.8242
;;9002313.82439
;;9002313.82461
;;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPS10P7 6651 printed Sep 23, 2025@19:26:25 Page 2
BPS10P7 ;OAK/ELZ - BPS*1*7 PRE/POST INSTALL ROUTINE ;6/9/08 11:02
+1 ;;1.0;E CLAIMS MGMT ENGINE;**7**;JUN 2004;Build 46
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
PRE ; pre-install of BPS*1*7
+1 ;
+2 ; delete the following files (leaving the data), the actual
+3 ; install of BPS*1*7 will re-install the updated files.
+4 ; 9002313.91 -- BPS NCPDP FIELD DEFS
+5 ; 9002313.92 -- BPS NCPDP FORMATS
+6 ; 9002313.93 -- BPS NCPDP REJECT CODES ** REMOVE DATA **
+7 ; 9002313.59 -- BPS TRANSACTION
+8 ; 9002313.02 -- BPS CLAIMS
+9 ; 9002313.03 -- BPS RESPONSES
+10 ; 9002313.56 -- BPS PHARMACIES
+11 ; 9002313.57 -- BPS LOG OF TRANSACTIONS
+12 ; 9002313.77 -- BPS REQUESTS
+13 ; 9002313.78 -- BPS INSURER DATA
+14 ; 9002313.99 -- BPS SETUP
+15 ;
+16 ; DBIA2172,DBIA10141,DBIA10014
+17 ;
+18 NEW BPSX,DIU,XPDIDTOT,BPSC,BPSP
+19 DO MES^XPDUTL(" Starting pre-install of BPS*1*7")
+20 SET XPDIDTOT=11
SET BPSC=0
+21 DO MES^XPDUTL(" - Deleting files to be restored during install.")
+22 FOR BPSX=9002313.91,9002313.92,9002313.93,9002313.59,9002313.02,9002313.03,9002313.56,9002313.57,9002313.77,9002313.78,9002313.99
Begin DoDot:1
+23 SET BPSP=$GET(DILOCKTM,3)
+24 DO MES^XPDUTL(" - Deleting file #"_BPSX_", Waiting for hardware "_BPSP_" seconds...")
+25 SET DIU=BPSX
+26 SET DIU(0)=$SELECT(BPSX=9002313.93:"DE",1:"E")
+27 DO EN^DIU2
+28 SET BPSC=BPSC+1
+29 DO UPDATE^XPDID(BPSC)
+30 ; need to pause so we don't hit the globals too hard
HANG BPSP
End DoDot:1
+31 DO MES^XPDUTL(" Finished pre-install of BPS*1*7")
+32 QUIT
+33 ;
POST ; post install for BPS*1*7
+1 ; - need to build the new AD cross reference on Status
+2 ; of the BPS LOG OF TRANSACTIONS so it matches the
+3 ; BPS TRANSACTION file.
+4 ;
+5 ; DBIA2172,DBIA10141
+6 ;
+7 NEW BPSX,BPSY,BPSC,XPDIDTOT,ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK,BPSTIME,DIU,BPSP
+8 DO MES^XPDUTL(" Starting post-install of BPS*1*7")
+9 DO MES^XPDUTL(" - Building AD xref on BPS LOG OF TRANSACTIONS file")
+10 SET XPDIDTOT=$PIECE($GET(^BPST(0)),"^",4)
+11 SET (BPSC,BPSX)=0
+12 FOR
SET BPSX=$ORDER(^BPST(BPSX))
if 'BPSX
QUIT
SET BPSC=BPSC+1
SET BPSY=$PIECE($GET(^BPST(BPSX,0)),"^",2)
if '(BPSC#500)
DO UPDATE^XPDID(BPSC)
IF $LENGTH(BPSY)
SET ^BPST("AD",$EXTRACT(BPSY,1,30),BPSX)=""
+13 ;
+14 ; need to clean up old fields from BPS Pharmacies 9002313.56
+15 DO MES^XPDUTL(" - Cleaning out old data from BPS PHARMACIES")
+16 SET BPSX=0
FOR
SET BPSX=$ORDER(^BPS(9002313.56,BPSX))
if 'BPSX
QUIT
KILL ^BPS(9002313.56,BPSX,"HOURS"),^("TCLOSE"),^("TOPEN")
+17 DO MES^XPDUTL(" - Done cleaning out old data from BPS PHARMACIES")
+18 ;
+19 ; Clean up the old field being removed with tasked job 9002313.0301,508Sales Tax Paid
+20 DO MES^XPDUTL(" - Queing task to clean up old data")
+21 SET ZTRTN="DQ^BPS10P7"
SET ZTDESC="Post Install BPS*1*7, Clean-up of Data"
+22 SET (BPSTIME,ZTDTH)=$$FMADD^XLFDT($$NOW^XLFDT,,,5)
SET ZTIO=""
+23 DO ^%ZTLOAD
+24 IF $GET(ZTSK)
Begin DoDot:1
+25 DO MES^XPDUTL(" - Task Queued, #"_ZTSK_" to run at "_$$FMTE^XLFDT(BPSTIME))
End DoDot:1
+26 IF '$TEST
DO MES^XPDUTL(" - ERROR: Task not queued!!!")
+27 ;
+28 ; populate new fields in setup file
+29 DO MES^XPDUTL(" - Setting up New Insurer Asleep fields in site param file")
+30 if $PIECE($GET(^BPS(9002313.99,1,0)),"^",5)=""
SET $PIECE(^(0),"^",5)=20
+31 if $PIECE($GET(^BPS(9002313.99,1,0)),"^",6)=""
SET $PIECE(^(0),"^",6)=10
+32 DO MES^XPDUTL(" - New Insurer Asleep fields set")
+33 ;
+34 ; delete the following obsolete files leaving no data
+35 ; 9002313.82103 BPS NCPDP FIELD 103
+36 ; 9002313.82305 BPS NCPDP FIELD 305
+37 ; 9002313.82306 BPS NCPDP FIELD 306
+38 ; 9002313.82307 BPS NCPDP FIELD 307
+39 ; 9002313.82308 BPS NCPDP FIELD 308
+40 ; 9002313.82309 BPS NCPDP FIELD 309
+41 ; 9002313.82406 BPS NCPDP FIELD 406
+42 ; 9002313.82408 BPS NCPDP FIELD 408
+43 ; 9002313.82416 BPS NCPDP FIELD 416
+44 ; 9002313.82419 BPS NCPDP FIELD 419
+45 ; 9002313.8242 BPS NCPDP FIELD 420
+46 ; 9002313.82423 BPS NCPDP FIELD 423
+47 ; 9002313.82425 BPS NCPDP FIELD 425
+48 ; 9002313.82429 BPS NCPDP FIELD 429
+49 ; 9002313.82432 BPS NCPDP FIELD 432
+50 ; 9002313.82436 BPS NCPDP FIELD 436
+51 ; 9002313.82439 BPS NCPDP FIELD 439
+52 ; 9002313.8244 BPS NCPDP FIELD 440
+53 ; 9002313.82441 BPS NCPDP FIELD 441
+54 ; 9002313.82461 BPS NCPDP FIELD 461
+55 ; 9002313.82501 BPS NCPDP FIELD 501
+56 ; 9002313.82522 BPS NCPDP FIELD 522
+57 ; 9002313.82528 BPS NCPDP FIELD 528
+58 ; 9002313.82529 BPS NCPDP FIELD 529
+59 ; 9002313.82532 BPS NCPDP FIELD 532
+60 ; 9002313.82533 BPS NCPDP FIELD 533
+61 ; 9002313.82535 BPS NCPDP FIELD 535
+62 ;
+63 ; DBIA2172,DBIA10141,DBIA10014
+64 ;
+65 DO MES^XPDUTL(" - Deleting obsolete files.")
+66 SET XPDIDTOT=27
SET BPSC=0
+67 FOR BPSY=1:1
SET BPSX=$PIECE($TEXT(DELFILE+BPSY),";",3)
if BPSX=""
QUIT
Begin DoDot:1
+68 SET BPSP=$GET(DILOCKTM,3)
+69 DO MES^XPDUTL(" - Deleting obsolete file #"_BPSX_", Waiting for hardware "_BPSP_" seconds...")
+70 SET DIU=BPSX
SET DIU(0)="EDT"
+71 DO EN^DIU2
+72 SET BPSC=BPSC+1
+73 DO UPDATE^XPDID(BPSC)
+74 ; need to pause so we don't hit the globals too hard
HANG BPSP
End DoDot:1
+75 ;
+76 DO MES^XPDUTL(" Finished post-install of BPS*1*7")
+77 QUIT
+78 ;
DQ ; taskman entry to clean up data
+1 NEW BPSX,BPSY,Y,%DT,X
+2 SET BPSX=0
FOR
SET BPSX=$ORDER(^BPSR(BPSX))
if 'BPSX
QUIT
SET BPSY=0
FOR
SET BPSY=$ORDER(^BPSR(BPSX,1000,BPSY))
if 'BPSY
QUIT
Begin DoDot:1
+3 IF $DATA(^BPSR(BPSX,1000,BPSY,500))
SET $PIECE(^(500),"^",8)=""
End DoDot:1
+4 ;
+5 ; reset *M Vendor field to be null if a date is not stored there
+6 IF $LENGTH($PIECE($GET(^BPS(9002313.99,1,0)),"^",4))
IF $EXTRACT($PIECE(^(0),"^",4),1,7)'?7N
SET $PIECE(^(0),"^",4)=""
+7 ;
+8 ; Cleaning up BPS Claims file, Date Reopened field (906)
+9 ; some data stored in there is in external format, like 8-31-2006@13:20:04
+10 SET BPSX=0
FOR
SET BPSX=$ORDER(^BPSC(BPSX))
if 'BPSX
QUIT
Begin DoDot:1
+11 SET BPSY=$PIECE($GET(^BPSC(BPSX,900)),"^",6)
+12 IF '$LENGTH(BPSY)
QUIT
+13 IF $EXTRACT(BPSY,1,7)?7N
QUIT
+14 SET %DT="PT"
SET X=$PIECE(BPSY,"@")
+15 DO ^%DT
+16 IF Y>0
SET $PIECE(^BPSC(BPSX,900),"^",6)=+(Y_$SELECT(BPSY["@":"."_$TRANSLATE($PIECE(BPSY,"@",2),":"),1:""))
End DoDot:1
+17 ;
+18 ; clean out the data for:
+19 ; ^BPSC(ien,400,"AC")
+20 ; $P(^BPSC(BPS(9002313.02),400,0),"^",3)
+21 SET BPSX=0
FOR
SET BPSX=$ORDER(^BPSC(BPSX))
if 'BPSX
QUIT
KILL ^BPSC(BPSX,400,"AC")
SET BPSY=0
FOR
SET BPSY=$ORDER(^BPSC(BPSX,400,BPSY))
if 'BPSY
QUIT
IF $LENGTH($GET(^BPSC(BPSX,400,BPSY,0)))
SET $PIECE(^(0),"^",3)=""
+22 ;
+23 QUIT
DELFILE ; list of files to go bye bye with their data
+1 ;;9002313.82103
+2 ;;9002313.82305
+3 ;;9002313.82306
+4 ;;9002313.82307
+5 ;;9002313.82308
+6 ;;9002313.82309
+7 ;;9002313.82406
+8 ;;9002313.82408
+9 ;;9002313.82416
+10 ;;9002313.82419
+11 ;;9002313.82423
+12 ;;9002313.82425
+13 ;;9002313.82429
+14 ;;9002313.82432
+15 ;;9002313.82436
+16 ;;9002313.8244
+17 ;;9002313.82441
+18 ;;9002313.82501
+19 ;;9002313.82522
+20 ;;9002313.82528
+21 ;;9002313.82529
+22 ;;9002313.82532
+23 ;;9002313.82533
+24 ;;9002313.82535
+25 ;;9002313.8242
+26 ;;9002313.82439
+27 ;;9002313.82461
+28 ;;
+29 ;
