XUMF333.m

XUMF333 ;OIFO-OAK/RAM - Add HCS data types ;02/21/02

 ;;8.0;KERNEL;**335**;Jul 10, 1995

 ;

 Q

 ;

 ;

POST ; -- post installation XU*8*333

 ;

 N XUMF,IENS,IEN,FDA,I,HCS,XXX

 ;

 S XUMF=1

 ;

 D KM,KM1,KM2,KM3,STUFF

 ;

 Q

 ;

KM ; -- add XUMF IMF EDIT STATUS to XUKERNEL

 ;

 N X,Y

 ;

 S X=$$FIND1^DIC(19,,"B","XUKERNEL")

 S Y="?+1,"

 ;

 S IENS=Y_X_","

 S FDA(19,"?1,",.01)="XUKERNEL"

 S FDA(19.01,"?+2,?1,",.01)="XUMF IMF EDIT STATUS"

 D UPDATE^DIE("","FDA")

 ;

 Q

 ;

KM1 ; -- add XUMF IMF EDIT STATUS to XUKERNEL

 ;

 N X,Y

 ;

 S X=$$FIND1^DIC(19,,"B","XUKERNEL")

 S Y="?+1,"

 ;

 S IENS=Y_X_","

 S FDA(19,"?1,",.01)="XUKERNEL"

 S FDA(19.01,"?+3,?1,",.01)="XUMF LOAD INSTITUTION"

 D UPDATE^DIE("","FDA")

 ;

 Q

 ;

KM2 ; -- add XUMF IMF EDIT STATUS to XUKERNEL

 ;

 N X,Y

 ;

 S X=$$FIND1^DIC(19,,"B","XUKERNEL")

 S Y="?+1,"

 ;

 S IENS=Y_X_","

 S FDA(19,"?1,",.01)="XUKERNEL"

 S FDA(19.01,"?+3,?1,",.01)="Patch XU*8*335 clean 4.1 and 4"

 D UPDATE^DIE("","FDA")

 ;

 Q

 ;

KM3 ; -- remove XUMF333 clean 4.1 and 4 if present

 ;

 N X,IENS,FDA

 ;

 S X=$$FIND1^DIC(19,,"B","XUMF333 clean 4.1 and 4")

 ;

 Q:'X

 ;

 S IENS=X_","

 S FDA(19,IENS,.01)="@"

 D UPDATE^DIE("","FDA")

 ;

 Q

 ;

STUFF ;

 ;

 S IEN=$O(^DIC(4.1,"B","HCS",0))

 S IENS=$S(IEN:IEN_",",1:"+1,")

 K FDA

 S FDA(4.1,IENS,.01)="HCS"

 S FDA(4.1,IENS,1)="HEALTH CARE SYSTEM"

 S FDA(4.1,IENS,3)="LOCAL"

 D UPDATE^DIE("E","FDA")

 ;

 S HCS=""

 F XXX=1:1 D  Q:HCS=""

 .S HCS=$P($T(HCS+XXX),";;",2)

 .S IEN=$S(HCS="":0,1:$O(^DIC(4,"B",HCS,0)))

 .S IENS=$S(IEN:IEN_",",1:"+1,")

 .;

 .K FDA

 .S FDA(4,IENS,.01)=HCS

 .S FDA(4,IENS,11)="LOCAL"

 .S FDA(4,IENS,13)="HCS"

 .D UPDATE^DIE("E","FDA")

 ;

 Q

 ;

