source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSUX1.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.2 KB
Line 
1IBCNSUX1 ;ALB/CMS - SPLIT COMBINATION PLANS CONT. ; 04-NOV-98
2 ;;2.0;INTEGRATED BILLING;**103,133**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6BEG ; -- Start to process policy separation from IBCNSUX
7 ; Input: IBINS=Selected Medicare Company
8 ; IBPLAN=Selected Combination Plan
9 ; IBWNR=MED WNR INS IEN^"MEDICARE (WNR)"
10 ; ^PART A IEN^"PART A"
11 ; ^PART B IEN^"PART A"
12 ;
13 N DFN,DO,DD,DA,DR,DIC,DIE,DIK,DIR,DIRUT,X,Y
14 N IBCDFN,IBERR,IB0,IBST,IBSUB1,IBPLANAM
15 K ^TMP($J,"IBCNSUX"),^TMP($J,"IBCNSUX1")
16 S IBST=$$NOW^XLFDT,IBPLANAM=$P($G(^IBA(355.3,IBPLAN,0)),U,3)
17 S IBSUB1=$$SUBS^IBCNSJ(IBINS,IBPLAN,0,"^TMP($J,""IBCNSUX1"")")
18 S DFN=0 F S DFN=$O(^TMP($J,"IBCNSUX1",DFN)) Q:'DFN D
19 .S IBCDFN=0 F S IBCDFN=$O(^TMP($J,"IBCNSUX1",DFN,IBCDFN)) Q:'IBCDFN D
20 ..S IB0=$G(^DPT(DFN,.312,IBCDFN,0))
21 ..I $P(IB0,U,18)'=+IBPLAN Q
22 ..;
23 ..; -- check for duplicate
24 ..D DUP
25 ..;
26 ..; -- if the policy to be split has no COB, and both an A and B
27 ..; -- policy need to be created, set it to Primary
28 ..I '$P(IB0,"^",20),'$D(^TMP($J,"IBCNSUX","ERR",DFN,2)),'$D(^(1)) D
29 ...N DIE,DA,DR,X,Y
30 ...S DIE="^DPT("_DFN_",.312,",DA=+IBCDFN,DA(1)=DFN,DR=".2////1" D ^DIE
31 ..;
32 ..; -- create Medicare (WNR) policies if none exists
33 ..I '$D(^TMP($J,"IBCNSUX","ERR",DFN,2)) D ADDB
34 ..I '$D(^TMP($J,"IBCNSUX","ERR",DFN,1)) D SETA
35 ;
36 ; -- delete combination plan if no subscribers left.
37 I '$$SUBS^IBCNSJ(IBINS,IBPLAN) D DEL^IBCNSJ(IBPLAN)
38 ;
39 D WRT
40 ;
41BEGQ K ^TMP($J,"IBCNSUX"),^TMP($J,"IBCNSUX1")
42 Q
43 ;
44 ;
45ADDB ; -- Create a New MEDICARE PART B patient policy
46 N DA,DIC,DIE,DR,IBBDFN,IBC,IBX,X,Y,IBCDA,IBNDA,IBN
47 K DD,D0
48 ;
49 S DIC("DR")=".01////"_+IBWNR_";1.09////1;1.05///NOW;1.06////"_DUZ_";.18////"_$P(IBWNR,U,5)
50 ;
51 ; -- If the policy to be split has no COB, and a valid Part A policy
52 ; -- already exists, set the COB to Primary
53 I '$P(IB0,"^",20),$D(^TMP($J,"IBCNSUX","ERR",DFN,1)) S DIC("DR")=DIC("DR")_";.2////1"
54 ;
55 S DA(1)=DFN,DIC="^DPT("_DFN_",.312,",DIC(0)="L",X=+IBWNR,DLAYGO=2.312
56 D FILE^DICN S IBBDFN=+Y K DIC
57 I IBBDFN<1 S ^TMP($J,"IBCNSUX","ERR",DFN,3)="Could not create a Part B policy." G ADDBQ
58 ;
59 ; -- Get settings of combination policy
60 S IBCDA=IBCDFN_","_DFN_","
61 D GETS^DIQ(2.312,IBCDA,"*","IN","IBC")
62 I $D(IBC("IBERR")) S ^TMP($J,"IBCNSUX","ERR",DFN,3)="Could not set Part B policy data." G ADDBQ
63 ;
64 ; -- Set Medicare Part B policy data - copy combination policy data to new new Part B policy
65 S IBNDA=+IBBDFN_","_DFN_","
66 S IBX=0 F S IBX=$O(IBC(2.312,IBCDA,IBX)) Q:IBX="" D
67 . ;
68 . ; -- Don't set system edited or triggered fields
69 . I ",.01,1.01,1.02,1.1,1.05,1.06,.18,"[(","_IBX_",") Q
70 . ;
71 . S IBN(2.312,IBNDA,IBX)=IBC(2.312,IBCDA,IBX,"I")
72 I $O(IBN(0)) D FILE^DIE("","IBN")
73ADDBQ Q
74 ;
75SETA ; -- Change policy to point to Part A
76 N DIE,DA,DR,X,Y
77 S DIE="^DPT("_DFN_",.312,",DA=+IBCDFN,DA(1)=DFN
78 S DR=".01////"_+IBWNR_";.18////"_$P(IBWNR,U,3)
79 ;
80 ; - if this policy still has no COB, set it to primary
81 I '$P($G(^DPT(DFN,.312,IBCDFN,0)),"^",20) S DR=DR_";.2////1"
82 D ^DIE
83 Q
84 ;
85DUP ; -- Check for duplicate
86 N IBX,IB0,X,Y
87 S IBX=0 F S IBX=$O(^DPT(DFN,.312,"B",+IBWNR,IBX)) Q:'IBX D
88 .S IB0=$G(^DPT(DFN,.312,IBX,0))
89 .I $P(IB0,U,18)=$P(IBWNR,U,3) S ^TMP($J,"IBCNSUX","ERR",DFN,1)="Medicare (WNR) Part A policy already exists." Q
90 .I $P(IB0,U,18)=$P(IBWNR,U,5) S ^TMP($J,"IBCNSUX","ERR",DFN,2)="Medicare (WNR) Part B policy already exists." Q
91 Q
92 ;
93WRT ; -- write report
94 N IBX,VA,VADM,VAERR,X,Y
95 W @IOF,!,"Separate Medicare Combination policies Part A and Part B"
96 W !!,"Process started ",$$FMTE^XLFDT(IBST)," ended ",$$FMTE^XLFDT($$NOW^XLFDT)
97 W !,?10,"Run by: ",$P($G(^VA(200,+$G(DUZ),0)),U,1)
98 W !!,?5,"Combination Company: ",$P($G(^DIC(36,IBINS,0)),U,1)
99 W !?3,"Combination Plan Name: ",IBPLANAM W:'$D(^IBA(355.3,IBPLAN,0)) " (This plan was deleted)"
100 W ! F IBX=1:1:79 W "="
101 ;
102 I '$O(^TMP($J,"IBCNSUX","ERR",0)) W !!,"SUCCESSFULLY COMPLETED, COMBINATION PLAN DELETED." G WRTQ
103 ;
104 W !,"Exception Report:"
105 S DFN=0 F S DFN=$O(^TMP($J,"IBCNSUX","ERR",DFN)) Q:'DFN D
106 .K VADM D DEM^VADPT
107 .W !!,VADM(1),?32,"SSN: ",$P(VADM(2),U,2),?50,"DOB: ",$P(VADM(3),U,2)
108 .S IBX=0 F S IBX=$O(^TMP($J,"IBCNSUX","ERR",DFN,IBX)) Q:'IBX D
109 ..W !,?5,^TMP($J,"IBCNSUX","ERR",DFN,IBX)
110WRTQ Q
111 ;IBCNSUX1
Note: See TracBrowser for help on using the repository browser.