- DIWF ;SFISC/GFT-FORMS PRINT ;01:52 PM 13 Nov 2000
- ;;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.
- ;
- D DT^DICRW,DICS,L S DIC("S")=DIC("S")_" I "_L
- S DIC="^DIC(",DIC(0)="AEQMZ",DIC("A")="Select Document File: "
- D ^DIC K DIC Q:Y<0
- FINDWORD X L I '$T S Y=-1 G Q
- S DJ=%,DIC=DIWF,D=$O(^DD(DIWFN,"SB",%,0)) S:D="" D=-1 Q:'$D(^DD(DIWFN,D,0)) S D=$P($P(^(0),U,4),";") S:+D'=D D=""""_D_"""" S DIWF=DIWF_"DIWFN,"_D_","
- S D=0 F S D=$O(^DD(DIWFN,D)) Q:D'>0 I $D(^(D,0)),$P(^(0),U,3)="DIC(" S DIWF(0)=D Q
- S:D="" D=-1
- DOC S DIC(0)="AEQM" D ^DIC G Q:Y<0
- I $D(DIWF(0)) S D=$P(^DD(DIWFN,DIWF(0),0),U,4),%=$P(D,";",1) I @("$D("_DIC_+Y_",%))") S D=$P(D,";",2),X=$S(D:$P(^(%),U,D),1:$E(^(%),+$E(D,2,9),+$P(D,",",2))) S:X DIWF(1)=X
- S DIWFN=+Y I @("$O("_DIWF_"0))'>0") W $C(7),!?7,"'"_$P(Y,U,2),"' HAS NO '"_$P(^DD(DJ,.01,0),U,1)_"' TEXT!",! G DOC
- EN2 ;
- N DIC,DIA,DHIT,FLDS,DHD
- I $O(@(DIWF_"0)"))'>0 G Q
- S DIC(0)="AIQEMZ",DIC="^DIC(",DIC("A")="Print from what FILE: "
- I $D(DIWF(1)) S DIC(0)="ZIF",X=DIWF(1)
- D DICS:'$D(DIWF(1)),^DIC K DIC G Q:Y<0,Q:'$D(^DIC(+Y,0,"GL")) S DIC=^("GL")
- S %=1 I $D(BY)[0 W !,"WANT EACH ENTRY ON A SEPARATE PAGE" D YN^DICN G Q:%<1
- S L=0,DHD="@",FLDS="",DHIT="X "_$P("^UTILITY($J,1):$Y,",9,%)_"DIWFX D ^DIWW",DIWFX="S DIWF=""?W"",DIWL=1,DIWR=IOM,D=0 F S D=$O("_DIWF_"D)) S:D="""" D=-1 Q:D'>0 I $D(^(D,0)) S X=^(0) D ^DIWP" K DIWF D EN1^DIP
- Q K L,DIWF,DIWFN,DIWFX,DIFILE,DIAC Q
- ;
- EN1 ;
- I DIC Q:'$D(^DIC(+DIC,0)) S Y=DIC D L G FINDWORD
- I @("$D("_DIC_"0))") S DIC=+$P(^(0),U,2) G EN1
- Q
- ;
- DICS S DIC("S")="S DIFILE=+Y,DIAC=""RD"" D ^DIAC I %" Q
- ;
- L S L="I $D(^DIC(+Y,0,""GL"")) S DIWF=^(""GL"") I $D(@(DIWF_""0)"")) S DIWFN=+$P(^(0),U,2) I $D(^DD(DIWFN,""SB"")) S %=0 F S %=$O(^DD(DIWFN,""SB"",%)) S:%="""" %=-1 Q:%<0 I $P(^DD(%,.01,0),U,2)[""W"" Q"
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIWF 2070 printed Jan 18, 2025@03:55:57 Page 2
- DIWF ;SFISC/GFT-FORMS PRINT ;01:52 PM 13 Nov 2000
- +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 DO DT^DICRW
- DO DICS
- DO L
- SET DIC("S")=DIC("S")_" I "_L
- +8 SET DIC="^DIC("
- SET DIC(0)="AEQMZ"
- SET DIC("A")="Select Document File: "
- +9 DO ^DIC
- KILL DIC
- if Y<0
- QUIT
- FINDWORD XECUTE L
- IF '$TEST
- SET Y=-1
- GOTO Q
- +1 SET DJ=%
- SET DIC=DIWF
- SET D=$ORDER(^DD(DIWFN,"SB",%,0))
- if D=""
- SET D=-1
- if '$DATA(^DD(DIWFN,D,0))
- QUIT
- SET D=$PIECE($PIECE(^(0),U,4),";")
- if +D'=D
- SET D=""""_D_""""
- SET DIWF=DIWF_"DIWFN,"_D_","
- +2 SET D=0
- FOR
- SET D=$ORDER(^DD(DIWFN,D))
- if D'>0
- QUIT
- IF $DATA(^(D,0))
- IF $PIECE(^(0),U,3)="DIC("
- SET DIWF(0)=D
- QUIT
- +3 if D=""
- SET D=-1
- DOC SET DIC(0)="AEQM"
- DO ^DIC
- if Y<0
- GOTO Q
- +1 IF $DATA(DIWF(0))
- SET D=$PIECE(^DD(DIWFN,DIWF(0),0),U,4)
- SET %=$PIECE(D,";",1)
- IF @("$D("_DIC_+Y_",%))")
- SET D=$PIECE(D,";",2)
- SET X=$SELECT(D:$PIECE(^(%),U,D),1:$EXTRACT(^(%),+$EXTRACT(D,2,9),+$PIECE(D,",",2)))
- if X
- SET DIWF(1)=X
- +2 SET DIWFN=+Y
- IF @("$O("_DIWF_"0))'>0")
- WRITE $CHAR(7),!?7,"'"_$PIECE(Y,U,2),"' HAS NO '"_$PIECE(^DD(DJ,.01,0),U,1)_"' TEXT!",!
- GOTO DOC
- EN2 ;
- +1 NEW DIC,DIA,DHIT,FLDS,DHD
- +2 IF $ORDER(@(DIWF_"0)"))'>0
- GOTO Q
- +3 SET DIC(0)="AIQEMZ"
- SET DIC="^DIC("
- SET DIC("A")="Print from what FILE: "
- +4 IF $DATA(DIWF(1))
- SET DIC(0)="ZIF"
- SET X=DIWF(1)
- +5 if '$DATA(DIWF(1))
- DO DICS
- DO ^DIC
- KILL DIC
- if Y<0
- GOTO Q
- if '$DATA(^DIC(+Y,0,"GL"))
- GOTO Q
- SET DIC=^("GL")
- +6 SET %=1
- IF $DATA(BY)[0
- WRITE !,"WANT EACH ENTRY ON A SEPARATE PAGE"
- DO YN^DICN
- if %<1
- GOTO Q
- +7 SET L=0
- SET DHD="@"
- SET FLDS=""
- SET DHIT="X "_$PIECE("^UTILITY($J,1):$Y,",9,%)_"DIWFX D ^DIWW"
- SET DIWFX="S DIWF=""?W"",DIWL=1,DIWR=IOM,D=0 F S D=$O("_DIWF_"D)) S:D="""" D=-1 Q:D'>0 I $D(^(D,0)) S X=^(0) D ^DIWP"
- KILL DIWF
- DO EN1^DIP
- Q KILL L,DIWF,DIWFN,DIWFX,DIFILE,DIAC
- QUIT
- +1 ;
- EN1 ;
- +1 IF DIC
- if '$DATA(^DIC(+DIC,0))
- QUIT
- SET Y=DIC
- DO L
- GOTO FINDWORD
- +2 IF @("$D("_DIC_"0))")
- SET DIC=+$PIECE(^(0),U,2)
- GOTO EN1
- +3 QUIT
- +4 ;
- DICS SET DIC("S")="S DIFILE=+Y,DIAC=""RD"" D ^DIAC I %"
- QUIT
- +1 ;
- L SET L="I $D(^DIC(+Y,0,""GL"")) S DIWF=^(""GL"") I $D(@(DIWF_""0)"")) S DIWFN=+$P(^(0),U,2) I $D(^DD(DIWFN,""SB"")) S %=0 F S %=$O(^DD(DIWFN,""SB"",%)) S:%="""" %=-1 Q:%<0 I $P(^DD(%,.01,0),U,2)[""W"" Q"