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

IBJPS3.m

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