RCRCACP.m

RCRCACP ;ALB/CMS - RC THIRD PARTY REFERRAL ACTION CODE LIST ; 06-JUN-00

V ;;4.5;Accounts Receivable;**63,159**;Mar 20, 1995

 ;;Per VHA Directive 10-93-142, this routine should not be modified.

 Q

 ;

TCD ;view of TRANSACTION CODE list

 NEW RCDA,RCY,RC0,X S (VALMCNT,X)=""

 K ^TMP("RCRCAC",$J)

 S RCDA=0 F  S RCDA=$O(^RCT(349.4,RCDA)) Q:'RCDA  D

 .S RC0=^RCT(349.4,RCDA,0)

 .I $P(RC0,U,1)="PP" Q

 .S VALMCNT=+$G(VALMCNT)+1

 .S RCY=VALMCNT,X=$$SETFLD^VALM1(RCY,X,"NUMBER")

 .S RCY=$P(RC0,U,1),X=$$SETFLD^VALM1(RCY,X,"CODE")

 .S RCY=$P(RC0,U,2),X=$$SETFLD^VALM1(RCY,X,"NAME")

 .S ^TMP("RCRCAC",$J,VALMCNT,0)=X

 .S ^TMP("RCRCAC",$J,"IDX",VALMCNT,VALMCNT)=RCDA

 .Q

 I VALMCNT=0 S VALMSG="NOTHING TO REPORT"

TCDQ Q

 ;

TRD(D0) ;Display Transaction Profile

 N DXS,J,I,PRCAIO,PRCAIO,PRCATYP,X,Y,Z

 S PRCAIO=IO,PRCAIO(0)=IO(0)

 W @IOF,!,?12,"TRANSACTION PROFILE",!

 D ^PRCATR3,ENF^IBOLK

 W !!

TRDQ Q

 ;

