Routine: RCDPCSA

RCDPCSA ;UNY/RGB-CROSS-SERVICING STATUS FIX ;03/15/14 3:34 PM

 ;;4.5;Accounts Receivable;**325,336,343**;Mar 20, 1995;Build 59

 ;;Per VA Directive 6402, this routine should not be modified.

 ;OPTION: RCDP TCSP FLAG CONTROL

 ;PRCA*4.5*336 When setting bills to cross service date

 ;             ensure the TCSP address node ^PRCA(430,ien,16)

 ;             is established

 ;PRCA*4.5*343 Moved Name/taxid lookup into routine since they

 ;             were moved from previous calls into RCTCSPD.

A S U="^" S SITE=+$$SITE^VASITE

B K DIR S DIR(0)="SO^1:Set cross-service flag on BILL;2:Clear cross-service flag on BILL;3:Clear cross-service flag on DEBTOR (AND ALL BILLS);4:Set cross-service flag on DEBTOR;5:Fully re-establish debtor/bill as cross-serviced"

 S DIR("?")="Enter an option number 1 to 5."

 S DIR("A")="Select Number"

 D ^DIR

 G EXIT:$D(DIRUT)

 S PRCAOPT=+Y

C ;select bill

 ;  returns -1 for timeout or ^, 0 for no selection, or ien of bill

 K %,%Y,C,DIC,DIR,DIE,DTOUT,DUOUT,X,Y

 K RCY,DIR,DIRUT

 W ! S DIC="^PRCA(430,",DIC(0)="QEAM",DIC("A")="Select BILL: "

 ;  special lookup on input

 S RCBEFLUP=1

 D ^DIC

 I $G(DUOUT)!$G(DTOUT) G B

 I Y<0 G B

 S RCBILLDA=+Y

 ;Disp last 4 soc#

