IBCIADD1 ;DSI/SLM - ADD ENTRY TO FILE 351.9 ;17-JAN-2001
;;2.0;INTEGRATED BILLING;**161,203,155**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
ADD ;add an entry
Q:'IBIFN
N FDA,IENS S IBCIADD=1
S DIC="^IBA(351.9,",(X,DINUM)=IBIFN,DIC(0)="Z"
D FILE^DICN I Y<0 W !!,IBIFN," NOT ADDED TO FILE 351.9" K Y Q
UPDT ; update an entry
I $G(IBCISNT)=7 Q ; esg - 1/3/2002
;
; esg - 3/20/02 - No need to rebuild the 3,4,5 nodes in the event of
; a cancel because we want to send the claim lines that were
; most recently sent to CM, not whatever Vista has now.
; esg - 10/9/02 - However, if the 3,4,5 nodes are not there, then we
; need to rebuild them based on whatever Vista has now.
;
I $G(IBCISNT)=4,$P($G(^IBA(351.9,IBIFN,3)),U,1) Q
;
D CLEAN^IBCIUT2,DELTI^IBCIUT4
NEW IBRFID,IBRFLN,IBRFMN,IBRFFN,IBRFDEPT,IBRFSPEC
S (IBRFID,IBRFLN,IBRFMN,IBRFFN,IBRFDEPT,IBRFSPEC)=""
I '$D(IBCIADD) S IBCIADD=0
D INIT1
S IENS=IBIFN_","
S FDA(351.9,IENS,.02)=IBCIST
I $P(^IBA(351.9,IBIFN,0),U,6)']"" D
.S FDA(351.9,IENS,.06)=IBCIDE,FDA(351.9,IENS,.07)=IBCIEB
S FDA(351.9,IENS,3.01)=IBCIPID,FDA(351.9,IENS,3.02)=IBCIPTLA
S FDA(351.9,IENS,3.03)=IBCIPTMI,FDA(351.9,IENS,3.04)=IBCIPTFI
S FDA(351.9,IENS,3.05)=IBCIDOB,FDA(351.9,IENS,3.06)=IBCISEX
S FDA(351.9,IENS,3.07)=IBCIET
;
; Add referring provider fields
S FDA(351.9,IENS,3.08)=IBRFID ; ID
S FDA(351.9,IENS,3.09)=IBRFLN ; last name
S FDA(351.9,IENS,3.1)=IBRFMN ; middle name
S FDA(351.9,IENS,3.11)=IBRFFN ; first name
S FDA(351.9,IENS,4.01)=IBRFDEPT ; department
S FDA(351.9,IENS,4.02)=IBRFSPEC ; specialty
;
D FILE^DIE("K","FDA"),UPDT1^IBCIST
;
S IBCILSEG=0 F S IBCILSEG=$O(IBXDATA(IBCILSEG)) Q:'IBCILSEG D
.I '$D(^IBA(351.9,IBIFN,5,IBCILSEG)) D ADDSUB
.S DR=".06////"_IBCIBDOS(IBCILSEG)_";.02////"_IBCIXLID(IBCILSEG)
.S DR=DR_";.03////"_IBCIOGID(IBCILSEG)_";.04////"_IBCIOID(IBCILSEG)
.S DR=DR_";.07////"_IBCIEDOS(IBCILSEG)_";.08////"_IBCIPOS(IBCILSEG)
.S DR=DR_";.09////"_IBCISPC(IBCILSEG)_";.1////"_IBCIAPC(IBCILSEG)
.S DR=DR_";.11////"_IBCISAMT(IBCILSEG)_";.12////"_IBCIPAC(IBCILSEG)
.S DIE="^IBA(351.9,"_IBIFN_",5,",DA=IBCILSEG,DA(1)=IBIFN D ^DIE
.S DR=".13////"_IBCISPID(IBCILSEG)_";1.01////"_IBCISPLA(IBCILSEG)
.S DR=DR_";1.02////"_IBCISPMI(IBCILSEG)_";1.03////"_IBCISPFI(IBCILSEG)
.S DR=DR_";1.04////"_IBCISPTI(IBCILSEG)_";1.05////"_IBCISPDE(IBCILSEG)
.S DIE="^IBA(351.9,"_IBIFN_",5,",DA=IBCILSEG,DA(1)=IBIFN D ^DIE
.S DR="1.06////"_IBCISPSP(IBCILSEG)_";1.07////"_IBCISPDI(IBCILSEG)
.S DR=DR_";1.08////"_IBCISPUP(IBCILSEG)_";1.09////"_IBCIBPID(IBCILSEG)
.S DIE="^IBA(351.9,"_IBIFN_",5,",DA=IBCILSEG,DA(1)=IBIFN D ^DIE
.S DR="2.01////"_IBCIBPLA(IBCILSEG)_";2.02////"_IBCIBPMI(IBCILSEG)
.S DR=DR_";2.03////"_IBCIBPFI(IBCILSEG)_";2.04////"_IBCIBPTI(IBCILSEG)
.S DR=DR_";2.05////"_IBCIBPDE(IBCILSEG)_";2.06////"_IBCIBPSP(IBCILSEG)
.S DIE="^IBA(351.9,"_IBIFN_",5,",DA=IBCILSEG,DA(1)=IBIFN D ^DIE
.S DR="2.07////"_IBCIBPDI(IBCILSEG)_";2.08////"_IBCIBPUP(IBCILSEG)
.S DR=DR_";2.09////"_IBCIPPID(IBCILSEG)_";2.1////"_IBCISPAI(IBCILSEG)
.S DR=DR_";2.11////"_IBCITOS(IBCILSEG)_";2.12////"_IBCIUNIT(IBCILSEG)
.S DR=DR_";3.01////"_IBCICPT(IBCILSEG)
.S DIE="^IBA(351.9,"_IBIFN_",5,",DA=IBCILSEG,DA(1)=IBIFN D ^DIE
.Q
D CLEAN^IBCIUT2 K IBCIADD
Q
;
INIT1 ; Initialize variables for adding entry in 351.9
NEW IBZ,IBPRV
S IBCIDFN=$P(^DGCR(399,IBIFN,0),U,2)
S IBCICL=$P(^DGCR(399,IBIFN,0),U)
S IBCIST=$S(IBCIADD=1:1,1:$P(^IBA(351.9,IBIFN,0),U,2)),IBCIEB=DUZ
S (IBCIDE,IBCIET)=$$NOW^XLFDT
S IBCIPID=$P(^DPT(IBCIDFN,0),U,9)
S X=$P(^DPT(IBCIDFN,0),U) D NAMSP^IBCIUT1
S IBCIPTLA=$P(Y,U,1),IBCIPTFI=$P(Y,U,2),IBCIPTMI=$P(Y,U,3)
S IBCIDOB=$P(^DPT(IBCIDFN,0),U,3),IBCISEX=$P(^DPT(IBCIDFN,0),U,2)
;
; capture referring provider information
D GETPRV^IBCEU(IBIFN,1,.IBZ) ; "1" signifies referring provider
S IBZ=$G(IBZ(1,1))
I IBZ'="" D
. S IBPRV=$P(IBZ,U,3)
. S IBRFLN=$$NAME^IBCEFG1($P(IBZ,U,1)),IBRFMN=$P(IBRFLN,U,3),IBRFFN=$P(IBRFLN,U,2),IBRFLN=$P(IBRFLN,U,1)
. S IBRFSPEC=$$BILLSPEC^IBCEU3(IBIFN,IBPRV) ; ref prov specialty
. I IBPRV'["IBA(355.93" D ; va provider data
.. S IBRFID=+IBPRV
.. S IBRFDEPT=$P($G(^VA(200,+IBPRV,5)),U,1)
.. Q
. I IBPRV["IBA(355.93" D ; non-va provider data
.. S IBRFID="NVA"_+IBPRV
.. S IBRFDEPT="NVA"
.. Q
. Q
;
;initialize variables for line items in 351.9 and save
D F^IBCEF("N-HCFA 1500 SERVICES (PRINT)",,,IBIFN)
S IBCILSEG=0
F S IBCILSEG=$O(IBXDATA(IBCILSEG)) Q:'IBCILSEG D
. NEW CURRENT,DIV
. S X=$P(IBXDATA(IBCILSEG),U),IBCIBDOS(IBCILSEG)=$$NOW1^IBCIUT1(X)
. I $P(IBXDATA(IBCILSEG),U,2)]"" S X=$P(IBXDATA(IBCILSEG),U,2),IBCIEDOS(IBCILSEG)=$$NOW1^IBCIUT1(X)
. I $P(IBXDATA(IBCILSEG),U,2)']"" S IBCIEDOS(IBCILSEG)=IBCIBDOS(IBCILSEG)
. S IBCIPOS(IBCILSEG)=$P(IBXDATA(IBCILSEG),U,3)
. S IBCITOS(IBCILSEG)=$P(IBXDATA(IBCILSEG),U,4)
. S IBCISPC(IBCILSEG)=$P(IBXDATA(IBCILSEG),U,5)
. S IBCISAMT(IBCILSEG)=$P(IBXDATA(IBCILSEG),U,8)
. S IBCIUNIT(IBCILSEG)=$P(IBXDATA(IBCILSEG),U,9)
. S IBCICPT(IBCILSEG)=$P(IBXDATA(IBCILSEG),U,10)
. S IBCICPT(IBCILSEG)=$$GETMOD^IBCIUT5(IBCICPT(IBCILSEG))
. I IBCIUNIT(IBCILSEG)>1 S IBCISAMT(IBCILSEG)=IBCISAMT(IBCILSEG)*IBCIUNIT(IBCILSEG)
. S IBCIAPC(IBCILSEG)="",IBCIXLID(IBCILSEG)=IBCILSEG
. S IBCIOGID(IBCILSEG)="",IBCIOID(IBCILSEG)="",IBCIPAC(IBCILSEG)=""
. ;
. ; capture the default division (field# .22) for the organization id
. S DIV=$P($G(^DGCR(399,IBIFN,0)),U,22)
. I DIV S IBCIOID(IBCILSEG)=$P($G(^DG(40.8,DIV,0)),U,2)
. ;
. ; Billing provider information
. S IBXDAT1=$$RPHY^IBCIUT1(IBIFN) ; Get provider information
. S IBCIBPID(IBCILSEG)=$P(IBXDAT1,U,2) ; provider ID
. S X=$P(IBXDAT1,U,1) D NAMSP^IBCIUT1 ; parse full provider name
. S IBCIBPLA(IBCILSEG)=$P(Y,U,1) ; provider last name
. S IBCIBPFI(IBCILSEG)=$P(Y,U,2) ; provider first name
. S IBCIBPMI(IBCILSEG)=$P(Y,U,3) ; provider middle name
. S IBCIBPDE(IBCILSEG)=$P(IBXDAT1,U,3) ; provider department
. S IBCIBPSP(IBCILSEG)=$P(IBXDAT1,U,4) ; provider specialty
. S IBCIBPDI(IBCILSEG)="" ; provider degree ID
. S IBCIBPTI(IBCILSEG)="" ; provider title
. S IBCIBPUP(IBCILSEG)="" ; provider UPIN
. KILL X,Y ; clean up
. ;
. ; Primary payer ID
. S IBCIPPID(IBCILSEG)=$$FINDINS^IBCEF1(IBIFN)
. ;
. ; Get the secondary payer ID based on the current bill sequence
. ;
. S IBCISPAI(IBCILSEG)=""
. S CURRENT=$$COB^IBCEF(IBIFN)
. I CURRENT="P" S IBCISPAI(IBCILSEG)=$$FINDINS^IBCEF1(IBIFN,"S")
. I CURRENT="S" S IBCISPAI(IBCILSEG)=$$FINDINS^IBCEF1(IBIFN,"T")
. ;
. S IBCISPID(IBCILSEG)="",IBCISPLA(IBCILSEG)="",IBCISPFI(IBCILSEG)=""
. S IBCISPMI(IBCILSEG)="",IBCISPTI(IBCILSEG)="",IBCISPDE(IBCILSEG)=""
. S IBCISPSP(IBCILSEG)="",IBCISPDI(IBCILSEG)="",IBCISPUP(IBCILSEG)=""
. Q
Q
;
ADDSUB ;create the subfile
S DIC="^IBA(351.9,"_IBIFN_",5,",DA(1)=IBIFN,DIC(0)="LMN",(DA,X)=IBCILSEG
D FILE^DICN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCIADD1 7162 printed Dec 13, 2024@02:13:07 Page 2
IBCIADD1 ;DSI/SLM - ADD ENTRY TO FILE 351.9 ;17-JAN-2001
+1 ;;2.0;INTEGRATED BILLING;**161,203,155**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
ADD ;add an entry
+1 if 'IBIFN
QUIT
+2 NEW FDA,IENS
SET IBCIADD=1
+3 SET DIC="^IBA(351.9,"
SET (X,DINUM)=IBIFN
SET DIC(0)="Z"
+4 DO FILE^DICN
IF Y<0
WRITE !!,IBIFN," NOT ADDED TO FILE 351.9"
KILL Y
QUIT
UPDT ; update an entry
+1 ; esg - 1/3/2002
IF $GET(IBCISNT)=7
QUIT
+2 ;
+3 ; esg - 3/20/02 - No need to rebuild the 3,4,5 nodes in the event of
+4 ; a cancel because we want to send the claim lines that were
+5 ; most recently sent to CM, not whatever Vista has now.
+6 ; esg - 10/9/02 - However, if the 3,4,5 nodes are not there, then we
+7 ; need to rebuild them based on whatever Vista has now.
+8 ;
+9 IF $GET(IBCISNT)=4
IF $PIECE($GET(^IBA(351.9,IBIFN,3)),U,1)
QUIT
+10 ;
+11 DO CLEAN^IBCIUT2
DO DELTI^IBCIUT4
+12 NEW IBRFID,IBRFLN,IBRFMN,IBRFFN,IBRFDEPT,IBRFSPEC
+13 SET (IBRFID,IBRFLN,IBRFMN,IBRFFN,IBRFDEPT,IBRFSPEC)=""
+14 IF '$DATA(IBCIADD)
SET IBCIADD=0
+15 DO INIT1
+16 SET IENS=IBIFN_","
+17 SET FDA(351.9,IENS,.02)=IBCIST
+18 IF $PIECE(^IBA(351.9,IBIFN,0),U,6)']""
Begin DoDot:1
+19 SET FDA(351.9,IENS,.06)=IBCIDE
SET FDA(351.9,IENS,.07)=IBCIEB
End DoDot:1
+20 SET FDA(351.9,IENS,3.01)=IBCIPID
SET FDA(351.9,IENS,3.02)=IBCIPTLA
+21 SET FDA(351.9,IENS,3.03)=IBCIPTMI
SET FDA(351.9,IENS,3.04)=IBCIPTFI
+22 SET FDA(351.9,IENS,3.05)=IBCIDOB
SET FDA(351.9,IENS,3.06)=IBCISEX
+23 SET FDA(351.9,IENS,3.07)=IBCIET
+24 ;
+25 ; Add referring provider fields
+26 ; ID
SET FDA(351.9,IENS,3.08)=IBRFID
+27 ; last name
SET FDA(351.9,IENS,3.09)=IBRFLN
+28 ; middle name
SET FDA(351.9,IENS,3.1)=IBRFMN
+29 ; first name
SET FDA(351.9,IENS,3.11)=IBRFFN
+30 ; department
SET FDA(351.9,IENS,4.01)=IBRFDEPT
+31 ; specialty
SET FDA(351.9,IENS,4.02)=IBRFSPEC
+32 ;
+33 DO FILE^DIE("K","FDA")
DO UPDT1^IBCIST
+34 ;
+35 SET IBCILSEG=0
FOR
SET IBCILSEG=$ORDER(IBXDATA(IBCILSEG))
if 'IBCILSEG
QUIT
Begin DoDot:1
+36 IF '$DATA(^IBA(351.9,IBIFN,5,IBCILSEG))
DO ADDSUB
+37 SET DR=".06////"_IBCIBDOS(IBCILSEG)_";.02////"_IBCIXLID(IBCILSEG)
+38 SET DR=DR_";.03////"_IBCIOGID(IBCILSEG)_";.04////"_IBCIOID(IBCILSEG)
+39 SET DR=DR_";.07////"_IBCIEDOS(IBCILSEG)_";.08////"_IBCIPOS(IBCILSEG)
+40 SET DR=DR_";.09////"_IBCISPC(IBCILSEG)_";.1////"_IBCIAPC(IBCILSEG)
+41 SET DR=DR_";.11////"_IBCISAMT(IBCILSEG)_";.12////"_IBCIPAC(IBCILSEG)
+42 SET DIE="^IBA(351.9,"_IBIFN_",5,"
SET DA=IBCILSEG
SET DA(1)=IBIFN
DO ^DIE
+43 SET DR=".13////"_IBCISPID(IBCILSEG)_";1.01////"_IBCISPLA(IBCILSEG)
+44 SET DR=DR_";1.02////"_IBCISPMI(IBCILSEG)_";1.03////"_IBCISPFI(IBCILSEG)
+45 SET DR=DR_";1.04////"_IBCISPTI(IBCILSEG)_";1.05////"_IBCISPDE(IBCILSEG)
+46 SET DIE="^IBA(351.9,"_IBIFN_",5,"
SET DA=IBCILSEG
SET DA(1)=IBIFN
DO ^DIE
+47 SET DR="1.06////"_IBCISPSP(IBCILSEG)_";1.07////"_IBCISPDI(IBCILSEG)
+48 SET DR=DR_";1.08////"_IBCISPUP(IBCILSEG)_";1.09////"_IBCIBPID(IBCILSEG)
+49 SET DIE="^IBA(351.9,"_IBIFN_",5,"
SET DA=IBCILSEG
SET DA(1)=IBIFN
DO ^DIE
+50 SET DR="2.01////"_IBCIBPLA(IBCILSEG)_";2.02////"_IBCIBPMI(IBCILSEG)
+51 SET DR=DR_";2.03////"_IBCIBPFI(IBCILSEG)_";2.04////"_IBCIBPTI(IBCILSEG)
+52 SET DR=DR_";2.05////"_IBCIBPDE(IBCILSEG)_";2.06////"_IBCIBPSP(IBCILSEG)
+53 SET DIE="^IBA(351.9,"_IBIFN_",5,"
SET DA=IBCILSEG
SET DA(1)=IBIFN
DO ^DIE
+54 SET DR="2.07////"_IBCIBPDI(IBCILSEG)_";2.08////"_IBCIBPUP(IBCILSEG)
+55 SET DR=DR_";2.09////"_IBCIPPID(IBCILSEG)_";2.1////"_IBCISPAI(IBCILSEG)
+56 SET DR=DR_";2.11////"_IBCITOS(IBCILSEG)_";2.12////"_IBCIUNIT(IBCILSEG)
+57 SET DR=DR_";3.01////"_IBCICPT(IBCILSEG)
+58 SET DIE="^IBA(351.9,"_IBIFN_",5,"
SET DA=IBCILSEG
SET DA(1)=IBIFN
DO ^DIE
+59 QUIT
End DoDot:1
+60 DO CLEAN^IBCIUT2
KILL IBCIADD
+61 QUIT
+62 ;
INIT1 ; Initialize variables for adding entry in 351.9
+1 NEW IBZ,IBPRV
+2 SET IBCIDFN=$PIECE(^DGCR(399,IBIFN,0),U,2)
+3 SET IBCICL=$PIECE(^DGCR(399,IBIFN,0),U)
+4 SET IBCIST=$SELECT(IBCIADD=1:1,1:$PIECE(^IBA(351.9,IBIFN,0),U,2))
SET IBCIEB=DUZ
+5 SET (IBCIDE,IBCIET)=$$NOW^XLFDT
+6 SET IBCIPID=$PIECE(^DPT(IBCIDFN,0),U,9)
+7 SET X=$PIECE(^DPT(IBCIDFN,0),U)
DO NAMSP^IBCIUT1
+8 SET IBCIPTLA=$PIECE(Y,U,1)
SET IBCIPTFI=$PIECE(Y,U,2)
SET IBCIPTMI=$PIECE(Y,U,3)
+9 SET IBCIDOB=$PIECE(^DPT(IBCIDFN,0),U,3)
SET IBCISEX=$PIECE(^DPT(IBCIDFN,0),U,2)
+10 ;
+11 ; capture referring provider information
+12 ; "1" signifies referring provider
DO GETPRV^IBCEU(IBIFN,1,.IBZ)
+13 SET IBZ=$GET(IBZ(1,1))
+14 IF IBZ'=""
Begin DoDot:1
+15 SET IBPRV=$PIECE(IBZ,U,3)
+16 SET IBRFLN=$$NAME^IBCEFG1($PIECE(IBZ,U,1))
SET IBRFMN=$PIECE(IBRFLN,U,3)
SET IBRFFN=$PIECE(IBRFLN,U,2)
SET IBRFLN=$PIECE(IBRFLN,U,1)
+17 ; ref prov specialty
SET IBRFSPEC=$$BILLSPEC^IBCEU3(IBIFN,IBPRV)
+18 ; va provider data
IF IBPRV'["IBA(355.93"
Begin DoDot:2
+19 SET IBRFID=+IBPRV
+20 SET IBRFDEPT=$PIECE($GET(^VA(200,+IBPRV,5)),U,1)
+21 QUIT
End DoDot:2
+22 ; non-va provider data
IF IBPRV["IBA(355.93"
Begin DoDot:2
+23 SET IBRFID="NVA"_+IBPRV
+24 SET IBRFDEPT="NVA"
+25 QUIT
End DoDot:2
+26 QUIT
End DoDot:1
+27 ;
+28 ;initialize variables for line items in 351.9 and save
+29 DO F^IBCEF("N-HCFA 1500 SERVICES (PRINT)",,,IBIFN)
+30 SET IBCILSEG=0
+31 FOR
SET IBCILSEG=$ORDER(IBXDATA(IBCILSEG))
if 'IBCILSEG
QUIT
Begin DoDot:1
+32 NEW CURRENT,DIV
+33 SET X=$PIECE(IBXDATA(IBCILSEG),U)
SET IBCIBDOS(IBCILSEG)=$$NOW1^IBCIUT1(X)
+34 IF $PIECE(IBXDATA(IBCILSEG),U,2)]""
SET X=$PIECE(IBXDATA(IBCILSEG),U,2)
SET IBCIEDOS(IBCILSEG)=$$NOW1^IBCIUT1(X)
+35 IF $PIECE(IBXDATA(IBCILSEG),U,2)']""
SET IBCIEDOS(IBCILSEG)=IBCIBDOS(IBCILSEG)
+36 SET IBCIPOS(IBCILSEG)=$PIECE(IBXDATA(IBCILSEG),U,3)
+37 SET IBCITOS(IBCILSEG)=$PIECE(IBXDATA(IBCILSEG),U,4)
+38 SET IBCISPC(IBCILSEG)=$PIECE(IBXDATA(IBCILSEG),U,5)
+39 SET IBCISAMT(IBCILSEG)=$PIECE(IBXDATA(IBCILSEG),U,8)
+40 SET IBCIUNIT(IBCILSEG)=$PIECE(IBXDATA(IBCILSEG),U,9)
+41 SET IBCICPT(IBCILSEG)=$PIECE(IBXDATA(IBCILSEG),U,10)
+42 SET IBCICPT(IBCILSEG)=$$GETMOD^IBCIUT5(IBCICPT(IBCILSEG))
+43 IF IBCIUNIT(IBCILSEG)>1
SET IBCISAMT(IBCILSEG)=IBCISAMT(IBCILSEG)*IBCIUNIT(IBCILSEG)
+44 SET IBCIAPC(IBCILSEG)=""
SET IBCIXLID(IBCILSEG)=IBCILSEG
+45 SET IBCIOGID(IBCILSEG)=""
SET IBCIOID(IBCILSEG)=""
SET IBCIPAC(IBCILSEG)=""
+46 ;
+47 ; capture the default division (field# .22) for the organization id
+48 SET DIV=$PIECE($GET(^DGCR(399,IBIFN,0)),U,22)
+49 IF DIV
SET IBCIOID(IBCILSEG)=$PIECE($GET(^DG(40.8,DIV,0)),U,2)
+50 ;
+51 ; Billing provider information
+52 ; Get provider information
SET IBXDAT1=$$RPHY^IBCIUT1(IBIFN)
+53 ; provider ID
SET IBCIBPID(IBCILSEG)=$PIECE(IBXDAT1,U,2)
+54 ; parse full provider name
SET X=$PIECE(IBXDAT1,U,1)
DO NAMSP^IBCIUT1
+55 ; provider last name
SET IBCIBPLA(IBCILSEG)=$PIECE(Y,U,1)
+56 ; provider first name
SET IBCIBPFI(IBCILSEG)=$PIECE(Y,U,2)
+57 ; provider middle name
SET IBCIBPMI(IBCILSEG)=$PIECE(Y,U,3)
+58 ; provider department
SET IBCIBPDE(IBCILSEG)=$PIECE(IBXDAT1,U,3)
+59 ; provider specialty
SET IBCIBPSP(IBCILSEG)=$PIECE(IBXDAT1,U,4)
+60 ; provider degree ID
SET IBCIBPDI(IBCILSEG)=""
+61 ; provider title
SET IBCIBPTI(IBCILSEG)=""
+62 ; provider UPIN
SET IBCIBPUP(IBCILSEG)=""
+63 ; clean up
KILL X,Y
+64 ;
+65 ; Primary payer ID
+66 SET IBCIPPID(IBCILSEG)=$$FINDINS^IBCEF1(IBIFN)
+67 ;
+68 ; Get the secondary payer ID based on the current bill sequence
+69 ;
+70 SET IBCISPAI(IBCILSEG)=""
+71 SET CURRENT=$$COB^IBCEF(IBIFN)
+72 IF CURRENT="P"
SET IBCISPAI(IBCILSEG)=$$FINDINS^IBCEF1(IBIFN,"S")
+73 IF CURRENT="S"
SET IBCISPAI(IBCILSEG)=$$FINDINS^IBCEF1(IBIFN,"T")
+74 ;
+75 SET IBCISPID(IBCILSEG)=""
SET IBCISPLA(IBCILSEG)=""
SET IBCISPFI(IBCILSEG)=""
+76 SET IBCISPMI(IBCILSEG)=""
SET IBCISPTI(IBCILSEG)=""
SET IBCISPDE(IBCILSEG)=""
+77 SET IBCISPSP(IBCILSEG)=""
SET IBCISPDI(IBCILSEG)=""
SET IBCISPUP(IBCILSEG)=""
+78 QUIT
End DoDot:1
+79 QUIT
+80 ;
ADDSUB ;create the subfile
+1 SET DIC="^IBA(351.9,"_IBIFN_",5,"
SET DA(1)=IBIFN
SET DIC(0)="LMN"
SET (DA,X)=IBCILSEG
+2 DO FILE^DICN
+3 QUIT
