- 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 Jan 18, 2025@03:14:20 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