Routine: IBCD3

IBCD3 ;ALB/ARH - AUTOMATED BILLER (ADD NEW BILL - CREATE BILL ENTRY) ;9/5/93

 ;;2.0;INTEGRATED BILLING;**14,55,52,91,106,125,51,148,160,137,210,245,260,405,384,516,522,592**;21-MAR-94;Build 58

 ;;Per VA Directive 6402, this routine should not be modified.

 ;Called by IBCD2,IBACUS2

EN(IBQUERY) ;

 N IBI,IBX,IBY,I,X,X1,X2,IBAC,IBCPY K IBDR,IBDR222 S IBAC=1

 S X=$P($T(WHERE),";;",2),X2=$P($T(WHERE+1),";;",2) F I=0:0 S I=$O(IB(I)) Q:'I  S X1=$P($E(X,$F(X,I)+1,999),";",1) S:X1="" X1=$P($E(X2,$F(X2,I)+1,999),";",1) I $D(IB(I))=1 S $P(IBDR($P(X1,"^",1)),"^",$P(X1,"^",2))=IB(I)

 F I=0,"C","M","M1","S","U","U1","U2" I $D(IBDR(I)) S ^DGCR(399,IBIFN,I)=IBDR(I)

 S $P(^DGCR(399,0),"^",3)=IBIFN,$P(^(0),"^",4)=$P(^(0),"^",4)+1

 S DIK="^DGCR(399,",DA=IBIFN D IX1^DIK K DA,DIK ; set cross-references

 ; Set the attending/rendering provider into provider multiple

 I $G(IB("PRV",.01))'="" D

 . S DIC("DR")="",I=.01

 . N IBV

 . ; Only file if the provider has an NPI.  otherwise it's not billable and would have to be removed from the claim later

 . I $$GETNPI^IBCEF73A($G(IB("PRV",.02)))]"" F  S I=$O(IB("PRV",I)) Q:'I  D

 .. I IB("PRV",I)="" Q

 .. S IBV(I)=IB("PRV",I),DIC("DR")=DIC("DR")_$S(DIC("DR")="":"",1:";")_I_"////^S X=IBV("_I_")"

 . S DIC="^DGCR(399,"_IBIFN_",""PRV"",",DIC(0)="L",DLAYGO=399,DA(1)=IBIFN,X=IB("PRV",.01)

 . K DO,DD D FILE^DICN K DO,DD,DLAYGO,DA,DIC

 ; Set the occurrence span codes for leave/pass days

 I $O(IB("OC",0)) D

 . N I,I1

 . S I1=0 F  S I1=$O(IB("OC",I1)) Q:'I1  D

 .. S I=0,DIC("DR")=""

 .. F  S I=$O(IB("OC",I1,I)) Q:'I  S DIC("DR")=DIC("DR")_$S(DIC("DR")="":"",1:";")_I_"////"_IB("OC",I1,I)

 .. S DIC="^DGCR(399,"_IBIFN_",""OC"",",DIC(0)="L",DLAYGO=399,DA(1)=IBIFN,DIC("P")=$$GETSPEC^IBEFUNC(399,41),X=IB("OC")

 .. K DO,DD D FILE^DICN K DO,DD,DLAYGO,DA,DIC

 ; file rx refills, default CPT and Dx if defined

 I $D(IB(362.4))>2 D  G END

 . N IBZ

 . S IBRX=0 F  S IBRX=$O(IB(362.4,IBRX)) Q:'IBRX  S IBY="" F  S IBY=$O(IB(362.4,IBRX,IBY)) Q:IBY=""  D

 .. S IBX=IB(362.4,IBRX,IBY) Q:IBX=""

 .. S IBZ=$$ADD^IBCSC5A($P(IBX,U),IBIFN,$P(IBX,U,4),$P(IBX,U,2),+IBRX,$P(IBX,U,3)_U_$P(IBX,U,5)_U_$P(IBX,U,6),IBY)

 ;file outpatient visit dates and find/store outpatient procedures and dx

 ;NOTE: If IBQUERY is defined at this point, it will be used to perform

 ;       the scan for outpatient procedures

 I '$$INPAT^IBCEF(IBIFN) D  G END

 . I $D(IB(43))>2 D

 .. S ^DGCR(399,IBIFN,"OP",0)="^399.043DA^" S IBX=0 F  S IBX=$O(IB(43,IBX)) Q:'IBX  D

 ... S DIC="^DGCR(399,"_IBIFN_",""OP"",",DIC(0)="L",DA(1)=IBIFN,(DINUM,X)=IBX,DLAYGO=399.043 K DD,DO D FILE^DICN K DIC,DA,DINUM,DO,DD,DLAYGO

