source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSM3.m@ 970

Last change on this file since 970 was 613, checked in by George Lilly, 16 years ago

initial load of WorldVistAEHR
File size: 3.1 KB
Line 
1IBCNSM3 ;ALB/AAS - INSURANCE MANAGEMENT - OUTPUTS ; 4/7/03 9:56am
2 ;;2.0;INTEGRATED BILLING;**6,28,85,211,251**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5% G EN^IBCNSM
6 ;
7AD ; -- Add new insurance policy
8 N X,Y,DO,DD,DA,DR,DIC,DIE,DIK,DIR,DIRUT,IBCNSP,IBCPOL,IBQUIT,IBOK,IBCDFN,IBAD,IBGRP,IBADPOL,IBCOVP,ANS,IBGNA,IBGNU
9 S IBCNSEH=$P($G(^IBE(350.9,1,4)),"^",1),IBQUIT=0,IBADPOL=1
10 D FULL^VALM1
11 S IBCOVP=$P($G(^DPT(DFN,.31)),"^",11)
12 I '$D(^DPT(DFN,.312,0)) S ^DPT(DFN,.312,0)="^2.312PAI^^"
13 ;
14 D INS^IBCNSEH
15 ; -- Select insurance company
16 ; If one already exists for same co. ask are you sure you are
17 ; adding a new one
18 S DIR(0)="350.9,4.06"
19 S DIR("A")="Select INSURANCE COMPANY",DIR("??")="^D ADH^IBCNSM3"
20 S DIR("?")="Select the Insurance Company for the policy you are entering"
21 D ^DIR K DIR S IBCNSP=+Y I Y<1 G ADQ
22 I $P($G(^DIC(36,+IBCNSP,0)),"^",2)="N" W !,"This company does not reimburse. "
23 I $P($G(^DIC(36,+IBCNSP,0)),"^",5) W !,*7,"Warning: Inactive Company" H 3 K IBCNSP G ADQ
24 I $$DUPCO^IBCNSOK1(DFN,IBCNSP,"",1) H 3
25 ;
26 ; -- see if can use existing policy
27 D SEL^IBCNSEH
28 S IBCPOL=$$LK^IBCNSM31(IBCNSP)
29 I IBCPOL<1 D NEW^IBCNSJ3(IBCNSP,.IBCPOL)
30 I IBCPOL<1 G ADQ
31 ;
32 ; -- file new patient policy
33 S DIC("DR")=".18////"_IBCPOL_";1.09////1;1.05///NOW;1.06////"_DUZ
34 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
35 D BEFORE^IBCNSEVT
36 ;
37 ; -- Edit patient policy data
38 D PAT^IBCNSEH,PATPOL^IBCNSM32(IBCDFN)
39 ;
40 ; -- edit PLAN data if hold key
41 I '$D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ)) G ADQ
42 I '$G(IBQUIT) D POL^IBCNSEH,EDPOL(IBCDFN)
43 I '$G(IBNEW) D AI^IBCNSP1
44 G ADQ
45 ;
46ADQ D COVERED^IBCNSM31(DFN,IBCOVP)
47 I $G(IBCDFN)>0 D AFTER^IBCNSEVT,^IBCNSEVT
48 I $G(IBCPOL)>0 D BLD^IBCNSM
49 S VALMBCK="R"
50 Q
51 ;
52EDPOL(IBCDFN) ; -- Edit GROUP PLAN specific info
53 I '$G(IBCDFN) G EDPOLQ
54 N DA,DR,DIE,DIC,IBAD,IBCPOL,IBDIF
55 S IBCPOL=$P($G(^DPT(DFN,.312,IBCDFN,0)),"^",18)
56 L +^IBA(355.3,+IBCPOL):5 I '$T D LOCKED^IBTRCD1 G EDPOLQ
57 I IBCPOL D
58 .D SAVE^IBCNSP3(IBCPOL)
59 .S DIE="^IBA(355.3,",DA=IBCPOL
60 .;DAOU/EEN-Adding BIN and PCN (6.02,6.03)
61 .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;.15;S Y=$S($$CATOK^IBCEMRA($P(^(0),U,14)):""@60"",1:""@65"");@60;.14;@65;.13;.05;.12;.06;.07;.08//YES;"
62 .;DAOU/EEN-Adding BIN and PCN (6.02,6.03)
63 .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;"
64 .I $D(IBREG),'$G(IBNEWP) S DR=DR_".15;S Y=$S($$CATOK^IBCEMRA($P(^(0),U,14)):""@60"",1:""@65"");@60;.14;@65;.13;.05;.12;.06;.07;.08//YES;"
65 .D ^DIE
66 .D COMP^IBCNSP3(IBCPOL)
67 .I IBDIF D UPDATE^IBCNSP3(IBCPOL),UPDATPT^IBCNSP3(DFN,IBCDFN) I $$DUPPOL^IBCNSOK1(IBCPOL,1)
68 L -^IBA(355.3,+IBCPOL)
69EDPOLQ Q
70 ;
71OK ; -- ask okay
72 S IBQUIT=0,DIR(0)="Y",DIR("A")=" ...OK",DIR("B")="YES" D ^DIR K DIR
73 I $D(DIRUT) S IBQUIT=1
74 S IBOK=Y
75 Q
76 ;
77ADH ; -- show existing policies for help
78 N DIR,DA,%A
79 W !!,"The patient currently has the following Insurance Policies"
80 D DISP^IBCNS
81 Q
Note: See TracBrowser for help on using the repository browser.