- 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 Feb 18, 2025@23:57:45 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 ;