XUMF4A ;CIOFO-SF/RAM - Institution File Clean Up; 06/28/99
;;8.0;KERNEL;**206,209,212,261**;Jul 10, 1995
;
;
EN ; -- entry point
;
I $$CDSN D Q
.D MSG^VALM10("Duplicates sta #s exist! -- NOTHING UPDATED!!!")
.H 5
.S VALMBCK="R"
;
W "...working",!
D DSN,CSN,GOLD,ASSC,HIST
;
K ^TMP("XUMF NAME",$J)
D NAME^XUMF4
S VALMBG=1
S VALMBCK="R"
;
Q
;
DSN ; -- clean out local station numbers
;
N IEN,DIE,DR,DA,XUMF,DIK
;
S XUMF=7
;
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 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
;
CSN ; -- check/update status
;
N IEN,DIE,DR,DA,XUMF,STATUS,STA
;
S XUMF=7
;
S IEN=0
F S IEN=$O(^DIC(4,IEN)) Q:'IEN D
.S STA=$P($G(^DIC(4,+IEN,99)),U)
.I STA S DR="11///N",DIE=4,DA=IEN D Q
..N IEN D ^DIE
.S STATUS=$P(^DIC(4,IEN,0),U,11)
.I STATUS="I" S DR="101///I",DIE=4,DA=IEN D
..N IEN D ^DIE
.S DR="11///L",DIE=4,DA=IEN D
..N IEN D ^DIE
;
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,STATE,AGENCY
;
S XUMF=7
;
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 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",,"ERR")
..S CNT=CNT+1 I '(CNT#10) W "."
;
Q
;
ASSC ; -- populate associations (parent facility and VISN)
;
N IEN,STA,VISN,PARENT,FDA,XUMF,CNT
;
S XUMF=7
;
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 I '(CNT#10) W "."
;
Q
;
HIST ; -- history
;
N IEN,STA,EFFDT,FDA,XUMF,CNT
;
S XUMF=7
;
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 I '(CNT#10) W "."
;
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
;
CMVD() ; -- check for missing national data
;
N STA,CNT
;
S CNT=0
;
S STA=""
F S STA=$O(^TMP("XUMF ARRAY",$J,STA)) Q:STA="" D
.Q:$D(^DIC(4,"D",STA))
.S CNT=CNT+1
;
Q CNT
;
CHCK ; -- check if clean up is complete
;
N VAR,FLD
;
K ^TMP("XUMF CHCK",$J)
;
S VALMCNT=0
;
I $$CDSN D
.S VALMCNT=VALMCNT+1,VAR=""
.S FLD="Local/Duplicate station #s exist -- use DSTA"
.S VAR=$$SETFLD^VALM1(FLD,VAR,"MSG")
.D SET^VALM10(VALMCNT,VAR,VALMCNT)
;
I $$CMVD D
.S VALMCNT=VALMCNT+1,VAR=""
.S FLD="INSTITUTION file not updated with NATIONAL data -- use AUTO"
.S VAR=$$SETFLD^VALM1(FLD,VAR,"MSG")
.D SET^VALM10(VALMCNT,VAR,VALMCNT)
;
D:'VALMCNT
.S VAR="",FLD="CONGRATULATIONS!!! Update complete!"
.S VAR=$$SETFLD^VALM1(FLD,VAR,"MSG")
.D SET^VALM10(1,VAR,1)
;
Q
;
FACTYP ;resolve duplicate facility types
;
N FT,CNT,IEN,DA,DIE,DR
;
S FT="",(CNT,IEN)=0
F S FT=$O(^DIC(4.1,"B",FT)) Q:FT="" D
.F S IEN=$O(^DIC(4.1,"B",FT,IEN)) Q:'IEN D
..Q:$E(FT,1,2)="ZZ"
..S CNT=CNT+1
..Q:CNT<2
..S DA=IEN,DIE=4.1
..S DR=".01///ZZ"_$P($G(^DIC(4.1,+IEN,0)),U)
..D ^DIE
.S CNT=0
;
Q
;
STATE ;resolve duplicate states
;
N STATE,CNT,IEN,DA,DIE,DR
;
;name
S STATE="",(CNT,IEN)=0
F S STATE=$O(^DIC(5,"B",STATE)) Q:STATE="" D
.F S IEN=$O(^DIC(5,"B",STATE,IEN)) Q:'IEN D
..Q:$E(STATE,1,2)="ZZ"
..S CNT=CNT+1
..Q:CNT<2
..S DA=IEN,DIE=5
..S DR=".01///ZZ"_$P($G(^DIC(5,+IEN,0)),U)
..D ^DIE
.S CNT=0
;
;abbreviation
S STATE="",(CNT,IEN)=0
F S STATE=$O(^DIC(5,"C",STATE)) Q:STATE="" Q:STATE D
.F S IEN=$O(^DIC(5,"C",STATE,IEN)) Q:'IEN D
..Q:$E(STATE,1,2)="ZZ"
..S CNT=CNT+1
..Q:CNT<2
..S DA=IEN,DIE=5
..S DR="1///ZZ"_$P($G(^DIC(5,+IEN,0)),U,2)
..D ^DIE
.S CNT=0
;
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[HXUMF4A 6690 printed Apr 09, 2024@21:05:49 Page 2
XUMF4A ;CIOFO-SF/RAM - Institution File Clean Up; 06/28/99
+1 ;;8.0;KERNEL;**206,209,212,261**;Jul 10, 1995
+2 ;
+3 ;
EN ; -- entry point
+1 ;
+2 IF $$CDSN
Begin DoDot:1
+3 DO MSG^VALM10("Duplicates sta #s exist! -- NOTHING UPDATED!!!")
+4 HANG 5
+5 SET VALMBCK="R"
End DoDot:1
QUIT
+6 ;
+7 WRITE "...working",!
+8 DO DSN
DO CSN
DO GOLD
DO ASSC
DO HIST
+9 ;
+10 KILL ^TMP("XUMF NAME",$JOB)
+11 DO NAME^XUMF4
+12 SET VALMBG=1
+13 SET VALMBCK="R"
+14 ;
+15 QUIT
+16 ;
DSN ; -- clean out local station numbers
+1 ;
+2 NEW IEN,DIE,DR,DA,XUMF,DIK
+3 ;
+4 SET XUMF=7
+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 DR="99///@"
SET DIE=4
SET DA=IEN
+11 Begin DoDot:2
+12 NEW IEN
DO ^DIE
End DoDot:2
End DoDot:1
+13 ;
+14 SET STA=""
SET IEN=0
+15 FOR
SET STA=$ORDER(^DIC(4,"D",STA))
if STA=""
QUIT
Begin DoDot:1
+16 FOR
SET IEN=$ORDER(^DIC(4,"D",STA,IEN))
if 'IEN
QUIT
Begin DoDot:2
+17 if $PIECE($GET(^DIC(4,+IEN,99)),U)=STA
QUIT
+18 KILL ^DIC(4,"D",STA,IEN)
End DoDot:2
End DoDot:1
+19 ;
+20 SET DIK="^DIC(4,"
SET DIK(1)="99^D"
DO ENALL^DIK
+21 ;
+22 QUIT
+23 ;
CSN ; -- check/update status
+1 ;
+2 NEW IEN,DIE,DR,DA,XUMF,STATUS,STA
+3 ;
+4 SET XUMF=7
+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)
+9 IF STA
SET DR="11///N"
SET DIE=4
SET DA=IEN
Begin DoDot:2
+10 NEW IEN
DO ^DIE
End DoDot:2
QUIT
+11 SET STATUS=$PIECE(^DIC(4,IEN,0),U,11)
+12 IF STATUS="I"
SET DR="101///I"
SET DIE=4
SET DA=IEN
Begin DoDot:2
+13 NEW IEN
DO ^DIE
End DoDot:2
+14 SET DR="11///L"
SET DIE=4
SET DA=IEN
Begin DoDot:2
+15 NEW IEN
DO ^DIE
End DoDot:2
End DoDot:1
+16 ;
+17 QUIT
+18 ;
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,STATE,AGENCY
+4 ;
+5 SET XUMF=7
+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 SET OLDNAME=$PIECE($GET(^DIC(4,+IEN,0)),U,1)
+12 SET OLDVANM=$PIECE($GET(^DIC(4,+IEN,99)),U,3)
+13 SET IENS=$SELECT(IEN:IEN_",",1:"+1,")
+14 SET NAME=$PIECE(X,U,2)
+15 SET FACTYP=$PIECE(X,U,5)
+16 SET VANAME=$PIECE(X,U,6)
+17 SET FLAG=$PIECE(X,U,7)
+18 SET STATE=$PIECE(X,U,8)
+19 SET AGENCY=$PIECE(X,U,17)
+20 KILL FDA
+21 SET FDA(4,IENS,.01)=NAME
+22 SET FDA(4,IENS,.02)=STATE
+23 SET FDA(4,IENS,99)=STA
+24 SET FDA(4,IENS,11)="NATIONAL"
+25 SET FDA(4,IENS,13)=$PIECE(FACTYP,"~")
+26 SET FDA(4,IENS,100)=VANAME
+27 SET FDA(4,IENS,101)=FLAG
+28 SET FDA(4,IENS,95)=$PIECE(AGENCY,"~")
+29 Begin DoDot:2
+30 NEW IEN,STA,NAME,VANAME,OLDNAME,OLDVANM
+31 DO UPDATE^DIE("E","FDA",,"ERR")
End DoDot:2
+32 IF 'IEN
SET IEN=$ORDER(^DIC(4,"D",STA,0))
+33 if 'IEN
QUIT
+34 IF OLDNAME=""
QUIT
+35 IF OLDNAME=NAME
IF VANAME=OLDVANM
QUIT
+36 SET IENS="?+"_DT_","_IEN_","
+37 KILL FDA
+38 SET FDA(4.999,IENS,.01)=DT
+39 if NAME'=OLDNAME
SET FDA(4.999,IENS,.02)=OLDNAME
+40 if VANAME'=OLDVANM
SET FDA(4.999,IENS,.03)=OLDVANM
+41 Begin DoDot:2
+42 NEW STA
+43 DO UPDATE^DIE("E","FDA",,"ERR")
+44 SET CNT=CNT+1
IF '(CNT#10)
WRITE "."
End DoDot:2
End DoDot:1
+45 ;
+46 QUIT
+47 ;
ASSC ; -- populate associations (parent facility and VISN)
+1 ;
+2 NEW IEN,STA,VISN,PARENT,FDA,XUMF,CNT
+3 ;
+4 SET XUMF=7
+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
IF '(CNT#10)
WRITE "."
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=7
+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
IF '(CNT#10)
WRITE "."
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 ;
CMVD() ; -- check for missing national data
+1 ;
+2 NEW STA,CNT
+3 ;
+4 SET CNT=0
+5 ;
+6 SET STA=""
+7 FOR
SET STA=$ORDER(^TMP("XUMF ARRAY",$JOB,STA))
if STA=""
QUIT
Begin DoDot:1
+8 if $DATA(^DIC(4,"D",STA))
QUIT
+9 SET CNT=CNT+1
End DoDot:1
+10 ;
+11 QUIT CNT
+12 ;
CHCK ; -- check if clean up is complete
+1 ;
+2 NEW VAR,FLD
+3 ;
+4 KILL ^TMP("XUMF CHCK",$JOB)
+5 ;
+6 SET VALMCNT=0
+7 ;
+8 IF $$CDSN
Begin DoDot:1
+9 SET VALMCNT=VALMCNT+1
SET VAR=""
+10 SET FLD="Local/Duplicate station #s exist -- use DSTA"
+11 SET VAR=$$SETFLD^VALM1(FLD,VAR,"MSG")
+12 DO SET^VALM10(VALMCNT,VAR,VALMCNT)
End DoDot:1
+13 ;
+14 IF $$CMVD
Begin DoDot:1
+15 SET VALMCNT=VALMCNT+1
SET VAR=""
+16 SET FLD="INSTITUTION file not updated with NATIONAL data -- use AUTO"
+17 SET VAR=$$SETFLD^VALM1(FLD,VAR,"MSG")
+18 DO SET^VALM10(VALMCNT,VAR,VALMCNT)
End DoDot:1
+19 ;
+20 if 'VALMCNT
Begin DoDot:1
+21 SET VAR=""
SET FLD="CONGRATULATIONS!!! Update complete!"
+22 SET VAR=$$SETFLD^VALM1(FLD,VAR,"MSG")
+23 DO SET^VALM10(1,VAR,1)
End DoDot:1
+24 ;
+25 QUIT
+26 ;
FACTYP ;resolve duplicate facility types
+1 ;
+2 NEW FT,CNT,IEN,DA,DIE,DR
+3 ;
+4 SET FT=""
SET (CNT,IEN)=0
+5 FOR
SET FT=$ORDER(^DIC(4.1,"B",FT))
if FT=""
QUIT
Begin DoDot:1
+6 FOR
SET IEN=$ORDER(^DIC(4.1,"B",FT,IEN))
if 'IEN
QUIT
Begin DoDot:2
+7 if $EXTRACT(FT,1,2)="ZZ"
QUIT
+8 SET CNT=CNT+1
+9 if CNT<2
QUIT
+10 SET DA=IEN
SET DIE=4.1
+11 SET DR=".01///ZZ"_$PIECE($GET(^DIC(4.1,+IEN,0)),U)
+12 DO ^DIE
End DoDot:2
+13 SET CNT=0
End DoDot:1
+14 ;
+15 QUIT
+16 ;
STATE ;resolve duplicate states
+1 ;
+2 NEW STATE,CNT,IEN,DA,DIE,DR
+3 ;
+4 ;name
+5 SET STATE=""
SET (CNT,IEN)=0
+6 FOR
SET STATE=$ORDER(^DIC(5,"B",STATE))
if STATE=""
QUIT
Begin DoDot:1
+7 FOR
SET IEN=$ORDER(^DIC(5,"B",STATE,IEN))
if 'IEN
QUIT
Begin DoDot:2
+8 if $EXTRACT(STATE,1,2)="ZZ"
QUIT
+9 SET CNT=CNT+1
+10 if CNT<2
QUIT
+11 SET DA=IEN
SET DIE=5
+12 SET DR=".01///ZZ"_$PIECE($GET(^DIC(5,+IEN,0)),U)
+13 DO ^DIE
End DoDot:2
+14 SET CNT=0
End DoDot:1
+15 ;
+16 ;abbreviation
+17 SET STATE=""
SET (CNT,IEN)=0
+18 FOR
SET STATE=$ORDER(^DIC(5,"C",STATE))
if STATE=""
QUIT
if STATE
QUIT
Begin DoDot:1
+19 FOR
SET IEN=$ORDER(^DIC(5,"C",STATE,IEN))
if 'IEN
QUIT
Begin DoDot:2
+20 if $EXTRACT(STATE,1,2)="ZZ"
QUIT
+21 SET CNT=CNT+1
+22 if CNT<2
QUIT
+23 SET DA=IEN
SET DIE=5
+24 SET DR="1///ZZ"_$PIECE($GET(^DIC(5,+IEN,0)),U,2)
+25 DO ^DIE
End DoDot:2
+26 SET CNT=0
End DoDot:1
+27 ;
+28 QUIT
+29 ;
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 ;