EOB ;Process the EOB Codes

 N CNT,D,DA,DIC,DIE,DR,PRCA,PRCABN,PRCABN0,PRCAEN,PRCATN,RCCAT,RCCOM,RCCNT,RCOUT,RCSEL,RCXMB,RCY,X,XMZ,Y

 N DIR,DIRUT,DIROUT,DTOUT,DUOUT S RCOUT=0

 D FULL^VALM1

 I '$O(^TMP("RCRCBL",$J,"SEL",0)) W !!,"NO PAYMENT TRANSACTION SELECTED !!",! G EOBQ

 I '$O(^PRCA(433,"AEOB",0)) W !!,"ALL TP BILLS ARE PROCESSED !!" G EOBQ

 D RCCAT^RCRCUTL(.RCCAT) K DIR

 S RCSEL=0 F  S RCSEL=$O(^TMP("RCRCBL",$J,"SEL",RCSEL)) Q:('RCSEL)!(RCOUT=1)  S RCCNT=$G(^(RCSEL)) D

 .S PRCATN=+$P($G(^TMP("RCRCBLX",$J,RCSEL)),U,2),RCCNT=+RCCNT

 .S PRCABN=$P($G(^PRCA(433,PRCATN,0)),U,2)

 .I '$D(^PRCA(433,"AEOB",PRCABN,PRCATN)) W !!," Item ",RCSEL,".  Transaction Number ",PRCATN,"  is processed.",! D PAUSE^VALM1 Q

 .D BNVAR^RCRCUTL(PRCABN)

 .D TRD(PRCATN)

 .S DA=PRCATN,DIE(0)="AQEZ",DIE="^PRCA(433,",DR="54" D ^DIE

 .K DIR W ! S DIR("A")="Ready to process payment information"

 .S DIR("?")="Enter 'Yes' to transmit the payment to RC and update the referral amount."

 .D ASK K DIR I $G(Y)="^" S RCOUT=1

 .I ($G(Y)'=1)!(RCOUT=1) S ^PRCA(433,"AEOB",+PRCABN,+PRCATN)="" Q

 .S RCCOM=$P($G(^PRCA(433,PRCATN,5)),U,4)

 .I RCCOM]"" S RCCOM="Payment EOB CODE: "_RCCOM D COM^RCRCRT(PRCATN,RCCOM)

 .S DA=PRCABN,DIE="^PRCA(430,",DR="66///^S X="_+$G(^PRCA(430,PRCABN,7)) D ^DIE

 .K ^PRCA(433,"AEOB",PRCABN,PRCATN)

 .D FLDTEXT^VALM10(RCSEL,"DEBTOR","Processed      ")

 .I $P($G(RCCAT(+$P(^PRCA(430,PRCABN,0),U,2))),U,1)'=1 Q

 .S Y=$G(^PRCA(433,PRCATN,1))

 .S RCXMB(2,0)=$G(PRCA("BNAME"),"UNK")_U_PRCATN_U_$P($P(Y,U,9),".",1)_U_+$P(Y,U,5)

 .S RCXMB(3,0)="EOB^"_$P($G(^PRCA(433,PRCATN,5)),U,4)

 .D EOBS

 .S RCCOM="Payment information sent to RC in MM# "_$G(XMZ) D COM^RCRCRT(PRCATN,RCCOM)

 .Q

EOBQ I $G(RCOUT)=1,$O(^PRCA(433,"AEOB",0)) D

 .W !!," NOTICE: All bills pending EOB processing should be processed inorder"

 .W !,?9,"to electronically send Partial Payment information to Regional Counsel"

 .W !,?9,"and update the bill referral amount.  Not processing may cause the"

 .W !,?9,"referral amount to be out-of-balance with Regional Counsel.",!

 D PAUSE^VALM1 S VALMBCK="R"

 Q

 ;

EOBS ;Send Partial Payment data to RC

 N RCBDIV,RCCOM,RCDIV,RCDOM,RCSITE,RCSUB,XMCHAN,XMDUZ,XMSUB,XMTEXT,XMY,X,Y

 I '$O(RCXMB(0)) G EOBSQ

 S RCSITE=$$SITE^RCMSITE

 D RCDIV^RCRCDIV(.RCDIV)

 I $O(RCDIV(0)) S RCBDIV=$$DIV^IBJDF2(PRCABN) S X=0 F  S X=$O(RCDIV(X)) Q:'X  D

 .I X=+RCBDIV S RCDOM=$P(RCDIV(X),U,6)

 I $G(RCDOM)="" S RCDOM=$$RCDOM^RCRCUTL

 S XMDUZ=DUZ,(RCSUB,XMSUB)="AR/RC - "_$G(RCSITE,"UNK")_" PARTIAL PAYMENT"

 S RCWHO=RCDOM,XMY(RCWHO)="",XMY(DUZ)=""

 S RCXMB(1,0)="$$RC$PP$$"_RCSITE_"$S.RC RC SERV"

 S RCXMB(4,0)="$END$1$"

 S XMTEXT="RCXMB(",XMCHAN=1 D ^XMD

 S RCCOM="Sent Payment Transaction to RC in MM# "_$G(XMZ)

 I $G(XMZ) D ENT^RCRCXMS(XMZ,RCSUB,RCWHO,RCCOM)

 W !!,?10,RCCOM,!

EOBSQ Q

 ;

ASK ;Ask Yes or No Caller send DIR("A"),DIR("?")

 N DIROUT,DUOUT,DTOUT,DIRUT

 S DIR(0)="Y",DIR("B")="Yes" D ^DIR

ASKQ Q

 ;

REQ ;Transmit a Action Request to RC

 N DIR,PRCABN,RCCOM,RCY,VALMCNT,VALMY,X,Y

 I '$O(^TMP("RCRCAL",$J,"SEL",0)) W !,"NO BILLS SELECTED!",!,"No selected items from Bill List" G REQQ

 D EN^VALM2($G(XQORNOD(0)),"SO") I '$O(VALMY(0)) G REQQ

 D FULL^VALM1

 S RCCOM=$G(^TMP("RCRCAC",$J,+$O(VALMY(0)),0))

 W !!,"You Selected: "_RCCOM

 W !!,"This action creates an AR Comment Transaction requesting that a "_RCCOM

 W !,"action be applied by Regional Counsel to the bills on the highlighted"

 W !,"selection list. You can then edit the Comment Transaction request"

 W !,"and transmit the request to RC.",!

 ;

 S RCCOM=^TMP("RCRCAC",$J,"IDX",+RCCOM,+RCCOM),RCCOM=$P($G(^RCT(349.4,+RCCOM,0)),U,1)

 S RCCOM="I am requesting that a "_RCCOM_" be applied to this bill."

 K DIR S DIR("A")="Okay to Create a Comment Transaction "

 S DIR("?")="Enter Yes to create a Comment Transaction or No to exit."

 D ASK K DIR I $G(Y)'=1 G REQQ

 K ^TMP("RCRCAC",$J,"XM")

 S RCY=0 F  S RCY=$O(^TMP("RCRCAL",$J,"SEL",RCY)) Q:'RCY  D

 .S PRCABN=+$P($G(^TMP("RCRCALX",$J,RCY)),U,2),PRCAEN=0

 .D CCOM

 .Q

 I '$O(^TMP("RCRCAC",$J,"XM",0)) G REQQ

 K DIR S DIR("A")="Send Request to RC now ",DIR("?")="Enter Yes if to transmit the created Comment entries"

 D ASK I $G(Y)=1 D SND

 ;

REQQ K ^TMP("RCRCAC",$J,"XM")

 K DIR D PAUSE^VALM1 S XQORM("B")="Quit",VALMBCK="R"

 Q

 ;

CCOM ;Create Comment Transaction

 ;Input: PRCABN

 N DA,DIC,DIE,DR,D0,PRCA,PRCABN0,PRCAD,PRCAEN,PRCAMT,X,Y

 S PRCABN0=$G(^PRCA(430,+$G(PRCABN),0))

 I 'PRCABN0 W !,PRCABN_" NOT A VALID AR BILL!",! G CCOMQ

 W !!,"Bill No. # "_$P(PRCABN0,U,1)

 D SETTR^PRCAUTL,PATTR^PRCAUTL

 I '$D(PRCAEN) W "COULD NOT CREATE A TRANSACTION AT THIS TIME!",!,"Try again later." G CCOMQ

 I $G(RCCOM)]"" D COM^RCRCRT(PRCAEN,RCCOM)

 S DIE="^PRCA(433,",DA=PRCAEN,DR="[PRCA COMMENT]" D ^DIE

 S DR="4////^S X=2" D ^DIE

 S ^TMP("RCRCAC",$J,"XM",PRCABN,PRCAEN)=""

