Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCNSP2

IBCNSP2.m

Go to the documentation of this file.
  1. IBCNSP2 ;ALB/AAS - PATIENT INSURANCE INTERFACE FOR REGISTRATION ;21-JUNE-93
  1. ;;2.0;INTEGRATED BILLING;**6,28,75,82,155,371**;21-MAR-94;Build 57
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. % ;
  1. REG ; --Edit Patient insurance from registration, fee and mccr, allow new entries
  1. ; only edit policy if new policy
  1. ; call event driver if adding a new policy
  1. ;
  1. ; -- Input DFN = patient
  1. ;
  1. I $G(DGPRFLG) D PREG^IBCNBME(DFN) Q
  1. D REG^IBCNBME(DFN)
  1. Q
  1. ;
  1. 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
  1. S IBCNP=1
  1. I '$D(DFN) D G:$D(VALMQUIT) REGQ
  1. .S DIC="^DPT(",DIC(0)="AEQMN" D ^DIC
  1. .S DFN=+Y
  1. I $G(DFN)<1 S IBQUIT=1,VALMQUIT="" G REGQ
  1. ;
  1. I '$$ASKCOVD(DFN,.IBCOV,.IBCOVP) S IBQUIT=1 G REGQ
  1. ;
  1. R1 S (IBNEW,IBNEWP,IBQUIT)=0
  1. S DIC="^DPT("_DFN_",.312,",DIC(0)="AEQLM",DIC("A")="Select INSURANCE COMPANY: "
  1. 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))"
  1. 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
  1. S DA(1)=DFN
  1. I $G(^DPT(DFN,.312,0))="" S ^DPT(DFN,.312,0)="^2.312PAI^^"
  1. D ^DIC K DIC I +Y<1 S IBQUIT=1,VALMQUIT="" G REGQ
  1. S IBCDFN=+Y,IBCNS=$P(Y,"^",2)
  1. I $P(Y,"^",3) S IBNEW=1 I $$DUPCO^IBCNSOK1(DFN,IBCNS,IBCDFN,1)
  1. D BEFORE^IBCNSEVT
  1. S IBCNSEH=$P($G(^IBE(350.9,1,4)),"^",1)
  1. S IBCNP=IBCNP+1
  1. I 'IBNEW,$P($G(^DPT(DFN,.312,+IBCDFN,0)),"^",18)="" D G REGQ
  1. .I '$P($G(^IBE(350.9,1,3)),"^",18) W !,"Insurance conversion not complete, NO EDITING ALLOWED",!! S IBQUIT=1 H 3 Q
  1. .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
  1. ;
  1. I $G(IBFEE),'$G(IBNEW) G REGQ ; fee users can add but not edit existing info
  1. I $G(IBNEW) D G:$G(IBQUIT) REGQ
  1. .D SEL^IBCNSEH
  1. .S IBCPOL=$$LK^IBCNSM31(IBCNS)
  1. .I IBCPOL<1 D NEW^IBCNSJ3(IBCNS,.IBCPOL) S:IBCPOL<1 IBQUIT=1 Q:IBQUIT S IBNEWP=1
  1. .; dgprflg is a 1 if called from pre-registration, set default 4
  1. .; for pre-reg, otherwise set the default to 1 for interview
  1. .S DR=".18////"_IBCPOL_";1.09////"_$S($G(DGPRFLG):4,1:1)_";1.05///NOW;1.06////"_DUZ
  1. .S DA=IBCDFN,DA(1)=DFN,DIE="^DPT("_DFN_",.312," D ^DIE
  1. .K DIE,DA,DR,DIC
  1. ;
  1. ; -- edit patient ins. data
  1. S IBREG=1 G:$G(IBQUIT) REGQ
  1. D PAT^IBCNSEH,PATPOL^IBCNSM32(IBCDFN),UPDCLM(+$G(IBIFN),DFN,IBCDFN)
  1. ;
  1. ; -- edit policy specific data if new or have key
  1. I $G(IBNEWP)!($D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ))) D:'$G(IBQUIT) POL^IBCNSEH,EDPOL^IBCNSM3(IBCDFN)
  1. K IBREG S IBQUIT=0
  1. ;
  1. REGQ ; -- exit logic and checks
  1. ; -- if no policy pointer delete
  1. I $G(IBNEW),$G(IBCDFN),$P($G(^DPT(DFN,.312,+IBCDFN,0)),"^",18)="" D
  1. .D DP1^IBCNSM1 W !,"<DELETED> GROUP INSURANCE PLAN REQUIRED BUT NOT ENTERED" K IBNEW
  1. ;
  1. ; -- call event driver
  1. I $G(IBCDFN),$P($G(^DPT(DFN,.312,+$G(IBCDFN),0)),"^",18) D
  1. .K IBNEW
  1. .D AFTER^IBCNSEVT,^IBCNSEVT
  1. ;
  1. K IBCNS,IBCDFN,IBNEW,IBNEWP
  1. I '$G(IBQUIT) W ! G R1
  1. D COVERED^IBCNSM31(DFN,$G(IBCOVP))
  1. K IBQUIT
  1. Q
  1. ;
  1. FEE ; -- fee entry point to add patient insurance.
  1. D FEE^IBCNBME(DFN)
  1. Q
  1. ;
  1. MCCR ; -- called from screen 3 of the edit bill option in mccr
  1. 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
  1. ;
  1. S IBCNP=1,IBMCR=$$WNRBILL^IBEFUNC(IBIFN)
  1. S DIE="^DGCR(399,",DA=IBIFN,DR="[IB SCREEN3]" D ^DIE K DIC,DIE,DA,DR
  1. ;
  1. I $G(IBADI)=1 D R1 S IBCNRTN=1 K IBADI G MCCR
  1. I 'IBMCR,$$WNRBILL^IBEFUNC(IBIFN) S DGRVRCAL=1
  1. K IBCNRTN
  1. Q
  1. ;
  1. UPDCLM(IBIFN,DFN,IBCDFN) ; Update the claim's insurance nodes when edits are made
  1. ; to the patient insurance file.
  1. ; This procedure is called when a claim is being edited from IB billing
  1. ; screen#3 and also when the patient insurance is being edited directly.
  1. ;
  1. I '$G(IBIFN)!'$G(DFN)!'$G(IBCDFN) Q ; missing something
  1. I $P($G(^DGCR(399,IBIFN,0)),U,2)'=DFN Q ; mismatch of claim and DFN
  1. I $P($G(^DGCR(399,IBIFN,0)),U,13)'=1 Q ; claim not editable
  1. I '$D(^DPT(DFN,.312,IBCDFN,0)) Q ; missing pat ins data
  1. NEW X,Z,NODE
  1. S X=IBCDFN
  1. F Z=1:1:3 I $P($G(^DGCR(399,IBIFN,"M")),U,11+Z)=IBCDFN D Q
  1. . S NODE="I"_Z
  1. . D IX^IBCNS2(IBIFN,NODE)
  1. . Q
  1. Q
  1. ;
  1. DISP ; -- Display Patient insurance policy information for registrations
  1. Q:'$D(DFN)
  1. D DISP^IBCNS
  1. DISPQ Q
  1. ;
  1. ASKCOVD(DFN,IBCOV,IBCOVP) ; ask user if patient covered by insurance (2,.3192), returns true if answered yes
  1. ;
  1. N IBX,IBINSD,DIC,DIE,DA,DR,X,Y,DTOUT
  1. ;
  1. S IBCOV=$P($G(^DPT(DFN,.31)),"^",11),IBINSD=$$INSURED^IBCNS1(DFN),IBX=1 W !
  1. ;
  1. ; -- if covered by ins but none currently active so indicate
  1. I IBCOV="Y",'IBINSD W !!,"Covered By Health Insurance indicates 'YES' but none currently Active.",!,"Please Review!",!!
  1. ;
  1. ; -- ask if covered by insurance
  1. S DIE="^DPT(",DR=".3192",DA=DFN D ^DIE K DIC,DIE,DA,DR I $D(Y)!($D(DTOUT)) S IBX=0
  1. ;
  1. S IBCOVP=$P($G(^DPT(DFN,.31)),"^",11) I +IBX,IBCOVP'="Y",'IBINSD S IBX=0
  1. ;
  1. Q IBX