- DIP100 ;SFISC/TKW - PROCESS BY(0) INPUT VARIABLES (CONT.OF DIP10) ;12/8/98 07:56
- ;;22.0;VA FileMan;;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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
- .. W !," START WITH follows GO TO." Q
- . 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
- DIP100 ;SFISC/TKW - PROCESS BY(0) INPUT VARIABLES (CONT.OF DIP10) ;12/8/98 07:56
- +1 ;;22.0;VA FileMan;;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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
- +2 WRITE !," START WITH follows GO TO."
- QUIT
- End DoDot:2
- GOTO E3
- +3 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
- +4 IF $PIECE($GET(DISPAR(0,DISUB)),U,2)]""
- SET $PIECE(DISPAR(0,DISUB),U,1)=""
- QUIT
- +5 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
- +6 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
- +7 IF $PIECE($GET(DISPAR(0,DISUB)),U,1)]""
- SET $PIECE(DISPAR(0,DISUB),U,2)=""
- QUIT
- +8 KILL DISPAR(0,DISUB)
- QUIT
- End DoDot:2
- IF $DATA(DIRUT)
- GOTO E2
- SET $PIECE(DISPAR(0,DISUB),U,2)=Y
- +9 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
- +10 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