CCOMQ Q

 ;

SND ;Send data to RC

 N PRCABN,PRCAEN,PRCA,RCXCNT,X,Y,RCSITE,RCDIV,RCDOM,RCBDIV

 K ^TMP("RCRCAT",$J,"XM") S RCXCNT=0

 S RCSITE=$$SITE^RCMSITE

 D RCDIV^RCRCDIV(.RCDIV)

 S PRCABN=0 F  S PRCABN=$O(^TMP("RCRCAC",$J,"XM",PRCABN)) Q:'PRCABN  D

 .D BNVAR^RCRCUTL(PRCABN)

 .D DEBT^RCRCUTL(PRCABN)

 .S PRCAEN=0 F  S PRCAEN=$O(^TMP("RCRCAC",$J,"XM",PRCABN,PRCAEN)) Q:'PRCAEN  D

 ..D SET^RCRCAT1

 ..I $G(RCDIV(0)) S RCBDIV=$$DIV^IBJDF2(PRCABN) S X=0 F  S X=$O(RCDIV(X)) Q:'X  D

 ...I X=+RCBDIV S RCDOM=$P(RCDIV(X),"^",6)

 I $G(RCDOM)="" S RCDOM=$$RCDOM^RCRCUTL

 D SEND^RCRCAT

 K ^TMP("RCRCAT",$J,"XM")

