IBCNSJ13 ;ALB/CPM - INACTIVATE AN INSURANCE PLAN (CON'T) ; 18-JAN-95
;;Version 2.0 ; INTEGRATED BILLING ;**28,62,52**; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
REP(IBCNS,IBNEWP,IBOLDP,IBMER) ; Repoint patient policies from old to new plan
; Input: IBCNS -- Pointer to the company in file #36 which
; offers the plans
; IBNEWP -- Pointer to the new plan in file #355.3
; IBOLDP -- Pointer to the old plan in file #355.3
; IBMER -- [optional]: set to 1 if benefits used should
; be merged instead of deleted
;
I '$G(IBCNS)!'$G(IBNEWP)!'$G(IBOLDP) G REPQ
N DA,DFN,DIE,DR,IBARR,IBCDFN,IBCBUM,IBCBUD,IBSUB1
S (IBCBUM,IBCBUD)=0 W !,"Repointing all policies to the new plan...",!
K ^TMP($J,"IBSUBS")
S IBSUB1=$$SUBS^IBCNSJ(IBCNS,IBOLDP,0,"^TMP($J,""IBSUBS"")")
S DFN=0 F S DFN=$O(^TMP($J,"IBSUBS",DFN)) Q:'DFN D
.S IBCDFN=0 F S IBCDFN=$O(^TMP($J,"IBSUBS",DFN,IBCDFN)) Q:'IBCDFN D
..Q:$P($G(^DPT(DFN,.312,IBCDFN,0)),"^",18)'=IBOLDP
..D SWPL(IBNEWP,DFN,IBCDFN) W "."
..;
..; - merge or delete previous benefits used
..S IBDAT="" F S IBDAT=$O(^IBA(355.5,"APPY",DFN,IBOLDP,IBDAT)) Q:IBDAT="" D
...S IBCDFN1=0 F S IBCDFN1=$O(^IBA(355.5,"APPY",DFN,IBOLDP,IBDAT,IBCDFN1)) Q:'IBCDFN1 I IBCDFN1=IBCDFN S IBBU=$O(^(IBCDFN1,0)) D
....I '$D(^IBA(355.4,"APY",IBNEWP,IBDAT))!'$G(IBMER) D DBU^IBCNSJ(IBBU) S IBCBUD=IBCBUD+1 Q
....D MERG(IBNEWP,IBBU) S IBCBUM=IBCBUM+1
;
W !,"All policies have been re-pointed to the new plan."
I 'IBCBUD,'IBCBUM W !,"There were no Benefits Used merged or deleted." G REPQ
W !,$S(IBCBUM:IBCBUM,1:"No")," Benefits Used record",$S(IBCBUM=1:" was",1:"s were")," merged."
W !,$S(IBCBUD:IBCBUD,1:"No")," Benefits Used record",$S(IBCBUD=1:" was",1:"s were")," deleted."
REPQ K ^TMP($J,"IBSUBS")
Q
;
SWPL(IBCPOL,DFN,IBCDFN) ; Change plan in policy.
; Input: IBCPOL -- Pointer to the new plan in file #355.3
; DFN -- Pointer to the patient in file #2
; IBCDFN -- Pointer to the policy in file #2.312
;
I '$G(IBCPOL)!'$G(DFN)!'$G(IBCDFN) G SWPLQ
S DR=".18////"_IBCPOL_";1.05///NOW;1.06////"_DUZ
S DA=IBCDFN,DA(1)=DFN,DIE="^DPT("_DFN_",.312," D ^DIE K DIE,DA,DR
D COV^IBCNSJ(DFN) ; adjust 'Covered by Insurance' field
D POL^IBCNSU41(DFN) ; stuff sponsor data into Tricare policies
SWPLQ Q
;
MERG(IBCPOL,IBBU,IBD) ; Merge previous benefits used into a new plan.
; Input: IBCPOL -- Pointer to the new plan in file #355.3
; IBBU -- Pointer to the benefit to merged in file #355.5
; IBD -- [optional] : new date for the benefit used
;
N DIC,DLAYGO,IBCBU,X,Y
I '$G(IBCPOL)!'$G(IBBU) G MERGQ
S X=IBCPOL,DIC(0)="L",DLAYGO=355.5,DIC="^IBA(355.5,"
K DD,DO D FILE^DICN G:+Y<0 MERGQ S IBCBU=+Y
S $P(^IBA(355.5,IBCBU,0),"^",2,30)=$P($G(^IBA(355.5,IBBU,0)),"^",2,30)
I $G(IBD) S $P(^IBA(355.5,IBCBU,0),"^",3)=IBD
I $D(^IBA(355.5,IBBU,1)) S ^IBA(355.5,IBCBU,1)=^(1)
S DA=IBCBU,DIK="^IBA(355.5," D IX1^DIK,EDUP^IBCNSD1
D DBU^IBCNSJ(IBBU)
MERGQ Q
;
BU(IBQ) ; Be sure user really wants to repoint policies with benefits used.
; Required variable input:
; IBCPOL -- Pointer to the new plan in file #355.3
;
; Formal parameter output:
; IBQ -- Set to 1 if user wishes to quit
;
; Optional variable output:
; IBMERGE -- Set to 1 if user wishes to merge applicable benefits
; IBREP -- Set to 0 if user does not want to repoint policies
;
S IBQ=0 I '$D(^IBA(355.4,"APY",IBCPOL)) D G BUQ
.W !!,*7," ** Please Note **",!!?5,"The selected plan has no Annual Benefits with which to associate"
.W !?5,"the Benefits Used from the current plan!"
.W !!?5,"If you re-point all policies to this plan, the Benefits Used for"
.W !?5,"the current plan will be deleted!!"
;
S DIR("A",1)="The selected plan has Annual Benefits on file. Should the repointing"
S DIR("A")="of the policies attempt to merge all transferable benefits"
S DIR(0)="Y",DIR("?")="^D HLMT^IBCNSJ11" D ^DIR K DIR
S IBMERGE=Y
I $D(DIRUT) K DIRUT,DTOUT,DUOUT,DIROUT D
.S DIR(0)="Y",DIR("A")=" Do you still wish to re-point these policies to a new plan",DIR("?")="^D HLRP^IBCNSJ11"
.W ! D ^DIR K DIR I $D(DIRUT) S IBQ=1 D DELP^IBCNSJ11 Q
.K DIRUT,DTOUT,DUOUT,DIROUT I 'Y S IBREP=0 D MAIL^IBCNSJ11,DELP^IBCNSJ11
BUQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSJ13 4461 printed Dec 13, 2024@02:17:15 Page 2
IBCNSJ13 ;ALB/CPM - INACTIVATE AN INSURANCE PLAN (CON'T) ; 18-JAN-95
+1 ;;Version 2.0 ; INTEGRATED BILLING ;**28,62,52**; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
REP(IBCNS,IBNEWP,IBOLDP,IBMER) ; Repoint patient policies from old to new plan
+1 ; Input: IBCNS -- Pointer to the company in file #36 which
+2 ; offers the plans
+3 ; IBNEWP -- Pointer to the new plan in file #355.3
+4 ; IBOLDP -- Pointer to the old plan in file #355.3
+5 ; IBMER -- [optional]: set to 1 if benefits used should
+6 ; be merged instead of deleted
+7 ;
+8 IF '$GET(IBCNS)!'$GET(IBNEWP)!'$GET(IBOLDP)
GOTO REPQ
+9 NEW DA,DFN,DIE,DR,IBARR,IBCDFN,IBCBUM,IBCBUD,IBSUB1
+10 SET (IBCBUM,IBCBUD)=0
WRITE !,"Repointing all policies to the new plan...",!
+11 KILL ^TMP($JOB,"IBSUBS")
+12 SET IBSUB1=$$SUBS^IBCNSJ(IBCNS,IBOLDP,0,"^TMP($J,""IBSUBS"")")
+13 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,"IBSUBS",DFN))
if 'DFN
QUIT
Begin DoDot:1
+14 SET IBCDFN=0
FOR
SET IBCDFN=$ORDER(^TMP($JOB,"IBSUBS",DFN,IBCDFN))
if 'IBCDFN
QUIT
Begin DoDot:2
+15 if $PIECE($GET(^DPT(DFN,.312,IBCDFN,0)),"^",18)'=IBOLDP
QUIT
+16 DO SWPL(IBNEWP,DFN,IBCDFN)
WRITE "."
+17 ;
+18 ; - merge or delete previous benefits used
+19 SET IBDAT=""
FOR
SET IBDAT=$ORDER(^IBA(355.5,"APPY",DFN,IBOLDP,IBDAT))
if IBDAT=""
QUIT
Begin DoDot:3
+20 SET IBCDFN1=0
FOR
SET IBCDFN1=$ORDER(^IBA(355.5,"APPY",DFN,IBOLDP,IBDAT,IBCDFN1))
if 'IBCDFN1
QUIT
IF IBCDFN1=IBCDFN
SET IBBU=$ORDER(^(IBCDFN1,0))
Begin DoDot:4
+21 IF '$DATA(^IBA(355.4,"APY",IBNEWP,IBDAT))!'$GET(IBMER)
DO DBU^IBCNSJ(IBBU)
SET IBCBUD=IBCBUD+1
QUIT
+22 DO MERG(IBNEWP,IBBU)
SET IBCBUM=IBCBUM+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+23 ;
+24 WRITE !,"All policies have been re-pointed to the new plan."
+25 IF 'IBCBUD
IF 'IBCBUM
WRITE !,"There were no Benefits Used merged or deleted."
GOTO REPQ
+26 WRITE !,$SELECT(IBCBUM:IBCBUM,1:"No")," Benefits Used record",$SELECT(IBCBUM=1:" was",1:"s were")," merged."
+27 WRITE !,$SELECT(IBCBUD:IBCBUD,1:"No")," Benefits Used record",$SELECT(IBCBUD=1:" was",1:"s were")," deleted."
REPQ KILL ^TMP($JOB,"IBSUBS")
+1 QUIT
+2 ;
SWPL(IBCPOL,DFN,IBCDFN) ; Change plan in policy.
+1 ; Input: IBCPOL -- Pointer to the new plan in file #355.3
+2 ; DFN -- Pointer to the patient in file #2
+3 ; IBCDFN -- Pointer to the policy in file #2.312
+4 ;
+5 IF '$GET(IBCPOL)!'$GET(DFN)!'$GET(IBCDFN)
GOTO SWPLQ
+6 SET DR=".18////"_IBCPOL_";1.05///NOW;1.06////"_DUZ
+7 SET DA=IBCDFN
SET DA(1)=DFN
SET DIE="^DPT("_DFN_",.312,"
DO ^DIE
KILL DIE,DA,DR
+8 ; adjust 'Covered by Insurance' field
DO COV^IBCNSJ(DFN)
+9 ; stuff sponsor data into Tricare policies
DO POL^IBCNSU41(DFN)
SWPLQ QUIT
+1 ;
MERG(IBCPOL,IBBU,IBD) ; Merge previous benefits used into a new plan.
+1 ; Input: IBCPOL -- Pointer to the new plan in file #355.3
+2 ; IBBU -- Pointer to the benefit to merged in file #355.5
+3 ; IBD -- [optional] : new date for the benefit used
+4 ;
+5 NEW DIC,DLAYGO,IBCBU,X,Y
+6 IF '$GET(IBCPOL)!'$GET(IBBU)
GOTO MERGQ
+7 SET X=IBCPOL
SET DIC(0)="L"
SET DLAYGO=355.5
SET DIC="^IBA(355.5,"
+8 KILL DD,DO
DO FILE^DICN
if +Y<0
GOTO MERGQ
SET IBCBU=+Y
+9 SET $PIECE(^IBA(355.5,IBCBU,0),"^",2,30)=$PIECE($GET(^IBA(355.5,IBBU,0)),"^",2,30)
+10 IF $GET(IBD)
SET $PIECE(^IBA(355.5,IBCBU,0),"^",3)=IBD
+11 IF $DATA(^IBA(355.5,IBBU,1))
SET ^IBA(355.5,IBCBU,1)=^(1)
+12 SET DA=IBCBU
SET DIK="^IBA(355.5,"
DO IX1^DIK
DO EDUP^IBCNSD1
+13 DO DBU^IBCNSJ(IBBU)
MERGQ QUIT
+1 ;
BU(IBQ) ; Be sure user really wants to repoint policies with benefits used.
+1 ; Required variable input:
+2 ; IBCPOL -- Pointer to the new plan in file #355.3
+3 ;
+4 ; Formal parameter output:
+5 ; IBQ -- Set to 1 if user wishes to quit
+6 ;
+7 ; Optional variable output:
+8 ; IBMERGE -- Set to 1 if user wishes to merge applicable benefits
+9 ; IBREP -- Set to 0 if user does not want to repoint policies
+10 ;
+11 SET IBQ=0
IF '$DATA(^IBA(355.4,"APY",IBCPOL))
Begin DoDot:1
+12 WRITE !!,*7," ** Please Note **",!!?5,"The selected plan has no Annual Benefits with which to associate"
+13 WRITE !?5,"the Benefits Used from the current plan!"
+14 WRITE !!?5,"If you re-point all policies to this plan, the Benefits Used for"
+15 WRITE !?5,"the current plan will be deleted!!"
End DoDot:1
GOTO BUQ
+16 ;
+17 SET DIR("A",1)="The selected plan has Annual Benefits on file. Should the repointing"
+18 SET DIR("A")="of the policies attempt to merge all transferable benefits"
+19 SET DIR(0)="Y"
SET DIR("?")="^D HLMT^IBCNSJ11"
DO ^DIR
KILL DIR
+20 SET IBMERGE=Y
+21 IF $DATA(DIRUT)
KILL DIRUT,DTOUT,DUOUT,DIROUT
Begin DoDot:1
+22 SET DIR(0)="Y"
SET DIR("A")=" Do you still wish to re-point these policies to a new plan"
SET DIR("?")="^D HLRP^IBCNSJ11"
+23 WRITE !
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET IBQ=1
DO DELP^IBCNSJ11
QUIT
+24 KILL DIRUT,DTOUT,DUOUT,DIROUT
IF 'Y
SET IBREP=0
DO MAIL^IBCNSJ11
DO DELP^IBCNSJ11
End DoDot:1
BUQ QUIT