. ;

 . D VST^IBCCPT(.IBQUERY) I $D(^UTILITY($J,"CPT-CNT")) D

 .. ;JWS;IB*2.0*592;new of IBUSED

 .. N IBPRX,IBUSED

 .. S DIC("P")=$$GETSPEC^IBEFUNC(399,304)

 .. S IBY=0 F  S IBY=$O(^UTILITY($J,"CPT-CNT",IBY)) Q:'IBY  S IBX=^(IBY) I '$P(IBX,U,6) D

 ... ;JWS;IB*2.0*592; added New command for var needed for link to DSS DRM data

 ... N IBPOS,IBTON,IBSURF,IBTSTAT,IBTNUM,IBPSCDS,IBDENHD

 ... S IBPRX(+$P(IBX,U,8))=""

 ... S DIC="^DGCR(399,"_IBIFN_",""CP"",",DIC(0)="L",DA(1)=IBIFN,X=+IBX_";ICPT(",DLAYGO=399 K DD,DO D FILE^DICN K DO,DD,DLAYGO Q:Y'>0

 ... ;

 ... S IBCPY=+Y

 ... ;

 ... ; add dx to 362.3 for associations if they exist

 ... I $G(^UTILITY($J,"CPT-CNT",IBY,"DX")) D ADDDX^IBCCPT1(IBIFN,IBCPY,^("DX"),.IBDR) I $L($G(IBDR)) S IBDR=IBDR_";"

 ... ;

 ... ;JWS;IB*2.0*592;begin;added Dental data from files 228.1 and 228.2; default POS to 22 for Dental, Type of Service to 35 Dental Care

 ... I $$FT^IBCEF(IBIFN)=7 D

 .... N IBDENH0,STOP,IBDENH,IBVST,TARGET0

 .... S IBPOS=$O(^IBE(353.1,"B",22,0)),IBVST=$P($G(IBTRND),"^",3)

 .... ;S IBTOS=$O(^IBE(353.2,"B",35,0)) ;4/25/18

 .... ;IA# 2051, 6870, 6871

 .... ;S IBDENH=$$FIND1^DIC(228.1,,"QX",IBVST,"AV")

 .... D FIND^DIC(228.1,,"IX","QXP",IBVST,,"AV",,,"TARGET0")

 .... I +$G(TARGET0("DILIST",0)) S IBDENH0=0 F  S IBDENH0=$O(TARGET0("DILIST",IBDENH0)) Q:'IBDENH0  D  I $G(STOP) Q

 ..... S IBDENH=$P($G(TARGET0("DILIST",IBDENH0,0)),"^")

 ..... I IBDENH D

 ...... N TARGET,TARGET1,IBDENHD0,IBPSCD0,IBPSC,IBPSCD,IBPSC2 S (IBDENHD0,STOP)=0

 ...... ;IA# 2051, 6870, 6871

 ...... D FIND^DIC(228.2,,"IX","QXP",IBDENH,,"AG",,,"TARGET")

 ...... I +$G(TARGET("DILIST",0)) F  S IBDENHD0=$O(TARGET("DILIST",IBDENHD0)) Q:'IBDENHD0  D  I STOP Q

 ....... S IBDENHD=$P(TARGET("DILIST",IBDENHD0,0),"^")

 ....... ;IA# 2056, 6870, 6871

 ....... S IBPSC=$$GET1^DIQ(228.2,IBDENHD_",",.04)

 ....... ;;S IBPROV=$$GET1^DIQ(228.2,IBDENHD_",",.03,"I")  ;provider linked to dental trans

 ....... I IBPSC'=$$GET1^DIQ(81,$P(IBX,"^")_",",.01) Q

 ....... I $D(^DGCR(399,"ADT",IBDENHD)) Q

 ....... I $D(IBUSED("D",IBDENHD)) Q

 ....... S IBUSED("D",IBDENHD)=""

 ....... ;attempt to pull in the Not Otherwise Classified proc description from the Provider Narrative

 ....... ;IA# 2051

 ....... D FIND^DIC(9000010.18,,"IX","QXP",IBVST,,"AD",,,"TARGET1")

 ....... S IBPSCD0=0,IBPSCDS=""

 ....... ;IA# 2056

 ....... F  S IBPSCD0=$O(TARGET1("DILIST",IBPSCD0)) Q:'IBPSCD0  S IBPSCD=$P(TARGET1("DILIST",IBPSCD0,0),"^") I $$GET1^DIQ(9000010.18,IBPSCD_",",.01)=IBPSC,'$D(IBUSED(IBPSCD)),$$CHECK^IBCCPT(IBPSCD,IBX) D  Q

 ........ S IBUSED(IBPSCD)="",IBPSCDS=$$GET1^DIQ(9000010.18,IBPSCD_",",.04,"E") Q

 ....... S IBPSC2=$$GET1^DIQ(399.0304,IBCPY_","_IBIFN_",",.01,"I") I $$GET1^DIQ(81,$P(IBPSC2,";")_",",.01)'=IBPSC Q

 ....... S STOP=1

 ....... N IBPDT S IBPDT=$$GET1^DIQ(399,IBIFN_",",.03,"I")

 ....... I '$$NOCPROC^IBCU7("^"_IBPSC2,IBPSC,IBPDT) S IBPSCDS=""

 ....... ;IA# 2056, 6870, 6871

 ....... S IBTON=$$GET1^DIQ(228.2,IBDENHD_",",.15)

 ....... S IBSURF=$$GET1^DIQ(228.2,IBDENHD_",",.16)

 ....... S IBTSTAT=$$GET1^DIQ(228.2,IBDENHD_",",.09),IBTSTAT=$S(IBTSTAT="cndMissing":"M",1:"")

 ....... N I1 F I=1:1:5 S X=$E(IBSURF,I) Q:X=""  I $F(",M,B,D,I,O,L,F,",","_X_",") S I1=$G(I1)+1,IBSURF(I1)=X

 ....... Q

 ...... I '$G(STOP) S IBDENHD=""

 ...... Q

 ..... Q

 .... I $P(IBX,U,8) K DA,DR,DIC D

 ..... N IBDATA

 ..... ; Only file if the provider has an NPI.  otherwise it's not billable and would have to be removed from the claim later

 ..... I $$GETNPI^IBCEF73A($P(IBX,U,8)_";VA(200,")="" Q

 ..... S DIC(0)="L",DIC="^DGCR(399,"_IBIFN_",""CP"","_IBCPY_",""LNPRV"",",DLAYGO=399.0404

 ..... S DA(2)=IBIFN,DA(1)=IBCPY,X=3,IBDATA=$P(IBX,U,8)_";VA(200,"

 ..... S DIC("DR")=".02////^S X=IBDATA"

 ..... D FILE^DICN K DIC,DO,DD,DA,DR

 ..... Q

 .... Q

 ... ;JWS;IB*2.0*592;end

 ... S DR=$G(IBDR)_"1////"_$P(IBX,U,2)_$S(+$P(IBX,U,8):";18////"_+$P(IBX,U,8),1:"") K IBDR

 ... S DR=DR_$S(+$P(IBX,U,9):";6////"_+$P(IBX,U,9),1:"")_$S(+$P(IBX,U,5):";5////"_+$P(IBX,U,5),1:"")

 ... S DR=DR_$S(+$P(IBX,U,11):";20////"_+$P(IBX,U,11),1:"")

 ... ;JWS;IB*2.0*592;add place of service default and NOC Procedure Description

 ... S DR=DR_$S($G(IBPOS):";8////"_$G(IBPOS),1:"")

 ... ;S DR=DR_$S($G(IBTOS):";9////"_$G(IBTOS),1:"")  ;4/25/18

 ... I $G(IBPSCDS)'="" S DR=DR_";51////"_IBPSCDS

 ... S DA(1)=IBIFN,DIE="^DGCR(399,"_IBIFN_",""CP"",",DA=+IBCPY D ^DIE K DIE,DIC,DA,DINUM,DO,DD,DR

 ... ;JWS;IB*2.0*592;start;Add tooth # and surfaces to procedure line

 ... ;JWS;IB*2.0*592;allow for tooth # without surface

 ... I $$FT^IBCEF(IBIFN)=7 D

 .... I $G(IBTON)'="" K DA,DR,DIC D

 ..... S DIC(0)="L",DIC="^DGCR(399,"_IBIFN_",""CP"","_IBCPY_",""DEN1"",",DLAYGO=399.30491

 ..... S DA(2)=IBIFN,DA(1)=IBCPY

 ..... S DIC("DR")=".01////"_IBTON_$S($D(IBSURF(1)):";.02////"_$G(IBSURF(1)),1:"")

 ..... S X=IBTON

 ..... I $D(IBSURF(2)) S DIC("DR")=DIC("DR")_";.03////"_IBSURF(2)

 ..... I $D(IBSURF(3)) S DIC("DR")=DIC("DR")_";.04////"_IBSURF(3)

 ..... I $D(IBSURF(4)) S DIC("DR")=DIC("DR")_";.05////"_IBSURF(4)

 ..... I $D(IBSURF(5)) S DIC("DR")=DIC("DR")_";.06////"_IBSURF(5)

 ..... I $G(IBDENHD) S DIC("DR")=DIC("DR")_";.07////"_IBDENHD

 ..... D FILE^DICN K DIC,DO,DD,DA,DR

 ..... Q

 .... I $G(IBTSTAT)'="",$G(IBTON) D

 ..... S DIC="^DGCR(399,"_IBIFN_",""DEN1"",",DIC(0)="L",DA(1)=IBIFN,X=IBTON,DLAYGO=399.096 K DD,DO D FILE^DICN K DO,DD,DLAYGO

 ..... S IBTNUM=+Y

 ..... S DR=".02////"_IBTSTAT

 ..... S DIE=DIC,DA=IBTNUM D ^DIE K DIE,DIC,DA,DINUM,DO,DD,DR

 .... ;JWS;IB*2.0*592;end

 ... I $P(IBX,U,10) D ADDMOD^IBCCPT(IBIFN,IBCPY,$P(IBX,U,10)) ;Modifiers

 .. I $O(IBPRX(""))=$O(IBPRX(""),-1),$O(IBPRX(0)) D

 ... ;If only 1 provider - make it the rendering

 ... S IB("PRV",.02)=+$O(IBPRX(0))_";VA(200,",IB("PRV",.01)=3

 . K DGCNT,V,IBOPV1,IBOPV2,I,DGDIV,I1,DGNOD,DGCPTS,I7,I2,DGCPT,^UTILITY($J,"CPT-CNT")

