DID2 ;SFISC/GFT-MODIFIED DD ;25JUL2011
;;22.2;VA FileMan;**19**;Jan 05, 2016;Build 2
;;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.
;
I $D(DINM) G DZ:X'["C"!(X["X")!'$D(^DD(F(Z),DJ(Z),9.1)) S %Y=X,X=^(9.1),W=" -- "_X D ^DIM,W1^DIDH1:'$D(X) S X=%Y G Q:M=U G DZ
F I=9.2:.1 Q:'$D(^(I))#2 W ! S W=I_" = "_^(I) D W G Q:M=U
I $D(^(9.1))#2 S W=^(9.1),%Y="9.1 = " S:X["C" %Y="ALGORITHM: " W !,?DDL1,%Y D W S W=$P(" (ALWAYS "_$E(N,$L(N)-1)_" DECIMAL DIGITS)",U,N?.E1" S X=$J(X,0,"1N1")") D W G Q:M=U
DZ ;
I $D(^("DT")) S Y=^("DT") D D^DIQ W !?DDL1,"LAST EDITED: " S W=Y D W1^DIDH1 G Q:M=U
H K W I $D(^DD(F(Z),DJ(Z),3)),^(3)]"" W !?DDL1,"HELP-PROMPT:" S W=^(3) D W1^DIDH1 G Q:M=U
EGP F %Y=0:0 S %Y=$O(^DD(F(Z),DJ(Z),.009,%Y)) Q:'%Y I $D(^(%Y,0)) S W="("_^(0)_")" W ! D W1^DIDH1 G Q:M=U ;**CCO/NI FOREIGN-LANGUAGE HELP-PROMPTS
I $$CHKWP^DID1(F(Z),DJ(Z)),$O(^DD(F(Z),DJ(Z),23,0))>0 S %Y=23 D DE^DIDH1 G Q:M=U,SC ;p19 only Technical Description for WP
F %Y=21,23 I $O(^DD(F(Z),DJ(Z),%Y,0))>0 D DE^DIDH1 G:M=U Q
SC ;
I $D(^DD(F(Z),DJ(Z),12.1)),'$D(DINM) I X["P"!(X["S") W !?DDL1,"SCREEN:" S W=^(12.1) D W I $D(^(12)) W !?DDL1,"EXPLANATION:" S W=^(12) D W G Q:M=U
I '$D(DINM),$D(^DD(F(Z),DJ(Z),4)),^(4)]"" W !?DDL1,"EXECUTABLE HELP:" S W=^(4) D W G Q:M=U
I $D(^(9.02))#2 W !?DDL1,"SUM:" S W=^(9.02) D W G Q:M=U
AUD S W=$G(^DD(F(Z),DJ(Z),"AUDIT")) I "n"'[W D G:M=U Q
. W !?DDL1,"AUDIT: "
. S W=$S(W="y":"YES, ALWAYS",W="e":"EDITED OR DELETED",1:W) D W Q:M=U
. S W=$G(^DD(F(Z),DJ(Z),"AX"))
. I '$D(DINM),W]"" W !?DDL1,"AUDIT CONDITION: " D W
PRELKUP I '$D(DINM),DJ(Z)=.01,$G(^DD(F(Z),DJ(Z),7.5))]"" W !?DDL1,"PRE-LOOKUP: " S W=^(7.5) D W G:M=U Q
DEL N DIDND
I '$D(DINM) S DIDND=$O(^DD(F(Z),DJ(Z),"DEL","")) I DIDND]"" D G:M=U Q W !
. W !?DDL1,"DELETE TEST: "
. F D S DIDND=$O(^DD(F(Z),DJ(Z),"DEL",DIDND)) Q:DIDND=""!(M=U) W !!
.. S W=$$QT(DIDND)_",0)= " D W Q:M=U
.. S W=$G(^DD(F(Z),DJ(Z),"DEL",DIDND,0)) D W
LAYGO I '$D(DINM),DJ(Z)=.01 S DIDND=$O(^DD(F(Z),DJ(Z),"LAYGO","")) I DIDND]"" D G:M=U Q W !
. N J W !?DDL1,"LAYGO TEST: "
. F D S DIDND=$O(^DD(F(Z),DJ(Z),"LAYGO",DIDND)) Q:DIDND=""!(M=U) W !!
.. S W=$$QT(DIDND)_",0)= " D W Q:M=U
.. S W=$G(^DD(F(Z),DJ(Z),"LAYGO",DIDND,0)) D W
D I $D(^DD(F(Z),DJ(Z),8.5)) W !?DDL1,"DELETE AUTHORITY: " S W=^(8.5) D W G Q:M=U
I X'["C",$D(^(9))#2,^(9)]"" W !?DDL1,"WRITE AUTHORITY:" S W=^(9) D W G Q:M=U
RD I $D(^(8))#2,^(8)]"" W !?DDL1,"READ AUTHORITY:" S W=^(8) D W G Q:M=U
I $D(^(10))#2,^(10)]"" W !?DDL1,"SOURCE OF DATA:" S W=^(10) D W G Q:M=U
I $O(^(11,0))>0 W !?DDL1,"DATA DESTINATION:" S I=0 F S I=$O(^DD(F(Z),DJ(Z),11,I)) Q:I="" S:$D(^DIC(.2,+^(I,0),0)) W=$P(^(0),U)
I S I=-1 D W G Q:M=U
I $O(^DD(F(Z),DJ(Z),20,0))>0 W !?DDL1,"GROUP:" S I=0 F S I=$O(^DD(F(Z),DJ(Z),20,I)) Q:I="" S W=$P(^(I,0),U)
I S I=-1 D W
Q
;
W F K=0:0 S:(($L(W)+DDL2)>IOM) DDL2=32 W ?DDL2 S %Y=$E(W,IOM-$X,999) W $E(W,1,IOM-$X-1) Q:%Y="" S W=%Y W !
I $Y+6>IOSL S DC=DC+1 D ^DIDH
I $D(^DD(F(Z),DJ(Z),0))
Q
;
Q G ND^DID1
;
MOD ;FROM DID
S X=U,%=2 W !,"WANT THE LISTING TO INCLUDE MUMPS CODE" D YN^DICN Q:%<0 S:%=2 DINM=1 I '% W !?5,"Enter YES, to see the MUMPS code as in the STANDARD listing.",!?5,"Enter NO, to eliminate MUMPS code from the listing." G MOD
MOD2 S %=2 W !,"WANT TO RESTRICT LISTING TO CERTAIN GROUPS OF FIELDS" D YN^DICN S:%=2 X=0 Q:%<0!(%=2) I '% W !?5,"Enter YES, to select the Groups you wish to see in this listing.",!?5,"Enter NO, to see all fields." G MOD2
W ! S DP="",L=""","_$S(Y-2:"DJ(Z)",1:"D1")_"))"
G R "Include GROUP: ",X:DTIME S:'$T X=U,DTOUT=1 I X[""""!($L(X)>30)!(X'?.ANP) W $C(7),!,"SORRY, THAT ISN'T WHAT A 'GROUP' NAME CAN LOOK LIKE",! G G
Q:X[U I X'?."?" S C="!" S:X?1"'"1E.E X=$E(X,2,99),C="&'" S DP=DP_C_"$D(^DD(F(Z),""GR"","""_X_L W !,"And " G G
I X="" S:DP]"" DIGR="I "_$E(DP,2,999) Q
W !?5,"To list only those fields which have a particular 'GROUP'",!?5,"(or several 'GROUPS') associated with them, Enter the GROUP NAME",!
W ?5,"To screen out a group, Type ""'"" in front of its name.",!
G G
;
QT(X) ;Quote X if noncanonic
Q:X=+$P(X,"E") X
S X=$NA(X(X)),X=$E(X,3,$L(X)-1)
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDID2 4372 printed Sep 23, 2025@20:22:54 Page 2
DID2 ;SFISC/GFT-MODIFIED DD ;25JUL2011
+1 ;;22.2;VA FileMan;**19**;Jan 05, 2016;Build 2
+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 IF $DATA(DINM)
if X'["C"!(X["X")!'$DATA(^DD(F(Z),DJ(Z),9.1))
GOTO DZ
SET %Y=X
SET X=^(9.1)
SET W=" -- "_X
DO ^DIM
if '$DATA(X)
DO W1^DIDH1
SET X=%Y
if M=U
GOTO Q
GOTO DZ
+8 FOR I=9.2:.1
if '$DATA(^(I))#2
QUIT
WRITE !
SET W=I_" = "_^(I)
DO W
if M=U
GOTO Q
+9 IF $DATA(^(9.1))#2
SET W=^(9.1)
SET %Y="9.1 = "
if X["C"
SET %Y="ALGORITHM: "
WRITE !,?DDL1,%Y
DO W
SET W=$PIECE(" (ALWAYS "_$EXTRACT(N,$LENGTH(N)-1)_" DECIMAL DIGITS)",U,N?.E1" S X=$J(X,0,"1N1")")
DO W
if M=U
GOTO Q
DZ ;
+1 IF $DATA(^("DT"))
SET Y=^("DT")
DO D^DIQ
WRITE !?DDL1,"LAST EDITED: "
SET W=Y
DO W1^DIDH1
if M=U
GOTO Q
H KILL W
IF $DATA(^DD(F(Z),DJ(Z),3))
IF ^(3)]""
WRITE !?DDL1,"HELP-PROMPT:"
SET W=^(3)
DO W1^DIDH1
if M=U
GOTO Q
EGP ;**CCO/NI FOREIGN-LANGUAGE HELP-PROMPTS
FOR %Y=0:0
SET %Y=$ORDER(^DD(F(Z),DJ(Z),.009,%Y))
if '%Y
QUIT
IF $DATA(^(%Y,0))
SET W="("_^(0)_")"
WRITE !
DO W1^DIDH1
if M=U
GOTO Q
+1 ;p19 only Technical Description for WP
IF $$CHKWP^DID1(F(Z),DJ(Z))
IF $ORDER(^DD(F(Z),DJ(Z),23,0))>0
SET %Y=23
DO DE^DIDH1
if M=U
GOTO Q
GOTO SC
+2 FOR %Y=21,23
IF $ORDER(^DD(F(Z),DJ(Z),%Y,0))>0
DO DE^DIDH1
if M=U
GOTO Q
SC ;
+1 IF $DATA(^DD(F(Z),DJ(Z),12.1))
IF '$DATA(DINM)
IF X["P"!(X["S")
WRITE !?DDL1,"SCREEN:"
SET W=^(12.1)
DO W
IF $DATA(^(12))
WRITE !?DDL1,"EXPLANATION:"
SET W=^(12)
DO W
if M=U
GOTO Q
+2 IF '$DATA(DINM)
IF $DATA(^DD(F(Z),DJ(Z),4))
IF ^(4)]""
WRITE !?DDL1,"EXECUTABLE HELP:"
SET W=^(4)
DO W
if M=U
GOTO Q
+3 IF $DATA(^(9.02))#2
WRITE !?DDL1,"SUM:"
SET W=^(9.02)
DO W
if M=U
GOTO Q
AUD SET W=$GET(^DD(F(Z),DJ(Z),"AUDIT"))
IF "n"'[W
Begin DoDot:1
+1 WRITE !?DDL1,"AUDIT: "
+2 SET W=$SELECT(W="y":"YES, ALWAYS",W="e":"EDITED OR DELETED",1:W)
DO W
if M=U
QUIT
+3 SET W=$GET(^DD(F(Z),DJ(Z),"AX"))
+4 IF '$DATA(DINM)
IF W]""
WRITE !?DDL1,"AUDIT CONDITION: "
DO W
End DoDot:1
if M=U
GOTO Q
PRELKUP IF '$DATA(DINM)
IF DJ(Z)=.01
IF $GET(^DD(F(Z),DJ(Z),7.5))]""
WRITE !?DDL1,"PRE-LOOKUP: "
SET W=^(7.5)
DO W
if M=U
GOTO Q
DEL NEW DIDND
+1 IF '$DATA(DINM)
SET DIDND=$ORDER(^DD(F(Z),DJ(Z),"DEL",""))
IF DIDND]""
Begin DoDot:1
+2 WRITE !?DDL1,"DELETE TEST: "
+3 FOR
Begin DoDot:2
+4 SET W=$$QT(DIDND)_",0)= "
DO W
if M=U
QUIT
+5 SET W=$GET(^DD(F(Z),DJ(Z),"DEL",DIDND,0))
DO W
End DoDot:2
SET DIDND=$ORDER(^DD(F(Z),DJ(Z),"DEL",DIDND))
if DIDND=""!(M=U)
QUIT
WRITE !!
End DoDot:1
if M=U
GOTO Q
WRITE !
LAYGO IF '$DATA(DINM)
IF DJ(Z)=.01
SET DIDND=$ORDER(^DD(F(Z),DJ(Z),"LAYGO",""))
IF DIDND]""
Begin DoDot:1
+1 NEW J
WRITE !?DDL1,"LAYGO TEST: "
+2 FOR
Begin DoDot:2
+3 SET W=$$QT(DIDND)_",0)= "
DO W
if M=U
QUIT
+4 SET W=$GET(^DD(F(Z),DJ(Z),"LAYGO",DIDND,0))
DO W
End DoDot:2
SET DIDND=$ORDER(^DD(F(Z),DJ(Z),"LAYGO",DIDND))
if DIDND=""!(M=U)
QUIT
WRITE !!
End DoDot:1
if M=U
GOTO Q
WRITE !
D IF $DATA(^DD(F(Z),DJ(Z),8.5))
WRITE !?DDL1,"DELETE AUTHORITY: "
SET W=^(8.5)
DO W
if M=U
GOTO Q
+1 IF X'["C"
IF $DATA(^(9))#2
IF ^(9)]""
WRITE !?DDL1,"WRITE AUTHORITY:"
SET W=^(9)
DO W
if M=U
GOTO Q
RD IF $DATA(^(8))#2
IF ^(8)]""
WRITE !?DDL1,"READ AUTHORITY:"
SET W=^(8)
DO W
if M=U
GOTO Q
+1 IF $DATA(^(10))#2
IF ^(10)]""
WRITE !?DDL1,"SOURCE OF DATA:"
SET W=^(10)
DO W
if M=U
GOTO Q
+2 IF $ORDER(^(11,0))>0
WRITE !?DDL1,"DATA DESTINATION:"
SET I=0
FOR
SET I=$ORDER(^DD(F(Z),DJ(Z),11,I))
if I=""
QUIT
if $DATA(^DIC(.2,+^(I,0),0))
SET W=$PIECE(^(0),U)
+3 IF $TEST
SET I=-1
DO W
if M=U
GOTO Q
+4 IF $ORDER(^DD(F(Z),DJ(Z),20,0))>0
WRITE !?DDL1,"GROUP:"
SET I=0
FOR
SET I=$ORDER(^DD(F(Z),DJ(Z),20,I))
if I=""
QUIT
SET W=$PIECE(^(I,0),U)
+5 IF $TEST
SET I=-1
DO W
+6 QUIT
+7 ;
W FOR K=0:0
if (($LENGTH(W)+DDL2)>IOM)
SET DDL2=32
WRITE ?DDL2
SET %Y=$EXTRACT(W,IOM-$X,999)
WRITE $EXTRACT(W,1,IOM-$X-1)
if %Y=""
QUIT
SET W=%Y
WRITE !
+1 IF $Y+6>IOSL
SET DC=DC+1
DO ^DIDH
+2 IF $DATA(^DD(F(Z),DJ(Z),0))
+3 QUIT
+4 ;
Q GOTO ND^DID1
+1 ;
MOD ;FROM DID
+1 SET X=U
SET %=2
WRITE !,"WANT THE LISTING TO INCLUDE MUMPS CODE"
DO YN^DICN
if %<0
QUIT
if %=2
SET DINM=1
IF '%
WRITE !?5,"Enter YES, to see the MUMPS code as in the STANDARD listing.",!?5,"Enter NO, to eliminate MUMPS code from the listing."
GOTO MOD
MOD2 SET %=2
WRITE !,"WANT TO RESTRICT LISTING TO CERTAIN GROUPS OF FIELDS"
DO YN^DICN
if %=2
SET X=0
if %<0!(%=2)
QUIT
IF '%
WRITE !?5,"Enter YES, to select the Groups you wish to see in this listing.",!?5,"Enter NO, to see all fields."
GOTO MOD2
+1 WRITE !
SET DP=""
SET L=""","_$SELECT(Y-2:"DJ(Z)",1:"D1")_"))"
G READ "Include GROUP: ",X:DTIME
if '$TEST
SET X=U
SET DTOUT=1
IF X[""""!($LENGTH(X)>30)!(X'?.ANP)
WRITE $CHAR(7),!,"SORRY, THAT ISN'T WHAT A 'GROUP' NAME CAN LOOK LIKE",!
GOTO G
+1 if X[U
QUIT
IF X'?."?"
SET C="!"
if X?1"'"1E.E
SET X=$EXTRACT(X,2,99)
SET C="&'"
SET DP=DP_C_"$D(^DD(F(Z),""GR"","""_X_L
WRITE !,"And "
GOTO G
+2 IF X=""
if DP]""
SET DIGR="I "_$EXTRACT(DP,2,999)
QUIT
+3 WRITE !?5,"To list only those fields which have a particular 'GROUP'",!?5,"(or several 'GROUPS') associated with them, Enter the GROUP NAME",!
+4 WRITE ?5,"To screen out a group, Type ""'"" in front of its name.",!
+5 GOTO G
+6 ;
QT(X) ;Quote X if noncanonic
+1 if X=+$PIECE(X,"E")
QUIT X
+2 SET X=$NAME(X(X))
SET X=$EXTRACT(X,3,$LENGTH(X)-1)
+3 QUIT X
