source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMCOPY.m@ 1800

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

revised back to 6/30/08 version
File size: 4.7 KB
Line 
1PXRMCOPY ; SLC/PKR,PJH - Copy various reminder files. ;05/11/2001
2 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
3 ;
4 ;=====================================================
5COPY(PROMPT,ROOT,WHAT) ;Copy an entry of ROOT into a new entry.
6 N DIROUT,DTOUT,DUOUT
7 F D GETORGR Q:$D(DIROUT) Q:$D(DTOUT)
8 Q
9 ;
10 ;=====================================================
11GETORGR ;Look-up logic to get and copy source entry to destination.
12 N DA,DIE,DIC,DIK,DIR,DIRUT,FDA,FIELDLEN,FILE
13 N IENN,IENO,IENS,MSG,NAME,ORGNAME,X,Y
14 S DIC=ROOT,DIC(0)="AEQ",DIC("A")=PROMPT
15 W !
16 D ^DIC
17 I $D(DUOUT)!$D(DTOUT) S DIROUT="" Q
18 S IENO=$P(Y,U,1)
19 I IENO=-1 S DIROUT="" Q
20 ;
21 ;Set the starting place for additions.
22 D SETSTART^PXRMCOPY(DIC)
23 S IENN=$$GETFOIEN(ROOT)
24 D MERGE(IENN,IENO,ROOT)
25 ;
26 ;Get the new name.
27 S ORGNAME=$P(@(ROOT_IENO_",0)"),U,1)
28 S FILE=$$FNFR^PXRMUTIL(ROOT)
29 S FIELDLEN=$$GET1^DID(FILE,.01,"","FIELD LENGTH")
30 S DIR(0)="F"_U_"3:"_FIELDLEN_U_"K:(X?.N)!'(X'?1P.E) X"
31 S DIR("A")="PLEASE ENTER A UNIQUE NAME"
32GETNAM D ^DIR
33 I $D(DIRUT) D DELETE(ROOT,IENN) Q
34 S NAME=Y
35 ;
36 ;Make sure the new name is valid.
37 I '$$VNAME^PXRMINTR(NAME,FILE) G GETNAM
38 ;
39 ;Change to the new name.
40 S IENS=IENN_","
41 S FDA(FILE,IENS,.01)=NAME
42 K MSG
43 D FILE^DIE("","FDA","MSG")
44 ;Check to make sure the name was not a duplicate.
45 I $G(MSG("DIERR",1))=740 D G GETNAM
46 . W !,NAME," is not a unique name!"
47 ;Change the class to local and delete the sponsor.
48 D SCAS(FILE,IENN,"L","")
49 ;Initialize the edit history.
50 D INIEH(FILE,ROOT,IENN,IENO)
51 ;
52 ;Reindex the cross-references.
53 S DIK=ROOT,DA=IENN
54 D IX^DIK
55 W !
56 ;
57 ;Tell the user what has happened and allow for editing of the new item.
58 S DIR(0)="Y"
59 S DIR("A")="Do you want to edit it now"
60 S DIR("A",1)="The original "_WHAT_" "_ORGNAME_" has been copied into "_NAME_"."
61 D ^DIR Q:$D(DIRUT)
62 I Y D EDIT^PXRMEDIT(ROOT,IENN)
63 Q
64 ;
65 ;=====================================================
66COPYREM ;Copy a reminder definition.
67 N PROMPT,ROOT,WHAT
68 S WHAT="reminder"
69 S ROOT="^PXD(811.9,"
70 S PROMPT="Select the reminder item to copy: "
71 D COPY(PROMPT,ROOT,WHAT)
72 Q
73 ;
74 ;=====================================================
75COPYTAX ;Copy a taxonomy.
76 N PROMPT,ROOT,WHAT
77 S WHAT="taxonomy"
78 S ROOT="^PXD(811.2,"
79 S PROMPT="Select the taxonomy item to copy: "
80 D COPY(PROMPT,ROOT,WHAT)
81 Q
82 ;
83 ;=====================================================
84COPYTERM ;Copy a reminder term.
85 N PROMPT,ROOT,WHAT
86 S WHAT="reminder term"
87 S ROOT="^PXRMD(811.5,"
88 S PROMPT="Select the reminder term to copy: "
89 D COPY(PROMPT,ROOT,WHAT)
90 Q
91 ;
92 ;=====================================================
93DELETE(DIK,DA) ;Delete the entry just added.
94 D ^DIK
95 W !!,"New entry not created due to invalid name!",!
96 Q
97 ;
98 ;=====================================================
99GETFOIEN(ROOT) ;Return the first open IEN in ROOT. This should be called
100 ;after a call to SETSTART.
101 N ENTRY,NIEN,OIEN
102 S ENTRY=ROOT_0_")"
103 S OIEN=$P(@ENTRY,U,3)
104 S ENTRY=ROOT_OIEN_")"
105 F S NIEN=$O(@ENTRY) Q:+(NIEN-OIEN)>1 Q:+NIEN'>0 S OIEN=NIEN,ENTRY=ROOT_NIEN_")"
106 Q OIEN+1
107 ;
108 ;=====================================================
109INIEH(FILENUM,ROOT,IENN,IENO) ;Initialize the edit history after a copy.
110 ;First delete any existing history entries.
111 N ENTRY,IND,IENS,FDA,FDAIEN,MSG,SFN,TARGET,WP
112 D FIELD^DID(FILENUM,"EDIT HISTORY","","SPECIFIER","TARGET")
113 S SFN=+$G(TARGET("SPECIFIER"))
114 I SFN=0 Q
115 S ENTRY=ROOT_IENN_",110)"
116 S IND=0
117 F S IND=$O(@ENTRY@(IND)) Q:+IND=0 D
118 . S IENS=IND_","_IENN_","
119 . S FDA(SFN,IENS,.01)="@"
120 I $D(FDA(SFN)) D FILE^DIE("K","FDA","MSG")
121 I $D(MSG) D AWRITE^PXRMUTIL("MSG")
122 ;Establish an initial entry in the edit history.
123 K FDA,MSG
124 S IENS="+1,"_IENN_","
125 S FDAIEN(IENN)=IENN
126 S FDA(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
127 S FDA(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01)
128 S FDA(SFN,IENS,2)="WP(1,1)"
129 S WP(1,1,1)="Copied from "_$$GET1^DIQ(FILENUM,IENO,.01)
130 D UPDATE^DIE("E","FDA","FDAIEN","MSG")
131 I $D(MSG) D AWRITE^PXRMUTIL("MSG")
132 Q
133 ;
134 ;=====================================================
135MERGE(IENN,IENO,ROOT) ;Use MERGE to copy ROOT(IENO into ROOT(IENN.
136 N DEST,SOURCE
137 S DEST=ROOT_IENN_")"
138 ;Lock the file before merging.
139 L +@DEST:10
140 S SOURCE=ROOT_IENO_")"
141 M @DEST=@SOURCE
142 ;Unlock the file
143 L -@DEST
144 Q
145 ;
146 ;=====================================================
147SCAS(FILENUM,IEN,CLASS,SPONSOR) ;Set the class field to CLASS and the sponsor
148 ;field to SPONSOR.
149 N IENS,FDA,MSG
150 S IENS=IEN_","
151 S FDA(FILENUM,IENS,100)=CLASS
152 S FDA(FILENUM,IENS,101)=SPONSOR
153 D FILE^DIE("K","FDA","MSG")
154 I $D(MSG) D AWRITE^PXRMUTIL("MSG")
155 Q
156 ;
157 ;=====================================================
158SETSTART(ROOT) ;Set the starting value to add new entries. Start
159 ;at the begining so empty spaces are filled in.
160 N CUR,ENTRY
161 S ENTRY=ROOT_"0)"
162 S $P(@ENTRY,U,3)=1
163 Q
164 ;
Note: See TracBrowser for help on using the repository browser.