. ;

 . D OPTDX^IBCSC4D(DFN,IB(151),IB(152),.IBDX) I +IBDX D  K IBDX

 .. S IBY=0 F  S IBY=$O(IBDX(IBY)) Q:IBY=""  S IBX=IBDX(IBY) I '$P(IBX,U,5) D

 ... I '$D(^DGCR(399,"AOPV",DFN,(+$P(IBX,U,4)\1),IBIFN)) Q

 ... S DIC("DR")=".02////"_IBIFN,DIC="^IBA(362.3,",DIC(0)="L",X=+IBX,DLAYGO=362.3 K DD,DO D FILE^DICN

 ... K DIE,DIC,DA,DLAYGO,DO,DD

 ;store inpatient diagnosis and procedures, default admit dx to first dx found

 I $$INPAT^IBCEF(IBIFN) D  G END

 . I $G(^TMP("IBDX",$J))=IB(.08) D  K ^TMP("IBDX",$J)

 .. N IBXDEF S IBXDEF=0

 .. S (IBI,IBX)="" F  S IBX=$O(^TMP("IBDX",$J,IBX)) Q:'IBX  S IBY=0 F  S IBY=$O(^TMP("IBDX",$J,IBX,IBY)) Q:'IBY  D

 ... S IBZ=^TMP("IBDX",$J,IBX,IBY) Q:($$ICD9^IBACSV(+IBZ)="")  S IBI=IBI+1

 ... S DIC("DR")=".02////"_IBIFN_";.03////"_IBI I $P(IBZ,U,3)'="" S DIC("DR")=DIC("DR")_";.04///"_$P(IBZ,U,3)

 ... S DIC="^IBA(362.3,",DIC(0)="L",X=+IBZ,DLAYGO=362.3 K DD,DO D FILE^DICN K DIE,DIC,DA,DLAYGO,DO,DD

 ... I Y>0,'IBXDEF S IBXDEF=1,DR="215////"_+IBZ,DIE="^DGCR(399,",DA=IBIFN D ^DIE

