- 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 Feb 18, 2025@23:43:51 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