XUS1 ;SF-ISC/STAFF - SIGNON ;09/23/14 16:06
;;8.0;KERNEL;**9,59,111,165,150,252,265,419,469,523,543,638,1007,1018**;Jul 10, 1995;Build 8
;THIS ROUTINE CONTAINS IHS MODIFICATIONS
;User setup
USER ;
K XUTEXT S XUM=$$USER^XUS1A(),$Y=0
;Show post sign-on text
F I=0:0 S I=$O(XUTEXT(I)) Q:I'>0 D:$Y>20 W:$E(XUTEXT(I),1)="!" ! W $E(XUTEXT(I),2,999)
. N DIR S DIR(0)="E",DIR("A")="Enter RETURN to continue" D ^DIR W @IOF Q
;if XUM=9 multi sign-on NOT allowed
I XUM=9 W !!,?8,$$EZBLD^DIALOG(30810.45)
Q:XUM ;User can't sign-on.
SET ;
S Y=$$CHKDIV()
I $P(Y,U,2)>0,$D(^DIC(4,0)) D ASKDIV
;----- BEGIN IHS MODIFICATION - XU*8.0*1007
;Modified by IHS/DSD/AEF 10/07/02 based on original midification by
;IHS/HQW/MFD 12/14/1997
;Add 2 lines to make sure Y is set to a division and display the
;division
I 'Y S Y=+$$IHSDIV(DUZ)
I Y W !,"Site set to ",$P($G(^DIC(4,+Y,0)),U),!
;----- END IHS MODIFICATION
S DUZ(2)=+Y D DUZ^XUS1A
;Check verify code
I $$VCHG D CVC^XUS2 G:$D(DUOUT) H^XUS
S:$P(XOPT,"^",5) XUTT=1 ;Ask Device
D ENQ ;Inquire to Terminal Type
Q
;
VCHG() ;Check if the Verify code needs to be changed
I $D(DUZ("ASH")) Q 0 ;p403
D:'$D(XUSER) USER^XUS(DUZ)
Q:'$L($P(XUSER(1),U,2)) 1 ;Null VC
I $$BROKER^XWBLIB Q:$P(XUSER(0),U,8)=1 0 ;VC never expires, only for BROKER
Q (XUSER(1)+$P(XOPT,U,15))'>$H ;Time to change
;
ASKDIV ;Ask the user for the Division, return Y
N X
;----- BEGIN IHS MODIFICATION - XU*8.0*1007
;Modified by IHS/DSD/AEF 10/07/02 based on original modification by
;IHS/HQW/MFD 12/14/1997
;This line is commented out and replaced by the line below. This
;modified line ensures that the default division is set.
;S DIC="^VA(200,DUZ,2,",DIC(0)="AEQ",DIC("P")="200.02P",X=$O(^VA(200,DUZ,2,"AX1",1,0)) S:X>0 DIC("B")=$P($$NS^XUAF4(X),U)
S DIC="^VA(200,DUZ,2,",DIC(0)="AEMQ",DIC("P")="200.02P",DIC("B")=$P($$IHSDIV(DUZ),U,2)
;----- END IHS MODIFICATION
D ^DIC I Y'>0 W !,*7,"You must select one." G ASKDIV
Q
;
CHKDIV(CD) ;ef,sr Check if user needs to select Division.
N %,%1,%2,%3,%4
I $G(DUZ("DIV"))>0 Q DUZ("DIV") ;p469 Set outside
S %=$O(^VA(200,DUZ,2,0)),%1=$O(^(%))
I %1,$D(CD) D
. S %2=0,%3=0,CD=0
. F S %2=$O(^VA(200,DUZ,2,%2)) Q:%2'>0 S %4=^(%2,0),%3=%3+1,CD(%3)=%2_"^"_$$NS^XUAF4(%2)_$S($P(%4,"^",2):"^1",1:"")
. S CD=%3
Q %_"^"_%1
;
ENQ ;Get terminal type
S XUT1="" I XUTT X XUEOFF R X:0 X ^%ZOSF("TYPE-AHEAD") W $C(27,91,99) X "R *X:2 I X=27 F R X#1:2 S XUT1=XUT1_X Q:'$T!(X=""c"")"
;Removed code for Wyse 75
X XUEON I XUTT,XUT1["[" S Y=$O(^%ZIS(3.22,"B",XUT1,0)) I Y>0 S X=$P($G(^%ZIS(3.22,Y,0)),"^",2)
I X?1.ANP S DIC="^%ZIS(2,",DIC(0)="MO" D ^DIC I Y>0 S XUIOP(1)=$P(Y,U,2),$P(XUIOP,";",2)=XUIOP(1),^VA(200,DUZ,1.2)=+Y
I '$D(XUIOP(1)),$D(^VA(200,DUZ,1.2)) S X=+^(1.2) I X>0,$D(^%ZIS(2,X,0)) S $P(XUIOP,";",2)=$P(^(0),U)
Q
;
NEXT ;Jump to the next routine
S IOP=XUIOP D ^%ZIS D SAVE ;Save off device/user info
S X=$G(^DISV(DUZ)) ;Add kill by session or day here
S ^DISV(DUZ)=$H
;Removed UCI jump p469
D AUDIT
S X=$S($D(^VA(200,DUZ,0)):$P($P(^(0),U),","),1:"Unk"),X=$E(X,1,10)_"_"_($J#10000) D SETENV^%ZOSV ;Set Process Name
;S X=$P(XOPT,U,16) X:X ^%ZOSF("PRIORITY")
D LOG:DUZ,KILL
K ^XUTL("OR",$J),^UTILITY($J),%UCI
G ^XQ
;
SAVE ;
N X
S X="DUZ" F S X=$Q(@X) Q:X="" I $D(@X) S ^XUTL("XQ",$J,$TR(X,""""))=@X
F X="DUZ","IO","IO(""IP"")","IO(""CLNM"")","XQVOL" I $D(@X) S ^XUTL("XQ",$J,X)=@X
D SAVEVAR^%ZIS ;Save the HOME device variables
Q
;
LOG ;used by R/S and Broker
N %,XP1,XP2
S XQXFLG("LLOG")=$P($G(^VA(200,DUZ,1.1)),U) ;Save for LOGIN templates
S XP1=$$SLOG($P(XUVOL,U,1),,XUDEV,XUCI,$P(XUENV,U,3))
S %=$$COOKIE($P(^VA(200,DUZ,0),U),XP1) I $L(%) S XQXFLG("ZEBRA")=XP1_"~"_%,$P(^XUSEC(0,XP1,0),U,13)=% L +^XWB("SESSION",XQXFLG("ZEBRA")):60
Q
;
;Division updated in DIVSET^XUSRB2
;The other parameters are in the symbol table with known names.
;P1=DUZ,P2=$I,P3=$J,P4=EXIT D/T,P5=VOLUME,P6=TASKMAN,P7=XUDEV,P8=UCI,P9=ZIO,P10=NODE,P11=IPV4,P12=CLNM,P13=HANDLE,P14=REMOTE SITE,P15=REMOTE IEN
SLOG(P5,P6,P7,P8,P10,P14,P15) ;
;p638 Changes: Save IPv4 address in field 11 (0;11) and IPv6 address in field 100 (1;1)
N %,I,DA,DIK,N,XL1,XL2,P11,P12,P100
S XL1=$$NOW^XLFDT
S P5=$G(P5),P6=$G(P6),P7=$G(P7),P8=$G(P8),P10=$P($G(P10),".")
S P11=$$FORCEIP4^XLFIPV($G(IO("IP"))),P12=$P($G(IO("CLNM")),"."),P100=$$FORCEIP6^XLFIPV($G(IO("IP")))
I P11="0.0.0.0" S P11="" ;Do not store null IPv4 address
I P100="0000:0000:0000:0000:0000:0000:0000:0000" S P100="" ;Do not store null IPv6 address
S N=DUZ_"^"_$I_"^"_$J_"^^"_P5_"^"_P6_"^"_P7_"^"_P8_"^"_$E($G(IO("ZIO")),1,30)_"^"_P10_"^"_P11_"^"_P12
S:$D(DUZ("VISITOR")) $P(N,U,14,15)=DUZ("VISITOR") ;p523
S:$G(DUZ(2))>0 $P(N,"^",17)=DUZ(2)
S:$D(DUZ("REMAPP")) $P(N,U,18)=$P(DUZ("REMAPP"),U) ;p523
F I=XL1:.00000001 L +^XUSEC(0,I):$G(DILOCKTM,5) Q:'$D(^XUSEC(0,I)) L -^XUSEC(0,I)
S ^XUSEC(0,I,0)=N
S ^XUSEC(0,I,1)=P100 ;p638 save IPv6 address in standard format
L -^XUSEC(0,I)
S $P(^XUSEC(0,0),"^",3,4)=I_U_(1+$P(^XUSEC(0,0),"^",4))
S (XL1,DA)=I,DIK="^XUSEC(0," D IX^DIK ;index new entry
S ^XUTL("XQ",$J,0)=XL1 ;save for sign-off
I 'P6 S XL2=$G(^VA(200,DUZ,1.1)),$P(XL2,U,1,3)=XL1_"^0^1",$P(XL2,U,5)="",^VA(200,DUZ,1.1)=XL2 ;Set last Sign-on
Q XL1
;
COOKIE(J1,J2) ;Call VAdeamon for a cookie
N ZZ,%
I $G(XQXFLG("ZEBRA"))=-1 K XQXFLG("ZEBRA") Q "" ;Disabled
Q:$G(IO("IP"))="" "" ;Not using Telnet or SSH
Q:$D(DUZ("VISITOR")) "" ;Don't create Handles for visitors p523
;
S %=$$CMD^XWBCAGNT(.ZZ,"XWB CREATE HANDLE",J1_"^"_J2) Q:'% ""
Q $G(ZZ(1))
;
AUDIT ;Set-up Audit info
N I,I1,I2
S I=$G(^XTV(8989.3,1,19)),I1=$P(I,U),I2=$P(I,U,2) Q:"asu"'[I1 I (I2>XUNOW)!($P(I,U,3)<XUNOW) Q
I "au"[I1 S:(I1="a")!($D(^XTV(8989.3,1,19.3,"B",DUZ))>1) XQAUDIT=1 Q
S XQAUDIT="" F I=0:0 S I=$O(^XTV(8989.3,1,19.1,"B",I)) Q:I'>0!($L(XQAUDIT)>245) S XQAUDIT=XQAUDIT_"2^"_I_U
S I1="" F I=0:0 S I1=$O(^XTV(8989.3,1,19.2,"B",I1)) Q:I1']""!($L(XQAUDIT)>245) S XQAUDIT=XQAUDIT_"3^"_I1_U
Q
;
DD(Y) Q $$FMTE^XLFDT(Y,1)
;
KILL N %UCI,PGM,U,XQUR,XMCHAN G KILL1^XUSCLEAN
Q
NO G NO^XUS
;----- BEGIN IHS MODIFICATION - XU*8.0*1007
;Modified by IHS/DSD/AEF 10/07/2002 based on original modification by
;IHS/HQW/MFD 12/14/1997
;New IHSDIV extrinsic function is added to set the default division
IHSDIV(DUZ) ;EXTRINSIC FUNCTION
;----- RETURN DEFAULT DIVISION
;
; INPUT: DUZ = USER'S IEN
;
; OUTPUT: DIVISIONIEN^DIVISIONAME
;
N X,Y,Z
S (X,Y,Z)=""
;
;Default Division in file 200, "AX1" x-ref
I '$G(X) S X=$O(^VA(200,DUZ,2,"AX1",1,0))
;
;If only one division get that one
I '$G(X) D
. S Z=$O(^VA(200,DUZ,2,0))
. I '$O(^VA(200,DUZ,2,Z)) S X=Z
;
;Last division signed on to
I '$G(X) D
. S Z="^VA(200,DUZ,2,"
. S X=$G(^DISV(DUZ,Z))
;
;First ^AUTTSITE
I '$G(X) S X=$P($G(^AUTTSITE(1,0)),U)
;
I X,$D(^DIC(4,X,0)) S Y=X_U_$P($$NS^XUAF4(X),U)
Q Y
;----- END IHS MODIFICATION
XUS1 ;SF-ISC/STAFF - SIGNON ;09/23/14 16:06
+1 ;;8.0;KERNEL;**9,59,111,165,150,252,265,419,469,523,543,638,1007,1018**;Jul 10, 1995;Build 8
+2 ;THIS ROUTINE CONTAINS IHS MODIFICATIONS
+3 ;User setup
USER ;
+1 KILL XUTEXT
SET XUM=$$USER^XUS1A()
SET $Y=0
+2 ;Show post sign-on text
+3 FOR I=0:0
SET I=$ORDER(XUTEXT(I))
IF I'>0
QUIT
IF $Y>20
Begin DoDot:1
+4 NEW DIR
SET DIR(0)="E"
SET DIR("A")="Enter RETURN to continue"
DO ^DIR
WRITE @IOF
QUIT
End DoDot:1
IF $EXTRACT(XUTEXT(I),1)="!"
WRITE !
WRITE $EXTRACT(XUTEXT(I),2,999)
+5 ;if XUM=9 multi sign-on NOT allowed
+6 IF XUM=9
WRITE !!,?8,$$EZBLD^DIALOG(30810.45)
+7 ;User can't sign-on.
IF XUM
QUIT
SET ;
+1 SET Y=$$CHKDIV()
+2 IF $PIECE(Y,U,2)>0
IF $DATA(^DIC(4,0))
DO ASKDIV
+3 ;----- BEGIN IHS MODIFICATION - XU*8.0*1007
+4 ;Modified by IHS/DSD/AEF 10/07/02 based on original midification by
+5 ;IHS/HQW/MFD 12/14/1997
+6 ;Add 2 lines to make sure Y is set to a division and display the
+7 ;division
+8 IF 'Y
SET Y=+$$IHSDIV(DUZ)
+9 IF Y
WRITE !,"Site set to ",$PIECE($GET(^DIC(4,+Y,0)),U),!
+10 ;----- END IHS MODIFICATION
+11 SET DUZ(2)=+Y
DO DUZ^XUS1A
+12 ;Check verify code
+13 IF $$VCHG
DO CVC^XUS2
IF $DATA(DUOUT)
GOTO H^XUS
+14 ;Ask Device
IF $PIECE(XOPT,"^",5)
SET XUTT=1
+15 ;Inquire to Terminal Type
DO ENQ
+16 QUIT
+17 ;
VCHG() ;Check if the Verify code needs to be changed
+1 ;p403
IF $DATA(DUZ("ASH"))
QUIT 0
+2 IF '$DATA(XUSER)
DO USER^XUS(DUZ)
+3 ;Null VC
IF '$LENGTH($PIECE(XUSER(1),U,2))
QUIT 1
+4 ;VC never expires, only for BROKER
IF $$BROKER^XWBLIB
IF $PIECE(XUSER(0),U,8)=1
QUIT 0
+5 ;Time to change
QUIT (XUSER(1)+$PIECE(XOPT,U,15))'>$HOROLOG
+6 ;
ASKDIV ;Ask the user for the Division, return Y
+1 NEW X
+2 ;----- BEGIN IHS MODIFICATION - XU*8.0*1007
+3 ;Modified by IHS/DSD/AEF 10/07/02 based on original modification by
+4 ;IHS/HQW/MFD 12/14/1997
+5 ;This line is commented out and replaced by the line below. This
+6 ;modified line ensures that the default division is set.
+7 ;S DIC="^VA(200,DUZ,2,",DIC(0)="AEQ",DIC("P")="200.02P",X=$O(^VA(200,DUZ,2,"AX1",1,0)) S:X>0 DIC("B")=$P($$NS^XUAF4(X),U)
+8 SET DIC="^VA(200,DUZ,2,"
SET DIC(0)="AEMQ"
SET DIC("P")="200.02P"
SET DIC("B")=$PIECE($$IHSDIV(DUZ),U,2)
+9 ;----- END IHS MODIFICATION
+10 DO ^DIC
IF Y'>0
WRITE !,*7,"You must select one."
GOTO ASKDIV
+11 QUIT
+12 ;
CHKDIV(CD) ;ef,sr Check if user needs to select Division.
+1 NEW %,%1,%2,%3,%4
+2 ;p469 Set outside
IF $GET(DUZ("DIV"))>0
QUIT DUZ("DIV")
+3 SET %=$ORDER(^VA(200,DUZ,2,0))
SET %1=$ORDER(^(%))
+4 IF %1
IF $DATA(CD)
Begin DoDot:1
+5 SET %2=0
SET %3=0
SET CD=0
+6 FOR
SET %2=$ORDER(^VA(200,DUZ,2,%2))
IF %2'>0
QUIT
SET %4=^(%2,0)
SET %3=%3+1
SET CD(%3)=%2_"^"_$$NS^XUAF4(%2)_$SELECT($PIECE(%4,"^",2):"^1",1:"")
+7 SET CD=%3
End DoDot:1
+8 QUIT %_"^"_%1
+9 ;
ENQ ;Get terminal type
+1 SET XUT1=""
IF XUTT
XECUTE XUEOFF
READ X:0
XECUTE ^%ZOSF("TYPE-AHEAD")
WRITE $CHAR(27,91,99)
XECUTE "R *X:2 I X=27 F R X#1:2 S XUT1=XUT1_X Q:'$T!(X=""c"")"
+2 ;Removed code for Wyse 75
+3 XECUTE XUEON
IF XUTT
IF XUT1["["
SET Y=$ORDER(^%ZIS(3.22,"B",XUT1,0))
IF Y>0
SET X=$PIECE($GET(^%ZIS(3.22,Y,0)),"^",2)
+4 IF X?1.ANP
SET DIC="^%ZIS(2,"
SET DIC(0)="MO"
DO ^DIC
IF Y>0
SET XUIOP(1)=$PIECE(Y,U,2)
SET $PIECE(XUIOP,";",2)=XUIOP(1)
SET ^VA(200,DUZ,1.2)=+Y
+5 IF '$DATA(XUIOP(1))
IF $DATA(^VA(200,DUZ,1.2))
SET X=+^(1.2)
IF X>0
IF $DATA(^%ZIS(2,X,0))
SET $PIECE(XUIOP,";",2)=$PIECE(^(0),U)
+6 QUIT
+7 ;
NEXT ;Jump to the next routine
+1 ;Save off device/user info
SET IOP=XUIOP
DO ^%ZIS
DO SAVE
+2 ;Add kill by session or day here
SET X=$GET(^DISV(DUZ))
+3 SET ^DISV(DUZ)=$HOROLOG
+4 ;Removed UCI jump p469
+5 DO AUDIT
+6 ;Set Process Name
SET X=$SELECT($DATA(^VA(200,DUZ,0)):$PIECE($PIECE(^(0),U),","),1:"Unk")
SET X=$EXTRACT(X,1,10)_"_"_($JOB#10000)
DO SETENV^%ZOSV
+7 ;S X=$P(XOPT,U,16) X:X ^%ZOSF("PRIORITY")
+8 IF DUZ
DO LOG
DO KILL
+9 KILL ^XUTL("OR",$JOB),^UTILITY($JOB),%UCI
+10 GOTO ^XQ
+11 ;
SAVE ;
+1 NEW X
+2 SET X="DUZ"
FOR
SET X=$QUERY(@X)
IF X=""
QUIT
IF $DATA(@X)
SET ^XUTL("XQ",$JOB,$TRANSLATE(X,""""))=@X
+3 FOR X="DUZ","IO","IO(""IP"")","IO(""CLNM"")","XQVOL"
IF $DATA(@X)
SET ^XUTL("XQ",$JOB,X)=@X
+4 ;Save the HOME device variables
DO SAVEVAR^%ZIS
+5 QUIT
+6 ;
LOG ;used by R/S and Broker
+1 NEW %,XP1,XP2
+2 ;Save for LOGIN templates
SET XQXFLG("LLOG")=$PIECE($GET(^VA(200,DUZ,1.1)),U)
+3 SET XP1=$$SLOG($PIECE(XUVOL,U,1),,XUDEV,XUCI,$PIECE(XUENV,U,3))
+4 SET %=$$COOKIE($PIECE(^VA(200,DUZ,0),U),XP1)
IF $LENGTH(%)
SET XQXFLG("ZEBRA")=XP1_"~"_%
SET $PIECE(^XUSEC(0,XP1,0),U,13)=%
LOCK +^XWB("SESSION",XQXFLG("ZEBRA")):60
+5 QUIT
+6 ;
+7 ;Division updated in DIVSET^XUSRB2
+8 ;The other parameters are in the symbol table with known names.
+9 ;P1=DUZ,P2=$I,P3=$J,P4=EXIT D/T,P5=VOLUME,P6=TASKMAN,P7=XUDEV,P8=UCI,P9=ZIO,P10=NODE,P11=IPV4,P12=CLNM,P13=HANDLE,P14=REMOTE SITE,P15=REMOTE IEN
SLOG(P5,P6,P7,P8,P10,P14,P15) ;
+1 ;p638 Changes: Save IPv4 address in field 11 (0;11) and IPv6 address in field 100 (1;1)
+2 NEW %,I,DA,DIK,N,XL1,XL2,P11,P12,P100
+3 SET XL1=$$NOW^XLFDT
+4 SET P5=$GET(P5)
SET P6=$GET(P6)
SET P7=$GET(P7)
SET P8=$GET(P8)
SET P10=$PIECE($GET(P10),".")
+5 SET P11=$$FORCEIP4^XLFIPV($GET(IO("IP")))
SET P12=$PIECE($GET(IO("CLNM")),".")
SET P100=$$FORCEIP6^XLFIPV($GET(IO("IP")))
+6 ;Do not store null IPv4 address
IF P11="0.0.0.0"
SET P11=""
+7 ;Do not store null IPv6 address
IF P100="0000:0000:0000:0000:0000:0000:0000:0000"
SET P100=""
+8 SET N=DUZ_"^"_$IO_"^"_$JOB_"^^"_P5_"^"_P6_"^"_P7_"^"_P8_"^"_$EXTRACT($GET(IO("ZIO")),1,30)_"^"_P10_"^"_P11_"^"_P12
+9 ;p523
IF $DATA(DUZ("VISITOR"))
SET $PIECE(N,U,14,15)=DUZ("VISITOR")
+10 IF $GET(DUZ(2))>0
SET $PIECE(N,"^",17)=DUZ(2)
+11 ;p523
IF $DATA(DUZ("REMAPP"))
SET $PIECE(N,U,18)=$PIECE(DUZ("REMAPP"),U)
+12 FOR I=XL1:.00000001
LOCK +^XUSEC(0,I):$GET(DILOCKTM,5)
IF '$DATA(^XUSEC(0,I))
QUIT
LOCK -^XUSEC(0,I)
+13 SET ^XUSEC(0,I,0)=N
+14 ;p638 save IPv6 address in standard format
SET ^XUSEC(0,I,1)=P100
+15 LOCK -^XUSEC(0,I)
+16 SET $PIECE(^XUSEC(0,0),"^",3,4)=I_U_(1+$PIECE(^XUSEC(0,0),"^",4))
+17 ;index new entry
SET (XL1,DA)=I
SET DIK="^XUSEC(0,"
DO IX^DIK
+18 ;save for sign-off
SET ^XUTL("XQ",$JOB,0)=XL1
+19 ;Set last Sign-on
IF 'P6
SET XL2=$GET(^VA(200,DUZ,1.1))
SET $PIECE(XL2,U,1,3)=XL1_"^0^1"
SET $PIECE(XL2,U,5)=""
SET ^VA(200,DUZ,1.1)=XL2
+20 QUIT XL1
+21 ;
COOKIE(J1,J2) ;Call VAdeamon for a cookie
+1 NEW ZZ,%
+2 ;Disabled
IF $GET(XQXFLG("ZEBRA"))=-1
KILL XQXFLG("ZEBRA")
QUIT ""
+3 ;Not using Telnet or SSH
IF $GET(IO("IP"))=""
QUIT ""
+4 ;Don't create Handles for visitors p523
IF $DATA(DUZ("VISITOR"))
QUIT ""
+5 ;
+6 SET %=$$CMD^XWBCAGNT(.ZZ,"XWB CREATE HANDLE",J1_"^"_J2)
IF '%
QUIT ""
+7 QUIT $GET(ZZ(1))
+8 ;
AUDIT ;Set-up Audit info
+1 NEW I,I1,I2
+2 SET I=$GET(^XTV(8989.3,1,19))
SET I1=$PIECE(I,U)
SET I2=$PIECE(I,U,2)
IF "asu"'[I1
QUIT
IF (I2>XUNOW)!($PIECE(I,U,3)<XUNOW)
QUIT
+3 IF "au"[I1
IF (I1="a")!($DATA(^XTV(8989.3,1,19.3,"B",DUZ))>1)
SET XQAUDIT=1
QUIT
+4 SET XQAUDIT=""
FOR I=0:0
SET I=$ORDER(^XTV(8989.3,1,19.1,"B",I))
IF I'>0!($LENGTH(XQAUDIT)>245)
QUIT
SET XQAUDIT=XQAUDIT_"2^"_I_U
+5 SET I1=""
FOR I=0:0
SET I1=$ORDER(^XTV(8989.3,1,19.2,"B",I1))
IF I1']""!($LENGTH(XQAUDIT)>245)
QUIT
SET XQAUDIT=XQAUDIT_"3^"_I1_U
+6 QUIT
+7 ;
DD(Y) QUIT $$FMTE^XLFDT(Y,1)
+1 ;
KILL NEW %UCI,PGM,U,XQUR,XMCHAN
GOTO KILL1^XUSCLEAN
+1 QUIT
NO GOTO NO^XUS
+1 ;----- BEGIN IHS MODIFICATION - XU*8.0*1007
+2 ;Modified by IHS/DSD/AEF 10/07/2002 based on original modification by
+3 ;IHS/HQW/MFD 12/14/1997
+4 ;New IHSDIV extrinsic function is added to set the default division
IHSDIV(DUZ) ;EXTRINSIC FUNCTION
+1 ;----- RETURN DEFAULT DIVISION
+2 ;
+3 ; INPUT: DUZ = USER'S IEN
+4 ;
+5 ; OUTPUT: DIVISIONIEN^DIVISIONAME
+6 ;
+7 NEW X,Y,Z
+8 SET (X,Y,Z)=""
+9 ;
+10 ;Default Division in file 200, "AX1" x-ref
+11 IF '$GET(X)
SET X=$ORDER(^VA(200,DUZ,2,"AX1",1,0))
+12 ;
+13 ;If only one division get that one
+14 IF '$GET(X)
Begin DoDot:1
+15 SET Z=$ORDER(^VA(200,DUZ,2,0))
+16 IF '$ORDER(^VA(200,DUZ,2,Z))
SET X=Z
End DoDot:1
+17 ;
+18 ;Last division signed on to
+19 IF '$GET(X)
Begin DoDot:1
+20 SET Z="^VA(200,DUZ,2,"
+21 SET X=$GET(^DISV(DUZ,Z))
End DoDot:1
+22 ;
+23 ;First ^AUTTSITE
+24 IF '$GET(X)
SET X=$PIECE($GET(^AUTTSITE(1,0)),U)
+25 ;
+26 IF X
IF $DATA(^DIC(4,X,0))
SET Y=X_U_$PIECE($$NS^XUAF4(X),U)
+27 QUIT Y
+28 ;----- END IHS MODIFICATION