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

IBCIADD1.m

Go to the documentation of this file.
  1. IBCIADD1 ;DSI/SLM - ADD ENTRY TO FILE 351.9 ;17-JAN-2001
  1. ;;2.0;INTEGRATED BILLING;**161,203,155**;21-MAR-94
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. ADD ;add an entry
  1. Q:'IBIFN
  1. N FDA,IENS S IBCIADD=1
  1. S DIC="^IBA(351.9,",(X,DINUM)=IBIFN,DIC(0)="Z"
  1. D FILE^DICN I Y<0 W !!,IBIFN," NOT ADDED TO FILE 351.9" K Y Q
  1. UPDT ; update an entry
  1. I $G(IBCISNT)=7 Q ; esg - 1/3/2002
  1. ;
  1. ; esg - 3/20/02 - No need to rebuild the 3,4,5 nodes in the event of
  1. ; a cancel because we want to send the claim lines that were
  1. ; most recently sent to CM, not whatever Vista has now.
  1. ; esg - 10/9/02 - However, if the 3,4,5 nodes are not there, then we
  1. ; need to rebuild them based on whatever Vista has now.
  1. ;
  1. I $G(IBCISNT)=4,$P($G(^IBA(351.9,IBIFN,3)),U,1) Q
  1. ;
  1. D CLEAN^IBCIUT2,DELTI^IBCIUT4
  1. NEW IBRFID,IBRFLN,IBRFMN,IBRFFN,IBRFDEPT,IBRFSPEC
  1. S (IBRFID,IBRFLN,IBRFMN,IBRFFN,IBRFDEPT,IBRFSPEC)=""
  1. I '$D(IBCIADD) S IBCIADD=0
  1. D INIT1
  1. S IENS=IBIFN_","
  1. S FDA(351.9,IENS,.02)=IBCIST
  1. I $P(^IBA(351.9,IBIFN,0),U,6)']"" D
  1. .S FDA(351.9,IENS,.06)=IBCIDE,FDA(351.9,IENS,.07)=IBCIEB
  1. S FDA(351.9,IENS,3.01)=IBCIPID,FDA(351.9,IENS,3.02)=IBCIPTLA
  1. S FDA(351.9,IENS,3.03)=IBCIPTMI,FDA(351.9,IENS,3.04)=IBCIPTFI
  1. S FDA(351.9,IENS,3.05)=IBCIDOB,FDA(351.9,IENS,3.06)=IBCISEX
  1. S FDA(351.9,IENS,3.07)=IBCIET
  1. ;
  1. ; Add referring provider fields
  1. S FDA(351.9,IENS,3.08)=IBRFID ; ID
  1. S FDA(351.9,IENS,3.09)=IBRFLN ; last name
  1. S FDA(351.9,IENS,3.1)=IBRFMN ; middle name
  1. S FDA(351.9,IENS,3.11)=IBRFFN ; first name
  1. S FDA(351.9,IENS,4.01)=IBRFDEPT ; department
  1. S FDA(351.9,IENS,4.02)=IBRFSPEC ; specialty
  1. ;
  1. D FILE^DIE("K","FDA"),UPDT1^IBCIST
  1. ;
  1. S IBCILSEG=0 F S IBCILSEG=$O(IBXDATA(IBCILSEG)) Q:'IBCILSEG D
  1. .I '$D(^IBA(351.9,IBIFN,5,IBCILSEG)) D ADDSUB
  1. .S DR=".06////"_IBCIBDOS(IBCILSEG)_";.02////"_IBCIXLID(IBCILSEG)
  1. .S DR=DR_";.03////"_IBCIOGID(IBCILSEG)_";.04////"_IBCIOID(IBCILSEG)
  1. .S DR=DR_";.07////"_IBCIEDOS(IBCILSEG)_";.08////"_IBCIPOS(IBCILSEG)
  1. .S DR=DR_";.09////"_IBCISPC(IBCILSEG)_";.1////"_IBCIAPC(IBCILSEG)
  1. .S DR=DR_";.11////"_IBCISAMT(IBCILSEG)_";.12////"_IBCIPAC(IBCILSEG)
  1. .S DIE="^IBA(351.9,"_IBIFN_",5,",DA=IBCILSEG,DA(1)=IBIFN D ^DIE
  1. .S DR=".13////"_IBCISPID(IBCILSEG)_";1.01////"_IBCISPLA(IBCILSEG)
  1. .S DR=DR_";1.02////"_IBCISPMI(IBCILSEG)_";1.03////"_IBCISPFI(IBCILSEG)
  1. .S DR=DR_";1.04////"_IBCISPTI(IBCILSEG)_";1.05////"_IBCISPDE(IBCILSEG)
  1. .S DIE="^IBA(351.9,"_IBIFN_",5,",DA=IBCILSEG,DA(1)=IBIFN D ^DIE
  1. .S DR="1.06////"_IBCISPSP(IBCILSEG)_";1.07////"_IBCISPDI(IBCILSEG)
  1. .S DR=DR_";1.08////"_IBCISPUP(IBCILSEG)_";1.09////"_IBCIBPID(IBCILSEG)
  1. .S DIE="^IBA(351.9,"_IBIFN_",5,",DA=IBCILSEG,DA(1)=IBIFN D ^DIE
  1. .S DR="2.01////"_IBCIBPLA(IBCILSEG)_";2.02////"_IBCIBPMI(IBCILSEG)
  1. .S DR=DR_";2.03////"_IBCIBPFI(IBCILSEG)_";2.04////"_IBCIBPTI(IBCILSEG)
  1. .S DR=DR_";2.05////"_IBCIBPDE(IBCILSEG)_";2.06////"_IBCIBPSP(IBCILSEG)
  1. .S DIE="^IBA(351.9,"_IBIFN_",5,",DA=IBCILSEG,DA(1)=IBIFN D ^DIE
  1. .S DR="2.07////"_IBCIBPDI(IBCILSEG)_";2.08////"_IBCIBPUP(IBCILSEG)
  1. .S DR=DR_";2.09////"_IBCIPPID(IBCILSEG)_";2.1////"_IBCISPAI(IBCILSEG)
  1. .S DR=DR_";2.11////"_IBCITOS(IBCILSEG)_";2.12////"_IBCIUNIT(IBCILSEG)
  1. .S DR=DR_";3.01////"_IBCICPT(IBCILSEG)
  1. .S DIE="^IBA(351.9,"_IBIFN_",5,",DA=IBCILSEG,DA(1)=IBIFN D ^DIE
  1. .Q
  1. D CLEAN^IBCIUT2 K IBCIADD
  1. Q
  1. ;
  1. INIT1 ; Initialize variables for adding entry in 351.9
  1. NEW IBZ,IBPRV
  1. S IBCIDFN=$P(^DGCR(399,IBIFN,0),U,2)
  1. S IBCICL=$P(^DGCR(399,IBIFN,0),U)
  1. S IBCIST=$S(IBCIADD=1:1,1:$P(^IBA(351.9,IBIFN,0),U,2)),IBCIEB=DUZ
  1. S (IBCIDE,IBCIET)=$$NOW^XLFDT
  1. S IBCIPID=$P(^DPT(IBCIDFN,0),U,9)
  1. S X=$P(^DPT(IBCIDFN,0),U) D NAMSP^IBCIUT1
  1. S IBCIPTLA=$P(Y,U,1),IBCIPTFI=$P(Y,U,2),IBCIPTMI=$P(Y,U,3)
  1. S IBCIDOB=$P(^DPT(IBCIDFN,0),U,3),IBCISEX=$P(^DPT(IBCIDFN,0),U,2)
  1. ;
  1. ; capture referring provider information
  1. D GETPRV^IBCEU(IBIFN,1,.IBZ) ; "1" signifies referring provider
  1. S IBZ=$G(IBZ(1,1))
  1. I IBZ'="" D
  1. . S IBPRV=$P(IBZ,U,3)
  1. . S IBRFLN=$$NAME^IBCEFG1($P(IBZ,U,1)),IBRFMN=$P(IBRFLN,U,3),IBRFFN=$P(IBRFLN,U,2),IBRFLN=$P(IBRFLN,U,1)
  1. . S IBRFSPEC=$$BILLSPEC^IBCEU3(IBIFN,IBPRV) ; ref prov specialty
  1. . I IBPRV'["IBA(355.93" D ; va provider data
  1. .. S IBRFID=+IBPRV
  1. .. S IBRFDEPT=$P($G(^VA(200,+IBPRV,5)),U,1)
  1. .. Q
  1. . I IBPRV["IBA(355.93" D ; non-va provider data
  1. .. S IBRFID="NVA"_+IBPRV
  1. .. S IBRFDEPT="NVA"
  1. .. Q
  1. . Q
  1. ;
  1. ;initialize variables for line items in 351.9 and save
  1. D F^IBCEF("N-HCFA 1500 SERVICES (PRINT)",,,IBIFN)
  1. S IBCILSEG=0
  1. F S IBCILSEG=$O(IBXDATA(IBCILSEG)) Q:'IBCILSEG D
  1. . NEW CURRENT,DIV
  1. . S X=$P(IBXDATA(IBCILSEG),U),IBCIBDOS(IBCILSEG)=$$NOW1^IBCIUT1(X)
  1. . I $P(IBXDATA(IBCILSEG),U,2)]"" S X=$P(IBXDATA(IBCILSEG),U,2),IBCIEDOS(IBCILSEG)=$$NOW1^IBCIUT1(X)
  1. . I $P(IBXDATA(IBCILSEG),U,2)']"" S IBCIEDOS(IBCILSEG)=IBCIBDOS(IBCILSEG)
  1. . S IBCIPOS(IBCILSEG)=$P(IBXDATA(IBCILSEG),U,3)
  1. . S IBCITOS(IBCILSEG)=$P(IBXDATA(IBCILSEG),U,4)
  1. . S IBCISPC(IBCILSEG)=$P(IBXDATA(IBCILSEG),U,5)
  1. . S IBCISAMT(IBCILSEG)=$P(IBXDATA(IBCILSEG),U,8)
  1. . S IBCIUNIT(IBCILSEG)=$P(IBXDATA(IBCILSEG),U,9)
  1. . S IBCICPT(IBCILSEG)=$P(IBXDATA(IBCILSEG),U,10)
  1. . S IBCICPT(IBCILSEG)=$$GETMOD^IBCIUT5(IBCICPT(IBCILSEG))
  1. . I IBCIUNIT(IBCILSEG)>1 S IBCISAMT(IBCILSEG)=IBCISAMT(IBCILSEG)*IBCIUNIT(IBCILSEG)
  1. . S IBCIAPC(IBCILSEG)="",IBCIXLID(IBCILSEG)=IBCILSEG
  1. . S IBCIOGID(IBCILSEG)="",IBCIOID(IBCILSEG)="",IBCIPAC(IBCILSEG)=""
  1. . ;
  1. . ; capture the default division (field# .22) for the organization id
  1. . S DIV=$P($G(^DGCR(399,IBIFN,0)),U,22)
  1. . I DIV S IBCIOID(IBCILSEG)=$P($G(^DG(40.8,DIV,0)),U,2)
  1. . ;
  1. . ; Billing provider information
  1. . S IBXDAT1=$$RPHY^IBCIUT1(IBIFN) ; Get provider information
  1. . S IBCIBPID(IBCILSEG)=$P(IBXDAT1,U,2) ; provider ID
  1. . S X=$P(IBXDAT1,U,1) D NAMSP^IBCIUT1 ; parse full provider name
  1. . S IBCIBPLA(IBCILSEG)=$P(Y,U,1) ; provider last name
  1. . S IBCIBPFI(IBCILSEG)=$P(Y,U,2) ; provider first name
  1. . S IBCIBPMI(IBCILSEG)=$P(Y,U,3) ; provider middle name
  1. . S IBCIBPDE(IBCILSEG)=$P(IBXDAT1,U,3) ; provider department
  1. . S IBCIBPSP(IBCILSEG)=$P(IBXDAT1,U,4) ; provider specialty
  1. . S IBCIBPDI(IBCILSEG)="" ; provider degree ID
  1. . S IBCIBPTI(IBCILSEG)="" ; provider title
  1. . S IBCIBPUP(IBCILSEG)="" ; provider UPIN
  1. . KILL X,Y ; clean up
  1. . ;
  1. . ; Primary payer ID
  1. . S IBCIPPID(IBCILSEG)=$$FINDINS^IBCEF1(IBIFN)
  1. . ;
  1. . ; Get the secondary payer ID based on the current bill sequence
  1. . ;
  1. . S IBCISPAI(IBCILSEG)=""
  1. . S CURRENT=$$COB^IBCEF(IBIFN)
  1. . I CURRENT="P" S IBCISPAI(IBCILSEG)=$$FINDINS^IBCEF1(IBIFN,"S")
  1. . I CURRENT="S" S IBCISPAI(IBCILSEG)=$$FINDINS^IBCEF1(IBIFN,"T")
  1. . ;
  1. . S IBCISPID(IBCILSEG)="",IBCISPLA(IBCILSEG)="",IBCISPFI(IBCILSEG)=""
  1. . S IBCISPMI(IBCILSEG)="",IBCISPTI(IBCILSEG)="",IBCISPDE(IBCILSEG)=""
  1. . S IBCISPSP(IBCILSEG)="",IBCISPDI(IBCILSEG)="",IBCISPUP(IBCILSEG)=""
  1. . Q
  1. Q
  1. ;
  1. ADDSUB ;create the subfile
  1. S DIC="^IBA(351.9,"_IBIFN_",5,",DA(1)=IBIFN,DIC(0)="LMN",(DA,X)=IBCILSEG
  1. D FILE^DICN
  1. Q