DIEZ2 ;SFISC/GFT-COMPILE INPUT TEMPLATE ;15JUN2006
;;22.2;VA FileMan;**19**;Jan 05, 2016;Build 2
;;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.
;
K DIEZAR D RECXR^DIEZ4(.DIEZAR)
K ^DIE(DIEZ,"AR") M:$D(DIEZAR) ^DIE(DIEZ,"AR")=DIEZAR
S %X="^UTILITY($J,""AF"",",%Y="^DIE(""AF""," D %XY^%RCR
K ^DIE(DIEZ,"AB") S %X="^UTILITY($J,""AB"",",%Y="^DIE(DIEZ,""AB""," D %XY^%RCR
S ^DIE(DIEZ,"ROUOLD")=DNM,^("ROU")=U_DNM
K K ^DIBT(.402,1,DIEZ),^UTILITY($J)
K @DIEZTMP,DIEZTMP,DIEZAR,DIER,DIERN
K DIE,DINC,DK,DL,DMAX,DNR,DP,DQ,DQFF,DRD,DS,DSN,DV,DW,DI,DH,%,%X,%Y,%H,X,Y
K DIEZ,DIEZDUP,DIEZR,Q,DPP,DPR,DM,DR,DU,T,F,DRN,DOV,DIEZL,DIEZP,DIEZAB
Q
;
XREF ;
N DIEZR,DIEZX,DIEZLN
S X="C"_DQ_" G C"_DQ_"S:$D(DE("_DQ_"))[0 K DB" D L
S DIEZX=L,DIEZLN=0 ;remember cross-refs will start after 'L'
F %=0:0 S %=$O(^DD(DP,DI,1,%)) Q:%'>0 S DW=^(%,2),X=" S X=DE("_DQ_"),DIC=DIE" D SK ;first build the KILL XREFS
I DV["a" S X=" S X=DE("_DQ_"),DIIX=2_U_DIFLD D AUDIT^DIET" D X
;I X]"" S X="C"_DQ_" ;" D L
D OVERFLO
S X="C"_DQ_"S S X="""" G:DG(DQ)=X C"_DQ_"F1 K DB" D L S X=""
S DIEZX=L,DIEZLN=L
F %=0:0 S %=$O(^DD(DP,DI,1,%)) Q:%'>0 S DW=^(%,1),X=X_" S X=DG(DQ),DIC=DIE" D SK ;then the SET XREFS
I DV["a" S X=X_" I $D(DE("_DQ_"))'[0!($G(^DD(DP,DIFLD,""AUDIT""))[""y"") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET" D X
D OVERFLO
;Build index code and code to check key
D INDEX
S X=X_" Q" D L
I $D(DIEZKEY) D GETKEY^DIEZ3(DP,DI,.DIEZKEY,DQ) K DIEZKEY
Q
;
SK D X I "Q"[DW S X=" ;" G X
I DW["Q",^DD(DP,DI,1,%,0)["MUMPS" S Q=DW,F=0 D QFF S X=" X "_Q G X
S X=" "_DW
X D L S DIEZLN=DIEZLN+$L(X),X="" Q
;
OVERFLO I DIEZLN+T+100<DMAX!'DIEZLN Q
K ^UTILITY($J,"DIEZXR") M ^UTILITY($J,"DIEZXR")=^UTILITY($J,0)
S DIEZR=DRN,(DIEZR(1),DRN)=$O(DRN(""),-1)+1 D
.N T,DQ,L
.D NEWROU^DIEZ ;make a new routine holding just the X-REFS
.F T=2:1 S DIEZX=DIEZX+1 Q:'$D(^UTILITY($J,"DIEZXR",DIEZX)) S ^UTILITY($J,0,T)=^(DIEZX) K ^UTILITY($J,"DIEZXR",DIEZX)
.F K ^UTILITY($J,0,T) S T=$O(^(T)) Q:'T
.D SAVE^DIEZ1
K ^UTILITY($J,0) M ^UTILITY($J,0)=^UTILITY($J,"DIEZXR")
S DRN=DIEZR,T=T-DIEZLN,X=" D ^"_DNM_DIEZR(1) D L
Q
;
MUL ;
S DNR=%,DW=$P(DW,";",1),X=$P(^DD(+DV,0),U,4)_U_DV_U_DW_U,%=^(.01,0),DV=+DV_$P(%,U,2)
G 1:DV'["W" I DPR]"" S F=0,Q=DPR D QFF S X=" S DE(1,0)="_Q D L
WPEGP S X=" S Y=""^"_$P(%,U,2,9)_""" S $P(Y,U)="_$S(DIEZP]"":""""_DIEZP_"""",1:"$$LABEL^DIALOGZ(DP,"_DI_")")_" S DG="""_DW_""",DC=""^"_+DV_""" D DIEN^DIWE K DE(1) G A" D L S X=" ;" D L,AF ;**CC0/NI WORD-PROCESSING FIELD LABEL
S ^UTILITY($J,"AF",+DV,.01,DIEZ)="" D AB G NX^DIEZ0
;
1 ;**CCO/NI COMPILE 'SELECT FIELD:' SO IT WORKS FOR ANY LANGUAGE
S X=" S DIFLD="_DI_",DGO=""^"_DNM_DNR_""",DC="""_X_""",DV="""_DV_""",DW=""0;1"",DOW="_$S(DIEZP]"":""""_DIEZP_"""",1:"$$LABEL^DIALOGZ(DP,DIFLD)")_",DLB=$P($$EZBLD^DIALOG(8042,DOW),"": "") S:D DC=DC_D",DPP=DV["M",DU=$P(^(0),U,3) D L,DU:DU]""
S X=$P(" G RE:D",U,DPP)_" I $D(DSC("_+DV_"))#2,$P(DSC("_+DV_"),""I $D(^UTILITY("",1)="""" X DSC("_+DV_") S D=$O(^(0)) S:D="""" D=-1 G M"_DQ D L
S:+DW'=DW DW=""""_DW_"""" S X=" S D=$S($D("_DIE_"DA,"_DW_",0)):$P(^(0),U,3,4),$O(^(0))'="""":$O(^(0)),1:-1)" D L
S X="M"_DQ_" I D>0 S DC=DC_D I $D("_DIE_"DA,"_DW_",+D,0)) S DE("_DQ_")=$P(^(0),U,1)" D L
D PR^DIEZ0 S X="R"_DQ_" D DE" D L
S X=$S(DPP:" S D=$S($D("_DIE_"DA,"_DW_",0)):$P(^(0),U,3,4),1:1) G "_DQ_"+1",1:" G A") D L S X=" ;" D L,AF,DIERN
S DRN(DNR)=+DV_U_DIERN_DIE_"D"_DIEZL_","_DW_","_U_(DIEZL+1)_U_DQ_U_DRN G NX^DIEZ0
;
DIERN ;
N M S DIERN=DL+1,M=$P(DR,";",DK+1) S:M?1"^"1.NP DK=DK+1,DIERN=$P(M,U,2) Q
;
AF ;
S ^UTILITY($J,"AF",DP,DI,DIEZ)=""
AB I '$D(^UTILITY($J,"AB",DIEZAB,DI)) S ^(DI)=DQ_U_DNM_DRN S:DPR?1"/".E ^(DI,"///")=""
Q
;
DU S F=0,Q=DU D QFF S X=" S DU="_Q,DU=""
L S L=L+1,^UTILITY($J,0,L)=X,T=T+$L(X)+2 Q
;
O ;
S F=0,Q=^(2) D QFF S DIEZOT=" S DQ("_DQ_",2)="_Q Q
;
PR ;
F %=1,2,3 Q:$E(DPR,%)'="/"
S X=$E(DPR,%,999),Q=X,F=0 D QFF I $A(X)-94 S X=" S Y="_Q
E S X=" "_$E(X,2,999) D L S X=" S Y=X"
D L S X=" G Y" I %>1 S DPP=0,X=" S X=Y,DB(DQ)=1"_$S(%=3:",DE(DW,""4/"")=""""",1:"")_" G:X="""" N^DIE17:DV,A I $D(DE(DQ)),DV[""I""!(DV[""#"") D E^DIE0 G A:'$D(X)" D L S X=" G "_$S(%=3:"RD:X=""@"",Z",1:"RD")
Q
QF ;
S F=0,Q=DIE
QFF ;
S F=$F(Q,"""",F) I F S Q=$E(Q,1,F-1)_$E(Q,F-1,999),F=F+1 G QFF
S Q=""""_Q_""""
Q
;
INDEX ;Build code field and record level cross references.
;In:
; DP = file #
; DI = field #
; DIEZKEY(xref#) = "" : for each xref that is a Uniqueness Index
; for a simple (single-field key)
N DIEZCNT,DIEZFLST,DIEZI,DIEZRLST,DIEZXR,DIEZXREF
S DIEZCNT=0
;
;Get field- and record-level xrefs
D LOADFLD^DIKC1(DP,DI,"KS","","@DIEZTMP@(""V"",","DIEZXREF",$NA(@DIEZTMP@("R")),.DIEZFLST,.DIEZRLST)
I DIEZFLST="",DIEZRLST="" S X="C"_DQ_"F1" Q
;
;Build code for each field-level xref
;Save DIEZKEY(uniquenessIndex)=index tag # (DIEZCNT)
I DIEZFLST]"" S DIEZXR=0 F S DIEZXR=$O(DIEZXREF(DP,DIEZXR)) Q:'DIEZXR D
. D GETXR(DIEZXR,.DIEZCNT)
. S:$D(DIEZKEY(DIEZXR))#2 DIEZKEY(DIEZXR)=DIEZCNT
;
;Build code to set the DIEZRXR array for each record-level xref
S X="C"_DQ_"F"_(DIEZCNT+1)
Q:DIEZRLST=""
S X=X_" S DIEZRXR("_DP_",DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))" D L
S X=" F DIXR="_$TR(DIEZRLST,U,",")_" S DIEZRXR("_DP_",DIXR)=""""" D L
S DIEZI=0 F S DIEZI=$O(DIEZRLST(DIEZI)) Q:'DIEZI D
. S X=" F DIXR="_$TR(DIEZRLST(DIEZI),U,",")_" S DIEZRXR("_DP_",DIXR)=""""" D L ;p19
;
S X=""
Q
;
GETXR(DIEZXR,DIEZCNT) ;Get code for one index DIEZXR
N DIEZCOD,DIEZF,DIEZKLOG,DIEZNSS,DIEZSLOG,DIEZO
S DIEZCNT=$G(DIEZCNT)+1
;
;Build code to call subroutine to set X array
S X="C"_DQ_"F"_DIEZCNT_$S(DIEZCNT=1:" N X,X1,X2",1:"")_" S DIXR="_DIEZXR_" D C"_DQ_"X"_DIEZCNT_"(U) K X2 M X2=X D C"_DQ_"X"_DIEZCNT_"(""O"") K X1 M X1=X"
D L
;
;Build code to check for null subscripts
S DIEZNSS="",DIEZO=0
F S DIEZO=$O(DIEZXREF(DP,DIEZXR,DIEZO)) Q:'DIEZO D
. Q:'$G(DIEZXREF(DP,DIEZXR,DIEZO,"SS"))
. I DIEZNSS="" S DIEZNSS="$G(X("_DIEZO_"))]"""""
. E S DIEZNSS=DIEZNSS_",$G(X("_DIEZO_"))]"""""
I DIEZNSS]"" S DIEZNSS=" I "_DIEZNSS_" D"
E S DIEZNSS=" D"
;
;Get kill logic and condition
S DIEZKLOG=$G(DIEZXREF(DP,DIEZXR,"K"))
I DIEZKLOG'?."^" D
. S X=DIEZNSS D L
. ;Get kill condition code
. S DIEZCOD=$G(DIEZXREF(DP,DIEZXR,"KC"))
. I DIEZCOD'?."^" D
.. S X=" . N DIEXARR M DIEXARR=X S DIEZCOND=1" D L
.. S X=" . "_DIEZCOD D L
.. S X=" . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND" D L
. ;Get kill logic
. S X=" . "_DIEZKLOG D L
;
;Get set logic and condition
S DIEZSLOG=$G(DIEZXREF(DP,DIEZXR,"S"))
I DIEZSLOG'?."^" D
. S X=" K X M X=X2"_DIEZNSS D L
. ;Get set condition code
. S DIEZCOD=$G(DIEZXREF(DP,DIEZXR,"SC"))
. I DIEZCOD'?."^" D
.. S X=" . N DIEXARR M DIEXARR=X S DIEZCOND=1" D L
.. S X=" . "_DIEZCOD D L
.. S X=" . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND" D L
. ;Get set logic
. S X=" . "_DIEZSLOG D L
;
S X=" G C"_DQ_"F"_(DIEZCNT+1) D L
;
;Build code to set X array
S DIEZF=$O(DIEZXREF(DP,DIEZXR,0))
S X="C"_DQ_"X"_DIEZCNT_"(DION) K X" D L
S DIEZO=0
F S DIEZO=$O(DIEZXREF(DP,DIEZXR,DIEZO)) Q:'DIEZO D
. D BLDDEC(DP,DIEZXR,DIEZO)
S X=" S X=$G(X("_DIEZF_"))" D L
S X=" Q" D L
Q
;
BLDDEC(DP,DIEZXR,DIEZO) ;Build data extraction code
N CODE,NODE,TRANS
;
S CODE=$G(DIEZXREF(DP,DIEZXR,DIEZO)) Q:CODE?."^"
S TRANS=$G(DIEZXREF(DP,DIEZXR,DIEZO,"T"))
I TRANS'?."^" D
. S X=" "_CODE D L
. D DOTLINE(" I $D(X)#2 "_TRANS)
. S X=" S:$D(X)#2 X("_DIEZO_")=X" D L
E I $D(DIEZXREF(DP,DIEZXR,DIEZO,"F"))#2,CODE?1"S X=".E D
. S X=" S X("_DIEZO_")"_$E(CODE,4,999) D L
E D
. S X=" "_CODE D L
. S X=" S:$D(X)#2 X("_DIEZO_")=X" D L
Q
;
DOTLINE(CODE) ;
I CODE[" Q"!(CODE[" Q:") D
. S X=" D" D L
. S X=" ."_CODE D L
E S X=CODE D L
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIEZ2 8091 printed Oct 16, 2024@18:48:02 Page 2
DIEZ2 ;SFISC/GFT-COMPILE INPUT TEMPLATE ;15JUN2006
+1 ;;22.2;VA FileMan;**19**;Jan 05, 2016;Build 2
+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 KILL DIEZAR
DO RECXR^DIEZ4(.DIEZAR)
+8 KILL ^DIE(DIEZ,"AR")
if $DATA(DIEZAR)
MERGE ^DIE(DIEZ,"AR")=DIEZAR
+9 SET %X="^UTILITY($J,""AF"","
SET %Y="^DIE(""AF"","
DO %XY^%RCR
+10 KILL ^DIE(DIEZ,"AB")
SET %X="^UTILITY($J,""AB"","
SET %Y="^DIE(DIEZ,""AB"","
DO %XY^%RCR
+11 SET ^DIE(DIEZ,"ROUOLD")=DNM
SET ^("ROU")=U_DNM
K KILL ^DIBT(.402,1,DIEZ),^UTILITY($JOB)
+1 KILL @DIEZTMP,DIEZTMP,DIEZAR,DIER,DIERN
+2 KILL DIE,DINC,DK,DL,DMAX,DNR,DP,DQ,DQFF,DRD,DS,DSN,DV,DW,DI,DH,%,%X,%Y,%H,X,Y
+3 KILL DIEZ,DIEZDUP,DIEZR,Q,DPP,DPR,DM,DR,DU,T,F,DRN,DOV,DIEZL,DIEZP,DIEZAB
+4 QUIT
+5 ;
XREF ;
+1 NEW DIEZR,DIEZX,DIEZLN
+2 SET X="C"_DQ_" G C"_DQ_"S:$D(DE("_DQ_"))[0 K DB"
DO L
+3 ;remember cross-refs will start after 'L'
SET DIEZX=L
SET DIEZLN=0
+4 ;first build the KILL XREFS
FOR %=0:0
SET %=$ORDER(^DD(DP,DI,1,%))
if %'>0
QUIT
SET DW=^(%,2)
SET X=" S X=DE("_DQ_"),DIC=DIE"
DO SK
+5 IF DV["a"
SET X=" S X=DE("_DQ_"),DIIX=2_U_DIFLD D AUDIT^DIET"
DO X
+6 ;I X]"" S X="C"_DQ_" ;" D L
+7 DO OVERFLO
+8 SET X="C"_DQ_"S S X="""" G:DG(DQ)=X C"_DQ_"F1 K DB"
DO L
SET X=""
+9 SET DIEZX=L
SET DIEZLN=L
+10 ;then the SET XREFS
FOR %=0:0
SET %=$ORDER(^DD(DP,DI,1,%))
if %'>0
QUIT
SET DW=^(%,1)
SET X=X_" S X=DG(DQ),DIC=DIE"
DO SK
+11 IF DV["a"
SET X=X_" I $D(DE("_DQ_"))'[0!($G(^DD(DP,DIFLD,""AUDIT""))[""y"") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET"
DO X
+12 DO OVERFLO
+13 ;Build index code and code to check key
+14 DO INDEX
+15 SET X=X_" Q"
DO L
+16 IF $DATA(DIEZKEY)
DO GETKEY^DIEZ3(DP,DI,.DIEZKEY,DQ)
KILL DIEZKEY
+17 QUIT
+18 ;
SK DO X
IF "Q"[DW
SET X=" ;"
GOTO X
+1 IF DW["Q"
IF ^DD(DP,DI,1,%,0)["MUMPS"
SET Q=DW
SET F=0
DO QFF
SET X=" X "_Q
GOTO X
+2 SET X=" "_DW
X DO L
SET DIEZLN=DIEZLN+$LENGTH(X)
SET X=""
QUIT
+1 ;
OVERFLO IF DIEZLN+T+100<DMAX!'DIEZLN
QUIT
+1 KILL ^UTILITY($JOB,"DIEZXR")
MERGE ^UTILITY($JOB,"DIEZXR")=^UTILITY($JOB,0)
+2 SET DIEZR=DRN
SET (DIEZR(1),DRN)=$ORDER(DRN(""),-1)+1
Begin DoDot:1
+3 NEW T,DQ,L
+4 ;make a new routine holding just the X-REFS
DO NEWROU^DIEZ
+5 FOR T=2:1
SET DIEZX=DIEZX+1
if '$DATA(^UTILITY($JOB,"DIEZXR",DIEZX))
QUIT
SET ^UTILITY($JOB,0,T)=^(DIEZX)
KILL ^UTILITY($JOB,"DIEZXR",DIEZX)
+6 FOR
KILL ^UTILITY($JOB,0,T)
SET T=$ORDER(^(T))
if 'T
QUIT
+7 DO SAVE^DIEZ1
End DoDot:1
+8 KILL ^UTILITY($JOB,0)
MERGE ^UTILITY($JOB,0)=^UTILITY($JOB,"DIEZXR")
+9 SET DRN=DIEZR
SET T=T-DIEZLN
SET X=" D ^"_DNM_DIEZR(1)
DO L
+10 QUIT
+11 ;
MUL ;
+1 SET DNR=%
SET DW=$PIECE(DW,";",1)
SET X=$PIECE(^DD(+DV,0),U,4)_U_DV_U_DW_U
SET %=^(.01,0)
SET DV=+DV_$PIECE(%,U,2)
+2 if DV'["W"
GOTO 1
IF DPR]""
SET F=0
SET Q=DPR
DO QFF
SET X=" S DE(1,0)="_Q
DO L
WPEGP ;**CC0/NI WORD-PROCESSING FIELD LABEL
SET X=" S Y=""^"_$PIECE(%,U,2,9)_""" S $P(Y,U)="_$SELECT(DIEZP]"":""""_DIEZP_"""",1:"$$LABEL^DIALOGZ(DP,"_DI_")")_" S DG="""_DW_""",DC=""^"_+DV_""" D DIEN^DIWE K DE(1) G A"
DO L
SET X=" ;"
DO L
DO AF
+1 SET ^UTILITY($JOB,"AF",+DV,.01,DIEZ)=""
DO AB
GOTO NX^DIEZ0
+2 ;
1 ;**CCO/NI COMPILE 'SELECT FIELD:' SO IT WORKS FOR ANY LANGUAGE
+1 SET X=" S DIFLD="_DI_",DGO=""^"_DNM_DNR_""",DC="""_X_""",DV="""_DV_""",DW=""0;1"",DOW="_$SELECT(DIEZP]"":""""_DIEZP_"""",1:"$$LABEL^DIALOGZ(DP,DIFLD)")_",DLB=$P($$EZBLD^DIALOG(8042,DOW),"": "") S:D DC=DC_D"
SET DPP=DV["M"
SET DU=$PIECE(^(0),U,3)
DO L
if DU]""
DO DU
+2 SET X=$PIECE(" G RE:D",U,DPP)_" I $D(DSC("_+DV_"))#2,$P(DSC("_+DV_"),""I $D(^UTILITY("",1)="""" X DSC("_+DV_") S D=$O(^(0)) S:D="""" D=-1 G M"_DQ
DO L
+3 if +DW'=DW
SET DW=""""_DW_""""
SET X=" S D=$S($D("_DIE_"DA,"_DW_",0)):$P(^(0),U,3,4),$O(^(0))'="""":$O(^(0)),1:-1)"
DO L
+4 SET X="M"_DQ_" I D>0 S DC=DC_D I $D("_DIE_"DA,"_DW_",+D,0)) S DE("_DQ_")=$P(^(0),U,1)"
DO L
+5 DO PR^DIEZ0
SET X="R"_DQ_" D DE"
DO L
+6 SET X=$SELECT(DPP:" S D=$S($D("_DIE_"DA,"_DW_",0)):$P(^(0),U,3,4),1:1) G "_DQ_"+1",1:" G A")
DO L
SET X=" ;"
DO L
DO AF
DO DIERN
+7 SET DRN(DNR)=+DV_U_DIERN_DIE_"D"_DIEZL_","_DW_","_U_(DIEZL+1)_U_DQ_U_DRN
GOTO NX^DIEZ0
+8 ;
DIERN ;
+1 NEW M
SET DIERN=DL+1
SET M=$PIECE(DR,";",DK+1)
if M?1"^"1.NP
SET DK=DK+1
SET DIERN=$PIECE(M,U,2)
QUIT
+2 ;
AF ;
+1 SET ^UTILITY($JOB,"AF",DP,DI,DIEZ)=""
AB IF '$DATA(^UTILITY($JOB,"AB",DIEZAB,DI))
SET ^(DI)=DQ_U_DNM_DRN
if DPR?1"/".E
SET ^(DI,"///")=""
+1 QUIT
+2 ;
DU SET F=0
SET Q=DU
DO QFF
SET X=" S DU="_Q
SET DU=""
L SET L=L+1
SET ^UTILITY($JOB,0,L)=X
SET T=T+$LENGTH(X)+2
QUIT
+1 ;
O ;
+1 SET F=0
SET Q=^(2)
DO QFF
SET DIEZOT=" S DQ("_DQ_",2)="_Q
QUIT
+2 ;
PR ;
+1 FOR %=1,2,3
if $EXTRACT(DPR,%)'="/"
QUIT
+2 SET X=$EXTRACT(DPR,%,999)
SET Q=X
SET F=0
DO QFF
IF $ASCII(X)-94
SET X=" S Y="_Q
+3 IF '$TEST
SET X=" "_$EXTRACT(X,2,999)
DO L
SET X=" S Y=X"
+4 DO L
SET X=" G Y"
IF %>1
SET DPP=0
SET X=" S X=Y,DB(DQ)=1"_$SELECT(%=3:",DE(DW,""4/"")=""""",1:"")_" G:X="""" N^DIE17:DV,A I $D(DE(DQ)),DV[""I""!(DV[""#"") D E^DIE0 G A:'$D(X)"
DO L
SET X=" G "_$SELECT(%=3:"RD:X=""@"",Z",1:"RD")
+5 QUIT
QF ;
+1 SET F=0
SET Q=DIE
QFF ;
+1 SET F=$FIND(Q,"""",F)
IF F
SET Q=$EXTRACT(Q,1,F-1)_$EXTRACT(Q,F-1,999)
SET F=F+1
GOTO QFF
+2 SET Q=""""_Q_""""
+3 QUIT
+4 ;
INDEX ;Build code field and record level cross references.
+1 ;In:
+2 ; DP = file #
+3 ; DI = field #
+4 ; DIEZKEY(xref#) = "" : for each xref that is a Uniqueness Index
+5 ; for a simple (single-field key)
+6 NEW DIEZCNT,DIEZFLST,DIEZI,DIEZRLST,DIEZXR,DIEZXREF
+7 SET DIEZCNT=0
+8 ;
+9 ;Get field- and record-level xrefs
+10 DO LOADFLD^DIKC1(DP,DI,"KS","","@DIEZTMP@(""V"",","DIEZXREF",$NAME(@DIEZTMP@("R")),.DIEZFLST,.DIEZRLST)
+11 IF DIEZFLST=""
IF DIEZRLST=""
SET X="C"_DQ_"F1"
QUIT
+12 ;
+13 ;Build code for each field-level xref
+14 ;Save DIEZKEY(uniquenessIndex)=index tag # (DIEZCNT)
+15 IF DIEZFLST]""
SET DIEZXR=0
FOR
SET DIEZXR=$ORDER(DIEZXREF(DP,DIEZXR))
if 'DIEZXR
QUIT
Begin DoDot:1
+16 DO GETXR(DIEZXR,.DIEZCNT)
+17 if $DATA(DIEZKEY(DIEZXR))#2
SET DIEZKEY(DIEZXR)=DIEZCNT
End DoDot:1
+18 ;
+19 ;Build code to set the DIEZRXR array for each record-level xref
+20 SET X="C"_DQ_"F"_(DIEZCNT+1)
+21 if DIEZRLST=""
QUIT
+22 SET X=X_" S DIEZRXR("_DP_",DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))"
DO L
+23 SET X=" F DIXR="_$TRANSLATE(DIEZRLST,U,",")_" S DIEZRXR("_DP_",DIXR)="""""
DO L
+24 SET DIEZI=0
FOR
SET DIEZI=$ORDER(DIEZRLST(DIEZI))
if 'DIEZI
QUIT
Begin DoDot:1
+25 ;p19
SET X=" F DIXR="_$TRANSLATE(DIEZRLST(DIEZI),U,",")_" S DIEZRXR("_DP_",DIXR)="""""
DO L
End DoDot:1
+26 ;
+27 SET X=""
+28 QUIT
+29 ;
GETXR(DIEZXR,DIEZCNT) ;Get code for one index DIEZXR
+1 NEW DIEZCOD,DIEZF,DIEZKLOG,DIEZNSS,DIEZSLOG,DIEZO
+2 SET DIEZCNT=$GET(DIEZCNT)+1
+3 ;
+4 ;Build code to call subroutine to set X array
+5 SET X="C"_DQ_"F"_DIEZCNT_$SELECT(DIEZCNT=1:" N X,X1,X2",1:"")_" S DIXR="_DIEZXR_" D C"_DQ_"X"_DIEZCNT_"(U) K X2 M X2=X D C"_DQ_"X"_DIEZCNT_"(""O"") K X1 M X1=X"
+6 DO L
+7 ;
+8 ;Build code to check for null subscripts
+9 SET DIEZNSS=""
SET DIEZO=0
+10 FOR
SET DIEZO=$ORDER(DIEZXREF(DP,DIEZXR,DIEZO))
if 'DIEZO
QUIT
Begin DoDot:1
+11 if '$GET(DIEZXREF(DP,DIEZXR,DIEZO,"SS"))
QUIT
+12 IF DIEZNSS=""
SET DIEZNSS="$G(X("_DIEZO_"))]"""""
+13 IF '$TEST
SET DIEZNSS=DIEZNSS_",$G(X("_DIEZO_"))]"""""
End DoDot:1
+14 IF DIEZNSS]""
SET DIEZNSS=" I "_DIEZNSS_" D"
+15 IF '$TEST
SET DIEZNSS=" D"
+16 ;
+17 ;Get kill logic and condition
+18 SET DIEZKLOG=$GET(DIEZXREF(DP,DIEZXR,"K"))
+19 IF DIEZKLOG'?."^"
Begin DoDot:1
+20 SET X=DIEZNSS
DO L
+21 ;Get kill condition code
+22 SET DIEZCOD=$GET(DIEZXREF(DP,DIEZXR,"KC"))
+23 IF DIEZCOD'?."^"
Begin DoDot:2
+24 SET X=" . N DIEXARR M DIEXARR=X S DIEZCOND=1"
DO L
+25 SET X=" . "_DIEZCOD
DO L
+26 SET X=" . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND"
DO L
End DoDot:2
+27 ;Get kill logic
+28 SET X=" . "_DIEZKLOG
DO L
End DoDot:1
+29 ;
+30 ;Get set logic and condition
+31 SET DIEZSLOG=$GET(DIEZXREF(DP,DIEZXR,"S"))
+32 IF DIEZSLOG'?."^"
Begin DoDot:1
+33 SET X=" K X M X=X2"_DIEZNSS
DO L
+34 ;Get set condition code
+35 SET DIEZCOD=$GET(DIEZXREF(DP,DIEZXR,"SC"))
+36 IF DIEZCOD'?."^"
Begin DoDot:2
+37 SET X=" . N DIEXARR M DIEXARR=X S DIEZCOND=1"
DO L
+38 SET X=" . "_DIEZCOD
DO L
+39 SET X=" . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND"
DO L
End DoDot:2
+40 ;Get set logic
+41 SET X=" . "_DIEZSLOG
DO L
End DoDot:1
+42 ;
+43 SET X=" G C"_DQ_"F"_(DIEZCNT+1)
DO L
+44 ;
+45 ;Build code to set X array
+46 SET DIEZF=$ORDER(DIEZXREF(DP,DIEZXR,0))
+47 SET X="C"_DQ_"X"_DIEZCNT_"(DION) K X"
DO L
+48 SET DIEZO=0
+49 FOR
SET DIEZO=$ORDER(DIEZXREF(DP,DIEZXR,DIEZO))
if 'DIEZO
QUIT
Begin DoDot:1
+50 DO BLDDEC(DP,DIEZXR,DIEZO)
End DoDot:1
+51 SET X=" S X=$G(X("_DIEZF_"))"
DO L
+52 SET X=" Q"
DO L
+53 QUIT
+54 ;
BLDDEC(DP,DIEZXR,DIEZO) ;Build data extraction code
+1 NEW CODE,NODE,TRANS
+2 ;
+3 SET CODE=$GET(DIEZXREF(DP,DIEZXR,DIEZO))
if CODE?."^"
QUIT
+4 SET TRANS=$GET(DIEZXREF(DP,DIEZXR,DIEZO,"T"))
+5 IF TRANS'?."^"
Begin DoDot:1
+6 SET X=" "_CODE
DO L
+7 DO DOTLINE(" I $D(X)#2 "_TRANS)
+8 SET X=" S:$D(X)#2 X("_DIEZO_")=X"
DO L
End DoDot:1
+9 IF '$TEST
IF $DATA(DIEZXREF(DP,DIEZXR,DIEZO,"F"))#2
IF CODE?1"S X=".E
Begin DoDot:1
+10 SET X=" S X("_DIEZO_")"_$EXTRACT(CODE,4,999)
DO L
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 SET X=" "_CODE
DO L
+13 SET X=" S:$D(X)#2 X("_DIEZO_")=X"
DO L
End DoDot:1
+14 QUIT
+15 ;
DOTLINE(CODE) ;
+1 IF CODE[" Q"!(CODE[" Q:")
Begin DoDot:1
+2 SET X=" D"
DO L
+3 SET X=" ."_CODE
DO L
End DoDot:1
+4 IF '$TEST
SET X=CODE
DO L
+5 QUIT
