SCRPW23.m

SCRPW23 ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ; 15 Jul 98  02:38PM

 ;;5.3;Scheduling;**144,474,1015**;AUG 13, 1993;Build 21

DIRB(SDFL) ;Get default values for range

 ;Required input: SDFL="F" for first, "L" for last

 N SDX S SDX=$O(SDPAR("X",SDS2,$S(SDDV:5,1:4),""),$S(SDFL="F":1,1:-1)) Q $S(SDX=""!'SDDV:SDX,1:SDPAR("X",SDS2,5,SDX))

 ;

RL ;Prompt for range or list

 N SDI,SDIRQ X:$L($P(SDACT,T,9)) $P(SDACT,T,9) S SDDV=0 S:$P(SDACT,T,2)="D" SDDV=1,SDPAR("X",SDS2,6)="D"

 I $P(SDPAR("X",SDS2,2),U)="N" D NULL Q

 I $P(SDPAR("X",SDS2,2),U)="L" D LST Q

RNG N SDR1,SDR2 D SUBT^SCRPW50("*** Item Range Selection ***")

R1 W !!,"Start with:" S SDR1=$$SEL($P(SDACT,T,2),$$DIRB("F")) Q:SDOUT!SDNUL

 S SDR2=$O(SDPAR("X",SDS2,$S(SDDV:5,1:4),""),-1) I $L(SDR2),$P(SDR1,U,$S(SDDV:1,1:2))]SDR2 F SDI=SDS1,"X" K SDPAR(SDI,SDS2,$S(SDDV:5,1:4),SDR2)

R2 W !!,"End with:" S SDR2=$$SEL($P(SDACT,T,2),$$DIRB("L")) Q:SDOUT!SDNUL

 I '$$RCOL() W !!,$C(7),"End value must collate after start value!" G R2

 F SDX="SDR1","SDR2" S SDPAR("X",SDS2,4,$P(@SDX,U,2),$P(@SDX,U))=""

 F SDX="SDR1","SDR2" S SDPAR("X",SDS2,5,$P(@SDX,U))=$P(@SDX,U,2)

 Q

 ;

RCOL() ;Determine range collation validity

 ;Output: 1=valid, 0=invalid

 I $P(SDR1,U,2)=+$P(SDR1,U,2),$P(SDR2,U,2)=+$P(SDR2,U,2) Q SDR1'>SDR2

 I SDDV Q $P(SDR1,U)'>$P(SDR2,U)

 Q $P(SDR1,U,2)']$P(SDR2,U,2)

 ;

NULL ;Set list for null value

 S SDPAR("X",SDS2,4,"~~~NONE~~~","~~~NONE~~~")="",SDPAR("X",SDS2,5,"~~~NONE~~~")="~~~NONE~~~" Q

 ;

LST I $D(SDPAR("X",SDS2,4)) D LST1

 D SUBT^SCRPW50("*** Item List Selection ***") W !

 F I=1:1:$P(SDACT,T,6) S SDX=$$SEL($P(SDACT,T,2)) Q:SDOUT!SDNUL  D LST0

 Q

 ;

LST0 I $D(SDPAR("X",SDS2,5,$P(SDX,U))) Q:$$LSD()

 S SDPAR("X",SDS2,5,$P(SDX,U))=$P(SDX,U,2),SDPAR("X",SDS2,4,$P(SDX,U,2),$P(SDX,U))=""

 Q

 ;

LSD() N DIR W !!,$C(7),$P(SDX,U,2)," is already selected." S DIR(0)="Y",DIR("A")="Do you want to delete it",DIR("B")="NO" D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q 0

 I Y D  W !,"   ...deleted." Q 1

 .F SDI=SDS1,"X" K SDPAR(SDI,SDS2,5,$P(SDX,U)),SDPAR(SDI,SDS2,4,$P(SDX,U,2),$P(SDX,U))

 .Q

 Q 0

 ;

