source: FOIAVistA/trunk/r/CLINICAL_CASE_REGISTRIES-ROR/RORPUT01.m@ 770

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

initial load of FOIAVistA 6/30/08 version
File size: 7.1 KB
Line 
1RORPUT01 ;HCIOFO/SG - EDIT LOINC AND DRUG CODE MULTIPLES ; 5/19/06 11:48am
2 ;;1.5;CLINICAL CASE REGISTRIES;**1**;Feb 17, 2006;Build 24
3 ;
4 Q
5 ;
6 ;***** ADDS THE RECORDS TO THE MULTIPLE
7 ;
8 ; REGIEN Registry IEN
9 ; SUBFILE Subfile number
10 ; LSTREF Reference to a list or the list itself (see the
11 ; $$COMPNEXT^RORPUT01 function for more details).
12 ;
13 ; Return Values:
14 ; <0 Error code
15 ; 0 Ok
16 ;
17ADD(REGIEN,SUBFILE,LSTREF) ;
18 N BUF,IENS,ITEM,LI,NEXT,RC,RORFDA,RORMSG,TLI
19 S NEXT=$$COMPNEXT(LSTREF) Q:NEXT<0 NEXT
20 S IENS="?+1,"_(+REGIEN)_",",RC=0
21 F TLI=1:1 X NEXT Q:$G(BUF)'[";;" D Q:RC<0
22 . S BUF=$P(BUF,";;",2)
23 . D MES^RORKIDS(BUF)
24 . S BUF=$TR(BUF," ")
25 . F LI=1:1 S ITEM=$P(BUF,",",LI) Q:ITEM="" D Q:RC<0
26 . . S RORFDA(SUBFILE,IENS,.01)=ITEM
27 . . D UPDATE^DIE(,"RORFDA",,"RORMSG")
28 . . S:$G(DIERR) RC=$$DBS^RORERR("RORMSG",-9,,,SUBFILE,IENS)
29 Q RC
30 ;
31 ;***** RESTORES THE CDC DEFINITION
32 ;
33 ; Return Values:
34 ; <0 Error code
35 ; 0 Ok
36 ;
37CDCDEF() ;
38 N RC,RESULTS,RORBUF
39 D BMES^RORKIDS("Restoring the CDC definition...")
40 ;--- Restore the definition from the transport global
41 M RORBUF=@XPDGREF@("RORCDCDEF")
42 S RORBUF="HIV CDC Form Template"
43 D SETPARM^RORRP038(.RESULTS,"ICRCDCDEF","PKG",.RORBUF)
44 Q:$G(RESULTS(0))<0 +RESULTS(0)
45 ;--- Success
46 D MES^RORKIDS("The definition has been restored successfully.")
47 Q 0
48 ;
49 ;***** COMPILES THE 'NEXT' LOGIC
50 ;
51 ; PARAM Parameter defining the list of codes. It should be
52 ; either a list of codes separated by commas or a full
53 ; reference (TAG^ROUTINE) to a routine label after
54 ; which the list is located. In the latter case, the
55 ; list itself should look like this:
56 ;
57 ; ;
58 ; ;***** SHORT DESCRIPTION OF THE LIST
59 ; LABEL ;
60 ; ;; Code1, Code2, ...
61 ; ;; CodeN, ...
62 ; ;
63 ;
64 ; There should be at least one line that does not
65 ; contain ";;" after the list (or no lines at all).
66 ;
67 ; Return Values:
68 ; <0 Error code
69 ; "" The list is empty
70 ; '="" A string that should be XECUTE'd to get the next
71 ; buffer with the list data
72 ;
73COMPNEXT(PARAM) ;
74 N I,N,NEXT,RC Q:PARAM?." " ""
75 ;--- Reference to a routine label
76 I PARAM?1.8UN1"^"1.8UN D Q NEXT
77 . S NEXT="S BUF=$T("_$P(PARAM,U)_"+TLI"_U_$P(PARAM,U,2)_")"
78 ;--- List of codes separated by commas
79 S N=$L(PARAM,","),RC=0
80 F I=1:1:N I '($P(PARAM,",",I)?." "1.N." ") S RC=-88 Q
81 I RC<0,I=N S:$P(PARAM,",",N)?." " RC=0,N=N-1
82 I N>0,RC'<0 D Q NEXT
83 . S NEXT="S BUF=$P("""_";;"_$P(PARAM,",",1,N)_""",U,TLI)"
84 ;--- Invalid parameter
85 Q $$ERROR^RORERR(-88,,,,"List of Codes",PARAM)
86 ;
87 ;***** ADDS ITEMS TO 'EXTRACTED RESULT' MULTIPLE OF FILE #798.1
88 ;
89 ; [RORREG] Registry IEN and registry name separated by the '^'
90 ; (RegistryIEN^RegistryName).
91 ;
92 ; [RORLNCAD] Either a list of LOINC codes (without check digits)
93 ; separated by commas or a full reference (TAG^ROUTINE)
94 ; to a routine label after which the list is located.
95 ;
96 ; All spaces are removed from the lines of the list.
97 ; See the $$COMPNEXT^RORPUT01 function for more
98 ; details.
99 ;
100 ; If some of these parameters are omitted or equal to an empty
101 ; strings, their values must be defined as the RORPARM("KIDS")
102 ; sub-nodes of the same name.
103 ;
104 ; Return Values:
105 ; <0 Error code
106 ; 0 Ok
107 ;
108LOINCADD(RORREG,RORLNCAD) ;
109 N RC
110 D BMES^RORKIDS("Adding new LOINC codes to the EXTRACTED RESULT multiple...")
111 ;--- Get the parameters
112 S:'$G(RORREG) RORREG=$$PARAM^RORKIDS("RORREG")
113 S:$G(RORLNCAD)="" RORLNCAD=$$PARAM^RORKIDS("RORLNCAD")
114 ;--- Add new LOINC codes
115 S RC=$$ADD(+RORREG,798.112,RORLNCAD) Q:RC<0 RC
116 ;--- Success
117 D MES^RORKIDS("The LOINC list has been updated successfully.")
118 Q 0
119 ;
120 ;***** REMOVES ITEMS FROM 'EXTRACTED RESULT' MULTIPLE OF FILE #798.1
121 ;
122 ; [RORREG] Registry IEN and registry name separated by the '^'
123 ; (RegistryIEN^RegistryName).
124 ;
125 ; [RORLNCRM] Either a list of LOINC codes (without check digits)
126 ; separated by commas or a full reference (TAG^ROUTINE)
127 ; to a routine label after which the list is located.
128 ;
129 ; All spaces are removed from the lines of the list.
130 ; See the $$COMPNEXT^RORPUT01 function for more
131 ; details.
132 ;
133 ; If some of these parameters are omitted or equal to an empty
134 ; strings, their values must be defined as the RORPARM("KIDS")
135 ; sub-nodes of the same name.
136 ;
137 ; Return Values:
138 ; <0 Error code
139 ; 0 Ok
140 ;
141LOINCREM(RORREG,RORLNCRM) ;
142 N BUF,DA,DIK,IENS,IR,LCI,LOINC,NEXT,RC,RORBUF,RORMSG,TLI
143 D BMES^RORKIDS("Removing obsolete codes from the EXTRACTED RESULT multiple...")
144 ;--- Get the parameters
145 S:'$G(RORREG) RORREG=$$PARAM^RORKIDS("RORREG")
146 S:$G(RORLNCRM)="" RORLNCRM=$$PARAM^RORKIDS("RORLNCRM")
147 ;--- Delete unnecessary LOINC codes
148 S RC=$$REMOVE(+RORREG,798.112,RORLNCRM) Q:RC<0 RC
149 ;--- Success
150 D MES^RORKIDS("The LOINC list has been updated successfully.")
151 Q 0
152 ;
153 ;***** REMOVES THE RECORDS FROM THE MULTIPLE
154 ;
155 ; REGIEN Registry IEN
156 ; SUBFILE Subfile number
157 ; LSTREF Reference to a list or the list itself (see the
158 ; $$COMPNEXT^RORPUT01 function for more details).
159 ;
160 ; Return Values:
161 ; <0 Error code
162 ; 0 Ok
163 ;
164REMOVE(REGIEN,SUBFILE,LSTREF) ;
165 N BUF,DA,DIK,IENS,IR,ITEM,LI,NEXT,RC,RORBUF,RORMSG,TLI
166 S NEXT=$$COMPNEXT(LSTREF) Q:NEXT<0 NEXT
167 S IENS=","_(+REGIEN)_",",RC=0
168 F TLI=1:1 X NEXT Q:$G(BUF)'[";;" D Q:RC<0
169 . S BUF=$P(BUF,";;",2)
170 . D MES^RORKIDS(BUF)
171 . S BUF=$TR(BUF," ")
172 . F LI=1:1 S ITEM=$P(BUF,",",LI) Q:ITEM="" D Q:RC<0
173 . . K RORBUF
174 . . D FIND^DIC(SUBFILE,IENS,"@","QX",ITEM,,"B",,,"RORBUF","RORMSG")
175 . . I $G(DIERR) S RC=$$DBS^RORERR("RORMSG",-9,,,SUBFILE,IENS) Q
176 . . S IR="",DIK=$$ROOT^DILFD(SUBFILE,IENS),DA(1)=+REGIEN
177 . . F S IR=$O(RORBUF("DILIST",2,IR)) Q:IR="" D
178 . . . S DA=RORBUF("DILIST",2,IR) D ^DIK
179 Q RC
180 ;
181 ;***** UPDATES (POPULATES) THE LOCAL REGISTRY
182 ;
183 ; [RORREG] Registry IEN and registry name separated by the '^'
184 ; (RegistryIEN^RegistryName).
185 ; [MAXNTSK] Maximum number of registry update subtasks
186 ; [SUSPEND] Suspend update (sub)tasks during the peak hours
187 ; (StartTime^EndTime)
188 ;
189 ; If some of these parameters are omitted or equal to an empty
190 ; strings, their values must be defined as the RORPARM("KIDS")
191 ; sub-nodes of the same name.
192 ;
193 ; Return Values:
194 ; <0 Error code
195 ; 0 Ok
196 ;
197UPDATE(RORREG,MAXNTSK,SUSPEND) ;
198 N EC,REGLST
199 D BMES^RORKIDS("Updating the local registry...")
200 ;--- Get the parameters
201 S:'$G(RORREG) RORREG=$$PARAM^RORKIDS("RORREG")
202 S:RORREG REGLST($P(RORREG,U,2))=+RORREG
203 S:$G(MAXNTSK)="" MAXNTSK=$$PARAM^RORKIDS("MAXNTSK")
204 S:$G(SUSPEND)="" SUSPEND=$$PARAM^RORKIDS("SUSPEND")
205 ;--- Update the registry
206 S RC=$$UPDATE^RORUPD(.REGLST,,MAXNTSK,SUSPEND) Q:RC<0 RC
207 ;--- Success
208 D MES^RORKIDS("Registry update completed.")
209 Q 0
Note: See TracBrowser for help on using the repository browser.