XUAF4 ;ISC-SF/RWF/RAM - Institution file access. ;12/03/2019 08:07
;;8.0;KERNEL;**43,112,206,209,232,217,261,394,549,555,723,662**;Jul 10, 1995;Build 49
;;Per VA Directive 6402, this routine should not be modified
Q ;No access from the top.
;
PARENT(ROOT,CHILD,ASSO) ;sr. Return array of IEN's of parents
N %,%0
S CHILD=$$LKUP(CHILD),ASSO=$$ASSO($G(ASSO)),%=0
F S %=$O(^DIC(4,CHILD,7,%)) Q:%'>0 S %0=+$P(^(%,0),U,2) D
. Q:+%'=ASSO
. S @ROOT@("P",+%0)=$$NS(+%0)
Q
CHILDREN(ROOT,PAR,ASSO,XUAC) ;sr. Return the children
N %,%1 S %=0,PAR=$$LKUP(PAR),ASSO=$$ASSO($G(ASSO)),XUAC=$G(XUAC)
Q:ASSO'>0
F S %=$O(^DIC(4,"AC",ASSO,PAR,%)) Q:%'>0 D
. I XUAC,$$STATUS(%)="I" Q
. S @ROOT@("C",%)=$$NS(%)
Q
SIBLING(ROOT,CHILD,ASSO) ;sr. Return the siblings
N % S %=0,ASSO=$$ASSO($G(ASSO))
D PARENT(ROOT,CHILD,ASSO)
F S %=$O(@ROOT@("P",%)) Q:%'>0 D CHILDREN($NA(@ROOT@("P",%)),"`"_%,ASSO)
Q
NNT(%) ;ef.sr. Return Name, Station Number, ASSO
I %'>0 Q ""
Q $$NS(%)_"^"_$$WHAT(%,13)
;
LKUP(%) ;ef.sr. Resolve a value into IEN
I $E(%)="`" S %=+$E(%,2,99) Q:$D(^DIC(4,%,0))#2 % Q 0
;Q $$FIND1^DIC(4,,"MX",%)
Q $$FIND1^DIC(4,,"MX",%,,"I $P(^(0),U,11)'=""I""") ;To screen Inactive
;
STATUS(%) ;Get the status of a IEN
Q $P($G(^DIC(4,%,0)),U,11)
;
TYPE(%) ;Lookup a Faclity TYPE in file 4.1
I %="" Q %
I $D(^DIC(4.1,"B",%))>9 Q %
S %=$$FIND1^DIC(4.1,,"MX",%)
Q $P($G(^DIC(4.1,+%,0)),U)
;
ASSO(%) ;Lookup an Asso
Q:+%=% % S:%="" %="VISN"
S %=$$FIND1^DIC(4.05,,"MX",%)
Q +%
;
NS(IEN) ;ef.sr. Return name and station #
Q $P($G(^DIC(4,IEN,0)),U,1)_U_$P($G(^DIC(4,+IEN,99)),U,1)
;
WHAT(IEN,FLD) ;ef.sr. Field to return
Q $$GET1^DIQ(4,IEN_",",FLD,"")
;
CIRN(%1,%2) ;ef.sr. Is this a CIRN Enables inst.
N % S %1=+$G(%1)
Q:'$D(^DIC(4,%1,0)) -1
I $G(%2)]"" N DIE,DR,DA S DA=%1,DR="990.1///"_%2,DIE="^DIC(4," D ^DIE
Q $$WHAT(%1,990.1)
;
IEN(STA) ;return IEN for a station number
S STA=$G(STA) Q:STA="" STA
Q $O(^DIC(4,"D",STA,0))
;
STA(IEN) ;return station number for an IEN
Q $P($G(^DIC(4,+IEN,99)),U)
;
TF(IEN) ;active treating facility? (1=YES,0=NO)
N ARRAY Q:'$G(IEN) 0
D F4($$STA(IEN),.ARRAY,"AM")
Q $S(ARRAY:1,1:0)
;
RT(IEN) ;realigned to
N ARRAY Q:'$G(IEN) 0
D F4($$STA(IEN),.ARRAY)
Q $G(ARRAY("REALIGNED TO"))
;
RF(IEN) ;realigned from
N ARRAY Q:'$G(IEN) 0
D F4($$STA(IEN),.ARRAY)
Q $G(ARRAY("REALIGNED FROM"))
;
O99(IEN) ;returns pointer to new station number IEN
Q:$O(^DIC(4,"AOLD99",+$G(IEN),""))="" ""
Q $O(^DIC(4,"D",$O(^DIC(4,"AOLD99",+$G(IEN),"")),0))
;
LEGACY(STA) ; -- legacy station number (1=yes; 0=no)
Q $S($$RT^XUAF4(+$$IEN^XUAF4(STA)):1,1:0)
;
PRNT(STA) ; -- parent facility
N X S STA=$G(STA) Q:STA="" "0^no station number passed"
D PARENT("X",STA,"PARENT FACILITY") S X=$O(X("P",0))
Q:'X "0^no parent associated with input station number"
Q X_U_$P($G(X("P",+X)),U,2)_U_$P($G(X("P",+X)),U)
;
NAME(IEN) ; -- Official Name
Q:$P($G(^DIC(4,+IEN,99)),U,3)'="" $P($G(^DIC(4,+IEN,99)),U,3)
Q $P($G(^DIC(4,+IEN,0)),U)
;
ACTIVE(IEN) ; -- active facility (1=active, 0=inactive)
;
Q '$P($G(^DIC(4,+IEN,99)),U,4)
;
PADD(IEN) ; -- physical address (street addr^city^state^zip)
;
N X,STATE
;
S X=$P($G(^DIC(4,+IEN,0)),U,2)
S STATE=$P($G(^DIC(5,+X,0)),U,2)
S X=$G(^DIC(4,+IEN,1)) Q:X="" X
;
Q $P(X,U)_U_$P(X,U,3)_U_STATE_U_$P(X,U,4)
;
HPADD(IEN,XUEDT) ; -- historical physical address based on effective date
;
Q:$G(XUEDT)=""
N XUADD1,XUADD2,XUCITY,XUSTDA,XUSTATE,XUZIP,XULINE
;
; Find valid historical address fields based on effective date
;
S XULINE=""
I '$D(^DIC(4,+IEN,999)) Q XULINE
N XUHFND,XUHDA,IENS,XUHRRY
S XUHDA="",XUHFND=0
F S XUHDA=$O(^DIC(4,+IEN,999,"B",XUHDA)) Q:XUHDA=""!XUHFND I $D(^DIC(4,+IEN,999,XUHDA,1)) D
. I XUEDT<XUHDA D
. . S IENS=XUHDA_","_+IEN_","
. . D GETS^DIQ(4.999,IENS,"1:1.4","IE","XUHRRY")
. . S XUHFND=1,XUADD1=XUHRRY(4.999,IENS,1,"E"),XUADD2=XUHRRY(4.999,IENS,1.1,"E")
. . S XUCITY=XUHRRY(4.999,IENS,1.2,"E"),XUZIP=XUHRRY(4.999,IENS,1.4,"E")
. . S XUSTDA=XUHRRY(4.999,IENS,1.3,"I"),XUSTATE=$P($G(^DIC(5,XUSTDA,0)),U,2)
. . S XULINE=XUADD1_U_XUADD2_U_XUCITY_U_XUSTATE_U_XUZIP
. . K XUHRRY
;
Q XULINE
;
MADD(IEN) ; -- mailing address (street addr^city^state^zip)
;
N X,STATE
;
S X=$G(^DIC(4,+IEN,4)) Q:X="" X
S STATE=$P($G(^DIC(5,+$P(X,U,4),0)),U,2)
;
Q $P(X,U)_U_$P(X,U,3)_U_STATE_U_$P(X,U,5)
;
F4(STA,ARRAY,FLAG,ONDT) ;File #4 multipurpose API
;
;INPUT
; STA Station number (required)
;
; [.]ARRAY $NAME reference for return values. (required)
;
; FLAG A = Active entries only. (optional)
; M = Medical treating facilities only.
;
; ONDT Return name on this FM internal date. (optional);
;
;OUTPUT
; ARRAY IEN or '0^error message'
; ARRAY("NAME") name
; ARRAY("VA NAME") offical va name
; ARRAY("STATION NUMBER") station number
; ARRAY("TYPE") facilty type name
; ARRAY("INACTIVE") inactive date (0=not inactive)
; note: if inactive date not available but entry inactive then 1
;
; ARRAY("REALIGNED TO") IEN^station number^date
; ARRAY("REALIGNED FROM") IEN^station number^date
;
K ARRAY
S STA=$G(STA),FLAG=$G(FLAG),ONDT=$G(ONDT)
I STA="" S ARRAY="0^invalid input STA - required" Q
;
N IEN,N99,TO,FM,I,RDT,NAME,VANAME,HDT
;
S IEN=$$IEN(STA)
I 'IEN S ARRAY="0^station number does not exist" Q
S N99=$G(^DIC(4,+IEN,99))
S ARRAY=$$SCRN() Q:'ARRAY
;
S ARRAY("NAME")=$P(^DIC(4,IEN,0),U)
S ARRAY("VA NAME")=$P(N99,U,3)
S ARRAY("STATION NUMBER")=STA
S ARRAY("TYPE")=$P($G(^DIC(4.1,+$G(^DIC(4,IEN,3)),0)),U)
;
;realignments
S TO=$O(^DIC(4,"ARTO",IEN,0)) D:TO
.S RDT=$O(^DIC(4,"ART",TO,IEN,0))
.S ARRAY("REALIGNED TO")=TO_U_$$STA(TO)_U_RDT
S FM=$O(^DIC(4,"ARFM",IEN,0)) D:FM
.S ARRAY("REALIGNED FROM")=FM_U_$$STA(FM)_U_$O(^DIC(4,"ARF",FM,IEN,0))
;
S I=$O(^DIC(4,"AI",IEN,0)),I=$S(I:I,$G(RDT):RDT,1:+$P(N99,U,4))
S ARRAY("INACTIVE")=I
;
Q:'ONDT
;
;get name for date
S NAME=ARRAY("NAME")
S VANAME=ARRAY("VA NAME")
S HDT=DT
F S HDT=$O(^DIC(4,IEN,999,HDT),-1) Q:('HDT!(HDT<ONDT)) D
.N X S X=$G(^DIC(4,IEN,999,HDT,0)) Q:X=""
.S:$P(X,U,2)'="" NAME=$P(X,U,2)
.S:$P(X,U,3)'="" VANAME=$P(X,U,3)
S ARRAY("NAME")=NAME
S ARRAY("VA NAME")=VANAME
;
Q
;
IDT(IEN) ; inactive date
N IDT,ND,XDT
S IEN=$G(IEN) Q:'IEN IEN
S XDT=9999999,IDT=""
F S XDT=$O(^DIC(4,+IEN,999,XDT),-1) Q:'XDT D Q:IDT
.S ND=$G(^DIC(4,+IEN,999,XDT,0)) Q:ND=""
.S IDT=$S($P(ND,U,5):XDT,$P(ND,U,7):XDT,1:IDT)
Q IDT
;
SCRN() ;sreen IEN
N X S X=$E(N99,1,3)
I FLAG["A",$P(N99,U,4) Q "0^inactive facility"
I FLAG["M",$S(X=358:0,X=740:0,X<400:1,X>759:1,X<700:0,X<750:1,1:0),$G(DUZ("AG"))="V" Q "0^not a treating facility"
Q IEN
;
LOOKUP ; -- lookup an enty by coding system / ID pair
;
N DIC,D
;
S DIC="^DIC(4,",DIC(0)="QEA",D="XUMFIDX" D IX^DIC
;
Q
;
IDX(CDSYS,ID) ; -- return IEN for a given coding system / ID pair
;
;INPUT
; CDSYS coding system (required)
; ID identifier (required)
;OUTPUT
; $$ Internal Entry Number
;
N IEN
;
S CDSYS=$G(CDSYS),ID=$G(ID)
;
Q:CDSYS="" "0^CDSYS required"
Q:ID="" "0^ID required"
;
I CDSYS="VASTANUM" Q $O(^DIC(4,"D",ID,0))
I CDSYS="NPI" Q $O(^DIC(4,"ANPI",ID,0))
;
S IEN=$O(^DIC(4,"XUMFIDX",CDSYS,ID,0))
;
Q $S(IEN:IEN,1:"0^not found")
;
ID(CDSYS,IEN) ; returns the ID for a given coding system / IEN
;
;INPUT
; CDSYS coding system (required)
; IEN Internal Entry Number (required)
;OUTPUT
; $$ Identifier
;
N ID,IDX
;
S CDSYS=$G(CDSYS),IEN=$G(IEN)
Q:CDSYS="" "" Q:'IEN "" Q:'$D(^DIC(4,IEN)) ""
;
I CDSYS="VASTANUM" Q $P($G(^DIC(4,+IEN,99)),U)
I CDSYS="NPI" Q $P($G(^DIC(4,+IEN,"NPI")),U)
;
S IDX=$O(^DIC(4,IEN,9999,"B",CDSYS,0)) Q:'IDX ""
;
Q $P($G(^DIC(4,IEN,9999,IDX,0)),U,2)
;
CDSYS(Y) ; coding systems
;
;INPUT/OUTPUT
; .Y Y(CDSYS) = $D local system ^ coding system name
;
S Y("DMIS")=$D(^DIC(4,"XUMFIDX","DMIS"))_U_"DoD DMIS ID"
S Y("VASTANUM")=$D(^DIC(4,"D"))_U_"VA Station Number"
S Y("NPI")=$D(^DIC(4,"ANPI"))_U_"NPI"
S Y("CLIA")=$D(^DIC(4,"XUMFIDX","CLIA"))_U_"CLIA number"
S Y("MAMMO-ACR")=$D(^DIC(4,"XUMFIDX","MAMMO-ACR"))_U_"MAMMO-ACR number"
;
Q
;
LCDSYS(Y) ; list coding systems
;
N CDSYS
S CDSYS=""
S CDSYS("NPI")="",CDSYS("VASTANUM")=""
F S CDSYS=$O(^DIC(4,"XUMFIDX",CDSYS)) Q:CDSYS="" D
.S Y(CDSYS)=""
;
Q
;
BNIEN(IEN) ; -- Billing Facility Name - Internal Entry Number
;
Q $P($G(^DIC(4,+IEN,99)),U,2)
;
BNSTA(STA) ; -- Billing Facility Name - Station Number
;
Q $P($G(^DIC(4,+$$IEN^XUAF4(STA),99)),U,2)
;
CERNER(STA) ; Check if a facility has been converted to CERNER
; Take in STA = Station number
; Return -1 for invalid station number
; Return 1 for CERNER station
N XUSIEN
S XUSIEN=+$$IEN^XUAF4(STA) I XUSIEN'>0 Q "-1^"_STA_" is not a valid station number"
Q $P($G(^DIC(4,XUSIEN,102)),U)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUAF4 9248 printed Dec 13, 2024@02:08:58 Page 2
XUAF4 ;ISC-SF/RWF/RAM - Institution file access. ;12/03/2019 08:07
+1 ;;8.0;KERNEL;**43,112,206,209,232,217,261,394,549,555,723,662**;Jul 10, 1995;Build 49
+2 ;;Per VA Directive 6402, this routine should not be modified
+3 ;No access from the top.
QUIT
+4 ;
PARENT(ROOT,CHILD,ASSO) ;sr. Return array of IEN's of parents
+1 NEW %,%0
+2 SET CHILD=$$LKUP(CHILD)
SET ASSO=$$ASSO($GET(ASSO))
SET %=0
+3 FOR
SET %=$ORDER(^DIC(4,CHILD,7,%))
if %'>0
QUIT
SET %0=+$PIECE(^(%,0),U,2)
Begin DoDot:1
+4 if +%'=ASSO
QUIT
+5 SET @ROOT@("P",+%0)=$$NS(+%0)
End DoDot:1
+6 QUIT
CHILDREN(ROOT,PAR,ASSO,XUAC) ;sr. Return the children
+1 NEW %,%1
SET %=0
SET PAR=$$LKUP(PAR)
SET ASSO=$$ASSO($GET(ASSO))
SET XUAC=$GET(XUAC)
+2 if ASSO'>0
QUIT
+3 FOR
SET %=$ORDER(^DIC(4,"AC",ASSO,PAR,%))
if %'>0
QUIT
Begin DoDot:1
+4 IF XUAC
IF $$STATUS(%)="I"
QUIT
+5 SET @ROOT@("C",%)=$$NS(%)
End DoDot:1
+6 QUIT
SIBLING(ROOT,CHILD,ASSO) ;sr. Return the siblings
+1 NEW %
SET %=0
SET ASSO=$$ASSO($GET(ASSO))
+2 DO PARENT(ROOT,CHILD,ASSO)
+3 FOR
SET %=$ORDER(@ROOT@("P",%))
if %'>0
QUIT
DO CHILDREN($NAME(@ROOT@("P",%)),"`"_%,ASSO)
+4 QUIT
NNT(%) ;ef.sr. Return Name, Station Number, ASSO
+1 IF %'>0
QUIT ""
+2 QUIT $$NS(%)_"^"_$$WHAT(%,13)
+3 ;
LKUP(%) ;ef.sr. Resolve a value into IEN
+1 IF $EXTRACT(%)="`"
SET %=+$EXTRACT(%,2,99)
if $DATA(^DIC(4,%,0))#2
QUIT %
QUIT 0
+2 ;Q $$FIND1^DIC(4,,"MX",%)
+3 ;To screen Inactive
QUIT $$FIND1^DIC(4,,"MX",%,,"I $P(^(0),U,11)'=""I""")
+4 ;
STATUS(%) ;Get the status of a IEN
+1 QUIT $PIECE($GET(^DIC(4,%,0)),U,11)
+2 ;
TYPE(%) ;Lookup a Faclity TYPE in file 4.1
+1 IF %=""
QUIT %
+2 IF $DATA(^DIC(4.1,"B",%))>9
QUIT %
+3 SET %=$$FIND1^DIC(4.1,,"MX",%)
+4 QUIT $PIECE($GET(^DIC(4.1,+%,0)),U)
+5 ;
ASSO(%) ;Lookup an Asso
+1 if +%=%
QUIT %
if %=""
SET %="VISN"
+2 SET %=$$FIND1^DIC(4.05,,"MX",%)
+3 QUIT +%
+4 ;
NS(IEN) ;ef.sr. Return name and station #
+1 QUIT $PIECE($GET(^DIC(4,IEN,0)),U,1)_U_$PIECE($GET(^DIC(4,+IEN,99)),U,1)
+2 ;
WHAT(IEN,FLD) ;ef.sr. Field to return
+1 QUIT $$GET1^DIQ(4,IEN_",",FLD,"")
+2 ;
CIRN(%1,%2) ;ef.sr. Is this a CIRN Enables inst.
+1 NEW %
SET %1=+$GET(%1)
+2 if '$DATA(^DIC(4,%1,0))
QUIT -1
+3 IF $GET(%2)]""
NEW DIE,DR,DA
SET DA=%1
SET DR="990.1///"_%2
SET DIE="^DIC(4,"
DO ^DIE
+4 QUIT $$WHAT(%1,990.1)
+5 ;
IEN(STA) ;return IEN for a station number
+1 SET STA=$GET(STA)
if STA=""
QUIT STA
+2 QUIT $ORDER(^DIC(4,"D",STA,0))
+3 ;
STA(IEN) ;return station number for an IEN
+1 QUIT $PIECE($GET(^DIC(4,+IEN,99)),U)
+2 ;
TF(IEN) ;active treating facility? (1=YES,0=NO)
+1 NEW ARRAY
if '$GET(IEN)
QUIT 0
+2 DO F4($$STA(IEN),.ARRAY,"AM")
+3 QUIT $SELECT(ARRAY:1,1:0)
+4 ;
RT(IEN) ;realigned to
+1 NEW ARRAY
if '$GET(IEN)
QUIT 0
+2 DO F4($$STA(IEN),.ARRAY)
+3 QUIT $GET(ARRAY("REALIGNED TO"))
+4 ;
RF(IEN) ;realigned from
+1 NEW ARRAY
if '$GET(IEN)
QUIT 0
+2 DO F4($$STA(IEN),.ARRAY)
+3 QUIT $GET(ARRAY("REALIGNED FROM"))
+4 ;
O99(IEN) ;returns pointer to new station number IEN
+1 if $ORDER(^DIC(4,"AOLD99",+$GET(IEN),""))=""
QUIT ""
+2 QUIT $ORDER(^DIC(4,"D",$ORDER(^DIC(4,"AOLD99",+$GET(IEN),"")),0))
+3 ;
LEGACY(STA) ; -- legacy station number (1=yes; 0=no)
+1 QUIT $SELECT($$RT^XUAF4(+$$IEN^XUAF4(STA)):1,1:0)
+2 ;
PRNT(STA) ; -- parent facility
+1 NEW X
SET STA=$GET(STA)
if STA=""
QUIT "0^no station number passed"
+2 DO PARENT("X",STA,"PARENT FACILITY")
SET X=$ORDER(X("P",0))
+3 if 'X
QUIT "0^no parent associated with input station number"
+4 QUIT X_U_$PIECE($GET(X("P",+X)),U,2)_U_$PIECE($GET(X("P",+X)),U)
+5 ;
NAME(IEN) ; -- Official Name
+1 if $PIECE($GET(^DIC(4,+IEN,99)),U,3)'=""
QUIT $PIECE($GET(^DIC(4,+IEN,99)),U,3)
+2 QUIT $PIECE($GET(^DIC(4,+IEN,0)),U)
+3 ;
ACTIVE(IEN) ; -- active facility (1=active, 0=inactive)
+1 ;
+2 QUIT '$PIECE($GET(^DIC(4,+IEN,99)),U,4)
+3 ;
PADD(IEN) ; -- physical address (street addr^city^state^zip)
+1 ;
+2 NEW X,STATE
+3 ;
+4 SET X=$PIECE($GET(^DIC(4,+IEN,0)),U,2)
+5 SET STATE=$PIECE($GET(^DIC(5,+X,0)),U,2)
+6 SET X=$GET(^DIC(4,+IEN,1))
if X=""
QUIT X
+7 ;
+8 QUIT $PIECE(X,U)_U_$PIECE(X,U,3)_U_STATE_U_$PIECE(X,U,4)
+9 ;
HPADD(IEN,XUEDT) ; -- historical physical address based on effective date
+1 ;
+2 if $GET(XUEDT)=""
QUIT
+3 NEW XUADD1,XUADD2,XUCITY,XUSTDA,XUSTATE,XUZIP,XULINE
+4 ;
+5 ; Find valid historical address fields based on effective date
+6 ;
+7 SET XULINE=""
+8 IF '$DATA(^DIC(4,+IEN,999))
QUIT XULINE
+9 NEW XUHFND,XUHDA,IENS,XUHRRY
+10 SET XUHDA=""
SET XUHFND=0
+11 FOR
SET XUHDA=$ORDER(^DIC(4,+IEN,999,"B",XUHDA))
if XUHDA=""!XUHFND
QUIT
IF $DATA(^DIC(4,+IEN,999,XUHDA,1))
Begin DoDot:1
+12 IF XUEDT<XUHDA
Begin DoDot:2
+13 SET IENS=XUHDA_","_+IEN_","
+14 DO GETS^DIQ(4.999,IENS,"1:1.4","IE","XUHRRY")
+15 SET XUHFND=1
SET XUADD1=XUHRRY(4.999,IENS,1,"E")
SET XUADD2=XUHRRY(4.999,IENS,1.1,"E")
+16 SET XUCITY=XUHRRY(4.999,IENS,1.2,"E")
SET XUZIP=XUHRRY(4.999,IENS,1.4,"E")
+17 SET XUSTDA=XUHRRY(4.999,IENS,1.3,"I")
SET XUSTATE=$PIECE($GET(^DIC(5,XUSTDA,0)),U,2)
+18 SET XULINE=XUADD1_U_XUADD2_U_XUCITY_U_XUSTATE_U_XUZIP
+19 KILL XUHRRY
End DoDot:2
End DoDot:1
+20 ;
+21 QUIT XULINE
+22 ;
MADD(IEN) ; -- mailing address (street addr^city^state^zip)
+1 ;
+2 NEW X,STATE
+3 ;
+4 SET X=$GET(^DIC(4,+IEN,4))
if X=""
QUIT X
+5 SET STATE=$PIECE($GET(^DIC(5,+$PIECE(X,U,4),0)),U,2)
+6 ;
+7 QUIT $PIECE(X,U)_U_$PIECE(X,U,3)_U_STATE_U_$PIECE(X,U,5)
+8 ;
F4(STA,ARRAY,FLAG,ONDT) ;File #4 multipurpose API
+1 ;
+2 ;INPUT
+3 ; STA Station number (required)
+4 ;
+5 ; [.]ARRAY $NAME reference for return values. (required)
+6 ;
+7 ; FLAG A = Active entries only. (optional)
+8 ; M = Medical treating facilities only.
+9 ;
+10 ; ONDT Return name on this FM internal date. (optional);
+11 ;
+12 ;OUTPUT
+13 ; ARRAY IEN or '0^error message'
+14 ; ARRAY("NAME") name
+15 ; ARRAY("VA NAME") offical va name
+16 ; ARRAY("STATION NUMBER") station number
+17 ; ARRAY("TYPE") facilty type name
+18 ; ARRAY("INACTIVE") inactive date (0=not inactive)
+19 ; note: if inactive date not available but entry inactive then 1
+20 ;
+21 ; ARRAY("REALIGNED TO") IEN^station number^date
+22 ; ARRAY("REALIGNED FROM") IEN^station number^date
+23 ;
+24 KILL ARRAY
+25 SET STA=$GET(STA)
SET FLAG=$GET(FLAG)
SET ONDT=$GET(ONDT)
+26 IF STA=""
SET ARRAY="0^invalid input STA - required"
QUIT
+27 ;
+28 NEW IEN,N99,TO,FM,I,RDT,NAME,VANAME,HDT
+29 ;
+30 SET IEN=$$IEN(STA)
+31 IF 'IEN
SET ARRAY="0^station number does not exist"
QUIT
+32 SET N99=$GET(^DIC(4,+IEN,99))
+33 SET ARRAY=$$SCRN()
if 'ARRAY
QUIT
+34 ;
+35 SET ARRAY("NAME")=$PIECE(^DIC(4,IEN,0),U)
+36 SET ARRAY("VA NAME")=$PIECE(N99,U,3)
+37 SET ARRAY("STATION NUMBER")=STA
+38 SET ARRAY("TYPE")=$PIECE($GET(^DIC(4.1,+$GET(^DIC(4,IEN,3)),0)),U)
+39 ;
+40 ;realignments
+41 SET TO=$ORDER(^DIC(4,"ARTO",IEN,0))
if TO
Begin DoDot:1
+42 SET RDT=$ORDER(^DIC(4,"ART",TO,IEN,0))
+43 SET ARRAY("REALIGNED TO")=TO_U_$$STA(TO)_U_RDT
End DoDot:1
+44 SET FM=$ORDER(^DIC(4,"ARFM",IEN,0))
if FM
Begin DoDot:1
+45 SET ARRAY("REALIGNED FROM")=FM_U_$$STA(FM)_U_$ORDER(^DIC(4,"ARF",FM,IEN,0))
End DoDot:1
+46 ;
+47 SET I=$ORDER(^DIC(4,"AI",IEN,0))
SET I=$SELECT(I:I,$GET(RDT):RDT,1:+$PIECE(N99,U,4))
+48 SET ARRAY("INACTIVE")=I
+49 ;
+50 if 'ONDT
QUIT
+51 ;
+52 ;get name for date
+53 SET NAME=ARRAY("NAME")
+54 SET VANAME=ARRAY("VA NAME")
+55 SET HDT=DT
+56 FOR
SET HDT=$ORDER(^DIC(4,IEN,999,HDT),-1)
if ('HDT!(HDT<ONDT))
QUIT
Begin DoDot:1
+57 NEW X
SET X=$GET(^DIC(4,IEN,999,HDT,0))
if X=""
QUIT
+58 if $PIECE(X,U,2)'=""
SET NAME=$PIECE(X,U,2)
+59 if $PIECE(X,U,3)'=""
SET VANAME=$PIECE(X,U,3)
End DoDot:1
+60 SET ARRAY("NAME")=NAME
+61 SET ARRAY("VA NAME")=VANAME
+62 ;
+63 QUIT
+64 ;
IDT(IEN) ; inactive date
+1 NEW IDT,ND,XDT
+2 SET IEN=$GET(IEN)
if 'IEN
QUIT IEN
+3 SET XDT=9999999
SET IDT=""
+4 FOR
SET XDT=$ORDER(^DIC(4,+IEN,999,XDT),-1)
if 'XDT
QUIT
Begin DoDot:1
+5 SET ND=$GET(^DIC(4,+IEN,999,XDT,0))
if ND=""
QUIT
+6 SET IDT=$SELECT($PIECE(ND,U,5):XDT,$PIECE(ND,U,7):XDT,1:IDT)
End DoDot:1
if IDT
QUIT
+7 QUIT IDT
+8 ;
SCRN() ;sreen IEN
+1 NEW X
SET X=$EXTRACT(N99,1,3)
+2 IF FLAG["A"
IF $PIECE(N99,U,4)
QUIT "0^inactive facility"
+3 IF FLAG["M"
IF $SELECT(X=358:0,X=740:0,X<400:1,X>759:1,X<700:0,X<750:1,1:0)
IF $GET(DUZ("AG"))="V"
QUIT "0^not a treating facility"
+4 QUIT IEN
+5 ;
LOOKUP ; -- lookup an enty by coding system / ID pair
+1 ;
+2 NEW DIC,D
+3 ;
+4 SET DIC="^DIC(4,"
SET DIC(0)="QEA"
SET D="XUMFIDX"
DO IX^DIC
+5 ;
+6 QUIT
+7 ;
IDX(CDSYS,ID) ; -- return IEN for a given coding system / ID pair
+1 ;
+2 ;INPUT
+3 ; CDSYS coding system (required)
+4 ; ID identifier (required)
+5 ;OUTPUT
+6 ; $$ Internal Entry Number
+7 ;
+8 NEW IEN
+9 ;
+10 SET CDSYS=$GET(CDSYS)
SET ID=$GET(ID)
+11 ;
+12 if CDSYS=""
QUIT "0^CDSYS required"
+13 if ID=""
QUIT "0^ID required"
+14 ;
+15 IF CDSYS="VASTANUM"
QUIT $ORDER(^DIC(4,"D",ID,0))
+16 IF CDSYS="NPI"
QUIT $ORDER(^DIC(4,"ANPI",ID,0))
+17 ;
+18 SET IEN=$ORDER(^DIC(4,"XUMFIDX",CDSYS,ID,0))
+19 ;
+20 QUIT $SELECT(IEN:IEN,1:"0^not found")
+21 ;
ID(CDSYS,IEN) ; returns the ID for a given coding system / IEN
+1 ;
+2 ;INPUT
+3 ; CDSYS coding system (required)
+4 ; IEN Internal Entry Number (required)
+5 ;OUTPUT
+6 ; $$ Identifier
+7 ;
+8 NEW ID,IDX
+9 ;
+10 SET CDSYS=$GET(CDSYS)
SET IEN=$GET(IEN)
+11 if CDSYS=""
QUIT ""
if 'IEN
QUIT ""
if '$DATA(^DIC(4,IEN))
QUIT ""
+12 ;
+13 IF CDSYS="VASTANUM"
QUIT $PIECE($GET(^DIC(4,+IEN,99)),U)
+14 IF CDSYS="NPI"
QUIT $PIECE($GET(^DIC(4,+IEN,"NPI")),U)
+15 ;
+16 SET IDX=$ORDER(^DIC(4,IEN,9999,"B",CDSYS,0))
if 'IDX
QUIT ""
+17 ;
+18 QUIT $PIECE($GET(^DIC(4,IEN,9999,IDX,0)),U,2)
+19 ;
CDSYS(Y) ; coding systems
+1 ;
+2 ;INPUT/OUTPUT
+3 ; .Y Y(CDSYS) = $D local system ^ coding system name
+4 ;
+5 SET Y("DMIS")=$DATA(^DIC(4,"XUMFIDX","DMIS"))_U_"DoD DMIS ID"
+6 SET Y("VASTANUM")=$DATA(^DIC(4,"D"))_U_"VA Station Number"
+7 SET Y("NPI")=$DATA(^DIC(4,"ANPI"))_U_"NPI"
+8 SET Y("CLIA")=$DATA(^DIC(4,"XUMFIDX","CLIA"))_U_"CLIA number"
+9 SET Y("MAMMO-ACR")=$DATA(^DIC(4,"XUMFIDX","MAMMO-ACR"))_U_"MAMMO-ACR number"
+10 ;
+11 QUIT
+12 ;
LCDSYS(Y) ; list coding systems
+1 ;
+2 NEW CDSYS
+3 SET CDSYS=""
+4 SET CDSYS("NPI")=""
SET CDSYS("VASTANUM")=""
+5 FOR
SET CDSYS=$ORDER(^DIC(4,"XUMFIDX",CDSYS))
if CDSYS=""
QUIT
Begin DoDot:1
+6 SET Y(CDSYS)=""
End DoDot:1
+7 ;
+8 QUIT
+9 ;
BNIEN(IEN) ; -- Billing Facility Name - Internal Entry Number
+1 ;
+2 QUIT $PIECE($GET(^DIC(4,+IEN,99)),U,2)
+3 ;
BNSTA(STA) ; -- Billing Facility Name - Station Number
+1 ;
+2 QUIT $PIECE($GET(^DIC(4,+$$IEN^XUAF4(STA),99)),U,2)
+3 ;
CERNER(STA) ; Check if a facility has been converted to CERNER
+1 ; Take in STA = Station number
+2 ; Return -1 for invalid station number
+3 ; Return 1 for CERNER station
+4 NEW XUSIEN
+5 SET XUSIEN=+$$IEN^XUAF4(STA)
IF XUSIEN'>0
QUIT "-1^"_STA_" is not a valid station number"
+6 QUIT $PIECE($GET(^DIC(4,XUSIEN,102)),U)
+7 ;
