DIDG ;SFISC/RWF-GLOBAL MAP ;10JAN2006
;;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.
;
K W S DJ(Z)=D0,F=0,W=F(Z),M=1,DP=0
W !
UP I $D(^DD(W,0,"UP")) S Y=^("UP"),N=$O(^DD(Y,"SB",W,0)) I $D(^DD(Y,N,0)) S F=F+1,W(F)=$P($P(^(0),U,4),";",1),W=Y G UP
S W=$S($D(^DIC(W,0,"GL")):^("GL"),1:"^("),Y=0 F N=F:-1:1 S W=W_"D"_Y_","_$S(+W(N)=W(N):W(N),1:""""_W(N)_"""")_",",Y=Y+1
S DID(Z-1)=W K W
;
L S DN(Z)=""
A S DN(Z)=$O(^DD(F(Z),"GL",DN(Z))),DP(0)=0 I DN(Z)="" D POP Q
S DID(Z)=DID(Z-1)_"D"_(F+Z-1)_","_DN(Z) I $O(^DD(F(Z),"GL",DN(Z),""))=0 S DP=""
E S W=DID(Z)_")=" W ! D WL Q:M=U
B S DP=$O(^DD(F(Z),"GL",DN(Z),DP)) G PUSH:DP=0,A:DP=""
S DF=$O(^DD(F(Z),"GL",DN(Z),DP,0))
I DP(0)+1<DP F I1=DP(0)+1:1:DP-1 S W=" ^ " D WL Q:M=U
S N=^DD(F(Z),DF,0),DP(0)=DP
S X=$P(N,U,2) I +X S Z=Z+1,F(Z)=+X D L G B
S W="(#"_DF_") "_$P(N,U,1)_" ["_DP
F Y="F","S","D","N","P","W","V","K" I X[Y S W=W_Y S:Y="P" W=W_":"_+$P(X,"P",2)
S W=W_"] ^ " D WL Q:M=U G B
;
PUSH S N=$O(^DD(F(Z),"GL",DN(Z),DP,0)) S:N="" N=-1 S Y=^DD(F(Z),N,0),DID(Z)=DID(Z)_","
W !,DID(Z)_"0)=^"_$P(Y,U,2)_"^^ (#",N,") "_$P(Y,U,1) S Z=Z+1,F(Z)=+$P(Y,U,2)
D L Q:M=U G A
;
POP S Z=Z-1,DID(Z)=$E(DID(Z),1,$L(DID(Z))-1) Q:Z K DN,W,DP,DG,DID S DN=0 W ! Q
;
END ;
S S=0,M=1
T1 S S=S+1 D:$Y+3>IOSL HDR Q:M=U
W !!,$S(S<4:$P("INPU^PRIN^SOR",U,S)_"T TEMPLATE(S):",1:"FORM(S)/BLOCK(S):")
S DFF="^DI"_$P("E^PT^BT^ST(.403)",U,S),DA=""
F S DA=$O(@DFF@("F"_F(1),DA)) Q:DA="" D Q:M=U
. S DUB=0 F S DUB=$O(@DFF@("F"_F(1),DA,DUB)) Q:DUB'>0 D Q:M=U
.. I $D(@DFF@(DUB,0))#2 S %1=^(0) D TEMPL
K %1 Q:M=U G T1:S<4
Q Q
TEMPL I $Y+3>IOSL D HDR Q:M=U
N % S %=$S($D(^("ROU")):"Compiled: "_^("ROU"),'$D(^("ROU"))&($D(^("ROUOLD"))):"Previously Compiled: "_^("ROUOLD"),1:"")
I %]"",DFF["DIBT" S %=%_"*"
I DFF'["DIST" W !,DFF,"("_DUB_")= ",$P(%1,U)_" "_%
E D FORM
Q
WL I $Y+4>IOSL S %1=W D HD Q:M=U S W=%1 I W[DID(Z) S W=""
F I=1:1 S Y=$P(W," ",I)_" " Q:$P(W," ",I,99)="" W:$X+$L(Y)+2>IOM !,?$L(DID(Z)),"==>" W Y
Q
W 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 Q:%Y="" S W=%Y G W
;
HD S DC=DC+1 D ^DIDH Q:M=U W !,DID(Z),")= " Q
;
HDR ;
S DC=DC+1 I IOST?1"C".E W $C(7) R M:DTIME S:'$T M=U Q:M=U
H1 W:$D(DIFF)&($Y) @IOF S DIFF=1 W "TEMPLATE LIST -- FILE #"_DIB,?(IOM-20),$$OUT^DIALOGU(DT,"FMTE","2D")_" "_$$EZBLD^DIALOG(7095,DC) ;**CCO/NI DATE AND 'PAGE'
S M="",$P(M,"-",IOM)="" W !,M
Q
;
FORM ;
W !,"^DIST(.403,"_DUB_")= ",$P(%1,U)_" "_%
;
N B,L,P
S L=1,L(1)=U
S P=0 F S P=$O(^DIST(.403,DUB,40,P)) Q:'P D Q:M=U
. Q:$D(^DIST(.403,DUB,40,P,0))[0 S B=$P(^(0),U,2) D:B BLOCK Q:M=U
. S B=0 F S B=$O(^DIST(.403,DUB,40,P,40,B)) Q:'B D BLOCK Q:M=U
W !
Q
BLOCK ;
N I
F I=1:1:L I L(I)[(U_B_U) G BLOCKQ
S:$L(L)+$L(B)+1>245 L=L+1,L(L)=U S L(L)=L(L)_B_U
Q:$D(^DIST(.404,B,0))[0 S %1=^(0)
;
I $Y+3>IOSL D HDR Q:M=U
W !?2,"^DIST(.404,"_B_")= ",$P(%1,U)
BLOCKQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIDG 3239 printed Sep 23, 2025@20:22:56 Page 2
DIDG ;SFISC/RWF-GLOBAL MAP ;10JAN2006
+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 KILL W
SET DJ(Z)=D0
SET F=0
SET W=F(Z)
SET M=1
SET DP=0
+8 WRITE !
UP IF $DATA(^DD(W,0,"UP"))
SET Y=^("UP")
SET N=$ORDER(^DD(Y,"SB",W,0))
IF $DATA(^DD(Y,N,0))
SET F=F+1
SET W(F)=$PIECE($PIECE(^(0),U,4),";",1)
SET W=Y
GOTO UP
+1 SET W=$SELECT($DATA(^DIC(W,0,"GL")):^("GL"),1:"^(")
SET Y=0
FOR N=F:-1:1
SET W=W_"D"_Y_","_$SELECT(+W(N)=W(N):W(N),1:""""_W(N)_"""")_","
SET Y=Y+1
+2 SET DID(Z-1)=W
KILL W
+3 ;
L SET DN(Z)=""
A SET DN(Z)=$ORDER(^DD(F(Z),"GL",DN(Z)))
SET DP(0)=0
IF DN(Z)=""
DO POP
QUIT
+1 SET DID(Z)=DID(Z-1)_"D"_(F+Z-1)_","_DN(Z)
IF $ORDER(^DD(F(Z),"GL",DN(Z),""))=0
SET DP=""
+2 IF '$TEST
SET W=DID(Z)_")="
WRITE !
DO WL
if M=U
QUIT
B SET DP=$ORDER(^DD(F(Z),"GL",DN(Z),DP))
if DP=0
GOTO PUSH
if DP=""
GOTO A
+1 SET DF=$ORDER(^DD(F(Z),"GL",DN(Z),DP,0))
+2 IF DP(0)+1<DP
FOR I1=DP(0)+1:1:DP-1
SET W=" ^ "
DO WL
if M=U
QUIT
+3 SET N=^DD(F(Z),DF,0)
SET DP(0)=DP
+4 SET X=$PIECE(N,U,2)
IF +X
SET Z=Z+1
SET F(Z)=+X
DO L
GOTO B
+5 SET W="(#"_DF_") "_$PIECE(N,U,1)_" ["_DP
+6 FOR Y="F","S","D","N","P","W","V","K"
IF X[Y
SET W=W_Y
if Y="P"
SET W=W_":"_+$PIECE(X,"P",2)
+7 SET W=W_"] ^ "
DO WL
if M=U
QUIT
GOTO B
+8 ;
PUSH SET N=$ORDER(^DD(F(Z),"GL",DN(Z),DP,0))
if N=""
SET N=-1
SET Y=^DD(F(Z),N,0)
SET DID(Z)=DID(Z)_","
+1 WRITE !,DID(Z)_"0)=^"_$PIECE(Y,U,2)_"^^ (#",N,") "_$PIECE(Y,U,1)
SET Z=Z+1
SET F(Z)=+$PIECE(Y,U,2)
+2 DO L
if M=U
QUIT
GOTO A
+3 ;
POP SET Z=Z-1
SET DID(Z)=$EXTRACT(DID(Z),1,$LENGTH(DID(Z))-1)
if Z
QUIT
KILL DN,W,DP,DG,DID
SET DN=0
WRITE !
QUIT
+1 ;
END ;
+1 SET S=0
SET M=1
T1 SET S=S+1
if $Y+3>IOSL
DO HDR
if M=U
QUIT
+1 WRITE !!,$SELECT(S<4:$PIECE("INPU^PRIN^SOR",U,S)_"T TEMPLATE(S):",1:"FORM(S)/BLOCK(S):")
+2 SET DFF="^DI"_$PIECE("E^PT^BT^ST(.403)",U,S)
SET DA=""
+3 FOR
SET DA=$ORDER(@DFF@("F"_F(1),DA))
if DA=""
QUIT
Begin DoDot:1
+4 SET DUB=0
FOR
SET DUB=$ORDER(@DFF@("F"_F(1),DA,DUB))
if DUB'>0
QUIT
Begin DoDot:2
+5 IF $DATA(@DFF@(DUB,0))#2
SET %1=^(0)
DO TEMPL
End DoDot:2
if M=U
QUIT
End DoDot:1
if M=U
QUIT
+6 KILL %1
if M=U
QUIT
if S<4
GOTO T1
Q QUIT
TEMPL IF $Y+3>IOSL
DO HDR
if M=U
QUIT
+1 NEW %
SET %=$SELECT($DATA(^("ROU")):"Compiled: "_^("ROU"),'$DATA(^("ROU"))&($DATA(^("ROUOLD"))):"Previously Compiled: "_^("ROUOLD"),1:"")
+2 IF %]""
IF DFF["DIBT"
SET %=%_"*"
+3 IF DFF'["DIST"
WRITE !,DFF,"("_DUB_")= ",$PIECE(%1,U)_" "_%
+4 IF '$TEST
DO FORM
+5 QUIT
WL IF $Y+4>IOSL
SET %1=W
DO HD
if M=U
QUIT
SET W=%1
IF W[DID(Z)
SET W=""
+1 FOR I=1:1
SET Y=$PIECE(W," ",I)_" "
if $PIECE(W," ",I,99)=""
QUIT
if $X+$LENGTH(Y)+2>IOM
WRITE !,?$LENGTH(DID(Z)),"==>"
WRITE Y
+2 QUIT
W 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=""
QUIT
SET W=%Y
GOTO W
+1 ;
HD SET DC=DC+1
DO ^DIDH
if M=U
QUIT
WRITE !,DID(Z),")= "
QUIT
+1 ;
HDR ;
+1 SET DC=DC+1
IF IOST?1"C".E
WRITE $CHAR(7)
READ M:DTIME
if '$TEST
SET M=U
if M=U
QUIT
H1 ;**CCO/NI DATE AND 'PAGE'
if $DATA(DIFF)&($Y)
WRITE @IOF
SET DIFF=1
WRITE "TEMPLATE LIST -- FILE #"_DIB,?(IOM-20),$$OUT^DIALOGU(DT,"FMTE","2D")_" "_$$EZBLD^DIALOG(7095,DC)
+1 SET M=""
SET $PIECE(M,"-",IOM)=""
WRITE !,M
+2 QUIT
+3 ;
FORM ;
+1 WRITE !,"^DIST(.403,"_DUB_")= ",$PIECE(%1,U)_" "_%
+2 ;
+3 NEW B,L,P
+4 SET L=1
SET L(1)=U
+5 SET P=0
FOR
SET P=$ORDER(^DIST(.403,DUB,40,P))
if 'P
QUIT
Begin DoDot:1
+6 if $DATA(^DIST(.403,DUB,40,P,0))[0
QUIT
SET B=$PIECE(^(0),U,2)
if B
DO BLOCK
if M=U
QUIT
+7 SET B=0
FOR
SET B=$ORDER(^DIST(.403,DUB,40,P,40,B))
if 'B
QUIT
DO BLOCK
if M=U
QUIT
End DoDot:1
if M=U
QUIT
+8 WRITE !
+9 QUIT
BLOCK ;
+1 NEW I
+2 FOR I=1:1:L
IF L(I)[(U_B_U)
GOTO BLOCKQ
+3 if $LENGTH(L)+$LENGTH(B)+1>245
SET L=L+1
SET L(L)=U
SET L(L)=L(L)_B_U
+4 if $DATA(^DIST(.404,B,0))[0
QUIT
SET %1=^(0)
+5 ;
+6 IF $Y+3>IOSL
DO HDR
if M=U
QUIT
+7 WRITE !?2,"^DIST(.404,"_B_")= ",$PIECE(%1,U)
BLOCKQ QUIT
