| [613] | 1 | PXTTEDC ;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 | ;=======================================================================
|
|---|
| 5 | COPYED ;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 | ;=======================================================================
|
|---|
| 14 | COPY(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 | ;
|
|---|
| 22 | GETORGR ;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 | ;
|
|---|
| 50 | UNIQ ;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 | ;
|
|---|
| 59 | NOVA ;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 | ;=======================================================================
|
|---|
| 90 | GETFOIEN(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 | ;=======================================================================
|
|---|
| 99 | MERGE(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 | ;=======================================================================
|
|---|
| 108 | VADSTN(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 | ;=======================================================================
|
|---|
| 114 | STRREP(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 | ;
|
|---|
| 130 | DELETE ;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 | ;
|
|---|