LST1 ;List existing item selections

 N SDOUT,SDL,SDX S SDOUT=0,SDL=1,SDX="" W !,"Items currently selected:"

 F  S SDX=$O(SDPAR("X",SDS2,4,SDX)) Q:SDX=""!SDOUT  S SDL=SDL+1 W !?5,SDX D:SDL>15 WAIT^SCRPW22

 Q

 ;

SEL(SDTYP,SDIRB) ;Select items for list or range

 ;Required input: SDTYP=type of data (D, P, F, N, T, C, PP, S)

 ;Optional input: SDIRB=value for default prompt

 N SDX S SDX="" D @SDTYP Q SDX

 ;

D ;Get date values

 N DIR M DIR=SDIRQ S DIR(0)=$P(SDACT,T,4),DIR("A")="Select "_$P(SDACT,T) S:$L($G(SDIRB)) DIR("B")=SDIRB D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q

 I '$L(Y) S SDNUL=1 Q

 S SDX=Y X ^DD("DD") S SDX=SDX_U_Y X:$L($P(SDACT,T,8)) $P(SDACT,T,8) Q

 ;

P ;Get pointer values ;SD*5.3*474 added PSCRN to screen certain status types

 N DIC M DIC=SDIRQ S DIC=$P(SDACT,T,3),DIC(0)="AEMQ",DIC("S")=$P(SDACT,T,4) K:'$L(DIC("S")) DIC("S") D:DIC="^SD(409.63," PSCRN D ^DIC I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q

 I Y'>0 S SDNUL=1 Q

 S SDX=Y X:$L($P(SDACT,T,8)) $P(SDACT,T,8) Q

 ;

PSCRN ;screen out the 4 cancellation type status' SD*5.3*474

 S DIC("S")="I $P(^(0),U,2)'=""C"",$P(^(0),U,2)'=""CA"",$P(^(0),U,2)'=""PC"",$P(^(0),U,2)'=""PCA"""

 Q

 ;

F ;Get field values

 N DIR M DIR=SDIRQ S DIR(0)=$P(SDACT,T,3) S:$L($G(SDIRB)) DIR("B")=SDIRB D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q

 I '$D(DIR("B")),X="" S SDNUL=1 Q

 S SDX=Y_U_$G(Y(0)) X:$L($P(SDACT,T,8)) $P(SDACT,T,8) Q

 ;

N ;Get number value

 N DIR M DIR=SDIRQ S DIR(0)=$P(SDACT,T,4),DIR("A")="Select "_$P(SDACT,T) S:$L($G(SDIRB)) DIR("B")=SDIRB D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q

 I Y'?1.N S SDNUL=1 Q

 S SDX=Y_U_Y X:$L($P(SDACT,T,8)) $P(SDACT,T,8) Q

 ;

T ;Get text value

 N DIR M DIR=SDIRQ S DIR(0)=$P(SDACT,T,4),DIR("A")="Select "_$P(SDACT,T) S:$L($G(SDIRB)) DIR("B")=SDIRB D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q

 I '$L(Y) S SDNUL=1 Q

 S SDX=Y_U_Y X:$L($P(SDACT,T,8)) $P(SDACT,T,8) Q

 ;

C ;Get computed value

 D @($P(SDACT,T,4)) X:$L($P(SDACT,T,8)) $P(SDACT,T,8) Q

 ;

PP ;Get pointer value from file multiple

 N DIC M DIC=SDIRQ S DIC=$P($P(SDACT,T,3),";"),DIC(0)="AEMQ",DIC("B")=$P($G(SDIRB),";") K:'$L(DIC("B")) DIC("B") D ^DIC I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q

 I Y<1 S SDNUL=1 Q

 S SDX=Y,DIC=DIC_+SDX_$P($P(SDACT,T,3),";",2),DIC("B")=$P($G(SDIRB),";",2) K:'$L(DIC("B")) DIC("B") D ^DIC I $D(DTOUT)!$D(DUOUT) S SDX="",SDOUT=1 Q

 I Y<1 S SDX="",SDNUL=1 Q

 S SDX=+SDX_";"_+Y_U_$P(SDX,U,2)_" / "_$P(Y,U,2) X:$L($P(SDACT,T,8)) $P(SDACT,T,8) Q

 ;

