Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RCDPUT

RCDPUT.m

Go to the documentation of this file.
  1. RCDPUT ;WASH-ISC@ALTOONA,PA/RGY/KML - UTILITIES ; 5/6/11 12:29pm
  1. 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.
  1. Q
  1. ;
  1. ;
  1. RECEIPTS ; check receipts
  1. N DATA,PAYDA,RCCOUNT,RCDATA0,RCDATE,RCRECTDA,STATUS,TOTAL,X,XCNP,XMDUZ,XMZ
  1. K ^TMP("RCDPUT",$J)
  1. ; check receipts which are 4 days old
  1. S RCDATE=$$FMADD^XLFDT(DT,-4)
  1. S RCCOUNT=7
  1. S RCRECTDA=0 F S RCRECTDA=$O(^RCY(344,RCRECTDA)) Q:'RCRECTDA D
  1. . ; if no payments, quit
  1. . I '$O(^RCY(344,RCRECTDA,1,0)) Q
  1. . ;
  1. . S RCDATA0=$G(^RCY(344,RCRECTDA,0))
  1. . ;
  1. . ; receipt is marked as processed
  1. . I $P(RCDATA0,"^",8) D Q
  1. . . ; check the last payment and see if it was processed
  1. . . ; the last payment must have a paid amount and no processed
  1. . . ; amount AND the payment did not go to suspense.
  1. . . S PAYDA=9999999,TOTAL=0
  1. . . 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
  1. . . ; no total paid on the receipt
  1. . . I 'TOTAL Q
  1. . . ; found the last payment and it is not processed
  1. . . I PAYDA,'$P(^RCY(344,RCRECTDA,1,PAYDA,0),"^",5) D BUILDLN(RCDATA0,"All payments NOT completely processed.") Q
  1. . . ;
  1. . . ; if no deposit ticket, receipt is processed
  1. . . I '$P(RCDATA0,"^",6) Q
  1. . . ;
  1. . . ; receipts is marked as entered on line
  1. . . I $P($G(^RCY(344,RCRECTDA,2)),"^",2)=1 Q
  1. . . ;
  1. . . ; fms document has not been sent
  1. . . I $P($G(^RCY(344,RCRECTDA,2)),"^")="" D BUILDLN(RCDATA0,"CR has NOT been sent to FMS.") Q
  1. . . ;
  1. . . ; get the status of the fms code sheet and see if it is
  1. . . ; accepted
  1. . . S STATUS=$$FMSSTAT^RCDPUREC(RCRECTDA)
  1. . . ; document is accepted or entered on line
  1. . . I $E($P(STATUS,"^",2))="A" Q
  1. . . I $E($P(STATUS,"^",2))="O" Q
  1. . . ; not been more than 4 days
  1. . . I $$FMDIFF^XLFDT(DT,$P(RCDATA0,"^",8))<4 Q
  1. . . D BUILDLN(RCDATA0,"CR NOT accepted in FMS ("_$P(STATUS," ")_").")
  1. . ;
  1. . ; receipt not that old
  1. . I $P(RCDATA0,"^",3)>RCDATE Q
  1. . ;
  1. . ; not processed in a timely manner
  1. . D BUILDLN(RCDATA0,"NOT processed in a timely manner.")
  1. ;
  1. I '$O(^TMP("RCDPUT",$J,0)) Q
  1. ;
  1. ; send mail message
  1. S ^TMP("RCDPUT",$J,1)="Sent to: PRCA ERROR mailgroup"
  1. S ^TMP("RCDPUT",$J,2)=" RCDP PAYMENTS mailgroup"
  1. S ^TMP("RCDPUT",$J,3)=" PRCAY PAYMENT SUP security key holders"
  1. S ^TMP("RCDPUT",$J,4)=" "
  1. S ^TMP("RCDPUT",$J,5)="RECEIPT OPENED PROCESS WARNING"
  1. S ^TMP("RCDPUT",$J,6)="------------------------------------------------------------------------------"
  1. S XMY("G.PRCA ERROR")=""
  1. S XMY("G.RCDP PAYMENTS")=""
  1. F X=0:0 S X=$O(^XUSEC("PRCAY PAYMENT SUP",X)) Q:'X S XMY(X)=""
  1. S XMDUZ="Accounts Receivable Package"
  1. S XMTEXT="^TMP(""RCDPUT"",$J,"
  1. S XMSUB="Error in Agent Cashier Receipt(s)"
  1. D ^XMD
  1. K ^TMP("RCDPUT",$J)
  1. Q
  1. ;
  1. ;
  1. BUILDLN(RCDATA0,WARNING) ; build line in mail message with receipt data
  1. N DATA,DATE
  1. S RCCOUNT=RCCOUNT+1
  1. S DATA=$E($P(RCDATA0,"^")_" ",1,11)_" "
  1. S DATE=$P(RCDATA0,"^",3) I DATE S DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3)
  1. S DATA=DATA_$E(DATE_" ",1,8)_" "
  1. S DATE=$P(RCDATA0,"^",8) I DATE S DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3)
  1. S DATA=DATA_$E(DATE_" ",1,8)_" "
  1. S DATA=DATA_WARNING
  1. S RCCOUNT=RCCOUNT+1
  1. S ^TMP("RCDPUT",$J,RCCOUNT)=DATA
  1. Q
  1. ;
  1. ;
  1. PURGE ; purge receipts and deposits
  1. N %,D0,D1,DA,DG,DIC,DICR,DIG,DIH,DIK,DIU,DIV,DIW,RCDATE,RCDEPDA,RCRECTDA,X,Y
  1. ;
  1. ; purge receipts
  1. ; HIPAA 5010 - retain receipts for 7 year (84 months)
  1. S RCDATE=$$FPS^RCAMFN01(DT,-84)
  1. S RCRECTDA=0 F S RCRECTDA=$O(^RCY(344,RCRECTDA)) Q:'RCRECTDA D
  1. . ; receipt not processed, do not purge
  1. . I '$P(^RCY(344,RCRECTDA,0),"^",8) Q
  1. . ; receipt processed less than 84 months ago, do not purge
  1. . I $P(^RCY(344,RCRECTDA,0),"^",8)>RCDATE Q
  1. . ; purge receipt
  1. . L +^RCY(344,RCRECTDA,0)
  1. . S DIK="^RCY(344,",DA=RCRECTDA D ^DIK
  1. . ; purge any comment history - PRCA*4.5*321
  1. . D PURGECH(RCRECTDA)
  1. . ;
  1. . L -^RCY(344,RCRECTDA,0)
  1. ;
  1. ; purge deposits
  1. ; ; HIPAA 5010 - retain deposits for 7 year (84 months)
  1. S RCDATE=$$FPS^RCAMFN01(DT,-84)
  1. S RCDEPDA=0 F S RCDEPDA=$O(^RCY(344.1,RCDEPDA)) Q:'RCDEPDA D
  1. . ; if receipts are on deposit, do not purge
  1. . I $O(^RCY(344,"AD",RCDEPDA,0)) Q
  1. . ; deposit not confirmed, do not purge
  1. . I '$P(^RCY(344.1,RCDEPDA,0),"^",11) Q
  1. . ; deposit confirmed less than 84 months ago, do not purge
  1. . I $P(^RCY(344.1,RCDEPDA,0),"^",11)>RCDATE Q
  1. . ; purge deposit
  1. . L +^RCY(344.1,RCDEPDA,0)
  1. . S DIK="^RCY(344.1,",DA=RCDEPDA D ^DIK
  1. . L -^RCY(344.1,RCDEPDA,0)
  1. Q
  1. ;
  1. PURGECH(RCDA) ; Purge Comment History - PRCA*4.5*321
  1. N DA,DIK,SUB
  1. S SUB=0
  1. F S SUB=$O(^RCY(344.73,"B",RCDA,SUB)) Q:'SUB D
  1. . ;Delete Comment
  1. . S DIK="^RCY(344.73,",DA=SUB D ^DIK
  1. Q
  1. ;
  1. MAN ; Entry point for nightly process for managing receipts and deposits
  1. D PURGE
  1. D RECEIPTS
  1. Q