C1 I '$D(^PRCA(430,"TCSP",RCBILLDA)),PRCAOPT=2 W !,"*** BILL NOT CROSS SERVICED ***" G C

 I $P($G(^PRCA(430,RCBILLDA,0)),U,8)'=16 W !,"*** BILL NOT ACTIVE ***" G C

 S RCDEBTOR=$P($G(^PRCA(430,RCBILLDA,0)),U,9) I 'RCDEBTOR W !," < *** debtor not found on bill *** >" G C

 S RCDEBTV=$P($G(^RCD(340,RCDEBTOR,0)),U) I 'RCDEBTV W !," < *** debtor on bill not found *** >" G C

 I RCDEBTV'["DPT(" W !," < *** debtor must be a veteran *** >" G C

 I '$D(^RCD(340,"TCSP",RCDEBTOR)),"245"'[PRCAOPT W !," <debtor not flagged as CS *** >" G C

 S RCDPT=+RCDEBTV,RC0=$G(^DPT(RCDPT,0)) I RC0="" W !," < *** debtor info not found *** >" G C

 W ?60,$E($P(RC0,U,9),6,9)

 D @PRCAOPT

G C

1 ;option 1

 I $D(^PRCA(430,"TCSP",RCBILLDA)) W !,"*** BILL ALREADY CROSS-SERVICED ***" Q

 S DIR(0)="D",DIR("A")="Enter Cross-Sevice Date" D ^DIR K DIR

 I $D(DIRUT)!($D(DUOUT)) Q

 S RCDATE=Y

 S DIR(0)="YA",DIR("A")="File CS Bill Change (Y/N): ",DIR("B")="N",DIR("?")="Enter (Y)es to file or (N)o to skip filing"

 D ^DIR K DIR I Y=0!$G(DIRUT) W "   < Bill Not Updated >" Q

 S RCDAS=RCBILLDA_",",PRCAR(430,RCDAS,151)=RCDATE D FILE^DIE("EK","PRCAR","PRCAERR") I $D(PRCAERR) W "   <",$G(PRCAERR("DIERR",1,"TEXT",1)),">" K PRCAERR G 1

 D SET16             ;PRCA*4.5*336

 W "  <DONE>"

2 ;option 2

 I '$D(^PRCA(430,"TCSP",RCBILLDA)) W !,"*** BILL NOT CROSS SERVICED ***" Q

 S DIR(0)="YA",DIR("A")="File CS Bill Flag Removal (Y/N): ",DIR("B")="N",DIR("?")="Enter (Y)es to file or (N)o to skip filing"

 D ^DIR K DIR I Y=0!$G(DIRUT) W "   <Bill Not Updated" Q

 K ^PRCA(430,RCBILLDA,16)

 S DA=RCBILLDA,DIE="^PRCA(430,",DR="151////@" D ^DIE W "  <DONE>"         ;PRCA*4.5*336

3 ;option 3

 S DIR(0)="YA",DIR("A")="File CS Debtor/Bills Flag Removal (Y/N): ",DIR("B")="N",DIR("?")="Enter (Y)es to file or (N)o to skip filing"

 D ^DIR I Y=0!$G(DIRUT) W "   <Bill Not Updated" Q

 S DA=RCDEBTOR,DIE="^RCD(340,",DR="7.05////@" D ^DIE W "  <DONE>"

 S PRCAIEN=0

 F  S PRCAIEN=$O(^PRCA(430,"C",RCDEBTOR,PRCAIEN)) Q:'PRCAIEN  D

 . I '$D(^PRCA(430,"TCSP",PRCAIEN)) Q

 . S DA=PRCAIEN,DIE="^PRCA(430,",DR="151////@" D ^DIE         ;PRCA*4.5*336

 . K ^PRCA(430,RCBILLDA,16)

 . W !,?4,$P(^PRCA(430,PRCAIEN,0),U),"  Cleared"

4 ;option 4

 I $D(^RCD(340,"TCSP",RCDEBTOR)) W !,"*** DEBTOR ALREADY CROSS-SERVICED ***" Q

 S DIR(0)="D",DIR("A")="Enter Debtor Cross-Sevice Date" D ^DIR K DIR

 I $D(DIRUT)!($D(DUOUT)) Q

 S RCDATE=Y

 S DIR(0)="YA",DIR("A")="File CS Debtor Change (Y/N): ",DIR("B")="N",DIR("?")="Enter (Y)es to file or (N)o to skip filing"

 D ^DIR K DIR I Y=0!$G(DIRUT) W "   < Debtor Not Updated >" Q

 S RCDAS=RCDEBTOR_",",RCDR(340,RCDAS,7.05)=RCDATE D FILE^DIE("EK","RCDR","RCDERR") I $D(RCDERR) W "   <",$G(RCDERR("DIERR",1,"TEXT",1)),">" K RCDERR G 4

 W "  <DONE>"

5 ;option 5

 I $D(^PRCA(430,"TCSP",RCBILLDA)) W !,"*** BILL ALREADY CROSS-SERVICED, DEBTOR MUST BE ALSO ***" Q

 I $D(^RCD(340,"TCSP",RCDEBTOR)) W !,"*** DEBTOR ALREADY CROSS-SERVICED, USE OPTION 1 TO SET BILL ***" Q

 I $D(^PRCA(430,RCBILLDA,30)) W !,"*** BILL RETURNED BY RECONCILIATION ***" Q

 S DIR(0)="D",DIR("A")="Enter Debtor Cross-Sevice Date" D ^DIR K DIR Q:$G(DIRUT)

 S RCDATE=Y

 S DIR(0)="YA",DIR("A")="File CS Debtor/Bill Change (Y/N): ",DIR("B")="N",DIR("?")="Enter (Y)es to file or (N)o to skip filing"

 D ^DIR K DIR I Y=0!$G(DIRUT) W "   < Debtor Not Updated >" Q

 S RCDAS=RCDEBTOR_",",RCDR(340,RCDAS,7.05)=RCDATE D FILE^DIE("EK","RCDR","RCDERR") I $D(RCDERR) W "   <",$G(RCDERR("DIERR",1,"TEXT",1)),">" K RCDERR G 5

 S ^PRCA(430,RCBILLDA,15)="",DA=RCBILLDA,DIE="^PRCA(430,",DR="151////^S X=RCDATE" D ^DIE

 D SET16              ;PRCA*4.5*336

 W "  <DONE>",!,">>> Bill Updating for CS info... "

 W "fully re-established as Cross-Serviced >"

SET16 ;SET NODE 16 FOR TCSP BILL     ;PRCA*4.5*336

 N RCXX,RCYY

 S (RCDEBTR0,DEBTOR0)=$G(^RCD(340,RCDEBTOR,0)),DEBTOR1=$G(^RCD(340,RCDEBTOR,1)),RCDFN=+RCDEBTR0

 S RCDPN16="",RCB6=$G(^PRCA(430,RCBILLDA,6)),RCB7=$G(^(7)),RCBILLDT=$P($P(RCB6,U,21),".")

 S TAXID=$$TAXID(RCDEBTOR),RCNAME=$$NAME(+RCDEBTR0),RCNAME=$P(RCNAME,U)

 S $P(RCDPN16,U)=TAXID,$P(RCDPN16,U,2)=RCNAME,$P(RCDPN16,U,3)=+RCBILLDT

 S DEBTOR=RCDEBTOR,ADDRCS=$$ADDR^RCTCSP1(RCDFN,1),$P(RCDPN16,U,4,8)=$P(ADDRCS,U,1,5)

 S $P(RCDPN16,U,12)=$S($P(ADDRCS,U,7)>2:$P(ADDRCS,U,7),+^PRCA(430,RCBILLDA,0)=436:2,1:1),$P(RCDPN16,U,13)=$P(^DPT(RCDFN,0),U,3)

 S RCAMTRFD=0 F I=1:1:5 S RCAMTRFD=RCAMTRFD+$P(RCB7,U,I)

 F I=9,10 S $P(RCDPN16,U,I)=RCAMTRFD

 S (RCXX,RCYY)=$P(ADDRCS,U,6)

 I RCXX'?10N D

 . S RCYY="" F I=1:1:$L(RCXX) I $E(RCXX,I)?1N S RCYY=RCYY_$E(RCXX,I)

 S $P(RCDPN16,U,11)=$E("000000000000",1,10-$L(RCYY))_RCYY

 S ^PRCA(430,RCBILLDA,16)=RCDPN16

TAXID(DEBTOR) ;computes TAXID to place on documents   ;PRCA*4.5*343

 N TAXID,DIC,DA,DR,DIQ

 S TAXID=$$SSN^RCFN01(DEBTOR)

 S TAXID=$$LJSF(TAXID,9)

 Q TAXID

NAME(DFN) ;returns name for document and name in file   ;PRCA*4.5*343

 N FN,LN,MN,NM,DOCNM,VA,VADM

 S NM=""

 D DEM^VADPT

 I $D(VADM) S NM=VADM(1)

 S LN=$TR($P(NM,",")," .'-"),MN=$P($P(NM,",",2)," ",2)

 I ($E(MN,1,2)="SR")!($E(MN,1,2)="JR")!(MN?2.3"I")!(MN?0.1"I"1"V"1.3"I") S MN=""

 S FN=$P($P(NM,",",2)," ")

 S DOCNM=$$LJ^XLFSTR($E(LN,1,35),35)_$$LJ^XLFSTR($E(FN,1,35),35)_$$LJ^XLFSTR($E(MN,1,35),35)

 Q DOCNM

LJSF(X,Y) ;left justified space filled

 S X=$E(X,1,Y)

 S X=X_$$BLANK(Y-$L(X))

Q X

BLANK(X) ;returns 'x' blank spaces

 N BLANK

 S BLANK="",$P(BLANK," ",X+1)=""

 Q BLANK

EXIT D KILL^XUSCLEAN Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPCSA   6709     printed  Mar 13, 2025@20:48:40                                                                                                                                                                                                     Page 2

RCDPCSA   ;UNY/RGB-CROSS-SERVICING STATUS FIX ;03/15/14 3:34 PM

 +1       ;;4.5;Accounts Receivable;**325,336,343**;Mar 20, 1995;Build 59

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3       ;OPTION: RCDP TCSP FLAG CONTROL

 +4       ;

 +5       ;PRCA*4.5*336 When setting bills to cross service date

 +6       ;             ensure the TCSP address node ^PRCA(430,ien,16)

 +7       ;             is established

 +8       ;PRCA*4.5*343 Moved Name/taxid lookup into routine since they

 +9       ;             were moved from previous calls into RCTCSPD.

 +10      ;

A          SET U="^"

           SET SITE=+$$SITE^VASITE

B          KILL DIR

           SET DIR(0)="SO^1:Set cross-service flag on BILL;2:Clear cross-service flag on BILL;3:Clear cross-service flag on DEBTOR (AND ALL BILLS);4:Set cross-service flag on DEBTOR;5:Fully re-establish debtor/bill as cross-serviced"

 +1        SET DIR("?")="Enter an option number 1 to 5."

 +2        SET DIR("A")="Select Number"

 +3        DO ^DIR

 +4        if $DATA(DIRUT)

               GOTO EXIT

 +5        SET PRCAOPT=+Y

 +6       ;

C         ;select bill

 +1       ;  returns -1 for timeout or ^, 0 for no selection, or ien of bill

 +2        KILL %,%Y,C,DIC,DIR,DIE,DTOUT,DUOUT,X,Y

 +3        KILL RCY,DIR,DIRUT

 +4        WRITE !

           SET DIC="^PRCA(430,"

           SET DIC(0)="QEAM"

           SET DIC("A")="Select BILL: "

 +5       ;  special lookup on input

 +6        SET RCBEFLUP=1

 +7        DO ^DIC

 +8        IF $GET(DUOUT)!$GET(DTOUT)

               GOTO B

 +9        IF Y<0

               GOTO B

 +10       SET RCBILLDA=+Y

 +11      ;Disp last 4 soc#

C1         IF '$DATA(^PRCA(430,"TCSP",RCBILLDA))

               IF PRCAOPT=2

                   WRITE !,"*** BILL NOT CROSS SERVICED ***"

                   GOTO C

 +1        IF $PIECE($GET(^PRCA(430,RCBILLDA,0)),U,8)'=16

               WRITE !,"*** BILL NOT ACTIVE ***"

               GOTO C

 +2        SET RCDEBTOR=$PIECE($GET(^PRCA(430,RCBILLDA,0)),U,9)

           IF 'RCDEBTOR

               WRITE !," < *** debtor not found on bill *** >"

               GOTO C

 +3        SET RCDEBTV=$PIECE($GET(^RCD(340,RCDEBTOR,0)),U)

           IF 'RCDEBTV

               WRITE !," < *** debtor on bill not found *** >"

               GOTO C

 +4        IF RCDEBTV'["DPT("

               WRITE !," < *** debtor must be a veteran *** >"

               GOTO C

 +5        IF '$DATA(^RCD(340,"TCSP",RCDEBTOR))

               IF "245"'[PRCAOPT

                   WRITE !," <debtor not flagged as CS *** >"

                   GOTO C

 +6        SET RCDPT=+RCDEBTV

           SET RC0=$GET(^DPT(RCDPT,0))

           IF RC0=""

               WRITE !," < *** debtor info not found *** >"

               GOTO C

 +7        WRITE ?60,$EXTRACT($PIECE(RC0,U,9),6,9)

 +8        DO @PRCAOPT

 +9        GOTO C

1         ;option 1

 +1        IF $DATA(^PRCA(430,"TCSP",RCBILLDA))

               WRITE !,"*** BILL ALREADY CROSS-SERVICED ***"

               QUIT

 +2        SET DIR(0)="D"

           SET DIR("A")="Enter Cross-Sevice Date"

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)!($DATA(DUOUT))

               QUIT

 +4        SET RCDATE=Y

 +5        SET DIR(0)="YA"

           SET DIR("A")="File CS Bill Change (Y/N): "

           SET DIR("B")="N"

           SET DIR("?")="Enter (Y)es to file or (N)o to skip filing"

 +6        DO ^DIR

           KILL DIR

           IF Y=0!$GET(DIRUT)

               WRITE "   < Bill Not Updated >"

               QUIT

 +7        SET RCDAS=RCBILLDA_","

           SET PRCAR(430,RCDAS,151)=RCDATE

           DO FILE^DIE("EK","PRCAR","PRCAERR")

           IF $DATA(PRCAERR)

               WRITE "   <",$GET(PRCAERR("DIERR",1,"TEXT",1)),">"

               KILL PRCAERR

               GOTO 1

 +8       ;PRCA*4.5*336

           DO SET16

 +9        WRITE "  <DONE>"

 +10       QUIT

