source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMGEDT.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 6.4 KB
Line 
1PXRMGEDT ; SLC/PJH - PXRM General Edit/Add. ;11/08/2000
2 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
3 ;
4 ;
5 ;Called from protocol PXRM SELECTION ADD
6 ;
7ADD(TYP) ;
8 N DIC,DIDEL,DLAYGO,DTOUT,DUOUT,FILE,HED,PXRMHD,X,Y
9 W IORESET
10 ;
11 ;Ignore finding type parameters
12 I "FPAR"=TYP D DUMMY^PXRMRUTL H 1 Q
13 ;
14 ;Edit dialog
15 I "DLGE"=TYP D ADD^PXRMDEDT Q
16 ;
17 ;Allow auto generate of reminder dialogs
18 I TYP["DLG" D ^PXRMDBLD Q
19 ;
20 ;Finding Item Parameter
21 I TYP="FIP" S FILE="801.43",HED="FINDING ITEM PARAMETER"
22 ;
23 ;Reminder Category
24 I TYP="RCAT" S FILE="811.7",HED="REMINDER CATEGORY"
25 ;
26 ;Resolution Status
27 I TYP="RESN" S FILE="801.9",HED="RESOLUTION STATUS"
28 ;
29 ;Health Factor Resolution
30 I TYP="SHFR" S FILE="801.95",HED="HEALTH FACTOR"
31 ;
32 F D Q:(X="")!$D(DUOUT)!$D(DTOUT)
33 .S DIC=FILE,DLAYGO=DIC,DIDEL=DIC,DIC(0)="QAELX"
34 .S DIC("A")="Select new "_HED_" name: "
35 .I TYP="SHFR" S DIC(0)="QAEL"
36 .D ^DIC Q:X=""
37 .I X=(U_U) S DTOUT=1
38 .I Y=-1 S DUOUT=1 W !,"Details not saved",! Q
39 .Q:$D(DTOUT)!$D(DUOUT)
40 .;Check if exists
41 .I ($P(Y,U,3)'=1) W !,"already exists" Q
42 .S DA=$P(Y,U)
43 .;Edit resolution status
44 .I TYP="RESN" D EDIT^PXRMSEDT("^PXRMD(801.9,",DA)
45 .;Edit others
46 .I TYP'="RESN" D EDIT(TYP,DA,1)
47 .S DUOUT=1
48 Q
49 ;
50DIE(HDR,FILE) ;Lock and edit
51 I FILE=801.45 W "ED - EDIT "_HDR,!!,PXRMHD,!
52 ;Display resolution details if finding type parameter edit
53 I FILE=801.45,$G(PXRMINST)'=1 D
54 .N RSUB,RNAM
55 .S RSUB=$P($G(^PXRMD(801.45,PXRMFIEN,1,PXRMFSUB,0)),U) Q:'RSUB
56 .S RNAM=$P($G(^PXRMD(801.9,RSUB,0)),U)
57 .S:RNAM="" RNAM=RSUB W "RESOLUTION STATUS : ",RNAM
58 D:$$LOCK(FILE) ^DIE,UNLOCK(FILE)
59 Q
60 ;
61 ;Called by protocol PXRM GENERAL EDIT
62 ;------------------------------------
63EDIT(TYP,DA,ADD) ;
64 N DIC,DIDEL,DIE,DR,DTOUT,DUOUT,Y
65 W IORESET
66 S VALMBCK="R"
67 ;
68 ;Taxonomy Dialog
69 I TYP="DTAX" D
70 .I $$TLOCK(811.2,DA) D D TUNLOCK(811.2,DA)
71 ..;Initialize the selectable codes if none exist
72 ..I ('$D(^PXD(811.2,DA,"SDX")))&('$D(^PXD(811.2,DA,"SPR"))) D
73 ...D BUILD^PXRMTDUP(DA)
74 ..;
75 ..N DIE,DR
76 ..S DIE="^PXD(811.2,"
77 ..;
78 ..W !,"Dialog Text Fields"
79 ..S DR=".03;3107;3108;3111;3112"
80 ..D ^DIE
81 ..I $D(Y) Q
82 ..;
83 ..W !!,"Dialog Selectable codes"
84 ..S DR="3102;3104"
85 ..D ^DIE
86 ..I $D(Y) Q
87 ..;
88 ..W !!,"Dialog Generation Parameters"
89 ..S DR="3106;3110"
90 ..D ^DIE
91 ;
92 ;Finding Item Parameter
93 I TYP="FIP" D
94 .S DIE="^PXRMD(801.43,",DR=".01;.02;.03;.04",DIDEL=801.43
95 .D DIE("FINDING ITEM PARAMETER",801.43)
96 ;
97 ;Finding Type Parameter
98 I TYP="FPAR" D
99 .;Programmer mode
100 .S:$G(PXRMINST)=1 DR=1,DR(2,801.451)="1;3;4;5",DIE="^PXRMD(801.45,"
101 .;Site mode
102 .I $G(PXRMINST)'=1 D
103 ..S DR="1;3;4;5",DIE="^PXRMD(801.45,PXRMFIEN,1,",DA(1)=PXRMFIEN
104 ..S DR(2,801.4515)="2;4;5;6;1"
105 .D DIE("FINDING TYPE PARAMETER",801.45)
106 ;
107 ;Reminder Category
108 I TYP="RCAT" D
109 .S DIE="^PXRMD(811.7,",DR=".01;1;2;10",DIDEL=811.7
110 .D DIE("CATEGORY",811.7)
111 ;
112 ;Resolution Status
113 I TYP="RESN" D
114 .I $$LOCK(801.9) D EDIT^PXRMSEDT("^PXRMD(801.9,",.DA),UNLOCK(811.9)
115 ;
116 ;Health Factor Resolution
117 I TYP="SHFR" D
118 .S DIE="^PXRMD(801.95,",DR=".01;.02",DIDEL=801.95
119 .D DIE("HEALTH FACTOR RESOLUTIONS",811.7)
120 ;
121 ;Skip rebuild if editting taxonomy called from dialog edit
122 I PXRMGTYP["DLG" Q
123 ;
124 ;Deleted ???
125 I '$D(DA) S VALMBCK="Q" Q
126 ;Redisplay changes
127 I 'ADD D BUILD^PXRMGEN
128 Q
129 ;
130 ;
131LOCK(FILE) ;Lock the entire file
132 L +^PXRMD(FILE):0 I Q 1
133 E W !!,?5,"Another user is editing this file, try later" H 2
134 Q 0
135 ;
136 ;
137UNLOCK(FILE) ;Unlock the file
138 L -^PXRMD(FILE)
139 Q
140 ;Build the list of codes for one taxonomy
141 ;----------------------------------------
142SEL(TAXIND) ;
143 N CODELIST,IC,FINDING,FILE,HIGH,LOW,NCE,TEMP
144 ;
145 ;Setup file names for indirection, these will hold the taxonomy lists.
146 N ICD9IEN,ICPTIEN
147 S ICD9IEN="^TMP(""PXRM"",$J,""ICD9IEN"")"
148 S ICPTIEN="^TMP(""PXRM"",$J,""ICPTIEN"")"
149 ;
150 S NCE=0
151 F FILE=80,81 D
152 .S IC=0
153 .F S IC=$O(^PXD(811.2,TAXIND,FILE,IC)) Q:+IC=0 D
154 ..S TEMP=$G(^PXD(811.2,TAXIND,FILE,IC,0))
155 ..;Append the taxonomy and finding information to CODELIST.
156 ..S NCE=NCE+1
157 ..S CODELIST(NCE)=TEMP_U_FILE
158 ;CODELIST is LOW_U_HIGH_U_FILE
159 ;Go through the standard coded list and get the file IEN for each entry.
160 F IC=1:1:NCE D
161 .S LOW=$P(CODELIST(IC),U,1)
162 .S HIGH=$P(CODELIST(IC),U,2)
163 .S FILE=$P(CODELIST(IC),U,3)
164 .I FILE=80 D ICD9(LOW,HIGH) Q
165 .I FILE=81 D ICPT(LOW,HIGH) Q
166 ;
167 ;Store the results.
168 D STORE(TAXIND)
169 K ^TMP("PXRM",$J,"ICD9IEN")
170 K ^TMP("PXRM",$J,"ICPTIEN")
171 Q
172 ;
173 ;=======================================================================
174DEL(TAXIND) ;Delete existing entry
175 K ^PXD(811.2,TAXIND,"SDX")
176 K ^PXD(811.2,TAXIND,"SPR")
177 Q
178 ;
179 ;Build the list of internal entries for ICD9 (File 80)
180 ;-----------------------------------------------------
181ICD9(LOW,HIGH) ;
182 N END,IEN,IND
183 S IND=LOW_" "
184 S END=HIGH_" "
185 F Q:(IND]END)!(+IND>+END)!(IND="") D
186 .S IEN=$O(^ICD9("BA",IND,""))
187 .I (+IEN>0),$$CODE^PXRMVAL($TR(IND," "),80) D
188 ..S ^TMP("PXRM",$J,"ICD9IEN",IND)=IEN
189 .S IND=$O(^ICD9("BA",IND))
190 Q
191 ;
192 ;Build the list of internal entries for ICPT (File 81)
193 ;-----------------------------------------------------
194ICPT(LOW,HIGH) ;
195 N IEN,IND
196 S IND=LOW
197 F Q:(IND]HIGH)!(+IND>+HIGH)!(IND="") D
198 .S IEN=$O(^ICPT("B",IND,""))
199 .I (+IEN>0),$$CODE^PXRMVAL($TR(IND," "),81) D
200 ..S ^TMP("PXRM",$J,"ICPTIEN",IND)=IEN
201 .S IND=$O(^ICPT("B",IND))
202 Q
203 ;
204 ;Store selectable codes in taxonomy
205 ;----------------------------------
206STORE(TAXIND) ;
207 K ^TMP("PXRMGEDT",$J)
208 N FDA,FDAIEN,FITEM,I2N,IEN,IND,MSG,NAME,SEQ,SUB,TEMP
209 ;
210 S NAME=$P(^PXD(811.2,TAXIND,0),U)
211 ;
212 S FDAIEN(1)=TAXIND
213 ;
214 S SUB="",IND=1,SEQ=0
215 F S SUB=$O(^TMP("PXRM",$J,"ICD9IEN",SUB)) Q:SUB="" D
216 .S IEN=^TMP("PXRM",$J,"ICD9IEN",SUB)
217 .S IND=IND+1,SEQ=SEQ+1
218 .S I2N="+"_IND_","_FDAIEN(1)_","
219 .S ^TMP("PXRMGEDT",$J,811.23102,I2N,.01)=IEN
220 ;
221 S SEQ=0
222 F S SUB=$O(^TMP("PXRM",$J,"ICPTIEN",SUB)) Q:SUB="" D
223 .S IEN=^TMP("PXRM",$J,"ICPTIEN",SUB)
224 .S IND=IND+1,SEQ=SEQ+1
225 .S I2N="+"_IND_","_FDAIEN(1)_","
226 .S ^TMP("PXRMGEDT",$J,811.23104,I2N,.01)=IEN
227 ;
228 ;None found
229 I IND=1 Q
230 ;
231 S TEMP="^TMP(""PXRMGEDT"","_$J_")"
232 D UPDATE^DIE("",TEMP,"FDAIEN","MSG")
233 I $D(MSG) D ERR
234 K ^TMP("PXRMGEDT",$J)
235 Q
236 ;
237 ;Error Handler
238 ;-------------
239ERR N ERROR,IC,REF
240 S ERROR(1)="Unable to build selectable codes for taxonomy : "
241 S ERROR(2)=NAME
242 S ERROR(3)="Error in UPDATE^DIE, needs further investigation"
243 ;Move MSG into ERROR
244 S REF="MSG"
245 F IC=4:1 S REF=$Q(@REF) Q:REF="" S ERROR(IC)=REF_"="_@REF
246 ;Screen message
247 D BMES^XPDUTL(.ERROR)
248 Q
249 ;
250TLOCK(FILE,DA) ;Lock the record
251 L +^PXD(FILE,DA):0 I Q 1
252 E W !!,?5,"Another user is editing this file, try later" H 2 Q 0
253 ;
254 ;
255TUNLOCK(FILE,DA) ;Unlock the record
256 L -^PXD(FILE,DA)
257 Q
Note: See TracBrowser for help on using the repository browser.