Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XUAF4

XUAF4.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified
  1. Q ;No access from the top.
  1. ;
  1. PARENT(ROOT,CHILD,ASSO) ;sr. Return array of IEN's of parents
  1. N %,%0
  1. S CHILD=$$LKUP(CHILD),ASSO=$$ASSO($G(ASSO)),%=0
  1. F S %=$O(^DIC(4,CHILD,7,%)) Q:%'>0 S %0=+$P(^(%,0),U,2) D
  1. . Q:+%'=ASSO
  1. . S @ROOT@("P",+%0)=$$NS(+%0)
  1. Q
  1. CHILDREN(ROOT,PAR,ASSO,XUAC) ;sr. Return the children
  1. N %,%1 S %=0,PAR=$$LKUP(PAR),ASSO=$$ASSO($G(ASSO)),XUAC=$G(XUAC)
  1. Q:ASSO'>0
  1. F S %=$O(^DIC(4,"AC",ASSO,PAR,%)) Q:%'>0 D
  1. . I XUAC,$$STATUS(%)="I" Q
  1. . S @ROOT@("C",%)=$$NS(%)
  1. Q
  1. SIBLING(ROOT,CHILD,ASSO) ;sr. Return the siblings
  1. N % S %=0,ASSO=$$ASSO($G(ASSO))
  1. D PARENT(ROOT,CHILD,ASSO)
  1. F S %=$O(@ROOT@("P",%)) Q:%'>0 D CHILDREN($NA(@ROOT@("P",%)),"`"_%,ASSO)
  1. Q
  1. NNT(%) ;ef.sr. Return Name, Station Number, ASSO
  1. I %'>0 Q ""
  1. Q $$NS(%)_"^"_$$WHAT(%,13)
  1. ;
  1. LKUP(%) ;ef.sr. Resolve a value into IEN
  1. I $E(%)="`" S %=+$E(%,2,99) Q:$D(^DIC(4,%,0))#2 % Q 0
  1. ;Q $$FIND1^DIC(4,,"MX",%)
  1. Q $$FIND1^DIC(4,,"MX",%,,"I $P(^(0),U,11)'=""I""") ;To screen Inactive
  1. ;
  1. STATUS(%) ;Get the status of a IEN
  1. Q $P($G(^DIC(4,%,0)),U,11)
  1. ;
  1. TYPE(%) ;Lookup a Faclity TYPE in file 4.1
  1. I %="" Q %
  1. I $D(^DIC(4.1,"B",%))>9 Q %
  1. S %=$$FIND1^DIC(4.1,,"MX",%)
  1. Q $P($G(^DIC(4.1,+%,0)),U)
  1. ;
  1. ASSO(%) ;Lookup an Asso
  1. Q:+%=% % S:%="" %="VISN"
  1. S %=$$FIND1^DIC(4.05,,"MX",%)
  1. Q +%
  1. ;
  1. NS(IEN) ;ef.sr. Return name and station #
  1. Q $P($G(^DIC(4,IEN,0)),U,1)_U_$P($G(^DIC(4,+IEN,99)),U,1)
  1. ;
  1. WHAT(IEN,FLD) ;ef.sr. Field to return
  1. Q $$GET1^DIQ(4,IEN_",",FLD,"")
  1. ;
  1. CIRN(%1,%2) ;ef.sr. Is this a CIRN Enables inst.
  1. N % S %1=+$G(%1)
  1. Q:'$D(^DIC(4,%1,0)) -1
  1. I $G(%2)]"" N DIE,DR,DA S DA=%1,DR="990.1///"_%2,DIE="^DIC(4," D ^DIE
  1. Q $$WHAT(%1,990.1)
  1. ;
  1. IEN(STA) ;return IEN for a station number
  1. S STA=$G(STA) Q:STA="" STA
  1. Q $O(^DIC(4,"D",STA,0))
  1. ;
  1. STA(IEN) ;return station number for an IEN
  1. Q $P($G(^DIC(4,+IEN,99)),U)
  1. ;
  1. TF(IEN) ;active treating facility? (1=YES,0=NO)
  1. N ARRAY Q:'$G(IEN) 0
  1. D F4($$STA(IEN),.ARRAY,"AM")
  1. Q $S(ARRAY:1,1:0)
  1. ;
  1. RT(IEN) ;realigned to
  1. N ARRAY Q:'$G(IEN) 0
  1. D F4($$STA(IEN),.ARRAY)
  1. Q $G(ARRAY("REALIGNED TO"))
  1. ;
  1. RF(IEN) ;realigned from
  1. N ARRAY Q:'$G(IEN) 0
  1. D F4($$STA(IEN),.ARRAY)
  1. Q $G(ARRAY("REALIGNED FROM"))
  1. ;
  1. O99(IEN) ;returns pointer to new station number IEN
  1. Q:$O(^DIC(4,"AOLD99",+$G(IEN),""))="" ""
  1. Q $O(^DIC(4,"D",$O(^DIC(4,"AOLD99",+$G(IEN),"")),0))
  1. ;
  1. LEGACY(STA) ; -- legacy station number (1=yes; 0=no)
  1. Q $S($$RT^XUAF4(+$$IEN^XUAF4(STA)):1,1:0)
  1. ;
  1. PRNT(STA) ; -- parent facility
  1. N X S STA=$G(STA) Q:STA="" "0^no station number passed"
  1. D PARENT("X",STA,"PARENT FACILITY") S X=$O(X("P",0))
  1. Q:'X "0^no parent associated with input station number"
  1. Q X_U_$P($G(X("P",+X)),U,2)_U_$P($G(X("P",+X)),U)
  1. ;
  1. NAME(IEN) ; -- Official Name
  1. Q:$P($G(^DIC(4,+IEN,99)),U,3)'="" $P($G(^DIC(4,+IEN,99)),U,3)
  1. Q $P($G(^DIC(4,+IEN,0)),U)
  1. ;
  1. ACTIVE(IEN) ; -- active facility (1=active, 0=inactive)
  1. ;
  1. Q '$P($G(^DIC(4,+IEN,99)),U,4)
  1. ;
  1. PADD(IEN) ; -- physical address (street addr^city^state^zip)
  1. ;
  1. N X,STATE
  1. ;
  1. S X=$P($G(^DIC(4,+IEN,0)),U,2)
  1. S STATE=$P($G(^DIC(5,+X,0)),U,2)
  1. S X=$G(^DIC(4,+IEN,1)) Q:X="" X
  1. ;
  1. Q $P(X,U)_U_$P(X,U,3)_U_STATE_U_$P(X,U,4)
  1. ;
  1. HPADD(IEN,XUEDT) ; -- historical physical address based on effective date
  1. ;
  1. Q:$G(XUEDT)=""
  1. N XUADD1,XUADD2,XUCITY,XUSTDA,XUSTATE,XUZIP,XULINE
  1. ;
  1. ; Find valid historical address fields based on effective date
  1. ;
  1. S XULINE=""
  1. I '$D(^DIC(4,+IEN,999)) Q XULINE
  1. N XUHFND,XUHDA,IENS,XUHRRY
  1. S XUHDA="",XUHFND=0
  1. F S XUHDA=$O(^DIC(4,+IEN,999,"B",XUHDA)) Q:XUHDA=""!XUHFND I $D(^DIC(4,+IEN,999,XUHDA,1)) D
  1. . I XUEDT<XUHDA D
  1. . . S IENS=XUHDA_","_+IEN_","
  1. . . D GETS^DIQ(4.999,IENS,"1:1.4","IE","XUHRRY")
  1. . . S XUHFND=1,XUADD1=XUHRRY(4.999,IENS,1,"E"),XUADD2=XUHRRY(4.999,IENS,1.1,"E")
  1. . . S XUCITY=XUHRRY(4.999,IENS,1.2,"E"),XUZIP=XUHRRY(4.999,IENS,1.4,"E")
  1. . . S XUSTDA=XUHRRY(4.999,IENS,1.3,"I"),XUSTATE=$P($G(^DIC(5,XUSTDA,0)),U,2)
  1. . . S XULINE=XUADD1_U_XUADD2_U_XUCITY_U_XUSTATE_U_XUZIP
  1. . . K XUHRRY
  1. ;
  1. Q XULINE
  1. ;
  1. MADD(IEN) ; -- mailing address (street addr^city^state^zip)
  1. ;
  1. N X,STATE
  1. ;
  1. S X=$G(^DIC(4,+IEN,4)) Q:X="" X
  1. S STATE=$P($G(^DIC(5,+$P(X,U,4),0)),U,2)
  1. ;
  1. Q $P(X,U)_U_$P(X,U,3)_U_STATE_U_$P(X,U,5)
  1. ;
  1. F4(STA,ARRAY,FLAG,ONDT) ;File #4 multipurpose API
  1. ;
  1. ;INPUT
  1. ; STA Station number (required)
  1. ;
  1. ; [.]ARRAY $NAME reference for return values. (required)
  1. ;
  1. ; FLAG A = Active entries only. (optional)
  1. ; M = Medical treating facilities only.
  1. ;
  1. ; ONDT Return name on this FM internal date. (optional);
  1. ;
  1. ;OUTPUT
  1. ; ARRAY IEN or '0^error message'
  1. ; ARRAY("NAME") name
  1. ; ARRAY("VA NAME") offical va name
  1. ; ARRAY("STATION NUMBER") station number
  1. ; ARRAY("TYPE") facilty type name
  1. ; ARRAY("INACTIVE") inactive date (0=not inactive)
  1. ; note: if inactive date not available but entry inactive then 1
  1. ;
  1. ; ARRAY("REALIGNED TO") IEN^station number^date
  1. ; ARRAY("REALIGNED FROM") IEN^station number^date
  1. ;
  1. K ARRAY
  1. S STA=$G(STA),FLAG=$G(FLAG),ONDT=$G(ONDT)
  1. I STA="" S ARRAY="0^invalid input STA - required" Q
  1. ;
  1. N IEN,N99,TO,FM,I,RDT,NAME,VANAME,HDT
  1. ;
  1. S IEN=$$IEN(STA)
  1. I 'IEN S ARRAY="0^station number does not exist" Q
  1. S N99=$G(^DIC(4,+IEN,99))
  1. S ARRAY=$$SCRN() Q:'ARRAY
  1. ;
  1. S ARRAY("NAME")=$P(^DIC(4,IEN,0),U)
  1. S ARRAY("VA NAME")=$P(N99,U,3)
  1. S ARRAY("STATION NUMBER")=STA
  1. S ARRAY("TYPE")=$P($G(^DIC(4.1,+$G(^DIC(4,IEN,3)),0)),U)
  1. ;
  1. ;realignments
  1. S TO=$O(^DIC(4,"ARTO",IEN,0)) D:TO
  1. .S RDT=$O(^DIC(4,"ART",TO,IEN,0))
  1. .S ARRAY("REALIGNED TO")=TO_U_$$STA(TO)_U_RDT
  1. S FM=$O(^DIC(4,"ARFM",IEN,0)) D:FM
  1. .S ARRAY("REALIGNED FROM")=FM_U_$$STA(FM)_U_$O(^DIC(4,"ARF",FM,IEN,0))
  1. ;
  1. S I=$O(^DIC(4,"AI",IEN,0)),I=$S(I:I,$G(RDT):RDT,1:+$P(N99,U,4))
  1. S ARRAY("INACTIVE")=I
  1. ;
  1. Q:'ONDT
  1. ;
  1. ;get name for date
  1. S NAME=ARRAY("NAME")
  1. S VANAME=ARRAY("VA NAME")
  1. S HDT=DT
  1. F S HDT=$O(^DIC(4,IEN,999,HDT),-1) Q:('HDT!(HDT<ONDT)) D
  1. .N X S X=$G(^DIC(4,IEN,999,HDT,0)) Q:X=""
  1. .S:$P(X,U,2)'="" NAME=$P(X,U,2)
  1. .S:$P(X,U,3)'="" VANAME=$P(X,U,3)
  1. S ARRAY("NAME")=NAME
  1. S ARRAY("VA NAME")=VANAME
  1. ;
  1. Q
  1. ;
  1. IDT(IEN) ; inactive date
  1. N IDT,ND,XDT
  1. S IEN=$G(IEN) Q:'IEN IEN
  1. S XDT=9999999,IDT=""
  1. F S XDT=$O(^DIC(4,+IEN,999,XDT),-1) Q:'XDT D Q:IDT
  1. .S ND=$G(^DIC(4,+IEN,999,XDT,0)) Q:ND=""
  1. .S IDT=$S($P(ND,U,5):XDT,$P(ND,U,7):XDT,1:IDT)
  1. Q IDT
  1. ;
  1. SCRN() ;sreen IEN
  1. N X S X=$E(N99,1,3)
  1. I FLAG["A",$P(N99,U,4) Q "0^inactive facility"
  1. 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"
  1. Q IEN
  1. ;
  1. LOOKUP ; -- lookup an enty by coding system / ID pair
  1. ;
  1. N DIC,D
  1. ;
  1. S DIC="^DIC(4,",DIC(0)="QEA",D="XUMFIDX" D IX^DIC
  1. ;
  1. Q
  1. ;
  1. IDX(CDSYS,ID) ; -- return IEN for a given coding system / ID pair
  1. ;
  1. ;INPUT
  1. ; CDSYS coding system (required)
  1. ; ID identifier (required)
  1. ;OUTPUT
  1. ; $$ Internal Entry Number
  1. ;
  1. N IEN
  1. ;
  1. S CDSYS=$G(CDSYS),ID=$G(ID)
  1. ;
  1. Q:CDSYS="" "0^CDSYS required"
  1. Q:ID="" "0^ID required"
  1. ;
  1. I CDSYS="VASTANUM" Q $O(^DIC(4,"D",ID,0))
  1. I CDSYS="NPI" Q $O(^DIC(4,"ANPI",ID,0))
  1. ;
  1. S IEN=$O(^DIC(4,"XUMFIDX",CDSYS,ID,0))
  1. ;
  1. Q $S(IEN:IEN,1:"0^not found")
  1. ;
  1. ID(CDSYS,IEN) ; returns the ID for a given coding system / IEN
  1. ;
  1. ;INPUT
  1. ; CDSYS coding system (required)
  1. ; IEN Internal Entry Number (required)
  1. ;OUTPUT
  1. ; $$ Identifier
  1. ;
  1. N ID,IDX
  1. ;
  1. S CDSYS=$G(CDSYS),IEN=$G(IEN)
  1. Q:CDSYS="" "" Q:'IEN "" Q:'$D(^DIC(4,IEN)) ""
  1. ;
  1. I CDSYS="VASTANUM" Q $P($G(^DIC(4,+IEN,99)),U)
  1. I CDSYS="NPI" Q $P($G(^DIC(4,+IEN,"NPI")),U)
  1. ;
  1. S IDX=$O(^DIC(4,IEN,9999,"B",CDSYS,0)) Q:'IDX ""
  1. ;
  1. Q $P($G(^DIC(4,IEN,9999,IDX,0)),U,2)
  1. ;
  1. CDSYS(Y) ; coding systems
  1. ;
  1. ;INPUT/OUTPUT
  1. ; .Y Y(CDSYS) = $D local system ^ coding system name
  1. ;
  1. S Y("DMIS")=$D(^DIC(4,"XUMFIDX","DMIS"))_U_"DoD DMIS ID"
  1. S Y("VASTANUM")=$D(^DIC(4,"D"))_U_"VA Station Number"
  1. S Y("NPI")=$D(^DIC(4,"ANPI"))_U_"NPI"
  1. S Y("CLIA")=$D(^DIC(4,"XUMFIDX","CLIA"))_U_"CLIA number"
  1. S Y("MAMMO-ACR")=$D(^DIC(4,"XUMFIDX","MAMMO-ACR"))_U_"MAMMO-ACR number"
  1. ;
  1. Q
  1. ;
  1. LCDSYS(Y) ; list coding systems
  1. ;
  1. N CDSYS
  1. S CDSYS=""
  1. S CDSYS("NPI")="",CDSYS("VASTANUM")=""
  1. F S CDSYS=$O(^DIC(4,"XUMFIDX",CDSYS)) Q:CDSYS="" D
  1. .S Y(CDSYS)=""
  1. ;
  1. Q
  1. ;
  1. BNIEN(IEN) ; -- Billing Facility Name - Internal Entry Number
  1. ;
  1. Q $P($G(^DIC(4,+IEN,99)),U,2)
  1. ;
  1. BNSTA(STA) ; -- Billing Facility Name - Station Number
  1. ;
  1. Q $P($G(^DIC(4,+$$IEN^XUAF4(STA),99)),U,2)
  1. ;
  1. CERNER(STA) ; Check if a facility has been converted to CERNER
  1. ; Take in STA = Station number
  1. ; Return -1 for invalid station number
  1. ; Return 1 for CERNER station
  1. N XUSIEN
  1. S XUSIEN=+$$IEN^XUAF4(STA) I XUSIEN'>0 Q "-1^"_STA_" is not a valid station number"
  1. Q $P($G(^DIC(4,XUSIEN,102)),U)
  1. ;