XU8PE689 ;ISD/JCH - Patch XU*8*689 Environment Check Routine ;01/26/23 12:04
;;8.0;KERNEL;**689**;Jul 10, 1995;Build 113
;Per VA Directive 6402, this routine should not be modified.
;
ENV ; Environment Check
N XUHANDLE,XUTITLE,XMISTART,XMIEXP,XUPDBAC
S XUHANDLE="PSO70684-INSTALL"
S XUPDBAC=$$XUPDBAC()
S XMISTART=$P($G(^XTMP(XUHANDLE,0)),"^",2),XMIEXP=0
I XMISTART,($$FMDIFF^XLFDT($$DT^XLFDT,XMISTART)>7) S XMIEXP=1
S XUTITLE="REFRESH DEA MIGRATION"
L +^XTMP(XUHANDLE):0 I '$T D Q
. D BMES^XPDUTL("**************************** WARNING ***********************************")
. D BMES^XPDUTL(XUTITLE_" job is still running. Halting...")
. D BMES^XPDUTL(" The DEA Migration must run to completion before installing this patch. ")
. D BMES^XPDUTL(" >>>> Installation aborted <<<< ")
. D BMES^XPDUTL("************************************************************************")
. S XPDABORT=1 ; Do not install this transport global and KILL it from ^XTMP.
I $$PATCH^XPDUTL("XU*8.0*689") D Q ; Don't require DEA migration if previously installed
. L -^XTMP(XUHANDLE)
I '$$PROD^XUPROD D Q
. S ^XTMP(XUHANDLE,0)=$$FMADD^XLFDT($$NOW^XLFDT,90)_"^"_$$NOW^XLFDT_"^PSO DEA Migration"
. S ^XTMP(XUHANDLE,"COMPLETE")=$$NOW^XLFDT
. S ^XTMP(XUHANDLE,"STATUS")="Install Completed"
. L -^XTMP(XUHANDLE)
I XUPDBAC!'$D(^XTMP(XUHANDLE))!($G(^XTMP(XUHANDLE,"STATUS"))'="Install Completed")!$G(XMIEXP) D L -^XTMP(XUHANDLE) Q
. N MISCHDT,MISCH
. S MISCHDT=$P($G(^XTMP(XUHANDLE,0)),"^",2),MISCH=$S(((MISCHDT?7N.E)&(MISCHDT>$$NOW^XLFDT)):1,1:0)
. D BMES^XPDUTL("**************************** WARNING ***********************************")
. I MISCH D
.. D BMES^XPDUTL(" The DEA Migration is scheduled to run "_$$FMTE^XLFDT(MISCHDT))
. I 'MISCH D
.. I $G(XUPDBAC) K ^XTMP("PSO70684-INSTALL") ; Require another DEA migration
.. D BMES^XPDUTL(" The DEA Migration is outdated. Please run the DEA Migration using the ")
.. D BMES^XPDUTL(" DEA Migration Report [PSO DEA MIGRATION REPORT] option and entering ")
.. D BMES^XPDUTL(" 'YES' at the prompt 'Do you want to re-run the DEA Migration?' ")
. D BMES^XPDUTL(" The DEA Migration must run to completion before installing this patch. ")
. D BMES^XPDUTL(" >>>> Installation aborted <<<< ")
. D BMES^XPDUTL("************************************************************************")
. S XPDABORT=1 ; Do not install this transport global and KILL it from ^XTMP.
L -^XTMP(XUHANDLE)
Q
;
XUPDBAC() ; Update BAC file with new codes if necessary (CQ, MT, MY)
N XUBACUPD,XUBACMIS
S XUBACUPD=$$MISSBAC(.XUBACMIS)
I 'XUBACUPD Q 0
S BAC="" F S BAC=$O(XUBACMIS(BAC)) Q:BAC="" D
. N FDA,XUDEAERR
. S FDA(8991.8,"?+1,",.01)=BAC
. S FDA(8991.8,"?+1,",.02)=$E(BAC)
. S FDA(8991.8,"?+1,",.03)=$E(BAC,$L(BAC))
. S FDA(8991.8,"?+1,",2)=$$NOW^XLFDT
. D UPDATE^DIE("","FDA",,"XUDEAERR")
. I $G(XUDEAERR("DIERR")) S XUBACUPD=XUBACUPD-1 ; If not filed, don't count it
I XUBACUPD<1 Q 0 ; Nothing updated
Q XUBACUPD
;
MISSBAC(MISSING) ; New BACs (CQ,MT,MY) missing from file 8991.8?
N BAC K MISSING S MISSING=0
F BAC="CQ","MT","MY" D
. Q:$$FIND1^DIC(8991.8,"","X",BAC)
. S MISSING(BAC)="",MISSING=$G(MISSING)+1
Q $S($G(MISSING):1,1:0)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXU8PE689 3409 printed Nov 22, 2024@17:18:59 Page 2
XU8PE689 ;ISD/JCH - Patch XU*8*689 Environment Check Routine ;01/26/23 12:04
+1 ;;8.0;KERNEL;**689**;Jul 10, 1995;Build 113
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
ENV ; Environment Check
+1 NEW XUHANDLE,XUTITLE,XMISTART,XMIEXP,XUPDBAC
+2 SET XUHANDLE="PSO70684-INSTALL"
+3 SET XUPDBAC=$$XUPDBAC()
+4 SET XMISTART=$PIECE($GET(^XTMP(XUHANDLE,0)),"^",2)
SET XMIEXP=0
+5 IF XMISTART
IF ($$FMDIFF^XLFDT($$DT^XLFDT,XMISTART)>7)
SET XMIEXP=1
+6 SET XUTITLE="REFRESH DEA MIGRATION"
+7 LOCK +^XTMP(XUHANDLE):0
IF '$TEST
Begin DoDot:1
+8 DO BMES^XPDUTL("**************************** WARNING ***********************************")
+9 DO BMES^XPDUTL(XUTITLE_" job is still running. Halting...")
+10 DO BMES^XPDUTL(" The DEA Migration must run to completion before installing this patch. ")
+11 DO BMES^XPDUTL(" >>>> Installation aborted <<<< ")
+12 DO BMES^XPDUTL("************************************************************************")
+13 ; Do not install this transport global and KILL it from ^XTMP.
SET XPDABORT=1
End DoDot:1
QUIT
+14 ; Don't require DEA migration if previously installed
IF $$PATCH^XPDUTL("XU*8.0*689")
Begin DoDot:1
+15 LOCK -^XTMP(XUHANDLE)
End DoDot:1
QUIT
+16 IF '$$PROD^XUPROD
Begin DoDot:1
+17 SET ^XTMP(XUHANDLE,0)=$$FMADD^XLFDT($$NOW^XLFDT,90)_"^"_$$NOW^XLFDT_"^PSO DEA Migration"
+18 SET ^XTMP(XUHANDLE,"COMPLETE")=$$NOW^XLFDT
+19 SET ^XTMP(XUHANDLE,"STATUS")="Install Completed"
+20 LOCK -^XTMP(XUHANDLE)
End DoDot:1
QUIT
+21 IF XUPDBAC!'$DATA(^XTMP(XUHANDLE))!($GET(^XTMP(XUHANDLE,"STATUS"))'="Install Completed")!$GET(XMIEXP)
Begin DoDot:1
+22 NEW MISCHDT,MISCH
+23 SET MISCHDT=$PIECE($GET(^XTMP(XUHANDLE,0)),"^",2)
SET MISCH=$SELECT(((MISCHDT?7N.E)&(MISCHDT>$$NOW^XLFDT)):1,1:0)
+24 DO BMES^XPDUTL("**************************** WARNING ***********************************")
+25 IF MISCH
Begin DoDot:2
+26 DO BMES^XPDUTL(" The DEA Migration is scheduled to run "_$$FMTE^XLFDT(MISCHDT))
End DoDot:2
+27 IF 'MISCH
Begin DoDot:2
+28 ; Require another DEA migration
IF $GET(XUPDBAC)
KILL ^XTMP("PSO70684-INSTALL")
+29 DO BMES^XPDUTL(" The DEA Migration is outdated. Please run the DEA Migration using the ")
+30 DO BMES^XPDUTL(" DEA Migration Report [PSO DEA MIGRATION REPORT] option and entering ")
+31 DO BMES^XPDUTL(" 'YES' at the prompt 'Do you want to re-run the DEA Migration?' ")
End DoDot:2
+32 DO BMES^XPDUTL(" The DEA Migration must run to completion before installing this patch. ")
+33 DO BMES^XPDUTL(" >>>> Installation aborted <<<< ")
+34 DO BMES^XPDUTL("************************************************************************")
+35 ; Do not install this transport global and KILL it from ^XTMP.
SET XPDABORT=1
End DoDot:1
LOCK -^XTMP(XUHANDLE)
QUIT
+36 LOCK -^XTMP(XUHANDLE)
+37 QUIT
+38 ;
XUPDBAC() ; Update BAC file with new codes if necessary (CQ, MT, MY)
+1 NEW XUBACUPD,XUBACMIS
+2 SET XUBACUPD=$$MISSBAC(.XUBACMIS)
+3 IF 'XUBACUPD
QUIT 0
+4 SET BAC=""
FOR
SET BAC=$ORDER(XUBACMIS(BAC))
if BAC=""
QUIT
Begin DoDot:1
+5 NEW FDA,XUDEAERR
+6 SET FDA(8991.8,"?+1,",.01)=BAC
+7 SET FDA(8991.8,"?+1,",.02)=$EXTRACT(BAC)
+8 SET FDA(8991.8,"?+1,",.03)=$EXTRACT(BAC,$LENGTH(BAC))
+9 SET FDA(8991.8,"?+1,",2)=$$NOW^XLFDT
+10 DO UPDATE^DIE("","FDA",,"XUDEAERR")
+11 ; If not filed, don't count it
IF $GET(XUDEAERR("DIERR"))
SET XUBACUPD=XUBACUPD-1
End DoDot:1
+12 ; Nothing updated
IF XUBACUPD<1
QUIT 0
+13 QUIT XUBACUPD
+14 ;
MISSBAC(MISSING) ; New BACs (CQ,MT,MY) missing from file 8991.8?
+1 NEW BAC
KILL MISSING
SET MISSING=0
+2 FOR BAC="CQ","MT","MY"
Begin DoDot:1
+3 if $$FIND1^DIC(8991.8,"","X",BAC)
QUIT
+4 SET MISSING(BAC)=""
SET MISSING=$GET(MISSING)+1
End DoDot:1
+5 QUIT $SELECT($GET(MISSING):1,1:0)
