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