Routine: DIVRPTR

DIVRPTR ;GFT/GFT - CHECK POINTER FIELDS (PROGRAMMER CALL) ;28FEB2004

 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42

 ;;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.

 N DIB,DIC K DIRUT

 D DT^DICRW,L^DICRW1 Q:'$D(DIC)

 D ^%ZIS Q:POP  U IO D HDR

 F A=$O(^DD(+Y),-1):0 S A=$O(^DD(A)) Q:'A!$D(DIRUT)  D IJ^DIUTL(A) Q:J(0)>DIB(1)  F DIFLD=0:0 S DIFLD=$O(^DD(A,DIFLD)) Q:'DIFLD!$D(DIRUT)  S X=$P($G(^(DIFLD,0)),U,2) I 'X F T="P","V" I X[T D CK(A,DIFLD,T) S X=""

 D ^%ZISC Q

CK(A,DIFLD,T) ;CHECK FIELD DIFLD, DATA DICTIONARY A, TYPE T

 N W,I,J,V,DIVTMP,DG,E,DIVZ,DE,DR,P4,M

 K ^UTILITY("DIVR",$J)

 D IJ^DIUTL(A) S V=$O(J(""),-1)

 S DIVZ=$P(^DD(A,DIFLD,0),U,3),DR=$P(^(0),U,2),P4=$P(^(0),U,4)

 I T="P" S DIVZ=$$CREF^DILF(U_DIVZ) I '$D(@DIVZ@(0)) D SUBHD W !,"POINTED-TO FILE (#",+$P(DR,"P",2),") IS MISSING!!",! Q

 D 0 S X=P4,Y=$P(X,";",2),X=$P(X,";")

 I +X'=X S X=""""_X_"""" I Y="" S DE=DE_"S X=DA D "_T G XEC

 S M="S X=$S($D(^(DA,"_X_")):$"_$S(Y:"P(^("_X_"),U,"_Y,1:"E(^("_X_"),"_$E(Y,2,9))_"),1:"""") D "_T

 I $L(M)+$L(DE)>250 S DE=DE_"X DE(1)",DE(1)=M

 E  S DE=DE_M

XEC K DIC,M,Y X DE

Q S M=$O(^UTILITY("DIVR",$J,0)),E=$O(^(M)),DK=J(0)

 K ^UTILITY("DIVR",$J)

0 ;

 K DA

 S Y=I(0),DE="",X=V

L S DA="DA" S:X DA=DA_"("_X_")" S Y=Y_DA,DE=DE_"F "_DA_"=0:0 Q:$D(DIRUT)  ",%="S "_DA_"=$O("_Y_"))" I V>2 S DE(X+X)=%,DE=DE_"X DE("_(X+X)_")"

 E  S DE=DE_%

 S DE=DE_" Q:"_DA_"'>0  S D"_(V-X)_"="_DA_" "

 S X=X-1 Q:X<0  S Y=Y_","_I(V-X)_"," G L

V ;VARIABLE POINTER

 Q:'X  I $P(X,";",2)'?1A.AN1"(".ANP,$P(X,";",2)'?1"%".AN1"(".ANP S M=""""_X_""""_" has the wrong format" G X

 S M=$S($D(@(U_$P(X,";",2)_"0)")):^(0),1:"")

 I '$D(^DD(A,DIFLD,"V","B",+$P(M,U,2))) S M=$P(M,U)_" FILE not in the DD" G X

 I '$D(@(U_$P(X,";",2)_+X_",0)")) S M=U_$P(X,";",2)_+X_",0) does not exist" G X

P ;REGULAR POINTER

 Q:'X  I $D(@DIVZ@(X,0)) Q

 S M="No '"_X_"' in "_$P(@DIVZ@(0),U)_" File"

X I $O(^UTILITY("DIVR",$J,0))="" D SUBHD

 S ^UTILITY("DIVR",$J,X)="",M=">>"_M_"<<"

 S DG=$$IENS^DILF(.DA),J=V

 F J=V:-1:0 W !,?V-J*2,$O(^DD(J(V-J),0,"NM",0)),": `",+$P(DG,",",J+1),?V-J*2+10,"  " S W="E" D  I W="" S W="I" D  ;TRY EXTERNAL FORM FIRST, THEN INTERNAL

 .S W=$$GET1^DIQ(J(V-J),$P(DG,",",J+1,99),.01,W) W W

 W "  " W:$X+$L(M)>IOM !?30 W M

 D LF Q

LF ;Issue a line feed or EOP read

 I $Y+3<IOSL W ! Q

 I IOST?1"C-".E D

 . N DIR,X,Y

 . S DIR(0)="E" W ! D ^DIR

 I '$D(DIRUT) D HDR,SUBHD W "continued",!

HDR ;Print header

 W @IOF,"DANGLING POINTER REPORT",!

SUBHD N I,Y W !!!,"FILE ",J(0),"  '",$$LABEL^DIALOGZ(A,DIFLD),"' ("

 S Y=" File #"_J(0)

 F I=1:1 Q:'$D(J(I))  S Y=" Sub-File #"_J(I)_" of"_Y

 S Y="Field #"_DIFLD_" in"_Y

 I $P($G(^DD(A,DIFLD,0)),U,2) S Y="Multiple "_Y

 W Y,")"

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIVRPTR   2981     printed  Mar 13, 2025@21:59:41                                                                                                                                                                                                     Page 2

DIVRPTR   ;GFT/GFT - CHECK POINTER FIELDS (PROGRAMMER CALL) ;28FEB2004

 +1       ;;22.2;VA FileMan;;Jan 05, 2016;Build 42

 +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        NEW DIB,DIC

           KILL DIRUT

 +8        DO DT^DICRW

           DO L^DICRW1

           if '$DATA(DIC)

               QUIT

 +9        DO ^%ZIS

           if POP

               QUIT

           USE IO

           DO HDR

 +10       FOR A=$ORDER(^DD(+Y),-1):0

               SET A=$ORDER(^DD(A))

               if 'A!$DATA(DIRUT)

                   QUIT

               DO IJ^DIUTL(A)

               if J(0)>DIB(1)

                   QUIT

               FOR DIFLD=0:0

                   SET DIFLD=$ORDER(^DD(A,DIFLD))

                   if 'DIFLD!$DATA(DIRUT)

                       QUIT

                   SET X=$PIECE($GET(^(DIFLD,0)),U,2)

                   IF 'X

                       FOR T="P","V"

                           IF X[T

                               DO CK(A,DIFLD,T)

                               SET X=""

 +11       DO ^%ZISC

           QUIT

 +12      ;

CK(A,DIFLD,T) ;CHECK FIELD DIFLD, DATA DICTIONARY A, TYPE T

 +1        NEW W,I,J,V,DIVTMP,DG,E,DIVZ,DE,DR,P4,M

 +2        KILL ^UTILITY("DIVR",$JOB)

 +3        DO IJ^DIUTL(A)

           SET V=$ORDER(J(""),-1)

 +4        SET DIVZ=$PIECE(^DD(A,DIFLD,0),U,3)

           SET DR=$PIECE(^(0),U,2)

           SET P4=$PIECE(^(0),U,4)

 +5        IF T="P"

               SET DIVZ=$$CREF^DILF(U_DIVZ)

               IF '$DATA(@DIVZ@(0))

                   DO SUBHD

                   WRITE !,"POINTED-TO FILE (#",+$PIECE(DR,"P",2),") IS MISSING!!",!

                   QUIT

 +6        DO 0

           SET X=P4

           SET Y=$PIECE(X,";",2)

           SET X=$PIECE(X,";")

 +7        IF +X'=X

               SET X=""""_X_""""

               IF Y=""

                   SET DE=DE_"S X=DA D "_T

                   GOTO XEC

 +8        SET M="S X=$S($D(^(DA,"_X_")):$"_$SELECT(Y:"P(^("_X_"),U,"_Y,1:"E(^("_X_"),"_$EXTRACT(Y,2,9))_"),1:"""") D "_T

 +9        IF $LENGTH(M)+$LENGTH(DE)>250

               SET DE=DE_"X DE(1)"

               SET DE(1)=M

 +10      IF '$TEST

               SET DE=DE_M

