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

RCAMINS.m

Go to the documentation of this file.
  1. RCAMINS ;WASH-ISC@ALTOONA,PA/LDB-CHECK FOR INSURANCE COMPANY AS DEBTOR,SECONDARY OR TERTIARY CO ;8/17/95 1:27 PM
  1. V ;;4.5;Accounts Receivable;**6,20,144**;Mar 20, 1995
  1. ;
  1. DEL(INS) ;Delete insurance company check
  1. N DEB,INS1,INSN1,INSN2
  1. I '$G(INS) S INS1="0^NO INSURANCE ENTRY" G DELQ
  1. S INS1=0,DEB=$O(^RCD(340,"B",INS_";DIC(36,",0))
  1. I 'DEB S INS1=0 G DELQ
  1. I $O(^PRCA(430,"C",DEB,0)) S INS1=2
  1. I '$O(^PRCA(430,"C",DEB,0)) S INS1=1
  1. DELQ Q INS1
  1. ;
  1. ;
  1. EN(INS,INS1,INS2,ERROR) ;Repoint any bills with an obsolete insurance co.
  1. Q:'$G(INS)
  1. N ADD,BN,DEB,DIE,DIK,DR,ETYP,MSG,XMSUB
  1. S ERROR=""
  1. K ^TMP("RCAMINS",$J)
  1. S DEB(1)=$O(^RCD(340,"B",INS_";DIC(36,",0))
  1. I 'DEB(1),'$G(INS2) S ERROR="-1^NO AR DEBTOR ENTRY FOR 1ST INSURANCE CO. "_DEB(1) Q
  1. S:'$G(INS1) DEB(2)=""
  1. I $G(INS1),'$G(INS2) S DEB(2)=$O(^RCD(340,"B",INS1_";DIC(36,",0)) I 'DEB(2) D
  1. .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
  1. .S DEB(2)=+Y
  1. I '$G(INS2),DEB(2)=-1 S ERROR="-1^NO AR DEBTOR ENTRY FOR "_INS1 Q
  1. S:$G(INS) INSN1=$P($G(^DIC(36,+INS,0)),"^")
  1. S INSN2=$S($G(INS1):$P($G(^DIC(36,+INS1,0)),"^"),1:"")
  1. S ADD(1)=$$DADD^RCAMADD(INS_";DIC(36,")
  1. S ADD(2)=$S($G(INS1):$$DADD^RCAMADD(INS1_";DIC(36,"),1:"")
  1. I $G(INS1),'$G(INS2) D MRG
  1. I $G(DEB(1)) D EVNT
  1. I $G(DEB(1)),'$O(^PRCA(430,"C",DEB(1),0)) S DA=DEB(1),DIK="^RCD(340," D ^DIK
  1. Q
  1. ;
  1. ;
  1. INS2(ROOT,COUNT) ; Check secondary or tertiary insurance fields
  1. ; Input: ROOT -- Global root for table of carriers to be repointed
  1. ; COUNT -- Passed by reference; # of fields updated
  1. N BN,BN0,P
  1. S (BN,COUNT)=0
  1. F S BN=$O(^PRCA(430,BN)) Q:'BN S BN0=$G(^PRCA(430,+BN,0)) I $G(BN0) D
  1. .F P=19,20 I $P(BN0,"^",P),$D(@ROOT@($P(BN0,"^",P))) D
  1. ..S $P(^PRCA(430,+BN,0),"^",P)=@ROOT@($P(BN0,"^",P))
  1. ..S COUNT=COUNT+1
  1. Q
  1. ;
  1. ATDX ;Fix "ATD" cross-reference
  1. 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)
  1. Q
  1. ;
  1. MRG ;Change debtor on bills
  1. S BN=0 F S BN=$O(^PRCA(430,"C",DEB(1),BN)) Q:'BN I $D(^PRCA(430,+BN,0)) D
  1. .S DA=BN,DIE="^PRCA(430,",DR="9////"_DEB(2) D ^DIE
  1. .I $P($G(^PRCA(430,+BN,0)),"^")]"" S ^TMP("RCAMINS",$J,$P($G(^PRCA(430,+BN,0)),"^"))=""
  1. .D BILL^IBCNSCD1($P($P($G(^PRCA(430,+DA,0)),"^"),"-",2),INS,INS1)
  1. S XMSUB="ACCOUNTS RECEIVABLE INSURANCE CO. MERGE/DELETION"
  1. S ^TMP($J,"MSG",17)="The following bills were affected:"
  1. Q
  1. ;
  1. EVNT ;Change AR EVENTS
  1. F ETYP=1,9 S EDAT=0 F S EDAT=$O(^RC(341,"AD",DEB(1),ETYP,EDAT)) Q:'EDAT D
  1. .S EVNT=0 F S EVNT=$O(^RC(341,"AD",DEB(1),ETYP,EDAT,EVNT)) Q:'EVNT D
  1. ..I DEB(2) S DA=EVNT,DIE="^RC(341,",DR=".05////"_DEB(2) D ^DIE K DA
  1. ..I 'DEB(2) S DA=EVNT,DIK="^RC(341," D ^DIK K DA
  1. K DA,DIE,DR
  1. D MAIL^RCAMINS1
  1. Q