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**;21-MAR-94;Build 57
	;;Per VHA Directive 2004-038, 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)
	;
	;move pure data nodes
	F I="I1","I2","I3","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
	F I="U","U1","U2","U3","UF2","UF3","UF31","C","M" 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
	;
	D FTPRV^IBCEU5(IBIFN) ; 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
	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
	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
	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
	;
	;
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:9,13,14 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:7 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=1:1:7 I $P(IBND("UF3"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF3"),"^",J)=$P(IBND("UF3"),"^",J)
	Q
UF31	F J=1:1:3 I $P(IBND("UF31"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF31"),"^",J)=$P(IBND("UF31"),"^",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:14 I $P(IBND("M"),"^",J)]"" S $P(^DGCR(399,IBIFN,"M"),"^",J)=$P(IBND("M"),"^",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:15 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("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)
	. ; 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)
	. 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)
CP1	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	S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
	N Z,Z0
	S Z=$P($G(^DGCR(399,IBIFN,0)),U,19),Z0=$P($G(^DGCR(399,IBIFN1,0)),U,19)
	S IBDD=399.0222 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J  I $D(^(J,0)) D
	. S ^DGCR(399,IBIFN,I,J,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,J,0),U)=(Z0+1)
	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)
	S DIK="^DGCR(399,",DA=IBIFN D IX1^DIK K DA,DIK
	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)
	;
	; 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
	;
	; Restore Taxonomies in fields 243 and 244.
	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
	; 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
	;
