Changeset 636 for FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XGKB.m

-              r628
+              r636
 XGKB ;SFISC/VYD - Read with Escape Processing ;10/23/2006
  ;;8.0;KERNEL;**34,244,365**;Jul 10, 1995;Build 5
+XGKB ;SFISC/VYD - Read with Escape Processing ;07/10/2002  10:58
+ ;;8.0;KERNEL;**34,244**;Jul 10, 1995
  ;;Special thanks to MELDRUM.KEVIN@ISC-SLC.VA.GOV
+ ;
 …
  I %OS["MSM" U $I:(0::::64) D:'$D(^XUTL("XGKB")) MSM^XGKB1
  I %OS["DTM" U $I:(VT=1:ESCAPE=1) D:'$D(^XUTL("XGKB")) DTM^XGKB1
  I %OS["OpenM" U $I:(:"CT") D:'$D(^XUTL("XGKB")) DTM^XGKB1 S:$G(XGTRM)="*" XGTRM=""
+ I %OS["OpenM" U $I:(:"CT") D:'$D(^XUTL("XGKB")) DTM^XGKB1
  I %OS["GT.M" U $I:(ESCAPE) D:'$D(^XUTL("XGKB")) GTM^XGKB1
  I $G(XGTRM)="*" X ^%ZOSF("TRMON") I 1 ;turn all on

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDDP.m

-              r628
+              r636
+XPDDP ;SFISC/RSD - Display a package ;03/18/2008
+ ;;8.0;KERNEL;**21,28,44,68,100,108,229,304,346,463,488**;Jul 10, 1995;Build 6
+ ; Per VHA Directive 2004-038, this routine should not be modified.
+ ; Options: XPD PRINT BUILD calls EN1
+ ;          XPD PRINT INSTALL calls EN2
+EN1 ; Print from Build file
+ N DIC,D0,XPD,XPDT,XPDST,Y
+XPDDP ;SFISC/RSD - Display a package ;6/21/07  09:44
+ ;;8.0;KERNEL;**21,28,44,68,100,108,229,304,346,463**;Jul 10, 1995;Build 4
+EN1 ;print from Build file
+ N DIC,D0,XPD,XPDT,XPDST,Y,Z
  S XPDST=$$LOOK^XPDB1 Q:XPDST<0
  S XPD("XPDT(")=""
  D EN^XUTMDEVQ("LST1^XPDDP","Build File Print",.XPD)
+ S XPD("XPDT(")="",Y="LST1^XPDDP",Z="Build File Print"
+ D EN^XUTMDEVQ(Y,Z,.XPD)
+ Q
 EN2 ; Print from Distribution
+EN2 ;print from Distribution
  N D0,DIC,POP,XPD,XPDA,XPDNM,XPDT,XPDST,Y,Z,%ZIS
  S XPDST=$$LOOK^XPDI1("I $D(^XTMP(""XPDI"",Y))",1)
  S D0=$O(^XTMP("XPDI",XPDST,"BLD",0)) Q:'D0
  S XPD("XPDT(")=""
  D EN^XUTMDEVQ("LST2^XPDDP","Transport Global Print",.XPD)
+ S XPD("XPDT(")="",Y="LST2^XPDDP",Z="Transport Global Print",D0=$O(^XTMP("XPDI",XPDST,"BLD",0))
+ Q:'D0
+ D EN^XUTMDEVQ(Y,Z,.XPD)
+ Q
+LST1 ; Print from Build file
+ K DIRUT N XPDIT,XPDCNT S (XPDIT,XPDCNT)=0
+ F  S XPDIT=$O(XPDT(XPDIT)) Q:$D(DIRUT)!(XPDIT'>0)  D  Q:$D(DIRUT)
+ . I XPDCNT Q:'$$CONT
+ . S XPDCNT=XPDCNT+1
+ ;
+LST1 ;
+ K DIRUT N XPDIT S XPDIT=0
+ F  S XPDIT=$O(XPDT(XPDIT)) Q:$D(DIRUT)!(XPDIT'>0)  D
  . S D0=+XPDT(XPDIT) D PNT("XPD(9.6,D0)")
- D WAIT
+ Q
+LST2 ; Print from XPDT array
+ K DIRUT N XPDIT,XPDCNT S (XPDIT,XPDCNT)=0
+ F  S XPDIT=$O(XPDT(XPDIT)) Q:$D(DIRUT)!(XPDIT'>0)  D  Q:$D(DIRUT)
+ . I XPDCNT Q:'$$CONT
+ . S XPDCNT=XPDCNT+1
+ ;
+LST2 ;Print from XPDT array
+ K DIRUT N XPDIT S XPDIT=0
+ F  S XPDIT=$O(XPDT(XPDIT)) Q:$D(DIRUT)!(XPDIT'>0)  D
  . S XPDA=+XPDT(XPDIT),D0=$O(^XTMP("XPDI",XPDA,"BLD",0)) D PNT("XTMP(""XPDI"",XPDA,""BLD"",D0)")
- D WAIT
+ Q
+WAIT ; Pause on last page or not? It depends on whether there's enough room
+ ; left on the page to display the KIDS menu.
+ Q:$E($G(IOST),1,2)'="C-"
+ Q:$D(DIRUT)
+ ; DUZ("AUTO")=1 means show menu option choices
+ I IOSL-$Y<$S($G(DUZ("AUTO")):14,1:3) D WAIT^XMXUTIL
+ Q
+PNT(XPDGR) ; Print a package, XPDGR=global root
+ ;XPDFL=0 - Build   - ^XPD(9.7 global root
+ ;      1 - Install - ^XTMP global root
+ ;      2 - Packman - ^TMP($J, global root
+ N I,J,K,X,XPD,XPDDT,XPDI,XPD0,XPDFL,XPDPG,XPDUL,XPDTYPE,XPDTRACK,XPDTXT
+ ;
+PNT(XPDGR) ;print a package, XPDGR=global root
+ ;XPDFL=0 - Build - ^XPD(9.7 global root, 1 - Install - ^XTMP global root
+ ;2 - Packman ^TMP($J, global root
+ N I,J,K,X,XPD,XPDDT,XPDI,XPD0,XPDFL,XPDPG,XPDUL,XPDTYPE,XPDTRACK,XPDTXT,XPDOUT
  Q:$G(XPDGR)=""  S XPDGR="^"_XPDGR
  Q:'$D(@XPDGR@(0))
+ D ID                     ; Package Identification
+ D DESCR Q:$D(DIRUT)      ; Description
+ I XPDTYPE=1 D MULT Q     ; Multi-Package
+ D PREPOST Q:$D(DIRUT)    ; Environment check & Pre/Post Routines
+ I XPDTYPE=2 D GLOBAL Q   ; Global Package
+ D FILES Q:$D(DIRUT)      ; Files/DDs
+ D COMP Q:$D(DIRUT)       ; Build Components
+ Q:XPDFL=2  ; Packman message, called from XMP2 - Summarize
+ D QUESTS Q:$D(DIRUT)     ; Install Questions
+ D ALFABETA Q:$D(DIRUT)   ; Alpha/Beta Testing
+ D NAMESP Q:$D(DIRUT)     ; Include/Exclude Namespaces
+ D REQDBLD Q:$D(DIRUT)    ; Required Builds
+ S XPD0=^(0),XPDPG=1,XPDFL=$S($E(XPDGR,1,5)="^TMP(":2,1:$E(XPDGR,1,5)="^XTMP"),$P(XPDUL,"-",IOM)="",XPDDT=$$HTE^XLFDT($H,"1PM"),XPDTYPE=+$P(XPD0,U,3),XPDTRACK=$P(XPD0,U,5)
+ W:$E(IOST,1,2)="C-" @IOF D HDR W XPDUL,!
+ W "TYPE: ",$$EXTERNAL^DILFD(9.6,2,"",XPDTYPE)
+ W !,"TRACK NATIONALLY: ",$$EXTERNAL^DILFD(9.6,5,"",XPDTRACK)
+ W !,"NATIONAL PACKAGE: ",$P($G(^DIC(9.4,+$P(XPD0,U,2),0),$P(XPD0,U,2)),U)
+ W !,"ALPHA/BETA TESTING: ",$S($P($G(@XPDGR@("ABPKG")),U)="y":"YES",1:"NO") ; new line added.
+ W !,"DESCRIPTION:"
+ S (XPDI,XPDOUT)=0
+ F  S XPDI=$O(@XPDGR@(1,XPDI)) Q:'XPDI  S XPDTXT=$G(^(XPDI,0)) D  Q:XPDOUT
+ . I $L(XPDTXT)'<IOM,$E(XPDTXT,$L(XPDTXT))=" " F  S XPDTXT=$E(XPDTXT,1,$L(XPDTXT)-1) Q:$E(XPDTXT,$L(XPDTXT))'=" "
+ . F  D  Q:$L(XPDTXT)<IOM!XPDOUT!(IOM<2)  S XPDTXT=$E(XPDTXT,IOM,999)
+ . . W $S(IOM>1:$E(XPDTXT,1,IOM-1),1:XPDTXT),!
+ . . S XPDOUT=$$CHK(2)
+ Q:$D(DIRUT)  G:XPDTYPE=1 MULT
+ W !,"ENVIRONMENT CHECK : ",$G(@XPDGR@("PRE"))
+ W ?47,"DELETE ENV ROUTINE: ",$S($P($G(@XPDGR@("INID")),U)="y":"Yes",1:"No")
+ W !
+ I 'XPDTYPE D
+ . W " PRE-INIT ROUTINE : ",$G(@XPDGR@("INI"))
+ . W ?42,"DELETE PRE-INIT ROUTINE: ",$S($P($G(@XPDGR@("INID")),U,3)="y":"Yes",1:"No")
+ . W !
+ Q:$$CHK(4)  W "POST-INIT ROUTINE : ",$G(@XPDGR@("INIT"))
+ W ?41,"DELETE POST-INIT ROUTINE: ",$S($P($G(@XPDGR@("INID")),U,2)="y":"Yes",1:"No")
+ W !
+ W:'XPDTYPE "PRE-TRANSPORT RTN : ",$G(@XPDGR@("PRET")),!
+ G:XPDTYPE=2 GLOBAL
+ I '$O(@XPDGR@(4,0)) Q:$$CHK(4)  G COMP
+ S I=$$CHK(10,1) Q:I  I '$P(I,"^",2) W !! D HDR1 W XPDUL,!
+PNT2 S XPDI=0 F  S XPDI=$O(@XPDGR@(4,XPDI)) Q:'XPDI  S XPD=$G(^(XPDI,222)) Q:$$CHK(4,1)  D
+ .;file number, file name, partial DD
+ .W !,XPDI,?12,$S('XPDFL:$P($G(^DIC(XPDI,0),"**unknown**"),U),1:$G(^XTMP("XPDI",XPDA,"FIA",XPDI)))
+ .W ?41,$$EXTERNAL^DILFD(9.64,222.1,"",$P(XPD,U)),?47,$$EXTERNAL^DILFD(9.64,222.2,"",$P(XPD,U,2)),?53,$$EXTERNAL^DILFD(9.64,222.7,"",$P(XPD,U,7))
+ .W ?60,$E($$EXTERNAL^DILFD(9.64,222.8,"",$P(XPD,U,8)),1,4),?67,$$EXTERNAL^DILFD(9.64,222.5,"",$P(XPD,U,5)),?73,$$EXTERNAL^DILFD(9.64,222.9,"",$P(XPD,U,9)),!
+ .;print partial DD information
+ .I $P(XPD,U,3)="p" S J=0 D
+ ..W "Partial DD:"
+ ..F  S J=$O(@XPDGR@(4,"APDD",XPDI,J)) Q:'J  W ?12,"subDD: ",J D  Q:$$CHK(4,1)
+ ...I '$O(@XPDGR@(4,"APDD",XPDI,J,0)) W ! Q
+ ...S I=0 F  S I=$O(@XPDGR@(4,"APDD",XPDI,J,I)) Q:'I  W ?30,"fld: ",I,!
+ .I $D(@XPDGR@(4,XPDI,223)) W ?2,"DD SCREEN  : ",^(223),!
+ .I $D(@XPDGR@(4,XPDI,224)) W ?2,"DATA SCREEN: ",^(224),!
+COMP Q:$D(DIRUT)  W ! Q:$$CHK(3)  S I=0,XPD=$P(^DD(9.68,.03,0),U,3)
+ ;print build components
+ F  S I=$O(@XPDGR@("KRN",I)),K=0,J="" Q:$D(DIRUT)!'I  F  S J=$O(@XPDGR@("KRN",I,"NM","B",J)) Q:J=""  S X=$O(^(J,0)) Q:$$CHK(4)  D:X
+ .S X=$G(@XPDGR@("KRN",I,"NM",X,0)) Q:X=""
+ .;K is flag to write type of component
+ .I 'K W !,$S($D(^DIC(I,0)):$P(^(0),U),XPDFL:$G(^XTMP("XPDI",XPDA,"FIA",I),"UNKNOWN"),1:"UNKNOWN")_":",! S K=1
+ .;write the entry name and write the action
+ .W ?3,$P(X,U),?50,$P($P(XPD,";",$P(X,U,3)+1),":",2),!
+ Q:XPDFL=2
+ ;XPDFL=2 this is a Packman message, called from XMP2 - Summarize
+ ;XPDFL=1 this is a Install, the call backs are already Build Components
+ Q:$D(DIRUT)  Q:$$CHK(3)
+ I $O(@XPDGR@("QUES",0))!($D(@XPDGR@("QDEF"))#2) W !,"INSTALL QUESTIONS: " S I=0 D
+ .F  S I=$O(@XPDGR@("QUES",I)) Q:'I  S X=$P(^(I,0),U),J=$G(^(1)),K=$G(^("A")) Q:$$CHK(5)  D
+ ..W !?5,"SUBSCRIPT: ",X,!,"DIR(0)=",J W:K]"" !,"DIR(""A"")=",K,!
+ ..F J=1:1 Q:'$D(@XPDGR@("QUES",I,"A1",J,0))  W "DIR(""A"",",J,")=",^(0),!
+ ..I $G(@XPDGR@("QUES",I,"B"))]"" W "DIR(""B"")=",^("B"),!
+ ..I $G(@XPDGR@("QUES",I,"Q"))]"" W "DIR(""?"")=",^("Q"),!
+ ..F J=1:1 Q:'$D(@XPDGR@("QUES",I,"Q1",J,0))  W "DIR(""?"",",J,")=",^(0),!
+ ..I $G(@XPDGR@("QUES",I,"QQ"))]"" W "DIR(""??"")=",^("QQ"),!
+ ..I $G(@XPDGR@("QUES",I,"M"))]"" W "M CODE: ",^("M"),!
+ . Q:$D(DIRUT)  Q:$$CHK(3)
+ . ;Show new Defaults for KIDS questions. p463
+ . I $D(@XPDGR@("QDEF"))#2 S X=$G(@XPDGR@("QDEF")) D
+ . . W:$X>1 !
+ . . I $L($P(X,U,9)) W " Default Rebuild Menu Trees Upon Completion of Install: ",$P(X,U,9),!
+ . . I $L($P(X,U,5)) W " Default INHIBIT LOGONs during the install: ",$P(X,U,5),!
+ . . I $L($P(X,U,11)) W " Default DISABLE Scheduled Options, Menu Options, and Protocols: ",$P(X,U,11)
+ . . Q
+ . Q
+ Q:$D(DIRUT)  Q:$$CHK(3)
+ I $L($G(@XPDGR@("ABPKG"))) S XPD=^("ABPKG") D:$P(XPD,U)="y"
+ .W !,"ALPHA/BETA TESTING:",$$EXTERNAL^DILFD(9.6,20,"",$P(XPD,U)),?40,"INSTALLATION MESSAGE: ",$$EXTERNAL^DILFD(9.6,21,"",$P(XPD,U,2))
+ .W !,"ADDRESS: ",$P(XPD,U,3),!!,"INCLUDE NAMESPACE",?30,"EXCLUDE NAMESPACE" S I=0
+ .F  S I=$O(@XPDGR@("ABNS",I)),J=0 Q:'I  W !?5,^(I,0) F  S J=$O(@XPDGR@("ABNS",I,1,J)) Q:'J  W ?35,^(J,0),! Q:$$CHK(3)
+REQB Q:$D(DIRUT)  Q:$$CHK(4)
+ I $O(@XPDGR@("REQB",0)) W !,"REQUIRED BUILDS:",?50,"ACTION:" D
+ .S XPDI=0 F  S XPDI=$O(@XPDGR@("REQB",XPDI)) Q:'XPDI  S XPD=$G(^(XPDI,0)) Q:$$CHK(4,1)  D
+ ..W !?3,$P(XPD,U),?50,$$EXTERNAL^DILFD(9.611,1,"",$P(XPD,U,2))
+ Q
+ID ; Identify the package
+ S XPD0=^(0),XPDPG=1,XPDFL=$S($E(XPDGR,1,5)="^TMP(":2,1:$E(XPDGR,1,5)="^XTMP"),$P(XPDUL,"-",IOM)="",XPDDT=$$HTE^XLFDT($H,"1PM"),XPDTYPE=+$P(XPD0,U,3),XPDTRACK=$P(XPD0,U,5)
+ W:$E(IOST,1,2)="C-" @IOF D HDR W !,XPDUL
+ W !,"TYPE: ",$$EXTERNAL^DILFD(9.6,2,"",XPDTYPE)
+ W ?51,"TRACK NATIONALLY: ",$$EXTERNAL^DILFD(9.6,5,"",XPDTRACK)
+ W !,"NATIONAL PACKAGE: ",$P($G(^DIC(9.4,+$P(XPD0,U,2),0),$P(XPD0,U,2)),U)
+ W ?49,"ALPHA/BETA TESTING: ",$S($P($G(@XPDGR@("ABPKG")),U)="y":"YES",1:"NO")
+ Q
+DESCR ; Show patch description
+ W !!,"DESCRIPTION:"
+ S XPDI=0
+ F  S XPDI=$O(@XPDGR@(1,XPDI)) Q:'XPDI  S XPDTXT=$G(^(XPDI,0)) D  Q:$D(DIRUT)
+ . I $L(XPDTXT)'<IOM,$E(XPDTXT,$L(XPDTXT))=" " F  S XPDTXT=$E(XPDTXT,1,$L(XPDTXT)-1) Q:$E(XPDTXT,$L(XPDTXT))'=" "
+ . F  D  Q:$L(XPDTXT)<IOM!$D(DIRUT)!(IOM<2)  S XPDTXT=$E(XPDTXT,IOM,999)
+ . . Q:$$CHK(2)
+ . . W !,$S(IOM>1:$E(XPDTXT,1,IOM-1),1:XPDTXT)
+ Q
+PREPOST ; Environment check and pre/post routines
+ Q:$$CHK(3)
+ W !!,"ENVIRONMENT CHECK: ",$G(@XPDGR@("PRE"))
+ W ?49,"DELETE ENV ROUTINE: " I $G(@XPDGR@("PRE"))]"" W $S($P($G(@XPDGR@("INID")),U)="y":"Yes",1:"No")
+ I 'XPDTYPE D  Q:$D(DIRUT)
+ . Q:$$CHK(2)
+ . W !," PRE-INIT ROUTINE: ",$G(@XPDGR@("INI"))
+ . W ?44,"DELETE PRE-INIT ROUTINE: " I $G(@XPDGR@("INI"))]"" W $S($P($G(@XPDGR@("INID")),U,3)="y":"Yes",1:"No")
+ Q:$$CHK(2)
+ W !,"POST-INIT ROUTINE: ",$G(@XPDGR@("INIT"))
+ W ?43,"DELETE POST-INIT ROUTINE: " I $G(@XPDGR@("INIT"))]"" W $S($P($G(@XPDGR@("INID")),U,2)="y":"Yes",1:"No")
+ I 'XPDTYPE Q:$$CHK(2)  W !,"PRE-TRANSPORT RTN: ",$G(@XPDGR@("PRET"))
+ Q
+FILES ; Show files/DDs
+ Q:'$O(@XPDGR@(4,0))  ; Quit if no files
+ S I=$$CHK(8,1) Q:I  I '$P(I,"^",2) D HDR1 W !,XPDUL
+ S XPDI=0
+ F  S XPDI=$O(@XPDGR@(4,XPDI)) Q:'XPDI  S XPD=$G(^(XPDI,222)) Q:$$CHK(3,1)  D
+ . ;file number, file name, partial DD
+ . W !!,XPDI,?12,$S('XPDFL:$P($G(^DIC(XPDI,0),"**unknown**"),U),1:$G(^XTMP("XPDI",XPDA,"FIA",XPDI)))
+ . ; update DD, send security code, data comes with file
+ . W ?43,$$EXTERNAL^DILFD(9.64,222.1,"",$P(XPD,U)),?49,$$EXTERNAL^DILFD(9.64,222.2,"",$P(XPD,U,2)),?55,$$EXTERNAL^DILFD(9.64,222.7,"",$P(XPD,U,7))
+ . ; override site data, resolve pointers, user override
+ . W ?63,$E($$EXTERNAL^DILFD(9.64,222.8,"",$P(XPD,U,8)),1,4),?69,$$EXTERNAL^DILFD(9.64,222.5,"",$P(XPD,U,5)),?75,$$EXTERNAL^DILFD(9.64,222.9,"",$P(XPD,U,9))
+ . I $P(XPD,U,3)="p" D  Q:$D(DIRUT)
+ . . ; Print partial DD information
+ . . N XPDSUB,XPDFLD
+ . . Q:$$CHK(2,1)
+ . . W !,"Partial DD:"
+ . . S (J,XPDSUB)=0
+ . . F  S J=$O(@XPDGR@(4,"APDD",XPDI,J)) Q:'J  D  Q:$D(DIRUT)
+ . . . I XPDSUB Q:$$CHK(2,1)  W !
+ . . . W ?12,"subDD: ",J
+ . . . S XPDSUB=1,(I,XPDFLD)=0
+ . . . F  S I=$O(@XPDGR@(4,"APDD",XPDI,J,I)) Q:'I  D  Q:$D(DIRUT)
+ . . . . I XPDFLD Q:$$CHK(2,1)  W !
+ . . . . W ?30,"fld: ",I S XPDFLD=1
+ . I "  "'[$G(@XPDGR@(4,XPDI,223)) Q:$$CHK(2,1)  W !,?2,"DD SCREEN  : ",^(223)
+ . I "  "'[$G(@XPDGR@(4,XPDI,224)) Q:$$CHK(2,1)  W !,?2,"DATA SCREEN: ",^(224)
+ Q
+COMP ; Print Build components
+ S I=0,XPD=$P(^DD(9.68,.03,0),U,3)
+ F  S I=$O(@XPDGR@("KRN",I)) Q:'I  D   Q:$D(DIRUT)
+ . Q:'$D(@XPDGR@("KRN",I,"NM","B"))
+ . Q:$$CHK(4)
+ . W !!,$S($D(^DIC(I,0)):$P(^(0),U),XPDFL:$G(^XTMP("XPDI",XPDA,"FIA",I),"UNKNOWN"),1:"UNKNOWN")_":",?47,"ACTION:"
+ . S J=""
+ . F  S J=$O(@XPDGR@("KRN",I,"NM","B",J)) Q:J=""  S X=$O(^(J,0)) D  Q:$D(DIRUT)
+ . . Q:'X
+ . . S X=$G(@XPDGR@("KRN",I,"NM",X,0)) Q:X=""
+ . . Q:$$CHK(2)
+ . . ;write the entry name and write the action
+ . . W !,?3,$P(X,U),?50,$P($P(XPD,";",$P(X,U,3)+1),":",2)
+ Q
+QUESTS ; Show Install Questions
+ I '$O(@XPDGR@("QUES",0)),'($D(@XPDGR@("QDEF"))#2) Q
+ Q:$$CHK(6)
+ W !!,"INSTALL QUESTIONS: "
+ S I=0
+ F  S I=$O(@XPDGR@("QUES",I)) Q:'I  S X=$P(^(I,0),U),J=$G(^(1)),K=$G(^("A")) D  Q:$D(DIRUT)
+ . Q:$$CHK(4)
+ . W !!?5,"SUBSCRIPT: ",X
+ . W !,"DIR(0)=",J
+ . S J=0
+ . F  S J=$O(@XPDGR@("QUES",I,"A1",J)) Q:'J  Q:$$CHK(2)  W !,"DIR(""A"",",J,")=",^(J,0)
+ . I K]"" Q:$$CHK(2)  W !,"DIR(""A"")=",K
+ . I $G(@XPDGR@("QUES",I,"B"))]"" Q:$$CHK(2)  W !,"DIR(""B"")=",^("B")
+ . S J=0
+ . F  S J=$O(@XPDGR@("QUES",I,"Q1",J)) Q:'J  Q:$$CHK(2)  W !,"DIR(""?"",",J,")=",^(J,0)
+ . I $G(@XPDGR@("QUES",I,"Q"))]"" Q:$$CHK(2)  W !,"DIR(""?"")=",^("Q")
+ . I $G(@XPDGR@("QUES",I,"QQ"))]"" Q:$$CHK(2)  W !,"DIR(""??"")=",^("QQ")
+ . I $G(@XPDGR@("QUES",I,"M"))]"" Q:$$CHK(2)  W !,"M CODE: ",^("M")
+ Q:$D(DIRUT)
+ ;Show new Defaults for KIDS questions. p463
+ S X=$G(@XPDGR@("QDEF")) Q:X=""
+ I '$L($P(X,U,9)),'$L($P(X,U,5)),'$L($P(X,U,11)) Q
+ Q:$$CHK(3)  W !
+ I $L($P(X,U,9)) Q:$$CHK(2)  W !," Default Rebuild Menu Trees Upon Completion of Install: ",$P(X,U,9)
+ I $L($P(X,U,5)) Q:$$CHK(2)  W !," Default INHIBIT LOGONs during the install: ",$P(X,U,5)
+ I $L($P(X,U,11)) Q:$$CHK(2)  W !," Default DISABLE Scheduled Options, Menu Options, and Protocols: ",$P(X,U,11)
+ Q
+ALFABETA ; Alpha/Beta Testing
+ S XPD=$G(@XPDGR@("ABPKG")) Q:XPD=""
+ Q:$P(XPD,U)'="y"
+ Q:$$CHK(4)
+ W !!,"ALPHA/BETA TESTING: ",$$EXTERNAL^DILFD(9.6,20,"",$P(XPD,U)),?47,"INSTALLATION MESSAGE: ",$$EXTERNAL^DILFD(9.6,21,"",$P(XPD,U,2))
+ W !,"ADDRESS: ",$P(XPD,U,3)
+ Q
+NAMESP ; Namespaces
+ Q:'$O(@XPDGR@("ABNS",0))
+ Q:$$CHK(4)
+ W !!,"INCLUDE NAMESPACE:",?47,"EXCLUDE NAMESPACE:"
+ S I=0
+ F  S I=$O(@XPDGR@("ABNS",I)) Q:'I  Q:$$CHK(2)  W !?3,^(I,0) D  Q:$D(DIRUT)
+ . N XPDNMSP,XPDLF
+ . S (J,XPDLF)=0
+ . F  S J=$O(@XPDGR@("ABNS",I,1,J)) Q:'J  S XPDNMSP=^(J,0) D  Q:$D(DIRUT)
+ . . I XPDLF Q:$$CHK(2)  W !
+ . . W ?50,XPDNMSP
+ . . S XPDLF=1
+ Q
+REQDBLD ; Required Builds
+ Q:'$O(@XPDGR@("REQB",0))
+ Q:$$CHK(4)
+ W !!,"REQUIRED BUILDS:",?47,"ACTION:"
+ S XPDI=0
+ F  S XPDI=$O(@XPDGR@("REQB",XPDI)) Q:'XPDI  S XPD=$G(^(XPDI,0)) Q:$$CHK(2)  D
+ . W !?3,$P(XPD,U),?50,$$EXTERNAL^DILFD(9.611,1,"",$P(XPD,U,2))
+ Q
+GLOBAL ; Global Package
+ Q:$$CHK(4)
+ W !!,"GLOBAL:",?47,"KILL GLOBAL BEFORE INSTALL:"
+ S XPDI=0
+ F  S XPDI=$O(@XPDGR@("GLO",XPDI)) Q:'XPDI  S XPD=$G(^(XPDI,0)) Q:$$CHK(2)  D
+ . W !?3,$P(XPD,U),?50,$$EXTERNAL^DILFD(9.65,1,"",$P(XPD,U,2))
+ Q
+MULT ; Multi-Package
+ Q:$$CHK(4)
+ W !!,"SEQUENCE OF BUILDS:"
+ S XPDI=0
+ F  S XPDI=$O(@XPDGR@(10,XPDI)) Q:'XPDI  S XPD=$G(^(XPDI,0)) Q:$$CHK(2)  D
+ . W !?2,XPDI,?8,$E($P(XPD,U),1,44),?54,$S($P(XPD,U,2)=1:"",1:"Not ")_"Required to Continue"
+ Q
+GLOBAL ;globals listing
+ S I=$$CHK(8,1) Q:I  I '$P(I,"^",2) W !!,"GLOBAL:",?20,"KILL GLOBAL BEFORE INSTALL:"
+ S XPDI=0 F  S XPDI=$O(@XPDGR@("GLO",XPDI)) Q:'XPDI  S XPD=$G(^(XPDI,0)) Q:$$CHK(4,1)  D
+ .W !?3,$P(XPD,U),?33,$$EXTERNAL^DILFD(9.65,1,"",$P(XPD,U,2))
+ W ! Q
+ ;
+MULT ;multiple-package
+ S I=$$CHK(10,1) Q:I  I '$P(I,"^",2) W !,"SEQUENCE OF BUILDS:"
+ S XPDI=0 F  S XPDI=$O(@XPDGR@(10,XPDI)) Q:'XPDI  S XPD=$G(^(XPDI,0)) Q:$$CHK(4,1)  D
+ .W !?2,XPDI,?8,$E($P(XPD,U),1,44),?54,$S($P(XPD,U,2)=1:"",1:"Not ")_"Required to Continue"
+ W ! Q
+ ;
+ ;return 0 if header was not written, else "0^1"
 CHK(Y,XPD) ;Y=excess lines XPD=1 print file header, return 1 to exit
- ;return 0 if header was not written, else "0^1"
  Q:$Y<(IOSL-Y) 0
+ Q:'$$CONT 1
+ I $E(IOST,1,2)="C-" D  Q:'Y 1
+ .N DIR,I,J,K,X
+ .S DIR(0)="E" D ^DIR
  S XPD=$G(XPD),XPDPG=XPDPG+1
  W @IOF D HDR,HDR1:XPD
  W !,XPDUL
+ W XPDUL,!
  Q "0^1"
+CONT() ; Press Return to continue; ^ to exit.
+ Q:$D(DIRUT) 0
+ Q:$E(IOST,1,2)'="C-" 1
+ N DIR,I,J,K,X,Y
+ S DIR(0)="E" D ^DIR
+ Q Y
+ ;
 XMP2(X,D0) ;called from ^XMP2
  N XPDA S XPDA=-1
+ D PNT(X)
+ D PNT(X) Q
+ ;
+HDR W !,"PACKAGE: ",$P(XPD0,U),"     ",XPDDT,?70,"PAGE ",XPDPG,!
+ Q
 HDR ;
  W "PACKAGE: ",$P(XPD0,U),"     ",XPDDT,?70,$$RJ^XLFSTR("PAGE "_XPDPG,9)
+HDR1 W ?41,"UP",?47,"SEND",?53,"DATA",?73,"USER",!,?41,"DATE",?47,"SEC.",?53,"COMES",?60,"SITE",?67,"RSLV",?73,"OVER"
+ W !,"FILE #",?12,"NAME",?41,"DD",?47,"CODE",?53,"W/FILE",?60,"DATA",?67,"PTS",?73,"RIDE",!
+ Q
-HDR1 ;
- W !!,?43,"UP    SEND  DATA                USER"
- W !,?43,"DATE  SEC.  COMES   SITE  RSLV  OVER"
- W !,"FILE #",?12,"FILE NAME",?43,"DD    CODE  W/FILE  DATA  PTRS  RIDE"
+ Q

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDI.m

-              r628
+              r636
 XPDI ;SFISC/RSD - Install Process ;9/16/02  13:29
+XPDI ;SFISC/RSD - Install Process ;9:53 AM  31 Jan 2008
  ;;8.0;KERNEL;**10,21,39,41,44,58,68,108,145,184,229**;Jul 10, 1995
 EN ;install
 …
  Q:'XPDST!$D(XPDQUIT)
  S XPDIT=0,(XPDSET,XPDSET1)=$P(^XPD(9.7,XPDST,0),U) K ^TMP($J)
+ ;;
+ ;; Patch checker , points to file # 9.6  ; RED
+ D EN^VEPEFKPC(.XPDT,.XPDQUIT,1053) Q:$D(XPDQUIT)    ;VOE 1 Patch
+ D EN^VEPEFKPC(.XPDT,.XPDQUIT,1054) Q:$D(XPDQUIT)    ;VOE 1.1 Patch
+ D EN^VEPEFKPC(.XPDT,.XPDQUIT,7397) Q:$D(XPDQUIT)    ;NO HOME 1.0 Patch
+ ;
  ;Check each part of XPDT array
  F  S XPDIT=$O(XPDT(XPDIT)) Q:'XPDIT  D  Q:'$D(XPDT)!$D(XPDQUIT)

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDI1.m

-              r628
+              r636
 XPDI1 ;SFISC/RSD - Cont of Install Process ;10/28/2002  17:14
  ;;8.0;KERNEL;**58,61,95,108,229,275**;Jul 10, 1995
+XPDI1 ;SFISC/RSD - Cont of Install Process ; 8/30/04 9:45am
+ ;;8.0;KERNEL;**58,61,95,108,229,275,L33**;Jul 10, 1995
  ;lookup into file 9.7, XPDS=DIC("S") for lookup
  ;return 0-fail or ien, XPDT=array of linked builds
 LOOK(XPDS,XPDL) ;lookup Install
  N DIC,Y,XPD,XPDIT,%
+ S:$D(AAQP) DIC("B")=AAQP ;MPLS XU*L33 used only by XPDZPAT and AAQMENU
  S DIC(0)="QEAMZ",DIC="^XPD(9.7,"
  S:$L($G(XPDS)) DIC("S")=XPDS

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDIL.m

-              r628
+              r636
 XPDIL ;SFISC/RSD - load Distribution Global ;05/17/2006
+XPDIL ;SFISC/RSD - load Distribution Global ;10/10/06  17:00
  ;;8.0;KERNEL;**15,44,58,68,108,422**;Jul 10, 1995;Build 2
  ;This routine has the changes made for patch 345 but was released as 422 to fix a read HFS problem
 …
  I '$G(XPDAUTO) D HOME^%ZIS
  I $G(XPDAUTO) S IO(0)=XPDDEV
+ S:$D(AAQFILE) DIR("B")=AAQFILE ;L33 used only by XPDZPAT
+ S:$D(AAQFILE) DIR("B")=AAQFILE ;L33 used only by XPDZPAT - line added for VOE
  S DIR(0)="F^3:75",DIR("A")="Enter a Host File",DIR("?")="Enter a filename and/or path to input Distribution."
  ;p345-rename AND* to XPD*

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDIST.m

-              r628
+              r636
+XPDIST ;SFISC/RSD - site tracking; 06/01/2006 ;03/05/2008
+ ;;8.0;KERNEL;**66,108,185,233,350,393,486**;Jul 10, 1995;Build 5
+ ; Per VHA Directive 2004-038, this routine should not be modified.
+XPDIST ;SFISC/RSD - site tracking; 06/01/2006
+ ;;8.0;KERNEL;**66,108,185,233,350,393**;Jul 10, 1995;Build 12
  ;Returns ""=failed, XMZ=sent
  ;D0=ien in file 9.7, XPY=national site tracking^address(optional)
 EN(D0,XPY) ;send message
  N %,DIFROM,XPD,XPD0,XPD1,XPD2,XPDV,XPZ,X,X1,Z,Y,XPD6,XPDTRACK
+ N %,DIFROM,XPD,XPD0,XPD1,XPD2,XPDV,XPDTEXT,XPZ,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,X,X1,Z,Y,XPD6
  ;Get data needed
  I '$D(^XPD(9.7,$G(D0),0)) D BMES^XPDUTL(" INSTALL file entry missing") Q ""
 …
  S XPZ(1)=$P(XPD1,U),XPZ(2)=$P(XPD1,U,3),XPZ(3)=$$FMDIFF^XLFDT(XPZ(2),XPZ(1),3),XPZ(1)=$$FMTE^XLFDT(XPZ(1)),XPZ(2)=$$FMTE^XLFDT(XPZ(2))
  D LOCAL
- S XPDTRACK=$$TRACK
  D REMEDY ;p350 -REM
  Q $$FORUM()
+ ;
+ ;
+FORUM() ;send to Server on FORUM
+ K XMY,XPDTEXT ;393
+ Q:$G(XPY)="" ""
+ S:XPY XMY("S.A5CSTS@FORUM.VA.GOV")="" ;,XMY("ESSRESOURCE@MED.VA.GOV")=""
+ S:$L($P(XPY,U,2)) XMY($P(XPY,U,2))=""
+ K ^TMP($J)
+ ;Quit if not VA production primary domain
+ I $G(^XMB("NETNAME"))'[".VA.GOV" D BMES^XPDUTL(" Not a VA primary domain") Q ""
+ X ^%ZOSF("UCI") S %=^%ZOSF("PROD")
+ S:%'["," Y=$P(Y,",")
+ I Y'=% D BMES^XPDUTL(" Not a production UCI") Q ""
+ ;Message for server
+ S XPDTEXT(1,0)="PACKAGE INSTALL"
+ S XPDTEXT(2,0)="SITE: "_$G(^XMB("NETNAME"))
+ S XPDTEXT(3,0)="PACKAGE: "_XPD
+ S XPDTEXT(4,0)="VERSION: "_XPDV
+ S XPDTEXT(5,0)="Start time: "_XPZ(1)
+ S XPDTEXT(6,0)="Completion time: "_XPZ(2)
+ S XPDTEXT(7,0)="Run time: "_XPZ(3)
+ S XPDTEXT(8,0)="DATE: "_DT
+ S XPDTEXT(9,0)="Installed by: "_$P($G(^VA(200,+$P(XPD0,U,11),0)),U)
+ S XPDTEXT(10,0)="Install Name: "_$P(XPD0,U)
+ S XPDTEXT(11,0)="Distribution Date: "_$P(XPD1,U,4)
+ S XPDTEXT(12,0)=XPD2
+ S XMDUZ=$S($P(XPD0,U,11):+$P(XPD0,U,11),1:.5),XMTEXT="XPDTEXT(",XMSUB=$P(XPD0,U)_" INSTALLATION"
+ D ^XMD
+ Q "#"_$G(XMZ)
+ ;
 LOCAL ;Send a message to local mail group
+ N XMY,XPDTEXT,XMTEXT,XMDUZ,XMSUB,XMZ
+ K ^TMP($J)
+ K ^TMP($J),XMY,XPDTEXT,XMTEXT
  S X=$$MAILGRP^XPDUTL(XPD) Q:X=""
  S XMY(X)="" D GETENV^%ZOSV
 …
  D ^XMD
+ Q
+TRACK() ; Should VA track the installation of this patch at a national level?
+ Q:$G(XPY)="" 0  ; No - National site tracking was not requested
+ ;Quit if not VA production primary domain
+ I $G(^XMB("NETNAME"))'[".VA.GOV" D BMES^XPDUTL(" Not a VA primary domain") Q 0
+ ;X ^%ZOSF("UCI") S %=^%ZOSF("PROD")
+ ;S:%'["," Y=$P(Y,",")
+ ;I Y'=% D BMES^XPDUTL(" Not a production UCI") Q ""
+ ; 486/GMB Replaced the above 3 lines with the following line:
+ I '$$PROD^XUPROD D BMES^XPDUTL(" Not a production UCI") Q 0
+ Q 1
+ ;
 REMEDY ;Send to Remedy Server - ESSRESOURCE@MED.VA.GOV *p350 -REM
+ Q:'XPDTRACK
+ N XMY,XPDTEXT,XMTEXT,XMDUZ,XMSUB,XMZ
+ K ^TMP($J)
+ K ^TMP($J),XMY,XPDTEXT,XMTEXT ;393
+ Q:$G(XPY)=""
  S:XPY XMY("ESSRESOURCE@MED.VA.GOV")=""
  S:$L($P(XPY,U,2)) XMY($P(XPY,U,2))=""
+ ;Quit if not VA production primary domain
+ I $G(^XMB("NETNAME"))'[".VA.GOV" D BMES^XPDUTL(" Not a VA primary domain") Q
+ X ^%ZOSF("UCI") S %=^%ZOSF("PROD")
+ S:%'["," Y=$P(Y,",")
+ I Y'=% D BMES^XPDUTL(" Not a production UCI") Q
  ;Message for server (all in one string)
  ;XMTEXT=Type(1),Domain(2-65),Pkg(66-95),Version(96-125),
 …
  D ^XMD
+ Q
-FORUM() ;send to Server on FORUM
- Q:'XPDTRACK ""
- N XMY,XPDTEXT,XMTEXT,XMDUZ,XMSUB,XMZ
- K ^TMP($J)
- S:XPY XMY("S.A5CSTS@FORUM.VA.GOV")=""
- S:$L($P(XPY,U,2)) XMY($P(XPY,U,2))=""
- ;Message for server
- S XPDTEXT(1,0)="PACKAGE INSTALL"
- S XPDTEXT(2,0)="SITE: "_$G(^XMB("NETNAME"))
- S XPDTEXT(3,0)="PACKAGE: "_XPD
- S XPDTEXT(4,0)="VERSION: "_XPDV
- S XPDTEXT(5,0)="Start time: "_XPZ(1)
- S XPDTEXT(6,0)="Completion time: "_XPZ(2)
- S XPDTEXT(7,0)="Run time: "_XPZ(3)
- S XPDTEXT(8,0)="DATE: "_DT
- S XPDTEXT(9,0)="Installed by: "_$P($G(^VA(200,+$P(XPD0,U,11),0)),U)
- S XPDTEXT(10,0)="Install Name: "_$P(XPD0,U)
- S XPDTEXT(11,0)="Distribution Date: "_$P(XPD1,U,4)
- S XPDTEXT(12,0)=XPD2
- S XMDUZ=$S($P(XPD0,U,11):+$P(XPD0,U,11),1:.5),XMTEXT="XPDTEXT(",XMSUB=$P(XPD0,U)_" INSTALLATION"
- D ^XMD
- Q "#"_$G(XMZ)

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ3.m

-              r628
+              r636
 XQ3 ;LL/THM,SF/GJL,SEA/JLI - CLEANUP DANGLING POINTERS IN OPTION OR HELP FRAME FILES ;04/30/08  17:06
  ;;8.0;KERNEL;**80,501**;Jul 10, 1995;Build 1
+XQ3 ;LL/THM,SF/GJL,SEA/JLI - CLEANUP DANGLING POINTERS IN OPTION OR HELP FRAME FILES ;04/21/98  13:20
+ ;;8.0;KERNEL;**80**;Jul 10, 1995
+ Q
 ENASK ;Ask to fix up dirty OPTION/HELP FRAME File
- N IX,XUT,J,K,XQFL,X
  I '$D(%) W !,$C(7),"ENTRY MUST BE WITH THE VARIABLE '%' SET TO INDICATE DESIRED FILE.",$C(7),! Q
  S XQFL=$S(%=1:"OPTION",%=2:"PROTOCOL",1:"HELP FRAME")
 …
  W !!,"Enter:  NO or ^ to continue on without effecting the ",XQFL," File."
  W ! G ENASK
+REMOVE D:%=1 OPFIX D:%=2 PFIX D:'% HFFIX W !,"Your ",XQFL," File is OK " I 'XUT W "(no bad pointers)."
+ E  W "now (",XUT," pointer" W:XUT>1 "s" W " fixed)."
+ W ! S X="Y"
+REMOVE D:%=1 ENFIX D:%=2 PFIX D:'% HFFIX W !,"Your ",XQFL," File is OK " I 'X W "(no bad pointers)."
+ E  W "now (",X," pointer" W:X>1 "s" W " fixed)."
+ W ! S X="Y" Q
+ENFIX ;Kill any dangling pointers in the OPTION File (#19)
+ S (I,X)=0 ;X=Total Deletions
+L1 S I=$O(^DIC(19,I)) I I>0 S (Y,J)=0 G L2 ;Loop through menus
+ Q
+OPFIX ;Kill any dangling pointers in the OPTION File (#19)
+ N %,IX,J,XQ3
+ S (IX,XUT)=0 ;XUT=Total Deletions
+ F  S IX=$O(^DIC(19,IX)) Q:'IX  W:'(IX#100) ". " S (XQ3,J)=0 D L2 ;Loop through Options
+ D NPF
+L2 S J=$O(^DIC(19,I,10,J)) I J>0 G ITEM ;Loop through menu items
+ I '$D(^DIC(19,I,10,0)) G L1
+ S (K,J)=0 F L=1:1 S J=$O(^DIC(19,I,10,J)) Q:J'>0  S K=J ;K=Last item
+ S J=^DIC(19,I,10,0),^(0)=$P(J,"^",1,2)_"^"_K_"^"_Y ;fix counters
+ G XREFS
+ITEM S K=+^DIC(19,I,10,J,0) I $D(^DIC(19,K,0)) S Y=Y+1 G L2 ;Y=No. of items
+ W !,"Option ",$P(^DIC(19,I,0),U,1)," points to missing option ",K
+ S X=X+1 K ^DIC(19,I,10,J) ;Kill invalid menu item
+ G L2
+XREFS S K=":"
+L3 S K=$O(^DIC(19,I,10,K)) I K="" G L1 ;Loop through cross references
+ S L=-1
+L4 S L=$O(^DIC(19,I,10,K,L)) I L="" G L3
+ S J=0
+L5 S J=$O(^DIC(19,I,10,K,L,J)) I J'>0 G L4
+ I '$D(^DIC(19,I,10,J,0)) G KILLXR ;kill xref to invalid item
+L6 S M=^DIC(19,I,10,J,0) I (M=L)!(M[L_"^") G L5
+KILLXR K ^DIC(19,I,10,K,L,J) I $O(^DIC(19,I,10,K,L,-1))="" K ^DIC(19,I,10,K,L)
+ G L5
+HFFIX ; Fix dangling pointers on help frame file
+ S (X,I)=0 F  S I=$O(^DIC(9.2,I)) Q:I'>0  I $D(^(I,2)) D HF1,HF2,HF3
+ Q
+L2 ;One Option
+ I '$D(^DIC(19,IX,10,0)) Q  ;Not a Menu
+ K ^DIC(19,IX,10,"B") ;Rebuild "B" X-ref
+ F  S J=$O(^DIC(19,IX,10,J)) Q:'J  D ITEM ;Loop through menu items
+ S (K,J)=0 F  S J=$O(^DIC(19,IX,10,J)) Q:J'>0  S K=J ;K=Last item
+ S J=^DIC(19,IX,10,0),^(0)=$P(J,"^",1,2)_"^"_K_"^"_XQ3 ;fix counters
+HF1 S (Y,J)=0 F  S J=$O(^DIC(9.2,I,2,J)) Q:J'>0  I $D(^(J,0)) S K=$P(^(0),U,2),Y=Y+1 I $L(K),'$D(^DIC(9.2,K)) S Y=Y-1,X=X+1 K ^DIC(9.2,I,2,J,0)
+ Q
+ ;
+ITEM ;One Menu item
+ N DA,DIK
+ S K=+^DIC(19,IX,10,J,0)
+ I $D(^DIC(19,K,0)) S XQ3=XQ3+1,^DIC(19,IX,10,"B",K,J)="" Q  ;Y=No. of items
+ W !,"Option ",$P(^DIC(19,IX,0),U,1)," points to missing option ",K
+ ;S XUT=XUT+1 K ^DIC(19,IX,10,J) ;Kill invalid menu item
+ S XUT=XUT+1,DIK="^DIC(19,DA(1),10,",DA=J,DA(1)=IX D ^DIK ;Trigger Menu-rebuild
+HF2 S (K,J)=0 F  S J=$O(^DIC(9.2,I,2,J)) Q:J'>0  S K=J
+ S J=^DIC(9.2,I,2,0),^(0)=$P(J,U,1,2)_U_K_U_Y
+ Q
+ ;
+NPF ;Fix the New Person File Option Pointers
+ N IX,I2,J,P,DIK,DIE,DR,DA,XUT
+ S (XUT,IX)=0
+ F  S IX=$O(^VA(200,IX)) Q:'IX  D
+ . S P=+$G(^VA(200,IX,201))
+ . I P,'$D(^DIC(19,P,0)) D
+ . . W !,"User: ",$P(^VA(200,IX,0),U),", Primary Menu points to missing option ",P
+ . . S XUT=XUT+1,DIE="^VA(200,",DA=IX,DR="201///@" D ^DIE
+ . . Q
+ . S I2=0
+ . F  S I2=$O(^VA(200,IX,203,I2)) Q:'I2  D
+ . . S P=+$G(^VA(200,IX,203,I2,0))
+ . . I P,'$D(^DIC(19,P,0)) D
+ . . . W !,"User: ",$P(^VA(200,IX,0),U),", Secondary Menu points to missing option ",P
+ . . . S XUT=XUT+1,DIK="^VA(200,DA(1),203,",DA=I2,DA(1)=IX D ^DIK
+ . . . Q
+ . . Q
+ . Q
+ I XUT W !,"Menu pointers fixed."
+HF3 S K=":" F  S K=$O(^DIC(9.2,I,2,K)) Q:K=""  S J=-1 F  S J=$O(^DIC(9.2,I,2,K,J)) Q:J=""  D HF4
+ Q
+HFFIX ; Fix dangling pointers on help frame file
+ N %
+ S (XUT,IX)=0 F  S IX=$O(^DIC(9.2,IX)) Q:IX'>0  I $D(^(IX,2)) D HF1,HF2,HF3
+ Q
+HF1 S (Y,J)=0 F  S J=$O(^DIC(9.2,IX,2,J)) Q:J'>0  I $D(^(J,0)) S K=$P(^(0),U,2),Y=Y+1 I $L(K),'$D(^DIC(9.2,K)) S Y=Y-1,XUT=XUT+1 K ^DIC(9.2,IX,2,J,0)
+ Q
+HF2 S (K,J)=0 F  S J=$O(^DIC(9.2,IX,2,J)) Q:J'>0  S K=J
+ S J=^DIC(9.2,IX,2,0),^(0)=$P(J,U,1,2)_U_K_U_Y
+ Q
+HF3 S K=":" F  S K=$O(^DIC(9.2,IX,2,K)) Q:K=""  S J=-1 F  S J=$O(^DIC(9.2,IX,2,K,J)) Q:J=""  D HF4
+ Q
+HF4 S JJ=0 F  S JJ=$O(^DIC(9.2,IX,2,K,J,JJ)) Q:JJ'>0  I '$D(^DIC(9.2,IX,2,JJ,0)) K ^DIC(9.2,IX,2,K,J,JJ)
+HF4 S JJ=0 F  S JJ=$O(^DIC(9.2,I,2,K,J,JJ)) Q:JJ'>0  I '$D(^DIC(9.2,I,2,JJ,0)) K ^DIC(9.2,I,2,K,J,JJ)
+ Q
 PFIX ;Kill any dangling pointers in the PROTOCOL File (#101)
+ N %
+ S (IX,XUT)=0 ;XUT=Total Deletions
+P1 S IX=$O(^ORD(101,IX)) I IX>0 S (Y,J)=0 G P2 ;Loop through protocols
+ S (I,X)=0 ;X=Total Deletions
+P1 S I=$O(^ORD(101,I)) I I>0 S (Y,J)=0 G P2 ;Loop through protocols
+ Q
 P2 S J=$O(^ORD(101,IX,10,J)) I J>0 G PITEM ;Loop through items
  I '$D(^ORD(101,IX,10,0)) G P1
  S (K,J)=0 F L=1:1 S J=$O(^ORD(101,IX,10,J)) Q:J'>0  S K=J ;K=Last item
  S J=^ORD(101,IX,10,0),^(0)=$P(J,"^",1,2)_"^"_K_"^"_Y ;fix counters
+P2 S J=$O(^ORD(101,I,10,J)) I J>0 G PITEM ;Loop through items
+ I '$D(^ORD(101,I,10,0)) G P1
+ S (K,J)=0 F L=1:1 S J=$O(^ORD(101,I,10,J)) Q:J'>0  S K=J ;K=Last item
+ S J=^ORD(101,I,10,0),^(0)=$P(J,"^",1,2)_"^"_K_"^"_Y ;fix counters
  G PXREFS
+PITEM S K=+^ORD(101,IX,10,J,0) I $D(^ORD(101,K,0)) S Y=Y+1 G P2 ;Y=No. of items
+ W !,"Protocol ",$P(^ORD(101,IX,0),U,1)," points to missing protocol ",K
+ ;S XUT=XUT+1 K ^ORD(101,IX,10,J) ;Kill invalid menu item
+ S XUT=XUT+1,DIK="^ORD(101,IX,10,",DA=J,DA(1)=IX D ^DIK ;Delete invalid menu item
+PITEM S K=+^ORD(101,I,10,J,0) I $D(^ORD(101,K,0)) S Y=Y+1 G P2 ;Y=No. of items
+ W !,"Option ",$P(^ORD(101,I,0),U,1)," points to missing option ",K
+ S X=X+1 K ^ORD(101,I,10,J) ;Kill invalid menu item
  G P2
 PXREFS S K=":"
 P3 S K=$O(^ORD(101,IX,10,K)) I K="" G P1 ;Loop through cross references
+P3 S K=$O(^ORD(101,I,10,K)) I K="" G P1 ;Loop through cross references
  S L=-1
 P4 S L=$O(^ORD(101,IX,10,K,L)) I L="" G P3
+P4 S L=$O(^ORD(101,I,10,K,L)) I L="" G P3
  S J=0
 P5 S J=$O(^ORD(101,IX,10,K,L,J)) I J'>0 G P4
  I '$D(^ORD(101,IX,10,J,0)) G PKILLXR ;kill xref to invalid item
 P6 S M=^ORD(101,IX,10,J,0) I (M=L)!(M[L_"^") G P5
 PKILLXR K ^ORD(101,IX,10,K,L,J) I $O(^ORD(101,IX,10,K,L,-1))="" K ^ORD(101,IX,10,K,L)
+P5 S J=$O(^ORD(101,I,10,K,L,J)) I J'>0 G P4
+ I '$D(^ORD(101,I,10,J,0)) G PKILLXR ;kill xref to invalid item
+P6 S M=^ORD(101,I,10,J,0) I (M=L)!(M[L_"^") G P5
+PKILLXR K ^ORD(101,I,10,K,L,J) I $O(^ORD(101,I,10,K,L,-1))="" K ^ORD(101,I,10,K,L)
  G P5

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ5.m

-              r628
+              r636
+XQ5 ;SF/GFT,MJM,KLD - Menu edit utilities [XUEDITOPT] ;01/30/2008
+ ;;8.0;KERNEL;**44,130,484**;Jul 10, 1995;Build 2
+ ; Per VHA Directive 2004-038, this routine should not be modified.
+ ; Option & Input Template: XUEDITOPT
+XQ5 ;SF/GFT,MJM,KLD - Menu edit utilities [XUEDITOPT] ;09/20/96  15:33
+ ;;8.0;KERNEL;**44,130**;Jul 10, 1995
 DIP ;
  K DIC S DIC=.4,DIC(0)="AEQMZ" I $D(^DIC(19,DA,63)),^(63)?1"[".E1"]" S DIC("B")=$E(^(63),2,$L(^(63))-1)
 …
 Q1 K XQDIC,XQ,Y S DIC=DIE Q
+ ;
+DIC S XQ=$P(^DIC(XQDIC,0),U,1),XQ(30)=$P(^(0,"GL"),U,2)
+ S XQ(31)=$G(^DIC(19,DA,31)) S:XQ(31)="" XQ(31)="AEMQ"
+DIC S XQ=$P(^DIC(XQDIC,0),U,1),XQ(30)=$P(^(0,"GL"),U,2),XQ(31)="AEMQ"
  I $D(^DIC(XQDIC,0,"LAYGO")),DUZ(0)'="@" S Y=$L(^("LAYGO")) I Y F %=1:1 I DUZ(0)[$E(^("LAYGO"),%) G A:%>Y Q
  W !,"WHEN USER SELECTS AN ENTRY IN THE '"_XQ_"' FILE,",!,"WILL ADDING A NEW ENTRY AT THAT TIME ('LAYGO') BE ALLOWED"
+ S %=$S(XQ(31)["L":0,1:2) D YN^DICN
+ I %=1 I XQ(31)'["L" S XQ(31)=XQ(31)_"L"
+ I %=2 I XQ(31)["L" S XQ(31)=$TR(XQ(31),"L")
+ S %=$S($D(^DIC(19,DA,31)):^(31)'["L"+1,1:0) D YN^DICN I %=1 S XQ(31)="AEMQL"
 A Q
+ ;
 …
  G:DUZ0 DIQ1 S DIC("S")="I 1 Q:'$D(^(0,""RD""))  F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q"
 DIQ1 ;
+ D ^DIC K DIC G:Y<0 Q  S (XQ(80),XQ(30))=$P(^(0,"GL"),U,2)
+ S XQ(31)=$G(^DIC(19,DA,31)) S:XQ(31)="" XQ(31)="AEMQ"
+ D PUT G Q1
+ D ^DIC K DIC G:Y<0 Q S XQ(31)="AEMQ",(XQ(80),XQ(30))=$P(^(0,"GL"),U,2) D PUT G Q1
+ ;
 NAME ;
 …
 PRNT W !,?16,"*** IMPORTANT PLEASE READ ***",!
  W !,"By selecting a new Print/Sort Template below, your defaults will"
  W !,"be changed. Your defaults are currently set as follows (see below)."
+ W !,"be changed. Your defaults are currently set as follows(see below)."
  W !,"Should you desire to keep the defaults as they are, or to revise"
  W !,"one or more, enter an '^' up-arrow, without selecting a new"
  W !,"template name."
  W !!,?23,"Default Values",!,?23,"==============",!
  W !,?5,"DIC {DIP}: "_$$GET1^DIQ(19,DA,60)
+ W !,?17,"DIC {DIP}: "_$$GET1^DIQ(19,DA,60)
  W ?40,"L.: "_$$GET1^DIQ(19,DA,62)
  W !,?5,"FLDS: "_$$GET1^DIQ(19,DA,63)
+ W !,?17,"FLDS: "_$$GET1^DIQ(19,DA,63)
  W ?40,"BY: "_$$GET1^DIQ(19,DA,64)
  W !,?5,"FR: "_$$GET1^DIQ(19,DA,65)
+ W !,?17,"FR: "_$$GET1^DIQ(19,DA,65)
  W ?40,"TO: "_$$GET1^DIQ(19,DA,66),!!
+ Q
 …
 SORT W !,?16,"*** IMPORTANT PLEASE READ ***",!
  W !,"By selecting a new Sort Template below, your defaults will be"
  W !,"changed. Your defaults are currently set as follows (see below)."
+ W !,"changed. Your defaults are currently set as follow(see below)."
  W !,"Should you desire to keep the defaults as they are, or to revise"
  W !,"one or more, enter an '^' up-arrow, without selecting a new Sort"
  W !,"Template."
  W !!,?23,"Default Values",!,?23,"==============",!
  W ?5,"BY: "_$$GET1^DIQ(19,DA,64)
  W !,?5,"FR: "_$$GET1^DIQ(19,DA,65)
+ W ?17,"BY: "_$$GET1^DIQ(19,DA,64)
+ W !,?17,"FR: "_$$GET1^DIQ(19,DA,65)
  W ?40,"TO: "_$$GET1^DIQ(19,DA,66),!!
+ Q

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ55.m

-              r628
+              r636
+XQ55 ; SEA/AMF,MJM,JLI - SEARCH FOR USERS ACCESS TO AN OPTION [4/12/04 4:36am] ;1/29/08  09:50
+ ;;8.0;KERNEL;**140,342,483**;Jul 10, 1995;Build 15
+ ;;Per VHA Directive 2004-038, this routine should not be modified
+XQ55 ; SEA/AMF,MJM,JLI - SEARCH FOR USERS ACCESS TO AN OPTION [4/12/04 4:36am]
+ ;;8.0;KERNEL;**140,342**;Jul 10, 1995
 INIT ;
  S XQDSH="-------------------------------------------------------------------------------"
 …
 MPAT W !!,"Show menu paths" S %=2 D YN^DICN G:%<0 OUT S XQMP=2-% I '% W !!,"If you answer 'YES', the listing will include the menu path(s) each user has",!,"to access the specified option." G MPAT
  K ^TMP($J),XQR,XQP
  S K=^DIC(19,XQOPT,0),XQHDR="Access to '"_$P(K,U,2)_"'  ["_$P(K,U,1)_"]",XQSCD=0,XQCOM=0,XQNOPRNT=0
+ S K=^DIC(19,XQOPT,0),XQHDR="Access to '"_$P(K,U,2)_"'  ["_$P(K,U,1)_"]",XQSCD=0
 LOOP1 S K=XQOPT,(L,X(0))=0,XQD=K K XQR,XQA,XQK,XQRV S XQR(K)="" I '$L($P(^DIC(19,K,0),U,3)) D TREE1
  G LOOP2
 …
 LOOP2 ;
  S XQPA(0)=0,XQP=0 F  S XQP=$O(^TMP($J,XQP)) Q:XQP=""  S XQN=^TMP($J,XQP,0) S XQPS="AP" D USERS S XQPS="AD" D USERS
- D USERS1 I XQNOPRNT G MUS ; 080115 - add in options from the common menu
  G LOOP3
 USERS ;
  S XQU=0 F  S XQU=$O(^VA(200,XQPS,XQP,XQU)) Q:XQU'>0  I $D(^VA(200,XQU,.1)),+$$ACTIVE^XUSER(XQU) D EACHU
+ Q
-USERS1 ; 080115 code added to handle options on the COMMON (XUCOMMAND) menu
- N XUCOMMON
- S XUCOMMON=$O(^DIC(19,"B","XUCOMMAND",0))
- S XQP=0 F  S XQP=$O(^TMP($J,XQP)) Q:XQP=""  S XQN=^TMP($J,XQP,0) F J=1:1:XQN Q:'$D(^TMP($J,XQP,J))  I $P($P(^TMP($J,XQP,J),U,2),",")=XUCOMMON D
- . D  Q:'Y
- . . W !,"***"
- . . W !,"*** This option is available from the 'SYSTEM COMMAND OPTIONS'  ***"
- . . W !,"*** (XUCOMMAND) menu available to all active users unless       ***"
- . . W !,"*** protected by a KEY - DO YOU REALLY WANT THE ENTIRE LIST     ***"
- . . W !,"*** OF THESE USERS???                                           ***",!
- . . N DIR S DIR(0)="Y" D ^DIR S:'Y XQNOPRNT=1 Q:'Y
- . . Q
- . S XQU=0,XQPS="(C)" F  S XQU=$O(^VA(200,XQU)) Q:XQU'>0  I $D(^VA(200,XQU,.1)),+$$ACTIVE^XUSER(XQU),$$KEYCHECK() S II=1 D SETU
+ Q
+ ;
 EACHU ;
  S II=1
+ F J=1:1:XQN Q:'$D(^TMP($J,XQP,J))  I $$KEYCHECK() D SETU ; 080115
+ F J=1:1:XQN Q:'$D(^TMP($J,XQP,J))  D
+ .S XQK=$P(^TMP($J,XQP,J),U,1),XX=$L(XQK,",")-1,XQGO=1
+ .I XX F X=1:1:XX S Y=$P(XQK,",",X) I Y'="",('$D(^XUSEC(Y,XQU))) S XQGO=0
+ .S XQK=$P(^TMP($J,XQP,J),U,3),XX=$L(XQK,",")-1
+ .I XX F X=1:1:XX S Y=$P(XQK,",",X) I Y'="",($D(^XUSEC(Y,XQU))) S XQGO=0
+ .D:XQGO SETU
+ Q
+ ;
-KEYCHECK() ; 080115 extracted common code
- ; returns 1 if user has access to the option, 0 if the user does not have access
- S XQK=$P(^TMP($J,XQP,J),U,1),XX=$L(XQK,",")-1,XQGO=1
- I XX F X=1:1:XX S Y=$P(XQK,",",X) I Y'="",('$D(^XUSEC(Y,XQU))) S XQGO=0
- S XQK=$P(^TMP($J,XQP,J),U,3),XX=$L(XQK,",")-1
- I XX F X=1:1:XX S Y=$P(XQK,",",X) I Y'="",($D(^XUSEC(Y,XQU))) S XQGO=0
- Q XQGO
+ ;
 SETU ;
  S XQPA=$P(^TMP($J,XQP,J),U,2)
  I '$D(XQPA(XQPA)) S I=XQPA(0)+1,XQPA(0)=I,XQPA(0,I)=XQPA,XQPA(XQPA)=I
  S XQPA=XQPA(XQPA) S:XQPS="AD" XQPA=XQPA_"(S)",XQSCD=1 S:XQPS="(C)" XQPA=XQPA_"(C)",XQCOM=1 ; 080115
+ S XQPA=XQPA(XQPA) S:XQPS="AD" XQPA=XQPA_"(S)",XQSCD=1
  S I=$P(^VA(200,XQU,0),U,1)_U_XQU S:$D(^TMP($J,0,I)) II=$O(^TMP($J,0,I,"A"),-1)+1 S ^TMP($J,0,I,II)=XQPA
+ Q
 …
  F I=1:1:XQPA(0) S K=XQPA(0,I) W !,I,".",?4 F N=1:1 Q:'$L($P(K,",",N))  W:N>1 " ... " W $P(^DIC(19,$P(K,",",N),0),U,1)
  I XQSCD W !,"(S) - secondary menu pathway"
- I XQCOM W !,"(C) - SYSTEM COMMAND OPTIONS (XUCOMMAND) menu pathway"
+ Q
 MUS G:X="^" OUT I XQPG,$E(IOST,1)="C" W !!,"Press return when finished viewing " R X:DTIME W @IOF G OUT
 …
  D ^%ZISC
 KILL K XQDT,XQGO,XQN,XQP,XQR,XQRV,XQOPT,XQPA,XQUI,XQSCD,XQDSH,XQU,N,K,J,X,XQA,XQD,XQHDR,XQK,XQP,XQPS,XQMP,XQPG,XX
  K DIC,I,II,JJ,L,POP,Y,XQNOPRNT I $D(ZTQUEUED),$D(ZTSK),ZTSK>0 K ^%ZTSK(ZTSK)
+ K DIC,I,II,JJ,L,POP,Y I $D(ZTQUEUED),$D(ZTSK),ZTSK>0 K ^%ZTSK(ZTSK)
+ Q

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ81.m

-              r628
+              r636
 XQ81 ;SEA/AMF/LUKE,SF/RWF - Build menu trees ;12/10/07
  ;;8.0;KERNEL;**81,116,157,253,478**;Jul 10, 1995;Build 3
+XQ81 ;SEA/AMF/LUKE,SF/RWF - Build menu trees ;03/03/2003  10:00
+ ;;8.0;KERNEL;**81,116,157,253**;Jul 10, 1995
 BUILD ;
+ ;
 …
  S XQSTART=$$HTE^XLFDT($H)
  K XQFG W !!,"This option will build menu trees for each primary and secondary menu.",!,"You may build all the trees, or build them selectively, using 'verify'.",!,"Note that the 'compiled menus' will only be built into ^XUTL on this CPU.",!
  S DIR(0)="Y",DIR("A")="Do you wish to verify each primary menu",DIR("B")="NO",DIR("??")="XQBUILDTREE-VER" D ^DIR K DIR G:$D(DIRUT) BLDEND1 S XQVE=(Y=1)
  S DIR(0)="Y",DIR("A")="Would you like to build secondary menu trees too",DIR("B")="YES",DIR("??")="XQBUILDTREE-SEC" D ^DIR G:$D(DIRUT) BLDEND1 S XQBSEC=(Y=1)
+ ;
  I 'XQVE S DIR(0)="Y",DIR("A")="Would you like to queue this job",DIR("B")="YES" D ^DIR K DIR G:$D(DIRUT) BLDEND1 I Y=1 D
+ S DIR(0)="Y",DIR("A")="Do you wish to verify each primary menu",DIR("B")="NO",DIR("??")="XQBUILDTREE-VER" D ^DIR K DIR G:$D(DIRUT) BLDEND S XQVE=(Y=1)
+ S DIR(0)="Y",DIR("A")="Would you like to build secondary menu trees too",DIR("B")="YES",DIR("??")="XQBUILDTREE-SEC" D ^DIR G:$D(DIRUT) BLDEND S XQBSEC=(Y=1)
+ ;
+ I 'XQVE S DIR(0)="Y",DIR("A")="Would you like to queue this job",DIR("B")="YES" D ^DIR K DIR G:$D(DIRUT) BLDEND I Y=1 D
  .S ZTRTN="QUE^XQ81",ZTIO=""
  .S ZTSAVE("XQVE")="",ZTSAVE("XQBSEC")="",ZTSAVE("XQSTART")=""
 …
  E  S ^DIC(19,"AXQ","P0")=$H L +^DIC(19,"AXQ","P0")
+ ;
  I 'XQVE S DIR(0)="Y",DIR("A")="Do you really wish to run this DIRECTLY (it may take some time)",DIR("B")="NO" D ^DIR K DIR G:$D(DIRUT) BLDEND1 G:Y'=1 RD2
+ I 'XQVE S DIR(0)="Y",DIR("A")="Do you really wish to run this DIRECTLY (it may take some time)",DIR("B")="NO" D ^DIR K DIR G:$D(DIRUT) BLDEND G:Y'=1 RD2
+ ;
 KIDS ;Entry from KIDS
 …
  G UNWIND^%ZTER
+ Q
+ ;
-BLDEND1 ;Quit and clean
- K %,%H,%TG,C,D,DIC,DIR,I,J,K,L,V,XQBSEC,X,Y,Z,XQL,XQN,XQRE,XQK,XQI,XQII,UU,XQH,XQPX,XQSAV,XQXUF,XQ81T,XQDATE,XQSEC,XQVE,XQBLD,XQP,XQR,XQJ
+ Q

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALDATA.m

-              r628
+              r636
 XQALDATA ;ISC-SF/JLI - PROVIDE DATA ON ALERTS ;4/9/07  13:39
  ;;8.0;KERNEL;**207,285,443**;Jul 10, 1995;Build 4
+XQALDATA ;ISC-SF/JLI - PROVIDE DATA ON ALERTS ;9/9/03  15:13
+ ;;8.0;KERNEL;**207,285**;Jul 10, 1995
+ Q
 GETUSER(ROOT,XQAUSER,FRSTDATE,LASTDATE) ;
  N XREF,XVAL,X,X2,X3,I,NCNT ; P443
+ N XREF,XVAL
  S:$G(XQAUSER)'>0 XQAUSER=DUZ
  S:$G(FRSTDATE)'>0 FRSTDATE=0
 …
  S NCNT=0 K @ROOT
  I FRSTDATE=0 D  Q
  . F I=0:0 S I=$O(^XTV(8992,XQAUSER,"XQA",I)) Q:I'>0  S X=^(I,0),X3=$G(^(3)),X2=$G(^(2)) D
+ . F I=0:0 S I=$O(^XTV(8992,XQAUSER,"XQA",I)) Q:I'>0  S X=^(I,0),X3=$G(^(3)) D
  . . S NCNT=NCNT+1
  . . S @ROOT@(NCNT)=$S($P(X3,U)'="":"G  ",$P(X,U,7,8)="^ ":"I  ",1:"   ")_$P(X,U,3)_U_$P(X,U,2)_$S($P(X2,U,3)'="":U_$P(X2,U,3),1:"") ; P443
+ . . S @ROOT@(NCNT)=$S($P(X3,U)'="":"G  ",$P(X,U,7,8)="^ ":"I  ",1:"   ")_$P(X,U,3)_U_$P(X,U,2)
  . S @ROOT=NCNT
  S XREF="R"
 …
+ Q
 GETPAT(ROOT,PATIENT,FRSTDATE,LASTDATE) ;
  N XREF,XVAL,NCNT
+ N XREF,XVAL
  S NCNT=0 K @ROOT
  I $G(PATIENT)'>0 S @ROOT=0 Q
 …
+ Q
 CHKTRAIL ;
- N XQ1,X,X1,X2,X3
- ; ZEXCEPT: FRSTDATE,LASTDATE,NCNT,ROOT,XREF,XVAL  -- from GETPAT or GETUSER
  F XQ1=0:0 S XQ1=$O(^XTV(8992.1,XREF,XVAL,XQ1)) Q:XQ1'>0  D
  . S X=$G(^XTV(8992.1,XQ1,0)),X1=$G(^(1)),X3=$G(^(3)),X2=$G(^(2)) Q:X=""
+ . S X=$G(^XTV(8992.1,XQ1,0)),X1=$G(^(1)),X3=$G(^(3)) Q:X=""
  . I FRSTDATE'>0,'$D(^XTV(8992,"AXQA",$P(X,U))) Q
  . I FRSTDATE>0,$P(X,U,2)<FRSTDATE Q
  . I FRSTDATE>0,LASTDATE>0,$P(X,U,2)>LASTDATE Q
  . S NCNT=NCNT+1
  . S @ROOT@(NCNT)=$S($P(X3,U)'="":"G  ",$P(X1,U,2,3)="^":"I  ",$P(X1,U,2,3)="":"I  ",1:"   ")_$P(X1,U)_U_$P(X,U)_$S($P(X2,U,3)'="":U_$P(X2,U,3),1:"") ; P443
+ . S @ROOT@(NCNT)=$S($P(X3,U)'="":"G  ",$P(X1,U,2,3)="^":"I  ",$P(X1,U,2,3)="":"I  ",1:"   ")_$P(X1,U)_U_$P(X,U)
  S @ROOT=NCNT
+ Q

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALDEL.m

-              r628
+              r636
 XQALDEL ;ISC-SF.SEA/JLI - DELETE ALERTS ;4/9/07  15:13
  ;;8.0;KERNEL;**6,24,65,114,174,285,443**;Jul 10, 1995;Build 4
+XQALDEL ;ISC-SF.SEA/JLI - DELETE ALERTS ;6/28/04  11:02
+ ;;8.0;KERNEL;**6,24,65,114,174,285**;Jul 10, 1995
  ;;
+ Q
 …
  S XQDAT=$$FMADD^XLFDT(DT,-30)
  F XQDEL1=0:0 S XQDEL1=$O(^XTV(8992.1,XQDEL1)) Q:XQDEL1'>0  D
  . S X1=$P($G(^XTV(8992.1,XQDEL1,0)),U,2),X2=$P($G(^(0)),U,8)
+ . S X1=$P(^XTV(8992.1,XQDEL1,0),U,2),X2=$P(^(0),U,8)
  . S DA=XQDEL1 I X2="",X1>XQDAT Q
  . I X2>0,DT<X2 Q

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALERT1.m

-              r628
+              r636
 XQALERT1 ;ISC-SF.SEA/JLI - ALERT HANDLER ;4/9/07  14:54
  ;;8.0;KERNEL;**20,65,114,123,125,164,173,285,366,443**;Jul 10, 1995;Build 4
+XQALERT1 ;ISC-SF.SEA/JLI - ALERT HANDLER ;9/6/05  15:13
+ ;;8.0;KERNEL;**20,65,114,123,125,164,173,285,366**;Jul 10, 1995
  ;;
+ Q
 …
 SUBLOOP W @IOF
  N XQZ1,XQZ
  S XQK=0 F XQI=0:0 Q:XQX1!XQXOUT  S XQI=$O(^TMP("XQ",$J,"XQA",XQI)) Q:XQI'>0  S XQX=^(XQI),XQII=^(XQI,1),XQZ=^(2),XQZ1=^(3),XQZ4=^(4) D  I XQX'="" D DOIT1
+ S XQK=0 F XQI=0:0 Q:XQX1!XQXOUT  S XQI=$O(^TMP("XQ",$J,"XQA",XQI)) Q:XQI'>0  S XQX=^(XQI),XQII=^(XQI,1),XQZ=^(2),XQZ1=^(3) D  I XQX'="" D DOIT1
  . I '$D(^XTV(8992,XQAUSER,"XQA",XQII)) S XQX="" K ^TMP("XQ",$J,"XQA",XQI),^TMP("XQ",$J,"XQA1",(999999-XQI))
  . Q
 …
+ ;
 RESTORE ; Restore a deleted message for use
  N ALERTREF,XTVGLOB,ADUZ,X,X0,X1,X2,TIME,MESG,OPT,TAG,ROU,X4,LONG
+ N ALERTREF,XTVGLOB,ADUZ,X,X0,X1,X2,TIME,MESG,OPT,TAG,ROU
  S XTVGLOB=$NA(^XTV(8992,DUZ,"XQA"))
  S ADUZ=$O(^XTV(8992,"AXQA",XQAID,0)) I ADUZ>0 S TIME=$O(^(ADUZ,0)) D  I 1
  . M @XTVGLOB@(TIME)=^XTV(8992,ADUZ,"XQA",TIME) K @XTVGLOB@(TIME,2) ; copy alert, kill comment if any
  E  S ALERTREF=$O(^XTV(8992.1,"B",XQAID,0)) Q:ALERTREF'>0  D  ; otherwise rebuild from alert tracking file if possible
  . S X0=^XTV(8992.1,ALERTREF,0),X1=$G(^(1)),X2=$G(^(2)),X4=$O(^(4,0))
  . S TIME=$P($P(X0,U),";",3),MESG=$P(X1,U),OPT=$P(X1,U,2),TAG=$P(X1,U,3),ROU=$P(X1,U,4),LONG=(X4>0)
  . S X=TIME_U_XQAID_U_MESG_U_U_$S(OPT'=""!(ROU'=""):"R",LONG:"L",1:"I")_U_U_$S(OPT'="":OPT,TAG'="":TAG,1:"")_U_$S(OPT'="":"",ROU'="":ROU,1:" ")
+ . S X0=^XTV(8992.1,ALERTREF,0),X1=$G(^(1)),X2=$G(^(2))
+ . S TIME=$P($P(X0,U),";",3),MESG=$P(X1,U),OPT=$P(X1,U,2),TAG=$P(X1,U,3),ROU=$P(X1,U,4)
+ . S X=TIME_U_XQAID_U_MESG_U_U_$S(OPT'=""!(ROU'=""):"R",1:"I")_U_U_$S(OPT'="":OPT,TAG'="":TAG,1:"")_U_$S(OPT'="":"",ROU'="":ROU,1:" ")
  . S @XTVGLOB@(TIME,0)=X I $G(X2)'="" S ^(1)=X2
  S ^XTV(8992,"AXQA",XQAID,DUZ,TIME)="",^XTV(8992,"AXQAN",$E($P(XQAID,";"),1,30),DUZ,TIME)=""
 …
  I XQK=0 S XQALINFO=0 I '$D(XQALFWD) W @IOF
  S XQON="$C(0)",XQOFF="$C(0)" S XQOUT=$P(XQX,U,3) I ($$UP^XLFSTR(XQOUT)["CRITICAL")!($$UP^XLFSTR(XQOUT)["ABNORMAL IMA") D:'$D(XQ1ON) SETREV^XQALERT S XQON=XQ1ON,XQOFF=XQ1OFF ; P285
  S XQK=XQK+1 W !,$J(XQK,2),".",$S(XQZ4:"L",$P(XQX,U,8)=" ":"I",1:" "),"  ",@XQON,$E($P(XQX,U,3),1,70),@XQOFF S:$P(XQX,U,8)=" " XQALINFO=XQALINFO+1 D:XQZ1'=""  ; P285
+ S XQK=XQK+1 W !,$J(XQK,2),".",$S($P(XQX,U,8)=" ":"I",1:" "),"  ",@XQON,$E($P(XQX,U,3),1,70),@XQOFF S:$P(XQX,U,8)=" " XQALINFO=XQALINFO+1 D:XQZ1'=""  ; P285
  . W !?8,"Forwarded by: ",$P(^VA(200,+XQZ1,0),U),"  Generated: ",$$DAT8^XQALERT(+$P($P(XQX,U,2),";",3),1)
  . I $P(XQZ1,U,3)'="" W !?8,$P(XQZ1,U,3)
 …
+ ;
 SORT ;Sort and remove display only
+ N XQZ,XQZ1,XQZ4,XQI,XQK,XQX,XQJ
+ F XQI=0:0 S XQI=$O(^XTV(8992,XQAUSER,"XQA",XQI)) Q:XQI'>0  S XQX=^(XQI,0),XQZ=$G(^(1)),XQZ1=$G(^(2)),XQZ4=$O(^(4,0)) S XQJ=$P(XQX,U,7,8) K:XQJ=U ^XTV(8992,XQAUSER,"XQA",XQI) I XQJ'=U D
+ . S XQACNT=XQACNT+1,XQJ=$S(XQAREV:999999-XQACNT,1:XQACNT),^TMP("XQ",$J,"XQA",XQJ)=XQX,^(XQJ,1)=XQI,^(2)=XQZ,^(3)=XQZ1,^(4)=XQZ4
+ F XQI=0:0 S XQI=$O(^XTV(8992,XQAUSER,"XQA",XQI)) Q:XQI'>0  S XQX=^(XQI,0),XQZ=$G(^(1)),XQZ1=$G(^(2)) S XQJ=$P(XQX,U,7,8) K:XQJ=U ^XTV(8992,XQAUSER,"XQA",XQI) I XQJ'=U D
+ . S XQACNT=XQACNT+1,XQJ=$S(XQAREV:999999-XQACNT,1:XQACNT),^TMP("XQ",$J,"XQA",XQJ)=XQX,^(XQJ,1)=XQI,^(2)=XQZ,^(3)=XQZ1
  S XQK=0 F XQI=0:0 S XQI=$O(^TMP("XQ",$J,"XQA",XQI)) Q:XQI'>0  S XQK=XQK+1 M ^TMP("XQ",$J,"XQA1",XQK)=^TMP("XQ",$J,"XQA",XQI)
+ Q

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALMAKE.m

-              r628
+              r636
 XQALMAKE ;ISC-SF.SEA/JLI- HIGH LEVEL SETUP ALERT ;4/9/07  14:03
  ;;8.0;KERNEL;**443**;Jul 10, 1995;Build 4
+XQALMAKE ;ISC-SF.SEA/JLI- HIGH LEVEL SETUP ALERT ;9/23/94  13:28
+ ;;8.0;KERNEL;;Jul 10, 1995
  ;;
 ENTRY ;
 …
  R !,"Enter ROUTINE name or ENTRY^ROUTINE name: ",X:DTIME S:'$T X=U G:X=U EXIT G:X="" ASKROU S XQAROU=X S X=$S(X'[U:X,1:$P(X,U,2)) G:X="" ASKROU X ^%ZOSF("TEST") I 'Y W !,"Routine '",X,"' not present" G ASKROU
 SETIT ;
- I '$D(XQAROU),'$D(XQAOPT) S DIR(0)="Y",DIR("A")="Do you want to make a long text info only alert" D ^DIR K DIR I Y D LONGTEXT
  W !!,"As currently entered, this alert will display the following text:",!!,XQAMSG
  W !!,"The alert is currently to be delivered to:" S XQAX="" F I=1:1 S XQAX=$O(XQA(XQAX)) Q:XQAX=""  S X=$S(XQAX>0:$P(^VA(200,XQAX,0),U),1:XQAX) W:(I#2) ! W:'(I#2) ?40 W X
 …
  S XQALDIC=$S("g.G."[$E(X,1,2):3.8,1:200),X=$S(XQALDIC=3.8:$E(X,3,$L(X)),1:X),DIC=XQALDIC,DIC(0)="EMQ" D ^DIC Q:Y'>0  S X=$S(XQALDIC=3.8:"G."_$P(Y,U,2),1:+Y),XQA(X)=""
+ Q
+ ;
-LONGTEXT ;
- W !,"Enter .EXIT  to terminate input",!
- S COUNT="" F  R X:DTIME Q:X=".EXIT"  S COUNT=COUNT+1,XQATEXT(COUNT)=X W !
+ Q

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSET.m

-              r628
+              r636
 XQALSET ;ISC-SF.SEA/JLI - SETUP ALERTS ;4/10/07  14:06
  ;;8.0;KERNEL;**1,6,65,75,114,125,173,207,285,443**;Jul 10, 1995;Build 4
+XQALSET ;ISC-SF.SEA/JLI - SETUP ALERTS ;6/24/04  13:46
+ ;;8.0;KERNEL;**1,6,65,75,114,125,173,207,285**;Jul 10, 1995
  ;;
+ Q
 …
+ Q
+ ;
 SETUP1() ; .SR Returns a string beginning with 1 if successful, 0 if not successful, the second piece is the IEN in the Alert Tracking File and the third piece is the value of XQAID.
+SETUP1() ; .SR Returns a string beginning with 1 if successful, 0 if not successful, the second piece is the IEN in the Alert Tracking File and the third piece is the value of XQAID.
  ; If not successful XQALERR is defined and contains reason for failure.
  K XQALERR
 …
 REENT() ; Entry for forwarding, etc.
  N RETVAL S RETVAL=1
- K ^TMP("XQAGROUP",$J) ; P443 - clear location for storage of groups processed
  N XQADATIM,XQALIST,XQALIST1,XQNRECIP S XQNRECIP=0 S XQADATIM=$$NOW^XLFDT()
  S XQALIN1=$S($D(XQAID)#2:XQAID,1:"")_U_$E(XQAMSG,1,80)_"^1^"_$S(XQAOPT1=U:"D",1:"R")_U_$S($D(XQACTMSG):$E(XQACTMSG,1,40),1:"")_U_XQAOPT1
 …
 REP I $D(^XTV(8992,XQJ,"XQA",XQXI,0)) S XQXI=XQXI+.00000001 G REP
  S ^XTV(8992,XQJ,"XQA",XQXI,0)=XQALIN S:$D(XQALIN1) ^(1)=XQALIN1 S:$D(XQAGUID)!$D(XQADFN) ^(3)=$G(XQAGUID)_U_$G(XQADFN) S:$D(XQARESET) ^(2)=XQAUSER_U_XQX_U_$G(XQACOMNT) S ^(0)=$P(^XTV(8992,XQJ,"XQA",0),U,1,2)_U_XQXI_U_($P(^(0),U,4)+1)
  I $D(XQATEXT) S:($D(XQATEXT)#2) XQATEXT(.1)=XQATEXT D WP^DIE(8992.01,(XQXI_","_XQJ_","),4,"","XQATEXT") ; P443 PUT DATA IN XQATEXT INTO ARRAY
+ I $D(XQATEXT) D WP^DIE(8992.01,(XQXI_","_XQJ_","),4,"","XQATEXT")
  L -^XTV(8992,XQJ)
  K XQA(XQJ) S:XQAID'="" ^XTV(8992,"AXQA",XQAID,XQJ,XQXI)="",^XTV(8992,"AXQAN",XQA1,XQJ,XQXI)=""
 …
  I RETVAL S RETVAL=RETVAL_U_$G(XQADA)_U_XQAID
  K:XQAID'="" ^XTV(8992,"AXQA",XQAID,0,0)
- K ^TMP("XQAGROUP",$J) ; P443 - clear global used to track processing of groups
  K XQA,XQALIN,XQALIN1,XQAMSG,XQAID,XQAFLG,XQAOPT,XQAOPT1,XQAROU,XQADATA,XQI,XQX,XQJ,XQK,XQA1,XQACTMSG,XQJ,XQXI,XQAARCH,XQACNDEL,XQAREVUE,XQASUPV,XQASURO,XQATEXT
  Q RETVAL

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSET1.m

-              r628
+              r636
 XQALSET1 ;ISC-SF.SEA/JLI - SETUP ALERTS (OVERFLOW) ;4/9/07  10:26
  ;;8.0;KERNEL;**285,443**;Jul 10, 1995;Build 4
+XQALSET1 ;ISC-SF.SEA/JLI - SETUP ALERTS (OVERFLOW) ;10/20/03  15:03
+ ;;8.0;KERNEL;**285**;Jul 10, 1995
  ;;
+ Q
 GROUP ;
+GROUP ;
  N XQI,XQL,XQL1,XQL2,XQLIST
+ S XQL=$E(XQJ,3,$L(XQJ)) ; P443 - changed from code that forced upper case
+ I $D(^TMP("XQAGROUP",$J,XQL)) Q  ; P443 group has already been processed - prevent cycling
+ S ^TMP("XQAGROUP",$J,XQL)="" ; P443 mark that the group has been seen
+ S XQL="" F XQI=3:1:$L(XQJ) S XQL1=$E(XQJ,XQI) S:XQL1?1L XQL1=$C($A(XQL1)-32) S XQL=XQL_XQL1
+ ;S XQI=$O(^XMB(3.8,"B",XQL,0)) I XQI'>0 S XQL1=$O(^XMB(3.8,"B",XQL)) I $E(XQL1,1,$L(XQL))=XQL S XQL2=$O(^(XQL1)) I $E(XQL2,1,$L(XQL))'=XQL S XQI=$O(^(XQL1,0))
+ ;I XQI>0 F XQL=0:0 S XQL=$O(^XMB(3.8,XQI,1,XQL)) Q:XQL'>0  S XQA(+^(XQL,0))=""
+ ;  Above code replaced to use Fileman calls, also code added to walk through member groups as well  030203 JLI P285
  S XQI=$$FIND1^DIC(3.8,,"X",XQL) Q:XQI'>0
  N XQLIST D LIST^DIC(3.81,","_XQI_",",".01","I",,,,,,,.XQLIST) I XQLIST("ORDER")>0 D
 …
  . Q
  K @XQLIST,XQLIST D LIST^DIC(3.811,","_XQI_",",".01",,,,,,,,.XQLIST) I XQLIST("ORDER")>0 D
+ . N XQAGROUP M XQAGROUP=@XQLIST@("ID") ; P443 - store group list data locally so it is not over written by recursive call to LIST^DIC
+ . N XQI F XQI=0:0 S XQI=$O(XQAGROUP(XQI)) Q:XQI'>0  N XQJ S XQJ="G."_XQAGROUP(XQI,.01) D GROUP ; P443 - change to reference XQAGROUP
+ . N XQI F XQI=0:0 S XQI=$O(@XQLIST@("ID",XQI)) Q:XQI'>0  N XQJ S XQJ="G."_^(XQI,.01) D GROUP
  . Q
- K @XQLIST,XQLIST
  K XQA(XQJ)
  D CHEKACTV(.XQA)
 …
+ Q
+ ;
 CHEKUSER(XQAUSER) ; Returns 0 if no valid user or surrogate, otherwise returns IEN of user or surrogate
+CHEKUSER(XQAUSER) ;SR. Returns 0 if no valid user or surrogate, otherwise returns IEN of user or surrogate
  N VALUE
  S VALUE=$$ACTVSURO^XQALSURO(XQAUSER)

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSUR1.m

-              r628
+              r636
 XQALSUR1 ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ;11/21/07  08:35
  ;;8.0;KERNEL;**366,443**;Jul 10, 1995;Build 4
+XQALSUR1 ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ;9/6/05  14:26
+ ;;8.0;KERNEL;**366**;Jul 10, 1995
+ Q
+ ;
 …
 SURRO11 ;
  S XQALSURO=$$NEWDLG() I XQALSURO'>0 Q
  I $$CYCLIC^XQALSURO(XQALSURO,XQAUSER)'>0 W $C(7),!,$$CYCLIC^XQALSURO(XQALSURO,XQAUSER),! G SURRO11
+ I $$CYCLIC^XQALSURO(XQALSURO,XQAUSER)'>0 W $C(7),!,$$CYCLIC^XQALSURO(XQALSURO,XQAUSER),! G SURRO1
  S XQALSTRT=+$$STRTDLG() I XQALSTRT<0 Q
  S XQALEND=+$$ENDDLG() I XQALEND<0 Q
 …
  S XQALSURO=$G(XQALSURO),XQALSTRT=$G(XQALSTRT)
  N XQALFM,XQALXREF,XQALSTR1,XQALSUR1,XQALNOW,XQALEND,XQA0
+ ; ZEXCEPT: XQATEST   (EXTERNAL VALUE - INDICATING TEST BEING RUN)
  D CHEKSUBS^XQALSUR2(XQAUSER)
  S XQALSUR1=+$P($G(^XTV(8992,XQAUSER,0)),U,2) S:XQALSURO'>0 XQALSURO=XQALSUR1
 …
 DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND) ;
  N XQALNOW,XQALFM
+ ; ZEXCEPT: XQATEST   (EXTERNAL VALUE - INDICATING TEST BEING RUN)
  S XQAUSER=XQAUSER_",",XQALXREF=XQALXREF_","_XQAUSER
  I XQALXREF>0 D
 …
  . Q
  I $D(XQALFM) D FILE^DIE("","XQALFM")
+ ; ZEXCEPT: XTMUNIT   (EXTERNAL VALUE - INDICATING UNIT TEST BEING RUN)
+ I XQALSURO>0,'$D(XTMUNIT) D
+ I XQALSURO>0,'$D(XQATEST) D
  . N XQAMESG,XMSUB,XMTEXT
  . S XQAMESG(1,0)="You have been REMOVED as a surrogate recipient for alerts for"

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSURO.m

-              r628
+              r636
 XQALSURO ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ;3/17/08  15:20
  ;;8.0;KERNEL;**114,125,173,285,366,443**;Jul 10, 1995;Build 4
+XQALSURO ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ;9/6/05  15:13
+ ;;8.0;KERNEL;**114,125,173,285,366**;Jul 10, 1995
  ;;
+ Q
 …
  D SURRO1^XQALSUR1(XQAUSER)
+ Q
+ ; P366 - optional start and end dates added to permit identification of cyclical surrogates in specific times
 CYCLIC(XQALSURO,XQAUSER,XQASTRT,XQAEND) ; code added to prevent cyclical surrogates
- I '$$ACTIVE^XUSER(XQALSURO) Q "You cannot have an INACTIVE USER ("_XQALSURO_") as a surrogate!" ;P443
- I XQALSURO=XQAUSER Q "You cannot specify yourself as your own surrogate!" ; moved in P443
  I $G(XQASTRT)>0 Q $$DCYCLIC^XQALSUR1(XQALSURO,XQAUSER,XQASTRT,$G(XQAEND))
  N XQALSTRT
+ I XQALSURO=XQAUSER Q "You cannot specify yourself as your own surrogate!"
  S XQALSTRT=$$CURRSURO(XQALSURO) I XQALSTRT>0 D
  . I XQALSTRT=XQAUSER S XQALSURO="YOU are designated as the surrogate for this user ("_XQALSURO_") - can't do it!" Q
+ . I XQALSTRT=XQAUSER S XQALSURO="YOU are designated as the surrogate for this user - can't do it!" Q
  . F  S XQALSTRT=$$CURRSURO(XQALSTRT) Q:XQALSTRT'>0  I XQALSTRT=XQAUSER S XQALSURO="This forms a circle which leads back to you - can't do it!" Q
  . Q
  Q XQALSURO
+ ;
+SETSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; Use SETSURO1 instead
+ N XQALVAL ; P443
+ S XQALVAL=$$SETSURO1(XQAUSER,XQALSURO,$G(XQALSTRT),$G(XQALEND)) ; P443
+ Q
+ ;
+SETSUROX(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; SETSURO CODE MOVED TO HERE TO PERMIT AN ERROR TO BE GENERATED AT THE OLD ENTRY POINT
+SETSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; SR
  N XQALFM,XQALIEN,XQAIENS
  I $G(XQAUSER)'>0 Q
 …
  S XMSUB="Surrogate Recipient for "_$$GET1^DIQ(200,XQAIENS,.01,"E")
  S XMTEXT="XQAMESG("
+ ; ZEXCEPT: XTMUNIT   - Defined if unit tests are being run
+ D:'$D(XTMUNIT) SENDMESG
+ D:'$D(XQATEST) SENDMESG
+ Q
+ ;
 …
  N XQAVAL
  S XQAVAL=$$CYCLIC(XQALSURO,XQAUSER,XQALSTRT,$G(XQALEND)) I XQAVAL'>0 Q XQAVAL ; Can't use as surrogate
  D SETSUROX(XQAUSER,XQALSURO,XQALSTRT,$G(XQALEND)) ; P443
+ D SETSURO(XQAUSER,XQALSURO,XQALSTRT,$G(XQALEND))
  Q XQALSURO
+ ;
 …
+ ;
  ; P366 - find the latest start time which is now or past or the first one in the future
+ S XQANOW=$$NOW^XLFDT() D
+ S XQANOW=$$NOW^XLFDT()
+ ;I $P($G(^XTV(8992,XQAUSER,0)),U,2)'>0 D
+ D
  . S XQAIVAL=0,XQASTR1=0
  . F XQASTRT=0:0 S XQASTRT=$O(^XTV(8992,XQAUSER,2,"B",XQASTRT)) Q:XQASTRT'>0  Q:XQASTRT'<XQANOW  S XQASTR1=XQASTRT F XQAI=0:0 S XQAI=$O(^XTV(8992,XQAUSER,2,"B",XQASTRT,XQAI)) Q:XQAI'>0  D
 …
  I $P(X,U,2)>0,+$P(X,U,3)'>XQANOW D  I $P($G(^XTV(8992,XQAUSER,0)),U,2)>0 Q +$P(^XTV(8992,XQAUSER,0),U,2)
  . N DATE ;   Get Current date/time to check date/times if present
+ . ; FOLLOWING LINES MODIFIED IN P443 TO ELIMINATE A STACK ERROR WHEN SURROGATE WAS CIRCULAR
+ . ;  Current Date/time past End date for surrogate
+ . S DATE=$P(X,U,4) I (DATE>0&(DATE<XQANOW)) D REMVSURO(XQAUSER) Q
+ . N XQASURO,XQASURO1 S XQASURO1=+$P(^XTV(8992,XQAUSER,0),U,2)
+ . ; REMOVE IF SURROGATE IS USER
+ . I XQASURO1=XQAUSER D REMVSURO(XQAUSER) Q
+ . N XQALLIST S XQALLIST(XQAUSER)=""
+ . ; REMOVE IF CYCLES BACK TO USER - thought about removing inactive, but best to let those be handled by groups for unprocessed alerts
+ . F  S XQASURO=$P($G(^XTV(8992,XQASURO1,0)),U,2) Q:XQASURO'>0  Q:'$$ISACTIVE(XQASURO)  S XQASURO1=XQASURO D
+ . . I $D(XQALLIST(XQASURO)) D REMVSURO(XQASURO) S XQASURO1=XQAUSER K XQALLIST S XQALLIST(XQAUSER)="" Q
+ . . S XQALLIST(XQASURO1)=""
+ . . Q
+ . ; END OF P443 MODIFICATION
+ . ;  Current Date/time past End date for surrogate or cyclic relationship remove checks for new surrogate
+ . S DATE=$P(X,U,4) I (DATE>0&(DATE<XQANOW))!('$$CYCLIC($P(X,U,2),XQAUSER)) D REMVSURO(XQAUSER)
  . Q
  Q -1
+ ;
-ISACTIVE(XQAUSER) ; checks for whether a surrogate relationship is active or not (returns 0 or 1)
- N DATA
- S DATA=$G(^XTV(8992,XQAUSER,0)) Q:$P(DATA,U,2)="" 0  ; NO SURROGATE SPECIFIED
- I $P(DATA,U,3)>0,$P(DATA,U,3)>$$NOW^XLFDT() Q 0  ; START DATE/TIME NOT YET
- I $P(DATA,U,4)>0,$P(DATA,U,4)<$$NOW^XLFDT() Q 0  ; PAST END DATE/TIME
- Q 1
+ ;
 ACTVSURO(XQAUSER) ;SR. - returns the actual surrogate at this time

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQARPRT2.m

-              r628
+              r636
 XQARPRT2 ;DCN/BUF,JLI/OAK-OIFO - LOOKUP PROVIDER ALERTS ;4/9/07  10:16
  ;;8.0;KERNEL;**316,443**;Jul 10, 1995;Build 4
+XQARPRT2 ;DCN/BUF,JLI/OAK-OIFO - LOOKUP PROVIDER ALERTS 25 SEP 98 ;9/3/03  11:15
+ ;;8.0;KERNEL;**316**;Jul 10, 1995
  ;  Based on the original routine AEKALERT
+ Q
 …
  N XQANWID,XQAIEN,XQADATE,XQANODE0,XQACTR,HEADERID,XQATOT
  S HEADERID="User "_$$GET1^DIQ(200,XQADOC_",",.01)_" (DFN="_XQADOC_")"
- U IO
  D HEADER(HEADERID,1)
  S XQAIEN=$O(^XTV(8992.1,"D",XQASDATE-.0000001)) I XQAIEN>0 S XQAIEN=$O(^(XQAIEN,0)) ; find starting point instead of having to work up through x-ref
 …
  . D PRNTATRK(XQAIEN)
  D HEADER(HEADERID,0)
- D ^%ZISC
  K XQADATE,XQACTR,DATA,DIR,DIRUT,XQADOC,XQAIEN,XQANODE0,XQASDATE,Y
+ Q
 …
  . Q
+ ;
  I $D(XQAWORDS)>1,$G(TYPE)="" D
+ I $D(XQAWORDS)>1,$G(TYPE)="" D
  . S DIR(0)="SO^1:Both Action and Info Only;2:Action Alerts;3:Info Only Alerts",DIR("?",1)="Select whether alerts listed should be alerts involving actions (2), info",DIR("?")="only or text only alerts (3), or both (1)."
  . S DIR("A")="Select Alert Type(s) desired",DIR("B")=1 D ^DIR K DIR S:Y'>0 Y=1 K DIRUT S XQADISP=+Y
 …
  S XQACTR=XQACTR+2 I XQACTR>(IOSL-4) D  Q:$D(DIRUT)  S XQACTR=0
  . I $D(ZTQUEUED) W @IOF
+ . E  U IO(0) S DIR(0)="E" D ^DIR K DIR W !
+ . U IO
+ . E  S DIR(0)="E" D ^DIR K DIR W !
  . Q
+ Q

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQCHK.m

-              r628
+              r636
+XQCHK ; SEA/MJM - Check security on option # XQCY ;5/20/08
+ ;;8.0;KERNEL;**47,110,149,303,427,503**;Jul 10, 1995;Build 2
+ ;;"Per VHA Directive 2004-038, this routine should not be modified".
+ ;
+XQCHK ; SEA/MJM - Check security on option # XQCY ; [7/19/06 10:45am]
+ ;;8.0;KERNEL;**47,110,149,303,427**;Jul 10, 1995;Build 3
  Q:'$D(XQCY)!(XQCY<1)  S:'$D(XQJMP) XQJMP=0
  I '$D(XQY0) S XQY0=^DIC(19,+XQCY,0)
 …
+ Q
+ ;
+OUT K %,%XQI,XQCY0,%Y,XQZ
+OUT ;I XQCY=-2 W !,"Locked...Do you have the key "_$P(XQRT,"^",2)
+ ;I XQCY=-3 W !,"Reversed Locked...Don't you have the key "_$P(XQRT,"^",2)
+ K %,%XQI,XQCY0,%Y,XQZ
+ Q
+ ;
 …
  Q %
+ ;
+ ;
 ACCESS(%XQUSR,%XQOP) ;Find out if a user has access to a particular option
+ Q $$ACCESS^XQCHK3(%XQUSR,%XQOP)
+ ;
+ ;    W $$ACCESS(DUZ,Option IEN) returns:
+ ;
+ ;-1:no such user in the New Person File
+ ;-2: User terminated or has no access code
+ ;-3: no such option in the Option File
+ ;0: no access found in any menu tree the user owns
+ ;
+ ;    All other cases return a 4-piece string stating
+ ;    access ^ menu tree IEN ^ a set of codes ^ key
+ ;
+ ;O^tree^codes^key: No access because of locks (see XQCODES below)
+ ;  where 'tree' is the menu where access WOULD be allowed
+ ;  and 'key' is the key preventing access
+ ;1^OpIEN^^: Access allowed through Primary Menu
+ ;2^OpIEN^codes^: Access found in the Common Options
+ ;3^OpIEN^codes^: Access found in top level of secondary option
+ ;4^OpIEN^codes^: Access through a the secondary menu tree OpIEN.
+ ;
+ ;XQCODES can contain:
+ ;  N=No Primary Menu in the User File (warning only)
+ ;  L=Locked and the user does not have the key (forces 0 in first piece)
+ ;  R=Reverse lock and user has the key (forces 0 in first piece)
+ ;
+ I '$D(^VA(200,%XQUSR,0)) Q -1
+ N %,DT
+ S DT=$$HTFM^XLFDT($H,1)
+ S %=^VA(200,%XQUSR,0) I ($P(%,U,3)="")!($L($P(%,U,11))&($P(%,U,11)'>DT)) Q -2
+ ;
+ ;Convert %XQOP to its IEN if the name is passed
+ I +%XQOP'=%XQOP D
+ .I $D(^DIC(19,"B",%XQOP))<1 S %XQOP=0 Q
+ .E  S %XQOP=$O(^DIC(19,"B",%XQOP,0))
+ .Q
+ I '%XQOP Q -3
+ I '$D(^DIC(19,%XQOP,0)) Q -3
+ ;
+ N XQCODES,XQCOM,XQDIC,XQDONE,XQI,XQJ,XQKEY,XQOK,XQPM,XQRSLT,XQSEC,XQTREE
+ S (%,XQDONE,XQOK)=0,(XQRSLT,XQCODES,XQTREE)=""
+ ;
+ ;
+ ;Look in the user's primary menu tree
+ S XQPM=$P($G(^VA(200,%XQUSR,201)),"^")
+ I 'XQPM S XQCODES=XQCODES_"N"
+ ;
+ ;
+ I XQPM S XQDIC="P"_XQPM I $D(^XUTL("XQO",XQDIC,"^",%XQOP)) D
+ .D KEYS
+ .I XQCODES'["L"&(XQCODES'["M") S XQOK=1
+ .Q
+ I XQOK Q "1^"_XQPM_"^"_XQCODES
+ I XQCODES["L"!(XQCODES["R") S XQRSLT="0^"_XQPM_"^"_XQCODES_"^"_XQKEY
+ ;
+ ; Search the common options
+ S XQCOM=$O(^DIC(19,"B","XUCOMMAND",0))
+ S XQDIC="PXU"
+ I $D(^XUTL("XQO",XQDIC,"^",%XQOP)) D
+ .D KEYS
+ .I XQCODES'["L"&(XQCODES'["R") S XQOK=1
+ .Q
+ I XQOK Q "2^"_XQCOM_"^"_XQCODES
+ I XQRSLT="" I XQCODES["L"!(XQCODES["R") S XQRSLT="0^"_XQCOM_"^"_XQCODES_"^"_XQKEY
+ ;
+ ;Check the top level of the secondary options
+ S XQDIC="U"_%XQUSR
+ I $D(^VA(200,%XQUSR,203,0)),$P(^(0),U,4)>0 D
+ .S XQJ=0,XQDONE=0
+ .F XQI=1:1 D  Q:XQDONE
+ ..S XQJ=$O(^VA(200,%XQUSR,203,XQJ))
+ ..I (XQJ'=+XQJ)!('XQJ) S XQDONE=1 Q
+ ..S XQSEC(XQI)=+^VA(200,%XQUSR,203,XQJ,0)
+ ..Q:XQSEC(XQI)'=%XQOP
+ ..D KEYS
+ ..I XQCODES'["L"&(XQCODES'["R") S XQOK=1
+ ..I XQRSLT="" I XQCODES["L"!(XQCODES["R") S XQRSLT="0^"_XQSEC(XQI)_"^"_XQCODES_"^"_XQKEY
+ ..Q
+ .Q
+ I XQOK Q "3^"_%XQOP_"^"_XQCODES
+ ;
+ ;If there are no secondaries quit here
+ I '$D(XQI)&((XQCODES["L")!(XQCODES["R")) Q XQRSLT
+ I '$D(XQI) Q 0
+ ;
+ ;Check each secondary menu tree
+ F XQK=1:1:XQI-1 Q:XQOK  D
+ .S XQDIC="P"_XQSEC(XQK)
+ .Q:'$D(^XUTL("XQO",XQDIC,"^",%XQOP))
+ .S XQTREE=$P(XQDIC,"P",2)
+ .D KEYS
+ .I XQCODES'["L"&(XQCODES'["R") S XQOK=1
+ .I XQRSLT="" I XQCODES["L"!(XQCODES["R") S XQRSLT="0^"_XQTREE_"^"_XQCODES_"^"_XQKEY
+ .Q
+ I XQOK Q "4^"_XQTREE_"^"_XQCODES
+ I XQRSLT]"" Q XQRSLT
+ ;
+ ;We doan find nothing nowhere
+ Q "0^^"_XQCODES
+ ;
+KEYS ;Check for keys, reverse keys...
+ N XQK,XQN,XQOPIQ,KFG
+ D CHCK1^XQCHK1 Q:KFG=1
+ I $D(^XUTL("XQO",XQDIC,"^",%XQOP)) S XQOPIQ=^(%XQOP)
+ E  S XQOPIQ=U_^DIC(19,%XQOP,0)
+ ;
+ I $L($P(XQOPIQ,U,7)) D
+ .S %=$P(XQOPIQ,U,7)
+ .F XQN=1:1 S XQK=$P(%,",",XQN) Q:XQK=""  D
+ ..I '$D(^XUSEC(XQK,%XQUSR)) S XQCODES=XQCODES_"L",XQKEY=XQK
+ ..Q
+ .Q
+ ;
+ I $L($P(XQOPIQ,U,17)) D
+ .S %=$P(XQOPIQ,U,17)
+ .F XQN=1:1 S XQK=$P(%,",",XQN) Q:XQK=""  D
+ ..I $D(^XUSEC(XQK,%XQUSR)) S XQCODES=XQCODES_"R",XQKEY=XQK
+ ..Q
+ .Q
+ Q
+ ;
 OPACCES ;Entry point for the option that checks to see if a user has
  ;access to a particular option by calling the above function.
+ D OPACCES^XQCHK3
+ N %,DIC,X,XQANS,XQCODES,XQK,XQKEY,XQOPT,XQOPN,XQPTR,XQRSLT,XQTREE,XQUSER,XQUSN,Y
+ ;
+ S DIC(0)="AEMNQ",DIC="^VA(200,",DIC("A")="Please enter the user's name: " D ^DIC
+ I $D(DUOUT)!($D(DTOUT)) D KILLFM Q
+ I Y=-1 W !!?5,"Sorry we couldn't find that user in the New Person File.",!
+ E  S XQUSN=+Y,XQUSER=$P(Y,U,2)
+ I Y=-1 D KILLFM Q
+ D KILLFM
+ ;
+ S DIC(0)="AEMNQ",DIC="^DIC(19,",DIC("A")="Please enter the name of the option: " D ^DIC
+ I $D(DUOUT)!($D(DTOUT)) D KILLFM Q
+ I Y=-1 W !!?5,"Sorry we couldn't find that option.",!
+ E  S XQOPN=+Y,XQOPT=$P(Y,U,2)
+ I Y=-1 D KILLFM Q
+ D KILLFM
+ ;
+ S XQANS=$$ACCESS(XQUSN,XQOPN)
+ ;W !,XQANS,!
+ ;
+ S XQRSLT=+XQANS,XQTREE=""
+ S XQPTR=$P(XQANS,U,2) I XQPTR>0 S XQTREE=$P(^DIC(19,$P(XQANS,U,2),0),U)
+ S XQCODES=$P(XQANS,U,3),XQKEY=$P(XQANS,U,4)
+ ;
+ I XQRSLT=-1 W !!?5,"User ",XQUSER," is not in the New Person File."
+ I XQRSLT=-2 W !!?5,"User ",XQUSER," has an active termination date,",!?5,"or no verify code."
+ I XQRSLT=-3 W !!?5,"Option ",XQOPT," is not in the Option File."
+ I XQRSLT=0 D
+ .W !!?5,"User ",XQUSER," does not have access to the option",!?5,XQOPT,"."
+ .I XQCODES["L" W !!?5,"There is a lock somewhere in the menu tree "_XQTREE,!?5,"and the user does not hold the key "_XQKEY_"."
+ .I XQCODES["R" W !!?5,"There is a reverse lock somewhere in the menu tree "_XQTREE,!?5,"and the user holds the key "_XQKEY_"."
+ .Q
+ I XQRSLT=1 W !!?5,"User ",XQUSER," has access to the option ",XQOPT,!?5,"through the primary menu ",XQTREE," (",$P(^DIC(19,XQPTR,0),U,2),")."
+ I XQRSLT=2 W !!?5,"User ",XQUSER," has access to the option ",XQOPT,!?5,"through the Common Options (XUCOMMAND)."
+ I XQRSLT=3 W !!?5,"User ",XQUSER," has access to the option ",XQOPT,!?5,"as a top-level secondary menu option."
+ I XQRSLT=4 W !!?5,"User ",XQUSER," has access to the option ",XQOPT,!?5,"through the secondary menu tree ",XQTREE," (",$P(^DIC(19,XQPTR,0),U,2),")."
+ W !
+ ;W !!,%,"  ",XQUSER,"  ",XQOPT
+ Q
+ ;
+KILLFM ;Kill off the FileMan variables
+ K D0,DI,DIC,DIE,DISYS,DQ,DR,DUOUT,DTOUT,X,Y
+ Q
+ ;

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQCHK2.m

-              r628
+              r636
+XQCHK2 ; OAK-BP/BDT - Internal APIs to check Keys for options; 5/20/08
+ ;;8.0;KERNEL;**427,503**;Jul 10, 1995;Build 2
+ ;;"Per VHA Directive 2004-038, this routine should not be modified".
+ Q
+ ;; These Internal Kernel APIs are using in the routine XQCHK
+ ;; to check Keys for options
+ ;;
+CHCKL(XQCY0,XQDUZ) ;Entry point for checking all Locks for an option
+ ;; XQCY0 is $P(^XUTL("XQO",XQDIC,"^",%XQOP),"^",2,99)
+ ;; XQDUZ is IEN of user
+ ;; Return XQRT: Zero or 1^Key found that user needed for the option
+ S XQCY0=$G(XQCY0)
+XQCHK2 ; BP/BDT - GET CALL FROM XQCHK ; [7/19/06 10:45am]
+ ;;8.0;KERNEL;**427**;Jul 10, 1995;Build 3
+ ; Entry point for checking all Locks for a option
+CHCKL(XQCY0,DUZ) ;
  N XQI,XQY,XQX,XQRT,XQK S (XQRT,XQX)=0
- ;check Key for the option; p457
- S XQY=$P(XQCY0,"^"),XQX=$$GETIEN(XQY)
- I +XQX S XQK=$$GET1^DIQ(19,XQX,3)
- I $G(XQK)'="",'$D(^XUSEC(XQK,XQDUZ)) S XQRT=1_"^"_XQK Q XQRT
- ;loop through higher menu options.
  S XQY=$P(XQCY0,"^",5)
  F XQI=1:1  S XQX=$P(XQY,",",XQI) Q:'XQX  D
  . I +XQX S XQK=$$GET1^DIQ(19,XQX,3) I XQK'="",'$D(^XUSEC(XQK,XQDUZ)) S XQRT=1_"^"_XQK Q
+ . I +XQX S XQK=$$GET1^DIQ(19,XQX,3) I XQK'="",'$D(^XUSEC(XQK,DUZ)) S XQRT=1_"^"_XQK Q
  Q XQRT
+ ;
+CHCKRL(XQCY0,XQDUZ) ;Entry point for checking all Reversed Locks for an option
+ ;; XQCY0 is $P(^XUTL("XQO",XQDIC,"^",%XQOP),"^",2,99)
+ ;; XQDUZ is IEN of user
+ ;; Return XQRT: Zero or 1^Reversed Key found that user has
+ S XQCY0=$G(XQCY0)
+ ; Entry point for checking all Reversed Locks for a option
+CHCKRL(XQCY0,DUZ) ;
  N XQI,XQY,XQX,XQRT,XQK S (XQRT,XQX)=0
- ;check Reversed Key for the option; p457
- S XQY=$P(XQCY0,"^"),XQX=$$GETIEN(XQY)
- I +XQX S XQK=$$GET1^DIQ(19,XQX,3.01)
- I $G(XQK)'="",$D(^XUSEC(XQK,XQDUZ)) S XQRT=1_"^"_XQK Q XQRT
- ;loop through higher menu options.
  S XQY=$P(XQCY0,"^",5)
  F XQI=1:1  S XQX=$P(XQY,",",XQI) Q:'XQX  D
  . I +XQX S XQK=$$GET1^DIQ(19,XQX,3.01) I XQK'="",$D(^XUSEC(XQK,XQDUZ)) S XQRT=1_"^"_XQK Q
+ . I +XQX S XQK=$$GET1^DIQ(19,XQX,3.01) I XQK'="",$D(^XUSEC(XQK,DUZ)) S XQRT=1_"^"_XQK Q
  Q XQRT
+ ;
-GETIEN(XQNAME) ;get IEN for an option; 457
- ;; XQNAME is name of an option
- ;; Retrun XQIEN: Null or IEN if existed
- N XQIEN S XQIEN=""
- I $G(XQNAME)="" Q XQIEN
- I '$D(^DIC(19,"B",XQNAME)) Q XQIEN
- S XQIEN=$O(^DIC(19,"B",XQNAME,XQIEN))
- Q XQIEN
+ ;
-CHKTOPL(XQIEN,XQDUZ) ;Check Lock for the top level of the secondary options
- ;this need to be called to check the top level first when check the
- ;Locks for lower menu option because the 6th piece of ^XUTL does not
- ;contain the IEN of the top menu option.
- N XQRT,XQK S XQRT=0
- I XQIEN'=+$G(XQIEN) Q XQRT
- S XQK=$$GET1^DIQ(19,XQIEN,3)
- I $G(XQK)'="",'$D(^XUSEC(XQK,XQDUZ)) S XQRT=1_"^"_XQK
- Q XQRT
+ ;
-CHKTOPRL(XQIEN,XQDUZ) ;Check Reversed Lock the top level of the secondary options
- ;this need to be called to check the top level first when check the
- ;Reversed Locks for lower menu option because the 6th piece of ^XUTL does not
- ;contain the IEN of the top menu option.
- N XQRT,XQK S XQRT=0
- I XQIEN'=+$G(XQIEN) Q XQRT
- S XQK=$$GET1^DIQ(19,XQIEN,3.01)
- I $G(XQK)'="",$D(^XUSEC(XQK,XQDUZ)) S XQRT=1_"^"_XQK
- Q XQRT

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQOR.m

-              r628
+              r636
+XQOR ; SLC/KCM - Prepare to Unwind Options ;5/24/94  17:58 ;
+ ;;8.0;KERNEL;**48,56**;Jul 10, 1995
+XQOR ; SLC/KCM - Prepare to Unwind Options ;4/3/07  16:21
+ ;;8.0;KERNEL;**48,56,437**;Jul 10, 1995;Build 22
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  S DIC=19,DIC(0)="AEMQ" D ^DIC K DIC Q:Y<0  S X=+Y_";DIC(19,"
 EN ;Process options/protocols from top
 …
  S XQORNEST(XQORS)=^TMP("XQORS",$J,XQORS,"VPT"),XQORNEST=XQORS
  G:'$D(@(^TMP("XQORS",$J,XQORS,"REF")_"0)")) EX S ^TMP("XQORS",$J,XQORS,"FLG")=$P(^(0),"^",4)_"^^" G:$P(^TMP("XQORS",$J,XQORS,"FLG"),"^")'?1A EX
+ I $L($P(@(^TMP("XQORS",$J,XQORS,"REF")_"0)"),"^",3)) W !!,$P(^(0),"^",3),! D READ^XQOR4 G EX
+ ; LOCAL MOD VWSD SILENTMODE ECHO SDAM EVENTS (VARIABLE XQORMUTE)
+ I $L($P(@(^TMP("XQORS",$J,XQORS,"REF")_"0)"),"^",3)) W:'$D(ZTSK)&'$D(XQORMUTE) !!,$P(^(0),"^",3),! D:'$D(ZTSK)&'$D(XQORMUTE) READ^XQOR4 G EX
+ ;I $L($P(@(^TMP("XQORS",$J,XQORS,"REF")_"0)"),"^",3)) W !!,$P(^(0),"^",3),! D READ^XQOR4 G EX
+ ;END LOCAL MODE
  D C19^XQOR4 G:Y<0 EX
  S ^TMP("XQORS",$J,0,"FILE")=";"_$P(^TMP("XQORS",$J,XQORS,"VPT"),";",2),^TMP("XQORS",$J,XQORS,"INP")=""

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQOR4.m

-              r628
+              r636
+XQOR4 ; SLC/KCM - Process "^^" jump ;11/18/92  09:53 ;
+ ;;8.0;KERNEL;**56,62**;Jul 10, 1995
+XQOR4 ; SLC/KCM - Process "^^" jump ;1/23/07  15:36
+ ;;8.0;KERNEL;**56,62,437**;Jul 10, 1995;Build 22
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
 DJMP ;From: STAK^XQOR1
  Q:'$D(^TMP("XQORS",$J,XQORS,"ITM",^TMP("XQORS",$J,XQORS,"ITM"),"IN"))
 …
  Q:'$D(@(^TMP("XQORS",$J,XQORS,"REF")_"0)"))  S X=$P(^(0),"^",2) W:X'?1." " !!?(36-($L(X)\2)),"--- "_X_" ---"
+ Q
+READ W !,"Press RETURN to continue: " R X:$S($D(DTIME):DTIME,1:300)
+ ;VWSD LOCAL MOD STARTED HERE, XQ SILENT MODE . VARIABLE XQORMUTE
+READ I '$D(XQORMUTE) W !,"Press RETURN to continue: " R X:$S($D(DTIME):DTIME,1:300)
+ ;READ W !,"Press RETURN to continue: " R X:$S($D(DTIME):DTIME,1:300)
+ ;END LOCAL MOD
+ Q
 C19 N X0 S X0=@(^TMP("XQORS",$J,XQORS,"REF")_"0)"),X=$P(X0,"^",6) I $L(X),'$D(^XUSEC(X,DUZ)) W !!,"This option "_$P(X0,"^")_" is locked.",! D READ S Y=-1 Q

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC.m

r628	r636
1		XQORC ; DRIVER FOR COMPILED XREFS FOR FILE #101 ; ~~10/15/04~~
	1	XQORC ; DRIVER FOR COMPILED XREFS FOR FILE #101 ; 01/30/05
2	2	;
3	3	N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC1.m

r628	r636
1		XQORC1 ; COMPILED XREF FOR FILE #101 ; ~~10/15/04~~
	1	XQORC1 ; COMPILED XREF FOR FILE #101 ; 01/30/05
2	2	;
3	3	S DIKZK=2

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC10.m

r628	r636
1		XQORC10 ; COMPILED XREF FOR FILE #101.02 ; ~~10/15/04~~
	1	XQORC10 ; COMPILED XREF FOR FILE #101.02 ; 01/30/05
2	2	;
3	3	S DA=0

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC11.m

r628	r636
1		XQORC11 ; COMPILED XREF FOR FILE #101.021 ; ~~10/15/04~~
	1	XQORC11 ; COMPILED XREF FOR FILE #101.021 ; 01/30/05
2	2	;
3	3	S DA=0

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC12.m

r628	r636
1		XQORC12 ; COMPILED XREF FOR FILE #101.03 ; ~~10/15/04~~
	1	XQORC12 ; COMPILED XREF FOR FILE #101.03 ; 01/30/05
2	2	;
3	3	S DA=0

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC13.m

r628	r636
1		XQORC13 ; COMPILED XREF FOR FILE #101.07 ; ~~10/15/04~~
	1	XQORC13 ; COMPILED XREF FOR FILE #101.07 ; 01/30/05
2	2	;
3	3	S DA=0

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC14.m

r628	r636
1		XQORC14 ; COMPILED XREF FOR FILE #101.0775 ; ~~10/15/04~~
	1	XQORC14 ; COMPILED XREF FOR FILE #101.0775 ; 01/30/05
2	2	;
3	3	S DA=0

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC2.m

r628	r636
1		XQORC2 ; COMPILED XREF FOR FILE #101.01 ; ~~10/15/04~~
	1	XQORC2 ; COMPILED XREF FOR FILE #101.01 ; 01/30/05
2	2	;
3	3	S DA(1)=DA S DA=0

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC3.m

r628	r636
1		XQORC3 ; COMPILED XREF FOR FILE #101.02 ; ~~10/15/04~~
	1	XQORC3 ; COMPILED XREF FOR FILE #101.02 ; 01/30/05
2	2	;
3	3	S DA=0

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC4.m

r628	r636
1		XQORC4 ; COMPILED XREF FOR FILE #101.021 ; ~~10/15/04~~
	1	XQORC4 ; COMPILED XREF FOR FILE #101.021 ; 01/30/05
2	2	;
3	3	S DA=0

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC5.m

r628	r636
1		XQORC5 ; COMPILED XREF FOR FILE #101.03 ; ~~10/15/04~~
	1	XQORC5 ; COMPILED XREF FOR FILE #101.03 ; 01/30/05
2	2	;
3	3	S DA=0

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC6.m

r628	r636
1		XQORC6 ; COMPILED XREF FOR FILE #101.07 ; ~~10/15/04~~
	1	XQORC6 ; COMPILED XREF FOR FILE #101.07 ; 01/30/05
2	2	;
3	3	S DA=0

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC7.m

r628	r636
1		XQORC7 ; COMPILED XREF FOR FILE #101.0775 ; ~~10/15/04~~
	1	XQORC7 ; COMPILED XREF FOR FILE #101.0775 ; 01/30/05
2	2	;
3	3	S DA=0

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC8.m

r628	r636
1		XQORC8 ; COMPILED XREF FOR FILE #101 ; ~~10/15/04~~
	1	XQORC8 ; COMPILED XREF FOR FILE #101 ; 01/30/05
2	2	;
3	3	S DIKZK=1

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC9.m

r628	r636
1		XQORC9 ; COMPILED XREF FOR FILE #101.01 ; ~~10/15/04~~
	1	XQORC9 ; COMPILED XREF FOR FILE #101.01 ; 01/30/05
2	2	;
3	3	S DA(1)=DA S DA=0

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQSUITE.m

-              r628
+              r636
 XQSUITE ;Luke/Sea - Window Suite driver ;2/14/95  10:32
+ ;;8.0;KERNEL;;Jul 10, 1995
+ ;;8.0;KERNEL;;Jul 10, 1995;Build 4
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
  ;Jump-start XQSUITE by asking which suite to run
 …
  .D GET^XGCLOAD(XQSUI,$NA(^TMP($J,XQWIN)))
  .D M^XG(XQWIN,$NA(^TMP($J,XQWIN)))
  .D SD^XG($PD,"FOCUS",XQWIN)
+ .D SD^XG($P,"FOCUS",XQWIN)
  .;D ESTA^XG() ;Send it off to window land
  .;

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUP.m

-              r628
+              r636
 XUP ;SFISC/RWF - Setup enviroment for programmers ;10/12/06  12:45
  ;;8.0;KERNEL;**208,258,284,432**;Jul 10, 1995;Build 3
+XUP ;SFISC/RWF - Setup enviroment for programmers ;09/21/2004  16:35
+ ;;8.0;KERNEL;**208,258,284**;Jul 10, 1995
  W !,"Setting up programmer environment"
  S U="^",$ECODE="",$ETRAP="" ;Clear error and error trap
+ N $ESTACK,$ETRAP S $ECODE="",$ETRAP="" ;Clear and error trap
  X ^%ZOSF("TYPE-AHEAD")
  ;Check if Production and report
 …
  I $D(DUZ("SAV")) S DUZ=+DUZ("SAV"),DUZ(0)=$P(DUZ("SAV"),U,2) K DUZ("SAV")
  ;Get user info
- I $G(DUZ)>.5,$D(^VA(200,DUZ,0))[0 K DUZ W !,"DUZ Must point to a real user." G EXIT ;p432
  I $G(DUZ)>0 D DUZ(DUZ)
  I $G(DUZ)'>0!('$D(DUZ(0))) D ASKDUZ G:Y'>0 EXIT
  I '$D(XQUSER) S XQUSER=$S($D(^VA(200,DUZ,20)):$P(^(20),"^",2),1:"Unk")
  S DTIME=600 ;Set a temp DTIME
- S DILOCKTM=+$G(^DD("DILOCKTM"),1) ;p432
  ;Getting Terminal Type
 ZIS I XUTT D ENQ^XUS1 G:$D(XUIOP(1)) ZIS2 S Y=0 D TT^XUS3 I Y>0 S XUIOP(1)=$P(XUIOP,";",2) G ZIS2
 …
  I $$GET^XPAR("USR^SYS","XUS-XUP SET ERROR TRAP",1,"Q") S $ETRAP="D ERR^XUP"
  D KILL1^XUSCLEAN S $P(XQXFLG,U,3)="XUP" D ^XQ1
+EXIT ;Clean-up and exit
+ D KILL1^XUSCLEAN K XQY,XQY0
+ I $G(DUZ)>0,$$GET^XPAR("USR^SYS","XUS-XUP VPE",1,"Q"),$D(^%ZVEMS) X ^%ZVEMS ;Run VPE
+EXIT D KILL1^XUSCLEAN K XQY,XQY0
+ I $$GET^XPAR("USR^SYS","XUS-XUP VPE",1,"Q"),$D(^%ZVEMS) X ^%ZVEMS ;Run VPE
+ Q
+ ;
+ASKDUZ ;Ask for Access Code
+ N X
+ ;X XUEOFF S DIR(0)="FO",DIR("A")="Access Code" D ^DIR W ! X XUEON I $D(DIRUT) S Y=-1 Q
+ X XUEOFF W !,"Access Code: " S X=$$ACCEPT^XUS() X XUEON
+ I X["^"!('$L(X)) S Y=-1 Q
+ASKDUZ X XUEOFF S DIR(0)="FO",DIR("A")="Access Code" D ^DIR W ! X XUEON I $D(DIRUT) S Y=-1 Q
  S X=$$UP^XLFSTR(X) S:X[":" XUTT=1,X=$P(X,":",1)_$P(X,":",2)
  D ^XUSHSH S Y=$O(^VA(200,"A",X,0))
+ K DUZ D DUZ(+Y)
+ Q
+ K DUZ D DUZ(+Y) Q
+ ;
 DUZ(DA) ;Build DUZ for a user.  Used by Mailman.
  ;(p284) Make the setting of several DUZ parts conditional.
+ N Y
+ S Y(0)=$G(^VA(200,+DA,0)),Y("XUS")=$G(^XTV(8989.3,1,"XUS"))
+ N Y S Y(0)=$G(^VA(200,+DA,0)),Y("XUS")=$G(^XTV(8989.3,1,"XUS"))
  S DUZ=DA
  S:$G(DUZ(0))'="@" DUZ(0)=$P(Y(0),"^",4)
  S DUZ(1)="",DUZ("AG")=$P($G(^XTV(8989.3,1,0)),"^",8)
  S:'$G(DUZ(2)) DUZ(2)=$O(^VA(200,DUZ,2,0))
  S:'DUZ(2) DUZ(2)=+$P(Y("XUS"),"^",17)
  S:'$L($G(DUZ("LANG"))) DUZ("LANG")=$P(Y("XUS"),"^",7)
+ S:'DUZ(2) DUZ(2)=+$P(Y("XUS"),U,17)
+ S:'$L($G(DUZ("LANG"))) DUZ("LANG")=$P(Y("XUS"),U,7)
+ Q
+ ;
 DTIME(E,D) ;Return DTIME value for user E, device D.
+ N P
+ S P=$P($G(^VA(200,+$G(E),200)),"^",10) S:P="" P=$P($G(^%ZIS(1,+$G(D),"XUS")),"^",10) S:P="" P=$P($G(^XTV(8989.3,1,"XUS")),"^",10)
+ N P S P=$P($G(^VA(200,+$G(E),200)),"^",10) S:P="" P=$P($G(^%ZIS(1,+$G(D),"XUS")),"^",10) S:P="" P=$P($G(^XTV(8989.3,1,"XUS")),"^",10)
  Q $S(P]"":P,1:300)
+ ;
 ERR ;
  N %XUP U $P
+ U $P
  W !,"$ECODE=",$ECODE,"   $STACK=",$STACK
- W !,"Location: ",$STACK($STACK-1,"PLACE")
  R !!,"Want to record the error: No// ",%XUP:600 I "Yy"[$E(%XUP_"N") D ^%ZTER
  D UNWIND^%ZTER ;S:'$ESTACK $ECODE="" S $ETRAP="" Q:$QUIT "" Q
+ ;

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUPROD.m

-              r628
+              r636
 XUPROD ;ISF/RWF - Is this a PROD account. ;8/23/07  16:47
  ;;8.0;KERNEL;**284,440**;Jul 10, 1995;Build 13
+XUPROD ;ISF/RWF - Is this a PROD account. ;06/17/2004  08:13
+ ;;8.0;KERNEL;**284**;Jul 10, 1995
+ ;
  ;IA# 4440
 …
  N DIR,P S P=$$PROD
  S DIR(0)="YO",DIR("A")="Is this a Production Account",DIR("B")="No"
+ S DIR("A",1)=""
+ S DIR("A",2)="This is now a "_$S(P:"PRODUCTION",1:"TEST")_" account."
+ S DIR("A",3)=" "
+ S DIR("A",4)="Only answer YES if this is the full time Production Account."
+ S DIR("A",5)="Answer No for all other accounts."
+ S DIR("A",1)="This is now a "_$S(P:"PRODUCTION",1:"TEST")_" account."
+ S DIR("A",2)=" "
+ S DIR("A",3)="Only answer YES if this is the full time Production Account."
+ S DIR("A",4)="Answer No for all other accounts."
  D ^DIR Q:$D(DIRUT)
  I Y=1 D SSID($$SID^%ZOSV)
 …
  W:P !!,"This is now a PRODUCTION account.",! W:'P !!,"This is now a TEST account.",!
+ Q
+ ;
-EDIT ;Edit Logical - Physical fields
- N DIE,DA,DR
- W !!,"This is only valid in a Cache v5.2 client/server configuration."
- W !,"This lets you edit the fields that support the"
- W !,"LOGICAL to PHYSICAL translation for the System ID.",!!
- S DA=1,DIE="^XTV(8989.3,",DR="504;505" D ^DIE
+ Q

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUS.m

-              r628
+              r636
+XUS ;SFISC/STAFF - SIGNON ;2/13/07  14:44
+ ;;8.0;KERNEL;**16,26,49,59,149,180,265,337,419,434**;Jul 10, 1995;Build 6
+XUS ;SFISC/STAFF - SIGNON ;3/19/07  09:15
+ ;;8.0;KERNEL;**16,26,49,59,149,180,265,337,419,437**;Jul 10, 1995;Build 22
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;Sign-on message numbers are 30810.51 to 30810.99
  S U="^" D INTRO^XUS1A()
 …
  . Q
  Q A
+ ;
+ ;
 CHECKAV(X1) ;Check A/V code return DUZ or Zero. (Called from XUSRB)
  N %,%1,X,Y,IEN,DA,DIK
 …
  . Q
  ;End CCOW
  S X1=$$UP(X1) S:X1[":" XUTT=1,X1=$TR(X1,":")
+ S X1=$S($$GET^XPAR("SYS","XU VC CASE SENSITIVE"):$$UP($P(X1,";",1))_";"_$P(X1,";",2),1:$$UP(X1)) S:X1[":" XUTT=1,X1=$TR(X1,":") ; Allow case sensitive for VOE
  S X=$P(X1,";") Q:X="^" -1 S:XUF %1="Access: "_X
  Q:X'?1.20ANP 0
  S X=$$EN^XUSHSH(X) I '$D(^VA(200,"A",X)) D LBAV Q 0
+ S X=$$EN^XUSHSH(X) I '$D(^VA(200,"A",X)) D LBAV Q 0 ; Case insensitive for Access Code for VOE
  S %1="",IEN=$O(^VA(200,"A",X,0)),XUF(.3)=IEN D USER(IEN)
  S X=$P(X1,";",2) S:XUF %1="Verify: "_X S X=$$EN^XUSHSH(X)
 …
  N %
  S U="^",XUEON=^%ZOSF("EON"),XUEOFF=^("EOFF")
  D XUVOL,XOPT S DUZ("LANG")=$P(XOPT,U,7) ;S:$P(XUVOL,U,6)="y" XRTL=XUCI_","_XQVOL
+ D XUVOL,XOPT S DUZ("LANG")=$P(XOPT,U,7) S:$P(XUVOL,U,6)="y" XRTL=XUCI_","_XQVOL
  K ^XUTL("XQ",$J) S XUF=0,XUDEV=0,DUZ=0,DUZ(0)="@",IOS=0,ION=""
  I FLAG S %ZIS="L",IOP="HOME" D ^%ZIS Q:POP
  S XUDEV=IOS,XUIOP=ION
+ S XUDEV=IOS,XUIOP=ION D:$D(XRTL) T0^%ZOSV
  D GETFAC^XUS3($G(IO("IP")))
  S %=$P(XOPT,U,14)
 …
  . S XUF=(%["R")+1,XUF(.1)="",XUF(.2)=0,XUF(.3)=0
  . I %["D" S:$D(^XTV(8989.3,1,4.33,"B",XUDEV))[0 XUF=0
- S DILOCKTM=+$G(^DD("DILOCKTM"),1) ;p434 IA#4909
+ Q
 SET2() ;EF. Return error code (also called from XUSRB)
 …
  S DTIME=600
  I '$P(XOPT,U,11),$D(^%ZIS(1,XUDEV,90)),^(90)>2800000,^(90)'>DT Q 8
+ I $D(XRT0) S XRTN="XUS" D T1^%ZOSV
  Q 0
+ ;
 …
  I $P(XUSER(1.1),U,5),$P(XUSER(1.1),U,5)>XUNOW S XUM(0)=$$FMTE^XLFDT($P(XUSER(1.1),U,5),"2PM") Q 18 ;User locked until
  I $P(XUSER(0),U,11),$P(XUSER(0),U,11)'>DT Q 11 ;Access Terminated
- I $D(DUZ("ASH")) Q 0 ;If auto handle, Allow to sign-on p434
  I $P(XUSER(0),U,7) Q 5 ;Disuser flag set
  I '$L($P(XUSER(1),U,2)) Q 21 ;p419, p434
+ I '$L($P(XUSER(1),U,2)) Q 21 ;419
  Q 0
+ ;

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUS2.m

-              r628
+              r636
 XUS2 ;SF/RWF - TO CHECK OR RETURN USER ATTRIBUTES ;11/29/2006
  ;;8.0;KERNEL;**59,180,313,419,437**;Jul 10, 1995;Build 2
+XUS2 ;SF/RWF - TO CHECK OR RETURN USER ATTRIBUTES ;2/3/07  19:18
+ ;;8.0;KERNEL;**59,180,313,419,437**;Jul 10, 1995;Build 22
+ Q
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+ ;
 ACCED ; ACCESS CODE EDIT from DD
 …
 GET ;Get the user input and convert case.
  S X=$$ACCEPT^XUS I (X["^")!('$L(X)) D DIRUT
  S X=$$UP^XLFSTR(X)
+ I '$D(ASKINGVC)!'$$GET^XPAR("SYS","XU VC CASE SENSITIVE") S X=$$UP^XLFSTR(X) ;for VOE allow case sensitive Verify Code
+ Q
+ ;
 …
  ;Fall into next code
 VERED ; VERIFY CODE EDIT From DD
  N DIR,DIR0,XUAUTO
+ N DIR,DIR0,XUAUTO,ASKINGVC
  I "Nn"[$E(X,1) S X="" Q
  I "Yy"'[$E(X,1) K X Q
  S XUH="",XUAUTO=($P($G(^XTV(8989.3,1,3)),U,3)="y") S:DUZ=DA XUAUTO="n" ;Auto only for admin
+ S ASKINGVC=1,XUH="",XUAUTO=($P($G(^XTV(8989.3,1,3)),U,3)="y") S:DUZ=DA XUAUTO="n" ;Auto only for admin
 VC1 D CLR,VASK:'XUAUTO,VAUTO:XUAUTO G OUT:$D(DIRUT) D REASK G OUT:$D(DIRUT),VC1:'XUK D CLR,VST(XUH,1)
  D CALL^XUSERP(DA,2)
 …
  N PUNC,NA S PUNC="~`!@#$%&*()_-+=|\{}[]'<>,.?/"
  S NA("FILE")=200,NA("FIELD")=.01,NA("IENS")=DA_",",NA=$$HLNAME^XLFNAME(.NA)
+ I ($L(S)<8)!($L(S)>20)!(S'?.UNP)!(S[";")!(S["^")!(S[":") Q "1^"_$$AVHLPTXT
+ ; for VOE allow case sensitive Verify Code with S'?.ANP
+ I ($L(S)<8)!($L(S)>20)!$S($$GET^XPAR("SYS","XU VC CASE SENSITIVE"):S'?.ANP,1:S'?.UNP)!(S[";")!(S["^")!(S[":") Q "1^"_$$AVHLPTXT
  I (S?8.20A)!(S?8.20N)!(S?8.20P)!(S?8.20AN)!(S?8.20AP)!(S?8.20NP) Q "2^VERIFY CODE must be a mix of alpha and numerics and punctuation."
  I $D(^VA(200,DA,.1)),EC=$P(^(.1),U,2) Q "3^This code is the same as the current one."
 …
+ ;
 AGEN ;Generate a ACCESS code
  S XUU=$$AC^XUS4 S (X,XUH)=$$EN^XUSHSH(XUU) I $D(^VA(200,"A",X))!$D(^VA(200,"AOLD",X)) G AGEN
+ S XUU=$$AC^XUS4 S X=$$EN^XUSHSH(XUU),XUH=X I $D(^VA(200,"A",X))!$D(^VA(200,"AOLD",X)) G AGEN
  D CLR W "The new ACCESS CODE is: ",XUU,"   This is ",XUK," of 3 tries."
  D YN
 …
+ ;
 VGEN ;Generate a VERIFY code
  S XUU=$$VC^XUS4 S (X,XUH)=$$EN^XUSHSH(XUU) I ($P($G(^VA(200,DA,0)),U,3)=X)!$D(^VA(200,DA,"VOLD",X)) G VGEN
+ S XUU=$$VC^XUS4 S X=$$EN^XUSHSH(XUU),XUH=X I ($P($G(^VA(200,DA,0)),U,3)=X)!$D(^VA(200,DA,"VOLD",X)) G VGEN
  D CLR W "The new VERIFY CODE is: ",XUU,"   This is ",XUK," of 3 tries."
  D YN
 …
 YN ;Ask if want to keep
  N DIR
+ S Y=1,DIR(0)="YA",DIR("A")=" Do you want to keep this one? ",DIR("B")="YES",DIR("?",1)="If you don't like this code, we can auto-generate another.",DIR("?")="Remember you only get 3 tries!"
+ S:XUK=3 DIR("A")="This is your final choice. "_DIR("A")
+ D ^DIR Q:(Y=1)!$D(DIRUT)  I XUK=2 W !,"O.K. You'll have to keep the next one!",! H 2
+ I (XUK=3)&(Y'=1) W !,"Lets stop and you can try later." H 3 D DIRUT
+ D CLR
+ S Y=1 Q:XUK=3  S DIR(0)="YA",DIR("A")=" Do you want to keep this one? ",DIR("B")="YES",DIR("?",1)="If you don't like this code, we can auto-generate another.",DIR("?")="Remember you only get 3 tries!"
+ D ^DIR Q:(Y=1)!$D(DIRUT)  D CLR W:XUK=2 "O.K. You'll have to keep the next one!",!
+ Q
+ ;

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSCLEAN.m

-              r628
+              r636
 XUSCLEAN ;SF/STAFF - CLEANUP BEFORE EXIT ;10/26/06  08:12
  ;;8.0;KERNEL;**13,59,165,353,434**;Jul 10, 1995;Build 6
+XUSCLEAN ;SF/STAFF - CLEANUP BEFORE EXIT ;05/26/2005  14:28
+ ;;8.0;KERNEL;**13,59,165,353**;Jul 10, 1995;Build 1
 H ;;Exit point for all R/S applications
  LOCK  ;Unlock any locks
 …
 H2 ;No talking after this point
  D C,XUTL
  ;un-comment the following line if you want FM space recall cleared
+ ;un-comment the following line if you want FM space recall cleared
  ;after each session.
  ;K ^DISV($G(DUZ,0))
 …
 KILL1 ;To clean up ALL but kernel variables.
  I $$BROKER^XWBLIB S %2=$P($T(VARLST^XWBLIB),";;",2) I %2]"" N @%2 ;Protect Broker variables.
  N XGWIN,XGDI,XGEVENT ;P434 remove KWAPI
+ N KWAPI,XGWIN,XGDI,XGEVENT
  N XQAEXIT,XQAUSER,XQX1,XQAKILL,XQAID
+ ;p434 add DILOCKTM, remove XRTL, %ZH0
+ K (DUZ,DTIME,DILOCKTM,DT,DISYS,IO,IOBS,IOF,IOM,ION,IOSL,IOST,IOT,IOS,IOXY,U,XQVOL,XQY,XQY0,XQDIC,XQPSM,XQPT,XQAUDIT,XQXFLG,ZTSTOP,ZTQUEUED,ZTREQ)
+ K (DUZ,DTIME,DT,DISYS,IO,IOBS,IOF,IOM,ION,IOSL,IOST,IOT,IOS,IOXY,U,XRTL,%ZH0,XQVOL,XQY,XQY0,XQDIC,XQPSM,XQPT,XQAUDIT,XQXFLG,ZTSTOP,ZTQUEUED,ZTREQ)
  K IO("C"),IO("Q")
+ Q
+ ;
 XMR ;Entry point from XUS to DO xmr and cleanup after.
- N XQXFLG ;p434
  D NEXT^XUS1 S XQXFLG="",XQXFLG("HALT")=1 G H2

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSERBLK.m

-              r628
+              r636
+XUSERBLK ;SF/RWF - Bulk user (new person) COMPUTER ACCESS  ;02/26/2008
+ ;;8.0;KERNEL;**20,214,230,289,419,490**;Jul 10, 1995;Build 5
+ ; Per VHA Directive 2004-038, this routine should not be modified.
+ ; Option: XUSERBLK
+XUSERBLK ;SF/RWF - Bulk user (new person) COMPUTER ACCESS  ; 5/23/2006
+ ;;8.0;KERNEL;**20,214,230,289,419**;Jul 10, 1995;Build 5
  ; This routine allows the Cloning of one person to a group of others.
 A ;
  I $G(DUZ)'>0 W !!,"You are not a known user and can't use this option." Q
  N DIC,X,Y,XUTMP,DA,DIR,XUTERMDT,XUSER,XUY,%ZIS,XUIOP,XMQUIET
+ N DIC,DIR,%,L,XUIOP,XUNODE,XU1,X1,X2,X3,X4,X5,X6,XUTEXT,XUNEW,XUSER,XUTMP,XUTERMDT,XUH,XUU,XUU2,M,P,XU
  K ^TMP($J)
 B1 W @IOF,!?26,"Batch Entry of New Persons"
  W !?26,"--------------------------",!!,"Please select a person to copy from"
  K DIC S DIC(0)="AEQZ",DIC("A")="Template PERSON: ",DIC="^VA(200," D ^DIC
+ Q:$D(DTOUT)!$D(DUOUT)
+ G B1:Y=-1
+ G QUIT:$D(DTOUT)!$D(DUOUT),B1:Y=-1
  ; Show INFO to be copied"
  S XUTMP=+Y,XUTMP(0)=$P(Y,U,2),DA=+Y D EN^DIQ
+ S DIR(0)="Y",DIR("A")="Is this the person whose data you want cloned" D ^DIR Q:$D(DIRUT)  G B1:'Y
+ W !!,"You may enter a date, when the users that are being created/updated",!,"will no longer have access to the system."
+ S DIR(0)="DAO^DT::AEF"
+ S DIR("A")="Enter (optional) TERMINATION DATE: "
+ D ^DIR Q:$D(DTOUT)!$D(DUOUT)
+ S XUTERMDT=Y
+ S DIR(0)="Y",DIR("A")="Is this the person data you want cloned" D ^DIR G B1:'Y
+ W !,"You may enter a date, when the users that are being created/updated",!,"will no longer have access to the system."
+ S XUTERMDT="",%DT="AEF",%DT(0)=DT,%DT("A")="Enter (optional) TERMINATION DATE: " D ^%DT S:Y>0 XUTERMDT=Y
  K XUSER S XUSER=0
 B2 ;
  W !!,?26,"Batch Entry of New Persons",!,?26,"--------------------------",!
  W !,"Clone of: ",XUTMP(0) I XUTERMDT W ?49,"TERMINATION DATE: ",$$FMTE^XLFDT(XUTERMDT)
+ W !,"Clone of: ",XUTMP(0) I XUTERMDT W ?50,"TERMINATION DATE: ",$$FMTE^XLFDT(XUTERMDT)
  ;;
 B3 F  S XUY=$$ADD^XUSERNEW Q:XUY<0  D  ;Create new entry
 …
  . . S DIR(0)="Y",DIR("A")="Do You Want To Clone PERSON CLASS" D ^DIR
  . . S:Y=1 $P(XUY,U,5)=1
  . S:XUY>0 XUSER=XUSER+1,XUSER(XUSER)=XUY W !!,"Next!"
+ . S:XUY>0 XUSER=XUSER+1,XUSER(XUSER)=XUY W !,"Next!",!
  . Q
 B4 ;
+ Q:XUSER'>0
+ I XUTERMDT D
+ . N XUZT
+ . S XUZT("ZTDTH")=XUTERMDT
+ . W !!,"Queueing automatic deactivation for ",$$FMTE^XLFDT(XUTERMDT)
+ . S X=$$NODEV^XUTMDEVQ("CHECK^XUSTERM1",,,.XUZT,1)
+ W !!,"Where do you want to print the COMPUTER ACCOUNT NOTIFICATION LETTERS?"
+ S XMQUIET=1
+ S %ZIS="NMQ" D ^%ZIS Q:POP  ; "N" means don't open device
+ K XMQUIET
+ S XUIOP=ION_";"_IOST_";"_IOM_";"_IOSL
+ D HOME^%ZIS
+ ;I ION["P-MESSAGE-HFS" G START
+ G:XUSER'>0 QUIT
+ I XUTERMDT>0 S ZTRTN="CHECK^XUSTERM1",ZTIO="",ZTDTH=XUTERMDT D ^%ZTLOAD W !,"Automatic deactivation has been queued for this date.",!
+ W !!,"Where do you want to print the COMPUTER ACCOUNT NOTIFICATION LETTERS"
+ S %ZIS="MQ" D ^%ZIS G QUIT:POP
+ I ION["P-MESSAGE-HFS" G START
  I '$D(IO("Q")) G CLONE
 START ;
+ N XUZT
+ S XUZT("ZTDTH")=$H
+ S X=$$NODEV^XUTMDEVQ("CLONE^XUSERBLK",,"XUIOP;XUTMP;XUTERMDT;XUSER;XUSER(",.XUZT,1)
+ S ZTRTN="CLONE^XUSERBLK" F I="XUTMP","XUTERMDT","XUSER","XUSER(" S ZTSAVE(I)=""
+ K IO("Q") D ^%ZTLOAD
+ ;;
+QUIT ;
+ K DIC,DIR,%,L,XUIOP,XUNODE,XU1,X1,X2,X3,X4,X5,X6,XUTEXT,XUNEW,XUSER,XUTMP,XUTERMDT,XUH,XUU,XUU2,M,P,XU
+ K ^TMP($J)
+ Q
  ;;
 CLONE ;;Do work
+ N XUTEXT,XU1,%,DA,XUNEW,XUPURGE
+ S XUTEXT=$O(^DIC(9.2,"B",$$GET^XUPARAM("XUSER COMPUTER ACCOUNT","N"),0))
+ S XUTEXT=$O(^DIC(9.2,"B",$$GET^XUPARAM("XUSER COMPUTER ACCOUNT","N"),0)),XUIOP=ION_";"_IOST_";"_IOM_";"_IOSL
  F XU1=1:1:XUSER S %=XUSER(XU1),DA=+%,XUNEW=$P(%,U,3),XUPURGE=$P(%,U,4) D C2,UPDATE("ORD",DA)
  K ^TMP($J)
+ Q
+ G QUIT
+ ;
 C2 ;
  N XUU,XUU2,XFDA,XUH,XUH2,XIEN,XERR,Y,XMZ,XMM,XMDT
+ N XUH,XUH2,XUU,XUU2
  I '$D(ZTQUEUED) W !!?8,$S(XUNEW:"CREATING A NEW ACCOUNT FOR '"_$P(XUSER(XU1),U,2)_"'",1:"CONVERTING "_$P(XUSER(XU1),U,2)_"'S ACCOUNT OVER"),!!,"One moment please..."
  D BLDFDA
 …
+ ;
 BLDFDA ;Build the FDA
- N X2,X3,X4,X5,X6,X7,XUNODE,XU
  S XFDA="^TMP($J,""XFDA"")",XIEN="^TMP($J,""XIEN"")" K ^TMP($J)
  ;Move piece on nodes from list, Build XU only once
 …
+ ;
 ACODE ;
- N Z
  F Z=0:0 S XUU=$$AC^XUS4(),XUH=$$EN^XUSHSH(XUU) Q:'($D(^VA(200,"AOLD",XUH))!$D(^VA(200,"A",XUH)))
+ Q
 …
+ ;
 LET(DA,XUTEXT) ;Write access letter
  N DIWF,FR,TO,BY,IOP
+ N DIWF,FR,TO,BY
  S DIWF="^DIC(9.2,"_XUTEXT_",1,",DIWF(1)=200,FR=DA,TO=DA,BY="NUMBER",IOP=XUIOP D EN2^DIWF
+ Q

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSHSH.m

-              r628
+              r636
 XUSHSH ;SF-ISC/STAFF - PASSWORD ENCRYPTION ;3/23/89  15:09 ;
+XUSHSH ;SF-ISC/STAFF - PASSWORD ENCRYPTION ;3/23/89  15:09 ; 4/14/05 1:22pm
  ;;8.0;KERNEL;;Jul 10, 1995
  ;; This is the public domain version of the VA Kernel.
 …
  ;; Input in X
  ;; Output in X
+A Q
+EN(X) Q X
+ ;; Algorithm for VistA Office EHR encryption (BSL)
+A ;
+ S X=$$EN(X)
+ Q
+EN(X) ; GENERIC HASHING ENCRYPTION -- USES ASCII ENCODING
+ N %HASH S %HASH=""
+ N %CHAR
+ F %CHAR=1:1:$L(X) D
+ . I %CHAR#2 S %HASH=$A(X,%CHAR)_%HASH
+ . E  S %HASH=%HASH_$A(X,%CHAR)
+ Q %HASH

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS.m

-              r628
+              r636
+%ZIS ;SFISC/AC,RWF -- DEVICE HANDLER ;1/24/08  16:06
+ ;;8.0;KERNEL;**18,23,69,112,199,191,275,363,440**;JUL 10, 1995;Build 13
+ ;Per VHA Directive 2004-038, this routine should not be modified
+%ZIS ;SFISC/AC,RWF -- DEVICE HANDLER ;10/14/2004  08:46
+ ;;8.0;KERNEL;**18,23,69,112,199,191,275,363**;JUL 10, 1995
  N %ZISOS,%ZISV
  S U="^",%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^%ZOSF("VOL"))
 …
  I '$D(%ZIS),$D(%IS) M %ZIS=%IS
  S:'($D(%ZIS)#2) %ZIS="M" M %IS=%ZIS ;update %IS for now
- I '$D(^XUTL("XQ",$J,"MIXED OS")) S ^XUTL("XQ",$J,"MIXED OS")=$$PRI^%ZOSV
- S %ZIS("PRI")=$G(^XUTL("XQ",$J,"MIXED OS"),1)
+ ;
  I $D(ZTQUEUED) D  I '$D(IOP) S POP=1 G EXIT^%ZIS1
  .I $D(ZTIO)#2,ZTIO="" S:%IS'[0 %IS=%IS_"0",%ZIS=%ZIS_"0"
  I '$D(ZTQUEUED),%IS["T",$P($G(IOP),";")="Q" S POP=1 G EXIT^%ZIS1
  N %,%A,%E,%H,%I,%X,%XX,%Y,%Z,%Z1,%Z2,%Z9,%Z90,%Z91,%Z95,%ZISB,%ZTIME,%ZTYPE
+ N %,%A,%E,%H,%I,%X,%XX,%Y,%Z,%Z1,%Z9,%Z90,%Z91,%Z95,%ZISB,%ZTIME,%ZTYPE
  N %ZHFN,%ZISOLD,DTOUT,DUOUT
  ;Save symbols to restore if don't open a device
 …
  S %=$$LINEPORT^%ZISUTL I % S (%E,%H)=% Q
  S %ZISVT=$I D VTLKUP I '%E S %ZISVT=$I D VIRTUAL
  I %ZISVT=""!(%E'>0) I %IS'[0 O IO(0)::0 I $T U IO(0) W !,"HOME DEVICE ("_$I_") DOES NOT EXIST IN THE DEVICE FILE",!,"PLEASE CONTACT YOUR SYSTEM MANAGER!",*7
+ I %ZISVT=""!(%E'>0) I %IS'[0 O IO(0)::0 I $T U IO(0) W !,"HOME DEVICE DOES NOT EXIST IN THE DEVICE FILE",!,"PLEASE CONTACT YOUR SYSTEM MANAGER!",*7
  S %H=%E S:'%H&(%IS'[0) POP=1 S:(%H>0)&('$D(IO("HOME"))) IO("HOME")=%H_"^"_$I
+ Q
 …
  ;IO("Q") is checked by many routines after a call to ^%ZISC, so only clean on call to %ZIS.
 CLEAN ;Cleanup env. Called from %ZISC also.
+ I $G(IOT)'="SPL" K IO("DOC"),IO("SPOOL") ;(p446)
+ I $G(IOT)'="HFS" K IO("HFSIO") ;p446
+ K IO("DOC"),IO("HFSIO"),IO("SPOOL") ;(p366)
  S (IOPAR,IOUPAR)=""
+ Q
 …
 RESETVAR ;Reset home IO* variables.
  I '$D(^XUTL("XQ",$J,"IO")) Q
+ N %
+ F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY","IOPAR","IOUPAR" I $D(^XUTL("XQ",$J,%))#2 S @%=^(%)
+ F %="IO(""IP"")","IO(""CLNM"")","IO(""DOC"")","IO(""HFSIO"")","IO(""SPOOL"")" I $D(^XUTL("XQ",$J,%))#2 S @%=^(%)
+ S POP=0,IO(0)=IO
+ N % F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY" I $D(^XUTL("XQ",$J,%))#2 S @%=^(%)
+ S POP=0,IO(0)=IO,(IOPAR,IOUPAR)=""
+ Q
+SAVEVAR ;Save home IO* variables, called from XUS1,%ZTMS3
+ N %
+ F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY","IOPAR","IOUPAR" I $D(@%) S ^XUTL("XQ",$J,%)=@%
+ F %="IO(""IP"")","IO(""CLNM"")","IO(""DOC"")","IO(""HFSIO"")","IO(""SPOOL"")" I $D(@%) S ^XUTL("XQ",$J,%)=@%
+SAVEVAR ;Save home IO* variables, called from XUS1
+ N % F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY" I $D(@%) S ^XUTL("XQ",$J,%)=@%
+ Q
 ZISLPC Q  ;No longer called in Kernel v8.

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS1.m

-              r628
+              r636
+%ZIS1 ;SFISC/AC,RWF -- DEVICE HANDLER (DEVICE INPUT) ;1/24/08  16:06
+ ;;8.0;KERNEL;**18,49,69,104,112,199,391,440**;JUL 10, 1995;Build 13
+ ;Per VHA Directive 2004-038, this routine should not be modified
+%ZIS1 ;SFISC/AC,RWF -- DEVICE HANDLER (DEVICE INPUT) ;07/07/2005  15:48
+ ;;8.0;KERNEL;**18,49,69,104,112,199,391**;JUL 10, 1995
 MAIN ;Called from %ZIS with a GO
  I '$D(IOP),$D(^%ZIS(1,%E,0)),'$P(^(0),"^",3) S %A=%H,%Z=^(0) D L2^%ZIS2 G EXIT
 …
  I '$D(IOP),$D(IO("Q")),POP D AQUE^%ZIS3 K:%=2 IO("Q") S:%=2 %ZISB=$S(%IS'["N":2,1:0) I %=-1 S POP=1 G EXIT
  S %E=%H,POP=0,%IS=%ZIS ;Reset %IS from %ZIS
  I %IS'["Q",$D(XQNOGO) S POP=1 W:'$D(IOP) !,$C(7),"OUTPUT IS NEVER ALLOWED FOR THIS OPTION" G EXIT
+ I %IS'["Q",$D(XQNOGO) S POP=1 W:'$D(IOP) !,*7,"OUTPUT IS NEVER ALLOWED FOR THIS OPTION" G EXIT
  D IOP:$D(IOP),R:'$D(IOP)
  G EXIT:$D(DTOUT)!$D(DUOUT)!(POP&$D(IOP)),L1:POP&'$D(IOP)
  D LKUP I %A'>0 S POP=1 D:'$D(DUOUT) MSG1 K DUOUT
+ I POP G EXIT:$D(IOP),L1:'$D(IOP)
  I '$D(^%ZIS(1,%A,0)) D MSG1 K %ZISIOS S POP=1
  I POP G EXIT:$D(IOP),L1:'$D(IOP)
 …
  I $D(%ZIS("S")) N Y S Y=%E D XS^ZISX S:'$T POP=1 G G:POP
  W:'$D(IOP)&($P(%Z,"^",2)'=$I)&($P(%Z1,"^")]"") "  ",$P(%Z1,"^")
  D L2^%ZIS2 ;Call
+ D L2^%ZIS2
 G G L1:POP&'$D(IOP)&'($D(DTOUT)!$D(DUOUT)) ;Didn't get it
+ ;For type[TRM reset $X & $Y
+ I 'POP,%ZTYPE["TRM",IO]"",$D(IO(1,IO)) U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0
+ ;
+EXIT ;
+ I POP G EX2 ;Did not get the device.
+ ;For type[TRM reset $X & $Y
+ I %ZTYPE["TRM",IO]"",$D(IO(1,IO)) U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0
+EXIT I $D(IO)#2,IO]"",$D(IO(1,IO))#2,$D(%Z1),$P(%Z1,"^",11) S IO(1,IO,"NOFF")=1
  ;Do count of number of times device opened.  Field 51.
  I $L($G(IO)),$D(IO(1,IO))#2,$G(%ZISIOS) D
+ I $L($G(IO)),$D(IO(1,IO))#2,'POP,$G(%ZISIOS) D
  . S $P(^(5),"^",1)=$P($G(^%ZIS(1,%ZISIOS,5)),"^",1)+1
+ I %ZIS["H" S IO(0)=IO,IO("HOME")=%ZISIOS_"^"_IO ;Make home device
+ I '$D(IO("Q")),$D(%ZISLOCK) S ^XUTL("XQ",$J,"lock",%ZISIOS)=%ZISLOCK
+ I $D(IO)#2,IO]"",$D(IO(1,IO))#2,$D(%Z1),$P(%Z1,"^",11) S IO(1,IO,"NOFF")=1
+EX2 ;
+ I 'POP,%ZIS["H" S IO(0)=IO,IO("HOME")=%ZISIOS_"^"_IO ;Make home device
  I %IS'[0,$G(IO(0))]"" U IO(0) ;Make sure return with home active
  G SETVAR:'POP!(%IS["T"),KILVAR
 …
  S %IS=%IS_%X K IOP W %X D SETQ Q
  ;Get ready to ask user for device
 R I %IS["Q",$D(XQNOGO) W !,$C(7),"AT THIS TIME, OUTPUT MUST BE QUEUED"
+R I %IS["Q",$D(XQNOGO) W !,*7,"AT THIS TIME, OUTPUT MUST BE QUEUED"
  S %A=$S($D(%IS("B")):%IS("B"),1:"HOME") ;Setup default
  I %IS["P",%A="HOME",$D(^%ZIS(1,%E,99)),$D(^%ZIS(1,+^(99),0)) S %A=$P(^(0),"^",1)
 …
  I %X'=%ZISVT S %ZISVT=%X D VTLKUP^%ZIS S %A=%E Q:%A>0  ;uppercase lookup
  N %XX,%YY S %XX=%X D 1^%ZIS5 S %A=+%YY Q
 SBR K DFOUT,DTOUT,DUOUT R %X:$S($D(DTIME)#2:DTIME,1:300) E  W $C(7) S DTOUT=1 Q
+SBR K DFOUT,DTOUT,DUOUT R %X:$S($D(DTIME)#2:DTIME,1:300) E  W *7 S DTOUT=1 Q
  S:%X="."!(%X="^") DUOUT=1,%X="" Q
 LC S %X=$$UP(%X)
 …
 LOW(%) Q $TR(%,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
 UP(%) Q $TR(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+ ;
+ ;Call/Return % = 1 (yes), 2 (no) -1 (^)
+YN W "? ",$P("Yes// ^No// ",U,%)
+RYN R %X:$S($D(DTIME):DTIME,$D(%ZISDTIM):%ZISDTIM,1:300) E  S DTOUT=1,%X=U W $C(7)
+YN W "? ",$P("YES// ^NO// ",U,%)
+RYN R %X:$S($D(DTIME):DTIME,$D(%ZISDTIM):%ZISDTIM,1:300) E  S DTOUT=1,%X=U W *7
  S:%X]""!'% %=$A(%X),%=$S(%=89:1,%=121:1,%=78:2,%=110:2,%=94:-1,1:0)
+ I '%,%X'?."?" W $C(7),"??",!?4,"ANSWER 'Yes' OR 'No': " G RYN
+ W:$X>73 ! W $P("  (Yes)^  (No)",U,%)
+ Q
+MSG1 I '$D(IOP) W ?20,$C(7),"  [DEVICE DOES NOT EXIST]"
+ I '%,%X'?."?" W *7,"??",!?4,"ANSWER 'YES' OR 'NO': " G RYN
+ W:$X>73 ! W $P("  (YES)^  (NO)",U,%) Q
+MSG1 I '$D(IOP) W ?20,*7,"  [DEVICE DOES NOT EXIST]"
+ Q
 SETVAR ;Come here to setup the variables for the selected device
 …
  S IOT=%ZTYPE,IOST(0)=%ZISIOST(0),IOST=%ZISIOST,IOPAR=%ZISOPAR,IOUPAR=%ZISUPAR,IOHG=%ZISHG
  S:IOF="" IOF="#" ;See that IOF has something
+ K IOCPU S:$D(%ZISCPU) IOCPU=%ZISCPU
+ G KIL
+ K IOCPU S:$D(%ZISCPU) IOCPU=%ZISCPU G KIL
+ ;
 KILVAR ;Come here to restore the calling variables
 …
  S:%IS["T" IO("T")=1 K %ZIS,%IS,%A,%E,%H,%ZISOS,%ZISV,IOP
 K2 K %I,%X,%Y,%Z,%Z1,%Z91,%Z95,%ZTYPE,%ZTIME
+ K %ZISCHK,%ZISCPU,%ZISI,%ZISR,%ZISVT,%ZISB,%ZISX,ZISI,%ZISHGL,%ZISHP,%ZISIO,%ZISIOS,%ZISIOM
+ K %ZISIOF,%ZISIOSL,%ZISIOBS,%ZISIOST,%ZISIOST(0),%ZISTO,%ZISTP,%ZISHG,%ZISSIO,%ZISOPEN,%ZISOPAR,%ZISUPAR
+ K %ZISMY,%ZISQUIT,%ZISLOCK
+ K %ZISCHK,%ZISCPU,%ZISI,%ZISR,%ZISVT,%ZISB,%ZISX,ZISI,%ZISHGL,%ZISHP,%ZISIO,%ZISIOS,%ZISIOM,%ZISIOF,%ZISIOSL,%ZISIOBS,%ZISIOST,%ZISIOST(0),%ZISTO,%ZISTP,%ZISHG,%ZISSIO,%ZISOPEN,%ZISOPAR,%ZISUPAR
+ K %ZISMY,%ZISQUIT
+ Q

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS2.m

-              r628
+              r636
+%ZIS2 ;SFISC/AC,RWF -- DEVICE HANDLER (CHECKS) ;1/24/08  16:07
+ ;;8.0;KERNEL;**69,104,112,118,136,241,440**;JUL 10, 1995;Build 13
+ ;Per VHA Directive 2004-038, this routine should not be modified
+%ZIS2 ;SFISC/AC,RWF -- DEVICE HANDLER (CHECKS) ;06/12/2002  15:41
+ ;;8.0;KERNEL;**69,104,112,118,136,241**;JUL 10, 1995
 HUNT S:'$D(%ZISHP) %ZISHP=%E,%ZISHGL=0 S %E=0
  F  S %ZISHGL=$O(^%ZIS(1,%ZISHG(0),"HG",%ZISHGL)) Q:%ZISHGL'>0  D  Q:%E
 …
 L2 ;Entry point from %ZIS1
  I $D(DTOUT)!$D(DUOUT) K %ZISHP,%ZISHPOP Q
+CHECK ;Get IO check for secondary $I
+ K %ZISCPU N %Z2
+ S POP=0,%Z=^%ZIS(1,%E,0),%Z2=$S(%ZIS("PRI")=1:"",1:$G(^%ZIS(1,%E,2))) ;Get Primary and secondary IO.
+ S IO=$S(%ZIS("PRI")=1:$P(%Z,"^",2),$L($P(%Z2,"^")):$P(%Z2,"^"),1:$P(%Z,"^",2)) ;
+ S:%IS["Q"&'$D(ZTQUEUED)&($P(%Z,"^",12)=1!$D(XQNOGO)) %ZISB=0,IO("Q")=1 ;Forced Queueing
+CHECK K %ZISCPU S POP=0,%Z=^%ZIS(1,%E,0),IO=$P(%Z,"^",2)
+ S:%IS["Q"&'$D(ZTQUEUED)&($P(%Z,"^",12)=1!$D(XQNOGO)) %ZISB=0,IO("Q")=1 ;Forced Queueing
  I $P(%Z,"^",12)=2 S %IS=$TR(%IS,"Q") I $D(IO("Q")) D  Q
  . I '$D(IOP) W !,"Queuing NOT ALLOWED on this device"

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS3.m

-              r628
+              r636
+%ZIS3 ;SFISC/AC,RWF -- DEVICE HANDLER(DEVICE TYPES & PARAMETERS) ;1/24/08  13:18
+ ;;8.0;KERNEL;**18,36,69,104,391,440**;JUL 10, 1995;Build 13
+ ;Per VHA Directive 2004-038, this routine should not be modified
+ ;Call with a Go from ^%ZIS2
+ I %ZIS'["T",$G(^%ZIS(1,+%E,"POX"))]"" D XPOX^ZISX(%E) ;Pre-Open
+%ZIS3 ;SFISC/AC,RWF -- DEVICE HANDLER(DEVICE TYPES & PARAMETERS) ;10/06/2005  13:23
+ ;;8.0;KERNEL;**18,36,69,104,391**;JUL 10, 1995
+ I %ZIS'["T",$G(^%ZIS(1,+%E,"POX"))]"" D XPOX^ZISX(%E)
  I $D(%ZISQUIT) S POP=1 K %ZISQUIT
  S %ZISCHK=1
+ ;I 'POP&(%ZISB)&(%ZTYPE'="RES")&(%ZTYPE'="OTH")&(%ZTYPE'="SDP")&(IO'["::") D DEVOK
+ ;See if need to lock.
+ K %ZISLOCK
+ I %ZIS'["T",+$G(^%ZIS(1,+%E,"GBL")) S %ZISLOCK=$NA(^%ZIS("lock",IO))
+ ;
+ I 'POP G TRM:(%ZTYPE["TRM"),@(%ZTYPE_"^%ZIS6") ;Jump to next part
+ ;
+Q ;%ZIS6 Returns here
+ ;See if need to un-lock.
+ I $D(%ZISUOUT) K %ZISUOUT,%ZISHP,%ZISHPOP Q
+ I 'POP&(%ZISB)&(%ZTYPE'="RES")&(%ZTYPE'="OTH")&(%ZTYPE'="SDP")&(IO'["::") D DEVOK
+ G Q:POP
+ G @%ZTYPE:(%ZTYPE["TRM"),@(%ZTYPE_"^%ZIS6") ;Jump to next part
+ ;
+Q I $D(%ZISUOUT) K %ZISUOUT,%ZISHP,%ZISHPOP Q
  I $D(%ZISHPOP)&$S(IO="":1,1:'$D(IO(1,IO))) D HGBSY^%ZIS2 Q
+ I POP S:%ZIS'["T" IO="" I $D(%ZISHG(0)),%ZIS'["D",'$D(%ZISHPOP) G HUNT^%ZIS2
+ Q  ;Return to %ZIS1
+ ;
+ I POP S:%IS'["T" IO="" I $D(%ZISHG(0)),%IS'["D",'$D(%ZISHPOP) G HUNT^%ZIS2
+ Q
 VTRM ;Virtual terminal type
+TRM ;D OPEN^%ZIS4:'POP&(%ZISB&(%ZIS'["T")),MARGN:'POP,SETPAR:'POP ;Terminal type
+ D MARGN:'POP,SETPAR:'POP ;Terminal type// TEST CHANGE
+ I 'POP,%ZIS'["T",%ZISB=1,'$D(IOP),IO'=IO(0),'$D(IO("Q")),%ZIS["Q" D AQUE
+ W:'$D(IOP) !
+ I '$D(IO("Q")),'POP,%ZISB,%ZIS'["T" D O^%ZIS4
+TRM D OPEN^%ZIS4:'POP&(%ZISB&(%IS'["T")),MARGN:'POP,SETPAR:'POP ;Terminal type
+ I 'POP,%IS'["T",%ZISB=1,'$D(IOP),IO'=IO(0),'$D(IO("Q")),%IS["Q" D AQUE
+ W:'$D(IOP) ! I '$D(IO("Q")) D O^%ZIS4:'POP&(%ZISB&(%IS'["T"))
  G Q
 DEVOK N X,Y,X1 ;Not sure this is needed
+DEVOK N X,Y,X1
  S X=IO,X1=%ZTYPE
  D DEVOK^%ZOSV I Y=-99!(Y=0)!(Y=$J) Q
  I Y>0 S POP=1 W:'$D(IOP)&('$D(%ZISHG(0))!(%IS["D")) !,$C(7),"[Device Unavailable]" Q
  I Y=-1 S IO="",POP=1 W:'$D(IOP)&('$D(ZISHG(0))!(%IS["D")) !,$C(7),"[Device does not Exist or Unavailable]" Q
+ I Y>0 S POP=1 W:'$D(IOP)&('$D(%ZISHG(0))!(%IS["D")) !,*7,"[Device Unavailable]" Q
+ I Y=-1 S IO="",POP=1 W:'$D(IOP)&('$D(ZISHG(0))!(%IS["D")) !,*7,"[Device does not Exist or Unavailable]" Q
+ Q
+ ;
 …
  S POP=1 I %ZISB&(%ZTYPE["TRM")&(IO'=IO(0)) C IO K IO(1,IO) Q
+ Q
 SETPAR S:$L(%ZISOPAR)&($E(%ZISOPAR)'="(") %ZISOPAR="("_%ZISOPAR_")"
+SETPAR S:%ZISOPAR]""&($A(%ZISOPAR)-40) %ZISOPAR="("_%ZISOPAR_")"
+ Q
+AQUE ;Ask about Queueing
+ W ! S %=$S($D(IO("Q")):1,1:2),U="^",%ZISDTIM=60
+AQUE W ! S %=$S($D(IO("Q")):1,1:2),U="^",%ZISDTIM=60
  I $D(IO("Q")) W !,"Previously, you have selected queueing."
  W !,"Do you "_$S($D(IO("Q")):"STILL ",1:"")_"want your output QUEUED"
 …
  I %=-1 S POP=1,%ZISHPOP=1,%ZISUOUT=1 C IO K IO(1,IO) Q
  I %=1 S IO("Q")=1 C IO K IO(1,IO) Q
- ;I %=2 K IO("Q")
+ Q
 ST(%ZISTP) ;
 …
  S:IOST="" IOST="P-OTHER",IOST(0)=0
+ Q

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS4GTM.m

-              r628
+              r636
 %ZIS4 ;ISF/RWF,DW - DEVICE HANDLER SPECIFIC CODE (GT.M for Unix/VMS) ;1/24/08  16:08
  ;;8.0;KERNEL;**275,425,440**;Jul 10, 1995;Build 13
  ;Per VHA Directive 2004-038, this routine should not be modified
+%ZIS4 ;ISF/RWF,DW - DEVICE HANDLER SPECIFIC CODE (GT.M for Unix/VMS) ;03/07/2007
+ ;;8.0;KERNEL;**275,425**;Jul 10, 1995;Build 18
+ ;
 OPEN ;From %ZIS3 for TRM
  G OPN2:$D(IO(1,IO))
 …
+ Q
  ;Why no open paraneters???
 OP1 N $ET S $ET="G OPNERR^%ZIS4"
  I $D(%ZISLOCK) L +@%ZISLOCK:5 E  S POP=1 Q
  O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1
+OP1 N $ES,$ET S $ET="G OPNERR^%ZIS4"
+ L:$D(%ZISLOCK) +@%ZISLOCK:60
+ O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1 L:$D(%ZISLOCK) -@%ZISLOCK
+ Q
 OPNERR ;Open Error
+ S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$$EC^%ZOSV,$EC=""
+ Q
+ S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$$EC^%ZOSV,$EC="" Q
+ ;
 O ;From %ZIS6 for all types.
+O ;From %ZIS6 for other types.
  D:%IS["L" ZIO
+ I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX ;Open Printer Port
+LCKGBL ;Lock Global
+ I %ZTYPE="CHAN" N % S %=$G(^%ZIS(1,+%E,"GBL")) I $L(%) L @("+^"_%_":0") S:'$T POP=1 I POP W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q
+ I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX
 OPAR I $D(IOP),%ZTYPE="HFS",$D(%IS("HFSIO")),$D(%IS("IOPAR")),%IS("HFSIO")]"" S IO=%IS("HFSIO"),%ZISOPAR=%IS("IOPAR")
  I %ZTYPE="CHAN" D TCPIP Q:POP  G OXECUTE^%ZIS6
  S %A=%ZISOPAR_$S(%ZISOPAR["):":"",1:":"_%ZISTO)
+ S %A=%ZISOPAR_$S(%ZISOPAR["):":"",%ZTYPE["CHAN"&($P(%ZTIME,"^",3)="n"):"",1:":"_%ZISTO)
  N % S %(IO)="",%=$P($P($NA(%(IO)),"(",2),")")
  S %A=%_$E(":",%A]"")_%A
 …
+ ;
 O1 N $ES,$ET S $ET="G OPNERR^%ZIS4"
  I $D(%ZISLOCK) L +@%ZISLOCK:5 E  S POP=1 Q
  O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)=""
+ L:$D(%ZISLOCK) +@%ZISLOCK:60
+ O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)="" L:$D(%ZISLOCK) -@%ZISLOCK
  S IO("ERROR")="" Q
+ ;
 …
+ Q
+ ;
 TCPIP ;For TCP/IP devices, should use ^%ZISTCP
+TCPIP ;For TCP/IP devices
  N %S
  S %ZISTO=$G(%ZISTO,3)
 …
  I $D(ZISDA) W:'$D(IOP) !?5,*7,"You may not Spool the printing of a Spool document" G N
  I $D(DUZ)[0 W:'$D(IOP) !,"Must be a valid user." G N
+R S %ZY=-1 D NEWDOC^ZISPL1 G N:%ZY'>0
+ S %ZDA=+%ZY,%ZFN=$P(%ZY(0),U,2),IO("DOC")=$P(%ZY(0),U,1) G OK:$D(IO("Q"))
+ G:'%ZISB OK I '$P(%ZY,"^",3),$L(%ZFN) O %ZFN:(append:nowrap):2 G DOC
+R S %ZY=-1 D NEWDOC^ZISPL1 G N:%ZY'>0 S %ZDA=+%ZY,%ZFN=$P(%ZY(0),U,2),IO("DOC")=$P(%ZY(0),U,1) G OK:$D(IO("Q"))
+ G:'%ZISB OK I '$P(%ZY,"^",3),%ZFN]"" D SPL3 G N:%ZFN']"",DOC
  S %ZFN=IO_"SPOOL_no_"_%ZDA_".TMP" D SPL2 G:%ZFN']"" N S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)=""
 DOC S IO=%ZFN,IO("SPOOL")=%ZDA,^XUTL("XQ",$J,"SPOOL")=%ZDA,IOF="#"
 …
 OK K %ZDA,%ZFN Q
 N K %ZDA,%ZFN,IO("DOC") S POP=1 Q
+ ;
+SPL2 ;Open for write
+ O %ZFN:(newversion:noreadonly:nowrap:exception="G SPL4"):2 G:$ZA<0 SPL4 S IO(1,%ZFN)="" Q
+ ;
+SPL3 ;Open for Read
+ O %ZFN:(readonly:exception="G SPL4"):2 S:'$T ZISPLQ=1 G:'$T SPL4 S IO(1,%ZFN)="" Q
+SPL2 O %ZFN:(NEWVERSION:WORLD=RWD) G:$ZA<0 SPL4 S IO(1,%ZFN)="" Q
+SPL3 N X S X="SPL4^%ZIS4",@^%ZOSF("TRAP")
+ O %ZFN:READONLY:1 S:'$T ZISPLQ=1 G:$ZA<0!('$T) SPL4 S IO(1,%ZFN)="" Q
 SPL4 W:'$D(IOP)&'$D(ZTQUEUED) !?5,*7,"Couldn't open the spool file." S %ZFN="" Q
+ ;
+CLOSE ;Close out the spool
+ N %,%1,%Z1,%ZFN,%ZS,%ZDA,XS,%Y,%X
+ I $L(IO) C IO K IO(1,IO)
+ D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q
+ S %ZFN=$P(%ZS,"^",2) D SPL3 Q:%ZFN']""  S %ZCR=$C(13),%Y=""
+ S %Z1=+$G(^XTV(8989.3,1,"SPL")),%=0
+ U %ZFN F  R %X#255:5 Q:$ZEOF  S %2=%X D CL2 Q:%Z1<%
+CLOSE N %Z1 C:IO]"" IO K:IO]"" IO(1,IO) D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q
+ S %ZFN=$P(%ZS,"^",2) D SPL3 Q:%ZFN']""  U %ZFN S %ZCR=$C(13),%Y="",X="SPLEOF^%ZIS4",@^%ZOSF("TRAP")
+ S %Z1=+$G(^XTV(8989.3,1,"SPL"))
+ F %=0:0 R %X#255:5 Q:$ZA<0  S %2=%X D CL2 G:%Z1<% SPLEX
+SPLEOF I $ZE'["ENDO" Q  ;Send error up
 SPLEX C %ZFN:(DELETE) K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q
+ ;

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS4ONT.m

-              r628
+              r636
+%ZIS4 ;SFISC/RWF,AC - DEVICE HANDLER SPOOL SPECIFIC CODE (Cache) ;1/24/08  16:08
+ ;;8.0;KERNEL;**34,59,69,191,278,293,440**;Jul 10, 1995;Build 13
+ ;Per VHA Directive 2004-038, this routine should not be modified
+OPEN ;Called for TRM devices
+ G OPN2:$D(IO(1,IO))
+%ZIS4 ;SFISC/RWF,AC - DEVICE HANDLER SPOOL SPECIFIC CODE (OpenM/WNT) ;11/03/2003  17:32
+ ;;8.0;KERNEL;**34,59,69,191,278,293**;Jul 10, 1995
+ ;
+OPEN G OPN2:$D(IO(1,IO))
  S POP=0 D OP1 G NOPEN:'$D(IO(1,IO))
+OPN2 ;
+ I $D(%ZISHP),'$D(IOP) W !,$C(7)_" Routing to device "_$P(^%ZIS(1,%E,0),"^",1)_$S($D(^(1)):" "_$P(^(1),"^",1)_" ",1:"")
+OPN2 I $D(%ZISHP),'$D(IOP) W !,$C(7)_" Routing to device "_$P(^%ZIS(1,%E,0),"^",1)_$S($D(^(1)):" "_$P(^(1),"^",1)_" ",1:"")
+ Q
+NOPEN ;
+ I %IS'["D",$D(%ZISHP)!(%ZISHG]"") S POP=1 Q
+NOPEN I %IS'["D",$D(%ZISHP)!(%ZISHG]"") S POP=1 Q
  I '$D(IOP) W $C(7)_"  [BUSY]" W "  ...  RETRY" S %=2,U="^" D YN^%ZIS1 G OPEN:%=1
+ K:%E'=%H ^XUTL("ZISPARAM",IO)
  S POP=1 Q
+ Q
 OP1 N $ET S $ET="G OPNERR^%ZIS4"
  I $D(%ZISLOCK) L +@%ZISLOCK:5 E  S POP=1 Q
  O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1
+OP1 N X S X="OPNERR^%ZIS4",@^%ZOSF("TRAP")
+ L:$D(%ZISLOCK) +@%ZISLOCK:60
+ O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1 L:$D(%ZISLOCK) -@%ZISLOCK
+ Q
+OPNERR S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$ZE,$EC=""
+ Q
+OPNERR S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$ZE,$EC="" Q
+ ;
+O ;Gets called for all devices
+ N X,%A1
+ D:%ZIS["L" ZIO
+O N X D:%IS["L" ZIO
  I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX ;Open Printer port
 OPAR I $D(IOP),%ZTYPE="HFS",$D(%ZIS("HFSIO")),$D(%ZIS("IOPAR")),%ZIS("HFSIO")]"" S IO=%ZIS("HFSIO"),%ZISOPAR=%ZIS("IOPAR")
  S %A=$S($L(%ZISOPAR):%ZISOPAR,%ZTYPE'["TRM":"",$E(%ZISIOST,1)="C":"("_+%Z91_":""C"")",$E(%ZISIOST,1,2)="PK":"("_+%Z91_":""P"")",1:+%Z91)
+OPAR I $D(IOP),%ZTYPE="HFS",$D(%IS("HFSIO")),$D(%IS("IOPAR")),%IS("HFSIO")]"" S IO=%IS("HFSIO"),%ZISOPAR=%IS("IOPAR")
+ S %A=$S(%ZISOPAR]"":%ZISOPAR,%ZTYPE'["TRM":"",%ZISIOST?1"C".E:"("_+%Z91_":""C"")",%ZISIOST?1"PK".E:"("_+%Z91_":""P"")",1:+%Z91)
  S %A=%A_$S(%A["):":"",%ZTYPE["OTH"&($P(%ZTIME,"^",3)="n"):"",1:":"_%ZISTO),%A=""""_IO_""""_$E(":",%A]"")_%A
  D O1 I POP W:'$D(IOP) !,?5,$C(7)_"[Device is BUSY]" Q
  ;I %ZTYPE="HFS" U IO S X=IO,IO=IO_";"_$P($ZIO,";",2),IO(1,IO)="" K IO(1,X)
  U IO S $X=0,$Y=0
  I $L(%ZISUPAR) S %A1=""""_IO_""":"_%ZISUPAR U @%A1
+ I %ZISUPAR]"" S %A1=""""_IO_""":"_%ZISUPAR U @%A1
  ;U:%IS'[0 IO(0)
  G OXECUTE^%ZIS6
+ ;
 O1 N $ET S $ET="G OPNERR^%ZIS4"
  I $D(%ZISLOCK) L +@%ZISLOCK:5 E  S POP=1 Q
+O1 N X S X="OPNERR^%ZIS4",@^%ZOSF("TRAP")
+ L:$D(%ZISLOCK) +@%ZISLOCK:60
  O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)=""
+ L:$D(%ZISLOCK) -@%ZISLOCK
  S IO("ERROR")=""
+ Q

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS6.m

-              r628
+              r636
+%ZIS6 ;SFISC/AC - DEVICE HANDLER -- RESOURCES ;1/24/08  16:09
+ ;;8.0;KERNEL;**24,49,69,118,127,136,440**;JUL 10, 1995;Build 13
+ ;Per VHA Directive 2004-038, this routine should not be modified
+%ZIS6 ;SFISC/AC - DEVICE HANDLER -- RESOURCES ;02/04/2000  08:14
+ ;;8.0;KERNEL;**24,49,69,118,127,136**;JUL 10, 1995
  ;Expect that IO is current device
+OXECUTE ;Open Execute
+ I $D(^%ZIS(2,%ZISIOST(0),2))=1 S %Y=^(2) D 2
+ANSBAK ;Answer Back
+ I $D(^%ZIS(2,%ZISIOST(0),102)) S %Y=^(102) D 2 E  S POP=1 D:'$D(IOP) SAY($C(7)_"[NOT ON LINE]") C:%ZISB IO K IO(1,IO) G QUIT
+OXECUTE I $D(^%ZIS(2,%ZISIOST(0),2))=1 S %Y=^(2) D 2
+ANSBAK I $D(^%ZIS(2,%ZISIOST(0),102)) S %Y=^(102) D 2 E  S POP=1 D:'$D(IOP) SAY($C(7)_"[NOT ON LINE]") C:%ZISB IO K IO(1,IO) G QUIT
  I $D(%ZISMTR) X ^%ZOSF("MAGTAPE") U IO W:$D(%MT("REW")) @%MT("REW") U IO(0) K %MT
  G QUIT:'$D(IO("P"))
 …
 HG ;
+ Q
+SPL ;Spool type
+ N %E,%Z D MARGN^%ZIS3 W:'$D(IOP) ! D SPOOL^%ZIS4:%IS'["T"
+SPL N %E,%Z D MARGN^%ZIS3 W:'$D(IOP) ! D SPOOL^%ZIS4:%IS'["T" ;Spool type
  G Q
 MT D MARGN^%ZIS3,ASKPAR,AMTREW:'POP&'$D(IOP)&%ZISB W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Magtape type
  G Q
+SDP ;Sequential disk processor type
+ D MARGN^%ZIS3,ASKPAR W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T"))
+SDP D MARGN^%ZIS3,ASKPAR W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Sequential disk processor type
  G Q
+HFS ;Host File Server type
+ D MARGN^%ZIS3,HFS^%ZIS4 W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T"))
+HFS D MARGN^%ZIS3,HFS^%ZIS4 W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Host File Server type
  G Q
+RES ;Resources
+ G Q:%IS["T" N X,X1 I %IS'["R"!'$D(IOP) S POP=1 W:'$D(IOP) *7,"  [NOT AVAILABLE]" Q
+RES G Q:%IS["T" N X,X1 I %IS'["R"!'$D(IOP) S POP=1 W:'$D(IOP) *7,"  [NOT AVAILABLE]" Q  ;Resources
  G Q:$D(IO(1,IO)) I %IS["T" S X=IO,X1="RES" D DEVOK^%ZIS3 S:Y POP=1 G Q:POP
  D:%ZISB RES1 G Q
 …
 IMPC ;Imaging Work Station
 BAR ;Bar Code
+OTH ;Other Device type
+ D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T"))
+OTH D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Other Device type
  G Q
+ ;
+ASKPAR ;Ask Parameters
+ G SETPAR^%ZIS3:$D(IOP),SETPAR^%ZIS3:'$P(^%ZIS(1,%E,0),"^",4) W "  ADDRESS/PARAMETERS: " W:%ZISOPAR]"" %ZISOPAR_"// " D SBR^%ZIS1 D MSG1:%X="?" G ASKPAR:%X="?" S:%X]"" %ZISOPAR=%X I $D(DTOUT)!$D(DUOUT) S POP=1
+ASKPAR G SETPAR^%ZIS3:$D(IOP),SETPAR^%ZIS3:'$P(^%ZIS(1,%E,0),"^",4) W "  ADDRESS/PARAMETERS: " W:%ZISOPAR]"" %ZISOPAR_"// " D SBR^%ZIS1 D MSG1:%X="?" G ASKPAR:%X="?" S:%X]"" %ZISOPAR=%X I $D(DTOUT)!$D(DUOUT) S POP=1
  I POP,%ZISB&(%ZTYPE["TRM") C IO K IO(1,IO) Q
  Q:POP  G SETPAR^%ZIS3
+AMTREW I %ZISB,%ZTYPE="MT",'$D(IOP) W "  REWIND" S %=2,U="^",%ZISDTIM=60 D YN^%ZIS1 K %ZISDTIM G AMTREW:%=0 I %=-1 S POP=1 Q
+ S:%=1 %ZISMTR=1 Q
+MSG1 W !?5,"Enter the desired parameters needed to open the selected device.",!?25 Q
+ ;
-AMTREW ;Mag Tape Rewind
- I %ZISB,%ZTYPE="MT",'$D(IOP) W "  REWIND" S %=2,U="^",%ZISDTIM=60 D YN^%ZIS1 K %ZISDTIM G AMTREW:%=0 I %=-1 S POP=1 Q
- S:%=1 %ZISMTR=1
+ Q
-MSG1 W !?5,"Enter the desired parameters needed to open the selected device.",!?25
+ Q
+ ;

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISC.m

-              r628
+              r636
+%ZISC ;SFISC/GFT,AC,MUS - CLOSE LOGIC FOR DEVICES  ;1/24/08  16:09
+ ;;8.0;KERNEL;**24,36,49,69,199,216,275,409,440**;JUL 10, 1995;Build 13
+ ;Per VHA Directive 2004-038, this routine should not be modified
+%ZISC ;SFISC/GFT,AC,MUS - CLOSE LOGIC FOR DEVICES  ;01/14/2002  09:06
+ ;;8.0;KERNEL;**24,36,49,69,199,216,275,409**;JUL 10, 1995;Build 3
 C0 ;
  N %,%E,%H,%ZISI,%ZISOS,%ZISX,%ZISV
 …
  . U:$S($D(ZTQUEUED):0,'$L($G(IO(0))):0,$D(IO(1,IO(0)))#2:1,1:0) IO(0)
  . C IO K IO(1,IO) S IO("CLOSE")=IO ;close device
- ;Unlock global used to control access.
- S %=$G(^XUTL("XQ",$J,"lock",+$G(IOS))) I $L(%) L -@% K ^XUTL("XQ",$J,"lock",IOS)
+ ;
+ ;
+ I $D(IOT),IOT="CHAN",$D(IOS) D
+ .S %=$G(^%ZIS(1,+IOS,"GBL"))
+ .I %]"" L @("-^"_%) ;unlock global used to control access to network channels.
  I $D(IO("SPOOL")) D CLOSE^%ZIS4 ;Special close for spool device
+ ;

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISEDIT.m

-              r628
+              r636
 ZISEDIT ;ISF/AC - DEVICE EDIT ;01/17/2008
  ;;8.0;KERNEL;**440**;Jul 10, 1995;Build 13
+ZISEDIT ;SFISC/AC - DEVICE EDIT ;11/9/92  17:00
+ ;;8.0;KERNEL;;Jul 10, 1995
+ ;
+TRM ;TRM or VTRM
+ D EDIT("TRM",,"Select Terminal/Printer Device: ")
+MT S ZISTYPE="MT",DIC("A")="Select Magtape Device: " D EDIT K ZISTYPE
+ Q
+ ;
+LPD ;LPD fields of a TRM device
+ D EDIT("LPD","TRM","Select LPD (Terminal/Printer) Device: ")
+SDP S ZISTYPE="SDP",DIC("A")="Select SDP Device: " D EDIT K ZISTYPE
+ Q
+ ;
+MT ;Mag Tape
+ D EDIT("MT",,"Select Magtape Device: ")
+SPL S ZISTYPE="SPL",DIC("A")="Select Spool Device: " D EDIT K ZISTYPE
+ Q
+ ;
+SDP ;
+ D EDIT("SDP",,"Select SDP Device: ")
+HFS S ZISTYPE="HFS",DIC("A")="Select Host File Device: " D EDIT K ZISTYPE
+ Q
+ ;
+SPL ;Spool
+ D EDIT("SPL",,"Select Spool Device: ")
+CHAN S ZISTYPE="CHAN",DIC("A")="Select Network Channel: " D EDIT K ZISTYPE
+ Q
+ ;
+HFS ;Host file
+ D EDIT("HFS",,"Select Host File Device: ")
+ Q
+ ;
+CHAN ;Network
+ D EDIT("CHAN",,"Select Network Channel: ")
+ Q
+ ;
+RES ;Resource
+ D EDIT("RES",,"Select Resource Device: ")
+ Q
+ ;
+EDIT(ZISTYPE,ZISSCR,DICA) ;
+ N Y,DA,DIC,DIE,DR,DDSFILE
+ED2 S DIC("A")=DICA,ZISSCR=$G(ZISSCR,ZISTYPE)
+ S DIC=3.5,DIC(0)="AEMQZL",DIC("S")="I $G(^(""TYPE""))["_""""_ZISSCR_"""" D ^DIC
+ Q:Y'>0
+ S DA=+Y
+ I $P(Y,"^",3) D
+ . N DIE,DR
+ . S DIE=DIC,DR="2///"_ZISTYPE_$S(ZISTYPE["TRM":"",1:";1.95///N")
+ . D ^DIE
+ . Q
+ ;;7.1P0;Kernel;;
+EDIT S DIC=3.5,DIC(0)="AEMQZL",DIC("S")="I $G(^(""TYPE""))="_""""_ZISTYPE_"""" D ^DIC
+ I Y'>0 K DIC Q
+ S DA=+Y I $P(Y,"^",3) S DIE=DIC,DR="2///"_ZISTYPE D ^DIE K DIE,DR
  S DR="[XUDEVICE "_ZISTYPE_"]",DDSFILE=3.5 D ^DDS
+ G ED2
+ Q
+ K DA,DR,DDSFILE Q

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISHONT.m

-              r628
+              r636
 %ZISH ;IHS/PR,SFISC/AC - Host File Control for Cache for VMS/NT/UNIX ;1/24/08  16:11
  ;;8.0;KERNEL;**34,65,84,104,191,306,385,440**;JUL 10, 1995;Build 13
  ;Per VHA Directive 2004-038, this routine should not be modified
+%ZISH ;IHS\PR,SFISC/AC - Host File Control for OpenM/Cache for NT/VMS ;12/13/2005
+ ;;8.0;KERNEL;**34,65,84,104,191,306,385**;JUL 10, 1995;Build 3
+ ;
  ; **MODIFIED VERSION FOR CACHE/VMS -- 9/7/01**
+ ;
 …
  Q 0
+ ;
 DEL(%ZX1,%ZX2) ;ef,SR. Del files, return 1 if deleted all requested.
+DEL(%ZX1,%ZX2) ;ef,SR. Del fl(s)
  ;S Y=$$DEL^%ZISH("dir path",$NA(array))
+ ; will invoke an OS command to delete file(s)
+ ; UNIX: rm -f filespec[ ...]
+ ; VMS: del filespec[,...]
+ N %ZARG,%ZXDEL,%ZOS,%ZDELIM,%ZCOMND,%ZLIST
+ S %ZARG="",%ZXDEL=1
+ S %ZX1=$$DEFDIR($G(%ZX1))
+ S %ZOS=$$OS^%ZOSV
+ S %ZDELIM=$S(%ZOS="UNIX":" ",1:",")
+ S %ZCOMND=$S(%ZOS="UNIX":"rm -f ",1:"del ")
+ D
+ N %,%ZX,%ZXDEL,%ZISH,%ZOS
+ S %ZX1=$$DEFDIR($G(%ZX1)),%ZOS=$$OS^%ZOSV,%ZXDEL=1,%ZISH=""
+ F  S %ZISH=$O(@%ZX2@(%ZISH)) Q:%ZISH=""  D
  . N $ETRAP,$ESTACK S $ETRAP="D DELERR^%ZISH"
+ . N %,%ZI,%ZISH,%ZX,%ZFOUND S %ZISH=""
+ . F %ZI=1:1 S %ZISH=$O(@%ZX2@(%ZISH)) Q:%ZISH=""  D
+ . . N $ETRAP,$ESTACK S $ETRAP="D DELERR^%ZISH"
+ . . I %ZISH["*" S %ZXDEL=0 Q  ; Wild card not allowed.
+ . . S %ZX=$S(%ZISH[%ZX1:%ZISH,1:%ZX1_%ZISH) ; prepend directory path
+ . . I %ZOS="VMS",%ZX'[";" S %ZX=%ZX_";*"
+ . . S %ZFOUND=$ZSEARCH(%ZX)]""  ; File exists
+ . . S:%ZFOUND %ZARG=$S(%ZARG="":%ZX,1:%ZARG_%ZDELIM_%ZX) ; join files
+ . . I $L(%ZARG)>2000 S %=$ZF(-1,%ZCOMND_%ZARG),%ZARG="" H 1 ; delete files at a time
+ . ;
+ . I $L(%ZARG) S %=$ZF(-1,%ZCOMND_%ZARG) ; delete remaining files
+ ;
+ I %ZXDEL S %ZXDEL='$$LIST(%ZX1,%ZX2,"%ZLIST")
+ . I %ZISH["*" S %ZXDEL=0 Q  ; Wild card not allowed.
+ . S %ZX=$S(%ZISH[%ZX1:%ZISH,1:%ZX1_%ZISH)
+ . I %ZOS="VMS",%ZX'[";" S %ZX=%ZX_";*"
+ . Q:$ZSEARCH(%ZX)']""  ; File doesn't exist
+ . S %=$ZF(-1,$S(%ZOS="UNIX":"rm ",1:"del ")_%ZX)
+ . I $ZSEARCH(%ZX)]"" S %ZXDEL=0 ; Delete was not successful.
  Q %ZXDEL
+ ;
 DELERR ;Trap any $ETRAP error, unwind and return.
  S $ETRAP="D UNWIND^%ZTER"
  S %ZXDEL=0,%ZARG=""
+ S %ZXDEL=0
  D UNWIND^%ZTER
+ Q
+ ;
-DEL1(%ZX3) ;ef,SR. Delete one file
- N %ZI1,%ZI2
- D SPLIT(%ZX3,.%ZI1,.%ZI2) S %ZI2(%ZI2)=""
- Q $$DEL(%ZI1,$NA(%ZI2))
+ ;
-SPLIT(%I,%O1,%O2) ;Split to path,file
- N %ZOS,%D,D S %ZOS=$$OS^%ZOSV
- I %ZOS["VMS" D  Q
- . S D=$S(%I["]":"]",1:":")
- . S %O1=$P(%I,D,1)_D,%O2=$P(%I,D,2)
- . Q
- S %D=$S(%ZOS="UNIX":"/",%ZOS="NT":"\",1:""),%O1="",%O2="" Q:%D=""
- S D=$L(%I,%D),%O1=$P(%I,%D,1,D-1),%O2=$P(%I,%D,D)
+ Q
+ ;
-FEXIST(%PATH,%FL) ;Check if files exsist.
- ;S Y=$$DTEST("/usr/var",$NA(array))
- N %ZISH,%ZISHY
- S %ZISH=$$LIST(%PATH,%FL,"%ZISHY")
- Q %ZISH
+ ;
 LIST(%ZX1,%ZX2,%ZX3) ;ef,SR. Create a local array holding file names
  ;S Y=$$LIST^%ZISH("\dir\",$NA(array),$NA(return array)) Return 1 if found anything
+ ;S Y=$$LIST^ZOSHDOS("\dir\",$NA(array),$NA(return array)) Return 1 if found anything
+ ;
  N %ZISH,%ZISHN,%ZX,%ZISHY,%ZY,%ZOS
 …
  . ;NT, display case, ignore for lookup
  . S %ZX=%ZX1_%ZISH
  . F %ZISHN=0:1 D  Q:(%ZX="")
+ . F %ZISHN=0:1 D  Q:(%ZX="")
  . . S %ZX=$ZSEARCH($S(%ZISHN:"",1:%ZX))
  . . ;Q:(%ZX="")!($$UP^XLFSTR(%ZX)'[%ZISHY)!(%ZX?.E1.2".")
 …
  N %ZOS,P1,P2 S %ZOS=$$OS^%ZOSV,DF=$G(DF)
  Q:DF="." "" ;Special way to get current dir.
  S:DF="" DF=$G(^XTV(8989.3,1,"DEV")),DF=$P(DF,"^",$S($$PRI^%ZOSV<2:1,1:2))
+ S:DF="" DF=$G(^XTV(8989.3,1,"DEV"))
  Q:DF="" ""
  ;Check syntax, VMS needs disk:[dir] or logical:
 …
  . S DF=P1_P2 S:DF'[":" DF=DF_":"
  . Q
  ;Check syntax, Unix needs /mnt/fl, ./fl, ~/fl $HOME/fl
+ ;Check syntax, Unix needs /mnt/fl, ./fl
  I %ZOS="UNIX" D
  . S DF=$TR(DF,"\","/")
  . S:$E(DF,$L(DF))'="/" DF=DF_"/"
  . Q
  ;Check syntax, NT needs c:\dir\
+ ;Check syntax, NT needs c:\dir\
  I %ZOS="NT" D
  . N P1,P2
 …
+ ;
 FTG(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5) ;ef,SR. Unload contents of host file into global
  ;p1=hostf file directory
+ ;p1=hostf file directory
  ;p2=host file name
  ;p3= $NAME REFERENCE INCLUDING STARTING SUBSCRIPT

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISS1.m

-              r628
+              r636
+%ZISS1 ;AC/SFISC - Collect screen parameters 5/29/88  2:02 PM ;1/24/08  16:10
+ ;;8.0;KERNEL;**69,440**;JUL 10, 1995;Build 13
+ ;Per VHA Directive 2004-038, this routine should not be modified
+VALID ;
+ N %ZISI,%ZISNP,ZISCH,ZISEND,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440
+ D L
+%ZISS1 ;AC/SFISC - Collect screen parameters 5/29/88  2:02 PM ;11/05/97  08:40
+ ;;8.0;KERNEL;**69**;JUL 10, 1995
+VALID D L K %ZISI,%ZISNP,ZISCH,ZISEND,ZISNUM,ZISQ,ZISXL,ZISXLN Q
+ ;
+SET2 S %ZISFN="" F %ZISZ=0:0 S %ZISFN=$O(%ZISZ(%ZISFN)) Q:%ZISFN=""  I $D(%ZISZ(%ZISFN))#2 S %ZISXX=%ZISZ(%ZISFN) D INDCK
+ Q
+ ;
+SET2 ;
+ S %ZISFN="" F %ZISZ=0:0 S %ZISFN=$O(%ZISZ(%ZISFN)) Q:%ZISFN=""  I $D(%ZISZ(%ZISFN))#2 S %ZISXX=%ZISZ(%ZISFN) D INDCK
+ Q
+INDCK ;
+ S %ZISY=""
+INDCK S %ZISY=""
  I "IOEFLD^IOSTBM"[%ZISFN S @%ZISFN=%ZISXX Q
  I %ZISXX]"" S @("%ZISY="_%ZISXX)
 …
  E  S @("IO"_$E(%ZISFN,1,6))=%ZISY
  Q:'$D(%ZIS)#2  Q:%ZIS'["I"  Q:'$D(%ZISZ(%ZISFN,1))
+ ;
+SRAY ;
+ S %=%ZISY,%ZISY=$A($E(%ZISY,1))
+SRAY S %=%ZISY,%ZISY=$A($E(%ZISY,1))
  F %1=2:1:$L(%) S %ZISY=%ZISY_$S($A(%,%1)<32:$A(%,%1),$A(%,%1)=127:127,1:$E(%,%1))
  S IOIS(%ZISY)=%ZISFN
+ Q
 CHECK ;Entry point called from input transforms of fields in DEV/TT files.
+ N %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440
+ S %ZISXX=X D L S X=%ZISYY
+ S %ZISXX=X D L S X=%ZISYY K %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN
+ Q
 CHECK1 ;Entry point called from input transforms of fields in DEV/TT files.
- N %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440
  S %ZISXX=$S(X?1"W ".E:$E(X,3,$L(X)),1:X)
  D L S X=$S(X?1"W ".E:"W "_%ZISYY,1:%ZISYY)
+ D L S X=$S(X?1"W ".E:"W "_%ZISYY,1:%ZISYY) K %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN
+ Q
 FORM ;Entry point called from input transforms of fields in DEV/TT files.
  Q:$L(X,"_")'>1
- N %ZISSI,%ZISSY ;p440
  ;F %ZISSI=1:1:$L(X,"_") S %ZISX1=$P(X,"_",%ZISSI) I %ZISX1]"","#?!"[$E(%ZISX1) S X=$S(%ZISSI=1:"",1:$P(X,"_",1,%ZISSI-1)_",")_%ZISX1_$S(%ZISSI<$L(X,"_"):","_$P(X,"_",%ZISSI+1,255),1:"") W !,%ZISSI_"==>"_X
  S %ZISSY=""
  F %ZISSI=1:1:$L(X,"_") S %ZISSY=%ZISSY_$P(X,"_",%ZISSI)_$S($P(X,"_",%ZISSI+1)="":"","#?!"[$E($P(X,"_",%ZISSI+1)):",","#?!"[$E($P(X,"_",%ZISSI)):",",1:"_")
  S X=%ZISSY
+ S X=%ZISSY K %ZISSI,%ZISSY
+ Q
+ ;
 L S ZISQ="""",%ZISNP=0,ZISXLN=$L(%ZISXX) I 'ZISXLN S %ZISYY="" Q
  S ZISXL=0,%ZISYY="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) D L1 Q:ZISXL'<ZISXLN
+ S (ZISXL)=0,%ZISYY="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) D L1 Q:ZISXL'<ZISXLN
  ;I $L(%ZISYY,"$C(")>2,%ZISYY[")_$C(" S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX Q
  S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX
 …
  I ZISCH="*" D STAR Q
  I ZISCH="(" D PAREN Q
+ S %ZISYY=%ZISYY_ZISCH
+ S %ZISYY=%ZISYY_ZISCH Q
+L2 F I=1:1:$L(%ZISXX,"_") S %ZISX1=$P(%ZISXX,"_",I),%ZISX2=$P(%ZISXX,"_",I+1) I $E(%ZISX1,1,3)="$C(",$E(%ZISX2,1,3)="$C(" D S2
+ Q
+L2 ;Find $C(x)_$C(y) and merge
+ N I ;p440
+ F I=1:1:$L(%ZISXX,"_") S %ZISX1=$P(%ZISXX,"_",I),%ZISX2=$P(%ZISXX,"_",I+1) I $E(%ZISX1,1,3)="$C(",$E(%ZISX2,1,3)="$C(" D S2
+ Q
+L3 ;
+ N I
+ F I=1:1:$L(%ZISXX,"_") I $P(%ZISXX,"_",I)["+","$("'[$E($P(%ZISXX,"_",I)),")"'[$E($P(%ZISXX,"_",I),$L($P(%ZISXX,"_",I))) S $P(%ZISXX,"_",I)="("_$P(%ZISXX,"_",I)_")"
+L3 F I=1:1:$L(%ZISXX,"_") I $P(%ZISXX,"_",I)["+","$("'[$E($P(%ZISXX,"_",I)),")"'[$E($P(%ZISXX,"_",I),$L($P(%ZISXX,"_",I))) S $P(%ZISXX,"_",I)="("_$P(%ZISXX,"_",I)_")"
+ Q
 STAR ;S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH?1N ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_+ZISNUM_")",ZISXL=ZISXL-1 Q
 …
 QUOTE S %ZISYY=%ZISYY_ZISCH F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL),%ZISYY=%ZISYY_ZISCH I ZISCH=ZISQ!(ZISXL'<ZISXLN) Q
+ Q
 DOLR ;Looking for $C.
+DOLR ;LOOKING FOR $C.
  I "IXY"[$E(%ZISXX,ZISXL+1) S %ZISYY=%ZISYY_"$"_$E(%ZISXX,ZISXL+1) S ZISXL=ZISXL+1 Q
+ I "ACDEFJLNOPRSTV"[$E(%ZISXX,ZISXL+1)&($E(%ZISXX,ZISXL+2)="(") S %ZISYY=%ZISYY_"$"_$E(%ZISXX,ZISXL+1),ZISXL=ZISXL+2 D PAREN Q
+ S %ZISYY=%ZISYY_"$" ;p440
+ I "ACDEFJLNOPRSTV"[$E(%ZISXX,ZISXL+1)&($E(%ZISXX,ZISXL+2)="(") S %ZISYY=%ZISYY_"$"_$E(%ZISXX,ZISXL+1),ZISXL=ZISXL+2 D PAREN
+ Q
+PAREN S %ZISYY=%ZISYY_"(",ZISEND=")",%ZISNP=%ZISNP+1 D SCAN S %ZISNP=%ZISNP-1
+ Q
+PAREN S %ZISYY=%ZISYY_"(",ZISEND=")",%ZISNP=%ZISNP+1 D SCAN S %ZISNP=%ZISNP-1 Q
 SCAN F %ZISI=0:0 S ZISXL=ZISXL+1,ZISCH=$E(%ZISXX,ZISXL) D S1 Q:ZISXL'<ZISXLN!(ZISEND=ZISCH&(%ZISNP))
+ Q
 …
  I ZISCH="$" D DOLR Q
  I ZISCH="(" D PAREN Q
+ S %ZISYY=%ZISYY_ZISCH
+ Q
+ S %ZISYY=%ZISYY_ZISCH Q
+ ;
 S2 ;MERGE $C

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZOSFONT.m

-              r628
+              r636
+ZOSFONT ;SFISC/AC - SETS UP ^%ZOSF for Cache for NT/VMS ;10/19/06  14:01
+ ;;8.0;KERNEL;**34,104,365**;JUL 10, 1995;Build 5
+ ;For Cache versions 3.2, 4 and 5
+ZOSFONT ;SFISC/AC - SETS UP ^%ZOSF FOR Open M for NT ;09/29/98  08:26
+ ;;8.0;KERNEL;**34,104**;JUL 03, 1995
  S %Y=1 K ^%ZOSF("MASTER"),^%ZOSF("SIGNOFF")
  N ZO F I="MGR","PROD","VOL" S:$D(^%ZOSF(I)) ZO(I)=^%ZOSF(I)
+ K ZO F I="MGR","PROD","VOL" S:$D(^%ZOSF(I)) ZO(I)=^%ZOSF(I)
  F I=1:2 S Z=$P($T(Z+I),";;",2) Q:Z=""  S X=$P($T(Z+1+I),";;",2,99) S ^%ZOSF(Z)=$S($D(ZO(Z)):ZO(Z),1:X)
+ ;
+MGR W !,"NAME OF MANAGER'S NAMESPACE: "_^%ZOSF("MGR")_"// " R X:$S($G(DTIME):DTIME,1:9999) I X]"" X ^("UCICHECK") G MGR:0[Y S ^%ZOSF("MGR")=X
+PROD W !,"PRODUCTION (SIGN-ON) NAMESPACE: "_^%ZOSF("PROD")_"// " R X:$S($G(DTIME):DTIME,1:9999) I X]"" X ^("UCICHECK") G PROD:0[Y S ^%ZOSF("PROD")=Y
+VOL W !,"NAME OF THIS CONFIGURATION: "_^%ZOSF("VOL")_"//" R X:$S($G(DTIME):DTIME,1:9999) I X]"" S:X?1.22U ^%ZOSF("VOL")=X I X'?1.22U W "MUST BE 1-22 uppercase characters." G VOL
+ ;
+MGR W !,"NAME OF MANAGER'S NAMESPACE: "_^%ZOSF("MGR")_"// " R X:$S($G(DTIME):DTIME,1:9999) I X]"" X ^("UCICHECK") G MGR:Y="" S ^%ZOSF("MGR")=X
+PROD W !,"PRODUCTION (SIGN-ON) NAMESPACE: "_^%ZOSF("PROD")_"// " R X:$S($G(DTIME):DTIME,1:9999) I X]"" X ^("UCICHECK") G PROD:Y="" S ^%ZOSF("PROD")=Y
+VOL W !,"NAME OF THIS CONFIGURATION: "_^%ZOSF("VOL")_"//" R X:$S($G(DTIME):DTIME,1:9999) I X]"" S:X?1.5U ^%ZOSF("VOL")=X I X'?1.5U W "MUST BE 1-5 uppercase characters." G VOL
 OS S $P(^%ZOSF("OS"),"^",1)="OpenM-NT" S:'$P(^%ZOSF("OS"),"^",2) $P(^%ZOSF("OS"),"^",2)=18
- ;For Cache 5.1 and above
- I $$VERSION^ZOSVONT>5 S ^%ZOSF("GSEL")="K ^CacheTempJ($J),^UTILITY($J) D ^%SYS.GSET M ^UTILITY($J)=CacheTempJ($J)"
  W !!,"ALL SET UP",!! Q
 Z ;;
 …
  ;;U $I:("":"+B")
  ;;DEL
  ;;X "ZR  ZS @X"
+ ;;X "ZR  ZS @X" K ^UTILITY("ROU",X)
  ;;EOFF
  ;;U $I:("":"+S")
 …
  ;;GD
  ;;D ^%GD
- ;;GSEL;Select Globals
- ;;K ^UTILITY($J) D ^%GSET
  ;;JOBPARAM
  ;;D JOBPAR^%ZOSV
 …
  ;;U IO:("":"+S+I-T":$C(13,27))
  ;;LOAD
  ;;N %,%N S %N=0 X "ZL @X F XCNP=XCNP+1:1 S %N=%N+1,%=$T(+%N) Q:$L(%)=0  S @(DIF_XCNP_"",0)"")=%"
+ ;;S %N=0 X "ZL @X F XCNP=XCNP+1:1 S %N=%N+1,%=$T(+%N) Q:$L(%)=0  S @(DIF_XCNP_"",0)"")=%"
  ;;LPC
  ;;S Y=$ZC(X)
 …
  ;;D @($S(X>7:"NORMAL",X>3:"NORMAL",1:"LOW")_"^%PRIO") ;Don't do HIGH
  ;;PROGMODE
  ;;S Y=$ZJOB#2
+ ;;S Y=$ZJ#2
  ;;PROD
  ;;VAH
 …
  ;;D ^%RD
  ;;RESJOB
  ;;N OLD S OLD=$ZNSPACE ZNSPACE "%SYS" D ^RESJOB ZNSPACE OLD Q
+ ;;Q:'$D(DUZ)  Q:'$D(^XUSEC("XUMGR",+DUZ))  N XQZ S XQZ="^RESJOB[MGR]" D DO^%XUCI
  ;;RM
  ;;I $G(IOT)["TRM" U $I:X
+ ;;U $I:X
  ;;RSEL;;ROUTINE SELECT
  ;;K ^UTILITY($J) D KERNEL^%RSET K %ST ;Special entry point for VA
  ;;RSUM
+ ;;N %,%1,%3 ZL @X S Y=0 F %=1,3:1 S %1=$T(+%),%3=$F(%1," ") Q:'%3  S %3=$S($E(%1,%3)'=";":$L(%1),$E(%1,%3+1)=";":$L(%1),1:%3-2) F %2=1:1:%3 S Y=$A(%1,%2)*%2+Y
+ ;;RSUM1
+ ;;N %,%1,%3 ZL @X S Y=0 F %=1,3:1 S %1=$T(+%),%3=$F(%1," ") Q:'%3  S %3=$S($E(%1,%3)'=";":$L(%1),$E(%1,%3+1)=";":$L(%1),1:%3-2) F %2=1:1:%3 S Y=$A(%1,%2)*(%2+%)+Y
+ ;;ZL @X S Y=0 F %=1,3:1 S %1=$T(+%),%3=$F(%1," ") Q:'%3  S %3=$S($E(%1,%3)'=";":$L(%1),$E(%1,%3+1)=";":$L(%1),1:%3-2) F %2=1:1:%3 S Y=$A(%1,%2)*%2+Y
  ;;SS
  ;;D ^%SS
  ;;SAVE
  ;;N XCS S XCS="F XCM=1:1 S XCN=$O(@(DIE_XCN_"")"")) Q:+XCN'=XCN  S %=^(XCN,0) Q:$E(%,1)=""$""  I $E(%,1)'="";"" ZI %" X "ZR  X XCS ZS @X"
+ ;;S XCS="F XCM=1:1 S XCN=$O(@(DIE_XCN_"")"")) Q:+XCN'=XCN  S %=^(XCN,0) Q:$E(%,1)=""$""  I $E(%,1)'="";"" ZI %" X "ZR  X XCS ZS @X" S ^UTILITY("ROU",X)="" K XCS
  ;;SIZE
  ;;S Y=0 F I=1:1 S %=$T(+I) Q:%=""  S Y=Y+$L(%)+2
 …
  ;;TMK;;MAGTAPE MARK
  ;;S Y=$ZA\4#2
  ;;TRAP;;S X="^%ET",@^%ZOSF("TRAP"); User $ETRAP
+ ;;TRAP;;S X="^%ET",@^%ZOSF("TRAP") TO SET ERROR TRAP
  ;;$ZT=X
  ;;TRMOFF
 …
  ;;TRMON
  ;;U $I:("":"+I+T")
  ;;TRMRD;;old Y=$A($ZB),Y=$S(Y<32:Y,Y=127:Y,1:0)
+ ;;TRMRD
  ;;S Y=$A($ZB),Y=$S(Y<32:Y,Y=127:Y,1:0)
  ;;TYPE-AHEAD
 …
  ;;VOL;;VOLUME SET NAME
  ;;ROU
  ;;ZD;;$H to external
+ ;;ZD
  ;;S Y=$ZD(X)

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZOSV2GTM.m

-              r628
+              r636
 %ZOSV2 ;ISF/RWF - More GT.M support routines ;10/18/06  14:29
+ ;;8.0;KERNEL;**275,425**;Jul 10, 1995;Build 18
+ ;;8.0;KERNEL;**275,425**;Jul 10, 1995;Build 4;WorldVistA 30-Jan-08
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ Q
  ;SAVE: DIE open array reference.
 …
  S $ETRAP="S $ECODE="""" Q"
  S %I=$I,%DIR=$$RTNDIR^%ZOSV,RN=$TR(RN,"%","_")
  I $L($ZSEARCH(%DIR_RN_".m",244)) ZSYSTEM "DEL "_%DIR_X_".m;*"
  I $L($ZSEARCH(%DIR_RN_".obj",244)) ZSYSTEM "DEL "_%DIR_X_".obj;*"
+ I $L($ZSEARCH(%DIR_RN_".m",244)) ZSYSTEM "rm -f "_%DIR_X_".m"
+ I $L($ZSEARCH(%DIR_RN_".obj",244)) ZSYSTEM "rm -f "_%DIR_X_".obj"
  I $L($ZSEARCH(%DIR_RN_".o",244)) ZSYSTEM "rm -f "_%DIR_X_".o"
+ Q

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZOSVONT.m

-              r628
+              r636
+%ZOSV ;SFISC/AC - $View commands for Open M for NT.  ;03/03/2008
+ ;;8.0;KERNEL;**34,94,107,118,136,215,293,284,385,425,440**;Jul 10, 1995;Build 13
+ ;Per VHA Directive 2004-038, this routine should not be modified
+%ZOSV ;SFISC/AC - $View commands for Open M for NT.  ;4/26/07  09:39
+ ;;8.0;KERNEL;**34,94,107,118,136,215,293,284,385,425**;Jul 10, 1995;Build 18
 ACTJ() ;# Active jobs
  N %,V,Y S V=$$VERSION()
 …
  ;maxpid: from %SS
  I V<5 D  Q AVJ
  . N PORT,T,X,MAXPID,LMFLIM
  . S $ET="",MAXPID=$V($ZU(40,2,118),-2,4)
  . X "S ZOSV=$ZU(5),%=$ZU(5,""%SYS"") S LMFLIM=$$inquire^LMFCLI,%=$ZU(5,ZOSV)" ;Get the license info
+ . N port,t,x,maxpid,lmflim
+ . S $ET="",maxpid=$V($ZU(40,2,118),-2,4)
+ . X "S ZOSV=$ZU(5),%=$ZU(5,""%SYS"") S lmflim=$$inquire^LMFCLI,%=$ZU(5,ZOSV)" ;Get the license info
  . ;Add together the enterprise and division licenses avaliable
  . S X=$P(LMFLIM,";",2)+$P($P(LMFLIM,"|",2),";",2)
  . S T=+LMFLIM+$P(LMFLIM,"|",2) ;Check the license total
  . S AVJ=$S(T<MAXPID:X,1:MAXPID-$$ACTJ) ;Return the smaller of license or pid
+ . S x=$P(lmflim,";",2)+$P($P(lmflim,"|",2),";",2)
+ . S t=+lmflim+$P(lmflim,"|",2) ;Check the license total
+ . S AVJ=$S(t<maxpid:x,1:maxpid-$$ACTJ) ;Return the smaller of license or pid
  ;To get available jobs from Cache 5.0 up
  I V'<5 D  Q AVJ
 …
+ ;
 GETPEER() ;Get the PEER tcp/ip address
  N PEER,NL,$ET S NL="",PEER="",$ET="S $EC=NL Q NL"
+ N PEER,NL,$ET S NL="",$ET="S $EC=NL Q NL",PEER=""
  I $$OS="VMS" S PEER=$ZF("TRNLNM","VISTA$IP")
  I '$L(PEER) S PEER=$ZU(111,0) S:$L(PEER) PEER=$A(PEER,1)_"."_$A(PEER,2)_"."_$A(PEER,3)_"."_$A(PEER,4)
 …
+ ;
 SHARELIC(TYPE) ;See if can share a C/S license
- ;Per Sandy Waal 10/18/2003: With Cache 5.0, your telnet and IP connections are now handled properly.
- ;N %,%N,%2,UID,%V,$ET S $ET="S $EC="""" Q",%V=$$VERSION()
- ;I %V'<5 Q
  ;Type is 1 for C/S and 0 for Telnet
+ ;I %V<3.1 X:TYPE "S %N=$ZU(5),%2=$ZU(5,""%SYS""),%2=$$GetLic^LMFCLI,%N=$ZU(5,%N)" Q
+ ;I %V<5 S:TYPE %=$$GetCSLic^%LICENSE S:'TYPE %=$$ShareLic^%LICENSE
+ ;S $EC=""
+ N %,%N,%2,UID,%V,$ET S $ET="S $EC="""" Q",%V=$$VERSION()
+ I %V<3.1 X:TYPE "S %N=$ZU(5),%2=$ZU(5,""%SYS""),%2=$$GetLic^LMFCLI,%N=$ZU(5,%N)" Q
+ I %V<5 S:TYPE %=$$GetCSLic^%LICENSE S:'TYPE %=$$ShareLic^%LICENSE
+ ;Per Sandy Waal 10/18/2003: With Cache' 5.0, your telnet and IP connections are now handled properly.
+ I %V'<5 S %V=%V
+ S $EC=""
+ Q
+ ;
 JOBPAR ;See if X points to a valid Job. Return its UCI.
  N NL,$ET S Y="",NL="",$ET="S $EC=NL Q"
  I $D(^$JOB(X)) S Y=$V(-1,X),Y=$P(Y,"^",14)_","_^%ZOSF("VOL")
+ Q
+ N ZJ S Y="",$ZT="JOBX"
+ Q:'$D(^$JOB(X))  S Y=$V(-1,X),Y=$P(Y,"^",14)_","_^%ZOSF("VOL")
+JOBX Q
+ ;
 NOLOG ;4096 is switch 12 - sign on inhibited.
 …
+ ;
 PROGMODE() ;Check if in PROG mode
  Q $ZJOB#2
+ Q $ZJ#2
+ ;
 PRGMODE ;
 …
  D UCI S XUCI=Y,XQZ="PRGM^ZUA[MGR]",XUSLNT=1 D DO^%XUCI D ^%PMODE U $I:(:"+B+C+R") S $ZT="" Q
+ Q
 LGR() ;Last Global ref.
  N $ET,NL S NL="",$ET="S $EC=NL Q NL"
+ Q $ZR
+LGR() S $ZT="LGRX^%ZOSV"
+ Q $ZR ;Last Global ref.
+LGRX Q ""
+ ;
+EC() ;Error code
+ Q $ZE
+EC() Q $ZE ;Error code
+ ;
 DOLRO ;SAVE ENTIRE SYMBOL TABLE IN LOCATION SPECIFIED BY X
 …
+ Q
+ ;
 PARSIZ ;Old and not used.
+PARSIZ ;
  S X=3
+ Q
+ ;
 DEVOPN ;List of Devices opened, Not used
+DEVOPN ;List of Devices opened
  ;Returns variable Y. Y=Devices owned separated by a comma
+ Q
+ ;
 DEVOK ;
  S Y=0,X1=$G(X1) Q:X=2  Q:(X1="HFS")!(X1="SPL")!(X1="MT")!(X1="CHAN")  ;Quit w/ OK for HFS, Spool, MT, TCP/IP
 …
+ ;
 OS() ;Return the OS NT, VMS, Unix
  Q $S($ZV["VMS":"VMS",$ZV["UNIX":"UNIX",$ZV["Linux":"UNIX",$ZV["Windows":"NT",$ZV["NT":"NT",1:"UNK")
+ Q $S($ZV["VMS":"VMS",$ZV["Windows":"NT",$ZV["NT":"NT",$ZV["UNIX":"UNIX",1:"UNK")
+ ;
 SETNM(X) ;Set name, Fall into SETENV
 …
+ ;
 SID() ;System ID Ver 1
  N %1,%2,%3,%4,%5,T S T="~"
+ N %1,%2,%3,T S T="~"
  S %1=$ZU(5) ;namespace
  S %2=$ZU(12,"") ;directory
  I '$L(%2),$$VERSION'<5.2 S %2=$$defdir^%SYS.GLO(%1) ;remote directory
- S %3=$G(^XTV(8989.3,1,"SID")),%4=$P(%3,"^",4),%5=$P(%3,"^",5)
- I $L(%4),$L(%5),%2[%4 S %2=$P(%2,%4)_%5_$P(%2,%4,2,9)
  S %3=%1_T_%2 ;namespace~directory
  Q "1~"_%3
 …
 PRI() ;Check if a mixed OS enviroment.
  ;Default return 1 unless we are on the secondary OS.
  ;Only Cache on a VMS(1)/Linux or NT(2) mix is supported now.
+ ;Only Cache on a VMS(1)/Linux(2) mix is supported now.
  N % S %=1
  I $P(^XTV(8989.3,1,0),"^",5),$$OS'="VMS" S %=2
+ ;I $P(^XTV(8989.3,1,0),"^",5),$$OS["NT" S %=2
  Q %
+ ;
 …
  Q 1
+ ;
 T0 ; start RT clock, obsolete
+T0 ; start RT clock
  ;S XRT0=$H
+ Q

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZTLOAD4.m

-              r628
+              r636
 %ZTLOAD4 ;SEA/RDS-TaskMan: P I: Is Queued? ;1/24/08  16:15
  ;;8.0;KERNEL;**440**;JUL 10, 1995;Build 13
  ;Per VHA Directive 2004-038, this routine should not be modified
  ;Call with ZTSK, [ZTCPU]; Return ZTSK()
+%ZTLOAD4 ;SEA/RDS-TaskMan: P I: Is Queued? ;7/26/91  11:55 ;
+ ;;8.0;KERNEL;;JUL 10, 1995
+ ;;7.0;
+ ;
 INPUT ;check input parameters for error conditions
- N %,$ES,$ET,%ZTVOL,ZTREC,ZTD,ZT1,ZT2,ZT3
  I $D(ZTSK)[0 S ZTSK=""
  I $D(ZTSK)>1 S %=ZTSK K ZTSK S ZTSK=%
+ I $D(ZTSK)>1 S ZTLOAD=ZTSK K ZTSK S ZTSK=ZTLOAD K ZTLOAD
  I ZTSK<1!(ZTSK\1'=ZTSK) S ZTSK="",ZTSK(0)="",ZTSK("E")="IT" G QUIT
  S ZTSK(0)="",ZTSK("E")="U",$ET="Q:$ES  S $EC="""" G QUIT^%ZTLOAD4"
+ S ZTSK(0)="",ZTSK("E")="U",X="QUIT^%ZTLOAD3",@^%ZOSF("TRAP")
  S %ZTVOL=^%ZOSF("VOL")
  I $D(ZTCPU)[0 S ZTCPU=%ZTVOL
 …
+ ;
 HERE ;lookup task's status on current volume set
+ L +^%ZTSK(ZTSK):1
+ I $D(^%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT
+ S ZTREC=^%ZTSK(ZTSK,0),ZTD=$G(^(.04))
+ S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=$P(ZTREC,U,6) ;scheduled $H
+ L +^%ZTSK(ZTSK) I $D(^%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT
+ S ZTREC=^%ZTSK(ZTSK,0),ZTD=$P(ZTREC,U,6)
+ S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=ZTD
  I ZTD]"",$D(^%ZTSCH(ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT
  I ZTD]"",$D(^%ZTSCH("JOB",ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ ;
  S ZT1="" F  S ZT1=$O(^%ZTSCH(ZT1)) Q:'ZT1  I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT
  S ZT1="IO",ZT2="" F  S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F  S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
  S ZT1="JOB",ZT2="" F  S ZT2=$O(^%ZTSCH(ZT1,ZT2)) Q:ZT2=""  I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT
  S ZT1="LINK",ZT2="" F  S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F  S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="" F ZT=0:0 S ZT1=$O(^%ZTSCH(ZT1)) Q:'ZT1  I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="IO",ZT2="" F ZT=0:0 S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F ZT=0:0 S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="JOB",ZT2="" F ZT=0:0 S ZT2=$O(^%ZTSCH(ZT1,ZT2)) Q:ZT2=""  I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="LINK",ZT2="" F ZT=0:0 S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F ZT=0:0 S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
  S ZTSK(0)=0
+ ;
 QUIT ;cleanup and quit
  L:ZTSK -^%ZTSK(ZTSK) ;K %ZTCPU,%ZTM,%ZTM1,%ZTM2,%ZTMAST,%ZTVOL,X,Y,ZT,ZT1,ZT2,ZT3,ZTCPU,ZTD,ZTREC
+ L:ZTSK -^%ZTSK(ZTSK) K %ZTCPU,%ZTM,%ZTM1,%ZTM2,%ZTMAST,%ZTVOL,X,Y,ZT,ZT1,ZT2,ZT3,ZTCPU,ZTD,ZTREC
  I ZTSK(0)]"" K ZTSK("E") Q
  I ZTSK("E")'="U" Q
 …
+ ;
 THERE ;rest of code looks up task's status on some other volume set
- N %ZTCPU,%ZTM,X,Y
+ ;
 FILES ;find TaskMan files on the volume set to be searched
 …
 SEARCH ;find out if task is queued on that volume set
  I $D(^[X,Y]%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT
  S ZTREC=^[X,Y]%ZTSK(ZTSK,0),ZTD=$G(^(.04))
  S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=$P(ZTREC,U,6)
+ S ZTREC=^[X,Y]%ZTSK(ZTSK,0),ZTD=$P(ZTREC,U,6)
+ S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=ZTD
  I ZTD]"",$D(^[X,Y]%ZTSCH(ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT
  I ZTD]"",$D(^[X,Y]%ZTSCH("JOB",ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ ;
  S ZT1="" F  S ZT1=$O(^[X,Y]%ZTSCH(ZT1)) Q:'ZT1  I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT
  S ZT1="IO",ZT2="" F  S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F  S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
  S ZT1="JOB",ZT2="" F  S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)) Q:ZT2=""  I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT
  S ZT1="LINK",ZT2="" F  S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F  S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="" F ZT=0:0 S ZT1=$O(^[X,Y]%ZTSCH(ZT1)) Q:'ZT1  I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="IO",ZT2="" F ZT=0:0 S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F ZT=0:0 S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="JOB",ZT2="" F ZT=0:0 S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)) Q:ZT2=""  I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="LINK",ZT2="" F ZT=0:0 S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F ZT=0:0 S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
  S ZTSK(0)=0 G QUIT
+ ;

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZTMGRSET.m

-              r628
+              r636
 ZTMGRSET ;SF/RWF,PUG/TOAD - SET UP THE MGR ACCOUNT FOR THE SYSTEM ;02/22/2006
+ZTMGRSET ;SF/RWF,PUG/TOAD - SET UP THE MGR ACCOUNT FOR THE SYSTEM ;6:53 PM  24 Jan 2008
  ;;8.0;KERNEL;**34,36,69,94,121,127,136,191,275,355**;JUL 10, 1995;Build 9
+ ;
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
  N %D,%S,I,OSMAX,U,X,X1,X2,Y,Z1,Z2,ZTOS,ZTMODE,SCR
 …
+ ;
 R() ; routine directory for GT.M
  Q d(1) ;
+ ;Q d(1) ;WVEHR/SO Commented out
  I ZTOS=7 Q $P($ZRO,",")
  I ZTOS=8 Q $P($S($ZRO["(":$P($P($ZRO,"(",2),")"),1:$ZRO)," ")_"/"

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS.m

-              r628
+              r636
+%ZIS ;SFISC/AC,RWF -- DEVICE HANDLER ;1/24/08  16:06
+ ;;8.0;KERNEL;**18,23,69,112,199,191,275,363,440**;JUL 10, 1995;Build 13
+ ;Per VHA Directive 2004-038, this routine should not be modified
+%ZIS ;SFISC/AC,RWF -- DEVICE HANDLER ;10/14/2004  08:46
+ ;;8.0;KERNEL;**18,23,69,112,199,191,275,363**;JUL 10, 1995
  N %ZISOS,%ZISV
  S U="^",%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^%ZOSF("VOL"))
 …
  I '$D(%ZIS),$D(%IS) M %ZIS=%IS
  S:'($D(%ZIS)#2) %ZIS="M" M %IS=%ZIS ;update %IS for now
- I '$D(^XUTL("XQ",$J,"MIXED OS")) S ^XUTL("XQ",$J,"MIXED OS")=$$PRI^%ZOSV
- S %ZIS("PRI")=$G(^XUTL("XQ",$J,"MIXED OS"),1)
+ ;
  I $D(ZTQUEUED) D  I '$D(IOP) S POP=1 G EXIT^%ZIS1
  .I $D(ZTIO)#2,ZTIO="" S:%IS'[0 %IS=%IS_"0",%ZIS=%ZIS_"0"
  I '$D(ZTQUEUED),%IS["T",$P($G(IOP),";")="Q" S POP=1 G EXIT^%ZIS1
  N %,%A,%E,%H,%I,%X,%XX,%Y,%Z,%Z1,%Z2,%Z9,%Z90,%Z91,%Z95,%ZISB,%ZTIME,%ZTYPE
+ N %,%A,%E,%H,%I,%X,%XX,%Y,%Z,%Z1,%Z9,%Z90,%Z91,%Z95,%ZISB,%ZTIME,%ZTYPE
  N %ZHFN,%ZISOLD,DTOUT,DUOUT
  ;Save symbols to restore if don't open a device
 …
  S %=$$LINEPORT^%ZISUTL I % S (%E,%H)=% Q
  S %ZISVT=$I D VTLKUP I '%E S %ZISVT=$I D VIRTUAL
  I %ZISVT=""!(%E'>0) I %IS'[0 O IO(0)::0 I $T U IO(0) W !,"HOME DEVICE ("_$I_") DOES NOT EXIST IN THE DEVICE FILE",!,"PLEASE CONTACT YOUR SYSTEM MANAGER!",*7
+ I %ZISVT=""!(%E'>0) I %IS'[0 O IO(0)::0 I $T U IO(0) W !,"HOME DEVICE DOES NOT EXIST IN THE DEVICE FILE",!,"PLEASE CONTACT YOUR SYSTEM MANAGER!",*7
  S %H=%E S:'%H&(%IS'[0) POP=1 S:(%H>0)&('$D(IO("HOME"))) IO("HOME")=%H_"^"_$I
+ Q
 …
  ;IO("Q") is checked by many routines after a call to ^%ZISC, so only clean on call to %ZIS.
 CLEAN ;Cleanup env. Called from %ZISC also.
+ I $G(IOT)'="SPL" K IO("DOC"),IO("SPOOL") ;(p446)
+ I $G(IOT)'="HFS" K IO("HFSIO") ;p446
+ K IO("DOC"),IO("HFSIO"),IO("SPOOL") ;(p366)
  S (IOPAR,IOUPAR)=""
+ Q
 …
 RESETVAR ;Reset home IO* variables.
  I '$D(^XUTL("XQ",$J,"IO")) Q
+ N %
+ F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY","IOPAR","IOUPAR" I $D(^XUTL("XQ",$J,%))#2 S @%=^(%)
+ F %="IO(""IP"")","IO(""CLNM"")","IO(""DOC"")","IO(""HFSIO"")","IO(""SPOOL"")" I $D(^XUTL("XQ",$J,%))#2 S @%=^(%)
+ S POP=0,IO(0)=IO
+ N % F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY" I $D(^XUTL("XQ",$J,%))#2 S @%=^(%)
+ S POP=0,IO(0)=IO,(IOPAR,IOUPAR)=""
+ Q
+SAVEVAR ;Save home IO* variables, called from XUS1,%ZTMS3
+ N %
+ F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY","IOPAR","IOUPAR" I $D(@%) S ^XUTL("XQ",$J,%)=@%
+ F %="IO(""IP"")","IO(""CLNM"")","IO(""DOC"")","IO(""HFSIO"")","IO(""SPOOL"")" I $D(@%) S ^XUTL("XQ",$J,%)=@%
+SAVEVAR ;Save home IO* variables, called from XUS1
+ N % F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY" I $D(@%) S ^XUTL("XQ",$J,%)=@%
+ Q
 ZISLPC Q  ;No longer called in Kernel v8.

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS1.m

-              r628
+              r636
+%ZIS1 ;SFISC/AC,RWF -- DEVICE HANDLER (DEVICE INPUT) ;1/24/08  16:06
+ ;;8.0;KERNEL;**18,49,69,104,112,199,391,440**;JUL 10, 1995;Build 13
+ ;Per VHA Directive 2004-038, this routine should not be modified
+%ZIS1 ;SFISC/AC,RWF -- DEVICE HANDLER (DEVICE INPUT) ;07/07/2005  15:48
+ ;;8.0;KERNEL;**18,49,69,104,112,199,391**;JUL 10, 1995
 MAIN ;Called from %ZIS with a GO
  I '$D(IOP),$D(^%ZIS(1,%E,0)),'$P(^(0),"^",3) S %A=%H,%Z=^(0) D L2^%ZIS2 G EXIT
 …
  I '$D(IOP),$D(IO("Q")),POP D AQUE^%ZIS3 K:%=2 IO("Q") S:%=2 %ZISB=$S(%IS'["N":2,1:0) I %=-1 S POP=1 G EXIT
  S %E=%H,POP=0,%IS=%ZIS ;Reset %IS from %ZIS
  I %IS'["Q",$D(XQNOGO) S POP=1 W:'$D(IOP) !,$C(7),"OUTPUT IS NEVER ALLOWED FOR THIS OPTION" G EXIT
+ I %IS'["Q",$D(XQNOGO) S POP=1 W:'$D(IOP) !,*7,"OUTPUT IS NEVER ALLOWED FOR THIS OPTION" G EXIT
  D IOP:$D(IOP),R:'$D(IOP)
  G EXIT:$D(DTOUT)!$D(DUOUT)!(POP&$D(IOP)),L1:POP&'$D(IOP)
  D LKUP I %A'>0 S POP=1 D:'$D(DUOUT) MSG1 K DUOUT
+ I POP G EXIT:$D(IOP),L1:'$D(IOP)
  I '$D(^%ZIS(1,%A,0)) D MSG1 K %ZISIOS S POP=1
  I POP G EXIT:$D(IOP),L1:'$D(IOP)
 …
  I $D(%ZIS("S")) N Y S Y=%E D XS^ZISX S:'$T POP=1 G G:POP
  W:'$D(IOP)&($P(%Z,"^",2)'=$I)&($P(%Z1,"^")]"") "  ",$P(%Z1,"^")
  D L2^%ZIS2 ;Call
+ D L2^%ZIS2
 G G L1:POP&'$D(IOP)&'($D(DTOUT)!$D(DUOUT)) ;Didn't get it
+ ;For type[TRM reset $X & $Y
+ I 'POP,%ZTYPE["TRM",IO]"",$D(IO(1,IO)) U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0
+ ;
+EXIT ;
+ I POP G EX2 ;Did not get the device.
+ ;For type[TRM reset $X & $Y
+ I %ZTYPE["TRM",IO]"",$D(IO(1,IO)) U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0
+EXIT I $D(IO)#2,IO]"",$D(IO(1,IO))#2,$D(%Z1),$P(%Z1,"^",11) S IO(1,IO,"NOFF")=1
  ;Do count of number of times device opened.  Field 51.
  I $L($G(IO)),$D(IO(1,IO))#2,$G(%ZISIOS) D
+ I $L($G(IO)),$D(IO(1,IO))#2,'POP,$G(%ZISIOS) D
  . S $P(^(5),"^",1)=$P($G(^%ZIS(1,%ZISIOS,5)),"^",1)+1
+ I %ZIS["H" S IO(0)=IO,IO("HOME")=%ZISIOS_"^"_IO ;Make home device
+ I '$D(IO("Q")),$D(%ZISLOCK) S ^XUTL("XQ",$J,"lock",%ZISIOS)=%ZISLOCK
+ I $D(IO)#2,IO]"",$D(IO(1,IO))#2,$D(%Z1),$P(%Z1,"^",11) S IO(1,IO,"NOFF")=1
+EX2 ;
+ I 'POP,%ZIS["H" S IO(0)=IO,IO("HOME")=%ZISIOS_"^"_IO ;Make home device
  I %IS'[0,$G(IO(0))]"" U IO(0) ;Make sure return with home active
  G SETVAR:'POP!(%IS["T"),KILVAR
 …
  S %IS=%IS_%X K IOP W %X D SETQ Q
  ;Get ready to ask user for device
 R I %IS["Q",$D(XQNOGO) W !,$C(7),"AT THIS TIME, OUTPUT MUST BE QUEUED"
+R I %IS["Q",$D(XQNOGO) W !,*7,"AT THIS TIME, OUTPUT MUST BE QUEUED"
  S %A=$S($D(%IS("B")):%IS("B"),1:"HOME") ;Setup default
  I %IS["P",%A="HOME",$D(^%ZIS(1,%E,99)),$D(^%ZIS(1,+^(99),0)) S %A=$P(^(0),"^",1)
 …
  I %X'=%ZISVT S %ZISVT=%X D VTLKUP^%ZIS S %A=%E Q:%A>0  ;uppercase lookup
  N %XX,%YY S %XX=%X D 1^%ZIS5 S %A=+%YY Q
 SBR K DFOUT,DTOUT,DUOUT R %X:$S($D(DTIME)#2:DTIME,1:300) E  W $C(7) S DTOUT=1 Q
+SBR K DFOUT,DTOUT,DUOUT R %X:$S($D(DTIME)#2:DTIME,1:300) E  W *7 S DTOUT=1 Q
  S:%X="."!(%X="^") DUOUT=1,%X="" Q
 LC S %X=$$UP(%X)
 …
 LOW(%) Q $TR(%,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
 UP(%) Q $TR(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+ ;
+ ;Call/Return % = 1 (yes), 2 (no) -1 (^)
+YN W "? ",$P("Yes// ^No// ",U,%)
+RYN R %X:$S($D(DTIME):DTIME,$D(%ZISDTIM):%ZISDTIM,1:300) E  S DTOUT=1,%X=U W $C(7)
+YN W "? ",$P("YES// ^NO// ",U,%)
+RYN R %X:$S($D(DTIME):DTIME,$D(%ZISDTIM):%ZISDTIM,1:300) E  S DTOUT=1,%X=U W *7
  S:%X]""!'% %=$A(%X),%=$S(%=89:1,%=121:1,%=78:2,%=110:2,%=94:-1,1:0)
+ I '%,%X'?."?" W $C(7),"??",!?4,"ANSWER 'Yes' OR 'No': " G RYN
+ W:$X>73 ! W $P("  (Yes)^  (No)",U,%)
+ Q
+MSG1 I '$D(IOP) W ?20,$C(7),"  [DEVICE DOES NOT EXIST]"
+ I '%,%X'?."?" W *7,"??",!?4,"ANSWER 'YES' OR 'NO': " G RYN
+ W:$X>73 ! W $P("  (YES)^  (NO)",U,%) Q
+MSG1 I '$D(IOP) W ?20,*7,"  [DEVICE DOES NOT EXIST]"
+ Q
 SETVAR ;Come here to setup the variables for the selected device
 …
  S IOT=%ZTYPE,IOST(0)=%ZISIOST(0),IOST=%ZISIOST,IOPAR=%ZISOPAR,IOUPAR=%ZISUPAR,IOHG=%ZISHG
  S:IOF="" IOF="#" ;See that IOF has something
+ K IOCPU S:$D(%ZISCPU) IOCPU=%ZISCPU
+ G KIL
+ K IOCPU S:$D(%ZISCPU) IOCPU=%ZISCPU G KIL
+ ;
 KILVAR ;Come here to restore the calling variables
 …
  S:%IS["T" IO("T")=1 K %ZIS,%IS,%A,%E,%H,%ZISOS,%ZISV,IOP
 K2 K %I,%X,%Y,%Z,%Z1,%Z91,%Z95,%ZTYPE,%ZTIME
+ K %ZISCHK,%ZISCPU,%ZISI,%ZISR,%ZISVT,%ZISB,%ZISX,ZISI,%ZISHGL,%ZISHP,%ZISIO,%ZISIOS,%ZISIOM
+ K %ZISIOF,%ZISIOSL,%ZISIOBS,%ZISIOST,%ZISIOST(0),%ZISTO,%ZISTP,%ZISHG,%ZISSIO,%ZISOPEN,%ZISOPAR,%ZISUPAR
+ K %ZISMY,%ZISQUIT,%ZISLOCK
+ K %ZISCHK,%ZISCPU,%ZISI,%ZISR,%ZISVT,%ZISB,%ZISX,ZISI,%ZISHGL,%ZISHP,%ZISIO,%ZISIOS,%ZISIOM,%ZISIOF,%ZISIOSL,%ZISIOBS,%ZISIOST,%ZISIOST(0),%ZISTO,%ZISTP,%ZISHG,%ZISSIO,%ZISOPEN,%ZISOPAR,%ZISUPAR
+ K %ZISMY,%ZISQUIT
+ Q

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS2.m

-              r628
+              r636
+%ZIS2 ;SFISC/AC,RWF -- DEVICE HANDLER (CHECKS) ;1/24/08  16:07
+ ;;8.0;KERNEL;**69,104,112,118,136,241,440**;JUL 10, 1995;Build 13
+ ;Per VHA Directive 2004-038, this routine should not be modified
+%ZIS2 ;SFISC/AC,RWF -- DEVICE HANDLER (CHECKS) ;06/12/2002  15:41
+ ;;8.0;KERNEL;**69,104,112,118,136,241**;JUL 10, 1995
 HUNT S:'$D(%ZISHP) %ZISHP=%E,%ZISHGL=0 S %E=0
  F  S %ZISHGL=$O(^%ZIS(1,%ZISHG(0),"HG",%ZISHGL)) Q:%ZISHGL'>0  D  Q:%E
 …
 L2 ;Entry point from %ZIS1
  I $D(DTOUT)!$D(DUOUT) K %ZISHP,%ZISHPOP Q
+CHECK ;Get IO check for secondary $I
+ K %ZISCPU N %Z2
+ S POP=0,%Z=^%ZIS(1,%E,0),%Z2=$S(%ZIS("PRI")=1:"",1:$G(^%ZIS(1,%E,2))) ;Get Primary and secondary IO.
+ S IO=$S(%ZIS("PRI")=1:$P(%Z,"^",2),$L($P(%Z2,"^")):$P(%Z2,"^"),1:$P(%Z,"^",2)) ;
+ S:%IS["Q"&'$D(ZTQUEUED)&($P(%Z,"^",12)=1!$D(XQNOGO)) %ZISB=0,IO("Q")=1 ;Forced Queueing
+CHECK K %ZISCPU S POP=0,%Z=^%ZIS(1,%E,0),IO=$P(%Z,"^",2)
+ S:%IS["Q"&'$D(ZTQUEUED)&($P(%Z,"^",12)=1!$D(XQNOGO)) %ZISB=0,IO("Q")=1 ;Forced Queueing
  I $P(%Z,"^",12)=2 S %IS=$TR(%IS,"Q") I $D(IO("Q")) D  Q
  . I '$D(IOP) W !,"Queuing NOT ALLOWED on this device"

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS3.m

-              r628
+              r636
+%ZIS3 ;SFISC/AC,RWF -- DEVICE HANDLER(DEVICE TYPES & PARAMETERS) ;1/24/08  13:18
+ ;;8.0;KERNEL;**18,36,69,104,391,440**;JUL 10, 1995;Build 13
+ ;Per VHA Directive 2004-038, this routine should not be modified
+ ;Call with a Go from ^%ZIS2
+ I %ZIS'["T",$G(^%ZIS(1,+%E,"POX"))]"" D XPOX^ZISX(%E) ;Pre-Open
+%ZIS3 ;SFISC/AC,RWF -- DEVICE HANDLER(DEVICE TYPES & PARAMETERS) ;10/06/2005  13:23
+ ;;8.0;KERNEL;**18,36,69,104,391**;JUL 10, 1995
+ I %ZIS'["T",$G(^%ZIS(1,+%E,"POX"))]"" D XPOX^ZISX(%E)
  I $D(%ZISQUIT) S POP=1 K %ZISQUIT
  S %ZISCHK=1
+ ;I 'POP&(%ZISB)&(%ZTYPE'="RES")&(%ZTYPE'="OTH")&(%ZTYPE'="SDP")&(IO'["::") D DEVOK
+ ;See if need to lock.
+ K %ZISLOCK
+ I %ZIS'["T",+$G(^%ZIS(1,+%E,"GBL")) S %ZISLOCK=$NA(^%ZIS("lock",IO))
+ ;
+ I 'POP G TRM:(%ZTYPE["TRM"),@(%ZTYPE_"^%ZIS6") ;Jump to next part
+ ;
+Q ;%ZIS6 Returns here
+ ;See if need to un-lock.
+ I $D(%ZISUOUT) K %ZISUOUT,%ZISHP,%ZISHPOP Q
+ I 'POP&(%ZISB)&(%ZTYPE'="RES")&(%ZTYPE'="OTH")&(%ZTYPE'="SDP")&(IO'["::") D DEVOK
+ G Q:POP
+ G @%ZTYPE:(%ZTYPE["TRM"),@(%ZTYPE_"^%ZIS6") ;Jump to next part
+ ;
+Q I $D(%ZISUOUT) K %ZISUOUT,%ZISHP,%ZISHPOP Q
  I $D(%ZISHPOP)&$S(IO="":1,1:'$D(IO(1,IO))) D HGBSY^%ZIS2 Q
+ I POP S:%ZIS'["T" IO="" I $D(%ZISHG(0)),%ZIS'["D",'$D(%ZISHPOP) G HUNT^%ZIS2
+ Q  ;Return to %ZIS1
+ ;
+ I POP S:%IS'["T" IO="" I $D(%ZISHG(0)),%IS'["D",'$D(%ZISHPOP) G HUNT^%ZIS2
+ Q
 VTRM ;Virtual terminal type
+TRM ;D OPEN^%ZIS4:'POP&(%ZISB&(%ZIS'["T")),MARGN:'POP,SETPAR:'POP ;Terminal type
+ D MARGN:'POP,SETPAR:'POP ;Terminal type// TEST CHANGE
+ I 'POP,%ZIS'["T",%ZISB=1,'$D(IOP),IO'=IO(0),'$D(IO("Q")),%ZIS["Q" D AQUE
+ W:'$D(IOP) !
+ I '$D(IO("Q")),'POP,%ZISB,%ZIS'["T" D O^%ZIS4
+TRM D OPEN^%ZIS4:'POP&(%ZISB&(%IS'["T")),MARGN:'POP,SETPAR:'POP ;Terminal type
+ I 'POP,%IS'["T",%ZISB=1,'$D(IOP),IO'=IO(0),'$D(IO("Q")),%IS["Q" D AQUE
+ W:'$D(IOP) ! I '$D(IO("Q")) D O^%ZIS4:'POP&(%ZISB&(%IS'["T"))
  G Q
 DEVOK N X,Y,X1 ;Not sure this is needed
+DEVOK N X,Y,X1
  S X=IO,X1=%ZTYPE
  D DEVOK^%ZOSV I Y=-99!(Y=0)!(Y=$J) Q
  I Y>0 S POP=1 W:'$D(IOP)&('$D(%ZISHG(0))!(%IS["D")) !,$C(7),"[Device Unavailable]" Q
  I Y=-1 S IO="",POP=1 W:'$D(IOP)&('$D(ZISHG(0))!(%IS["D")) !,$C(7),"[Device does not Exist or Unavailable]" Q
+ I Y>0 S POP=1 W:'$D(IOP)&('$D(%ZISHG(0))!(%IS["D")) !,*7,"[Device Unavailable]" Q
+ I Y=-1 S IO="",POP=1 W:'$D(IOP)&('$D(ZISHG(0))!(%IS["D")) !,*7,"[Device does not Exist or Unavailable]" Q
+ Q
+ ;
 …
  S POP=1 I %ZISB&(%ZTYPE["TRM")&(IO'=IO(0)) C IO K IO(1,IO) Q
+ Q
 SETPAR S:$L(%ZISOPAR)&($E(%ZISOPAR)'="(") %ZISOPAR="("_%ZISOPAR_")"
+SETPAR S:%ZISOPAR]""&($A(%ZISOPAR)-40) %ZISOPAR="("_%ZISOPAR_")"
+ Q
+AQUE ;Ask about Queueing
+ W ! S %=$S($D(IO("Q")):1,1:2),U="^",%ZISDTIM=60
+AQUE W ! S %=$S($D(IO("Q")):1,1:2),U="^",%ZISDTIM=60
  I $D(IO("Q")) W !,"Previously, you have selected queueing."
  W !,"Do you "_$S($D(IO("Q")):"STILL ",1:"")_"want your output QUEUED"
 …
  I %=-1 S POP=1,%ZISHPOP=1,%ZISUOUT=1 C IO K IO(1,IO) Q
  I %=1 S IO("Q")=1 C IO K IO(1,IO) Q
- ;I %=2 K IO("Q")
+ Q
 ST(%ZISTP) ;
 …
  S:IOST="" IOST="P-OTHER",IOST(0)=0
+ Q

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS4.m

-              r628
+              r636
 %ZIS4 ;ISF/RWF,DW - DEVICE HANDLER SPECIFIC CODE (GT.M for Unix/VMS) ;1/24/08  16:08
  ;;8.0;KERNEL;**275,425,440**;Jul 10, 1995;Build 13
  ;Per VHA Directive 2004-038, this routine should not be modified
+%ZIS4 ;ISF/RWF,DW - DEVICE HANDLER SPECIFIC CODE (GT.M for Unix/VMS) ;03/07/2007
+ ;;8.0;KERNEL;**275,425**;Jul 10, 1995;Build 18
+ ;
 OPEN ;From %ZIS3 for TRM
  G OPN2:$D(IO(1,IO))
 …
+ Q
  ;Why no open paraneters???
 OP1 N $ET S $ET="G OPNERR^%ZIS4"
  I $D(%ZISLOCK) L +@%ZISLOCK:5 E  S POP=1 Q
  O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1
+OP1 N $ES,$ET S $ET="G OPNERR^%ZIS4"
+ L:$D(%ZISLOCK) +@%ZISLOCK:60
+ O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1 L:$D(%ZISLOCK) -@%ZISLOCK
+ Q
 OPNERR ;Open Error
+ S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$$EC^%ZOSV,$EC=""
+ Q
+ S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$$EC^%ZOSV,$EC="" Q
+ ;
 O ;From %ZIS6 for all types.
+O ;From %ZIS6 for other types.
  D:%IS["L" ZIO
+ I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX ;Open Printer Port
+LCKGBL ;Lock Global
+ I %ZTYPE="CHAN" N % S %=$G(^%ZIS(1,+%E,"GBL")) I $L(%) L @("+^"_%_":0") S:'$T POP=1 I POP W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q
+ I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX
 OPAR I $D(IOP),%ZTYPE="HFS",$D(%IS("HFSIO")),$D(%IS("IOPAR")),%IS("HFSIO")]"" S IO=%IS("HFSIO"),%ZISOPAR=%IS("IOPAR")
  I %ZTYPE="CHAN" D TCPIP Q:POP  G OXECUTE^%ZIS6
  S %A=%ZISOPAR_$S(%ZISOPAR["):":"",1:":"_%ZISTO)
+ S %A=%ZISOPAR_$S(%ZISOPAR["):":"",%ZTYPE["CHAN"&($P(%ZTIME,"^",3)="n"):"",1:":"_%ZISTO)
  N % S %(IO)="",%=$P($P($NA(%(IO)),"(",2),")")
  S %A=%_$E(":",%A]"")_%A
 …
+ ;
 O1 N $ES,$ET S $ET="G OPNERR^%ZIS4"
  I $D(%ZISLOCK) L +@%ZISLOCK:5 E  S POP=1 Q
  O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)=""
+ L:$D(%ZISLOCK) +@%ZISLOCK:60
+ O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)="" L:$D(%ZISLOCK) -@%ZISLOCK
  S IO("ERROR")="" Q
+ ;
 …
+ Q
+ ;
 TCPIP ;For TCP/IP devices, should use ^%ZISTCP
+TCPIP ;For TCP/IP devices
  N %S
  S %ZISTO=$G(%ZISTO,3)
 …
  I $D(ZISDA) W:'$D(IOP) !?5,*7,"You may not Spool the printing of a Spool document" G N
  I $D(DUZ)[0 W:'$D(IOP) !,"Must be a valid user." G N
+R S %ZY=-1 D NEWDOC^ZISPL1 G N:%ZY'>0
+ S %ZDA=+%ZY,%ZFN=$P(%ZY(0),U,2),IO("DOC")=$P(%ZY(0),U,1) G OK:$D(IO("Q"))
+ G:'%ZISB OK I '$P(%ZY,"^",3),$L(%ZFN) O %ZFN:(append:nowrap):2 G DOC
+R S %ZY=-1 D NEWDOC^ZISPL1 G N:%ZY'>0 S %ZDA=+%ZY,%ZFN=$P(%ZY(0),U,2),IO("DOC")=$P(%ZY(0),U,1) G OK:$D(IO("Q"))
+ G:'%ZISB OK I '$P(%ZY,"^",3),%ZFN]"" D SPL3 G N:%ZFN']"",DOC
  S %ZFN=IO_"SPOOL_no_"_%ZDA_".TMP" D SPL2 G:%ZFN']"" N S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)=""
 DOC S IO=%ZFN,IO("SPOOL")=%ZDA,^XUTL("XQ",$J,"SPOOL")=%ZDA,IOF="#"
 …
 OK K %ZDA,%ZFN Q
 N K %ZDA,%ZFN,IO("DOC") S POP=1 Q
+ ;
+SPL2 ;Open for write
+ O %ZFN:(newversion:noreadonly:nowrap:exception="G SPL4"):2 G:$ZA<0 SPL4 S IO(1,%ZFN)="" Q
+ ;
+SPL3 ;Open for Read
+ O %ZFN:(readonly:exception="G SPL4"):2 S:'$T ZISPLQ=1 G:'$T SPL4 S IO(1,%ZFN)="" Q
+SPL2 O %ZFN:(NEWVERSION:WORLD=RWD) G:$ZA<0 SPL4 S IO(1,%ZFN)="" Q
+SPL3 N X S X="SPL4^%ZIS4",@^%ZOSF("TRAP")
+ O %ZFN:READONLY:1 S:'$T ZISPLQ=1 G:$ZA<0!('$T) SPL4 S IO(1,%ZFN)="" Q
 SPL4 W:'$D(IOP)&'$D(ZTQUEUED) !?5,*7,"Couldn't open the spool file." S %ZFN="" Q
+ ;
+CLOSE ;Close out the spool
+ N %,%1,%Z1,%ZFN,%ZS,%ZDA,XS,%Y,%X
+ I $L(IO) C IO K IO(1,IO)
+ D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q
+ S %ZFN=$P(%ZS,"^",2) D SPL3 Q:%ZFN']""  S %ZCR=$C(13),%Y=""
+ S %Z1=+$G(^XTV(8989.3,1,"SPL")),%=0
+ U %ZFN F  R %X#255:5 Q:$ZEOF  S %2=%X D CL2 Q:%Z1<%
+CLOSE N %Z1 C:IO]"" IO K:IO]"" IO(1,IO) D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q
+ S %ZFN=$P(%ZS,"^",2) D SPL3 Q:%ZFN']""  U %ZFN S %ZCR=$C(13),%Y="",X="SPLEOF^%ZIS4",@^%ZOSF("TRAP")
+ S %Z1=+$G(^XTV(8989.3,1,"SPL"))
+ F %=0:0 R %X#255:5 Q:$ZA<0  S %2=%X D CL2 G:%Z1<% SPLEX
+SPLEOF I $ZE'["ENDO" Q  ;Send error up
 SPLEX C %ZFN:(DELETE) K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q
+ ;

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS6.m

-              r628
+              r636
+%ZIS6 ;SFISC/AC - DEVICE HANDLER -- RESOURCES ;1/24/08  16:09
+ ;;8.0;KERNEL;**24,49,69,118,127,136,440**;JUL 10, 1995;Build 13
+ ;Per VHA Directive 2004-038, this routine should not be modified
+%ZIS6 ;SFISC/AC - DEVICE HANDLER -- RESOURCES ;02/04/2000  08:14
+ ;;8.0;KERNEL;**24,49,69,118,127,136**;JUL 10, 1995
  ;Expect that IO is current device
+OXECUTE ;Open Execute
+ I $D(^%ZIS(2,%ZISIOST(0),2))=1 S %Y=^(2) D 2
+ANSBAK ;Answer Back
+ I $D(^%ZIS(2,%ZISIOST(0),102)) S %Y=^(102) D 2 E  S POP=1 D:'$D(IOP) SAY($C(7)_"[NOT ON LINE]") C:%ZISB IO K IO(1,IO) G QUIT
+OXECUTE I $D(^%ZIS(2,%ZISIOST(0),2))=1 S %Y=^(2) D 2
+ANSBAK I $D(^%ZIS(2,%ZISIOST(0),102)) S %Y=^(102) D 2 E  S POP=1 D:'$D(IOP) SAY($C(7)_"[NOT ON LINE]") C:%ZISB IO K IO(1,IO) G QUIT
  I $D(%ZISMTR) X ^%ZOSF("MAGTAPE") U IO W:$D(%MT("REW")) @%MT("REW") U IO(0) K %MT
  G QUIT:'$D(IO("P"))
 …
 HG ;
+ Q
+SPL ;Spool type
+ N %E,%Z D MARGN^%ZIS3 W:'$D(IOP) ! D SPOOL^%ZIS4:%IS'["T"
+SPL N %E,%Z D MARGN^%ZIS3 W:'$D(IOP) ! D SPOOL^%ZIS4:%IS'["T" ;Spool type
  G Q
 MT D MARGN^%ZIS3,ASKPAR,AMTREW:'POP&'$D(IOP)&%ZISB W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Magtape type
  G Q
+SDP ;Sequential disk processor type
+ D MARGN^%ZIS3,ASKPAR W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T"))
+SDP D MARGN^%ZIS3,ASKPAR W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Sequential disk processor type
  G Q
+HFS ;Host File Server type
+ D MARGN^%ZIS3,HFS^%ZIS4 W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T"))
+HFS D MARGN^%ZIS3,HFS^%ZIS4 W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Host File Server type
  G Q
+RES ;Resources
+ G Q:%IS["T" N X,X1 I %IS'["R"!'$D(IOP) S POP=1 W:'$D(IOP) *7,"  [NOT AVAILABLE]" Q
+RES G Q:%IS["T" N X,X1 I %IS'["R"!'$D(IOP) S POP=1 W:'$D(IOP) *7,"  [NOT AVAILABLE]" Q  ;Resources
  G Q:$D(IO(1,IO)) I %IS["T" S X=IO,X1="RES" D DEVOK^%ZIS3 S:Y POP=1 G Q:POP
  D:%ZISB RES1 G Q
 …
 IMPC ;Imaging Work Station
 BAR ;Bar Code
+OTH ;Other Device type
+ D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T"))
+OTH D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Other Device type
  G Q
+ ;
+ASKPAR ;Ask Parameters
+ G SETPAR^%ZIS3:$D(IOP),SETPAR^%ZIS3:'$P(^%ZIS(1,%E,0),"^",4) W "  ADDRESS/PARAMETERS: " W:%ZISOPAR]"" %ZISOPAR_"// " D SBR^%ZIS1 D MSG1:%X="?" G ASKPAR:%X="?" S:%X]"" %ZISOPAR=%X I $D(DTOUT)!$D(DUOUT) S POP=1
+ASKPAR G SETPAR^%ZIS3:$D(IOP),SETPAR^%ZIS3:'$P(^%ZIS(1,%E,0),"^",4) W "  ADDRESS/PARAMETERS: " W:%ZISOPAR]"" %ZISOPAR_"// " D SBR^%ZIS1 D MSG1:%X="?" G ASKPAR:%X="?" S:%X]"" %ZISOPAR=%X I $D(DTOUT)!$D(DUOUT) S POP=1
  I POP,%ZISB&(%ZTYPE["TRM") C IO K IO(1,IO) Q
  Q:POP  G SETPAR^%ZIS3
+AMTREW I %ZISB,%ZTYPE="MT",'$D(IOP) W "  REWIND" S %=2,U="^",%ZISDTIM=60 D YN^%ZIS1 K %ZISDTIM G AMTREW:%=0 I %=-1 S POP=1 Q
+ S:%=1 %ZISMTR=1 Q
+MSG1 W !?5,"Enter the desired parameters needed to open the selected device.",!?25 Q
+ ;
-AMTREW ;Mag Tape Rewind
- I %ZISB,%ZTYPE="MT",'$D(IOP) W "  REWIND" S %=2,U="^",%ZISDTIM=60 D YN^%ZIS1 K %ZISDTIM G AMTREW:%=0 I %=-1 S POP=1 Q
- S:%=1 %ZISMTR=1
+ Q
-MSG1 W !?5,"Enter the desired parameters needed to open the selected device.",!?25
+ Q
+ ;

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZISC.m

-              r628
+              r636
+%ZISC ;SFISC/GFT,AC,MUS - CLOSE LOGIC FOR DEVICES  ;1/24/08  16:09
+ ;;8.0;KERNEL;**24,36,49,69,199,216,275,409,440**;JUL 10, 1995;Build 13
+ ;Per VHA Directive 2004-038, this routine should not be modified
+%ZISC ;SFISC/GFT,AC,MUS - CLOSE LOGIC FOR DEVICES  ;01/14/2002  09:06
+ ;;8.0;KERNEL;**24,36,49,69,199,216,275,409**;JUL 10, 1995;Build 3
 C0 ;
  N %,%E,%H,%ZISI,%ZISOS,%ZISX,%ZISV
 …
  . U:$S($D(ZTQUEUED):0,'$L($G(IO(0))):0,$D(IO(1,IO(0)))#2:1,1:0) IO(0)
  . C IO K IO(1,IO) S IO("CLOSE")=IO ;close device
- ;Unlock global used to control access.
- S %=$G(^XUTL("XQ",$J,"lock",+$G(IOS))) I $L(%) L -@% K ^XUTL("XQ",$J,"lock",IOS)
+ ;
+ ;
+ I $D(IOT),IOT="CHAN",$D(IOS) D
+ .S %=$G(^%ZIS(1,+IOS,"GBL"))
+ .I %]"" L @("-^"_%) ;unlock global used to control access to network channels.
  I $D(IO("SPOOL")) D CLOSE^%ZIS4 ;Special close for spool device
+ ;

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZISS1.m

-              r628
+              r636
+%ZISS1 ;AC/SFISC - Collect screen parameters 5/29/88  2:02 PM ;1/24/08  16:10
+ ;;8.0;KERNEL;**69,440**;JUL 10, 1995;Build 13
+ ;Per VHA Directive 2004-038, this routine should not be modified
+VALID ;
+ N %ZISI,%ZISNP,ZISCH,ZISEND,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440
+ D L
+%ZISS1 ;AC/SFISC - Collect screen parameters 5/29/88  2:02 PM ;11/05/97  08:40
+ ;;8.0;KERNEL;**69**;JUL 10, 1995
+VALID D L K %ZISI,%ZISNP,ZISCH,ZISEND,ZISNUM,ZISQ,ZISXL,ZISXLN Q
+ ;
+SET2 S %ZISFN="" F %ZISZ=0:0 S %ZISFN=$O(%ZISZ(%ZISFN)) Q:%ZISFN=""  I $D(%ZISZ(%ZISFN))#2 S %ZISXX=%ZISZ(%ZISFN) D INDCK
+ Q
+ ;
+SET2 ;
+ S %ZISFN="" F %ZISZ=0:0 S %ZISFN=$O(%ZISZ(%ZISFN)) Q:%ZISFN=""  I $D(%ZISZ(%ZISFN))#2 S %ZISXX=%ZISZ(%ZISFN) D INDCK
+ Q
+INDCK ;
+ S %ZISY=""
+INDCK S %ZISY=""
  I "IOEFLD^IOSTBM"[%ZISFN S @%ZISFN=%ZISXX Q
  I %ZISXX]"" S @("%ZISY="_%ZISXX)
 …
  E  S @("IO"_$E(%ZISFN,1,6))=%ZISY
  Q:'$D(%ZIS)#2  Q:%ZIS'["I"  Q:'$D(%ZISZ(%ZISFN,1))
+ ;
+SRAY ;
+ S %=%ZISY,%ZISY=$A($E(%ZISY,1))
+SRAY S %=%ZISY,%ZISY=$A($E(%ZISY,1))
  F %1=2:1:$L(%) S %ZISY=%ZISY_$S($A(%,%1)<32:$A(%,%1),$A(%,%1)=127:127,1:$E(%,%1))
  S IOIS(%ZISY)=%ZISFN
+ Q
 CHECK ;Entry point called from input transforms of fields in DEV/TT files.
+ N %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440
+ S %ZISXX=X D L S X=%ZISYY
+ S %ZISXX=X D L S X=%ZISYY K %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN
+ Q
 CHECK1 ;Entry point called from input transforms of fields in DEV/TT files.
- N %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440
  S %ZISXX=$S(X?1"W ".E:$E(X,3,$L(X)),1:X)
  D L S X=$S(X?1"W ".E:"W "_%ZISYY,1:%ZISYY)
+ D L S X=$S(X?1"W ".E:"W "_%ZISYY,1:%ZISYY) K %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN
+ Q
 FORM ;Entry point called from input transforms of fields in DEV/TT files.
  Q:$L(X,"_")'>1
- N %ZISSI,%ZISSY ;p440
  ;F %ZISSI=1:1:$L(X,"_") S %ZISX1=$P(X,"_",%ZISSI) I %ZISX1]"","#?!"[$E(%ZISX1) S X=$S(%ZISSI=1:"",1:$P(X,"_",1,%ZISSI-1)_",")_%ZISX1_$S(%ZISSI<$L(X,"_"):","_$P(X,"_",%ZISSI+1,255),1:"") W !,%ZISSI_"==>"_X
  S %ZISSY=""
  F %ZISSI=1:1:$L(X,"_") S %ZISSY=%ZISSY_$P(X,"_",%ZISSI)_$S($P(X,"_",%ZISSI+1)="":"","#?!"[$E($P(X,"_",%ZISSI+1)):",","#?!"[$E($P(X,"_",%ZISSI)):",",1:"_")
  S X=%ZISSY
+ S X=%ZISSY K %ZISSI,%ZISSY
+ Q
+ ;
 L S ZISQ="""",%ZISNP=0,ZISXLN=$L(%ZISXX) I 'ZISXLN S %ZISYY="" Q
  S ZISXL=0,%ZISYY="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) D L1 Q:ZISXL'<ZISXLN
+ S (ZISXL)=0,%ZISYY="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) D L1 Q:ZISXL'<ZISXLN
  ;I $L(%ZISYY,"$C(")>2,%ZISYY[")_$C(" S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX Q
  S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX
 …
  I ZISCH="*" D STAR Q
  I ZISCH="(" D PAREN Q
+ S %ZISYY=%ZISYY_ZISCH
+ S %ZISYY=%ZISYY_ZISCH Q
+L2 F I=1:1:$L(%ZISXX,"_") S %ZISX1=$P(%ZISXX,"_",I),%ZISX2=$P(%ZISXX,"_",I+1) I $E(%ZISX1,1,3)="$C(",$E(%ZISX2,1,3)="$C(" D S2
+ Q
+L2 ;Find $C(x)_$C(y) and merge
+ N I ;p440
+ F I=1:1:$L(%ZISXX,"_") S %ZISX1=$P(%ZISXX,"_",I),%ZISX2=$P(%ZISXX,"_",I+1) I $E(%ZISX1,1,3)="$C(",$E(%ZISX2,1,3)="$C(" D S2
+ Q
+L3 ;
+ N I
+ F I=1:1:$L(%ZISXX,"_") I $P(%ZISXX,"_",I)["+","$("'[$E($P(%ZISXX,"_",I)),")"'[$E($P(%ZISXX,"_",I),$L($P(%ZISXX,"_",I))) S $P(%ZISXX,"_",I)="("_$P(%ZISXX,"_",I)_")"
+L3 F I=1:1:$L(%ZISXX,"_") I $P(%ZISXX,"_",I)["+","$("'[$E($P(%ZISXX,"_",I)),")"'[$E($P(%ZISXX,"_",I),$L($P(%ZISXX,"_",I))) S $P(%ZISXX,"_",I)="("_$P(%ZISXX,"_",I)_")"
+ Q
 STAR ;S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH?1N ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_+ZISNUM_")",ZISXL=ZISXL-1 Q
 …
 QUOTE S %ZISYY=%ZISYY_ZISCH F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL),%ZISYY=%ZISYY_ZISCH I ZISCH=ZISQ!(ZISXL'<ZISXLN) Q
+ Q
 DOLR ;Looking for $C.
+DOLR ;LOOKING FOR $C.
  I "IXY"[$E(%ZISXX,ZISXL+1) S %ZISYY=%ZISYY_"$"_$E(%ZISXX,ZISXL+1) S ZISXL=ZISXL+1 Q
+ I "ACDEFJLNOPRSTV"[$E(%ZISXX,ZISXL+1)&($E(%ZISXX,ZISXL+2)="(") S %ZISYY=%ZISYY_"$"_$E(%ZISXX,ZISXL+1),ZISXL=ZISXL+2 D PAREN Q
+ S %ZISYY=%ZISYY_"$" ;p440
+ I "ACDEFJLNOPRSTV"[$E(%ZISXX,ZISXL+1)&($E(%ZISXX,ZISXL+2)="(") S %ZISYY=%ZISYY_"$"_$E(%ZISXX,ZISXL+1),ZISXL=ZISXL+2 D PAREN
+ Q
+PAREN S %ZISYY=%ZISYY_"(",ZISEND=")",%ZISNP=%ZISNP+1 D SCAN S %ZISNP=%ZISNP-1
+ Q
+PAREN S %ZISYY=%ZISYY_"(",ZISEND=")",%ZISNP=%ZISNP+1 D SCAN S %ZISNP=%ZISNP-1 Q
 SCAN F %ZISI=0:0 S ZISXL=ZISXL+1,ZISCH=$E(%ZISXX,ZISXL) D S1 Q:ZISXL'<ZISXLN!(ZISEND=ZISCH&(%ZISNP))
+ Q
 …
  I ZISCH="$" D DOLR Q
  I ZISCH="(" D PAREN Q
+ S %ZISYY=%ZISYY_ZISCH
+ Q
+ S %ZISYY=%ZISYY_ZISCH Q
+ ;
 S2 ;MERGE $C

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZOSV2.m

-              r628
+              r636
 %ZOSV2 ;ISF/RWF - More GT.M support routines ;10/18/06  14:29
+ ;;8.0;KERNEL;**275,425**;Jul 10, 1995;Build 18
+ ;;8.0;KERNEL;**275,425**;Jul 10, 1995;Build 4;WorldVistA 30-Jan-08
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ Q
  ;SAVE: DIE open array reference.
 …
  S $ETRAP="S $ECODE="""" Q"
  S %I=$I,%DIR=$$RTNDIR^%ZOSV,RN=$TR(RN,"%","_")
  I $L($ZSEARCH(%DIR_RN_".m",244)) ZSYSTEM "DEL "_%DIR_X_".m;*"
  I $L($ZSEARCH(%DIR_RN_".obj",244)) ZSYSTEM "DEL "_%DIR_X_".obj;*"
+ I $L($ZSEARCH(%DIR_RN_".m",244)) ZSYSTEM "rm -f "_%DIR_X_".m"
+ I $L($ZSEARCH(%DIR_RN_".obj",244)) ZSYSTEM "rm -f "_%DIR_X_".obj"
  I $L($ZSEARCH(%DIR_RN_".o",244)) ZSYSTEM "rm -f "_%DIR_X_".o"
+ Q

FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZTLOAD4.m

-              r628
+              r636
 %ZTLOAD4 ;SEA/RDS-TaskMan: P I: Is Queued? ;1/24/08  16:15
  ;;8.0;KERNEL;**440**;JUL 10, 1995;Build 13
  ;Per VHA Directive 2004-038, this routine should not be modified
  ;Call with ZTSK, [ZTCPU]; Return ZTSK()
+%ZTLOAD4 ;SEA/RDS-TaskMan: P I: Is Queued? ;7/26/91  11:55 ;
+ ;;8.0;KERNEL;;JUL 10, 1995
+ ;;7.0;
+ ;
 INPUT ;check input parameters for error conditions
- N %,$ES,$ET,%ZTVOL,ZTREC,ZTD,ZT1,ZT2,ZT3
  I $D(ZTSK)[0 S ZTSK=""
  I $D(ZTSK)>1 S %=ZTSK K ZTSK S ZTSK=%
+ I $D(ZTSK)>1 S ZTLOAD=ZTSK K ZTSK S ZTSK=ZTLOAD K ZTLOAD
  I ZTSK<1!(ZTSK\1'=ZTSK) S ZTSK="",ZTSK(0)="",ZTSK("E")="IT" G QUIT
  S ZTSK(0)="",ZTSK("E")="U",$ET="Q:$ES  S $EC="""" G QUIT^%ZTLOAD4"
+ S ZTSK(0)="",ZTSK("E")="U",X="QUIT^%ZTLOAD3",@^%ZOSF("TRAP")
  S %ZTVOL=^%ZOSF("VOL")
  I $D(ZTCPU)[0 S ZTCPU=%ZTVOL
 …
+ ;
 HERE ;lookup task's status on current volume set
+ L +^%ZTSK(ZTSK):1
+ I $D(^%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT
+ S ZTREC=^%ZTSK(ZTSK,0),ZTD=$G(^(.04))
+ S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=$P(ZTREC,U,6) ;scheduled $H
+ L +^%ZTSK(ZTSK) I $D(^%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT
+ S ZTREC=^%ZTSK(ZTSK,0),ZTD=$P(ZTREC,U,6)
+ S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=ZTD
  I ZTD]"",$D(^%ZTSCH(ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT
  I ZTD]"",$D(^%ZTSCH("JOB",ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ ;
  S ZT1="" F  S ZT1=$O(^%ZTSCH(ZT1)) Q:'ZT1  I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT
  S ZT1="IO",ZT2="" F  S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F  S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
  S ZT1="JOB",ZT2="" F  S ZT2=$O(^%ZTSCH(ZT1,ZT2)) Q:ZT2=""  I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT
  S ZT1="LINK",ZT2="" F  S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F  S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="" F ZT=0:0 S ZT1=$O(^%ZTSCH(ZT1)) Q:'ZT1  I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="IO",ZT2="" F ZT=0:0 S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F ZT=0:0 S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="JOB",ZT2="" F ZT=0:0 S ZT2=$O(^%ZTSCH(ZT1,ZT2)) Q:ZT2=""  I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="LINK",ZT2="" F ZT=0:0 S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F ZT=0:0 S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
  S ZTSK(0)=0
+ ;
 QUIT ;cleanup and quit
  L:ZTSK -^%ZTSK(ZTSK) ;K %ZTCPU,%ZTM,%ZTM1,%ZTM2,%ZTMAST,%ZTVOL,X,Y,ZT,ZT1,ZT2,ZT3,ZTCPU,ZTD,ZTREC
+ L:ZTSK -^%ZTSK(ZTSK) K %ZTCPU,%ZTM,%ZTM1,%ZTM2,%ZTMAST,%ZTVOL,X,Y,ZT,ZT1,ZT2,ZT3,ZTCPU,ZTD,ZTREC
  I ZTSK(0)]"" K ZTSK("E") Q
  I ZTSK("E")'="U" Q
 …
+ ;
 THERE ;rest of code looks up task's status on some other volume set
- N %ZTCPU,%ZTM,X,Y
+ ;
 FILES ;find TaskMan files on the volume set to be searched
 …
 SEARCH ;find out if task is queued on that volume set
  I $D(^[X,Y]%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT
  S ZTREC=^[X,Y]%ZTSK(ZTSK,0),ZTD=$G(^(.04))
  S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=$P(ZTREC,U,6)
+ S ZTREC=^[X,Y]%ZTSK(ZTSK,0),ZTD=$P(ZTREC,U,6)
+ S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=ZTD
  I ZTD]"",$D(^[X,Y]%ZTSCH(ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT
  I ZTD]"",$D(^[X,Y]%ZTSCH("JOB",ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ ;
  S ZT1="" F  S ZT1=$O(^[X,Y]%ZTSCH(ZT1)) Q:'ZT1  I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT
  S ZT1="IO",ZT2="" F  S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F  S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
  S ZT1="JOB",ZT2="" F  S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)) Q:ZT2=""  I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT
  S ZT1="LINK",ZT2="" F  S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F  S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="" F ZT=0:0 S ZT1=$O(^[X,Y]%ZTSCH(ZT1)) Q:'ZT1  I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="IO",ZT2="" F ZT=0:0 S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F ZT=0:0 S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="JOB",ZT2="" F ZT=0:0 S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)) Q:ZT2=""  I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="LINK",ZT2="" F ZT=0:0 S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F ZT=0:0 S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
  S ZTSK(0)=0 G QUIT
+ ;

Context Navigation

Legend:

Download in other formats: