- DDSRUN ;SFISC/MKO-RUN A FORM ;6JUL2013
- ;;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.
- ;
- ;Select file (DDSFILE)
- EGP S DDS1=8108.3 D W^DICRW K DDS1 G:Y<0 RUNQ ;**CCO/NI 'RUN FORM:'
- 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 S DDSPAGE=$$MULSELPG(DDSRUNDR) I DDSPAGE]"" K DA G GO ;IF THERE'S A RECORD SELECTION PAGE WITH MULTIPLES, USE IT
- K DIR S Y=$O(^DIST(.403,DDSRUNDR,40,0)) I '$O(^(Y)) S DDSPAGE=1 G REC ;DON'T ASK PAGE IF THERE IS ONLY ONE!
- 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
- 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
- GO 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
- ;
- MULSELPG(DDS) ;RETURN RECORD SELECTION PAGE IF IT IS NOT A POP-UP, I.E. IF IT IS A NEW-STYLE MULTIPLE SELECTION PAGE
- N Y,P S Y=$G(^DIST(.403,+DDS,21)) I Y]"" S P=$O(^(40,"B",Y,0)) I P,'$P(^DIST(.403,+DDS,40,P,0),U,6) Q Y
- Q ""
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDSRUN 1818 printed Jan 18, 2025@03:44:32 Page 2
- DDSRUN ;SFISC/MKO-RUN A FORM ;6JUL2013
- +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 ;Select file (DDSFILE)
- EGP ;**CCO/NI 'RUN FORM:'
- SET DDS1=8108.3
- DO W^DICRW
- KILL DDS1
- if Y<0
- GOTO RUNQ
- +1 if '$DATA(@(DIC_"0)"))
- GOTO RUNQ
- +2 KILL DDSFILE
- SET DDSFILE=+Y
- +3 ;
- +4 ;Select form (DDSRUNDR)
- +5 KILL DIC
- +6 SET DIC=.403
- SET DIC(0)="QEA"
- SET D="F"_+Y
- +7 SET DIC("S")="I $P(^(0),U,8)=+DDSFILE"
- +8 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"
- +9 WRITE !
- DO IX^DIC
- KILL DIC,D
- if Y<0
- GOTO RUNQ
- +10 SET DDSRUNDR=+Y
- +11 ;
- +12 IF '$$COMPILED^DDS0(DDSRUNDR)
- DO EN^DDSZ(DDSRUNDR)
- if $GET(DIERR)
- GOTO RUNQ
- +13 ;
- +14 ;Select page (DDSPAGE)
- PAGE ;IF THERE'S A RECORD SELECTION PAGE WITH MULTIPLES, USE IT
- SET DDSPAGE=$$MULSELPG(DDSRUNDR)
- IF DDSPAGE]""
- KILL DA
- GOTO GO
- +1 ;DON'T ASK PAGE IF THERE IS ONLY ONE!
- KILL DIR
- SET Y=$ORDER(^DIST(.403,DDSRUNDR,40,0))
- IF '$ORDER(^(Y))
- SET DDSPAGE=1
- GOTO REC
- +2 SET DIR(0)="NOA^1:999.9:1"
- +3 SET DIR("A")="Enter number of first page: "
- SET DIR("B")=1
- +4 WRITE !
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- GOTO RUNQ
- +5 KILL DDSPAGE
- if Y'=1
- SET DDSPAGE=Y
- +6 ;
- REC ;Select record (DA)
- +1 KILL DA
- +2 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
- GO KILL DR
- SET DR=DDSRUNDR
- DO ^DDS
- if $DATA(DA)
- GOTO REC
- +1 ;
- 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
- +6 ;
- MULSELPG(DDS) ;RETURN RECORD SELECTION PAGE IF IT IS NOT A POP-UP, I.E. IF IT IS A NEW-STYLE MULTIPLE SELECTION PAGE
- +1 NEW Y,P
- SET Y=$GET(^DIST(.403,+DDS,21))
- IF Y]""
- SET P=$ORDER(^(40,"B",Y,0))
- IF P
- IF '$PIECE(^DIST(.403,+DDS,40,P,0),U,6)
- QUIT Y
- +2 QUIT ""