HCS ;

 ;;VA GREATER LOS ANGELES (691)

 ;;VA HEARTLAND-EAST VISN15 (657)

 ;;VA HEARTLAND-WEST VISN15 (589)

 ;;VA CHICAGO HSC (537)

 ;;CENTRAL PLAINS NETWORK (636)

 ;;MONTANA HCS (436)

 ;;VA PACIFIC ISLANDS HCS (459)

 ;;NEW MEXICO HCS (501)

 ;;AMARILLO HCS (504)

 ;;MARYLAND HCS (512)

 ;;WEST TEXAS HCS (519)

 ;;BOSTON HCS (523)

 ;;UPSTATE NEW YORK HCS (528)

 ;;NORTH TEXAS HCS (549)

 ;;EASTERN COLORADO HCS (554)

 ;;NEW JERSEY HCS (561)

 ;;BLACK HILLS HCS (568)

 ;;CENTRAL CALIFORNIA HCS (570)

 ;;N FLORIDA/S GEORGIA HCS (573)

 ;;GREATER NEBRASKA HCS (597)

 ;;CENTRAL ARKANSAS HCS (598)

 ;;LONG BEACH HCS (600)

 ;;CENTRAL ALABAMA HCS (619)

 ;;HUDSON VALLEY HCS VAMC (620)

 ;;TENNESSEE VALLEY HCS (626)

 ;;PALO ALTO HCS (640)

 ;;PITTSBURGH HCS (646)

 ;;ROSEBURG HCS (653)

 ;;SIERRA NEVADA HCS (654)

 ;;SALT LAKE CITY HCS (660)

 ;;PUGET SOUND HCS (663)

 ;;SAN DIEGO HCS (664)

 ;;SOUTH TEXAS HCS (671)

 ;;CENTRAL TEXAS HCS (674)

 ;;EASTERN KANSAS HCS (677)

 ;;SOUTHERN ARIZONA VA HCS (678)

 ;;CONNECTICUT HCS (689)

 ;;EL PASO VA HCS (756)

 ;;NEW YORK HHS (630)

 ;

 ; do not include

 ;;EASTERN COLORADO HCS (554A4)

 ;;SOUTHERN COLORADO HCS

 ;;CENTRAL IOWA HCS (555)

 ;;ILLIANA HCS (550)

 ;;NORTHERN CALIFORNIA HCS (612)

 ;;SOUTHERN NEVADA HCS (593)

 ;;NORTHERN ARIZONA HCS (649)

 ;

 Q

 ;

CHK ; -- check site updating required

 ;

 N STA,IEN,FLAG,CHK

 ;

 S STA=$$STA^XUAF4(+$G(DUZ(2)))

 ;

 I STA="" W !!,"DUZ not defined.  Please log on." Q

 ;

 W @IOF,!,STA," ",$P($$NS^XUAF4(+DUZ(2)),U)

 ;

 S CHK=$$INST^XUMF333(+DUZ(2),.ERR)

 I CHK=1 D

 .W !!?5,"MISSING DATA - please fix",!

 .S I=0 F  S I=$O(ERR("FATAL",I)) Q:'I  D

 ..W !?5,ERR("FATAL",I)

 I CHK'=1 W " is okay"

 ;

 S STA=STA_"A"

 F  S STA=$O(^DIC(4,"D",STA)) Q:STA=""  D  Q:$G(FLAG)

 .I $E($$STA^XUAF4(DUZ(2)),1,3)'=$E(STA,1,3) S FLAG=1 Q

 .S IEN=$$IEN^XUAF4(STA)

 .S CHK=$$INST^XUMF333(+IEN,.ERR)

 .W !!,STA," ",$P($$NS^XUAF4(+IEN),U)

 .I CHK'=1 W " is okay" Q

 .I CHK=1 D

 ..W " is MISSING DATA - please fix",!

 ..S I=0 F  S I=$O(ERR("FATAL",I)) Q:'I  D

 ...W !?5,ERR("FATAL",I)

 .K ERR

 ;

 ;

 Q

 ;

INST(IEN,ERR) ; -- validate Institution entry FALSE=valid

 ;

 Q:'$G(IEN) "IEN null"

 ;

 S CNT=1

 ;

 D ZERO(IEN,.ERR,.CNT)

 D ADD1(IEN,.ERR,.CNT)

 D ADD2(IEN,.ERR,.CNT)

 D FTYP(IEN,.ERR,.CNT)

 D ND99(IEN,.ERR,.CNT)

 ;

 Q $S($D(ERR("FATAL")):1,$D(ERR("WARNING")):2,1:0)

 ;

