- DITP ;SFISC/GFT-TRANSFER POINTERS ;6:40 AM 16 Jun 2000 [ 04/02/2003 8:25 AM ]
- ;;22.0;VA FileMan;**1001**;APR 1, 2003
- ;;22.0;VA FileMan;**50**;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- D ASK Q:%-1 G PTS
- ;
- ASK ;
- I '$D(^UTILITY("DIT",$J,0,1)) S %=2 Q
- S %=$O(^(1)),%Y=+^(1) S:%="" %=-1
- U I $D(^DD(%Y,0,"UP")) S %Y=^("UP") G U
- W !,"SINCE THE "_$P("TRANSFERRED^DELETED",U,DH+1)_" ENTRY MAY HAVE BEEN 'POINTED TO'"
- W !,"BY ENTRIES IN THE '"_$P(^DIC(+%Y,0),U,1)_"' FILE," W:%>1 " ETC.,"
- Q W !,"DO YOU WANT THOSE POINTERS UPDATED (WHICH COULD TAKE QUITE A WHILE)"
- S %=2 D YN^DICN Q:% W !?4,"ANSWER 'YES' IF YOU THINK THAT THE ENTRY WHICH YOU HAVE JUST "_$P("MOVED^DELETED",U,DH+1),!?4,"MAY BE 'POINTED TO' BY SOME POINTER-TYPE FIELD VALUE SOMEWHERE",! G Q
- ;
- PTS ;
- D WAIT^DICD K IOP
- P K DR,D,DL,X S (BY,FR,TO)="",X=$O(^UTILITY("DIT",$J,0,0))
- I X="" K ^UTILITY("DIT",$J),DIA,DHD,DR,DISTOP,BY,TO,FR,FLDS,L Q
- S Y=^(X),L=$P(Y,U,2),DL=1
- S DL(1)=L_"////^S X=$S($D(DE(DQ))[0:"""",$D(^UTILITY(""DIT"",$J,DE(DQ)))-1:"""",^(DE(DQ)):"_$S($P(Y,U,3)'["V":"+",1:"")_"^(DE(DQ)),1:""@"") I X]"""",$G(DIFIXPT)=1 D PTRPT^DITP" K ^(X)
- S L=$P(^DD(+Y,L,0),U,4),%=$P(L,";",2),L=""""_$P(L,";",1)_"""",DHD=$P(^(0),U) I % S %="$P(^("_L_"),U,"_%
- E S %="$E(^("_L_"),"_+$E(%,2,9)_","_$P(%,",",2)
- S L=L_")):"""","_%_")?."" "":"""",'$D(^UTILITY(""DIT"",$J,"_$S($P(Y,U,3)'["V":"+",1:"")_%_"))):"""",1:D"
- UP S (D(DL),%)=+Y I $D(^DD(%,0,"UP")) S DL=DL+1,Y=^("UP"),(DL(DL),%)=$O(^DD(Y,"SB",%,0))_"///",X(DL)=""""_$P($P(^DD(Y,+%,0),U,4),";")_"""",BY=+%_","_BY G UP
- S DHD=$O(^("NM",0))_" entries whose '"_DHD_"' pointers have been changed" G P:'$D(^DIC(%,0,"GL")) S DIC=^("GL"),Y="S X=$S('$D("_DIC_"D0,"
- F X=0:1:DL-1 S DR(X+1,D(DL-X))=DL(DL-X) S:X Y=Y_X(DL+1-X)_",D"_X_","
- S DIA("P")=%,%=$L(BY,",") I %>2 S BY=$P(BY,",",%-2)_",.01,"_BY
- S BY=BY_Y_L_X_")",L=0,FLDS="",DISTOP=0,DHIT="G LOOP^DIA2",%ZIS=""
- I $G(DIFIXPT)=1 D EN1^DIP G P
- D EN1^DIP
- S IOP=$G(IO) G P
- ;
- PTRPT Q:'$G(DIFIXPTC) N I,J,X
- F I=1:1:DL S J="" F S J=$O(DR(I,J)) Q:J="" I DR(I,J)["///" S X=$P($G(DR(I,J)),"///",1) I X]"" D
- . S ^TMP("DIFIXPT",$J,DIFIXPTC)=^TMP("DIFIXPT",$J,DIFIXPTC)_$S(I>1:" entry:"_$S(I=DL:$G(DA),1:$G(DA(DL-I))),1:"")_$S(I=DL:" field:",1:" mult.fld:")_X
- . Q
- Q
- DITP ;SFISC/GFT-TRANSFER POINTERS ;6:40 AM 16 Jun 2000 [ 04/02/2003 8:25 AM ]
- +1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
- +2 ;;22.0;VA FileMan;**50**;Mar 30, 1999
- +3 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +4 DO ASK
- IF %-1
- QUIT
- GOTO PTS
- +5 ;
- ASK ;
- +1 IF '$DATA(^UTILITY("DIT",$JOB,0,1))
- SET %=2
- QUIT
- +2 SET %=$ORDER(^(1))
- SET %Y=+^(1)
- IF %=""
- SET %=-1
- U IF $DATA(^DD(%Y,0,"UP"))
- SET %Y=^("UP")
- GOTO U
- +1 WRITE !,"SINCE THE "_$PIECE("TRANSFERRED^DELETED",U,DH+1)_" ENTRY MAY HAVE BEEN 'POINTED TO'"
- +2 WRITE !,"BY ENTRIES IN THE '"_$PIECE(^DIC(+%Y,0),U,1)_"' FILE,"
- IF %>1
- WRITE " ETC.,"
- Q WRITE !,"DO YOU WANT THOSE POINTERS UPDATED (WHICH COULD TAKE QUITE A WHILE)"
- +1 SET %=2
- DO YN^DICN
- IF %
- QUIT
- WRITE !?4,"ANSWER 'YES' IF YOU THINK THAT THE ENTRY WHICH YOU HAVE JUST "_$PIECE("MOVED^DELETED",U,DH+1),!?4,"MAY BE 'POINTED TO' BY SOME POINTER-TYPE FIELD VALUE SOMEWHERE",!
- GOTO Q
- +2 ;
- PTS ;
- +1 DO WAIT^DICD
- KILL IOP
- P KILL DR,D,DL,X
- SET (BY,FR,TO)=""
- SET X=$ORDER(^UTILITY("DIT",$JOB,0,0))
- +1 IF X=""
- KILL ^UTILITY("DIT",$JOB),DIA,DHD,DR,DISTOP,BY,TO,FR,FLDS,L
- QUIT
- +2 SET Y=^(X)
- SET L=$PIECE(Y,U,2)
- SET DL=1
- +3 SET DL(1)=L_"////^S X=$S($D(DE(DQ))[0:"""",$D(^UTILITY(""DIT"",$J,DE(DQ)))-1:"""",^(DE(DQ)):"_$SELECT($PIECE(Y,U,3)'["V":"+",1:"")_"^(DE(DQ)),1:""@"") I X]"""",$G(DIFIXPT)=1 D PTRPT^DITP"
- KILL ^(X)
- +4 SET L=$PIECE(^DD(+Y,L,0),U,4)
- SET %=$PIECE(L,";",2)
- SET L=""""_$PIECE(L,";",1)_""""
- SET DHD=$PIECE(^(0),U)
- IF %
- SET %="$P(^("_L_"),U,"_%
- +5 IF '$TEST
- SET %="$E(^("_L_"),"_+$EXTRACT(%,2,9)_","_$PIECE(%,",",2)
- +6 SET L=L_")):"""","_%_")?."" "":"""",'$D(^UTILITY(""DIT"",$J,"_$SELECT($PIECE(Y,U,3)'["V":"+",1:"")_%_"))):"""",1:D"
- UP SET (D(DL),%)=+Y
- IF $DATA(^DD(%,0,"UP"))
- SET DL=DL+1
- SET Y=^("UP")
- SET (DL(DL),%)=$ORDER(^DD(Y,"SB",%,0))_"///"
- SET X(DL)=""""_$PIECE($PIECE(^DD(Y,+%,0),U,4),";")_""""
- SET BY=+%_","_BY
- GOTO UP
- +1 SET DHD=$ORDER(^("NM",0))_" entries whose '"_DHD_"' pointers have been changed"
- IF '$DATA(^DIC(%,0,"GL"))
- GOTO P
- SET DIC=^("GL")
- SET Y="S X=$S('$D("_DIC_"D0,"
- +2 FOR X=0:1:DL-1
- SET DR(X+1,D(DL-X))=DL(DL-X)
- IF X
- SET Y=Y_X(DL+1-X)_",D"_X_","
- +3 SET DIA("P")=%
- SET %=$LENGTH(BY,",")
- IF %>2
- SET BY=$PIECE(BY,",",%-2)_",.01,"_BY
- +4 SET BY=BY_Y_L_X_")"
- SET L=0
- SET FLDS=""
- SET DISTOP=0
- SET DHIT="G LOOP^DIA2"
- SET %ZIS=""
- +5 IF $GET(DIFIXPT)=1
- DO EN1^DIP
- GOTO P
- +6 DO EN1^DIP
- +7 SET IOP=$GET(IO)
- GOTO P
- +8 ;
- PTRPT IF '$GET(DIFIXPTC)
- QUIT
- NEW I,J,X
- +1 FOR I=1:1:DL
- SET J=""
- FOR
- SET J=$ORDER(DR(I,J))
- IF J=""
- QUIT
- IF DR(I,J)["///"
- SET X=$PIECE($GET(DR(I,J)),"///",1)
- IF X]""
- Begin DoDot:1
- +2 SET ^TMP("DIFIXPT",$JOB,DIFIXPTC)=^TMP("DIFIXPT",$JOB,DIFIXPTC)_$SELECT(I>1:" entry:"_$SELECT(I=DL:$GET(DA),1:$GET(DA(DL-I))),1:"")_$SELECT(I=DL:" field:",1:" mult.fld:")_X
- +3 QUIT
- End DoDot:1
- +4 QUIT
