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 ---[H[J[2J[HXUMF4L0 4218 printed Oct 16, 2024@18:11:10 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 ;