2         ;option 2

 +1        IF '$DATA(^PRCA(430,"TCSP",RCBILLDA))

               WRITE !,"*** BILL NOT CROSS SERVICED ***"

               QUIT

 +2        SET DIR(0)="YA"

           SET DIR("A")="File CS Bill Flag Removal (Y/N): "

           SET DIR("B")="N"

           SET DIR("?")="Enter (Y)es to file or (N)o to skip filing"

 +3        DO ^DIR

           KILL DIR

           IF Y=0!$GET(DIRUT)

               WRITE "   <Bill Not Updated"

               QUIT

 +4        KILL ^PRCA(430,RCBILLDA,16)

 +5       ;PRCA*4.5*336

           SET DA=RCBILLDA

           SET DIE="^PRCA(430,"

           SET DR="151////@"

           DO ^DIE

           WRITE "  <DONE>"

 +6        QUIT

3         ;option 3

 +1        SET DIR(0)="YA"

           SET DIR("A")="File CS Debtor/Bills Flag Removal (Y/N): "

           SET DIR("B")="N"

           SET DIR("?")="Enter (Y)es to file or (N)o to skip filing"

 +2        DO ^DIR

           IF Y=0!$GET(DIRUT)

               WRITE "   <Bill Not Updated"

               QUIT

 +3        SET DA=RCDEBTOR

           SET DIE="^RCD(340,"

           SET DR="7.05////@"

           DO ^DIE

           WRITE "  <DONE>"

 +4        SET PRCAIEN=0

 +5        FOR

               SET PRCAIEN=$ORDER(^PRCA(430,"C",RCDEBTOR,PRCAIEN))

               if 'PRCAIEN

                   QUIT

               Begin DoDot:1

 +6                IF '$DATA(^PRCA(430,"TCSP",PRCAIEN))

                       QUIT

 +7       ;PRCA*4.5*336

                   SET DA=PRCAIEN

                   SET DIE="^PRCA(430,"

                   SET DR="151////@"

                   DO ^DIE

 +8                KILL ^PRCA(430,RCBILLDA,16)

 +9                WRITE !,?4,$PIECE(^PRCA(430,PRCAIEN,0),U),"  Cleared"

               End DoDot:1

 +10       QUIT

