XINDX10 ;ISC/GRK - assemble DD executable code ;11/12/2002 11:40
;;7.3;TOOLKIT;**20,27,66,68,132,153**;Apr 25, 1995;Build 3
; Per VHA Directive 2004-038, this routine should not be modified.
ASK ;Ask for Build, Install, or Package file.
N X,Y,P,V,RN
S DA=0,Y=-1,INP(11)=""
S:$D(^DD(9.6,0)) P=9.6,Y=$$BUILD^XTRUTL1 Q:$D(DUOUT) D:Y>0 I Y<0 S:$D(^DD(9.7,0)) P=9.7,Y=$$INSTALL^XTRUTL1 D:Y>0
. S INP(10)=P,DA=+Y,X=$P(Y,"^",2),V=$$VER^XTRUTL1(X)
. S INP(11)="I $P(LIN,"";"",3)'["""_V_""" D E^XINDX1(44)",INP(11.1)=V
. ;p153 don't setup check if patch is zero
. I $P(X,"*",3) S INP(12)="I $P(LIN,"";"",5)'?.E1P1"""_$P(X,"*",3)_"""1P.E S ERR=56,ERR(1)=INP(12.1) D E^XINDX1(.ERR)",INP(12.1)=$P(X,"*",3)
. Q
K DIC Q:$D(DUOUT)
I $D(^DD(9.4,0)),'DA S DIC="^DIC(9.4,",DIC(0)="AEQMZ" D ^DIC S INP(10)=9.4,DA=+Y
Q
;
START ;called from SETUP^XINDX7
G PKG:INP(10)=9.4,NEXT:INP(10)=9.7
;Get routines and other code from BUILD.
W !,"The BUILD file Data Dictionaries are being processed.",!
F J=0:0 S J=$O(^XPD(9.6,DA,4,J)) Q:J'>0 I $D(^(J,0)) S INDFN=+^(0),INDRN="|dd"_INDFN D XPD
G NEXT
PKG W !,"The package file Data Dictionaries are being processed.",!
F J=0:0 S J=$O(^DIC(9.4,DA,4,J)) Q:J'>0 I $D(^(J,0)) S INDFN=+^(0),INDRN="|dd"_INDFN,(INDF,INDL)=0 D INSERT
NEXT D ^XINDX11,REMCOMP:'INP(9) K A,B,C,C9,G,H,INDD,INDEL,INDF,INDFN,INDID,INDL,INDN,INDRN,INDSB,INDX,INDXN,INDXRF,DA,DIC,J,INDLC,INDC
Q
XPD ;Check if Full/Partial DD
N IND1,IND222,J2,J3 S IND222=$G(^XPD(9.6,DA,4,J,222))
S (INDF,INDL)=0 I $P(IND222,"^",3)="f" K IND222 D INSERT Q
;Each entry at the J2 level is a new file/sub-file.
F J2=0:0 S J2=$O(^XPD(9.6,DA,4,J,2,J2)) Q:J2'>0 S IND1=^(J2,0) D
. S INDFN=J2,INDRN="|dd"_INDFN,INDLC=0 Q:'$$HDR()
. ;Each J3 is a field in the file.
. F J3=0:0 S J3=$O(^XPD(9.6,DA,4,J,2,J2,1,J3)) Q:J3'>0 S INDFN=J2,INDF=J3,INDL=0 D STRIP
. S ^UTILITY($J,1,INDRN,0,0)=INDLC
. Q
Q
HDR() ;Display Header and start faux routine build
I '$D(^DD(INDFN)) W !,"File # ",INDFN," is missing !",$C(7) Q 0
S ^UTILITY($J,INDRN)="",NRO=NRO+1 W !,INDFN," ",$O(^DD(INDFN,0,"NM",0))
S INDLC=0,INDC=INDRN_" ;"_$S($D(IND222):"Partial ",1:"")_"DD of the "_$O(^DD(INDFN,0,"NM",0))_$S(INDL:" sub-",1:" ")_"file"_$S(INDL:" of the "_$O(^DD(INDFN(1),0,"NM",0))_" (#"_INDFN(1)_") file.",1:"."),INDX="" D ADD
Q 1
INSERT ;Find executable code in this DD
Q:'$$HDR
ID S INDID=-1 F G=0:0 S INDID=$O(^DD(INDFN,0,"ID",INDID)) Q:INDID="" I $D(^(INDID))#2 S INDC="ID"_INDID_" ; IDENTIFIER CODE FOR "_INDID S INDX=$S(^(INDID)]"":^(INDID),1:"Q") D ADD
W I $D(^DD(INDFN,0,"W"))#2 S INDX=^("W"),INDC="W ; 'W' code ??" D ADD
FLD S INDF=$O(^DD(INDFN,INDF)) I INDF>0 D STRIP W "." G FLD
S ^UTILITY($J,1,INDRN,0,0)=INDLC Q
STRIP ;
S A=$P(^DD(INDFN,INDF,0),"^",2) I A D PUSH,INSERT,POP Q
I A'["W",A'["S" S INDX=$P(^(0),"^",5,99),INDC=INDF_" ; "_$P(^(0),"^",1) D ADD
I $D(^DD(INDFN,INDF,2))#2 S INDC=INDF_"OT ; OUTPUT TRANSFORM CODE",INDX=^(2) D ADD
I $D(^DD(INDFN,INDF,4))#2 S INDC=INDF_"HELP ; EXECUTABLE HELP CODE",INDX=^(4) D ADD
I $D(^DD(INDFN,INDF,12)) S INDC=INDF_"SCR ; "_$E(^(12),1,220) S INDX=$S($D(^(12.1))#2:^(12.1),1:"Q") D ADD
I $D(^DD(INDFN,INDF,7.5))#2 S INDC=INDF_"TPL ; TRANSFORM DONE PRIOR TO THE DIC LOOK-UP",INDX=^(7.5) D ADD
I $D(^DD(INDFN,INDF,"AX"))#2 S INDC=INDF_"AX ; EXECUTABLE AUDIT CHECK CODE",INDX=^("AX") D ADD
F INDEL=9.2:.1:9.9 I $D(^DD(INDFN,INDF,INDEL))#2 S INDC=INDF_"OF"_INDEL_" ; OVERFLOW CODE",INDX=^(INDEL) D ADD
S INDEL="" F S INDEL=$O(^DD(INDFN,INDF,"DEL",INDEL)) Q:INDEL="" I $D(^(INDEL,0))#2 S INDC=INDF_"DEL"_INDEL_" ; DELETE PROTECTION CODE",INDX=^(0) D ADD
S INDEL="" F G=0:0 S INDEL=$O(^DD(INDFN,INDF,"LAYGO",INDEL)) Q:INDEL="" I $D(^(INDEL,0))#2 S INDC=INDF_"LAYGO"_INDEL_" ; LAYGO CHECK CODE",INDX=^(0) D ADD
F INDXRF=0:0 S INDXRF=$O(^DD(INDFN,INDF,1,INDXRF)) Q:INDXRF'>0 S C=$P(^(INDXRF,0),"^",2) F G=0:0 S G=$O(^DD(INDFN,INDF,1,INDXRF,G)) Q:G'>0 D XREFS
Q
XREFS Q:('$D(^(G))#2)!(G=3) ;Node 3 is don't delete comment.
S INDC=INDF_"XRF"_INDXRF_$S(G=1:"S",G=2:"K",1:"n"_G)_" ; "_$S(G<2:"SET",G<3:"KILL",1:"OVERFLOW")_" LOGIC FOR '"_$S(C]"":C,1:INDXRF)_"' XREF",INDX=^(G) D ADD
Q
ADD ;Put code in UTILITY for processing
S INDLC=INDLC+1,^UTILITY($J,1,INDRN,0,INDLC,0)=INDC I INDX]"" S INDLC=INDLC+1,^UTILITY($J,1,INDRN,0,INDLC,0)=" "_INDX
Q
PUSH S INDL=INDL+1 F A="INDFN","INDF","INDLC","INDRN" S @(A_"(INDL)")=@A
S INDFN=+$P(^DD(INDFN,INDF,0),"^",2),INDRN="|dd"_INDFN,(INDLC,INDF)=0
Q
POP F A="INDFN","INDF","INDLC","INDRN" S @A=@(A_"(INDL)")
S INDL=INDL-1 Q
REMCOMP ;Remove compiled template routines from selected list
S %="|dd"
F J=1:1 S %=$O(^UTILITY($J,%)) Q:%'?1"|dd".NP S INDFN=+$E(%,4,999) I '$D(^DD(INDFN,0,"UP")) F F="^DIE(","^DIPT(" S F1=F_"""F"_INDFN_""",",%1="" F J=0:0 S %1=$O(@(F1_"%1)")) Q:%1="" F %2=0:0 S %2=$O(@(F1_"%1,%2)")) Q:%2'>0 D P
Q
P I $D(@(F_"%2,0)")) S R=$E($S($D(^("ROU")):^("ROU"),$D(^("ROUOLD")):^("ROUOLD"),1:""),2,999)
Q:R=""
I $D(^UTILITY($J,R)) K ^UTILITY($J,R)
S RN=R F J=0:0 S RN=$O(^UTILITY($J,RN)) Q:RN=""!(RN'?@("1"""_R_"""1N.N")) K ^UTILITY($J,RN)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXINDX10 14470 printed Apr 09, 2024@21:44:46 Page 2
XINDX10 ;ISC/GRK,KRM/CJE,OSE/SMH - assemble DD executable code ;2018-03-13 10:37 AM
+1 ;;7.3;TOOLKIT;**20,27,66,68,132,10001**;Apr 25, 1995;Build 4
+2 ; Original routine authored by U.S. Department of Veterans Affairs
+3 ; Entry points ASKNS,ASKFILES,N1,F1,NS,FILE,INDX &
+4 ; Lines START+1,STRIP+14-16 authored by Christopher Edwards 2017.
+5 ; Lines STRIP+16ff, tags ROUTAG,DATA1,AGAIN by Sam Habiel for XINDEXING data 2018.
ASK ;Ask for Build, Install, or Package file.
+1 NEW X,Y,P,V,RN
+2 SET DA=0
SET Y=-1
SET INP(11)=""
+3 if $DATA(^DD(9.6,0))
SET P=9.6
SET Y=$$BUILD^XTRUTL1
if $DATA(DUOUT)
QUIT
if Y>0
Begin DoDot:1
+4 SET INP(10)=P
SET DA=+Y
SET X=$PIECE(Y,"^",2)
SET V=$$VER^XTRUTL1(X)
+5 SET INP(11)="I $P(LIN,"";"",3)'["""_V_""" D E^XINDX1(44)"
SET INP(11.1)=V
+6 IF $LENGTH($PIECE(X,"*",3))
SET INP(12)="I $P(LIN,"";"",5)'?.E1P1"""_$PIECE(X,"*",3)_"""1P.E S ERR=56,ERR(1)=INP(12.1) D E^XINDX1(.ERR)"
SET INP(12.1)=$PIECE(X,"*",3)
+7 QUIT
End DoDot:1
IF Y<0
if $DATA(^DD(9.7,0))
SET P=9.7
SET Y=$$INSTALL^XTRUTL1
if Y>0
Begin DoDot:1
End DoDot:1
+8 KILL DIC
if $DATA(DUOUT)
QUIT
+9 IF $DATA(^DD(9.4,0))
IF 'DA
SET DIC="^DIC(9.4,"
SET DIC(0)="AEQMZ"
DO ^DIC
SET INP(10)=9.4
SET DA=+Y
+10 DO ASKNS
DO ASKFILES
+11 QUIT
ASKNS ;Ask for a list of namespaces
+1 NEW NSC,NS
+2 WRITE !,"LIST OF NAMESPACES TO BE INDEXED; PRESS RETURN TO TERMINATE LIST",!
SET NSC=0
N1 READ !,"NAMESPACE: ",NS:$SELECT($GET(DTIME):DTIME,1:360)
if NS=""
QUIT
if NS="^"
QUIT
+1 IF NS'?1(1"%",1"!",1"-").UN&(NS'?1U.UN)
WRITE " INVALID NAMESPACE"
GOTO N1
+2 IF NS?1(1"!",1"-").UN
SET $EXTRACT(NS,1,1)="!"
SET NSC=NSC+1
SET ENAMESPACES($JOB,NS)=""
+3 IF '$TEST
SET NSC=NSC+1
SET NAMESPACES($JOB,NS)=""
+4 SET INP(10)="NAMESPACE"
SET DA=1
+5 GOTO N1
+6 QUIT
+7 ;
ASKFILES ;Ask for a list of files
+1 NEW FILESC,FILE
+2 WRITE !,"LIST OF FILES TO BE INDEXED; PRESS RETURN TO TERMINATE LIST",!
SET FILESC=0
F1 READ !,"FILE: ",FILE:$SELECT($GET(DTIME):DTIME,1:360)
if FILE=""
QUIT
if FILE="^"
QUIT
+1 IF FILE'?1.45UNP&('$DATA(^DIC(FILE))!'($DATA(^DIC("B",FILE))))
WRITE " INVALID FILENAME"
GOTO F1
+2 ; should only get file number for list, but accept file name or number
+3 IF '$TEST
Begin DoDot:1
+4 ; translate the file name into a number
+5 IF FILE'=+FILE
SET FILE=$ORDER(^DIC("B",FILE,""))
IF FILE=""
WRITE " INVALID FILENAME"
QUIT
+6 ; if we have a number then we can add it and continue
+7 SET FILESC=FILESC+1
SET FILES($JOB,FILE)=""
WRITE " ",FILE
End DoDot:1
+8 SET INP(10)="NAMESPACE"
SET DA=1
+9 GOTO F1
+10 QUIT
+11 ;
START ;called from SETUP^XINDX7
+1 if INP(10)=9.4
GOTO PKG
if INP(10)=9.7
GOTO NEXT
if INP(10)="NAMESPACE"
GOTO NS
+2 ;Get routines and other code from BUILD.
+3 WRITE !,"The BUILD file Data Dictionaries are being processed.",!
+4 FOR J=0:0
SET J=$ORDER(^XPD(9.6,DA,4,J))
if J'>0
QUIT
IF $DATA(^(J,0))
SET INDFN=+^(0)
SET INDRN="|dd"_INDFN
DO XPD
+5 GOTO NEXT
NS WRITE !,"The selected file Data Dictionaries are being processed.",!
+1 FOR J=0:0
SET J=$ORDER(FILES($JOB,J))
if J'>0
QUIT
IF $DATA(^DIC(J,0))
SET INDFN=J
SET INDRN="|dd"_INDFN
SET (INDF,INDL)=0
DO INSERT
+2 GOTO NEXT
PKG WRITE !,"The package file Data Dictionaries are being processed.",!
+1 FOR J=0:0
SET J=$ORDER(^DIC(9.4,DA,4,J))
if J'>0
QUIT
IF $DATA(^(J,0))
SET INDFN=+^(0)
SET INDRN="|dd"_INDFN
SET (INDF,INDL)=0
DO INSERT
NEXT DO ^XINDX11
if 'INP(9)
DO REMCOMP
KILL A,B,C,C9,G,H,INDD,INDEL,INDF,INDFN,INDID,INDL,INDN,INDRN,INDSB,INDX,INDXN,INDXRF,DA,DIC,J,INDLC,INDC
+1 QUIT
XPD ;Check if Full/Partial DD
+1 NEW IND1,IND222,J2,J3
SET IND222=$GET(^XPD(9.6,DA,4,J,222))
+2 SET (INDF,INDL)=0
IF $PIECE(IND222,"^",3)="f"
KILL IND222
DO INSERT
QUIT
+3 ;Each entry at the J2 level is a new file/sub-file.
+4 FOR J2=0:0
SET J2=$ORDER(^XPD(9.6,DA,4,J,2,J2))
if J2'>0
QUIT
SET IND1=^(J2,0)
Begin DoDot:1
+5 SET INDFN=J2
SET INDRN="|dd"_INDFN
SET INDLC=0
if '$$HDR()
QUIT
+6 ;Each J3 is a field in the file.
+7 FOR J3=0:0
SET J3=$ORDER(^XPD(9.6,DA,4,J,2,J2,1,J3))
if J3'>0
QUIT
SET INDFN=J2
SET INDF=J3
SET INDL=0
DO STRIP
+8 SET ^UTILITY($JOB,1,INDRN,0,0)=INDLC
+9 QUIT
End DoDot:1
+10 QUIT
HDR() ;Display Header and start faux routine build
+1 IF '$DATA(^DD(INDFN))
WRITE !,"File # ",INDFN," is missing !",$CHAR(7)
QUIT 0
+2 SET ^UTILITY($JOB,INDRN)=""
SET NRO=NRO+1
WRITE !,INDFN," ",$ORDER(^DD(INDFN,0,"NM",0))
+3 SET INDLC=0
SET INDC=INDRN_" ;"_$SELECT($DATA(IND222):"Partial ",1:"")_"DD of the "_$ORDER(^DD(INDFN,0,"NM",0))_$SELECT(INDL:" sub-",1:" ")_"file"_$SELECT(INDL:" of the "_$ORDER(^DD(INDFN(1),0,"NM",0))_" (#"_INDFN(1)_") file.",1:".")
SET INDX=""
DO ADD
+4 QUIT 1
INSERT ;Find executable code in this DD
+1 if '$$HDR
QUIT
ID SET INDID=-1
FOR G=0:0
SET INDID=$ORDER(^DD(INDFN,0,"ID",INDID))
if INDID=""
QUIT
IF $DATA(^(INDID))#2
SET INDC="ID"_INDID_" ; IDENTIFIER CODE FOR "_INDID
SET INDX=$SELECT(^(INDID)]"":^(INDID),1:"Q")
DO ADD
W IF $DATA(^DD(INDFN,0,"W"))#2
SET INDX=^("W")
SET INDC="W ; 'W' code ??"
DO ADD
FILE ;Get additional File level fields that contain executable code
+1 IF $DATA(^DD(INDFN,0,"ACT"))#2
SET INDC="ACT ; POST-ACTION"
SET INDX=^("ACT")
DO ADD
+2 IF $DATA(^DD(INDFN,0,"DIC"))#2
SET INDC="DIC ; SPECIAL LOOKUP"
SET INDX="D ^"_^("DIC")
DO ADD
INDX ;Get New-Style Cross-Reference stored in the INDEX File
+1 ;We can get this from the "BB" index on the INDEX file (INDEL is the index name)
+2 SET INDEL=""
FOR
SET INDEL=$ORDER(^DD("IX","BB",INDFN,INDEL))
if INDEL=""
QUIT
Begin DoDot:1
+3 ; Naked reference to ^DD("IX","BB",INDFN)
SET X=$QUERY(^(INDEL))
SET X=$QSUBSCRIPT(X,5)
+4 IF $DATA(^DD("IX",X,1))#2
SET INDC="IX"_INDEL_"SL ; SET LOGIC"
SET INDX=$EXTRACT(^DD("IX",X,1),1,245)
DO ADD
+5 SET SUB=""
FOR
SET SUB=$ORDER(^DD("IX",X,1.2,SUB))
if SUB=""
QUIT
if SUB'=+SUB
QUIT
IF $DATA(^DD("IX",X,1.2,SUB,1))#2
SET INDC="IX"_INDEL_"P"_SUB_"SOF ; OVERFLOW SET LOGIC ("_SUB_")"
SET INDX=$EXTRACT(^DD("IX",X,1.2,SUB,1),1,245)
DO ADD
+6 IF $DATA(^DD("IX",X,1.4))#2
SET INDC="IX"_INDEL_"SCC ; SET CONDITION CODE"
SET INDX=$EXTRACT(^DD("IX",X,1.4),1,245)
DO ADD
+7 IF $DATA(^DD("IX",X,2))#2
SET INDC="IX"_INDEL_"KL ; KILL LOGIC"
SET INDX=$EXTRACT(^DD("IX",X,2),1,245)
DO ADD
+8 SET SUB=""
FOR
SET SUB=$ORDER(^DD("IX",X,2.2,SUB))
if SUB=""
QUIT
if SUB'=+SUB
QUIT
IF $DATA(^DD("IX",X,2.2,SUB,2))#2
SET INDC="IX"_INDEL_"P"_SUB_"KOF ; OVERFLOW KILL LOGIC ("_SUB_")"
SET INDX=$EXTRACT(^DD("IX",X,2.2,SUB,2),1,245)
DO ADD
+9 IF $DATA(^DD("IX",X,2.4))#2
SET INDC="IX"_INDEL_"KCC ; KILL CONDITION CODE"
SET INDX=$EXTRACT(^DD("IX",X,2.4),1,245)
DO ADD
+10 IF $DATA(^DD("IX",X,2.5))#2
SET INDC="IX"_INDEL_"KEIC ; KILL ENTIRE INDEX CODE"
SET INDX=$EXTRACT(^DD("IX",X,2.5),1,245)
DO ADD
+11 SET SUB=""
FOR
SET SUB=$ORDER(^DD("IX",X,11.1,SUB))
if SUB=""
QUIT
if SUB'=+SUB
QUIT
Begin DoDot:2
+12 IF $DATA(^DD("IX",X,11.1,SUB,1.5))#2
SET INDC="IX"_INDEL_"P"_SUB_"CC ; COMPUTED CODE ("_SUB_")"
SET INDX=$EXTRACT(^DD("IX",X,11.1,SUB,1.5),1,245)
DO ADD
+13 IF $DATA(^DD("IX",X,11.1,SUB,2))#2
SET INDC="IX"_INDEL_"P"_SUB_"TS ; TRANSFORM FOR STORAGE ("_SUB_")"
SET INDX=$EXTRACT(^DD("IX",X,11.1,SUB,2),1,245)
DO ADD
+14 IF $DATA(^DD("IX",X,11.1,SUB,4))#2
SET INDC="IX"_INDEL_"P"_SUB_"TL ; TRANSFORM FOR LOOKUP ("_SUB_")"
SET INDX=$EXTRACT(^DD("IX",X,11.1,SUB,4),1,245)
DO ADD
+15 IF $DATA(^DD("IX",X,11.1,SUB,3))#2
SET INDC="IX"_INDEL_"P"_SUB_"TD ; TRANSFORM FOR DISPLAY ("_SUB_")"
SET INDX=$EXTRACT(^DD("IX",X,11.1,SUB,3),1,245)
DO ADD
End DoDot:2
End DoDot:1
FLD SET INDF=$ORDER(^DD(INDFN,INDF))
IF INDF>0
DO STRIP
WRITE "."
GOTO FLD
+1 SET ^UTILITY($JOB,1,INDRN,0,0)=INDLC
QUIT
STRIP ;
+1 SET A=$PIECE(^DD(INDFN,INDF,0),"^",2)
IF A
DO PUSH
DO INSERT
DO POP
QUIT
+2 IF A'["W"
IF A'["S"
SET INDX=$PIECE(^(0),"^",5,99)
SET INDC=INDF_" ; "_$PIECE(^(0),"^",1)
DO ADD
+3 IF $DATA(^DD(INDFN,INDF,2))#2
SET INDC=INDF_"OT ; OUTPUT TRANSFORM CODE"
SET INDX=^(2)
DO ADD
+4 IF $DATA(^DD(INDFN,INDF,4))#2
SET INDC=INDF_"HELP ; EXECUTABLE HELP CODE"
SET INDX=^(4)
DO ADD
+5 IF $DATA(^DD(INDFN,INDF,12))
SET INDC=INDF_"SCR ; "_$EXTRACT(^(12),1,220)
SET INDX=$SELECT($DATA(^(12.1))#2:^(12.1),1:"Q")
DO ADD
+6 IF $DATA(^DD(INDFN,INDF,7.5))#2
SET INDC=INDF_"TPL ; TRANSFORM DONE PRIOR TO THE DIC LOOK-UP"
SET INDX=^(7.5)
DO ADD
+7 IF $DATA(^DD(INDFN,INDF,"AX"))#2
SET INDC=INDF_"AX ; EXECUTABLE AUDIT CHECK CODE"
SET INDX=^("AX")
DO ADD
+8 FOR INDEL=9.2:.1:9.9
IF $DATA(^DD(INDFN,INDF,INDEL))#2
SET INDC=INDF_"OF"_INDEL_" ; OVERFLOW CODE"
SET INDX=^(INDEL)
DO ADD
+9 SET INDEL=""
FOR
SET INDEL=$ORDER(^DD(INDFN,INDF,"DEL",INDEL))
if INDEL=""
QUIT
IF $DATA(^(INDEL,0))#2
SET INDC=INDF_"DEL"_INDEL_" ; DELETE PROTECTION CODE"
SET INDX=^(0)
DO ADD
+10 SET INDEL=""
FOR G=0:0
SET INDEL=$ORDER(^DD(INDFN,INDF,"LAYGO",INDEL))
if INDEL=""
QUIT
IF $DATA(^(INDEL,0))#2
SET INDC=INDF_"LAYGO"_INDEL_" ; LAYGO CHECK CODE"
SET INDX=^(0)
DO ADD
+11 FOR INDXRF=0:0
SET INDXRF=$ORDER(^DD(INDFN,INDF,1,INDXRF))
if INDXRF'>0
QUIT
SET C=$PIECE(^(INDXRF,0),"^",2)
FOR G=0:0
SET G=$ORDER(^DD(INDFN,INDF,1,INDXRF,G))
if G'>0
QUIT
DO XREFS
+12 ; Additional Data Dictionary fields that contain executable code
+13 IF $DATA(^DD(INDFN,INDF,12.2))
SET INDC=INDF_"SCREXP ; EXPRESSION FOR POINTER SCREEN"
SET INDX=$SELECT($DATA(^(12.2))#2:^(12.2),1:"Q")
DO ADD
+14 SET INDEL=""
FOR
SET INDEL=$ORDER(^DD(INDFN,INDF,"V",INDEL))
if INDEL=""
QUIT
IF $DATA(^(INDEL,1))#2
SET INDC=INDF_"VPSCR"_INDEL_" ; VARIABLE POINTER SCREEN"
SET INDX=^(1)
DO ADD
+15 ;
+16 ; Modifications to XINDEX data *10001* OSE/SMH
+17 ; OSE/SMH - M code in Data
IF A["K"
DO DATA1(INDFN,INDF)
+18 ; OSE/SMH - Routine and tag stored separately
IF $PIECE(^DD(INDFN,INDF,0),U)["ROUTINE"
DO ROUTAG
+19 ;
+20 QUIT
+21 ;
ROUTAG ; [Private] OSE/SMH *10001* - XINDEX Routine and Tag when stored separately.
+1 ; We are at the routine; find the tag in the dd before or after.
+2 ; If we can't find the tag, forget about it then.
+3 NEW tagSub
+4 NEW prevSub
SET prevSub=$ORDER(^DD(INDFN,INDF),-1)
+5 NEW nextSub
SET nextSub=$ORDER(^DD(INDFN,INDF),+1)
+6 Begin DoDot:1
+7 IF prevSub
IF $PIECE(^DD(INDFN,prevSub,0),U)["TAG"
SET tagSub=prevSub
QUIT
+8 IF nextSub
IF $PIECE(^DD(INDFN,nextSub,0),U)["TAG"
SET tagSub=nextSub
QUIT
End DoDot:1
+9
*** ERROR ***
IF $g(tagSub)=""
QUIT
+10 ; debug
+11 ; w "found "_tagSub_" as "_$P(^DD(INDFN,tagSub,0),U),!
+12 ; debug
+13 DO DATA1(INDFN,tagSub,INDF)
+14 QUIT
+15 ;
DATA1(inFile,inField1,inField2) ; [Private] OSE/SMH *10001* - XINDEX data in M fields in the file
+1 ; If inFile and inField1 are passed, iField1 is assumed to be an M code field
+2 ; If inField1 and inField2 are both passed, inField1 is the tag, and inField2 is the routine.
+3 ; First, find the data storage location in the file/subfile
+4 NEW spec1,spec2
+5 NEW sub1,sub2
+6 NEW piece1,piece2
+7 NEW eStart1,eEnd1,eStart2,eEnd2
+8 ;
+9 ; Field 1
+10 SET spec1=$PIECE(^DD(inFile,inField1,0),U,4)
+11
*** ERROR ***
SET sub1=$p(spec1,";",1)
+12
*** ERROR ***
SET piece1=$p(spec1,";",2)
+13
*** ERROR ***
IF $e(piece1)="E"
