- DIDG ;SFISC/RWF-GLOBAL MAP ;1:24 PM 1 Mar 2002 [ 12/09/2003 4:48 PM ]
- ;;22.0;VA FileMan;**105,1002**;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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 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),$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)_" PAGE "_DC
- 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
- DIDG ;SFISC/RWF-GLOBAL MAP ;1:24 PM 1 Mar 2002 [ 12/09/2003 4:48 PM ]
- +1 ;;22.0;VA FileMan;**105,1002**;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 KILL W
- SET DJ(Z)=D0
- SET F=0
- SET W=F(Z)
- SET M=1
- SET DP=0
- +4 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 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 IF $DATA(DIFF)&($Y)
- WRITE @IOF
- SET DIFF=1
- WRITE "TEMPLATE LIST -- FILE #"_DIB,?(IOM-20),$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)_" PAGE "_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
