DIP100 ;SFISC/TKW - PROCESS BY(0) INPUT VARIABLES (CONT.OF DIP10) ;12:27 PM 13 Oct 1999
;;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.
;
ENBY0 ; Interactive dialogue to prompt for BY(0) data
Q:DUZ(0)'["@" K DPP,BY(0),L(0),FR(0),TO(0),DISPAR(0) N DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y
EDBY W ! S DIR(0)=".401,1622O",DIR("B")=$G(BY(0)) D ^DIR K DIR G:$G(DTOUT)!("^^@"[X) EXBY0 S:$E(Y)="^" Y=$E(Y,2,9999) S BY(0)="^"_$P(Y,U)
S DIR(0)=".401,1623",DIR("B")=$G(L(0)) D ^DIR K DIR G:X="@" EDBY G:$G(DIRUT) EXBY0 S L(0)=$P(Y,U)
F X=L(0):1:8 K FR(0,X),TO(0,X),DISPAR(0,X)
G:L(0)'>1 BYOK N DISUB D G:$G(DTOUT)!($G(DIROUT)) EXBY0 G BYOK
E2 . S DIR("?")="Enter 'YES' to experiment with these settings",DIR("?",1)="This will let you define sort ranges for any of the variable subscripts"
. S DIR("?",2)="in the global referenced by BY(0). It will also let you define sort",DIR("?",3)="qualifiers including page breaks and customized subheaders.",DIR("?",4)=""
. W ! S DIR(0)="Y",DIR("A")="Edit ranges or subheaders",DIR("B")="NO" D ^DIR K DIR Q:'Y!$D(DIRUT)
. W ! S DIR(0)=".4011624,.01^^K:X>(L(0)-1) X",DIR("B")=1 D ^DIR K DIR,DINUM Q:$G(DIRUT) S DISUB=$P(Y,U)
E3 . S DIR(0)=".4011624,1",DIR("B")=$G(FR(0,DISUB)) D ^DIR K DIR Q:$G(DTOUT) Q:$G(DIROUT) G:X="^" E2 K FR(0,DISUB) I X'="@",Y]"" S FR(0,DISUB)=$P(Y,U)
. S DIR(0)=".4011624,2",DIR("B")=$G(TO(0,DISUB)) D ^DIR K DIR Q:$G(DTOUT) Q:$G(DIROUT) G:X="^" E2 K TO(0,DISUB) I X'="@",Y]"" S TO(0,DISUB)=$P(Y,U) I $G(FR(0,DISUB))]$P(Y,U) D G E3
EGP .. W !,$$EZBLD^DIALOG(1511) Q ;**CCO/NI 'START WITH IS GREATER THAN GO TO!'
. S DIR(0)=".4011624,3.1",DIR("B")=$P($G(DISPAR(0,DISUB)),U,1) D ^DIR K DIR D:X="@" G:$D(DUOUT)!$D(DTOUT) E2 S:Y]"" $P(DISPAR(0,DISUB),U,1)=Y
.. I $P($G(DISPAR(0,DISUB)),U,2)]"" S $P(DISPAR(0,DISUB),U,1)="" Q
.. K DISPAR(0,DISUB) Q
. S DIR(0)=".4011624,3.2",DIR("B")=$P($G(DISPAR(0,DISUB)),U,2) D ^DIR K DIR D:X="@" G:$D(DIRUT) E2 S $P(DISPAR(0,DISUB),U,2)=Y
.. I $P($G(DISPAR(0,DISUB)),U,1)]"" S $P(DISPAR(0,DISUB),U,2)="" Q
.. K DISPAR(0,DISUB) Q
. S DIR(0)=".4011624,4",DIR("B")=$G(DISPAR(0,DISUB,"OUT")) D ^DIR K DIR Q:$G(DTOUT) Q:$G(DIROUT) K DISPAR(0,DISUB,"OUT") I "^@"'[X,Y]"" S DISPAR(0,DISUB,"OUT")=Y
. G E2
BYOK I $G(DIEDITBY) Q:DUZ(0)'["@" N DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y
W !!," BY(0)="_BY(0)_" L(0)="_L(0),!
I L(0)>1,$O(FR(0,0))!$O(TO(0,0))!$O(DISPAR(0,0)) D
. F X=1:1:(L(0)-1) W !," SUB: "_X D
.. W ?10,"FR(0,"_X_"): ",$G(FR(0,X)),!,?10,"TO(0,"_X_"): ",$G(TO(0,X)),!
.. W ?10,"DISPAR(0,"_X_") PIECE ONE: ",$P($G(DISPAR(0,X)),U,1),!
.. W ?10,"DISPAR(0,"_X_") PIECE TWO: ",$P($G(DISPAR(0,X)),U,2),!
.. W:$D(DISPAR(0,X,"OUT")) ?10,"DISPAR(0,"_X_",OUT): ",$G(DISPAR(0,X,"OUT")),!
.. Q
.Q
S DIR(0)="Y",DIR("A")=" OK",DIR("B")="YES" D ^DIR K DIR G:$G(DIRUT) EXBY0 G:'Y EDBY
D EN^DIP10 G:$G(BY(0))="" EDBY Q
EXBY0 W ! K BY(0),L(0),FR(0),TO(0),DISPAR(0),DPP(0) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIP100 3174 printed Dec 13, 2024@02:52:39 Page 2
DIP100 ;SFISC/TKW - PROCESS BY(0) INPUT VARIABLES (CONT.OF DIP10) ;12:27 PM 13 Oct 1999
+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 ;
ENBY0 ; Interactive dialogue to prompt for BY(0) data
+1 if DUZ(0)'["@"
QUIT
KILL DPP,BY(0),L(0),FR(0),TO(0),DISPAR(0)
NEW DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y
EDBY WRITE !
SET DIR(0)=".401,1622O"
SET DIR("B")=$GET(BY(0))
DO ^DIR
KILL DIR
if $GET(DTOUT)!("^^@"[X)
GOTO EXBY0
if $EXTRACT(Y)="^"
SET Y=$EXTRACT(Y,2,9999)
SET BY(0)="^"_$PIECE(Y,U)
+1 SET DIR(0)=".401,1623"
SET DIR("B")=$GET(L(0))
DO ^DIR
KILL DIR
if X="@"
GOTO EDBY
if $GET(DIRUT)
GOTO EXBY0
SET L(0)=$PIECE(Y,U)
+2 FOR X=L(0):1:8
KILL FR(0,X),TO(0,X),DISPAR(0,X)
+3 if L(0)'>1
GOTO BYOK
NEW DISUB
Begin DoDot:1
E2 SET DIR("?")="Enter 'YES' to experiment with these settings"
SET DIR("?",1)="This will let you define sort ranges for any of the variable subscripts"
+1 SET DIR("?",2)="in the global referenced by BY(0). It will also let you define sort"
SET DIR("?",3)="qualifiers including page breaks and customized subheaders."
SET DIR("?",4)=""
+2 WRITE !
SET DIR(0)="Y"
SET DIR("A")="Edit ranges or subheaders"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
if 'Y!$DATA(DIRUT)
QUIT
+3 WRITE !
SET DIR(0)=".4011624,.01^^K:X>(L(0)-1) X"
SET DIR("B")=1
DO ^DIR
KILL DIR,DINUM
if $GET(DIRUT)
QUIT
SET DISUB=$PIECE(Y,U)
E3 SET DIR(0)=".4011624,1"
SET DIR("B")=$GET(FR(0,DISUB))
DO ^DIR
KILL DIR
if $GET(DTOUT)
QUIT
if $GET(DIROUT)
QUIT
if X="^"
GOTO E2
KILL FR(0,DISUB)
IF X'="@"
IF Y]""
SET FR(0,DISUB)=$PIECE(Y,U)
+1 SET DIR(0)=".4011624,2"
SET DIR("B")=$GET(TO(0,DISUB))
DO ^DIR
KILL DIR
if $GET(DTOUT)
QUIT
if $GET(DIROUT)
QUIT
if X="^"
GOTO E2
KILL TO(0,DISUB)
IF X'="@"
IF Y]""
SET TO(0,DISUB)=$PIECE(Y,U)
IF $GET(FR(0,DISUB))]$PIECE(Y,U)
Begin DoDot:2
EGP ;**CCO/NI 'START WITH IS GREATER THAN GO TO!'
WRITE !,$$EZBLD^DIALOG(1511)
QUIT
End DoDot:2
GOTO E3
+1 SET DIR(0)=".4011624,3.1"
SET DIR("B")=$PIECE($GET(DISPAR(0,DISUB)),U,1)
DO ^DIR
KILL DIR
if X="@"
Begin DoDot:2
+2 IF $PIECE($GET(DISPAR(0,DISUB)),U,2)]""
SET $PIECE(DISPAR(0,DISUB),U,1)=""
QUIT
+3 KILL DISPAR(0,DISUB)
QUIT
End DoDot:2
if $DATA(DUOUT)!$DATA(DTOUT)
GOTO E2
if Y]""
SET $PIECE(DISPAR(0,DISUB),U,1)=Y
+4 SET DIR(0)=".4011624,3.2"
SET DIR("B")=$PIECE($GET(DISPAR(0,DISUB)),U,2)
DO ^DIR
KILL DIR
if X="@"
Begin DoDot:2
+5 IF $PIECE($GET(DISPAR(0,DISUB)),U,1)]""
SET $PIECE(DISPAR(0,DISUB),U,2)=""
QUIT
+6 KILL DISPAR(0,DISUB)
QUIT
End DoDot:2
if $DATA(DIRUT)
GOTO E2
SET $PIECE(DISPAR(0,DISUB),U,2)=Y
+7 SET DIR(0)=".4011624,4"
SET DIR("B")=$GET(DISPAR(0,DISUB,"OUT"))
DO ^DIR
KILL DIR
if $GET(DTOUT)
QUIT
if $GET(DIROUT)
QUIT
KILL DISPAR(0,DISUB,"OUT")
IF "^@"'[X
IF Y]""
SET DISPAR(0,DISUB,"OUT")=Y
+8 GOTO E2
End DoDot:1
if $GET(DTOUT)!($GET(DIROUT))
GOTO EXBY0
GOTO BYOK
BYOK IF $GET(DIEDITBY)
if DUZ(0)'["@"
QUIT
NEW DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y
+1 WRITE !!," BY(0)="_BY(0)_" L(0)="_L(0),!
+2 IF L(0)>1
IF $ORDER(FR(0,0))!$ORDER(TO(0,0))!$ORDER(DISPAR(0,0))
Begin DoDot:1
+3 FOR X=1:1:(L(0)-1)
WRITE !," SUB: "_X
Begin DoDot:2
+4 WRITE ?10,"FR(0,"_X_"): ",$GET(FR(0,X)),!,?10,"TO(0,"_X_"): ",$GET(TO(0,X)),!
+5 WRITE ?10,"DISPAR(0,"_X_") PIECE ONE: ",$PIECE($GET(DISPAR(0,X)),U,1),!
+6 WRITE ?10,"DISPAR(0,"_X_") PIECE TWO: ",$PIECE($GET(DISPAR(0,X)),U,2),!
+7 if $DATA(DISPAR(0,X,"OUT"))
WRITE ?10,"DISPAR(0,"_X_",OUT): ",$GET(DISPAR(0,X,"OUT")),!
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 SET DIR(0)="Y"
SET DIR("A")=" OK"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
if $GET(DIRUT)
GOTO EXBY0
if 'Y
GOTO EDBY
+11 DO EN^DIP10
if $GET(BY(0))=""
GOTO EDBY
QUIT
EXBY0 WRITE !
KILL BY(0),L(0),FR(0),TO(0),DISPAR(0),DPP(0)
QUIT
