VALM ;MJK/ALB - List Manager;02:00 PM 21 Jan 1993 [ 07/24/98 9:04 AM ]
;;1;List Manager;**1,1002**;Aug 13, 1993
;IHS/ANMC/LJF 3/11/97 IHS PATCH #1002
; -- force re-execute of header code
;
;
EN(NAME,PARMS) ; -- main entry point
; input: NAME := free text name of list template or routine call
; PARMS := parameter list
;
I $G(PARMS)["T" K VALMEVL ; kill if 'T'op level
D INIT^VALM0(.NAME,$G(PARMS)) G ENQ:$D(VALMQUIT)
; -- build list of items
I $G(^TMP("VALM DATA",$J,VALMEVL,"INIT"))]"" X ^("INIT") G ENQ:$D(VALMQUIT)
; -- start event loop
S VALMBCK="R" D ASK
X:$G(^TMP("VALM DATA",$J,VALMEVL,"FNL"))]"" ^("FNL")
ENQ D POP^VALM0
Q
;
ASK ; -- event loop
S X=VALM("PROTOCOL") D XQORM,EN^XQOR
I $D(VALMBCK),VALMBCK'="Q" G ASK
ASKQ K XQORM,DTOUT,DIROUT,DUOUT Q
;
COL ; -- set up column dd array
K VALMDDF
S I=0 F S I=$O(^SD(409.61,VALM("IFN"),"COL",I)) Q:'I I $D(^(I,0)) S VALMDDF($P(^(0),U))=^(0)
Q
;
CAPTION() ; -- set up caption line of header
N X,COL,FLD
S $P(X,$S(VALMCC:" ",1:"-"),VALM("RM")+1)=""
S COL="" F S COL=$O(VALMDDF(COL)) Q:COL="" S FLD=VALMDDF(COL) D
.S X=$$SETSTR^VALM1($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(VALMDDF(FLD),U,4)=LABEL,VALMCAP=$$CAPTION
Q
;
REFRESH ; -- refresh display
S VALMPGE=$$PAGE^VALM4(VALMBG,VALM("LINES"))
S X=0 X ^%ZOSF("RM")
D HDR:$G(VALMBCK)'["P",TBAR,LIST,LBAR
S VALMBCK=""
Q
;
HDR ; -- prt/display header
N X,I
;I '$D(VALMHDR) X:$G(VALM("HDR"))]"" VALM("HDR") ;IHS PATCH #1002
X:$G(VALM("HDR"))]"" VALM("HDR") ;IHS PATCH #1002
; -- prt hdr line
W @IOF
W:VALMCC $C(13)_IOUON_$C(13)_IOINHI_$C(13) ; -- turn on undln/hi
I $E(IOST,1,2)="C-" D IOXY^VALM4(0,0) ; -- position cursor
W $E(VALM("TITLE"),1,30) ; -- prt title
W:VALMCC IOINORM,IOUON ; -- turn off hi
W $J("",30-$L(VALM("TITLE"))) ; -- fill in w/blanks
I $E(IOST,1,2)="C-" W $C(13) D IOXY^VALM4(30,0) ; -- position cursor
W $J("",((VALMWD-80)/2)),$$LOWER^VALM1($$NOW^VALM1),$J("",10+((VALMWD-80)/2)),"Page: ",$J(VALMPGE,4)," of ",$J($$PAGE^VALM4(VALMCNT,VALM("LINES")),4)_$S($D(VALMORE):"+",1:" ") ; -- prt rest of hdr
W:VALMCC IOUOFF I $E(IOST,1,2)="C-" D IOXY^VALM4(0,0) ; -- turn off undln
F I=1:1:VALM("TM")-3 W !,$S('$D(VALMHDR(I)):"",$L(VALMHDR(I))>(VALMWD-1):$$EXTRACT^VALM4($G(VALMHDR(I))),1:VALMHDR(I)) ; -- prt hdr
Q
;
TBAR ; -- print caption/top bar
N X
D CRT(0,VALM("TM")-3)
S VALMUP=(VALMBG>1),VALMCAP=$S(VALMUP:"+",VALMCC:" ",1:"-")_$E(VALMCAP,2,VALM("RM"))
S X=$E(VALMCAP,1,VALM("FIXED"))_$E(VALMCAP,VALMLFT,VALMLFT+VALMWD-1-VALM("FIXED"))
I VALM("TM")>2 D
.S:VALMCC X=IOUON_$C(13)_X_$C(13)_IOUOFF_$C(13)
.W !,X
Q
;
LIST ; -- list items
N I,LN,DY,DX
S DY=0
I $E(IOST,1,2)="C-" W ! S DX=0,DY=VALM("TM")-2 X IOXY
S I=VALMBG,VALMLST=I+VALM("LINES")-1 S:VALMLST>VALMCNT VALMLST=VALMCNT
F LN=1:1:VALM("LINES") D WRITE^VALM4(I,1,1,DY+LN) S I=I+1
Q
;
LBAR ; -- print low bar
N CHR,X
D CRT(0,VALM("BM")-1)
S CHR=$S(VALMCC:" ",1:"-")
K X S $P(X,CHR,VALMWD+1)=""
S X=$E(X,1,10)_$E($E($S($G(VALMSG)="":$$MSG(),1:VALMSG),1,50)_$E(X,11,75),1,65)_$E(X,76,VALMWD) K VALMSG
S VALMDN=(VALMLST<VALMCNT)
S X=$S(VALMDN:"+",1:CHR)_CHR_$S(VALMLFT>(VALM("FIXED")+1):"<<<",1:CHR_CHR_CHR)_$E(X,6,VALMWD-3)_$S((VALMLFT+(VALMWD-VALM("FIXED")))<VALM("RM"):">>>",1:CHR_CHR_CHR)
S:VALMCC X=$C(13)_IORVON_$C(13)_X_$C(13)_IORVOFF_$C(13)
W !,X
I $E(IOST,1,2)="C-" W !
Q
;
MSG() ;
Q "Enter ?? for more actions"
;
CRT(DX,DY) ;
I DX'<0,DY'<0,$E(IOST,1,2)="C-" W $C(13) D IOXY^VALM4(.DX,.DY)
Q
;
SHOW ; -- show items to user / main call back
W VALMCOFF
N DX,DY
S:'$D(VALMBG) VALMBG=1
S:'$D(VALMLFT) VALMLFT=VALM("FIXED")+1
S VALMPGE=$$PAGE^VALM4(VALMBG,VALM("LINES"))
I $G(VALMBCK)="R" D REFRESH
I $D(VALMSG) D MSG^VALM10(VALMSG) K VALMSG
I '$D(XQORM("B")),VALM("DEFS") S XQORM("B")=$S(VALMLST<VALMCNT:"Next Screen",1:"Quit")
I VALMCC D RESET^VALM4
S DX=0,DY=VALM("BM")-$S(VALM("TYPE")=2:0,1:VALMMENU) X IOXY
I VALMMENU D
.S X="?" D DISP^XQORM1
.W:VALMCC IOEDEOP
W VALMCON
D XQORM,KEYS K VALMBCK,VALMDY
Q
;
WP1(VALMREF) ; -- quick setup
S VALMCNT=+$P(@VALMREF@(0),U,4)
S VALM("ARRAY")=VALMREF
S:$D(VALMWPTL) VALM("TITLE")=VALMWPTL
Q
;
WP(VALMREF,VALMWPTL) ; -- quick entry to List Manager (c)
D EN("WP1^VALM(VALMREF)")
Q
;
XQORM ; -- set XQOR init vars
S XQORM(0)=VALM("MAX")_"AR\"
S XQORM("??")="D HELP^VALM2"
K DTOUT,DIROUT,DUOUT
Q
;
KEYS ; -- set XQOR auto-protocols
N I S I=0
F S I=$O(VALMKEY(I)) Q:'I S X=VALMKEY(I) S:$P(X,U,2)]"" XQORM("KEY",$P(X,U,2))=+X_"^1"
S XQORM("XLATE","LEFT")="<=1",XQORM("XLATE","RIGHT")=">=1"
S XQORM("XLATE","FIND")="SE",XQORM("XLATE","HELP")="??"
S XQORM("XLATE","DOWN")="DN",XQORM("XLATE","UP")="UP"
Q
VALM ;MJK/ALB - List Manager;02:00 PM 21 Jan 1993 [ 07/24/98 9:04 AM ]
+1 ;;1;List Manager;**1,1002**;Aug 13, 1993
+2 ;IHS/ANMC/LJF 3/11/97 IHS PATCH #1002
+3 ; -- force re-execute of header code
+4 ;
+5 ;
EN(NAME,PARMS) ; -- main entry point
+1 ; input: NAME := free text name of list template or routine call
+2 ; PARMS := parameter list
+3 ;
+4 ; kill if 'T'op level
IF $GET(PARMS)["T"
KILL VALMEVL
+5 DO INIT^VALM0(.NAME,$GET(PARMS))
IF $DATA(VALMQUIT)
GOTO ENQ
+6 ; -- build list of items
+7 IF $GET(^TMP("VALM DATA",$JOB,VALMEVL,"INIT"))]""
XECUTE ^("INIT")
IF $DATA(VALMQUIT)
GOTO ENQ
+8 ; -- start event loop
+9 SET VALMBCK="R"
DO ASK
+10 IF $GET(^TMP("VALM DATA",$JOB,VALMEVL,"FNL"))]""
XECUTE ^("FNL")
ENQ DO POP^VALM0
+1 QUIT
+2 ;
ASK ; -- event loop
+1 SET X=VALM("PROTOCOL")
DO XQORM
DO EN^XQOR
+2 IF $DATA(VALMBCK)
IF VALMBCK'="Q"
GOTO ASK
ASKQ KILL XQORM,DTOUT,DIROUT,DUOUT
QUIT
+1 ;
COL ; -- set up column dd array
+1 KILL VALMDDF
+2 SET I=0
FOR
SET I=$ORDER(^SD(409.61,VALM("IFN"),"COL",I))
IF 'I
QUIT
IF $DATA(^(I,0))
SET VALMDDF($PIECE(^(0),U))=^(0)
+3 QUIT
+4 ;
CAPTION() ; -- set up caption line of header
+1 NEW X,COL,FLD
+2 SET $PIECE(X,$SELECT(VALMCC:" ",1:"-"),VALM("RM")+1)=""
+3 SET COL=""
FOR
SET COL=$ORDER(VALMDDF(COL))
IF COL=""
QUIT
SET FLD=VALMDDF(COL)
Begin DoDot:1
+4 SET X=$$SETSTR^VALM1($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(VALMDDF(FLD),U,4)=LABEL
SET VALMCAP=$$CAPTION
+4 QUIT
+5 ;
REFRESH ; -- refresh display
+1 SET VALMPGE=$$PAGE^VALM4(VALMBG,VALM("LINES"))
+2 SET X=0
XECUTE ^%ZOSF("RM")
+3 IF $GET(VALMBCK)'["P"
DO HDR
DO TBAR
DO LIST
DO LBAR
+4 SET VALMBCK=""
+5 QUIT
+6 ;
HDR ; -- prt/display header
+1 NEW X,I
+2 ;I '$D(VALMHDR) X:$G(VALM("HDR"))]"" VALM("HDR") ;IHS PATCH #1002
+3 ;IHS PATCH #1002
IF $GET(VALM("HDR"))]""
XECUTE VALM("HDR")
+4 ; -- prt hdr line
+5 WRITE @IOF
+6 ; -- turn on undln/hi
IF VALMCC
WRITE $CHAR(13)_IOUON_$CHAR(13)_IOINHI_$CHAR(13)
+7 ; -- position cursor
IF $EXTRACT(IOST,1,2)="C-"
DO IOXY^VALM4(0,0)
+8 ; -- prt title
WRITE $EXTRACT(VALM("TITLE"),1,30)
+9 ; -- turn off hi
IF VALMCC
WRITE IOINORM,IOUON
+10 ; -- fill in w/blanks
WRITE $JUSTIFY("",30-$LENGTH(VALM("TITLE")))
+11 ; -- position cursor
IF $EXTRACT(IOST,1,2)="C-"
WRITE $CHAR(13)
DO IOXY^VALM4(30,0)
+12 ; -- prt rest of hdr
WRITE $JUSTIFY("",((VALMWD-80)/2)),$$LOWER^VALM1($$NOW^VALM1),$JUSTIFY("",10+((VALMWD-80)/2)),"Page: ",$JUSTIFY(VALMPGE,4)," of ",$JUSTIFY($$PAGE^VALM4(VALMCNT,VALM("LINES")),4)_$SELECT($DATA(VALMORE):"+",1:" ")
+13 ; -- turn off undln
IF VALMCC
WRITE IOUOFF
IF $EXTRACT(IOST,1,2)="C-"
DO IOXY^VALM4(0,0)
+14 ; -- prt hdr
FOR I=1:1:VALM("TM")-3
WRITE !,$SELECT('$DATA(VALMHDR(I)):"",$LENGTH(VALMHDR(I))>(VALMWD-1):$$EXTRACT^VALM4($GET(VALMHDR(I))),1:VALMHDR(I))
+15 QUIT
+16 ;
TBAR ; -- print caption/top bar
+1 NEW X
+2 DO CRT(0,VALM("TM")-3)
+3 SET VALMUP=(VALMBG>1)
SET VALMCAP=$SELECT(VALMUP:"+",VALMCC:" ",1:"-")_$EXTRACT(VALMCAP,2,VALM("RM"))
+4 SET X=$EXTRACT(VALMCAP,1,VALM("FIXED"))_$EXTRACT(VALMCAP,VALMLFT,VALMLFT+VALMWD-1-VALM("FIXED"))
+5 IF VALM("TM")>2
Begin DoDot:1
+6 IF VALMCC
SET X=IOUON_$CHAR(13)_X_$CHAR(13)_IOUOFF_$CHAR(13)
+7 WRITE !,X
End DoDot:1
+8 QUIT
+9 ;
LIST ; -- list items
+1 NEW I,LN,DY,DX
+2 SET DY=0
+3 IF $EXTRACT(IOST,1,2)="C-"
WRITE !
SET DX=0
SET DY=VALM("TM")-2
XECUTE IOXY
+4 SET I=VALMBG
SET VALMLST=I+VALM("LINES")-1
IF VALMLST>VALMCNT
SET VALMLST=VALMCNT
+5 FOR LN=1:1:VALM("LINES")
DO WRITE^VALM4(I,1,1,DY+LN)
SET I=I+1
+6 QUIT
+7 ;
LBAR ; -- print low bar
+1 NEW CHR,X
+2 DO CRT(0,VALM("BM")-1)
+3 SET CHR=$SELECT(VALMCC:" ",1:"-")
+4 KILL X
SET $PIECE(X,CHR,VALMWD+1)=""
+5 SET X=$EXTRACT(X,1,10)_$EXTRACT($EXTRACT($SELECT($GET(VALMSG)="":$$MSG(),1:VALMSG),1,50)_$EXTRACT(X,11,75),1,65)_$EXTRACT(X,76,VALMWD)
KILL VALMSG
+6 SET VALMDN=(VALMLST<VALMCNT)
+7 SET X=$SELECT(VALMDN:"+",1:CHR)_CHR_$SELECT(VALMLFT>(VALM("FIXED")+1):"<<<",1:CHR_CHR_CHR)_$EXTRACT(X,6,VALMWD-3)_$SELECT((VALMLFT+(VALMWD-VALM("FIXED")))<VALM("RM"):">>>",1:CHR_CHR_CHR)
+8 IF VALMCC
SET X=$CHAR(13)_IORVON_$CHAR(13)_X_$CHAR(13)_IORVOFF_$CHAR(13)
+9 WRITE !,X
+10 IF $EXTRACT(IOST,1,2)="C-"
WRITE !
+11 QUIT
+12 ;
MSG() ;
+1 QUIT "Enter ?? for more actions"
+2 ;
CRT(DX,DY) ;
+1 IF DX'<0
IF DY'<0
IF $EXTRACT(IOST,1,2)="C-"
WRITE $CHAR(13)
DO IOXY^VALM4(.DX,.DY)
+2 QUIT
+3 ;
SHOW ; -- show items to user / main call back
+1 WRITE VALMCOFF
+2 NEW DX,DY
+3 IF '$DATA(VALMBG)
SET VALMBG=1
+4 IF '$DATA(VALMLFT)
SET VALMLFT=VALM("FIXED")+1
+5 SET VALMPGE=$$PAGE^VALM4(VALMBG,VALM("LINES"))
+6 IF $GET(VALMBCK)="R"
DO REFRESH
+7 IF $DATA(VALMSG)
DO MSG^VALM10(VALMSG)
KILL VALMSG
+8 IF '$DATA(XQORM("B"))
IF VALM("DEFS")
SET XQORM("B")=$SELECT(VALMLST<VALMCNT:"Next Screen",1:"Quit")
+9 IF VALMCC
DO RESET^VALM4
+10 SET DX=0
SET DY=VALM("BM")-$SELECT(VALM("TYPE")=2:0,1:VALMMENU)
XECUTE IOXY
+11 IF VALMMENU
Begin DoDot:1
+12 SET X="?"
DO DISP^XQORM1
+13 IF VALMCC
WRITE IOEDEOP
End DoDot:1
+14 WRITE VALMCON
+15 DO XQORM
DO KEYS
KILL VALMBCK,VALMDY
+16 QUIT
+17 ;
WP1(VALMREF) ; -- quick setup
+1 SET VALMCNT=+$PIECE(@VALMREF@(0),U,4)
+2 SET VALM("ARRAY")=VALMREF
+3 IF $DATA(VALMWPTL)
SET VALM("TITLE")=VALMWPTL
+4 QUIT
+5 ;
WP(VALMREF,VALMWPTL) ; -- quick entry to List Manager (c)
+1 DO EN("WP1^VALM(VALMREF)")
+2 QUIT
+3 ;
XQORM ; -- set XQOR init vars
+1 SET XQORM(0)=VALM("MAX")_"AR\"
+2 SET XQORM("??")="D HELP^VALM2"
+3 KILL DTOUT,DIROUT,DUOUT
+4 QUIT
+5 ;
KEYS ; -- set XQOR auto-protocols
+1 NEW I
SET I=0
+2 FOR
SET I=$ORDER(VALMKEY(I))
IF 'I
QUIT
SET X=VALMKEY(I)
IF $PIECE(X,U,2)]""
SET XQORM("KEY",$PIECE(X,U,2))=+X_"^1"
+3 SET XQORM("XLATE","LEFT")="<=1"
SET XQORM("XLATE","RIGHT")=">=1"
+4 SET XQORM("XLATE","FIND")="SE"
SET XQORM("XLATE","HELP")="??"
+5 SET XQORM("XLATE","DOWN")="DN"
SET XQORM("XLATE","UP")="UP"
+6 QUIT
