VALM2 ;ALB/MJK - List Manager Utilities;08:52 PM 17 Jan 1993 ;02/01/2001 11:43
;;1.0;List Manager;**6,10**;Aug 13, 1993;Build 10
SEL ; -- select w/XQORNOD(0) defined
D EN(XQORNOD(0)) Q
EN(VALMNOD,VALMDIR) ; -- generic selector
; input passed: VALMNOD := var in XQORNOD(0) format
N Y,BG,LST,VALMOUT,INDEX
K VALMY
I '$D(VALMDIR) N VALMDIR S VALMDIR=""
S BG=+$O(@VALMAR@("IDX",VALMBG,0))
S LST=+$O(@VALMAR@("IDX",VALMLST,0))
I BG,BG=LST,$P($P(VALMNOD,U,4),"=",2)="",VALMDIR'["O" S VALMY(BG)="" Q ; -- only one entry
I 'BG D Q
. W !!,$C(7),"There are no '",VALM("ENTITY"),"s' to select.",!
. D WAIT^VALM1
. D OUT
S Y=$$PARSE(.VALMNOD,.BG,.LST)
I 'Y D Q:$G(VALMOUT)
. N DIR,X,DIRUT,DTOUT,DUOUT,DIROUT
. S DIR(0)=$S(VALMDIR'["S":"L",1:"N")_$S(VALMDIR["O":"O",1:"")_"^"_BG_":"_LST
. S DIR("A")="Select "_VALM("ENTITY")_$S(VALMDIR["S":"",1:"(s)")
. D ^DIR I $D(DIRUT) D OUT S VALMOUT=1
; -- check was valid entries
I $G(Y(0))="" S Y(0)=Y
S INDEX=""
F S INDEX=$O(Y(INDEX)) Q:INDEX="" D
. F I=1:1 S X=$P(Y(INDEX),",",I) Q:'X D
. . I '$O(@VALMAR@("IDX",X,0))!(X<BG)!(X>LST) D
. . . W !,$C(7),">>> Selection '",X,"' is not a valid choice."
. . . S VALMOUT=1
. I $G(VALMOUT) D WAIT^VALM1 Q
. F I=1:1 S X=$P(Y(INDEX),",",I) Q:'X S VALMY(X)=""
Q
PARSE(VALMNOD,BEG,END) ; -- split out pre-answers from user
N Y,J,L,X
S Y=$TR($P($P(VALMNOD,U,4),"=",2),"/\; .",",,,,,")
I Y["-" S X=Y,Y="" F I=1:1 S J=$P(X,",",I) Q:J']"" I +J>(BEG-1),+J<(END+1) S:J'["-" Y=Y_J_"," I J["-",+J,+J<+$P(J,"-",2) F L=+J:1:+$P(J,"-",2) I L>(BEG-1),L<(END+1) S Y=Y_L_","
Q Y
OUT ; -- set variables to quit
S VALMBCK=$S(VALMCC:"",1:"R")
Q
N VALMX,DIR,X ;,Y,DIRUT,DUOUT,DTOUT,DIROUT calling app may check?
S VALMX=$G(^DISV($S($D(DUZ)#2:DUZ,1:0),"VALMMENU",VALM("PROTOCOL"))) S:VALMX="" (VALMX,^(VALM("PROTOCOL")))=1
W ! S DIR(0)="Y",DIR("A")="Do you wish to turn auto-display "_$S(VALMX:"'OFF'",1:"'ON'")_" for this menu",DIR("B")="NO"
D ^DIR
I Y S (VALMMENU,^DISV($S($D(DUZ)#2:DUZ,1:0),"VALMMENU",VALM("PROTOCOL")))='VALMX
D FINISH^VALM4
Q
HELP ; -- help entry point
N VALMANS,VALMHLP,DIR,DIRUT,DUOUT,DTOUT ; ^XQORM1 checks DIROUT
S VALMANS=X N X ; save answer
S VALMHLP=$G(^TMP("VALM DATA",$J,VALMEVL,"HLP")),X=VALMANS
I VALMHLP="" D
. I VALM("TYPE")=2 S VALMANS="??" Q
. S X="?" D DISP^XQORM1,PAUSE^VALM1
E D
. X VALMHLP
I $P($G(VALMKEY),U,2)]"",VALMANS["??" D:'$D(DIRUT) FULL^VALM1,KEYS,PAUSE^VALM1 S VALMBCK="R"
D:$G(VALMBCK)="R" REFRESH^VALM K VALMBCK
D:VALMCC RESET^VALM4
D SHOW^VALM W !
Q
KEYS ; -- hidden key help
W !,"The following actions are also available:"
N XQORM,ORULT S XQORM=$O(^ORD(101,"B",$P(VALMKEY,U,2),0))_";ORD(101,"
I '$D(^XUTL("XQORM",XQORM)) D XREF^XQORM K ORULT ; build ^XUTL nodes
D DISP^XQORM1:XQORM
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVALM2 2872 printed Oct 16, 2024@18:10:48 Page 2
VALM2 ;ALB/MJK - List Manager Utilities;08:52 PM 17 Jan 1993 ;02/01/2001 11:43
+1 ;;1.0;List Manager;**6,10**;Aug 13, 1993;Build 10
SEL ; -- select w/XQORNOD(0) defined
+1 DO EN(XQORNOD(0))
QUIT
EN(VALMNOD,VALMDIR) ; -- generic selector
+1 ; input passed: VALMNOD := var in XQORNOD(0) format
+2 NEW Y,BG,LST,VALMOUT,INDEX
+3 KILL VALMY
+4 IF '$DATA(VALMDIR)
NEW VALMDIR
SET VALMDIR=""
+5 SET BG=+$ORDER(@VALMAR@("IDX",VALMBG,0))
+6 SET LST=+$ORDER(@VALMAR@("IDX",VALMLST,0))
+7 ; -- only one entry
IF BG
IF BG=LST
IF $PIECE($PIECE(VALMNOD,U,4),"=",2)=""
IF VALMDIR'["O"
SET VALMY(BG)=""
QUIT
+8 IF 'BG
Begin DoDot:1
+9 WRITE !!,$CHAR(7),"There are no '",VALM("ENTITY"),"s' to select.",!
+10 DO WAIT^VALM1
+11 DO OUT
End DoDot:1
QUIT
+12 SET Y=$$PARSE(.VALMNOD,.BG,.LST)
+13 IF 'Y
Begin DoDot:1
+14 NEW DIR,X,DIRUT,DTOUT,DUOUT,DIROUT
+15 SET DIR(0)=$SELECT(VALMDIR'["S":"L",1:"N")_$SELECT(VALMDIR["O":"O",1:"")_"^"_BG_":"_LST
+16 SET DIR("A")="Select "_VALM("ENTITY")_$SELECT(VALMDIR["S":"",1:"(s)")
+17 DO ^DIR
IF $DATA(DIRUT)
DO OUT
SET VALMOUT=1
End DoDot:1
if $GET(VALMOUT)
QUIT
+18 ; -- check was valid entries
+19 IF $GET(Y(0))=""
SET Y(0)=Y
+20 SET INDEX=""
+21 FOR
SET INDEX=$ORDER(Y(INDEX))
if INDEX=""
QUIT
Begin DoDot:1
+22 FOR I=1:1
SET X=$PIECE(Y(INDEX),",",I)
if 'X
QUIT
Begin DoDot:2
+23 IF '$ORDER(@VALMAR@("IDX",X,0))!(X<BG)!(X>LST)
Begin DoDot:3
+24 WRITE !,$CHAR(7),">>> Selection '",X,"' is not a valid choice."
+25 SET VALMOUT=1
End DoDot:3
End DoDot:2
+26 IF $GET(VALMOUT)
DO WAIT^VALM1
QUIT
+27 FOR I=1:1
SET X=$PIECE(Y(INDEX),",",I)
if 'X
QUIT
SET VALMY(X)=""
End DoDot:1
+28 QUIT
PARSE(VALMNOD,BEG,END) ; -- split out pre-answers from user
+1 NEW Y,J,L,X
+2 SET Y=$TRANSLATE($PIECE($PIECE(VALMNOD,U,4),"=",2),"/\; .",",,,,,")
+3 IF Y["-"
SET X=Y
SET Y=""
FOR I=1:1
SET J=$PIECE(X,",",I)
if J']""
QUIT
IF +J>(BEG-1)
IF +J<(END+1)
if J'["-"
SET Y=Y_J_","
IF J["-"
IF +J
IF +J<+$PIECE(J,"-",2)
FOR L=+J:1:+$PIECE(J,"-",2)
IF L>(BEG-1)
IF L<(END+1)
SET Y=Y_L_","
+4 QUIT Y
OUT ; -- set variables to quit
+1 SET VALMBCK=$SELECT(VALMCC:"",1:"R")
+2 QUIT
+1 ;,Y,DIRUT,DUOUT,DTOUT,DIROUT calling app may check?
NEW VALMX,DIR,X
+2 SET VALMX=$GET(^DISV($SELECT($DATA(DUZ)#2:DUZ,1:0),"VALMMENU",VALM("PROTOCOL")))
if VALMX=""
SET (VALMX,^(VALM("PROTOCOL")))=1
+3 WRITE !
SET DIR(0)="Y"
SET DIR("A")="Do you wish to turn auto-display "_$SELECT(VALMX:"'OFF'",1:"'ON'")_" for this menu"
SET DIR("B")="NO"
+4 DO ^DIR
+5 IF Y
SET (VALMMENU,^DISV($SELECT($DATA(DUZ)#2:DUZ,1:0),"VALMMENU",VALM("PROTOCOL")))='VALMX
+6 DO FINISH^VALM4
+7 QUIT
HELP ; -- help entry point
+1 ; ^XQORM1 checks DIROUT
NEW VALMANS,VALMHLP,DIR,DIRUT,DUOUT,DTOUT
+2 ; save answer
SET VALMANS=X
NEW X
+3 SET VALMHLP=$GET(^TMP("VALM DATA",$JOB,VALMEVL,"HLP"))
SET X=VALMANS
+4 IF VALMHLP=""
Begin DoDot:1
+5 IF VALM("TYPE")=2
SET VALMANS="??"
QUIT
+6 SET X="?"
DO DISP^XQORM1
DO PAUSE^VALM1
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 XECUTE VALMHLP
End DoDot:1
+9 IF $PIECE($GET(VALMKEY),U,2)]""
IF VALMANS["??"
if '$DATA(DIRUT)
DO FULL^VALM1
DO KEYS
DO PAUSE^VALM1
SET VALMBCK="R"
+10 if $GET(VALMBCK)="R"
DO REFRESH^VALM
KILL VALMBCK
+11 if VALMCC
DO RESET^VALM4
+12 DO SHOW^VALM
WRITE !
+13 QUIT
KEYS ; -- hidden key help
+1 WRITE !,"The following actions are also available:"
+2 NEW XQORM,ORULT
SET XQORM=$ORDER(^ORD(101,"B",$PIECE(VALMKEY,U,2),0))_";ORD(101,"
+3 ; build ^XUTL nodes
IF '$DATA(^XUTL("XQORM",XQORM))
DO XREF^XQORM
KILL ORULT
+4 if XQORM
DO DISP^XQORM1
+5 QUIT
