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 ---[H[J[2J[HSCRPW22 8326 printed Dec 13, 2024@02:43:25 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)))
QUIT
+2 ;
DESC ;Prompt for descriptive report title
+1 KILL DIR
DO DIRB1^SCRPW23("O",2)
+2 SET DIR(0)="FO^1:80"
SET DIR("A")="Report descriptive title (optional)"
SET DIR("?")="Enter brief text describing the report (displayed at top of each page printed)."
+3 WRITE !
SET SDX=$$DIR^SCRPW23(.DIR,0)
IF SDX=""!(SDX=U)
KILL SDPAR("O",2)
QUIT
+4 if $LENGTH(SDX)
SET SDPAR("O",2)=SDX
QUIT
+5 ;
REST() ;Select/restore template for editing
+1 ;Ouput: 1=template restored, 0=template not restored
+2 if '$ORDER(^SDD(409.91,0))
QUIT 0
+3 WRITE !
KILL DIR
SET DIR(0)="YO"
SET DIR("A")="Would you like to use parameters from an existing template"
DO ^DIR
IF $DATA(DUOUT)!$DATA(DTOUT)
SET SDOUT=1
QUIT 0
+4 if 'Y
QUIT 0
WRITE !
KILL SDPAR
QUIT $$SELT^SCRPW21(.SDPAR)
