PXTTEDC ;ISL/PKR,DLT,ISA/KWP/ESW - Code to copy an education topic entry making sure it is unique. ;5/20/96 12:06
;;1.0;PCE PATIENT CARE ENCOUNTER;**106**;Aug 12, 1996
;
;=======================================================================
COPYED ;Copy an education topic into the site's range of IENS.
N PROMPT,ROOT,WHAT
S WHAT="education topic"
S ROOT="^AUTTEDT("
S PROMPT="Select the EDUCATION TOPIC to copy: "
D COPY(PROMPT,ROOT)
Q
;
;=======================================================================
COPY(PROMPT,ROOT) ;Copy an entry of ROOT into a new entry.
N DIC,DUOUT,DTOUT,DIROUT,DIRUT,SIEN,IENN,IENO,PXTTSNUM,X,Y
S PXTTSNUM=+$P($$SITE^VASITE,U,3)
I $L(PXTTSNUM)'=3 W !,"You must have a 3-digit primary station number in order to use this option, See IRM!" Q
;
F D GETORGR Q:$D(DIROUT) Q:$D(DTOUT)
Q
;
GETORGR ;Look-up logic to get and copy source entry in education topic file.
;PXNAT - a variable to be setup to 1 in ACTION ENTRY field of OPTION
; file:
; PXTT COPY EDUCATION TOPICS
; while copying a topic in a national package
;
S DIC=ROOT,DIC(0)="AMEQ",DIC("A")=PROMPT
W !
D ^DIC I $D(DUOUT)!$D(DTOUT) S DIROUT="" Q
S IENO=$P(Y,U,1)
I IENO=-1 S DIROUT="" Q
;
S IENN=$S(+$G(PXNAT):1,1:+PXTTSNUM_"001")
S IENN=$$GETFOIEN(ROOT,IENN)
;Lock the file before merging.
L +^AUTTEDT(IENN):10
D MERGE(IENN,IENO,ROOT)
;
;Unlock the file.
L -^AUTTEDT(IENN)
;
N DA,DIE,DIK,DIR,DR,ENTRY,NAME,ORGNAME
S ENTRY=ROOT_IENN_","_"0)"
S NAME=$P($G(@ENTRY),U,1),ORGNAME=NAME
; If there is a VA- or VA*- in the copied name get rid of it.
I $F(NAME,"VA-")>0 S NAME=$$STRREP(NAME,"VA-","")
I $F(NAME,"VA*-")>0 S NAME=$$STRREP(NAME,"VA*-","")
;
UNIQ ;Make sure the name is unique.
S Y=""
I $D(^AUTTEDT("B",NAME)) D Q:$D(DIRUT)
. S DIR(0)="F"_U_"3:30"_U_"K:(X?.N)!'(X'?1P.E) X"
. S DIR("A")=NAME_" - IS A DUPLICATE NAME, PLEASE ENTER A UNIQUE NAME"
. D ^DIR I $D(DIRUT) D DELETE Q
. S NAME=Y
I Y'="" G UNIQ
;
NOVA ;Sites are not allowed to use VA in their names.
S Y=""
I '$G(PXNAT)&($$VADSTN(NAME)) D Q:$D(DIRUT)
. S DIR(0)="F"_U_"3:30"_U_"K:(X?.N)!'(X'?1P.E) X"
. S DIR("A")=NAME_" CANNOT START WITH ""VA-"", INPUT A DIFFERENT ONE"
. D ^DIR I $D(DIRUT) D DELETE Q
. S NAME=Y
I Y'="" G UNIQ
;
;Store the unique name
S DR=".01///^S X=NAME",DIE=ROOT,DA=IENN
D ^DIE
;
;Reindex the cross-references.
S DIK=ROOT,DA=IENN
D IX^DIK
;
;Tell the user what has happened and allow for editing of the new item.
W !
S DIR(0)="Y"
S DIR("A")="Do you want to edit it now"
S DIR("A",1)="The original education topic "_ORGNAME_" has been copied into "_NAME_"."
D ^DIR Q:$D(DIRUT)
I Y D
. N DIE,DR
. S DIE=ROOT,DR="[PXTT EDIT PAT. EDUCATION]"
. D ^DIE
. Q
Q
;
;=======================================================================
GETFOIEN(ROOT,SIEN) ;Given ROOT and a starting IEN (SIEN) return the first
;open IEN in ROOT
N ENTRY,NIEN,OIEN
S OIEN=SIEN-1
S ENTRY=ROOT_OIEN_")"
F S NIEN=$O(@ENTRY) Q:+(NIEN-OIEN)>1 Q:+NIEN'>0 S OIEN=NIEN,ENTRY=ROOT_NIEN_")"
Q OIEN+1
;
;=======================================================================
MERGE(IENN,IENO,ROOT) ;Use MERGE to copy ROOT(IENO into ROOT(IENN.
N DEST,SOURCE
;
S DEST=ROOT_IENN_")"
S SOURCE=ROOT_IENO_")"
M @DEST=@SOURCE
Q
;
;=======================================================================
VADSTN(NAME) ;Return TRUE (1) if VA- starts the NAME.
I $F(NAME,"VA-")=4 Q 1
I $F(NAME,"VA*-")=5 Q 1
E Q 0
;
;=======================================================================
STRREP(STRING,TS,RS) ;Replace every occurence of the target string (TS)
;in STRING with the replacement string (RS).
;Example 9.19 (page 220) in "The Complete Mumps" by John Lewkowicz:
;
N FROM,NPCS,STR
;
I STRING'[TS Q STRING
;Count the number of pieces using the target string as the delimiter.
S FROM=1
F NPCS=1:1 S FROM=$F(STRING,TS,FROM) Q:FROM=0
;Extract the pieces and concatenate RS
S STR=""
F FROM=1:1:NPCS-1 S STR=STR_$P(STRING,TS,FROM)_RS
S STR=STR_$P(STRING,TS,NPCS)
Q STR
;
DELETE ;Delete the entry just added.
S DIK=ROOT,DA=IENN D ^DIK
W !!,"New entry not created due to invalid education topic name!",!
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXTTEDC 4337 printed Apr 09, 2024@21:27:38 Page 2
PXTTEDC ;ISL/PKR,DLT,ISA/KWP/ESW - Code to copy an education topic entry making sure it is unique. ;5/20/96 12:06
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**106**;Aug 12, 1996
+2 ;
+3 ;=======================================================================
COPYED ;Copy an education topic into the site's range of IENS.
+1 NEW PROMPT,ROOT,WHAT
+2 SET WHAT="education topic"
+3 SET ROOT="^AUTTEDT("
+4 SET PROMPT="Select the EDUCATION TOPIC to copy: "
+5 DO COPY(PROMPT,ROOT)
+6 QUIT
+7 ;
+8 ;=======================================================================
COPY(PROMPT,ROOT) ;Copy an entry of ROOT into a new entry.
+1 NEW DIC,DUOUT,DTOUT,DIROUT,DIRUT,SIEN,IENN,IENO,PXTTSNUM,X,Y
+2 SET PXTTSNUM=+$PIECE($$SITE^VASITE,U,3)
+3 IF $LENGTH(PXTTSNUM)'=3
WRITE !,"You must have a 3-digit primary station number in order to use this option, See IRM!"
QUIT
+4 ;
+5 FOR
DO GETORGR
if $DATA(DIROUT)
QUIT
if $DATA(DTOUT)
QUIT
+6 QUIT
+7 ;
GETORGR ;Look-up logic to get and copy source entry in education topic file.
+1 ;PXNAT - a variable to be setup to 1 in ACTION ENTRY field of OPTION
+2 ; file:
+3 ; PXTT COPY EDUCATION TOPICS
+4 ; while copying a topic in a national package
+5 ;
+6 SET DIC=ROOT
SET DIC(0)="AMEQ"
SET DIC("A")=PROMPT
+7 WRITE !
+8 DO ^DIC
IF $DATA(DUOUT)!$DATA(DTOUT)
SET DIROUT=""
QUIT
+9 SET IENO=$PIECE(Y,U,1)
+10 IF IENO=-1
SET DIROUT=""
QUIT
+11 ;
+12 SET IENN=$SELECT(+$GET(PXNAT):1,1:+PXTTSNUM_"001")
+13 SET IENN=$$GETFOIEN(ROOT,IENN)
+14 ;Lock the file before merging.
+15 LOCK +^AUTTEDT(IENN):10
+16 DO MERGE(IENN,IENO,ROOT)
+17 ;
+18 ;Unlock the file.
+19 LOCK -^AUTTEDT(IENN)
+20 ;
+21 NEW DA,DIE,DIK,DIR,DR,ENTRY,NAME,ORGNAME
+22 SET ENTRY=ROOT_IENN_","_"0)"
+23 SET NAME=$PIECE($GET(@ENTRY),U,1)
SET ORGNAME=NAME
+24 ; If there is a VA- or VA*- in the copied name get rid of it.
+25 IF $FIND(NAME,"VA-")>0
SET NAME=$$STRREP(NAME,"VA-","")
+26 IF $FIND(NAME,"VA*-")>0
SET NAME=$$STRREP(NAME,"VA*-","")
+27 ;
UNIQ ;Make sure the name is unique.
+1 SET Y=""
+2 IF $DATA(^AUTTEDT("B",NAME))
Begin DoDot:1
+3 SET DIR(0)="F"_U_"3:30"_U_"K:(X?.N)!'(X'?1P.E) X"
+4 SET DIR("A")=NAME_" - IS A DUPLICATE NAME, PLEASE ENTER A UNIQUE NAME"
+5 DO ^DIR
IF $DATA(DIRUT)
DO DELETE
QUIT
+6 SET NAME=Y
End DoDot:1
if $DATA(DIRUT)
QUIT
+7 IF Y'=""
GOTO UNIQ
+8 ;
NOVA ;Sites are not allowed to use VA in their names.
+1 SET Y=""
+2 IF '$GET(PXNAT)&($$VADSTN(NAME))
Begin DoDot:1
+3 SET DIR(0)="F"_U_"3:30"_U_"K:(X?.N)!'(X'?1P.E) X"
+4 SET DIR("A")=NAME_" CANNOT START WITH ""VA-"", INPUT A DIFFERENT ONE"
+5 DO ^DIR
IF $DATA(DIRUT)
DO DELETE
QUIT
+6 SET NAME=Y
End DoDot:1
if $DATA(DIRUT)
QUIT
+7 IF Y'=""
GOTO UNIQ
+8 ;
+9 ;Store the unique name
+10 SET DR=".01///^S X=NAME"
SET DIE=ROOT
SET DA=IENN
+11 DO ^DIE
+12 ;
+13 ;Reindex the cross-references.
+14 SET DIK=ROOT
SET DA=IENN
+15 DO IX^DIK
+16 ;
+17 ;Tell the user what has happened and allow for editing of the new item.
+18 WRITE !
+19 SET DIR(0)="Y"
+20 SET DIR("A")="Do you want to edit it now"
+21 SET DIR("A",1)="The original education topic "_ORGNAME_" has been copied into "_NAME_"."
+22 DO ^DIR
if $DATA(DIRUT)
QUIT
+23 IF Y
Begin DoDot:1
+24 NEW DIE,DR
+25 SET DIE=ROOT
SET DR="[PXTT EDIT PAT. EDUCATION]"
+26 DO ^DIE
+27 QUIT
End DoDot:1
+28 QUIT
+29 ;
+30 ;=======================================================================
GETFOIEN(ROOT,SIEN) ;Given ROOT and a starting IEN (SIEN) return the first
+1 ;open IEN in ROOT
+2 NEW ENTRY,NIEN,OIEN
+3 SET OIEN=SIEN-1
+4 SET ENTRY=ROOT_OIEN_")"
+5 FOR
SET NIEN=$ORDER(@ENTRY)
if +(NIEN-OIEN)>1
QUIT
if +NIEN'>0
QUIT
SET OIEN=NIEN
SET ENTRY=ROOT_NIEN_")"
+6 QUIT OIEN+1
+7 ;
+8 ;=======================================================================
MERGE(IENN,IENO,ROOT) ;Use MERGE to copy ROOT(IENO into ROOT(IENN.
+1 NEW DEST,SOURCE
+2 ;
+3 SET DEST=ROOT_IENN_")"
+4 SET SOURCE=ROOT_IENO_")"
+5 MERGE @DEST=@SOURCE
+6 QUIT
+7 ;
+8 ;=======================================================================
VADSTN(NAME) ;Return TRUE (1) if VA- starts the NAME.
+1 IF $FIND(NAME,"VA-")=4
QUIT 1
+2 IF $FIND(NAME,"VA*-")=5
QUIT 1
+3 IF '$TEST
QUIT 0
+4 ;
+5 ;=======================================================================
STRREP(STRING,TS,RS) ;Replace every occurence of the target string (TS)
+1 ;in STRING with the replacement string (RS).
+2 ;Example 9.19 (page 220) in "The Complete Mumps" by John Lewkowicz:
+3 ;
+4 NEW FROM,NPCS,STR
+5 ;
+6 IF STRING'[TS
QUIT STRING
+7 ;Count the number of pieces using the target string as the delimiter.
+8 SET FROM=1
+9 FOR NPCS=1:1
SET FROM=$FIND(STRING,TS,FROM)
if FROM=0
QUIT
+10 ;Extract the pieces and concatenate RS
+11 SET STR=""
+12 FOR FROM=1:1:NPCS-1
SET STR=STR_$PIECE(STRING,TS,FROM)_RS
+13 SET STR=STR_$PIECE(STRING,TS,NPCS)
+14 QUIT STR
+15 ;
DELETE ;Delete the entry just added.
+1 SET DIK=ROOT
SET DA=IENN
DO ^DIK
+2 WRITE !!,"New entry not created due to invalid education topic name!",!
+3 QUIT
+4 ;