. ;

 . D PTFPRDT^IBCSC4A(+IB(.08),IB(151),IB(152),9) I $D(^UTILITY($J,"IB")) D  K ^UTILITY($J,"IB")

 .. S ^DGCR(399,IBIFN,"CP",0)="^399.0304AVI^"

 .. S IBX=0 F  S IBX=$O(^UTILITY($J,"IB",IBX)) Q:'IBX  S IBY=0 F  S IBY=$O(^UTILITY($J,"IB",IBX,IBY)) Q:'IBY  D

 ... S IBZ=^UTILITY($J,"IB",IBX,IBY) Q:($$ICD0^IBACSV(+IBZ)="")  S IBI=$P(^UTILITY($J,"IB",IBX,1),U,2)

 ... S DIC="^DGCR(399,"_IBIFN_",""CP"",",DIC(0)="L",DA(1)=IBIFN,X=+IBZ_";ICD0(",DLAYGO=399.0304 K DD,DO D FILE^DICN

 ... I Y>0 S DIE=DIC,DA=+Y,DR="1////"_(IBI\1) D ^DIE K DIE,DIC,DA,DLAYGO,DO,DD

END S IBX="1^Billing Record #"_$P(^DGCR(399,+IBIFN,0),"^",1)_" established for "_$P($G(^DPT(IBDFN,0)),U,1)

 S IBAUTO=1,DGPTUPDT="" I '$G(IBCHTRN) D PROC^IBCU7A(IBIFN) D ^IBCU6 ; auto calculate/store revenue codes

Q K %,%DT,IBDR,X1,X2,X3,X4,Y,DGDIRA,DGDIRB,DGDIR0,DIR,DGRVRCAL,DIC,DA,DR,DINUM,DGPTUPDT,DGXRF1,IBCHK,IBINDT,IBIDS,DLAYGO

WHERE ;;.01^0^1;.02^0^2;.03^0^3;.04^0^4;.05^0^5;.06^0^6;.07^0^7;.08^0^8;.09^0^9;.11^0^11;.17^0^17;.16^0^16;.18^0^18;.19^0^19;.2^0^20;.22^0^22;.27^0^27;112^M^12;151^U^1;152^U^2;155^U^5;157^U^7;101^M^1;158^U^8;159^U^9;160^U^10;161^U^11;162^U^12;

 ;;217^U2^3;221^U2^7;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCD3   10768     printed  Mar 13, 2025@21:14:04                                                                                                                                                                                                      Page 2

IBCD3     ;ALB/ARH - AUTOMATED BILLER (ADD NEW BILL - CREATE BILL ENTRY) ;9/5/93

 +1       ;;2.0;INTEGRATED BILLING;**14,55,52,91,106,125,51,148,160,137,210,245,260,405,384,516,522,592**;21-MAR-94;Build 58

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3       ;

 +4       ;Called by IBCD2,IBACUS2

 +5       ;

EN(IBQUERY) ;

 +1        NEW IBI,IBX,IBY,I,X,X1,X2,IBAC,IBCPY

           KILL IBDR,IBDR222

           SET IBAC=1

 +2        SET X=$PIECE($TEXT(WHERE),";;",2)

           SET X2=$PIECE($TEXT(WHERE+1),";;",2)

           FOR I=0:0

               SET I=$ORDER(IB(I))

               if 'I

                   QUIT

               SET X1=$PIECE($EXTRACT(X,$FIND(X,I)+1,999),";",1)

               if X1=""

                   SET X1=$PIECE($EXTRACT(X2,$FIND(X2,I)+1,999),";",1)

               IF $DATA(IB(I))=1

                   SET $PIECE(IBDR($PIECE(X1,"^",1)),"^",$PIECE(X1,"^",2))=IB(I)

 +3        FOR I=0,"C","M","M1","S","U","U1","U2"

               IF $DATA(IBDR(I))

                   SET ^DGCR(399,IBIFN,I)=IBDR(I)

 +4        SET $PIECE(^DGCR(399,0),"^",3)=IBIFN

           SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)+1

 +5       ; set cross-references

           SET DIK="^DGCR(399,"

           SET DA=IBIFN

           DO IX1^DIK

           KILL DA,DIK

 +6       ;

 +7       ; Set the attending/rendering provider into provider multiple

 +8        IF $GET(IB("PRV",.01))'=""

               Begin DoDot:1

 +9                SET DIC("DR")=""

                   SET I=.01

 +10               NEW IBV

 +11      ; Only file if the provider has an NPI.  otherwise it's not billable and would have to be removed from the claim later

 +12               IF $$GETNPI^IBCEF73A($GET(IB("PRV",.02)))]""

FOR

                           SET I=$ORDER(IB("PRV",I))

                           if 'I

                               QUIT

                           Begin DoDot:2

 +13                           IF IB("PRV",I)=""

                                   QUIT

 +14                           SET IBV(I)=IB("PRV",I)

                               SET DIC("DR")=DIC("DR")_$SELECT(DIC("DR")="":"",1:";")_I_"////^S X=IBV("_I_")"

                           End DoDot:2

 +15               SET DIC="^DGCR(399,"_IBIFN_",""PRV"","

                   SET DIC(0)="L"

                   SET DLAYGO=399

                   SET DA(1)=IBIFN

                   SET X=IB("PRV",.01)

 +16               KILL DO,DD

                   DO FILE^DICN

                   KILL DO,DD,DLAYGO,DA,DIC

               End DoDot:1

 +17      ;

 +18      ; Set the occurrence span codes for leave/pass days

 +19       IF $ORDER(IB("OC",0))

               Begin DoDot:1

 +20               NEW I,I1

 +21               SET I1=0

