- 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 Feb 18, 2025@23:43:53 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