XUMF4L0.m

XUMF4L0 ;OIFO-OAK/RAM - Load IMF ;02/21/02

 ;;8.0;KERNEL;**217**;Jul 10, 1995

 ;

 ; $$PARAM^HLCS2 call supported by IA #3552

 ;

MAIN ; -- main

 ;

 Q:$$SERVER^XUMFI()

 ;

 D V23

 ;

 I $$CNT<1000 D NEVER Q

 ;

 D BG

 ;

 Q

 ;

BG ; -- background job

 ;

 N ZTRTN,ZTDESC,ZTDTH,ZTIO

 ;

 S ZTRTN="EN^XUMF4L0"

 S ZTDESC="XUMF Institution file background cleanup"

 S ZTDTH=$$NOW^XLFDT

 S ZTIO=""

 ;

 D ^%ZTLOAD

 ;

 Q

 ;

EN ; -- entry point

 ;

 D UPDATE,LOCAL^XUMF4L2,NVS^XUMF4L2,EXIT Q

 ;

 Q

 ;

UPDATE ; -- get FACILITY TYPE, update, get INSTITUTION, update

 ;

 ; -- get FACILITY TYPE

 K ^TMP("XUMF ARRAY",$J)

 ;

 N PARAM,XUMFLAG,ERROR,TEST

 ;

 S (ERROR,XUMFLAG,TEST)=0

 ;

 I $P($$PARAM^HLCS2,U,3)="T" S TEST=1

 ;

 L +^TMP("XUMF ARRAY",$J):0 D:'$T

 .S ERROR="1^another process is using the Master File Server"

 ;

 I ERROR D EXIT Q

 ;

 D MFS0

 ;

 I ERROR D EXIT Q

 ;

 I '$D(^TMP("XUMF ARRAY",$J)) D  D EXIT Q

 .S ERROR="1^Connection to master file server failed!"

 ;

 ; -- update

 D FTCLEAN^XUMF4A I ERROR D EXIT Q

 ;

 ; -- get INSTITUTION

 K ^TMP("XUMF ARRAY",$J),^TMP("XUMF MFS",$J)

 ;

 D MFS1

 ;

 I ERROR D EXIT Q

 ;

 I '$D(^TMP("XUMF ARRAY",$J)) D  Q

 .S ERROR="1^Connection to master file server failed!"

 .D EXIT

 ;

 ; -- update

 D EN^XUMF4L1

 ;

 D EXIT

 ;

 Q

 ;

