- DITP ;SFISC/GFT-TRANSFER POINTERS ;17MAY2005
- ;;22.2;VA FileMan;**10**;Jan 05, 2016;Build 11
- ;;Per VA Directive 6402, this routine should not be modified.
- ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- ;;Licensed under the terms of the Apache License, Version 2.0.
- ;
- 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
- ;
- ;
- ;
- ;
- EN(DIFILE,DILIST) ;IF THERE ARE POINTERS TO FILE 'DIFILE', GO THRU THE DILIST AND CHANGE THE POINTERS
- K ^UTILITY("DIT",$J)
- N Y,DIA,DTO,DL
- S (DIA("P"),Y)=DIFILE,(DIA,DTO)=$G(^DIC(+DIFILE,0,"GL")) I DTO="" W "ERROR in specification" Q ;,DIA(1)=FROM
- D PTS^DIT
- S X=0 F Y=0:0 S Y=$O(DILIST(Y)) Q:'Y S %=$P(DILIST(Y),U,2) D I '$D(X) W "ERROR in specification" G END
- .I '%,"@"'[% K X Q
- .I %,'$D(@(DTO_"%)")) K X Q
- .S X=X+1,^UTILITY("DIT",$J,+DILIST(Y))=%_";"_$E(DTO,2,99)
- I X D P
- END K ^UTILITY("DIT",$J)
- Q
- ;
- PTS ;
- D WAIT^DICD K IOP
- ;At this point, e.g.^UTILITY("DIT",$J,0,1)=801.41^15^V
- ;and ^UTILITY("DIT",$J,38)="103;AUTTIMM(" meaning that pointers to entry 38 in ^AUTTIMM are being moved to 103
- P F S X=$O(^UTILITY("DIT",$J,0,0)) Q:X="" S Y=^UTILITY("DIT",$J,0,X),L=$P(Y,U,2) K ^(X) D 1(+Y,L,.DTO) ;KILL NODES AS WE PROCESS THEM
- K ^UTILITY("DIT",$J) Q
- ;
- 1(DIPFILE,DIPFIELD,DTO) ;CALL DIP PRINT MODULE ONCE TO GO THRU CHANGING ONE FIELD'S VALUE. 'DTO' IS ROOT OF FILE BEING POINTED TO.
- N DIPVP,DL,L,DHD,DIA,BY,DITPY,DR,D,X,FLDS,DIOBEG,FR,TO,DISTOP,DIOBEG
- S (BY,FR,TO)="",DIPVP=$P(^DD(DIPFILE,DIPFIELD,0),U,2)["V" Q:$P(^(0),U,2) ;A MULTIPLE CAN'T POINT
- S DL=1,DL(1)=DIPFIELD_"////^D STUFF^DITP("_(DIPVP)_")"
- ;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(DIPFILE,DIPFIELD,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_")):"""","_%_"?."" "":"""","
- I DIPVP,DTO]"" S L=L_"$P("_%_","";"",2)'="""_$E(DTO,2,99)_""":"""","
- S L=L_"'$D(^UTILITY(""DIT"",$J,+"_%_")):"""","
- 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"
- Q:'$D(^DIC(%,0,"GL")) S DIC=^("GL"),DITPY="S X=$S('$D("_DIC_"D0,"
- F X=0:1:DL-1 S DR(X+1,D(DL-X))=DL(DL-X) S:X DITPY=DITPY_X(DL+1-X)_",D"_X_","
- S DIA("P")=%,%=$L(BY,",") I %>2 S BY=$P(BY,",",%-2)_",.01,"_BY
- S DITPY=DITPY_L_"1:D"_X_")",BY=BY_"X DITPY;@"
- ;Now DITPY=e.g. S X=$S('$D(^AUPNVIMM(D0,"0")):"",$P(^("0"),U,1)?." ":"",'$D(^UTILITY("DIT",$J,+$P(^("0"),U,1))):"",1:D0)
- S L=0,FLDS="",DISTOP=0,DHIT="N DIFIXPT G LOOP^DIA2",%ZIS="",DIOBEG="W !!" ;It will happen in DIA2
- I $G(DIQUIET) K DIOBEG S DIFIXPT=1 ;DHD="@@"
- D EN1^DIP
- IOP S IOP=$S($G(IOS):"`"_IOS,1:$G(IO)) Q ;KEEP THE SAME OUTPUT DEVICE AS WE GO THRU DIFFERENT 'PRINTINGS'
- ;
- STUFF(VP) ;VP=BOOLEAN
- S X="" Q:$G(DE(DQ))=""
- N % S %=DE(DQ) Q:'%!'$D(^UTILITY("DIT",$J,+%)) ;^UTILITY("DIT",$J,38)="103;AUTTIMM(" means 'CHANGE OLD 38 TO 103' if we have a variable-pointer to ^AUTTIMM
- S X=^(+%) I 'VP S X=+X
- E S X=$S($P(X,";",2)'=$P(%,";",2):"",'X:"@",1:X) W:X="" " (no change)" Q
- S:'X X="@"
- Q
- ;
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDITP 4241 printed Feb 19, 2025@00:20:43 Page 2
- DITP ;SFISC/GFT-TRANSFER POINTERS ;17MAY2005
- +1 ;;22.2;VA FileMan;**10**;Jan 05, 2016;Build 11
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- +4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- +5 ;;Licensed under the terms of the Apache License, Version 2.0.
- +6 ;
- +7 DO ASK
- if %-1
- QUIT
- GOTO PTS
- +8 ;
- 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
- +2 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",!
- +3 GOTO Q
- +4 ;
- +5 ;
- +6 ;
- +7 ;
- EN(DIFILE,DILIST) ;IF THERE ARE POINTERS TO FILE 'DIFILE', GO THRU THE DILIST AND CHANGE THE POINTERS
- +1 KILL ^UTILITY("DIT",$JOB)
- +2 NEW Y,DIA,DTO,DL
- +3 ;,DIA(1)=FROM
- SET (DIA("P"),Y)=DIFILE
- SET (DIA,DTO)=$GET(^DIC(+DIFILE,0,"GL"))
- IF DTO=""
- WRITE "ERROR in specification"
- QUIT
- +4 DO PTS^DIT
- +5 SET X=0
- FOR Y=0:0
- SET Y=$ORDER(DILIST(Y))
- if 'Y
- QUIT
- SET %=$PIECE(DILIST(Y),U,2)
- Begin DoDot:1
- +6 IF '%
- IF "@"'[%
- KILL X
- QUIT
- +7 IF %
- IF '$DATA(@(DTO_"%)"))
- KILL X
- QUIT
- +8 SET X=X+1
- SET ^UTILITY("DIT",$JOB,+DILIST(Y))=%_";"_$EXTRACT(DTO,2,99)
- End DoDot:1
- IF '$DATA(X)
- WRITE "ERROR in specification"
- GOTO END
- +9 IF X
- DO P
- END KILL ^UTILITY("DIT",$JOB)
- +1 QUIT
- +2 ;
- PTS ;
- +1 DO WAIT^DICD
- KILL IOP
- +2 ;At this point, e.g.^UTILITY("DIT",$J,0,1)=801.41^15^V
- +3 ;and ^UTILITY("DIT",$J,38)="103;AUTTIMM(" meaning that pointers to entry 38 in ^AUTTIMM are being moved to 103
- P ;KILL NODES AS WE PROCESS THEM
- FOR
- SET X=$ORDER(^UTILITY("DIT",$JOB,0,0))
- if X=""
- QUIT
- SET Y=^UTILITY("DIT",$JOB,0,X)
- SET L=$PIECE(Y,U,2)
- KILL ^(X)
- DO 1(+Y,L,.DTO)
- +1 KILL ^UTILITY("DIT",$JOB)
- QUIT
- +2 ;
- 1(DIPFILE,DIPFIELD,DTO) ;CALL DIP PRINT MODULE ONCE TO GO THRU CHANGING ONE FIELD'S VALUE. 'DTO' IS ROOT OF FILE BEING POINTED TO.
- +1 NEW DIPVP,DL,L,DHD,DIA,BY,DITPY,DR,D,X,FLDS,DIOBEG,FR,TO,DISTOP,DIOBEG
- +2 ;A MULTIPLE CAN'T POINT
- SET (BY,FR,TO)=""
- SET DIPVP=$PIECE(^DD(DIPFILE,DIPFIELD,0),U,2)["V"
- if $PIECE(^(0),U,2)
- QUIT
- +3 SET DL=1
- SET DL(1)=DIPFIELD_"////^D STUFF^DITP("_(DIPVP)_")"
- +4 ;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)
- +5 SET L=$PIECE(^DD(DIPFILE,DIPFIELD,0),U,4)
- SET %=$PIECE(L,";",2)
- SET L=""""_$PIECE(L,";",1)_""""
- SET DHD=$PIECE(^(0),U)
- IF %
- SET %="$P(^("_L_"),U,"_%_")"
- +6 IF '$TEST
- SET %="$E(^("_L_"),"_+$EXTRACT(%,2,9)_","_$PIECE(%,",",2)_")"
- +7 SET L=L_")):"""","_%_"?."" "":"""","
- +8 IF DIPVP
- IF DTO]""
- SET L=L_"$P("_%_","";"",2)'="""_$EXTRACT(DTO,2,99)_""":"""","
- +9 SET L=L_"'$D(^UTILITY(""DIT"",$J,+"_%_")):"""","
- 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"
- +2 if '$DATA(^DIC(%,0,"GL"))
- QUIT
- SET DIC=^("GL")
- SET DITPY="S X=$S('$D("_DIC_"D0,"
- +3 FOR X=0:1:DL-1
- SET DR(X+1,D(DL-X))=DL(DL-X)
- if X
- SET DITPY=DITPY_X(DL+1-X)_",D"_X_","
- +4 SET DIA("P")=%
- SET %=$LENGTH(BY,",")
- IF %>2
- SET BY=$PIECE(BY,",",%-2)_",.01,"_BY
- +5 SET DITPY=DITPY_L_"1:D"_X_")"
- SET BY=BY_"X DITPY;@"
- +6 ;Now DITPY=e.g. S X=$S('$D(^AUPNVIMM(D0,"0")):"",$P(^("0"),U,1)?." ":"",'$D(^UTILITY("DIT",$J,+$P(^("0"),U,1))):"",1:D0)
- +7 ;It will happen in DIA2
- SET L=0
- SET FLDS=""
- SET DISTOP=0
- SET DHIT="N DIFIXPT G LOOP^DIA2"
- SET %ZIS=""
- SET DIOBEG="W !!"
- +8 ;DHD="@@"
- IF $GET(DIQUIET)
- KILL DIOBEG
- SET DIFIXPT=1
- +9 DO EN1^DIP
- IOP ;KEEP THE SAME OUTPUT DEVICE AS WE GO THRU DIFFERENT 'PRINTINGS'
- SET IOP=$SELECT($GET(IOS):"`"_IOS,1:$GET(IO))
- QUIT
- +1 ;
- STUFF(VP) ;VP=BOOLEAN
- +1 SET X=""
- if $GET(DE(DQ))=""
- QUIT
- +2 ;^UTILITY("DIT",$J,38)="103;AUTTIMM(" means 'CHANGE OLD 38 TO 103' if we have a variable-pointer to ^AUTTIMM
- NEW %
- SET %=DE(DQ)
- if '%!'$DATA(^UTILITY("DIT",$JOB,+%))
- QUIT
- +3 SET X=^(+%)
- IF 'VP
- SET X=+X
- +4 IF '$TEST
- SET X=$SELECT($PIECE(X,";",2)'=$PIECE(%,";",2):"",'X:"@",1:X)
- if X=""
- WRITE " (no change)"
- QUIT
- +5 if 'X
- SET X="@"
- +6 QUIT
- +7 ;
- 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
