IBCNSCD1 ;ALB/CPM - DELETE INSURANCE COMPANY (CON'T) ; 02-FEB-95
;;2.0;INTEGRATED BILLING;**28,46,80,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
;
DQ ; Queued entry point for the final clean-up job.
;
K ^TMP($J,"IBCNSCD")
L +^IB("IBCNSCD"):5 E G DDQ ; another clean-up job got started
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)
I '$D(^TMP($J,"IBCNSCD")) G DDQ ; no companies to be deleted
;
D NOW^%DTC S IBBDT=%
;
; - dispositions
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
.S $P(^DPT(DFN,"DIS",IBC,2),"^",6)=$G(^TMP($J,"IBCNSCD",IBCO))
.S IBCT("DIS")=$G(IBCT("DIS"))+1
.I $G(^TMP($J,"IBCNSCD",IBCO))="" S IBCT("DIS",DFN,IBC)=""
;
; - insurance companies
S IBC=0 F S IBC=$O(^DIC(36,IBC)) Q:'IBC D
.;JWS;IB*2.0*592;add Dental Ins address
.;IA# 5292
.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))
.K IBV
.I $P(IB0,"^",16),$D(^TMP($J,"IBCNSCD",$P(IB0,"^",16))) S IBV(0)="16^"_^($P(IB0,"^",16))
.I $P(IB12,"^",7),$D(^TMP($J,"IBCNSCD",$P(IB12,"^",7))) S IBV(.12)="7^"_^($P(IB12,"^",7))
.I $P(IB13,"^",9),$D(^TMP($J,"IBCNSCD",$P(IB13,"^",9))) S IBV(.13)="9^"_^($P(IB13,"^",9))
.I $P(IB14,"^",7),$D(^TMP($J,"IBCNSCD",$P(IB14,"^",7))) S IBV(.14)="7^"_^($P(IB14,"^",7))
.I $P(IB16,"^",7),$D(^TMP($J,"IBCNSCD",$P(IB16,"^",7))) S IBV(.16)="7^"_^($P(IB16,"^",7))
.I $P(IB18,"^",7),$D(^TMP($J,"IBCNSCD",$P(IB18,"^",7))) S IBV(.18)="7^"_^($P(IB18,"^",7))
.;JWS;IB*2.0*592;add Dental Ins address
.I $P(IB19,"^",7),$D(^TMP($J,"IBCNSCD",$P(IB19,"^",7))) S IBV(.19)="7^"_^($P(IB19,"^",7))
.Q:'$D(IBV)
.;
.; - delete or repoint
.S IBX="" F S IBX=$O(IBV(IBX)) Q:IBX="" D
..S $P(^DIC(36,IBC,IBX),"^",+IBV(IBX))=$P(IBV(IBX),"^",2)
..S IBCT("INS",IBX)=$G(IBCT("INS",IBX))+1
..I $P(IBV(IBX),"^",2)="" S IBCT("INS",IBX,IBC)=""
;
; - insurance reviews
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
.S IBVAL=$G(^TMP($J,"IBCNSCD",IBCO)) I 'IBVAL S IBVAL="@"
.S DA=IBC,DR=".08////"_IBVAL,DIE="^IBT(356.2," D ^DIE K DA,DIE,DR
.S IBCT("IR")=$G(IBCT("IR"))+1
.I IBVAL="@" S IBCT("IR",+$P(IBCD,"^",5),+IBCD)=""
;
; - bills
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
;
; - call AR to handle receivables
S IBCTAR=0 D INS2^RCAMINS("^TMP($J,""IBCNSCD"")",.IBCTAR)
;
D NOW^%DTC S IBEDT=%
;
; - mail results
D MAIL^IBCNSCD2
;
; - finally, delete the companies
S IBC=0 F S IBC=$O(^TMP($J,"IBCNSCD",IBC)) Q:'IBC S DA=IBC,DIK="^DIC(36,",DIDEL=36 D ^DIK
;
; - delete task number from #350.9
S $P(^IBE(350.9,1,4),"^",8)=""
;
DDQ K IBC,IBCT,^TMP($J,"IBCNSCD")
L -^IB("IBCNSCD")
S ZTREQ="@"
Q
;
;
FIND ; Find the carrier somewhere in the bill.
; Required local variables are those described in CARR.
S IB0=$G(^DGCR(399,IBC,0)),IBM=$G(^("M"))
;
; - look for the carrier
I +IBM=IBCNS D CARR(1,"I1") ; primary
I $P(IBM,"^",2)=IBCNS D CARR(2,"I2") ; secondary
I $P(IBM,"^",3)=IBCNS D CARR(3,"I3") ; tertiary
;
; - kill off the x-ref
K ^DGCR(399,IBC,"AIC",IBCNS)
Q
;
CARR(IBP,IBSUB) ; Update each carrier.
; Input: IBP -- carrier [1:primary 2:secondary 3:tertiary]
; IBSUB -- updated subscript ["I1":prim "I2":sec "I3":tert]
;
; The following local variables are also required to be defined:
; IBCNS, IB0, IBM, IBC, IBREP, IBVAL
;
S IBCNS1=+IBREP
S $P(^DGCR(399,IBC,"M"),"^",IBP)=IBVAL
I $G(^DGCR(399,IBC,IBSUB))]"" S $P(^(IBSUB),"^",1)=IBVAL
I IBVAL="" D
.S IBS=0
.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
.I 'IBS S IBCT("BL",IBP,IBC)=""
;
I IBCNS1 S ^DGCR(399,IBC,"AIC",IBCNS1)=""
;
I IBCNS=+$G(^DGCR(399,IBC,"MP")) D
.I $P(IB0,"^",2),+IBCNS K ^DGCR(399,"AE",$P(IB0,"^",2),IBCNS,IBC)
.S $P(^DGCR(399,IBC,"MP"),U,1)=IBCNS1
.I $P(IB0,"^",2),+IBCNS1 S ^DGCR(399,"AE",$P(IB0,"^",2),+IBCNS1,IBC)=""
;
S IBCT("BL",IBP)=$G(IBCT("BL",IBP))+1
Q
;
;
BILL(IBBILLN,IBCNS,IBREP) ; Callable Entry Point for Accounts Receivable
; Input: IBBILLN -- Bill Number for bill to be repointed
; IBCNS -- Pointer to the insurance company in file #36
; that is being merged
; IBREP -- Pointer to the insurance company in file #36
; into which information is being merged
;
N IBC,IBCT,IBVAL,IBCNS1,IB0,IBM
I $G(IBBILLN)=""!'$G(IBCNS)!($G(IBREP)="") G BILLQ
S IBC=$O(^DGCR(399,"B",IBBILLN,0)) I 'IBC G BILLQ
S IBVAL=$S(IBREP:IBREP,1:"")
D FIND
BILLQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSCD1 5107 printed Oct 16, 2024@18:17:42 Page 2
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
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
DQ ; Queued entry point for the final clean-up job.
+1 ;
+2 KILL ^TMP($JOB,"IBCNSCD")
+3 ; another clean-up job got started
LOCK +^IB("IBCNSCD"):5
IF '$TEST
GOTO DDQ
+4 SET IBC=0
FOR
SET IBC=$ORDER(^DIC(36,"ADEL",IBC))
if 'IBC
QUIT
SET ^TMP($JOB,"IBCNSCD",IBC)=$PIECE($GET(^DIC(36,IBC,5)),"^",2)
+5 ; no companies to be deleted
IF '$DATA(^TMP($JOB,"IBCNSCD"))
GOTO DDQ
+6 ;
+7 DO NOW^%DTC
SET IBBDT=%
+8 ;
+9 ; - dispositions
+10 SET DFN=0
FOR
SET DFN=$ORDER(^DPT(DFN))
if 'DFN
QUIT
SET IBC=0
FOR
SET IBC=$ORDER(^DPT(DFN,"DIS",IBC))
if 'IBC
QUIT
SET IBCO=$PIECE($GET(^(IBC,2)),"^",6)
IF IBCO
IF $DATA(^TMP($JOB,"IBCNSCD",IBCO))
Begin DoDot:1
+11 SET $PIECE(^DPT(DFN,"DIS",IBC,2),"^",6)=$GET(^TMP($JOB,"IBCNSCD",IBCO))
+12 SET IBCT("DIS")=$GET(IBCT("DIS"))+1
+13 IF $GET(^TMP($JOB,"IBCNSCD",IBCO))=""
SET IBCT("DIS",DFN,IBC)=""
End DoDot:1
+14 ;
+15 ; - insurance companies
+16 SET IBC=0
FOR
SET IBC=$ORDER(^DIC(36,IBC))
if 'IBC
QUIT
Begin DoDot:1
+17 ;JWS;IB*2.0*592;add Dental Ins address
+18 ;IA# 5292
+19 SET IB0=$GET(^DIC(36,IBC,0))
SET IB12=$GET(^(.12))
SET IB13=$GET(^(.13))
SET IB14=$GET(^(.14))
SET IB16=$GET(^(.16))
SET IB18=$GET(^(.18))
SET IB19=$GET(^(.19))
+20 KILL IBV
+21 IF $PIECE(IB0,"^",16)
IF $DATA(^TMP($JOB,"IBCNSCD",$PIECE(IB0,"^",16)))
SET IBV(0)="16^"_^($PIECE(IB0,"^",16))
+22 IF $PIECE(IB12,"^",7)
IF $DATA(^TMP($JOB,"IBCNSCD",$PIECE(IB12,"^",7)))
SET IBV(.12)="7^"_^($PIECE(IB12,"^",7))
+23 IF $PIECE(IB13,"^",9)
IF $DATA(^TMP($JOB,"IBCNSCD",$PIECE(IB13,"^",9)))
SET IBV(.13)="9^"_^($PIECE(IB13,"^",9))
+24 IF $PIECE(IB14,"^",7)
IF $DATA(^TMP($JOB,"IBCNSCD",$PIECE(IB14,"^",7)))
SET IBV(.14)="7^"_^($PIECE(IB14,"^",7))
+25 IF $PIECE(IB16,"^",7)
IF $DATA(^TMP($JOB,"IBCNSCD",$PIECE(IB16,"^",7)))
SET IBV(.16)="7^"_^($PIECE(IB16,"^",7))
+26 IF $PIECE(IB18,"^",7)
IF $DATA(^TMP($JOB,"IBCNSCD",$PIECE(IB18,"^",7)))
SET IBV(.18)="7^"_^($PIECE(IB18,"^",7))
+27 ;JWS;IB*2.0*592;add Dental Ins address
+28 IF $PIECE(IB19,"^",7)
IF $DATA(^TMP($JOB,"IBCNSCD",$PIECE(IB19,"^",7)))
SET IBV(.19)="7^"_^($PIECE(IB19,"^",7))
+29 if '$DATA(IBV)
QUIT
+30 ;
+31 ; - delete or repoint
+32 SET IBX=""
FOR
SET IBX=$ORDER(IBV(IBX))
if IBX=""
QUIT
Begin DoDot:2
+33 SET $PIECE(^DIC(36,IBC,IBX),"^",+IBV(IBX))=$PIECE(IBV(IBX),"^",2)
+34 SET IBCT("INS",IBX)=$GET(IBCT("INS",IBX))+1
+35 IF $PIECE(IBV(IBX),"^",2)=""
SET IBCT("INS",IBX,IBC)=""
End DoDot:2
End DoDot:1
+36 ;
+37 ; - insurance reviews
+38 SET IBC=0
FOR
SET IBC=$ORDER(^IBT(356.2,IBC))
if 'IBC
QUIT
SET IBCO=$PIECE($GET(^(IBC,0)),"^",8)
IF IBCO
IF $DATA(^TMP($JOB,"IBCNSCD",IBCO))
SET IBCD=$GET(^IBT(356.2,IBC,0))
Begin DoDot:1
+39 SET IBVAL=$GET(^TMP($JOB,"IBCNSCD",IBCO))
IF 'IBVAL
SET IBVAL="@"
+40 SET DA=IBC
SET DR=".08////"_IBVAL
SET DIE="^IBT(356.2,"
DO ^DIE
KILL DA,DIE,DR
+41 SET IBCT("IR")=$GET(IBCT("IR"))+1
+42 IF IBVAL="@"
SET IBCT("IR",+$PIECE(IBCD,"^",5),+IBCD)=""
End DoDot:1
+43 ;
+44 ; - bills
+45 SET IBC=0
FOR
SET IBC=$ORDER(^DGCR(399,IBC))
if 'IBC
QUIT
SET IBCNS=0
FOR
SET IBCNS=$ORDER(^DGCR(399,IBC,"AIC",IBCNS))
if 'IBCNS
QUIT
IF $DATA(^TMP($JOB,"IBCNSCD",IBCNS))
SET (IBREP,IBVAL)=$GET(^(IBCNS))
DO FIND
+46 ;
+47 ; - call AR to handle receivables
+48 SET IBCTAR=0
DO INS2^RCAMINS("^TMP($J,""IBCNSCD"")",.IBCTAR)
+49 ;
+50 DO NOW^%DTC
SET IBEDT=%
+51 ;
+52 ; - mail results
+53 DO MAIL^IBCNSCD2
+54 ;
+55 ; - finally, delete the companies
+56 SET IBC=0
FOR
SET IBC=$ORDER(^TMP($JOB,"IBCNSCD",IBC))
if 'IBC
QUIT
SET DA=IBC
SET DIK="^DIC(36,"
SET DIDEL=36
DO ^DIK
+57 ;
+58 ; - delete task number from #350.9
+59 SET $PIECE(^IBE(350.9,1,4),"^",8)=""
+60 ;
DDQ KILL IBC,IBCT,^TMP($JOB,"IBCNSCD")
+1 LOCK -^IB("IBCNSCD")
+2 SET ZTREQ="@"
+3 QUIT
+4 ;
+5 ;
FIND ; Find the carrier somewhere in the bill.
+1 ; Required local variables are those described in CARR.
+2 SET IB0=$GET(^DGCR(399,IBC,0))
SET IBM=$GET(^("M"))
+3 ;
+4 ; - look for the carrier
+5 ; primary
IF +IBM=IBCNS
DO CARR(1,"I1")
+6 ; secondary
IF $PIECE(IBM,"^",2)=IBCNS
DO CARR(2,"I2")
+7 ; tertiary
IF $PIECE(IBM,"^",3)=IBCNS
DO CARR(3,"I3")
+8 ;
+9 ; - kill off the x-ref
+10 KILL ^DGCR(399,IBC,"AIC",IBCNS)
+11 QUIT
+12 ;
CARR(IBP,IBSUB) ; Update each carrier.
+1 ; Input: IBP -- carrier [1:primary 2:secondary 3:tertiary]
+2 ; IBSUB -- updated subscript ["I1":prim "I2":sec "I3":tert]
+3 ;
+4 ; The following local variables are also required to be defined:
+5 ; IBCNS, IB0, IBM, IBC, IBREP, IBVAL
+6 ;
+7 SET IBCNS1=+IBREP
+8 SET $PIECE(^DGCR(399,IBC,"M"),"^",IBP)=IBVAL
+9 IF $GET(^DGCR(399,IBC,IBSUB))]""
SET $PIECE(^(IBSUB),"^",1)=IBVAL
+10 IF IBVAL=""
Begin DoDot:1
+11 SET IBS=0
+12 IF $PIECE(IB0,"^",2)
SET IBCNS1=+$GET(^DPT($PIECE(IB0,"^",2),.312,+$PIECE(IBM,"^",IBP+11),0))
IF IBCNS1
SET IBS=1
SET $PIECE(^DGCR(399,IBC,"M"),"^",IBP)=IBCNS1
if $GET(^(IBSUB))]""
SET $PIECE(^(IBSUB),"^",1)=IBCNS1
+13 IF 'IBS
SET IBCT("BL",IBP,IBC)=""
End DoDot:1
+14 ;
+15 IF IBCNS1
SET ^DGCR(399,IBC,"AIC",IBCNS1)=""
+16 ;
+17 IF IBCNS=+$GET(^DGCR(399,IBC,"MP"))
Begin DoDot:1
+18 IF $PIECE(IB0,"^",2)
IF +IBCNS
KILL ^DGCR(399,"AE",$PIECE(IB0,"^",2),IBCNS,IBC)
+19 SET $PIECE(^DGCR(399,IBC,"MP"),U,1)=IBCNS1
+20 IF $PIECE(IB0,"^",2)
IF +IBCNS1
SET ^DGCR(399,"AE",$PIECE(IB0,"^",2),+IBCNS1,IBC)=""
End DoDot:1
+21 ;
+22 SET IBCT("BL",IBP)=$GET(IBCT("BL",IBP))+1
+23 QUIT
+24 ;
+25 ;
BILL(IBBILLN,IBCNS,IBREP) ; Callable Entry Point for Accounts Receivable
+1 ; Input: IBBILLN -- Bill Number for bill to be repointed
+2 ; IBCNS -- Pointer to the insurance company in file #36
+3 ; that is being merged
+4 ; IBREP -- Pointer to the insurance company in file #36
+5 ; into which information is being merged
+6 ;
+7 NEW IBC,IBCT,IBVAL,IBCNS1,IB0,IBM
+8 IF $GET(IBBILLN)=""!'$GET(IBCNS)!($GET(IBREP)="")
GOTO BILLQ
+9 SET IBC=$ORDER(^DGCR(399,"B",IBBILLN,0))
IF 'IBC
GOTO BILLQ
+10 SET IBVAL=$SELECT(IBREP:IBREP,1:"")
+11 DO FIND
BILLQ QUIT
