XUMF218A ;OIFO-OAK/RAM - Load DMIS ID's;04/15/02
;;8.0;KERNEL;**218,261**;Jul 10, 1995
;
;
EN ; -- entry point
;
N ID,NAME,FDA,ERROR,IEN,IENS,X,XUMF,STANUM,OFNME,AGENCY
;
S XUMF=1
;
S ID=""
F S ID=$O(^TMP("XUMF ARRAY",$J,ID)) Q:ID="" D
.S X=^TMP("XUMF ARRAY",$J,ID)
.S STANUM=$P(X,U,3)
.S IEN=$$IEN^XUMF(4,"DMIS",ID)
.I 'IEN,$G(STANUM)'="" S IEN=$O(^DIC(4,"D",STANUM,0))
.S IENS=$S(IEN:IEN_",",1:"+1,")
.S NAME=$P(X,U,2)
.S OFNME=$P(X,U,6)
.S AGENCY=$P(X,U,17)
.K FDA,IEN1
.S FDA(4,IENS,.01)=NAME
.S FDA(4,IENS,100)=OFNME
.S FDA(4,IENS,95)=$P(AGENCY,"~")
.D UPDATE^DIE("E","FDA","IEN1")
.I 'IEN S IEN=$G(IEN1(1))
.Q:'IEN
.S IENS="?+1,"_IEN_","
.K FDA
.S FDA(4.9999,IENS,.01)="DMIS"
.S FDA(4.9999,IENS,.02)=ID
.D UPDATE^DIE("E","FDA")
;
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[HXUMF218A 1151 printed Nov 22, 2024@17:20:20 Page 2
XUMF218A ;OIFO-OAK/RAM - Load DMIS ID's;04/15/02
+1 ;;8.0;KERNEL;**218,261**;Jul 10, 1995
+2 ;
+3 ;
EN ; -- entry point
+1 ;
+2 NEW ID,NAME,FDA,ERROR,IEN,IENS,X,XUMF,STANUM,OFNME,AGENCY
+3 ;
+4 SET XUMF=1
+5 ;
+6 SET ID=""
+7 FOR
SET ID=$ORDER(^TMP("XUMF ARRAY",$JOB,ID))
if ID=""
QUIT
Begin DoDot:1
+8 SET X=^TMP("XUMF ARRAY",$JOB,ID)
+9 SET STANUM=$PIECE(X,U,3)
+10 SET IEN=$$IEN^XUMF(4,"DMIS",ID)
+11 IF 'IEN
IF $GET(STANUM)'=""
SET IEN=$ORDER(^DIC(4,"D",STANUM,0))
+12 SET IENS=$SELECT(IEN:IEN_",",1:"+1,")
+13 SET NAME=$PIECE(X,U,2)
+14 SET OFNME=$PIECE(X,U,6)
+15 SET AGENCY=$PIECE(X,U,17)
+16 KILL FDA,IEN1
+17 SET FDA(4,IENS,.01)=NAME
+18 SET FDA(4,IENS,100)=OFNME
+19 SET FDA(4,IENS,95)=$PIECE(AGENCY,"~")
+20 DO UPDATE^DIE("E","FDA","IEN1")
+21 IF 'IEN
SET IEN=$GET(IEN1(1))
+22 if 'IEN
QUIT
+23 SET IENS="?+1,"_IEN_","
+24 KILL FDA
+25 SET FDA(4.9999,IENS,.01)="DMIS"
+26 SET FDA(4.9999,IENS,.02)=ID
+27 DO UPDATE^DIE("E","FDA")
End DoDot:1
+28 ;
+29 QUIT
+30 ;
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 ;
