Routine: RCTOP1

RCTOP1 ;WASH IRMFO@ALTOONA,PA/TJK-TOP TRANSMISSION ;2/11/00  9:36 AM

V ;;4.5;Accounts Receivable;**141**;Mar 20, 1995

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

EN1(DEBTOR,AMOUNT,CODE,EFFDT,BILL,FILE) ;ENTRY POINT TO COMPILE TYPE 1 DOCUMENTS INTO GLOBAL

 ;NEEDS DEBTOR INTERNAL NUMBER,AMOUNT  AND CODE:"M","U","Y","R","RV"

 ;BILL WILL BE 0 FOR "M","U","Y" DOCUMENTS

 Q:'DEBTOR  Q:'FILE

 N DEBTOR0,DEBTOR1,REC,DEBNR,ACTION,TAXID,OTAXID,NAME,ONAME,DEBTOR4

 N DEBTOR6

 ;set debtor record in temporary global

 S DEBTOR0=$G(^RCD(340,DEBTOR,0)),DEBTOR4=$G(^(4)),DEBTOR6=$G(^(6))

 S REC="04      "_$P(^RC(342,1,3),U,5)_"      "

 S DEBNR=$E(SITE,1,3)_$S(FILE=2:0,FILE=440:"V",1:"E")_$TR($J(DEBTOR,14)," ",0),REC=REC_DEBNR

 S:CODE="M" ACTION="A"

 S:CODE="Y" ACTION="Y"

 I CODE="U" S ACTION=$S(AMOUNT>0:"I",1:"S")

 I $E(CODE)="R" S ACTION=$$REFCD(CODE,BILL) Q:ACTION=""

 S TAXID=$$TAXID(DEBTOR,FILE),OTAXID=$P(DEBTOR4,U)

 S REC=REC_ACTION_1_$S(CODE="M":TAXID,1:OTAXID)

 S NAME=$$NAME(+DEBTOR0,FILE),NM=$P(NAME,U,2),NAME=$P(NAME,U)

 S ONAME=$P(DEBTOR4,U,2),REC=REC_$S(CODE="M":NAME,1:ONAME)

 I CODE="U" D

    .I NAME=ONAME,TAXID=OTAXID Q

.;

    .;COMPILES ALIAS DOCUMENT IF NECESSARY

.;

    .D EN1^RCTOP4(NAME,TAXID,DEBTOR4,DEBTOR,FILE)

.Q

 S REC=REC_$$DATE8(EFFDT)_"          "_$$AMOUNT(AMOUNT)_"MO"_$S(FILE=440:"B",1:"I")_" "

 S REC=REC_$S('BILL:"          ",1:$P(^PRCA(430,BILL,14),U,3))_$$BLANK(40)

 S CNTR(1)=CNTR(1)+1,^XTMP("RCTOPD",$J,1,CNTR(1))=REC

 S ^XTMP("RCTOPD",$J,"REC",NM_TAXID_"#:"_CNTR(1))=$$LJ^XLFSTR($E(NM,1,30),30)_"   "_TAXID_"   "_CODE_"   "_$J(AMOUNT,12,2)

 ;set debtor, bill file data

 I CODE="M" S $P(^RCD(340,DEBTOR,4),U)=TAXID,$P(^(4),U,2)=NAME,$P(^(4),U,3)=AMOUNT,$P(^(4),U,6)=EFFDT,$P(^(6),U)=DT,^RCD(340,"TOP",DEBTOR,DT)=""

 I CODE="U" S $P(^(4),U,3)=$P(^RCD(340,DEBTOR,4),U,3)+AMOUNT,$P(^(4),U,6)=EFFDT

 I $E(CODE)="R" S DIE="^PRCA(430,",DA=BILL,DR="142///^S X=$S(CODE=""R"":2,1:4)" D ^DIE

 S I=0 F  S I=$O(^TMP("RCTOPD",$J,"BILL",I)) Q:I'?1N.N  S:'$P($G(^PRCA(430,I,14)),U) $P(^(14),U)=DT

DATE8(X) ;changes fileman date into 8 digit date yyyymmdd

 S X=DT+17000000

Q X

AMOUNT(X) ;changes amount to zero filled, right justified

 S:X<0 X=-X

 S X=$TR($J(X,0,2),".")

 S X=$E("000000000000",1,12-$L(X))_X

Q X

NAME(DEBTOR,FILE) ;returns name for document and name in file

 N FN,LN,MN,NM,DOCNM

 I FILE=440 S NM=$P($G(^PRC(440,DEBTOR,0)),U),MN="",LN=$E(NM,1,35),FN=$E(NM,36,70) G DOCNM

 S NM=$S(FILE=2:$P($G(^DPT(DEBTOR,0)),"^"),1:$P($G(^VA(200,DEBTOR,0)),U))

 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)," ")

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

