DG837PST ;BIR/PTD/ELZ/CKN-PATCH DG*5.3*837 POST INSTALLATION ROUTINE ; 1/3/12 1:30pm
;;5.3;Registration;**837**;Aug 13, 1993;Build 5
;
D IDFLD,ALIAS
D EP ;MVI_791 - Conversion process for TF file #391.91
Q
;
IDFLD ;MVI_876 (ptd) - Turn on Audit for the new DoD identification fields
;Do not run module if patch DG*5.3*837 previously installed.
I $$PATCH^XPDUTL("DG*5.3*837") Q
N FLDNUM
S FLDNUM=991.08 D TURNON^DIAUTL(2,FLDNUM)
D BMES^XPDUTL("The TEMPORARY ID NUMBER #"_FLDNUM_" field in the PATIENT file is set to AUDIT.")
S FLDNUM=991.09 D TURNON^DIAUTL(2,FLDNUM)
D BMES^XPDUTL("The FOREIGN ID NUMBER #"_FLDNUM_" field in the PATIENT file is set to AUDIT.")
Q
;
ALIAS ;MVI_805 (elz) - clean up Alias multiple in patient (#2) file.
;Do not run module if patch DG*5.3*837 previously installed.
I $$PATCH^XPDUTL("DG*5.3*837") Q
AGAIN ;Line tag to be called if module needs to be run again.
N DGNM,DFN,DGX,FDA,DGERR
D BMES^XPDUTL("Cleaning up duplicate Alias PATIENT file entries.")
K ^TMP("DG837PST",$J)
S DGNM="" F S DGNM=$O(^DPT("B",DGNM)) Q:DGNM="" S DFN=0 F S DFN=$O(^DPT("B",DGNM,DFN)) Q:'DFN I $O(^DPT("B",DGNM,DFN,0)) S ^TMP("DG837PST",$J,DFN)=""
S DFN=0 F S DFN=$O(^TMP("DG837PST",$J,DFN)) Q:'DFN D
. N DGALIAS
. S DGX=0 F S DGX=$O(^DPT(DFN,.01,DGX)) Q:'DGX D
.. S DGALIAS=$P($G(^DPT(DFN,.01,DGX,0)),"^",1,2) Q:DGALIAS=""
.. I '$D(DGALIAS(DGALIAS)) S DGALIAS(DGALIAS)="" Q
.. S FDA(2.01,DGX_","_DFN_",",.01)="@" D FILE^DIE("E","FDA","DGERR")
.. I $G(DGERR("DIERR",1,"TEXT",1))'="" D BMES^XPDUTL("ERROR: DFN"_DFN_" "_DGERR("DIERR",1,"TEXT",1))
D BMES^XPDUTL("Done cleaning up Duplicate Alias entries.")
K ^TMP("DG837PST",$J)
Q
;
EP ;MVI_791 (ckn) - Post install routine entry point for TF conversion process
N RESTART
S RESTART=0
I '$$CHECK() Q
D QUE
Q
QUE ;Queue the process
N ZTRTN,ZTDESC,ZTSK
S ZTRTN="PROCESS^DG837PST",ZTDESC="DG837PST - CONVERSION PROCESS TREATING FACILITY FILE"
S ZTIO="",ZTDTH=$H
D ^%ZTLOAD
I $D(ZTSK) S ^XTMP("DG837PST","@@","TASK")=ZTSK
S:$D(ZTQUEUED) ZTREQ="@"
Q
CHECK() ;Initial check
D BMES^XPDUTL("Post install conversion process to update TREATING FACILITY FILE #391.91")
N INITSTRT
I '$D(^XTMP("DG837PST","@@","PROCESS INIT STARTED")) S (^XTMP("DG837PST","@@","PROCESS INIT STARTED"),^XTMP("DG837PST","@@","PROCESS STARTED"))=$$NOW^XLFDT() D BMES^XPDUTL("<<Process Started>>") Q 1
I $D(^XTMP("DG837PST","@@","PROCESS COMPLETED")) D BMES^XPDUTL("<<Process is already completed>>")
I $D(^XTMP("DG837PST","@@","PROCESS STOPPED")) D BMES^XPDUTL("<<Process stopped in previous run>>")
I 'RESTART Q 0
W ! S DIR(0)="Y",DIR("B")="Yes",DIR("A")="Do you want to complete the rerun" D ^DIR K DIR
I '+Y Q 0
S INITSTRT=$G(^XTMP("DG837PST","@@","PROCESS INIT STARTED"))
K ^XTMP("DG837PST","@@")
S ^XTMP("DG837PST","@@","PROCESS INIT STARTED")=$G(INITSTRT)
S ^XTMP("DG837PST","@@","PROCESS STARTED")=$$NOW^XLFDT()
D BMES^XPDUTL("<<Process Started>>") Q 1
PROCESS ;
N TFIEN,MIEN,QFLG,X,X1,X2,FDA,FDAIEN,SNODE0,NODE0
S QFLG=0
S X1=DT,X2=60 D C^%DTC
S ^XTMP("DG837PST","@@","TOTAL RECORDS")=$P($G(^DGCN(391.91,0)),"^",4)
S ^XTMP("DG837PST",0)=X_"^"_$$DT^XLFDT_"^DG*5.3*837 - POST INSTALL - CONVERSION PROCESS IN TREATING FACILITY FILE"
S TFIEN=+$G(^XTMP("DG837PST","@@","CURRENT IEN"))
F S TFIEN=$O(^DGCN(391.91,TFIEN)) Q:+TFIEN=0!(QFLG) D
. I $D(^XTMP("DG837PST","@@","FORCE STOP")) S QFLG=1 Q
. S ^XTMP("DG837PST","@@","CURRENT IEN")=TFIEN
. I $O(^DGCN(391.91,TFIEN,1,0))="" D
. . N TMPST
. . S TMPST=$P($G(^DGCN(391.91,TFIEN,0)),"^",2)
. . I $E($$STA^XUAF4(TMPST),1,4)="200N" D Q
. . . N FDA
. . . I $P($G(^DGCN(391.91,TFIEN,2)),"^")'="" S FDA(1,391.91,+TFIEN_",",10)=$P($G(^DGCN(391.91,TFIEN,2)),"^")
. . . I $P($G(^DGCN(391.91,TFIEN,0)),"^",9)="" S FDA(1,391.91,+TFIEN_",",.09)="NI"
. . . D FILE^DIE("K","FDA(1)","ERR")
. . . K FDA
. . I ($E($$STA^XUAF4(TMPST),1,4)'="200N")&(($$STA^XUAF4(TMPST)=200)!($$GET1^DIQ(4,TMPST_",",13)="OTHER")!($$GET1^DIQ(4,TMPST_",",13)="VAMC")) D
. . . N FDA
. . . S FDA(1,391.91,+TFIEN_",",.09)="PI",FDA(1,391.91,+TFIEN_",",10)="USVHA"
. . . D FILE^DIE("K","FDA(1)","ERR")
. . . K FDA
. I $D(^DGCN(391.91,TFIEN,1)) D
. . S MIEN=0 S MIEN=$O(^DGCN(391.91,TFIEN,1,MIEN)) Q:+MIEN=0
. . S SNODE0=$G(^DGCN(391.91,TFIEN,1,MIEN,0))
. . S FDA(1,391.91,+TFIEN_",",11)=$P(SNODE0,"^") ;Source ID
. . S FDA(1,391.91,+TFIEN_",",12)=$P(SNODE0,"^",2) ;Identifier Status
. . D FILE^DIE("K","FDA(1)","ERR")
. . K FDA
. . I $O(^DGCN(391.91,TFIEN,1,MIEN))="" Q ;No more entries in multiple file
. . ; For rest of the entries in multiple file, create new record.
. . S NODE0=$G(^DGCN(391.91,TFIEN,0)),TMPST=$P(NODE0,"^",2)
. . S FDA(1,391.91,"+1,",.01)=$P($G(NODE0),"^",1)
. . S FDA(1,391.91,"+1,",.02)=$P($G(NODE0),"^",2)
. . S FDA(1,391.91,"+1,",.03)=$P($G(NODE0),"^",3)
. . S FDA(1,391.91,"+1,",.07)=$P($G(NODE0),"^",7)
. . S FDA(1,391.91,"+1,",.08)=$P($G(NODE0),"^",8)
. . S FDA(1,391.91,"+1,",.09)=$P($G(NODE0),"^",9)
. . I $E($$STA^XUAF4(TMPST),1,4)="200N" S FDA(1,391.91,"+1,",10)="",FDA(1,391.91,"+1,",.09)="NI"
. . I ($E($$STA^XUAF4(TMPST),1,4)'="200N")&(($$STA^XUAF4(TMPST)=200)!($$GET1^DIQ(4,TMPST_",",13)="OTHER")!($$GET1^DIQ(4,TMPST_",",13)="VAMC")) D
. . . S FDA(1,391.91,"+1,",.09)="PI",FDA(1,391.91,"+1,",10)="USVHA"
. . F S MIEN=$O(^DGCN(391.91,TFIEN,1,MIEN)) Q:+MIEN=0 D
. . . N FDAIEN S SNODE0=$G(^DGCN(391.91,TFIEN,1,MIEN,0))
. . . S FDA(1,391.91,"+1,",11)=$P($G(SNODE0),"^")
. . . S FDA(1,391.91,"+1,",12)=$P($G(SNODE0),"^",2)
. . . D UPDATE^DIE("S","FDA(1)","FDAIEN","ERR")
. . K FDA,FDAIEN
. S DIK="^DGCN(391.91,"_TFIEN_",1,",DA(1)=TFIEN
. S DA=0 F S DA=$O(^DGCN(391.91,TFIEN,1,DA)) Q:+DA=0 D ^DIK
. K DIK,DA
I QFLG S ^XTMP("DG837PST","@@","PROCESS STOPPED")=$$NOW^XLFDT() Q
S ^XTMP("DG837PST","@@","PROCESS COMPLETED")=$$NOW^XLFDT()
D MAIL
D DELDD ;Delete old fields once conversion process is done.
Q
MAIL ;Send Mail message
N PATCH,SITE,STATN,SITENM,MSG,XMDUZ,XMSUB,XMTEXT,XMY
S PATCH="DG*5.3*837"
S SITE=$$SITE^VASITE,STATN=$P($G(SITE),"^",3),SITENM=$P($G(SITE),"^",2)
S (XMY(DUZ),XMY(.5))="",XMY("CHINTAN.NAIK@DOMAIN.EXT")="",XMY("PAULETTE.DAVIS@DOMAIN.EXT")="",XMY("CHRISTINE.CHESNEY@DOMAIN.EXT")=""
S XMDUZ="MPI PATCH MONITOR",XMTEXT="MSG("
S XMSUB="DG*5.3*837 - Conversion process completed for site: "_STATN
S MSG(1)="The DG*5.3*837 post-init conversion process for TREATING FACILITY LIST (#391.91) file completed successfully."
S MSG(1.5)=""
S MSG(2)="Patch: "_PATCH
S MSG(3)="Task: "_$G(^XTMP("DG837PST","@@","TASK"))
S MSG(4)=""
S MSG(5)="Site Station #: "_STATN
S MSG(6)="Site Name: "_SITENM
S MSG(7)=""
S MSG(8)="Process Started at: "_$$FMTE^XLFDT($G(^XTMP("DG837PST","@@","PROCESS INIT STARTED")),"5P")
S MSG(8.5)=""
S MSG(9)="Process Completed at: "_$$FMTE^XLFDT($G(^XTMP("DG837PST","@@","PROCESS COMPLETED")),"5P")
S MSG(9.5)=""
S MSG(10)="Total Records in TREATING FACILITY LIST file (#391.91): "_^XTMP("DG837PST","@@","TOTAL RECORDS")
D ^XMD
Q
STRTAGN ;Re run of process in case of process is stopped
N RESTART
S RESTART=1
I '$$CHECK() Q
D QUE
Q
STOP ;Stop the process
W !!,"Stop process"
I '$D(^XTMP("DG837PST","@@","PROCESS STARTED")) W !,"<< No process is currently running >>" Q
I $D(^XTMP("DG837PST","@@","PROCESS COMPLETED")) W !,"<< Process already completed >>" Q
W !!,"Process is currently running."
W ! S DIR(0)="Y",DIR("B")="Yes",DIR("A")="Do you want to stop this process" D ^DIR K DIR
I +Y S ^XTMP("DG837PST","@@","FORCE STOP")=1
K DIR,Y
Q
;
DELDD ;MVI_791 (ptd) - Delete obsolete fields in #391.91 file and 391.92.
;This code should only be called after the conversion
;routine has moved the data from the obsolete fields
;to the new fields and deleted the data.
;
;Delete these fields from the TREATING FACILITY LIST #391.91 file:
; ASSIGNING AUTHORITY (#1) field, and
; SOURCE ID (#20) subfile 391.9101, which includes the
; SOURCE ID(#.01) and IDENTIFIER STATUS (#1) fields
;and delete the obsolete VAFC ASSIGNING AUTHORITY (#391.92) file.
;
;
D BMES^XPDUTL("Removing obsolete fields from the TREATING FACILITY LIST #391.91 file.")
;Delete DD definition for the ASSIGNING AUTHORITY (#1)
;field in the TREATING FACILITY LIST (#391.91) file.
;
S DIK="^DD(391.91,",DA=1,DA(1)=391.91
D ^DIK
K DA,DIK
D BMES^XPDUTL(">>> Obsolete ASSIGNING AUTHORITY #1 field has been deleted.")
;
;Remove SOURCE ID (#391.9101) sub-file in the TREATING FACILITY
;LIST (#391.91) file. S=subfile.
I $$VFILE^DILFD(391.9101)=1 D ;If sub-file exists, delete it.
.S DIU=391.9101,DIU(0)="S"
.D EN^DIU2
.K DIU
.D BMES^XPDUTL(">>> Obsolete SOURCE ID #391.9101 sub-file has been deleted.")
;
;Remove VAFC ASSIGNING AUTHORITY (#391.92) file; D=delete data
I $$VFILE^DILFD(391.92)=1 D ;If file exists, delete it.
.D BMES^XPDUTL("Removing obsolete VAFC ASSIGNING AUTHORITY #391.92 file.")
.S DIU="^DGCN(391.92,",DIU(0)="D"
.D EN^DIU2
.K DIU
.D BMES^XPDUTL(">>> Obsolete VAFC ASSIGNING AUTHORITY #391.92 file has been deleted.")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG837PST 9201 printed Sep 23, 2025@20:16:39 Page 2
DG837PST ;BIR/PTD/ELZ/CKN-PATCH DG*5.3*837 POST INSTALLATION ROUTINE ; 1/3/12 1:30pm
+1 ;;5.3;Registration;**837**;Aug 13, 1993;Build 5
+2 ;
+3 DO IDFLD
DO ALIAS
+4 ;MVI_791 - Conversion process for TF file #391.91
DO EP
+5 QUIT
+6 ;
IDFLD ;MVI_876 (ptd) - Turn on Audit for the new DoD identification fields
+1 ;Do not run module if patch DG*5.3*837 previously installed.
+2 IF $$PATCH^XPDUTL("DG*5.3*837")
QUIT
+3 NEW FLDNUM
+4 SET FLDNUM=991.08
DO TURNON^DIAUTL(2,FLDNUM)
+5 DO BMES^XPDUTL("The TEMPORARY ID NUMBER #"_FLDNUM_" field in the PATIENT file is set to AUDIT.")
+6 SET FLDNUM=991.09
DO TURNON^DIAUTL(2,FLDNUM)
+7 DO BMES^XPDUTL("The FOREIGN ID NUMBER #"_FLDNUM_" field in the PATIENT file is set to AUDIT.")
+8 QUIT
+9 ;
ALIAS ;MVI_805 (elz) - clean up Alias multiple in patient (#2) file.
+1 ;Do not run module if patch DG*5.3*837 previously installed.
+2 IF $$PATCH^XPDUTL("DG*5.3*837")
QUIT
AGAIN ;Line tag to be called if module needs to be run again.
+1 NEW DGNM,DFN,DGX,FDA,DGERR
+2 DO BMES^XPDUTL("Cleaning up duplicate Alias PATIENT file entries.")
+3 KILL ^TMP("DG837PST",$JOB)
+4 SET DGNM=""
FOR
SET DGNM=$ORDER(^DPT("B",DGNM))
if DGNM=""
QUIT
SET DFN=0
FOR
SET DFN=$ORDER(^DPT("B",DGNM,DFN))
if 'DFN
QUIT
IF $ORDER(^DPT("B",DGNM,DFN,0))
SET ^TMP("DG837PST",$JOB,DFN)=""
+5 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("DG837PST",$JOB,DFN))
if 'DFN
QUIT
Begin DoDot:1
+6 NEW DGALIAS
+7 SET DGX=0
FOR
SET DGX=$ORDER(^DPT(DFN,.01,DGX))
if 'DGX
QUIT
Begin DoDot:2
+8 SET DGALIAS=$PIECE($GET(^DPT(DFN,.01,DGX,0)),"^",1,2)
if DGALIAS=""
QUIT
+9 IF '$DATA(DGALIAS(DGALIAS))
SET DGALIAS(DGALIAS)=""
QUIT
+10 SET FDA(2.01,DGX_","_DFN_",",.01)="@"
DO FILE^DIE("E","FDA","DGERR")
+11 IF $GET(DGERR("DIERR",1,"TEXT",1))'=""
DO BMES^XPDUTL("ERROR: DFN"_DFN_" "_DGERR("DIERR",1,"TEXT",1))
End DoDot:2
End DoDot:1
+12 DO BMES^XPDUTL("Done cleaning up Duplicate Alias entries.")
+13 KILL ^TMP("DG837PST",$JOB)
+14 QUIT
+15 ;
EP ;MVI_791 (ckn) - Post install routine entry point for TF conversion process
+1 NEW RESTART
+2 SET RESTART=0
+3 IF '$$CHECK()
QUIT
+4 DO QUE
+5 QUIT
QUE ;Queue the process
+1 NEW ZTRTN,ZTDESC,ZTSK
+2 SET ZTRTN="PROCESS^DG837PST"
SET ZTDESC="DG837PST - CONVERSION PROCESS TREATING FACILITY FILE"
+3 SET ZTIO=""
SET ZTDTH=$HOROLOG
+4 DO ^%ZTLOAD
+5 IF $DATA(ZTSK)
SET ^XTMP("DG837PST","@@","TASK")=ZTSK
+6 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+7 QUIT
CHECK() ;Initial check
+1 DO BMES^XPDUTL("Post install conversion process to update TREATING FACILITY FILE #391.91")
+2 NEW INITSTRT
+3 IF '$DATA(^XTMP("DG837PST","@@","PROCESS INIT STARTED"))
SET (^XTMP("DG837PST","@@","PROCESS INIT STARTED"),^XTMP("DG837PST","@@","PROCESS STARTED"))=$$NOW^XLFDT()
DO BMES^XPDUTL("<<Process Started>>")
QUIT 1
+4 IF $DATA(^XTMP("DG837PST","@@","PROCESS COMPLETED"))
DO BMES^XPDUTL("<<Process is already completed>>")
+5 IF $DATA(^XTMP("DG837PST","@@","PROCESS STOPPED"))
DO BMES^XPDUTL("<<Process stopped in previous run>>")
+6 IF 'RESTART
QUIT 0
+7 WRITE !
SET DIR(0)="Y"
SET DIR("B")="Yes"
SET DIR("A")="Do you want to complete the rerun"
DO ^DIR
KILL DIR
+8 IF '+Y
QUIT 0
+9 SET INITSTRT=$GET(^XTMP("DG837PST","@@","PROCESS INIT STARTED"))
+10 KILL ^XTMP("DG837PST","@@")
+11 SET ^XTMP("DG837PST","@@","PROCESS INIT STARTED")=$GET(INITSTRT)
+12 SET ^XTMP("DG837PST","@@","PROCESS STARTED")=$$NOW^XLFDT()
+13 DO BMES^XPDUTL("<<Process Started>>")
QUIT 1
PROCESS ;
+1 NEW TFIEN,MIEN,QFLG,X,X1,X2,FDA,FDAIEN,SNODE0,NODE0
+2 SET QFLG=0
+3 SET X1=DT
SET X2=60
DO C^%DTC
+4 SET ^XTMP("DG837PST","@@","TOTAL RECORDS")=$PIECE($GET(^DGCN(391.91,0)),"^",4)
+5 SET ^XTMP("DG837PST",0)=X_"^"_$$DT^XLFDT_"^DG*5.3*837 - POST INSTALL - CONVERSION PROCESS IN TREATING FACILITY FILE"
+6 SET TFIEN=+$GET(^XTMP("DG837PST","@@","CURRENT IEN"))
+7 FOR
SET TFIEN=$ORDER(^DGCN(391.91,TFIEN))
if +TFIEN=0!(QFLG)
QUIT
Begin DoDot:1
+8 IF $DATA(^XTMP("DG837PST","@@","FORCE STOP"))
SET QFLG=1
QUIT
+9 SET ^XTMP("DG837PST","@@","CURRENT IEN")=TFIEN
+10 IF $ORDER(^DGCN(391.91,TFIEN,1,0))=""
Begin DoDot:2
+11 NEW TMPST
+12 SET TMPST=$PIECE($GET(^DGCN(391.91,TFIEN,0)),"^",2)
+13 IF $EXTRACT($$STA^XUAF4(TMPST),1,4)="200N"
Begin DoDot:3
+14 NEW FDA
+15 IF $PIECE($GET(^DGCN(391.91,TFIEN,2)),"^")'=""
SET FDA(1,391.91,+TFIEN_",",10)=$PIECE($GET(^DGCN(391.91,TFIEN,2)),"^")
+16 IF $PIECE($GET(^DGCN(391.91,TFIEN,0)),"^",9)=""
SET FDA(1,391.91,+TFIEN_",",.09)="NI"
+17 DO FILE^DIE("K","FDA(1)","ERR")
+18 KILL FDA
End DoDot:3
QUIT
+19 IF ($EXTRACT($$STA^XUAF4(TMPST),1,4)'="200N")&(($$STA^XUAF4(TMPST)=200)!($$GET1^DIQ(4,TMPST_",",13)="OTHER")!($$GET1^DIQ(4,TMPST_",",13)="VAMC"))
Begin DoDot:3
+20 NEW FDA
+21 SET FDA(1,391.91,+TFIEN_",",.09)="PI"
SET FDA(1,391.91,+TFIEN_",",10)="USVHA"
+22 DO FILE^DIE("K","FDA(1)","ERR")
+23 KILL FDA
End DoDot:3
End DoDot:2
+24 IF $DATA(^DGCN(391.91,TFIEN,1))
Begin DoDot:2
+25 SET MIEN=0
SET MIEN=$ORDER(^DGCN(391.91,TFIEN,1,MIEN))
if +MIEN=0
QUIT
+26 SET SNODE0=$GET(^DGCN(391.91,TFIEN,1,MIEN,0))
+27 ;Source ID
SET FDA(1,391.91,+TFIEN_",",11)=$PIECE(SNODE0,"^")
+28 ;Identifier Status
SET FDA(1,391.91,+TFIEN_",",12)=$PIECE(SNODE0,"^",2)
+29 DO FILE^DIE("K","FDA(1)","ERR")
+30 KILL FDA
+31 ;No more entries in multiple file
IF $ORDER(^DGCN(391.91,TFIEN,1,MIEN))=""
QUIT
+32 ; For rest of the entries in multiple file, create new record.
+33 SET NODE0=$GET(^DGCN(391.91,TFIEN,0))
SET TMPST=$PIECE(NODE0,"^",2)
+34 SET FDA(1,391.91,"+1,",.01)=$PIECE($GET(NODE0),"^",1)
+35 SET FDA(1,391.91,"+1,",.02)=$PIECE($GET(NODE0),"^",2)
+36 SET FDA(1,391.91,"+1,",.03)=$PIECE($GET(NODE0),"^",3)
+37 SET FDA(1,391.91,"+1,",.07)=$PIECE($GET(NODE0),"^",7)
+38 SET FDA(1,391.91,"+1,",.08)=$PIECE($GET(NODE0),"^",8)
+39 SET FDA(1,391.91,"+1,",.09)=$PIECE($GET(NODE0),"^",9)
+40 IF $EXTRACT($$STA^XUAF4(TMPST),1,4)="200N"
SET FDA(1,391.91,"+1,",10)=""
SET FDA(1,391.91,"+1,",.09)="NI"
+41 IF ($EXTRACT($$STA^XUAF4(TMPST),1,4)'="200N")&(($$STA^XUAF4(TMPST)=200)!($$GET1^DIQ(4,TMPST_",",13)="OTHER")!($$GET1^DIQ(4,TMPST_",",13)="VAMC"))
Begin DoDot:3
+42 SET FDA(1,391.91,"+1,",.09)="PI"
SET FDA(1,391.91,"+1,",10)="USVHA"
End DoDot:3
+43 FOR
SET MIEN=$ORDER(^DGCN(391.91,TFIEN,1,MIEN))
if +MIEN=0
QUIT
Begin DoDot:3
+44 NEW FDAIEN
SET SNODE0=$GET(^DGCN(391.91,TFIEN,1,MIEN,0))
+45 SET FDA(1,391.91,"+1,",11)=$PIECE($GET(SNODE0),"^")
+46 SET FDA(1,391.91,"+1,",12)=$PIECE($GET(SNODE0),"^",2)
+47 DO UPDATE^DIE("S","FDA(1)","FDAIEN","ERR")
End DoDot:3
+48 KILL FDA,FDAIEN
End DoDot:2
+49 SET DIK="^DGCN(391.91,"_TFIEN_",1,"
SET DA(1)=TFIEN
+50 SET DA=0
FOR
SET DA=$ORDER(^DGCN(391.91,TFIEN,1,DA))
if +DA=0
QUIT
DO ^DIK
+51 KILL DIK,DA
End DoDot:1
+52 IF QFLG
SET ^XTMP("DG837PST","@@","PROCESS STOPPED")=$$NOW^XLFDT()
QUIT
+53 SET ^XTMP("DG837PST","@@","PROCESS COMPLETED")=$$NOW^XLFDT()
+54 DO MAIL
+55 ;Delete old fields once conversion process is done.
DO DELDD
+56 QUIT
MAIL ;Send Mail message
+1 NEW PATCH,SITE,STATN,SITENM,MSG,XMDUZ,XMSUB,XMTEXT,XMY
+2 SET PATCH="DG*5.3*837"
+3 SET SITE=$$SITE^VASITE
SET STATN=$PIECE($GET(SITE),"^",3)
SET SITENM=$PIECE($GET(SITE),"^",2)
+4 SET (XMY(DUZ),XMY(.5))=""
SET XMY("CHINTAN.NAIK@DOMAIN.EXT")=""
SET XMY("PAULETTE.DAVIS@DOMAIN.EXT")=""
SET XMY("CHRISTINE.CHESNEY@DOMAIN.EXT")=""
+5 SET XMDUZ="MPI PATCH MONITOR"
SET XMTEXT="MSG("
+6 SET XMSUB="DG*5.3*837 - Conversion process completed for site: "_STATN
+7 SET MSG(1)="The DG*5.3*837 post-init conversion process for TREATING FACILITY LIST (#391.91) file completed successfully."
+8 SET MSG(1.5)=""
+9 SET MSG(2)="Patch: "_PATCH
+10 SET MSG(3)="Task: "_$GET(^XTMP("DG837PST","@@","TASK"))
+11 SET MSG(4)=""
+12 SET MSG(5)="Site Station #: "_STATN
+13 SET MSG(6)="Site Name: "_SITENM
+14 SET MSG(7)=""
+15 SET MSG(8)="Process Started at: "_$$FMTE^XLFDT($GET(^XTMP("DG837PST","@@","PROCESS INIT STARTED")),"5P")
+16 SET MSG(8.5)=""
+17 SET MSG(9)="Process Completed at: "_$$FMTE^XLFDT($GET(^XTMP("DG837PST","@@","PROCESS COMPLETED")),"5P")
+18 SET MSG(9.5)=""
+19 SET MSG(10)="Total Records in TREATING FACILITY LIST file (#391.91): "_^XTMP("DG837PST","@@","TOTAL RECORDS")
+20 DO ^XMD
+21 QUIT
STRTAGN ;Re run of process in case of process is stopped
+1 NEW RESTART
+2 SET RESTART=1
+3 IF '$$CHECK()
QUIT
+4 DO QUE
+5 QUIT
STOP ;Stop the process
+1 WRITE !!,"Stop process"
+2 IF '$DATA(^XTMP("DG837PST","@@","PROCESS STARTED"))
WRITE !,"<< No process is currently running >>"
QUIT
+3 IF $DATA(^XTMP("DG837PST","@@","PROCESS COMPLETED"))
WRITE !,"<< Process already completed >>"
QUIT
+4 WRITE !!,"Process is currently running."
+5 WRITE !
SET DIR(0)="Y"
SET DIR("B")="Yes"
SET DIR("A")="Do you want to stop this process"
DO ^DIR
KILL DIR
+6 IF +Y
SET ^XTMP("DG837PST","@@","FORCE STOP")=1
+7 KILL DIR,Y
+8 QUIT
+9 ;
DELDD ;MVI_791 (ptd) - Delete obsolete fields in #391.91 file and 391.92.
+1 ;This code should only be called after the conversion
+2 ;routine has moved the data from the obsolete fields
+3 ;to the new fields and deleted the data.
+4 ;
+5 ;Delete these fields from the TREATING FACILITY LIST #391.91 file:
+6 ; ASSIGNING AUTHORITY (#1) field, and
+7 ; SOURCE ID (#20) subfile 391.9101, which includes the
+8 ; SOURCE ID(#.01) and IDENTIFIER STATUS (#1) fields
+9 ;and delete the obsolete VAFC ASSIGNING AUTHORITY (#391.92) file.
+10 ;
+11 ;
+12 DO BMES^XPDUTL("Removing obsolete fields from the TREATING FACILITY LIST #391.91 file.")
+13 ;Delete DD definition for the ASSIGNING AUTHORITY (#1)
+14 ;field in the TREATING FACILITY LIST (#391.91) file.
+15 ;
+16 SET DIK="^DD(391.91,"
SET DA=1
SET DA(1)=391.91
+17 DO ^DIK
+18 KILL DA,DIK
+19 DO BMES^XPDUTL(">>> Obsolete ASSIGNING AUTHORITY #1 field has been deleted.")
+20 ;
+21 ;Remove SOURCE ID (#391.9101) sub-file in the TREATING FACILITY
+22 ;LIST (#391.91) file. S=subfile.
+23 ;If sub-file exists, delete it.
IF $$VFILE^DILFD(391.9101)=1
Begin DoDot:1
+24 SET DIU=391.9101
SET DIU(0)="S"
+25 DO EN^DIU2
+26 KILL DIU
+27 DO BMES^XPDUTL(">>> Obsolete SOURCE ID #391.9101 sub-file has been deleted.")
End DoDot:1
+28 ;
+29 ;Remove VAFC ASSIGNING AUTHORITY (#391.92) file; D=delete data
+30 ;If file exists, delete it.
IF $$VFILE^DILFD(391.92)=1
Begin DoDot:1
+31 DO BMES^XPDUTL("Removing obsolete VAFC ASSIGNING AUTHORITY #391.92 file.")
+32 SET DIU="^DGCN(391.92,"
SET DIU(0)="D"
+33 DO EN^DIU2
+34 KILL DIU
+35 DO BMES^XPDUTL(">>> Obsolete VAFC ASSIGNING AUTHORITY #391.92 file has been deleted.")
End DoDot:1
+36 QUIT
+37 ;
