RCDPESP4 ; Albany/hrubovcak - ePayment Auto-post/Decrease for IOC testing, file #344.6 ;Jul 29, 2014@15:19:17
;;4.5;Accounts Receivable;**298**;Nov 11, 2013;Build 121
;Per VA Directive 6402, this routine should not be modified.
;
Q
;
; * this routine is to be used for IOC purposes only *
; * the VHA CBO prohibits this routine from being used in any option *
; * or in any way that is accessible to a VistA user *
;
IOCSTRT ; disable auto-post and auto-decrease for all payers (for IOC start)
;
N DIR,DTOUT,DUOUT,X,Y
W !,"This routine excludes all payers from auto-posting."
W !,"The routine should only be used at the start of IOC testing."
S DIR(0)="YA",DIR("A")="Do you wish to proceed? (Y/N): ",DIR("B")="NO"
D ^DIR
I 'Y!$D(DTOUT)!$D(DUOUT) W !!,"File not updated.",! Q
;
W !,"Exclusions for start of IOC started "_$$FMTE^XLFDT($$NOW^XLFDT,"1ZPM")
N J,P,RCDUZ,RCFLD,RCIEN,RCNTRY,RCOMMNT
S RCDUZ=DUZ X "S DUZ=.5" ; DUZ is used in triggers for file #344.6
S RCOMMNT="Auto Addition - Beginning of Field Test/IOC"
; iterate through file #344.6
S RCIEN=0 F S RCIEN=$O(^RCY(344.6,RCIEN)) Q:'RCIEN S RCNTRY=$G(^RCY(344.6,RCIEN,0)) D:RCNTRY]""
.F RCFLD=.06,.07 S P=100*RCFLD,X=$P(RCNTRY,U,P) D:'X ; if NO, update entry
..N I,RCXCLFDA ; FileMan FDA array
..S I=RCIEN_",",I("CMNTFLD")=$S(RCFLD=.06:1,1:2) ; IENS and comment field #
..S RCXCLFDA(344.6,I,RCFLD)=1 ; change to YES
..S RCXCLFDA(344.6,I,I("CMNTFLD"))=RCOMMNT
..D UPDATE^DIE(,"RCXCLFDA") ; update entry
..D AUDXCLSN(RCIEN_U_RCFLD_U_1_U_0_U_RCOMMNT)
;
W !,"Exclusions for start of IOC finished "_$$FMTE^XLFDT($$NOW^XLFDT,"1ZPM")
X "S DUZ=RCDUZ"
; send MailMan message
D IOCMLMSG(RCOMMNT) W !!,"A MailMan message has been sent."
;
Q
;
IOCEND ; enable auto-post and auto-decrease for all payers (for IOC end)
;
N DIR,DTOUT,DUOUT,X,Y
W !,"This routine resets all payers as ready for auto-posting."
W !,"The routine should only be used at the end of IOC."
S DIR(0)="YA",DIR("A")="Do you wish to proceed? (Y/N): ",DIR("B")="NO"
D ^DIR
I 'Y!$D(DTOUT)!$D(DUOUT) W !!,"File not updated.",! Q
;
W !,"Exclusions for end of IOC started "_$$FMTE^XLFDT($$NOW^XLFDT,"1ZPM")
N J,P,RCDUZ,RCFLD,RCIEN,RCNTRY,RCOMMNT
S RCDUZ=DUZ X "S DUZ=.5" ; DUZ is used in triggers for file #344.6
S RCOMMNT="Auto Deletion - End of Field Test/IOC"
; iterate through file #344.6
S RCIEN=0 F S RCIEN=$O(^RCY(344.6,RCIEN)) Q:'RCIEN S RCNTRY=$G(^RCY(344.6,RCIEN,0)) D:RCNTRY]""
.F RCFLD=.06,.07 S P=100*RCFLD,X=$P(RCNTRY,U,P) D:X ; if YES, update entry
..N I,RCXCLFDA ; FileMan FDA array
..S I=RCIEN_",",I("CMNTFLD")=$S(RCFLD=.06:1,1:2) ; IENS and comment field #
..S RCXCLFDA(344.6,I,RCFLD)=0 ; change to NO
..S RCXCLFDA(344.6,I,I("CMNTFLD"))=RCOMMNT
..D UPDATE^DIE(,"RCXCLFDA") ; update entry
..D AUDXCLSN(RCIEN_U_RCFLD_U_0_U_1_U_RCOMMNT)
;
W !,"Exclusions for end of IOC finished "_$$FMTE^XLFDT($$NOW^XLFDT,"1ZPM")
X "S DUZ=RCDUZ"
; send MailMan message
D IOCMLMSG(RCOMMNT) W !!,"A MailMan message has been sent."
;
Q
;
AUDXCLSN(NTRY) ; add entry to RCDPE PARAMETER AUDIT file (#344.7)
; for IOC changes to RCDPE AUTO-PAY EXCLUSION file (#344.6)
; the POSTMASTER is the user for each update
; NTRY = audit value in this format:
; IEN^FIELD #^NEW VALUE^OLD VALUE^COMMENT
; 1 ^ 2 ^ 3 ^ 4 ^ 5
;
Q:$G(NTRY)="" ; NTRY is required
N RCFDA ; FileMan FDA array for audits
S RCFDA(344.7,"+1,",.01)=$$NOW^XLFDT
S RCFDA(344.7,"+1,",.02)=$P(NTRY,U) ; IEN
S RCFDA(344.7,"+1,",.03)=.5 ; USER (POSTMASTER)
S RCFDA(344.7,"+1,",.04)=$P(NTRY,U,2) ; FIELD NUMBER
S RCFDA(344.7,"+1,",.05)=344.6 ; FILE NUMBER
S RCFDA(344.7,"+1,",.06)=$P(NTRY,U,3) ; NEW VALUE
S RCFDA(344.7,"+1,",.07)=$P(NTRY,U,4) ; OLD VALUE
S RCFDA(344.7,"+1,",.08)=$P(NTRY,U,5) ; COMMENT
D UPDATE^DIE(,"RCFDA")
Q
;
IOCMLMSG(RCACT) ; RCACT - activity to include MailMan message text
N RCMSGTXT,RCSITE,RCSUBJ,XMINSTR,XMTO
S RCSITE=$$SITE^VASITE
; limit subject to 65 chars.
S RCSUBJ=$E("ePayments IOC activity "_$P(RCSITE,U,2),1,65)
S RCMSGTXT(1)=" "
S RCMSGTXT(2)=" Site: "_$P(RCSITE,U,2)
S RCMSGTXT(3)=" Station # "_$P(RCSITE,U,3)
S RCMSGTXT(4)=" Domain: "_$G(^XMB("NETNAME"))
S RCMSGTXT(5)=" Date/Time: "_$$FMTE^XLFDT($$NOW^XLFDT,"1ZPM")
S RCMSGTXT(6)=" User: "_$P($G(^VA(200,DUZ,0)),U)
S RCMSGTXT(7)=" "
S RCMSGTXT(8)=" The following IOC activity was performed: "
S RCMSGTXT(9)=" "_$C(34)_$G(RCACT)_$C(34)
;
S XMINSTR("FROM")="POSTMASTER"
;
S XMTO(DUZ)="",XMTO("G.RCDPE PAYMENTS MGMT")=""
;
K ^TMP("XMERR",$J)
D SENDMSG^XMXAPI(DUZ,RCSUBJ,"RCMSGTXT",.XMTO,.XMINSTR)
;
I $D(^TMP("XMERR",$J)) D
.D MES^XPDUTL("MailMan returned an error.")
.D MES^XPDUTL("The error text is:")
.N G S G=$NA(^TMP("XMERR",$J))
.F S G=$Q(@G) Q:G="" Q:$QS(G,2)'=$J D MES^XPDUTL(" "_$C(34)_@G_$C(34))
.D MES^XPDUTL(" * End of Error Text *")
.K ^TMP("XMERR",$J)
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPESP4 5040 printed Sep 23, 2025@19:21:20 Page 2
RCDPESP4 ; Albany/hrubovcak - ePayment Auto-post/Decrease for IOC testing, file #344.6 ;Jul 29, 2014@15:19:17
+1 ;;4.5;Accounts Receivable;**298**;Nov 11, 2013;Build 121
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
+6 ; * this routine is to be used for IOC purposes only *
+7 ; * the VHA CBO prohibits this routine from being used in any option *
+8 ; * or in any way that is accessible to a VistA user *
+9 ;
IOCSTRT ; disable auto-post and auto-decrease for all payers (for IOC start)
+1 ;
+2 NEW DIR,DTOUT,DUOUT,X,Y
+3 WRITE !,"This routine excludes all payers from auto-posting."
+4 WRITE !,"The routine should only be used at the start of IOC testing."
+5 SET DIR(0)="YA"
SET DIR("A")="Do you wish to proceed? (Y/N): "
SET DIR("B")="NO"
+6 DO ^DIR
+7 IF 'Y!$DATA(DTOUT)!$DATA(DUOUT)
WRITE !!,"File not updated.",!
QUIT
+8 ;
+9 WRITE !,"Exclusions for start of IOC started "_$$FMTE^XLFDT($$NOW^XLFDT,"1ZPM")
+10 NEW J,P,RCDUZ,RCFLD,RCIEN,RCNTRY,RCOMMNT
+11 ; DUZ is used in triggers for file #344.6
SET RCDUZ=DUZ
XECUTE "S DUZ=.5"
+12 SET RCOMMNT="Auto Addition - Beginning of Field Test/IOC"
+13 ; iterate through file #344.6
+14 SET RCIEN=0
FOR
SET RCIEN=$ORDER(^RCY(344.6,RCIEN))
if 'RCIEN
QUIT
SET RCNTRY=$GET(^RCY(344.6,RCIEN,0))
if RCNTRY]""
Begin DoDot:1
+15 ; if NO, update entry
FOR RCFLD=.06,.07
SET P=100*RCFLD
SET X=$PIECE(RCNTRY,U,P)
if 'X
Begin DoDot:2
+16 ; FileMan FDA array
NEW I,RCXCLFDA
+17 ; IENS and comment field #
SET I=RCIEN_","
SET I("CMNTFLD")=$SELECT(RCFLD=.06:1,1:2)
+18 ; change to YES
SET RCXCLFDA(344.6,I,RCFLD)=1
+19 SET RCXCLFDA(344.6,I,I("CMNTFLD"))=RCOMMNT
+20 ; update entry
DO UPDATE^DIE(,"RCXCLFDA")
+21 DO AUDXCLSN(RCIEN_U_RCFLD_U_1_U_0_U_RCOMMNT)
End DoDot:2
End DoDot:1
+22 ;
+23 WRITE !,"Exclusions for start of IOC finished "_$$FMTE^XLFDT($$NOW^XLFDT,"1ZPM")
+24 XECUTE "S DUZ=RCDUZ"
+25 ; send MailMan message
+26 DO IOCMLMSG(RCOMMNT)
WRITE !!,"A MailMan message has been sent."
+27 ;
+28 QUIT
+29 ;
IOCEND ; enable auto-post and auto-decrease for all payers (for IOC end)
+1 ;
+2 NEW DIR,DTOUT,DUOUT,X,Y
+3 WRITE !,"This routine resets all payers as ready for auto-posting."
+4 WRITE !,"The routine should only be used at the end of IOC."
+5 SET DIR(0)="YA"
SET DIR("A")="Do you wish to proceed? (Y/N): "
SET DIR("B")="NO"
+6 DO ^DIR
+7 IF 'Y!$DATA(DTOUT)!$DATA(DUOUT)
WRITE !!,"File not updated.",!
QUIT
+8 ;
+9 WRITE !,"Exclusions for end of IOC started "_$$FMTE^XLFDT($$NOW^XLFDT,"1ZPM")
+10 NEW J,P,RCDUZ,RCFLD,RCIEN,RCNTRY,RCOMMNT
+11 ; DUZ is used in triggers for file #344.6
SET RCDUZ=DUZ
XECUTE "S DUZ=.5"
+12 SET RCOMMNT="Auto Deletion - End of Field Test/IOC"
+13 ; iterate through file #344.6
+14 SET RCIEN=0
FOR
SET RCIEN=$ORDER(^RCY(344.6,RCIEN))
if 'RCIEN
QUIT
SET RCNTRY=$GET(^RCY(344.6,RCIEN,0))
if RCNTRY]""
Begin DoDot:1
+15 ; if YES, update entry
FOR RCFLD=.06,.07
SET P=100*RCFLD
SET X=$PIECE(RCNTRY,U,P)
if X
Begin DoDot:2
+16 ; FileMan FDA array
NEW I,RCXCLFDA
+17 ; IENS and comment field #
SET I=RCIEN_","
SET I("CMNTFLD")=$SELECT(RCFLD=.06:1,1:2)
+18 ; change to NO
SET RCXCLFDA(344.6,I,RCFLD)=0
+19 SET RCXCLFDA(344.6,I,I("CMNTFLD"))=RCOMMNT
+20 ; update entry
DO UPDATE^DIE(,"RCXCLFDA")
+21 DO AUDXCLSN(RCIEN_U_RCFLD_U_0_U_1_U_RCOMMNT)
End DoDot:2
End DoDot:1
+22 ;
+23 WRITE !,"Exclusions for end of IOC finished "_$$FMTE^XLFDT($$NOW^XLFDT,"1ZPM")
+24 XECUTE "S DUZ=RCDUZ"
+25 ; send MailMan message
+26 DO IOCMLMSG(RCOMMNT)
WRITE !!,"A MailMan message has been sent."
+27 ;
+28 QUIT
+29 ;
AUDXCLSN(NTRY) ; add entry to RCDPE PARAMETER AUDIT file (#344.7)
+1 ; for IOC changes to RCDPE AUTO-PAY EXCLUSION file (#344.6)
+2 ; the POSTMASTER is the user for each update
+3 ; NTRY = audit value in this format:
+4 ; IEN^FIELD #^NEW VALUE^OLD VALUE^COMMENT
+5 ; 1 ^ 2 ^ 3 ^ 4 ^ 5
+6 ;
+7 ; NTRY is required
if $GET(NTRY)=""
QUIT
+8 ; FileMan FDA array for audits
NEW RCFDA
+9 SET RCFDA(344.7,"+1,",.01)=$$NOW^XLFDT
+10 ; IEN
SET RCFDA(344.7,"+1,",.02)=$PIECE(NTRY,U)
+11 ; USER (POSTMASTER)
SET RCFDA(344.7,"+1,",.03)=.5
+12 ; FIELD NUMBER
SET RCFDA(344.7,"+1,",.04)=$PIECE(NTRY,U,2)
+13 ; FILE NUMBER
SET RCFDA(344.7,"+1,",.05)=344.6
+14 ; NEW VALUE
SET RCFDA(344.7,"+1,",.06)=$PIECE(NTRY,U,3)
+15 ; OLD VALUE
SET RCFDA(344.7,"+1,",.07)=$PIECE(NTRY,U,4)
+16 ; COMMENT
SET RCFDA(344.7,"+1,",.08)=$PIECE(NTRY,U,5)
+17 DO UPDATE^DIE(,"RCFDA")
+18 QUIT
+19 ;
IOCMLMSG(RCACT) ; RCACT - activity to include MailMan message text
+1 NEW RCMSGTXT,RCSITE,RCSUBJ,XMINSTR,XMTO
+2 SET RCSITE=$$SITE^VASITE
+3 ; limit subject to 65 chars.
+4 SET RCSUBJ=$EXTRACT("ePayments IOC activity "_$PIECE(RCSITE,U,2),1,65)
+5 SET RCMSGTXT(1)=" "
+6 SET RCMSGTXT(2)=" Site: "_$PIECE(RCSITE,U,2)
+7 SET RCMSGTXT(3)=" Station # "_$PIECE(RCSITE,U,3)
+8 SET RCMSGTXT(4)=" Domain: "_$GET(^XMB("NETNAME"))
+9 SET RCMSGTXT(5)=" Date/Time: "_$$FMTE^XLFDT($$NOW^XLFDT,"1ZPM")
+10 SET RCMSGTXT(6)=" User: "_$PIECE($GET(^VA(200,DUZ,0)),U)
+11 SET RCMSGTXT(7)=" "
+12 SET RCMSGTXT(8)=" The following IOC activity was performed: "
+13 SET RCMSGTXT(9)=" "_$CHAR(34)_$GET(RCACT)_$CHAR(34)
+14 ;
+15 SET XMINSTR("FROM")="POSTMASTER"
+16 ;
+17 SET XMTO(DUZ)=""
SET XMTO("G.RCDPE PAYMENTS MGMT")=""
+18 ;
+19 KILL ^TMP("XMERR",$JOB)
+20 DO SENDMSG^XMXAPI(DUZ,RCSUBJ,"RCMSGTXT",.XMTO,.XMINSTR)
+21 ;
+22 IF $DATA(^TMP("XMERR",$JOB))
Begin DoDot:1
+23 DO MES^XPDUTL("MailMan returned an error.")
+24 DO MES^XPDUTL("The error text is:")
+25 NEW G
SET G=$NAME(^TMP("XMERR",$JOB))
+26 FOR
SET G=$QUERY(@G)
if G=""
QUIT
if $QSUBSCRIPT(G,2)'=$JOB
QUIT
DO MES^XPDUTL(" "_$CHAR(34)_@G_$CHAR(34))
+27 DO MES^XPDUTL(" * End of Error Text *")
+28 KILL ^TMP("XMERR",$JOB)
End DoDot:1
+29 ;
+30 QUIT
+31 ;
