source: WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPXPAP.m@ 923

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

initial load of WorldVistAEHR
File size: 7.3 KB
Line 
1RCDPXPAP ;WISC/RFJ-automatically process the deposits ;1 Jun 99
2 ;;4.5;Accounts Receivable;**114,150,206**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7PROCESS(RCDPDATE,RCPAYDA) ; process the deposits
8 ; rcdpdate is the transmission date; rcpayda is ien for the payment
9 ; type found in ^rc(341.1,rcpayda)
10 N DR,PAYDESC,RCDEPDAT,RCDEPOSI,RCDEPTDA,RCDFN,RCDPDATA,RCLINE,RCRECTDA,RCTRANDA,STATUS
11 K ^TMP($J,"RCDPXPAP")
12 ;
13 ; file the data in the payment files 344 and 344.1
14 ; tmp global = acct number(1) ^ amount(2) ^ batch#(3) ^ sequence#(4) ^
15 ; pay type(5) ^ pay desc fields(6)
16 S RCDEPOSI="" F S RCDEPOSI=$O(^TMP($J,"RCDPXPAY","DEPOSIT",RCDEPOSI)) Q:RCDEPOSI="" D
17 . S RCDEPDAT=$G(^TMP($J,"RCDPXPAY","DEPDATE",RCDEPOSI))
18 . ; add the deposit if not already in file
19 . ; make sure deposit is 6 characters in length
20 . S X=$E("000000",1,6-$L(RCDEPOSI))_RCDEPOSI
21 . S RCDEPTDA=$$ADDDEPT^RCDPUDEP(X,RCDEPDAT)
22 . I 'RCDEPTDA D ERROR^RCDPXPAM(RCDPDATE,RCDPXMZ,"Unable to ADD deposit "_RCDEPOSI_" to the AR DEPOSIT file #344.1") Q
23 . ;
24 . ; lock deposit
25 . L +^RCY(344.1,RCDEPTDA)
26 . ; confirm deposit (close it to prevent modifications to it)
27 . D CONFIRM^RCDPUDEP(RCDEPTDA)
28 . ; store the deposit for unlocking below
29 . S ^TMP($J,"RCDPXPAP","DEPOSITLOCK",RCDEPTDA)=""
30 . ;
31 . ; create receipt for transmission date and deposit
32 . S RCRECTDA=$$ADDRECT^RCDPUREC(RCDPDATE,RCDEPTDA,RCPAYDA)
33 . I 'RCRECTDA D ERROR^RCDPXPAM(RCDPDATE,RCDPXMZ,"Unable to ADD receipt "_RCDPDATE_" to the AR BATCH PAYMENT file #344") Q
34 . ;
35 . ; lock receipt
36 . L +^RCY(344,RCRECTDA)
37 . ; check to see if receipt has been processed (fms document)
38 . D DIQ344^RCDPRPLM(RCRECTDA,"200;")
39 . ; code sheet already sent once, this is a retransmission, check it
40 . I RCDPDATA(344,RCRECTDA,200,"E")'="" D
41 . . S STATUS=$$STATUS^GECSSGET(RCDPDATA(344,RCRECTDA,200,"E"))
42 . . ; okay to continue if status is Error, Rejected, or not defined (-1)
43 . . I $E(STATUS)="E"!($E(STATUS)="R")!(STATUS=-1) Q
44 . . S ^TMP($J,"RCDPXPAP","DUPLICATE",RCRECTDA)="Receipt Not Changed^1"
45 . I $D(^TMP($J,"RCDPXPAP","DUPLICATE",RCRECTDA)) L -^RCY(344,RCRECTDA) Q
46 . ;
47 . ; mark receipt as processed (closed) to prevent editing
48 . D MARKPROC^RCDPUREC(RCRECTDA,"")
49 . ; store the receipt for automatic processing (and unlock) below
50 . ; the 0 is the count of unlinked accts displayed in mail message
51 . S ^TMP($J,"RCDPXPAP","PROCESS",RCRECTDA)=0
52 . ;
53 . ; build a list of the current stored payments by batch_sequence
54 . ; number to prevent adding duplicates
55 . K ^TMP($J,"RCDPXPAP",RCRECTDA)
56 . S RCLINE=0 F S RCLINE=$O(^RCY(344,RCRECTDA,1,RCLINE)) Q:'RCLINE D
57 . . S RCDPDATA=$G(^RCY(344,RCRECTDA,1,RCLINE,2))
58 . . I '$P(RCDPDATA,"^",2)!('$P(RCDPDATA,"^",3)) Q
59 . . S ^TMP($J,"RCDPXPAP",RCRECTDA,$P(RCDPDATA,"^",2),$P(RCDPDATA,"^",3))=RCLINE
60 . ;
61 . ; loop transactions and add them to the receipt
62 . S RCLINE=0 F S RCLINE=$O(^TMP($J,"RCDPXPAY","DEPOSIT",RCDEPOSI,RCLINE)) Q:'RCLINE D
63 . . ; data in the form:
64 . . ; acct lookup(1) ^ amount(2) ^ batch(3) ^ sequence(4) ^
65 . . ; payment type(5) ^ payment description(6)
66 . . S RCDPDATA=^TMP($J,"RCDPXPAY","DEPOSIT",RCDEPOSI,RCLINE)
67 . . ; if batch and sequence number already stored get current entry
68 . . ; and do not add a new one
69 . . S RCTRANDA=0
70 . . I $P(RCDPDATA,"^",3),$P(RCDPDATA,"^",4) S RCTRANDA=+$G(^TMP($J,"RCDPXPAP",RCRECTDA,+$P(RCDPDATA,"^",3),+$P(RCDPDATA,"^",4)))
71 . . I 'RCTRANDA S RCTRANDA=+$$ADDTRAN^RCDPURET(RCRECTDA)
72 . . I 'RCTRANDA D ERROR^RCDPXPAM(RCDPDATE,RCDPXMZ,"Unable to ADD a new transaction to the AR BATCH PAYMENT file #344") Q
73 . . ;
74 . . ; if the entry has already been processed, do not make any changes
75 . . I $P(^RCY(344,RCRECTDA,1,RCTRANDA,0),"^",5) S:'$D(^TMP($J,"RCDPXPAP","DUPLICATE",RCRECTDA)) ^(RCRECTDA)="Receipt Not Changed" Q
76 . . I $D(^TMP($J,"RCDPXPAP","DUPLICATE",RCRECTDA)) S ^(RCRECTDA)="Receipt Updated"
77 . . ;
78 . . ; lookup account
79 . . S RCDFN=$$FINDACCT($P(RCDPDATA,"^"))_";DPT("
80 . . ; acct not found, count as unlinked for mail message
81 . . I 'RCDFN S ^TMP($J,"RCDPXPAP","PROCESS",RCRECTDA)=^TMP($J,"RCDPXPAP","PROCESS",RCRECTDA)+1
82 . . ;
83 . . ; build dr string to store the data
84 . . S DR=".21////"_$P(RCDPDATA,"^")_";" ;account
85 . . I RCDFN S DR=DR_".03////^S X=RCDFN;.09////^S X=RCDFN;"
86 . . S DR=DR_".22////"_+$P(RCDPDATA,"^",3)_";" ;batch number
87 . . S DR=DR_".23////"_+$P(RCDPDATA,"^",4)_";" ;sequence number
88 . . S DR=DR_".24////"_$P(RCDPDATA,"^",5)_";" ;payment type
89 . . S DR=DR_".04////"_($P(RCDPDATA,"^",2)/100)_";" ;payment amount
90 . . S DR=DR_".06////"_RCDEPDAT_";" ;payment date = deposit date
91 . . ;
92 . . S PAYDESC=$P(RCDPDATA,"^",6)
93 . . ; payment type check
94 . . I $P(RCDPDATA,"^",5)=2 D
95 . . . ; check number : account number : bank routing number
96 . . . I $P(PAYDESC,":")'="" S DR=DR_".07////"_$P(PAYDESC,":")_";"
97 . . . I $P(PAYDESC,":",2)'="" S DR=DR_".13////"_$P(PAYDESC,":",2)_";"
98 . . . I $P(PAYDESC,":",3)'="" S DR=DR_".08////"_$P(PAYDESC,":",3)_";"
99 . . ; payment type credit, store credit card number
100 . . I $P(RCDPDATA,"^",5)=3,$P(PAYDESC,":")'="" S DR=DR_".11////"_$P(PAYDESC,":")_";"
101 . . ;
102 . . ; store the payment under the receipt
103 . . D FILETRAN(RCRECTDA,RCTRANDA,DR)
104 ;
105 ; automatically process the receipts added
106 ; ^tmp($j,"rcdpxpap","process",receiptda)=""
107 S RCRECTDA=0 F S RCRECTDA=$O(^TMP($J,"RCDPXPAP","PROCESS",RCRECTDA)) Q:'RCRECTDA D
108 . D PROCESS^RCDPURE1(RCRECTDA,0)
109 . ; clear the lock (set above)
110 . L -^RCY(344,RCRECTDA)
111 ;
112 ; clear all locked deposits
113 S RCDEPTDA=0 F S RCDEPTDA=$O(^TMP($J,"RCDPXPAP","DEPOSITLOCK",RCDEPTDA)) Q:'RCDEPTDA D
114 . ; confirm deposit (recalc totals)
115 . D CONFIRM^RCDPUDEP(RCDEPTDA)
116 . L -^RCY(344.1,RCDEPTDA)
117 ;
118 ; send a message to the users showing what was processed
119 D PROCMSG^RCDPXPAM
120 ;
121 ; need to delete the 344.2 entry
122 D DELETRAN^RCDPXPA1(RCDPDATE)
123 ;
124 K ^TMP($J,"RCDPXPAP")
125 Q
126 ;
127 ;
128FINDACCT(ACCT) ; lookup the patient and return the dfn
129 ; if more than one patient matches acct, return null
130 ; acct in the form 123456789ABCDE
131 I ACCT'?9N1.5A D Q DFN
132 . S DFN=+ACCT I $G(^DPT(DFN,0))'="" Q
133 . S DFN=$E(DFN,1,10)_"."_$E(DFN,11,99) I $G(^DPT(DFN,0))'="" Q
134 . S DFN=0
135 . ;
136 N COUNT,DFN,FOUND,NAME,SSN
137 S SSN=$E(ACCT,1,9),NAME=$E(ACCT,10,99)
138 I SSN="" Q 0
139 S NAME=$TR(NAME,"/","'")
140 S COUNT=0 ;used to count number of matches
141 S FOUND=0 ;used to store matching acct's DFN number
142 S DFN=0 F S DFN=$O(^DPT("SSN",SSN,DFN)) Q:'DFN I $E($TR($P($G(^DPT(DFN,0)),"^")," "),1,$L(NAME))=NAME S COUNT=COUNT+1,FOUND=DFN
143 ; multiple acct matches, return null
144 I COUNT>1 Q 0
145 ; acct found, return dfn of account which matches
146 I FOUND Q FOUND
147 ; try looking up the name without the apostrophe
148 S NAME=$TR(NAME,"'")
149 S DFN=0 F S DFN=$O(^DPT("SSN",SSN,DFN)) Q:'DFN I $E($TR($P($G(^DPT(DFN,0)),"^")," "),1,$L(NAME))=NAME S COUNT=COUNT+1,FOUND=DFN
150 ; multiple acct matches, return null
151 I COUNT>1 Q 0
152 ; return dfn of account which matches, or 0 if not found
153 Q +FOUND
154 ;
155 ;
156FILETRAN(RECTDA,TRANDA,DR) ; file the payment transaction
157 N %,D,D0,D1,DA,DI,DIC,DICR,DIE,DIG,DIH,DIU,DIV,DIW,DQ,X,Y
158 S (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
159 S DA=TRANDA,DA(1)=RECTDA
160 D ^DIE
161 Q
Note: See TracBrowser for help on using the repository browser.