Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (14 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

File:
1 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP8.m

    r613 r623  
    1 IBCEP8  ;ALB/TMP - Functions for NON-VA PROVIDER ;11-07-00
    2         ;;2.0;INTEGRATED BILLING;**51,137,232,288,320,343,374,377,391**;21-MAR-94;Build 39
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 EN      ; -- main entry point
    6         N IBNPRV
    7         K IBFASTXT
    8         D FULL^VALM1
    9         D EN^VALM("IBCE PRVNVA MAINT")
    10         Q
    11         ;
    12 HDR     ; -- header code
    13         K VALMHDR
    14         Q
    15         ;
    16 INIT    ; Initialization
    17         N DIC,DA,X,Y,DLAYGO,IBIF,DIR,DTOUT,DUOUT
    18         K ^TMP("IBCE_PRVNVA_MAINT",$J)
    19         ;
    20         ; if coming in from main routine ^IBCEP6 this special variable IBNVPMIF is set already
    21         I $G(IBNVPMIF)'="" S IBIF=IBNVPMIF G INIT1
    22         ;
    23         S DIR("A")="(I)NDIVIDUAL OR (F)ACILITY?: ",DIR(0)="SA^I:INDIVIDUAL;F:FACILITY" D ^DIR K DIR
    24         I $D(DUOUT)!$D(DTOUT) S VALMQUIT=1 G INITQ
    25         S IBIF=Y
    26         ;
    27 INIT1   ;
    28         ;
    29         I IBIF="F" D
    30         . S VALM("TITLE")="Non-VA Lab or Facility Info"
    31         . K VALM("PROTOCOL")
    32         . S Y=$$FIND1^DIC(101,,,"IBCE PRVNVA NONIND MAINT")
    33         . I Y S VALM("PROTOCOL")=+Y_";ORD(101,"
    34         ;
    35         S DIC="^IBA(355.93,",DIC("DR")=".02///"_$S(IBIF'="F":2,1:1)
    36         S DIC("S")="I $P(^(0),U,2)="_$S(IBIF'="F":2,1:1)
    37         S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON"_$S(IBIF="I":"-",1:"/OTHER ")_"VA PROVIDER: "
    38         D ^DIC K DIC,DLAYGO
    39         I Y'>0 S VALMQUIT=1 G INITQ
    40         S IBNPRV=+Y
    41         D BLD^IBCEP8B(IBNPRV)
    42 INITQ   Q
    43         ;
    44 EXPND   ;
    45         Q
    46         ;
    47 HELP    ;
    48         Q
    49         ;
    50 EXIT    ;
    51         K ^TMP("IBCE_PRVNVA_MAINT",$J)
    52         D CLEAN^VALM10
    53         K IBFASTXT
    54         Q
    55         ;
    56 EDIT1(IBNPRV,IBNOLM)    ; Edit non-VA provider/facility demographics
    57         ; IBNPRV = ien of entry in file 355.93
    58         ; IBNOLM = 1 if not called from list manager
    59         ;
    60         N DA,X,Y,DIE,DR,IBP
    61         I '$G(IBNOLM) D FULL^VALM1
    62         I IBNPRV D
    63         . I '$G(IBNOLM) D CLEAR^VALM1
    64         . S DIE="^IBA(355.93,",DA=IBNPRV,IBP=($P($G(^IBA(355.93,IBNPRV,0)),U,2)=2)
    65         . ; PRXM/KJH - Added NPI and Taxonomy to the list of fields to be edited. Put a "NO^" around the Taxonomy multiple (#42) since some of the sub-field entries are 'required'.
    66         . S DR=".01;"_$S(IBP:".03;.04",1:".05;.1;.06;.07;.08;.13///24;W !,""ID Qualifier: 24 - EMPLOYER'S IDENTIFICATION #"";.09Lab or Facility Primary ID;.11;.15")_";D PRENPI^IBCEP81(IBNPRV);D EN^IBCEP82(IBNPRV);S DIE(""NO^"")="""";42;K DIE(""NO^"")"
    67         . D ^DIE
    68         . Q:$G(IBNOLM)
    69         . D BLD^IBCEP8B(IBNPRV)
    70         I '$G(IBNOLM) K VALMBCK S VALMBCK="R"
    71         Q
    72         ;
    73 EDITID(IBNPRV,IBSLEV)   ; Link from this list template to maintain provider-specific ids
    74         ; This entry point is called by 4 action protocols.
    75         ; IBNPRV = ien of entry in file 355.93 (can be either an individual or a facility) (required)
    76         ; IBSLEV = 1 for facility/provider own ID's
    77         ; IBSLEV = 2 for facility/provider ID's furnished by an insurance company
    78         ;
    79         Q:'$G(IBNPRV)
    80         Q:'$G(IBSLEV)
    81         N IBPRV,IBIF
    82         D FULL^VALM1    ; set full scrolling region
    83         D CLEAR^VALM1   ; clear screen
    84         S IBPRV=IBNPRV
    85         ;
    86         K IBFASTXT
    87         S IBIF=$$GET1^DIQ(355.93,IBPRV,.02,"I")    ; 1=facility/group      2=individual
    88         D EN^VALM("IBCE PRVPRV MAINT")
    89         ;
    90         K VALMQUIT
    91         S VALMBCK=$S($G(IBFASTXT)'="":"Q",1:"R")
    92         Q
    93         ;
    94 NVAFAC  ; Enter/edit Non-VA facility information
    95         ; This entry point is called by the menu system for option IBCE PRVNVA FAC EDIT
    96         N X,Y,DA,DIC,IBNPRV,DLAYGO
    97         S DIC="^IBA(355.93,",DIC("S")="I $P(^(0),U,2)=1",DIC("DR")=".02///1"
    98         S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON/Other VA FACILITY: "
    99         D ^DIC K DIC,DLAYGO
    100         I Y'>0 S VALMQUIT=1 G NVAFACQ
    101         S IBNPRV=+Y
    102         D EDIT1(IBNPRV,1)
    103         ;
    104 NVAFACQ Q
    105         ;
    106 GETFAC(IB,IBFILE,IBELE,IBSFD)   ; Returns facility name,address lines or city-state-zip
    107         ; IB = ien of entry in file
    108         ; IBFILE = 0 for retrieval from file 4, 1 for retrieval from file 355.93
    109         ; If IBELE=0, returns name
    110         ;         =1, returns address line 1
    111         ;         =2, returns address line 2
    112         ;         =3, returns city, state zip
    113         ;         = "3C", returns city  = "3S", state    = "3Z", zip
    114         ; IBSFD (optional) = Output formatter segment name if the output needs
    115         ;       to be screened thru the VAMCFD^IBCEF75 procedure for the flag
    116         ;       in the insurance company file
    117         ;
    118         N Z,IBX,IBZ
    119         S IBX=""
    120         ;
    121         I $G(IBSFD)="SUB" D VAMCFD^IBCEF75(+$G(IBXIEN),.IBZ) I $D(IBZ),'$G(IBZ("C",1)) G GETFACX
    122         ;
    123         S Z=$S('IBFILE:$G(^DIC(4,+IB,1)),1:$G(^IBA(355.93,+IB,0)))
    124         I +IBELE=0 S IBX=$S('IBFILE:$P($G(^DIC(4,+IB,0)),U),1:$P($G(^IBA(355.93,+IB,0)),U))
    125         I IBELE=1!(IBELE=12) S IBX=$S('IBFILE:$P(Z,U),1:$P(Z,U,5))
    126         I IBELE=2!(IBELE=12) S IBX=$S(IBELE=12:IBX_" ",1:"")_$S('IBFILE:$P(Z,U,2),1:$P(Z,U,10))
    127         ;
    128         I +IBELE=3,'IBFILE D
    129         . S:IBELE=3!(IBELE["C") IBX=$P(Z,U,3) Q:IBELE["C"
    130         . S:IBELE=3 IBX=IBX_$S(IBX'="":", ",1:"") S:IBELE=3!(IBELE["S") IBX=IBX_$$STATE^IBCEFG1($P($G(^DIC(4,+IB,0)),U,2)) Q:IBELE["S"
    131         . S:IBELE=3 IBX=IBX_" " S:IBELE=3!(IBELE["Z") IBX=IBX_$P(Z,U,4)
    132         . Q
    133         ;
    134         I +IBELE=3,IBFILE D
    135         . S:IBELE=3!(IBELE["C") IBX=$P(Z,U,6) Q:IBELE["C"
    136         . S:IBELE=3 IBX=IBX_$S(IBX'="":", ",1:"") S:IBELE=3!(IBELE["S") IBX=IBX_$$STATE^IBCEFG1($P(Z,U,7))
    137         . S:IBELE=3 IBX=IBX_" " S:IBELE=3!(IBELE["Z") IBX=IBX_$P(Z,U,8)
    138         . Q
    139 GETFACX ;
    140         Q IBX
    141         ;
    142 ALLID(IBPRV,IBPTYP,IBZ) ; Returns array IBZ for all ids for provider IBPRV
    143         ; for all provider id types or for id type in IBPTYP
    144         ; IBPRV = vp ien of provider
    145         ; IBPTYP = ien of provider id type to return or "" for all
    146         ; IBZ = array returned with internal data:
    147         ;  IBZ(file 355.9 ien)=ID type^ID#^ins co^form type^bill care type^care un^X12 code for id type
    148         N Z,Z0
    149         K IBZ
    150         G:'$G(IBPRV) ALLIDQ
    151         S IBPTYP=$G(IBPTYP)
    152         S Z=0 F  S Z=$O(^IBA(355.9,"B",IBPRV,Z)) Q:'Z  S Z0=$G(^IBA(355.9,Z,0)) D
    153         . I $S(IBPTYP="":1,1:($P(Z0,U,6)=IBPTYP)) S IBZ(Z)=($P(Z0,U,6)_U_$P(Z0,U,7)_U_$P(Z0,U,2)_U_$P(Z0,U,4)_U_$P(Z0,U,5)_U_$P(Z0,U,3))_U_$P($G(^IBE(355.97,+$P(Z0,U,6),0)),U,3)
    154         ;
    155 ALLIDQ  Q
    156         ;
    157 CLIA()  ; Returns ien of CLIA # provider id type
    158         N Z,IBZ
    159         S (IBZ,Z)=0 F  S Z=$O(^IBE(355.97,Z)) Q:'Z  I $P($G(^(Z,0)),U,3)="X4",$P(^(0),U)["CLIA" S IBZ=Z Q
    160         Q IBZ
    161         ;
    162 STLIC() ; Returns ien of STLIC# provider id type
    163         N Z,IBZ
    164         S (IBZ,Z)=0 F  S Z=$O(^IBE(355.97,Z)) Q:'Z  I $P($G(^(Z,1)),U,3) S IBZ=Z Q
    165         Q IBZ
    166         ;
    167 TAXID() ; Returns ien of Fed tax id provider id type
    168         N Z,IBZ
    169         S (IBZ,Z)=0 F  S Z=$O(^IBE(355.97,Z)) Q:'Z  I $P($G(^(Z,1)),U,4) S IBZ=Z Q
    170         Q IBZ
    171         ;
    172 CLIANVA(IBIFN)  ; Returns CLIA # for a non-VA facility on bill ien IBIFN
    173         N IBCLIA,IBZ,IBNVA,Z
    174         S IBCLIA="",IBZ=$$CLIA()
    175         I IBZ D
    176         . S IBNVA=$P($G(^DGCR(399,IBIFN,"U2")),U,10) Q:'IBNVA
    177         . S IBCLIA=$$IDFIND^IBCEP2(IBIFN,IBZ,IBNVA_";IBA(355.93,","",1)
    178         Q IBCLIA
    179         ;
    180 VALFAC(X)       ; Function returns 1 if format is valid for X12 facility name
    181         ; Alpha/numeric/certain punctuation valid.  Must start with an Alpha
    182         N OK,VAL
    183         S OK=1
    184         S VAL("A")="",VAL("N")="",VAL=",.- "
    185         I $E(X)'?1A!'$$VALFMT(X,.VAL) S OK=0
    186         Q OK
    187         ;
    188 VALFMT(X,VAL)   ; Returns 1 if format of X is valid, 0 if not
    189         ; X = data to be examined
    190         ; VAL = a 'string' of valid characters AND/OR (passed by reference)
    191         ;    if VAL("A") defined ==> Alpha
    192         ;    if VAL("A") defined ==> Numeric valid
    193         ;    if VAL("A") defined ==> Punctuation valid
    194         ;   any other character included in the string is checked individually
    195         N Z
    196         I $D(VAL("A")) D
    197         . N Z0
    198         . F Z=1:1:$L(X) I $E(X,Z)?1A S Z0(Z)=""
    199         . S Z0="" F  S Z0=$O(Z0(Z0),-1) Q:'Z0  S $E(X,Z0)=""
    200         I $D(VAL("N")) D
    201         . N Z0
    202         . F Z=1:1:$L(X) I $E(X,Z)?1N S Z0(Z)=""
    203         . S Z0="" F  S Z0=$O(Z0(Z0),-1) Q:'Z0  S $E(X,Z0)=""
    204         I $D(VAL("P")) D
    205         . N Z0
    206         . F Z=1:1:$L(X) I $E(X,Z)?1P S Z0(Z)=""
    207         . S Z0="" F  S Z0=$O(Z0(Z0),-1) Q:'Z0  S $E(X,Z0)=""
    208         I $G(VAL)'="" S X=$TR(X,VAL,"")
    209         Q (X="")
    210         ;
    211 PS(IBXSAVE)     ; Returns 1 if IBXSAVE("PSVC") indicates the svc was non-lab
    212         ;
    213         Q $S($G(IBXSAVE("PSVC"))="":0,1:"13"[IBXSAVE("PSVC"))
    214         ;
    215         ; Pass in the Internal Entry number to File 355.93
    216         ; Return the Primary ID and Qualifier (ID Type) from 355.9
    217 PRIMID(IEN35593)        ; Return External Primary ID and ID Quailier
    218         N INDXVAL,LIST,MSG,IDCODE
    219         S INDXVAL=IEN35593_";IBA(355.93,"
    220         N SCREEN S SCREEN="I $P(^(0),U,8)"
    221         D FIND^DIC(355.9,,"@;.06EI;.07","Q",INDXVAL,,,SCREEN,,"LIST","MSG")
    222         I '+$G(LIST("DILIST",0)) Q ""   ; No Primary ID
    223         I +$G(LIST("DILIST",0))>1 Q "***ERROR***^***ERROR***"  ; Bad.  More than one.
    224         ; Found just one
    225         S IDCODE=$$GET1^DIQ(355.97,LIST("DILIST","ID",1,.06,"I"),.03)
    226         Q $G(LIST("DILIST","ID",1,.07))_U_IDCODE_" - "_$G(LIST("DILIST","ID",1,.06,"E"))
     1IBCEP8 ;ALB/TMP - Functions for NON-VA PROVIDER ;11-07-00
     2 ;;2.0;INTEGRATED BILLING;**51,137,232,288,320,343,374**;21-MAR-94;Build 16
     3 ;
     4EN ; -- main entry point
     5 N IBNPRV
     6 K IBFASTXT
     7 D FULL^VALM1
     8 D EN^VALM("IBCE PRVNVA MAINT")
     9 Q
     10 ;
     11HDR ; -- header code
     12 K VALMHDR
     13 Q
     14 ;
     15INIT ; Initialization
     16 N DIC,DA,X,Y,DLAYGO,IBIF,DIR,DTOUT,DUOUT
     17 K ^TMP("IBCE_PRVNVA_MAINT",$J)
     18 S DIR("A")="(I)NDIVIDUAL OR (F)ACILITY?: ",DIR(0)="SA^I:INDIVIDUAL;F:FACILITY" D ^DIR K DIR
     19 I $D(DUOUT)!$D(DTOUT) S VALMQUIT=1 G INITQ
     20 S IBIF=Y
     21 ;
     22 I IBIF="F" D
     23 . S VALM("TITLE")="Non-VA Lab or Facility Info"
     24 . K VALM("PROTOCOL")
     25 . S Y=$$FIND1^DIC(101,,,"IBCE PRVNVA NONIND MAINT")
     26 . I Y S VALM("PROTOCOL")=+Y_";ORD(101,"
     27 ;
     28 S DIC="^IBA(355.93,",DIC("DR")=".02////"_$S(IBIF'="F":2,1:1)
     29 S DIC("S")="I $P(^(0),U,2)="_$S(IBIF'="F":2,1:1)
     30 S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON"_$S(IBIF="I":"-",1:"/OTHER ")_"VA PROVIDER: "
     31 D ^DIC K DIC,DLAYGO
     32 I Y'>0 S VALMQUIT=1 G INITQ
     33 S IBNPRV=+Y
     34 D BLD
     35INITQ Q
     36 ;
     37BLD ; Build/Rebuild display
     38 N IBLCT,IBCT,IBLST,IBPRI,IBIEN,Z,Z1,Z2
     39 K @VALMAR
     40 S (IBLCT,IBCT)=0,Z=$G(^IBA(355.93,IBNPRV,0))
     41 S IBCT=IBCT+1
     42 S Z1=$J("Name: ",15)_$P(Z,U) D SET1(.IBLCT,Z1,IBCT)
     43 I $P(Z,U,2)=2 D
     44 . S IBCT=IBCT+1
     45 . S Z1=$J("Type: ",15)_$S($P(Z,U,2)=2:"INDIVIDUAL PROVIDER",1:"OUTSIDE OR OTHER VA FACILITY") D SET1(.IBLCT,Z1,IBCT)
     46 . S IBCT=IBCT+1
     47 . S Z1=$J("Credentials: ",15)_$P(Z,U,3) D SET1(.IBLCT,Z1,IBCT)
     48 . S IBCT=IBCT+1
     49 . S Z1=$J("Specialty: ",15)_$P(Z,U,4) D SET1(.IBLCT,Z1,IBCT)
     50 . S IBCT=IBCT+1
     51 . S Z1=$J("NPI: ",15)_$$NPIGET^IBCEP81(IBNPRV) D SET1(.IBLCT,Z1,IBCT)
     52 . S IBCT=IBCT+1
     53 . S IBPRI=$$TAXGET^IBCEP81(IBNPRV,.IBLST)
     54 . S Z1=$J("Taxonomy Code: ",15)_$P(IBPRI,U)
     55 . I $D(IBLST) S Z1=Z1_" ("_$S($P(IBLST(IBLST),U,3)=1:"Primary",1:"Secondary")_")"
     56 . D SET1(.IBLCT,Z1,IBCT)
     57 . S IBIEN=""
     58 . F  S IBIEN=$O(IBLST(IBIEN)) Q:IBIEN=""  D
     59 .. I IBIEN=IBLST Q
     60 .. S IBCT=IBCT+1
     61 .. S Z1=$J("",15)_$P(IBLST(IBIEN),U)_" ("_$S($P(IBLST(IBIEN),U,3)=1:"Primary",1:"Secondary")_")"
     62 .. D SET1(.IBLCT,Z1,IBCT)
     63 E  D
     64 . S IBCT=IBCT+1
     65 . S Z1=$J("Address: ",15)_$P(Z,U,5) D SET1(.IBLCT,Z1,IBCT)
     66 . I $P(Z,U,10) D
     67 .. S IBCT=IBCT+1
     68 .. S Z1=$J("",15)_$P(Z,U,10)
     69 . S IBCT=IBCT+1
     70 . S Z1=$J("",15)_$P(Z,U,6)_$S($P(Z,U,6)'="":", ",1:"")_$S($P(Z,U,7):$$EXTERNAL^DILFD(355.93,.07,"",$P(Z,U,7))_"  ",1:"")_$P(Z,U,8)
     71 . D SET1(.IBLCT,Z1,IBCT)
     72 . S IBCT=IBCT+1
     73 . S Z1=" " D SET1(.IBLCT,Z1,IBCT)
     74 . S IBCT=IBCT+1
     75 . S Z1=$J("Type of Facility: ",30)_$$EXTERNAL^DILFD(355.93,.11,,$P(Z,U,11))
     76 . D SET1(.IBLCT,Z1,IBCT)
     77 . S IBCT=IBCT+1
     78 . S Z1=$J("Primary ID: ",30)_$P(Z,U,9)
     79 . D SET1(.IBLCT,Z1,IBCT)
     80 . S IBCT=IBCT+1
     81 . S Z1=$J("ID Qualifier: ",30)_$$GET1^DIQ(355.97,$P(Z,U,13),.03) I $P(Z,U,13)]"" S Z1=Z1_" - "_$$GET1^DIQ(355.97,$P(Z,U,13),.01)
     82 . D SET1(.IBLCT,Z1,IBCT)
     83 . S IBCT=IBCT+1
     84 . S Z1=$J("Mammography Certification #: ",30)_$P(Z,U,15)
     85 . D SET1(.IBLCT,Z1,IBCT)
     86 . S IBCT=IBCT+1
     87 . S Z1=$J("NPI: ",30)_$$NPIGET^IBCEP81(IBNPRV) D SET1(.IBLCT,Z1,IBCT)
     88 . S IBCT=IBCT+1
     89 . S IBPRI=$$TAXGET^IBCEP81(IBNPRV,.IBLST)
     90 . S Z1=$J("Taxonomy Code: ",30)_$P(IBPRI,U)
     91 . I $D(IBLST) S Z1=Z1_" ("_$S($P(IBLST(IBLST),U,3)=1:"Primary",1:"Secondary")_")"
     92 . D SET1(.IBLCT,Z1,IBCT)
     93 . S IBIEN=""
     94 . F  S IBIEN=$O(IBLST(IBIEN)) Q:IBIEN=""  D
     95 .. I IBIEN=IBLST Q
     96 .. S IBCT=IBCT+1
     97 .. S Z1=$J("",30)_$P(IBLST(IBIEN),U)_" ("_$S($P(IBLST(IBIEN),U,3)=1:"Primary",1:"Secondary")_")"
     98 .. D SET1(.IBLCT,Z1,IBCT)
     99 K VALMBG,VALMCNT
     100 S VALMBG=1,VALMCNT=IBLCT
     101 Q
     102 ;
     103SET1(IBLCT,TEXT,IBCT) ;
     104 S IBLCT=IBLCT+1 D SET^VALM10(IBLCT,TEXT,$G(IBCT))
     105 Q
     106EXPND ;
     107 Q
     108 ;
     109HELP ;
     110 Q
     111 ;
     112EXIT ;
     113 K ^TMP("IBCE_PRVNVA_MAINT",$J)
     114 D CLEAN^VALM10
     115 K IBFASTXT
     116 Q
     117 ;
     118EDIT1(IBNPRV,IBNOLM) ; Edit non-VA provider/facility demographics
     119 ; IBNPRV = ien of entry in file 355.93
     120 ; IBNOLM = 1 if not called from list manager
     121 ;
     122 N DA,X,Y,DIE,DR,IBP
     123 I '$G(IBNOLM) D FULL^VALM1
     124 I IBNPRV D
     125 . I '$G(IBNOLM) D CLEAR^VALM1
     126 . S DIE="^IBA(355.93,",DA=IBNPRV,IBP=($P($G(^IBA(355.93,IBNPRV,0)),U,2)=2)
     127 . ; PRXM/KJH - Added NPI and Taxonomy to the list of fields to be edited. Put a "NO^" around the Taxonomy multiple (#42) since some of the sub-field entries are 'required'.
     128 . S DR=".01;"_$S(IBP:".03;.04",1:".05;.1;.06;.07;.08;.13///24;W !,""ID Qualifier: 24 - EMPLOYER'S IDENTIFICATION #"";.09Lab or Facility Primary ID;.11;.15")_";D EN^IBCEP82;S DIE(""NO^"")="""";42;K DIE(""NO^"")"
     129 . D ^DIE
     130 . Q:$G(IBNOLM)
     131 . D BLD
     132 I '$G(IBNOLM) K VALMBCK S VALMBCK="R"
     133 Q
     134 ;
     135EDITID(IBNPRV) ; Link from this list template to maintain provider-specific ids
     136 ; IBNPRV = ien of entry in file 355.93
     137 N IBPRV
     138 D FULL^VALM1
     139 D CLEAR^VALM1
     140 S IBPRV=IBNPRV
     141 D EN1^IBCEP5
     142 K VALMQUIT
     143 S VALMBCK="R"
     144 Q
     145 ;
     146NVAFAC ; Enter/edit Non-VA facility information
     147 N X,Y,DA,DIC,IBNPRV,DLAYGO
     148 S DIC="^IBA(355.93,",DIC("S")="I $P(^(0),U,2)=1",DIC("DR")=".02////1"
     149 S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON/Other VA FACILITY: "
     150 D ^DIC K DIC,DLAYGO
     151 I Y'>0 S VALMQUIT=1 G NVAFACQ
     152 S IBNPRV=+Y
     153 D EDIT1(IBNPRV,1)
     154 ;
     155NVAFACQ Q
     156 ;
     157GETFAC(IB,IBFILE,IBELE,IBSFD) ; Returns facility name,address lines or city-state-zip
     158 ; IB = ien of entry in file
     159 ; IBFILE = 0 for retrieval from file 4, 1 for retrieval from file 355.93
     160 ; If IBELE=0, returns name
     161 ;         =1, returns address line 1
     162 ;         =2, returns address line 2
     163 ;         =3, returns city, state zip
     164 ;         = "3C", returns city  = "3S", state    = "3Z", zip
     165 ; IBSFD (optional) = Output formatter segment name if the output needs
     166 ;       to be screened thru the VAMCFD^IBCEF75 procedure for the flag
     167 ;       in the insurance company file
     168 ;
     169 N Z,IBX,IBZ
     170 S IBX=""
     171 ;
     172 I $G(IBSFD)="SUB" D VAMCFD^IBCEF75(+$G(IBXIEN),.IBZ) I $D(IBZ),'$G(IBZ("C",1)) G GETFACX
     173 ;
     174 S Z=$S('IBFILE:$G(^DIC(4,+IB,1)),1:$G(^IBA(355.93,+IB,0)))
     175 I +IBELE=0 S IBX=$S('IBFILE:$P($G(^DIC(4,+IB,0)),U),1:$P($G(^IBA(355.93,+IB,0)),U))
     176 I IBELE=1!(IBELE=12) S IBX=$S('IBFILE:$P(Z,U),1:$P(Z,U,5))
     177 I IBELE=2!(IBELE=12) S IBX=$S(IBELE=12:IBX_" ",1:"")_$S('IBFILE:$P(Z,U,2),1:$P(Z,U,10))
     178 ;
     179 I +IBELE=3,'IBFILE D
     180 . S:IBELE=3!(IBELE["C") IBX=$P(Z,U,3) Q:IBELE["C"
     181 . S:IBELE=3 IBX=IBX_$S(IBX'="":", ",1:"") S:IBELE=3!(IBELE["S") IBX=IBX_$$STATE^IBCEFG1($P($G(^DIC(4,+IB,0)),U,2)) Q:IBELE["S"
     182 . S:IBELE=3 IBX=IBX_" " S:IBELE=3!(IBELE["Z") IBX=IBX_$P(Z,U,4)
     183 . Q
     184 ;
     185 I +IBELE=3,IBFILE D
     186 . S:IBELE=3!(IBELE["C") IBX=$P(Z,U,6) Q:IBELE["C"
     187 . S:IBELE=3 IBX=IBX_$S(IBX'="":", ",1:"") S:IBELE=3!(IBELE["S") IBX=IBX_$$STATE^IBCEFG1($P(Z,U,7))
     188 . S:IBELE=3 IBX=IBX_" " S:IBELE=3!(IBELE["Z") IBX=IBX_$P(Z,U,8)
     189 . Q
     190GETFACX ;
     191 Q IBX
     192 ;
     193ALLID(IBPRV,IBPTYP,IBZ) ; Returns array IBZ for all ids for provider IBPRV
     194 ; for all provider id types or for id type in IBPTYP
     195 ; IBPRV = vp ien of provider
     196 ; IBPTYP = ien of provider id type to return or "" for all
     197 ; IBZ = array returned with internal data:
     198 ;  IBZ(file 355.9 ien)=ID type^ID#^ins co^form type^bill care type^care un^X12 code for id type
     199 N Z,Z0
     200 K IBZ
     201 G:'$G(IBPRV) ALLIDQ
     202 S IBPTYP=$G(IBPTYP)
     203 S Z=0 F  S Z=$O(^IBA(355.9,"B",IBPRV,Z)) Q:'Z  S Z0=$G(^IBA(355.9,Z,0)) D
     204 . I $S(IBPTYP="":1,1:($P(Z0,U,6)=IBPTYP)) S IBZ(Z)=($P(Z0,U,6)_U_$P(Z0,U,7)_U_$P(Z0,U,2)_U_$P(Z0,U,4)_U_$P(Z0,U,5)_U_$P(Z0,U,3))_U_$P($G(^IBE(355.97,+$P(Z0,U,6),0)),U,3)
     205 ;
     206ALLIDQ Q
     207 ;
     208CLIA() ; Returns ien of CLIA # provider id type
     209 N Z,IBZ
     210 S (IBZ,Z)=0 F  S Z=$O(^IBE(355.97,Z)) Q:'Z  I $P($G(^(Z,0)),U,3)="X4",$P(^(0),U)["CLIA" S IBZ=Z Q
     211 Q IBZ
     212 ;
     213STLIC() ; Returns ien of STLIC# provider id type
     214 N Z,IBZ
     215 S (IBZ,Z)=0 F  S Z=$O(^IBE(355.97,Z)) Q:'Z  I $P($G(^(Z,1)),U,3) S IBZ=Z Q
     216 Q IBZ
     217 ;
     218TAXID() ; Returns ien of Fed tax id provider id type
     219 N Z,IBZ
     220 S (IBZ,Z)=0 F  S Z=$O(^IBE(355.97,Z)) Q:'Z  I $P($G(^(Z,1)),U,4) S IBZ=Z Q
     221 Q IBZ
     222 ;
     223CLIANVA(IBIFN) ; Returns CLIA # for a non-VA facility on bill ien IBIFN
     224 N IBCLIA,IBZ,IBNVA,Z
     225 S IBCLIA="",IBZ=$$CLIA()
     226 I IBZ D
     227 . S IBNVA=$P($G(^DGCR(399,IBIFN,"U2")),U,10) Q:'IBNVA
     228 . S IBCLIA=$$IDFIND^IBCEP2(IBIFN,IBZ,IBNVA_";IBA(355.93,","",1)
     229 Q IBCLIA
     230 ;
     231VALFAC(X) ; Function returns 1 if format is valid for X12 facility name
     232 ; Alpha/numeric/certain punctuation valid.  Must start with an Alpha
     233 N OK,VAL
     234 S OK=1
     235 S VAL("A")="",VAL("N")="",VAL=",.- "
     236 I $E(X)'?1A!'$$VALFMT(X,.VAL) S OK=0
     237 Q OK
     238 ;
     239VALFMT(X,VAL) ; Returns 1 if format of X is valid, 0 if not
     240 ; X = data to be examined
     241 ; VAL = a 'string' of valid characters AND/OR (passed by reference)
     242 ;    if VAL("A") defined ==> Alpha
     243 ;    if VAL("A") defined ==> Numeric valid
     244 ;    if VAL("A") defined ==> Punctuation valid
     245 ;   any other character included in the string is checked individually
     246 N Z
     247 I $D(VAL("A")) D
     248 . N Z0
     249 . F Z=1:1:$L(X) I $E(X,Z)?1A S Z0(Z)=""
     250 . S Z0="" F  S Z0=$O(Z0(Z0),-1) Q:'Z0  S $E(X,Z0)=""
     251 I $D(VAL("N")) D
     252 . N Z0
     253 . F Z=1:1:$L(X) I $E(X,Z)?1N S Z0(Z)=""
     254 . S Z0="" F  S Z0=$O(Z0(Z0),-1) Q:'Z0  S $E(X,Z0)=""
     255 I $D(VAL("P")) D
     256 . N Z0
     257 . F Z=1:1:$L(X) I $E(X,Z)?1P S Z0(Z)=""
     258 . S Z0="" F  S Z0=$O(Z0(Z0),-1) Q:'Z0  S $E(X,Z0)=""
     259 I $G(VAL)'="" S X=$TR(X,VAL,"")
     260 Q (X="")
     261 ;
     262PS(IBXSAVE) ; Returns 1 if IBXSAVE("PSVC") indicates the svc was non-lab
     263 ;
     264 Q $S($G(IBXSAVE("PSVC"))="":0,1:"13"[IBXSAVE("PSVC"))
     265 ;
     266 ; Pass in the Internal Entry number to File 355.93
     267 ; Return the Primary ID and Qualifier (ID Type) from 355.9
     268PRIMID(IEN35593) ; Return External Primary ID and ID Quailier
     269 N INDXVAL,LIST,MSG,IDCODE
     270 S INDXVAL=IEN35593_";IBA(355.93,"
     271 N SCREEN S SCREEN="I $P(^(0),U,8)"
     272 D FIND^DIC(355.9,,"@;.06EI;.07","Q",INDXVAL,,,SCREEN,,"LIST","MSG")
     273 I '+$G(LIST("DILIST",0)) Q ""   ; No Primary ID
     274 I +$G(LIST("DILIST",0))>1 Q "***ERROR***^***ERROR***"  ; Bad.  More than one.
     275 ; Found just one
     276 S IDCODE=$$GET1^DIQ(355.97,LIST("DILIST","ID",1,.06,"I"),.03)
     277 Q $G(LIST("DILIST","ID",1,.07))_U_IDCODE_" - "_$G(LIST("DILIST","ID",1,.06,"E"))
Note: See TracChangeset for help on using the changeset viewer.