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