ZERO(IEN,ERR,CNT) ; -- zero node

 ;

 N X

 ;

 S CNT=$G(CNT) S:'CNT CNT=1

 ;

 S X=$G(^DIC(4,+IEN,0))

 I $P(X,U,2)="" D

 .S ERR("FATAL",CNT)="STATE is missing",CNT=CNT+1

 ;

 Q

 ;

ADD1(IEN,ERR,CNT) ; -- address node

 ;

 N X,I

 ;

 S CNT=$G(CNT) S:'CNT CNT=1

 ;

 S X=$G(^DIC(4,+IEN,1))

 I $P(X,U,1)="" D

 .S ERR("FATAL",CNT)="Physical address St. line 1 missing"

 .S CNT=CNT+1

 I $P(X,U,3)="" D

 .S ERR("FATAL",CNT)="Physical address City missing"

 .S CNT=CNT+1

 I $P(X,U,4)="" D

 .S ERR("FATAL",CNT)="Physical address ZIP missing"

 .S CNT=CNT+1

 I $P(X,U,2)="" D

 .S ERR("WARNING",CNT)="Physical address St. line 2 missing"

 .S CNT=CNT+1

 ;

 Q

 ;

ADD2(IEN,ERR,CNT) ; -- mailing address node

 ;

 N X,I

 ;

 S CNT=$G(CNT) S:'CNT CNT=1

 ;

 S X=$G(^DIC(4,+IEN,4))

 I $P(X,U,1)="" D

 .S ERR("FATAL",CNT)="Mailing address St. line 1 missing"

 .S CNT=CNT+1

 I $P(X,U,3)="" D

 .S ERR("FATAL",CNT)="Mailing address City missing"

 .S CNT=CNT+1

 I $P(X,U,4)="" D

 .S ERR("FATAL",CNT)="Mailing address State missing"

 .S CNT=CNT+1

 I $P(X,U,5)="" D

 .S ERR("FATAL",CNT)="Mailing address ZIP missing"

 .S CNT=CNT+1

 I $P(X,U,2)="" D

 .S ERR("WARNING",CNT)="Mailing address St. line 2 missing"

 .S CNT=CNT+1

 ;

 Q

 ;

FTYP(IEN,ERR,CNT) ; -- facility type node

 ;

 N X

 ;

 S CNT=$G(CNT) S:'CNT CNT=1

 ;

 S X=$G(^DIC(4,+IEN,3))

 I 'X D

 .S ERR("FATAL",CNT)="FACILITY TYPE is missing",CNT=CNT+1

 I $P($G(^DIC(4.1,+X,0)),U,4)'="N" D

 .S ERR("FATAL",CNT)="FACILITY TYPE is not NATIONAL",CNT=CNT+1

 ;

 Q

 ;

