IBCNSM3 ;ALB/AAS - INSURANCE MANAGEMENT - OUTPUTS ; 28-MAY-93
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
% G EN^IBCNSM
;
AD ; -- Add new insurance policy
N X,Y,DO,DD,DA,DR,DIC,DIE,DIK,DIR,DIRUT,IBCNSP,IBCPOL,IBQUIT,IBOK,IBCDFN,IBAD,IBGRP,IBADPOL,IBCOVP
S IBCNSEH=$P($G(^IBE(350.9,1,4)),"^",1),IBQUIT=0,IBADPOL=1
D FULL^VALM1
S IBCOVP=$P($G(^DPT(DFN,.31)),"^",11)
I '$D(^DPT(DFN,.312,0)) S ^DPT(DFN,.312,0)="^2.312PAI^^"
;
D INS^IBCNSEH
; -- Select insurance company
; If one already exists for same co. ask are you sure you are
; adding a new one
S DIR(0)="350.9,4.06"
S DIR("A")="Select INSURANCE COMPANY",DIR("??")="^D ADH^IBCNSM3"
S DIR("?")="Select the Insurance Company for the policy you are entering"
D ^DIR K DIR S IBCNSP=+Y I Y<1 G ADQ
I $P($G(^DIC(36,+IBCNSP,0)),"^",2)="N" W !,"This company does not reimburse. "
I $P($G(^DIC(36,+IBCNSP,0)),"^",5) W !,*7,"Warning: Inactive Company" H 3 K IBCNSP G ADQ
I $$DUPCO^IBCNSOK1(DFN,IBCNSP,"",1) H 3
;
; -- see if can use existing policy
D SEL^IBCNSEH
S IBCPOL=$$LK^IBCNSM31(IBCNSP) I IBCPOL>0 D OK G:IBQUIT ADQ S:'IBOK IBCPOL=-1
I IBCPOL<1 S IBCPOL=$$NEW(IBCNSP)
I IBCPOL<1 G ADQ
;
; -- file new patient policy
S DIC("DR")=".18////"_IBCPOL_";1.09////1;1.05///NOW;1.06////"_DUZ
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
;
; -- Edit patient policy data
D PAT^IBCNSEH,PATPOL(IBCDFN)
;
; -- edit PLAN data if hold key
I '$D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ)) G ADQ
I '$G(IBQUIT) D POL^IBCNSEH,EDPOL(IBCDFN)
I '$G(IBNEW) D AI^IBCNSP1
G ADQ
;
ADQ D COVERED^IBCNSM31(DFN,IBCOVP)
I $G(IBNEW),$G(IBCDFN)>0 D AFTER^IBCNSEVT,^IBCNSEVT
I $G(IBCPOL)>0 D BLD^IBCNSM
S VALMBCK="R"
Q
;
PATPOL(IBCDFN) ; -- edit patient specific policy info
I '$G(IBCDFN) G PATPOLQ
D SAVEPT^IBCNSP3(DFN,IBCDFN)
;
; -- give warning if expired or inactive co.
I $P(^DPT(DFN,.312,IBCDFN,0),"^",4),$P(^(0),"^",4)'>DT W !,"WARNING: This appears to be an expired policy!",!
I $P(^DIC(36,+$P(^DPT(DFN,.312,IBCDFN,0),"^"),0),"^",5) W !,*7,"WARNING: This insurance company is INACTIVE!",!
;
N IBAD,IBDIF,DA,DR,DIC,DIE
S DIE="^DPT("_DFN_",.312,",DA(1)=DFN,DA=IBCDFN
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"
I $G(IBREG),$D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ)) S DR=".01//;"_DR
L +^DPT(DFN,.312,+IBCDFN):5 I '$T D LOCKED^IBTRCD1 G PATPOLQ
D ^DIE I $D(Y)!($D(DTOUT)) S IBQUIT=1
I '$D(DA) S IBQUIT=1 G PATPOLQ
K IBFUTUR
D COMPPT^IBCNSP3(DFN,IBCDFN)
I IBDIF D UPDATPT^IBCNSP3(DFN,IBCDFN)
L -^DPT(DFN,.312,+IBCDFN)
;
D FUTURE^IBCNSM31 K Y,IBFUTUR
PATPOLQ Q
;
EDPOL(IBCDFN) ; -- Edit GROUP PLAN specific info
I '$G(IBCDFN) G EDPOLQ
N DA,DR,DIE,DIC,IBAD,IBCPOL,IBDIF
S IBCPOL=$P($G(^DPT(DFN,.312,IBCDFN,0)),"^",18)
L +^IBA(355.3,+IBCPOL):5 I '$T D LOCKED^IBTRCD1 G EDPOLQ
I IBCPOL D
.D SAVE^IBCNSP3(IBCPOL)
.S DIE="^IBA(355.3,",DA=IBCPOL
.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;"
.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;"
.D ^DIE
.D COMP^IBCNSP3(IBCPOL)
.I IBDIF D UPDATE^IBCNSP3(IBCPOL),UPDATPT^IBCNSP3(DFN,IBCDFN) I $$DUPPOL^IBCNSOK1(IBCPOL,1)
L -^IBA(355.3,+IBCPOL)
EDPOLQ Q
;
NEW(IBCNSC) ; -- ask if add new policy, if yes file (addh^ibcnsu)
N IBCPOL,DIR,Y,X,IBGRP
S IBCPOL=-1
S DIR(0)="Y",DIR("B")="NO",DIR("A")="ARE YOU ADDING "_$P(^DIC(36,+IBCNSC,0),"^")_" AS A NEW GROUP INSURANCE PLAN"
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'."
D ^DIR K DIR
I Y<1!($D(DIRUT)) G NEWQ
;
; -- is group policy
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."
S DIR(0)="355.3,.02",DIR("A")="IS THIS A GROUP PLAN" D ^DIR K DIR S IBGRP=Y
I $D(DIRUT) G NEWQ
;
; -- file new policy in policy file
S IBCPOL=$$ADDH^IBCNSU(IBCNSC,IBGRP)
NEWQ Q IBCPOL
;
OK ; -- ask okay
S IBQUIT=0,DIR(0)="Y",DIR("A")=" ...OK",DIR("B")="YES" D ^DIR K DIR
I $D(DIRUT) S IBQUIT=1
S IBOK=Y
Q
;
ADH ; -- show existing policies for help
N DIR,DA,%A
W !!,"The patient currently has the following Insurance Policies"
D DISP^IBCNS
Q
IBCNSM3 ;ALB/AAS - INSURANCE MANAGEMENT - OUTPUTS ; 28-MAY-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
% GOTO EN^IBCNSM
+1 ;
AD ; -- Add new insurance policy
+1 NEW X,Y,DO,DD,DA,DR,DIC,DIE,DIK,DIR,DIRUT,IBCNSP,IBCPOL,IBQUIT,IBOK,IBCDFN,IBAD,IBGRP,IBADPOL,IBCOVP
+2 SET IBCNSEH=$PIECE($GET(^IBE(350.9,1,4)),"^",1)
SET IBQUIT=0
SET IBADPOL=1
+3 DO FULL^VALM1
+4 SET IBCOVP=$PIECE($GET(^DPT(DFN,.31)),"^",11)
+5 IF '$DATA(^DPT(DFN,.312,0))
SET ^DPT(DFN,.312,0)="^2.312PAI^^"
+6 ;
+7 DO INS^IBCNSEH
+8 ; -- Select insurance company
+9 ; If one already exists for same co. ask are you sure you are
+10 ; adding a new one
+11 SET DIR(0)="350.9,4.06"
+12 SET DIR("A")="Select INSURANCE COMPANY"
SET DIR("??")="^D ADH^IBCNSM3"
+13 SET DIR("?")="Select the Insurance Company for the policy you are entering"
+14 DO ^DIR
KILL DIR
SET IBCNSP=+Y
IF Y<1
GOTO ADQ
+15 IF $PIECE($GET(^DIC(36,+IBCNSP,0)),"^",2)="N"
WRITE !,"This company does not reimburse. "
+16 IF $PIECE($GET(^DIC(36,+IBCNSP,0)),"^",5)
WRITE !,*7,"Warning: Inactive Company"
HANG 3
KILL IBCNSP
GOTO ADQ
+17 IF $$DUPCO^IBCNSOK1(DFN,IBCNSP,"",1)
HANG 3
+18 ;
+19 ; -- see if can use existing policy
+20 DO SEL^IBCNSEH
+21 SET IBCPOL=$$LK^IBCNSM31(IBCNSP)
IF IBCPOL>0
DO OK
IF IBQUIT
GOTO ADQ
IF 'IBOK
SET IBCPOL=-1
+22 IF IBCPOL<1
SET IBCPOL=$$NEW(IBCNSP)
+23 IF IBCPOL<1
GOTO ADQ
+24 ;
+25 ; -- file new patient policy
+26 SET DIC("DR")=".18////"_IBCPOL_";1.09////1;1.05///NOW;1.06////"_DUZ
+27 KILL DD,DO
SET DA(1)=DFN
SET DIC="^DPT("_DFN_",.312,"
SET DIC(0)="L"
SET X=IBCNSP
DO FILE^DICN
KILL DIC
SET IBCDFN=+Y
SET IBNEW=1
IF +Y<1
GOTO ADQ
+28 ;
+29 ; -- Edit patient policy data
+30 DO PAT^IBCNSEH
DO PATPOL(IBCDFN)
+31 ;
+32 ; -- edit PLAN data if hold key
+33 IF '$DATA(^XUSEC("IB INSURANCE SUPERVISOR",DUZ))
GOTO ADQ
+34 IF '$GET(IBQUIT)
DO POL^IBCNSEH
DO EDPOL(IBCDFN)
+35 IF '$GET(IBNEW)
DO AI^IBCNSP1
+36 GOTO ADQ
+37 ;
ADQ DO COVERED^IBCNSM31(DFN,IBCOVP)
+1 IF $GET(IBNEW)
IF $GET(IBCDFN)>0
DO AFTER^IBCNSEVT
DO ^IBCNSEVT
+2 IF $GET(IBCPOL)>0
DO BLD^IBCNSM
+3 SET VALMBCK="R"
+4 QUIT
+5 ;
PATPOL(IBCDFN) ; -- edit patient specific policy info
+1 IF '$GET(IBCDFN)
GOTO PATPOLQ
+2 DO SAVEPT^IBCNSP3(DFN,IBCDFN)
+3 ;
+4 ; -- give warning if expired or inactive co.
+5 IF $PIECE(^DPT(DFN,.312,IBCDFN,0),"^",4)
IF $PIECE(^(0),"^",4)'>DT
WRITE !,"WARNING: This appears to be an expired policy!",!
+6 IF $PIECE(^DIC(36,+$PIECE(^DPT(DFN,.312,IBCDFN,0),"^"),0),"^",5)
WRITE !,*7,"WARNING: This insurance company is INACTIVE!",!
+7 ;
+8 NEW IBAD,IBDIF,DA,DR,DIC,DIE
+9 SET DIE="^DPT("_DFN_",.312,"
SET DA(1)=DFN
SET DA=IBCDFN
+10 SET 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"
+11 IF $GET(IBREG)
IF $DATA(^XUSEC("IB INSURANCE SUPERVISOR",DUZ))
SET DR=".01//;"_DR
+12 LOCK +^DPT(DFN,.312,+IBCDFN):5
IF '$TEST
DO LOCKED^IBTRCD1
GOTO PATPOLQ
+13 DO ^DIE
IF $DATA(Y)!($DATA(DTOUT))
SET IBQUIT=1
+14 IF '$DATA(DA)
SET IBQUIT=1
GOTO PATPOLQ
+15 KILL IBFUTUR
+16 DO COMPPT^IBCNSP3(DFN,IBCDFN)
+17 IF IBDIF
DO UPDATPT^IBCNSP3(DFN,IBCDFN)
+18 LOCK -^DPT(DFN,.312,+IBCDFN)
+19 ;
+20 DO FUTURE^IBCNSM31
KILL Y,IBFUTUR
PATPOLQ QUIT
+1 ;
EDPOL(IBCDFN) ; -- Edit GROUP PLAN specific info
+1 IF '$GET(IBCDFN)
GOTO EDPOLQ
+2 NEW DA,DR,DIE,DIC,IBAD,IBCPOL,IBDIF
+3 SET IBCPOL=$PIECE($GET(^DPT(DFN,.312,IBCDFN,0)),"^",18)
+4 LOCK +^IBA(355.3,+IBCPOL):5
IF '$TEST
DO LOCKED^IBTRCD1
GOTO EDPOLQ
+5 IF IBCPOL
Begin DoDot:1
+6 DO SAVE^IBCNSP3(IBCPOL)
+7 SET DIE="^IBA(355.3,"
SET DA=IBCPOL
+8 SET 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;"
+9 IF $DATA(IBREG)
IF '$GET(IBNEWP)
SET 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;"
+10 DO ^DIE
+11 DO COMP^IBCNSP3(IBCPOL)
+12 IF IBDIF
DO UPDATE^IBCNSP3(IBCPOL)
DO UPDATPT^IBCNSP3(DFN,IBCDFN)
IF $$DUPPOL^IBCNSOK1(IBCPOL,1)
End DoDot:1
+13 LOCK -^IBA(355.3,+IBCPOL)
EDPOLQ QUIT
+1 ;
NEW(IBCNSC) ; -- ask if add new policy, if yes file (addh^ibcnsu)
+1 NEW IBCPOL,DIR,Y,X,IBGRP
+2 SET IBCPOL=-1
+3 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="ARE YOU ADDING "_$PIECE(^DIC(36,+IBCNSC,0),"^")_" AS A NEW GROUP INSURANCE PLAN"
+4 SET 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'."
+5 DO ^DIR
KILL DIR
+6 IF Y<1!($DATA(DIRUT))
GOTO NEWQ
+7 ;
+8 ; -- is group policy
+9 SET 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."
+10 SET DIR(0)="355.3,.02"
SET DIR("A")="IS THIS A GROUP PLAN"
DO ^DIR
KILL DIR
SET IBGRP=Y
+11 IF $DATA(DIRUT)
GOTO NEWQ
+12 ;
+13 ; -- file new policy in policy file
+14 SET IBCPOL=$$ADDH^IBCNSU(IBCNSC,IBGRP)
NEWQ QUIT IBCPOL
+1 ;
OK ; -- ask okay
+1 SET IBQUIT=0
SET DIR(0)="Y"
SET DIR("A")=" ...OK"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
SET IBQUIT=1
+3 SET IBOK=Y
+4 QUIT
+5 ;
ADH ; -- show existing policies for help
+1 NEW DIR,DA,%A
+2 WRITE !!,"The patient currently has the following Insurance Policies"
+3 DO DISP^IBCNS
+4 QUIT
