IBCNSC3 ;ALB/NLR - INACTIVATE AND REPOINT INS STUFF1 ; 20-APR-93
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
RPTASK ; -- ask if user wishes to repoint patients to active insurance company
;
N IBR
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 G:'Y!$D(DIRUT) R3Q
W !
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" D ^DIC K DIC G:$D(DIRUT) R3Q
Q:+Y<1
S IBR=+Y D SAVE
;
REPOINT ; -- get parameters for call to DIE
;
S DFN=0 F S DFN=$O(^DPT("AB",IBCNS,DFN)) Q:'DFN!('IBR) D RPT1
Q
RPT1 ;
S IBD=0 F S IBD=$O(^DPT("AB",IBCNS,DFN,IBD)) Q:'IBD D CALLDIE D RPT2
Q
RPT2 ;
S IBN=0 F S IBN=$O(^IBA(355.3,"B",IBCNS,IBN)) Q:'IBN S DA=IBN D CALLDIE1
;
R3Q Q
;
VERIFY ; -- allow user to change mind about inactivating company
;
W !
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."
D ^DIR K DIR I $D(DIRUT) S IBQUIT=1
S:Y IBV=1
Q
;
HDR ; -- print header
;
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)
W !?1,"PATIENT",?31,"PATIENT ID",?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)),X=$$PT^IBEFUNC(DFN),IBNA=$P(X,U,1),IBNO=$P(X,U,2) S:IBNA="" IBNA="<Pt. "_DFN_" Name Missing>" Q:'DFN S IBD=0 F S IBD=$O(^DPT("AB",IBCNS,DFN,IBD)) Q:'IBD D
.S IBIND=$G(^DPT(DFN,.312,IBD,0))
.;S IBIND2=$G(^DPT(DFN,.312,IBD,2))
.I IBCNS'=$P(+IBIND,U) Q ;bad x-ref,maybe later take action
.D SET
Q
;
CALLDIE ; -- get name of active insurance co., repoint patients to same
;
;S DIE="^DPT(DFN,.312,",DA(1)=DFN,DA=IBD,DR=".01////"_$G(IBR) D ^DIE K DIE
S DIE="^DPT(DFN,.312,",DA(1)=DFN,DA=IBD,DR=".01///`"_$G(IBR) D ^DIE K DIE
Q
CALLDIE1 ; -- stuff .01 field of 355.3 with newly-assigned ins. co.
;
;S DIE="^IBA(355.3,",DA=IBN,DR=".01////"_$G(IBR) D ^DIE K DIE
S DIE="^IBA(355.3,",DA=IBN,DR=".01///`"_$G(IBR) D ^DIE K DIE
Q
;
SET ; -- store data to be printed in temp array
;
; ^tmp($j,"ibcnsc2",patient name,dfn,ien of policy) =
; patient id^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 EMPLOYER=VAOA(9)
S ^TMP($J,"IBCNSC2",IBNA,DFN,IBD)=IBNO_"^"_$P(IBIND,"^",8)_U_$P(IBIND,"^",4)_"^"_$P(IBIND,"^",2)_"^"_IBWI_"^"_EMPLOYER
Q
;
SAVE ; -- save off field repointed too
N DA,DR,DIC,DIE
Q:'$G(IBR)
S DA=IBCNS,DR=".16////"_IBR,DIE="^DIC(36," D ^DIE
Q
IBCNSC3 ;ALB/NLR - INACTIVATE AND REPOINT INS STUFF1 ; 20-APR-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
RPTASK ; -- ask if user wishes to repoint patients to active insurance company
+1 ;
+2 NEW IBR
+3 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"
+4 WRITE !
+5 DO ^DIR
KILL DIR
IF 'Y!$DATA(DIRUT)
GOTO R3Q
+6 WRITE !
+7 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"
DO ^DIC
KILL DIC
IF $DATA(DIRUT)
GOTO R3Q
+8 IF +Y<1
QUIT
+9 SET IBR=+Y
DO SAVE
+10 ;
REPOINT ; -- get parameters for call to DIE
+1 ;
+2 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("AB",IBCNS,DFN))
IF 'DFN!('IBR)
QUIT
DO RPT1
+3 QUIT
RPT1 ;
+1 SET IBD=0
FOR
SET IBD=$ORDER(^DPT("AB",IBCNS,DFN,IBD))
IF 'IBD
QUIT
DO CALLDIE
DO RPT2
+2 QUIT
RPT2 ;
+1 SET IBN=0
FOR
SET IBN=$ORDER(^IBA(355.3,"B",IBCNS,IBN))
IF 'IBN
QUIT
SET DA=IBN
DO CALLDIE1
+2 ;
R3Q QUIT
+1 ;
VERIFY ; -- allow user to change mind about inactivating company
+1 ;
+2 WRITE !
+3 SET DIR("B")="No"
SET DIR(0)="YO"
SET DIR("A")="ARE YOU REALLY SURE YOU WISH TO INACTIVATE "_IBN
+4 SET DIR("?",1)="You are about to change "_IBN_" to inactive."
+5 SET DIR("?",2)="This means you will no longer be able to bill "
+6 SET DIR("?")=""_IBN_" for its patients' charges."
+7 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET IBQUIT=1
+8 IF Y
SET IBV=1
+9 QUIT
+10 ;
HDR ; -- print header
+1 ;
+2 IF $EXTRACT(IOST,1,2)["C-"!($GET(IBPAG))
WRITE @IOF
+3 SET IBPAG=$GET(IBPAG)+1
+4 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)
+5 WRITE !?1,"PATIENT",?31,"PATIENT ID",?52,"EFF DATE",?63,"EXP DATE",?74,"SUBSCR ID",?95,"WHOSE INS",?106,"EMPLOYER",!
+6 WRITE $TRANSLATE($JUSTIFY(" ",IOM)," ","-")
+7 QUIT
+8 ;
BUILD ; -- set list of patients in ^tmp array
+1 ;
+2 KILL ^TMP($JOB,"IBCNSC2")
+3 SET DFN=0
+4 FOR
SET DFN=$ORDER(^DPT("AB",IBCNS,DFN))
SET X=$$PT^IBEFUNC(DFN)
SET IBNA=$PIECE(X,U,1)
SET IBNO=$PIECE(X,U,2)
IF IBNA=""
SET IBNA="<Pt. "_DFN_" Name Missing>"
IF 'DFN
QUIT
SET IBD=0
FOR
SET IBD=$ORDER(^DPT("AB",IBCNS,DFN,IBD))
IF 'IBD
QUIT
Begin DoDot:1
+5 SET IBIND=$GET(^DPT(DFN,.312,IBD,0))
+6 ;S IBIND2=$G(^DPT(DFN,.312,IBD,2))
+7 ;bad x-ref,maybe later take action
IF IBCNS'=$PIECE(+IBIND,U)
QUIT
+8 DO SET
End DoDot:1
+9 QUIT
+10 ;
CALLDIE ; -- get name of active insurance co., repoint patients to same
+1 ;
+2 ;S DIE="^DPT(DFN,.312,",DA(1)=DFN,DA=IBD,DR=".01////"_$G(IBR) D ^DIE K DIE
+3 SET DIE="^DPT(DFN,.312,"
SET DA(1)=DFN
SET DA=IBD
SET DR=".01///`"_$GET(IBR)
DO ^DIE
KILL DIE
+4 QUIT
CALLDIE1 ; -- stuff .01 field of 355.3 with newly-assigned ins. co.
+1 ;
+2 ;S DIE="^IBA(355.3,",DA=IBN,DR=".01////"_$G(IBR) D ^DIE K DIE
+3 SET DIE="^IBA(355.3,"
SET DA=IBN
SET DR=".01///`"_$GET(IBR)
DO ^DIE
KILL DIE
+4 QUIT
+5 ;
SET ; -- store data to be printed in temp array
+1 ;
+2 ; ^tmp($j,"ibcnsc2",patient name,dfn,ien of policy) =
+3 ; patient id^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 EMPLOYER=VAOA(9)
+9 SET ^TMP($JOB,"IBCNSC2",IBNA,DFN,IBD)=IBNO_"^"_$PIECE(IBIND,"^",8)_U_$PIECE(IBIND,"^",4)_"^"_$PIECE(IBIND,"^",2)_"^"_IBWI_"^"_EMPLOYER
+10 QUIT
+11 ;
SAVE ; -- save off field repointed too
+1 NEW DA,DR,DIC,DIE
+2 IF '$GET(IBR)
QUIT
+3 SET DA=IBCNS
SET DR=".16////"_IBR
SET DIE="^DIC(36,"
DO ^DIE
+4 QUIT
