- 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 Feb 18, 2025@23:38:24 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