QNM Q DOCNM_U_NM

BLANK(X) ;returns 'x' blank spaces

 N BLANK

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

 Q BLANK

TAXID(DEBTOR,FILE) ;computes tax id (tid) to place on documents

 N TAXID,DIC,DA,DR,DIQ

 I FILE'=440 S TAXID=$$SSN^RCFN01(DEBTOR) G TAXIDQ

 S DIC="^PRC(440,",DA=+^RCD(340,DEBTOR,0),DR="38",DIQ="TAXID(",DIQ(0)="E"

 D EN^DIQ1 S TAXID=TAXID(440,DA,38,"E")

TAXIDQ S:$L(TAXID)'=9 TAXID="         "

 Q TAXID

REFCD(CODE,BILL) ;computes action code for refund/refund reversal documents

 N REFYR,REFCD,X

 S REFCD="",REFYR=$P($G(^PRCA(430,BILL,14)),U,4)

 S:'REFYR REFYR=$E(DT,1,3)+1700

 S X="",X=$O(^RC(348.2,"B",REFYR,X)) G REFCDQ:'X

 S REFCD=$S(CODE="R":$P(^RC(348.2,X,0),U,2),1:$P(^RC(348.2,X,0),U,3))

REFCDQ Q REFCD

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCTOP1   3595     printed  Feb 18, 2025@23:15:27                                                                                                                                                                                                      Page 2

RCTOP1    ;WASH IRMFO@ALTOONA,PA/TJK-TOP TRANSMISSION ;2/11/00  9:36 AM

V         ;;4.5;Accounts Receivable;**141**;Mar 20, 1995

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

