source: FOIAVistA/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIKCBLD.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 5.6 KB
Line 
1DIKCBLD ;SFISC/MKO-AUTOBUILD A ROUTINE THAT CALLS CREIXN^DDMOD ;11:30 AM 9 Jul 2002
2 ;;22.0;VA FileMan;**95**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5MAIN ;Main process
6 N DIKCRTN,DIKCNMSP,DIKCITL,DIKCXR,%
7 ;
8 ;Check save code
9 D:'$D(DISYS) OS^DII
10 I '$D(^DD("OS",DISYS,"ZS")) W $C(7),$$EZBLD^DIALOG(820) Q
11 ;
12 ;Gather information from user
13Q1 S DIKCRTN=$$ASKRTN Q:U[DIKCRTN
14Q2 S DIKCITL=$$ASKITL Q:DIKCITL[U I DIKCITL="" W ! G Q1
15Q3 S DIKCNMSP=$$ASKNMSP Q:DIKCNMSP[U I DIKCNMSP="" W ! G Q2
16Q4 S DIKCXR=$$ASKXR() I 'DIKCXR W ! G Q3
17 ;
18 ;Build and save routine
19 D BUILD(DIKCRTN,DIKCITL,DIKCNMSP,DIKCXR)
20 D SAVE(DIKCRTN)
21 ;
22 ;Final message and clean up
23 W !!," Done!"
24 W !!," Be sure to edit the routine to fill in the missing details,"
25 W !," and to customize the call to CREIXN^DDMOD."
26 W !
27 K ^UTILITY($J)
28 Q
29 ;
30BUILD(DIKCRTN,DIKCITL,NS,XR) ;Build routine DIKCRTN
31 N CV
32 K ^UTILITY($J)
33 D AD(DIKCRTN_" ;xxxx/"_DIKCITL_"-CREATE NEW-STYLE XREF ;")
34 D AD(" ;;1.0")
35 D AD(" ;")
36 D AD(" N "_NS_"XR,"_NS_"RES,"_NS_"OUT")
37 D BC(NS,XR,"FILE",0,1)
38 D:$P($G(^DD("IX",XR,0)),U,8)="W" BC(NS,XR,"ROOT FILE",0,9)
39 D BC(NS,XR,"NAME",0,2)
40 D BC(NS,XR,"TYPE",0,4)
41 D BC(NS,XR,"USE",0,14)
42 D BC(NS,XR,"EXECUTION",0,6)
43 D BC(NS,XR,"ACTIVITY",0,7)
44 D BC(NS,XR,"SHORT DESCR",0,3)
45 D BCW(NS,XR,"DESCR",.1)
46 D:$P($G(^DD("IX",XR,0)),U,4)="MU"
47 . D BC(NS,XR,"SET",1)
48 . D BC(NS,XR,"KILL",2)
49 . D BC(NS,XR,"WHOLE KILL",2.5)
50 D BC(NS,XR,"SET CONDITION",1.4)
51 D BC(NS,XR,"KILL CONDITION",2.4)
52 ;
53 S CV=0 F S CV=$O(^DD("IX",XR,11.1,CV)) Q:'CV D
54 . N ON,TP,VAL
55 . S ON=$P($G(^DD("IX",XR,11.1,CV,0)),U) Q:'ON
56 . S TP=$P($G(^DD("IX",XR,11.1,CV,0)),U,2)
57 . I TP="F" D
58 .. S VAL=$P($G(^DD("IX",XR,11.1,CV,0)),U,4) Q:'VAL
59 .. D AD(" S "_NS_"XR(""VAL"","_ON_")="_VAL)
60 . E D
61 .. S VAL=$G(^DD("IX",XR,11.1,CV,1.5)) Q:VAL=""
62 .. D AD(" S "_NS_"XR(""VAL"","_ON_")="_$$QT(VAL))
63 . D BCC(NS,XR,CV,ON,"SUBSCRIPT",0,6)
64 . D BCC(NS,XR,CV,ON,"LENGTH",0,5)
65 . D BCC(NS,XR,CV,ON,"COLLATION",0,7)
66 . D BCC(NS,XR,CV,ON,"LOOKUP PROMPT",0,8)
67 . D:TP="F"
68 .. D BCC(NS,XR,CV,ON,"XFORM FOR STORAGE",2)
69 .. D BCC(NS,XR,CV,ON,"XFORM FOR LOOKUP",4)
70 .. D BCC(NS,XR,CV,ON,"XFORM FOR DISPLAY",3)
71 ;
72 D AD(" D CREIXN^DDMOD(."_NS_"XR,""SW"",."_NS_"RES,"""_NS_"OUT"")")
73 D AD(" Q")
74 ;
75 Q
76BC(NS,XR,SUB,ND,PC) ;Build code that sets an array element
77 N VAL
78 I $G(PC)="" S VAL=$G(^DD("IX",XR,ND))
79 E S VAL=$P($G(^DD("IX",XR,ND)),U,PC)
80 Q:VAL=""
81 D AD(" S "_NS_"XR("""_SUB_""")="_$$QT(VAL))
82 Q
83 ;
84BCW(NS,XR,SUB,ND) ;Build code that sets array for wp field
85 N I,VAL
86 S I=0 F S I=$O(^DD("IX",XR,ND,I)) Q:'I D
87 . S VAL=$G(^DD("IX",XR,ND,I,0)) S:VAL="" VAL=" "
88 . D AD(" S "_NS_"XR("""_SUB_""","_I_")="_$$QT(VAL))
89 Q
90 ;
91BCC(NS,XR,CV,ON,SUB,ND,PC) ;Build code that sets an array element
92 N VAL
93 I $G(PC)="" S VAL=$G(^DD("IX",XR,11.1,CV,ND))
94 E S VAL=$P($G(^DD("IX",XR,11.1,CV,ND)),U,PC)
95 Q:VAL=""
96 D AD(" S "_NS_"XR(""VAL"","_ON_","""_SUB_""")="_$$QT(VAL))
97 Q
98 ;
99QT(X) ;Return string X quoted, if noncanonic
100 Q:$G(X)="" """"""
101 Q:X=+$E($P(X,"E"),1,15) X
102 S X(X)="",X=$Q(X(""))
103 Q $E(X,3,$L(X)-1)
104 ;
105AD(X) ;Add a routine line to ^UTILITY
106 N LN
107 S LN=$O(^UTILITY($J,0," "),-1)+1
108 S ^UTILITY($J,0,LN)=X
109 Q
110 ;
111SAVE(DIKCRTN) ;Save routine DIKCRTN
112 N X,%Y
113 S ^UTILITY($J,0,1)=^UTILITY($J,0,1)_$$NOW
114 S X=DIKCRTN X ^DD("OS",DISYS,"ZS")
115 W !!,$$EZBLD^DIALOG(8025,DIKCRTN)
116 Q
117 ;
118ASKRTN() ;Prompt for routine name; return ^ if timeout, null, or ^
119 N DIR,X,Y,DIROUT,DIRUT,DTOUT,DUOUT
120 S DIR(0)="FO^1:8^K:X?.E1.C.E!'(X?1""%""1.7AN!(X?1A1.7AN)) X"
121 S DIR("A")="Routine name"
122 S DIR("?",1)=" Enter the name of the routine, without the leading up-arrow, that"
123 S DIR("?",2)=" should be built."
124 S DIR("?",3)=""
125 S DIR("?",4)=" Answer must be 1-8 characters in length. It must begin with % or a"
126 S DIR("?")=" letter, followed by a combination of letters and numbers."
127 F D Q:$G(DIKCRTN)]""
128 . D ^DIR I $D(DIRUT) S DIKCRTN=U Q
129 . S DIKCRTN=X
130 . X ^%ZOSF("TEST") E Q
131 . Q:$$ASKREPL(DIKCRTN)
132 . S DIKCRTN=""
133 Q $G(DIKCRTN)
134 ;
135ASKREPL(DIKCRTN) ;Ask whether to replace the existing routine
136 N DIR,X,Y,DIROUT,DIRUT,DTOUT,DUOUT
137 S DIR(0)="YO"
138 S DIR("A")=" Do you wish to replace routine "_DIKCRTN
139 S DIR("B")="NO"
140 S DIR("?")=" Answer yes if you wish to replace routine "_DIKCRTN_" with a new version."
141 W !!," Routine "_DIKCRTN_" already exists."
142 D ^DIR W !
143 Q Y
144 ;
145ASKITL() ;Ask for programmer initials
146 N DIR,X,Y,DIROUT,DIRUT,DTOUT,DUOUT
147 S DIR(0)="FO^1:15"
148 S DIR("A")="Programmer initials"
149 S DIR("?",1)=" Enter your initials, which will appear on the first line of the"
150 S DIR("?")=" routine."
151 D ^DIR
152 Q Y
153 ;
154ASKNMSP() ;Prompt for a namespace
155 N DIR,X,Y,DIROUT,DIRUT,DTOUT,DUOUT
156 S DIR(0)="FO^1:4^K:X?.E1.C.E!'(X?1""%""1.3AN!(X?1A1.3AN)) X"
157 S DIR("A")="Namespace to use for local variables"
158 S DIR("?",1)=" All variables used in the generated routine will start with the namespace"
159 S DIR("?",2)=" you choose."
160 S DIR("?",3)=""
161 S DIR("?",4)=" Answer must be 1-4 characters in length. It must begin with % or a"
162 S DIR("?")=" letter, followed by a combination of letters and numbers."
163 D ^DIR
164 Q Y
165 ;
166ASKXR() ;Prompt for file/xref
167 N DIKCCNT,DIKCROOT,DIKCTOP,DIKCFILE,DDS1,D,DIC,X,Y
168 S DDS1="CROSS-REFERENCE FROM" D W^DICRW Q:Y<0 ""
169 S DIKCTOP=+$P($G(@(DIC_"0)")),U,2) Q:'DIKCTOP ""
170 S DIKCFILE=$$SUB^DIKCU(DIKCTOP)
171 ;
172 D GETXR^DIKCUTL2(DIKCFILE,.DIKCCNT)
173 W ! D LIST^DIKCUTL2(.DIKCCNT)
174 Q $$CHOOSE^DIKCUTL2(.DIKCCNT,"to build a routine for")
175 ;
176NOW() ;Return current time in external form
177 N %,%I,%H,AP,HR,MIN,MON,TIM,X
178 D NOW^%DTC
179 S TIM=$P(%,".",2)
180 S HR=$E(TIM,1,2)
181 S AP=$S(HR<12:"AM",1:"PM")
182 S HR=$S(HR<13:+HR,1:HR#12)
183 S MIN=$E(TIM_"0000",3,4)
184 ;
185 S MON=$P("Jan^Feb^Mar^Apr^May^Jun^Jul^Aug^Sep^Oct^Nov^Dec",U,%I(1))
186 Q HR_":"_MIN_" "_AP_" "_%I(2)_" "_MON_" "_(%I(3)+1700)
Note: See TracBrowser for help on using the repository browser.