source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSUR1.m@ 691

Last change on this file since 691 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 8.0 KB
RevLine 
[613]1IBCNSUR1 ;ALB/CPM/CMS - MOVE SUBSCRIBERS TO DIFFERENT PLAN (CON'T) ;09-SEP-96
2 ;;2.0;INTEGRATED BILLING;**103,225,276**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7PROC ; - Top of processing from IBCNSUR
8 ; Move subscribers to another company's insurance plan.
9 N IBCNS,IBPLAN,IBC1,IBC1N,IBC1X,IBC2,IBC2N,IBC2X,IBCPOL
10 N IBP1,IBP1N,IBP1X,IBP2,IBP2N,IBP2X,IBQ,IBQUIT,IBSUB,DFN,IBCDFN
11 N IBXXX,IBX,IBDAT,IBCDFN1,IBNP,IBAB,IBI,IBIAB,IBCAB,IBW,IBST
12 N DIC,DIE,DR,DA,D0,DIR,DIRUT,DIROUT,DTOUT,DUOUT,I,X,Y,DIK,DLAYGO
13 N IBSPLIT,IBEFFDT,IBEXPDT,REF,IBLN
14 ;
15 K ^TMP($J,"IBCNSUR") ; subscribers
16 K ^TMP($J,"IBCNSUR1") ; e-mail bulletin
17 S REF=$NA(^TMP($J,"IBCNSUR1")),IBLN=0
18 ;
19 S IBQUIT=0
20 W !!!,"=====================",!,"MOVE SUBSCRIBERS FROM",!,"====================="
21 W !!,"Select the Insurance Company and Plan to move subscribers FROM.",!
22 ;
23 ; - select company/plan for subscribers to be moved
24 S IBQUIT=0
25 D SEL^IBCNSUR(0)
26 I IBQUIT S IBSTOP=1 G PROCQ
27 ;
28 ; - collect the plan subscribers
29 S IBC1=IBCNS,IBP1=IBPLAN
30 W !!,"Collecting Subscribers ..."
31 S IBSUB=$$SUBS^IBCNSJ(IBC1,IBP1,0,"^TMP($J,""IBCNSUR"")")
32 I 'IBSUB W !!,?5,*7,"* This plan has no subscribers!" S IBQUIT=1 G PROCQ
33 W !!,"This plan has ",+IBSUB," subscribers. All subscribers will be moved."
34 ;
35 ; - select company/plan to move subscribers
36 W !!!,"MOVE SUBSCRIBERS TO"
37 W !!,"Select the Insurance Company and Plan to move subscribers TO.",!
38 D SEL^IBCNSUR(1)
39 I IBQUIT G PROCQ
40 I $P($G(^DIC(36,IBCNS,0)),"^",5) W !!,*7,"You must move the subscribers to an active insurance company!" G PROCQ
41 S IBC2=IBCNS,IBP2=IBPLAN
42 ;
43 ; - make sure not moving the subscribers to their current plan
44 I (IBC1=IBC2)&(IBP1=IBP2) W !!,*7,"You must move the subscribers to a different plan!" G PROCQ
45 ;
46 ; - set name and plan number
47 S IBC1N=$P($G(^DIC(36,+IBC1,0)),U,1)
48 S IBP1N=$P($G(^IBA(355.3,+IBP1,0)),U,3,4),IBP1X=$P(IBP1N,U,2)
49 S IBP1X=$S(IBP1X]"":IBP1X,1:"<Not Specified>")
50 S IBP1N=$S($P(IBP1N,U,1)="":"<Not Specified>",1:$P(IBP1N,U,1))
51 S IBC2N=$P($G(^DIC(36,+IBC2,0)),U,1)
52 S IBP2N=$P($G(^IBA(355.3,+IBP2,0)),U,3,4),IBP2X=$P(IBP2N,U,2)
53 S IBP2X=$S(IBP2X]"":IBP2X,1:"<Not Specified>")
54 S IBP2N=$S($P(IBP2N,U,1)="":"<Not Specified>",1:$P(IBP2N,U,1))
55 ;
56 ; - ask if they want to delete the old insurance
57 S DIR(0)="Y",DIR("A")="Do you want to EXPIRE the old plan by entering the new plan Effective date"
58 S DIR("B")="NO"
59 S DIR("?")="If you wish to apply Effective Date, enter 'Yes' - otherwise, enter 'No'"
60 W ! D ^DIR K DIR
61 I $D(DIRUT) G PROCQ
62 S IBSPLIT=''Y
63 ; if yes then
64 ; - ask the effective date of the new insurance
65 I IBSPLIT D I IBQ G PROCQ
66 . S IBQ=0
67 . S %DT="AEX",%DT("A")="Effective Date of the new Plan: "
68 . W ! D ^%DT K %DT I Y'>0 S IBQ=1 Q
69 . S IBEFFDT=$P(+Y,".")
70 . S IBEXPDT=$$FMADD^XLFDT(IBEFFDT,-1)
71 ;
72 ; - ask are they sure
73 W !!!,"You selected to move ",IBSUB," subscribers and "
74 W $S(IBSPLIT:"EXPIRE",1:"REPLACE")," the old plan in the patient",!,"profile.",!
75 W !?5,"FROM Insurance Company ",IBC1N
76 W !?10,"Plan Name ",IBP1N," Number ",IBP1X
77 W !?5,"TO Insurance Company ",IBC2N
78 W !?10,"Plan Name ",IBP2N," Number ",IBP2X
79 I IBSPLIT D
80 . W !?5,"BY switching to the new Insurance/Plan"
81 . W !?10,"with Effective Date ",$$DAT2^IBOUTL(IBEFFDT)
82 W !
83 W !,"Please Note that the old insurance group plan will be "
84 W $S(IBSPLIT:"EXPIRED",1:"REPLACED")," in the patient",!,"profile!",!
85 ;
86 S DIR(0)="Y",DIR("A")="Okay to continue"
87 S DIR("?")="If you wish to move these subscribers, enter 'Yes' - otherwise, enter 'No.'"
88 W ! D ^DIR K DIR
89 I 'Y W !!,?10,"<Okay, nothing moved>" G PROCQ
90 ;
91 ; - should annual benefits be moved?
92 S (IBAB,IBQ)=0
93 I $D(^IBA(355.4,"APY",IBP1)),'$D(^IBA(355.4,"APY",IBP2)) D G:IBQ PROCQ
94 .S DIR(0)="Y",DIR("A")="Okay to add "_IBC1N_"'s plan Annual Benefits to "_IBC2N_"'s plan"
95 .S DIR("?")="If you wish to move these Annual Benefits, enter 'Yes' - otherwise, enter 'No.'"
96 .W ! D ^DIR K DIR I $D(DIRUT)!$D(DIROUT)!$D(DUOUT)!$D(DTOUT) S IBQ=1
97 .S:Y IBAB=1 K DIRUT,DUOUT,DTOUT,DIROUT
98 ;
99 ; - copy annual benefits over to the new plan
100 I IBAB D
101 .S IBI=0 F S IBI=$O(^IBA(355.4,"C",IBP1,IBI)) Q:'IBI D
102 ..S IBIAB=$G(^IBA(355.4,IBI,0)) Q:'IBIAB
103 ..S X=+IBIAB,DIC(0)="L",DLAYGO=355.4,DIC="^IBA(355.4,"
104 ..K DD,DO D FILE^DICN Q:+Y<0 S IBCAB=+Y
105 ..S $P(^IBA(355.4,IBCAB,0),"^",2)=IBP2
106 ..S $P(^IBA(355.4,IBCAB,0),"^",5,6)=$P(IBIAB,"^",5,6)
107 ..F I=1:1:5 I $G(^IBA(355.4,IBI,I))]"" S ^IBA(355.4,IBCAB,I)=^(I)
108 ..S DA=IBCAB,DIK="^IBA(355.4," D IX1^DIK,EDUP^IBCNSA2
109 ;
110 ; - should plan comments be copied over to the new plan?
111 S (IBAB,IBQ)=0
112 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
113 .S DIR(0)="Y"
114 .S DIR("A")="Okay to add "_IBC1N_"'s Comments to "_IBC2N_"'s plan"
115 .S DIR("?")="If you wish to move these Comments, enter 'Yes'"
116 .S DIR("?")=DIR("?")_" - otherwise, ente"
117 .W ! D ^DIR K DIR I $D(DIRUT)!$D(DIROUT)!$D(DUOUT)!$D(DTOUT) S IBQ=1
118 .S:Y IBAB=1 K DIRUT,DUOUT,DTOUT,DIROUT
119 ;
120 ; - copy plan comments over to the new plan
121 I IBAB D
122 .S DIC="^IBA(355.3,"_IBP2_",11,",DIC(0)="L",DIC("P")=355.311
123 .S IBI=0 F S IBI=$O(^IBA(355.3,IBP1,11,IBI)) Q:'IBI D
124 ..I $G(^IBA(355.3,IBP1,11,IBI,0))]"" S X=^(0) D FILE^DICN
125 ;
126 ; The MailMan bulletin header
127 D BHEAD^IBCNSUR3
128 ;
129 ; - move the subscribers to the new plan
130 W !!,"Moving subscribers "
131 S DFN=0 F S DFN=$O(^TMP($J,"IBCNSUR",DFN)) Q:'DFN D
132 .S IBCDFN=0 F S IBCDFN=$O(^TMP($J,"IBCNSUR",DFN,IBCDFN)) Q:'IBCDFN D
133 ..Q:$P($G(^DPT(DFN,.312,IBCDFN,0)),"^",18)'=IBP1
134 ..;
135 ..D ADS^IBCNSUR3(DFN,IBCDFN)
136 ..I 'IBSPLIT D MODIFINS(IBC2,IBP2,DFN,IBCDFN) ;regular mode
137 ..I IBSPLIT D SPLITINS(IBC2,IBP2,DFN,IBCDFN,IBEFFDT,IBEXPDT)
138 ..; - merge previous benefits used
139 ..S IBDAT="" F S IBDAT=$O(^IBA(355.5,"APPY",DFN,IBP1,IBDAT)) Q:IBDAT="" D
140 ...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
141 ....I '$D(^IBA(355.4,"APY",IBP2,IBDAT)) D DBU^IBCNSJ(IBBU) Q
142 ....D MERG^IBCNSJ13(IBP2,IBBU)
143 ..;
144 ..W "."
145 ;
146 W !!,"Done. All subscribers were moved as requested!",!
147 D DONE^IBCNSUR3
148 W !,"The Bulletin was sent to you and members of 'IB NEW INSURANCE' Mail Group.",!
149 R !!,?10,"Press any key to continue. ",IBX:DTIME
150 ;
151 ; - finish processing in IBCNSUR (keep RSIZE down)
152 D PROC^IBCNSUR
153 ;
154 ;
155PROCQ ;I 'IBSTOP S IBQUIT=0 D ASK^IBCOMC2 I IBQUIT=1 S IBSTOP=1
156 K ^TMP($J,"IBCNSUR")
157 K ^TMP($J,"IBCNSUR1")
158 Q
159 ;
160 ; modify the ins plan
161MODIFINS(IBC2,IBP2,DFN,IBCDFN) ;
162 N IBXXX,DIE,DA,DR,IBX
163 ; - change the policy company
164 S IBXXX='$G(^DPT(DFN,.312,IBCDFN,1))
165 S DIE="^DPT(DFN,.312,",DA(1)=DFN,DA=IBCDFN,DR=".01///`"_IBC2 D ^DIE K DIE,DA,DR
166 I IBXXX S $P(^DPT(DFN,.312,IBCDFN,1),"^",1,2)="^"
167 ;
168 ; - repoint Insurance Reviews to the new company
169 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
170 ;
171 ; - change the policy plan
172 D SWPL^IBCNSJ13(IBP2,DFN,IBCDFN)
173 Q
174 ;
175 ;
176 ;
177 ; change the ins plan effective IBEFFDT
178SPLITINS(IBC2,IBP2,DFN,IBCDFN,IBEFFDT,IBEXPDT) ;
179 N IBX,IBZ,IBZ1,IBRT,IBI,IBIEN,IBCDFN2,IBERR,DIK,DA,DIE,DR,DGRUGA08
180 S IBZ=$G(^DPT(DFN,.312,IBCDFN,0))
181 S IBZ1=$G(^DPT(DFN,.312,IBCDFN,1))
182 ; - ignore if the old plan expired
183 I $P(IBZ,U,4),$P(IBZ,U,4)<IBEFFDT Q
184 ; - if the ins is effective later - no need to split
185 I $P(IBZ,U,8),$P(IBZ,U,8)'<IBEFFDT D MODIFINS(IBC2,IBP2,DFN,IBCDFN) Q
186 ;
187 S DGRUGA08=1 ; Disable HL7 triggered by 2.312/3 and 2.312/8
188 ; - create the new insurance record for the DFN (clone)
189 S IBI="+1,"_DFN_","
190 ; - add a record
191 S IBRT(2.312,IBI,.01)=IBC2
192 D UPDATE^DIE("","IBRT","IBIEN","IBERR")
193 I $D(IBERR) Q ; error
194 I '$G(IBIEN(1)) Q ; error
195 S IBCDFN2=+IBIEN(1)
196 ; - clone the insurance data
197 M ^DPT(DFN,.312,IBCDFN2)=^DPT(DFN,.312,IBCDFN)
198 S $P(^DPT(DFN,.312,IBCDFN2,0),U,1)=IBC2
199 S $P(^DPT(DFN,.312,IBCDFN2,0),U,8)=IBEFFDT
200 ; - now reindex
201 S DA(1)=DFN,DA=IBCDFN2,DIK="^DPT("_DFN_",.312,"
202 D IX1^DIK
203 ; - change the policy plan
204 D SWPL^IBCNSJ13(IBP2,DFN,IBCDFN2)
205 ; - set the expiration date
206 S $P(^DPT(DFN,.312,IBCDFN,0),U,4)=IBEXPDT
207 S DA(1)=DFN,DA=IBCDFN,DIK="^DPT("_DFN_",.312,"
208 D IX1^DIK
209 Q
Note: See TracBrowser for help on using the repository browser.