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
Q
;
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 Apr 09, 2024@20:54:13 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