FOR

                       SET I1=$ORDER(IB("OC",I1))

                       if 'I1

                           QUIT

                       Begin DoDot:2

 +22                       SET I=0

                           SET DIC("DR")=""

 +23                       FOR

                               SET I=$ORDER(IB("OC",I1,I))

                               if 'I

                                   QUIT

                               SET DIC("DR")=DIC("DR")_$SELECT(DIC("DR")="":"",1:";")_I_"////"_IB("OC",I1,I)

 +24                       SET DIC="^DGCR(399,"_IBIFN_",""OC"","

                           SET DIC(0)="L"

                           SET DLAYGO=399

                           SET DA(1)=IBIFN

                           SET DIC("P")=$$GETSPEC^IBEFUNC(399,41)

                           SET X=IB("OC")

 +25                       KILL DO,DD

                           DO FILE^DICN

                           KILL DO,DD,DLAYGO,DA,DIC

                       End DoDot:2

               End DoDot:1

 +26      ;

 +27      ; file rx refills, default CPT and Dx if defined

 +28       IF $DATA(IB(362.4))>2

               Begin DoDot:1

 +29               NEW IBZ

 +30               SET IBRX=0

FOR

                       SET IBRX=$ORDER(IB(362.4,IBRX))

                       if 'IBRX

                           QUIT

                       SET IBY=""

FOR

                           SET IBY=$ORDER(IB(362.4,IBRX,IBY))

                           if IBY=""

                               QUIT

                           Begin DoDot:2

 +31                           SET IBX=IB(362.4,IBRX,IBY)

                               if IBX=""

                                   QUIT

 +32                           SET IBZ=$$ADD^IBCSC5A($PIECE(IBX,U),IBIFN,$PIECE(IBX,U,4),$PIECE(IBX,U,2),+IBRX,$PIECE(IBX,U,3)_U_$PIECE(IBX,U,5)_U_$PIECE(IBX,U,6),IBY)

                           End DoDot:2

               End DoDot:1

               GOTO END

 +33      ;

 +34      ;file outpatient visit dates and find/store outpatient procedures and dx

 +35      ;NOTE: If IBQUERY is defined at this point, it will be used to perform

 +36      ;       the scan for outpatient procedures

 +37       IF '$$INPAT^IBCEF(IBIFN)

               Begin DoDot:1

 +38               IF $DATA(IB(43))>2

                       Begin DoDot:2

 +39                       SET ^DGCR(399,IBIFN,"OP",0)="^399.043DA^"

                           SET IBX=0

FOR

                               SET IBX=$ORDER(IB(43,IBX))

                               if 'IBX

                                   QUIT

                               Begin DoDot:3

 +40                               SET DIC="^DGCR(399,"_IBIFN_",""OP"","

                                   SET DIC(0)="L"

                                   SET DA(1)=IBIFN

                                   SET (DINUM,X)=IBX

                                   SET DLAYGO=399.043

                                   KILL DD,DO

                                   DO FILE^DICN

                                   KILL DIC,DA,DINUM,DO,DD,DLAYGO

                               End DoDot:3

                       End DoDot:2

 +41      ;

 +42               DO VST^IBCCPT(.IBQUERY)

                   IF $DATA(^UTILITY($JOB,"CPT-CNT"))

                       Begin DoDot:2

 +43      ;JWS;IB*2.0*592;new of IBUSED

 +44                       NEW IBPRX,IBUSED

 +45                       SET DIC("P")=$$GETSPEC^IBEFUNC(399,304)

 +46                       SET IBY=0

FOR

                               SET IBY=$ORDER(^UTILITY($JOB,"CPT-CNT",IBY))

                               if 'IBY

                                   QUIT

                               SET IBX=^(IBY)

                               IF '$PIECE(IBX,U,6)

                                   Begin DoDot:3

 +47      ;JWS;IB*2.0*592; added New command for var needed for link to DSS DRM data

 +48                                   NEW IBPOS,IBTON,IBSURF,IBTSTAT,IBTNUM,IBPSCDS,IBDENHD

 +49                                   SET IBPRX(+$PIECE(IBX,U,8))=""

 +50                                   SET DIC="^DGCR(399,"_IBIFN_",""CP"","

                                       SET DIC(0)="L"

                                       SET DA(1)=IBIFN

                                       SET X=+IBX_";ICPT("

                                       SET DLAYGO=399

                                       KILL DD,DO

                                       DO FILE^DICN

                                       KILL DO,DD,DLAYGO

                                       if Y'>0

                                           QUIT

 +51      ;

 +52                                   SET IBCPY=+Y

 +53      ;

 +54      ; add dx to 362.3 for associations if they exist

 +55                                   IF $GET(^UTILITY($JOB,"CPT-CNT",IBY,"DX"))

                                           DO ADDDX^IBCCPT1(IBIFN,IBCPY,^("DX"),.IBDR)

                                           IF $LENGTH($GET(IBDR))

                                               SET IBDR=IBDR_";"

 +56      ;

 +57      ;JWS;IB*2.0*592;begin;added Dental data from files 228.1 and 228.2; default POS to 22 for Dental, Type of Service to 35 Dental Care

 +58                                   IF $$FT^IBCEF(IBIFN)=7

                                           Begin DoDot:4

 +59                                           NEW IBDENH0,STOP,IBDENH,IBVST,TARGET0

 +60                                           SET IBPOS=$ORDER(^IBE(353.1,"B",22,0))

                                               SET IBVST=$PIECE($GET(IBTRND),"^",3)

 +61      ;S IBTOS=$O(^IBE(353.2,"B",35,0)) ;4/25/18

 +62      ;IA# 2051, 6870, 6871

 +63      ;S IBDENH=$$FIND1^DIC(228.1,,"QX",IBVST,"AV")

 +64                                           DO FIND^DIC(228.1,,"IX","QXP",IBVST,,"AV",,,"TARGET0")

 +65                                           IF +$GET(TARGET0("DILIST",0))

                                                   SET IBDENH0=0

