source: FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCBEUTRA.m@ 846

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

initial load of FOIAVistA 6/30/08 version
File size: 6.6 KB
Line 
1RCBEUTRA ;WISC/RFJ-utilties for transactions (in file 433) ;1 Jun 00
2 ;;4.5;Accounts Receivable;**153,169,204**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7ADD433(BILLDA,TRANTYPE) ; add a new transaction to file 433 (silent)
8 ; return: ien of 433 transaction or 0^error msg
9 ; : ^prca(433,ien) will be locked if entry selected
10 N %I,DA,DATA0,DD,DIC,DICR,DIE,DINUM,DIW,DLAYGO,DO,I,RCTRANDA,REFCODE,X,Y
11 ;
12 ; find next available transaction number
13 ; add an extra level of locks, some operating systems do not process
14 ; the locks correctly if they happen at the same time.
15 L +^PRCA(433,"ADDNEWENTRY")
16 ; start with last entry in file
17 ; -> if no data is in the entry, lock it
18 ; -> if the lock works and no data was added (prior to the lock)
19 ; -> then you have the entry.
20 ; -> otherwise, unlock it and start over
21 F DINUM=$P(^PRCA(433,0),"^",3)+1:1 I '$D(^PRCA(433,DINUM)) L +^PRCA(433,DINUM):1 Q:$T&('$D(^PRCA(433,DINUM))) L -^PRCA(433,DINUM)
22 L -^PRCA(433,"ADDNEWENTRY")
23 ;
24 ; add entry to file
25 S RCTRANDA=DINUM,(DIC,DIE)="^PRCA(433,",DIC(0)="L",DLAYGO=433,X=DINUM
26 ; build DR string, 42=processed by (use postmaster if queued)
27 S DIC("DR")="42////"_$S($D(ZTQUEUED):.5,1:DUZ)_";"
28 S DIC("DR")=DIC("DR")_".03////"_BILLDA_";" ;bill ien
29 S DIC("DR")=DIC("DR")_"12////"_TRANTYPE_";" ;transaction type
30 S DATA0=$G(^PRCA(430,BILLDA,0))
31 ; appropriation symbol
32 I $P(DATA0,"^",18)'="" S DIC("DR")=DIC("DR")_"8////"_$P(DATA0,"^",18)_";"
33 ; segment
34 I $P(DATA0,"^",21)'="" S DIC("DR")=DIC("DR")_"6////"_$P(DATA0,"^",21)_";"
35 ; test for referral code
36 S REFCODE=$P($G(^PRCA(430,BILLDA,6)),"^",5)
37 I REFCODE'="" S REFCODE=$S(REFCODE="DC":"RC",1:REFCODE),DIC("DR")=DIC("DR")_"7////"_REFCODE_";"
38 ; file it
39 D FILE^DICN
40 I Y=-1 L -^PRCA(433,RCTRANDA) Q "0^UNABLE TO ADD A NEW ENTRY TO FILE 433"
41 Q RCTRANDA
42 ;
43 ;
44FY433(RCTRANDA) ; transfer fiscal year multiple from 430 to 433
45 ; bill number must be stored in file 433, field .03 before calling
46 N BILLDA,FY,FYDATA
47 S BILLDA=+$P($G(^PRCA(433,RCTRANDA,0)),"^",2) I 'BILLDA Q
48 K ^PRCA(433,RCTRANDA,4)
49 S FY=0 F S FY=$O(^PRCA(430,BILLDA,2,FY)) Q:'FY D
50 . S FYDATA=$G(^PRCA(430,BILLDA,2,FY,0)) I $P(FYDATA,"^")="" Q
51 . S ^PRCA(433,RCTRANDA,4,FY,0)=$P(FYDATA,"^",1,3)_"^1"
52 . S ^PRCA(433,RCTRANDA,4,"B",$P(FYDATA,"^"),FY)=""
53 ;
54 S ^PRCA(433,RCTRANDA,4,0)="^433.01I^"_$P($G(^PRCA(430,BILLDA,2,0)),"^",3,4)
55 Q
56 ;
57 ;
58FYMULT(RCTRANDA) ; apply payment to fy multiple, oldest first
59 N AMOUNT,FYDA,FYAMOUNT
60 ; transfer fy multiple if not there
61 I '$D(^PRCA(433,RCTRANDA,4)) D FY433(RCTRANDA)
62 ; amount is principal amount
63 S AMOUNT=$P($$TRANVALU^RCDPBTLM(RCTRANDA),"^",2) I 'AMOUNT Q
64 ;
65 ; the transaction value is minus, decrease principal
66 I AMOUNT<0 D Q
67 . S AMOUNT=-AMOUNT
68 . S FYDA=0 F S FYDA=$O(^PRCA(433,RCTRANDA,4,FYDA)) Q:'FYDA D I 'AMOUNT Q
69 . . S FYAMOUNT=$P($G(^PRCA(433,RCTRANDA,4,FYDA,0)),"^",2)
70 . . ; fy amount is greater than transaction amount
71 . . I FYAMOUNT>AMOUNT D Q
72 . . . S $P(^PRCA(433,RCTRANDA,4,FYDA,0),"^",2)=FYAMOUNT-AMOUNT
73 . . . S $P(^PRCA(433,RCTRANDA,4,FYDA,0),"^",5)=AMOUNT
74 . . . S AMOUNT=0
75 . . ; fy amount not greater than total amount
76 . . S $P(^PRCA(433,RCTRANDA,4,FYDA,0),"^",2)=0
77 . . S $P(^PRCA(433,RCTRANDA,4,FYDA,0),"^",5)=FYAMOUNT
78 . . S AMOUNT=AMOUNT-FYAMOUNT
79 . ; move back to 430
80 . D FYMULT^RCBEUBIL(RCTRANDA)
81 ;
82 ; the transaction value is plus, increase principal
83 S FYDA=$O(^PRCA(433,RCTRANDA,4,999),-1) I 'FYDA Q
84 S $P(^PRCA(433,RCTRANDA,4,FYDA,0),"^",2)=$P(^PRCA(433,RCTRANDA,4,FYDA,0),"^",2)+AMOUNT
85 S $P(^PRCA(433,RCTRANDA,4,FYDA,0),"^",5)=AMOUNT
86 ; move back to 430
87 D FYMULT^RCBEUBIL(RCTRANDA)
88 Q
89 ;
90 ;
91EDIT433(RCTRANDA,DR) ; edit the field in 433 with the DR string passed
92 I '$D(^PRCA(433,RCTRANDA)) Q
93 N %,D,D0,D1,DA,DDH,DI,DIC,DIE,DQ,J,X,Y
94 S (DIC,DIE)="^PRCA(433,",DA=RCTRANDA
95 D ^DIE
96 ; user pressed up-arrow
97 I $D(Y) Q "0^TRANSACTION NOT COMPLETELY PROCESSED"
98 Q 1
99 ;
100 ;
101PROCESS(RCTRANDA) ; mark transaction as processed
102 I '$D(^PRCA(433,RCTRANDA,0)) Q
103 N D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
104 S (DIC,DIE)="^PRCA(433,",DA=RCTRANDA
105 S DR="3////0;4////2;"
106 D ^DIE
107 Q
108 ;
109 ;
110INCOMPLE(RCTRANDA) ; opposite of processed, make a transaction incomplete
111 I '$D(^PRCA(433,RCTRANDA,0)) Q
112 N D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
113 S (DIC,DIE)="^PRCA(433,",DA=RCTRANDA
114 S DR="4////1;"
115 D ^DIE
116 Q
117 ;
118 ;
119DEL433(RCTRANDA,COMMENT,ARCHIVE) ; delete (mark incomplete) in file 433
120 ; comment is the user comment in field 41 (default USER CANCELLED)
121 ; archive is set to 1 if called to archive transaction
122 I '$D(^PRCA(433,RCTRANDA,0)) Q
123 N %,D,D0,DA,DI,DIC,DIE,DQ,DR,J,RCBILLDA,X,Y
124 ;
125 S (DIC,DIE)="^PRCA(433,",DA=RCTRANDA
126 ; build DR string
127 S DR=""
128 S DR=DR_"4////1;" ;transaction status incomplete
129 S DR=DR_"10////1;" ;incomplete transaction flag
130 S DR=DR_"11///T;" ;transaction date
131 I $G(COMMENT)="" S COMMENT="USER CANCELLED"
132 S DR=DR_"41///"_COMMENT_";"
133 ; brief comment
134 S RCBILLDA=$P($G(^PRCA(433,RCTRANDA,0)),"^",2)
135 S DR=DR_"5.02////SYSTEM "_$S($G(ARCHIVE):"ARCHIVED",1:"INACTIVATED")_$S(RCBILLDA:" (BILL "_$P($G(^PRCA(430,RCBILLDA,0)),"^")_")",1:"")_";"
136 D ^DIE
137 ; since the bill number (field .03) is required, it must be manually removed
138 I RCBILLDA S $P(^PRCA(433,RCTRANDA,0),"^",2)="" K ^PRCA(433,"C",RCBILLDA,RCTRANDA)
139 ; remove fy multiple
140 K ^PRCA(433,RCTRANDA,4)
141 Q
142 ;
143 ;
144ADDCOMM(RCTRANDA,COMMENT) ; automatically put a comment on a transaction
145 ; comment in the array comment(1)=first line
146 ; comment(2)=second line
147 N CURRLINE,LINE
148 ; get the last line
149 S CURRLINE=$O(^PRCA(433,RCTRANDA,7,99999999),-1)
150 ; if comment already on transaction, add a blank line and
151 ; date time of new comment
152 I CURRLINE D
153 . S CURRLINE=CURRLINE+1,^PRCA(433,RCTRANDA,7,CURRLINE,0)=" "
154 . S CURRLINE=CURRLINE+1,^PRCA(433,RCTRANDA,7,CURRLINE,0)="Comment added on: "_$$FMTE^XLFDT($$NOW^XLFDT)
155 ; add new lines
156 F LINE=1:1 Q:'$D(COMMENT(LINE)) S ^PRCA(433,RCTRANDA,7,CURRLINE+LINE,0)=COMMENT(LINE)
157 ; set the 0th node
158 S ^PRCA(433,RCTRANDA,7,0)="^^"_(CURRLINE+LINE-1)_"^"_(CURRLINE+LINE-1)_"^"_DT_"^"
159 Q
160FMSDATE(X) ;Finds the next month & year and sets the date for transmission
161 ;of the document to FMS. If DT is after EOAM and the document has not
162 ;been previously transmitted, the date will be set to the first of the
163 ;next month. If the DT is after the EOAM and the document is being
164 ;re-transmitted, the the date of transmission will be DT. The flag REGEN
165 ;is set in the source code if the document is being
166 ;re-transmitted, thus will have a transmission date of DT.
167 I $G(REFMS) G QUIT
168 I DT>$$LDATE^RCRJR(DT) S X=$E($$FPS^RCAMFN01(X,1),1,5)_"01"
169QUIT Q X
Note: See TracBrowser for help on using the repository browser.