RCDPXPAP ;WISC/RFJ-CS automatically process the deposits ;1 Jun 99
;;4.5;Accounts Receivable;**114,150,206,296,301**;Mar 20, 1995;Build 144
;;Per VA Directive 6402, this routine should not be modified.
Q
;
;PRCA*4.5*301 Add check for valid billing # on CS 170 transactions
; and create suspense entry if invalid.
;
PROCESS(RCDPDATE,RCPAYDA) ; process the deposits
; rcdpdate is the transmission date; rcpayda is ien for the payment
; type found in ^rc(341.1,rcpayda)
N DR,PAYDESC,RCDEPDAT,RCDEPOSI,RCDEPTDA,RCDFN,RCDPDATA,RCLINE,RCRECTDA,RCTRANDA,STATUS
K ^TMP($J,"RCDPXPAP")
;
; file the data in the payment files 344 (AR BATCH PAYMENT) and 344.1 (AR DEPOSIT)
; tmp global = acct number(1) ^ amount(2) ^ batch#(3) ^ sequence#(4) ^
; pay type(5) ^ pay desc fields(6)
S RCDEPOSI="" F S RCDEPOSI=$O(^TMP($J,"RCDPXPAY","DEPOSIT",RCDEPOSI)) Q:RCDEPOSI="" D
. S RCDEPDAT=$G(^TMP($J,"RCDPXPAY","DEPDATE",RCDEPOSI))
. ; *296 - event type 'a' or 't' or 'p' based on the prefix deposit #
. N RCDETY S RCDETY=+$E(RCDEPOSI,1,3)
. S RCPAYDA=$S(RCDETY=168:15,RCDETY=169:13,RCDETY=170:16,1:$G(RCPAYDA))
. ;
. ; add the deposit if not already in file
. ; make sure deposit is 6 characters in length
. S X=$E("000000",1,6-$L(RCDEPOSI))_RCDEPOSI
. S RCDEPTDA=$$ADDDEPT^RCDPUDEP(X,RCDEPDAT)
. I 'RCDEPTDA D ERROR^RCDPXPAM(RCDPDATE,RCDPXMZ,"Unable to ADD deposit "_RCDEPOSI_" to the AR DEPOSIT file #344.1") Q
. ;
. ; lock deposit
. L +^RCY(344.1,RCDEPTDA)
. ; confirm deposit (close it to prevent modifications to it)
. D CONFIRM^RCDPUDEP(RCDEPTDA)
. ; store the deposit for unlocking below
. S ^TMP($J,"RCDPXPAP","DEPOSITLOCK",RCDEPTDA)=""
. ;
. ; create receipt for transmission date and deposit
. S RCRECTDA=$$ADDRECT^RCDPUREC(RCDPDATE,RCDEPTDA,RCPAYDA)
. I 'RCRECTDA D ERROR^RCDPXPAM(RCDPDATE,RCDPXMZ,"Unable to ADD receipt "_RCDPDATE_" to the AR BATCH PAYMENT file #344") Q
. ;
. ; lock receipt
. L +^RCY(344,RCRECTDA)
. ; check to see if receipt has been processed (fms document)
. D DIQ344^RCDPRPLM(RCRECTDA,"200;")
. ; code sheet already sent once, this is a retransmission, check it
. I RCDPDATA(344,RCRECTDA,200,"E")'="" D
. . S STATUS=$$STATUS^GECSSGET(RCDPDATA(344,RCRECTDA,200,"E"))
. . ; okay to continue if status is Error, Rejected, or not defined (-1)
. . I $E(STATUS)="E"!($E(STATUS)="R")!(STATUS=-1) Q
. . S ^TMP($J,"RCDPXPAP","DUPLICATE",RCRECTDA)="Receipt Not Changed^1"
. I $D(^TMP($J,"RCDPXPAP","DUPLICATE",RCRECTDA)) L -^RCY(344,RCRECTDA) Q
. ;
. ; mark receipt as processed (closed) to prevent editing
. D MARKPROC^RCDPUREC(RCRECTDA,"")
. ; store the receipt for automatic processing (and unlock) below
. ; the 0 is the count of unlinked accts displayed in mail message
. S ^TMP($J,"RCDPXPAP","PROCESS",RCRECTDA)=0
. ;
. ; build a list of the current stored payments by batch_sequence
. ; number to prevent adding duplicates
. K ^TMP($J,"RCDPXPAP",RCRECTDA)
. S RCLINE=0 F S RCLINE=$O(^RCY(344,RCRECTDA,1,RCLINE)) Q:'RCLINE D
. . S RCDPDATA=$G(^RCY(344,RCRECTDA,1,RCLINE,2))
. . I '$P(RCDPDATA,"^",2)!('$P(RCDPDATA,"^",3)) Q
. . S ^TMP($J,"RCDPXPAP",RCRECTDA,$P(RCDPDATA,"^",2),$P(RCDPDATA,"^",3))=RCLINE
. ;
. ; loop transactions and add them to the receipt
. S RCLINE=0 F S RCLINE=$O(^TMP($J,"RCDPXPAY","DEPOSIT",RCDEPOSI,RCLINE)) Q:'RCLINE D
. . ; data in the form:
. . ; acct lookup(1) ^ amount(2) ^ batch(3) ^ sequence(4) ^
. . ; payment type(5) ^ payment description(6)
. . S RCDPDATA=^TMP($J,"RCDPXPAY","DEPOSIT",RCDEPOSI,RCLINE)
. . ; if batch and sequence number already stored get current entry
. . ; and do not add a new one
. . S RCTRANDA=0
. . I $P(RCDPDATA,"^",3),$P(RCDPDATA,"^",4) S RCTRANDA=+$G(^TMP($J,"RCDPXPAP",RCRECTDA,+$P(RCDPDATA,"^",3),+$P(RCDPDATA,"^",4)))
. . I 'RCTRANDA S RCTRANDA=+$$ADDTRAN^RCDPURET(RCRECTDA)
. . I 'RCTRANDA D ERROR^RCDPXPAM(RCDPDATE,RCDPXMZ,"Unable to ADD a new transaction to the AR BATCH PAYMENT file #344") Q
. . ;
. . ; if the entry has already been processed, do not make any changes
. . I $P(^RCY(344,RCRECTDA,1,RCTRANDA,0),"^",5) S:'$D(^TMP($J,"RCDPXPAP","DUPLICATE",RCRECTDA)) ^(RCRECTDA)="Receipt Not Changed" Q
. . I $D(^TMP($J,"RCDPXPAP","DUPLICATE",RCRECTDA)) S ^(RCRECTDA)="Receipt Updated"
. . ;
. . ; lookup account
. . S RCDFN=$$FINDACCT($P(RCDPDATA,"^"))_";DPT("
. . ; acct not found, count as unlinked for mail message
. . I 'RCDFN S ^TMP($J,"RCDPXPAP","PROCESS",RCRECTDA)=^TMP($J,"RCDPXPAP","PROCESS",RCRECTDA)+1
. . ;
. . ; build dr string to store the data
. . S DR=".21////"_$P(RCDPDATA,"^")_";" ;account
. . I RCDFN S DR=DR_".03////^S X=RCDFN;.09////^S X=RCDFN;"
. . S DR=DR_".22////"_+$P(RCDPDATA,"^",3)_";" ;batch number
. . S DR=DR_".23////"_+$P(RCDPDATA,"^",4)_";" ;sequence number
. . S DR=DR_".24////"_$P(RCDPDATA,"^",5)_";" ;payment type
. . S DR=DR_".04////"_($P(RCDPDATA,"^",2)/100)_";" ;payment amount
. . S DR=DR_".06////"_RCDEPDAT_";" ;payment date = deposit date
. . ;
. . S PAYDESC=$P(RCDPDATA,"^",6)
. . ; payment type check
. . I $P(RCDPDATA,"^",5)=2 D
. . . ; check number : account number : bank routing number
. . . I $P(PAYDESC,":")'="" S DR=DR_".07////"_$P(PAYDESC,":")_";"
. . . I $P(PAYDESC,":",2)'="" S DR=DR_".13////"_$P(PAYDESC,":",2)_";"
. . . I $P(PAYDESC,":",3)'="" S DR=DR_".08////"_$P(PAYDESC,":",3)_";"
. . ; payment type credit, store credit card number
. . I $P(RCDPDATA,"^",5)=3,$P(PAYDESC,":")'="" S DR=DR_".11////"_$P(PAYDESC,":")_";"
. . ;
. . ; store the payment under the receipt
. . D FILETRAN(RCRECTDA,RCTRANDA,DR)
. . S $P(^RCY(344,RCRECTDA,1,RCTRANDA,0),"^",19)=$P(RCDPDATA,"^",7) ;PRCA*4.5*301
;
; automatically process the receipts added
; ^tmp($j,"rcdpxpap","process",receiptda)=""
S RCRECTDA=0 F S RCRECTDA=$O(^TMP($J,"RCDPXPAP","PROCESS",RCRECTDA)) Q:'RCRECTDA D
. D PROCESS^RCDPURE1(RCRECTDA,0)
. ; clear the lock (set above)
. L -^RCY(344,RCRECTDA)
;
; clear all locked deposits
S RCDEPTDA=0 F S RCDEPTDA=$O(^TMP($J,"RCDPXPAP","DEPOSITLOCK",RCDEPTDA)) Q:'RCDEPTDA D
. ; confirm deposit (recalc totals)
. D CONFIRM^RCDPUDEP(RCDEPTDA)
. L -^RCY(344.1,RCDEPTDA)
;
; send a message to the users showing what was processed
D PROCMSG^RCDPXPAM
;
; need to delete the 344.2 entry
D DELETRAN^RCDPXPA1(RCDPDATE)
;
K ^TMP($J,"RCDPXPAP")
Q
;
;
FINDACCT(ACCT) ; lookup the patient and return the dfn
; if more than one patient matches acct, return null
; acct in the form 123456789ABCDE
; *296 - punctuation added to not process the acct in 9n1.5ap
I ACCT'?9N1.5AP D Q DFN
. S DFN=+ACCT I $G(^DPT(DFN,0))'="" Q
. S DFN=$E(DFN,1,10)_"."_$E(DFN,11,99) I $G(^DPT(DFN,0))'="" Q
. S DFN=0
. ;
N COUNT,DFN,FOUND,NAME,SSN
S SSN=$E(ACCT,1,9),NAME=$E(ACCT,10,99)
I SSN="" Q 0
S NAME=$TR(NAME,"/","'")
S COUNT=0 ;used to count number of matches
S FOUND=0 ;used to store matching acct's DFN number
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
; multiple acct matches, return null
I COUNT>1 Q 0
; acct found, return dfn of account which matches
I FOUND D:$G(RCDETY)=170 CHK170 Q FOUND ;PRCA*4.5*301
;
; *296 - remove spaces, periods, apostrophes, dashes from the name for treasury/c&p deposits
; lookup the first 3 chars in the last name for c&p
I $G(RCDETY)=168 S NAME=$E(NAME,3,5)
S NAME=$TR(NAME," .'-")
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
; multiple acct matches, return null
I COUNT>1 Q 0
; return dfn of account which matches, or 0 if not found
I +FOUND,$G(RCDETY)=170 D CHK170
Q +FOUND
;
CHK170 ;CHECK CS TX 170 FOR VALID BILL NUMER ;PRCA*4.5*301
S PRCABIL1=$E($P(RCDPDATA,"^",6),1,3)_"-"_$E($P(RCDPDATA,"^",6),4,10)
S PRCABIL2=$O(^PRCA(430,"B",PRCABIL1,0)) I 'PRCABIL2 S FOUND=0 Q
S PRCABIL2=$P(^PRCA(430,PRCABIL2,0),"^",9)
I +$G(^RCD(340,PRCABIL2,0))'=+FOUND S FOUND=0
Q
;
FILETRAN(RECTDA,TRANDA,DR) ; file the payment transaction
N %,D,D0,D1,DA,DI,DIC,DICR,DIE,DIG,DIH,DIU,DIV,DIW,DQ,X,Y
S (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
S DA=TRANDA,DA(1)=RECTDA
D ^DIE
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPXPAP 8751 printed Sep 23, 2025@19:22:51 Page 2
RCDPXPAP ;WISC/RFJ-CS automatically process the deposits ;1 Jun 99
+1 ;;4.5;Accounts Receivable;**114,150,206,296,301**;Mar 20, 1995;Build 144
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;PRCA*4.5*301 Add check for valid billing # on CS 170 transactions
+6 ; and create suspense entry if invalid.
+7 ;
PROCESS(RCDPDATE,RCPAYDA) ; process the deposits
+1 ; rcdpdate is the transmission date; rcpayda is ien for the payment
+2 ; type found in ^rc(341.1,rcpayda)
+3 NEW DR,PAYDESC,RCDEPDAT,RCDEPOSI,RCDEPTDA,RCDFN,RCDPDATA,RCLINE,RCRECTDA,RCTRANDA,STATUS
+4 KILL ^TMP($JOB,"RCDPXPAP")
+5 ;
+6 ; file the data in the payment files 344 (AR BATCH PAYMENT) and 344.1 (AR DEPOSIT)
+7 ; tmp global = acct number(1) ^ amount(2) ^ batch#(3) ^ sequence#(4) ^
+8 ; pay type(5) ^ pay desc fields(6)
+9 SET RCDEPOSI=""
FOR
SET RCDEPOSI=$ORDER(^TMP($JOB,"RCDPXPAY","DEPOSIT",RCDEPOSI))
if RCDEPOSI=""
QUIT
Begin DoDot:1
+10 SET RCDEPDAT=$GET(^TMP($JOB,"RCDPXPAY","DEPDATE",RCDEPOSI))
+11 ; *296 - event type 'a' or 't' or 'p' based on the prefix deposit #
+12 NEW RCDETY
SET RCDETY=+$EXTRACT(RCDEPOSI,1,3)
+13 SET RCPAYDA=$SELECT(RCDETY=168:15,RCDETY=169:13,RCDETY=170:16,1:$GET(RCPAYDA))
+14 ;
+15 ; add the deposit if not already in file
+16 ; make sure deposit is 6 characters in length
+17 SET X=$EXTRACT("000000",1,6-$LENGTH(RCDEPOSI))_RCDEPOSI
+18 SET RCDEPTDA=$$ADDDEPT^RCDPUDEP(X,RCDEPDAT)
+19 IF 'RCDEPTDA
DO ERROR^RCDPXPAM(RCDPDATE,RCDPXMZ,"Unable to ADD deposit "_RCDEPOSI_" to the AR DEPOSIT file #344.1")
QUIT
+20 ;
+21 ; lock deposit
+22 LOCK +^RCY(344.1,RCDEPTDA)
+23 ; confirm deposit (close it to prevent modifications to it)
+24 DO CONFIRM^RCDPUDEP(RCDEPTDA)
+25 ; store the deposit for unlocking below
+26 SET ^TMP($JOB,"RCDPXPAP","DEPOSITLOCK",RCDEPTDA)=""
+27 ;
+28 ; create receipt for transmission date and deposit
+29 SET RCRECTDA=$$ADDRECT^RCDPUREC(RCDPDATE,RCDEPTDA,RCPAYDA)
+30 IF 'RCRECTDA
DO ERROR^RCDPXPAM(RCDPDATE,RCDPXMZ,"Unable to ADD receipt "_RCDPDATE_" to the AR BATCH PAYMENT file #344")
QUIT
+31 ;
+32 ; lock receipt
+33 LOCK +^RCY(344,RCRECTDA)
+34 ; check to see if receipt has been processed (fms document)
+35 DO DIQ344^RCDPRPLM(RCRECTDA,"200;")
+36 ; code sheet already sent once, this is a retransmission, check it
+37 IF RCDPDATA(344,RCRECTDA,200,"E")'=""
Begin DoDot:2
+38 SET STATUS=$$STATUS^GECSSGET(RCDPDATA(344,RCRECTDA,200,"E"))
+39 ; okay to continue if status is Error, Rejected, or not defined (-1)
+40 IF $EXTRACT(STATUS)="E"!($EXTRACT(STATUS)="R")!(STATUS=-1)
QUIT
+41 SET ^TMP($JOB,"RCDPXPAP","DUPLICATE",RCRECTDA)="Receipt Not Changed^1"
End DoDot:2
+42 IF $DATA(^TMP($JOB,"RCDPXPAP","DUPLICATE",RCRECTDA))
LOCK -^RCY(344,RCRECTDA)
QUIT
+43 ;
+44 ; mark receipt as processed (closed) to prevent editing
+45 DO MARKPROC^RCDPUREC(RCRECTDA,"")
+46 ; store the receipt for automatic processing (and unlock) below
+47 ; the 0 is the count of unlinked accts displayed in mail message
+48 SET ^TMP($JOB,"RCDPXPAP","PROCESS",RCRECTDA)=0
+49 ;
+50 ; build a list of the current stored payments by batch_sequence
+51 ; number to prevent adding duplicates
+52 KILL ^TMP($JOB,"RCDPXPAP",RCRECTDA)
+53 SET RCLINE=0
FOR
SET RCLINE=$ORDER(^RCY(344,RCRECTDA,1,RCLINE))
if 'RCLINE
QUIT
Begin DoDot:2
+54 SET RCDPDATA=$GET(^RCY(344,RCRECTDA,1,RCLINE,2))
+55 IF '$PIECE(RCDPDATA,"^",2)!('$PIECE(RCDPDATA,"^",3))
QUIT
+56 SET ^TMP($JOB,"RCDPXPAP",RCRECTDA,$PIECE(RCDPDATA,"^",2),$PIECE(RCDPDATA,"^",3))=RCLINE
End DoDot:2
+57 ;
+58 ; loop transactions and add them to the receipt
+59 SET RCLINE=0
FOR
SET RCLINE=$ORDER(^TMP($JOB,"RCDPXPAY","DEPOSIT",RCDEPOSI,RCLINE))
if 'RCLINE
QUIT
Begin DoDot:2
+60 ; data in the form:
+61 ; acct lookup(1) ^ amount(2) ^ batch(3) ^ sequence(4) ^
+62 ; payment type(5) ^ payment description(6)
+63 SET RCDPDATA=^TMP($JOB,"RCDPXPAY","DEPOSIT",RCDEPOSI,RCLINE)
+64 ; if batch and sequence number already stored get current entry
+65 ; and do not add a new one
+66 SET RCTRANDA=0
+67 IF $PIECE(RCDPDATA,"^",3)
IF $PIECE(RCDPDATA,"^",4)
SET RCTRANDA=+$GET(^TMP($JOB,"RCDPXPAP",RCRECTDA,+$PIECE(RCDPDATA,"^",3),+$PIECE(RCDPDATA,"^",4)))
+68 IF 'RCTRANDA
SET RCTRANDA=+$$ADDTRAN^RCDPURET(RCRECTDA)
+69 IF 'RCTRANDA
DO ERROR^RCDPXPAM(RCDPDATE,RCDPXMZ,"Unable to ADD a new transaction to the AR BATCH PAYMENT file #344")
QUIT
+70 ;
+71 ; if the entry has already been processed, do not make any changes
+72 IF $PIECE(^RCY(344,RCRECTDA,1,RCTRANDA,0),"^",5)
if '$DATA(^TMP($JOB,"RCDPXPAP","DUPLICATE",RCRECTDA))
SET ^(RCRECTDA)="Receipt Not Changed"
QUIT
+73 IF $DATA(^TMP($JOB,"RCDPXPAP","DUPLICATE",RCRECTDA))
SET ^(RCRECTDA)="Receipt Updated"
+74 ;
+75 ; lookup account
+76 SET RCDFN=$$FINDACCT($PIECE(RCDPDATA,"^"))_";DPT("
+77 ; acct not found, count as unlinked for mail message
+78 IF 'RCDFN
SET ^TMP($JOB,"RCDPXPAP","PROCESS",RCRECTDA)=^TMP($JOB,"RCDPXPAP","PROCESS",RCRECTDA)+1
+79 ;
+80 ; build dr string to store the data
+81 ;account
SET DR=".21////"_$PIECE(RCDPDATA,"^")_";"
+82 IF RCDFN
SET DR=DR_".03////^S X=RCDFN;.09////^S X=RCDFN;"
+83 ;batch number
SET DR=DR_".22////"_+$PIECE(RCDPDATA,"^",3)_";"
+84 ;sequence number
SET DR=DR_".23////"_+$PIECE(RCDPDATA,"^",4)_";"
+85 ;payment type
SET DR=DR_".24////"_$PIECE(RCDPDATA,"^",5)_";"
+86 ;payment amount
SET DR=DR_".04////"_($PIECE(RCDPDATA,"^",2)/100)_";"
+87 ;payment date = deposit date
SET DR=DR_".06////"_RCDEPDAT_";"
+88 ;
+89 SET PAYDESC=$PIECE(RCDPDATA,"^",6)
+90 ; payment type check
+91 IF $PIECE(RCDPDATA,"^",5)=2
Begin DoDot:3
+92 ; check number : account number : bank routing number
+93 IF $PIECE(PAYDESC,":")'=""
SET DR=DR_".07////"_$PIECE(PAYDESC,":")_";"
+94 IF $PIECE(PAYDESC,":",2)'=""
SET DR=DR_".13////"_$PIECE(PAYDESC,":",2)_";"
+95 IF $PIECE(PAYDESC,":",3)'=""
SET DR=DR_".08////"_$PIECE(PAYDESC,":",3)_";"
End DoDot:3
+96 ; payment type credit, store credit card number
+97 IF $PIECE(RCDPDATA,"^",5)=3
IF $PIECE(PAYDESC,":")'=""
SET DR=DR_".11////"_$PIECE(PAYDESC,":")_";"
+98 ;
+99 ; store the payment under the receipt
+100 DO FILETRAN(RCRECTDA,RCTRANDA,DR)
+101 ;PRCA*4.5*301
SET $PIECE(^RCY(344,RCRECTDA,1,RCTRANDA,0),"^",19)=$PIECE(RCDPDATA,"^",7)
End DoDot:2
End DoDot:1
+102 ;
+103 ; automatically process the receipts added
+104 ; ^tmp($j,"rcdpxpap","process",receiptda)=""
+105 SET RCRECTDA=0
FOR
SET RCRECTDA=$ORDER(^TMP($JOB,"RCDPXPAP","PROCESS",RCRECTDA))
if 'RCRECTDA
QUIT
Begin DoDot:1
+106 DO PROCESS^RCDPURE1(RCRECTDA,0)
+107 ; clear the lock (set above)
+108 LOCK -^RCY(344,RCRECTDA)
End DoDot:1
+109 ;
+110 ; clear all locked deposits
+111 SET RCDEPTDA=0
FOR
SET RCDEPTDA=$ORDER(^TMP($JOB,"RCDPXPAP","DEPOSITLOCK",RCDEPTDA))
if 'RCDEPTDA
QUIT
Begin DoDot:1
+112 ; confirm deposit (recalc totals)
+113 DO CONFIRM^RCDPUDEP(RCDEPTDA)
+114 LOCK -^RCY(344.1,RCDEPTDA)
End DoDot:1
+115 ;
+116 ; send a message to the users showing what was processed
+117 DO PROCMSG^RCDPXPAM
+118 ;
+119 ; need to delete the 344.2 entry
+120 DO DELETRAN^RCDPXPA1(RCDPDATE)
+121 ;
+122 KILL ^TMP($JOB,"RCDPXPAP")
+123 QUIT
+124 ;
+125 ;
FINDACCT(ACCT) ; lookup the patient and return the dfn
+1 ; if more than one patient matches acct, return null
+2 ; acct in the form 123456789ABCDE
+3 ; *296 - punctuation added to not process the acct in 9n1.5ap
+4 IF ACCT'?9N1.5AP
Begin DoDot:1
+5 SET DFN=+ACCT
IF $GET(^DPT(DFN,0))'=""
QUIT
+6 SET DFN=$EXTRACT(DFN,1,10)_"."_$EXTRACT(DFN,11,99)
IF $GET(^DPT(DFN,0))'=""
QUIT
+7 SET DFN=0
+8 ;
End DoDot:1
QUIT DFN
+9 NEW COUNT,DFN,FOUND,NAME,SSN
+10 SET SSN=$EXTRACT(ACCT,1,9)
SET NAME=$EXTRACT(ACCT,10,99)
+11 IF SSN=""
QUIT 0
+12 SET NAME=$TRANSLATE(NAME,"/","'")
+13 ;used to count number of matches
SET COUNT=0
+14 ;used to store matching acct's DFN number
SET FOUND=0
+15 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("SSN",SSN,DFN))
if 'DFN
QUIT
IF $EXTRACT($TRANSLATE($PIECE($GET(^DPT(DFN,0)),"^")," "),1,$LENGTH(NAME))=NAME
SET COUNT=COUNT+1
SET FOUND=DFN
+16 ; multiple acct matches, return null
+17 IF COUNT>1
QUIT 0
+18 ; acct found, return dfn of account which matches
+19 ;PRCA*4.5*301
IF FOUND
if $GET(RCDETY)=170
DO CHK170
QUIT FOUND
+20 ;
+21 ; *296 - remove spaces, periods, apostrophes, dashes from the name for treasury/c&p deposits
+22 ; lookup the first 3 chars in the last name for c&p
+23 IF $GET(RCDETY)=168
SET NAME=$EXTRACT(NAME,3,5)
+24 SET NAME=$TRANSLATE(NAME," .'-")
+25 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("SSN",SSN,DFN))
if 'DFN
QUIT
IF $EXTRACT($TRANSLATE($PIECE($GET(^DPT(DFN,0)),"^")," .'-"),1,$LENGTH(NAME))=NAME
SET COUNT=COUNT+1
SET FOUND=DFN
+26 ; multiple acct matches, return null
+27 IF COUNT>1
QUIT 0
+28 ; return dfn of account which matches, or 0 if not found
+29 IF +FOUND
IF $GET(RCDETY)=170
DO CHK170
+30 QUIT +FOUND
+31 ;
CHK170 ;CHECK CS TX 170 FOR VALID BILL NUMER ;PRCA*4.5*301
+1 SET PRCABIL1=$EXTRACT($PIECE(RCDPDATA,"^",6),1,3)_"-"_$EXTRACT($PIECE(RCDPDATA,"^",6),4,10)
+2 SET PRCABIL2=$ORDER(^PRCA(430,"B",PRCABIL1,0))
IF 'PRCABIL2
SET FOUND=0
QUIT
+3 SET PRCABIL2=$PIECE(^PRCA(430,PRCABIL2,0),"^",9)
+4 IF +$GET(^RCD(340,PRCABIL2,0))'=+FOUND
SET FOUND=0
+5 QUIT
+6 ;
FILETRAN(RECTDA,TRANDA,DR) ; file the payment transaction
+1 NEW %,D,D0,D1,DA,DI,DIC,DICR,DIE,DIG,DIH,DIU,DIV,DIW,DQ,X,Y
+2 SET (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
+3 SET DA=TRANDA
SET DA(1)=RECTDA
+4 DO ^DIE
+5 QUIT
+6 ;
