IBP431 ;ALB/PJH - POST INSTALL FOR IB*2.0*431 ; 4/25/11 5:24pm
;;2.0;INTEGRATED BILLING;**431**;21-MAR-94;Build 106
;;Per VHA Directive 2004-038, this routine should not be modified.
;
Q
;
POST ;Called from IB*2*431 patch install
;
;Move EOB file #361.1 fields to new location
;
N OK,PROG
S PROG="IBP431"
K ^TMP(PROG,$J)
D BMES^XPDUTL("Converting EXPLANATION OF BENEFIT FILE")
S OK=$$MOVE(PROG)
I OK D BMES^XPDUTL("Conversion COMPLETED")
I 'OK D BMES^XPDUTL("Conversion ABORTED")
K ^TMP(PROG,$J)
Q
;
MAIL ;Send mail message
N XMDUZ,XMTEXT,XMSUB,XMY,XMINSTR
S XMDUZ=DUZ
S XMTEXT="^TMP(""IBP431"","_$J_")"
S XMSUB="IB*2.0*431 Post Install - Completed"
S XMY(DUZ)=""
S XMINSTR("FROM")="VistA routine IBP431"
D SENDMSG^XMXAPI(XMDUZ,XMSUB,XMTEXT,.XMY,.XMINSTR)
Q
;
MOVE(PROG) ;Move existing field to new global node
;
;Moves field CROSSED OVER NAME (361.1, #.08)
;from ^IBM(361.1,D0,0) piece 8
;to ^IBM(361.1,D0,51) piece 2
;
N C,I,M,N,VALUE,X,X1,X2,%
S C=0,M=0
;Lock ^XTMP
L +^XTMP(PROG):5 E Q 0
;Update mail message
D NOW^%DTC S M=M+1,^TMP(PROG,$J,M)="Started "_$$FMTE^XLFDT(%)
;XTMP purge Date is today+90
S X1=DT,X2=90 D C^%DTC
;Set up ^XTMP header
S ^XTMP(PROG,0)=X_"^"_DT_"^IB*2.0*431 Post Install"
;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(^IBM(361.1,N)) Q:'N S VALUE=$P($G(^IBM(361.1,N,0)),U,8) I VALUE]"" S C=C+1,^XTMP(PROG,C)=VALUE_U_N,$P(^IBM(361.1,N,51),U,2)=VALUE,$P(^IBM(361.1,N,0),U,8)=""
;Completion time
D NOW^%DTC
S $P(^XTMP(PROG,0),U,4)=X
S M=M+1,^TMP(PROG,$J,M)="Completed "_$$FMTE^XLFDT(%)
S M=M+1,^TMP(PROG,$J,M)="Count of records in EOB file - "_(I-1)
S M=M+1,^TMP(PROG,$J,M)="Count of fields moved - "_+C
;Send mail message to patch installer
D MAIL
;Release ^XTMP
L -^XTMP(PROG)
Q 1
;
RESET ;Restore original fields
Q
N DIR,N,C,VALUE,Y
S DIR("A")="Move data to original location"
S DIR(0)="Y",DIR("B")="YES" D ^DIR Q:Y'=1
S C=0
F S C=$O(^XTMP("IBP431",C)) Q:'C D
.;Get values saved in ^XTMP
.S VALUE=$P(^XTMP("IBP431",C),U),N=$P(^XTMP("IBP431",C),U,2)
.;Ignore if not present
.Q:(VALUE="")!('N)
.;Do not update if node is not defined
.Q:$G(^IBM(361.1,N,0))=""
.;Or if data already exists in field
.Q:$P($G(^IBM(361.1,N,0)),U,8)]""
.;Otherwise reset original value
.S $P(^IBM(361.1,N,0),U,8)=VALUE
.;And clear from 51 node
.K ^IBM(361.1,N,51)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBP431 2510 printed Dec 13, 2024@02:26:26 Page 2
IBP431 ;ALB/PJH - POST INSTALL FOR IB*2.0*431 ; 4/25/11 5:24pm
+1 ;;2.0;INTEGRATED BILLING;**431**;21-MAR-94;Build 106
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
POST ;Called from IB*2*431 patch install
+1 ;
+2 ;Move EOB file #361.1 fields to new location
+3 ;
+4 NEW OK,PROG
+5 SET PROG="IBP431"
+6 KILL ^TMP(PROG,$JOB)
+7 DO BMES^XPDUTL("Converting EXPLANATION OF BENEFIT FILE")
+8 SET OK=$$MOVE(PROG)
+9 IF OK
DO BMES^XPDUTL("Conversion COMPLETED")
+10 IF 'OK
DO BMES^XPDUTL("Conversion ABORTED")
+11 KILL ^TMP(PROG,$JOB)
+12 QUIT
+13 ;
MAIL ;Send mail message
+1 NEW XMDUZ,XMTEXT,XMSUB,XMY,XMINSTR
+2 SET XMDUZ=DUZ
+3 SET XMTEXT="^TMP(""IBP431"","_$JOB_")"
+4 SET XMSUB="IB*2.0*431 Post Install - Completed"
+5 SET XMY(DUZ)=""
+6 SET XMINSTR("FROM")="VistA routine IBP431"
+7 DO SENDMSG^XMXAPI(XMDUZ,XMSUB,XMTEXT,.XMY,.XMINSTR)
+8 QUIT
+9 ;
MOVE(PROG) ;Move existing field to new global node
+1 ;
+2 ;Moves field CROSSED OVER NAME (361.1, #.08)
+3 ;from ^IBM(361.1,D0,0) piece 8
+4 ;to ^IBM(361.1,D0,51) piece 2
+5 ;
+6 NEW C,I,M,N,VALUE,X,X1,X2,%
+7 SET C=0
SET M=0
+8 ;Lock ^XTMP
+9 LOCK +^XTMP(PROG):5
IF '$TEST
QUIT 0
+10 ;Update mail message
+11 DO NOW^%DTC
SET M=M+1
SET ^TMP(PROG,$JOB,M)="Started "_$$FMTE^XLFDT(%)
+12 ;XTMP purge Date is today+90
+13 SET X1=DT
SET X2=90
DO C^%DTC
+14 ;Set up ^XTMP header
+15 SET ^XTMP(PROG,0)=X_"^"_DT_"^IB*2.0*431 Post Install"
+16 ;Scan file moving non-null fields only into ^XTMP and new location
+17 ;and clear field in original location
+18 SET N=0
FOR I=1:1
SET N=$ORDER(^IBM(361.1,N))
if 'N
QUIT
SET VALUE=$PIECE($GET(^IBM(361.1,N,0)),U,8)
IF VALUE]""
SET C=C+1
SET ^XTMP(PROG,C)=VALUE_U_N
SET $PIECE(^IBM(361.1,N,51),U,2)=VALUE
SET $PIECE(^IBM(361.1,N,0),U,8)=""
+19 ;Completion time
+20 DO NOW^%DTC
+21 SET $PIECE(^XTMP(PROG,0),U,4)=X
+22 SET M=M+1
SET ^TMP(PROG,$JOB,M)="Completed "_$$FMTE^XLFDT(%)
+23 SET M=M+1
SET ^TMP(PROG,$JOB,M)="Count of records in EOB file - "_(I-1)
+24 SET M=M+1
SET ^TMP(PROG,$JOB,M)="Count of fields moved - "_+C
+25 ;Send mail message to patch installer
+26 DO MAIL
+27 ;Release ^XTMP
+28 LOCK -^XTMP(PROG)
+29 QUIT 1
+30 ;
RESET ;Restore original fields
+1 QUIT
+2 NEW DIR,N,C,VALUE,Y
+3 SET DIR("A")="Move data to original location"
+4 SET DIR(0)="Y"
SET DIR("B")="YES"
DO ^DIR
if Y'=1
QUIT
+5 SET C=0
+6 FOR
SET C=$ORDER(^XTMP("IBP431",C))
if 'C
QUIT
Begin DoDot:1
+7 ;Get values saved in ^XTMP
+8 SET VALUE=$PIECE(^XTMP("IBP431",C),U)
SET N=$PIECE(^XTMP("IBP431",C),U,2)
+9 ;Ignore if not present
+10 if (VALUE="")!('N)
QUIT
+11 ;Do not update if node is not defined
+12 if $GET(^IBM(361.1,N,0))=""
QUIT
+13 ;Or if data already exists in field
+14 if $PIECE($GET(^IBM(361.1,N,0)),U,8)]""
QUIT
+15 ;Otherwise reset original value
+16 SET $PIECE(^IBM(361.1,N,0),U,8)=VALUE
+17 ;And clear from 51 node
+18 KILL ^IBM(361.1,N,51)
End DoDot:1
+19 QUIT
