- 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 Jan 18, 2025@03:11:29 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 ;