Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXTTEDC

PXTTEDC.m

Go to the documentation of this file.
  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
  1. ;;1.0;PCE PATIENT CARE ENCOUNTER;**106**;Aug 12, 1996
  1. ;
  1. ;=======================================================================
  1. COPYED ;Copy an education topic into the site's range of IENS.
  1. N PROMPT,ROOT,WHAT
  1. S WHAT="education topic"
  1. S ROOT="^AUTTEDT("
  1. S PROMPT="Select the EDUCATION TOPIC to copy: "
  1. D COPY(PROMPT,ROOT)
  1. Q
  1. ;
  1. ;=======================================================================
  1. COPY(PROMPT,ROOT) ;Copy an entry of ROOT into a new entry.
  1. N DIC,DUOUT,DTOUT,DIROUT,DIRUT,SIEN,IENN,IENO,PXTTSNUM,X,Y
  1. S PXTTSNUM=+$P($$SITE^VASITE,U,3)
  1. I $L(PXTTSNUM)'=3 W !,"You must have a 3-digit primary station number in order to use this option, See IRM!" Q
  1. ;
  1. F D GETORGR Q:$D(DIROUT) Q:$D(DTOUT)
  1. Q
  1. ;
  1. 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
  1. ; file:
  1. ; PXTT COPY EDUCATION TOPICS
  1. ; while copying a topic in a national package
  1. ;
  1. S DIC=ROOT,DIC(0)="AMEQ",DIC("A")=PROMPT
  1. W !
  1. D ^DIC I $D(DUOUT)!$D(DTOUT) S DIROUT="" Q
  1. S IENO=$P(Y,U,1)
  1. I IENO=-1 S DIROUT="" Q
  1. ;
  1. S IENN=$S(+$G(PXNAT):1,1:+PXTTSNUM_"001")
  1. S IENN=$$GETFOIEN(ROOT,IENN)
  1. ;Lock the file before merging.
  1. L +^AUTTEDT(IENN):10
  1. D MERGE(IENN,IENO,ROOT)
  1. ;
  1. ;Unlock the file.
  1. L -^AUTTEDT(IENN)
  1. ;
  1. N DA,DIE,DIK,DIR,DR,ENTRY,NAME,ORGNAME
  1. S ENTRY=ROOT_IENN_","_"0)"
  1. S NAME=$P($G(@ENTRY),U,1),ORGNAME=NAME
  1. ; If there is a VA- or VA*- in the copied name get rid of it.
  1. I $F(NAME,"VA-")>0 S NAME=$$STRREP(NAME,"VA-","")
  1. I $F(NAME,"VA*-")>0 S NAME=$$STRREP(NAME,"VA*-","")
  1. ;
  1. UNIQ ;Make sure the name is unique.
  1. S Y=""
  1. I $D(^AUTTEDT("B",NAME)) D Q:$D(DIRUT)
  1. . S DIR(0)="F"_U_"3:30"_U_"K:(X?.N)!'(X'?1P.E) X"
  1. . S DIR("A")=NAME_" - IS A DUPLICATE NAME, PLEASE ENTER A UNIQUE NAME"
  1. . D ^DIR I $D(DIRUT) D DELETE Q
  1. . S NAME=Y
  1. I Y'="" G UNIQ
  1. ;
  1. NOVA ;Sites are not allowed to use VA in their names.
  1. S Y=""
  1. I '$G(PXNAT)&($$VADSTN(NAME)) D Q:$D(DIRUT)
  1. . S DIR(0)="F"_U_"3:30"_U_"K:(X?.N)!'(X'?1P.E) X"
  1. . S DIR("A")=NAME_" CANNOT START WITH ""VA-"", INPUT A DIFFERENT ONE"
  1. . D ^DIR I $D(DIRUT) D DELETE Q
  1. . S NAME=Y
  1. I Y'="" G UNIQ
  1. ;
  1. ;Store the unique name
  1. S DR=".01///^S X=NAME",DIE=ROOT,DA=IENN
  1. D ^DIE
  1. ;
  1. ;Reindex the cross-references.
  1. S DIK=ROOT,DA=IENN
  1. D IX^DIK
  1. ;
  1. ;Tell the user what has happened and allow for editing of the new item.
  1. W !
  1. S DIR(0)="Y"
  1. S DIR("A")="Do you want to edit it now"
  1. S DIR("A",1)="The original education topic "_ORGNAME_" has been copied into "_NAME_"."
  1. D ^DIR Q:$D(DIRUT)
  1. I Y D
  1. . N DIE,DR
  1. . S DIE=ROOT,DR="[PXTT EDIT PAT. EDUCATION]"
  1. . D ^DIE
  1. . Q
  1. Q
  1. ;
  1. ;=======================================================================
  1. GETFOIEN(ROOT,SIEN) ;Given ROOT and a starting IEN (SIEN) return the first
  1. ;open IEN in ROOT
  1. N ENTRY,NIEN,OIEN
  1. S OIEN=SIEN-1
  1. S ENTRY=ROOT_OIEN_")"
  1. F S NIEN=$O(@ENTRY) Q:+(NIEN-OIEN)>1 Q:+NIEN'>0 S OIEN=NIEN,ENTRY=ROOT_NIEN_")"
  1. Q OIEN+1
  1. ;
  1. ;=======================================================================
  1. MERGE(IENN,IENO,ROOT) ;Use MERGE to copy ROOT(IENO into ROOT(IENN.
  1. N DEST,SOURCE
  1. ;
  1. S DEST=ROOT_IENN_")"
  1. S SOURCE=ROOT_IENO_")"
  1. M @DEST=@SOURCE
  1. Q
  1. ;
  1. ;=======================================================================
  1. VADSTN(NAME) ;Return TRUE (1) if VA- starts the NAME.
  1. I $F(NAME,"VA-")=4 Q 1
  1. I $F(NAME,"VA*-")=5 Q 1
  1. E Q 0
  1. ;
  1. ;=======================================================================
  1. STRREP(STRING,TS,RS) ;Replace every occurence of the target string (TS)
  1. ;in STRING with the replacement string (RS).
  1. ;Example 9.19 (page 220) in "The Complete Mumps" by John Lewkowicz:
  1. ;
  1. N FROM,NPCS,STR
  1. ;
  1. I STRING'[TS Q STRING
  1. ;Count the number of pieces using the target string as the delimiter.
  1. S FROM=1
  1. F NPCS=1:1 S FROM=$F(STRING,TS,FROM) Q:FROM=0
  1. ;Extract the pieces and concatenate RS
  1. S STR=""
  1. F FROM=1:1:NPCS-1 S STR=STR_$P(STRING,TS,FROM)_RS
  1. S STR=STR_$P(STRING,TS,NPCS)
  1. Q STR
  1. ;
  1. DELETE ;Delete the entry just added.
  1. S DIK=ROOT,DA=IENN D ^DIK
  1. W !!,"New entry not created due to invalid education topic name!",!
  1. Q
  1. ;