S ;Get set-of-codes value

 N DIR M DIR=SDIRQ X $P(SDACT,T,3) S DIR("A")="Select "_$P(SDACT,T) S:$L($G(SDIRB)) DIR("B")=SDIRB D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q

 I '$L(Y) S SDNUL=1 Q

 S SDX=Y_U_Y(0) X:$L($P(SDACT,T,8)) $P(SDACT,T,8) Q

 ;

VCP(SDX) ;Validate Stop Code credit pair

 ;Required input: SDX=6 digit numeric value

 ;Output: 1=valid credit pair, 0=invalid credit pair

 G:SDX'?6N VCPQ G:'$D(^DIC(40.7,"C",$E(SDX,1,3))) VCPQ G:'$D(^DIC(40.7,"C",$E(SDX,4,6)))&($E(SDX,4,6)'="000") VCPQ

 Q 1

 ;

VCPQ W $C(7),"   ??",!,"This response must be a 6 digit numeric value",!,"that represents two valid stop codes!" Q 0

 ;

PLIST ;Print category list

 N ZTSAVE D EN^XUTMDEVQ("PLST^SCRPW23","CATEGORY LIST",.ZTSAVE) Q

PLST ;Print category list

 D:'$D(^TMP("SCRPW",$J,"SEL")) BLD^SCRPW21

 S I=0 F  S I=$O(^TMP("SCRPW",$J,"SEL",1,I)) Q:'I  S X1=$O(^TMP("SCRPW",$J,"SEL",1,I,"")) W !!,$P(^TMP("SCRPW",$J,"SEL",1,I,X1),"~") D PLST1

 K I,II,X1,X2,^TMP("SCRPW",$J) Q

 ;

PLST1 S II=0 F  S II=$O(^TMP("SCRPW",$J,"SEL",2,X1,II)) Q:'II  S X2=$O(^TMP("SCRPW",$J,"SEL",2,X1,II,"")) W !?4,$P(^TMP("SCRPW",$J,"SEL",2,X1,II,X2),"~")

 Q

 ;

DISP0 ;Return to full screen scrolling

 Q:$E(IOST)'="C"

 D ENS^%ZISS S SDRM=^%ZOSF("RM"),SDXY=^%ZOSF("XY"),(IOTM,IOBM)=0 W $$XY(IOSTBM,1),@IOF N DX,DY,X S (DX,DY)=0 X SDXY S X=IOM X SDRM Q

 ;

DISP(SDTOP,SDBOT) ;Create centered scrolling region

 ;Required input: SDTOP=text to center at top of screen

 ;Required input: SDBOT(n)=numbered array of text to display at bottom of screen

 N X D DISP0 S X=0 X SDRM W $$XY(IORVON) F I=1:1:(78-$L(SDTOP)\2) W "-"

 W " ",SDTOP," " F  W "-" Q:$X>79

 W $$XY(IORVOFF) S IOTM=3 W $$XY(IOSTBM,1) S (C,I)="" F  S I=$O(SDBOT(I)) Q:I=""  S C=C+1

 F  W ! Q:$Y>(IOSL-C)

 S II=$O(SDBOT("")) Q:II=""  W $$XY(IORVON) F I=1:1:(78-$L(SDBOT(II))\2) W "-"

 W " ",SDBOT(II)," " F  W "-" Q:$X>79

 W $$XY(IORVOFF) F  S II=$O(SDBOT(II)) Q:II=""  W !,$E(SDBOT(II),1,80)

 S IOBM=(IOSL-C-1) W $$XY(IOSTBM,1) Q

 ;

XY(X,SDI) ;Maintain $X, $Y

 ;Required input: X=screen handling variable to write

 ;Optional input: SDI=1 (to specify the use of indirection)

 N DX,DY S DX=$X,DY=$Y

 I $G(SDI) W @X X SDXY Q ""

 W X X SDXY Q ""

 ;