FOR

                                                       SET IBDENH0=$ORDER(TARGET0("DILIST",IBDENH0))

                                                       if 'IBDENH0

                                                           QUIT

                                                       Begin DoDot:5

 +66                                                       SET IBDENH=$PIECE($GET(TARGET0("DILIST",IBDENH0,0)),"^")

 +67                                                       IF IBDENH

                                                               Begin DoDot:6

 +68                                                               NEW TARGET,TARGET1,IBDENHD0,IBPSCD0,IBPSC,IBPSCD,IBPSC2

                                                                   SET (IBDENHD0,STOP)=0

 +69      ;IA# 2051, 6870, 6871

 +70                                                               DO FIND^DIC(228.2,,"IX","QXP",IBDENH,,"AG",,,"TARGET")

 +71                                                               IF +$GET(TARGET("DILIST",0))

FOR

                                                                           SET IBDENHD0=$ORDER(TARGET("DILIST",IBDENHD0))

                                                                           if 'IBDENHD0

                                                                               QUIT

                                                                           Begin DoDot:7

 +72                                                                           SET IBDENHD=$PIECE(TARGET("DILIST",IBDENHD0,0),"^")

 +73      ;IA# 2056, 6870, 6871

 +74                                                                           SET IBPSC=$$GET1^DIQ(228.2,IBDENHD_",",.04)

 +75      ;;S IBPROV=$$GET1^DIQ(228.2,IBDENHD_",",.03,"I")  ;provider linked to dental trans

 +76                                                                           IF IBPSC'=$$GET1^DIQ(81,$PIECE(IBX,"^")_",",.01)

                                                                                   QUIT

 +77                                                                           IF $DATA(^DGCR(399,"ADT",IBDENHD))

                                                                                   QUIT

 +78                                                                           IF $DATA(IBUSED("D",IBDENHD))

                                                                                   QUIT

 +79                                                                           SET IBUSED("D",IBDENHD)=""

 +80      ;attempt to pull in the Not Otherwise Classified proc description from the Provider Narrative

 +81      ;IA# 2051

 +82                                                                           DO FIND^DIC(9000010.18,,"IX","QXP",IBVST,,"AD",,,"TARGET1")

 +83                                                                           SET IBPSCD0=0

                                                                               SET IBPSCDS=""

 +84      ;IA# 2056

 +85                                                                           FOR

                                                                                   SET IBPSCD0=$ORDER(TARGET1("DILIST",IBPSCD0))

                                                                                   if 'IBPSCD0

                                                                                       QUIT

                                                                                   SET IBPSCD=$PIECE(TARGET1("DILIST",IBPSCD0,0),"^")

                                                                                   IF $$GET1^DIQ(9000010.18,IBPSCD_",",.01)=IBPSC

                                                                                       IF '$DATA(IBUSED(IBPSCD))

                                                                                           IF $$CHECK^IBCCPT(IBPSCD,IBX)

                                                                                               Begin DoDot:8

 +86                                                                                               SET IBUSED(IBPSCD)=""

                                                                                                   SET IBPSCDS=$$GET1^DIQ(9000010.18,IBPSCD_",",.04,"E")

                                                                                                   QUIT

                                                                                               End DoDot:8

                                                                                               QUIT

 +87                                                                           SET IBPSC2=$$GET1^DIQ(399.0304,IBCPY_","_IBIFN_",",.01,"I")

                                                                               IF $$GET1^DIQ(81,$PIECE(IBPSC2,";")_",",.01)'=IBPSC

                                                                                   QUIT

 +88                                                                           SET STOP=1

 +89                                                                           NEW IBPDT

                                                                               SET IBPDT=$$GET1^DIQ(399,IBIFN_",",.03,"I")

 +90                                                                           IF '$$NOCPROC^IBCU7("^"_IBPSC2,IBPSC,IBPDT)

                                                                                   SET IBPSCDS=""

 +91      ;IA# 2056, 6870, 6871

 +92                                                                           SET IBTON=$$GET1^DIQ(228.2,IBDENHD_",",.15)

 +93                                                                           SET IBSURF=$$GET1^DIQ(228.2,IBDENHD_",",.16)

 +94                                                                           SET IBTSTAT=$$GET1^DIQ(228.2,IBDENHD_",",.09)

                                                                               SET IBTSTAT=$SELECT(IBTSTAT="cndMissing":"M",1:"")

 +95                                                                           NEW I1

                                                                               FOR I=1:1:5

                                                                                   SET X=$EXTRACT(IBSURF,I)

                                                                                   if X=""

                                                                                       QUIT

                                                                                   IF $FIND(",M,B,D,I,O,L,F,",","_X_",")

                                                                                       SET I1=$GET(I1)+1

                                                                                       SET IBSURF(I1)=X

 +96                                                                           QUIT

                                                                           End DoDot:7

                                                                           IF STOP

                                                                               QUIT

 +97                                                               IF '$GET(STOP)

                                                                       SET IBDENHD=""

 +98                                                               QUIT

                                                               End DoDot:6

 +99                                                       QUIT

                                                       End DoDot:5

                                                       IF $GET(STOP)

                                                           QUIT

 +100                                          IF $PIECE(IBX,U,8)

                                                   KILL DA,DR,DIC

                                                   Begin DoDot:5

 +101                                                  NEW IBDATA

 +102     ; Only file if the provider has an NPI.  otherwise it's not billable and would have to be removed from the claim later

 +103                                                  IF $$GETNPI^IBCEF73A($PIECE(IBX,U,8)_";VA(200,")=""

                                                           QUIT

 +104                                                  SET DIC(0)="L"

                                                       SET DIC="^DGCR(399,"_IBIFN_",""CP"","_IBCPY_",""LNPRV"","

                                                       SET DLAYGO=399.0404

 +105                                                  SET DA(2)=IBIFN

                                                       SET DA(1)=IBCPY

                                                       SET X=3

                                                       SET IBDATA=$PIECE(IBX,U,8)_";VA(200,"

 +106                                                  SET DIC("DR")=".02////^S X=IBDATA"

 +107                                                  DO FILE^DICN

                                                       KILL DIC,DO,DD,DA,DR

 +108                                                  QUIT

                                                   End DoDot:5

 +109                                          QUIT

                                           End DoDot:4

 +110     ;JWS;IB*2.0*592;end

 +111                                  SET DR=$GET(IBDR)_"1////"_$PIECE(IBX,U,2)_$SELECT(+$PIECE(IBX,U,8):";18////"_+$PIECE(IBX,U,8),1:"")

                                       KILL IBDR

 +112                                  SET DR=DR_$SELECT(+$PIECE(IBX,U,9):";6////"_+$PIECE(IBX,U,9),1:"")_$SELECT(+$PIECE(IBX,U,5):";5////"_+$PIECE(IBX,U,5),1:"")

 +113                                  SET DR=DR_$SELECT(+$PIECE(IBX,U,11):";20////"_+$PIECE(IBX,U,11),1:"")

 +114     ;JWS;IB*2.0*592;add place of service default and NOC Procedure Description

 +115                                  SET DR=DR_$SELECT($GET(IBPOS):";8////"_$GET(IBPOS),1:"")

 +116     ;S DR=DR_$S($G(IBTOS):";9////"_$G(IBTOS),1:"")  ;4/25/18

 +117                                  IF $GET(IBPSCDS)'=""

                                           SET DR=DR_";51////"_IBPSCDS

 +118                                  SET DA(1)=IBIFN

                                       SET DIE="^DGCR(399,"_IBIFN_",""CP"","

                                       SET DA=+IBCPY

                                       DO ^DIE

                                       KILL DIE,DIC,DA,DINUM,DO,DD,DR

 +119     ;JWS;IB*2.0*592;start;Add tooth # and surfaces to procedure line

 +120     ;JWS;IB*2.0*592;allow for tooth # without surface

 +121                                  IF $$FT^IBCEF(IBIFN)=7

                                           Begin DoDot:4

 +122                                          IF $GET(IBTON)'=""

                                                   KILL DA,DR,DIC

                                                   Begin DoDot:5

 +123                                                  SET DIC(0)="L"

                                                       SET DIC="^DGCR(399,"_IBIFN_",""CP"","_IBCPY_",""DEN1"","

                                                       SET DLAYGO=399.30491

 +124                                                  SET DA(2)=IBIFN

                                                       SET DA(1)=IBCPY

 +125                                                  SET DIC("DR")=".01////"_IBTON_$SELECT($DATA(IBSURF(1)):";.02////"_$GET(IBSURF(1)),1:"")

 +126                                                  SET X=IBTON

 +127                                                  IF $DATA(IBSURF(2))

                                                           SET DIC("DR")=DIC("DR")_";.03////"_IBSURF(2)

 +128                                                  IF $DATA(IBSURF(3))

                                                           SET DIC("DR")=DIC("DR")_";.04////"_IBSURF(3)

 +129                                                  IF $DATA(IBSURF(4))

                                                           SET DIC("DR")=DIC("DR")_";.05////"_IBSURF(4)

 +130                                                  IF $DATA(IBSURF(5))

                                                           SET DIC("DR")=DIC("DR")_";.06////"_IBSURF(5)

 +131                                                  IF $GET(IBDENHD)

                                                           SET DIC("DR")=DIC("DR")_";.07////"_IBDENHD

 +132                                                  DO FILE^DICN

                                                       KILL DIC,DO,DD,DA,DR

 +133                                                  QUIT

                                                   End DoDot:5

 +134                                          IF $GET(IBTSTAT)'=""

                                                   IF $GET(IBTON)

                                                       Begin DoDot:5

 +135                                                      SET DIC="^DGCR(399,"_IBIFN_",""DEN1"","

                                                           SET DIC(0)="L"

                                                           SET DA(1)=IBIFN

                                                           SET X=IBTON

                                                           SET DLAYGO=399.096

                                                           KILL DD,DO

                                                           DO FILE^DICN

                                                           KILL DO,DD,DLAYGO

 +136                                                      SET IBTNUM=+Y

 +137                                                      SET DR=".02////"_IBTSTAT

 +138                                                      SET DIE=DIC

                                                           SET DA=IBTNUM

                                                           DO ^DIE

                                                           KILL DIE,DIC,DA,DINUM,DO,DD,DR

                                                       End DoDot:5

 +139     ;JWS;IB*2.0*592;end

                                           End DoDot:4

 +140     ;Modifiers

                                       IF $PIECE(IBX,U,10)

                                           DO ADDMOD^IBCCPT(IBIFN,IBCPY,$PIECE(IBX,U,10))

                                   End DoDot:3

 +141                      IF $ORDER(IBPRX(""))=$ORDER(IBPRX(""),-1)

                               IF $ORDER(IBPRX(0))

                                   Begin DoDot:3

 +142     ;If only 1 provider - make it the rendering

 +143                                  SET IB("PRV",.02)=+$ORDER(IBPRX(0))_";VA(200,"

                                       SET IB("PRV",.01)=3

                                   End DoDot:3

                       End DoDot:2

 +144              KILL DGCNT,V,IBOPV1,IBOPV2,I,DGDIV,I1,DGNOD,DGCPTS,I7,I2,DGCPT,^UTILITY($JOB,"CPT-CNT")

 +145     ;

 +146              DO OPTDX^IBCSC4D(DFN,IB(151),IB(152),.IBDX)

                   IF +IBDX

                       Begin DoDot:2

 +147                      SET IBY=0

