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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCRCREC2 4416 printed Nov 22, 2024@16:57:55 Page 2
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
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
+3 ;Called from RCRCREC to loop through the XTMP(RCXTYP) global
+4 ;and the ^PRCA(430,"AD" cross-ref and compare the two. The
+5 ;task execution time is set by the RC RC SERV menu option Server
+6 ;Action. This job may be killed by IRM but notify the MCCR Referral Cord
+7 ;
+8 ;INPUT : RCJOB,RCXTYP,RCVAR,RCSITE,RCXMY
+9 ;OUTPUT: ^TMP("PRCA",$J,MESSAGE TYPE for each message type
+10 ;
+11 DO ARLOOP
+12 DO RCLOOP
END QUIT
+1 ;
ARLOOP ;LOOP THROUGH AR CROSS-REF DATE "AD" OF 430
+1 NEW RCBN,RCBN0,RCCAT,REF,RFDT
+2 SET RCCAT=""
DO RCCAT^RCRCUTL(.RCCAT)
+3 SET RFDT=0
FOR
SET RFDT=$ORDER(^PRCA(430,"AD",RFDT))
if 'RFDT
QUIT
DO RCBN
+4 QUIT
RCBN ;GET BN AND CHK FOR BAD CROSS-REF, IF TP SET
+1 NEW RCS1,RCS2,RCS3
+2 SET RCBN=0
FOR
SET RCBN=$ORDER(^PRCA(430,"AD",RFDT,RCBN))
if 'RCBN
QUIT
Begin DoDot:1
+3 SET REF=$PIECE($GET(^PRCA(430,RCBN,6)),U,4,6)
+4 IF REF=""
KILL ^PRCA(430,"AD",RFDT,RCBN)
QUIT
+5 IF $PIECE(REF,U,1)=""
IF $PIECE(REF,U,3)=""
KILL ^PRCA(430,"AD",RFDT,RCBN)
QUIT
+6 IF $PIECE(REF,U,1)=""
IF $PIECE(REF,U,3)]""
SET $PIECE(^PRCA(430,RCBN,6),U,4)=RFDT
SET $PIECE(REF,U,1)=RFDT
+7 IF $PIECE(REF,U,1)'=RFDT
SET ^PRCA(430,"AD",$PIECE(REF,U,1),RCBN)=""
KILL ^PRCA(430,"AD",RFDT,RCBN)
+8 SET RCBN0=$GET(^PRCA(430,RCBN,0))
+9 IF $PIECE(RCBN0,U,8)'=16
QUIT
+10 IF RCXTYP="PRCADR1"
IF +$PIECE(RCBN0,U,2)'=9
QUIT
+11 SET RCS1=$GET(RCCAT(+$PIECE(RCBN0,U,2)))
IF RCS1=""
QUIT
+12 IF $ORDER(RCDIV(0))
IF ('$DATA(RCDIV("RCDOMAIN",RCDOMNM,$$DIV^IBJDF2(RCBN0))))
QUIT
+13 SET RCS2=$$NAM^RCFN01(+$PIECE(RCBN0,U,9))
+14 ;
+15 SET RCS3=$PIECE($GET(^DPT(+$PIECE(RCBN0,U,7),0)),U,1)
+16 ;
+17 ;
+18 SET ^TMP("PRCA",$JOB,$PIECE(RCBN0,U,1),RCBN)=$PIECE(RCBN0,U,1)_U_RCS2_U_$PIECE(REF,U,1)_U_$PIECE(REF,U,2)_U_RCS3_U_$PIECE(REF,U,3)_U_$PIECE($GET(^DPT(+$PIECE(RCBN0,U,7),0)),U,9)_U_$PIECE(RCS1,U,2)
End DoDot:1
+19 QUIT
+20 ;
+21 ;
RCLOOP ;LOOP THRU THE XTMP GLOBAL SET FROM RC
+1 ;MR1- Bill referred by medical Center, but not in Regional Counsel
+2 ;MR2- Regional Counsel has bill but, Medical does not show bill as referred
+3 ;MR3- Bill in both RC and VAMC but, dollar amount does not agree
+4 ;MR4- Bill in both RC and VAMC but, a contract/decrease adjustment was made before referred
+5 ;
+6 NEW ERR,I,RCI,RCLN
+7 SET RCI=0
FOR
SET RCI=$ORDER(^XTMP(RCXTYP,RCXMZ,RCI))
if 'RCI
QUIT
Begin DoDot:1
+8 SET RCLN=^XTMP(RCXTYP,RCXMZ,RCI)
KILL ERR
+9 IF RCLN["$$RC$"
QUIT
+10 IF RCLN'["^"
QUIT
+11 IF $PIECE(RCLN,U,1)=""
DO MR2
QUIT
+12 IF $DATA(^TMP("PRCA",$JOB,$PIECE(RCLN,U,1)))
DO MR34
QUIT
+13 IF '$DATA(^TMP("PRCA",$JOB,$PIECE(RCLN,U,1)))
DO MR2
End DoDot:1
+14 DO MR1
+15 DO SORT^RCRCREC3
+16 QUIT
+17 ;
MR34 ;BILL IS IN BOTH SYSTEMS AS REFERRED
+1 ;MR3. SEE IF DOLLAR AMT IS THE SAME
+2 ;MR4. SEE IF DECREASE/CONTRACT DONE BEFORE REFERRED
+3 NEW ARLN,ARBAL,BN,CURBAL,MTYP,X
SET MTYP="MR3"
KILL ERR
+4 SET BN=$ORDER(^TMP("PRCA",$JOB,$PIECE(RCLN,U,1),0))
if BN=""
GOTO MR34Q
+5 SET ARLN=^TMP("PRCA",$JOB,$PIECE(RCLN,U,1),BN)
+6 IF +$PIECE(ARLN,U,6)'=$PIECE(+$PIECE(RCLN,U,6),".00",1)
SET ERR("MR3",3)=""
+7 SET ARBAL=$GET(^PRCA(430,BN,7))
SET CURBAL=0
+8 IF ARBAL]""
FOR X=1:1:5
SET CURBAL=CURBAL+$PIECE(ARBAL,U,X)
+9 IF +CURBAL'=+$PIECE(ARLN,U,6)
SET ERR("MR3",7)=CURBAL
+10 IF $PIECE(RCLN,U,7)]""
IF $PIECE(ARLN,U,7)'=$PIECE(RCLN,U,7)
SET ERR("MR3",9)=""
+11 IF $ORDER(ERR("MR3",0))
SET MTYP="MR3"
GOTO MR34A
+12 SET MTYP="MR4"
DO L433^RCRCREC3
IF $ORDER(ERR("MR4",0))
SET RCLN=""
+13 IF '$ORDER(ERR("MR4",0))
GOTO MR34B
MR34A KILL ERR("MR3",3)
DO SET^RCRCREC3
MR34B KILL ^TMP("PRCA",$JOB,$PIECE(ARLN,U,1)),^XTMP(RCXTYP,RCXMZ,RCI)
MR34Q QUIT
+1 ;
MR2 ;MR2 BILL IS AT RC AS REFERRED BUT NOT IN AR AS REFERRED
+1 NEW BN,MTYP,REFDT,RCBN0,RFDT
SET MTYP="MR2"
+2 IF $PIECE(RCLN,U,1)=""
SET ERR("MR2",1)=""
GOTO MR2A
+3 IF '$DATA(^PRCA(430,"B",$PIECE(RCLN,U,1)))
SET ERR("MR2",1)=""
GOTO MR2A
+4 SET BN=$ORDER(^PRCA(430,"B",$PIECE(RCLN,U,1),0))
SET RCBN0=^PRCA(430,BN,0)
+5 IF $PIECE(RCBN0,U,8)'=16
SET ERR("MR2",2)=$PIECE($GET(^PRCA(430.3,+$PIECE(RCBN0,U,8),0)),"^",1)
GOTO MR2A
+6 IF RCXTYP="PRCADR1"
IF $PIECE(RCBN0,U,2)'=9
SET ERR("MR2",6)=$PIECE($GET(^PRCA(430.2,+$PIECE(RCBN0,U,2),0)),"^",1)
GOTO MR2A
+7 ;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
+8 SET RFDT=$PIECE($GET(^PRCA(430,BN,6)),U,4)
IF RFDT=""
SET ERR("MR2",5)=""
GOTO MR2A
+9 IF '$DATA(^PRCA(430,"AD",RFDT,BN))
SET ^PRCA(430,"AD",RFDT,BN)=""
GOTO MR2B
+10 GOTO MR2B
MR2A DO SET^RCRCREC3
MR2B KILL ^XTMP(RCXTYP,RCXMZ,RCI)
MR2Q QUIT
+1 ;
MR1 ;BILLS REFERRED IN AR NOT IN RC
+1 NEW ARBAL,BN,CURBAL,ERR,I,MTYP,RCBNAM,REFDT,X
+2 SET RCLN=""
SET RCI=""
SET MTYP="MR1"
+3 SET RCBNAM=""
FOR I=1:1
SET RCBNAM=$ORDER(^TMP("PRCA",$JOB,RCBNAM))
if 'RCBNAM
QUIT
Begin DoDot:1
+4 SET BN=$ORDER(^TMP("PRCA",$JOB,RCBNAM,0))
+5 IF $ORDER(RCDIV(0))
IF ('$DATA(RCDIV("RCDOMAIN",RCDOMNM,$$DIV^IBJDF2(+BN))))
QUIT
+6 SET ARLN=^TMP("PRCA",$JOB,RCBNAM,BN)
MR1A DO SET^RCRCREC3
+1 KILL ^TMP("PRCA",$JOB,RCBNAM)
End DoDot:1
MR1Q QUIT
+1 ;
+2 ;
+3 ;
+4 ;
+5 ;RCRCREC2
