PXRMCPLS.m

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       ;