IBCNSJ2 ;ALB/CPM - CHANGE POLICY PLAN ; 03-JAN-95
;;2.0;INTEGRATED BILLING;**28,516**;21-MAR-94;Build 123
;;Per VA Directive 6402, this routine should not be modified.
;
CSTP ; 'Change Policy Plan' Action
; Required variable input:
; DFN -- Pointer to the patient in file #2
; IBPPOL -- Patient insurance policy definition
;
N DA,DIK,IBCDFN,IBCPOL,IBNEWP,IBX,IBPLAN,IBPLAND,X
N IBCNS,IBALR,IBMERGE,IBIP,IBBU,IBAB,IBMRGN,IBMRGF,IBX
S IBCDFN=$P($G(IBPPOL),"^",4)
I '$G(DFN)!'IBCDFN G CSTPQ
D FULL^VALM1
I '$D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ)) W !!,"Sorry, but you do not have the required privileges to change the policy plan." G CSTPQ
;
;IB*2.0*516/TAZ - Use HIPAA Compliant fields
S X=$G(^DPT(DFN,.312,IBCDFN,0)) I 'X W !!,"This policy is not valid!" G CSTPQ
;S IBCNS=+X,IBPLAN=+$P(X,"^",18),IBPLAND=$G(^IBA(355.3,IBPLAN,0)) ;516 - baa
;I 'IBPLAN D NOPL G CSTPQ
S IBCNS=+X,IBPLAN=+$P(X,"^",18) I 'IBPLAN D NOPL G CSTPQ
;Insert HIPAA compliant fields into the original data string.
S IBPLAND=$G(^IBA(355.3,IBPLAN,0)),$P(IBPLAND,U,3)=$$GET1^DIQ(355.3,IBPLAN_",",2.01),$P(IBPLAND,U,4)=$$GET1^DIQ(355.3,IBPLAN_",",2.02)
I 'IBPLAND W !!,"This plan has no company! Please contact your IRM for assistance." G CSTPQ
I IBCNS'=+IBPLAND D PLAN^IBCNSM32(DFN,IBCDFN,+IBPLAND) G CSTPQ
;
; - introduction
W !!,"This action will allow you to change the insurance plan to which the"
W !,"veteran is subscribing through this policy."
W !!,$S($P(IBPLAND,"^",2):"Group",1:"Individual")," Plan Number: ",$S($P(IBPLAND,"^",4)]"":$P(IBPLAND,"^",4),1:"<not specified>"),?50,"Plan Name: ",$S($P(IBPLAND,"^",3)]"":$P(IBPLAND,"^",3),1:"<not specified>"),!
D NOTES^IBCNSJ21
;
; - select or add a new plan for the policy
D GETPL^IBCNSJ12
I 'IBCPOL W !,"Can't change subscribed-to plan..." G CSTPQ
;
; - last few notes
I IBIP W !,*7," *** Please note that this Individual Plan will be deleted if you select",!," to switch plans associated with this policy."
I '$O(IBBU(0)) G OK
W !,*7,"This patient has Benefits Used associated with his current plan and policy!"
D AB^IBCNSJ21 I '$O(IBAB(0)) W !,"The newly proposed subscribed-to plan has no associated Annual Benefits,",!,"so the Benefits Used associated with the current plan will be deleted!" G OK
;
; - display mergeable benefits used
D DMBU^IBCNSJ21
W !!,"Please note that ",$S('$O(IBMRGF(0)):"no",$G(IBMRGN):"some",1:"all")," Benefits Used are transferable."
I $G(IBMRGN) W !,$S('$O(IBMRGF(0)):"All Benefits Used",1:"Note that those Benefits Used which cannot be merged")," will be deleted!"
I '$O(IBMRGF(0)) G OK
;
; - merge or delete previous benefits used?
S DIR(0)="Y",DIR("A")="Do you want to merge the transferable Benefits Used",DIR("?")="^D HLMT^IBCNSJ11"
W ! D ^DIR K DIR I $D(DIRUT) D DELP^IBCNSJ11 G CSTPQ
S IBMERGE=Y
W !,$S(IBMERGE:"The transferable",1:"All")," Benefits Used will be ",$S(IBMERGE:"merged.",1:"deleted.")
;
OK ; - okay to switch subscribed-to plan?
S DIR(0)="Y",DIR("A")="Okay to change the subscribed-to plan",DIR("?")="^D HLSW^IBCNSJ21"
W ! D ^DIR K DIR,DIRUT,DTOUT,DUOUT,DIROUT
I 'Y W !!,"The subscribed-to plan for this policy was not changed.",! D DELP^IBCNSJ11 G CSTPQ
;
; - change plan in policy; adjust 'covered by insurance' field
W !!,"Changing the subscribed-to plan... " D SWPL^IBCNSJ13(IBCPOL,DFN,IBCDFN) W "done."
;
; - merge/delete benefits used, if necessary
D MD^IBCNSJ21
;
; - delete the previous individual plan, if necessary
I IBIP W !,"Deleting the formerly subscribed-to Individual Plan... " D DEL^IBCNSJ(IBPLAN) W "done." G CSTPQ
;
; - if plan no longer has subscribers, say so.
I '$$SUBS^IBCNSJ(IBCNS,IBPLAN,1) W !!,"There are no longer any subscribers to the previous plan. You may wish",!,"to inactivate or delete this plan using the 'Inactivate Plan' action."
;
CSTPQ D PAUSE^VALM1
D HDR^IBCNSP,BLD^IBCNSP S VALMBCK="R"
Q
;
NOPL ; Display message if there is no insurance plan.
W !!,"There is no plan associated with this policy!"
W !!,"Please use the action 'Change Plan Info', which will create a plan"
W !,"for the policy."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSJ2 4204 printed Apr 09, 2024@21:38:01 Page 2
IBCNSJ2 ;ALB/CPM - CHANGE POLICY PLAN ; 03-JAN-95
+1 ;;2.0;INTEGRATED BILLING;**28,516**;21-MAR-94;Build 123
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
CSTP ; 'Change Policy Plan' Action
+1 ; Required variable input:
+2 ; DFN -- Pointer to the patient in file #2
+3 ; IBPPOL -- Patient insurance policy definition
+4 ;
+5 NEW DA,DIK,IBCDFN,IBCPOL,IBNEWP,IBX,IBPLAN,IBPLAND,X
+6 NEW IBCNS,IBALR,IBMERGE,IBIP,IBBU,IBAB,IBMRGN,IBMRGF,IBX
+7 SET IBCDFN=$PIECE($GET(IBPPOL),"^",4)
+8 IF '$GET(DFN)!'IBCDFN
GOTO CSTPQ
+9 DO FULL^VALM1
+10 IF '$DATA(^XUSEC("IB INSURANCE SUPERVISOR",DUZ))
WRITE !!,"Sorry, but you do not have the required privileges to change the policy plan."
GOTO CSTPQ
+11 ;
+12 ;IB*2.0*516/TAZ - Use HIPAA Compliant fields
+13 SET X=$GET(^DPT(DFN,.312,IBCDFN,0))
IF 'X
WRITE !!,"This policy is not valid!"
GOTO CSTPQ
+14 ;S IBCNS=+X,IBPLAN=+$P(X,"^",18),IBPLAND=$G(^IBA(355.3,IBPLAN,0)) ;516 - baa
+15 ;I 'IBPLAN D NOPL G CSTPQ
+16 SET IBCNS=+X
SET IBPLAN=+$PIECE(X,"^",18)
IF 'IBPLAN
DO NOPL
GOTO CSTPQ
+17 ;Insert HIPAA compliant fields into the original data string.
+18 SET IBPLAND=$GET(^IBA(355.3,IBPLAN,0))
SET $PIECE(IBPLAND,U,3)=$$GET1^DIQ(355.3,IBPLAN_",",2.01)
SET $PIECE(IBPLAND,U,4)=$$GET1^DIQ(355.3,IBPLAN_",",2.02)
+19 IF 'IBPLAND
WRITE !!,"This plan has no company! Please contact your IRM for assistance."
GOTO CSTPQ
+20 IF IBCNS'=+IBPLAND
DO PLAN^IBCNSM32(DFN,IBCDFN,+IBPLAND)
GOTO CSTPQ
+21 ;
+22 ; - introduction
+23 WRITE !!,"This action will allow you to change the insurance plan to which the"
+24 WRITE !,"veteran is subscribing through this policy."
+25 WRITE !!,$SELECT($PIECE(IBPLAND,"^",2):"Group",1:"Individual")," Plan Number: ",$SELECT($PIECE(IBPLAND,"^",4)]"":$PIECE(IBPLAND,"^",4),1:"<not specified>"),?50,"Plan Name: ",$SELECT($PIECE(IBPLAND,"^",3)]"":$PIECE(IBPLAND,"^",3),1:"<not specifi
ed>"),!
+26 DO NOTES^IBCNSJ21
+27 ;
+28 ; - select or add a new plan for the policy
+29 DO GETPL^IBCNSJ12
+30 IF 'IBCPOL
WRITE !,"Can't change subscribed-to plan..."
GOTO CSTPQ
+31 ;
+32 ; - last few notes
+33 IF IBIP
WRITE !,*7," *** Please note that this Individual Plan will be deleted if you select",!," to switch plans associated with this policy."
+34 IF '$ORDER(IBBU(0))
GOTO OK
+35 WRITE !,*7,"This patient has Benefits Used associated with his current plan and policy!"
+36 DO AB^IBCNSJ21
IF '$ORDER(IBAB(0))
WRITE !,"The newly proposed subscribed-to plan has no associated Annual Benefits,",!,"so the Benefits Used associated with the current plan will be deleted!"
GOTO OK
+37 ;
+38 ; - display mergeable benefits used
+39 DO DMBU^IBCNSJ21
+40 WRITE !!,"Please note that ",$SELECT('$ORDER(IBMRGF(0)):"no",$GET(IBMRGN):"some",1:"all")," Benefits Used are transferable."
+41 IF $GET(IBMRGN)
WRITE !,$SELECT('$ORDER(IBMRGF(0)):"All Benefits Used",1:"Note that those Benefits Used which cannot be merged")," will be deleted!"
+42 IF '$ORDER(IBMRGF(0))
GOTO OK
+43 ;
+44 ; - merge or delete previous benefits used?
+45 SET DIR(0)="Y"
SET DIR("A")="Do you want to merge the transferable Benefits Used"
SET DIR("?")="^D HLMT^IBCNSJ11"
+46 WRITE !
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
DO DELP^IBCNSJ11
GOTO CSTPQ
+47 SET IBMERGE=Y
+48 WRITE !,$SELECT(IBMERGE:"The transferable",1:"All")," Benefits Used will be ",$SELECT(IBMERGE:"merged.",1:"deleted.")
+49 ;
OK ; - okay to switch subscribed-to plan?
+1 SET DIR(0)="Y"
SET DIR("A")="Okay to change the subscribed-to plan"
SET DIR("?")="^D HLSW^IBCNSJ21"
+2 WRITE !
DO ^DIR
KILL DIR,DIRUT,DTOUT,DUOUT,DIROUT
+3 IF 'Y
WRITE !!,"The subscribed-to plan for this policy was not changed.",!
DO DELP^IBCNSJ11
GOTO CSTPQ
+4 ;
+5 ; - change plan in policy; adjust 'covered by insurance' field
+6 WRITE !!,"Changing the subscribed-to plan... "
DO SWPL^IBCNSJ13(IBCPOL,DFN,IBCDFN)
WRITE "done."
+7 ;
+8 ; - merge/delete benefits used, if necessary
+9 DO MD^IBCNSJ21
+10 ;
+11 ; - delete the previous individual plan, if necessary
+12 IF IBIP
WRITE !,"Deleting the formerly subscribed-to Individual Plan... "
DO DEL^IBCNSJ(IBPLAN)
WRITE "done."
GOTO CSTPQ
+13 ;
+14 ; - if plan no longer has subscribers, say so.
+15 IF '$$SUBS^IBCNSJ(IBCNS,IBPLAN,1)
WRITE !!,"There are no longer any subscribers to the previous plan. You may wish",!,"to inactivate or delete this plan using the 'Inactivate Plan' action."
+16 ;
CSTPQ DO PAUSE^VALM1
+1 DO HDR^IBCNSP
DO BLD^IBCNSP
SET VALMBCK="R"
+2 QUIT
+3 ;
NOPL ; Display message if there is no insurance plan.
+1 WRITE !!,"There is no plan associated with this policy!"
+2 WRITE !!,"Please use the action 'Change Plan Info', which will create a plan"
+3 WRITE !,"for the policy."
+4 QUIT
