source: FOIAVistA/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXTTEDC.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 4.1 KB
Line 
1PXTTEDC ;ISL/PKR,DLT,ISA/KWP/ESW - Code to copy an education topic entry making sure it is unique. ;5/20/96 12:06
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**106**;Aug 12, 1996
3 ;
4 ;=======================================================================
5COPYED ;Copy an education topic into the site's range of IENS.
6 N PROMPT,ROOT,WHAT
7 S WHAT="education topic"
8 S ROOT="^AUTTEDT("
9 S PROMPT="Select the EDUCATION TOPIC to copy: "
10 D COPY(PROMPT,ROOT)
11 Q
12 ;
13 ;=======================================================================
14COPY(PROMPT,ROOT) ;Copy an entry of ROOT into a new entry.
15 N DIC,DUOUT,DTOUT,DIROUT,DIRUT,SIEN,IENN,IENO,PXTTSNUM,X,Y
16 S PXTTSNUM=+$P($$SITE^VASITE,U,3)
17 I $L(PXTTSNUM)'=3 W !,"You must have a 3-digit primary station number in order to use this option, See IRM!" Q
18 ;
19 F D GETORGR Q:$D(DIROUT) Q:$D(DTOUT)
20 Q
21 ;
22GETORGR ;Look-up logic to get and copy source entry in education topic file.
23 ;PXNAT - a variable to be setup to 1 in ACTION ENTRY field of OPTION
24 ; file:
25 ; PXTT COPY EDUCATION TOPICS
26 ; while copying a topic in a national package
27 ;
28 S DIC=ROOT,DIC(0)="AMEQ",DIC("A")=PROMPT
29 W !
30 D ^DIC I $D(DUOUT)!$D(DTOUT) S DIROUT="" Q
31 S IENO=$P(Y,U,1)
32 I IENO=-1 S DIROUT="" Q
33 ;
34 S IENN=$S(+$G(PXNAT):1,1:+PXTTSNUM_"001")
35 S IENN=$$GETFOIEN(ROOT,IENN)
36 ;Lock the file before merging.
37 L +^AUTTEDT(IENN):10
38 D MERGE(IENN,IENO,ROOT)
39 ;
40 ;Unlock the file.
41 L -^AUTTEDT(IENN)
42 ;
43 N DA,DIE,DIK,DIR,DR,ENTRY,NAME,ORGNAME
44 S ENTRY=ROOT_IENN_","_"0)"
45 S NAME=$P($G(@ENTRY),U,1),ORGNAME=NAME
46 ; If there is a VA- or VA*- in the copied name get rid of it.
47 I $F(NAME,"VA-")>0 S NAME=$$STRREP(NAME,"VA-","")
48 I $F(NAME,"VA*-")>0 S NAME=$$STRREP(NAME,"VA*-","")
49 ;
50UNIQ ;Make sure the name is unique.
51 S Y=""
52 I $D(^AUTTEDT("B",NAME)) D Q:$D(DIRUT)
53 . S DIR(0)="F"_U_"3:30"_U_"K:(X?.N)!'(X'?1P.E) X"
54 . S DIR("A")=NAME_" - IS A DUPLICATE NAME, PLEASE ENTER A UNIQUE NAME"
55 . D ^DIR I $D(DIRUT) D DELETE Q
56 . S NAME=Y
57 I Y'="" G UNIQ
58 ;
59NOVA ;Sites are not allowed to use VA in their names.
60 S Y=""
61 I '$G(PXNAT)&($$VADSTN(NAME)) D Q:$D(DIRUT)
62 . S DIR(0)="F"_U_"3:30"_U_"K:(X?.N)!'(X'?1P.E) X"
63 . S DIR("A")=NAME_" CANNOT START WITH ""VA-"", INPUT A DIFFERENT ONE"
64 . D ^DIR I $D(DIRUT) D DELETE Q
65 . S NAME=Y
66 I Y'="" G UNIQ
67 ;
68 ;Store the unique name
69 S DR=".01///^S X=NAME",DIE=ROOT,DA=IENN
70 D ^DIE
71 ;
72 ;Reindex the cross-references.
73 S DIK=ROOT,DA=IENN
74 D IX^DIK
75 ;
76 ;Tell the user what has happened and allow for editing of the new item.
77 W !
78 S DIR(0)="Y"
79 S DIR("A")="Do you want to edit it now"
80 S DIR("A",1)="The original education topic "_ORGNAME_" has been copied into "_NAME_"."
81 D ^DIR Q:$D(DIRUT)
82 I Y D
83 . N DIE,DR
84 . S DIE=ROOT,DR="[PXTT EDIT PAT. EDUCATION]"
85 . D ^DIE
86 . Q
87 Q
88 ;
89 ;=======================================================================
90GETFOIEN(ROOT,SIEN) ;Given ROOT and a starting IEN (SIEN) return the first
91 ;open IEN in ROOT
92 N ENTRY,NIEN,OIEN
93 S OIEN=SIEN-1
94 S ENTRY=ROOT_OIEN_")"
95 F S NIEN=$O(@ENTRY) Q:+(NIEN-OIEN)>1 Q:+NIEN'>0 S OIEN=NIEN,ENTRY=ROOT_NIEN_")"
96 Q OIEN+1
97 ;
98 ;=======================================================================
99MERGE(IENN,IENO,ROOT) ;Use MERGE to copy ROOT(IENO into ROOT(IENN.
100 N DEST,SOURCE
101 ;
102 S DEST=ROOT_IENN_")"
103 S SOURCE=ROOT_IENO_")"
104 M @DEST=@SOURCE
105 Q
106 ;
107 ;=======================================================================
108VADSTN(NAME) ;Return TRUE (1) if VA- starts the NAME.
109 I $F(NAME,"VA-")=4 Q 1
110 I $F(NAME,"VA*-")=5 Q 1
111 E Q 0
112 ;
113 ;=======================================================================
114STRREP(STRING,TS,RS) ;Replace every occurence of the target string (TS)
115 ;in STRING with the replacement string (RS).
116 ;Example 9.19 (page 220) in "The Complete Mumps" by John Lewkowicz:
117 ;
118 N FROM,NPCS,STR
119 ;
120 I STRING'[TS Q STRING
121 ;Count the number of pieces using the target string as the delimiter.
122 S FROM=1
123 F NPCS=1:1 S FROM=$F(STRING,TS,FROM) Q:FROM=0
124 ;Extract the pieces and concatenate RS
125 S STR=""
126 F FROM=1:1:NPCS-1 S STR=STR_$P(STRING,TS,FROM)_RS
127 S STR=STR_$P(STRING,TS,NPCS)
128 Q STR
129 ;
130DELETE ;Delete the entry just added.
131 S DIK=ROOT,DA=IENN D ^DIK
132 W !!,"New entry not created due to invalid education topic name!",!
133 Q
134 ;
Note: See TracBrowser for help on using the repository browser.