- DIKCUTL2 ;SFISC/MKO-UTILITY OPTION TO MODIFY INDEX ;17DEC2010
- ;;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.
- ;
- ;========
- ; $$TYPE
- ;========
- ;Prompt for type xref (to reindex or modify)
- ;Returns:
- ; '1' for Traditional; or
- ; '2' for New
- ;
- TYPE() ;
- N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
- S DIR(0)="SAM^1:TRADITIONAL;2:NEW"
- S DIR("A")="What type of cross-reference (Traditional or New)? "
- S DIR("B")="Traditional"
- S DIR("?",1)="Enter 'T' to select a Traditional cross-reference."
- S DIR("?",2)=" Traditional cross references are stored in the data"
- S DIR("?",3)=" dictionary under ^DD(file#,field#,1)."
- S DIR("?",4)=" "
- S DIR("?",5)="Enter 'N' to select a New-Style cross-reference."
- S DIR("?",6)=" New-Style cross references are stored in the Index file."
- S DIR("?",7)=" Compound indexes (indexes based on more than one field)"
- S DIR("?")=" are examples of New-Style cross-references."
- D ^DIR
- Q $S($D(DIRUT):"",1:Y)
- ;
- ;==========================
- ; GETXR(file#,.count,flag)
- ;==========================
- ;Loop through the "AC" index to get the list of Index file
- ;xrefs with root file FIL.
- ;In:
- ; FIL = Root file #
- ; FLG [ "M" : also get xrefs on subfiles of FIL
- ;Out:
- ; CNT = # xrefs^rootFile# (or null if FLG [ "M")
- ; CNT(xref#) = rootFile#^File#^xrefName^rootType^UI[if uniq index]
- ;
- GETXR(FIL,CNT,FLG) ;
- N F,SB,XR
- K CNT
- D:$G(FLG)["M" SUBFILES^DIKCU(FIL,.SB)
- S SB(FIL)=""
- ;
- S (CNT,F)=0 F S F=$O(SB(F)) Q:'F D
- . S XR=0 F S XR=$O(^DD("IX","AC",F,XR)) Q:'XR D
- .. I $G(^DD("IX",XR,0))?."^" K ^DD("IX","AC",F,XR) Q
- ..I $G(FLG)["x",$G(^("NOREINDEX")) Q ;167
- .. S CNT=CNT+1
- .. S CNT(XR)=F_U_$P($G(^DD("IX",XR,0)),U,1,2)_U_$P(^(0),U,8)
- .. S:$D(^DD("KEY","AU",XR)) $P(CNT(XR),U,5)="UI"
- ;
- S:$G(FLG)'["M" $P(CNT,U,2)=FIL
- Q
- ;
- ;============================
- ; LIST(.count,header,screen)
- ;============================
- ;List the xrefs in the CNT array
- ;In:
- ; CNT = Array of xrefs to print (obtained by GETXR call above)
- ; HDR = Text to print before listing
- ; (default is 'Current Indexes[ on [sub]file #xxx]:')
- ; SCR = Sets $T to screen out indexes (Y = index#)
- ;
- LIST(CNT,HDR,SCR) ;
- I '$G(CNT) W:$P(CNT,U,2) !,"There are no INDEX file cross-references defined on "_$$FSTR($P(CNT,U,2))_"." Q
- N FIL,I,ONEFIL,RFIL,TYP,TXT,UI,XR,Y
- ;
- S ONEFIL=$P(CNT,U,2)
- S:$G(HDR)="" HDR="Current Indexes"_$S(ONEFIL:" on "_$$FSTR(ONEFIL),1:"")_":"
- W !,HDR
- ;
- S XR=0 F S XR=$O(CNT(XR)) Q:'XR D
- . I $G(SCR)]"" K Y S Y=XR,Y(0)=CNT(XR) X SCR K Y E Q
- . S FIL=$P(CNT(XR),U,2),RFIL=$P(CNT(XR),U),TYP=$P(CNT(XR),U,4)
- . S UI=$S($P(CNT(XR),U,5)="UI":"uniqueness ",1:"")
- . S RFIL=$S('ONEFIL:" on "_$$FSTR(RFIL),1:"")
- . ;
- . S TXT=XR_" "_$J("",5-$L(XR))_"'"_$P(CNT(XR),U,3)_"' "_UI
- . I TYP'="W" S TXT=TXT_"index"_RFIL
- . E S TXT=TXT_"whole file index"_RFIL_" (resides on "_$$FSTR(FIL)_")"
- . ;
- . D WRAP^DIKCU2(.TXT,-11,-2)
- . W !," "_TXT F I=1:1 Q:$D(TXT(I))[0 W !?10,TXT(I)
- . K TXT
- Q
- ;
- ;================================
- ; $$CHOOSE(.count,prompt,screen)
- ;================================
- ;Prompt for a xref from the DIKCCNT array
- ;In:
- ; DIKCCNT = Array contain xref data (obtained by GETXR call above)
- ; DIKCPR = Action to include with the prompt
- ; DIKCSCR = Sets $T to screen out entries (Y=index#)
- ;Returns:
- ; Index ien (or 0, if none selected)
- ;
- CHOOSE(DIKCCNT,DIKCPR,DIKCSCR) ;
- Q:'$G(DIKCCNT) 0
- N I,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
- ;
- S DIR(0)="SAO^"
- S I=0 F S I=$O(DIKCCNT(I)) Q:'I S DIR("C",I)=I_":"_$P(DIKCCNT(I),U,3)
- S DIR("A")="Which Index do you wish to "_DIKCPR_"? "
- S:+DIKCCNT=1 DIR("B")=$O(DIKCCNT(0))
- S DIR("?")="",DIR("??")="^D LIST^DIKCUTL2(.DIKCCNT)"
- W ! D ^DIR I 'Y!$D(DIRUT) Q 0
- Q Y
- ;
- ;====================
- ; $$FSTR(file#,flag)
- ;====================
- ;Return string 'file #xxx' or 'subfile #xxx'
- ;In:
- ; FIL = File #
- ; FLG [ U : Capitalize 'File' or 'Subfile'
- ;
- FSTR(FIL,FLG) ;
- ;Q $P($P("f;F^subf;Subf",U,$G(^DD(FIL,0,"UP"))>0+1),";",$G(FLG)["U"+1)_"ile #"_FIL
- Q $P($$EZBLD^DIALOG(8098),U,$G(^DD(FIL,0,"UP"))>0*2+1+($G(FLG)["U"))_" #"_FIL
- ;
- ;================
- ; PRTMSG(index#)
- ;================
- ;Print message that DIXR can't be deleted because it's the
- ;Uniqueness Index for a key.
- ;In:
- ; DIXR = index #
- ;
- PRTMSG(DIXR) ;
- N KEYID,I,INDID,MSG
- ;
- S KEYID=$O(^DD("KEY","AU",DIXR,0)) Q:'KEYID
- S KEYID=$G(^DD("KEY",KEYID,0)) Q:KEYID?."^"
- S KEYID="Key '"_$P(KEYID,U,2)_"' on File #"_$P(KEYID,U)
- ;
- S INDID="Index '"_$P($G(^DD("IX",DIXR,0)),U,2)_"'"
- S MSG(0)=INDID_" cannot be deleted. It is the uniqueness index for "_KEYID_"."
- D WRAP^DIKCU2(.MSG)
- ;
- W $C(7) F I=0:1 Q:'$D(MSG(I)) W !,MSG(I)
- Q
- ;
- ;================
- ; BLDLOG(index#)
- ;================
- ;Build and file the logic of the cross reference.
- ;In:
- ; DIXR = index #
- ;
- ;Called from EDIT^DIKCUTL after an Index is edited.
- ;The reason for this call is if the user deletes some Cross-Reference
- ;Values, and then Quits the form, the Set/Kill logic may not reflect
- ;the deleted Values.
- ;
- BLDLOG(DIXR) ;
- N CNT,CRV,CRV0,DIERR,FCNT,FDA,FILE,IX0,KILL,L,LDIF,MAXL,MSG
- N NAME,ORD,ROOT,RTYPE,RFILE,SBSC,SET,VAL,WKILL
- ;
- ;Get index data
- S IX0=$G(^DD("IX",DIXR,0)) Q:IX0?."^"
- I $P(IX0,U,4)="MU" D UPDEXEC(DIXR) Q
- S FILE=$P(IX0,U),NAME=$P(IX0,U,2),RTYPE=$P(IX0,U,8),RFILE=$P(IX0,U,9)
- ;
- ;Build root of index and the 'Kill Entire Index Code'
- I FILE'=RFILE Q:RTYPE'="W" S LDIF=$$FLEVDIFF^DIKCU(FILE,RFILE)
- E S LDIF=0
- S ROOT=$$FROOTDA^DIKCU(FILE,LDIF_"O")_""""_NAME_""""
- S WKILL="K "_ROOT_")"
- ;
- ;Loop through Cross-Reference Values multiple
- ;Build SBSC(subscript#)=order#^maxLength array
- S CRV=0 F S CRV=$O(^DD("IX",DIXR,11.1,CRV)) Q:'CRV D
- . S CRV0=$G(^DD("IX",DIXR,11.1,CRV,0)) Q:CRV0?."^"
- . S ORD=$P(CRV0,U) Q:'ORD
- . S:$P(CRV0,U,2)="F" FCNT=$G(FCNT)+1
- . S CNT=$G(CNT)+1
- . S SBSC=$P(CRV0,U,6) Q:'SBSC
- . S MAXL=$P(CRV0,U,5)
- . S SBSC(SBSC)=ORD_U_MAXL
- ;
- ;Loop through SBSC array and build the root w/ X(n) array
- S SBSC=0 F S SBSC=$O(SBSC(SBSC)) Q:'SBSC D
- . S ORD=$P(SBSC(SBSC),U),MAXL=$P(SBSC(SBSC),U,2)
- . I $G(CNT)=1 S VAL=$S(MAXL:"$E(X,1,"_MAXL_")",1:"X")
- . E S VAL=$S(MAXL:"$E(X("_ORD_"),1,"_MAXL_")",1:"X("_ORD_")")
- . S ROOT=ROOT_","_VAL
- ;
- ;Append DA(n) to root
- F L=LDIF:-1:1 S ROOT=ROOT_",DA("_L_")"
- S ROOT=ROOT_",DA)"
- ;
- ;Build and file the Set and Kill Logic and the Execution
- I '$O(SBSC(0)) S (SET,KILL)="Q",WKILL=""
- E S SET="S "_ROOT_"=""""",KILL="K "_ROOT
- K FDA
- S FDA(.11,DIXR_",",1.1)=SET
- S FDA(.11,DIXR_",",2.1)=KILL
- S FDA(.11,DIXR_",",2.5)=WKILL
- S FDA(.11,DIXR_",",.4)=$S($G(FCNT)>1:"R",1:"F")
- D FILE^DIE("","FDA","MSG")
- Q
- ;
- UPDEXEC(DIXR) ;Update Execution based on number of field-type xref values
- N CRV,CRV0,DIERR,FCNT,FDA,MSG
- S CRV(1)=DIXR,CRV=0
- F S CRV=$O(^DD("IX",DIXR,11.1,CRV)) Q:'CRV D
- . S CRV0=$G(^DD("IX",DIXR,11.1,CRV,0)) Q:'CRV0
- . S:$P(CRV0,U,2)="F" FCNT=$G(FCNT)+1
- S FDA(.11,DIXR_",",.4)=$S($G(FCNT)>1:"R",1:"F")
- D FILE^DIE("","FDA","MSG")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIKCUTL2 7361 printed Jan 18, 2025@03:49:53 Page 2
- DIKCUTL2 ;SFISC/MKO-UTILITY OPTION TO MODIFY INDEX ;17DEC2010
- +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 ;
- +7 ;========
- +8 ; $$TYPE
- +9 ;========
- +10 ;Prompt for type xref (to reindex or modify)
- +11 ;Returns:
- +12 ; '1' for Traditional; or
- +13 ; '2' for New
- +14 ;
- TYPE() ;
- +1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
- +2 SET DIR(0)="SAM^1:TRADITIONAL;2:NEW"
- +3 SET DIR("A")="What type of cross-reference (Traditional or New)? "
- +4 SET DIR("B")="Traditional"
- +5 SET DIR("?",1)="Enter 'T' to select a Traditional cross-reference."
- +6 SET DIR("?",2)=" Traditional cross references are stored in the data"
- +7 SET DIR("?",3)=" dictionary under ^DD(file#,field#,1)."
- +8 SET DIR("?",4)=" "
- +9 SET DIR("?",5)="Enter 'N' to select a New-Style cross-reference."
- +10 SET DIR("?",6)=" New-Style cross references are stored in the Index file."
- +11 SET DIR("?",7)=" Compound indexes (indexes based on more than one field)"
- +12 SET DIR("?")=" are examples of New-Style cross-references."
- +13 DO ^DIR
- +14 QUIT $SELECT($DATA(DIRUT):"",1:Y)
- +15 ;
- +16 ;==========================
- +17 ; GETXR(file#,.count,flag)
- +18 ;==========================
- +19 ;Loop through the "AC" index to get the list of Index file
- +20 ;xrefs with root file FIL.
- +21 ;In:
- +22 ; FIL = Root file #
- +23 ; FLG [ "M" : also get xrefs on subfiles of FIL
- +24 ;Out:
- +25 ; CNT = # xrefs^rootFile# (or null if FLG [ "M")
- +26 ; CNT(xref#) = rootFile#^File#^xrefName^rootType^UI[if uniq index]
- +27 ;
- GETXR(FIL,CNT,FLG) ;
- +1 NEW F,SB,XR
- +2 KILL CNT
- +3 if $GET(FLG)["M"
- DO SUBFILES^DIKCU(FIL,.SB)
- +4 SET SB(FIL)=""
- +5 ;
- +6 SET (CNT,F)=0
- FOR
- SET F=$ORDER(SB(F))
- if 'F
- QUIT
- Begin DoDot:1
- +7 SET XR=0
- FOR
- SET XR=$ORDER(^DD("IX","AC",F,XR))
- if 'XR
- QUIT
- Begin DoDot:2
- +8 IF $GET(^DD("IX",XR,0))?."^"
- KILL ^DD("IX","AC",F,XR)
- QUIT
- +9 ;167
- IF $GET(FLG)["x"
- IF $GET(^("NOREINDEX"))
- QUIT
- +10 SET CNT=CNT+1
- +11 SET CNT(XR)=F_U_$PIECE($GET(^DD("IX",XR,0)),U,1,2)_U_$PIECE(^(0),U,8)
- +12 if $DATA(^DD("KEY","AU",XR))
- SET $PIECE(CNT(XR),U,5)="UI"
- End DoDot:2
- End DoDot:1
- +13 ;
- +14 if $GET(FLG)'["M"
- SET $PIECE(CNT,U,2)=FIL
- +15 QUIT
- +16 ;
- +17 ;============================
- +18 ; LIST(.count,header,screen)
- +19 ;============================
- +20 ;List the xrefs in the CNT array
- +21 ;In:
- +22 ; CNT = Array of xrefs to print (obtained by GETXR call above)
- +23 ; HDR = Text to print before listing
- +24 ; (default is 'Current Indexes[ on [sub]file #xxx]:')
- +25 ; SCR = Sets $T to screen out indexes (Y = index#)
- +26 ;
- LIST(CNT,HDR,SCR) ;
- +1 IF '$GET(CNT)
- if $PIECE(CNT,U,2)
- WRITE !,"There are no INDEX file cross-references defined on "_$$FSTR($PIECE(CNT,U,2))_"."
- QUIT
- +2 NEW FIL,I,ONEFIL,RFIL,TYP,TXT,UI,XR,Y
- +3 ;
- +4 SET ONEFIL=$PIECE(CNT,U,2)
- +5 if $GET(HDR)=""
- SET HDR="Current Indexes"_$SELECT(ONEFIL:" on "_$$FSTR(ONEFIL),1:"")_":"
- +6 WRITE !,HDR
- +7 ;
- +8 SET XR=0
- FOR
- SET XR=$ORDER(CNT(XR))
- if 'XR
- QUIT
- Begin DoDot:1
- +9 IF $GET(SCR)]""
- KILL Y
- SET Y=XR
- SET Y(0)=CNT(XR)
- XECUTE SCR
- KILL Y
- IF '$TEST
- QUIT
- +10 SET FIL=$PIECE(CNT(XR),U,2)
- SET RFIL=$PIECE(CNT(XR),U)
- SET TYP=$PIECE(CNT(XR),U,4)
- +11 SET UI=$SELECT($PIECE(CNT(XR),U,5)="UI":"uniqueness ",1:"")
- +12 SET RFIL=$SELECT('ONEFIL:" on "_$$FSTR(RFIL),1:"")
- +13 ;
- +14 SET TXT=XR_" "_$JUSTIFY("",5-$LENGTH(XR))_"'"_$PIECE(CNT(XR),U,3)_"' "_UI
- +15 IF TYP'="W"
- SET TXT=TXT_"index"_RFIL
- +16 IF '$TEST
- SET TXT=TXT_"whole file index"_RFIL_" (resides on "_$$FSTR(FIL)_")"
- +17 ;
- +18 DO WRAP^DIKCU2(.TXT,-11,-2)
- +19 WRITE !," "_TXT
- FOR I=1:1
- if $DATA(TXT(I))[0
- QUIT
- WRITE !?10,TXT(I)
- +20 KILL TXT
- End DoDot:1
- +21 QUIT
- +22 ;
- +23 ;================================
- +24 ; $$CHOOSE(.count,prompt,screen)
- +25 ;================================
- +26 ;Prompt for a xref from the DIKCCNT array
- +27 ;In:
- +28 ; DIKCCNT = Array contain xref data (obtained by GETXR call above)
- +29 ; DIKCPR = Action to include with the prompt
- +30 ; DIKCSCR = Sets $T to screen out entries (Y=index#)
- +31 ;Returns:
- +32 ; Index ien (or 0, if none selected)
- +33 ;
- CHOOSE(DIKCCNT,DIKCPR,DIKCSCR) ;
- +1 if '$GET(DIKCCNT)
- QUIT 0
- +2 NEW I,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
- +3 ;
- +4 SET DIR(0)="SAO^"
- +5 SET I=0
- FOR
- SET I=$ORDER(DIKCCNT(I))
- if 'I
- QUIT
- SET DIR("C",I)=I_":"_$PIECE(DIKCCNT(I),U,3)
- +6 SET DIR("A")="Which Index do you wish to "_DIKCPR_"? "
- +7 if +DIKCCNT=1
- SET DIR("B")=$ORDER(DIKCCNT(0))
- +8 SET DIR("?")=""
- SET DIR("??")="^D LIST^DIKCUTL2(.DIKCCNT)"
- +9 WRITE !
- DO ^DIR
- IF 'Y!$DATA(DIRUT)
- QUIT 0
- +10 QUIT Y
- +11 ;
- +12 ;====================
- +13 ; $$FSTR(file#,flag)
- +14 ;====================
- +15 ;Return string 'file #xxx' or 'subfile #xxx'
- +16 ;In:
- +17 ; FIL = File #
- +18 ; FLG [ U : Capitalize 'File' or 'Subfile'
- +19 ;
- FSTR(FIL,FLG) ;
- +1 ;Q $P($P("f;F^subf;Subf",U,$G(^DD(FIL,0,"UP"))>0+1),";",$G(FLG)["U"+1)_"ile #"_FIL
- +2 QUIT $PIECE($$EZBLD^DIALOG(8098),U,$GET(^DD(FIL,0,"UP"))>0*2+1+($GET(FLG)["U"))_" #"_FIL
- +3 ;
- +4 ;================
- +5 ; PRTMSG(index#)
- +6 ;================
- +7 ;Print message that DIXR can't be deleted because it's the
- +8 ;Uniqueness Index for a key.
- +9 ;In:
- +10 ; DIXR = index #
- +11 ;
- PRTMSG(DIXR) ;
- +1 NEW KEYID,I,INDID,MSG
- +2 ;
- +3 SET KEYID=$ORDER(^DD("KEY","AU",DIXR,0))
- if 'KEYID
- QUIT
- +4 SET KEYID=$GET(^DD("KEY",KEYID,0))
- if KEYID?."^"
- QUIT
- +5 SET KEYID="Key '"_$PIECE(KEYID,U,2)_"' on File #"_$PIECE(KEYID,U)
- +6 ;
- +7 SET INDID="Index '"_$PIECE($GET(^DD("IX",DIXR,0)),U,2)_"'"
- +8 SET MSG(0)=INDID_" cannot be deleted. It is the uniqueness index for "_KEYID_"."
- +9 DO WRAP^DIKCU2(.MSG)
- +10 ;
- +11 WRITE $CHAR(7)
- FOR I=0:1
- if '$DATA(MSG(I))
- QUIT
- WRITE !,MSG(I)
- +12 QUIT
- +13 ;
- +14 ;================
- +15 ; BLDLOG(index#)
- +16 ;================
- +17 ;Build and file the logic of the cross reference.
- +18 ;In:
- +19 ; DIXR = index #
- +20 ;
- +21 ;Called from EDIT^DIKCUTL after an Index is edited.
- +22 ;The reason for this call is if the user deletes some Cross-Reference
- +23 ;Values, and then Quits the form, the Set/Kill logic may not reflect
- +24 ;the deleted Values.
- +25 ;
- BLDLOG(DIXR) ;
- +1 NEW CNT,CRV,CRV0,DIERR,FCNT,FDA,FILE,IX0,KILL,L,LDIF,MAXL,MSG
- +2 NEW NAME,ORD,ROOT,RTYPE,RFILE,SBSC,SET,VAL,WKILL
- +3 ;
- +4 ;Get index data
- +5 SET IX0=$GET(^DD("IX",DIXR,0))
- if IX0?."^"
- QUIT
- +6 IF $PIECE(IX0,U,4)="MU"
- DO UPDEXEC(DIXR)
- QUIT
- +7 SET FILE=$PIECE(IX0,U)
- SET NAME=$PIECE(IX0,U,2)
- SET RTYPE=$PIECE(IX0,U,8)
- SET RFILE=$PIECE(IX0,U,9)
- +8 ;
- +9 ;Build root of index and the 'Kill Entire Index Code'
- +10 IF FILE'=RFILE
- if RTYPE'="W"
- QUIT
- SET LDIF=$$FLEVDIFF^DIKCU(FILE,RFILE)
- +11 IF '$TEST
- SET LDIF=0
- +12 SET ROOT=$$FROOTDA^DIKCU(FILE,LDIF_"O")_""""_NAME_""""
- +13 SET WKILL="K "_ROOT_")"
- +14 ;
- +15 ;Loop through Cross-Reference Values multiple
- +16 ;Build SBSC(subscript#)=order#^maxLength array
- +17 SET CRV=0
- FOR
- SET CRV=$ORDER(^DD("IX",DIXR,11.1,CRV))
- if 'CRV
- QUIT
- Begin DoDot:1
- +18 SET CRV0=$GET(^DD("IX",DIXR,11.1,CRV,0))
- if CRV0?."^"
- QUIT
- +19 SET ORD=$PIECE(CRV0,U)
- if 'ORD
- QUIT
- +20 if $PIECE(CRV0,U,2)="F"
- SET FCNT=$GET(FCNT)+1
- +21 SET CNT=$GET(CNT)+1
- +22 SET SBSC=$PIECE(CRV0,U,6)
- if 'SBSC
- QUIT
- +23 SET MAXL=$PIECE(CRV0,U,5)
- +24 SET SBSC(SBSC)=ORD_U_MAXL
- End DoDot:1
- +25 ;
- +26 ;Loop through SBSC array and build the root w/ X(n) array
- +27 SET SBSC=0
- FOR
- SET SBSC=$ORDER(SBSC(SBSC))
- if 'SBSC
- QUIT
- Begin DoDot:1
- +28 SET ORD=$PIECE(SBSC(SBSC),U)
- SET MAXL=$PIECE(SBSC(SBSC),U,2)
- +29 IF $GET(CNT)=1
- SET VAL=$SELECT(MAXL:"$E(X,1,"_MAXL_")",1:"X")
- +30 IF '$TEST
- SET VAL=$SELECT(MAXL:"$E(X("_ORD_"),1,"_MAXL_")",1:"X("_ORD_")")
- +31 SET ROOT=ROOT_","_VAL
- End DoDot:1
- +32 ;
- +33 ;Append DA(n) to root
- +34 FOR L=LDIF:-1:1
- SET ROOT=ROOT_",DA("_L_")"
- +35 SET ROOT=ROOT_",DA)"
- +36 ;
- +37 ;Build and file the Set and Kill Logic and the Execution
- +38 IF '$ORDER(SBSC(0))
- SET (SET,KILL)="Q"
- SET WKILL=""
- +39 IF '$TEST
- SET SET="S "_ROOT_"="""""
- SET KILL="K "_ROOT
- +40 KILL FDA
- +41 SET FDA(.11,DIXR_",",1.1)=SET
- +42 SET FDA(.11,DIXR_",",2.1)=KILL
- +43 SET FDA(.11,DIXR_",",2.5)=WKILL
- +44 SET FDA(.11,DIXR_",",.4)=$SELECT($GET(FCNT)>1:"R",1:"F")
- +45 DO FILE^DIE("","FDA","MSG")
- +46 QUIT
- +47 ;
- UPDEXEC(DIXR) ;Update Execution based on number of field-type xref values
- +1 NEW CRV,CRV0,DIERR,FCNT,FDA,MSG
- +2 SET CRV(1)=DIXR
- SET CRV=0
- +3 FOR
- SET CRV=$ORDER(^DD("IX",DIXR,11.1,CRV))
- if 'CRV
- QUIT
- Begin DoDot:1
- +4 SET CRV0=$GET(^DD("IX",DIXR,11.1,CRV,0))
- if 'CRV0
- QUIT
- +5 if $PIECE(CRV0,U,2)="F"
- SET FCNT=$GET(FCNT)+1
- End DoDot:1
- +6 SET FDA(.11,DIXR_",",.4)=$SELECT($GET(FCNT)>1:"R",1:"F")
- +7 DO FILE^DIE("","FDA","MSG")
- +8 QUIT