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

PXRMCOPY.m

Go to the documentation of this file. 
  1. PXRMCOPY ; SLC/PKR,PJH - Copy various reminder files. ;01/28/2013
  1.  ;;2.0;CLINICAL REMINDERS;**6,12,26**;Feb 04, 2005;Build 404
  1.  ;
  1.  ;=====================================================
  1. COPY(PROMPT,ROOT,WHAT) ;Copy an entry of ROOT into a new entry.
  1.  N DIROUT,DTOUT,DUOUT
  1.  F  D GETORGR Q:$D(DIROUT)  Q:$D(DTOUT)
  1.  Q
  1.  ;
  1.  ;=====================================================
  1. GETORGR ;Look-up logic to get and copy source entry to destination.
  1.  N DA,DIE,DIC,DIK,DIR,DIRUT,FDA,FIELDLEN,FILE
  1.  N IENN,IENO,IENS,MSG,NAME,ORGNAME,X,Y
  1.  S DIC=ROOT,DIC(0)="AEMQ",DIC("A")=PROMPT
  1.  W !
  1.  D ^DIC
  1.  I $D(DUOUT)!$D(DTOUT) S DIROUT="" Q
  1.  S IENO=$P(Y,U,1)
  1.  I IENO=-1 S DIROUT="" Q
  1.  ;
  1.  ;Set the starting place for additions.
  1.  D SETSTART^PXRMCOPY(DIC)
  1.  S IENN=$$GETFOIEN(ROOT)
  1.  D MERGE(IENN,IENO,ROOT)
  1.  ;
  1.  ;Get the new name.
  1.  S ORGNAME=$P(@(ROOT_IENO_",0)"),U,1)
  1.  S FILE=$$FNFR^PXRMUTIL(ROOT)
  1.  S FIELDLEN=$$GET1^DID(FILE,.01,"","FIELD LENGTH")
  1.  S DIR(0)="F"_U_"3:"_FIELDLEN_U_"K:(X?.N)!'(X'?1P.E) X"
  1.  S DIR("A")="PLEASE ENTER A UNIQUE NAME"
  1. GETNAM D ^DIR
  1.  I $D(DIRUT) D DELETE(ROOT,IENN) Q
  1.  S NAME=Y
  1.  ;
  1.  ;Make sure the new name is valid.
  1.  I '$$VNAME^PXRMINTR(NAME) G GETNAM
  1.  ;
  1.  ;Change to the new name.
  1.  S IENS=IENN_","
  1.  S FDA(FILE,IENS,.01)=NAME
  1.  K MSG
  1.  D FILE^DIE("","FDA","MSG")
  1.  ;Check to make sure the name was not a duplicate.
  1.  I $G(MSG("DIERR",1))=740 D  G GETNAM
  1.  . W !,NAME," is not a unique name!"
  1.  ;Change the class to local and delete the sponsor.
  1.  D SCAS(FILE,IENN,"L","")
  1.  ;Initialize the edit history.
  1.  D INIEH(FILE,ROOT,IENN,IENO)
  1.  ;
  1.  ;Reindex the cross-references.
  1.  S DIK=ROOT,DA=IENN
  1.  D IX^DIK
  1.  W !
  1.  ;
  1.  ;Tell the user what has happened and allow for editing of the new item.
  1.  S DIR(0)="Y"
  1.  S DIR("A")="Do you want to edit it now"
  1.  S DIR("A",1)="The original "_WHAT_" "_ORGNAME_" has been copied into "_NAME_"."
  1.  D ^DIR Q:$D(DIRUT)
  1.  I Y D EDIT^PXRMEDIT(ROOT,IENN)
  1.  Q
  1.  ;
  1.  ;=====================================================
  1. COPYLL ;Copy a location list.
  1.  N PROMPT,ROOT,WHAT
  1.  S WHAT="location list"
  1.  S ROOT="^PXRMD(810.9,"
  1.  S PROMPT="Select the reminder location list to copy: "
  1.  D COPY(PROMPT,ROOT,WHAT)
  1.  Q
  1.  ;
  1.  ;=====================================================
  1. COPYREM ;Copy a reminder definition.
  1.  N PROMPT,ROOT,WHAT
  1.  S WHAT="reminder"
  1.  S ROOT="^PXD(811.9,"
  1.  S PROMPT="Select the reminder definition to copy: "
  1.  D COPY(PROMPT,ROOT,WHAT)
  1.  Q
  1.  ;
  1.  ;=====================================================
  1. COPYTAX ;Copy a taxonomy.
  1.  N PROMPT,ROOT,WHAT
  1.  S WHAT="taxonomy"
  1.  S ROOT="^PXD(811.2,"
  1.  S PROMPT="Select the reminder taxonomy to copy: "
  1.  D COPY(PROMPT,ROOT,WHAT)
  1.  Q
  1.  ;
  1.  ;=====================================================
  1. COPYTERM ;Copy a reminder term.
  1.  N PROMPT,ROOT,WHAT
  1.  S WHAT="reminder term"
  1.  S ROOT="^PXRMD(811.5,"
  1.  S PROMPT="Select the reminder term to copy: "
  1.  D COPY(PROMPT,ROOT,WHAT)
  1.  Q
  1.  ;
  1.  ;=====================================================
  1. DELETE(DIK,DA) ;Delete the entry just added. 
  1.  D ^DIK
  1.  W !!,"New entry not created due to invalid name!",!
  1.  Q
  1.  ;
  1.  ;=====================================================
  1. GETFOIEN(ROOT) ;Return the first open IEN in ROOT. This should be called
  1.  ;after a call to SETSTART.
  1.  N ENTRY,NIEN,OIEN
  1.  S ENTRY=ROOT_0_")"
  1.  S OIEN=+$P(@ENTRY,U,3)
  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. INIEH(FILENUM,ROOT,IENN,IENO) ;Initialize the edit history after a copy.
  1.  ;First delete any existing history entries.
  1.  N ENTRY,IND,IENS,FDA,FDAIEN,MSG,SFN,TARGET,WP
  1.  D FIELD^DID(FILENUM,"EDIT HISTORY","","SPECIFIER","TARGET")
  1.  S SFN=+$G(TARGET("SPECIFIER"))
  1.  I SFN=0 Q
  1.  S ENTRY=ROOT_IENN_",110)"
  1.  S IND=0
  1.  F  S IND=$O(@ENTRY@(IND)) Q:+IND=0  D
  1.  . S IENS=IND_","_IENN_","
  1.  . S FDA(SFN,IENS,.01)="@"
  1.  I $D(FDA(SFN)) D FILE^DIE("K","FDA","MSG")
  1.  I $D(MSG) D AWRITE^PXRMUTIL("MSG")
  1.  ;Establish an initial entry in the edit history.
  1.  K FDA,MSG
  1.  S IENS="+1,"_IENN_","
  1.  S FDAIEN(IENN)=IENN
  1.  S FDA(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
  1.  S FDA(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01)
  1.  S FDA(SFN,IENS,2)="WP(1,1)"
  1.  S WP(1,1,1)="Copied from "_$$GET1^DIQ(FILENUM,IENO,.01)
  1.  D UPDATE^DIE("E","FDA","FDAIEN","MSG")
  1.  I $D(MSG) D AWRITE^PXRMUTIL("MSG")
  1.  Q
  1.  ;
  1.  ;=====================================================
  1. MERGE(IENN,IENO,ROOT) ;Use MERGE to copy ROOT(IENO into ROOT(IENN.
  1.  N DEST,SOURCE
  1.  S DEST=ROOT_IENN_")"
  1.  ;Lock the file before merging.
  1.  L +@DEST:DILOCKTM
  1.  S SOURCE=ROOT_IENO_")"
  1.  M @DEST=@SOURCE
  1.  ;Unlock the file
  1.  L -@DEST
  1.  Q
  1.  ;
  1.  ;=====================================================
  1. SCAS(FILENUM,IEN,CLASS,SPONSOR) ;Set the class field to CLASS and the sponsor
  1.  ;field to SPONSOR.
  1.  N IENS,FDA,MSG
  1.  S IENS=IEN_","
  1.  S FDA(FILENUM,IENS,100)=CLASS
  1.  S FDA(FILENUM,IENS,101)=SPONSOR
  1.  D FILE^DIE("K","FDA","MSG")
  1.  I $D(MSG) D AWRITE^PXRMUTIL("MSG")
  1.  Q
  1.  ;
  1.  ;=====================================================
  1. SETSTART(ROOT) ;Set the starting value to add new entries. Start
  1.  ;at the begining so empty spaces are filled in.
  1.  N CUR,ENTRY
  1.  S ENTRY=ROOT_"0)"
  1.  S $P(@ENTRY,U,3)=1
  1.  Q
  1.  ;