DIR(DIR,SDLEV,SDEXE,SDS,SDO,SDPFL,SDA) ;Ask questions!

 ;Required input: DIR array (pass by reference)

 ;Required input: SDLEV=level to build DIR(0) for large sets

 ;Optional input: SDEXE=code to execute prior to ^DIR

 ;Optional input: SDS=subscript lookup value for level 2 (required for level 2)

 ;Optional input: SDO="O" to indicate input is optional

 ;Optional input: SDPFL=print field level (1,2) for print field prompts

 ;Optional input: SDA=1 to force single item selection prompt

 X:$L($G(SDEXE)) SDEXE I '$D(DIR(0)) D @("DIR"_SDLEV)

 I '$G(SDA),$E(DIR(0))="S",$L(DIR(0),":")=2 Q $P($P(DIR(0),U,2),":")_U_$P(DIR(0),":",2)

 D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q ""

 I X="" S SDNUL=1 Q ""

 Q Y_U_$S($L($G(Y(0))):Y(0),1:Y)

 ;

DIR1 N X,I,II S X="",I=0 F  S I=$O(^TMP("SCRPW",$J,"SEL",1,I)) Q:'I  S II="" F  S II=$O(^TMP("SCRPW",$J,"SEL",1,I,II)) Q:II=""  S:$$PFL1() X=X_";"_II_":"_$P(^TMP("SCRPW",$J,"SEL",1,I,II),T)

 S DIR(0)="S"_$G(SDO)_"^"_$E(X,2,245) Q

 ;

DIR2 N X,I,II S X="",I=0 F  S I=$O(^TMP("SCRPW",$J,"SEL",2,SDS,I)) Q:'I  S II="" F  S II=$O(^TMP("SCRPW",$J,"SEL",2,SDS,I,II)) Q:II=""  S:$$PFL2() X=X_";"_II_":"_$P(^TMP("SCRPW",$J,"SEL",2,SDS,I,II),T)

 S DIR(0)="S"_$G(SDO)_"^"_$E(X,2,245) Q

 ;

PFL1() ;Print field level 1 evaluator

 Q:'$G(SDPFL) 1

 Q $P(^TMP("SCRPW",$J,"SEL",1,I,II),T,2)>(SDPFL-1)

 ;

PFL2() ;Print field level 2 evaluator

 Q:'$G(SDPFL) 1

 Q $P(^TMP("SCRPW",$J,"SEL",2,SDS,I,II),T,2)>(SDPFL-1)

 ;

DIRB1(S1,S2,SDEF) ;Set DIR("B")

 ;Required input: S1, S2=subscript values

 ;Optional input: SDEF=default value

 S DIR("B")=$S($D(SDPAR(S1,S2)):$P(SDPAR(S1,S2),U,2),1:$G(SDEF))

 K:'$L(DIR("B")) DIR("B") Q

SCRPW23   ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ; 15 Jul 98  02:38PM

 +1       ;;5.3;Scheduling;**144,474,1015**;AUG 13, 1993;Build 21

DIRB(SDFL) ;Get default values for range

 +1       ;Required input: SDFL="F" for first, "L" for last

 +2        NEW SDX

           SET SDX=$ORDER(SDPAR("X",SDS2,$SELECT(SDDV:5,1:4),""),$SELECT(SDFL="F":1,1:-1))

           QUIT $SELECT(SDX=""!'SDDV:SDX,1:SDPAR("X",SDS2,5,SDX))

 +3       ;

RL        ;Prompt for range or list

 +1        NEW SDI,SDIRQ

           IF $LENGTH($PIECE(SDACT,T,9))

               XECUTE $PIECE(SDACT,T,9)

           SET SDDV=0

           IF $PIECE(SDACT,T,2)="D"

               SET SDDV=1

               SET SDPAR("X",SDS2,6)="D"

 +2        IF $PIECE(SDPAR("X",SDS2,2),U)="N"

               DO NULL

               QUIT 

 +3        IF $PIECE(SDPAR("X",SDS2,2),U)="L"

               DO LST

               QUIT 

RNG        NEW SDR1,SDR2

           DO SUBT^SCRPW50("*** Item Range Selection ***")

R1         WRITE !!,"Start with:"

           SET SDR1=$$SEL($PIECE(SDACT,T,2),$$DIRB("F"))

           IF SDOUT!SDNUL

               QUIT 

 +1        SET SDR2=$ORDER(SDPAR("X",SDS2,$SELECT(SDDV:5,1:4),""),-1)

           IF $LENGTH(SDR2)

               IF $PIECE(SDR1,U,$SELECT(SDDV:1,1:2))]SDR2

                   FOR SDI=SDS1,"X"

                       KILL SDPAR(SDI,SDS2,$SELECT(SDDV:5,1:4),SDR2)

