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