- 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 Feb 19, 2025@00:28:13 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