FOR

                               SET IBY=$ORDER(IBDX(IBY))

                               if IBY=""

                                   QUIT

                               SET IBX=IBDX(IBY)

                               IF '$PIECE(IBX,U,5)

                                   Begin DoDot:3

 +148                                  IF '$DATA(^DGCR(399,"AOPV",DFN,(+$PIECE(IBX,U,4)\1),IBIFN))

                                           QUIT

 +149                                  SET DIC("DR")=".02////"_IBIFN

                                       SET DIC="^IBA(362.3,"

                                       SET DIC(0)="L"

                                       SET X=+IBX

                                       SET DLAYGO=362.3

                                       KILL DD,DO

                                       DO FILE^DICN

 +150                                  KILL DIE,DIC,DA,DLAYGO,DO,DD

                                   End DoDot:3

                       End DoDot:2

                       KILL IBDX

               End DoDot:1

               GOTO END

 +151     ;

 +152     ;store inpatient diagnosis and procedures, default admit dx to first dx found

 +153      IF $$INPAT^IBCEF(IBIFN)

               Begin DoDot:1

 +154              IF $GET(^TMP("IBDX",$JOB))=IB(.08)

                       Begin DoDot:2

 +155                      NEW IBXDEF

                           SET IBXDEF=0

 +156                      SET (IBI,IBX)=""