EN1(DEBTOR,AMOUNT,CODE,EFFDT,BILL,FILE) ;ENTRY POINT TO COMPILE TYPE 1 DOCUMENTS INTO GLOBAL

 +1       ;NEEDS DEBTOR INTERNAL NUMBER,AMOUNT  AND CODE:"M","U","Y","R","RV"

 +2       ;BILL WILL BE 0 FOR "M","U","Y" DOCUMENTS

 +3        if 'DEBTOR

               QUIT

           if 'FILE

               QUIT

 +4        NEW DEBTOR0,DEBTOR1,REC,DEBNR,ACTION,TAXID,OTAXID,NAME,ONAME,DEBTOR4

 +5        NEW DEBTOR6

 +6       ;

 +7       ;set debtor record in temporary global

 +8       ;

 +9        SET DEBTOR0=$GET(^RCD(340,DEBTOR,0))

           SET DEBTOR4=$GET(^(4))

           SET DEBTOR6=$GET(^(6))

 +10       SET REC="04      "_$PIECE(^RC(342,1,3),U,5)_"      "

 +11       SET DEBNR=$EXTRACT(SITE,1,3)_$SELECT(FILE=2:0,FILE=440:"V",1:"E")_$TRANSLATE($JUSTIFY(DEBTOR,14)," ",0)

           SET REC=REC_DEBNR

 +12       if CODE="M"

               SET ACTION="A"

 +13       if CODE="Y"

               SET ACTION="Y"

 +14       IF CODE="U"

               SET ACTION=$SELECT(AMOUNT>0:"I",1:"S")

 +15       IF $EXTRACT(CODE)="R"

               SET ACTION=$$REFCD(CODE,BILL)

               if ACTION=""

                   QUIT

 +16       SET TAXID=$$TAXID(DEBTOR,FILE)

           SET OTAXID=$PIECE(DEBTOR4,U)

 +17       SET REC=REC_ACTION_1_$SELECT(CODE="M":TAXID,1:OTAXID)

 +18       SET NAME=$$NAME(+DEBTOR0,FILE)

           SET NM=$PIECE(NAME,U,2)

           SET NAME=$PIECE(NAME,U)

 +19       SET ONAME=$PIECE(DEBTOR4,U,2)

           SET REC=REC_$SELECT(CODE="M":NAME,1:ONAME)

 +20       IF CODE="U"

               Begin DoDot:1

 +21               IF NAME=ONAME

                       IF TAXID=OTAXID

                           QUIT

 +22      ;

 +23      ;COMPILES ALIAS DOCUMENT IF NECESSARY

 +24      ;

 +25               DO EN1^RCTOP4(NAME,TAXID,DEBTOR4,DEBTOR,FILE)

 +26               QUIT

               End DoDot:1

 +27       SET REC=REC_$$DATE8(EFFDT)_"          "_$$AMOUNT(AMOUNT)_"MO"_$SELECT(FILE=440:"B",1:"I")_" "

 +28       SET REC=REC_$SELECT('BILL:"          ",1:$PIECE(^PRCA(430,BILL,14),U,3))_$$BLANK(40)

 +29       SET CNTR(1)=CNTR(1)+1

           SET ^XTMP("RCTOPD",$JOB,1,CNTR(1))=REC

 +30       SET ^XTMP("RCTOPD",$JOB,"REC",NM_TAXID_"#:"_CNTR(1))=$$LJ^XLFSTR($EXTRACT(NM,1,30),30)_"   "_TAXID_"   "_CODE_"   "_$JUSTIFY(AMOUNT,12,2)

 +31      ;

 +32      ;set debtor, bill file data

 +33      ;

 +34       IF CODE="M"

               SET $PIECE(^RCD(340,DEBTOR,4),U)=TAXID

               SET $PIECE(^(4),U,2)=NAME

               SET $PIECE(^(4),U,3)=AMOUNT

               SET $PIECE(^(4),U,6)=EFFDT

               SET $PIECE(^(6),U)=DT

               SET ^RCD(340,"TOP",DEBTOR,DT)=""

 +35       IF CODE="U"

               SET $PIECE(^(4),U,3)=$PIECE(^RCD(340,DEBTOR,4),U,3)+AMOUNT

               SET $PIECE(^(4),U,6)=EFFDT

 +36       IF $EXTRACT(CODE)="R"

               SET DIE="^PRCA(430,"

               SET DA=BILL

               SET DR="142///^S X=$S(CODE=""R"":2,1:4)"

               DO ^DIE

 +37       SET I=0

FOR

               SET I=$ORDER(^TMP("RCTOPD",$JOB,"BILL",I))

               if I'?1N.N

                   QUIT

               if '$PIECE($GET(^PRCA(430,I,14)),U)

                   SET $PIECE(^(14),U)=DT

 +38       QUIT

 +39      ;

DATE8(X)  ;changes fileman date into 8 digit date yyyymmdd

 +1        SET X=DT+17000000

 +2        QUIT X

 +3       ;

AMOUNT(X) ;changes amount to zero filled, right justified

 +1        if X<0

               SET X=-X

 +2        SET X=$TRANSLATE($JUSTIFY(X,0,2),".")

 +3        SET X=$EXTRACT("000000000000",1,12-$LENGTH(X))_X

 +4        QUIT X

 +5       ;

NAME(DEBTOR,FILE) ;returns name for document and name in file

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

 +2        IF FILE=440

               SET NM=$PIECE($GET(^PRC(440,DEBTOR,0)),U)

               SET MN=""

               SET LN=$EXTRACT(NM,1,35)

               SET FN=$EXTRACT(NM,36,70)

               GOTO DOCNM

 +3        SET NM=$SELECT(FILE=2:$PIECE($GET(^DPT(DEBTOR,0)),"^"),1:$PIECE($GET(^VA(200,DEBTOR,0)),U))

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

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

 +5        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=""

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

DOCNM      SET DOCNM=$$LJ^XLFSTR($EXTRACT(LN,1,35),35)_$$LJ^XLFSTR($EXTRACT(FN,1,35),35)_$SELECT(MN="":" ",1:$EXTRACT(MN))

QNM        QUIT DOCNM_U_NM

 +1       ;

BLANK(X)  ;returns 'x' blank spaces

 +1        NEW BLANK

 +2        SET BLANK=""

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

 +3        QUIT BLANK

 +4       ;

TAXID(DEBTOR,FILE) ;computes tax id (tid) to place on documents

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

 +2        IF FILE'=440

               SET TAXID=$$SSN^RCFN01(DEBTOR)

               GOTO TAXIDQ

 +3        SET DIC="^PRC(440,"

           SET DA=+^RCD(340,DEBTOR,0)

           SET DR="38"

           SET DIQ="TAXID("

           SET DIQ(0)="E"

 +4        DO EN^DIQ1

           SET TAXID=TAXID(440,DA,38,"E")

TAXIDQ     if $LENGTH(TAXID)'=9

               SET TAXID="         "

 +1        QUIT TAXID

 +2       ;

REFCD(CODE,BILL) ;computes action code for refund/refund reversal documents

 +1        NEW REFYR,REFCD,X

 +2        SET REFCD=""

           SET REFYR=$PIECE($GET(^PRCA(430,BILL,14)),U,4)

 +3        if 'REFYR

               SET REFYR=$EXTRACT(DT,1,3)+1700

 +4        SET X=""

           SET X=$ORDER(^RC(348.2,"B",REFYR,X))

           if 'X

               GOTO REFCDQ

 +5        SET REFCD=$SELECT(CODE="R":$PIECE(^RC(348.2,X,0),U,2),1:$PIECE(^RC(348.2,X,0),U,3))

REFCDQ     QUIT REFCD

RCTOP1.m