R2         WRITE !!,"End with:"

           SET SDR2=$$SEL($PIECE(SDACT,T,2),$$DIRB("L"))

           IF SDOUT!SDNUL

               QUIT 

 +1        IF '$$RCOL()

               WRITE !!,$CHAR(7),"End value must collate after start value!"

               GOTO R2

 +2        FOR SDX="SDR1","SDR2"

               SET SDPAR("X",SDS2,4,$PIECE(@SDX,U,2),$PIECE(@SDX,U))=""

 +3        FOR SDX="SDR1","SDR2"

               SET SDPAR("X",SDS2,5,$PIECE(@SDX,U))=$PIECE(@SDX,U,2)

 +4        QUIT 

 +5       ;

RCOL()    ;Determine range collation validity

 +1       ;Output: 1=valid, 0=invalid

 +2        IF $PIECE(SDR1,U,2)=+$PIECE(SDR1,U,2)

               IF $PIECE(SDR2,U,2)=+$PIECE(SDR2,U,2)

                   QUIT SDR1'>SDR2

 +3        IF SDDV

               QUIT $PIECE(SDR1,U)'>$PIECE(SDR2,U)

 +4        QUIT $PIECE(SDR1,U,2)']$PIECE(SDR2,U,2)

 +5       ;

NULL      ;Set list for null value

 +1        SET SDPAR("X",SDS2,4,"~~~NONE~~~","~~~NONE~~~")=""

           SET SDPAR("X",SDS2,5,"~~~NONE~~~")="~~~NONE~~~"

           QUIT 

 +2       ;

LST        IF $DATA(SDPAR("X",SDS2,4))

               DO LST1

 +1        DO SUBT^SCRPW50("*** Item List Selection ***")

           WRITE !

 +2        FOR I=1:1:$PIECE(SDACT,T,6)

               SET SDX=$$SEL($PIECE(SDACT,T,2))

               IF SDOUT!SDNUL

                   QUIT 

               DO LST0

 +3        QUIT 

 +4       ;

LST0       IF $DATA(SDPAR("X",SDS2,5,$PIECE(SDX,U)))

               IF $$LSD()

                   QUIT 

 +1        SET SDPAR("X",SDS2,5,$PIECE(SDX,U))=$PIECE(SDX,U,2)

           SET SDPAR("X",SDS2,4,$PIECE(SDX,U,2),$PIECE(SDX,U))=""

 +2        QUIT 

 +3       ;

LSD()      NEW DIR

           WRITE !!,$CHAR(7),$PIECE(SDX,U,2)," is already selected."

           SET DIR(0)="Y"

           SET DIR("A")="Do you want to delete it"

           SET DIR("B")="NO"

           DO ^DIR

           IF $DATA(DTOUT)!$DATA(DUOUT)

               SET SDOUT=1

               QUIT 0

 +1        IF Y

               Begin DoDot:1

 +2                FOR SDI=SDS1,"X"

                       KILL SDPAR(SDI,SDS2,5,$PIECE(SDX,U)),SDPAR(SDI,SDS2,4,$PIECE(SDX,U,2),$PIECE(SDX,U))

 +3                QUIT 

               End DoDot:1

               WRITE !,"   ...deleted."

               QUIT 1

 +4        QUIT 0

 +5       ;