XEC        KILL DIC,M,Y

           XECUTE DE

Q          SET M=$ORDER(^UTILITY("DIVR",$JOB,0))

           SET E=$ORDER(^(M))

           SET DK=J(0)

 +1        KILL ^UTILITY("DIVR",$JOB)

 +2        QUIT

 +3       ;

 +4       ;

0         ;

 +1        KILL DA

 +2        SET Y=I(0)

           SET DE=""

           SET X=V

L          SET DA="DA"

           if X

               SET DA=DA_"("_X_")"

           SET Y=Y_DA

           SET DE=DE_"F "_DA_"=0:0 Q:$D(DIRUT)  "

           SET %="S "_DA_"=$O("_Y_"))"

           IF V>2

               SET DE(X+X)=%

               SET DE=DE_"X DE("_(X+X)_")"

 +1       IF '$TEST

               SET DE=DE_%

 +2        SET DE=DE_" Q:"_DA_"'>0  S D"_(V-X)_"="_DA_" "

 +3        SET X=X-1

           if X<0

               QUIT

           SET Y=Y_","_I(V-X)_","

           GOTO L

 +4       ;

 +5       ;

 +6       ;

 +7       ;

V         ;VARIABLE POINTER

 +1        if 'X

               QUIT

           IF $PIECE(X,";",2)'?1A.AN1"(".ANP

               IF $PIECE(X,";",2)'?1"%".AN1"(".ANP

                   SET M=""""_X_""""_" has the wrong format"

                   GOTO X

 +2        SET M=$SELECT($DATA(@(U_$PIECE(X,";",2)_"0)")):^(0),1:"")

 +3        IF '$DATA(^DD(A,DIFLD,"V","B",+$PIECE(M,U,2)))

               SET M=$PIECE(M,U)_" FILE not in the DD"

               GOTO X

 +4        IF '$DATA(@(U_$PIECE(X,";",2)_+X_",0)"))

               SET M=U_$PIECE(X,";",2)_+X_",0) does not exist"

               GOTO X

 +5        QUIT

 +6       ;

