- 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 Jan 18, 2025@03:10:09 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 ;