SNDQ Q

 ;RCRCACP

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---RCRCACP   6423     printed  Feb 18, 2025@23:13:50                                                                                                                                                                                                     Page 2

RCRCACP   ;ALB/CMS - RC THIRD PARTY REFERRAL ACTION CODE LIST ; 06-JUN-00

V         ;;4.5;Accounts Receivable;**63,159**;Mar 20, 1995

 +1       ;;Per VHA Directive 10-93-142, this routine should not be modified.

 +2        QUIT 

 +3       ;

TCD       ;view of TRANSACTION CODE list

 +1        NEW RCDA,RCY,RC0,X

           SET (VALMCNT,X)=""

 +2        KILL ^TMP("RCRCAC",$JOB)

 +3        SET RCDA=0

           FOR 

               SET RCDA=$ORDER(^RCT(349.4,RCDA))

               if 'RCDA

                   QUIT 

               Begin DoDot:1

 +4                SET RC0=^RCT(349.4,RCDA,0)

 +5                IF $PIECE(RC0,U,1)="PP"

                       QUIT 

 +6                SET VALMCNT=+$GET(VALMCNT)+1

 +7                SET RCY=VALMCNT

                   SET X=$$SETFLD^VALM1(RCY,X,"NUMBER")

 +8                SET RCY=$PIECE(RC0,U,1)

                   SET X=$$SETFLD^VALM1(RCY,X,"CODE")

 +9                SET RCY=$PIECE(RC0,U,2)

                   SET X=$$SETFLD^VALM1(RCY,X,"NAME")

 +10               SET ^TMP("RCRCAC",$JOB,VALMCNT,0)=X

 +11               SET ^TMP("RCRCAC",$JOB,"IDX",VALMCNT,VALMCNT)=RCDA

 +12               QUIT 

               End DoDot:1

 +13       IF VALMCNT=0

               SET VALMSG="NOTHING TO REPORT"

TCDQ       QUIT 

 +1       ;

TRD(D0)   ;Display Transaction Profile

 +1        NEW DXS,J,I,PRCAIO,PRCAIO,PRCATYP,X,Y,Z

 +2        SET PRCAIO=IO

           SET PRCAIO(0)=IO(0)

 +3        WRITE @IOF,!,?12,"TRANSACTION PROFILE",!

 +4        DO ^PRCATR3

           DO ENF^IBOLK

 +5        WRITE !!

TRDQ       QUIT 

 +1       ;

