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 ; 28-MAY-93
  1. 	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
  1. 	;;Per VHA Directive 10-93-142, 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
  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) I IBCPOL>0 D OK G:IBQUIT ADQ S:'IBOK IBCPOL=-1
  1. 	I IBCPOL<1 S IBCPOL=$$NEW(IBCNSP)
  1. 	I IBCPOL<1 G ADQ
  1. 	;
  1. 	; -- file new patient policy
  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. 	;
  1. 	; -- Edit patient policy data
  1. 	D PAT^IBCNSEH,PATPOL(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(IBNEW),$G(IBCDFN)>0 D AFTER^IBCNSEVT,^IBCNSEVT
  1. 	I $G(IBCPOL)>0 D BLD^IBCNSM
  1. 	S VALMBCK="R"
  1. 	Q
  1. 	;
  1. PATPOL(IBCDFN)	; -- edit patient specific policy info
  1. 	I '$G(IBCDFN) G PATPOLQ
  1. 	D SAVEPT^IBCNSP3(DFN,IBCDFN)
  1. 	;
  1. 	; -- give warning if expired or inactive co.
  1. 	I $P(^DPT(DFN,.312,IBCDFN,0),"^",4),$P(^(0),"^",4)'>DT W !,"WARNING:  This appears to be an expired policy!",!
  1. 	I $P(^DIC(36,+$P(^DPT(DFN,.312,IBCDFN,0),"^"),0),"^",5) W !,*7,"WARNING:  This insurance company is INACTIVE!",!
  1. 	;
  1. 	N IBAD,IBDIF,DA,DR,DIC,DIE
  1. 	S DIE="^DPT("_DFN_",.312,",DA(1)=DFN,DA=IBCDFN
  1. 	S DR="S IBAD="""";8;@333;3;D FUTURE^IBCNSM31;6;S IBAD=X;I IBAD'=""v"" S Y=""@10"";17///^S X=""`""_DFN;16///^S X=""01"";S Y=""@20"";@10;17;16//^S X=$S(IBAD=""s"":""02"",1:"""");@20;1;I $G(IBREG) S Y=""@99"";.2;@99"
  1. 	I $G(IBREG),$D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ)) S DR=".01//;"_DR
  1. 	L +^DPT(DFN,.312,+IBCDFN):5 I '$T D LOCKED^IBTRCD1 G PATPOLQ
  1. 	D ^DIE I $D(Y)!($D(DTOUT)) S IBQUIT=1
  1. 	I '$D(DA) S IBQUIT=1 G PATPOLQ
  1. 	K IBFUTUR
  1. 	D COMPPT^IBCNSP3(DFN,IBCDFN)
  1. 	I IBDIF D UPDATPT^IBCNSP3(DFN,IBCDFN)
  1. 	L -^DPT(DFN,.312,+IBCDFN)
  1. 	;
  1. 	D FUTURE^IBCNSM31 K Y,IBFUTUR
  1. PATPOLQ	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. 	.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;.09;.05;.06;.07;.08//YES;"
  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;.09;.05;.06;.07;.08//YES;"
  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. NEW(IBCNSC)	; -- ask if add new policy, if yes file (addh^ibcnsu)
  1. 	N IBCPOL,DIR,Y,X,IBGRP
  1. 	S IBCPOL=-1
  1. 	S DIR(0)="Y",DIR("B")="NO",DIR("A")="ARE YOU ADDING "_$P(^DIC(36,+IBCNSC,0),"^")_" AS A NEW GROUP INSURANCE PLAN"
  1. 	S DIR("?")="If this is a group plan that has not been previously entered an you wish to add it answer 'YES'.  If you do not wish to add a new group plan enter 'NO'."
  1. 	D ^DIR K DIR
  1. 	I Y<1!($D(DIRUT)) G NEWQ
  1. 	;
  1. 	; -- is group policy
  1. 	S DIR("?")="Answer 'YES' if this is a group insurance plan, that is, more than one patient may have a policy covered by this plan.  Answer 'NO' if this is an individual insurance plan."
  1. 	S DIR(0)="355.3,.02",DIR("A")="IS THIS A GROUP PLAN" D ^DIR K DIR S IBGRP=Y
  1. 	I $D(DIRUT) G NEWQ
  1. 	;
  1. 	; -- file new policy in policy file
  1. 	S IBCPOL=$$ADDH^IBCNSU(IBCNSC,IBGRP)
  1. NEWQ	Q IBCPOL
  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