source: FOIAVistA/tag/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XINDX10.m@ 1605

Last change on this file since 1605 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.7 KB
Line 
1XINDX10 ;ISC/GRK - assemble DD executable code ;11/12/2002 11:40
2 ;;7.3;TOOLKIT;**20,27,66,68**;Apr 25, 1995
3ASK ;Ask for Build file, Package file.
4 N X,Y,P,V,RN S DA=0,INP(11)=""
5 K DIC I $D(^DD(9.6,0)) S Y=$$BUILD^XTRUTL1
6 I Y>0 D Q
7 . S INP(10)=9.6,DA=+Y,X=$P(Y,"^",2),V=$$VER^XTRUTL1(X)
8 . S INP(11)="I $P(LIN,"";"",3)'["""_V_""" D E^XINDX1(44)",INP(11.1)=V
9 . I $L($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)
10 . Q
11 K DIC I $D(^DD(9.4,0)) S DIC="^DIC(9.4,",DIC(0)="AEQMZ" D ^DIC S INP(10)=9.4,DA=+Y Q
12 ;
13START I INP(10)=9.4 G PKG
14 ;Get routines and other code from BUILD.
15 W !,"The BUILD file Data Dictionaries are being processed.",!
16 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
17 G NEXT
18PKG W !,"The package file Data Dictionaries are being processed.",!
19 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
20NEXT 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
21 Q
22XPD ;Check if Full/Partial DD
23 N IND1,IND222,J2,J3 S IND222=$G(^XPD(9.6,DA,4,J,222))
24 S (INDF,INDL)=0 I $P(IND222,"^",3)="f" K IND222 D INSERT Q
25 ;Each entry at the J2 level is a new file/sub-file.
26 F J2=0:0 S J2=$O(^XPD(9.6,DA,4,J,2,J2)) Q:J2'>0 S IND1=^(J2,0) D
27 . S INDFN=J2,INDRN="|dd"_INDFN,INDLC=0 Q:'$$HDR()
28 . ;Each J3 is a field in the file.
29 . 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
30 . S ^UTILITY($J,1,INDRN,0,0)=INDLC
31 . Q
32 Q
33HDR() ;Display Header and start faux routine build
34 I '$D(^DD(INDFN)) W !,"File # ",INDFN," is missing !",$C(7) Q 0
35 S ^UTILITY($J,INDRN)="",NRO=NRO+1 W !,INDFN," ",$O(^DD(INDFN,0,"NM",0))
36 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
37 Q 1
38INSERT ;Find executable code in this DD
39 Q:'$$HDR
40ID 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
41W I $D(^DD(INDFN,0,"W"))#2 S INDX=^("W"),INDC="W ; 'W' code ??" D ADD
42FLD S INDF=$O(^DD(INDFN,INDF)) I INDF>0 D STRIP W "." G FLD
43 S ^UTILITY($J,1,INDRN,0,0)=INDLC Q
44STRIP ;
45 S A=$P(^DD(INDFN,INDF,0),"^",2) I A D PUSH,INSERT,POP Q
46 I A'["W",A'["S" S INDX=$P(^(0),"^",5,99),INDC=INDF_" ; "_$P(^(0),"^",1) D ADD
47 I $D(^DD(INDFN,INDF,2))#2 S INDC=INDF_"OT ; OUTPUT TRANSFORM CODE",INDX=^(2) D ADD
48 I $D(^DD(INDFN,INDF,4))#2 S INDC=INDF_"HELP ; EXECUTABLE HELP CODE",INDX=^(4) D ADD
49 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
50 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
51 I $D(^DD(INDFN,INDF,"AX"))#2 S INDC=INDF_"AX ; EXECUTABLE AUDIT CHECK CODE",INDX=^("AX") D ADD
52 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
53 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
54 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
55 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
56 Q
57XREFS Q:('$D(^(G))#2)!(G=3) ;Node 3 is don't delete comment.
58 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
59 Q
60ADD ;Put code in UTILITY for processing
61 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
62 Q
63PUSH S INDL=INDL+1 F A="INDFN","INDF","INDLC","INDRN" S @(A_"(INDL)")=@A
64 S INDFN=+$P(^DD(INDFN,INDF,0),"^",2),INDRN="|dd"_INDFN,(INDLC,INDF)=0
65 Q
66POP F A="INDFN","INDF","INDLC","INDRN" S @A=@(A_"(INDL)")
67 S INDL=INDL-1 Q
68REMCOMP ;Remove compiled template routines from selected list
69 S %="|dd"
70 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
71 Q
72P I $D(@(F_"%2,0)")) S R=$E($S($D(^("ROU")):^("ROU"),$D(^("ROUOLD")):^("ROUOLD"),1:""),2,999)
73 Q:R=""
74 I $D(^UTILITY($J,R)) K ^UTILITY($J,R)
75 S RN=R F J=0:0 S RN=$O(^UTILITY($J,RN)) Q:RN=""!(RN'?@("1"""_R_"""1N.N")) K ^UTILITY($J,RN)
76 Q
Note: See TracBrowser for help on using the repository browser.