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

IBCNSM3.m

Go to the documentation of this file.
  1. IBCNSM3 ;ALB/AAS - INSURANCE MANAGEMENT - OUTPUTS ; 4/7/03 9:56am
  1. ;;2.0;INTEGRATED BILLING;**6,28,85,211,251,399,506,516,631**;21-MAR-94;Build 23
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. % G EN^IBCNSM
  1. ;
  1. N X,Y,DO,DD,DA,DR,DIC,DIE,DIK,DIR,DIRUT,IBCNSP,IBCPOL,IBQUIT,IBOK,IBCDFN,IBAD,IBGRP,IBADPOL,IBCOVP,ANS,IBGNA,IBGNU
  1. S IBCNSEH=$P($G(^IBE(350.9,1,4)),"^",1),IBQUIT=0,IBADPOL=1
  1. D FULL^VALM1
  1. S IBCOVP=$P($G(^DPT(DFN,.31)),"^",11)
  1. I '$D(^DPT(DFN,.312,0)) S ^DPT(DFN,.312,0)="^2.312PAI^^"
  1. ;
  1. D INS^IBCNSEH
  1. ; -- Select insurance company
  1. ; If one already exists for same co. ask are you sure you are
  1. ; adding a new one
  1. S DIR(0)="350.9,4.06"
  1. S DIR("A")="Select INSURANCE COMPANY",DIR("??")="^D ADH^IBCNSM3"
  1. S DIR("?")="Select the Insurance Company for the policy you are entering"
  1. D ^DIR K DIR S IBCNSP=+Y I Y<1 G ADQ
  1. I $P($G(^DIC(36,+IBCNSP,0)),"^",2)="N" W !,"This company does not reimburse. "
  1. I $P($G(^DIC(36,+IBCNSP,0)),"^",5) W !,*7,"Warning: Inactive Company" H 3 K IBCNSP G ADQ
  1. I $$DUPCO^IBCNSOK1(DFN,IBCNSP,"",1) H 3
  1. ;
  1. ; -- see if can use existing policy
  1. D SEL^IBCNSEH
  1. S IBCPOL=$$LK^IBCNSM31(IBCNSP)
  1. ;
  1. ; IB*2.0*506 added IBKEY parameter (4th) to the NEW^IBCNSJ3 call (check user's security keys)
  1. I IBCPOL<1 D NEW^IBCNSJ3(IBCNSP,.IBCPOL,,1)
  1. I IBCPOL<1 G ADQ
  1. ;
  1. ; -- file new patient policy
  1. ;IB*2.0*516/baa - Use HIPAA Compliant fields
  1. ;S DIC("DR")=".18////"_IBCPOL_";1.09////7.02;1.05///NOW;1.06////"_DUZ
  1. ;/IB*2.0*631/vd - Replaced the original code which was accidentally stepped on by
  1. ; the IB*2.0*516 patch and caused an invalid value to appear in the SOI field when
  1. ; entering a new patient policy. (US7912)
  1. S DIC("DR")=".18////"_IBCPOL_";1.09////1;1.05///NOW;1.06////"_DUZ
  1. K DD,DO S DA(1)=DFN,DIC="^DPT("_DFN_",.312,",DIC(0)="L",X=IBCNSP D FILE^DICN K DIC S IBCDFN=+Y,IBNEW=1 I +Y<1 G ADQ
  1. D BEFORE^IBCNSEVT
  1. ;
  1. ; -- Edit patient policy data
  1. D PAT^IBCNSEH,PATPOL^IBCNSM32(IBCDFN)
  1. ;
  1. ; -- edit PLAN data if hold key
  1. I '$D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ)) G ADQ
  1. I '$G(IBQUIT) D POL^IBCNSEH,EDPOL(IBCDFN)
  1. I '$G(IBNEW) D AI^IBCNSP1
  1. G ADQ
  1. ;
  1. ADQ D COVERED^IBCNSM31(DFN,IBCOVP)
  1. I $G(IBCDFN)>0 D AFTER^IBCNSEVT,^IBCNSEVT
  1. I $G(IBCPOL)>0 D BLD^IBCNSM
  1. S VALMBCK="R"
  1. Q
  1. ;
  1. EDPOL(IBCDFN) ; -- Edit GROUP PLAN specific info
  1. I '$G(IBCDFN) G EDPOLQ
  1. N DA,DR,DIE,DIC,IBAD,IBCPOL,IBDIF
  1. S IBCPOL=$P($G(^DPT(DFN,.312,IBCDFN,0)),"^",18)
  1. L +^IBA(355.3,+IBCPOL):5 I '$T D LOCKED^IBTRCD1 G EDPOLQ
  1. I IBCPOL D
  1. .D SAVE^IBCNSP3(IBCPOL)
  1. .S DIE="^IBA(355.3,",DA=IBCPOL
  1. .;IB*2.0*516/baa - Use HIPAA Compliant fields
  1. .;S DR="S IBAD=$P($G(^IBA(355.3,DA,0)),U,2),Y=$S(IBAD=0:""@55"",IBAD="""":""@1"",1:""@25"");@1;.02;@25;.03;.04;@55;6.02;6.03;.09;"
  1. .S DR="S IBAD=$P($G(^IBA(355.3,DA,0)),U,2),Y=$S(IBAD=0:""@55"",IBAD="""":""@1"",1:""@25"");@1;.02;@25;2.01;2.02;@55;6.02;6.03;.09;"
  1. .S DR=DR_".15;S Y=$S($$CATOK^IBCEMRA($P(^(0),U,14)):""@60"",1:""@65"");@60;.14;@65;.16;I '$$FTFV^IBCNSU31(X) S Y=""@66"";.17;@66;.13;.05;.12;.06;.07;.08//YES;"
  1. .;
  1. .I $D(IBREG),'$G(IBNEWP) S DR="S IBAD=$P($G(^IBA(355.3,DA,0)),U,2),Y=$S(IBAD=0:""@55"",IBAD="""":""@1"",1:""@25"");@1;.02;@25;D 3^IBCNSM31;D 4^IBCNSM31;@55;6.02;6.03;.09;"
  1. .I $D(IBREG),'$G(IBNEWP) S DR=DR_".15;S Y=$S($$CATOK^IBCEMRA($P(^(0),U,14)):""@60"",1:""@65"");@60;.14;@65;.16;I '$$FTFV^IBCNSU31(X) S Y=""@66"";.17;@66;.13;.05;.12;.06;.07;.08//YES;"
  1. .;
  1. .D ^DIE
  1. .D COMP^IBCNSP3(IBCPOL)
  1. .I IBDIF D UPDATE^IBCNSP3(IBCPOL),UPDATPT^IBCNSP3(DFN,IBCDFN) I $$DUPPOL^IBCNSOK1(IBCPOL,1)
  1. L -^IBA(355.3,+IBCPOL)
  1. EDPOLQ Q
  1. ;
  1. OK ; -- ask okay
  1. S IBQUIT=0,DIR(0)="Y",DIR("A")=" ...OK",DIR("B")="YES" D ^DIR K DIR
  1. I $D(DIRUT) S IBQUIT=1
  1. S IBOK=Y
  1. Q
  1. ;
  1. ADH ; -- show existing policies for help
  1. N DIR,DA,%A
  1. W !!,"The patient currently has the following Insurance Policies"
  1. D DISP^IBCNS
  1. Q