4         ;option 4

 +1        IF $DATA(^RCD(340,"TCSP",RCDEBTOR))

               WRITE !,"*** DEBTOR ALREADY CROSS-SERVICED ***"

               QUIT

 +2        SET DIR(0)="D"

           SET DIR("A")="Enter Debtor Cross-Sevice Date"

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)!($DATA(DUOUT))

               QUIT

 +4        SET RCDATE=Y

 +5        SET DIR(0)="YA"

           SET DIR("A")="File CS Debtor Change (Y/N): "

           SET DIR("B")="N"

           SET DIR("?")="Enter (Y)es to file or (N)o to skip filing"

 +6        DO ^DIR

           KILL DIR

           IF Y=0!$GET(DIRUT)

               WRITE "   < Debtor Not Updated >"

               QUIT

 +7        SET RCDAS=RCDEBTOR_","

           SET RCDR(340,RCDAS,7.05)=RCDATE

           DO FILE^DIE("EK","RCDR","RCDERR")

           IF $DATA(RCDERR)

               WRITE "   <",$GET(RCDERR("DIERR",1,"TEXT",1)),">"

               KILL RCDERR

               GOTO 4

 +8        WRITE "  <DONE>"

 +9        QUIT

5         ;option 5

 +1        IF $DATA(^PRCA(430,"TCSP",RCBILLDA))

               WRITE !,"*** BILL ALREADY CROSS-SERVICED, DEBTOR MUST BE ALSO ***"

               QUIT

 +2        IF $DATA(^RCD(340,"TCSP",RCDEBTOR))

               WRITE !,"*** DEBTOR ALREADY CROSS-SERVICED, USE OPTION 1 TO SET BILL ***"

               QUIT

 +3        IF $DATA(^PRCA(430,RCBILLDA,30))

               WRITE !,"*** BILL RETURNED BY RECONCILIATION ***"

               QUIT

 +4        SET DIR(0)="D"

           SET DIR("A")="Enter Debtor Cross-Sevice Date"

           DO ^DIR

           KILL DIR

           if $GET(DIRUT)

               QUIT

 +5        SET RCDATE=Y

 +6        SET DIR(0)="YA"

           SET DIR("A")="File CS Debtor/Bill Change (Y/N): "

           SET DIR("B")="N"

           SET DIR("?")="Enter (Y)es to file or (N)o to skip filing"

 +7        DO ^DIR

           KILL DIR

           IF Y=0!$GET(DIRUT)

               WRITE "   < Debtor Not Updated >"

               QUIT

 +8        SET RCDAS=RCDEBTOR_","

           SET RCDR(340,RCDAS,7.05)=RCDATE

           DO FILE^DIE("EK","RCDR","RCDERR")

           IF $DATA(RCDERR)

               WRITE "   <",$GET(RCDERR("DIERR",1,"TEXT",1)),">"

               KILL RCDERR

               GOTO 5

 +9        SET ^PRCA(430,RCBILLDA,15)=""

           SET DA=RCBILLDA

           SET DIE="^PRCA(430,"

           SET DR="151////^S X=RCDATE"

           DO ^DIE

 +10      ;PRCA*4.5*336

           DO SET16

 +11       WRITE "  <DONE>",!,">>> Bill Updating for CS info... "

 +12       WRITE "fully re-established as Cross-Serviced >"

 +13       QUIT

 +14      ;

