Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCNSCD

IBCNSCD.m

Go to the documentation of this file.
  1. IBCNSCD ;ALB/CPM - DELETE INSURANCE COMPANY ;01-FEB-95
  1. ;;2.0;INTEGRATED BILLING;**28,46,232**;21-MAR-94
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. DEL ; 'Delete Insurance Company' Action
  1. ; Required variable input:
  1. ; IBCNS -- Pointer to the company in file #36
  1. ;
  1. N I,IBC,IBDAT,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
  1. S VALMBCK="R" D FULL^VALM1
  1. I '$G(IBCNS) G DELQ
  1. S IBCNSD=$G(^DIC(36,IBCNS,0))
  1. I IBCNSD="" W !!,"This Insurance Company does not exist!",! G DELQ
  1. I '$D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ)) D SORRY^IBTRE1 G DELQ
  1. I '$P(IBCNSD,"^",5) D G DELQ
  1. .W !!,"This Insurance Company is still active! You must use the"
  1. .W !,"'Inactivate Company' action to inactivate this company before"
  1. .W !,"you can delete it."
  1. I $D(^DPT("AB",IBCNS)) D G DELQ
  1. .W !!,"There are still patient policies with this company! These policies"
  1. .W !,"must be deleted or re-pointed to another company before you can"
  1. .W !,"delete the company."
  1. I $D(^IBA(355.3,"B",IBCNS)) D G DELQ
  1. .W !!,"There are still Insurance Plans on file with this company! These plans"
  1. .W !,"must be deleted or re-pointed to another company before you can"
  1. .W !,"delete the company."
  1. I $O(^IBA(355.9,"AE",IBCNS,""))!$O(^IBA(355.91,"AC",IBCNS,"")) D G DELQ
  1. .W !!,"There are still provider ids defined for this company! These ids must"
  1. .W !,"be deleted before you can delete this company."
  1. I $O(^IBA(355.96,"AC",IBCNS,""))!$O(^IBA(355.95,"C",IBCNS,"")) D G DELQ
  1. .W !!,"There are still provider id care units defined for this company! These"
  1. .W !,"care unit entries must be deleted before you can delete this company."
  1. I $O(^IBA(355.92,"B",IBCNS,"")) D G DELQ
  1. .W !!,"There are still facility ids defined for this company! These ids must be"
  1. .W !,"deleted before you can delete this company."
  1. ;
  1. ; - explain functionality
  1. D INTRO^IBCNSCD3 S DIR(0)="E" W ! D ^DIR K DIR I $D(DIRUT)!$D(DUOUT) G DELQ1
  1. ;
  1. ; - need to merge data into another company?
  1. D MERGE^IBCNSCD3 I IBQUIT G DELQ
  1. ;
  1. ; - provide a warning message
  1. D WARN^IBCNSCD3
  1. ;
  1. ; - okay to proceed?
  1. 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"
  1. W ! D ^DIR K DIR I 'Y W !!,"The company was not deleted." G DELQ
  1. ;
  1. ; - merge Insurance Reviews
  1. I IBCALLIR,$D(^IBT(356.2,"AIACT",IBCNS)) D
  1. .W !!," >> Merging known Insurance Reviews into ",IBREPN,"... "
  1. .S IBC=0 F S IBC=$O(^IBT(356.2,"AIACT",IBCNS,IBC)) Q:'IBC D
  1. ..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
  1. .W "done."
  1. ;
  1. ; - merge bills/receivables
  1. I IBCALLAR W !!," >> Merging known bills and receivables into ",IBREPN,"... ",!
  1. S IBERR="" D EN^RCAMINS(IBCNS,$S(+$G(IBREP):IBREP,1:""),'IBCALLAR,.IBERR)
  1. I IBCALLAR W !?5,$S(IBERR<0:"AR Error: "_$P(IBERR,"^",2),1:"All done.")
  1. ;
  1. ; - flag company for deletion
  1. W !!," >> Flagging ",$P(IBCNSD,"^")," for deletion... "
  1. S DA=IBCNS,DIE="^DIC(36,",DR="5.01////1;5.02////"_$S($G(IBREP):IBREP,1:"@")
  1. D ^DIE K DA,DIE,DR W "done."
  1. ;
  1. ; - queue the final clean up job
  1. W !!," >> Queuing the final clean-up job... "
  1. S IBTASK=$$ALR I IBTASK W !?5,"This job is already queued as task number ",IBTASK,"." G DELC
  1. S IBDAT=$S($P($H,",",2)<25200:$H,$P($H,",",2)>82800:$H,1:+$H_",82800")
  1. S ZTRTN="DQ^IBCNSCD1",ZTDTH=IBDAT,ZTIO="",ZTDESC="IB - INSURANCE COMPANY DELETION"
  1. S IBCNSN=$P(IBCNSD,"^") F I="IBCNS","IBREP","IBCNSN" S ZTSAVE(I)=""
  1. D ^%ZTLOAD
  1. 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.")
  1. I $D(ZTSK)#2 S $P(^IBE(350.9,1,4),"^",8)=ZTSK
  1. ;
  1. DELC S VALMBCK="Q"
  1. ;
  1. DELQ D PAUSE^VALM1
  1. DELQ1 K IBCNSD,IBCNSN,IBREP,IBREPN,IBIP,IBBU,IBAB,IBMRGN,IBMRGF,IBX,IBTASK
  1. K DIRUT,DUOUT,DTOUT,DIROUT,ZTSK,IBQUIT,IBCALLAR,IBCALLIR,IBERR
  1. Q
  1. ;
  1. ALR() ; Has the background clean-up job already been queued?
  1. ; Input: None
  1. ; Output: 0 -- Job hasn't been queued
  1. ; >0 -- Task # of queued job
  1. N ZTSK
  1. S ZTSK=+$P($G(^IBE(350.9,1,4)),"^",8) I 'ZTSK G ALRQ
  1. D ISQED^%ZTLOAD I 'ZTSK(0) S ZTSK=0
  1. ALRQ Q ZTSK