IBCNSUR1 ;ALB/CPM/CMS - MOVE SUBSCRIBERS TO DIFFERENT PLAN (CON'T) ;09-SEP-96
;;2.0;INTEGRATED BILLING;**103,225,276,516,549,713**;21-MAR-94;Build 12
;;Per VA Directive 6402, this routine should not be modified.
Q
;
;
PROC ; - Top of processing from IBCNSUR
; Move subscribers to another company's insurance plan.
N D0,DA,DFN,DIC,DIE,DIK,DIR,DIROUT,DIRUT,DLAYGO,DR,DTOUT,DUOUT
N I,IBAB,IBBU,IBC1,IBC1N,IBC1X,IBC2,IBC2N,IBC2X
N IBCAB,IBCDFN,IBCDFN1,IBCNS,IBCPOL,IBDAT,IBDEAD,IBDONE
N IBEFDT,IBEFDT1,IBEFDT2,IBEFFDT,IBEXPDT,IBGRP,IBI,IBIAB,IBLN
N IBNP,IBP1,IBP1N,IBP1X,IBP2,IBP2N,IBP2X,IBPLAN,IBQ,IBQUIT
N IBSPLIT,IBST,IBSUB,IBSUBACT,IBSUBID,IBVALUE,IBW,IBXXX,IBX
N NUMSEL,REF,X,Y
;
K ^TMP($J,"IBCNSUR") ; subscribers
K ^TMP($J,"IBCNSUR1") ; e-mail bulletin
S REF=$NA(^TMP($J,"IBCNSUR1")),IBLN=0
;
S (IBDONE,IBQUIT,NUMSEL)=0
;
W !!!,"=====================",!,"MOVE SUBSCRIBERS FROM",!,"====================="
W !!,"Select the Insurance Company and Plan to move subscribers FROM.",!
;
; - select company/plan for subscribers to be moved
S IBQUIT=0
D SEL^IBCNSUR(0)
I IBQUIT S IBSTOP=1 Q
;
; IB*2.0*549 - Filtering questions begin here.
; - ask if they want to move the entire group plan
S DIR(0)="Y",DIR("A")="Do you want to move the entire group plan"
S DIR("B")="YES"
S DIR("?")="If you wish to be Selective of which Subscribers are moved, enter 'No' - otherwise, enter 'Yes'"
W ! D ^DIR K DIR
I Y="^" S IBQUIT=1 G PROCQ
S IBGRP=Y
;
; Make sure is at least one subscriber in the selected Insurance Company/Group Plan
I '$$SUBS^IBCNSJ(IBCNS,IBPLAN,0,,1) D G PROCQ
. W !!,?5,*7,"* This group plan has no subscribers!"
. S IBQUIT=1
;
I 'IBGRP D FILTER ; IB*2.0*549 - if not moving entire plan...proceed with filter questions.
I IBQUIT G PROCQ
;
COLLECT ; - collect the plan subscribers
S IBC1=IBCNS,IBP1=IBPLAN
W !!,"Collecting Subscribers ..."
I IBGRP D G:IBQUIT PROCQ
. S IBSUB=$$SUBS^IBCNSJ(IBC1,IBP1,0,"^TMP($J,""IBCNSUR"")")
. ; Proceed after all subscribers, etc. are accounted for.
. I 'IBSUB W !!,?5,*7,"* This group plan has no subscribers!" S IBQUIT=1 Q
. W !!,"This group plan has "_+IBSUB_" subscribers. All subscribers will be moved."
. S DIR(0)="Y",DIR("A")="Okay to continue"
. S DIR("?")="If you wish to move these subscribers, enter 'Yes' - otherwise, enter 'No.'"
. W ! D ^DIR K DIR
. I 'Y W !!,?10,"<Okay, nothing moved>" S IBQUIT=1 Q
;
I 'IBGRP D G:IBQUIT PROCQ ; Prompt for selected subscribers to move - IB*2*549 (vd)
. S NUMSEL=$$EN^IBCNSUR4(IBC1,IBP1,IBDEAD,IBSUBID,IBVALUE,IBSUBACT,IBEFDT,IBEFDT1,IBEFDT2) ; This is a new sub-routine to collect the subscribers using the various filters.
. I IBQUIT S IBSTOP=1 Q
. S IBSUB=+$P(NUMSEL,U,2)
. I '+NUMSEL W !!,?5,*7,"* No subscribers selected to be moved." S IBQUIT=1 Q
. ;
. W !!,"This group plan has "_+IBSUB_" subscribers. You have selected to move"
. W !,+NUMSEL_" of these subscribers."
. S DIR(0)="Y",DIR("A")="Okay to continue"
. S DIR("?")="If you wish to move these subscribers, enter 'Yes' - otherwise, enter 'No.'"
. W ! D ^DIR K DIR
. I 'Y W !!,?10,"<Okay, nothing moved>" S IBQUIT=1 Q
;
; - select company/plan to move subscribers
W !!!,"MOVE SUBSCRIBERS TO"
W !!,"Select the Insurance Company and Plan to move subscribers TO.",!
D SEL^IBCNSUR(1)
I IBQUIT G PROCQ
I $P($G(^DIC(36,IBCNS,0)),"^",5) W !!,*7,"You must move the subscribers to an active insurance company!" G PROCQ
S IBC2=IBCNS,IBP2=IBPLAN
;
; - make sure not moving the subscribers to their current plan
I (IBC1=IBC2)&(IBP1=IBP2) W !!,*7,"You must move the subscribers to a different plan!" G PROCQ
;
; - set name and plan number
S IBC1N=$P($G(^DIC(36,+IBC1,0)),U,1)
;IB*2.0*516/TAZ - Retrieve data from HIPAA compliant fields
;S IBP1N=$P($G(^IBA(355.3,+IBP1,0)),U,3,4),IBP1X=$P(IBP1N,U,2) ; 516 - baa
S IBP1N=$$GET1^DIQ(355.3,+IBP1,2.01)_U_$$GET1^DIQ(355.3,+IBP1,2.02),IBP1X=$P(IBP1N,U,2)
S IBP1X=$S(IBP1X]"":IBP1X,1:"<Not Specified>")
S IBC2N=$P($G(^DIC(36,+IBC2,0)),U,1)
;IB*2.0*516/TAZ - Retrieve data from HIPAA compliant fields
;S IBP2N=$P($G(^IBA(355.3,+IBP2,0)),U,3,4),IBP2X=$P(IBP2N,U,2) ; 516 - baa
S IBP2N=$$GET1^DIQ(355.3,+IBP2,2.01)_U_$$GET1^DIQ(355.3,+IBP2,2.02),IBP2X=$P(IBP2N,U,2)
S IBP2X=$S(IBP2X]"":IBP2X,1:"<Not Specified>")
S IBP2N=$S($P(IBP2N,U,1)="":"<Not Specified>",1:$P(IBP2N,U,1))
;
; - ask if they want to delete the old insurance
S DIR(0)="Y",DIR("A")="policy Effective date"
S DIR("A",1)="Do you want to EXPIRE the old patient policy(s) by entering the new"
S DIR("B")="NO"
S DIR("?")="If you wish to apply Effective Date, enter 'Yes' - otherwise, enter 'No'"
W ! D ^DIR K DIR
I $D(DIRUT) G PROCQ
S IBSPLIT=''Y
; if yes then
; - ask the effective date of the new insurance
I IBSPLIT D I IBQ G PROCQ
. S IBQ=0
. S %DT="AEX",%DT("A")="Effective Date of the new Plan Policy(s): "
. W ! D ^%DT K %DT I Y'>0 S IBQ=1 Q
. S IBEFFDT=$P(+Y,".")
. S IBEXPDT=$$FMADD^XLFDT(IBEFFDT,-1)
;
; - ask are they sure
W !!!,"You selected to move ",$S(+IBGRP:IBSUB,1:+NUMSEL)," subscriber(s) and "
W $S(IBSPLIT:"EXPIRE",1:"REPLACE")," the old group plan &"
W !,"policy in the patient profile.",!
W !?5,"FROM Insurance Company ",IBC1N
W !?10,"Plan Name ",$P(IBP1N,U,1)," Number ",IBP1X
W !?5,"TO Insurance Company ",IBC2N
W !?10,"Plan Name ",IBP2N," Number ",IBP2X
I IBSPLIT D
. W !?5,"BY switching to the new Insurance/Plan"
. W !?10,"with Effective Date ",$$DAT2^IBOUTL(IBEFFDT)
W !
W !,"Please Note that the old group plan & policy will be "
W $S(IBSPLIT:"EXPIRED",1:"REPLACED")," in the patient",!,"profile!",!
;
S DIR(0)="Y",DIR("A")="Okay to continue"
S DIR("?")="If you wish to move these subscribers, enter 'Yes' - otherwise, enter 'No.'"
W ! D ^DIR K DIR
I 'Y W !!,?10,"<Okay, nothing moved>" G PROCQ
;
; - should annual benefits be moved?
S (IBAB,IBQ)=0
I $D(^IBA(355.4,"APY",IBP1)),'$D(^IBA(355.4,"APY",IBP2)) D G:IBQ PROCQ
.S DIR(0)="Y",DIR("A")="Okay to add "_IBC1N_"'s plan Annual Benefits to "_IBC2N_"'s plan"
.S DIR("?")="If you wish to move these Annual Benefits, enter 'Yes' - otherwise, enter 'No.'"
.W ! D ^DIR K DIR I $D(DIRUT)!$D(DIROUT)!$D(DUOUT)!$D(DTOUT) S IBQ=1
.S:Y IBAB=1 K DIRUT,DUOUT,DTOUT,DIROUT
;
; - copy annual benefits over to the new plan
I IBAB D
.S IBI=0 F S IBI=$O(^IBA(355.4,"C",IBP1,IBI)) Q:'IBI D
..S IBIAB=$G(^IBA(355.4,IBI,0)) Q:'IBIAB
..S X=+IBIAB,DIC(0)="L",DLAYGO=355.4,DIC="^IBA(355.4,"
..K DD,DO D FILE^DICN Q:+Y<0 S IBCAB=+Y
..S $P(^IBA(355.4,IBCAB,0),"^",2)=IBP2
..S $P(^IBA(355.4,IBCAB,0),"^",5,6)=$P(IBIAB,"^",5,6)
..F I=1:1:5 I $G(^IBA(355.4,IBI,I))]"" S ^IBA(355.4,IBCAB,I)=^(I)
..S DA=IBCAB,DIK="^IBA(355.4," D IX1^DIK,EDUP^IBCNSA2
;
; - should plan comments be copied over to the new plan?
S (IBAB,IBQ)=0
I $P($G(^IBA(355.3,IBP1,11,0)),U,4),'$P($G(^IBA(355.3,IBP2,11,0)),U,4) D G:IBQ PROCQ
.S DIR(0)="Y"
.S DIR("A")="Okay to add "_IBC1N_"'s Comments to "_IBC2N_"'s plan"
.S DIR("?")="If you wish to move these Comments, enter 'Yes'"
.S DIR("?")=DIR("?")_" - otherwise, enter 'NO'."
.W ! D ^DIR K DIR I $D(DIRUT)!$D(DIROUT)!$D(DUOUT)!$D(DTOUT) S IBQ=1
.S:Y IBAB=1 K DIRUT,DUOUT,DTOUT,DIROUT
;
; - copy plan comments over to the new plan
I IBAB D
. ;IB*713/TAZ - Maintain blank lines in word processing field - user request.
. N ARRAY,LINE
. M ARRAY=^IBA(355.3,IBP1,11)
. ;File data in new location.
. D WP^DIE(355.3,IBP2_",",11,,"ARRAY")
.;S DIC="^IBA(355.3,"_IBP2_",11,",DIC(0)="L",DIC("P")=355.311
.;S IBI=0 F S IBI=$O(^IBA(355.3,IBP1,11,IBI)) Q:'IBI D
.;. I $G(^IBA(355.3,IBP1,11,IBI,0))]"" S X=^(0) D FILE^DICN
;
; The MailMan bulletin header
D BHEAD^IBCNSUR3
;
; - move the subscribers to the new plan
W !!,"Moving subscribers"
I IBGRP D G PROCA ; Move a group of subscribers
. S DFN=0 F S DFN=$O(^TMP($J,"IBCNSUR",DFN)) Q:'DFN D
. . S IBCDFN=0 F S IBCDFN=$O(^TMP($J,"IBCNSUR",DFN,IBCDFN)) Q:'IBCDFN D MOVESUB
;
I 'IBGRP D ; Move individual subscribers - IB*2*549 (VD)
. S DFN=0 F S DFN=$O(^TMP("IBCNSUR4A",$J,DFN)) Q:'DFN D
. . S IBCDFN=0 F S IBCDFN=$O(^TMP("IBCNSUR4A",$J,DFN,IBCDFN)) Q:'IBCDFN D MOVESUB
;
PROCA ; Proc continuation.
;
W !!,"Done. All subscribers were moved as requested!",!
D DONE^IBCNSUR3
W !,"The Bulletin was sent to you and members of 'IB NEW INSURANCE' Mail Group.",!
R !!,?10,"Press any key to continue. ",IBX:DTIME
;
; - finish processing in IBCNSUR (keep RSIZE down)
D PROC^IBCNSUR
;
PROCQ ;
K ^TMP($J,"IBCNSUR")
K ^TMP($J,"IBCNSUR1")
K ^TMP($J,"IBCNSURS")
K ^TMP("IBCNSUR4A",$J)
Q
;
MOVESUB ; Move the current subscriber.
Q:$P($G(^DPT(DFN,.312,IBCDFN,0)),"^",18)'=IBP1
;
D ADS^IBCNSUR3(DFN,IBCDFN)
I 'IBSPLIT D MODIFINS(IBC2,IBP2,DFN,IBCDFN) ;regular mode
I IBSPLIT D SPLITINS(IBC2,IBP2,DFN,IBCDFN,IBEFFDT,IBEXPDT)
; - merge previous benefits used
S IBDAT="" F S IBDAT=$O(^IBA(355.5,"APPY",DFN,IBP1,IBDAT)) Q:IBDAT="" D
. S IBCDFN1=0 F S IBCDFN1=$O(^IBA(355.5,"APPY",DFN,IBP1,IBDAT,IBCDFN1)) Q:'IBCDFN1 I IBCDFN1=IBCDFN S IBBU=$O(^(IBCDFN1,0)) D
. . I '$D(^IBA(355.4,"APY",IBP2,IBDAT)) D DBU^IBCNSJ(IBBU) Q
. . D MERG^IBCNSJ13(IBP2,IBBU)
;
W "."
Q
;
; modify the ins plan
MODIFINS(IBC2,IBP2,DFN,IBCDFN) ;
N DA,DIE,DR,IBX,IBXXX
; - change the policy company
S IBXXX='$G(^DPT(DFN,.312,IBCDFN,1))
S DIE="^DPT(DFN,.312,",DA(1)=DFN,DA=IBCDFN,DR=".01///`"_IBC2 D ^DIE K DIE,DA,DR
I IBXXX S $P(^DPT(DFN,.312,IBCDFN,1),"^",1,2)="^"
;
; - repoint Insurance Reviews to the new company
S IBX=0 F S IBX=$O(^IBT(356.2,"D",DFN,IBX)) Q:'IBX I $P($G(^IBT(356.2,IBX,1)),"^",5)=IBCDFN S DIE="^IBT(356.2,",DA=IBX,DR=".08////"_IBC2 D ^DIE K DIE,DA,DR
;
; - change the policy plan
D SWPL^IBCNSJ13(IBP2,DFN,IBCDFN)
Q
; change the ins plan effective IBEFFDT
SPLITINS(IBC2,IBP2,DFN,IBCDFN,IBEFFDT,IBEXPDT) ;
N DA,DGRUGA08,DIE,DIK,DR,IBCDFN2,IBERR,IBI,IBIEN,IBRT,IBX,IBZ,IBZ1
S IBZ=$G(^DPT(DFN,.312,IBCDFN,0))
S IBZ1=$G(^DPT(DFN,.312,IBCDFN,1))
; - ignore if the old plan expired
I $P(IBZ,U,4),$P(IBZ,U,4)<IBEFFDT Q
; - if the ins is effective later - no need to split
I $P(IBZ,U,8),$P(IBZ,U,8)'<IBEFFDT D MODIFINS(IBC2,IBP2,DFN,IBCDFN) Q
;
S DGRUGA08=1 ; Disable HL7 triggered by 2.312/3 and 2.312/8
; - create the new insurance record for the DFN (clone)
S IBI="+1,"_DFN_","
; - add a record
S IBRT(2.312,IBI,.01)=IBC2
D UPDATE^DIE("","IBRT","IBIEN","IBERR")
I $D(IBERR) Q ; error
I '$G(IBIEN(1)) Q ; error
S IBCDFN2=+IBIEN(1)
; - clone the insurance data
M ^DPT(DFN,.312,IBCDFN2)=^DPT(DFN,.312,IBCDFN)
S $P(^DPT(DFN,.312,IBCDFN2,0),U,1)=IBC2
S $P(^DPT(DFN,.312,IBCDFN2,0),U,8)=IBEFFDT
; - now reindex
S DA(1)=DFN,DA=IBCDFN2,DIK="^DPT("_DFN_",.312,"
D IX1^DIK
; - change the policy plan
D SWPL^IBCNSJ13(IBP2,DFN,IBCDFN2)
; - set the expiration date
S $P(^DPT(DFN,.312,IBCDFN,0),U,4)=IBEXPDT
S DA(1)=DFN,DA=IBCDFN,DIK="^DPT("_DFN_",.312,"
D IX1^DIK
Q
;
FILTER ; IB*2.0*549 - Prompts for Filter questions.
; if no, then proceed with the filtering questions.
; - ask if they want to continue because they are about to select individual subscribers
S DIR(0)="Y",DIR("A")="You have selected to move individual subscribers. Okay to continue"
S DIR("B")="YES"
S DIR("?")="If you wish to continue being Selective of which Subscribers are moved, enter 'Yes' - otherwise, enter 'No' to quit."
W ! D ^DIR K DIR
; if yes then proceed with collecting the subscribers for the entire plan.
I '+Y!(Y="^") S IBQUIT=1 Q ; QUIT
;
; - ask if they want to filter out Deceased Patients
S DIR(0)="Y",DIR("A")="Do you want to filter out deceased patients"
S DIR("B")="YES"
S DIR("?")="If you wish to ignore Deceased Patients in the selection process, enter 'Yes' - otherwise, enter 'No'"
W ! D ^DIR K DIR
I Y="^" S IBQUIT=1 Q
S IBDEAD=+Y ; 1=ignore deceased patients, 0=include deceased patients.
;
; - ask if they want to filter based on Subscriber ID
S DIR(0)="YO",DIR("A")="Do you want to filter Subscriber ID"
S DIR("B")="YES"
S DIR("?")="If you wish to filter subscribers based upon the Subscriber ID, enter 'Yes' - otherwise, enter 'No'"
W ! D ^DIR K DIR
I Y="^" S IBQUIT=1 Q
S IBSUBID=+Y ; 1=filter based upon the Subscriber ID, 0=ignore Subscriber IDs.
S IBQUIT=0
S IBVALUE=""
I +IBSUBID D I +IBQUIT Q
. ;
. ; - ask user to enter the value that subscriber IDs need to 'contain'
. S DIR(0)="FAO",DIR("A")="Filter Subscriber IDs that contain: "
. S DIR("?")="Enter value that Subscriber IDs should contain. NULL value means blank values."
. D ^DIR K DIR
. I Y="^" S IBQUIT=1 Q
. S IBVALUE=$$UP^XLFSTR(Y)
;
; - ask if they want to filter based on ACTIVE or INACTIVE
S DIR(0)="Y",DIR("A")="Do you want to filter for active or inactive policies"
S DIR("B")="YES"
S DIR("?")="If you wish to specify filter subscribers based upon ACTIVE or INACTIVE, enter 'Yes' - otherwise, enter 'No'"
W ! D ^DIR K DIR
I Y="^" S IBQUIT=1 Q
S IBSUBACT=+Y ; 1=filter based upon the ACTIVE or INACTIVE, 0=ignore ACTIVE status.
;
I IBSUBACT D I +IBQUIT Q
. ; Filter based on Active or Inactive policies.
. S DIR(0)="SA^1:1 Active Policies;2:2 Inactive Policies;3:3 Both"
. S DIR("A")=" SELECT 1 or 2 or 3: "
. S DIR("A",1)="1. Active Policies"
. S DIR("A",2)="2. Inactive Policies"
. S DIR("A",3)="3. Both"
. S DIR("B")=1
. S DIR("?",1)=" 1 - Only allow selection of ACTIVE Policies"
. S DIR("?",2)=" 2 - Only allow selection of INACTIVE Policies"
. S DIR("?")=" 3 - Allow selection of ACTIVE and INACTIVE Policies"
. D ^DIR K DIR I Y<0!$D(DIRUT) S IBQUIT=1 Q
. S IBSUBACT=Y K Y
;
; - ask if they want to filter based on Effective Dates
S DIR(0)="Y",DIR("A")="Do you want to filter Effective Dates"
S DIR("B")="NO"
S DIR("?")="If you wish to specify filter subscribers based upon Effective Dates, enter 'Yes' - otherwise, enter 'No'"
W ! D ^DIR K DIR
I Y="^" S IBQUIT=1 Q
S IBEFDT=+Y ; 1=filter based upon Effective Dates, 0=ignore Effective Dates.
I 'IBEFDT S (IBEFDT1,IBEFDT2)="" Q
;
FILTERA ; Enter Effective Date range to filter subscribers.
N TODAY
S TODAY=$$DAT1^IBOUTL(DT) K DIR
W ! S DIR(0)="DAO",DIR("A")="Start with DATE: ",DIR("?")="Enter the earliest Effective Date to filter Subscribers."
D ^DIR K DIR
I '$L(Y) D Q
. S IBEFDT=0,(IBEFDT1,IBEFDT2)="" Q
I Y="^" S IBQUIT=1 Q
S IBEFDT1=Y
;
FILTERB ; Enter End Date
W ! S DIR(0)="DA",DIR("A")="Go to DATE: ",DIR("B")=TODAY,DIR("?")="Enter the latest Effective Date to filter Subscribers."
D ^DIR K DIR
I 'Y S IBQUIT=1 Q
S IBEFDT2=Y
I IBEFDT2<IBEFDT1 W !,"End date cannot be less than Start date. Please re-enter date range." G FILTERB
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSUR1 14943 printed Sep 23, 2025@19:54:19 Page 2
IBCNSUR1 ;ALB/CPM/CMS - MOVE SUBSCRIBERS TO DIFFERENT PLAN (CON'T) ;09-SEP-96
+1 ;;2.0;INTEGRATED BILLING;**103,225,276,516,549,713**;21-MAR-94;Build 12
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
PROC ; - Top of processing from IBCNSUR
+1 ; Move subscribers to another company's insurance plan.
+2 NEW D0,DA,DFN,DIC,DIE,DIK,DIR,DIROUT,DIRUT,DLAYGO,DR,DTOUT,DUOUT
+3 NEW I,IBAB,IBBU,IBC1,IBC1N,IBC1X,IBC2,IBC2N,IBC2X
+4 NEW IBCAB,IBCDFN,IBCDFN1,IBCNS,IBCPOL,IBDAT,IBDEAD,IBDONE
+5 NEW IBEFDT,IBEFDT1,IBEFDT2,IBEFFDT,IBEXPDT,IBGRP,IBI,IBIAB,IBLN
+6 NEW IBNP,IBP1,IBP1N,IBP1X,IBP2,IBP2N,IBP2X,IBPLAN,IBQ,IBQUIT
+7 NEW IBSPLIT,IBST,IBSUB,IBSUBACT,IBSUBID,IBVALUE,IBW,IBXXX,IBX
+8 NEW NUMSEL,REF,X,Y
+9 ;
+10 ; subscribers
KILL ^TMP($JOB,"IBCNSUR")
+11 ; e-mail bulletin
KILL ^TMP($JOB,"IBCNSUR1")
+12 SET REF=$NAME(^TMP($JOB,"IBCNSUR1"))
SET IBLN=0
+13 ;
+14 SET (IBDONE,IBQUIT,NUMSEL)=0
+15 ;
+16 WRITE !!!,"=====================",!,"MOVE SUBSCRIBERS FROM",!,"====================="
+17 WRITE !!,"Select the Insurance Company and Plan to move subscribers FROM.",!
+18 ;
+19 ; - select company/plan for subscribers to be moved
+20 SET IBQUIT=0
+21 DO SEL^IBCNSUR(0)
+22 IF IBQUIT
SET IBSTOP=1
QUIT
+23 ;
+24 ; IB*2.0*549 - Filtering questions begin here.
+25 ; - ask if they want to move the entire group plan
+26 SET DIR(0)="Y"
SET DIR("A")="Do you want to move the entire group plan"
+27 SET DIR("B")="YES"
+28 SET DIR("?")="If you wish to be Selective of which Subscribers are moved, enter 'No' - otherwise, enter 'Yes'"
+29 WRITE !
DO ^DIR
KILL DIR
+30 IF Y="^"
SET IBQUIT=1
GOTO PROCQ
+31 SET IBGRP=Y
+32 ;
+33 ; Make sure is at least one subscriber in the selected Insurance Company/Group Plan
+34 IF '$$SUBS^IBCNSJ(IBCNS,IBPLAN,0,,1)
Begin DoDot:1
+35 WRITE !!,?5,*7,"* This group plan has no subscribers!"
+36 SET IBQUIT=1
End DoDot:1
GOTO PROCQ
+37 ;
+38 ; IB*2.0*549 - if not moving entire plan...proceed with filter questions.
IF 'IBGRP
DO FILTER
+39 IF IBQUIT
GOTO PROCQ
+40 ;
COLLECT ; - collect the plan subscribers
+1 SET IBC1=IBCNS
SET IBP1=IBPLAN
+2 WRITE !!,"Collecting Subscribers ..."
+3 IF IBGRP
Begin DoDot:1
+4 SET IBSUB=$$SUBS^IBCNSJ(IBC1,IBP1,0,"^TMP($J,""IBCNSUR"")")
+5 ; Proceed after all subscribers, etc. are accounted for.
+6 IF 'IBSUB
WRITE !!,?5,*7,"* This group plan has no subscribers!"
SET IBQUIT=1
QUIT
+7 WRITE !!,"This group plan has "_+IBSUB_" subscribers. All subscribers will be moved."
+8 SET DIR(0)="Y"
SET DIR("A")="Okay to continue"
+9 SET DIR("?")="If you wish to move these subscribers, enter 'Yes' - otherwise, enter 'No.'"
+10 WRITE !
DO ^DIR
KILL DIR
+11 IF 'Y
WRITE !!,?10,"<Okay, nothing moved>"
SET IBQUIT=1
QUIT
End DoDot:1
if IBQUIT
GOTO PROCQ
+12 ;
+13 ; Prompt for selected subscribers to move - IB*2*549 (vd)
IF 'IBGRP
Begin DoDot:1
+14 ; This is a new sub-routine to collect the subscribers using the various filters.
SET NUMSEL=$$EN^IBCNSUR4(IBC1,IBP1,IBDEAD,IBSUBID,IBVALUE,IBSUBACT,IBEFDT,IBEFDT1,IBEFDT2)
+15 IF IBQUIT
SET IBSTOP=1
QUIT
+16 SET IBSUB=+$PIECE(NUMSEL,U,2)
+17 IF '+NUMSEL
WRITE !!,?5,*7,"* No subscribers selected to be moved."
SET IBQUIT=1
QUIT
+18 ;
+19 WRITE !!,"This group plan has "_+IBSUB_" subscribers. You have selected to move"
+20 WRITE !,+NUMSEL_" of these subscribers."
+21 SET DIR(0)="Y"
SET DIR("A")="Okay to continue"
+22 SET DIR("?")="If you wish to move these subscribers, enter 'Yes' - otherwise, enter 'No.'"
+23 WRITE !
DO ^DIR
KILL DIR
+24 IF 'Y
WRITE !!,?10,"<Okay, nothing moved>"
SET IBQUIT=1
QUIT
End DoDot:1
if IBQUIT
GOTO PROCQ
+25 ;
+26 ; - select company/plan to move subscribers
+27 WRITE !!!,"MOVE SUBSCRIBERS TO"
+28 WRITE !!,"Select the Insurance Company and Plan to move subscribers TO.",!
+29 DO SEL^IBCNSUR(1)
+30 IF IBQUIT
GOTO PROCQ
+31 IF $PIECE($GET(^DIC(36,IBCNS,0)),"^",5)
WRITE !!,*7,"You must move the subscribers to an active insurance company!"
GOTO PROCQ
+32 SET IBC2=IBCNS
SET IBP2=IBPLAN
+33 ;
+34 ; - make sure not moving the subscribers to their current plan
+35 IF (IBC1=IBC2)&(IBP1=IBP2)
WRITE !!,*7,"You must move the subscribers to a different plan!"
GOTO PROCQ
+36 ;
+37 ; - set name and plan number
+38 SET IBC1N=$PIECE($GET(^DIC(36,+IBC1,0)),U,1)
+39 ;IB*2.0*516/TAZ - Retrieve data from HIPAA compliant fields
+40 ;S IBP1N=$P($G(^IBA(355.3,+IBP1,0)),U,3,4),IBP1X=$P(IBP1N,U,2) ; 516 - baa
+41 SET IBP1N=$$GET1^DIQ(355.3,+IBP1,2.01)_U_$$GET1^DIQ(355.3,+IBP1,2.02)
SET IBP1X=$PIECE(IBP1N,U,2)
+42 SET IBP1X=$SELECT(IBP1X]"":IBP1X,1:"<Not Specified>")
+43 SET IBC2N=$PIECE($GET(^DIC(36,+IBC2,0)),U,1)
+44 ;IB*2.0*516/TAZ - Retrieve data from HIPAA compliant fields
+45 ;S IBP2N=$P($G(^IBA(355.3,+IBP2,0)),U,3,4),IBP2X=$P(IBP2N,U,2) ; 516 - baa
+46 SET IBP2N=$$GET1^DIQ(355.3,+IBP2,2.01)_U_$$GET1^DIQ(355.3,+IBP2,2.02)
SET IBP2X=$PIECE(IBP2N,U,2)
+47 SET IBP2X=$SELECT(IBP2X]"":IBP2X,1:"<Not Specified>")
+48 SET IBP2N=$SELECT($PIECE(IBP2N,U,1)="":"<Not Specified>",1:$PIECE(IBP2N,U,1))
+49 ;
+50 ; - ask if they want to delete the old insurance
+51 SET DIR(0)="Y"
SET DIR("A")="policy Effective date"
+52 SET DIR("A",1)="Do you want to EXPIRE the old patient policy(s) by entering the new"
+53 SET DIR("B")="NO"
+54 SET DIR("?")="If you wish to apply Effective Date, enter 'Yes' - otherwise, enter 'No'"
+55 WRITE !
DO ^DIR
KILL DIR
+56 IF $DATA(DIRUT)
GOTO PROCQ
+57 SET IBSPLIT=''Y
+58 ; if yes then
+59 ; - ask the effective date of the new insurance
+60 IF IBSPLIT
Begin DoDot:1
+61 SET IBQ=0
+62 SET %DT="AEX"
SET %DT("A")="Effective Date of the new Plan Policy(s): "
+63 WRITE !
DO ^%DT
KILL %DT
IF Y'>0
SET IBQ=1
QUIT
+64 SET IBEFFDT=$PIECE(+Y,".")
+65 SET IBEXPDT=$$FMADD^XLFDT(IBEFFDT,-1)
End DoDot:1
IF IBQ
GOTO PROCQ
+66 ;
+67 ; - ask are they sure
+68 WRITE !!!,"You selected to move ",$SELECT(+IBGRP:IBSUB,1:+NUMSEL)," subscriber(s) and "
+69 WRITE $SELECT(IBSPLIT:"EXPIRE",1:"REPLACE")," the old group plan &"
+70 WRITE !,"policy in the patient profile.",!
+71 WRITE !?5,"FROM Insurance Company ",IBC1N
+72 WRITE !?10,"Plan Name ",$PIECE(IBP1N,U,1)," Number ",IBP1X
+73 WRITE !?5,"TO Insurance Company ",IBC2N
+74 WRITE !?10,"Plan Name ",IBP2N," Number ",IBP2X
+75 IF IBSPLIT
Begin DoDot:1
+76 WRITE !?5,"BY switching to the new Insurance/Plan"
+77 WRITE !?10,"with Effective Date ",$$DAT2^IBOUTL(IBEFFDT)
End DoDot:1
+78 WRITE !
+79 WRITE !,"Please Note that the old group plan & policy will be "
+80 WRITE $SELECT(IBSPLIT:"EXPIRED",1:"REPLACED")," in the patient",!,"profile!",!
+81 ;
+82 SET DIR(0)="Y"
SET DIR("A")="Okay to continue"
+83 SET DIR("?")="If you wish to move these subscribers, enter 'Yes' - otherwise, enter 'No.'"
+84 WRITE !
DO ^DIR
KILL DIR
+85 IF 'Y
WRITE !!,?10,"<Okay, nothing moved>"
GOTO PROCQ
+86 ;
+87 ; - should annual benefits be moved?
+88 SET (IBAB,IBQ)=0
+89 IF $DATA(^IBA(355.4,"APY",IBP1))
IF '$DATA(^IBA(355.4,"APY",IBP2))
Begin DoDot:1
+90 SET DIR(0)="Y"
SET DIR("A")="Okay to add "_IBC1N_"'s plan Annual Benefits to "_IBC2N_"'s plan"
+91 SET DIR("?")="If you wish to move these Annual Benefits, enter 'Yes' - otherwise, enter 'No.'"
+92 WRITE !
DO ^DIR
KILL DIR
IF $DATA(DIRUT)!$DATA(DIROUT)!$DATA(DUOUT)!$DATA(DTOUT)
SET IBQ=1
+93 if Y
SET IBAB=1
KILL DIRUT,DUOUT,DTOUT,DIROUT
End DoDot:1
if IBQ
GOTO PROCQ
+94 ;
+95 ; - copy annual benefits over to the new plan
+96 IF IBAB
Begin DoDot:1
+97 SET IBI=0
FOR
SET IBI=$ORDER(^IBA(355.4,"C",IBP1,IBI))
if 'IBI
QUIT
Begin DoDot:2
+98 SET IBIAB=$GET(^IBA(355.4,IBI,0))
if 'IBIAB
QUIT
+99 SET X=+IBIAB
SET DIC(0)="L"
SET DLAYGO=355.4
SET DIC="^IBA(355.4,"
+100 KILL DD,DO
DO FILE^DICN
if +Y<0
QUIT
SET IBCAB=+Y
+101 SET $PIECE(^IBA(355.4,IBCAB,0),"^",2)=IBP2
+102 SET $PIECE(^IBA(355.4,IBCAB,0),"^",5,6)=$PIECE(IBIAB,"^",5,6)
+103 FOR I=1:1:5
IF $GET(^IBA(355.4,IBI,I))]""
SET ^IBA(355.4,IBCAB,I)=^(I)
+104 SET DA=IBCAB
SET DIK="^IBA(355.4,"
DO IX1^DIK
DO EDUP^IBCNSA2
End DoDot:2
End DoDot:1
+105 ;
+106 ; - should plan comments be copied over to the new plan?
+107 SET (IBAB,IBQ)=0
+108 IF $PIECE($GET(^IBA(355.3,IBP1,11,0)),U,4)
IF '$PIECE($GET(^IBA(355.3,IBP2,11,0)),U,4)
Begin DoDot:1
+109 SET DIR(0)="Y"
+110 SET DIR("A")="Okay to add "_IBC1N_"'s Comments to "_IBC2N_"'s plan"
+111 SET DIR("?")="If you wish to move these Comments, enter 'Yes'"
+112 SET DIR("?")=DIR("?")_" - otherwise, enter 'NO'."
+113 WRITE !
DO ^DIR
KILL DIR
IF $DATA(DIRUT)!$DATA(DIROUT)!$DATA(DUOUT)!$DATA(DTOUT)
SET IBQ=1
+114 if Y
SET IBAB=1
KILL DIRUT,DUOUT,DTOUT,DIROUT
End DoDot:1
if IBQ
GOTO PROCQ
+115 ;
+116 ; - copy plan comments over to the new plan
+117 IF IBAB
Begin DoDot:1
+118 ;IB*713/TAZ - Maintain blank lines in word processing field - user request.
+119 NEW ARRAY,LINE
+120 MERGE ARRAY=^IBA(355.3,IBP1,11)
+121 ;File data in new location.
+122 DO WP^DIE(355.3,IBP2_",",11,,"ARRAY")
+123 ;S DIC="^IBA(355.3,"_IBP2_",11,",DIC(0)="L",DIC("P")=355.311
+124 ;S IBI=0 F S IBI=$O(^IBA(355.3,IBP1,11,IBI)) Q:'IBI D
+125 ;. I $G(^IBA(355.3,IBP1,11,IBI,0))]"" S X=^(0) D FILE^DICN
End DoDot:1
+126 ;
+127 ; The MailMan bulletin header
+128 DO BHEAD^IBCNSUR3
+129 ;
+130 ; - move the subscribers to the new plan
+131 WRITE !!,"Moving subscribers"
+132 ; Move a group of subscribers
IF IBGRP
Begin DoDot:1
+133 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,"IBCNSUR",DFN))
if 'DFN
QUIT
Begin DoDot:2
+134 SET IBCDFN=0
FOR
SET IBCDFN=$ORDER(^TMP($JOB,"IBCNSUR",DFN,IBCDFN))
if 'IBCDFN
QUIT
DO MOVESUB
End DoDot:2
End DoDot:1
GOTO PROCA
+135 ;
+136 ; Move individual subscribers - IB*2*549 (VD)
IF 'IBGRP
Begin DoDot:1
+137 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("IBCNSUR4A",$JOB,DFN))
if 'DFN
QUIT
Begin DoDot:2
+138 SET IBCDFN=0
FOR
SET IBCDFN=$ORDER(^TMP("IBCNSUR4A",$JOB,DFN,IBCDFN))
if 'IBCDFN
QUIT
DO MOVESUB
End DoDot:2
End DoDot:1
+139 ;
PROCA ; Proc continuation.
+1 ;
+2 WRITE !!,"Done. All subscribers were moved as requested!",!
+3 DO DONE^IBCNSUR3
+4 WRITE !,"The Bulletin was sent to you and members of 'IB NEW INSURANCE' Mail Group.",!
+5 READ !!,?10,"Press any key to continue. ",IBX:DTIME
+6 ;
+7 ; - finish processing in IBCNSUR (keep RSIZE down)
+8 DO PROC^IBCNSUR
+9 ;
PROCQ ;
+1 KILL ^TMP($JOB,"IBCNSUR")
+2 KILL ^TMP($JOB,"IBCNSUR1")
+3 KILL ^TMP($JOB,"IBCNSURS")
+4 KILL ^TMP("IBCNSUR4A",$JOB)
+5 QUIT
+6 ;
MOVESUB ; Move the current subscriber.
+1 if $PIECE($GET(^DPT(DFN,.312,IBCDFN,0)),"^",18)'=IBP1
QUIT
+2 ;
+3 DO ADS^IBCNSUR3(DFN,IBCDFN)
+4 ;regular mode
IF 'IBSPLIT
DO MODIFINS(IBC2,IBP2,DFN,IBCDFN)
+5 IF IBSPLIT
DO SPLITINS(IBC2,IBP2,DFN,IBCDFN,IBEFFDT,IBEXPDT)
+6 ; - merge previous benefits used
+7 SET IBDAT=""
FOR
SET IBDAT=$ORDER(^IBA(355.5,"APPY",DFN,IBP1,IBDAT))
if IBDAT=""
QUIT
Begin DoDot:1
+8 SET IBCDFN1=0
FOR
SET IBCDFN1=$ORDER(^IBA(355.5,"APPY",DFN,IBP1,IBDAT,IBCDFN1))
if 'IBCDFN1
QUIT
IF IBCDFN1=IBCDFN
SET IBBU=$ORDER(^(IBCDFN1,0))
Begin DoDot:2
+9 IF '$DATA(^IBA(355.4,"APY",IBP2,IBDAT))
DO DBU^IBCNSJ(IBBU)
QUIT
+10 DO MERG^IBCNSJ13(IBP2,IBBU)
End DoDot:2
End DoDot:1
+11 ;
+12 WRITE "."
+13 QUIT
+14 ;
+15 ; modify the ins plan
MODIFINS(IBC2,IBP2,DFN,IBCDFN) ;
+1 NEW DA,DIE,DR,IBX,IBXXX
+2 ; - change the policy company
+3 SET IBXXX='$GET(^DPT(DFN,.312,IBCDFN,1))
+4 SET DIE="^DPT(DFN,.312,"
SET DA(1)=DFN
SET DA=IBCDFN
SET DR=".01///`"_IBC2
DO ^DIE
KILL DIE,DA,DR
+5 IF IBXXX
SET $PIECE(^DPT(DFN,.312,IBCDFN,1),"^",1,2)="^"
+6 ;
+7 ; - repoint Insurance Reviews to the new company
+8 SET IBX=0
FOR
SET IBX=$ORDER(^IBT(356.2,"D",DFN,IBX))
if 'IBX
QUIT
IF $PIECE($GET(^IBT(356.2,IBX,1)),"^",5)=IBCDFN
SET DIE="^IBT(356.2,"
SET DA=IBX
SET DR=".08////"_IBC2
DO ^DIE
KILL DIE,DA,DR
+9 ;
+10 ; - change the policy plan
+11 DO SWPL^IBCNSJ13(IBP2,DFN,IBCDFN)
+12 QUIT
+13 ; change the ins plan effective IBEFFDT
SPLITINS(IBC2,IBP2,DFN,IBCDFN,IBEFFDT,IBEXPDT) ;
+1 NEW DA,DGRUGA08,DIE,DIK,DR,IBCDFN2,IBERR,IBI,IBIEN,IBRT,IBX,IBZ,IBZ1
+2 SET IBZ=$GET(^DPT(DFN,.312,IBCDFN,0))
+3 SET IBZ1=$GET(^DPT(DFN,.312,IBCDFN,1))
+4 ; - ignore if the old plan expired
+5 IF $PIECE(IBZ,U,4)
IF $PIECE(IBZ,U,4)<IBEFFDT
QUIT
+6 ; - if the ins is effective later - no need to split
+7 IF $PIECE(IBZ,U,8)
IF $PIECE(IBZ,U,8)'<IBEFFDT
DO MODIFINS(IBC2,IBP2,DFN,IBCDFN)
QUIT
+8 ;
+9 ; Disable HL7 triggered by 2.312/3 and 2.312/8
SET DGRUGA08=1
+10 ; - create the new insurance record for the DFN (clone)
+11 SET IBI="+1,"_DFN_","
+12 ; - add a record
+13 SET IBRT(2.312,IBI,.01)=IBC2
+14 DO UPDATE^DIE("","IBRT","IBIEN","IBERR")
+15 ; error
IF $DATA(IBERR)
QUIT
+16 ; error
IF '$GET(IBIEN(1))
QUIT
+17 SET IBCDFN2=+IBIEN(1)
+18 ; - clone the insurance data
+19 MERGE ^DPT(DFN,.312,IBCDFN2)=^DPT(DFN,.312,IBCDFN)
+20 SET $PIECE(^DPT(DFN,.312,IBCDFN2,0),U,1)=IBC2
+21 SET $PIECE(^DPT(DFN,.312,IBCDFN2,0),U,8)=IBEFFDT
+22 ; - now reindex
+23 SET DA(1)=DFN
SET DA=IBCDFN2
SET DIK="^DPT("_DFN_",.312,"
+24 DO IX1^DIK
+25 ; - change the policy plan
+26 DO SWPL^IBCNSJ13(IBP2,DFN,IBCDFN2)
+27 ; - set the expiration date
+28 SET $PIECE(^DPT(DFN,.312,IBCDFN,0),U,4)=IBEXPDT
+29 SET DA(1)=DFN
SET DA=IBCDFN
SET DIK="^DPT("_DFN_",.312,"
+30 DO IX1^DIK
+31 QUIT
+32 ;
FILTER ; IB*2.0*549 - Prompts for Filter questions.
+1 ; if no, then proceed with the filtering questions.
+2 ; - ask if they want to continue because they are about to select individual subscribers
+3 SET DIR(0)="Y"
SET DIR("A")="You have selected to move individual subscribers. Okay to continue"
+4 SET DIR("B")="YES"
+5 SET DIR("?")="If you wish to continue being Selective of which Subscribers are moved, enter 'Yes' - otherwise, enter 'No' to quit."
+6 WRITE !
DO ^DIR
KILL DIR
+7 ; if yes then proceed with collecting the subscribers for the entire plan.
+8 ; QUIT
IF '+Y!(Y="^")
SET IBQUIT=1
QUIT
+9 ;
+10 ; - ask if they want to filter out Deceased Patients
+11 SET DIR(0)="Y"
SET DIR("A")="Do you want to filter out deceased patients"
+12 SET DIR("B")="YES"
+13 SET DIR("?")="If you wish to ignore Deceased Patients in the selection process, enter 'Yes' - otherwise, enter 'No'"
+14 WRITE !
DO ^DIR
KILL DIR
+15 IF Y="^"
SET IBQUIT=1
QUIT
+16 ; 1=ignore deceased patients, 0=include deceased patients.
SET IBDEAD=+Y
+17 ;
+18 ; - ask if they want to filter based on Subscriber ID
+19 SET DIR(0)="YO"
SET DIR("A")="Do you want to filter Subscriber ID"
+20 SET DIR("B")="YES"
+21 SET DIR("?")="If you wish to filter subscribers based upon the Subscriber ID, enter 'Yes' - otherwise, enter 'No'"
+22 WRITE !
DO ^DIR
KILL DIR
+23 IF Y="^"
SET IBQUIT=1
QUIT
+24 ; 1=filter based upon the Subscriber ID, 0=ignore Subscriber IDs.
SET IBSUBID=+Y
+25 SET IBQUIT=0
+26 SET IBVALUE=""
+27 IF +IBSUBID
Begin DoDot:1
+28 ;
+29 ; - ask user to enter the value that subscriber IDs need to 'contain'
+30 SET DIR(0)="FAO"
SET DIR("A")="Filter Subscriber IDs that contain: "
+31 SET DIR("?")="Enter value that Subscriber IDs should contain. NULL value means blank values."
+32 DO ^DIR
KILL DIR
+33 IF Y="^"
SET IBQUIT=1
QUIT
+34 SET IBVALUE=$$UP^XLFSTR(Y)
End DoDot:1
IF +IBQUIT
QUIT
+35 ;
+36 ; - ask if they want to filter based on ACTIVE or INACTIVE
+37 SET DIR(0)="Y"
SET DIR("A")="Do you want to filter for active or inactive policies"
+38 SET DIR("B")="YES"
+39 SET DIR("?")="If you wish to specify filter subscribers based upon ACTIVE or INACTIVE, enter 'Yes' - otherwise, enter 'No'"
+40 WRITE !
DO ^DIR
KILL DIR
+41 IF Y="^"
SET IBQUIT=1
QUIT
+42 ; 1=filter based upon the ACTIVE or INACTIVE, 0=ignore ACTIVE status.
SET IBSUBACT=+Y
+43 ;
+44 IF IBSUBACT
Begin DoDot:1
+45 ; Filter based on Active or Inactive policies.
+46 SET DIR(0)="SA^1:1 Active Policies;2:2 Inactive Policies;3:3 Both"
+47 SET DIR("A")=" SELECT 1 or 2 or 3: "
+48 SET DIR("A",1)="1. Active Policies"
+49 SET DIR("A",2)="2. Inactive Policies"
+50 SET DIR("A",3)="3. Both"
+51 SET DIR("B")=1
+52 SET DIR("?",1)=" 1 - Only allow selection of ACTIVE Policies"
+53 SET DIR("?",2)=" 2 - Only allow selection of INACTIVE Policies"
+54 SET DIR("?")=" 3 - Allow selection of ACTIVE and INACTIVE Policies"
+55 DO ^DIR
KILL DIR
IF Y<0!$DATA(DIRUT)
SET IBQUIT=1
QUIT
+56 SET IBSUBACT=Y
KILL Y
End DoDot:1
IF +IBQUIT
QUIT
+57 ;
+58 ; - ask if they want to filter based on Effective Dates
+59 SET DIR(0)="Y"
SET DIR("A")="Do you want to filter Effective Dates"
+60 SET DIR("B")="NO"
+61 SET DIR("?")="If you wish to specify filter subscribers based upon Effective Dates, enter 'Yes' - otherwise, enter 'No'"
+62 WRITE !
DO ^DIR
KILL DIR
+63 IF Y="^"
SET IBQUIT=1
QUIT
+64 ; 1=filter based upon Effective Dates, 0=ignore Effective Dates.
SET IBEFDT=+Y
+65 IF 'IBEFDT
SET (IBEFDT1,IBEFDT2)=""
QUIT
+66 ;
FILTERA ; Enter Effective Date range to filter subscribers.
+1 NEW TODAY
+2 SET TODAY=$$DAT1^IBOUTL(DT)
KILL DIR
+3 WRITE !
SET DIR(0)="DAO"
SET DIR("A")="Start with DATE: "
SET DIR("?")="Enter the earliest Effective Date to filter Subscribers."
+4 DO ^DIR
KILL DIR
+5 IF '$LENGTH(Y)
Begin DoDot:1
+6 SET IBEFDT=0
SET (IBEFDT1,IBEFDT2)=""
QUIT
End DoDot:1
QUIT
+7 IF Y="^"
SET IBQUIT=1
QUIT
+8 SET IBEFDT1=Y
+9 ;
FILTERB ; Enter End Date
+1 WRITE !
SET DIR(0)="DA"
SET DIR("A")="Go to DATE: "
SET DIR("B")=TODAY
SET DIR("?")="Enter the latest Effective Date to filter Subscribers."
+2 DO ^DIR
KILL DIR
+3 IF 'Y
SET IBQUIT=1
QUIT
+4 SET IBEFDT2=Y
+5 IF IBEFDT2<IBEFDT1
WRITE !,"End date cannot be less than Start date. Please re-enter date range."
GOTO FILTERB
+6 QUIT
+7 ;
