DG53653A ;ALB/TDM,CKN - Patch DG*5.3*653 Post-Install Utility Routine ; 10/24/06 11:39am
;;5.3;Registration;**653**;AUG 13, 1993;Build 2
Q
;
EN N DIE,DA,DR
D MOD386 ;Edit file 38.6 entries
D EP^DG53653U ;Add file 38.6 entries
D DELXREF ;Remove cross references
D HECMSG ;Send Message to HEC Legacy
Q
;
MOD386 ; Update entry in INCONSISTENT DATA ELEMENTS file (#38.6)
N ERR
F RULE=4,7,9,11,13,15,16,19,24,29,30,31,34,60,72,74,75,76,78,81,83,85,86 D
. D BMES^XPDUTL("Modifying entry #"_RULE_" in 38.6 file.")
. S DIE=38.6,DA=$$FIND1^DIC(DIE,"","X",RULE)
. I 'DA D MES^XPDUTL(" *** Entry not found! ***") Q
. S DR="6////1" D ^DIE
. D MES^XPDUTL(" *** Update Complete ***")
D BMES^XPDUTL("")
Q
;
DELXREF ;Delete x-ref and indexes
N ZINDX
D BMES^XPDUTL(">>> Deleting ADELBAI index from PATIENT File #2")
D DELIXN^DDMOD(2,"ADELBAI")
Q
HECMSG ; Send message to HEC Legacy that install is complete.
N SITE,STATN,PRODFLG,XMDUZ,XMSUB,XMY,XMTEXT,MSG
S SITE=$$SITE^VASITE,STATN=$P($G(SITE),U,3)
S PRODFLG=$$GET1^DIQ(869.3,"1,",.03,"I")="P"
S XMDUZ="EVC I1 Install"
S XMSUB=XMDUZ_" - "_STATN_" (DG*5.3*653)"
S:PRODFLG XMY("S.IVMB*2*860 MESSAGE@IVM.DOMAIN.EXT")=""
S:'PRODFLG XMY(DUZ)=""
S XMTEXT="MSG("
S $P(MSG(1),U)="IVMB*2*860"
S $P(MSG(1),U,2)=STATN
S $P(MSG(1),U,3)="DG*5.3*653 "_$$FMTE^XLFDT($$NOW^XLFDT(),"5D")
S $P(MSG(1),U,4)=PRODFLG
D ^XMD
D BMES^XPDUTL(" *** Install Message Sent to HEC Legacy ***")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53653A 1520 printed Sep 23, 2025@20:13:52 Page 2
DG53653A ;ALB/TDM,CKN - Patch DG*5.3*653 Post-Install Utility Routine ; 10/24/06 11:39am
+1 ;;5.3;Registration;**653**;AUG 13, 1993;Build 2
+2 QUIT
+3 ;
EN NEW DIE,DA,DR
+1 ;Edit file 38.6 entries
DO MOD386
+2 ;Add file 38.6 entries
DO EP^DG53653U
+3 ;Remove cross references
DO DELXREF
+4 ;Send Message to HEC Legacy
DO HECMSG
+5 QUIT
+6 ;
MOD386 ; Update entry in INCONSISTENT DATA ELEMENTS file (#38.6)
+1 NEW ERR
+2 FOR RULE=4,7,9,11,13,15,16,19,24,29,30,31,34,60,72,74,75,76,78,81,83,85,86
Begin DoDot:1
+3 DO BMES^XPDUTL("Modifying entry #"_RULE_" in 38.6 file.")
+4 SET DIE=38.6
SET DA=$$FIND1^DIC(DIE,"","X",RULE)
+5 IF 'DA
DO MES^XPDUTL(" *** Entry not found! ***")
QUIT
+6 SET DR="6////1"
DO ^DIE
+7 DO MES^XPDUTL(" *** Update Complete ***")
End DoDot:1
+8 DO BMES^XPDUTL("")
+9 QUIT
+10 ;
DELXREF ;Delete x-ref and indexes
+1 NEW ZINDX
+2 DO BMES^XPDUTL(">>> Deleting ADELBAI index from PATIENT File #2")
+3 DO DELIXN^DDMOD(2,"ADELBAI")
+4 QUIT
HECMSG ; Send message to HEC Legacy that install is complete.
+1 NEW SITE,STATN,PRODFLG,XMDUZ,XMSUB,XMY,XMTEXT,MSG
+2 SET SITE=$$SITE^VASITE
SET STATN=$PIECE($GET(SITE),U,3)
+3 SET PRODFLG=$$GET1^DIQ(869.3,"1,",.03,"I")="P"
+4 SET XMDUZ="EVC I1 Install"
+5 SET XMSUB=XMDUZ_" - "_STATN_" (DG*5.3*653)"
+6 if PRODFLG
SET XMY("S.IVMB*2*860 MESSAGE@IVM.DOMAIN.EXT")=""
+7 if 'PRODFLG
SET XMY(DUZ)=""
+8 SET XMTEXT="MSG("
+9 SET $PIECE(MSG(1),U)="IVMB*2*860"
+10 SET $PIECE(MSG(1),U,2)=STATN
+11 SET $PIECE(MSG(1),U,3)="DG*5.3*653 "_$$FMTE^XLFDT($$NOW^XLFDT(),"5D")
+12 SET $PIECE(MSG(1),U,4)=PRODFLG
+13 DO ^XMD
+14 DO BMES^XPDUTL(" *** Install Message Sent to HEC Legacy ***")
+15 QUIT
