IBCNSM32 ;ALB/AAS - INSURANCE MANAGEMENT - POLICY EDIT ;23-JAN-95
;;2.0;INTEGRATED BILLING;**28,40,52,85,103,133,361,371,413**;21-MAR-94;Build 9
;;Per VHA Directive 2004-038, this routine should not be modified.
;
PATPOL(IBCDFN) ; -- edit patient specific policy info
I '$G(IBCDFN) G PATPOLQ
D SAVEPT^IBCNSP3(DFN,IBCDFN)
D POL^IBCNSU41(DFN)
;
; -- give warning if expired or inactive co.
I $P(^DPT(DFN,.312,IBCDFN,0),"^",4),$P(^(0),"^",4)'>DT W !,"WARNING: This appears to be an expired policy!",!
I $P(^DIC(36,+$P(^DPT(DFN,.312,IBCDFN,0),"^"),0),"^",5) W !,*7,"WARNING: This insurance company is INACTIVE!",!
;
N IBAD,IBDIF,DA,DR,DIC,DIE,DGSENFLG S DGSENFLG=1
L +^DPT(DFN,.312,+IBCDFN):5 I '$T D LOCKED^IBTRCD1 G PATPOLQ
;
D EDIT^IBCNSP1(DFN,IBCDFN,.IBQUIT) ; IB*371 edit 2.312 subfile data
;
; If the 2.312 subfile entry was deleted then unlock and get out
I '$D(^DPT(DFN,.312,IBCDFN,0)) L -^DPT(DFN,.312,+IBCDFN) G PATPOLQ
;
; -- if the company was changed, change the policy plan
I $G(IBREG),$G(IBCNS),+$G(^DPT(DFN,.312,IBCDFN,0))'=IBCNS D CHPL
;
K IBFUTUR
D COMPPT^IBCNSP3(DFN,IBCDFN)
I IBDIF D UPDATPT^IBCNSP3(DFN,IBCDFN)
L -^DPT(DFN,.312,+IBCDFN)
;
D FUTURE^IBCNSM31 K Y,IBFUTUR
PATPOLQ Q
;
CHPL ; Change policy plan if the policy company differs from plan company.
; Required variable input:
; DFN -- pointer to the patient in file #2
; IBCDFN -- pointer to the policy in file #2.312
; IBCNS -- pointer to the plan company in file #36
;
N IBBU,IBCNS1,IBCPOL1,IBNEWP1,IBPLAN,IBIP,IBT,X
S X=$G(^DPT(DFN,.312,IBCDFN,0)),IBCNS1=+X
S IBPLAN=$P(X,"^",18),IBIP='$P($G(^IBA(355.3,IBPLAN,0)),"^",2)
W !!,"Since you have changed the Insurance Company to ",$E($P($G(^DIC(36,IBCNS1,0)),"^"),1,25),","
W !,"you must now change the Insurance Plan to which this veteran"
W !,"is subscribing to one which is offered by this company!",!
;
; - warn about benefits used
D BU^IBCNSJ21 I $O(IBBU(0)) D
.W !,"The current policy plan has Benefits Used associated with it!"
.W !,"If you add or select another plan to associate with this policy,"
.W !,"these Benefits Used will be deleted!",!
;
; - warn about Individual Plans
I IBIP D
.W !," *** Please note: Since the veteran's current plan is an Individual Plan,"
.W !?21,"this plan will be deleted if you add or select a new"
.W !?21,"plan to associate with this policy.",!
;
; - select or add a new plan
S IBCPOL1=$$LK^IBCNSM31(IBCNS1)
I 'IBCPOL1 D NEW^IBCNSJ3(IBCNS1,.IBCPOL1) S:IBCPOL1 IBNEWP1=1
I 'IBCPOL1 D G CHPLQ
.W !!,"A new plan was not added or selected!"
.W !,"Changing the policy company back to ",$E($P($G(^DIC(36,IBCNS,0)),"^"),1,25),"..."
.S DIE="^DPT(DFN,.312,",DA(1)=DFN,DA=IBCDFN,DR=".01////"_IBCNS_";1.05///NOW;1.06////"_DUZ D ^DIE K DA,DIE,DR
;
W !!,"Changing the policy plan..."
S DIE="^DPT(DFN,.312,",DA(1)=DFN,DA=IBCDFN,DR=".18////"_IBCPOL1_";1.05///NOW;1.06////"_DUZ D ^DIE K DA,DIE,DR
I IBIP!$G(IBNEWP) W !!,"Deleting the ",$S(IBIP:"current Individual",1:"previously-added")," plan for ",$E($P($G(^DIC(36,IBCNS,0)),"^"),1,25),"..." D DEL^IBCNSJ(IBPLAN)
;
; - delete any dangling benefits used
I $O(IBBU(0)) D
.N IBDAT
.W !!,"Deleting current Benefits Used... "
.S IBDAT="" F S IBDAT=$O(IBBU(IBDAT)) Q:IBDAT="" D DBU^IBCNSJ(IBBU(IBDAT))
;
; - repoint all Insurance Reviews to new company
I $$IR^IBCNSJ21(DFN,IBCDFN) D
.W !!,"Repointing all Insurance Reviews to ",$E($P($G(^DIC(36,IBCNS1,0)),"^"),1,25),"... "
.S IBT=0 F S IBT=$O(^IBT(356.2,"D",DFN,IBT)) Q:'IBT I $P($G(^IBT(356.2,IBT,1)),"^",5)=IBCDFN,$P($G(^(0)),"^",8)'=IBCNS1 S DA=IBT,DR=".08////"_IBCNS1,DIE="^IBT(356.2," D ^DIE K DA,DR,DIE W "."
;
S IBCNS=IBCNS1,IBNEWP=$G(IBNEWP1)
CHPLQ Q
;
PLAN(DFN,IBCDFN,IBCNS) ; Fix policies when identified.
;
; This function is invoked from Inactivate Plan or Change Policy Plan,
; when it is recognized that the policy and plan companies are out
; of synch. If the user doesn't select a new plan to associate with
; the policy, the policy company will be changed to the plan company.
;
; The input parameters are defined above.
;
N IBNEWP
I '$G(DFN)!'$G(IBCDFN)!'$G(IBCNS) G PLANQ
W !!,*7,"The policy company and plan company are not the same!!"
W !,"This inconsistency probably occurred in the past when changing"
W !,"the policy company through Screen 5 of Registration."
W !!,"You must resolve this inconsistency. If you do not choose a new plan"
W !,"offered by the policy company, the policy company will be changed to"
W !,"the plan company (",$P($G(^DIC(36,IBCNS,0)),"^"),") ...."
D CHPL
PLANQ Q
HLP ; -- help text for subscriber id
W !,?5,"Enter Medicare Claim Number (Subscriber ID) exactly as it"
W !,?5,"appears on the Medicare Insurance Card including All Characters."
W !,?5,"Valid HICN formats are: 1-3 alpha characters followed by 6 or 9 digits, "
W !,?5,"or 9 digits followed by 1 alpha character optionally followed by another "
W !,?5,"alpha character or 1 digit."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSM32 5096 printed Sep 23, 2025@19:53:44 Page 2
IBCNSM32 ;ALB/AAS - INSURANCE MANAGEMENT - POLICY EDIT ;23-JAN-95
+1 ;;2.0;INTEGRATED BILLING;**28,40,52,85,103,133,361,371,413**;21-MAR-94;Build 9
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
PATPOL(IBCDFN) ; -- edit patient specific policy info
+1 IF '$GET(IBCDFN)
GOTO PATPOLQ
+2 DO SAVEPT^IBCNSP3(DFN,IBCDFN)
+3 DO POL^IBCNSU41(DFN)
+4 ;
+5 ; -- give warning if expired or inactive co.
+6 IF $PIECE(^DPT(DFN,.312,IBCDFN,0),"^",4)
IF $PIECE(^(0),"^",4)'>DT
WRITE !,"WARNING: This appears to be an expired policy!",!
+7 IF $PIECE(^DIC(36,+$PIECE(^DPT(DFN,.312,IBCDFN,0),"^"),0),"^",5)
WRITE !,*7,"WARNING: This insurance company is INACTIVE!",!
+8 ;
+9 NEW IBAD,IBDIF,DA,DR,DIC,DIE,DGSENFLG
SET DGSENFLG=1
+10 LOCK +^DPT(DFN,.312,+IBCDFN):5
IF '$TEST
DO LOCKED^IBTRCD1
GOTO PATPOLQ
+11 ;
+12 ; IB*371 edit 2.312 subfile data
DO EDIT^IBCNSP1(DFN,IBCDFN,.IBQUIT)
+13 ;
+14 ; If the 2.312 subfile entry was deleted then unlock and get out
+15 IF '$DATA(^DPT(DFN,.312,IBCDFN,0))
LOCK -^DPT(DFN,.312,+IBCDFN)
GOTO PATPOLQ
+16 ;
+17 ; -- if the company was changed, change the policy plan
+18 IF $GET(IBREG)
IF $GET(IBCNS)
IF +$GET(^DPT(DFN,.312,IBCDFN,0))'=IBCNS
DO CHPL
+19 ;
+20 KILL IBFUTUR
+21 DO COMPPT^IBCNSP3(DFN,IBCDFN)
+22 IF IBDIF
DO UPDATPT^IBCNSP3(DFN,IBCDFN)
+23 LOCK -^DPT(DFN,.312,+IBCDFN)
+24 ;
+25 DO FUTURE^IBCNSM31
KILL Y,IBFUTUR
PATPOLQ QUIT
+1 ;
CHPL ; Change policy plan if the policy company differs from plan company.
+1 ; Required variable input:
+2 ; DFN -- pointer to the patient in file #2
+3 ; IBCDFN -- pointer to the policy in file #2.312
+4 ; IBCNS -- pointer to the plan company in file #36
+5 ;
+6 NEW IBBU,IBCNS1,IBCPOL1,IBNEWP1,IBPLAN,IBIP,IBT,X
+7 SET X=$GET(^DPT(DFN,.312,IBCDFN,0))
SET IBCNS1=+X
+8 SET IBPLAN=$PIECE(X,"^",18)
SET IBIP='$PIECE($GET(^IBA(355.3,IBPLAN,0)),"^",2)
+9 WRITE !!,"Since you have changed the Insurance Company to ",$EXTRACT($PIECE($GET(^DIC(36,IBCNS1,0)),"^"),1,25),","
+10 WRITE !,"you must now change the Insurance Plan to which this veteran"
+11 WRITE !,"is subscribing to one which is offered by this company!",!
+12 ;
+13 ; - warn about benefits used
+14 DO BU^IBCNSJ21
IF $ORDER(IBBU(0))
Begin DoDot:1
+15 WRITE !,"The current policy plan has Benefits Used associated with it!"
+16 WRITE !,"If you add or select another plan to associate with this policy,"
+17 WRITE !,"these Benefits Used will be deleted!",!
End DoDot:1
+18 ;
+19 ; - warn about Individual Plans
+20 IF IBIP
Begin DoDot:1
+21 WRITE !," *** Please note: Since the veteran's current plan is an Individual Plan,"
+22 WRITE !?21,"this plan will be deleted if you add or select a new"
+23 WRITE !?21,"plan to associate with this policy.",!
End DoDot:1
+24 ;
+25 ; - select or add a new plan
+26 SET IBCPOL1=$$LK^IBCNSM31(IBCNS1)
+27 IF 'IBCPOL1
DO NEW^IBCNSJ3(IBCNS1,.IBCPOL1)
if IBCPOL1
SET IBNEWP1=1
+28 IF 'IBCPOL1
Begin DoDot:1
+29 WRITE !!,"A new plan was not added or selected!"
+30 WRITE !,"Changing the policy company back to ",$EXTRACT($PIECE($GET(^DIC(36,IBCNS,0)),"^"),1,25),"..."
+31 SET DIE="^DPT(DFN,.312,"
SET DA(1)=DFN
SET DA=IBCDFN
SET DR=".01////"_IBCNS_";1.05///NOW;1.06////"_DUZ
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
GOTO CHPLQ
+32 ;
+33 WRITE !!,"Changing the policy plan..."
+34 SET DIE="^DPT(DFN,.312,"
SET DA(1)=DFN
SET DA=IBCDFN
SET DR=".18////"_IBCPOL1_";1.05///NOW;1.06////"_DUZ
DO ^DIE
KILL DA,DIE,DR
+35 IF IBIP!$GET(IBNEWP)
WRITE !!,"Deleting the ",$SELECT(IBIP:"current Individual",1:"previously-added")," plan for ",$EXTRACT($PIECE($GET(^DIC(36,IBCNS,0)),"^"),1,25),"..."
DO DEL^IBCNSJ(IBPLAN)
+36 ;
+37 ; - delete any dangling benefits used
+38 IF $ORDER(IBBU(0))
Begin DoDot:1
+39 NEW IBDAT
+40 WRITE !!,"Deleting current Benefits Used... "
+41 SET IBDAT=""
FOR
SET IBDAT=$ORDER(IBBU(IBDAT))
if IBDAT=""
QUIT
DO DBU^IBCNSJ(IBBU(IBDAT))
End DoDot:1
+42 ;
+43 ; - repoint all Insurance Reviews to new company
+44 IF $$IR^IBCNSJ21(DFN,IBCDFN)
Begin DoDot:1
+45 WRITE !!,"Repointing all Insurance Reviews to ",$EXTRACT($PIECE($GET(^DIC(36,IBCNS1,0)),"^"),1,25),"... "
+46 SET IBT=0
FOR
SET IBT=$ORDER(^IBT(356.2,"D",DFN,IBT))
if 'IBT
QUIT
IF $PIECE($GET(^IBT(356.2,IBT,1)),"^",5)=IBCDFN
IF $PIECE($GET(^(0)),"^",8)'=IBCNS1
SET DA=IBT
SET DR=".08////"_IBCNS1
SET DIE="^IBT(356.2,"
DO ^DIE
KILL DA,DR,DIE
WRITE "."
End DoDot:1
+47 ;
+48 SET IBCNS=IBCNS1
SET IBNEWP=$GET(IBNEWP1)
CHPLQ QUIT
+1 ;
PLAN(DFN,IBCDFN,IBCNS) ; Fix policies when identified.
+1 ;
+2 ; This function is invoked from Inactivate Plan or Change Policy Plan,
+3 ; when it is recognized that the policy and plan companies are out
+4 ; of synch. If the user doesn't select a new plan to associate with
+5 ; the policy, the policy company will be changed to the plan company.
+6 ;
+7 ; The input parameters are defined above.
+8 ;
+9 NEW IBNEWP
+10 IF '$GET(DFN)!'$GET(IBCDFN)!'$GET(IBCNS)
GOTO PLANQ
+11 WRITE !!,*7,"The policy company and plan company are not the same!!"
+12 WRITE !,"This inconsistency probably occurred in the past when changing"
+13 WRITE !,"the policy company through Screen 5 of Registration."
+14 WRITE !!,"You must resolve this inconsistency. If you do not choose a new plan"
+15 WRITE !,"offered by the policy company, the policy company will be changed to"
+16 WRITE !,"the plan company (",$PIECE($GET(^DIC(36,IBCNS,0)),"^"),") ...."
+17 DO CHPL
PLANQ QUIT
HLP ; -- help text for subscriber id
+1 WRITE !,?5,"Enter Medicare Claim Number (Subscriber ID) exactly as it"
+2 WRITE !,?5,"appears on the Medicare Insurance Card including All Characters."
+3 WRITE !,?5,"Valid HICN formats are: 1-3 alpha characters followed by 6 or 9 digits, "
+4 WRITE !,?5,"or 9 digits followed by 1 alpha character optionally followed by another "
+5 WRITE !,?5,"alpha character or 1 digit."
+6 QUIT
