IBTASFAC.m

IBTASFAC ; AITC/MRD - TAS RPC - Facilities RPC ;Feb 20, 2019@13:53:52

 ;;2.0;INTEGRATED BILLING;**638**;21-MAR-94;Build 16

 ;Per VA Directive 6402, this routine should not be modified.

 ;

 Q

 ;

 ; The Facilities RPC is used by the TAS application to maintain

 ; a mapping of VISNs to Stations, including the state of each

 ; Station and which Stations are also Divisions.  This information

 ; comes from file# 4, Institution, most of which is pushed out to

 ; each site from FORUM.  Each site may add local entries.  Local

 ; entries will not be returned by this RPC.  The TAS application

 ; also maintains a mapping of CPACs to VISNs.  That information

 ; cannot be found on VistA and comes from another source, such as

 ; a published PDF listing all CPACs and VISNs.

 ;

FACILITY(RESULT,ARG) ;

 ;

 N IBLIST

 ;

 S RESULT=$NA(^TMP("JSON",$J))

 K @RESULT

 ;

 D VISNS(.IBLIST)

 D DIVISIONS(.IBLIST)

 D STATIONS(.IBLIST)

 D RESULTS(.IBLIST,RESULT)

 ;

 Q

 ;

 ; VISNS builds an array listing all VISNs.  It will skip

 ; VISN 99 and any site-defined VISNs, identified by having

 ; anything after the two-digit number in the VISN name.

 ; Format of array:

 ;   IBLIST(VISN IEN) = VISN Name

 ;

VISNS(IBLIST) ;

 ;

 N IBVIEN,IBVISN,IBVISNNAME

 ;

 S IBVISN="VISN"

 F  S IBVISN=$O(^DIC(4,"B",IBVISN)) Q:IBVISN'?1"VISN".E  D

 . I IBVISN'?1"VISN "1.2N Q

 . I $P(IBVISN," ",2)'<99 Q

 . S IBVIEN=$O(^DIC(4,"B",IBVISN,0))

 . ;

 . ; Add a leading zero if the VISN number is a single digit.

 . ;

 . S IBVISNNAME=IBVISN

 . I $L($P(IBVISN," ",2))=1 S IBVISNNAME="VISN 0"_$P(IBVISN," ",2)

 . S IBLIST(IBVIEN)=IBVISNNAME

 . Q

 Q

 ;

 ; DIVISIONS gathers the list of Divisions, which must be done

 ; before building the list of Stations.  Only active, National

 ; entries will be included.

 ; Format of array:

 ;   IBLIST(VISN IEN, Division IEN) = Division #

 ;

