VALM1 ;ALB/MJK - Screen Manipulation Utilities ;06/27/2006
;;1.0;List Manager;**5,6,8,9**;Aug 13, 1993;Build 2
;Per VHA Directive 2004-038, this routine should not be modified.
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,LINE,CON,COFF) ; -- update entry and field on screen
; STR := string to insert
; FLD := col name
; LINE := entry # in list
D INSTR(.STR,+$P(VALMDDF(FLD),U,2),LINE-VALMBG+VALM("TM"),$P(VALMDDF(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(STR,VAR,+$P(VALMDDF(FLD),U,2),+$P(VALMDDF(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 '$L($G(IOSTBM))!'$G(IOSL)!'$L($G(IOSC))!'$D(IORC) D TERM^VALM0
I IOSTBM]"" S IOTM=1,IOBM=IOSL W IOSC W @IOSTBM W IORC
S:'$G(VALMWD) VALMWD=IOM S X=VALMWD X ^%ZOSF("RM")
Q
CLEAR ; -- clear screen
D FULL,ERASE W @IOF
Q
ERASE ;
W $G(VALMSGR),$G(IOSGR0)
Q
FDATE(Y) ; -- return formatted date
; input: Y := field name
; output: [returned] := formatted date only
Q $E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)
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 VALMY
S VALMY=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)
D DD^%DT
Q VALMY_$S($P(Y,"@",2)]"":"@"_$P(Y,"@",2),1:"")
NOW() ; -- return now
D NOW^%DTC
Q $$FTIME(%)
RANGE ; -- change date range
G RANGE^VALM11
WAIT ; "Enter RETURN to continue"
N DIR,X,Y,DIRUT,DUOUT,DTOUT,DIROUT
W ! S DIR(0)="E" S DIR("A")="Enter RETURN to continue" D ^DIR W !
Q
GOON() ; "Enter RETURN to continue or '^' to exit"
N DIR,X,Y,DIRUT,DUOUT,DTOUT,DIROUT
W ! S DIR(0)="E" D ^DIR W !
Q +Y
PAUSE ;
W ! S DIR(0)="E" D ^DIR K DIR W !
Q
PRT ; -- prt screen (PS)
N VALMESC
S VALMBCK="R"
D:VALMCC FULL
S %ZIS="Q" D ^%ZIS G PRTQ:POP
I $D(IO("Q")) D G PRTQ
. S ZTRTN="PRTS^VALM1",ZTDESC="List Manager: Print Screen"
. D SAVE,^%ZTLOAD
I IO=IO(0) D CLEAR S X=0 X ^%ZOSF("RM")
; fall through
PRTS ;
N VALMCC,VALMCAP
I $D(ZTQUEUED) S ZTREQ="@"
S VALMCC=0,VALMCAP=$$CAPTION^VALM,VALMPG1=1
U IO D HDR^VALM,TBAR^VALM,LIST^VALM,LBAR^VALM,FTR
; fall through
PRTQ ;
D CHKLONG
D:'$D(ZTQUEUED) ^%ZISC
D TERM^VALM0 S X=0 X ^%ZOSF("RM")
Q
SAVE ; -- save to queue
F X="VALMIOXY","VALMEVL","VALMLFT","VALMPGE","VALMWD","VALMCNT","VALMBG","VALMDDF(","VALMHDR(","VALM(" S ZTSAVE(X)=""
F X="VALMAR",$S($E(VALMAR,$L(VALMAR))=")":$E(VALMAR,1,$L(VALMAR)-1)_",",1:VALMAR_"(") S ZTSAVE(X)=""
Q
FTR ; -- footer to print
S VALMESC=""
I $E(IOST,1,2)="C-" S VALMESC='$$GOON
Q
PRTL ; -- prt list (PL)
I $G(VALM("PRT"))]"",$O(^ORD(101,"B",VALM("PRT"),0)) S X=$O(^(0))_";ORD(101," D EN^XQOR G PRTQ
N VALMESC
S VALMBCK="R"
D:VALMCC FULL
S %ZIS="Q" D ^%ZIS G PRTQ:POP
I $D(IO("Q")) D G PRTLQ
. S ZTRTN="PRTLS^VALM1",ZTDESC="List Manager: Print List"
. D SAVE,^%ZTLOAD
I IO=IO(0) D CLEAR S X=0 X ^%ZOSF("RM")
; fall through
PRTLS ;
N VALMPGE,VALMESC,VALMCC,VALMI,VALMLNS,VALMCAP,VALMWD
I $D(ZTQUEUED) S ZTREQ="@"
S VALMWD=IOM,VALMLNS=VALM("LINES"),VALMPG1=1
S VALM("LINES")=IOSL-(VALM("TM")+3),VALMCC=0,VALMPGE=1,VALMCAP=$$CAPTION^VALM
U IO D HDR^VALM,TBAR^VALM
F VALMI=1:1:VALMCNT S X=$G(@VALMAR@($$GET^VALM4(VALMI),0)) W !,X I IOSL<($Y+6) D FTR G PRTLQ:VALMESC S VALMPGE=VALMPGE+1 D HDR^VALM,TBAR^VALM
D FTR
; fall through
PRTLQ ;
D CHKLONG
D:'$D(ZTQUEUED) ^%ZISC
D TERM^VALM0 S X=0 X ^%ZOSF("RM")
S:$D(VALMLNS) VALM("LINES")=VALMLNS
Q
CHKLONG ;
Q:'$$TOOLONG
I '$D(ZTQUEUED) S VALMSG="Some printed item lines may have been truncated." Q:IO(0)=IO!$D(IO("Q"))
Q:$E(IOST,1,2)="C-"
I $Y+4>IOSL W @IOF
E W !
W !,">>> Warning: Some list items lines may have been truncated."
W !,">>> This list requires ",VALM("RM")," characters/line."
W !,">>> This device supports ",IOM," characters/line."
Q
TOOLONG() ; Is the line length too long for the device?
Q:'$D(VALM("RM")) 0
Q:'$D(IOM) 0
Q $S(VALM("RM")>IOM:1,1:0)
UPPER(X) ; -- convert to uppercase
Q $$UP^XLFSTR(X)
LOWER(X) ;
N Y,C,Z,I
S Y=$E(X)_$TR($E(X,2,999),"ABCDEFGHIJKLMNOPQRSTUVWXYZ@","abcdefghijklmnopqrstuvwxyz ")
F C=" ",",","/" S I=0 F S I=$F(Y,C,I) Q:'I S Y=$E(Y,1,I-1)_$TR($E(Y,I),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$E(Y,I+1,999)
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVALM1 5059 printed Oct 16, 2024@18:10:46 Page 2
VALM1 ;ALB/MJK - Screen Manipulation Utilities ;06/27/2006
+1 ;;1.0;List Manager;**5,6,8,9**;Aug 13, 1993;Build 2
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
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 WRITE IOSC
+7 IF $GET(ERASE)
SET DY=Y-1
SET DX=X-1
XECUTE IOXY
WRITE $JUSTIFY("",LENGTH)
+8 SET DY=Y-1
SET DX=X-1
XECUTE IOXY
WRITE STR
+9 WRITE IORC
+10 QUIT
FLDUPD(STR,FLD,LINE,CON,COFF) ; -- update entry and field on screen
+1 ; STR := string to insert
+2 ; FLD := col name
+3 ; LINE := entry # in list
+4 DO INSTR(.STR,+$PIECE(VALMDDF(FLD),U,2),LINE-VALMBG+VALM("TM"),$PIECE(VALMDDF(FLD),U,3),1)
+5 QUIT
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(STR,VAR,+$PIECE(VALMDDF(FLD),U,2),+$PIECE(VALMDDF(FLD),U,3))
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 QUIT $EXTRACT(V_$JUSTIFY("",X-1),1,X-1)_$EXTRACT(S_$JUSTIFY("",L),1,L)_$EXTRACT(V,X+L,999)
FULL ; set full scrolling region
+1 IF '$LENGTH($GET(IOSTBM))!'$GET(IOSL)!'$LENGTH($GET(IOSC))!'$DATA(IORC)
DO TERM^VALM0
+2 IF IOSTBM]""
SET IOTM=1
SET IOBM=IOSL
WRITE IOSC
WRITE @IOSTBM
WRITE IORC
+3 if '$GET(VALMWD)
SET VALMWD=IOM
SET X=VALMWD
XECUTE ^%ZOSF("RM")
+4 QUIT
CLEAR ; -- clear screen
+1 DO FULL
DO ERASE
WRITE @IOF
+2 QUIT
ERASE ;
+1 WRITE $GET(VALMSGR),$GET(IOSGR0)
+2 QUIT
FDATE(Y) ; -- return formatted date
+1 ; input: Y := field name
+2 ; output: [returned] := formatted date only
+3 QUIT $EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)
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
FDTTM(Y) ; -- return formatted date/time
+1 ; input: Y := internal date/time
+2 ; output: [returned] := formatted date and time
+3 NEW VALMY
+4 SET VALMY=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)
+5 DO DD^%DT
+6 QUIT VALMY_$SELECT($PIECE(Y,"@",2)]"":"@"_$PIECE(Y,"@",2),1:"")
NOW() ; -- return now
+1 DO NOW^%DTC
+2 QUIT $$FTIME(%)
RANGE ; -- change date range
+1 GOTO RANGE^VALM11
WAIT ; "Enter RETURN to continue"
+1 NEW DIR,X,Y,DIRUT,DUOUT,DTOUT,DIROUT
+2 WRITE !
SET DIR(0)="E"
SET DIR("A")="Enter RETURN to continue"
DO ^DIR
WRITE !
+3 QUIT
GOON() ; "Enter RETURN to continue or '^' to exit"
+1 NEW DIR,X,Y,DIRUT,DUOUT,DTOUT,DIROUT
+2 WRITE !
SET DIR(0)="E"
DO ^DIR
WRITE !
+3 QUIT +Y
PAUSE ;
+1 WRITE !
SET DIR(0)="E"
DO ^DIR
KILL DIR
WRITE !
+2 QUIT
PRT ; -- prt screen (PS)
+1 NEW VALMESC
+2 SET VALMBCK="R"
+3 if VALMCC
DO FULL
+4 SET %ZIS="Q"
DO ^%ZIS
if POP
GOTO PRTQ
+5 IF $DATA(IO("Q"))
Begin DoDot:1
+6 SET ZTRTN="PRTS^VALM1"
SET ZTDESC="List Manager: Print Screen"
+7 DO SAVE
DO ^%ZTLOAD
End DoDot:1
GOTO PRTQ
+8 IF IO=IO(0)
DO CLEAR
SET X=0
XECUTE ^%ZOSF("RM")
+9 ; fall through
PRTS ;
+1 NEW VALMCC,VALMCAP
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 SET VALMCC=0
SET VALMCAP=$$CAPTION^VALM
SET VALMPG1=1
+4 USE IO
DO HDR^VALM
DO TBAR^VALM
DO LIST^VALM
DO LBAR^VALM
DO FTR
+5 ; fall through
PRTQ ;
+1 DO CHKLONG
+2 if '$DATA(ZTQUEUED)
DO ^%ZISC
+3 DO TERM^VALM0
SET X=0
XECUTE ^%ZOSF("RM")
+4 QUIT
SAVE ; -- save to queue
+1 FOR X="VALMIOXY","VALMEVL","VALMLFT","VALMPGE","VALMWD","VALMCNT","VALMBG","VALMDDF(","VALMHDR(","VALM("
SET ZTSAVE(X)=""
+2 FOR X="VALMAR",$SELECT($EXTRACT(VALMAR,$LENGTH(VALMAR))=")":$EXTRACT(VALMAR,1,$LENGTH(VALMAR)-1)_",",1:VALMAR_"(")
SET ZTSAVE(X)=""
+3 QUIT
FTR ; -- footer to print
+1 SET VALMESC=""
+2 IF $EXTRACT(IOST,1,2)="C-"
SET VALMESC='$$GOON
+3 QUIT
PRTL ; -- prt list (PL)
+1 IF $GET(VALM("PRT"))]""
IF $ORDER(^ORD(101,"B",VALM("PRT"),0))
SET X=$ORDER(^(0))_";ORD(101,"
DO EN^XQOR
GOTO PRTQ
+2 NEW VALMESC
+3 SET VALMBCK="R"
+4 if VALMCC
DO FULL
+5 SET %ZIS="Q"
DO ^%ZIS
if POP
GOTO PRTQ
+6 IF $DATA(IO("Q"))
Begin DoDot:1
+7 SET ZTRTN="PRTLS^VALM1"
SET ZTDESC="List Manager: Print List"
+8 DO SAVE
DO ^%ZTLOAD
End DoDot:1
GOTO PRTLQ
+9 IF IO=IO(0)
DO CLEAR
SET X=0
XECUTE ^%ZOSF("RM")
+10 ; fall through
PRTLS ;
+1 NEW VALMPGE,VALMESC,VALMCC,VALMI,VALMLNS,VALMCAP,VALMWD
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 SET VALMWD=IOM
SET VALMLNS=VALM("LINES")
SET VALMPG1=1
+4 SET VALM("LINES")=IOSL-(VALM("TM")+3)
SET VALMCC=0
SET VALMPGE=1
SET VALMCAP=$$CAPTION^VALM
+5 USE IO
DO HDR^VALM
DO TBAR^VALM
+6 FOR VALMI=1:1:VALMCNT
SET X=$GET(@VALMAR@($$GET^VALM4(VALMI),0))
WRITE !,X
IF IOSL<($Y+6)
DO FTR
if VALMESC
GOTO PRTLQ
SET VALMPGE=VALMPGE+1
DO HDR^VALM
DO TBAR^VALM
+7 DO FTR
+8 ; fall through
PRTLQ ;
+1 DO CHKLONG
+2 if '$DATA(ZTQUEUED)
DO ^%ZISC
+3 DO TERM^VALM0
SET X=0
XECUTE ^%ZOSF("RM")
+4 if $DATA(VALMLNS)
SET VALM("LINES")=VALMLNS
+5 QUIT
CHKLONG ;
+1 if '$$TOOLONG
QUIT
+2 IF '$DATA(ZTQUEUED)
SET VALMSG="Some printed item lines may have been truncated."
if IO(0)=IO!$DATA(IO("Q"))
QUIT
+3 if $EXTRACT(IOST,1,2)="C-"
QUIT
+4 IF $Y+4>IOSL
WRITE @IOF
+5 IF '$TEST
WRITE !
+6 WRITE !,">>> Warning: Some list items lines may have been truncated."
+7 WRITE !,">>> This list requires ",VALM("RM")," characters/line."
+8 WRITE !,">>> This device supports ",IOM," characters/line."
+9 QUIT
TOOLONG() ; Is the line length too long for the device?
+1 if '$DATA(VALM("RM"))
QUIT 0
+2 if '$DATA(IOM)
QUIT 0
+3 QUIT $SELECT(VALM("RM")>IOM:1,1:0)
UPPER(X) ; -- convert to uppercase
+1 QUIT $$UP^XLFSTR(X)
LOWER(X) ;
+1 NEW Y,C,Z,I
+2 SET Y=$EXTRACT(X)_$TRANSLATE($EXTRACT(X,2,999),"ABCDEFGHIJKLMNOPQRSTUVWXYZ@","abcdefghijklmnopqrstuvwxyz ")
+3 FOR C=" ",",","/"
SET I=0
FOR
SET I=$FIND(Y,C,I)
if 'I
QUIT
SET Y=$EXTRACT(Y,1,I-1)_$TRANSLATE($EXTRACT(Y,I),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$EXTRACT(Y,I+1,999)
+4 QUIT Y
