- 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 Mar 13, 2025@21:21:57 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