ND99(IEN,ERR,CNT) ; -- 99 node

 ;

 N X

 ;

 S CNT=$G(CNT) S:'CNT CNT=1

 ;

 S X=$G(^DIC(4,+IEN,99))

 I $P(X,U,3)="" D

 .S ERR("FATAL",CNT)="OFFICIAL VA NAME is missing",CNT=CNT+1

 I ($P(X,U,4))&($E($$NS^XUAF4(+IEN),1,2)'="ZZ") D

 .S ERR("FATAL",CNT)="Inactive facility NAME not ZZ'd",CNT=CNT+1

 ;

 Q

 ;

C4 ; -- clean up Institution file

 ;

 D RIP,CFTYP,GET

 ;

 Q

 ;

RIP ; -- remove from all inactive and local the associations visn & parent

 ;

 N IEN

 ;

 S IEN=0

 F  S IEN=$O(^DIC(4,IEN)) Q:'IEN  D

 .I $P($G(^DIC(4,+IEN,0)),U,11)="N",'$P($G(^DIC(4,+IEN,99)),U,4) Q

 .D IFF^XUMF333(IEN)

 ;

 Q

 ;

IFF(IEN) ; -- inactive facility remove VISN and parent association

 ;

 N FDA,IENS,XUMF

 ;

 S XUMF=1

 ;

 S IENS="1,"_IEN_","

 S FDA(4.014,IENS,.01)="@"

 S IENS="2,"_IEN_","

 S FDA(4.014,IENS,.01)="@"

 D FILE^DIE("E","FDA")

 ;

 Q

 ;

CFTYP ; - clean 4.1

 ;

 N FDA,IENS,XUMF,IEN

 ;

 M ^TMP("XUMF 4.1",$J)=^DIC(4.1)

 ;

 S XUMF=1

 ;

 S IEN=0

 F  S IEN=$O(^DIC(4.1,IEN)) Q:'IEN  D

 .S IENS=IEN_","

 .K FDA

 .S FDA(4.1,IENS,.01)="@"

 .D FILE^DIE("E","FDA")

 ;

 S IEN=0

 F  S IEN=$O(^DIC(4,IEN)) Q:'IEN  D

 .S IENS=IEN_","

 .K FDA

 .S FDA(4,IENS,13)="@"

 .D FILE^DIE("E","FDA")

 ;

 Q

 ;

GET ; -- get Institution Master File (IMF) and Facility Types

 ;

 W !!,"...getting Facility Types - wait please 5 min..."

 D LOAD^XUMF(4.1)

 W !!,"...getting Institutions - wait please 10 min..."

 D LOAD^XUMF(4)

 ;

 Q

 ;

SCN(IEN,XUMF) ; screen out HCS entries

 ;

 ; IEN = Institution Internal Entry Number to check

 ;

 S XUMF=$G(XUMF) Q:XUMF 1

 ;

 I $O(^DIC(4.1,"B","HCS",0))=+$G(^DIC(4,+IEN,3)) Q 0

 ;

 Q 1

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---XUMF333   7374     printed  Sep 23, 2025@19:46:27                                                                                                                                                                                                     Page 2

XUMF333   ;OIFO-OAK/RAM - Add HCS data types ;02/21/02

 +1       ;;8.0;KERNEL;**335**;Jul 10, 1995

 +2       ;

 +3        QUIT 

 +4       ;

 +5       ;

POST      ; -- post installation XU*8*333

 +1       ;

 +2        NEW XUMF,IENS,IEN,FDA,I,HCS,XXX

 +3       ;

 +4        SET XUMF=1

 +5       ;

 +6        DO KM

           DO KM1

           DO KM2

           DO KM3

           DO STUFF

 +7       ;

 +8        QUIT 

 +9       ;

KM        ; -- add XUMF IMF EDIT STATUS to XUKERNEL

 +1       ;

 +2        NEW X,Y

 +3       ;

 +4        SET X=$$FIND1^DIC(19,,"B","XUKERNEL")

 +5        SET Y="?+1,"

 +6       ;

 +7        SET IENS=Y_X_","

 +8        SET FDA(19,"?1,",.01)="XUKERNEL"

 +9        SET FDA(19.01,"?+2,?1,",.01)="XUMF IMF EDIT STATUS"

 +10       DO UPDATE^DIE("","FDA")

 +11      ;

 +12       QUIT 

 +13      ;

KM1       ; -- add XUMF IMF EDIT STATUS to XUKERNEL

 +1       ;

 +2        NEW X,Y

 +3       ;

 +4        SET X=$$FIND1^DIC(19,,"B","XUKERNEL")

 +5        SET Y="?+1,"

 +6       ;

 +7        SET IENS=Y_X_","

 +8        SET FDA(19,"?1,",.01)="XUKERNEL"

 +9        SET FDA(19.01,"?+3,?1,",.01)="XUMF LOAD INSTITUTION"

 +10       DO UPDATE^DIE("","FDA")

 +11      ;

 +12       QUIT 

 +13      ;

KM2       ; -- add XUMF IMF EDIT STATUS to XUKERNEL

 +1       ;

 +2        NEW X,Y

 +3       ;

 +4        SET X=$$FIND1^DIC(19,,"B","XUKERNEL")

 +5        SET Y="?+1,"

 +6       ;

 +7        SET IENS=Y_X_","

 +8        SET FDA(19,"?1,",.01)="XUKERNEL"

 +9        SET FDA(19.01,"?+3,?1,",.01)="Patch XU*8*335 clean 4.1 and 4"

 +10       DO UPDATE^DIE("","FDA")

 +11      ;

 +12       QUIT 

 +13      ;

KM3       ; -- remove XUMF333 clean 4.1 and 4 if present

 +1       ;

 +2        NEW X,IENS,FDA

 +3       ;

 +4        SET X=$$FIND1^DIC(19,,"B","XUMF333 clean 4.1 and 4")

 +5       ;

 +6        if 'X

               QUIT 

 +7       ;

 +8        SET IENS=X_","

 +9        SET FDA(19,IENS,.01)="@"

 +10       DO UPDATE^DIE("","FDA")

 +11      ;

 +12       QUIT 

 +13      ;

STUFF     ;

 +1       ;

 +2        SET IEN=$ORDER(^DIC(4.1,"B","HCS",0))

 +3        SET IENS=$SELECT(IEN:IEN_",",1:"+1,")

 +4        KILL FDA

 +5        SET FDA(4.1,IENS,.01)="HCS"

 +6        SET FDA(4.1,IENS,1)="HEALTH CARE SYSTEM"

 +7        SET FDA(4.1,IENS,3)="LOCAL"

 +8        DO UPDATE^DIE("E","FDA")

 +9       ;

 +10       SET HCS=""

 +11       FOR XXX=1:1

               Begin DoDot:1

 +12               SET HCS=$PIECE($TEXT(HCS+XXX),";;",2)

 +13               SET IEN=$SELECT(HCS="":0,1:$ORDER(^DIC(4,"B",HCS,0)))

 +14               SET IENS=$SELECT(IEN:IEN_",",1:"+1,")

 +15      ;

 +16               KILL FDA

 +17               SET FDA(4,IENS,.01)=HCS

 +18               SET FDA(4,IENS,11)="LOCAL"

 +19               SET FDA(4,IENS,13)="HCS"

 +20               DO UPDATE^DIE("E","FDA")

               End DoDot:1

               if HCS=""

                   QUIT 

 +21      ;

 +22       QUIT 

 +23      ;

HCS       ;

 +1       ;;VA GREATER LOS ANGELES (691)

 +2       ;;VA HEARTLAND-EAST VISN15 (657)

 +3       ;;VA HEARTLAND-WEST VISN15 (589)

 +4       ;;VA CHICAGO HSC (537)

 +5       ;;CENTRAL PLAINS NETWORK (636)

 +6       ;;MONTANA HCS (436)

 +7       ;;VA PACIFIC ISLANDS HCS (459)

 +8       ;;NEW MEXICO HCS (501)

 +9       ;;AMARILLO HCS (504)

 +10      ;;MARYLAND HCS (512)

 +11      ;;WEST TEXAS HCS (519)

 +12      ;;BOSTON HCS (523)

 +13      ;;UPSTATE NEW YORK HCS (528)

 +14      ;;NORTH TEXAS HCS (549)

 +15      ;;EASTERN COLORADO HCS (554)

 +16      ;;NEW JERSEY HCS (561)

 +17      ;;BLACK HILLS HCS (568)

 +18      ;;CENTRAL CALIFORNIA HCS (570)

 +19      ;;N FLORIDA/S GEORGIA HCS (573)

 +20      ;;GREATER NEBRASKA HCS (597)

 +21      ;;CENTRAL ARKANSAS HCS (598)

 +22      ;;LONG BEACH HCS (600)

 +23      ;;CENTRAL ALABAMA HCS (619)

 +24      ;;HUDSON VALLEY HCS VAMC (620)

 +25      ;;TENNESSEE VALLEY HCS (626)

 +26      ;;PALO ALTO HCS (640)

 +27      ;;PITTSBURGH HCS (646)

 +28      ;;ROSEBURG HCS (653)

 +29      ;;SIERRA NEVADA HCS (654)

 +30      ;;SALT LAKE CITY HCS (660)

 +31      ;;PUGET SOUND HCS (663)

 +32      ;;SAN DIEGO HCS (664)

 +33      ;;SOUTH TEXAS HCS (671)

 +34      ;;CENTRAL TEXAS HCS (674)

 +35      ;;EASTERN KANSAS HCS (677)

 +36      ;;SOUTHERN ARIZONA VA HCS (678)

 +37      ;;CONNECTICUT HCS (689)

 +38      ;;EL PASO VA HCS (756)

 +39      ;;NEW YORK HHS (630)

 +40      ;

 +41      ; do not include

 +42      ;;EASTERN COLORADO HCS (554A4)

 +43      ;;SOUTHERN COLORADO HCS

 +44      ;;CENTRAL IOWA HCS (555)

 +45      ;;ILLIANA HCS (550)

 +46      ;;NORTHERN CALIFORNIA HCS (612)

 +47      ;;SOUTHERN NEVADA HCS (593)

 +48      ;;NORTHERN ARIZONA HCS (649)

 +49      ;

 +50       QUIT 

 +51      ;

CHK       ; -- check site updating required

 +1       ;

 +2        NEW STA,IEN,FLAG,CHK

 +3       ;

 +4        SET STA=$$STA^XUAF4(+$GET(DUZ(2)))

 +5       ;

 +6        IF STA=""

               WRITE !!,"DUZ not defined.  Please log on."

               QUIT 

 +7       ;

 +8        WRITE @IOF,!,STA," ",$PIECE($$NS^XUAF4(+DUZ(2)),U)

 +9       ;

 +10       SET CHK=$$INST^XUMF333(+DUZ(2),.ERR)

 +11       IF CHK=1

               Begin DoDot:1

 +12               WRITE !!?5,"MISSING DATA - please fix",!

 +13               SET I=0

                   FOR 

                       SET I=$ORDER(ERR("FATAL",I))

                       if 'I

                           QUIT 

                       Begin DoDot:2

 +14                       WRITE !?5,ERR("FATAL",I)

                       End DoDot:2

               End DoDot:1

 +15       IF CHK'=1

               WRITE " is okay"

 +16      ;

 +17       SET STA=STA_"A"

 +18       FOR 

               SET STA=$ORDER(^DIC(4,"D",STA))

               if STA=""

                   QUIT 

               Begin DoDot:1

 +19               IF $EXTRACT($$STA^XUAF4(DUZ(2)),1,3)'=$EXTRACT(STA,1,3)

                       SET FLAG=1

                       QUIT 

 +20               SET IEN=$$IEN^XUAF4(STA)

 +21               SET CHK=$$INST^XUMF333(+IEN,.ERR)

 +22               WRITE !!,STA," ",$PIECE($$NS^XUAF4(+IEN),U)

 +23               IF CHK'=1

                       WRITE " is okay"

                       QUIT 

 +24               IF CHK=1

                       Begin DoDot:2

 +25                       WRITE " is MISSING DATA - please fix",!

 +26                       SET I=0

                           FOR 

                               SET I=$ORDER(ERR("FATAL",I))

                               if 'I

                                   QUIT 

                               Begin DoDot:3

 +27                               WRITE !?5,ERR("FATAL",I)

                               End DoDot:3

                       End DoDot:2

 +28               KILL ERR

               End DoDot:1

               if $GET(FLAG)

                   QUIT 

 +29      ;

 +30      ;

 +31       QUIT 

 +32      ;

INST(IEN,ERR) ; -- validate Institution entry FALSE=valid

 +1       ;

 +2        if '$GET(IEN)

               QUIT "IEN null"

 +3       ;

 +4        SET CNT=1

 +5       ;

 +6        DO ZERO(IEN,.ERR,.CNT)

 +7        DO ADD1(IEN,.ERR,.CNT)

 +8        DO ADD2(IEN,.ERR,.CNT)

 +9        DO FTYP(IEN,.ERR,.CNT)

 +10       DO ND99(IEN,.ERR,.CNT)

 +11      ;

 +12       QUIT $SELECT($DATA(ERR("FATAL")):1,$DATA(ERR("WARNING")):2,1:0)

 +13      ;

ZERO(IEN,ERR,CNT) ; -- zero node

 +1       ;

 +2        NEW X

 +3       ;

 +4        SET CNT=$GET(CNT)

           if 'CNT

               SET CNT=1

 +5       ;

 +6        SET X=$GET(^DIC(4,+IEN,0))

 +7        IF $PIECE(X,U,2)=""

               Begin DoDot:1

 +8                SET ERR("FATAL",CNT)="STATE is missing"

                   SET CNT=CNT+1

               End DoDot:1

 +9       ;

 +10       QUIT 

 +11      ;

ADD1(IEN,ERR,CNT) ; -- address node

 +1       ;

 +2        NEW X,I

 +3       ;

 +4        SET CNT=$GET(CNT)

           if 'CNT

               SET CNT=1

 +5       ;

 +6        SET X=$GET(^DIC(4,+IEN,1))

 +7        IF $PIECE(X,U,1)=""

               Begin DoDot:1

 +8                SET ERR("FATAL",CNT)="Physical address St. line 1 missing"

 +9                SET CNT=CNT+1

               End DoDot:1

 +10       IF $PIECE(X,U,3)=""

               Begin DoDot:1

 +11               SET ERR("FATAL",CNT)="Physical address City missing"

 +12               SET CNT=CNT+1

               End DoDot:1

 +13       IF $PIECE(X,U,4)=""

               Begin DoDot:1

 +14               SET ERR("FATAL",CNT)="Physical address ZIP missing"

 +15               SET CNT=CNT+1

               End DoDot:1

 +16       IF $PIECE(X,U,2)=""

               Begin DoDot:1

 +17               SET ERR("WARNING",CNT)="Physical address St. line 2 missing"

 +18               SET CNT=CNT+1

               End DoDot:1

 +19      ;

 +20       QUIT 

 +21      ;

ADD2(IEN,ERR,CNT) ; -- mailing address node

 +1       ;

 +2        NEW X,I

 +3       ;

 +4        SET CNT=$GET(CNT)

           if 'CNT

               SET CNT=1

 +5       ;

 +6        SET X=$GET(^DIC(4,+IEN,4))

 +7        IF $PIECE(X,U,1)=""

               Begin DoDot:1

 +8                SET ERR("FATAL",CNT)="Mailing address St. line 1 missing"

 +9                SET CNT=CNT+1

               End DoDot:1

 +10       IF $PIECE(X,U,3)=""

               Begin DoDot:1

 +11               SET ERR("FATAL",CNT)="Mailing address City missing"

 +12               SET CNT=CNT+1

               End DoDot:1

 +13       IF $PIECE(X,U,4)=""

               Begin DoDot:1

 +14               SET ERR("FATAL",CNT)="Mailing address State missing"

 +15               SET CNT=CNT+1

               End DoDot:1

 +16       IF $PIECE(X,U,5)=""

               Begin DoDot:1

 +17               SET ERR("FATAL",CNT)="Mailing address ZIP missing"

 +18               SET CNT=CNT+1

               End DoDot:1

 +19       IF $PIECE(X,U,2)=""

               Begin DoDot:1

 +20               SET ERR("WARNING",CNT)="Mailing address St. line 2 missing"

 +21               SET CNT=CNT+1

               End DoDot:1

 +22      ;

 +23       QUIT 

 +24      ;

FTYP(IEN,ERR,CNT) ; -- facility type node

 +1       ;

 +2        NEW X

 +3       ;

 +4        SET CNT=$GET(CNT)

           if 'CNT

               SET CNT=1

 +5       ;

 +6        SET X=$GET(^DIC(4,+IEN,3))

 +7        IF 'X

               Begin DoDot:1

 +8                SET ERR("FATAL",CNT)="FACILITY TYPE is missing"

                   SET CNT=CNT+1

               End DoDot:1

 +9        IF $PIECE($GET(^DIC(4.1,+X,0)),U,4)'="N"

               Begin DoDot:1

 +10               SET ERR("FATAL",CNT)="FACILITY TYPE is not NATIONAL"

                   SET CNT=CNT+1

               End DoDot:1

 +11      ;

 +12       QUIT 

 +13      ;

ND99(IEN,ERR,CNT) ; -- 99 node

 +1       ;

 +2        NEW X

 +3       ;

 +4        SET CNT=$GET(CNT)

           if 'CNT

               SET CNT=1

 +5       ;

 +6        SET X=$GET(^DIC(4,+IEN,99))

 +7        IF $PIECE(X,U,3)=""

               Begin DoDot:1

 +8                SET ERR("FATAL",CNT)="OFFICIAL VA NAME is missing"

                   SET CNT=CNT+1

               End DoDot:1

 +9        IF ($PIECE(X,U,4))&($EXTRACT($$NS^XUAF4(+IEN),1,2)'="ZZ")

               Begin DoDot:1

 +10               SET ERR("FATAL",CNT)="Inactive facility NAME not ZZ'd"

                   SET CNT=CNT+1

               End DoDot:1

 +11      ;

 +12       QUIT 

 +13      ;

C4        ; -- clean up Institution file

 +1       ;

 +2        DO RIP

           DO CFTYP

           DO GET

 +3       ;

 +4        QUIT 

 +5       ;

RIP       ; -- remove from all inactive and local the associations visn & parent

 +1       ;

 +2        NEW IEN

 +3       ;

 +4        SET IEN=0

 +5        FOR 

               SET IEN=$ORDER(^DIC(4,IEN))

               if 'IEN

                   QUIT 

               Begin DoDot:1

 +6                IF $PIECE($GET(^DIC(4,+IEN,0)),U,11)="N"

                       IF '$PIECE($GET(^DIC(4,+IEN,99)),U,4)

                           QUIT 

 +7                DO IFF^XUMF333(IEN)

               End DoDot:1

 +8       ;

 +9        QUIT 

 +10      ;

IFF(IEN)  ; -- inactive facility remove VISN and parent association

 +1       ;

 +2        NEW FDA,IENS,XUMF

 +3       ;

 +4        SET XUMF=1

 +5       ;

 +6        SET IENS="1,"_IEN_","

 +7        SET FDA(4.014,IENS,.01)="@"

 +8        SET IENS="2,"_IEN_","

 +9        SET FDA(4.014,IENS,.01)="@"

 +10       DO FILE^DIE("E","FDA")

 +11      ;

 +12       QUIT 

 +13      ;

CFTYP     ; - clean 4.1

 +1       ;

 +2        NEW FDA,IENS,XUMF,IEN

 +3       ;

 +4        MERGE ^TMP("XUMF 4.1",$JOB)=^DIC(4.1)

 +5       ;

 +6        SET XUMF=1

 +7       ;

 +8        SET IEN=0

 +9        FOR 

               SET IEN=$ORDER(^DIC(4.1,IEN))

               if 'IEN

                   QUIT 

               Begin DoDot:1

 +10               SET IENS=IEN_","

 +11               KILL FDA

 +12               SET FDA(4.1,IENS,.01)="@"

 +13               DO FILE^DIE("E","FDA")

               End DoDot:1

 +14      ;

 +15       SET IEN=0

 +16       FOR 

               SET IEN=$ORDER(^DIC(4,IEN))

               if 'IEN

                   QUIT 

               Begin DoDot:1

 +17               SET IENS=IEN_","

 +18               KILL FDA

 +19               SET FDA(4,IENS,13)="@"

 +20               DO FILE^DIE("E","FDA")

               End DoDot:1

 +21      ;

 +22       QUIT 

 +23      ;

GET       ; -- get Institution Master File (IMF) and Facility Types

 +1       ;

 +2        WRITE !!,"...getting Facility Types - wait please 5 min..."

 +3        DO LOAD^XUMF(4.1)

 +4        WRITE !!,"...getting Institutions - wait please 10 min..."

 +5        DO LOAD^XUMF(4)

 +6       ;

 +7        QUIT 

 +8       ;

SCN(IEN,XUMF) ; screen out HCS entries

 +1       ;

 +2       ; IEN = Institution Internal Entry Number to check

 +3       ;

 +4        SET XUMF=$GET(XUMF)

           if XUMF

               QUIT 1

 +5       ;

 +6        IF $ORDER(^DIC(4.1,"B","HCS",0))=+$GET(^DIC(4,+IEN,3))

               QUIT 0

 +7       ;

 +8        QUIT 1

 +9       ;