source: FOIAVistA/trunk/r/CLINICAL_CASE_REGISTRIES-ROR/RORUTL06.m@ 649

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

initial load of FOIAVistA 6/30/08 version
File size: 8.6 KB
Line 
1RORUTL06 ;HCIOFO/SG - DEVELOPER ENTRY POINTS ; 11/20/05 5:09pm
2 ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
3 ;
4 N DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
5 W !,"CLINICAL CASE REGISTRIES DEVELOPER'S UTILITIES"
6 S X=""
7 S X=X_";M:Metadata definitions"
8 S X=X_";V:Verify registry definition"
9 S X=X_";P:Prepare for KIDS"
10 S DIR(0)="SO^"_$P(X,";",2,999)
11 D ^DIR W ! Q:$D(DIRUT)
12 G PRTMDE:Y="M",VERIFY:Y="V",DISTPREP:Y="P"
13 Q
14 ;
15 ;***** VERIFIES REGISTRY DEFINITION
16VERIFY ;
17 N RORERRDL ; Default error location
18 N RORERROR ; Error processing data
19 N RORLOG ; Log parameters
20 N RORPARM ; Application parameters
21 ;
22 N RC,REGLST,REGNAME,TMP
23 W !,"REGISTRY DEFINITION VERIFIER",!
24 D KILL^XUSCLEAN,INIT^RORUTL01("ROR")
25 S RORPARM("DEBUG")=2
26 S RORPARM("ERR")=1
27 S RORPARM("LOG")=1
28 F TMP=1:1:6 S RORPARM("LOG",TMP)=1
29 D CLEAR^RORERR("START^RORUTL06")
30 ;--- Select registries
31 Q:$$SELREG^RORUTL07(.REGLST)'>0
32 ;--- Validate registry update defintion
33 S RC=$$UPDDEF(.REGLST) G:RC<0 ERROR
34 ;--- Validate data extraction defintion
35 S RC=$$EXTDEF(.REGLST) G:RC<0 ERROR
36 ;--- Cleanup
37 D INIT^RORUTL01("ROR")
38 Q
39 ;
40 ;***** PREPARES THE REGISTRY FOR KIDS DISTRIBUTION
41DISTPREP ;
42 N RORERRDL ; Default error location
43 N RORERROR ; Error processing data
44 N RORFULL ; Full installation (backpull, population, etc.)
45 N RORPARM ; Application parameters
46 ;
47 N IENS,FLD,FULL,RC,REGIEN,REGNAME,RORFDA,RORMSG
48 N DA,DIR,DIRUT,DTOUT,DUOUT,X,Y
49 W !,"REGISTRY PREPARATION FOR KIDS DISTRIBUTION",!
50 D KILL^XUSCLEAN
51 S RORPARM("ERR")=1
52 D CLEAR^RORERR("DISTPREP^RORUTL06")
53 ;--- Select a registry
54 S RC=$$SELREG^RORUTL18(.REGNAME) G:RC<0 ERROR
55 Q:RC'>0 S REGIEN=RC
56 ;--- Select the type of distribution
57 K DIR S DIR(0)="S^I:Installation;U:Update",DIR("B")="Update"
58 S DIR("A")="Slect the type of distribution"
59 D ^DIR Q:$D(DIRUT) W !
60 S RORFULL=(Y="I")
61 ;--- Request a confirmation
62 K DIR S DIR(0)="Y",DIR("B")="NO"
63 S DIR("A",1)="Some fields of the '"_REGNAME_"' registry parameters"
64 S DIR("A",2)="will be cleared to prepare them for KIDS distribution."
65 S DIR("A")="Do you really want to do this"
66 D ^DIR Q:'$G(Y) W !
67 ;--- Clear Registry parameters (single-valued)
68 S IENS=REGIEN_","
69 F FLD=1,2,5,13,19.1,19.2,19.3,21.01,21.04,21.05 D
70 . S RORFDA(798.1,IENS,FLD)="@"
71 D FILE^DIE(,"RORFDA","RORMSG")
72 G:$$DBS^RORERR("RORMSG",-9,,,798.1,IENS) ERROR
73 ;--- Clear Registry parameters (multiples)
74 S IENS=","_REGIEN_","
75 G:$$CLEAR^RORUTL05(798.11,IENS)<0 ERROR ; LOG EVENT (8.1)
76 G:$$CLEAR^RORUTL05(798.114,IENS)<0 ERROR ; NOTIFICATION (14)
77 G:$$CLEAR^RORUTL05(798.122,IENS)<0 ERROR ; LAST BATCH CONTROL ID (22)
78 G:$$CLEAR^RORUTL05(798.128,IENS)<0 ERROR ; LOCAL LAB TEST (28)
79 G:$$CLEAR^RORUTL05(798.129,IENS)<0 ERROR ; LOCAL DRUG (29)
80 G:$$CLEAR^RORUTL05(798.12,IENS)<0 ERROR ; REPORT STATS (30)
81 ;--- Registry-specific data
82 I REGNAME="VA HEPC" G:$$HEPC(REGIEN)<0 ERROR
83 I REGNAME="VA HIV" G:$$HIV(REGIEN)<0 ERROR
84 ;--- Clean the ROR LOCAL FIELD file (#799.53)
85 G:$$LOCFLDS()<0 ERROR
86 ;--- Success
87 W !,"Registry parameters are ready for distribution."
88 Q
89 ;
90 ;***** DISPLAYS THE ERRORS
91ERROR ;
92 D DSPSTK^RORERR()
93 Q
94 ;
95 ;***** VALIDATES DATA EXTRACTION DEFINITION
96 ;
97 ; .REGLST Reference to a local array containing
98 ; registry names as subscripts
99 ;
100 ; Return Values:
101 ; <0 Error Code
102 ; 0 Ok
103 ;
104EXTDEF(REGLST) ;
105 N RORERRDL ; Default error location
106 N ROREXT ; Data extraction descriptor
107 N RORHL ; HL7 variables
108 N RORLRC ; List of codes of Lab results to be extracted
109 ;
110 N RC
111 W !,"DATA EXTRACTION DEFINITION",!
112 D CLEAR^RORERR("UPDDEF^RORUTL06")
113 S RC=$$PREPARE^ROREXPR(.REGLST)
114 D:RC'<0 DEBUG^ROREXTUT
115 Q RC
116 ;
117 ;***** HEPC-SPECIFIC PREPARATIONS
118HEPC(REGIEN) ;
119 N IENS,RORFDA,RORMSG
120 S IENS=(+REGIEN)_","
121 D:$G(RORFULL)
122 . S RORFDA(798.1,IENS,1)=2900101 ; REGISTRY UPDATED UNTIL
123 . S RORFDA(798.1,IENS,2)=2850101 ; DATA EXTRACTED UNTIL
124 S RORFDA(798.1,IENS,25)=1 ; ENABLE PROTOCOLS
125 D FILE^DIE(,"RORFDA","RORMSG")
126 Q $$DBS^RORERR("RORMSG",-9,,,798.1,IENS)
127 ;
128 ;***** HIV-SPECIFIC PREPARATIONS
129HIV(REGIEN) ;
130 N IENS,RORFDA,RORMSG
131 S IENS=(+REGIEN)_","
132 D:$G(RORFULL)
133 . S RORFDA(798.1,IENS,1)=2850101 ; REGISTRY UPDATED UNTIL
134 . S RORFDA(798.1,IENS,2)=2850101 ; DATA EXTRACTED UNTIL
135 S RORFDA(798.1,IENS,25)=1 ; ENABLE PROTOCOLS
136 D FILE^DIE(,"RORFDA","RORMSG")
137 Q $$DBS^RORERR("RORMSG",-9,,,798.1,IENS)
138 ;
139 ;***** CLEANS THE 'ROR LOCAL FIELD' FILE (#799.53)
140LOCFLDS() ;
141 N DA,DIK,ROOT
142 S DIK=$$ROOT^DILFD(799.53),ROOT=$$CREF^DILF(DIK)
143 S DA=0
144 F S DA=$O(@ROOT@(DA)) Q:DA'>0 D ^DIK
145 Q 0
146 ;
147 ;***** PRINTS THE DATA ELEMENT METADATA
148PRTMDE ;
149 N RORCOLS ; Lits of column descriptors
150 N RORERRDL ; Default error location
151 N RORERROR ; Error processing data
152 N RORLST ; List of files grouped by parents
153 N RORPAGE ; Current page number
154 N RORPARM ; Application parameters
155 N RORTTL ; Title of the report
156 ;
157 N DIR,DIRUT,DTOUT,DUOUT,MODE,TMP,X,Y
158 D KILL^XUSCLEAN
159 S (DDBDMSG,RORTTL)="METADATA OF THE DATA ELEMENTS"
160 W !,RORTTL,! S RORPARM("ERR")=1
161 D CLEAR^RORERR("PRTMDE^RORUTL06")
162 ;---Request report sort mode from user
163 S DIR(0)="S^H:Hierarhical;L:List of codes"
164 S DIR("A")="Sort mode",DIR("B")="List of codes"
165 D ^DIR Q:$D(DIRUT) S MODE=Y
166 ;--- Generate and print the report
167 I MODE="H" S RC=0 D
168 . N %ZIS,I,FILE,PARENT,ROOT,RORMSG
169 . S ROOT=$$ROOT^DILFD(799.2,,1),RORPAGE=0
170 . ;--- Load column descriptors
171 . F I=1:1 S TMP=$P($T(PRTMDEH+I),";;",2) Q:TMP="" D
172 . . S RORCOLS(I)=$TR($P(TMP,U,1,3)," ")_U_$P(TMP,U,4)
173 . ;--- Load file list
174 . S FILE=0,RC=0
175 . F S FILE=$O(@ROOT@(FILE)) Q:FILE'>0 D Q:RC<0
176 . . S PARENT=+$$GET1^DIQ(799.2,FILE_",",1,"I",,"RORMSG")
177 . . I $G(DIERR) D Q
178 . . . S RC=$$DBS^RORERR("RORMSG",-9,,,799.2,FILE_",")
179 . . S RORLST(PARENT,FILE)=""
180 . Q:RC<0
181 . ;--- Print the report
182 . S %ZIS("B")=""
183 . D ^%ZIS Q:$G(POP) U IO
184 . S RC=$$PRTMDEH() S:RC'<0 RC=$$PRTMDE1(0,1)
185 . D ^%ZISC
186 E S RC=$$PRTMDE2()
187 G:RC<0 ERROR
188 Q
189 ;
190 ;***** PRINTS A LEVEL OF THE "FILE-PROCESSING TREE"
191 ;
192 ; PARENT Parent file number
193 ; LEVEL Number of the current level in the tree
194 ;
195 ; Return Values:
196 ; <0 Error Code
197 ; 0 Ok
198 ;
199PRTMDE1(PARENT,LEVEL) ;
200 N FIELDS,FILE,FLD,I,IENS,IR,L,RORBUF,RORMSG
201 S FIELDS="@;.01E;.02I;1I;2E;4I;4.1;4.2;6I"
202 ;---
203 S FILE="",RC=0
204 F S FILE=$O(RORLST(PARENT,FILE)) Q:FILE="" D Q:RC<0
205 . ;--- Load descriptors of the data elements
206 . K RORBUF S IENS=","_FILE_","
207 . D LIST^DIC(799.22,IENS,FIELDS,,,,,"B",,,"RORBUF","RORMSG")
208 . ;--- Print header (if necessary) and file number
209 . I ($Y+5)>IOSL S RC=$$PRTMDEH() Q:RC<0
210 . D PRTMDEL(LEVEL-1),PRTMDEL(LEVEL-1,FILE)
211 . ;--- Print data element descriptors
212 . S IR="",RC=0
213 . F S IR=$O(RORBUF("DILIST","ID",IR)) Q:IR="" D Q:RC<0 W !
214 . . I ($Y+5)>IOSL S RC=$$PRTMDEH() Q:RC<0
215 . . D:IR>1 PRTMDEL(LEVEL,"")
216 . . S I=""
217 . . F S I=$O(RORCOLS(I)) Q:I="" D
218 . . . S FLD=+$P(RORCOLS(I),U,2) Q:FLD'>0
219 . . . S L=+$P(RORCOLS(I),U,3) S:L'>0 L=999
220 . . . W ?(+RORCOLS(I)),$E($G(RORBUF("DILIST","ID",IR,FLD)),1,L)
221 . Q:RC<0
222 . S:$D(RORLST(FILE))>1 RC=$$PRTMDE1(FILE,LEVEL+1)
223 Q $S(RC<0:RC,1:0)
224 ;
225 ;***** PRINTS A TABLE OF DATA ELEMENTS
226PRTMDE2() ;
227 N BY,DHD,FR,L,DIC,FLDS,TO
228 S L=0,DIC=799.2,DHD=RORTTL
229 S BY="[ROR DATA ELEMENTS]",FLDS="[ROR DATA ELEMENTS]"
230 D EN1^DIP
231 Q 0
232 ;
233 ;***** PRINTS A HEADER OF THE DATA ELEMENT REPORT
234 ; X Field Width Title
235PRTMDEH() ;
236 ;; 0^ ^ ^File
237 ;; 22^ .01^ 25^Data Name
238 ;; 49^ .02^ ^Code
239 ;; 55^ 2 ^ ^Req
240 ;; 60^ 1 ^ ^API
241 ;; 65^ 6 ^ ^Field Number
242 ;; 82^ 4 ^ ^VT
243 ;; 86^ 4.1 ^ 20^External
244 ;;108^ 4.2 ^ 20^Internal
245 ;
246 N DIR,DIRUT,DTOUT,DUOUT,I,X,Y
247 I RORPAGE,$E(IOST,1,2)="C-" D Q:'Y $S(Y="":-72,1:-71)
248 . S DIR(0)="E" D ^DIR
249 W:RORPAGE!($E(IOST,1,2)="C-") @IOF
250 S RORPAGE=RORPAGE+1,I="" W RORTTL,!
251 F S I=$O(RORCOLS(I)) Q:I="" W ?(+RORCOLS(I)),$P(RORCOLS(I),U,4)
252 S X="",$P(X,"-",IOM)=""
253 W !,X,!
254 Q 0
255 ;
256 ;***** PRINTS THE LEVEL INDICATOR
257 ;
258 ; N Number of dots in the indicator
259 ; [FILE] File number
260 ;
261PRTMDEL(N,FILE) ;
262 N I W:$X>0 ! F I=1:1:N W ". "
263 W:$D(FILE) FILE W:'$D(FILE) !
264 Q
265 ;
266 ;***** VALIDATES REGISTRY UPDATE DEFINITION
267 ;
268 ; .REGLST Reference to a local array containing
269 ; registry names as subscripts
270 ;
271 ; Return Values:
272 ; <0 Error Code
273 ; 0 Ok
274 ;
275UPDDEF(REGLST) ;
276 N RORERRDL ; Default error location
277 N RORLRC ; List of Lab result codes to check
278 N RORUPD ; Update descriptor
279 N RORUPDPI ; Closed root of the temporary storage
280 N RORVALS ; Calculated values
281 ;
282 N RC
283 W !,"REGISTRY UPDATE DEFINITION",!
284 D CLEAR^RORERR("UPDDEF^RORUTL06")
285 S RORUPDPI=$NA(^TMP("RORUPD",$J))
286 S RC=$$PREPARE^RORUPR(.REGLST)
287 D:RC'<0 DEBUG^RORUPDUT
288 Q RC
Note: See TracBrowser for help on using the repository browser.