SDUL ;MJK/ALB - List Manager; 12/1/91
;;5.3;Scheduling;;Aug 13, 1993
;
EN(NAME,PARMS) ; -- main entry point
; input: NAME := free text name of list template or routine call
; PARMS := parameter list
;
D INIT^SDUL0(.NAME,$G(PARMS)) G ENQ:$D(SDULQUIT)
D BLD G ENQ:$D(SDULQUIT)
D REFRESH,ASK
X:$G(^TMP("SDUL DATA",$J,SDULEVL,"FNL"))]"" ^("FNL")
ENQ D POP^SDUL0
Q
;
BLD ; -- build list of items
I $G(^TMP("SDUL DATA",$J,SDULEVL,"INIT"))]"" X ^("INIT") G BLDQ:$D(SDULQUIT)
S:'$D(SDULBG) SDULBG=1
S SDULPGE=$$PAGE^SDUL4(SDULBG,SDUL("LINES"))
BLDQ Q
;
LIST ; -- list items
S:'$D(SDULBG) SDULBG=1
S SDULST=0,SDULPGE=$$PAGE^SDUL4(SDULBG,SDUL("LINES"))
I $E(IOST,1,2)="C-" W ! S DX=0,DY=SDUL("TM")-2 X IOXY,^%ZOSF("XY")
S I=SDULBG F LN=1:1:SDUL("LINES") S X=$G(@SDULAR@($$GET^SDUL4(I),0)) S SDULST=I W !,X S I=I+1
S:SDULST>SDULCNT SDULST=SDULCNT
K X S $P(X,$S(SDULCC:" ",1:"-"),SDULWD+1)=""
S SDULDN=(SDULST<SDULCNT) S:SDULDN X="+"_$E(X,2,SDULWD+1)
S:SDULCC X=IOUON_$C(13)_X_$C(13)_IOUOFF
W !,X W:$E(IOST,1,2)="C-" !
Q
;
ASK ; -- prompt user
I SDULCC D RESET^SDUL4
S X=SDUL("PROTOCOL"),XQORM(0)=SDUL("MAX")_"A\"
S:$G(^TMP("SDUL DATA",$J,SDULEVL,"HLP"))]"" XQORM("??")=^("HLP")
K SDULBCK,DTOUT,DIROUT,DUOUT
D EN^XQOR
I $D(SDULBCK),SDULBCK'="Q" D REFRESH:SDULBCK="R" G ASK
ASKQ K XQORM,DTOUT,DIROUT,DUOUT Q
;
COL ;
K SDULDDF
S I=0 F S I=$O(^SD(409.61,SDUL("IFN"),"COL",I)) Q:'I I $D(^(I,0)) S SDULDDF($P(^(0),U))=^(0)
Q
;
CAPTION() ; -- set up caption line of header
N X,COL,FLD
S $P(X,$S(SDULCC:" ",1:"-"),SDULWD+1)=""
S COL="" F S COL=$O(SDULDDF(COL)) Q:COL="" S FLD=SDULDDF(COL) D
.S X=$$SETSTR^SDUL1($P(FLD,U,4),X,+$P(FLD,U,2),$S($L($P(FLD,U,4))<$P(FLD,U,3):$L($P(FLD,U,4)),1:+$P(FLD,U,3)))
Q X
;
CHGCAP(FLD,LABEL) ; -- change label on caption
; input: FLD := name of field
; LABEL := text for column header
S $P(SDULDDF(FLD),U,4)=LABEL,SDULCAP=$$CAPTION
Q
;
HDR ; -- prt/display header
N X,I
I '$D(SDULHDR) X:$G(SDUL("HDR"))]"" SDUL("HDR")
; -- prt hdr line
W @IOF
W:SDULCC IOUON,IOINHI
I $E(IOST,1,2)="C-" S DX=0,DY=0 X IOXY
W $E(SDUL("TITLE"),1,30)
W:SDULCC IOINORM,IOUON
W $J("",30-$L(SDUL("TITLE")))
I $E(IOST,1,2)="C-" W $C(13) S DX=30,DY=0 X IOXY
W $$LOWER^SDUL1($$NOW^SDUL1)," Page: ",$J(SDULPGE,3)," of ",$J($$PAGE^SDUL4(SDULCNT,SDUL("LINES")),3)
W:SDULCC IOUOFF,$C(13)
;
F I=1:1:SDUL("TM")-3 W !,$G(SDULHDR(I))
S SDULUP=(SDULBG>1) S SDULCAP=$S(SDULUP:"+",'SDULCC:"-",1:" ")_$E(SDULCAP,2,SDULWD)
I SDUL("TM")>2 D
.W:SDULCC !,IOUON,$C(13),SDULCAP,$C(13),IOUOFF
.W:'SDULCC !,SDULCAP
Q
;
REFRESH ;
S SDULPGE=$$PAGE^SDUL4(SDULBG,SDUL("LINES")) D HDR
S SDULBCK="" D LIST
Q
;
SHOW ; -- show items to user
S DX=0,DY=SDUL("BM")-SDULMENU X IOXY
I SDULMENU D
.S X="?" D DISP^XQORM1
Q
;
WP1(SDULREF) ; -- quick setup
S SDULCNT=+$P(@SDULREF@(0),U,4)
S SDUL("ARRAY")=SDULREF
S:$D(SDULWPTL) SDUL("TITLE")=SDULWPTL
Q
;
WP(SDULREF,SDULWPTL) ; -- quick entry to List Manager (c)
D EN("WP1^SDUL(SDULREF)")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDUL 3111 printed Apr 09, 2024@21:51 Page 2
SDUL ;MJK/ALB - List Manager; 12/1/91
+1 ;;5.3;Scheduling;;Aug 13, 1993
+2 ;
EN(NAME,PARMS) ; -- main entry point
+1 ; input: NAME := free text name of list template or routine call
+2 ; PARMS := parameter list
+3 ;
+4 DO INIT^SDUL0(.NAME,$GET(PARMS))
if $DATA(SDULQUIT)
GOTO ENQ
+5 DO BLD
if $DATA(SDULQUIT)
GOTO ENQ
+6 DO REFRESH
DO ASK
+7 if $GET(^TMP("SDUL DATA",$JOB,SDULEVL,"FNL"))]""
XECUTE ^("FNL")
ENQ DO POP^SDUL0
+1 QUIT
+2 ;
BLD ; -- build list of items
+1 IF $GET(^TMP("SDUL DATA",$JOB,SDULEVL,"INIT"))]""
XECUTE ^("INIT")
if $DATA(SDULQUIT)
GOTO BLDQ
+2 if '$DATA(SDULBG)
SET SDULBG=1
+3 SET SDULPGE=$$PAGE^SDUL4(SDULBG,SDUL("LINES"))
BLDQ QUIT
+1 ;
LIST ; -- list items
+1 if '$DATA(SDULBG)
SET SDULBG=1
+2 SET SDULST=0
SET SDULPGE=$$PAGE^SDUL4(SDULBG,SDUL("LINES"))
+3 IF $EXTRACT(IOST,1,2)="C-"
WRITE !
SET DX=0
SET DY=SDUL("TM")-2
XECUTE IOXY
XECUTE ^%ZOSF("XY")
+4 SET I=SDULBG
FOR LN=1:1:SDUL("LINES")
SET X=$GET(@SDULAR@($$GET^SDUL4(I),0))
SET SDULST=I
WRITE !,X
SET I=I+1
+5 if SDULST>SDULCNT
SET SDULST=SDULCNT
+6 KILL X
SET $PIECE(X,$SELECT(SDULCC:" ",1:"-"),SDULWD+1)=""
+7 SET SDULDN=(SDULST<SDULCNT)
if SDULDN
SET X="+"_$EXTRACT(X,2,SDULWD+1)
+8 if SDULCC
SET X=IOUON_$CHAR(13)_X_$CHAR(13)_IOUOFF
+9 WRITE !,X
if $EXTRACT(IOST,1,2)="C-"
WRITE !
+10 QUIT
+11 ;
ASK ; -- prompt user
+1 IF SDULCC
DO RESET^SDUL4
+2 SET X=SDUL("PROTOCOL")
SET XQORM(0)=SDUL("MAX")_"A\"
+3 if $GET(^TMP("SDUL DATA",$JOB,SDULEVL,"HLP"))]""
SET XQORM("??")=^("HLP")
+4 KILL SDULBCK,DTOUT,DIROUT,DUOUT
+5 DO EN^XQOR
+6 IF $DATA(SDULBCK)
IF SDULBCK'="Q"
if SDULBCK="R"
DO REFRESH
GOTO ASK
ASKQ KILL XQORM,DTOUT,DIROUT,DUOUT
QUIT
+1 ;
COL ;
+1 KILL SDULDDF
+2 SET I=0
FOR
SET I=$ORDER(^SD(409.61,SDUL("IFN"),"COL",I))
if 'I
QUIT
IF $DATA(^(I,0))
SET SDULDDF($PIECE(^(0),U))=^(0)
+3 QUIT
+4 ;
CAPTION() ; -- set up caption line of header
+1 NEW X,COL,FLD
+2 SET $PIECE(X,$SELECT(SDULCC:" ",1:"-"),SDULWD+1)=""
+3 SET COL=""
FOR
SET COL=$ORDER(SDULDDF(COL))
if COL=""
QUIT
SET FLD=SDULDDF(COL)
Begin DoDot:1
+4 SET X=$$SETSTR^SDUL1($PIECE(FLD,U,4),X,+$PIECE(FLD,U,2),$SELECT($LENGTH($PIECE(FLD,U,4))<$PIECE(FLD,U,3):$LENGTH($PIECE(FLD,U,4)),1:+$PIECE(FLD,U,3)))
End DoDot:1
+5 QUIT X
+6 ;
CHGCAP(FLD,LABEL) ; -- change label on caption
+1 ; input: FLD := name of field
+2 ; LABEL := text for column header
+3 SET $PIECE(SDULDDF(FLD),U,4)=LABEL
SET SDULCAP=$$CAPTION
+4 QUIT
+5 ;
HDR ; -- prt/display header
+1 NEW X,I
+2 IF '$DATA(SDULHDR)
if $GET(SDUL("HDR"))]""
XECUTE SDUL("HDR")
+3 ; -- prt hdr line
+4 WRITE @IOF
+5 if SDULCC
WRITE IOUON,IOINHI
+6 IF $EXTRACT(IOST,1,2)="C-"
SET DX=0
SET DY=0
XECUTE IOXY
+7 WRITE $EXTRACT(SDUL("TITLE"),1,30)
+8 if SDULCC
WRITE IOINORM,IOUON
+9 WRITE $JUSTIFY("",30-$LENGTH(SDUL("TITLE")))
+10 IF $EXTRACT(IOST,1,2)="C-"
WRITE $CHAR(13)
SET DX=30
SET DY=0
XECUTE IOXY
+11 WRITE $$LOWER^SDUL1($$NOW^SDUL1)," Page: ",$JUSTIFY(SDULPGE,3)," of ",$JUSTIFY($$PAGE^SDUL4(SDULCNT,SDUL("LINES")),3)
+12 if SDULCC
WRITE IOUOFF,$CHAR(13)
+13 ;
+14 FOR I=1:1:SDUL("TM")-3
WRITE !,$GET(SDULHDR(I))
+15 SET SDULUP=(SDULBG>1)
SET SDULCAP=$SELECT(SDULUP:"+",'SDULCC:"-",1:" ")_$EXTRACT(SDULCAP,2,SDULWD)
+16 IF SDUL("TM")>2
Begin DoDot:1
+17 if SDULCC
WRITE !,IOUON,$CHAR(13),SDULCAP,$CHAR(13),IOUOFF
+18 if 'SDULCC
WRITE !,SDULCAP
End DoDot:1
+19 QUIT
+20 ;
REFRESH ;
+1 SET SDULPGE=$$PAGE^SDUL4(SDULBG,SDUL("LINES"))
DO HDR
+2 SET SDULBCK=""
DO LIST
+3 QUIT
+4 ;
SHOW ; -- show items to user
+1 SET DX=0
SET DY=SDUL("BM")-SDULMENU
XECUTE IOXY
+2 IF SDULMENU
Begin DoDot:1
+3 SET X="?"
DO DISP^XQORM1
End DoDot:1
+4 QUIT
+5 ;
WP1(SDULREF) ; -- quick setup
+1 SET SDULCNT=+$PIECE(@SDULREF@(0),U,4)
+2 SET SDUL("ARRAY")=SDULREF
+3 if $DATA(SDULWPTL)
SET SDUL("TITLE")=SDULWPTL
+4 QUIT
+5 ;
WP(SDULREF,SDULWPTL) ; -- quick entry to List Manager (c)
+1 DO EN("WP1^SDUL(SDULREF)")
+2 QUIT