EOB       ;Process the EOB Codes

 +1        NEW CNT,D,DA,DIC,DIE,DR,PRCA,PRCABN,PRCABN0,PRCAEN,PRCATN,RCCAT,RCCOM,RCCNT,RCOUT,RCSEL,RCXMB,RCY,X,XMZ,Y

 +2        NEW DIR,DIRUT,DIROUT,DTOUT,DUOUT

           SET RCOUT=0

 +3        DO FULL^VALM1

 +4        IF '$ORDER(^TMP("RCRCBL",$JOB,"SEL",0))

               WRITE !!,"NO PAYMENT TRANSACTION SELECTED !!",!

               GOTO EOBQ

 +5        IF '$ORDER(^PRCA(433,"AEOB",0))

               WRITE !!,"ALL TP BILLS ARE PROCESSED !!"

               GOTO EOBQ

 +6        DO RCCAT^RCRCUTL(.RCCAT)

           KILL DIR

 +7        SET RCSEL=0

           FOR 

               SET RCSEL=$ORDER(^TMP("RCRCBL",$JOB,"SEL",RCSEL))

               if ('RCSEL)!(RCOUT=1)

                   QUIT 

               SET RCCNT=$GET(^(RCSEL))

               Begin DoDot:1

 +8                SET PRCATN=+$PIECE($GET(^TMP("RCRCBLX",$JOB,RCSEL)),U,2)

                   SET RCCNT=+RCCNT

 +9                SET PRCABN=$PIECE($GET(^PRCA(433,PRCATN,0)),U,2)

 +10               IF '$DATA(^PRCA(433,"AEOB",PRCABN,PRCATN))

                       WRITE !!," Item ",RCSEL,".  Transaction Number ",PRCATN,"  is processed.",!

                       DO PAUSE^VALM1

                       QUIT 

 +11               DO BNVAR^RCRCUTL(PRCABN)

 +12               DO TRD(PRCATN)

 +13               SET DA=PRCATN

                   SET DIE(0)="AQEZ"

                   SET DIE="^PRCA(433,"

                   SET DR="54"

                   DO ^DIE

 +14               KILL DIR

                   WRITE !

                   SET DIR("A")="Ready to process payment information"

 +15               SET DIR("?")="Enter 'Yes' to transmit the payment to RC and update the referral amount."

 +16               DO ASK

                   KILL DIR

                   IF $GET(Y)="^"

                       SET RCOUT=1

 +17               IF ($GET(Y)'=1)!(RCOUT=1)

                       SET ^PRCA(433,"AEOB",+PRCABN,+PRCATN)=""

                       QUIT 

 +18               SET RCCOM=$PIECE($GET(^PRCA(433,PRCATN,5)),U,4)

 +19               IF RCCOM]""

                       SET RCCOM="Payment EOB CODE: "_RCCOM

                       DO COM^RCRCRT(PRCATN,RCCOM)

 +20               SET DA=PRCABN

                   SET DIE="^PRCA(430,"

                   SET DR="66///^S X="_+$GET(^PRCA(430,PRCABN,7))

                   DO ^DIE

 +21               KILL ^PRCA(433,"AEOB",PRCABN,PRCATN)

 +22               DO FLDTEXT^VALM10(RCSEL,"DEBTOR","Processed      ")

 +23               IF $PIECE($GET(RCCAT(+$PIECE(^PRCA(430,PRCABN,0),U,2))),U,1)'=1

                       QUIT 

 +24               SET Y=$GET(^PRCA(433,PRCATN,1))

 +25               SET RCXMB(2,0)=$GET(PRCA("BNAME"),"UNK")_U_PRCATN_U_$PIECE($PIECE(Y,U,9),".",1)_U_+$PIECE(Y,U,5)

 +26               SET RCXMB(3,0)="EOB^"_$PIECE($GET(^PRCA(433,PRCATN,5)),U,4)

 +27               DO EOBS

 +28               SET RCCOM="Payment information sent to RC in MM# "_$GET(XMZ)

                   DO COM^RCRCRT(PRCATN,RCCOM)

 +29               QUIT 

               End DoDot:1

EOBQ       IF $GET(RCOUT)=1

               IF $ORDER(^PRCA(433,"AEOB",0))

                   Begin DoDot:1

 +1                    WRITE !!," NOTICE: All bills pending EOB processing should be processed inorder"

 +2                    WRITE !,?9,"to electronically send Partial Payment information to Regional Counsel"

 +3                    WRITE !,?9,"and update the bill referral amount.  Not processing may cause the"

 +4                    WRITE !,?9,"referral amount to be out-of-balance with Regional Counsel.",!

                   End DoDot:1

 +5        DO PAUSE^VALM1

           SET VALMBCK="R"

 +6        QUIT 

 +7       ;

EOBS      ;Send Partial Payment data to RC

 +1        NEW RCBDIV,RCCOM,RCDIV,RCDOM,RCSITE,RCSUB,XMCHAN,XMDUZ,XMSUB,XMTEXT,XMY,X,Y

 +2        IF '$ORDER(RCXMB(0))

               GOTO EOBSQ

 +3        SET RCSITE=$$SITE^RCMSITE

 +4        DO RCDIV^RCRCDIV(.RCDIV)

 +5        IF $ORDER(RCDIV(0))

               SET RCBDIV=$$DIV^IBJDF2(PRCABN)

               SET X=0

               FOR 

                   SET X=$ORDER(RCDIV(X))

                   if 'X

                       QUIT 

                   Begin DoDot:1

 +6                    IF X=+RCBDIV

                           SET RCDOM=$PIECE(RCDIV(X),U,6)

                   End DoDot:1

 +7        IF $GET(RCDOM)=""

               SET RCDOM=$$RCDOM^RCRCUTL

 +8        SET XMDUZ=DUZ

           SET (RCSUB,XMSUB)="AR/RC - "_$GET(RCSITE,"UNK")_" PARTIAL PAYMENT"

 +9        SET RCWHO=RCDOM

           SET XMY(RCWHO)=""

           SET XMY(DUZ)=""

 +10       SET RCXMB(1,0)="$$RC$PP$$"_RCSITE_"$S.RC RC SERV"

 +11       SET RCXMB(4,0)="$END$1$"

 +12       SET XMTEXT="RCXMB("

           SET XMCHAN=1

           DO ^XMD

 +13       SET RCCOM="Sent Payment Transaction to RC in MM# "_$GET(XMZ)

 +14       IF $GET(XMZ)

               DO ENT^RCRCXMS(XMZ,RCSUB,RCWHO,RCCOM)

 +15       WRITE !!,?10,RCCOM,!

EOBSQ      QUIT 

 +1       ;

ASK       ;Ask Yes or No Caller send DIR("A"),DIR("?")

 +1        NEW DIROUT,DUOUT,DTOUT,DIRUT

 +2        SET DIR(0)="Y"

           SET DIR("B")="Yes"

           DO ^DIR

ASKQ       QUIT 

 +1       ;

REQ       ;Transmit a Action Request to RC

 +1        NEW DIR,PRCABN,RCCOM,RCY,VALMCNT,VALMY,X,Y

 +2        IF '$ORDER(^TMP("RCRCAL",$JOB,"SEL",0))

               WRITE !,"NO BILLS SELECTED!",!,"No selected items from Bill List"

               GOTO REQQ

 +3        DO EN^VALM2($GET(XQORNOD(0)),"SO")

           IF '$ORDER(VALMY(0))

               GOTO REQQ

 +4        DO FULL^VALM1

 +5        SET RCCOM=$GET(^TMP("RCRCAC",$JOB,+$ORDER(VALMY(0)),0))

 +6        WRITE !!,"You Selected: "_RCCOM

 +7        WRITE !!,"This action creates an AR Comment Transaction requesting that a "_RCCOM

 +8        WRITE !,"action be applied by Regional Counsel to the bills on the highlighted"

 +9        WRITE !,"selection list. You can then edit the Comment Transaction request"

 +10       WRITE !,"and transmit the request to RC.",!

 +11      ;

 +12       SET RCCOM=^TMP("RCRCAC",$JOB,"IDX",+RCCOM,+RCCOM)

           SET RCCOM=$PIECE($GET(^RCT(349.4,+RCCOM,0)),U,1)

 +13       SET RCCOM="I am requesting that a "_RCCOM_" be applied to this bill."

 +14       KILL DIR

           SET DIR("A")="Okay to Create a Comment Transaction "

 +15       SET DIR("?")="Enter Yes to create a Comment Transaction or No to exit."

 +16       DO ASK

           KILL DIR

           IF $GET(Y)'=1

               GOTO REQQ

 +17       KILL ^TMP("RCRCAC",$JOB,"XM")

 +18       SET RCY=0

           FOR 

               SET RCY=$ORDER(^TMP("RCRCAL",$JOB,"SEL",RCY))

               if 'RCY

                   QUIT 

               Begin DoDot:1

 +19               SET PRCABN=+$PIECE($GET(^TMP("RCRCALX",$JOB,RCY)),U,2)

                   SET PRCAEN=0

 +20               DO CCOM

 +21               QUIT 

               End DoDot:1

 +22       IF '$ORDER(^TMP("RCRCAC",$JOB,"XM",0))

               GOTO REQQ

 +23       KILL DIR

           SET DIR("A")="Send Request to RC now "

           SET DIR("?")="Enter Yes if to transmit the created Comment entries"

 +24       DO ASK

           IF $GET(Y)=1

               DO SND

 +25      ;

REQQ       KILL ^TMP("RCRCAC",$JOB,"XM")

 +1        KILL DIR

           DO PAUSE^VALM1

           SET XQORM("B")="Quit"

           SET VALMBCK="R"

 +2        QUIT 

 +3       ;

CCOM      ;Create Comment Transaction

 +1       ;Input: PRCABN

 +2        NEW DA,DIC,DIE,DR,D0,PRCA,PRCABN0,PRCAD,PRCAEN,PRCAMT,X,Y

 +3        SET PRCABN0=$GET(^PRCA(430,+$GET(PRCABN),0))

 +4        IF 'PRCABN0

               WRITE !,PRCABN_" NOT A VALID AR BILL!",!

               GOTO CCOMQ

 +5        WRITE !!,"Bill No. # "_$PIECE(PRCABN0,U,1)

 +6        DO SETTR^PRCAUTL

           DO PATTR^PRCAUTL

 +7        IF '$DATA(PRCAEN)

               WRITE "COULD NOT CREATE A TRANSACTION AT THIS TIME!",!,"Try again later."

               GOTO CCOMQ

 +8        IF $GET(RCCOM)]""

               DO COM^RCRCRT(PRCAEN,RCCOM)

 +9        SET DIE="^PRCA(433,"

           SET DA=PRCAEN

           SET DR="[PRCA COMMENT]"

           DO ^DIE

 +10       SET DR="4////^S X=2"

           DO ^DIE

 +11       SET ^TMP("RCRCAC",$JOB,"XM",PRCABN,PRCAEN)=""

