SCRPW22.m

SCRPW22 ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ;03 Aug 98  9:36 PM

 ;;5.3;Scheduling;**144,593**;AUG 13, 1993;Build 13

PLIST(C,SDLP,SDTEMP) ;Display parameter list

 ;Required input: C=column to format left margin

 ;Required input: SDLP=number of lines to print on a page

 ;Optional input: SDTEMP=array of template information to print

 N SDI,SDII,SDS1,SDS2,SDX,SDX1,SDX2,SDL S (SDOUT,SDL)=0

 D PHD(" R E P O R T   F O R M A T ") Q:SDOUT  D D1("F","") Q:SDOUT

 D PHD(" R E P O R T   P E R S P E C T I V E ") Q:SDOUT  D D2("Perspective","P",1) Q:SDOUT

 D PHD(" R E P O R T   L I M I T A T I O N S ") Q:SDOUT  D D1("L",2) Q:SDOUT

 S SDS1="L",SDS2=2 F  S SDS2=$O(SDPAR(SDS1,SDS2)) Q:'SDS2!SDOUT  D:SDL>SDLP WAIT Q:SDOUT  W ! S SDL=SDL+1 D D2("Addl. limitation",SDS1,SDS2)

 Q:SDOUT  D PHD(" R E P O R T   P R I N T   O R D E R ") Q:SDOUT  D D1("O","")

 I $D(SDPAR("PF")) D PHD(" A D D I T I O N A L   P R I N T   F I E L D S ") Q:SDOUT

 F SDS2=2,1 S SDS3=0 F  S SDS3=$O(SDPAR("PF",SDS2,SDS3)) Q:'SDS3  S SDX=SDPAR("PF",SDS2,SDS3) D:SDL>SDLP WAIT Q:SDOUT  W !?(C+36-$L($P(SDX,U,2))),$P(SDX,U,2),": ",$E($P(SDX,U,3),1,(42+C)) S SDL=SDL+1

 Q:SDOUT  D:SDL>SDLP WAIT Q:SDOUT  D:$D(SDTEMP)>1 PHD(" T E M P L A T E   I N F O R M A T I O N "),PTMP Q:SDOUT

 D:SDL>SDLP WAIT Q:SDOUT  W ! S SDL=SDL+1 D:SDL>SDLP WAIT Q:SDOUT  W ! S SDL=SDL+1 F SDI=1:1:IOM W "-"

 I $E(IOST)="C" D WAIT

 Q

 ;

PTMP N SDI S SDI=0 F  S SDI=$O(SDTEMP(SDI)) Q:'SDI!SDOUT  S SDX=$P(SDTEMP(SDI),U),SDX1=$P(SDTEMP(SDI),U,2) D D2P

 Q

 ;

D1(SDI,SDE) S SDII="" F  S SDII=$O(SDPAR(SDI,SDII)) Q:SDII=""!(SDE&(SDII>SDE))  S SDX=$P($T(@SDI+SDII),";;",2) D:SDL>SDLP WAIT Q:SDOUT  W !?(C+36-$L(SDX)),SDX,": ",$E($P(SDPAR(SDI,SDII),U,2),1,(42+C)) S SDL=SDL+1

 Q

 ;