SET16     ;SET NODE 16 FOR TCSP BILL     ;PRCA*4.5*336

 +1        NEW RCXX,RCYY

 +2        SET (RCDEBTR0,DEBTOR0)=$GET(^RCD(340,RCDEBTOR,0))

           SET DEBTOR1=$GET(^RCD(340,RCDEBTOR,1))

           SET RCDFN=+RCDEBTR0

 +3        SET RCDPN16=""

           SET RCB6=$GET(^PRCA(430,RCBILLDA,6))

           SET RCB7=$GET(^(7))

           SET RCBILLDT=$PIECE($PIECE(RCB6,U,21),".")

 +4        SET TAXID=$$TAXID(RCDEBTOR)

           SET RCNAME=$$NAME(+RCDEBTR0)

           SET RCNAME=$PIECE(RCNAME,U)

 +5        SET $PIECE(RCDPN16,U)=TAXID

           SET $PIECE(RCDPN16,U,2)=RCNAME

           SET $PIECE(RCDPN16,U,3)=+RCBILLDT

 +6        SET DEBTOR=RCDEBTOR

           SET ADDRCS=$$ADDR^RCTCSP1(RCDFN,1)

           SET $PIECE(RCDPN16,U,4,8)=$PIECE(ADDRCS,U,1,5)

 +7        SET $PIECE(RCDPN16,U,12)=$SELECT($PIECE(ADDRCS,U,7)>2:$PIECE(ADDRCS,U,7),+^PRCA(430,RCBILLDA,0)=436:2,1:1)

           SET $PIECE(RCDPN16,U,13)=$PIECE(^DPT(RCDFN,0),U,3)

 +8        SET RCAMTRFD=0

           FOR I=1:1:5

               SET RCAMTRFD=RCAMTRFD+$PIECE(RCB7,U,I)

 +9        FOR I=9,10

               SET $PIECE(RCDPN16,U,I)=RCAMTRFD

 +10       SET (RCXX,RCYY)=$PIECE(ADDRCS,U,6)

 +11       IF RCXX'?10N

               Begin DoDot:1

 +12               SET RCYY=""

                   FOR I=1:1:$LENGTH(RCXX)

                       IF $EXTRACT(RCXX,I)?1N

                           SET RCYY=RCYY_$EXTRACT(RCXX,I)

               End DoDot:1

 +13       SET $PIECE(RCDPN16,U,11)=$EXTRACT("000000000000",1,10-$LENGTH(RCYY))_RCYY

 +14       SET ^PRCA(430,RCBILLDA,16)=RCDPN16

 +15       QUIT

 +16      ;