MFS0 ; -- get national facility type file from Master File Server

 ;

 S PARAM("LLNK")="XUMF MFR^XUMF "_$S('TEST:"FORUM",1:"TEST")

 S PARAM("PROTOCOL")=$O(^ORD(101,"B","XUMF MFQ",0))

 ;

 D MAIN^XUMFP(4.1,"ALL",7,.PARAM,.ERROR) Q:ERROR

 D MAIN^XUMFI(4.1,"ALL",7,.PARAM,.ERROR) Q:ERROR

 D MAIN^XUMFH

 ;

 Q

 ;

MFS1 ; -- get national facility type file from Master File Server

 ;

 S PARAM("LLNK")="XUMF MFR^XUMF "_$S('TEST:"FORUM",1:"TEST")

 S PARAM("PROTOCOL")=$O(^ORD(101,"B","XUMF MFQ",0))

 ;

 D MAIN^XUMFP(4,"ALL",7,.PARAM,.ERROR) Q:ERROR

 D MAIN^XUMFI(4,"ALL",7,.PARAM,.ERROR) Q:ERROR

 D MAIN^XUMFH

 ;

 Q

 ;

 ;

CNT() ; -- count station numbers in Institution file

 ;

 N STA,CNT

 ;

 S STA="" F  S STA=$O(^DIC(4,"D",STA)) Q:STA=""  S CNT=$G(CNT)+1

 ;

 Q CNT

 ;

EXIT ; -- cleanup and quit

 ;

 K ^TMP("XUMF ADD",$J),^TMP("XUMF MOD",$J),^TMP("XUMF DEL",$J)

 K ^TMP("XUMF ARRAY",$J),^TMP("XUMF MFS",$J),^TMP("DIERR",$J)

 ;

 L -^TMP("XUMF ARRAY",$J)

 ;

 S ZTREQ="@"

 ;

 Q

 ;

V23 ; -- stuff VISN 23

 ;

 N XUMF,IENS,IEN

 ;

 S XUMF=1

 ;

 S IEN=$O(^DIC(4.1,"B","VISN",0))

 S IENS=$S(IEN:IEN_",",1:"+1,")

 ;

 K FDA

 S FDA(4.1,IENS,.01)="VISN"

 S FDA(4.1,IENS,1)="VETERANS INTEGRATED SERVICE NETWORK"

 S FDA(4.1,IENS,3)="NATIONAL"

 D UPDATE^DIE("E","FDA")

 ;

 S IEN=$O(^DIC(4,"B","VISN 23",0))

 S IENS=$S(IEN:IEN_",",1:"+1,")

 ;

 K FDA

 S FDA(4,IENS,.01)="VISN 23"

 S FDA(4,IENS,11)="LOCAL"

 S FDA(4,IENS,13)="VISN"

 D UPDATE^DIE("E","FDA")

 ;

 Q

 ;

NEVER ; -- cleanup never performed - notify site and NVS

 ;

 N XMSUB,TEXT,XMY,XMDUZ,XMTEXT

 ;

 S TEXT(1)="A check of the INSTITUTION file (#4) indicates the IFR"

 S TEXT(2)="cleanup has NOT been performed."

 S TEXT(3)=""

 S TEXT(4)="The IFR cleanup is a required action.  Future initiatives"

 S TEXT(5)="are dependant on consistent and reliable Institution data"

 S TEXT(6)="at each site.  A copy of this message is being sent to NVS"

 S TEXT(7)="for tracking purposes."

 S TEXT(8)=""

 S TEXT(9)="If you require assistance performing the IFR cleanup,"

 S TEXT(10)="you may contact NVS and someone will contact you and"

 S TEXT(11)="help you with the IFR cleanup process.  To request"

 S TEXT(12)="assistance you may send a MailMan message to the"

 S TEXT(13)="G.XUMF INSTITUTION mail group on FORUM or log a NOIS."

 S TEXT(14)=""

 S TEXT(15)="Note: Running the IFR cleanup on LEGACY systems is"

 S TEXT(16)="OPTIONAL.  If this message refers to a legacy system"

 S TEXT(17)="please disregard this message."

 ;

 S XMSUB="IFR/cleanup/REQUIRED at "_$$SITE

 S XMDUZ=$S(DUZ:DUZ,1:.5),XMY(DUZ)=""

 S XMTEXT="TEXT("

 S XMY("G.XUMF INSTITUTION")=""

 S:$P($$PARAM^HLCS2,U,3)'="T" XMY("G.XUMF INSTITUTION@FORUM")=""

 D ^XMD

 ;

 Q

 ;

SITE() ; -- facility name and sta # string

 ;

 Q $P($G(^DIC(4,+DUZ(2),0)),U)_" Sta#: "_$P($G(^DIC(4,+DUZ(2),99)),U)

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---XUMF4L0   4218     printed  Mar 13, 2025@21:15:16                                                                                                                                                                                                     Page 2

XUMF4L0   ;OIFO-OAK/RAM - Load IMF ;02/21/02

 +1       ;;8.0;KERNEL;**217**;Jul 10, 1995

 +2       ;

 +3       ; $$PARAM^HLCS2 call supported by IA #3552

 +4       ;

MAIN      ; -- main

 +1       ;

 +2        if $$SERVER^XUMFI()

               QUIT 

 +3       ;

 +4        DO V23

 +5       ;

 +6        IF $$CNT<1000

               DO NEVER

               QUIT 

 +7       ;

 +8        DO BG

 +9       ;

 +10       QUIT 

 +11      ;

BG        ; -- background job

 +1       ;

 +2        NEW ZTRTN,ZTDESC,ZTDTH,ZTIO

 +3       ;

 +4        SET ZTRTN="EN^XUMF4L0"

 +5        SET ZTDESC="XUMF Institution file background cleanup"

 +6        SET ZTDTH=$$NOW^XLFDT

 +7        SET ZTIO=""

 +8       ;

 +9        DO ^%ZTLOAD

 +10      ;

 +11       QUIT 

 +12      ;

EN        ; -- entry point

 +1       ;

 +2        DO UPDATE

           DO LOCAL^XUMF4L2

           DO NVS^XUMF4L2

           DO EXIT

           QUIT 

 +3       ;

 +4        QUIT 

 +5       ;

UPDATE    ; -- get FACILITY TYPE, update, get INSTITUTION, update

 +1       ;

 +2       ; -- get FACILITY TYPE

 +3        KILL ^TMP("XUMF ARRAY",$JOB)

 +4       ;

 +5        NEW PARAM,XUMFLAG,ERROR,TEST

 +6       ;

 +7        SET (ERROR,XUMFLAG,TEST)=0

 +8       ;

 +9        IF $PIECE($$PARAM^HLCS2,U,3)="T"

               SET TEST=1

 +10      ;

 +11       LOCK +^TMP("XUMF ARRAY",$JOB):0

           if '$TEST

               Begin DoDot:1

 +12               SET ERROR="1^another process is using the Master File Server"

               End DoDot:1

 +13      ;

 +14       IF ERROR

               DO EXIT

               QUIT 

 +15      ;

 +16       DO MFS0

 +17      ;

 +18       IF ERROR

               DO EXIT

               QUIT 

 +19      ;

 +20       IF '$DATA(^TMP("XUMF ARRAY",$JOB))

               Begin DoDot:1

 +21               SET ERROR="1^Connection to master file server failed!"

               End DoDot:1

               DO EXIT

               QUIT 

 +22      ;

 +23      ; -- update

 +24       DO FTCLEAN^XUMF4A

           IF ERROR

               DO EXIT

               QUIT 

 +25      ;

 +26      ; -- get INSTITUTION

 +27       KILL ^TMP("XUMF ARRAY",$JOB),^TMP("XUMF MFS",$JOB)

 +28      ;

 +29       DO MFS1

 +30      ;

 +31       IF ERROR

               DO EXIT

               QUIT 

 +32      ;

 +33       IF '$DATA(^TMP("XUMF ARRAY",$JOB))

               Begin DoDot:1

 +34               SET ERROR="1^Connection to master file server failed!"

 +35               DO EXIT

               End DoDot:1

               QUIT 

 +36      ;

 +37      ; -- update

 +38       DO EN^XUMF4L1

 +39      ;

 +40       DO EXIT

 +41      ;

 +42       QUIT 

 +43      ;

MFS0      ; -- get national facility type file from Master File Server

 +1       ;

 +2        SET PARAM("LLNK")="XUMF MFR^XUMF "_$SELECT('TEST:"FORUM",1:"TEST")

 +3        SET PARAM("PROTOCOL")=$ORDER(^ORD(101,"B","XUMF MFQ",0))

 +4       ;

 +5        DO MAIN^XUMFP(4.1,"ALL",7,.PARAM,.ERROR)

           if ERROR

               QUIT 

 +6        DO MAIN^XUMFI(4.1,"ALL",7,.PARAM,.ERROR)

           if ERROR

               QUIT 

 +7        DO MAIN^XUMFH

 +8       ;

 +9        QUIT 

 +10      ;

MFS1      ; -- get national facility type file from Master File Server

 +1       ;

 +2        SET PARAM("LLNK")="XUMF MFR^XUMF "_$SELECT('TEST:"FORUM",1:"TEST")

 +3        SET PARAM("PROTOCOL")=$ORDER(^ORD(101,"B","XUMF MFQ",0))

 +4       ;

 +5        DO MAIN^XUMFP(4,"ALL",7,.PARAM,.ERROR)

           if ERROR

               QUIT 

 +6        DO MAIN^XUMFI(4,"ALL",7,.PARAM,.ERROR)

           if ERROR

               QUIT 

 +7        DO MAIN^XUMFH

 +8       ;

 +9        QUIT 

 +10      ;

 +11      ;

CNT()     ; -- count station numbers in Institution file

 +1       ;

 +2        NEW STA,CNT

 +3       ;

 +4        SET STA=""

           FOR 

               SET STA=$ORDER(^DIC(4,"D",STA))

               if STA=""

                   QUIT 

               SET CNT=$GET(CNT)+1

 +5       ;

 +6        QUIT CNT

 +7       ;

EXIT      ; -- cleanup and quit

 +1       ;

 +2        KILL ^TMP("XUMF ADD",$JOB),^TMP("XUMF MOD",$JOB),^TMP("XUMF DEL",$JOB)

 +3        KILL ^TMP("XUMF ARRAY",$JOB),^TMP("XUMF MFS",$JOB),^TMP("DIERR",$JOB)

 +4       ;

 +5        LOCK -^TMP("XUMF ARRAY",$JOB)

 +6       ;

 +7        SET ZTREQ="@"

 +8       ;

 +9        QUIT 

 +10      ;

V23       ; -- stuff VISN 23

 +1       ;

 +2        NEW XUMF,IENS,IEN

 +3       ;

 +4        SET XUMF=1

 +5       ;

 +6        SET IEN=$ORDER(^DIC(4.1,"B","VISN",0))

 +7        SET IENS=$SELECT(IEN:IEN_",",1:"+1,")

 +8       ;

 +9        KILL FDA

 +10       SET FDA(4.1,IENS,.01)="VISN"

 +11       SET FDA(4.1,IENS,1)="VETERANS INTEGRATED SERVICE NETWORK"

 +12       SET FDA(4.1,IENS,3)="NATIONAL"

 +13       DO UPDATE^DIE("E","FDA")

 +14      ;

 +15       SET IEN=$ORDER(^DIC(4,"B","VISN 23",0))

 +16       SET IENS=$SELECT(IEN:IEN_",",1:"+1,")

 +17      ;

 +18       KILL FDA

 +19       SET FDA(4,IENS,.01)="VISN 23"

 +20       SET FDA(4,IENS,11)="LOCAL"

 +21       SET FDA(4,IENS,13)="VISN"

 +22       DO UPDATE^DIE("E","FDA")

 +23      ;

 +24       QUIT 

 +25      ;

NEVER     ; -- cleanup never performed - notify site and NVS

 +1       ;

 +2        NEW XMSUB,TEXT,XMY,XMDUZ,XMTEXT

 +3       ;

 +4        SET TEXT(1)="A check of the INSTITUTION file (#4) indicates the IFR"

 +5        SET TEXT(2)="cleanup has NOT been performed."

 +6        SET TEXT(3)=""

 +7        SET TEXT(4)="The IFR cleanup is a required action.  Future initiatives"

 +8        SET TEXT(5)="are dependant on consistent and reliable Institution data"

 +9        SET TEXT(6)="at each site.  A copy of this message is being sent to NVS"

 +10       SET TEXT(7)="for tracking purposes."

 +11       SET TEXT(8)=""

 +12       SET TEXT(9)="If you require assistance performing the IFR cleanup,"

 +13       SET TEXT(10)="you may contact NVS and someone will contact you and"

 +14       SET TEXT(11)="help you with the IFR cleanup process.  To request"

 +15       SET TEXT(12)="assistance you may send a MailMan message to the"

 +16       SET TEXT(13)="G.XUMF INSTITUTION mail group on FORUM or log a NOIS."

 +17       SET TEXT(14)=""

 +18       SET TEXT(15)="Note: Running the IFR cleanup on LEGACY systems is"

 +19       SET TEXT(16)="OPTIONAL.  If this message refers to a legacy system"

 +20       SET TEXT(17)="please disregard this message."

 +21      ;

 +22       SET XMSUB="IFR/cleanup/REQUIRED at "_$$SITE

 +23       SET XMDUZ=$SELECT(DUZ:DUZ,1:.5)

           SET XMY(DUZ)=""

 +24       SET XMTEXT="TEXT("

 +25       SET XMY("G.XUMF INSTITUTION")=""

 +26       if $PIECE($$PARAM^HLCS2,U,3)'="T"

               SET XMY("G.XUMF INSTITUTION@FORUM")=""

 +27       DO ^XMD

 +28      ;

 +29       QUIT 

 +30      ;

SITE()    ; -- facility name and sta # string

 +1       ;

 +2        QUIT $PIECE($GET(^DIC(4,+DUZ(2),0)),U)_" Sta#: "_$PIECE($GET(^DIC(4,+DUZ(2),99)),U)

 +3       ;