source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDCPY.m@ 1006

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

initial load of WorldVistAEHR

File size: 5.6 KB
Line 
1PXRMDCPY ; SLC/PJH - Copy dialog files. ;07/09/2002
2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
3 ;
4 ;Called by label from PXRMDEDT
5 ;
6 ;Yes/No prompts
7 ;--------------
8ASK(YESNO,TEXT,HLP,DEFAULT) ;
9 N X,Y,DIR
10 K DIROUT,DIRUT,DTOUT,DUOUT
11 S DIR(0)="YA0"
12 S DIR("A")=TEXT
13 S DIR("B")=DEFAULT
14 S DIR("?")="Enter Y or N. For detailed help type ??"
15 S DIR("??")=U_"D HELP^PXRMDEDT(HLP)"
16 D ^DIR K DIR
17 I $D(DIROUT) S DTOUT=1
18 I $D(DTOUT)!($D(DUOUT)) Q
19 S YESNO=$E(Y(0))
20 Q
21 ;
22 ;Copy any dialog
23 ;---------------
24ANY W IORESET
25 N DIC,DUOUT,DTOUT,DIROUT,DIRUT,DTYP,LFIND,LOCK,SIEN,IENN,IENO,X,Y
26 N PROMPT,ROOT,WHAT
27 S WHAT="dialog",ROOT="^PXRMD(801.41,",PROMPT="Select the dialog to copy: "
28 ;
29 S DIC=ROOT,DIC(0)="AEQ",DIC("A")=PROMPT
30 S DIC("S")="I $P(^(0),U,4)=PXRMDTYP"
31 W !
32 D ^DIC
33 I $D(DUOUT)!$D(DTOUT) S DIROUT="" Q
34 S IENO=$P(Y,U,1) I IENO=-1 S DIROUT="" Q
35 ;
36 ;Check for Uneditable flag
37 S LOCK=$P($G(^PXRMD(801.41,IENO,100)),U,4)
38 S LFIND=$P($G(^PXRMD(801.41,IENO,1)),U,5)
39 S DTYP=$P($G(^PXRMD(801.41,IENO,0)),U,4)
40 I LOCK=1,'$G(PXRMINST),DTYP="G" D Q
41 .W !,"This item cannot be copied." H 2
42 I LOCK=1,$G(LFIND)'="",$G(LFIND)'["ORD",'$G(PXRMINST),DTYP'="G" D Q
43 .W !,"This item cannot be copied." H 2
44 ;
45 ;Copy the dialog
46 D COPY(IENO,.IENN,0) Q:$D(DUOUT)
47 ;
48 ;Prompts may become forced values
49 I "PF"[$P(@(ROOT_IENN_",0)"),U,4) D
50 .;Get original process ID
51 .N SUB S SUB=$P($G(^PXRMD(801.41,IENO,46)),U)
52 .;Update GUI process in 801.41
53 .I SUB S DR="46///"_SUB,DIE=ROOT,DA=IENN D ^DIE
54 .;check if a prompt
55 .I $P(@(ROOT_IENN_",0)"),U,4)="P" D
56 ..;Allow PXRM prompts to be changed into forced values
57 ..N ANS,TEXT
58 ..S TEXT="Change the new prompt into a forced value :"
59 ..D ASK(.ANS,TEXT,4,"N") Q:$D(DUOUT)!$D(DTOUT) Q:ANS'="Y"
60 ..;Store the dialog type
61 ..S DR="4///F",DIE=ROOT,DA=IENN
62 ..D ^DIE
63 .Q
64 ;
65 Q
66 ;
67 ;Copy original dialog
68 ;--------------------
69COPY(IENO,IENN,RDIEN) ;
70 D SETSTART^PXRMCOPY(ROOT)
71 S IENN=$$GETFOIEN(ROOT)
72 D MERGE(IENN,IENO,ROOT) Q:$D(DUOUT)
73 ;
74 S DPOS=$G(SEQ)
75 N DA,DIE,DIK,DIR,DR,NAME,ORGNAME,X
76 S ORGNAME=$P(@(ROOT_IENO_",0)"),U,1),NAME=""
77 ;Get the new name.
78 F D Q:$D(DTOUT)!$D(DUOUT) Q:NAME]""
79 .S DIR(0)="F"_U_"3:63"_U_"K:(X?.N)!'(X'?1P.E) X"
80 .S DIR("A")="ENTER A UNIQUE NAME"
81 .;If give a default name
82 .S:RDIEN DIR("B")=$$NAME(IENO,ORGNAME)
83 .D ^DIR Q:$D(DTOUT)!$D(DUOUT)
84 .I Y["""" D EN^DDIOL(" name cannot contain quotes!") Q
85 .I $E(Y,1,4)="PXRM" D EN^DDIOL(" name cannot begin with PXRM!") Q
86 .I '$$VNAME^PXRMINTR(Y,801.41) Q
87 .I $$UNIQNAME(Y,ROOT) S NAME=Y Q
88 .D EN^DDIOL(" is not a unique name!")
89 ;
90 Q:$D(DTOUT)!$D(DUOUT)
91 ;
92 ;Store the unique name
93 S DR=".01///^S X=NAME",DIE=ROOT,DA=IENN
94 D ^DIE
95 ;
96 ;Change the class to local and delete the sponsor
97 D SCAS^PXRMCOPY(801.41,IENN,"L","")
98 ;Initialize the edit history
99 D INIEH^PXRMCOPY(801.41,ROOT,IENN,IENO)
100 ;Reindex the cross-references.
101 S DIK=ROOT,DA=IENN
102 D IX^DIK
103 ;
104 W !!,"Completed copy of '"_ORGNAME_"'"
105 W !,"into '"_NAME_"'",! H 2
106 ;
107 Q
108 ;
109 ;Delete the entry just added
110 ;---------------------------
111DELETE S DIK=ROOT,DA=IENN D ^DIK
112 W !!,"New entry not created due to invalid name!",!
113 Q
114 ;
115 ;Error Handler
116 ;-------------
117ERR(DESC) ;
118 N ERROR,IC,REF
119 S ERROR(1)="Unable to update GUI PROCESS file : "_DESC
120 S ERROR(2)="Error in UPDATE^DIE, needs further investigation"
121 ;Move MSG into ERROR
122 S REF="MSG"
123 F IC=3:1 S REF=$Q(@REF) Q:REF="" S ERROR(IC)=REF_"="_@REF
124 ;Screen message
125 D BMES^XPDUTL(.ERROR)
126 Q
127 ;
128 ;Given ROOT return the first
129 ;---------------------------
130GETFOIEN(ROOT) ;Return the first open IEN in ROOT. This should be called
131 ;after a call to SETSTART.
132 N ENTRY,NIEN,OIEN
133 S ENTRY=ROOT_0_")"
134 S OIEN=$P(@ENTRY,U,3)
135 S ENTRY=ROOT_OIEN_")"
136 F S NIEN=$O(@ENTRY) Q:+(NIEN-OIEN)>1 Q:+NIEN'>0 S OIEN=NIEN,ENTRY=ROOT_NIEN_")"
137 Q OIEN+1
138 ;
139 ;Use MERGE to copy ROOT(IENO into ROOT(IENN
140 ;------------------------------------------
141MERGE(IENN,IENO,ROOT) ;
142 N DEST,SOURCE
143 ;
144 S DEST=ROOT_IENN_")"
145 ;Lock the file before merging.
146 L +@DEST:10
147 E W !,"Another user is editing this file, try later" H 2 S DUOUT=1 Q
148 S SOURCE=ROOT_IENO_")"
149 M @DEST=@SOURCE
150 ;Unlock the file
151 L -@DEST
152 Q
153 ;
154 ;Get default name
155 ;----------------
156NAME(IEN,ORG) ;
157 N CNT,NAME,PREV
158 ;
159 S PREV=0
160 I $E(ORG,$L(ORG))=")",ORG[" (" D
161 .S PREV=+$P(ORG," (",2) S:PREV>0 ORG=$P(ORG," (",1)
162 F CNT=PREV+1:1 S NAME=ORG_" ("_CNT_")" Q:'$D(^PXRMD(801.41,"B",NAME))
163 Q NAME
164 ;
165 ;Copy selected dialog element OR reminder dialog
166 ;-----------------------------------------------
167SEL(IENO,RDIEN) ;
168 W IORESET S VALMBCK="R"
169 N ANS,IENN,PROMPT,ROOT,TEXT,WHAT,DPOS
170 S WHAT="dialog element"
171 S ROOT="^PXRMD(801.41,"
172 S PROMPT="Select the dialog to copy: "
173 S TEXT=$P($G(^PXRMD(801.41,IENO,0)),U)
174 ;
175 I RDIEN S TEXT="Copy and replace '"_TEXT_"' "
176 I 'RDIEN S TEXT="Copy reminder dialog '"_TEXT_"' "
177 D ASK(.ANS,TEXT,2,"Y") Q:$D(DUOUT)!$D(DTOUT) Q:ANS'="Y"
178 ;Copy
179 D COPY(IENO,.IENN,RDIEN) Q:$D(DUOUT)!$D(DTOUT)
180 ;Replace dialog element in reminder dialog
181 I RDIEN D
182 .N DR,DA,DIE
183 .S DA=0
184 .F S DA=$O(^PXRMD(801.41,RDIEN,10,"D",IENO,DA)) Q:DA="" D
185 . . I $P($G(^PXRMD(801.41,RDIEN,10,DA,0)),U)=$G(DPOS) D
186 . . . S DA(1)=RDIEN
187 . . . S DR="2///"_IENN
188 . . . S DIE=ROOT_RDIEN_",10,"
189 . . . D ^DIE
190 .W !,"Replaced element'"_$P(@(ROOT_IENO_",0)"),U)_"'"
191 .W !,"with '"_$P(@(ROOT_IENN_",0)"),U)_"'"
192 .W !,"on this dialog.",!
193 ;
194 ;Quit screen for edit = yes
195 I 'RDIEN S VALMBCK="Q" Q
196 ;
197 N DIR
198 S DIR(0)="YAO"
199 S DIR("A")="Do you want to edit now "
200 S DIR("B")="Y"
201 D ^DIR
202 I $D(DIRUT) S DUOUT=1 Q
203 I $E(Y(0))'="Y" S DUOUT=1 Q
204 W !
205 ;Reset dialog element ien
206 S IENO=IENN
207 Q
208 ;
209 ;Return TRUE (1) if NAME is unique
210 ;---------------------------------
211UNIQNAME(NAME,ROOT) ;
212 N RETVAL,REF
213 S RETVAL=1,REF=ROOT_"""B"""_","_""""_NAME_""""_")"
214 I $D(@REF) S RETVAL=0
215 Q RETVAL
Note: See TracBrowser for help on using the repository browser.