TMGDIA3 ;TMG/kst/Custom version of DIA3 ;03/25/06 ;;1.0;TMG-LIB;**1**;01/01/06 DIA3 ;SFISC/GFT-UPDATE POINTERS, CHECK CODE IN INPUT STRING, CHECK FILE ACCESS ;9/7/94 09:57 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ;"************************************************************************* ;"* Custom version of Fileman code, for customization ;"* Also includes code from DITP.m ;"************************************************************************* FIXPT(DIFLG,DIFILE,DIDELIEN,DIPTIEN) ;"Purpose: DELETE OR REPOINT POINTERS ;"Note: In V21, will just delete pointers. Later, DIPTIEN will be record to repoint to. ;"Input: DIFLG="D" (delete) ;" ADDED "R" (replace) //kt ;" DIFILE=File# previously pointed to ;" DIDELIEN=Record# previously pointed to ;" DIPTIEN=New pointed-to record(future) ;"//KT fixed to do now. ;" ;"//e.g. if wanting to replace all pointers to file#50, record#20 to record#40 (must be in file#50) ;" ;"// then DIFILE=50, DIDELIEN=20, DIPTIEN=40 ;"Output: ;"Result: none ;"Note: sample of array passed to P^DITP ;" 23510 is $J ;" 47 is IEN to be deleted in file 50 (stored at ^PSDRUG(*)) ;" 1646 is IEN to be substituted for all 47's ;" ;" First part of array is list of all files & fields that point to file ;" ---------------- ;" ^UTILITY("DIT",23510,0,1)="727.819^67^P50'" ;" ... ;" ^UTILITY("DIT",23510,0,54)="801.43^.02^RV" ;" ^UTILITY("DIT",23510,0,55)="810.31^.04^V" ;" ^UTILITY("DIT",23510,0,56)="810.32^.01^V" ;" ^UTILITY("DIT",23510,0,57)="811.52^.01^MVX" ;" ^UTILITY("DIT",23510,0,58)="811.902^.01^MVX" ;" ^UTILITY("DIT",23510,0,59)="9009032.4^.05^P50'" ;" ;" Second part of array is list of changes that should be made. Only 1 change shown here. ;" ---------------- ;" ^UTILITY("DIT",23510,47)="1646;PSDRUG(" ;" ^UTILITY("DIT",23510,"47;PSDRUG(")="1646;PSDRUG(" new %X,%Y,X,Y ;"new DIPTIEN ;//kt allow input value to be used. new DIFIXPT,DIFIXPTC,DIFIXPTH do if $G(X)]"" do BLD^DIALOG(201,X) quit ;"BUILD FILEMAN DIALOG . set X="DIFLG" quit:(($G(DIFLG)'="D")&($G(DIFLG)'="R")) ;"//kt added "R" . set X="DIDELIEN" Q:'$G(DIDELIEN) . set X="DIFILE" Q:'$G(DIFILE) Q:$G(^DIC(DIFILE,0,"GL"))="" . set X="DIPTIEN" . if (DIFLG="R"),$G(DIPTIEN) do quit:(Y="") . . set Y=$get(^DIC(DIFILE,0,"GL")) ;"//kt changed ^DD to ^DIC . . quit:Y="" . . if '$data(@(Y_DIPTIEN_",0)")) set Y="" quit . kill X . quit set DIPTIEN=+$G(DIPTIEN) set (DIFIXPT,DIFIXPTC)=1 new %,BY,D,DHD,DHIT,DIA,DIC,DISTOP,DL,DR,DTO,FLDS,FR,IOP,L,TO,X,Y,Z kill ^UTILITY("DIT",$J),^TMP("DIFIXPT",$J) set (DIFILE,DIA("P"),Y)=+DIFILE set (DIA,DTO)=^DIC(DIFILE,0,"GL") set DIA(1)=DIDELIEN do PTS^DIT set ^UTILITY("DIT",$J,0)=0 goto:$D(^(0))<9 QFIXPT set ^UTILITY("DIT",$J,DIA(1))=DIPTIEN_";"_$E(DIA,2,999) set ^UTILITY("DIT",$J,DIA(1)_";"_$E(DIA,2,999))=DIPTIEN_";"_$E(DIA,2,999) zwr ^UTILITY("DIT",$J,*) ;"do P^DITP ;"do P QFIXPT K ^UTILITY("DIT",$J),DIFLG,DIFILE,DIDELIEN,DIIOP,DIPTIEN quit ; ;"************************************************************************* ;"* Code below from DITP.m ;"************************************************************************* PTS ; D WAIT^DICD kill IOP P kill DR,D,DL,X set (BY,FR,TO)="" set X=$O(^UTILITY("DIT",$J,0,0)) if X="" do quit ;"<--- exit point from loop . K ^UTILITY("DIT",$J),DIA,DHD,DR,DISTOP,BY,TO,FR,FLDS,L set Y=^(X) ;"get value of entry e.g. 50^905^P50'X set L=$P(Y,U,2) ;"L= field# set DL=1 set DL(1)=L set DL(1)=DL(1)_"////^S X=$S($D(DE(DQ))[0:"""",$D(^UTILITY(""DIT"",$J,DE(DQ)))-1:"""",^(DE(DQ)):" set DL(1)=DL(1)_$S($P(Y,U,3)'["V":"+",1:"") set DL(1)=DL(1)_"^(DE(DQ)),1:""@"") I X]"""",$G(DIFIXPT)=1 D PTRPT^TMGDIA3" kill ^(X) ;"delete entry from top of list set L=$P(^DD(+Y,L,0),U,4) ;"+Y=File#, L=Field# --> L set to 4th piece of data dictionary entry, e.g. '8;6' set %=$P(L,";",2) ;"e.g. %=6 set L=""""_$P(L,";",1)_"""" ;"e.g. L="8" set DHD=$P(^(0),U) ;"DHD--> header for EN1^DIP if % set %="$P(^("_L_"),U,"_% ;"--> e.g. set %='$P(^(8),U,8 else set %="$E(^("_L_"),"_+$E(%,2,9)_","_$P(%,",",2) set L=L_")):"""","_%_")?."" "":"""",'$D(^UTILITY(""DIT"",$J,"_$S($P(Y,U,3)'["V":"+",1:"")_%_"))):"""",1:D" UP set D(DL)=+Y ;"+Y = File# set %=+Y ;"+Y = File# if $D(^DD(%,0,"UP")) do goto UP . set DL=DL+1 . set Y=^("UP") . set (DL(DL),%)=$O(^DD(Y,"SB",%,0))_"///" . set X(DL)=""""_$P($P(^DD(Y,+%,0),U,4),";")_"""" . set BY=+%_","_BY set DHD=$O(^("NM",0))_" entries whose '"_DHD_"' pointers have been changed" if '$D(^DIC(%,0,"GL")) goto P set DIC=^("GL") set Y="S X=$S('$D("_DIC_"D0," for X=0:1:DL-1 do . set DR(X+1,D(DL-X))=DL(DL-X) . if X set Y=Y_X(DL+1-X)_",D"_X_"," set DIA("P")=% set %=$L(BY,",") if %>2 set BY=$P(BY,",",%-2)_",.01,"_BY set BY=BY_Y_L_X_")" set L=0 set FLDS="" set DISTOP=0 set DHIT="G LOOP^DIA2" set %ZIS="" do EN1^DIP if $G(DIFIXPT)=1 goto P set IOP=$G(IO) goto P ; PTRPT quit:'$G(DIFIXPTC) new I,J,X for I=1:1:DL do . set J="" . for set J=$order(DR(I,J)) quit:J="" do . . if DR(I,J)["///" do . . . set X=$P($G(DR(I,J)),"///",1) . . . if X]"" do . . . . new s . . . . set s=^TMP("DIFIXPT",$J,DIFIXPTC) . . . . set s=s_$S(I>1:" entry:"_$S(I=DL:$G(DA),1:$G(DA(DL-I))),1:"") . . . . set s=s_$S(I=DL:" field:",1:" mult.fld:") . . . . set s=s_X . . . . set ^TMP("DIFIXPT",$J,DIFIXPTC)=s Q