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)
Q
;
;
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
Q
;
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",!
Q
;
HDR ;Print header
W @IOF,"DANGLING POINTER REPORT",!
Q
;
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,")"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIVRPTR 2981 printed Apr 09, 2024@21:48:30 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
