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