- 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 Feb 18, 2025@23:13:07 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 ;