- 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 Feb 18, 2025@23:36:49 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 ;