LST1      ;List existing item selections

 +1        NEW SDOUT,SDL,SDX

           SET SDOUT=0

           SET SDL=1

           SET SDX=""

           WRITE !,"Items currently selected:"

 +2        FOR 

               SET SDX=$ORDER(SDPAR("X",SDS2,4,SDX))

               IF SDX=""!SDOUT

                   QUIT 

               SET SDL=SDL+1

               WRITE !?5,SDX

               IF SDL>15

                   DO WAIT^SCRPW22

 +3        QUIT 

 +4       ;

SEL(SDTYP,SDIRB) ;Select items for list or range

 +1       ;Required input: SDTYP=type of data (D, P, F, N, T, C, PP, S)

 +2       ;Optional input: SDIRB=value for default prompt

 +3        NEW SDX

           SET SDX=""

           DO @SDTYP

           QUIT SDX

 +4       ;

D         ;Get date values

 +1        NEW DIR

           MERGE DIR=SDIRQ

           SET DIR(0)=$PIECE(SDACT,T,4)

           SET DIR("A")="Select "_$PIECE(SDACT,T)

           IF $LENGTH($GET(SDIRB))

               SET DIR("B")=SDIRB

           DO ^DIR

           IF $DATA(DTOUT)!$DATA(DUOUT)

               SET SDOUT=1

               QUIT 

 +2        IF '$LENGTH(Y)

               SET SDNUL=1

               QUIT 

 +3        SET SDX=Y

           XECUTE ^DD("DD")

           SET SDX=SDX_U_Y

           IF $LENGTH($PIECE(SDACT,T,8))

               XECUTE $PIECE(SDACT,T,8)

           QUIT 

 +4       ;

P         ;Get pointer values ;SD*5.3*474 added PSCRN to screen certain status types

 +1        NEW DIC

           MERGE DIC=SDIRQ

           SET DIC=$PIECE(SDACT,T,3)

           SET DIC(0)="AEMQ"

           SET DIC("S")=$PIECE(SDACT,T,4)

           IF '$LENGTH(DIC("S"))

               KILL DIC("S")

           IF DIC="^SD(409.63,"

               DO PSCRN

           DO ^DIC

           IF $DATA(DTOUT)!$DATA(DUOUT)

               SET SDOUT=1

               QUIT 

 +2        IF Y'>0

               SET SDNUL=1

               QUIT 

 +3        SET SDX=Y

           IF $LENGTH($PIECE(SDACT,T,8))

               XECUTE $PIECE(SDACT,T,8)

           QUIT 

 +4       ;

PSCRN     ;screen out the 4 cancellation type status' SD*5.3*474

 +1        SET DIC("S")="I $P(^(0),U,2)'=""C"",$P(^(0),U,2)'=""CA"",$P(^(0),U,2)'=""PC"",$P(^(0),U,2)'=""PCA"""

 +2        QUIT 

 +3       ;

F         ;Get field values

 +1        NEW DIR

           MERGE DIR=SDIRQ

           SET DIR(0)=$PIECE(SDACT,T,3)

           IF $LENGTH($GET(SDIRB))

               SET DIR("B")=SDIRB

           DO ^DIR

           IF $DATA(DTOUT)!$DATA(DUOUT)

               SET SDOUT=1

               QUIT 

 +2        IF '$DATA(DIR("B"))

               IF X=""

                   SET SDNUL=1

                   QUIT 

 +3        SET SDX=Y_U_$GET(Y(0))

           IF $LENGTH($PIECE(SDACT,T,8))

               XECUTE $PIECE(SDACT,T,8)

           QUIT 

 +4       ;

