- 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 Jan 18, 2025@03:18:13 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