- XUS1 ;SF-ISC/STAFF - SIGNON ;01/14/20 13:32
- ;;8.0;KERNEL;**9,59,111,165,150,252,265,419,469,523,543,638,659,701,795**;Jul 10, 1995;Build 1
- ;Per VA Directive 6402, this routine should not be modified.
- ;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
- 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
- Q:$G(DUZ("AUTHENTICATION"))["SSO" 0 ;VC expiration ignored during SAML/STS/IAM Auth (p702)
- 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
- 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)
- 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
- ;P100=IPV6,P101=LOA
- SLOG(P5,P6,P7,P8,P10,P14,P15) ;
- ;ZEXCEPT: DILOCKTM ;Global variable for lock timeout
- ;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,P101,P102,P103
- 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"))),P100=$$FORCEIP6^XLFIPV($G(IO("IP")))
- S P12=$P($G(IO("CLNM")),".")
- 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 P101=$G(DUZ("LOA"))
- S P102=$G(DUZ("AUTHENTICATION"))
- S P102=$S(P102="AVCODES":1,P102="SSOI":2,P102="SSOE":3,P102="BSETOKEN":4,P102="CCOWTOKEN":5,P102="ASHTOKEN":6,P102="NHIN":7,P102="NONE":8,1:9)
- S P103=$G(DUZ("WARNINGS"))
- 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,U,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_"^"_P101_"^"_P102_"^"_P103 ;Save IPv6 address,LOA,type,warnings
- 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
- ; <bug-fix>
- Q:$G(XQXFLG("ASO"))=1 "" ; if auto sign on setup is skipped then we should NOT create a broker client handle
- ;------------------------- that calls back to the client workstation. reference SETUP^XUSRB
- ; </bug-fix>
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUS1 6181 printed Jan 18, 2025@03:13:02 Page 2
- XUS1 ;SF-ISC/STAFF - SIGNON ;01/14/20 13:32
- +1 ;;8.0;KERNEL;**9,59,111,165,150,252,265,419,469,523,543,638,659,701,795**;Jul 10, 1995;Build 1
- +2 ;Per VA Directive 6402, this routine should not be modified.
- +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 SET DUZ(2)=+Y
- DO DUZ^XUS1A
- +4 ;Check verify code
- +5 IF $$VCHG
- DO CVC^XUS2
- if $DATA(DUOUT)
- GOTO H^XUS
- +6 ;Ask Device
- if $PIECE(XOPT,"^",5)
- SET XUTT=1
- +7 ;Inquire to Terminal Type
- DO ENQ
- +8 QUIT
- +9 ;
- 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 expiration ignored during SAML/STS/IAM Auth (p702)
- if $GET(DUZ("AUTHENTICATION"))["SSO"
- QUIT 0
- +5 ;VC never expires, only for BROKER
- IF $$BROKER^XWBLIB
- if $PIECE(XUSER(0),U,8)=1
- QUIT 0
- +6 ;Time to change
- QUIT (XUSER(1)+$PIECE(XOPT,U,15))'>$HOROLOG
- +7 ;
- ASKDIV ;Ask the user for the Division, return Y
- +1 NEW X
- +2 SET DIC="^VA(200,DUZ,2,"
- SET DIC(0)="AEQ"
- SET DIC("P")="200.02P"
- SET X=$ORDER(^VA(200,DUZ,2,"AX1",1,0))
- if X>0
- SET DIC("B")=$PIECE($$NS^XUAF4(X),U)
- +3 DO ^DIC
- IF Y'>0
- WRITE !,*7,"You must select one."
- GOTO ASKDIV
- +4 QUIT
- +5 ;
- 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
- +10 ;P100=IPV6,P101=LOA
- SLOG(P5,P6,P7,P8,P10,P14,P15) ;
- +1 ;ZEXCEPT: DILOCKTM ;Global variable for lock timeout
- +2 ;p638 Changes: Save IPv4 address in field 11 (0;11) and IPv6 address in field 100 (1;1)
- +3 NEW %,I,DA,DIK,N,XL1,XL2,P11,P12,P100,P101,P102,P103
- +4 SET XL1=$$NOW^XLFDT
- +5 SET P5=$GET(P5)
- SET P6=$GET(P6)
- SET P7=$GET(P7)
- SET P8=$GET(P8)
- SET P10=$PIECE($GET(P10),".")
- +6 SET P11=$$FORCEIP4^XLFIPV($GET(IO("IP")))
- SET P100=$$FORCEIP6^XLFIPV($GET(IO("IP")))
- +7 SET P12=$PIECE($GET(IO("CLNM")),".")
- +8 ;Do not store null IPv4 address
- IF P11="0.0.0.0"
- SET P11=""
- +9 ;Do not store null IPv6 address
- IF P100="0000:0000:0000:0000:0000:0000:0000:0000"
- SET P100=""
- +10 SET P101=$GET(DUZ("LOA"))
- +11 SET P102=$GET(DUZ("AUTHENTICATION"))
- +12 SET P102=$SELECT(P102="AVCODES":1,P102="SSOI":2,P102="SSOE":3,P102="BSETOKEN":4,P102="CCOWTOKEN":5,P102="ASHTOKEN":6,P102="NHIN":7,P102="NONE":8,1:9)
- +13 SET P103=$GET(DUZ("WARNINGS"))
- +14 SET N=DUZ_"^"_$IO_"^"_$JOB_"^^"_P5_"^"_P6_"^"_P7_"^"_P8_"^"_$EXTRACT($GET(IO("ZIO")),1,30)_"^"_P10_"^"_P11_"^"_P12
- +15 ;p523
- if $DATA(DUZ("VISITOR"))
- SET $PIECE(N,U,14,15)=DUZ("VISITOR")
- +16 if $GET(DUZ(2))>0
- SET $PIECE(N,U,17)=DUZ(2)
- +17 ;p523
- if $DATA(DUZ("REMAPP"))
- SET $PIECE(N,U,18)=$PIECE(DUZ("REMAPP"),U)
- +18 FOR I=XL1:.00000001
- LOCK +^XUSEC(0,I):$GET(DILOCKTM,5)
- if '$DATA(^XUSEC(0,I))
- QUIT
- LOCK -^XUSEC(0,I)
- +19 SET ^XUSEC(0,I,0)=N
- +20 ;Save IPv6 address,LOA,type,warnings
- SET ^XUSEC(0,I,1)=P100_"^"_P101_"^"_P102_"^"_P103
- +21 LOCK -^XUSEC(0,I)
- +22 SET $PIECE(^XUSEC(0,0),"^",3,4)=I_U_(1+$PIECE(^XUSEC(0,0),"^",4))
- +23 ;index new entry
- SET (XL1,DA)=I
- SET DIK="^XUSEC(0,"
- DO IX^DIK
- +24 ;save for sign-off
- SET ^XUTL("XQ",$JOB,0)=XL1
- +25 ;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
- +26 QUIT XL1
- +27 ;
- 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 ; <bug-fix>
- +6 ; if auto sign on setup is skipped then we should NOT create a broker client handle
- if $GET(XQXFLG("ASO"))=1
- QUIT ""
- +7 ;------------------------- that calls back to the client workstation. reference SETUP^XUSRB
- +8 ; </bug-fix>
- +9 SET %=$$CMD^XWBCAGNT(.ZZ,"XWB CREATE HANDLE",J1_"^"_J2)
- if '%
- QUIT ""
- +10 QUIT $GET(ZZ(1))
- +11 ;
- 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