N         ;Get number value

 +1        NEW DIR

           MERGE DIR=SDIRQ

           SET DIR(0)=$PIECE(SDACT,T,4)

           SET DIR("A")="Select "_$PIECE(SDACT,T)

           IF $LENGTH($GET(SDIRB))

               SET DIR("B")=SDIRB

           DO ^DIR

           IF $DATA(DTOUT)!$DATA(DUOUT)

               SET SDOUT=1

               QUIT 

 +2        IF Y'?1.N

               SET SDNUL=1

               QUIT 

 +3        SET SDX=Y_U_Y

           IF $LENGTH($PIECE(SDACT,T,8))

               XECUTE $PIECE(SDACT,T,8)

           QUIT 

 +4       ;

T         ;Get text value

 +1        NEW DIR

           MERGE DIR=SDIRQ

           SET DIR(0)=$PIECE(SDACT,T,4)

           SET DIR("A")="Select "_$PIECE(SDACT,T)

           IF $LENGTH($GET(SDIRB))

               SET DIR("B")=SDIRB

           DO ^DIR

           IF $DATA(DTOUT)!$DATA(DUOUT)

               SET SDOUT=1

               QUIT 

 +2        IF '$LENGTH(Y)

               SET SDNUL=1

               QUIT 

 +3        SET SDX=Y_U_Y

           IF $LENGTH($PIECE(SDACT,T,8))

               XECUTE $PIECE(SDACT,T,8)

           QUIT 

 +4       ;

C         ;Get computed value

 +1        DO @($PIECE(SDACT,T,4))

           IF $LENGTH($PIECE(SDACT,T,8))

               XECUTE $PIECE(SDACT,T,8)

           QUIT 

 +2       ;

PP        ;Get pointer value from file multiple

 +1        NEW DIC

           MERGE DIC=SDIRQ

           SET DIC=$PIECE($PIECE(SDACT,T,3),";")

           SET DIC(0)="AEMQ"

           SET DIC("B")=$PIECE($GET(SDIRB),";")

           IF '$LENGTH(DIC("B"))

               KILL DIC("B")

           DO ^DIC

           IF $DATA(DTOUT)!$DATA(DUOUT)

               SET SDOUT=1

               QUIT 

 +2        IF Y<1

               SET SDNUL=1

               QUIT 

 +3        SET SDX=Y

           SET DIC=DIC_+SDX_$PIECE($PIECE(SDACT,T,3),";",2)

           SET DIC("B")=$PIECE($GET(SDIRB),";",2)

           IF '$LENGTH(DIC("B"))

               KILL DIC("B")

           DO ^DIC

           IF $DATA(DTOUT)!$DATA(DUOUT)

               SET SDX=""

               SET SDOUT=1

               QUIT 

 +4        IF Y<1

               SET SDX=""

               SET SDNUL=1

               QUIT 

 +5        SET SDX=+SDX_";"_+Y_U_$PIECE(SDX,U,2)_" / "_$PIECE(Y,U,2)

           IF $LENGTH($PIECE(SDACT,T,8))

               XECUTE $PIECE(SDACT,T,8)

           QUIT 

 +6       ;

S         ;Get set-of-codes value

 +1        NEW DIR

           MERGE DIR=SDIRQ

           XECUTE $PIECE(SDACT,T,3)

           SET DIR("A")="Select "_$PIECE(SDACT,T)

           IF $LENGTH($GET(SDIRB))

               SET DIR("B")=SDIRB

           DO ^DIR

           IF $DATA(DTOUT)!$DATA(DUOUT)

               SET SDOUT=1

               QUIT 

 +2        IF '$LENGTH(Y)

               SET SDNUL=1

               QUIT 

 +3        SET SDX=Y_U_Y(0)

           IF $LENGTH($PIECE(SDACT,T,8))

               XECUTE $PIECE(SDACT,T,8)

           QUIT 

 +4       ;

VCP(SDX)  ;Validate Stop Code credit pair

 +1       ;Required input: SDX=6 digit numeric value

 +2       ;Output: 1=valid credit pair, 0=invalid credit pair

 +3        IF SDX'?6N

               GOTO VCPQ

           IF '$DATA(^DIC(40.7,"C",$EXTRACT(SDX,1,3)))

               GOTO VCPQ

           IF '$DATA(^DIC(40.7,"C",$EXTRACT(SDX,4,6)))&($EXTRACT(SDX,4,6)'="000")

               GOTO VCPQ

 +4        QUIT 1

 +5       ;

