RCDPUT ;WASH-ISC@ALTOONA,PA/RGY/KML - UTILITIES ; 5/6/11 12:29pm
V ;;4.5;Accounts Receivable;**69,90,106,114,169,269,321**;Mar 20, 1995;Build 48
;;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
RECEIPTS ; check receipts
N DATA,PAYDA,RCCOUNT,RCDATA0,RCDATE,RCRECTDA,STATUS,TOTAL,X,XCNP,XMDUZ,XMZ
K ^TMP("RCDPUT",$J)
; check receipts which are 4 days old
S RCDATE=$$FMADD^XLFDT(DT,-4)
S RCCOUNT=7
S RCRECTDA=0 F S RCRECTDA=$O(^RCY(344,RCRECTDA)) Q:'RCRECTDA D
. ; if no payments, quit
. I '$O(^RCY(344,RCRECTDA,1,0)) Q
. ;
. S RCDATA0=$G(^RCY(344,RCRECTDA,0))
. ;
. ; receipt is marked as processed
. I $P(RCDATA0,"^",8) D Q
. . ; check the last payment and see if it was processed
. . ; the last payment must have a paid amount and no processed
. . ; amount AND the payment did not go to suspense.
. . S PAYDA=9999999,TOTAL=0
. . F S PAYDA=$O(^RCY(344,RCRECTDA,1,PAYDA),-1) Q:'PAYDA S DATA=$G(^RCY(344,RCRECTDA,1,PAYDA,0)),TOTAL=TOTAL+$P(DATA,"^",4) I $P(DATA,"^",4),$P(DATA,"^",3),$P($G(^RCY(344,RCRECTDA,1,PAYDA,2)),"^",5)="" Q
. . ; no total paid on the receipt
. . I 'TOTAL Q
. . ; found the last payment and it is not processed
. . I PAYDA,'$P(^RCY(344,RCRECTDA,1,PAYDA,0),"^",5) D BUILDLN(RCDATA0,"All payments NOT completely processed.") Q
. . ;
. . ; if no deposit ticket, receipt is processed
. . I '$P(RCDATA0,"^",6) Q
. . ;
. . ; receipts is marked as entered on line
. . I $P($G(^RCY(344,RCRECTDA,2)),"^",2)=1 Q
. . ;
. . ; fms document has not been sent
. . I $P($G(^RCY(344,RCRECTDA,2)),"^")="" D BUILDLN(RCDATA0,"CR has NOT been sent to FMS.") Q
. . ;
. . ; get the status of the fms code sheet and see if it is
. . ; accepted
. . S STATUS=$$FMSSTAT^RCDPUREC(RCRECTDA)
. . ; document is accepted or entered on line
. . I $E($P(STATUS,"^",2))="A" Q
. . I $E($P(STATUS,"^",2))="O" Q
. . ; not been more than 4 days
. . I $$FMDIFF^XLFDT(DT,$P(RCDATA0,"^",8))<4 Q
. . D BUILDLN(RCDATA0,"CR NOT accepted in FMS ("_$P(STATUS," ")_").")
. ;
. ; receipt not that old
. I $P(RCDATA0,"^",3)>RCDATE Q
. ;
. ; not processed in a timely manner
. D BUILDLN(RCDATA0,"NOT processed in a timely manner.")
;
I '$O(^TMP("RCDPUT",$J,0)) Q
;
; send mail message
S ^TMP("RCDPUT",$J,1)="Sent to: PRCA ERROR mailgroup"
S ^TMP("RCDPUT",$J,2)=" RCDP PAYMENTS mailgroup"
S ^TMP("RCDPUT",$J,3)=" PRCAY PAYMENT SUP security key holders"
S ^TMP("RCDPUT",$J,4)=" "
S ^TMP("RCDPUT",$J,5)="RECEIPT OPENED PROCESS WARNING"
S ^TMP("RCDPUT",$J,6)="------------------------------------------------------------------------------"
S XMY("G.PRCA ERROR")=""
S XMY("G.RCDP PAYMENTS")=""
F X=0:0 S X=$O(^XUSEC("PRCAY PAYMENT SUP",X)) Q:'X S XMY(X)=""
S XMDUZ="Accounts Receivable Package"
S XMTEXT="^TMP(""RCDPUT"",$J,"
S XMSUB="Error in Agent Cashier Receipt(s)"
D ^XMD
K ^TMP("RCDPUT",$J)
Q
;
;
BUILDLN(RCDATA0,WARNING) ; build line in mail message with receipt data
N DATA,DATE
S RCCOUNT=RCCOUNT+1
S DATA=$E($P(RCDATA0,"^")_" ",1,11)_" "
S DATE=$P(RCDATA0,"^",3) I DATE S DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3)
S DATA=DATA_$E(DATE_" ",1,8)_" "
S DATE=$P(RCDATA0,"^",8) I DATE S DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3)
S DATA=DATA_$E(DATE_" ",1,8)_" "
S DATA=DATA_WARNING
S RCCOUNT=RCCOUNT+1
S ^TMP("RCDPUT",$J,RCCOUNT)=DATA
Q
;
;
PURGE ; purge receipts and deposits
N %,D0,D1,DA,DG,DIC,DICR,DIG,DIH,DIK,DIU,DIV,DIW,RCDATE,RCDEPDA,RCRECTDA,X,Y
;
; purge receipts
; HIPAA 5010 - retain receipts for 7 year (84 months)
S RCDATE=$$FPS^RCAMFN01(DT,-84)
S RCRECTDA=0 F S RCRECTDA=$O(^RCY(344,RCRECTDA)) Q:'RCRECTDA D
. ; receipt not processed, do not purge
. I '$P(^RCY(344,RCRECTDA,0),"^",8) Q
. ; receipt processed less than 84 months ago, do not purge
. I $P(^RCY(344,RCRECTDA,0),"^",8)>RCDATE Q
. ; purge receipt
. L +^RCY(344,RCRECTDA,0)
. S DIK="^RCY(344,",DA=RCRECTDA D ^DIK
. ; purge any comment history - PRCA*4.5*321
. D PURGECH(RCRECTDA)
. ;
. L -^RCY(344,RCRECTDA,0)
;
; purge deposits
; ; HIPAA 5010 - retain deposits for 7 year (84 months)
S RCDATE=$$FPS^RCAMFN01(DT,-84)
S RCDEPDA=0 F S RCDEPDA=$O(^RCY(344.1,RCDEPDA)) Q:'RCDEPDA D
. ; if receipts are on deposit, do not purge
. I $O(^RCY(344,"AD",RCDEPDA,0)) Q
. ; deposit not confirmed, do not purge
. I '$P(^RCY(344.1,RCDEPDA,0),"^",11) Q
. ; deposit confirmed less than 84 months ago, do not purge
. I $P(^RCY(344.1,RCDEPDA,0),"^",11)>RCDATE Q
. ; purge deposit
. L +^RCY(344.1,RCDEPDA,0)
. S DIK="^RCY(344.1,",DA=RCDEPDA D ^DIK
. L -^RCY(344.1,RCDEPDA,0)
Q
;
PURGECH(RCDA) ; Purge Comment History - PRCA*4.5*321
N DA,DIK,SUB
S SUB=0
F S SUB=$O(^RCY(344.73,"B",RCDA,SUB)) Q:'SUB D
. ;Delete Comment
. S DIK="^RCY(344.73,",DA=SUB D ^DIK
Q
;
MAN ; Entry point for nightly process for managing receipts and deposits
D PURGE
D RECEIPTS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPUT 5265 printed Sep 23, 2025@19:22:47 Page 2
RCDPUT ;WASH-ISC@ALTOONA,PA/RGY/KML - UTILITIES ; 5/6/11 12:29pm
V ;;4.5;Accounts Receivable;**69,90,106,114,169,269,321**;Mar 20, 1995;Build 48
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
+3 ;
+4 ;
RECEIPTS ; check receipts
+1 NEW DATA,PAYDA,RCCOUNT,RCDATA0,RCDATE,RCRECTDA,STATUS,TOTAL,X,XCNP,XMDUZ,XMZ
+2 KILL ^TMP("RCDPUT",$JOB)
+3 ; check receipts which are 4 days old
+4 SET RCDATE=$$FMADD^XLFDT(DT,-4)
+5 SET RCCOUNT=7
+6 SET RCRECTDA=0
FOR
SET RCRECTDA=$ORDER(^RCY(344,RCRECTDA))
if 'RCRECTDA
QUIT
Begin DoDot:1
+7 ; if no payments, quit
+8 IF '$ORDER(^RCY(344,RCRECTDA,1,0))
QUIT
+9 ;
+10 SET RCDATA0=$GET(^RCY(344,RCRECTDA,0))
+11 ;
+12 ; receipt is marked as processed
+13 IF $PIECE(RCDATA0,"^",8)
Begin DoDot:2
+14 ; check the last payment and see if it was processed
+15 ; the last payment must have a paid amount and no processed
+16 ; amount AND the payment did not go to suspense.
+17 SET PAYDA=9999999
SET TOTAL=0
+18 FOR
SET PAYDA=$ORDER(^RCY(344,RCRECTDA,1,PAYDA),-1)
if 'PAYDA
QUIT
SET DATA=$GET(^RCY(344,RCRECTDA,1,PAYDA,0))
SET TOTAL=TOTAL+$PIECE(DATA,"^",4)
IF $PIECE(DATA,"^",4)
IF $PIECE(DATA,"^",3)
IF $PIECE($GET(^RCY(344,RCRECTDA,1,PAYDA,2)),"^",5)=""
QUIT
+19 ; no total paid on the receipt
+20 IF 'TOTAL
QUIT
+21 ; found the last payment and it is not processed
+22 IF PAYDA
IF '$PIECE(^RCY(344,RCRECTDA,1,PAYDA,0),"^",5)
DO BUILDLN(RCDATA0,"All payments NOT completely processed.")
QUIT
+23 ;
+24 ; if no deposit ticket, receipt is processed
+25 IF '$PIECE(RCDATA0,"^",6)
QUIT
+26 ;
+27 ; receipts is marked as entered on line
+28 IF $PIECE($GET(^RCY(344,RCRECTDA,2)),"^",2)=1
QUIT
+29 ;
+30 ; fms document has not been sent
+31 IF $PIECE($GET(^RCY(344,RCRECTDA,2)),"^")=""
DO BUILDLN(RCDATA0,"CR has NOT been sent to FMS.")
QUIT
+32 ;
+33 ; get the status of the fms code sheet and see if it is
+34 ; accepted
+35 SET STATUS=$$FMSSTAT^RCDPUREC(RCRECTDA)
+36 ; document is accepted or entered on line
+37 IF $EXTRACT($PIECE(STATUS,"^",2))="A"
QUIT
+38 IF $EXTRACT($PIECE(STATUS,"^",2))="O"
QUIT
+39 ; not been more than 4 days
+40 IF $$FMDIFF^XLFDT(DT,$PIECE(RCDATA0,"^",8))<4
QUIT
+41 DO BUILDLN(RCDATA0,"CR NOT accepted in FMS ("_$PIECE(STATUS," ")_").")
End DoDot:2
QUIT
+42 ;
+43 ; receipt not that old
+44 IF $PIECE(RCDATA0,"^",3)>RCDATE
QUIT
+45 ;
+46 ; not processed in a timely manner
+47 DO BUILDLN(RCDATA0,"NOT processed in a timely manner.")
End DoDot:1
+48 ;
+49 IF '$ORDER(^TMP("RCDPUT",$JOB,0))
QUIT
+50 ;
+51 ; send mail message
+52 SET ^TMP("RCDPUT",$JOB,1)="Sent to: PRCA ERROR mailgroup"
+53 SET ^TMP("RCDPUT",$JOB,2)=" RCDP PAYMENTS mailgroup"
+54 SET ^TMP("RCDPUT",$JOB,3)=" PRCAY PAYMENT SUP security key holders"
+55 SET ^TMP("RCDPUT",$JOB,4)=" "
+56 SET ^TMP("RCDPUT",$JOB,5)="RECEIPT OPENED PROCESS WARNING"
+57 SET ^TMP("RCDPUT",$JOB,6)="------------------------------------------------------------------------------"
+58 SET XMY("G.PRCA ERROR")=""
+59 SET XMY("G.RCDP PAYMENTS")=""
+60 FOR X=0:0
SET X=$ORDER(^XUSEC("PRCAY PAYMENT SUP",X))
if 'X
QUIT
SET XMY(X)=""
+61 SET XMDUZ="Accounts Receivable Package"
+62 SET XMTEXT="^TMP(""RCDPUT"",$J,"
+63 SET XMSUB="Error in Agent Cashier Receipt(s)"
+64 DO ^XMD
+65 KILL ^TMP("RCDPUT",$JOB)
+66 QUIT
+67 ;
+68 ;
BUILDLN(RCDATA0,WARNING) ; build line in mail message with receipt data
+1 NEW DATA,DATE
+2 SET RCCOUNT=RCCOUNT+1
+3 SET DATA=$EXTRACT($PIECE(RCDATA0,"^")_" ",1,11)_" "
+4 SET DATE=$PIECE(RCDATA0,"^",3)
IF DATE
SET DATE=$EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,6,7)_"/"_$EXTRACT(DATE,2,3)
+5 SET DATA=DATA_$EXTRACT(DATE_" ",1,8)_" "
+6 SET DATE=$PIECE(RCDATA0,"^",8)
IF DATE
SET DATE=$EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,6,7)_"/"_$EXTRACT(DATE,2,3)
+7 SET DATA=DATA_$EXTRACT(DATE_" ",1,8)_" "
+8 SET DATA=DATA_WARNING
+9 SET RCCOUNT=RCCOUNT+1
+10 SET ^TMP("RCDPUT",$JOB,RCCOUNT)=DATA
+11 QUIT
+12 ;
+13 ;
PURGE ; purge receipts and deposits
+1 NEW %,D0,D1,DA,DG,DIC,DICR,DIG,DIH,DIK,DIU,DIV,DIW,RCDATE,RCDEPDA,RCRECTDA,X,Y
+2 ;
+3 ; purge receipts
+4 ; HIPAA 5010 - retain receipts for 7 year (84 months)
+5 SET RCDATE=$$FPS^RCAMFN01(DT,-84)
+6 SET RCRECTDA=0
FOR
SET RCRECTDA=$ORDER(^RCY(344,RCRECTDA))
if 'RCRECTDA
QUIT
Begin DoDot:1
+7 ; receipt not processed, do not purge
+8 IF '$PIECE(^RCY(344,RCRECTDA,0),"^",8)
QUIT
+9 ; receipt processed less than 84 months ago, do not purge
+10 IF $PIECE(^RCY(344,RCRECTDA,0),"^",8)>RCDATE
QUIT
+11 ; purge receipt
+12 LOCK +^RCY(344,RCRECTDA,0)
+13 SET DIK="^RCY(344,"
SET DA=RCRECTDA
DO ^DIK
+14 ; purge any comment history - PRCA*4.5*321
+15 DO PURGECH(RCRECTDA)
+16 ;
+17 LOCK -^RCY(344,RCRECTDA,0)
End DoDot:1
+18 ;
+19 ; purge deposits
+20 ; ; HIPAA 5010 - retain deposits for 7 year (84 months)
+21 SET RCDATE=$$FPS^RCAMFN01(DT,-84)
+22 SET RCDEPDA=0
FOR
SET RCDEPDA=$ORDER(^RCY(344.1,RCDEPDA))
if 'RCDEPDA
QUIT
Begin DoDot:1
+23 ; if receipts are on deposit, do not purge
+24 IF $ORDER(^RCY(344,"AD",RCDEPDA,0))
QUIT
+25 ; deposit not confirmed, do not purge
+26 IF '$PIECE(^RCY(344.1,RCDEPDA,0),"^",11)
QUIT
+27 ; deposit confirmed less than 84 months ago, do not purge
+28 IF $PIECE(^RCY(344.1,RCDEPDA,0),"^",11)>RCDATE
QUIT
+29 ; purge deposit
+30 LOCK +^RCY(344.1,RCDEPDA,0)
+31 SET DIK="^RCY(344.1,"
SET DA=RCDEPDA
DO ^DIK
+32 LOCK -^RCY(344.1,RCDEPDA,0)
End DoDot:1
+33 QUIT
+34 ;
PURGECH(RCDA) ; Purge Comment History - PRCA*4.5*321
+1 NEW DA,DIK,SUB
+2 SET SUB=0
+3 FOR
SET SUB=$ORDER(^RCY(344.73,"B",RCDA,SUB))
if 'SUB
QUIT
Begin DoDot:1
+4 ;Delete Comment
+5 SET DIK="^RCY(344.73,"
SET DA=SUB
DO ^DIK
End DoDot:1
+6 QUIT
+7 ;
MAN ; Entry point for nightly process for managing receipts and deposits
+1 DO PURGE
+2 DO RECEIPTS
+3 QUIT
