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

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

initial load of WorldVistAEHR

File size: 4.3 KB
Line 
1IBCNSJ13 ;ALB/CPM - INACTIVATE AN INSURANCE PLAN (CON'T) ; 18-JAN-95
2 ;;Version 2.0 ; INTEGRATED BILLING ;**28,62,52**; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5REP(IBCNS,IBNEWP,IBOLDP,IBMER) ; Repoint patient policies from old to new plan
6 ; Input: IBCNS -- Pointer to the company in file #36 which
7 ; offers the plans
8 ; IBNEWP -- Pointer to the new plan in file #355.3
9 ; IBOLDP -- Pointer to the old plan in file #355.3
10 ; IBMER -- [optional]: set to 1 if benefits used should
11 ; be merged instead of deleted
12 ;
13 I '$G(IBCNS)!'$G(IBNEWP)!'$G(IBOLDP) G REPQ
14 N DA,DFN,DIE,DR,IBARR,IBCDFN,IBCBUM,IBCBUD,IBSUB1
15 S (IBCBUM,IBCBUD)=0 W !,"Repointing all policies to the new plan...",!
16 K ^TMP($J,"IBSUBS")
17 S IBSUB1=$$SUBS^IBCNSJ(IBCNS,IBOLDP,0,"^TMP($J,""IBSUBS"")")
18 S DFN=0 F S DFN=$O(^TMP($J,"IBSUBS",DFN)) Q:'DFN D
19 .S IBCDFN=0 F S IBCDFN=$O(^TMP($J,"IBSUBS",DFN,IBCDFN)) Q:'IBCDFN D
20 ..Q:$P($G(^DPT(DFN,.312,IBCDFN,0)),"^",18)'=IBOLDP
21 ..D SWPL(IBNEWP,DFN,IBCDFN) W "."
22 ..;
23 ..; - merge or delete previous benefits used
24 ..S IBDAT="" F S IBDAT=$O(^IBA(355.5,"APPY",DFN,IBOLDP,IBDAT)) Q:IBDAT="" D
25 ...S IBCDFN1=0 F S IBCDFN1=$O(^IBA(355.5,"APPY",DFN,IBOLDP,IBDAT,IBCDFN1)) Q:'IBCDFN1 I IBCDFN1=IBCDFN S IBBU=$O(^(IBCDFN1,0)) D
26 ....I '$D(^IBA(355.4,"APY",IBNEWP,IBDAT))!'$G(IBMER) D DBU^IBCNSJ(IBBU) S IBCBUD=IBCBUD+1 Q
27 ....D MERG(IBNEWP,IBBU) S IBCBUM=IBCBUM+1
28 ;
29 W !,"All policies have been re-pointed to the new plan."
30 I 'IBCBUD,'IBCBUM W !,"There were no Benefits Used merged or deleted." G REPQ
31 W !,$S(IBCBUM:IBCBUM,1:"No")," Benefits Used record",$S(IBCBUM=1:" was",1:"s were")," merged."
32 W !,$S(IBCBUD:IBCBUD,1:"No")," Benefits Used record",$S(IBCBUD=1:" was",1:"s were")," deleted."
33REPQ K ^TMP($J,"IBSUBS")
34 Q
35 ;
36SWPL(IBCPOL,DFN,IBCDFN) ; Change plan in policy.
37 ; Input: IBCPOL -- Pointer to the new plan in file #355.3
38 ; DFN -- Pointer to the patient in file #2
39 ; IBCDFN -- Pointer to the policy in file #2.312
40 ;
41 I '$G(IBCPOL)!'$G(DFN)!'$G(IBCDFN) G SWPLQ
42 S DR=".18////"_IBCPOL_";1.05///NOW;1.06////"_DUZ
43 S DA=IBCDFN,DA(1)=DFN,DIE="^DPT("_DFN_",.312," D ^DIE K DIE,DA,DR
44 D COV^IBCNSJ(DFN) ; adjust 'Covered by Insurance' field
45 D POL^IBCNSU41(DFN) ; stuff sponsor data into Tricare policies
46SWPLQ Q
47 ;
48MERG(IBCPOL,IBBU,IBD) ; Merge previous benefits used into a new plan.
49 ; Input: IBCPOL -- Pointer to the new plan in file #355.3
50 ; IBBU -- Pointer to the benefit to merged in file #355.5
51 ; IBD -- [optional] : new date for the benefit used
52 ;
53 N DIC,DLAYGO,IBCBU,X,Y
54 I '$G(IBCPOL)!'$G(IBBU) G MERGQ
55 S X=IBCPOL,DIC(0)="L",DLAYGO=355.5,DIC="^IBA(355.5,"
56 K DD,DO D FILE^DICN G:+Y<0 MERGQ S IBCBU=+Y
57 S $P(^IBA(355.5,IBCBU,0),"^",2,30)=$P($G(^IBA(355.5,IBBU,0)),"^",2,30)
58 I $G(IBD) S $P(^IBA(355.5,IBCBU,0),"^",3)=IBD
59 I $D(^IBA(355.5,IBBU,1)) S ^IBA(355.5,IBCBU,1)=^(1)
60 S DA=IBCBU,DIK="^IBA(355.5," D IX1^DIK,EDUP^IBCNSD1
61 D DBU^IBCNSJ(IBBU)
62MERGQ Q
63 ;
64BU(IBQ) ; Be sure user really wants to repoint policies with benefits used.
65 ; Required variable input:
66 ; IBCPOL -- Pointer to the new plan in file #355.3
67 ;
68 ; Formal parameter output:
69 ; IBQ -- Set to 1 if user wishes to quit
70 ;
71 ; Optional variable output:
72 ; IBMERGE -- Set to 1 if user wishes to merge applicable benefits
73 ; IBREP -- Set to 0 if user does not want to repoint policies
74 ;
75 S IBQ=0 I '$D(^IBA(355.4,"APY",IBCPOL)) D G BUQ
76 .W !!,*7," ** Please Note **",!!?5,"The selected plan has no Annual Benefits with which to associate"
77 .W !?5,"the Benefits Used from the current plan!"
78 .W !!?5,"If you re-point all policies to this plan, the Benefits Used for"
79 .W !?5,"the current plan will be deleted!!"
80 ;
81 S DIR("A",1)="The selected plan has Annual Benefits on file. Should the repointing"
82 S DIR("A")="of the policies attempt to merge all transferable benefits"
83 S DIR(0)="Y",DIR("?")="^D HLMT^IBCNSJ11" D ^DIR K DIR
84 S IBMERGE=Y
85 I $D(DIRUT) K DIRUT,DTOUT,DUOUT,DIROUT D
86 .S DIR(0)="Y",DIR("A")=" Do you still wish to re-point these policies to a new plan",DIR("?")="^D HLRP^IBCNSJ11"
87 .W ! D ^DIR K DIR I $D(DIRUT) S IBQ=1 D DELP^IBCNSJ11 Q
88 .K DIRUT,DTOUT,DUOUT,DIROUT I 'Y S IBREP=0 D MAIL^IBCNSJ11,DELP^IBCNSJ11
89BUQ Q
Note: See TracBrowser for help on using the repository browser.