VALM0 ;MJK/ALB - List Manager (cont.);08:19 PM 17 Jan 1993 [ 07/24/98 9:06 AM ]
;;1;List Manager;**1001,1002**;Aug 13, 1993
;IHS/ANMC/LJF 3/5/96 IHS PATCH #1001
; -- Added code to turn line wrap OFF; needed if WP field was called
;IHS/ANMC/LJF 5/21/97 IHS PATCH #1002
; -- Added check for variable VALMNOFF to suppress form feed after
; last list template. Set VALMNOFF=1 in EXIT subrtn for your
; list template
;
INIT(NAME,PARMS) ;
D STACK
K VALMBCK,VALMQUIT,VALMHDR
S VALM(0)=$G(PARMS)
I NAME["^",'$$SETUP^VALM00(.NAME) S VALMQUIT="" G INITQ
I NAME'["^",'$$TEMP(.NAME) S VALMQUIT="" G INITQ
D TERM:'VALMEVL,CALC
INITQ K VALMX,X Q
;
TERM ; -- set up term characteristics
D HOME^%ZIS
S VALMWD=IOM,X=$$IO_";IOBON;IOBOFF;IOSGR0" D ENDR^%ZISS
S X="IOAWM0" D ENDR^%ZISS W IOAWM0 K IOAWM0 ;IHS PATCH #1001
S VALMSGR=$S($G(IOSGR0)]"":IOSGR0,1:$G(IOINORM))
; -- cursor off/on to avoid bouncing
S (VALMCON,VALMCOFF)=""
I $E(IOST,1,4)="C-VT" S VALMCOFF=$C(13,27,91)_"?25l"_$C(13),VALMCON=$C(13,27,91)_"?25h"_$C(13)
S X="XQORM6" X ^%ZOSF("TEST") D:$T INIT^XQORM6
S VALMIOXY=^%ZOSF("XY")
Q
;
IO() ; -- what device params
Q "IORVON;IORVOFF;IOIL;IOSTBM;IOSC;IORC;IOEDEOP;IOINHI;IOINORM;IOUON;IOUOFF"
;
STACK ; -- stack vars
I $D(VALMEVL) D
.K ^TMP("VALM STACK",$J,VALMEVL)
.; -- stack'em
.I $O(^TMP("VALM STACK",$J,VALMEVL,"VALM",""))="" S X="" F S X=$O(VALM(X)) Q:X="" S ^(X)=VALM(X)
.I $O(^TMP("VALM STACK",$J,VALMEVL,"OTHER VARS",""))="" F X="VALMMENU","VALMCAP","VALMAR","VALMCNT","VALMBG","VALMLST","VALMCC","VALMLFT" S ^(X)=$G(@X)
.K VALMBG,VALM,VALMLFT
;
S VALMEVL=$S($D(VALMEVL):VALMEVL+1,1:0)
I 'VALMEVL D
.F X="VALM DATA","VALM VIDEO","VALM VIDEO SAVE","VALMAR" K ^TMP(X,$J)
.K VALMBG,VALM,VALMLFT
STACKQ Q
;
POP ; -- clean up and unstack vars
K VALMLFT,VALMMENU,VALMCAP,VALMHDR,VALMPGE,VALMUP,VALMDN,VALMDDF,VALMCC,VALMAR,VALMCNT,VALM,VALMBG,VALMLST,LN
K ^TMP("VALM DATA",$J,VALMEVL) D KILL^VALM10()
;
; -- final clean up
I 'VALMEVL D G POPQ
.;D CLEAR^VALM1 ;IHS PATCH #1002
.D:'$G(VALMNOFF) CLEAR^VALM1 K VALMNOFF ;IHS PATCH #1002
.S X=VALMWD X ^%ZOSF("RM")
.S Y=$$IO F I=1:1 S X=$P(Y,";",I) Q:X="" K @X
.K IOBON,IOBOFF,IOSGR0,VALMSGR
.K Y,X,I,VALMEVL,VALMWD,VALMFIND,VALMIOXY,VALMKEY,VALMCON,VALMCOFF,VALMQUIT
.S X="XQORM6" X ^%ZOSF("TEST") D:$T EXIT^XQORM6
;
; -- unstack'em
S VALMEVL=$S(VALMEVL:VALMEVL-1,1:0)
I $O(^TMP("VALM STACK",$J,VALMEVL,"VALM",""))]"" S X="" F S X=$O(^(X)) Q:X="" S VALM(X)=^(X)
I $O(^TMP("VALM STACK",$J,VALMEVL,"OTHER VARS",""))]"" S X="" F S X=$O(^(X)) Q:X="" S @X=^(X)
K ^TMP("VALM STACK",$J,VALMEVL)
D COL^VALM
I $G(^TMP("VALM DATA",$J,VALMEVL,"HIDDEN"))'=$P($G(VALMKEY),U,2) D KEYS^VALM00($G(^("HIDDEN")),1)
S VALMBCK="R",(VALMUP,VALMDN)=""
POPQ Q
;
TEMP(NAME) ; -- use list template
N VALM0,VALM1,NODE
S VALM=+$O(^SD(409.61,"B",NAME,0)),VALM0=$G(^SD(409.61,VALM,0)),VALM1=$G(^(1))
G:VALM0="" TEMPQ
;
F NODE="ARRAY","HDR","EXP","HLP","INIT","FNL" S VALM(NODE)=$G(^SD(409.61,VALM,NODE))
S VALM("IFN")=VALM D COL^VALM
S VALM("TYPE")=$P(VALM0,U,2)
S VALM("TM")=$P(VALM0,U,5)
S VALM("BM")=$P(VALM0,U,6)
S VALM("FIXED")=$S($G(^SD(409.61,VALM("IFN"),"COL",+$O(^SD(409.61,VALM("IFN"),"COL","AIDENT",1,0)),0))]"":$P(^(0),U,2)+$P(^(0),U,3),1:0)
S VALM("RM")=$S($P(VALM0,U,4):$P(VALM0,U,4),1:80)
S VALMCC=+$P(VALM0,U,8)
S VALM("ENTITY")=$P(VALM0,U,9)
S VALM("PROTOCOL")=$P(VALM0,U,10)
S VALM("PRT")=$P(VALM1,U)
S VALM("TITLE")=$S($P(VALM0,U,11)]"":$P(VALM0,U,11),1:$P(VALM0,U))
S VALM("MAX")=$S($P(VALM0,U,12):$P(VALM0,U,12),1:1)
S VALM("DAYS")=$S($P(VALM0,U,13):$P(VALM0,U,13),1:30)
S VALM("DEFS")=$S($P(VALM0,U,14)=0:0,1:1)
S VALM("HIDDEN")=$P(VALM1,U,2)
I VALM("HIDDEN")="",VALM("TYPE")=2 S VALM("HIDDEN")="VALM HIDDEN ACTIONS"
TEMPQ Q VALM0]""
;
CALC ; -- calculate derived parmeters
N NODE,X,I,X,Y
F NODE="HIDDEN","DAYS","EXP","HLP","INIT","FNL" I $G(VALM(NODE))]"" S ^TMP("VALM DATA",$J,VALMEVL,NODE)=VALM(NODE) K VALM(NODE)
S VALMAR=$E(VALM("ARRAY"),2,50) K VALM("ARRAY")
S:VALMAR="" VALMAR="^TMP(""VALMAR"",$J,VALMEVL)"
S VALM("LINES")=(VALM("BM")-VALM("TM"))+1
S:VALM("TM")<3 VALM("TITLE")=" "_VALM("TITLE")
S:VALM("TYPE")=2 VALM("DEFS")=1
; -- set up protocol
S X="VALM DISPLAY" ; default protocol
I VALM("TYPE")=1,VALM("PROTOCOL")]"" S X=VALM("PROTOCOL")
I VALM("TYPE")=2,$D(^TMP("VALM DATA",$J,VALMEVL,"EXP")) S X=X_" W/EXPAND"
S VALM("PROTOCOL")=+$O(^ORD(101,"B",X,0))_";ORD(101,"
;
S (VALMUP,VALMDN)=""
I VALMCC S Y=$$IO F I=1:1 S X=$P(Y,";",I) Q:X="" I $G(@X)="" S VALMCC=0 Q
S VALMCAP=$$CAPTION^VALM D ATR^VALM00
I $G(^TMP("VALM DATA",$J,VALMEVL,"HIDDEN"))'=$P($G(VALMKEY),U,2) D KEYS^VALM00($G(^("HIDDEN")),1)
S:$G(^DISV($S($D(DUZ)#2:DUZ,1:0),"VALMMENU",VALM("PROTOCOL")))="" ^(VALM("PROTOCOL"))=1 S VALMMENU=^(VALM("PROTOCOL"))
Q
;
VALM0 ;MJK/ALB - List Manager (cont.);08:19 PM 17 Jan 1993 [ 07/24/98 9:06 AM ]
+1 ;;1;List Manager;**1001,1002**;Aug 13, 1993
+2 ;IHS/ANMC/LJF 3/5/96 IHS PATCH #1001
+3 ; -- Added code to turn line wrap OFF; needed if WP field was called
+4 ;IHS/ANMC/LJF 5/21/97 IHS PATCH #1002
+5 ; -- Added check for variable VALMNOFF to suppress form feed after
+6 ; last list template. Set VALMNOFF=1 in EXIT subrtn for your
+7 ; list template
+8 ;
INIT(NAME,PARMS) ;
+1 DO STACK
+2 KILL VALMBCK,VALMQUIT,VALMHDR
+3 SET VALM(0)=$GET(PARMS)
+4 IF NAME["^"
IF '$$SETUP^VALM00(.NAME)
SET VALMQUIT=""
GOTO INITQ
+5 IF NAME'["^"
IF '$$TEMP(.NAME)
SET VALMQUIT=""
GOTO INITQ
+6 IF 'VALMEVL
DO TERM
DO CALC
INITQ KILL VALMX,X
QUIT
+1 ;
TERM ; -- set up term characteristics
+1 DO HOME^%ZIS
+2 SET VALMWD=IOM
SET X=$$IO_";IOBON;IOBOFF;IOSGR0"
DO ENDR^%ZISS
+3 ;IHS PATCH #1001
SET X="IOAWM0"
DO ENDR^%ZISS
WRITE IOAWM0
KILL IOAWM0
+4 SET VALMSGR=$SELECT($GET(IOSGR0)]"":IOSGR0,1:$GET(IOINORM))
+5 ; -- cursor off/on to avoid bouncing
+6 SET (VALMCON,VALMCOFF)=""
+7 IF $EXTRACT(IOST,1,4)="C-VT"
SET VALMCOFF=$CHAR(13,27,91)_"?25l"_$CHAR(13)
SET VALMCON=$CHAR(13,27,91)_"?25h"_$CHAR(13)
+8 SET X="XQORM6"
XECUTE ^%ZOSF("TEST")
IF $TEST
DO INIT^XQORM6
+9 SET VALMIOXY=^%ZOSF("XY")
+10 QUIT
+11 ;
IO() ; -- what device params
+1 QUIT "IORVON;IORVOFF;IOIL;IOSTBM;IOSC;IORC;IOEDEOP;IOINHI;IOINORM;IOUON;IOUOFF"
+2 ;
STACK ; -- stack vars
+1 IF $DATA(VALMEVL)
Begin DoDot:1
+2 KILL ^TMP("VALM STACK",$JOB,VALMEVL)
+3 ; -- stack'em
+4 IF $ORDER(^TMP("VALM STACK",$JOB,VALMEVL,"VALM",""))=""
SET X=""
FOR
SET X=$ORDER(VALM(X))
IF X=""
QUIT
SET ^(X)=VALM(X)
+5 IF $ORDER(^TMP("VALM STACK",$JOB,VALMEVL,"OTHER VARS",""))=""
FOR X="VALMMENU","VALMCAP","VALMAR","VALMCNT","VALMBG","VALMLST","VALMCC","VALMLFT"
SET ^(X)=$GET(@X)
+6 KILL VALMBG,VALM,VALMLFT
End DoDot:1
+7 ;
+8 SET VALMEVL=$SELECT($DATA(VALMEVL):VALMEVL+1,1:0)
+9 IF 'VALMEVL
Begin DoDot:1
+10 FOR X="VALM DATA","VALM VIDEO","VALM VIDEO SAVE","VALMAR"
KILL ^TMP(X,$JOB)
+11 KILL VALMBG,VALM,VALMLFT
End DoDot:1
STACKQ QUIT
+1 ;
POP ; -- clean up and unstack vars
+1 KILL VALMLFT,VALMMENU,VALMCAP,VALMHDR,VALMPGE,VALMUP,VALMDN,VALMDDF,VALMCC,VALMAR,VALMCNT,VALM,VALMBG,VALMLST,LN
+2 KILL ^TMP("VALM DATA",$JOB,VALMEVL)
DO KILL^VALM10()
+3 ;
+4 ; -- final clean up
+5 IF 'VALMEVL
Begin DoDot:1
+6 ;D CLEAR^VALM1 ;IHS PATCH #1002
+7 ;IHS PATCH #1002
IF '$GET(VALMNOFF)
DO CLEAR^VALM1
KILL VALMNOFF
+8 SET X=VALMWD
XECUTE ^%ZOSF("RM")
+9 SET Y=$$IO
FOR I=1:1
SET X=$PIECE(Y,";",I)
IF X=""
QUIT
KILL @X
+10 KILL IOBON,IOBOFF,IOSGR0,VALMSGR
+11 KILL Y,X,I,VALMEVL,VALMWD,VALMFIND,VALMIOXY,VALMKEY,VALMCON,VALMCOFF,VALMQUIT
+12 SET X="XQORM6"
XECUTE ^%ZOSF("TEST")
IF $TEST
DO EXIT^XQORM6
End DoDot:1
GOTO POPQ
+13 ;
+14 ; -- unstack'em
+15 SET VALMEVL=$SELECT(VALMEVL:VALMEVL-1,1:0)
+16 IF $ORDER(^TMP("VALM STACK",$JOB,VALMEVL,"VALM",""))]""
SET X=""
FOR
SET X=$ORDER(^(X))
IF X=""
QUIT
SET VALM(X)=^(X)
+17 IF $ORDER(^TMP("VALM STACK",$JOB,VALMEVL,"OTHER VARS",""))]""
SET X=""
FOR
SET X=$ORDER(^(X))
IF X=""
QUIT
SET @X=^(X)
+18 KILL ^TMP("VALM STACK",$JOB,VALMEVL)
+19 DO COL^VALM
+20 IF $GET(^TMP("VALM DATA",$JOB,VALMEVL,"HIDDEN"))'=$PIECE($GET(VALMKEY),U,2)
DO KEYS^VALM00($GET(^("HIDDEN")),1)
+21 SET VALMBCK="R"
SET (VALMUP,VALMDN)=""
POPQ QUIT
+1 ;
TEMP(NAME) ; -- use list template
+1 NEW VALM0,VALM1,NODE
+2 SET VALM=+$ORDER(^SD(409.61,"B",NAME,0))
SET VALM0=$GET(^SD(409.61,VALM,0))
SET VALM1=$GET(^(1))
+3 IF VALM0=""
GOTO TEMPQ
+4 ;
+5 FOR NODE="ARRAY","HDR","EXP","HLP","INIT","FNL"
SET VALM(NODE)=$GET(^SD(409.61,VALM,NODE))
+6 SET VALM("IFN")=VALM
DO COL^VALM
+7 SET VALM("TYPE")=$PIECE(VALM0,U,2)
+8 SET VALM("TM")=$PIECE(VALM0,U,5)
+9 SET VALM("BM")=$PIECE(VALM0,U,6)
+10 SET VALM("FIXED")=$SELECT($GET(^SD(409.61,VALM("IFN"),"COL",+$ORDER(^SD(409.61,VALM("IFN"),"COL","AIDENT",1,0)),0))]"":$PIECE(^(0),U,2)+$PIECE(^(0),U,3),1:0)
+11 SET VALM("RM")=$SELECT($PIECE(VALM0,U,4):$PIECE(VALM0,U,4),1:80)
+12 SET VALMCC=+$PIECE(VALM0,U,8)
+13 SET VALM("ENTITY")=$PIECE(VALM0,U,9)
+14 SET VALM("PROTOCOL")=$PIECE(VALM0,U,10)
+15 SET VALM("PRT")=$PIECE(VALM1,U)
+16 SET VALM("TITLE")=$SELECT($PIECE(VALM0,U,11)]"":$PIECE(VALM0,U,11),1:$PIECE(VALM0,U))
+17 SET VALM("MAX")=$SELECT($PIECE(VALM0,U,12):$PIECE(VALM0,U,12),1:1)
+18 SET VALM("DAYS")=$SELECT($PIECE(VALM0,U,13):$PIECE(VALM0,U,13),1:30)
+19 SET VALM("DEFS")=$SELECT($PIECE(VALM0,U,14)=0:0,1:1)
+20 SET VALM("HIDDEN")=$PIECE(VALM1,U,2)
+21 IF VALM("HIDDEN")=""
IF VALM("TYPE")=2
SET VALM("HIDDEN")="VALM HIDDEN ACTIONS"
TEMPQ QUIT VALM0]""
+1 ;
CALC ; -- calculate derived parmeters
+1 NEW NODE,X,I,X,Y
+2 FOR NODE="HIDDEN","DAYS","EXP","HLP","INIT","FNL"
IF $GET(VALM(NODE))]""
SET ^TMP("VALM DATA",$JOB,VALMEVL,NODE)=VALM(NODE)
KILL VALM(NODE)
+3 SET VALMAR=$EXTRACT(VALM("ARRAY"),2,50)
KILL VALM("ARRAY")
+4 IF VALMAR=""
SET VALMAR="^TMP(""VALMAR"",$J,VALMEVL)"
+5 SET VALM("LINES")=(VALM("BM")-VALM("TM"))+1
+6 IF VALM("TM")<3
SET VALM("TITLE")=" "_VALM("TITLE")
+7 IF VALM("TYPE")=2
SET VALM("DEFS")=1
+8 ; -- set up protocol
+9 ; default protocol
SET X="VALM DISPLAY"
+10 IF VALM("TYPE")=1
IF VALM("PROTOCOL")]""
SET X=VALM("PROTOCOL")
+11 IF VALM("TYPE")=2
IF $DATA(^TMP("VALM DATA",$JOB,VALMEVL,"EXP"))
SET X=X_" W/EXPAND"
+12 SET VALM("PROTOCOL")=+$ORDER(^ORD(101,"B",X,0))_";ORD(101,"
+13 ;
+14 SET (VALMUP,VALMDN)=""
+15 IF VALMCC
SET Y=$$IO
FOR I=1:1
SET X=$PIECE(Y,";",I)
IF X=""
QUIT
IF $GET(@X)=""
SET VALMCC=0
QUIT
+16 SET VALMCAP=$$CAPTION^VALM
DO ATR^VALM00
+17 IF $GET(^TMP("VALM DATA",$JOB,VALMEVL,"HIDDEN"))'=$PIECE($GET(VALMKEY),U,2)
DO KEYS^VALM00($GET(^("HIDDEN")),1)
+18 IF $GET(^DISV($SELECT($DATA(DUZ)#2
SET ^(VALM("PROTOCOL"))=1
SET VALMMENU=^(VALM("PROTOCOL"))
+19 QUIT
+20 ;
