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