- DIEVK1 ;SFISC/MKO-KEY VALIDATION ;10:42 AM 30 Sep 1998
- ;;22.0;VA FileMan;;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- BUILD(DIVKFDA,DIVKFLAG) ;Loop thru FDA and load key info
- N DIVKEYOK,DIVKFIL,DIVKFLD,DIVKIENS,DIVKQUIT
- ;
- S DIVKEYOK=1,DIVKFIL=0
- F S DIVKFIL=$O(@DIVKFDA@(DIVKFIL)) Q:'DIVKFIL D Q:$G(DIVKQUIT)
- . Q:'$D(^DD("KEY","F",DIVKFIL))
- . D:$G(DIVKFLAG)["K" GETPKEY(DIVKFIL)
- . S DIVKIENS=""
- . F S DIVKIENS=$O(@DIVKFDA@(DIVKFIL,DIVKIENS)) Q:DIVKIENS="" D Q:$G(DIVKQUIT)
- .. I $G(DIVKFLAG)["K",$E(DIVKIENS)="?",$E(DIVKIENS,2)'="+",'$$KFLD(DIVKFIL,DIVKIENS,DIVKFDA) S DIVKEYOK=0 I $G(DIVKFLAG)["Q" S DIVKQUIT=1 Q
- .. S DIVKFLD=0
- .. F S DIVKFLD=$O(@DIVKFDA@(DIVKFIL,DIVKIENS,DIVKFLD)) Q:'DIVKFLD D BLDFLD(DIVKFIL,DIVKIENS,DIVKFLD)
- Q DIVKEYOK
- ;
- BLDFLD(DIVKFIL,DIVKIENS,DIVKFLD) ;Build key/index info on a given field
- ; ^TMP("DIKK",$J,"L",key) = rfile^ui^priority
- ; ... ,file,iens) = ""
- ; ... ,"UIR") = uir
- ; ... ,"SS",n) = file^field^maxlen
- N DIVKEY,DIVKPRI,DIVKRFIL,DIVKSS,DIVKUI,DIVKUIR
- ;
- S DIVKEY=0
- F S DIVKEY=$O(^DD("KEY","F",DIVKFIL,DIVKFLD,DIVKEY)) Q:'DIVKEY D
- . Q:$D(^TMP("DIKK",$J,"L",DIVKEY,DIVKFIL,DIVKIENS))#2 S ^(DIVKIENS)=""
- . Q:$D(^TMP("DIKK",$J,"L",DIVKEY))#2
- . ;
- . D LOADKEY^DIKK1(DIVKEY)
- . S DIVKRFIL=$P($G(^DD("KEY",DIVKEY,0)),U),DIVKUI=$P($G(^(0)),U,4),DIVKPRI=$P($G(^(0)),U,3)
- . S ^TMP("DIKK",$J,"L",DIVKEY)=DIVKRFIL_U_DIVKUI_U_DIVKPRI
- . Q:'DIVKRFIL!'DIVKUI
- . D XRINFO^DIKCU2(DIVKUI,.DIVKUIR,"","","","",.DIVKSS)
- . S ^TMP("DIKK",$J,"L",DIVKEY,"UIR")=DIVKUIR
- . M ^TMP("DIKK",$J,"L",DIVKEY,"SS")=DIVKSS
- Q
- ;
- GETPKEY(KFIL) ;Get fields in primary key for file KFIL
- ; ^TMP("DIKK",$J,"P",kfile) = key^ui#^uifile^uiname
- ; ... ,file,field) = seq#
- ;
- N FIL,FLD,I,KEY,SEQ,UI
- S KEY=$O(^DD("KEY","AP",KFIL,"P",0)) Q:'KEY
- S I=0 F S I=$O(^DD("KEY",KEY,2,I)) Q:'I D
- . Q:$D(^DD("KEY",KEY,2,I,0))[0 S FLD=$P(^(0),U),FIL=$P(^(0),U,2),SEQ=$P(^(0),U,3)
- . Q:'FLD!'FIL!'SEQ
- . S ^TMP("DIKK",$J,"P",KFIL,FIL,FLD)=SEQ
- I $D(^TMP("DIKK",$J,"P",KFIL)) D
- . S UI=$P(^DD("KEY",KEY,0),U,4)
- . S ^TMP("DIKK",$J,"P",KFIL)=KEY_U_UI_U_$P($G(^DD("IX",+UI,0)),U,1,2)
- Q
- ;
- KFLD(KFIL,IENS,FDA) ;Check that at least one primary key field is in FDA
- N FIL,FLD,KEY,OK,SEQ
- S KEY=+$G(^TMP("DIKK",$J,"P",KFIL)) Q:'KEY 1
- S OK=0
- S FIL=0 F S FIL=$O(^TMP("DIKK",$J,"P",KFIL,FIL)) Q:'FIL D Q:OK
- . S FLD=0 F S FLD=$O(^TMP("DIKK",$J,"P",KFIL,FIL,FLD)) Q:'FLD D Q:OK
- .. S:"@"'[$G(@FDA@(FIL,IENS,FLD)) OK=1
- D:'OK ERR746(KFIL,KEY,IENS)
- Q OK
- ;
- FINDCONV(DIVKIENS,DIVKFIEN) ;Replace ?n in DIVKIENS with actual ien's
- N I,N,P
- F I=1:1:$L(DIVKIENS,",")-1 D
- . S P=$P(DIVKIENS,",",I) Q:P'["?"
- . S N=$G(@DIVKFIEN@($TR(P,"?+"))) Q:'N
- . S $P(DIVKIENS,",",I)=+$G(@DIVKFIEN@($TR(P,"?+")))
- Q DIVKIENS
- ;
- ERR740(FILE,KEY,IENS) ;New values are invalid because they create a duplicate
- ;Key '|1|' for the |2| file.
- N P,PEXT
- S P(1)=$P(^DD("KEY",KEY,0),U,2)
- S P(2)=$O(^DD(FILE,0,"NM","")) S:P(2)?." " P(2)="#"_FILE
- S PEXT("FILE")=FILE,PEXT("KEY")=KEY,PEXT("IENS")=IENS
- D BLD^DIALOG(740,.P,.PEXT)
- Q
- ;
- ERR742(FILE,FIELD,KEY,IENS) ; The value of field |1| in the |2| file
- ;cannot be deleted because that field is part of the '|3|' key.
- N P,PEXT
- S P(1)=$$FLDNM^DIEFU(FILE,FIELD)
- S P(2)=$O(^DD(FILE,0,"NM","")) S:P(2)?." " P(2)="#"_FILE
- S P(3)=$P(^DD("KEY",KEY,0),U,2)
- S PEXT("FILE")=FILE,PEXT("FIELD")=FIELD,PEXT("IENS")=IENS
- D BLD^DIALOG(742,.P,.PEXT)
- Q
- ;
- ERR744(FILE,FIELD,KEY,IENS) ;Field |1| is part of Key '|2|', but the
- ;field has not been assigned a value.
- N P,PEXT
- S P(1)=$$FLDNM^DIEFU(FILE,FIELD)
- S P(2)=$P(^DD("KEY",KEY,0),U,2)
- S PEXT("FILE")=FILE,PEXT("FIELD")=FIELD,PEXT("IENS")=IENS
- D BLD^DIALOG(744,.P,.PEXT)
- Q
- ;
- ERR746(FILE,KEY,IENS) ;At least one field in Primary Key '|1|' must be
- ;provided in the FDA to look up '|IENS|' in the |2| file.
- N P,PEXT
- S P(1)=$P(^DD("KEY",KEY,0),U,2)
- S P(2)=$O(^DD(FILE,0,"NM","")) S:P(2)?." " P(2)="#"_FILE
- S P("IENS")=IENS
- S PEXT("FILE")=FILE,PEXT("KEY")=KEY,PEXT("IENS")=IENS
- D BLD^DIALOG(746,.P,.PEXT)
- Q
- DIEVK1 ;SFISC/MKO-KEY VALIDATION ;10:42 AM 30 Sep 1998
- +1 ;;22.0;VA FileMan;;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- BUILD(DIVKFDA,DIVKFLAG) ;Loop thru FDA and load key info
- +1 NEW DIVKEYOK,DIVKFIL,DIVKFLD,DIVKIENS,DIVKQUIT
- +2 ;
- +3 SET DIVKEYOK=1
- SET DIVKFIL=0
- +4 FOR
- SET DIVKFIL=$ORDER(@DIVKFDA@(DIVKFIL))
- IF 'DIVKFIL
- QUIT
- Begin DoDot:1
- +5 IF '$DATA(^DD("KEY","F",DIVKFIL))
- QUIT
- +6 IF $GET(DIVKFLAG)["K"
- DO GETPKEY(DIVKFIL)
- +7 SET DIVKIENS=""
- +8 FOR
- SET DIVKIENS=$ORDER(@DIVKFDA@(DIVKFIL,DIVKIENS))
- IF DIVKIENS=""
- QUIT
- Begin DoDot:2
- +9 IF $GET(DIVKFLAG)["K"
- IF $EXTRACT(DIVKIENS)="?"
- IF $EXTRACT(DIVKIENS,2)'="+"
- IF '$$KFLD(DIVKFIL,DIVKIENS,DIVKFDA)
- SET DIVKEYOK=0
- IF $GET(DIVKFLAG)["Q"
- SET DIVKQUIT=1
- QUIT
- +10 SET DIVKFLD=0
- +11 FOR
- SET DIVKFLD=$ORDER(@DIVKFDA@(DIVKFIL,DIVKIENS,DIVKFLD))
- IF 'DIVKFLD
- QUIT
- DO BLDFLD(DIVKFIL,DIVKIENS,DIVKFLD)
- End DoDot:2
- IF $GET(DIVKQUIT)
- QUIT
- End DoDot:1
- IF $GET(DIVKQUIT)
- QUIT
- +12 QUIT DIVKEYOK
- +13 ;
- BLDFLD(DIVKFIL,DIVKIENS,DIVKFLD) ;Build key/index info on a given field
- +1 ; ^TMP("DIKK",$J,"L",key) = rfile^ui^priority
- +2 ; ... ,file,iens) = ""
- +3 ; ... ,"UIR") = uir
- +4 ; ... ,"SS",n) = file^field^maxlen
- +5 NEW DIVKEY,DIVKPRI,DIVKRFIL,DIVKSS,DIVKUI,DIVKUIR
- +6 ;
- +7 SET DIVKEY=0
- +8 FOR
- SET DIVKEY=$ORDER(^DD("KEY","F",DIVKFIL,DIVKFLD,DIVKEY))
- IF 'DIVKEY
- QUIT
- Begin DoDot:1
- +9 IF $DATA(^TMP("DIKK",$JOB,"L",DIVKEY,DIVKFIL,DIVKIENS))#2
- QUIT
- SET ^(DIVKIENS)=""
- +10 IF $DATA(^TMP("DIKK",$JOB,"L",DIVKEY))#2
- QUIT
- +11 ;
- +12 DO LOADKEY^DIKK1(DIVKEY)
- +13 SET DIVKRFIL=$PIECE($GET(^DD("KEY",DIVKEY,0)),U)
- SET DIVKUI=$PIECE($GET(^(0)),U,4)
- SET DIVKPRI=$PIECE($GET(^(0)),U,3)
- +14 SET ^TMP("DIKK",$JOB,"L",DIVKEY)=DIVKRFIL_U_DIVKUI_U_DIVKPRI
- +15 IF 'DIVKRFIL!'DIVKUI
- QUIT
- +16 DO XRINFO^DIKCU2(DIVKUI,.DIVKUIR,"","","","",.DIVKSS)
- +17 SET ^TMP("DIKK",$JOB,"L",DIVKEY,"UIR")=DIVKUIR
- +18 MERGE ^TMP("DIKK",$JOB,"L",DIVKEY,"SS")=DIVKSS
- End DoDot:1
- +19 QUIT
- +20 ;
- GETPKEY(KFIL) ;Get fields in primary key for file KFIL
- +1 ; ^TMP("DIKK",$J,"P",kfile) = key^ui#^uifile^uiname
- +2 ; ... ,file,field) = seq#
- +3 ;
- +4 NEW FIL,FLD,I,KEY,SEQ,UI
- +5 SET KEY=$ORDER(^DD("KEY","AP",KFIL,"P",0))
- IF 'KEY
- QUIT
- +6 SET I=0
- FOR
- SET I=$ORDER(^DD("KEY",KEY,2,I))
- IF 'I
- QUIT
- Begin DoDot:1
- +7 IF $DATA(^DD("KEY",KEY,2,I,0))[0
- QUIT
- SET FLD=$PIECE(^(0),U)
- SET FIL=$PIECE(^(0),U,2)
- SET SEQ=$PIECE(^(0),U,3)
- +8 IF 'FLD!'FIL!'SEQ
- QUIT
- +9 SET ^TMP("DIKK",$JOB,"P",KFIL,FIL,FLD)=SEQ
- End DoDot:1
- +10 IF $DATA(^TMP("DIKK",$JOB,"P",KFIL))
- Begin DoDot:1
- +11 SET UI=$PIECE(^DD("KEY",KEY,0),U,4)
- +12 SET ^TMP("DIKK",$JOB,"P",KFIL)=KEY_U_UI_U_$PIECE($GET(^DD("IX",+UI,0)),U,1,2)
- End DoDot:1
- +13 QUIT
- +14 ;
- KFLD(KFIL,IENS,FDA) ;Check that at least one primary key field is in FDA
- +1 NEW FIL,FLD,KEY,OK,SEQ
- +2 SET KEY=+$GET(^TMP("DIKK",$JOB,"P",KFIL))
- IF 'KEY
- QUIT 1
- +3 SET OK=0
- +4 SET FIL=0
- FOR
- SET FIL=$ORDER(^TMP("DIKK",$JOB,"P",KFIL,FIL))
- IF 'FIL
- QUIT
- Begin DoDot:1
- +5 SET FLD=0
- FOR
- SET FLD=$ORDER(^TMP("DIKK",$JOB,"P",KFIL,FIL,FLD))
- IF 'FLD
- QUIT
- Begin DoDot:2
- +6 IF "@"'[$GET(@FDA@(FIL,IENS,FLD))
- SET OK=1
- End DoDot:2
- IF OK
- QUIT
- End DoDot:1
- IF OK
- QUIT
- +7 IF 'OK
- DO ERR746(KFIL,KEY,IENS)
- +8 QUIT OK
- +9 ;
- FINDCONV(DIVKIENS,DIVKFIEN) ;Replace ?n in DIVKIENS with actual ien's
- +1 NEW I,N,P
- +2 FOR I=1:1:$LENGTH(DIVKIENS,",")-1
- Begin DoDot:1
- +3 SET P=$PIECE(DIVKIENS,",",I)
- IF P'["?"
- QUIT
- +4 SET N=$GET(@DIVKFIEN@($TRANSLATE(P,"?+")))
- IF 'N
- QUIT
- +5 SET $PIECE(DIVKIENS,",",I)=+$GET(@DIVKFIEN@($TRANSLATE(P,"?+")))
- End DoDot:1
- +6 QUIT DIVKIENS
- +7 ;
- ERR740(FILE,KEY,IENS) ;New values are invalid because they create a duplicate
- +1 ;Key '|1|' for the |2| file.
- +2 NEW P,PEXT
- +3 SET P(1)=$PIECE(^DD("KEY",KEY,0),U,2)
- +4 SET P(2)=$ORDER(^DD(FILE,0,"NM",""))
- IF P(2)?." "
- SET P(2)="#"_FILE
- +5 SET PEXT("FILE")=FILE
- SET PEXT("KEY")=KEY
- SET PEXT("IENS")=IENS
- +6 DO BLD^DIALOG(740,.P,.PEXT)
- +7 QUIT
- +8 ;
- ERR742(FILE,FIELD,KEY,IENS) ; The value of field |1| in the |2| file
- +1 ;cannot be deleted because that field is part of the '|3|' key.
- +2 NEW P,PEXT
- +3 SET P(1)=$$FLDNM^DIEFU(FILE,FIELD)
- +4 SET P(2)=$ORDER(^DD(FILE,0,"NM",""))
- IF P(2)?." "
- SET P(2)="#"_FILE
- +5 SET P(3)=$PIECE(^DD("KEY",KEY,0),U,2)
- +6 SET PEXT("FILE")=FILE
- SET PEXT("FIELD")=FIELD
- SET PEXT("IENS")=IENS
- +7 DO BLD^DIALOG(742,.P,.PEXT)
- +8 QUIT
- +9 ;
- ERR744(FILE,FIELD,KEY,IENS) ;Field |1| is part of Key '|2|', but the
- +1 ;field has not been assigned a value.
- +2 NEW P,PEXT
- +3 SET P(1)=$$FLDNM^DIEFU(FILE,FIELD)
- +4 SET P(2)=$PIECE(^DD("KEY",KEY,0),U,2)
- +5 SET PEXT("FILE")=FILE
- SET PEXT("FIELD")=FIELD
- SET PEXT("IENS")=IENS
- +6 DO BLD^DIALOG(744,.P,.PEXT)
- +7 QUIT
- +8 ;
- ERR746(FILE,KEY,IENS) ;At least one field in Primary Key '|1|' must be
- +1 ;provided in the FDA to look up '|IENS|' in the |2| file.
- +2 NEW P,PEXT
- +3 SET P(1)=$PIECE(^DD("KEY",KEY,0),U,2)
- +4 SET P(2)=$ORDER(^DD(FILE,0,"NM",""))
- IF P(2)?." "
- SET P(2)="#"_FILE
- +5 SET P("IENS")=IENS
- +6 SET PEXT("FILE")=FILE
- SET PEXT("KEY")=KEY
- SET PEXT("IENS")=IENS
- +7 DO BLD^DIALOG(746,.P,.PEXT)
- +8 QUIT