VCPQ       WRITE $CHAR(7),"   ??",!,"This response must be a 6 digit numeric value",!,"that represents two valid stop codes!"

           QUIT 0

 +1       ;

PLIST     ;Print category list

 +1        NEW ZTSAVE

           DO EN^XUTMDEVQ("PLST^SCRPW23","CATEGORY LIST",.ZTSAVE)

           QUIT 

PLST      ;Print category list

 +1        IF '$DATA(^TMP("SCRPW",$JOB,"SEL"))

               DO BLD^SCRPW21

 +2        SET I=0

           FOR 

               SET I=$ORDER(^TMP("SCRPW",$JOB,"SEL",1,I))

               IF 'I

                   QUIT 

               SET X1=$ORDER(^TMP("SCRPW",$JOB,"SEL",1,I,""))

               WRITE !!,$PIECE(^TMP("SCRPW",$JOB,"SEL",1,I,X1),"~")

               DO PLST1

 +3        KILL I,II,X1,X2,^TMP("SCRPW",$JOB)

           QUIT 

 +4       ;

PLST1      SET II=0

           FOR 

               SET II=$ORDER(^TMP("SCRPW",$JOB,"SEL",2,X1,II))

               IF 'II

                   QUIT 

               SET X2=$ORDER(^TMP("SCRPW",$JOB,"SEL",2,X1,II,""))

               WRITE !?4,$PIECE(^TMP("SCRPW",$JOB,"SEL",2,X1,II,X2),"~")

 +1        QUIT 

 +2       ;

DISP0     ;Return to full screen scrolling

 +1        IF $EXTRACT(IOST)'="C"

               QUIT 

 +2        DO ENS^%ZISS

           SET SDRM=^%ZOSF("RM")

           SET SDXY=^%ZOSF("XY")

           SET (IOTM,IOBM)=0

           WRITE $$XY(IOSTBM,1),@IOF

           NEW DX,DY,X

           SET (DX,DY)=0

           XECUTE SDXY

           SET X=IOM

           XECUTE SDRM

           QUIT 

 +3       ;

DISP(SDTOP,SDBOT) ;Create centered scrolling region

 +1       ;Required input: SDTOP=text to center at top of screen

 +2       ;Required input: SDBOT(n)=numbered array of text to display at bottom of screen

 +3        NEW X

           DO DISP0

           SET X=0

           XECUTE SDRM

           WRITE $$XY(IORVON)

           FOR I=1:1:(78-$LENGTH(SDTOP)\2)

               WRITE "-"

 +4        WRITE " ",SDTOP," "

           FOR 

               WRITE "-"

               IF $X>79

                   QUIT 

 +5        WRITE $$XY(IORVOFF)

           SET IOTM=3

           WRITE $$XY(IOSTBM,1)

           SET (C,I)=""

           FOR 

               SET I=$ORDER(SDBOT(I))

               IF I=""

                   QUIT 

               SET C=C+1

 +6        FOR 

               WRITE !

               IF $Y>(IOSL-C)

                   QUIT 

 +7        SET II=$ORDER(SDBOT(""))

           IF II=""

               QUIT 

           WRITE $$XY(IORVON)

           FOR I=1:1:(78-$LENGTH(SDBOT(II))\2)

               WRITE "-"

 +8        WRITE " ",SDBOT(II)," "

           FOR 

               WRITE "-"

               IF $X>79

                   QUIT 

 +9        WRITE $$XY(IORVOFF)

           FOR 

               SET II=$ORDER(SDBOT(II))

               IF II=""

                   QUIT 

               WRITE !,$EXTRACT(SDBOT(II),1,80)

 +10       SET IOBM=(IOSL-C-1)

           WRITE $$XY(IOSTBM,1)

           QUIT 

 +11      ;

XY(X,SDI) ;Maintain $X, $Y

 +1       ;Required input: X=screen handling variable to write