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 Oct 16, 2024@18:44:07 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 ""
