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

TIUFHA8.m

Go to the documentation of this file.
  1. TIUFHA8 ; SLC/MAM - MOVEDOC, MDRPOINT(OLDTLDA,NEWTLDA,POLDTLDA,PNEWTLDA,NOLOCK), NEWTITLE(FILEDA,PFILEDA), MTRPOINT(TITLEDA,OLDCLASS) ;1/29/06
  1. ;;1.0;TEXT INTEGRATION UTILITIES;**11,27,64,184**;Jun 20, 1997
  1. ;
  1. CANT(FILEDA,NODE0) ; Check if docmts can be moved; return 1 if cant
  1. N CANTMSG,CANT S CANT=0
  1. I $P(NODE0,U,4)'="DOC" S CANTMSG=" ?? Entry must be a TITLE (not a Document Class, etc.)" G:$D(CANTMSG) CANTX
  1. I $$HASITEMS^TIUFLF1(FILEDA) S CANTMSG=" ?? Documents cannot be moved for Titles with Components" G:$D(CANTMSG) CANTX
  1. I '$O(^TIU(8925,"B",FILEDA,0)) S CANTMSG=" ?? Title has no documents to move" G:$D(CANTMSG) CANTX
  1. I FILEDA=81 S CANTMSG=" ?? Can't Move Addenda" G:$D(CANTMSG) CANTX
  1. I $$ISPFTTL^TIUPRFL(FILEDA) S CANTMSG=" ?? Documents cannot be moved for PRF Flag Titles" G:$D(CANTMSG) CANTX
  1. CANTX I $D(CANTMSG) W !,CANTMSG,! D PAUSE^TIUFXHLX S CANT=1
  1. Q CANT
  1. ;
  1. MOVEDOC ; Move documents from old Title to new Title. Template H ONLY. Titles must have same grandparent. Titles cannot have components.
  1. N INFO,FILEDA,NODE0,PFILEDA,TENDA,NEWTLY,LINENO,PLINENO
  1. N DA,DIK,NPLINENO,DIR,NPFILEDA,NOLOCK,CWAD1,CWAD2
  1. ; N DIR for EN^VALM2 default
  1. S VALM("ENTITY")="Title whose documents you want to Move"
  1. AGAINDOC D EN^VALM2(TIUFXNOD,"SO") G:'$O(VALMY(0)) MDOCX S INFO=$G(^TMP("TIUF1IDX",$J,$O(VALMY(0)))) I 'INFO W !," Missing List Manager Data; See IRM",! D PAUSE^TIUFXHLX S VALMBCK="Q" G MDOCX
  1. S FILEDA=$P(INFO,U,2),NODE0=^TIU(8925.1,FILEDA,0),LINENO=+INFO
  1. N DIRUT
  1. ; - Check selected title. Need TIUFXNOD phrase to prevent loop:
  1. I $$CANT(FILEDA,NODE0) G MDOCX:$D(DIRUT)!(TIUFXNOD["="),AGAINDOC
  1. S PFILEDA=+$O(^TIU(8925.1,"AD",FILEDA,0)),PLINENO=$P(INFO,U,5)
  1. S TENDA=$P(INFO,U,6)
  1. S VALMBCK="R" K DIRUT
  1. S NEWTLY=$$NEWTITLE(FILEDA,PFILEDA)
  1. I 'NEWTLY G MDOCX
  1. D I 'NEWTLY G MDOCX ;P64 add Are you sure; add CWAD/nonCWAD warning
  1. . S DIR(0)="Y",DIR("B")="YES",DIR("?")=" Action not reversible if target title already has its own documents."
  1. . S DIR("A",1)="Moving documents from title",DIR("A",2)=" "_$P(NODE0,U),DIR("A",3)=" to title "_$P(NEWTLY,U,2)_"."
  1. . S DIR("A")=" Are you sure"
  1. . S NPFILEDA=+$O(^TIU(8925.1,"AD",+NEWTLY,0)),CWAD1=$P($G(^TIU(8925.1,NPFILEDA,0)),U,14),CWAD2=$P($G(^TIU(8925.1,PFILEDA,0)),U,14)
  1. . I (CWAD1="")&(CWAD2'="")!((CWAD1'="")&(CWAD2="")) S DIR("A")="CWADs behave differently from nonCWAD documents. Sure you want to move",DIR("B")="NO",DIR("?")=" CWADs generate alerts; nonCWADs don't."
  1. . W ! D ^DIR I 'Y S NEWTLY=0
  1. I $P(NODE0,U,7)'=+^TMP("TIUF",$J,"STATI") D AUTOSTAT^TIUFLF6(FILEDA,NODE0,"INACTIVE")
  1. S NOLOCK=0 D MDRPOINT(FILEDA,+NEWTLY,PFILEDA,NPFILEDA,.NOLOCK)
  1. W ! W:NOLOCK "...done. Please move remaining documents later."
  1. W:'NOLOCK "...done. All documents Moved to Title ",$P(NEWTLY,U,2),".",!,"Parent Document Type updated as necessary for all documents."
  1. W !!,"If you want users to be able to enter more documents on the OLD TITLE,",!,"please reactivate it."
  1. D PAUSE^TIUFXHLX
  1. S NPLINENO=+$O(^TMP("TIUF1IDX",$J,"DAF",NPFILEDA,0))
  1. I NPFILEDA'=PFILEDA D REEXPAND^TIUFHA7(PFILEDA,PLINENO,1)
  1. D REEXPAND^TIUFHA7(NPFILEDA,NPLINENO,1),VALMBG^TIUFHA7(+NEWTLY,FILEDA,LINENO)
  1. MDOCX I '$G(NEWTLY) W !,"...Nothing moved" H 2 ;P64 add Nothing moved
  1. S VALM("ENTITY")="Entry"
  1. Q
  1. ;
  1. MDRPOINT(OLDTLDA,NEWTLDA,POLDTLDA,PNEWTLDA,NOLOCK) ; Repoint for Move Documents from one title to another: Repoints TITLE and PARENT DOCUMENT TYPE for documents that use old title.
  1. ; If old and new titles are in same DC, skips repointing PARENT DOCUMENT TYPE.
  1. N DIE,DR,DA,FILEDA
  1. W !!,"OLD Title inactivated. Moving documents..."
  1. S DR=".01////"_NEWTLDA,DIE=8925
  1. S:POLDTLDA'=PNEWTLDA DR=DR_";.04////"_PNEWTLDA
  1. S FILEDA=0 F S FILEDA=$O(^TIU(8925,"B",OLDTLDA,FILEDA)) Q:'FILEDA D
  1. . L +^TIU(8925,FILEDA,0):1 I '$T W !,"...Document can't be locked. Please move it later. Continuing to move others...",! H 2 S NOLOCK=1 Q
  1. . S DA=FILEDA D ^DIE
  1. . W "." L -^TIU(8925,FILEDA,0)
  1. Q
  1. ;
  1. NEWTITLE(FILEDA,PFILEDA) ; Function returns DIC's Y=N^S of New Title to move documents to, or 0 if none chosen.
  1. ;Requires FILEDA = IFN of old Title
  1. ;Requires PFILEDA = parent of old Title
  1. N X,Y,DIC,DIR,NEWTLY,TIUFCK,NPFILEDA,GPFILEDA,OVERRIDE
  1. N SCRN1,SCRN2,SCRN3
  1. S GPFILEDA=+$O(^TIU(8925.1,"AD",PFILEDA,0)) ; G'parent of old Title
  1. AGAINNEW S DIC=8925.1,DIC(0)="AEMNQZ" K NEWTLY
  1. W !!," Selecting target Title."
  1. W " Enter '??' for a list of selectable ones.",!
  1. W " You may not select PRF Flag Titles or Titles outside"
  1. W " the original Class."
  1. S DIC("A")="Select TIU TITLE NAME to Move documents to: "
  1. ; - Type=TL, not=old title, not addm title, not PRF title,
  1. ; same g'parent (i.e. class):
  1. S SCRN1="I $P(^(0),U,4)=""DOC""&(Y'=FILEDA)&(Y'=81)"
  1. S SCRN2="&'$$ISPFTTL^TIUPRFL(Y)&(GPFILEDA="
  1. S SCRN3="+$O(^TIU(8925.1,""AD"",+$O(^TIU(8925.1,""AD"",Y,0)),0)))"
  1. S DIC("S")=SCRN1_SCRN2_SCRN3
  1. D ^DIC I Y=-1 G NEWTLX
  1. S NEWTLY=Y,NEWTLY(0)=Y(0),NPFILEDA=+$O(^TIU(8925.1,"AD",+NEWTLY,0))
  1. ;P64 removed "can't move docmts to natl titles"
  1. I $$HASITEMS^TIUFLF1(+NEWTLY) W !," ?? Documents cannot be moved to Titles with Components",! G AGAINNEW
  1. D CHECK^TIUFLF3(+NEWTLY,NPFILEDA,0,.TIUFCK)
  1. I 'TIUFCK D
  1. . W !!,"Faulty Title. Please TRY Title and correct problems",!,"before moving documents to it."
  1. . S OVERRIDE=$$OVERRIDE^TIUFHA2("select title even though it is FAULTY")
  1. . I 'OVERRIDE W " Documents NOT Moved.",! D PAUSE^TIUFXHLX K NEWTLY
  1. NEWTLX I $D(DTOUT) S VALMQUIT=1
  1. Q $S($G(NEWTLY):NEWTLY,1:0)
  1. ;
  1. MTRPOINT(TITLEDA,OLDCLASS) ; Repoint for Move Title from one DC to another:
  1. ; Repoints PARENT DOCUMENT TYPE to parent of TITLEDA for documents using
  1. ;title TITLEDA.
  1. ; If by special arrangement with TIU developers, Title is moved from one
  1. ;CLASS to another, ALSO resets class xrefs for documents using TITLEDA.
  1. ;Requires OLDCLASS = IFN of class title was moved FROM. Gets OLDCLASS
  1. ;from MOVETL, or from UPDATE using ^XTMP("TIUFMOVEN",TITLEDA) = OLDCLASS
  1. ; Requires TIUFMOVE,^XTMP("TIUFMOVE"[_N]_TLDA,0)
  1. N DIE,DR,DA,FILEDA,NOLOCK,XDCDA
  1. I '$O(^TIU(8925,"B",TITLEDA,0)) W !!,"Title has no documents to update.",! Q
  1. S NOLOCK=0,XDCDA=+$O(^TIU(8925.1,"AD",TITLEDA,0)) I 'XDCDA W !!,"Title has no parent.",! Q
  1. W !!,"Processing documents that use this Title...",!
  1. S FILEDA=0 F S FILEDA=$O(^TIU(8925,"B",TITLEDA,FILEDA)) Q:'FILEDA D MTRPT1(TITLEDA,FILEDA,XDCDA,+$G(OLDCLASS),.NOLOCK)
  1. W !,"Done."
  1. I NOLOCK D D PAUSE^TIUFXHLX Q
  1. . W !!," Since some documents needing update were (still) not available, please update",!,"them using action 'Update Documents' (again) for this title.",!
  1. . S ^XTMP("TIUFMOVE"_TIUFMOVE_TITLEDA,"ONCETHRU")=""
  1. W " All documents updated for selected Title.",!
  1. K ^XTMP("TIUFMOVE"_TIUFMOVE_TITLEDA) D PAUSE^TIUFXHLX
  1. Q
  1. ;
  1. MTRPT1(TITLEDA,DA,XDCDA,OLDCLASS,NOLOCK) ; Repoint 1 docmt for Move TL.
  1. ; Requires TITLEDA,DA,XDCDA,TIUFMOVE. Requires OLDCLASS>or=0.
  1. ; Kills DA node of ^XTMP("TIUFMOVE[N]"_TLDA if successfully updated.
  1. I $D(^XTMP("TIUFMOVE"_TIUFMOVE_TITLEDA,"ONCETHRU")),'$D(^XTMP("TIUFMOVE"_TIUFMOVE_TITLEDA,DA)) Q ;DA already updated
  1. I TIUFMOVE'="N",XDCDA=$P(^TIU(8925,DA,0),U,4) Q ; move NOT between CLASSES, Parent Docmt Type already ok.
  1. L +^TIU(8925,DA,0):1 I '$T W !,"...Document ",DA," can't be locked, not updated.",! S NOLOCK=1 S ^XTMP("TIUFMOVE"_TIUFMOVE_TITLEDA,DA)="" Q
  1. S DR=".04////"_XDCDA,DIE=8925 D ^DIE
  1. I OLDCLASS D CLXREF^TIUFHA9(DA,OLDCLASS)
  1. L -^TIU(8925,DA,0)
  1. I $G(ACTION)="U" W !,"Document ",DA," updated"
  1. E W "."
  1. K ^XTMP("TIUFMOVE"_TIUFMOVE_TITLEDA,DA)
  1. Q
  1. ;
  1. DCDOCMTS(XDCLASS,OLDCLASS) ; Updates CLASS xrefs for documents using DC XDCLASS
  1. N TENDA,TITLEDA
  1. S TENDA=0
  1. F S TENDA=$O(^TIU(8925.1,XDCLASS,10,TENDA)) Q:'TENDA D
  1. . S TITLEDA=+^TIU(8925.1,XDCLASS,10,TENDA,0) Q:'TITLEDA
  1. . D TLDOCMTS(TITLEDA,OLDCLASS)
  1. Q
  1. ;
  1. TLDOCMTS(TITLEDA,OLDCLASS) ; Updates CLASS xrefs for documents using title TITLEDA.
  1. N DIE,DR,DA,FILEDA,NOLOCK,XDCDA
  1. I '$O(^TIU(8925,"B",TITLEDA,0)) Q
  1. ;I '$O(^TIU(8925,"B",TITLEDA,0)) W !!,"Title has no documents to update.",! Q
  1. ;W !!,"Updating CLASS cross-references for documents that use this Title...",!
  1. S FILEDA=0 F S FILEDA=$O(^TIU(8925,"B",TITLEDA,FILEDA)) Q:'FILEDA D CLXREF^TIUFHA9(FILEDA,OLDCLASS)
  1. ;W !,"Done."
  1. W "."
  1. Q
  1. ;