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

IBCNSUX1.m

Go to the documentation of this file. 
  1. IBCNSUX1 ;ALB/CMS - SPLIT COMBINATION PLANS CONT. ; 04-NOV-98
  1.  ;;2.0;INTEGRATED BILLING;**103,133,516**;21-MAR-94;Build 123
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  Q
  1.  ;
  1. BEG ; -- Start to process policy separation from IBCNSUX
  1.  ;    Input: IBINS=Selected Medicare Company
  1.  ;          IBPLAN=Selected Combination Plan
  1.  ;           IBWNR=MED WNR INS IEN^"MEDICARE (WNR)"
  1.  ;                  ^PART A IEN^"PART A"
  1.  ;                  ^PART B IEN^"PART A"
  1.  ;
  1.  N DFN,DO,DD,DA,DR,DIC,DIE,DIK,DIR,DIRUT,X,Y
  1.  N IBCDFN,IBERR,IB0,IBST,IBSUB1,IBPLANAM
  1.  K ^TMP($J,"IBCNSUX"),^TMP($J,"IBCNSUX1")
  1.  ;IB*2.0*516/TAZ - Retrieve HIPAA compliant Plan Name.
  1.  ;S IBST=$$NOW^XLFDT,IBPLANAM=$P($G(^IBA(355.3,IBPLAN,0)),U,3)
  1.  S IBST=$$NOW^XLFDT,IBPLANAM=$$GET1^DIQ(355.3,IBPLAN,2.01)  ; 516 - baa
  1.  S IBSUB1=$$SUBS^IBCNSJ(IBINS,IBPLAN,0,"^TMP($J,""IBCNSUX1"")")
  1.  S DFN=0 F  S DFN=$O(^TMP($J,"IBCNSUX1",DFN)) Q:'DFN  D
  1.  .S IBCDFN=0 F  S IBCDFN=$O(^TMP($J,"IBCNSUX1",DFN,IBCDFN)) Q:'IBCDFN  D
  1.  ..S IB0=$G(^DPT(DFN,.312,IBCDFN,0))
  1.  ..I $P(IB0,U,18)'=+IBPLAN Q
  1.  ..;
  1.  ..;  -- check for duplicate
  1.  ..D DUP
  1.  ..;
  1.  ..;  -- if the policy to be split has no COB, and both an A and B
  1.  ..;  -- policy need to be created, set it to Primary
  1.  ..I '$P(IB0,"^",20),'$D(^TMP($J,"IBCNSUX","ERR",DFN,2)),'$D(^(1)) D
  1.  ...N DIE,DA,DR,X,Y
  1.  ...S DIE="^DPT("_DFN_",.312,",DA=+IBCDFN,DA(1)=DFN,DR=".2////1" D ^DIE
  1.  ..;
  1.  ..;  -- create Medicare (WNR) policies if none exists
  1.  ..I '$D(^TMP($J,"IBCNSUX","ERR",DFN,2)) D ADDB
  1.  ..I '$D(^TMP($J,"IBCNSUX","ERR",DFN,1)) D SETA
  1.  ;
  1.  ; -- delete combination plan if no subscribers left.
  1.  I '$$SUBS^IBCNSJ(IBINS,IBPLAN) D DEL^IBCNSJ(IBPLAN)
  1.  ;
  1.  D WRT
  1.  ;
  1. BEGQ K ^TMP($J,"IBCNSUX"),^TMP($J,"IBCNSUX1")
  1.  Q
  1.  ;
  1.  ;
  1. ADDB ; -- Create a New MEDICARE PART B patient policy
  1.  N DA,DIC,DIE,DR,IBBDFN,IBC,IBX,X,Y,IBCDA,IBNDA,IBN
  1.  K DD,D0
  1.  ;
  1.  S DIC("DR")=".01////"_+IBWNR_";1.09////1;1.05///NOW;1.06////"_DUZ_";.18////"_$P(IBWNR,U,5)
  1.  ;
  1.  ; -- If the policy to be split has no COB, and a valid Part A policy
  1.  ; -- already exists, set the COB to Primary
  1.  I '$P(IB0,"^",20),$D(^TMP($J,"IBCNSUX","ERR",DFN,1)) S DIC("DR")=DIC("DR")_";.2////1"
  1.  ;
  1.  S DA(1)=DFN,DIC="^DPT("_DFN_",.312,",DIC(0)="L",X=+IBWNR,DLAYGO=2.312
  1.  D FILE^DICN S IBBDFN=+Y K DIC
  1.  I IBBDFN<1 S ^TMP($J,"IBCNSUX","ERR",DFN,3)="Could not create a Part B policy." G ADDBQ
  1.  ;
  1.  ; -- Get settings of combination policy
  1.  S IBCDA=IBCDFN_","_DFN_","
  1.  D GETS^DIQ(2.312,IBCDA,"*","IN","IBC")
  1.  I $D(IBC("IBERR")) S ^TMP($J,"IBCNSUX","ERR",DFN,3)="Could not set Part B policy data." G ADDBQ
  1.  ;
  1.  ; -- Set Medicare Part B policy data - copy combination policy data to new new Part B policy
  1.  S IBNDA=+IBBDFN_","_DFN_","
  1.  S IBX=0 F  S IBX=$O(IBC(2.312,IBCDA,IBX)) Q:IBX=""  D
  1.  . ;
  1.  . ; -- Don't set system edited or triggered fields
  1.  . I ",.01,1.01,1.02,1.1,1.05,1.06,.18,"[(","_IBX_",") Q
  1.  . ;
  1.  . S IBN(2.312,IBNDA,IBX)=IBC(2.312,IBCDA,IBX,"I")
  1.  I $O(IBN(0)) D FILE^DIE("","IBN")
  1. ADDBQ Q
  1.  ;
  1. SETA ; -- Change policy to point to Part A
  1.  N DIE,DA,DR,X,Y
  1.  S DIE="^DPT("_DFN_",.312,",DA=+IBCDFN,DA(1)=DFN
  1.  S DR=".01////"_+IBWNR_";.18////"_$P(IBWNR,U,3)
  1.  ;
  1.  ; - if this policy still has no COB, set it to primary
  1.  I '$P($G(^DPT(DFN,.312,IBCDFN,0)),"^",20) S DR=DR_";.2////1"
  1.  D ^DIE
  1.  Q
  1.  ;
  1. DUP ; -- Check for duplicate
  1.  N IBX,IB0,X,Y
  1.  S IBX=0 F  S IBX=$O(^DPT(DFN,.312,"B",+IBWNR,IBX)) Q:'IBX  D
  1.  .S IB0=$G(^DPT(DFN,.312,IBX,0))
  1.  .I $P(IB0,U,18)=$P(IBWNR,U,3) S ^TMP($J,"IBCNSUX","ERR",DFN,1)="Medicare (WNR) Part A policy already exists." Q
  1.  .I $P(IB0,U,18)=$P(IBWNR,U,5) S ^TMP($J,"IBCNSUX","ERR",DFN,2)="Medicare (WNR) Part B policy already exists." Q
  1.  Q
  1.  ;
  1. WRT ; -- write report
  1.  N IBX,VA,VADM,VAERR,X,Y
  1.  W @IOF,!,"Separate Medicare Combination policies Part A and Part B"
  1.  W !!,"Process started ",$$FMTE^XLFDT(IBST)," ended ",$$FMTE^XLFDT($$NOW^XLFDT)
  1.  W !,?10,"Run by: ",$P($G(^VA(200,+$G(DUZ),0)),U,1)
  1.  W !!,?5,"Combination Company: ",$P($G(^DIC(36,IBINS,0)),U,1)
  1.  W !?3,"Combination Plan Name: ",IBPLANAM W:'$D(^IBA(355.3,IBPLAN,0)) "  (This plan was deleted)"
  1.  W ! F IBX=1:1:79 W "="
  1.  ;
  1.  I '$O(^TMP($J,"IBCNSUX","ERR",0)) W !!,"SUCCESSFULLY COMPLETED,  COMBINATION PLAN DELETED." G WRTQ
  1.  ;
  1.  W !,"Exception Report:"
  1.  S DFN=0 F  S DFN=$O(^TMP($J,"IBCNSUX","ERR",DFN)) Q:'DFN  D
  1.  .K VADM D DEM^VADPT
  1.  .W !!,VADM(1),?32,"SSN: ",$P(VADM(2),U,2),?50,"DOB: ",$P(VADM(3),U,2)
  1.  .S IBX=0 F  S IBX=$O(^TMP($J,"IBCNSUX","ERR",DFN,IBX)) Q:'IBX  D
  1.  ..W !,?5,^TMP($J,"IBCNSUX","ERR",DFN,IBX)
  1. WRTQ Q
  1.  ;IBCNSUX1