- 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 Feb 19, 2025@00:13:02 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