Routine: RCRCREC2

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

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)

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

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  Apr 23, 2025@18:02:10                                                                                                                                                                                                    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

RCRCREC2.m