VALM1 ;ALB/MJK - Screen Malipulation Utilities ;08:17 PM 6 Dec 1992 [ 09/26/2002 11:33 AM ]
;;1;List Manager;**1002**;Aug 13, 1993
;IHS/ANMC/LJF 7/8/98 IHS PATCH #1002
; -- added check for VALMWD under FULL
;
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 '$D(IOSTBM) D TERM^VALM0 ;IHS PATCH #1002
I '$D(IOSTBM)!('$D(VALMWD)) D TERM^VALM0 ;IHS PATCH #1002
I IOSTBM]"" S IOTM=1,IOBM=IOSL W IOSC W @IOSTBM W IORC
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
;
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")),IO=IO(0) D CLEAR S X=0 X ^%ZOSF("RM")
I '$D(IO("Q")) G PRTS
S ZTRTN="PRTS^VALM1",ZTIO=ION,ZTDESC="Print Screen -- List Manager Action"
D SAVE,^%ZTLOAD G PRTQ
;
PRTS ;
N VALMCC,VALMCAP
S VALMCC=0,VALMCAP=$$CAPTION^VALM
U IO D HDR^VALM,TBAR^VALM,LIST^VALM,LBAR^VALM,FTR
PRTQ 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-" D PAUSE S VALMESC='Y
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")),IO=IO(0) D CLEAR S X=0 X ^%ZOSF("RM")
I '$D(IO("Q")) G PRTLS
S ZTRTN="PRTLS^VALM1",ZTIO=ION,ZTDESC="Print List -- List Manager Action"
D SAVE,^%ZTLOAD G PRTLQ
;
PRTLS ;
N VALMPGE,VALMESC,VALMCC,VALMI,VALMLNS,VALMCAP,VALMWD
S VALMWD=IOM,VALMLNS=VALM("LINES")
S VALM("LINES")=IOSL-5,VALMCC=0,VALMPGE=1,VALMCAP=$$CAPTION^VALM
;9/26/2002 WAR per LJF24
;U IO D HDR^VALM,TBAR^VALM
U IO NEW VALMSAV S VALMSAV=VALM("HDR") S VALM("HDR")="" D HDR^VALM,TBAR^VALM S VALM("HDR")=VALMSAV ;IHS/ANMC/LJF 7/29/2002 VALMHDR array already sen't recreate if queued
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
PRTLQ D:'$D(ZTQUEUED) ^%ZISC D TERM^VALM0 S X=0 X ^%ZOSF("RM")
S:$D(VALMLNS) VALM("LINES")=VALMLNS
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=" ",",","/" 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
;
VALM1 ;ALB/MJK - Screen Malipulation Utilities ;08:17 PM 6 Dec 1992 [ 09/26/2002 11:33 AM ]
+1 ;;1;List Manager;**1002**;Aug 13, 1993
+2 ;IHS/ANMC/LJF 7/8/98 IHS PATCH #1002
+3 ; -- added check for VALMWD under FULL
+4 ;
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,LINE,CON,COFF) ; -- update entry and field on screen
+1 ; STR := string to insert
+2 ; FLD := col name
+3 ; LINE := entry # in list
+4 ;
+5 DO INSTR(.STR,+$PIECE(VALMDDF(FLD),U,2),LINE-VALMBG+VALM("TM"),$PIECE(VALMDDF(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(STR,VAR,+$PIECE(VALMDDF(FLD),U,2),+$PIECE(VALMDDF(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 ;I '$D(IOSTBM) D TERM^VALM0 ;IHS PATCH #1002
+2 ;IHS PATCH #1002
IF '$DATA(IOSTBM)!('$DATA(VALMWD))
DO TERM^VALM0
+3 IF IOSTBM]""
SET IOTM=1
SET IOBM=IOSL
WRITE IOSC
WRITE @IOSTBM
WRITE IORC
+4 SET X=VALMWD
XECUTE ^%ZOSF("RM")
+5 QUIT
+6 ;
CLEAR ; -- clear screen
+1 DO FULL
DO ERASE
WRITE @IOF
+2 QUIT
+3 ;
ERASE ;
+1 WRITE $GET(VALMSGR),$GET(IOSGR0)
+2 QUIT
+3 ;
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)
+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 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:"")
+7 ;
NOW() ; -- return now
+1 DO NOW^%DTC
+2 QUIT $$FTIME(%)
+3 ;
RANGE ; -- change date range
+1 GOTO RANGE^VALM11
+2 ;
PAUSE ;
+1 WRITE !
SET DIR(0)="E"
DO ^DIR
KILL DIR
WRITE !
+2 QUIT
+3 ;
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"))
IF IO=IO(0)
DO CLEAR
SET X=0
XECUTE ^%ZOSF("RM")
+6 IF '$DATA(IO("Q"))
GOTO PRTS
+7 SET ZTRTN="PRTS^VALM1"
SET ZTIO=ION
SET ZTDESC="Print Screen -- List Manager Action"
+8 DO SAVE
DO ^%ZTLOAD
GOTO PRTQ
+9 ;
PRTS ;
+1 NEW VALMCC,VALMCAP
+2 SET VALMCC=0
SET VALMCAP=$$CAPTION^VALM
+3 USE IO
DO HDR^VALM
DO TBAR^VALM
DO LIST^VALM
DO LBAR^VALM
DO FTR
PRTQ IF '$DATA(ZTQUEUED)
DO ^%ZISC
DO TERM^VALM0
SET X=0
XECUTE ^%ZOSF("RM")
+1 QUIT
+2 ;
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
+4 ;
FTR ; -- footer to print
+1 SET VALMESC=""
+2 IF $EXTRACT(IOST,1,2)="C-"
DO PAUSE
SET VALMESC='Y
+3 QUIT
+4 ;
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"))
IF IO=IO(0)
DO CLEAR
SET X=0
XECUTE ^%ZOSF("RM")
+7 IF '$DATA(IO("Q"))
GOTO PRTLS
+8 SET ZTRTN="PRTLS^VALM1"
SET ZTIO=ION
SET ZTDESC="Print List -- List Manager Action"
+9 DO SAVE
DO ^%ZTLOAD
GOTO PRTLQ
+10 ;
PRTLS ;
+1 NEW VALMPGE,VALMESC,VALMCC,VALMI,VALMLNS,VALMCAP,VALMWD
+2 SET VALMWD=IOM
SET VALMLNS=VALM("LINES")
+3 SET VALM("LINES")=IOSL-5
SET VALMCC=0
SET VALMPGE=1
SET VALMCAP=$$CAPTION^VALM
+4 ;9/26/2002 WAR per LJF24
+5 ;U IO D HDR^VALM,TBAR^VALM
+6 ;IHS/ANMC/LJF 7/29/2002 VALMHDR array already sen't recreate if queued
USE IO
NEW VALMSAV
SET VALMSAV=VALM("HDR")
SET VALM("HDR")=""
DO HDR^VALM
DO TBAR^VALM
SET VALM("HDR")=VALMSAV
+7 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
+8 DO FTR
PRTLQ IF '$DATA(ZTQUEUED)
DO ^%ZISC
DO TERM^VALM0
SET X=0
XECUTE ^%ZOSF("RM")
+1 IF $DATA(VALMLNS)
SET VALM("LINES")=VALMLNS
+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=" ",",","/"
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
+5 ;
