- IBCNSP2 ;ALB/AAS - PATIENT INSURANCE INTERFACE FOR REGISTRATION ; 21-JUNE-93
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;;Per VHA Directive 10-93-142, 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
- ;
- 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
- ;
- ; -- of covered by ins but none currently active so indicate
- S IBCOV=$P($G(^DPT(DFN,.31)),"^",11)
- I IBCOV="Y",'$$INSURED^IBCNS1(DFN) W !!,"Covered By Health Insurance indicates 'YES' but none currently Active.",!,"Please Review!",!!
- ;
- ; -- ask if covered by insuracnce
- S DIE="^DPT(",DR=".3192",DA=DFN D ^DIE K DIC,DIE,DA,DR
- S IBCOVP=$P($G(^DPT(DFN,.31)),"^",11)
- I $D(Y)!($D(DTOUT)) S IBQUIT=1 G REGQ
- I $P($G(^DPT(DFN,.31)),"^",11)'="Y",'$$INSURED^IBCNS1(DFN) 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)
- 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>0 D OK^IBCNSM3 Q:IBQUIT S:'IBOK IBCPOL=-1
- .I IBCPOL<1 S IBCPOL=$$NEW^IBCNSM3(IBCNS) S:IBCPOL<1 IBQUIT=1 Q:IBQUIT S IBNEWP=1
- .S DR=".18////"_IBCPOL_";1.09////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^IBCNSM3(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
- ;
- ; -- if new call event drive
- I $G(IBNEW),$G(IBCDFN)>1,$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.
- N IBFEE S IBFEE=1 D REG
- 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
- ;
- S IBCNP=1
- 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
- K IBCNRTN
- Q
- ;
- DISP ; -- Display Patient insurance policy information for registrations
- Q:'$D(DFN)
- D DISP^IBCNS
- DISPQ Q
- IBCNSP2 ;ALB/AAS - PATIENT INSURANCE INTERFACE FOR REGISTRATION ; 21-JUNE-93
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, 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 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
- +7 SET IBCNP=1
- +8 IF '$DATA(DFN)
- Begin DoDot:1
- +9 SET DIC="^DPT("
- SET DIC(0)="AEQMN"
- DO ^DIC
- +10 SET DFN=+Y
- End DoDot:1
- IF $DATA(VALMQUIT)
- GOTO REGQ
- +11 IF $GET(DFN)<1
- SET IBQUIT=1
- SET VALMQUIT=""
- GOTO REGQ
- +12 ;
- +13 ; -- of covered by ins but none currently active so indicate
- +14 SET IBCOV=$PIECE($GET(^DPT(DFN,.31)),"^",11)
- +15 IF IBCOV="Y"
- IF '$$INSURED^IBCNS1(DFN)
- WRITE !!,"Covered By Health Insurance indicates 'YES' but none currently Active.",!,"Please Review!",!!
- +16 ;
- +17 ; -- ask if covered by insuracnce
- +18 SET DIE="^DPT("
- SET DR=".3192"
- SET DA=DFN
- DO ^DIE
- KILL DIC,DIE,DA,DR
- +19 SET IBCOVP=$PIECE($GET(^DPT(DFN,.31)),"^",11)
- +20 IF $DATA(Y)!($DATA(DTOUT))
- SET IBQUIT=1
- GOTO REGQ
- +21 IF $PIECE($GET(^DPT(DFN,.31)),"^",11)'="Y"
- IF '$$INSURED^IBCNS1(DFN)
- SET IBQUIT=1
- GOTO REGQ
- +22 ;
- 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 SET IBCNSEH=$PIECE($GET(^IBE(350.9,1,4)),"^",1)
- +10 SET IBCNP=IBCNP+1
- +11 IF 'IBNEW
- IF $PIECE($GET(^DPT(DFN,.312,+IBCDFN,0)),"^",18)=""
- Begin DoDot:1
- +12 IF '$PIECE($GET(^IBE(350.9,1,3)),"^",18)
- WRITE !,"Insurance conversion not complete, NO EDITING ALLOWED",!!
- SET IBQUIT=1
- HANG 3
- QUIT
- +13 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
- +14 ;
- +15 ; fee users can add but not edit existing info
- IF $GET(IBFEE)
- IF '$GET(IBNEW)
- GOTO REGQ
- +16 IF $GET(IBNEW)
- Begin DoDot:1
- +17 DO SEL^IBCNSEH
- +18 SET IBCPOL=$$LK^IBCNSM31(IBCNS)
- +19 IF IBCPOL>0
- DO OK^IBCNSM3
- IF IBQUIT
- QUIT
- IF 'IBOK
- SET IBCPOL=-1
- +20 IF IBCPOL<1
- SET IBCPOL=$$NEW^IBCNSM3(IBCNS)
- IF IBCPOL<1
- SET IBQUIT=1
- IF IBQUIT
- QUIT
- SET IBNEWP=1
- +21 SET DR=".18////"_IBCPOL_";1.09////1;1.05///NOW;1.06////"_DUZ
- +22 SET DA=IBCDFN
- SET DA(1)=DFN
- SET DIE="^DPT("_DFN_",.312,"
- DO ^DIE
- +23 KILL DIE,DA,DR,DIC
- End DoDot:1
- IF $GET(IBQUIT)
- GOTO REGQ
- +24 ;
- +25 ; -- edit patient ins. data
- +26 SET IBREG=1
- IF $GET(IBQUIT)
- GOTO REGQ
- +27 DO PAT^IBCNSEH
- DO PATPOL^IBCNSM3(IBCDFN)
- +28 ;
- +29 ; -- edit policy specific data if new or have key
- +30 IF $GET(IBNEWP)!($DATA(^XUSEC("IB INSURANCE SUPERVISOR",DUZ)))
- IF '$GET(IBQUIT)
- DO POL^IBCNSEH
- DO EDPOL^IBCNSM3(IBCDFN)
- +31 KILL IBREG
- SET IBQUIT=0
- +32 ;
- 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 ; -- if new call event drive
- +6 IF $GET(IBNEW)
- IF $GET(IBCDFN)>1
- 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 NEW IBFEE
- SET IBFEE=1
- DO REG
- +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
- +2 ;
- +3 SET IBCNP=1
- +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 KILL IBCNRTN
- +8 QUIT
- +9 ;
- DISP ; -- Display Patient insurance policy information for registrations
- +1 IF '$DATA(DFN)
- QUIT
- +2 DO DISP^IBCNS
- DISPQ QUIT
