PRCAP269 ;ALB/PJH - PRCA*4.5*269 POST INSTALL ; 3/9/11 12:50pm
;;4.5;Accounts Receivable;**269**;Mar 20, 1995;Build 113
;;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
POST ;Called from PRCA*4.5*269 patch install
;
;Move ERA file #344.4 and EFT file #344.31 fields to new locations
;
N M,OK,PROG,X,X1,X2
S PROG="PRCAP269"
;Clear workfile
K ^TMP(PROG,$J)
;
;Lock ^XTMP
L +^XTMP(PROG):5 E D BMES^XPDUTL("Conversion ABORTED") Q
;XTMP purge Date is today+90
S X1=DT,X2=90 D C^%DTC
;Set up ^XTMP header
S ^XTMP(PROG,0)=X_"^"_DT_"^PRCA*4.5*269 Post Install"
;
D BMES^XPDUTL("Deleting Obsolete Cross References")
D DELIX^DDMOD(344.31,.02,1) ;PAYER NAME - "C"
D DELIX^DDMOD(344.31,.04,1) ;TRACE # - "D"
D DELIX^DDMOD(344.4,.02,1) ;TRACE # - "D"
D DELIX^DDMOD(344.42,.01,1) ;REFERENCE NUMBER - "B"
;
D BMES^XPDUTL("Converting EDI THIRD PARTY EFT DETAIL FILE")
D MOVEEFT
;
D BMES^XPDUTL("Converting ELECTRONIC REMITTANCE ADVICE file")
D MOVEERA,MOVEERA1,MOVEERA2
;
;Send mail message to patch installer
D MAIL
;
;Send mail message to CBO release coordinators
D MAILCBO
;
;Clear workfile
K ^TMP(PROG,$J)
;
D BMES^XPDUTL("Conversion COMPLETED")
;Release ^XTMP
L -^XTMP(PROG)
Q
;
MAIL ;Installer mail message
N XMDUZ,XMTEXT,XMSUB,XMY,XMINSTR
S XMDUZ=DUZ
S XMTEXT="^TMP(""PRCAP269"","_$J_")"
S XMSUB="PRCA*4.5*269 Post Install - Completed"
S XMY(DUZ)=""
S XMINSTR("FROM")="VistA routine PRCAP269"
D SENDMSG^XMXAPI(XMDUZ,XMSUB,XMTEXT,.XMY,.XMINSTR)
Q
;
MAILCBO ;CBO notification mail message
N %,INSTNAME,M,MSG,SITE,STATION,X,XMDUZ,XMTEXT,XMSUB,XMY,XMINSTR
S M=0
D NOW^%DTC
;IA - 10112 supported reference
S SITE=$$SITE^VASITE,STATION=$P(SITE,U,3),INSTNAME=$P(SITE,U,2)
S M=M+1,MSG(M)="Institution Name: "_INSTNAME
S M=M+1,MSG(M)="Station Number : "_STATION
S M=M+1,MSG(M)=""
S M=M+1,MSG(M)="Completed Install "_$$FMTE^XLFDT(%)
S XMDUZ=DUZ
S XMTEXT="MSG"
S XMSUB="ePayments - Station "_STATION
S XMY(DUZ)=""
S:$$PROD^XUPROD(1) XMY("VHACBOEPAY5010@DOMAIN.EXT")=""
S XMINSTR("FROM")="VistA routine PRCAP269"
D SENDMSG^XMXAPI(XMDUZ,XMSUB,XMTEXT,.XMY,.XMINSTR)
;
I $D(^TMP("XMERR",$J)) D
.D MES^XPDUTL("MailMan reported a problem trying to send the installation notification message.")
.D MES^XPDUTL(" ")
.N GLO,GLB
.S GLB="^TMP(""XMERR"","_$J,GLO=GLB_")"
.F S GLO=$Q(@GLO) Q:GLO'[GLB D MES^XPDUTL(" "_GLO_" = "_$G(@GLO))
.D MES^XPDUTL(" ")
Q
;
MOVEEFT ;Move existing EFT (File #344.31) field to new global node
;
;Moves field ACH TRACE # (.15)
;from ^RCY(344.31,D0,0) piece 15
;to ^RCY(344.31,D0,1) piece 1
;
;Moves field MANUAL TR DOCUMENT (.16)
;from ^RCY(344.31,D0,0) piece 16
;to ^RCY(344.31,D0,1) piece 2
;
N %,C,I,N,VALUE,X
S C=0,M=0
;Update mail message
D NOW^%DTC
S M=M+1,^TMP(PROG,$J,M)="Started EFT file at "_$$FMTE^XLFDT(%)
;Scan file moving non-null fields only into ^XTMP and new location
;and clear field in original location
S N=0 F I=1:1 S N=$O(^RCY(344.31,N)) Q:'N S VALUE=$P($G(^RCY(344.31,N,0)),U,15,16) I $P(VALUE,U)'="",$P(VALUE,U,2)'="" S C=C+1,^XTMP(PROG,"EFT",C)=VALUE_U_N,^RCY(344.31,N,1)=VALUE,$P(^RCY(344.31,N,0),U,15)="",$P(^RCY(344.31,N,0),U,16)=""
;Completion time
D NOW^%DTC
S M=M+1,^TMP(PROG,$J,M)="Completed EFT file at "_$$FMTE^XLFDT(%)
S M=M+1,^TMP(PROG,$J,M)="Count of records in EFT file - "_(I-1)
S M=M+1,^TMP(PROG,$J,M)="Count of fields moved - "_+C
Q
;
;
MOVEERA ;Move existing ERA (File #344.4) field to new global node
;
;Moves field CHECK# (.13)
;from ^RCY(344.4,D0,0) piece 13
;to ^RCY(344.4,D0,5) piece 2
;
;
N %,C,I,N,VALUE,X
S C=0
;Update mail message
D NOW^%DTC
S M=M+1,^TMP(PROG,$J,M)="Started ERA file at "_$$FMTE^XLFDT(%)
;Scan file moving non-null fields only into ^XTMP and new location
;and clear field in original location
S N=0 F I=1:1 S N=$O(^RCY(344.4,N)) Q:'N S VALUE=$P($G(^RCY(344.4,N,0)),U,13) I VALUE]"" S C=C+1,^XTMP(PROG,"ERA",C)=VALUE_U_N,$P(^RCY(344.4,N,5),U,2)=VALUE,$P(^RCY(344.4,N,0),U,13)=""
;Completion time
D NOW^%DTC
S M=M+1,^TMP(PROG,$J,M)="Completed ERA file at "_$$FMTE^XLFDT(%)
S M=M+1,^TMP(PROG,$J,M)="Count of records in ERA file - "_(I-1)
S M=M+1,^TMP(PROG,$J,M)="Count of fields moved - "_+C
Q
;
MOVEERA1 ;Move existing ERA (File #344.41) field to new global node
;
;Moves field REN PROV COMMENT (#.23)
;from ^RCY(344.4,D0,1,D1,3) piece 5
;to ^RCY(344.4,D0,1,D1,4) piece 1
;
;
N %,C,I,N,N1,VALUE,X
S C=0
;Update mail message
D NOW^%DTC
S M=M+1,^TMP(PROG,$J,M)="Started ERA,1 file at "_$$FMTE^XLFDT(%)
;Scan file moving non-null fields only into ^XTMP and new location
;and clear field in original location
S N=0,I=0
F S N=$O(^RCY(344.4,N)) Q:'N S N1=0 D
.F S N1=$O(^RCY(344.4,N,1,N1)) Q:'N1 D
..S I=I+1,VALUE=$P($G(^RCY(344.4,N,1,N1,3)),U,5) I VALUE]"" S C=C+1,^XTMP(PROG,"ERA1",C)=VALUE_U_N_U_N1,^RCY(344.4,N,1,N1,4)=VALUE,$P(^RCY(344.4,N,1,N1,3),U,5)=""
;Completion time
D NOW^%DTC
S M=M+1,^TMP(PROG,$J,M)="Completed ERA,1 file at "_$$FMTE^XLFDT(%)
S M=M+1,^TMP(PROG,$J,M)="Count of records in ERA,1 file - "_+I
S M=M+1,^TMP(PROG,$J,M)="Count of fields moved - "_+C
Q
;
MOVEERA2 ;Move existing ERA (File #344.42) field to new global node
;
;Moves field ADJUSTMENT TEXT (#.04)
;from ^RCY(344.4,D0,2,D1,0) piece 4
;to ^RCY(344.4,D0,2,D1,1) piece 1
;
;
N %,C,I,N,N1,VALUE,X
S C=0
;Update mail message
D NOW^%DTC
S M=M+1,^TMP(PROG,$J,M)="Started ERA,2 file at "_$$FMTE^XLFDT(%)
;Scan file moving non-null fields only into ^XTMP and new location
;and clear field in original location
S N=0,I=0
F S N=$O(^RCY(344.4,N)) Q:'N S N1=0 D
.F S N1=$O(^RCY(344.4,N,2,N1)) Q:'N1 D
..S I=I+1,VALUE=$P($G(^RCY(344.4,N,2,N1,0)),U,4) I VALUE]"" S C=C+1,^XTMP(PROG,"ERA2",C)=VALUE_U_N_U_N1,^RCY(344.4,N,2,N1,1)=VALUE,$P(^RCY(344.4,N,2,N1,0),U,4)=""
;Completion time
D NOW^%DTC
;Also update XTMP as complete
S $P(^XTMP(PROG,0),U,4)=X
S M=M+1,^TMP(PROG,$J,M)="Completed ERA,2 file at "_$$FMTE^XLFDT(%)
S M=M+1,^TMP(PROG,$J,M)="Count of records in ERA,2 file - "_+I
S M=M+1,^TMP(PROG,$J,M)="Count of fields moved - "_+C
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAP269 6297 printed Dec 13, 2024@01:40:35 Page 2
PRCAP269 ;ALB/PJH - PRCA*4.5*269 POST INSTALL ; 3/9/11 12:50pm
+1 ;;4.5;Accounts Receivable;**269**;Mar 20, 1995;Build 113
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
POST ;Called from PRCA*4.5*269 patch install
+1 ;
+2 ;Move ERA file #344.4 and EFT file #344.31 fields to new locations
+3 ;
+4 NEW M,OK,PROG,X,X1,X2
+5 SET PROG="PRCAP269"
+6 ;Clear workfile
+7 KILL ^TMP(PROG,$JOB)
+8 ;
+9 ;Lock ^XTMP
+10 LOCK +^XTMP(PROG):5
IF '$TEST
DO BMES^XPDUTL("Conversion ABORTED")
QUIT
+11 ;XTMP purge Date is today+90
+12 SET X1=DT
SET X2=90
DO C^%DTC
+13 ;Set up ^XTMP header
+14 SET ^XTMP(PROG,0)=X_"^"_DT_"^PRCA*4.5*269 Post Install"
+15 ;
+16 DO BMES^XPDUTL("Deleting Obsolete Cross References")
+17 ;PAYER NAME - "C"
DO DELIX^DDMOD(344.31,.02,1)
+18 ;TRACE # - "D"
DO DELIX^DDMOD(344.31,.04,1)
+19 ;TRACE # - "D"
DO DELIX^DDMOD(344.4,.02,1)
+20 ;REFERENCE NUMBER - "B"
DO DELIX^DDMOD(344.42,.01,1)
+21 ;
+22 DO BMES^XPDUTL("Converting EDI THIRD PARTY EFT DETAIL FILE")
+23 DO MOVEEFT
+24 ;
+25 DO BMES^XPDUTL("Converting ELECTRONIC REMITTANCE ADVICE file")
+26 DO MOVEERA
DO MOVEERA1
DO MOVEERA2
+27 ;
+28 ;Send mail message to patch installer
+29 DO MAIL
+30 ;
+31 ;Send mail message to CBO release coordinators
+32 DO MAILCBO
+33 ;
+34 ;Clear workfile
+35 KILL ^TMP(PROG,$JOB)
+36 ;
+37 DO BMES^XPDUTL("Conversion COMPLETED")
+38 ;Release ^XTMP
+39 LOCK -^XTMP(PROG)
+40 QUIT
+41 ;
MAIL ;Installer mail message
+1 NEW XMDUZ,XMTEXT,XMSUB,XMY,XMINSTR
+2 SET XMDUZ=DUZ
+3 SET XMTEXT="^TMP(""PRCAP269"","_$JOB_")"
+4 SET XMSUB="PRCA*4.5*269 Post Install - Completed"
+5 SET XMY(DUZ)=""
+6 SET XMINSTR("FROM")="VistA routine PRCAP269"
+7 DO SENDMSG^XMXAPI(XMDUZ,XMSUB,XMTEXT,.XMY,.XMINSTR)
+8 QUIT
+9 ;
MAILCBO ;CBO notification mail message
+1 NEW %,INSTNAME,M,MSG,SITE,STATION,X,XMDUZ,XMTEXT,XMSUB,XMY,XMINSTR
+2 SET M=0
+3 DO NOW^%DTC
+4 ;IA - 10112 supported reference
+5 SET SITE=$$SITE^VASITE
SET STATION=$PIECE(SITE,U,3)
SET INSTNAME=$PIECE(SITE,U,2)
+6 SET M=M+1
SET MSG(M)="Institution Name: "_INSTNAME
+7 SET M=M+1
SET MSG(M)="Station Number : "_STATION
+8 SET M=M+1
SET MSG(M)=""
+9 SET M=M+1
SET MSG(M)="Completed Install "_$$FMTE^XLFDT(%)
+10 SET XMDUZ=DUZ
+11 SET XMTEXT="MSG"
+12 SET XMSUB="ePayments - Station "_STATION
+13 SET XMY(DUZ)=""
+14 if $$PROD^XUPROD(1)
SET XMY("VHACBOEPAY5010@DOMAIN.EXT")=""
+15 SET XMINSTR("FROM")="VistA routine PRCAP269"
+16 DO SENDMSG^XMXAPI(XMDUZ,XMSUB,XMTEXT,.XMY,.XMINSTR)
+17 ;
+18 IF $DATA(^TMP("XMERR",$JOB))
Begin DoDot:1
+19 DO MES^XPDUTL("MailMan reported a problem trying to send the installation notification message.")
+20 DO MES^XPDUTL(" ")
+21 NEW GLO,GLB
+22 SET GLB="^TMP(""XMERR"","_$JOB
SET GLO=GLB_")"
+23 FOR
SET GLO=$QUERY(@GLO)
if GLO'[GLB
QUIT
DO MES^XPDUTL(" "_GLO_" = "_$GET(@GLO))
+24 DO MES^XPDUTL(" ")
End DoDot:1
+25 QUIT
+26 ;
MOVEEFT ;Move existing EFT (File #344.31) field to new global node
+1 ;
+2 ;Moves field ACH TRACE # (.15)
+3 ;from ^RCY(344.31,D0,0) piece 15
+4 ;to ^RCY(344.31,D0,1) piece 1
+5 ;
+6 ;Moves field MANUAL TR DOCUMENT (.16)
+7 ;from ^RCY(344.31,D0,0) piece 16
+8 ;to ^RCY(344.31,D0,1) piece 2
+9 ;
+10 NEW %,C,I,N,VALUE,X
+11 SET C=0
SET M=0
+12 ;Update mail message
+13 DO NOW^%DTC
+14 SET M=M+1
SET ^TMP(PROG,$JOB,M)="Started EFT file at "_$$FMTE^XLFDT(%)
+15 ;Scan file moving non-null fields only into ^XTMP and new location
+16 ;and clear field in original location
+17 SET N=0
FOR I=1:1
SET N=$ORDER(^RCY(344.31,N))
if 'N
QUIT
SET VALUE=$PIECE($GET(^RCY(344.31,N,0)),U,15,16)
IF $PIECE(VALUE,U)'=""
IF $PIECE(VALUE,U,2)'=""
SET C=C+1
SET ^XTMP(PROG,"EFT",C)=VALUE_U_N
SET ^RCY(344.31,N,1)=VALUE
SET $PIECE(^RCY(344.31,N,0),U,15)=""
SET $PIECE(^RCY(344.31,N,0),U,16)=""
+18 ;Completion time
+19 DO NOW^%DTC
+20 SET M=M+1
SET ^TMP(PROG,$JOB,M)="Completed EFT file at "_$$FMTE^XLFDT(%)
+21 SET M=M+1
SET ^TMP(PROG,$JOB,M)="Count of records in EFT file - "_(I-1)
+22 SET M=M+1
SET ^TMP(PROG,$JOB,M)="Count of fields moved - "_+C
+23 QUIT
+24 ;
+25 ;
MOVEERA ;Move existing ERA (File #344.4) field to new global node
+1 ;
+2 ;Moves field CHECK# (.13)
+3 ;from ^RCY(344.4,D0,0) piece 13
+4 ;to ^RCY(344.4,D0,5) piece 2
+5 ;
+6 ;
+7 NEW %,C,I,N,VALUE,X
+8 SET C=0
+9 ;Update mail message
+10 DO NOW^%DTC
+11 SET M=M+1
SET ^TMP(PROG,$JOB,M)="Started ERA file at "_$$FMTE^XLFDT(%)
+12 ;Scan file moving non-null fields only into ^XTMP and new location
+13 ;and clear field in original location
+14 SET N=0
FOR I=1:1
SET N=$ORDER(^RCY(344.4,N))
if 'N
QUIT
SET VALUE=$PIECE($GET(^RCY(344.4,N,0)),U,13)
IF VALUE]""
SET C=C+1
SET ^XTMP(PROG,"ERA",C)=VALUE_U_N
SET $PIECE(^RCY(344.4,N,5),U,2)=VALUE
SET $PIECE(^RCY(344.4,N,0),U,13)=""
+15 ;Completion time
+16 DO NOW^%DTC
+17 SET M=M+1
SET ^TMP(PROG,$JOB,M)="Completed ERA file at "_$$FMTE^XLFDT(%)
+18 SET M=M+1
SET ^TMP(PROG,$JOB,M)="Count of records in ERA file - "_(I-1)
+19 SET M=M+1
SET ^TMP(PROG,$JOB,M)="Count of fields moved - "_+C
+20 QUIT
+21 ;
MOVEERA1 ;Move existing ERA (File #344.41) field to new global node
+1 ;
+2 ;Moves field REN PROV COMMENT (#.23)
+3 ;from ^RCY(344.4,D0,1,D1,3) piece 5
+4 ;to ^RCY(344.4,D0,1,D1,4) piece 1
+5 ;
+6 ;
+7 NEW %,C,I,N,N1,VALUE,X
+8 SET C=0
+9 ;Update mail message
+10 DO NOW^%DTC
+11 SET M=M+1
SET ^TMP(PROG,$JOB,M)="Started ERA,1 file at "_$$FMTE^XLFDT(%)
+12 ;Scan file moving non-null fields only into ^XTMP and new location
+13 ;and clear field in original location
+14 SET N=0
SET I=0
+15 FOR
SET N=$ORDER(^RCY(344.4,N))
if 'N
QUIT
SET N1=0
Begin DoDot:1
+16 FOR
SET N1=$ORDER(^RCY(344.4,N,1,N1))
if 'N1
QUIT
Begin DoDot:2
+17 SET I=I+1
SET VALUE=$PIECE($GET(^RCY(344.4,N,1,N1,3)),U,5)
IF VALUE]""
SET C=C+1
SET ^XTMP(PROG,"ERA1",C)=VALUE_U_N_U_N1
SET ^RCY(344.4,N,1,N1,4)=VALUE
SET $PIECE(^RCY(344.4,N,1,N1,3),U,5)=""
End DoDot:2
End DoDot:1
+18 ;Completion time
+19 DO NOW^%DTC
+20 SET M=M+1
SET ^TMP(PROG,$JOB,M)="Completed ERA,1 file at "_$$FMTE^XLFDT(%)
+21 SET M=M+1
SET ^TMP(PROG,$JOB,M)="Count of records in ERA,1 file - "_+I
+22 SET M=M+1
SET ^TMP(PROG,$JOB,M)="Count of fields moved - "_+C
+23 QUIT
+24 ;
MOVEERA2 ;Move existing ERA (File #344.42) field to new global node
+1 ;
+2 ;Moves field ADJUSTMENT TEXT (#.04)
+3 ;from ^RCY(344.4,D0,2,D1,0) piece 4
+4 ;to ^RCY(344.4,D0,2,D1,1) piece 1
+5 ;
+6 ;
+7 NEW %,C,I,N,N1,VALUE,X
+8 SET C=0
+9 ;Update mail message
+10 DO NOW^%DTC
+11 SET M=M+1
SET ^TMP(PROG,$JOB,M)="Started ERA,2 file at "_$$FMTE^XLFDT(%)
+12 ;Scan file moving non-null fields only into ^XTMP and new location
+13 ;and clear field in original location
+14 SET N=0
SET I=0
+15 FOR
SET N=$ORDER(^RCY(344.4,N))
if 'N
QUIT
SET N1=0
Begin DoDot:1
+16 FOR
SET N1=$ORDER(^RCY(344.4,N,2,N1))
if 'N1
QUIT
Begin DoDot:2
+17 SET I=I+1
SET VALUE=$PIECE($GET(^RCY(344.4,N,2,N1,0)),U,4)
IF VALUE]""
SET C=C+1
SET ^XTMP(PROG,"ERA2",C)=VALUE_U_N_U_N1
SET ^RCY(344.4,N,2,N1,1)=VALUE
SET $PIECE(^RCY(344.4,N,2,N1,0),U,4)=""
End DoDot:2
End DoDot:1
+18 ;Completion time
+19 DO NOW^%DTC
+20 ;Also update XTMP as complete
+21 SET $PIECE(^XTMP(PROG,0),U,4)=X
+22 SET M=M+1
SET ^TMP(PROG,$JOB,M)="Completed ERA,2 file at "_$$FMTE^XLFDT(%)
+23 SET M=M+1
SET ^TMP(PROG,$JOB,M)="Count of records in ERA,2 file - "_+I
+24 SET M=M+1
SET ^TMP(PROG,$JOB,M)="Count of fields moved - "_+C
+25 QUIT
