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