IBCNSC3 ;ALB/NLR - INACTIVATE AND REPOINT INS STUFF1 ; 20-APR-93
;;2.0;INTEGRATED BILLING;**28,46,68,516**;21-MAR-94;Build 123
;;Per VA Directive 6402, this routine should not be modified.
;
RPTASK ; -- ask if user wishes to repoint patients to active insurance company
;
S DIR(0)="YO",DIR("A")="DO YOU WISH TO REPOINT "_$S(IBC=1:"THIS PATIENT",1:"THESE PATIENTS")_" TO ANOTHER INSURANCE COMPANY",DIR("B")="No"
W ! D ^DIR K DIR I 'Y!$D(DIRUT) D:$G(IBCOV) COVD G RPTASKQ
;
; - select company to which policies/plans should be repointed
S DIC="^DIC(36,",DIC(0)="QEAZ",DIC("A")="REPOINT "_$S(IBC=1:"THIS PATIENT",1:"THESE PATIENTS")_" TO WHICH (ACTIVE) INSURANCE COMPANY: ",DIC("S")="I +$P(^(0),U,5)=0,+$P(^(0),U,16)'=Y,$G(IBCNS)'=Y",DIC("W")="D ID^IBCNSCD3"
W ! D ^DIC K DIC S IBR=+Y I Y<1!$D(DIRUT) D:$G(IBCOV) COVD G RPTASKQ
;
; - save the new company in the inactivated company
S DA=IBCNS,DR=".16////"_IBR,DIE="^DIC(36," D ^DIE K DIE,DA,DR
;
; - repoint patient policy information
S DFN=0 F S DFN=$O(^DPT("AB",IBCNS,DFN)) Q:'DFN D
.S IBD=0 F S IBD=$O(^DPT("AB",IBCNS,DFN,IBD)) Q:'IBD D
..;
..; - repoint the policy to the new company
..S IBXXX='$G(^DPT(DFN,.312,IBD,1))
..S DIE="^DPT(DFN,.312,",DA(1)=DFN,DA=IBD,DR=".01///`"_IBR_";1.05///NOW;1.06////"_DUZ D ^DIE K DIE,DA,DR
..I IBXXX S $P(^DPT(DFN,.312,IBD,1),"^",1,2)="^"
..;
..; - repoint Insurance Reviews to the new company
..S IBX=0 F S IBX=$O(^IBT(356.2,"D",DFN,IBX)) Q:'IBX I $P($G(^IBT(356.2,IBX,1)),"^",5)=IBD S DIE="^IBT(356.2,",DA=IBX,DR=".08////"_IBR D ^DIE K DIE,DA,DR
.;
.; - adjust 'Covered by Insurance' prompt
.D COV^IBCNSJ(DFN)
;
; - repoint all plans
S IBD=0 F S IBD=$O(^IBA(355.3,"B",IBCNS,IBD)) Q:'IBD D
.S DIE="^IBA(355.3,",DA=IBD,DR=".01///`"_IBR D ^DIE K DIE,DA,DR
;
RPTASKQ K DIRUT,DTOUT,DUOUT,DIROUT,DFN,IBD,IBR,IBX,IBXXX
Q
;
COVD ; Adjust 'Covered by Insurance' prompt for repointed patients
S DFN=0 F S DFN=$O(^DPT("AB",IBCNS,DFN)) Q:'DFN D COV^IBCNSJ(DFN)
Q
;
;
;
VERIFY ; -- allow user to change mind about inactivating company
;
S DIR("B")="No",DIR(0)="YO",DIR("A")="ARE YOU REALLY SURE YOU WISH TO INACTIVATE "_IBN
S DIR("?",1)="You are about to change "_IBN_" to inactive."
S DIR("?",2)="This means you will no longer be able to bill "
S DIR("?")=IBN_" for its patients' charges."
W ! D ^DIR K DIR I $D(DIRUT) S IBQUIT=1
S:Y IBV=1
Q
;
HDR ; -- print header
;
N X,TAB
W:$E(IOST,1,2)["C-"!($G(IBPAG)) @IOF
S IBPAG=$G(IBPAG)+1
W !,?1,"PATIENTS WITH "_$S(+IBV=0:"ACTIVE",+IBV=1:"INACTIVATED")_" INSURANCE, "_$P(^DIC(36,IBCNS,0),U),?69,"PAGE ",IBPAG,?77,$$DAT1^IBOUTL(DT)
;
; - display Insurance Company name and address.
S X=$G(^DIC(36,+IBCNS,.11)),TAB=$S('IBV:33,1:38)
W:$P(X,"^")]"" !?TAB,$P(X,"^")
W:$P(X,"^",2)]"" !?TAB,$P(X,"^",2)
W:$P(X,"^",3)]"" !?TAB,$P(X,"^",3)
W:$P(X,"^")]""!($P(X,"^",2)]"")!($P(X,"^",3)]"") !?TAB
W $P(X,"^",4) W:$P(X,"^",4)]""&($P(X,"^",5)]"") ", "
W $P($G(^DIC(5,+$P(X,"^",5),0)),"^")
W:$P(X,"^",6)]""&($P(X,"^",4)]""!($P(X,"^",5)]"")) " "
W $E($P(X,"^",6),1,5),$S($E($P(X,"^",6),6,9)]"":"-"_$E($P(X,"^",6),6,9),1:"")
;
W !?1,"PATIENT",?31,"PATIENT ID",?45,"IR?",?52,"EFF DATE",?63,"EXP DATE",?74,"SUBSCR ID",?95,"WHOSE INS",?106,"EMPLOYER",!
W $TR($J(" ",IOM)," ","-")
Q
;
BUILD ; -- set list of patients in ^tmp array
;
K ^TMP($J,"IBCNSC2")
S DFN=0 F S DFN=$O(^DPT("AB",IBCNS,DFN)) Q:'DFN D
.D COV^IBCNSJ(DFN)
.S X=$$PT^IBEFUNC(DFN),IBNA=$P(X,U,1),IBNO=$P(X,U,2)
.S:IBNA="" IBNA="<Pt. "_DFN_" Name Missing>"
.S IBD=0 F S IBD=$O(^DPT("AB",IBCNS,DFN,IBD)) Q:'IBD D
..;S IBIND=$G(^DPT(DFN,.312,IBD,0)) ;516 - baa
..S IBIND=$$ZND^IBCNS1(DFN,IBD) ;516 - baa
..I IBCNS'=$P(+IBIND,U) Q ;bad x-ref,maybe later take action
..D SET
Q
;
SET ; -- store data to be printed in temp array
;
; ^tmp($j,"ibcnsc2",patient name,dfn,ien of policy) =
; patient id^IR?^effective date^expiration date^subscriber id^whose insurance^employer
;
S IBWI=$P(IBIND,"^",6)
S VAOA("A")=$S(IBWI="v":5,IBWI="s":6,1:5)
D OAD^VADPT
S ^TMP($J,"IBCNSC2",IBNA,DFN,IBD)=IBNO_"^"_$S($$IR^IBCNSJ21(DFN,IBD):"Y",1:"N")_"^"_$P(IBIND,"^",8)_U_$P(IBIND,"^",4)_"^"_$P(IBIND,"^",2)_"^"_IBWI_"^"_VAOA(9)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSC3 4285 printed Sep 23, 2025@19:53:12 Page 2
IBCNSC3 ;ALB/NLR - INACTIVATE AND REPOINT INS STUFF1 ; 20-APR-93
+1 ;;2.0;INTEGRATED BILLING;**28,46,68,516**;21-MAR-94;Build 123
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
RPTASK ; -- ask if user wishes to repoint patients to active insurance company
+1 ;
+2 SET DIR(0)="YO"
SET DIR("A")="DO YOU WISH TO REPOINT "_$SELECT(IBC=1:"THIS PATIENT",1:"THESE PATIENTS")_" TO ANOTHER INSURANCE COMPANY"
SET DIR("B")="No"
+3 WRITE !
DO ^DIR
KILL DIR
IF 'Y!$DATA(DIRUT)
if $GET(IBCOV)
DO COVD
GOTO RPTASKQ
+4 ;
+5 ; - select company to which policies/plans should be repointed
+6 SET DIC="^DIC(36,"
SET DIC(0)="QEAZ"
SET DIC("A")="REPOINT "_$SELECT(IBC=1:"THIS PATIENT",1:"THESE PATIENTS")_" TO WHICH (ACTIVE) INSURANCE COMPANY: "
SET DIC("S")="I +$P(^(0),U,5)=0,+$P(^(0),U,16)'=Y,$G(IBCNS)'=Y"
SET DIC("W")="D ID^IBCNSCD3"
+7 WRITE !
DO ^DIC
KILL DIC
SET IBR=+Y
IF Y<1!$DATA(DIRUT)
if $GET(IBCOV)
DO COVD
GOTO RPTASKQ
+8 ;
+9 ; - save the new company in the inactivated company
+10 SET DA=IBCNS
SET DR=".16////"_IBR
SET DIE="^DIC(36,"
DO ^DIE
KILL DIE,DA,DR
+11 ;
+12 ; - repoint patient policy information
+13 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("AB",IBCNS,DFN))
if 'DFN
QUIT
Begin DoDot:1
+14 SET IBD=0
FOR
SET IBD=$ORDER(^DPT("AB",IBCNS,DFN,IBD))
if 'IBD
QUIT
Begin DoDot:2
+15 ;
+16 ; - repoint the policy to the new company
+17 SET IBXXX='$GET(^DPT(DFN,.312,IBD,1))
+18 SET DIE="^DPT(DFN,.312,"
SET DA(1)=DFN
SET DA=IBD
SET DR=".01///`"_IBR_";1.05///NOW;1.06////"_DUZ
DO ^DIE
KILL DIE,DA,DR
+19 IF IBXXX
SET $PIECE(^DPT(DFN,.312,IBD,1),"^",1,2)="^"
+20 ;
+21 ; - repoint Insurance Reviews to the new company
+22 SET IBX=0
FOR
SET IBX=$ORDER(^IBT(356.2,"D",DFN,IBX))
if 'IBX
QUIT
IF $PIECE($GET(^IBT(356.2,IBX,1)),"^",5)=IBD
SET DIE="^IBT(356.2,"
SET DA=IBX
SET DR=".08////"_IBR
DO ^DIE
KILL DIE,DA,DR
End DoDot:2
+23 ;
+24 ; - adjust 'Covered by Insurance' prompt
+25 DO COV^IBCNSJ(DFN)
End DoDot:1
+26 ;
+27 ; - repoint all plans
+28 SET IBD=0
FOR
SET IBD=$ORDER(^IBA(355.3,"B",IBCNS,IBD))
if 'IBD
QUIT
Begin DoDot:1
+29 SET DIE="^IBA(355.3,"
SET DA=IBD
SET DR=".01///`"_IBR
DO ^DIE
KILL DIE,DA,DR
End DoDot:1
+30 ;
RPTASKQ KILL DIRUT,DTOUT,DUOUT,DIROUT,DFN,IBD,IBR,IBX,IBXXX
+1 QUIT
+2 ;
COVD ; Adjust 'Covered by Insurance' prompt for repointed patients
+1 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("AB",IBCNS,DFN))
if 'DFN
QUIT
DO COV^IBCNSJ(DFN)
+2 QUIT
+3 ;
+4 ;
+5 ;
VERIFY ; -- allow user to change mind about inactivating company
+1 ;
+2 SET DIR("B")="No"
SET DIR(0)="YO"
SET DIR("A")="ARE YOU REALLY SURE YOU WISH TO INACTIVATE "_IBN
+3 SET DIR("?",1)="You are about to change "_IBN_" to inactive."
+4 SET DIR("?",2)="This means you will no longer be able to bill "
+5 SET DIR("?")=IBN_" for its patients' charges."
+6 WRITE !
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET IBQUIT=1
+7 if Y
SET IBV=1
+8 QUIT
+9 ;
HDR ; -- print header
+1 ;
+2 NEW X,TAB
+3 if $EXTRACT(IOST,1,2)["C-"!($GET(IBPAG))
WRITE @IOF
+4 SET IBPAG=$GET(IBPAG)+1
+5 WRITE !,?1,"PATIENTS WITH "_$SELECT(+IBV=0:"ACTIVE",+IBV=1:"INACTIVATED")_" INSURANCE, "_$PIECE(^DIC(36,IBCNS,0),U),?69,"PAGE ",IBPAG,?77,$$DAT1^IBOUTL(DT)
+6 ;
+7 ; - display Insurance Company name and address.
+8 SET X=$GET(^DIC(36,+IBCNS,.11))
SET TAB=$SELECT('IBV:33,1:38)
+9 if $PIECE(X,"^")]""
WRITE !?TAB,$PIECE(X,"^")
+10 if $PIECE(X,"^",2)]""
WRITE !?TAB,$PIECE(X,"^",2)
+11 if $PIECE(X,"^",3)]""
WRITE !?TAB,$PIECE(X,"^",3)
+12 if $PIECE(X,"^")]""!($PIECE(X,"^",2)]"")!($PIECE(X,"^",3)]"")
WRITE !?TAB
+13 WRITE $PIECE(X,"^",4)
if $PIECE(X,"^",4)]""&($PIECE(X,"^",5)]"")
WRITE ", "
+14 WRITE $PIECE($GET(^DIC(5,+$PIECE(X,"^",5),0)),"^")
+15 if $PIECE(X,"^",6)]""&($PIECE(X,"^",4)]""!($PIECE(X,"^",5)]""))
WRITE " "
+16 WRITE $EXTRACT($PIECE(X,"^",6),1,5),$SELECT($EXTRACT($PIECE(X,"^",6),6,9)]"":"-"_$EXTRACT($PIECE(X,"^",6),6,9),1:"")
+17 ;
+18 WRITE !?1,"PATIENT",?31,"PATIENT ID",?45,"IR?",?52,"EFF DATE",?63,"EXP DATE",?74,"SUBSCR ID",?95,"WHOSE INS",?106,"EMPLOYER",!
+19 WRITE $TRANSLATE($JUSTIFY(" ",IOM)," ","-")
+20 QUIT
+21 ;
BUILD ; -- set list of patients in ^tmp array
+1 ;
+2 KILL ^TMP($JOB,"IBCNSC2")
+3 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("AB",IBCNS,DFN))
if 'DFN
QUIT
Begin DoDot:1
+4 DO COV^IBCNSJ(DFN)
+5 SET X=$$PT^IBEFUNC(DFN)
SET IBNA=$PIECE(X,U,1)
SET IBNO=$PIECE(X,U,2)
+6 if IBNA=""
SET IBNA="<Pt. "_DFN_" Name Missing>"
+7 SET IBD=0
FOR
SET IBD=$ORDER(^DPT("AB",IBCNS,DFN,IBD))
if 'IBD
QUIT
Begin DoDot:2
+8 ;S IBIND=$G(^DPT(DFN,.312,IBD,0)) ;516 - baa
+9 ;516 - baa
SET IBIND=$$ZND^IBCNS1(DFN,IBD)
+10 ;bad x-ref,maybe later take action
IF IBCNS'=$PIECE(+IBIND,U)
QUIT
+11 DO SET
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
SET ; -- store data to be printed in temp array
+1 ;
+2 ; ^tmp($j,"ibcnsc2",patient name,dfn,ien of policy) =
+3 ; patient id^IR?^effective date^expiration date^subscriber id^whose insurance^employer
+4 ;
+5 SET IBWI=$PIECE(IBIND,"^",6)
+6 SET VAOA("A")=$SELECT(IBWI="v":5,IBWI="s":6,1:5)
+7 DO OAD^VADPT
+8 SET ^TMP($JOB,"IBCNSC2",IBNA,DFN,IBD)=IBNO_"^"_$SELECT($$IR^IBCNSJ21(DFN,IBD):"Y",1:"N")_"^"_$PIECE(IBIND,"^",8)_U_$PIECE(IBIND,"^",4)_"^"_$PIECE(IBIND,"^",2)_"^"_IBWI_"^"_VAOA(9)
+9 QUIT
