Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCNSUR

IBCNSUR.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. Q
  1. ;
  1. EN ; Entry point from option. Main processing loop.
  1. 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
  1. W !!,?5,"MOVE SUBSCRIBERS OF ONE PLAN TO ANOTHER PLAN"
  1. W !,?5,"This option may be used to move subscribers from a selected Plan"
  1. W !,?5,"to a different Plan. The plans may be associated with the same"
  1. W !,?5,"Insurance Company or a different one. Plan and Annual Benefit"
  1. W !,?5,"information may be moved as well. Users of this option should"
  1. W !,?5,"be knowledgeable of the VistA Patient Insurance management options."
  1. W !
  1. W !,?5,"This option also gives the user the option to expire the old plan or"
  1. W !,?5,"replace it completely in the patient insurance profile. The reason"
  1. W !,?5,"to expire the old plan is intended for use when Insurance groups change"
  1. W !,?5,"PBMs for processing electronic Pharmacy claims. By leaving the old"
  1. W !,?5,"plan information intact (i.e. do not replace), the user will be able"
  1. W !,?5,"to monitor PBM changes that affect the electronic Pharmacy claims."
  1. ;
  1. W !!,$TR($J("",75)," ","-")
  1. S IBSTOP=0 F D PROC^IBCNSUR1 Q:IBSTOP
  1. ENQ K IBSTOP
  1. Q
  1. ;
  1. PROC ; - Process continuation from IBCNSUR1.
  1. ; - display old plan attributes; allow new plan to be edited
  1. D PL^IBCNSUR2
  1. R !!,?10,"Press any key to continue. ",IBX:DTIME
  1. ;
  1. ; - display coverage limitations; allow add/edit of plan 2 limitations
  1. D LIM^IBCNSUR2
  1. ;
  1. 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
  1. ;
  1. ; - does the user wish to inactivate the old plan?
  1. W !! S DIR(0)="Y",DIR("A")="Do you wish to inactivate "_IBC1N_"'s plan subscribers were moved from"
  1. S DIR("?")="If you wish to inactivate the old plan, enter 'Yes' - otherwise, enter 'No.'"
  1. D ^DIR K DIR I 'Y W !," <The old plan is still active>" G PROCQ
  1. ;
  1. D IRACT^IBCNSJ(IBP1,1) W !!,"The plan has been inactivated."
  1. ;
  1. 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
  1. ;
  1. ;IB*732/CKB - removed check for the number of subscribers
  1. ;If moving entire group by expiring the policy by adding a new effective
  1. ; date, do NOT allow the group to be deleted.
  1. I IBGRP,IBSPLIT,$G(IBEFFDT) D NODEL G PROCQ
  1. ;
  1. ;IB*732/CKB - should only check for only 1 subscriber.
  1. ;If moving the entire group (if there is only 1 subscriber) by replacing the
  1. ; old group plan,the user they should BE allowed to delete the group.
  1. I IBGRP,(IBSUB=1) G PROCDP1
  1. ;
  1. ;If moving a subset of subscribers from the group by expiring the policy adding
  1. ; a new effective date, do NOT allow the group to be deleted.
  1. ;IB*732/CKB - if user selected chose to select subscribers allow for the user
  1. ; selecting All or Some of the subscribers
  1. ;;***I 'IBGRP,+NUMSEL<IBSUB,$G(IBEFFDT) D NODEL G PROCQ
  1. I 'IBGRP,+NUMSEL'>IBSUB,$G(IBEFFDT) D NODEL G PROCQ
  1. ;
  1. ;If moving a subset of subscribers from the group by replacing the old group plan,
  1. ; do NOT allow the group to be deleted.
  1. ;IB*732/CKB - if user selected chose to select subscribers allow for the user
  1. ; selecting All or Some of the subscribers
  1. ;;***I 'IBGRP,+NUMSEL<IBSUB,'IBSPLIT D NODEL G PROCQ
  1. I 'IBGRP,+NUMSEL'>IBSUB,'IBSPLIT D NODEL G PROCQ
  1. ;
  1. PROCDP1 ; Prompt to delete the plan
  1. W !! S DIR(0)="Y",DIR("A")="Do you wish to delete this plan"
  1. S DIR("?")="If you wish to delete the old plan, enter 'Yes' - otherwise, enter 'No.'"
  1. D ^DIR K DIR I 'Y G PROCQ
  1. ;
  1. ;IB*2*702/CKB - Added a "Are you sure" question before deleting the plan
  1. W ! S DIR(0)="Y",DIR("A")="Are you sure you want to delete this plan"
  1. S DIR("?")="If you're sure you want to delete the old plan, enter 'Yes' - otherwise, enter 'No.'"
  1. D ^DIR K DIR I 'Y G PROCQ
  1. ;
  1. D DEL^IBCNSJ(IBP1) W !!,"The plan has been deleted."
  1. ;
  1. PROCQ Q
  1. ;
  1. NODEL ;IB*2*702/CKB - Display a "not allowed to delete" message to the user
  1. W !,"There are still subscribers to this plan. The plan cannot be deleted.",!
  1. S DIR(0)="EA",DIR("A")="Press RETURN to continue."
  1. D ^DIR K DIR
  1. Q
  1. ;
  1. SEL(IBNP) ; Select a company and plan.
  1. ; Input: IBNP -- If set to 1, allows adding a new plan and
  1. ; -- Screen Inactive Companies
  1. ; -- If set to 0, must have at least one group plan
  1. ; Output: IBCNS -- Pointer to selected company in file #36
  1. ; IBPLAN -- Pointer to selected/added plan in file #355.3
  1. ; IBQUIT -- Set to 1 if the user wants to quit.
  1. ;
  1. N X,Y K DIC,DIR
  1. S DIC(0)="QEAMZ",DIC="^DIC(36,"
  1. I 'IBNP S DIC("S")="I $$ANYGP^IBCNSJ(+Y,0,1)"
  1. I IBNP S DIC("S")="I '$P($G(^DIC(36,+Y,0)),U,5)"
  1. S DIC("A")="Select INSURANCE COMPANY: "
  1. D ^DIC K DIC S IBCNS=+Y
  1. I Y<0 W " <No Insurance Company selected>" S IBQUIT=1 G SELQ
  1. ;
  1. ; - if a new plan may be added, allow adding
  1. I IBNP D I (IBPLAN)!(IBQUIT) G SELQ
  1. .W !!,"You may add a new Plan at this time or select an existing Plan."
  1. .; IB*2.0*506 added IBKEY parameter (4th) to the NEW^IBCNSJ3 call (check user's security keys)
  1. .D NEW^IBCNSJ3(IBCNS,.IBPLAN,1,1)
  1. .I 'IBPLAN,'$$ANYGP^IBCNSJ(+IBCNS,0,1) W !!,*7,"Insurance Company receiving subscribers must have a Plan." S IBQUIT=1
  1. ;
  1. ; - see if user wants to select the plan
  1. W !!,"You may select an existing Plan from a list or enter a specific Plan.",!
  1. S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do you wish to enter a specific plan"
  1. 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."
  1. D ^DIR K DIR I $D(DIRUT) S IBQUIT=1 G SELQ
  1. ;
  1. ; - invoke the plan look-up
  1. I 'Y D G SELQ
  1. . N IBTITLE
  1. . S IBTITLE="Group Plan Lookup"
  1. . W " ..."
  1. . S IBPLAN=0
  1. . D LKP^IBCNSU2(IBCNS,0,0,.IBPLAN,0,1,IBTITLE)
  1. . I 'IBPLAN W !!,*7,"* No plan selected!",! S IBQUIT=1
  1. ;
  1. ; - allow a FileMan look-up
  1. ; MRD;IB*2.0*516 - Display new Group Name and Number fields.
  1. S DIC("A")="Select a GROUP PLAN: "
  1. S DIC="^IBA(355.3,",DIC(0)="AEQM",DIC("S")="I +^(0)=IBCNS,$P(^(0),U,2)"
  1. ;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>"")"
  1. 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)"
  1. D ^DIC K DIC S IBPLAN=+Y
  1. I Y<0 W !!,*7,"* No plan selected!",! S IBQUIT=1
  1. ;
  1. SELQ K DIRUT,DUOUT,DTOUT,DIROUT
  1. Q
  1. ;
  1. EXPGRP ; EP for [IBCN EXPIRE GROUP SUBSCRIBERS]
  1. ; IB*2.0*602/DM implement expire group plan
  1. N X,Y,DIC,DIR,DTA,ERR,REF,IBLN,XMDUZ,XMTEXT,XMSUB,XMY
  1. N IBQUIT,IBCNS,IBPLAN,IBSUB,IBEXP,DFN,IBIPOL,IBIENWK
  1. N IBINSNM,IBGRPNM,IBGRPNO,IBEXPOK,IBEXPERR,IBSUPRES,IBCBI
  1. ;
  1. W !!,?5,"EXPIRE ALL SUBSCRIBERS WITHIN A GROUP PLAN"
  1. W !,?5,"You can use this option to specify an expiration date for all subscriber"
  1. W !,?5,"policies in a group plan without moving the subscribers to another group"
  1. W !,?5,"plan. If the group plan status is currently ""active"", you can also choose"
  1. W !,?5,"to ""inactivate"" the group plan."
  1. W !!,$TR($J("",75)," ","-")
  1. S IBQUIT=1
  1. ;
  1. NXTGRP ; EP for next expire group process
  1. K ^TMP($J,"IBCNSUR") ; subscribers
  1. K ^TMP($J,"IBCNSURBLL") ; bulletin
  1. I 'IBQUIT D
  1. . W !!,"=========================================="
  1. . W !,"EXPIRE ALL SUBSCRIBERS WITHIN A GROUP PLAN"
  1. . W !,"==========================================",!
  1. ; get insco and plan
  1. S IBQUIT=0
  1. D SEL^IBCNSUR(0) I IBQUIT Q
  1. ;
  1. ; Make sure plan has at least one subscriber
  1. I '$$SUBS^IBCNSJ(IBCNS,IBPLAN,0,,1) W !!,?5,*7,"* This group plan has no subscribers!",! G NXTGRP
  1. ;
  1. S IBINSNM=$$GET1^DIQ(36,IBCNS_",","NAME")
  1. S IBGRPNM=$$GET1^DIQ(355.3,IBPLAN_",","GROUP NAME")
  1. S IBGRPNO=$$GET1^DIQ(355.3,IBPLAN_",","GROUP NUMBER")
  1. ;
  1. W !!,"Collecting Subscribers ..."
  1. S IBSUB=$$SUBS^IBCNSJ(IBCNS,IBPLAN,0,"^TMP($J,""IBCNSUR"")")
  1. W !!,"This group plan has "_+IBSUB_" subscribers. All subscribers will be expired.",!
  1. S DIR(0)="Y"
  1. S DIR("A")="Do you want to expire all subscribers' policies for this plan"
  1. S DIR("?",1)="You will be asked for an expiration date to terminate the attached policies."
  1. S DIR("?",2)="You will have an opportunity to stop if desired."
  1. S DIR("?")="Enter 'Yes' to continue, or 'No' to stop the process now."
  1. D ^DIR K DIR
  1. I 'Y!$D(DIRUT) G NXTGRP
  1. ;
  1. W !
  1. ; get the expiration date
  1. ;IB*2.0*664/TAZ - Force exact date.
  1. S DIR(0)="D^::EX",DIR("A")="Enter expiration date (applies to all subscribers in this plan)"
  1. S DIR("?")="Each active policy will be expired with the expiration date entered."
  1. D ^DIR K DIR
  1. I 'Y!$D(DIRUT) G NXTGRP
  1. S IBEXP=Y
  1. ;
  1. W !!,"You selected to expire "_+IBSUB_" subscriber(s) with Expiration Date "_$$FMTE^XLFDT(IBEXP)_" for:"
  1. W !,?5,"Insurance Company "_IBINSNM
  1. W !,?5,"Plan Name "_IBGRPNM_" Number "_IBGRPNO
  1. W !!,"Please Note that the policy will be EXPIRED in the patient profile!!",!
  1. ;
  1. S DIR(0)="Y",DIR("A")="Okay to continue"
  1. S DIR("?",1)="If you wish to expire the policies for these subscribers, enter 'Yes'."
  1. S DIR("?")="Otherwise, enter 'No' to exit."
  1. D ^DIR K DIR
  1. I 'Y!$D(DIRUT) G NXTGRP
  1. ;
  1. ; expire the plan subscribers
  1. ; as we process the policies, we'll set the ^TMP nodes to 'O'k or 'E'rror
  1. W !!,"Expiring Policies...",!
  1. S IBSUPRES=1 ; tell COVERED^IBCNSM31 to be quiet
  1. S (IBEXPOK,IBEXPERR)=0
  1. S DFN=0 F S DFN=$O(^TMP($J,"IBCNSUR",DFN)) Q:'DFN D
  1. . S IBIPOL=0 F S IBIPOL=$O(^TMP($J,"IBCNSUR",DFN,IBIPOL)) Q:IBIPOL="" D
  1. .. S IBIENWK=IBIPOL_","_DFN_","
  1. .. Q:$$GET1^DIQ(2.312,IBIENWK,"GROUP PLAN","I")'=IBPLAN
  1. .. Q:+$$GET1^DIQ(2.312,IBIENWK,"INSURANCE EXPIRATION","I")
  1. .. I $$GET1^DIQ(2.312,IBIENWK,"EFFECTIVE DATE OF POLICY","I")>IBEXP S ^TMP($J,"IBCNSUR",DFN,IBIPOL)="E",IBEXPERR=IBEXPERR+1 Q
  1. .. S IBCBI=$$GET1^DIQ(2,DFN_",","COVERED BY HEALTH INSURANCE?","I")
  1. .. K DTA,ERR
  1. .. S DTA(2.312,IBIENWK,3)=IBEXP ; set the expiration date
  1. .. S DTA(2.312,IBIENWK,1.05)=$$NOW^XLFDT() ; last edited
  1. .. S DTA(2.312,IBIENWK,1.06)=DUZ ; by
  1. .. D FILE^DIE("","DTA","ERR")
  1. .. I $D(ERR) S ^TMP($J,"IBCNSUR",DFN,IBIPOL)="E",IBEXPERR=IBEXPERR+1 Q
  1. .. S ^TMP($J,"IBCNSUR",DFN,IBIPOL)="O",IBEXPOK=IBEXPOK+1
  1. .. D COVERED^IBCNSM31(DFN,IBCBI) ; set covered by insurance
  1. ;
  1. W !,"Done. "_IBEXPOK_" Subscribers' policies were expired as of "_$$FMTE^XLFDT(IBEXP)_"."
  1. W !,"A Bulletin was sent to you and members of 'IB NEW INSURANCE' Mail Group."
  1. ;
  1. ; prepare the bulletin
  1. S IBLN=0,REF=$NA(^TMP($J,"IBCNSURBLL"))
  1. D ADD^IBCNSUR3(1,"EXPIRE ALL SUBSCRIBERS WITHIN A GROUP PLAN")
  1. D ADD^IBCNSUR3()
  1. D ADD^IBCNSUR3(1,"You selected to expire ",IBSUB," subscriber(s)")
  1. D ADD^IBCNSUR3()
  1. D ADD^IBCNSUR3(1,"FROM Insurance Company ",IBINSNM)
  1. D ADD^IBCNSUR3(1,"Plan Name ",IBGRPNM," Number ",IBGRPNO)
  1. D ADD^IBCNSUR3()
  1. D ADD^IBCNSUR3(1,"Policies will be expired as of ",$$FMTE^XLFDT(IBEXP),".")
  1. D ADD^IBCNSUR3()
  1. ;
  1. I IBEXPERR D
  1. . D ADD^IBCNSUR3(1,"* These ",IBEXPERR," entries could not be processed, they'll need to be adjusted manually")
  1. . W !!,@REF@(IBLN)
  1. . D ADD^IBCNSUR3(1,"-------------------------------------------------------------------------------")
  1. . W !,@REF@(IBLN)
  1. . D ADD^IBCNSUR3(1,"Patient Name/ID Whose Employer Effective Expires")
  1. . W !,@REF@(IBLN),!
  1. . S DFN=0 F S DFN=$O(^TMP($J,"IBCNSUR",DFN)) Q:'DFN D
  1. .. S IBIPOL=0 F S IBIPOL=$O(^TMP($J,"IBCNSUR",DFN,IBIPOL)) Q:IBIPOL="" D
  1. ... I ^TMP($J,"IBCNSUR",DFN,IBIPOL)'="E" Q
  1. ... D ADS^IBCNSUR3(DFN,IBIPOL)
  1. ... W !,@REF@(IBLN)
  1. . D ADD^IBCNSUR3(1,"============================")
  1. . D ADD^IBCNSUR3()
  1. . W !!,"Examine the entries that could not be processed."
  1. ;
  1. I IBEXPOK D
  1. . D ADD^IBCNSUR3(1,"These ",IBEXPOK," policies were processed successfully")
  1. . D ADD^IBCNSUR3(1,"-------------------------------------------------------------------------------")
  1. . D ADD^IBCNSUR3(1,"Patient Name/ID Whose Employer Effective Expires")
  1. . S DFN=0 F S DFN=$O(^TMP($J,"IBCNSUR",DFN)) Q:'DFN D
  1. .. S IBIPOL=0 F S IBIPOL=$O(^TMP($J,"IBCNSUR",DFN,IBIPOL)) Q:IBIPOL="" D
  1. ... I ^TMP($J,"IBCNSUR",DFN,IBIPOL)'="O" Q
  1. ... D ADS^IBCNSUR3(DFN,IBIPOL)
  1. . D ADD^IBCNSUR3(1,"============================")
  1. . D ADD^IBCNSUR3()
  1. ;
  1. I 'IBEXPOK,'IBEXPERR D
  1. . D ADD^IBCNSUR3(1,"============================")
  1. . D ADD^IBCNSUR3(1,"After processing, no changes were needed, no policies were expired.")
  1. . W !!,@REF@(IBLN)
  1. . D ADD^IBCNSUR3(1,"============================")
  1. . D ADD^IBCNSUR3()
  1. ;
  1. W !
  1. S DIR(0)="EA",DIR("A")="Press RETURN to continue." D ^DIR K DIR
  1. ;
  1. I +$$GET1^DIQ(355.3,IBPLAN_",","INACTIVE","I") D G NXTGRP
  1. . D ADD^IBCNSUR3(1,"Please note the ",IBGRPNM," plan is already inactive.")
  1. . W !!,@REF@(IBLN),!
  1. . D SNDBULL
  1. ;
  1. W !
  1. S DIR(0)="Y",DIR("B")="NO"
  1. I IBEXPERR D
  1. . S DIR("A",1)=" ***********************************************"
  1. . S DIR("A",2)=" * WARNING *"
  1. . S DIR("A",3)=" * There are still active subscribers *"
  1. . S DIR("A",4)=" * that will need to be adjusted manually *"
  1. . S DIR("A",5)=" ***********************************************"
  1. . S DIR("A",6)=" "
  1. S DIR("A")="Do you wish to inactivate plan "_IBGRPNM
  1. D ^DIR K DIR
  1. I 'Y!$D(DIRUT) D G NXTGRP
  1. . D ADD^IBCNSUR3(1,"The ",IBGRPNM," plan is still active.")
  1. . W !!,@REF@(IBLN),!
  1. . D SNDBULL
  1. ; inactivate the plan
  1. S IBIENWK=IBPLAN_","
  1. K DTA,ERR
  1. S DTA(355.3,IBIENWK,.11)=1 ; inactive
  1. S DTA(355.3,IBIENWK,1.05)=$$NOW^XLFDT() ; last edited
  1. S DTA(355.3,IBIENWK,1.06)=DUZ ; by
  1. D FILE^DIE("","DTA","ERR")
  1. I $D(ERR) D G NXTGRP
  1. . D ADD^IBCNSUR3(1,"There was an issue inactivating the ",IBGRPNM," plan.")
  1. . W !!,@REF@(IBLN),!
  1. . D SNDBULL
  1. D ADD^IBCNSUR3(1,"The ",IBGRPNM," plan has been inactivated.")
  1. W !!,@REF@(IBLN),!
  1. D SNDBULL
  1. G NXTGRP
  1. ;
  1. SNDBULL ; send out the bulletin
  1. I '$G(IBLN) Q
  1. D ADD^IBCNSUR3()
  1. D ADD^IBCNSUR3(1,"THE PROCESS COMPLETED SUCCESSFULLY ON "_$$DAT1^IBOUTL($$NOW^XLFDT(),1))
  1. S XMSUB="SUBSCRIPTION LIST FOR INACTIVATED PLAN"
  1. S XMDUZ="INTEGRATED BILLING PACKAGE",XMTEXT="^TMP("_$J_",""IBCNSURBLL"","
  1. S XMY(DUZ)=""
  1. S XMY("G.IB NEW INSURANCE")=""
  1. D ^XMD
  1. Q