| 1 | IBCNSCD ;ALB/CPM - DELETE INSURANCE COMPANY ;01-FEB-95
|
|---|
| 2 | ;;2.0;INTEGRATED BILLING;**28,46,232**;21-MAR-94
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | DEL ; 'Delete Insurance Company' Action
|
|---|
| 6 | ; Required variable input:
|
|---|
| 7 | ; IBCNS -- Pointer to the company in file #36
|
|---|
| 8 | ;
|
|---|
| 9 | N I,IBC,IBDAT,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
|
|---|
| 10 | S VALMBCK="R" D FULL^VALM1
|
|---|
| 11 | I '$G(IBCNS) G DELQ
|
|---|
| 12 | S IBCNSD=$G(^DIC(36,IBCNS,0))
|
|---|
| 13 | I IBCNSD="" W !!,"This Insurance Company does not exist!",! G DELQ
|
|---|
| 14 | I '$D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ)) D SORRY^IBTRE1 G DELQ
|
|---|
| 15 | I '$P(IBCNSD,"^",5) D G DELQ
|
|---|
| 16 | .W !!,"This Insurance Company is still active! You must use the"
|
|---|
| 17 | .W !,"'Inactivate Company' action to inactivate this company before"
|
|---|
| 18 | .W !,"you can delete it."
|
|---|
| 19 | I $D(^DPT("AB",IBCNS)) D G DELQ
|
|---|
| 20 | .W !!,"There are still patient policies with this company! These policies"
|
|---|
| 21 | .W !,"must be deleted or re-pointed to another company before you can"
|
|---|
| 22 | .W !,"delete the company."
|
|---|
| 23 | I $D(^IBA(355.3,"B",IBCNS)) D G DELQ
|
|---|
| 24 | .W !!,"There are still Insurance Plans on file with this company! These plans"
|
|---|
| 25 | .W !,"must be deleted or re-pointed to another company before you can"
|
|---|
| 26 | .W !,"delete the company."
|
|---|
| 27 | I $O(^IBA(355.9,"AE",IBCNS,""))!$O(^IBA(355.91,"AC",IBCNS,"")) D G DELQ
|
|---|
| 28 | .W !!,"There are still provider ids defined for this company! These ids must"
|
|---|
| 29 | .W !,"be deleted before you can delete this company."
|
|---|
| 30 | I $O(^IBA(355.96,"AC",IBCNS,""))!$O(^IBA(355.95,"C",IBCNS,"")) D G DELQ
|
|---|
| 31 | .W !!,"There are still provider id care units defined for this company! These"
|
|---|
| 32 | .W !,"care unit entries must be deleted before you can delete this company."
|
|---|
| 33 | I $O(^IBA(355.92,"B",IBCNS,"")) D G DELQ
|
|---|
| 34 | .W !!,"There are still facility ids defined for this company! These ids must be"
|
|---|
| 35 | .W !,"deleted before you can delete this company."
|
|---|
| 36 | ;
|
|---|
| 37 | ; - explain functionality
|
|---|
| 38 | D INTRO^IBCNSCD3 S DIR(0)="E" W ! D ^DIR K DIR I $D(DIRUT)!$D(DUOUT) G DELQ1
|
|---|
| 39 | ;
|
|---|
| 40 | ; - need to merge data into another company?
|
|---|
| 41 | D MERGE^IBCNSCD3 I IBQUIT G DELQ
|
|---|
| 42 | ;
|
|---|
| 43 | ; - provide a warning message
|
|---|
| 44 | D WARN^IBCNSCD3
|
|---|
| 45 | ;
|
|---|
| 46 | ; - okay to proceed?
|
|---|
| 47 | S DIR(0)="Y",DIR("A")="Is it okay to "_$S(IBREP:"merge",1:"delete")_" this company"_$S(IBREP:" information into the other",1:""),DIR("?")="^D HLP^IBCNSCD3"
|
|---|
| 48 | W ! D ^DIR K DIR I 'Y W !!,"The company was not deleted." G DELQ
|
|---|
| 49 | ;
|
|---|
| 50 | ; - merge Insurance Reviews
|
|---|
| 51 | I IBCALLIR,$D(^IBT(356.2,"AIACT",IBCNS)) D
|
|---|
| 52 | .W !!," >> Merging known Insurance Reviews into ",IBREPN,"... "
|
|---|
| 53 | .S IBC=0 F S IBC=$O(^IBT(356.2,"AIACT",IBCNS,IBC)) Q:'IBC D
|
|---|
| 54 | ..S IBX=0 F S IBX=$O(^IBT(356.2,"AIACT",IBCNS,IBC,IBX)) Q:'IBX S DA=IBX,DIE="^IBT(356.2,",DR=".08////"_IBREP D ^DIE K DA,DIE,DR
|
|---|
| 55 | .W "done."
|
|---|
| 56 | ;
|
|---|
| 57 | ; - merge bills/receivables
|
|---|
| 58 | I IBCALLAR W !!," >> Merging known bills and receivables into ",IBREPN,"... ",!
|
|---|
| 59 | S IBERR="" D EN^RCAMINS(IBCNS,$S(+$G(IBREP):IBREP,1:""),'IBCALLAR,.IBERR)
|
|---|
| 60 | I IBCALLAR W !?5,$S(IBERR<0:"AR Error: "_$P(IBERR,"^",2),1:"All done.")
|
|---|
| 61 | ;
|
|---|
| 62 | ; - flag company for deletion
|
|---|
| 63 | W !!," >> Flagging ",$P(IBCNSD,"^")," for deletion... "
|
|---|
| 64 | S DA=IBCNS,DIE="^DIC(36,",DR="5.01////1;5.02////"_$S($G(IBREP):IBREP,1:"@")
|
|---|
| 65 | D ^DIE K DA,DIE,DR W "done."
|
|---|
| 66 | ;
|
|---|
| 67 | ; - queue the final clean up job
|
|---|
| 68 | W !!," >> Queuing the final clean-up job... "
|
|---|
| 69 | S IBTASK=$$ALR I IBTASK W !?5,"This job is already queued as task number ",IBTASK,"." G DELC
|
|---|
| 70 | S IBDAT=$S($P($H,",",2)<25200:$H,$P($H,",",2)>82800:$H,1:+$H_",82800")
|
|---|
| 71 | S ZTRTN="DQ^IBCNSCD1",ZTDTH=IBDAT,ZTIO="",ZTDESC="IB - INSURANCE COMPANY DELETION"
|
|---|
| 72 | S IBCNSN=$P(IBCNSD,"^") F I="IBCNS","IBREP","IBCNSN" S ZTSAVE(I)=""
|
|---|
| 73 | D ^%ZTLOAD
|
|---|
| 74 | W !?5,$S($D(ZTSK):"The job has been queued to run "_$S($P($H,",",2)<$P(IBDAT,",",2):"at 11:00pm",1:"now")_". The task number is "_ZTSK_".",1:"Unable to queue this job. Please contact your IRM Service.")
|
|---|
| 75 | I $D(ZTSK)#2 S $P(^IBE(350.9,1,4),"^",8)=ZTSK
|
|---|
| 76 | ;
|
|---|
| 77 | DELC S VALMBCK="Q"
|
|---|
| 78 | ;
|
|---|
| 79 | DELQ D PAUSE^VALM1
|
|---|
| 80 | DELQ1 K IBCNSD,IBCNSN,IBREP,IBREPN,IBIP,IBBU,IBAB,IBMRGN,IBMRGF,IBX,IBTASK
|
|---|
| 81 | K DIRUT,DUOUT,DTOUT,DIROUT,ZTSK,IBQUIT,IBCALLAR,IBCALLIR,IBERR
|
|---|
| 82 | Q
|
|---|
| 83 | ;
|
|---|
| 84 | ALR() ; Has the background clean-up job already been queued?
|
|---|
| 85 | ; Input: None
|
|---|
| 86 | ; Output: 0 -- Job hasn't been queued
|
|---|
| 87 | ; >0 -- Task # of queued job
|
|---|
| 88 | N ZTSK
|
|---|
| 89 | S ZTSK=+$P($G(^IBE(350.9,1,4)),"^",8) I 'ZTSK G ALRQ
|
|---|
| 90 | D ISQED^%ZTLOAD I 'ZTSK(0) S ZTSK=0
|
|---|
| 91 | ALRQ Q ZTSK
|
|---|
