DIEKMSG ;SFISC/MKO-PRINT MESSAGE ABOUT BAD KEYS ;12:47 PM 18 Feb 1998
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
MSG(DIEBADK,DIEREST) ;Print message
Q:$D(DIEBADK)<2
;
N ANS,FIL,FINFO,FLD,KEY,LEV,MSG,NEW,OLD,REC,RFIL,TXT,DIERR
K ^TMP("DIEMSG",$J)
;
D PROMPT(DIEREST,.ANS) Q:'ANS
;
W !
I DIEREST D
. D L("The following field(s) have been restored to their pre-edited values:")
E D L("The following field values are not valid:")
D L("")
;
;Loop through root files
S RFIL=0 F S RFIL=$O(DIEBADK(RFIL)) Q:'RFIL D
. D FILENAME^DIKCU1(RFIL,.TXT,.FINFO) Q:'$D(FINFO)
. D FILELN(.TXT,FINFO)
. ;
. ;Loop through keys
. S KEY=0 F S KEY=$O(DIEBADK(RFIL,KEY)) Q:'KEY D
.. D L(" Key: "_$P(^DD("KEY",KEY,0),U,2))
.. ;
.. ;Loop through files
.. S FIL=0 F S FIL=$O(DIEBADK(RFIL,KEY,FIL)) Q:'FIL D
... ;
... ;Loop through records
... S REC=0 F S REC=$O(DIEBADK(RFIL,KEY,FIL,REC)) Q:'REC D
.... D RECNAME^DIKCU1("",REC,.TXT,.FINFO)
.... D RECLN(.TXT,FINFO)
.... ;
.... ;Loop through fields
.... S FLD=0 F S FLD=$O(DIEBADK(RFIL,KEY,FIL,REC,FLD)) Q:'FLD D
..... S OLD=$G(DIEBADK(RFIL,KEY,FIL,REC,FLD,"O"))
..... S NEW=$G(DIEBADK(RFIL,KEY,FIL,REC,FLD,"N"))
..... S OLD=$S(OLD]"":$$EXTERNAL^DILFD(FIL,FLD,"",OLD,"MSG"),1:"<null>")
..... S NEW=$S(NEW]"":$$EXTERNAL^DILFD(FIL,FLD,"",NEW,"MSG"),1:"<null>")
..... I $G(DIERR) K DIERR,MSG Q
..... D L("")
..... D L($J("",14)_"Field: "_$P(^DD(FIL,FLD,0),U)_" (#"_FLD_")")
..... D L($J("",6)_"Invalid value: "),L(NEW,1,21)
..... D:$G(DIEREST) L($J("",8)_"Restored to: "),L(OLD,1,21)
.... D L("")
;
I $D(^TMP("DIEMSG",$J)) D PRINT
K ^TMP("DIEMSG",$J)
Q
;
FILELN(TXT,LEV) ;
N I,MAR
S MAR=$S($G(IOM)<40:80,1:IOM)-1
;
S TXT=$S(LEV:"Subfile",1:"File")_": "_TXT
D WRAP^DIKCU2(.TXT,MAR-9,MAR)
D L(TXT) F I=1:1 Q:'$D(TXT(I)) D L($J("",9)_TXT(I))
Q
;
RECLN(TXT,LEV) ;
N I,MAR
S MAR=$S($G(IOM)<40:80,1:IOM)-1
;
S TXT=" Record: "_TXT
D WRAP^DIKCU2(.TXT,MAR-12,MAR)
D L(TXT) F I=1:1 Q:'$D(TXT(I)) D L($J("",12)_TXT(I))
Q
;
L(X,A,LM) ;Add X to the DIEMSG array
N LC
S LC=$O(^TMP("DIEMSG",$J,""),-1)
;
I '$G(LM) D Q
. I '$G(A) S ^TMP("DIEMSG",$J,LC+1)=X
. E S ^(LC)=^TMP("DIEMSG",$J,LC)_X
;
N I,M,T
S M=$S($G(IOM)<40:80,1:IOM)-1 S:M'>LM LM=0
F I=1:1 D Q:X=""
. S T=$E(X,1,M-LM),X=$E(X,M-LM+1,999)
. I I=1,$G(A) S ^(LC)=^TMP("DIEMSG",$J,LC)_T
. E S LC=LC+1,^TMP("DIEMSG",$J,LC)=$J("",LM)_T
Q
;
PRINT ;Print lines stored in ^TMP("DIEMSG",$J)
N I,LC,SL
S SL=$S($G(IOSL)<4:24,1:IOSL)
S (I,LC)=0 F S I=$O(^TMP("DIEMSG",$J,I)) Q:'I D
. S LC=LC+1
. W ^TMP("DIEMSG",$J,I),!
. I LC'<(SL-2) D
.. N DIR,DUOUT,DTOUT,DIRUT,DIROUT,X,Y
.. S DIR(0)="E" D ^DIR W !!
.. S LC=0
Q
;
PROMPT(DIEREST,ANS) ;Ask user whether to print report
N DIR,X,Y,DTOUT,DUOUT,DIROUT,DIRUT
W !!,$C(7)_"***** NOTE *****"
W !!,"Some of the previous edits are not valid because they create one or more"
W !,"duplicate keys."
I $G(DIEREST) D
. W " Some fields have been restored to their pre-edited"
. W !,"values."
W !
;
S DIR(0)="Y",DIR("B")="YES"
S DIR("A")="Do you want to see a list of those fields"
D ^DIR W !
S ANS=Y=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIEKMSG 3499 printed Oct 16, 2024@18:47:45 Page 2
DIEKMSG ;SFISC/MKO-PRINT MESSAGE ABOUT BAD KEYS ;12:47 PM 18 Feb 1998
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
MSG(DIEBADK,DIEREST) ;Print message
+1 if $DATA(DIEBADK)<2
QUIT
+2 ;
+3 NEW ANS,FIL,FINFO,FLD,KEY,LEV,MSG,NEW,OLD,REC,RFIL,TXT,DIERR
+4 KILL ^TMP("DIEMSG",$JOB)
+5 ;
+6 DO PROMPT(DIEREST,.ANS)
if 'ANS
QUIT
+7 ;
+8 WRITE !
+9 IF DIEREST
Begin DoDot:1
+10 DO L("The following field(s) have been restored to their pre-edited values:")
End DoDot:1
+11 IF '$TEST
DO L("The following field values are not valid:")
+12 DO L("")
+13 ;
+14 ;Loop through root files
+15 SET RFIL=0
FOR
SET RFIL=$ORDER(DIEBADK(RFIL))
if 'RFIL
QUIT
Begin DoDot:1
+16 DO FILENAME^DIKCU1(RFIL,.TXT,.FINFO)
if '$DATA(FINFO)
QUIT
+17 DO FILELN(.TXT,FINFO)
+18 ;
+19 ;Loop through keys
+20 SET KEY=0
FOR
SET KEY=$ORDER(DIEBADK(RFIL,KEY))
if 'KEY
QUIT
Begin DoDot:2
+21 DO L(" Key: "_$PIECE(^DD("KEY",KEY,0),U,2))
+22 ;
+23 ;Loop through files
+24 SET FIL=0
FOR
SET FIL=$ORDER(DIEBADK(RFIL,KEY,FIL))
if 'FIL
QUIT
Begin DoDot:3
+25 ;
+26 ;Loop through records
+27 SET REC=0
FOR
SET REC=$ORDER(DIEBADK(RFIL,KEY,FIL,REC))
if 'REC
QUIT
Begin DoDot:4
+28 DO RECNAME^DIKCU1("",REC,.TXT,.FINFO)
+29 DO RECLN(.TXT,FINFO)
+30 ;
+31 ;Loop through fields
+32 SET FLD=0
FOR
SET FLD=$ORDER(DIEBADK(RFIL,KEY,FIL,REC,FLD))
if 'FLD
QUIT
Begin DoDot:5
+33 SET OLD=$GET(DIEBADK(RFIL,KEY,FIL,REC,FLD,"O"))
+34 SET NEW=$GET(DIEBADK(RFIL,KEY,FIL,REC,FLD,"N"))
+35 SET OLD=$SELECT(OLD]"":$$EXTERNAL^DILFD(FIL,FLD,"",OLD,"MSG"),1:"<null>")
+36 SET NEW=$SELECT(NEW]"":$$EXTERNAL^DILFD(FIL,FLD,"",NEW,"MSG"),1:"<null>")
+37 IF $GET(DIERR)
KILL DIERR,MSG
QUIT
+38 DO L("")
+39 DO L($JUSTIFY("",14)_"Field: "_$PIECE(^DD(FIL,FLD,0),U)_" (#"_FLD_")")
+40 DO L($JUSTIFY("",6)_"Invalid value: ")
DO L(NEW,1,21)
+41 if $GET(DIEREST)
DO L($JUSTIFY("",8)_"Restored to: ")
DO L(OLD,1,21)
End DoDot:5
+42 DO L("")
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+43 ;
+44 IF $DATA(^TMP("DIEMSG",$JOB))
DO PRINT
+45 KILL ^TMP("DIEMSG",$JOB)
+46 QUIT
+47 ;
FILELN(TXT,LEV) ;
+1 NEW I,MAR
+2 SET MAR=$SELECT($GET(IOM)<40:80,1:IOM)-1
+3 ;
+4 SET TXT=$SELECT(LEV:"Subfile",1:"File")_": "_TXT
+5 DO WRAP^DIKCU2(.TXT,MAR-9,MAR)
+6 DO L(TXT)
FOR I=1:1
if '$DATA(TXT(I))
QUIT
DO L($JUSTIFY("",9)_TXT(I))
+7 QUIT
+8 ;
RECLN(TXT,LEV) ;
+1 NEW I,MAR
+2 SET MAR=$SELECT($GET(IOM)<40:80,1:IOM)-1
+3 ;
+4 SET TXT=" Record: "_TXT
+5 DO WRAP^DIKCU2(.TXT,MAR-12,MAR)
+6 DO L(TXT)
FOR I=1:1
if '$DATA(TXT(I))
QUIT
DO L($JUSTIFY("",12)_TXT(I))
+7 QUIT
+8 ;
L(X,A,LM) ;Add X to the DIEMSG array
+1 NEW LC
+2 SET LC=$ORDER(^TMP("DIEMSG",$JOB,""),-1)
+3 ;
+4 IF '$GET(LM)
Begin DoDot:1
+5 IF '$GET(A)
SET ^TMP("DIEMSG",$JOB,LC+1)=X
+6 IF '$TEST
SET ^(LC)=^TMP("DIEMSG",$JOB,LC)_X
End DoDot:1
QUIT
+7 ;
+8 NEW I,M,T
+9 SET M=$SELECT($GET(IOM)<40:80,1:IOM)-1
if M'>LM
SET LM=0
+10 FOR I=1:1
Begin DoDot:1
+11 SET T=$EXTRACT(X,1,M-LM)
SET X=$EXTRACT(X,M-LM+1,999)
+12 IF I=1
IF $GET(A)
SET ^(LC)=^TMP("DIEMSG",$JOB,LC)_T
+13 IF '$TEST
SET LC=LC+1
SET ^TMP("DIEMSG",$JOB,LC)=$JUSTIFY("",LM)_T
End DoDot:1
if X=""
QUIT
+14 QUIT
+15 ;
PRINT ;Print lines stored in ^TMP("DIEMSG",$J)
+1 NEW I,LC,SL
+2 SET SL=$SELECT($GET(IOSL)<4:24,1:IOSL)
+3 SET (I,LC)=0
FOR
SET I=$ORDER(^TMP("DIEMSG",$JOB,I))
if 'I
QUIT
Begin DoDot:1
+4 SET LC=LC+1
+5 WRITE ^TMP("DIEMSG",$JOB,I),!
+6 IF LC'<(SL-2)
Begin DoDot:2
+7 NEW DIR,DUOUT,DTOUT,DIRUT,DIROUT,X,Y
+8 SET DIR(0)="E"
DO ^DIR
WRITE !!
+9 SET LC=0
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
PROMPT(DIEREST,ANS) ;Ask user whether to print report
+1 NEW DIR,X,Y,DTOUT,DUOUT,DIROUT,DIRUT
+2 WRITE !!,$CHAR(7)_"***** NOTE *****"
+3 WRITE !!,"Some of the previous edits are not valid because they create one or more"
+4 WRITE !,"duplicate keys."
+5 IF $GET(DIEREST)
Begin DoDot:1
+6 WRITE " Some fields have been restored to their pre-edited"
+7 WRITE !,"values."
End DoDot:1
+8 WRITE !
+9 ;
+10 SET DIR(0)="Y"
SET DIR("B")="YES"
+11 SET DIR("A")="Do you want to see a list of those fields"
+12 DO ^DIR
WRITE !
+13 SET ANS=Y=1
+14 QUIT
