- IBCCC2 ;ALB/AAS - CANCEL AND CLONE A BILL - CONTINUED ;6/6/03 9:56am
- ;;2.0;INTEGRATED BILLING;**80,106,124,138,51,151,137,161,182,211,245,155,296,320,348,349,371,400,433,432,447,516,577,592,608,623**;21-MAR-94;Build 70
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ;MAP TO DGCRCC2
- ;
- ;STEP 5 - get remainder of data to move and store in MCCR then x-ref
- ;STEP 6 - go to screens, come out to IBB1 or something like that
- ;
- STEP5 S IBIFN1=$P(^DGCR(399,IBIFN,0),"^",15) G END:$S(IBIFN1="":1,'$D(^DGCR(399,IBIFN1,0)):1,1:0)
- ; NOTE: any new or changed data nodes may also need to be updated in IBNCPDP5
- ;move pure data nodes
- ; MRD;IB*2.0*516 - Added "In7" nodes.
- F I="I1","I17","I2","I27","I3","I37","M1" I $D(^DGCR(399,IBIFN1,I)) S ^DGCR(399,IBIFN,I)=^DGCR(399,IBIFN1,I)
- ;
- ;move top level data node. ;Do not move 'TX' node EXCEPT piece 8 (added with IB*2.0*432)
- ;F I="U","U1","U2","U3","UF2","UF3","UF31","C","M" I $D(^DGCR(399,IBIFN1,I)) S IBND(I)=^(I) D @I
- ; add new data nodes introduced with IB*2.0*432
- ; vd - IB*2.0*623 - Added "M2".
- F I="TX","U","U1","U2","U3","U4","U5","U6","U7","U8","UF2","UF3","UF31","UF32","C","M","M2" I $D(^DGCR(399,IBIFN1,I)) S IBND(I)=^(I) D @I
- ;
- ;move multiple level data
- ;F I="CC","OC","OP","OT","RC","CP","CV","PRV" I $D(^DGCR(399,IBIFN1,I,0)) D @I
- ; add new data nodes introduced with IB*2.0*447 BI
- F I="CC","OC","OP","OT","RC","CP","CV","PRV","U9" I $D(^DGCR(399,IBIFN1,I,0)) D @I
- ;
- ;JWS;IB*2.0*592;add new Dental Claim fields; IA# 3820
- I $D(^DGCR(399,IBIFN1,"DEN")) S ^DGCR(399,IBIFN,"DEN")=^DGCR(399,IBIFN1,"DEN")
- I $D(^DGCR(399,IBIFN1,"DEN1",0)) S ^DGCR(399,IBIFN,"DEN1",0)=^DGCR(399,IBIFN1,"DEN1",0) D
- . S K=0 F S K=$O(^DGCR(399,IBIFN1,"DEN1",K)) Q:'K S ^DGCR(399,IBIFN,"DEN1",K,0)=^DGCR(399,IBIFN1,"DEN1",K,0)
- I $D(^DGCR(399,IBIFN1,"DEN2")) S ^DGCR(399,IBIFN,"DEN2")=^DGCR(399,IBIFN1,"DEN2")
- ;
- ; IB*2.0*432 ADDED IBSILENT flag so that this can be processed in background
- D FTPRV^IBCEU5(IBIFN,$G(IBSILENT)) ; Ask change prov type if form type not the same
- D COBCHG(IBIFN,,.IBCOB)
- ;
- D ^IBCCC3 ; copy table files (362.3)
- ;
- S I=$G(^DGCR(399,IBIFN1,0)) I $P(I,U,13)=7,$P(I,U,20)=1 D COPYB^IBCDC(IBIFN1,IBIFN) ; update auto bill files
- D PRIOR(IBIFN) ; add new bill to previous bills in series, primary/secondary
- ;
- I +$G(IBCTCOPY) N IBAUTO S IBAUTO=1 D PROC^IBCU7A(IBIFN),BILL^IBCRBC(IBIFN),CPTMOD26^IBCU73(IBIFN) D RECALL^DILFD(399,IBIFN_",",DUZ) G END
- ;
- STEP6 N IBGOEND
- ;JWS;IB*2.0*623v24;need to identify valid duplicate
- I $G(IBCNCRD)=1 D
- . N DA,DR,DIE,X,Y
- . S DA=IBIFN,DIE="^DGCR(399,",DR="23////1" D ^DIE
- . Q
- ; need to kill CRD flag prior to entering billing screens in case a copy for corresponding claim is needed
- K IBCNCRD
- ; don't call IB bill edit screens if this is non-MRA background processing
- I $G(IBSTSM)=1 G END
- I '$G(IBCE("EDI"))!$G(IBCE("EDI","NEW")),'$G(IBCEAUTO) D IBSCEDT G END:$G(IBGOEND)
- ;
- ;
- END K DFN,IB,IBA,IBA2,IBAD,IBADD1,IBBNO,IBCAN,IBCCC,IBDA,IBDPT,IBDR,IBDT,IBI,IBI1,IBIDS,IBIFN,IBIFN1,IBND,IBQUIT,IBU,IBUN,IBARST,IBCOB,IBCNCOPY,IBCBCOPY,IBCNCRD,IBKEY
- K IBV,IBV1,IBW,IBWW,IBYN,IBZZ,PRCASV,PRCAERCD,PRCAERR,PRCASVC,PRCAT,IBBT,IBCH,IBNDS,IBOA,IBREV,IBX,DGXRF1,VAEL,VAERR,IBAC,IBCCC,IBDD1,IBIN,DGREV,DGREV00,DGREVHDR,IBCHK
- K IBBS,IBLS,DGPCM,IBIP,IBND0,IBNDU,IBO,IBPTF,IBST,IBUC,IBDD,D,%,%DT,DIC,VA,VADM,X,X1,X2,X3,X4,Y,I,J,K,DGRVRCAL,DDH,DGACTDT,DGAMNT,DGBR,DGBRN,DGBSI,DGBSLOS,IBA1,IBOD,IBINS,IBN,IBPROC,DGFUNC,DGIFN
- Q
- ;
- ;
- IBSCEDT ; call the IB bill edit screens and validate the data
- N IBV,IBPAR,IBAC,IBHV,IBH,IBCIREDT
- ; if the user came from CBW->PC and this is a non-MRA claim w/a paper EOB, set force print flag IB*2.0*432
- ; also, if the user came from CBW->PC and this is a non-MRA claim and the only EEOB we have has filing errors, set force print flag
- I $G(IBMRANOT)=1,$$COBN^IBCEF(IBIFN)>1,$G(IBFROM)=2 D
- .I $G(IBDA)="" D FORCEPRT^IBCAPP($G(IBIFN)) Q
- .I $D(^IBM(361.1,IBDA,"ERR")) D FORCEPRT^IBCAPP($G(IBIFN)) Q
- D RECALL^DILFD(399,IBIFN_",",DUZ)
- ST1 S IBV=0 D ^IBCSCU,^IBCSC1 I $G(IBPOPOUT) S IBGOEND=1 G IBSCX
- S IBAC=1
- D ^IBCB1
- I $G(IBCIREDT) G ST1
- IBSCX ;
- Q
- ;
- ;
- TX F J=8 I $P(IBND("TX"),"^",J)]"" S $P(^DGCR(399,IBIFN,"TX"),"^",J)=$P(IBND("TX"),"^",J)
- Q
- U F J=3,4,6:1:17,20 I $P(IBND("U"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U"),"^",J)=$P(IBND("U"),"^",J)
- Q
- U1 F J=1:1:3,15 I $P(IBND("U1"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U1"),"^",J)=$P(IBND("U1"),"^",J)
- Q
- U2 F J=1:1:19 I $P(IBND("U2"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U2"),"^",J)=$P(IBND("U2"),"^",J)
- Q
- U3 F J=1:1:11 I $P(IBND("U3"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U3"),"^",J)=$P(IBND("U3"),"^",J)
- Q
- UF2 F J=1,3 I $P(IBND("UF2"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF2"),"^",J)=$P(IBND("UF2"),"^",J)
- Q
- UF3 F J=4:1:6 I $P(IBND("UF3"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF3"),"^",J)=$P(IBND("UF3"),"^",J)
- Q
- U4 F J=1:1:14 I $P(IBND("U4"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U4"),"^",J)=$P(IBND("U4"),"^",J)
- Q
- U5 F J=1:1:6 I $P(IBND("U5"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U5"),"^",J)=$P(IBND("U5"),"^",J)
- Q
- U6 F J=1:1:6 I $P(IBND("U6"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U6"),"^",J)=$P(IBND("U6"),"^",J)
- Q
- U7 F J=1:1:5 I $P(IBND("U7"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U7"),"^",J)=$P(IBND("U7"),"^",J)
- Q
- U8 F J=1:1:3 I $P(IBND("U8"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U8"),"^",J)=$P(IBND("U8"),"^",J)
- Q
- UF31 F J=3 I $P(IBND("UF31"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF31"),"^",J)=$P(IBND("UF31"),"^",J)
- Q
- UF32 F J=1:1:3 I $P(IBND("UF32"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF32"),"^",J)=$P(IBND("UF32"),"^",J)
- Q
- C F J=10 I $P(IBND("C"),"^",J)]"" S $P(^DGCR(399,IBIFN,"C"),"^",J)=$P(IBND("C"),"^",J)
- I '$D(^DGCR(399,IBIFN1,"CP")) D CP1
- Q
- M F J=1:1:9,11:1:14 I $P(IBND("M"),"^",J)]"" S $P(^DGCR(399,IBIFN,"M"),"^",J)=$P(IBND("M"),"^",J)
- Q
- ; vd - IB*2.0*623 - Added the following module of code.
- M2 F J=1:1:6 I $P(IBND("M2"),"^",J)]"" S $P(^DGCR(399,IBIFN,"M2"),"^",J)=$P(IBND("M2"),"^",J)
- Q
- CC S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
- S IBDD=399.04 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
- OP S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
- S IBDD=399.043 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
- Q
- OC S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
- S IBDD=399.041 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
- Q
- OT S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
- S IBDD=399.048 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
- Q
- CV ; Don't copy value codes from inpatient inst to inpatient prof bills
- I $$FT^IBCEF(IBIFN1)'=2,$$FT^IBCEF(IBIFN)=2 Q
- S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
- S IBDD=399.047 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
- Q
- RC S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
- S IBDD=399.042 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S IBND("RC")=^(0) F K=1:1:16 S $P(^DGCR(399,IBIFN,I,J,0),"^",K)=$P(IBND("RC"),"^",K),X=$P(IBND("RC"),"^",K)
- Q
- CP S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
- I +$G(IBNOCPT) Q
- S IBDD=399.0304 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S IBND("CP")=^(0),IBND("CP1")=$G(^(1)),IBND("CP2")=$G(^(2)),IBND("CP-AUX")=$G(^("AUX")) D
- . F K=1:1:7,9:1:14,16:1:22 S $P(^DGCR(399,IBIFN,I,J,0),"^",K)=$P(IBND("CP"),"^",K)
- . ; IB*2.0*432 add new 1 node
- . ; MRD;IB*2.0*516 - Added pieces 7 & 8 (NDC, Units) to 1-node.
- . F K=1:1:8 S $P(^DGCR(399,IBIFN,I,J,1),"^",K)=$P(IBND("CP1"),"^",K)
- . ; WCJ;IB*2.0*577 - Added piece 1 (UNITS/BASIS OF MEASUREMENT) to 2-node.
- . F K=1:1:1 S $P(^DGCR(399,IBIFN,I,J,2),"^",K)=$P(IBND("CP2"),"^",K)
- . ; esg - 11/2/06 - IB*2*348 - 50.09 field was added - AUX piece [9]
- . I IBND("CP-AUX")'="" F K=1:1:9 S $P(^DGCR(399,IBIFN,I,J,"AUX"),"^",K)=$P(IBND("CP-AUX"),"^",K)
- . ; IB*2.0*432 add new LNPRV multiple
- . I $D(^DGCR(399,IBIFN1,I,J,"LNPRV",0)) S ^DGCR(399,IBIFN,I,J,"LNPRV",0)=^DGCR(399,IBIFN1,I,J,"LNPRV",0) D
- .. S K=0 F S K=$O(^DGCR(399,IBIFN1,I,J,"LNPRV",K)) Q:'K D
- ... S ^DGCR(399,IBIFN,I,J,"LNPRV",K,0)=^DGCR(399,IBIFN1,I,J,"LNPRV",K,0)
- . I $D(^DGCR(399,IBIFN1,I,J,"MOD",0)) S ^DGCR(399,IBIFN,I,J,"MOD",0)=^DGCR(399,IBIFN1,I,J,"MOD",0) D
- .. S K=0 F S K=$O(^DGCR(399,IBIFN1,I,J,"MOD",K)) Q:'K D
- ... I $G(IBNOTC),$P($$MOD^ICPTMOD(+$P($G(^DGCR(399,IBIFN1,I,J,"MOD",K,0)),U,2),"I"),U,2)="TC" Q ; Don't copy TC modifier from inst to prof bill
- ... S ^DGCR(399,IBIFN,I,J,"MOD",K,0)=^DGCR(399,IBIFN1,I,J,"MOD",K,0)
- . ;JWS;IB*2.0*592;add new Dental claim form fields
- . I $D(^DGCR(399,IBIFN1,I,J,"DEN")) S ^DGCR(399,IBIFN,I,J,"DEN")=^DGCR(399,IBIFN1,I,J,"DEN")
- . I $D(^DGCR(399,IBIFN1,I,J,"DEN1",0)) S ^DGCR(399,IBIFN,I,J,"DEN1",0)=^DGCR(399,IBIFN1,I,J,"DEN1",0) D
- .. N IBDL
- .. S K=0 F S K=$O(^DGCR(399,IBIFN1,I,J,"DEN1",K)) Q:'K D
- ... S ^DGCR(399,IBIFN,I,J,"DEN1",K,0)=^DGCR(399,IBIFN1,I,J,"DEN1",K,0)
- ... ;JWS;IB*2.0*592;If DENT file 228.2 link, remove it from old invoice.
- ... S IBDL=$P($G(^DGCR(399,IBIFN1,I,J,"DEN1",K,0)),"^",7)
- ... I IBDL K ^DGCR(399,"ADT",IBDL,IBIFN1)
- . ;JRA;IB*2.0*608 Add CMN info - Node 'CMN-10126' contains data specific to only the CMS-10126 form, node 'CMN-484' contains data specific to
- . ; only the CMN-484 form, and node 'CMN' contains data common to both forms.
- . I $D(^DGCR(399,IBIFN1,I,J,"CMN")) S ^DGCR(399,IBIFN,I,J,"CMN")=^DGCR(399,IBIFN1,I,J,"CMN")
- . I $D(^DGCR(399,IBIFN1,I,J,"CMN-10126")) S ^DGCR(399,IBIFN,I,J,"CMN-10126")=^DGCR(399,IBIFN1,I,J,"CMN-10126")
- . I $D(^DGCR(399,IBIFN1,I,J,"CMN-484")) S ^DGCR(399,IBIFN,I,J,"CMN-484")=^DGCR(399,IBIFN1,I,J,"CMN-484")
- CP1 N DGI,IBCOD
- S IBCOD=$P($G(^DGCR(399,IBIFN,0)),"^",9) Q:IBCOD=""!('$D(^DGCR(399,IBIFN1,"C")))
- I IBCOD=9 F DGI=4,5,6 I $P(^DGCR(399,IBIFN1,"C"),"^",DGI) S X=$P(^("C"),"^",DGI)_";ICD0(",DGPROCDT=$P(^("C"),"^",DGI+7) D FILE
- I IBCOD=4 F DGI=1,2,3 I $P(^DGCR(399,IBIFN1,"C"),"^",DGI) S X=$P(^("C"),"^",DGI)_";ICPT(",DGPROCDT=$P(^("C"),"^",DGI+10) D FILE
- I IBCOD=5 F DGI=7,8,9 I $P(^DGCR(399,IBIFN1,"C"),"^",DGI) S X=$P(^("C"),"^",DGI)_";ICPT(",DGPROCDT=$P(^("C"),"^",DGI+4) D FILE
- Q
- ;
- PRV ; Copy providers for cloned claim
- N Z,Z0,CNT
- S Z=$P($G(^DGCR(399,IBIFN,0)),U,19),Z0=$P($G(^DGCR(399,IBIFN1,0)),U,19),CNT=0
- S IBDD=399.0222 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) D
- . I $$GETNPI^IBCEF73A($P(^DGCR(399,IBIFN1,I,J,0),U,2))="" Q ;Don't file provider if no NPI - IB*2*516
- . S CNT=CNT+1,^DGCR(399,IBIFN,I,CNT,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
- . I Z'=Z0,$S(X=3:Z0=3,X=4:Z0=2,1:0) S $P(^DGCR(399,IBIFN,I,CNT,0),U)=(Z0+1)
- I CNT S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0),$P(^DGCR(399,IBIFN,I,0),U,3)=CNT,$P(^DGCR(399,IBIFN,I,0),U,4)=CNT
- Q
- ;
- U9 ; Added for new data elements in IB*2.0*447 BI
- M ^DGCR(399,IBIFN,I)=^DGCR(399,IBIFN1,I)
- Q
- ;
- COB S J=0 F S J=$O(IBCOB(I,J)) Q:'J S $P(^DGCR(399,IBIFN,I),U,J)=IBCOB(I,J)
- Q
- ;
- FILE N DIC,DIE,DR,DA,X,Y,DLAYGO,DD,DO
- I '$D(^DGCR(399,IBIFN,"CP",0)) S DIC("P")=$$GETSPEC^IBEFUNC(399,304)
- S DIC(0)="L",DLAYGO=399,DA(1)=IBIFN,DIC="^DGCR(399,"_DA(1)_",""CP""," Q:X="" D FILE^DICN K DO,DD Q:+Y<1 S DA=+Y
- S DIE="^DGCR(399,"_DA(1)_",""CP"",",DR="1///"_DGPROCDT D ^DIE
- K DGPROCDT
- Q
- ;
- INDEX ;index entire file (set logic)
- N IBMAED D SAVERC(IBIFN,.IBMAED) ; IB*2.0*447 BI - Save the value of piece 16 of each RC node before re-indexing.
- S DIK="^DGCR(399,",DA=IBIFN D IX1^DIK K DA,DIK
- D RESTRC(IBIFN,.IBMAED) ; IB*2.0*447 BI - Restore the value of piece 16 of each RC node before re-indexing.
- Q
- ;
- PRIOR(IBIFN) ; set Secondary/Tertiary Bill #s on prior bills, if the bill is cancelled remove it from prior bills
- N IBSEQ,IBSEQN,IBM1,I,IBIFN1
- S IBSEQ=$$COB^IBCEF(IBIFN)
- S IBSEQN=$S(IBSEQ="S":6,IBSEQ="T":7,1:"") Q:'IBSEQN
- ;
- S IBM1=$G(^DGCR(399,IBIFN,"M1")) I +$P(^DGCR(399,IBIFN,0),U,13)=7 S IBIFN=""
- F I=5,6 I I<IBSEQN S IBIFN1=+$P(IBM1,U,I) I +IBIFN1,$D(^DGCR(399,+IBIFN1,0)) S $P(^DGCR(399,IBIFN1,"M1"),U,IBSEQN)=IBIFN
- Q
- ;
- COBCHG(IBIFN,IBINS,IBCOB) ; Make changes for a new COB payer for bill
- ; IBIFN = ien of bill in file 399
- ; IBINS = ien of bill's current insurance (optional)
- ; IBCOB = array subscripted by node,piece of COB data field change
- ;
- N I,IBFRMTYP,IBTAXLST
- ; Subtract the Prior Payments from the bill's Offset (these are re-added by triggers)
- F I=4,5,6 S $P(^DGCR(399,IBIFN,"U1"),U,2)=$P($G(^DGCR(399,IBIFN,"U1")),U,2)-$P($G(^DGCR(399,IBIFN,"U2")),U,I)
- ;
- I $G(IBINS),$$MCRWNR^IBEFUNC(IBINS) D
- . ;MCRWNR is current insurance ... move payer only
- . N IBCOBN,IBX
- . S IBCOBN=$$COBN^IBCEF(IBIFN)
- . S IBCOB(0,21)=$P("S^T^",U,IBCOBN)
- . S IBCOB("M1",IBCOBN+4)=IBIFN
- . S IBCOB("TX",1)="",IBCOB("TX",2)=""
- . S IBX=$$REQMRA^IBEFUNC(IBIFN)
- . I IBX=0 S IBCOB("TX",5)=0 ; MRA not needed
- . I IBX["R" S IBCOB("TX",5)="A" ; MRA skipped
- . I IBX=1,$$CHK^IBCEMU1(IBIFN) S IBCOB("TX",5)="C" ; MRA on file
- . I $G(IBPRCOB) S IBCOB("TX",5)="C" ; MRA being proc'd
- . D PRIOR(IBIFN)
- . Q
- ;
- ;reset fields for next Sequence Payer
- F I=0,"M1","U2","TX" I $D(IBCOB(I)) D COB
- ;
- ; IB*2.0*211
- ; save off Form Type
- S IBFRMTYP=$P($G(^DGCR(399,IBIFN,0)),U,19)
- ; Save off Taxonomies for providers.
- S I=0 F S I=$O(^DGCR(399,IBIFN,"PRV",I)) Q:'I S IBTAXLST(I)=$P($G(^DGCR(399,IBIFN,"PRV",I,0)),U,15)
- ;
- ;vd - IB*2.0*623 (US4100) - Added the following to correctly process MRAs for Alternate Payer ID.
- I $D(^DGCR(399,IBIFN,"M2")) S IBND("M2")=^DGCR(399,IBIFN,"M2")
- ;
- ; fire xrefs set logic
- D INDEX
- ;
- ; Restore Form Type if changed, but don't restore Form Type if
- ; creating CMS-1500 claim from CTCOPY1^IBCCCB
- I $G(IBCTCOPY)'=1,IBFRMTYP'=$P($G(^DGCR(399,IBIFN,0)),U,19) N DA,DIE,DR S DA=IBIFN,DIE="^DGCR(399,",DR=".19////"_IBFRMTYP D ^DIE
- ;
- ; Restore Claim MRA Status field since triggers in fields 101 & 102
- ; will overwrite the correct value when processing the MRA/EOB.
- ; If we're processing the MRA/EOB, then a valid MRA has been received.
- I $G(IBPRCOB) N DA,DIE,DR S DA=IBIFN,DIE="^DGCR(399,",DR="24////C" D ^DIE
- ;
- ;vd - Added the following "M2" code for IB*2.0*623 (US4100)
- ; Restore Claim Alternate Payer ID data fields since triggers in fields 140-145
- ; will overwrite the correct value when CLONing or processing the MRA/EOB. / vd - Added for IB*2.0*623 (US4100)
- I $TR($G(IBND("M2")),U)]"" D K IBND("M2")
- . N DA,DIE,DR,II,JJ
- . F II=1:1:6 S JJ=$P($G(IBND("M2")),U,II),DA=IBIFN,DIE="^DGCR(399,",DR=(139+II)_"////"_JJ D ^DIE
- ;
- ; Only if cloning, then restore Taxonomies in fields 243 and 244 and 252.
- I '$G(IBINS),'$G(IBPRCOB) D
- . S I=$P($G(IBND("U3")),U,2)
- . I I'=$P($G(^DGCR(399,IBIFN,"U3")),U,2) D
- .. N DA,DIE,DR S DA=IBIFN,DIE="^DGCR(399,",DR="243////"_$S(I'="":I,1:"@") D ^DIE
- . ;
- . S I=$P($G(IBND("U3")),U,3)
- . I I'=$P($G(^DGCR(399,IBIFN,"U3")),U,3) D
- .. N DA,DIE,DR S DA=IBIFN,DIE="^DGCR(399,",DR="244////"_$S(I'="":I,1:"@") D ^DIE
- . ;
- . S I=$P($G(IBND("U3")),U,11)
- . I I'=$P($G(^DGCR(399,IBIFN,"U3")),U,11) D
- .. N DA,DIE,DR S DA=IBIFN,DIE="^DGCR(399,",DR="252////"_$S(I'="":I,1:"@") D ^DIE
- . Q
- ;
- ; Restore Taxonomies in field .15 in sub-file 399.0222.
- S IBTAXLST=0 F S IBTAXLST=$O(IBTAXLST(IBTAXLST)) Q:'IBTAXLST D
- . S I=IBTAXLST(IBTAXLST)
- . I I=$P($G(^DGCR(399,IBIFN,"PRV",IBTAXLST,0)),U,15) Q ; No change
- . N DA,DIE,DR
- . S DA(1)=IBIFN,DA=IBTAXLST
- . S DIE="^DGCR(399,"_DA(1)_",""PRV"",",DR=".15////"_$S(I'="":I,1:"@")
- . D ^DIE
- . Q
- ;
- K IBCOB("TX")
- Q
- ;
- SAVERC(IBIFN,IBMAED) ; IB*2.0*447 BI - Save the value of piece 16 of each RC node before re-indexing.
- Q:$G(IBCTCOPY)=1 Q:$G(IBCTCOPY)=2
- N IBCNT S IBCNT=0
- Q:'$G(IBIFN) Q:'$D(^DGCR(399,IBIFN,"RC"))
- F S IBCNT=$O(^DGCR(399,IBIFN,"RC",IBCNT)) Q:+IBCNT=0 D
- . S IBMAED(IBCNT)=$P($G(^DGCR(399,IBIFN,"RC",IBCNT,0)),U,16)
- Q
- ;
- RESTRC(IBIFN,IBMAED) ; IB*2.0*447 BI - Restore the value of piece 16 of each RC node after re-indexing.
- Q:$G(IBCTCOPY)=1 Q:$G(IBCTCOPY)=2
- N IBCNT S IBCNT=0
- Q:'$G(IBIFN) Q:'$D(^DGCR(399,IBIFN,"RC"))
- F S IBCNT=$O(IBMAED(IBCNT)) Q:+IBCNT=0 D
- . S $P(^DGCR(399,IBIFN,"RC",IBCNT,0),U,16)=IBMAED(IBCNT)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCCC2 16457 printed Mar 13, 2025@21:13:54 Page 2
- IBCCC2 ;ALB/AAS - CANCEL AND CLONE A BILL - CONTINUED ;6/6/03 9:56am
- +1 ;;2.0;INTEGRATED BILLING;**80,106,124,138,51,151,137,161,182,211,245,155,296,320,348,349,371,400,433,432,447,516,577,592,608,623**;21-MAR-94;Build 70
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ;MAP TO DGCRCC2
- +5 ;
- +6 ;STEP 5 - get remainder of data to move and store in MCCR then x-ref
- +7 ;STEP 6 - go to screens, come out to IBB1 or something like that
- +8 ;
- STEP5 SET IBIFN1=$PIECE(^DGCR(399,IBIFN,0),"^",15)
- if $SELECT(IBIFN1="":1,'$DATA(^DGCR(399,IBIFN1,0)):1,1:0)
- GOTO END
- +1 ; NOTE: any new or changed data nodes may also need to be updated in IBNCPDP5
- +2 ;move pure data nodes
- +3 ; MRD;IB*2.0*516 - Added "In7" nodes.
- +4 FOR I="I1","I17","I2","I27","I3","I37","M1"
- IF $DATA(^DGCR(399,IBIFN1,I))
- SET ^DGCR(399,IBIFN,I)=^DGCR(399,IBIFN1,I)
- +5 ;
- +6 ;move top level data node. ;Do not move 'TX' node EXCEPT piece 8 (added with IB*2.0*432)
- +7 ;F I="U","U1","U2","U3","UF2","UF3","UF31","C","M" I $D(^DGCR(399,IBIFN1,I)) S IBND(I)=^(I) D @I
- +8 ; add new data nodes introduced with IB*2.0*432
- +9 ; vd - IB*2.0*623 - Added "M2".
- +10 FOR I="TX","U","U1","U2","U3","U4","U5","U6","U7","U8","UF2","UF3","UF31","UF32","C","M","M2"
- IF $DATA(^DGCR(399,IBIFN1,I))
- SET IBND(I)=^(I)
- DO @I
- +11 ;
- +12 ;move multiple level data
- +13 ;F I="CC","OC","OP","OT","RC","CP","CV","PRV" I $D(^DGCR(399,IBIFN1,I,0)) D @I
- +14 ; add new data nodes introduced with IB*2.0*447 BI
- +15 FOR I="CC","OC","OP","OT","RC","CP","CV","PRV","U9"
- IF $DATA(^DGCR(399,IBIFN1,I,0))
- DO @I
- +16 ;
- +17 ;JWS;IB*2.0*592;add new Dental Claim fields; IA# 3820
- +18 IF $DATA(^DGCR(399,IBIFN1,"DEN"))
- SET ^DGCR(399,IBIFN,"DEN")=^DGCR(399,IBIFN1,"DEN")
- +19 IF $DATA(^DGCR(399,IBIFN1,"DEN1",0))
- SET ^DGCR(399,IBIFN,"DEN1",0)=^DGCR(399,IBIFN1,"DEN1",0)
- Begin DoDot:1
- +20 SET K=0
- FOR
- SET K=$ORDER(^DGCR(399,IBIFN1,"DEN1",K))
- if 'K
- QUIT
- SET ^DGCR(399,IBIFN,"DEN1",K,0)=^DGCR(399,IBIFN1,"DEN1",K,0)
- End DoDot:1
- +21 IF $DATA(^DGCR(399,IBIFN1,"DEN2"))
- SET ^DGCR(399,IBIFN,"DEN2")=^DGCR(399,IBIFN1,"DEN2")
- +22 ;
- +23 ; IB*2.0*432 ADDED IBSILENT flag so that this can be processed in background
- +24 ; Ask change prov type if form type not the same
- DO FTPRV^IBCEU5(IBIFN,$GET(IBSILENT))
- +25 DO COBCHG(IBIFN,,.IBCOB)
- +26 ;
- +27 ; copy table files (362.3)
- DO ^IBCCC3
- +28 ;
- +29 ; update auto bill files
- SET I=$GET(^DGCR(399,IBIFN1,0))
- IF $PIECE(I,U,13)=7
- IF $PIECE(I,U,20)=1
- DO COPYB^IBCDC(IBIFN1,IBIFN)
- +30 ; add new bill to previous bills in series, primary/secondary
- DO PRIOR(IBIFN)
- +31 ;
- +32 IF +$GET(IBCTCOPY)
- NEW IBAUTO
- SET IBAUTO=1
- DO PROC^IBCU7A(IBIFN)
- DO BILL^IBCRBC(IBIFN)
- DO CPTMOD26^IBCU73(IBIFN)
- DO RECALL^DILFD(399,IBIFN_",",DUZ)
- GOTO END
- +33 ;
- STEP6 NEW IBGOEND
- +1 ;JWS;IB*2.0*623v24;need to identify valid duplicate
- +2 IF $GET(IBCNCRD)=1
- Begin DoDot:1
- +3 NEW DA,DR,DIE,X,Y
- +4 SET DA=IBIFN
- SET DIE="^DGCR(399,"
- SET DR="23////1"
- DO ^DIE
- +5 QUIT
- End DoDot:1
- +6 ; need to kill CRD flag prior to entering billing screens in case a copy for corresponding claim is needed
- +7 KILL IBCNCRD
- +8 ; don't call IB bill edit screens if this is non-MRA background processing
- +9 IF $GET(IBSTSM)=1
- GOTO END
- +10 IF '$GET(IBCE("EDI"))!$GET(IBCE("EDI","NEW"))
- IF '$GET(IBCEAUTO)
- DO IBSCEDT
- if $GET(IBGOEND)
- GOTO END
- +11 ;
- +12 ;
- END KILL DFN,IB,IBA,IBA2,IBAD,IBADD1,IBBNO,IBCAN,IBCCC,IBDA,IBDPT,IBDR,IBDT,IBI,IBI1,IBIDS,IBIFN,IBIFN1,IBND,IBQUIT,IBU,IBUN,IBARST,IBCOB,IBCNCOPY,IBCBCOPY,IBCNCRD,IBKEY
- +1 KILL IBV,IBV1,IBW,IBWW,IBYN,IBZZ,PRCASV,PRCAERCD,PRCAERR,PRCASVC,PRCAT,IBBT,IBCH,IBNDS,IBOA,IBREV,IBX,DGXRF1,VAEL,VAERR,IBAC,IBCCC,IBDD1,IBIN,DGREV,DGREV00,DGREVHDR,IBCHK
- +2 KILL IBBS,IBLS,DGPCM,IBIP,IBND0,IBNDU,IBO,IBPTF,IBST,IBUC,IBDD,D,%,%DT,DIC,VA,VADM,X,X1,X2,X3,X4,Y,I,J,K,DGRVRCAL,DDH,DGACTDT,DGAMNT,DGBR,DGBRN,DGBSI,DGBSLOS,IBA1,IBOD,IBINS,IBN,IBPROC,DGFUNC,DGIFN
- +3 QUIT
- +4 ;
- +5 ;
- IBSCEDT ; call the IB bill edit screens and validate the data
- +1 NEW IBV,IBPAR,IBAC,IBHV,IBH,IBCIREDT
- +2 ; if the user came from CBW->PC and this is a non-MRA claim w/a paper EOB, set force print flag IB*2.0*432
- +3 ; also, if the user came from CBW->PC and this is a non-MRA claim and the only EEOB we have has filing errors, set force print flag
- +4 IF $GET(IBMRANOT)=1
- IF $$COBN^IBCEF(IBIFN)>1
- IF $GET(IBFROM)=2
- Begin DoDot:1
- +5 IF $GET(IBDA)=""
- DO FORCEPRT^IBCAPP($GET(IBIFN))
- QUIT
- +6 IF $DATA(^IBM(361.1,IBDA,"ERR"))
- DO FORCEPRT^IBCAPP($GET(IBIFN))
- QUIT
- End DoDot:1
- +7 DO RECALL^DILFD(399,IBIFN_",",DUZ)
- ST1 SET IBV=0
- DO ^IBCSCU
- DO ^IBCSC1
- IF $GET(IBPOPOUT)
- SET IBGOEND=1
- GOTO IBSCX
- +1 SET IBAC=1
- +2 DO ^IBCB1
- +3 IF $GET(IBCIREDT)
- GOTO ST1
- IBSCX ;
- +1 QUIT
- +2 ;
- +3 ;
- TX FOR J=8
- IF $PIECE(IBND("TX"),"^",J)]""
- SET $PIECE(^DGCR(399,IBIFN,"TX"),"^",J)=$PIECE(IBND("TX"),"^",J)
- +1 QUIT
- U FOR J=3,4,6:1:17,20
- IF $PIECE(IBND("U"),"^",J)]""
- SET $PIECE(^DGCR(399,IBIFN,"U"),"^",J)=$PIECE(IBND("U"),"^",J)
- +1 QUIT
- U1 FOR J=1:1:3,15
- IF $PIECE(IBND("U1"),"^",J)]""
- SET $PIECE(^DGCR(399,IBIFN,"U1"),"^",J)=$PIECE(IBND("U1"),"^",J)
- +1 QUIT
- U2 FOR J=1:1:19
- IF $PIECE(IBND("U2"),"^",J)]""
- SET $PIECE(^DGCR(399,IBIFN,"U2"),"^",J)=$PIECE(IBND("U2"),"^",J)
- +1 QUIT
- U3 FOR J=1:1:11
- IF $PIECE(IBND("U3"),"^",J)]""
- SET $PIECE(^DGCR(399,IBIFN,"U3"),"^",J)=$PIECE(IBND("U3"),"^",J)
- +1 QUIT
- UF2 FOR J=1,3
- IF $PIECE(IBND("UF2"),"^",J)]""
- SET $PIECE(^DGCR(399,IBIFN,"UF2"),"^",J)=$PIECE(IBND("UF2"),"^",J)
- +1 QUIT
- UF3 FOR J=4:1:6
- IF $PIECE(IBND("UF3"),"^",J)]""
- SET $PIECE(^DGCR(399,IBIFN,"UF3"),"^",J)=$PIECE(IBND("UF3"),"^",J)
- +1 QUIT
- U4 FOR J=1:1:14
- IF $PIECE(IBND("U4"),"^",J)]""
- SET $PIECE(^DGCR(399,IBIFN,"U4"),"^",J)=$PIECE(IBND("U4"),"^",J)
- +1 QUIT
- U5 FOR J=1:1:6
- IF $PIECE(IBND("U5"),"^",J)]""
- SET $PIECE(^DGCR(399,IBIFN,"U5"),"^",J)=$PIECE(IBND("U5"),"^",J)
- +1 QUIT
- U6 FOR J=1:1:6
- IF $PIECE(IBND("U6"),"^",J)]""
- SET $PIECE(^DGCR(399,IBIFN,"U6"),"^",J)=$PIECE(IBND("U6"),"^",J)
- +1 QUIT
- U7 FOR J=1:1:5
- IF $PIECE(IBND("U7"),"^",J)]""
- SET $PIECE(^DGCR(399,IBIFN,"U7"),"^",J)=$PIECE(IBND("U7"),"^",J)
- +1 QUIT
- U8 FOR J=1:1:3
- IF $PIECE(IBND("U8"),"^",J)]""
- SET $PIECE(^DGCR(399,IBIFN,"U8"),"^",J)=$PIECE(IBND("U8"),"^",J)
- +1 QUIT
- UF31 FOR J=3
- IF $PIECE(IBND("UF31"),"^",J)]""
- SET $PIECE(^DGCR(399,IBIFN,"UF31"),"^",J)=$PIECE(IBND("UF31"),"^",J)
- +1 QUIT
- UF32 FOR J=1:1:3
- IF $PIECE(IBND("UF32"),"^",J)]""
- SET $PIECE(^DGCR(399,IBIFN,"UF32"),"^",J)=$PIECE(IBND("UF32"),"^",J)
- +1 QUIT
- C FOR J=10
- IF $PIECE(IBND("C"),"^",J)]""
- SET $PIECE(^DGCR(399,IBIFN,"C"),"^",J)=$PIECE(IBND("C"),"^",J)
- +1 IF '$DATA(^DGCR(399,IBIFN1,"CP"))
- DO CP1
- +2 QUIT
- M FOR J=1:1:9,11:1:14
- IF $PIECE(IBND("M"),"^",J)]""
- SET $PIECE(^DGCR(399,IBIFN,"M"),"^",J)=$PIECE(IBND("M"),"^",J)
- +1 QUIT
- +2 ; vd - IB*2.0*623 - Added the following module of code.
- M2 FOR J=1:1:6
- IF $PIECE(IBND("M2"),"^",J)]""
- SET $PIECE(^DGCR(399,IBIFN,"M2"),"^",J)=$PIECE(IBND("M2"),"^",J)
- +1 QUIT
- CC SET ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
- +1 SET IBDD=399.04
- FOR J=0:0
- SET J=$ORDER(^DGCR(399,IBIFN1,I,J))
- if 'J
- QUIT
- IF $DATA(^(J,0))
- SET ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0)
- SET X=$PIECE(^(0),"^")
- OP SET ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
- +1 SET IBDD=399.043
- FOR J=0:0
- SET J=$ORDER(^DGCR(399,IBIFN1,I,J))
- if 'J
- QUIT
- IF $DATA(^(J,0))
- SET ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0)
- SET X=$PIECE(^(0),"^")
- +2 QUIT
- OC SET ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
- +1 SET IBDD=399.041
- FOR J=0:0
- SET J=$ORDER(^DGCR(399,IBIFN1,I,J))
- if 'J
- QUIT
- IF $DATA(^(J,0))
- SET ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0)
- SET X=$PIECE(^(0),"^")
- +2 QUIT
- OT SET ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
- +1 SET IBDD=399.048
- FOR J=0:0
- SET J=$ORDER(^DGCR(399,IBIFN1,I,J))
- if 'J
- QUIT
- IF $DATA(^(J,0))
- SET ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0)
- SET X=$PIECE(^(0),"^")
- +2 QUIT
- CV ; Don't copy value codes from inpatient inst to inpatient prof bills
- +1 IF $$FT^IBCEF(IBIFN1)'=2
- IF $$FT^IBCEF(IBIFN)=2
- QUIT
- +2 SET ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
- +3 SET IBDD=399.047
- FOR J=0:0
- SET J=$ORDER(^DGCR(399,IBIFN1,I,J))
- if 'J
- QUIT
- IF $DATA(^(J,0))
- SET ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0)
- SET X=$PIECE(^(0),"^")
- +4 QUIT
- RC SET ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
- +1 SET IBDD=399.042
- FOR J=0:0
- SET J=$ORDER(^DGCR(399,IBIFN1,I,J))
- if 'J
- QUIT
- IF $DATA(^(J,0))
- SET IBND("RC")=^(0)
- FOR K=1:1:16
- SET $PIECE(^DGCR(399,IBIFN,I,J,0),"^",K)=$PIECE(IBND("RC"),"^",K)
- SET X=$PIECE(IBND("RC"),"^",K)
- +2 QUIT
- CP SET ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
- +1 IF +$GET(IBNOCPT)
- QUIT
- +2 SET IBDD=399.0304
- FOR J=0:0
- SET J=$ORDER(^DGCR(399,IBIFN1,I,J))
- if 'J
- QUIT
- IF $DATA(^(J,0))
- SET IBND("CP")=^(0)
- SET IBND("CP1")=$GET(^(1))
- SET IBND("CP2")=$GET(^(2))
- SET IBND("CP-AUX")=$GET(^("AUX"))
- Begin DoDot:1
- +3 FOR K=1:1:7,9:1:14,16:1:22
- SET $PIECE(^DGCR(399,IBIFN,I,J,0),"^",K)=$PIECE(IBND("CP"),"^",K)
- +4 ; IB*2.0*432 add new 1 node
- +5 ; MRD;IB*2.0*516 - Added pieces 7 & 8 (NDC, Units) to 1-node.
- +6 FOR K=1:1:8
- SET $PIECE(^DGCR(399,IBIFN,I,J,1),"^",K)=$PIECE(IBND("CP1"),"^",K)
- +7 ; WCJ;IB*2.0*577 - Added piece 1 (UNITS/BASIS OF MEASUREMENT) to 2-node.
- +8 FOR K=1:1:1
- SET $PIECE(^DGCR(399,IBIFN,I,J,2),"^",K)=$PIECE(IBND("CP2"),"^",K)
- +9 ; esg - 11/2/06 - IB*2*348 - 50.09 field was added - AUX piece [9]
- +10 IF IBND("CP-AUX")'=""
- FOR K=1:1:9
- SET $PIECE(^DGCR(399,IBIFN,I,J,"AUX"),"^",K)=$PIECE(IBND("CP-AUX"),"^",K)
- +11 ; IB*2.0*432 add new LNPRV multiple
- +12 IF $DATA(^DGCR(399,IBIFN1,I,J,"LNPRV",0))
- SET ^DGCR(399,IBIFN,I,J,"LNPRV",0)=^DGCR(399,IBIFN1,I,J,"LNPRV",0)
- Begin DoDot:2
- +13 SET K=0
- FOR
- SET K=$ORDER(^DGCR(399,IBIFN1,I,J,"LNPRV",K))
- if 'K
- QUIT
- Begin DoDot:3
- +14 SET ^DGCR(399,IBIFN,I,J,"LNPRV",K,0)=^DGCR(399,IBIFN1,I,J,"LNPRV",K,0)
- End DoDot:3
- End DoDot:2
- +15 IF $DATA(^DGCR(399,IBIFN1,I,J,"MOD",0))
- SET ^DGCR(399,IBIFN,I,J,"MOD",0)=^DGCR(399,IBIFN1,I,J,"MOD",0)
- Begin DoDot:2
- +16 SET K=0
- FOR
- SET K=$ORDER(^DGCR(399,IBIFN1,I,J,"MOD",K))
- if 'K
- QUIT
- Begin DoDot:3
- +17 ; Don't copy TC modifier from inst to prof bill
- IF $GET(IBNOTC)
- IF $PIECE($$MOD^ICPTMOD(+$PIECE($GET(^DGCR(399,IBIFN1,I,J,"MOD",K,0)),U,2),"I"),U,2)="TC"
- QUIT
- +18 SET ^DGCR(399,IBIFN,I,J,"MOD",K,0)=^DGCR(399,IBIFN1,I,J,"MOD",K,0)
- End DoDot:3
- End DoDot:2
- +19 ;JWS;IB*2.0*592;add new Dental claim form fields
- +20 IF $DATA(^DGCR(399,IBIFN1,I,J,"DEN"))
- SET ^DGCR(399,IBIFN,I,J,"DEN")=^DGCR(399,IBIFN1,I,J,"DEN")
- +21 IF $DATA(^DGCR(399,IBIFN1,I,J,"DEN1",0))
- SET ^DGCR(399,IBIFN,I,J,"DEN1",0)=^DGCR(399,IBIFN1,I,J,"DEN1",0)
- Begin DoDot:2
- +22 NEW IBDL
- +23 SET K=0
- FOR
- SET K=$ORDER(^DGCR(399,IBIFN1,I,J,"DEN1",K))
- if 'K
- QUIT
- Begin DoDot:3
- +24 SET ^DGCR(399,IBIFN,I,J,"DEN1",K,0)=^DGCR(399,IBIFN1,I,J,"DEN1",K,0)
- +25 ;JWS;IB*2.0*592;If DENT file 228.2 link, remove it from old invoice.
- +26 SET IBDL=$PIECE($GET(^DGCR(399,IBIFN1,I,J,"DEN1",K,0)),"^",7)
- +27 IF IBDL
- KILL ^DGCR(399,"ADT",IBDL,IBIFN1)
- End DoDot:3
- End DoDot:2
- +28 ;JRA;IB*2.0*608 Add CMN info - Node 'CMN-10126' contains data specific to only the CMS-10126 form, node 'CMN-484' contains data specific to
- +29 ; only the CMN-484 form, and node 'CMN' contains data common to both forms.
- +30 IF $DATA(^DGCR(399,IBIFN1,I,J,"CMN"))
- SET ^DGCR(399,IBIFN,I,J,"CMN")=^DGCR(399,IBIFN1,I,J,"CMN")
- +31 IF $DATA(^DGCR(399,IBIFN1,I,J,"CMN-10126"))
- SET ^DGCR(399,IBIFN,I,J,"CMN-10126")=^DGCR(399,IBIFN1,I,J,"CMN-10126")
- +32 IF $DATA(^DGCR(399,IBIFN1,I,J,"CMN-484"))
- SET ^DGCR(399,IBIFN,I,J,"CMN-484")=^DGCR(399,IBIFN1,I,J,"CMN-484")
- End DoDot:1
- CP1 NEW DGI,IBCOD
- +1 SET IBCOD=$PIECE($GET(^DGCR(399,IBIFN,0)),"^",9)
- if IBCOD=""!('$DATA(^DGCR(399,IBIFN1,"C")))
- QUIT
- +2 IF IBCOD=9
- FOR DGI=4,5,6
- IF $PIECE(^DGCR(399,IBIFN1,"C"),"^",DGI)
- SET X=$PIECE(^("C"),"^",DGI)_";ICD0("
- SET DGPROCDT=$PIECE(^("C"),"^",DGI+7)
- DO FILE
- +3 IF IBCOD=4
- FOR DGI=1,2,3
- IF $PIECE(^DGCR(399,IBIFN1,"C"),"^",DGI)
- SET X=$PIECE(^("C"),"^",DGI)_";ICPT("
- SET DGPROCDT=$PIECE(^("C"),"^",DGI+10)
- DO FILE
- +4 IF IBCOD=5
- FOR DGI=7,8,9
- IF $PIECE(^DGCR(399,IBIFN1,"C"),"^",DGI)
- SET X=$PIECE(^("C"),"^",DGI)_";ICPT("
- SET DGPROCDT=$PIECE(^("C"),"^",DGI+4)
- DO FILE
- +5 QUIT
- +6 ;
- PRV ; Copy providers for cloned claim
- +1 NEW Z,Z0,CNT
- +2 SET Z=$PIECE($GET(^DGCR(399,IBIFN,0)),U,19)
- SET Z0=$PIECE($GET(^DGCR(399,IBIFN1,0)),U,19)
- SET CNT=0
- +3 SET IBDD=399.0222
- FOR J=0:0
- SET J=$ORDER(^DGCR(399,IBIFN1,I,J))
- if 'J
- QUIT
- IF $DATA(^(J,0))
- Begin DoDot:1
- +4 ;Don't file provider if no NPI - IB*2*516
- IF $$GETNPI^IBCEF73A($PIECE(^DGCR(399,IBIFN1,I,J,0),U,2))=""
- QUIT
- +5 SET CNT=CNT+1
- SET ^DGCR(399,IBIFN,I,CNT,0)=^DGCR(399,IBIFN1,I,J,0)
- SET X=$PIECE(^(0),"^")
- +6 IF Z'=Z0
- IF $SELECT(X=3:Z0=3,X=4:Z0=2,1:0)
- SET $PIECE(^DGCR(399,IBIFN,I,CNT,0),U)=(Z0+1)
- End DoDot:1
- +7 IF CNT
- SET ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
- SET $PIECE(^DGCR(399,IBIFN,I,0),U,3)=CNT
- SET $PIECE(^DGCR(399,IBIFN,I,0),U,4)=CNT
- +8 QUIT
- +9 ;
- U9 ; Added for new data elements in IB*2.0*447 BI
- +1 MERGE ^DGCR(399,IBIFN,I)=^DGCR(399,IBIFN1,I)
- +2 QUIT
- +3 ;
- COB SET J=0
- FOR
- SET J=$ORDER(IBCOB(I,J))
- if 'J
- QUIT
- SET $PIECE(^DGCR(399,IBIFN,I),U,J)=IBCOB(I,J)
- +1 QUIT
- +2 ;
- FILE NEW DIC,DIE,DR,DA,X,Y,DLAYGO,DD,DO
- +1 IF '$DATA(^DGCR(399,IBIFN,"CP",0))
- SET DIC("P")=$$GETSPEC^IBEFUNC(399,304)
- +2 SET DIC(0)="L"
- SET DLAYGO=399
- SET DA(1)=IBIFN
- SET DIC="^DGCR(399,"_DA(1)_",""CP"","
- if X=""
- QUIT
- DO FILE^DICN
- KILL DO,DD
- if +Y<1
- QUIT
- SET DA=+Y
- +3 SET DIE="^DGCR(399,"_DA(1)_",""CP"","
- SET DR="1///"_DGPROCDT
- DO ^DIE
- +4 KILL DGPROCDT
- +5 QUIT
- +6 ;
- INDEX ;index entire file (set logic)
- +1 ; IB*2.0*447 BI - Save the value of piece 16 of each RC node before re-indexing.
- NEW IBMAED
- DO SAVERC(IBIFN,.IBMAED)
- +2 SET DIK="^DGCR(399,"
- SET DA=IBIFN
- DO IX1^DIK
- KILL DA,DIK
- +3 ; IB*2.0*447 BI - Restore the value of piece 16 of each RC node before re-indexing.
- DO RESTRC(IBIFN,.IBMAED)
- +4 QUIT
- +5 ;
- PRIOR(IBIFN) ; set Secondary/Tertiary Bill #s on prior bills, if the bill is cancelled remove it from prior bills
- +1 NEW IBSEQ,IBSEQN,IBM1,I,IBIFN1
- +2 SET IBSEQ=$$COB^IBCEF(IBIFN)
- +3 SET IBSEQN=$SELECT(IBSEQ="S":6,IBSEQ="T":7,1:"")
- if 'IBSEQN
- QUIT
- +4 ;
- +5 SET IBM1=$GET(^DGCR(399,IBIFN,"M1"))
- IF +$PIECE(^DGCR(399,IBIFN,0),U,13)=7
- SET IBIFN=""
- +6 FOR I=5,6
- IF I<IBSEQN
- SET IBIFN1=+$PIECE(IBM1,U,I)
- IF +IBIFN1
- IF $DATA(^DGCR(399,+IBIFN1,0))
- SET $PIECE(^DGCR(399,IBIFN1,"M1"),U,IBSEQN)=IBIFN
- +7 QUIT
- +8 ;
- COBCHG(IBIFN,IBINS,IBCOB) ; Make changes for a new COB payer for bill
- +1 ; IBIFN = ien of bill in file 399
- +2 ; IBINS = ien of bill's current insurance (optional)
- +3 ; IBCOB = array subscripted by node,piece of COB data field change
- +4 ;
- +5 NEW I,IBFRMTYP,IBTAXLST
- +6 ; Subtract the Prior Payments from the bill's Offset (these are re-added by triggers)
- +7 FOR I=4,5,6
- SET $PIECE(^DGCR(399,IBIFN,"U1"),U,2)=$PIECE($GET(^DGCR(399,IBIFN,"U1")),U,2)-$PIECE($GET(^DGCR(399,IBIFN,"U2")),U,I)
- +8 ;
- +9 IF $GET(IBINS)
- IF $$MCRWNR^IBEFUNC(IBINS)
- Begin DoDot:1
- +10 ;MCRWNR is current insurance ... move payer only
- +11 NEW IBCOBN,IBX
- +12 SET IBCOBN=$$COBN^IBCEF(IBIFN)
- +13 SET IBCOB(0,21)=$PIECE("S^T^",U,IBCOBN)
- +14 SET IBCOB("M1",IBCOBN+4)=IBIFN
- +15 SET IBCOB("TX",1)=""
- SET IBCOB("TX",2)=""
- +16 SET IBX=$$REQMRA^IBEFUNC(IBIFN)
- +17 ; MRA not needed
- IF IBX=0
- SET IBCOB("TX",5)=0
- +18 ; MRA skipped
- IF IBX["R"
- SET IBCOB("TX",5)="A"
- +19 ; MRA on file
- IF IBX=1
- IF $$CHK^IBCEMU1(IBIFN)
- SET IBCOB("TX",5)="C"
- +20 ; MRA being proc'd
- IF $GET(IBPRCOB)
- SET IBCOB("TX",5)="C"
- +21 DO PRIOR(IBIFN)
- +22 QUIT
- End DoDot:1
- +23 ;
- +24 ;reset fields for next Sequence Payer
- +25 FOR I=0,"M1","U2","TX"
- IF $DATA(IBCOB(I))
- DO COB
- +26 ;
- +27 ; IB*2.0*211
- +28 ; save off Form Type
- +29 SET IBFRMTYP=$PIECE($GET(^DGCR(399,IBIFN,0)),U,19)
- +30 ; Save off Taxonomies for providers.
- +31 SET I=0
- FOR
- SET I=$ORDER(^DGCR(399,IBIFN,"PRV",I))
- if 'I
- QUIT
- SET IBTAXLST(I)=$PIECE($GET(^DGCR(399,IBIFN,"PRV",I,0)),U,15)
- +32 ;
- +33 ;vd - IB*2.0*623 (US4100) - Added the following to correctly process MRAs for Alternate Payer ID.
- +34 IF $DATA(^DGCR(399,IBIFN,"M2"))
- SET IBND("M2")=^DGCR(399,IBIFN,"M2")
- +35 ;
- +36 ; fire xrefs set logic
- +37 DO INDEX
- +38 ;
- +39 ; Restore Form Type if changed, but don't restore Form Type if
- +40 ; creating CMS-1500 claim from CTCOPY1^IBCCCB
- +41 IF $GET(IBCTCOPY)'=1
- IF IBFRMTYP'=$PIECE($GET(^DGCR(399,IBIFN,0)),U,19)
- NEW DA,DIE,DR
- SET DA=IBIFN
- SET DIE="^DGCR(399,"
- SET DR=".19////"_IBFRMTYP
- DO ^DIE
- +42 ;
- +43 ; Restore Claim MRA Status field since triggers in fields 101 & 102
- +44 ; will overwrite the correct value when processing the MRA/EOB.
- +45 ; If we're processing the MRA/EOB, then a valid MRA has been received.
- +46 IF $GET(IBPRCOB)
- NEW DA,DIE,DR
- SET DA=IBIFN
- SET DIE="^DGCR(399,"
- SET DR="24////C"
- DO ^DIE
- +47 ;
- +48 ;vd - Added the following "M2" code for IB*2.0*623 (US4100)
- +49 ; Restore Claim Alternate Payer ID data fields since triggers in fields 140-145
- +50 ; will overwrite the correct value when CLONing or processing the MRA/EOB. / vd - Added for IB*2.0*623 (US4100)
- +51 IF $TRANSLATE($GET(IBND("M2")),U)]""
- Begin DoDot:1
- +52 NEW DA,DIE,DR,II,JJ
- +53 FOR II=1:1:6
- SET JJ=$PIECE($GET(IBND("M2")),U,II)
- SET DA=IBIFN
- SET DIE="^DGCR(399,"
- SET DR=(139+II)_"////"_JJ
- DO ^DIE
- End DoDot:1
- KILL IBND("M2")
- +54 ;
- +55 ; Only if cloning, then restore Taxonomies in fields 243 and 244 and 252.
- +56 IF '$GET(IBINS)
- IF '$GET(IBPRCOB)
- Begin DoDot:1
- +57 SET I=$PIECE($GET(IBND("U3")),U,2)
- +58 IF I'=$PIECE($GET(^DGCR(399,IBIFN,"U3")),U,2)
- Begin DoDot:2
- +59 NEW DA,DIE,DR
- SET DA=IBIFN
- SET DIE="^DGCR(399,"
- SET DR="243////"_$SELECT(I'="":I,1:"@")
- DO ^DIE
- End DoDot:2
- +60 ;
- +61 SET I=$PIECE($GET(IBND("U3")),U,3)
- +62 IF I'=$PIECE($GET(^DGCR(399,IBIFN,"U3")),U,3)
- Begin DoDot:2
- +63 NEW DA,DIE,DR
- SET DA=IBIFN
- SET DIE="^DGCR(399,"
- SET DR="244////"_$SELECT(I'="":I,1:"@")
- DO ^DIE
- End DoDot:2
- +64 ;
- +65 SET I=$PIECE($GET(IBND("U3")),U,11)
- +66 IF I'=$PIECE($GET(^DGCR(399,IBIFN,"U3")),U,11)
- Begin DoDot:2
- +67 NEW DA,DIE,DR
- SET DA=IBIFN
- SET DIE="^DGCR(399,"
- SET DR="252////"_$SELECT(I'="":I,1:"@")
- DO ^DIE
- End DoDot:2
- +68 QUIT
- End DoDot:1
- +69 ;
- +70 ; Restore Taxonomies in field .15 in sub-file 399.0222.
- +71 SET IBTAXLST=0
- FOR
- SET IBTAXLST=$ORDER(IBTAXLST(IBTAXLST))
- if 'IBTAXLST
- QUIT
- Begin DoDot:1
- +72 SET I=IBTAXLST(IBTAXLST)
- +73 ; No change
- IF I=$PIECE($GET(^DGCR(399,IBIFN,"PRV",IBTAXLST,0)),U,15)
- QUIT
- +74 NEW DA,DIE,DR
- +75 SET DA(1)=IBIFN
- SET DA=IBTAXLST
- +76 SET DIE="^DGCR(399,"_DA(1)_",""PRV"","
- SET DR=".15////"_$SELECT(I'="":I,1:"@")
- +77 DO ^DIE
- +78 QUIT
- End DoDot:1
- +79 ;
- +80 KILL IBCOB("TX")
- +81 QUIT
- +82 ;
- SAVERC(IBIFN,IBMAED) ; IB*2.0*447 BI - Save the value of piece 16 of each RC node before re-indexing.
- +1 if $GET(IBCTCOPY)=1
- QUIT
- if $GET(IBCTCOPY)=2
- QUIT
- +2 NEW IBCNT
- SET IBCNT=0
- +3 if '$GET(IBIFN)
- QUIT
- if '$DATA(^DGCR(399,IBIFN,"RC"))
- QUIT
- +4 FOR
- SET IBCNT=$ORDER(^DGCR(399,IBIFN,"RC",IBCNT))
- if +IBCNT=0
- QUIT
- Begin DoDot:1
- +5 SET IBMAED(IBCNT)=$PIECE($GET(^DGCR(399,IBIFN,"RC",IBCNT,0)),U,16)
- End DoDot:1
- +6 QUIT
- +7 ;
- RESTRC(IBIFN,IBMAED) ; IB*2.0*447 BI - Restore the value of piece 16 of each RC node after re-indexing.
- +1 if $GET(IBCTCOPY)=1
- QUIT
- if $GET(IBCTCOPY)=2
- QUIT
- +2 NEW IBCNT
- SET IBCNT=0
- +3 if '$GET(IBIFN)
- QUIT
- if '$DATA(^DGCR(399,IBIFN,"RC"))
- QUIT
- +4 FOR
- SET IBCNT=$ORDER(IBMAED(IBCNT))
- if +IBCNT=0
- QUIT
- Begin DoDot:1
- +5 SET $PIECE(^DGCR(399,IBIFN,"RC",IBCNT,0),U,16)=IBMAED(IBCNT)
- End DoDot:1
- +6 QUIT
