DIDX ;SFISC/XAK - BRIEF DD ; Jun 22, 2022@09:04:42
;;22.2;VA FileMan;**2,23**;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.
;
;
S D1=D0,DINM=1,DDRG=1,DDL1=14,DDL2=32 G B
;
L S DJ(Z)=0
A I DIDX D G:D1>0 A:^DD(F(Z),"B",DJ(Z),D1)
. S DJ(Z)=$O(^DD(F(Z),"B",DJ(Z))) S:DJ(Z)="" D1="" Q:DJ(Z)="" S D1=$O(^(DJ(Z),0))
. Q
E S (D1,DJ(Z))=$O(^DD(F(Z),DJ(Z)))
I D1'>0 W ! S Z=Z-1 Q
B I $D(DIGR),D1-.01!'DID X DIGR E G END
S N=^DD(F(Z),D1,0) D HD:$Y+9>IOSL Q:M=U W !!?Z+Z-2,$P(N,U,1),?30,S,F(Z),",",D1,S,S
S X=$P(N,U,2) I X W ?M,$J(+X,8) I $D(^DD(+X,.01,0)),$P(^(0),U,2)["W" W " WORD-PROCESSING" S X=""
W ?M,S,S F W="BOOLEAN","COMPUTED","FREE TEXT","SET","DATE","NUMBER","POINTER","VARIABLE POINTER","K","p","m" I X[$E(W) S:W="K" W="MUMPS" S:W="p" W="POINTER" S:W="m" W="MULTIPLE" D W1 I X["V" D VP0
TYPE S W=+$P(X,"t",2) I W,$D(^DI(.81,W,0)) S W=" ("_$P(^(0),U)_" Data Type)" D W1
I 'X D
.N Y,NM S:X["P" Y=U_$P(N,U,3),NM=+$P(X,"P",2) I X["C" S NM=+$P(X,"p",2) I NM S Y=$G(^DIC(NM,0,"GL"))
.Q:'$D(Y) I Y[U,$D(@(Y_"0)")) S W="TO "_$P(^(0),U)_" FILE (#"_NM_")"
.E S W="***** TO A FILE THAT IS UNDEFINED *******"
.D W1
T ;
S W=0
H ;
W ! I $D(^DD(F(Z),D1,.1))#2 W ?(Z*2),^(.1)," ",?M
I X["S" S N=$P(N,U,3) F I=1:1 S Y=$P(N,";",I) Q:Y="" S W="'"_$P(Y,":")_"' FOR "_$P(Y,":",2)_";" W ?M," "_W,!
I $D(^DD(F(Z),D1,3))#2 S W=^(3) W ?M D W1
RD ;
I X S Z=Z+1,DDL1=DDL1+2,DDL2=DDL2+2,F(Z)=+X,W=" Multiple" D W1,L ;L is called recursively for a multiple, pushing down a stack
END S X="" G:M'=U A:Z>1 Q
;
W1 W:$X+$L(W)+3>IOM !,?$S(IOM-$L(W)-5<M:IOM-5-$L(W),1:M),S S %Y=$E(W,IOM-$X,999) W $E(W,1,IOM-$X-1),S I %Y]"" S W=%Y G W1
D:$Y>IOSL HD Q
;
HD S DC=DC+1 D ^DIDH
Q
VP ;Variable Pointer
W ?50,W S D1=DJ(Z)
VP0 I '$D(^DD(F(Z),D1,"V",0)) S W="" Q
S DID1=0,DIMU=0,DID2=0 I '$D(DDRG) D RT
S W="FILE ORDER PREFIX LAYGO MESSAGE" W !?(Z+Z+12),W G Q:M=U
VP1 S DID2=$O(^DD(F(Z),D1,"V",DID2)) S:DID2="" DID2=-1 G:DID2'>0 VP2 S DIDV=^(DID2,0) I '$D(^DIC(+DIDV,0)) S DIDV(+DIDV)=""
S DIVP=$P(DIDV,U),DDLF=(Z+Z+15) I $L(DIVP)>4 W !?(DDLF-$L(DIVP))+1,DIVP
E W !?DDLF,DIVP
W ?(DDLF+5),$P(DIDV,U,3),?(DDLF+10),$P(DIDV,U,4),?(DDLF+23),$P(DIDV,U,6) S DDL3=DDL2,DDL2=DDLF+27,W=$P(DIDV,U,2) D W1^DIDH1 S DDL2=DDL3 S:$P(DIDV,U,5)["y" DIMU=1 D:$Y+4>IOSL HD G ND^DID1:M=U,VP1
VP2 I DIMU S DIDVI=0 F S DIDVI=$O(^DD(F(Z),D1,"V",DIDVI)) Q:DIDVI'>0 I $D(^(DIDVI,1)) S %=^(0) D VP3 Q:M=U
S DIDV=0 F S DIDV=$O(DIDV(DIDV)) Q:DIDV'>0 S W="!! FILE "_DIDV_" DOES NOT EXIST !!" D W^DID1 Q:M=U
Q W ! K DID2,DIMU,DID1,DIDV,DIDVI S W="" Q
VP3 ;p23
I '$D(DINM) W !?(Z+Z+12),"SCREEN ON FILE "_$P(%,U)_":" S W=" "_^(1) D W^DID1:'$D(DINM)
W !?(Z+Z+12)," SCREEN EXPLANATION"_$S($D(DINM):" ON FILE "_$P(%,U),1:"")_":" S W=" "_$G(^(2)) D W^DIDH
Q
RT F W="Required","Add New Entry without Asking","Multiply asked","audited" I X[$E(W,1) S W=" ("_W_")" W:($L(W)+$X)'<IOM ! D W^DID1 G ND^DID1:M=U
I $D(^DD("KEY","F",F(Z),DJ(Z))) S W=" (Key field)" W:($L(W)+$X)'<IOM ! D W^DID1 G ND^DID1:M=U
W ! I $D(^DD(F(Z),DJ(Z),.1)),^(.1)]"" W !?(Z+Z+12),^(.1)," ",?M
Q
AH W !,"ALPHABETICALLY BY LABEL" D YN^DICN Q:%<0 S:%=1 DIDX=1,BY="@.01"
I '% W !?5,"Enter YES to list the fields ALPHABETICALLY BY LABEL.",!?5,"Enter NO to list the fields by NUMBER." S %=2 G AH
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIDX 3547 printed Dec 13, 2024@02:46:58 Page 2
DIDX ;SFISC/XAK - BRIEF DD ; Jun 22, 2022@09:04:42
+1 ;;22.2;VA FileMan;**2,23**;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 ;
+8 SET D1=D0
SET DINM=1
SET DDRG=1
SET DDL1=14
SET DDL2=32
GOTO B
+9 ;
L SET DJ(Z)=0
A IF DIDX
Begin DoDot:1
+1 SET DJ(Z)=$ORDER(^DD(F(Z),"B",DJ(Z)))
if DJ(Z)=""
SET D1=""
if DJ(Z)=""
QUIT
SET D1=$ORDER(^(DJ(Z),0))
+2 QUIT
End DoDot:1
if D1>0
if ^DD(F(Z),"B",DJ(Z),D1)
GOTO A
+3 IF '$TEST
SET (D1,DJ(Z))=$ORDER(^DD(F(Z),DJ(Z)))
+4 IF D1'>0
WRITE !
SET Z=Z-1
QUIT
B IF $DATA(DIGR)
IF D1-.01!'DID
XECUTE DIGR
IF '$TEST
GOTO END
+1 SET N=^DD(F(Z),D1,0)
if $Y+9>IOSL
DO HD
if M=U
QUIT
WRITE !!?Z+Z-2,$PIECE(N,U,1),?30,S,F(Z),",",D1,S,S
+2 SET X=$PIECE(N,U,2)
IF X
WRITE ?M,$JUSTIFY(+X,8)
IF $DATA(^DD(+X,.01,0))
IF $PIECE(^(0),U,2)["W"
WRITE " WORD-PROCESSING"
SET X=""
+3 WRITE ?M,S,S
FOR W="BOOLEAN","COMPUTED","FREE TEXT","SET","DATE","NUMBER","POINTER","VARIABLE POINTER","K","p","m"
IF X[$EXTRACT(W)
if W="K"
SET W="MUMPS"
if W="p"
SET W="POINTER"
if W="m"
SET W="MULTIPLE"
DO W1
IF X["V"
DO VP0
TYPE SET W=+$PIECE(X,"t",2)
IF W
IF $DATA(^DI(.81,W,0))
SET W=" ("_$PIECE(^(0),U)_" Data Type)"
DO W1
+1 IF 'X
Begin DoDot:1
+2 NEW Y,NM
if X["P"
SET Y=U_$PIECE(N,U,3)
SET NM=+$PIECE(X,"P",2)
IF X["C"
SET NM=+$PIECE(X,"p",2)
IF NM
SET Y=$GET(^DIC(NM,0,"GL"))
+3 if '$DATA(Y)
QUIT
IF Y[U
IF $DATA(@(Y_"0)"))
SET W="TO "_$PIECE(^(0),U)_" FILE (#"_NM_")"
+4 IF '$TEST
SET W="***** TO A FILE THAT IS UNDEFINED *******"
+5 DO W1
End DoDot:1
T ;
+1 SET W=0
H ;
+1 WRITE !
IF $DATA(^DD(F(Z),D1,.1))#2
WRITE ?(Z*2),^(.1)," ",?M
+2 IF X["S"
SET N=$PIECE(N,U,3)
FOR I=1:1
SET Y=$PIECE(N,";",I)
if Y=""
QUIT
SET W="'"_$PIECE(Y,":")_"' FOR "_$PIECE(Y,":",2)_";"
WRITE ?M," "_W,!
+3 IF $DATA(^DD(F(Z),D1,3))#2
SET W=^(3)
WRITE ?M
DO W1
RD ;
+1 ;L is called recursively for a multiple, pushing down a stack
IF X
SET Z=Z+1
SET DDL1=DDL1+2
SET DDL2=DDL2+2
SET F(Z)=+X
SET W=" Multiple"
DO W1
DO L
END SET X=""
if M'=U
if Z>1
GOTO A
QUIT
+1 ;
W1 if $X+$LENGTH(W)+3>IOM
WRITE !,?$SELECT(IOM-$LENGTH(W)-5<M:IOM-5-$LENGTH(W),1:M),S
SET %Y=$EXTRACT(W,IOM-$X,999)
WRITE $EXTRACT(W,1,IOM-$X-1),S
IF %Y]""
SET W=%Y
GOTO W1
+1 if $Y>IOSL
DO HD
QUIT
+2 ;
HD SET DC=DC+1
DO ^DIDH
+1 QUIT
VP ;Variable Pointer
+1 WRITE ?50,W
SET D1=DJ(Z)
VP0 IF '$DATA(^DD(F(Z),D1,"V",0))
SET W=""
QUIT
+1 SET DID1=0
SET DIMU=0
SET DID2=0
IF '$DATA(DDRG)
DO RT
+2 SET W="FILE ORDER PREFIX LAYGO MESSAGE"
WRITE !?(Z+Z+12),W
if M=U
GOTO Q
VP1 SET DID2=$ORDER(^DD(F(Z),D1,"V",DID2))
if DID2=""
SET DID2=-1
if DID2'>0
GOTO VP2
SET DIDV=^(DID2,0)
IF '$DATA(^DIC(+DIDV,0))
SET DIDV(+DIDV)=""
+1 SET DIVP=$PIECE(DIDV,U)
SET DDLF=(Z+Z+15)
IF $LENGTH(DIVP)>4
WRITE !?(DDLF-$LENGTH(DIVP))+1,DIVP
+2 IF '$TEST
WRITE !?DDLF,DIVP
+3 WRITE ?(DDLF+5),$PIECE(DIDV,U,3),?(DDLF+10),$PIECE(DIDV,U,4),?(DDLF+23),$PIECE(DIDV,U,6)
SET DDL3=DDL2
SET DDL2=DDLF+27
SET W=$PIECE(DIDV,U,2)
DO W1^DIDH1
SET DDL2=DDL3
if $PIECE(DIDV,U,5)["y"
SET DIMU=1
if $Y+4>IOSL
DO HD
if M=U
GOTO ND^DID1
GOTO VP1
VP2 IF DIMU
SET DIDVI=0
FOR
SET DIDVI=$ORDER(^DD(F(Z),D1,"V",DIDVI))
if DIDVI'>0
QUIT
IF $DATA(^(DIDVI,1))
SET %=^(0)
DO VP3
if M=U
QUIT
+1 SET DIDV=0
FOR
SET DIDV=$ORDER(DIDV(DIDV))
if DIDV'>0
QUIT
SET W="!! FILE "_DIDV_" DOES NOT EXIST !!"
DO W^DID1
if M=U
QUIT
Q WRITE !
KILL DID2,DIMU,DID1,DIDV,DIDVI
SET W=""
QUIT
VP3 ;p23
+1 IF '$DATA(DINM)
WRITE !?(Z+Z+12),"SCREEN ON FILE "_$PIECE(%,U)_":"
SET W=" "_^(1)
if '$DATA(DINM)
DO W^DID1
+2 WRITE !?(Z+Z+12)," SCREEN EXPLANATION"_$SELECT($DATA(DINM):" ON FILE "_$PIECE(%,U),1:"")_":"
SET W=" "_$GET(^(2))
DO W^DIDH
+3 QUIT
RT FOR W="Required","Add New Entry without Asking","Multiply asked","audited"
IF X[$EXTRACT(W,1)
SET W=" ("_W_")"
if ($LENGTH(W)+$X)'<IOM
WRITE !
DO W^DID1
if M=U
GOTO ND^DID1
+1 IF $DATA(^DD("KEY","F",F(Z),DJ(Z)))
SET W=" (Key field)"
if ($LENGTH(W)+$X)'<IOM
WRITE !
DO W^DID1
if M=U
GOTO ND^DID1
+2 WRITE !
IF $DATA(^DD(F(Z),DJ(Z),.1))
IF ^(.1)]""
WRITE !?(Z+Z+12),^(.1)," ",?M
+3 QUIT
AH WRITE !,"ALPHABETICALLY BY LABEL"
DO YN^DICN
if %<0
QUIT
if %=1
SET DIDX=1
SET BY="@.01"
+1 IF '%
WRITE !?5,"Enter YES to list the fields ALPHABETICALLY BY LABEL.",!?5,"Enter NO to list the fields by NUMBER."
SET %=2
GOTO AH
+2 QUIT
