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