source: FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCRCREC2.m@ 1397

RCRCREC2 ;ALB/CMS - RC AND DHCP RECONCILIATION REP LOOP ; 16-JUN-00
V ;;4.5;Accounts Receivable;**61,82,63,147,159**;Mar 20, 1995
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ;Called from RCRCREC to loop through the XTMP(RCXTYP) global
 ;and the ^PRCA(430,"AD" cross-ref and compare the two. The
 ;task execution time is set by the RC RC SERV menu option Server
 ;Action. This job may be killed by IRM but notify the MCCR Referral Cord
 ;
 ;INPUT : RCJOB,RCXTYP,RCVAR,RCSITE,RCXMY
 ;OUTPUT: ^TMP("PRCA",$J,MESSAGE TYPE for each message type
 ;     
 D ARLOOP
 D RCLOOP
END Q
 ;
ARLOOP ;LOOP THROUGH AR CROSS-REF DATE "AD" OF 430
 N RCBN,RCBN0,RCCAT,REF,RFDT
 S RCCAT="" D RCCAT^RCRCUTL(.RCCAT)
 S RFDT=0 F  S RFDT=$O(^PRCA(430,"AD",RFDT)) Q:'RFDT  D RCBN
 Q
RCBN ;GET BN AND CHK FOR BAD CROSS-REF, IF TP SET
 N RCS1,RCS2,RCS3
 S RCBN=0 F  S RCBN=$O(^PRCA(430,"AD",RFDT,RCBN)) Q:'RCBN  D
 .S REF=$P($G(^PRCA(430,RCBN,6)),U,4,6)
 .I REF="" K ^PRCA(430,"AD",RFDT,RCBN) Q
 .I $P(REF,U,1)="",$P(REF,U,3)="" K ^PRCA(430,"AD",RFDT,RCBN) Q
 .I $P(REF,U,1)="",$P(REF,U,3)]"" S $P(^PRCA(430,RCBN,6),U,4)=RFDT S $P(REF,U,1)=RFDT
 .I $P(REF,U,1)'=RFDT S ^PRCA(430,"AD",$P(REF,U,1),RCBN)="" K ^PRCA(430,"AD",RFDT,RCBN)
 .S RCBN0=$G(^PRCA(430,RCBN,0))
 .I $P(RCBN0,U,8)'=16 Q
 .I RCXTYP="PRCADR1",+$P(RCBN0,U,2)'=9 Q
 .S RCS1=$G(RCCAT(+$P(RCBN0,U,2))) I RCS1="" Q
 .I $O(RCDIV(0)),('$D(RCDIV("RCDOMAIN",RCDOMNM,$$DIV^IBJDF2(RCBN0)))) Q
 .S RCS2=$$NAM^RCFN01(+$P(RCBN0,U,9))
 .;
 .S RCS3=$P($G(^DPT(+$P(RCBN0,U,7),0)),U,1)
 .;
 .;
 .S ^TMP("PRCA",$J,$P(RCBN0,U,1),RCBN)=$P(RCBN0,U,1)_U_RCS2_U_$P(REF,U,1)_U_$P(REF,U,2)_U_RCS3_U_$P(REF,U,3)_U_$P($G(^DPT(+$P(RCBN0,U,7),0)),U,9)_U_$P(RCS1,U,2)
 Q
 ;
 ;
RCLOOP ;LOOP THRU THE XTMP GLOBAL SET FROM RC
 ;MR1- Bill referred by medical Center, but not in Regional Counsel
 ;MR2- Regional Counsel has bill but, Medical does not show bill as referred
 ;MR3- Bill in both RC and VAMC but, dollar amount does not agree
 ;MR4- Bill in both RC and VAMC but, a contract/decrease adjustment was made before referred
 ;
 N ERR,I,RCI,RCLN
 S RCI=0 F  S RCI=$O(^XTMP(RCXTYP,RCXMZ,RCI)) Q:'RCI  D
 .S RCLN=^XTMP(RCXTYP,RCXMZ,RCI) K ERR
 .I RCLN["$$RC$" Q
 .I RCLN'["^" Q
 .I $P(RCLN,U,1)="" D MR2 Q
 .I $D(^TMP("PRCA",$J,$P(RCLN,U,1))) D MR34 Q
 .I '$D(^TMP("PRCA",$J,$P(RCLN,U,1))) D MR2
 D MR1
 D SORT^RCRCREC3
 Q
 ;
MR34 ;BILL IS IN BOTH SYSTEMS AS REFERRED
 ;MR3.  SEE IF DOLLAR AMT IS THE SAME 
 ;MR4.  SEE IF DECREASE/CONTRACT DONE BEFORE REFERRED
 N ARLN,ARBAL,BN,CURBAL,MTYP,X S MTYP="MR3" K ERR
 S BN=$O(^TMP("PRCA",$J,$P(RCLN,U,1),0)) G MR34Q:BN=""
 S ARLN=^TMP("PRCA",$J,$P(RCLN,U,1),BN)
 I +$P(ARLN,U,6)'=$P(+$P(RCLN,U,6),".00",1) S ERR("MR3",3)=""
 S ARBAL=$G(^PRCA(430,BN,7)),CURBAL=0
 I ARBAL]"" F X=1:1:5 S CURBAL=CURBAL+$P(ARBAL,U,X)
 I +CURBAL'=+$P(ARLN,U,6) S ERR("MR3",7)=CURBAL
 I $P(RCLN,U,7)]"",$P(ARLN,U,7)'=$P(RCLN,U,7) S ERR("MR3",9)=""
 I $O(ERR("MR3",0)) S MTYP="MR3" G MR34A
 S MTYP="MR4" D L433^RCRCREC3 I $O(ERR("MR4",0)) S RCLN=""
 I '$O(ERR("MR4",0)) G MR34B
MR34A K ERR("MR3",3) D SET^RCRCREC3
MR34B K ^TMP("PRCA",$J,$P(ARLN,U,1)),^XTMP(RCXTYP,RCXMZ,RCI)
MR34Q Q
 ;
MR2 ;MR2 BILL IS AT RC AS REFERRED BUT NOT IN AR AS REFERRED
 N BN,MTYP,REFDT,RCBN0,RFDT S MTYP="MR2"
 I $P(RCLN,U,1)="" S ERR("MR2",1)="" G MR2A
 I '$D(^PRCA(430,"B",$P(RCLN,U,1))) S ERR("MR2",1)="" G MR2A
 S BN=$O(^PRCA(430,"B",$P(RCLN,U,1),0)) S RCBN0=^PRCA(430,BN,0)
 I $P(RCBN0,U,8)'=16 S ERR("MR2",2)=$P($G(^PRCA(430.3,+$P(RCBN0,U,8),0)),"^",1) G MR2A
 I RCXTYP="PRCADR1",$P(RCBN0,U,2)'=9 S ERR("MR2",6)=$P($G(^PRCA(430.2,+$P(RCBN0,U,2),0)),"^",1) G MR2A
 ;I '$G(RCCAT(+$P(RCBN0,U,2))) S ERR("MR2",6)=$P($G(^PRCA(430.2,+$P(RCBN0,U,2),0)),U,1) G MR2A
 S RFDT=$P($G(^PRCA(430,BN,6)),U,4) I RFDT="" S ERR("MR2",5)="" G MR2A
 I '$D(^PRCA(430,"AD",RFDT,BN)) S ^PRCA(430,"AD",RFDT,BN)="" G MR2B
 G MR2B
MR2A D SET^RCRCREC3
MR2B K ^XTMP(RCXTYP,RCXMZ,RCI)
MR2Q Q
 ;
MR1 ;BILLS REFERRED IN AR NOT IN RC
 N ARBAL,BN,CURBAL,ERR,I,MTYP,RCBNAM,REFDT,X
 S RCLN="",RCI="",MTYP="MR1"
 S RCBNAM="" F I=1:1 S RCBNAM=$O(^TMP("PRCA",$J,RCBNAM)) Q:'RCBNAM  D
 .S BN=$O(^TMP("PRCA",$J,RCBNAM,0))
 .I $O(RCDIV(0)),('$D(RCDIV("RCDOMAIN",RCDOMNM,$$DIV^IBJDF2(+BN)))) Q
 .S ARLN=^TMP("PRCA",$J,RCBNAM,BN)
MR1A .D SET^RCRCREC3
 .K ^TMP("PRCA",$J,RCBNAM)
MR1Q Q
 ;
 ;
 ;
 ;
 ;RCRCREC2