SDUL1 ;ALB/MJK - Screen Malipulation Utilities ; 12/1/91
;;5.3;Scheduling;**140**;Aug 13, 1993
;
INSTR(STR,X,Y,LENGTH,ERASE) ; -- insert text
; STR := string to insert
; X := X coordinate
; Y := Y coordinate
; LENGTH := clear # of characters
; ERASE := erase chars first
;
W IOSC
I $G(ERASE) S DY=Y-1,DX=X-1 X IOXY W $J("",LENGTH)
S DY=Y-1,DX=X-1 X IOXY W STR
W IORC
Q
;
FLDUPD(STR,FLD,ENTRY) ; -- update entry and field on screen
; STR := string to insert
; FLD := col name
; ENTRY := entry # in list
;
D INSTR(.STR,+$P(SDULDDF(FLD),U,2),ENTRY-SDULBG+SDUL("TM"),$P(SDULDDF(FLD),U,3),1)
Q
;
SETFLD(STR,VAR,FLD) ; -- set field in var
; input: STR := string to insert
; VAR := destination string
; FLD := col name
Q $$SETSTR^SDUL1(STR,VAR,+$P(SDULDDF(FLD),U,2),+$P(SDULDDF(FLD),U,3))
;
SETSTR(S,V,X,L) ; -- insert text(S) into variable(V)
; S := string to insert
; V := destination string
; X := insert @ col X
; L := clear # of chars (length)
;
Q $E(V_$J("",X-1),1,X-1)_$E(S_$J("",L),1,L)_$E(V,X+L,999)
;
FULL ; set full scrolling region
I '$D(IOSTBM) D TERM^SDUL0
I IOSTBM]"" S IOTM=1,IOBM=IOSL W IOSC W @IOSTBM W IORC
Q
;
CLEAR ; -- clear screen
D FULL,ERASE W @IOF
Q
;
ERASE ;
F X="IOUOFF","IOINORM" W $G(@X)
Q
;
FDATE(Y) ; -- return formatted date
; input: Y := field name
; output: [returned] := formatted date only
Q $TR($$FMTE^XLFDT(Y,"5DF")," ","0")
;
FTIME(Y) ; -- return formatted date/time
; input: Y := internal date/time
; output: [returned] := formatted date and time
D DD^%DT
Q Y
;
FDTTM(Y) ; -- return formatted date/time
; input: Y := internal date/time
; output: [returned] := formatted date and time
N SDY
S SDY=$TR($$FMTE^XLFDT(Y,"5DF")," ","0")
D DD^%DT
Q SDY_$S($P(Y,"@",2)]"":"@"_$P(Y,"@",2),1:"")
;
NOW() ; -- return now
D NOW^%DTC
Q $$FTIME(%)
;
RANGE ; -- change date range
; input: ^TMP("SDUL DATA",$J SDULEVL,"DAYS") := number of days allowed
; SDB := default beginning date {optional}
;
I $D(SDB) S Y=SDB D DD^%DT S:Y]"" %DT("B")=Y
W ! S:$D(SDMIN) %DT(0)=SDMIN S %DT="AEX",%DT("A")="Select Beginning Date: " D ^%DT K %DT
G RANGEQ:Y<0 S (X1,SDX)=Y,X2=+$G(^TMP("SDUL DATA",$J,SDULEVL,"DAYS")) D C^%DTC S SDX1=X,X=""
I SDX'>DT,SDX1>DT S X="TODAY"
I X="" S Y=SDX D DD^%DT S X=Y
S DIR("B")=X
S DIR(0)="DA"_U_SDX_":"_SDX1_":EX",DIR("A")="Select Ending Date: "
S DIR("?",1)="Date range can be a maximum of "_+$G(^TMP("SDUL DATA",$J,SDULEVL,"DAYS"))_" days long.",DIR("?",2)=" "
S DIR("?",3)="Enter a date between "_$$FDATE(SDX)_" and "_$$FDATE(SDX1)_".",DIR("?")=" "
D ^DIR K DIR G RANGEQ:Y'>0 S SDEND=Y,SDBEG=SDX
RANGEQ K SDX,SDX1 Q
;
PAUSE ;
W ! S DIR(0)="E" D ^DIR K DIR W !
Q
;
PRT ; -- prt screen (PS)
N SDESC
S SDULBCK=$S(SDULCC:"",1:"R")
S %ZIS="Q" D ^%ZIS G PRTQ:POP
I '$D(IO("Q")),IO=IO(0) S SDULBCK="R" D CLEAR
I '$D(IO("Q")) G PRTS
S ZTRTN="PRTS^SDUL1",ZTIO=ION,ZTDESC="Print Screen -- List Manager Action"
D SAVE,^%ZTLOAD G PRTQ
;
PRTS ;
N SDULCC,SDULCAP
S SDULCC=0,SDULCAP=$$CAPTION^SDUL
U IO D HDR^SDUL,LIST^SDUL,FTR
PRTQ D:'$D(ZTQUEUED) ^%ZISC D TERM^SDUL0
Q
;
SAVE ; -- save to queue
F X="SDULPGE","SDULWD","SDULCNT","SDULBG","SDULDDF(","SDULHDR(","SDUL(","SDULAR",$E(SDULAR,1,$L(SDULAR)-1)_$S($E(SDULAR,$L(SDULAR))=")":",",1:"(") S ZTSAVE(X)=""
Q
;
FTR ; -- footer to print
S SDESC=""
I $E(IOST,1,2)="C-" D PAUSE S SDESC='Y
Q
;
PRTL ; -- prt list (PL)
N SDESC
S SDULBCK=$S(SDULCC:"",1:"R")
S %ZIS="Q" D ^%ZIS G PRTQ:POP
I '$D(IO("Q")),IO=IO(0) S SDULBCK="R" D CLEAR
I '$D(IO("Q")) G PRTLS
S ZTRTN="PRTLS^SDUL1",ZTIO=ION,ZTDESC="Print List -- List Manager Action"
D SAVE,^%ZTLOAD G PRTLQ
;
PRTLS ;
N SDULPGE,SDESC,SDULCC,SDI,SDLINES,SDULCAP
S SDLINES=SDUL("LINES")
S SDUL("LINES")=IOSL-5,SDULCC=0,SDULPGE=1,SDULCAP=$$CAPTION^SDUL
U IO D HDR^SDUL
F SDI=1:1:SDULCNT S X=$G(@SDULAR@($$GET^SDUL4(SDI),0)) W !,X I IOSL<($Y+6) D FTR G PRTLQ:SDESC S SDULPGE=SDULPGE+1 D HDR^SDUL
D FTR
PRTLQ D:'$D(ZTQUEUED) ^%ZISC D TERM^SDUL0
S:$D(SDLINES) SDUL("LINES")=SDLINES
Q
;
UPPER(X) ; -- convert to uppercase
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;
LOWER(X) ;
N Y,C,Z,I
S Y=$E(X)_$TR($E(X,2,999),"ABCDEFGHIJKLMNOPQRSTUVWXYZ@","abcdefghijklmnopqrstuvwxyz ")
F C=" ",",","/" F I=2:1 S Z=$P(Y,C,I,999) Q:Z="" S Y=$P(Y,C,1,I-1)_C_$TR($E(Z),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$E(Z,2,999)
Q Y
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDUL1 4639 printed Dec 13, 2024@03:01:45 Page 2
SDUL1 ;ALB/MJK - Screen Malipulation Utilities ; 12/1/91
+1 ;;5.3;Scheduling;**140**;Aug 13, 1993
+2 ;
INSTR(STR,X,Y,LENGTH,ERASE) ; -- insert text
+1 ; STR := string to insert
+2 ; X := X coordinate
+3 ; Y := Y coordinate
+4 ; LENGTH := clear # of characters
+5 ; ERASE := erase chars first
+6 ;
+7 WRITE IOSC
+8 IF $GET(ERASE)
SET DY=Y-1
SET DX=X-1
XECUTE IOXY
WRITE $JUSTIFY("",LENGTH)
+9 SET DY=Y-1
SET DX=X-1
XECUTE IOXY
WRITE STR
+10 WRITE IORC
+11 QUIT
+12 ;
FLDUPD(STR,FLD,ENTRY) ; -- update entry and field on screen
+1 ; STR := string to insert
+2 ; FLD := col name
+3 ; ENTRY := entry # in list
+4 ;
+5 DO INSTR(.STR,+$PIECE(SDULDDF(FLD),U,2),ENTRY-SDULBG+SDUL("TM"),$PIECE(SDULDDF(FLD),U,3),1)
+6 QUIT
+7 ;
SETFLD(STR,VAR,FLD) ; -- set field in var
+1 ; input: STR := string to insert
+2 ; VAR := destination string
+3 ; FLD := col name
+4 QUIT $$SETSTR^SDUL1(STR,VAR,+$PIECE(SDULDDF(FLD),U,2),+$PIECE(SDULDDF(FLD),U,3))
+5 ;
SETSTR(S,V,X,L) ; -- insert text(S) into variable(V)
+1 ; S := string to insert
+2 ; V := destination string
+3 ; X := insert @ col X
+4 ; L := clear # of chars (length)
+5 ;
+6 QUIT $EXTRACT(V_$JUSTIFY("",X-1),1,X-1)_$EXTRACT(S_$JUSTIFY("",L),1,L)_$EXTRACT(V,X+L,999)
+7 ;
FULL ; set full scrolling region
+1 IF '$DATA(IOSTBM)
DO TERM^SDUL0
+2 IF IOSTBM]""
SET IOTM=1
SET IOBM=IOSL
WRITE IOSC
WRITE @IOSTBM
WRITE IORC
+3 QUIT
+4 ;
CLEAR ; -- clear screen
+1 DO FULL
DO ERASE
WRITE @IOF
+2 QUIT
+3 ;
ERASE ;
+1 FOR X="IOUOFF","IOINORM"
WRITE $GET(@X)
+2 QUIT
+3 ;
FDATE(Y) ; -- return formatted date
+1 ; input: Y := field name
+2 ; output: [returned] := formatted date only
+3 QUIT $TRANSLATE($$FMTE^XLFDT(Y,"5DF")," ","0")
+4 ;
FTIME(Y) ; -- return formatted date/time
+1 ; input: Y := internal date/time
+2 ; output: [returned] := formatted date and time
+3 DO DD^%DT
+4 QUIT Y
+5 ;
FDTTM(Y) ; -- return formatted date/time
+1 ; input: Y := internal date/time
+2 ; output: [returned] := formatted date and time
+3 NEW SDY
+4 SET SDY=$TRANSLATE($$FMTE^XLFDT(Y,"5DF")," ","0")
+5 DO DD^%DT
+6 QUIT SDY_$SELECT($PIECE(Y,"@",2)]"":"@"_$PIECE(Y,"@",2),1:"")
+7 ;
NOW() ; -- return now
+1 DO NOW^%DTC
+2 QUIT $$FTIME(%)
+3 ;
RANGE ; -- change date range
+1 ; input: ^TMP("SDUL DATA",$J SDULEVL,"DAYS") := number of days allowed
+2 ; SDB := default beginning date {optional}
+3 ;
+4 IF $DATA(SDB)
SET Y=SDB
DO DD^%DT
if Y]""
SET %DT("B")=Y
+5 WRITE !
if $DATA(SDMIN)
SET %DT(0)=SDMIN
SET %DT="AEX"
SET %DT("A")="Select Beginning Date: "
DO ^%DT
KILL %DT
+6 if Y<0
GOTO RANGEQ
SET (X1,SDX)=Y
SET X2=+$GET(^TMP("SDUL DATA",$JOB,SDULEVL,"DAYS"))
DO C^%DTC
SET SDX1=X
SET X=""
+7 IF SDX'>DT
IF SDX1>DT
SET X="TODAY"
+8 IF X=""
SET Y=SDX
DO DD^%DT
SET X=Y
+9 SET DIR("B")=X
+10 SET DIR(0)="DA"_U_SDX_":"_SDX1_":EX"
SET DIR("A")="Select Ending Date: "
+11 SET DIR("?",1)="Date range can be a maximum of "_+$GET(^TMP("SDUL DATA",$JOB,SDULEVL,"DAYS"))_" days long."
SET DIR("?",2)=" "
+12 SET DIR("?",3)="Enter a date between "_$$FDATE(SDX)_" and "_$$FDATE(SDX1)_"."
SET DIR("?")=" "
+13 DO ^DIR
KILL DIR
if Y'>0
GOTO RANGEQ
SET SDEND=Y
SET SDBEG=SDX
RANGEQ KILL SDX,SDX1
QUIT
+1 ;
PAUSE ;
+1 WRITE !
SET DIR(0)="E"
DO ^DIR
KILL DIR
WRITE !
+2 QUIT
+3 ;
PRT ; -- prt screen (PS)
+1 NEW SDESC
+2 SET SDULBCK=$SELECT(SDULCC:"",1:"R")
+3 SET %ZIS="Q"
DO ^%ZIS
if POP
GOTO PRTQ
+4 IF '$DATA(IO("Q"))
IF IO=IO(0)
SET SDULBCK="R"
DO CLEAR
+5 IF '$DATA(IO("Q"))
GOTO PRTS
+6 SET ZTRTN="PRTS^SDUL1"
SET ZTIO=ION
SET ZTDESC="Print Screen -- List Manager Action"
+7 DO SAVE
DO ^%ZTLOAD
GOTO PRTQ
+8 ;
PRTS ;
+1 NEW SDULCC,SDULCAP
+2 SET SDULCC=0
SET SDULCAP=$$CAPTION^SDUL
+3 USE IO
DO HDR^SDUL
DO LIST^SDUL
DO FTR
PRTQ if '$DATA(ZTQUEUED)
DO ^%ZISC
DO TERM^SDUL0
+1 QUIT
+2 ;
SAVE ; -- save to queue
+1 FOR X="SDULPGE","SDULWD","SDULCNT","SDULBG","SDULDDF(","SDULHDR(","SDUL(","SDULAR",$EXTRACT(SDULAR,1,$LENGTH(SDULAR)-1)_$SELECT($EXTRACT(SDULAR,$LENGTH(SDULAR))=")":",",1:"(")
SET ZTSAVE(X)=""
+2 QUIT
+3 ;
FTR ; -- footer to print
+1 SET SDESC=""
+2 IF $EXTRACT(IOST,1,2)="C-"
DO PAUSE
SET SDESC='Y
+3 QUIT
+4 ;
PRTL ; -- prt list (PL)
+1 NEW SDESC
+2 SET SDULBCK=$SELECT(SDULCC:"",1:"R")
+3 SET %ZIS="Q"
DO ^%ZIS
if POP
GOTO PRTQ
+4 IF '$DATA(IO("Q"))
IF IO=IO(0)
SET SDULBCK="R"
DO CLEAR
+5 IF '$DATA(IO("Q"))
GOTO PRTLS
+6 SET ZTRTN="PRTLS^SDUL1"
SET ZTIO=ION
SET ZTDESC="Print List -- List Manager Action"
+7 DO SAVE
DO ^%ZTLOAD
GOTO PRTLQ
+8 ;
PRTLS ;
+1 NEW SDULPGE,SDESC,SDULCC,SDI,SDLINES,SDULCAP
+2 SET SDLINES=SDUL("LINES")
+3 SET SDUL("LINES")=IOSL-5
SET SDULCC=0
SET SDULPGE=1
SET SDULCAP=$$CAPTION^SDUL
+4 USE IO
DO HDR^SDUL
+5 FOR SDI=1:1:SDULCNT
SET X=$GET(@SDULAR@($$GET^SDUL4(SDI),0))
WRITE !,X
IF IOSL<($Y+6)
DO FTR
if SDESC
GOTO PRTLQ
SET SDULPGE=SDULPGE+1
DO HDR^SDUL
+6 DO FTR
PRTLQ if '$DATA(ZTQUEUED)
DO ^%ZISC
DO TERM^SDUL0
+1 if $DATA(SDLINES)
SET SDUL("LINES")=SDLINES
+2 QUIT
+3 ;
UPPER(X) ; -- convert to uppercase
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 ;
LOWER(X) ;
+1 NEW Y,C,Z,I
+2 SET Y=$EXTRACT(X)_$TRANSLATE($EXTRACT(X,2,999),"ABCDEFGHIJKLMNOPQRSTUVWXYZ@","abcdefghijklmnopqrstuvwxyz ")
+3 FOR C=" ",",","/"
FOR I=2:1
SET Z=$PIECE(Y,C,I,999)
if Z=""
QUIT
SET Y=$PIECE(Y,C,1,I-1)_C_$TRANSLATE($EXTRACT(Z),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$EXTRACT(Z,2,999)
+4 QUIT Y
+5 ;
