- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP2.m
r613 r623 1 IBCNSP2 ;ALB/AAS - PATIENT INSURANCE INTERFACE FOR REGISTRATION ;21-JUNE-93 2 ;;2.0;INTEGRATED BILLING;**6,28,75,82,155,371**;21-MAR-94;Build 57 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 % ; 6 REG ; --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 ; 25 R1 S (IBNEW,IBNEWP,IBQUIT)=0 26 S DIC="^DPT("_DFN_",.312,",DIC(0)="AEQLM",DIC("A")="Select INSURANCE COMPANY: " 27 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))" 28 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 29 S DA(1)=DFN 30 I $G(^DPT(DFN,.312,0))="" S ^DPT(DFN,.312,0)="^2.312PAI^^" 31 D ^DIC K DIC I +Y<1 S IBQUIT=1,VALMQUIT="" G REGQ 32 S IBCDFN=+Y,IBCNS=$P(Y,"^",2) 33 I $P(Y,"^",3) S IBNEW=1 I $$DUPCO^IBCNSOK1(DFN,IBCNS,IBCDFN,1) 34 D BEFORE^IBCNSEVT 35 S IBCNSEH=$P($G(^IBE(350.9,1,4)),"^",1) 36 S IBCNP=IBCNP+1 37 I 'IBNEW,$P($G(^DPT(DFN,.312,+IBCDFN,0)),"^",18)="" D G REGQ 38 .I '$P($G(^IBE(350.9,1,3)),"^",18) W !,"Insurance conversion not complete, NO EDITING ALLOWED",!! S IBQUIT=1 H 3 Q 39 .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 40 ; 41 I $G(IBFEE),'$G(IBNEW) G REGQ ; fee users can add but not edit existing info 42 I $G(IBNEW) D G:$G(IBQUIT) REGQ 43 .D SEL^IBCNSEH 44 .S IBCPOL=$$LK^IBCNSM31(IBCNS) 45 .I IBCPOL<1 D NEW^IBCNSJ3(IBCNS,.IBCPOL) S:IBCPOL<1 IBQUIT=1 Q:IBQUIT S IBNEWP=1 46 .; dgprflg is a 1 if called from pre-registration, set default 4 47 .; for pre-reg, otherwise set the default to 1 for interview 48 .S DR=".18////"_IBCPOL_";1.09////"_$S($G(DGPRFLG):4,1:1)_";1.05///NOW;1.06////"_DUZ 49 .S DA=IBCDFN,DA(1)=DFN,DIE="^DPT("_DFN_",.312," D ^DIE 50 .K DIE,DA,DR,DIC 51 ; 52 ; -- edit patient ins. data 53 S IBREG=1 G:$G(IBQUIT) REGQ 54 D PAT^IBCNSEH,PATPOL^IBCNSM32(IBCDFN),UPDCLM(+$G(IBIFN),DFN,IBCDFN) 55 ; 56 ; -- edit policy specific data if new or have key 57 I $G(IBNEWP)!($D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ))) D:'$G(IBQUIT) POL^IBCNSEH,EDPOL^IBCNSM3(IBCDFN) 58 K IBREG S IBQUIT=0 59 ; 60 REGQ ; -- exit logic and checks 61 ; -- if no policy pointer delete 62 I $G(IBNEW),$G(IBCDFN),$P($G(^DPT(DFN,.312,+IBCDFN,0)),"^",18)="" D 63 .D DP1^IBCNSM1 W !,"<DELETED> GROUP INSURANCE PLAN REQUIRED BUT NOT ENTERED" K IBNEW 64 ; 65 ; -- call event driver 66 I $G(IBCDFN),$P($G(^DPT(DFN,.312,+$G(IBCDFN),0)),"^",18) D 67 .K IBNEW 68 .D AFTER^IBCNSEVT,^IBCNSEVT 69 ; 70 K IBCNS,IBCDFN,IBNEW,IBNEWP 71 I '$G(IBQUIT) W ! G R1 72 D COVERED^IBCNSM31(DFN,$G(IBCOVP)) 73 K IBQUIT 74 Q 75 ; 76 FEE ; -- fee entry point to add patient insurance. 77 D FEE^IBCNBME(DFN) 78 Q 79 ; 80 MCCR ; -- called from screen 3 of the edit bill option in mccr 81 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 82 ; 83 S IBCNP=1,IBMCR=$$WNRBILL^IBEFUNC(IBIFN) 84 S DIE="^DGCR(399,",DA=IBIFN,DR="[IB SCREEN3]" D ^DIE K DIC,DIE,DA,DR 85 ; 86 I $G(IBADI)=1 D R1 S IBCNRTN=1 K IBADI G MCCR 87 I 'IBMCR,$$WNRBILL^IBEFUNC(IBIFN) S DGRVRCAL=1 88 K IBCNRTN 89 Q 90 ; 91 UPDCLM(IBIFN,DFN,IBCDFN) ; Update the claim's insurance nodes when edits are made 92 ; to the patient insurance file. 93 ; This procedure is called when a claim is being edited from IB billing 94 ; screen#3 and also when the patient insurance is being edited directly. 95 ; 96 I '$G(IBIFN)!'$G(DFN)!'$G(IBCDFN) Q ; missing something 97 I $P($G(^DGCR(399,IBIFN,0)),U,2)'=DFN Q ; mismatch of claim and DFN 98 I $P($G(^DGCR(399,IBIFN,0)),U,13)'=1 Q ; claim not editable 99 I '$D(^DPT(DFN,.312,IBCDFN,0)) Q ; missing pat ins data 100 NEW X,Z,NODE 101 S X=IBCDFN 102 F Z=1:1:3 I $P($G(^DGCR(399,IBIFN,"M")),U,11+Z)=IBCDFN D Q 103 . S NODE="I"_Z 104 . D IX^IBCNS2(IBIFN,NODE) 105 . Q 106 Q 107 ; 108 DISP ; -- Display Patient insurance policy information for registrations 109 Q:'$D(DFN) 110 D DISP^IBCNS 111 DISPQ Q 112 ; 113 ASKCOVD(DFN,IBCOV,IBCOVP) ; ask user if patient covered by insurance (2,.3192), returns true if answered yes 114 ; 115 N IBX,IBINSD,DIC,DIE,DA,DR,X,Y,DTOUT 116 ; 117 S IBCOV=$P($G(^DPT(DFN,.31)),"^",11),IBINSD=$$INSURED^IBCNS1(DFN),IBX=1 W ! 118 ; 119 ; -- if covered by ins but none currently active so indicate 120 I IBCOV="Y",'IBINSD W !!,"Covered By Health Insurance indicates 'YES' but none currently Active.",!,"Please Review!",!! 121 ; 122 ; -- ask if covered by insurance 123 S DIE="^DPT(",DR=".3192",DA=DFN D ^DIE K DIC,DIE,DA,DR I $D(Y)!($D(DTOUT)) S IBX=0 124 ; 125 S IBCOVP=$P($G(^DPT(DFN,.31)),"^",11) I +IBX,IBCOVP'="Y",'IBINSD S IBX=0 126 ; 127 Q IBX 1 IBCNSP2 ;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 % ; 6 REG ; --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 ; 34 R1 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 ; 69 REGQ ; -- 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 ; 85 FEE ; -- fee entry point to add patient insurance. 86 ;N IBFEE S IBFEE=1 D REG 87 D FEE^IBCNBME(DFN) 88 Q 89 ; 90 MCCR ; -- 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 ; 101 DISP ; -- Display Patient insurance policy information for registrations 102 Q:'$D(DFN) 103 D DISP^IBCNS 104 DISPQ Q 105 ; 106 ASKCOVD(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 TracChangeset
for help on using the changeset viewer.
