Released XU*8*543 SEQ #461 Extracted from mail message **KIDS**:XU*8.0*543^ **INSTALL NAME** XU*8.0*543 "BLD",1293,0) XU*8.0*543^KERNEL^0^3110503^y "BLD",1293,1,0) ^^3^3^3100317^ "BLD",1293,1,1,0) Please refer to the Description in the FORUM Patch Module for details. "BLD",1293,1,2,0) "BLD",1293,1,3,0) XU*8*543 Auto Sign-on Fix. "BLD",1293,4,0) ^9.64PA^^ "BLD",1293,6.3) 15 "BLD",1293,"ABPKG") n "BLD",1293,"INIT") POST^XU8P543 "BLD",1293,"KRN",0) ^9.67PA^9002226^21 "BLD",1293,"KRN",.4,0) .4 "BLD",1293,"KRN",.401,0) .401 "BLD",1293,"KRN",.402,0) .402 "BLD",1293,"KRN",.403,0) .403 "BLD",1293,"KRN",.5,0) .5 "BLD",1293,"KRN",.84,0) .84 "BLD",1293,"KRN",3.6,0) 3.6 "BLD",1293,"KRN",3.8,0) 3.8 "BLD",1293,"KRN",9.2,0) 9.2 "BLD",1293,"KRN",9.8,0) 9.8 "BLD",1293,"KRN",9.8,"NM",0) ^9.68A^5^5 "BLD",1293,"KRN",9.8,"NM",1,0) XUS1B^^0^B8553582 "BLD",1293,"KRN",9.8,"NM",2,0) XUSPURGE^^0^B8394877 "BLD",1293,"KRN",9.8,"NM",3,0) XUS1^^0^B25184482 "BLD",1293,"KRN",9.8,"NM",4,0) XUDHUTL^^0^B552843 "BLD",1293,"KRN",9.8,"NM",5,0) ZIS4ONT^^0^B31901858 "BLD",1293,"KRN",9.8,"NM","B","XUDHUTL",4) "BLD",1293,"KRN",9.8,"NM","B","XUS1",3) "BLD",1293,"KRN",9.8,"NM","B","XUS1B",1) "BLD",1293,"KRN",9.8,"NM","B","XUSPURGE",2) "BLD",1293,"KRN",9.8,"NM","B","ZIS4ONT",5) "BLD",1293,"KRN",19,0) 19 "BLD",1293,"KRN",19,"NM",0) ^9.68A^1^1 "BLD",1293,"KRN",19,"NM",1,0) XUTTEST^^0 "BLD",1293,"KRN",19,"NM","B","XUTTEST",1) "BLD",1293,"KRN",19.1,0) 19.1 "BLD",1293,"KRN",101,0) 101 "BLD",1293,"KRN",409.61,0) 409.61 "BLD",1293,"KRN",771,0) 771 "BLD",1293,"KRN",779.2,0) 779.2 "BLD",1293,"KRN",870,0) 870 "BLD",1293,"KRN",8989.51,0) 8989.51 "BLD",1293,"KRN",8989.52,0) 8989.52 "BLD",1293,"KRN",8994,0) 8994 "BLD",1293,"KRN",9002226,0) 9002226 "BLD",1293,"KRN","B",.4,.4) "BLD",1293,"KRN","B",.401,.401) "BLD",1293,"KRN","B",.402,.402) "BLD",1293,"KRN","B",.403,.403) "BLD",1293,"KRN","B",.5,.5) "BLD",1293,"KRN","B",.84,.84) "BLD",1293,"KRN","B",3.6,3.6) "BLD",1293,"KRN","B",3.8,3.8) "BLD",1293,"KRN","B",9.2,9.2) "BLD",1293,"KRN","B",9.8,9.8) "BLD",1293,"KRN","B",19,19) "BLD",1293,"KRN","B",19.1,19.1) "BLD",1293,"KRN","B",101,101) "BLD",1293,"KRN","B",409.61,409.61) "BLD",1293,"KRN","B",771,771) "BLD",1293,"KRN","B",779.2,779.2) "BLD",1293,"KRN","B",870,870) "BLD",1293,"KRN","B",8989.51,8989.51) "BLD",1293,"KRN","B",8989.52,8989.52) "BLD",1293,"KRN","B",8994,8994) "BLD",1293,"KRN","B",9002226,9002226) "BLD",1293,"QDEF") ^^^^YES^^^^NO^^NO "BLD",1293,"QUES",0) ^9.62^^ "BLD",1293,"REQB",0) ^9.611^5^4 "BLD",1293,"REQB",2,0) XU*8.0*312^2 "BLD",1293,"REQB",3,0) XU*8.0*469^2 "BLD",1293,"REQB",4,0) XU*8.0*523^0 "BLD",1293,"REQB",5,0) XU*8.0*546^2 "BLD",1293,"REQB","B","XU*8.0*312",2) "BLD",1293,"REQB","B","XU*8.0*469",3) "BLD",1293,"REQB","B","XU*8.0*523",4) "BLD",1293,"REQB","B","XU*8.0*546",5) "INIT") POST^XU8P543 "KRN",19,34,-1) 0^1 "KRN",19,34,0) XUTTEST^Send Test Pattern to Terminal^^R^^^^^^^^KERNEL^y^^^ "KRN",19,34,1,0) ^^2^2^3100902^ "KRN",19,34,1,1,0) This option prints a selected number of nonsense lines to a terminal or "KRN",19,34,1,2,0) Printer to test data communications. "KRN",19,34,20) "KRN",19,34,25) PTEST^XUDHUTL "KRN",19,34,"U") SEND TEST PATTERN TO TERMINAL "MBREQ") 0 "ORD",18,19) 19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA "ORD",18,19,0) OPTION "PKG",3,-1) 1^1 "PKG",3,0) KERNEL^XU^SIGN-ON, SECURITY, MENU DRIVER, DEVICES, TASKMAN^ "PKG",3,20,0) ^9.402P^200^1 "PKG",3,20,200,0) 200^^XDRM200N "PKG",3,20,200,1) "PKG",3,20,"B",200,200) "PKG",3,22,0) ^9.49I^1^1 "PKG",3,22,1,0) 8.0^3090706^3090706^6 "PKG",3,22,1,"PAH",1,0) 543^3110503 "PKG",3,22,1,"PAH",1,1,0) ^^3^3^3110503 "PKG",3,22,1,"PAH",1,1,1,0) Please refer to the Description in the FORUM Patch Module for details. "PKG",3,22,1,"PAH",1,1,2,0) "PKG",3,22,1,"PAH",1,1,3,0) XU*8*543 Auto Sign-on Fix. "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") YES "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") NO "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") NO "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 6 "RTN","XU8P543") 0^^B31582^n/a "RTN","XU8P543",1,0) XU8P543 ;ISF/RD - Patch XU*8*543 ; "RTN","XU8P543",2,0) ;;8.0;KERNEL;**543**;Jul 10, 1995;Build 15 "RTN","XU8P543",3,0) Q "RTN","XU8P543",4,0) ; "RTN","XU8P543",5,0) POST ;POST-INIT "RTN","XU8P543",6,0) D PATCH^ZTMGRSET(543) "RTN","XU8P543",7,0) Q "RTN","XUDHUTL") 0^4^B552843^n/a "RTN","XUDHUTL",1,0) XUDHUTL ;ISF/RWF - Some device Utilities. ;09/02/10 17:22 "RTN","XUDHUTL",2,0) ;;8.0;KERNEL;**543**;Jul 10, 1995;Build 15 "RTN","XUDHUTL",3,0) Q "RTN","XUDHUTL",4,0) ; "RTN","XUDHUTL",5,0) PTEST ;Send a test pattern to a printer "RTN","XUDHUTL",6,0) N X,Y,DIR,DIRUT,DUOUT,DTOUT,XUDH1 "RTN","XUDHUTL",7,0) S DIR(0)="N^1:66",DIR("A")="How Many Lines" D ^DIR Q:$D(DIRUT) "RTN","XUDHUTL",8,0) S XUDH1=Y,X("XUDH1")="",%ZIS="QM" "RTN","XUDHUTL",9,0) D EN^XUTMDEVQ("PT1^XUDHUTL","Printer Test",.X,.%ZIS) "RTN","XUDHUTL",10,0) Q "RTN","XUDHUTL",11,0) ; "RTN","XUDHUTL",12,0) PT1 ;Do the print "RTN","XUDHUTL",13,0) N X,I "RTN","XUDHUTL",14,0) U IO "RTN","XUDHUTL",15,0) F X=XUDH1:-1 W ! Q:'X F I=1:1:IOM W $C(I+X#96+32) "RTN","XUDHUTL",16,0) Q "RTN","XUS1") 0^3^B25184482^B26024789 "RTN","XUS1",1,0) XUS1 ;SF-ISC/STAFF - SIGNON ;08/11/10 16:07 "RTN","XUS1",2,0) ;;8.0;KERNEL;**9,59,111,165,150,252,265,419,469,523,543**;Jul 10, 1995;Build 15 "RTN","XUS1",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","XUS1",4,0) ;User setup "RTN","XUS1",5,0) USER ; "RTN","XUS1",6,0) K XUTEXT S XUM=$$USER^XUS1A(),$Y=0 "RTN","XUS1",7,0) ;Show post sign-on text "RTN","XUS1",8,0) 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) "RTN","XUS1",9,0) . N DIR S DIR(0)="E",DIR("A")="Enter RETURN to continue" D ^DIR W @IOF Q "RTN","XUS1",10,0) ;if XUM=9 multi sign-on NOT allowed "RTN","XUS1",11,0) I XUM=9 W !!,?8,$$EZBLD^DIALOG(30810.45) "RTN","XUS1",12,0) Q:XUM ;User can't sign-on. "RTN","XUS1",13,0) SET ; "RTN","XUS1",14,0) S Y=$$CHKDIV() "RTN","XUS1",15,0) I $P(Y,U,2)>0,$D(^DIC(4,0)) D ASKDIV "RTN","XUS1",16,0) S DUZ(2)=+Y D DUZ^XUS1A "RTN","XUS1",17,0) ;Check verify code "RTN","XUS1",18,0) I $$VCHG D CVC^XUS2 G:$D(DUOUT) H^XUS "RTN","XUS1",19,0) S:$P(XOPT,"^",5) XUTT=1 ;Ask Device "RTN","XUS1",20,0) D ENQ ;Inquire to Terminal Type "RTN","XUS1",21,0) Q "RTN","XUS1",22,0) ; "RTN","XUS1",23,0) VCHG() ;Check if the Verify code needs to be changed "RTN","XUS1",24,0) I $D(DUZ("ASH")) Q 0 ;rwf 403 "RTN","XUS1",25,0) D:'$D(XUSER) USER^XUS(DUZ) "RTN","XUS1",26,0) Q:'$L($P(XUSER(1),U,2)) 1 ;Null VC "RTN","XUS1",27,0) I $$BROKER^XWBLIB Q:$P(XUSER(0),U,8)=1 0 ;VC never expires, only for BROKER "RTN","XUS1",28,0) Q (XUSER(1)+$P(XOPT,U,15))'>$H ;Time to change "RTN","XUS1",29,0) ; "RTN","XUS1",30,0) ASKDIV ;Ask the user for the Division, return Y "RTN","XUS1",31,0) N X "RTN","XUS1",32,0) S DIC="^VA(200,DUZ,2,",DIC(0)="AEMQ",DIC("P")="200.02P",X=$O(^VA(200,DUZ,2,"AX1",1,0)) S:X>0 DIC("B")=$P($$NS^XUAF4(X),U) "RTN","XUS1",33,0) D ^DIC I Y'>0 W !,*7,"You must select one." G ASKDIV "RTN","XUS1",34,0) Q "RTN","XUS1",35,0) ; "RTN","XUS1",36,0) CHKDIV(CD) ;ef,sr Check if user needs to select Division. "RTN","XUS1",37,0) N %,%1,%2,%3,%4 "RTN","XUS1",38,0) I $G(DUZ("DIV"))>0 Q DUZ("DIV") ;p469 Set outside "RTN","XUS1",39,0) S %=$O(^VA(200,DUZ,2,0)),%1=$O(^(%)) "RTN","XUS1",40,0) I %1,$D(CD) D "RTN","XUS1",41,0) . S %2=0,%3=0,CD=0 "RTN","XUS1",42,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:"") "RTN","XUS1",43,0) . S CD=%3 "RTN","XUS1",44,0) Q %_"^"_%1 "RTN","XUS1",45,0) ; "RTN","XUS1",46,0) ENQ ;Get terminal type "RTN","XUS1",47,0) 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"")" "RTN","XUS1",48,0) ;Removed code for Wyse 75 "RTN","XUS1",49,0) 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) "RTN","XUS1",50,0) 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 "RTN","XUS1",51,0) 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) "RTN","XUS1",52,0) Q "RTN","XUS1",53,0) ; "RTN","XUS1",54,0) NEXT ;Jump to the next routine "RTN","XUS1",55,0) S IOP=XUIOP D ^%ZIS D SAVE ;Save off device/user info "RTN","XUS1",56,0) S X=$G(^DISV(DUZ)) ;Add kill by session or day here "RTN","XUS1",57,0) S ^DISV(DUZ)=$H "RTN","XUS1",58,0) ;Removed UCI jump p469 "RTN","XUS1",59,0) D AUDIT "RTN","XUS1",60,0) 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 "RTN","XUS1",61,0) ;S X=$P(XOPT,U,16) X:X ^%ZOSF("PRIORITY") "RTN","XUS1",62,0) D LOG:DUZ,KILL "RTN","XUS1",63,0) K ^XUTL("OR",$J),^UTILITY($J),%UCI "RTN","XUS1",64,0) G ^XQ "RTN","XUS1",65,0) ; "RTN","XUS1",66,0) SAVE ; "RTN","XUS1",67,0) N X "RTN","XUS1",68,0) S X="DUZ" F S X=$Q(@X) Q:X="" I $D(@X) S ^XUTL("XQ",$J,$TR(X,""""))=@X "RTN","XUS1",69,0) F X="DUZ","IO","IO(""IP"")","IO(""CLNM"")","XQVOL" I $D(@X) S ^XUTL("XQ",$J,X)=@X "RTN","XUS1",70,0) D SAVEVAR^%ZIS ;Save the HOME device variables "RTN","XUS1",71,0) Q "RTN","XUS1",72,0) ; "RTN","XUS1",73,0) LOG ;used by R/S and Broker "RTN","XUS1",74,0) N %,XP1,XP2 "RTN","XUS1",75,0) S XQXFLG("LLOG")=$P($G(^VA(200,DUZ,1.1)),U) ;Save for LOGIN templates "RTN","XUS1",76,0) S XP1=$$SLOG($P(XUVOL,U,1),,XUDEV,XUCI,$P(XUENV,U,3)) "RTN","XUS1",77,0) 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 "RTN","XUS1",78,0) Q "RTN","XUS1",79,0) ; "RTN","XUS1",80,0) ;Division updated in DIVSET^XUSRB2 "RTN","XUS1",81,0) ;The other parameters are in the symbol table with known names. "RTN","XUS1",82,0) ;P1=DUZ,P2=$I,P3=$J,P4=EXIT D/T,P5=VOLUME,P6=TASKMAN,P7=XUDEV,P8=UCI,P9=ZIO,P10=NODE,P11=IP,P12=CLNM,P13=HANDLE,P14=REMOTE SITE,P15=REMOTE IEN "RTN","XUS1",83,0) SLOG(P5,P6,P7,P8,P10,P14,P15) ; "RTN","XUS1",84,0) N %,I,DA,DIK,N,XL1,XL2 S XL1=$$NOW^XLFDT "RTN","XUS1",85,0) S P5=$G(P5),P6=$G(P6),P7=$G(P7),P8=$G(P8),P10=$G(P10) "RTN","XUS1",86,0) S N=DUZ_"^"_$I_"^"_$J_"^^"_P5_"^"_P6_"^"_P7_"^"_P8_"^"_$G(IO("ZIO"))_"^"_P10_"^"_$G(IO("IP"))_"^"_$G(IO("CLNM")) "RTN","XUS1",87,0) S:$D(DUZ("VISITOR")) $P(N,U,14,15)=DUZ("VISITOR") ;p523 "RTN","XUS1",88,0) S:$G(DUZ(2))>0 $P(N,"^",17)=DUZ(2) "RTN","XUS1",89,0) S:$D(DUZ("REMAPP")) $P(N,U,18)=$P(DUZ("REMAPP"),U) ;p523 "RTN","XUS1",90,0) F I=XL1:.00000001 L +^XUSEC(0,I):$G(DILOCKTM,5) Q:'$D(^XUSEC(0,I)) L -^XUSEC(0,I) "RTN","XUS1",91,0) S ^XUSEC(0,I,0)=N "RTN","XUS1",92,0) L -^XUSEC(0,I) "RTN","XUS1",93,0) S $P(^XUSEC(0,0),"^",3,4)=I_U_(1+$P(^XUSEC(0,0),"^",4)) "RTN","XUS1",94,0) S (XL1,DA)=I,DIK="^XUSEC(0," D IX^DIK ;index new entry "RTN","XUS1",95,0) S ^XUTL("XQ",$J,0)=XL1 ;save for sign-off "RTN","XUS1",96,0) 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 "RTN","XUS1",97,0) Q XL1 "RTN","XUS1",98,0) ; "RTN","XUS1",99,0) COOKIE(J1,J2) ;Call VAdeamon for a cookie "RTN","XUS1",100,0) N ZZ,% "RTN","XUS1",101,0) I $G(XQXFLG("ZEBRA"))=-1 K XQXFLG("ZEBRA") Q "" ;Disabled "RTN","XUS1",102,0) Q:$G(IO("IP"))="" "" ;Not using Telnet "RTN","XUS1",103,0) Q:$D(DUZ("VISITOR")) "" ;Don't create Handles for visitors p523 "RTN","XUS1",104,0) ; "RTN","XUS1",105,0) S %=$$CMD^XWBCAGNT(.ZZ,"XWB CREATE HANDLE",J1_"^"_J2) Q:'% "" "RTN","XUS1",106,0) Q $G(ZZ(1)) "RTN","XUS1",107,0) ; "RTN","XUS1",108,0) AUDIT ;Set-up Audit info "RTN","XUS1",109,0) N I,I1,I2 "RTN","XUS1",110,0) 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)1) XQAUDIT=1 Q "RTN","XUS1",112,0) 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 "RTN","XUS1",113,0) 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 "RTN","XUS1",114,0) Q "RTN","XUS1",115,0) ; "RTN","XUS1",116,0) DD(Y) Q $$FMTE^XLFDT(Y,1) "RTN","XUS1",117,0) ; "RTN","XUS1",118,0) KILL N %UCI,PGM,U,XQUR,XMCHAN G KILL1^XUSCLEAN "RTN","XUS1",119,0) Q "RTN","XUS1",120,0) NO G NO^XUS "RTN","XUS1B") 0^1^B8553582^B3544888 "RTN","XUS1B",1,0) XUS1B ;ISCSF/RWF - Auto sign-on ;10/27/10 15:14 "RTN","XUS1B",2,0) ;;8.0;KERNEL;**59,337,395,469,543**;Jul 10, 1995;Build 15 "RTN","XUS1B",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","XUS1B",4,0) Q "RTN","XUS1B",5,0) ; "RTN","XUS1B",6,0) AUTOXUS() ;Do the check for XUS and Auto Sign-on "RTN","XUS1B",7,0) N %,FG,Y "RTN","XUS1B",8,0) I $G(XQXFLG("ASO")) Q 0 ;Already tried once. "RTN","XUS1B",9,0) G AUTO "RTN","XUS1B",10,0) ; "RTN","XUS1B",11,0) AUTOXWB() ;Do the check for XWB and Auto Sign-on "RTN","XUS1B",12,0) N %,FG,Y,NUNOW "RTN","XUS1B",13,0) I $G(XQXFLG("ASO")) Q 0 ;Already tried so skip. "RTN","XUS1B",14,0) S XUNOW=$$NOW^XLFDT ;p543 "RTN","XUS1B",15,0) AUTO ;Common code "RTN","XUS1B",16,0) I ($T(^XWBCAGNT)="")!($P(XOPT,U,18)="d") S XQXFLG("ZEBRA")=-1 Q 0 ;Disabled "RTN","XUS1B",17,0) S Y=$$CHKVIP(),%=0 "RTN","XUS1B",18,0) I Y>0 S %=$$PREF($P(XOPT,U,18),$P($G(^VA(200,Y,200)),U,18)) "RTN","XUS1B",19,0) I Y>0,'% S Y=0 ;No Auto signon "RTN","XUS1B",20,0) I Y>0 S DUZ(2)=+FG ;Set Division p543 "RTN","XUS1B",21,0) Q Y "RTN","XUS1B",22,0) ; "RTN","XUS1B",23,0) CHKVIP() ;Check for a Valid current IP "RTN","XUS1B",24,0) N REF,XREF,IEN,R0,ENV,JOB,HNDL,XTMP "RTN","XUS1B",25,0) ;D SETUP ;To log data for debug "RTN","XUS1B",26,0) S IEN=0,ENV=$$ENV,REF=$G(IO("IP")) I $L(REF) D GETHNDL(.HNDL) "RTN","XUS1B",27,0) ;Look thru the IP X-ref "RTN","XUS1B",28,0) I $L(REF) D LKUP("AS1",$P(REF,":")) ;Will set IEN "RTN","XUS1B",29,0) Q IEN "RTN","XUS1B",30,0) ; "RTN","XUS1B",31,0) LKUP(XREF,LK) ;Check one X-ref "RTN","XUS1B",32,0) N R0,R1,IX,D1,NM ;p543 "RTN","XUS1B",33,0) S IX=0,IEN=0 "RTN","XUS1B",34,0) F S IX=$O(^XUSEC(0,XREF,LK,IX)) Q:'$L(IX) D CHK Q:IEN>0 "RTN","XUS1B",35,0) Q "RTN","XUS1B",36,0) CHK ;Could this be a good one. "RTN","XUS1B",37,0) S R0=$G(^XUSEC(0,IX,0)) "RTN","XUS1B",38,0) ;Check that IP really matches "RTN","XUS1B",39,0) I $P(R0,U,11)'=REF Q ;p543 "RTN","XUS1B",40,0) ;Check entry does not have sign-off D/T. p543 "RTN","XUS1B",41,0) I $P(R0,U,4) Q "RTN","XUS1B",42,0) ;If have a Client name check that same as log. "RTN","XUS1B",43,0) S NM=$$LOW^XLFSTR($P(R0,U,12)) "RTN","XUS1B",44,0) I $D(IO("CLNM")),$L(NM),NM'=$$LOW^XLFSTR(IO("CLNM")) Q "RTN","XUS1B",45,0) ;Check date within 8 hours p543 "RTN","XUS1B",46,0) S D1=$$FMDIFF^XLFDT(XUNOW,IX,2) I (D1>28800)!(D1<-5) Q "RTN","XUS1B",47,0) ;Check handle. Use timeout on Lock p543 "RTN","XUS1B",48,0) S R1=$P(R0,U,13) I $L(R1),$D(HNDL(R1)) D "RTN","XUS1B",49,0) . L +^XWB("SESSION",IX_"~"_R1):DILOCKTM I $T L -^XWB("SESSION",IX_"~"_R1) Q "RTN","XUS1B",50,0) . ;Remove D LOG after debug. "RTN","XUS1B",51,0) . S IEN=+R0,FG=$P(R0,"^",17),XQXFLG("ASO")=IX ;D LOG Q ;Found a match "RTN","XUS1B",52,0) . Q "RTN","XUS1B",53,0) Q "RTN","XUS1B",54,0) ; "RTN","XUS1B",55,0) ENV() N Y D GETENV^%ZOSV "RTN","XUS1B",56,0) Q Y "RTN","XUS1B",57,0) ; "RTN","XUS1B",58,0) PREF(%1,%2) ; "RTN","XUS1B",59,0) Q $S($L(%2):%2,1:%1) "RTN","XUS1B",60,0) ; "RTN","XUS1B",61,0) GETHNDL(RET) ;Get the Handles from the Client "RTN","XUS1B",62,0) N %,%1,X,XXX,TS "RTN","XUS1B",63,0) ;Don't call Terminal servers/Proxy's "RTN","XUS1B",64,0) S TS=$G(IO("IP")) "RTN","XUS1B",65,0) I $L(TS),$O(^XTV(8989.3,1,405.2,"B",TS,0)) S XQXFLG("ZEBRA")=-1 Q ;Disable to TS and Proxy's "RTN","XUS1B",66,0) S %=$$CMD^XWBCAGNT(.XXX,"XWB GET HANDLES") I '% S XQXFLG("ZEBRA")=-1 Q ;Disable on Timeout p543 "RTN","XUS1B",67,0) Q:'$O(XXX(0)) "RTN","XUS1B",68,0) ;build array "RTN","XUS1B",69,0) S RET=0,%1=1 F %=1:1:$L(XXX(%1),"^") S X=$P(XXX(%1),"^",%) S:X]"" RET(X)="",RET=RET+1 "RTN","XUS1B",70,0) Q "RTN","XUS1B",71,0) ;Temp for data collection "RTN","XUS1B",72,0) SETUP ; "RTN","XUS1B",73,0) N N1,N2 "RTN","XUS1B",74,0) I '$D(^XTMP("XUSP543","CNT")) S ^XTMP("XUSP543",0)=$$HTFM^XLFDT($H+30)_"^"_XUNOW,^("CNT")=0 "RTN","XUS1B",75,0) S N1="XUSP543",N2="CNT" "RTN","XUS1B",76,0) X "S XTMP=$INCREMENT(^XTMP(N1,N2))" "RTN","XUS1B",77,0) S ^XTMP("XUSP543",XTMP,0)=$G(IO("IP"))_U_$G(IO("ZIO"))_U_XUNOW "RTN","XUS1B",78,0) Q "RTN","XUS1B",79,0) ; "RTN","XUS1B",80,0) LOG ;Log more data "RTN","XUS1B",81,0) M ^XTMP("XUSP543",XTMP,"HNDL")=HNDL "RTN","XUS1B",82,0) S ^XTMP("XUSP543",XTMP,"R0")=R0,^("R1")=R1,^("IX")=IX "RTN","XUS1B",83,0) Q "RTN","XUSPURGE") 0^2^B8394877^B7738964 "RTN","XUSPURGE",1,0) XUSPURGE ;SFISC/STAFF - PURGE ROUTINE FOR XUSEC ;03/18/10 07:10 "RTN","XUSPURGE",2,0) ;;8.0;KERNEL;**180,312,543**;Jul 10, 1995;Build 15 "RTN","XUSPURGE",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","XUSPURGE",4,0) SCPURG ;Purge sign-on log to 30 days "RTN","XUSPURGE",5,0) N XU1,XU2,XUDT,DIK,DA,DIE,DR,XUNOW "RTN","XUSPURGE",6,0) S XUDT=$$FMADD^XLFDT(DT,-30),XUNOW=$$NOW^XLFDT() ;Set the limit "RTN","XUSPURGE",7,0) I $O(^XUSEC(0,0))'>0 Q "RTN","XUSPURGE",8,0) F DA=0:0 S DA=$O(^XUSEC(0,DA)) Q:(DA'>0)!(DA>XUDT) D "RTN","XUSPURGE",9,0) . S XU1=$G(^XUSEC(0,DA,0)),XU2=+XU1 "RTN","XUSPURGE",10,0) . ;Enter a SIGN OFF time to clear the X-ref's p543 "RTN","XUSPURGE",11,0) . I $P(XU1,U,4)="" S DR="3////"_XUNOW,DIE="^XUSEC(0," D ^DIE "RTN","XUSPURGE",12,0) . ;Now kill the record. "RTN","XUSPURGE",13,0) . S DIK="^XUSEC(0," D ^DIK "RTN","XUSPURGE",14,0) . ;Make sure the CUR X-ref is cleared. "RTN","XUSPURGE",15,0) . I XU1 K ^XUSEC(0,"CUR",XU2,DA) "RTN","XUSPURGE",16,0) . Q "RTN","XUSPURGE",17,0) Q "RTN","XUSPURGE",18,0) ; "RTN","XUSPURGE",19,0) AOLD ; "RTN","XUSPURGE",20,0) N DIRUT,DIR,XUT,XUDAYS,XUDT,XUI,XUJ,XUK,X "RTN","XUSPURGE",21,0) I $D(ZTQUEUED) D Q "RTN","XUSPURGE",22,0) . S X=$G(ZTQPARAM),X=$S(X<270:270,1:X) D A02(X),V02(X) "RTN","XUSPURGE",23,0) . Q "RTN","XUSPURGE",24,0) W !!,"This option will purge the log of inactive access and verify codes ",!,"older than the date specified to allow for their re-use." "RTN","XUSPURGE",25,0) S DIR("A")="Do you wish to continue",DIR(0)="Y",DIR("B")="NO" D ^DIR G:$D(DIRUT)!(Y'=1) ENDA "RTN","XUSPURGE",26,0) DAYS K DIR S DIR("A")="How far back do you wish to retain codes",DIR("A",1)="VHA has set the minimum time to keep old codes at 270 days.",DIR("B")=270 "RTN","XUSPURGE",27,0) S DIR("?")="Enter the number of days indicating at what date codes should be purged.",DIR(0)="N^270:400" "RTN","XUSPURGE",28,0) D ^DIR Q:$D(DIRUT) "RTN","XUSPURGE",29,0) D A02(X),V02(X) "RTN","XUSPURGE",30,0) Q "RTN","XUSPURGE",31,0) ; "RTN","XUSPURGE",32,0) A02(XUDAYS) ;Purge old Access codes in the AOLD x-ref. "RTN","XUSPURGE",33,0) N XUT,XUI,XUJ,XUK,XUDT "RTN","XUSPURGE",34,0) S XUT=0,XUDT=$H-XUDAYS,XUI="" "RTN","XUSPURGE",35,0) F S XUI=$O(^VA(200,"AOLD",XUI)) Q:XUI="" S XUJ=$O(^(XUI,0)) S XUK=^(XUJ) I XUK0 S XUK="" D "RTN","XUSPURGE",43,0) . F S XUK=$O(^VA(200,XUI,"VOLD",XUK)) Q:XUK="" I ^(XUK)0 S %ZDA=+%ZY,%ZFN=$P(%ZY(0),U,2),IO("DOC")=$P(%ZY(0),U,1) G OK:$D(IO("Q")) "RTN","ZIS4ONT",62,0) G:'%ZISB OK I '$P(%ZY,"^",3),%ZFN]"" D SPL3 G NO:%ZFN<0,DOC "RTN","ZIS4ONT",63,0) I %ZOS="NT" D G:%ZFN>255 NO "RTN","ZIS4ONT",64,0) . F %ZFN=1:1:260 I '$D(^XMB(3.51,"C",%ZFN))!$D(^(%ZFN,%ZDA)) Q:%ZFN<256 W:'$D(IOP) $C(7)_" DELETE SOME OTHER DOCUMENT!" Q "RTN","ZIS4ONT",65,0) . Q:%ZFN>255 D SPL2 S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)="" "RTN","ZIS4ONT",66,0) I %ZOS'="NT" D G:%ZFN=-1 NO ;For VMS & UNIT p546 "RTN","ZIS4ONT",67,0) . S %ZFN=IO_"SPOOL_no_"_%ZDA_".TMP" D SPL2 Q:%ZFN=-1 S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)="",IO=%ZFN "RTN","ZIS4ONT",68,0) DOC S IO("SPOOL")=%ZDA,^XUTL("XQ",$J,"SPOOL")=%ZDA "RTN","ZIS4ONT",69,0) I $D(^%ZIS(1,%ZISIOS,1)),$P(^(1),"^",8),$O(^("SPL",0)) S ^XUTL("XQ",$J,"ADSPL")=%ZISIOS,ZISPLAD=%ZISIOS "RTN","ZIS4ONT",70,0) OK K %ZDA,%ZFN Q "RTN","ZIS4ONT",71,0) NO K %ZDA,%ZFN,IO("DOC") S POP=1 Q "RTN","ZIS4ONT",72,0) ; "RTN","ZIS4ONT",73,0) SPL2 ;Open for output "RTN","ZIS4ONT",74,0) I %ZOS="NT" O IO:(%ZFN:0) S IO(1,IO)="",^SPOOL(0,IO("DOC"),%ZFN)="",^SPOOL(%ZFN,0)=IO("DOC")_"{"_$H Q "RTN","ZIS4ONT",75,0) ;VMS "RTN","ZIS4ONT",76,0) O %ZFN:("WNS"):2 G:'$T SPL4 S IO(1,%ZFN)="" Q "RTN","ZIS4ONT",77,0) ; "RTN","ZIS4ONT",78,0) SPL3 ;Open to read "RTN","ZIS4ONT",79,0) I %ZOS="NT" G SPL4:'$D(^SPOOL(%ZFN,2147483647)) O IO:(%ZFN:$P(^(2147483647),"{",3)):1 S:'$T ZISPLQ=1 K ^(2147483647) S IO(1,IO)="" Q "RTN","ZIS4ONT",80,0) ;VMS "RTN","ZIS4ONT",81,0) N $ETRAP S $ETRAP="S $EC="""" G SPL4^%ZIS4" "RTN","ZIS4ONT",82,0) O %ZFN:"RV":1 S:'$T ZISPLQ=1 G:$ZA<0!('$T) SPL4 S IO(1,%ZFN)="" Q "RTN","ZIS4ONT",83,0) ; "RTN","ZIS4ONT",84,0) SPL4 W:'$D(IOP) !,"Spool file already open" S %ZFN=-1 Q "RTN","ZIS4ONT",85,0) ; "RTN","ZIS4ONT",86,0) CLOSE ;Handle Close and copy to Global "RTN","ZIS4ONT",87,0) N %,%ZOS,%Z1,%ZCR,%2,%3,%X,%Y,ZTSK,%ZFN S %ZOS=$$OS^%ZOSV "RTN","ZIS4ONT",88,0) I %ZOS="NT",IO=2,$D(IO(1,IO)) K IO(1,IO) C IO "RTN","ZIS4ONT",89,0) I %ZOS="VMS",$L(IO),$D(IO(1,IO)) U IO S %ZFN=$ZIO C IO K IO(1,IO) "RTN","ZIS4ONT",90,0) I %ZOS="UNIX",$L(IO),$D(IO(1,IO)) C IO K IO(1,IO) "RTN","ZIS4ONT",91,0) ;See that ZTSK is set so we will move to the global now. "RTN","ZIS4ONT",92,0) S ZTSK=$G(ZTSK,1) D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q "RTN","ZIS4ONT",93,0) G:%ZOS'="NT" CLVMS ;p546 "RTN","ZIS4ONT",94,0) S %ZFN=$P(%ZS,"^",2),%ZCR=$C(13),%Y="",%=0,%3=$P(^SPOOL(%ZFN,2147483647),"{",3) "RTN","ZIS4ONT",95,0) S %Z1=+$G(^XTV(8989.3,1,"SPL")) "RTN","ZIS4ONT",96,0) F %2=1:1:%3 Q:'$D(^SPOOL(%ZFN,%2)) S %X=^SPOOL(%ZFN,%2) D "RTN","ZIS4ONT",97,0) . I %Z1<% D LIMIT S %2=%3 Q "RTN","ZIS4ONT",98,0) . I %X[$C(13,12) D:$L($P(%X,$C(13))) ADD($P(%X,$C(13))) D ADD("|TOP|") Q "RTN","ZIS4ONT",99,0) . D ADD($P(%X,$C(13),1)) "RTN","ZIS4ONT",100,0) K ^SPOOL(%ZFN),^SPOOL(0,$P(%ZS,U,1)),%Y,%X,%1,%2,%3 D CLOSE^ZISPL1 "RTN","ZIS4ONT",101,0) Q "RTN","ZIS4ONT",102,0) ADD(L) S %=%+1,^XMBS(3.519,XS,2,%,0)=L "RTN","ZIS4ONT",103,0) Q "RTN","ZIS4ONT",104,0) LIMIT D ADD("*** INCOMPLETE REPORT -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***") S $P(^XMB(3.51,%ZDA,0),"^",11)=1 "RTN","ZIS4ONT",105,0) Q "RTN","ZIS4ONT",106,0) CLVMS ;Close for Cache VMS & Linux "RTN","ZIS4ONT",107,0) N $ES,$ET S $ET="D:$EC'[""ENDOF"" ^%ZTER,UNWIND^%ZTER S $EC="""" D SPLEX^%ZIS4,UNWIND^%ZTER" "RTN","ZIS4ONT",108,0) S %ZA=$ZU(68,40,1) ;Work like DSM "RTN","ZIS4ONT",109,0) ;%ZFN Could be set at the top "RTN","ZIS4ONT",110,0) S %ZFN=$S($G(%ZFN)]"":%ZFN,1:$P(%ZS,"^",2)) D SPL3 Q:%ZFN']"" U %ZFN S %ZCR=$C(13),%Y="" "RTN","ZIS4ONT",111,0) S %Z1=+$G(^XTV(8989.3,1,"SPL")),%=0 "RTN","ZIS4ONT",112,0) F R %X#255:5 Q:$ZEOF<0 D G:%Z1<% SPLEX "RTN","ZIS4ONT",113,0) . I %Z1<% D LIMIT Q "RTN","ZIS4ONT",114,0) . I %X[$C(12) D Q "RTN","ZIS4ONT",115,0) . . S %Y=$P(%X,$C(12)) D:$L(%Y) ADD(%Y),ADD("|TOP|") "RTN","ZIS4ONT",116,0) . . S %Y=$P(%X,$C(12),2) D:$L(%Y) ADD(%Y) "RTN","ZIS4ONT",117,0) . . Q "RTN","ZIS4ONT",118,0) . D ADD(%X) "RTN","ZIS4ONT",119,0) . Q "RTN","ZIS4ONT",120,0) SPLEX C %ZFN:"D" K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q "RTN","ZIS4ONT",121,0) ; "RTN","ZIS4ONT",122,0) ; "RTN","ZIS4ONT",123,0) HFS G HFS^%ZISF "RTN","ZIS4ONT",124,0) REWMT(IO2,IOPAR) ;Rewind Magtape "RTN","ZIS4ONT",125,0) N $ETRAP S $ET="G REWERR^%ZIS4" "RTN","ZIS4ONT",126,0) U IO2 W *5 "RTN","ZIS4ONT",127,0) Q 1 "RTN","ZIS4ONT",128,0) REWSDP(IO2,IOPAR) ;Rewind SDP "RTN","ZIS4ONT",129,0) G REW1 "RTN","ZIS4ONT",130,0) REWHFS(IO2,IOPAR) ;Rewind Host File. "RTN","ZIS4ONT",131,0) REW1 ;ZIS set % to the current $I so need to update % if = IO "RTN","ZIS4ONT",132,0) N NIO,OP,$ETRAP "RTN","ZIS4ONT",133,0) S $ET="G REWERR^%ZIS4" "RTN","ZIS4ONT",134,0) C IO2 ;You do a rewind to read the file. "RTN","ZIS4ONT",135,0) S OP=$S($ZV["VMS":"RV",1:"RS") "RTN","ZIS4ONT",136,0) O IO2:(OP):1 S IO(1,IO2)="" "RTN","ZIS4ONT",137,0) Q 1 "RTN","ZIS4ONT",138,0) REWERR ;Error encountered "RTN","ZIS4ONT",139,0) S IO("ERROR")=$EC,$ECODE="" "RTN","ZIS4ONT",140,0) Q 0 "VER") 8.0^22.0 "BLD",1293,6) ^461 **END** **END**