XUS5 ;SF-ISC/STAFF - RESUME LOGIC FOR CONTINUE ;2/5/08 15:34
;;8.0;KERNEL;**313,741**;Jul 10, 1995;Build 1
;;;;Per VHA Directive 6402, this routine should not be modified.
;
S %=^XUTL("XQ",$J,"XQM"),XQSV=%_U_%_U_$S($D(^XUTL("XQO","P"_%,"^",%)):$P(^(%),U,2,99),1:^DIC(19,%,0))
G JUMP^XQ72
;
CONT D ABT^XQ12
C1 S XQY=^VA(200,DUZ,201),^XUTL("XQ",$J,"XQM")=XQY,^("T")=1
S XQY0=$S($D(^XUTL("XQO","P"_XQY,"^",XQY)):$P(^(XQY),U,2,99),1:"") I XQY0="" D S1^XQCHK
S XQCY=XQY D ^XQCHK I XQCY<1 S XQPRMN=1,XQL=0 D MES^XQCHK,PAUSE^XQ6 G ^XUSCLEAN
S XQDIC="P"_XQY,^XUTL("XQ",$J,1)=XQY_XQDIC_U_XQY0
I $P(XQY0,U,14),$D(^DIC(19,XQY,20)),$L(^(20)) X ^(20)
I $D(XQUIT) W !!,"==> The variable XQUIT encountered in the Entry Action of your Primary Menu.",*7 S XQL=0 D PAUSE^XQ6 G ^XUSCLEAN
I $P(XQY0,U,18),$D(^DIC(19,XQY,26)),$L(^(26)) X ^(26)
S XQA=0 Q:'$D(^VA(200,DUZ,202.1))
S %=^(202.1) K ^VA(200,DUZ,202.1) S XQY=+%,XQPSM=$P(%,XQY,2),XQDIC=$S(XQPSM[",":$P(XQPSM,",",2),1:XQPSM)
S XQCY=XQY D ^XQCHK I 'XQCY K XQCY,XQCY0 D NOGO Q
I $E(XQDIC,1)="U" D:$S('$D(^XUTL("XQO",XQDIC,0)):1,'$D(^VA(200,DUZ,203.1)):1,1:^VA(200,DUZ,203.1)'=$P(^XUTL("XQO",XQDIC,0),U,2)) ^XQSET
I $E(XQDIC,1)="P",XQDIC'="PXU" I $S('$D(^XUTL("XQO",XQDIC,0)):1,'$D(^DIC(19,$E(XQDIC,2,99),99.1)):1,1:0) S XQCON="" D NOGO Q
I XQDIC="PXU" S %=$O(^DIC(19,"B","XUCOMMAND",0)) I $S('$D(^XUTL("XQO",XQDIC,0)):1,'$D(^DIC(19,%,99.1)):1,1:0) S XQCON="" D NOGO Q
I '$D(^XUTL("XQO",XQDIC,"^",XQY)) D NOGO Q
W !!,"You were last executing the '",$P(^XUTL("XQO",XQDIC,"^",XQY),U,3),"' menu option."
ASK W !,"Do you wish to resume" S %=1 D YN^DICN I '% W !!,"If you wish to continue at the last option you were executing, enter 'Y',",! G ASK
I %=1 S XQA=1,XQY0=$P(^XUTL("XQO",XQDIC,"^",XQY),U,2,99)
E D NOGO Q
I $D(^XUTL("XQO",XQDIC,"^",XQY,0)) S XQ=^(0) F XQI=1:1:XQ S XQ(XQI)=$P(^XUTL("XQO",XQDIC,"^",XQY,0,XQI),U)
E S XQ=0
Q
;
NOGO ;Continue fails: reset primary menu
S XQY=^XUTL("XQ",$J,"XQM"),XQA3="",XQA=0 K XQCON,XQRE
Q
;
EUC ; EDIT USER CHARACTERISTIC
N Y,XUDEV,XUIOP,IOP,DR,DIE,DA,DUOUT
S Y=0,XUDEV=$G(^XUTL("XQ",$J,"IOS"))
I $D(^VA(200,DUZ,1.2))[0 S ^(1.2)=IOST(0)
K XUIOP(1) D:'$D(ION) HOME^%ZIS S:'($D(XUIOP)#2) XUIOP=ION
I $D(^VA(200,DUZ,1.2))#2,$D(^%ZIS(2,+^(1.2),0)) S $P(XUIOP,";",2)=$P(^(0),U)
D TT^XUS3 G ECX:$D(DUOUT)!$D(DTOUT)
S POP=1,X=+$G(^VA(200,DUZ,1.2))
I X'=$G(^XUTL("XQ",$J,"IOST(0)")) S IOP=$S($D(^XUTL("XQ",$J,"ION")):^("ION"),1:"HOME")_";"_$P($G(^%ZIS(2,X,0)),"^"),%ZIS="M" D ^%ZIS
I 'POP S ^VA(200,DUZ,1.2)=IOST(0) D SAVE^XUS1
S DR="["_$$GET^XUPARAM("XUEDIT CHARACTERISTICS","N")_"]"
S DIE="^VA(200,",DA=DUZ D XUDIE
ECX S X=$P($G(^VA(200,DUZ,200)),U,6),DUZ("AUTO")=$S(X'="":X,1:DUZ("AUTO")),X=$P($G(^(200)),U,9) I X'="" S DUZ("BUF")=(X["Y"),X=$S(DUZ("BUF"):"",1:"NO-")_"TYPE-AHEAD" X:$D(^%ZOSF(X)) ^%ZOSF(X)
;DUZ("LANG")
K X
Q
VIRTUAL ;
N X,Y,DIC
S X=$S($D(^%ZOSF("VOL")):^("VOL")_$I,1:$E($I,2,99)),DIC=3.5,DIC(0)="ML",DIC("DR")="1///"_$I_";1.9////"_$S($D(^%ZOSF("VOL")):^("VOL"),1:"")_";4////1;5////1;2////TRM;.02////"_$I D ^DIC K DIR,DR Q:Y<0 S XUDEV=+Y
Q
;Called from several places.
XUDIE ; Check and see if need a DDS or a DIE call
N J,XUDIE,DDSFILE,DIMSG
S:+DIE DIE=^DIC(+DIE,0,"GL") S J=$S($E(DR)="[":$E(DR,2,$L(DR)-1),1:""),XUDIE=DIE_(+DA)_",0)"
L +@XUDIE:2 I '$T W !,"Record in use by someone else." Q
I $G(^VA(200,DUZ,508))=1 D ^DIE G XUDIEX ; P741 check for disability users
I J]"",IOST["C-",$D(^DIST(.403,"B",J)) S DDSFILE=DIE D ^DDS G:'$D(DIMSG) XUDIEX
K DIMSG D ^DIE
XUDIEX ;
D CALL^XUSERP(+DA,2) ;Call XQOR
L -@XUDIE Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUS5 3625 printed Nov 22, 2024@17:22:06 Page 2
XUS5 ;SF-ISC/STAFF - RESUME LOGIC FOR CONTINUE ;2/5/08 15:34
+1 ;;8.0;KERNEL;**313,741**;Jul 10, 1995;Build 1
+2 ;;;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 SET %=^XUTL("XQ",$JOB,"XQM")
SET XQSV=%_U_%_U_$SELECT($DATA(^XUTL("XQO","P"_%,"^",%)):$PIECE(^(%),U,2,99),1:^DIC(19,%,0))
+5 GOTO JUMP^XQ72
+6 ;
CONT DO ABT^XQ12
C1 SET XQY=^VA(200,DUZ,201)
SET ^XUTL("XQ",$JOB,"XQM")=XQY
SET ^("T")=1
+1 SET XQY0=$SELECT($DATA(^XUTL("XQO","P"_XQY,"^",XQY)):$PIECE(^(XQY),U,2,99),1:"")
IF XQY0=""
DO S1^XQCHK
+2 SET XQCY=XQY
DO ^XQCHK
IF XQCY<1
SET XQPRMN=1
SET XQL=0
DO MES^XQCHK
DO PAUSE^XQ6
GOTO ^XUSCLEAN
+3 SET XQDIC="P"_XQY
SET ^XUTL("XQ",$JOB,1)=XQY_XQDIC_U_XQY0
+4 IF $PIECE(XQY0,U,14)
IF $DATA(^DIC(19,XQY,20))
IF $LENGTH(^(20))
XECUTE ^(20)
+5 IF $DATA(XQUIT)
WRITE !!,"==> The variable XQUIT encountered in the Entry Action of your Primary Menu.",*7
SET XQL=0
DO PAUSE^XQ6
GOTO ^XUSCLEAN
+6 IF $PIECE(XQY0,U,18)
IF $DATA(^DIC(19,XQY,26))
IF $LENGTH(^(26))
XECUTE ^(26)
+7 SET XQA=0
if '$DATA(^VA(200,DUZ,202.1))
QUIT
+8 SET %=^(202.1)
KILL ^VA(200,DUZ,202.1)
SET XQY=+%
SET XQPSM=$PIECE(%,XQY,2)
SET XQDIC=$SELECT(XQPSM[",":$PIECE(XQPSM,",",2),1:XQPSM)
+9 SET XQCY=XQY
DO ^XQCHK
IF 'XQCY
KILL XQCY,XQCY0
DO NOGO
QUIT
+10 IF $EXTRACT(XQDIC,1)="U"
if $SELECT('$DATA(^XUTL("XQO",XQDIC,0))
DO ^XQSET
+11 IF $EXTRACT(XQDIC,1)="P"
IF XQDIC'="PXU"
IF $SELECT('$DATA(^XUTL("XQO",XQDIC,0)):1,'$DATA(^DIC(19,$EXTRACT(XQDIC,2,99),99.1)):1,1:0)
SET XQCON=""
DO NOGO
QUIT
+12 IF XQDIC="PXU"
SET %=$ORDER(^DIC(19,"B","XUCOMMAND",0))
IF $SELECT('$DATA(^XUTL("XQO",XQDIC,0)):1,'$DATA(^DIC(19,%,99.1)):1,1:0)
SET XQCON=""
DO NOGO
QUIT
+13 IF '$DATA(^XUTL("XQO",XQDIC,"^",XQY))
DO NOGO
QUIT
+14 WRITE !!,"You were last executing the '",$PIECE(^XUTL("XQO",XQDIC,"^",XQY),U,3),"' menu option."
ASK WRITE !,"Do you wish to resume"
SET %=1
DO YN^DICN
IF '%
WRITE !!,"If you wish to continue at the last option you were executing, enter 'Y',",!
GOTO ASK
+1 IF %=1
SET XQA=1
SET XQY0=$PIECE(^XUTL("XQO",XQDIC,"^",XQY),U,2,99)
+2 IF '$TEST
DO NOGO
QUIT
+3 IF $DATA(^XUTL("XQO",XQDIC,"^",XQY,0))
SET XQ=^(0)
FOR XQI=1:1:XQ
SET XQ(XQI)=$PIECE(^XUTL("XQO",XQDIC,"^",XQY,0,XQI),U)
+4 IF '$TEST
SET XQ=0
+5 QUIT
+6 ;
NOGO ;Continue fails: reset primary menu
+1 SET XQY=^XUTL("XQ",$JOB,"XQM")
SET XQA3=""
SET XQA=0
KILL XQCON,XQRE
+2 QUIT
+3 ;
EUC ; EDIT USER CHARACTERISTIC
+1 NEW Y,XUDEV,XUIOP,IOP,DR,DIE,DA,DUOUT
+2 SET Y=0
SET XUDEV=$GET(^XUTL("XQ",$JOB,"IOS"))
+3 IF $DATA(^VA(200,DUZ,1.2))[0
SET ^(1.2)=IOST(0)
+4 KILL XUIOP(1)
if '$DATA(ION)
DO HOME^%ZIS
if '($DATA(XUIOP)#2)
SET XUIOP=ION
+5 IF $DATA(^VA(200,DUZ,1.2))#2
IF $DATA(^%ZIS(2,+^(1.2),0))
SET $PIECE(XUIOP,";",2)=$PIECE(^(0),U)
+6 DO TT^XUS3
if $DATA(DUOUT)!$DATA(DTOUT)
GOTO ECX
+7 SET POP=1
SET X=+$GET(^VA(200,DUZ,1.2))
+8 IF X'=$GET(^XUTL("XQ",$JOB,"IOST(0)"))
SET IOP=$SELECT($DATA(^XUTL("XQ",$JOB,"ION")):^("ION"),1:"HOME")_";"_$PIECE($GET(^%ZIS(2,X,0)),"^")
SET %ZIS="M"
DO ^%ZIS
+9 IF 'POP
SET ^VA(200,DUZ,1.2)=IOST(0)
DO SAVE^XUS1
+10 SET DR="["_$$GET^XUPARAM("XUEDIT CHARACTERISTICS","N")_"]"
+11 SET DIE="^VA(200,"
SET DA=DUZ
DO XUDIE
ECX SET X=$PIECE($GET(^VA(200,DUZ,200)),U,6)
SET DUZ("AUTO")=$SELECT(X'="":X,1:DUZ("AUTO"))
SET X=$PIECE($GET(^(200)),U,9)
IF X'=""
SET DUZ("BUF")=(X["Y")
SET X=$SELECT(DUZ("BUF"):"",1:"NO-")_"TYPE-AHEAD"
if $DATA(^%ZOSF(X))
XECUTE ^%ZOSF(X)
+1 ;DUZ("LANG")
+2 KILL X
+3 QUIT
VIRTUAL ;
+1 NEW X,Y,DIC
+2 SET X=$SELECT($DATA(^%ZOSF("VOL")):^("VOL")_$IO,1:$EXTRACT($IO,2,99))
SET DIC=3.5
SET DIC(0)="ML"
SET DIC("DR")="1///"_$IO_";1.9////"_$SELECT($DATA(^%ZOSF("VOL")):^("VOL"),1:"")_";4////1;5////1;2////TRM;.02////"_$IO
DO ^DIC
KILL DIR,DR
if Y<0
QUIT
SET XUDEV=+Y
+3 QUIT
+4 ;Called from several places.
XUDIE ; Check and see if need a DDS or a DIE call
+1 NEW J,XUDIE,DDSFILE,DIMSG
+2 if +DIE
SET DIE=^DIC(+DIE,0,"GL")
SET J=$SELECT($EXTRACT(DR)="[":$EXTRACT(DR,2,$LENGTH(DR)-1),1:"")
SET XUDIE=DIE_(+DA)_",0)"
+3 LOCK +@XUDIE:2
IF '$TEST
WRITE !,"Record in use by someone else."
QUIT
+4 ; P741 check for disability users
IF $GET(^VA(200,DUZ,508))=1
DO ^DIE
GOTO XUDIEX
+5 IF J]""
IF IOST["C-"
IF $DATA(^DIST(.403,"B",J))
SET DDSFILE=DIE
DO ^DDS
if '$DATA(DIMSG)
GOTO XUDIEX
+6 KILL DIMSG
DO ^DIE
XUDIEX ;
+1 ;Call XQOR
DO CALL^XUSERP(+DA,2)
+2 LOCK -@XUDIE
QUIT
