- DDMAP ;SFISC/JKS(Helsinki)-GRAPH OF FILEMAN POINTER RELATIONS ;7/1/93 4:14 PM
- ;;22.0;VA FileMan;;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;EXPLANATIONS:
- ; N = normal reference
- ; S = pointer file not included in the set
- ; C = cross reference in the pointer file
- ; L = laygo allowed
- ; * = reference internally truncated
- ; m = Multiple field
- ; v = Variable Pointer
- ;
- ST S DDPCK=1 I DUZ(0)'="@",$S($D(^VA(200,DUZ,"FOF",9.4,0)):1,1:$D(^DIC(3,DUZ,"FOF",9.4,0))) G INFO:$P(^(0),U,2),EN1
- I DUZ(0)'="@",$D(^DIC(9.4,0,"DD")) S DDPCK=0 F I=1:1:$L(^("DD")) I DUZ(0)[$E(^("DD"),I) S DDPCK=1 Q
- I 'DDPCK G EN1
- INFO W !!,"Prints a graph of pointer relations in a database of FileMan files",!,"named in the Kernel PACKAGE file (9.4) or given separately.",!,"Works best with 132 column output!"
- DDPCK D DT^DICRW K ^UTILITY($J),DDTO,DDPCK,DUOUT,DTOUT S DDPCKN="" G GET:'$D(^DD(9.4)) S DIC=9.4,DIC(0)="AEQML" D ^DIC G END:X[U!$D(DTOUT),GET:Y<0 S DDPCK=+Y,DDPCKN=$P(Y,U,2)
- S DDFLE="" F I=1:1 S DDFLE=$O(^DIC(9.4,DDPCK,4,"B",DDFLE)) Q:DDFLE="" S ^UTILITY($J,"F",DDFLE)=""
- G GET:DDPCKN="" D LIST
- REM S DIC=1,DIC(0)="AEMQ",DIC("S")="I $D(^UTILITY($J,""F"",+Y)) Q",DIC("A")="Remove FILE: " D ^DIC G:X[U!$D(DTOUT) END G:Y<0 ADD K ^UTILITY($J,"F",+Y) G REM
- GET I DDPCKN="" W !!,"Enter files to be included"
- ADD K DIC I DUZ(0)'="@" S DIC("S")="I 1 Q:'$D(^(0,""DD"")) F DC=1:1:$L(^(""DD"")) I DUZ(0)[$E(^(""DD""),DC) Q" D ADD0
- S DIC=1,DIC(0)="QEAM",DIC("A")="Add FILE: " D ^DIC G END:X[U!$D(DTOUT),ADD1:Y<0 S ^UTILITY($J,"F",+Y)="" G ADD
- ADD0 I $D(^VA(200,"AFOF")) S DIC("S")="I $D(^VA(200,DUZ,""FOF"",+Y,0)),$P(^(0),U,2) Q"
- I $D(^DIC(3,"AFOF")) S DIC("S")="I $D(^DIC(3,DUZ,""FOF"",+Y,0)),$P(^(0),U,2) Q"
- Q
- ADD1 G END:'$D(^UTILITY($J)) D:DDPCKN="" LIST
- GO G END:'$D(^UTILITY($J)) W !,"Enter name of file group for optional graph header: " W:DDPCKN]"" DDPCKN,"// " R X:DTIME G:X[U!'$T END I X'[U,X]"",($L(X)<3!($L(X)>20)) W:X'["?" $C(7) G HLP1:X["?",HLP
- S:X="" X=DDPCKN S DDPCKN=X W !
- EXIT S %ZIS="Q" D ^%ZIS G:POP EXIT1 S DDFLE=0
- I $D(IO("Q")) S ZTRTN="NXF^DDMAP2" F I="^UTILITY($J,","DDFLE","DDPCKN" S ZTSAVE(I)=""
- I $D(IO("Q")) D ^%ZTLOAD G EXIT1
- U IO G ^DDMAP2
- EN1 W !," Access NOT Permitted for this Routine.",!,"(Must have DD Access to the PACKAGE File)"
- END K DIC,DDFLE,DDPCKN,DDPCK,^UTILITY($J) Q
- EXIT2 I $D(ZTSK) K ^%ZTSK(ZTSK),ZTSK G KILL
- EXIT1 I $D(DD9),IO=IO(0) R !,"Enter '^' to exit or return to continue: ",X:$S($D(DTIME):DTIME,1:300) I $T,X'=U D KILL W @IOF G ST
- KILL W:$Y @IOF X $G(^%ZIS("C"))
- K ^UTILITY($J),DDA1,DDA2,DDCR,DIC,DDFL,DDFLD,DDFLE,DDFNMAX,DDFRN,DDFPT,I,DDINC,DDLGO,DDLN,DDMAX,DDOUT,DD5,DD7,DD9,DDP,DDPCK,DDPCKN,DDPP
- K %H,%ZISI,%,DISYS,DDPT,DDPTF,DDTB1,DDTB2,DDTO,DDW,X,Y,%T,%XX,%YY,ZTSK,DDMIOSL,DDMAPC
- Q
- LIST W !!,"Files included" S DDFLE=0 F I=1:1 S DDFLE=$O(^UTILITY($J,"F",DDFLE)) Q:DDFLE'>0 W ?27,$J(DDFLE,10)," ",$O(^DD(DDFLE,0,"NM","")),!
- Q
- HLP1 W !,"Type a header that can be used for the print out"
- HLP W !,"The Header must be between 3 and 20 characters" G GO
- DDMAP ;SFISC/JKS(Helsinki)-GRAPH OF FILEMAN POINTER RELATIONS ;7/1/93 4:14 PM
- +1 ;;22.0;VA FileMan;;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;EXPLANATIONS:
- +4 ; N = normal reference
- +5 ; S = pointer file not included in the set
- +6 ; C = cross reference in the pointer file
- +7 ; L = laygo allowed
- +8 ; * = reference internally truncated
- +9 ; m = Multiple field
- +10 ; v = Variable Pointer
- +11 ;
- ST SET DDPCK=1
- IF DUZ(0)'="@"
- IF $SELECT($DATA(^VA(200,DUZ,"FOF",9.4,0)):1,1:$DATA(^DIC(3,DUZ,"FOF",9.4,0)))
- IF $PIECE(^(0),U,2)
- GOTO INFO
- GOTO EN1
- +1 IF DUZ(0)'="@"
- IF $DATA(^DIC(9.4,0,"DD"))
- SET DDPCK=0
- FOR I=1:1:$LENGTH(^("DD"))
- IF DUZ(0)[$EXTRACT(^("DD"),I)
- SET DDPCK=1
- QUIT
- +2 IF 'DDPCK
- GOTO EN1
- INFO WRITE !!,"Prints a graph of pointer relations in a database of FileMan files",!,"named in the Kernel PACKAGE file (9.4) or given separately.",!,"Works best with 132 column output!"
- DDPCK DO DT^DICRW
- KILL ^UTILITY($JOB),DDTO,DDPCK,DUOUT,DTOUT
- SET DDPCKN=""
- IF '$DATA(^DD(9.4))
- GOTO GET
- SET DIC=9.4
- SET DIC(0)="AEQML"
- DO ^DIC
- IF X[U!$DATA(DTOUT)
- GOTO END
- IF Y<0
- GOTO GET
- SET DDPCK=+Y
- SET DDPCKN=$PIECE(Y,U,2)
- +1 SET DDFLE=""
- FOR I=1:1
- SET DDFLE=$ORDER(^DIC(9.4,DDPCK,4,"B",DDFLE))
- IF DDFLE=""
- QUIT
- SET ^UTILITY($JOB,"F",DDFLE)=""
- +2 IF DDPCKN=""
- GOTO GET
- DO LIST
- REM SET DIC=1
- SET DIC(0)="AEMQ"
- SET DIC("S")="I $D(^UTILITY($J,""F"",+Y)) Q"
- SET DIC("A")="Remove FILE: "
- DO ^DIC
- IF X[U!$DATA(DTOUT)
- GOTO END
- IF Y<0
- GOTO ADD
- KILL ^UTILITY($JOB,"F",+Y)
- GOTO REM
- GET IF DDPCKN=""
- WRITE !!,"Enter files to be included"
- ADD KILL DIC
- IF DUZ(0)'="@"
- SET DIC("S")="I 1 Q:'$D(^(0,""DD"")) F DC=1:1:$L(^(""DD"")) I DUZ(0)[$E(^(""DD""),DC) Q"
- DO ADD0
- +1 SET DIC=1
- SET DIC(0)="QEAM"
- SET DIC("A")="Add FILE: "
- DO ^DIC
- IF X[U!$DATA(DTOUT)
- GOTO END
- IF Y<0
- GOTO ADD1
- SET ^UTILITY($JOB,"F",+Y)=""
- GOTO ADD
- ADD0 IF $DATA(^VA(200,"AFOF"))
- SET DIC("S")="I $D(^VA(200,DUZ,""FOF"",+Y,0)),$P(^(0),U,2) Q"
- +1 IF $DATA(^DIC(3,"AFOF"))
- SET DIC("S")="I $D(^DIC(3,DUZ,""FOF"",+Y,0)),$P(^(0),U,2) Q"
- +2 QUIT
- ADD1 IF '$DATA(^UTILITY($JOB))
- GOTO END
- IF DDPCKN=""
- DO LIST
- GO IF '$DATA(^UTILITY($JOB))
- GOTO END
- WRITE !,"Enter name of file group for optional graph header: "
- IF DDPCKN]""
- WRITE DDPCKN,"// "
- READ X:DTIME
- IF X[U!'$TEST
- GOTO END
- IF X'[U
- IF X]""
- IF ($LENGTH(X)<3!($LENGTH(X)>20))
- IF X'["?"
- WRITE $CHAR(7)
- IF X["?"
- GOTO HLP1
- GOTO HLP
- +1 IF X=""
- SET X=DDPCKN
- SET DDPCKN=X
- WRITE !
- EXIT SET %ZIS="Q"
- DO ^%ZIS
- IF POP
- GOTO EXIT1
- SET DDFLE=0
- +1 IF $DATA(IO("Q"))
- SET ZTRTN="NXF^DDMAP2"
- FOR I="^UTILITY($J,","DDFLE","DDPCKN"
- SET ZTSAVE(I)=""
- +2 IF $DATA(IO("Q"))
- DO ^%ZTLOAD
- GOTO EXIT1
- +3 USE IO
- GOTO ^DDMAP2
- EN1 WRITE !," Access NOT Permitted for this Routine.",!,"(Must have DD Access to the PACKAGE File)"
- END KILL DIC,DDFLE,DDPCKN,DDPCK,^UTILITY($JOB)
- QUIT
- EXIT2 IF $DATA(ZTSK)
- KILL ^%ZTSK(ZTSK),ZTSK
- GOTO KILL
- EXIT1 IF $DATA(DD9)
- IF IO=IO(0)
- READ !,"Enter '^' to exit or return to continue: ",X:$SELECT($DATA(DTIME):DTIME,1:300)
- IF $TEST
- IF X'=U
- DO KILL
- WRITE @IOF
- GOTO ST
- KILL IF $Y
- WRITE @IOF
- XECUTE $GET(^%ZIS("C"))
- +1 KILL ^UTILITY($JOB),DDA1,DDA2,DDCR,DIC,DDFL,DDFLD,DDFLE,DDFNMAX,DDFRN,DDFPT,I,DDINC,DDLGO,DDLN,DDMAX,DDOUT,DD5,DD7,DD9,DDP,DDPCK,DDPCKN,DDPP
- +2 KILL %H,%ZISI,%,DISYS,DDPT,DDPTF,DDTB1,DDTB2,DDTO,DDW,X,Y,%T,%XX,%YY,ZTSK,DDMIOSL,DDMAPC
- +3 QUIT
- LIST WRITE !!,"Files included"
- SET DDFLE=0
- FOR I=1:1
- SET DDFLE=$ORDER(^UTILITY($JOB,"F",DDFLE))
- IF DDFLE'>0
- QUIT
- WRITE ?27,$JUSTIFY(DDFLE,10)," ",$ORDER(^DD(DDFLE,0,"NM","")),!
- +1 QUIT
- HLP1 WRITE !,"Type a header that can be used for the print out"
- HLP WRITE !,"The Header must be between 3 and 20 characters"
- GOTO GO
