- DDSRUN ;SFISC/MKO-RUN A FORM ;21SEP2006
- ;;22.0;VA FileMan;**151**;Mar 30, 1999;Build 10
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ;Select file (DDSFILE)
- S DDS1="RUN FORM FROM" D W^DICRW K DDS1 G:Y<0 RUNQ
- G:'$D(@(DIC_"0)")) RUNQ
- K DDSFILE S DDSFILE=+Y
- ;
- ;Select form (DDSRUNDR)
- K DIC
- S DIC=.403,DIC(0)="QEA",D="F"_+Y
- S DIC("S")="I $P(^(0),U,8)=+DDSFILE"
- I DUZ(0)'="@" S DIC("S")=DIC("S")_" N DDSI F DDSI=1:1:$L($P(^(0),U,2)) I DUZ(0)[$E($P(^(0),U,2),DDSI) Q"
- W ! D IX^DIC K DIC,D G:Y<0 RUNQ
- S DDSRUNDR=+Y
- ;
- I '$$COMPILED^DDS0(DDSRUNDR) D EN^DDSZ(DDSRUNDR) G:$G(DIERR) RUNQ
- ;
- ;Select page (DDSPAGE)
- PAGE K DIR S Y=$O(^DIST(.403,DDSRUNDR,40,0)) I '$O(^(Y)) S DDSPAGE=1 G REC
- S DIR(0)="NOA^1:999.9:1"
- S DIR("A")="Enter number of first page: ",DIR("B")=1
- W ! D ^DIR K DIR G:$D(DIRUT) RUNQ
- K DDSPAGE S:Y'=1 DDSPAGE=Y
- ;
- REC ;Select record (DA)
- K DA
- I '$P(^DIST(.403,DDSRUNDR,0),U,10) D G:DA<0 RUNQ
- . S DIC=DDSFILE,DIC(0)="QEALM"
- . W ! D ^DIC K DIC
- . S DA=+Y
- K D,DIC,X,Y
- ;
- ;Invoke form
- K DR S DR=DDSRUNDR D ^DDS G:$D(DA) REC
- ;
- RUNQ ;Clean up and quit
- I $D(DIERR) W !,$C(7) D MSG^DIALOG("BW")
- K D,DIC,X,Y
- K DDSFILE,DDSPAGE,DDSRUNDR,DA,DR
- K DIRUT,DTOUT,DUOUT
- Q
- DDSRUN ;SFISC/MKO-RUN A FORM ;21SEP2006
- +1 ;;22.0;VA FileMan;**151**;Mar 30, 1999;Build 10
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 ;Select file (DDSFILE)
- +5 SET DDS1="RUN FORM FROM"
- DO W^DICRW
- KILL DDS1
- IF Y<0
- GOTO RUNQ
- +6 IF '$DATA(@(DIC_"0)"))
- GOTO RUNQ
- +7 KILL DDSFILE
- SET DDSFILE=+Y
- +8 ;
- +9 ;Select form (DDSRUNDR)
- +10 KILL DIC
- +11 SET DIC=.403
- SET DIC(0)="QEA"
- SET D="F"_+Y
- +12 SET DIC("S")="I $P(^(0),U,8)=+DDSFILE"
- +13 IF DUZ(0)'="@"
- SET DIC("S")=DIC("S")_" N DDSI F DDSI=1:1:$L($P(^(0),U,2)) I DUZ(0)[$E($P(^(0),U,2),DDSI) Q"
- +14 WRITE !
- DO IX^DIC
- KILL DIC,D
- IF Y<0
- GOTO RUNQ
- +15 SET DDSRUNDR=+Y
- +16 ;
- +17 IF '$$COMPILED^DDS0(DDSRUNDR)
- DO EN^DDSZ(DDSRUNDR)
- IF $GET(DIERR)
- GOTO RUNQ
- +18 ;
- +19 ;Select page (DDSPAGE)
- PAGE KILL DIR
- SET Y=$ORDER(^DIST(.403,DDSRUNDR,40,0))
- IF '$ORDER(^(Y))
- SET DDSPAGE=1
- GOTO REC
- +1 SET DIR(0)="NOA^1:999.9:1"
- +2 SET DIR("A")="Enter number of first page: "
- SET DIR("B")=1
- +3 WRITE !
- DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- GOTO RUNQ
- +4 KILL DDSPAGE
- IF Y'=1
- SET DDSPAGE=Y
- +5 ;
- REC ;Select record (DA)
- +1 KILL DA
- +2 IF '$PIECE(^DIST(.403,DDSRUNDR,0),U,10)
- Begin DoDot:1
- +3 SET DIC=DDSFILE
- SET DIC(0)="QEALM"
- +4 WRITE !
- DO ^DIC
- KILL DIC
- +5 SET DA=+Y
- End DoDot:1
- IF DA<0
- GOTO RUNQ
- +6 KILL D,DIC,X,Y
- +7 ;
- +8 ;Invoke form
- +9 KILL DR
- SET DR=DDSRUNDR
- DO ^DDS
- IF $DATA(DA)
- GOTO REC
- +10 ;
- RUNQ ;Clean up and quit
- +1 IF $DATA(DIERR)
- WRITE !,$CHAR(7)
- DO MSG^DIALOG("BW")
- +2 KILL D,DIC,X,Y
- +3 KILL DDSFILE,DDSPAGE,DDSRUNDR,DA,DR
- +4 KILL DIRUT,DTOUT,DUOUT
- +5 QUIT
