XUMF4 ;OIFO-OAK/RAM - Institution File Clean Up; 06/28/00
;;8.0;KERNEL;**206,209,212,261**;Jul 10, 1995
;
;
EN ; -- entry point
;
K ^TMP("XUMF ARRAY",$J)
;
N PARAM,XUMFLAG,ERROR,TEST,ERR
;
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 EXIT1 Q
;
I '$D(^TMP("XUMF ARRAY",$J)) D
.W !!,"...connecting with master file server..."
.D MFS0
;
I ERROR D EXIT1 Q
;
I '$D(^TMP("XUMF ARRAY",$J)) D D EXIT1 Q
.S ERROR="1^Connection to master file server failed!"
;
D FTCLEAN^XUMF4A I ERROR D EXIT1 Q
;
K ^TMP("XUMF ARRAY",$J),^TMP("XUMF MFS",$J)
;
W !!,"...connecting with master file server..."
D MFS1
;
I ERROR D EXIT1 Q
;
I '$D(^TMP("XUMF ARRAY",$J)) D Q
.S ERROR="1^Connection to master file server failed!"
.D EXIT1
;
D EN^VALM("XUMF NAME")
;
D EXIT1
;
Q
;
RDSN ; - resolve duplicate station number
;
I '$O(@VALMAR@("INDEX",0)) D Q
.W !!,"No duplicates to select from!",!
.S VALMBCK="R" H 2
;
N ENTRY,VALMY,DA,DR,DIE,STA,MERGED,FROM
;
D EN^VALM2(XQORNOD(0),"OS")
Q:'$D(VALMY) Q:'$D(VALMAR)
;
S DA=@VALMAR@("INDEX",+$O(VALMY(0)))
S DR="99///@",DIE=4
I DA D
.I $O(^HLCS(870,"C",DA,0)) D Q
..W !!?20,"Pointed to by HL7 Logical Link"
..W !?22,"*select other entry*",!!
.D ^DIE
;
D @($E($P(VALMAR,"XUMF ",2),1,4)_"^XUMF4")
S VALMBCK="R"
;
Q
;
;
DSTA ; -- duplicate station #s
;
K ^TMP("XUMF DSTA",$J),^TMP("XUMF TMP",$J)
;
I 'XUMFLAG D LOCAL
;
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:'$D(^TMP("XUMF ARRAY",$J,STA))
..S ^TMP("XUMF TMP",$J,STA,IEN)=$P(^DIC(4,IEN,0),U)
;
S STA="",(VALMCNT,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 VALMCNT=VALMCNT+1
..S VAR="",NAME=$P(^TMP("XUMF TMP",$J,STA,IEN),U)
..S VAR=$$SETFLD^VALM1(VALMCNT,VAR,"ENTRY NUMBER")
..S VAR=$$SETFLD^VALM1(STA,VAR,"STATION NUMBER")
..S VAR=$$SETFLD^VALM1(NAME,VAR,"INSTITUTION NAME")
..S VAR=$$SETFLD^VALM1(IEN,VAR,"IEN")
..D SET^VALM10(VALMCNT,VAR,VALMCNT)
..S @VALMAR@("INDEX",VALMCNT)=IEN
;
D:'VALMCNT
.S VAR="",VAR=$$SETFLD^VALM1("***No duplicates***",VAR,"INSTITUTION NAME")
.S VALMCNT=1
.D SET^VALM10(VALMCNT,VAR,VALMCNT)
;
K ^TMP("XUMF TMP",$J)
;
Q
;
LOCAL ; -- auto-delete local/duplicate station numbers
;
W !!,"This action will auto-delete local/duplicate station numbers."
N Y S DIR(0)="Y",DIR("B")="YES" W !
S DIR("A")="Do you wish to proceed"
D ^DIR K DIR I 'Y Q
;
S XUMFLAG=1
D DXRF
;
N IEN,STA,STANUM,VAR,NAME,FLAG,CNT
;
S STA="",(IEN,CNT)=0
F S STA=$O(^DIC(4,"D",STA)) Q:STA="" D
.Q:'$O(^DIC(4,"D",STA,+$O(^DIC(4,"D",STA,0))))
.S FLAG=0
.F S IEN=$O(^DIC(4,"D",STA,IEN)) Q:'IEN D
..S:$O(^HLCS(870,"C",IEN,0)) FLAG=1
.Q:'FLAG
.F S IEN=$O(^DIC(4,"D",STA,IEN)) Q:'IEN D
..Q:$O(^HLCS(870,"C",IEN,0))
..W !?5,"deleting duplicate station number ",STA," from IEN: ",IEN
..H 1
..S DR="99///@",DIE=4,DA=IEN,CNT=CNT+1
..N IEN,STA,FLAG D ^DIE
I CNT D EOP S CNT=0
;
S STA="",IEN=0
F S STA=$O(^DIC(4,"D",STA)) Q:STA="" D
.Q:$D(^TMP("XUMF ARRAY",$J,STA))
.Q:'$D(^TMP("XUMF ARRAY",$J))
.F S IEN=$O(^DIC(4,"D",STA,IEN)) Q:'IEN D
..S DR="99///@",DIE=4,DA=IEN,CNT=CNT+1
..W !?5,"deleting local station number ",STA," from IEN: ",IEN
..H 1
..N IEN,STA D ^DIE
I CNT D EOP S CNT=0
;
Q
;
;
DXRF ; -- re-index "D" cross-reference
;
N DIK
;
K ^DIC(4,"D")
;
S DIK="^DIC(4,",DIK(1)="99^D" D ENALL^DIK
;
Q
;
;
LLCL ; -- local data
;
K ^TMP("XUMF LLCL",$J)
;
N STA,IEN,STANUM,VAR,NAME,FTYP
;
S STA="",VALMCNT=0
F S STA=$O(^DIC(4,"D",STA)) Q:STA="" D
.S IEN=$O(^DIC(4,"D",STA,0))
.S FTYP=$P($G(^DIC(4.1,+$G(^DIC(4,+IEN,3)),0)),U)
.Q:$D(^TMP("XUMF ARRAY",$J,STA))
.S VALMCNT=VALMCNT+1
.S VAR="",NAME=$P(^DIC(4,IEN,0),U)
.S VAR=$$SETFLD^VALM1(STA,VAR,"STATION NUMBER")
.S VAR=$$SETFLD^VALM1(NAME,VAR,"INSTITUTION NAME")
.S VAR=$$SETFLD^VALM1(IEN,VAR,"IEN")
.S VAR=$$SETFLD^VALM1(FTYP,VAR,"FACILITY TYPE")
.D SET^VALM10(VALMCNT,VAR,VALMCNT)
.S @VALMAR@("INDEX",VALMCNT)=IEN
;
D:'VALMCNT
.S VAR="",VAR=$$SETFLD^VALM1("***None found***",VAR,"INSTITUTION NAME")
.D SET^VALM10(1,VAR,1)
;
Q
;
;
NATL ; -- national data to merge
;
K ^TMP("XUMF NATL",$J)
;
N STA,VAR,NAME,TYPE,STATE
;
S STA="",VALMCNT=0
F S STA=$O(^TMP("XUMF ARRAY",$J,STA)) Q:STA="" D
.Q:$D(^DIC(4,"D",STA))
.S VALMCNT=VALMCNT+1
.S VAR="",NAME=$P(^TMP("XUMF ARRAY",$J,STA),U,2)
.S TYPE=$P($P(^TMP("XUMF ARRAY",$J,STA),U,5),"~")
.S STATE=$P(^TMP("XUMF ARRAY",$J,STA),U,8)
.S VAR=$$SETFLD^VALM1(STA,VAR,"STATION NUMBER")
.S VAR=$$SETFLD^VALM1(NAME,VAR,"NATIONAL NAME")
.S VAR=$$SETFLD^VALM1(STATE,VAR,"STATE")
.S VAR=$$SETFLD^VALM1(TYPE,VAR,"TYPE")
.D SET^VALM10(VALMCNT,VAR,VALMCNT)
;
D:'VALMCNT
.S VAR="",VAR=$$SETFLD^VALM1("***None found***",VAR,"NATIONAL NAME")
.D SET^VALM10(1,VAR,1)
;
Q
;
;
NAME ; -- compare INSTITUTION name vs national name
;
K ^TMP("XUMF NAME",$J),^TMP("XUMF TABLE",$J)
;
N STA,IEN,NAME,GOLD,NAME,VAR,ARRAY
;
D DXRF
;
S STA="",(IEN,VALMCNT)=0
F S STA=$O(^DIC(4,"D",STA)) Q:STA="" D
.S IEN=$O(^DIC(4,"D",STA,0))
.S GOLD=$P($G(^TMP("XUMF ARRAY",$J,STA)),U,2)
.S NAME=$P(^DIC(4,IEN,0),U)
.S ^TMP("XUMF TABLE",$J,STA,IEN)=NAME_U_GOLD
;
F S STA=$O(^TMP("XUMF ARRAY",$J,STA)) Q:STA="" D
.Q:$D(^TMP("XUMF TABLE",$J,STA))
.S NAME=$P(^TMP("XUMF ARRAY",$J,STA),U,2)
.S ^TMP("XUMF TABLE",$J,STA,9999)="^"_NAME
;
S (IEN,VALMCNT)=0
F S STA=$O(^TMP("XUMF TABLE",$J,STA)) Q:STA="" D
.F S IEN=$O(^TMP("XUMF TABLE",$J,STA,IEN)) Q:'IEN D
..S GOLD=$P(^TMP("XUMF TABLE",$J,STA,IEN),U,2)
..S NAME=$P(^TMP("XUMF TABLE",$J,STA,IEN),U)
..S VALMCNT=VALMCNT+1,VAR=""
..S VAR=$$SETFLD^VALM1(STA,VAR,"STATION NUMBER")
..S VAR=$$SETFLD^VALM1(NAME,VAR,"INSTITUTION NAME")
..S VAR=$$SETFLD^VALM1(GOLD,VAR,"GOLD NAME")
..D SET^VALM10(VALMCNT,VAR,VALMCNT)
;
D:'VALMCNT
.S VAR="",VAR=$$SETFLD^VALM1("***None found***",VAR,"INSTITUTION NAME")
.D SET^VALM10(1,VAR,1)
;
K ^TMP("XUMF TABLE",$J)
;
Q
;
;
MFS0 ; -- get national facility type file from Master File Server
;
D FACTYP^XUMF4A
D STATE^XUMF4A
;
S PARAM("LLNK")="XUMF MFR^XUMF "_$S('TEST:"FORUM",1:"TEST")
S PARAM("PROTOCOL")=$O(^ORD(101,"B","XUMF MFQ",0))
;
W !!,"...getting FACILITY TYPE file..."
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))
;
W !!,"...getting INSTITUTION file..."
W !,"...please wait...(approx. 5 minutes)..."
D MAIN^XUMFP(4,"ALL",7,.PARAM,.ERROR) Q:ERROR
D MAIN^XUMFI(4,"ALL",7,.PARAM,.ERROR) Q:ERROR
D MAIN^XUMFH
;
Q
;
EXIT ; -- cleanup and quit
;
K:$D(VALMAR) @VALMAR
;
Q
;
EXIT1 ;
;
K ^TMP("XUMF ARRAY",$J),^TMP("XUMF MFS",$J)
K ^TMP("DIERR",$J)
;
L -^TMP("XUMF ARRAY",$J)
;
I ERROR D
.N XMY S XMY("G.XUMF INSTITUTION")=""
.D EM^XUMFH(ERROR,.ERR,"IFR CLEANUP",.XMY)
.W !!,ERROR,!,$G(ERR),!
;
Q
;
EOP ; -- End-of-Page
;
S DIR(0)="E"
D ^DIR,CLEAR^VALM1
S VALMBCK="R"
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUMF4 7634 printed Apr 09, 2024@21:13:22 Page 2
XUMF4 ;OIFO-OAK/RAM - Institution File Clean Up; 06/28/00
+1 ;;8.0;KERNEL;**206,209,212,261**;Jul 10, 1995
+2 ;
+3 ;
EN ; -- entry point
+1 ;
+2 KILL ^TMP("XUMF ARRAY",$JOB)
+3 ;
+4 NEW PARAM,XUMFLAG,ERROR,TEST,ERR
+5 ;
+6 SET (ERROR,XUMFLAG,TEST)=0
+7 ;
+8 IF $PIECE($$PARAM^HLCS2,U,3)="T"
SET TEST=1
+9 ;
+10 LOCK +^TMP("XUMF ARRAY",$JOB):0
if '$TEST
Begin DoDot:1
+11 SET ERROR="1^another process is using the Master File Server"
End DoDot:1
+12 ;
+13 IF ERROR
DO EXIT1
QUIT
+14 ;
+15 IF '$DATA(^TMP("XUMF ARRAY",$JOB))
Begin DoDot:1
+16 WRITE !!,"...connecting with master file server..."
+17 DO MFS0
End DoDot:1
+18 ;
+19 IF ERROR
DO EXIT1
QUIT
+20 ;
+21 IF '$DATA(^TMP("XUMF ARRAY",$JOB))
Begin DoDot:1
+22 SET ERROR="1^Connection to master file server failed!"
End DoDot:1
DO EXIT1
QUIT
+23 ;
+24 DO FTCLEAN^XUMF4A
IF ERROR
DO EXIT1
QUIT
+25 ;
+26 KILL ^TMP("XUMF ARRAY",$JOB),^TMP("XUMF MFS",$JOB)
+27 ;
+28 WRITE !!,"...connecting with master file server..."
+29 DO MFS1
+30 ;
+31 IF ERROR
DO EXIT1
QUIT
+32 ;
+33 IF '$DATA(^TMP("XUMF ARRAY",$JOB))
Begin DoDot:1
+34 SET ERROR="1^Connection to master file server failed!"
+35 DO EXIT1
End DoDot:1
QUIT
+36 ;
+37 DO EN^VALM("XUMF NAME")
+38 ;
+39 DO EXIT1
+40 ;
+41 QUIT
+42 ;
RDSN ; - resolve duplicate station number
+1 ;
+2 IF '$ORDER(@VALMAR@("INDEX",0))
Begin DoDot:1
+3 WRITE !!,"No duplicates to select from!",!
+4 SET VALMBCK="R"
HANG 2
End DoDot:1
QUIT
+5 ;
+6 NEW ENTRY,VALMY,DA,DR,DIE,STA,MERGED,FROM
+7 ;
+8 DO EN^VALM2(XQORNOD(0),"OS")
+9 if '$DATA(VALMY)
QUIT
if '$DATA(VALMAR)
QUIT
+10 ;
+11 SET DA=@VALMAR@("INDEX",+$ORDER(VALMY(0)))
+12 SET DR="99///@"
SET DIE=4
+13 IF DA
Begin DoDot:1
+14 IF $ORDER(^HLCS(870,"C",DA,0))
Begin DoDot:2
+15 WRITE !!?20,"Pointed to by HL7 Logical Link"
+16 WRITE !?22,"*select other entry*",!!
End DoDot:2
QUIT
+17 DO ^DIE
End DoDot:1
+18 ;
+19 DO @($EXTRACT($PIECE(VALMAR,"XUMF ",2),1,4)_"^XUMF4")
+20 SET VALMBCK="R"
+21 ;
+22 QUIT
+23 ;
+24 ;
DSTA ; -- duplicate station #s
+1 ;
+2 KILL ^TMP("XUMF DSTA",$JOB),^TMP("XUMF TMP",$JOB)
+3 ;
+4 IF 'XUMFLAG
DO LOCAL
+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 if '$DATA(^TMP("XUMF ARRAY",$JOB,STA))
QUIT
+10 SET ^TMP("XUMF TMP",$JOB,STA,IEN)=$PIECE(^DIC(4,IEN,0),U)
End DoDot:2
End DoDot:1
+11 ;
+12 SET STA=""
SET (VALMCNT,IEN)=0
+13 FOR
SET STA=$ORDER(^TMP("XUMF TMP",$JOB,STA))
if STA=""
QUIT
Begin DoDot:1
+14 if '$ORDER(^TMP("XUMF TMP",$JOB,STA,+$ORDER(^TMP("XUMF TMP",$JOB,STA,0))))
QUIT
+15 FOR
SET IEN=$ORDER(^TMP("XUMF TMP",$JOB,STA,IEN))
if 'IEN
QUIT
Begin DoDot:2
+16 SET VALMCNT=VALMCNT+1
+17 SET VAR=""
SET NAME=$PIECE(^TMP("XUMF TMP",$JOB,STA,IEN),U)
+18 SET VAR=$$SETFLD^VALM1(VALMCNT,VAR,"ENTRY NUMBER")
+19 SET VAR=$$SETFLD^VALM1(STA,VAR,"STATION NUMBER")
+20 SET VAR=$$SETFLD^VALM1(NAME,VAR,"INSTITUTION NAME")
+21 SET VAR=$$SETFLD^VALM1(IEN,VAR,"IEN")
+22 DO SET^VALM10(VALMCNT,VAR,VALMCNT)
+23 SET @VALMAR@("INDEX",VALMCNT)=IEN
End DoDot:2
End DoDot:1
+24 ;
+25 if 'VALMCNT
Begin DoDot:1
+26 SET VAR=""
SET VAR=$$SETFLD^VALM1("***No duplicates***",VAR,"INSTITUTION NAME")
+27 SET VALMCNT=1
+28 DO SET^VALM10(VALMCNT,VAR,VALMCNT)
End DoDot:1
+29 ;
+30 KILL ^TMP("XUMF TMP",$JOB)
+31 ;
+32 QUIT
+33 ;
LOCAL ; -- auto-delete local/duplicate station numbers
+1 ;
+2 WRITE !!,"This action will auto-delete local/duplicate station numbers."
+3 NEW Y
SET DIR(0)="Y"
SET DIR("B")="YES"
WRITE !
+4 SET DIR("A")="Do you wish to proceed"
+5 DO ^DIR
KILL DIR
IF 'Y
QUIT
+6 ;
+7 SET XUMFLAG=1
+8 DO DXRF
+9 ;
+10 NEW IEN,STA,STANUM,VAR,NAME,FLAG,CNT
+11 ;
+12 SET STA=""
SET (IEN,CNT)=0
+13 FOR
SET STA=$ORDER(^DIC(4,"D",STA))
if STA=""
QUIT
Begin DoDot:1
+14 if '$ORDER(^DIC(4,"D",STA,+$ORDER(^DIC(4,"D",STA,0))))
QUIT
+15 SET FLAG=0
+16 FOR
SET IEN=$ORDER(^DIC(4,"D",STA,IEN))
if 'IEN
QUIT
Begin DoDot:2
+17 if $ORDER(^HLCS(870,"C",IEN,0))
SET FLAG=1
End DoDot:2
+18 if 'FLAG
QUIT
+19 FOR
SET IEN=$ORDER(^DIC(4,"D",STA,IEN))
if 'IEN
QUIT
Begin DoDot:2
+20 if $ORDER(^HLCS(870,"C",IEN,0))
QUIT
+21 WRITE !?5,"deleting duplicate station number ",STA," from IEN: ",IEN
+22 HANG 1
+23 SET DR="99///@"
SET DIE=4
SET DA=IEN
SET CNT=CNT+1
+24 NEW IEN,STA,FLAG
DO ^DIE
End DoDot:2
End DoDot:1
+25 IF CNT
DO EOP
SET CNT=0
+26 ;
+27 SET STA=""
SET IEN=0
+28 FOR
SET STA=$ORDER(^DIC(4,"D",STA))
if STA=""
QUIT
Begin DoDot:1
+29 if $DATA(^TMP("XUMF ARRAY",$JOB,STA))
QUIT
+30 if '$DATA(^TMP("XUMF ARRAY",$JOB))
QUIT
+31 FOR
SET IEN=$ORDER(^DIC(4,"D",STA,IEN))
if 'IEN
QUIT
Begin DoDot:2
+32 SET DR="99///@"
SET DIE=4
SET DA=IEN
SET CNT=CNT+1
+33 WRITE !?5,"deleting local station number ",STA," from IEN: ",IEN
+34 HANG 1
+35 NEW IEN,STA
DO ^DIE
End DoDot:2
End DoDot:1
+36 IF CNT
DO EOP
SET CNT=0
+37 ;
+38 QUIT
+39 ;
+40 ;
DXRF ; -- re-index "D" cross-reference
+1 ;
+2 NEW DIK
+3 ;
+4 KILL ^DIC(4,"D")
+5 ;
+6 SET DIK="^DIC(4,"
SET DIK(1)="99^D"
DO ENALL^DIK
+7 ;
+8 QUIT
+9 ;
+10 ;
LLCL ; -- local data
+1 ;
+2 KILL ^TMP("XUMF LLCL",$JOB)
+3 ;
+4 NEW STA,IEN,STANUM,VAR,NAME,FTYP
+5 ;
+6 SET STA=""
SET VALMCNT=0
+7 FOR
SET STA=$ORDER(^DIC(4,"D",STA))
if STA=""
QUIT
Begin DoDot:1
+8 SET IEN=$ORDER(^DIC(4,"D",STA,0))
+9 SET FTYP=$PIECE($GET(^DIC(4.1,+$GET(^DIC(4,+IEN,3)),0)),U)
+10 if $DATA(^TMP("XUMF ARRAY",$JOB,STA))
QUIT
+11 SET VALMCNT=VALMCNT+1
+12 SET VAR=""
SET NAME=$PIECE(^DIC(4,IEN,0),U)
+13 SET VAR=$$SETFLD^VALM1(STA,VAR,"STATION NUMBER")
+14 SET VAR=$$SETFLD^VALM1(NAME,VAR,"INSTITUTION NAME")
+15 SET VAR=$$SETFLD^VALM1(IEN,VAR,"IEN")
+16 SET VAR=$$SETFLD^VALM1(FTYP,VAR,"FACILITY TYPE")
+17 DO SET^VALM10(VALMCNT,VAR,VALMCNT)
+18 SET @VALMAR@("INDEX",VALMCNT)=IEN
End DoDot:1
+19 ;
+20 if 'VALMCNT
Begin DoDot:1
+21 SET VAR=""
SET VAR=$$SETFLD^VALM1("***None found***",VAR,"INSTITUTION NAME")
+22 DO SET^VALM10(1,VAR,1)
End DoDot:1
+23 ;
+24 QUIT
+25 ;
+26 ;
NATL ; -- national data to merge
+1 ;
+2 KILL ^TMP("XUMF NATL",$JOB)
+3 ;
+4 NEW STA,VAR,NAME,TYPE,STATE
+5 ;
+6 SET STA=""
SET VALMCNT=0
+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 VALMCNT=VALMCNT+1
+10 SET VAR=""
SET NAME=$PIECE(^TMP("XUMF ARRAY",$JOB,STA),U,2)
+11 SET TYPE=$PIECE($PIECE(^TMP("XUMF ARRAY",$JOB,STA),U,5),"~")
+12 SET STATE=$PIECE(^TMP("XUMF ARRAY",$JOB,STA),U,8)
+13 SET VAR=$$SETFLD^VALM1(STA,VAR,"STATION NUMBER")
+14 SET VAR=$$SETFLD^VALM1(NAME,VAR,"NATIONAL NAME")
+15 SET VAR=$$SETFLD^VALM1(STATE,VAR,"STATE")
+16 SET VAR=$$SETFLD^VALM1(TYPE,VAR,"TYPE")
+17 DO SET^VALM10(VALMCNT,VAR,VALMCNT)
End DoDot:1
+18 ;
+19 if 'VALMCNT
Begin DoDot:1
+20 SET VAR=""
SET VAR=$$SETFLD^VALM1("***None found***",VAR,"NATIONAL NAME")
+21 DO SET^VALM10(1,VAR,1)
End DoDot:1
+22 ;
+23 QUIT
+24 ;
+25 ;
NAME ; -- compare INSTITUTION name vs national name
+1 ;
+2 KILL ^TMP("XUMF NAME",$JOB),^TMP("XUMF TABLE",$JOB)
+3 ;
+4 NEW STA,IEN,NAME,GOLD,NAME,VAR,ARRAY
+5 ;
+6 DO DXRF
+7 ;
+8 SET STA=""
SET (IEN,VALMCNT)=0
+9 FOR
SET STA=$ORDER(^DIC(4,"D",STA))
if STA=""
QUIT
Begin DoDot:1
+10 SET IEN=$ORDER(^DIC(4,"D",STA,0))
+11 SET GOLD=$PIECE($GET(^TMP("XUMF ARRAY",$JOB,STA)),U,2)
+12 SET NAME=$PIECE(^DIC(4,IEN,0),U)
+13 SET ^TMP("XUMF TABLE",$JOB,STA,IEN)=NAME_U_GOLD
End DoDot:1
+14 ;
+15 FOR
SET STA=$ORDER(^TMP("XUMF ARRAY",$JOB,STA))
if STA=""
QUIT
Begin DoDot:1
+16 if $DATA(^TMP("XUMF TABLE",$JOB,STA))
QUIT
+17 SET NAME=$PIECE(^TMP("XUMF ARRAY",$JOB,STA),U,2)
+18 SET ^TMP("XUMF TABLE",$JOB,STA,9999)="^"_NAME
End DoDot:1
+19 ;
+20 SET (IEN,VALMCNT)=0
+21 FOR
SET STA=$ORDER(^TMP("XUMF TABLE",$JOB,STA))
if STA=""
QUIT
Begin DoDot:1
+22 FOR
SET IEN=$ORDER(^TMP("XUMF TABLE",$JOB,STA,IEN))
if 'IEN
QUIT
Begin DoDot:2
+23 SET GOLD=$PIECE(^TMP("XUMF TABLE",$JOB,STA,IEN),U,2)
+24 SET NAME=$PIECE(^TMP("XUMF TABLE",$JOB,STA,IEN),U)
+25 SET VALMCNT=VALMCNT+1
SET VAR=""
+26 SET VAR=$$SETFLD^VALM1(STA,VAR,"STATION NUMBER")
+27 SET VAR=$$SETFLD^VALM1(NAME,VAR,"INSTITUTION NAME")
+28 SET VAR=$$SETFLD^VALM1(GOLD,VAR,"GOLD NAME")
+29 DO SET^VALM10(VALMCNT,VAR,VALMCNT)
End DoDot:2
End DoDot:1
+30 ;
+31 if 'VALMCNT
Begin DoDot:1
+32 SET VAR=""
SET VAR=$$SETFLD^VALM1("***None found***",VAR,"INSTITUTION NAME")
+33 DO SET^VALM10(1,VAR,1)
End DoDot:1
+34 ;
+35 KILL ^TMP("XUMF TABLE",$JOB)
+36 ;
+37 QUIT
+38 ;
+39 ;
MFS0 ; -- get national facility type file from Master File Server
+1 ;
+2 DO FACTYP^XUMF4A
+3 DO STATE^XUMF4A
+4 ;
+5 SET PARAM("LLNK")="XUMF MFR^XUMF "_$SELECT('TEST:"FORUM",1:"TEST")
+6 SET PARAM("PROTOCOL")=$ORDER(^ORD(101,"B","XUMF MFQ",0))
+7 ;
+8 WRITE !!,"...getting FACILITY TYPE file..."
+9 DO MAIN^XUMFP(4.1,"ALL",7,.PARAM,.ERROR)
if ERROR
QUIT
+10 DO MAIN^XUMFI(4.1,"ALL",7,.PARAM,.ERROR)
if ERROR
QUIT
+11 DO MAIN^XUMFH
+12 ;
+13 QUIT
+14 ;
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 WRITE !!,"...getting INSTITUTION file..."
+6 WRITE !,"...please wait...(approx. 5 minutes)..."
+7 DO MAIN^XUMFP(4,"ALL",7,.PARAM,.ERROR)
if ERROR
QUIT
+8 DO MAIN^XUMFI(4,"ALL",7,.PARAM,.ERROR)
if ERROR
QUIT
+9 DO MAIN^XUMFH
+10 ;
+11 QUIT
+12 ;
EXIT ; -- cleanup and quit
+1 ;
+2 if $DATA(VALMAR)
KILL @VALMAR
+3 ;
+4 QUIT
+5 ;
EXIT1 ;
+1 ;
+2 KILL ^TMP("XUMF ARRAY",$JOB),^TMP("XUMF MFS",$JOB)
+3 KILL ^TMP("DIERR",$JOB)
+4 ;
+5 LOCK -^TMP("XUMF ARRAY",$JOB)
+6 ;
+7 IF ERROR
Begin DoDot:1
+8 NEW XMY
SET XMY("G.XUMF INSTITUTION")=""
+9 DO EM^XUMFH(ERROR,.ERR,"IFR CLEANUP",.XMY)
+10 WRITE !!,ERROR,!,$GET(ERR),!
End DoDot:1
+11 ;
+12 QUIT
+13 ;
EOP ; -- End-of-Page
+1 ;
+2 SET DIR(0)="E"
+3 DO ^DIR
DO CLEAR^VALM1
+4 SET VALMBCK="R"
+5 ;
+6 QUIT
+7 ;
