source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSCD.m@ 1397

Last change on this file since 1397 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.1 KB
Line 
1IBCNSCD ;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 ;
5DEL ; '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 ;
77DELC S VALMBCK="Q"
78 ;
79DELQ D PAUSE^VALM1
80DELQ1 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 ;
84ALR() ; 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
91ALRQ Q ZTSK
Note: See TracBrowser for help on using the repository browser.