TAXID(DEBTOR) ;computes TAXID to place on documents   ;PRCA*4.5*343

 +1        NEW TAXID,DIC,DA,DR,DIQ

 +2        SET TAXID=$$SSN^RCFN01(DEBTOR)

 +3        SET TAXID=$$LJSF(TAXID,9)

 +4        QUIT TAXID

 +5       ;

NAME(DFN) ;returns name for document and name in file   ;PRCA*4.5*343

 +1        NEW FN,LN,MN,NM,DOCNM,VA,VADM

 +2        SET NM=""

 +3        DO DEM^VADPT

 +4        IF $DATA(VADM)

               SET NM=VADM(1)

 +5        SET LN=$TRANSLATE($PIECE(NM,",")," .'-")

           SET MN=$PIECE($PIECE(NM,",",2)," ",2)

 +6        IF ($EXTRACT(MN,1,2)="SR")!($EXTRACT(MN,1,2)="JR")!(MN?2.3"I")!(MN?0.1"I"1"V"1.3"I")

               SET MN=""

 +7        SET FN=$PIECE($PIECE(NM,",",2)," ")

 +8        SET DOCNM=$$LJ^XLFSTR($EXTRACT(LN,1,35),35)_$$LJ^XLFSTR($EXTRACT(FN,1,35),35)_$$LJ^XLFSTR($EXTRACT(MN,1,35),35)

 +9        QUIT DOCNM

 +10      ;

LJSF(X,Y) ;left justified space filled

 +1        SET X=$EXTRACT(X,1,Y)

 +2        SET X=X_$$BLANK(Y-$LENGTH(X))

 +3        QUIT X

 +4       ;

BLANK(X)  ;returns 'x' blank spaces

 +1        NEW BLANK

 +2        SET BLANK=""

           SET $PIECE(BLANK," ",X+1)=""

 +3        QUIT BLANK

 +4       ;

EXIT       DO KILL^XUSCLEAN

           QUIT

RCDPCSA.m