IBCU ;ALB/MRL - BILLING UTILITY ROUTINE ;01 JUN 88 12:00
;;2.0;INTEGRATED BILLING;**52,106,51,191,232,323,320,384,432,547,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified..
;
;MAP TO DGCRU
;
ARSTAT ;find status of bill in file 430.3 (ar) return status number
S IBARST=$$STA^PRCAFN(IBIFN)
Q
;
ARCAT ;Trigger logic to set who's responsible in 399.3 from AR Category
S X=$P($$CATN^PRCAFN($P(^DGCR(399.3,DA,0),"^",6)),"^",3)
S:X'="" X=$S("PC"[X:"p",X="N":"o",X="T":"i",1:"")
Q
;
PTF ;Screen for appropriate PTF records
K IBDD1 S DFN=+$P(^DGCR(399,+DA,0),"^",2) Q:'$D(^DPT(+DFN,0)) S IB05=$P(^(0),"^",1),IB03=$P(^DGCR(399,+DA,0),"^",3)
S IB01="",IB02=0 F IB02=0:0 S IB01=$O(^DD(45,0,"ID",IB01)) Q:'IB01 S IB02=IB02+1,IBDD(IB02)=^(IB01)
F IB01=0:0 S IB01=$O(^DGPT("B",+DFN,IB01)) Q:'IB01 I $D(^DGPT(+IB01,0)) S IB04=$P(^(0),"^",2),Y=+IB01 I $P(IB03,".",1)=$P(IB04,".",1) S IBDD1(+Y)="" I $S('$D(X):0,X["?":1,1:0) D PTFW
G PTFQ:X'["?" I '$O(IBDD1(0)) W !,"Patient has no ACTIVE PTF RECORDS for this event date.",!,"A 'PTF NUMBER' is required for inpatient billing records."
E W !!,"Select the appropriate billing record from the above listing by number."
PTFQ W ! K IB01,IB02,IB03,IB04,IB05,IBDD Q
PTFW W !,Y,?15,IB05 F IB02=0:0 S IB02=$O(IBDD(IB02)) Q:'IB02 X IBDD(IB02)
Q
;
AGE ;Input Transform for Condition Code 17
I X=18 G SEX
I X=17 S IBC=X,DFN=$P(^DGCR(399,D0,0),"^",2) D DEM^VADPT I VADM(4)<100 W !!,"This patient is only ",VADM(4)," years old!!",!! K IBC Q
I $D(IBC) S X=IBC
Q
;
SEX ;Input Transform for Condition Code 18
I X=18 S IBC=X,DFN=$P(^DGCR(399,D0,0),"^",2) D DEM^VADPT I $E(VADM(5))="M" W !!,"This patient is a MALE!! Condition code 18 applies only to FEMALES!!",!! K IBC,X
I $D(IBC) S X=IBC
Q
;
REV ;Input Transform for Revenue Code
I X=-1 W !!,"Choose only ACTIVE Revenue Codes!!",!! S D="AC" ;S X="" S X=$O(^DGCR(399.2,"AC",X)) Q:X="" W !,$P(^DGCR(399.2,X,0),"^",1),?30,$P(^(0),"^",2) K X Q
I '$D(IBC) I $D(^DGCR(399.2,X,0)) I '$P(^DGCR(399.2,X,0),"^",3) W !!,"Only ACTIVE Revenue Codes may be selected!!",!! K X Q
Q
;
YN S X=$E(X),X=$S(X=1:X,X=0:X,X="Y":1,X="y":1,X="n":0,X="N":0,1:2) I X'=2 D EN^DDIOL(" ("_$S(X:"YES",1:"NO")_")","","?0") Q
D EN^DDIOL("NOT A VALID CHOICE!","","!?4") K X Q
Q
;
NOPTF ; Input transform for file 399, field 159.5 (NON-VA ADMIT TIME)
N %DT
I X>24 K:X'=99 X Q
I $P($G(^DGCR(399,DA,0)),U,8) K X Q ; PTF pointer exists
S X=$TR(X,"M ") S:X=0 X="12A" S:X<12 X=$TR(X,"A")
S:X?1N.N&($L(X)<3) Y="."_$E("0",$L(X))_X S:X'?1.2N %DT="TPR",X=DT_"@"_X D:$L(X)>2 ^%DT S X=$E($P(Y,".",2)_"00",1,2)#24 K:Y=-1 X
Q
;
DIS ;Determine Billing Discharge status from PTF
;Called from triggers on fields .08 and 161
N A
I '$D(^DGCR(399,DA,0)) S X="" G DISQ
S X=$P(^DGCR(399,DA,0),"^",6) I X=2!(X=3) S X=$O(^DGCR(399.1,"B","STILL PATIENT",0)) G DISQ
S X=$P(^DGCR(399,DA,0),"^",8) I $S(X="":1,'$D(^DGPT(X)):1,1:0) S X="" G DISQ
I '+$G(^DGPT(X,70)) S X=$O(^DGCR(399.1,"B","STILL PATIENT",0)) G DISQ
S A=$P($G(^DGCR(399,DA,"U")),"^",2) I A,(A+.24)<+$G(^DGPT(X,70)) S X=$O(^DGCR(399.1,"B","STILL PATIENT",0)) G DISQ
S X=+$P($G(^DGPT(X,70)),"^",3)
I X=1 S X=$O(^DGCR(399.1,"B",$E("DISCHARGED TO HOME OR SELF CARE",1,30),0)) G DISQ
I X=4 S X=$O(^DGCR(399.1,"B",$E("LEFT AGAINST MEDICAL ADVICE",1,30),0)) G DISQ
I X=6!(X=7) S X=$O(^DGCR(399.1,"B","EXPIRED",0)) G DISQ
I X=5!(X=2) S X=$O(^DGCR(399.1,"B",$E("DISCHARGED TO ANOTHER SHORT-TERM GENERAL HOSPITAL",1,30),0)) G DISQ
S X=""
DISQ Q
;
INST ;Ask Institutution address info
S DIC("DR")="1.01;1.02;1.03;.02;1.04" I $D(^XUSEC("IB SUPERVISOR",DUZ)) S DLAYGO=4
Q
;
PTADD(DFN,MAXL) ; outputs patient address for the trigger on Patient Short Address (399,110)
N IBX,IBY,IBI,IBDPT S (IBX,IBDPT)="" I $G(MAXL)="PSA" S MAXL=47
I +$G(DFN) S IBDPT=$G(^DPT(DFN,.11)) F IBI=1:1:4 S IBY=$P(IBDPT,U,IBI) I IBY'="" S IBX=IBX_IBY_","
I +$P(IBDPT,U,5) S IBY=$P($G(^DIC(5,+$P(IBDPT,U,5),0)),U,2),IBX=IBX_IBY
I $P(IBDPT,U,12)'="" S IBX=IBX_" "_$P(IBDPT,U,12)
I +$G(MAXL),$L(IBX)>+MAXL S IBX=""
Q IBX
;
SM ;Flag for printing medicare statment on UB-82
;DGSM=0 means figure out which statement, DGSM=1 means no statements
S DGSM=0 Q
;IBCU
;
CHGTYP(IBIFN,ARR) ; sets up array of all charge types defined on a bill: ARR(TYPE, COMPONENT)=""
N IBI,IBX,IBT K ARR
I +$O(^DGCR(399,+$G(IBIFN),"RC",0)) S IBI=0 F S IBI=$O(^DGCR(399,+IBIFN,"RC",IBI)) Q:'IBI D
. S IBX=$G(^DGCR(399,+IBIFN,"RC",IBI,0)),IBT=$P(IBX,U,10) I +IBT S ARR(IBT,+$P(IBX,U,12))=""
Q
;
CHGTYPE(IBIFN) ; returns list of charge types on a bill: TYPE ^ TYPE ^ ... ; EXTERNAL TYPE , EXTERNAL TYPE , ...
N IBAR,IBY,IBS,IBI,IBC,IBJ,IBX
D CHGTYP($G(IBIFN),.IBAR)
S (IBX,IBY,IBS)="",IBI=0 F S IBI=$O(IBAR(IBI)) Q:'IBI D
. S IBX=IBX_IBI_U
. S IBC="INPT" I IBI=1 S IBJ=$O(IBAR(IBI,0)),IBC=$S(IBJ=1:"INST",IBJ=2:"PF",1:"INPT") I +$O(IBAR(IBI,IBJ)) S IBC="INPT"
. S IBY=IBY_IBS_$S(IBI=1:IBC,IBI=2:"VST",IBI=3:"RX",IBI=4:"CPT",IBI=5:"PI",IBI=6:"DRG",IBI=9:"UN",1:""),IBS=","
S IBY=IBX_";"_IBY
Q IBY
;
BCHGTYPE(IBIFN) ; returns type of bill and charges: (CLASS (.05): TYPE, TYPE, ...)
N IBCLASS,IBTYPE,IBY S IBY=""
S IBCLASS=$P($G(^DGCR(399,+$G(IBIFN),0)),U,5)
S IBTYPE=$P($$CHGTYPE(+$G(IBIFN)),";",2) I IBTYPE="INPT" S IBTYPE=""
I +IBCLASS S IBY=$S(IBCLASS<3:"Inpt",1:"Opt") I IBTYPE'="" S IBY=IBY_" ("_IBTYPE_")"
Q IBY
;
CLNSCRN(IBDT,CLIFN) ; screen for a Procedures Associated Clinic (399, 304, 6), returns true if clinic can be used
; clinic must be defined as a 'Clinic' and it must be active on date of procedure
;
N IBCL0,IBCLI,IBX S IBX=0
S IBCL0=$G(^SC(+$G(CLIFN),0)),IBCLI=$G(^SC(+$G(CLIFN),"I"))
S IBX=$S($P(IBCL0,U,3)'="C":0,'$G(IBDT):0,'IBCLI:1,+IBCLI>+IBDT:1,'$P(IBCLI,U,2):0,1:$P(IBCLI,U,2)'>IBDT)
Q IBX
;
PRVNUM(IBIFN,IBINS,COB) ; Trigger code (399:122,123,124)
; on Primary Secondary/Tertiary Carrier (399:101,102,103)
; returns the Provider Number for the Insurance Company
; Hospital Provider Number for prov id in file 355.92
; or Medicare A provider Number (psych/non-psych) if Medicare A
;
; Input IBIFN - bill ifn
; IBINS - insurance company ifn (opt)
; COB - 1 for primary, 2 for secondary, 3 for tertiary
;
N IBX,IBB0,IBBF,IBFT,Z,Z0
S:'$G(COB) COB=1
S IBX=$P($G(^DGCR(399,+$G(IBIFN),"M1")),U,COB+1),IBB0=$G(^DGCR(399,+$G(IBIFN),0))
I $G(IBINS)="" S IBINS=+$G(^DGCR(399,+$G(IBIFN),"I"_COB))
G:'IBINS PRVNQ
;
; OEC - 12/21/05 - If an MRA is being processed into an MRA secondary
; claim and the billing provider # already exists, then leave it
I $G(IBPRCOB),IBX'="" G PRVNQ
;
;patch 432 enh5: The IB system shall no longer add the following default Billing Provider Secondary ID to all Medicare Part A (Institutional) general/psychiatric claims: 674499 Psychiatric, 670899 General
;I +$G(IBIFN),COB N DA S DA=IBIFN I $$MCRACK^IBCBB3(+IBIFN,$P($G(^DGCR(399,+IBIFN,"TX")),U,5),+COB) S IBX=$$MCRANUM^IBCBB3(+IBIFN) G PRVNQ
;
; WCJ - 1/17/06 - Some Insurances require certain electronic plan types to have no secondary ID
; Check if this plan type requires a blank sec id to go out for this insurance
N NOSEC S NOSEC=0
I $D(^DIC(36,IBINS,13)),$G(IBIFN) D
. N PLAN,PLANTYPE
. S PLAN=$P($G(^DGCR(399,IBIFN,"I"_COB)),U,18) Q:'PLAN
. S PLANTYPE=$P($G(^IBA(355.3,PLAN,0)),U,15) Q:'PLANTYPE
. Q:'$D(^DIC(36,IBINS,13,"B",PLANTYPE))
. S NOSEC=1,IBX=""
I NOSEC G PRVNQ
;
; If using attending/rendering secondary ID, don't do anything
I $$FT^IBCEF(IBIFN)=2,$$GET1^DIQ(36,IBINS,4.06,"I") G PRVNQ
I $$FT^IBCEF(IBIFN)=3,$$GET1^DIQ(36,IBINS,4.08,"I") G PRVNQ
;JWS;IB*2.0*592;Dental form 7
;IA# 2056
I $$FT^IBCEF(IBIFN)=7,$$GET1^DIQ(36,IBINS,4.06,"I") G PRVNQ
;
S IBX=$$FACNUM^IBCEP2B(IBIFN,COB)
;
; PATCH 432 ENH5: The IB system shall no longer add a default Billing Provider Secondary ID to a claim.
;I IBX="" S IBX=$$GET1^DIQ(350.9,1,1.05)
;
PRVNQ Q IBX
;
BF() ; Returns ien of billing fac primary id type
N Z,IBX
S IBX="",Z=0 F S Z=$O(^IBE(355.97,Z)) Q:'Z I $P($G(^(Z,1)),U,9) S IBX=Z Q
Q IBX
;
BILLPNS(IBIFN) ; Trigger Code that sets all Bill P/S/T Prov# and QUAL (399: .122,123,124,128,129,130)
; on Bill Form Type (399:.19)
N IBDR
;
I +$G(^DGCR(399,+$G(IBIFN),"I1")) S IBDR(399,IBIFN_",",122)=$$PRVNUM(IBIFN,"",1),IBDR(399,IBIFN_",",128)=$$PRVQUAL(IBIFN,"",1)
I +$G(^DGCR(399,+$G(IBIFN),"I2")) S IBDR(399,IBIFN_",",123)=$$PRVNUM(IBIFN,"",2),IBDR(399,IBIFN_",",129)=$$PRVQUAL(IBIFN,"",2)
I +$G(^DGCR(399,+$G(IBIFN),"I3")) S IBDR(399,IBIFN_",",124)=$$PRVNUM(IBIFN,"",3),IBDR(399,IBIFN_",",130)=$$PRVQUAL(IBIFN,"",3)
;
I $O(IBDR(0)) D FILE^DIE("","IBDR")
Q
;
PRVQUAL(IBIFN,IBINS,COB) ; Trigger code for Bill P/S/T Prov QUAL (399:128,129,130)
; on P/S/T Carrier (399: 101,102,103)
; returns the Provider ID QUALIFIER
;
; Input IBIFN - bill ifn
; IBINS - insurance company ifn (opt)
; COB - 1 for primary, 2 for secondary, 3 for tertiary
;
N IBX,IBB0,IBBF,IBFT,Z,Z0
S:'$G(COB) COB=1
S IBX=$P($G(^DGCR(399,+$G(IBIFN),"M1")),U,COB+9),IBB0=$G(^DGCR(399,+$G(IBIFN),0))
I $G(IBINS)="" S IBINS=+$G(^DGCR(399,+$G(IBIFN),"I"_COB))
G:'IBINS PRVQUALQ
;
; If an MRA is being processed into an MRA secondary claim and the
; billing provider qualifier already exists, then leave it alone
I $G(IBPRCOB),IBX'="" G PRVQUALQ
;
; PATCH 432 ENH5: The IB system shall no longer add a default Billing Provider Secondary ID to a claim.
;I +$G(IBIFN),COB N DA S DA=IBIFN I $$MCRACK^IBCBB3(+IBIFN,$P($G(^DGCR(399,+IBIFN,"TX")),U,5),+COB) S IBX=$$FIND1^DIC(355.97,,"MX","MEDICARE PART A") G PRVQUALQ
;
; Some Insurances require certain electronic plan types to have no secondary ID
; If this is the case, there is no qualifier
N NOSEC S NOSEC=0
I $D(^DIC(36,IBINS,13)),$G(IBIFN) D
. N PLAN,PLANTYPE
. S PLAN=$P($G(^DGCR(399,IBIFN,"I"_COB)),U,18) Q:'PLAN
. S PLANTYPE=$P($G(^IBA(355.3,PLAN,0)),U,15) Q:'PLANTYPE
. Q:'$D(^DIC(36,IBINS,13,"B",PLANTYPE))
. S NOSEC=1,IBX=""
I NOSEC G PRVQUALQ
;
; Leave qualifer blank if sending REND/ATT ID
I $$FT^IBCEF(IBIFN)=2,$$GET1^DIQ(36,IBINS,4.06,"I") G PRVQUALQ
I $$FT^IBCEF(IBIFN)=3,$$GET1^DIQ(36,IBINS,4.08,"I") G PRVQUALQ
;JWS;IB*2.0*592;Dental form 7
;IA# 2056
I $$FT^IBCEF(IBIFN)=7,$$GET1^DIQ(36,IBINS,4.06,"I") G PRVQUALQ
;
S IBX=$$FACNUM^IBCEP2B(IBIFN,COB,1)
;
I IBX="",$$GET1^DIQ(350.9,1,1.05)=$P($G(^DGCR(399,IBIFN,"M1")),U,COB+1) S IBX=$$FIND1^DIC(355.97,,"MX","1J")
;
PRVQUALQ Q IBX
;
ACIDS(IBIFN,COB,ENTRY) ; Administrative Contractor IDS
; This is called as a screen from fields 140, 142, and 144 in the BILL/CLAIMS file #399
; It should only allow types that have previously been defined for this insurance company and
; are allowed for this form type.
;
; Input IBIFN - bill ifn
; COB - 1 for primary, 2 for secondary, 3 for tertiary
; ENTRY - IEN # to the pointed to file corresponding to what the user entered.
;
; Output 1 or 0, yay or nay, good or evil, jedi or sith ...
;
; overkill, but why not
Q:'$G(ENTRY) 0
Q:'$G(COB) 0
Q:'$D(IBIFN) 0
;
N IBINSDAT,IBINSCO,IBPLAN,IBPLTYPE,IBPLDAT,IBSPSF,IBINST,IBINSSF
;
; get insurance company data from bill
S IBINSDAT=$G(^DGCR(399,IBIFN,"I"_COB))
Q:'IBINSDAT 0 ; no insurance company
S IBINSCO=+IBINSDAT
;
; get the plan
S IBPLAN=$P(IBINSDAT,U,18)
Q:'IBPLAN 0 ; no plan
;
; get the pland data
S IBPLDAT=$G(^IBA(355.3,IBPLAN,0))
Q:IBPLDAT="" 0 ; no valid plan
;
; get the electronic plan type
S IBPLTYPE=$P(IBPLDAT,U,15)
Q:IBPLTYPE="" 0 ; no electronic plan type
;
; at this point, IBPLTYPE="MX" for medicare. anything else is not medicare (considered commercial for the purpose of this exercise).
; we will next be looking to see if this is set up correctly by looking at the correct subfile in the file 36.
; subfile 36.015 is for institutional
; subfile 36.016 is for professional.
;
; get the site parameter subfile
S IBSPSF=$S(IBPLTYPE="MX":81,1:82)
;
; get the formtype (Instituional or professional)
S IBINST=$$FT^IBCEF(+IBIFN)=3 ; set IBINST flag=1 if it is institutional.
;
; get the insurance subfile
S IBINSSF=$S(IBINST:15,1:16)
;
; quit if the subfile is not defined
Q:'$P($G(^DIC(36,IBINSCO,IBINSSF,0)),U,3) 0 ; none set up for this Insurance Company
;
; get the values in the correct multiple
N TARGET,ERROR
D GETS^DIQ(36,IBINSCO_",",IBINSSF_"*","I","TARGET","ERROR")
Q:'$D(TARGET) 0 ; nothing set up in the site parameters
;
; TARGET contains something like this
; TARGET(36.015,"1,3,",.01,"I")=5
; TARGET(36.015,"1,3,",.02,"I")="TESTID1"
; TARGET(36.015,"2,3,",.01,"I")=29
; TARGET(36.015,"2,3,",.02,"I")="TESTID2"
;
N SUBFILE
S SUBFILE="36.0"_IBINSSF
;
; Now, time to make it more useful.
N LOOP1,ADMINCON
S LOOP1="" F S LOOP1=$O(TARGET(SUBFILE,LOOP1)) Q:LOOP1="" D
. Q:'$D(^IBE(350.9,1,IBSPSF,"B",+$G(TARGET(SUBFILE,LOOP1,.01,"I"))))
. S ADMINCON(TARGET(SUBFILE,LOOP1,.01,"I"))=""
;
; which leaves us with an array like
; ADMINCON(IEN1)=""
; ADMINCON(IEN2)=""
; of allowable entries.
;
; and finally, see if it's allowed.
; at this point, it needed to be in the site parameter file for use with this form type (institutional or professional)
; and it needed to be in the insurance company file for this type of plan (medicare or commercial)
Q $S($D(ADMINCON(+ENTRY)):1,1:0)
;
ACIDD(IBIFN,COB,ENTRY) ; Administrative Contractor ID Default
; This will default the ID based on the valid type entered.
; It is called from a trigger on fields 140, 142, and 144 in the BILL/CLAIMS file #399
; and triggers fields 141, 143, and 145
;
; Input IBIFN - bill ien
; COB - 1 for primary, 2 for secondary, 3 for tertiary
; ENTRY - value of triggering field
;
; Output Default ID for that Insurance Company or nothing at all
;
; overkill, but why not
Q:$G(ENTRY)="" ""
Q:'$G(COB) ""
Q:'$G(IBIFN) ""
;
N IBINST,IBINSDAT,IBINSSF,IBACID,IBSFIEN,IBINSCO
;
; get the form type (institutional or professional)
S IBINST=$$FT^IBCEF(+IBIFN)=3 ; set IBINST flag=1 if it is institutional.
;
; get insurance company data from bill
S IBINSDAT=$G(^DGCR(399,IBIFN,"I"_COB))
Q:'IBINSDAT "" ; no insurance company
S IBINSCO=+IBINSDAT
;
; get the insurance subfile based on institutional or professional
S IBINSSF=$S(IBINST:15,1:16)
;
; quit if the subfile is not defined
Q:'$P($G(^DIC(36,IBINSCO,IBINSSF,0)),U,4) "" ; none set up for this Insurance Company
;
; get the specific entry
S IBSFIEN=$O(^DIC(36,IBINSCO,IBINSSF,"B",ENTRY,""))
Q:'IBSFIEN ""
;
S IBACID=$P($G(^DIC(36,IBINSCO,IBINSSF,IBSFIEN,0)),U,2)
;
Q IBACID
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCU 14924 printed Oct 16, 2024@18:21:15 Page 2
IBCU ;ALB/MRL - BILLING UTILITY ROUTINE ;01 JUN 88 12:00
+1 ;;2.0;INTEGRATED BILLING;**52,106,51,191,232,323,320,384,432,547,592**;21-MAR-94;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified..
+3 ;
+4 ;MAP TO DGCRU
+5 ;
ARSTAT ;find status of bill in file 430.3 (ar) return status number
+1 SET IBARST=$$STA^PRCAFN(IBIFN)
+2 QUIT
+3 ;
ARCAT ;Trigger logic to set who's responsible in 399.3 from AR Category
+1 SET X=$PIECE($$CATN^PRCAFN($PIECE(^DGCR(399.3,DA,0),"^",6)),"^",3)
+2 if X'=""
SET X=$SELECT("PC"[X:"p",X="N":"o",X="T":"i",1:"")
+3 QUIT
+4 ;
PTF ;Screen for appropriate PTF records
+1 KILL IBDD1
SET DFN=+$PIECE(^DGCR(399,+DA,0),"^",2)
if '$DATA(^DPT(+DFN,0))
QUIT
SET IB05=$PIECE(^(0),"^",1)
SET IB03=$PIECE(^DGCR(399,+DA,0),"^",3)
+2 SET IB01=""
SET IB02=0
FOR IB02=0:0
SET IB01=$ORDER(^DD(45,0,"ID",IB01))
if 'IB01
QUIT
SET IB02=IB02+1
SET IBDD(IB02)=^(IB01)
+3 FOR IB01=0:0
SET IB01=$ORDER(^DGPT("B",+DFN,IB01))
if 'IB01
QUIT
IF $DATA(^DGPT(+IB01,0))
SET IB04=$PIECE(^(0),"^",2)
SET Y=+IB01
IF $PIECE(IB03,".",1)=$PIECE(IB04,".",1)
SET IBDD1(+Y)=""
IF $SELECT('$DATA(X):0,X["?":1,1:0)
DO PTFW
+4 if X'["?"
GOTO PTFQ
IF '$ORDER(IBDD1(0))
WRITE !,"Patient has no ACTIVE PTF RECORDS for this event date.",!,"A 'PTF NUMBER' is required for inpatient billing records."
+5 IF '$TEST
WRITE !!,"Select the appropriate billing record from the above listing by number."
PTFQ WRITE !
KILL IB01,IB02,IB03,IB04,IB05,IBDD
QUIT
PTFW WRITE !,Y,?15,IB05
FOR IB02=0:0
SET IB02=$ORDER(IBDD(IB02))
if 'IB02
QUIT
XECUTE IBDD(IB02)
+1 QUIT
+2 ;
AGE ;Input Transform for Condition Code 17
+1 IF X=18
GOTO SEX
+2 IF X=17
SET IBC=X
SET DFN=$PIECE(^DGCR(399,D0,0),"^",2)
DO DEM^VADPT
IF VADM(4)<100
WRITE !!,"This patient is only ",VADM(4)," years old!!",!!
KILL IBC
QUIT
+3 IF $DATA(IBC)
SET X=IBC
+4 QUIT
+5 ;
SEX ;Input Transform for Condition Code 18
+1 IF X=18
SET IBC=X
SET DFN=$PIECE(^DGCR(399,D0,0),"^",2)
DO DEM^VADPT
IF $EXTRACT(VADM(5))="M"
WRITE !!,"This patient is a MALE!! Condition code 18 applies only to FEMALES!!",!!
KILL IBC,X
+2 IF $DATA(IBC)
SET X=IBC
+3 QUIT
+4 ;
REV ;Input Transform for Revenue Code
+1 ;S X="" S X=$O(^DGCR(399.2,"AC",X)) Q:X="" W !,$P(^DGCR(399.2,X,0),"^",1),?30,$P(^(0),"^",2) K X Q
IF X=-1
WRITE !!,"Choose only ACTIVE Revenue Codes!!",!!
SET D="AC"
+2 IF '$DATA(IBC)
IF $DATA(^DGCR(399.2,X,0))
IF '$PIECE(^DGCR(399.2,X,0),"^",3)
WRITE !!,"Only ACTIVE Revenue Codes may be selected!!",!!
KILL X
QUIT
+3 QUIT
+4 ;
YN SET X=$EXTRACT(X)
SET X=$SELECT(X=1:X,X=0:X,X="Y":1,X="y":1,X="n":0,X="N":0,1:2)
IF X'=2
DO EN^DDIOL(" ("_$SELECT(X:"YES",1:"NO")_")","","?0")
QUIT
+1 DO EN^DDIOL("NOT A VALID CHOICE!","","!?4")
KILL X
QUIT
+2 QUIT
+3 ;
NOPTF ; Input transform for file 399, field 159.5 (NON-VA ADMIT TIME)
+1 NEW %DT
+2 IF X>24
if X'=99
KILL X
QUIT
+3 ; PTF pointer exists
IF $PIECE($GET(^DGCR(399,DA,0)),U,8)
KILL X
QUIT
+4 SET X=$TRANSLATE(X,"M ")
if X=0
SET X="12A"
if X<12
SET X=$TRANSLATE(X,"A")
+5 if X?1N.N&($LENGTH(X)<3)
SET Y="."_$EXTRACT("0",$LENGTH(X))_X
if X'?1.2N
SET %DT="TPR"
SET X=DT_"@"_X
if $LENGTH(X)>2
DO ^%DT
SET X=$EXTRACT($PIECE(Y,".",2)_"00",1,2)#24
if Y=-1
KILL X
+6 QUIT
+7 ;
DIS ;Determine Billing Discharge status from PTF
+1 ;Called from triggers on fields .08 and 161
+2 NEW A
+3 IF '$DATA(^DGCR(399,DA,0))
SET X=""
GOTO DISQ
+4 SET X=$PIECE(^DGCR(399,DA,0),"^",6)
IF X=2!(X=3)
SET X=$ORDER(^DGCR(399.1,"B","STILL PATIENT",0))
GOTO DISQ
+5 SET X=$PIECE(^DGCR(399,DA,0),"^",8)
IF $SELECT(X="":1,'$DATA(^DGPT(X)):1,1:0)
SET X=""
GOTO DISQ
+6 IF '+$GET(^DGPT(X,70))
SET X=$ORDER(^DGCR(399.1,"B","STILL PATIENT",0))
GOTO DISQ
+7 SET A=$PIECE($GET(^DGCR(399,DA,"U")),"^",2)
IF A
IF (A+.24)<+$GET(^DGPT(X,70))
SET X=$ORDER(^DGCR(399.1,"B","STILL PATIENT",0))
GOTO DISQ
+8 SET X=+$PIECE($GET(^DGPT(X,70)),"^",3)
+9 IF X=1
SET X=$ORDER(^DGCR(399.1,"B",$EXTRACT("DISCHARGED TO HOME OR SELF CARE",1,30),0))
GOTO DISQ
+10 IF X=4
SET X=$ORDER(^DGCR(399.1,"B",$EXTRACT("LEFT AGAINST MEDICAL ADVICE",1,30),0))
GOTO DISQ
+11 IF X=6!(X=7)
SET X=$ORDER(^DGCR(399.1,"B","EXPIRED",0))
GOTO DISQ
+12 IF X=5!(X=2)
SET X=$ORDER(^DGCR(399.1,"B",$EXTRACT("DISCHARGED TO ANOTHER SHORT-TERM GENERAL HOSPITAL",1,30),0))
GOTO DISQ
+13 SET X=""
DISQ QUIT
+1 ;
INST ;Ask Institutution address info
+1 SET DIC("DR")="1.01;1.02;1.03;.02;1.04"
IF $DATA(^XUSEC("IB SUPERVISOR",DUZ))
SET DLAYGO=4
+2 QUIT
+3 ;
PTADD(DFN,MAXL) ; outputs patient address for the trigger on Patient Short Address (399,110)
+1 NEW IBX,IBY,IBI,IBDPT
SET (IBX,IBDPT)=""
IF $GET(MAXL)="PSA"
SET MAXL=47
+2 IF +$GET(DFN)
SET IBDPT=$GET(^DPT(DFN,.11))
FOR IBI=1:1:4
SET IBY=$PIECE(IBDPT,U,IBI)
IF IBY'=""
SET IBX=IBX_IBY_","
+3 IF +$PIECE(IBDPT,U,5)
SET IBY=$PIECE($GET(^DIC(5,+$PIECE(IBDPT,U,5),0)),U,2)
SET IBX=IBX_IBY
+4 IF $PIECE(IBDPT,U,12)'=""
SET IBX=IBX_" "_$PIECE(IBDPT,U,12)
+5 IF +$GET(MAXL)
IF $LENGTH(IBX)>+MAXL
SET IBX=""
+6 QUIT IBX
+7 ;
SM ;Flag for printing medicare statment on UB-82
+1 ;DGSM=0 means figure out which statement, DGSM=1 means no statements
+2 SET DGSM=0
QUIT
+3 ;IBCU
+4 ;
CHGTYP(IBIFN,ARR) ; sets up array of all charge types defined on a bill: ARR(TYPE, COMPONENT)=""
+1 NEW IBI,IBX,IBT
KILL ARR
+2 IF +$ORDER(^DGCR(399,+$GET(IBIFN),"RC",0))
SET IBI=0
FOR
SET IBI=$ORDER(^DGCR(399,+IBIFN,"RC",IBI))
if 'IBI
QUIT
Begin DoDot:1
+3 SET IBX=$GET(^DGCR(399,+IBIFN,"RC",IBI,0))
SET IBT=$PIECE(IBX,U,10)
IF +IBT
SET ARR(IBT,+$PIECE(IBX,U,12))=""
End DoDot:1
+4 QUIT
+5 ;
CHGTYPE(IBIFN) ; returns list of charge types on a bill: TYPE ^ TYPE ^ ... ; EXTERNAL TYPE , EXTERNAL TYPE , ...
+1 NEW IBAR,IBY,IBS,IBI,IBC,IBJ,IBX
+2 DO CHGTYP($GET(IBIFN),.IBAR)
+3 SET (IBX,IBY,IBS)=""
SET IBI=0
FOR
SET IBI=$ORDER(IBAR(IBI))
if 'IBI
QUIT
Begin DoDot:1
+4 SET IBX=IBX_IBI_U
+5 SET IBC="INPT"
IF IBI=1
SET IBJ=$ORDER(IBAR(IBI,0))
SET IBC=$SELECT(IBJ=1:"INST",IBJ=2:"PF",1:"INPT")
IF +$ORDER(IBAR(IBI,IBJ))
SET IBC="INPT"
+6 SET IBY=IBY_IBS_$SELECT(IBI=1:IBC,IBI=2:"VST",IBI=3:"RX",IBI=4:"CPT",IBI=5:"PI",IBI=6:"DRG",IBI=9:"UN",1:"")
SET IBS=","
End DoDot:1
+7 SET IBY=IBX_";"_IBY
+8 QUIT IBY
+9 ;
BCHGTYPE(IBIFN) ; returns type of bill and charges: (CLASS (.05): TYPE, TYPE, ...)
+1 NEW IBCLASS,IBTYPE,IBY
SET IBY=""
+2 SET IBCLASS=$PIECE($GET(^DGCR(399,+$GET(IBIFN),0)),U,5)
+3 SET IBTYPE=$PIECE($$CHGTYPE(+$GET(IBIFN)),";",2)
IF IBTYPE="INPT"
SET IBTYPE=""
+4 IF +IBCLASS
SET IBY=$SELECT(IBCLASS<3:"Inpt",1:"Opt")
IF IBTYPE'=""
SET IBY=IBY_" ("_IBTYPE_")"
+5 QUIT IBY
+6 ;
CLNSCRN(IBDT,CLIFN) ; screen for a Procedures Associated Clinic (399, 304, 6), returns true if clinic can be used
+1 ; clinic must be defined as a 'Clinic' and it must be active on date of procedure
+2 ;
+3 NEW IBCL0,IBCLI,IBX
SET IBX=0
+4 SET IBCL0=$GET(^SC(+$GET(CLIFN),0))
SET IBCLI=$GET(^SC(+$GET(CLIFN),"I"))
+5 SET IBX=$SELECT($PIECE(IBCL0,U,3)'="C":0,'$GET(IBDT):0,'IBCLI:1,+IBCLI>+IBDT:1,'$PIECE(IBCLI,U,2):0,1:$PIECE(IBCLI,U,2)'>IBDT)
+6 QUIT IBX
+7 ;
PRVNUM(IBIFN,IBINS,COB) ; Trigger code (399:122,123,124)
+1 ; on Primary Secondary/Tertiary Carrier (399:101,102,103)
+2 ; returns the Provider Number for the Insurance Company
+3 ; Hospital Provider Number for prov id in file 355.92
+4 ; or Medicare A provider Number (psych/non-psych) if Medicare A
+5 ;
+6 ; Input IBIFN - bill ifn
+7 ; IBINS - insurance company ifn (opt)
+8 ; COB - 1 for primary, 2 for secondary, 3 for tertiary
+9 ;
+10 NEW IBX,IBB0,IBBF,IBFT,Z,Z0
+11 if '$GET(COB)
SET COB=1
+12 SET IBX=$PIECE($GET(^DGCR(399,+$GET(IBIFN),"M1")),U,COB+1)
SET IBB0=$GET(^DGCR(399,+$GET(IBIFN),0))
+13 IF $GET(IBINS)=""
SET IBINS=+$GET(^DGCR(399,+$GET(IBIFN),"I"_COB))
+14 if 'IBINS
GOTO PRVNQ
+15 ;
+16 ; OEC - 12/21/05 - If an MRA is being processed into an MRA secondary
+17 ; claim and the billing provider # already exists, then leave it
+18 IF $GET(IBPRCOB)
IF IBX'=""
GOTO PRVNQ
+19 ;
+20 ;patch 432 enh5: The IB system shall no longer add the following default Billing Provider Secondary ID to all Medicare Part A (Institutional) general/psychiatric claims: 674499 Psychiatric, 670899 General
+21 ;I +$G(IBIFN),COB N DA S DA=IBIFN I $$MCRACK^IBCBB3(+IBIFN,$P($G(^DGCR(399,+IBIFN,"TX")),U,5),+COB) S IBX=$$MCRANUM^IBCBB3(+IBIFN) G PRVNQ
+22 ;
+23 ; WCJ - 1/17/06 - Some Insurances require certain electronic plan types to have no secondary ID
+24 ; Check if this plan type requires a blank sec id to go out for this insurance
+25 NEW NOSEC
SET NOSEC=0
+26 IF $DATA(^DIC(36,IBINS,13))
IF $GET(IBIFN)
Begin DoDot:1
+27 NEW PLAN,PLANTYPE
+28 SET PLAN=$PIECE($GET(^DGCR(399,IBIFN,"I"_COB)),U,18)
if 'PLAN
QUIT
+29 SET PLANTYPE=$PIECE($GET(^IBA(355.3,PLAN,0)),U,15)
if 'PLANTYPE
QUIT
+30 if '$DATA(^DIC(36,IBINS,13,"B",PLANTYPE))
QUIT
+31 SET NOSEC=1
SET IBX=""
End DoDot:1
+32 IF NOSEC
GOTO PRVNQ
+33 ;
+34 ; If using attending/rendering secondary ID, don't do anything
+35 IF $$FT^IBCEF(IBIFN)=2
IF $$GET1^DIQ(36,IBINS,4.06,"I")
GOTO PRVNQ
+36 IF $$FT^IBCEF(IBIFN)=3
IF $$GET1^DIQ(36,IBINS,4.08,"I")
GOTO PRVNQ
+37 ;JWS;IB*2.0*592;Dental form 7
+38 ;IA# 2056
+39 IF $$FT^IBCEF(IBIFN)=7
IF $$GET1^DIQ(36,IBINS,4.06,"I")
GOTO PRVNQ
+40 ;
+41 SET IBX=$$FACNUM^IBCEP2B(IBIFN,COB)
+42 ;
+43 ; PATCH 432 ENH5: The IB system shall no longer add a default Billing Provider Secondary ID to a claim.
+44 ;I IBX="" S IBX=$$GET1^DIQ(350.9,1,1.05)
+45 ;
PRVNQ QUIT IBX
+1 ;
BF() ; Returns ien of billing fac primary id type
+1 NEW Z,IBX
+2 SET IBX=""
SET Z=0
FOR
SET Z=$ORDER(^IBE(355.97,Z))
if 'Z
QUIT
IF $PIECE($GET(^(Z,1)),U,9)
SET IBX=Z
QUIT
+3 QUIT IBX
+4 ;
BILLPNS(IBIFN) ; Trigger Code that sets all Bill P/S/T Prov# and QUAL (399: .122,123,124,128,129,130)
+1 ; on Bill Form Type (399:.19)
+2 NEW IBDR
+3 ;
+4 IF +$GET(^DGCR(399,+$GET(IBIFN),"I1"))
SET IBDR(399,IBIFN_",",122)=$$PRVNUM(IBIFN,"",1)
SET IBDR(399,IBIFN_",",128)=$$PRVQUAL(IBIFN,"",1)
+5 IF +$GET(^DGCR(399,+$GET(IBIFN),"I2"))
SET IBDR(399,IBIFN_",",123)=$$PRVNUM(IBIFN,"",2)
SET IBDR(399,IBIFN_",",129)=$$PRVQUAL(IBIFN,"",2)
+6 IF +$GET(^DGCR(399,+$GET(IBIFN),"I3"))
SET IBDR(399,IBIFN_",",124)=$$PRVNUM(IBIFN,"",3)
SET IBDR(399,IBIFN_",",130)=$$PRVQUAL(IBIFN,"",3)
+7 ;
+8 IF $ORDER(IBDR(0))
DO FILE^DIE("","IBDR")
+9 QUIT
+10 ;
PRVQUAL(IBIFN,IBINS,COB) ; Trigger code for Bill P/S/T Prov QUAL (399:128,129,130)
+1 ; on P/S/T Carrier (399: 101,102,103)
+2 ; returns the Provider ID QUALIFIER
+3 ;
+4 ; Input IBIFN - bill ifn
+5 ; IBINS - insurance company ifn (opt)
+6 ; COB - 1 for primary, 2 for secondary, 3 for tertiary
+7 ;
+8 NEW IBX,IBB0,IBBF,IBFT,Z,Z0
+9 if '$GET(COB)
SET COB=1
+10 SET IBX=$PIECE($GET(^DGCR(399,+$GET(IBIFN),"M1")),U,COB+9)
SET IBB0=$GET(^DGCR(399,+$GET(IBIFN),0))
+11 IF $GET(IBINS)=""
SET IBINS=+$GET(^DGCR(399,+$GET(IBIFN),"I"_COB))
+12 if 'IBINS
GOTO PRVQUALQ
+13 ;
+14 ; If an MRA is being processed into an MRA secondary claim and the
+15 ; billing provider qualifier already exists, then leave it alone
+16 IF $GET(IBPRCOB)
IF IBX'=""
GOTO PRVQUALQ
+17 ;
+18 ; PATCH 432 ENH5: The IB system shall no longer add a default Billing Provider Secondary ID to a claim.
+19 ;I +$G(IBIFN),COB N DA S DA=IBIFN I $$MCRACK^IBCBB3(+IBIFN,$P($G(^DGCR(399,+IBIFN,"TX")),U,5),+COB) S IBX=$$FIND1^DIC(355.97,,"MX","MEDICARE PART A") G PRVQUALQ
+20 ;
+21 ; Some Insurances require certain electronic plan types to have no secondary ID
+22 ; If this is the case, there is no qualifier
+23 NEW NOSEC
SET NOSEC=0
+24 IF $DATA(^DIC(36,IBINS,13))
IF $GET(IBIFN)
Begin DoDot:1
+25 NEW PLAN,PLANTYPE
+26 SET PLAN=$PIECE($GET(^DGCR(399,IBIFN,"I"_COB)),U,18)
if 'PLAN
QUIT
+27 SET PLANTYPE=$PIECE($GET(^IBA(355.3,PLAN,0)),U,15)
if 'PLANTYPE
QUIT
+28 if '$DATA(^DIC(36,IBINS,13,"B",PLANTYPE))
QUIT
+29 SET NOSEC=1
SET IBX=""
End DoDot:1
+30 IF NOSEC
GOTO PRVQUALQ
+31 ;
+32 ; Leave qualifer blank if sending REND/ATT ID
+33 IF $$FT^IBCEF(IBIFN)=2
IF $$GET1^DIQ(36,IBINS,4.06,"I")
GOTO PRVQUALQ
+34 IF $$FT^IBCEF(IBIFN)=3
IF $$GET1^DIQ(36,IBINS,4.08,"I")
GOTO PRVQUALQ
+35 ;JWS;IB*2.0*592;Dental form 7
+36 ;IA# 2056
+37 IF $$FT^IBCEF(IBIFN)=7
IF $$GET1^DIQ(36,IBINS,4.06,"I")
GOTO PRVQUALQ
+38 ;
+39 SET IBX=$$FACNUM^IBCEP2B(IBIFN,COB,1)
+40 ;
+41 IF IBX=""
IF $$GET1^DIQ(350.9,1,1.05)=$PIECE($GET(^DGCR(399,IBIFN,"M1")),U,COB+1)
SET IBX=$$FIND1^DIC(355.97,,"MX","1J")
+42 ;
PRVQUALQ QUIT IBX
+1 ;
ACIDS(IBIFN,COB,ENTRY) ; Administrative Contractor IDS
+1 ; This is called as a screen from fields 140, 142, and 144 in the BILL/CLAIMS file #399
+2 ; It should only allow types that have previously been defined for this insurance company and
+3 ; are allowed for this form type.
+4 ;
+5 ; Input IBIFN - bill ifn
+6 ; COB - 1 for primary, 2 for secondary, 3 for tertiary
+7 ; ENTRY - IEN # to the pointed to file corresponding to what the user entered.
+8 ;
+9 ; Output 1 or 0, yay or nay, good or evil, jedi or sith ...
+10 ;
+11 ; overkill, but why not
+12 if '$GET(ENTRY)
QUIT 0
+13 if '$GET(COB)
QUIT 0
+14 if '$DATA(IBIFN)
QUIT 0
+15 ;
+16 NEW IBINSDAT,IBINSCO,IBPLAN,IBPLTYPE,IBPLDAT,IBSPSF,IBINST,IBINSSF
+17 ;
+18 ; get insurance company data from bill
+19 SET IBINSDAT=$GET(^DGCR(399,IBIFN,"I"_COB))
+20 ; no insurance company
if 'IBINSDAT
QUIT 0
+21 SET IBINSCO=+IBINSDAT
+22 ;
+23 ; get the plan
+24 SET IBPLAN=$PIECE(IBINSDAT,U,18)
+25 ; no plan
if 'IBPLAN
QUIT 0
+26 ;
+27 ; get the pland data
+28 SET IBPLDAT=$GET(^IBA(355.3,IBPLAN,0))
+29 ; no valid plan
if IBPLDAT=""
QUIT 0
+30 ;
+31 ; get the electronic plan type
+32 SET IBPLTYPE=$PIECE(IBPLDAT,U,15)
+33 ; no electronic plan type
if IBPLTYPE=""
QUIT 0
+34 ;
+35 ; at this point, IBPLTYPE="MX" for medicare. anything else is not medicare (considered commercial for the purpose of this exercise).
+36 ; we will next be looking to see if this is set up correctly by looking at the correct subfile in the file 36.
+37 ; subfile 36.015 is for institutional
+38 ; subfile 36.016 is for professional.
+39 ;
+40 ; get the site parameter subfile
+41 SET IBSPSF=$SELECT(IBPLTYPE="MX":81,1:82)
+42 ;
+43 ; get the formtype (Instituional or professional)
+44 ; set IBINST flag=1 if it is institutional.
SET IBINST=$$FT^IBCEF(+IBIFN)=3
+45 ;
+46 ; get the insurance subfile
+47 SET IBINSSF=$SELECT(IBINST:15,1:16)
+48 ;
+49 ; quit if the subfile is not defined
+50 ; none set up for this Insurance Company
if '$PIECE($GET(^DIC(36,IBINSCO,IBINSSF,0)),U,3)
QUIT 0
+51 ;
+52 ; get the values in the correct multiple
+53 NEW TARGET,ERROR
+54 DO GETS^DIQ(36,IBINSCO_",",IBINSSF_"*","I","TARGET","ERROR")
+55 ; nothing set up in the site parameters
if '$DATA(TARGET)
QUIT 0
+56 ;
+57 ; TARGET contains something like this
+58 ; TARGET(36.015,"1,3,",.01,"I")=5
+59 ; TARGET(36.015,"1,3,",.02,"I")="TESTID1"
+60 ; TARGET(36.015,"2,3,",.01,"I")=29
+61 ; TARGET(36.015,"2,3,",.02,"I")="TESTID2"
+62 ;
+63 NEW SUBFILE
+64 SET SUBFILE="36.0"_IBINSSF
+65 ;
+66 ; Now, time to make it more useful.
+67 NEW LOOP1,ADMINCON
+68 SET LOOP1=""
FOR
SET LOOP1=$ORDER(TARGET(SUBFILE,LOOP1))
if LOOP1=""
QUIT
Begin DoDot:1
+69 if '$DATA(^IBE(350.9,1,IBSPSF,"B",+$GET(TARGET(SUBFILE,LOOP1,.01,"I"))))
QUIT
+70 SET ADMINCON(TARGET(SUBFILE,LOOP1,.01,"I"))=""
End DoDot:1
+71 ;
+72 ; which leaves us with an array like
+73 ; ADMINCON(IEN1)=""
+74 ; ADMINCON(IEN2)=""
+75 ; of allowable entries.
+76 ;
+77 ; and finally, see if it's allowed.
+78 ; at this point, it needed to be in the site parameter file for use with this form type (institutional or professional)
+79 ; and it needed to be in the insurance company file for this type of plan (medicare or commercial)
+80 QUIT $SELECT($DATA(ADMINCON(+ENTRY)):1,1:0)
+81 ;
ACIDD(IBIFN,COB,ENTRY) ; Administrative Contractor ID Default
+1 ; This will default the ID based on the valid type entered.
+2 ; It is called from a trigger on fields 140, 142, and 144 in the BILL/CLAIMS file #399
+3 ; and triggers fields 141, 143, and 145
+4 ;
+5 ; Input IBIFN - bill ien
+6 ; COB - 1 for primary, 2 for secondary, 3 for tertiary
+7 ; ENTRY - value of triggering field
+8 ;
+9 ; Output Default ID for that Insurance Company or nothing at all
+10 ;
+11 ; overkill, but why not
+12 if $GET(ENTRY)=""
QUIT ""
+13 if '$GET(COB)
QUIT ""
+14 if '$GET(IBIFN)
QUIT ""
+15 ;
+16 NEW IBINST,IBINSDAT,IBINSSF,IBACID,IBSFIEN,IBINSCO
+17 ;
+18 ; get the form type (institutional or professional)
+19 ; set IBINST flag=1 if it is institutional.
SET IBINST=$$FT^IBCEF(+IBIFN)=3
+20 ;
+21 ; get insurance company data from bill
+22 SET IBINSDAT=$GET(^DGCR(399,IBIFN,"I"_COB))
+23 ; no insurance company
if 'IBINSDAT
QUIT ""
+24 SET IBINSCO=+IBINSDAT
+25 ;
+26 ; get the insurance subfile based on institutional or professional
+27 SET IBINSSF=$SELECT(IBINST:15,1:16)
+28 ;
+29 ; quit if the subfile is not defined
+30 ; none set up for this Insurance Company
if '$PIECE($GET(^DIC(36,IBINSCO,IBINSSF,0)),U,4)
QUIT ""
+31 ;
+32 ; get the specific entry
+33 SET IBSFIEN=$ORDER(^DIC(36,IBINSCO,IBINSSF,"B",ENTRY,""))
+34 if 'IBSFIEN
QUIT ""
+35 ;
+36 SET IBACID=$PIECE($GET(^DIC(36,IBINSCO,IBINSSF,IBSFIEN,0)),U,2)
+37 ;
+38 QUIT IBACID