CCOMQ      QUIT 

 +1       ;

SND       ;Send data to RC

 +1        NEW PRCABN,PRCAEN,PRCA,RCXCNT,X,Y,RCSITE,RCDIV,RCDOM,RCBDIV

 +2        KILL ^TMP("RCRCAT",$JOB,"XM")

           SET RCXCNT=0

 +3        SET RCSITE=$$SITE^RCMSITE

 +4        DO RCDIV^RCRCDIV(.RCDIV)

 +5        SET PRCABN=0

           FOR 

               SET PRCABN=$ORDER(^TMP("RCRCAC",$JOB,"XM",PRCABN))

               if 'PRCABN

                   QUIT 

               Begin DoDot:1

 +6                DO BNVAR^RCRCUTL(PRCABN)

 +7                DO DEBT^RCRCUTL(PRCABN)

 +8                SET PRCAEN=0

                   FOR 

                       SET PRCAEN=$ORDER(^TMP("RCRCAC",$JOB,"XM",PRCABN,PRCAEN))

                       if 'PRCAEN

                           QUIT 

                       Begin DoDot:2

 +9                        DO SET^RCRCAT1

 +10                       IF $GET(RCDIV(0))

                               SET RCBDIV=$$DIV^IBJDF2(PRCABN)

                               SET X=0

                               FOR 

                                   SET X=$ORDER(RCDIV(X))

                                   if 'X

                                       QUIT 

                                   Begin DoDot:3

 +11                                   IF X=+RCBDIV

                                           SET RCDOM=$PIECE(RCDIV(X),"^",6)

                                   End DoDot:3

                       End DoDot:2

               End DoDot:1

 +12       IF $GET(RCDOM)=""

               SET RCDOM=$$RCDOM^RCRCUTL

 +13       DO SEND^RCRCAT

 +14       KILL ^TMP("RCRCAT",$JOB,"XM")

SNDQ       QUIT 

 +1       ;RCRCACP