DIVISIONS(IBLIST) ;

 ;

 N IBDIVISION,IBIDNO,IBINST,IBPARENTDIV,IBPARENTVISN,IBVISN

 ;

 S IBVISN=$O(^DIC(4.05,"B","VISN",""))

 S IBDIVISION=$O(^DIC(4.05,"B","PARENT FACILITY",""))

 ;

 S IBINST=0

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

 . I $$GET1^DIQ(4,IBINST,11,"I")'="N" Q  ; Skip if not a National entry (i.e. skip local entries).

 . I $$GET1^DIQ(4,IBINST,101,"I")=1 Q  ; Skip if the Inactive Facility Flag is '1'.

 . I $E($$GET1^DIQ(4,IBINST,.01),1,2)="ZZ" Q  ; Skip any entries beginning with "ZZ".

 . ;

 . ; Determine the parent VISN.

 . ;

 . S IBPARENTVISN=$O(^DIC(4,IBINST,7,"B",IBVISN,""))

 . I IBPARENTVISN'="" S IBPARENTVISN=$$GET1^DIQ(4.014,IBPARENTVISN_","_IBINST,1,"I")

 . I IBPARENTVISN="" Q

 . ;

 . ; Quit if the parent VISN is not on the list of VISNs.

 . ; Quit if this entry is the parent VISN.

 . ;

 . I '$D(IBLIST(IBPARENTVISN)) Q

 . I IBPARENTVISN=IBINST Q

 . ;

 . ; Determine the parent Division.

 . ;

 . S IBPARENTDIV=$O(^DIC(4,IBINST,7,"B",IBDIVISION,""))

 . I IBPARENTDIV'="" S IBPARENTDIV=$$GET1^DIQ(4.014,IBPARENTDIV_","_IBINST,1,"I")

 . I IBPARENTDIV="" Q

 . ;

 . ; Quit if the parent VISN and parent Division are the same.

 . ; Quit if the parent Division has no Station Number.

 . ; Quit if the Station Number is other than three digits.

 . ;

 . I IBPARENTVISN=IBPARENTDIV Q

 . ;

 . S IBIDNO=$$GET1^DIQ(4,IBPARENTDIV,99)

 . I IBIDNO="" Q

 . I IBIDNO'?3N Q

 . ;

 . ; Divisions are identified two ways:  a) it lists itself as a parent;

 . ; b) the Station Number (field# 99) is the same as the IEN.

 . ; If either is true, add this as a Division.

 . ;

 . I IBPARENTDIV=IBINST S IBLIST(IBPARENTVISN,IBPARENTDIV)=IBIDNO Q

 . I $$GET1^DIQ(4,IBINST,99)=IBINST S IBLIST(IBPARENTVISN,IBPARENTDIV)=IBIDNO

 . ;

 . Q

 Q

 ;

 ; STATIONS builds a list of stations associated with each Division

 ; and VISN.  Only active, National entries will be included.

 ; Format of array:

 ;   IBLIST(VISN IEN, Division IEN, Station IEN) = ""

 ;

STATIONS(IBLIST) ;

 ;

 N IBDIVISION,IBINST,IBPARENTDIV,IBPARENTVISN,IBVISN

 ;

 S IBVISN=$O(^DIC(4.05,"B","VISN",""))

 S IBDIVISION=$O(^DIC(4.05,"B","PARENT FACILITY",""))

 ;

 S IBINST=0

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

 . I $$GET1^DIQ(4,IBINST,11,"I")'="N" Q  ; Skip if not a National entry (i.e. skip local entries).

 . I $$GET1^DIQ(4,IBINST,101,"I")=1 Q  ; Skip if the Inactive Facility Flag is '1'.

 . I $E($$GET1^DIQ(4,IBINST,.01),1,2)="ZZ" Q  ; Skip any entries beginning with "ZZ".

 . ;

 . ; Determine the parent VISN.

 . ;

 . S IBPARENTVISN=$O(^DIC(4,IBINST,7,"B",IBVISN,""))

 . I IBPARENTVISN'="" S IBPARENTVISN=$$GET1^DIQ(4.014,IBPARENTVISN_","_IBINST,1,"I")

 . I IBPARENTVISN="" Q

 . ;

 . ; Quit if the parent VISN is not on the list of VISNs.

 . ;

 . I '$D(IBLIST(IBPARENTVISN)) Q

 . ;

 . ; Determine the parent Division.

 . ;

 . S IBPARENTDIV=$O(^DIC(4,IBINST,7,"B",IBDIVISION,""))

 . I IBPARENTDIV'="" S IBPARENTDIV=$$GET1^DIQ(4.014,IBPARENTDIV_","_IBINST,1,"I")

 . I IBPARENTDIV="" Q

 . ;

 . ; Do not add a Division to the list of Stations for itself.

 . ; Divisions are identified two ways:  a) it lists itself as a parent;

 . ; b) the Station Number (field# 99) is the same as the IEN.  Either

 . ; may be true

 . ;

 . I IBPARENTDIV=IBINST Q

 . I $$GET1^DIQ(4,IBINST,99)=IBINST Q

 . ;

 . ; If the parent VISN is on the list of VISNs, and the parent Division

 . ; is on the list of Divisions, then add this station to the list.

 . ;

 . I $D(IBLIST(IBPARENTVISN,IBPARENTDIV)) S IBLIST(IBPARENTVISN,IBPARENTDIV,IBINST)=""

 . ;

 . Q

 Q

 ;

 ; RESULTS builds the temp global to be passed into ENCODE^XLFJSON,

 ; which will create the JSON.

 ; Format of array:

 ;   IBLIST(VISN IEN) = VISN Name

 ;   IBLIST(VISN IEN, Division IEN) = Division #

 ;   IBLIST(VISN IEN, Division IEN, Station IEN) = ""

 ;

RESULTS(IBLIST,RESULT) ; Move into result in vaid json format

 ;

 N IBDIV,IBDIVCNT,IBIDNO,IBNAME,IBSTACNT,IBSTATE

 N IBSTATION,IBTEMP,IBVISN,IBVISNCNT,X

 ;

 S IBTEMP=$NA(^TMP("IBTAS",$J))

 K @IBTEMP

 ;

 S IBVISNCNT=0

 ;

 S IBVISN=0

 F  S IBVISN=$O(IBLIST(IBVISN)) Q:'IBVISN  I $D(IBLIST(IBVISN))=11 D

 . S IBVISNCNT=IBVISNCNT+1

 . S @IBTEMP@("VISNs",IBVISNCNT,"Name")=IBLIST(IBVISN)

 . ;

 . S IBDIVCNT=0

 . ;

 . S IBDIV=0

 . F  S IBDIV=$O(IBLIST(IBVISN,IBDIV)) Q:'IBDIV  D

 . . ;

 . . S IBIDNO=$$GET1^DIQ(4,IBDIV,99)

 . . S IBNAME=$$GET1^DIQ(4,IBDIV,.01)

 . . S IBNAME=$$NAME(IBNAME)

 . . S IBSTATE=$$GET1^DIQ(4,IBDIV,.02,"I")

 . . S IBSTATE=$$GET1^DIQ(5,IBSTATE,1)

 . . ;

 . . S IBDIVCNT=IBDIVCNT+1

 . . ;

 . . S @IBTEMP@("VISNs",IBVISNCNT,"Divisions",IBDIVCNT,"ID")=IBIDNO

 . . S @IBTEMP@("VISNs",IBVISNCNT,"Divisions",IBDIVCNT,"ID","IEN")=IBDIV

 . . S @IBTEMP@("VISNs",IBVISNCNT,"Divisions",IBDIVCNT,"Name")=IBNAME

 . . S @IBTEMP@("VISNs",IBVISNCNT,"Divisions",IBDIVCNT,"State")=IBSTATE

 . . ;

 . . S IBSTACNT=0

 . . ;

 . . S IBSTATION=0

 . . F  S IBSTATION=$O(IBLIST(IBVISN,IBDIV,IBSTATION)) Q:'IBSTATION  D

 . . . ;

 . . . S IBIDNO=$$GET1^DIQ(4,IBSTATION,99)

 . . . S IBNAME=$$GET1^DIQ(4,IBSTATION,.01)

 . . . S IBNAME=$$NAME(IBNAME)

 . . . S IBSTATE=$$GET1^DIQ(4,IBSTATION,.02,"I")

 . . . S IBSTATE=$$GET1^DIQ(5,IBSTATE,1)

 . . . ;

 . . . S IBSTACNT=IBSTACNT+1

 . . . ;

 . . . S @IBTEMP@("VISNs",IBVISNCNT,"Divisions",IBDIVCNT,"Stations",IBSTACNT,"ID")=IBIDNO

 . . . S @IBTEMP@("VISNs",IBVISNCNT,"Divisions",IBDIVCNT,"Stations",IBSTACNT,"Name")=IBNAME

 . . . S @IBTEMP@("VISNs",IBVISNCNT,"Divisions",IBDIVCNT,"Stations",IBSTACNT,"State")=IBSTATE

 . . . ;

 . . . Q

 . . Q

 . Q

 ;

 ; Call the utility ENCODE to translate the results into valid JSON.

 ;

 D ENCODE^XLFJSON(IBTEMP,RESULT)

 S @RESULT@(1)="["_@RESULT@(1)

 S X=$O(@RESULT@(""),-1)

 S @RESULT@(X)=@RESULT@(X)_"]"

 ;

 Q

 ;

REPORT(EXCEL) ; Build the list and display the results.

 ;

 ; This procedure exists mainly to aid in the development and

 ; testing of the RPC.

 ;

 ; EXCEL - Optional input parameter.  If 1, then the output

 ; will be "^" delimited.

 ;

 N IBLIST,RESULT

 ;

 S RESULT=$NA(^TMP("JSON",$J))

 K @RESULT

 ;

 D VISNS(.IBLIST)

 D DIVISIONS(.IBLIST)

 D STATIONS(.IBLIST)

 ;

 D DISPLAY(.IBLIST,$G(EXCEL))

 ;

 Q

 ;

DISPLAY(IBLIST,EXCEL) ; Display results.

 ;

 N IBCOUNT,IBCPAC,IBDIV,IBDIVNAME,IBDIVNO,IBDIVSTATE,IBSTATION

 N IBSTNIDNO,IBSTNNAME,IBSTNSTATE,IBVISN

 ;

 I '$G(EXCEL) S EXCEL=0

 ;

 ; Set up array of VISN-to-CPAC mapping.

 ;

 I EXCEL D CPACMAP(.IBCPAC)

 ;

 S IBCOUNT=0

 S IBVISN=0

 F  S IBVISN=$O(IBLIST(IBVISN)) Q:'IBVISN  I $D(IBLIST(IBVISN))=11 D

 . ;

 . I 'EXCEL W !!,IBLIST(IBVISN)

 . ;

 . S IBDIV=0

 . F  S IBDIV=$O(IBLIST(IBVISN,IBDIV)) Q:'IBDIV  D

 . . ;

 . . S IBDIVNO=$$GET1^DIQ(4,IBDIV,99)

 . . S IBDIVNAME=$$NAME($$GET1^DIQ(4,IBDIV,.01))

 . . S IBDIVSTATE=$$GET1^DIQ(4,IBDIV,.02,"I")

 . . S IBDIVSTATE=$$GET1^DIQ(5,IBDIVSTATE,1)

 . . ;

 . . I 'EXCEL W !?4,IBDIVNO,?9,IBDIVNAME

 . . ;

 . . S IBSTATION=0

 . . F  S IBSTATION=$O(IBLIST(IBVISN,IBDIV,IBSTATION)) Q:'IBSTATION  D

 . . . ;

 . . . S IBCOUNT=IBCOUNT+1

 . . . S IBSTNIDNO=$$GET1^DIQ(4,IBSTATION,99)

 . . . S IBSTNNAME=$$NAME($$GET1^DIQ(4,IBSTATION,.01))

 . . . S IBSTNSTATE=$$GET1^DIQ(4,IBSTATION,.02,"I")

 . . . S IBSTNSTATE=$$GET1^DIQ(5,IBSTNSTATE,1)

 . . . ;

 . . . I EXCEL D

 . . . . W !,IBCOUNT,"^"

 . . . . W $G(IBCPAC(IBLIST(IBVISN))),"^"

 . . . . W IBLIST(IBVISN),"^"

 . . . . W IBDIVNO,"^"

 . . . . W IBDIVNAME,"^"

 . . . . W IBDIVSTATE,"^"

 . . . . W IBSTNIDNO,"^"

 . . . . W IBSTNNAME,"^"

 . . . . W IBSTNSTATE

 . . . . Q

 . . . E  W !?6,IBSTNIDNO,?13,IBSTNNAME

 . . . ;

 . . . Q

 . . Q

 . Q

 Q

 ;

NAME(IBNAME) ; Strip commas from name.

 ;

 ; Strip commas, and be sure to leave one <space> not two.

 ;

 I $F(IBNAME,", ") S IBNAME=$TR(IBNAME,",")

 I $F(IBNAME,",") S IBNAME=$TR(IBNAME,","," ")

 Q IBNAME

 ;

CPACMAP(IBCPAC) ;

 ;

 ; VISNs 3, 11, 13, 14, and 18 should not exist -- they have each been

 ; merged into other VISNs.  If they do exist, they should be

 ; associated with the CPACs indicated.

 ;

 S IBCPAC("VISN 01")="NORTH EAST CPAC"

 S IBCPAC("VISN 02")="NORTH EAST CPAC"

 S IBCPAC("VISN 03")="NORTH EAST CPAC"

 S IBCPAC("VISN 04")="NORTH EAST CPAC"

 S IBCPAC("VISN 05")="MID-ATLANTIC CPAC"

 S IBCPAC("VISN 06")="MID-ATLANTIC CPAC"

 S IBCPAC("VISN 07")="MID-ATLANTIC CPAC"

 S IBCPAC("VISN 08")="FLORIDA/CARIBBEAN CPAC"

 S IBCPAC("VISN 09")="MID-SOUTH CPAC"

 S IBCPAC("VISN 10")="NORTH CENTRAL CPAC"

 S IBCPAC("VISN 11")="NORTH CENTRAL CPAC"

 S IBCPAC("VISN 12")="NORTH CENTRAL CPAC"

 S IBCPAC("VISN 13")="CENTRAL PLAINS CPAC"

 S IBCPAC("VISN 14")="CENTRAL PLAINS CPAC"

 S IBCPAC("VISN 15")="CENTRAL PLAINS CPAC"

 S IBCPAC("VISN 16")="MID-SOUTH CPAC"

 S IBCPAC("VISN 17")="MID-SOUTH CPAC"

 S IBCPAC("VISN 18")="WEST CPAC"

 S IBCPAC("VISN 19")="CENTRAL PLAINS CPAC"

 S IBCPAC("VISN 20")="WEST CPAC"

 S IBCPAC("VISN 21")="WEST CPAC"

 S IBCPAC("VISN 22")="WEST CPAC"

 S IBCPAC("VISN 23")="CENTRAL PLAINS CPAC"

 ;

 Q

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IBTASFAC   10949     printed  Nov 22, 2024@17:37:08                                                                                                                                                                                                   Page 2

IBTASFAC  ; AITC/MRD - TAS RPC - Facilities RPC ;Feb 20, 2019@13:53:52

 +1       ;;2.0;INTEGRATED BILLING;**638**;21-MAR-94;Build 16

 +2       ;Per VA Directive 6402, this routine should not be modified.

 +3       ;

 +4        QUIT 

 +5       ;

 +6       ; The Facilities RPC is used by the TAS application to maintain

 +7       ; a mapping of VISNs to Stations, including the state of each

 +8       ; Station and which Stations are also Divisions.  This information

 +9       ; comes from file# 4, Institution, most of which is pushed out to

 +10      ; each site from FORUM.  Each site may add local entries.  Local

 +11      ; entries will not be returned by this RPC.  The TAS application

 +12      ; also maintains a mapping of CPACs to VISNs.  That information

 +13      ; cannot be found on VistA and comes from another source, such as

 +14      ; a published PDF listing all CPACs and VISNs.

 +15      ;

FACILITY(RESULT,ARG) ;

 +1       ;

 +2        NEW IBLIST

 +3       ;

 +4        SET RESULT=$NAME(^TMP("JSON",$JOB))

 +5        KILL @RESULT

 +6       ;

 +7        DO VISNS(.IBLIST)

 +8        DO DIVISIONS(.IBLIST)

 +9        DO STATIONS(.IBLIST)

 +10       DO RESULTS(.IBLIST,RESULT)

 +11      ;

 +12       QUIT 

 +13      ;

 +14      ; VISNS builds an array listing all VISNs.  It will skip

 +15      ; VISN 99 and any site-defined VISNs, identified by having

 +16      ; anything after the two-digit number in the VISN name.

 +17      ; Format of array:

 +18      ;   IBLIST(VISN IEN) = VISN Name

 +19      ;

VISNS(IBLIST) ;

 +1       ;

 +2        NEW IBVIEN,IBVISN,IBVISNNAME

 +3       ;

 +4        SET IBVISN="VISN"

 +5        FOR 

               SET IBVISN=$ORDER(^DIC(4,"B",IBVISN))

               if IBVISN'?1"VISN".E

                   QUIT 

               Begin DoDot:1

 +6                IF IBVISN'?1"VISN "1.2N

                       QUIT 

 +7                IF $PIECE(IBVISN," ",2)'<99

                       QUIT 

 +8                SET IBVIEN=$ORDER(^DIC(4,"B",IBVISN,0))

 +9       ;

 +10      ; Add a leading zero if the VISN number is a single digit.

 +11      ;

 +12               SET IBVISNNAME=IBVISN

 +13               IF $LENGTH($PIECE(IBVISN," ",2))=1

                       SET IBVISNNAME="VISN 0"_$PIECE(IBVISN," ",2)

 +14               SET IBLIST(IBVIEN)=IBVISNNAME

 +15               QUIT 

               End DoDot:1

 +16       QUIT 

 +17      ;

 +18      ; DIVISIONS gathers the list of Divisions, which must be done

 +19      ; before building the list of Stations.  Only active, National

 +20      ; entries will be included.

 +21      ; Format of array:

 +22      ;   IBLIST(VISN IEN, Division IEN) = Division #

 +23      ;

DIVISIONS(IBLIST) ;

 +1       ;

 +2        NEW IBDIVISION,IBIDNO,IBINST,IBPARENTDIV,IBPARENTVISN,IBVISN

 +3       ;

 +4        SET IBVISN=$ORDER(^DIC(4.05,"B","VISN",""))

 +5        SET IBDIVISION=$ORDER(^DIC(4.05,"B","PARENT FACILITY",""))

 +6       ;

 +7        SET IBINST=0

 +8        FOR 

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

               if 'IBINST

                   QUIT 

               Begin DoDot:1

 +9       ; Skip if not a National entry (i.e. skip local entries).

                   IF $$GET1^DIQ(4,IBINST,11,"I")'="N"

                       QUIT 

 +10      ; Skip if the Inactive Facility Flag is '1'.

                   IF $$GET1^DIQ(4,IBINST,101,"I")=1

                       QUIT 

 +11      ; Skip any entries beginning with "ZZ".

                   IF $EXTRACT($$GET1^DIQ(4,IBINST,.01),1,2)="ZZ"

                       QUIT 

 +12      ;

 +13      ; Determine the parent VISN.

 +14      ;

 +15               SET IBPARENTVISN=$ORDER(^DIC(4,IBINST,7,"B",IBVISN,""))

 +16               IF IBPARENTVISN'=""

                       SET IBPARENTVISN=$$GET1^DIQ(4.014,IBPARENTVISN_","_IBINST,1,"I")

 +17               IF IBPARENTVISN=""

                       QUIT 

 +18      ;

 +19      ; Quit if the parent VISN is not on the list of VISNs.

 +20      ; Quit if this entry is the parent VISN.

 +21      ;

 +22               IF '$DATA(IBLIST(IBPARENTVISN))

                       QUIT 

 +23               IF IBPARENTVISN=IBINST

                       QUIT 

 +24      ;

 +25      ; Determine the parent Division.

 +26      ;

 +27               SET IBPARENTDIV=$ORDER(^DIC(4,IBINST,7,"B",IBDIVISION,""))

 +28               IF IBPARENTDIV'=""

                       SET IBPARENTDIV=$$GET1^DIQ(4.014,IBPARENTDIV_","_IBINST,1,"I")

 +29               IF IBPARENTDIV=""

                       QUIT 

 +30      ;

 +31      ; Quit if the parent VISN and parent Division are the same.

 +32      ; Quit if the parent Division has no Station Number.

 +33      ; Quit if the Station Number is other than three digits.

 +34      ;

 +35               IF IBPARENTVISN=IBPARENTDIV

                       QUIT 

 +36      ;

 +37               SET IBIDNO=$$GET1^DIQ(4,IBPARENTDIV,99)

 +38               IF IBIDNO=""

                       QUIT 

 +39               IF IBIDNO'?3N

                       QUIT 

 +40      ;

 +41      ; Divisions are identified two ways:  a) it lists itself as a parent;

 +42      ; b) the Station Number (field# 99) is the same as the IEN.

 +43      ; If either is true, add this as a Division.

 +44      ;

 +45               IF IBPARENTDIV=IBINST

                       SET IBLIST(IBPARENTVISN,IBPARENTDIV)=IBIDNO

                       QUIT 

 +46               IF $$GET1^DIQ(4,IBINST,99)=IBINST

                       SET IBLIST(IBPARENTVISN,IBPARENTDIV)=IBIDNO

 +47      ;

 +48               QUIT 

               End DoDot:1

 +49       QUIT 

 +50      ;

 +51      ; STATIONS builds a list of stations associated with each Division

 +52      ; and VISN.  Only active, National entries will be included.

 +53      ; Format of array:

 +54      ;   IBLIST(VISN IEN, Division IEN, Station IEN) = ""

 +55      ;

STATIONS(IBLIST) ;

 +1       ;

 +2        NEW IBDIVISION,IBINST,IBPARENTDIV,IBPARENTVISN,IBVISN

 +3       ;

 +4        SET IBVISN=$ORDER(^DIC(4.05,"B","VISN",""))

 +5        SET IBDIVISION=$ORDER(^DIC(4.05,"B","PARENT FACILITY",""))

 +6       ;

 +7        SET IBINST=0

 +8        FOR 

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

               if 'IBINST

                   QUIT 

               Begin DoDot:1

 +9       ; Skip if not a National entry (i.e. skip local entries).

                   IF $$GET1^DIQ(4,IBINST,11,"I")'="N"

                       QUIT 

 +10      ; Skip if the Inactive Facility Flag is '1'.

                   IF $$GET1^DIQ(4,IBINST,101,"I")=1

                       QUIT 

 +11      ; Skip any entries beginning with "ZZ".

                   IF $EXTRACT($$GET1^DIQ(4,IBINST,.01),1,2)="ZZ"

                       QUIT 

 +12      ;

 +13      ; Determine the parent VISN.

 +14      ;

 +15               SET IBPARENTVISN=$ORDER(^DIC(4,IBINST,7,"B",IBVISN,""))

 +16               IF IBPARENTVISN'=""

                       SET IBPARENTVISN=$$GET1^DIQ(4.014,IBPARENTVISN_","_IBINST,1,"I")

 +17               IF IBPARENTVISN=""

                       QUIT 

 +18      ;

 +19      ; Quit if the parent VISN is not on the list of VISNs.

 +20      ;

 +21               IF '$DATA(IBLIST(IBPARENTVISN))

                       QUIT 

 +22      ;

 +23      ; Determine the parent Division.

 +24      ;

 +25               SET IBPARENTDIV=$ORDER(^DIC(4,IBINST,7,"B",IBDIVISION,""))

 +26               IF IBPARENTDIV'=""

                       SET IBPARENTDIV=$$GET1^DIQ(4.014,IBPARENTDIV_","_IBINST,1,"I")

 +27               IF IBPARENTDIV=""

                       QUIT 

 +28      ;

 +29      ; Do not add a Division to the list of Stations for itself.

 +30      ; Divisions are identified two ways:  a) it lists itself as a parent;

 +31      ; b) the Station Number (field# 99) is the same as the IEN.  Either

 +32      ; may be true

 +33      ;

 +34               IF IBPARENTDIV=IBINST

                       QUIT 

 +35               IF $$GET1^DIQ(4,IBINST,99)=IBINST

                       QUIT 

 +36      ;

 +37      ; If the parent VISN is on the list of VISNs, and the parent Division

 +38      ; is on the list of Divisions, then add this station to the list.

 +39      ;

 +40               IF $DATA(IBLIST(IBPARENTVISN,IBPARENTDIV))

                       SET IBLIST(IBPARENTVISN,IBPARENTDIV,IBINST)=""

 +41      ;

 +42               QUIT 

               End DoDot:1

 +43       QUIT 

 +44      ;

 +45      ; RESULTS builds the temp global to be passed into ENCODE^XLFJSON,

 +46      ; which will create the JSON.

 +47      ; Format of array:

 +48      ;   IBLIST(VISN IEN) = VISN Name

 +49      ;   IBLIST(VISN IEN, Division IEN) = Division #

 +50      ;   IBLIST(VISN IEN, Division IEN, Station IEN) = ""

 +51      ;

RESULTS(IBLIST,RESULT) ; Move into result in vaid json format

 +1       ;

 +2        NEW IBDIV,IBDIVCNT,IBIDNO,IBNAME,IBSTACNT,IBSTATE

 +3        NEW IBSTATION,IBTEMP,IBVISN,IBVISNCNT,X

 +4       ;

 +5        SET IBTEMP=$NAME(^TMP("IBTAS",$JOB))

 +6        KILL @IBTEMP

 +7       ;

 +8        SET IBVISNCNT=0

 +9       ;

 +10       SET IBVISN=0

 +11       FOR 

               SET IBVISN=$ORDER(IBLIST(IBVISN))

               if 'IBVISN

                   QUIT 

               IF $DATA(IBLIST(IBVISN))=11

                   Begin DoDot:1

 +12                   SET IBVISNCNT=IBVISNCNT+1

 +13                   SET @IBTEMP@("VISNs",IBVISNCNT,"Name")=IBLIST(IBVISN)

 +14      ;

 +15                   SET IBDIVCNT=0

 +16      ;

 +17                   SET IBDIV=0

 +18                   FOR 

                           SET IBDIV=$ORDER(IBLIST(IBVISN,IBDIV))

                           if 'IBDIV

                               QUIT 

                           Begin DoDot:2

 +19      ;

 +20                           SET IBIDNO=$$GET1^DIQ(4,IBDIV,99)

 +21                           SET IBNAME=$$GET1^DIQ(4,IBDIV,.01)

 +22                           SET IBNAME=$$NAME(IBNAME)

 +23                           SET IBSTATE=$$GET1^DIQ(4,IBDIV,.02,"I")

 +24                           SET IBSTATE=$$GET1^DIQ(5,IBSTATE,1)

 +25      ;

 +26                           SET IBDIVCNT=IBDIVCNT+1

 +27      ;

 +28                           SET @IBTEMP@("VISNs",IBVISNCNT,"Divisions",IBDIVCNT,"ID")=IBIDNO

 +29                           SET @IBTEMP@("VISNs",IBVISNCNT,"Divisions",IBDIVCNT,"ID","IEN")=IBDIV

 +30                           SET @IBTEMP@("VISNs",IBVISNCNT,"Divisions",IBDIVCNT,"Name")=IBNAME

 +31                           SET @IBTEMP@("VISNs",IBVISNCNT,"Divisions",IBDIVCNT,"State")=IBSTATE

 +32      ;

 +33                           SET IBSTACNT=0

 +34      ;

 +35                           SET IBSTATION=0

 +36                           FOR 

                                   SET IBSTATION=$ORDER(IBLIST(IBVISN,IBDIV,IBSTATION))

                                   if 'IBSTATION

                                       QUIT 

                                   Begin DoDot:3

 +37      ;

 +38                                   SET IBIDNO=$$GET1^DIQ(4,IBSTATION,99)

 +39                                   SET IBNAME=$$GET1^DIQ(4,IBSTATION,.01)

 +40                                   SET IBNAME=$$NAME(IBNAME)

 +41                                   SET IBSTATE=$$GET1^DIQ(4,IBSTATION,.02,"I")

 +42                                   SET IBSTATE=$$GET1^DIQ(5,IBSTATE,1)

 +43      ;

 +44                                   SET IBSTACNT=IBSTACNT+1

 +45      ;

 +46                                   SET @IBTEMP@("VISNs",IBVISNCNT,"Divisions",IBDIVCNT,"Stations",IBSTACNT,"ID")=IBIDNO

 +47                                   SET @IBTEMP@("VISNs",IBVISNCNT,"Divisions",IBDIVCNT,"Stations",IBSTACNT,"Name")=IBNAME

 +48                                   SET @IBTEMP@("VISNs",IBVISNCNT,"Divisions",IBDIVCNT,"Stations",IBSTACNT,"State")=IBSTATE

 +49      ;

 +50                                   QUIT 

                                   End DoDot:3

 +51                           QUIT 

                           End DoDot:2

 +52                   QUIT 

                   End DoDot:1

 +53      ;

 +54      ; Call the utility ENCODE to translate the results into valid JSON.

 +55      ;

 +56       DO ENCODE^XLFJSON(IBTEMP,RESULT)

 +57       SET @RESULT@(1)="["_@RESULT@(1)

 +58       SET X=$ORDER(@RESULT@(""),-1)

 +59       SET @RESULT@(X)=@RESULT@(X)_"]"

 +60      ;

 +61       QUIT 

 +62      ;

REPORT(EXCEL) ; Build the list and display the results.

 +1       ;

 +2       ; This procedure exists mainly to aid in the development and

 +3       ; testing of the RPC.

 +4       ;

 +5       ; EXCEL - Optional input parameter.  If 1, then the output

 +6       ; will be "^" delimited.

 +7       ;

 +8        NEW IBLIST,RESULT

 +9       ;

 +10       SET RESULT=$NAME(^TMP("JSON",$JOB))

 +11       KILL @RESULT

 +12      ;

 +13       DO VISNS(.IBLIST)

 +14       DO DIVISIONS(.IBLIST)

 +15       DO STATIONS(.IBLIST)

 +16      ;

 +17       DO DISPLAY(.IBLIST,$GET(EXCEL))

 +18      ;

 +19       QUIT 

 +20      ;

DISPLAY(IBLIST,EXCEL) ; Display results.

 +1       ;

 +2        NEW IBCOUNT,IBCPAC,IBDIV,IBDIVNAME,IBDIVNO,IBDIVSTATE,IBSTATION

 +3        NEW IBSTNIDNO,IBSTNNAME,IBSTNSTATE,IBVISN

 +4       ;

 +5        IF '$GET(EXCEL)

               SET EXCEL=0

 +6       ;

 +7       ; Set up array of VISN-to-CPAC mapping.

 +8       ;

 +9        IF EXCEL

               DO CPACMAP(.IBCPAC)

 +10      ;

 +11       SET IBCOUNT=0

 +12       SET IBVISN=0

 +13       FOR 

               SET IBVISN=$ORDER(IBLIST(IBVISN))

               if 'IBVISN

                   QUIT 

               IF $DATA(IBLIST(IBVISN))=11

                   Begin DoDot:1

 +14      ;

 +15                   IF 'EXCEL

                           WRITE !!,IBLIST(IBVISN)

 +16      ;

 +17                   SET IBDIV=0

 +18                   FOR 

                           SET IBDIV=$ORDER(IBLIST(IBVISN,IBDIV))

                           if 'IBDIV

                               QUIT 

                           Begin DoDot:2

 +19      ;

 +20                           SET IBDIVNO=$$GET1^DIQ(4,IBDIV,99)

 +21                           SET IBDIVNAME=$$NAME($$GET1^DIQ(4,IBDIV,.01))

 +22                           SET IBDIVSTATE=$$GET1^DIQ(4,IBDIV,.02,"I")

 +23                           SET IBDIVSTATE=$$GET1^DIQ(5,IBDIVSTATE,1)

 +24      ;

 +25                           IF 'EXCEL

                                   WRITE !?4,IBDIVNO,?9,IBDIVNAME

 +26      ;

 +27                           SET IBSTATION=0

 +28                           FOR 

                                   SET IBSTATION=$ORDER(IBLIST(IBVISN,IBDIV,IBSTATION))

                                   if 'IBSTATION

                                       QUIT 

                                   Begin DoDot:3

 +29      ;

 +30                                   SET IBCOUNT=IBCOUNT+1

 +31                                   SET IBSTNIDNO=$$GET1^DIQ(4,IBSTATION,99)

 +32                                   SET IBSTNNAME=$$NAME($$GET1^DIQ(4,IBSTATION,.01))

 +33                                   SET IBSTNSTATE=$$GET1^DIQ(4,IBSTATION,.02,"I")

 +34                                   SET IBSTNSTATE=$$GET1^DIQ(5,IBSTNSTATE,1)

 +35      ;

 +36                                   IF EXCEL

                                           Begin DoDot:4

 +37                                           WRITE !,IBCOUNT,"^"

 +38                                           WRITE $GET(IBCPAC(IBLIST(IBVISN))),"^"

 +39                                           WRITE IBLIST(IBVISN),"^"

 +40                                           WRITE IBDIVNO,"^"

 +41                                           WRITE IBDIVNAME,"^"

 +42                                           WRITE IBDIVSTATE,"^"

 +43                                           WRITE IBSTNIDNO,"^"

 +44                                           WRITE IBSTNNAME,"^"

 +45                                           WRITE IBSTNSTATE

 +46                                           QUIT 

                                           End DoDot:4

 +47                                  IF '$TEST

                                           WRITE !?6,IBSTNIDNO,?13,IBSTNNAME

 +48      ;

 +49                                   QUIT 

                                   End DoDot:3

 +50                           QUIT 

                           End DoDot:2

 +51                   QUIT 

                   End DoDot:1

 +52       QUIT 

 +53      ;

NAME(IBNAME) ; Strip commas from name.

 +1       ;

 +2       ; Strip commas, and be sure to leave one <space> not two.

 +3       ;

 +4        IF $FIND(IBNAME,", ")

               SET IBNAME=$TRANSLATE(IBNAME,",")

 +5        IF $FIND(IBNAME,",")

               SET IBNAME=$TRANSLATE(IBNAME,","," ")

 +6        QUIT IBNAME

 +7       ;

CPACMAP(IBCPAC) ;

 +1       ;

 +2       ; VISNs 3, 11, 13, 14, and 18 should not exist -- they have each been

 +3       ; merged into other VISNs.  If they do exist, they should be

 +4       ; associated with the CPACs indicated.

 +5       ;

 +6        SET IBCPAC("VISN 01")="NORTH EAST CPAC"

 +7        SET IBCPAC("VISN 02")="NORTH EAST CPAC"

 +8        SET IBCPAC("VISN 03")="NORTH EAST CPAC"

 +9        SET IBCPAC("VISN 04")="NORTH EAST CPAC"

 +10       SET IBCPAC("VISN 05")="MID-ATLANTIC CPAC"

 +11       SET IBCPAC("VISN 06")="MID-ATLANTIC CPAC"

 +12       SET IBCPAC("VISN 07")="MID-ATLANTIC CPAC"

 +13       SET IBCPAC("VISN 08")="FLORIDA/CARIBBEAN CPAC"

 +14       SET IBCPAC("VISN 09")="MID-SOUTH CPAC"

 +15       SET IBCPAC("VISN 10")="NORTH CENTRAL CPAC"

 +16       SET IBCPAC("VISN 11")="NORTH CENTRAL CPAC"

 +17       SET IBCPAC("VISN 12")="NORTH CENTRAL CPAC"

 +18       SET IBCPAC("VISN 13")="CENTRAL PLAINS CPAC"

 +19       SET IBCPAC("VISN 14")="CENTRAL PLAINS CPAC"

 +20       SET IBCPAC("VISN 15")="CENTRAL PLAINS CPAC"

 +21       SET IBCPAC("VISN 16")="MID-SOUTH CPAC"

 +22       SET IBCPAC("VISN 17")="MID-SOUTH CPAC"

 +23       SET IBCPAC("VISN 18")="WEST CPAC"

 +24       SET IBCPAC("VISN 19")="CENTRAL PLAINS CPAC"

 +25       SET IBCPAC("VISN 20")="WEST CPAC"

 +26       SET IBCPAC("VISN 21")="WEST CPAC"

 +27       SET IBCPAC("VISN 22")="WEST CPAC"

 +28       SET IBCPAC("VISN 23")="CENTRAL PLAINS CPAC"

 +29      ;

 +30       QUIT 

 +31      ;