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

IBCNSCD1.m

Go to the documentation of this file. 
  1. IBCNSCD1 ;ALB/CPM - DELETE INSURANCE COMPANY (CON'T) ; 02-FEB-95
  1.  ;;2.0;INTEGRATED BILLING;**28,46,80,592**;21-MAR-94;Build 58
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ; 
  1. DQ ; Queued entry point for the final clean-up job.
  1.  ;
  1.  K ^TMP($J,"IBCNSCD")
  1.  L +^IB("IBCNSCD"):5 E  G DDQ ;    another clean-up job got started
  1.  S IBC=0 F  S IBC=$O(^DIC(36,"ADEL",IBC)) Q:'IBC  S ^TMP($J,"IBCNSCD",IBC)=$P($G(^DIC(36,IBC,5)),"^",2)
  1.  I '$D(^TMP($J,"IBCNSCD")) G DDQ ; no companies to be deleted
  1.  ;
  1.  D NOW^%DTC S IBBDT=%
  1.  ;
  1.  ; - dispositions
  1.  S DFN=0 F  S DFN=$O(^DPT(DFN)) Q:'DFN  S IBC=0 F  S IBC=$O(^DPT(DFN,"DIS",IBC)) Q:'IBC  S IBCO=$P($G(^(IBC,2)),"^",6) I IBCO,$D(^TMP($J,"IBCNSCD",IBCO)) D
  1.  .S $P(^DPT(DFN,"DIS",IBC,2),"^",6)=$G(^TMP($J,"IBCNSCD",IBCO))
  1.  .S IBCT("DIS")=$G(IBCT("DIS"))+1
  1.  .I $G(^TMP($J,"IBCNSCD",IBCO))="" S IBCT("DIS",DFN,IBC)=""
  1.  ;
  1.  ; - insurance companies
  1.  S IBC=0 F  S IBC=$O(^DIC(36,IBC)) Q:'IBC  D
  1.  .;JWS;IB*2.0*592;add Dental Ins address
  1.  .;IA# 5292
  1.  .S IB0=$G(^DIC(36,IBC,0)),IB12=$G(^(.12)),IB13=$G(^(.13)),IB14=$G(^(.14)),IB16=$G(^(.16)),IB18=$G(^(.18)),IB19=$G(^(.19))
  1.  .K IBV
  1.  .I $P(IB0,"^",16),$D(^TMP($J,"IBCNSCD",$P(IB0,"^",16))) S IBV(0)="16^"_^($P(IB0,"^",16))
  1.  .I $P(IB12,"^",7),$D(^TMP($J,"IBCNSCD",$P(IB12,"^",7))) S IBV(.12)="7^"_^($P(IB12,"^",7))
  1.  .I $P(IB13,"^",9),$D(^TMP($J,"IBCNSCD",$P(IB13,"^",9))) S IBV(.13)="9^"_^($P(IB13,"^",9))
  1.  .I $P(IB14,"^",7),$D(^TMP($J,"IBCNSCD",$P(IB14,"^",7))) S IBV(.14)="7^"_^($P(IB14,"^",7))
  1.  .I $P(IB16,"^",7),$D(^TMP($J,"IBCNSCD",$P(IB16,"^",7))) S IBV(.16)="7^"_^($P(IB16,"^",7))
  1.  .I $P(IB18,"^",7),$D(^TMP($J,"IBCNSCD",$P(IB18,"^",7))) S IBV(.18)="7^"_^($P(IB18,"^",7))
  1.  .;JWS;IB*2.0*592;add Dental Ins address
  1.  .I $P(IB19,"^",7),$D(^TMP($J,"IBCNSCD",$P(IB19,"^",7))) S IBV(.19)="7^"_^($P(IB19,"^",7))
  1.  .Q:'$D(IBV)
  1.  .;
  1.  .; - delete or repoint
  1.  .S IBX="" F  S IBX=$O(IBV(IBX)) Q:IBX=""  D
  1.  ..S $P(^DIC(36,IBC,IBX),"^",+IBV(IBX))=$P(IBV(IBX),"^",2)
  1.  ..S IBCT("INS",IBX)=$G(IBCT("INS",IBX))+1
  1.  ..I $P(IBV(IBX),"^",2)="" S IBCT("INS",IBX,IBC)=""
  1.  ;
  1.  ; - insurance reviews
  1.  S IBC=0 F  S IBC=$O(^IBT(356.2,IBC)) Q:'IBC  S IBCO=$P($G(^(IBC,0)),"^",8) I IBCO,$D(^TMP($J,"IBCNSCD",IBCO)) S IBCD=$G(^IBT(356.2,IBC,0)) D
  1.  .S IBVAL=$G(^TMP($J,"IBCNSCD",IBCO)) I 'IBVAL S IBVAL="@"
  1.  .S DA=IBC,DR=".08////"_IBVAL,DIE="^IBT(356.2," D ^DIE K DA,DIE,DR
  1.  .S IBCT("IR")=$G(IBCT("IR"))+1
  1.  .I IBVAL="@" S IBCT("IR",+$P(IBCD,"^",5),+IBCD)=""
  1.  ;
  1.  ; - bills
  1.  S IBC=0 F  S IBC=$O(^DGCR(399,IBC)) Q:'IBC  S IBCNS=0 F  S IBCNS=$O(^DGCR(399,IBC,"AIC",IBCNS)) Q:'IBCNS  I $D(^TMP($J,"IBCNSCD",IBCNS)) S (IBREP,IBVAL)=$G(^(IBCNS)) D FIND
  1.  ;
  1.  ; - call AR to handle receivables
  1.  S IBCTAR=0 D INS2^RCAMINS("^TMP($J,""IBCNSCD"")",.IBCTAR)
  1.  ;
  1.  D NOW^%DTC S IBEDT=%
  1.  ;
  1.  ; - mail results
  1.  D MAIL^IBCNSCD2
  1.  ;
  1.  ; - finally, delete the companies
  1.  S IBC=0 F  S IBC=$O(^TMP($J,"IBCNSCD",IBC)) Q:'IBC  S DA=IBC,DIK="^DIC(36,",DIDEL=36 D ^DIK
  1.  ;
  1.  ; - delete task number from #350.9
  1.  S $P(^IBE(350.9,1,4),"^",8)=""
  1.  ;
  1. DDQ K IBC,IBCT,^TMP($J,"IBCNSCD")
  1.  L -^IB("IBCNSCD")
  1.  S ZTREQ="@"
  1.  Q
  1.  ;
  1.  ;
  1. FIND ; Find the carrier somewhere in the bill.
  1.  ;   Required local variables are those described in CARR.
  1.  S IB0=$G(^DGCR(399,IBC,0)),IBM=$G(^("M"))
  1.  ;
  1.  ; - look for the carrier
  1.  I +IBM=IBCNS D CARR(1,"I1") ;            primary
  1.  I $P(IBM,"^",2)=IBCNS D CARR(2,"I2") ;   secondary
  1.  I $P(IBM,"^",3)=IBCNS D CARR(3,"I3") ;   tertiary
  1.  ;
  1.  ; - kill off the x-ref
  1.  K ^DGCR(399,IBC,"AIC",IBCNS)
  1.  Q
  1.  ;
  1. CARR(IBP,IBSUB) ; Update each carrier.
  1.  ;  Input:   IBP  --  carrier [1:primary  2:secondary  3:tertiary]
  1.  ;         IBSUB  --  updated subscript ["I1":prim  "I2":sec  "I3":tert]
  1.  ;
  1.  ;  The following local variables are also required to be defined:
  1.  ;      IBCNS, IB0, IBM, IBC, IBREP, IBVAL
  1.  ;
  1.  S IBCNS1=+IBREP
  1.  S $P(^DGCR(399,IBC,"M"),"^",IBP)=IBVAL
  1.  I $G(^DGCR(399,IBC,IBSUB))]"" S $P(^(IBSUB),"^",1)=IBVAL
  1.  I IBVAL="" D
  1.  .S IBS=0
  1.  .I $P(IB0,"^",2) S IBCNS1=+$G(^DPT($P(IB0,"^",2),.312,+$P(IBM,"^",IBP+11),0)) I IBCNS1 S IBS=1,$P(^DGCR(399,IBC,"M"),"^",IBP)=IBCNS1 S:$G(^(IBSUB))]"" $P(^(IBSUB),"^",1)=IBCNS1
  1.  .I 'IBS S IBCT("BL",IBP,IBC)=""
  1.  ;
  1.  I IBCNS1 S ^DGCR(399,IBC,"AIC",IBCNS1)=""
  1.  ;
  1.  I IBCNS=+$G(^DGCR(399,IBC,"MP")) D
  1.  .I $P(IB0,"^",2),+IBCNS K ^DGCR(399,"AE",$P(IB0,"^",2),IBCNS,IBC)
  1.  .S $P(^DGCR(399,IBC,"MP"),U,1)=IBCNS1
  1.  .I $P(IB0,"^",2),+IBCNS1 S ^DGCR(399,"AE",$P(IB0,"^",2),+IBCNS1,IBC)=""
  1.  ;
  1.  S IBCT("BL",IBP)=$G(IBCT("BL",IBP))+1
  1.  Q
  1.  ;
  1.  ;
  1. BILL(IBBILLN,IBCNS,IBREP) ; Callable Entry Point for Accounts Receivable
  1.  ;  Input:     IBBILLN  --  Bill Number for bill to be repointed
  1.  ;               IBCNS  --  Pointer to the insurance company in file #36
  1.  ;                          that is being merged
  1.  ;               IBREP  --  Pointer to the insurance company in file #36
  1.  ;                          into which information is being merged
  1.  ;
  1.  N IBC,IBCT,IBVAL,IBCNS1,IB0,IBM
  1.  I $G(IBBILLN)=""!'$G(IBCNS)!($G(IBREP)="") G BILLQ
  1.  S IBC=$O(^DGCR(399,"B",IBBILLN,0)) I 'IBC G BILLQ
  1.  S IBVAL=$S(IBREP:IBREP,1:"")
  1.  D FIND
  1. BILLQ Q