- 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 Feb 19, 2025@00:18:53 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