D2(SDTX,SDS1,SDS2) N DIWL,DIWF,SDL2 S DIWL=1 S DIWF="C"_(42+C)_"|"

 Q:'$D(SDPAR(SDS1,SDS2))  S SDX=SDTX_" category",SDX1=$P(SDPAR(SDS1,SDS2),U,2) D D2P Q:SDOUT

 Q:'$D(SDPAR(SDS1,SDS2,1))  S SDX=SDTX_" sub-category",SDX1=$P(SDPAR(SDS1,SDS2,1),U,2) D D2P Q:SDOUT

 Q:'$D(SDPAR(SDS1,SDS2,2))  S SDX2=$P(SDPAR(SDS1,SDS2,2),U) D:SDL>SDLP WAIT Q:SDOUT  S SDX1=$O(SDPAR(SDS1,SDS2,4,"")) Q:SDX1=""

 S SDX=$S(SDS1="P":"Detail",$P(SDPAR(SDS1,SDS2,3),U)="I":"Include",1:"Exclude")_" "_$S("LN"[SDX2:"list",1:"range - from") D D2P Q:SDOUT

 I SDX2="R" S SDX="to",SDX1=$O(SDPAR(SDS1,SDS2,4,SDX1)) Q:SDX1=""  D D2P Q

 F  S SDX1=$O(SDPAR(SDS1,SDS2,4,SDX1)) Q:SDX1=""!SDOUT  D:SDL>SDLP WAIT Q:SDOUT  D

 . K ^UTILITY($J,"W") S X=SDX1 D ^DIWP

 . F SDL2=1:1:^UTILITY($J,"W",DIWL) D  S SDL=SDL+1 D:SDL>SDLP WAIT Q:SDOUT

 . . W !?(38+C),$E(^UTILITY($J,"W",DIWL,SDL2,0),1,(42+C))

 Q

 ;

D2P N DIWL,DIWF,SDL2 S DIWL=1 S DIWF="C"_(42+C)_"|"

 D:SDL>SDLP WAIT Q:SDOUT

 K ^UTILITY($J,"W") S X=SDX1 D ^DIWP

 F SDL2=1:1:^UTILITY($J,"W",DIWL) D  S SDL=SDL+1 D:SDL>SDLP WAIT Q:SDOUT

 . I SDL2=1 W !?(C+36-$L(SDX)),SDX,": ",$E(^UTILITY($J,"W",DIWL,SDL2,0),1,(42+C)) I 1

 . E  W !?(38+C),$E(^UTILITY($J,"W",DIWL,SDL2,0),1,(42+C))

 Q

 ;

F ;Format captions

 ;;Report output format

 ;;Compare data to previous year

 ;;Type of detail

 ;;List activity detail by

 ;;Limit Dx/Proc. list to most frequent

 ;;Produce output as

L ;Limitation captions

 ;;Starting date

 ;;Ending date

O ;Order caption

 ;;Output order

 ;;Report descriptive title

 ;

XY(X) ;Maintain $X, $Y

 ;Required input: X=screen handling variable to write

 S:'$D(SDXY) SDXY=^%ZOSF("XY") N DX,DY S DX=$X,DY=$Y W X X SDXY Q ""

 ;

PHD(SDH) ;Parameter header

 ;Required input: SDH=header value

 W ! S SDL=SDL+1 D:(SDL+1)>SDLP WAIT Q:SDOUT

 W ! S SDL=SDL+1

 F  W "-" Q:$X>(IOM-3-$L(SDH)\2)

 W " ",SDH," " F  W "-" Q:$X>(IOM-1)

 W ! S SDL=SDL+1 D:SDL>SDLP WAIT Q

 ;

WAIT I $E(IOST)="C" N DIR S DIR(0)="E" D ^DIR S:'Y SDOUT=1 W:'SDOUT $$XY(IOELALL),$$XY(IOCUU) S SDL=0 Q

 D HDR^SCRPW29("Report Parameters Selected") S SDL=0 Q

 ;

CAT(SDA) ;Enter edit perspective and limitation categories

 ;Required entry: SDA="A" for add or "E" for edit

 K SDPAR("X") M:SDA="E" SDPAR("X")=SDPAR(SDS1) I SDS1="L",SDA="E" S SDSEL=$P(SDPAR(SDS1,SDS2),U)_$P(SDPAR(SDS1,SDS2,1),U) G CAT1

 S (SDSEL,SDX)=$$DIR^SCRPW23(.DIR,1,"","","O") Q:SDOUT!SDNUL

 I SDA="E",SDX'=SDPAR(SDS1,SDS2) K SDPAR("X",SDS2)

 S SDPAR("X",SDS2)=SDX

 K SDEXE D PRMT("X",SDS2) S SDX=$$DIR^SCRPW23(.DIR,2,$G(SDEXE),$P(SDPAR("X",SDS2),U)) G:SDOUT!SDNUL CATQ

 I SDA="E",SDX'=$G(SDPAR("X",SDS2,1)) D

 .F SDI=1:1:6 K SDPAR("X",SDS2,SDI)

 .F SDI=4,5,6 K SDPAR(SDS1,SDS2,SDI)

 .Q

 S SDPAR("X",SDS2,1)=SDX,SDSEL=$P(SDSEL,U)_$P(SDX,U)

 I SDS1="P",$P(SDPAR("F",1),U)="S" M SDPAR(SDS1)=SDPAR("X") Q

CAT1 S SDACT=^TMP("SCRPW",$J,"ACT",SDSEL)

 I SDS1="P" S SDLR="L",SDX=$$RL() G:SDOUT CATQ S SDPAR("X",SDS2,2)=SDX D RL^SCRPW23 S (SDOUT,SDNUL)=0 M:$D(SDPAR("X",SDS2,4)) SDPAR(SDS1)=SDPAR("X") G:'$D(SDPAR("X",SDS2,4)) CATQ D CATD Q

 S SDLR=$P(SDACT,T,5),SDX=$$RL() G:SDOUT CATQ I SDA="E",SDX'=SDPAR("X",SDS2,2) F SDI=4,5 K SDPAR("X",SDS2,SDI)

 S SDPAR("X",SDS2,2)=SDX D RL^SCRPW23,CATD S (SDOUT,SDNUL)=0 G:'$D(SDPAR("X",SDS2,4)) CATQ

 K DIR D DIRB("X",SDS2,3) S DIR(0)="S^I:INCLUDE;E:EXCLUDE",DIR("A")="Include or exclude records in this category" D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G CATQ

 S SDPAR("X",SDS2,3)=Y_U_Y(0) M SDPAR(SDS1)=SDPAR("X") Q

 ;

CATD Q:'SDREV!($D(SDPAR(SDS1,SDS2,4)))!'$D(SDPAR(SDS1,SDS2))

 W !!,$C(7),"Required ",$S($P(SDPAR(SDS1,SDS2,2),U)="L":"list",1:"range")," data missing.",!,$P(SDPAR(SDS1,SDS2),U,2),": ",$P(SDPAR(SDS1,SDS2,1),U,2)," element deleted!" H 3

 K SDPAR(SDS1,SDS2) Q

 ;

CATQ W !!,"Required data missing!  "_$S(SDS1="P":"Perspective ",1:"Limitation item ")_$S(SDA="E":"changes ",1:"")_"not filed.",! H 2 S (SDOUT,SDNUL)=0 Q

 ;

RL() ;List or range?

 ;Output: selector type

 K DIR D DIRB("X",SDS2,2)

 S DIR("A")="Limit this factor by",DIR("?")="Specify if a list or a range of items should be used to limit this element.",DIR(0)="S^"_$S(SDLR["L":"L:LIST;",1:"")_$S(SDLR["R":"R:RANGE;",1:"")_"N:NULL (NO DATA VALUE)"

 Q $$DIR^SCRPW23(.DIR,0)

 ;

PRMT(SDS1,SDS2) ;Prompts for level DIR2

 ;Required input: SDS1,SDS2=subscript to find responses

 K DIR(0) D DIRB("X",SDS2,1) S DIR("A")="Select "_$P(SDPAR(SDS1,SDS2),U,2)_" category" Q

 ;

DIRB(SDS1,SDS2,SDS3) ;Get default value

 ;Required input: SDS1,SDS2,SDS3=subscript value

 S DIR("B")=$P($G(SDPAR(SDS1,SDS2,SDS3)),U,2) K:'$L(DIR("B")) DIR("B") Q

 ;

AED(SDS1) ;Add/edit/delete element categories

 ;Required input: SDS1=global subscript to work with

 N SDOUT S SDOUT=0 F  Q:SDOUT!SDNUL  D AED1

 Q

 ;

AED1 I '$O(SDPAR(SDS1,2)) D A Q

 W !!?28,$$XY(IORVON)," Limitation item action ",$$XY(IORVOFF) K DIR S DIR(0)="SO^A:ADD CATEGORY ITEMS;E:EDIT CATEGORY ITEMS;D:DELETE CATEGORY ITEMS",DIR("A")="Select edit action"

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

 D @Y Q

 ;

A ;Add items

 D L2A^SCRPW20 Q

 ;

E ;Edit items

 S SDX=$$ILIST("E") Q:'SDX!SDOUT  S SDS2=+SDX D CAT("E") Q

 ;

D ;Delete items

 S SDX=$$ILIST("D") Q:'SDX!SDOUT  D DEL1 Q

 ;

DEL1 N DIR S DIR(0)="Y",DIR("A")="Ok to delete "_$P(SDX,U,2)_" item",DIR("B")="YES" D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q

 Q:'Y  K SDPAR(SDS1,$P(SDX,U)) Q

 ;

ILIST(SDY) ;List/select items

 ;Required input: SDY="E" for edit, "D" for delete

 N SDI,SDX,SDOUT,SDS2 S (SDI,SDOUT)=0,SDS2=2,SDX=""

 W ! F  S SDS2=$O(SDPAR(SDS1,SDS2)) Q:'SDS2!SDOUT  S SDI=SDI+1 D ISET W !,SDI,". ",$P(SDI(SDI),U,2) D:'SDI#5 IL1

 D:'SDOUT&SDI#5 IL1 Q SDX

 ;

ISET S SDI(SDI)=SDS2_U_$P(SDPAR(SDS1,SDS2),U,2)_": "_$P(SDPAR(SDS1,SDS2,1),U,2)_" ("_$P(SDPAR(SDS1,SDS2,2),U,2)_")" Q

 ;

IL1 W ! N DIR S DIR(0)="NO^1:"_SDI_":0",DIR("A")="Select item to "_$S(SDY="E":"edit",1:"delete") D ^DIR W ! I $D(DTOUT)!$D(DUOUT)!$G(Y) S SDOUT=1

 S SDX=$G(SDI(+$G(Y))) Q

 ;

DESC ;Prompt for descriptive report title

 K DIR D DIRB1^SCRPW23("O",2)

 S DIR(0)="FO^1:80",DIR("A")="Report descriptive title (optional)",DIR("?")="Enter brief text describing the report (displayed at top of each page printed)."

 W ! S SDX=$$DIR^SCRPW23(.DIR,0) I SDX=""!(SDX=U) K SDPAR("O",2) Q

 S:$L(SDX) SDPAR("O",2)=SDX Q

 ;

REST() ;Select/restore template for editing

 ;Ouput: 1=template restored, 0=template not restored

 Q:'$O(^SDD(409.91,0)) 0

 W ! K DIR S DIR(0)="YO",DIR("A")="Would you like to use parameters from an existing template" D ^DIR I $D(DUOUT)!$D(DTOUT) S SDOUT=1 Q 0

 Q:'Y 0  W ! K SDPAR Q $$SELT^SCRPW21(.SDPAR)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---SCRPW22   8326     printed  Feb 19, 2025@00:09:52                                                                                                                                                                                                     Page 2

SCRPW22   ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ;03 Aug 98  9:36 PM

 +1       ;;5.3;Scheduling;**144,593**;AUG 13, 1993;Build 13

PLIST(C,SDLP,SDTEMP) ;Display parameter list

 +1       ;Required input: C=column to format left margin

 +2       ;Required input: SDLP=number of lines to print on a page

 +3       ;Optional input: SDTEMP=array of template information to print

 +4        NEW SDI,SDII,SDS1,SDS2,SDX,SDX1,SDX2,SDL

           SET (SDOUT,SDL)=0

 +5        DO PHD(" R E P O R T   F O R M A T ")

           if SDOUT

               QUIT 

           DO D1("F","")

           if SDOUT

               QUIT 

 +6        DO PHD(" R E P O R T   P E R S P E C T I V E ")

           if SDOUT

               QUIT 

           DO D2("Perspective","P",1)

           if SDOUT

               QUIT 

 +7        DO PHD(" R E P O R T   L I M I T A T I O N S ")

           if SDOUT

               QUIT 

           DO D1("L",2)

           if SDOUT

               QUIT 

 +8        SET SDS1="L"

           SET SDS2=2

           FOR 

               SET SDS2=$ORDER(SDPAR(SDS1,SDS2))

               if 'SDS2!SDOUT

                   QUIT 

               if SDL>SDLP

                   DO WAIT

               if SDOUT

                   QUIT 

               WRITE !

               SET SDL=SDL+1

               DO D2("Addl. limitation",SDS1,SDS2)

 +9        if SDOUT

               QUIT 

           DO PHD(" R E P O R T   P R I N T   O R D E R ")

           if SDOUT

               QUIT 

           DO D1("O","")

 +10       IF $DATA(SDPAR("PF"))

               DO PHD(" A D D I T I O N A L   P R I N T   F I E L D S ")

               if SDOUT

                   QUIT 

 +11       FOR SDS2=2,1

               SET SDS3=0

               FOR 

                   SET SDS3=$ORDER(SDPAR("PF",SDS2,SDS3))

                   if 'SDS3

                       QUIT 

                   SET SDX=SDPAR("PF",SDS2,SDS3)

                   if SDL>SDLP

                       DO WAIT

                   if SDOUT

                       QUIT 

                   WRITE !?(C+36-$LENGTH($PIECE(SDX,U,2))),$PIECE(SDX,U,2),": ",$EXTRACT($PIECE(SDX,U,3),1,(42+C))

                   SET SDL=SDL+1

 +12       if SDOUT

               QUIT 

           if SDL>SDLP

               DO WAIT

           if SDOUT

               QUIT 

           if $DATA(SDTEMP)>1

               DO PHD(" T E M P L A T E   I N F O R M A T I O N ")

               DO PTMP

           if SDOUT

               QUIT 

 +13       if SDL>SDLP

               DO WAIT

           if SDOUT

               QUIT 

           WRITE !

           SET SDL=SDL+1

           if SDL>SDLP

               DO WAIT

           if SDOUT

               QUIT 

           WRITE !

           SET SDL=SDL+1

           FOR SDI=1:1:IOM

               WRITE "-"

 +14       IF $EXTRACT(IOST)="C"

               DO WAIT

 +15       QUIT 

 +16      ;

PTMP       NEW SDI

           SET SDI=0

           FOR 

               SET SDI=$ORDER(SDTEMP(SDI))

               if 'SDI!SDOUT

                   QUIT 

               SET SDX=$PIECE(SDTEMP(SDI),U)

               SET SDX1=$PIECE(SDTEMP(SDI),U,2)

               DO D2P

 +1        QUIT 

 +2       ;

D1(SDI,SDE)  SET SDII=""

           FOR 

               SET SDII=$ORDER(SDPAR(SDI,SDII))

               if SDII=""!(SDE&(SDII>SDE))

                   QUIT 

               SET SDX=$PIECE($TEXT(@SDI+SDII),";;",2)

               if SDL>SDLP

                   DO WAIT

               if SDOUT

                   QUIT 

               WRITE !?(C+36-$LENGTH(SDX)),SDX,": ",$EXTRACT($PIECE(SDPAR(SDI,SDII),U,2),1,(42+C))

               SET SDL=SDL+1

 +1        QUIT 

 +2       ;

D2(SDTX,SDS1,SDS2)  NEW DIWL,DIWF,SDL2

           SET DIWL=1

           SET DIWF="C"_(42+C)_"|"

 +1        if '$DATA(SDPAR(SDS1,SDS2))

               QUIT 

           SET SDX=SDTX_" category"

           SET SDX1=$PIECE(SDPAR(SDS1,SDS2),U,2)

           DO D2P

           if SDOUT

               QUIT 

 +2        if '$DATA(SDPAR(SDS1,SDS2,1))

               QUIT 

           SET SDX=SDTX_" sub-category"

           SET SDX1=$PIECE(SDPAR(SDS1,SDS2,1),U,2)

           DO D2P

           if SDOUT

               QUIT 

 +3        if '$DATA(SDPAR(SDS1,SDS2,2))

               QUIT 

           SET SDX2=$PIECE(SDPAR(SDS1,SDS2,2),U)

           if SDL>SDLP

               DO WAIT

           if SDOUT

               QUIT 

           SET SDX1=$ORDER(SDPAR(SDS1,SDS2,4,""))

           if SDX1=""

               QUIT 

 +4        SET SDX=$SELECT(SDS1="P":"Detail",$PIECE(SDPAR(SDS1,SDS2,3),U)="I":"Include",1:"Exclude")_" "_$SELECT("LN"[SDX2:"list",1:"range - from")

           DO D2P

           if SDOUT

               QUIT 

 +5        IF SDX2="R"

               SET SDX="to"

               SET SDX1=$ORDER(SDPAR(SDS1,SDS2,4,SDX1))

               if SDX1=""

                   QUIT 

               DO D2P

               QUIT 

 +6        FOR 

               SET SDX1=$ORDER(SDPAR(SDS1,SDS2,4,SDX1))

               if SDX1=""!SDOUT

                   QUIT 

               if SDL>SDLP

                   DO WAIT

               if SDOUT

                   QUIT 

               Begin DoDot:1

 +7                KILL ^UTILITY($JOB,"W")

                   SET X=SDX1

                   DO ^DIWP

 +8                FOR SDL2=1:1:^UTILITY($JOB,"W",DIWL)

                       Begin DoDot:2

 +9                        WRITE !?(38+C),$EXTRACT(^UTILITY($JOB,"W",DIWL,SDL2,0),1,(42+C))

                       End DoDot:2

                       SET SDL=SDL+1

                       if SDL>SDLP

                           DO WAIT

                       if SDOUT

                           QUIT 

               End DoDot:1

 +10       QUIT 

 +11      ;

D2P        NEW DIWL,DIWF,SDL2

           SET DIWL=1

           SET DIWF="C"_(42+C)_"|"

 +1        if SDL>SDLP

               DO WAIT

           if SDOUT

               QUIT 

 +2        KILL ^UTILITY($JOB,"W")

           SET X=SDX1

           DO ^DIWP

 +3        FOR SDL2=1:1:^UTILITY($JOB,"W",DIWL)

               Begin DoDot:1

 +4                IF SDL2=1

                       WRITE !?(C+36-$LENGTH(SDX)),SDX,": ",$EXTRACT(^UTILITY($JOB,"W",DIWL,SDL2,0),1,(42+C))

                       IF 1

 +5               IF '$TEST

                       WRITE !?(38+C),$EXTRACT(^UTILITY($JOB,"W",DIWL,SDL2,0),1,(42+C))

               End DoDot:1

               SET SDL=SDL+1

               if SDL>SDLP

                   DO WAIT

               if SDOUT

                   QUIT 

 +6        QUIT 

 +7       ;

F         ;Format captions

 +1       ;;Report output format

 +2       ;;Compare data to previous year

 +3       ;;Type of detail

 +4       ;;List activity detail by

 +5       ;;Limit Dx/Proc. list to most frequent

 +6       ;;Produce output as

L         ;Limitation captions

 +1       ;;Starting date

 +2       ;;Ending date

O         ;Order caption

 +1       ;;Output order

 +2       ;;Report descriptive title

 +3       ;

XY(X)     ;Maintain $X, $Y

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

 +2        if '$DATA(SDXY)

               SET SDXY=^%ZOSF("XY")

           NEW DX,DY

           SET DX=$X

           SET DY=$Y

           WRITE X

           XECUTE SDXY

           QUIT ""

 +3       ;

PHD(SDH)  ;Parameter header

 +1       ;Required input: SDH=header value

 +2        WRITE !

           SET SDL=SDL+1

           if (SDL+1)>SDLP

               DO WAIT

           if SDOUT

               QUIT 

 +3        WRITE !

           SET SDL=SDL+1

 +4        FOR 

               WRITE "-"

               if $X>(IOM-3-$LENGTH(SDH)\2)

                   QUIT 

 +5        WRITE " ",SDH," "

           FOR 

               WRITE "-"

               if $X>(IOM-1)

                   QUIT 

 +6        WRITE !

           SET SDL=SDL+1

           if SDL>SDLP

               DO WAIT

           QUIT 

 +7       ;

WAIT       IF $EXTRACT(IOST)="C"

               NEW DIR

               SET DIR(0)="E"

               DO ^DIR

               if 'Y

                   SET SDOUT=1

               if 'SDOUT

                   WRITE $$XY(IOELALL),$$XY(IOCUU)

               SET SDL=0

               QUIT 

 +1        DO HDR^SCRPW29("Report Parameters Selected")

           SET SDL=0

           QUIT 

 +2       ;

CAT(SDA)  ;Enter edit perspective and limitation categories

 +1       ;Required entry: SDA="A" for add or "E" for edit

 +2        KILL SDPAR("X")

           if SDA="E"

               MERGE SDPAR("X")=SDPAR(SDS1)

           IF SDS1="L"

               IF SDA="E"

                   SET SDSEL=$PIECE(SDPAR(SDS1,SDS2),U)_$PIECE(SDPAR(SDS1,SDS2,1),U)

                   GOTO CAT1

 +3        SET (SDSEL,SDX)=$$DIR^SCRPW23(.DIR,1,"","","O")

           if SDOUT!SDNUL

               QUIT 

 +4        IF SDA="E"

               IF SDX'=SDPAR(SDS1,SDS2)

                   KILL SDPAR("X",SDS2)

 +5        SET SDPAR("X",SDS2)=SDX

 +6        KILL SDEXE

           DO PRMT("X",SDS2)

           SET SDX=$$DIR^SCRPW23(.DIR,2,$GET(SDEXE),$PIECE(SDPAR("X",SDS2),U))

           if SDOUT!SDNUL

               GOTO CATQ

 +7        IF SDA="E"

               IF SDX'=$GET(SDPAR("X",SDS2,1))

                   Begin DoDot:1

 +8                    FOR SDI=1:1:6

                           KILL SDPAR("X",SDS2,SDI)

 +9                    FOR SDI=4,5,6

                           KILL SDPAR(SDS1,SDS2,SDI)

 +10                   QUIT 

                   End DoDot:1

 +11       SET SDPAR("X",SDS2,1)=SDX

           SET SDSEL=$PIECE(SDSEL,U)_$PIECE(SDX,U)

 +12       IF SDS1="P"

               IF $PIECE(SDPAR("F",1),U)="S"

                   MERGE SDPAR(SDS1)=SDPAR("X")

                   QUIT 

CAT1       SET SDACT=^TMP("SCRPW",$JOB,"ACT",SDSEL)

 +1        IF SDS1="P"

               SET SDLR="L"

               SET SDX=$$RL()

               if SDOUT

                   GOTO CATQ

               SET SDPAR("X",SDS2,2)=SDX

               DO RL^SCRPW23

               SET (SDOUT,SDNUL)=0

               if $DATA(SDPAR("X",SDS2,4))

                   MERGE SDPAR(SDS1)=SDPAR("X")

               if '$DATA(SDPAR("X",SDS2,4))

                   GOTO CATQ

               DO CATD

               QUIT 

 +2        SET SDLR=$PIECE(SDACT,T,5)

           SET SDX=$$RL()

           if SDOUT

               GOTO CATQ

           IF SDA="E"

               IF SDX'=SDPAR("X",SDS2,2)

                   FOR SDI=4,5

                       KILL SDPAR("X",SDS2,SDI)

 +3        SET SDPAR("X",SDS2,2)=SDX

           DO RL^SCRPW23

           DO CATD

           SET (SDOUT,SDNUL)=0

           if '$DATA(SDPAR("X",SDS2,4))

               GOTO CATQ

 +4        KILL DIR

           DO DIRB("X",SDS2,3)

           SET DIR(0)="S^I:INCLUDE;E:EXCLUDE"

           SET DIR("A")="Include or exclude records in this category"

           DO ^DIR

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

               SET SDOUT=1

               GOTO CATQ

 +5        SET SDPAR("X",SDS2,3)=Y_U_Y(0)

           MERGE SDPAR(SDS1)=SDPAR("X")

           QUIT 

 +6       ;

CATD       if 'SDREV!($DATA(SDPAR(SDS1,SDS2,4)))!'$DATA(SDPAR(SDS1,SDS2))

               QUIT 

 +1        WRITE !!,$CHAR(7),"Required ",$SELECT($PIECE(SDPAR(SDS1,SDS2,2),U)="L":"list",1:"range")," data missing.",!,$PIECE(SDPAR(SDS1,SDS2),U,2),": ",$PIECE(SDPAR(SDS1,SDS2,1),U,2)," element deleted!"

           HANG 3

 +2        KILL SDPAR(SDS1,SDS2)

           QUIT 

 +3       ;

CATQ       WRITE !!,"Required data missing!  "_$SELECT(SDS1="P":"Perspective ",1:"Limitation item ")_$SELECT(SDA="E":"changes ",1:"")_"not filed.",!

           HANG 2

           SET (SDOUT,SDNUL)=0

           QUIT 

 +1       ;

RL()      ;List or range?

 +1       ;Output: selector type

 +2        KILL DIR

           DO DIRB("X",SDS2,2)

 +3        SET DIR("A")="Limit this factor by"

           SET DIR("?")="Specify if a list or a range of items should be used to limit this element."

           SET DIR(0)="S^"_$SELECT(SDLR["L":"L:LIST;",1:"")_$SELECT(SDLR["R":"R:RANGE;",1:"")_"N:NULL (NO DATA VALUE)"

 +4        QUIT $$DIR^SCRPW23(.DIR,0)

 +5       ;

PRMT(SDS1,SDS2) ;Prompts for level DIR2

 +1       ;Required input: SDS1,SDS2=subscript to find responses

 +2        KILL DIR(0)

           DO DIRB("X",SDS2,1)

           SET DIR("A")="Select "_$PIECE(SDPAR(SDS1,SDS2),U,2)_" category"

           QUIT 

 +3       ;

DIRB(SDS1,SDS2,SDS3) ;Get default value

 +1       ;Required input: SDS1,SDS2,SDS3=subscript value

 +2        SET DIR("B")=$PIECE($GET(SDPAR(SDS1,SDS2,SDS3)),U,2)

           if '$LENGTH(DIR("B"))

               KILL DIR("B")

           QUIT 

 +3       ;

AED(SDS1) ;Add/edit/delete element categories

 +1       ;Required input: SDS1=global subscript to work with

 +2        NEW SDOUT

           SET SDOUT=0

           FOR 

               if SDOUT!SDNUL

                   QUIT 

               DO AED1

 +3        QUIT 

 +4       ;

AED1       IF '$ORDER(SDPAR(SDS1,2))

               DO A

               QUIT 

 +1        WRITE !!?28,$$XY(IORVON)," Limitation item action ",$$XY(IORVOFF)

           KILL DIR

           SET DIR(0)="SO^A:ADD CATEGORY ITEMS;E:EDIT CATEGORY ITEMS;D:DELETE CATEGORY ITEMS"

           SET DIR("A")="Select edit action"

 +2        DO ^DIR

           IF $DATA(DTOUT)!$DATA(DUOUT)!($GET(X)="")

               SET SDOUT=1

               QUIT 

 +3        DO @Y

           QUIT 

 +4       ;

A         ;Add items

 +1        DO L2A^SCRPW20

           QUIT 

 +2       ;

E         ;Edit items

 +1        SET SDX=$$ILIST("E")

           if 'SDX!SDOUT

               QUIT 

           SET SDS2=+SDX

           DO CAT("E")

           QUIT 

 +2       ;

D         ;Delete items

 +1        SET SDX=$$ILIST("D")

           if 'SDX!SDOUT

               QUIT 

           DO DEL1

           QUIT 

 +2       ;

DEL1       NEW DIR

           SET DIR(0)="Y"

           SET DIR("A")="Ok to delete "_$PIECE(SDX,U,2)_" item"

           SET DIR("B")="YES"

           DO ^DIR

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

               SET SDOUT=1

               QUIT 

 +1        if 'Y

               QUIT 

           KILL SDPAR(SDS1,$PIECE(SDX,U))

           QUIT 

 +2       ;

ILIST(SDY) ;List/select items

 +1       ;Required input: SDY="E" for edit, "D" for delete

 +2        NEW SDI,SDX,SDOUT,SDS2

           SET (SDI,SDOUT)=0

           SET SDS2=2

           SET SDX=""

 +3        WRITE !

           FOR 

               SET SDS2=$ORDER(SDPAR(SDS1,SDS2))

               if 'SDS2!SDOUT

                   QUIT 

               SET SDI=SDI+1

               DO ISET

               WRITE !,SDI,". ",$PIECE(SDI(SDI),U,2)

               if 'SDI#5

                   DO IL1

 +4        if 'SDOUT&SDI#5

               DO IL1

           QUIT SDX

 +5       ;

ISET       SET SDI(SDI)=SDS2_U_$PIECE(SDPAR(SDS1,SDS2),U,2)_": "_$PIECE(SDPAR(SDS1,SDS2,1),U,2)_" ("_$PIECE(SDPAR(SDS1,SDS2,2),U,2)_")"

           QUIT 

 +1       ;

IL1        WRITE !

           NEW DIR

           SET DIR(0)="NO^1:"_SDI_":0"

           SET DIR("A")="Select item to "_$SELECT(SDY="E":"edit",1:"delete")

           DO ^DIR

           WRITE !

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

               SET SDOUT=1

 +1        SET SDX=$GET(SDI(+$GET(Y)))