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

Last change on this file since 700 was 623, checked in by George Lilly, 15 years ago

revised back to 6/30/08 version
File size: 4.7 KB
RevLine 
[623]1IBCNSP2 ;ALB/AAS - PATIENT INSURANCE INTERFACE FOR REGISTRATION ;21-JUNE-93
2 ;;2.0;INTEGRATED BILLING;**6,28,75,82,155**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5% ;
6REG ; --Edit Patient insurance from registration, fee and mccr, allow new entries
7 ; only edit policy if new policy
8 ; call event driver if adding a new policy
9 ;
10 ; -- Input DFN = patient
11 ;
12 I $G(DGPRFLG) D PREG^IBCNBME(DFN) Q
13 D REG^IBCNBME(DFN)
14 Q
15 ;
16 N DIC,DIE,DE,DQ,DIR,DA,DR,DIC,DIV,X,Y,I,J,L,D,DIH,DIY,IBSEL,IBDD,IBD,IBNEW,IBNEWP,IBDT,IBQUIT,IBCNS,IBCDFN,IBCNSEH,IBCNP,IBCPOL,IBOK,VALMQUIT,IBCNT,IBEVT1,IBEVTA,VAERR,IBCOVP
17 S IBCNP=1
18 I '$D(DFN) D G:$D(VALMQUIT) REGQ
19 .S DIC="^DPT(",DIC(0)="AEQMN" D ^DIC
20 .S DFN=+Y
21 I $G(DFN)<1 S IBQUIT=1,VALMQUIT="" G REGQ
22 ;
23 I '$$ASKCOVD(DFN,.IBCOV,.IBCOVP) S IBQUIT=1 G REGQ
24 ; -- of covered by ins but none currently active so indicate
25 ;S IBCOV=$P($G(^DPT(DFN,.31)),"^",11)
26 ;I IBCOV="Y",'$$INSURED^IBCNS1(DFN) W !!,"Covered By Health Insurance indicates 'YES' but none currently Active.",!,"Please Review!",!!
27 ;
28 ;; -- ask if covered by insuracnce
29 ;S DIE="^DPT(",DR=".3192",DA=DFN D ^DIE K DIC,DIE,DA,DR
30 ;S IBCOVP=$P($G(^DPT(DFN,.31)),"^",11)
31 ;I $D(Y)!($D(DTOUT)) S IBQUIT=1 G REGQ
32 ;I $P($G(^DPT(DFN,.31)),"^",11)'="Y",'$$INSURED^IBCNS1(DFN) S IBQUIT=1 G REGQ
33 ;
34R1 S (IBNEW,IBNEWP,IBQUIT)=0
35 S DIC="^DPT("_DFN_",.312,",DIC(0)="AEQLM",DIC("A")="Select INSURANCE COMPANY: "
36 S DIC("W")="N IBD S IBD=$G(^DPT(DFN,.312,+Y,0)) W "" Group: ""_$$GRP^IBCNS($P(IBD,U,18))_"" Whose: ""_$$EXPAND^IBTRE(2.312,6,$P(IBD,U,6))"
37 I IBCNP=1 S X=$P($G(^DIC(36,+$G(^DPT(DFN,.312,+$P($G(^DPT(DFN,.312,0)),"^",3),0)),0)),"^") I X'="" S DIC("B")=X
38 S DA(1)=DFN
39 I $G(^DPT(DFN,.312,0))="" S ^DPT(DFN,.312,0)="^2.312PAI^^"
40 D ^DIC K DIC I +Y<1 S IBQUIT=1,VALMQUIT="" G REGQ
41 S IBCDFN=+Y,IBCNS=$P(Y,"^",2)
42 I $P(Y,"^",3) S IBNEW=1 I $$DUPCO^IBCNSOK1(DFN,IBCNS,IBCDFN,1)
43 D BEFORE^IBCNSEVT
44 S IBCNSEH=$P($G(^IBE(350.9,1,4)),"^",1)
45 S IBCNP=IBCNP+1
46 I 'IBNEW,$P($G(^DPT(DFN,.312,+IBCDFN,0)),"^",18)="" D G REGQ
47 .I '$P($G(^IBE(350.9,1,3)),"^",18) W !,"Insurance conversion not complete, NO EDITING ALLOWED",!! S IBQUIT=1 H 3 Q
48 .I $P($G(^IBE(350.9,1,3)),"^",18) W !,"INVALID ENTRY, DELETE AND RE-ENTER, NO EDITING ALLOWED",!! S IBQUIT=1 H 3 Q
49 ;
50 I $G(IBFEE),'$G(IBNEW) G REGQ ; fee users can add but not edit existing info
51 I $G(IBNEW) D G:$G(IBQUIT) REGQ
52 .D SEL^IBCNSEH
53 .S IBCPOL=$$LK^IBCNSM31(IBCNS)
54 .I IBCPOL<1 D NEW^IBCNSJ3(IBCNS,.IBCPOL) S:IBCPOL<1 IBQUIT=1 Q:IBQUIT S IBNEWP=1
55 .; dgprflg is a 1 if called from pre-registration, set default 4
56 .; for pre-reg, otherwise set the default to 1 for interview
57 .S DR=".18////"_IBCPOL_";1.09////"_$S($G(DGPRFLG):4,1:1)_";1.05///NOW;1.06////"_DUZ
58 .S DA=IBCDFN,DA(1)=DFN,DIE="^DPT("_DFN_",.312," D ^DIE
59 .K DIE,DA,DR,DIC
60 ;
61 ; -- edit patient ins. data
62 S IBREG=1 G:$G(IBQUIT) REGQ
63 D PAT^IBCNSEH,PATPOL^IBCNSM32(IBCDFN)
64 ;
65 ; -- edit policy specific data if new or have key
66 I $G(IBNEWP)!($D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ))) D:'$G(IBQUIT) POL^IBCNSEH,EDPOL^IBCNSM3(IBCDFN)
67 K IBREG S IBQUIT=0
68 ;
69REGQ ; -- exit logic and checks
70 ; -- if no policy pointer delete
71 I $G(IBNEW),$G(IBCDFN),$P($G(^DPT(DFN,.312,+IBCDFN,0)),"^",18)="" D
72 .D DP1^IBCNSM1 W !,"<DELETED> GROUP INSURANCE PLAN REQUIRED BUT NOT ENTERED" K IBNEW
73 ;
74 ; -- call event driver
75 I $G(IBCDFN),$P($G(^DPT(DFN,.312,+$G(IBCDFN),0)),"^",18) D
76 .K IBNEW
77 .D AFTER^IBCNSEVT,^IBCNSEVT
78 ;
79 K IBCNS,IBCDFN,IBNEW,IBNEWP
80 I '$G(IBQUIT) W ! G R1
81 D COVERED^IBCNSM31(DFN,$G(IBCOVP))
82 K IBQUIT
83 Q
84 ;
85FEE ; -- fee entry point to add patient insurance.
86 ;N IBFEE S IBFEE=1 D REG
87 D FEE^IBCNBME(DFN)
88 Q
89 ;
90MCCR ; -- called from screen 3 of the edit bill option in mccr
91 N DLAYGO,DIC,DIE,DE,DQ,DIR,DA,DR,DIC,DIV,X,Y,I,J,L,D,DIH,DIY,IBSEL,IBDD,IBD,IBNEW,IBNEWP,IBDT,IBQUIT,IBCNS,IBCDFN,IBCNSEH,IBCNP,IBCPOL,IBOK,VALMQUIT,IBMCR
92 ;
93 S IBCNP=1,IBMCR=$$WNRBILL^IBEFUNC(IBIFN)
94 S DIE="^DGCR(399,",DA=IBIFN,DR="[IB SCREEN3]" D ^DIE K DIC,DIE,DA,DR
95 ;
96 I $G(IBADI)=1 D R1 S IBCNRTN=1 K IBADI G MCCR
97 I 'IBMCR,$$WNRBILL^IBEFUNC(IBIFN) S DGRVRCAL=1
98 K IBCNRTN
99 Q
100 ;
101DISP ; -- Display Patient insurance policy information for registrations
102 Q:'$D(DFN)
103 D DISP^IBCNS
104DISPQ Q
105 ;
106ASKCOVD(DFN,IBCOV,IBCOVP) ; ask user if patient covered by insurance (2,.3192), returns true if answered yes
107 ;
108 N IBX,IBINSD,DIC,DIE,DA,DR,X,Y,DTOUT
109 ;
110 S IBCOV=$P($G(^DPT(DFN,.31)),"^",11),IBINSD=$$INSURED^IBCNS1(DFN),IBX=1 W !
111 ;
112 ; -- if covered by ins but none currently active so indicate
113 I IBCOV="Y",'IBINSD W !!,"Covered By Health Insurance indicates 'YES' but none currently Active.",!,"Please Review!",!!
114 ;
115 ; -- ask if covered by insurance
116 S DIE="^DPT(",DR=".3192",DA=DFN D ^DIE K DIC,DIE,DA,DR I $D(Y)!($D(DTOUT)) S IBX=0
117 ;
118 S IBCOVP=$P($G(^DPT(DFN,.31)),"^",11) I +IBX,IBCOVP'="Y",'IBINSD S IBX=0
119 ;
120 Q IBX
Note: See TracBrowser for help on using the repository browser.