IBCNSUX1 ;ALB/CMS - SPLIT COMBINATION PLANS CONT. ; 04-NOV-98
;;2.0;INTEGRATED BILLING;**103,133,516**;21-MAR-94;Build 123
;;Per VA Directive 6402, this routine should not be modified.
Q
;
BEG ; -- Start to process policy separation from IBCNSUX
; Input: IBINS=Selected Medicare Company
; IBPLAN=Selected Combination Plan
; IBWNR=MED WNR INS IEN^"MEDICARE (WNR)"
; ^PART A IEN^"PART A"
; ^PART B IEN^"PART A"
;
N DFN,DO,DD,DA,DR,DIC,DIE,DIK,DIR,DIRUT,X,Y
N IBCDFN,IBERR,IB0,IBST,IBSUB1,IBPLANAM
K ^TMP($J,"IBCNSUX"),^TMP($J,"IBCNSUX1")
;IB*2.0*516/TAZ - Retrieve HIPAA compliant Plan Name.
;S IBST=$$NOW^XLFDT,IBPLANAM=$P($G(^IBA(355.3,IBPLAN,0)),U,3)
S IBST=$$NOW^XLFDT,IBPLANAM=$$GET1^DIQ(355.3,IBPLAN,2.01) ; 516 - baa
S IBSUB1=$$SUBS^IBCNSJ(IBINS,IBPLAN,0,"^TMP($J,""IBCNSUX1"")")
S DFN=0 F S DFN=$O(^TMP($J,"IBCNSUX1",DFN)) Q:'DFN D
.S IBCDFN=0 F S IBCDFN=$O(^TMP($J,"IBCNSUX1",DFN,IBCDFN)) Q:'IBCDFN D
..S IB0=$G(^DPT(DFN,.312,IBCDFN,0))
..I $P(IB0,U,18)'=+IBPLAN Q
..;
..; -- check for duplicate
..D DUP
..;
..; -- if the policy to be split has no COB, and both an A and B
..; -- policy need to be created, set it to Primary
..I '$P(IB0,"^",20),'$D(^TMP($J,"IBCNSUX","ERR",DFN,2)),'$D(^(1)) D
...N DIE,DA,DR,X,Y
...S DIE="^DPT("_DFN_",.312,",DA=+IBCDFN,DA(1)=DFN,DR=".2////1" D ^DIE
..;
..; -- create Medicare (WNR) policies if none exists
..I '$D(^TMP($J,"IBCNSUX","ERR",DFN,2)) D ADDB
..I '$D(^TMP($J,"IBCNSUX","ERR",DFN,1)) D SETA
;
; -- delete combination plan if no subscribers left.
I '$$SUBS^IBCNSJ(IBINS,IBPLAN) D DEL^IBCNSJ(IBPLAN)
;
D WRT
;
BEGQ K ^TMP($J,"IBCNSUX"),^TMP($J,"IBCNSUX1")
Q
;
;
ADDB ; -- Create a New MEDICARE PART B patient policy
N DA,DIC,DIE,DR,IBBDFN,IBC,IBX,X,Y,IBCDA,IBNDA,IBN
K DD,D0
;
S DIC("DR")=".01////"_+IBWNR_";1.09////1;1.05///NOW;1.06////"_DUZ_";.18////"_$P(IBWNR,U,5)
;
; -- If the policy to be split has no COB, and a valid Part A policy
; -- already exists, set the COB to Primary
I '$P(IB0,"^",20),$D(^TMP($J,"IBCNSUX","ERR",DFN,1)) S DIC("DR")=DIC("DR")_";.2////1"
;
S DA(1)=DFN,DIC="^DPT("_DFN_",.312,",DIC(0)="L",X=+IBWNR,DLAYGO=2.312
D FILE^DICN S IBBDFN=+Y K DIC
I IBBDFN<1 S ^TMP($J,"IBCNSUX","ERR",DFN,3)="Could not create a Part B policy." G ADDBQ
;
; -- Get settings of combination policy
S IBCDA=IBCDFN_","_DFN_","
D GETS^DIQ(2.312,IBCDA,"*","IN","IBC")
I $D(IBC("IBERR")) S ^TMP($J,"IBCNSUX","ERR",DFN,3)="Could not set Part B policy data." G ADDBQ
;
; -- Set Medicare Part B policy data - copy combination policy data to new new Part B policy
S IBNDA=+IBBDFN_","_DFN_","
S IBX=0 F S IBX=$O(IBC(2.312,IBCDA,IBX)) Q:IBX="" D
. ;
. ; -- Don't set system edited or triggered fields
. I ",.01,1.01,1.02,1.1,1.05,1.06,.18,"[(","_IBX_",") Q
. ;
. S IBN(2.312,IBNDA,IBX)=IBC(2.312,IBCDA,IBX,"I")
I $O(IBN(0)) D FILE^DIE("","IBN")
ADDBQ Q
;
SETA ; -- Change policy to point to Part A
N DIE,DA,DR,X,Y
S DIE="^DPT("_DFN_",.312,",DA=+IBCDFN,DA(1)=DFN
S DR=".01////"_+IBWNR_";.18////"_$P(IBWNR,U,3)
;
; - if this policy still has no COB, set it to primary
I '$P($G(^DPT(DFN,.312,IBCDFN,0)),"^",20) S DR=DR_";.2////1"
D ^DIE
Q
;
DUP ; -- Check for duplicate
N IBX,IB0,X,Y
S IBX=0 F S IBX=$O(^DPT(DFN,.312,"B",+IBWNR,IBX)) Q:'IBX D
.S IB0=$G(^DPT(DFN,.312,IBX,0))
.I $P(IB0,U,18)=$P(IBWNR,U,3) S ^TMP($J,"IBCNSUX","ERR",DFN,1)="Medicare (WNR) Part A policy already exists." Q
.I $P(IB0,U,18)=$P(IBWNR,U,5) S ^TMP($J,"IBCNSUX","ERR",DFN,2)="Medicare (WNR) Part B policy already exists." Q
Q
;
WRT ; -- write report
N IBX,VA,VADM,VAERR,X,Y
W @IOF,!,"Separate Medicare Combination policies Part A and Part B"
W !!,"Process started ",$$FMTE^XLFDT(IBST)," ended ",$$FMTE^XLFDT($$NOW^XLFDT)
W !,?10,"Run by: ",$P($G(^VA(200,+$G(DUZ),0)),U,1)
W !!,?5,"Combination Company: ",$P($G(^DIC(36,IBINS,0)),U,1)
W !?3,"Combination Plan Name: ",IBPLANAM W:'$D(^IBA(355.3,IBPLAN,0)) " (This plan was deleted)"
W ! F IBX=1:1:79 W "="
;
I '$O(^TMP($J,"IBCNSUX","ERR",0)) W !!,"SUCCESSFULLY COMPLETED, COMBINATION PLAN DELETED." G WRTQ
;
W !,"Exception Report:"
S DFN=0 F S DFN=$O(^TMP($J,"IBCNSUX","ERR",DFN)) Q:'DFN D
.K VADM D DEM^VADPT
.W !!,VADM(1),?32,"SSN: ",$P(VADM(2),U,2),?50,"DOB: ",$P(VADM(3),U,2)
.S IBX=0 F S IBX=$O(^TMP($J,"IBCNSUX","ERR",DFN,IBX)) Q:'IBX D
..W !,?5,^TMP($J,"IBCNSUX","ERR",DFN,IBX)
WRTQ Q
;IBCNSUX1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSUX1 4552 printed Sep 23, 2025@19:54:24 Page 2
IBCNSUX1 ;ALB/CMS - SPLIT COMBINATION PLANS CONT. ; 04-NOV-98
+1 ;;2.0;INTEGRATED BILLING;**103,133,516**;21-MAR-94;Build 123
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
BEG ; -- Start to process policy separation from IBCNSUX
+1 ; Input: IBINS=Selected Medicare Company
+2 ; IBPLAN=Selected Combination Plan
+3 ; IBWNR=MED WNR INS IEN^"MEDICARE (WNR)"
+4 ; ^PART A IEN^"PART A"
+5 ; ^PART B IEN^"PART A"
+6 ;
+7 NEW DFN,DO,DD,DA,DR,DIC,DIE,DIK,DIR,DIRUT,X,Y
+8 NEW IBCDFN,IBERR,IB0,IBST,IBSUB1,IBPLANAM
+9 KILL ^TMP($JOB,"IBCNSUX"),^TMP($JOB,"IBCNSUX1")
+10 ;IB*2.0*516/TAZ - Retrieve HIPAA compliant Plan Name.
+11 ;S IBST=$$NOW^XLFDT,IBPLANAM=$P($G(^IBA(355.3,IBPLAN,0)),U,3)
+12 ; 516 - baa
SET IBST=$$NOW^XLFDT
SET IBPLANAM=$$GET1^DIQ(355.3,IBPLAN,2.01)
+13 SET IBSUB1=$$SUBS^IBCNSJ(IBINS,IBPLAN,0,"^TMP($J,""IBCNSUX1"")")
+14 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,"IBCNSUX1",DFN))
if 'DFN
QUIT
Begin DoDot:1
+15 SET IBCDFN=0
FOR
SET IBCDFN=$ORDER(^TMP($JOB,"IBCNSUX1",DFN,IBCDFN))
if 'IBCDFN
QUIT
Begin DoDot:2
+16 SET IB0=$GET(^DPT(DFN,.312,IBCDFN,0))
+17 IF $PIECE(IB0,U,18)'=+IBPLAN
QUIT
+18 ;
+19 ; -- check for duplicate
+20 DO DUP
+21 ;
+22 ; -- if the policy to be split has no COB, and both an A and B
+23 ; -- policy need to be created, set it to Primary
+24 IF '$PIECE(IB0,"^",20)
IF '$DATA(^TMP($JOB,"IBCNSUX","ERR",DFN,2))
IF '$DATA(^(1))
Begin DoDot:3
+25 NEW DIE,DA,DR,X,Y
+26 SET DIE="^DPT("_DFN_",.312,"
SET DA=+IBCDFN
SET DA(1)=DFN
SET DR=".2////1"
DO ^DIE
End DoDot:3
+27 ;
+28 ; -- create Medicare (WNR) policies if none exists
+29 IF '$DATA(^TMP($JOB,"IBCNSUX","ERR",DFN,2))
DO ADDB
+30 IF '$DATA(^TMP($JOB,"IBCNSUX","ERR",DFN,1))
DO SETA
End DoDot:2
End DoDot:1
+31 ;
+32 ; -- delete combination plan if no subscribers left.
+33 IF '$$SUBS^IBCNSJ(IBINS,IBPLAN)
DO DEL^IBCNSJ(IBPLAN)
+34 ;
+35 DO WRT
+36 ;
BEGQ KILL ^TMP($JOB,"IBCNSUX"),^TMP($JOB,"IBCNSUX1")
+1 QUIT
+2 ;
+3 ;
ADDB ; -- Create a New MEDICARE PART B patient policy
+1 NEW DA,DIC,DIE,DR,IBBDFN,IBC,IBX,X,Y,IBCDA,IBNDA,IBN
+2 KILL DD,D0
+3 ;
+4 SET DIC("DR")=".01////"_+IBWNR_";1.09////1;1.05///NOW;1.06////"_DUZ_";.18////"_$PIECE(IBWNR,U,5)
+5 ;
+6 ; -- If the policy to be split has no COB, and a valid Part A policy
+7 ; -- already exists, set the COB to Primary
+8 IF '$PIECE(IB0,"^",20)
IF $DATA(^TMP($JOB,"IBCNSUX","ERR",DFN,1))
SET DIC("DR")=DIC("DR")_";.2////1"
+9 ;
+10 SET DA(1)=DFN
SET DIC="^DPT("_DFN_",.312,"
SET DIC(0)="L"
SET X=+IBWNR
SET DLAYGO=2.312
+11 DO FILE^DICN
SET IBBDFN=+Y
KILL DIC
+12 IF IBBDFN<1
SET ^TMP($JOB,"IBCNSUX","ERR",DFN,3)="Could not create a Part B policy."
GOTO ADDBQ
+13 ;
+14 ; -- Get settings of combination policy
+15 SET IBCDA=IBCDFN_","_DFN_","
+16 DO GETS^DIQ(2.312,IBCDA,"*","IN","IBC")
+17 IF $DATA(IBC("IBERR"))
SET ^TMP($JOB,"IBCNSUX","ERR",DFN,3)="Could not set Part B policy data."
GOTO ADDBQ
+18 ;
+19 ; -- Set Medicare Part B policy data - copy combination policy data to new new Part B policy
+20 SET IBNDA=+IBBDFN_","_DFN_","
+21 SET IBX=0
FOR
SET IBX=$ORDER(IBC(2.312,IBCDA,IBX))
if IBX=""
QUIT
Begin DoDot:1
+22 ;
+23 ; -- Don't set system edited or triggered fields
+24 IF ",.01,1.01,1.02,1.1,1.05,1.06,.18,"[(","_IBX_",")
QUIT
+25 ;
+26 SET IBN(2.312,IBNDA,IBX)=IBC(2.312,IBCDA,IBX,"I")
End DoDot:1
+27 IF $ORDER(IBN(0))
DO FILE^DIE("","IBN")
ADDBQ QUIT
+1 ;
SETA ; -- Change policy to point to Part A
+1 NEW DIE,DA,DR,X,Y
+2 SET DIE="^DPT("_DFN_",.312,"
SET DA=+IBCDFN
SET DA(1)=DFN
+3 SET DR=".01////"_+IBWNR_";.18////"_$PIECE(IBWNR,U,3)
+4 ;
+5 ; - if this policy still has no COB, set it to primary
+6 IF '$PIECE($GET(^DPT(DFN,.312,IBCDFN,0)),"^",20)
SET DR=DR_";.2////1"
+7 DO ^DIE
+8 QUIT
+9 ;
DUP ; -- Check for duplicate
+1 NEW IBX,IB0,X,Y
+2 SET IBX=0
FOR
SET IBX=$ORDER(^DPT(DFN,.312,"B",+IBWNR,IBX))
if 'IBX
QUIT
Begin DoDot:1
+3 SET IB0=$GET(^DPT(DFN,.312,IBX,0))
+4 IF $PIECE(IB0,U,18)=$PIECE(IBWNR,U,3)
SET ^TMP($JOB,"IBCNSUX","ERR",DFN,1)="Medicare (WNR) Part A policy already exists."
QUIT
+5 IF $PIECE(IB0,U,18)=$PIECE(IBWNR,U,5)
SET ^TMP($JOB,"IBCNSUX","ERR",DFN,2)="Medicare (WNR) Part B policy already exists."
QUIT
End DoDot:1
+6 QUIT
+7 ;
WRT ; -- write report
+1 NEW IBX,VA,VADM,VAERR,X,Y
+2 WRITE @IOF,!,"Separate Medicare Combination policies Part A and Part B"
+3 WRITE !!,"Process started ",$$FMTE^XLFDT(IBST)," ended ",$$FMTE^XLFDT($$NOW^XLFDT)
+4 WRITE !,?10,"Run by: ",$PIECE($GET(^VA(200,+$GET(DUZ),0)),U,1)
+5 WRITE !!,?5,"Combination Company: ",$PIECE($GET(^DIC(36,IBINS,0)),U,1)
+6 WRITE !?3,"Combination Plan Name: ",IBPLANAM
if '$DATA(^IBA(355.3,IBPLAN,0))
WRITE " (This plan was deleted)"
+7 WRITE !
FOR IBX=1:1:79
WRITE "="
+8 ;
+9 IF '$ORDER(^TMP($JOB,"IBCNSUX","ERR",0))
WRITE !!,"SUCCESSFULLY COMPLETED, COMBINATION PLAN DELETED."
GOTO WRTQ
+10 ;
+11 WRITE !,"Exception Report:"
+12 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,"IBCNSUX","ERR",DFN))
if 'DFN
QUIT
Begin DoDot:1
+13 KILL VADM
DO DEM^VADPT
+14 WRITE !!,VADM(1),?32,"SSN: ",$PIECE(VADM(2),U,2),?50,"DOB: ",$PIECE(VADM(3),U,2)
+15 SET IBX=0
FOR
SET IBX=$ORDER(^TMP($JOB,"IBCNSUX","ERR",DFN,IBX))
if 'IBX
QUIT
Begin DoDot:2
+16 WRITE !,?5,^TMP($JOB,"IBCNSUX","ERR",DFN,IBX)
End DoDot:2
End DoDot:1
WRTQ QUIT
+1 ;IBCNSUX1
