PXRMCPLS ;SLC/PKR - Copy various reminder files. ;09/25/2013
;;2.0;CLINICAL REMINDERS;**26**;Feb 04, 2005;Build 404
;New version of PXRMCOPY for List Manager ScreenMan
;applications. This can eventually replace PXRMCOPY.
;================================
COPY(FILENUM,IEN) ;Copy an entry of ROOT into a new entry.
N DA,DIK,DIR,DIROUT,DIRUT,DTOUT,DUOUT,FDA,FIELDLEN,FILENAME
N IENN,IENS,MSG,NAME,ORIGNAME,ROOT,X,Y
S ROOT=$$ROOT^DILFD(FILENUM)
S FILENAME=$$GET1^DID(FILENUM,"","","NAME")
S FILENAME=$$LOW^XLFSTR(FILENAME)
S ORIGNAME=$$GET1^DIQ(FILENUM,IEN,.01)
;Get the new name.
S FIELDLEN=$$GET1^DID(FILENUM,.01,"","FIELD LENGTH")
S DIR(0)="F"_U_"3:"_FIELDLEN_U_"K:(X?.N)!'(X'?1P.E) X"
S DIR("A")="Enter a Unique Name"
GETNAM D ^DIR
I $D(DIRUT) Q
S NAME=Y
;
;Make sure the new name is valid and unique.
I '$$VNAME^PXRMINTR(NAME) G GETNAM
I $$EXISTS^PXRMEXIU(FILENUM,NAME) D G GETNAM
. W !,"There is already an entry with that name!"
;
;Set the starting place for additions and do the merge.
D SETSTART^PXRMCOPY(ROOT)
S IENN=$$GETFOIEN(ROOT)
D MERGE(IENN,IEN,ROOT)
;
;Change to the new name.
S IENS=IENN_","
S FDA(FILENUM,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(FILENUM,IENN,"L","")
;Initialize the change log.
D INIEH(FILENUM,ROOT,IENN,IEN)
;
;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 "_FILENAME_" "_ORIGNAME_" has been copied into "_NAME_"."
D ^DIR Q:$D(DIRUT)
I Y D EDIT(FILENUM,IENN)
Q
;
;================================
EDIT(FILENUM,IEN) ;Call the appropriate editor.
;The initial version only includes taxonomies.
I FILENUM=811.2 D SMANEDIT^PXRMTXSM(IEN,0,"PXRM TAXONOMY EDIT")
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,IEN) ;Initialize the change log after a copy.
;First delete any existing history entries.
N ENTRY,IND,IENS,FDA,FDAIEN,MSG,SFN,TARGET,WP
D FIELD^DID(FILENUM,"CHANGE LOG","","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 change log.
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,IEN,.01)
D UPDATE^DIE("E","FDA","FDAIEN","MSG")
I $D(MSG) D AWRITE^PXRMUTIL("MSG")
Q
;
;================================
MERGE(IENN,IEN,ROOT) ;Use MERGE to copy ROOT(IEN into ROOT(IENN.
N DEST,SOURCE
S DEST=ROOT_IENN_")"
;Lock the file before merging.
L +@DEST:DILOCKTM
S SOURCE=ROOT_IEN_")"
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
;
PXRMCPLS ;SLC/PKR - Copy various reminder files. ;09/25/2013
+1 ;;2.0;CLINICAL REMINDERS;**26**;Feb 04, 2005;Build 404
+2 ;New version of PXRMCOPY for List Manager ScreenMan
+3 ;applications. This can eventually replace PXRMCOPY.
+4 ;================================
COPY(FILENUM,IEN) ;Copy an entry of ROOT into a new entry.
+1 NEW DA,DIK,DIR,DIROUT,DIRUT,DTOUT,DUOUT,FDA,FIELDLEN,FILENAME
+2 NEW IENN,IENS,MSG,NAME,ORIGNAME,ROOT,X,Y
+3 SET ROOT=$$ROOT^DILFD(FILENUM)
+4 SET FILENAME=$$GET1^DID(FILENUM,"","","NAME")
+5 SET FILENAME=$$LOW^XLFSTR(FILENAME)
+6 SET ORIGNAME=$$GET1^DIQ(FILENUM,IEN,.01)
+7 ;Get the new name.
+8 SET FIELDLEN=$$GET1^DID(FILENUM,.01,"","FIELD LENGTH")
+9 SET DIR(0)="F"_U_"3:"_FIELDLEN_U_"K:(X?.N)!'(X'?1P.E) X"
+10 SET DIR("A")="Enter a Unique Name"
GETNAM DO ^DIR
+1 IF $DATA(DIRUT)
QUIT
+2 SET NAME=Y
+3 ;
+4 ;Make sure the new name is valid and unique.
+5 IF '$$VNAME^PXRMINTR(NAME)
GOTO GETNAM
+6 IF $$EXISTS^PXRMEXIU(FILENUM,NAME)
Begin DoDot:1
+7 WRITE !,"There is already an entry with that name!"
End DoDot:1
GOTO GETNAM
+8 ;
+9 ;Set the starting place for additions and do the merge.
+10 DO SETSTART^PXRMCOPY(ROOT)
+11 SET IENN=$$GETFOIEN(ROOT)
+12 DO MERGE(IENN,IEN,ROOT)
+13 ;
+14 ;Change to the new name.
+15 SET IENS=IENN_","
+16 SET FDA(FILENUM,IENS,.01)=NAME
+17 KILL MSG
+18 DO FILE^DIE("","FDA","MSG")
+19 ;Check to make sure the name was not a duplicate.
+20 IF $GET(MSG("DIERR",1))=740
Begin DoDot:1
+21 WRITE !,NAME," is not a unique name!"
End DoDot:1
GOTO GETNAM
+22 ;Change the class to local and delete the sponsor.
+23 DO SCAS(FILENUM,IENN,"L","")
+24 ;Initialize the change log.
+25 DO INIEH(FILENUM,ROOT,IENN,IEN)
+26 ;
+27 ;Reindex the cross-references.
+28 SET DIK=ROOT
SET DA=IENN
+29 DO IX^DIK
+30 ;
+31 ;Tell the user what has happened and allow for editing of the new item.
+32 WRITE !
+33 SET DIR(0)="Y"
+34 SET DIR("A")="Do you want to edit it now"
+35 SET DIR("A",1)="The original "_FILENAME_" "_ORIGNAME_" has been copied into "_NAME_"."
+36 DO ^DIR
IF $DATA(DIRUT)
QUIT
+37 IF Y
DO EDIT(FILENUM,IENN)
+38 QUIT
+39 ;
+40 ;================================
EDIT(FILENUM,IEN) ;Call the appropriate editor.
+1 ;The initial version only includes taxonomies.
+2 IF FILENUM=811.2
DO SMANEDIT^PXRMTXSM(IEN,0,"PXRM TAXONOMY EDIT")
+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,IEN) ;Initialize the change log 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,"CHANGE LOG","","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 change log.
+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,IEN,.01)
+21 DO UPDATE^DIE("E","FDA","FDAIEN","MSG")
+22 IF $DATA(MSG)
DO AWRITE^PXRMUTIL("MSG")
+23 QUIT
+24 ;
+25 ;================================
MERGE(IENN,IEN,ROOT) ;Use MERGE to copy ROOT(IEN 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_IEN_")"
+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 ;
