IBJPS3 ;BP/YMG - IB Site Parameters, Pay-To Provider ;20-Oct-2008
;;2.0;INTEGRATED BILLING;**400,432,516,577,608**;21-MAR-94;Build 90
;;Per VA Directive 6402, this routine should not be modified.
;
; MRD;IB*2.0*516 - Added logic pertaining to TRICARE-Specific Pay-To
; Providers, which entailed adding the parameter IBTCFLAG to many
; procedures here and in ^IBJPS4.
;
EN(IBTCFLAG) ; -- main entry point for IBJP IB PAY-TO PROVIDERS
D EN^VALM("IBJP IB "_$S(IBTCFLAG:"TRICARE PAY-TO PROVS",1:"PAY-TO PROVIDERS"))
Q
;
HDR(IBTCFLAG) ; -- header code
; Not setting VALMHDR causes this tag to be called upon return from every action,
; this is done to keep VALMSG displayed at all times, instead of the default message on the lower bar.
S VALMSG="* = Default "_$S(IBTCFLAG:"Non-MCCF ",1:"")_"Pay-to provider"
Q
;
INIT(IBTCFLAG) ; -- init variables and list array
N IBCNT,IBLN,IBSTR,PIEN,PDATA,IBNODE
S IBNODE=$$NODE^IBJPS4(IBTCFLAG)
;
S (VALMCNT,IBCNT,IBLN)=0
S PIEN=0 F S PIEN=$O(^IBE(350.9,1,IBNODE,PIEN)) Q:'PIEN D
.I $P($G(^IBE(350.9,1,IBNODE,PIEN,0)),U,5)'="" Q
.S PDATA=$$PTG(PIEN,IBTCFLAG),IBCNT=IBCNT+1
.S IBSTR=$$SETSTR^VALM1(IBCNT_".","",2,4)
.I $$ISDFLT(PIEN,IBTCFLAG) S IBSTR=$$SETSTR^VALM1("*",IBSTR,7,1)
.S IBSTR=$$SETSTR^VALM1("Name : "_$P(PDATA,U),IBSTR,8,45)
.;S IBSTR=$$SETSTR^VALM1("State : "_$P(PDATA,U,8),IBSTR,54,25) ;JRA IB*2.0*577 ';'
.S IBLN=$$SET(IBLN,IBSTR)
.;S IBSTR=$$SETSTR^VALM1("Address 1: "_$P(PDATA,U,5),"",8,45) ;JRA IB*2.0*577 ';'
.S IBSTR=$$SETSTR^VALM1("Address 1: "_$P(PDATA,U,5),"",8,66) ;JRA IB*2.0*577 expand to 55 chars
.;S IBSTR=$$SETSTR^VALM1("Zip Code: "_$P(PDATA,U,9),IBSTR,54,25) ;JRA IB*2.0*577 ';'
.S IBLN=$$SET(IBLN,IBSTR)
.;S IBSTR=$$SETSTR^VALM1("Address 2: "_$P(PDATA,U,6),"",8,45) ;JRA IB*2.0*577 ';'
.S IBSTR=$$SETSTR^VALM1("Address 2: "_$P(PDATA,U,6),"",8,66) ;JRA IB*2.0*577 expand to 55 chars
.;S IBSTR=$$SETSTR^VALM1("Phone : "_$P(PDATA,U,4),IBSTR,54,25) ;JRA IB*2.0*577 ';'
.S IBLN=$$SET(IBLN,IBSTR)
.S IBSTR=$$SETSTR^VALM1("City : "_$P(PDATA,U,7),"",8,45)
.S IBLN=$$SET(IBLN,IBSTR)
.;S IBSTR=$$SETSTR^VALM1("Tax ID : "_$P(PDATA,U,3),IBSTR,54,25) ;JRA IB*2.0*577 ';'
.;JRA Move State, Zip Code, Phone and Tax ID under City to allow for longer address lines
.S IBSTR=$$SETSTR^VALM1("State : "_$P(PDATA,U,8),IBSTR,8,25) ;JRA IB*2.0*577
.S IBLN=$$SET(IBLN,IBSTR) ;JRA IB*2.0*577
.S IBSTR=$$SETSTR^VALM1("Zip Code : "_$P(PDATA,U,9),IBSTR,8,25) ;JRA IB*2.0*577
.S IBLN=$$SET(IBLN,IBSTR) ;JRA IB*2.0*577
.S IBSTR=$$SETSTR^VALM1("Phone : "_$P(PDATA,U,4),IBSTR,8,25) ;JRA IB*2.0*577
.S IBLN=$$SET(IBLN,IBSTR) ;JRA IB*2.0*577
.S IBSTR=$$SETSTR^VALM1("Tax ID : "_$P(PDATA,U,3),IBSTR,8,25) ;JRA IB*2.0*577
.S IBLN=$$SET(IBLN,IBSTR),IBLN=$$SET(IBLN,"")
.S @VALMAR@("ZIDX",IBCNT,PIEN)=""
.Q
;
I 'IBLN S IBLN=$$SET(IBLN,$$SETSTR^VALM1("No "_$S(IBTCFLAG:"Non-MCCF ",1:"")_"Pay-To Providers defined.","",13,40))
;
S VALMCNT=IBLN,VALMBG=1
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
D CLEAR^VALM1,CLEAN^VALM10
Q
;
PRVADD(IBTCFLAG) ; add new pay-to provider
N X,Y,DIC,DA,DLAYGO,DIE,DR,DIR,DIRUT,DUOUT,DTOUT,IEN,IBNODE
S IBNODE=$$NODE^IBJPS4(IBTCFLAG)
D FULL^VALM1
S VALMBCK="R"
S DIC="^IBE(350.9,1,"_IBNODE_",",DIC(0)="AELMQ",DA(1)=1,DLAYGO=350.9
S DIC("A")="Enter "_$S(IBTCFLAG:"Non-MCCF ",1:"")_"Pay-to Provider: "
D ^DIC S IEN=+Y
I IEN'>0 Q
D PRVEDIT1
I $P($G(^IBE(350.9,1,IBNODE,IEN,0)),U,2)="" D PRVDEL1
Q
;
PRVDEL(IBTCFLAG) ; delete a pay-to provider
N DA,DR,DIE,X,Y,DIR,DIRUT,DUOUT,DTOUT,I,IEN,DIVS,DFLT,IBNODE,IBDISP
S IBNODE=$$NODE^IBJPS4(IBTCFLAG)
S IBDISP=$S(IBTCFLAG:"Non-MCCF ",1:"")_"Pay-To Provider"
S VALMBCK="R"
D FULL^VALM1
S IEN=$$SEL(IBTCFLAG) Q:'IEN
S DFLT=$$ISDFLT(IEN,IBTCFLAG)
I DFLT W !!,"WARNING: This is the default "_IBDISP_"."
D GETDIVS^IBJPS4(IEN,.DIVS,IBTCFLAG)
I 'DFLT D
.W !!,"The following divisions are currently associated with this "_IBDISP_": "
.S I="" F S I=$O(DIVS(I)) Q:I="" W !,?5,DIVS(I)
.W:'$D(DIVS) "None",! W !
.Q
S DIR("?")="Enter Yes to delete this "_IBDISP_"."
S DIR("A")="Delete "_IBDISP_" "_$P($G(^IBE(350.9,1,IBNODE,IEN,0)),U,2)
S DIR(0)="YO",DIR("B")="NO" D ^DIR Q:'Y
I DFLT S DIE="^IBE(350.9,",DA=1,DR=$S(IBTCFLAG:"11.04",1:"11.03")_"////@" D ^DIE
I $D(DIVS) K DIK S DIK="^IBE(350.9,1,"_IBNODE_",",DA(1)=1,I="" F S I=$O(DIVS(I)) Q:I="" S DA=I D ^DIK
K DIK
PRVDEL1 ;
N DIK
K DA
S DIK="^IBE(350.9,1,"_IBNODE_","
S DA(1)=1,DA=IEN
D ^DIK
D CLEAN^VALM10,INIT(IBTCFLAG)
Q
;
PRVEDIT(IBTCFLAG) ; edit existing pay-to provider
N IEN,IBNODE
S IBNODE=$$NODE^IBJPS4(IBTCFLAG)
S VALMBCK="R"
D FULL^VALM1
S IEN=$$SEL(IBTCFLAG) Q:'IEN
PRVEDIT1 ;
N DIE,DA,DR,DIR,DIRUT,DUOUT,DTOUT,X,Y
S DIE="^IBE(350.9,1,"_IBNODE_","
S DA=IEN,DA(1)=1
S DR=".02T;1.01T;1.02T;1.03T;1.04T;1.05T;.04T;.03T;.05///@"
D ^DIE
S DIR("?")="Enter Yes to make this entry the default "_$S(IBTCFLAG:"Non-MCCF ",1:"")_"Pay-to Provider."
S DIR("A")="Is this the default "_$S(IBTCFLAG:"Non-MCCF ",1:"")_"Pay-To Provider"
S DIR(0)="YO"
S DIR("B")="YES" I $$GETDFLT(IBTCFLAG),'$$ISDFLT(IEN,IBTCFLAG) S DIR("B")="NO"
D ^DIR I Y K DA S DIE="^IBE(350.9,",DA=1,DR=$S(IBTCFLAG:"11.04",1:"11.03")_"////"_IEN D ^DIE
D CLEAN^VALM10,INIT(IBTCFLAG)
Q
;
SET(IBLN,IBSTR) ; add a line to display list
; returns line number added
S IBLN=IBLN+1 D SET^VALM10(IBLN,IBSTR)
Q IBLN
;
ISDFLT(PIEN,IBTCFLAG) ; returns 1 if provider with ien PIEN is the default pay-to provider, 0 otherwise
Q:PIEN="" 0
Q $$GETDFLT(IBTCFLAG)=PIEN
;
GETDFLT(IBTCFLAG) ; returns ien of default pay-to provider
Q $P($G(^IBE(350.9,1,11)),U,$S(IBTCFLAG:4,1:3))
;
SEL(IBTCFLAG) ; select pay-to provider
; returns ien of selected pay-to provider, or 0 if nothing is selected
N DIR,IEN,MAX,X,Y
S IEN=0
I VALMLST>4 D
. ; there is at least one entry
. S MAX=$O(@VALMAR@("ZIDX",""),-1) S:MAX=1 Y=1
. I MAX>1 D
. . S DIR("A")="Select "_$S(IBTCFLAG:"Non-MCCF ",1:"")_"Pay-To Provider (1-"_MAX_"): "
. . S DIR(0)="NA^"_1_":"_MAX_":0"
. . D ^DIR
. . Q
. S:+Y>0 IEN=$O(@VALMAR@("ZIDX",Y,""))
. Q
Q +IEN
;
PRVDATA(IBIFN) ; Return a string of Pay-To provider information in the following format
; [1] name
; [2] npi
; [3] tax id#
; [4] phone#
; [5] street 1
; [6] street 2
; [7] city
; [8] state abbreviation
; [9] zip
; [10] list of IB error messages if any of this data is missing in IBXX1;IBXX2;IBXX3;IBXX4; format
; [11] Institution (File 4) ien
;
; **NOTE: pieces 12,13,14 are added to this string in output formatter data element #1624 for PRV1-1.5 for PRV1
; pieces 2,3,5. If pieces are added here to this string, then adjust the code in PRV1-1.5,2,3,5 accordingly.
;
N DATA,IB0,EVDT,IBDIV,INST,PIEN,IBER,IBTCFLAG
S DATA="",IBER=""
;
S IBTCFLAG=$$TRICARE^IBJPS4(IBIFN) ; Set IBTCFLAG to '1' if TRICARE claim, otherwise '0'.
;
S IB0=$G(^DGCR(399,IBIFN,0))
S EVDT=$P(IB0,U,3) ; event date on claim
I 'EVDT S EVDT=DT
S IBDIV=+$P(IB0,U,22) ; division on claim
I 'IBDIV S IBDIV=$$PRIM^VASITE(EVDT)
I IBDIV'>0 S IBDIV=$$PRIM^VASITE()
I IBDIV'>0 G PRVDATX ; get out if no division
S INST=+$$SITE^VASITE(EVDT,IBDIV) ; inst file 4 pointer
I INST'>0 S INST=+$$SITE^VASITE(DT,IBDIV)
I INST'>0 S INST=+$$SITE^VASITE()
I INST'>0 G PRVDATX ; get out if no institution
;
; check to see if this institution exists as a separate Pay-To Provider subfile entry
S PIEN=+$O(^IBE(350.9,1,$S(IBTCFLAG:29,1:19),"B",INST,""))
;
I 'PIEN D G PRVDATX ; this institution does not exist in 350.9004/350.929.
. ; check to see if the default Pay-To provider information is defined (350.9;11.03/11.04)
. S PIEN=+$P($G(^IBE(350.9,1,11)),U,$S(IBTCFLAG:4,1:3)) Q:'PIEN
. S DATA=$$PTG(PIEN,IBTCFLAG)
. Q
;
; here PIEN exists and the institution pointer was found in the 350.9004 subfile
; find parent pay-to provider
S PIEN=$$GETPROV^IBJPS4(PIEN,IBTCFLAG) S:PIEN DATA=$$PTG(PIEN,IBTCFLAG)
;
PRVDATX ;
I DATA="" S IBER=IBER_"IB177;",$P(DATA,U,10)=IBER
Q DATA
;
PTG(PIEN,IBTCFLAG) ; gather pay-to provider info
N N0,N1,IBORG,NPI,STIEN,STATE,Z,IBER,IBNODE
;
S IBNODE=$$NODE^IBJPS4(+$G(IBTCFLAG))
;
S Z="",IBER="",PIEN=+$G(PIEN)
;
I '$D(^IBE(350.9,1,IBNODE,PIEN)) S IBER=IBER_"IB177;",$P(Z,U,10)=IBER G PTGX
S N0=$G(^IBE(350.9,1,IBNODE,PIEN,0))
S N1=$G(^IBE(350.9,1,IBNODE,PIEN,1))
;
; get the NPI# from the Institution file
S IBORG=+$P(N0,U,1),NPI=""
I IBORG S NPI=$P($$NPI^XUSNPI("Organization_ID",IBORG),U,1)
;
; get the state abbreviation
S STIEN=+$P(N1,U,4),STATE=""
I STIEN S STATE=$$GET1^DIQ(5,STIEN_",",1)
;
; check for missing data
I '$L($P(N0,U,2)) S IBER=IBER_"IB178;" ; missing name
I NPI'>0 S IBER=IBER_"IB179;" ; missing npi
; Patch 432 enh5: The IB system shall no longer prevent users from authorizing (fatal error message) a claim because the system can not find the human providers SSN or EIN
;I '$L($P(N0,U,3)) S IBER=IBER_"IB180;" ; missing tax ID
I '$L($P(N1,U,1))!'$L($P(N1,U,3))!'$L(STATE)!'$L($P(N1,U,5)) S IBER=IBER_"IB181;" ; missing address part(s)
;
S Z=$P(N0,U,2)_U_NPI_U_$P(N0,U,3)_U_$P(N0,U,4)_U_$P(N1,U,1)_U_$P(N1,U,2)_U_$P(N1,U,3)_U_STATE_U_$P(N1,U,5)_U_IBER_U_IBORG
PTGX ;
Q Z
;
PRVPHONE(IBIFN) ; Return Pay-to provider phone# for a given claim
; IBIFN - internal claim# (optional parameter)
; If IBIFN is not passed in, then the phone# from the default pay-to provider entry will be returned.
; For example, AR option 'EDI Lockbox 3rd Party Exceptions' needs the phone# for the process of transfering an
; EEOB to another site, but the claim# is not available to this process.
N PTPP,PIEN
S PTPP=""
I +$G(IBIFN) S PTPP=$P($$PRVDATA(IBIFN),U,4) G PRVPHNX
;
S PIEN=+$P($G(^IBE(350.9,1,11)),U,3) I 'PIEN G PRVPHNX ; no claim#, default pay-to provider
S PTPP=$P($$PTG(PIEN),U,4) ; phone#
;
PRVPHNX ;
Q PTPP
;
DEF(INST,DA,IBTCFLAG) ; This procedure is called by new style x-ref in
; order to default name and address fields.
; INST - IEN to file #4, Institution. This is the value in the .01
; field of the Pay-to or TRICARE Pay-to Providers sub-fil.
; DA - DA array as passed in from FileMan. DA(1) should equal 1 since
; this is the IB site params and there is only 1 entry. DA should
; equal the IEN to the pay-to provider multiple entry
; This procedure is called only if a new institution is being added to
; the sub-file or an entry in the sub-file is being changed from one
; institution to another.
;
NEW NAD,IENS,ST,STIEN,IBTAXID,IBFILE
;
I '$G(INST) G DEFX
;
I IBTCFLAG S IBFILE=350.929
E S IBFILE=350.9004
;
S ST=$$WHAT^XUAF4(INST,.02) ; full state name
S STIEN=$$FIND1^DIC(5,,"BX",ST,"B") ; state ien
;
; if the selected pay-to provider institution is the same as the main
; facility name field from the IB site parameters, then also default
; the federal tax ID# from the IB site parameters into the pay-to
; provider tax ID# field.
S IBTAXID=""
I INST=$P($G(^IBE(350.9,1,0)),U,2) S IBTAXID=$P($G(^IBE(350.9,1,1)),U,5)
;
S IENS=DA_",1,"
S NAD(IBFILE,IENS,.02)=$$WHAT^XUAF4(INST,100) ; official VA name
S NAD(IBFILE,IENS,.03)=IBTAXID ; tax#
S NAD(IBFILE,IENS,.04)="" ; phone# - blank it out
S NAD(IBFILE,IENS,.05)="" ; parent - blank it out
S NAD(IBFILE,IENS,1.01)=$$WHAT^XUAF4(INST,1.01) ; address line 1
S NAD(IBFILE,IENS,1.02)=$$WHAT^XUAF4(INST,1.02) ; address line 2
S NAD(IBFILE,IENS,1.03)=$$WHAT^XUAF4(INST,1.03) ; city
I STIEN S NAD(IBFILE,IENS,1.04)=STIEN ; state
S NAD(IBFILE,IENS,1.05)=$$WHAT^XUAF4(INST,1.04) ; zip
D FILE^DIE(,"NAD")
DEFX ;
Q
;
DIFF(IBIFN,EDI) ; This function will determine if there are any differences between
; the Billing Provider name and address and the Pay-to Provider name and address.
; When these two are the same, then the Pay-to Provider information is
; suppressed and is not printed or transmitted.
; This function returns a 1 if differences are found, and 0 if they are the same.
;
; EDI=1 if this is being called for the electronic claim transmission
; EDI=0 if this is being called for the printed UB-04 claim form
;
N BPZ,PTP,DIFF,BPNAME,BPAD1,BPAD2,BPCITY,BPST,BPZIP,IBZ
S DIFF=0,EDI=+$G(EDI)
S BPZ=+$$B^IBCEF79(IBIFN) ; billing provider ien to file 4
S PTP=$$UP^XLFSTR($$PRVDATA(IBIFN)) ; pay-to provider information
;
; for EDI claims, use the GETBP utility to get the billing provider data
I EDI D
. D GETBP^IBCEF79(IBIFN,"",BPZ,"DIFF",.IBZ)
. S BPNAME=$$UP^XLFSTR($G(IBZ("DIFF","NAME")))
. S BPAD1=$$UP^XLFSTR($G(IBZ("DIFF","ADDR1")))
. S BPAD2=$$UP^XLFSTR($G(IBZ("DIFF","ADDR2")))
. S BPCITY=$$UP^XLFSTR($G(IBZ("DIFF","CITY")))
. S BPST=$$UP^XLFSTR($G(IBZ("DIFF","ST")))
. S BPZIP=$$NOPUNCT^IBCEF($$UP^XLFSTR($G(IBZ("DIFF","ZIP"))))
. Q
;
; for printed UB claims, use the Institution file for FL-1 data
I 'EDI D
. S BPNAME=$$UP^XLFSTR($$GETFAC^IBCEP8(BPZ,0,0))
. S BPAD1=$$UP^XLFSTR($$GETFAC^IBCEP8(BPZ,0,1))
. S BPAD2=$$UP^XLFSTR($$GETFAC^IBCEP8(BPZ,0,2))
. S BPCITY=$$UP^XLFSTR($$GETFAC^IBCEP8(BPZ,0,"3C"))
. S BPST=$$UP^XLFSTR($$GETFAC^IBCEP8(BPZ,0,"3S"))
. S BPZIP=$$NOPUNCT^IBCEF($$UP^XLFSTR($$GETFAC^IBCEP8(BPZ,0,"3Z")))
. Q
;
I BPNAME'=$P(PTP,U,1) S DIFF=1 G DIFFX
I BPAD1'=$P(PTP,U,5) S DIFF=1 G DIFFX
I BPAD2'=$P(PTP,U,6) S DIFF=1 G DIFFX
I BPCITY'=$P(PTP,U,7) S DIFF=1 G DIFFX
I BPST'=$P(PTP,U,8) S DIFF=1 G DIFFX
I BPZIP'=$$NOPUNCT^IBCEF($P(PTP,U,9)) S DIFF=1 G DIFFX
DIFFX ;
Q DIFF
;
MAINPRV(IBTCFLAG) ; Return Pay-To provider information for main VAMC
N DATA,IBER,IEN4,PIEN,IBNODE
S IBNODE=$$NODE^IBJPS4(IBTCFLAG)
S (DATA,IBER)="",IEN4=+$$SITE^VASITE I 'IEN4 G MAINPRVX
S PIEN=$O(^IBE(350.9,1,IBNODE,"B",IEN4,"")) I 'PIEN G MAINPRVX
I $P($G(^IBE(350.9,1,IBNODE,PIEN,0)),U,5)'="" G MAINPRVX ; if this sub-entry is not a pay-to provider, then get out
S DATA=$$PTG(PIEN,IBTCFLAG)
MAINPRVX ;
I DATA="" S IBER=IBER_"IB177;",$P(DATA,U,10)=IBER
Q DATA
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJPS3 14484 printed Sep 23, 2025@19:59:55 Page 2
IBJPS3 ;BP/YMG - IB Site Parameters, Pay-To Provider ;20-Oct-2008
+1 ;;2.0;INTEGRATED BILLING;**400,432,516,577,608**;21-MAR-94;Build 90
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; MRD;IB*2.0*516 - Added logic pertaining to TRICARE-Specific Pay-To
+5 ; Providers, which entailed adding the parameter IBTCFLAG to many
+6 ; procedures here and in ^IBJPS4.
+7 ;
EN(IBTCFLAG) ; -- main entry point for IBJP IB PAY-TO PROVIDERS
+1 DO EN^VALM("IBJP IB "_$SELECT(IBTCFLAG:"TRICARE PAY-TO PROVS",1:"PAY-TO PROVIDERS"))
+2 QUIT
+3 ;
HDR(IBTCFLAG) ; -- header code
+1 ; Not setting VALMHDR causes this tag to be called upon return from every action,
+2 ; this is done to keep VALMSG displayed at all times, instead of the default message on the lower bar.
+3 SET VALMSG="* = Default "_$SELECT(IBTCFLAG:"Non-MCCF ",1:"")_"Pay-to provider"
+4 QUIT
+5 ;
INIT(IBTCFLAG) ; -- init variables and list array
+1 NEW IBCNT,IBLN,IBSTR,PIEN,PDATA,IBNODE
+2 SET IBNODE=$$NODE^IBJPS4(IBTCFLAG)
+3 ;
+4 SET (VALMCNT,IBCNT,IBLN)=0
+5 SET PIEN=0
FOR
SET PIEN=$ORDER(^IBE(350.9,1,IBNODE,PIEN))
if 'PIEN
QUIT
Begin DoDot:1
+6 IF $PIECE($GET(^IBE(350.9,1,IBNODE,PIEN,0)),U,5)'=""
QUIT
+7 SET PDATA=$$PTG(PIEN,IBTCFLAG)
SET IBCNT=IBCNT+1
+8 SET IBSTR=$$SETSTR^VALM1(IBCNT_".","",2,4)
+9 IF $$ISDFLT(PIEN,IBTCFLAG)
SET IBSTR=$$SETSTR^VALM1("*",IBSTR,7,1)
+10 SET IBSTR=$$SETSTR^VALM1("Name : "_$PIECE(PDATA,U),IBSTR,8,45)
+11 ;S IBSTR=$$SETSTR^VALM1("State : "_$P(PDATA,U,8),IBSTR,54,25) ;JRA IB*2.0*577 ';'
+12 SET IBLN=$$SET(IBLN,IBSTR)
+13 ;S IBSTR=$$SETSTR^VALM1("Address 1: "_$P(PDATA,U,5),"",8,45) ;JRA IB*2.0*577 ';'
+14 ;JRA IB*2.0*577 expand to 55 chars
SET IBSTR=$$SETSTR^VALM1("Address 1: "_$PIECE(PDATA,U,5),"",8,66)
+15 ;S IBSTR=$$SETSTR^VALM1("Zip Code: "_$P(PDATA,U,9),IBSTR,54,25) ;JRA IB*2.0*577 ';'
+16 SET IBLN=$$SET(IBLN,IBSTR)
+17 ;S IBSTR=$$SETSTR^VALM1("Address 2: "_$P(PDATA,U,6),"",8,45) ;JRA IB*2.0*577 ';'
+18 ;JRA IB*2.0*577 expand to 55 chars
SET IBSTR=$$SETSTR^VALM1("Address 2: "_$PIECE(PDATA,U,6),"",8,66)
+19 ;S IBSTR=$$SETSTR^VALM1("Phone : "_$P(PDATA,U,4),IBSTR,54,25) ;JRA IB*2.0*577 ';'
+20 SET IBLN=$$SET(IBLN,IBSTR)
+21 SET IBSTR=$$SETSTR^VALM1("City : "_$PIECE(PDATA,U,7),"",8,45)
+22 SET IBLN=$$SET(IBLN,IBSTR)
+23 ;S IBSTR=$$SETSTR^VALM1("Tax ID : "_$P(PDATA,U,3),IBSTR,54,25) ;JRA IB*2.0*577 ';'
+24 ;JRA Move State, Zip Code, Phone and Tax ID under City to allow for longer address lines
+25 ;JRA IB*2.0*577
SET IBSTR=$$SETSTR^VALM1("State : "_$PIECE(PDATA,U,8),IBSTR,8,25)
+26 ;JRA IB*2.0*577
SET IBLN=$$SET(IBLN,IBSTR)
+27 ;JRA IB*2.0*577
SET IBSTR=$$SETSTR^VALM1("Zip Code : "_$PIECE(PDATA,U,9),IBSTR,8,25)
+28 ;JRA IB*2.0*577
SET IBLN=$$SET(IBLN,IBSTR)
+29 ;JRA IB*2.0*577
SET IBSTR=$$SETSTR^VALM1("Phone : "_$PIECE(PDATA,U,4),IBSTR,8,25)
+30 ;JRA IB*2.0*577
SET IBLN=$$SET(IBLN,IBSTR)
+31 ;JRA IB*2.0*577
SET IBSTR=$$SETSTR^VALM1("Tax ID : "_$PIECE(PDATA,U,3),IBSTR,8,25)
+32 SET IBLN=$$SET(IBLN,IBSTR)
SET IBLN=$$SET(IBLN,"")
+33 SET @VALMAR@("ZIDX",IBCNT,PIEN)=""
+34 QUIT
End DoDot:1
+35 ;
+36 IF 'IBLN
SET IBLN=$$SET(IBLN,$$SETSTR^VALM1("No "_$SELECT(IBTCFLAG:"Non-MCCF ",1:"")_"Pay-To Providers defined.","",13,40))
+37 ;
+38 SET VALMCNT=IBLN
SET VALMBG=1
+39 QUIT
+40 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 DO CLEAR^VALM1
DO CLEAN^VALM10
+2 QUIT
+3 ;
PRVADD(IBTCFLAG) ; add new pay-to provider
+1 NEW X,Y,DIC,DA,DLAYGO,DIE,DR,DIR,DIRUT,DUOUT,DTOUT,IEN,IBNODE
+2 SET IBNODE=$$NODE^IBJPS4(IBTCFLAG)
+3 DO FULL^VALM1
+4 SET VALMBCK="R"
+5 SET DIC="^IBE(350.9,1,"_IBNODE_","
SET DIC(0)="AELMQ"
SET DA(1)=1
SET DLAYGO=350.9
+6 SET DIC("A")="Enter "_$SELECT(IBTCFLAG:"Non-MCCF ",1:"")_"Pay-to Provider: "
+7 DO ^DIC
SET IEN=+Y
+8 IF IEN'>0
QUIT
+9 DO PRVEDIT1
+10 IF $PIECE($GET(^IBE(350.9,1,IBNODE,IEN,0)),U,2)=""
DO PRVDEL1
+11 QUIT
+12 ;
PRVDEL(IBTCFLAG) ; delete a pay-to provider
+1 NEW DA,DR,DIE,X,Y,DIR,DIRUT,DUOUT,DTOUT,I,IEN,DIVS,DFLT,IBNODE,IBDISP
+2 SET IBNODE=$$NODE^IBJPS4(IBTCFLAG)
+3 SET IBDISP=$SELECT(IBTCFLAG:"Non-MCCF ",1:"")_"Pay-To Provider"
+4 SET VALMBCK="R"
+5 DO FULL^VALM1
+6 SET IEN=$$SEL(IBTCFLAG)
if 'IEN
QUIT
+7 SET DFLT=$$ISDFLT(IEN,IBTCFLAG)
+8 IF DFLT
WRITE !!,"WARNING: This is the default "_IBDISP_"."
+9 DO GETDIVS^IBJPS4(IEN,.DIVS,IBTCFLAG)
+10 IF 'DFLT
Begin DoDot:1
+11 WRITE !!,"The following divisions are currently associated with this "_IBDISP_": "
+12 SET I=""
FOR
SET I=$ORDER(DIVS(I))
if I=""
QUIT
WRITE !,?5,DIVS(I)
+13 if '$DATA(DIVS)
WRITE "None",!
WRITE !
+14 QUIT
End DoDot:1
+15 SET DIR("?")="Enter Yes to delete this "_IBDISP_"."
+16 SET DIR("A")="Delete "_IBDISP_" "_$PIECE($GET(^IBE(350.9,1,IBNODE,IEN,0)),U,2)
+17 SET DIR(0)="YO"
SET DIR("B")="NO"
DO ^DIR
if 'Y
QUIT
+18 IF DFLT
SET DIE="^IBE(350.9,"
SET DA=1
SET DR=$SELECT(IBTCFLAG:"11.04",1:"11.03")_"////@"
DO ^DIE
+19 IF $DATA(DIVS)
KILL DIK
SET DIK="^IBE(350.9,1,"_IBNODE_","
SET DA(1)=1
SET I=""
FOR
SET I=$ORDER(DIVS(I))
if I=""
QUIT
SET DA=I
DO ^DIK
+20 KILL DIK
PRVDEL1 ;
+1 NEW DIK
+2 KILL DA
+3 SET DIK="^IBE(350.9,1,"_IBNODE_","
+4 SET DA(1)=1
SET DA=IEN
+5 DO ^DIK
+6 DO CLEAN^VALM10
DO INIT(IBTCFLAG)
+7 QUIT
+8 ;
PRVEDIT(IBTCFLAG) ; edit existing pay-to provider
+1 NEW IEN,IBNODE
+2 SET IBNODE=$$NODE^IBJPS4(IBTCFLAG)
+3 SET VALMBCK="R"
+4 DO FULL^VALM1
+5 SET IEN=$$SEL(IBTCFLAG)
if 'IEN
QUIT
PRVEDIT1 ;
+1 NEW DIE,DA,DR,DIR,DIRUT,DUOUT,DTOUT,X,Y
+2 SET DIE="^IBE(350.9,1,"_IBNODE_","
+3 SET DA=IEN
SET DA(1)=1
+4 SET DR=".02T;1.01T;1.02T;1.03T;1.04T;1.05T;.04T;.03T;.05///@"
+5 DO ^DIE
+6 SET DIR("?")="Enter Yes to make this entry the default "_$SELECT(IBTCFLAG:"Non-MCCF ",1:"")_"Pay-to Provider."
+7 SET DIR("A")="Is this the default "_$SELECT(IBTCFLAG:"Non-MCCF ",1:"")_"Pay-To Provider"
+8 SET DIR(0)="YO"
+9 SET DIR("B")="YES"
IF $$GETDFLT(IBTCFLAG)
IF '$$ISDFLT(IEN,IBTCFLAG)
SET DIR("B")="NO"
+10 DO ^DIR
IF Y
KILL DA
SET DIE="^IBE(350.9,"
SET DA=1
SET DR=$SELECT(IBTCFLAG:"11.04",1:"11.03")_"////"_IEN
DO ^DIE
+11 DO CLEAN^VALM10
DO INIT(IBTCFLAG)
+12 QUIT
+13 ;
SET(IBLN,IBSTR) ; add a line to display list
+1 ; returns line number added
+2 SET IBLN=IBLN+1
DO SET^VALM10(IBLN,IBSTR)
+3 QUIT IBLN
+4 ;
ISDFLT(PIEN,IBTCFLAG) ; returns 1 if provider with ien PIEN is the default pay-to provider, 0 otherwise
+1 if PIEN=""
QUIT 0
+2 QUIT $$GETDFLT(IBTCFLAG)=PIEN
+3 ;
GETDFLT(IBTCFLAG) ; returns ien of default pay-to provider
+1 QUIT $PIECE($GET(^IBE(350.9,1,11)),U,$SELECT(IBTCFLAG:4,1:3))
+2 ;
SEL(IBTCFLAG) ; select pay-to provider
+1 ; returns ien of selected pay-to provider, or 0 if nothing is selected
+2 NEW DIR,IEN,MAX,X,Y
+3 SET IEN=0
+4 IF VALMLST>4
Begin DoDot:1
+5 ; there is at least one entry
+6 SET MAX=$ORDER(@VALMAR@("ZIDX",""),-1)
if MAX=1
SET Y=1
+7 IF MAX>1
Begin DoDot:2
+8 SET DIR("A")="Select "_$SELECT(IBTCFLAG:"Non-MCCF ",1:"")_"Pay-To Provider (1-"_MAX_"): "
+9 SET DIR(0)="NA^"_1_":"_MAX_":0"
+10 DO ^DIR
+11 QUIT
End DoDot:2
+12 if +Y>0
SET IEN=$ORDER(@VALMAR@("ZIDX",Y,""))
+13 QUIT
End DoDot:1
+14 QUIT +IEN
+15 ;
PRVDATA(IBIFN) ; Return a string of Pay-To provider information in the following format
+1 ; [1] name
+2 ; [2] npi
+3 ; [3] tax id#
+4 ; [4] phone#
+5 ; [5] street 1
+6 ; [6] street 2
+7 ; [7] city
+8 ; [8] state abbreviation
+9 ; [9] zip
+10 ; [10] list of IB error messages if any of this data is missing in IBXX1;IBXX2;IBXX3;IBXX4; format
+11 ; [11] Institution (File 4) ien
+12 ;
+13 ; **NOTE: pieces 12,13,14 are added to this string in output formatter data element #1624 for PRV1-1.5 for PRV1
+14 ; pieces 2,3,5. If pieces are added here to this string, then adjust the code in PRV1-1.5,2,3,5 accordingly.
+15 ;
+16 NEW DATA,IB0,EVDT,IBDIV,INST,PIEN,IBER,IBTCFLAG
+17 SET DATA=""
SET IBER=""
+18 ;
+19 ; Set IBTCFLAG to '1' if TRICARE claim, otherwise '0'.
SET IBTCFLAG=$$TRICARE^IBJPS4(IBIFN)
+20 ;
+21 SET IB0=$GET(^DGCR(399,IBIFN,0))
+22 ; event date on claim
SET EVDT=$PIECE(IB0,U,3)
+23 IF 'EVDT
SET EVDT=DT
+24 ; division on claim
SET IBDIV=+$PIECE(IB0,U,22)
+25 IF 'IBDIV
SET IBDIV=$$PRIM^VASITE(EVDT)
+26 IF IBDIV'>0
SET IBDIV=$$PRIM^VASITE()
+27 ; get out if no division
IF IBDIV'>0
GOTO PRVDATX
+28 ; inst file 4 pointer
SET INST=+$$SITE^VASITE(EVDT,IBDIV)
+29 IF INST'>0
SET INST=+$$SITE^VASITE(DT,IBDIV)
+30 IF INST'>0
SET INST=+$$SITE^VASITE()
+31 ; get out if no institution
IF INST'>0
GOTO PRVDATX
+32 ;
+33 ; check to see if this institution exists as a separate Pay-To Provider subfile entry
+34 SET PIEN=+$ORDER(^IBE(350.9,1,$SELECT(IBTCFLAG:29,1:19),"B",INST,""))
+35 ;
+36 ; this institution does not exist in 350.9004/350.929.
IF 'PIEN
Begin DoDot:1
+37 ; check to see if the default Pay-To provider information is defined (350.9;11.03/11.04)
+38 SET PIEN=+$PIECE($GET(^IBE(350.9,1,11)),U,$SELECT(IBTCFLAG:4,1:3))
if 'PIEN
QUIT
+39 SET DATA=$$PTG(PIEN,IBTCFLAG)
+40 QUIT
End DoDot:1
GOTO PRVDATX
+41 ;
+42 ; here PIEN exists and the institution pointer was found in the 350.9004 subfile
+43 ; find parent pay-to provider
+44 SET PIEN=$$GETPROV^IBJPS4(PIEN,IBTCFLAG)
if PIEN
SET DATA=$$PTG(PIEN,IBTCFLAG)
+45 ;
PRVDATX ;
+1 IF DATA=""
SET IBER=IBER_"IB177;"
SET $PIECE(DATA,U,10)=IBER
+2 QUIT DATA
+3 ;
PTG(PIEN,IBTCFLAG) ; gather pay-to provider info
+1 NEW N0,N1,IBORG,NPI,STIEN,STATE,Z,IBER,IBNODE
+2 ;
+3 SET IBNODE=$$NODE^IBJPS4(+$GET(IBTCFLAG))
+4 ;
+5 SET Z=""
SET IBER=""
SET PIEN=+$GET(PIEN)
+6 ;
+7 IF '$DATA(^IBE(350.9,1,IBNODE,PIEN))
SET IBER=IBER_"IB177;"
SET $PIECE(Z,U,10)=IBER
GOTO PTGX
+8 SET N0=$GET(^IBE(350.9,1,IBNODE,PIEN,0))
+9 SET N1=$GET(^IBE(350.9,1,IBNODE,PIEN,1))
+10 ;
+11 ; get the NPI# from the Institution file
+12 SET IBORG=+$PIECE(N0,U,1)
SET NPI=""
+13 IF IBORG
SET NPI=$PIECE($$NPI^XUSNPI("Organization_ID",IBORG),U,1)
+14 ;
+15 ; get the state abbreviation
+16 SET STIEN=+$PIECE(N1,U,4)
SET STATE=""
+17 IF STIEN
SET STATE=$$GET1^DIQ(5,STIEN_",",1)
+18 ;
+19 ; check for missing data
+20 ; missing name
IF '$LENGTH($PIECE(N0,U,2))
SET IBER=IBER_"IB178;"
+21 ; missing npi
IF NPI'>0
SET IBER=IBER_"IB179;"
+22 ; Patch 432 enh5: The IB system shall no longer prevent users from authorizing (fatal error message) a claim because the system can not find the human providers SSN or EIN
+23 ;I '$L($P(N0,U,3)) S IBER=IBER_"IB180;" ; missing tax ID
+24 ; missing address part(s)
IF '$LENGTH($PIECE(N1,U,1))!'$LENGTH($PIECE(N1,U,3))!'$LENGTH(STATE)!'$LENGTH($PIECE(N1,U,5))
SET IBER=IBER_"IB181;"
+25 ;
+26 SET Z=$PIECE(N0,U,2)_U_NPI_U_$PIECE(N0,U,3)_U_$PIECE(N0,U,4)_U_$PIECE(N1,U,1)_U_$PIECE(N1,U,2)_U_$PIECE(N1,U,3)_U_STATE_U_$PIECE(N1,U,5)_U_IBER_U_IBORG
PTGX ;
+1 QUIT Z
+2 ;
PRVPHONE(IBIFN) ; Return Pay-to provider phone# for a given claim
+1 ; IBIFN - internal claim# (optional parameter)
+2 ; If IBIFN is not passed in, then the phone# from the default pay-to provider entry will be returned.
+3 ; For example, AR option 'EDI Lockbox 3rd Party Exceptions' needs the phone# for the process of transfering an
+4 ; EEOB to another site, but the claim# is not available to this process.
+5 NEW PTPP,PIEN
+6 SET PTPP=""
+7 IF +$GET(IBIFN)
SET PTPP=$PIECE($$PRVDATA(IBIFN),U,4)
GOTO PRVPHNX
+8 ;
+9 ; no claim#, default pay-to provider
SET PIEN=+$PIECE($GET(^IBE(350.9,1,11)),U,3)
IF 'PIEN
GOTO PRVPHNX
+10 ; phone#
SET PTPP=$PIECE($$PTG(PIEN),U,4)
+11 ;
PRVPHNX ;
+1 QUIT PTPP
+2 ;
DEF(INST,DA,IBTCFLAG) ; This procedure is called by new style x-ref in
+1 ; order to default name and address fields.
+2 ; INST - IEN to file #4, Institution. This is the value in the .01
+3 ; field of the Pay-to or TRICARE Pay-to Providers sub-fil.
+4 ; DA - DA array as passed in from FileMan. DA(1) should equal 1 since
+5 ; this is the IB site params and there is only 1 entry. DA should
+6 ; equal the IEN to the pay-to provider multiple entry
+7 ; This procedure is called only if a new institution is being added to
+8 ; the sub-file or an entry in the sub-file is being changed from one
+9 ; institution to another.
+10 ;
+11 NEW NAD,IENS,ST,STIEN,IBTAXID,IBFILE
+12 ;
+13 IF '$GET(INST)
GOTO DEFX
+14 ;
+15 IF IBTCFLAG
SET IBFILE=350.929
+16 IF '$TEST
SET IBFILE=350.9004
+17 ;
+18 ; full state name
SET ST=$$WHAT^XUAF4(INST,.02)
+19 ; state ien
SET STIEN=$$FIND1^DIC(5,,"BX",ST,"B")
+20 ;
+21 ; if the selected pay-to provider institution is the same as the main
+22 ; facility name field from the IB site parameters, then also default
+23 ; the federal tax ID# from the IB site parameters into the pay-to
+24 ; provider tax ID# field.
+25 SET IBTAXID=""
+26 IF INST=$PIECE($GET(^IBE(350.9,1,0)),U,2)
SET IBTAXID=$PIECE($GET(^IBE(350.9,1,1)),U,5)
+27 ;
+28 SET IENS=DA_",1,"
+29 ; official VA name
SET NAD(IBFILE,IENS,.02)=$$WHAT^XUAF4(INST,100)
+30 ; tax#
SET NAD(IBFILE,IENS,.03)=IBTAXID
+31 ; phone# - blank it out
SET NAD(IBFILE,IENS,.04)=""
+32 ; parent - blank it out
SET NAD(IBFILE,IENS,.05)=""
+33 ; address line 1
SET NAD(IBFILE,IENS,1.01)=$$WHAT^XUAF4(INST,1.01)
+34 ; address line 2
SET NAD(IBFILE,IENS,1.02)=$$WHAT^XUAF4(INST,1.02)
+35 ; city
SET NAD(IBFILE,IENS,1.03)=$$WHAT^XUAF4(INST,1.03)
+36 ; state
IF STIEN
SET NAD(IBFILE,IENS,1.04)=STIEN
+37 ; zip
SET NAD(IBFILE,IENS,1.05)=$$WHAT^XUAF4(INST,1.04)
+38 DO FILE^DIE(,"NAD")
DEFX ;
+1 QUIT
+2 ;
DIFF(IBIFN,EDI) ; This function will determine if there are any differences between
+1 ; the Billing Provider name and address and the Pay-to Provider name and address.
+2 ; When these two are the same, then the Pay-to Provider information is
+3 ; suppressed and is not printed or transmitted.
+4 ; This function returns a 1 if differences are found, and 0 if they are the same.
+5 ;
+6 ; EDI=1 if this is being called for the electronic claim transmission
+7 ; EDI=0 if this is being called for the printed UB-04 claim form
+8 ;
+9 NEW BPZ,PTP,DIFF,BPNAME,BPAD1,BPAD2,BPCITY,BPST,BPZIP,IBZ
+10 SET DIFF=0
SET EDI=+$GET(EDI)
+11 ; billing provider ien to file 4
SET BPZ=+$$B^IBCEF79(IBIFN)
+12 ; pay-to provider information
SET PTP=$$UP^XLFSTR($$PRVDATA(IBIFN))
+13 ;
+14 ; for EDI claims, use the GETBP utility to get the billing provider data
+15 IF EDI
Begin DoDot:1
+16 DO GETBP^IBCEF79(IBIFN,"",BPZ,"DIFF",.IBZ)
+17 SET BPNAME=$$UP^XLFSTR($GET(IBZ("DIFF","NAME")))
+18 SET BPAD1=$$UP^XLFSTR($GET(IBZ("DIFF","ADDR1")))
+19 SET BPAD2=$$UP^XLFSTR($GET(IBZ("DIFF","ADDR2")))
+20 SET BPCITY=$$UP^XLFSTR($GET(IBZ("DIFF","CITY")))
+21 SET BPST=$$UP^XLFSTR($GET(IBZ("DIFF","ST")))
+22 SET BPZIP=$$NOPUNCT^IBCEF($$UP^XLFSTR($GET(IBZ("DIFF","ZIP"))))
+23 QUIT
End DoDot:1
+24 ;
+25 ; for printed UB claims, use the Institution file for FL-1 data
+26 IF 'EDI
Begin DoDot:1
+27 SET BPNAME=$$UP^XLFSTR($$GETFAC^IBCEP8(BPZ,0,0))
+28 SET BPAD1=$$UP^XLFSTR($$GETFAC^IBCEP8(BPZ,0,1))
+29 SET BPAD2=$$UP^XLFSTR($$GETFAC^IBCEP8(BPZ,0,2))
+30 SET BPCITY=$$UP^XLFSTR($$GETFAC^IBCEP8(BPZ,0,"3C"))
+31 SET BPST=$$UP^XLFSTR($$GETFAC^IBCEP8(BPZ,0,"3S"))
+32 SET BPZIP=$$NOPUNCT^IBCEF($$UP^XLFSTR($$GETFAC^IBCEP8(BPZ,0,"3Z")))
+33 QUIT
End DoDot:1
+34 ;
+35 IF BPNAME'=$PIECE(PTP,U,1)
SET DIFF=1
GOTO DIFFX
+36 IF BPAD1'=$PIECE(PTP,U,5)
SET DIFF=1
GOTO DIFFX
+37 IF BPAD2'=$PIECE(PTP,U,6)
SET DIFF=1
GOTO DIFFX
+38 IF BPCITY'=$PIECE(PTP,U,7)
SET DIFF=1
GOTO DIFFX
+39 IF BPST'=$PIECE(PTP,U,8)
SET DIFF=1
GOTO DIFFX
+40 IF BPZIP'=$$NOPUNCT^IBCEF($PIECE(PTP,U,9))
SET DIFF=1
GOTO DIFFX
DIFFX ;
+1 QUIT DIFF
+2 ;
MAINPRV(IBTCFLAG) ; Return Pay-To provider information for main VAMC
+1 NEW DATA,IBER,IEN4,PIEN,IBNODE
+2 SET IBNODE=$$NODE^IBJPS4(IBTCFLAG)
+3 SET (DATA,IBER)=""
SET IEN4=+$$SITE^VASITE
IF 'IEN4
GOTO MAINPRVX
+4 SET PIEN=$ORDER(^IBE(350.9,1,IBNODE,"B",IEN4,""))
IF 'PIEN
GOTO MAINPRVX
+5 ; if this sub-entry is not a pay-to provider, then get out
IF $PIECE($GET(^IBE(350.9,1,IBNODE,PIEN,0)),U,5)'=""
GOTO MAINPRVX
+6 SET DATA=$$PTG(PIEN,IBTCFLAG)
MAINPRVX ;
+1 IF DATA=""
SET IBER=IBER_"IB177;"
SET $PIECE(DATA,U,10)=IBER
+2 QUIT DATA
+3 ;
