source: WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCTOP1.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.4 KB
Line 
1RCTOP1 ;WASH IRMFO@ALTOONA,PA/TJK-TOP TRANSMISSION ;2/11/00 9:36 AM
2V ;;4.5;Accounts Receivable;**141**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified
4EN1(DEBTOR,AMOUNT,CODE,EFFDT,BILL,FILE) ;ENTRY POINT TO COMPILE TYPE 1 DOCUMENTS INTO GLOBAL
5 ;NEEDS DEBTOR INTERNAL NUMBER,AMOUNT AND CODE:"M","U","Y","R","RV"
6 ;BILL WILL BE 0 FOR "M","U","Y" DOCUMENTS
7 Q:'DEBTOR Q:'FILE
8 N DEBTOR0,DEBTOR1,REC,DEBNR,ACTION,TAXID,OTAXID,NAME,ONAME,DEBTOR4
9 N DEBTOR6
10 ;
11 ;set debtor record in temporary global
12 ;
13 S DEBTOR0=$G(^RCD(340,DEBTOR,0)),DEBTOR4=$G(^(4)),DEBTOR6=$G(^(6))
14 S REC="04 "_$P(^RC(342,1,3),U,5)_" "
15 S DEBNR=$E(SITE,1,3)_$S(FILE=2:0,FILE=440:"V",1:"E")_$TR($J(DEBTOR,14)," ",0),REC=REC_DEBNR
16 S:CODE="M" ACTION="A"
17 S:CODE="Y" ACTION="Y"
18 I CODE="U" S ACTION=$S(AMOUNT>0:"I",1:"S")
19 I $E(CODE)="R" S ACTION=$$REFCD(CODE,BILL) Q:ACTION=""
20 S TAXID=$$TAXID(DEBTOR,FILE),OTAXID=$P(DEBTOR4,U)
21 S REC=REC_ACTION_1_$S(CODE="M":TAXID,1:OTAXID)
22 S NAME=$$NAME(+DEBTOR0,FILE),NM=$P(NAME,U,2),NAME=$P(NAME,U)
23 S ONAME=$P(DEBTOR4,U,2),REC=REC_$S(CODE="M":NAME,1:ONAME)
24 I CODE="U" D
25 .I NAME=ONAME,TAXID=OTAXID Q
26 .;
27 .;COMPILES ALIAS DOCUMENT IF NECESSARY
28 .;
29 .D EN1^RCTOP4(NAME,TAXID,DEBTOR4,DEBTOR,FILE)
30 .Q
31 S REC=REC_$$DATE8(EFFDT)_" "_$$AMOUNT(AMOUNT)_"MO"_$S(FILE=440:"B",1:"I")_" "
32 S REC=REC_$S('BILL:" ",1:$P(^PRCA(430,BILL,14),U,3))_$$BLANK(40)
33 S CNTR(1)=CNTR(1)+1,^XTMP("RCTOPD",$J,1,CNTR(1))=REC
34 S ^XTMP("RCTOPD",$J,"REC",NM_TAXID_"#:"_CNTR(1))=$$LJ^XLFSTR($E(NM,1,30),30)_" "_TAXID_" "_CODE_" "_$J(AMOUNT,12,2)
35 ;
36 ;set debtor, bill file data
37 ;
38 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)=""
39 I CODE="U" S $P(^(4),U,3)=$P(^RCD(340,DEBTOR,4),U,3)+AMOUNT,$P(^(4),U,6)=EFFDT
40 I $E(CODE)="R" S DIE="^PRCA(430,",DA=BILL,DR="142///^S X=$S(CODE=""R"":2,1:4)" D ^DIE
41 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
42 Q
43 ;
44DATE8(X) ;changes fileman date into 8 digit date yyyymmdd
45 S X=DT+17000000
46 Q X
47 ;
48AMOUNT(X) ;changes amount to zero filled, right justified
49 S:X<0 X=-X
50 S X=$TR($J(X,0,2),".")
51 S X=$E("000000000000",1,12-$L(X))_X
52 Q X
53 ;
54NAME(DEBTOR,FILE) ;returns name for document and name in file
55 N FN,LN,MN,NM,DOCNM
56 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
57 S NM=$S(FILE=2:$P($G(^DPT(DEBTOR,0)),"^"),1:$P($G(^VA(200,DEBTOR,0)),U))
58 S LN=$TR($P(NM,",")," .'-"),MN=$P($P(NM,",",2)," ",2)
59 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=""
60 S FN=$P($P(NM,",",2)," ")
61DOCNM S DOCNM=$$LJ^XLFSTR($E(LN,1,35),35)_$$LJ^XLFSTR($E(FN,1,35),35)_$S(MN="":" ",1:$E(MN))
62QNM Q DOCNM_U_NM
63 ;
64BLANK(X) ;returns 'x' blank spaces
65 N BLANK
66 S BLANK="",$P(BLANK," ",X+1)=""
67 Q BLANK
68 ;
69TAXID(DEBTOR,FILE) ;computes tax id (tid) to place on documents
70 N TAXID,DIC,DA,DR,DIQ
71 I FILE'=440 S TAXID=$$SSN^RCFN01(DEBTOR) G TAXIDQ
72 S DIC="^PRC(440,",DA=+^RCD(340,DEBTOR,0),DR="38",DIQ="TAXID(",DIQ(0)="E"
73 D EN^DIQ1 S TAXID=TAXID(440,DA,38,"E")
74TAXIDQ S:$L(TAXID)'=9 TAXID=" "
75 Q TAXID
76 ;
77REFCD(CODE,BILL) ;computes action code for refund/refund reversal documents
78 N REFYR,REFCD,X
79 S REFCD="",REFYR=$P($G(^PRCA(430,BILL,14)),U,4)
80 S:'REFYR REFYR=$E(DT,1,3)+1700
81 S X="",X=$O(^RC(348.2,"B",REFYR,X)) G REFCDQ:'X
82 S REFCD=$S(CODE="R":$P(^RC(348.2,X,0),U,2),1:$P(^RC(348.2,X,0),U,3))
83REFCDQ Q REFCD
Note: See TracBrowser for help on using the repository browser.