- 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 Jan 18, 2025@03:19:16 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