- %INDX10 ;ISC/GRK - assemble DD executable code ;1/9/95 12:16
- ;;7.3;TOOLKIT;;Apr 25, 1995
- ASKP K DIC S DIC="^DIC(9.4,",DIC(0)="AEQMZ" D ^DIC S DA=+Y Q
- START W !,"The package 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
- D ^%INDX11,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
- INSERT ;Find executable code in this DD
- I '$D(^DD(INDFN)) W !,"File # ",INDFN," is missing !",*7 Q
- S ^UTILITY($J,INDRN)="",NRO=NRO+1 W !,INDFN," ",$O(^DD(INDFN,0,"NM",0))
- S INDLC=0,INDC=INDRN_" ;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
- 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 ^(R)
- S RN=R F J=0:0 S RN=$O(^UTILITY($J,RN)) Q:RN=""!(RN'?@("1"""_R_"""1N.N")) K ^(RN)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HZINDX10 3540 printed Feb 19, 2025@00:08:58 Page 2
- %INDX10 ;ISC/GRK - assemble DD executable code ;1/9/95 12:16
- +1 ;;7.3;TOOLKIT;;Apr 25, 1995
- ASKP KILL DIC
- SET DIC="^DIC(9.4,"
- SET DIC(0)="AEQMZ"
- DO ^DIC
- SET DA=+Y
- QUIT
- START WRITE !,"The package 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
- +2 DO ^%INDX11
- 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
- +3 QUIT
- INSERT ;Find executable code in this DD
- +1 IF '$DATA(^DD(INDFN))
- WRITE !,"File # ",INDFN," is missing !",*7
- QUIT
- +2 SET ^UTILITY($JOB,INDRN)=""
- SET NRO=NRO+1
- WRITE !,INDFN," ",$ORDER(^DD(INDFN,0,"NM",0))
- +3 SET INDLC=0
- SET INDC=INDRN_" ;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
- 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
- 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 QUIT
- XREFS ;Node 3 is don't delete comment.
- if ('$DATA(^(G))#2)!(G=3)
- QUIT
- +1 SET INDC=INDF_"XRF"_INDXRF_$SELECT(G=1:"S",G=2:"K",1:"n"_G)_" ; "_$SELECT(G<2:"SET",G<3:"KILL",1:"OVERFLOW")_" LOGIC FOR '"_$SELECT(C]"":C,1:INDXRF)_"' XREF"
- SET INDX=^(G)
- DO ADD
- +2 QUIT
- ADD ;Put code in UTILITY for processing
- +1 SET INDLC=INDLC+1
- SET ^UTILITY($JOB,1,INDRN,0,INDLC,0)=INDC
- IF INDX]""
- SET INDLC=INDLC+1
- SET ^UTILITY($JOB,1,INDRN,0,INDLC,0)=" "_INDX
- +2 QUIT
- PUSH SET INDL=INDL+1
- FOR A="INDFN","INDF","INDLC","INDRN"
- SET @(A_"(INDL)")=@A
- +1 SET INDFN=+$PIECE(^DD(INDFN,INDF,0),"^",2)
- SET INDRN="|dd"_INDFN
- SET (INDLC,INDF)=0
- +2 QUIT
- POP FOR A="INDFN","INDF","INDLC","INDRN"
- SET @A=@(A_"(INDL)")
- +1 SET INDL=INDL-1
- QUIT
- REMCOMP ;Remove compiled template routines from selected list
- +1 SET %="dd"
- +2 FOR J=1:1
- SET %=$ORDER(^UTILITY($JOB,%))
- if %'?1"|dd".NP
- QUIT
- SET INDFN=+$EXTRACT(%,4,999)
- IF '$DATA(^DD(INDFN,0,"UP"))
- FOR F="^DIE(","^DIPT("
- SET F1=F_"""F"_INDFN_""","
- SET %1=""
- FOR J=0:0
- SET %1=$ORDER(@(F1_"%1)"))
- if %1=""
- QUIT
- FOR %2=0:0
- SET %2=$ORDER(@(F1_"%1,%2)"))
- if %2'>0
- QUIT
- DO P
- +3 QUIT
- P IF $DATA(@(F_"%2,0)"))
- SET R=$EXTRACT($SELECT($DATA(^("ROU")):^("ROU"),$DATA(^("ROUOLD")):^("ROUOLD"),1:""),2,999)
- if R=""
- QUIT
- +1 IF $DATA(^UTILITY($JOB,R))
- KILL ^(R)
- +2 SET RN=R
- FOR J=0:0
- SET RN=$ORDER(^UTILITY($JOB,RN))
- if RN=""!(RN'?@("1"""_R_"""1N.N"))
- QUIT
- KILL ^(RN)
- +3 QUIT
