- DIEKMSG ;SFISC/MKO-PRINT MESSAGE ABOUT BAD KEYS ;12:47 PM 18 Feb 1998
- ;;22.0;VA FileMan;;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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
- DIEKMSG ;SFISC/MKO-PRINT MESSAGE ABOUT BAD KEYS ;12:47 PM 18 Feb 1998
- +1 ;;22.0;VA FileMan;;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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
