RCAMINS ;WASH-ISC@ALTOONA,PA/LDB-CHECK FOR INSURANCE COMPANY AS DEBTOR,SECONDARY OR TERTIARY CO ;8/17/95 1:27 PM
V ;;4.5;Accounts Receivable;**6,20,144**;Mar 20, 1995
;
DEL(INS) ;Delete insurance company check
N DEB,INS1,INSN1,INSN2
I '$G(INS) S INS1="0^NO INSURANCE ENTRY" G DELQ
S INS1=0,DEB=$O(^RCD(340,"B",INS_";DIC(36,",0))
I 'DEB S INS1=0 G DELQ
I $O(^PRCA(430,"C",DEB,0)) S INS1=2
I '$O(^PRCA(430,"C",DEB,0)) S INS1=1
DELQ Q INS1
;
;
EN(INS,INS1,INS2,ERROR) ;Repoint any bills with an obsolete insurance co.
Q:'$G(INS)
N ADD,BN,DEB,DIE,DIK,DR,ETYP,MSG,XMSUB
S ERROR=""
K ^TMP("RCAMINS",$J)
S DEB(1)=$O(^RCD(340,"B",INS_";DIC(36,",0))
I 'DEB(1),'$G(INS2) S ERROR="-1^NO AR DEBTOR ENTRY FOR 1ST INSURANCE CO. "_DEB(1) Q
S:'$G(INS1) DEB(2)=""
I $G(INS1),'$G(INS2) S DEB(2)=$O(^RCD(340,"B",INS1_";DIC(36,",0)) I 'DEB(2) D
.K DD,DO S DIC="^RCD(340,",DIC(0)="QL",X=INS1_";DIC(36,",DLAYG0=340 D FILE^DICN K DIC,DD,DLAYGO,DO,X
.S DEB(2)=+Y
I '$G(INS2),DEB(2)=-1 S ERROR="-1^NO AR DEBTOR ENTRY FOR "_INS1 Q
S:$G(INS) INSN1=$P($G(^DIC(36,+INS,0)),"^")
S INSN2=$S($G(INS1):$P($G(^DIC(36,+INS1,0)),"^"),1:"")
S ADD(1)=$$DADD^RCAMADD(INS_";DIC(36,")
S ADD(2)=$S($G(INS1):$$DADD^RCAMADD(INS1_";DIC(36,"),1:"")
I $G(INS1),'$G(INS2) D MRG
I $G(DEB(1)) D EVNT
I $G(DEB(1)),'$O(^PRCA(430,"C",DEB(1),0)) S DA=DEB(1),DIK="^RCD(340," D ^DIK
Q
;
;
INS2(ROOT,COUNT) ; Check secondary or tertiary insurance fields
; Input: ROOT -- Global root for table of carriers to be repointed
; COUNT -- Passed by reference; # of fields updated
N BN,BN0,P
S (BN,COUNT)=0
F S BN=$O(^PRCA(430,BN)) Q:'BN S BN0=$G(^PRCA(430,+BN,0)) I $G(BN0) D
.F P=19,20 I $P(BN0,"^",P),$D(@ROOT@($P(BN0,"^",P))) D
..S $P(^PRCA(430,+BN,0),"^",P)=@ROOT@($P(BN0,"^",P))
..S COUNT=COUNT+1
Q
;
ATDX ;Fix "ATD" cross-reference
S X=0 F S X=$O(^RCD(340,X)) Q:'X I $D(^RCD(340,+X,0)),(^(0)'["DPT"),$D(^PRCA(433,"ATD",X)) K ^PRCA(433,"ATD",X)
Q
;
MRG ;Change debtor on bills
S BN=0 F S BN=$O(^PRCA(430,"C",DEB(1),BN)) Q:'BN I $D(^PRCA(430,+BN,0)) D
.S DA=BN,DIE="^PRCA(430,",DR="9////"_DEB(2) D ^DIE
.I $P($G(^PRCA(430,+BN,0)),"^")]"" S ^TMP("RCAMINS",$J,$P($G(^PRCA(430,+BN,0)),"^"))=""
.D BILL^IBCNSCD1($P($P($G(^PRCA(430,+DA,0)),"^"),"-",2),INS,INS1)
S XMSUB="ACCOUNTS RECEIVABLE INSURANCE CO. MERGE/DELETION"
S ^TMP($J,"MSG",17)="The following bills were affected:"
Q
;
EVNT ;Change AR EVENTS
F ETYP=1,9 S EDAT=0 F S EDAT=$O(^RC(341,"AD",DEB(1),ETYP,EDAT)) Q:'EDAT D
.S EVNT=0 F S EVNT=$O(^RC(341,"AD",DEB(1),ETYP,EDAT,EVNT)) Q:'EVNT D
..I DEB(2) S DA=EVNT,DIE="^RC(341,",DR=".05////"_DEB(2) D ^DIE K DA
..I 'DEB(2) S DA=EVNT,DIK="^RC(341," D ^DIK K DA
K DA,DIE,DR
D MAIL^RCAMINS1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCAMINS 2783 printed Oct 16, 2024@17:43:19 Page 2
RCAMINS ;WASH-ISC@ALTOONA,PA/LDB-CHECK FOR INSURANCE COMPANY AS DEBTOR,SECONDARY OR TERTIARY CO ;8/17/95 1:27 PM
V ;;4.5;Accounts Receivable;**6,20,144**;Mar 20, 1995
+1 ;
DEL(INS) ;Delete insurance company check
+1 NEW DEB,INS1,INSN1,INSN2
+2 IF '$GET(INS)
SET INS1="0^NO INSURANCE ENTRY"
GOTO DELQ
+3 SET INS1=0
SET DEB=$ORDER(^RCD(340,"B",INS_";DIC(36,",0))
+4 IF 'DEB
SET INS1=0
GOTO DELQ
+5 IF $ORDER(^PRCA(430,"C",DEB,0))
SET INS1=2
+6 IF '$ORDER(^PRCA(430,"C",DEB,0))
SET INS1=1
DELQ QUIT INS1
+1 ;
+2 ;
EN(INS,INS1,INS2,ERROR) ;Repoint any bills with an obsolete insurance co.
+1 if '$GET(INS)
QUIT
+2 NEW ADD,BN,DEB,DIE,DIK,DR,ETYP,MSG,XMSUB
+3 SET ERROR=""
+4 KILL ^TMP("RCAMINS",$JOB)
+5 SET DEB(1)=$ORDER(^RCD(340,"B",INS_";DIC(36,",0))
+6 IF 'DEB(1)
IF '$GET(INS2)
SET ERROR="-1^NO AR DEBTOR ENTRY FOR 1ST INSURANCE CO. "_DEB(1)
QUIT
+7 if '$GET(INS1)
SET DEB(2)=""
+8 IF $GET(INS1)
IF '$GET(INS2)
SET DEB(2)=$ORDER(^RCD(340,"B",INS1_";DIC(36,",0))
IF 'DEB(2)
Begin DoDot:1
+9 KILL DD,DO
SET DIC="^RCD(340,"
SET DIC(0)="QL"
SET X=INS1_";DIC(36,"
SET DLAYG0=340
DO FILE^DICN
KILL DIC,DD,DLAYGO,DO,X
+10 SET DEB(2)=+Y
End DoDot:1
+11 IF '$GET(INS2)
IF DEB(2)=-1
SET ERROR="-1^NO AR DEBTOR ENTRY FOR "_INS1
QUIT
+12 if $GET(INS)
SET INSN1=$PIECE($GET(^DIC(36,+INS,0)),"^")
+13 SET INSN2=$SELECT($GET(INS1):$PIECE($GET(^DIC(36,+INS1,0)),"^"),1:"")
+14 SET ADD(1)=$$DADD^RCAMADD(INS_";DIC(36,")
+15 SET ADD(2)=$SELECT($GET(INS1):$$DADD^RCAMADD(INS1_";DIC(36,"),1:"")
+16 IF $GET(INS1)
IF '$GET(INS2)
DO MRG
+17 IF $GET(DEB(1))
DO EVNT
+18 IF $GET(DEB(1))
IF '$ORDER(^PRCA(430,"C",DEB(1),0))
SET DA=DEB(1)
SET DIK="^RCD(340,"
DO ^DIK
+19 QUIT
+20 ;
+21 ;
INS2(ROOT,COUNT) ; Check secondary or tertiary insurance fields
+1 ; Input: ROOT -- Global root for table of carriers to be repointed
+2 ; COUNT -- Passed by reference; # of fields updated
+3 NEW BN,BN0,P
+4 SET (BN,COUNT)=0
+5 FOR
SET BN=$ORDER(^PRCA(430,BN))
if 'BN
QUIT
SET BN0=$GET(^PRCA(430,+BN,0))
IF $GET(BN0)
Begin DoDot:1
+6 FOR P=19,20
IF $PIECE(BN0,"^",P)
IF $DATA(@ROOT@($PIECE(BN0,"^",P)))
Begin DoDot:2
+7 SET $PIECE(^PRCA(430,+BN,0),"^",P)=@ROOT@($PIECE(BN0,"^",P))
+8 SET COUNT=COUNT+1
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
ATDX ;Fix "ATD" cross-reference
+1 SET X=0
FOR
SET X=$ORDER(^RCD(340,X))
if 'X
QUIT
IF $DATA(^RCD(340,+X,0))
IF (^(0)'["DPT")
IF $DATA(^PRCA(433,"ATD",X))
KILL ^PRCA(433,"ATD",X)
+2 QUIT
+3 ;
MRG ;Change debtor on bills
+1 SET BN=0
FOR
SET BN=$ORDER(^PRCA(430,"C",DEB(1),BN))
if 'BN
QUIT
IF $DATA(^PRCA(430,+BN,0))
Begin DoDot:1
+2 SET DA=BN
SET DIE="^PRCA(430,"
SET DR="9////"_DEB(2)
DO ^DIE
+3 IF $PIECE($GET(^PRCA(430,+BN,0)),"^")]""
SET ^TMP("RCAMINS",$JOB,$PIECE($GET(^PRCA(430,+BN,0)),"^"))=""
+4 DO BILL^IBCNSCD1($PIECE($PIECE($GET(^PRCA(430,+DA,0)),"^"),"-",2),INS,INS1)
End DoDot:1
+5 SET XMSUB="ACCOUNTS RECEIVABLE INSURANCE CO. MERGE/DELETION"
+6 SET ^TMP($JOB,"MSG",17)="The following bills were affected:"
+7 QUIT
+8 ;
EVNT ;Change AR EVENTS
+1 FOR ETYP=1,9
SET EDAT=0
FOR
SET EDAT=$ORDER(^RC(341,"AD",DEB(1),ETYP,EDAT))
if 'EDAT
QUIT
Begin DoDot:1
+2 SET EVNT=0
FOR
SET EVNT=$ORDER(^RC(341,"AD",DEB(1),ETYP,EDAT,EVNT))
if 'EVNT
QUIT
Begin DoDot:2
+3 IF DEB(2)
SET DA=EVNT
SET DIE="^RC(341,"
SET DR=".05////"_DEB(2)
DO ^DIE
KILL DA
+4 IF 'DEB(2)
SET DA=EVNT
SET DIK="^RC(341,"
DO ^DIK
KILL DA
End DoDot:2
End DoDot:1
+5 KILL DA,DIE,DR
+6 DO MAIL^RCAMINS1
+7 QUIT
