IBCNSUR ;ALB/CPM/CMS - MOVE SUBSCRIBERS TO DIFFERENT PLAN ; 09-SEP-96
;;2.0;INTEGRATED BILLING;**103,276,506,516,549,602,664,702,732**;21-MAR-94;Build 13
;;Per VA Directive 6402, this routine should not be modified.
Q
;
EN ; Entry point from option. Main processing loop.
I $S('($D(DUZ)#2):1,'$D(^VA(200,+DUZ,0)):1,1:0) W !!?3,"The variable DUZ must be set to an active user code before continuing." G ENQ
W !!,?5,"MOVE SUBSCRIBERS OF ONE PLAN TO ANOTHER PLAN"
W !,?5,"This option may be used to move subscribers from a selected Plan"
W !,?5,"to a different Plan. The plans may be associated with the same"
W !,?5,"Insurance Company or a different one. Plan and Annual Benefit"
W !,?5,"information may be moved as well. Users of this option should"
W !,?5,"be knowledgeable of the VistA Patient Insurance management options."
W !
W !,?5,"This option also gives the user the option to expire the old plan or"
W !,?5,"replace it completely in the patient insurance profile. The reason"
W !,?5,"to expire the old plan is intended for use when Insurance groups change"
W !,?5,"PBMs for processing electronic Pharmacy claims. By leaving the old"
W !,?5,"plan information intact (i.e. do not replace), the user will be able"
W !,?5,"to monitor PBM changes that affect the electronic Pharmacy claims."
;
W !!,$TR($J("",75)," ","-")
S IBSTOP=0 F D PROC^IBCNSUR1 Q:IBSTOP
ENQ K IBSTOP
Q
;
PROC ; - Process continuation from IBCNSUR1.
; - display old plan attributes; allow new plan to be edited
D PL^IBCNSUR2
R !!,?10,"Press any key to continue. ",IBX:DTIME
;
; - display coverage limitations; allow add/edit of plan 2 limitations
D LIM^IBCNSUR2
;
I $P($G(^IBA(355.3,IBP1,0)),"^",11) W !!,"Please note that ",IBC1N,"'s",!,"plan, subscribers were moved from, is already inactive." G PROCDP
;
; - does the user wish to inactivate the old plan?
W !! S DIR(0)="Y",DIR("A")="Do you wish to inactivate "_IBC1N_"'s plan subscribers were moved from"
S DIR("?")="If you wish to inactivate the old plan, enter 'Yes' - otherwise, enter 'No.'"
D ^DIR K DIR I 'Y W !," <The old plan is still active>" G PROCQ
;
D IRACT^IBCNSJ(IBP1,1) W !!,"The plan has been inactivated."
;
PROCDP ; - does the user wish to delete the old plan?
;IB*2*702/CKB - Add checks to determine whether a group is allowed to be delete or not
;
;IB*732/CKB - removed check for the number of subscribers
;If moving entire group by expiring the policy by adding a new effective
; date, do NOT allow the group to be deleted.
I IBGRP,IBSPLIT,$G(IBEFFDT) D NODEL G PROCQ
;
;IB*732/CKB - should only check for only 1 subscriber.
;If moving the entire group (if there is only 1 subscriber) by replacing the
; old group plan,the user they should BE allowed to delete the group.
I IBGRP,(IBSUB=1) G PROCDP1
;
;If moving a subset of subscribers from the group by expiring the policy adding
; a new effective date, do NOT allow the group to be deleted.
;IB*732/CKB - if user selected chose to select subscribers allow for the user
; selecting All or Some of the subscribers
;;***I 'IBGRP,+NUMSEL<IBSUB,$G(IBEFFDT) D NODEL G PROCQ
I 'IBGRP,+NUMSEL'>IBSUB,$G(IBEFFDT) D NODEL G PROCQ
;
;If moving a subset of subscribers from the group by replacing the old group plan,
; do NOT allow the group to be deleted.
;IB*732/CKB - if user selected chose to select subscribers allow for the user
; selecting All or Some of the subscribers
;;***I 'IBGRP,+NUMSEL<IBSUB,'IBSPLIT D NODEL G PROCQ
I 'IBGRP,+NUMSEL'>IBSUB,'IBSPLIT D NODEL G PROCQ
;
PROCDP1 ; Prompt to delete the plan
W !! S DIR(0)="Y",DIR("A")="Do you wish to delete this plan"
S DIR("?")="If you wish to delete the old plan, enter 'Yes' - otherwise, enter 'No.'"
D ^DIR K DIR I 'Y G PROCQ
;
;IB*2*702/CKB - Added a "Are you sure" question before deleting the plan
W ! S DIR(0)="Y",DIR("A")="Are you sure you want to delete this plan"
S DIR("?")="If you're sure you want to delete the old plan, enter 'Yes' - otherwise, enter 'No.'"
D ^DIR K DIR I 'Y G PROCQ
;
D DEL^IBCNSJ(IBP1) W !!,"The plan has been deleted."
;
PROCQ Q
;
NODEL ;IB*2*702/CKB - Display a "not allowed to delete" message to the user
W !,"There are still subscribers to this plan. The plan cannot be deleted.",!
S DIR(0)="EA",DIR("A")="Press RETURN to continue."
D ^DIR K DIR
Q
;
SEL(IBNP) ; Select a company and plan.
; Input: IBNP -- If set to 1, allows adding a new plan and
; -- Screen Inactive Companies
; -- If set to 0, must have at least one group plan
; Output: IBCNS -- Pointer to selected company in file #36
; IBPLAN -- Pointer to selected/added plan in file #355.3
; IBQUIT -- Set to 1 if the user wants to quit.
;
N X,Y K DIC,DIR
S DIC(0)="QEAMZ",DIC="^DIC(36,"
I 'IBNP S DIC("S")="I $$ANYGP^IBCNSJ(+Y,0,1)"
I IBNP S DIC("S")="I '$P($G(^DIC(36,+Y,0)),U,5)"
S DIC("A")="Select INSURANCE COMPANY: "
D ^DIC K DIC S IBCNS=+Y
I Y<0 W " <No Insurance Company selected>" S IBQUIT=1 G SELQ
;
; - if a new plan may be added, allow adding
I IBNP D I (IBPLAN)!(IBQUIT) G SELQ
.W !!,"You may add a new Plan at this time or select an existing Plan."
.; IB*2.0*506 added IBKEY parameter (4th) to the NEW^IBCNSJ3 call (check user's security keys)
.D NEW^IBCNSJ3(IBCNS,.IBPLAN,1,1)
.I 'IBPLAN,'$$ANYGP^IBCNSJ(+IBCNS,0,1) W !!,*7,"Insurance Company receiving subscribers must have a Plan." S IBQUIT=1
;
; - see if user wants to select the plan
W !!,"You may select an existing Plan from a list or enter a specific Plan.",!
S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do you wish to enter a specific plan"
S DIR("?")="The look-up facility to select a group plan has been enhanced to use the List Manager. Enter 'NO' if you wish to select a plan from this look-up, or 'YES' to directly enter a plan."
D ^DIR K DIR I $D(DIRUT) S IBQUIT=1 G SELQ
;
; - invoke the plan look-up
I 'Y D G SELQ
. N IBTITLE
. S IBTITLE="Group Plan Lookup"
. W " ..."
. S IBPLAN=0
. D LKP^IBCNSU2(IBCNS,0,0,.IBPLAN,0,1,IBTITLE)
. I 'IBPLAN W !!,*7,"* No plan selected!",! S IBQUIT=1
;
; - allow a FileMan look-up
; MRD;IB*2.0*516 - Display new Group Name and Number fields.
S DIC("A")="Select a GROUP PLAN: "
S DIC="^IBA(355.3,",DIC(0)="AEQM",DIC("S")="I +^(0)=IBCNS,$P(^(0),U,2)"
;S DIC("W")="N IBX S IBX=$G(^(0)) W "" Name: "",$E($S($P(IBX,U,3)]"""":$P(IBX,U,3),1:""<none>"")_$J("""",20),1,20),"" Number: "",$S($P(IBX,U,4)]"""":$P(IBX,U,4),1:""<none>"")"
S DIC("W")="N IBX S IBX=$G(^(2)) W "" Name: "",$E($S($P(IBX,U,1)]"""":$P(IBX,U,1),1:""<none>"")_$J("""",20),1,20),"" Number: "",$E($S($P(IBX,U,2)]"""":$P(IBX,U,2),1:""<none>""),1,14)"
D ^DIC K DIC S IBPLAN=+Y
I Y<0 W !!,*7,"* No plan selected!",! S IBQUIT=1
;
SELQ K DIRUT,DUOUT,DTOUT,DIROUT
Q
;
EXPGRP ; EP for [IBCN EXPIRE GROUP SUBSCRIBERS]
; IB*2.0*602/DM implement expire group plan
N X,Y,DIC,DIR,DTA,ERR,REF,IBLN,XMDUZ,XMTEXT,XMSUB,XMY
N IBQUIT,IBCNS,IBPLAN,IBSUB,IBEXP,DFN,IBIPOL,IBIENWK
N IBINSNM,IBGRPNM,IBGRPNO,IBEXPOK,IBEXPERR,IBSUPRES,IBCBI
;
W !!,?5,"EXPIRE ALL SUBSCRIBERS WITHIN A GROUP PLAN"
W !,?5,"You can use this option to specify an expiration date for all subscriber"
W !,?5,"policies in a group plan without moving the subscribers to another group"
W !,?5,"plan. If the group plan status is currently ""active"", you can also choose"
W !,?5,"to ""inactivate"" the group plan."
W !!,$TR($J("",75)," ","-")
S IBQUIT=1
;
NXTGRP ; EP for next expire group process
K ^TMP($J,"IBCNSUR") ; subscribers
K ^TMP($J,"IBCNSURBLL") ; bulletin
I 'IBQUIT D
. W !!,"=========================================="
. W !,"EXPIRE ALL SUBSCRIBERS WITHIN A GROUP PLAN"
. W !,"==========================================",!
; get insco and plan
S IBQUIT=0
D SEL^IBCNSUR(0) I IBQUIT Q
;
; Make sure plan has at least one subscriber
I '$$SUBS^IBCNSJ(IBCNS,IBPLAN,0,,1) W !!,?5,*7,"* This group plan has no subscribers!",! G NXTGRP
;
S IBINSNM=$$GET1^DIQ(36,IBCNS_",","NAME")
S IBGRPNM=$$GET1^DIQ(355.3,IBPLAN_",","GROUP NAME")
S IBGRPNO=$$GET1^DIQ(355.3,IBPLAN_",","GROUP NUMBER")
;
W !!,"Collecting Subscribers ..."
S IBSUB=$$SUBS^IBCNSJ(IBCNS,IBPLAN,0,"^TMP($J,""IBCNSUR"")")
W !!,"This group plan has "_+IBSUB_" subscribers. All subscribers will be expired.",!
S DIR(0)="Y"
S DIR("A")="Do you want to expire all subscribers' policies for this plan"
S DIR("?",1)="You will be asked for an expiration date to terminate the attached policies."
S DIR("?",2)="You will have an opportunity to stop if desired."
S DIR("?")="Enter 'Yes' to continue, or 'No' to stop the process now."
D ^DIR K DIR
I 'Y!$D(DIRUT) G NXTGRP
;
W !
; get the expiration date
;IB*2.0*664/TAZ - Force exact date.
S DIR(0)="D^::EX",DIR("A")="Enter expiration date (applies to all subscribers in this plan)"
S DIR("?")="Each active policy will be expired with the expiration date entered."
D ^DIR K DIR
I 'Y!$D(DIRUT) G NXTGRP
S IBEXP=Y
;
W !!,"You selected to expire "_+IBSUB_" subscriber(s) with Expiration Date "_$$FMTE^XLFDT(IBEXP)_" for:"
W !,?5,"Insurance Company "_IBINSNM
W !,?5,"Plan Name "_IBGRPNM_" Number "_IBGRPNO
W !!,"Please Note that the policy will be EXPIRED in the patient profile!!",!
;
S DIR(0)="Y",DIR("A")="Okay to continue"
S DIR("?",1)="If you wish to expire the policies for these subscribers, enter 'Yes'."
S DIR("?")="Otherwise, enter 'No' to exit."
D ^DIR K DIR
I 'Y!$D(DIRUT) G NXTGRP
;
; expire the plan subscribers
; as we process the policies, we'll set the ^TMP nodes to 'O'k or 'E'rror
W !!,"Expiring Policies...",!
S IBSUPRES=1 ; tell COVERED^IBCNSM31 to be quiet
S (IBEXPOK,IBEXPERR)=0
S DFN=0 F S DFN=$O(^TMP($J,"IBCNSUR",DFN)) Q:'DFN D
. S IBIPOL=0 F S IBIPOL=$O(^TMP($J,"IBCNSUR",DFN,IBIPOL)) Q:IBIPOL="" D
.. S IBIENWK=IBIPOL_","_DFN_","
.. Q:$$GET1^DIQ(2.312,IBIENWK,"GROUP PLAN","I")'=IBPLAN
.. Q:+$$GET1^DIQ(2.312,IBIENWK,"INSURANCE EXPIRATION","I")
.. I $$GET1^DIQ(2.312,IBIENWK,"EFFECTIVE DATE OF POLICY","I")>IBEXP S ^TMP($J,"IBCNSUR",DFN,IBIPOL)="E",IBEXPERR=IBEXPERR+1 Q
.. S IBCBI=$$GET1^DIQ(2,DFN_",","COVERED BY HEALTH INSURANCE?","I")
.. K DTA,ERR
.. S DTA(2.312,IBIENWK,3)=IBEXP ; set the expiration date
.. S DTA(2.312,IBIENWK,1.05)=$$NOW^XLFDT() ; last edited
.. S DTA(2.312,IBIENWK,1.06)=DUZ ; by
.. D FILE^DIE("","DTA","ERR")
.. I $D(ERR) S ^TMP($J,"IBCNSUR",DFN,IBIPOL)="E",IBEXPERR=IBEXPERR+1 Q
.. S ^TMP($J,"IBCNSUR",DFN,IBIPOL)="O",IBEXPOK=IBEXPOK+1
.. D COVERED^IBCNSM31(DFN,IBCBI) ; set covered by insurance
;
W !,"Done. "_IBEXPOK_" Subscribers' policies were expired as of "_$$FMTE^XLFDT(IBEXP)_"."
W !,"A Bulletin was sent to you and members of 'IB NEW INSURANCE' Mail Group."
;
; prepare the bulletin
S IBLN=0,REF=$NA(^TMP($J,"IBCNSURBLL"))
D ADD^IBCNSUR3(1,"EXPIRE ALL SUBSCRIBERS WITHIN A GROUP PLAN")
D ADD^IBCNSUR3()
D ADD^IBCNSUR3(1,"You selected to expire ",IBSUB," subscriber(s)")
D ADD^IBCNSUR3()
D ADD^IBCNSUR3(1,"FROM Insurance Company ",IBINSNM)
D ADD^IBCNSUR3(1,"Plan Name ",IBGRPNM," Number ",IBGRPNO)
D ADD^IBCNSUR3()
D ADD^IBCNSUR3(1,"Policies will be expired as of ",$$FMTE^XLFDT(IBEXP),".")
D ADD^IBCNSUR3()
;
I IBEXPERR D
. D ADD^IBCNSUR3(1,"* These ",IBEXPERR," entries could not be processed, they'll need to be adjusted manually")
. W !!,@REF@(IBLN)
. D ADD^IBCNSUR3(1,"-------------------------------------------------------------------------------")
. W !,@REF@(IBLN)
. D ADD^IBCNSUR3(1,"Patient Name/ID Whose Employer Effective Expires")
. W !,@REF@(IBLN),!
. S DFN=0 F S DFN=$O(^TMP($J,"IBCNSUR",DFN)) Q:'DFN D
.. S IBIPOL=0 F S IBIPOL=$O(^TMP($J,"IBCNSUR",DFN,IBIPOL)) Q:IBIPOL="" D
... I ^TMP($J,"IBCNSUR",DFN,IBIPOL)'="E" Q
... D ADS^IBCNSUR3(DFN,IBIPOL)
... W !,@REF@(IBLN)
. D ADD^IBCNSUR3(1,"============================")
. D ADD^IBCNSUR3()
. W !!,"Examine the entries that could not be processed."
;
I IBEXPOK D
. D ADD^IBCNSUR3(1,"These ",IBEXPOK," policies were processed successfully")
. D ADD^IBCNSUR3(1,"-------------------------------------------------------------------------------")
. D ADD^IBCNSUR3(1,"Patient Name/ID Whose Employer Effective Expires")
. S DFN=0 F S DFN=$O(^TMP($J,"IBCNSUR",DFN)) Q:'DFN D
.. S IBIPOL=0 F S IBIPOL=$O(^TMP($J,"IBCNSUR",DFN,IBIPOL)) Q:IBIPOL="" D
... I ^TMP($J,"IBCNSUR",DFN,IBIPOL)'="O" Q
... D ADS^IBCNSUR3(DFN,IBIPOL)
. D ADD^IBCNSUR3(1,"============================")
. D ADD^IBCNSUR3()
;
I 'IBEXPOK,'IBEXPERR D
. D ADD^IBCNSUR3(1,"============================")
. D ADD^IBCNSUR3(1,"After processing, no changes were needed, no policies were expired.")
. W !!,@REF@(IBLN)
. D ADD^IBCNSUR3(1,"============================")
. D ADD^IBCNSUR3()
;
W !
S DIR(0)="EA",DIR("A")="Press RETURN to continue." D ^DIR K DIR
;
I +$$GET1^DIQ(355.3,IBPLAN_",","INACTIVE","I") D G NXTGRP
. D ADD^IBCNSUR3(1,"Please note the ",IBGRPNM," plan is already inactive.")
. W !!,@REF@(IBLN),!
. D SNDBULL
;
W !
S DIR(0)="Y",DIR("B")="NO"
I IBEXPERR D
. S DIR("A",1)=" ***********************************************"
. S DIR("A",2)=" * WARNING *"
. S DIR("A",3)=" * There are still active subscribers *"
. S DIR("A",4)=" * that will need to be adjusted manually *"
. S DIR("A",5)=" ***********************************************"
. S DIR("A",6)=" "
S DIR("A")="Do you wish to inactivate plan "_IBGRPNM
D ^DIR K DIR
I 'Y!$D(DIRUT) D G NXTGRP
. D ADD^IBCNSUR3(1,"The ",IBGRPNM," plan is still active.")
. W !!,@REF@(IBLN),!
. D SNDBULL
; inactivate the plan
S IBIENWK=IBPLAN_","
K DTA,ERR
S DTA(355.3,IBIENWK,.11)=1 ; inactive
S DTA(355.3,IBIENWK,1.05)=$$NOW^XLFDT() ; last edited
S DTA(355.3,IBIENWK,1.06)=DUZ ; by
D FILE^DIE("","DTA","ERR")
I $D(ERR) D G NXTGRP
. D ADD^IBCNSUR3(1,"There was an issue inactivating the ",IBGRPNM," plan.")
. W !!,@REF@(IBLN),!
. D SNDBULL
D ADD^IBCNSUR3(1,"The ",IBGRPNM," plan has been inactivated.")
W !!,@REF@(IBLN),!
D SNDBULL
G NXTGRP
;
SNDBULL ; send out the bulletin
I '$G(IBLN) Q
D ADD^IBCNSUR3()
D ADD^IBCNSUR3(1,"THE PROCESS COMPLETED SUCCESSFULLY ON "_$$DAT1^IBOUTL($$NOW^XLFDT(),1))
S XMSUB="SUBSCRIPTION LIST FOR INACTIVATED PLAN"
S XMDUZ="INTEGRATED BILLING PACKAGE",XMTEXT="^TMP("_$J_",""IBCNSURBLL"","
S XMY(DUZ)=""
S XMY("G.IB NEW INSURANCE")=""
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSUR 14770 printed Sep 23, 2025@19:54:18 Page 2
IBCNSUR ;ALB/CPM/CMS - MOVE SUBSCRIBERS TO DIFFERENT PLAN ; 09-SEP-96
+1 ;;2.0;INTEGRATED BILLING;**103,276,506,516,549,602,664,702,732**;21-MAR-94;Build 13
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
EN ; Entry point from option. Main processing loop.
+1 IF $SELECT('($DATA(DUZ)#2):1,'$DATA(^VA(200,+DUZ,0)):1,1:0)
WRITE !!?3,"The variable DUZ must be set to an active user code before continuing."
GOTO ENQ
+2 WRITE !!,?5,"MOVE SUBSCRIBERS OF ONE PLAN TO ANOTHER PLAN"
+3 WRITE !,?5,"This option may be used to move subscribers from a selected Plan"
+4 WRITE !,?5,"to a different Plan. The plans may be associated with the same"
+5 WRITE !,?5,"Insurance Company or a different one. Plan and Annual Benefit"
+6 WRITE !,?5,"information may be moved as well. Users of this option should"
+7 WRITE !,?5,"be knowledgeable of the VistA Patient Insurance management options."
+8 WRITE !
+9 WRITE !,?5,"This option also gives the user the option to expire the old plan or"
+10 WRITE !,?5,"replace it completely in the patient insurance profile. The reason"
+11 WRITE !,?5,"to expire the old plan is intended for use when Insurance groups change"
+12 WRITE !,?5,"PBMs for processing electronic Pharmacy claims. By leaving the old"
+13 WRITE !,?5,"plan information intact (i.e. do not replace), the user will be able"
+14 WRITE !,?5,"to monitor PBM changes that affect the electronic Pharmacy claims."
+15 ;
+16 WRITE !!,$TRANSLATE($JUSTIFY("",75)," ","-")
+17 SET IBSTOP=0
FOR
DO PROC^IBCNSUR1
if IBSTOP
QUIT
ENQ KILL IBSTOP
+1 QUIT
+2 ;
PROC ; - Process continuation from IBCNSUR1.
+1 ; - display old plan attributes; allow new plan to be edited
+2 DO PL^IBCNSUR2
+3 READ !!,?10,"Press any key to continue. ",IBX:DTIME
+4 ;
+5 ; - display coverage limitations; allow add/edit of plan 2 limitations
+6 DO LIM^IBCNSUR2
+7 ;
+8 IF $PIECE($GET(^IBA(355.3,IBP1,0)),"^",11)
WRITE !!,"Please note that ",IBC1N,"'s",!,"plan, subscribers were moved from, is already inactive."
GOTO PROCDP
+9 ;
+10 ; - does the user wish to inactivate the old plan?
+11 WRITE !!
SET DIR(0)="Y"
SET DIR("A")="Do you wish to inactivate "_IBC1N_"'s plan subscribers were moved from"
+12 SET DIR("?")="If you wish to inactivate the old plan, enter 'Yes' - otherwise, enter 'No.'"
+13 DO ^DIR
KILL DIR
IF 'Y
WRITE !," <The old plan is still active>"
GOTO PROCQ
+14 ;
+15 DO IRACT^IBCNSJ(IBP1,1)
WRITE !!,"The plan has been inactivated."
+16 ;
PROCDP ; - does the user wish to delete the old plan?
+1 ;IB*2*702/CKB - Add checks to determine whether a group is allowed to be delete or not
+2 ;
+3 ;IB*732/CKB - removed check for the number of subscribers
+4 ;If moving entire group by expiring the policy by adding a new effective
+5 ; date, do NOT allow the group to be deleted.
+6 IF IBGRP
IF IBSPLIT
IF $GET(IBEFFDT)
DO NODEL
GOTO PROCQ
+7 ;
+8 ;IB*732/CKB - should only check for only 1 subscriber.
+9 ;If moving the entire group (if there is only 1 subscriber) by replacing the
+10 ; old group plan,the user they should BE allowed to delete the group.
+11 IF IBGRP
IF (IBSUB=1)
GOTO PROCDP1
+12 ;
+13 ;If moving a subset of subscribers from the group by expiring the policy adding
+14 ; a new effective date, do NOT allow the group to be deleted.
+15 ;IB*732/CKB - if user selected chose to select subscribers allow for the user
+16 ; selecting All or Some of the subscribers
+17 ;;***I 'IBGRP,+NUMSEL<IBSUB,$G(IBEFFDT) D NODEL G PROCQ
+18 IF 'IBGRP
IF +NUMSEL'>IBSUB
IF $GET(IBEFFDT)
DO NODEL
GOTO PROCQ
+19 ;
+20 ;If moving a subset of subscribers from the group by replacing the old group plan,
+21 ; do NOT allow the group to be deleted.
+22 ;IB*732/CKB - if user selected chose to select subscribers allow for the user
+23 ; selecting All or Some of the subscribers
+24 ;;***I 'IBGRP,+NUMSEL<IBSUB,'IBSPLIT D NODEL G PROCQ
+25 IF 'IBGRP
IF +NUMSEL'>IBSUB
IF 'IBSPLIT
DO NODEL
GOTO PROCQ
+26 ;
PROCDP1 ; Prompt to delete the plan
+1 WRITE !!
SET DIR(0)="Y"
SET DIR("A")="Do you wish to delete this plan"
+2 SET DIR("?")="If you wish to delete the old plan, enter 'Yes' - otherwise, enter 'No.'"
+3 DO ^DIR
KILL DIR
IF 'Y
GOTO PROCQ
+4 ;
+5 ;IB*2*702/CKB - Added a "Are you sure" question before deleting the plan
+6 WRITE !
SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to delete this plan"
+7 SET DIR("?")="If you're sure you want to delete the old plan, enter 'Yes' - otherwise, enter 'No.'"
+8 DO ^DIR
KILL DIR
IF 'Y
GOTO PROCQ
+9 ;
+10 DO DEL^IBCNSJ(IBP1)
WRITE !!,"The plan has been deleted."
+11 ;
PROCQ QUIT
+1 ;
NODEL ;IB*2*702/CKB - Display a "not allowed to delete" message to the user
+1 WRITE !,"There are still subscribers to this plan. The plan cannot be deleted.",!
+2 SET DIR(0)="EA"
SET DIR("A")="Press RETURN to continue."
+3 DO ^DIR
KILL DIR
+4 QUIT
+5 ;
SEL(IBNP) ; Select a company and plan.
+1 ; Input: IBNP -- If set to 1, allows adding a new plan and
+2 ; -- Screen Inactive Companies
+3 ; -- If set to 0, must have at least one group plan
+4 ; Output: IBCNS -- Pointer to selected company in file #36
+5 ; IBPLAN -- Pointer to selected/added plan in file #355.3
+6 ; IBQUIT -- Set to 1 if the user wants to quit.
+7 ;
+8 NEW X,Y
KILL DIC,DIR
+9 SET DIC(0)="QEAMZ"
SET DIC="^DIC(36,"
+10 IF 'IBNP
SET DIC("S")="I $$ANYGP^IBCNSJ(+Y,0,1)"
+11 IF IBNP
SET DIC("S")="I '$P($G(^DIC(36,+Y,0)),U,5)"
+12 SET DIC("A")="Select INSURANCE COMPANY: "
+13 DO ^DIC
KILL DIC
SET IBCNS=+Y
+14 IF Y<0
WRITE " <No Insurance Company selected>"
SET IBQUIT=1
GOTO SELQ
+15 ;
+16 ; - if a new plan may be added, allow adding
+17 IF IBNP
Begin DoDot:1
+18 WRITE !!,"You may add a new Plan at this time or select an existing Plan."
+19 ; IB*2.0*506 added IBKEY parameter (4th) to the NEW^IBCNSJ3 call (check user's security keys)
+20 DO NEW^IBCNSJ3(IBCNS,.IBPLAN,1,1)
+21 IF 'IBPLAN
IF '$$ANYGP^IBCNSJ(+IBCNS,0,1)
WRITE !!,*7,"Insurance Company receiving subscribers must have a Plan."
SET IBQUIT=1
End DoDot:1
IF (IBPLAN)!(IBQUIT)
GOTO SELQ
+22 ;
+23 ; - see if user wants to select the plan
+24 WRITE !!,"You may select an existing Plan from a list or enter a specific Plan.",!
+25 SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Do you wish to enter a specific plan"
+26 SET DIR("?")="The look-up facility to select a group plan has been enhanced to use the List Manager. Enter 'NO' if you wish to select a plan from this look-up, or 'YES' to directly enter a plan."
+27 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET IBQUIT=1
GOTO SELQ
+28 ;
+29 ; - invoke the plan look-up
+30 IF 'Y
Begin DoDot:1
+31 NEW IBTITLE
+32 SET IBTITLE="Group Plan Lookup"
+33 WRITE " ..."
+34 SET IBPLAN=0
+35 DO LKP^IBCNSU2(IBCNS,0,0,.IBPLAN,0,1,IBTITLE)
+36 IF 'IBPLAN
WRITE !!,*7,"* No plan selected!",!
SET IBQUIT=1
End DoDot:1
GOTO SELQ
+37 ;
+38 ; - allow a FileMan look-up
+39 ; MRD;IB*2.0*516 - Display new Group Name and Number fields.
+40 SET DIC("A")="Select a GROUP PLAN: "
+41 SET DIC="^IBA(355.3,"
SET DIC(0)="AEQM"
SET DIC("S")="I +^(0)=IBCNS,$P(^(0),U,2)"
+42 ;S DIC("W")="N IBX S IBX=$G(^(0)) W "" Name: "",$E($S($P(IBX,U,3)]"""":$P(IBX,U,3),1:""<none>"")_$J("""",20),1,20),"" Number: "",$S($P(IBX,U,4)]"""":$P(IBX,U,4),1:""<none>"")"
+43 SET DIC("W")="N IBX S IBX=$G(^(2)) W "" Name: "",$E($S($P(IBX,U,1)]"""":$P(IBX,U,1),1:""<none>"")_$J("""",20),1,20),"" Number: "",$E($S($P(IBX,U,2)]"""":$P(IBX,U,2),1:""<none>""),1,14)"
+44 DO ^DIC
KILL DIC
SET IBPLAN=+Y
+45 IF Y<0
WRITE !!,*7,"* No plan selected!",!
SET IBQUIT=1
+46 ;
SELQ KILL DIRUT,DUOUT,DTOUT,DIROUT
+1 QUIT
+2 ;
EXPGRP ; EP for [IBCN EXPIRE GROUP SUBSCRIBERS]
+1 ; IB*2.0*602/DM implement expire group plan
+2 NEW X,Y,DIC,DIR,DTA,ERR,REF,IBLN,XMDUZ,XMTEXT,XMSUB,XMY
+3 NEW IBQUIT,IBCNS,IBPLAN,IBSUB,IBEXP,DFN,IBIPOL,IBIENWK
+4 NEW IBINSNM,IBGRPNM,IBGRPNO,IBEXPOK,IBEXPERR,IBSUPRES,IBCBI
+5 ;
+6 WRITE !!,?5,"EXPIRE ALL SUBSCRIBERS WITHIN A GROUP PLAN"
+7 WRITE !,?5,"You can use this option to specify an expiration date for all subscriber"
+8 WRITE !,?5,"policies in a group plan without moving the subscribers to another group"
+9 WRITE !,?5,"plan. If the group plan status is currently ""active"", you can also choose"
+10 WRITE !,?5,"to ""inactivate"" the group plan."
+11 WRITE !!,$TRANSLATE($JUSTIFY("",75)," ","-")
+12 SET IBQUIT=1
+13 ;
NXTGRP ; EP for next expire group process
+1 ; subscribers
KILL ^TMP($JOB,"IBCNSUR")
+2 ; bulletin
KILL ^TMP($JOB,"IBCNSURBLL")
+3 IF 'IBQUIT
Begin DoDot:1
+4 WRITE !!,"=========================================="
+5 WRITE !,"EXPIRE ALL SUBSCRIBERS WITHIN A GROUP PLAN"
+6 WRITE !,"==========================================",!
End DoDot:1
+7 ; get insco and plan
+8 SET IBQUIT=0
+9 DO SEL^IBCNSUR(0)
IF IBQUIT
QUIT
+10 ;
+11 ; Make sure plan has at least one subscriber
+12 IF '$$SUBS^IBCNSJ(IBCNS,IBPLAN,0,,1)
WRITE !!,?5,*7,"* This group plan has no subscribers!",!
GOTO NXTGRP
+13 ;
+14 SET IBINSNM=$$GET1^DIQ(36,IBCNS_",","NAME")
+15 SET IBGRPNM=$$GET1^DIQ(355.3,IBPLAN_",","GROUP NAME")
+16 SET IBGRPNO=$$GET1^DIQ(355.3,IBPLAN_",","GROUP NUMBER")
+17 ;
+18 WRITE !!,"Collecting Subscribers ..."
+19 SET IBSUB=$$SUBS^IBCNSJ(IBCNS,IBPLAN,0,"^TMP($J,""IBCNSUR"")")
+20 WRITE !!,"This group plan has "_+IBSUB_" subscribers. All subscribers will be expired.",!
+21 SET DIR(0)="Y"
+22 SET DIR("A")="Do you want to expire all subscribers' policies for this plan"
+23 SET DIR("?",1)="You will be asked for an expiration date to terminate the attached policies."
+24 SET DIR("?",2)="You will have an opportunity to stop if desired."
+25 SET DIR("?")="Enter 'Yes' to continue, or 'No' to stop the process now."
+26 DO ^DIR
KILL DIR
+27 IF 'Y!$DATA(DIRUT)
GOTO NXTGRP
+28 ;
+29 WRITE !
+30 ; get the expiration date
+31 ;IB*2.0*664/TAZ - Force exact date.
+32 SET DIR(0)="D^::EX"
SET DIR("A")="Enter expiration date (applies to all subscribers in this plan)"
+33 SET DIR("?")="Each active policy will be expired with the expiration date entered."
+34 DO ^DIR
KILL DIR
+35 IF 'Y!$DATA(DIRUT)
GOTO NXTGRP
+36 SET IBEXP=Y
+37 ;
+38 WRITE !!,"You selected to expire "_+IBSUB_" subscriber(s) with Expiration Date "_$$FMTE^XLFDT(IBEXP)_" for:"
+39 WRITE !,?5,"Insurance Company "_IBINSNM
+40 WRITE !,?5,"Plan Name "_IBGRPNM_" Number "_IBGRPNO
+41 WRITE !!,"Please Note that the policy will be EXPIRED in the patient profile!!",!
+42 ;
+43 SET DIR(0)="Y"
SET DIR("A")="Okay to continue"
+44 SET DIR("?",1)="If you wish to expire the policies for these subscribers, enter 'Yes'."
+45 SET DIR("?")="Otherwise, enter 'No' to exit."
+46 DO ^DIR
KILL DIR
+47 IF 'Y!$DATA(DIRUT)
GOTO NXTGRP
+48 ;
+49 ; expire the plan subscribers
+50 ; as we process the policies, we'll set the ^TMP nodes to 'O'k or 'E'rror
+51 WRITE !!,"Expiring Policies...",!
+52 ; tell COVERED^IBCNSM31 to be quiet
SET IBSUPRES=1
+53 SET (IBEXPOK,IBEXPERR)=0
+54 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,"IBCNSUR",DFN))
if 'DFN
QUIT
Begin DoDot:1
+55 SET IBIPOL=0
FOR
SET IBIPOL=$ORDER(^TMP($JOB,"IBCNSUR",DFN,IBIPOL))
if IBIPOL=""
QUIT
Begin DoDot:2
+56 SET IBIENWK=IBIPOL_","_DFN_","
+57 if $$GET1^DIQ(2.312,IBIENWK,"GROUP PLAN","I")'=IBPLAN
QUIT
+58 if +$$GET1^DIQ(2.312,IBIENWK,"INSURANCE EXPIRATION","I")
QUIT
+59 IF $$GET1^DIQ(2.312,IBIENWK,"EFFECTIVE DATE OF POLICY","I")>IBEXP
SET ^TMP($JOB,"IBCNSUR",DFN,IBIPOL)="E"
SET IBEXPERR=IBEXPERR+1
QUIT
+60 SET IBCBI=$$GET1^DIQ(2,DFN_",","COVERED BY HEALTH INSURANCE?","I")
+61 KILL DTA,ERR
+62 ; set the expiration date
SET DTA(2.312,IBIENWK,3)=IBEXP
+63 ; last edited
SET DTA(2.312,IBIENWK,1.05)=$$NOW^XLFDT()
+64 ; by
SET DTA(2.312,IBIENWK,1.06)=DUZ
+65 DO FILE^DIE("","DTA","ERR")
+66 IF $DATA(ERR)
SET ^TMP($JOB,"IBCNSUR",DFN,IBIPOL)="E"
SET IBEXPERR=IBEXPERR+1
QUIT
+67 SET ^TMP($JOB,"IBCNSUR",DFN,IBIPOL)="O"
SET IBEXPOK=IBEXPOK+1
+68 ; set covered by insurance
DO COVERED^IBCNSM31(DFN,IBCBI)
End DoDot:2
End DoDot:1
+69 ;
+70 WRITE !,"Done. "_IBEXPOK_" Subscribers' policies were expired as of "_$$FMTE^XLFDT(IBEXP)_"."
+71 WRITE !,"A Bulletin was sent to you and members of 'IB NEW INSURANCE' Mail Group."
+72 ;
+73 ; prepare the bulletin
+74 SET IBLN=0
SET REF=$NAME(^TMP($JOB,"IBCNSURBLL"))
+75 DO ADD^IBCNSUR3(1,"EXPIRE ALL SUBSCRIBERS WITHIN A GROUP PLAN")
+76 DO ADD^IBCNSUR3()
+77 DO ADD^IBCNSUR3(1,"You selected to expire ",IBSUB," subscriber(s)")
+78 DO ADD^IBCNSUR3()
+79 DO ADD^IBCNSUR3(1,"FROM Insurance Company ",IBINSNM)
+80 DO ADD^IBCNSUR3(1,"Plan Name ",IBGRPNM," Number ",IBGRPNO)
+81 DO ADD^IBCNSUR3()
+82 DO ADD^IBCNSUR3(1,"Policies will be expired as of ",$$FMTE^XLFDT(IBEXP),".")
+83 DO ADD^IBCNSUR3()
+84 ;
+85 IF IBEXPERR
Begin DoDot:1
+86 DO ADD^IBCNSUR3(1,"* These ",IBEXPERR," entries could not be processed, they'll need to be adjusted manually")
+87 WRITE !!,@REF@(IBLN)
+88 DO ADD^IBCNSUR3(1,"-------------------------------------------------------------------------------")
+89 WRITE !,@REF@(IBLN)
+90 DO ADD^IBCNSUR3(1,"Patient Name/ID Whose Employer Effective Expires")
+91 WRITE !,@REF@(IBLN),!
+92 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,"IBCNSUR",DFN))
if 'DFN
QUIT
Begin DoDot:2
+93 SET IBIPOL=0
FOR
SET IBIPOL=$ORDER(^TMP($JOB,"IBCNSUR",DFN,IBIPOL))
if IBIPOL=""
QUIT
Begin DoDot:3
+94 IF ^TMP($JOB,"IBCNSUR",DFN,IBIPOL)'="E"
QUIT
+95 DO ADS^IBCNSUR3(DFN,IBIPOL)
+96 WRITE !,@REF@(IBLN)
End DoDot:3
End DoDot:2
+97 DO ADD^IBCNSUR3(1,"============================")
+98 DO ADD^IBCNSUR3()
+99 WRITE !!,"Examine the entries that could not be processed."
End DoDot:1
+100 ;
+101 IF IBEXPOK
Begin DoDot:1
+102 DO ADD^IBCNSUR3(1,"These ",IBEXPOK," policies were processed successfully")
+103 DO ADD^IBCNSUR3(1,"-------------------------------------------------------------------------------")
+104 DO ADD^IBCNSUR3(1,"Patient Name/ID Whose Employer Effective Expires")
+105 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,"IBCNSUR",DFN))
if 'DFN
QUIT
Begin DoDot:2
+106 SET IBIPOL=0
FOR
SET IBIPOL=$ORDER(^TMP($JOB,"IBCNSUR",DFN,IBIPOL))
if IBIPOL=""
QUIT
Begin DoDot:3
+107 IF ^TMP($JOB,"IBCNSUR",DFN,IBIPOL)'="O"
QUIT
+108 DO ADS^IBCNSUR3(DFN,IBIPOL)
End DoDot:3
End DoDot:2
+109 DO ADD^IBCNSUR3(1,"============================")
+110 DO ADD^IBCNSUR3()
End DoDot:1
+111 ;
+112 IF 'IBEXPOK
IF 'IBEXPERR
Begin DoDot:1
+113 DO ADD^IBCNSUR3(1,"============================")
+114 DO ADD^IBCNSUR3(1,"After processing, no changes were needed, no policies were expired.")
+115 WRITE !!,@REF@(IBLN)
+116 DO ADD^IBCNSUR3(1,"============================")
+117 DO ADD^IBCNSUR3()
End DoDot:1
+118 ;
+119 WRITE !
+120 SET DIR(0)="EA"
SET DIR("A")="Press RETURN to continue."
DO ^DIR
KILL DIR
+121 ;
+122 IF +$$GET1^DIQ(355.3,IBPLAN_",","INACTIVE","I")
Begin DoDot:1
+123 DO ADD^IBCNSUR3(1,"Please note the ",IBGRPNM," plan is already inactive.")
+124 WRITE !!,@REF@(IBLN),!
+125 DO SNDBULL
End DoDot:1
GOTO NXTGRP
+126 ;
+127 WRITE !
+128 SET DIR(0)="Y"
SET DIR("B")="NO"
+129 IF IBEXPERR
Begin DoDot:1
+130 SET DIR("A",1)=" ***********************************************"
+131 SET DIR("A",2)=" * WARNING *"
+132 SET DIR("A",3)=" * There are still active subscribers *"
+133 SET DIR("A",4)=" * that will need to be adjusted manually *"
+134 SET DIR("A",5)=" ***********************************************"
+135 SET DIR("A",6)=" "
End DoDot:1
+136 SET DIR("A")="Do you wish to inactivate plan "_IBGRPNM
+137 DO ^DIR
KILL DIR
+138 IF 'Y!$DATA(DIRUT)
Begin DoDot:1
+139 DO ADD^IBCNSUR3(1,"The ",IBGRPNM," plan is still active.")
+140 WRITE !!,@REF@(IBLN),!
+141 DO SNDBULL
End DoDot:1
GOTO NXTGRP
+142 ; inactivate the plan
+143 SET IBIENWK=IBPLAN_","
+144 KILL DTA,ERR
+145 ; inactive
SET DTA(355.3,IBIENWK,.11)=1
+146 ; last edited
SET DTA(355.3,IBIENWK,1.05)=$$NOW^XLFDT()
+147 ; by
SET DTA(355.3,IBIENWK,1.06)=DUZ
+148 DO FILE^DIE("","DTA","ERR")
+149 IF $DATA(ERR)
Begin DoDot:1
+150 DO ADD^IBCNSUR3(1,"There was an issue inactivating the ",IBGRPNM," plan.")
+151 WRITE !!,@REF@(IBLN),!
+152 DO SNDBULL
End DoDot:1
GOTO NXTGRP
+153 DO ADD^IBCNSUR3(1,"The ",IBGRPNM," plan has been inactivated.")
+154 WRITE !!,@REF@(IBLN),!
+155 DO SNDBULL
+156 GOTO NXTGRP
+157 ;
SNDBULL ; send out the bulletin
+1 IF '$GET(IBLN)
QUIT
+2 DO ADD^IBCNSUR3()
+3 DO ADD^IBCNSUR3(1,"THE PROCESS COMPLETED SUCCESSFULLY ON "_$$DAT1^IBOUTL($$NOW^XLFDT(),1))
+4 SET XMSUB="SUBSCRIPTION LIST FOR INACTIVATED PLAN"
+5 SET XMDUZ="INTEGRATED BILLING PACKAGE"
SET XMTEXT="^TMP("_$JOB_",""IBCNSURBLL"","
+6 SET XMY(DUZ)=""
+7 SET XMY("G.IB NEW INSURANCE")=""
+8 DO ^XMD
+9 QUIT