FOR

                               SET IBX=$ORDER(^TMP("IBDX",$JOB,IBX))

                               if 'IBX

                                   QUIT

                               SET IBY=0

FOR

                                   SET IBY=$ORDER(^TMP("IBDX",$JOB,IBX,IBY))

                                   if 'IBY

                                       QUIT

                                   Begin DoDot:3

 +157                                  SET IBZ=^TMP("IBDX",$JOB,IBX,IBY)

                                       if ($$ICD9^IBACSV(+IBZ)="")

                                           QUIT

                                       SET IBI=IBI+1

 +158                                  SET DIC("DR")=".02////"_IBIFN_";.03////"_IBI

                                       IF $PIECE(IBZ,U,3)'=""

                                           SET DIC("DR")=DIC("DR")_";.04///"_$PIECE(IBZ,U,3)

 +159                                  SET DIC="^IBA(362.3,"

                                       SET DIC(0)="L"

                                       SET X=+IBZ

                                       SET DLAYGO=362.3

                                       KILL DD,DO

                                       DO FILE^DICN

                                       KILL DIE,DIC,DA,DLAYGO,DO,DD

 +160                                  IF Y>0

                                           IF 'IBXDEF

                                               SET IBXDEF=1

                                               SET DR="215////"_+IBZ

                                               SET DIE="^DGCR(399,"

                                               SET DA=IBIFN

                                               DO ^DIE

                                   End DoDot:3

                       End DoDot:2

                       KILL ^TMP("IBDX",$JOB)

 +161     ;

 +162              DO PTFPRDT^IBCSC4A(+IB(.08),IB(151),IB(152),9)

                   IF $DATA(^UTILITY($JOB,"IB"))

                       Begin DoDot:2

 +163                      SET ^DGCR(399,IBIFN,"CP",0)="^399.0304AVI^"

 +164                      SET IBX=0

FOR

                               SET IBX=$ORDER(^UTILITY($JOB,"IB",IBX))

                               if 'IBX

                                   QUIT

                               SET IBY=0

FOR

                                   SET IBY=$ORDER(^UTILITY($JOB,"IB",IBX,IBY))

                                   if 'IBY

                                       QUIT

                                   Begin DoDot:3

 +165                                  SET IBZ=^UTILITY($JOB,"IB",IBX,IBY)

                                       if ($$ICD0^IBACSV(+IBZ)="")

                                           QUIT

                                       SET IBI=$PIECE(^UTILITY($JOB,"IB",IBX,1),U,2)

 +166                                  SET DIC="^DGCR(399,"_IBIFN_",""CP"","

                                       SET DIC(0)="L"

                                       SET DA(1)=IBIFN

                                       SET X=+IBZ_";ICD0("

                                       SET DLAYGO=399.0304

                                       KILL DD,DO

                                       DO FILE^DICN

 +167                                  IF Y>0

                                           SET DIE=DIC

                                           SET DA=+Y

                                           SET DR="1////"_(IBI\1)

                                           DO ^DIE

                                           KILL DIE,DIC,DA,DLAYGO,DO,DD

                                   End DoDot:3

                       End DoDot:2

                       KILL ^UTILITY($JOB,"IB")

               End DoDot:1

               GOTO END

 +168     ;

END        SET IBX="1^Billing Record #"_$PIECE(^DGCR(399,+IBIFN,0),"^",1)_" established for "_$PIECE($GET(^DPT(IBDFN,0)),U,1)

 +1       ;

 +2       ; auto calculate/store revenue codes

           SET IBAUTO=1

           SET DGPTUPDT=""

           IF '$GET(IBCHTRN)

               DO PROC^IBCU7A(IBIFN)

               DO ^IBCU6

 +3       ;

Q          KILL %,%DT,IBDR,X1,X2,X3,X4,Y,DGDIRA,DGDIRB,DGDIR0,DIR,DGRVRCAL,DIC,DA,DR,DINUM,DGPTUPDT,DGXRF1,IBCHK,IBINDT,IBIDS,DLAYGO

 +1        QUIT

 +2       ;

WHERE     ;;.01^0^1;.02^0^2;.03^0^3;.04^0^4;.05^0^5;.06^0^6;.07^0^7;.08^0^8;.09^0^9;.11^0^11;.17^0^17;.16^0^16;.18^0^18;.19^0^19;.2^0^20;.22^0^22;.27^0^27;112^M^12;151^U^1;152^U^2;155^U^5;157^U^7;101^M^1;158^U^8;159^U^9;160^U^10;161^U^11;162^U^12;

 +1       ;;217^U2^3;221^U2^7;

IBCD3.m