- 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 Jan 18, 2025@03:19:06 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