DVBACRVA ;SLC/GRE - ; 01/08/2016
;;2.7;AMIE;**193**;AUG 30,2016;Build 84
;
;Public, Supported ICRs
; #2056 - Fileman API - $$GET1^DIQ
;
Q
;
GETFAC(RESULT,SORTBY) ; Extract records from file and sort by State Code
K ^TMP($J)
N II,FACNAME,STATE,ST,STATION,STATX,FIEN,FACTYPE,R,F1,F11,F2,F2N
N VAMCNAME,A1,RES,X,X1
S (FACNAME,STATE,ST,STATION,STATX,FIEN,FACTYPE,F1,F11,F2,F2N,VAMCNAME)=""
S (R,II)=0
; % IS THE FIRST XREF
F S II=$O(^DVB(396.195,II)) Q:II="" Q:II="B" D
. S X=^DVB(396.195,II,0)
. ;S X1=$G(^DIC(4,II,99)) ;sSTATION NUMBER;$G SETS TO NULL IF RECORD DOES NOT EXIST
. S FACNAME=$P(X,U,1)
. S FNAME=$P(FACNAME,"located",1)
. S ST=$P(X,U,2)
. S STATION=$$DSTAT(II) Q:STATION=""
. S:SORTBY="STATE" RES(ST,II)=U_FACNAME_U_II_U_STATION
. S:SORTBY="NAME" RESULT(FNAME)=U_FACNAME_U_II_U_STATION
I SORTBY="STATE" S (R,II)=0,ST="" D
. N CNT S CNT=0
. F S ST=$O(RES(ST)) Q:ST="" D
.. S II=0
.. F S II=$O(RES(ST,II)) Q:II="" D
... S CNT=$G(CNT)+1
... S RESULT(CNT)=RES(ST,II)
Q
;
DSTAT(RSI) ; Returns Domain Station Number
;
N DMNI,DMN
Q:RSI="" 0
Q:'$D(^DVB(396.195,RSI,0)) 0
;
S DMN=$P(^DVB(396.195,RSI,0),"^",3)
S DMNI=$O(^DIC(4.2,"B",DMN,""))
Q:DMNI="" 0
S STN=$P(^DIC(4.2,DMNI,0),"^",13)
Q STN
;
GETFACNM(RESULT,SORTBY) ; Extract records from file and sort by State Code
K ^TMP($J)
N II,FACNAME,STATE,ST,STATION,STATX,FIEN,FACTYPE,R,F1,F11,F2,F2N
N VAMCNAME,A1,RES,X,X1
S (FACNAME,STATE,ST,STATION,STATX,FIEN,FACTYPE,F1,F11,F2,F2N,VAMCNAME)=""
S (R,II)=0
; % IS THE FIRST XREF
F S II=$O(^DIC(4,II)) Q:II="" Q:II="%" D
. S X=^DIC(4,II,0),R=0
. S X1=$G(^DIC(4,II,99)) ;$G SETS TO NULL IF RECORD DOES NOT EXIST
. S F11=$P(X1,U,4) ;INACTIVE FLAG - POINTER
. Q:F11=1 ;QUIT IF F1=INACTIVE=1
. S F1=$G(^DIC(4,II,3))
. Q:F1=""
. S F2=$G(^DIC(4.1,F1,0))
. S F2N=$P(F2,U,1)
. S A1=$P(F2,U,1)
. S FACNAME=$P(X,U,1)
. I "VAMC"[F2N S R=1
. I "BVA/VBA-SO"[F2N S R=1
. I "RO"[F2N S R=1
. I "CENTRAL OFFICE"[F2N S R=1
. I "BVA"[F2N S R=1
. I "M&ROC"[F2N S R=1
. I "MC&RO"[F2N S R=1
. I "RO-OC"[F2N S R=1
. I "RO&IC"[F2N S R=1
. I "VAMROC"[F2N S R=1
. I "-RO"[F2N S R=1
. I "VAHSRO"[F2N S R=1
. I "TIGER TEAM"[F2N S R=1
. I II=460 S R=1
. Q:R=0
. S FACNAME=$P(X,U,1)
. S STATE=$P(X,U,2) I STATE="" Q:STATE=""
. S STATION=$P(X1,U,1)
. S FIEN=$P(X,U,1)
. S ST=$$EXTERNAL^DILFD(4,.02,"",STATE)
. S:SORTBY="STATE" RES(ST,II)=ST_U_FACNAME_U_STATION_U_II_U_A1
. S:SORTBY="NAME" RESULT(FACNAME)=ST_U_FACNAME_U_STATION_U_II
I SORTBY="STATE" S (R,II)=0,ST="" D
. N CNT S CNT=0
. F S ST=$O(RES(ST)) Q:ST="" D
.. S II=0
.. F S II=$O(RES(ST,II)) Q:II="" D
... S CNT=$G(CNT)+1
... S RESULT(CNT)=RES(ST,II)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBACRVA 2851 printed Apr 09, 2024@20:55:56 Page 2
DVBACRVA ;SLC/GRE - ; 01/08/2016
+1 ;;2.7;AMIE;**193**;AUG 30,2016;Build 84
+2 ;
+3 ;Public, Supported ICRs
+4 ; #2056 - Fileman API - $$GET1^DIQ
+5 ;
+6 QUIT
+7 ;
GETFAC(RESULT,SORTBY) ; Extract records from file and sort by State Code
+1 KILL ^TMP($JOB)
+2 NEW II,FACNAME,STATE,ST,STATION,STATX,FIEN,FACTYPE,R,F1,F11,F2,F2N
+3 NEW VAMCNAME,A1,RES,X,X1
+4 SET (FACNAME,STATE,ST,STATION,STATX,FIEN,FACTYPE,F1,F11,F2,F2N,VAMCNAME)=""
+5 SET (R,II)=0
+6 ; % IS THE FIRST XREF
+7 FOR
SET II=$ORDER(^DVB(396.195,II))
if II=""
QUIT
if II="B"
QUIT
Begin DoDot:1
+8 SET X=^DVB(396.195,II,0)
+9 ;S X1=$G(^DIC(4,II,99)) ;sSTATION NUMBER;$G SETS TO NULL IF RECORD DOES NOT EXIST
+10 SET FACNAME=$PIECE(X,U,1)
+11 SET FNAME=$PIECE(FACNAME,"located",1)
+12 SET ST=$PIECE(X,U,2)
+13 SET STATION=$$DSTAT(II)
if STATION=""
QUIT
+14 if SORTBY="STATE"
SET RES(ST,II)=U_FACNAME_U_II_U_STATION
+15 if SORTBY="NAME"
SET RESULT(FNAME)=U_FACNAME_U_II_U_STATION
End DoDot:1
+16 IF SORTBY="STATE"
SET (R,II)=0
SET ST=""
Begin DoDot:1
+17 NEW CNT
SET CNT=0
+18 FOR
SET ST=$ORDER(RES(ST))
if ST=""
QUIT
Begin DoDot:2
+19 SET II=0
+20 FOR
SET II=$ORDER(RES(ST,II))
if II=""
QUIT
Begin DoDot:3
+21 SET CNT=$GET(CNT)+1
+22 SET RESULT(CNT)=RES(ST,II)
End DoDot:3
End DoDot:2
End DoDot:1
+23 QUIT
+24 ;
DSTAT(RSI) ; Returns Domain Station Number
+1 ;
+2 NEW DMNI,DMN
+3 if RSI=""
QUIT 0
+4 if '$DATA(^DVB(396.195,RSI,0))
QUIT 0
+5 ;
+6 SET DMN=$PIECE(^DVB(396.195,RSI,0),"^",3)
+7 SET DMNI=$ORDER(^DIC(4.2,"B",DMN,""))
+8 if DMNI=""
QUIT 0
+9 SET STN=$PIECE(^DIC(4.2,DMNI,0),"^",13)
+10 QUIT STN
+11 ;
GETFACNM(RESULT,SORTBY) ; Extract records from file and sort by State Code
+1 KILL ^TMP($JOB)
+2 NEW II,FACNAME,STATE,ST,STATION,STATX,FIEN,FACTYPE,R,F1,F11,F2,F2N
+3 NEW VAMCNAME,A1,RES,X,X1
+4 SET (FACNAME,STATE,ST,STATION,STATX,FIEN,FACTYPE,F1,F11,F2,F2N,VAMCNAME)=""
+5 SET (R,II)=0
+6 ; % IS THE FIRST XREF
+7 FOR
SET II=$ORDER(^DIC(4,II))
if II=""
QUIT
if II="%"
QUIT
Begin DoDot:1
+8 SET X=^DIC(4,II,0)
SET R=0
+9 ;$G SETS TO NULL IF RECORD DOES NOT EXIST
SET X1=$GET(^DIC(4,II,99))
+10 ;INACTIVE FLAG - POINTER
SET F11=$PIECE(X1,U,4)
+11 ;QUIT IF F1=INACTIVE=1
if F11=1
QUIT
+12 SET F1=$GET(^DIC(4,II,3))
+13 if F1=""
QUIT
+14 SET F2=$GET(^DIC(4.1,F1,0))
+15 SET F2N=$PIECE(F2,U,1)
+16 SET A1=$PIECE(F2,U,1)
+17 SET FACNAME=$PIECE(X,U,1)
+18 IF "VAMC"[F2N
SET R=1
+19 IF "BVA/VBA-SO"[F2N
SET R=1
+20 IF "RO"[F2N
SET R=1
+21 IF "CENTRAL OFFICE"[F2N
SET R=1
+22 IF "BVA"[F2N
SET R=1
+23 IF "M&ROC"[F2N
SET R=1
+24 IF "MC&RO"[F2N
SET R=1
+25 IF "RO-OC"[F2N
SET R=1
+26 IF "RO&IC"[F2N
SET R=1
+27 IF "VAMROC"[F2N
SET R=1
+28 IF "-RO"[F2N
SET R=1
+29 IF "VAHSRO"[F2N
SET R=1
+30 IF "TIGER TEAM"[F2N
SET R=1
+31 IF II=460
SET R=1
+32 if R=0
QUIT
+33 SET FACNAME=$PIECE(X,U,1)
+34 SET STATE=$PIECE(X,U,2)
IF STATE=""
if STATE=""
QUIT
+35 SET STATION=$PIECE(X1,U,1)
+36 SET FIEN=$PIECE(X,U,1)
+37 SET ST=$$EXTERNAL^DILFD(4,.02,"",STATE)
+38 if SORTBY="STATE"
SET RES(ST,II)=ST_U_FACNAME_U_STATION_U_II_U_A1
+39 if SORTBY="NAME"
SET RESULT(FACNAME)=ST_U_FACNAME_U_STATION_U_II
End DoDot:1
+40 IF SORTBY="STATE"
SET (R,II)=0
SET ST=""
Begin DoDot:1
+41 NEW CNT
SET CNT=0
+42 FOR
SET ST=$ORDER(RES(ST))
if ST=""
QUIT
Begin DoDot:2
+43 SET II=0
+44 FOR
SET II=$ORDER(RES(ST,II))
if II=""
QUIT
Begin DoDot:3
+45 SET CNT=$GET(CNT)+1
+46 SET RESULT(CNT)=RES(ST,II)
End DoDot:3
End DoDot:2
End DoDot:1
+47 QUIT
