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