XUMF4L1 ;OIFO-OAK/RAM - Load IMF ;02/21/02
;;8.0;KERNEL;**217,261**;Jul 10, 1995
;
;
EN ; -- entry point
;
K ^TMP("XUMF ADD",$J),^TMP("XUMF MOD",$J),^TMP("XUMF DEL",$J)
;
D DSN,GOLD,ASSC,HIST
;
Q
;
DSN ; -- clean out local station numbers
;
N IEN,DIE,DR,DA,XUMF,DIK
;
S XUMF=1
;
S IEN=0
F S IEN=$O(^DIC(4,IEN)) Q:'IEN D
.S STA=$P($G(^DIC(4,+IEN,99)),U) Q:STA=""
.Q:$D(^TMP("XUMF ARRAY",$J,STA))
.S ^TMP("XUMF DEL",$J,STA,IEN)=""
.S DR="99///@",DIE=4,DA=IEN
.D
..N IEN D ^DIE
;
S STA="",IEN=0
F S STA=$O(^DIC(4,"D",STA)) Q:STA="" D
.F S IEN=$O(^DIC(4,"D",STA,IEN)) Q:'IEN D
..Q:$P($G(^DIC(4,+IEN,99)),U)=STA
..K ^DIC(4,"D",STA,IEN)
;
S DIK="^DIC(4,",DIK(1)="99^D" D ENALL^DIK
;
Q
;
GOLD ; -- add missing national data from standard table
;
N STA,NAME,FDA,ERROR,IEN,IENS,X,FLAG,CNT
N OLDNAME,OLDVANM,STATE,FACTYP,XUMF,AGENCY
;
S XUMF=1
;
S STA="",CNT=0
F S STA=$O(^TMP("XUMF ARRAY",$J,STA)) Q:STA="" D
.S X=^TMP("XUMF ARRAY",$J,STA)
.S IEN=$O(^DIC(4,"D",STA,0))
.S:'IEN ^TMP("XUMF ADD",$J,STA)=^TMP("XUMF ARRAY",$J,STA)
.D:IEN MOD
.S OLDNAME=$P($G(^DIC(4,+IEN,0)),U,1)
.S OLDVANM=$P($G(^DIC(4,+IEN,99)),U,3)
.S IENS=$S(IEN:IEN_",",1:"+1,")
.S NAME=$P(X,U,2)
.S FACTYP=$P(X,U,5)
.S VANAME=$P(X,U,6)
.S FLAG=$P(X,U,7)
.S STATE=$P(X,U,8)
.S AGENCY=$P(X,U,17)
.K FDA
.S FDA(4,IENS,.01)=NAME
.S FDA(4,IENS,.02)=STATE
.S FDA(4,IENS,99)=STA
.S FDA(4,IENS,11)="National"
.S FDA(4,IENS,13)=$P(FACTYP,"~")
.S FDA(4,IENS,100)=VANAME
.S FDA(4,IENS,101)=FLAG
.S FDA(4,IENS,95)=$P(AGENCY,"~")
.D
..N IEN,STA,NAME,VANAME,OLDNAME,OLDVANM
..D UPDATE^DIE("E","FDA",,"ERR")
.I 'IEN S IEN=$O(^DIC(4,"D",STA,0))
.Q:'IEN
.I OLDNAME="" Q
.I OLDNAME=NAME,VANAME=OLDVANM Q
.S IENS="?+"_DT_","_IEN_","
.K FDA
.S FDA(4.999,IENS,.01)=DT
.S:NAME'=OLDNAME FDA(4.999,IENS,.02)=OLDNAME
.S:VANAME'=OLDVANM FDA(4.999,IENS,.03)=OLDVANM
.D
..N STA
..D UPDATE^DIE("E","FDA")
..S CNT=CNT+1
;
Q
;
ASSC ; -- populate associations (parent facility and VISN)
;
N IEN,STA,VISN,PARENT,FDA,XUMF,CNT
;
S XUMF=1
;
S STA="",CNT=0
F S STA=$O(^TMP("XUMF ARRAY",$J,STA)) Q:STA="" D
.S IEN=$O(^DIC(4,"D",STA,0)) Q:'IEN
.S VISN=$P(^TMP("XUMF ARRAY",$J,STA),U,9)
.I VISN'="" D
..K FDA
..S IENS="?+1,"_IEN_","
..S FDA(4.014,IENS,.01)="VISN"
..S FDA(4.014,IENS,1)=$P(VISN,"~")
..D
...N IEN,STA
...D UPDATE^DIE("E","FDA")
.S PARENT=$P(^TMP("XUMF ARRAY",$J,STA),U,10)
.I PARENT'="" D
..K FDA
..S IENS="?+2,"_IEN_","
..S FDA(4.014,IENS,.01)="PARENT FACILITY"
..S FDA(4.014,IENS,1)=PARENT
..D
...N IEN,STA
...D UPDATE^DIE("E","FDA")
...S CNT=CNT+1
;
Q
;
HIST ; -- history
;
N IEN,STA,EFFDT,FDA,XUMF,CNT
;
S XUMF=1
;
S STA="",CNT=0
F S STA=$O(^TMP("XUMF ARRAY",$J,STA)) Q:STA="" D
.S IEN=$O(^DIC(4,"D",STA,0)) Q:'IEN
.S EFFDT=$P(^TMP("XUMF ARRAY",$J,STA),U,11)
.S EFFDT=$$FMDATE^HLFNC(+EFFDT)
.I EFFDT D
..S IENS="?+"_EFFDT_","_IEN_","
..K FDA
..S FDA(4.999,IENS,.01)=EFFDT
..S FDA(4.999,IENS,.06)=$P(^TMP("XUMF ARRAY",$J,STA),U,12)
..D
...N IEN,STA
...D UPDATE^DIE("E","FDA")
.S EFFDT=$P(^TMP("XUMF ARRAY",$J,STA),U,13)
.S EFFDT=$$FMDATE^HLFNC(+EFFDT)
.I EFFDT D
..S IENS="?+"_EFFDT_","_IEN_","
..K FDA
..S FDA(4.999,IENS,.01)=EFFDT
..S FDA(4.999,IENS,.05)=$P(^TMP("XUMF ARRAY",$J,STA),U,14)
..D
...N IEN,STA
...D UPDATE^DIE("E","FDA")
...S CNT=CNT+1
;
Q
;
CDSN() ; -- check for duplicate sta # (true=duplicates, false=none)
;
K ^TMP("XUMF TMP",$J)
;
N IEN,STA,CNT
;
S STA="",IEN=0
F S STA=$O(^DIC(4,"D",STA)) Q:STA="" D
.F S IEN=$O(^DIC(4,"D",STA,IEN)) Q:'IEN D
..S ^TMP("XUMF TMP",$J,STA,IEN)=$P(^DIC(4,IEN,0),U)
;
S STA="",(CNT,IEN)=0
F S STA=$O(^TMP("XUMF TMP",$J,STA)) Q:STA="" D
.Q:'$O(^TMP("XUMF TMP",$J,STA,+$O(^TMP("XUMF TMP",$J,STA,0))))
.F S IEN=$O(^TMP("XUMF TMP",$J,STA,IEN)) Q:'IEN D
..S CNT=CNT+1
;
K ^TMP("XUMF TMP",$J)
;
Q CNT
;
MOD ; if entry modified set TMP
;
N NAME,FACTYP,VANAME,STANUM,FLAG,PRNT,VISN,STATE,X,Y
;
Q:'$D(^DIC(4,+IEN,0))
;
S X=$P(^TMP("XUMF ARRAY",$J,STA),U,2,10)
;
S NAME=$P($G(^DIC(4,+IEN,0)),U)
S FACTYP=$P($G(^DIC(4.1,+$G(^DIC(4,+IEN,3)),0)),U)
S:FACTYP'="" FACTYP=FACTYP_"~FACILITY TYPE~VA"
S VANAME=$P($G(^DIC(4,+IEN,99)),U,3)
S STANUM=$P($G(^DIC(4,+IEN,99)),U)
S FLAG=$S(+$P($G(^DIC(4,+IEN,99)),U,4):"INACTIVE",1:"")
S PRNT=$P($G(^DIC(4,+$P($G(^DIC(4,+IEN,7,2,0)),U,2),99)),U)
S VISN=$P($G(^DIC(4,+$P($G(^DIC(4,+IEN,7,1,0)),U,2),0)),U)
S:VISN'="" VISN=VISN_"~VISN~VA"
S STATE=$P($G(^DIC(5,+$P($G(^DIC(4,+IEN,0)),U,2),0)),U)
;
S Y=NAME_U_STANUM_U_"National"_U_FACTYP_U_VANAME_U_FLAG_U_STATE
S Y=Y_U_VISN_U_PRNT
;
Q:Y=X
;
S ^TMP("XUMF MOD",$J,STA,"NEW")=X
S ^TMP("XUMF MOD",$J,STA,"OLD")=Y
;
Q
;
FTCLEAN ; -- add missing facility types
;
N NAME,FULL,FDA
;
S NAME=""
F S NAME=$O(^TMP("XUMF ARRAY",$J,NAME)) Q:NAME="" D
.S FULL=$P(^TMP("XUMF ARRAY",$J,NAME),U,3)
.D
..K FDA
..S FDA(4.1,"?+1,",.01)=NAME
..S FDA(4.1,"?+1,",1)=FULL
..S FDA(4.1,"?+1,",3)="N"
..N NAME
..D UPDATE^DIE("E","FDA",,"ERR")
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUMF4L1 5230 printed Sep 23, 2025@19:46:37 Page 2
XUMF4L1 ;OIFO-OAK/RAM - Load IMF ;02/21/02
+1 ;;8.0;KERNEL;**217,261**;Jul 10, 1995
+2 ;
+3 ;
EN ; -- entry point
+1 ;
+2 KILL ^TMP("XUMF ADD",$JOB),^TMP("XUMF MOD",$JOB),^TMP("XUMF DEL",$JOB)
+3 ;
+4 DO DSN
DO GOLD
DO ASSC
DO HIST
+5 ;
+6 QUIT
+7 ;
DSN ; -- clean out local station numbers
+1 ;
+2 NEW IEN,DIE,DR,DA,XUMF,DIK
+3 ;
+4 SET XUMF=1
+5 ;
+6 SET IEN=0
+7 FOR
SET IEN=$ORDER(^DIC(4,IEN))
if 'IEN
QUIT
Begin DoDot:1
+8 SET STA=$PIECE($GET(^DIC(4,+IEN,99)),U)
if STA=""
QUIT
+9 if $DATA(^TMP("XUMF ARRAY",$JOB,STA))
QUIT
+10 SET ^TMP("XUMF DEL",$JOB,STA,IEN)=""
+11 SET DR="99///@"
SET DIE=4
SET DA=IEN
+12 Begin DoDot:2
+13 NEW IEN
DO ^DIE
End DoDot:2
End DoDot:1
+14 ;
+15 SET STA=""
SET IEN=0
+16 FOR
SET STA=$ORDER(^DIC(4,"D",STA))
if STA=""
QUIT
Begin DoDot:1
+17 FOR
SET IEN=$ORDER(^DIC(4,"D",STA,IEN))
if 'IEN
QUIT
Begin DoDot:2
+18 if $PIECE($GET(^DIC(4,+IEN,99)),U)=STA
QUIT
+19 KILL ^DIC(4,"D",STA,IEN)
End DoDot:2
End DoDot:1
+20 ;
+21 SET DIK="^DIC(4,"
SET DIK(1)="99^D"
DO ENALL^DIK
+22 ;
+23 QUIT
+24 ;
GOLD ; -- add missing national data from standard table
+1 ;
+2 NEW STA,NAME,FDA,ERROR,IEN,IENS,X,FLAG,CNT
+3 NEW OLDNAME,OLDVANM,STATE,FACTYP,XUMF,AGENCY
+4 ;
+5 SET XUMF=1
+6 ;
+7 SET STA=""
SET CNT=0
+8 FOR
SET STA=$ORDER(^TMP("XUMF ARRAY",$JOB,STA))
if STA=""
QUIT
Begin DoDot:1
+9 SET X=^TMP("XUMF ARRAY",$JOB,STA)
+10 SET IEN=$ORDER(^DIC(4,"D",STA,0))
+11 if 'IEN
SET ^TMP("XUMF ADD",$JOB,STA)=^TMP("XUMF ARRAY",$JOB,STA)
+12 if IEN
DO MOD
+13 SET OLDNAME=$PIECE($GET(^DIC(4,+IEN,0)),U,1)
+14 SET OLDVANM=$PIECE($GET(^DIC(4,+IEN,99)),U,3)
+15 SET IENS=$SELECT(IEN:IEN_",",1:"+1,")
+16 SET NAME=$PIECE(X,U,2)
+17 SET FACTYP=$PIECE(X,U,5)
+18 SET VANAME=$PIECE(X,U,6)
+19 SET FLAG=$PIECE(X,U,7)
+20 SET STATE=$PIECE(X,U,8)
+21 SET AGENCY=$PIECE(X,U,17)
+22 KILL FDA
+23 SET FDA(4,IENS,.01)=NAME
+24 SET FDA(4,IENS,.02)=STATE
+25 SET FDA(4,IENS,99)=STA
+26 SET FDA(4,IENS,11)="National"
+27 SET FDA(4,IENS,13)=$PIECE(FACTYP,"~")
+28 SET FDA(4,IENS,100)=VANAME
+29 SET FDA(4,IENS,101)=FLAG
+30 SET FDA(4,IENS,95)=$PIECE(AGENCY,"~")
+31 Begin DoDot:2
+32 NEW IEN,STA,NAME,VANAME,OLDNAME,OLDVANM
+33 DO UPDATE^DIE("E","FDA",,"ERR")
End DoDot:2
+34 IF 'IEN
SET IEN=$ORDER(^DIC(4,"D",STA,0))
+35 if 'IEN
QUIT
+36 IF OLDNAME=""
QUIT
+37 IF OLDNAME=NAME
IF VANAME=OLDVANM
QUIT
+38 SET IENS="?+"_DT_","_IEN_","
+39 KILL FDA
+40 SET FDA(4.999,IENS,.01)=DT
+41 if NAME'=OLDNAME
SET FDA(4.999,IENS,.02)=OLDNAME
+42 if VANAME'=OLDVANM
SET FDA(4.999,IENS,.03)=OLDVANM
+43 Begin DoDot:2
+44 NEW STA
+45 DO UPDATE^DIE("E","FDA")
+46 SET CNT=CNT+1
End DoDot:2
End DoDot:1
+47 ;
+48 QUIT
+49 ;
ASSC ; -- populate associations (parent facility and VISN)
+1 ;
+2 NEW IEN,STA,VISN,PARENT,FDA,XUMF,CNT
+3 ;
+4 SET XUMF=1
+5 ;
+6 SET STA=""
SET CNT=0
+7 FOR
SET STA=$ORDER(^TMP("XUMF ARRAY",$JOB,STA))
if STA=""
QUIT
Begin DoDot:1
+8 SET IEN=$ORDER(^DIC(4,"D",STA,0))
if 'IEN
QUIT
+9 SET VISN=$PIECE(^TMP("XUMF ARRAY",$JOB,STA),U,9)
+10 IF VISN'=""
Begin DoDot:2
+11 KILL FDA
+12 SET IENS="?+1,"_IEN_","
+13 SET FDA(4.014,IENS,.01)="VISN"
+14 SET FDA(4.014,IENS,1)=$PIECE(VISN,"~")
+15 Begin DoDot:3
+16 NEW IEN,STA
+17 DO UPDATE^DIE("E","FDA")
End DoDot:3
End DoDot:2
+18 SET PARENT=$PIECE(^TMP("XUMF ARRAY",$JOB,STA),U,10)
+19 IF PARENT'=""
Begin DoDot:2
+20 KILL FDA
+21 SET IENS="?+2,"_IEN_","
+22 SET FDA(4.014,IENS,.01)="PARENT FACILITY"
+23 SET FDA(4.014,IENS,1)=PARENT
+24 Begin DoDot:3
+25 NEW IEN,STA
+26 DO UPDATE^DIE("E","FDA")
+27 SET CNT=CNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+28 ;
+29 QUIT
+30 ;
HIST ; -- history
+1 ;
+2 NEW IEN,STA,EFFDT,FDA,XUMF,CNT
+3 ;
+4 SET XUMF=1
+5 ;
+6 SET STA=""
SET CNT=0
+7 FOR
SET STA=$ORDER(^TMP("XUMF ARRAY",$JOB,STA))
if STA=""
QUIT
Begin DoDot:1
+8 SET IEN=$ORDER(^DIC(4,"D",STA,0))
if 'IEN
QUIT
+9 SET EFFDT=$PIECE(^TMP("XUMF ARRAY",$JOB,STA),U,11)
+10 SET EFFDT=$$FMDATE^HLFNC(+EFFDT)
+11 IF EFFDT
Begin DoDot:2
+12 SET IENS="?+"_EFFDT_","_IEN_","
+13 KILL FDA
+14 SET FDA(4.999,IENS,.01)=EFFDT
+15 SET FDA(4.999,IENS,.06)=$PIECE(^TMP("XUMF ARRAY",$JOB,STA),U,12)
+16 Begin DoDot:3
+17 NEW IEN,STA
+18 DO UPDATE^DIE("E","FDA")
End DoDot:3
End DoDot:2
+19 SET EFFDT=$PIECE(^TMP("XUMF ARRAY",$JOB,STA),U,13)
+20 SET EFFDT=$$FMDATE^HLFNC(+EFFDT)
+21 IF EFFDT
Begin DoDot:2
+22 SET IENS="?+"_EFFDT_","_IEN_","
+23 KILL FDA
+24 SET FDA(4.999,IENS,.01)=EFFDT
+25 SET FDA(4.999,IENS,.05)=$PIECE(^TMP("XUMF ARRAY",$JOB,STA),U,14)
+26 Begin DoDot:3
+27 NEW IEN,STA
+28 DO UPDATE^DIE("E","FDA")
+29 SET CNT=CNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+30 ;
+31 QUIT
+32 ;
CDSN() ; -- check for duplicate sta # (true=duplicates, false=none)
+1 ;
+2 KILL ^TMP("XUMF TMP",$JOB)
+3 ;
+4 NEW IEN,STA,CNT
+5 ;
+6 SET STA=""
SET IEN=0
+7 FOR
SET STA=$ORDER(^DIC(4,"D",STA))
if STA=""
QUIT
Begin DoDot:1
+8 FOR
SET IEN=$ORDER(^DIC(4,"D",STA,IEN))
if 'IEN
QUIT
Begin DoDot:2
+9 SET ^TMP("XUMF TMP",$JOB,STA,IEN)=$PIECE(^DIC(4,IEN,0),U)
End DoDot:2
End DoDot:1
+10 ;
+11 SET STA=""
SET (CNT,IEN)=0
+12 FOR
SET STA=$ORDER(^TMP("XUMF TMP",$JOB,STA))
if STA=""
QUIT
Begin DoDot:1
+13 if '$ORDER(^TMP("XUMF TMP",$JOB,STA,+$ORDER(^TMP("XUMF TMP",$JOB,STA,0))))
QUIT
+14 FOR
SET IEN=$ORDER(^TMP("XUMF TMP",$JOB,STA,IEN))
if 'IEN
QUIT
Begin DoDot:2
+15 SET CNT=CNT+1
End DoDot:2
End DoDot:1
+16 ;
+17 KILL ^TMP("XUMF TMP",$JOB)
+18 ;
+19 QUIT CNT
+20 ;
MOD ; if entry modified set TMP
+1 ;
+2 NEW NAME,FACTYP,VANAME,STANUM,FLAG,PRNT,VISN,STATE,X,Y
+3 ;
+4 if '$DATA(^DIC(4,+IEN,0))
QUIT
+5 ;
+6 SET X=$PIECE(^TMP("XUMF ARRAY",$JOB,STA),U,2,10)
+7 ;
+8 SET NAME=$PIECE($GET(^DIC(4,+IEN,0)),U)
+9 SET FACTYP=$PIECE($GET(^DIC(4.1,+$GET(^DIC(4,+IEN,3)),0)),U)
+10 if FACTYP'=""
SET FACTYP=FACTYP_"~FACILITY TYPE~VA"
+11 SET VANAME=$PIECE($GET(^DIC(4,+IEN,99)),U,3)
+12 SET STANUM=$PIECE($GET(^DIC(4,+IEN,99)),U)
+13 SET FLAG=$SELECT(+$PIECE($GET(^DIC(4,+IEN,99)),U,4):"INACTIVE",1:"")
+14 SET PRNT=$PIECE($GET(^DIC(4,+$PIECE($GET(^DIC(4,+IEN,7,2,0)),U,2),99)),U)
+15 SET VISN=$PIECE($GET(^DIC(4,+$PIECE($GET(^DIC(4,+IEN,7,1,0)),U,2),0)),U)
+16 if VISN'=""
SET VISN=VISN_"~VISN~VA"
+17 SET STATE=$PIECE($GET(^DIC(5,+$PIECE($GET(^DIC(4,+IEN,0)),U,2),0)),U)
+18 ;
+19 SET Y=NAME_U_STANUM_U_"National"_U_FACTYP_U_VANAME_U_FLAG_U_STATE
+20 SET Y=Y_U_VISN_U_PRNT
+21 ;
+22 if Y=X
QUIT
+23 ;
+24 SET ^TMP("XUMF MOD",$JOB,STA,"NEW")=X
+25 SET ^TMP("XUMF MOD",$JOB,STA,"OLD")=Y
+26 ;
+27 QUIT
+28 ;
FTCLEAN ; -- add missing facility types
+1 ;
+2 NEW NAME,FULL,FDA
+3 ;
+4 SET NAME=""
+5 FOR
SET NAME=$ORDER(^TMP("XUMF ARRAY",$JOB,NAME))
if NAME=""
QUIT
Begin DoDot:1
+6 SET FULL=$PIECE(^TMP("XUMF ARRAY",$JOB,NAME),U,3)
+7 Begin DoDot:2
+8 KILL FDA
+9 SET FDA(4.1,"?+1,",.01)=NAME
+10 SET FDA(4.1,"?+1,",1)=FULL
+11 SET FDA(4.1,"?+1,",3)="N"
+12 NEW NAME
+13 DO UPDATE^DIE("E","FDA",,"ERR")
End DoDot:2
End DoDot:1
+14 ;
+15 QUIT
+16 ;
