IBCNSM3 ;ALB/AAS - INSURANCE MANAGEMENT - OUTPUTS ; 4/7/03 9:56am
;;2.0;INTEGRATED BILLING;**6,28,85,211,251,399,506,516,631**;21-MAR-94;Build 23
;;Per VA Directive 6402, 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,ANS,IBGNA,IBGNU
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)
;
; IB*2.0*506 added IBKEY parameter (4th) to the NEW^IBCNSJ3 call (check user's security keys)
I IBCPOL<1 D NEW^IBCNSJ3(IBCNSP,.IBCPOL,,1)
I IBCPOL<1 G ADQ
;
; -- file new patient policy
;IB*2.0*516/baa - Use HIPAA Compliant fields
;S DIC("DR")=".18////"_IBCPOL_";1.09////7.02;1.05///NOW;1.06////"_DUZ
;/IB*2.0*631/vd - Replaced the original code which was accidentally stepped on by
; the IB*2.0*516 patch and caused an invalid value to appear in the SOI field when
; entering a new patient policy. (US7912)
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
D BEFORE^IBCNSEVT
;
; -- Edit patient policy data
D PAT^IBCNSEH,PATPOL^IBCNSM32(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(IBCDFN)>0 D AFTER^IBCNSEVT,^IBCNSEVT
I $G(IBCPOL)>0 D BLD^IBCNSM
S VALMBCK="R"
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
.;IB*2.0*516/baa - Use HIPAA Compliant fields
.;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;"
.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;"
.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;"
.;
.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;"
.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;"
.;
.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
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSM3 3929 printed Apr 09, 2024@21:24:06 Page 2
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
+2 ;;Per VA Directive 6402, 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,ANS,IBGNA,IBGNU
+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)
+22 ;
+23 ; IB*2.0*506 added IBKEY parameter (4th) to the NEW^IBCNSJ3 call (check user's security keys)
+24 IF IBCPOL<1
DO NEW^IBCNSJ3(IBCNSP,.IBCPOL,,1)
+25 IF IBCPOL<1
GOTO ADQ
+26 ;
+27 ; -- file new patient policy
+28 ;IB*2.0*516/baa - Use HIPAA Compliant fields
+29 ;S DIC("DR")=".18////"_IBCPOL_";1.09////7.02;1.05///NOW;1.06////"_DUZ
+30 ;/IB*2.0*631/vd - Replaced the original code which was accidentally stepped on by
+31 ; the IB*2.0*516 patch and caused an invalid value to appear in the SOI field when
+32 ; entering a new patient policy. (US7912)
+33 SET DIC("DR")=".18////"_IBCPOL_";1.09////1;1.05///NOW;1.06////"_DUZ
+34 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
+35 DO BEFORE^IBCNSEVT
+36 ;
+37 ; -- Edit patient policy data
+38 DO PAT^IBCNSEH
DO PATPOL^IBCNSM32(IBCDFN)
+39 ;
+40 ; -- edit PLAN data if hold key
+41 IF '$DATA(^XUSEC("IB INSURANCE SUPERVISOR",DUZ))
GOTO ADQ
+42 IF '$GET(IBQUIT)
DO POL^IBCNSEH
DO EDPOL(IBCDFN)
+43 IF '$GET(IBNEW)
DO AI^IBCNSP1
+44 GOTO ADQ
+45 ;
ADQ DO COVERED^IBCNSM31(DFN,IBCOVP)
+1 IF $GET(IBCDFN)>0
DO AFTER^IBCNSEVT
DO ^IBCNSEVT
+2 IF $GET(IBCPOL)>0
DO BLD^IBCNSM
+3 SET VALMBCK="R"
+4 QUIT
+5 ;
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 ;IB*2.0*516/baa - Use HIPAA Compliant fields
+9 ;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;"
+10 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;2.01;2.02;@55;6.02;6.03;.09;"
+11 SET 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;"
+12 ;
+13 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;6.02;6.03;.09;"
+14 IF $DATA(IBREG)
IF '$GET(IBNEWP)
SET 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;"
+15 ;
+16 DO ^DIE
+17 DO COMP^IBCNSP3(IBCPOL)
+18 IF IBDIF
DO UPDATE^IBCNSP3(IBCPOL)
DO UPDATPT^IBCNSP3(DFN,IBCDFN)
IF $$DUPPOL^IBCNSOK1(IBCPOL,1)
End DoDot:1
+19 LOCK -^IBA(355.3,+IBCPOL)
EDPOLQ QUIT
+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
