- 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 Feb 18, 2025@23:08:51 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