P         ;REGULAR POINTER

 +1        if 'X

               QUIT

           IF $DATA(@DIVZ@(X,0))

               QUIT

 +2        SET M="No '"_X_"' in "_$PIECE(@DIVZ@(0),U)_" File"

X          IF $ORDER(^UTILITY("DIVR",$JOB,0))=""

               DO SUBHD

 +1        SET ^UTILITY("DIVR",$JOB,X)=""

           SET M=">>"_M_"<<"

 +2        SET DG=$$IENS^DILF(.DA)

           SET J=V

 +3       ;TRY EXTERNAL FORM FIRST, THEN INTERNAL

           FOR J=V:-1:0

               WRITE !,?V-J*2,$ORDER(^DD(J(V-J),0,"NM",0)),": `",+$PIECE(DG,",",J+1),?V-J*2+10,"  "

               SET W="E"

               Begin DoDot:1

 +4                SET W=$$GET1^DIQ(J(V-J),$PIECE(DG,",",J+1,99),.01,W)

                   WRITE W

               End DoDot:1

               IF W=""

                   SET W="I"

                   Begin DoDot:1

                   End DoDot:1

 +5        WRITE "  "

           if $X+$LENGTH(M)>IOM

               WRITE !?30

           WRITE M

 +6        DO LF

           QUIT

 +7       ;

 +8       ;

LF        ;Issue a line feed or EOP read

 +1        IF $Y+3<IOSL

               WRITE !

               QUIT

 +2        IF IOST?1"C-".E

               Begin DoDot:1

 +3                NEW DIR,X,Y

 +4                SET DIR(0)="E"

                   WRITE !

                   DO ^DIR

               End DoDot:1

 +5        IF '$DATA(DIRUT)

               DO HDR

               DO SUBHD

               WRITE "continued",!

 +6        QUIT

 +7       ;

HDR       ;Print header

 +1        WRITE @IOF,"DANGLING POINTER REPORT",!

 +2        QUIT

 +3       ;

SUBHD      NEW I,Y

           WRITE !!!,"FILE ",J(0),"  '",$$LABEL^DIALOGZ(A,DIFLD),"' ("

 +1        SET Y=" File #"_J(0)

 +2        FOR I=1:1

               if '$DATA(J(I))

                   QUIT

               SET Y=" Sub-File #"_J(I)_" of"_Y

 +3        SET Y="Field #"_DIFLD_" in"_Y

 +4        IF $PIECE($GET(^DD(A,DIFLD,0)),U,2)

               SET Y="Multiple "_Y

 +5        WRITE Y,")"

 +6        QUIT

DIVRPTR.m