Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,64 +1,64 @@
-XGKB	;SFISC/VYD - Read with Escape Processing ;10/23/2006
-	;;8.0;KERNEL;**34,244,365**;Jul 10, 1995;Build 5
-	;;Special thanks to MELDRUM.KEVIN@ISC-SLC.VA.GOV
-	;
-INIT(XGTRM)	;turn escape processing on and passed terminator string if any
-	N %,%OS S %OS=^%ZOSF("OS")
-	I %OS["VAX DSM" U $I:(NOLINE:ESCAPE) D:'$D(^XUTL("XGKB")) VAXDSM^XGKB1
-	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["GT.M" U $I:(ESCAPE) D:'$D(^XUTL("XGKB")) GTM^XGKB1
-	I $G(XGTRM)="*" X ^%ZOSF("TRMON") I 1 ;turn all on
-	E  I $L($G(XGTRM)) S %=$$SETTRM^%ZOSV(XGTRM) ;turn on passed terminators
-	S XGRT=""
-	Q
-	;
-	;
-EXIT	; Reset device (disable escape processing, turn terminators off)
-	N %OS S %OS=^%ZOSF("OS")
-	I %OS["VAX DSM" U $I:(LINE:NOESCAPE)
-	I %OS["MSM" U $I:(0:::::64)
-	I %OS["DTM" U $I:(ESCAPE=0)
-	I %OS["GT.M" U $I:(NOESCAPE)
-	X ^%ZOSF("TRMOFF")
-	K XGRT
-	Q
-	;
-	;
-ACTION(XGKEY,XGACTION)	;add or remove key-action
-	;XGKEY:key mnemonic ("F10","NEXT",etc.)
-	;XGACTION:M executable string
-	;if action is passed ADD mode is assumed otherwise REMOVE
-	I $D(XGACTION) S ^TMP("XGKEY",$J,XGKEY)=XGACTION
-	E  K ^TMP("XGKEY",$J,XGKEY)
-	Q
-	;
-	;
-READ(XGCHARS,XGTO)	; read XGCHARS using escape processing. XGTO timeout (optional).  Result returned.
-	; Char that terminated the read will be in XGRT
-	N S,XGW1,XGT1,XGSEQ ;string,window,timer,timer sequence
-	K DTOUT
-	S XGRT=""
-	D:$G(XGTO)=""                 ;set timeout value if one wasn't passed
-	. I $D(XGT) D  Q              ;if timers are defined
-	. . S XGTO=$O(XGT(0,""))      ;get shortest time left of all timers
-	. . S XGW1=$P(XGT(0,XGTO,$O(XGT(0,XGTO,"")),"ID"),U,1) ;get timer's window
-	. . S XGT1=$P(XGT(0,XGTO,$O(XGT(0,XGTO,"")),"ID"),U,3) ;get timer's name
-	. I $D(XGW) S XGTO=99999999 Q  ;in emulation read forever
-	. S XGTO=$G(DTIME,600)
-	;
-	I $G(XGCHARS)>0 R S#XGCHARS:XGTO S:'$T DTOUT=1 I 1 ;fixed length read
-	E  R S:XGTO S:'$T DTOUT=1 I 1 ;read as many as possible
-	S:$G(DTOUT)&('$D(XGT1)) S=U                          ;stuff ^
-	;
-	S:$L($ZB) XGRT=$G(^XUTL("XGKB",$ZB))          ;get terminator if any
-	I $G(DTOUT),$D(XGT1),$D(^TMP("XGW",$J,XGW1,"T",XGT1,"EVENT","TIMER")) D  I 1 ;if timed out
-	. D E^XGEVNT1(XGW1,"T",XGT1,"","TIMER")
-	E  I $L(XGRT),$D(^TMP("XGKEY",$J,XGRT)) X ^(XGRT)     ;do some action
-	; this really should be handled by keyboard mapping -- later
-	Q S
-	;
-	;
-TEST	F  S X=$$READ Q:X["^"  W ?20,X,?40,XGRT,?60,$ZB,!
-	Q
+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
+ ;
+INIT(XGTRM) ;turn escape processing on and passed terminator string if any
+ N %,%OS S %OS=^%ZOSF("OS")
+ I %OS["VAX DSM" U $I:(NOLINE:ESCAPE) D:'$D(^XUTL("XGKB")) VAXDSM^XGKB1
+ 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
+ I %OS["GT.M" U $I:(ESCAPE) D:'$D(^XUTL("XGKB")) GTM^XGKB1
+ I $G(XGTRM)="*" X ^%ZOSF("TRMON") I 1 ;turn all on
+ E  I $L($G(XGTRM)) S %=$$SETTRM^%ZOSV(XGTRM) ;turn on passed terminators
+ S XGRT=""
+ Q
+ ;
+ ;
+EXIT ; Reset device (disable escape processing, turn terminators off)
+ N %OS S %OS=^%ZOSF("OS")
+ I %OS["VAX DSM" U $I:(LINE:NOESCAPE)
+ I %OS["MSM" U $I:(0:::::64)
+ I %OS["DTM" U $I:(ESCAPE=0)
+ I %OS["GT.M" U $I:(NOESCAPE)
+ X ^%ZOSF("TRMOFF")
+ K XGRT
+ Q
+ ;
+ ;
+ACTION(XGKEY,XGACTION) ;add or remove key-action
+ ;XGKEY:key mnemonic ("F10","NEXT",etc.)
+ ;XGACTION:M executable string
+ ;if action is passed ADD mode is assumed otherwise REMOVE
+ I $D(XGACTION) S ^TMP("XGKEY",$J,XGKEY)=XGACTION
+ E  K ^TMP("XGKEY",$J,XGKEY)
+ Q
+ ;
+ ;
+READ(XGCHARS,XGTO) ; read XGCHARS using escape processing. XGTO timeout (optional).  Result returned.
+ ; Char that terminated the read will be in XGRT
+ N S,XGW1,XGT1,XGSEQ ;string,window,timer,timer sequence
+ K DTOUT
+ S XGRT=""
+ D:$G(XGTO)=""                 ;set timeout value if one wasn't passed
+ . I $D(XGT) D  Q              ;if timers are defined
+ . . S XGTO=$O(XGT(0,""))      ;get shortest time left of all timers
+ . . S XGW1=$P(XGT(0,XGTO,$O(XGT(0,XGTO,"")),"ID"),U,1) ;get timer's window
+ . . S XGT1=$P(XGT(0,XGTO,$O(XGT(0,XGTO,"")),"ID"),U,3) ;get timer's name
+ . I $D(XGW) S XGTO=99999999 Q  ;in emulation read forever
+ . S XGTO=$G(DTIME,600)
+ ;
+ I $G(XGCHARS)>0 R S#XGCHARS:XGTO S:'$T DTOUT=1 I 1 ;fixed length read
+ E  R S:XGTO S:'$T DTOUT=1 I 1 ;read as many as possible
+ S:$G(DTOUT)&('$D(XGT1)) S=U                          ;stuff ^
+ ;
+ S:$L($ZB) XGRT=$G(^XUTL("XGKB",$ZB))          ;get terminator if any
+ I $G(DTOUT),$D(XGT1),$D(^TMP("XGW",$J,XGW1,"T",XGT1,"EVENT","TIMER")) D  I 1 ;if timed out
+ . D E^XGEVNT1(XGW1,"T",XGT1,"","TIMER")
+ E  I $L(XGRT),$D(^TMP("XGKEY",$J,XGRT)) X ^(XGRT)     ;do some action
+ ; this really should be handled by keyboard mapping -- later
+ Q S
+ ;
+ ;
+TEST F  S X=$$READ Q:X["^"  W ?20,X,?40,XGRT,?60,$ZB,!
+ Q
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,227 +1,147 @@
-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
-	S XPDST=$$LOOK^XPDB1 Q:XPDST<0
-	S XPD("XPDT(")=""
-	D EN^XUTMDEVQ("LST1^XPDDP","Build File Print",.XPD)
-	Q
-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)
-	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
-	. 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
-	. 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
-	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
-	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
-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
-	S XPD=$G(XPD),XPDPG=XPDPG+1
-	W @IOF D HDR,HDR1:XPD
-	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)
-	Q
-HDR	;
-	W "PACKAGE: ",$P(XPD0,U),"     ",XPDDT,?70,$$RJ^XLFSTR("PAGE "_XPDPG,9)
-	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
+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(")="",Y="LST1^XPDDP",Z="Build File Print"
+ D EN^XUTMDEVQ(Y,Z,.XPD)
+ Q
+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 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 ;
+ 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)")
+ Q
+ ;
+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)")
+ 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,XPDOUT
+ Q:$G(XPDGR)=""  S XPDGR="^"_XPDGR
+ Q:'$D(@XPDGR@(0))
+ 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
+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
+ Q:$Y<(IOSL-Y) 0
+ 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,!
+ Q "0^1"
+ ;
+XMP2(X,D0) ;called from ^XMP2
+ N XPDA S XPDA=-1
+ D PNT(X) Q
+ ;
+HDR W !,"PACKAGE: ",$P(XPD0,U),"     ",XPDDT,?70,"PAGE ",XPDPG,!
+ Q
+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
Index: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDIA3.m
===================================================================
--- WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDIA3.m	(revision 613)
+++ WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDIA3.m	(revision 623)
@@ -1,90 +1,84 @@
-XPDIA3	;SFISC/RWF - Install Pre/Post Actions for Kernel files cont. ;6/22/06  09:13
-	;;8.0;KERNEL;**201,302,393,498**;Jul 10, 1995;Build 13
-	;Per VHA Directive 2004-038, this routine should not be modified.
-	Q
-	;^XTMP("XPDI",,XPDA,"KRN",XPDFILE,OLDA) is the global root
-	;XPDNM=package name, XPDA=ien in ^XPD(9.6,
-	;DA=ien in file, OLDA= ien in ^XTMP
-	;
-PAR0F2	;PARAMETER file 8989.5: post.  This is a fake entry called from the post of file 8989.51
-	;Now load any entries from 8989.5
-	N XP1,XP2,XP3,DIK,OLDA,DA,ERR,PN,PE,PT,ROOT
-	S XP1=$O(^XTMP("XPDI",XPDA,"PKG",0)) ;Get the package
-	Q:'XP1  S PN=$G(^XTMP("XPDI",XPDA,"PKG",XP1,0))
-	S PE=$$FIND1^DIC(9.4,,"MX",$P(PN,U,2)) ;Get the IEN of the package
-	S OLDA=0,ROOT=$NA(^XTMP("XPDI",XPDA,"KRN",8989.5))
-	F  S OLDA=$O(@ROOT@(OLDA)) Q:'OLDA  D
-	. S XP1=@ROOT@(OLDA,0)
-	. S $P(XP1,U,1)=PE_";DIC(9.4," ;entity
-	. S $P(XP1,U,2)=$$LK^XPDIA($NA(^XTV(8989.51)),$P(XP1,U,2))
-	. S DA=$$LKPAR($P(XP1,U),$P(XP1,U,2),$P(XP1,U,3))
-	. ;Remove the current entry if we have one
-	. I DA>0 S DIK="^XTV(8989.5," D ^DIK
-	. ;Otherwise Add the zero node, See that we have a IEN
-	. I DA'>0 D ADDPAR($P(XP1,U),$P(XP1,U,2),$P(XP1,U,3)) S DA=$$LKPAR($P(XP1,U),$P(XP1,U,2),$P(XP1,U,3))
-	. Q:'DA  ;don't have a entry
-	. ;Merge the date ;with IHS fix
-	. M ^XTV(8989.5,DA)=^XTMP("XPDI",XPDA,"KRN",8989.5,OLDA)
-	. S ^XTV(8989.5,DA,0)=XP1 ;zero node with new pointers
-	. ;Get Definition and check if Data Type is pointer, then get pointed to global ref.
-	. S PT=$G(^XTV(8989.51,+$P(XP1,U,2),1)) D:$P(PT,U)="P"
-	. . S XP3=$G(^XTV(8989.5,DA,1)),PT=$P(PT,U,2)
-	. . S:PT $P(XP3,U)=$$FIND1^DIC(PT,"","X",$P(XP3,U)) ;resolve pointer value
-	. . S:$P(XP3,U) ^XTV(8989.5,DA,1)=XP3
-	. ;X-ref it
-	. S DIK="^XTV(8989.5," D IX1^DIK
-	Q
-	;
-LKPAR(ENT,PAR,INST)	;Lookup an entry
-	Q $O(^XTV(8989.5,"AC",PAR,ENT,INST,0))
-	;
-ADDPAR(ENT,PAR,INST)	;Add a parameter instance
-	N FDA,FDAIEN,DIERR
-	S FDA(8989.5,"+1,",.01)=ENT
-	S FDA(8989.5,"+1,",.02)=PAR
-	S FDA(8989.5,"+1,",.03)=INST
-	D UPDATE^DIE("","FDA","FDAIEN","DIERR")
-	Q
-	;
-PAR1F1	;PARAMETER File 8989.51: file Pre
-	Q
-PAR1E1	;PARAMETER file 8989.51: entry pre
-	N XP1,XP2,XP3
-	S ^TMP($J,"XPD",DA)=""
-	;if there is a new Description, kill the old Description
-	K:$O(^XTMP("XPDI",XPDA,"KRN",8989.51,OLDA,20,0)) ^XTV(8989.51,DA,20)
-	;Kill any old Allowable entries
-	K:$O(^XTMP("XPDI",XPDA,"KRN",8989.51,OLDA,30,0)) ^XTV(8989.51,DA,30)
-	Q
-PAR1F2	;PARAMETER file 8989.51: file post
-	N XPD,DIK,DA
-	S DA=0
-	F  S DA=$O(^TMP($J,"XPD",DA)) Q:'DA  D
-	. S DIK="^XTV(8989.51," D IX1^DIK
-	D PAR0F2 ;Go load the entries from 8989.5
-	Q
-PAR1DEL(RT)	;Delete Parameter Def entries
-	D DELPTR^XPDUTL1(8989.51,RT) ;Cleanup pointers
-	D DELIEN^XPDUTL1(8989.51,RT) ;Cleanup entries
-	Q
-	;
-PAR2F1	;PARAMETER File 8989.52: file Pre
-	K ^TMP($J,"XPD")
-	Q
-PAR2E1	;PARAMETER file 8989.52: entry Pre
-	N XP1,XP2,ROOT
-	S ROOT=$NA(^XTMP("XPDI",XPDA,"KRN",8989.52))
-	S XP2=$P(@ROOT@(OLDA,0),U,4) ;Use instance of
-	;Because we change the transport global see that a restart will work
-	I $L(XP2),XP2?1A.E S $P(@ROOT@(OLDA,0),U,4)=$$LK^XPDIA($NA(^XTV(8989.51)),XP2)
-	S XP1=0
-	F  S XP1=$O(@ROOT@(OLDA,10,XP1)),XP2="" Q:'XP1  D
-	. S XP2=$P(@ROOT@(OLDA,10,XP1,0),U,2) ;Parameter
-	. I $L(XP2),XP2?1A.E S $P(@ROOT@(OLDA,10,XP1,0),U,2)=$$LK^XPDIA($NA(^XTV(8989.51)),XP2)
-	. Q
-	Q
-PAR2F2	;PARAMETER file 8989.52: file Post
-	Q
-PAR2DEL(RT)	;Delete Parameter Templates
-	D DELIEN^XPDUTL1(8989.52,RT)
-	Q
+XPDIA3 ;SFISC/RWF - Install Pre/Post Actions for Kernel files cont. ;6/22/06  09:13
+ ;;8.0;KERNEL;**201,302,393**;Jul 10, 1995;Build 12
+ Q
+ ;^XTMP("XPDI",,XPDA,"KRN",XPDFILE,OLDA) is the global root
+ ;XPDNM=package name, XPDA=ien in ^XPD(9.6,
+ ;DA=ien in file, OLDA= ien in ^XTMP
+ ;
+PAR0F2 ;PARAMETER file 8989.5: post.  This is a fake entry called from the post of file 8989.51
+ ;Now load any entries from 8989.5
+ N XP1,XP2,DIK,OLDA,DA,ERR,PN,PE,ROOT
+ S XP1=$O(^XTMP("XPDI",XPDA,"PKG",0)) ;Get the package
+ Q:'XP1  S PN=$G(^XTMP("XPDI",XPDA,"PKG",XP1,0))
+ S PE=$$FIND1^DIC(9.4,,"MX",$P(PN,U,2)) ;Get the IEN of the package
+ S OLDA=0,ROOT=$NA(^XTMP("XPDI",XPDA,"KRN",8989.5))
+ F  S OLDA=$O(@ROOT@(OLDA)) Q:'OLDA  D
+ . S XP1=@ROOT@(OLDA,0)
+ . S $P(XP1,U,1)=PE_";DIC(9.4," ;entity
+ . S $P(XP1,U,2)=$$LK^XPDIA($NA(^XTV(8989.51)),$P(XP1,U,2))
+ . S DA=$$LKPAR($P(XP1,U),$P(XP1,U,2),$P(XP1,U,3))
+ . ;Remove the current entry if we have one
+ . I DA>0 S DIK="^XTV(8989.5," D ^DIK
+ . ;Otherwise Add the zero node, See that we have a IEN
+ . I DA'>0 D ADDPAR($P(XP1,U),$P(XP1,U,2),$P(XP1,U,3)) S DA=$$LKPAR($P(XP1,U),$P(XP1,U,2),$P(XP1,U,3))
+ . Q:'DA  ;don't have a entry
+ . ;Merge the date ;with IHS fix
+ . M ^XTV(8989.5,DA)=^XTMP("XPDI",XPDA,"KRN",8989.5,OLDA)
+ . S ^XTV(8989.5,DA,0)=XP1 ;zero node with new pointers
+ . ;X-ref it
+ . S DIK="^XTV(8989.5," D IX1^DIK
+ Q
+ ;
+LKPAR(ENT,PAR,INST) ;Lookup an entry
+ Q $O(^XTV(8989.5,"AC",PAR,ENT,INST,0))
+ ;
+ADDPAR(ENT,PAR,INST) ;Add a parameter instance
+ N FDA,FDAIEN,DIERR
+ S FDA(8989.5,"+1,",.01)=ENT
+ S FDA(8989.5,"+1,",.02)=PAR
+ S FDA(8989.5,"+1,",.03)=INST
+ D UPDATE^DIE("","FDA","FDAIEN","DIERR")
+ Q
+ ;
+PAR1F1 ;PARAMETER File 8989.51: file Pre
+ Q
+PAR1E1 ;PARAMETER file 8989.51: entry pre
+ N XP1,XP2,XP3
+ S ^TMP($J,"XPD",DA)=""
+ ;if there is a new Description, kill the old Description
+ K:$O(^XTMP("XPDI",XPDA,"KRN",8989.51,OLDA,20,0)) ^XTV(8989.51,DA,20)
+ ;Kill any old Allowable entries
+ K:$O(^XTMP("XPDI",XPDA,"KRN",8989.51,OLDA,30,0)) ^XTV(8989.51,DA,30)
+ Q
+PAR1F2 ;PARAMETER file 8989.51: file post
+ N XPD,DIK,DA
+ S DA=0
+ F  S DA=$O(^TMP($J,"XPD",DA)) Q:'DA  D
+ . S DIK="^XTV(8989.51," D IX1^DIK
+ D PAR0F2 ;Go load the entries from 8989.5
+ Q
+PAR1DEL(RT) ;Delete Parameter Def entries
+ D DELPTR^XPDUTL1(8989.51,RT) ;Cleanup pointers
+ D DELIEN^XPDUTL1(8989.51,RT) ;Cleanup entries
+ Q
+ ;
+PAR2F1 ;PARAMETER File 8989.52: file Pre
+ K ^TMP($J,"XPD")
+ Q
+PAR2E1 ;PARAMETER file 8989.52: entry Pre
+ N XP1,XP2,ROOT
+ S ROOT=$NA(^XTMP("XPDI",XPDA,"KRN",8989.52))
+ S XP2=$P(@ROOT@(OLDA,0),U,4) ;Use instance of
+ ;Because we change the transport global see that a restart will work
+ I $L(XP2),XP2?1A.E S $P(@ROOT@(OLDA,0),U,4)=$$LK^XPDIA($NA(^XTV(8989.51)),XP2)
+ S XP1=0
+ F  S XP1=$O(@ROOT@(OLDA,10,XP1)),XP2="" Q:'XP1  D
+ . S XP2=$P(@ROOT@(OLDA,10,XP1,0),U,2) ;Parameter
+ . I $L(XP2),XP2?1A.E S $P(@ROOT@(OLDA,10,XP1,0),U,2)=$$LK^XPDIA($NA(^XTV(8989.51)),XP2)
+ . Q
+ Q
+PAR2F2 ;PARAMETER file 8989.52: file Post
+ Q
+PAR2DEL(RT) ;Delete Parameter Templates
+ D DELIEN^XPDUTL1(8989.52,RT)
+ Q
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,91 +1,91 @@
-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.
-	;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
-	;Get data needed
-	I '$D(^XPD(9.7,$G(D0),0)) D BMES^XPDUTL(" INSTALL file entry missing") Q ""
-	;p350 -add node 6 for the Test# and Seq#. -REM
-	S XPD0=^XPD(9.7,D0,0),XPD1=$G(^(1)),XPD2=$G(^(2)),XPD6=$G(^(6))
-	I '$P(XPD0,U,2) D BMES^XPDUTL(" No link to PACKAGE file") Q ""
-	S XPD=$P($G(^DIC(9.4,+$P(XPD0,U,2),0)),U),XPDV=$$VER^XPDUTL($P(XPD0,U))
-	I XPD="" D BMES^XPDUTL(" PACKAGE file entry missing") Q ""
-	;XPZ(1)=start, XPZ(2)=completion date/time, XPZ(3)=run time
-	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()
-LOCAL	;Send a message to local mail group
-	N XMY,XPDTEXT,XMTEXT,XMDUZ,XMSUB,XMZ
-	K ^TMP($J)
-	S X=$$MAILGRP^XPDUTL(XPD) Q:X=""
-	S XMY(X)="" D GETENV^%ZOSV
-	;Message for users
-	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)="Environment: "_Y
-	S XPDTEXT(8,0)="Installed by: "_$P($G(^VA(200,+$P(XPD0,U,11),0)),U)
-	S XPDTEXT(9,0)="Install Name: "_$P(XPD0,U)
-	S XPDTEXT(10,0)="Distribution Date: "_$$FMTE^XLFDT($P(XPD1,U,4))
-	S XMDUZ=$S($P(XPD0,U,11):+$P(XPD0,U,11),1:.5),XMTEXT="XPDTEXT(",XMSUB=$P(XPD0,U)_" INSTALLATION"
-	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)
-	S:XPY XMY("ESSRESOURCE@MED.VA.GOV")=""
-	S:$L($P(XPY,U,2)) XMY($P(XPY,U,2))=""
-	;Message for server (all in one string)
-	;XMTEXT=Type(1),Domain(2-65),Pkg(66-95),Version(96-125),
-	;       StartTime(126-147),CompleteTime(148-169),RunTime(170-177),
-	;       Date(178-199),InstalledBy(200-229),InstallName(230-259),
-	;       DistributionDate(260-281),Seq#(282-286),
-	;       PatchTestVersion(287-317)
-	;
-	S X1=1_$G(^XMB("NETNAME")) ;Type is always "1"(1=patch,0=pkg).
-	S $E(X1,66,95)=XPD,$E(X1,96,125)=XPDV,$E(X1,126,147)=XPZ(1),$E(X1,148,169)=XPZ(2),$E(X1,170,177)=XPZ(3),$E(X1,178,199)=DT
-	S $E(X1,200,229)=$P($G(^VA(200,+$P(XPD0,U,11),0)),U),$E(X1,230,259)=$P(XPD0,U),$E(X1,260,281)=$P(XPD1,U,4),$E(X1,282,286)=$P(XPD6,U,2),$E(X1,287,317)=$P(XPD6,U)
-	S XPDTEXT(1,0)=X1
-	S XMDUZ=$S($P(XPD0,U,11):+$P(XPD0,U,11),1:.5),XMTEXT="XPDTEXT(",XMSUB="KIDS-"_$P(XPD0,U)_" INSTALLATION"
-	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)
+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,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 ""
+ ;p350 -add node 6 for the Test# and Seq#. -REM
+ S XPD0=^XPD(9.7,D0,0),XPD1=$G(^(1)),XPD2=$G(^(2)),XPD6=$G(^(6))
+ I '$P(XPD0,U,2) D BMES^XPDUTL(" No link to PACKAGE file") Q ""
+ S XPD=$P($G(^DIC(9.4,+$P(XPD0,U,2),0)),U),XPDV=$$VER^XPDUTL($P(XPD0,U))
+ I XPD="" D BMES^XPDUTL(" PACKAGE file entry missing") Q ""
+ ;XPZ(1)=start, XPZ(2)=completion date/time, XPZ(3)=run time
+ 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
+ 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
+ K ^TMP($J),XMY,XPDTEXT,XMTEXT
+ S X=$$MAILGRP^XPDUTL(XPD) Q:X=""
+ S XMY(X)="" D GETENV^%ZOSV
+ ;Message for users
+ 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)="Environment: "_Y
+ S XPDTEXT(8,0)="Installed by: "_$P($G(^VA(200,+$P(XPD0,U,11),0)),U)
+ S XPDTEXT(9,0)="Install Name: "_$P(XPD0,U)
+ S XPDTEXT(10,0)="Distribution Date: "_$$FMTE^XLFDT($P(XPD1,U,4))
+ S XMDUZ=$S($P(XPD0,U,11):+$P(XPD0,U,11),1:.5),XMTEXT="XPDTEXT(",XMSUB=$P(XPD0,U)_" INSTALLATION"
+ D ^XMD
+ Q
+ ;
+REMEDY ;Send to Remedy Server - ESSRESOURCE@MED.VA.GOV *p350 -REM
+ 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),
+ ;       StartTime(126-147),CompleteTime(148-169),RunTime(170-177),
+ ;       Date(178-199),InstalledBy(200-229),InstallName(230-259),
+ ;       DistributionDate(260-281),Seq#(282-286),
+ ;       PatchTestVersion(287-317)
+ ;
+ S X1=1_$G(^XMB("NETNAME")) ;Type is always "1"(1=patch,0=pkg).
+ S $E(X1,66,95)=XPD,$E(X1,96,125)=XPDV,$E(X1,126,147)=XPZ(1),$E(X1,148,169)=XPZ(2),$E(X1,170,177)=XPZ(3),$E(X1,178,199)=DT
+ S $E(X1,200,229)=$P($G(^VA(200,+$P(XPD0,U,11),0)),U),$E(X1,230,259)=$P(XPD0,U),$E(X1,260,281)=$P(XPD1,U,4),$E(X1,282,286)=$P(XPD6,U,2),$E(X1,287,317)=$P(XPD6,U)
+ S XPDTEXT(1,0)=X1
+ S XMDUZ=$S($P(XPD0,U,11):+$P(XPD0,U,11),1:.5),XMTEXT="XPDTEXT(",XMSUB="KIDS-"_$P(XPD0,U)_" INSTALLATION"
+ D ^XMD
+ Q
Index: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDTA.m
===================================================================
--- WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDTA.m	(revision 613)
+++ WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDTA.m	(revision 623)
@@ -1,147 +1,135 @@
-XPDTA	;SFISC/RSD - Build Actions for Kernel Files ;02/14/2006
-	;;8.0;KERNEL;**15,44,58,131,229,393,498**;Jul 10, 1995;Build 13
-	;Per VHA Directive 2004-038, this routine should not be modified.
-	Q
-	;^XTMP("XPDT",XPDA,"KRN",FILE,DA) is the global root
-	;DA=ien in ^XTMP,XPDNM=package name, XPDA=package ien in ^XPD(9.6,
-OPT	;options
-	N %,%1,%2
-	;if link, kill everything and just process the menu items
-	I XPDFL=2 D  G OPTT
-	.S %=0 F  S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,%)) Q:'%  K:%'=10 ^(%)
-	;resolve Package (0;12), remove Creator (0;5)
-	S %=^XTMP("XPDT",XPDA,"KRN",19,DA,0),$P(%,U,12)=$$PT("^DIC(9.4)",$P(%,U,12)),$P(%,U,5)=""
-	;resolve Help Frame (0;7), kill Permitted Devices (3.96;0) & queue node (200)
-	S $P(%,U,7)=$$PT("^DIC(9.2)",$P(%,U,7)),^XTMP("XPDT",XPDA,"KRN",19,DA,0)=% K ^(3.96),^(200)
-	;resolve Server Bulletin (220;1), Server Mailgroup (220;3)
-	I $D(^XTMP("XPDT",XPDA,"KRN",19,DA,220)) S %=^(220),$P(%,U)=$$PT("^XMB(3.6)",+%),$P(%,U,3)=$$PT("^XMB(3.8)",$P(%,U,3)),^XTMP("XPDT",XPDA,"KRN",19,DA,220)=%
-	;resolve RPC (RPC;0), must be type Broker
-	I $D(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC")) K:$P(^(0),U,4)'="B" ^("RPC") D
-	.;kill  "B"=name x-ref, it will be re-indexed when installed
-	.K ^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC","B")
-	.;loop thru RPCs and resolve (RPC;1)
-	.S %=0 F  S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%)) Q:'%  S %1=$G(^(%,0)) D
-	..S %2=$$PT("^XWB(8994)",+%1)
-	..;if can't resolve then delete
-	..I %2="" K ^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%,0) Q
-	..;save the RPC name
-	..S $P(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%,0),U)=%2
-	.Q
-OPTT	;Menus can only exist for options of type: menu,protocol,protocol menu,
-	;extended action, limited, window suite
-	I "LMOQXZ"'[$P(^XTMP("XPDT",XPDA,"KRN",19,DA,0),U,4) K ^(10) Q
-	;kill  "B"=name, "C"=synonyms x-ref, it will be re-indexed when installed
-	K ^XTMP("XPDT",XPDA,"KRN",19,DA,10,"B"),^("C")
-	;loop thru 10=Menus and resolve Menu (10;1), kill if it doesn't resolve
-	S %=0 F  S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,10,%)) Q:'%  S %1=$G(^(%,0)) D
-	.S %2=$$PT("^DIC(19)",+%1)
-	.;items must be sent by themselves, check "B" x-ref
-	.I $L(%2),$D(^XPD(9.6,XPDA,"KRN",19,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",19,DA,10,%,U)=%2 Q
-	.;if I couldn't resolve this option, then kill it
-	.K ^XTMP("XPDT",XPDA,"KRN",19,DA,10,%)
-	Q
-	;
-PRO	;protocols
-	N %,%1,%2
-	;if link, kill everything and just process the menu items
-	I XPDFL=2 D  G PROT
-	.S %=0 F  S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,%)) Q:'%  K:%'=10 ^(%)
-	;resolve Package (0;12), remove Creator (0;5)
-	S %=^XTMP("XPDT",XPDA,"KRN",101,DA,0),$P(%,U,12)=$$PT("^DIC(9.4)",$P(%,U,12)),$P(%,U,5)=""
-	;kill under Menus (10), "B"=name, "C"=synonyms
-	S ^XTMP("XPDT",XPDA,"KRN",101,DA,0)=%
-	;resolve File Link (5;1), its a variable pointer
-	S %=$P($G(^XTMP("XPDT",XPDA,"KRN",101,DA,5)),U),%1=$P(%,";",2)
-	I %,$D(@("^"_%1_+%_",0)")) S $P(^XTMP("XPDT",XPDA,"KRN",101,DA,5),U)=$P(^(0),U)_";"_%1
-	;resolve HL7 fields, node 770
-	S %=$G(^XTMP("XPDT",XPDA,"KRN",101,DA,770)) I $L(%) D  S ^XTMP("XPDT",XPDA,"KRN",101,DA,770)=%
-	.S $P(%,U)=$$PT("^HL(771)",$P(%,U)),$P(%,U,2)=$$PT("^HL(771)",$P(%,U,2))
-	.S $P(%,U,3)=$$PT("^HL(771.2)",$P(%,U,3)),$P(%,U,11)=$$PT("^HL(771.2)",$P(%,U,11))
-	.S $P(%,U,4)=$$PT("^HL(779.001)",$P(%,U,4)),$P(%,U,7)=$$PT("^HLCS(870)",$P(%,U,7))
-	.S $P(%,U,8)=$$PT("^HL(779.003)",$P(%,U,8)),$P(%,U,9)=$$PT("^HL(779.003)",$P(%,U,9))
-	.S $P(%,U,10)=$$PT("^HL(771.5)",$P(%,U,10))
-PROT	;loop thru 10=Menus and resolve Menu (10;1), kill if it doesn't resolve
-	;kill under Menus (10), "B"=name, "C"=synonyms
-	I $D(^XTMP("XPDT",XPDA,"KRN",101,DA,10,0)) K ^("B"),^("C")
-	S %=0 F  S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,10,%)) Q:'%  S %1=$G(^(%,0)) D
-	.;%2=.01 of Menu(protocol)
-	.S %2=$$PT("^ORD(101)",+%1)
-	.;Menu must also be sent by itself, check "B" x-ref
-	.I $L(%2),$D(^XPD(9.6,XPDA,"KRN",101,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",101,DA,10,%,U)=%2,$P(^XTMP("XPDT",XPDA,"KRN",101,DA,10,%,0),U,4)=$$PT("^ORD(101)",$P(%1,U,4)) Q
-	.K ^XTMP("XPDT",XPDA,"KRN",101,DA,10,%)
-	;If type is Event Driver and sending Subscribers (775)
-	I $P(^XTMP("XPDT",XPDA,"KRN",101,DA,0),U,4)="E" D
-	. ;kill Menu multiple and Subscriber x-ref "B"=name
-	. K ^XTMP("XPDT",XPDA,"KRN",101,DA,10),^(775,"B")
-	. ;loop thru 775=Subscribers and resolve pointer (775;1)
-	. S %=0 F  S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,775,%)) Q:'%  S %1=$G(^(%,0)) D
-	.. ;%2=.01 of subscriber(protocol)
-	.. S %2=$$PT("^ORD(101)",+%1)
-	.. ;protocol must also be sent by itself, check "B" x-ref
-	.. I $L(%2),$D(^XPD(9.6,XPDA,"KRN",101,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",101,DA,775,%,U)=%2 Q
-	.. K ^XTMP("XPDT",XPDA,"KRN",101,DA,775,%)
-	;quit if no Access multiple
-	Q:'$D(^XTMP("XPDT",XPDA,"KRN",101,DA,3,0))  K ^("B")
-	;loop thru Access and resolve (3;1), kill if it doesn't resolve
-	S %=0 F  S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,3,%)) Q:'%  S %1=$G(^(%,0)) D
-	.;%2=.01 of Menu(protocol)
-	.S %2=$$PT("^DIC(19.1)",+%1)
-	.I $L(%2) S ^XTMP("XPDT",XPDA,"KRN",101,DA,3,%,0)=%2 Q
-	.K ^XTMP("XPDT",XPDA,"KRN",101,DA,3,%)
-	Q
-	;
-RTNE	;routine entry build action
-	N %,X,XPD
-	;move routine to ^XTMP("XPDT",DPK1,"RTN",routine name
-	;routines will have the checksum in XTMP("XPDT",XPDA,"RTN",X) & in
-	;Build file
-	S X=$P(^XTMP("XPDT",XPDA,"KRN",9.8,DA,0),U),XPD=^(-1)
-	Q:X=""  S %=$$LOAD(X,XPD),$P(^XPD(9.6,XPDA,"KRN",9.8,"NM",+$P(XPD,U,2),0),U,4)=%
-	K ^XTMP("XPDT",XPDA,"KRN",9.8,DA)
-	Q
-	;
-RTNF	;routine file build action
-	N X,Y,% S Y=0
-	;the routines that are left in XTMP("XPDT",XPDA,"KRN",9.8) are to be
-	;deleted at site, move name field to RTN node
-	F  S Y=$O(^XTMP("XPDT",XPDA,"KRN",9.8,Y)) Q:'Y  S %=^(Y,-1),X=^(0) D
-	.I +%=1 S ^XTMP("XPDT",XPDA,"RTN",X)=%,^("RTN")=$G(^XTMP("XPDT",XPDA,"RTN"))+1
-	;kill everything
-	K ^XTMP("XPDT",XPDA,"KRN",9.8)
-	Q
-	;
-PT(GR,DA)	;GR=file global ref, DA=ien, return .01 value
-	Q:'DA ""
-	Q:GR="" ""
-	I $D(@GR@(+DA,0))#2 Q $P(^(0),U)
-	Q ""
-	;
-GR(FN)	;returns closed global root, FN=file number
-	N Y
-	Q:'$G(FN) ""
-	S Y=$G(^DIC(FN,0,"GL")) Q:Y="" ""
-	Q $E(Y,1,($L(Y)-1))_$S($L(Y,",")>1:")",1:"")
-	;
-LOAD(X,XPD)	;load routine X, XPD=action^ien in Build file
-	;XPD = 0-load, 1-delete, 2-skip, returns checksum
-	;quit if routine is already saved
-	Q:$D(^XTMP("XPDT",XPDA,"RTN",X)) $P(^(X),U,3)
-	N DIF,XCNP,%N,%A,FDA,IEN,LN2
-	S DIF="^XTMP(""XPDT"",XPDA,""RTN"",X,",XCNP=0
-	X ^%ZOSF("LOAD")
-	S $P(^XTMP("XPDT",XPDA,"RTN",X,2,0),";",7)="Build "_(+^XPD(9.6,XPDA,6.3)),LN2=^XTMP("XPDT",XPDA,"RTN",X,2,0)
-	S IEN=$$FIND1^DIC(9.8,"","X",X)
-	;^XTMP("XPDT",XPDA,"RTN",X)=action^ien in Build^checksum
-	S %N="B"_$$SUMB^XPDRSUM($NA(^XTMP("XPDT",XPDA,"RTN",X)))
-	S $P(XPD,"^",3)=%N ;Make sure the Checksum is in the 3rd piece
-	S ^XTMP("XPDT",XPDA,"RTN",X)=XPD
-	;update count node
-	S ^("RTN")=$G(^XTMP("XPDT",XPDA,"RTN"))+1
-	N XUA,XUB S (XUA,XUB)=""
-	;Update Dev Patch field in Routine file
-	I IEN D
-	. S XUB=$P(XPDT(XPDT),U,2) S:XUB["*" $P(XUB,"*",2)=+$P(XUB,"*",2)
-	. S IEN="?+2,"_IEN_",",FDA(9.819,IEN,.01)=XUB
-	. S FDA(9.819,IEN,2)=%N,FDA(9.819,IEN,3)=$P(LN2,";",5)
-	. D UPDATE^DIE("","FDA","IEN")
-	Q %N
+XPDTA ;SFISC/RSD - Build Actions for Kernel Files ;02/14/2006
+ ;;8.0;KERNEL;**15,44,58,131,229,393**;Jul 10, 1995;Build 12
+ Q
+ ;^XTMP("XPDT",XPDA,"KRN",FILE,DA) is the global root
+ ;DA=ien in ^XTMP,XPDNM=package name, XPDA=package ien in ^XPD(9.6,
+OPT ;options
+ N %,%1,%2
+ ;if link, kill everything and just process the menu items
+ I XPDFL=2 D  G OPTT
+ .S %=0 F  S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,%)) Q:'%  K:%'=10 ^(%)
+ ;resolve Package (0;12), remove Creator (0;5)
+ S %=^XTMP("XPDT",XPDA,"KRN",19,DA,0),$P(%,U,12)=$$PT("^DIC(9.4)",$P(%,U,12)),$P(%,U,5)=""
+ ;resolve Help Frame (0;7), kill Permitted Devices (3.96;0) & queue node (200)
+ S $P(%,U,7)=$$PT("^DIC(9.2)",$P(%,U,7)),^XTMP("XPDT",XPDA,"KRN",19,DA,0)=% K ^(3.96),^(200)
+ ;resolve Server Bulletin (220;1), Server Mailgroup (220;3)
+ I $D(^XTMP("XPDT",XPDA,"KRN",19,DA,220)) S %=^(220),$P(%,U)=$$PT("^XMB(3.6)",+%),$P(%,U,3)=$$PT("^XMB(3.8)",$P(%,U,3)),^XTMP("XPDT",XPDA,"KRN",19,DA,220)=%
+ ;resolve RPC (RPC;0), must be type Broker
+ I $D(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC")) K:$P(^(0),U,4)'="B" ^("RPC") D
+ .;kill  "B"=name x-ref, it will be re-indexed when installed
+ .K ^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC","B")
+ .;loop thru RPCs and resolve (RPC;1)
+ .S %=0 F  S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%)) Q:'%  S %1=$G(^(%,0)) D
+ ..S %2=$$PT("^XWB(8994)",+%1)
+ ..;if can't resolve then delete
+ ..I %2="" K ^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%,0) Q
+ ..;save the RPC name
+ ..S $P(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%,0),U)=%2
+ .Q
+OPTT ;Menus can only exist for options of type: menu,protocol,protocol menu,
+ ;extended action, limited, window suite
+ I "LMOQXZ"'[$P(^XTMP("XPDT",XPDA,"KRN",19,DA,0),U,4) K ^(10) Q
+ ;kill  "B"=name, "C"=synonyms x-ref, it will be re-indexed when installed
+ K ^XTMP("XPDT",XPDA,"KRN",19,DA,10,"B"),^("C")
+ ;loop thru 10=Menus and resolve Menu (10;1), kill if it doesn't resolve
+ S %=0 F  S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,10,%)) Q:'%  S %1=$G(^(%,0)) D
+ .S %2=$$PT("^DIC(19)",+%1)
+ .;items must be sent by themselves, check "B" x-ref
+ .I $L(%2),$D(^XPD(9.6,XPDA,"KRN",19,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",19,DA,10,%,U)=%2 Q
+ .;if I couldn't resolve this option, then kill it
+ .K ^XTMP("XPDT",XPDA,"KRN",19,DA,10,%)
+ Q
+PRO ;protocols
+ N %,%1,%2
+ ;if link, kill everything and just process the menu items
+ I XPDFL=2 D  G PROT
+ .S %=0 F  S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,%)) Q:'%  K:%'=10 ^(%)
+ ;resolve Package (0;12), remove Creator (0;5)
+ S %=^XTMP("XPDT",XPDA,"KRN",101,DA,0),$P(%,U,12)=$$PT("^DIC(9.4)",$P(%,U,12)),$P(%,U,5)=""
+ ;kill under Menus (10), "B"=name, "C"=synonyms
+ S ^XTMP("XPDT",XPDA,"KRN",101,DA,0)=%
+ ;resolve File Link (5;1), its a variable pointer
+ S %=$P($G(^XTMP("XPDT",XPDA,"KRN",101,DA,5)),U),%1=$P(%,";",2)
+ I %,$D(@("^"_%1_+%_",0)")) S $P(^XTMP("XPDT",XPDA,"KRN",101,DA,5),U)=$P(^(0),U)_";"_%1
+ ;resolve HL7 fields, node 770
+ S %=$G(^XTMP("XPDT",XPDA,"KRN",101,DA,770)) I $L(%) D  S ^XTMP("XPDT",XPDA,"KRN",101,DA,770)=%
+ .S $P(%,U)=$$PT("^HL(771)",$P(%,U)),$P(%,U,2)=$$PT("^HL(771)",$P(%,U,2))
+ .S $P(%,U,3)=$$PT("^HL(771.2)",$P(%,U,3)),$P(%,U,11)=$$PT("^HL(771.2)",$P(%,U,11))
+ .S $P(%,U,4)=$$PT("^HL(779.001)",$P(%,U,4)),$P(%,U,7)=$$PT("^HLCS(870)",$P(%,U,7))
+ .S $P(%,U,8)=$$PT("^HL(779.003)",$P(%,U,8)),$P(%,U,9)=$$PT("^HL(779.003)",$P(%,U,9))
+ .S $P(%,U,10)=$$PT("^HL(771.5)",$P(%,U,10))
+PROT ;loop thru 10=Menus and resolve Menu (10;1), kill if it doesn't resolve
+ ;kill under Menus (10), "B"=name, "C"=synonyms
+ I $D(^XTMP("XPDT",XPDA,"KRN",101,DA,10,0)) K ^("B"),^("C")
+ S %=0 F  S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,10,%)) Q:'%  S %1=$G(^(%,0)) D
+ .;%2=.01 of Menu(protocol)
+ .S %2=$$PT("^ORD(101)",+%1)
+ .;Menu must also be sent by itself, check "B" x-ref
+ .I $L(%2),$D(^XPD(9.6,XPDA,"KRN",101,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",101,DA,10,%,U)=%2,$P(^XTMP("XPDT",XPDA,"KRN",101,DA,10,%,0),U,4)=$$PT("^ORD(101)",$P(%1,U,4)) Q
+ .K ^XTMP("XPDT",XPDA,"KRN",101,DA,10,%)
+ ;If type is Event Driver and sending Subscribers (775)
+ I $P(^XTMP("XPDT",XPDA,"KRN",101,DA,0),U,4)="E" D
+ . ;kill Menu multiple and Subscriber x-ref "B"=name
+ . K ^XTMP("XPDT",XPDA,"KRN",101,DA,10),^(775,"B")
+ . ;loop thru 775=Subscribers and resolve pointer (775;1)
+ . S %=0 F  S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,775,%)) Q:'%  S %1=$G(^(%,0)) D
+ .. ;%2=.01 of subscriber(protocol)
+ .. S %2=$$PT("^ORD(101)",+%1)
+ .. ;protocol must also be sent by itself, check "B" x-ref
+ .. I $L(%2),$D(^XPD(9.6,XPDA,"KRN",101,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",101,DA,775,%,U)=%2 Q
+ .. K ^XTMP("XPDT",XPDA,"KRN",101,DA,775,%)
+ ;quit if no Access multiple
+ Q:'$D(^XTMP("XPDT",XPDA,"KRN",101,DA,3,0))  K ^("B")
+ ;loop thru Access and resolve (3;1), kill if it doesn't resolve
+ S %=0 F  S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,3,%)) Q:'%  S %1=$G(^(%,0)) D
+ .;%2=.01 of Menu(protocol)
+ .S %2=$$PT("^DIC(19.1)",+%1)
+ .I $L(%2) S ^XTMP("XPDT",XPDA,"KRN",101,DA,3,%,0)=%2 Q
+ .K ^XTMP("XPDT",XPDA,"KRN",101,DA,3,%)
+ Q
+RTNE ;routine entry build action
+ N %,X,XPD
+ ;move routine to ^XTMP("XPDT",DPK1,"RTN",routine name
+ ;routines will have the checksum in XTMP("XPDT",XPDA,"RTN",X) & in
+ ;Build file
+ S X=$P(^XTMP("XPDT",XPDA,"KRN",9.8,DA,0),U),XPD=^(-1)
+ Q:X=""  S %=$$LOAD(X,XPD),$P(^XPD(9.6,XPDA,"KRN",9.8,"NM",+$P(XPD,U,2),0),U,4)=%
+ K ^XTMP("XPDT",XPDA,"KRN",9.8,DA)
+ Q
+RTNF ;routine file build action
+ N X,Y,% S Y=0
+ ;the routines that are left in XTMP("XPDT",XPDA,"KRN",9.8) are to be
+ ;deleted at site, move name field to RTN node
+ F  S Y=$O(^XTMP("XPDT",XPDA,"KRN",9.8,Y)) Q:'Y  S %=^(Y,-1),X=^(0) D
+ .I +%=1 S ^XTMP("XPDT",XPDA,"RTN",X)=%,^("RTN")=$G(^XTMP("XPDT",XPDA,"RTN"))+1
+ ;kill everything
+ K ^XTMP("XPDT",XPDA,"KRN",9.8)
+ Q
+PT(GR,DA) ;GR=file global ref, DA=ien, return .01 value
+ Q:'DA ""
+ I $D(@GR@(+DA,0))#2 Q $P(^(0),U)
+ Q ""
+ ;
+LOAD(X,XPD) ;load routine X, XPD=action^ien in Build file
+ ;XPD = 0-load, 1-delete, 2-skip, returns checksum
+ ;quit if routine is already saved
+ Q:$D(^XTMP("XPDT",XPDA,"RTN",X)) $P(^(X),U,3)
+ N DIF,XCNP,%N,%A,FDA,IEN,LN2
+ S DIF="^XTMP(""XPDT"",XPDA,""RTN"",X,",XCNP=0
+ X ^%ZOSF("LOAD")
+ S $P(^XTMP("XPDT",XPDA,"RTN",X,2,0),";",7)="Build "_(+^XPD(9.6,XPDA,6.3)),LN2=^XTMP("XPDT",XPDA,"RTN",X,2,0)
+ S IEN=$$FIND1^DIC(9.8,"","X",X)
+ ;^XTMP("XPDT",XPDA,"RTN",X)=action^ien in Build^checksum
+ S %N="B"_$$SUMB^XPDRSUM($NA(^XTMP("XPDT",XPDA,"RTN",X)))
+ S $P(XPD,"^",3)=%N ;Make sure the Checksum is in the 3rd piece
+ S ^XTMP("XPDT",XPDA,"RTN",X)=XPD
+ ;update count node
+ S ^("RTN")=$G(^XTMP("XPDT",XPDA,"RTN"))+1
+ N XUA,XUB S (XUA,XUB)=""
+ ;Update Dev Patch field in Routine file
+ I IEN D
+ . S XUB=$P(XPDT(XPDT),U,2) S:XUB["*" $P(XUB,"*",2)=+$P(XUB,"*",2)
+ . S IEN="?+2,"_IEN_",",FDA(9.819,IEN,.01)=XUB
+ . S FDA(9.819,IEN,2)=%N,FDA(9.819,IEN,3)=$P(LN2,";",5)
+ . D UPDATE^DIE("","FDA","IEN")
+ Q %N
Index: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDTA2.m
===================================================================
--- WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDTA2.m	(revision 613)
+++ WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDTA2.m	(revision 623)
@@ -1,52 +1,48 @@
-XPDTA2	;SFISC/RWF -  Build Actions for Kernel Files Cont. ;08/09/2001  12:36
-	;;8.0;KERNEL;**201,498**;Jul 10, 1995;Build 13
-	;Per VHA Directive 2004-038, this routine should not be modified.
-	Q
-	;^XTMP("XPDT",XPDA,"KRN",XPDFILE,DA) is the global root
-	;DA=ien in ^XTMP,XPDNM=package name, XPDA=package ien in ^XPD(9.6,
-	;
-PAR1E1	;PARAMETER file 8989.51: entry post
-	N XP,XP1,XP2,XP3,XP4,VP,PN,PT,ROOT
-	S ROOT=$NA(^XTMP("XPDT",XPDA,"KRN"))
-	D PAR51(DA) ;Handle the entry from 8989.51
-	S PT=$S($E($G(^XTV(8989.51,DA,1)))="P":$P(^(1),U,2),1:"") ;Data Type & Value - check if pointer in for loop
-	S:PT]"" PT=$S(PT:$$GR^XPDTA(PT),1:"") ;PT=file # of pointed to file from parm def.
-	;Now find any entrys in 8989.5 to transport, because we point to them
-	S XP=0,XP3=$P(^XPD(9.6,XPDA,0),U,2),VP=XP3_";DIC(9.4,",PN=$$PT^XPDTA("^DIC(9.4)",XP3)
-	Q:'XP3  ;No package file link
-	F  S XP=$O(^XTV(8989.5,"AC",DA,VP,XP)),XP1=0 Q:'XP  D  ;Instance
-	. F  S XP1=$O(^XTV(8989.5,"AC",DA,VP,XP,XP1)) Q:'XP1  D  ;entry
-	. . M ^XTMP("XPDT",XPDA,"KRN",8989.5,XP1)=^XTV(8989.5,XP1)
-	. . S XP3=^XTV(8989.5,XP1,0),XP4=$G(^(1)) ;param def.
-	. . S $P(@ROOT@(8989.5,XP1,0),U,2)=$$PT^XPDTA("^XTV(8989.51)",$P(XP3,U,2))
-	. . I PT]"",XP4>0 S $P(@ROOT@(8989.5,XP1,1),U)=$$PT^XPDTA(PT,XP4) ;Data Type pointer - resolve
-	. . Q  ;Will redo the ENT at other end.
-	Q
-	;
-PAR51(DA)	;Fix one 8989.51 entry in transport global
-	;Called from both PAR1E1 and PAR2E1
-	N XP,XP1,XP2,XP3,VP,PN,ROOT
-	S ROOT=$NA(^XTMP("XPDT",XPDA,"KRN"))
-	;Don't bring X-ref
-	K @ROOT@(8989.51,DA,30,"B"),^("AG")
-	S XP=0
-	;Entries in the file will be maintained by Toolkit patches.
-	Q
-	;
-PAR2E1	;PARAMETER file 8989.52 entry post
-	N XP1,XP2,XP3,ROOT
-	S ROOT=$NA(^XTMP("XPDT",XPDA,"KRN"))
-	;Resolve USE INSTANCE OF
-	S XP2=$P(^XTV(8989.52,DA,0),U,4),XP3="" I XP2 S XP3=$$PT^XPDTA($NA(^XTV(8989.51)),XP2)
-	I $L(XP3) S $P(@ROOT@(8989.52,DA,0),U,4)=XP3
-	;Resolve PARAMETERS
-	S XP1=0 K ^XTMP("XPDT",XPDA,"KRN",8989.52,DA,10,"B") ;Drop X-ref
-	F  S XP1=$O(^XTV(8989.52,DA,10,XP1)),XP3="" Q:'XP1  D
-	. S XP2=$P(^XTV(8989.52,DA,10,XP1,0),U,2)
-	. I XP2 S XP3=$$PT^XPDTA($NA(^XTV(8989.51)),XP2)
-	. I '$L(XP3) K @ROOT@(8989.52,DA,10,XP1)
-	. S $P(^XTMP("XPDT",XPDA,"KRN",8989.52,DA,10,XP1,0),U,2)=XP3
-	. ;Now to move the entries this points to.
-	. I '$D(@ROOT@(8989.51,XP2)) M @ROOT@(8989.51,XP2)=^XTV(8989.51,XP2) D PAR51(XP2)
-	. Q
-	Q 
+XPDTA2 ;SFISC/RWF -  Build Actions for Kernel Files Cont. ;08/09/2001  12:36
+ ;;8.0;KERNEL;**201**;Jul 10, 1995
+ Q
+ ;^XTMP("XPDT",XPDA,"KRN",XPDFILE,DA) is the global root
+ ;DA=ien in ^XTMP,XPDNM=package name, XPDA=package ien in ^XPD(9.6,
+ ;
+PAR1E1 ;PARAMETER file 8989.51: entry post
+ N XP,XP1,XP2,XP3,VP,PN,ROOT
+ S ROOT=$NA(^XTMP("XPDT",XPDA,"KRN"))
+ D PAR51(DA) ;Handle the entry from 8989.51
+ ;Now find any entrys in 8989.5 to transport, because we point to them
+ S XP=0,XP3=$P(^XPD(9.6,XPDA,0),U,2),VP=XP3_";DIC(9.4,",PN=$$PT^XPDTA("^DIC(9.4)",XP3)
+ Q:'XP3  ;No package file link
+ F  S XP=$O(^XTV(8989.5,"AC",DA,VP,XP)),XP1=0 Q:'XP  D  ;Instance
+ . F  S XP1=$O(^XTV(8989.5,"AC",DA,VP,XP,XP1)) Q:'XP1  D  ;entry
+ . . M ^XTMP("XPDT",XPDA,"KRN",8989.5,XP1)=^XTV(8989.5,XP1)
+ . . S XP3=^XTV(8989.5,XP1,0) ;param def.
+ . . S $P(@ROOT@(8989.5,XP1,0),U,2)=$$PT^XPDTA("^XTV(8989.51)",$P(XP3,U,2))
+ . . Q  ;Will redo the ENT at other end.
+ Q
+ ;
+PAR51(DA) ;Fix one 8989.51 entry in transport global
+ ;Called from both PAR1E1 and PAR2E1
+ N XP,XP1,XP2,XP3,VP,PN,ROOT
+ S ROOT=$NA(^XTMP("XPDT",XPDA,"KRN"))
+ ;Don't bring X-ref
+ K @ROOT@(8989.51,DA,30,"B"),^("AG")
+ S XP=0
+ ;Entries in the file will be maintained by Toolkit patches.
+ Q
+ ;
+PAR2E1 ;PARAMETER file 8989.52 entry post
+ N XP1,XP2,XP3,ROOT
+ S ROOT=$NA(^XTMP("XPDT",XPDA,"KRN"))
+ ;Resolve USE INSTANCE OF
+ S XP2=$P(^XTV(8989.52,DA,0),U,4),XP3="" I XP2 S XP3=$$PT^XPDTA($NA(^XTV(8989.51)),XP2)
+ I $L(XP3) S $P(@ROOT@(8989.52,DA,0),U,4)=XP3
+ ;Resolve PARAMETERS
+ S XP1=0 K ^XTMP("XPDT",XPDA,"KRN",8989.52,DA,10,"B") ;Drop X-ref
+ F  S XP1=$O(^XTV(8989.52,DA,10,XP1)),XP3="" Q:'XP1  D
+ . S XP2=$P(^XTV(8989.52,DA,10,XP1,0),U,2)
+ . I XP2 S XP3=$$PT^XPDTA($NA(^XTV(8989.51)),XP2)
+ . I '$L(XP3) K @ROOT@(8989.52,DA,10,XP1)
+ . S $P(^XTMP("XPDT",XPDA,"KRN",8989.52,DA,10,XP1,0),U,2)=XP3
+ . ;Now to move the entries this points to.
+ . I '$D(@ROOT@(8989.51,XP2)) M @ROOT@(8989.51,XP2)=^XTV(8989.51,XP2) D PAR51(XP2)
+ . Q
+ Q
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,108 +1,83 @@
-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
-	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 !,"Do you want to remove any 'Dangling Pointers' from your ",XQFL," File?  Y// " R X:$S($D(DTIME):DTIME,1:300) I '$T Q
-	W ! I X="" S X="Y"
-	I X["?" G SYNTAX
-	I X["^" S X="^" Q
-STRIP	I X'="",X'?1A.E S X=$E(X,2,256) G STRIP
-	S X=$E(X,1) I X="" G SYNTAX
-	I "Nn"[X S X="N" Q
-	I "Yy"[X W !,"PLEASE WAIT while I check this out . . . " G REMOVE
-SYNTAX	W ! I X'["?" W ?11,"I'm sorry, but I don't understand your answer. Please"
-	W !,"Enter: YES (or press the RETURN key) if you want me to remove from"
-	W !,?11,"your ",XQFL," File any pointers left over from incompletely"
-	W !,?11,"deleted ",XQFL,". If such pointers do exist and are not"
-	W !,?11,"removed, the ",XQFL," File (i.e. the menus) could become"
-	W !,?11,"messed up by an INIT."
-	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"
-	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
-	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
-	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
-	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."
-	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)
-	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
-	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
-	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
-	G P2
-PXREFS	S K=":"
-P3	S K=$O(^ORD(101,IX,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
-	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)
-	G P5
+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
+ 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 !,"Do you want to remove any 'Dangling Pointers' from your ",XQFL," File?  Y// " R X:$S($D(DTIME):DTIME,1:300) I '$T Q
+ W ! I X="" S X="Y"
+ I X["?" G SYNTAX
+ I X["^" S X="^" Q
+STRIP I X'="",X'?1A.E S X=$E(X,2,256) G STRIP
+ S X=$E(X,1) I X="" G SYNTAX
+ I "Nn"[X S X="N" Q
+ I "Yy"[X W !,"PLEASE WAIT while I check this out . . . " G REMOVE
+SYNTAX W ! I X'["?" W ?11,"I'm sorry, but I don't understand your answer. Please"
+ W !,"Enter: YES (or press the RETURN key) if you want me to remove from"
+ W !,?11,"your ",XQFL," File any pointers left over from incompletely"
+ W !,?11,"deleted ",XQFL,". If such pointers do exist and are not"
+ W !,?11,"removed, the ",XQFL," File (i.e. the menus) could become"
+ W !,?11,"messed up by an INIT."
+ W !!,"Enter:  NO or ^ to continue on without effecting the ",XQFL," File."
+ W ! G ENASK
+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
+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
+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
+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
+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
+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)
+ 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,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,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,I,10,K)) I K="" G P1 ;Loop through cross references
+ S L=-1
+P4 S L=$O(^ORD(101,I,10,K,L)) I L="" G P3
+ S J=0
+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
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,102 +1,95 @@
-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
-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)
-	S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0) G:DUZ0 DIP1 S DIC("S")="I 1 Q:'$D(^DIC(+$P(^(0),U,4),0,""RD""))  F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q"
-DIP1	;
-	D:$G(DUZ0) PRNT
-	D ^DIC K DIC G:Y<0&(DUZ(0)'="@") Q G:Y<0&(DUZ0) Q1 S XQDIC=+$P(Y(0),U,4) G:XQDIC'>1 Q S XQ=$P(^DIC(XQDIC,0),U,1)_U_XQDIC,XQ(63)="["_$P(Y,U,2)_"]",XQ(60)=$P(^(0,"GL"),U,2),XQ(62)=0
-BY	;
-	D:$G(DUZ0) SORT
-	K DIC S DIC=.401,DIC(0)="AEQMZ" I $D(^DIC(19,DA,64)),^(64)?1"[".E1"]" S DIC("B")=$E(^(64),2,$L(^(64))-1)
-	S DIC("S")="I $P(^(0),U,4)=XQDIC" G:DUZ0 BY1 S DIC("S")=DIC("S")_" Q:'$D(^DIC(+$P(^(0),U,4),0,""RD""))  F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q"
-BY1	;
-	D ^DIC K DIC G TEM:X="",Q:Y<0 S XQDIC=+$P(Y(0),U,4),XQ=$P(^DIC(XQDIC,0),U,1)_U_XQDIC,XQ(64)="["_$P(Y,U,2)_"]" G FR
-TEM	;
-	I +X=X,'$D(^DD(+$P(XQ,U,2),X,0)) W *7,"NO SUCH FIELD NUMBER" K X G BY
-	S XQ(64)=X
-FR	K X S Y=$S($D(^DIC(19,DA,65)):^(65),1:"") W !,"START WITH: ",$S(Y]"":Y,1:"FIRST")_"// " R X:DTIME G:X=U Q S:X="" X=Y W:X="?" !?4,"ENTER IN 'FR' FORMAT" G:X="?" FR K:X="@" X,^DIC(19,DA,65) W:'$D(X) *7,"   DELETED!" S:$D(X) XQ(65)=X
-TO	K X S Y=$S($D(^DIC(19,DA,66)):^(66),1:"") W !,"GO TO: ",$S(Y]"":Y,1:"LAST")_"// " R X:DTIME G:X=U Q S:X="" X=Y W:X="?" !?4,"ENTER IN 'TO' FORMAT" G:X="?" TO K:X="@" X,^DIC(19,DA,66) W:'$D(X) *7,"   DELETED!" S:$D(X) XQ(66)=X
-	D PUT G Q1
-DIE	;
-	S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0)
-	K DIC,XQ S DIC=.402,DIC(0)="AQEMZ" I $D(^DIC(19,DA,51)),^(51)?1"[".E1"]" S DIC("B")=$E(^(51),2,$L(^(51))-1)
-	G:DUZ0 DIE1 S DIC("S")="I 1 Q:'$D(^DIC(+$P(^(0),U,4),0,""WR""))  F %=1:1:$L(^(""WR"")) I DUZ(0)[$E(^(""WR""),%) Q"
-DIE1	;
-	D ^DIC K DIC G:Y<0&(DUZ(0)'="@") Q G:Y<0&(DUZ0) Q1 S XQDIC="",XQDIC=+$P(Y(0),U,4) G:'XQDIC Q S XQ(51)="["_$P(Y,U,2)_"]" D DIC S XQ(50)=XQ(30) D PUT G Q1
-PUT	S X=0 F  S X=$O(XQ(X)) Q:X'>0  S ^DIC(19,DA,X)=XQ(X)
-	Q
-	;
-Q	W *7,!,"NO CHANGE MADE TO OPTION LOGIC"
-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"
-	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")
-A	Q
-	;
-DIQ	;
-	S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0)
-	K DIC,XQ S DIC=1,DIC(0)="AEQMZ",DIC("A")="INQUIRE TO WHAT FILE: "
-	I $D(^DIC(19,DA,30)),^(30)["(",@("$D(^"_^(30)_"0))") S DIC("B")=+$P(^(0),U,2)
-	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
-	;
-NAME	;
-	I $E(X,1)="A"!($E(X,1)="Z") S %=1,%1="Local" Q
-	F %=4:-1:2 G:$D(^DIC(9.4,"C",$E(X,1,%))) NAMEOK
-	I 0
-	Q
-NAMEOK	S %1=$O(^DIC(9.4,"C",$E(X,1,%),0)) S:%1="" %1=-1 S:$D(^DIC(9.4,%1,0)) %1=$P(^(0),U,1),XQPK=%1 I 1 Q
-	;
-CHKNAME	;Called from the input transform of the .01 field of the Option File
-	Q:$D(DIFROM)!($D(ZTQUEUED))  K XQPK
-	I $D(DIC(0))#2,DIC(0)'["E" Q
-	D NAME E  D EN^DDIOL("Not a known package or a local namespace.") Q
-	D EN^DDIOL("  Located in the "_$E(X,1,%)_" ("_%1_") namespace.") Q
-	;
-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 !,"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 ?40,"L.: "_$$GET1^DIQ(19,DA,62)
-	W !,?5,"FLDS: "_$$GET1^DIQ(19,DA,63)
-	W ?40,"BY: "_$$GET1^DIQ(19,DA,64)
-	W !,?5,"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 !,"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 ?40,"TO: "_$$GET1^DIQ(19,DA,66),!!
-	Q
-TEST	W !,"Enter a name, and the computer will respond with the namespace to which",!,"that name belongs.  It does this by looking at the package file.",!!
-T1	R !,"NAME: ",X:DTIME,"  " Q:X=""  D CHKNAME G T1
-CLEAR	;Clear fields not used by this option.
-	I "EMPRSOQ"[X X "F %="_$S("M"[X:"25,27:1:82","QO"[X:"25,31:1:82","RS"[X:"10,30:1:82","E"[X:"10,25,60:1:82","P"[X:"10,25,27:1:54,80:1:82")_" I $D(^DIC(19,DA,%)) D:%=10 CLEAR1 K ^DIC(19,DA,%)"
-	I "AI"[X X "F %="_$S("A"[X:"10,25,30:1:82","I"[X:"10,25,36:1:62,64:1:73")_" I $D(^DIC(19,DA,%)) D:%=10 CLEAR1 K ^DIC(19,DA,%)"
-	I "OQ"'[X F %=100,100.1,100.2 I $D(^DIC(19,DA,%)) K ^DIC(19,DA,%)
-	Q
-CLEAR1	S XQI=0 F  S XQI=$O(^DIC(19,DA,%,XQI)) Q:XQI'>0  S XQJ=$P(^(XQI,0),U) K ^DIC(19,"AD",$E(XQJ,1,30),DA,XQI)
-	K XQI,XQJ
-	Q
+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)
+ S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0) G:DUZ0 DIP1 S DIC("S")="I 1 Q:'$D(^DIC(+$P(^(0),U,4),0,""RD""))  F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q"
+DIP1 ;
+ D:$G(DUZ0) PRNT
+ D ^DIC K DIC G:Y<0&(DUZ(0)'="@") Q G:Y<0&(DUZ0) Q1 S XQDIC=+$P(Y(0),U,4) G:XQDIC'>1 Q S XQ=$P(^DIC(XQDIC,0),U,1)_U_XQDIC,XQ(63)="["_$P(Y,U,2)_"]",XQ(60)=$P(^(0,"GL"),U,2),XQ(62)=0
+BY ;
+ D:$G(DUZ0) SORT
+ K DIC S DIC=.401,DIC(0)="AEQMZ" I $D(^DIC(19,DA,64)),^(64)?1"[".E1"]" S DIC("B")=$E(^(64),2,$L(^(64))-1)
+ S DIC("S")="I $P(^(0),U,4)=XQDIC" G:DUZ0 BY1 S DIC("S")=DIC("S")_" Q:'$D(^DIC(+$P(^(0),U,4),0,""RD""))  F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q"
+BY1 ;
+ D ^DIC K DIC G TEM:X="",Q:Y<0 S XQDIC=+$P(Y(0),U,4),XQ=$P(^DIC(XQDIC,0),U,1)_U_XQDIC,XQ(64)="["_$P(Y,U,2)_"]" G FR
+TEM ;
+ I +X=X,'$D(^DD(+$P(XQ,U,2),X,0)) W *7,"NO SUCH FIELD NUMBER" K X G BY
+ S XQ(64)=X
+FR K X S Y=$S($D(^DIC(19,DA,65)):^(65),1:"") W !,"START WITH: ",$S(Y]"":Y,1:"FIRST")_"// " R X:DTIME G:X=U Q S:X="" X=Y W:X="?" !?4,"ENTER IN 'FR' FORMAT" G:X="?" FR K:X="@" X,^DIC(19,DA,65) W:'$D(X) *7,"   DELETED!" S:$D(X) XQ(65)=X
+TO K X S Y=$S($D(^DIC(19,DA,66)):^(66),1:"") W !,"GO TO: ",$S(Y]"":Y,1:"LAST")_"// " R X:DTIME G:X=U Q S:X="" X=Y W:X="?" !?4,"ENTER IN 'TO' FORMAT" G:X="?" TO K:X="@" X,^DIC(19,DA,66) W:'$D(X) *7,"   DELETED!" S:$D(X) XQ(66)=X
+ D PUT G Q1
+DIE ;
+ S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0)
+ K DIC,XQ S DIC=.402,DIC(0)="AQEMZ" I $D(^DIC(19,DA,51)),^(51)?1"[".E1"]" S DIC("B")=$E(^(51),2,$L(^(51))-1)
+ G:DUZ0 DIE1 S DIC("S")="I 1 Q:'$D(^DIC(+$P(^(0),U,4),0,""WR""))  F %=1:1:$L(^(""WR"")) I DUZ(0)[$E(^(""WR""),%) Q"
+DIE1 ;
+ D ^DIC K DIC G:Y<0&(DUZ(0)'="@") Q G:Y<0&(DUZ0) Q1 S XQDIC="",XQDIC=+$P(Y(0),U,4) G:'XQDIC Q S XQ(51)="["_$P(Y,U,2)_"]" D DIC S XQ(50)=XQ(30) D PUT G Q1
+PUT S X=0 F  S X=$O(XQ(X)) Q:X'>0  S ^DIC(19,DA,X)=XQ(X)
+ Q
+ ;
+Q W *7,!,"NO CHANGE MADE TO OPTION LOGIC"
+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),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($D(^DIC(19,DA,31)):^(31)'["L"+1,1:0) D YN^DICN I %=1 S XQ(31)="AEMQL"
+A Q
+ ;
+DIQ ;
+ S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0)
+ K DIC,XQ S DIC=1,DIC(0)="AEQMZ",DIC("A")="INQUIRE TO WHAT FILE: "
+ I $D(^DIC(19,DA,30)),^(30)["(",@("$D(^"_^(30)_"0))") S DIC("B")=+$P(^(0),U,2)
+ 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(31)="AEMQ",(XQ(80),XQ(30))=$P(^(0,"GL"),U,2) D PUT G Q1
+ ;
+NAME ;
+ I $E(X,1)="A"!($E(X,1)="Z") S %=1,%1="Local" Q
+ F %=4:-1:2 G:$D(^DIC(9.4,"C",$E(X,1,%))) NAMEOK
+ I 0
+ Q
+NAMEOK S %1=$O(^DIC(9.4,"C",$E(X,1,%),0)) S:%1="" %1=-1 S:$D(^DIC(9.4,%1,0)) %1=$P(^(0),U,1),XQPK=%1 I 1 Q
+ ;
+CHKNAME ;Called from the input transform of the .01 field of the Option File
+ Q:$D(DIFROM)!($D(ZTQUEUED))  K XQPK
+ I $D(DIC(0))#2,DIC(0)'["E" Q
+ D NAME E  D EN^DDIOL("Not a known package or a local namespace.") Q
+ D EN^DDIOL("  Located in the "_$E(X,1,%)_" ("_%1_") namespace.") Q
+ ;
+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 !,"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 !,?17,"DIC {DIP}: "_$$GET1^DIQ(19,DA,60)
+ W ?40,"L.: "_$$GET1^DIQ(19,DA,62)
+ W !,?17,"FLDS: "_$$GET1^DIQ(19,DA,63)
+ W ?40,"BY: "_$$GET1^DIQ(19,DA,64)
+ 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 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 ?17,"BY: "_$$GET1^DIQ(19,DA,64)
+ W !,?17,"FR: "_$$GET1^DIQ(19,DA,65)
+ W ?40,"TO: "_$$GET1^DIQ(19,DA,66),!!
+ Q
+TEST W !,"Enter a name, and the computer will respond with the namespace to which",!,"that name belongs.  It does this by looking at the package file.",!!
+T1 R !,"NAME: ",X:DTIME,"  " Q:X=""  D CHKNAME G T1
+CLEAR ;Clear fields not used by this option.
+ I "EMPRSOQ"[X X "F %="_$S("M"[X:"25,27:1:82","QO"[X:"25,31:1:82","RS"[X:"10,30:1:82","E"[X:"10,25,60:1:82","P"[X:"10,25,27:1:54,80:1:82")_" I $D(^DIC(19,DA,%)) D:%=10 CLEAR1 K ^DIC(19,DA,%)"
+ I "AI"[X X "F %="_$S("A"[X:"10,25,30:1:82","I"[X:"10,25,36:1:62,64:1:73")_" I $D(^DIC(19,DA,%)) D:%=10 CLEAR1 K ^DIC(19,DA,%)"
+ I "OQ"'[X F %=100,100.1,100.2 I $D(^DIC(19,DA,%)) K ^DIC(19,DA,%)
+ Q
+CLEAR1 S XQI=0 F  S XQI=$O(^DIC(19,DA,%,XQI)) Q:XQI'>0  S XQJ=$P(^(XQI,0),U) K ^DIC(19,"AD",$E(XQJ,1,30),DA,XQI)
+ K XQI,XQJ
+ Q
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,112 +1,90 @@
-XQ55	; SEA/AMF,MJM,JLI - SEARCH FOR USERS ACCESS TO AN OPTION;
-	;;8.0;KERNEL;**140,342,483,508**;Jul 10, 1995;Build 1
-	;;Per VHA Directive 2004-038, this routine should not be modified
-INIT	;
-	S XQDSH="-------------------------------------------------------------------------------"
-	D ^XQDATE S XQDT=%Y
-OPT	W ! S DIC=19,DIC(0)="AEQM" D ^DIC G:Y=-1 OUT S XQOPT=+Y
-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
-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
-	Q
-TREE	S X(L)=$O(^DIC(19,"AD",XQD,X(L))) Q:X(L)'>0  S K=X(L) G:$D(XQR(K)) TREE S XQR(K)=""
-TREE1	;
-	S Y(0)=^DIC(19,K,0) G:$L($P(Y(0),U,3)) TREE S:$L($P(Y(0),U,6)) XQK(L)=$P(Y(0),U,6) S XQA(L)=K I $P(Y(0),U,16) S XQRV(L)=^DIC(19,K,3)
-	D SETGLO S L=L+1,X(L)=0,(XQD,XQD(L))=K D TREE
-	Q:L=1  K XQR(XQD(L)) S L=L-1 K XQA(L),XQK(L),XQRV(L) S XQD=XQD(L) G TREE
-	Q
-SETGLO	;
-	S XQK="" F I=L:-1:0 I $D(XQK(I)),$L(XQK(I)) S XQK=XQK_XQK(I)_","
-	S XQRV="" F I=L:-1:0 I $D(XQRV(I)),$L(XQRV(I)) S XQRV=XQRV_XQRV(I)_","
-	S XQA="" F I=L:-1:1 I $D(XQA(I)) S XQA=XQA_XQA(I)_","
-	S XQA=XQA_XQOPT,J=0 S:$D(^TMP($J,K,0)) J=^(0) S J=J+1,^(0)=J,^TMP($J,K,J)=XQK_U_XQA_U_XQRV
-	Q
-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
-	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 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
-LOOP3	;
-	I $O(^TMP($J,0,0))="" W !!,"** NO USERS CAN ACCESS THIS OPTION **" G OUT
-	S %ZIS="MFQ" D ^%ZIS G OUT:POP I $D(IO("Q")) K IO("Q") S ZTRTN="DQ^XQ55",ZTDESC="OPTION ACCESS BY USER",ZTSAVE("XQ*")="",ZTSAVE("^TMP($J,")="" D ^%ZTLOAD K ZTSK,ZTRTN,ZTSAVE,ZTDESC G OUT
-	;
-DQ	;Entry point for queued job
-	U IO
-	S:'XQMP XQPA(0)=-4 S XQPG=0,XQUI=0 D NEWPG G:XQUI MUS
-	S XQU=0 F  S XQU=$O(^TMP($J,0,XQU)) Q:XQU=""  D PRTU G:XQUI MUS
-	D:XQMP MENUPAT G MUS
-NEWPG	;
-	S X="" I XQPG,$E(IOST,1)="C" D CON S XQUI=(X="^") Q:XQUI
-	D HDR Q
-CON	;
-	W !!,"Press return to continue or '^' to escape " R X:DTIME S:'$T X=U
-	Q
-HDR	;
-	W @IOF S XQPG=XQPG+1
-	W "Page ",XQPG,?62,XQDT,!! S XQTAB=(76-$L(XQHDR))/2 W ?XQTAB,XQHDR
-	W !!,"USER NAME",?27,"LAST ON",?37,"PRIMARY MENU" W:XQMP ?63,"PATH(S)"
-	W !,$E(XQDSH,1,25),?27,$E(XQDSH,1,8),?37,$E(XQDSH,1,$S(XQMP:24,1:40)) W:XQMP ?63,$E(XQDSH,1,14)
-	Q
-PRTU	;
-	I $Y>(IOSL-XQPA(0)-8) D:XQMP MENUPAT D NEWPG Q:XQUI
-	S J=$P(XQU,U,2),K="" S:$D(^VA(200,J,1.1)) K=$P(^(1.1),"^") S:$L(K) K=$E(K,4,5)_"/"_$E(K,6,7)_"/"_$E(K,2,3) W !,$E($P(XQU,U,1),1,27),?27,K
-	I $D(^VA(200,J,201)) S K=+^(201) I K>0,$D(^DIC(19,K,0)) W ?37,$E($P(^(0),U,1),1,24)
-	I XQMP D
-	.W ?63,""
-	.S JJ=$O(^TMP($J,0,XQU,"A"),-1)
-	.F II=1:1:JJ W $G(^TMP($J,0,XQU,II)) I II'=JJ W ","
-	I 'XQMP D
-	.S II=0 F  S II=$O(^TMP($J,0,XQU,II)) Q:II'>0  D
-	..I ^TMP($J,0,XQU,II)["(S)" W "  (Secondary menu)" S II="A"
-	Q
-MENUPAT	;
-	W !!,$E(XQDSH,1,27),"     MENU PATH(S)     ",$E(XQDSH,1,29),!
-	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 $G(XQPG),$E(IOST,1)="C" W !!,"Press return when finished viewing " R X:DTIME W @IOF G OUT
-	I $D(ZTSK) K ^%ZTSK(ZTSK)
-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)
-	Q
+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="-------------------------------------------------------------------------------"
+ D ^XQDATE S XQDT=%Y
+OPT W ! S DIC=19,DIC(0)="AEQM" D ^DIC G:Y=-1 OUT S XQOPT=+Y
+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
+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
+ Q
+TREE S X(L)=$O(^DIC(19,"AD",XQD,X(L))) Q:X(L)'>0  S K=X(L) G:$D(XQR(K)) TREE S XQR(K)=""
+TREE1 ;
+ S Y(0)=^DIC(19,K,0) G:$L($P(Y(0),U,3)) TREE S:$L($P(Y(0),U,6)) XQK(L)=$P(Y(0),U,6) S XQA(L)=K I $P(Y(0),U,16) S XQRV(L)=^DIC(19,K,3)
+ D SETGLO S L=L+1,X(L)=0,(XQD,XQD(L))=K D TREE
+ Q:L=1  K XQR(XQD(L)) S L=L-1 K XQA(L),XQK(L),XQRV(L) S XQD=XQD(L) G TREE
+ Q
+SETGLO ;
+ S XQK="" F I=L:-1:0 I $D(XQK(I)),$L(XQK(I)) S XQK=XQK_XQK(I)_","
+ S XQRV="" F I=L:-1:0 I $D(XQRV(I)),$L(XQRV(I)) S XQRV=XQRV_XQRV(I)_","
+ S XQA="" F I=L:-1:1 I $D(XQA(I)) S XQA=XQA_XQA(I)_","
+ S XQA=XQA_XQOPT,J=0 S:$D(^TMP($J,K,0)) J=^(0) S J=J+1,^(0)=J,^TMP($J,K,J)=XQK_U_XQA_U_XQRV
+ Q
+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
+ 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
+EACHU ;
+ S II=1
+ 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
+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 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
+LOOP3 ;
+ I $O(^TMP($J,0,0))="" W !!,"** NO USERS CAN ACCESS THIS OPTION **" G OUT
+ S %ZIS="MFQ" D ^%ZIS G OUT:POP I $D(IO("Q")) K IO("Q") S ZTRTN="DQ^XQ55",ZTDESC="OPTION ACCESS BY USER",ZTSAVE("XQ*")="",ZTSAVE("^TMP($J,")="" D ^%ZTLOAD K ZTSK,ZTRTN,ZTSAVE,ZTDESC G OUT
+ ;
+DQ ;Entry point for queued job
+ U IO
+ S:'XQMP XQPA(0)=-4 S XQPG=0,XQUI=0 D NEWPG G:XQUI MUS
+ S XQU=0 F  S XQU=$O(^TMP($J,0,XQU)) Q:XQU=""  D PRTU G:XQUI MUS
+ D:XQMP MENUPAT G MUS
+NEWPG ;
+ S X="" I XQPG,$E(IOST,1)="C" D CON S XQUI=(X="^") Q:XQUI
+ D HDR Q
+CON ;
+ W !!,"Press return to continue or '^' to escape " R X:DTIME S:'$T X=U
+ Q
+HDR ;
+ W @IOF S XQPG=XQPG+1
+ W "Page ",XQPG,?62,XQDT,!! S XQTAB=(76-$L(XQHDR))/2 W ?XQTAB,XQHDR
+ W !!,"USER NAME",?27,"LAST ON",?37,"PRIMARY MENU" W:XQMP ?63,"PATH(S)"
+ W !,$E(XQDSH,1,25),?27,$E(XQDSH,1,8),?37,$E(XQDSH,1,$S(XQMP:24,1:40)) W:XQMP ?63,$E(XQDSH,1,14)
+ Q
+PRTU ;
+ I $Y>(IOSL-XQPA(0)-8) D:XQMP MENUPAT D NEWPG Q:XQUI
+ S J=$P(XQU,U,2),K="" S:$D(^VA(200,J,1.1)) K=$P(^(1.1),"^") S:$L(K) K=$E(K,4,5)_"/"_$E(K,6,7)_"/"_$E(K,2,3) W !,$E($P(XQU,U,1),1,27),?27,K
+ I $D(^VA(200,J,201)) S K=+^(201) I K>0,$D(^DIC(19,K,0)) W ?37,$E($P(^(0),U,1),1,24)
+ I XQMP D
+ .W ?63,""
+ .S JJ=$O(^TMP($J,0,XQU,"A"),-1)
+ .F II=1:1:JJ W $G(^TMP($J,0,XQU,II)) I II'=JJ W ","
+ I 'XQMP D
+ .S II=0 F  S II=$O(^TMP($J,0,XQU,II)) Q:II'>0  D
+ ..I ^TMP($J,0,XQU,II)["(S)" W "  (Secondary menu)" S II="A"
+ Q
+MENUPAT ;
+ W !!,$E(XQDSH,1,27),"     MENU PATH(S)     ",$E(XQDSH,1,29),!
+ 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"
+ Q
+MUS G:X="^" OUT I XQPG,$E(IOST,1)="C" W !!,"Press return when finished viewing " R X:DTIME W @IOF G OUT
+ I $D(ZTSK) K ^%ZTSK(ZTSK)
+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 I $D(ZTQUEUED),$D(ZTSK),ZTSK>0 K ^%ZTSK(ZTSK)
+ Q
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,256 +1,252 @@
-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
-BUILD	;
-	;
-RD2	N XQSTAT S XQSTAT=$$STATUS()
-	I 'XQSTAT W !!,"Some one else is rebuilding menus.  Sorry." Q
-	K ZTSK
-	D MICRO ;Turn off micro surgery for now
-	;
-	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 ZTRTN="QUE^XQ81",ZTIO=""
-	.S ZTSAVE("XQVE")="",ZTSAVE("XQBSEC")="",ZTSAVE("XQSTART")=""
-	.S ZTDESC="Build menu trees in ^DIC(19,""AXQ"")"
-	.D ^%ZTLOAD
-	.I $D(ZTSK),'XQVE W !!,"Task #: ",ZTSK,!
-	.Q
-	;
-	I $D(ZTSK) K ^DIC(19,"AXQ","P0") S XQALLDON="" G BLDEND
-	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
-	;
-KIDS	;Entry from KIDS
-	I '$D(XQSTAT),$D(^DIC(19,"AXQ","P0")) S XQSTAT=$$STATUS I 'XQSTAT W !!,"  Some one else is building menus.  Sorry." K XQSTAT Q
-	I '$D(^DIC(19,"AXQ","P0","STOP")) D MICRO
-	I '$D(^DIC(19,"AXQ","P0")) S ^DIC(19,"AXQ","P0")=$H L +^DIC(19,"AXQ","P0")
-	I '$D(XQVE) S XQFG=0,XQBSEC=1,XQVE=0
-	N XQNTREE,XQNDONE S (XQNTREE,XQNDONE)=0
-	;
-	;Set up the error trap so we can clear the screen if it blows
-	I $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^XQ81"
-	E  S X="ERR^XQ81",@^%ZOSF("TRAP")
-	;
-	;Set up the bar graph and window if not from KIDS
-	I '$D(XPDNM) D INIT^XPDID
-	I XPDIDVT D
-	.I $D(XPDIDTOT) S XQSAVTOT=XPDIDTOT
-	.S X="Rebuilding Menus" D TITLE^XPDID(X)
-	.S XPDIDTOT=50 ;Number of divisions in bar graph
-	.D UPDATE^XPDID(0)
-	.Q
-	;
-	S XQSTART=$$HTE^XLFDT($H)
-	W !!,"Starting Menu Rebuild:  ",XQSTART
-	S XQFG=0 W !!,"Collecting primary menus in the New Person file..."
-	;
-DQ	;Entry from taskman  Write if $D(XQFG)
-	K ZTREQ
-	I '$D(XQSTART) S XQSTART=$$HTE^XLFDT($H)
-	N XQNOW,XQ8FLG,XQTASK
-	S XQ8FLG=0
-	S:'$D(XQNOW) XQNOW=$H
-	S ^DIC(19,"AXQ","P0")=XQNOW
-	S ^DIC(19,"AXQ","P0","STOP")=XQNOW ;Stop micro surgery if it's running
-	;
-	S XQSEC=1,XQ81T="" I 'XQVE H 1
-	S XQI="" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:XQI'=+XQI!(XQI="")  I $D(^TMP("XQO",$J,XQI,0))#2 S $P(^(0),U,2)=""
-	S XQI="U" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:"U"'[$E(XQI)!(XQI="")  I $D(^TMP("XQO",$J,XQI,0))#2 S $P(^(0),U,2)=""
-	S XQI="P" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:"P"'[$E(XQI)!(XQI="")  I $D(^TMP("XQO",$J,XQI,0))#2,$L(^(0)) S XQ81T=^(0) Q
-	S:XQ81T="" XQ81T="Unknown"
-	S XQI="P" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:"P"'[$E(XQI)!(XQI="")  I "P"[$E(XQI),XQI'="P0" K ^TMP("XQO",$J,XQI)
-	;
-	;Find the various trees and put them into ^TMP($J), and count them
-	S:'$D(XQH) XQH=$H K ^TMP($J) S XQI=.5 F XQK=0:0 S XQI=$O(^VA(200,XQI)) Q:XQI'=+XQI  I $D(^VA(200,XQI,0)),$L($P(^VA(200,XQI,0),U,3)) D SET
-	;
-	S (XQNTREE,%)=0 F  S %=$O(^TMP($J,%)) Q:%=""  S XQNTREE=XQNTREE+1
-	S %=0 F  S %=$O(^TMP($J,"SEC",%)) Q:%=""  S XQNTREE=XQNTREE+1
-	;
-	W:$D(XQFG) !!?20,"Primary menus found in the New Person file",!?20,"------------------------------------------"
-	W:$D(XQFG) !!,"OPTION NAME         MENU TEXT",?49,"# OF",?62,"LAST",?71,"LAST",!?49,"USERS",?62,"USED",?71,"BUILT",!
-	S X="" F XQBLD=0:0 S XQBLD=$O(^TMP($J,XQBLD)) Q:XQBLD'>0!(X=U)  I $D(^DIC(19,XQBLD,0)) S XQJ=^DIC(19,XQBLD,0) D VER
-	S XQSEC=0 I $D(XQFG),XQBSEC W !!,"Building secondary menu trees...."
-	I XQBSEC S X="" F XQBLD=0:0 S XQBLD=$O(^TMP($J,"SEC",XQBLD)) Q:XQBLD'>0  D SEC
-	I 'XQVE S XQK="P" F XQBLD=0:0 S XQK=$O(^TMP("XQO",$J,XQK)) Q:XQK'["P"  S ^(XQK,0)=XQH
-	G BLDEND
-	;
-SEC	S XQL="P"_XQBLD Q:$D(^TMP("XQO",$J,XQL))  D RD3 Q
-	S XQL="P" F XQN=0:0 S XQL=$O(^TMP("XQO",$J,XQL)) Q:$E(XQL)'="P"  I $D(^TMP("XQO",$J,XQL,"^",XQBLD)) Q
-	D:$E(XQL)'="P" RD3
-	Q
-	;
-VER	I $D(XQFG) D
-	.N XQMT,XQOPNM
-	.S XQK=$P(^TMP($J,XQBLD),U,2)
-	.S:$L(XQK) XQK=$E(XQK,4,5)_"/"_$E(XQK,6,7)_"/"_$E(XQK,2,3)
-	.S XQOPNM=$P(XQJ,U)
-	.S XQMT=$P(XQJ,U,2) I $L(XQMT)>28 S XQMT=$E(XQMT,1,25)_"..."
-	.W !,$P(XQJ,U,1)
-	.W:($L(XQOPNM)>20) !
-	.W ?20,XQMT,?49,+^TMP($J,XQBLD),?60,XQK
-	.Q
-	;
-	I $D(XQFG) S:$D(^DIC(19,"AXQ","P"_XQBLD,0)) XQ81T=+^(0) I $L(XQ81T) S %H=XQ81T D YMD^%DTC S XQK=X W ?71,$E(XQK,4,5),"/",$E(XQK,6,7),"/",$E(XQK,2,3)
-	;
-RD3	;Update counter an rebuild it if necessary
-	I $D(XQFG),XPDIDVT D
-	.N %
-	.S XQNDONE=XQNDONE+1
-	.S %=(XQNDONE/XQNTREE)*XPDIDTOT
-	.D UPDATE^XPDID(%)
-	.Q
-	;
-	S XQDIC="P"_XQBLD D CHK^XQ8 I XQRE W:$D(XQFG) !,"SOMEONE ELSE IS CURRENTLY REBUILDING THIS MENU" Q
-	I XQVE,XQSEC S DIR(0)="Y",DIR("A")="Rebuild",DIR("B")="YES" D ^DIR Q:$D(DIRUT)  W ! Q:Y'=1
-	S XQFG1=1 D PM2^XQ8
-	I $D(ZTQUEUED) S ZTREQ="@"
-	Q
-	;
-SET	G:'$D(^VA(200,XQI,201)) SET1 S XQK=+^(201) Q:'$L(XQK)  ;I $D(XQFG) W:'(XQI#10) "."
-	S XQR="" S:$D(^VA(200,XQI,1.1)) XQR=$P(^(1.1),".",1) S XQP=1_U_XQR
-	I $D(^TMP($J,XQK)) S XQP=^TMP($J,XQK) S XQP=XQP+1_U_$S(XQR>$P(XQP,U,2):XQR,1:$P(XQP,U,2))
-	I $D(^DIC(19,XQK,0)),$P(^(0),U,4)="M" S ^TMP($J,XQK)=XQP
-	;
-SET1	I XQBSEC F XQN=0:0 S XQN=$O(^VA(200,XQI,203,XQN)) Q:XQN'>0  S XQL=+^(XQN,0) I $D(^DIC(19,XQL,0)),$P(^(0),U,4)="M" S ^TMP($J,"SEC",XQL)=""
-	Q
-	;
-QUE	;Entry point for the option XQBUILDTREEQUE, and XQBUILDALL
-	;Also called by CHEK^XQ83
-	S XQVE=0,XQBSEC=1 K XQFG
-	S XQSTART=$$HTE^XLFDT($H)
-	G DQ
-	;
-BLDEND	;File a report, cleanup, and quit.
-	;
-	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
-	;
-	I $D(XQALLDON) K XQALLDON Q  ;Quit here if we're just creating a task
-	;
-	D MERGET
-	D CLEAN
-	D MERGEX
-	;
-	K ^TMP($J),^TMP("XQO",$J)
-	;
-	;Clear the flags and locks.
-	K ^XUTL("XQMERGED") ;Menues merged since last rebuild REACT^XQ84
-	K ^DIC(19,"AT") ;Micro message nodes
-	S ^XUTL("XQ","MICRO")=0 ;Number of Micro instances since last build
-	K ^DIC(19,"AXQ","P0","STOP") ;Allow Micro surgery to start up
-	K ^DIC(19,"AXQ","P0") ;Clear the rebuild flag (redundant, I know)
-	L -^DIC(19,"AXQ","P0") ;Unlock the rebuild flag, everybody's good to go
-	;
-	S %=$S($D(XPDNM):"KIDS",$D(ZTSK):"QUEUED",1:"LIVE")
-	D REPORT^XQ84(%)
-	K XQSTART,ZTSK
-	;
-	I '$D(XPDIDVT) K XQFG Q
-	;
-	I $D(XQFG),XPDIDVT F %=((XQNDONE/XQNTREE)*XPDIDTOT):1:XPDIDTOT D UPDATE^XPDID(%) H .25
-	I $D(XQFG),XPDIDVT D UPDATE^XPDID(XPDIDTOT)
-	I $D(XQFG) W !!,"Menu Rebuild Complete:  ",$$HTE^XLFDT($H)
-	;
-	;
-	H 2
-	;If we're not from KIDS then clean it up, otherwise let kids do it.
-	I '$D(XPDNM) D
-	.D EXIT^XPDID()
-	.K XPDIDVT,XPDIDTOT
-	.Q
-	;
-	I $D(XQSAVTOT) S XPDIDTOT=XQSAVTOT
-	K %,VALMCOFF,VALMCON,VALMIOXY,VALMSGR,VALMWD,XQFG,XQNDONE,XQNTREE,XQSAVTOT
-	Q
-	;
-	;================================Subroutines==========================
-	;
-MERGET	;Merge ^TMP("XQO",$J) into ^DIC(19,"AXQ")
-	N Q,X,XQFLAG,Y S X="P",XQFLAG=0,Q=""""
-	I $D(XQFG) W !!,"Merging...."
-	F  S X=$O(^TMP("XQO",$J,X)) Q:X=""  D
-	.L +^DIC(19,"AXQ",X):2 I '$T S XQFLAG=1 Q
-	.S %X="^TMP(""XQO"","_$J_","_Q_X_Q_","
-	.S %Y="^DIC(19,""AXQ"","_Q_X_Q_","
-	.K ^DIC(19,"AXQ",X)
-	.;M ^DIC(19,"AXQ",X)=^TMP("XQO",$J,X)
-	.D %XY^%RCR
-	.L -^DIC(19,"AXQ",X)
-	.K %X,%Y
-	.Q
-	;
-	I XQFLAG,$D(XQFG) D
-	.N %,Y
-	.S Y=$P(X,"P",2) Q:Y=""
-	.S %=$G(^DIC(19,Y,0)) Q:%=""
-	.S Y=$P(%,"^",2) Q:%=""
-	.W !,?12,"Could not merge menu: "_Y
-	.Q
-	Q
-	;
-CLEAN	;Clean out unused menu trees from ^DIC(19,"AXQ")
-	N X,Y S X="P"
-	F  S X=$O(^DIC(19,"AXQ",X)) Q:X=""  D
-	.I X'="PXU" D
-	..S Y=$E(X,2,99)
-	..I '$D(^TMP($J,Y))&('$D(^TMP($J,"SEC",Y))) K ^DIC(19,"AXQ",X),^XUTL("XQO",X)
-	..Q
-	.Q
-	Q
-	;
-MERGEX	;Merge ^DIC(19,"AXQ") into ^XUTL("XQO")
-	N Q,X,XQFLAG,Y S X="P",XQFLAG=0,Q=""""
-	F  S X=$O(^DIC(19,"AXQ",X)) Q:X=""  D
-	.L +^XUTL("XQO",X):2 I '$T S XQFLAG=1 Q
-	.S %X="^DIC(19,""AXQ"","_Q_X_Q_","
-	.S %Y="^XUTL(""XQO"","_Q_X_Q_","
-	.K ^XUTL("XQO",X)
-	.;M ^XUTL("XQO",X)=^DIC(19,"AXQ",X)
-	.D %XY^%RCR
-	.L -^XUTL("XQO",X)
-	.K %X,%Y
-	.Q
-	;
-	I XQFLAG,$D(XQFG) D
-	.N %,Y
-	.S Y=$P(X,"P",2) Q:Y=""
-	.S %=$G(^DIC(19,Y,0)) Q:%=""
-	.S Y=$P(%,"^",2) Q:%=""
-	.W !,?12,"Could not merge menu: "_Y
-	.Q
-	;
-	I 'XQFLAG,$D(XQFG) W " done."
-	Q
-	;
-STATUS()	 ;Are the menus being rebuilt even as we speak?
-	N %,XQTHEN
-	S %=$G(^DIC(19,"AXQ","P0")) I %="" Q 1  ;It finished.  Never mind.
-	L +^DIC(19,"AXQ","P0"):0 ;If job is still running we can't lock it
-	I $T L -^DIC(19,"AXQ","P0") K ^("P0") Q 1  ;Job must have failed
-	Q 0
-	;
-	;
-MICRO	;Turn off micro surgery
-	I $D(^DIC(19,"AXQ","P0","MICRO")) D
-	.S ^DIC(19,"AXQ","P0","STOP")=$H ;Turn off micro-surgery
-	.K ^DIC(19,"AXQ","P0","MICRO")
-	.H 2
-	.Q
-	Q
-	;
-	;
-ERR	;Come here on error
-	N XQERROR
-	S XQERROR=$$EC^%ZOSV
-	D ^%ZTER
-	D EXIT^XPDID()
-	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
+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 ;
+ ;
+RD2 N XQSTAT S XQSTAT=$$STATUS()
+ I 'XQSTAT W !!,"Some one else is rebuilding menus.  Sorry." Q
+ K ZTSK
+ D MICRO ;Turn off micro surgery for now
+ ;
+ 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) 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")=""
+ .S ZTDESC="Build menu trees in ^DIC(19,""AXQ"")"
+ .D ^%ZTLOAD
+ .I $D(ZTSK),'XQVE W !!,"Task #: ",ZTSK,!
+ .Q
+ ;
+ I $D(ZTSK) K ^DIC(19,"AXQ","P0") S XQALLDON="" G BLDEND
+ 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) BLDEND G:Y'=1 RD2
+ ;
+KIDS ;Entry from KIDS
+ I '$D(XQSTAT),$D(^DIC(19,"AXQ","P0")) S XQSTAT=$$STATUS I 'XQSTAT W !!,"  Some one else is building menus.  Sorry." K XQSTAT Q
+ I '$D(^DIC(19,"AXQ","P0","STOP")) D MICRO
+ I '$D(^DIC(19,"AXQ","P0")) S ^DIC(19,"AXQ","P0")=$H L +^DIC(19,"AXQ","P0")
+ I '$D(XQVE) S XQFG=0,XQBSEC=1,XQVE=0
+ N XQNTREE,XQNDONE S (XQNTREE,XQNDONE)=0
+ ;
+ ;Set up the error trap so we can clear the screen if it blows
+ I $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^XQ81"
+ E  S X="ERR^XQ81",@^%ZOSF("TRAP")
+ ;
+ ;Set up the bar graph and window if not from KIDS
+ I '$D(XPDNM) D INIT^XPDID
+ I XPDIDVT D
+ .I $D(XPDIDTOT) S XQSAVTOT=XPDIDTOT
+ .S X="Rebuilding Menus" D TITLE^XPDID(X)
+ .S XPDIDTOT=50 ;Number of divisions in bar graph
+ .D UPDATE^XPDID(0)
+ .Q
+ ;
+ S XQSTART=$$HTE^XLFDT($H)
+ W !!,"Starting Menu Rebuild:  ",XQSTART
+ S XQFG=0 W !!,"Collecting primary menus in the New Person file..."
+ ;
+DQ ;Entry from taskman  Write if $D(XQFG)
+ K ZTREQ
+ I '$D(XQSTART) S XQSTART=$$HTE^XLFDT($H)
+ N XQNOW,XQ8FLG,XQTASK
+ S XQ8FLG=0
+ S:'$D(XQNOW) XQNOW=$H
+ S ^DIC(19,"AXQ","P0")=XQNOW
+ S ^DIC(19,"AXQ","P0","STOP")=XQNOW ;Stop micro surgery if it's running
+ ;
+ S XQSEC=1,XQ81T="" I 'XQVE H 1
+ S XQI="" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:XQI'=+XQI!(XQI="")  I $D(^TMP("XQO",$J,XQI,0))#2 S $P(^(0),U,2)=""
+ S XQI="U" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:"U"'[$E(XQI)!(XQI="")  I $D(^TMP("XQO",$J,XQI,0))#2 S $P(^(0),U,2)=""
+ S XQI="P" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:"P"'[$E(XQI)!(XQI="")  I $D(^TMP("XQO",$J,XQI,0))#2,$L(^(0)) S XQ81T=^(0) Q
+ S:XQ81T="" XQ81T="Unknown"
+ S XQI="P" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:"P"'[$E(XQI)!(XQI="")  I "P"[$E(XQI),XQI'="P0" K ^TMP("XQO",$J,XQI)
+ ;
+ ;Find the various trees and put them into ^TMP($J), and count them
+ S:'$D(XQH) XQH=$H K ^TMP($J) S XQI=.5 F XQK=0:0 S XQI=$O(^VA(200,XQI)) Q:XQI'=+XQI  I $D(^VA(200,XQI,0)),$L($P(^VA(200,XQI,0),U,3)) D SET
+ ;
+ S (XQNTREE,%)=0 F  S %=$O(^TMP($J,%)) Q:%=""  S XQNTREE=XQNTREE+1
+ S %=0 F  S %=$O(^TMP($J,"SEC",%)) Q:%=""  S XQNTREE=XQNTREE+1
+ ;
+ W:$D(XQFG) !!?20,"Primary menus found in the New Person file",!?20,"------------------------------------------"
+ W:$D(XQFG) !!,"OPTION NAME         MENU TEXT",?49,"# OF",?62,"LAST",?71,"LAST",!?49,"USERS",?62,"USED",?71,"BUILT",!
+ S X="" F XQBLD=0:0 S XQBLD=$O(^TMP($J,XQBLD)) Q:XQBLD'>0!(X=U)  I $D(^DIC(19,XQBLD,0)) S XQJ=^DIC(19,XQBLD,0) D VER
+ S XQSEC=0 I $D(XQFG),XQBSEC W !!,"Building secondary menu trees...."
+ I XQBSEC S X="" F XQBLD=0:0 S XQBLD=$O(^TMP($J,"SEC",XQBLD)) Q:XQBLD'>0  D SEC
+ I 'XQVE S XQK="P" F XQBLD=0:0 S XQK=$O(^TMP("XQO",$J,XQK)) Q:XQK'["P"  S ^(XQK,0)=XQH
+ G BLDEND
+ ;
+SEC S XQL="P"_XQBLD Q:$D(^TMP("XQO",$J,XQL))  D RD3 Q
+ S XQL="P" F XQN=0:0 S XQL=$O(^TMP("XQO",$J,XQL)) Q:$E(XQL)'="P"  I $D(^TMP("XQO",$J,XQL,"^",XQBLD)) Q
+ D:$E(XQL)'="P" RD3
+ Q
+ ;
+VER I $D(XQFG) D
+ .N XQMT,XQOPNM
+ .S XQK=$P(^TMP($J,XQBLD),U,2)
+ .S:$L(XQK) XQK=$E(XQK,4,5)_"/"_$E(XQK,6,7)_"/"_$E(XQK,2,3)
+ .S XQOPNM=$P(XQJ,U)
+ .S XQMT=$P(XQJ,U,2) I $L(XQMT)>28 S XQMT=$E(XQMT,1,25)_"..."
+ .W !,$P(XQJ,U,1)
+ .W:($L(XQOPNM)>20) !
+ .W ?20,XQMT,?49,+^TMP($J,XQBLD),?60,XQK
+ .Q
+ ;
+ I $D(XQFG) S:$D(^DIC(19,"AXQ","P"_XQBLD,0)) XQ81T=+^(0) I $L(XQ81T) S %H=XQ81T D YMD^%DTC S XQK=X W ?71,$E(XQK,4,5),"/",$E(XQK,6,7),"/",$E(XQK,2,3)
+ ;
+RD3 ;Update counter an rebuild it if necessary
+ I $D(XQFG),XPDIDVT D
+ .N %
+ .S XQNDONE=XQNDONE+1
+ .S %=(XQNDONE/XQNTREE)*XPDIDTOT
+ .D UPDATE^XPDID(%)
+ .Q
+ ;
+ S XQDIC="P"_XQBLD D CHK^XQ8 I XQRE W:$D(XQFG) !,"SOMEONE ELSE IS CURRENTLY REBUILDING THIS MENU" Q
+ I XQVE,XQSEC S DIR(0)="Y",DIR("A")="Rebuild",DIR("B")="YES" D ^DIR Q:$D(DIRUT)  W ! Q:Y'=1
+ S XQFG1=1 D PM2^XQ8
+ I $D(ZTQUEUED) S ZTREQ="@"
+ Q
+ ;
+SET G:'$D(^VA(200,XQI,201)) SET1 S XQK=+^(201) Q:'$L(XQK)  ;I $D(XQFG) W:'(XQI#10) "."
+ S XQR="" S:$D(^VA(200,XQI,1.1)) XQR=$P(^(1.1),".",1) S XQP=1_U_XQR
+ I $D(^TMP($J,XQK)) S XQP=^TMP($J,XQK) S XQP=XQP+1_U_$S(XQR>$P(XQP,U,2):XQR,1:$P(XQP,U,2))
+ I $D(^DIC(19,XQK,0)),$P(^(0),U,4)="M" S ^TMP($J,XQK)=XQP
+ ;
+SET1 I XQBSEC F XQN=0:0 S XQN=$O(^VA(200,XQI,203,XQN)) Q:XQN'>0  S XQL=+^(XQN,0) I $D(^DIC(19,XQL,0)),$P(^(0),U,4)="M" S ^TMP($J,"SEC",XQL)=""
+ Q
+ ;
+QUE ;Entry point for the option XQBUILDTREEQUE, and XQBUILDALL
+ ;Also called by CHEK^XQ83
+ S XQVE=0,XQBSEC=1 K XQFG
+ S XQSTART=$$HTE^XLFDT($H)
+ G DQ
+ ;
+BLDEND ;File a report, cleanup, and quit.
+ ;
+ 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
+ ;
+ I $D(XQALLDON) K XQALLDON Q  ;Quit here if we're just creating a task
+ ;
+ D MERGET
+ D CLEAN
+ D MERGEX
+ ;
+ K ^TMP($J),^TMP("XQO",$J)
+ ;
+ ;Clear the flags and locks.
+ K ^XUTL("XQMERGED") ;Menues merged since last rebuild REACT^XQ84
+ K ^DIC(19,"AT") ;Micro message nodes
+ S ^XUTL("XQ","MICRO")=0 ;Number of Micro instances since last build
+ K ^DIC(19,"AXQ","P0","STOP") ;Allow Micro surgery to start up
+ K ^DIC(19,"AXQ","P0") ;Clear the rebuild flag (redundant, I know)
+ L -^DIC(19,"AXQ","P0") ;Unlock the rebuild flag, everybody's good to go
+ ;
+ S %=$S($D(XPDNM):"KIDS",$D(ZTSK):"QUEUED",1:"LIVE")
+ D REPORT^XQ84(%)
+ K XQSTART,ZTSK
+ ;
+ I '$D(XPDIDVT) K XQFG Q
+ ;
+ I $D(XQFG),XPDIDVT F %=((XQNDONE/XQNTREE)*XPDIDTOT):1:XPDIDTOT D UPDATE^XPDID(%) H .25
+ I $D(XQFG),XPDIDVT D UPDATE^XPDID(XPDIDTOT)
+ I $D(XQFG) W !!,"Menu Rebuild Complete:  ",$$HTE^XLFDT($H)
+ ;
+ ;
+ H 2
+ ;If we're not from KIDS then clean it up, otherwise let kids do it.
+ I '$D(XPDNM) D
+ .D EXIT^XPDID()
+ .K XPDIDVT,XPDIDTOT
+ .Q
+ ;
+ I $D(XQSAVTOT) S XPDIDTOT=XQSAVTOT
+ K %,VALMCOFF,VALMCON,VALMIOXY,VALMSGR,VALMWD,XQFG,XQNDONE,XQNTREE,XQSAVTOT
+ Q
+ ;
+ ;================================Subroutines==========================
+ ;
+MERGET ;Merge ^TMP("XQO",$J) into ^DIC(19,"AXQ")
+ N Q,X,XQFLAG,Y S X="P",XQFLAG=0,Q=""""
+ I $D(XQFG) W !!,"Merging...."
+ F  S X=$O(^TMP("XQO",$J,X)) Q:X=""  D
+ .L +^DIC(19,"AXQ",X):2 I '$T S XQFLAG=1 Q
+ .S %X="^TMP(""XQO"","_$J_","_Q_X_Q_","
+ .S %Y="^DIC(19,""AXQ"","_Q_X_Q_","
+ .K ^DIC(19,"AXQ",X)
+ .;M ^DIC(19,"AXQ",X)=^TMP("XQO",$J,X)
+ .D %XY^%RCR
+ .L -^DIC(19,"AXQ",X)
+ .K %X,%Y
+ .Q
+ ;
+ I XQFLAG,$D(XQFG) D
+ .N %,Y
+ .S Y=$P(X,"P",2) Q:Y=""
+ .S %=$G(^DIC(19,Y,0)) Q:%=""
+ .S Y=$P(%,"^",2) Q:%=""
+ .W !,?12,"Could not merge menu: "_Y
+ .Q
+ Q
+ ;
+CLEAN ;Clean out unused menu trees from ^DIC(19,"AXQ")
+ N X,Y S X="P"
+ F  S X=$O(^DIC(19,"AXQ",X)) Q:X=""  D
+ .I X'="PXU" D
+ ..S Y=$E(X,2,99)
+ ..I '$D(^TMP($J,Y))&('$D(^TMP($J,"SEC",Y))) K ^DIC(19,"AXQ",X),^XUTL("XQO",X)
+ ..Q
+ .Q
+ Q
+ ;
+MERGEX ;Merge ^DIC(19,"AXQ") into ^XUTL("XQO")
+ N Q,X,XQFLAG,Y S X="P",XQFLAG=0,Q=""""
+ F  S X=$O(^DIC(19,"AXQ",X)) Q:X=""  D
+ .L +^XUTL("XQO",X):2 I '$T S XQFLAG=1 Q
+ .S %X="^DIC(19,""AXQ"","_Q_X_Q_","
+ .S %Y="^XUTL(""XQO"","_Q_X_Q_","
+ .K ^XUTL("XQO",X)
+ .;M ^XUTL("XQO",X)=^DIC(19,"AXQ",X)
+ .D %XY^%RCR
+ .L -^XUTL("XQO",X)
+ .K %X,%Y
+ .Q
+ ;
+ I XQFLAG,$D(XQFG) D
+ .N %,Y
+ .S Y=$P(X,"P",2) Q:Y=""
+ .S %=$G(^DIC(19,Y,0)) Q:%=""
+ .S Y=$P(%,"^",2) Q:%=""
+ .W !,?12,"Could not merge menu: "_Y
+ .Q
+ ;
+ I 'XQFLAG,$D(XQFG) W " done."
+ Q
+ ;
+STATUS()  ;Are the menus being rebuilt even as we speak?
+ N %,XQTHEN
+ S %=$G(^DIC(19,"AXQ","P0")) I %="" Q 1  ;It finished.  Never mind.
+ L +^DIC(19,"AXQ","P0"):0 ;If job is still running we can't lock it
+ I $T L -^DIC(19,"AXQ","P0") K ^("P0") Q 1  ;Job must have failed
+ Q 0
+ ;
+ ;
+MICRO ;Turn off micro surgery
+ I $D(^DIC(19,"AXQ","P0","MICRO")) D
+ .S ^DIC(19,"AXQ","P0","STOP")=$H ;Turn off micro-surgery
+ .K ^DIC(19,"AXQ","P0","MICRO")
+ .H 2
+ .Q
+ Q
+ ;
+ ;
+ERR ;Come here on error
+ N XQERROR
+ S XQERROR=$$EC^%ZOSV
+ D ^%ZTER
+ D EXIT^XPDID()
+ G UNWIND^%ZTER
+ Q
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,56 +1,54 @@
-XQALDATA	;ISC-SF/JLI - PROVIDE DATA ON ALERTS ;4/9/07  13:39
-	;;8.0;KERNEL;**207,285,443**;Jul 10, 1995;Build 4
-	Q
-GETUSER(ROOT,XQAUSER,FRSTDATE,LASTDATE)	;
-	N XREF,XVAL,X,X2,X3,I,NCNT ; P443
-	S:$G(XQAUSER)'>0 XQAUSER=DUZ
-	S:$G(FRSTDATE)'>0 FRSTDATE=0
-	S:$G(LASTDATE)'>0 LASTDATE=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
-	. . 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 XREF="R"
-	S XVAL=XQAUSER
-	D CHKTRAIL
-	Q
-GETPAT(ROOT,PATIENT,FRSTDATE,LASTDATE)	;
-	N XREF,XVAL,NCNT
-	S NCNT=0 K @ROOT
-	I $G(PATIENT)'>0 S @ROOT=0 Q
-	S XREF="C"
-	S XVAL=PATIENT
-	D CHKTRAIL
-	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=""
-	. 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
-	Q
-GETUSER1(ROOT,XQAUSER,FRSTDATE,LASTDATE)	;
-	N NCNT,KEY
-	S:$G(XQAUSER)'>0 XQAUSER=DUZ
-	S:$G(FRSTDATE)'>0 FRSTDATE=0
-	S:$G(LASTDATE)'>0 LASTDATE=0
-	S NCNT=0 K @ROOT
-	I FRSTDATE=0 D  Q
-	. N X,X2,X3,X4,I S I="" F  S I=$O(^XTV(8992,XQAUSER,"XQA",I),-1) Q:I'>0  S X=^(I,0),X2=$G(^(2)),X3=$G(^(3)),X4=$D(^(4)) D
-	. . I $P(X,U,4)'="" S $P(^XTV(8992,XQAUSER,"XQA",I,0),U,4)="" ; MARK SEEN
-	. . S NCNT=NCNT+1
-	. . S KEY=$S($P(X3,U)'="":"G  ",X4>1:"L  ",$P(X,U,7,8)="^ ":"I  ",1:"R  "),@ROOT@(NCNT)=KEY_$P(X,U,3)_U_$P(X,U,2)
-	. . I X2'="" D
-	. . . S NCNT=NCNT+1,@ROOT@(NCNT)=KEY_"-----Forwarded by: "_$$GET1^DIQ(200,($P(X2,U)_","),.01)_"   Generated: "_$$DAT8^XQALERT($P(X2,U,2),1)_U_$P(X,U,2)
-	. . . I $P(X2,U,3)'="" S NCNT=NCNT+1,@ROOT@(NCNT)=KEY_"-----"_$P(X2,U,3)_U_$P(X,U,2)
-	. . . Q
-	. S @ROOT=NCNT
-	. Q
-	Q
+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
+ S:$G(XQAUSER)'>0 XQAUSER=DUZ
+ S:$G(FRSTDATE)'>0 FRSTDATE=0
+ S:$G(LASTDATE)'>0 LASTDATE=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)) 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 @ROOT=NCNT
+ S XREF="R"
+ S XVAL=XQAUSER
+ D CHKTRAIL
+ Q
+GETPAT(ROOT,PATIENT,FRSTDATE,LASTDATE) ;
+ N XREF,XVAL
+ S NCNT=0 K @ROOT
+ I $G(PATIENT)'>0 S @ROOT=0 Q
+ S XREF="C"
+ S XVAL=PATIENT
+ D CHKTRAIL
+ Q
+CHKTRAIL ;
+ 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)) 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 @ROOT=NCNT
+ Q
+GETUSER1(ROOT,XQAUSER,FRSTDATE,LASTDATE) ;
+ N NCNT,KEY
+ S:$G(XQAUSER)'>0 XQAUSER=DUZ
+ S:$G(FRSTDATE)'>0 FRSTDATE=0
+ S:$G(LASTDATE)'>0 LASTDATE=0
+ S NCNT=0 K @ROOT
+ I FRSTDATE=0 D  Q
+ . N X,X2,X3,X4,I S I="" F  S I=$O(^XTV(8992,XQAUSER,"XQA",I),-1) Q:I'>0  S X=^(I,0),X2=$G(^(2)),X3=$G(^(3)),X4=$D(^(4)) D
+ . . I $P(X,U,4)'="" S $P(^XTV(8992,XQAUSER,"XQA",I,0),U,4)="" ; MARK SEEN
+ . . S NCNT=NCNT+1
+ . . S KEY=$S($P(X3,U)'="":"G  ",X4>1:"L  ",$P(X,U,7,8)="^ ":"I  ",1:"R  "),@ROOT@(NCNT)=KEY_$P(X,U,3)_U_$P(X,U,2)
+ . . I X2'="" D
+ . . . S NCNT=NCNT+1,@ROOT@(NCNT)=KEY_"-----Forwarded by: "_$$GET1^DIQ(200,($P(X2,U)_","),.01)_"   Generated: "_$$DAT8^XQALERT($P(X2,U,2),1)_U_$P(X,U,2)
+ . . . I $P(X2,U,3)'="" S NCNT=NCNT+1,@ROOT@(NCNT)=KEY_"-----"_$P(X2,U,3)_U_$P(X,U,2)
+ . . . Q
+ . S @ROOT=NCNT
+ . Q
+ Q
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,175 +1,175 @@
-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
-	;;
-	Q
-	;
-DELETE	;
-	N XQAFOUND,XQADAT,XQX,XQK,XQXX,XQXY,XQJ,XQAID1
-	Q:'$D(XQAID)  Q:XQAID=""  S:'$D(XQAKILL) XQAKILL=0 S:$P(XQAID,";")="NO-ID" XQAKILL=1
-	S XQADAT=$$NOW^XLFDT()
-	I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ
-	S XQAFOUND=0 D
-	. S XQX=XQAUSER F XQK=0:0 S XQK=$O(^XTV(8992,XQAUSER,"XQA",XQK)) Q:XQK'>0  I $P(^(XQK,0),U,2)=XQAID S XQAFOUND=1 Q
-	S XQXX=$O(^XTV(8992.1,"B",XQAID,0)) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQAUSER,0)) I XQXY>0,XQAFOUND,'$G(XQAUSERD) S $P(^XTV(8992.1,XQXX,20,XQXY,0),U,4)=XQADAT
-	K XQXX,XQXY
-	I '$D(^XTV(8992,"AXQA",XQAID,XQAUSER)) D KILLOC
-	F XQX=0:0 S XQX=$O(^XTV(8992,"AXQA",XQAID,XQX)) Q:XQX'>0  D  Q:XQAKILL
-	. I XQAKILL S XQX=XQAUSER ; Make sure XQAKILL gets only XQAUSER
-	. F XQK=0:0 S XQK=$O(^XTV(8992,"AXQA",XQAID,XQX,XQK)) Q:XQK'>0  K ^(XQK),^XTV(8992,"AXQAN",$P(XQAID,";"),XQX,XQK) S XQAID1=XQAID D:$D(^XTV(8992,XQX,"XQA",XQK,0)) DELA S XQAID=XQAID1
-	K XQAID,XQX,XQJ,XQK,XQAID1,XQAKILL
-	Q
-	;
-DELETEA	;
-	N XQA1,XQADAT,XQAFOUND,XQX,XQXX,XQXY,XQK,XQJ
-	Q:'$D(XQAID)  Q:XQAID=""  S XQA1=$P(XQAID,";")
-	S XQADAT=$$NOW^XLFDT()
-	I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ
-	S:'$D(XQAKILL) XQAKILL=0 G:$P(XQAID,";")="NO-ID" DELETE
-	S XQAFOUND=0 D
-	. S XQX=XQAUSER F XQK=0:0 S XQK=$O(^XTV(8992,XQAUSER,"XQA",XQK)) Q:XQK'>0  I $P($G(^(XQK,0)),U,2)=XQAID S XQAFOUND=1 Q
-	S XQXX=$O(^XTV(8992.1,"B",XQAID,0)) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQAUSER,0)) I XQXY>0,XQAFOUND,'$G(XQAUSERD) S $P(^XTV(8992.1,XQXX,20,XQXY,0),U,4)=XQADAT
-	I '$D(^XTV(8992,"AXQAN",XQA1,XQAUSER)) D KILLOC
-	I $P(XQAID,",",2)'=""!($P(XQAID,";",2)="") F XQX=0:0 S XQX=$O(^XTV(8992,"AXQAN",XQA1,XQX)) Q:XQX'>0  D  Q:XQAKILL
-	. I XQAKILL S XQX=XQAUSER
-	. F XQK=0:0 S XQK=$O(^XTV(8992,"AXQAN",XQA1,XQX,XQK)) Q:XQK'>0  K ^(XQK) I $D(^XTV(8992,XQX,"XQA",XQK,0)) D DELA
-	I $P(XQAID,",",2)=""&($P(XQAID,";",2)'="") F XQX=0:0 S XQX=$O(^XTV(8992,"AXQA",XQAID,XQX)) Q:XQX'>0  D  Q:XQAKILL
-	. I XQAKILL S XQX=XQAUSER
-	. S XQK=$O(^XTV(8992,"AXQA",XQAID,XQX,0)) Q:XQK'>0  K ^(XQK),^XTV(8992,"AXQAN",XQA1,XQX,XQK) I $D(^XTV(8992,XQX,"XQA",XQK,0)) D DELA
-	K XQAID,XQA1,XQX,XQK,XQAKILL
-	Q
-DELA	;
-	N XQDEL11 S XQAID=$P($G(^XTV(8992,XQX,"XQA",XQK,0)),U,2),XQDEL11=$P($G(^(0)),U) K ^XTV(8992,XQX,"XQA",XQK) K:XQAID'="" ^XTV(8992,"AXQA",XQAID,XQX,XQK)
-	D COUNT(-1,XQX)
-	K:XQAID'="" ^XTV(8992,"AXQAN",$P(XQAID,";"),XQX,XQK) K:XQDEL11'="" ^XTV(8992,XQX,"XQA","B",XQDEL11,XQK)
-	S XQXX=$S(XQAID'="":$O(^XTV(8992.1,"B",XQAID,0)),1:0) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQX,0)) I XQXY>0,$P(^XTV(8992.1,XQXX,20,XQXY,0),U,5)'>0 S $P(^(0),U,5)=XQADAT I $G(XQAUSERD) S $P(^(0),U,9)=DUZ
-	K XQXX,XQXY
-	Q
-	;
-COUNT(%1,%2)	;Change the count on the zero node, (amount, user)
-	Q:$G(%2)'>0
-	L +^XTV(8992,%2):10
-	I %1 S %=$P($G(^XTV(8992,%2,"XQA",0)),U,4)+%1 S:%'<0 $P(^(0),U,4)=%
-	I '%1 D
-	. N % S %1=0,%=0 F  S %=$O(^XTV(8992,%2,"XQA",%)) Q:%'>0  S %1=%1+1
-	. S $P(^XTV(8992,%2,"XQA",0),U,4)=%1
-	L -^XTV(8992,%2)
-	Q
-KILLOC	;
-	N XQX,XQK
-	S XQX=XQAUSER F XQK=0:0 S XQK=$O(^XTV(8992,XQAUSER,"XQA",XQK)) Q:XQK'>0  I $P(^(XQK,0),U,2)=XQAID D
-	. N XQAID D DELA
-	Q
-	;
-OLDDEL	;
-	N XQADAT,X2,XQDAT,XQDEL1
-	S XQADAT=$$NOW^XLFDT()
-	S X2=-15 I $G(ZTQPARAM)>0 S X2=-ZTQPARAM
-	S XQDAT=$$FMADD^XLFDT(DT,X2)
-	;Loop thru users (XQDEL1) levels
-	F XQDEL1=0:0 S XQDEL1=$O(^XTV(8992,XQDEL1)) Q:XQDEL1'>0  D OLDDEL1
-	D KILLARCH
-	K X1,X2,X,XQDEL1,XQDEL2,XQDAT,XQA,XQADAT
-	Q
-OLDDEL1	;Loop thru the Alert (XQDEL2) level
-	L +^XTV(8992,XQDEL1):10
-	N XQAGLOB,KILLOLD,XQAZERO,XQAUSER,XQLIST,Y,XQAV,XQPRAMTY,XQDEL2,XQA
-	S XQAGLOB=$NA(^XTV(8992,XQDEL1,"XQA")),XQAUSER=XQDEL1
-	F XQDEL2=0:0 S XQDEL2=$O(@XQAGLOB@(XQDEL2)) Q:XQDEL2'>0  S XQAZERO=^(XQDEL2,0) D
-	. ; CHECK FOR BACKUP REVIEWER TO FORWARD ALERTS NEEDING ACTION -- P174
-	. I $P(XQAZERO,U,15)>0 I $$FMADD^XLFDT(+XQAZERO,+$P(XQAZERO,U,15))\1=DT D  Q:$D(KILLOLD)  ; changed '>DT to =DT so only send once without killing
-	. . N XQA D GETBKUP(.XQA,XQDEL1)
-	. . I $D(XQA) S XQALTYPE="BACKUP REVIEWER" D FORWARD^XQALFWD($P(XQAZERO,U,2),.XQA,"A","ALERT NOT PROCESSED BY "_$$GET1^DIQ(200,XQDEL1_",",.01)) S KILLOLD=1
-	. . Q  ;  End of Backup Reviewer Code -- P174
-	. I $P(XQAZERO,U,13)>0 I $$FMADD^XLFDT(+XQAZERO,+$P(XQAZERO,U,13))\1=DT D  Q:$D(KILLOLD)  ; P174
-	. . N XQA,I F I=0:0 S I=$O(^XMB(3.7,XQAUSER,9,I)) Q:I'>0  S XQAV=+^(I,0),XQA(XQAV)=XQAV
-	. . I $D(XQA) S XQALTYPE="EMAIL SURROGATE" D FORWARD^XQALFWD($P(XQAZERO,U,2),.XQA,"A","ALERT NOT PROCESSED BY "_$$GET1^DIQ(200,XQDEL1_",",.01)) S KILLOLD=1
-	. . Q
-	. I $P(XQAZERO,U,14)>0 I $$FMADD^XLFDT(+XQAZERO,+$P(XQAZERO,U,14))\1=DT D  Q:$D(KILLOLD)  ; P174
-	. . N XQA,I S I=$P($G(^VA(200,XQAUSER,5)),U) I I>0 S I=$P($G(^DIC(49,+I,0)),U,3) I I>0,$D(^VA(200,+I,0)) S XQA(+I)=+I
-	. . I $D(XQA) S XQALTYPE="CHIEF/SUPERVISOR" D FORWARD^XQALFWD($P(XQAZERO,U,2),.XQA,"A","ALERT NOT PROCESSED BY "_$$GET1^DIQ(200,XQDEL1_",",.01)) S KILLOLD=1
-	. . Q
-	. I XQDEL2'>XQDAT  D OLDDEL2
-	. Q
-	K:$O(^XTV(8992,XQDEL1,"XQA",0))="" ^XTV(8992,XQDEL1,"XQA")
-	L -^XTV(8992,XQDEL1)
-	Q
-	;
-OLDDEL2	;
-	N XQA,XQXX,XQXY
-	S XQA=$P(^XTV(8992,XQDEL1,"XQA",XQDEL2,0),U,2) K ^XTV(8992,XQDEL1,"XQA",XQDEL2) K:XQA'="" ^XTV(8992,"AXQA",XQA,XQDEL1),^XTV(8992,"AXQAN",$P(XQA,";"),XQDEL1)
-	D COUNT(-1,XQDEL1)
-	I XQA'="" S XQXX=$O(^XTV(8992.1,"B",XQA,0)) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQDEL1,0)) I XQXY>0 S $P(^XTV(8992.1,XQXX,20,XQXY,0),U,6)=XQADAT
-	Q
-	;
-KILLARCH	;
-	;  Q  ; turn off deletion from ALERT TRACKING file ; remove from XU*8*285  JLI 040624
-	N DA,DIK,XQDAT,XQDEL1,X1,X2,DA,DIK
-	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 DA=XQDEL1 I X2="",X1>XQDAT Q
-	. I X2>0,DT<X2 Q
-	. S DIK="^XTV(8992.1," D ^DIK
-	Q
-	;
-USERDEL	; Delete undesired alerts for a user
-	N DA,DIC,XQAUSERD
-	S DIC("A")="Select NEW PERSON entry for deletion of alerts: "
-	S DIC(0)="AEQM",DIC=200
-	D ^DIC K DIC Q:Y'>0  S XQAUSER=+Y
-	S XQALDELE=1
-	K XQX1
-	D DOIT^XQALERT1
-	K XQALDELE S XQAUSERD=1
-	I $D(XQX1),XQX1>0 D
-	. F  Q:XQX1=""  S DA=+XQX1,XQX1=$P(XQX1,",",2,99) D  I XQX1="" S Y=$O(XQX1(0)) I Y>0 S XQX1=XQX1(Y) K XQX1(Y)
-	. . S XQAID=$P(^TMP("XQ",$J,"XQA1",DA),U,2),XQAKILL=1
-	. . I XQAID="" K ^XTV(8992,XQAUSER,"XQA",+^TMP("XQ",$J,"XQA1",DA,1))
-	. . I XQAID'="" D DELETE
-	. . K ^TMP("XQ",$J,"XQA1",DA),^TMP("XQ",$J,"XQA",(999999-DA))
-	K XQAUSER,XQX1
-	Q
-	;
-GETBKUP(XQA,XQAUSER)	;  JLI 030129 - REMOVED TO SEPARATE METHOD
-	N I,XQORY,XQENTITY,XQPARAM,XQERR,K,XQAV,XQLIST
-	S XQPARAM="XQAL BACKUP REVIEWER"
-	D GETLST^XPAR(.XQLIST,"USR.`"_XQAUSER,XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=200 ; USER
-	I '($D(XQLIST)>1) S I=$$GET1^DIQ(200,XQAUSER_",",29,"I") I I>0 D GETLST^XPAR(.XQLIST,"SRV.`"_I,XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=49 ; SERVICE
-	I '($D(XQLIST)>1) D GETLST^XPAR(.XQLIST,$$DIVENTIT(XQAUSER),XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=4 ; DIVISION
-	I '($D(XQLIST)>1) D GETLST^XPAR(.XQLIST,"SYS",XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=4.2 ; SYSTEM
-	F I=0:0 S I=$O(XQLIST(I)) Q:I'>0  S XQAV=$P(XQLIST(I),U,2),XQA(XQAV)=XQAV
-	; Removed Teams per Curtis Anderson with CPRS
-	;I '$D(XQA) D  ; NONE UNDER USER - CHECK FOR ENTRIES IN PARAMETER FILE FOR TEAMS
-	;. I $T(TEAMPR^ORQPTQ1)]"" D TEAMPR^ORQPTQ1(.XQORY,XQAUSER) K:+$G(XQORY(1))<1 XQORY ; GET TEAM ID'S IF ANY ; CONTROLLED SUBSCRIPTION
-	;. S I=0 F  S I=$O(XQORY(I)) Q:I'>0  K XQLIST D GETLST^XPAR(.XQLIST,$P(XQORY(I),U,2)_";OR(100.21,",XQPARAM,"Q",.ERR) I $D(XQTEAM) D
-	;. . N K F K=0:0 S K=$O(XQLIST(K)) Q:K'>0  S XQAV=$P(XQLIST(K),U,2),XQA(XQAV)=XQAV
-	;. . Q`
-	;. Q
-	;I '$D(XQLIST) D  ; NO TEAM ENTRIES, CHECK OTHER ENTITIES (SERVICE,DIVISION,SYSTEM)
-	;. S XQENTITY="SYS"
-	;. S I=$$GET1^DIQ(200,XQAUSER_",",16,"I") I I>0 S XQENTITY="DIV.`"_I_U_XQENTITY ; DIVISION
-	;. S I=$$GET1^DIQ(200,XQAUSER_",",29,"I") I I>0 S XQENTITY="SRV.`"_I_U_XQENTITY ; SERVICE\SECTION
-	;. D GETLST^XPAR(.XQLIST,XQENTITY,XQPARAM,"Q",.XQERR) F I=0:0 S I=$O(XQLIST(I)) Q:I'>0  S XQAV=+$P(XQLIST(I),U,2),XQA(XQAV)=XQAV
-	;. Q
-	;I '$D(XQA) D  ; NO PARAMETERS ENTERED - USE LAST RESORT MAIL GROUP
-	;. S XQJ="G.XQAL UNPROCESSED ALERTS" D GROUP^XQALSET1
-	;. I '$D(XQA) S XQJ="G.PATCH" D GROUP^XQALSET1 ; REALLY LAST RESORT
-	;. F I=0:0 S I=$O(XQA(I)) Q:I'>0  S XQA(I)=I
-	;. Q
-	Q
-	;
-DIVENTIT(XQAUSER)	;
-	N ENTITY,NCNT,DIVNAM,I
-	S ENTITY="" I DUZ=XQAUSER S ENTITY="DIV.`"_DUZ(2)
-	I ENTITY="" D
-	. K NCNT,DIVNAM S NCNT=0 F I=0:0 S I=$O(^VA(200,XQAUSER,2,I)) Q:I'>0  S NCNT=NCNT+1,DIVNAM(NCNT)=+^(I,0) I $P(^(0),U,2) S DIVNAM=+^(0)
-	. I NCNT'>0 Q
-	. I NCNT=1 S ENTITY="DIV.`"_DIVNAM(1) Q
-	. I $D(DIVNAM)#2 S ENTITY="DIV.`"_DIVNAM Q
-	. F I=1:1:NCNT S ENTITY="DIV.`"_DIVNAM(I)_$S(ENTITY'="":U,1:"")_ENTITY
-	I ENTITY="" S ENTITY="DIV.`"_$$GET1^DIQ(8989.3,"1,",217,"I")
-	Q ENTITY
-	;
-BKUPREVW	;OPT - SET BACKUP REVIEWER(S) IN PARAMETER FILE
-	G BKUPREVW^XQALBUTL
-	;
+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
+ ;
+DELETE ;
+ N XQAFOUND,XQADAT,XQX,XQK,XQXX,XQXY,XQJ,XQAID1
+ Q:'$D(XQAID)  Q:XQAID=""  S:'$D(XQAKILL) XQAKILL=0 S:$P(XQAID,";")="NO-ID" XQAKILL=1
+ S XQADAT=$$NOW^XLFDT()
+ I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ
+ S XQAFOUND=0 D
+ . S XQX=XQAUSER F XQK=0:0 S XQK=$O(^XTV(8992,XQAUSER,"XQA",XQK)) Q:XQK'>0  I $P(^(XQK,0),U,2)=XQAID S XQAFOUND=1 Q
+ S XQXX=$O(^XTV(8992.1,"B",XQAID,0)) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQAUSER,0)) I XQXY>0,XQAFOUND,'$G(XQAUSERD) S $P(^XTV(8992.1,XQXX,20,XQXY,0),U,4)=XQADAT
+ K XQXX,XQXY
+ I '$D(^XTV(8992,"AXQA",XQAID,XQAUSER)) D KILLOC
+ F XQX=0:0 S XQX=$O(^XTV(8992,"AXQA",XQAID,XQX)) Q:XQX'>0  D  Q:XQAKILL
+ . I XQAKILL S XQX=XQAUSER ; Make sure XQAKILL gets only XQAUSER
+ . F XQK=0:0 S XQK=$O(^XTV(8992,"AXQA",XQAID,XQX,XQK)) Q:XQK'>0  K ^(XQK),^XTV(8992,"AXQAN",$P(XQAID,";"),XQX,XQK) S XQAID1=XQAID D:$D(^XTV(8992,XQX,"XQA",XQK,0)) DELA S XQAID=XQAID1
+ K XQAID,XQX,XQJ,XQK,XQAID1,XQAKILL
+ Q
+ ;
+DELETEA ;
+ N XQA1,XQADAT,XQAFOUND,XQX,XQXX,XQXY,XQK,XQJ
+ Q:'$D(XQAID)  Q:XQAID=""  S XQA1=$P(XQAID,";")
+ S XQADAT=$$NOW^XLFDT()
+ I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ
+ S:'$D(XQAKILL) XQAKILL=0 G:$P(XQAID,";")="NO-ID" DELETE
+ S XQAFOUND=0 D
+ . S XQX=XQAUSER F XQK=0:0 S XQK=$O(^XTV(8992,XQAUSER,"XQA",XQK)) Q:XQK'>0  I $P($G(^(XQK,0)),U,2)=XQAID S XQAFOUND=1 Q
+ S XQXX=$O(^XTV(8992.1,"B",XQAID,0)) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQAUSER,0)) I XQXY>0,XQAFOUND,'$G(XQAUSERD) S $P(^XTV(8992.1,XQXX,20,XQXY,0),U,4)=XQADAT
+ I '$D(^XTV(8992,"AXQAN",XQA1,XQAUSER)) D KILLOC
+ I $P(XQAID,",",2)'=""!($P(XQAID,";",2)="") F XQX=0:0 S XQX=$O(^XTV(8992,"AXQAN",XQA1,XQX)) Q:XQX'>0  D  Q:XQAKILL
+ . I XQAKILL S XQX=XQAUSER
+ . F XQK=0:0 S XQK=$O(^XTV(8992,"AXQAN",XQA1,XQX,XQK)) Q:XQK'>0  K ^(XQK) I $D(^XTV(8992,XQX,"XQA",XQK,0)) D DELA
+ I $P(XQAID,",",2)=""&($P(XQAID,";",2)'="") F XQX=0:0 S XQX=$O(^XTV(8992,"AXQA",XQAID,XQX)) Q:XQX'>0  D  Q:XQAKILL
+ . I XQAKILL S XQX=XQAUSER
+ . S XQK=$O(^XTV(8992,"AXQA",XQAID,XQX,0)) Q:XQK'>0  K ^(XQK),^XTV(8992,"AXQAN",XQA1,XQX,XQK) I $D(^XTV(8992,XQX,"XQA",XQK,0)) D DELA
+ K XQAID,XQA1,XQX,XQK,XQAKILL
+ Q
+DELA ;
+ N XQDEL11 S XQAID=$P($G(^XTV(8992,XQX,"XQA",XQK,0)),U,2),XQDEL11=$P($G(^(0)),U) K ^XTV(8992,XQX,"XQA",XQK) K:XQAID'="" ^XTV(8992,"AXQA",XQAID,XQX,XQK)
+ D COUNT(-1,XQX)
+ K:XQAID'="" ^XTV(8992,"AXQAN",$P(XQAID,";"),XQX,XQK) K:XQDEL11'="" ^XTV(8992,XQX,"XQA","B",XQDEL11,XQK)
+ S XQXX=$S(XQAID'="":$O(^XTV(8992.1,"B",XQAID,0)),1:0) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQX,0)) I XQXY>0,$P(^XTV(8992.1,XQXX,20,XQXY,0),U,5)'>0 S $P(^(0),U,5)=XQADAT I $G(XQAUSERD) S $P(^(0),U,9)=DUZ
+ K XQXX,XQXY
+ Q
+ ;
+COUNT(%1,%2) ;Change the count on the zero node, (amount, user)
+ Q:$G(%2)'>0
+ L +^XTV(8992,%2):10
+ I %1 S %=$P($G(^XTV(8992,%2,"XQA",0)),U,4)+%1 S:%'<0 $P(^(0),U,4)=%
+ I '%1 D
+ . N % S %1=0,%=0 F  S %=$O(^XTV(8992,%2,"XQA",%)) Q:%'>0  S %1=%1+1
+ . S $P(^XTV(8992,%2,"XQA",0),U,4)=%1
+ L -^XTV(8992,%2)
+ Q
+KILLOC ;
+ N XQX,XQK
+ S XQX=XQAUSER F XQK=0:0 S XQK=$O(^XTV(8992,XQAUSER,"XQA",XQK)) Q:XQK'>0  I $P(^(XQK,0),U,2)=XQAID D
+ . N XQAID D DELA
+ Q
+ ;
+OLDDEL ;
+ N XQADAT,X2,XQDAT,XQDEL1
+ S XQADAT=$$NOW^XLFDT()
+ S X2=-15 I $G(ZTQPARAM)>0 S X2=-ZTQPARAM
+ S XQDAT=$$FMADD^XLFDT(DT,X2)
+ ;Loop thru users (XQDEL1) levels
+ F XQDEL1=0:0 S XQDEL1=$O(^XTV(8992,XQDEL1)) Q:XQDEL1'>0  D OLDDEL1
+ D KILLARCH
+ K X1,X2,X,XQDEL1,XQDEL2,XQDAT,XQA,XQADAT
+ Q
+OLDDEL1 ;Loop thru the Alert (XQDEL2) level
+ L +^XTV(8992,XQDEL1):10
+ N XQAGLOB,KILLOLD,XQAZERO,XQAUSER,XQLIST,Y,XQAV,XQPRAMTY,XQDEL2,XQA
+ S XQAGLOB=$NA(^XTV(8992,XQDEL1,"XQA")),XQAUSER=XQDEL1
+ F XQDEL2=0:0 S XQDEL2=$O(@XQAGLOB@(XQDEL2)) Q:XQDEL2'>0  S XQAZERO=^(XQDEL2,0) D
+ . ; CHECK FOR BACKUP REVIEWER TO FORWARD ALERTS NEEDING ACTION -- P174
+ . I $P(XQAZERO,U,15)>0 I $$FMADD^XLFDT(+XQAZERO,+$P(XQAZERO,U,15))\1=DT D  Q:$D(KILLOLD)  ; changed '>DT to =DT so only send once without killing
+ . . N XQA D GETBKUP(.XQA,XQDEL1)
+ . . I $D(XQA) S XQALTYPE="BACKUP REVIEWER" D FORWARD^XQALFWD($P(XQAZERO,U,2),.XQA,"A","ALERT NOT PROCESSED BY "_$$GET1^DIQ(200,XQDEL1_",",.01)) S KILLOLD=1
+ . . Q  ;  End of Backup Reviewer Code -- P174
+ . I $P(XQAZERO,U,13)>0 I $$FMADD^XLFDT(+XQAZERO,+$P(XQAZERO,U,13))\1=DT D  Q:$D(KILLOLD)  ; P174
+ . . N XQA,I F I=0:0 S I=$O(^XMB(3.7,XQAUSER,9,I)) Q:I'>0  S XQAV=+^(I,0),XQA(XQAV)=XQAV
+ . . I $D(XQA) S XQALTYPE="EMAIL SURROGATE" D FORWARD^XQALFWD($P(XQAZERO,U,2),.XQA,"A","ALERT NOT PROCESSED BY "_$$GET1^DIQ(200,XQDEL1_",",.01)) S KILLOLD=1
+ . . Q
+ . I $P(XQAZERO,U,14)>0 I $$FMADD^XLFDT(+XQAZERO,+$P(XQAZERO,U,14))\1=DT D  Q:$D(KILLOLD)  ; P174
+ . . N XQA,I S I=$P($G(^VA(200,XQAUSER,5)),U) I I>0 S I=$P($G(^DIC(49,+I,0)),U,3) I I>0,$D(^VA(200,+I,0)) S XQA(+I)=+I
+ . . I $D(XQA) S XQALTYPE="CHIEF/SUPERVISOR" D FORWARD^XQALFWD($P(XQAZERO,U,2),.XQA,"A","ALERT NOT PROCESSED BY "_$$GET1^DIQ(200,XQDEL1_",",.01)) S KILLOLD=1
+ . . Q
+ . I XQDEL2'>XQDAT  D OLDDEL2
+ . Q
+ K:$O(^XTV(8992,XQDEL1,"XQA",0))="" ^XTV(8992,XQDEL1,"XQA")
+ L -^XTV(8992,XQDEL1)
+ Q
+ ;
+OLDDEL2 ;
+ N XQA,XQXX,XQXY
+ S XQA=$P(^XTV(8992,XQDEL1,"XQA",XQDEL2,0),U,2) K ^XTV(8992,XQDEL1,"XQA",XQDEL2) K:XQA'="" ^XTV(8992,"AXQA",XQA,XQDEL1),^XTV(8992,"AXQAN",$P(XQA,";"),XQDEL1)
+ D COUNT(-1,XQDEL1)
+ I XQA'="" S XQXX=$O(^XTV(8992.1,"B",XQA,0)) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQDEL1,0)) I XQXY>0 S $P(^XTV(8992.1,XQXX,20,XQXY,0),U,6)=XQADAT
+ Q
+ ;
+KILLARCH ;
+ ;  Q  ; turn off deletion from ALERT TRACKING file ; remove from XU*8*285  JLI 040624
+ N DA,DIK,XQDAT,XQDEL1,X1,X2,DA,DIK
+ S XQDAT=$$FMADD^XLFDT(DT,-30)
+ F XQDEL1=0:0 S XQDEL1=$O(^XTV(8992.1,XQDEL1)) Q:XQDEL1'>0  D
+ . 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
+ . S DIK="^XTV(8992.1," D ^DIK
+ Q
+ ;
+USERDEL ; Delete undesired alerts for a user
+ N DA,DIC,XQAUSERD
+ S DIC("A")="Select NEW PERSON entry for deletion of alerts: "
+ S DIC(0)="AEQM",DIC=200
+ D ^DIC K DIC Q:Y'>0  S XQAUSER=+Y
+ S XQALDELE=1
+ K XQX1
+ D DOIT^XQALERT1
+ K XQALDELE S XQAUSERD=1
+ I $D(XQX1),XQX1>0 D
+ . F  Q:XQX1=""  S DA=+XQX1,XQX1=$P(XQX1,",",2,99) D  I XQX1="" S Y=$O(XQX1(0)) I Y>0 S XQX1=XQX1(Y) K XQX1(Y)
+ . . S XQAID=$P(^TMP("XQ",$J,"XQA1",DA),U,2),XQAKILL=1
+ . . I XQAID="" K ^XTV(8992,XQAUSER,"XQA",+^TMP("XQ",$J,"XQA1",DA,1))
+ . . I XQAID'="" D DELETE
+ . . K ^TMP("XQ",$J,"XQA1",DA),^TMP("XQ",$J,"XQA",(999999-DA))
+ K XQAUSER,XQX1
+ Q
+ ;
+GETBKUP(XQA,XQAUSER) ;  JLI 030129 - REMOVED TO SEPARATE METHOD
+ N I,XQORY,XQENTITY,XQPARAM,XQERR,K,XQAV,XQLIST
+ S XQPARAM="XQAL BACKUP REVIEWER"
+ D GETLST^XPAR(.XQLIST,"USR.`"_XQAUSER,XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=200 ; USER
+ I '($D(XQLIST)>1) S I=$$GET1^DIQ(200,XQAUSER_",",29,"I") I I>0 D GETLST^XPAR(.XQLIST,"SRV.`"_I,XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=49 ; SERVICE
+ I '($D(XQLIST)>1) D GETLST^XPAR(.XQLIST,$$DIVENTIT(XQAUSER),XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=4 ; DIVISION
+ I '($D(XQLIST)>1) D GETLST^XPAR(.XQLIST,"SYS",XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=4.2 ; SYSTEM
+ F I=0:0 S I=$O(XQLIST(I)) Q:I'>0  S XQAV=$P(XQLIST(I),U,2),XQA(XQAV)=XQAV
+ ; Removed Teams per Curtis Anderson with CPRS
+ ;I '$D(XQA) D  ; NONE UNDER USER - CHECK FOR ENTRIES IN PARAMETER FILE FOR TEAMS
+ ;. I $T(TEAMPR^ORQPTQ1)]"" D TEAMPR^ORQPTQ1(.XQORY,XQAUSER) K:+$G(XQORY(1))<1 XQORY ; GET TEAM ID'S IF ANY ; CONTROLLED SUBSCRIPTION
+ ;. S I=0 F  S I=$O(XQORY(I)) Q:I'>0  K XQLIST D GETLST^XPAR(.XQLIST,$P(XQORY(I),U,2)_";OR(100.21,",XQPARAM,"Q",.ERR) I $D(XQTEAM) D
+ ;. . N K F K=0:0 S K=$O(XQLIST(K)) Q:K'>0  S XQAV=$P(XQLIST(K),U,2),XQA(XQAV)=XQAV
+ ;. . Q`
+ ;. Q
+ ;I '$D(XQLIST) D  ; NO TEAM ENTRIES, CHECK OTHER ENTITIES (SERVICE,DIVISION,SYSTEM)
+ ;. S XQENTITY="SYS"
+ ;. S I=$$GET1^DIQ(200,XQAUSER_",",16,"I") I I>0 S XQENTITY="DIV.`"_I_U_XQENTITY ; DIVISION
+ ;. S I=$$GET1^DIQ(200,XQAUSER_",",29,"I") I I>0 S XQENTITY="SRV.`"_I_U_XQENTITY ; SERVICE\SECTION
+ ;. D GETLST^XPAR(.XQLIST,XQENTITY,XQPARAM,"Q",.XQERR) F I=0:0 S I=$O(XQLIST(I)) Q:I'>0  S XQAV=+$P(XQLIST(I),U,2),XQA(XQAV)=XQAV
+ ;. Q
+ ;I '$D(XQA) D  ; NO PARAMETERS ENTERED - USE LAST RESORT MAIL GROUP
+ ;. S XQJ="G.XQAL UNPROCESSED ALERTS" D GROUP^XQALSET1
+ ;. I '$D(XQA) S XQJ="G.PATCH" D GROUP^XQALSET1 ; REALLY LAST RESORT
+ ;. F I=0:0 S I=$O(XQA(I)) Q:I'>0  S XQA(I)=I
+ ;. Q
+ Q
+ ;
+DIVENTIT(XQAUSER) ;
+ N ENTITY,NCNT,DIVNAM,I
+ S ENTITY="" I DUZ=XQAUSER S ENTITY="DIV.`"_DUZ(2)
+ I ENTITY="" D
+ . K NCNT,DIVNAM S NCNT=0 F I=0:0 S I=$O(^VA(200,XQAUSER,2,I)) Q:I'>0  S NCNT=NCNT+1,DIVNAM(NCNT)=+^(I,0) I $P(^(0),U,2) S DIVNAM=+^(0)
+ . I NCNT'>0 Q
+ . I NCNT=1 S ENTITY="DIV.`"_DIVNAM(1) Q
+ . I $D(DIVNAM)#2 S ENTITY="DIV.`"_DIVNAM Q
+ . F I=1:1:NCNT S ENTITY="DIV.`"_DIVNAM(I)_$S(ENTITY'="":U,1:"")_ENTITY
+ I ENTITY="" S ENTITY="DIV.`"_$$GET1^DIQ(8989.3,"1,",217,"I")
+ Q ENTITY
+ ;
+BKUPREVW ;OPT - SET BACKUP REVIEWER(S) IN PARAMETER FILE
+ G BKUPREVW^XQALBUTL
+ ;
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,162 +1,161 @@
-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
-	;;
-	Q
-	;
-DOIT	I $D(XQX1),XQX1'>0 K XQX1
-	I $D(XQAID) D  I '$D(XQAID) G EXIT
-	. N XQACHOIC,REASK S REASK=0
-	. I '$D(XQX1),$O(^XTV(8992,XQAUSER,"XQA",+$O(^XTV(8992,XQAUSER,"XQA",0))))'>0,$G(XQAROUX)="^ " S XQAROU=""
-AGAIN	. S XQACHOIC="Y:YES;N:NO;C:CONTINUE;",XQAQ("?")="Enter Y (or C) to continue, N to exit alert processing"
-	. S XQACHOIC=$G(XQACHOIC)_"F:FORWARD ALERT;R:RENEW(MAKE NEW AGAIN);" S XQAQ("?",1)="Enter F to forward this alert to someone else",XQAQ("?",2)="Enter R to Renew (Make New) this alert"
-	. D  I REASK=1 G AGAIN
-	. . S REASK=0 W !! K DIR S DIR(0)="SA^"_XQACHOIC,DIR("A")=$S(XQACHOIC["F:":"Continue (Y/N) or F(orward) or R(enew) ",1:"Continue Processing (Y/N) "),DIR("B")="YES" M DIR("?")=XQAQ("?") D ^DIR K DIR
-	. . I $D(DUOUT)!$D(DIRUT) S Y="N" K DUOUT,DIRUT
-	. . I Y="N" D:$D(XQAKILL) DELETEA^XQALERT K XQAID
-	. . I Y="R" S REASK=REASK+1 K XQAKILL I '$D(^XTV(8992,"AXQA",XQAID,DUZ)) D RESTORE
-	. . I Y="F" D:'$D(^XTV(8992,"AXQA",XQAID,DUZ)) RESTORE D FRWRDONE S REASK=REASK+1
-	. . Q
-	. Q
-	I $D(XQAKILL) D DELETEA^XQALERT
-	S XQAREV=1,XQXOUT=0,XQK=0,XQACNT=0 K XQADATA,XQAID,XQAROU,XQAKILL,XQAROUX
-	I '$D(XQX1) S XQX1=0 K ^TMP("XQ",$J,"XQA"),^("XQA1"),^("XQA2") I $O(^XTV(8992,XQAUSER,"XQA",0))'>0 K XQX1 D:'$G(^TMP("XQALERT1",$J,"NOTFIRST")) CHKSURO G:$O(^XTV(8992,XQAUSER,"XQA",0))'>0 EXIT S XQX1=0 ; P366
-	I $$ACTVSURO^XQALSURO(XQAUSER)'>0 D RETURN^XQALSUR1(XQAUSER) ; P366
-	S ^TMP("XQALERT1",$J,"NOTFIRST")=1 ; Added 2/2/99 jli to clear flag for initial entry
-	;Sort and remove display only
-	I 'XQX1 W !!! D
-	. D SORT
-	; Now display them.
-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
-	. I '$D(^XTV(8992,XQAUSER,"XQA",XQII)) S XQX="" K ^TMP("XQ",$J,"XQA",XQI),^TMP("XQ",$J,"XQA1",(999999-XQI))
-	. Q
-	S:'$D(XQXOUT) XQXOUT=0 G:XQXOUT EXIT G:XQK'>0&'XQX1 EXIT I 'XQX1 D ASK G:XQXOUT EXIT
-	G:+XQX1=0 EXIT I XQX1<0 S XQX1=0 G DOIT
-	I $D(XQALDELE)!$D(XQALFWD) Q
-	;D WAIT(+XQX1) G:XQXOUT EXIT
-	G:XQXOUT EXIT
-	G EN^XQALDOIT
-	;
-RESTORE	; Restore a deleted message for use
-	N ALERTREF,XTVGLOB,ADUZ,X,X0,X1,X2,TIME,MESG,OPT,TAG,ROU,X4,LONG
-	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 @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)=""
-	Q
-	;
-EXIT	;
-	I $G(XQALAST)="I",$G(DUZ("AUTO")) D WAIT2
-	I $D(XQALDELE)!$D(XQALFWD) Q
-	K ^TMP("XQ",$J,"XQA"),^("XQA1"),^("XQA2"),XQI,XQX,XQJ,XQK,XQX1,XQX2,XQXOUT,XQ1,XQII,XQACNT,XQA1,XQAREV,%ZIS,XQAROU,XQALAST,XQAROUX,XQON,XQOFF,XQ1ON,XQ1OFF,XQOUT,XQAQ
-	K ^TMP("XQALERT1",$J)
-	Q
-	;
-	; CHKSURO added 2/2/99 to give user opportunity to add/remove surrogate if no alerts present
-CHKSURO	; If user selects process alerts with no alerts present, give him/her the opportunity to add or delete a surrogate
-	; P366 - list currently established surrogates if any
-	I '$G(^TMP("XQALERT1",$J,"NOTFIRST")) W !!,"You have no alerts for processing.",!
-	D SURROGAT^XQALSURO ; XU*8*17
-	Q
-	;
-DOIT1	;
-	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
-	. 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)
-	S ^TMP("XQ",$J,"XQA1",XQK)=XQX,^(XQK,1)=XQII,^(2)=XQZ,^(3)=XQZ1
-	I ($Y+6)>IOSL N XQKVALUE S XQKVALUE=XQK D ASK0(XQI) S:'$D(XQK) XQK=XQKVALUE Q:XQX1!(XQXOUT)  W @IOF
-	Q
-	;
-ASK0(XQI)	;Stack XQI
-ASK	;
-	N XQALNEWF K XQALAST
-	;I '$D(XQALDELE)&'$D(XQALFWD) S XQALNEWF=$P(^XTV(8992,XQAUSER,0),U,5) I XQALNEWF<20 D
-	;. N XQALFDA
-	;. S XQALNEWF=XQALNEWF+1,XQALFDA=(8992,(XQAUSER_","),.05)=XQALNEWF D FILE^DIE("","XQALFDA")
-	;. W !,"NEW OPTIONS: S-to add/remove SURROGATE and D-to selectively Delete SOME alerts"
-	S XQ1=0,XQXOUT=0 W !?10,"Select from 1 to ",XQK W:$D(XQALDELE) " to DELETE" W:$D(XQALFWD) " to FORWARD"
-	W !?10,"or enter ?, A, " W:'$D(XQALDELE)&'$D(XQALFWD)&(XQALINFO>0) "I, D, " W:'$D(XQALDELE)&'$D(XQALFWD) "F, S, P, M, R, " W "or ^ to exit" I XQI>0,$O(^XTV(8992,XQAUSER,"XQA",XQI))>0 W !?10,"or RETURN to continue" S XQ1=1
-	R ": ",XQII:DTIME S:'$T!(XQII[U)!(XQII=""&'XQ1) XQXOUT=1 Q:XQXOUT
-	I '$D(XQALDELE)&'$D(XQALFWD),"PpMm"[$E(XQII_".") D MORP^XQALDOIT D:"Pp"[$E(XQII_".") PRINT^XQALDOIT D:"Mm"[$E(XQII_".") MAIL^XQALDOIT K ^TMP("XQ",$J,"XQA2") G ASK
-	I XQII'="",XQII["?" D HELP G ASK
-	I XQII=""&XQ1 Q
-	I "IiAaFfRrSsDd"'[$E(XQII_"."),$L(XQII)>31,$E(XQII,1,32)?1N.N W !,$C(7),"  ??  Invalid number entered",! G ASK
-	I "IiAaFfRrSsDd"'[$E(XQII_"."),(XQII<1)!(XQII>XQK) W $C(7),"  ??",! G ASK
-	I '$D(XQALDELE)&'$D(XQALFWD),"Ff"[$E(XQII) D FWRD^XQALFWD S XQX1=-2 Q  ; MODIFIED 7-6
-	I '$D(XQALDELE)&'$D(XQALFWD),"Ss"[$E(XQII) D CHKSURO S XQX1=-1 Q
-	I '$D(XQALDELE)&'$D(XQALFWD),"Dd"[$E(XQII) D ASKDEL S XQX1=-2 Q  ; MODIFIED 7-6
-	I '$D(XQALDELE),"Rr"[$E(XQII) S XQX1=-2 Q
-	I "Aa"[$E(XQII) S X="1-"_XQACNT,DIR(0)="LV^1:"_XQACNT D ^DIR K DIR,XQX1 M XQX1=Y S XQII="" K Y ;Merge list from Y
-	I XQII'="","Ii"[$E(XQII) S XQX1(0)="",XQX2=0,XQII="" F XQK=0:0 S XQK=$O(^TMP("XQ",$J,"XQA1",XQK)) S:XQK'>0 XQX1=XQX1(0) Q:XQK'>0  I $P(^(XQK),U,7,8)="^ " S XQX1(XQX2)=XQX1(XQX2)_XQK_"," S:$L(XQX1(XQX2))>240 XQX2=XQX2+1,XQX1(XQX2)=""
-	I XQII="" Q
-	S X=XQII,DIR(0)="LV^1:"_XQK D ^DIR I '$D(Y) W $C(7),"  ??" D HELP G ASK ;Use of 'LV' is special
-	K XQX1 M XQX1=Y K Y S Y=XQX1 ;Merge list from Y
-	Q
-WAIT(IFN)	;Wait for user input if last alert is INFO and next isn't.
-	N X,YY Q:$G(XQXOUT)
-	S X=$G(^TMP("XQ",$J,"XQA1",IFN)),YY=$P(X,U,7,8),YY=$S(YY="^ ":"I",YY="^":"O",1:"R")
-	I $G(XQALAST)="I","OR"[YY D WAIT2
-	I YY="I",$Y+4>IOSL D WAIT2 W @IOF
-	S XQALAST=YY
-	Q
-WAIT2	;Wait for user input before continuing
-	N DIR,Y,DIROUT,DIRUT S DIR(0)="E",DIR("?")="The next ALERT may cause the loss of info on the screen."
-	D ^DIR S:$D(DIRUT) XQXOUT=1
-	Q
-	;
-HELP	W !!,"YOU MAY ENTER:",!?3,$S(XQK>1:"One or more numbers",1:"A number")," in the range 1 to ",XQK," to select specific alert(s)"
-	W !?6,"for "_$S($D(XQALDELE):"DELETION.",$D(XQALFWD):"FORWARDING",1:"processing.") W:XQK>1 "  This may be a series of numbers, e.g., 2,3,6-9"
-	W !?3,"A to "_$S($D(XQALDELE):"DELETE",$D(XQALFWD):"FORWARD",1:"process")," all of the pending alerts in the order shown."
-	W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"I to process all of the INFORMATION ONLY alerts, if any, without further ado."
-	W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"S to add or remove a surrogate to receive alerts for you"
-	W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"F to forward one or more specific alerts.  Forwarding may be as an ALERT",!,"to specific user(s) and/or mail group(s), or as a MAIL MESSAGE, or to a",!,"specific PRINTER."
-	W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"D to delete specific alerts (some alerts may not be deleted)"
-	W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"P to print a copy of the pending alerts on a printer"
-	W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"M to receive a MailMan message containing a copy of these pending alerts"
-	W:'$D(XQALDELE) !?3,"R to Redisplay the available alerts"
-	W !?3,"^ to exit"
-	I XQI W !?5,"or RETURN to see additional pending ALERTS"
-	W !!
-	Q
-	;
-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
-	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
-	;
-ASKDEL	;
-	N XQALDELE,XQX1COPY,XQAID,DA,XQAKILL,XQXOUT,XQAUSERD,XQALVALU
-	S XQALDELE=1
-	K XQX1
-	D DOIT^XQALERT1
-	K XQALDELE S XQAUSERD=1
-	I $D(XQX1),XQX1>0 D
-	. M XQX1COPY=XQX1
-	. F  Q:XQX1=""  S DA=+XQX1,XQX1=$P(XQX1,",",2,99) D  I XQX1="" S Y=$O(XQX1(0)) I Y>0 S XQX1=XQX1(Y) K XQX1(Y)
-	. . S XQAID=$P(^TMP("XQ",$J,"XQA1",DA),U,2),XQALVALU=^(DA),XQAKILL=1
-	. . I $P(XQALVALU,U,8)=" "!$P(XQALVALU,U,10) D
-	. . . I XQAID="" K ^XTV(8992,XQAUSER,"XQA",+^TMP("XQ",$J,"XQA1",DA,1))
-	. . . I XQAID'="" D DELETE^XQALDEL
-	. . . K ^TMP("XQ",$J,"XQA1",DA),^TMP("XQ",$J,"XQA",(999999-DA))
-	. K XQX1 M XQX1=XQX1COPY S XQAID=0
-	. F  Q:XQX1=""  S DA=+XQX1,XQX1=$P(XQX1,",",2,99) D  I XQX1="" S Y=$O(XQX1(0)) I Y>0 S XQX1=XQX1(Y) K XQX1(Y)
-	. . I $D(^TMP("XQ",$J,"XQA1",DA)) W:'XQAID !!,"Unable to delete alerts which require action: ",DA W:XQAID ",",DA S XQAID=1
-	. I XQAID=1 K DIR S DIR(0)="E" D ^DIR K DIR
-	K XQX1,XQAKILL
-	Q
-	;
-FRWRDONE	;
-	N XQX1,XQALFWDL S XQALFWDL(1)=XQAID
-	N XQAID
-	D FWDONE^XQALFWD
-	Q
+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
+ ;
+DOIT I $D(XQX1),XQX1'>0 K XQX1
+ I $D(XQAID) D  I '$D(XQAID) G EXIT
+ . N XQACHOIC,REASK S REASK=0
+ . I '$D(XQX1),$O(^XTV(8992,XQAUSER,"XQA",+$O(^XTV(8992,XQAUSER,"XQA",0))))'>0,$G(XQAROUX)="^ " S XQAROU=""
+AGAIN . S XQACHOIC="Y:YES;N:NO;C:CONTINUE;",XQAQ("?")="Enter Y (or C) to continue, N to exit alert processing"
+ . S XQACHOIC=$G(XQACHOIC)_"F:FORWARD ALERT;R:RENEW(MAKE NEW AGAIN);" S XQAQ("?",1)="Enter F to forward this alert to someone else",XQAQ("?",2)="Enter R to Renew (Make New) this alert"
+ . D  I REASK=1 G AGAIN
+ . . S REASK=0 W !! K DIR S DIR(0)="SA^"_XQACHOIC,DIR("A")=$S(XQACHOIC["F:":"Continue (Y/N) or F(orward) or R(enew) ",1:"Continue Processing (Y/N) "),DIR("B")="YES" M DIR("?")=XQAQ("?") D ^DIR K DIR
+ . . I $D(DUOUT)!$D(DIRUT) S Y="N" K DUOUT,DIRUT
+ . . I Y="N" D:$D(XQAKILL) DELETEA^XQALERT K XQAID
+ . . I Y="R" S REASK=REASK+1 K XQAKILL I '$D(^XTV(8992,"AXQA",XQAID,DUZ)) D RESTORE
+ . . I Y="F" D:'$D(^XTV(8992,"AXQA",XQAID,DUZ)) RESTORE D FRWRDONE S REASK=REASK+1
+ . . Q
+ . Q
+ I $D(XQAKILL) D DELETEA^XQALERT
+ S XQAREV=1,XQXOUT=0,XQK=0,XQACNT=0 K XQADATA,XQAID,XQAROU,XQAKILL,XQAROUX
+ I '$D(XQX1) S XQX1=0 K ^TMP("XQ",$J,"XQA"),^("XQA1"),^("XQA2") I $O(^XTV(8992,XQAUSER,"XQA",0))'>0 K XQX1 D:'$G(^TMP("XQALERT1",$J,"NOTFIRST")) CHKSURO G:$O(^XTV(8992,XQAUSER,"XQA",0))'>0 EXIT S XQX1=0 ; P366
+ I $$ACTVSURO^XQALSURO(XQAUSER)'>0 D RETURN^XQALSUR1(XQAUSER) ; P366
+ S ^TMP("XQALERT1",$J,"NOTFIRST")=1 ; Added 2/2/99 jli to clear flag for initial entry
+ ;Sort and remove display only
+ I 'XQX1 W !!! D
+ . D SORT
+ ; Now display them.
+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) 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
+ S:'$D(XQXOUT) XQXOUT=0 G:XQXOUT EXIT G:XQK'>0&'XQX1 EXIT I 'XQX1 D ASK G:XQXOUT EXIT
+ G:+XQX1=0 EXIT I XQX1<0 S XQX1=0 G DOIT
+ I $D(XQALDELE)!$D(XQALFWD) Q
+ ;D WAIT(+XQX1) G:XQXOUT EXIT
+ G:XQXOUT EXIT
+ G EN^XQALDOIT
+ ;
+RESTORE ; Restore a deleted message for use
+ 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))
+ . 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)=""
+ Q
+ ;
+EXIT ;
+ I $G(XQALAST)="I",$G(DUZ("AUTO")) D WAIT2
+ I $D(XQALDELE)!$D(XQALFWD) Q
+ K ^TMP("XQ",$J,"XQA"),^("XQA1"),^("XQA2"),XQI,XQX,XQJ,XQK,XQX1,XQX2,XQXOUT,XQ1,XQII,XQACNT,XQA1,XQAREV,%ZIS,XQAROU,XQALAST,XQAROUX,XQON,XQOFF,XQ1ON,XQ1OFF,XQOUT,XQAQ
+ K ^TMP("XQALERT1",$J)
+ Q
+ ;
+ ; CHKSURO added 2/2/99 to give user opportunity to add/remove surrogate if no alerts present
+CHKSURO ; If user selects process alerts with no alerts present, give him/her the opportunity to add or delete a surrogate
+ ; P366 - list currently established surrogates if any
+ I '$G(^TMP("XQALERT1",$J,"NOTFIRST")) W !!,"You have no alerts for processing.",!
+ D SURROGAT^XQALSURO ; XU*8*17
+ Q
+ ;
+DOIT1 ;
+ 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($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)
+ S ^TMP("XQ",$J,"XQA1",XQK)=XQX,^(XQK,1)=XQII,^(2)=XQZ,^(3)=XQZ1
+ I ($Y+6)>IOSL N XQKVALUE S XQKVALUE=XQK D ASK0(XQI) S:'$D(XQK) XQK=XQKVALUE Q:XQX1!(XQXOUT)  W @IOF
+ Q
+ ;
+ASK0(XQI) ;Stack XQI
+ASK ;
+ N XQALNEWF K XQALAST
+ ;I '$D(XQALDELE)&'$D(XQALFWD) S XQALNEWF=$P(^XTV(8992,XQAUSER,0),U,5) I XQALNEWF<20 D
+ ;. N XQALFDA
+ ;. S XQALNEWF=XQALNEWF+1,XQALFDA=(8992,(XQAUSER_","),.05)=XQALNEWF D FILE^DIE("","XQALFDA")
+ ;. W !,"NEW OPTIONS: S-to add/remove SURROGATE and D-to selectively Delete SOME alerts"
+ S XQ1=0,XQXOUT=0 W !?10,"Select from 1 to ",XQK W:$D(XQALDELE) " to DELETE" W:$D(XQALFWD) " to FORWARD"
+ W !?10,"or enter ?, A, " W:'$D(XQALDELE)&'$D(XQALFWD)&(XQALINFO>0) "I, D, " W:'$D(XQALDELE)&'$D(XQALFWD) "F, S, P, M, R, " W "or ^ to exit" I XQI>0,$O(^XTV(8992,XQAUSER,"XQA",XQI))>0 W !?10,"or RETURN to continue" S XQ1=1
+ R ": ",XQII:DTIME S:'$T!(XQII[U)!(XQII=""&'XQ1) XQXOUT=1 Q:XQXOUT
+ I '$D(XQALDELE)&'$D(XQALFWD),"PpMm"[$E(XQII_".") D MORP^XQALDOIT D:"Pp"[$E(XQII_".") PRINT^XQALDOIT D:"Mm"[$E(XQII_".") MAIL^XQALDOIT K ^TMP("XQ",$J,"XQA2") G ASK
+ I XQII'="",XQII["?" D HELP G ASK
+ I XQII=""&XQ1 Q
+ I "IiAaFfRrSsDd"'[$E(XQII_"."),$L(XQII)>31,$E(XQII,1,32)?1N.N W !,$C(7),"  ??  Invalid number entered",! G ASK
+ I "IiAaFfRrSsDd"'[$E(XQII_"."),(XQII<1)!(XQII>XQK) W $C(7),"  ??",! G ASK
+ I '$D(XQALDELE)&'$D(XQALFWD),"Ff"[$E(XQII) D FWRD^XQALFWD S XQX1=-2 Q  ; MODIFIED 7-6
+ I '$D(XQALDELE)&'$D(XQALFWD),"Ss"[$E(XQII) D CHKSURO S XQX1=-1 Q
+ I '$D(XQALDELE)&'$D(XQALFWD),"Dd"[$E(XQII) D ASKDEL S XQX1=-2 Q  ; MODIFIED 7-6
+ I '$D(XQALDELE),"Rr"[$E(XQII) S XQX1=-2 Q
+ I "Aa"[$E(XQII) S X="1-"_XQACNT,DIR(0)="LV^1:"_XQACNT D ^DIR K DIR,XQX1 M XQX1=Y S XQII="" K Y ;Merge list from Y
+ I XQII'="","Ii"[$E(XQII) S XQX1(0)="",XQX2=0,XQII="" F XQK=0:0 S XQK=$O(^TMP("XQ",$J,"XQA1",XQK)) S:XQK'>0 XQX1=XQX1(0) Q:XQK'>0  I $P(^(XQK),U,7,8)="^ " S XQX1(XQX2)=XQX1(XQX2)_XQK_"," S:$L(XQX1(XQX2))>240 XQX2=XQX2+1,XQX1(XQX2)=""
+ I XQII="" Q
+ S X=XQII,DIR(0)="LV^1:"_XQK D ^DIR I '$D(Y) W $C(7),"  ??" D HELP G ASK ;Use of 'LV' is special
+ K XQX1 M XQX1=Y K Y S Y=XQX1 ;Merge list from Y
+ Q
+WAIT(IFN) ;Wait for user input if last alert is INFO and next isn't.
+ N X,YY Q:$G(XQXOUT)
+ S X=$G(^TMP("XQ",$J,"XQA1",IFN)),YY=$P(X,U,7,8),YY=$S(YY="^ ":"I",YY="^":"O",1:"R")
+ I $G(XQALAST)="I","OR"[YY D WAIT2
+ I YY="I",$Y+4>IOSL D WAIT2 W @IOF
+ S XQALAST=YY
+ Q
+WAIT2 ;Wait for user input before continuing
+ N DIR,Y,DIROUT,DIRUT S DIR(0)="E",DIR("?")="The next ALERT may cause the loss of info on the screen."
+ D ^DIR S:$D(DIRUT) XQXOUT=1
+ Q
+ ;
+HELP W !!,"YOU MAY ENTER:",!?3,$S(XQK>1:"One or more numbers",1:"A number")," in the range 1 to ",XQK," to select specific alert(s)"
+ W !?6,"for "_$S($D(XQALDELE):"DELETION.",$D(XQALFWD):"FORWARDING",1:"processing.") W:XQK>1 "  This may be a series of numbers, e.g., 2,3,6-9"
+ W !?3,"A to "_$S($D(XQALDELE):"DELETE",$D(XQALFWD):"FORWARD",1:"process")," all of the pending alerts in the order shown."
+ W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"I to process all of the INFORMATION ONLY alerts, if any, without further ado."
+ W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"S to add or remove a surrogate to receive alerts for you"
+ W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"F to forward one or more specific alerts.  Forwarding may be as an ALERT",!,"to specific user(s) and/or mail group(s), or as a MAIL MESSAGE, or to a",!,"specific PRINTER."
+ W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"D to delete specific alerts (some alerts may not be deleted)"
+ W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"P to print a copy of the pending alerts on a printer"
+ W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"M to receive a MailMan message containing a copy of these pending alerts"
+ W:'$D(XQALDELE) !?3,"R to Redisplay the available alerts"
+ W !?3,"^ to exit"
+ I XQI W !?5,"or RETURN to see additional pending ALERTS"
+ W !!
+ Q
+ ;
+SORT ;Sort and remove display only
+ 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
+ ;
+ASKDEL ;
+ N XQALDELE,XQX1COPY,XQAID,DA,XQAKILL,XQXOUT,XQAUSERD,XQALVALU
+ S XQALDELE=1
+ K XQX1
+ D DOIT^XQALERT1
+ K XQALDELE S XQAUSERD=1
+ I $D(XQX1),XQX1>0 D
+ . M XQX1COPY=XQX1
+ . F  Q:XQX1=""  S DA=+XQX1,XQX1=$P(XQX1,",",2,99) D  I XQX1="" S Y=$O(XQX1(0)) I Y>0 S XQX1=XQX1(Y) K XQX1(Y)
+ . . S XQAID=$P(^TMP("XQ",$J,"XQA1",DA),U,2),XQALVALU=^(DA),XQAKILL=1
+ . . I $P(XQALVALU,U,8)=" "!$P(XQALVALU,U,10) D
+ . . . I XQAID="" K ^XTV(8992,XQAUSER,"XQA",+^TMP("XQ",$J,"XQA1",DA,1))
+ . . . I XQAID'="" D DELETE^XQALDEL
+ . . . K ^TMP("XQ",$J,"XQA1",DA),^TMP("XQ",$J,"XQA",(999999-DA))
+ . K XQX1 M XQX1=XQX1COPY S XQAID=0
+ . F  Q:XQX1=""  S DA=+XQX1,XQX1=$P(XQX1,",",2,99) D  I XQX1="" S Y=$O(XQX1(0)) I Y>0 S XQX1=XQX1(Y) K XQX1(Y)
+ . . I $D(^TMP("XQ",$J,"XQA1",DA)) W:'XQAID !!,"Unable to delete alerts which require action: ",DA W:XQAID ",",DA S XQAID=1
+ . I XQAID=1 K DIR S DIR(0)="E" D ^DIR K DIR
+ K XQX1,XQAKILL
+ Q
+ ;
+FRWRDONE ;
+ N XQX1,XQALFWDL S XQALFWDL(1)=XQAID
+ N XQAID
+ D FWDONE^XQALFWD
+ Q
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,39 +1,33 @@
-XQALMAKE	;ISC-SF.SEA/JLI- HIGH LEVEL SETUP ALERT ;4/9/07  14:03
-	;;8.0;KERNEL;**443**;Jul 10, 1995;Build 4
-	;;
-ENTRY	;
-	W !!,"ALERT GENERATOR"
-TEXT	K XQA,XQAMSG,XQAOPT,XQAROU,DIC,DIR
-	R !!,"ON THE NEXT LINE ENTER THE TEXT TO BE DISPLAYED FOR THE ALERT ___",!,X:DTIME G:'$T!(X[U)!(X="") EXIT W !!,X S XQALX=X,DIR(0)="Y",DIR("A")="Is this text OK? ",DIR("B")="YES" D ^DIR K DIR G:'Y TEXT S XQAMSG=XQALX
-	D LOOP1 G:'$D(XQA) EXIT
-ASKOPT	S DIR(0)="Y",DIR("A")="Do you want to transfer control to an option when the alert is selected" D ^DIR K DIR I Y D GETOPT G:Y'="" SETIT G ASKOPT
-ASKROU	S DIR(0)="Y",DIR("A")="Do you want to transfer control to a routine when the alert is selected" D ^DIR K DIR G:'Y SETIT
-	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
-	W:$D(XQAROU) !!,"On selection of the alert, the user will run the routine ",XQAROU W:$D(XQAOPT) !!,"On selection of the alert, the user will be taken to the",!,"the option ",XQAOPT W !!
-	S DIR(0)="Y",DIR("A")="Is this alert what was intended",DIR("B")="YES" D ^DIR K DIR I 'Y G ENTRY
-	D SETUP^XQALERT
-	W !!?20,"ALERT IS NOW SET",!!
-	G ENTRY
-	;
-GETOPT	;
-	S DIC=19,DIC(0)="AEQM",DIC("A")="Indicate the desired OPTION: " D ^DIC K DIC S:Y'>0 Y="" S XQAOPT=$P(Y,U,2)
-	Q
-	;
-EXIT	;
-	K XQALDIC,XQALX,XQA,XQAMSG,XQAOPT,XQAROU,DIC,DIR,X,Y
-	Q
-LOOP1	K XQA R !,"Enter a User name or G.mailgroup",!,"as recipient of the Alert: ",X:DTIME S:'$T!(X="") X=U I X'[U D SETONE G:Y'>0 LOOP1
-	I X'[U F  R !,"Enter another user or G.mailgroup: ",X:DTIME  S:'$T X=U Q:X[U!(X="")  D SETONE
-	K:X[U XQA Q
-SETONE	;
-	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
+XQALMAKE ;ISC-SF.SEA/JLI- HIGH LEVEL SETUP ALERT ;9/23/94  13:28
+ ;;8.0;KERNEL;;Jul 10, 1995
+ ;;
+ENTRY ;
+ W !!,"ALERT GENERATOR"
+TEXT K XQA,XQAMSG,XQAOPT,XQAROU,DIC,DIR
+ R !!,"ON THE NEXT LINE ENTER THE TEXT TO BE DISPLAYED FOR THE ALERT ___",!,X:DTIME G:'$T!(X[U)!(X="") EXIT W !!,X S XQALX=X,DIR(0)="Y",DIR("A")="Is this text OK? ",DIR("B")="YES" D ^DIR K DIR G:'Y TEXT S XQAMSG=XQALX
+ D LOOP1 G:'$D(XQA) EXIT
+ASKOPT S DIR(0)="Y",DIR("A")="Do you want to transfer control to an option when the alert is selected" D ^DIR K DIR I Y D GETOPT G:Y'="" SETIT G ASKOPT
+ASKROU S DIR(0)="Y",DIR("A")="Do you want to transfer control to a routine when the alert is selected" D ^DIR K DIR G:'Y SETIT
+ 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 ;
+ 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
+ W:$D(XQAROU) !!,"On selection of the alert, the user will run the routine ",XQAROU W:$D(XQAOPT) !!,"On selection of the alert, the user will be taken to the",!,"the option ",XQAOPT W !!
+ S DIR(0)="Y",DIR("A")="Is this alert what was intended",DIR("B")="YES" D ^DIR K DIR I 'Y G ENTRY
+ D SETUP^XQALERT
+ W !!?20,"ALERT IS NOW SET",!!
+ G ENTRY
+ ;
+GETOPT ;
+ S DIC=19,DIC(0)="AEQM",DIC("A")="Indicate the desired OPTION: " D ^DIC K DIC S:Y'>0 Y="" S XQAOPT=$P(Y,U,2)
+ Q
+ ;
+EXIT ;
+ K XQALDIC,XQALX,XQA,XQAMSG,XQAOPT,XQAROU,DIC,DIR,X,Y
+ Q
+LOOP1 K XQA R !,"Enter a User name or G.mailgroup",!,"as recipient of the Alert: ",X:DTIME S:'$T!(X="") X=U I X'[U D SETONE G:Y'>0 LOOP1
+ I X'[U F  R !,"Enter another user or G.mailgroup: ",X:DTIME  S:'$T X=U Q:X[U!(X="")  D SETONE
+ K:X[U XQA Q
+SETONE ;
+ 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
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,159 +1,157 @@
-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
-	;;
-	Q
-	; Original entry point - throw away return value since no value expected
-SETUP	;
-	N I S I=$$SETUP1() K XQALERR
-	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.
-	; If not successful XQALERR is defined and contains reason for failure.
-	K XQALERR
-	I $O(XQA(0))="" S XQALERR="No recipient list in XQA array" Q 0
-	I '($D(XQAMSG)#2)!($G(XQAMSG)="") S XQALERR="No valid XQAMSG for display" Q 0
-	N X,XQI,XQJ,XQX,XQK,XQACOMNT,XQARESET,DA,XQADA,XQALTYPE
-	S XQALTYPE="INITIAL RECIPIENT"
-	S XQAOPT1=$S('($D(XQAROU)#2):U,XQAROU'[U:U_XQAROU,1:XQAROU),XQAOPT1=$S(XQAOPT1'=U:XQAOPT1,$D(XQAOPT)#2:XQAOPT_U,1:XQAOPT1) S:XQAOPT1=U XQAOPT1=U_" "
-NOW	S XQX=$$NOW^XLFDT()
-	S:$S('$D(XQAID):1,XQAID="":1,1:0) XQAID="NO-ID" S:XQAID[";" XQAID=$P(XQAID,";") S XQA1=XQAID,XQI=XQX
-	S XQAID=$$SETIEN(XQA1,XQX),XQADA=""
-	Q $$REENT()
-	;
-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
-	S:$D(XQACNDEL) $P(XQALIN1,U,9)=1 S:$D(XQASURO) $P(XQALIN1,U,12)=XQASURO S:$D(XQASUPV) $P(XQALIN1,U,13)=XQASUPV S:$D(XQAREVUE) $P(XQALIN1,U,14)=XQAREVUE
-	S XQALIN=XQX_U_XQALIN1,XQJ=0
-	K XQALIN1 S:$D(XQADATA) XQALIN1=XQADATA
-LOOP1	S XQJ=$O(XQA(" ")) I XQJ'="" K:"G.g."'[$E(XQJ_",,",1,2) XQA(XQJ) D:$D(XQA(XQJ)) GROUP^XQALSET1 G LOOP1
-LOOP2	; RE-ENTRY FOR FORWARDING IF ALL RECIPIENTS ARE UNDELIVERABLE
-	N:'$D(XQAUSER) XQAUSER M XQALIST=XQA F I=0:0 S I=$O(XQALIST(I)) Q:I'>0  S XQALIST(I,XQALTYPE)="" I '$D(XQAUSER) S XQAUSER=I ; SAVE ORIGINAL LIST OF RECIPIENTS AND REASON
-	; The following section of code was added to provide a generalized way to handle surrogates
-	F XQJ=0:0 S XQJ=$O(XQA(XQJ)) Q:XQJ=""  D
-	. N X S X=$$ACTVSURO^XQALSURO(XQJ) I X>0 D  ; Modified to get final surrogate if a sequence of them
-	. . S XQA(X)="" K XQA(XQJ) ; Add Surrogate to XQA array, delete XQJ entry
-	. . S XQALIST(X,$O(XQALIST(XQJ,""))_"-SURROGATE")="" ; Add Surrogate to XQALIST with same type as original
-	. . S XQALIST(X,"z AS_SURO",XQJ)="" ; Mark user as in list as a surrogate, subscript for surrogate to
-	. . S XQALIST(XQJ,"z TO_SURO",X)=""
-	. . Q
-	. Q
-	;
-	S XQJ=0
-LOOP	;
-	S XQJ=$O(XQA(XQJ)) G:XQJ="" WRAP
-	;
-	I '(+$$ACTIVE^XUSER(XQJ)) K XQA(XQJ) N XX S XX=$O(XQALIST(XQJ,"")) K XQALIST(XQJ,XX) S XQALIST(XQJ,XX_"-UNDELIVERABLE")="" G LOOP ;Don't send to users that can't sign-on
-	;
-	I '$D(^XTV(8992,XQJ,0)) D  I '$D(^XTV(8992,XQJ,0)) S ^(0)=XQJ
-	. N FDA,IENS
-	. F  D  Q:'$D(DIERR)  Q:'$D(^TMP("DIERR",$J,"E",110))&'$D(^TMP("DIERR",$J,"E",111))
-	. . K DIERR,^TMP("DIERR",$J)
-	. . S FDA=$NA(^TMP($J,"XQALSET")) K @FDA S @FDA@(8992,"+1,",.01)=XQJ
-	. . S IENS(1)=XQJ
-	. . D UPDATE^DIE("S",FDA,"IENS")
-	. . Q
-	. Q
-	L +^XTV(8992,XQJ):10 S XQXI=XQX S:'$D(^XTV(8992,XQJ,"XQA",0)) ^(0)="^8992.01DA^"
-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
-	L -^XTV(8992,XQJ)
-	K XQA(XQJ) S:XQAID'="" ^XTV(8992,"AXQA",XQAID,XQJ,XQXI)="",^XTV(8992,"AXQAN",XQA1,XQJ,XQXI)=""
-	S XQNRECIP=XQNRECIP+1
-	G LOOP
-	;
-WRAP	;
-	M XQALIST1=XQALIST
-	I XQNRECIP=0,'$$SNDNACTV(XQAID) S RETVAL=0,XQALERR="NO ACTIVE RECIPIENTS - OLDER TIU ALERTS"
-	E  I XQNRECIP=0 D  I $D(XQA) S XQACOMNT=$E("None of recipients were active users. "_$G(XQACOMNT),1,245),XQNRECIP=1,XQARESET=1 K XQALIST G LOOP2 ; SET NUMBER OF RECIPIENTS TO 1 SO WE WON'T COME HERE AGAIN
-	. N XQAA,XQJ F XQI=0:0 S XQI=$O(XQALIST(XQI)) Q:XQI'>0  D GETBKUP^XQALDEL(.XQAA,XQI) S XQALTYPE="BACKUP REVIEWER" F XQJ=0:0 S XQJ=$O(XQAA(XQJ)) Q:XQJ'>0  S XQA(XQAA(XQJ))=""
-	. I $D(XQA) D CHEKACTV^XQALSET1(.XQA)
-	. I '$D(XQA) S XQJ="G.XQAL UNPROCESSED ALERTS" D GROUP^XQALSET1 S XQALTYPE="UNPROCESSED ALERTS MAIL GROUP" ;D GETMLGRP(.XQA,XQI) ; COULDN'T FIND ANY BACKUP, GET A MAILGROUP AND MEMBERS TO SEND IT TO
-	. I '$D(XQA) S XQJ="G.PATCHES" D GROUP^XQALSET1 S XQALTYPE="LAST HOPE" ; Last gasp, send it to G.PATCHES
-	. I '$D(XQA) S XQJ="G.PATCH" D GROUP^XQALSET1 S XQALTYPE="LAST HOPE" ; Last gasp, send it to G.PATCH
-	. I '$D(XQA) S RETVAL=0,XQALERR="Could not find any active user to send it to" ; Should not get here, this is only if all backups and mail groups tried don't have any active users
-	. Q
-	; END OF JLI 030129 INSERTION P285
-	; moved recording of users in Alert Tracking file to here to include all of them  030220
-	; modified code to use FM calls instead of direct global references
-	I RETVAL,$G(XQADA)'>0,XQAID'="" D SETTRACK ; moved to here to avoid tracking entries with no users
-	;
-	I RETVAL,$G(XQADA)>0 L +^XTV(8992.1,XQADA):10 D  L -^XTV(8992.1,XQADA) ; 030131
-	. F XQJ=0:0 S XQJ=$O(XQALIST1(XQJ)) Q:XQJ'>0  D
-	. . N NCOUNT,SUBSCRPT,SUBSCRPN,KCNT,IENVAL
-	. . S IENVAL=XQADA_",",KCNT=$$FIND1^DIC(8992.11,","_IENVAL,"Q",XQJ)
-	. . S FDA=$NA(^TMP($J,"XQALSET")) K @FDA I KCNT=0 S @FDA@(8992.11,"+1,"_IENVAL,.01)=XQJ,KCNT="+1"
-	. . S IENVAL=","_KCNT_","_IENVAL,NCOUNT=1 S SUBSCRPT="" F  S SUBSCRPT=$O(XQALIST1(XQJ,SUBSCRPT)) Q:SUBSCRPT=""  I $E(SUBSCRPT,1)'="z" D
-	. . . S SUBSCRPN=$$FIND1^DIC(8992.2,"","X",SUBSCRPT) I SUBSCRPN'>0 D
-	. . . . N FDA1,IENROOT S FDA1=$NA(^TMP($J,"XQALSET1")) K @FDA1 S @FDA1@(8992.2,"+1,",.01)=SUBSCRPT D UPDATE^DIE("",FDA1,"IENROOT") S SUBSCRPN=$G(IENROOT(1))
-	. . . . Q
-	. . . S NCOUNT=NCOUNT+1,@FDA@(8992.111,"+"_NCOUNT_IENVAL,.01)=SUBSCRPN,@FDA@(8992.111,"+"_NCOUNT_IENVAL,.04)=XQADATIM
-	. . . Q
-	. . I $D(XQALIST1(XQJ,"z TO_SURO")) S @FDA@(8992.111,"+"_NCOUNT_IENVAL,.02)=$O(XQALIST1(XQJ,"z TO_SURO",0))
-	. . I $D(XQALIST1(XQJ,"z AS_SURO")) D
-	. . . S @FDA@(8992.111,"+"_NCOUNT_IENVAL,.03)="Y"
-	. . . N XQK S NCOUNT=NCOUNT+1 F XQK=0:0 S XQK=$O(XQALIST1(XQJ,"z AS_SURO",XQK)) Q:XQK'>0  S @FDA@(8992.113,"+"_NCOUNT_IENVAL,.01)=XQK,@FDA@(8992.113,"+"_NCOUNT_IENVAL,.02)=XQADATIM
-	. . . Q
-	. . S SUBSCRPT=$O(XQALIST1(XQJ,"")) I SUBSCRPT'["INITIAL" S SUBSCRPT=$P(SUBSCRPT,"-") D  ; FORWARDING
-	. . . S SUBSCRPN=$$FIND1^DIC(8992.2,"","X",SUBSCRPT) I SUBSCRPN'>0 D
-	. . . . N FDA1,IENROOT S FDA1=$NA(^TMP($J,"XQALSET1")) K @FDA1 S @FDA1@(8992.2,"+1,",.01)=SUBSCRPT D UPDATE^DIE("",FDA1,"IENROOT") S SUBSCRPN=$G(IENROOT(1))
-	. . . . Q
-	. . . S NCOUNT=NCOUNT+1,@FDA@(8992.112,"+"_NCOUNT_IENVAL,.01)=XQADATIM,@FDA@(8992.112,"+"_NCOUNT_IENVAL,.02)=SUBSCRPN I $G(XQACOMNT)'="" S @FDA@(8992.112,"+"_NCOUNT_IENVAL,1.01)=XQACOMNT
-	. . . I $G(XQAUSER)>0 S @FDA@(8992.112,"+"_NCOUNT_IENVAL,.03)=XQAUSER
-	. . . Q
-	. . N IENSTR D UPDATE^DIE("",FDA,"IENSTR")
-	. . Q
-	. Q
-	;
-	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
-	;
-SNDNACTV(XQAID)	; Determine if we go ahead and send alerts addressed only to inactive users to backup reviewers
-	N XVAL
-	I $E(XQAID,1,3)="TIU" S XVAL=$E($P(XQAID,";"),4,99),XVAL=$$GET1^DIQ(8925,XVAL_",",1201,"I") I XVAL>0,$$FMDIFF^XLFDT(DT,XVAL)>60 Q 0
-	Q 1
-	;
-SETIEN(XQA1,XQI)	; determine unique XQAID value for alert
-	N XQAID
-	S:$G(XQA1)="" XQA1="NO-ID" F  S XQAID=XQA1_";"_DUZ_";"_XQI L +^XTV(8992,"AXQA",XQAID):10 D  L -^XTV(8992,"AXQA",XQAID) Q:XQI=""  S XQI=XQI+.00000001
-	. I $D(^XTV(8992,"AXQA",XQAID)) Q
-	. S ^XTV(8992,"AXQA",XQAID,0,0)="",XQI=""
-	. Q
-	Q XQAID
-	;
-SETTRACK	; Setup entry in Alert Tracking file
-	; Note: if there are error messages or we can't create an entry for some reason, it simply returns and continues
-	N FDA,IENS,XQA2,DIERR
-	S XQADA=0
-	S XQA2=XQA1 I XQA2[",",$P(XQA2,",",3)'="" S XQA2=$P(XQA2,",")_","_$P(XQA2,",",3)
-	F  D  Q:'$D(DIERR)  Q:'$D(^TMP("DIERR",$J,"E",111))
-	. K DIERR,^TMP("DIERR",$J)
-	. S FDA=$NA(^TMP($J,"XQALSET")) K @FDA
-	. S @FDA@(8992.1,"+1,",.01)=XQAID D UPDATE^DIE("",FDA,"IENS")
-	. K @FDA
-	. Q
-	I $D(DIERR) Q  ;S XQDIERR1=DIERR M XQDIERR=^TMP("DIERR",$J) Q
-	Q:IENS(1)'>0  S (DA,XQADA)=IENS(1)
-	S IENS=IENS(1)_",",@FDA@(8992.1,IENS,.02)=XQX,^(.03)=XQA2,^(.05)=DUZ,^(1.01)=XQAMSG
-	I $D(XQAARCH) S X=$$FMADD^XLFDT(DT,XQAARCH) I X>DT S @FDA@(8992.1,IENS,.08)=X
-	I $P(XQA1,",")="OR",$P(XQA1,",",2)>0 S @FDA@(8992.1,IENS,.04)=$P(XQA1,",",2)
-	I $D(ZTQUEUED) S @FDA@(8992.1,IENS,.06)=1
-	I $D(XQAOPT)#2 S @FDA@(8992.1,IENS,1.02)=XQAOPT
-	I $D(XQAROU)#2 N XQAXX S XQAXX=$S(XQAROU[U:XQAROU,1:U_XQAROU) I $P(XQAXX,U,2)'="" S:$P(XQAXX,U)'="" @FDA@(8992.1,IENS,1.03)=$P(XQAXX,U) S @FDA@(8992.1,IENS,1.04)=$P(XQAXX,U,2)
-	I $D(XQACTMSG) S @FDA@(8992.1,IENS,1.05)=XQACTMSG
-	I $D(XQADATA) S @FDA@(8992.1,IENS,2)=XQADATA
-	I $D(XQAGUID) S @FDA@(8992.1,IENS,3.01)=XQAGUID
-	I $D(XQADFN) S @FDA@(8992.1,IENS,.04)=XQADFN
-	D FILE^DIE("KS",FDA)
-	I $D(XQATEXT) D WP^DIE(8992.1,IENS,4,"","XQATEXT")
-	Q
-	;
-CHEKUSER(XQAUSER)	; .SR Returns 0 if no valid user or surrogate, otherwise returns IEN of user or surrogate
-	Q $$CHEKUSER^XQALSET1(XQAUSER)
-	;
+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
+ ; Original entry point - throw away return value since no value expected
+SETUP ;
+ N I S I=$$SETUP1() K XQALERR
+ 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. 
+ ; If not successful XQALERR is defined and contains reason for failure.
+ K XQALERR
+ I $O(XQA(0))="" S XQALERR="No recipient list in XQA array" Q 0
+ I '($D(XQAMSG)#2)!($G(XQAMSG)="") S XQALERR="No valid XQAMSG for display" Q 0
+ N X,XQI,XQJ,XQX,XQK,XQACOMNT,XQARESET,DA,XQADA,XQALTYPE
+ S XQALTYPE="INITIAL RECIPIENT"
+ S XQAOPT1=$S('($D(XQAROU)#2):U,XQAROU'[U:U_XQAROU,1:XQAROU),XQAOPT1=$S(XQAOPT1'=U:XQAOPT1,$D(XQAOPT)#2:XQAOPT_U,1:XQAOPT1) S:XQAOPT1=U XQAOPT1=U_" "
+NOW S XQX=$$NOW^XLFDT()
+ S:$S('$D(XQAID):1,XQAID="":1,1:0) XQAID="NO-ID" S:XQAID[";" XQAID=$P(XQAID,";") S XQA1=XQAID,XQI=XQX
+ S XQAID=$$SETIEN(XQA1,XQX),XQADA=""
+ Q $$REENT()
+ ;
+REENT() ; Entry for forwarding, etc.
+ N RETVAL S RETVAL=1
+ 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
+ S:$D(XQACNDEL) $P(XQALIN1,U,9)=1 S:$D(XQASURO) $P(XQALIN1,U,12)=XQASURO S:$D(XQASUPV) $P(XQALIN1,U,13)=XQASUPV S:$D(XQAREVUE) $P(XQALIN1,U,14)=XQAREVUE
+ S XQALIN=XQX_U_XQALIN1,XQJ=0
+ K XQALIN1 S:$D(XQADATA) XQALIN1=XQADATA
+LOOP1 S XQJ=$O(XQA(" ")) I XQJ'="" K:"G.g."'[$E(XQJ_",,",1,2) XQA(XQJ) D:$D(XQA(XQJ)) GROUP^XQALSET1 G LOOP1
+LOOP2 ; RE-ENTRY FOR FORWARDING IF ALL RECIPIENTS ARE UNDELIVERABLE
+ N:'$D(XQAUSER) XQAUSER M XQALIST=XQA F I=0:0 S I=$O(XQALIST(I)) Q:I'>0  S XQALIST(I,XQALTYPE)="" I '$D(XQAUSER) S XQAUSER=I ; SAVE ORIGINAL LIST OF RECIPIENTS AND REASON
+ ; The following section of code was added to provide a generalized way to handle surrogates
+ F XQJ=0:0 S XQJ=$O(XQA(XQJ)) Q:XQJ=""  D
+ . N X S X=$$ACTVSURO^XQALSURO(XQJ) I X>0 D  ; Modified to get final surrogate if a sequence of them
+ . . S XQA(X)="" K XQA(XQJ) ; Add Surrogate to XQA array, delete XQJ entry
+ . . S XQALIST(X,$O(XQALIST(XQJ,""))_"-SURROGATE")="" ; Add Surrogate to XQALIST with same type as original
+ . . S XQALIST(X,"z AS_SURO",XQJ)="" ; Mark user as in list as a surrogate, subscript for surrogate to
+ . . S XQALIST(XQJ,"z TO_SURO",X)=""
+ . . Q
+ . Q
+ ;
+ S XQJ=0
+LOOP ;
+ S XQJ=$O(XQA(XQJ)) G:XQJ="" WRAP
+ ;
+ I '(+$$ACTIVE^XUSER(XQJ)) K XQA(XQJ) N XX S XX=$O(XQALIST(XQJ,"")) K XQALIST(XQJ,XX) S XQALIST(XQJ,XX_"-UNDELIVERABLE")="" G LOOP ;Don't send to users that can't sign-on
+ ;
+ I '$D(^XTV(8992,XQJ,0)) D  I '$D(^XTV(8992,XQJ,0)) S ^(0)=XQJ
+ . N FDA,IENS
+ . F  D  Q:'$D(DIERR)  Q:'$D(^TMP("DIERR",$J,"E",110))&'$D(^TMP("DIERR",$J,"E",111))
+ . . K DIERR,^TMP("DIERR",$J)
+ . . S FDA=$NA(^TMP($J,"XQALSET")) K @FDA S @FDA@(8992,"+1,",.01)=XQJ
+ . . S IENS(1)=XQJ
+ . . D UPDATE^DIE("S",FDA,"IENS")
+ . . Q
+ . Q
+ L +^XTV(8992,XQJ):10 S XQXI=XQX S:'$D(^XTV(8992,XQJ,"XQA",0)) ^(0)="^8992.01DA^"
+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) 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)=""
+ S XQNRECIP=XQNRECIP+1
+ G LOOP
+ ;
+WRAP ;
+ M XQALIST1=XQALIST
+ I XQNRECIP=0,'$$SNDNACTV(XQAID) S RETVAL=0,XQALERR="NO ACTIVE RECIPIENTS - OLDER TIU ALERTS"
+ E  I XQNRECIP=0 D  I $D(XQA) S XQACOMNT=$E("None of recipients were active users. "_$G(XQACOMNT),1,245),XQNRECIP=1,XQARESET=1 K XQALIST G LOOP2 ; SET NUMBER OF RECIPIENTS TO 1 SO WE WON'T COME HERE AGAIN
+ . N XQAA,XQJ F XQI=0:0 S XQI=$O(XQALIST(XQI)) Q:XQI'>0  D GETBKUP^XQALDEL(.XQAA,XQI) S XQALTYPE="BACKUP REVIEWER" F XQJ=0:0 S XQJ=$O(XQAA(XQJ)) Q:XQJ'>0  S XQA(XQAA(XQJ))=""
+ . I $D(XQA) D CHEKACTV^XQALSET1(.XQA)
+ . I '$D(XQA) S XQJ="G.XQAL UNPROCESSED ALERTS" D GROUP^XQALSET1 S XQALTYPE="UNPROCESSED ALERTS MAIL GROUP" ;D GETMLGRP(.XQA,XQI) ; COULDN'T FIND ANY BACKUP, GET A MAILGROUP AND MEMBERS TO SEND IT TO
+ . I '$D(XQA) S XQJ="G.PATCHES" D GROUP^XQALSET1 S XQALTYPE="LAST HOPE" ; Last gasp, send it to G.PATCHES
+ . I '$D(XQA) S XQJ="G.PATCH" D GROUP^XQALSET1 S XQALTYPE="LAST HOPE" ; Last gasp, send it to G.PATCH
+ . I '$D(XQA) S RETVAL=0,XQALERR="Could not find any active user to send it to" ; Should not get here, this is only if all backups and mail groups tried don't have any active users
+ . Q
+ ; END OF JLI 030129 INSERTION P285
+ ; moved recording of users in Alert Tracking file to here to include all of them  030220
+ ; modified code to use FM calls instead of direct global references
+ I RETVAL,$G(XQADA)'>0,XQAID'="" D SETTRACK ; moved to here to avoid tracking entries with no users
+ ;
+ I RETVAL,$G(XQADA)>0 L +^XTV(8992.1,XQADA):10 D  L -^XTV(8992.1,XQADA) ; 030131
+ . F XQJ=0:0 S XQJ=$O(XQALIST1(XQJ)) Q:XQJ'>0  D
+ . . N NCOUNT,SUBSCRPT,SUBSCRPN,KCNT,IENVAL
+ . . S IENVAL=XQADA_",",KCNT=$$FIND1^DIC(8992.11,","_IENVAL,"Q",XQJ)
+ . . S FDA=$NA(^TMP($J,"XQALSET")) K @FDA I KCNT=0 S @FDA@(8992.11,"+1,"_IENVAL,.01)=XQJ,KCNT="+1"
+ . . S IENVAL=","_KCNT_","_IENVAL,NCOUNT=1 S SUBSCRPT="" F  S SUBSCRPT=$O(XQALIST1(XQJ,SUBSCRPT)) Q:SUBSCRPT=""  I $E(SUBSCRPT,1)'="z" D
+ . . . S SUBSCRPN=$$FIND1^DIC(8992.2,"","X",SUBSCRPT) I SUBSCRPN'>0 D
+ . . . . N FDA1,IENROOT S FDA1=$NA(^TMP($J,"XQALSET1")) K @FDA1 S @FDA1@(8992.2,"+1,",.01)=SUBSCRPT D UPDATE^DIE("",FDA1,"IENROOT") S SUBSCRPN=$G(IENROOT(1))
+ . . . . Q
+ . . . S NCOUNT=NCOUNT+1,@FDA@(8992.111,"+"_NCOUNT_IENVAL,.01)=SUBSCRPN,@FDA@(8992.111,"+"_NCOUNT_IENVAL,.04)=XQADATIM
+ . . . Q
+ . . I $D(XQALIST1(XQJ,"z TO_SURO")) S @FDA@(8992.111,"+"_NCOUNT_IENVAL,.02)=$O(XQALIST1(XQJ,"z TO_SURO",0))
+ . . I $D(XQALIST1(XQJ,"z AS_SURO")) D
+ . . . S @FDA@(8992.111,"+"_NCOUNT_IENVAL,.03)="Y"
+ . . . N XQK S NCOUNT=NCOUNT+1 F XQK=0:0 S XQK=$O(XQALIST1(XQJ,"z AS_SURO",XQK)) Q:XQK'>0  S @FDA@(8992.113,"+"_NCOUNT_IENVAL,.01)=XQK,@FDA@(8992.113,"+"_NCOUNT_IENVAL,.02)=XQADATIM
+ . . . Q
+ . . S SUBSCRPT=$O(XQALIST1(XQJ,"")) I SUBSCRPT'["INITIAL" S SUBSCRPT=$P(SUBSCRPT,"-") D  ; FORWARDING
+ . . . S SUBSCRPN=$$FIND1^DIC(8992.2,"","X",SUBSCRPT) I SUBSCRPN'>0 D
+ . . . . N FDA1,IENROOT S FDA1=$NA(^TMP($J,"XQALSET1")) K @FDA1 S @FDA1@(8992.2,"+1,",.01)=SUBSCRPT D UPDATE^DIE("",FDA1,"IENROOT") S SUBSCRPN=$G(IENROOT(1))
+ . . . . Q
+ . . . S NCOUNT=NCOUNT+1,@FDA@(8992.112,"+"_NCOUNT_IENVAL,.01)=XQADATIM,@FDA@(8992.112,"+"_NCOUNT_IENVAL,.02)=SUBSCRPN I $G(XQACOMNT)'="" S @FDA@(8992.112,"+"_NCOUNT_IENVAL,1.01)=XQACOMNT
+ . . . I $G(XQAUSER)>0 S @FDA@(8992.112,"+"_NCOUNT_IENVAL,.03)=XQAUSER
+ . . . Q
+ . . N IENSTR D UPDATE^DIE("",FDA,"IENSTR")
+ . . Q
+ . Q
+ ;
+ I RETVAL S RETVAL=RETVAL_U_$G(XQADA)_U_XQAID
+ K:XQAID'="" ^XTV(8992,"AXQA",XQAID,0,0)
+ 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
+ ;
+SNDNACTV(XQAID) ; Determine if we go ahead and send alerts addressed only to inactive users to backup reviewers
+ N XVAL
+ I $E(XQAID,1,3)="TIU" S XVAL=$E($P(XQAID,";"),4,99),XVAL=$$GET1^DIQ(8925,XVAL_",",1201,"I") I XVAL>0,$$FMDIFF^XLFDT(DT,XVAL)>60 Q 0
+ Q 1
+ ;
+SETIEN(XQA1,XQI) ; determine unique XQAID value for alert
+ N XQAID
+ S:$G(XQA1)="" XQA1="NO-ID" F  S XQAID=XQA1_";"_DUZ_";"_XQI L +^XTV(8992,"AXQA",XQAID):10 D  L -^XTV(8992,"AXQA",XQAID) Q:XQI=""  S XQI=XQI+.00000001
+ . I $D(^XTV(8992,"AXQA",XQAID)) Q
+ . S ^XTV(8992,"AXQA",XQAID,0,0)="",XQI=""
+ . Q
+ Q XQAID
+ ;
+SETTRACK ; Setup entry in Alert Tracking file
+ ; Note: if there are error messages or we can't create an entry for some reason, it simply returns and continues
+ N FDA,IENS,XQA2,DIERR
+ S XQADA=0
+ S XQA2=XQA1 I XQA2[",",$P(XQA2,",",3)'="" S XQA2=$P(XQA2,",")_","_$P(XQA2,",",3)
+ F  D  Q:'$D(DIERR)  Q:'$D(^TMP("DIERR",$J,"E",111))
+ . K DIERR,^TMP("DIERR",$J)
+ . S FDA=$NA(^TMP($J,"XQALSET")) K @FDA
+ . S @FDA@(8992.1,"+1,",.01)=XQAID D UPDATE^DIE("",FDA,"IENS")
+ . K @FDA
+ . Q
+ I $D(DIERR) Q  ;S XQDIERR1=DIERR M XQDIERR=^TMP("DIERR",$J) Q
+ Q:IENS(1)'>0  S (DA,XQADA)=IENS(1)
+ S IENS=IENS(1)_",",@FDA@(8992.1,IENS,.02)=XQX,^(.03)=XQA2,^(.05)=DUZ,^(1.01)=XQAMSG
+ I $D(XQAARCH) S X=$$FMADD^XLFDT(DT,XQAARCH) I X>DT S @FDA@(8992.1,IENS,.08)=X
+ I $P(XQA1,",")="OR",$P(XQA1,",",2)>0 S @FDA@(8992.1,IENS,.04)=$P(XQA1,",",2)
+ I $D(ZTQUEUED) S @FDA@(8992.1,IENS,.06)=1
+ I $D(XQAOPT)#2 S @FDA@(8992.1,IENS,1.02)=XQAOPT
+ I $D(XQAROU)#2 N XQAXX S XQAXX=$S(XQAROU[U:XQAROU,1:U_XQAROU) I $P(XQAXX,U,2)'="" S:$P(XQAXX,U)'="" @FDA@(8992.1,IENS,1.03)=$P(XQAXX,U) S @FDA@(8992.1,IENS,1.04)=$P(XQAXX,U,2)
+ I $D(XQACTMSG) S @FDA@(8992.1,IENS,1.05)=XQACTMSG
+ I $D(XQADATA) S @FDA@(8992.1,IENS,2)=XQADATA
+ I $D(XQAGUID) S @FDA@(8992.1,IENS,3.01)=XQAGUID
+ I $D(XQADFN) S @FDA@(8992.1,IENS,.04)=XQADFN
+ D FILE^DIE("KS",FDA)
+ I $D(XQATEXT) D WP^DIE(8992.1,IENS,4,"","XQATEXT")
+ Q
+ ;
+CHEKUSER(XQAUSER) ; .SR Returns 0 if no valid user or surrogate, otherwise returns IEN of user or surrogate
+ Q $$CHEKUSER^XQALSET1(XQAUSER)
+ ;
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,34 +1,33 @@
-XQALSET1	;ISC-SF.SEA/JLI - SETUP ALERTS (OVERFLOW) ;4/9/07  10:26
-	;;8.0;KERNEL;**285,443**;Jul 10, 1995;Build 4
-	;;
-	Q
-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 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
-	. N XQI F XQI=0:0 S XQI=$O(@XQLIST@("ID",XQI)) Q:XQI'>0  S XQA(^(XQI,.01))=""
-	. 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
-	. Q
-	K @XQLIST,XQLIST
-	K XQA(XQJ)
-	D CHEKACTV(.XQA)
-	Q
-	;
-	; Check and remove any entries in array that don't have active surrogates and aren't active
-CHEKACTV(XQARRAY)	;
-	N XQJ
-	F XQJ=0:0 S XQJ=$O(XQARRAY(XQJ)) Q:XQJ'>0  I $$CHEKUSER(XQJ)'>0 K XQARRAY(XQJ)
-	Q
-	;
-CHEKUSER(XQAUSER)	; Returns 0 if no valid user or surrogate, otherwise returns IEN of user or surrogate
-	N VALUE
-	S VALUE=$$ACTVSURO^XQALSURO(XQAUSER)
-	I VALUE'>0 S VALUE=XQAUSER I '$$ACTIVE^XUSER(XQAUSER) Q 0
-	Q VALUE
-	;
+XQALSET1 ;ISC-SF.SEA/JLI - SETUP ALERTS (OVERFLOW) ;10/20/03  15:03
+ ;;8.0;KERNEL;**285**;Jul 10, 1995
+ ;;
+ Q
+GROUP ; 
+ N XQI,XQL,XQL1,XQL2,XQLIST
+ 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
+ . N XQI F XQI=0:0 S XQI=$O(@XQLIST@("ID",XQI)) Q:XQI'>0  S XQA(^(XQI,.01))=""
+ . Q
+ K @XQLIST,XQLIST D LIST^DIC(3.811,","_XQI_",",".01",,,,,,,,.XQLIST) I XQLIST("ORDER")>0 D
+ . 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 XQA(XQJ)
+ D CHEKACTV(.XQA)
+ Q
+ ;
+ ; Check and remove any entries in array that don't have active surrogates and aren't active
+CHEKACTV(XQARRAY) ;
+ N XQJ
+ F XQJ=0:0 S XQJ=$O(XQARRAY(XQJ)) Q:XQJ'>0  I $$CHEKUSER(XQJ)'>0 K XQARRAY(XQJ)
+ Q
+ ;
+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)
+ I VALUE'>0 S VALUE=XQAUSER I '$$ACTIVE^XUSER(XQAUSER) Q 0
+ Q VALUE
+ ;
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,168 +1,169 @@
-XQALSUR1	;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ;11/21/07  08:35
-	;;8.0;KERNEL;**366,443**;Jul 10, 1995;Build 4
-	Q
-	;
-RETURN(XQAUSER)	; P366 - return alerts to the user
-	N XQAI,X0,XQASTRT,XQASURO,XQAEND
-	; identify periods in the surrogate multiple that haven't been returned
-	F XQAI=0:0 S XQAI=$O(^XTV(8992,XQAUSER,2,"AC",1,XQAI)) Q:XQAI'>0  S X0=^XTV(8992,XQAUSER,2,XQAI,0) I $P(X0,U,4)=1 D
-	. S XQASTRT=$P(X0,U) S XQAEND=$P(X0,U,3)
-	. ; and clear the flag indicating we need to restore these alerts
-	. N XQAFDA S XQAFDA(8992.02,XQAI_","_XQAUSER_",",.04)="@" D FILE^DIE("","XQAFDA")
-	. ; restore alerts to intended user, remove from surrogate if completed (i.e., no other surrogates and not intended recipient)
-	. D PUSHBACK(XQAUSER,XQASTRT,XQAEND)
-	. Q
-	Q
-	;
-PUSHBACK(XQAUSER,XQASTRT,XQAEND)	; P366 - identify alerts in alert tracking file for return and return them
-	N XQAINIT,XQAI,X0,X30,XNOSURO,XQADT,XQAJ,XQAK,XQAL,XQAOTH,XQASUROP
-	S XQAINIT=$$FIND1^DIC(8992.2,,"X","INITIAL RECIPIENT")
-	F XQADT=XQASTRT-.0000001:0 S XQADT=$O(^XTV(8992.1,"AUD",XQAUSER,XQADT)) Q:XQADT'>0  Q:XQADT>XQAEND  F XQAI=0:0 S XQAI=$O(^XTV(8992.1,"AUD",XQAUSER,XQADT,XQAI)) Q:XQAI'>0  D
-	. S XQAJ=$O(^XTV(8992.1,XQAI,20,"B",XQAUSER,0)) Q:XQAJ'>0
-	. N XSURO,XNOSURO,XQAID S XNOSURO=0,XQAID=$P(^XTV(8992.1,XQAI,0),U)
-	. F XQAK=0:0 S XQAK=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK)) Q:XQAK'>0  F XQAL=0:0 S XQAL=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK,XQAL)) Q:XQAL'>0  D
-	. . S X0=^XTV(8992.1,XQAI,20,XQAJ,1,XQAL,0) S:$P(X0,U,2)>0 XSURO($P(X0,U,2))="" S:$P(X0,U,2)'>0 XNOSURO=1 ; sent to XSURO as surrogate
-	. . Q
-	. I 'XNOSURO D
-	. . N XQA,XQACMNT,XQALTYPE
-	. . S XQA(XQAUSER)="",XQACMNT="RESTORED FROM SURROGATE",XQALTYPE="RESTORE FROM SURROGATE"
-	. . N XQAUSER,XQAI S XQAUSER=$O(^XTV(8992,"AXQA",XQAID,0)) Q:XQAUSER'>0  D RESETUP^XQALFWD(XQAID,.XQA,XQACMNT)
-	. . Q
-	. ; walk through each of those it was sent to as a surrogate for XQAUSER
-	. F XQASUROP=0:0 S XQASUROP=$O(XSURO(XQASUROP)) Q:XQASUROP'>0  S XQAJ=$O(^XTV(8992.1,XQAI,20,"B",XQASUROP,0)) D
-	. . ; and identify each time they were considered a recipient of the alert
-	. . S XNOSURO=0 F XQAK=0:0 Q:XNOSURO  S XQAK=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK)) Q:XQAK'>0  F XQAL=0:0 S XQAL=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK,XQAL)) Q:XQAL'>0  S X0=^XTV(8992.1,XQAI,20,XQAJ,1,XQAL,0) D  Q:XNOSURO
-	. . . I $P(X0,U,3)'="Y" S XNOSURO=1 Q  ; this one got it directly as a recipient as well
-	. . . ; walk through the SURROGATE FOR entries for this user
-	. . . F XQAOTH=0:0 S XQAOTH=$O(^XTV(8992.1,XQAI,20,XQAJ,3,XQAOTH)) Q:XQAOTH'>0  S X30=^(XQAOTH,0) D  Q:XNOSURO
-	. . . . I +X30=XQAUSER S $P(^XTV(8992.1,XQAI,20,XQAJ,3,XQAOTH,0),U,3)=$$NOW^XLFDT() Q  ; mark this user as returned
-	. . . . I $P(X30,U,3)'>0 S XNOSURO=1 Q  ; another surrogate hasn't been returned yet, so leave the alert
-	. . . . Q
-	. . . Q
-	. . I 'XNOSURO D
-	. . . N XQAKILL,XQAUSER,XQAI S XQAKILL=1,XQAUSER=XQASUROP D DELETE^XQALDEL
-	. . . Q
-	. . Q
-	. Q
-	Q
-	;
-SUROLIST(XQAUSER,XQALIST)	; returns for XQAUSER a list of current and/or future surrogates in XQALIST
-	;  usage  D SUROLIST^XQALSUR1(DUZ,.XQALIST)
-	;
-	;  returns  XQALIST=count
-	;           XQALIST(1)=IEN2^NEWPERSON,USER2^STARTDATETIME^ENDDATETIME
-	;           XQALIST(2)=3^NAME,USER3^3050407.1227^3050406
-	;
-	N XQA0,XQADATE,XQAIEN,XQAL,XQALCNT,XQALEND,XQANOW,XQASTART,XQASURO,XQAVALU
-	D CHEKSUBS^XQALSUR2(XQAUSER)
-	S XQALCNT=$$CURRSURO^XQALSURO(XQAUSER)
-	S XQANOW=$$NOW^XLFDT(),XQALCNT=0
-	S XQADATE="" F  S XQADATE=$O(^XTV(8992,XQAUSER,2,"B",XQADATE)) Q:XQADATE'>0  S XQAIEN="" F  S XQAIEN=$O(^XTV(8992,XQAUSER,2,"B",XQADATE,XQAIEN)) Q:XQAIEN'>0  D
-	. S XQA0=^XTV(8992,XQAUSER,2,XQAIEN,0),XQASTART=$P(XQA0,U),XQASURO=$P(XQA0,U,2),XQALEND=$P(XQA0,U,3) I XQALEND>0,XQALEND'>XQANOW Q
-	. S XQALCNT=XQALCNT+1,XQAVALU=$$GET1^DIQ(200,XQASURO_",",.01),XQAL(XQALCNT)=XQASURO_U_XQAVALU_U_XQASTART_U_XQALEND
-	. Q
-	; now rearrange by earliest to last
-	K XQALIST S XQALIST=0
-	S XQALCNT="" F  S XQALCNT=$O(XQAL(XQALCNT)) Q:XQALCNT'>0  D
-	. ; if end date not specified, and start date follows, set end date to next start date
-	. I $D(XQAL(XQALCNT+1)),($P(XQAL(XQALCNT),U,4)>$P(XQAL(XQALCNT+1),U,3))!($P(XQAL(XQALCNT),U,4)'>0) S $P(XQAL(XQALCNT),U,4)=$P(XQAL(XQALCNT+1),U,3)
-	. S XQALIST=XQALIST+1,XQALIST(XQALIST)=XQAL(XQALCNT)
-	. Q
-	Q
-	;
-DCYCLIC(XQALSURO,XQAUSER,XQALSTRT,XQALEND)	; code added to prevent cyclical surrogates - use dates for surrogacy
-	N XQALNEXT,XQALIST,I,XQALAST
-	I XQALSURO=XQAUSER Q "This forms a circle which leads back to this user during this period - can't do it!"
-	S XQALNEXT=$$CURRSURO^XQALSURO(XQALSURO,XQALSTRT,XQALEND) I XQALNEXT>0 D
-	. F I=1:1 Q:$P(XQALNEXT,U,I)=""  S XQALAST=$$DCYCLIC($P(XQALNEXT,U,I),XQAUSER,XQALSTRT,XQALEND) I XQALAST'>0 S XQALSURO=XQALAST Q
-	. Q
-	Q XQALSURO
-	;
-DATESURO(XQAUSER,XQALSTRT,XQALEND)	; returns surrogate(s) for XQAUSER in date range XQALSTRT to XQALEND, may be multiple values ^-separated
-	N XQALY,XQA0,XQALIEN,XQALS
-	S XQALY="" I XQALEND'>0 S XQALEND=4000101
-	F XQALS=0:0 S XQALS=$O(^XTV(8992,XQAUSER,2,"B",XQALS)) Q:XQALS'>0  Q:XQALS'<XQALEND  D
-	. F XQALIEN=0:0 S XQALIEN=$O(^XTV(8992,XQAUSER,2,"B",XQALS,XQALIEN)) Q:XQALIEN'>0  S XQA0=^XTV(8992,XQAUSER,2,XQALIEN,0) Q:$P(XQA0,U,3)'>XQALSTRT  S XQALY=XQALY_$S(XQALY="":"",1:U)_$P(XQA0,U,2)
-	. Q
-	Q XQALY
-	;
-SURRO1(XQAUSER)	;
-	N XQALSURO,XQALSTRT,XQALEND
-	D CHKREMV^XQALSURO
-SURRO11	;
-	S XQALSURO=$$NEWDLG() I XQALSURO'>0 Q
-	I $$CYCLIC^XQALSURO(XQALSURO,XQAUSER)'>0 W $C(7),!,$$CYCLIC^XQALSURO(XQALSURO,XQAUSER),! G SURRO11
-	S XQALSTRT=+$$STRTDLG() I XQALSTRT<0 Q
-	S XQALEND=+$$ENDDLG() I XQALEND<0 Q
-	D SETSURO^XQALSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND)
-	G SURRO11 ;
-	Q
-	;
-	; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date
-REMVSURO(XQAUSER,XQALSURO,XQALSTRT)	; SR - ends the currently active surrogate relationship
-	I $G(XQAUSER)'>0 Q
-	S XQALSURO=$G(XQALSURO),XQALSTRT=$G(XQALSTRT)
-	N XQALFM,XQALXREF,XQALSTR1,XQALSUR1,XQALNOW,XQALEND,XQA0
-	D CHEKSUBS^XQALSUR2(XQAUSER)
-	S XQALSUR1=+$P($G(^XTV(8992,XQAUSER,0)),U,2) S:XQALSURO'>0 XQALSURO=XQALSUR1
-	S XQALSTR1=$P($G(^XTV(8992,XQAUSER,0)),U,3) S:XQALSTRT'>0 XQALSTRT=XQALSTR1
-	S XQALEND=$P($G(^XTV(8992,XQAUSER,0)),U,4)
-	S XQALXREF=0 I XQALSTRT>0 F  S XQALXREF=$O(^XTV(8992,XQAUSER,2,"B",XQALSTRT,XQALXREF)) Q:XQALXREF'>0  I $P(^XTV(8992,XQAUSER,2,XQALXREF,0),U,2)=XQALSURO D
-	. S XQALEND=$P(^XTV(8992,XQAUSER,2,XQALXREF,0),U,3) D DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND)
-	. Q
-	S XQALSURO=$$CURRSURO^XQALSURO(XQAUSER) ; make sure current surrogate is updated if necessary.
-	Q
-	;
-DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND)	;
-	N XQALNOW,XQALFM
-	S XQAUSER=XQAUSER_",",XQALXREF=XQALXREF_","_XQAUSER
-	I XQALXREF>0 D
-	. S XQALNOW=$$NOW^XLFDT()
-	. I XQALSTRT>XQALNOW S XQALFM(8992.02,XQALXREF,.01)=XQALNOW ; if scheduled for later, mark start as now
-	. I (XQALEND>XQALNOW)!(XQALEND'>0) S XQALFM(8992.02,XQALXREF,.03)=XQALNOW ; update end time for surrogate to now
-	. I XQALSTRT'>XQALNOW S XQALFM(8992.02,XQALXREF,.04)=1
-	. Q
-	I XQALSUR1=XQALSURO,XQALSTRT=XQALSTR1 D
-	. S XQALFM(8992,XQAUSER,.02)="@"
-	. S XQALFM(8992,XQAUSER,.03)="@"
-	. S XQALFM(8992,XQAUSER,.04)="@"
-	. Q
-	I $D(XQALFM) D FILE^DIE("","XQALFM")
-	; ZEXCEPT: XTMUNIT   (EXTERNAL VALUE - INDICATING UNIT TEST BEING RUN)
-	I XQALSURO>0,'$D(XTMUNIT) D
-	. N XQAMESG,XMSUB,XMTEXT
-	. S XQAMESG(1,0)="You have been REMOVED as a surrogate recipient for alerts for"
-	. S XQAMESG(2,0)=$$GET1^DIQ(200,XQAUSER,.01,"E")_" (IEN="_$P(XQAUSER,",")_")."
-	. S XMTEXT="XQAMESG(",XMSUB="Removal as surrogate recipient"
-	. D SENDMESG^XQALSURO
-	. Q
-	Q
-	;
-NEWDLG()	; new surrogate dialog
-	N DIR,Y S DIR(0)="Y",DIR("A")="Do you want to SET a new surrogate recipient",DIR("?")="A surrogate will receive your alerts until they are removed as surrogate.",DIR("B")="NO"
-	S Y=$$ASKDIR(.DIR) I 'Y Q 0
-	;
-	S DIR(0)="P^200:AEMQ",DIR("A")="Select USER to be SURROGATE" S Y=$$ASKDIR(.DIR)  ; COS-0401-41366
-	I Y>0 W "  ",$P(Y,U,2)
-	Q +Y
-	;
-STRTDLG()	; new surrogate start date/time dialog
-	N DIR
-	S DIR(0)="DO^::ATEX",DIR("A")="Specify Date/Time SURROGATE becomes active" ; BRX-1000-10427
-	S DIR("A",1)="",DIR("A",2)=""
-	S DIR("A",3)="if no date/time is entered, alerts will start going to"
-	S DIR("A",4)="the SURROGATE immediately."
-	Q +$$ASKDIR(.DIR)
-	;
-ENDDLG()	; new surrogate end date/time dialog
-	N DIR
-	S DIR(0)="DO^::AETX",DIR("A")="Specify Date/Time SURROGATE should be removed" ; BRX-1000-10427
-	S DIR("A",1)="",DIR("A",2)=""
-	S DIR("A",3)="if no date/time is entered, YOU must remove the SURROGATE"
-	S DIR("A",4)="to terminate alerts going to the SURROGATE"
-	Q +$$ASKDIR(.DIR)
-	;
-ASKDIR(DIR)	;
-	N Y,DTOUT,DUOUT
-	D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S Y=-1
-	Q Y
+XQALSUR1 ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ;9/6/05  14:26
+ ;;8.0;KERNEL;**366**;Jul 10, 1995
+ Q
+ ;
+RETURN(XQAUSER) ; P366 - return alerts to the user
+ N XQAI,X0,XQASTRT,XQASURO,XQAEND
+ ; identify periods in the surrogate multiple that haven't been returned
+ F XQAI=0:0 S XQAI=$O(^XTV(8992,XQAUSER,2,"AC",1,XQAI)) Q:XQAI'>0  S X0=^XTV(8992,XQAUSER,2,XQAI,0) I $P(X0,U,4)=1 D
+ . S XQASTRT=$P(X0,U) S XQAEND=$P(X0,U,3)
+ . ; and clear the flag indicating we need to restore these alerts
+ . N XQAFDA S XQAFDA(8992.02,XQAI_","_XQAUSER_",",.04)="@" D FILE^DIE("","XQAFDA")
+ . ; restore alerts to intended user, remove from surrogate if completed (i.e., no other surrogates and not intended recipient)
+ . D PUSHBACK(XQAUSER,XQASTRT,XQAEND)
+ . Q
+ Q
+ ;
+PUSHBACK(XQAUSER,XQASTRT,XQAEND) ; P366 - identify alerts in alert tracking file for return and return them
+ N XQAINIT,XQAI,X0,X30,XNOSURO,XQADT,XQAJ,XQAK,XQAL,XQAOTH,XQASUROP
+ S XQAINIT=$$FIND1^DIC(8992.2,,"X","INITIAL RECIPIENT")
+ F XQADT=XQASTRT-.0000001:0 S XQADT=$O(^XTV(8992.1,"AUD",XQAUSER,XQADT)) Q:XQADT'>0  Q:XQADT>XQAEND  F XQAI=0:0 S XQAI=$O(^XTV(8992.1,"AUD",XQAUSER,XQADT,XQAI)) Q:XQAI'>0  D
+ . S XQAJ=$O(^XTV(8992.1,XQAI,20,"B",XQAUSER,0)) Q:XQAJ'>0
+ . N XSURO,XNOSURO,XQAID S XNOSURO=0,XQAID=$P(^XTV(8992.1,XQAI,0),U)
+ . F XQAK=0:0 S XQAK=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK)) Q:XQAK'>0  F XQAL=0:0 S XQAL=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK,XQAL)) Q:XQAL'>0  D
+ . . S X0=^XTV(8992.1,XQAI,20,XQAJ,1,XQAL,0) S:$P(X0,U,2)>0 XSURO($P(X0,U,2))="" S:$P(X0,U,2)'>0 XNOSURO=1 ; sent to XSURO as surrogate
+ . . Q
+ . I 'XNOSURO D
+ . . N XQA,XQACMNT,XQALTYPE
+ . . S XQA(XQAUSER)="",XQACMNT="RESTORED FROM SURROGATE",XQALTYPE="RESTORE FROM SURROGATE"
+ . . N XQAUSER,XQAI S XQAUSER=$O(^XTV(8992,"AXQA",XQAID,0)) Q:XQAUSER'>0  D RESETUP^XQALFWD(XQAID,.XQA,XQACMNT)
+ . . Q
+ . ; walk through each of those it was sent to as a surrogate for XQAUSER
+ . F XQASUROP=0:0 S XQASUROP=$O(XSURO(XQASUROP)) Q:XQASUROP'>0  S XQAJ=$O(^XTV(8992.1,XQAI,20,"B",XQASUROP,0)) D
+ . . ; and identify each time they were considered a recipient of the alert
+ . . S XNOSURO=0 F XQAK=0:0 Q:XNOSURO  S XQAK=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK)) Q:XQAK'>0  F XQAL=0:0 S XQAL=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK,XQAL)) Q:XQAL'>0  S X0=^XTV(8992.1,XQAI,20,XQAJ,1,XQAL,0) D  Q:XNOSURO
+ . . . I $P(X0,U,3)'="Y" S XNOSURO=1 Q  ; this one got it directly as a recipient as well
+ . . . ; walk through the SURROGATE FOR entries for this user
+ . . . F XQAOTH=0:0 S XQAOTH=$O(^XTV(8992.1,XQAI,20,XQAJ,3,XQAOTH)) Q:XQAOTH'>0  S X30=^(XQAOTH,0) D  Q:XNOSURO
+ . . . . I +X30=XQAUSER S $P(^XTV(8992.1,XQAI,20,XQAJ,3,XQAOTH,0),U,3)=$$NOW^XLFDT() Q  ; mark this user as returned
+ . . . . I $P(X30,U,3)'>0 S XNOSURO=1 Q  ; another surrogate hasn't been returned yet, so leave the alert
+ . . . . Q
+ . . . Q
+ . . I 'XNOSURO D
+ . . . N XQAKILL,XQAUSER,XQAI S XQAKILL=1,XQAUSER=XQASUROP D DELETE^XQALDEL
+ . . . Q
+ . . Q
+ . Q
+ Q
+ ;
+SUROLIST(XQAUSER,XQALIST) ; returns for XQAUSER a list of current and/or future surrogates in XQALIST
+ ;  usage  D SUROLIST^XQALSUR1(DUZ,.XQALIST)
+ ;
+ ;  returns  XQALIST=count
+ ;           XQALIST(1)=IEN2^NEWPERSON,USER2^STARTDATETIME^ENDDATETIME
+ ;           XQALIST(2)=3^NAME,USER3^3050407.1227^3050406
+ ;
+ N XQA0,XQADATE,XQAIEN,XQAL,XQALCNT,XQALEND,XQANOW,XQASTART,XQASURO,XQAVALU
+ D CHEKSUBS^XQALSUR2(XQAUSER)
+ S XQALCNT=$$CURRSURO^XQALSURO(XQAUSER)
+ S XQANOW=$$NOW^XLFDT(),XQALCNT=0
+ S XQADATE="" F  S XQADATE=$O(^XTV(8992,XQAUSER,2,"B",XQADATE)) Q:XQADATE'>0  S XQAIEN="" F  S XQAIEN=$O(^XTV(8992,XQAUSER,2,"B",XQADATE,XQAIEN)) Q:XQAIEN'>0  D
+ . S XQA0=^XTV(8992,XQAUSER,2,XQAIEN,0),XQASTART=$P(XQA0,U),XQASURO=$P(XQA0,U,2),XQALEND=$P(XQA0,U,3) I XQALEND>0,XQALEND'>XQANOW Q
+ . S XQALCNT=XQALCNT+1,XQAVALU=$$GET1^DIQ(200,XQASURO_",",.01),XQAL(XQALCNT)=XQASURO_U_XQAVALU_U_XQASTART_U_XQALEND
+ . Q
+ ; now rearrange by earliest to last
+ K XQALIST S XQALIST=0
+ S XQALCNT="" F  S XQALCNT=$O(XQAL(XQALCNT)) Q:XQALCNT'>0  D
+ . ; if end date not specified, and start date follows, set end date to next start date
+ . I $D(XQAL(XQALCNT+1)),($P(XQAL(XQALCNT),U,4)>$P(XQAL(XQALCNT+1),U,3))!($P(XQAL(XQALCNT),U,4)'>0) S $P(XQAL(XQALCNT),U,4)=$P(XQAL(XQALCNT+1),U,3)
+ . S XQALIST=XQALIST+1,XQALIST(XQALIST)=XQAL(XQALCNT)
+ . Q
+ Q
+ ;
+DCYCLIC(XQALSURO,XQAUSER,XQALSTRT,XQALEND) ; code added to prevent cyclical surrogates - use dates for surrogacy
+ N XQALNEXT,XQALIST,I,XQALAST
+ I XQALSURO=XQAUSER Q "This forms a circle which leads back to this user during this period - can't do it!"
+ S XQALNEXT=$$CURRSURO^XQALSURO(XQALSURO,XQALSTRT,XQALEND) I XQALNEXT>0 D
+ . F I=1:1 Q:$P(XQALNEXT,U,I)=""  S XQALAST=$$DCYCLIC($P(XQALNEXT,U,I),XQAUSER,XQALSTRT,XQALEND) I XQALAST'>0 S XQALSURO=XQALAST Q
+ . Q
+ Q XQALSURO
+ ;
+DATESURO(XQAUSER,XQALSTRT,XQALEND) ; returns surrogate(s) for XQAUSER in date range XQALSTRT to XQALEND, may be multiple values ^-separated
+ N XQALY,XQA0,XQALIEN,XQALS
+ S XQALY="" I XQALEND'>0 S XQALEND=4000101
+ F XQALS=0:0 S XQALS=$O(^XTV(8992,XQAUSER,2,"B",XQALS)) Q:XQALS'>0  Q:XQALS'<XQALEND  D
+ . F XQALIEN=0:0 S XQALIEN=$O(^XTV(8992,XQAUSER,2,"B",XQALS,XQALIEN)) Q:XQALIEN'>0  S XQA0=^XTV(8992,XQAUSER,2,XQALIEN,0) Q:$P(XQA0,U,3)'>XQALSTRT  S XQALY=XQALY_$S(XQALY="":"",1:U)_$P(XQA0,U,2)
+ . Q
+ Q XQALY
+ ;
+SURRO1(XQAUSER) ;
+ N XQALSURO,XQALSTRT,XQALEND
+ D CHKREMV^XQALSURO
+SURRO11 ;
+ S XQALSURO=$$NEWDLG() I XQALSURO'>0 Q
+ 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
+ D SETSURO^XQALSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND)
+ G SURRO11 ;
+ Q
+ ;
+ ; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date
+REMVSURO(XQAUSER,XQALSURO,XQALSTRT) ; SR - ends the currently active surrogate relationship
+ I $G(XQAUSER)'>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
+ S XQALSTR1=$P($G(^XTV(8992,XQAUSER,0)),U,3) S:XQALSTRT'>0 XQALSTRT=XQALSTR1
+ S XQALEND=$P($G(^XTV(8992,XQAUSER,0)),U,4)
+ S XQALXREF=0 I XQALSTRT>0 F  S XQALXREF=$O(^XTV(8992,XQAUSER,2,"B",XQALSTRT,XQALXREF)) Q:XQALXREF'>0  I $P(^XTV(8992,XQAUSER,2,XQALXREF,0),U,2)=XQALSURO D
+ . S XQALEND=$P(^XTV(8992,XQAUSER,2,XQALXREF,0),U,3) D DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND)
+ . Q
+ S XQALSURO=$$CURRSURO^XQALSURO(XQAUSER) ; make sure current surrogate is updated if necessary.
+ Q
+ ;
+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
+ . S XQALNOW=$$NOW^XLFDT()
+ . I XQALSTRT>XQALNOW S XQALFM(8992.02,XQALXREF,.01)=XQALNOW ; if scheduled for later, mark start as now
+ . I (XQALEND>XQALNOW)!(XQALEND'>0) S XQALFM(8992.02,XQALXREF,.03)=XQALNOW ; update end time for surrogate to now
+ . I XQALSTRT'>XQALNOW S XQALFM(8992.02,XQALXREF,.04)=1
+ . Q
+ I XQALSUR1=XQALSURO,XQALSTRT=XQALSTR1 D
+ . S XQALFM(8992,XQAUSER,.02)="@"
+ . S XQALFM(8992,XQAUSER,.03)="@"
+ . S XQALFM(8992,XQAUSER,.04)="@"
+ . Q
+ I $D(XQALFM) D FILE^DIE("","XQALFM")
+ 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"
+ . S XQAMESG(2,0)=$$GET1^DIQ(200,XQAUSER,.01,"E")_" (IEN="_$P(XQAUSER,",")_")."
+ . S XMTEXT="XQAMESG(",XMSUB="Removal as surrogate recipient"
+ . D SENDMESG^XQALSURO
+ . Q
+ Q
+ ;
+NEWDLG() ; new surrogate dialog
+ N DIR,Y S DIR(0)="Y",DIR("A")="Do you want to SET a new surrogate recipient",DIR("?")="A surrogate will receive your alerts until they are removed as surrogate.",DIR("B")="NO"
+ S Y=$$ASKDIR(.DIR) I 'Y Q 0
+ ;
+ S DIR(0)="P^200:AEMQ",DIR("A")="Select USER to be SURROGATE" S Y=$$ASKDIR(.DIR)  ; COS-0401-41366
+ I Y>0 W "  ",$P(Y,U,2)
+ Q +Y
+ ;
+STRTDLG() ; new surrogate start date/time dialog
+ N DIR
+ S DIR(0)="DO^::ATEX",DIR("A")="Specify Date/Time SURROGATE becomes active" ; BRX-1000-10427
+ S DIR("A",1)="",DIR("A",2)=""
+ S DIR("A",3)="if no date/time is entered, alerts will start going to"
+ S DIR("A",4)="the SURROGATE immediately."
+ Q +$$ASKDIR(.DIR)
+ ;
+ENDDLG() ; new surrogate end date/time dialog
+ N DIR
+ S DIR(0)="DO^::AETX",DIR("A")="Specify Date/Time SURROGATE should be removed" ; BRX-1000-10427
+ S DIR("A",1)="",DIR("A",2)=""
+ S DIR("A",3)="if no date/time is entered, YOU must remove the SURROGATE"
+ S DIR("A",4)="to terminate alerts going to the SURROGATE"
+ Q +$$ASKDIR(.DIR)
+ ;
+ASKDIR(DIR) ;
+ N Y,DTOUT,DUOUT
+ D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S Y=-1
+ Q Y
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,195 +1,173 @@
-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
-	;;
-	Q
-OTHRSURO	; OPT:- XQALERT SURROGATE SET/REMOVE -- OTHERS SPECIFY SURROGATE FOR SELECTED USER
-	N XQAUSER,DIR,Y
-	S DIR(0)="PD^200:AEMQ",DIR("A",1)="SURROGATE related to which"
-	S DIR("A")="NEW PERSON entry"
-	D ^DIR K DIR Q:Y'>0  W "  ",$P(Y,U,2)
-	S XQAUSER=+Y
-	G SURROGAT
-	Q
-	;
-SURROGAT	; USER SPECIFICATION OF SURROGATE
-	I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ
-	D SURRO1^XQALSUR1(XQAUSER)
-	Q
-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
-	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
-	. 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
-	N XQALFM,XQALIEN,XQAIENS
-	I $G(XQAUSER)'>0 Q
-	I $G(XQALSURO)'>0 Q
-	I '$D(^XTV(8992,XQAUSER,0)) D
-	. N XQALFM,XQALFM1
-	. S XQALFM1(1)=XQAUSER
-	. S XQALFM(8992,"+1,",.01)=XQAUSER
-	. D UPDATE^DIE("","XQALFM","XQALFM1")
-	. Q
-	S XQAIENS=XQAUSER_","
-	; P366 - force no start date/time to NOW
-	; P366 - change to force anything less than NOW to NOW - 8/22/05
-	I $G(XQALSTRT)<$$NOW^XLFDT() S XQALSTRT=$$NOW^XLFDT()
-	; P366 - add values to new multiple
-	S XQALFM(8992.02,"+1,"_XQAIENS,.01)=XQALSTRT
-	S XQALFM(8992.02,"+1,"_XQAIENS,.02)=XQALSURO
-	I XQALEND>0 S XQALFM(8992.02,"+1,"_XQAIENS,.03)=XQALEND
-	K XQALIEN D UPDATE^DIE("","XQALFM","XQALIEN")
-	; P366 - if start date time is already in effect - place in old locations to make active
-	I XQALSTRT'>$$NOW^XLFDT() D ACTIVATE(XQAUSER,XQALIEN(1))
-	N XQAMESG,XMSUB,XMTEXT
-	S XQAMESG(1,0)="You have been specified as a surrogate recipient for alerts for"
-	S XQAMESG(2,0)=$$GET1^DIQ(200,XQAIENS,.01,"E")_" (IEN="_XQAUSER_") effective "_$$FMTE^XLFDT(XQALSTRT)
-	I $G(XQALEND)'>0 S XQAMESG(2,0)=XQAMESG(2,0)_"."
-	E  S XQAMESG(3,0)="until "_$$FMTE^XLFDT(XQALEND)
-	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
-	Q
-	;
-ACTIVATE(XQAUSER,XQALIEN)	; activates a surrogate
-	N X0,XQALFM,XQALSURO,XQALSTRT,XQALEND
-	S X0=$G(^XTV(8992,XQAUSER,2,XQALIEN,0)) Q:X0=""  S XQALSTRT=$P(X0,U),XQALSURO=$P(X0,U,2),XQALEND=$P(X0,U,3)
-	S X0=^XTV(8992,XQAUSER,0)
-	I $P(X0,U,2)>0,$P(X0,U,3)'>$$NOW^XLFDT() D REMVSURO(XQAUSER) ; If we are activaing a new surrogate, if one exists simply remove.
-	K XQALFM S XQALFM(8992,XQAUSER_",",.03)=XQALSTRT
-	S XQALFM(8992,XQAUSER_",",.02)=XQALSURO
-	S XQALFM(8992,XQAUSER_",",.04)=$S($G(XQALEND)>0:XQALEND,1:"@")
-	D FILE^DIE("","XQALFM")
-	Q
-	;
-	; usage $$SETSURO1(XQAUSER,XQALSURO,XQALSTRT,XQALEND)  returns 0 if invalid, otherwise > 0
-SETSURO1(XQAUSER,XQALSURO,XQALSTRT,XQALEND)	; SR. This should be used instead of SETSURO
-	I $G(XQALSTRT)'>0 S XQALSTRT=$$NOW^XLFDT()
-	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
-	Q XQALSURO
-	;
-CHKREMV	;
-	N DIR,XQAI,XQASLIST,XQAVAL,YVAL,Y
-	; ZEXCEPT: XQAUSER    (EXTERNAL VALUE)
-	D SUROLIST^XQALSUR1(XQAUSER,.XQASLIST)
-	W !,"Current Surrogate(s):",?35,"START DATE",?60,"END DATE"
-	F XQAI=0:0 S XQAI=$O(XQASLIST(XQAI)) Q:XQAI'>0  W !,XQAI,"  ",$P(XQASLIST(XQAI),U,2),?35,$$FMTE^XLFDT($P(XQASLIST(XQAI),U,3)),?60,$$FMTE^XLFDT($P(XQASLIST(XQAI),U,4))
-	W ! I XQASLIST'>0 W !,"  No current surrogates",! Q
-	S DIR(0)="Y",DIR("A")="Do you want to REMOVE "_$S(XQASLIST>1:"a",1:"THIS")_" surrogate recipient",DIR("?")="A surrogate will receive your alerts until they are removed as surrogate." D ^DIR K DIR Q:Y'>0
-	S Y=1 I XQASLIST>1 S DIR(0)="L^1:"_XQASLIST,DIR("A")="Enter a list (comma separated, e.g., 1,2) of the surrogate(s) to remove" D ^DIR K DIR
-	I Y>0 S YVAL=Y F XQAI=1:1 S XQAVAL=+$P(YVAL,",",XQAI) Q:XQAVAL'>0  D REMVSURO(XQAUSER,$P(XQASLIST(XQAVAL),U),$P(XQASLIST(XQAVAL),U,3))
-	Q
-	;
-	; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date
-REMVSURO(XQAUSER,XQALSURO,XQALSTRT)	; SR - ends the currently active surrogate relationship
-	I $G(XQAUSER)'>0 Q
-	D REMVSURO^XQALSUR1(XQAUSER,$G(XQALSURO),$G(XQALSTRT))
-	Q
-	;
-	; P366 - added OPTIONAL second and third arguments to determine surrogate for specified time range
-CURRSURO(XQAUSER,XQASTRT,XQAEND)	;SR. - returns current surrogate for user or -1  usage $$CURRSURO^XQALSURO(DUZ)
-	N X,ACTIVE,XQANOW,XQASTR1,XQAIVAL,XQA0,XQAI
-	D CHEKSUBS^XQALSUR2(XQAUSER)
-	I $G(XQASTRT)>0 Q $$DATESURO^XQALSUR1(XQAUSER,XQASTRT,$G(XQAEND)) ; P366 - check for current in specified date/times
-	;
-	; P366 - find the latest start time which is now or past or the first one in the future
-	S XQANOW=$$NOW^XLFDT() 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
-	. . S XQAEND=$P(^XTV(8992,XQAUSER,2,XQAI,0),U,3) I (XQAEND="")!(XQAEND>XQANOW) S XQAIVAL=XQAI
-	. . Q
-	. ; to be compatible with the past, if there is not a current surrogate, show the next scheduled on the zero node if there is one
-	. I XQAIVAL=0 S XQASTRT=$O(^XTV(8992,XQAUSER,2,"B",XQASTR1)) Q:XQASTRT=""  F XQAI=0:0 S XQAI=$O(^XTV(8992,XQAUSER,2,"B",XQASTRT,XQAI)) Q:XQAI'>0  D  Q:XQAIVAL>0
-	. . S XQAEND=$P(^XTV(8992,XQAUSER,2,XQAI,0),U,3) I (XQAEND="")!(XQAEND>XQANOW) S XQAIVAL=XQAI
-	. . Q
-	. I XQAIVAL>0 S XQA0=^XTV(8992,XQAUSER,2,XQAIVAL,0),XQASTRT=^XTV(8992,XQAUSER,0) I ($P(XQA0,U,2)'=$P(XQASTRT,U,2))!($P(XQA0,U)'=$P(XQASTRT,U,3))!(+$P(XQA0,U,3)'=+$P(XQASTRT,U,4)) D ACTIVATE(XQAUSER,XQAIVAL)
-	. Q
-	; P366 - end
-	S X=$G(^XTV(8992,XQAUSER,0))
-	; now check for a CURRENT surrogate, already started and not expired or cyclic
-	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
-	. 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
-	N CURRSURO,NEXTSURO,SURODATA,NOW
-	S NOW=$$NOW^XLFDT()
-	S CURRSURO=$$CURRSURO(XQAUSER),SURODATA=$$GETSURO(XQAUSER) I (CURRSURO'>0)!(+$P(SURODATA,U,3)>NOW)!('(+$$ACTIVE^XUSER(CURRSURO))) Q -1
-	F  S NEXTSURO=$$CURRSURO(CURRSURO),SURODATA=$$GETSURO(CURRSURO) Q:NEXTSURO'>0  Q:+$P(SURODATA,U,3)>NOW  Q:'(+$$ACTIVE^XUSER(NEXTSURO))  S CURRSURO=NEXTSURO
-	Q CURRSURO
-	;
-GETSURO(XQAUSER)	;SR. - returns data for surrogate for user including times
-	I $$CURRSURO(XQAUSER)'>0 Q ""
-	N GLOBREF,IENS,X
-	S IENS=XQAUSER_",",GLOBREF=$NA(^TMP($J,"XQALSURO")) K @GLOBREF
-	D GETS^DIQ(8992,IENS,".02;.03;.04","IE",GLOBREF)
-	S GLOBREF=$NA(@GLOBREF@(8992,IENS))
-	S X=$G(@GLOBREF@(.02,"I"))_U_$G(@GLOBREF@(.02,"E"))_U_$G(@GLOBREF@(.03,"I"))_U_$G(@GLOBREF@(.04,"I"))
-	K @GLOBREF
-	Q X
-	;
-GETFOR	;OPT.
-	N XQAUSER,VALUES,XQACNT,DIR,DIRUT,I,Y
-	S DIR(0)="PD^200:AEMQ",DIR("A",1)="View Users who have selected a specified User as their Surrogate."
-	S DIR("A")="Select User (NEW PERSON entry)"
-	D ^DIR K DIR Q:Y'>0  W "  ",$P(Y,U,2)
-	S XQAUSER=+Y
-	D SUROFOR(.VALUES,XQAUSER) I VALUES'>0 W !,"No entries found.",!! Q
-	S XQACNT=0 K DIRUT F I=0:0 S I=$O(VALUES(I)) Q:I'>0  D:(XQACNT>(IOSL-4))  Q:$D(DIRUT)  W !,?5,$P(VALUES(I),U,2) S XQACNT=XQACNT+1
-	. S DIR(0)="E" D ^DIR K DIR
-	. Q
-	K DIRUT
-	Q
-	;
-SUROLIST(XQAUSER,XQALIST)	; SR. returns list of current and scheduled surrogates for XQAUSER
-	D SUROLIST^XQALSUR1(XQAUSER,.XQALIST)
-	Q
-	;
-SUROFOR(LIST,XQAUSER)	;SR. - returns list of users XQAUSER is acting as a surrogate for
-	I $G(XQAUSER)="" Q
-	N I,COUNT S I=0,COUNT=0 F  S I=$O(^XTV(8992,"AC",XQAUSER,I)) Q:I'>0  I $$CURRSURO(I)>0 D
-	. S COUNT=COUNT+1,LIST(COUNT)=I_U_$$GET1^DIQ(200,(I_","),".01","E")_U_$$GET1^DIQ(8992,(I_","),".03","E")_U_$$GET1^DIQ(8992,(I_","),".04","E")
-	S LIST=COUNT
-	Q
-	;
-SENDMESG	;
-	N XMY,XMDUZ,XMCHAN
-	; ZEXCEPT: XQALSURO   (EXTERNAL VALUE)
-	S XMY(XQALSURO)="",XMDUZ=.5
-	D ^XMD
-	Q
+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
+OTHRSURO ; OPT:- XQALERT SURROGATE SET/REMOVE -- OTHERS SPECIFY SURROGATE FOR SELECTED USER
+ N XQAUSER,DIR,Y
+ S DIR(0)="PD^200:AEMQ",DIR("A",1)="SURROGATE related to which"
+ S DIR("A")="NEW PERSON entry"
+ D ^DIR K DIR Q:Y'>0  W "  ",$P(Y,U,2)
+ S XQAUSER=+Y
+ G SURROGAT
+ Q
+ ;
+SURROGAT ; USER SPECIFICATION OF SURROGATE
+ I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ
+ 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 $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 - 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) ; SR
+ N XQALFM,XQALIEN,XQAIENS
+ I $G(XQAUSER)'>0 Q
+ I $G(XQALSURO)'>0 Q
+ I '$D(^XTV(8992,XQAUSER,0)) D
+ . N XQALFM,XQALFM1
+ . S XQALFM1(1)=XQAUSER
+ . S XQALFM(8992,"+1,",.01)=XQAUSER
+ . D UPDATE^DIE("","XQALFM","XQALFM1")
+ . Q
+ S XQAIENS=XQAUSER_","
+ ; P366 - force no start date/time to NOW
+ ; P366 - change to force anything less than NOW to NOW - 8/22/05
+ I $G(XQALSTRT)<$$NOW^XLFDT() S XQALSTRT=$$NOW^XLFDT()
+ ; P366 - add values to new multiple
+ S XQALFM(8992.02,"+1,"_XQAIENS,.01)=XQALSTRT
+ S XQALFM(8992.02,"+1,"_XQAIENS,.02)=XQALSURO
+ I XQALEND>0 S XQALFM(8992.02,"+1,"_XQAIENS,.03)=XQALEND
+ K XQALIEN D UPDATE^DIE("","XQALFM","XQALIEN")
+ ; P366 - if start date time is already in effect - place in old locations to make active
+ I XQALSTRT'>$$NOW^XLFDT() D ACTIVATE(XQAUSER,XQALIEN(1))
+ N XQAMESG,XMSUB,XMTEXT
+ S XQAMESG(1,0)="You have been specified as a surrogate recipient for alerts for"
+ S XQAMESG(2,0)=$$GET1^DIQ(200,XQAIENS,.01,"E")_" (IEN="_XQAUSER_") effective "_$$FMTE^XLFDT(XQALSTRT)
+ I $G(XQALEND)'>0 S XQAMESG(2,0)=XQAMESG(2,0)_"."
+ E  S XQAMESG(3,0)="until "_$$FMTE^XLFDT(XQALEND)
+ S XMSUB="Surrogate Recipient for "_$$GET1^DIQ(200,XQAIENS,.01,"E")
+ S XMTEXT="XQAMESG("
+ D:'$D(XQATEST) SENDMESG
+ Q
+ ;
+ACTIVATE(XQAUSER,XQALIEN) ; activates a surrogate
+ N X0,XQALFM,XQALSURO,XQALSTRT,XQALEND
+ S X0=$G(^XTV(8992,XQAUSER,2,XQALIEN,0)) Q:X0=""  S XQALSTRT=$P(X0,U),XQALSURO=$P(X0,U,2),XQALEND=$P(X0,U,3)
+ S X0=^XTV(8992,XQAUSER,0)
+ I $P(X0,U,2)>0,$P(X0,U,3)'>$$NOW^XLFDT() D REMVSURO(XQAUSER) ; If we are activaing a new surrogate, if one exists simply remove.
+ K XQALFM S XQALFM(8992,XQAUSER_",",.03)=XQALSTRT
+ S XQALFM(8992,XQAUSER_",",.02)=XQALSURO
+ S XQALFM(8992,XQAUSER_",",.04)=$S($G(XQALEND)>0:XQALEND,1:"@")
+ D FILE^DIE("","XQALFM")
+ Q
+ ;
+ ; usage $$SETSURO1(XQAUSER,XQALSURO,XQALSTRT,XQALEND)  returns 0 if invalid, otherwise > 0
+SETSURO1(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; SR. This should be used instead of SETSURO
+ I $G(XQALSTRT)'>0 S XQALSTRT=$$NOW^XLFDT()
+ N XQAVAL
+ S XQAVAL=$$CYCLIC(XQALSURO,XQAUSER,XQALSTRT,$G(XQALEND)) I XQAVAL'>0 Q XQAVAL ; Can't use as surrogate
+ D SETSURO(XQAUSER,XQALSURO,XQALSTRT,$G(XQALEND))
+ Q XQALSURO
+ ;
+CHKREMV ;
+ N DIR,XQAI,XQASLIST,XQAVAL,YVAL,Y
+ ; ZEXCEPT: XQAUSER    (EXTERNAL VALUE)
+ D SUROLIST^XQALSUR1(XQAUSER,.XQASLIST)
+ W !,"Current Surrogate(s):",?35,"START DATE",?60,"END DATE"
+ F XQAI=0:0 S XQAI=$O(XQASLIST(XQAI)) Q:XQAI'>0  W !,XQAI,"  ",$P(XQASLIST(XQAI),U,2),?35,$$FMTE^XLFDT($P(XQASLIST(XQAI),U,3)),?60,$$FMTE^XLFDT($P(XQASLIST(XQAI),U,4))
+ W ! I XQASLIST'>0 W !,"  No current surrogates",! Q
+ S DIR(0)="Y",DIR("A")="Do you want to REMOVE "_$S(XQASLIST>1:"a",1:"THIS")_" surrogate recipient",DIR("?")="A surrogate will receive your alerts until they are removed as surrogate." D ^DIR K DIR Q:Y'>0
+ S Y=1 I XQASLIST>1 S DIR(0)="L^1:"_XQASLIST,DIR("A")="Enter a list (comma separated, e.g., 1,2) of the surrogate(s) to remove" D ^DIR K DIR
+ I Y>0 S YVAL=Y F XQAI=1:1 S XQAVAL=+$P(YVAL,",",XQAI) Q:XQAVAL'>0  D REMVSURO(XQAUSER,$P(XQASLIST(XQAVAL),U),$P(XQASLIST(XQAVAL),U,3))
+ Q
+ ;
+ ; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date
+REMVSURO(XQAUSER,XQALSURO,XQALSTRT) ; SR - ends the currently active surrogate relationship
+ I $G(XQAUSER)'>0 Q
+ D REMVSURO^XQALSUR1(XQAUSER,$G(XQALSURO),$G(XQALSTRT))
+ Q
+ ;
+ ; P366 - added OPTIONAL second and third arguments to determine surrogate for specified time range
+CURRSURO(XQAUSER,XQASTRT,XQAEND) ;SR. - returns current surrogate for user or -1  usage $$CURRSURO^XQALSURO(DUZ)
+ N X,ACTIVE,XQANOW,XQASTR1,XQAIVAL,XQA0,XQAI
+ D CHEKSUBS^XQALSUR2(XQAUSER)
+ I $G(XQASTRT)>0 Q $$DATESURO^XQALSUR1(XQAUSER,XQASTRT,$G(XQAEND)) ; P366 - check for current in specified date/times
+ ;
+ ; P366 - find the latest start time which is now or past or the first one in the future
+ 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
+ . . S XQAEND=$P(^XTV(8992,XQAUSER,2,XQAI,0),U,3) I (XQAEND="")!(XQAEND>XQANOW) S XQAIVAL=XQAI
+ . . Q
+ . ; to be compatible with the past, if there is not a current surrogate, show the next scheduled on the zero node if there is one
+ . I XQAIVAL=0 S XQASTRT=$O(^XTV(8992,XQAUSER,2,"B",XQASTR1)) Q:XQASTRT=""  F XQAI=0:0 S XQAI=$O(^XTV(8992,XQAUSER,2,"B",XQASTRT,XQAI)) Q:XQAI'>0  D  Q:XQAIVAL>0
+ . . S XQAEND=$P(^XTV(8992,XQAUSER,2,XQAI,0),U,3) I (XQAEND="")!(XQAEND>XQANOW) S XQAIVAL=XQAI
+ . . Q
+ . I XQAIVAL>0 S XQA0=^XTV(8992,XQAUSER,2,XQAIVAL,0),XQASTRT=^XTV(8992,XQAUSER,0) I ($P(XQA0,U,2)'=$P(XQASTRT,U,2))!($P(XQA0,U)'=$P(XQASTRT,U,3))!(+$P(XQA0,U,3)'=+$P(XQASTRT,U,4)) D ACTIVATE(XQAUSER,XQAIVAL)
+ . Q
+ ; P366 - end
+ S X=$G(^XTV(8992,XQAUSER,0))
+ ; now check for a CURRENT surrogate, already started and not expired or cyclic
+ 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
+ . ;  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
+ ;
+ACTVSURO(XQAUSER) ;SR. - returns the actual surrogate at this time
+ N CURRSURO,NEXTSURO,SURODATA,NOW
+ S NOW=$$NOW^XLFDT()
+ S CURRSURO=$$CURRSURO(XQAUSER),SURODATA=$$GETSURO(XQAUSER) I (CURRSURO'>0)!(+$P(SURODATA,U,3)>NOW)!('(+$$ACTIVE^XUSER(CURRSURO))) Q -1
+ F  S NEXTSURO=$$CURRSURO(CURRSURO),SURODATA=$$GETSURO(CURRSURO) Q:NEXTSURO'>0  Q:+$P(SURODATA,U,3)>NOW  Q:'(+$$ACTIVE^XUSER(NEXTSURO))  S CURRSURO=NEXTSURO
+ Q CURRSURO
+ ;
+GETSURO(XQAUSER) ;SR. - returns data for surrogate for user including times
+ I $$CURRSURO(XQAUSER)'>0 Q ""
+ N GLOBREF,IENS,X
+ S IENS=XQAUSER_",",GLOBREF=$NA(^TMP($J,"XQALSURO")) K @GLOBREF
+ D GETS^DIQ(8992,IENS,".02;.03;.04","IE",GLOBREF)
+ S GLOBREF=$NA(@GLOBREF@(8992,IENS))
+ S X=$G(@GLOBREF@(.02,"I"))_U_$G(@GLOBREF@(.02,"E"))_U_$G(@GLOBREF@(.03,"I"))_U_$G(@GLOBREF@(.04,"I"))
+ K @GLOBREF
+ Q X
+ ;
+GETFOR ;OPT.
+ N XQAUSER,VALUES,XQACNT,DIR,DIRUT,I,Y
+ S DIR(0)="PD^200:AEMQ",DIR("A",1)="View Users who have selected a specified User as their Surrogate."
+ S DIR("A")="Select User (NEW PERSON entry)"
+ D ^DIR K DIR Q:Y'>0  W "  ",$P(Y,U,2)
+ S XQAUSER=+Y
+ D SUROFOR(.VALUES,XQAUSER) I VALUES'>0 W !,"No entries found.",!! Q
+ S XQACNT=0 K DIRUT F I=0:0 S I=$O(VALUES(I)) Q:I'>0  D:(XQACNT>(IOSL-4))  Q:$D(DIRUT)  W !,?5,$P(VALUES(I),U,2) S XQACNT=XQACNT+1
+ . S DIR(0)="E" D ^DIR K DIR
+ . Q
+ K DIRUT
+ Q
+ ;
+SUROLIST(XQAUSER,XQALIST) ; SR. returns list of current and scheduled surrogates for XQAUSER
+ D SUROLIST^XQALSUR1(XQAUSER,.XQALIST)
+ Q
+ ;
+SUROFOR(LIST,XQAUSER) ;SR. - returns list of users XQAUSER is acting as a surrogate for
+ I $G(XQAUSER)="" Q
+ N I,COUNT S I=0,COUNT=0 F  S I=$O(^XTV(8992,"AC",XQAUSER,I)) Q:I'>0  I $$CURRSURO(I)>0 D
+ . S COUNT=COUNT+1,LIST(COUNT)=I_U_$$GET1^DIQ(200,(I_","),".01","E")_U_$$GET1^DIQ(8992,(I_","),".03","E")_U_$$GET1^DIQ(8992,(I_","),".04","E")
+ S LIST=COUNT
+ Q
+ ;
+SENDMESG ;
+ N XMY,XMDUZ,XMCHAN
+ ; ZEXCEPT: XQALSURO   (EXTERNAL VALUE)
+ S XMY(XQALSURO)="",XMDUZ=.5
+ D ^XMD
+ Q
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,152 +1,149 @@
-XQARPRT2	;DCN/BUF,JLI/OAK-OIFO - LOOKUP PROVIDER ALERTS ;4/9/07  10:16
-	;;8.0;KERNEL;**316,443**;Jul 10, 1995;Build 4
-	;  Based on the original routine AEKALERT
-	Q
-EN	; OPT - interactive lists alerts from start date for a single user based on contents of alert tracking file
-	N DIR,XQADOC S DIR(0)="PO^200:EMZ" D ^DIR K DIR Q:$D(DIRUT)  Q:Y'>0  S XQADOC=+Y
-EN1	;
-	N XQASDATE,XQAWORDS,XQADISP,%ZIS,ZTRTN,ZTDESC,ZTSAVE,POP,XQAU1N4
-	D DATES Q:Y'>0
-	D WORDS() Q:$D(DIRUT)  K Y
-	S %ZIS="MQ" D ^%ZIS Q:POP  I $D(IO("Q")) K IO("Q") S ZTRTN="DQ1^XQARPRT2",ZTDESC="List of User Alerts",ZTSAVE("*")="" D ^%ZTLOAD W:$G(ZTSK)>0 !,"Task number is ",ZTSK K ZTSK Q
-DQ1	;
-	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
-	I XQAIEN>0 F  S XQAIEN=$O(^XTV(8992.1,"R",XQADOC,XQAIEN)) Q:XQAIEN'>0  D  Q:$D(DIRUT)!(XQADATE>XQAEDATE)
-	. S XQANODE0=$G(^XTV(8992.1,XQAIEN,0)),XQADATE=$P(XQANODE0,"^",2) Q:(XQADATE<XQASDATE)!(XQADATE>XQAEDATE)
-	. D PRNTATRK(XQAIEN)
-	D HEADER(HEADERID,0)
-	D ^%ZISC
-	K XQADATE,XQACTR,DATA,DIR,DIRUT,XQADOC,XQAIEN,XQANODE0,XQASDATE,Y
-	Q
-	;
-WORDS(TYPE)	; Allow user to select alerts containing only certain words
-	S DIR(0)="Y",DIR("A")="Do you want to "_$S($G(TYPE)'="":"count",1:"list")_" only alerts containing specific words or phrase(s)"
-	S DIR("?",1)="You can enter one or more words or phrases which you want to be used to"
-	S DIR("?",2)="select the alerts to be listed.  If you enter NO, all for the selected"
-	S DIR("?",3)="individual in the selected time period will be selected.  If you enter"
-	S DIR("?",4)="YES, you will be prompted to enter a word or phrase.  You will be prompted"
-	S DIR("?",5)="again, and you may enter as many word or phrase entries as you want."
-	S DIR("?",6)="Comparisons will NOT be case specific."
-	S DIR("?",7)=""
-	S DIR("?",8)="HOWEVER ALL WORDS OR PHRASES ENTERED MUST BE IN THE MESSAGE FOR AN ALERT"
-	S DIR("?")="TO BE SELECTED."
-	D ^DIR K DIR Q:Y'>0
-	;
-	F J=1:1 W:J>1 !?7,"--- OR ---",!,"Enter another set of words or phrases that should",!,"be matched independently of the previous entr"_$S(J>2:"ies",1:"y") D  Q:'$D(XQAWORDS(J))
-	. W !?10,"ALL words or phrases connected by -AND- must appear in the",!?10,"message for an alert to be selected"
-	. S DIR("?",1)="Enter a word, at least three characters long, or phrase, without regard to"
-	. S DIR("?",2)="case, that you want to be required for selection of alerts to be listed."
-	. S DIR("?",3)="If more than one word or phrase are specified, ALL of them must be in alerts"
-	. S DIR("?")="which will be listed."
-	. F I=1:1 S DIR(0)="FO^3:",DIR("A")="Enter "_$S(I=1:"a",1:"another")_" word or phrase" W:I>1 !?10,"-AND-" D ^DIR Q:(Y="")!(Y["^")  S XQAWORDS(J,I)=$$UP^XLFSTR(Y)
-	. K DIR,DIRUT
-	. Q
-	;
-	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
-	. Q
-	Q
-	;
-USER	;USER ENTRY POINT
-	N DIR,XQADOC S XQADOC=DUZ
-	G EN1
-	;
-DATES	;
-	S DIR(0)="DO^::EX",DIR("B")="TODAY",DIR("A")="START DATE" D ^DIR K DIR Q:Y'>0  S XQASDATE=+Y
-	I XQASDATE<$$OLDEST() W !?10,"The earliest date in the alert tracking file is ",$$FMTE^XLFDT($$OLDEST(),"D") S XQASDATE=$$OLDEST()
-	I $D(XQA1U4N) W !,"*** WARNING ***: Do not specify too many days - each entry in the Alert Tracking",!,"file must be checked for the date range specified.",! S DIR("B")=$$FMTE^XLFDT(XQASDATE)
-	S DIR(0)="DO^"_XQASDATE_":DT",DIR("A")="END DATE" D ^DIR K DIR Q:$D(DIRUT)  I Y>0 S XQAEDATE=Y+.24
-	Q
-	;
-PRNTATRK(IEN)	; Print data for an entry from the alert tracking file
-	N XQANODE0,XQADATE,Y,XQANEN,XQAMSG,XQAOPT,XQAROU,XQAMSGUC
-	S XQANODE0=$G(^XTV(8992.1,IEN,0)),XQADATE=$P(XQANODE0,"^",2)
-	S XQAMSG=$G(^XTV(8992.1,IEN,1)),XQAOPT=$P(XQAMSG,U,2),XQAROU=$P(XQAMSG,U,3,4),XQAMSG=$P(XQAMSG,U)
-	S XQAOPT=$S(XQAOPT>0:" [OPT]",1:"") S XQAROU=$S((XQAROU'="")&(XQAROU'="^"):" [ROU]",1:"") S XQAOPT=$S(XQAOPT'="":XQAOPT,XQAROU'="":XQAROU,1:"      ")
-	I $D(XQAWORDS)>1 S XQAMSGUC=$$UP^XLFSTR(XQAMSG) D  Q:XQAMSGUC=""
-	. N XQAMSG1,J,I S XQAMSG1=XQAMSGUC F J=0:0 S J=$O(XQAWORDS(J)) Q:J'>0  S XQAMSGUC=XQAMSG1 D  Q:XQAMSGUC'=""
-	. . F I=0:0 S I=$O(XQAWORDS(J,I)) Q:I'>0  I XQAMSGUC'[XQAWORDS(J,I) S XQAMSGUC="" Q
-	. . I XQAMSGUC'="",XQADISP'=1 D
-	. . . I XQADISP=2,XQAOPT="",XQAROU="" S XQAMSGUC=""
-	. . . I XQADISP=3,(XQAOPT'="")!(XQAROU'="") S XQAMSGUC=""
-	. . . Q
-	. . Q
-	. Q
-	S XQANEN=$$FMTE^XLFDT(XQADATE,"5Z")_XQAOPT_" ien="_IEN
-	W !,$E(XQAMSG,1,IOM-1) W !?35,XQANEN S XQATOT=XQATOT+1
-	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
-	. Q
-	Q
-	;
-HEADER(XQANAME,DOFF)	; Output header at start of report XQANAME indicates who report is for
-	W:DOFF @IOF W:'DOFF ! W $S('DOFF:"Found "_XQATOT_" ",1:""),$S($D(XQAWORDS)>1:"Selected ",1:""),"Alerts for ",XQANAME,!,"  for dates ",$$FMTE^XLFDT(XQASDATE)," through "
-	N OUTDATE S OUTDATE=$$FMTE^XLFDT(XQAEDATE,"D") I 'DOFF,$D(XQADATE),XQADATE<XQAEDATE,'$D(ZTQUEUED) S OUTDATE=$$FMTE^XLFDT(XQADATE)
-	W OUTDATE S XQACTR=2
-	D WORDHDR
-	W ! S XQACTR=XQACTR+1
-	S XQATOT=0
-	Q
-	;
-WORDHDR	;
-	N I,J
-	F I=0:0 S I=$O(XQAWORDS(I)) Q:I'>0  W:I>1 !?10,"--- OR ---" D
-	. F J=0:0 S J=$O(XQAWORDS(I,J)) Q:J'>0  W !?5,$S(J=1:"Selected alerts containing:",1:"            and containing:"),?35,XQAWORDS(I,J) S XQACTR=XQACTR+1
-	. Q
-	Q
-DTPT	; OPT - GIVEN DATE AND PATIENT, TAKE A LOOK AT ALL USING 'D' X-REF
-	; for one day and for 1 patient list data in alert tracking file related to patient
-	N DIR,XQANAME,XQADFN,XQA1U4N,XQASDATE,XQAEDATE,XQA1U4NP,XQAWORDS
-	S DIR(0)="PO^2:EMZ" D ^DIR Q:Y'>0  S XQANAME=$P(Y,"^",2),XQADFN=+Y,XQA1U4N=$$GET1^DIQ(2,XQADFN_",",.0905),XQA1U4NP="("_XQA1U4N_")"
-	D CHEKSCAN(XQADFN) Q:$D(DIRUT)
-	D DATES Q:Y'>0
-	D WORDS() K Y Q:$D(DIRUT)
-	S %ZIS="MQ" D ^%ZIS Q:POP  I $D(IO("Q")) K IO("Q") S ZTRTN="DTPTDQ^XQARPRT2",ZTDESC="List of Patient Alerts",ZTSAVE("*")="" D ^%ZTLOAD W:$G(ZTSK)>0 !,"Task number is ",ZTSK K ZTSK Q
-DTPTDQ	;
-	N XQANWID,FOUND,ONE,ZERO,XQACTR,XQAIEN,XQATYPE,XQADATE,HEADERID,XQATOT
-	S HEADERID="Patient "_$$GET1^DIQ(2,XQADFN_",",.01)_" ("_$$GET1^DIQ(2,XQADFN_",",.0905)_")"
-	D HEADER(HEADERID,1)
-	S XQADATE=XQASDATE-0.0000001 F  S XQADATE=$O(^XTV(8992.1,"D",XQADATE)) Q:(XQADATE'>0)!(XQADATE>XQAEDATE)  D  Q:$D(DIRUT)
-	. S XQAIEN=0 F  S XQAIEN=$O(^XTV(8992.1,"D",XQADATE,XQAIEN)) Q:XQAIEN=""  S ONE=$G(^XTV(8992.1,XQAIEN,1)),ZERO=$G(^(0)),XQATYPE=$E(ZERO,1,3) D  Q:$D(DIRUT)
-	. . S FOUND=0
-	. . I (XQATYPE="DVB")!(XQATYPE="OR,") I $P(ZERO,U,4)=XQADFN S FOUND=1
-	. . I (XQATYPE="GMA"),$P(ONE,U)[XQANAME S FOUND=1
-	. . I (XQATYPE="TIU"),$P(ONE,U)[$E(XQANAME,1,9),$P(ONE,U)[XQA1U4NP S FOUND=1
-	. . I FOUND D PRNTATRK(XQAIEN)
-	. . Q
-	. Q
-	D HEADER(HEADERID,0)
-	Q
-	;
-CHEKSCAN(XQADFN)	; Output a list of dates when OR, and DVB alerts are found
-	N DIR,OLDEST,X,Y,XQASDATE,XX,CNT,COL,BASECNT,I
-	W !!! S DIR(0)="Y",DIR("A")="Do you want to scan for a list of dates that have at least some alerts for this patient",DIR("A",1)="The quick scan method used here will not pick up some alerts,"
-	S DIR("A",2)="but should give an indication of when alerts might be found.",DIR("A",3)=""
-	D ^DIR K DIR Q:$D(DIRUT)  I Y D
-	. K ^TMP("XQARPRT2",$J)
-	. N OLDEST S OLDEST=$$FMTE^XLFDT($$OLDEST(),"5DZ")
-	. S DIR(0)="SO^;1:1 Week ago;2:1 month ago;3:3 months ago;4:6 months ago;5:1 year ago;6:As far back as possible",DIR("A")="Select a period for starting",DIR("A",1)="The oldest entry in your Alert Tracking file is from "_OLDEST,DIR("A",2)=""
-	. D ^DIR K DIR Q:Y'>0
-	. S X=$S(Y=1:"1W",Y=2:"1M",Y=3:"3M",Y=4:"6M",Y=5:"12M",1:"1000M"),X="T-"_X D ^%DT S XQASDATE=Y
-	. F I=0:0 S I=$O(^XTV(8992.1,"C",XQADFN,I)) Q:I'>0  S ZERO=$P(^XTV(8992.1,I,0),U,2) I ZERO'<XQASDATE S ^TMP("XQARPRT2",$J,(ZERO\1))=$G(^TMP("XQARPRT2",$J,(ZERO\1)))+1
-	. ; Output date and number found in vertical columns, with (if lots of dates) three columns per screen
-	. I $D(^TMP("XQARPRT2",$J)) W !,"Dates and number of alerts found in () [may not be all of them]"
-	. ; S CNT=0,COL=1,BASECNT=0 F I=0:0 S I=$O(^TMP("XQARPRT2",$J,I)) Q:I'>0  S CNT=CNT+1,XX(CNT)=$G(XX(CNT))_$$FMTE^XLFDT(I,"5DZ")_"  ("_^(I)_")"_"     " I (CNT-BASECNT)>(IOSL-4) S COL=COL+1 S:'(COL#3) BASECNT=CNT S CNT=BASECNT
-	. S CNT=2 F I=0:0 S I=$O(^TMP("XQARPRT2",$J,I)) Q:I'>0  S CNT=CNT+1,XX(CNT\3)=$G(XX(CNT\3))_$$FMTE^XLFDT(I,"5DZ")_"  ("_^(I)_")"_"     "
-	. F I=0:0 S I=$O(XX(I)) Q:I'>0  W !,XX(I)
-	. Q
-	Q
-	;
-VIEWTRAK	; OPT.  View an entry in the Alert Tracking file in Captioned mode
-	D VIEWTRAK^XQARPRT1
-	Q
-	;
-OLDEST()	; Returns date of oldest entry in alert tracking file
-	Q $$OLDEST^XQARPRT1()
+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
+EN ; OPT - interactive lists alerts from start date for a single user based on contents of alert tracking file
+ N DIR,XQADOC S DIR(0)="PO^200:EMZ" D ^DIR K DIR Q:$D(DIRUT)  Q:Y'>0  S XQADOC=+Y
+EN1 ;
+ N XQASDATE,XQAWORDS,XQADISP,%ZIS,ZTRTN,ZTDESC,ZTSAVE,POP,XQAU1N4
+ D DATES Q:Y'>0
+ D WORDS() Q:$D(DIRUT)  K Y
+ S %ZIS="MQ" D ^%ZIS Q:POP  I $D(IO("Q")) K IO("Q") S ZTRTN="DQ1^XQARPRT2",ZTDESC="List of User Alerts",ZTSAVE("*")="" D ^%ZTLOAD W:$G(ZTSK)>0 !,"Task number is ",ZTSK K ZTSK Q
+DQ1 ;
+ N XQANWID,XQAIEN,XQADATE,XQANODE0,XQACTR,HEADERID,XQATOT
+ S HEADERID="User "_$$GET1^DIQ(200,XQADOC_",",.01)_" (DFN="_XQADOC_")"
+ 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
+ I XQAIEN>0 F  S XQAIEN=$O(^XTV(8992.1,"R",XQADOC,XQAIEN)) Q:XQAIEN'>0  D  Q:$D(DIRUT)!(XQADATE>XQAEDATE)
+ . S XQANODE0=$G(^XTV(8992.1,XQAIEN,0)),XQADATE=$P(XQANODE0,"^",2) Q:(XQADATE<XQASDATE)!(XQADATE>XQAEDATE)
+ . D PRNTATRK(XQAIEN)
+ D HEADER(HEADERID,0)
+ K XQADATE,XQACTR,DATA,DIR,DIRUT,XQADOC,XQAIEN,XQANODE0,XQASDATE,Y
+ Q
+ ;
+WORDS(TYPE) ; Allow user to select alerts containing only certain words
+ S DIR(0)="Y",DIR("A")="Do you want to "_$S($G(TYPE)'="":"count",1:"list")_" only alerts containing specific words or phrase(s)"
+ S DIR("?",1)="You can enter one or more words or phrases which you want to be used to"
+ S DIR("?",2)="select the alerts to be listed.  If you enter NO, all for the selected"
+ S DIR("?",3)="individual in the selected time period will be selected.  If you enter"
+ S DIR("?",4)="YES, you will be prompted to enter a word or phrase.  You will be prompted"
+ S DIR("?",5)="again, and you may enter as many word or phrase entries as you want."
+ S DIR("?",6)="Comparisons will NOT be case specific."
+ S DIR("?",7)=""
+ S DIR("?",8)="HOWEVER ALL WORDS OR PHRASES ENTERED MUST BE IN THE MESSAGE FOR AN ALERT"
+ S DIR("?")="TO BE SELECTED."
+ D ^DIR K DIR Q:Y'>0
+ ;
+ F J=1:1 W:J>1 !?7,"--- OR ---",!,"Enter another set of words or phrases that should",!,"be matched independently of the previous entr"_$S(J>2:"ies",1:"y") D  Q:'$D(XQAWORDS(J))
+ . W !?10,"ALL words or phrases connected by -AND- must appear in the",!?10,"message for an alert to be selected"
+ . S DIR("?",1)="Enter a word, at least three characters long, or phrase, without regard to"
+ . S DIR("?",2)="case, that you want to be required for selection of alerts to be listed."
+ . S DIR("?",3)="If more than one word or phrase are specified, ALL of them must be in alerts"
+ . S DIR("?")="which will be listed."
+ . F I=1:1 S DIR(0)="FO^3:",DIR("A")="Enter "_$S(I=1:"a",1:"another")_" word or phrase" W:I>1 !?10,"-AND-" D ^DIR Q:(Y="")!(Y["^")  S XQAWORDS(J,I)=$$UP^XLFSTR(Y)
+ . K DIR,DIRUT
+ . Q
+ ;
+ 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
+ . Q
+ Q
+ ;
+USER ;USER ENTRY POINT
+ N DIR,XQADOC S XQADOC=DUZ
+ G EN1
+ ;
+DATES ;
+ S DIR(0)="DO^::EX",DIR("B")="TODAY",DIR("A")="START DATE" D ^DIR K DIR Q:Y'>0  S XQASDATE=+Y
+ I XQASDATE<$$OLDEST() W !?10,"The earliest date in the alert tracking file is ",$$FMTE^XLFDT($$OLDEST(),"D") S XQASDATE=$$OLDEST()
+ I $D(XQA1U4N) W !,"*** WARNING ***: Do not specify too many days - each entry in the Alert Tracking",!,"file must be checked for the date range specified.",! S DIR("B")=$$FMTE^XLFDT(XQASDATE)
+ S DIR(0)="DO^"_XQASDATE_":DT",DIR("A")="END DATE" D ^DIR K DIR Q:$D(DIRUT)  I Y>0 S XQAEDATE=Y+.24
+ Q
+ ;
+PRNTATRK(IEN) ; Print data for an entry from the alert tracking file
+ N XQANODE0,XQADATE,Y,XQANEN,XQAMSG,XQAOPT,XQAROU,XQAMSGUC
+ S XQANODE0=$G(^XTV(8992.1,IEN,0)),XQADATE=$P(XQANODE0,"^",2)
+ S XQAMSG=$G(^XTV(8992.1,IEN,1)),XQAOPT=$P(XQAMSG,U,2),XQAROU=$P(XQAMSG,U,3,4),XQAMSG=$P(XQAMSG,U)
+ S XQAOPT=$S(XQAOPT>0:" [OPT]",1:"") S XQAROU=$S((XQAROU'="")&(XQAROU'="^"):" [ROU]",1:"") S XQAOPT=$S(XQAOPT'="":XQAOPT,XQAROU'="":XQAROU,1:"      ")
+ I $D(XQAWORDS)>1 S XQAMSGUC=$$UP^XLFSTR(XQAMSG) D  Q:XQAMSGUC=""
+ . N XQAMSG1,J,I S XQAMSG1=XQAMSGUC F J=0:0 S J=$O(XQAWORDS(J)) Q:J'>0  S XQAMSGUC=XQAMSG1 D  Q:XQAMSGUC'=""
+ . . F I=0:0 S I=$O(XQAWORDS(J,I)) Q:I'>0  I XQAMSGUC'[XQAWORDS(J,I) S XQAMSGUC="" Q
+ . . I XQAMSGUC'="",XQADISP'=1 D
+ . . . I XQADISP=2,XQAOPT="",XQAROU="" S XQAMSGUC=""
+ . . . I XQADISP=3,(XQAOPT'="")!(XQAROU'="") S XQAMSGUC=""
+ . . . Q
+ . . Q
+ . Q
+ S XQANEN=$$FMTE^XLFDT(XQADATE,"5Z")_XQAOPT_" ien="_IEN
+ W !,$E(XQAMSG,1,IOM-1) W !?35,XQANEN S XQATOT=XQATOT+1
+ S XQACTR=XQACTR+2 I XQACTR>(IOSL-4) D  Q:$D(DIRUT)  S XQACTR=0
+ . I $D(ZTQUEUED) W @IOF
+ . E  S DIR(0)="E" D ^DIR K DIR W !
+ . Q
+ Q
+ ;
+HEADER(XQANAME,DOFF) ; Output header at start of report XQANAME indicates who report is for
+ W:DOFF @IOF W:'DOFF ! W $S('DOFF:"Found "_XQATOT_" ",1:""),$S($D(XQAWORDS)>1:"Selected ",1:""),"Alerts for ",XQANAME,!,"  for dates ",$$FMTE^XLFDT(XQASDATE)," through "
+ N OUTDATE S OUTDATE=$$FMTE^XLFDT(XQAEDATE,"D") I 'DOFF,$D(XQADATE),XQADATE<XQAEDATE,'$D(ZTQUEUED) S OUTDATE=$$FMTE^XLFDT(XQADATE)
+ W OUTDATE S XQACTR=2
+ D WORDHDR
+ W ! S XQACTR=XQACTR+1
+ S XQATOT=0
+ Q
+ ;
+WORDHDR ;
+ N I,J
+ F I=0:0 S I=$O(XQAWORDS(I)) Q:I'>0  W:I>1 !?10,"--- OR ---" D
+ . F J=0:0 S J=$O(XQAWORDS(I,J)) Q:J'>0  W !?5,$S(J=1:"Selected alerts containing:",1:"            and containing:"),?35,XQAWORDS(I,J) S XQACTR=XQACTR+1
+ . Q
+ Q
+DTPT ; OPT - GIVEN DATE AND PATIENT, TAKE A LOOK AT ALL USING 'D' X-REF
+ ; for one day and for 1 patient list data in alert tracking file related to patient
+ N DIR,XQANAME,XQADFN,XQA1U4N,XQASDATE,XQAEDATE,XQA1U4NP,XQAWORDS
+ S DIR(0)="PO^2:EMZ" D ^DIR Q:Y'>0  S XQANAME=$P(Y,"^",2),XQADFN=+Y,XQA1U4N=$$GET1^DIQ(2,XQADFN_",",.0905),XQA1U4NP="("_XQA1U4N_")"
+ D CHEKSCAN(XQADFN) Q:$D(DIRUT)
+ D DATES Q:Y'>0
+ D WORDS() K Y Q:$D(DIRUT)
+ S %ZIS="MQ" D ^%ZIS Q:POP  I $D(IO("Q")) K IO("Q") S ZTRTN="DTPTDQ^XQARPRT2",ZTDESC="List of Patient Alerts",ZTSAVE("*")="" D ^%ZTLOAD W:$G(ZTSK)>0 !,"Task number is ",ZTSK K ZTSK Q
+DTPTDQ ;
+ N XQANWID,FOUND,ONE,ZERO,XQACTR,XQAIEN,XQATYPE,XQADATE,HEADERID,XQATOT
+ S HEADERID="Patient "_$$GET1^DIQ(2,XQADFN_",",.01)_" ("_$$GET1^DIQ(2,XQADFN_",",.0905)_")"
+ D HEADER(HEADERID,1)
+ S XQADATE=XQASDATE-0.0000001 F  S XQADATE=$O(^XTV(8992.1,"D",XQADATE)) Q:(XQADATE'>0)!(XQADATE>XQAEDATE)  D  Q:$D(DIRUT)
+ . S XQAIEN=0 F  S XQAIEN=$O(^XTV(8992.1,"D",XQADATE,XQAIEN)) Q:XQAIEN=""  S ONE=$G(^XTV(8992.1,XQAIEN,1)),ZERO=$G(^(0)),XQATYPE=$E(ZERO,1,3) D  Q:$D(DIRUT)
+ . . S FOUND=0
+ . . I (XQATYPE="DVB")!(XQATYPE="OR,") I $P(ZERO,U,4)=XQADFN S FOUND=1
+ . . I (XQATYPE="GMA"),$P(ONE,U)[XQANAME S FOUND=1
+ . . I (XQATYPE="TIU"),$P(ONE,U)[$E(XQANAME,1,9),$P(ONE,U)[XQA1U4NP S FOUND=1
+ . . I FOUND D PRNTATRK(XQAIEN)
+ . . Q
+ . Q
+ D HEADER(HEADERID,0)
+ Q
+ ;
+CHEKSCAN(XQADFN) ; Output a list of dates when OR, and DVB alerts are found
+ N DIR,OLDEST,X,Y,XQASDATE,XX,CNT,COL,BASECNT,I
+ W !!! S DIR(0)="Y",DIR("A")="Do you want to scan for a list of dates that have at least some alerts for this patient",DIR("A",1)="The quick scan method used here will not pick up some alerts,"
+ S DIR("A",2)="but should give an indication of when alerts might be found.",DIR("A",3)=""
+ D ^DIR K DIR Q:$D(DIRUT)  I Y D
+ . K ^TMP("XQARPRT2",$J)
+ . N OLDEST S OLDEST=$$FMTE^XLFDT($$OLDEST(),"5DZ")
+ . S DIR(0)="SO^;1:1 Week ago;2:1 month ago;3:3 months ago;4:6 months ago;5:1 year ago;6:As far back as possible",DIR("A")="Select a period for starting",DIR("A",1)="The oldest entry in your Alert Tracking file is from "_OLDEST,DIR("A",2)=""
+ . D ^DIR K DIR Q:Y'>0
+ . S X=$S(Y=1:"1W",Y=2:"1M",Y=3:"3M",Y=4:"6M",Y=5:"12M",1:"1000M"),X="T-"_X D ^%DT S XQASDATE=Y
+ . F I=0:0 S I=$O(^XTV(8992.1,"C",XQADFN,I)) Q:I'>0  S ZERO=$P(^XTV(8992.1,I,0),U,2) I ZERO'<XQASDATE S ^TMP("XQARPRT2",$J,(ZERO\1))=$G(^TMP("XQARPRT2",$J,(ZERO\1)))+1
+ . ; Output date and number found in vertical columns, with (if lots of dates) three columns per screen
+ . I $D(^TMP("XQARPRT2",$J)) W !,"Dates and number of alerts found in () [may not be all of them]"
+ . ; S CNT=0,COL=1,BASECNT=0 F I=0:0 S I=$O(^TMP("XQARPRT2",$J,I)) Q:I'>0  S CNT=CNT+1,XX(CNT)=$G(XX(CNT))_$$FMTE^XLFDT(I,"5DZ")_"  ("_^(I)_")"_"     " I (CNT-BASECNT)>(IOSL-4) S COL=COL+1 S:'(COL#3) BASECNT=CNT S CNT=BASECNT
+ . S CNT=2 F I=0:0 S I=$O(^TMP("XQARPRT2",$J,I)) Q:I'>0  S CNT=CNT+1,XX(CNT\3)=$G(XX(CNT\3))_$$FMTE^XLFDT(I,"5DZ")_"  ("_^(I)_")"_"     "
+ . F I=0:0 S I=$O(XX(I)) Q:I'>0  W !,XX(I)
+ . Q
+ Q
+ ;
+VIEWTRAK ; OPT.  View an entry in the Alert Tracking file in Captioned mode
+ D VIEWTRAK^XQARPRT1
+ Q
+ ;
+OLDEST() ; Returns date of oldest entry in alert tracking file
+ Q $$OLDEST^XQARPRT1()
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,80 +1,238 @@
-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".
-	;
-	Q:'$D(XQCY)!(XQCY<1)  S:'$D(XQJMP) XQJMP=0
-	I '$D(XQY0) S XQY0=^DIC(19,+XQCY,0)
-	I '$D(XQCY0) S XQSAV=XQY0,XQY=XQCY D SET Q:XQCY<0  S XQCY0=XQY0,XQY0=XQSAV
-CHK	I XQCY0="" S XQCY=-1 G OUT
-	I $P(XQCY0,U,3)'="" S XQCY=-1 G OUT
-	N XQRT S XQRT=$$CHCKL^XQCHK2(XQCY0,DUZ) I +XQRT S XQCY=-2 G OUT  ; add this line to check all Locks
-	I $L($P(XQCY0,U,6)) S %="" F %XQI=1:1 S %=$P($P(XQCY0,U,6),",",%XQI) Q:%=""  I '$D(^XUSEC(%,DUZ)) S XQCY=-2 G OUT  ; remove
-	N XQRT S XQRT=$$CHCKRL^XQCHK2(XQCY0,DUZ) I +XQRT S XQCY=-3 G OUT  ; add this line to check all Reversed Locks
-	I $L($P(XQCY0,U,16)) S %="" F %XQI=1:1 S %=$P($P(XQCY0,U,16),",",%XQI) Q:%=""  I $D(^XUSEC(%,DUZ)) S XQCY=-3 G OUT  ; remove
-	I $L($P(XQCY0,U,9)) S XQZ=$P(XQCY0,U,9) D ^XQDATE S X=% D XQO^XQ92 I X="" S XQCY=-4 G OUT
-	G:$P(XQCY0,U,10)'["y" OUT
-	S %=0 F %XQI=1:1 S %=$O(^DIC(19,XQCY,3.96,%,0)) Q:%=""  I IOS=% G OUT
-	S XQCY=-5 G OUT
-	Q
-	;
-OUT	K %,%XQI,XQCY0,%Y,XQZ
-	Q
-	;
-JMP	;Check all options in jump path in %XQJP returned as "" if not OK
-	S XQJMP=1
-	F %XQCI=1:1 S XQCY=$P(%XQJP,",",%XQCI) Q:XQCY=""  S XQCY0=$G(^XUTL("XQO",XQDIC,"^",XQCY)),XQCY0=$P(XQCY0,U,2,99) D CHK S:XQCY<0 %XQJP=""
-	K %XQCI,XQCY,XQCY0
-	Q
-	;
-SET	;Produce the same XQY0 as SET1^XQ7 without the synonym
-	I '$D(^DIC(19,+XQY,0)) S XQY=-1 Q
-S1	Q:XQY'>0  S XQY0=^DIC(19,+XQY,0),XQY0=$P(XQY0,U,1,2)_U_$S($P(XQY0,U,3)]"":1,1:"")_U_$P(XQY0,U,4)_U_U_$P(XQY0,U,6,99)
-	S %="" I $D(^DIC(19,+XQY,3.91)) F %XQI=0:0 S %XQI=$O(^DIC(19,+XQY,3.91,%XQI)) Q:%XQI=""!(%XQI'=+%XQI)  I ^(%XQI,0)]"" S %=$S(%'="":%_";",1:"")_$P(^(0),U,1)_$P(^(0),U,2)
-	I %]"" S XQY0=$P(XQY0,U,1,8)_U_%_U_$P(XQY0,U,10,99)
-	I $P(XQY0,U,16),$D(^DIC(19,XQY,3)) S %=$P(^(3),U) I %'="" S XQY0=$P(XQY0,U,1,15)_U_%_U_$P(XQY0,U,17,99)
-	K %,%XQI
-	Q
-	;
-MES	;Messages for rejected options from a call to XQCHK
-	W $C(7)
-	I XQCY=-1 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," is out of order with the message:",!?10,$P(^DIC(19,XQY,0),U,3)
-	I XQCY=-2 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," is locked."
-	I XQCY=-3 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," has a reverse lock on it."
-	I XQCY=-4 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," not allowed right now."
-	I XQCY=-5 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," not allowed on this device."
-	Q
-	;
-OP	;Find out what option or protocol is in charge right now
-	;Returns option or protocol name and text in XQOPT
-	S U="^",%XQ=0
-	I $D(XQORNOD) S %XQ=+XQORNOD,%XQ1=U_$P(XQORNOD,";",2),%XQ=@(%XQ1_%XQ_",0)"),XQOPT=$P(%XQ,U)_U_$P(%XQ,U,2)
-	I '$D(XQORNOD) S %XQ=$S($D(XQY)#2:XQY,1:0) I %XQ S %XQ1=^DIC(19,+%XQ,0),XQOPT=$P(%XQ1,U)_U_$P(%XQ1,U,2)
-	I '$D(XQOPT) S XQOPT="-1^Unknown"
-	K %XQ,%XQ1
-	Q
-	;
-OP1()	;Extrinsic function call returns 3 pieces: 1. "P", "O", or "U" for
-	;Protocol, Option, or Unknown.  2: The Option or Protocol's name. 3:
-	;3: Text name of the Protocol or Option.  For example:
-	;
-	;           O^EVE^System Manager's Menu
-	;
-	N %,%XQ,%XQ1
-	S U="^",%XQ=0
-	I $D(XQORNOD) S %XQ=+XQORNOD,%XQ1=U_$P(XQORNOD,";",2),%XQ=@(%XQ1_%XQ_",0)"),%="P"_U_$P(%XQ,U)_U_$P(%XQ,U,2)
-	I '$D(XQORNOD) S %XQ=$S($D(XQY)#2:XQY,1:0) I %XQ S %XQ1=^DIC(19,+%XQ,0),%="O"_U_$P(%XQ1,U)_U_$P(%XQ1,U,2)
-	I '$D(%) S %="U"_U_"Unknown"_U_"No option or protocol data available"
-	Q %
-	;
-ACCESS(%XQUSR,%XQOP)	;Find out if a user has access to a particular option
-	Q $$ACCESS^XQCHK3(%XQUSR,%XQOP)
-	;
-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
-	Q
-	;
-KEYSET(XQU)	;Collect users keys and set them into ^TMP($J)
-	N %,XQI
-	S %=0 F XQI=0:1 S %=$O(^VA(200,XQU,51,"B",%)) Q:%=""  S:$D(^DIC(19.1,%,0)) ^TMP($J,$P(^DIC(19.1,%,0),U),%)=""
-	Q
+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)
+ I '$D(XQCY0) S XQSAV=XQY0,XQY=XQCY D SET Q:XQCY<0  S XQCY0=XQY0,XQY0=XQSAV
+CHK I XQCY0="" S XQCY=-1 G OUT
+ I $P(XQCY0,U,3)'="" S XQCY=-1 G OUT
+ N XQRT S XQRT=$$CHCKL^XQCHK2(XQCY0,DUZ) I +XQRT S XQCY=-2 G OUT  ; add this line to check all Locks
+ I $L($P(XQCY0,U,6)) S %="" F %XQI=1:1 S %=$P($P(XQCY0,U,6),",",%XQI) Q:%=""  I '$D(^XUSEC(%,DUZ)) S XQCY=-2 G OUT  ; remove
+ N XQRT S XQRT=$$CHCKRL^XQCHK2(XQCY0,DUZ) I +XQRT S XQCY=-3 G OUT  ; add this line to check all Reversed Locks
+ I $L($P(XQCY0,U,16)) S %="" F %XQI=1:1 S %=$P($P(XQCY0,U,16),",",%XQI) Q:%=""  I $D(^XUSEC(%,DUZ)) S XQCY=-3 G OUT  ; remove
+ I $L($P(XQCY0,U,9)) S XQZ=$P(XQCY0,U,9) D ^XQDATE S X=% D XQO^XQ92 I X="" S XQCY=-4 G OUT
+ G:$P(XQCY0,U,10)'["y" OUT
+ S %=0 F %XQI=1:1 S %=$O(^DIC(19,XQCY,3.96,%,0)) Q:%=""  I IOS=% G OUT
+ S XQCY=-5 G OUT
+ Q
+ ;
+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
+ ;
+JMP ;Check all options in jump path in %XQJP returned as "" if not OK
+ S XQJMP=1
+ F %XQCI=1:1 S XQCY=$P(%XQJP,",",%XQCI) Q:XQCY=""  S XQCY0=$G(^XUTL("XQO",XQDIC,"^",XQCY)),XQCY0=$P(XQCY0,U,2,99) D CHK S:XQCY<0 %XQJP=""
+ K %XQCI,XQCY,XQCY0
+ Q
+ ;
+SET ;Produce the same XQY0 as SET1^XQ7 without the synonym
+ I '$D(^DIC(19,+XQY,0)) S XQY=-1 Q
+S1 Q:XQY'>0  S XQY0=^DIC(19,+XQY,0),XQY0=$P(XQY0,U,1,2)_U_$S($P(XQY0,U,3)]"":1,1:"")_U_$P(XQY0,U,4)_U_U_$P(XQY0,U,6,99)
+ S %="" I $D(^DIC(19,+XQY,3.91)) F %XQI=0:0 S %XQI=$O(^DIC(19,+XQY,3.91,%XQI)) Q:%XQI=""!(%XQI'=+%XQI)  I ^(%XQI,0)]"" S %=$S(%'="":%_";",1:"")_$P(^(0),U,1)_$P(^(0),U,2)
+ I %]"" S XQY0=$P(XQY0,U,1,8)_U_%_U_$P(XQY0,U,10,99)
+ I $P(XQY0,U,16),$D(^DIC(19,XQY,3)) S %=$P(^(3),U) I %'="" S XQY0=$P(XQY0,U,1,15)_U_%_U_$P(XQY0,U,17,99)
+ K %,%XQI
+ Q
+ ;
+MES ;Messages for rejected options from a call to XQCHK
+ W $C(7)
+ I XQCY=-1 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," is out of order with the message:",!?10,$P(^DIC(19,XQY,0),U,3)
+ I XQCY=-2 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," is locked."
+ I XQCY=-3 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," has a reverse lock on it."
+ I XQCY=-4 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," not allowed right now."
+ I XQCY=-5 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," not allowed on this device."
+ Q
+ ;
+OP ;Find out what option or protocol is in charge right now
+ ;Returns option or protocol name and text in XQOPT
+ S U="^",%XQ=0
+ I $D(XQORNOD) S %XQ=+XQORNOD,%XQ1=U_$P(XQORNOD,";",2),%XQ=@(%XQ1_%XQ_",0)"),XQOPT=$P(%XQ,U)_U_$P(%XQ,U,2)
+ I '$D(XQORNOD) S %XQ=$S($D(XQY)#2:XQY,1:0) I %XQ S %XQ1=^DIC(19,+%XQ,0),XQOPT=$P(%XQ1,U)_U_$P(%XQ1,U,2)
+ I '$D(XQOPT) S XQOPT="-1^Unknown"
+ K %XQ,%XQ1
+ Q
+ ;
+OP1() ;Extrinsic function call returns 3 pieces: 1. "P", "O", or "U" for
+ ;Protocol, Option, or Unknown.  2: The Option or Protocol's name. 3:
+ ;3: Text name of the Protocol or Option.  For example:
+ ;
+ ;           O^EVE^System Manager's Menu
+ ;
+ N %,%XQ,%XQ1
+ S U="^",%XQ=0
+ I $D(XQORNOD) S %XQ=+XQORNOD,%XQ1=U_$P(XQORNOD,";",2),%XQ=@(%XQ1_%XQ_",0)"),%="P"_U_$P(%XQ,U)_U_$P(%XQ,U,2)
+ I '$D(XQORNOD) S %XQ=$S($D(XQY)#2:XQY,1:0) I %XQ S %XQ1=^DIC(19,+%XQ,0),%="O"_U_$P(%XQ1,U)_U_$P(%XQ1,U,2)
+ I '$D(%) S %="U"_U_"Unknown"_U_"No option or protocol data available"
+ Q %
+ ;
+ ;
+ACCESS(%XQUSR,%XQOP) ;Find out if a user has access to a particular option
+ ;
+ ;    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.
+ 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
+ ;
+KEYSET(XQU) ;Collect users keys and set them into ^TMP($J)
+ N %,XQI
+ S %=0 F XQI=0:1 S %=$O(^VA(200,XQU,51,"B",%)) Q:%=""  S:$D(^DIC(19.1,%,0)) ^TMP($J,$P(^DIC(19.1,%,0),U),%)=""
+ Q
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,67 +1,16 @@
-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)
-	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
-	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)
-	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 
-	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
+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
+ 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,DUZ)) S XQRT=1_"^"_XQK Q
+ Q XQRT
+ ; Entry point for checking all Reversed Locks for a option
+CHCKRL(XQCY0,DUZ) ;
+ N XQI,XQY,XQX,XQRT,XQK S (XQRT,XQX)=0
+ 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,DUZ)) S XQRT=1_"^"_XQK Q 
+ Q XQRT
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,65 +1,65 @@
-XQOR	; SLC/KCM - Prepare to Unwind Options ;4/3/07  16:21
-	;;8.0;KERNEL;**48,56,437**;Jul 10, 1995;Build 23
-	; 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
-	;From: Anywhere  Entry: X,{DIC,XQORFLG}  Exit: none
-	Q:$D(X)[0  K XQORPOP,XQORQUIT
-	I '$D(XQORS) S XQORS=0 K ^TMP("XQORS",$J)
-	S XQORS=XQORS+1 ;push
-	I $D(XQOR("HIJACK")) S X=XQOR("HIJACK"),DIC=101 K XQOR("HIJACK")
-	I X?1.N1";ORD(101,"!(X?1.N1";DIC(19,") S ^TMP("XQORS",$J,XQORS,"REF")="^"_$P(X,";",2)_+X_",",^TMP("XQORS",$J,XQORS,"VPT")=X
-	E  S:$D(DIC)[0 DIC=19 S DIC(0)="N" D ^DIC S:Y>0 ^TMP("XQORS",$J,XQORS,"REF")=DIC_+Y_",",^TMP("XQORS",$J,XQORS,"VPT")=+Y_";"_$P(DIC,"^",2) K DIC G:Y<0 EX
-	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
-	; 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")=""
-	I XQORS>1,$D(^TMP("XQORS",$J,XQORS-1,"ITM")),$D(^TMP("XQORS",$J,XQORS-1,"ITM",^TMP("XQORS",$J,XQORS-1,"ITM"),"IN")) S ^TMP("XQORS",$J,XQORS,"INP")=^TMP("XQORS",$J,XQORS-1,"ITM",^TMP("XQORS",$J,XQORS-1,"ITM"),"IN")
-	I XQORS>1,$D(XQORFLG("PI")) K XQORFLG("PI") S ^TMP("XQORS",$J,XQORS,"INP")=^TMP("XQORS",$J,XQORS-1,"INP")
-	S XQORNOD=^TMP("XQORS",$J,XQORS,"VPT"),XQORNOD(0)=^TMP("XQORS",$J,XQORS,"INP")
-	I XQORS>1,$D(^TMP("XQORS",$J,XQORS-1,"FLG")) S X=^TMP("XQORS",$J,XQORS-1,"FLG"),$P(^TMP("XQORS",$J,XQORS,"FLG"),"^",3)=$S($L($P(X,"^",5)):$P(X,"^",5),1:$P(X,"^",3))
-	I ^TMP("XQORS",$J,0,"FILE")=";ORD(101,",$D(@(^TMP("XQORS",$J,XQORS,"REF")_"4)")) S:$P(^(4),"^",3)="Y" $P(^TMP("XQORS",$J,XQORS,"FLG"),"^",2)=1
-	I ^TMP("XQORS",$J,0,"FILE")=";DIC(19,",$P(^TMP("XQORS",$J,XQORS,"FLG"),"^")="M" S $P(^TMP("XQORS",$J,XQORS,"FLG"),"^",2)=1
-	I $D(XQORFLG) S:$D(XQORFLG("PS")) $P(^TMP("XQORS",$J,XQORS,"FLG"),"^",2)=+XQORFLG("PS") S:$D(XQORFLG("SH")) $P(^TMP("XQORS",$J,XQORS,"FLG"),"^",3)=+XQORFLG("SH") K XQORFLG
-	I $D(ORITMO) S $P(^TMP("XQORS",$J,XQORS,"FLG"),"^",6)=1 K ORITMO G REDO^XQOR1
-	I $P(^TMP("XQORS",$J,XQORS,"FLG"),"^")="D" N XQORDLG
-	G LOOP^XQOR1
-EX	K XQORNEST(XQORS),XQORFLG,XQORNOD,XQORY,^TMP("XQORS",$J,XQORS) S XQORS=XQORS-1,XQORNEST=XQORS ;pop
-	I XQORS=0 K XQORNEST,XQORS,^TMP("XQORS",$J),XQORSPEW
-	Q
-EN1	;Process items on option/protocol only (i.e., skip initial actions)
-	;From: Anywhere  Entry: X,DIC  Exit: none
-	S ORITMO=1 G EN
-	Q
-XQ	;From: Menuman  Entry: XQOR  Exit: XQOR
-	S X=+XQOR_";DIC(19," I $D(^DD(19,0,"VR")),^("VR")<5.9 G EN
-	G EN1
-MSG(X,XQORMSG)	;Event point for HL7 messages
-	N DIC S DIC=101
-	I '$D(XQORHSTK) N XQORHSTK S XQORHSTK=-1 K ^TMP("XQORHSTK",$J)
-	S XQORHSTK=XQORHSTK+1
-	K ^TMP("XQORHSTK",$J,XQORHSTK) M ^TMP("XQORHSTK",$J,XQORHSTK)=XQORMSG
-	D EN^XQOR
-	S XQORHSTK=XQORHSTK-1
-	I XQORHSTK>-1 K XQORMSG M XQORMSG=^TMP("XQORHSTK",$J,XQORHSTK)
-	I XQORHSTK=-1 K ^TMP("XQORHSTK",$J)
-	Q
+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
+ ;From: Anywhere  Entry: X,{DIC,XQORFLG}  Exit: none
+ Q:$D(X)[0  K XQORPOP,XQORQUIT
+ I '$D(XQORS) S XQORS=0 K ^TMP("XQORS",$J)
+ S XQORS=XQORS+1 ;push
+ I $D(XQOR("HIJACK")) S X=XQOR("HIJACK"),DIC=101 K XQOR("HIJACK")
+ I X?1.N1";ORD(101,"!(X?1.N1";DIC(19,") S ^TMP("XQORS",$J,XQORS,"REF")="^"_$P(X,";",2)_+X_",",^TMP("XQORS",$J,XQORS,"VPT")=X
+ E  S:$D(DIC)[0 DIC=19 S DIC(0)="N" D ^DIC S:Y>0 ^TMP("XQORS",$J,XQORS,"REF")=DIC_+Y_",",^TMP("XQORS",$J,XQORS,"VPT")=+Y_";"_$P(DIC,"^",2) K DIC G:Y<0 EX
+ 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
+ ; 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")=""
+ I XQORS>1,$D(^TMP("XQORS",$J,XQORS-1,"ITM")),$D(^TMP("XQORS",$J,XQORS-1,"ITM",^TMP("XQORS",$J,XQORS-1,"ITM"),"IN")) S ^TMP("XQORS",$J,XQORS,"INP")=^TMP("XQORS",$J,XQORS-1,"ITM",^TMP("XQORS",$J,XQORS-1,"ITM"),"IN")
+ I XQORS>1,$D(XQORFLG("PI")) K XQORFLG("PI") S ^TMP("XQORS",$J,XQORS,"INP")=^TMP("XQORS",$J,XQORS-1,"INP")
+ S XQORNOD=^TMP("XQORS",$J,XQORS,"VPT"),XQORNOD(0)=^TMP("XQORS",$J,XQORS,"INP")
+ I XQORS>1,$D(^TMP("XQORS",$J,XQORS-1,"FLG")) S X=^TMP("XQORS",$J,XQORS-1,"FLG"),$P(^TMP("XQORS",$J,XQORS,"FLG"),"^",3)=$S($L($P(X,"^",5)):$P(X,"^",5),1:$P(X,"^",3))
+ I ^TMP("XQORS",$J,0,"FILE")=";ORD(101,",$D(@(^TMP("XQORS",$J,XQORS,"REF")_"4)")) S:$P(^(4),"^",3)="Y" $P(^TMP("XQORS",$J,XQORS,"FLG"),"^",2)=1
+ I ^TMP("XQORS",$J,0,"FILE")=";DIC(19,",$P(^TMP("XQORS",$J,XQORS,"FLG"),"^")="M" S $P(^TMP("XQORS",$J,XQORS,"FLG"),"^",2)=1
+ I $D(XQORFLG) S:$D(XQORFLG("PS")) $P(^TMP("XQORS",$J,XQORS,"FLG"),"^",2)=+XQORFLG("PS") S:$D(XQORFLG("SH")) $P(^TMP("XQORS",$J,XQORS,"FLG"),"^",3)=+XQORFLG("SH") K XQORFLG
+ I $D(ORITMO) S $P(^TMP("XQORS",$J,XQORS,"FLG"),"^",6)=1 K ORITMO G REDO^XQOR1
+ I $P(^TMP("XQORS",$J,XQORS,"FLG"),"^")="D" N XQORDLG
+ G LOOP^XQOR1
+EX K XQORNEST(XQORS),XQORFLG,XQORNOD,XQORY,^TMP("XQORS",$J,XQORS) S XQORS=XQORS-1,XQORNEST=XQORS ;pop
+ I XQORS=0 K XQORNEST,XQORS,^TMP("XQORS",$J),XQORSPEW
+ Q
+EN1 ;Process items on option/protocol only (i.e., skip initial actions)
+ ;From: Anywhere  Entry: X,DIC  Exit: none
+ S ORITMO=1 G EN
+ Q
+XQ ;From: Menuman  Entry: XQOR  Exit: XQOR
+ S X=+XQOR_";DIC(19," I $D(^DD(19,0,"VR")),^("VR")<5.9 G EN
+ G EN1
+MSG(X,XQORMSG) ;Event point for HL7 messages
+ N DIC S DIC=101
+ I '$D(XQORHSTK) N XQORHSTK S XQORHSTK=-1 K ^TMP("XQORHSTK",$J)
+ S XQORHSTK=XQORHSTK+1
+ K ^TMP("XQORHSTK",$J,XQORHSTK) M ^TMP("XQORHSTK",$J,XQORHSTK)=XQORMSG
+ D EN^XQOR
+ S XQORHSTK=XQORHSTK-1
+ I XQORHSTK>-1 K XQORMSG M XQORMSG=^TMP("XQORHSTK",$J,XQORHSTK)
+ I XQORHSTK=-1 K ^TMP("XQORHSTK",$J)
+ Q
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,47 +1,47 @@
-XQOR4	; SLC/KCM - Process "^^" jump ;1/23/07  15:36
-	;;8.0;KERNEL;**56,62,437**;Jul 10, 1995;Build 23
-	; 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"))
-	I $D(VALMCC) N XQORLMGR S XQORLMGR="" D FULL^VALM1 ; List Mgr Running?
-	S X=^TMP("XQORS",$J,XQORS,"ITM",^TMP("XQORS",$J,XQORS,"ITM"),"IN")
-	I '$L($P(X,"^",3)) W !!,"For entry ""^^",$P(X,"^",4),""" -"
-	S X=$P(X,"^",4,99) D EAT^XQORM1 ;Q:$E(X,1,2)'="^^"
-	S X=$P(X,"=",1),D="K.ORWARD",DIC="^ORD(101,",DIC(0)="SE" D IX^DIC K DIC,D
-	I Y<0!('$D(^ORD(101,+Y,0))) W:(X'["^")&(X'["?") !!,">>>  ",X," not found or selected.  No action taken." D:(X'["^")&(X'["?") READ S X="" G DJMPX
-	S ORNSV=+Y
-	K X F I=1:1:XQORS I $P(^TMP("XQORS",$J,XQORS,"VPT"),";",2)="ORD(101,",$D(^ORD(101,+^TMP("XQORS",$J,XQORS,"VPT"),21)) D DJMP1
-	S X="" F I=0:0 S X=$O(X(X)) Q:X=""  N @X
-	S X=ORNSV_";ORD(101," K ORNSV
-	D EN^XQOR
-DJMPX	I $D(XQORLMGR) S VALMBCK="R"                       ; Refresh List Mgr
-	Q
-DJMP1	F J=0:0 S J=$O(^ORD(101,+^TMP("XQORS",$J,XQORS,"VPT"),21,J)) Q:J'>0  I $D(^ORD(101,+^TMP("XQORS",$J,XQORS,"VPT"),21,J,0)) S X=^(0) I X?1A.ANP!(X?1"%".ANP) S X(X)=""
-	Q
-SHDR	;Display sub-header
-	Q:'$D(@(^TMP("XQORS",$J,XQORS,"REF")_"0)"))  S X=$P(^(0),"^",2) W:X'?1." " !!?(36-($L(X)\2)),"--- "_X_" ---"
-	Q
-	;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
-	S ORNSV=$P(X0,"^",9),X="NOW",%DT="T" D ^%DT S X=$P(Y,".",2) I X>$P(ORNSV,"-"),X<$P(ORNSV,"-",2) W !!,"Not Available: ",ORNSV,! K ORNSV D READ S Y=-1 Q
-	K ORNSV I "QMOXALDT"'[$P(^TMP("XQORS",$J,XQORS,"FLG"),"^") W !!,"This option type not supported by 'unwinder' routines.",! D READ S Y=-1 Q
-	S Y=1 Q
+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"))
+ I $D(VALMCC) N XQORLMGR S XQORLMGR="" D FULL^VALM1 ; List Mgr Running?
+ S X=^TMP("XQORS",$J,XQORS,"ITM",^TMP("XQORS",$J,XQORS,"ITM"),"IN")
+ I '$L($P(X,"^",3)) W !!,"For entry ""^^",$P(X,"^",4),""" -"
+ S X=$P(X,"^",4,99) D EAT^XQORM1 ;Q:$E(X,1,2)'="^^"
+ S X=$P(X,"=",1),D="K.ORWARD",DIC="^ORD(101,",DIC(0)="SE" D IX^DIC K DIC,D
+ I Y<0!('$D(^ORD(101,+Y,0))) W:(X'["^")&(X'["?") !!,">>>  ",X," not found or selected.  No action taken." D:(X'["^")&(X'["?") READ S X="" G DJMPX
+ S ORNSV=+Y
+ K X F I=1:1:XQORS I $P(^TMP("XQORS",$J,XQORS,"VPT"),";",2)="ORD(101,",$D(^ORD(101,+^TMP("XQORS",$J,XQORS,"VPT"),21)) D DJMP1
+ S X="" F I=0:0 S X=$O(X(X)) Q:X=""  N @X
+ S X=ORNSV_";ORD(101," K ORNSV
+ D EN^XQOR
+DJMPX I $D(XQORLMGR) S VALMBCK="R"                       ; Refresh List Mgr
+ Q
+DJMP1 F J=0:0 S J=$O(^ORD(101,+^TMP("XQORS",$J,XQORS,"VPT"),21,J)) Q:J'>0  I $D(^ORD(101,+^TMP("XQORS",$J,XQORS,"VPT"),21,J,0)) S X=^(0) I X?1A.ANP!(X?1"%".ANP) S X(X)=""
+ Q
+SHDR ;Display sub-header
+ Q:'$D(@(^TMP("XQORS",$J,XQORS,"REF")_"0)"))  S X=$P(^(0),"^",2) W:X'?1." " !!?(36-($L(X)\2)),"--- "_X_" ---"
+ Q
+ ;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
+ S ORNSV=$P(X0,"^",9),X="NOW",%DT="T" D ^%DT S X=$P(Y,".",2) I X>$P(ORNSV,"-"),X<$P(ORNSV,"-",2) W !!,"Not Available: ",ORNSV,! K ORNSV D READ S Y=-1 Q
+ K ORNSV I "QMOXALDT"'[$P(^TMP("XQORS",$J,XQORS,"FLG"),"^") W !!,"This option type not supported by 'unwinder' routines.",! D READ S Y=-1 Q
+ S Y=1 Q
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,72 +1,62 @@
-XUP	;SFISC/RWF - Setup enviroment for programmers ;10/12/06  12:45
-	;;8.0;KERNEL;**208,258,284,432**;Jul 10, 1995;Build 3
-	W !,"Setting up programmer environment"
-	S U="^",$ECODE="",$ETRAP="" ;Clear error and error trap
-	X ^%ZOSF("TYPE-AHEAD")
-	;Check if Production and report
-	W !,"This is a "_$S($$PROD^XUPROD(1):"PRODUCTION",1:"TEST")_" account.",!
-	;
-	K ^UTILITY($J),^XUTL("XQ",$J) D KILL1^XUSCLEAN
-	S U="^",DT=$$DT^XLFDT
-	S XUEOFF=^%ZOSF("EOFF"),XUEON=^%ZOSF("EON"),U="^",XUTT=0,XUIOP=""
-	D GETENV^%ZOSV S XUENV=Y,XUVOL=$P(Y,U,2),XUCI=$P(Y,U,1)
-	;Reset DUZ if user "Switched Identities".
-	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
-	S X="`"_+$G(^VA(200,DUZ,1.2)),DIC="^%ZIS(2,",DIC(0)="MQ"_$S(X]"`0":"",1:"AE") D ^DIC G:Y'>0 EXIT
-	S XUIOP(1)=$P(Y,U,2) I DIC(0)["A",$G(^VA(200,+DUZ,0))]"" S $P(^VA(200,DUZ,1.2),U,1)=+Y
-ZIS2	S %ZIS="L",IOP="HOME;"_XUIOP(1) D ^%ZIS G EXIT:POP W !,"Terminal Type set to: ",IOST,!
-	S DTIME=$$DTIME(DUZ,IOS),DUZ("BUF")=1,XUDEV=IOS
-	;Save info, Set last sign-on
-	D SAVE^XUS1 S $P(^VA(200,DUZ,1.1),"^",1)=$$NOW^XLFDT
-	;Check Mail
-	S Y=$P($G(^XMB(3.7,DUZ,0)),U,6) I Y W !,"You have "_Y_" new message"_$S(Y=1:"",1:"s")_"."
-	;Setup error trap
-	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
-	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
-	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
-	;
-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"))
-	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)
-	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)
-	Q $S(P]"":P,1:300)
-	;
-ERR	;
-	N %XUP 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
+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"
+ N $ESTACK,$ETRAP S $ECODE="",$ETRAP="" ;Clear and error trap
+ X ^%ZOSF("TYPE-AHEAD")
+ ;Check if Production and report
+ W !,"This is a "_$S($$PROD^XUPROD(1):"PRODUCTION",1:"TEST")_" account.",!
+ ;
+ K ^UTILITY($J),^XUTL("XQ",$J) D KILL1^XUSCLEAN
+ S U="^",DT=$$DT^XLFDT
+ S XUEOFF=^%ZOSF("EOFF"),XUEON=^%ZOSF("EON"),U="^",XUTT=0,XUIOP=""
+ D GETENV^%ZOSV S XUENV=Y,XUVOL=$P(Y,U,2),XUCI=$P(Y,U,1)
+ ;Reset DUZ if user "Switched Identities".
+ I $D(DUZ("SAV")) S DUZ=+DUZ("SAV"),DUZ(0)=$P(DUZ("SAV"),U,2) K DUZ("SAV")
+ ;Get user info
+ 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
+ ;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
+ S X="`"_+$G(^VA(200,DUZ,1.2)),DIC="^%ZIS(2,",DIC(0)="MQ"_$S(X]"`0":"",1:"AE") D ^DIC G:Y'>0 EXIT
+ S XUIOP(1)=$P(Y,U,2) I DIC(0)["A",$G(^VA(200,+DUZ,0))]"" S $P(^VA(200,DUZ,1.2),U,1)=+Y
+ZIS2 S %ZIS="L",IOP="HOME;"_XUIOP(1) D ^%ZIS G EXIT:POP W !,"Terminal Type set to: ",IOST,!
+ S DTIME=$$DTIME(DUZ,IOS),DUZ("BUF")=1,XUDEV=IOS
+ ;Save info, Set last sign-on
+ D SAVE^XUS1 S $P(^VA(200,DUZ,1.1),"^",1)=$$NOW^XLFDT
+ ;Check Mail
+ S Y=$P($G(^XMB(3.7,DUZ,0)),U,6) I Y W !,"You have "_Y_" new message"_$S(Y=1:"",1:"s")_"."
+ ;Setup error trap
+ 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 D KILL1^XUSCLEAN K XQY,XQY0
+ I $$GET^XPAR("USR^SYS","XUS-XUP VPE",1,"Q"),$D(^%ZVEMS) X ^%ZVEMS ;Run VPE
+ 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
+ ;
+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"))
+ 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"),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)
+ Q $S(P]"":P,1:300)
+ ;
+ERR ;
+ U $P
+ W !,"$ECODE=",$ECODE,"   $STACK=",$STACK
+ 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
+ ;
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,52 +1,43 @@
-XUPROD	;ISF/RWF - Is this a PROD account. ;8/23/07  16:47
-	;;8.0;KERNEL;**284,440**;Jul 10, 1995;Build 13
-	;
-	;IA# 4440
-PROD(FORCE)	;Return 1 if this is a production account
-	;A non-zero flag will force a real check
-	;This call just checks a flag in the KSP, Other code will compair
-	;with registered ID.
-	N LC,SID
-	S SID=$G(^XTV(8989.3,1,"SID"))
-	I '$L($P(SID,"^",3))!($P(SID,"^",3)'=$G(DT))!$G(FORCE) D
-	. D CHECK S SID=$G(^XTV(8989.3,1,"SID"))
-	Q +$P(SID,"^",1)
-	;
-CHECK	;Check if SID matched stored value, Set field 501
-	N CSID,SSID,FDA
-	L +^XTV(8989.3,1,"SID"):2
-	S CSID=$$SID^%ZOSV,SSID=$P($G(^XTV(8989.3,1,"SID")),"^",2)
-	S FDA(8989.3,"1,",501)=(CSID=SSID),FDA(8989.3,"1,",503)=$$DT^XLFDT
-	D FILE^DIE("","FDA")
-	L -^XTV(8989.3,1,"SID")
-	Q
-	;
-SSID(SID)	;Set the SID into KSP.
-	N FDA
-	S FDA(8989.3,"1,",502)=SID,FDA(8989.3,"1,",503)="@"
-	L +^XTV(8989.3,1,"SID"):2
-	D FILE^DIE("","FDA")
-	L -^XTV(8989.3,1,"SID")
-	Q
-ASK	;Ask user if this is prod.
-	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."
-	D ^DIR Q:$D(DIRUT)
-	I Y=1 D SSID($$SID^%ZOSV)
-	E  D SSID("2~TEST~999")
-	S P=$$PROD
-	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
+XUPROD ;ISF/RWF - Is this a PROD account. ;06/17/2004  08:13
+ ;;8.0;KERNEL;**284**;Jul 10, 1995
+ ;
+ ;IA# 4440
+PROD(FORCE) ;Return 1 if this is a production account
+ ;A non-zero flag will force a real check
+ ;This call just checks a flag in the KSP, Other code will compair
+ ;with registered ID.
+ N LC,SID
+ S SID=$G(^XTV(8989.3,1,"SID"))
+ I '$L($P(SID,"^",3))!($P(SID,"^",3)'=$G(DT))!$G(FORCE) D
+ . D CHECK S SID=$G(^XTV(8989.3,1,"SID"))
+ Q +$P(SID,"^",1)
+ ;
+CHECK ;Check if SID matched stored value, Set field 501
+ N CSID,SSID,FDA
+ L +^XTV(8989.3,1,"SID"):2
+ S CSID=$$SID^%ZOSV,SSID=$P($G(^XTV(8989.3,1,"SID")),"^",2)
+ S FDA(8989.3,"1,",501)=(CSID=SSID),FDA(8989.3,"1,",503)=$$DT^XLFDT
+ D FILE^DIE("","FDA")
+ L -^XTV(8989.3,1,"SID")
+ Q
+ ;
+SSID(SID) ;Set the SID into KSP.
+ N FDA
+ S FDA(8989.3,"1,",502)=SID,FDA(8989.3,"1,",503)="@"
+ L +^XTV(8989.3,1,"SID"):2
+ D FILE^DIE("","FDA")
+ L -^XTV(8989.3,1,"SID")
+ Q
+ASK ;Ask user if this is prod.
+ N DIR,P S P=$$PROD
+ S DIR(0)="YO",DIR("A")="Is this a Production Account",DIR("B")="No"
+ 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)
+ E  D SSID("2~TEST~999")
+ S P=$$PROD
+ W:P !!,"This is now a PRODUCTION account.",! W:'P !!,"This is now a TEST account.",!
+ Q
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,179 +1,174 @@
-XUS	;SFISC/STAFF - SIGNON ;1:27 PM  11 Dec 2008
-	;;8.0;KERNEL;**16,26,49,59,149,180,265,337,419,434,437**;Jul 10, 1995;Build 23
-	; 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
-	;
-	;Sign-on message numbers are 30810.51 to 30810.99
-	S U="^" D INTRO^XUS1A()
-	K  K ^XUTL("ZISPARAM",$I)
-	S U="^",XQXFLG("GUI")="^"
-	W ! S $Y=0 D SET1(1) I POP S XUM=3 G NO ;Sets DUZ("LANG")
-	S XUSTMP(51)=$$EZBLD^DIALOG(30810.51),XUSTMP(52)=$$EZBLD^DIALOG(30810.52)
-	W !!,"Volume set: ",$P(XUENV,U,4),"  UCI: ",XUCI,"  Device: ",$I W:$S('$D(IO("ZIO")):0,1:$I'=IO("ZIO")) " (",IO("ZIO"),")" W !
-RESTART	;
-	S XUM=$$SET2 G:XUM NO
-	I $P(XU1,U,2)]"" S XUM=$$DEVPAS() I XUM G H:XUM<0,NO
-	;S PGM=$P(XOPT,U,8),XUA=$P(PGM,"[",1) I XUA]"" X XUEON G NEXT^XUS1
-A	S (XUSER(0),XUSER(1),XQUR)=""
-	;Check for locked IP/device.
-	I $$LKCHECK^XUSTZIP() S XUM=7,XUFAC=$P(XOPT,U,2),XUHALT=1 G NO
-	;Auto Sign-on check
-	S X=$$AUTOXUS^XUS1B() I X>0 S DUZ=X D USER(DUZ) W !!,">> Auto Sign-on: ",$P(XUSER(0),U)," <<<",! G B
-	X XUEOFF S AV=$$ASKAV() X XUEON I AV="^;^" G H ;Get out
-	I AV["MAIL-BOX",AV[";XMR" S (XUA,PGM)="XMR",XMCHAN=$P($P(AV,";")," ",2),DUZ=.5 G XMR^XUSCLEAN
-	S XQUR=$P(AV,";",3)
-	S DUZ=$$CHECKAV(AV) K AV
-	S XUM=$$UVALID() G:XUM NO
-B	K XUF,%1 S XUF=0 X XUEON
-	I DUZ D USER^XUS1 G:XUM NO
-	I DUZ D SEC^XUS3:($D(^%ZIS(1,XUDEV,"TIME"))!$D(^(95))) G:XUM NO
-	G NO:'DUZ
-	S DTIME=$P(XOPT,U,10),X=$S(DUZ("BUF"):"",1:"NO-")_"TYPE-AHEAD" X:$D(^%ZOSF(X)) ^(X)
-	D TT^XUS3:$G(XUTT)
-	D CLRFAC^XUS3($G(IO("IP")))
-PGM	;
-	S Y=+$G(^%ZIS(1,XUDEV,201)) I Y>0,$$CHK S XQY=Y G OK
-	S Y=+$G(^VA(200,DUZ,201)) I Y>0,$$CHK S XQY=Y G OK
-	I $D(DUZ("ASH")) S Y=$O(^DIC(19,"B","XU NOP MENU",0)) I Y>0 S XQY=Y G OK ;rwf 403
-	S XUM=16
-	G NO
-	;
-OK	D CHEK^XQ83
-	S (XUA,PGM)="XQ"
-	G NEXT^XUS1
-	;
-CHK()	;Check that option exeist and LOCK
-	I $D(^DIC(19,Y,0)),$S($P(^(0),U,6)="":1,1:$D(^XUSEC($P(^(0),U,6),DUZ))) Q 1
-	Q 0
-	;
-LC	S X=$$UP(X)
-	Q
-UP(%)	Q $TR(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
-	;
-FAC	;Failed access
-	S:'DUZ XUF(.1)=$E(%1)
-	S:XUF=2 XUF(.2)=XUF(.2)+1,XUF(XUF(.2))=%1 S %1="" Q
-	Q
-NO	;Tell why didn't get on
-	S X=$$NO^XUS3() G RESTART:'X ;fall into exit
-H	;Exit point for all applications
-C	;CLOSE
-	G ^XUSCLEAN
-	;
-ON	X ^%ZOSF("EON") Q
-	;
-ASKAV(PRE)	;Ask and return Access;Verify code, Turn off echo before calling
-	N X,Y S PRE=$G(PRE)
-	F  W !,PRE,XUSTMP(51) S X=$$ACCEPT S:X="^" X="^;^" Q:$L(X)
-	S X=$TR(X,$C(9),";") ;Convert TAB to ; to match GUI.
-	I $P(X," ")="MAIL-BOX" S X=X_";XMR"
-	I $E(X,1,7)="~~TOK~~" Q X ;Use CCOW token
-	I '$L($P(X,";",2)) W !,PRE,XUSTMP(52) S Y=$$ACCEPT S:Y="^" X="^;" S $P(X,";",2)=Y
-	Q X
-	;
-	;Timeout used by XUSTZ call.
-ACCEPT(TO)	;Read A/V and echo '*' char.
-	;Have the Read write to flush the buffer on some systems
-	N C,A,E K DUOUT S A="",TO=$G(TO,60),E=0
-	F  D  Q:E
-	. R "",*C:TO S:('$T) DUOUT=1 S:('$T)!(C=94) A="^"
-	. I (A="^")!(C=13)!($L(A)>60) S E=1 Q
-	. I C=127 Q:'$L(A)  S A=$E(A,1,$L(A)-1) W $C(8,32,8) Q
-	. S A=A_$C(C) W *42
-	. Q
-	Q A
-	;
-CHECKAV(X1)	;Check A/V code return DUZ or Zero. (Called from XUSRB)
-	N %,%1,X,Y,IEN,DA,DIK
-	S IEN=0
-	;Start CCOW
-	I $E(X1,1,7)="~~TOK~~" D  Q:IEN>0 IEN
-	. I $E(X1,8,9)="~1" S IEN=$$CHKASH^XUSRB4($E(X1,8,255))
-	. I $E(X1,8,9)="~2" S IEN=$$CHKCCOW^XUSRB4($E(X1,8,255))
-	. Q
-	;End CCOW
-	; WV p437 ;Allow case sensitivefor VOE
-	S X1=$S($$GET^XPAR("SYS","XU VC CASE SENSITIVE"):$$UP($P(X1,";",1))_";"_$P(X1,";",2),1:$$UP(X1))
-	; End WV change
-	S X1=$$UP(X1) S:X1[":" XUTT=1,X1=$TR(X1,":")
-	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 %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)
-	I $P(XUSER(1),"^",2)'=X D LBAV Q 0
-	I $G(XUFAC(1)) S DIK="^XUSEC(4,",DA=XUFAC(1) D ^DIK
-	Q IEN
-LBAV	;Log Bad AV
-	D:XUF FAC
-	I IEN S X=$P($G(^VA(200,IEN,1.1)),U,2)+1,$P(^(1.1),"^",2)=X
-	Q
-	;
-USER(IX)	;Build XUSER
-	S XUSER(0)=$G(^VA(200,+IX,0)),XUSER(1)=$G(^(.1)),XUSER(1.1)=$G(^(1.1))
-	Q
-	;
-XUVOL	;Setup XUENV, XUCI,XQVOL,XUVOL
-	S U="^" D GETENV^%ZOSV S XUENV=Y,XUCI=$P(Y,U,1),XQVOL=$P(Y,U,2)
-	S X=$O(^XTV(8989.3,1,4,"B",XQVOL,0)),XUVOL=$S(X>0:^XTV(8989.3,1,4,X,0),1:XQVOL_"^y^1")
-	Q
-	;
-XOPT	;Setup initial XOPT
-	S XOPT=$S($D(^XTV(8989.3,1,"XUS")):^("XUS"),1:"")
-	F I=2:1:15 I $P(XOPT,U,I)="" S $P(XOPT,U,I)=$P("^5^900^1^1^^^^1^300^^^^N^90",U,I)
-	Q
-	;
-SET1(FLAG)	;Setup parameters (also called from XUSRB)
-	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
-	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
-	D GETFAC^XUS3($G(IO("IP")))
-	S %=$P(XOPT,U,14)
-	I "N"'[% D
-	. 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)
-	N %,X
-	S XUNOW=$$HTFM^XLFDT($H),DT=$P(XUNOW,".")
-	K DUZ,XUSER
-	S (DUZ,DUZ(2))=0,(DUZ(0),DUZ("AG"),XUSER(0),XUSER(1),XUTT,%UCI)=""
-	S %=$$INHIBIT^XUSRB() I %>0 Q %
-	S X=$G(^%ZIS(1,XUDEV,"XUS")),XU1=$G(^(1))
-	I $L(X) F I=1:1:15 I $L($P(X,U,I)) S $P(XOPT,U,I)=$P(X,U,I)
-	S DTIME=600
-	I '$P(XOPT,U,11),$D(^%ZIS(1,XUDEV,90)),^(90)>2800000,^(90)'>DT Q 8
-	Q 0
-	;
-UVALID()	;EF. Is it valid for this user to sign on?
-	I DUZ'>0 Q 4
-	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
-	Q 0
-	;
-DEVPAS()	;EF. Ask device password
-	X XUEOFF W !,"DEVICE PASSWORD: " R X:60 X XUEON
-	S X=$E(X,1,30) S:'$T X="^" D LC Q:X["^" -1 I $P(XU1,U,2)'=X S:XUF %1="Device: "_X D:XUF FAC Q 6
-	Q 0
-	;
+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()
+ K  K ^XUTL("ZISPARAM",$I)
+ S U="^",XQXFLG("GUI")="^"
+ W ! S $Y=0 D SET1(1) I POP S XUM=3 G NO ;Sets DUZ("LANG")
+ S XUSTMP(51)=$$EZBLD^DIALOG(30810.51),XUSTMP(52)=$$EZBLD^DIALOG(30810.52)
+ W !!,"Volume set: ",$P(XUENV,U,4),"  UCI: ",XUCI,"  Device: ",$I W:$S('$D(IO("ZIO")):0,1:$I'=IO("ZIO")) " (",IO("ZIO"),")" W !
+RESTART ;
+ S XUM=$$SET2 G:XUM NO
+ I $P(XU1,U,2)]"" S XUM=$$DEVPAS() I XUM G H:XUM<0,NO
+ ;S PGM=$P(XOPT,U,8),XUA=$P(PGM,"[",1) I XUA]"" X XUEON G NEXT^XUS1
+A S (XUSER(0),XUSER(1),XQUR)=""
+ ;Check for locked IP/device.
+ I $$LKCHECK^XUSTZIP() S XUM=7,XUFAC=$P(XOPT,U,2),XUHALT=1 G NO
+ ;Auto Sign-on check
+ S X=$$AUTOXUS^XUS1B() I X>0 S DUZ=X D USER(DUZ) W !!,">> Auto Sign-on: ",$P(XUSER(0),U)," <<<",! G B
+ X XUEOFF S AV=$$ASKAV() X XUEON I AV="^;^" G H ;Get out
+ I AV["MAIL-BOX",AV[";XMR" S (XUA,PGM)="XMR",XMCHAN=$P($P(AV,";")," ",2),DUZ=.5 G XMR^XUSCLEAN
+ S XQUR=$P(AV,";",3)
+ S DUZ=$$CHECKAV(AV) K AV
+ S XUM=$$UVALID() G:XUM NO
+B K XUF,%1 S XUF=0 X XUEON
+ I DUZ D USER^XUS1 G:XUM NO
+ I DUZ D SEC^XUS3:($D(^%ZIS(1,XUDEV,"TIME"))!$D(^(95))) G:XUM NO
+ G NO:'DUZ
+ S DTIME=$P(XOPT,U,10),X=$S(DUZ("BUF"):"",1:"NO-")_"TYPE-AHEAD" X:$D(^%ZOSF(X)) ^(X)
+ D TT^XUS3:$G(XUTT)
+ D CLRFAC^XUS3($G(IO("IP")))
+PGM ;
+ S Y=+$G(^%ZIS(1,XUDEV,201)) I Y>0,$$CHK S XQY=Y G OK
+ S Y=+$G(^VA(200,DUZ,201)) I Y>0,$$CHK S XQY=Y G OK
+ I $D(DUZ("ASH")) S Y=$O(^DIC(19,"B","XU NOP MENU",0)) I Y>0 S XQY=Y G OK ;rwf 403
+ S XUM=16
+ G NO
+ ;
+OK D CHEK^XQ83
+ S (XUA,PGM)="XQ"
+ G NEXT^XUS1
+ ;
+CHK() ;Check that option exeist and LOCK
+ I $D(^DIC(19,Y,0)),$S($P(^(0),U,6)="":1,1:$D(^XUSEC($P(^(0),U,6),DUZ))) Q 1
+ Q 0
+ ;
+LC S X=$$UP(X)
+ Q
+UP(%) Q $TR(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+ ;
+FAC ;Failed access
+ S:'DUZ XUF(.1)=$E(%1)
+ S:XUF=2 XUF(.2)=XUF(.2)+1,XUF(XUF(.2))=%1 S %1="" Q
+ Q
+NO ;Tell why didn't get on
+ S X=$$NO^XUS3() G RESTART:'X ;fall into exit
+H ;Exit point for all applications
+C ;CLOSE
+ G ^XUSCLEAN
+ ;
+ON X ^%ZOSF("EON") Q
+ ;
+ASKAV(PRE) ;Ask and return Access;Verify code, Turn off echo before calling
+ N X,Y S PRE=$G(PRE)
+ F  W !,PRE,XUSTMP(51) S X=$$ACCEPT S:X="^" X="^;^" Q:$L(X)
+ S X=$TR(X,$C(9),";") ;Convert TAB to ; to match GUI.
+ I $P(X," ")="MAIL-BOX" S X=X_";XMR"
+ I $E(X,1,7)="~~TOK~~" Q X ;Use CCOW token
+ I '$L($P(X,";",2)) W !,PRE,XUSTMP(52) S Y=$$ACCEPT S:Y="^" X="^;" S $P(X,";",2)=Y
+ Q X
+ ;
+ ;Timeout used by XUSTZ call.
+ACCEPT(TO) ;Read A/V and echo '*' char.
+ ;Have the Read write to flush the buffer on some systems
+ N C,A,E K DUOUT S A="",TO=$G(TO,60),E=0
+ F  D  Q:E
+ . R "",*C:TO S:('$T) DUOUT=1 S:('$T)!(C=94) A="^"
+ . I (A="^")!(C=13)!($L(A)>60) S E=1 Q
+ . I C=127 Q:'$L(A)  S A=$E(A,1,$L(A)-1) W $C(8,32,8) Q
+ . S A=A_$C(C) W *42
+ . Q
+ Q A
+ ; 
+CHECKAV(X1) ;Check A/V code return DUZ or Zero. (Called from XUSRB)
+ N %,%1,X,Y,IEN,DA,DIK
+ S IEN=0
+ ;Start CCOW
+ I $E(X1,1,7)="~~TOK~~" D  Q:IEN>0 IEN
+ . I $E(X1,8,9)="~1" S IEN=$$CHKASH^XUSRB4($E(X1,8,255))
+ . I $E(X1,8,9)="~2" S IEN=$$CHKCCOW^XUSRB4($E(X1,8,255))
+ . Q
+ ;End CCOW
+ 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 ; 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)
+ I $P(XUSER(1),"^",2)'=X D LBAV Q 0
+ I $G(XUFAC(1)) S DIK="^XUSEC(4,",DA=XUFAC(1) D ^DIK
+ Q IEN
+LBAV ;Log Bad AV
+ D:XUF FAC
+ I IEN S X=$P($G(^VA(200,IEN,1.1)),U,2)+1,$P(^(1.1),"^",2)=X
+ Q
+ ;
+USER(IX) ;Build XUSER
+ S XUSER(0)=$G(^VA(200,+IX,0)),XUSER(1)=$G(^(.1)),XUSER(1.1)=$G(^(1.1))
+ Q
+ ;
+XUVOL ;Setup XUENV, XUCI,XQVOL,XUVOL
+ S U="^" D GETENV^%ZOSV S XUENV=Y,XUCI=$P(Y,U,1),XQVOL=$P(Y,U,2)
+ S X=$O(^XTV(8989.3,1,4,"B",XQVOL,0)),XUVOL=$S(X>0:^XTV(8989.3,1,4,X,0),1:XQVOL_"^y^1")
+ Q
+ ;
+XOPT ;Setup initial XOPT
+ S XOPT=$S($D(^XTV(8989.3,1,"XUS")):^("XUS"),1:"")
+ F I=2:1:15 I $P(XOPT,U,I)="" S $P(XOPT,U,I)=$P("^5^900^1^1^^^^1^300^^^^N^90",U,I)
+ Q
+ ;
+SET1(FLAG) ;Setup parameters (also called from XUSRB)
+ 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
+ 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 D:$D(XRTL) T0^%ZOSV
+ D GETFAC^XUS3($G(IO("IP")))
+ S %=$P(XOPT,U,14)
+ I "N"'[% D
+ . 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
+ Q
+SET2() ;EF. Return error code (also called from XUSRB)
+ N %,X
+ S XUNOW=$$HTFM^XLFDT($H),DT=$P(XUNOW,".")
+ K DUZ,XUSER
+ S (DUZ,DUZ(2))=0,(DUZ(0),DUZ("AG"),XUSER(0),XUSER(1),XUTT,%UCI)=""
+ S %=$$INHIBIT^XUSRB() I %>0 Q %
+ S X=$G(^%ZIS(1,XUDEV,"XUS")),XU1=$G(^(1))
+ I $L(X) F I=1:1:15 I $L($P(X,U,I)) S $P(XOPT,U,I)=$P(X,U,I)
+ 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
+ ;
+UVALID() ;EF. Is it valid for this user to sign on?
+ I DUZ'>0 Q 4
+ 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 $P(XUSER(0),U,7) Q 5 ;Disuser flag set
+ I '$L($P(XUSER(1),U,2)) Q 21 ;419
+ Q 0
+ ;
+DEVPAS() ;EF. Ask device password
+ X XUEOFF W !,"DEVICE PASSWORD: " R X:60 X XUEON
+ S X=$E(X,1,30) S:'$T X="^" D LC Q:X["^" -1 I $P(XU1,U,2)'=X S:XUF %1="Device: "_X D:XUF FAC Q 6
+ Q 0
+ ;
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,188 +1,188 @@
-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 23
-	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
-	I "Nn"[$E(X,1) S X="" Q
-	I "Yy"'[$E(X,1) K X Q
-	N DIR,DIR0,XUAUTO,XUK
-	S XUAUTO=($P($G(^XTV(8989.3,1,3)),U,1)="y"),XUH=""
-AC1	D CLR,AAUTO:XUAUTO,AASK:'XUAUTO G OUT:$D(DIRUT) D REASK G OUT:$D(DIRUT),AC1:'XUK D CLR,AST(XUH)
-	G OUT
-	;
-AASK	;Ask for Access code
-	N X,XUU,XUEX X ^%ZOSF("EOFF")
-	S XUEX=0
-	F  D AASK1 Q:XUEX!($D(DIRUT))
-	Q
-	;
-AASK1	;
-	W "Enter a new ACCESS CODE <Hidden>: " D GET Q:$D(DIRUT)
-	I X="@" D DEL D:Y'=1 DIRUT S XUH="",XUEX=1 Q
-	I X[$C(34)!(X[";")!(X["^")!(X[":")!(X'?.UNP)!($L(X)>20)!($L(X)<6)!(X="MAIL-BOX") D CLR W $C(7),$$AVHLPTXT(1) D AHELP Q
-	I 'XUAUTO,((X?6.20A)!(X?6.20N)) D CLR W $C(7),$$AVHLPTXT(1),! Q
-	S XUU=X,X=$$EN^XUSHSH(X),XUH=X,XMB(1)=$O(^VA(200,"A",XUH,0)) I XMB(1),XMB(1)'=DA S XMB="XUS ACCESS CODE VIOLATION",XMB(1)=$P(^VA(200,XMB(1),0),"^"),XMDUN="Security" D ^XMB
-	I $D(^VA(200,"AOLD",XUH))!$D(^VA(200,"A",XUH)) D CLR W $C(7),"This has been used previously as an ACCESS CODE.",! Q
-	S XUEX=1 ;Now we can quit
-	Q
-	;
-REASK	S XUK=1 Q:XUH=""  D CLR X ^%ZOSF("EOFF")
-	F XUK=3:-1:1 W "Please re-type the new code to show that I have it right: " D GET G:$D(DIRUT) DIRUT D ^XUSHSH Q:(XUH=X)  D CLR W "This doesn't match.  Try again!",!,$C(7)
-	S:XUH'=X XUK=0
-	Q
-	;
-AST(XUH)	;Change ACCESS CODE and index.
-	W "OK, Access code has been changed!"
-	N FDA,IEN,ERR
-	S IEN=DA_","
-	S FDA(200,IEN,2)=XUH D FILE^DIE("","FDA","ERR")
-	W !,"The VERIFY CODE has been deleted as a security measure.",!,"You will need to enter a new VERIFY code so the user can sign-on.",$C(7)
-	D VST("",1)
-	I $D(^XMB(3.7,DA,0))[0 S Y=DA D NEW^XM ;Make sure has a Mailbox
-	Q
-	;
-GET	;Get the user input and convert case.
-	S X=$$ACCEPT^XUS I (X["^")!('$L(X)) D DIRUT
-	I '$D(ASKINGVC)!'$$GET^XPAR("SYS","XU VC CASE SENSITIVE") S X=$$UP^XLFSTR(X) ;for VOE allow case sensitive Verify Code
-	Q
-	;
-DIRUT	S DIRUT=1
-	Q
-	;
-CLR	;New line or Clear screenman area
-	I '$D(DDS) W ! Q
-	N DX,DY
-	D CLRMSG^DDS S DX=0,DY=DDSHBX+1 X IOXY
-	Q
-	;
-NEWCODE	D REASK I XUK W !,"OK, remember this code for next time!"
-	G OUT
-	;
-CVC	;From XUS1
-	N DA,X
-	S DA=DUZ,X="Y"
-	W !,"You must change your VERIFY CODE at this time."
-	;Fall into next code
-VERED	; VERIFY CODE EDIT From DD
-	N DIR,DIR0,XUAUTO,ASKINGVC
-	I "Nn"[$E(X,1) S X="" Q
-	I "Yy"'[$E(X,1) K X Q
-	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)
-	G OUT
-	;
-VASK	;Ask for Verify Code
-	N X,XUU X ^%ZOSF("EOFF") G:'$$CHKCUR() DIRUT D CLR
-VASK1	W "Enter a new VERIFY CODE: " D GET Q:$D(DIRUT)
-	I '$D(XUNC),(X="@") D DEL G:Y'=1 DIRUT S XUH="" Q
-	D CLR S XUU=X,X=$$EN^XUSHSH(X),XUH=X,Y=$$VCHK(XUU,XUH) I +Y W $C(7),$P(Y,U,2,9),! D:+Y=1 VHELP G VASK1
-	Q
-	;
-VCHK(S,EC)	;Call with String and Encripted versions
-	;Updated per VHA directive 6210 Strong Passwords
-	N PUNC,NA S PUNC="~`!@#$%&*()_-+=|\{}[]'<>,.?/"
-	S NA("FILE")=200,NA("FIELD")=.01,NA("IENS")=DA_",",NA=$$HLNAME^XLFNAME(.NA)
-	; 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."
-	I $D(^VA(200,DA,"VOLD",EC)) Q "4^This has been used previously as the VERIFY CODE."
-	I EC=$P(^VA(200,DA,0),U,3) Q "5^VERIFY CODE must be different than the ACCESS CODE."
-	I S[$P(NA,"^")!(S[$P(NA,"^",2)) Q "6^Name cannot be part of code."
-	Q 0
-	;
-VST(XUH,%)	;
-	W:$L(XUH)&% !,"OK, Verify code has been changed!"
-	N FDA,IEN,ERR S IEN=DA_","
-	S:XUH="" XUH="@" ;11.2 get triggerd
-	S FDA(200,IEN,11)=XUH D FILE^DIE("","FDA","ERR")
-	I $D(ERR) D ^%ZTER
-	S:DA=DUZ DUZ("NEWCODE")=XUH Q
-	;
-DEL	;
-	X ^%ZOSF("EON") W $C(7) S DIR(0)="Y",DIR("A")="Sure you want to delete" D ^DIR I Y'=1 W:$X>55 !?9 W $C(7),"  <Nothing Deleted>"
-	Q
-	;
-AAUTO	;Auto-get Access codes
-	N XUK,Y
-	X ^%ZOSF("EON") F XUK=1:1:3 D AGEN Q:(Y=1)!($D(DIRUT))
-	Q
-	;
-AGEN	;Generate a ACCESS code
-	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
-	Q
-	;
-AHELP	S XUU=$$AC^XUS4 S X=$$EN^XUSHSH(XUU) I $D(^VA(200,"A",X))!$D(^VA(200,"AOLD",X)) G AHELP
-	W !,"Here is an example of an acceptable Access Code: ",XUU,!
-	Q
-	;
-VHELP	S XUU=$$VC^XUS4 S X=$$EN^XUSHSH(XUU) I ($P($G(^VA(200,DA,0)),U,3)=X)!$D(^VA(200,DA,"VOLD",X)) G VHELP
-	W !,"Here is an example of an acceptable Verify Code: ",XUU,!
-	Q
-	;
-VAUTO	;Auto-get Access codes
-	N XUK
-	X ^%ZOSF("EON") F XUK=1:1:3 D VGEN Q:(Y=1)!($D(DIRUT))
-	Q
-	;
-VGEN	;Generate a VERIFY code
-	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
-	Q
-YN	;Ask if want to keep
-	N DIR
-	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
-	;
-OUT	;
-	K DUOUT S:$D(DIRUT) DUOUT=1
-	X ^%ZOSF("EON") W !
-	K DIR,DIRUT,XUKO,XUAUTO,XUU,XUH,XUK,XUI S X=""
-	Q
-	;
-CHKCUR()	;Check user knows current code, Return 1 if OK to continue
-	Q:DA'=DUZ 1 ;Only ask user
-	Q:$P($G(^VA(200,DA,.1)),U,2)="" 1 ;Must have an old one
-	S XUK=0 D CLR
-CHK1	W "Please enter your CURRENT verify code: " D GET Q:$D(DIRUT) 0
-	I $P(^VA(200,DA,.1),U,2)=$$EN^XUSHSH(X) Q 1
-	D CLR W "Sorry that is not correct!",!
-	S XUK=XUK+1 G:XUK<3 CHK1
-	Q 0
-	;
-BRCVC(XV1,XV2)	;Broker change VC, return 0 if good, '1^msg' if bad.
-	N XUU,XUH
-	Q:$G(DUZ)'>0 "1^Bad DUZ" S DA=DUZ,XUH=$$EN^XUSHSH(XV2)
-	I $P($G(^VA(200,DUZ,.1)),"^",2)'=$$EN^XUSHSH(XV1) Q "1^Sorry that isn't the correct current code"
-	S Y=$$VCHK(XV2,XUH) Q:Y Y
-	D VST(XUH,0),CALL^XUSERP(DA,2)
-	Q 0
-	;
-AVHLPTXT(%)	;
-	Q "Enter "_$S($G(%):"6-20",1:"8-20")_" characters mixed alphanumeric and punctuation (except '^', ';', ':')."
-	;
-	;Left over code, Don't think it is called anymore.
-	G XUS2^XUVERIFY ;All check or return user attributes moved to XUVERIFY
-USER	G USER^XUVERIFY
-EDIT	G EDIT^XUVERIFY
+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
+ I "Nn"[$E(X,1) S X="" Q
+ I "Yy"'[$E(X,1) K X Q
+ N DIR,DIR0,XUAUTO,XUK
+ S XUAUTO=($P($G(^XTV(8989.3,1,3)),U,1)="y"),XUH=""
+AC1 D CLR,AAUTO:XUAUTO,AASK:'XUAUTO G OUT:$D(DIRUT) D REASK G OUT:$D(DIRUT),AC1:'XUK D CLR,AST(XUH)
+ G OUT
+ ;
+AASK ;Ask for Access code
+ N X,XUU,XUEX X ^%ZOSF("EOFF")
+ S XUEX=0
+ F  D AASK1 Q:XUEX!($D(DIRUT))
+ Q
+ ;
+AASK1 ;
+ W "Enter a new ACCESS CODE <Hidden>: " D GET Q:$D(DIRUT)
+ I X="@" D DEL D:Y'=1 DIRUT S XUH="",XUEX=1 Q
+ I X[$C(34)!(X[";")!(X["^")!(X[":")!(X'?.UNP)!($L(X)>20)!($L(X)<6)!(X="MAIL-BOX") D CLR W $C(7),$$AVHLPTXT(1) D AHELP Q
+ I 'XUAUTO,((X?6.20A)!(X?6.20N)) D CLR W $C(7),$$AVHLPTXT(1),! Q
+ S XUU=X,X=$$EN^XUSHSH(X),XUH=X,XMB(1)=$O(^VA(200,"A",XUH,0)) I XMB(1),XMB(1)'=DA S XMB="XUS ACCESS CODE VIOLATION",XMB(1)=$P(^VA(200,XMB(1),0),"^"),XMDUN="Security" D ^XMB
+ I $D(^VA(200,"AOLD",XUH))!$D(^VA(200,"A",XUH)) D CLR W $C(7),"This has been used previously as an ACCESS CODE.",! Q
+ S XUEX=1 ;Now we can quit
+ Q
+ ;
+REASK S XUK=1 Q:XUH=""  D CLR X ^%ZOSF("EOFF")
+ F XUK=3:-1:1 W "Please re-type the new code to show that I have it right: " D GET G:$D(DIRUT) DIRUT D ^XUSHSH Q:(XUH=X)  D CLR W "This doesn't match.  Try again!",!,$C(7)
+ S:XUH'=X XUK=0
+ Q
+ ;
+AST(XUH) ;Change ACCESS CODE and index.
+ W "OK, Access code has been changed!"
+ N FDA,IEN,ERR
+ S IEN=DA_","
+ S FDA(200,IEN,2)=XUH D FILE^DIE("","FDA","ERR")
+ W !,"The VERIFY CODE has been deleted as a security measure.",!,"You will need to enter a new VERIFY code so the user can sign-on.",$C(7)
+ D VST("",1)
+ I $D(^XMB(3.7,DA,0))[0 S Y=DA D NEW^XM ;Make sure has a Mailbox
+ Q
+ ;
+GET ;Get the user input and convert case.
+ S X=$$ACCEPT^XUS I (X["^")!('$L(X)) D DIRUT
+ I '$D(ASKINGVC)!'$$GET^XPAR("SYS","XU VC CASE SENSITIVE") S X=$$UP^XLFSTR(X) ;for VOE allow case sensitive Verify Code
+ Q
+ ;
+DIRUT S DIRUT=1
+ Q
+ ;
+CLR ;New line or Clear screenman area
+ I '$D(DDS) W ! Q
+ N DX,DY
+ D CLRMSG^DDS S DX=0,DY=DDSHBX+1 X IOXY
+ Q
+ ;
+NEWCODE D REASK I XUK W !,"OK, remember this code for next time!"
+ G OUT
+ ;
+CVC ;From XUS1
+ N DA,X
+ S DA=DUZ,X="Y"
+ W !,"You must change your VERIFY CODE at this time."
+ ;Fall into next code
+VERED ; VERIFY CODE EDIT From DD
+ N DIR,DIR0,XUAUTO,ASKINGVC
+ I "Nn"[$E(X,1) S X="" Q
+ I "Yy"'[$E(X,1) K X Q
+ 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)
+ G OUT
+ ;
+VASK ;Ask for Verify Code
+ N X,XUU X ^%ZOSF("EOFF") G:'$$CHKCUR() DIRUT D CLR
+VASK1 W "Enter a new VERIFY CODE: " D GET Q:$D(DIRUT)
+ I '$D(XUNC),(X="@") D DEL G:Y'=1 DIRUT S XUH="" Q
+ D CLR S XUU=X,X=$$EN^XUSHSH(X),XUH=X,Y=$$VCHK(XUU,XUH) I +Y W $C(7),$P(Y,U,2,9),! D:+Y=1 VHELP G VASK1
+ Q
+ ;
+VCHK(S,EC) ;Call with String and Encripted versions
+ ;Updated per VHA directive 6210 Strong Passwords
+ N PUNC,NA S PUNC="~`!@#$%&*()_-+=|\{}[]'<>,.?/"
+ S NA("FILE")=200,NA("FIELD")=.01,NA("IENS")=DA_",",NA=$$HLNAME^XLFNAME(.NA)
+ ; 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."
+ I $D(^VA(200,DA,"VOLD",EC)) Q "4^This has been used previously as the VERIFY CODE."
+ I EC=$P(^VA(200,DA,0),U,3) Q "5^VERIFY CODE must be different than the ACCESS CODE."
+ I S[$P(NA,"^")!(S[$P(NA,"^",2)) Q "6^Name cannot be part of code."
+ Q 0
+ ;
+VST(XUH,%) ;
+ W:$L(XUH)&% !,"OK, Verify code has been changed!"
+ N FDA,IEN,ERR S IEN=DA_","
+ S:XUH="" XUH="@" ;11.2 get triggerd
+ S FDA(200,IEN,11)=XUH D FILE^DIE("","FDA","ERR")
+ I $D(ERR) D ^%ZTER
+ S:DA=DUZ DUZ("NEWCODE")=XUH Q
+ ;
+DEL ;
+ X ^%ZOSF("EON") W $C(7) S DIR(0)="Y",DIR("A")="Sure you want to delete" D ^DIR I Y'=1 W:$X>55 !?9 W $C(7),"  <Nothing Deleted>"
+ Q
+ ;
+AAUTO ;Auto-get Access codes
+ N XUK,Y
+ X ^%ZOSF("EON") F XUK=1:1:3 D AGEN Q:(Y=1)!($D(DIRUT))
+ Q
+ ;
+AGEN ;Generate a ACCESS code
+ 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
+ Q
+ ;
+AHELP S XUU=$$AC^XUS4 S X=$$EN^XUSHSH(XUU) I $D(^VA(200,"A",X))!$D(^VA(200,"AOLD",X)) G AHELP
+ W !,"Here is an example of an acceptable Access Code: ",XUU,!
+ Q
+ ;
+VHELP S XUU=$$VC^XUS4 S X=$$EN^XUSHSH(XUU) I ($P($G(^VA(200,DA,0)),U,3)=X)!$D(^VA(200,DA,"VOLD",X)) G VHELP
+ W !,"Here is an example of an acceptable Verify Code: ",XUU,!
+ Q
+ ;
+VAUTO ;Auto-get Access codes
+ N XUK
+ X ^%ZOSF("EON") F XUK=1:1:3 D VGEN Q:(Y=1)!($D(DIRUT))
+ Q
+ ;
+VGEN ;Generate a VERIFY code
+ 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
+ Q
+YN ;Ask if want to keep
+ N DIR
+ 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
+ ;
+OUT ;
+ K DUOUT S:$D(DIRUT) DUOUT=1
+ X ^%ZOSF("EON") W !
+ K DIR,DIRUT,XUKO,XUAUTO,XUU,XUH,XUK,XUI S X=""
+ Q
+ ;
+CHKCUR() ;Check user knows current code, Return 1 if OK to continue
+ Q:DA'=DUZ 1 ;Only ask user
+ Q:$P($G(^VA(200,DA,.1)),U,2)="" 1 ;Must have an old one
+ S XUK=0 D CLR
+CHK1 W "Please enter your CURRENT verify code: " D GET Q:$D(DIRUT) 0
+ I $P(^VA(200,DA,.1),U,2)=$$EN^XUSHSH(X) Q 1
+ D CLR W "Sorry that is not correct!",!
+ S XUK=XUK+1 G:XUK<3 CHK1
+ Q 0
+ ;
+BRCVC(XV1,XV2) ;Broker change VC, return 0 if good, '1^msg' if bad.
+ N XUU,XUH
+ Q:$G(DUZ)'>0 "1^Bad DUZ" S DA=DUZ,XUH=$$EN^XUSHSH(XV2)
+ I $P($G(^VA(200,DUZ,.1)),"^",2)'=$$EN^XUSHSH(XV1) Q "1^Sorry that isn't the correct current code"
+ S Y=$$VCHK(XV2,XUH) Q:Y Y
+ D VST(XUH,0),CALL^XUSERP(DA,2)
+ Q 0
+ ;
+AVHLPTXT(%) ;
+ Q "Enter "_$S($G(%):"6-20",1:"8-20")_" characters mixed alphanumeric and punctuation (except '^', ';', ':')."
+ ;
+ ;Left over code, Don't think it is called anymore.
+ G XUS2^XUVERIFY ;All check or return user attributes moved to XUVERIFY
+USER G USER^XUVERIFY
+EDIT G EDIT^XUVERIFY
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,89 +1,87 @@
-XUSCLEAN	;SF/STAFF - CLEANUP BEFORE EXIT ;10/26/06  08:12
-	;;8.0;KERNEL;**13,59,165,353,434**;Jul 10, 1995;Build 6
-H	;;Exit point for all R/S applications
-	LOCK  ;Unlock any locks
-	S U="^"
-	;Unwind Exit Actions
-	I $D(^XUTL("XQ",$J,"T")) S %XQEA=^("T") D
-	. F %XQEA1=%XQEA:-1:1 I $D(^XUTL("XQ",$J,%XQEA1)),$P(^(%XQEA1),U,16) S %XQEA2=+^(%XQEA1) I $D(^DIC(19,%XQEA2,15)),$L(^(15)) X ^(15)
-	K %XQEA,%XQEA1,%XQEA2
-	;Jump if the home device was closed
-	G:$D(IO("C")) H2
-	;Clear the screen
-	I $S($D(IOST)[0:1,IOST="":1,IOST["C-":1,1:0),'$D(XUERF) W !!!!!!!!!!!!!!!!!!!!!!!
-	I $D(XQNOLOG) W !!,"==>  Sorry, all activity on this volume set is being halted!  Try again later.",*7,*7,*7,!!!!
-	;W !!,"Halting at " S X=$P($H,",",2),Y=$E(X#3600\60+100,2,3),X=X\3600,Z=0 S:X>11 Z=1 S:'X X=12 S:X>12 X=X-12 W X,":",Y," ",$S(Z:"pm",1:"am")
-	W !!,"Logged out at "_$$HTE^XLFDT($H,"1FMP")
-	D:$D(DUZ("NEWCODE")) NEWCODE
-	;NON-R/S exit thru here also.
-H2	;No talking after this point
-	D C,XUTL
-	;un-comment the following line if you want FM space recall cleared
-	;after each session.
-	;K ^DISV($G(DUZ,0))
-	S:'($D(XQXFLG)#2) XQXFLG="" I $D(XQCH),XQCH="HALT" S $P(XQXFLG,U,3)=""
-	I ($D(XQNOHALT)#2)!($D(ZTQUEUED)#2)!($P(XQXFLG,U,3)="XUP") K XQNOHALT,XQXFLG Q  ;Return to REST^XQ12, ^XUP or Taskman.
-	;This was for modem hang up code. Obsolete now
-	I $D(^%ZIS("H"))#2 X ^("H")
-	;Go to ZU to do final halt.
-	G HALT^ZU
-	;
-TOUCH	;SR. API to set the keepalive node, Only set once a day
-	Q:+$G(^XUTL("XQ",$J,"KEEPALIVE"))=+$H
-	S ^XUTL("XQ",$J,"KEEPALIVE")=$H
-	Q
-	;
-C	;Do device close execute, User exit.
-	N XUDEV
-	S XUDEV=$S($D(^XUTL("XQ",$J,"IOS")):^("IOS"),1:"")
-	D ^%ZISC,BYE
-	Q
-	;
-	;Called from Broker, VistaLink, R/S
-BYE	;Set flags to show user has left. Called from anyplace the user exits
-	N DA,DIK,R0,%
-	I $G(^VA(200,+$G(DUZ),1.1)) S $P(^VA(200,DUZ,1.1),"^",3)=0
-	S DA=+$G(^XUTL("XQ",$J,0)) D LOUT(DA)
-	I $D(^XUSEC(0,DA,0)) D
-	. S R0=^XUSEC(0,DA,0)
-	. I $G(IO("IP"))]"",$P(R0,"^",13)]"" S %=$$CMD^XWBCAGNT(.R0,"XWB DELETE HANDLE",$P(R0,"^",13))
-	K ^XUTL("XQ",$J)
-	Q
-	;
-LOUT(DA)	;Enter log-out time, in Sign-on log
-	N DIK
-	I $D(^XUSEC(0,DA,0)) D
-	. S R0=^(0),$P(^(0),"^",4)=$$NOW^XLFDT,DIK="^XUSEC(0,",DIK(1)="3" D EN1^DIK
-	Q
-	;
-XUTL	;Cleanup JOB temporary Globals
-	N XQN D CLEAN^DILF ;Cleanup FM too.
-	K ^XUTL($J),^UTILITY($J),^TMP($J)
-	S XQN=" " F  S XQN=$O(^XUTL(XQN)) Q:XQN=""  K:"^XQO^XGATR^XGKB^"'[XQN ^XUTL(XQN,$J)
-	S XQN=" " F  S XQN=$O(^TMP(XQN)) Q:XQN=""  K ^TMP(XQN,$J)
-	S XQN=" " F  S XQN=$O(^UTILITY(XQN)) Q:XQN=""  K:"^ROU^GLO^LRLTR"'[XQN ^UTILITY(XQN,$J)
-	K ^XUTL("ZISPARAM",$I)
-	Q
-	;
-NEWCODE	;Remind user they changed there VC.
-	W !!,*7,"But, as I recall...",!,"You've changed your VERIFY CODE during this session.",!,"Please remember it for next time." H 4
-	Q
-	;
-	;Entry point to clear symbol table
-KILL	;SR. This is what was requested.
-	K %1,%2,%3 S %3=+$G(^XUTL("XQ",$J,"T"))
-	;See if Menu stack has Variable to protect.
-	F %1=%3:-1:1 S %2=+$G(^XUTL("XQ",$J,%1)),%2=$G(^DIC(19,%2,"NOKILL")) I %2]"" N @%2
-	;Fall into next part of kill.
-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 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 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
+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
+ S U="^"
+ ;Unwind Exit Actions
+ I $D(^XUTL("XQ",$J,"T")) S %XQEA=^("T") D
+ . F %XQEA1=%XQEA:-1:1 I $D(^XUTL("XQ",$J,%XQEA1)),$P(^(%XQEA1),U,16) S %XQEA2=+^(%XQEA1) I $D(^DIC(19,%XQEA2,15)),$L(^(15)) X ^(15)
+ K %XQEA,%XQEA1,%XQEA2
+ ;Jump if the home device was closed
+ G:$D(IO("C")) H2
+ ;Clear the screen
+ I $S($D(IOST)[0:1,IOST="":1,IOST["C-":1,1:0),'$D(XUERF) W !!!!!!!!!!!!!!!!!!!!!!!
+ I $D(XQNOLOG) W !!,"==>  Sorry, all activity on this volume set is being halted!  Try again later.",*7,*7,*7,!!!!
+ ;W !!,"Halting at " S X=$P($H,",",2),Y=$E(X#3600\60+100,2,3),X=X\3600,Z=0 S:X>11 Z=1 S:'X X=12 S:X>12 X=X-12 W X,":",Y," ",$S(Z:"pm",1:"am")
+ W !!,"Logged out at "_$$HTE^XLFDT($H,"1FMP")
+ D:$D(DUZ("NEWCODE")) NEWCODE
+ ;NON-R/S exit thru here also.
+H2 ;No talking after this point
+ D C,XUTL
+ ;un-comment the following line if you want FM space recall cleared 
+ ;after each session.
+ ;K ^DISV($G(DUZ,0))
+ S:'($D(XQXFLG)#2) XQXFLG="" I $D(XQCH),XQCH="HALT" S $P(XQXFLG,U,3)=""
+ I ($D(XQNOHALT)#2)!($D(ZTQUEUED)#2)!($P(XQXFLG,U,3)="XUP") K XQNOHALT,XQXFLG Q  ;Return to REST^XQ12, ^XUP or Taskman.
+ ;This was for modem hang up code. Obsolete now
+ I $D(^%ZIS("H"))#2 X ^("H")
+ ;Go to ZU to do final halt.
+ G HALT^ZU
+ ;
+TOUCH ;SR. API to set the keepalive node, Only set once a day
+ Q:+$G(^XUTL("XQ",$J,"KEEPALIVE"))=+$H
+ S ^XUTL("XQ",$J,"KEEPALIVE")=$H
+ Q
+ ;
+C ;Do device close execute, User exit.
+ N XUDEV
+ S XUDEV=$S($D(^XUTL("XQ",$J,"IOS")):^("IOS"),1:"")
+ D ^%ZISC,BYE
+ Q
+ ;
+ ;Called from Broker, VistaLink, R/S
+BYE ;Set flags to show user has left. Called from anyplace the user exits
+ N DA,DIK,R0,%
+ I $G(^VA(200,+$G(DUZ),1.1)) S $P(^VA(200,DUZ,1.1),"^",3)=0
+ S DA=+$G(^XUTL("XQ",$J,0)) D LOUT(DA)
+ I $D(^XUSEC(0,DA,0)) D
+ . S R0=^XUSEC(0,DA,0)
+ . I $G(IO("IP"))]"",$P(R0,"^",13)]"" S %=$$CMD^XWBCAGNT(.R0,"XWB DELETE HANDLE",$P(R0,"^",13))
+ K ^XUTL("XQ",$J)
+ Q
+ ;
+LOUT(DA) ;Enter log-out time, in Sign-on log
+ N DIK
+ I $D(^XUSEC(0,DA,0)) D
+ . S R0=^(0),$P(^(0),"^",4)=$$NOW^XLFDT,DIK="^XUSEC(0,",DIK(1)="3" D EN1^DIK
+ Q
+ ;
+XUTL ;Cleanup JOB temporary Globals
+ N XQN D CLEAN^DILF ;Cleanup FM too.
+ K ^XUTL($J),^UTILITY($J),^TMP($J)
+ S XQN=" " F  S XQN=$O(^XUTL(XQN)) Q:XQN=""  K:"^XQO^XGATR^XGKB^"'[XQN ^XUTL(XQN,$J)
+ S XQN=" " F  S XQN=$O(^TMP(XQN)) Q:XQN=""  K ^TMP(XQN,$J)
+ S XQN=" " F  S XQN=$O(^UTILITY(XQN)) Q:XQN=""  K:"^ROU^GLO^LRLTR"'[XQN ^UTILITY(XQN,$J)
+ K ^XUTL("ZISPARAM",$I)
+ Q
+ ;
+NEWCODE ;Remind user they changed there VC.
+ W !!,*7,"But, as I recall...",!,"You've changed your VERIFY CODE during this session.",!,"Please remember it for next time." H 4
+ Q
+ ;
+ ;Entry point to clear symbol table
+KILL ;SR. This is what was requested.
+ K %1,%2,%3 S %3=+$G(^XUTL("XQ",$J,"T"))
+ ;See if Menu stack has Variable to protect.
+ F %1=%3:-1:1 S %2=+$G(^XUTL("XQ",$J,%1)),%2=$G(^DIC(19,%2,"NOKILL")) I %2]"" N @%2
+ ;Fall into next part of kill.
+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 KWAPI,XGWIN,XGDI,XGEVENT
+ N XQAEXIT,XQAUSER,XQX1,XQAKILL,XQAID
+ 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.
+ D NEXT^XUS1 S XQXFLG="",XQXFLG("HALT")=1 G H2
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,188 +1,174 @@
-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
-	; 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
-	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
-	; 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
-	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)
-	;;
-B3	F  S XUY=$$ADD^XUSERNEW Q:XUY<0  D  ;Create new entry
-	. I '$P(XUY,U,3) D
-	. . S DIR(0)="Y",DIR("A")=$P(XUY,U,2)_" is an existing user. Do you want to include" D ^DIR I Y'=1 S XUY=-1 Q
-	. . S DIR(0)="Y",DIR("A")="Clear out KEYS, FILES, SECONDARY MENUS first" D ^DIR
-	. . S:Y=1 $P(XUY,U,4)=1
-	. . Q
-	. I XUY>0 D
-	. . 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!"
-	. 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
-	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)
-	Q
-	;;
-CLONE	;;Do work
-	N XUTEXT,XU1,%,DA,XUNEW,XUPURGE
-	S XUTEXT=$O(^DIC(9.2,"B",$$GET^XUPARAM("XUSER COMPUTER ACCOUNT","N"),0))
-	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
-C2	;
-	N XUU,XUU2,XFDA,XUH,XUH2,XIEN,XERR,Y,XMZ,XMM,XMDT
-	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
-	I $P(^VA(200,DA,0),U,3)']"" S XUNEW=1 ;if no access code treat as new
-	I $P($G(^VA(200,DA,.1)),U,2)']"" S XUNEW=1 ;If no verify code treat as new
-	S (XUU,XUU2)="unchanged",$P(^VA(200,DA,0),U,11)=XUTERMDT
-	I XUNEW D ACODE S @XFDA@(200,DA_",",2)=XUH D VCODE S @XFDA@(200,DA_",",11)=XUH2
-	D UPDATE^DIE("",XFDA,XIEN,"XERR") K @XFDA
-	I XUNEW,XUTEXT>0 D LET(DA,XUTEXT)
-	I $D(^XMB(3.7,DA,0))[0 S Y=DA K XMZ D NEW^XM K XMDT,XMM,XMZ
-	Q
-	;
-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
-	F X2=1:1 S XUNODE=$P($T(DATA+X2),";;",2) Q:XUNODE=""  D
-	. F X3=1:1 S X7=$P(XUNODE,U,X3) Q:X7=""  S X4=$$GETDD(200,X7),X5=$P(X4,";"),X6=$P(X4,";",2) D
-	. . I '$D(XU(2,X5)) S XU(2,X5)=$G(^VA(200,XUTMP,X5))
-	. . S:$P(XU(2,X5),U,X6)]"" @XFDA@(200,DA_",",X7)=$P(XU(2,X5),U,X6)
-	. . Q
-	. Q
-	D SUBFILE
-	Q
-	;
-GETDD(FI,FE)	;Return node;piece for a field
-	Q $P($G(^DD(FI,FE,0)),U,4)
-	;
-DATA	;;field#
-	;;3^8^15^29^28
-	;;200.04^200.05^200.06^200.09^200.1^201^
-	;;41^41.1^41.2
-	;;101.01^101.02
-	;;9.21^9.22
-	;;
-	;
-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
-	;
-VCODE	;
-	S XUU2=$$VC^XUS4(),XUH2=$$EN^XUSHSH(XUU2)
-	Q
-	;
-SUBFILE	;Move subfiles: Subscript, Subfile#, DINUM, Fields
-	N XCNT S XCNT=0
-KEY	D MULTI(51,200.051,1,".01,3")
-PATH	;D MULTI(19.8,".01")
-FOF	D MULTI("FOF",200.032,1,".01,1,2,3,4,5,6")
-DIV	D MULTI(2,200.02,1,".01")
-SEC	D MULTI(203,200.03,0,".01,2")
-TAB	D MULTI("ORD",200.010113,0,".01,.02,.03")
-PSCLSS	I $P($G(XUSER(XU1)),U,5)=1 D PRSNCL(DA)
-	Q
-	;
-MULTI(XSS,XSF,XDN,XDD)	;Build new data
-	I XUPURGE D CLEAR(DA,XSS)
-	Q:'$D(^VA(200,XUTMP,XSS,0))
-	;S X=^(0),Y=$S($D(^VA(200,DA,X2,0)):^(0),1:"")
-	F X1=0:0 S X1=$O(^VA(200,XUTMP,XSS,X1)) Q:X1'>0  S X=^(X1,0) D
-	. F X2=1:1 S X3=$P(XDD,",",X2) Q:X3=""  D
-	. . I X3'=.01 S @XFDA@(XSF,"?+"_XCNT_","_DA_",",X3)=$$VAL(X,X3,XSF) Q
-	. . S XCNT=XCNT+1,@XFDA@(XSF,"?+"_XCNT_","_DA_",",.01)=$P(X,U,1)
-	. . S:XDN @XIEN@(XCNT)=X1
-	. . Q
-	. Q
-	Q
-	;
-VAL(V,FE,FI)	;Get value
-	N % S %=$$GETDD(FI,FE),%=$P(%,";",2) Q $P(V,"^",%)
-	;
-LET(DA,XUTEXT)	;Write access letter
-	N DIWF,FR,TO,BY,IOP
-	S DIWF="^DIC(9.2,"_XUTEXT_",1,",DIWF(1)=200,FR=DA,TO=DA,BY="NUMBER",IOP=XUIOP D EN2^DIWF
-	Q
-	;
-CLEAR(X4,X2)	;Clear subfile first, IEN, Subscript
-	Q:$D(^VA(200,X4,X2,0))[0  N C,XUFN,XDEL,XMSG
-	S C=",",XDEL=$NA(^TMP($J,"XUBLK2")),XUFN=+$P(^VA(200,X4,X2,0),"^",2)
-	F X1=0:0 S X1=$O(^VA(200,X4,X2,X1)) Q:X1'>0  D
-	. I X2=51 S %=$$DEL^XQKEY(X4,X1) Q  ;Special case for KEYS
-	. S @XDEL@(XUFN,X1_C_X4_C,.01)="@"
-	. Q
-	I $D(@XDEL)>1 D FILE^DIE("",XDEL,"XMSG") ;I $D(XMSG) ZW XMSG
-	Q
-	;
-UPDATE(XX,USRIEN)	;Update effective date
-	N PC,PC1
-	S PC=$O(^VA(200,USRIEN,XX,"A"),-1) Q:PC'>0
-	S PC=0 F  S PC=$O(^VA(200,USRIEN,XX,PC)) Q:PC'>0  D
-	.S PC1=$P($G(^VA(200,USRIEN,XX,PC,0)),"^",3)
-	.I (PC1="")!(PC1'<DT) D DOPD
-	Q
-	;
-DOPD	;
-	L +^VA(200,DA,XX,PC,0):20 I '$T D  Q
-	.W !,"===> The user is locked. Please try this option again."
-	S $P(^VA(200,USRIEN,XX,PC,0),"^",2)=DT
-	L -^VA(200,USRIEN,XX,PC,0)
-	Q
-	;
-PRSNCL(USERIEN)	;
-	N XUDATA,XUPSC,XUEFDA,XUEXDA,ZZ
-	S XUDATA=$O(^VA(200,XUTMP,"USC1","A"),-1) Q:XUDATA'>0
-	S XUDATA=$G(^VA(200,XUTMP,"USC1",XUDATA,0)) Q:XUDATA=""
-	S XUPSC=$P(XUDATA,"^")
-	S XUEFDA=$P(XUDATA,"^",2) I XUEFDA'>DT S XUEFDA=DT
-	S XUEXDA=$P(XUDATA,"^",3)
-	I XUEXDA<DT,XUEXDA'="" Q
-	N XULAST,XULDATA
-	S XULAST=$O(^VA(200,USERIEN,"USC1","A"),-1)
-	S ZZ(1,200.05,"+2,"_USERIEN_",",.01)=XUPSC
-	S ZZ(1,200.05,"+2,"_USERIEN_",",2)=XUEFDA
-	S ZZ(1,200.05,"+2,"_USERIEN_",",3)=XUEXDA
-	D UPDATE^DIE("","ZZ(1)")
-	Q:XULAST'>0
-	S XULDATA=$G(^VA(200,USERIEN,"USC1",XULAST,0))
-	S XULDATA=$P(XULDATA,"^",3)
-	Q:XULDATA'>DT
-	S $P(^VA(200,USERIEN,"USC1",XULAST,0),"^",3)=DT
-	Q
+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,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
+ 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 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 ?50,"TERMINATION DATE: ",$$FMTE^XLFDT(XUTERMDT)
+ ;;
+B3 F  S XUY=$$ADD^XUSERNEW Q:XUY<0  D  ;Create new entry
+ . I '$P(XUY,U,3) D
+ . . S DIR(0)="Y",DIR("A")=$P(XUY,U,2)_" is an existing user. Do you want to include" D ^DIR I Y'=1 S XUY=-1 Q
+ . . S DIR(0)="Y",DIR("A")="Clear out KEYS, FILES, SECONDARY MENUS first" D ^DIR
+ . . S:Y=1 $P(XUY,U,4)=1
+ . . Q
+ . I XUY>0 D
+ . . 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!",!
+ . Q
+B4 ;
+ 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 ;
+ 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
+ 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)
+ G QUIT
+ ;
+C2 ;
+ 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
+ I $P(^VA(200,DA,0),U,3)']"" S XUNEW=1 ;if no access code treat as new
+ I $P($G(^VA(200,DA,.1)),U,2)']"" S XUNEW=1 ;If no verify code treat as new
+ S (XUU,XUU2)="unchanged",$P(^VA(200,DA,0),U,11)=XUTERMDT
+ I XUNEW D ACODE S @XFDA@(200,DA_",",2)=XUH D VCODE S @XFDA@(200,DA_",",11)=XUH2
+ D UPDATE^DIE("",XFDA,XIEN,"XERR") K @XFDA
+ I XUNEW,XUTEXT>0 D LET(DA,XUTEXT)
+ I $D(^XMB(3.7,DA,0))[0 S Y=DA K XMZ D NEW^XM K XMDT,XMM,XMZ
+ Q
+ ;
+BLDFDA ;Build the FDA
+ S XFDA="^TMP($J,""XFDA"")",XIEN="^TMP($J,""XIEN"")" K ^TMP($J)
+ ;Move piece on nodes from list, Build XU only once
+ F X2=1:1 S XUNODE=$P($T(DATA+X2),";;",2) Q:XUNODE=""  D
+ . F X3=1:1 S X7=$P(XUNODE,U,X3) Q:X7=""  S X4=$$GETDD(200,X7),X5=$P(X4,";"),X6=$P(X4,";",2) D
+ . . I '$D(XU(2,X5)) S XU(2,X5)=$G(^VA(200,XUTMP,X5))
+ . . S:$P(XU(2,X5),U,X6)]"" @XFDA@(200,DA_",",X7)=$P(XU(2,X5),U,X6)
+ . . Q
+ . Q
+ D SUBFILE
+ Q
+ ;
+GETDD(FI,FE) ;Return node;piece for a field
+ Q $P($G(^DD(FI,FE,0)),U,4)
+ ;
+DATA ;;field#
+ ;;3^8^15^29^28
+ ;;200.04^200.05^200.06^200.09^200.1^201^
+ ;;41^41.1^41.2
+ ;;101.01^101.02
+ ;;9.21^9.22
+ ;;
+ ;
+ACODE ;
+ F Z=0:0 S XUU=$$AC^XUS4(),XUH=$$EN^XUSHSH(XUU) Q:'($D(^VA(200,"AOLD",XUH))!$D(^VA(200,"A",XUH)))
+ Q
+ ;
+VCODE ;
+ S XUU2=$$VC^XUS4(),XUH2=$$EN^XUSHSH(XUU2)
+ Q
+ ;
+SUBFILE ;Move subfiles: Subscript, Subfile#, DINUM, Fields
+ N XCNT S XCNT=0
+KEY D MULTI(51,200.051,1,".01,3")
+PATH ;D MULTI(19.8,".01")
+FOF D MULTI("FOF",200.032,1,".01,1,2,3,4,5,6")
+DIV D MULTI(2,200.02,1,".01")
+SEC D MULTI(203,200.03,0,".01,2")
+TAB D MULTI("ORD",200.010113,0,".01,.02,.03")
+PSCLSS I $P($G(XUSER(XU1)),U,5)=1 D PRSNCL(DA)
+ Q
+ ;
+MULTI(XSS,XSF,XDN,XDD) ;Build new data
+ I XUPURGE D CLEAR(DA,XSS)
+ Q:'$D(^VA(200,XUTMP,XSS,0))
+ ;S X=^(0),Y=$S($D(^VA(200,DA,X2,0)):^(0),1:"")
+ F X1=0:0 S X1=$O(^VA(200,XUTMP,XSS,X1)) Q:X1'>0  S X=^(X1,0) D
+ . F X2=1:1 S X3=$P(XDD,",",X2) Q:X3=""  D
+ . . I X3'=.01 S @XFDA@(XSF,"?+"_XCNT_","_DA_",",X3)=$$VAL(X,X3,XSF) Q
+ . . S XCNT=XCNT+1,@XFDA@(XSF,"?+"_XCNT_","_DA_",",.01)=$P(X,U,1)
+ . . S:XDN @XIEN@(XCNT)=X1
+ . . Q
+ . Q
+ Q
+ ;
+VAL(V,FE,FI) ;Get value
+ N % S %=$$GETDD(FI,FE),%=$P(%,";",2) Q $P(V,"^",%)
+ ;
+LET(DA,XUTEXT) ;Write access letter
+ 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
+ ;
+CLEAR(X4,X2) ;Clear subfile first, IEN, Subscript
+ Q:$D(^VA(200,X4,X2,0))[0  N C,XUFN,XDEL,XMSG
+ S C=",",XDEL=$NA(^TMP($J,"XUBLK2")),XUFN=+$P(^VA(200,X4,X2,0),"^",2)
+ F X1=0:0 S X1=$O(^VA(200,X4,X2,X1)) Q:X1'>0  D
+ . I X2=51 S %=$$DEL^XQKEY(X4,X1) Q  ;Special case for KEYS
+ . S @XDEL@(XUFN,X1_C_X4_C,.01)="@"
+ . Q
+ I $D(@XDEL)>1 D FILE^DIE("",XDEL,"XMSG") ;I $D(XMSG) ZW XMSG
+ Q
+ ;
+UPDATE(XX,USRIEN) ;Update effective date
+ N PC,PC1
+ S PC=$O(^VA(200,USRIEN,XX,"A"),-1) Q:PC'>0
+ S PC=0 F  S PC=$O(^VA(200,USRIEN,XX,PC)) Q:PC'>0  D
+ .S PC1=$P($G(^VA(200,USRIEN,XX,PC,0)),"^",3)
+ .I (PC1="")!(PC1'<DT) D DOPD
+ Q
+ ;
+DOPD ;
+ L +^VA(200,DA,XX,PC,0):20 I '$T D  Q
+ .W !,"===> The user is locked. Please try this option again."
+ S $P(^VA(200,USRIEN,XX,PC,0),"^",2)=DT
+ L -^VA(200,USRIEN,XX,PC,0)
+ Q
+ ;
+PRSNCL(USERIEN) ;
+ N XUDATA,XUPSC,XUEFDA,XUEXDA,ZZ
+ S XUDATA=$O(^VA(200,XUTMP,"USC1","A"),-1) Q:XUDATA'>0
+ S XUDATA=$G(^VA(200,XUTMP,"USC1",XUDATA,0)) Q:XUDATA=""
+ S XUPSC=$P(XUDATA,"^")
+ S XUEFDA=$P(XUDATA,"^",2) I XUEFDA'>DT S XUEFDA=DT
+ S XUEXDA=$P(XUDATA,"^",3)
+ I XUEXDA<DT,XUEXDA'="" Q
+ N XULAST,XULDATA
+ S XULAST=$O(^VA(200,USERIEN,"USC1","A"),-1)
+ S ZZ(1,200.05,"+2,"_USERIEN_",",.01)=XUPSC
+ S ZZ(1,200.05,"+2,"_USERIEN_",",2)=XUEFDA
+ S ZZ(1,200.05,"+2,"_USERIEN_",",3)=XUEXDA
+ D UPDATE^DIE("","ZZ(1)")
+ Q:XULAST'>0
+ S XULDATA=$G(^VA(200,USERIEN,"USC1",XULAST,0))
+ S XULDATA=$P(XULDATA,"^",3)
+ Q:XULDATA'>DT
+ S $P(^VA(200,USERIEN,"USC1",XULAST,0),"^",3)=DT
+ Q
Index: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSERNEW.m
===================================================================
--- WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSERNEW.m	(revision 613)
+++ WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSERNEW.m	(revision 623)
@@ -1,111 +1,105 @@
-XUSERNEW	;SF/RWF - ADD NEW USER ;5/13/08  17:19
-	;;8.0;KERNEL;**16,49,134,208,157,313,351,419,467,480**;Jul 10, 1995;Build 38
-	;;Per VHA Directive 2004-038, this routine should not be modified
-	;In the call to NEW^XM for new users the variable XMZ must be undef.
-	;on a reactivation XMZ should be set to the current max message number.
-EN	;Add
-	N Y,XUN,DR,DIE,DA,DTOUT,DIWF,XMDT,XMM,XMZ
-	S Y=$$ADD("","",1) G EXIT:Y'>0,RE:$P(Y,U,3)'=1
-	S XUN=+Y ;XU USER ADD called in $$ADD
-	S DR="["_$$GET^XUPARAM("XUNEW USER","N")_"]"
-	S DIE=200,DA=XUN D XUDIE^XUS5 G:$D(DTOUT) EXIT
-	I $$GET1^DIQ(200,XUN_",",11,"I")="" W !,"Without a VERIFY code the user will not be able to sign-on!",$C(7),!
-	S Y=XUN K XMZ D NEW^XM K XMDT,XMM,XMZ
-	;ACCESS LETTER, Also see XUSERBLK
-	W ! D LETTER(XUN,1)
-	K DIR,DIWF,XUTEXT
-	;
-	;Fall in from above, called from REACT
-KEYS	N DIR,XQHOLD,XQKEY,XQDA,XQAL,XQ6,XQFL
-	S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you wish to allocate security keys" D ^DIR G:$D(DIRUT) EXIT
-	I Y=1 S XQHOLD(XUN)="",XQKEY(0)=0,XQDA=0,XQAL=1,XQ6="",XQFL="" D KEY^XQ6
-	;
-	;Check on adding this user to user groups
-	I $P(^VA(200,XUN,0),U,3)'="" D  ;Must have access code & mailbox
-	.N DIR,Y
-	.S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you wish to add this user to mail groups" D ^DIR Q:$D(DIRUT)
-	.I Y=1 D ENLOCAL1^XMVGRP(XUN)
-	.K XMDUN,XMDUZ,XMV
-	.Q
-	;
-EXIT	K D0,DA,DDER,DDSFILE,DIE,DIC,DIR,DI,DICR,DIG,DIH,DISYS,DIU,DIV,DIWT,DLAYGO,DR,DQ,K,I,X,X1,XQHOLD,XQKEY,XUN,XUSOLD,XMB,XMZ,Y,Z,XQ6,XQFL,DTOUT
-	Q
-	;
-RE	;Jump from new user to reactivate
-	S XUN=+Y,DIR("A")="This isn't a new user, Want to reactivate?",DIR(0)="Y",DIR("B")="NO"
-	D ^DIR
-	G EXIT:$D(DIRUT)!(Y'=1),RE2
-	;Reactivate a user
-REACT	;SEA/WDE-REACTIVATE A USER
-	N XUN,XUSOLD,DIE,DIC,DA,DR,FDA
-	S XUN=+$$LOOKUP^XUSER G EXIT:XUN<0
-RE2	S XUSOLD=^VA(200,XUN,0)
-	S FDA(200,XUN_",",9.2)="@" ;Clear the Termination date
-	D UPDATE^DIE("E","FDA")
-	;Show the screanman form
-	S DIE=200,DR="["_$$GET^XUPARAM("XUREACT USER","N")_"]",DA=XUN
-	D XUDIE^XUS5 G:$D(DTOUT) EXIT
-	I $P(^VA(200,XUN,0),U,3)="" W !!,"No ACCESS CODE has been entered.",$C(7),!
-	I $P(^VA(200,XUN,0),U,11)>0,$P(^(0),U,11)'>DT W !!,"User is still TERMINATED.",$C(7),!
-	I $$GET1^DIQ(200,XUN_",",11,"I")="" W !,"Without a VERIFY code the user will not be able to sign-on!",$C(7),!
-	N DIR
-	S DIR(0)="Y",DIR("A")="Deny access to old mail messages",DIR("B")="NO",DIR("?")="Enter a 'YES' to restrict access to old mail messages."
-	D ^DIR G:$D(DIRUT) EXIT
-	K XMZ S:Y=1 XMZ=+$P(^XMB(3.9,0),"^",3) S Y=XUN D NEW^XM K XMDT,XMM,XMZ
-	D REACT^XQ84(XUN) ;See if this user's menu trees need to be rebuilt
-	G KEYS
-	Q
-	;
-ADD(NP1,KEYS,NONC)	;Common point to do DIC call for adding a new person.
-	;NP1 will be added to the default or what comes from the NPI field or the KSP.
-	;KEYS is a list of Keys to give the new person
-	N DA,DR,DLAYGO,XUITNAME,XUS1,XUS2,DIC,DIE,DIK,NP2,Y
-	I $G(^XTV(8989.3,1,"NPI"))]"" X ^("NPI") S NP2=DR
-	S:'$D(NP2) NP2="1;"_$S($D(^XUSEC("XUSPF200",DUZ)):9,1:"9R~")_";4;41.99"
-	;";41.99" is for adding National Provider Identifier
-	S DIC="^VA(200,",DIC(0)="AELMQ",DLAYGO=200,DIC("A")="Enter NEW PERSON's name (Family,Given Middle Suffix): ",DIC("DR")="",XUITNAME=1
-	D ^DIC S XUS1=Y G AX:(Y'>0)!($P(Y,U,3)'>0)
-	S DA=+$G(^VA(200,+XUS1,3.1)) I DA,'$G(NONC) D
-	. W !,"Name components."
-	. S DIE="^VA(20,",DR="1;2;3;5"
-	. L +^VA(20,DA,0):60 D ^DIE L -^VA(20,DA,0)
-	. I $D(Y)!$D(DTOUT) S DA=+XUS1,XUS1=-1
-	. E  S $P(XUS1,U,2)=$P(^VA(200,+XUS1,0),U)
-	D:XUS1>0
-	. W !,"Now for the Identifiers."
-	. S DA=+XUS1,DIE="^VA(200,",DR=NP2_$S($D(NP1):";"_NP1,1:""),DIE("NO^")="OUTOK"
-	. L +^VA(200,DA,0):60 D ^DIE L -^VA(200,DA,0)
-	. S:$D(Y)!$D(DTOUT) XUS1=-1
-	I XUS1<0 D  S XUS1=-1
-	. W !?5,"<'",$P(^VA(200,DA,0),U),"' DELETED>"
-	. S DIK="^VA(200," D ^DIK
-	. Q:$P($G(^DIC(3,0)),U)'="USER"!'$D(^DD(3,0))
-	. S DIK="^DIC(3,",XUS1=$P($G(^DIC(3,DA,0)),U,16) D ^DIK
-	. Q:'XUS1!($P($G(^DIC(16,0)),U)'="PERSON")!'$D(^DD(16,0))
-	. S DIK="^DIC(16,",DA=XUS1 D ^DIK
-	N XUSNPI S XUSNPI=$P($G(^VA(200,DA,"NPI")),"^")
-	I XUS1>0,+XUSNPI>0 D
-	. S XUSNPI=$$ADDNPI^XUSNPI("Individual_ID",DA,XUSNPI,$$NOW^XLFDT(),1) ;add NPI to multiple
-	. ; Initialize field 41.97 to 1 (YES)
-	. Q:+XUSNPI'>0
-	. N DIE,DR,DA S DIE="^VA(200,",DA=+XUS1,DR="41.97////1" D ^DIE
-	. Q
-	I XUS1>0,$D(KEYS) F XUS2=1:1 S Y=$P(KEYS,",",XUS2) Q:'$L(Y)  D
-	. S %=$$ADD^XQKEY(XUS1,Y) I '% W !,"Key '",Y,"' not allocated"
-	I XUS1>0 D CALL^XUSERP(+XUS1,1) ;XQOR add
-AX	Q XUS1
-	;
-REPRINT	;Reprint letter
-	S DA=+$$LOOKUP^XUSER G EXIT:DA'>0
-	D LETTER(DA)
-	G EXIT
-	;
-LETTER(XUN,ASK)	;Print access letter
-	Q:'$G(XUN)
-	N DIWF,FR,TO,BY,DIR,XUTEXT
-	S XUTEXT=$$GET^XUPARAM("XUSER COMPUTER ACCOUNT","N"),XUTEXT=$O(^DIC(9.2,"B",XUTEXT,0))
-	S DIR(0)="Y",DIR("A")="Print User Account Access Letter"
-	I XUTEXT>0 S Y=1 D:$G(ASK) ^DIR I Y=1 D
-	. S (XUU,XUU2)="________",DIWF="^DIC(9.2,XUTEXT,1,",DIWF(1)=200,FR=XUN,TO=XUN,BY="NUMBER" D EN2^DIWF
-	. Q
-	Q
+XUSERNEW ;SF/RWF - ADD NEW USER ;6/27/07
+ ;;8.0;KERNEL;**16,49,134,208,157,313,351,419,467**;Jul 10, 1995;Build 12
+ ;In the call to NEW^XM for new users the variable XMZ must be undef.
+ ;on a reactivation XMZ should be set to the current max message number.
+EN ;Add
+ N Y,XUN,DR,DIE,DA,DTOUT,DIWF,XMDT,XMM,XMZ
+ S Y=$$ADD("","",1) G EXIT:Y'>0,RE:$P(Y,U,3)'=1
+ S XUN=+Y ;XU USER ADD called in $$ADD
+ S DR="["_$$GET^XUPARAM("XUNEW USER","N")_"]"
+ S DIE=200,DA=XUN D XUDIE^XUS5 G:$D(DTOUT) EXIT
+ I $$GET1^DIQ(200,XUN_",",11,"I")="" W !,"Without a VERIFY code the user will not be able to sign-on!",$C(7),!
+ S Y=XUN K XMZ D NEW^XM K XMDT,XMM,XMZ
+ ;ACCESS LETTER, Also see XUSERBLK
+ W ! D LETTER(XUN,1)
+ K DIR,DIWF,XUTEXT
+ ;
+ ;Fall in from above, called from REACT
+KEYS N DIR,XQHOLD,XQKEY,XQDA,XQAL,XQ6,XQFL
+ S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you wish to allocate security keys" D ^DIR G:$D(DIRUT) EXIT
+ I Y=1 S XQHOLD(XUN)="",XQKEY(0)=0,XQDA=0,XQAL=1,XQ6="",XQFL="" D KEY^XQ6
+ ;
+ ;Check on adding this user to user groups
+ I $P(^VA(200,XUN,0),U,3)'="" D  ;Must have access code & mailbox
+ .N DIR,Y
+ .S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you wish to add this user to mail groups" D ^DIR Q:$D(DIRUT)
+ .I Y=1 D ENLOCAL1^XMVGRP(XUN)
+ .K XMDUN,XMDUZ,XMV
+ .Q
+ ;
+EXIT K D0,DA,DDER,DDSFILE,DIE,DIC,DIR,DI,DICR,DIG,DIH,DISYS,DIU,DIV,DIWT,DLAYGO,DR,DQ,K,I,X,X1,XQHOLD,XQKEY,XUN,XUSOLD,XMB,XMZ,Y,Z,XQ6,XQFL,DTOUT
+ Q
+ ;
+RE ;Jump from new user to reactivate
+ S XUN=+Y,DIR("A")="This isn't a new user, Want to reactivate?",DIR(0)="Y",DIR("B")="NO"
+ D ^DIR
+ G EXIT:$D(DIRUT)!(Y'=1),RE2
+ ;Reactivate a user
+REACT ;SEA/WDE-REACTIVATE A USER
+ N XUN,XUSOLD,DIE,DIC,DA,DR,FDA
+ S XUN=+$$LOOKUP^XUSER G EXIT:XUN<0
+RE2 S XUSOLD=^VA(200,XUN,0)
+ S FDA(200,XUN_",",9.2)="@" ;Clear the Termination date
+ D UPDATE^DIE("E","FDA")
+ ;Show the screanman form
+ S DIE=200,DR="["_$$GET^XUPARAM("XUREACT USER","N")_"]",DA=XUN
+ D XUDIE^XUS5 G:$D(DTOUT) EXIT
+ I $P(^VA(200,XUN,0),U,3)="" W !!,"No ACCESS CODE has been entered.",$C(7),!
+ I $P(^VA(200,XUN,0),U,11)>0,$P(^(0),U,11)'>DT W !!,"User is still TERMINATED.",$C(7),!
+ I $$GET1^DIQ(200,XUN_",",11,"I")="" W !,"Without a VERIFY code the user will not be able to sign-on!",$C(7),!
+ N DIR
+ S DIR(0)="Y",DIR("A")="Deny access to old mail messages",DIR("B")="NO",DIR("?")="Enter a 'YES' to restrict access to old mail messages."
+ D ^DIR G:$D(DIRUT) EXIT
+ K XMZ S:Y=1 XMZ=+$P(^XMB(3.9,0),"^",3) S Y=XUN D NEW^XM K XMDT,XMM,XMZ
+ D REACT^XQ84(XUN) ;See if this user's menu trees need to be rebuilt
+ G KEYS
+ Q
+ ;
+ADD(NP1,KEYS,NONC) ;Common point to do DIC call for adding a new person.
+ ;NP1 will be added to the default or what comes from the NPI field of the KSP.
+ ;KEYS is a list of Keys to give the new person
+ N DA,DR,DLAYGO,XUITNAME,XUS1,XUS2,DIC,DIE,DIK,NP2,Y
+ I $G(^XTV(8989.3,1,"NPI"))]"" X ^("NPI") S NP2=DR
+ S:'$D(NP2) NP2="1;"_$S($D(^XUSEC("XUSPF200",DUZ)):9,1:"9R~")_";4;41.99"
+ ;";41.99" is for adding National Provider Identifier
+ S DIC="^VA(200,",DIC(0)="AELMQ",DLAYGO=200,DIC("A")="Enter NEW PERSON's name (Family,Given Middle Suffix): ",DIC("DR")="",XUITNAME=1
+ D ^DIC S XUS1=Y G AX:(Y'>0)!($P(Y,U,3)'>0)
+ S DA=+$G(^VA(200,+XUS1,3.1)) I DA,'$G(NONC) D
+ . W !,"Name components."
+ . S DIE="^VA(20,",DR="1;2;3;5"
+ . L +^VA(20,DA,0):60 D ^DIE L -^VA(20,DA,0)
+ . I $D(Y)!$D(DTOUT) S DA=+XUS1,XUS1=-1
+ . E  S $P(XUS1,U,2)=$P(^VA(200,+XUS1,0),U)
+ D:XUS1>0
+ . W !,"Now for the Identifiers."
+ . S DA=+XUS1,DIE="^VA(200,",DR=NP2_$S($D(NP1):";"_NP1,1:""),DIE("NO^")="OUTOK"
+ . L +^VA(200,DA,0):60 D ^DIE L -^VA(200,DA,0)
+ . S:$D(Y)!$D(DTOUT) XUS1=-1
+ I XUS1<0 D  S XUS1=-1
+ . W !?5,"<'",$P(^VA(200,DA,0),U),"' DELETED>"
+ . S DIK="^VA(200," D ^DIK
+ . Q:$P($G(^DIC(3,0)),U)'="USER"!'$D(^DD(3,0))
+ . S DIK="^DIC(3,",XUS1=$P($G(^DIC(3,DA,0)),U,16) D ^DIK
+ . Q:'XUS1!($P($G(^DIC(16,0)),U)'="PERSON")!'$D(^DD(16,0))
+ . S DIK="^DIC(16,",DA=XUS1 D ^DIK
+ N XUSNPI S XUSNPI=$P($G(^VA(200,DA,"NPI")),"^")
+ I XUS1>0,+XUSNPI>0 S XUSNPI=$$ADDNPI^XUSNPI("Individual_ID",DA,XUSNPI,$$NOW^XLFDT(),1) ;add NPI
+ I XUS1>0,$D(KEYS) F XUS2=1:1 S Y=$P(KEYS,",",XUS2) Q:'$L(Y)  D
+ . S %=$$ADD^XQKEY(XUS1,Y) I '% W !,"Key '",Y,"' not allocated"
+ I XUS1>0 D CALL^XUSERP(+XUS1,1) ;XQOR add
+AX Q XUS1
+ ;
+REPRINT ;Reprint letter
+ S DA=+$$LOOKUP^XUSER G EXIT:DA'>0
+ D LETTER(DA)
+ G EXIT
+ ;
+LETTER(XUN,ASK) ;Print access letter
+ Q:'$G(XUN)
+ N DIWF,FR,TO,BY,DIR,XUTEXT
+ S XUTEXT=$$GET^XUPARAM("XUSER COMPUTER ACCOUNT","N"),XUTEXT=$O(^DIC(9.2,"B",XUTEXT,0))
+ S DIR(0)="Y",DIR("A")="Print User Account Access Letter"
+ I XUTEXT>0 S Y=1 D:$G(ASK) ^DIR I Y=1 D
+ . S (XUU,XUU2)="________",DIWF="^DIC(9.2,XUTEXT,1,",DIWF(1)=200,FR=XUN,TO=XUN,BY="NUMBER" D EN2^DIWF
+ . Q
+ Q
Index: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPI.m
===================================================================
--- WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPI.m	(revision 613)
+++ WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPI.m	(revision 623)
@@ -1,201 +1,189 @@
-XUSNPI	;OAK_BP/BDT - NATIONAL PROVIDER IDENTIFIER ;6/3/08  13:51
-	;;8.0;KERNEL;**410,416,480**; July 10, 1995;Build 38
-	;;Per VHA Directive 2004-038, this routine should not be modified
-ADDNPI(XUSQI,XUSIEN,XUSNPI,XUSDATE,XUSTATUS)	;
-	;;==============================================================
-	;; Update the Effective Date, Status & NPI trio.
-	;; XUSQI   : Qualified Identifier, Required. For examble: Individual_ID Or Organization_ID
-	;; XUSIEN  : Internal Entry Number. Required.
-	;; XUSNPI  : National Provider Identifier. Required.
-	;; XUSDATE : Active Date. Required.
-	;; 
-	;; If successful, return XUSRTN = IEN of new 42 sub-file entry.
-	;; Else return XUSRTN = "-1^ErrorMessage".
-	;; =============================================================
-	;
-	; Check valid inputs.
-	N XUSROOT,XUSFNB
-	S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI)
-	I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT
-	I XUSROOT="^" Q "-1^Invalid Qualified Identifier"
-	I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier"
-	S XUSFNB=+$P(XUSROOT,"(",2)
-	I 'XUSFNB Q "-1^No File #"
-	S XUSFNB=XUSFNB_".42"
-	I $G(XUSIEN)'>0 Q "-1^Invalid IEN"
-	;I (XUSIEN?.N)=0 Q "-1^Invalid IEN"
-	I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN"
-	N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I '$D(@XUIENCK) Q "-1^Invalid IEN"
-	I '$$CHKDGT(XUSNPI) Q "-1^Invalid NPI"
-	I '$$CHKDT(XUSQI,XUSIEN,XUSDATE) Q "-1^Invalid Effective Date"
-	I $G(XUSTATUS)="" S XUSTATUS=1
-	I (XUSTATUS'=0),(XUSTATUS'=1) Q "-1^Invalid Status"
-	N CHNPI S CHNPI=$$CHKDGT^XUSNPIE1(XUSNPI,XUSIEN,XUSQI) ; check if NPI is being used.
-	I CHNPI'=1 Q "-1^The NPI is being used."
-	;
-	;------------------------------------------------------------------
-	N ZZ,XUSRTN,ERRMSG,XUSX S ERRMSG=""
-	S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_")"
-	; Update Effective Date #42 multiple fields 
-	S XUSFNB=$P(XUSROOT,"(",2)
-	S XUSFNB=+$P(XUSFNB,",") I XUSFNB S XUSFNB=XUSFNB_".042"
-	S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.01)=XUSDATE
-	S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.02)=XUSTATUS
-	S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.03)=XUSNPI
-	D UPDATE^DIE("","ZZ(1)",,ERRMSG)
-	I $L(ERRMSG) Q "-1^"_$G(ERRMSG)
-	S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""B"""_","_XUSDATE_","_"""A"""_")"
-	S XUSRTN=$O(@XUSX,-1)
-	I '+XUSRTN Q "-1^No entry add"
-	Q XUSRTN
-	;
-NPI(XUSQI,XUSIEN,XUSDATE)	; Retrieve the NPI value for a qualified identifier entity.
-	;;==============================================================
-	;; XUSQI   : Qualified Identifier, Required. For examble: Individual_ID Or Organization_ID
-	;; XUSIEN  : Internal Entry Number of file #4 or #200. Required.
-	;; XUSDATE : Active Date. Not Required. Default: 'Today'.
-	;; 
-	;; If current NPI exists, return XUSRTN = 'NPI^EffectiveDate^Status'
-	;; If invalid XUSQI or XUSIEN, return '-1^ErrorMessage'
-	;; Else return 0
-	;; =============================================================
-	; check valid inputs
-	I $G(XUSIEN)'>0 Q "-1^Invalid IEN"
-	;I (XUSIEN?.N)=0 Q "-1^Invalid IEN"
-	I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN"
-	I $G(XUSDATE)="" S XUSDATE=$$NOW^XLFDT
-	N X,Y,%DT S %DT="T",X=XUSDATE D ^%DT I Y'=XUSDATE Q "-1^Invalid Effective Date"
-	;-----------------------------------
-	N XUSDA,XUSI,XUSRTN,XUSROOT,XUSX,XUSTAT S (XUSDA,XUSRTN)="",XUSTAT="Inactive"
-	; get global from Parameter file base on Qualified Identifier.
-	S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI)
-	I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT
-	I XUSROOT="^" Q "-1^Invalid Qualified Identifier"
-	N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I '$D(@XUIENCK) Q "-1^Invalid IEN"
-	I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier"
-	S XUSROOT=XUSROOT_XUSIEN_","_"""NPISTATUS"""
-	S XUSX=XUSROOT_")" I '$D(@XUSX) Q "-1^No NPI found"
-	S XUSI=0 F  S XUSI=$O(@(XUSROOT_","_"""B"""_","_XUSI_")")) Q:XUSI>XUSDATE!'XUSI
-	I 'XUSI S XUSX=XUSROOT_","_"""B"""_","_"""A"""_")",XUSDA=$O(@XUSX,-1)
-	I XUSI>XUSDATE S XUSX=XUSROOT_","_"""B"""_","_XUSI_")",XUSDA=$O(@(XUSX),-1)
-	I XUSDA="" Q 0
-	S XUSDA=XUSROOT_","_"""B"""_","_XUSDA_","_"""A"""_")",XUSDA=$O(@XUSDA,-1)
-	S XUSRTN=XUSROOT_","_XUSDA_","_0_")"
-	I '$D(@XUSRTN) Q "-1^Invalid IEN"
-	I $P($G(@XUSRTN),"^",2)=1 S XUSTAT="Active"
-	Q $P($G(@XUSRTN),"^",3)_"^"_$P($G(@XUSRTN),"^",1)_"^"_XUSTAT
-	;       
-QI(XUSNPI)	; Retrieve the ALL qualified indentifier entity for an NPI value.
-	;;================================================
-	;; XUSNPI  : National Provider Identifier. Required
-	;; 
-	;; If qualified identified entity exists, return
-	;; 'QualifiedIdentifier^IEN^EffectiveDate^Status;'
-	;; If more than one records found, they are separated by ";"
-	;; Else return 0        
-	;;================================================
-	; check valid NPI
-	I '$$CHKDGT(XUSNPI) Q "0^Invalid NPI"
-	N ZZ
-	D GETLST^XPAR(.ZZ,"PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER")
-	I ZZ'>0 Q 0
-	N XUSI,XUSIEN,XUSROOT,XUSQT,XUSX,XUSRTN,XUSRTN1 S (XUSQT,XUSRTN)=0,XUSRTN1=""
-	S XUSI=0 F  S XUSI=$O(ZZ(XUSI)) Q:'XUSI  D
-	. S XUSROOT=$P(ZZ(XUSI),"^",2),XUSROOT="^"_XUSROOT
-	. I $$GLCK(XUSROOT)'>0 Q  ;check valid global root
-	. I $E(XUSNPI,1,1)=0 S XUSNPI=""""_XUSNPI_""""
-	. S XUSX=XUSROOT_"""NPI42"""_","_XUSNPI_")" Q:'$D(@XUSX)
-	. S XUSIEN=0 F  S XUSX=XUSROOT_"""NPI42"""_","_XUSNPI_","_XUSIEN_")",XUSIEN=$O(@XUSX) Q:XUSIEN'>0  D
-	. . S XUSRTN=$$SRCHNPI(XUSROOT,XUSIEN,XUSNPI)
-	. . I +XUSRTN S XUSRTN1=XUSRTN1_$P(ZZ(XUSI),"^")_"^"_XUSRTN_";",XUSQT=XUSQT+1
-	I XUSRTN1="" S XUSRTN1=0
-	Q XUSRTN1
-	;
-GLCK(XUSROOT)	; check valid global root
-	N XUFNB,ZZ
-	I $G(XUSROOT)="" Q 0
-	S XUFNB=$P(XUSROOT,"(",2),XUFNB=$P(XUFNB,",")
-	D FILE^DID(XUFNB,"","GLOBAL NAME","ZZ")
-	Q (XUSROOT=$G(ZZ("GLOBAL NAME")))
-	;
-SRCHNPI(XUSROOT,XUSIEN,XUSNPI)	;
-	I $G(XUSIEN)'>0 Q 0
-	I (XUSIEN?.N)=0 Q 0
-	N XUSX,XUSRTN S XUSRTN=0
-	I $E(XUSNPI,1,1)=0 S XUSNPI=""""_XUSNPI_""""
-	S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""C"""_","_XUSNPI_")"
-	I '$D(@XUSX) Q 0
-	S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""C"""_","_XUSNPI_","_"""A"""_")"
-	S XUSRTN=$O(@XUSX,-1)
-	I '+XUSRTN Q 0
-	S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_XUSRTN_","_0_")"
-	I '$D(@XUSX) Q 0
-	S XUSRTN=$G(@XUSX) I XUSRTN S XUSRTN=XUSIEN_"^"_$P(XUSRTN,"^")_"^"_$P(XUSRTN,"^",2)
-	I $P(XUSRTN,"^",3)=1 S $P(XUSRTN,"^",3)="Active"
-	I $P(XUSRTN,"^",3)=0 S $P(XUSRTN,"^",3)="Inactive"
-	Q XUSRTN
-	;
-CHKDGT(XUSNPI)	;
-	;  Function to validate the format of an NPI number.  It checks the
-	;  length of the number, whether the NPI is numeric, and whether
-	;  the check digit is valid.
-	;
-	;  Input parameter:
-	;    NPI - 10-digit NPI number to validate.
-	;
-	;  Output parameter:
-	;    Boolean value indicating whether the NPI has a valid format
-	;
-	;  NPI must be 10 digits long.
-	I XUSNPI'?10N Q 0
-	Q $E(XUSNPI,10)=$$CKDIGIT($E(XUSNPI,1,9))
-	;
-CKDIGIT(XUSNPI)	;
-	;  Function to calculate and return the check digit of an NPI.
-	;  The check digit is calculated using the Luhn Formula for
-	;  Modulus 10 "double-add-double" Check Digit.  A value of 24 is
-	;  added to the total to account for the implied USA (80840) prefix.
-	;
-	N XUSCTOT,XUSCN,XUSCDIG,XUSI
-	S XUSCTOT=24
-	F XUSI=9:-2:1 S XUSCN=2*$E(XUSNPI,XUSI),XUSCTOT=XUSCTOT+$E(XUSCN)+$E(XUSCN,2)+$E(XUSNPI,XUSI-1)
-	S XUSCDIG=150-XUSCTOT
-	Q $E(XUSCDIG,$L(XUSCDIG))
-	;
-CHKDT(XUSQI,XUSIEN,XUSDATE)	; Check Date
-	;;============================================================================
-	;;  XUSQI   : Qualified Identifier. Required. For examble: "Individual_ID"
-	;;  XUSIEN  : Internal Entry Number. Required.
-	;;  XUSDATE : The Effective Date value to test. Must be FM date. Required. 
-	;;  
-	;;  If input passes date comparison, return 1.
-	;;  Else return 0.
-	;;============================================================================
-	; 
-	I $G(XUSIEN)'>0 Q "0^Invalid IEN."
-	;I (XUSIEN?.N)=0 Q "0^Invalid IEN."
-	I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN"
-	N X,Y,%DT S %DT="T",X=$G(XUSDATE) D ^%DT I Y'=XUSDATE Q "0^Invalid Effective Date. Must be FM Date/Time."
-	;-----------------------------------
-	N XUSROOT,XUSDA
-	N XUSCRDT S XUSCRDT=$$NOW^XLFDT I XUSDATE>XUSCRDT Q 0
-	; get global from Parameter file base on Qualified Identifier.
-	S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI)
-	I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT
-	I XUSROOT="^" Q "0^Invalid Qualified Identifier."
-	I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier"
-	N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I $D(@XUIENCK)'>0 Q "0^Invalid IEN."
-	S XUSROOT=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""B"""_","_"""A"""_")",XUSDA=$O(@XUSROOT,-1)
-	Q (XUSDATE'<XUSDA)
-	;
-GETRLNPI(XUSIEN)	; Return field indicating blanket release of NPI
-	;; XUSIEN  : Internal Entry Number of person in file 200. Required
-	;; Output: -1^error message or contents of AUTHORIZE RELEASE OF NPI field.
-	S XUSIEN=+$G(XUSIEN) I $G(^VA(200,XUSIEN,0))="" Q "-1^Invalid IEN"
-	N X
-	S X=$$NPI^XUSNPI("Individual_ID",XUSIEN)
-	I (X'>0)!($P(X,U,3)'="Active") Q "-1^User has no active NPI"
-	S X=$P($G(^VA(200,XUSIEN,"NPI")),U,3)
-	S:X="" X=0
-	Q X
-	;
+XUSNPI ;OAK_BP/BDT - NATIONAL PROVIDER IDENTIFIER; 8/10/06
+ ;;8.0;KERNEL;**410,416**; July 10, 1997;Build 5
+ ;;
+ADDNPI(XUSQI,XUSIEN,XUSNPI,XUSDATE,XUSTATUS) ;
+ ;;==============================================================
+ ;; Update the Effective Date, Status & NPI trio.
+ ;; XUSQI   : Qualified Identifier, Required. For examble: Individual_ID Or Organization_ID
+ ;; XUSIEN  : Internal Entry Number. Required.
+ ;; XUSNPI  : National Provider Identifier. Required.
+ ;; XUSDATE : Active Date. Required.
+ ;; 
+ ;; If successful, return XUSRTN = IEN of new 42 sub-file entry.
+ ;; Else return XUSRTN = "-1^ErrorMessage".
+ ;; =============================================================
+ ;
+ ; Check valid inputs.
+ N XUSROOT,XUSFNB
+ S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI)
+ I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT
+ I XUSROOT="^" Q "-1^Invalid Qualified Identifier"
+ I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier"
+ S XUSFNB=+$P(XUSROOT,"(",2)
+ I 'XUSFNB Q "-1^No File #"
+ S XUSFNB=XUSFNB_".42"
+ I $G(XUSIEN)'>0 Q "-1^Invalid IEN"
+ ;I (XUSIEN?.N)=0 Q "-1^Invalid IEN"
+ I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN"
+ N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I '$D(@XUIENCK) Q "-1^Invalid IEN"
+ I '$$CHKDGT(XUSNPI) Q "-1^Invalid NPI"
+ I '$$CHKDT(XUSQI,XUSIEN,XUSDATE) Q "-1^Invalid Effective Date"
+ I $G(XUSTATUS)="" S XUSTATUS=1
+ I (XUSTATUS'=0),(XUSTATUS'=1) Q "-1^Invalid Status"
+ N CHNPI S CHNPI=$$CHKDGT^XUSNPIE1(XUSNPI,XUSIEN,XUSQI) ; check if NPI is being used.
+ I CHNPI'=1 Q "-1^The NPI is being used."
+ ;
+ ;------------------------------------------------------------------
+ N ZZ,XUSRTN,ERRMSG,XUSX S ERRMSG=""
+ S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_")"
+ ; Update Effective Date #42 multiple fields 
+ S XUSFNB=$P(XUSROOT,"(",2)
+ S XUSFNB=+$P(XUSFNB,",") I XUSFNB S XUSFNB=XUSFNB_".042"
+ S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.01)=XUSDATE
+ S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.02)=XUSTATUS
+ S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.03)=XUSNPI
+ D UPDATE^DIE("","ZZ(1)",,ERRMSG)
+ I $L(ERRMSG) Q "-1^"_$G(ERRMSG)
+ S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""B"""_","_XUSDATE_","_"""A"""_")"
+ S XUSRTN=$O(@XUSX,-1)
+ I '+XUSRTN Q "-1^No entry add"
+ Q XUSRTN
+ ;
+NPI(XUSQI,XUSIEN,XUSDATE) ; Retrieve the NPI value for a qualified identifier entity.
+ ;;==============================================================
+ ;; XUSQI   : Qualified Identifier, Required. For examble: Individual_ID Or Organization_ID
+ ;; XUSIEN  : Internal Entry Number of file #4 or #200. Required.
+ ;; XUSDATE : Active Date. Not Required. Default: 'Today'.
+ ;; 
+ ;; If current NPI exists, return XUSRTN = 'NPI^EffectiveDate^Status'
+ ;; If invalid XUSQI or XUSIEN, return '-1^ErrorMessage'
+ ;; Else return 0
+ ;; =============================================================
+ ; check valid inputs
+ I $G(XUSIEN)'>0 Q "-1^Invalid IEN"
+ ;I (XUSIEN?.N)=0 Q "-1^Invalid IEN"
+ I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN"
+ I $G(XUSDATE)="" S XUSDATE=$$NOW^XLFDT
+ N X,Y,%DT S %DT="T",X=XUSDATE D ^%DT I Y'=XUSDATE Q "-1^Invalid Effective Date"
+ ;-----------------------------------
+ N XUSDA,XUSI,XUSRTN,XUSROOT,XUSX,XUSTAT S (XUSDA,XUSRTN)="",XUSTAT="Inactive"
+ ; get global from Parameter file base on Qualified Identifier.
+ S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI)
+ I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT
+ I XUSROOT="^" Q "-1^Invalid Qualified Identifier"
+ N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I '$D(@XUIENCK) Q "-1^Invalid IEN"
+ I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier"
+ S XUSROOT=XUSROOT_XUSIEN_","_"""NPISTATUS"""
+ S XUSX=XUSROOT_")" I '$D(@XUSX) Q "-1^No NPI found"
+ S XUSI=0 F  S XUSI=$O(@(XUSROOT_","_"""B"""_","_XUSI_")")) Q:XUSI>XUSDATE!'XUSI
+ I 'XUSI S XUSX=XUSROOT_","_"""B"""_","_"""A"""_")",XUSDA=$O(@XUSX,-1)
+ I XUSI>XUSDATE S XUSX=XUSROOT_","_"""B"""_","_XUSI_")",XUSDA=$O(@(XUSX),-1)
+ I XUSDA="" Q 0
+ S XUSDA=XUSROOT_","_"""B"""_","_XUSDA_","_"""A"""_")",XUSDA=$O(@XUSDA,-1)
+ S XUSRTN=XUSROOT_","_XUSDA_","_0_")"
+ I '$D(@XUSRTN) Q "-1^Invalid IEN"
+ I $P($G(@XUSRTN),"^",2)=1 S XUSTAT="Active"
+ Q $P($G(@XUSRTN),"^",3)_"^"_$P($G(@XUSRTN),"^",1)_"^"_XUSTAT
+ ;       
+QI(XUSNPI) ; Retrieve the ALL qualified indentifier entity for an NPI value.
+ ;;================================================
+ ;; XUSNPI  : National Provider Identifier. Required
+ ;; 
+ ;; If qualified identified entity exists, return
+ ;; 'QualifiedIdentifier^IEN^EffectiveDate^Status;'
+ ;; If more than one records found, they are separated by ";"
+ ;; Else return 0        
+ ;;================================================
+ ; check valid NPI
+ I '$$CHKDGT(XUSNPI) Q "0^Invalid NPI"
+ N ZZ
+ D GETLST^XPAR(.ZZ,"PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER")
+ I ZZ'>0 Q 0
+ N XUSI,XUSIEN,XUSROOT,XUSQT,XUSX,XUSRTN,XUSRTN1 S (XUSQT,XUSRTN)=0,XUSRTN1=""
+ S XUSI=0 F  S XUSI=$O(ZZ(XUSI)) Q:'XUSI  D
+ . S XUSROOT=$P(ZZ(XUSI),"^",2),XUSROOT="^"_XUSROOT
+ . I $$GLCK(XUSROOT)'>0 Q  ;check valid global root
+ . I $E(XUSNPI,1,1)=0 S XUSNPI=""""_XUSNPI_""""
+ . S XUSX=XUSROOT_"""NPI42"""_","_XUSNPI_")" Q:'$D(@XUSX)
+ . S XUSIEN=0 F  S XUSX=XUSROOT_"""NPI42"""_","_XUSNPI_","_XUSIEN_")",XUSIEN=$O(@XUSX) Q:XUSIEN'>0  D
+ . . S XUSRTN=$$SRCHNPI(XUSROOT,XUSIEN,XUSNPI)
+ . . I +XUSRTN S XUSRTN1=XUSRTN1_$P(ZZ(XUSI),"^")_"^"_XUSRTN_";",XUSQT=XUSQT+1
+ I XUSRTN1="" S XUSRTN1=0
+ Q XUSRTN1
+ ;
+GLCK(XUSROOT) ; check valid global root
+ N XUFNB,ZZ
+ I $G(XUSROOT)="" Q 0
+ S XUFNB=$P(XUSROOT,"(",2),XUFNB=$P(XUFNB,",")
+ D FILE^DID(XUFNB,"","GLOBAL NAME","ZZ")
+ Q (XUSROOT=$G(ZZ("GLOBAL NAME")))
+ ;
+SRCHNPI(XUSROOT,XUSIEN,XUSNPI) ;
+ I $G(XUSIEN)'>0 Q 0
+ I (XUSIEN?.N)=0 Q 0
+ N XUSX,XUSRTN S XUSRTN=0
+ I $E(XUSNPI,1,1)=0 S XUSNPI=""""_XUSNPI_""""
+ S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""C"""_","_XUSNPI_")"
+ I '$D(@XUSX) Q 0
+ S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""C"""_","_XUSNPI_","_"""A"""_")"
+ S XUSRTN=$O(@XUSX,-1)
+ I '+XUSRTN Q 0
+ S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_XUSRTN_","_0_")"
+ I '$D(@XUSX) Q 0
+ S XUSRTN=$G(@XUSX) I XUSRTN S XUSRTN=XUSIEN_"^"_$P(XUSRTN,"^")_"^"_$P(XUSRTN,"^",2)
+ I $P(XUSRTN,"^",3)=1 S $P(XUSRTN,"^",3)="Active"
+ I $P(XUSRTN,"^",3)=0 S $P(XUSRTN,"^",3)="Inactive"
+ Q XUSRTN
+ ;
+CHKDGT(XUSNPI) ;
+ ;  Function to validate the format of an NPI number.  It checks the
+ ;  length of the number, whether the NPI is numeric, and whether
+ ;  the check digit is valid.
+ ;
+ ;  Input parameter:
+ ;    NPI - 10-digit NPI number to validate.
+ ;
+ ;  Output parameter:
+ ;    Boolean value indicating whether the NPI has a valid format
+ ;
+ ;  NPI must be 10 digits long.
+ I XUSNPI'?10N Q 0
+ Q $E(XUSNPI,10)=$$CKDIGIT($E(XUSNPI,1,9))
+ ;
+CKDIGIT(XUSNPI) ;
+ ;  Function to calculate and return the check digit of an NPI.
+ ;  The check digit is calculated using the Luhn Formula for
+ ;  Modulus 10 "double-add-double" Check Digit.  A value of 24 is
+ ;  added to the total to account for the implied USA (80840) prefix.
+ ;
+ N XUSCTOT,XUSCN,XUSCDIG,XUSI
+ S XUSCTOT=24
+ F XUSI=9:-2:1 S XUSCN=2*$E(XUSNPI,XUSI),XUSCTOT=XUSCTOT+$E(XUSCN)+$E(XUSCN,2)+$E(XUSNPI,XUSI-1)
+ S XUSCDIG=150-XUSCTOT
+ Q $E(XUSCDIG,$L(XUSCDIG))
+ ;
+CHKDT(XUSQI,XUSIEN,XUSDATE) ; Check Date
+ ;;============================================================================
+ ;;  XUSQI   : Qualified Identifier. Required. For examble: "Individual_ID"
+ ;;  XUSIEN  : Internal Entry Number. Required.
+ ;;  XUSDATE : The Effective Date value to test. Must be FM date. Required. 
+ ;;  
+ ;;  If input passes date comparison, return 1.
+ ;;  Else return 0.
+ ;;============================================================================
+ ; 
+ I $G(XUSIEN)'>0 Q "0^Invalid IEN."
+ ;I (XUSIEN?.N)=0 Q "0^Invalid IEN."
+ I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN"
+ N X,Y,%DT S %DT="T",X=$G(XUSDATE) D ^%DT I Y'=XUSDATE Q "0^Invalid Effective Date. Must be FM Date/Time."
+ ;-----------------------------------
+ N XUSROOT,XUSDA
+ N XUSCRDT S XUSCRDT=$$NOW^XLFDT I XUSDATE>XUSCRDT Q 0
+ ; get global from Parameter file base on Qualified Identifier.
+ S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI)
+ I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT
+ I XUSROOT="^" Q "0^Invalid Qualified Identifier."
+ I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier"
+ N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I $D(@XUIENCK)'>0 Q "0^Invalid IEN."
+ S XUSROOT=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""B"""_","_"""A"""_")",XUSDA=$O(@XUSROOT,-1)
+ Q (XUSDATE'<XUSDA)
Index: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIDA.m
===================================================================
--- WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIDA.m	(revision 613)
+++ WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIDA.m	(revision 623)
@@ -1,345 +1,343 @@
-XUSNPIDA	;FO-OAKLAND/JLI - SPECIFIED TAXONOMY VALUES FOR NPI RECIPIENTS ;4/8/08  18:18
-	;;8.0;KERNEL;**420,410,480**;Jul 10, 1995;Build 38
-	;;Per VHA Directive 2004-038, this routine should not be modified
-	Q
-	;
-CHKGLOB()	;  returns global location of TAXONOMY values also rebuilds if they are missing
-	N I,STR,XUGLOB
-	S XUGLOB=$NA(^XTMP("NPIVALS"))
-	; check for ;;; is to permit sites to add a ; to exclude some values not used at site
-	I '$D(@XUGLOB) F I=1:1 S STR=$T(@("VALUES+"_I_"^XUSNPIDA")) I STR'[";;;" S STR=$P(STR,";;",2) Q:STR=""  S @XUGLOB@(STR)=""
-	S @XUGLOB@(0)=$$FMADD^XLFDT(DT,15)
-	Q XUGLOB
-	;
-VALUES	;
-	;;101Y00000X
-	;;101YA0400X
-	;;101YM0800X
-	;;101YP1600X
-	;;101YP2500X
-	;;101YS0200X
-	;;103G00000X
-	;;103GC0700X
-	;;103T00000X
-	;;103TA0400X
-	;;103TA0700X
-	;;103TB0200X
-	;;103TC0700X
-	;;103TC1900X
-	;;103TC2200X
-	;;103TE1000X
-	;;103TE1100X
-	;;103TF0000X
-	;;103TF0200X
-	;;103TH0100X
-	;;103TM1700X
-	;;103TM1800X
-	;;103TP0814X
-	;;103TP2700X
-	;;103TP2701X
-	;;103TR0400X
-	;;103TS0200X
-	;;103TW0100X
-	;;104100000X
-	;;1041C0700X
-	;;1041S0200X
-	;;111N00000X
-	;;111NI0900X
-	;;111NN0400X
-	;;111NN1001X
-	;;111NR0200X
-	;;111NS0005X
-	;;111NT0100X
-	;;111NX0100X
-	;;111NX0800X
-	;;122300000X
-	;;1223D0001X
-	;;1223E0200X
-	;;1223G0001X
-	;;1223P0106X
-	;;1223P0221X
-	;;1223P0300X
-	;;1223P0700X
-	;;1223S0112X
-	;;1223X0008X
-	;;1223X0400X
-	;;133V00000X
-	;;133VN1004X
-	;;133VN1005X
-	;;133VN1006X
-	;;152W00000X
-	;;152WC0802X
-	;;152WL0500X
-	;;152WP0200X
-	;;152WS0006X
-	;;152WV0400X
-	;;152WX0102X
-	;;170100000X
-	;;183500000X
-	;;1835G0000X
-	;;1835N0905X
-	;;1835N1003X
-	;;1835P1200X
-	;;1835P1300X
-	;;204C00000X
-	;;204D00000X
-	;;204E00000X
-	;;204F00000X
-	;;207K00000X
-	;;207KA0200X
-	;;207KI0005X
-	;;207L00000X
-	;;207LA0401X
-	;;207LC0200X
-	;;207LP2900X
-	;;207N00000X
-	;;207ND0101X
-	;;207ND0900X
-	;;207NI0002X
-	;;207NP0225X
-	;;207NS0135X
-	;;207P00000X
-	;;207PE0004X
-	;;207PE0005X
-	;;207PP0204X
-	;;207PS0010X
-	;;207PT0002X
-	;;207Q00000X
-	;;207QA0000X
-	;;207QA0401X
-	;;207QA0505X
-	;;207QG0300X
-	;;207QS0010X
-	;;207R00000X
-	;;207RA0000X
-	;;207RA0201X
-	;;207RA0401X
-	;;207RC0000X
-	;;207RC0001X
-	;;207RC0200X
-	;;207RE0101X
-	;;207RG0100X
-	;;207RG0300X
-	;;207RH0000X
-	;;207RH0003X
-	;;207RI0001X
-	;;207RI0008X
-	;;207RI0011X
-	;;207RI0200X
-	;;207RM1200X
-	;;207RN0300X
-	;;207RP1001X
-	;;207RR0500X
-	;;207RS0010X
-	;;207RX0202X
-	;;207SC0300X
-	;;207SG0201X
-	;;207SG0202X
-	;;207SG0203X
-	;;207SG0205X
-	;;207SM0001X
-	;;207T00000X
-	;;207U00000X
-	;;207UN0901X
-	;;207UN0902X
-	;;207UN0903X
-	;;207V00000X
-	;;207VC0200X
-	;;207VE0102X
-	;;207VG0400X
-	;;207VM0101X
-	;;207VX0000X
-	;;207VX0201X
-	;;207W00000X
-	;;207X00000X
-	;;207XS0106X
-	;;207XS0114X
-	;;207XS0117X
-	;;207XX0004X
-	;;207XX0005X
-	;;207XX0801X
-	;;207Y00000X
-	;;207YP0228X
-	;;207YS0123X
-	;;207YX0007X
-	;;207YX0602X
-	;;207YX0901X
-	;;207YX0905X
-	;;207ZB0001X
-	;;207ZC0500X
-	;;207ZD0900X
-	;;207ZF0201X
-	;;207ZH0000X
-	;;207ZI0100X
-	;;207ZM0300X
-	;;207ZN0500X
-	;;207ZP0007X
-	;;207ZP0101X
-	;;207ZP0102X
-	;;207ZP0104X
-	;;207ZP0105X
-	;;207ZP0213X
-	;;208000000X
-	;;2080A0000X
-	;;2080I0007X
-	;;2080N0001X
-	;;2080P0006X
-	;;2080P0008X
-	;;2080P0201X
-	;;2080P0202X
-	;;2080P0203X
-	;;2080P0204X
-	;;2080P0205X
-	;;2080P0206X
-	;;2080P0207X
-	;;2080P0208X
-	;;2080P0210X
-	;;2080P0214X
-	;;2080P0216X
-	;;2080S0010X
-	;;2080T0002X
-	;;208100000X
-	;;2081P0004X
-	;;2081P0010X
-	;;2081P2900X
-	;;2081S0010X
-	;;208200000X
-	;;2082S0099X
-	;;2082S0105X
-	;;2083A0100X
-	;;2083P0011X
-	;;2083P0500X
-	;;2083P0901X
-	;;2083S0010X
-	;;2083T0002X
-	;;2083X0100X
-	;;2084A0401X
-	;;2084F0202X
-	;;2084N0400X
-	;;2084N0402X
-	;;2084N0600X
-	;;2084P0005X
-	;;2084P0800X
-	;;2084P0802X
-	;;2084P0804X
-	;;2084P0805X
-	;;2084P2900X
-	;;2084S0010X
-	;;2084V0102X
-	;;2085B0100X
-	;;2085N0700X
-	;;2085N0904X
-	;;2085P0229X
-	;;2085R0001X
-	;;2085R0202X
-	;;2085R0203X
-	;;2085R0204X
-	;;2085R0205X
-	;;2085U0001X
-	;;208600000X
-	;;2086S0102X
-	;;2086S0105X
-	;;2086S0120X
-	;;2086S0122X
-	;;2086S0127X
-	;;2086S0129X
-	;;2086X0206X
-	;;208800000X
-	;;208C00000X
-	;;208D00000X
-	;;208G00000X
-	;;208M00000X
-	;;208U00000X
-	;;208VP0000X
-	;;208VP0014X
-	;;209800000X
-	;;213E00000X
-	;;213EG0000X
-	;;213EP0504X
-	;;213EP1101X
-	;;213ER0200X
-	;;213ES0000X
-	;;213ES0103X
-	;;213ES0131X
-	;;225100000X
-	;;2251C2600X
-	;;2251E1200X
-	;;2251E1300X
-	;;2251G0304X
-	;;2251H1200X
-	;;2251H1300X
-	;;2251N0400X
-	;;2251P0200X
-	;;2251S0007X
-	;;2251X0800X
-	;;225X00000X
-	;;225XE1200X
-	;;225XH1200X
-	;;225XH1300X
-	;;225XN1300X
-	;;225XP0200X
-	;;225XR0403X
-	;;231H00000X
-	;;231HA2400X
-	;;231HA2500X
-	;;237600000X
-	;;363A00000X
-	;;363AM0700X
-	;;363AS0400X
-	;;363L00000X
-	;;363LA2100X
-	;;363LA2200X
-	;;363LC0200X
-	;;363LC1500X
-	;;363LF0000X
-	;;363LG0600X
-	;;363LN0000X
-	;;363LN0005X
-	;;363LP0200X
-	;;363LP0222X
-	;;363LP0808X
-	;;363LP1700X
-	;;363LP2300X
-	;;363LS0200X
-	;;363LW0102X
-	;;363LX0001X
-	;;363LX0106X
-	;;364S00000X
-	;;364SA2100X
-	;;364SA2200X
-	;;364SC0200X
-	;;364SC1501X
-	;;364SC2300X
-	;;364SE0003X
-	;;364SE1400X
-	;;364SF0001X
-	;;364SG0600X
-	;;364SH0200X
-	;;364SH1100X
-	;;364SI0800X
-	;;364SL0600X
-	;;364SM0705X
-	;;364SN0000X
-	;;364SN0800X
-	;;364SP0200X
-	;;364SP0807X
-	;;364SP0808X
-	;;364SP0809X
-	;;364SP0810X
-	;;364SP0811X
-	;;364SP0812X
-	;;364SP0813X
-	;;364SP1700X
-	;;364SP2800X
-	;;364SR0400X
-	;;364SS0200X
-	;;364ST0500X
-	;;364SW0102X
-	;;364SX0106X
-	;;364SX0200X
-	;;364SX0204X
-	;;367500000X
-	;;367A00000X
-	;;367H00000X
-	;;390200000X
-	;;
+XUSNPIDA ;FO-OAKLAND/JLI - SPECIFIED TAXONOMY VALUES FOR NPI RECIPIENTS ;8/22/06  11:37
+ ;;8.0;KERNEL;**420,410**;Jul 10, 1995;Build 27
+ Q
+ ;
+CHKGLOB() ;  returns global location of TAXONOMY values also rebuilds if they are missing
+ N I,STR,XUGLOB
+ S XUGLOB=$NA(^XTMP("NPIVALS"))
+ ; check for ;;; is to permit sites to add a ; to exclude some values not used at site
+ I '$D(@XUGLOB) F I=1:1 S STR=$T(@("VALUES+"_I_"^XUSNPIDA")) I STR'[";;;" S STR=$P(STR,";;",2) Q:STR=""  S @XUGLOB@(STR)=""
+ S @XUGLOB@(0)=$$FMADD^XLFDT(DT,15)
+ Q XUGLOB
+ ;
+VALUES ;
+ ;;101Y00000X
+ ;;101YA0400X
+ ;;101YM0800X
+ ;;101YP1600X
+ ;;101YP2500X
+ ;;101YS0200X
+ ;;103G00000X
+ ;;103GC0700X
+ ;;103T00000X
+ ;;103TA0400X
+ ;;103TA0700X
+ ;;103TB0200X
+ ;;103TC0700X
+ ;;103TC1900X
+ ;;103TC2200X
+ ;;103TE1000X
+ ;;103TE1100X
+ ;;103TF0000X
+ ;;103TF0200X
+ ;;103TH0100X
+ ;;103TM1700X
+ ;;103TM1800X
+ ;;103TP0814X
+ ;;103TP2700X
+ ;;103TP2701X
+ ;;103TR0400X
+ ;;103TS0200X
+ ;;103TW0100X
+ ;;104100000X
+ ;;1041C0700X
+ ;;1041S0200X
+ ;;111N00000X
+ ;;111NI0900X
+ ;;111NN0400X
+ ;;111NN1001X
+ ;;111NR0200X
+ ;;111NS0005X
+ ;;111NT0100X
+ ;;111NX0100X
+ ;;111NX0800X
+ ;;122300000X
+ ;;1223D0001X
+ ;;1223E0200X
+ ;;1223G0001X
+ ;;1223P0106X
+ ;;1223P0221X
+ ;;1223P0300X
+ ;;1223P0700X
+ ;;1223S0112X
+ ;;1223X0008X
+ ;;1223X0400X
+ ;;133V00000X
+ ;;133VN1004X
+ ;;133VN1005X
+ ;;133VN1006X
+ ;;152W00000X
+ ;;152WC0802X
+ ;;152WL0500X
+ ;;152WP0200X
+ ;;152WS0006X
+ ;;152WV0400X
+ ;;152WX0102X
+ ;;170100000X
+ ;;183500000X
+ ;;1835G0000X
+ ;;1835N0905X
+ ;;1835N1003X
+ ;;1835P1200X
+ ;;1835P1300X
+ ;;204C00000X
+ ;;204D00000X
+ ;;204E00000X
+ ;;204F00000X
+ ;;207K00000X
+ ;;207KA0200X
+ ;;207KI0005X
+ ;;207L00000X
+ ;;207LA0401X
+ ;;207LC0200X
+ ;;207LP2900X
+ ;;207N00000X
+ ;;207ND0101X
+ ;;207ND0900X
+ ;;207NI0002X
+ ;;207NP0225X
+ ;;207NS0135X
+ ;;207P00000X
+ ;;207PE0004X
+ ;;207PE0005X
+ ;;207PP0204X
+ ;;207PS0010X
+ ;;207PT0002X
+ ;;207Q00000X
+ ;;207QA0000X
+ ;;207QA0401X
+ ;;207QA0505X
+ ;;207QG0300X
+ ;;207QS0010X
+ ;;207R00000X
+ ;;207RA0000X
+ ;;207RA0201X
+ ;;207RA0401X
+ ;;207RC0000X
+ ;;207RC0001X
+ ;;207RC0200X
+ ;;207RE0101X
+ ;;207RG0100X
+ ;;207RG0300X
+ ;;207RH0000X
+ ;;207RH0003X
+ ;;207RI0001X
+ ;;207RI0008X
+ ;;207RI0011X
+ ;;207RI0200X
+ ;;207RM1200X
+ ;;207RN0300X
+ ;;207RP1001X
+ ;;207RR0500X
+ ;;207RS0010X
+ ;;207RX0202X
+ ;;207SC0300X
+ ;;207SG0201X
+ ;;207SG0202X
+ ;;207SG0203X
+ ;;207SG0205X
+ ;;207SM0001X
+ ;;207T00000X
+ ;;207U00000X
+ ;;207UN0901X
+ ;;207UN0902X
+ ;;207UN0903X
+ ;;207V00000X
+ ;;207VC0200X
+ ;;207VE0102X
+ ;;207VG0400X
+ ;;207VM0101X
+ ;;207VX0000X
+ ;;207VX0201X
+ ;;207W00000X
+ ;;207X00000X
+ ;;207XS0106X
+ ;;207XS0114X
+ ;;207XS0117X
+ ;;207XX0004X
+ ;;207XX0005X
+ ;;207XX0801X
+ ;;207Y00000X
+ ;;207YP0228X
+ ;;207YS0123X
+ ;;207YX0007X
+ ;;207YX0602X
+ ;;207YX0901X
+ ;;207YX0905X
+ ;;207ZB0001X
+ ;;207ZC0500X
+ ;;207ZD0900X
+ ;;207ZF0201X
+ ;;207ZH0000X
+ ;;207ZI0100X
+ ;;207ZM0300X
+ ;;207ZN0500X
+ ;;207ZP0007X
+ ;;207ZP0101X
+ ;;207ZP0102X
+ ;;207ZP0104X
+ ;;207ZP0105X
+ ;;207ZP0213X
+ ;;208000000X
+ ;;2080A0000X
+ ;;2080I0007X
+ ;;2080N0001X
+ ;;2080P0006X
+ ;;2080P0008X
+ ;;2080P0201X
+ ;;2080P0202X
+ ;;2080P0203X
+ ;;2080P0204X
+ ;;2080P0205X
+ ;;2080P0206X
+ ;;2080P0207X
+ ;;2080P0208X
+ ;;2080P0210X
+ ;;2080P0214X
+ ;;2080P0216X
+ ;;2080S0010X
+ ;;2080T0002X
+ ;;208100000X
+ ;;2081P0004X
+ ;;2081P0010X
+ ;;2081P2900X
+ ;;2081S0010X
+ ;;208200000X
+ ;;2082S0099X
+ ;;2082S0105X
+ ;;2083A0100X
+ ;;2083P0011X
+ ;;2083P0500X
+ ;;2083P0901X
+ ;;2083S0010X
+ ;;2083T0002X
+ ;;2083X0100X
+ ;;2084A0401X
+ ;;2084F0202X
+ ;;2084N0400X
+ ;;2084N0402X
+ ;;2084N0600X
+ ;;2084P0005X
+ ;;2084P0800X
+ ;;2084P0802X
+ ;;2084P0804X
+ ;;2084P0805X
+ ;;2084P2900X
+ ;;2084S0010X
+ ;;2084V0102X
+ ;;2085B0100X
+ ;;2085N0700X
+ ;;2085N0904X
+ ;;2085P0229X
+ ;;2085R0001X
+ ;;2085R0202X
+ ;;2085R0203X
+ ;;2085R0204X
+ ;;2085R0205X
+ ;;2085U0001X
+ ;;208600000X
+ ;;2086S0102X
+ ;;2086S0105X
+ ;;2086S0120X
+ ;;2086S0122X
+ ;;2086S0127X
+ ;;2086S0129X
+ ;;2086X0206X
+ ;;208800000X
+ ;;208C00000X
+ ;;208D00000X
+ ;;208G00000X
+ ;;208M00000X
+ ;;208U00000X
+ ;;208VP0000X
+ ;;208VP0014X
+ ;;209800000X
+ ;;213E00000X
+ ;;213EG0000X
+ ;;213EP0504X
+ ;;213EP1101X
+ ;;213ER0200X
+ ;;213ES0000X
+ ;;213ES0103X
+ ;;213ES0131X
+ ;;225100000X
+ ;;2251C2600X
+ ;;2251E1200X
+ ;;2251E1300X
+ ;;2251G0304X
+ ;;2251H1200X
+ ;;2251H1300X
+ ;;2251N0400X
+ ;;2251P0200X
+ ;;2251S0007X
+ ;;2251X0800X
+ ;;225X00000X
+ ;;225XE1200X
+ ;;225XH1200X
+ ;;225XH1300X
+ ;;225XN1300X
+ ;;225XP0200X
+ ;;225XR0403X
+ ;;231H00000X
+ ;;231HA2400X
+ ;;231HA2500X
+ ;;237600000X
+ ;;363A00000X
+ ;;363AM0700X
+ ;;363AS0400X
+ ;;363L00000X
+ ;;363LA2100X
+ ;;363LA2200X
+ ;;363LC0200X
+ ;;363LC1500X
+ ;;363LF0000X
+ ;;363LG0600X
+ ;;363LN0000X
+ ;;363LN0005X
+ ;;363LP0200X
+ ;;363LP0222X
+ ;;363LP0808X
+ ;;363LP1700X
+ ;;363LP2300X
+ ;;363LS0200X
+ ;;363LW0102X
+ ;;363LX0001X
+ ;;363LX0106X
+ ;;364S00000X
+ ;;364SA2100X
+ ;;364SA2200X
+ ;;364SC0200X
+ ;;364SC1501X
+ ;;364SC2300X
+ ;;364SE0003X
+ ;;364SE1400X
+ ;;364SF0001X
+ ;;364SG0600X
+ ;;364SH0200X
+ ;;364SH1100X
+ ;;364SI0800X
+ ;;364SL0600X
+ ;;364SM0705X
+ ;;364SN0000X
+ ;;364SN0800X
+ ;;364SP0200X
+ ;;364SP0807X
+ ;;364SP0808X
+ ;;364SP0809X
+ ;;364SP0810X
+ ;;364SP0811X
+ ;;364SP0812X
+ ;;364SP0813X
+ ;;364SP1700X
+ ;;364SP2800X
+ ;;364SR0400X
+ ;;364SS0200X
+ ;;364ST0500X
+ ;;364SW0102X
+ ;;364SX0106X
+ ;;364SX0200X
+ ;;364SX0204X
+ ;;367500000X
+ ;;367A00000X
+ ;;367H00000X
+ ;;
Index: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIE1.m
===================================================================
--- WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIE1.m	(revision 613)
+++ WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIE1.m	(revision 623)
@@ -1,103 +1,160 @@
-XUSNPIE1	;FO-OAKLAND/JLI - NATIONAL PROVIDER IDENTIFIER DATA CAPTURE ;5/13/08  17:32
-	;;8.0;KERNEL;**420,410,435,454,462,480**; July 10, 1995;Build 38
-	;;Per VHA Directive 2004-038, this routine should not be modified
-	Q
-	;
-SET(XUSIEN,XUSNPI)	;
-	; set value for NPI related fields (#41.97-41.99) in file #200
-	N XUSFDA,XUSIENS,X
-	S X=$G(^VA(200,XUSIEN,"NPI"))
-	S XUSIENS=XUSIEN_","
-	S XUSFDA(200,XUSIENS,41.99)=XUSNPI
-	S XUSFDA(200,XUSIENS,41.98)="D"
-	S XUSFDA(200,XUSIENS,41.97)=1
-	D FILE^DIE("","XUSFDA")
-	Q
-	;
-SET1(XUSIEN,XUSNPI)	;
-	; set value for NPI field (#41.99) in file #4
-	N OLDNPI S OLDNPI=$P($G(^DIC(4,XUSIEN,"NPI")),"^")
-	I OLDNPI K ^DIC(4,"ANPI",OLDNPI,XUSIEN)
-	S ^DIC(4,XUSIEN,"NPI")=XUSNPI,^DIC(4,"ANPI",XUSNPI,XUSIEN)=""
-	Q
-	;
-SIGNON	; .ACT - run at user sign-on display message if NEEDS AN NPI
-	N XVAL,DATETIME,OPT,XVALTIME
-	I $$CHEKNPI^XUSNPIED(DUZ) W !!,"To enter your NPI value enter  NPI  at a menu prompt to jump to the",!,"edit option.",! H 1
-	; following to insure CBO List is scheduled to run on first day of month
-	S XVALTIME=$E(DT,6,7) I '((XVALTIME="01")!(XVALTIME="15")) Q
-	S XVAL=+$E($$NOW^XLFDT(),6,10) I XVAL>(XVALTIME_".19"),XVAL<(XVALTIME_".1958") D  ; 7 PM TO 7:58 PM ON 1ST OF MONTH
-	. S OPT=$$FIND1^DIC(19.2,"","","XUS NPI CBO LIST") I OPT'>0 L +^TMP("XUS NPI CBO LOCK"):0 Q:'$T  D CBOQUEUE L -^TMP("XUS NPI CBO LOCK") Q
-	. S DATETIME=$$GET1^DIQ(19.2,OPT_",",2)
-	. I DATETIME'=$$FMTE^XLFDT(DT_".2") L +^DIC(19.2,OPT):0 Q:'$T  D SETQUEUE(OPT,DT_".2") L -^DIC(19.2,OPT) Q
-	. I '$$GET1^DIQ(19.2,OPT_",",99.1) L +^DIC(19.2,OPT):0 Q:'$T  D  L -^DIC(19.2,OPT)
-	. . D SETQUEUE(OPT,"@")
-	. . D SETQUEUE(OPT,DT_".2")
-	. . Q
-	. Q
-	Q
-	;
-SETQUEUE(OPT,VALUE)	;
-	N FDA S FDA(19.2,OPT_",",2)=VALUE D FILE^DIE("","FDA")
-	Q
-	;
-POSTINIT	;
-	N XUGLOB,XUUSER,XIEN,X,ZTDESC,ZTDTH,ZTIO,ZTRTN
-	;S XIEN=$$FIND1^DIC(19,"","","XUCOMMAND") I XIEN>0,$$FIND1^DIC(19.01,","_XIEN_",","","XUS NPI PROVIDER SELF ENTRY")'>0 S X=$$ADD^XPDMENU("XUCOMMAND","XUS NPI PROVIDER SELF ENTRY","NPI","")
-	;S XIEN=$$FIND1^DIC(19,"","","XU USER SIGN-ON") I XIEN>0,$$FIND1^DIC(19.01,","_XIEN_",","","XUS NPI SIGNON CHECK")'>0 S X=$$ADD^XPDMENU("XU USER SIGN-ON","XUS NPI SIGNON CHECK","","")
-	; get global containing Taxonomy values
-	S XUGLOB=$$CHKGLOB^XUSNPIED()
-	; go through file 200 and ma
-	S XUUSER=0 F  S XUUSER=$O(^VA(200,XUUSER)) Q:XUUSER'>0  I $$ACTIVE^XUSER(XUUSER) D DOUSER^XUSNPIED(XUUSER,XUGLOB)
-	; and send CBO a starting point list
-	;S ZTIO="",ZTDTH=$$NOW^XLFDT(),ZTRTN="CBOLIST^XUSNPIED",ZTDESC="XUS NPI CBOLIST MESSAGE GENERATION" D ^%ZTLOAD
-	; set up to generate CBO list monthly
-	D CBOQUEUE
-	Q
-	;
-CBOQUEUE	;
-	N FDA,XUSVAL
-	; check for already queued
-	S XUSVAL=$$FIND1^DIC(19.2,"","","XUS NPI CBO LIST") I XUSVAL>0 D  Q
-	. S FDA(19.2,XUSVAL_",",2)=$$SETDATE()
-	. S FDA(19.2,XUSVAL_",",6)="1M(1@2000,15@2000)"
-	. N ZTQUEUED S ZTQUEUED=1 D FILE^DIE("","FDA") K ZTQUEUED
-	. Q
-	; no set up queued job
-	S XUSVAL=$$FIND1^DIC(19,"","","XUS NPI CBO LIST") Q:XUSVAL'>0  S FDA(19.2,"+1,",.01)=XUSVAL
-	S FDA(19.2,"+1,",2)=$$SETDATE()
-	S FDA(19.2,"+1,",6)="1M(1@2000,15@2000)"
-	N ZTQUEUED S ZTQUEUED=1 D UPDATE^DIE("","FDA") K ZTQUEUED
-	Q
-	;
-SETDATE()	;
-	Q $S($E($$NOW^XLFDT(),6,10)<1.2:DT,$E($$NOW^XLFDT(),6,10)<15.2:$E(DT,1,5)_"15",$E(DT,4,5)>11:(($E(DT,1,3)+1)_"0101"),1:($E(DT,1,5)+1)_"01")_".2"
-	;
-CHKOLD1(IEN)	;
-	D CHKOLD1^XUSNPIE2(IEN)
-	Q
-	;
-CLERXMPT	;
-	D CLERXMPT^XUSNPIE2
-	Q
-	;
-CHKDGT(XUSNPI,XUSDA,XUSQI)	; INPUT TRANSFORM
-	N XUS S XUS=$$CHKDGT^XUSNPI(XUSNPI)
-	I XUS'>0 Q 0
-	N XUSQIK S XUSQIK=$$QI^XUSNPI(XUSNPI) I XUSQIK=0 Q 1
-	; Check whether NPI is already being used. If so, issue error or warning.
-	N NPIUSED,XUSRSLT
-	S NPIUSED=$$NPIUSED^XUSNPI1(XUSNPI,XUSQI,XUSQIK,XUSDA,.XUSRSLT,1)
-	; If an error was encountered, quit 0.
-	I NPIUSED=1 Q 0
-	; If a warning was encountered, quit 1 (Person on file 200 and 355.93 can share NPI)
-	I NPIUSED=2 Q 1
-	; If current provider previously had this NPI, make sure the NPI being added is the most
-	; current one in the EFFECTIVE DATE/TIME multiple (history).
-	N XUSROOT S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI)
-	I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT
-	N XUS1 S XUS1=XUSROOT_XUSDA_","_"""NPISTATUS"""_","_"""A"""_")"
-	N XUS2 S XUS2=$O(@XUS1,-1) I XUS2'>0 Q 1
-	S XUS1=XUSROOT_XUSDA_","_"""NPISTATUS"""_","_XUS2_","_0_")"
-	S XUS2=$G(@XUS1) I $P(XUS2,"^",3)=XUSNPI Q 1
-	Q 0
+XUSNPIE1 ;FO-OAKLAND/JLI - NATIONAL PROVIDER IDENTIFIER DATA CAPTURE ;05/02/07
+ ;;8.0;KERNEL;**420,410,435,454,462**; July 10, 1995;Build 3
+ ;
+ Q
+ ;
+SET(XUSIEN,XUSNPI) ;
+ ; set value for NPI field (#41.99) in file #200
+ N OLDNPI S OLDNPI=$P($G(^VA(200,XUSIEN,"NPI")),"^")
+ I OLDNPI K ^VA(200,"ANPI",OLDNPI,XUSIEN)
+ S ^VA(200,XUSIEN,"NPI")=XUSNPI_U_"D",^VA(200,"ANPI",XUSNPI,XUSIEN)=""
+ Q
+ ;
+SET1(XUSIEN,XUSNPI) ;
+ ; set value for NPI field (#41.99) in file #4
+ N OLDNPI S OLDNPI=$P($G(^DIC(4,XUSIEN,"NPI")),"^")
+ I OLDNPI K ^DIC(4,"ANPI",OLDNPI,XUSIEN)
+ S ^DIC(4,XUSIEN,"NPI")=XUSNPI,^DIC(4,"ANPI",XUSNPI,XUSIEN)=""
+ Q
+ ;
+SIGNON ; .ACT - run at user sign-on display message if NEEDS AN NPI
+ N XVAL,DATETIME,OPT,XVALTIME
+ I $$CHEKNPI^XUSNPIED(DUZ) W !!,"To enter your NPI value enter  NPI  at a menu prompt to jump to the",!,"edit option.",! H 1
+ ; following to insure CBO List is scheduled to run on first day of month
+ S XVALTIME=$E(DT,6,7) I '((XVALTIME="01")!(XVALTIME="15")) Q
+ S XVAL=+$E($$NOW^XLFDT(),6,10) I XVAL>(XVALTIME_".19"),XVAL<(XVALTIME_".1958") D  ; 7 PM TO 7:58 PM ON 1ST OF MONTH
+ . S OPT=$$FIND1^DIC(19.2,"","","XUS NPI CBO LIST") I OPT'>0 L +^TMP("XUS NPI CBO LOCK"):0 Q:'$T  D CBOQUEUE L -^TMP("XUS NPI CBO LOCK") Q
+ . S DATETIME=$$GET1^DIQ(19.2,OPT_",",2)
+ . I DATETIME'=$$FMTE^XLFDT(DT_".2") L +^DIC(19.2,OPT):0 Q:'$T  D SETQUEUE(OPT,DT_".2") L -^DIC(19.2,OPT) Q
+ . I '$$GET1^DIQ(19.2,OPT_",",99.1) L +^DIC(19.2,OPT):0 Q:'$T  D  L -^DIC(19.2,OPT)
+ . . D SETQUEUE(OPT,"@")
+ . . D SETQUEUE(OPT,DT_".2")
+ . . Q
+ . Q
+ Q
+ ;
+SETQUEUE(OPT,VALUE) ;
+ N FDA S FDA(19.2,OPT_",",2)=VALUE D FILE^DIE("","FDA")
+ Q
+ ;
+POSTINIT ;
+ N XUGLOB,XUUSER,XIEN,X,ZTDESC,ZTDTH,ZTIO,ZTRTN
+ ;S XIEN=$$FIND1^DIC(19,"","","XUCOMMAND") I XIEN>0,$$FIND1^DIC(19.01,","_XIEN_",","","XUS NPI PROVIDER SELF ENTRY")'>0 S X=$$ADD^XPDMENU("XUCOMMAND","XUS NPI PROVIDER SELF ENTRY","NPI","")
+ ;S XIEN=$$FIND1^DIC(19,"","","XU USER SIGN-ON") I XIEN>0,$$FIND1^DIC(19.01,","_XIEN_",","","XUS NPI SIGNON CHECK")'>0 S X=$$ADD^XPDMENU("XU USER SIGN-ON","XUS NPI SIGNON CHECK","","")
+ ; get global containing Taxonomy values
+ S XUGLOB=$$CHKGLOB^XUSNPIED()
+ ; go through file 200 and ma
+ S XUUSER=0 F  S XUUSER=$O(^VA(200,XUUSER)) Q:XUUSER'>0  I $$ACTIVE^XUSER(XUUSER) D DOUSER^XUSNPIED(XUUSER,XUGLOB)
+ ; and send CBO a starting point list
+ ;S ZTIO="",ZTDTH=$$NOW^XLFDT(),ZTRTN="CBOLIST^XUSNPIED",ZTDESC="XUS NPI CBOLIST MESSAGE GENERATION" D ^%ZTLOAD
+ ; set up to generate CBO list monthly
+ D CBOQUEUE
+ Q
+ ;
+CBOQUEUE ;
+ N FDA,XUSVAL
+ ; check for already queued
+ S XUSVAL=$$FIND1^DIC(19.2,"","","XUS NPI CBO LIST") I XUSVAL>0 D  Q
+ . S FDA(19.2,XUSVAL_",",2)=$$SETDATE()
+ . S FDA(19.2,XUSVAL_",",6)="1M(1@2000,15@2000)"
+ . N ZTQUEUED S ZTQUEUED=1 D FILE^DIE("","FDA") K ZTQUEUED
+ . Q
+ ; no set up queued job
+ S XUSVAL=$$FIND1^DIC(19,"","","XUS NPI CBO LIST") Q:XUSVAL'>0  S FDA(19.2,"+1,",.01)=XUSVAL
+ S FDA(19.2,"+1,",2)=$$SETDATE()
+ S FDA(19.2,"+1,",6)="1M(1@2000,15@2000)"
+ N ZTQUEUED S ZTQUEUED=1 D UPDATE^DIE("","FDA") K ZTQUEUED
+ Q
+ ;
+SETDATE() ;
+ Q $S($E($$NOW^XLFDT(),6,10)<1.2:DT,$E($$NOW^XLFDT(),6,10)<15.2:$E(DT,1,5)_"15",$E(DT,4,5)>11:(($E(DT,1,3)+1)_"0101"),1:($E(DT,1,5)+1)_"01")_".2"
+ ;
+EDITNPI(IEN) ; main entry of NPI value
+ ; IEN is the internal entry number in file 200 for the provider
+ ;
+ N DATEVAL,DESCRIP,DONE,NPIVAL1,NPIVAL2,PROVNAME,XX,Y,CURRNPI
+ N ODATEVAL,OIEN,OLDNPI,XUSNONED,DIR,ADDNPI,DELETNPI,NOOLDNPI,XUSQI
+ S ADDNPI=1,DELETNPI=2,NOOLDNPI=0
+ S PROVNAME=$$GET1^DIQ(200,IEN_",",.01)
+ ;I $$ACTIVE^XUSER(IEN) W !,"This user isn't currently active" Q
+ I $$GETTAXON^XUSNPIED(IEN,.DESCRIP)=-1 W !,"This user doesn't have a Taxonomy Code indicating a need for an NPI." S XUSNONED=1 ; but don't quit on that
+ I $$NPISTATS^XUSNPIED(IEN)="D" S XUSNONED=1
+ I $$NPISTATS^XUSNPIED(IEN)="E" W !,"This provider has been indicated as being EXEMPT from needing an NPI value.",!,"   Use Exempt option to remove it first" Q
+ S OLDNPI=NOOLDNPI I $$NPISTATS^XUSNPIED(IEN)="D" D  Q:OLDNPI=NOOLDNPI  ; exit without changing
+ . N I,X,DIR
+ . S CURRNPI=$$GET1^DIQ(200,IEN_",",41.99) I CURRNPI="" Q
+ . S OIEN=$$SRCHNPI^XUSNPI("^VA(200,",IEN,CURRNPI) I OIEN>0 S ODATEVAL=$P(OIEN,U,2),OIEN=$O(^VA(200,IEN,"NPISTATUS","C",CURRNPI,"A"),-1)
+ . I '$D(ODATEVAL) S OLDNPI=2 ; can't find entry in multiple, delete entry at top
+ . W !,"This provider already has an NPI value (",CURRNPI,") entered."
+ . ;S DIR(0)="Y",DIR("A")="Do you want to ADD a new NPI value as the active one",DIR("B")="NO" D ^DIR S OLDNPI=Y Q:OLDNPI
+ . ;K DIR S DIR(0)="Y",DIR("A")="Do you REALLY want to **DELETE** this NPI value",DIR("B")="NO" D ^DIR I Y S OLDNPI=2
+ . S DIR(0)="S^D:Delete;R:Replace",DIR("A")="Do you want to (D)elete or (R)eplace this NPI value?",DIR("?")="Enter either D or R or ^ to quit with out editing"
+ . S DIR("?",1)="If the value was entered for the incorrect individual, it should be Deleted.",DIR("?",2)="Otherwise it should be Replaced"
+ . D ^DIR K DIR Q:"DR"'[Y  I Y="R" S OLDNPI=ADDNPI Q
+ . S DIR(0)="S^V:VALID;E:ERROR",DIR("A",1)="Was the original NPI (V)alid for this provider",DIR("A")="or was it entered in (E)rror?",DIR("?")="Enter either V or E or ^ to quit with out editing"
+ . S DIR("?",1)="If the NPI value was entered for the incorrect individual, respond E,",DIR("?",2)="otherwise enter V"
+ . D ^DIR K DIR Q:"EV"'[Y  I Y="V" S Y=$$ADDNPI^XUSNPI("Individual_ID",IEN,CURRNPI,$$NOW^XLFDT(),0) D   S OLDNPI=NOOLDNPI Q
+ . . W !,$S(Y>-1:"Entry has been marked inactive.",1:$P(Y,U,2)),! Q:+Y=-1
+ . . N XUFDA S XUFDA(200,IEN_",",41.98)="@",XUFDA(200,IEN_",",41.99)="@" D FILE^DIE("","XUFDA") S Y=$$CHEKNPI^XUSNPIED(IEN)
+ . . Q
+ . S OLDNPI=DELETNPI
+ . Q
+ I $$CHEKNPI^XUSNPIED(IEN)=0,OLDNPI=0 W !,"Need for an NPI value isn't indicated - but you can enter an NPI",$C(7)
+ I IEN'=DUZ W !,"Provider: ",PROVNAME,"   ","XXX-XX-"_$E($$GET1^DIQ(200,IEN_",",9),6,9),"   DOB: " S XX=$P($G(^VA(200,IEN,1)),U,3) S:XX'="" XX=$$DATE10^XUSNPIED(XX) W XX
+ ;I IEN'=DUZ W !,"Status:   Active"
+ S DONE=0 I OLDNPI'=DELETNPI F  R !,"Enter NPI (10 digits): ",NPIVAL1:DTIME Q:'$T  Q:NPIVAL1=""  Q:NPIVAL1=U  D  Q:DONE
+ . I NPIVAL1'?10N D  Q
+ . . W !,$C(7),"Enter a 10 digit National Provider Identifier which is obtained ",!,"from 'https://nppes.cms.hhs.gov/NPPES/Welcome.do'"
+ . . Q:$$PROD^XUPROD()  W ! K DIR S DIR(0)="Y",DIR("A")="Do you want to generate a test NPI value" D ^DIR Q:'Y
+ . . R !,"Enter a nine (9) digit number as the base: ",Y:DTIME Q:Y'?9N
+ . . W !,"The complete NPI value is: ",Y_$$CKDIGIT^XUSNPI(Y),!
+ . . Q
+ . S XUSQI=$$QI^XUSNPI(NPIVAL1) I +XUSQI=0,$P(XUSQI,U,2)="Invalid NPI" W !,"NPI values have a specific structure to validate them...",!,"The Checksum for this entry is not valid",! Q
+ . I XUSQI'=0 N ZZ,DONE1 S DONE1=0 D GETLST^XPAR(.ZZ,"PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER") D  Q:DONE1
+ . . S ZZ="" F  S ZZ=$O(ZZ(ZZ)) Q:ZZ'>0  I $P(ZZ(ZZ),U)=$P(XUSQI,U) W !,"That NPI value is already associated with "_$P(@("^"_$P(ZZ(ZZ),U,2)_$P(XUSQI,U,2)_",0)"),U) S DONE1=1 Q
+ . . Q
+ . R !,"Please re-enter NPI  : ",NPIVAL2:DTIME Q:'$T  I NPIVAL1'=NPIVAL2 W !,"Values do not match!" Q
+ . S DONE=1
+ . Q
+ I OLDNPI=DELETNPI D
+ . I $D(ODATEVAL) D  S Y=$$CHEKNPI^XUSNPIED(IEN) Q
+ . . N DIR S DIR(0)="Y",DIR("A")="Confirm that you want to **DELETE** this incorrectly entered NPI",DIR("B")="NO" D ^DIR Q:'Y
+ . . D DELETNPI^XUSNPIE2(IEN,OIEN,ODATEVAL)
+ . . D CHKOLD1(IEN) ; check for earlier value, and activate if present
+ . . W !,"Entry was DELETED..."
+ . . Q
+ . D DELETNPI^XUSNPIE2(IEN) ; clean up where no entry in multiple
+ . W !,"Entry was DELETED..."
+ . Q
+ I 'DONE Q
+ ;N DIR S DIR("A")="Enter the date the provider was issued this number from CMS: ",DIR(0)="D^:"_$$NOW^XLFDT() D ^DIR Q:Y'>0  S DATEVAL=+Y
+ S DATEVAL=$$NOW^XLFDT()
+ ; mark previous NPI value as inactive
+ I OLDNPI=ADDNPI S DONE=$$ADDNPI^XUSNPI("Individual_ID",IEN,CURRNPI,DATEVAL,0) ; set status to INACTIVE
+ S DONE=$$ADDNPI^XUSNPI("Individual_ID",IEN,NPIVAL1,DATEVAL) I +DONE=-1 W !,"Problem writing that value into the database! --  It was **NOT** recorded.",!,$P(DONE,U,2) Q
+ W !!,"For provider ",PROVNAME," "_$S('$D(XUSNONED):"(who requires an NPI), ",1:"")_"the NPI ",NPIVAL1,!,"was saved to VistA successfully."
+ Q
+ ;
+CHKOLD1(IEN) ;
+ D CHKOLD1^XUSNPIE2(IEN)
+ Q
+ ;
+CLERXMPT ;
+ D CLERXMPT^XUSNPIE2
+ Q
+ ;
+CHKDGT(XUSNPI,XUSDA,XUSQI) ; INPUT TRANSFORM
+ N XUS S XUS=$$CHKDGT^XUSNPI(XUSNPI)
+ I XUS'>0 Q 0
+ N XUSQIK S XUSQIK=$$QI^XUSNPI(XUSNPI) I XUSQIK=0 Q 1
+ I XUSQIK'=0,$P(XUSQIK,"^",2)'=XUSDA Q 0 ; return zero if the NPI found and not bellong to the current user
+ N XUSQIK1 S XUSQIK1=$P(XUSQIK,"^")
+ I XUSQI'=XUSQIK1 Q 0
+ I $P($P(XUSQIK,"^",4),";")="Inactive" Q 0
+ N XUSROOT S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQIK1)
+ I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT
+ N XUS1 S XUS1=XUSROOT_XUSDA_","_"""NPISTATUS"""_","_"""A"""_")"
+ N XUS2 S XUS2=$O(@XUS1,-1) I XUS2'>0 Q 1
+ S XUS1=XUSROOT_XUSDA_","_"""NPISTATUS"""_","_XUS2_","_0_")"
+ S XUS2=$G(@XUS1) I $P(XUS2,"^",3)=XUSNPI Q 1
+ Q 0
Index: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIE2.m
===================================================================
--- WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIE2.m	(revision 613)
+++ WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIE2.m	(revision 623)
@@ -1,174 +1,143 @@
-XUSNPIE2	;FO-OAKLAND/JLI - DATA ENTRY FOR INITIAL NPI VALUES ;5/13/08  17:41
-	;;8.0;KERNEL;**410,435,454,462,480**;Jul 10, 1995;Build 38
-	;;Per VHA Directive 2004-038, this routine should not be modified
-	Q
-	;
-PRINTOPT	;
-	N DIR,%ZIS,ION,OPTION,PRNTFRMT,XUSDIV,XUSSORT,XUSRESO,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK
-	K IO("Q")
-	W !,"Select one of the following:",!!,?11,"1",?21,"All providers",!,?11,"2",?21,"All providers without NPI numbers",!
-	S DIR(0)="N^1:2",DIR("A")="Select a report option",DIR("B")="1" D ^DIR K DIR Q:Y'>0  S OPTION=+Y
-	S XUSRESO="" D  Q:XUSRESO=""
-	. S DIR(0)="S^P:Providers who are not residents;R:Residents only;B:Both"
-	. S DIR("B")="P",DIR("A")="Selection: "
-	. D ^DIR K DIR Q:"PRB"'[Y
-	. S XUSRESO=Y Q
-	S DIR(0)="Y",DIR("B")="NO",DIR("A")="Sort by DIVISION" D ^DIR K DIR Q:Y="^"  S XUSDIV=+Y
-	S PRNTFRMT=1
-	I XUSDIV S DIR(0)="N^1:2",DIR("A")="Output type (1=Printed text or 2=^-delimited)" D ^DIR K DIR Q:Y'>0  S PRNTFRMT=Y
-	S DIR(0)="Y",DIR("B")="YES",DIR("A")="Sort by SERVICE/SECTION"_$S(XUSDIV>0:" (as well)",1:"") D ^DIR K DIR Q:Y="^"  S XUSSORT=+Y
-	W !!,">>> Report processing time is approximately 10 minutes."
-	W !,"    Recommend text output be queued to a network printer."
-	W !
-	S %ZIS="MQ" D ^%ZIS Q:POP
-	I $D(IO("Q")) D  Q
-	. S ZTSAVE("OPTION")="",ZTSAVE("XUSSORT")="",ZTSAVE("XUSDIV")="",ZTSAVE("PRNTFRMT")="",ZTSAVE("XUSRESO")=""
-	. S ZTIO=ION,ZTRTN="DQ^XUSNPIE2",ZTDESC="NPI PRINT JOB FOR OPTION "_OPTION
-	. D ^%ZTLOAD W:$D(ZTSK) !,"Queued as Task "_ZTSK D HOME^%ZIS Q
-	;
-DQ	; entry point for queued print job
-	U IO D PRNTPROV(OPTION,XUSSORT,XUSDIV,PRNTFRMT,XUSRESO)
-	U IO D ^%ZISC
-	Q
-	;
-PRNTPROV(OPTION,XUSSORT,XUSDIV,PRNTFRMT,XUSRESO)	;
-	; PRINT PROVIDER INFO
-	;
-	; OPTION   SPECIFIES TYPE OF PRINT - 1=ALL PROVIDERS, 2=NEEDS NPI ONLY
-	; XUSSORT  INDICATES WHETHER SORTED BY SERVICE/SECTION
-	; XUSDIV   INDICATES WHETHER SORTED BY DIVISION
-	; PRNTFRMT INDICATES TYPE OF OUTPUT, PRINTED OR ^-DELIMITED
-	;
-	; ZEXCEPT: IOSL    - KERNEL VARIABLE
-	N PAGENUM,LINENUM,PROVNAME,TAXDESCR,TAXONOMY,SERVSECT,DIRUT,DTOUT
-	N GLOBLOC,IEN,NPI,DATETIME,GLOBVALU,NCOUNT,GLOBLOC1,XUSDIVNM,CNTTOTAL,CNTNONE,CNTEXMPT,CNTDONE,MULTDIV,MULTDIVC
-	S CNTTOTAL=0,CNTNONE=0,CNTEXMPT=0,CNTDONE=0
-	S PAGENUM=0,LINENUM=0
-	S DATETIME=$$NOW^XLFDT()
-	S GLOBLOC1=$$GETDATA(OPTION,XUSSORT,XUSDIV,XUSRESO)
-	I PRNTFRMT'=1 W !,"PROVIDER_NAME^LAST4^IEN^NPI^TAXONOMY_CODE^TAXONOMY DESCRIPTION"_$S(XUSDIV:"^DIVISION",1:"")_$S(XUSSORT:"^SERVICE/SECTION",1:"")
-	S GLOBLOC=GLOBLOC1,XUSDIVNM="" F  S XUSDIVNM=$O(@GLOBLOC1@(XUSDIVNM)) Q:XUSDIVNM=""  D  Q:$D(DIRUT)!$D(DTOUT)
-	. S SERVSECT="" F  S SERVSECT=$O(@GLOBLOC1@(XUSDIVNM,SERVSECT)) Q:SERVSECT=""  S GLOBLOC=$NA(@GLOBLOC1@(XUSDIVNM,SERVSECT)) D  Q:$D(DIRUT)!$D(DTOUT)
-	. . I PRNTFRMT=1 D HEADER(OPTION,DATETIME,.PAGENUM,.LINENUM,XUSDIV,XUSDIVNM,XUSSORT,SERVSECT,XUSRESO) Q:$D(DIRUT)!$D(DTOUT)
-	. . S PROVNAME="" F  S PROVNAME=$O(@GLOBLOC@(PROVNAME)) Q:PROVNAME=""  Q:$D(DIRUT)!$D(DTOUT)  S IEN=0 F  S IEN=$O(@GLOBLOC@(PROVNAME,IEN)) Q:IEN'>0  D  Q:$D(DIRUT)!$D(DTOUT)
-	. . . S NCOUNT=0
-	. . . S TAXDESCR="" F  S TAXDESCR=$O(@GLOBLOC@(PROVNAME,IEN,TAXDESCR)) Q:TAXDESCR=""  S GLOBVALU=@GLOBLOC@(PROVNAME,IEN,TAXDESCR) D
-	. . . . S NPI=$P(GLOBVALU,U,3),TAXONOMY=$P(GLOBVALU,U,4)
-	. . . . I PRNTFRMT=1 S NCOUNT=NCOUNT+1 W:NCOUNT=1 !,PROVNAME,?33,$$ALIGNRGT(IEN,11),?49,NPI W !,?6,TAXONOMY,"  ",TAXDESCR
-	. . . . I PRNTFRMT'=1 W !,PROVNAME_U_$E($$GET1^DIQ(200,IEN_",",9),6,9)_U_IEN_U_NPI_U_TAXONOMY_U_TAXDESCR_$S(XUSDIV:U_XUSDIVNM,1:"")_$S(XUSSORT:U_SERVSECT,1:"")
-	. . . . Q
-	. . . I PRNTFRMT=1 S LINENUM=LINENUM+NCOUNT+1 I LINENUM>(IOSL-4) D HEADER(OPTION,DATETIME,.PAGENUM,.LINENUM,XUSDIV,XUSDIVNM,XUSSORT,SERVSECT,XUSRESO) Q:$D(DIRUT)!$D(DTOUT)
-	. . . Q
-	. . Q
-	. Q
-	I '($D(DIRUT)!$D(DTOUT)),PRNTFRMT=1 D
-	. S PROVNAME="" I $O(@GLOBLOC@(PROVNAME))="" W !,?20,"* * * N O  D A T A  F O U N D * * *",!! I 1
-	. E  D
-	. . N TOTTYP S TOTTYP=$S(XUSRESO="R":"Residents",1:"Billable Providers")
-	. . W !!,"Total "_TOTTYP_":",?43,CNTTOTAL,!,TOTTYP_" with an NPI:",?43,CNTDONE,!,"EXEMPT "_TOTTYP_":",?43,CNTEXMPT,!,TOTTYP_" Still Needing an NPI:",?43,CNTNONE
-	. . I $G(MULTDIV)>0 W !!,MULTDIV," Providers were repeated a total of ",MULTDIVC," times",!," due to listing under multiple divisions"
-	. . Q
-	. W !!,?27,"*** End of Report ***"
-	. Q
-	Q
-	;
-HEADER(OPTION,DATETIME,PAGNOREF,LINNOREF,XUSDIV,XUSDIVNM,XUSSORT,SERVSECT,XUSRESO)	;
-	; ZEXCEPT: IOF,IOST  KERNEL IO VARIABLES
-	; ZEXCEPT: DIRUT,DTOUT  NEWED IN CALLING PRNTPROV - INDICATE QUIT TO PRNTPROV
-	N TEMPVAL,DIR,X,Y
-	S PAGNOREF=PAGNOREF+1
-	; Don't page feed on the first page
-	IF PAGNOREF>1 I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR I 'Y S DIRUT=1 Q
-	IF PAGNOREF>1 W @IOF
-	W:$E(IOST,1,2)'="C-" !
-	W "Active Provider Report ("_$S(XUSRESO="P":"no residents)",XUSRESO="R":"residents only)",1:"includes residents)")
-	W ?48,$$FMTE^XLFDT(DATETIME),"  Page: ",PAGNOREF
-	W !," Report Option: Provider List       Active Providers",$S(OPTION=2:" Without NPI Numbers",1:"")
-	W !!,"Provider Name",?39,"IEN",?49,$S(OPTION'=2:"NPI",1:"")
-	W !,"      Taxonomy"
-	W !,"--------------------------------------------------------------------------------"
-	S LINNOREF=6
-	I XUSDIV W !,"DIVISION: ",XUSDIVNM,"   " S LINNOREF=LINNOREF+1
-	I XUSSORT W:'XUSDIV ! W "SERVICE/SECTION: ",SERVSECT S:'XUSDIV LINNOREF=LINNOREF+1
-	Q
-	;
-GETDATA(OPTION,XUSSORT,XUSDIV,XUSRESO)	; get data for reports for providers
-	N NPI,PROVNAME,TAXDESCR,TAXONOMY,XUSDEFLT,XUSDIVCN,XUSDIVN,XUSDIVNM,XUSGLOB,XUSACTV,XUSSKIP
-	N XUSIEN,XUSSERVC,XUSVAL,CNTCLEAN,X
-	S XUSRESO=$G(XUSRESO)
-	; ZEXCEPT: CNTTOTAL,CNTNONE,CNTEXMPT,CNTDONE - NEWed and initialized in PRNTPROV or killed based on CNTCLEAN
-	S CNTCLEAN=0 I '$D(CNTTOTAL) S CNTCLEAN=1
-	S XUSGLOB=$NA(^TMP($J,"XUSNPIPRNT")) K @XUSGLOB
-	I 'XUSDIV S XUSDIVNM(1)=" ",XUSDEFLT=" "
-	I XUSDIV S XUSDEFLT=$$NS^XUAF4($$KSP^XUPARAM("INST")),XUSDEFLT=$P(XUSDEFLT,U)
-	I 'XUSSORT S XUSSERVC=" "
-	F XUSIEN=0:0 S XUSIEN=$O(^VA(200,XUSIEN)) Q:XUSIEN'>0  D
-	. ; Don't report TERMINATED or DISUSERed users
-	. S XUSACTV=$$ACTIVE^XUSER(XUSIEN)
-	. I XUSACTV=""!($P(XUSACTV,U)=0) Q
-	. ; Don't report users with null NPI ENTRY STATUS
-	. S XUSVAL=$$CHEKNPI^XUSNPIED(XUSIEN),XUSVAL=$$NPISTATS^XUSNPIED(XUSIEN)
-	. Q:XUSVAL=""
-	. S PROVNAME=$$GET1^DIQ(200,XUSIEN_",",.01),NPI=$$GETNPI^XUSNPIED(XUSIEN),TAXONOMY=$$GETTAXON^XUSNPIED(XUSIEN,.TAXDESCR) I TAXONOMY=-1 S TAXONOMY=" ",TAXDESCR=" "
-	. ; Determine whether provider is a resident for local reports.
-	. I OPTION'=3,XUSRESO'="B" S XUSSKIP=0 D  Q:XUSSKIP
-	. . I XUSRESO="R",TAXONOMY'="390200000X" S XUSSKIP=1 Q
-	. . I XUSRESO="P",TAXONOMY="390200000X" S XUSSKIP=1
-	. . Q
-	. I NPI="",$$EXMPTNPI^XUSNPIED(XUSIEN) S NPI="EXEMPTED  "
-	. S CNTTOTAL=$G(CNTTOTAL)+1 S:NPI="" CNTNONE=$G(CNTNONE)+1 S:NPI="EXEMPTED  " CNTEXMPT=$G(CNTEXMPT)+1 S:NPI?10N CNTDONE=$G(CNTDONE)+1
-	. I '((XUSVAL="N")!(OPTION'=2)) Q
-	. I XUSSORT S XUSSERVC=$$GET1^DIQ(200,XUSIEN_",",29) I XUSSERVC="" S XUSSERVC=" "
-	. I XUSDIV D
-	. . K XUSDIVNM S XUSDIVCN=0,XUSDIVNM(1)=XUSDEFLT
-	. . F XUSDIVN=0:0 S XUSDIVN=$O(^VA(200,XUSIEN,2,XUSDIVN)) Q:XUSDIVN'>0  S XUSDIVCN=XUSDIVCN+1,XUSDIVNM(XUSDIVCN)=$$GET1^DIQ(200.02,XUSDIVN_","_XUSIEN_",",.01)
-	. . I XUSDIVCN>1 S MULTDIV=$G(MULTDIV)+1,MULTDIVC=$G(MULTDIVC)+XUSDIVCN-1
-	. . Q
-	. F XUSDIVN=0:0 S XUSDIVN=$O(XUSDIVNM(XUSDIVN)) Q:XUSDIVN'>0  D
-	. . S X=PROVNAME_U_XUSIEN_U_NPI_U_TAXONOMY_U_TAXDESCR
-	. . S @XUSGLOB@(XUSDIVNM(XUSDIVN),XUSSERVC,PROVNAME,XUSIEN,TAXDESCR)=X
-	. . Q 
-	. Q
-	I CNTCLEAN K CNTTOTAL,CNTNONE,CNTEXMPT,CNTDONE
-	Q XUSGLOB
-	;
-ALIGNRGT(TEXT,WIDTH)	; align text right in a specified width
-	N RESULT
-	S $P(RESULT," ",WIDTH)=" ",RESULT=RESULT_TEXT,RESULT=$E(RESULT,$L(RESULT)-WIDTH+1,$L(RESULT))
-	Q RESULT
-	;
-CHKOLD1(IEN)	; check for earlier value, and activate if present
-	N IEN1,STATUS,NPI,DATE,XUFDA
-	S IEN1=$O(^VA(200,IEN,"NPISTATUS"," "),-1) I IEN1>0 D  I STATUS=0 D CHKOLD1(IEN)
-	. S STATUS=^VA(200,IEN,"NPISTATUS",IEN1,0),NPI=$P(STATUS,U,3),DATE=$P(STATUS,U),STATUS=$P(STATUS,U,2)
-	. I STATUS=0 D DELETNPI(IEN,IEN1,DATE) Q  ; entry making it INACTIVE - remove it
-	. I STATUS=1 D SET^XUSNPIE1(IEN,NPI)
-	. Q
-	Q
-	;
-DELETNPI(IEN,OIEN,ODATEVAL)	;
-	N XUFDA
-	I $D(ODATEVAL) S XUFDA(200.042,OIEN_","_IEN_",",.01)="@" D FILE^DIE("","XUFDA")
-	I $O(^VA(200,IEN,"NPISTATUS",0))>0 Q
-	N XUFDA
-	I $$GET1^DIQ(200,IEN_",",41.99) S XUFDA(200,IEN_",",41.99)="@"
-	I $$GET1^DIQ(200,IEN_",",41.98)'="" S XUFDA(200,IEN_",",41.98)="@"
-	I $D(XUFDA) D FILE^DIE("","XUFDA")
-	Q
-	;
-CLERXMPT	; edit entry indicating whether a provider is exempt from needing an NPI
-	N DIC,DIR,FDA,IEN,Y
-	W ! S DIC="^VA(200,",DIC(0)="AEQ" S DIC("A")="select Provider: " D ^DIC Q:Y'>0  S IEN=+Y
-	I $$HASNPI^XUSNPIED(IEN) W !,"This Provider already has an NPI value.  Nothing to do." Q
-	I '$$CHEKNPI^XUSNPIED(IEN),'$$EXMPTNPI^XUSNPIED(IEN) W !,"This Provider does not appear to need an NPI or Exemption." Q
-	I $$EXMPTNPI^XUSNPIED(IEN) D  Q  ; currently marked as Exempt
-	. S DIR(0)="Y",DIR("A")="Provider is currently EXEMPT from needing an NPI, set to NEEDS an NPI (Y/N)" D ^DIR I 'Y Q
-	. S FDA(200,IEN_",",41.98)="N" D FILE^DIE("","FDA")
-	. W !,$S($$NEEDSNPI^XUSNPIED(IEN):"File updated",1:"Ecountered a problem updating file, status NOT set to NEEDS an NPI")
-	. Q
-	; check to make sure provider should be exempt
-	S DIR(0)="Y",DIR("A")="Confirm that Provider should be Exempt from needing an NPI (Y/N)" D ^DIR I 'Y Q
-	; and update file to show as exempt
-	S FDA(200,IEN_",",41.98)="E" D FILE^DIE("","FDA")
-	W !,$S($$EXMPTNPI^XUSNPIED(IEN):"File updated",1:"Ecountered a problem updating file, status NOT set to EXEMPT")
-	Q
+XUSNPIE2 ;FO-OAKLAND/JLI - DATA ENTRY FOR INITIAL NPI VALUES ;06/06/07
+ ;;8.0;KERNEL;**410,435,454,462**;Jul 10, 1995;Build 3
+ Q
+ ;
+PRINTOPT ;
+ N DIR,%ZIS,ION,OPTION,PRNTFRMT,XUSDIV,XUSSORT,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK
+ K IO("Q")
+ W !,"Select one of the following:",!!,?11,"1",?21,"All providers",!,?11,"2",?21,"All providers without NPI numbers",!
+ S DIR(0)="N^1:2",DIR("A")="Select a report option",DIR("B")="1" D ^DIR K DIR Q:Y'>0  S OPTION=+Y
+ S DIR(0)="Y",DIR("B")="NO",DIR("A")="Sort by DIVISION" D ^DIR K DIR Q:Y="^"  S XUSDIV=+Y
+ S PRNTFRMT=1
+ I XUSDIV S DIR(0)="N^1:2",DIR("A")="Output type (1=Printed text or 2=^-delimited)" D ^DIR K DIR Q:Y'>0  S PRNTFRMT=Y
+ S DIR(0)="Y",DIR("B")="YES",DIR("A")="Sort by SERVICE/SECTION"_$S(XUSDIV>0:" (as well)",1:"") D ^DIR K DIR Q:Y="^"  S XUSSORT=+Y
+ W !!,">>> Report processing time is approximately 10 minutes."
+ W !,"    Recommend text output be queued to a network printer."
+ W !
+ S %ZIS="MQ" D ^%ZIS Q:POP
+ I $D(IO("Q")) S ZTSAVE("OPTION")="",ZTSAVE("XUSSORT")="",ZTSAVE("XUSDIV")="",ZTSAVE("PRNTFRMT")="",ZTIO=ION,ZTRTN="DQ^XUSNPIE2",ZTDESC="NPI PRINT JOB FOR OPTION "_OPTION D ^%ZTLOAD W:$D(ZTSK) !,"Queued as Task "_ZTSK D HOME^%ZIS Q
+ ;
+DQ ; entry point for queued print job
+ U IO D PRNTPROV(OPTION,XUSSORT,XUSDIV,PRNTFRMT)
+ U IO D ^%ZISC
+ Q
+ ;
+PRNTPROV(OPTION,XUSSORT,XUSDIV,PRNTFRMT) ;
+ ; PRINT PROVIDER INFO
+ ;
+ ; OPTION   SPECIFIES TYPE OF PRINT - 1=ALL PROVIDERS, 2=NEEDS NPI ONLY
+ ; XUSSORT  INDICATES WHETHER SORTED BY SERVICE/SECTION
+ ; XUSDIV   INDICATES WHETHER SORTED BY DIVISION
+ ; PRNTFRMT INDICATES TYPE OF OUTPUT, PRINTED OR ^-DELIMITED
+ ;
+ ; ZEXCEPT: IOSL    - KERNEL VARIABLE
+ N PAGENUM,LINENUM,PROVNAME,TAXDESCR,TAXONOMY,SERVSECT,DIRUT,DTOUT
+ N GLOBLOC,IEN,NPI,DATETIME,GLOBVALU,NCOUNT,GLOBLOC1,XUSDIVNM,CNTTOTAL,CNTNONE,CNTEXMPT,CNTDONE,MULTDIV,MULTDIVC
+ S CNTTOTAL=0,CNTNONE=0,CNTEXMPT=0,CNTDONE=0
+ S PAGENUM=0,LINENUM=0
+ S DATETIME=$$NOW^XLFDT()
+ S GLOBLOC1=$$GETDATA(OPTION,XUSSORT,XUSDIV)
+ I PRNTFRMT'=1 W !,"PROVIDER_NAME^LAST4^IEN^NPI^TAXONOMY_CODE^TAXONOMY DESCRIPTION"_$S(XUSDIV:"^DIVISION",1:"")_$S(XUSSORT:"^SERVICE/SECTION",1:"")
+ S GLOBLOC=GLOBLOC1,XUSDIVNM="" F  S XUSDIVNM=$O(@GLOBLOC1@(XUSDIVNM)) Q:XUSDIVNM=""  D  Q:$D(DIRUT)!$D(DTOUT)
+ . S SERVSECT="" F  S SERVSECT=$O(@GLOBLOC1@(XUSDIVNM,SERVSECT)) Q:SERVSECT=""  S GLOBLOC=$NA(@GLOBLOC1@(XUSDIVNM,SERVSECT)) D  Q:$D(DIRUT)!$D(DTOUT)
+ . . I PRNTFRMT=1 D HEADER(OPTION,DATETIME,.PAGENUM,.LINENUM,XUSDIV,XUSDIVNM,XUSSORT,SERVSECT) Q:$D(DIRUT)!$D(DTOUT)
+ . . S PROVNAME="" F  S PROVNAME=$O(@GLOBLOC@(PROVNAME)) Q:PROVNAME=""  Q:$D(DIRUT)!$D(DTOUT)  S IEN=0 F  S IEN=$O(@GLOBLOC@(PROVNAME,IEN)) Q:IEN'>0  D  Q:$D(DIRUT)!$D(DTOUT)
+ . . . S NCOUNT=0
+ . . . S TAXDESCR="" F  S TAXDESCR=$O(@GLOBLOC@(PROVNAME,IEN,TAXDESCR)) Q:TAXDESCR=""  S GLOBVALU=@GLOBLOC@(PROVNAME,IEN,TAXDESCR) D
+ . . . . S NPI=$P(GLOBVALU,U,3),TAXONOMY=$P(GLOBVALU,U,4)  I PRNTFRMT=1 S NCOUNT=NCOUNT+1 W:NCOUNT=1 !,PROVNAME,?33,$$ALIGNRGT(IEN,11),?49,NPI W !,?6,TAXONOMY,"  ",TAXDESCR
+ . . . . I PRNTFRMT'=1 W !,PROVNAME_U_$E($$GET1^DIQ(200,IEN_",",9),6,9)_U_IEN_U_NPI_U_TAXONOMY_U_TAXDESCR_$S(XUSDIV:U_XUSDIVNM,1:"")_$S(XUSSORT:U_SERVSECT,1:"")
+ . . . . Q
+ . . . I PRNTFRMT=1 S LINENUM=LINENUM+NCOUNT+1 I LINENUM>(IOSL-4) D HEADER(OPTION,DATETIME,.PAGENUM,.LINENUM,XUSDIV,XUSDIVNM,XUSSORT,SERVSECT) Q:$D(DIRUT)!$D(DTOUT)
+ . . . Q
+ . . Q
+ . Q
+ I '($D(DIRUT)!$D(DTOUT)),PRNTFRMT=1 D
+ . S PROVNAME="" I $O(@GLOBLOC@(PROVNAME))="" W !,?20,"* * * N O  D A T A  F O U N D * * *",!! I 1
+ . E  D
+ . . W !!,"Total Billable Providers:",?43,CNTTOTAL,!,"Billable Providers with an NPI:",?43,CNTDONE,!,"EXEMPT Billable Providers:",?43,CNTEXMPT,!,"Billable Providers Still Needing an NPI:",?43,CNTNONE
+ . . I $G(MULTDIV)>0 W !!,MULTDIV," Providers were repeated a total of ",MULTDIVC," times",!," due to listing under multiple divisions"
+ . . Q
+ . W !!,?27,"*** End of Report ***"
+ . Q
+ Q
+ ;
+HEADER(OPTION,DATETIME,PAGNOREF,LINNOREF,XUSDIV,XUSDIVNM,XUSSORT,SERVSECT) ;
+ ; ZEXCEPT: IOF,IOST  KERNEL IO VARIABLES
+ ; ZEXCEPT: DIRUT,DTOUT  NEWED IN CALLING PRNTPROV - INDICATE QUIT TO PRNTPROV
+ N TEMPVAL,DIR,X,Y
+ S PAGNOREF=PAGNOREF+1
+ ; Don't page feed on the first page
+ IF PAGNOREF>1 I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR I 'Y S DIRUT=1 Q
+ IF PAGNOREF>1 W @IOF
+ W:$E(IOST,1,2)'="C-" ! W "Active Provider Report",?48,$$FMTE^XLFDT(DATETIME),"  Page: ",PAGNOREF
+ W !," Report Option: Provider List       Active Providers",$S(OPTION=2:" Without NPI Numbers",1:"")
+ W !!,"Provider Name",?39,"IEN",?49,$S(OPTION'=2:"NPI",1:"")
+ W !,"      Taxonomy"
+ W !,"--------------------------------------------------------------------------------"
+ S LINNOREF=6
+ I XUSDIV W !,"DIVISION: ",XUSDIVNM,"   " S LINNOREF=LINNOREF+1
+ I XUSSORT W:'XUSDIV ! W "SERVICE/SECTION: ",SERVSECT S:'XUSDIV LINNOREF=LINNOREF+1
+ Q
+ ;
+GETDATA(OPTION,XUSSORT,XUSDIV) ; get data for reports for providers
+ N NPI,PROVNAME,TAXDESCR,TAXONOMY,XUSDEFLT,XUSDIVCN,XUSDIVN,XUSDIVNM,XUSGLOB
+ N XUSIEN,XUSSERVC,XUSVAL,CNTCLEAN
+ ; ZEXCEPT: CNTTOTAL,CNTNONE,CNTEXMPT,CNTDONE - NEWed and initialized in PRNTPROV or killed based on CNTCLEAN
+ S CNTCLEAN=0 I '$D(CNTTOTAL) S CNTCLEAN=1
+ S XUSGLOB=$NA(^TMP($J,"XUSNPIPRNT")) K @XUSGLOB
+ I 'XUSDIV S XUSDIVNM(1)=" ",XUSDEFLT=" "
+ I XUSDIV S XUSDEFLT=$$NS^XUAF4($$KSP^XUPARAM("INST")),XUSDEFLT=$P(XUSDEFLT,U)
+ I 'XUSSORT S XUSSERVC=" "
+ F XUSIEN=0:0 S XUSIEN=$O(^VA(200,XUSIEN)) Q:XUSIEN'>0  I ($$ACTIVE^XUSER(XUSIEN)'=""),($P($$ACTIVE^XUSER(XUSIEN),"^",2)'="TERMINATED") S XUSVAL=$$CHEKNPI^XUSNPIED(XUSIEN),XUSVAL=$$NPISTATS^XUSNPIED(XUSIEN) I XUSVAL'="" D
+ . S PROVNAME=$$GET1^DIQ(200,XUSIEN_",",.01),NPI=$$GETNPI^XUSNPIED(XUSIEN),TAXONOMY=$$GETTAXON^XUSNPIED(XUSIEN,.TAXDESCR) I TAXONOMY=-1 S TAXONOMY=" ",TAXDESCR=" "
+ . I NPI="",$$EXMPTNPI^XUSNPIED(XUSIEN) S NPI="EXEMPTED  "
+ . S CNTTOTAL=$G(CNTTOTAL)+1 S:NPI="" CNTNONE=$G(CNTNONE)+1 S:NPI="EXEMPTED  " CNTEXMPT=$G(CNTEXMPT)+1 S:NPI?10N CNTDONE=$G(CNTDONE)+1
+ . I '((XUSVAL="N")!(OPTION'=2)) Q
+ . I XUSSORT S XUSSERVC=$$GET1^DIQ(200,XUSIEN_",",29) I XUSSERVC="" S XUSSERVC=" "
+ . I XUSDIV D
+ . . K XUSDIVNM S XUSDIVCN=0,XUSDIVNM(1)=XUSDEFLT
+ . . F XUSDIVN=0:0 S XUSDIVN=$O(^VA(200,XUSIEN,2,XUSDIVN)) Q:XUSDIVN'>0  S XUSDIVCN=XUSDIVCN+1,XUSDIVNM(XUSDIVCN)=$$GET1^DIQ(200.02,XUSDIVN_","_XUSIEN_",",.01)
+ . . I XUSDIVCN>1 S MULTDIV=$G(MULTDIV)+1,MULTDIVC=$G(MULTDIVC)+XUSDIVCN-1
+ . . Q
+ . F XUSDIVN=0:0 S XUSDIVN=$O(XUSDIVNM(XUSDIVN)) Q:XUSDIVN'>0  S @XUSGLOB@(XUSDIVNM(XUSDIVN),XUSSERVC,PROVNAME,XUSIEN,TAXDESCR)=PROVNAME_U_XUSIEN_U_NPI_U_TAXONOMY_U_TAXDESCR
+ . Q
+ I CNTCLEAN K CNTTOTAL,CNTNONE,CNTEXMPT,CNTDONE
+ Q XUSGLOB
+ ;
+ALIGNRGT(TEXT,WIDTH) ; align text right in a specified width
+ N RESULT
+ S $P(RESULT," ",WIDTH)=" ",RESULT=RESULT_TEXT,RESULT=$E(RESULT,$L(RESULT)-WIDTH+1,$L(RESULT))
+ Q RESULT
+ ;
+CHKOLD1(IEN) ; check for earlier value, and activate if present
+ N IEN1,STATUS,NPI,DATE,XUFDA
+ S IEN1=$O(^VA(200,IEN,"NPISTATUS"," "),-1) I IEN1>0 D  I STATUS=0 D CHKOLD1(IEN)
+ . S STATUS=^VA(200,IEN,"NPISTATUS",IEN1,0),NPI=$P(STATUS,U,3),DATE=$P(STATUS,U),STATUS=$P(STATUS,U,2)
+ . I STATUS=0 D DELETNPI(IEN,IEN1,DATE) Q  ; entry making it INACTIVE - remove it
+ . I STATUS=1 D SET^XUSNPIE1(IEN,NPI)
+ . Q
+ Q
+ ;
+DELETNPI(IEN,OIEN,ODATEVAL) ;
+ N XUFDA
+ I $D(ODATEVAL) S XUFDA(200.042,OIEN_","_IEN_",",.01)="@"
+ S XUFDA(200,IEN_",",41.99)="@",XUFDA(200,IEN_",",41.98)="@"
+ D FILE^DIE("","XUFDA")
+ Q
+ ;
+CLERXMPT ; edit entry indicating whether a provider is exempt from needing an NPI
+ N DIC,DIR,FDA,IEN,Y
+ W ! S DIC="^VA(200,",DIC(0)="AEQ" S DIC("A")="select Provider: " D ^DIC Q:Y'>0  S IEN=+Y
+ I $$HASNPI^XUSNPIED(IEN) W !,"This Provider already has an NPI value.  Nothing to do." Q
+ I '$$CHEKNPI^XUSNPIED(IEN),'$$EXMPTNPI^XUSNPIED(IEN) W !,"This Provider does not appear to need an NPI or Exemption." Q
+ I $$EXMPTNPI^XUSNPIED(IEN) D  Q  ; currently marked as Exempt
+ . S DIR(0)="Y",DIR("A")="Provider is currently EXEMPT from needing an NPI, set to NEEDS an NPI (Y/N)" D ^DIR I 'Y Q
+ . S FDA(200,IEN_",",41.98)="N" D FILE^DIE("","FDA")
+ . W !,$S($$NEEDSNPI^XUSNPIED(IEN):"File updated",1:"Ecountered a problem updating file, status NOT set to NEEDS an NPI")
+ . Q
+ ; check to make sure provider should be exempt
+ S DIR(0)="Y",DIR("A")="Confirm that Provider should be Exempt from needing an NPI (Y/N)" D ^DIR I 'Y Q
+ ; and update file to show as exempt
+ S FDA(200,IEN_",",41.98)="E" D FILE^DIE("","FDA")
+ W !,$S($$EXMPTNPI^XUSNPIED(IEN):"File updated",1:"Ecountered a problem updating file, status NOT set to EXEMPT")
+ Q
Index: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIED.m
===================================================================
--- WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIED.m	(revision 613)
+++ WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIED.m	(revision 623)
@@ -1,135 +1,128 @@
-XUSNPIED	;FO-OAKLAND/JLI - DATA ENTRY FOR INITIAL NPI VALUES ;6/3/08  17:19
-	;;8.0;KERNEL;**420,410,435,480**;Jul 10, 1995;Build 38
-	;;Per VHA Directive 2004-038, this routine should not be modified
-	Q
-	;
-SIGNON	; run at user sign-on to display message if NPI value is needed.
-	D SIGNON^XUSNPIE1
-	Q
-	;
-CLEREDIT	; Input editing of NPI value for clerical staff - ask provider
-	N IEN,DIC,PROVNAME,DATEVAL,DESCRIP,DONE,IENS,NPIVAL1,NPIVAL2,Y,XX
-	F  W ! S DIC="^VA(200,",DIC(0)="AEQ" S DIC("A")="Select Provider: " D ^DIC Q:Y'>0  S IEN=+Y D EDITNPI(IEN)
-	Q
-	;
-USEREDIT	; Entry point for provider to enter own data
-	I $$NPISTATS(DUZ)="" W !,$C(7),"Please see your local NPI facilitator to add the NPI",! H 3 Q
-	D EDITNPI(DUZ)
-	Q
-	;
-EDITNPI(IEN)	;
-	D EDITNPI^XUSNPIE3(IEN)
-	Q
-	;
-EDRLNPI(IEN)	; Edit AUTHORIZES RELEASE OF NPI field
-	; NOTE: *** This field is no longer being used, and should always be set to YES 05/13/08 tkw***
-	Q:$P($G(^VA(200,+$G(IEN),"NPI")),U,3)=1
-	N DIE,DR,DA S DIE="^VA(200,",DA=IEN,DR="41.97////1" D ^DIE
-	Q
-	; 
-CLERXMPT	;
-	D CLERXMPT^XUSNPIE1
-	Q
-	;
-CHKGLOB()	; returns global location of TAXONOMY values also rebuilds if they are missing
-	Q $$CHKGLOB^XUSNPIDA()
-	;
-DOUSER(XUUSER,XUGLOB)	; check user for needing an NPI status value
-	N PCLASS,XUDONE,PVAL,CODE,NPISTATS,XUVALUE,D0,EXPIRATN,I,NPIFLD,NPISUBFL
-	S NPISTATS=41.98,NPISUBFL=200.042,NPIFLD=.03
-	I $$GET1^DIQ(200,XUUSER_",",NPISTATS)'="" Q  ; user is already flagged
-	S PCLASS=0,XUDONE=0 F  S PCLASS=$O(^VA(200,XUUSER,"USC1",PCLASS)) Q:PCLASS'>0  S D0=^(PCLASS,0) D  Q:XUDONE
-	. S EXPIRATN=$P(D0,U,3)>0 I EXPIRATN Q
-	. S PVAL=$P(D0,U),CODE=$$GET1^DIQ(8932.1,PVAL_",",6) I CODE'="",$D(@XUGLOB@(CODE)) D  S XUDONE=1 Q
-	. . S XUVALUE="N" N NPIVAL F I=1:1 S NPIVAL=$$GET1^DIQ(NPISUBFL,I_","_XUUSER_",",NPIFLD) Q:NPIVAL=""  S XUVALUE="D" Q
-	. . N XUFDA S XUFDA(200,XUUSER_",",NPISTATS)=XUVALUE
-	. . D FILE^DIE("","XUFDA")
-	. . Q
-	. Q
-	Q
-	;
-CBOLIST	; list ^ delimited output to CBO exchange mail group.
-	N DATE,DOMAIN,ADDRESS,STATNAME,COUNT,GLOBLOC,GLOBOUT
-	N IEN,NPI,PROVNAME,TAXDESCR,TAXONOMY,STATION,STATUS,OPTION
-	I '$$PROD^XUPROD() Q  ; messages from production systems only
-	S DATE=(1700+$E(DT,1,3))_"-"_$E(DT,4,5)_"-"_$E(DT,6,7)
-	S DOMAIN=$G(^XTV(8989.3,1,0)),DOMAIN=$P(DOMAIN,U)
-	S STATION=$$NS^XUAF4($$KSP^XUPARAM("INST"))
-	S ADDRESS=$P(STATION,U) ;$$GET1^DIQ(4.2,DOMAIN_",",.01)
-	S STATION=$P(STATION,U,2) ;$$GET1^DIQ(4.2,DOMAIN_",",5.5)
-	S OPTION=3
-	S GLOBLOC=$$GETDATA(OPTION,0,0) ; get most of data into location specified by GLOBLOC
-	S COUNT=0,GLOBOUT=$NA(^TMP($J,"XUSNPIOUT")) K @GLOBOUT
-	S COUNT=1,@GLOBOUT@(COUNT)="--START"
-	S GLOBLOC=$NA(@GLOBLOC@(" "," "))
-	S PROVNAME="" F  S PROVNAME=$O(@GLOBLOC@(PROVNAME)) Q:PROVNAME=""  S IEN=0 F  S IEN=$O(@GLOBLOC@(PROVNAME,IEN)) Q:IEN'>0  D
-	. S TAXDESCR="" F  S TAXDESCR=$O(@GLOBLOC@(PROVNAME,IEN,TAXDESCR)) Q:TAXDESCR=""  S TAXONOMY=$P(^(TAXDESCR),U,4),NPI=$P(^(TAXDESCR),U,3) D
-	. . S STATUS=$$NPISTATS(IEN)
-	. . S COUNT=COUNT+1,@GLOBOUT@(COUNT)=PROVNAME_U_STATION_U_NPI_U_TAXONOMY_U_TAXDESCR_U_DATE_U_STATUS
-	. . Q
-	. Q
-	S COUNT=COUNT+1,@GLOBOUT@(COUNT)="--END"
-	; and generate mail message
-	N XMTEXT,XMDUZ,XMY,XMSUB
-	S XMTEXT=$E(GLOBOUT,1,$L(GLOBOUT)-1)_",",XMDUZ=0.5,XMY("VHACONPINPF@VA.GOV")=""
-	S XMSUB="NPI LIST "_DATE_" FOR "_ADDRESS_" ("_STATION_")"
-	D ^XMD
-	Q
-	;
-PRINTOPT	;
-	D PRINTOPT^XUSNPIE2
-	Q
-GETDATA(OPTION,XUSSORT,XUSDIV)	; get data for reports for providers
-	Q $$GETDATA^XUSNPIE2(OPTION,XUSSORT,XUSDIV)
-	;
-CHEKNPI(IEN)	; returns whether status is Needs, will check and update if not set
-	N VALUE,FDA
-	S VALUE=$E($$GET1^DIQ(200,IEN_",",41.98))
-	I VALUE="N" S FDA(200,IEN_",",41.98)="" D FILE^DIE("","FDA") S VALUE="" ; XU*8*435 JLI
-	I VALUE="",$$CHKTAXON(IEN) K FDA S FDA(200,IEN_",",41.98)="N" D FILE^DIE("","FDA") S VALUE="N"
-	Q VALUE="N"
-	;
-NEEDSNPI(IEN)	; returns whether current status is N
-	Q $$NPISTATS(IEN)="N"
-	;
-HASNPI(IEN)	; returns whether current status is D (Done)
-	Q $$NPISTATS(IEN)="D"
-	;
-EXMPTNPI(IEN)	; returns whether current status is E (Exempt)
-	Q $$NPISTATS(IEN)="E"
-	;
-NPISTATS(IEN)	; returns one letter status indicator
-	N VAL
-	S VAL=$E($$GET1^DIQ(200,IEN_",",41.98))
-	I (VAL="")!(VAL="N") S VAL=$$CHEKNPI(IEN)
-	Q $E($$GET1^DIQ(200,IEN_",",41.98))
-	;
-GETNPI(IEN)	; returns current NPI value
-	Q $$GET1^DIQ(200,IEN_",",41.99)
-	;
-GETTAXON(IEN,DESCRREF)	; returns Taxonomy value (X12) and sets description in DESCRREF, otherwise -1
-	N I,POINTER,TAXON
-	S TAXON=-1,DESCRREF=" "
-	;F I=0:0 S I=$O(^VA(200,IEN,"USC1",I)) Q:I'>0  I $P(^(I,0),U,3)'>0 S POINTER=+^(0) S TAXON=$$GET1^DIQ(8932.1,POINTER_",",6),DESCRREF=$$GET1^DIQ(8932.1,POINTER_",",1) Q
-	S POINTER=+$$GET^XUA4A72(IEN) I POINTER>0 S TAXON=$$GET1^DIQ(8932.1,POINTER_",",6),DESCRREF=$$GET1^DIQ(8932.1,POINTER_",",1) ; XU*8*435 make sure active on today
-	I TAXON="" S TAXON=-1,DESCRREF=" "
-	Q TAXON
-	;
-CHKTAXON(IEN,TAXONOMY)	; checks whether taxonomy value (X12) is in list of billable otherwise 0-1
-	N DESCRIP,XUSGLOB
-	I $G(TAXONOMY)="" S TAXONOMY=$$GETTAXON(IEN,.DESCRIP)
-	S XUSGLOB=$$CHKGLOB()
-	Q $D(@XUSGLOB@(TAXONOMY))
-	;
-DATE10(DATE)	; returns date in mm/dd/yyyyy format
-	Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_(1700+$E(DATE,1,3))
-	;
-POSTINIT	; runs post init
-	D POSTINIT^XUSNPIE1
-	Q
-	;
-CBOQUEUE	; queues CBO List to run on first day of month
-	D CBOQUEUE^XUSNPIE1
-	Q
-ALIGNRGT(TEXT,WIDTH)	; align text right in a specified width
-	Q $$ALIGNRGT^XUSNPIE2(TEXT,WIDTH)
+XUSNPIED ;FO-OAKLAND/JLI - DATA ENTRY FOR INITIAL NPI VALUES ;11/20/06  11:20
+ ;;8.0;KERNEL;**420,410,435**;Jul 10, 1995;Build 10
+ Q
+ ;
+SIGNON ; run at user sign-on to display message if NPI value is needed.
+ D SIGNON^XUSNPIE1
+ Q
+ ;
+CLEREDIT ; Input editing of NPI value for clerical staff - ask provider
+ N IEN,DIC,PROVNAME,DATEVAL,DESCRIP,DONE,IENS,NPIVAL1,NPIVAL2,Y,XX
+ F  W ! S DIC="^VA(200,",DIC(0)="AEQ" S DIC("A")="Select Provider: " D ^DIC Q:Y'>0  S IEN=+Y D EDITNPI(IEN)
+ Q
+ ;
+USEREDIT ; Entry point for provider to enter own data
+ I $$NPISTATS(DUZ)="" W !,$C(7),"Please see your local NPI facilitator to add the NPI",! H 3 Q
+ D EDITNPI(DUZ)
+ Q
+ ;
+EDITNPI(IEN) ;
+ D EDITNPI^XUSNPIE1(IEN)
+ Q
+ ;
+CLERXMPT ;
+ D CLERXMPT^XUSNPIE1
+ Q
+ ;
+CHKGLOB() ; returns global location of TAXONOMY values also rebuilds if they are missing
+ Q $$CHKGLOB^XUSNPIDA()
+ ;
+DOUSER(XUUSER,XUGLOB) ; check user for needing an NPI status value
+ N PCLASS,XUDONE,PVAL,CODE,NPISTATS,XUVALUE,D0,EXPIRATN,I,NPIFLD,NPISUBFL
+ S NPISTATS=41.98,NPISUBFL=200.042,NPIFLD=.03
+ I $$GET1^DIQ(200,XUUSER_",",NPISTATS)'="" Q  ; user is already flagged
+ S PCLASS=0,XUDONE=0 F  S PCLASS=$O(^VA(200,XUUSER,"USC1",PCLASS)) Q:PCLASS'>0  S D0=^(PCLASS,0) D  Q:XUDONE
+ . S EXPIRATN=$P(D0,U,3)>0 I EXPIRATN Q
+ . S PVAL=$P(D0,U),CODE=$$GET1^DIQ(8932.1,PVAL_",",6) I CODE'="",$D(@XUGLOB@(CODE)) D  S XUDONE=1 Q
+ . . S XUVALUE="N" N NPIVAL F I=1:1 S NPIVAL=$$GET1^DIQ(NPISUBFL,I_","_XUUSER_",",NPIFLD) Q:NPIVAL=""  S XUVALUE="D" Q
+ . . N XUFDA S XUFDA(200,XUUSER_",",NPISTATS)=XUVALUE
+ . . D FILE^DIE("","XUFDA")
+ . . Q
+ . Q
+ Q
+ ;
+CBOLIST ; list ^ delimited output to CBO exchange mail group.
+ N DATE,DOMAIN,ADDRESS,STATNAME,COUNT,DOB,GLOBLOC,GLOBOUT
+ N IEN,NPI,PROVNAME,SSN,TAXDESCR,TAXONOMY,STATION,STATUS,OPTION
+ I '$$PROD^XUPROD() Q  ; messages from production systems only
+ S DATE=(1700+$E(DT,1,3))_"-"_$E(DT,4,5)_"-"_$E(DT,6,7)
+ S DOMAIN=$G(^XTV(8989.3,1,0)),DOMAIN=$P(DOMAIN,U)
+ S STATION=$$NS^XUAF4($$KSP^XUPARAM("INST"))
+ S ADDRESS=$P(STATION,U) ;$$GET1^DIQ(4.2,DOMAIN_",",.01)
+ S STATION=$P(STATION,U,2) ;$$GET1^DIQ(4.2,DOMAIN_",",5.5)
+ S OPTION=3
+ S GLOBLOC=$$GETDATA(OPTION,0,0) ; get most of data into location specified by GLOBLOC
+ S COUNT=0,GLOBOUT=$NA(^TMP($J,"XUSNPIOUT")) K @GLOBOUT
+ S COUNT=1,@GLOBOUT@(COUNT)="--START"
+ S GLOBLOC=$NA(@GLOBLOC@(" "," "))
+ S PROVNAME="" F  S PROVNAME=$O(@GLOBLOC@(PROVNAME)) Q:PROVNAME=""  S IEN=0 F  S IEN=$O(@GLOBLOC@(PROVNAME,IEN)) Q:IEN'>0  D
+ . S TAXDESCR="" F  S TAXDESCR=$O(@GLOBLOC@(PROVNAME,IEN,TAXDESCR)) Q:TAXDESCR=""  S TAXONOMY=$P(^(TAXDESCR),U,4),NPI=$P(^(TAXDESCR),U,3) D
+ . . S DOB=$P($G(^VA(200,IEN,1)),U,3),SSN=$E($$GET1^DIQ(200,IEN_",",9),6,9) S:DOB'="" DOB=$$DATE10(DOB) S STATUS=$$NPISTATS(IEN)
+ . . S COUNT=COUNT+1,@GLOBOUT@(COUNT)=PROVNAME_U_STATION_U_NPI_U_SSN_U_DOB_U_TAXONOMY_U_TAXDESCR_U_DATE_U_STATUS
+ . . Q
+ . Q
+ S COUNT=COUNT+1,@GLOBOUT@(COUNT)="--END"
+ ; and generate mail message
+ N XMTEXT,XMDUZ,XMY,XMSUB
+ S XMTEXT=$E(GLOBOUT,1,$L(GLOBOUT)-1)_",",XMDUZ=0.5,XMY("VHACONPINPF@VA.GOV")=""
+ S XMSUB="NPI LIST "_DATE_" FOR "_ADDRESS_" ("_STATION_")"
+ D ^XMD
+ Q
+ ;
+PRINTOPT ;
+ D PRINTOPT^XUSNPIE2
+ Q
+GETDATA(OPTION,XUSSORT,XUSDIV) ; get data for reports for providers
+ Q $$GETDATA^XUSNPIE2(OPTION,XUSSORT,XUSDIV)
+ ;
+CHEKNPI(IEN) ; returns whether status is Needs, will check and update if not set
+ N VALUE,FDA
+ S VALUE=$E($$GET1^DIQ(200,IEN_",",41.98))
+ I VALUE="N" S FDA(200,IEN_",",41.98)="" D FILE^DIE("","FDA") S VALUE="" ; XU*8*435 JLI
+ I VALUE="",$$CHKTAXON(IEN) K FDA S FDA(200,IEN_",",41.98)="N" D FILE^DIE("","FDA") S VALUE="N"
+ Q VALUE="N"
+ ;
+NEEDSNPI(IEN) ; returns whether current status is N
+ Q $$NPISTATS(IEN)="N"
+ ;
+HASNPI(IEN) ; returns whether current status is D (Done)
+ Q $$NPISTATS(IEN)="D"
+ ;
+EXMPTNPI(IEN) ; returns whether current status is E (Exempt)
+ Q $$NPISTATS(IEN)="E"
+ ;
+NPISTATS(IEN) ; returns one letter status indicator
+ N VAL
+ S VAL=$E($$GET1^DIQ(200,IEN_",",41.98))
+ I (VAL="")!(VAL="N") S VAL=$$CHEKNPI(IEN)
+ Q $E($$GET1^DIQ(200,IEN_",",41.98))
+ ;
+GETNPI(IEN) ; returns current NPI value
+ Q $$GET1^DIQ(200,IEN_",",41.99)
+ ;
+GETTAXON(IEN,DESCRREF) ; returns Taxonomy value (X12) and sets description in DESCRREF, otherwise -1
+ N I,POINTER,TAXON
+ S TAXON=-1,DESCRREF=" "
+ ;F I=0:0 S I=$O(^VA(200,IEN,"USC1",I)) Q:I'>0  I $P(^(I,0),U,3)'>0 S POINTER=+^(0) S TAXON=$$GET1^DIQ(8932.1,POINTER_",",6),DESCRREF=$$GET1^DIQ(8932.1,POINTER_",",1) Q
+ S POINTER=+$$GET^XUA4A72(IEN) I POINTER>0 S TAXON=$$GET1^DIQ(8932.1,POINTER_",",6),DESCRREF=$$GET1^DIQ(8932.1,POINTER_",",1) ; XU*8*435 make sure active on today
+ I TAXON="" S TAXON=-1,DESCRREF=" "
+ Q TAXON
+ ;
+CHKTAXON(IEN,TAXONOMY) ; checks whether taxonomy value (X12) is in list of billable otherwise 0-1
+ N DESCRIP,XUSGLOB
+ I $G(TAXONOMY)="" S TAXONOMY=$$GETTAXON(IEN,.DESCRIP)
+ S XUSGLOB=$$CHKGLOB()
+ Q $D(@XUSGLOB@(TAXONOMY))
+ ;
+DATE10(DATE) ; returns date in mm/dd/yyyyy format
+ Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_(1700+$E(DATE,1,3))
+ ;
+POSTINIT ; runs post init
+ D POSTINIT^XUSNPIE1
+ Q
+ ;
+CBOQUEUE ; queues CBO List to run on first day of month
+ D CBOQUEUE^XUSNPIE1
+ Q
+ALIGNRGT(TEXT,WIDTH) ; align text right in a specified width
+ Q $$ALIGNRGT^XUSNPIE2(TEXT,WIDTH)
Index: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX1.m
===================================================================
--- WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX1.m	(revision 613)
+++ WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX1.m	(revision 623)
@@ -1,273 +1,249 @@
-XUSNPIX1	;OAK_BP/CMW - NPI EXTRACT REPORT ;11:45 AM  28 Jul 2009
-	;;8.0;KERNEL;**438,452,453,481,WV**; Jul 10, 1995;Build 21
-	;;Per VHA Directive 2004-038, this routine should not be modified.
-	;
-	; NPI Extract Report
-	;
-	; Input parameter: N/A
-	;
-	; Other relevant variables:
-	;   XUSRTN="XUSNPIX1" (current routine name, used for ^XTMP and ^TMP
-	;                         storage subscript)
-	; Storage Global:
-	;   ^XTMP("XUSNPIX1",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6
-	;      where:
-	;      Piece 1 => Purge Date - 1 year in future
-	;      Piece 2 => Create Date - Today
-	;      Piece 3 => Description
-	;      Piece 4 => Last Date Compiled
-	;      Piece 5 => $H last run start time
-	;      Piece 6 => $H last run completion time
-	;
-	;   ^XTMP("XUSNPIX1",1) = DATA
-	;
-	;          XUSNPI => Unique NPI of entry
-	;          LDT => Last Date Run, VA Fileman Format
-	;
-	; Entry Point - TASKMAN => Run report in background using TASKMAN
-	;
-	Q
-	;
-TASKMAN	;TASKMAN ENTRY POINT
-	; Process Report
-	N XUSRTN,DTTM,XUSPROD,XUSVER,INSMAIL
-	;
-	; Check for required variables
-	I $G(U)=""!($G(DT)="") G EXIT
-	S XUSRTN="XUSNPIX1"
-	S DTTM=$$HTE^XLFDT($H,"2")
-	; Check to see if report is in use
-	L +^XTMP(XUSRTN):5 I '$T G EXIT
-	;
-	;Reset Summary Scratch Globals
-	K ^TMP("XUSNPIXS",$J)
-	K ^TMP("XUSNPIXT",$J)
-	;
-	; Initialize variables
-	D INIT(XUSRTN)
-	;
-	; Pull Station(Institution) data
-	D INST(XUSRTN,XUSVER,.INSMAIL)
-	;
-	;Process New Person File
-	D PROC1(XUSRTN,XUSPROD,XUSVER,DTTM,INSMAIL)
-	;
-	; Process Institution File
-	D ENT^XUSNPIX2(XUSPROD,XUSVER)
-	;
-	; Process Non VA File
-	D ENT^XUSNPIX3(XUSPROD,XUSVER)
-	;
-	; Send summary message
-	D SMAIL^XUSNPIX5("XUSNPIXT",XUSPROD,XUSVER,DTTM)
-	;
-	;Standard EXIT point
-EXIT	;
-	K DTTM,XUSVER,XUSHDR,XUSPROD,INSMAIL
-	;
-	;Kill off Scratch Globals
-	K ^TMP("XUSNPIXS",$J)
-	K ^TMP("XUSNPIXT",$J)
-	K ^TMP("XUSNPIXU",$J)
-	; Log Run Completion Time
-	S $P(^XTMP(XUSRTN,0),U,6)=$H
-	L -^XTMP(XUSRTN)
-	;
-	Q
-	;
-INIT(XUSRTN)	; check/init variables
-	N XUSDESC
-	; Set to NEXT release version from NPM
-	S XUSVER="481.5"
-	; Get production/test account flag
-	S XUSPROD=$S($$PROD^XUPROD(1):"PROD",1:"TEST")
-	;
-	; Reset Temporary Scratch Global
-	D INIT^XUSNPIXU
-	K ^TMP(XUSRTN)
-	S XUSDESC="NPI EXTRACT TYPE 1 - Do Not Delete"
-	S ^XTMP(XUSRTN,0)=(DT+10000)_U_DT_U_XUSDESC_U_DT_U_$H
-	; Generate TMP BCBS Array
-	D BCBSID^XUSNPIXU
-	;
-	Q
-	;
-INST(XUSRTN,XUSVER,INSMAIL)	;Pull station and Institution info
-	N INST,SINFO,DIC4
-	; Pull site info
-	S SINFO=$$SITE^VASITE
-	; Station Number
-	S SITE=$P(SINFO,U,3)
-	; Institution
-	S INST=$P(SINFO,U)
-	;
-	; Get institution mailing address
-	I INST D
-	. S DIC4=$G(^DIC(4,INST,4))
-	. S XUSNP(7)=$P(DIC4,U)
-	. S XUSNP(8)=$P(DIC4,U,2)
-	. S XUSNP(9)=$P(DIC4,U,3)
-	. S XUSNP(10)=$P(DIC4,U,4)
-	. I XUSNP(10) S XUSNP(10)=$P($G(^DIC(5,XUSNP(10),0)),U,2)
-	. S XUSNP(11)=$P(DIC4,U,5)
-	. S INSMAIL=XUSNP(7)_U_XUSNP(8)_U_XUSNP(9)_U_XUSNP(10)_U_XUSNP(11)
-	S XUSHDR="Station: "_SITE_U_XUSNP(9)_U_XUSNP(10)_U_XUSNP(11)_U_"TYPE 1"_U_XUSVER
-	;
-	Q
-	;
-PROC1(XUSRTN,XUSPROD,XUSVER,DTTM,INSMAIL)	;Process all New Person records
-	N XUSNPI,XUSDT,XUSNEW,XUSI,XUSDATA,XUSVA0,XUSVA0,XUSVA1,XUSNAME,XUSDOB,XUSDIV,XUSSTL,XUSSTLN,XUSOPN
-	N XUSPER,XUSSPC,XUSTAX,XUSTAXID,XUSIZE,NPIEN,DIC4,SPDIV,VA12,VA13,COUNT,MSGCNT,MAXSIZE,TOTREC,XUSEOL
-	;
-	; Set to 300000 for live
-	S MAXSIZE=300000
-	;
-	; Set end of line character
-	S XUSEOL="~~"
-	;
-	; set counter
-	S COUNT=1,(TOTREC,MSGCNT,XUSIZE)=0
-	; Loop through NEW PERSON NPI records NPI cross ref
-	S XUSNPI=0
-	F  S XUSNPI=$O(^VA(200,"ANPI",XUSNPI)) Q:'XUSNPI  D
-	. S NPIEN=$O(^VA(200,"ANPI",XUSNPI,""))
-	. ;
-	. ; Init columns
-	. F XUSI=1:1:29 S XUSNP(XUSI)=""
-	. S XUSNP(1)=XUSNPI S XUSDATA1=XUSNP(1)
-	. ;
-	. S XUSVA0=$G(^VA(200,NPIEN,0))
-	. S XUSVA1=$G(^VA(200,NPIEN,1))
-	. S XUSNAME=$P(XUSVA0,U)
-	. ; BREAK NAME INTO COMPONENTS
-	. I XUSNAME'="" D
-	. . ;Begin WorldVistA Change; 07/28/2009
-	. . ;S XLFNC=XUSNAME D FORMAT^XLFNAME7(.XLFNC,,,,0)
-	. . S XLFNC=XUSNAME S XLFNC=$$FORMAT^XLFNAME7(.XLFNC,,,,0)
-	. . ;End WorldVistA change
-	. . S XUSNP(2)=XLFNC("GIVEN"),XUSNP(3)=XLFNC("MIDDLE"),XUSNP(4)=XLFNC("FAMILY")
-	. . I XLFNC("SUFFIX")'="" S XUSNP(4)=XUSNP(4)_" "_XLFNC("SUFFIX")
-	. . K XLFNC
-	. S XUSDATA1=XUSDATA1_U_XUSNP(2)_U_XUSNP(3)_U_XUSNP(4)
-	. S XUSNP(5)=1 ;TYPE
-	. S XUSDOB=$P(XUSVA1,U,3)
-	. ; dob formatted as mm/dd/yyyy
-	. I XUSDOB D
-	. . S XUSNP(6)=$$FMTE^XLFDT(XUSDOB,5)
-	. S XUSDATA1=XUSDATA1_U_XUSNP(5)_U_XUSNP(6)
-	. ;
-	. ; Pay to Provider Address Use primary institution mailing address NP7-11
-	. S XUSDATA1=XUSDATA1_U_INSMAIL
-	. ;
-	. ; Servicing Provider Address
-	. S (XUSDIV)=0
-	. ; Loop through Division multiple
-	. F  S XUSDIV=$O(^VA(200,NPIEN,2,XUSDIV)) Q:'XUSDIV  D
-	. . S DIC4=$G(^DIC(4,XUSDIV,4))
-	. . S XUSNP(12)=$P(DIC4,U)
-	. . S XUSNP(13)=$P(DIC4,U,2)
-	. . S XUSNP(14)=$P(DIC4,U,3)
-	. . S XUSNP(15)=$P(DIC4,U,4)
-	. . I XUSNP(15) S XUSNP(15)=$P($G(^DIC(5,XUSNP(15),0)),U,2)
-	. . S XUSNP(16)=$P(DIC4,U,5)
-	. . S XUSSTA(XUSDIV)=$P($G(^DIC(4,XUSDIV,99)),U)
-	. . S SPADR(XUSDIV)=XUSNP(12)_U_XUSNP(13)_U_XUSNP(14)_U_XUSNP(15)_U_XUSNP(16)
-	. ; If no divisions found
-	. I '$D(SPADR) D
-	. . S XUSSTA(9999)="N/A",SPADR(9999)=XUSNP(12)_U_XUSNP(13)_U_XUSNP(14)_U_XUSNP(15)_U_XUSNP(16)
-	. ;
-	. ; Office Phone number
-	. S XUSOPN=$P($G(^VA(200,NPIEN,.13)),U,2)
-	. I XUSOPN'="" S XUSNP(17)=XUSOPN
-	. ;
-	. ; Degree
-	. S XUSNP(18)=$P($G(^VA(200,NPIEN,3.1)),U,6)
-	. ; Degree Code (place holder)
-	. S XUSNP(19)=""
-	. ;
-	. ; get taxonomy and specialty
-	. S XUSPER=0
-	. F  S XUSPER=$O(^VA(200,NPIEN,"USC1","B",XUSPER)) Q:'XUSPER  D
-	. . S XUSSPC=$P($G(^USC(8932.1,XUSPER,0)),U,9)
-	. . S XUSTAX=$P($G(^USC(8932.1,XUSPER,0)),U,7)
-	. . I XUSSPC'="" D
-	. . . I XUSNP(20)="" S XUSNP(20)=XUSSPC Q
-	. . . S XUSNP(20)=XUSNP(20)_";"_XUSSPC
-	. . I XUSTAX'="" D
-	. . . I XUSNP(21)="" S XUSNP(21)=XUSTAX Q
-	. . . S XUSNP(21)=XUSNP(21)_";"_XUSTAX
-	. ;
-	. ; Tax ID
-	. S XUSTAXID=$P($G(^VA(200,NPIEN,"TPB")),U,2)
-	. I XUSTAXID="" S XUSTAXID=$P($G(^VA(200,NPIEN,1)),U,9)
-	. S XUSNP(22)=XUSTAXID
-	. ;
-	. S XUSDATA2=XUSNP(17)_U_XUSNP(18)_U_XUSNP(19)_U_XUSNP(20)_U_XUSNP(21)_U_XUSNP(22)
-	. ;
-	. ; Medicare Part A/B
-	. S XUSNP(23)=670899
-	. S XUSNP(24)="VA"_$E(SITE+10000,2,5)
-	. ;
-	. ; State License
-	. S XUSSTL=0
-	. F  S XUSSTL=$O(^VA(200,NPIEN,"PS1",XUSSTL)) Q:'XUSSTL  D
-	. . S XUSSTLN=$P($G(^VA(200,NPIEN,"PS1",XUSSTL,0)),U,2)
-	. . I XUSSTLN'="" D
-	. . . I XUSNP(25)="" S XUSNP(25)=XUSSTLN Q
-	. . . S XUSNP(25)=XUSNP(25)_";"_XUSSTLN
-	. ; DEA #
-	. S XUSNP(26)=$P($G(^VA(200,NPIEN,"PS")),U,2)
-	. ;
-	. S XUSDATA2=XUSDATA2_U_XUSNP(23)_U_XUSNP(24)_U_XUSNP(25)_U_XUSNP(26)
-	. ;
-	. ; Station #
-	. S XUSNP(27)=""
-	. ;
-	. ; Get BCBS Payer ID Array
-	. K XUSBXID
-	. D PRACID^XUSNPIXU(NPIEN,.XUSBXID)
-	. ;
-	. ; Save entry to ^TMP and update count
-	. N XUSB
-	. S XUSDIV=0
-	. F  S XUSDIV=$O(SPADR(XUSDIV)) Q:'XUSDIV  D
-	. . S COUNT=COUNT+1,TOTREC=TOTREC+1
-	. . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_SPADR(XUSDIV)_U_XUSDATA2_U_XUSSTA(XUSDIV)_U_XUSEOL
-	. . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT))
-	. . ; Check BCBS Id array
-	. . I $D(XUSBXID) D
-	. . . S XUSB=""
-	. . . F  S XUSB=$O(XUSBXID(XUSB)) Q:XUSB=""  D
-	. . . . S COUNT=COUNT+1,TOTREC=TOTREC+1
-	. . . . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_SPADR(XUSDIV)_U_XUSDATA2_U_XUSSTA(XUSDIV)_U_XUSB_U_XUSEOL
-	. . . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT))
-	. K XUSNP,XUSDATA1,XUSDATA2,XUSDATA3,SPADR,XUSBXID,CNT,XUSSTA
-	. I XUSIZE>MAXSIZE D
-	. . D EOF(XUSRTN)
-	. . D EMAIL^XUSNPIX5(XUSRTN)
-	. . K ^TMP(XUSRTN,$J)
-	. . S ^TMP("XUSNPIXS",$J,1,MSGCNT)="1^"_(COUNT-2)
-	. . S ^TMP(XUSRTN,$J,1)=XUSHDR
-	. . S COUNT=1,XUSIZE=0
-	D EOF(XUSRTN)
-	;
-	; Send the last message (if it has records)
-	I $G(COUNT)>1 D
-	.D EMAIL^XUSNPIX5(XUSRTN)
-	.K ^TMP(XUSRTN,$J)
-	.S ^TMP("XUSNPIXS",$J,1,MSGCNT)="1^"_(COUNT-2)
-	;
-	; Set summary totals
-	S ^XTMP("XUSNPIXT",0)=(DT+10000)_U_DT_U_"NPI EXTRACT SUMMARY TOTALS"_U_DT_U_$H
-	S ^XTMP("XUSNPIXT","H")=$P(XUSHDR,U,1,4)
-	S ^XTMP("XUSNPIXT",1)=MSGCNT_U_TOTREC_U_DTTM
-	K INSMAIL,SITE
-	Q
-	;
-EOF(XUSRTN)	;
-	Q:COUNT=1
-	S MSGCNT=MSGCNT+1
-	S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_COUNT_U_DTTM_U_$G(XUSPROD)_U_XUSEOL
-	S COUNT=COUNT+1
-	S ^TMP(XUSRTN,$J,COUNT)="END OF FILE"_U_XUSEOL
-	Q
+XUSNPIX1 ;OAK_BP/CMW - NPI EXTRACT REPORT ;01-OCT-06
+ ;;8.0;KERNEL;**438,452,453**; Jul 10, 1995;Build 36
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
+ ; NPI Extract Report
+ ;
+ ; Input parameter: N/A
+ ;
+ ; Other relevant variables:
+ ;   XUSRTN="XUSNPIX1" (current routine name, used for ^XTMP and ^TMP
+ ;                         storage subscript)
+ ; Storage Global:
+ ;   ^XTMP("XUSNPIX1",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6
+ ;      where:
+ ;      Piece 1 => Purge Date - 1 year in future
+ ;      Piece 2 => Create Date - Today
+ ;      Piece 3 => Description
+ ;      Piece 4 => Last Date Compiled
+ ;      Piece 5 => $H last run start time
+ ;      Piece 6 => $H last run completion time
+ ;
+ ;   ^XTMP("XUSNPIX1",1) = DATA
+ ;               
+ ;          XUSNPI => Unique NPI of entry
+ ;          LDT => Last Date Run, VA Fileman Format
+ ;
+ ; Entry Point - TASKMAN => Run report in background using TASKMAN
+ ;
+ Q
+ ;
+TASKMAN ;TASKMAN ENTRY POINT
+ ; Process Report
+ N XUSRTN,DTTM
+ ; Check for required variables
+ I $G(U)=""!($G(DT)="") G EXIT
+ S XUSRTN="XUSNPIX1"
+ S DTTM=$$HTE^XLFDT($H,"2")
+ ; Check to see if report is in use
+ L +^XTMP(XUSRTN):5 I '$T G EXIT
+ ;
+ D INIT(XUSRTN)
+ ; Pull Station(Institution) data
+ D INST(XUSRTN)
+ ;
+ D PROC1(XUSRTN)
+ ; Send the message
+ D EMAIL^XUSNPIX5(XUSRTN)
+ D VMAIL^XUSNPIX5(XUSRTN)
+ ;
+ ; Process Institution File
+ D ENT^XUSNPIX2
+ ;
+ ; Process Non VA File
+ D ENT^XUSNPIX3
+ ;
+ ; Send summary message
+ D SMAIL^XUSNPIX5("XUSNPIXT")
+ ;
+ ;Standard EXIT point
+EXIT ;
+ K XUSEOL,DTTM,MAXSIZE,XUSVER,XUSHDR,XUSPROD
+ K MSGCNT,TOTREC,COUNT
+ K ^TMP("XUSNPIXU",$J)
+ ; Log Run Completion Time
+ S $P(^XTMP(XUSRTN,0),U,6)=$H
+ L -^XTMP(XUSRTN)
+ ;
+ Q
+ ;
+INIT(XUSRTN) ; check/init variables
+ N XUSDESC
+ ; Set to NEXT release version from NPM
+ S XUSVER="453.16"
+ ; Get production/test account flag
+ S XUSPROD=$S($$PROD^XUPROD(1):"PROD",1:"TEST")
+ ; Set end of line character
+ S XUSEOL="~~"
+ ; Set to 300000 for live
+ S MAXSIZE=300000
+ ; Reset Temporary Scratch Global
+ D INIT^XUSNPIXU
+ K ^TMP(XUSRTN)
+ S XUSDESC="NPI EXTRACT TYPE 1 - Do Not Delete"
+ S ^XTMP(XUSRTN,0)=(DT+10000)_U_DT_U_XUSDESC_U_DT_U_$H
+ ; Generate TMP BCBS Array
+ D BCBSID^XUSNPIXU
+ ;
+ Q
+ ;
+INST(XUSRTN) ;Pull station and Institution info
+ N INST,SINFO,DIC4
+ ; Pull site info
+ S SINFO=$$SITE^VASITE
+ ; Station Number 
+ S SITE=$P(SINFO,U,3)
+ ; Institution    
+ S INST=$P(SINFO,U)
+ ;
+ ; Get institution mailing address
+ I INST D
+ . S DIC4=$G(^DIC(4,INST,4))
+ . S XUSNP(7)=$P(DIC4,U)
+ . S XUSNP(8)=$P(DIC4,U,2)
+ . S XUSNP(9)=$P(DIC4,U,3)
+ . S XUSNP(10)=$P(DIC4,U,4)
+ . I XUSNP(10) S XUSNP(10)=$P($G(^DIC(5,XUSNP(10),0)),U,2)
+ . S XUSNP(11)=$P(DIC4,U,5)
+ . S INSMAIL=XUSNP(7)_U_XUSNP(8)_U_XUSNP(9)_U_XUSNP(10)_U_XUSNP(11)
+ S XUSHDR="Station: "_SITE_U_XUSNP(9)_U_XUSNP(10)_U_XUSNP(11)_U_"TYPE 1"_U_XUSVER
+ ;
+ Q
+ ;
+PROC1(XUSRTN) ;Process all New Person records
+ N XUSNPI,XUSDT,XUSNEW,XUSI,XUSDATA,XUSVA0,XUSVA0,XUSVA1,XUSNAME,XUSDOB,XUSDIV,XUSSTL,XUSSTLN,XUSOPN
+ N XUSPER,XUSSPC,XUSTAX,XUSTAXID,XUSIZE,NPIEN,DIC4,SPDIV,VA12,VA13
+ ; set counter
+ S COUNT=1,(TOTREC,MSGCNT,XUSIZE)=0
+ ; Loop through NEW PERSON NPI records NPI cross ref
+ S XUSNPI=0
+ F  S XUSNPI=$O(^VA(200,"ANPI",XUSNPI)) Q:'XUSNPI  D
+ . S NPIEN=$O(^VA(200,"ANPI",XUSNPI,""))
+ . ;
+ . ; Init columns
+ . F XUSI=1:1:29 S XUSNP(XUSI)=""
+ . S XUSNP(1)=XUSNPI S XUSDATA1=XUSNP(1)
+ . ;
+ . S XUSVA0=$G(^VA(200,NPIEN,0))
+ . S XUSVA1=$G(^VA(200,NPIEN,1))
+ . S XUSNAME=$P(XUSVA0,U)
+ . ; BREAK NAME INTO COMPONENTS
+ . I XUSNAME'="" D
+ . . S XLFNC=XUSNAME D FORMAT^XLFNAME7(.XLFNC,,,,0)
+ . . S XUSNP(2)=XLFNC("GIVEN"),XUSNP(3)=XLFNC("MIDDLE"),XUSNP(4)=XLFNC("FAMILY")
+ . . I XLFNC("SUFFIX")'="" S XUSNP(4)=XUSNP(4)_" "_XLFNC("SUFFIX")
+ . . K XLFNC
+ . S XUSDATA1=XUSDATA1_U_XUSNP(2)_U_XUSNP(3)_U_XUSNP(4)
+ . S XUSNP(5)=1 ;TYPE
+ . S XUSDOB=$P(XUSVA1,U,3)
+ . ; dob formatted as mm/dd/yyyy
+ . I XUSDOB D
+ . . S XUSNP(6)=$$FMTE^XLFDT(XUSDOB,5)
+ . S XUSDATA1=XUSDATA1_U_XUSNP(5)_U_XUSNP(6)
+ . ;
+ . ; Pay to Provider Address Use primary institution mailing address NP7-11
+ . S XUSDATA1=XUSDATA1_U_INSMAIL
+ . ;
+ . ; Servicing Provider Address
+ . S (XUSDIV)=0
+ . ; Loop through Division multiple
+ . F  S XUSDIV=$O(^VA(200,NPIEN,2,XUSDIV)) Q:'XUSDIV  D
+ . . S DIC4=$G(^DIC(4,XUSDIV,4))
+ . . S XUSNP(12)=$P(DIC4,U)
+ . . S XUSNP(13)=$P(DIC4,U,2)
+ . . S XUSNP(14)=$P(DIC4,U,3)
+ . . S XUSNP(15)=$P(DIC4,U,4)
+ . . I XUSNP(15) S XUSNP(15)=$P($G(^DIC(5,XUSNP(15),0)),U,2)
+ . . S XUSNP(16)=$P(DIC4,U,5)
+ . . S XUSSTA(XUSDIV)=$P($G(^DIC(4,XUSDIV,99)),U)
+ . . S SPADR(XUSDIV)=XUSNP(12)_U_XUSNP(13)_U_XUSNP(14)_U_XUSNP(15)_U_XUSNP(16)
+ . ; If no divisions found
+ . I '$D(SPADR) D
+ . . S XUSSTA(9999)="N/A",SPADR(9999)=XUSNP(12)_U_XUSNP(13)_U_XUSNP(14)_U_XUSNP(15)_U_XUSNP(16)
+ . ;
+ . ; Office Phone number
+ . S XUSOPN=$P($G(^VA(200,NPIEN,.13)),U,2)
+ . I XUSOPN'="" S XUSNP(17)=XUSOPN
+ . ;
+ . ; Degree
+ . S XUSNP(18)=$P($G(^VA(200,NPIEN,3.1)),U,6)
+ . ; Degree Code (place holder)
+ . S XUSNP(19)=""
+ . ;
+ . ; get taxonomy and specialty
+ . S XUSPER=0
+ . F  S XUSPER=$O(^VA(200,NPIEN,"USC1","B",XUSPER)) Q:'XUSPER  D
+ . . S XUSSPC=$P($G(^USC(8932.1,XUSPER,0)),U,9)
+ . . S XUSTAX=$P($G(^USC(8932.1,XUSPER,0)),U,7)
+ . . I XUSSPC'="" D
+ . . . I XUSNP(20)="" S XUSNP(20)=XUSSPC Q
+ . . . S XUSNP(20)=XUSNP(20)_";"_XUSSPC
+ . . I XUSTAX'="" D
+ . . . I XUSNP(21)="" S XUSNP(21)=XUSTAX Q
+ . . . S XUSNP(21)=XUSNP(21)_";"_XUSTAX
+ . ;
+ . ; Tax ID
+ . S XUSTAXID=$P($G(^VA(200,NPIEN,"TPB")),U,2)
+ . I XUSTAXID="" S XUSTAXID=$P($G(^VA(200,NPIEN,1)),U,9)
+ . S XUSNP(22)=XUSTAXID
+ . ;
+ . S XUSDATA2=XUSNP(17)_U_XUSNP(18)_U_XUSNP(19)_U_XUSNP(20)_U_XUSNP(21)_U_XUSNP(22)
+ . ;
+ . ; Medicare Part A/B
+ . S XUSNP(23)=670899
+ . S XUSNP(24)="VA"_$E(SITE+10000,2,5)
+ . ;
+ . ; State License
+ . S XUSSTL=0
+ . F  S XUSSTL=$O(^VA(200,NPIEN,"PS1",XUSSTL)) Q:'XUSSTL  D
+ . . S XUSSTLN=$P($G(^VA(200,NPIEN,"PS1",XUSSTL,0)),U,2)
+ . . I XUSSTLN'="" D
+ . . . I XUSNP(25)="" S XUSNP(25)=XUSSTLN Q
+ . . . S XUSNP(25)=XUSNP(25)_";"_XUSSTLN
+ . ; DEA #
+ . S XUSNP(26)=$P($G(^VA(200,NPIEN,"PS")),U,2)
+ . ;
+ . S XUSDATA2=XUSDATA2_U_XUSNP(23)_U_XUSNP(24)_U_XUSNP(25)_U_XUSNP(26)
+ . ;
+ . ; Station #
+ . S XUSNP(27)=""
+ . ;
+ . ; Get BCBS Payer ID Array
+ . K XUSBXID
+ . D PRACID^XUSNPIXU(NPIEN,.XUSBXID)
+ . ;
+ . ; Save entry to ^TMP and update count
+ . N XUSB
+ . S XUSDIV=0
+ . F  S XUSDIV=$O(SPADR(XUSDIV)) Q:'XUSDIV  D
+ . . S COUNT=COUNT+1,TOTREC=TOTREC+1
+ . . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_SPADR(XUSDIV)_U_XUSDATA2_U_XUSSTA(XUSDIV)_U_XUSEOL
+ . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT))
+ . . ; Check BCBS Id array
+ . . I $D(XUSBXID) D
+ . . . S XUSB=""
+ . . . F  S XUSB=$O(XUSBXID(XUSB)) Q:XUSB=""  D
+ . . . . S COUNT=COUNT+1,TOTREC=TOTREC+1
+ . . . . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_SPADR(XUSDIV)_U_XUSDATA2_U_XUSSTA(XUSDIV)_U_XUSB_U_XUSEOL
+ . . . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT))
+ . K XUSNP,XUSDATA1,XUSDATA2,XUSDATA3,SPADR,XUSBXID,CNT,XUSSTA
+ . I XUSIZE>MAXSIZE D
+ . . D EOF(XUSRTN)
+ . . D EMAIL^XUSNPIX5(XUSRTN)
+ . . D VMAIL^XUSNPIX5(XUSRTN)
+ . . S ^TMP(XUSRTN,$J,1)=XUSHDR
+ . . S COUNT=1,XUSIZE=0
+ D EOF(XUSRTN)
+ ; set summary totals
+ S ^XTMP("XUSNPIXT",0)=(DT+10000)_U_DT_U_"NPI EXTRACT SUMMARY TOTALS"_U_DT_U_$H
+ S ^XTMP("XUSNPIXT","H")=$P(XUSHDR,U,1,4)
+ S ^XTMP("XUSNPIXT",1)=MSGCNT_U_TOTREC_U_DTTM
+ K INSMAIL,SITE
+ Q
+ ;
+EOF(XUSRTN) ;
+ S MSGCNT=MSGCNT+1
+ S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_COUNT_U_DTTM_U_$G(XUSPROD)_U_XUSEOL
+ S COUNT=COUNT+1
+ S ^TMP(XUSRTN,$J,COUNT)="END OF FILE"_U_XUSEOL
+ Q
Index: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX2.m
===================================================================
--- WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX2.m	(revision 613)
+++ WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX2.m	(revision 623)
@@ -1,298 +1,301 @@
-XUSNPIX2	;OAK_BP/CMW - NPI EXTRACT REPORT ;7/7/08  17:17
-	;;8.0;KERNEL;**438,452,453,481**; Jul 10, 1995;Build 21
-	;;Per VHA Directive 2004-038, this routine should not be modified.
-	;
-	; NPI Extract Report
-	;
-	; Input parameter: N/A
-	;
-	; Other relevant variables:
-	;   XUSRTN="XUSNPIX2" (current routine name, used for ^XTMP and ^TMP
-	;                         storage subscript)
-	; Storage Global:
-	;   ^XTMP("XUSNPIX2",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6
-	;      where:
-	;      Piece 1 => Purge Date - 1 year in future
-	;      Piece 2 => Create Date - Today
-	;      Piece 3 => Description
-	;      Piece 4 => Last Date Compiled
-	;      Piece 5 => $H last run start time
-	;      Piece 6 => $H last run completion time
-	;
-	;   ^XTMP("XUSNPIX2",1) = STATION INFO
-	;   ^XTMP("XUSNPIX2",2) = DATA
-	;               
-	;          NPI => Unique NPI of entry
-	;          LDT => Last Date Run, VA Fileman Format
-	;
-	; Entry Point - ENT called from XUSNPIX1
-	;
-	Q
-	;
-ENT(XUSPROD,XUSVER)	; ENTRY POINT
-	; Initialize variables
-	N XUSRTN
-	S XUSRTN="XUSNPIX2"
-	S DTTM2=$$HTE^XLFDT($H,"2")
-	; Check to see if report is in use
-	L +^XTMP(XUSRTN):5 I '$T G EXIT
-	; Process Institution File
-	D INIT(XUSRTN)
-	; Pull Station(Institution) data
-	D STAT(XUSRTN)
-	; Process Report
-	D PROC2(XUSRTN,XUSPROD,DTTM2)
-	;
-	; Standard EXIT point
-EXIT	;
-	K ^TMP(XUSRTN,$J),^TMP($J,"XUS59"),^TMP("XUSNPIX",$J)
-	; Log Run Completion Time
-	S $P(^XTMP(XUSRTN,0),U,6)=$H
-	L -^XTMP(XUSRTN)
-	K P,XUSPT,INST,DTTM2,XUSIZE,XUSHDR,XUSTAXID
-	Q
-	;
-INIT(XUSRTN)	; check/init variables
-	N XUSDESC
-	;
-	; Reset Temporary Scratch Global
-	K ^TMP(XUSRTN)
-	S XUSDESC="NPI EXTRACT TYPE 2 - Do Not Delete"
-	S ^XTMP(XUSRTN,0)=(DT+10000)_U_DT_U_XUSDESC_U_DT_U_$H
-	;
-	I '$D(^TMP("XUSNPIXU",$J)) D BCBSID^XUSNPIXU
-	;
-	; Create pharmacy institution ^TMP file
-	D GETPHARM
-	Q
-	;
-STAT(XUSRTN)	; Pull station and Institution info 
-	N SINFO,DIC4,IBSITE,IBFAC,IB0
-	; Pull site info
-	S SINFO=$$SITE^VASITE
-	; Station Number
-	S SITE=$P(SINFO,U,3)
-	; Institution  
-	S INST=$P(SINFO,U)
-	;
-	; Get Federal Tax Id
-	S XUSTAXID=""
-	S IBSITE=0
-	F  S IBSITE=$O(^IBE(350.9,IBSITE)) Q:'IBSITE!(XUSTAXID'="")  D
-	. S XUSTAXID=$P($G(^IBE(350.9,IBSITE,1)),U,5)
-	;
-	; Get institution mailing address (PAY TO)
-	;ST ADDR 1,ST ADDR 2,CITY,ZIP
-	I INST D
-	. S DIC4=$G(^DIC(4,INST,4))
-	. S XUSPT(4)=$P(DIC4,U)
-	. S XUSPT(5)=$P(DIC4,U,2)
-	. S XUSPT(6)=$P(DIC4,U,3)
-	. S XUSPT(7)=$P(DIC4,U,4)
-	. I XUSPT(7) S XUSPT(7)=$P($G(^DIC(5,XUSPT(7),0)),U,2)
-	. S XUSPT(8)=$P(DIC4,U,5)
-	. S PTPMAIL=XUSPT(4)_U_XUSPT(5)_U_XUSPT(6)_U_XUSPT(7)_U_XUSPT(8)
-	S XUSHDR="Station: "_SITE_U_XUSPT(6)_U_XUSPT(7)_U_XUSPT(8)_U_"TYPE 2"_U_XUSVER
-	;
-	Q
-	;
-PROC2(XUSRTN,XUSPROD,DTTM2)	;Process all Institution records
-	N XUSNPI,XUSNEW,XUSDT,XUSI,XUSIN,XUSTXY,XUSSPC,XUSTAX,XUPHM
-	N XUSFCT,XUSFCN,XUSDATA1,XUSDATA2,XUSDATA3,XUSDATA4,XUSDATA5,XUSSTA,XUSEOL
-	N INIEN,DIC0,DIC1,PSIEN,NPIINS,RELINS,PSSTA,COUNT,TOTREC,MSGCNT,MAXSIZE
-	;
-	; Set to 300000 for live
-	S MAXSIZE=300000
-	;
-	; Set end of line character
-	S XUSEOL="~~"
-	;
-	; set counter
-	S COUNT=1,(TOTREC,MSGCNT,XUSIZE)=0
-	; Loop through INSTITUTION NPI records NPI xref
-	S XUSNPI=0
-	F  S XUSNPI=$O(^DIC(4,"ANPI",XUSNPI)) Q:'XUSNPI  D
-	. S INIEN=$O(^DIC(4,"ANPI",XUSNPI,""))
-	. ;
-	. ; Get Station Number
-	. S XUSSTA=$P($G(^DIC(4,INIEN,99)),U)
-	. ; Parent of Association
-	. I (INIEN'=INST)&('$$POA(INIEN,INST)) Q
-	. ; Initialize columns
-	. F XUSI=1:1:24 S XUSIN(XUSI)=""
-	. ;
-	. S XUSIN(1)=XUSNPI
-	. S DIC0=$G(^DIC(4,INIEN,0)) Q:DIC0=""
-	. ;Organization Name  
-	. S XUSIN(2)=$P($G(DIC0),U)
-	. S XUSIN(3)=2
-	. S XUSDATA1=XUSIN(1)_U_XUSIN(2)_U_XUSIN(3)
-	. ;
-	. ; Pay to Provider Address
-	. S XUSDATA2=PTPMAIL
-	. ;
-	. ; Servicing Provider Address
-	. S DIC1=$G(^DIC(4,INIEN,1))
-	. I DIC1'="" D
-	. . S XUSIN(9)=$P(DIC1,U)
-	. . S XUSIN(10)=$P(DIC1,U,2)
-	. . S XUSIN(11)=$P(DIC1,U,3)
-	. . S XUSIN(12)=$P($G(DIC0),U,2)
-	. . I XUSIN(12) S XUSIN(12)=$P($G(^DIC(5,XUSIN(12),0)),U,2)
-	. . S XUSIN(13)=$P(DIC1,U,4)
-	. S XUSDATA3=XUSIN(9)_U_XUSIN(10)_U_XUSIN(11)_U_XUSIN(12)_U_XUSIN(13)
-	. ;
-	. ;Phone number (place holder)
-	. S XUSIN(14)=""
-	. ;
-	. ; Get Taxonomy and Specialty
-	. S XUSTXY=0
-	. F  S XUSTXY=$O(^DIC(4,INIEN,"TAXONOMY","B",XUSTXY)) Q:'XUSTXY  D
-	. . S XUSSPC=$P($G(^USC(8932.1,XUSTXY,0)),U,9)
-	. . S XUSTAX=$P($G(^USC(8932.1,XUSTXY,0)),U,7)
-	. . I XUSSPC'="" D
-	. . . I XUSIN(15)="" S XUSIN(15)=XUSSPC Q
-	. . . S XUSIN(15)=XUSIN(15)_";"_XUSSPC
-	. . I XUSTAX'="" D
-	. . . I XUSIN(16)="" S XUSIN(16)=XUSTAX Q
-	. . . S XUSIN(16)=XUSIN(16)_";"_XUSTAX
-	. ;
-	. ; Federal Tax ID
-	. S XUSIN(17)=$G(XUSTAXID)
-	. ; 
-	. ; Medicaid Part A/B
-	. S XUSIN(18)=670899
-	. S XUSIN(19)="VA"_$E(SITE+10000,2,5)
-	. ;
-	. S XUSDATA4=XUSIN(14)_U_XUSIN(15)_U_XUSIN(16)_U_XUSIN(17)_U_XUSIN(18)_U_XUSIN(19)
-	. ;
-	. ; DEA Number
-	. S XUSIN(20)=$P($G(^DIC(4,INIEN,"DEA")),U)
-	. ;
-	. ; get Facility Type and Name 
-	. S XUSFCT=$P($G(^DIC(4,INIEN,3)),U)
-	. I XUSFCT'="" S XUSFCN=$P($G(^DIC(4.1,XUSFCT,0)),U)
-	. I $G(XUSFCN)="PHARM" D
-	. . I $D(^TMP("XUSNPIX",$J,INIEN)) D
-	. . . S XUPHM=^TMP("XUSNPIX",$J,INIEN)
-	. . . ; get NCPDP from ^TMP
-	. . . S XUSIN(21)=$P($G(XUPHM),U)
-	. . . ; get station number from^TMP
-	. . . I $P($G(XUPHM),U,2) S XUSSTA=$P(XUPHM,U,2)
-	. ;
-	. ; VISN Station Number
-	. S XUSIN(22)=XUSSTA
-	. ;
-	. S XUSDATA5=XUSIN(20)_U_XUSIN(21)_U_XUSIN(22)
-	. ;
-	. ; Get BCBS Payer ID Array
-	. K XUSBXID
-	. D INSTID^XUSNPIXU(.XUSBXID)
-	. ;
-	. ; Update counter and save Entry
-	. ;
-	. S COUNT=COUNT+1,TOTREC=TOTREC+1
-	. S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_XUSDATA2_U_XUSDATA3_U_XUSDATA4_U_XUSDATA5_U_XUSEOL
-	. S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT))
-	. I $D(XUSBXID) D
-	. . S XUSB=""
-	. . F  S XUSB=$O(XUSBXID(XUSB)) Q:XUSB=""  D
-	. . . S COUNT=COUNT+1,TOTREC=TOTREC+1
-	. . . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_XUSDATA2_U_XUSDATA3_U_XUSDATA4_U_XUSDATA5_U_XUSB_U_XUSBXID(XUSB)_U_XUSEOL
-	. . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT))
-	. K XUSIN,XUSDATA1,XUSDATA2,XUSDATA3,XUSDATA4,XUSDATA5,XUSB,XUSBXID
-	. I XUSIZE>MAXSIZE D
-	. . D EOF(XUSRTN)
-	. . D EMAIL(XUSRTN)
-	. . K ^TMP(XUSRTN,$J)
-	. . S ^TMP("XUSNPIXS",$J,2,MSGCNT)="2^"_(COUNT-2)
-	. . S ^TMP(XUSRTN,$J,1)=XUSHDR
-	. . S COUNT=1,XUSIZE=0
-	;
-	D EOF(XUSRTN)
-	;
-	; Send the last message (if it has records)
-	I $G(COUNT)>1 D
-	.D EMAIL(XUSRTN)
-	.K ^TMP(XUSRTN,$J)
-	.S ^TMP("XUSNPIXS",$J,2,MSGCNT)="2^"_(COUNT-2)
-	;
-	; Set Summary totals
-	S ^XTMP("XUSNPIXT",2)=MSGCNT_U_TOTREC_U_DTTM2
-	;
-	K XUSPT,PTPMAIL,LDTCMP,SITE,XUSTAXID
-	Q
-	;
-EOF(XUSRTN)	;
-	Q:COUNT=1
-	S MSGCNT=MSGCNT+1
-	S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_COUNT_U_DTTM2_U_$G(XUSPROD)_U_XUSEOL
-	S COUNT=COUNT+1
-	S ^TMP(XUSRTN,$J,COUNT)="END OF FILE"_U_XUSEOL
-	Q
-	;
-	; Email the message
-EMAIL(XUSRTN)	;
-	N XMY
-	; Send email to designated recipient for live release
-	S XMY("XXX@Q-NPS.VA.GOV")=""
-	D ESEND
-	Q
-	;
-ESEND	N XMTEXT,XMSUB,XMDUN,XMDUZ,XMZ,XMMG,DIFROM
-	;
-	S XMTEXT="^TMP("""_XUSRTN_""","_$J_","
-	S XMSUB=$TR($P($G(^TMP(XUSRTN,$J,1)),U),":")_"("_$G(XUSPROD)_") NPI EXTRACT TYPE 2"
-	D ^XMD
-	Q
-POA(IEN,INST)	; Check Parent of Association for Institution IEN up to VISN level to see if INST is in the chain
-	N XUSPOA
-	I +$G(INST)=0 Q 0 ; No institution - return false
-POA1	;
-	I $G(IEN)="" Q 0 ; No IEN remaining to check - return false
-	I $D(XUSPOA(IEN)) Q 0 ; Already reviewed this IEN - possible infinite loop - return false
-	S XUSPOA(IEN)=""
-	S XUSPOA=$P($G(^DIC(4,IEN,7,2,0)),U,2) ; Get parent of this institution
-	I XUSPOA=INST Q 1 ; Found matching institution - return true
-	I IEN=XUSPOA Q 0 ; Top level reached - return false
-	S IEN=XUSPOA ; Reset IEN to check next level
-	G POA1
-	;
-GETPHARM	;
-	; this subroutine retrieves data from the OUTPATIENT SITE file
-	; using the supported Pharmacy API PSS^PSO59.
-	; It takes the results and places them into a temporary 
-	; global array that is accessed when processing data
-	; associated with a pharmacy institution.
-	N D,DIC,XUS59DA,XUSNPIDA,XUSRELDA,PSSTA,Y,X,XUNCP
-	;
-	;Fix for Remedy Ticket 217164
-	;Quit if Outpatient Site API routine is not loaded
-	S X="PSO59" X ^%ZOSF("TEST") Q:'$T
-	;
-	K ^TMP($J,"XUS59"),^TMP("XUSNPIX",$J) ; remove any pre-existing nodes
-	D PSS^PSO59(,"??","XUS59")  ;IA#4827
-	S XUS59DA=0
-	; gather data from each Outpatient site entry stored in the pharmacy 
-	; ^TMP global and build 2nd ^TMP global for later processing
-	F  S XUS59DA=$O(^TMP($J,"XUS59",XUS59DA)) Q:'XUS59DA  D
-	. ;
-	. ;Get Pharmacy NPI institution from API
-	. S XUSNPIDA=$P($G(^TMP($J,"XUS59",XUS59DA,101)),U)
-	. Q:XUSNPIDA']""  ; NPI institution does not exist
-	. ;
-	. ; Get Pharmacy Related Institution from API
-	. S XUSRELDA=$P($G(^TMP($J,"XUS59",XUS59DA,100)),U)
-	. ; get station number off the related institution
-	. S PSSTA=$P($G(^DIC(4,XUSRELDA,99)),U)
-	. ;
-	. ; Get NCPDP number
-	. S XUNCP=""   ;prevent previous values being carried over
-	. S X=XUSNPIDA S D="C",DIC=9002313.56,DIC(0)="" D IX^DIC
-	. I +Y>0 S XUNCP=$$GET1^DIQ(9002313.56,+Y,.02)
-	. S:$G(XUNCP)="" XUNCP=$P($G(^TMP($J,"XUS59",XUS59DA,1008)),U)
-	. ;
-	. ; rebuild the ^TMP global by NPI institution
-	. ; collect necessary data used in the 'PHARM' logic
-	. S ^TMP("XUSNPIX",$J,XUSNPIDA)=XUNCP_"^"_PSSTA ; ncpdp#^station
-	Q
+XUSNPIX2 ;OAK_BP/CMW - NPI EXTRACT REPORT ; 06 Sep 2007  3:34 PM
+ ;;8.0;KERNEL;**438,452,453**; Jul 10, 1995;Build 36
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
+ ; NPI Extract Report
+ ;
+ ; Input parameter: N/A
+ ;
+ ; Other relevant variables:
+ ;   XUSRTN="XUSNPIX2" (current routine name, used for ^XTMP and ^TMP
+ ;                         storage subscript)
+ ; Storage Global:
+ ;   ^XTMP("XUSNPIX2",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6
+ ;      where:
+ ;      Piece 1 => Purge Date - 1 year in future
+ ;      Piece 2 => Create Date - Today
+ ;      Piece 3 => Description
+ ;      Piece 4 => Last Date Compiled
+ ;      Piece 5 => $H last run start time
+ ;      Piece 6 => $H last run completion time
+ ;
+ ;   ^XTMP("XUSNPIX2",1) = STATION INFO
+ ;   ^XTMP("XUSNPIX2",2) = DATA
+ ;               
+ ;          NPI => Unique NPI of entry
+ ;          LDT => Last Date Run, VA Fileman Format
+ ;
+ ; Entry Point - ENT called from XUSNPIX1
+ ;
+ Q
+ ;
+ENT ; ENTRY POINT
+ ; Initialize variables
+ N XUSRTN
+ S XUSRTN="XUSNPIX2"
+ S DTTM2=$$HTE^XLFDT($H,"2")
+ ; Check to see if report is in use
+ L +^XTMP(XUSRTN):5 I '$T G EXIT
+ ; Process Institution File
+ D INIT(XUSRTN)
+ ; Pull Station(Institution) data
+ D STAT(XUSRTN)
+ ; Process Report
+ D PROC2(XUSRTN)
+ ; Send the message
+ D EMAIL(XUSRTN)
+ D VMAIL(XUSRTN)
+ S ^XTMP("XUSNPIXT",2)=MSGCNT_U_TOTREC_U_DTTM2
+ ;
+ ; Standard EXIT point
+EXIT ;
+ K ^TMP(XUSRTN,$J),^TMP($J,"XUS59"),^TMP("XUSNPIX",$J)
+ ; Log Run Completion Time
+ S $P(^XTMP(XUSRTN,0),U,6)=$H
+ L -^XTMP(XUSRTN)
+ K P,XUSPT,INST,XUSEOL,DTTM2,MAXSIZE,XUSIZE,MSGCNT,COUNT,TOTREC,XUSHDR,XUSTAXID
+ Q
+ ;
+ ;
+INIT(XUSRTN) ; check/init variables
+ N XUSDESC
+ ; Set end of line character
+ S XUSEOL="~~"
+ ; Set to 300000 for live
+ S MAXSIZE=300000
+ ; Reset Temporary Scratch Global
+ K ^TMP(XUSRTN)
+ S XUSDESC="NPI EXTRACT TYPE 2 - Do Not Delete"
+ S ^XTMP(XUSRTN,0)=(DT+10000)_U_DT_U_XUSDESC_U_DT_U_$H
+ ;
+ I '$D(^TMP("XUSNPIXU",$J)) D BCBSID^XUSNPIXU
+ ;
+ ; Create pharmacy institution ^TMP file
+ D GETPHARM
+ Q
+ ;
+STAT(XUSRTN) ; Pull station and Institution info 
+ N SINFO,DIC4,IBSITE,IBFAC,IB0
+ ; Pull site info
+ S SINFO=$$SITE^VASITE
+ ; Station Number
+ S SITE=$P(SINFO,U,3)
+ ; Institution  
+ S INST=$P(SINFO,U)
+ ;
+ ; Get Federal Tax Id
+ S XUSTAXID=""
+ S IBSITE=0
+ F  S IBSITE=$O(^IBE(350.9,IBSITE)) Q:'IBSITE!(XUSTAXID'="")  D
+ . S XUSTAXID=$P($G(^IBE(350.9,IBSITE,1)),U,5)
+ ;
+ ; Get institution mailing address (PAY TO)
+ ;ST ADDR 1,ST ADDR 2,CITY,ZIP
+ I INST D
+ . S DIC4=$G(^DIC(4,INST,4))
+ . S XUSPT(4)=$P(DIC4,U)
+ . S XUSPT(5)=$P(DIC4,U,2)
+ . S XUSPT(6)=$P(DIC4,U,3)
+ . S XUSPT(7)=$P(DIC4,U,4)
+ . I XUSPT(7) S XUSPT(7)=$P($G(^DIC(5,XUSPT(7),0)),U,2)
+ . S XUSPT(8)=$P(DIC4,U,5)
+ . S PTPMAIL=XUSPT(4)_U_XUSPT(5)_U_XUSPT(6)_U_XUSPT(7)_U_XUSPT(8)
+ S XUSHDR="Station: "_SITE_U_XUSPT(6)_U_XUSPT(7)_U_XUSPT(8)_U_"TYPE 2"_U_XUSVER
+ ;
+ Q
+ ;
+PROC2(XUSRTN) ;Process all Institution records
+ N XUSNPI,XUSNEW,XUSDT,XUSI,XUSIN,XUSTXY,XUSSPC,XUSTAX,XUPHM
+ N XUSFCT,XUSFCN,XUSDATA1,XUSDATA2,XUSDATA3,XUSDATA4,XUSDATA5,XUSSTA
+ N INIEN,DIC0,DIC1,PSIEN,NPIINS,RELINS,PSSTA
+ ; set counter
+ S COUNT=1,(TOTREC,MSGCNT,XUSIZE)=0
+ ; Loop through INSTITUTION NPI records NPI xref
+ S XUSNPI=0
+ F  S XUSNPI=$O(^DIC(4,"ANPI",XUSNPI)) Q:'XUSNPI  D
+ . S INIEN=$O(^DIC(4,"ANPI",XUSNPI,""))
+ . ;
+ . ; Get Station Number
+ . S XUSSTA=$P($G(^DIC(4,INIEN,99)),U)
+ . ; Parent of Association
+ . I (INIEN'=INST)&('$$POA(INIEN,INST)) Q
+ . ; Initialize columns
+ . F XUSI=1:1:24 S XUSIN(XUSI)=""
+ . ;
+ . S XUSIN(1)=XUSNPI
+ . S DIC0=$G(^DIC(4,INIEN,0)) Q:DIC0=""
+ . ;Organization Name  
+ . S XUSIN(2)=$P($G(DIC0),U)
+ . S XUSIN(3)=2
+ . S XUSDATA1=XUSIN(1)_U_XUSIN(2)_U_XUSIN(3)
+ . ;
+ . ; Pay to Provider Address
+ . S XUSDATA2=PTPMAIL
+ . ;
+ . ; Servicing Provider Address
+ . S DIC1=$G(^DIC(4,INIEN,1))
+ . I DIC1'="" D
+ . . S XUSIN(9)=$P(DIC1,U)
+ . . S XUSIN(10)=$P(DIC1,U,2)
+ . . S XUSIN(11)=$P(DIC1,U,3)
+ . . S XUSIN(12)=$P($G(DIC0),U,2)
+ . . I XUSIN(12) S XUSIN(12)=$P($G(^DIC(5,XUSIN(12),0)),U,2)
+ . . S XUSIN(13)=$P(DIC1,U,4)
+ . S XUSDATA3=XUSIN(9)_U_XUSIN(10)_U_XUSIN(11)_U_XUSIN(12)_U_XUSIN(13)
+ . ;
+ . ;Phone number (place holder)
+ . S XUSIN(14)=""
+ . ;
+ . ; Get Taxonomy and Specialty
+ . S XUSTXY=0
+ . F  S XUSTXY=$O(^DIC(4,INIEN,"TAXONOMY","B",XUSTXY)) Q:'XUSTXY  D
+ . . S XUSSPC=$P($G(^USC(8932.1,XUSTXY,0)),U,9)
+ . . S XUSTAX=$P($G(^USC(8932.1,XUSTXY,0)),U,7)
+ . . I XUSSPC'="" D
+ . . . I XUSIN(15)="" S XUSIN(15)=XUSSPC Q
+ . . . S XUSIN(15)=XUSIN(15)_";"_XUSSPC
+ . . I XUSTAX'="" D
+ . . . I XUSIN(16)="" S XUSIN(16)=XUSTAX Q
+ . . . S XUSIN(16)=XUSIN(16)_";"_XUSTAX
+ . ;
+ . ; Federal Tax ID
+ . S XUSIN(17)=$G(XUSTAXID)
+ . ; 
+ . ; Medicaid Part A/B
+ . S XUSIN(18)=670899
+ . S XUSIN(19)="VA"_$E(SITE+10000,2,5)
+ . ;
+ . S XUSDATA4=XUSIN(14)_U_XUSIN(15)_U_XUSIN(16)_U_XUSIN(17)_U_XUSIN(18)_U_XUSIN(19)
+ . ;
+ . ; DEA Number
+ . S XUSIN(20)=$P($G(^DIC(4,INIEN,"DEA")),U)
+ . ;
+ . ; get Facility Type and Name 
+ . S XUSFCT=$P($G(^DIC(4,INIEN,3)),U)
+ . I XUSFCT'="" S XUSFCN=$P($G(^DIC(4.1,XUSFCT,0)),U)
+ . I $G(XUSFCN)="PHARM" D
+ . . I $D(^TMP("XUSNPIX",$J,INIEN)) D
+ . . . S XUPHM=^TMP("XUSNPIX",$J,INIEN)
+ . . . ; get NCPDP from ^TMP
+ . . . S XUSIN(21)=$P($G(XUPHM),U)
+ . . . ; get station number from^TMP
+ . . . I $P($G(XUPHM),U,2) S XUSSTA=$P(XUPHM,U,2)
+ . ;
+ . ; VISN Station Number
+ . S XUSIN(22)=XUSSTA
+ . ;
+ . S XUSDATA5=XUSIN(20)_U_XUSIN(21)_U_XUSIN(22)
+ . ;
+ . ; Get BCBS Payer ID Array
+ . K XUSBXID
+ . D INSTID^XUSNPIXU(.XUSBXID)
+ . ;
+ . ; Update counter and save Entry
+ . ;
+ . S COUNT=COUNT+1,TOTREC=TOTREC+1
+ . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_XUSDATA2_U_XUSDATA3_U_XUSDATA4_U_XUSDATA5_U_XUSEOL
+ . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT))
+ . I $D(XUSBXID) D
+ . . S XUSB=""
+ . . F  S XUSB=$O(XUSBXID(XUSB)) Q:XUSB=""  D
+ . . . S COUNT=COUNT+1,TOTREC=TOTREC+1
+ . . . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_XUSDATA2_U_XUSDATA3_U_XUSDATA4_U_XUSDATA5_U_XUSB_U_XUSBXID(XUSB)_U_XUSEOL
+ . . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT))
+ . K XUSIN,XUSDATA1,XUSDATA2,XUSDATA3,XUSDATA4,XUSDATA5,XUSB,XUSBXID
+ . I XUSIZE>MAXSIZE D
+ . . D EOF(XUSRTN)
+ . . D EMAIL(XUSRTN)
+ . . D VMAIL(XUSRTN)
+ . . S ^TMP(XUSRTN,$J,1)=XUSHDR
+ . . S COUNT=1,XUSIZE=0
+ ;
+ D EOF(XUSRTN)
+ K XUSPT,PTPMAIL,LDTCMP,SITE,XUSTAXID
+ Q
+ ;
+EOF(XUSRTN) ;
+ S MSGCNT=MSGCNT+1
+ S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_COUNT_U_DTTM2_U_$G(XUSPROD)_U_XUSEOL
+ S COUNT=COUNT+1
+ S ^TMP(XUSRTN,$J,COUNT)="END OF FILE"_U_XUSEOL
+ Q
+ ;
+ ; EMail the message
+EMAIL(XUSRTN) ;
+ N XMY
+ ; Send email to designated recipient for live release
+ S XMY("XXX@Q-NPS.VA.GOV")=""
+ ;S XMY(DUZ)="" ;use for testing - remove before live    
+ D ESEND
+ Q
+ ;
+VMAIL(XUSRTN) ; verification email
+ N TMP
+ S TMP=^TMP(XUSRTN,$J,1)
+ K ^TMP(XUSRTN,$J)
+ S ^TMP(XUSRTN,$J,1)=$P(TMP,U,1,4)
+ S ^TMP(XUSRTN,$J,2)=""
+ S ^TMP(XUSRTN,$J,3)="TYPE 1 : INSTITUTION FILE (#4)"
+ S ^TMP(XUSRTN,$J,4)=""
+ S ^TMP(XUSRTN,$J,5)="Date/Time of Extract:   "_$P(TMP,U,9)
+ S ^TMP(XUSRTN,$J,6)=""
+ S ^TMP(XUSRTN,$J,7)="Message number: "_MSGCNT_"  Total NPI records: "_(COUNT-2)
+ S ^TMP(XUSRTN,$J,8)=""
+ S ^TMP(XUSRTN,$J,9)="Programmer Notes:   "_XUSVER_" - "_$P(TMP,U,10)
+ ; Send verification email to local mail group and VA Outlook mail group
+ S XMY("G.NPI EXTRACT VERIFICATION")=""
+ D ESEND
+ K ^TMP(XUSRTN)
+ Q
+ESEND N XMTEXT,XMSUB,XMDUN,XMDUZ,XMZ
+ ;Q
+ S XMTEXT="^TMP("""_XUSRTN_""","_$J_","
+ S XMSUB=$TR($P($G(^TMP(XUSRTN,$J,1)),U),":")_"("_$G(XUSPROD)_") NPI EXTRACT TYPE 2"
+ D ^XMD
+ Q
+POA(IEN,INST) ; Check Parent of Association for Institution IEN up to VISN level to see if INST is in the chain
+ N XUSPOA
+ I +$G(INST)=0 Q 0 ; No institution - return false
+POA1 ;
+ I $G(IEN)="" Q 0 ; No IEN remaining to check - return false
+ I $D(XUSPOA(IEN)) Q 0 ; Already reviewed this IEN - possible infinite loop - return false
+ S XUSPOA(IEN)=""
+ S XUSPOA=$P($G(^DIC(4,IEN,7,2,0)),U,2) ; Get parent of this institution
+ I XUSPOA=INST Q 1 ; Found matching institution - return true
+ I IEN=XUSPOA Q 0 ; Top level reached - return false
+ S IEN=XUSPOA ; Reset IEN to check next level
+ G POA1
+ ;
+GETPHARM ;
+ ; this subroutine retrieves data from the OUTPATIENT SITE file
+ ; using the supported Pharmacy API PSS^PSO59.
+ ; It takes the results and places them into a temporary 
+ ; global array that is accessed when processing data
+ ; associated with a pharmacy institution.
+ N XUS59DA,XUSNPIDA,XUSRELDA,PSSTA,Y,X,XUNCP
+ K ^TMP($J,"XUS59"),^TMP("XUSNPIX",$J) ; remove any pre-existing nodes
+ D PSS^PSO59(,"??","XUS59")
+ S XUS59DA=0
+ ; gather data from each Outpatient site entry stored in the pharmacy 
+ ; ^TMP global and build 2nd ^TMP global for later processing
+ F  S XUS59DA=$O(^TMP($J,"XUS59",XUS59DA)) Q:'XUS59DA  D
+ . ;
+ . ;Get Pharmacy NPI institution from API
+ . S XUSNPIDA=$P($G(^TMP($J,"XUS59",XUS59DA,101)),U)
+ . Q:XUSNPIDA']""  ; NPI institution does not exist
+ . ;
+ . ; Get Pharmacy Related Institution from API
+ . S XUSRELDA=$P($G(^TMP($J,"XUS59",XUS59DA,100)),U)
+ . ; get station number off the related institution
+ . S PSSTA=$P($G(^DIC(4,XUSRELDA,99)),U)
+ . ;
+ . ; Get NCPDP number
+ . S XUNCP=""   ;prevent previous values being carried over
+ . S X=XUSNPIDA S D="C",DIC=9002313.56,DIC(0)="" D IX^DIC
+ . I +Y>0 S XUNCP=$$GET1^DIQ(9002313.56,+Y,.02)
+ . S:$G(XUNCP)="" XUNCP=$P($G(^TMP($J,"XUS59",XUS59DA,1008)),U)
+ . ;
+ . ; rebuild the ^TMP global by NPI institution
+ . ; collect necessary data used in the 'PHARM' logic
+ . S ^TMP("XUSNPIX",$J,XUSNPIDA)=XUNCP_"^"_PSSTA ; ncpdp#^station
+ Q
Index: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX3.m
===================================================================
--- WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX3.m	(revision 613)
+++ WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX3.m	(revision 623)
@@ -1,146 +1,166 @@
-XUSNPIX3	;OAK_BP/CMW - NPI EXTRACT REPORT ;01-OCT-06
-	;;8.0;KERNEL;**438,452,453,481**; Jul 10, 1995;Build 21
-	;;Per VHA Directive 2004-038, this routine should not be modified.
-	;
-	; NPI Extract Report
-	;
-	; Input parameter: N/A
-	;
-	; Other relevant variables:
-	;   XUSRTN="XUSNPIX1NV" (current routine name, used for ^XTMP and ^TMP
-	;   XUSRTN="XUSNPIX2NV"  storage subscript)
-	; Storage Global:
-	;   ^XTMP("XUSNPIX1VA",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6
-	;   ^XTMP("XUSNPIX2VA",0)
-	;      where:
-	;      Piece 1 => Purge Date - 1 year in future
-	;      Piece 2 => Create Date - Today
-	;      Piece 3 => Description
-	;      Piece 4 => Last Date Compiled
-	;      Piece 5 => $H last run start time
-	;      Piece 6 => $H last run completion time
-	;      
-	;      Entry Point - ENT called from XUSNPIX1
-	;
-	Q
-	;
-ENT(XUSPROD,XUSVER)	; ENTRY POINT
-	; init variables
-	N XUSRTN,XUSEOL,DTTM3
-	N XUSNPI,XUSDATA,XUSTYP,XUST
-	N NVIEN,IBA0,PROTYPE,NPIDT,NPINEW
-	K ^TMP("XUSNPI",$J)
-	;
-	; Set end of line character
-	S XUSEOL="~~"
-	;
-	S DTTM3=$$HTE^XLFDT($H,"2")
-	;
-	S XUST=""
-	; Loop through IB NON/OTHER VA BILLING PROVIDER records NPI xref
-	S XUSNPI=0
-	F  S XUSNPI=$O(^IBA(355.93,"NPI",XUSNPI)) Q:'XUSNPI  D
-	. S NVIEN=$O(^IBA(355.93,"NPI",XUSNPI,""))
-	. S IBA0=$G(^IBA(355.93,NVIEN,0))
-	. ; Get Provider Type
-	. S PROTYPE=$P(IBA0,U,2)
-	. S XUSTYP=$S(PROTYPE=1:2,1:1)
-	. ; setup NPI array
-	. S ^TMP("XUSNPI",$J,XUSTYP,XUSNPI)=NVIEN
-	. ;
-	; If Provider Type is Individual
-	S XUSRTN="XUSNPIX1NV",NVHEADR=" NPI EXTRACT TYPE 1 (NON VA)",NVTYPE="TYPE 1 (NVA)"
-	I $D(^TMP("XUSNPI",$J,1)) D  I XUST G EXIT
-	. ; Check to see if report is in use
-	. L +^XTMP(XUSRTN):5 I '$T S XUST=1 Q
-	. D INIT(XUSRTN)
-	. D INST(XUSRTN)
-	. D TYPE1^XUSNPIX4(DTTM3,PTPMAIL,SITE,XUSPROD,XUSHDR)
-	. ;
-	. ; Log Run Completion Time
-	. S $P(^XTMP(XUSRTN,0),U,6)=$H
-	. L -^XTMP(XUSRTN)
-	;
-	I '$D(^TMP("XUSNPI",$J,1)) D
-	. D INIT(XUSRTN)
-	. D INST(XUSRTN)
-	. S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_1_U_"Line Count: "_1_U_DTTM3_U_$G(XUSPROD)_XUSEOL
-	. S ^XTMP("XUSNPIXT","1NV")=1_U_0_U_DTTM3
-	. S ^TMP(XUSRTN,$J,2)="END OF FILE"_U_XUSEOL
-	. D EMAIL(XUSRTN)
-	. S ^TMP("XUSNPIXS",$J,3,1)="1 (Non-VA)^0"
-	;
-	; If Provider Type is Facility/Group
-	S XUSRTN="XUSNPIX2NV",NVHEADR=" NPI EXTRACT TYPE 2 (NON VA)",NVTYPE="TYPE 2 (NVA)"
-	I $D(^TMP("XUSNPI",$J,2)) D  I XUST G EXIT
-	. ; Check to see if report is in use
-	. L +^XTMP(XUSRTN):5 I '$T S XUST=1 Q
-	. D INIT(XUSRTN)
-	. D INST(XUSRTN)
-	. D TYPE2^XUSNPIX4(DTTM3,PTPMAIL,SITE,XUSPROD,XUSHDR)
-	. ;
-	. ; Log Run Completion Time
-	. S $P(^XTMP(XUSRTN,0),U,6)=$H
-	. L -^XTMP(XUSRTN)
-	. ;
-	I '$D(^TMP("XUSNPI",$J,2)) D
-	. D INIT(XUSRTN)
-	. D INST(XUSRTN)
-	. S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_1_U_"Line Count: "_1_U_DTTM3_U_$G(XUSPROD)_XUSEOL
-	. S ^XTMP("XUSNPIXT","2NV")=1_U_0_U_DTTM3
-	. S ^TMP(XUSRTN,$J,2)="END OF FILE"_U_XUSEOL
-	. D EMAIL(XUSRTN)
-	. S ^TMP("XUSNPIXS",$J,4,1)="2 (Non-VA)^0"
-	;
-EXIT	;Standard EXIT point
-	K ^TMP("XUSNPI",$J)
-	K XUSNV,P,LDTCMP,PTPMAIL,SITE,NVHEADR,NVTYPE,XUSEOL,DTTM3
-	K XUSHDR
-	;
-	Q
-	;
-INIT(XUSRTN)	; check/init variables
-	N XUSDESC
-	;
-	;Reset Temporary Scratch Global
-	K ^TMP(XUSRTN)
-	S XUSDESC="NPI EXTRACT NON VA - Do Not Delete"
-	S ^XTMP(XUSRTN,0)=(DT+10000)_U_DT_U_XUSDESC_U_DT_U_$H
-	;
-	I '$D(^TMP("XUSNPIXU",$J)) D BCBSID^XUSNPIXU
-	Q
-	;
-INST(XUSRTN)	;Pull station and Institution info
-	N INST,SINFO,DIC4
-	; Pull site info
-	S SINFO=$$SITE^VASITE
-	; Station Number        
-	S SITE=$P(SINFO,U,3)
-	; Institution   
-	S INST=$P(SINFO,U)
-	;
-	; Get institution mailing address
-	I INST D
-	. S DIC4=$G(^DIC(4,INST,4))
-	. S XUSNV(7)=$P(DIC4,U)
-	. S XUSNV(8)=$P(DIC4,U,2)
-	. S XUSNV(9)=$P(DIC4,U,3)
-	. S XUSNV(10)=$P(DIC4,U,4)
-	. I XUSNV(10) S XUSNV(10)=$P($G(^DIC(5,XUSNV(10),0)),U,2)
-	. S XUSNV(11)=$P(DIC4,U,5)
-	. S PTPMAIL=XUSNV(7)_U_XUSNV(8)_U_XUSNV(9)_U_XUSNV(10)_U_XUSNV(11)
-	S XUSHDR="Station: "_SITE_U_XUSNV(9)_U_XUSNV(10)_U_XUSNV(11)_U_NVTYPE_U_XUSVER
-	Q
-	;
-EMAIL(XUSRTN)	; EMAIL THE MESSAGE
-	N XMY
-	; Send email to designated recipient for live release
-	S XMY("XXX@Q-NPS.VA.GOV")=""
-	D ESEND
-	Q
-	;
-ESEND	N XMTEXT,XMSUB,XMDUN,XMDUZ,XMZ,XMMG,DIFROM
-	S XMTEXT="^TMP("""_XUSRTN_""","_$J_","
-	S XMSUB=$TR($P($G(^TMP(XUSRTN,$J,1)),U),":")_"("_$G(XUSPROD)_") "_NVHEADR
-	D ^XMD
-	Q
+XUSNPIX3 ;OAK_BP/CMW - NPI EXTRACT REPORT ;01-OCT-06
+ ;;8.0;KERNEL;**438,452,453**; Jul 10, 1995;Build 36
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
+ ; NPI Extract Report
+ ;
+ ; Input parameter: N/A
+ ;
+ ; Other relevant variables:
+ ;   XUSRTN="XUSNPIX1NV" (current routine name, used for ^XTMP and ^TMP
+ ;   XUSRTN="XUSNPIX2NV"  storage subscript)
+ ; Storage Global:
+ ;   ^XTMP("XUSNPIX1VA",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6
+ ;   ^XTMP("XUSNPIX2VA",0)
+ ;      where:
+ ;      Piece 1 => Purge Date - 1 year in future
+ ;      Piece 2 => Create Date - Today
+ ;      Piece 3 => Description
+ ;      Piece 4 => Last Date Compiled
+ ;      Piece 5 => $H last run start time
+ ;      Piece 6 => $H last run completion time
+ ;      
+ ;      Entry Point - ENT called from XUSNPIX1
+ ;
+ Q
+ ;
+ENT ; ENTRY POINT
+ ; init variables
+ N XUSRTN
+ N XUSNPI,XUSDATA,XUSTYP,XUST
+ N NVIEN,IBA0,PROTYPE,NPIDT,NPINEW
+ K ^TMP("XUSNPI",$J)
+ S XUST="",XUSCNT=2,MSGCNT=0
+ ; Loop through IB NON/OTHER VA BILLING PROVIDER records NPI xref
+ S XUSNPI=0
+ F  S XUSNPI=$O(^IBA(355.93,"NPI",XUSNPI)) Q:'XUSNPI  D
+ . S NVIEN=$O(^IBA(355.93,"NPI",XUSNPI,""))
+ . S IBA0=$G(^IBA(355.93,NVIEN,0))
+ . ; Get Provider Type
+ . S PROTYPE=$P(IBA0,U,2)
+ . S XUSTYP=$S(PROTYPE=1:2,1:1)
+ . ; setup NPI array
+ . S ^TMP("XUSNPI",$J,XUSTYP,XUSNPI)=NVIEN
+ . ;
+ ; If Provider Type is Individual
+ S XUSRTN="XUSNPIX1NV",NVHEADR=" NPI EXTRACT TYPE 1 (NON VA)",NVTYPE="TYPE 1 (NVA)"
+ I $D(^TMP("XUSNPI",$J,1)) D  I XUST G EXIT
+ . ; Check to see if report is in use
+ . L +^XTMP(XUSRTN):5 I '$T S XUST=1 Q
+ . D INIT(XUSRTN)
+ . D INST(XUSRTN)
+ . D TYPE1^XUSNPIX4
+ . D EMAIL(XUSRTN)
+ . D VMAIL(XUSRTN)
+ . ; Log Run Completion Time
+ . S $P(^XTMP(XUSRTN,0),U,6)=$H
+ . L -^XTMP(XUSRTN)
+ ;
+ I '$D(^TMP("XUSNPI",$J,1)) D
+ . D INIT(XUSRTN)
+ . D INST(XUSRTN)
+ . S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_1_U_"Line Count: "_1_U_DTTM3_U_$G(XUSPROD)_XUSEOL
+ . S ^XTMP("XUSNPIXT","1NV")=1_U_0_U_DTTM3
+ . S ^TMP(XUSRTN,$J,2)="END OF FILE"_U_XUSEOL
+ . D EMAIL(XUSRTN),VMAIL(XUSRTN)
+ ;
+ ; If Provider Type is Facility/Group
+ S XUSRTN="XUSNPIX2NV",NVHEADR=" NPI EXTRACT TYPE 2 (NON VA)",NVTYPE="TYPE 2 (NVA)"
+ I $D(^TMP("XUSNPI",$J,2)) D  I XUST G EXIT
+ . ; Check to see if report is in use
+ . L +^XTMP(XUSRTN):5 I '$T S XUST=1 Q
+ . D INIT(XUSRTN)
+ . D INST(XUSRTN)
+ . D TYPE2^XUSNPIX4
+ . D EMAIL(XUSRTN)
+ . D VMAIL(XUSRTN)
+ . ; Log Run Completion Time
+ . S $P(^XTMP(XUSRTN,0),U,6)=$H
+ . L -^XTMP(XUSRTN)
+ . ;
+ I '$D(^TMP("XUSNPI",$J,2)) D
+ . D INIT(XUSRTN)
+ . D INST(XUSRTN)
+ . S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_1_U_"Line Count: "_1_U_DTTM3_U_$G(XUSPROD)_XUSEOL
+ . S ^XTMP("XUSNPIXT","2NV")=1_U_0_U_DTTM3
+ . S ^TMP(XUSRTN,$J,2)="END OF FILE"_U_XUSEOL
+ . D EMAIL(XUSRTN),VMAIL(XUSRTN)
+ ;
+EXIT ;Standard EXIT point
+ K ^TMP("XUSNPI",$J)
+ K XUSNV,P,LDTCMP,PTPMAIL,SITE,NVHEADR,NVTYPE,XUSEOL,DTTM3
+ K MAXSIZE,XUSHDR,XUSCNT,MSGCNT
+ ;
+ Q
+ ;
+INIT(XUSRTN) ; check/init variables
+ N XUSDESC
+ ; Set end of line character
+ S XUSEOL="~~"
+ ; Set to 300000 for live
+ S MAXSIZE=300000
+ S DTTM3=$$HTE^XLFDT($H,"2")
+ ;
+ ;Reset Temporary Scratch Global
+ K ^TMP(XUSRTN)
+ S XUSDESC="NPI EXTRACT NON VA - Do Not Delete"
+ S ^XTMP(XUSRTN,0)=(DT+10000)_U_DT_U_XUSDESC_U_DT_U_$H
+ ;
+ I '$D(^TMP("XUSNPIXU",$J)) D BCBSID^XUSNPIXU
+ Q
+ ;
+INST(XUSRTN) ;Pull station and Institution info
+ N INST,SINFO,DIC4
+ ; Pull site info
+ S SINFO=$$SITE^VASITE
+ ; Station Number        
+ S SITE=$P(SINFO,U,3)
+ ; Institution   
+ S INST=$P(SINFO,U)
+ ;
+ ; Get institution mailing address
+ I INST D
+ . S DIC4=$G(^DIC(4,INST,4))
+ . S XUSNV(7)=$P(DIC4,U)
+ . S XUSNV(8)=$P(DIC4,U,2)
+ . S XUSNV(9)=$P(DIC4,U,3)
+ . S XUSNV(10)=$P(DIC4,U,4)
+ . I XUSNV(10) S XUSNV(10)=$P($G(^DIC(5,XUSNV(10),0)),U,2)
+ . S XUSNV(11)=$P(DIC4,U,5)
+ . S PTPMAIL=XUSNV(7)_U_XUSNV(8)_U_XUSNV(9)_U_XUSNV(10)_U_XUSNV(11)
+ S XUSHDR="Station: "_SITE_U_XUSNV(9)_U_XUSNV(10)_U_XUSNV(11)_U_NVTYPE_U_XUSVER
+ Q
+ ;
+EMAIL(XUSRTN) ; EMAIL THE MESSAGE
+ N XMY
+ ; Send email to designated recipient for live release
+ S XMY("XXX@Q-NPS.VA.GOV")=""
+ ;S XMY(DUZ)="" ;use for testing - remove before live
+ D ESEND
+ Q
+ ;
+VMAIL(XUSRTN) ; Verification email
+ N TMP
+ S TMP=^TMP(XUSRTN,$J,1)
+ K ^TMP(XUSRTN,$J)
+ S ^TMP(XUSRTN,$J,1)=$P(TMP,U,1,4)
+ S ^TMP(XUSRTN,$J,2)=""
+ S ^TMP(XUSRTN,$J,3)=NVHEADR_" (FILE #355.93)"
+ S ^TMP(XUSRTN,$J,4)=""
+ S ^TMP(XUSRTN,$J,5)="Date/Time of Extract:   "_$P(TMP,U,9)
+ S ^TMP(XUSRTN,$J,6)=""
+ S ^TMP(XUSRTN,$J,7)="Message number: "_$S(MSGCNT>0:MSGCNT,1:1)_"  Total NPI records: "_(XUSCNT-2)
+ S ^TMP(XUSRTN,$J,8)=""
+ S ^TMP(XUSRTN,$J,9)="Programmer Notes:   "_XUSVER_" - "_$P(TMP,U,10)
+ ;
+ ; Send verification email to local mail group and VA Outlook mail group
+ S XMY("G.NPI EXTRACT VERIFICATION")=""
+ D ESEND
+ K ^TMP(XUSRTN)
+ Q
+ ;
+ESEND N XMTEXT,XMSUB,XMDUN,XMDUZ,XMZ
+ S XMTEXT="^TMP("""_XUSRTN_""","_$J_","
+ S XMSUB=$TR($P($G(^TMP(XUSRTN,$J,1)),U),":")_"("_$G(XUSPROD)_") "_NVHEADR
+ D ^XMD
+ Q
Index: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX4.m
===================================================================
--- WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX4.m	(revision 613)
+++ WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX4.m	(revision 623)
@@ -1,273 +1,236 @@
-XUSNPIX4	;OAK_BP/CMW - NPI EXTRACT REPORT ;11:47 AM  28 Jul 2009
-	;;8.0;KERNEL;**438,452,453,481,WV**; Jul 10, 1995;Build 21
-	;;Per VHA Directive 2004-038, this routine should not be modified.
-	;
-	; NPI Extract Report
-	;
-	; Input parameter: N/A
-	;
-	; Other relevant variables:
-	;   XUSRTN="XUSNPIX1NV" (current routine name, used for ^XTMP and ^TMP
-	;   XUSRTN="XUSNPIX2NV"  storage subscript)
-	; Storage Global:
-	;   ^XTMP("XUSNPIX1VA",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6
-	;   ^XTMP("XUSNPIX2VA",0)
-	;      where:
-	;      Piece 1 => Purge Date - 1 year in future
-	;      Piece 2 => Create Date - Today
-	;      Piece 3 => Description
-	;      Piece 4 => Last Date Compiled
-	;      Piece 5 => $H last run start time
-	;      Piece 6 => $H last run completion time
-	;
-	;      Entry Point - ENT called from XUSNPIX1
-	;
-	Q
-	;
-	; Individual records
-TYPE1(DTTM3,PTPMAIL,SITE,XUSPROD,XUSHDR)	;
-	N IBA0,NVIEN,XUSNPI,MAXSIZE,XUSEOL,XUSCNT
-	N XUSI,XUSNM,XUSNV,XLFNC,XUSIZE,XUSDT,XUSNEW
-	N TOTREC1
-	;
-	; Set Maximum Message Size
-	S MAXSIZE=300000
-	;
-	; Set end of line character
-	S XUSEOL="~~"
-	;
-	S XUSCNT=1,(TOTREC1,MSGCNT,XUSIZE)=0
-	S XUSNPI=""
-	F  S XUSNPI=$O(^TMP("XUSNPI",$J,1,XUSNPI)) Q:'XUSNPI  D
-	. S XUSDATA=XUSNPI
-	. S NVIEN=$G(^TMP("XUSNPI",$J,1,XUSNPI))
-	. ;
-	. F XUSI=1:1:29 S XUSNV(XUSI)=""
-	. S IBA0=$G(^IBA(355.93,NVIEN,0))
-	. S XUSNM=$P(IBA0,U)
-	. ; Break Name into components
-	. I XUSNM'="" D
-	. . ;Begin WorldVistA Change; 07/28/2009
-	. . ;S XLFNC=XUSNM D FORMAT^XLFNAME7(.XLFNC,,,,0)
-	. . S XLFNC=XUSNM S XLFNC=$$FORMAT^XLFNAME7(.XLFNC,,,,0)
-	. . ;End WorldVistA change
-	. . S XUSNV(2)=XLFNC("GIVEN"),XUSNV(3)=XLFNC("MIDDLE"),XUSNV(4)=XLFNC("FAMILY")
-	. . I XLFNC("SUFFIX")'="" S XUSNV(4)=XUSNV(4)_" "_XLFNC("SUFFIX")
-	. . K XLFNC
-	. S XUSDATA=XUSDATA_U_XUSNV(2)_U_XUSNV(3)_U_XUSNV(4)
-	. S XUSNV(5)=1 ;TYPE
-	. ;
-	. ; DOB (place holder)
-	. S XUSNV(6)=""
-	. S XUSDATA=XUSDATA_U_XUSNV(5)_U_XUSNV(6)
-	. ;
-	. ; Pay to Provider Address (7-11)
-	. S XUSDATA=XUSDATA_U_PTPMAIL
-	. ;
-	. ; Servicing Provider Address
-	. S XUSNV(12)=$P(IBA0,U,5)
-	. S XUSNV(13)=$P(IBA0,U,10)
-	. S XUSNV(14)=$P(IBA0,U,6)
-	. S XUSNV(15)=$P(IBA0,U,7)
-	. I XUSNV(15) S XUSNV(15)=$P($G(^DIC(5,XUSNV(12),0)),U,2)
-	. S XUSNV(16)=$P(IBA0,U,8)
-	. S XUSDATA=XUSDATA_U_XUSNV(12)_U_XUSNV(13)_U_XUSNV(14)_U_XUSNV(15)_U_XUSNV(16)
-	. ;
-	. ; Office Phone number (place holder)
-	. S XUSNV(17)=""
-	. ;
-	. ; Degree Description / Degree Code (place holder)
-	. S XUSNV(18)=""
-	. S XUSNV(19)=""
-	. ;
-	. ; Get Taxonomy and specialty codes
-	. N NVTX,NVSPC,NVTAX
-	. S NVTX=0
-	. F  S NVTX=$O(^IBA(355.93,NVIEN,"TAXONOMY","B",NVTX)) Q:'NVTX  D
-	. . S NVSPC=$P($G(^USC(8932.1,NVTX,0)),U,9)
-	. . S NVTAX=$P($G(^USC(8932.1,NVTX,0)),U,7)
-	. . I NVSPC'="" D
-	. . . I XUSNV(20)="" S XUSNV(20)=NVSPC Q
-	. . . S XUSNV(20)=XUSNV(20)_";"_NVSPC
-	. . I NVTAX'="" D
-	. . . I XUSNV(21)="" S XUSNV(21)=NVTAX Q
-	. . . S XUSNV(21)=XUSNV(21)_";"_NVTAX
-	. ;
-	. ; Fed tax ID
-	. S XUSNV(22)=$P($G(IBA0),U,9)
-	. ;
-	. S XUSDATA=XUSDATA_U_XUSNV(17)_U_XUSNV(18)_U_XUSNV(19)_U_XUSNV(20)_U_XUSNV(21)_U_XUSNV(22)
-	. ;
-	. ; Medicare Part A/B
-	. S XUSNV(23)=670899
-	. S XUSNV(24)="VA"_$E(SITE+10000,2,5)
-	. ;
-	. ; State Lic and DEA (place holder)
-	. S XUSNV(25)=""
-	. S XUSNV(26)=""
-	. ;
-	. ; VISN Station
-	. S XUSNV(27)=SITE
-	. ;
-	. S XUSDATA=XUSDATA_U_XUSNV(23)_U_XUSNV(24)_U_XUSNV(25)_U_XUSNV(26)_U_XUSNV(27)
-	. ;
-	. ;BCBS info
-	. K XUSBXID
-	. D NNVAID^XUSNPIXU(NVIEN,.XUSBXID)
-	. ;
-	. ;Update counter and save Entry
-	. N XUSB
-	. S XUSCNT=XUSCNT+1,TOTREC1=TOTREC1+1
-	. S ^TMP(XUSRTN,$J,XUSCNT)=XUSDATA_U_XUSEOL
-	. S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,XUSCNT))
-	. I $D(XUSBXID) D
-	. . S XUSB=""
-	. . F  S XUSB=$O(XUSBXID(XUSB)) Q:XUSB=""  D
-	. . . S XUSCNT=XUSCNT+1,TOTREC1=TOTREC1+1
-	. . . S ^TMP(XUSRTN,$J,XUSCNT)=XUSDATA_U_XUSB_U_XUSEOL
-	. . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,XUSCNT))
-	. I XUSIZE>MAXSIZE D
-	. . D EOF1(XUSRTN)
-	. . D EMAIL^XUSNPIX3(XUSRTN)
-	. . K ^TMP(XUSRTN,$J)
-	. . S ^TMP("XUSNPIXS",$J,3,MSGCNT)="1 (Non-VA)^"_(XUSCNT-2)
-	. . S ^TMP(XUSRTN,$J,1)=XUSHDR
-	. . S XUSCNT=1,XUSIZE=0
-	. K XUSNV,XUSDATA,XUSBXID
-	;
-	D EOF1(XUSRTN)
-	;
-	; Send last message (if it has records)
-	I $G(XUSCNT)>1 D
-	. D EMAIL^XUSNPIX3(XUSRTN)
-	. K ^TMP(XUSRTN,$J)
-	. S ^TMP("XUSNPIXS",$J,3,MSGCNT)="1 (Non-VA)^"_($G(XUSCNT)-2)
-	;
-	; Update Summary
-	S ^XTMP("XUSNPIXT","1NV")=MSGCNT_U_TOTREC1_U_DTTM3
-	Q
-	;
-EOF1(XUSRTN)	;
-	Q:$G(XUSCNT)=1
-	S MSGCNT=MSGCNT+1
-	S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_XUSCNT_U_DTTM3_U_$G(XUSPROD)_U_XUSEOL
-	S XUSCNT=XUSCNT+1
-	S ^TMP(XUSRTN,$J,XUSCNT)="END OF FILE"_U_XUSEOL
-	Q
-	;
-TYPE2(DTTM3,PTPMAIL,SITE,XUSPROD,XUSHDR)	;Facility/Group
-	N IBA0,NVIEN,XUSNPI,MAXSIZE,XUSEOL,XUSCNT
-	N XUSNV,XUSI,XUSNM,XLFNC,MSGCNT,XUSIZE,XUSDT,XUSNEW,TOTREC2
-	;
-	; Set Maximum Message Size
-	S MAXSIZE=300000
-	;
-	; Set end of line character
-	S XUSEOL="~~"
-	;
-	S XUSNPI=""
-	S XUSCNT=1,(TOTREC2,MSGCNT,XUSIZE)=0
-	F  S XUSNPI=$O(^TMP("XUSNPI",$J,2,XUSNPI)) Q:'XUSNPI  D
-	. S XUSDATA=XUSNPI
-	. S NVIEN=$G(^TMP("XUSNPI",$J,2,XUSNPI))
-	. ;
-	. F XUSI=1:1:24 S XUSNV(XUSI)=""
-	. S IBA0=$G(^IBA(355.93,NVIEN,0))
-	. ;Get Organization name
-	. S XUSNV(2)=$P(IBA0,U)
-	. ;Type
-	. S XUSNV(3)=2
-	. ;
-	. S XUSDATA=XUSDATA_U_XUSNV(2)_U_XUSNV(3)
-	. ;
-	. ; Pay to Provider Address (4-8)
-	. S XUSDATA=XUSDATA_U_PTPMAIL
-	. ;
-	. ; Servicing Provider Address
-	. S XUSNV(9)=$P(IBA0,U,5)
-	. S XUSNV(10)=$P(IBA0,U,10)
-	. S XUSNV(11)=$P(IBA0,U,6)
-	. S XUSNV(12)=$P(IBA0,U,7)
-	. I XUSNV(12) S XUSNV(12)=$P($G(^DIC(5,XUSNV(12),0)),U,2)
-	. S XUSNV(13)=$P(IBA0,U,8)
-	. S XUSDATA=XUSDATA_U_XUSNV(9)_U_XUSNV(10)_U_XUSNV(11)_U_XUSNV(12)_U_XUSNV(13)
-	. ;
-	. ;Office Phone number (place holder)
-	. S XUSNV(14)=""
-	. ;
-	. ; get Taxonomy and Specialty
-	. N NVTX,NVSPC,NVTAX
-	. S NVTX=0
-	. F  S NVTX=$O(^IBA(355.93,NVIEN,"TAXONOMY","B",NVTX)) Q:'NVTX  D
-	. . S NVSPC=$P($G(^USC(8932.1,NVTX,0)),U,9)
-	. . S NVTAX=$P($G(^USC(8932.1,NVTX,0)),U,7)
-	. . I NVSPC'="" D
-	. . . I XUSNV(15)="" S XUSNV(15)=NVSPC Q
-	. . . S XUSNV(15)=XUSNV(15)_";"_NVSPC
-	. . I NVTAX'="" D
-	. . . I XUSNV(16)="" S XUSNV(16)=NVTAX Q
-	. . . S XUSNV(16)=XUSNV(16)_";"_NVTAX
-	. ;
-	. ; Fed Tax ID
-	. S XUSNV(17)=$P($G(IBA0),U,9)
-	. ;
-	. ;Medicare A/B
-	. S XUSNV(18)=670899
-	. S XUSNV(19)="VA"_$E(SITE+10000,2,5)
-	. ;
-	. S XUSDATA=XUSDATA_U_XUSNV(14)_U_XUSNV(15)_U_XUSNV(16)_U_XUSNV(17)_U_XUSNV(18)_U_XUSNV(19)
-	. ;
-	. ;State License Number
-	. S XUSNV(20)=$P($G(IBA0),U,12)
-	. ;
-	. ;DEA Number (place holder)
-	. S XUSNV(21)=""
-	. ;
-	. ;VISN STATION ID
-	. S XUSNV(22)=SITE
-	. ;
-	. S XUSDATA=XUSDATA_U_XUSNV(20)_U_XUSNV(21)_U_XUSNV(22)
-	. ;
-	. ;BCBS info
-	. K XUSBXID
-	. D NNVAID^XUSNPIXU(NVIEN,.XUSBXID)
-	. ;
-	. ;Update counter and save Entry
-	. N XUSB
-	. S XUSCNT=XUSCNT+1,TOTREC2=TOTREC2+1
-	. S ^TMP(XUSRTN,$J,XUSCNT)=XUSDATA_U_XUSEOL
-	. S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,XUSCNT))
-	. I $D(XUSBXID) D
-	. . S XUSB=""
-	. . F  S XUSB=$O(XUSBXID(XUSB)) Q:XUSB=""  D
-	. . . S XUSCNT=XUSCNT+1,TOTREC2=TOTREC2+1
-	. . . S ^TMP(XUSRTN,$J,XUSCNT)=XUSDATA_U_XUSB_U_XUSEOL
-	. . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,XUSCNT))
-	. I XUSIZE>MAXSIZE D
-	. . D EOF2(XUSRTN)
-	. . D EMAIL^XUSNPIX3(XUSRTN)
-	. . K ^TMP(XUSRTN,$J)
-	. . S ^TMP("XUSNPIXS",$J,4,MSGCNT)="2 (Non-VA)^"_(XUSCNT-2)
-	. . S ^TMP(XUSRTN,$J,1)=XUSHDR
-	. . S XUSCNT=1,XUSIZE=0
-	. K XUSNV,XUSDATA,XUSB,XUSBXID
-	;
-	D EOF2(XUSRTN)
-	;
-	; Send last message (if it has records)
-	I $G(XUSCNT)>1 D
-	. D EMAIL^XUSNPIX3(XUSRTN)
-	. K ^TMP(XUSRTN,$J)
-	. S ^TMP("XUSNPIXS",$J,4,MSGCNT)="2 (Non-VA)^"_($G(XUSCNT)-2)
-	;
-	; Update Summary
-	S ^XTMP("XUSNPIXT","2NV")=MSGCNT_U_TOTREC2_U_DTTM3
-	Q
-	;
-EOF2(XUSRTN)	;
-	Q:$G(XUSCNT)=1
-	S MSGCNT=MSGCNT+1
-	S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_XUSCNT_U_DTTM3_U_$G(XUSPROD)_U_XUSEOL
-	S XUSCNT=XUSCNT+1
-	S ^TMP(XUSRTN,$J,XUSCNT)="END OF FILE"_U_XUSEOL
-	Q
+XUSNPIX4 ;OAK_BP/CMW - NPI EXTRACT REPORT ;01-OCT-06
+ ;;8.0;KERNEL;**438,452,453**; Jul 10, 1995;Build 36
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
+ ; NPI Extract Report
+ ;
+ ; Input parameter: N/A
+ ;
+ ; Other relevant variables:
+ ;   XUSRTN="XUSNPIX1NV" (current routine name, used for ^XTMP and ^TMP
+ ;   XUSRTN="XUSNPIX2NV"  storage subscript)
+ ; Storage Global:
+ ;   ^XTMP("XUSNPIX1VA",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6
+ ;   ^XTMP("XUSNPIX2VA",0)
+ ;      where:
+ ;      Piece 1 => Purge Date - 1 year in future
+ ;      Piece 2 => Create Date - Today
+ ;      Piece 3 => Description
+ ;      Piece 4 => Last Date Compiled
+ ;      Piece 5 => $H last run start time
+ ;      Piece 6 => $H last run completion time
+ ;      
+ ;      Entry Point - ENT called from XUSNPIX1
+ ;
+ Q
+ ;
+ ; Individual records
+TYPE1 ;
+ N IBA0,NVIEN,XUSNPI
+ N XUSI,XUSNM,XUSNV,XLFNC,XUSIZE,XUSDT,XUSNEW
+ N TOTREC1,TOTREC2
+ S XUSCNT=1,(TOTREC1,MSGCNT,XUSIZE)=0
+ S XUSNPI=""
+ F  S XUSNPI=$O(^TMP("XUSNPI",$J,1,XUSNPI)) Q:'XUSNPI  D
+ . S XUSDATA=XUSNPI
+ . S NVIEN=$G(^TMP("XUSNPI",$J,1,XUSNPI))
+ . ;
+ . F XUSI=1:1:29 S XUSNV(XUSI)=""
+ . S IBA0=$G(^IBA(355.93,NVIEN,0))
+ . S XUSNM=$P(IBA0,U)
+ . ; Break Name into components
+ . I XUSNM'="" D
+ . . S XLFNC=XUSNM D FORMAT^XLFNAME7(.XLFNC,,,,0)
+ . . S XUSNV(2)=XLFNC("GIVEN"),XUSNV(3)=XLFNC("MIDDLE"),XUSNV(4)=XLFNC("FAMILY")
+ . . I XLFNC("SUFFIX")'="" S XUSNV(4)=XUSNV(4)_" "_XLFNC("SUFFIX")
+ . . K XLFNC
+ . S XUSDATA=XUSDATA_U_XUSNV(2)_U_XUSNV(3)_U_XUSNV(4)
+ . S XUSNV(5)=1 ;TYPE
+ . ;                                    
+ . ; DOB (place holder)
+ . S XUSNV(6)=""
+ . S XUSDATA=XUSDATA_U_XUSNV(5)_U_XUSNV(6)
+ . ;
+ . ; Pay to Provider Address (7-11)
+ . S XUSDATA=XUSDATA_U_PTPMAIL
+ . ;
+ . ; Servicing Provider Address
+ . S XUSNV(12)=$P(IBA0,U,5)
+ . S XUSNV(13)=$P(IBA0,U,10)
+ . S XUSNV(14)=$P(IBA0,U,6)
+ . S XUSNV(15)=$P(IBA0,U,7)
+ . I XUSNV(15) S XUSNV(15)=$P($G(^DIC(5,XUSNV(12),0)),U,2)
+ . S XUSNV(16)=$P(IBA0,U,8)
+ . S XUSDATA=XUSDATA_U_XUSNV(12)_U_XUSNV(13)_U_XUSNV(14)_U_XUSNV(15)_U_XUSNV(16)
+ . ;
+ . ; Office Phone number (place holder)
+ . S XUSNV(17)=""
+ . ;
+ . ; Degree Description / Degree Code (place holder)
+ . S XUSNV(18)=""
+ . S XUSNV(19)=""
+ . ;
+ . ; Get Taxonomy and specialty codes
+ . N NVTX,NVSPC,NVTAX
+ . S NVTX=0
+ . F  S NVTX=$O(^IBA(355.93,NVIEN,"TAXONOMY","B",NVTX)) Q:'NVTX  D
+ . . S NVSPC=$P($G(^USC(8932.1,NVTX,0)),U,9)
+ . . S NVTAX=$P($G(^USC(8932.1,NVTX,0)),U,7)
+ . . I NVSPC'="" D
+ . . . I XUSNV(20)="" S XUSNV(20)=NVSPC Q
+ . . . S XUSNV(20)=XUSNV(20)_";"_NVSPC
+ . . I NVTAX'="" D
+ . . . I XUSNV(21)="" S XUSNV(21)=NVTAX Q
+ . . . S XUSNV(21)=XUSNV(21)_";"_NVTAX
+ . ;
+ . ; Fed tax ID
+ . S XUSNV(22)=$P($G(IBA0),U,9)
+ . ;
+ . S XUSDATA=XUSDATA_U_XUSNV(17)_U_XUSNV(18)_U_XUSNV(19)_U_XUSNV(20)_U_XUSNV(21)_U_XUSNV(22)
+ . ;
+ . ; Medicare Part A/B
+ . S XUSNV(23)=670899
+ . S XUSNV(24)="VA"_$E(SITE+10000,2,5)
+ . ;
+ . ; State Lic and DEA (place holder)
+ . S XUSNV(25)=""
+ . S XUSNV(26)=""
+ . ;
+ . ; VISN Station
+ . S XUSNV(27)=SITE
+ . ;
+ . S XUSDATA=XUSDATA_U_XUSNV(23)_U_XUSNV(24)_U_XUSNV(25)_U_XUSNV(26)_U_XUSNV(27)
+ . ;
+ . ;BCBS info
+ . K XUSBXID
+ . D NNVAID^XUSNPIXU(NVIEN,.XUSBXID)
+ . ;
+ . ;Update counter and save Entry
+ . N XUSB
+ . S XUSCNT=XUSCNT+1,TOTREC1=TOTREC1+1
+ . S ^TMP(XUSRTN,$J,XUSCNT)=XUSDATA_U_XUSEOL
+ . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,XUSCNT))
+ . I $D(XUSBXID) D
+ . . S XUSB=""
+ . . F  S XUSB=$O(XUSBXID(XUSB)) Q:XUSB=""  D
+ . . . S XUSCNT=XUSCNT+1,TOTREC1=TOTREC1+1
+ . . . S ^TMP(XUSRTN,$J,XUSCNT)=XUSDATA_U_XUSB_U_XUSEOL
+ . . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,XUSCNT))
+ . I XUSIZE>MAXSIZE D
+ . . D EOF1(XUSRTN)
+ . . D EMAIL^XUSNPIX3(XUSRTN)
+ . . D VMAIL^XUSNPIX3(XUSRTN)
+ . . S ^TMP(XUSRTN,$J,1)=XUSHDR
+ . . S XUSCNT=1,XUSIZE=0
+ . K XUSNV,XUSDATA,XUSBXID
+ ;
+ D EOF1(XUSRTN)
+ S ^XTMP("XUSNPIXT","1NV")=MSGCNT_U_TOTREC1_U_DTTM3
+ Q
+ ;
+EOF1(XUSRTN) ;
+ S MSGCNT=MSGCNT+1
+ S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_XUSCNT_U_DTTM3_U_$G(XUSPROD)_U_XUSEOL
+ S XUSCNT=XUSCNT+1
+ S ^TMP(XUSRTN,$J,XUSCNT)="END OF FILE"_U_XUSEOL
+ Q
+ ;
+TYPE2 ;Facility/Group
+ N IBA0,NVIEN,XUSNPI
+ N XUSNV,XUSI,XUSNM,XLFNC,MSGCNT,XUSIZE,XUSDT,XUSNEW
+ S XUSNPI=""
+ S XUSCNT=1,(TOTREC2,MSGCNT,XUSIZE)=0
+ F  S XUSNPI=$O(^TMP("XUSNPI",$J,2,XUSNPI)) Q:'XUSNPI  D
+ . S XUSDATA=XUSNPI
+ . S NVIEN=$G(^TMP("XUSNPI",$J,2,XUSNPI))
+ . ;
+ . F XUSI=1:1:24 S XUSNV(XUSI)=""
+ . S IBA0=$G(^IBA(355.93,NVIEN,0))
+ . ;Get Organization name  
+ . S XUSNV(2)=$P(IBA0,U)
+ . ;Type
+ . S XUSNV(3)=2
+ . ;
+ . S XUSDATA=XUSDATA_U_XUSNV(2)_U_XUSNV(3)
+ . ;
+ . ; Pay to Provider Address (4-8)
+ . S XUSDATA=XUSDATA_U_PTPMAIL
+ . ;
+ . ; Servicing Provider Address
+ . S XUSNV(9)=$P(IBA0,U,5)
+ . S XUSNV(10)=$P(IBA0,U,10)
+ . S XUSNV(11)=$P(IBA0,U,6)
+ . S XUSNV(12)=$P(IBA0,U,7)
+ . I XUSNV(12) S XUSNV(12)=$P($G(^DIC(5,XUSNV(12),0)),U,2)
+ . S XUSNV(13)=$P(IBA0,U,8)
+ . S XUSDATA=XUSDATA_U_XUSNV(9)_U_XUSNV(10)_U_XUSNV(11)_U_XUSNV(12)_U_XUSNV(13)
+ . ;
+ . ;Office Phone number (place holder)
+ . S XUSNV(14)=""
+ . ; 
+ . ; get Taxonomy and Specialty
+ . N NVTX,NVSPC,NVTAX
+ . S NVTX=0
+ . F  S NVTX=$O(^IBA(355.93,NVIEN,"TAXONOMY","B",NVTX)) Q:'NVTX  D
+ . . S NVSPC=$P($G(^USC(8932.1,NVTX,0)),U,9)
+ . . S NVTAX=$P($G(^USC(8932.1,NVTX,0)),U,7)
+ . . I NVSPC'="" D
+ . . . I XUSNV(15)="" S XUSNV(15)=NVSPC Q
+ . . . S XUSNV(15)=XUSNV(15)_";"_NVSPC
+ . . I NVTAX'="" D
+ . . . I XUSNV(16)="" S XUSNV(16)=NVTAX Q
+ . . . S XUSNV(16)=XUSNV(16)_";"_NVTAX
+ . ;
+ . ; Fed Tax ID
+ . S XUSNV(17)=$P($G(IBA0),U,9)
+ . ;
+ . ;Medicare A/B
+ . S XUSNV(18)=670899
+ . S XUSNV(19)="VA"_$E(SITE+10000,2,5)
+ . ;
+ . S XUSDATA=XUSDATA_U_XUSNV(14)_U_XUSNV(15)_U_XUSNV(16)_U_XUSNV(17)_U_XUSNV(18)_U_XUSNV(19)
+ . ;
+ . ;State License Number
+ . S XUSNV(20)=$P($G(IBA0),U,12)
+ . ;
+ . ;DEA Number (place holder)
+ . S XUSNV(21)=""
+ . ;
+ . ;VISN STATION ID
+ . S XUSNV(22)=SITE
+ . ;
+ . S XUSDATA=XUSDATA_U_XUSNV(20)_U_XUSNV(21)_U_XUSNV(22)
+ . ;
+ . ;BCBS info
+ . K XUSBXID
+ . D NNVAID^XUSNPIXU(NVIEN,.XUSBXID)
+ . ;
+ . ;Update counter and save Entry
+ . N XUSB
+ . S XUSCNT=XUSCNT+1,TOTREC2=TOTREC2+1
+ . S ^TMP(XUSRTN,$J,XUSCNT)=XUSDATA_U_XUSEOL
+ . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,XUSCNT))
+ . I $D(XUSBXID) D
+ . . S XUSB=""
+ . . F  S XUSB=$O(XUSBXID(XUSB)) Q:XUSB=""  D
+ . . . S XUSCNT=XUSCNT+1,TOTREC2=TOTREC2+1
+ . . . S ^TMP(XUSRTN,$J,XUSCNT)=XUSDATA_U_XUSB_U_XUSEOL
+ . . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,XUSCNT))
+ . I XUSIZE>MAXSIZE D
+ . . D EOF2(XUSRTN)
+ . . D EMAIL^XUSNPIX3(XUSRTN)
+ . . D VMAIL^XUSNPIX3(XUSRTN)
+ . . S ^TMP(XUSRTN,$J,1)=XUSHDR
+ . . S XUSCNT=1,XUSIZE=0
+ . K XUSNV,XUSDATA,XUSB,XUSBXID
+ ;
+ D EOF2(XUSRTN)
+ S ^XTMP("XUSNPIXT","2NV")=MSGCNT_U_TOTREC2_U_DTTM3
+ Q
+ ;
+EOF2(XUSRTN) ;
+ S MSGCNT=MSGCNT+1
+ S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_XUSCNT_U_DTTM3_U_$G(XUSPROD)_U_XUSEOL
+ S XUSCNT=XUSCNT+1
+ S ^TMP(XUSRTN,$J,XUSCNT)="END OF FILE"_U_XUSEOL
+ Q
Index: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX5.m
===================================================================
--- WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX5.m	(revision 613)
+++ WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX5.m	(revision 623)
@@ -1,96 +1,100 @@
-XUSNPIX5	;OAK_BP/CMW - NPI EXTRACT REPORT ;7/7/08  17:45
-	;;8.0;KERNEL;**453,481**; Jul 10, 1995;Build 21
-	;;Per VHA Directive 2004-038, this routine should not be modified.
-	;
-	; NPI Extract Report Mailer routine
-	;
-	; Input parameter: XUSRTN
-	;
-	; Other relevant variables:
-	;   XUSRTN="XUSNPIX1" (current routine name, used for ^XTMP and ^TMP
-	;                         storage subscript)
-	; Storage Global:
-	;   ^XTMP("XUSNPIX1",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6
-	;      where:
-	;      Piece 1 => Purge Date - 1 year in future
-	;      Piece 2 => Create Date - Today
-	;      Piece 3 => Description
-	;      Piece 4 => Last Date Compiled
-	;      Piece 5 => $H last run start time
-	;      Piece 6 => $H last run completion time
-	;
-	;   ^XTMP("XUSNPIX1",1) = DATA
-	;               
-	;          XUSNPI => Unique NPI of entry
-	;          LDT => Last Date Run, VA Fileman Format
-	;
-	Q
-	;
-EMAIL(XUSRTN)	; EMAIL THE MESSAGE
-	; Add domain name if it does not exist
-	N XUSFOC,DLAYGO,DA,DIC,DIE,DR,X,Y
-	I '$$FIND1^DIC(4.2,,"QX","Q-NPS.VA.GOV","B") D
-	. S XUSFOC=$O(^DIC(4.2,"B","FOC-AUSTIN.VA.GOV",0)) I 'XUSFOC Q
-	. I XUSFOC=$O(^DIC(4.2,"B","FOC-AUSTIN.VA.GOV",""),-1) D
-	. . S DIC="^DIC(4.2,",X="Q-NPS.VA.GOV",DIC(0)="L",DLAYGO=4.2 D ^DIC K DLAYGO
-	. . S DIE=DIC,DA=+Y
-	. . S DR="1///NS;2///^S X=XUSFOC;1.7///YES;6.2///NPS;"
-	. . D ^DIE
-	;
-	N XMY
-	; Send email to designated recipient for live release
-	S XMY("XXX@Q-NPS.VA.GOV")=""
-	D ESEND
-	Q
-	;
-SMAIL(XUSRTN,XUSPROD,XUSVER,DTTM)	; Summary email
-	N HYPHEN,L,M,N,T,TMP,T1,T2,T1NV,T2NV,XMY
-	K ^TMP(XUSRTN,$J)
-	S T1=$G(^XTMP(XUSRTN,1))
-	S T2=$G(^XTMP(XUSRTN,2))
-	S T1NV=$G(^XTMP(XUSRTN,"1NV"))
-	S T2NV=$G(^XTMP(XUSRTN,"2NV"))
-	S ^TMP(XUSRTN,$J,1)="SUMMARY"
-	S ^TMP(XUSRTN,$J,2)="-------"
-	S ^TMP(XUSRTN,$J,3)=^XTMP(XUSRTN,"H")_"  "_DTTM
-	S ^TMP(XUSRTN,$J,4)=""
-	S ^TMP(XUSRTN,$J,5)="Type 1  NEW PERSON FILE (#200)          "_$J(+$P(T1,U),3)_" Message(s) Totaling "_$J(+$P(T1,U,2),7)_" NPI records."
-	S ^TMP(XUSRTN,$J,6)="Type 2  INSITUTION FILE (#4)            "_$J(+$P(T2,U),3)_" Message(s) Totaling "_$J(+$P(T2,U,2),7)_" NPI records."
-	S ^TMP(XUSRTN,$J,7)="Type 1  NON VA Individual (#355.93)     "_$J(+$P(T1NV,U),3)_" Message(s) Totaling "_$J(+$P(T1NV,U,2),7)_" NPI records."
-	S ^TMP(XUSRTN,$J,8)="Type 2  NON VA Facility/Group (#355.93) "_$J(+$P(T2NV,U),3)_" Message(s) Totaling "_$J(+$P(T2NV,U,2),7)_" NPI records."
-	S ^TMP(XUSRTN,$J,9)=""
-	S ^TMP(XUSRTN,$J,10)="Programmer Notes:   "_XUSVER_" - "_$G(XUSPROD)
-	;
-	;Summary Detail
-	;
-	S HYPHEN="",$P(HYPHEN,"-",84)="-"
-	;
-	S ^TMP(XUSRTN,$J,11)=""
-	S ^TMP(XUSRTN,$J,12)=HYPHEN
-	S ^TMP(XUSRTN,$J,13)=""
-	S ^TMP(XUSRTN,$J,14)="MESSAGE DETAILS"
-	S ^TMP(XUSRTN,$J,15)="---------------"
-	S ^TMP(XUSRTN,$J,16)=""
-	S ^TMP(XUSRTN,$J,17)="TYPE      "_$J("MESSAGE NUMBER",20)_$J("RECORD COUNT",20)
-	S ^TMP(XUSRTN,$J,18)="----------"_$J("--------------",20)_$J("------------",20)
-	;
-	S L=18,T="" F  S T=$O(^TMP("XUSNPIXS",$J,T)) Q:'T  S M=0 F  S M=$O(^TMP("XUSNPIXS",$J,T,M)) Q:'M  D
-	.S N=$G(^TMP("XUSNPIXS",$J,T,M))
-	.S L=L+1
-	.S ^TMP(XUSRTN,$J,L)=$E($P(N,U)_"          ",1,10)_$J(M,16)_$J($P(N,U,2),24)
-	S L=L+1,^TMP(XUSRTN,$J,L)=""
-	S L=L+1,^TMP(XUSRTN,$J,L)=HYPHEN
-	; Send verification email to local mail group and VA Outlook mail group
-	S XMY("G.NPI EXTRACT VERIFICATION")=""
-	N XMTEXT,XMSUB,XMDUN,XMDUZ,XMZ,XMMG,DIFROM
-	S XMTEXT="^TMP("""_XUSRTN_""","_$J_","
-	S XMSUB=$TR($P(^XTMP(XUSRTN,"H"),U),":")_"("_$G(XUSPROD)_") NPI CROSSWALK EXTRACT SUMMARY "
-	D ^XMD
-	K ^TMP(XUSRTN,$J)
-	Q
-	;
-ESEND	N XMTEXT,XMSUB,XMDUN,XMDUZ,XMZ,XMMG,DIFROM
-	S XMTEXT="^TMP("""_XUSRTN_""","_$J_","
-	S XMSUB=$TR($P($G(^TMP(XUSRTN,$J,1)),U),":")_"("_$G(XUSPROD)_") NPI EXTRACT TYPE 1 "
-	D ^XMD
-	Q
+XUSNPIX5 ;OAK_BP/CMW - NPI EXTRACT REPORT ;01-OCT-06
+ ;;8.0;KERNEL;**453**; Jul 10, 1995;Build 36
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
+ ; NPI Extract Report Mailer routine
+ ;
+ ; Input parameter: XUSRTN
+ ;
+ ; Other relevant variables:
+ ;   XUSRTN="XUSNPIX1" (current routine name, used for ^XTMP and ^TMP
+ ;                         storage subscript)
+ ; Storage Global:
+ ;   ^XTMP("XUSNPIX1",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6
+ ;      where:
+ ;      Piece 1 => Purge Date - 1 year in future
+ ;      Piece 2 => Create Date - Today
+ ;      Piece 3 => Description
+ ;      Piece 4 => Last Date Compiled
+ ;      Piece 5 => $H last run start time
+ ;      Piece 6 => $H last run completion time
+ ;
+ ;   ^XTMP("XUSNPIX1",1) = DATA
+ ;               
+ ;          XUSNPI => Unique NPI of entry
+ ;          LDT => Last Date Run, VA Fileman Format
+ ;
+ Q
+ ;
+EMAIL(XUSRTN) ; EMAIL THE MESSAGE
+ ; Add domain name if it does not exist
+ N XUSFOC,DLAYGO,DA,DIC,DIE,DR,X,Y
+ I '$$FIND1^DIC(4.2,,"QX","Q-NPS.VA.GOV","B") D
+ . S XUSFOC=$O(^DIC(4.2,"B","FOC-AUSTIN.VA.GOV",0)) I 'XUSFOC Q
+ . I XUSFOC=$O(^DIC(4.2,"B","FOC-AUSTIN.VA.GOV",""),-1) D
+ . . S DIC="^DIC(4.2,",X="Q-NPS.VA.GOV",DIC(0)="L",DLAYGO=4.2 D ^DIC K DLAYGO
+ . . S DIE=DIC,DA=+Y
+ . . S DR="1///NS;2///^S X=XUSFOC;1.7///YES;6.2///NPS;"
+ . . D ^DIE
+ ;
+ N XMY
+ ; Send email to designated recipient for live release
+ S XMY("XXX@Q-NPS.VA.GOV")=""
+ ;S XMY(DUZ)="" ;use for testing - remove before live
+ D ESEND
+ Q
+ ;
+VMAIL(XUSRTN) ; Verification email
+ N TMP
+ S TMP=^TMP(XUSRTN,$J,1)
+ K ^TMP(XUSRTN,$J)
+ S ^TMP(XUSRTN,$J,1)=$P(TMP,U,1,4)
+ S ^TMP(XUSRTN,$J,2)=""
+ S ^TMP(XUSRTN,$J,3)="TYPE 1 : NEW PERSON FILE (#200)"
+ S ^TMP(XUSRTN,$J,4)=""
+ S ^TMP(XUSRTN,$J,5)="Date/Time of Extract:   "_$P(TMP,U,9)
+ S ^TMP(XUSRTN,$J,6)=""
+ S ^TMP(XUSRTN,$J,7)="Message number: "_MSGCNT_"  Total NPI records: "_(COUNT-2)
+ S ^TMP(XUSRTN,$J,8)=""
+ S ^TMP(XUSRTN,$J,9)="Programmer Notes:   "_XUSVER_" - "_$P(TMP,U,10)
+ ;
+ ; Send verification email to local mail group and VA Outlook mail group.
+ S XMY("G.NPI EXTRACT VERIFICATION")=""
+ D ESEND
+ K ^TMP(XUSRTN)
+ Q
+ ;
+SMAIL(XUSRTN) ; Summary email
+ N TMP,T1,T2,T1NV,T2NV
+ K ^TMP(XUSRTN,$J)
+ S T1=$G(^XTMP(XUSRTN,1))
+ S T2=$G(^XTMP(XUSRTN,2))
+ S T1NV=$G(^XTMP(XUSRTN,"1NV"))
+ S T2NV=$G(^XTMP(XUSRTN,"2NV"))
+ S ^TMP(XUSRTN,$J,1)=^XTMP(XUSRTN,"H")_" - SUMMARY for "_DTTM
+ S ^TMP(XUSRTN,$J,2)=""
+ S ^TMP(XUSRTN,$J,3)="NEW PERSON FILE (#200)  "_+$P(T1,U)_" Message(s) Totaling "_+$P(T1,U,2)_" NPI records."
+ S ^TMP(XUSRTN,$J,4)=""
+ S ^TMP(XUSRTN,$J,5)="INSITUTION FILE (#4)  "_+$P(T2,U)_" Message(s) Totaling "_+$P(T2,U,2)_" NPI records."
+ S ^TMP(XUSRTN,$J,6)=""
+ S ^TMP(XUSRTN,$J,7)="NON VA Individual (#355.93)  "_+$P(T1NV,U)_" Message(s) Totaling "_+$P(T1NV,U,2)_" NPI records."
+ S ^TMP(XUSRTN,$J,8)=""
+ S ^TMP(XUSRTN,$J,9)="NON VA Facility/Group (#355.93)  "_+$P(T2NV,U)_" Message(s) Totaling "_+$P(T2NV,U,2)_" NPI records."
+ S ^TMP(XUSRTN,$J,10)=""
+ S ^TMP(XUSRTN,$J,11)="Programmer Notes:   "_XUSVER_" - "_$G(XUSPROD)
+ ;
+ ; Send verification email to local mail group and VA Outlook mail group
+ S XMY("G.NPI EXTRACT VERIFICATION")=""
+ N XMTEXT,XMSUB,XMDUN,XMDUZ,XMZ
+ S XMTEXT="^TMP("""_XUSRTN_""","_$J_","
+ S XMSUB=$TR($P($G(^TMP(XUSRTN,$J,1)),U),":")_"("_$G(XUSPROD)_") NPI EXTRACT SUMMARY "
+ D ^XMD
+ Q
+ K ^TMP(XUSRTN)
+ Q
+ ;
+ESEND N XMTEXT,XMSUB,XMDUN,XMDUZ,XMZ
+ S XMTEXT="^TMP("""_XUSRTN_""","_$J_","
+ S XMSUB=$TR($P($G(^TMP(XUSRTN,$J,1)),U),":")_"("_$G(XUSPROD)_") NPI EXTRACT TYPE 1 "
+ D ^XMD
+ Q
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,99 +1,91 @@
-%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
-	N %ZISOS,%ZISV
-	S U="^",%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^%ZOSF("VOL"))
-	;Check SPOOLER special case first
-INIT	I $D(ZTQUEUED),$G(IOT)="SPL",$D(IO)#2,$D(IO(0))#2,IO]"",IO=IO(0),$D(IO(1,IO))#2,%ZISOS["VAX DSM"!(%ZISOS["M/VX"),$G(IOP)[ION!(IOP[IO) K %ZIS,%IS,IOP Q
-	;
-	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 %ZHFN,%ZISOLD,DTOUT,DUOUT
-	;Save symbols to restore if don't open a device
-	D SYMBOL^%ZISUTL(0,$NA(%ZISOLD))
-A	D CLEAN ;(p363) K IO("CLOSE"),IO("HFSIO")
-	K IO("P"),IO("Q"),IO("S"),IO("T")
-K2	D K2^%ZIS1
-	S %ZISB=%ZIS'["N",(%E,%H,POP)=0,%Y="" S:'$D(IO(0)) IO(0)=$I
-	I %ZISOS["VAX DSM",$I["SYS$INPUT:.;" S:%ZIS'[0 %IS=%IS_"0",%ZIS=%ZIS_"0"
-	;I %IS["T"&(%IS["0") S (%H,%E)=0 G ^%ZIS1
-	I $D(IOP),IOP=$I!(IOP="HOME")!(0[IOP),$D(^XUTL("XQ",$J,"IO")) D HOME K %IS,%Y,%ZIS,%ZISB,%ZISV,IOP Q
-	;Don't worry about HOME if %ZIS[0
-	D:%ZIS'[0 GETHOME G EXIT^%ZIS1:POP,^%ZIS1 ;Jump to next part
-	;
-GETHOME	I $D(IO("HOME")),$P(IO("HOME"),"^",2)=IO(0) S (%E,%H)=+IO("HOME") Q
-	I $D(^XUTL("XQ",$J,"IOS")),$D(^("IO")),IO(0)=^("IO") S (%E,%H)=^("IOS") Q
-	;CALL LINEPORT CODE HERE---
-	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
-	S %H=%E S:'%H&(%IS'[0) POP=1 S:(%H>0)&('$D(IO("HOME"))) IO("HOME")=%H_"^"_$I
-	Q
-VIRTUAL	;See if a Virtual Terminal (LAT, TELNET)
-	;Change the MSM check for telnet to work with v4.4
-	I %ZISOS["MSM" X "I $P($ZV,""Version "",2)'<3 S %ZISVT=$ZDE(+%ZISVT) I %ZISVT?.E1""~""4.5N.E S %ZISVT=""TELNET"""
-	F %ZISI=$L(%ZISVT):-1:0 D:$D(^%ZIS(1,"C",%ZISVT))  Q:$S('%E:0,'$D(^%ZIS(1,%E,"TYPE")):0,^("TYPE")="VTRM":1,1:0)  S %ZISVT=$E(%ZISVT,1,%ZISI)
-	.D VTLKUP Q:$S('%E:0,'$D(^%ZIS(1,%E,"TYPE")):0,^("TYPE")="VTRM":1,1:0)
-	.S %X=0 F %ZISX=%ZISV,"" Q:%X>0  S %X=0 F  S %E=+$O(^%ZIS(1,"CPU",%ZISX_"."_%ZISVT,%X)) S %X=%E Q:%E'>0  I $G(^%ZIS(1,+%E,"TYPE"))="VTRM" Q
-	Q
-VTLKUP	F %ZISX=%ZISV,"" S %E=+$O(^%ZIS(1,"G","SYS."_%ZISX_"."_%ZISVT,0)) Q:%E  S %E=+$O(^%ZIS(1,"CPU",%ZISX_"."_%ZISVT,0)) Q:%E
-	Q
-	;
-CURRENT	N POP,%ZIS,%IS,%E,%H
-	S FF="#",SL=24,BS="*8",RM=80,(SUB,XY)="",%IS=0,%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^("VOL")),POP=0
-	D GETHOME K %E,%IS,%ZISI,%ZISOS,%ZISV,%ZISVT,%ZISX Q:POP
-	I $D(^%ZIS(1,%H,"SUBTYPE")) S SUB=+^("SUBTYPE") K %H
-	I $D(SUB),SUB,$D(^%ZIS(2,SUB,1)) S SUB=$S($D(^(0)):$P(^(0),"^"),1:""),FF=$P(^(1),"^",2),SL=$P(^(1),"^",3),BS=$P(^(1),"^",4),XY=$P(^(1),"^",5),RM=+^(1)
-	E  S SUB=""
-	I $D(^%ZOSF("RM")) N X S X=RM X ^("RM") K %A
-	Q
-HOME	;Entry point to establish IO* variables for home device.
-	D CLEAN ;(p363)
-	N X I '$D(^XUTL("XQ",$J,"IO")) S IOP="HOME" D ^%ZIS Q
-	D RESETVAR
-	I '$D(IO("C")),$G(IOM),IO=$I,$D(IO(1,IO)),$D(^%ZOSF("RM")) S X=+IOM X ^("RM")
-	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
-	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
-	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,%)=@%
-	Q
-ZISLPC	Q  ;No longer called in Kernel v8.
-	;
-HLP1	G EN1^%ZIS7
-HLP2	N %E,%H,%X,%ZISV,X S %ZISV=$S($D(^%ZOSF("VOL")):^("VOL"),1:"") G EN2^%ZIS7
-	;
-REWIND(IO2,IOT,IOPAR)	;Rewind Device
-	N %,X,Y,$ES,$ET S $ET="D REWERR^%ZIS Q 0"
-	S %=$I
-	I '($D(IO2)#2)!'$D(IOT)!'$D(IOPAR) Q 0
-	I "MT^SDP^HFS"'[IOT Q 0
-	S @("Y=$$REW"_IOT_"^%ZIS4(IO2,IOPAR)")
-	U %
-	Q Y
-REWERR	;Error encountered
-	S IO("ERROR")=$EC
-	S $EC="",$ET="Q:$ES>1  S $EC="""" Q 0" S $EC=",U1,"
-	Q 0
-	;
+%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"))
+ ;Check SPOOLER special case first
+INIT I $D(ZTQUEUED),$G(IOT)="SPL",$D(IO)#2,$D(IO(0))#2,IO]"",IO=IO(0),$D(IO(1,IO))#2,%ZISOS["VAX DSM"!(%ZISOS["M/VX"),$G(IOP)[ION!(IOP[IO) K %ZIS,%IS,IOP Q
+ ;
+ I '$D(%ZIS),$D(%IS) M %ZIS=%IS
+ S:'($D(%ZIS)#2) %ZIS="M" M %IS=%ZIS ;update %IS for now
+ ;
+ 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,%Z9,%Z90,%Z91,%Z95,%ZISB,%ZTIME,%ZTYPE
+ N %ZHFN,%ZISOLD,DTOUT,DUOUT
+ ;Save symbols to restore if don't open a device
+ D SYMBOL^%ZISUTL(0,$NA(%ZISOLD))
+A D CLEAN ;(p363) K IO("CLOSE"),IO("HFSIO")
+ K IO("P"),IO("Q"),IO("S"),IO("T")
+K2 D K2^%ZIS1
+ S %ZISB=%ZIS'["N",(%E,%H,POP)=0,%Y="" S:'$D(IO(0)) IO(0)=$I
+ I %ZISOS["VAX DSM",$I["SYS$INPUT:.;" S:%ZIS'[0 %IS=%IS_"0",%ZIS=%ZIS_"0"
+ ;I %IS["T"&(%IS["0") S (%H,%E)=0 G ^%ZIS1
+ I $D(IOP),IOP=$I!(IOP="HOME")!(0[IOP),$D(^XUTL("XQ",$J,"IO")) D HOME K %IS,%Y,%ZIS,%ZISB,%ZISV,IOP Q
+ ;Don't worry about HOME if %ZIS[0
+ D:%ZIS'[0 GETHOME G EXIT^%ZIS1:POP,^%ZIS1 ;Jump to next part
+ ;
+GETHOME I $D(IO("HOME")),$P(IO("HOME"),"^",2)=IO(0) S (%E,%H)=+IO("HOME") Q
+ I $D(^XUTL("XQ",$J,"IOS")),$D(^("IO")),IO(0)=^("IO") S (%E,%H)=^("IOS") Q
+ ;CALL LINEPORT CODE HERE---
+ 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 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
+VIRTUAL ;See if a Virtual Terminal (LAT, TELNET)
+ ;Change the MSM check for telnet to work with v4.4
+ I %ZISOS["MSM" X "I $P($ZV,""Version "",2)'<3 S %ZISVT=$ZDE(+%ZISVT) I %ZISVT?.E1""~""4.5N.E S %ZISVT=""TELNET"""
+ F %ZISI=$L(%ZISVT):-1:0 D:$D(^%ZIS(1,"C",%ZISVT))  Q:$S('%E:0,'$D(^%ZIS(1,%E,"TYPE")):0,^("TYPE")="VTRM":1,1:0)  S %ZISVT=$E(%ZISVT,1,%ZISI)
+ .D VTLKUP Q:$S('%E:0,'$D(^%ZIS(1,%E,"TYPE")):0,^("TYPE")="VTRM":1,1:0)
+ .S %X=0 F %ZISX=%ZISV,"" Q:%X>0  S %X=0 F  S %E=+$O(^%ZIS(1,"CPU",%ZISX_"."_%ZISVT,%X)) S %X=%E Q:%E'>0  I $G(^%ZIS(1,+%E,"TYPE"))="VTRM" Q
+ Q
+VTLKUP F %ZISX=%ZISV,"" S %E=+$O(^%ZIS(1,"G","SYS."_%ZISX_"."_%ZISVT,0)) Q:%E  S %E=+$O(^%ZIS(1,"CPU",%ZISX_"."_%ZISVT,0)) Q:%E
+ Q
+ ;
+CURRENT N POP,%ZIS,%IS,%E,%H
+ S FF="#",SL=24,BS="*8",RM=80,(SUB,XY)="",%IS=0,%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^("VOL")),POP=0
+ D GETHOME K %E,%IS,%ZISI,%ZISOS,%ZISV,%ZISVT,%ZISX Q:POP
+ I $D(^%ZIS(1,%H,"SUBTYPE")) S SUB=+^("SUBTYPE") K %H
+ I $D(SUB),SUB,$D(^%ZIS(2,SUB,1)) S SUB=$S($D(^(0)):$P(^(0),"^"),1:""),FF=$P(^(1),"^",2),SL=$P(^(1),"^",3),BS=$P(^(1),"^",4),XY=$P(^(1),"^",5),RM=+^(1)
+ E  S SUB=""
+ I $D(^%ZOSF("RM")) N X S X=RM X ^("RM") K %A
+ Q
+HOME ;Entry point to establish IO* variables for home device.
+ D CLEAN ;(p363)
+ N X I '$D(^XUTL("XQ",$J,"IO")) S IOP="HOME" D ^%ZIS Q
+ D RESETVAR
+ I '$D(IO("C")),$G(IOM),IO=$I,$D(IO(1,IO)),$D(^%ZOSF("RM")) S X=+IOM X ^("RM")
+ 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.
+ 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" I $D(^XUTL("XQ",$J,%))#2 S @%=^(%)
+ S POP=0,IO(0)=IO,(IOPAR,IOUPAR)=""
+ Q
+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.
+ ;
+HLP1 G EN1^%ZIS7
+HLP2 N %E,%H,%X,%ZISV,X S %ZISV=$S($D(^%ZOSF("VOL")):^("VOL"),1:"") G EN2^%ZIS7
+ ;
+REWIND(IO2,IOT,IOPAR) ;Rewind Device
+ N %,X,Y,$ES,$ET S $ET="D REWERR^%ZIS Q 0"
+ S %=$I
+ I '($D(IO2)#2)!'$D(IOT)!'$D(IOPAR) Q 0
+ I "MT^SDP^HFS"'[IOT Q 0
+ S @("Y=$$REW"_IOT_"^%ZIS4(IO2,IOPAR)")
+ U %
+ Q Y
+REWERR ;Error encountered
+ S IO("ERROR")=$EC
+ S $EC="",$ET="Q:$ES>1  S $EC="""" Q 0" S $EC=",U1,"
+ Q 0
+ ;
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,102 +1,93 @@
-%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
-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
-L1	;Main Loop
-	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
-	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 '$D(^%ZIS(1,%A,0)) D MSG1 K %ZISIOS S POP=1
-	I POP G EXIT:$D(IOP),L1:'$D(IOP)
-	S %E=%A,%Z=^%ZIS(1,%A,0),%Z1=$G(^(1))
-	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
-G	G L1:POP&'$D(IOP)&'($D(DTOUT)!$D(DUOUT)) ;Didn't get it
-	;
-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
-	;Do count of number of times device opened.  Field 51.
-	I $L($G(IO)),$D(IO(1,IO))#2,$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 %IS'[0,$G(IO(0))]"" U IO(0) ;Make sure return with home active
-	G SETVAR:'POP!(%IS["T"),KILVAR
-	;
-IOP	;Request with IOP set
-	S (%ZISVT,%X)=IOP S:%X'?1.UNP %X=$$UP(%X) I %X'="Q" D SETQ Q
-	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"
-	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)
-RD	W !,$S($D(%IS("A")):%IS("A"),1:"DEVICE: ") W:%A]"" %A,"// " D SBR S:%X="" %X=%A S %ZISVT=%X
-	I %X?2"?".E D EN2^%ZIS7 G R
-	I %X?1"?".E D EN1^%ZIS7 G R
-	I $D(DTOUT)!$D(DUOUT)!(%X'?.ANP)!($L($P(%X,";"))>31) S:%IS["T" IO="" S POP=1 Q
-	S:%X'?1.UNP %X=$$UP(%X) D SETQ G R:$T Q
-SETQ	S %Y=$P(%X,";",2,9),%X=$P(%X,";",1) S:$L(";"_%Y,";/")=2 IO("P")=$P(";"_%Y,";/",2)
-	I %IS["Q",%X="Q" S %X=%Y,%ZISVT=$P(%ZISVT,";",2,9),%ZISB=0,IO("Q")=1,%IS("A")="DEVICE: " S:$D(IOP) %Y=$P(%X,";",2,9),%X=$P(%X,";",1)
-	I $T,'$D(IOP) W "UEUE TO PRINT ON" Q  ; Return $T value
-	Q
-LKUP	S %ZISMY=$P(%ZISVT,";",2,999),%ZISVT=$P(%ZISVT,";")
-	I %X="H" W:'$D(IOP) "ome" S %X=0
-	I 0[%X!(%X="HOME")!(%X=$I) S %A=%H Q
-	I $E(%ZISVT)="`",$D(IOP) S %A=+$E(%ZISVT,2,999) I $G(^%ZIS(1,%A,0))]"" Q
-	S %A=0 I "P"[%X Q:$D(IOP)&('$D(^%ZIS(1,%E,99)))  I $D(^%ZIS(1,%E,99)) S %A=+^(99) Q
-	I %X=" ",$D(DUZ)#2,$D(^DISV(+DUZ,"^%ZIS(1,")) S %A=^("^%ZIS(1,") Q
-	S %A=+$O(^%ZIS(1,"B",%ZISVT,0)) Q:%A>0  ;mixed case lookup
-	I %X'=%ZISVT S %A=+$O(^%ZIS(1,"B",%X,0)) Q:%A>0  ;uppercase lookup
-	D VTLKUP^%ZIS S %A=%E Q:%A>0  ;mixed case lookup
-	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
-	S:%X="."!(%X="^") DUOUT=1,%X="" Q
-LC	S %X=$$UP(%X)
-	Q
-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)
-	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]"
-	Q
-SETVAR	;Come here to setup the variables for the selected device
-	S:$D(IO)[0 IO="" G KILVAR:%IS["T"&(IO="")
-	I $G(%Z)="" S ION="Unknown device",POP=1 G KILVAR
-	S:IO'=IO(0)&($D(DUZ)#2) ^DISV(+DUZ,"^%ZIS(1,")=%E
-	S ION=$P(%Z,"^",1),IOM=+%Z91,IOF=$P(%Z91,"^",2),IOSL=$P(%Z91,"^",3),IOBS=$P(%Z91,"^",4),IOXY=$P(%Z91,"^",5)
-	I IOSL>65530 S IOSL=65530 ;Cache rolls $Y at 65535
-	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
-	;
-KILVAR	;Come here to restore the calling variables
-	D SYMBOL^%ZISUTL(1,"%ZISOLD")
-	S:'$L($G(IOF)) IOF="#" S:'$D(IOST(0)) IOST(0)=0
-	;See that all standard variables are defined
-	F %I="IO","ION","IOM","IOBS","IOSL","IOST" S:$D(@%I)[0 @%I=""
-	K IO("HFSIO"),IO("OPEN") I $D(%ZISCPU) S:'$D(IOCPU) IOCPU=%ZISCPU
-KIL	;Final exit cleanup
-	S:'POP IOS=%ZISIOS I POP K:%IS'["T" %ZISIOS I %IS["T" K IOS S:$D(%ZISIOS) IOS=%ZISIOS
-	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
-	Q
+%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
+L1 ;Main Loop
+ 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) !,*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)
+ S %E=%A,%Z=^%ZIS(1,%A,0),%Z1=$G(^(1))
+ 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
+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 $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,'POP,$G(%ZISIOS) D
+ . S $P(^(5),"^",1)=$P($G(^%ZIS(1,%ZISIOS,5)),"^",1)+1
+ 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
+ ;
+IOP ;Request with IOP set
+ S (%ZISVT,%X)=IOP S:%X'?1.UNP %X=$$UP(%X) I %X'="Q" D SETQ Q
+ 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 !,*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)
+RD W !,$S($D(%IS("A")):%IS("A"),1:"DEVICE: ") W:%A]"" %A,"// " D SBR S:%X="" %X=%A S %ZISVT=%X
+ I %X?2"?".E D EN2^%ZIS7 G R
+ I %X?1"?".E D EN1^%ZIS7 G R
+ I $D(DTOUT)!$D(DUOUT)!(%X'?.ANP)!($L($P(%X,";"))>31) S:%IS["T" IO="" S POP=1 Q
+ S:%X'?1.UNP %X=$$UP(%X) D SETQ G R:$T Q
+SETQ S %Y=$P(%X,";",2,9),%X=$P(%X,";",1) S:$L(";"_%Y,";/")=2 IO("P")=$P(";"_%Y,";/",2)
+ I %IS["Q",%X="Q" S %X=%Y,%ZISVT=$P(%ZISVT,";",2,9),%ZISB=0,IO("Q")=1,%IS("A")="DEVICE: " S:$D(IOP) %Y=$P(%X,";",2,9),%X=$P(%X,";",1)
+ I $T,'$D(IOP) W "UEUE TO PRINT ON" Q  ; Return $T value
+ Q
+LKUP S %ZISMY=$P(%ZISVT,";",2,999),%ZISVT=$P(%ZISVT,";")
+ I %X="H" W:'$D(IOP) "ome" S %X=0
+ I 0[%X!(%X="HOME")!(%X=$I) S %A=%H Q
+ I $E(%ZISVT)="`",$D(IOP) S %A=+$E(%ZISVT,2,999) I $G(^%ZIS(1,%A,0))]"" Q
+ S %A=0 I "P"[%X Q:$D(IOP)&('$D(^%ZIS(1,%E,99)))  I $D(^%ZIS(1,%E,99)) S %A=+^(99) Q
+ I %X=" ",$D(DUZ)#2,$D(^DISV(+DUZ,"^%ZIS(1,")) S %A=^("^%ZIS(1,") Q
+ S %A=+$O(^%ZIS(1,"B",%ZISVT,0)) Q:%A>0  ;mixed case lookup
+ I %X'=%ZISVT S %A=+$O(^%ZIS(1,"B",%X,0)) Q:%A>0  ;uppercase lookup
+ D VTLKUP^%ZIS S %A=%E Q:%A>0  ;mixed case lookup
+ 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 *7 S DTOUT=1 Q
+ S:%X="."!(%X="^") DUOUT=1,%X="" Q
+LC S %X=$$UP(%X)
+ Q
+LOW(%) Q $TR(%,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
+UP(%) Q $TR(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+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 *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:$D(IO)[0 IO="" G KILVAR:%IS["T"&(IO="")
+ I $G(%Z)="" S ION="Unknown device",POP=1 G KILVAR
+ S:IO'=IO(0)&($D(DUZ)#2) ^DISV(+DUZ,"^%ZIS(1,")=%E
+ S ION=$P(%Z,"^",1),IOM=+%Z91,IOF=$P(%Z91,"^",2),IOSL=$P(%Z91,"^",3),IOBS=$P(%Z91,"^",4),IOXY=$P(%Z91,"^",5)
+ I IOSL>65530 S IOSL=65530 ;Cache rolls $Y at 65535
+ 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
+ ;
+KILVAR ;Come here to restore the calling variables
+ D SYMBOL^%ZISUTL(1,"%ZISOLD")
+ S:'$L($G(IOF)) IOF="#" S:'$D(IOST(0)) IOST(0)=0
+ ;See that all standard variables are defined
+ F %I="IO","ION","IOM","IOBS","IOSL","IOST" S:$D(@%I)[0 @%I=""
+ K IO("HFSIO"),IO("OPEN") I $D(%ZISCPU) S:'$D(IOCPU) IOCPU=%ZISCPU
+KIL ;Final exit cleanup
+ S:'POP IOS=%ZISIOS I POP K:%IS'["T" %ZISIOS I %IS["T" K IOS S:$D(%ZISIOS) IOS=%ZISIOS
+ 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,%ZISIOF,%ZISIOSL,%ZISIOBS,%ZISIOST,%ZISIOST(0),%ZISTO,%ZISTP,%ZISHG,%ZISSIO,%ZISOPEN,%ZISOPAR,%ZISUPAR
+ K %ZISMY,%ZISQUIT
+ Q
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,94 +1,90 @@
-%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
-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
-	. N %1,%2 S %1=$G(^%ZIS(1,%ZISHG(0),"HG",+%ZISHGL,0)),%2=$G(^%ZIS(1,+%1,0))
-	. ;Check that HG device is on same VOL.
-	. I $P(%2,"^",9)=%ZISV!($P(%2,"^",9)="") S %E=+$P(^%ZIS(1,%ZISHG(0),"HG",+%ZISHGL,0),"^")
-	. Q
-	G L2:%ZISHGL>0 S %ZISHPOP=1,%E=%ZISHP
-	;
-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
-	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"
-	. S POP=1 K:$D(IOP) IO("Q") Q
-	S %Z90=$G(^(90)),%Z95=$G(^(95)),%ZTIME=$G(^("TIME")),%ZTYPE=$G(^("TYPE")),%ZISHG=$O(^%ZIS(1,"AHG",%E,0))
-	I %ZISHG,$D(^%ZIS(1,+%ZISHG,0)) S:'$D(%ZISHG(0)) %ZISHG(0)=+%ZISHG S %ZISHG=$P(^(0),"^",1)
-	E  S %ZISHG=""
-	I %ZTYPE="HG" D OTHCPU("HUNT GROUP") G T:$D(%ZISHG(0))!POP
-	I %ZTYPE="RES" S %ZISRL=+$P(%Z1,"^",10) G T
-VTRM	I %ZTYPE="VTRM",'('$D(IO("Q"))&(%A=%H)) W:'$D(IOP)&'$D(%ZISHP) *7,"  [YOU CAN NOT SELECT A VIRTUAL TERMINAL]" S POP=1 ;Virtual Terminal Check
-	S:%ZTYPE="VTRM"&'$D(IO("Q"))&(%A=%H) IO=$I
-	;
-SLAVE	I $D(IO("Q")),$P(%Z,"^",2)=0,$P(%Z,"^",8)']"" W:'$D(IOP) *7,!?10,"  [SLAVE device NOT set up for queuing]" S POP=1 G T
-OCPU	D OTHCPU("DEVICE")
-	;
-OOS	G T:POP I %Z90,$D(DT)#2,%Z90'>DT S POP=1 ;Out Of Service Check
-	I $T,'$D(IOP),'$D(%ZISHP) W *7,"  [Out of Service]" ;I 'POP W " ..OK" S %=2,U="^" D YN^%ZIS1 G:%=0 OOS S:%'=1 POP=1
-	;
-PTIME	G T:POP!(IO=$I)!(IO=0)
-	;Prohibitted Time Check
-	S %A=$P(%ZTIME,"^") I %ZISB,$L(%A) D  I POP,'$D(IOP),'$D(%ZISHP) W *7,"  [ACCESS PROHIBITED "_%A_"]" ;AT THIS TIME]"
-	. N %C,%L,%H ;%C is current time, %L is lower limit, %H is upper limit
-	. S %C=$P($H,",",2),%C=%C\60#60+(%C\3600*100),%H=$P(%A,"-",2),%L=+%A
-	. I $S(%H'<%L:(%C'>%H&(%C'<%L)),1:(%C'<%L!(%C'>%H))) S POP=1
-	. Q
-DUZ	I 'POP D SEC ;Security Check
-	;
-T	I POP,$D(%ZISHG(0)),%IS'["D",'$D(%ZISHPOP),%ZISB G HUNT
-	I POP D HGBSY:$D(%ZISHPOP) ;G T2:%IS["T"
-	;
-TMPVAR	K IO("S") S %ZISIOS=%E S:IO=0 IO=$I,IO("S")=%H
-	S %ZISOPAR=$$IOPAR(%E,"IOPAR")
-	S %ZISUPAR=$$IOPAR(%E,"IOUPAR"),%ZISTO=+$P(%ZTIME,"^",2)
-	I $D(IO("S")) D  I POP Q
-	. S IO=$S(%IS["S":$P($G(^%ZIS(1,+$P(%Z,"^",8),0)),"^",2),1:IO)
-	. I %IS["S",IO]"" S %H=+$P(%Z,"^",8),IO("S")=%H,IO(0)=IO
-	. S IO("S")=$S($G(^XUTL("XQ",$J,"IOST(0)")):^("IOST(0)"),1:$G(^%ZIS(1,%H,"SUBTYPE")))
-	. S:IO="" POP=1
-	. Q
-	S %A=+$G(^%ZIS(1,%E,"SUBTYPE")),%ZISTP=0 ;%A is pointer to subtype
-	I %E=%H,%ZTYPE["TRM" D  I 1
-	. I $D(^XUTL("XQ",$J,"IOST(0)")) D  ;Use home
-	. . S %A=+^XUTL("XQ",$J,"IOST(0)"),%Z91="",%ZISTP=1
-	. . F %ZISI="IOM","IOF","IOSL","IOBS","IOXY" S %Z91=%Z91_$G(^XUTL("XQ",$J,%ZISI))_"^"
-	. E  S %=$$LNPRTSUB^%ZISUTL I %>0 S %A=%,%Z91=""
-	E  S %Z91=$P($G(^%ZIS(2,%A,1)),"^",1,4),$P(%Z91,"^",5)=$G(^("XY"))
-	;I $D(%Z91),%Z91'?1.4"^" ;$P(%Z91,"^")]"",$P(%Z91,"^",2)]"",$P(%Z91,"^",3),$P(%Z91,"^",4)]""
-	D ST^%ZIS3(%ZISTP) S:%IS["U" USIO=$P(%Z91,"^",1,4)
-T2	I POP S:%IS'["T" IO="" Q
-	G ^%ZIS3:"^MTRM^VTRM^TRM^SPL^MT^SDP^HFS^RES^OTH^BAR^HG^IMPC^CHAN^"[("^"_%ZTYPE_"^") ;Jump to next part
-	S POP=1 Q
-	;
-HGBSY	S POP=1 S:%IS'["T" IO="" K %ZISHP,%ZISHPOP Q:$D(IOP)
-	W:$X>38 !,?5 W *7," All devices in hunt group "_%ZISHG_" are busy!" Q
-	;
-OTHCPU(%1)	;%1 should be either DEVICE or HUNT GROUP
-	N %2,X,Y,%ZISMSG S %ZISMSG=0
-	F %2="CPU","VOLUME SET" D
-	.I %2="VOLUME SET" S X=$P($P(%Z,"^",9),":"),Y=%ZISV
-	.E  D GETENV^%ZOSV S X=$P($P(%Z,"^",9),":",2),Y=$P($P(Y,"^",4),":",2)
-	.I X=Y!(X="") Q:%1="DEVICE"  D  Q  ;Other Vol Set/Cpu Check
-	..S %ZISHG(0)=%E,%ZISHG=$P(%Z,"^")
-	..I %ZISB S POP=1
-	..E  S IO=" "
-	.I %2="VOLUME SET" S $P(%ZISCPU,":")=X
-	.E  S $P(%ZISCPU,":",2)=X
-	.I %1="HUNT GROUP" K %ZISHG(0)
-	.I %IS["Q" S IO("Q")=1,%ZISB=0 S:%1="HUNT GROUP" IO=" "
-	.E  I %ZISB&(%ZTYPE="TRM"&($D(%ZISHG(0))&(%IS'["D"))) S POP=1
-	.E  W:'$D(IOP)&'%ZISMSG *7,"  ["_%1_" is on another "_%2_" ('"_X_"')]",! S POP=1,%ZISMSG=1
-	Q
-IOPAR(%DA,%N)	;Return I/O parameters
-	Q $S($G(%ZIS(%N))]"":%ZIS(%N),1:$G(^%ZIS(1,%DA,%N)))
-	;
-SEC	I %Z95]"" S %X=$G(DUZ(0)) I %X'="@" S POP=1 F %A=1:1:$L(%X) I %Z95[$E(%X,%A) S POP=0 Q
-	I POP,'$D(IOP),'$D(%ZISHP) W *7,"  [Access Prohibited]"
-	Q
+%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
+ . N %1,%2 S %1=$G(^%ZIS(1,%ZISHG(0),"HG",+%ZISHGL,0)),%2=$G(^%ZIS(1,+%1,0))
+ . ;Check that HG device is on same VOL.
+ . I $P(%2,"^",9)=%ZISV!($P(%2,"^",9)="") S %E=+$P(^%ZIS(1,%ZISHG(0),"HG",+%ZISHGL,0),"^")
+ . Q
+ G L2:%ZISHGL>0 S %ZISHPOP=1,%E=%ZISHP
+ ;
+L2 ;Entry point from %ZIS1
+ I $D(DTOUT)!$D(DUOUT) K %ZISHP,%ZISHPOP Q
+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"
+ . S POP=1 K:$D(IOP) IO("Q") Q
+ S %Z90=$G(^(90)),%Z95=$G(^(95)),%ZTIME=$G(^("TIME")),%ZTYPE=$G(^("TYPE")),%ZISHG=$O(^%ZIS(1,"AHG",%E,0))
+ I %ZISHG,$D(^%ZIS(1,+%ZISHG,0)) S:'$D(%ZISHG(0)) %ZISHG(0)=+%ZISHG S %ZISHG=$P(^(0),"^",1)
+ E  S %ZISHG=""
+ I %ZTYPE="HG" D OTHCPU("HUNT GROUP") G T:$D(%ZISHG(0))!POP
+ I %ZTYPE="RES" S %ZISRL=+$P(%Z1,"^",10) G T
+VTRM I %ZTYPE="VTRM",'('$D(IO("Q"))&(%A=%H)) W:'$D(IOP)&'$D(%ZISHP) *7,"  [YOU CAN NOT SELECT A VIRTUAL TERMINAL]" S POP=1 ;Virtual Terminal Check
+ S:%ZTYPE="VTRM"&'$D(IO("Q"))&(%A=%H) IO=$I
+ ;
+SLAVE I $D(IO("Q")),$P(%Z,"^",2)=0,$P(%Z,"^",8)']"" W:'$D(IOP) *7,!?10,"  [SLAVE device NOT set up for queuing]" S POP=1 G T
+OCPU D OTHCPU("DEVICE")
+ ;
+OOS G T:POP I %Z90,$D(DT)#2,%Z90'>DT S POP=1 ;Out Of Service Check
+ I $T,'$D(IOP),'$D(%ZISHP) W *7,"  [Out of Service]" ;I 'POP W " ..OK" S %=2,U="^" D YN^%ZIS1 G:%=0 OOS S:%'=1 POP=1
+ ;
+PTIME G T:POP!(IO=$I)!(IO=0)
+ ;Prohibitted Time Check
+ S %A=$P(%ZTIME,"^") I %ZISB,$L(%A) D  I POP,'$D(IOP),'$D(%ZISHP) W *7,"  [ACCESS PROHIBITED "_%A_"]" ;AT THIS TIME]"
+ . N %C,%L,%H ;%C is current time, %L is lower limit, %H is upper limit
+ . S %C=$P($H,",",2),%C=%C\60#60+(%C\3600*100),%H=$P(%A,"-",2),%L=+%A
+ . I $S(%H'<%L:(%C'>%H&(%C'<%L)),1:(%C'<%L!(%C'>%H))) S POP=1
+ . Q
+DUZ I 'POP D SEC ;Security Check
+ ;
+T I POP,$D(%ZISHG(0)),%IS'["D",'$D(%ZISHPOP),%ZISB G HUNT
+ I POP D HGBSY:$D(%ZISHPOP) ;G T2:%IS["T"
+ ;
+TMPVAR K IO("S") S %ZISIOS=%E S:IO=0 IO=$I,IO("S")=%H
+ S %ZISOPAR=$$IOPAR(%E,"IOPAR")
+ S %ZISUPAR=$$IOPAR(%E,"IOUPAR"),%ZISTO=+$P(%ZTIME,"^",2)
+ I $D(IO("S")) D  I POP Q
+ . S IO=$S(%IS["S":$P($G(^%ZIS(1,+$P(%Z,"^",8),0)),"^",2),1:IO)
+ . I %IS["S",IO]"" S %H=+$P(%Z,"^",8),IO("S")=%H,IO(0)=IO
+ . S IO("S")=$S($G(^XUTL("XQ",$J,"IOST(0)")):^("IOST(0)"),1:$G(^%ZIS(1,%H,"SUBTYPE")))
+ . S:IO="" POP=1
+ . Q
+ S %A=+$G(^%ZIS(1,%E,"SUBTYPE")),%ZISTP=0 ;%A is pointer to subtype
+ I %E=%H,%ZTYPE["TRM" D  I 1
+ . I $D(^XUTL("XQ",$J,"IOST(0)")) D  ;Use home
+ . . S %A=+^XUTL("XQ",$J,"IOST(0)"),%Z91="",%ZISTP=1
+ . . F %ZISI="IOM","IOF","IOSL","IOBS","IOXY" S %Z91=%Z91_$G(^XUTL("XQ",$J,%ZISI))_"^"
+ . E  S %=$$LNPRTSUB^%ZISUTL I %>0 S %A=%,%Z91=""
+ E  S %Z91=$P($G(^%ZIS(2,%A,1)),"^",1,4),$P(%Z91,"^",5)=$G(^("XY"))
+ ;I $D(%Z91),%Z91'?1.4"^" ;$P(%Z91,"^")]"",$P(%Z91,"^",2)]"",$P(%Z91,"^",3),$P(%Z91,"^",4)]""
+ D ST^%ZIS3(%ZISTP) S:%IS["U" USIO=$P(%Z91,"^",1,4)
+T2 I POP S:%IS'["T" IO="" Q
+ G ^%ZIS3:"^MTRM^VTRM^TRM^SPL^MT^SDP^HFS^RES^OTH^BAR^HG^IMPC^CHAN^"[("^"_%ZTYPE_"^") ;Jump to next part
+ S POP=1 Q
+ ;
+HGBSY S POP=1 S:%IS'["T" IO="" K %ZISHP,%ZISHPOP Q:$D(IOP)
+ W:$X>38 !,?5 W *7," All devices in hunt group "_%ZISHG_" are busy!" Q
+ ;
+OTHCPU(%1) ;%1 should be either DEVICE or HUNT GROUP
+ N %2,X,Y,%ZISMSG S %ZISMSG=0
+ F %2="CPU","VOLUME SET" D
+ .I %2="VOLUME SET" S X=$P($P(%Z,"^",9),":"),Y=%ZISV
+ .E  D GETENV^%ZOSV S X=$P($P(%Z,"^",9),":",2),Y=$P($P(Y,"^",4),":",2)
+ .I X=Y!(X="") Q:%1="DEVICE"  D  Q  ;Other Vol Set/Cpu Check
+ ..S %ZISHG(0)=%E,%ZISHG=$P(%Z,"^")
+ ..I %ZISB S POP=1
+ ..E  S IO=" "
+ .I %2="VOLUME SET" S $P(%ZISCPU,":")=X
+ .E  S $P(%ZISCPU,":",2)=X
+ .I %1="HUNT GROUP" K %ZISHG(0)
+ .I %IS["Q" S IO("Q")=1,%ZISB=0 S:%1="HUNT GROUP" IO=" "
+ .E  I %ZISB&(%ZTYPE="TRM"&($D(%ZISHG(0))&(%IS'["D"))) S POP=1
+ .E  W:'$D(IOP)&'%ZISMSG *7,"  ["_%1_" is on another "_%2_" ('"_X_"')]",! S POP=1,%ZISMSG=1
+ Q
+IOPAR(%DA,%N) ;Return I/O parameters
+ Q $S($G(%ZIS(%N))]"":%ZIS(%N),1:$G(^%ZIS(1,%DA,%N)))
+ ;
+SEC I %Z95]"" S %X=$G(DUZ(0)) I %X'="@" S POP=1 F %A=1:1:$L(%X) I %Z95[$E(%X,%A) S POP=0 Q
+ I POP,'$D(IOP),'$D(%ZISHP) W *7,"  [Access Prohibited]"
+ Q
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,82 +1,71 @@
-%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
-	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 $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
-	;
-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
-	G Q
-DEVOK	N X,Y,X1 ;Not sure this is needed
-	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
-	Q
-	;
-MARGN	;Get the margin and page length
-	S %A=$P(%Y,";",1)
-	I %A?1A.ANP D SUBIEN(.%A,1) I $D(^%ZIS(2,%A,1)) K %Z91 D ST(1) S %Y=$P(%Y,";",2,9),%ZISMY=$P(%ZISMY,";",2,9) G MARGN
-	I %A>3 S $P(%Z91,"^")=$S(%A>255:255,1:+%A)
-	I $P(%Y,";",2) S $P(%Z91,"^",3)=+$S($P(%Y,";",2)>65530:65530,1:$P(%Y,";",2)) ;Cache fix for $Y#65535 wrap
-	;
-ALTP	I '$D(IO("P")) Q:%A>3  G ASKMAR:%ZTYPE["TRM" Q
-	S %X=$F(IO("P"),"M") I %X S %A=+$E(IO("P"),%X,99),$P(%Z91,"^")=$S(%A>255:255,1:%A)
-	S %X=$F(IO("P"),"L") I %X S $P(%Z91,"^",3)=+$E(IO("P"),%X,99)
-	Q:%A>3!(%ZTYPE'["TRM")
-ASKMAR	I %IS["M",'$D(IOP),$S(%E=%H:+$P(%Z,"^",3),1:1),$P(%Z,"^",4) W "    Right Margin: " W:$P(%Z91,"^")]"" +%Z91,"// "
-	E  Q
-	D SBR^%ZIS1 I '$D(DTOUT)&'$D(DUOUT) S:%X=""&($P(%Z91,"^")]"") %X=+%Z91 G ASKMAR:%X'?1.N S $P(%Z91,"^")=$S(%X>255:255,1:%X) 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_")"
-	Q
-AQUE	;Ask about Queueing
-	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"
-	D YN^%ZIS1 K %ZISDTIM G AQUE:%=0 Q:$D(IO("Q"))
-	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 %ZISIOST(0)=%A,%ZISIOST=$P($G(^%ZIS(2,%A,0)),"^")
-	S:'$D(%Z91) %Z91=$P($G(^%ZIS(2,%A,1),"132^#^60^$C(8)"),"^",1,4),$P(%Z91,"^",5)=$G(^("XY"))
-	Q:%ZISTP
-STP	N %B ;%E is a pointer to the Device file
-	S %B=$G(^%ZIS(1,%E,91))
-	S:$P(%B,"^")]"" $P(%Z91,"^")=+%B S:$P(%B,"^",3)]"" $P(%Z91,"^",3)=$P(%B,"^",3) ;S $P(%Z91,"^",5)=$G(^%ZIS(2,%ZISIOST(0),"XY"))
-	Q
-SUBIEN(%1,%)	;Return Subtype ien. %1 is call by Ref.
-	N %XX,%YY
-	I $D(^%ZIS(2,"B",%1))>9 S %1=+$O(^%ZIS(2,"B",%1,0)) Q
-	I '$G(%) S X="" Q
-	S %XX=%1 D 2^%ZIS5 S %1=+%YY
-	Q
-SUBTYPE(%A)	;Called from %ZISH
-	N %ZISIOST,%Z91
-	S:$G(%A)="" %A="P-OTHER"
-	D SUBIEN(.%A),ST(1)
-	S IOM=$P(%Z91,U,1),IOF=$P(%Z91,U,2),IOSL=$P(%Z91,U,3),IOST=%ZISIOST,IOST(0)=%ZISIOST(0),IOBS="$C(8)"
-	S:IOST="" IOST="P-OTHER",IOST(0)=0
-	Q
+%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
+ 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:%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&(%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
+ 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")) !,*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
+ ;
+MARGN ;Get the margin and page length
+ S %A=$P(%Y,";",1)
+ I %A?1A.ANP D SUBIEN(.%A,1) I $D(^%ZIS(2,%A,1)) K %Z91 D ST(1) S %Y=$P(%Y,";",2,9),%ZISMY=$P(%ZISMY,";",2,9) G MARGN
+ I %A>3 S $P(%Z91,"^")=$S(%A>255:255,1:+%A)
+ I $P(%Y,";",2) S $P(%Z91,"^",3)=+$S($P(%Y,";",2)>65530:65530,1:$P(%Y,";",2)) ;Cache fix for $Y#65535 wrap
+ ;
+ALTP I '$D(IO("P")) Q:%A>3  G ASKMAR:%ZTYPE["TRM" Q
+ S %X=$F(IO("P"),"M") I %X S %A=+$E(IO("P"),%X,99),$P(%Z91,"^")=$S(%A>255:255,1:%A)
+ S %X=$F(IO("P"),"L") I %X S $P(%Z91,"^",3)=+$E(IO("P"),%X,99)
+ Q:%A>3!(%ZTYPE'["TRM")
+ASKMAR I %IS["M",'$D(IOP),$S(%E=%H:+$P(%Z,"^",3),1:1),$P(%Z,"^",4) W "    Right Margin: " W:$P(%Z91,"^")]"" +%Z91,"// "
+ E  Q
+ D SBR^%ZIS1 I '$D(DTOUT)&'$D(DUOUT) S:%X=""&($P(%Z91,"^")]"") %X=+%Z91 G ASKMAR:%X'?1.N S $P(%Z91,"^")=$S(%X>255:255,1:%X) Q
+ S POP=1 I %ZISB&(%ZTYPE["TRM")&(IO'=IO(0)) C IO K IO(1,IO) Q
+ Q
+SETPAR S:%ZISOPAR]""&($A(%ZISOPAR)-40) %ZISOPAR="("_%ZISOPAR_")"
+ Q
+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"
+ D YN^%ZIS1 K %ZISDTIM G AQUE:%=0 Q:$D(IO("Q"))
+ 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
+ Q
+ST(%ZISTP) ;
+ S %ZISIOST(0)=%A,%ZISIOST=$P($G(^%ZIS(2,%A,0)),"^")
+ S:'$D(%Z91) %Z91=$P($G(^%ZIS(2,%A,1),"132^#^60^$C(8)"),"^",1,4),$P(%Z91,"^",5)=$G(^("XY"))
+ Q:%ZISTP
+STP N %B ;%E is a pointer to the Device file
+ S %B=$G(^%ZIS(1,%E,91))
+ S:$P(%B,"^")]"" $P(%Z91,"^")=+%B S:$P(%B,"^",3)]"" $P(%Z91,"^",3)=$P(%B,"^",3) ;S $P(%Z91,"^",5)=$G(^%ZIS(2,%ZISIOST(0),"XY"))
+ Q
+SUBIEN(%1,%) ;Return Subtype ien. %1 is call by Ref.
+ N %XX,%YY
+ I $D(^%ZIS(2,"B",%1))>9 S %1=+$O(^%ZIS(2,"B",%1,0)) Q
+ I '$G(%) S X="" Q
+ S %XX=%1 D 2^%ZIS5 S %1=+%YY
+ Q
+SUBTYPE(%A) ;Called from %ZISH
+ N %ZISIOST,%Z91
+ S:$G(%A)="" %A="P-OTHER"
+ D SUBIEN(.%A),ST(1)
+ S IOM=$P(%Z91,U,1),IOF=$P(%Z91,U,2),IOSL=$P(%Z91,U,3),IOST=%ZISIOST,IOST(0)=%ZISIOST(0),IOBS="$C(8)"
+ S:IOST="" IOST="P-OTHER",IOST(0)=0
+ Q
+ 
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,109 +1,103 @@
-%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
-OPEN	;From %ZIS3 for TRM
-	G OPN2:$D(IO(1,IO))
-	S POP=0 D OP1 G NOPEN:'$D(IO(1,IO))
-OPN2	;
-	I $D(%ZISHP),'$D(IOP) W !,*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
-	I '$D(IOP) W *7,"  [BUSY]" W "  ...  RETRY" S %=2,U="^" D YN^%ZIS1 G OPEN:%=1
-	S POP=1 Q
-	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
-	Q
-OPNERR	;Open Error
-	S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$$EC^%ZOSV,$EC=""
-	Q
-	;
-O	;From %ZIS6 for all 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
-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)
-	N % S %(IO)="",%=$P($P($NA(%(IO)),"(",2),")")
-	S %A=%_$E(":",%A]"")_%A
-	D O1 I POP D  Q
-	.I %ZTYPE="HFS",'$D(IOP),$G(IO("ERROR"))["file not found" W !,?5,*7,"[File Not Found]" Q
-	.W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q
-	;S IO(1,IO)="" U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91)
-	U IO S $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91)
-	I %ZISUPAR]"" S %A1=""""_IO_""":"_%ZISUPAR U @%A1
-	;U:%IS'[0 IO(0)
-	G OXECUTE^%ZIS6
-	;
-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)=""
-	S IO("ERROR")="" Q
-	;
-	;Need to find out how to get IP address
-ZIO	N %,%1 S (%,%1)=$ZIO
-	I $ZV["VMS",%["_TNA" D
-	. S (%,%1)=$ZGETDVI($I,"TT_ACCPORNAM")
-	. S %=$S(%["Host:":$P($P(%,"Host: ",2)," ")_":"_$P(%,"Port: ",2),1:%) S:%[" " %=$TR(%," ")
-	I $ZV'["VMS" D
-	. S (%,%1)=$ZTRNLNM("REMOTEHOST") S:$L(%) %1="Host:"_% S:'$L(%) %=$ZIO
-	S IO("ZIO")=% S:(%1["Host:")&'$D(IO("IP")) IO("IP")=$P(%,":")
-	Q
-	;
-TCPIP	;For TCP/IP devices, should use ^%ZISTCP
-	N %S
-	S %ZISTO=$G(%ZISTO,3)
-	S %A="IO:"_$S($E(%ZISOPAR)="(":"",1:"(")_%ZISOPAR_$S($E(%ZISOPAR,$L(%ZISOPAR))=")":"",1:")")_":%ZISTO:""SOCKET"""
-	;U $P W !,"%A=",%A
-	O @%A I '$T S POP=1 Q  ;D O1 ;Do the open.
-	U IO:(WIDTH=512:NOWRAP:EXCEPT="G OPNERR^%ZIS4") S %S=$KEY
-	U $P ;W !,"$KEY=",%S
-	Q
-	;
-SPOOL	;%ZDA=pointer to ^XMB(3.51, %ZFN=spool file name.
-	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
-	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="#"
-	I $D(^%ZIS(1,%ZISIOS,1)),$P(^(1),"^",8),$O(^("SPL",0)) S ^XUTL("XQ",$J,"ADSPL")=%ZISIOS,ZISPLAD=%ZISIOS
-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
-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<%
-SPLEX	C %ZFN:(DELETE) K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q
-	;
-CL2	S %=%+1 I %Z1<% S ^XMBS(3.519,XS,2,%,0)="*** INCOMPLETE REPORT  -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***",$P(^XMB(3.51,%ZDA,0),"^",11)=1 Q
-	I %2[$C(12) S ^XMBS(3.519,XS,2,%,0)="|TOP|" Q
-	S ^XMBS(3.519,XS,2,%,0)=%2 Q
-	;
-HFS	G HFS^%ZISF
-REWMT(IO,IOPAR)	;Rewind Magtape
-	S X="REWERR^%ZIS4",@^%ZOSF("TRAP")
-	U IO W *5
-	Q 1
-REWSDP(IO,IOPAR)	;Rewind SDP
-	G REW1
-REWHFS(IO,IOPAR)	;Rewind Host File.
-REW1	S X="REWERR^%ZIS4",@^%ZOSF("TRAP")
-	U IO:(REWIND)
-	Q 1
-REWERR	;Error encountered
-	Q 0
+%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))
+ S POP=0 D OP1 G NOPEN:'$D(IO(1,IO))
+OPN2 ;
+ I $D(%ZISHP),'$D(IOP) W !,*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
+ I '$D(IOP) W *7,"  [BUSY]" W "  ...  RETRY" S %=2,U="^" D YN^%ZIS1 G OPEN:%=1
+ S POP=1 Q
+ Q
+ ;Why no open paraneters???
+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
+ ;
+O ;From %ZIS6 for other types.
+ D:%IS["L" ZIO
+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["):":"",%ZTYPE["CHAN"&($P(%ZTIME,"^",3)="n"):"",1:":"_%ZISTO)
+ N % S %(IO)="",%=$P($P($NA(%(IO)),"(",2),")")
+ S %A=%_$E(":",%A]"")_%A
+ D O1 I POP D  Q
+ .I %ZTYPE="HFS",'$D(IOP),$G(IO("ERROR"))["file not found" W !,?5,*7,"[File Not Found]" Q
+ .W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q
+ ;S IO(1,IO)="" U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91)
+ U IO S $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91)
+ I %ZISUPAR]"" S %A1=""""_IO_""":"_%ZISUPAR U @%A1
+ ;U:%IS'[0 IO(0)
+ G OXECUTE^%ZIS6
+ ;
+O1 N $ES,$ET S $ET="G OPNERR^%ZIS4"
+ 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
+ ;
+ ;Need to find out how to get IP address
+ZIO N %,%1 S (%,%1)=$ZIO
+ I $ZV["VMS",%["_TNA" D
+ . S (%,%1)=$ZGETDVI($I,"TT_ACCPORNAM")
+ . S %=$S(%["Host:":$P($P(%,"Host: ",2)," ")_":"_$P(%,"Port: ",2),1:%) S:%[" " %=$TR(%," ")
+ I $ZV'["VMS" D
+ . S (%,%1)=$ZTRNLNM("REMOTEHOST") S:$L(%) %1="Host:"_% S:'$L(%) %=$ZIO
+ S IO("ZIO")=% S:(%1["Host:")&'$D(IO("IP")) IO("IP")=$P(%,":")
+ Q
+ ;
+TCPIP ;For TCP/IP devices
+ N %S
+ S %ZISTO=$G(%ZISTO,3)
+ S %A="IO:"_$S($E(%ZISOPAR)="(":"",1:"(")_%ZISOPAR_$S($E(%ZISOPAR,$L(%ZISOPAR))=")":"",1:")")_":%ZISTO:""SOCKET"""
+ ;U $P W !,"%A=",%A
+ O @%A I '$T S POP=1 Q  ;D O1 ;Do the open.
+ U IO:(WIDTH=512:NOWRAP:EXCEPT="G OPNERR^%ZIS4") S %S=$KEY
+ U $P ;W !,"$KEY=",%S
+ Q
+ ;
+SPOOL ;%ZDA=pointer to ^XMB(3.51, %ZFN=spool file name.
+ 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),%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="#"
+ I $D(^%ZIS(1,%ZISIOS,1)),$P(^(1),"^",8),$O(^("SPL",0)) S ^XUTL("XQ",$J,"ADSPL")=%ZISIOS,ZISPLAD=%ZISIOS
+OK K %ZDA,%ZFN Q
+N K %ZDA,%ZFN,IO("DOC") S POP=1 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 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
+ ;
+CL2 S %=%+1 I %Z1<% S ^XMBS(3.519,XS,2,%,0)="*** INCOMPLETE REPORT  -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***",$P(^XMB(3.51,%ZDA,0),"^",11)=1 Q
+ I %2[$C(12) S ^XMBS(3.519,XS,2,%,0)="|TOP|" Q
+ S ^XMBS(3.519,XS,2,%,0)=%2 Q
+ ;
+HFS G HFS^%ZISF
+REWMT(IO,IOPAR) ;Rewind Magtape
+ S X="REWERR^%ZIS4",@^%ZOSF("TRAP")
+ U IO W *5
+ Q 1
+REWSDP(IO,IOPAR) ;Rewind SDP
+ G REW1
+REWHFS(IO,IOPAR) ;Rewind Host File.
+REW1 S X="REWERR^%ZIS4",@^%ZOSF("TRAP")
+ U IO:(REWIND)
+ Q 1
+REWERR ;Error encountered
+ Q 0
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,131 +1,127 @@
-%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))
-	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:"")
-	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
-	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
-	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
-	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)
-	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
-	;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
-	O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)=""
-	S IO("ERROR")=""
-	Q
-	;Version 3 used ip/port, Version 4 has ip:port|xx
-ZIO	N %,%1 S %=$ZIO,%1=$$VERSION^%ZOSV
-	S IO("ZIO")=$S(%1<4:$I,1:$ZIO),%1=$S(%["/":"/",1:":")
-	;Drop prefix
-	S:%["|TNT|" %=$E(%,6,999) S:%["|TNA|" %=$E(%,6,999)
-	;Get IP name or number
-	I '$D(IO("IP")) D
-	. S:$P(%,%1)["." IO("IP")=$P(%,%1)
-	Q
-	;
-SPOOL	;%ZDA=pointer to ^XMB(3.51, %ZFN=spool file Num/Name.
-	N %ZOS S %ZOS=$$OS^%ZOSV
-	I '$D(^XMB(3.51,0)) W:'$D(IOP) !?5,"The spooler files are not setup in this account." G NO
-	I $D(ZISDA) W:'$D(IOP) !?5,$C(7)_"You may not Spool the printing of a Spool document" G NO
-	I $D(DUZ)[0 W:'$D(IOP) !,"Must be a valid user." G NO
-	;Get entry in Spool Doc file
-R	S %ZY=-1 D NEWDOC^ZISPL1:$D(DUZ)=11 G NO:%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 NO:%ZFN<0,DOC
-	I %ZOS="NT" D  G:%ZFN>255 NO
-	. F %ZFN=1:1:260 I '$D(^XMB(3.51,"C",%ZFN))!$D(^(%ZFN,%ZDA)) Q:%ZFN<256  W:'$D(IOP) $C(7)_"  DELETE SOME OTHER DOCUMENT!" Q
-	. Q:%ZFN>255  D SPL2 S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)=""
-	I %ZOS="VMS" D  G:%ZFN=-1 NO
-	. S %ZFN=IO_"SPOOL_no_"_%ZDA_".TMP" D SPL2 Q:%ZFN=-1  S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)="",IO=%ZFN
-DOC	S IO("SPOOL")=%ZDA,^XUTL("XQ",$J,"SPOOL")=%ZDA
-	I $D(^%ZIS(1,%ZISIOS,1)),$P(^(1),"^",8),$O(^("SPL",0)) S ^XUTL("XQ",$J,"ADSPL")=%ZISIOS,ZISPLAD=%ZISIOS
-OK	K %ZDA,%ZFN Q
-NO	K %ZDA,%ZFN,IO("DOC") S POP=1 Q
-	;
-SPL2	I %ZOS="NT" O IO:(%ZFN:0) S IO(1,IO)="",^SPOOL(0,IO("DOC"),%ZFN)="",^SPOOL(%ZFN,0)=IO("DOC")_"{"_$H Q
-	;VMS
-	O %ZFN:("WNS"):2 G:'$T SPL4 S IO(1,%ZFN)="" Q
-	;
-SPL3	I %ZOS="NT" G SPL4:'$D(^SPOOL(%ZFN,2147483647)) O IO:(%ZFN:$P(^(2147483647),"{",3)):1 S:'$T ZISPLQ=1 K ^(2147483647) S IO(1,IO)="" Q
-	;VMS
-	N $ETRAP S $ETRAP="S $EC="""" G SPL4^%ZIS4"
-	O %ZFN:"RV":1 S:'$T ZISPLQ=1 G:$ZA<0!('$T) SPL4 S IO(1,%ZFN)="" Q
-	;
-SPL4	W:'$D(IOP) !,"Spool file already open" S %ZFN=-1 Q
-	;
-CLOSE	N %ZOS,%Z1,%ZCR,%2,%3,%X,%Y,ZTSK,%ZFN S %ZOS=$$OS^%ZOSV
-	I %ZOS="NT",IO=2,$D(IO(1,IO)) K IO(1,IO) C IO
-	I %ZOS="VMS",IO]"",$D(IO(1,IO)) U IO S %ZFN=$ZIO C IO K IO(1,IO)
-	;See that ZTSK is set so we will move to the global now.
-	S ZTSK=$G(ZTSK,1) D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q
-	G:%ZOS="VMS" CLVMS
-	S %ZFN=$P(%ZS,"^",2),%ZCR=$C(13),%Y="",%=0,%3=$P(^SPOOL(%ZFN,2147483647),"{",3)
-	S %Z1=+$G(^XTV(8989.3,1,"SPL"))
-	F %2=1:1:%3 Q:'$D(^SPOOL(%ZFN,%2))  S %X=^SPOOL(%ZFN,%2) D
-	. I %Z1<% D LIMIT S %2=%3 Q
-	. I %X[$C(13,12) D:$L($P(%X,$C(13))) ADD($P(%X,$C(13))) D ADD("|TOP|") Q
-	. D ADD($P(%X,$C(13),1))
-	K ^SPOOL(%ZFN),^SPOOL(0,$P(%ZS,U,1)),%Y,%X,%1,%2,%3 D CLOSE^ZISPL1
-	Q
-ADD(L)	S %=%+1,^XMBS(3.519,XS,2,%,0)=L Q
-LIMIT	D ADD("*** INCOMPLETE REPORT  -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***") S $P(^XMB(3.51,%ZDA,0),"^",11)=1
-	Q
-CLVMS	;Close for Cache VMS
-	N $ES,$ET S $ET="D:$EC'[""ENDOF"" ^%ZTER,UNWIND^%ZTER S $EC="""" D SPLEX^%ZIS4,UNWIND^%ZTER"
-	S %ZA=$ZU(68,40,1) ;Work like DSM
-	;%ZFN Could be set at the top
-	S %ZFN=$S($G(%ZFN)]"":%ZFN,1:$P(%ZS,"^",2)) D SPL3 Q:%ZFN']""  U %ZFN S %ZCR=$C(13),%Y=""
-	S %Z1=+$G(^XTV(8989.3,1,"SPL")),%=0
-	F  R %X#255:5 Q:$ZEOF<0  D  G:%Z1<% SPLEX
-	. I %Z1<% D LIMIT Q
-	. I %X[$C(12) D  Q
-	. . S %Y=$P(%X,$C(12)) D:$L(%Y) ADD(%Y),ADD("|TOP|")
-	. . S %Y=$P(%X,$C(12),2) D:$L(%Y) ADD(%Y)
-	. . Q
-	. D ADD(%X)
-	. Q
-SPLEX	C %ZFN:"D" K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q
-	;
-	;
-HFS	G HFS^%ZISF
-REWMT(IO2,IOPAR)	;Rewind Magtape
-	N $ETRAP S $ET="G REWERR^%ZIS4"
-	U IO2 W *5
-	Q 1
-REWSDP(IO2,IOPAR)	;Rewind SDP
-	G REW1
-REWHFS(IO2,IOPAR)	;Rewind Host File.
-REW1	;ZIS set % to the current $I so need to update % if = IO
-	N NIO,OP,$ETRAP
-	S $ET="G REWERR^%ZIS4"
-	C IO2 ;You do a rewind to read the file.
-	S OP=$S($ZV["VMS":"RV",1:"RS")
-	O IO2:(OP):1 S IO(1,IO2)=""
-	Q 1
-REWERR	;Error encountered
-	S IO("ERROR")=$EC,$ECODE=""
-	Q 0
+%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:"")
+ 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 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
+ ;
+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(%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 %ZISUPAR]"" S %A1=""""_IO_""":"_%ZISUPAR U @%A1
+ ;U:%IS'[0 IO(0)
+ G OXECUTE^%ZIS6
+ ;
+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
+ ;Version 3 used ip/port, Version 4 has ip:port|xx
+ZIO N %,%1 S %=$ZIO,%1=$$VERSION^%ZOSV
+ S IO("ZIO")=$S(%1<4:$I,1:$ZIO),%1=$S(%["/":"/",1:":")
+ ;Drop prefix
+ S:%["|TNT|" %=$E(%,6,999) S:%["|TNA|" %=$E(%,6,999)
+ ;Get IP name or number
+ I '$D(IO("IP")) D
+ . S:$P(%,%1)["." IO("IP")=$P(%,%1)
+ Q
+ ;
+SPOOL ;%ZDA=pointer to ^XMB(3.51, %ZFN=spool file Num/Name.
+ N %ZOS S %ZOS=$$OS^%ZOSV
+ I '$D(^XMB(3.51,0)) W:'$D(IOP) !?5,"The spooler files are not setup in this account." G NO
+ I $D(ZISDA) W:'$D(IOP) !?5,$C(7)_"You may not Spool the printing of a Spool document" G NO
+ I $D(DUZ)[0 W:'$D(IOP) !,"Must be a valid user." G NO
+ ;Get entry in Spool Doc file
+R S %ZY=-1 D NEWDOC^ZISPL1:$D(DUZ)=11 G NO:%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 NO:%ZFN<0,DOC
+ I %ZOS="NT" D  G:%ZFN>255 NO
+ . F %ZFN=1:1:260 I '$D(^XMB(3.51,"C",%ZFN))!$D(^(%ZFN,%ZDA)) Q:%ZFN<256  W:'$D(IOP) $C(7)_"  DELETE SOME OTHER DOCUMENT!" Q
+ . Q:%ZFN>255  D SPL2 S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)=""
+ I %ZOS="VMS" D  G:%ZFN=-1 NO
+ . S %ZFN=IO_"SPOOL_no_"_%ZDA_".TMP" D SPL2 Q:%ZFN=-1  S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)="",IO=%ZFN
+DOC S IO("SPOOL")=%ZDA,^XUTL("XQ",$J,"SPOOL")=%ZDA
+ I $D(^%ZIS(1,%ZISIOS,1)),$P(^(1),"^",8),$O(^("SPL",0)) S ^XUTL("XQ",$J,"ADSPL")=%ZISIOS,ZISPLAD=%ZISIOS
+OK K %ZDA,%ZFN Q
+NO K %ZDA,%ZFN,IO("DOC") S POP=1 Q
+ ;
+SPL2 I %ZOS="NT" O IO:(%ZFN:0) S IO(1,IO)="",^SPOOL(0,IO("DOC"),%ZFN)="",^SPOOL(%ZFN,0)=IO("DOC")_"{"_$H Q
+ ;VMS
+ O %ZFN:("WNS"):2 G:'$T SPL4 S IO(1,%ZFN)="" Q
+ ;
+SPL3 I %ZOS="NT" G SPL4:'$D(^SPOOL(%ZFN,2147483647)) O IO:(%ZFN:$P(^(2147483647),"{",3)):1 S:'$T ZISPLQ=1 K ^(2147483647) S IO(1,IO)="" Q
+ ;VMS
+ N $ETRAP S $ETRAP="S $EC="""" G SPL4^%ZIS4"
+ O %ZFN:"RV":1 S:'$T ZISPLQ=1 G:$ZA<0!('$T) SPL4 S IO(1,%ZFN)="" Q
+ ;
+SPL4 W:'$D(IOP) !,"Spool file already open" S %ZFN=-1 Q
+ ;
+CLOSE N %ZOS,%Z1,%ZCR,%2,%3,%X,%Y,ZTSK,%ZFN S %ZOS=$$OS^%ZOSV
+ I %ZOS="NT",IO=2,$D(IO(1,IO)) K IO(1,IO) C IO
+ I %ZOS="VMS",IO]"",$D(IO(1,IO)) U IO S %ZFN=$ZIO C IO K IO(1,IO)
+ ;See that ZTSK is set so we will move to the global now.
+ S ZTSK=$G(ZTSK,1) D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q
+ G:%ZOS="VMS" CLVMS
+ S %ZFN=$P(%ZS,"^",2),%ZCR=$C(13),%Y="",%=0,%3=$P(^SPOOL(%ZFN,2147483647),"{",3)
+ S %Z1=+$G(^XTV(8989.3,1,"SPL"))
+ F %2=1:1:%3 Q:'$D(^SPOOL(%ZFN,%2))  S %X=^SPOOL(%ZFN,%2) D
+ . I %Z1<% D LIMIT S %2=%3 Q
+ . I %X[$C(13,12) D:$L($P(%X,$C(13))) ADD($P(%X,$C(13))) D ADD("|TOP|") Q
+ . D ADD($P(%X,$C(13),1))
+ K ^SPOOL(%ZFN),^SPOOL(0,$P(%ZS,U,1)),%Y,%X,%1,%2,%3 D CLOSE^ZISPL1
+ Q
+ADD(L) S %=%+1,^XMBS(3.519,XS,2,%,0)=L Q
+LIMIT D ADD("*** INCOMPLETE REPORT  -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***") S $P(^XMB(3.51,%ZDA,0),"^",11)=1
+ Q
+CLVMS ;Close for Cache VMS
+ N $ES,$ET S $ET="D:$EC'[""ENDOF"" ^%ZTER,UNWIND^%ZTER S $EC="""" D SPLEX^%ZIS4,UNWIND^%ZTER"
+ S %ZA=$ZU(68,40,1) ;Work like DSM
+ ;%ZFN Could be set at the top
+ S %ZFN=$S($G(%ZFN)]"":%ZFN,1:$P(%ZS,"^",2)) D SPL3 Q:%ZFN']""  U %ZFN S %ZCR=$C(13),%Y=""
+ S %Z1=+$G(^XTV(8989.3,1,"SPL")),%=0
+ F  R %X#255:5 Q:$ZEOF<0  D  G:%Z1<% SPLEX
+ . I %Z1<% D LIMIT Q
+ . I %X[$C(12) D  Q
+ . . S %Y=$P(%X,$C(12)) D:$L(%Y) ADD(%Y),ADD("|TOP|")
+ . . S %Y=$P(%X,$C(12),2) D:$L(%Y) ADD(%Y)
+ . . Q
+ . D ADD(%X)
+ . Q
+SPLEX C %ZFN:"D" K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q
+ ;
+ ;
+HFS G HFS^%ZISF
+REWMT(IO2,IOPAR) ;Rewind Magtape
+ N $ETRAP S $ET="G REWERR^%ZIS4"
+ U IO2 W *5
+ Q 1
+REWSDP(IO2,IOPAR) ;Rewind SDP
+ G REW1
+REWHFS(IO2,IOPAR) ;Rewind Host File.
+REW1 ;ZIS set % to the current $I so need to update % if = IO
+ N NIO,OP,$ETRAP
+ S $ET="G REWERR^%ZIS4"
+ C IO2 ;You do a rewind to read the file.
+ S OP=$S($ZV["VMS":"RV",1:"RS")
+ O IO2:(OP):1 S IO(1,IO2)=""
+ Q 1
+REWERR ;Error encountered
+ S IO("ERROR")=$EC,$ECODE=""
+ Q 0
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,101 +1,88 @@
-%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
-	;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
-	I $D(%ZISMTR) X ^%ZOSF("MAGTAPE") U IO W:$D(%MT("REW")) @%MT("REW") U IO(0) K %MT
-	G QUIT:'$D(IO("P"))
-	I $F(IO("P"),"B"),$D(^%ZIS(2,%ZISIOST(0),7)) S %Y=$P(^(7),"^",1) I %Y]"" W @%Y
-	S %Y=$F(IO("P"),"P") G QLTY:'%Y S %Y=+$E(IO("P"),%Y,99),%X=$S(%Y=16:12.1,%Y=10!(%Y=12):5,1:"") G QLTY:'%X
-	S %Y=$S($D(^%ZIS(2,%ZISIOST(0),%X)):$P(^(%X),"^",$S(%Y=12:2,1:1)),1:"")
-	I %Y]"" W @%Y
-QLTY	S %Y=$F(IO("P"),"Q") Q:'%Y  S %Y=+$E(IO("P"),%Y,99),%X=$S(%Y<0!(%Y>2):0,1:%Y+1)
-	I %X S %Y=$S($D(^%ZIS(2,%ZISIOST(0),12.2)):$P(^(12.2),"^",%X),1:"") I %Y]""  W @%Y
-QUIT	U:%IS'[0 IO(0)
-	Q
-2	Q:%Y=""  I %IS'[0,$D(^%ZIS(1,+%H,"TYPE")),^("TYPE")["TRM" D OH Q:POP
-	S %X=$T U IO D %Y^ZISX ;Q:'%X  U IO(0)
-	Q
-OH	Q:$S($G(IO(0))]"":$D(IO(1,IO(0))),1:0)
-	N X S X="OPNERR^%ZIS4",@^%ZOSF("TRAP")
-	O IO(0)::0 S IO(1,IO(0))="" Q  ;See that HOME DEVICE is open.
-	;
-SAY(%SAY)	;
-	Q:%IS[0  U IO(0) W %SAY U IO
-	Q
-RES1	;Allocate a resource slot, Release in %ZISC.
-	N A,L,X,%ZISD0
-	S %ZISD0=$O(^%ZISL(3.54,"B",IO,0))
-	I '%ZISD0 S %ZISD0=$$RADD(IO) ;New one
-	L +^%ZISL(3.54,%ZISD0,0):2 I '$T S POP=1 W:'$D(IOP) *7,"  [NOT Available]" G RESX
-RES2	S X=$P(^%ZISL(3.54,%ZISD0,0),"^",2)
-	I X<1 S POP=1 W:'$D(IOP) *7,"  [NOT Available]" G RESX
-	S X=$S(X>0:X-1,1:0),$P(^%ZISL(3.54,%ZISD0,0),"^",2)=X
-	;
-R1	;Grab a slot
-	S IO(1,IO)="RES",A=$G(^%ZISL(3.54,%ZISD0,1,0),"^3.542^^")
-	F L=1:1:%ZISRL I '$D(^%ZISL(3.54,%ZISD0,1,L,0)) Q
-	I '$T K IO(1,IO) G RES2 ;No free slots
-	S ^%ZISL(3.54,%ZISD0,1,L,0)=L_"^"_%ZISV_"^"_$J_"^"_$G(ZTSK)_"^"_$H,^%ZISL(3.54,"AJ",$J,%ZISD0,L)="",^%ZISL(3.54,%ZISD0,1,"B",L,L)=""
-	S $P(A,"^",3,4)=L_U_($P(A,U,4)+1),^%ZISL(3.54,%ZISD0,1,0)=A
-RESX	L -^%ZISL(3.54,%ZISD0,0) Q
-	;
-RADD(X)	;Add Resource
-	N %1,%2
-	S %1=$G(^%ZISL(3.54,0),"RESOURCE^3.54^^"),%2=$P(%1,U,3)
-	F %2=%2:1 Q:'$D(^%ZISL(3.54,%2,0))
-	S $P(^%ZISL(3.54,0),U,3,4)=%2_U_($P(%1,U,4)+1),^%ZISL(3.54,%2,0)=X_"^"_$G(%ZISRL,1),^%ZISL(3.54,"B",X,%2)=""
-	Q %2
-	;
-RESOK	;DEVOK check for RES devices, for all OS's.
-	N %ZISD0,%ZISD1
-	S Y=0,%ZISD0=$O(^%ZISL(3.54,"B",X,0))
-	I '%ZISD0 S Y=-1,%ZISD0=$O(^%ZIS(1,"C",X,0)) Q:'%ZISD0  Q:'$D(^%ZIS(1,+%ZISD0,0))  Q:$P(^(0),"^")'=X  Q:'$D(^("TYPE"))  Q:^("TYPE")'="RES"  S Y=0 Q
-	S X1=$G(^%ZISL(3.54,+%ZISD0,0))
-	I $P(X1,"^",2)&(X=$P(X1,"^")) S Y=0 Q
-	S Y=999 F %ZISD1=0:0 S %ZISD1=$O(^%ZISL(3.54,%ZISD0,1,%ZISD1)) Q:%ZISD1'>0  I $D(^(%ZISD1,0)) S Y=$P(^(0),"^",3) Q
-	Q
-	;
-Q	G Q^%ZIS3
-HG	;
-	Q
-SPL	;Spool type
-	N %E,%Z D MARGN^%ZIS3 W:'$D(IOP) ! D SPOOL^%ZIS4:%IS'["T"
-	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"))
-	G Q
-HFS	;Host File Server type
-	D MARGN^%ZIS3,HFS^%ZIS4 W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T"))
-	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
-	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
-CHAN	;Network Channel type devices -- DecNet or TCP/IP devices.
-	I IO="SYS$NET",$I="SYS$INPUT:;" S IO(0)=IO U IO ;DECNET Server Device
-	D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T"))
-	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"))
-	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
-	I POP,%ZISB&(%ZTYPE["TRM") C IO K IO(1,IO) Q
-	Q:POP  G SETPAR^%ZIS3
-	;
-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
-	;
+%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 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"))
+ I $F(IO("P"),"B"),$D(^%ZIS(2,%ZISIOST(0),7)) S %Y=$P(^(7),"^",1) I %Y]"" W @%Y
+ S %Y=$F(IO("P"),"P") G QLTY:'%Y S %Y=+$E(IO("P"),%Y,99),%X=$S(%Y=16:12.1,%Y=10!(%Y=12):5,1:"") G QLTY:'%X
+ S %Y=$S($D(^%ZIS(2,%ZISIOST(0),%X)):$P(^(%X),"^",$S(%Y=12:2,1:1)),1:"")
+ I %Y]"" W @%Y
+QLTY S %Y=$F(IO("P"),"Q") Q:'%Y  S %Y=+$E(IO("P"),%Y,99),%X=$S(%Y<0!(%Y>2):0,1:%Y+1)
+ I %X S %Y=$S($D(^%ZIS(2,%ZISIOST(0),12.2)):$P(^(12.2),"^",%X),1:"") I %Y]""  W @%Y
+QUIT U:%IS'[0 IO(0)
+ Q
+2 Q:%Y=""  I %IS'[0,$D(^%ZIS(1,+%H,"TYPE")),^("TYPE")["TRM" D OH Q:POP
+ S %X=$T U IO D %Y^ZISX ;Q:'%X  U IO(0)
+ Q
+OH Q:$S($G(IO(0))]"":$D(IO(1,IO(0))),1:0)
+ N X S X="OPNERR^%ZIS4",@^%ZOSF("TRAP")
+ O IO(0)::0 S IO(1,IO(0))="" Q  ;See that HOME DEVICE is open.
+ ;
+SAY(%SAY) ;
+ Q:%IS[0  U IO(0) W %SAY U IO
+ Q
+RES1 ;Allocate a resource slot, Release in %ZISC.
+ N A,L,X,%ZISD0
+ S %ZISD0=$O(^%ZISL(3.54,"B",IO,0))
+ I '%ZISD0 S %ZISD0=$$RADD(IO) ;New one
+ L +^%ZISL(3.54,%ZISD0,0):2 I '$T S POP=1 W:'$D(IOP) *7,"  [NOT Available]" G RESX
+RES2 S X=$P(^%ZISL(3.54,%ZISD0,0),"^",2)
+ I X<1 S POP=1 W:'$D(IOP) *7,"  [NOT Available]" G RESX
+ S X=$S(X>0:X-1,1:0),$P(^%ZISL(3.54,%ZISD0,0),"^",2)=X
+ ;
+R1 ;Grab a slot
+ S IO(1,IO)="RES",A=$G(^%ZISL(3.54,%ZISD0,1,0),"^3.542^^")
+ F L=1:1:%ZISRL I '$D(^%ZISL(3.54,%ZISD0,1,L,0)) Q
+ I '$T K IO(1,IO) G RES2 ;No free slots
+ S ^%ZISL(3.54,%ZISD0,1,L,0)=L_"^"_%ZISV_"^"_$J_"^"_$G(ZTSK)_"^"_$H,^%ZISL(3.54,"AJ",$J,%ZISD0,L)="",^%ZISL(3.54,%ZISD0,1,"B",L,L)=""
+ S $P(A,"^",3,4)=L_U_($P(A,U,4)+1),^%ZISL(3.54,%ZISD0,1,0)=A
+RESX L -^%ZISL(3.54,%ZISD0,0) Q
+ ;
+RADD(X) ;Add Resource
+ N %1,%2
+ S %1=$G(^%ZISL(3.54,0),"RESOURCE^3.54^^"),%2=$P(%1,U,3)
+ F %2=%2:1 Q:'$D(^%ZISL(3.54,%2,0))
+ S $P(^%ZISL(3.54,0),U,3,4)=%2_U_($P(%1,U,4)+1),^%ZISL(3.54,%2,0)=X_"^"_$G(%ZISRL,1),^%ZISL(3.54,"B",X,%2)=""
+ Q %2
+ ;
+RESOK ;DEVOK check for RES devices, for all OS's.
+ N %ZISD0,%ZISD1
+ S Y=0,%ZISD0=$O(^%ZISL(3.54,"B",X,0))
+ I '%ZISD0 S Y=-1,%ZISD0=$O(^%ZIS(1,"C",X,0)) Q:'%ZISD0  Q:'$D(^%ZIS(1,+%ZISD0,0))  Q:$P(^(0),"^")'=X  Q:'$D(^("TYPE"))  Q:^("TYPE")'="RES"  S Y=0 Q
+ S X1=$G(^%ZISL(3.54,+%ZISD0,0))
+ I $P(X1,"^",2)&(X=$P(X1,"^")) S Y=0 Q
+ S Y=999 F %ZISD1=0:0 S %ZISD1=$O(^%ZISL(3.54,%ZISD0,1,%ZISD1)) Q:%ZISD1'>0  I $D(^(%ZISD1,0)) S Y=$P(^(0),"^",3) Q
+ Q
+ ;
+Q G Q^%ZIS3
+HG ;
+ Q
+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 D MARGN^%ZIS3,ASKPAR W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Sequential disk processor type
+ G Q
+HFS D MARGN^%ZIS3,HFS^%ZIS4 W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Host File Server type
+ G 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
+CHAN ;Network Channel type devices -- DecNet or TCP/IP devices.
+ I IO="SYS$NET",$I="SYS$INPUT:;" S IO(0)=IO U IO ;DECNET Server Device
+ D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T"))
+ G Q
+IMPC ;Imaging Work Station
+BAR ;Bar Code
+OTH D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Other Device type
+ G Q
+ ;
+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
+ ;
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,130 +1,131 @@
-%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
-C0	;
-	N %,%E,%H,%ZISI,%ZISOS,%ZISX,%ZISV
-	;Clear IO var we will use for reporting
-	K IO("ERROR"),IO("LASTERR"),IO("CLOSE")
-	;Protect ourself from calls with incomplete setup.
-	S:$D(IO)[0 IO=$I S:'$D(IO(0)) IO(0)=$P
-	S U="^",%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^("VOL"))
-	;S %=$S(+$G(IOS):IOS,$L($G(ION)):ION,1:IO)
-	S %=$S($L($G(ION)):ION,1:IO) ;p409
-	I (%="")!(IO="") G SETIO:IO(0)]"",END
-	I $G(IOT)="RES" D RES G SETIO ;Handle a resource device
-	;
-	;Define subtype info if not already defined.
-	D SUBTYPE
-	;
-	;perform close execute
-	I $G(IOST(0))>0 D
-	. I $G(^%ZIS(2,+IOST(0),3))]"",$D(IO(1,IO)) D
-	. . U IO S:$X $X=1 D X3^ZISX:'$D(IO("T"))
-	;
-	;Incase the Close execute changed IO, Open IO("HOME") or NULL.
-	I '$L($G(IO)) D  Q
-	. S IOP=$S($L($G(IO("HOME"))):"`"_(+IO("HOME")),1:"NULL") D ^%ZIS
-	. Q
-	;
-	;Perform the following if the device is open.
-	I $D(IO(1,IO)) D
-	. I $G(IO("P"))["B" D  ;Return to normal intensity
-	. . S %=$P($G(^%ZIS(2,+IOST(0),7)),"^",3) I %]"" W @%
-	. I $G(IO("P"))["P" D  ;Return to default pitch
-	. . S %=$G(^%ZIS(2,+IOST(0),12.11)) I %]"" W @%
-	. ;
-	. W:$$FF @IOF ;Issue form feed at close
-	. I $$CLOSPP D X11^ZISX:'$D(IO("T")) K IO("S") ;Close printer port
-	. Q
-	;
-	;Don't use IOCPU as we now use IO(1,IO)
-	I (IO'=IO(0)!$D(IO("C"))),$D(IO(1,IO)) D
-	. 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(IO("SPOOL")) D CLOSE^%ZIS4 ;Special close for spool device
-	;
-SETIO	;
-	;See if old device has PCX code
-	I $G(IOS),$G(^%ZIS(1,+IOS,"PCX"))]"" S %ZISPCX=^("PCX")
-	;Setup the IO(0) device, should be the home device
-	S IO=IO(0),(IOPAR,IOUPAR)="" K IO("T") D CIOS(IO(0))
-	I 'IOS S IOT="TRM" G END
-	S ION=$P(^%ZIS(1,IOS,0),"^",1),IOT=$G(^("TYPE")),IOST(0)=$S(IOT["TRM"&($D(^XUTL("XQ",$J,"IOST(0)"))):^("IOST(0)"),1:$G(^%ZIS(1,IOS,"SUBTYPE")))
-	I IOT["TRM",$D(^XUTL("XQ",$J,"IO")) D HOME^%ZIS G END
-	S %="Y"
-	I IOST(0),$D(^%ZIS(2,IOST(0),1)) S %=^(1),IOM=+%,IOF=$P(%,"^",2),IOSL=$P(%,"^",3),IOBS=$P(%,"^",4)
-	I $D(^%ZIS(1,IOS,91)) S %=^%ZIS(1,IOS,91) S:+% IOM=+% S:$P(%,"^",3) IOSL=$P(%,"^",3)
-	;Don't know the subtype so set some defaults
-	I %="Y" S IOM=80,IOSL=24,IOF="#",IOST="C-OTHER",IOBS="$C(8)"
-S1	S:IOST(0) IOST=$P($G(^%ZIS(2,+IOST(0),0)),"^"),IOXY=$G(^("XY"))
-	I '$D(ZTQUEUED),'$D(IO("C")),IOT["TRM" D RM:$D(IO(1,IO))
-	;With home device set, Do Post-close execute code of Device closed.
-END	I '$D(IO("T")),$G(%ZISPCX)]"" S %Y=%ZISPCX D %Y^ZISX
-	;See that any extra IO variables are cleaned up
-	K IO("P"),IO("DOC"),IO("HFSIO"),IO("SPOOL"),IOC,IONOFF
-	;IOCPU should not be changed.
-	Q
-	;
-SUBTYPE	;Find a subtype
-	N %S
-	S IOST=$G(IOST),IOST(0)=+$G(IOST(0))
-	I $L(IOST)&$L(IOST(0)) Q  ;Have a subtype
-	S %S=$G(^%ZIS(2,+IOST(0),0)) I $L(%S) S IOST=$P(%S,U) Q
-	I $L(IOST) S %S=$O(^%ZIS(2,"B",$G(IOST,"X"),0)) I %S>0 S IOST(0)=+%S Q
-	S IOST="",IOST(0)=0 D CIOS($I) Q:IOS'>0
-	S IOST(0)=$G(^%ZIS(1,+IOS,"SUBTYPE")),IOST=$P($G(^%ZIS(2,+IOST(0),0)),"^")
-	Q
-	;
-CIOS(%I)	;Find a value for IOS (IEN into device file)
-	N %ZISVT
-	I $D(^XUTL("XQ",$J,"IOS")) S IOS=+^("IOS") Q
-	I $D(%ZISV) S %ZISVT=%I D VTLKUP^%ZIS S IOS=+%E
-	E  S IOS=+$O(^%ZIS(1,"C",%I,0))
-	Q:$G(IOS)>0
-	S %ZISVT=%I D VIRTUAL^%ZIS
-	I $D(%ZISVT) S %H=%E I %ZISVT]"",%H>0,$D(^%ZIS(1,%H,0)),$D(^("TYPE")),^("TYPE")="VTRM" S IOS=%H
-	Q
-	;
-RM	N X S X=+IOM X ^%ZOSF("RM")
-	Q
-	;
-RES	;Close resource device.
-	Q:'$D(IO(1,IO))&'$D(^%ZISL(3.54,"AJ",$J))
-	N %ZISJOB,%X,%Y,%ZISD0,%ZISD1,%ZISRES,%ZISRL,%ZISY0,%ZTRTN,ZTSAVE,ZTIO
-	S %ZISJOB=$J
-	;
-RES1	G RQ:'$D(IOS),RQ:'$D(^%ZIS(1,+IOS,1)) S %ZISRL=+$P(^(1),"^",10),%ZISRL=$S(%ZISRL:%ZISRL,1:1)
-	S %X=$O(^%ZISL(3.54,"B",IO,0)) G RQ:'%X
-	G RQ:'$D(^%ZISL(3.54,+%X,0)) S %ZISD0=+%X,%ZISY0=^(0)
-	S %X=$O(^%ZISL(3.54,"AJ",%ZISJOB,%ZISD0,0)) S %ZISD1=%X G RQ:'%X
-	S %Y=$G(^%ZISL(3.54,%ZISD0,1,+%ZISD1,0)) G RQ:$P(%Y,"^",3)'=%ZISJOB
-	D KILLRES(+%ZISD0,+%ZISD1)
-RQ	K IO(1,IO)
-	Q
-	;
-KILLRES(D0,D1)	;Kill one resource use
-	Q:(D0'>0)!(D1'>0)
-	N %X,%Y,%J,%ZISRL
-	L +^%ZISL(3.54,D0,0)
-	S %Y=$G(^%ZISL(3.54,D0,0)) G KRX:%Y=""
-	S %X=$G(^%ZISL(3.54,D0,1,D1,0)),%J=$P(%X,"^",3) S:%J="" %J=" "
-	K ^%ZISL(3.54,D0,1,D1,0),^%ZISL(3.54,D0,1,"B",D1,D1),^%ZISL(3.54,"AJ",%J,D0,D1)
-	S %X=$P(%Y,"^",2)+1,$P(^%ZISL(3.54,D0,0),"^",2)=%X
-	;I '$D(^%ZISL(3.54,%ZISD0,1,0)) S ^(0)="^3.542A^^" G RQ
-	S %Y=$G(^%ZISL(3.54,D0,1,0)),%X=$P(%Y,"^",4),$P(^%ZISL(3.54,D0,1,0),"^",3,4)="^"_$S(%X>0:(%X-1),1:0)
-KRX	L -^%ZISL(3.54,D0,0)
-	Q
-	;
-DQCRES	;Tasked entry point to close resource device.
-	S IO=%ZISRES G RES1
-	;
-FF()	;Issue form feed
-	I $E(IOST,1,2)'["C-",$D(IO(1,IO)),$G(IOT)="TRM"!($G(IOT)="SPL"),'$D(IO("T"))&$Y&'$D(IONOFF)&'$D(IO(1,IO,"NOFF")) Q 1
-	Q 0
-	;
-CLOSPP()	;Close printer port
-	I $D(IO("S")),$D(^%ZIS(2,+IO("S"),11))&$D(IO(1,IO)) Q 1
-	Q 0
+%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
+ ;Clear IO var we will use for reporting
+ K IO("ERROR"),IO("LASTERR"),IO("CLOSE")
+ ;Protect ourself from calls with incomplete setup.
+ S:$D(IO)[0 IO=$I S:'$D(IO(0)) IO(0)=$P
+ S U="^",%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^("VOL"))
+ ;S %=$S(+$G(IOS):IOS,$L($G(ION)):ION,1:IO)
+ S %=$S($L($G(ION)):ION,1:IO) ;p409
+ I (%="")!(IO="") G SETIO:IO(0)]"",END
+ I $G(IOT)="RES" D RES G SETIO ;Handle a resource device
+ ;
+ ;Define subtype info if not already defined.
+ D SUBTYPE
+ ;
+ ;perform close execute
+ I $G(IOST(0))>0 D
+ . I $G(^%ZIS(2,+IOST(0),3))]"",$D(IO(1,IO)) D
+ . . U IO S:$X $X=1 D X3^ZISX:'$D(IO("T"))
+ ;
+ ;Incase the Close execute changed IO, Open IO("HOME") or NULL.
+ I '$L($G(IO)) D  Q
+ . S IOP=$S($L($G(IO("HOME"))):"`"_(+IO("HOME")),1:"NULL") D ^%ZIS
+ . Q
+ ;
+ ;Perform the following if the device is open.
+ I $D(IO(1,IO)) D
+ . I $G(IO("P"))["B" D  ;Return to normal intensity
+ . . S %=$P($G(^%ZIS(2,+IOST(0),7)),"^",3) I %]"" W @%
+ . I $G(IO("P"))["P" D  ;Return to default pitch
+ . . S %=$G(^%ZIS(2,+IOST(0),12.11)) I %]"" W @%
+ . ;
+ . W:$$FF @IOF ;Issue form feed at close
+ . I $$CLOSPP D X11^ZISX:'$D(IO("T")) K IO("S") ;Close printer port
+ . Q
+ ;
+ ;Don't use IOCPU as we now use IO(1,IO)
+ I (IO'=IO(0)!$D(IO("C"))),$D(IO(1,IO)) D
+ . 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
+ ;
+ ;
+ 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
+ ;
+SETIO ;
+ ;See if old device has PCX code
+ I $G(IOS),$G(^%ZIS(1,+IOS,"PCX"))]"" S %ZISPCX=^("PCX")
+ ;Setup the IO(0) device, should be the home device
+ S IO=IO(0),(IOPAR,IOUPAR)="" K IO("T") D CIOS(IO(0))
+ I 'IOS S IOT="TRM" G END
+ S ION=$P(^%ZIS(1,IOS,0),"^",1),IOT=$G(^("TYPE")),IOST(0)=$S(IOT["TRM"&($D(^XUTL("XQ",$J,"IOST(0)"))):^("IOST(0)"),1:$G(^%ZIS(1,IOS,"SUBTYPE")))
+ I IOT["TRM",$D(^XUTL("XQ",$J,"IO")) D HOME^%ZIS G END
+ S %="Y"
+ I IOST(0),$D(^%ZIS(2,IOST(0),1)) S %=^(1),IOM=+%,IOF=$P(%,"^",2),IOSL=$P(%,"^",3),IOBS=$P(%,"^",4)
+ I $D(^%ZIS(1,IOS,91)) S %=^%ZIS(1,IOS,91) S:+% IOM=+% S:$P(%,"^",3) IOSL=$P(%,"^",3)
+ ;Don't know the subtype so set some defaults
+ I %="Y" S IOM=80,IOSL=24,IOF="#",IOST="C-OTHER",IOBS="$C(8)"
+S1 S:IOST(0) IOST=$P($G(^%ZIS(2,+IOST(0),0)),"^"),IOXY=$G(^("XY"))
+ I '$D(ZTQUEUED),'$D(IO("C")),IOT["TRM" D RM:$D(IO(1,IO))
+ ;With home device set, Do Post-close execute code of Device closed.
+END I '$D(IO("T")),$G(%ZISPCX)]"" S %Y=%ZISPCX D %Y^ZISX
+ ;See that any extra IO variables are cleaned up
+ K IO("P"),IO("DOC"),IO("HFSIO"),IO("SPOOL"),IOC,IONOFF
+ ;IOCPU should not be changed.
+ Q
+ ;
+SUBTYPE ;Find a subtype
+ N %S
+ S IOST=$G(IOST),IOST(0)=+$G(IOST(0))
+ I $L(IOST)&$L(IOST(0)) Q  ;Have a subtype
+ S %S=$G(^%ZIS(2,+IOST(0),0)) I $L(%S) S IOST=$P(%S,U) Q
+ I $L(IOST) S %S=$O(^%ZIS(2,"B",$G(IOST,"X"),0)) I %S>0 S IOST(0)=+%S Q
+ S IOST="",IOST(0)=0 D CIOS($I) Q:IOS'>0
+ S IOST(0)=$G(^%ZIS(1,+IOS,"SUBTYPE")),IOST=$P($G(^%ZIS(2,+IOST(0),0)),"^")
+ Q
+ ;
+CIOS(%I) ;Find a value for IOS (IEN into device file)
+ N %ZISVT
+ I $D(^XUTL("XQ",$J,"IOS")) S IOS=+^("IOS") Q
+ I $D(%ZISV) S %ZISVT=%I D VTLKUP^%ZIS S IOS=+%E
+ E  S IOS=+$O(^%ZIS(1,"C",%I,0))
+ Q:$G(IOS)>0
+ S %ZISVT=%I D VIRTUAL^%ZIS
+ I $D(%ZISVT) S %H=%E I %ZISVT]"",%H>0,$D(^%ZIS(1,%H,0)),$D(^("TYPE")),^("TYPE")="VTRM" S IOS=%H
+ Q
+ ;
+RM N X S X=+IOM X ^%ZOSF("RM")
+ Q
+ ;
+RES ;Close resource device.
+ Q:'$D(IO(1,IO))&'$D(^%ZISL(3.54,"AJ",$J))
+ N %ZISJOB,%X,%Y,%ZISD0,%ZISD1,%ZISRES,%ZISRL,%ZISY0,%ZTRTN,ZTSAVE,ZTIO
+ S %ZISJOB=$J
+ ;
+RES1 G RQ:'$D(IOS),RQ:'$D(^%ZIS(1,+IOS,1)) S %ZISRL=+$P(^(1),"^",10),%ZISRL=$S(%ZISRL:%ZISRL,1:1)
+ S %X=$O(^%ZISL(3.54,"B",IO,0)) G RQ:'%X
+ G RQ:'$D(^%ZISL(3.54,+%X,0)) S %ZISD0=+%X,%ZISY0=^(0)
+ S %X=$O(^%ZISL(3.54,"AJ",%ZISJOB,%ZISD0,0)) S %ZISD1=%X G RQ:'%X
+ S %Y=$G(^%ZISL(3.54,%ZISD0,1,+%ZISD1,0)) G RQ:$P(%Y,"^",3)'=%ZISJOB
+ D KILLRES(+%ZISD0,+%ZISD1)
+RQ K IO(1,IO)
+ Q
+ ;
+KILLRES(D0,D1) ;Kill one resource use
+ Q:(D0'>0)!(D1'>0)
+ N %X,%Y,%J,%ZISRL
+ L +^%ZISL(3.54,D0,0)
+ S %Y=$G(^%ZISL(3.54,D0,0)) G KRX:%Y=""
+ S %X=$G(^%ZISL(3.54,D0,1,D1,0)),%J=$P(%X,"^",3) S:%J="" %J=" "
+ K ^%ZISL(3.54,D0,1,D1,0),^%ZISL(3.54,D0,1,"B",D1,D1),^%ZISL(3.54,"AJ",%J,D0,D1)
+ S %X=$P(%Y,"^",2)+1,$P(^%ZISL(3.54,D0,0),"^",2)=%X
+ ;I '$D(^%ZISL(3.54,%ZISD0,1,0)) S ^(0)="^3.542A^^" G RQ
+ S %Y=$G(^%ZISL(3.54,D0,1,0)),%X=$P(%Y,"^",4),$P(^%ZISL(3.54,D0,1,0),"^",3,4)="^"_$S(%X>0:(%X-1),1:0)
+KRX L -^%ZISL(3.54,D0,0)
+ Q
+ ;
+DQCRES ;Tasked entry point to close resource device.
+ S IO=%ZISRES G RES1
+ ;
+FF() ;Issue form feed
+ I $E(IOST,1,2)'["C-",$D(IO(1,IO)),$G(IOT)="TRM"!($G(IOT)="SPL"),'$D(IO("T"))&$Y&'$D(IONOFF)&'$D(IO(1,IO,"NOFF")) Q 1
+ Q 0
+ ;
+CLOSPP() ;Close printer port
+ I $D(IO("S")),$D(^%ZIS(2,+IO("S"),11))&$D(IO(1,IO)) Q 1
+ Q 0
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,49 +1,23 @@
-ZISEDIT	;ISF/AC - DEVICE EDIT ;01/17/2008
-	;;8.0;KERNEL;**440**;Jul 10, 1995;Build 13
-	;
-TRM	;TRM or VTRM
-	D EDIT("TRM",,"Select Terminal/Printer Device: ")
-	Q
-	;
-LPD	;LPD fields of a TRM device
-	D EDIT("LPD","TRM","Select LPD (Terminal/Printer) Device: ")
-	Q
-	;
-MT	;Mag Tape
-	D EDIT("MT",,"Select Magtape Device: ")
-	Q
-	;
-SDP	;
-	D EDIT("SDP",,"Select SDP Device: ")
-	Q
-	;
-SPL	;Spool
-	D EDIT("SPL",,"Select Spool Device: ")
-	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
-	S DR="[XUDEVICE "_ZISTYPE_"]",DDSFILE=3.5 D ^DDS
-	G ED2
-	Q
+ZISEDIT ;SFISC/AC - DEVICE EDIT ;11/9/92  17:00
+ ;;8.0;KERNEL;;Jul 10, 1995
+ ;
+MT S ZISTYPE="MT",DIC("A")="Select Magtape Device: " D EDIT K ZISTYPE
+ Q
+ ;
+SDP S ZISTYPE="SDP",DIC("A")="Select SDP Device: " D EDIT K ZISTYPE
+ Q
+ ;
+SPL S ZISTYPE="SPL",DIC("A")="Select Spool Device: " D EDIT K ZISTYPE
+ Q
+ ;
+HFS S ZISTYPE="HFS",DIC("A")="Select Host File Device: " D EDIT K ZISTYPE
+ Q
+ ;
+CHAN S ZISTYPE="CHAN",DIC("A")="Select Network Channel: " D EDIT K ZISTYPE
+ 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
+ K DA,DR,DDSFILE Q
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,281 +1,246 @@
-%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
-	; **MODIFIED VERSION FOR CACHE/VMS -- 9/7/01**
-	;
-OPEN(X1,X2,X3,X4,X5,X6)	   ;SR. Open Host File
-	;X1=handle name
-	;X2=directory name \dir\
-	;X3=file name
-	;X4=file access mode e.g.: W for write, R for read, A for append.
-	;X5=Max record size for a new file, X6=Subtype
-	N %,%1,%2,%I,%ZOS,%T,%ZA,%ZISHIO,$ET
-	S $ET="D OPNERR^%ZISH"
-	S U="^",%I=$I,%T=0,POP=0,X2=$$DEFDIR($G(X2)),%ZOS=$$OS^%ZOSV M %ZISHIO=IO
-	I %ZOS'="VMS" S %1=$S(X4["A":"AW",X4["W":"WN",1:"R")_$S(X4["B":"U",1:"S") ;NT & Unix
-	I %ZOS="VMS" S %1=$S(X4["A":"AW",X4["W":"WN",1:"RH")_$S(X4["B":"U",1:"S")
-	;The next line eliminates the <ENDOFFILE> error for sequential files for the current process.
-	S %ZA=$ZUTIL(68,40,1) ;Work like DSM
-	S %=X2_X3 O %:(%1):2 I '$T S POP=1 Q
-	;U % S %ZA=$ZA ;Comment out, $ZA is for READ status
-	;I %ZA=-1 U:%I]"" %I C % S POP=1 Q
-	S IO=%,IO(1,IO)="",IOT="HFS",IOM=80,IOSL=60,POP=0 D SUBTYPE^%ZIS3($G(X6,"P-OTHER"))
-	I $G(X1)]"" D SAVDEV^%ZISUTL(X1)
-	U $S(%I]"":%I,1:$P)
-	Q
-	;
-OPNERR	;Handle open error
-	S POP=1,$ECODE=""
-	U:$P]"" $P
-	Q
-	;
-CLOSE(X)	;SR. Close HFS device not opened by %ZIS.
-	;X=HANDLE NAME
-	;IO=Device
-	N %
-	I $G(IO)]"" C IO K IO(1,IO)
-	I $G(X)]"" D RMDEV^%ZISUTL(X)
-	;Only reset home if one setup.
-	I $D(IO("HOME"))!$D(^XUTL("XQ",$J,"IOS")) D HOME^%ZIS
-	Q
-	;
-OPENERR	;
-	Q 0
-	;
-DEL(%ZX1,%ZX2)	;ef,SR. Del files, return 1 if deleted all requested.
-	;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 $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")
-	Q %ZXDEL
-	;
-DELERR	;Trap any $ETRAP error, unwind and return.
-	S $ETRAP="D UNWIND^%ZTER"
-	S %ZXDEL=0,%ZARG=""
-	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
-	;
-	N %ZISH,%ZISHN,%ZX,%ZISHY,%ZY,%ZOS
-	S %ZX1=$$DEFDIR($G(%ZX1)),%ZOS=$$OS^%ZOSV
-	;S %ZX1=$$TRNLNM(%ZX1)
-	;Get fls to act on
-	S %ZISH="" F  S %ZISH=$O(@%ZX2@(%ZISH)) Q:%ZISH=""  D
-	. S %ZISHY=$P(%ZISH,"*")
-	. I %ZOS="VMS",%ZISH'["." S %ZISH=%ZISH_".*" ;Allways upper
-	. ;NT, display case, ignore for lookup
-	. S %ZX=%ZX1_%ZISH
-	. F %ZISHN=0:1 D  Q:(%ZX="")
-	. . S %ZX=$ZSEARCH($S(%ZISHN:"",1:%ZX))
-	. . ;Q:(%ZX="")!($$UP^XLFSTR(%ZX)'[%ZISHY)!(%ZX?.E1.2".")
-	. . Q:(%ZX="")!(%ZX?.E1.2".")
-	. . I %ZOS="VMS" S %ZX=$P(%ZX,"]",2),@%ZX3@(%ZX)=""
-	. . I %ZOS="NT" S %ZY=$P(%ZX,"\",$L(%ZX,"\")),@%ZX3@(%ZY)=""
-	. . I %ZOS="UNIX" S %ZY=$P(%ZX,"/",$L(%ZX,"/")) Q:%ZX'[%ZISHY  S @%ZX3@(%ZY)=""
-	. . Q
-	Q $O(@%ZX3@(""))]""
-	;
-MV(X1,X2,Y1,Y2)	;ef,SR. Rename a fl
-	;S Y=$$MV^ZOSHDOS("\dir\","fl","\dir\","fl")
-	;Unix use mv, NT/VMS use COPY and DEL
-	N %,X,Y,%ZOS,%ZISHX S %ZOS=$$OS^%ZOSV
-	S X1=$$DEFDIR($G(X1)),Y1=$$DEFDIR($G(Y1))
-	S X=$ZSEARCH(X1_X2),Y=Y1_Y2 ;move X to Y
-	I X="" Q 0
-	S %=$ZF(-1,$S(%ZOS="UNIX":"mv ",1:"copy ")_X_" "_Y) ;Use NT/VMS copy
-	I %ZOS'="UNIX" D
-	. S X2=$P(X,X1,2),%ZISHX(X2)=""
-	. S Y=$$DEL^%ZISH(X1,$NA(%ZISHX))
-	Q 1
-	;
-PWD()	;ef,SR. Print working directory
-	N Y,%ZOS
-	S Y=$$DEFDIR(""),%ZOS=$$OS^%ZOSV
-	I Y="" S Y=$ZSEARCH("*")
-	Q $S(%ZOS["VMS":Y,1:$P(Y,".",1))
-	;
-TRNLNM(PATH)	;ef. Expand logical path
-	N %ZOS,P1,P2
-	S %ZOS=$$OS^%ZOSV,PATH=$G(PATH)
-	I %ZOS="VMS" D  Q PATH
-	. S P1=PATH_$S(PATH[":":"*.*",1:":*.*")
-	. S P2=$ZSEARCH(P1)
-	. S:$L(P2) PATH=$S(P2["]":$P(P2,"]",1)_"]",1:$P(P2,":",1)_":")
-	. Q
-	I %ZOS="NT" D  Q PATH
-	. S P1=PATH_$S($E(PATH,$L(PATH))'="\":"\*",1:"*"),P2=$ZSEARCH(P1)
-	. S:$L(P2) PATH=$P(P2,"\",1,$L(P2,"\")-1)_"\"
-	. Q
-	I %ZOS="UNIX" D  Q PATH
-	. S P1=PATH_$S($E(PATH,$L(PATH))'="/":"/*",1:"*"),P2=$ZSEARCH(P1)
-	. S:$L(P2) PATH=$P(P2,"/",1,$L(P2,"/")-1)_"/"
-	. Q
-	Q PATH
-	;
-DEFDIR(DF)	;ef. Default Dir and frmt
-	;Need to handle NT, VMS and Linux
-	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))
-	Q:DF="" ""
-	;Check syntax, VMS needs disk:[dir] or logical:
-	I %ZOS="VMS" D
-	. I DF[":" S P1=$P(DF,":")_":",P2=$P(DF,":",2)
-	. E  S P1="",P2=DF
-	. I P1="",P2["$" S P1=P2,P2=""  ;Could be a logical
-	. I $L(P2) S:P2'["[" P2="["_P2 S:P2'["]" P2=P2_"]"
-	. S DF=P1_P2 S:DF'[":" DF=DF_":"
-	. Q
-	;Check syntax, Unix needs /mnt/fl, ./fl, ~/fl $HOME/fl
-	I %ZOS="UNIX" D
-	. S DF=$TR(DF,"\","/")
-	. S:$E(DF,$L(DF))'="/" DF=DF_"/"
-	. Q
-	;Check syntax, NT needs c:\dir\
-	I %ZOS="NT" D
-	. N P1,P2
-	. I DF[":" S P1=$P(DF,":")_":",P2=$P(DF,":",2)
-	. E  S P1="",P2=DF
-	. S P2=$TR(P2,"/","\")
-	. I $L(P2) S:".\"'[$E(P2,1) P2="\"_P2 S:$E(P2,$L(P2))'="\" P2=P2_"\"
-	. S DF=P1_P2
-	. Q
-	S DF=$$TRNLNM(DF) ;Resolve logicals
-	Q DF
-	;
-FL(X)	;Fl len
-	N ZOSHP1,ZOSHP2
-	S ZOSHP1=$P(X,"."),ZOSHP2=$P(X,".",2)
-	I $L(ZOSHP1)>8 S X=4 Q
-	I $L(ZOSHP2)>3 S X=4 Q
-	Q
-	;
-STATUS()	;ef,SR. Return EOF status
-	U $I
-	Q $$EOF($ZEOF)
-	;
-EOF(X)	;Eof flag, pass in $ZEOF
-	Q (X=-1)
-	;
-MAKEREF(HF,IX,OVF)	;Internal call to rebuild global ref.
-	;Return %ZISHF,%ZISHO,%ZISHI,%ZISUB
-	N I,F,MX
-	S OVF=$G(OVF,"%ZISHOF")
-	S %ZISHI=$QS(HF,IX),MX=$QL(HF) ;
-	S F=$NA(@HF,IX-1) ;Get first part
-	I IX=1 S %ZISHF=F_"(%ZISHI" ;Build root, IX=1
-	I IX>1 S %ZISHF=$E(F,1,$L(F)-1)_",%ZISHI" ;Build root
-	S %ZISHO=%ZISHF_","_OVF_",%OVFCNT)" ;Make overflow
-	F I=IX+1:1:MX S %ZISHF=%ZISHF_",%ZISUB("_I_")",%ZISUB(I)=$QS(HF,I)
-	S %ZISHF=%ZISHF_")"
-	Q
-	;
-READNXT(REC)	;Read any sized record into array. %ZB has terminator
-	N %,I,X,$ES,$ET S REC="",$ET="D READNX^%ZISH Q"
-	U IO R X:5 S %ZB=$A($ZB),REC=$E(X,1,255)
-	Q:$L(X)<256
-	S %=256 F I=1:1 Q:$L(X)<%  S REC(I)=$E(X,%,%+254),%=%+255
-	Q
-READNX	;Check for EOF
-	I $ZE["ENDOFFILE" S %ZA=-1
-	S $EC=""
-	Q
-	;
-FTG(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5)	;ef,SR. Unload contents of host file into global
-	;p1=hostf file directory
-	;p2=host file name
-	;p3= $NAME REFERENCE INCLUDING STARTING SUBSCRIPT
-	;p4=INCREMENT SUBSCRIPT
-	;p5=Overflow subscript, defaults to "OVF"
-	N %ZA,%ZB,%ZC,X,%OVFCNT,%ZISHF,%ZISHO,POP,%ZISUB,$ES,$ET
-	N I,%ZISH,%ZISH1,%ZISHI,%ZISHL,%ZISHOF,%ZISHOX,%ZISHS,%ZX,%ZISHY
-	S %ZX1=$$DEFDIR($G(%ZX1)),%ZISHOF=$G(%ZX5,"OVF")
-	D MAKEREF(%ZX3,%ZX4,"%ZISHOF")
-	D OPEN^%ZISH(,%ZX1,%ZX2,"R")
-	I POP Q 0
-	S %ZC=1,%ZA=0,$ET="S %ZC=0,%ZA=-1,$EC="""" Q"
-	U IO F  K %XX D READNXT(.%XX) Q:$$EOF($ZEOF)!%ZA  D
-	. S @%ZISHF=%XX
-	. I $D(%XX)>2 F %OVFCNT=1:1 Q:'$D(%XX(%OVFCNT))  S @%ZISHO=%XX(%OVFCNT)
-	. S %ZISHI=%ZISHI+1
-	. Q
-	D CLOSE() ;Normal exit
-	Q %ZC
-	;
-GTF(%ZX1,%ZX2,%ZX3,%ZX4)	;ef,SR. Load contents of global to host file.
-	;p1=$NAME of global reference
-	;p2=incrementing subscript
-	;p3=host file directory
-	;p4=host file name
-	N %ZISHY,%ZISHOX
-	S %ZISHY=$$MGTF(%ZX1,%ZX2,%ZX3,%ZX4,"W")
-	Q %ZISHY
-	;
-GATF(%ZX1,%ZX2,%ZX3,%ZX4)	;ef,SR. Append to host file.
-	;
-	;p1=$NAME of global reference
-	;p2=incrementing subscript
-	;p3=host file directory
-	;p4=host file name
-	N %ZISHY
-	S %ZISHY=$$MGTF(%ZX1,%ZX2,%ZX3,%ZX4,"A")
-	Q %ZISHY
-	;
-MGTF(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5)	;
-	;p1=$NAME of global reference
-	;p2=incrementing subscript
-	;p3=host file directory
-	;p4=host file name
-	N %ZISH,%ZISH1,%ZISHI,%ZISHL,%ZISHS,%ZISHOX,IO,%ZX,Y,%ZC
-	D MAKEREF(%ZX1,%ZX2)
-	D OPEN^%ZISH(,$G(%ZX3),%ZX4,%ZX5) ;Default dir set in open
-	I POP Q 0
-	N $ETRAP S $ETRAP="S $EC="""" D CLOSE^%ZISH() Q 0"
-	F  Q:'($D(@%ZISHF)#2)  S %ZX=@%ZISHF,%ZISHI=%ZISHI+1 U IO W %ZX,!
-	D CLOSE()
-	Q 1
-	;
+%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**
+ ;
+OPEN(X1,X2,X3,X4,X5,X6)    ;SR. Open Host File
+ ;X1=handle name
+ ;X2=directory name \dir\
+ ;X3=file name
+ ;X4=file access mode e.g.: W for write, R for read, A for append.
+ ;X5=Max record size for a new file, X6=Subtype
+ N %,%1,%2,%I,%ZOS,%T,%ZA,%ZISHIO,$ET
+ S $ET="D OPNERR^%ZISH"
+ S U="^",%I=$I,%T=0,POP=0,X2=$$DEFDIR($G(X2)),%ZOS=$$OS^%ZOSV M %ZISHIO=IO
+ I %ZOS'="VMS" S %1=$S(X4["A":"AW",X4["W":"WN",1:"R")_$S(X4["B":"U",1:"S") ;NT & Unix
+ I %ZOS="VMS" S %1=$S(X4["A":"AW",X4["W":"WN",1:"RH")_$S(X4["B":"U",1:"S")
+ ;The next line eliminates the <ENDOFFILE> error for sequential files for the current process.
+ S %ZA=$ZUTIL(68,40,1) ;Work like DSM
+ S %=X2_X3 O %:(%1):2 I '$T S POP=1 Q
+ ;U % S %ZA=$ZA ;Comment out, $ZA is for READ status
+ ;I %ZA=-1 U:%I]"" %I C % S POP=1 Q
+ S IO=%,IO(1,IO)="",IOT="HFS",IOM=80,IOSL=60,POP=0 D SUBTYPE^%ZIS3($G(X6,"P-OTHER"))
+ I $G(X1)]"" D SAVDEV^%ZISUTL(X1)
+ U $S(%I]"":%I,1:$P)
+ Q
+ ;
+OPNERR ;Handle open error
+ S POP=1,$ECODE=""
+ U:$P]"" $P
+ Q
+ ;
+CLOSE(X) ;SR. Close HFS device not opened by %ZIS.
+ ;X=HANDLE NAME
+ ;IO=Device
+ N %
+ I $G(IO)]"" C IO K IO(1,IO)
+ I $G(X)]"" D RMDEV^%ZISUTL(X)
+ ;Only reset home if one setup.
+ I $D(IO("HOME"))!$D(^XUTL("XQ",$J,"IOS")) D HOME^%ZIS
+ Q
+ ;
+OPENERR ;
+ Q 0
+ ;
+DEL(%ZX1,%ZX2) ;ef,SR. Del fl(s)
+ ;S Y=$$DEL^%ZISH("dir path",$NA(array))
+ 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"
+ . 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
+ D UNWIND^%ZTER
+ Q
+ ;
+LIST(%ZX1,%ZX2,%ZX3) ;ef,SR. Create a local array holding file names
+ ;S Y=$$LIST^ZOSHDOS("\dir\",$NA(array),$NA(return array)) Return 1 if found anything
+ ;
+ N %ZISH,%ZISHN,%ZX,%ZISHY,%ZY,%ZOS
+ S %ZX1=$$DEFDIR($G(%ZX1)),%ZOS=$$OS^%ZOSV
+ ;S %ZX1=$$TRNLNM(%ZX1)
+ ;Get fls to act on
+ S %ZISH="" F  S %ZISH=$O(@%ZX2@(%ZISH)) Q:%ZISH=""  D
+ . S %ZISHY=$P(%ZISH,"*")
+ . I %ZOS="VMS",%ZISH'["." S %ZISH=%ZISH_".*" ;Allways upper
+ . ;NT, display case, ignore for lookup
+ . S %ZX=%ZX1_%ZISH
+ . F %ZISHN=0:1 D  Q:(%ZX="") 
+ . . S %ZX=$ZSEARCH($S(%ZISHN:"",1:%ZX))
+ . . ;Q:(%ZX="")!($$UP^XLFSTR(%ZX)'[%ZISHY)!(%ZX?.E1.2".")
+ . . Q:(%ZX="")!(%ZX?.E1.2".")
+ . . I %ZOS="VMS" S %ZX=$P(%ZX,"]",2),@%ZX3@(%ZX)=""
+ . . I %ZOS="NT" S %ZY=$P(%ZX,"\",$L(%ZX,"\")),@%ZX3@(%ZY)=""
+ . . I %ZOS="UNIX" S %ZY=$P(%ZX,"/",$L(%ZX,"/")) Q:%ZX'[%ZISHY  S @%ZX3@(%ZY)=""
+ . . Q
+ Q $O(@%ZX3@(""))]""
+ ;
+MV(X1,X2,Y1,Y2) ;ef,SR. Rename a fl
+ ;S Y=$$MV^ZOSHDOS("\dir\","fl","\dir\","fl")
+ ;Unix use mv, NT/VMS use COPY and DEL
+ N %,X,Y,%ZOS,%ZISHX S %ZOS=$$OS^%ZOSV
+ S X1=$$DEFDIR($G(X1)),Y1=$$DEFDIR($G(Y1))
+ S X=$ZSEARCH(X1_X2),Y=Y1_Y2 ;move X to Y
+ I X="" Q 0
+ S %=$ZF(-1,$S(%ZOS="UNIX":"mv ",1:"copy ")_X_" "_Y) ;Use NT/VMS copy
+ I %ZOS'="UNIX" D
+ . S X2=$P(X,X1,2),%ZISHX(X2)=""
+ . S Y=$$DEL^%ZISH(X1,$NA(%ZISHX))
+ Q 1
+ ;
+PWD() ;ef,SR. Print working directory
+ N Y,%ZOS
+ S Y=$$DEFDIR(""),%ZOS=$$OS^%ZOSV
+ I Y="" S Y=$ZSEARCH("*")
+ Q $S(%ZOS["VMS":Y,1:$P(Y,".",1))
+ ;
+TRNLNM(PATH) ;ef. Expand logical path
+ N %ZOS,P1,P2
+ S %ZOS=$$OS^%ZOSV,PATH=$G(PATH)
+ I %ZOS="VMS" D  Q PATH
+ . S P1=PATH_$S(PATH[":":"*.*",1:":*.*")
+ . S P2=$ZSEARCH(P1)
+ . S:$L(P2) PATH=$S(P2["]":$P(P2,"]",1)_"]",1:$P(P2,":",1)_":")
+ . Q
+ I %ZOS="NT" D  Q PATH
+ . S P1=PATH_$S($E(PATH,$L(PATH))'="\":"\*",1:"*"),P2=$ZSEARCH(P1)
+ . S:$L(P2) PATH=$P(P2,"\",1,$L(P2,"\")-1)_"\"
+ . Q
+ I %ZOS="UNIX" D  Q PATH
+ . S P1=PATH_$S($E(PATH,$L(PATH))'="/":"/*",1:"*"),P2=$ZSEARCH(P1)
+ . S:$L(P2) PATH=$P(P2,"/",1,$L(P2,"/")-1)_"/"
+ . Q
+ Q PATH
+ ;
+DEFDIR(DF) ;ef. Default Dir and frmt
+ ;Need to handle NT, VMS and Linux
+ 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"))
+ Q:DF="" ""
+ ;Check syntax, VMS needs disk:[dir] or logical:
+ I %ZOS="VMS" D
+ . I DF[":" S P1=$P(DF,":")_":",P2=$P(DF,":",2)
+ . E  S P1="",P2=DF
+ . I P1="",P2["$" S P1=P2,P2=""  ;Could be a logical
+ . I $L(P2) S:P2'["[" P2="["_P2 S:P2'["]" P2=P2_"]"
+ . S DF=P1_P2 S:DF'[":" DF=DF_":"
+ . Q
+ ;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\ 
+ I %ZOS="NT" D
+ . N P1,P2
+ . I DF[":" S P1=$P(DF,":")_":",P2=$P(DF,":",2)
+ . E  S P1="",P2=DF
+ . S P2=$TR(P2,"/","\")
+ . I $L(P2) S:".\"'[$E(P2,1) P2="\"_P2 S:$E(P2,$L(P2))'="\" P2=P2_"\"
+ . S DF=P1_P2
+ . Q
+ S DF=$$TRNLNM(DF) ;Resolve logicals
+ Q DF
+ ;
+FL(X) ;Fl len
+ N ZOSHP1,ZOSHP2
+ S ZOSHP1=$P(X,"."),ZOSHP2=$P(X,".",2)
+ I $L(ZOSHP1)>8 S X=4 Q
+ I $L(ZOSHP2)>3 S X=4 Q
+ Q
+ ;
+STATUS() ;ef,SR. Return EOF status
+ U $I
+ Q $$EOF($ZEOF)
+ ;
+EOF(X) ;Eof flag, pass in $ZEOF
+ Q (X=-1)
+ ;
+MAKEREF(HF,IX,OVF) ;Internal call to rebuild global ref.
+ ;Return %ZISHF,%ZISHO,%ZISHI,%ZISUB
+ N I,F,MX
+ S OVF=$G(OVF,"%ZISHOF")
+ S %ZISHI=$QS(HF,IX),MX=$QL(HF) ;
+ S F=$NA(@HF,IX-1) ;Get first part
+ I IX=1 S %ZISHF=F_"(%ZISHI" ;Build root, IX=1
+ I IX>1 S %ZISHF=$E(F,1,$L(F)-1)_",%ZISHI" ;Build root
+ S %ZISHO=%ZISHF_","_OVF_",%OVFCNT)" ;Make overflow
+ F I=IX+1:1:MX S %ZISHF=%ZISHF_",%ZISUB("_I_")",%ZISUB(I)=$QS(HF,I)
+ S %ZISHF=%ZISHF_")"
+ Q
+ ;
+READNXT(REC) ;Read any sized record into array. %ZB has terminator
+ N %,I,X,$ES,$ET S REC="",$ET="D READNX^%ZISH Q"
+ U IO R X:5 S %ZB=$A($ZB),REC=$E(X,1,255)
+ Q:$L(X)<256
+ S %=256 F I=1:1 Q:$L(X)<%  S REC(I)=$E(X,%,%+254),%=%+255
+ Q
+READNX ;Check for EOF
+ I $ZE["ENDOFFILE" S %ZA=-1
+ S $EC=""
+ Q
+ ;
+FTG(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5) ;ef,SR. Unload contents of host file into global
+ ;p1=hostf file directory 
+ ;p2=host file name
+ ;p3= $NAME REFERENCE INCLUDING STARTING SUBSCRIPT
+ ;p4=INCREMENT SUBSCRIPT
+ ;p5=Overflow subscript, defaults to "OVF"
+ N %ZA,%ZB,%ZC,X,%OVFCNT,%ZISHF,%ZISHO,POP,%ZISUB,$ES,$ET
+ N I,%ZISH,%ZISH1,%ZISHI,%ZISHL,%ZISHOF,%ZISHOX,%ZISHS,%ZX,%ZISHY
+ S %ZX1=$$DEFDIR($G(%ZX1)),%ZISHOF=$G(%ZX5,"OVF")
+ D MAKEREF(%ZX3,%ZX4,"%ZISHOF")
+ D OPEN^%ZISH(,%ZX1,%ZX2,"R")
+ I POP Q 0
+ S %ZC=1,%ZA=0,$ET="S %ZC=0,%ZA=-1,$EC="""" Q"
+ U IO F  K %XX D READNXT(.%XX) Q:$$EOF($ZEOF)!%ZA  D
+ . S @%ZISHF=%XX
+ . I $D(%XX)>2 F %OVFCNT=1:1 Q:'$D(%XX(%OVFCNT))  S @%ZISHO=%XX(%OVFCNT)
+ . S %ZISHI=%ZISHI+1
+ . Q
+ D CLOSE() ;Normal exit
+ Q %ZC
+ ;
+GTF(%ZX1,%ZX2,%ZX3,%ZX4) ;ef,SR. Load contents of global to host file.
+ ;p1=$NAME of global reference
+ ;p2=incrementing subscript
+ ;p3=host file directory
+ ;p4=host file name
+ N %ZISHY,%ZISHOX
+ S %ZISHY=$$MGTF(%ZX1,%ZX2,%ZX3,%ZX4,"W")
+ Q %ZISHY
+ ;
+GATF(%ZX1,%ZX2,%ZX3,%ZX4) ;ef,SR. Append to host file.
+ ;
+ ;p1=$NAME of global reference
+ ;p2=incrementing subscript
+ ;p3=host file directory
+ ;p4=host file name
+ N %ZISHY
+ S %ZISHY=$$MGTF(%ZX1,%ZX2,%ZX3,%ZX4,"A")
+ Q %ZISHY
+ ;
+MGTF(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5) ;
+ ;p1=$NAME of global reference
+ ;p2=incrementing subscript
+ ;p3=host file directory
+ ;p4=host file name
+ N %ZISH,%ZISH1,%ZISHI,%ZISHL,%ZISHS,%ZISHOX,IO,%ZX,Y,%ZC
+ D MAKEREF(%ZX1,%ZX2)
+ D OPEN^%ZISH(,$G(%ZX3),%ZX4,%ZX5) ;Default dir set in open
+ I POP Q 0
+ N $ETRAP S $ETRAP="S $EC="""" D CLOSE^%ZISH() Q 0"
+ F  Q:'($D(@%ZISHF)#2)  S %ZX=@%ZISHF,%ZISHI=%ZISHI+1 U IO W %ZX,!
+ D CLOSE()
+ Q 1
+ ;
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,88 +1,69 @@
-%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
-	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=""
-	I "IOEFLD^IOSTBM"[%ZISFN S @%ZISFN=%ZISXX Q
-	I %ZISXX]"" S @("%ZISY="_%ZISXX)
-	;E  S @("%ZISY="_"""""")
-	I $E(%ZISFN,1,2)="IO" S @%ZISFN=%ZISY
-	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))
-	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
-	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)
-	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
-	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
-	;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
-	Q
-L1	I ZISCH="_"!(ZISCH=",") S %ZISYY=%ZISYY_"_" Q
-	I ZISCH=ZISQ D QUOTE Q
-	I ZISCH="$" D DOLR Q
-	I ZISCH="*" D STAR Q
-	I ZISCH="(" D PAREN Q
-	S %ZISYY=%ZISYY_ZISCH
-	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)_")"
-	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
-	S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH'=""&(ZISCH'=",") ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_ZISNUM_")",ZISXL=ZISXL-1 Q
-	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.
-	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
-	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
-S1	I ZISCH=ZISQ D QUOTE Q
-	I ZISCH="$" D DOLR Q
-	I ZISCH="(" D PAREN Q
-	S %ZISYY=%ZISYY_ZISCH
-	Q
-	;
-S2	;MERGE $C
-	S %ZISX1=$E(%ZISX1,1,$L(%ZISX1)-1),%ZISX2=","_$E(%ZISX2,4,$L(%ZISX2))
-	S $P(%ZISXX,"_",I,I+1)=%ZISX1_%ZISX2
-	N I D L2
-	Q
+%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
+INDCK S %ZISY=""
+ I "IOEFLD^IOSTBM"[%ZISFN S @%ZISFN=%ZISXX Q
+ I %ZISXX]"" S @("%ZISY="_%ZISXX)
+ ;E  S @("%ZISY="_"""""")
+ I $E(%ZISFN,1,2)="IO" S @%ZISFN=%ZISY
+ 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))
+ 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.
+ 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.
+ 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) 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
+ ;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 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
+ ;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
+ Q
+L1 I ZISCH="_"!(ZISCH=",") S %ZISYY=%ZISYY_"_" Q
+ I ZISCH=ZISQ D QUOTE Q
+ I ZISCH="$" D DOLR Q
+ I ZISCH="*" D STAR Q
+ I ZISCH="(" D PAREN Q
+ 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
+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
+ S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH'=""&(ZISCH'=",") ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_ZISNUM_")",ZISXL=ZISXL-1 Q
+ 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.
+ 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
+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
+S1 I ZISCH=ZISQ D QUOTE Q
+ I ZISCH="$" D DOLR Q
+ I ZISCH="(" D PAREN Q
+ S %ZISYY=%ZISYY_ZISCH Q
+ ;
+S2 ;MERGE $C
+ S %ZISX1=$E(%ZISX1,1,$L(%ZISX1)-1),%ZISX2=","_$E(%ZISX2,4,$L(%ZISX2))
+ S $P(%ZISXX,"_",I,I+1)=%ZISX1_%ZISX2
+ N I D L2
+ Q
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,120 +1,111 @@
-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
-	S %Y=1 K ^%ZOSF("MASTER"),^%ZOSF("SIGNOFF")
-	N 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
-	;
-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	;;
-	;;ACTJ
-	;;S Y=$$ACTJ^%ZOSV()
-	;;AVJ
-	;;S Y=$$AVJ^%ZOSV()
-	;;BRK
-	;;U $I:("":"+B")
-	;;DEL
-	;;X "ZR  ZS @X"
-	;;EOFF
-	;;U $I:("":"+S")
-	;;EON
-	;;U $I:("":"-S")
-	;;EOT
-	;;S Y=$ZA\1024#2
-	;;ERRTN
-	;;^%ZTER
-	;;ETRP
-	;;Q
-	;;GD
-	;;D ^%GD
-	;;GSEL;Select Globals
-	;;K ^UTILITY($J) D ^%GSET
-	;;JOBPARAM
-	;;D JOBPAR^%ZOSV
-	;;LABOFF
-	;;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)"")=%"
-	;;LPC
-	;;S Y=$ZC(X)
-	;;MAXSIZ
-	;;S $ZS=X+X
-	;;MGR
-	;;%SYS
-	;;MAGTAPE
-	;;S %MT("BS")="*-1",%MT("FS")="*-2",%MT("WTM")="*-3",%MT("WB")="*-4",%MT("REW")="*-5",%MT("RB")="*-6",%MT("REL")="*-7",%MT("WHL")="*-8",%MT("WEL")="*-9"
-	;;MTBOT
-	;;S Y=$ZA\32#2
-	;;MTONLINE
-	;;S Y=$ZA\64#2
-	;;MTWPROT
-	;;S Y=$ZA\4#2
-	;;MTERR;;MAGTAPE ERROR
-	;;S Y=$ZA\32768#2
-	;;NBRK
-	;;U $I:("":"-B")
-	;;NO-PASSALL
-	;;U $I:("":"-I+T")
-	;;NO-TYPE-AHEAD
-	;;U $I:("":"+F":$C(13,27))
-	;;PASSALL
-	;;U $I:("":"+I-T")
-	;;PRIINQ;; Priority in current queue
-	;;N %PRIO D ^%PRIO S Y=$S('%PRIO:5,%PRIO>0:8,1:3)
-	;;PRIORITY;;set priority to X (1=low, 10=high)
-	;;D @($S(X>7:"NORMAL",X>3:"NORMAL",1:"LOW")_"^%PRIO") ;Don't do HIGH
-	;;PROGMODE
-	;;S Y=$ZJOB#2
-	;;PROD
-	;;VAH
-	;;RD
-	;;D ^%RD
-	;;RESJOB
-	;;N OLD S OLD=$ZNSPACE ZNSPACE "%SYS" D ^RESJOB ZNSPACE OLD Q
-	;;RM
-	;;I $G(IOT)["TRM" 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
-	;;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"
-	;;SIZE
-	;;S Y=0 F I=1:1 S %=$T(+I) Q:%=""  S Y=Y+$L(%)+2
-	;;TEST
-	;;I X?1(1"%",1A).7AN,$D(^$ROUTINE(X))
-	;;TMK;;MAGTAPE MARK
-	;;S Y=$ZA\4#2
-	;;TRAP;;S X="^%ET",@^%ZOSF("TRAP"); User $ETRAP
-	;;$ZT=X
-	;;TRMOFF
-	;;U $I:("":"-I-T":$C(13,27))
-	;;TRMON
-	;;U $I:("":"+I+T")
-	;;TRMRD;;old Y=$A($ZB),Y=$S(Y<32:Y,Y=127:Y,1:0)
-	;;S Y=$A($ZB),Y=$S(Y<32:Y,Y=127:Y,1:0)
-	;;TYPE-AHEAD
-	;;U $I:("":"-F":$C(13,27))
-	;;UCI
-	;;D UCI^%ZOSV
-	;;UCICHECK
-	;;S Y=$$UCICHECK^%ZOSV(X)
-	;;UPPERCASE
-	;;S Y=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
-	;;XY
-	;;S $X=DX,$Y=DY
-	;;VOL;;VOLUME SET NAME
-	;;ROU
-	;;ZD;;$H to external
-	;;S Y=$ZD(X)
+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")
+ 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: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
+ W !!,"ALL SET UP",!! Q
+Z ;;
+ ;;ACTJ
+ ;;S Y=$$ACTJ^%ZOSV()
+ ;;AVJ
+ ;;S Y=$$AVJ^%ZOSV()
+ ;;BRK
+ ;;U $I:("":"+B")
+ ;;DEL
+ ;;X "ZR  ZS @X" K ^UTILITY("ROU",X)
+ ;;EOFF
+ ;;U $I:("":"+S")
+ ;;EON
+ ;;U $I:("":"-S")
+ ;;EOT
+ ;;S Y=$ZA\1024#2
+ ;;ERRTN
+ ;;^%ZTER
+ ;;ETRP
+ ;;Q
+ ;;GD
+ ;;D ^%GD
+ ;;JOBPARAM
+ ;;D JOBPAR^%ZOSV
+ ;;LABOFF
+ ;;U IO:("":"+S+I-T":$C(13,27))
+ ;;LOAD
+ ;;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)
+ ;;MAXSIZ
+ ;;S $ZS=X+X
+ ;;MGR
+ ;;%SYS
+ ;;MAGTAPE
+ ;;S %MT("BS")="*-1",%MT("FS")="*-2",%MT("WTM")="*-3",%MT("WB")="*-4",%MT("REW")="*-5",%MT("RB")="*-6",%MT("REL")="*-7",%MT("WHL")="*-8",%MT("WEL")="*-9"
+ ;;MTBOT
+ ;;S Y=$ZA\32#2
+ ;;MTONLINE
+ ;;S Y=$ZA\64#2
+ ;;MTWPROT
+ ;;S Y=$ZA\4#2
+ ;;MTERR;;MAGTAPE ERROR
+ ;;S Y=$ZA\32768#2
+ ;;NBRK
+ ;;U $I:("":"-B")
+ ;;NO-PASSALL
+ ;;U $I:("":"-I+T")
+ ;;NO-TYPE-AHEAD
+ ;;U $I:("":"+F":$C(13,27))
+ ;;PASSALL
+ ;;U $I:("":"+I-T")
+ ;;PRIINQ;; Priority in current queue
+ ;;N %PRIO D ^%PRIO S Y=$S('%PRIO:5,%PRIO>0:8,1:3)
+ ;;PRIORITY;;set priority to X (1=low, 10=high)
+ ;;D @($S(X>7:"NORMAL",X>3:"NORMAL",1:"LOW")_"^%PRIO") ;Don't do HIGH
+ ;;PROGMODE
+ ;;S Y=$ZJ#2
+ ;;PROD
+ ;;VAH
+ ;;RD
+ ;;D ^%RD
+ ;;RESJOB
+ ;;Q:'$D(DUZ)  Q:'$D(^XUSEC("XUMGR",+DUZ))  N XQZ S XQZ="^RESJOB[MGR]" D DO^%XUCI
+ ;;RM
+ ;;U $I:X
+ ;;RSEL;;ROUTINE SELECT
+ ;;K ^UTILITY($J) D KERNEL^%RSET K %ST ;Special entry point for VA
+ ;;RSUM
+ ;;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
+ ;;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
+ ;;TEST
+ ;;I X?1(1"%",1A).7AN,$D(^$ROUTINE(X))
+ ;;TMK;;MAGTAPE MARK
+ ;;S Y=$ZA\4#2
+ ;;TRAP;;S X="^%ET",@^%ZOSF("TRAP") TO SET ERROR TRAP
+ ;;$ZT=X
+ ;;TRMOFF
+ ;;U $I:("":"-I-T":$C(13,27))
+ ;;TRMON
+ ;;U $I:("":"+I+T")
+ ;;TRMRD
+ ;;S Y=$A($ZB),Y=$S(Y<32:Y,Y=127:Y,1:0)
+ ;;TYPE-AHEAD
+ ;;U $I:("":"-F":$C(13,27))
+ ;;UCI
+ ;;D UCI^%ZOSV
+ ;;UCICHECK
+ ;;S Y=$$UCICHECK^%ZOSV(X)
+ ;;UPPERCASE
+ ;;S Y=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+ ;;XY
+ ;;S $X=DX,$Y=DY
+ ;;VOL;;VOLUME SET NAME
+ ;;ROU
+ ;;ZD
+ ;;S Y=$ZD(X)
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,169 +1,164 @@
-%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
-ACTJ()	;# Active jobs
-	N %,V,Y S V=$$VERSION()
-	I V<5 D  Q Y
-	. S %=0 F Y=0:1 S %=$ZJOB(%) Q:%=""
-	S Y=$system.License.LUConsumed() ;Cache 5 up
-	Q Y
-AVJ()	;# available jobs
-	N %,AVJ,V,ZOSV,$ET
-	S V=+$$VERSION()
-	;Cache 3 and 4
-	;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
-	. ;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
-	;To get available jobs from Cache 5.0 up
-	I V'<5 D  Q AVJ
-	. X "S AVJ=$system.License.LUAvailable()"
-	;Return fixed value not known version
-	Q 15
-	;
-PRIINQ()	;
-	Q 8
-	;
-UCI	;Current UCI,VOL
-	S Y=$ZU(5)_","_^%ZOSF("VOL") Q
-	;
-UCICHECK(X)	;Check if valid namespace (UCI)
-	N Y,%
-	S %=$P(X,",",1),Y=0 I $ZU(90,10,%) S Y=%
-	Q Y
-	;
-GETPEER()	;Get the PEER tcp/ip address
-	N PEER,NL,$ET S NL="",PEER="",$ET="S $EC=NL Q NL"
-	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)
-	Q PEER
-	;
-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=""
-	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
-	;
-NOLOG	;4096 is switch 12 - sign on inhibited.
-	S Y="$V(0,-2,4)\4096#2" Q
-	;
-PROGMODE()	;Check if in PROG mode
-	Q $ZJOB#2
-	;
-PRGMODE	;
-	N X,XMB,XQZ,XUCI,XUSLNT,XUVOL,Y,ZTPAC
-	W ! S ZTPAC=$S('$D(^VA(200,+DUZ,.1)):"",1:$P(^(.1),U,5)),XUVOL=^%ZOSF("VOL")
-	S X="" X ^%ZOSF("EOFF") R:ZTPAC]"" !,"PAC: ",X:60 D LC^XUS X ^%ZOSF("EON") I X'=ZTPAC W "??"_$C(7) Q
-	S XMB="XUPROGMODE",XMB(1)=DUZ,XMB(2)=$I D ^XMB:$L($T(^XMB)) D BYE^XUSCLEAN K ZTPAC,X,XMB
-	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
-	;
-EC()	;Error code
-	Q $ZE
-	;
-DOLRO	;SAVE ENTIRE SYMBOL TABLE IN LOCATION SPECIFIED BY X
-	;S Y="%" F  S Y=$O(@Y) Q:Y=""  D
-	;. I $D(@Y)#2 S @(X_"Y)="_Y)
-	;. I $D(@Y)>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR
-	S Y="%" F  M:$D(@Y) @(X_"Y)="_Y) S Y=$O(@Y) Q:Y=""
-	Q
-	;
-ORDER	;SAVE PART OF SYMBOL TABLE IN LOCATION SPECIFIED BY X
-	N %
-	S (Y,%)=$P(Y,"*",1) ;I $D(@Y)=0 F  S Y=$O(@Y) Q:Y=""!(Y[Y1)
-	Q:Y=""
-	;S %=$D(@Y) S:%#2 @(X_"Y)="_Y) I %>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR
-	;F  S Y=$O(@Y) Q:Y=""!(Y'[Y1)  S %=$D(@Y) S:%#2 @(X_"Y)="_Y) I %>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR
-	F  M:$D(@Y) @(X_"Y)="_Y) S Y=$O(@Y) Q:Y=""!(Y'[%)
-	Q
-	;
-PARSIZ	;Old and not used.
-	S X=3
-	Q
-	;
-DEVOPN	;List of Devices opened, Not used
-	;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
-	G:X1="RES" RESOK^%ZIS6
-	N $ET S $ET="D OPNERR Q"
-	O X::$S($D(%ZISTO):%ZISTO,1:0) E  S Y=999 Q  ;G NOPN
-	S Y=0 I '$D(%ZISCHK)!($G(%ZIS)["T") C X Q
-	S:X]"" IO(1,X)="" Q
-	Q
-	;
-OPNERR	S $EC="",Y=-1 Q
-	;
-GETENV	;Get environment  (UCI^VOL^NODE^BOX:VOLUME)
-	N %,%1 S %=$$VERSION,%1=$ZU(86),%1=$S(%<3.1:$P(%1,"*",3),1:$P(%1,"*",2))
-	D UCI S Y=$P(Y,",")_"^"_^%ZOSF("VOL")_"^"_$ZU(110)_"^"_^%ZOSF("VOL")_":"_%1
-	Q
-VERSION(X)	;return Cache version, X=1 - return full name
-	Q $S($G(X):$P($ZV,")")_")",1:$P($P($ZV,") ",2),"("))
-	;
-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")
-	;
-SETNM(X)	;Set name, Fall into SETENV
-SETENV	;Set environment
-	N Q,$ET,$ES S $ET="S $EC="""" Q"
-	I $$OS="VMS" S Q=$ZF("SETPRN",$E(X,1,15))
-	Q
-	;
-SID()	;System ID Ver 1
-	N %1,%2,%3,%4,%5,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.
-	N % S %=1
-	I $P(^XTV(8989.3,1,0),"^",5),$$OS'="VMS" S %=2
-	Q %
-	;
-HFSREW(IO,IOPAR)	;Rewind Host File.
-	S $ZT="HFSRWERR"
-	C IO O @(""""_IO_""""_$S(IOPAR]"":":"_IOPAR_":1",1:":1")) I '$T Q 0
-	Q 1
-HFSRWERR	;Error encountered
-	Q 0
-LOGRSRC(OPT,TYPE,STATUS)	;record resource usage in ^XTMP("KMPR"
-	Q:'$G(^%ZTSCH("LOGRSRC"))  ; quit if RUM not turned on.
-	; call to RUM routine.
-	D RU^%ZOSVKR($G(OPT),$G(TYPE),$G(STATUS))
-	Q
-SETTRM(X)	;Turn on specified terminators.
-	U $I:(:"+T":X)
-	Q 1
-	;
-T0	; start RT clock, obsolete
-	;S XRT0=$H
-	Q
-T1	; store RT datum, obsolete
-	;S ^%ZRTL(3,XRTL,+$H,XRTN,$P($H,",",2))=XRT0 K XRT0
-	Q
+%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()
+ I V<5 D  Q Y
+ . S %=0 F Y=0:1 S %=$ZJOB(%) Q:%=""
+ S Y=$system.License.LUConsumed() ;Cache 5 up
+ Q Y
+AVJ() ;# available jobs
+ N %,AVJ,V,ZOSV,$ET
+ S V=+$$VERSION()
+ ;Cache 3 and 4
+ ;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
+ . ;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
+ ;To get available jobs from Cache 5.0 up
+ I V'<5 D  Q AVJ
+ . X "S AVJ=$system.License.LUAvailable()"
+ ;Return fixed value not known version
+ Q 15
+ ;
+PRIINQ() ;
+ Q 8
+ ;
+UCI ;Current UCI,VOL
+ S Y=$ZU(5)_","_^%ZOSF("VOL") Q
+ ;
+UCICHECK(X) ;Check if valid namespace (UCI)
+ N Y,%
+ S %=$P(X,",",1),Y=0 I $ZU(90,10,%) S Y=%
+ Q Y
+ ;
+GETPEER() ;Get the PEER tcp/ip address
+ 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)
+ Q PEER
+ ;
+SHARELIC(TYPE) ;See if can share a C/S license
+ ;Type is 1 for C/S and 0 for Telnet
+ 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 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.
+ S Y="$V(0,-2,4)\4096#2" Q
+ ;
+PROGMODE() ;Check if in PROG mode
+ Q $ZJ#2
+ ;
+PRGMODE ;
+ N X,XMB,XQZ,XUCI,XUSLNT,XUVOL,Y,ZTPAC
+ W ! S ZTPAC=$S('$D(^VA(200,+DUZ,.1)):"",1:$P(^(.1),U,5)),XUVOL=^%ZOSF("VOL")
+ S X="" X ^%ZOSF("EOFF") R:ZTPAC]"" !,"PAC: ",X:60 D LC^XUS X ^%ZOSF("EON") I X'=ZTPAC W "??"_$C(7) Q
+ S XMB="XUPROGMODE",XMB(1)=DUZ,XMB(2)=$I D ^XMB:$L($T(^XMB)) D BYE^XUSCLEAN K ZTPAC,X,XMB
+ 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() S $ZT="LGRX^%ZOSV"
+ Q $ZR ;Last Global ref.
+LGRX Q ""
+ ;
+EC() Q $ZE ;Error code
+ ;
+DOLRO ;SAVE ENTIRE SYMBOL TABLE IN LOCATION SPECIFIED BY X
+ ;S Y="%" F  S Y=$O(@Y) Q:Y=""  D
+ ;. I $D(@Y)#2 S @(X_"Y)="_Y)
+ ;. I $D(@Y)>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR
+ S Y="%" F  M:$D(@Y) @(X_"Y)="_Y) S Y=$O(@Y) Q:Y=""
+ Q
+ ;
+ORDER ;SAVE PART OF SYMBOL TABLE IN LOCATION SPECIFIED BY X
+ N %
+ S (Y,%)=$P(Y,"*",1) ;I $D(@Y)=0 F  S Y=$O(@Y) Q:Y=""!(Y[Y1)
+ Q:Y=""
+ ;S %=$D(@Y) S:%#2 @(X_"Y)="_Y) I %>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR
+ ;F  S Y=$O(@Y) Q:Y=""!(Y'[Y1)  S %=$D(@Y) S:%#2 @(X_"Y)="_Y) I %>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR
+ F  M:$D(@Y) @(X_"Y)="_Y) S Y=$O(@Y) Q:Y=""!(Y'[%)
+ Q
+ ;
+PARSIZ ;
+ S X=3
+ Q
+ ;
+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
+ G:X1="RES" RESOK^%ZIS6
+ N $ET S $ET="D OPNERR Q"
+ O X::$S($D(%ZISTO):%ZISTO,1:0) E  S Y=999 Q  ;G NOPN
+ S Y=0 I '$D(%ZISCHK)!($G(%ZIS)["T") C X Q
+ S:X]"" IO(1,X)="" Q
+ Q
+ ;
+OPNERR S $EC="",Y=-1 Q
+ ;
+GETENV ;Get environment  (UCI^VOL^NODE^BOX:VOLUME)
+ N %,%1 S %=$$VERSION,%1=$ZU(86),%1=$S(%<3.1:$P(%1,"*",3),1:$P(%1,"*",2))
+ D UCI S Y=$P(Y,",")_"^"_^%ZOSF("VOL")_"^"_$ZU(110)_"^"_^%ZOSF("VOL")_":"_%1
+ Q
+VERSION(X) ;return Cache version, X=1 - return full name
+ Q $S($G(X):$P($ZV,")")_")",1:$P($P($ZV,") ",2),"("))
+ ;
+OS() ;Return the OS NT, VMS, Unix
+ Q $S($ZV["VMS":"VMS",$ZV["Windows":"NT",$ZV["NT":"NT",$ZV["UNIX":"UNIX",1:"UNK")
+ ;
+SETNM(X) ;Set name, Fall into SETENV
+SETENV ;Set environment
+ N Q,$ET,$ES S $ET="S $EC="""" Q"
+ I $$OS="VMS" S Q=$ZF("SETPRN",$E(X,1,15))
+ Q
+ ;
+SID() ;System ID Ver 1
+ 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=%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(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 %
+ ;
+HFSREW(IO,IOPAR) ;Rewind Host File.
+ S $ZT="HFSRWERR"
+ C IO O @(""""_IO_""""_$S(IOPAR]"":":"_IOPAR_":1",1:":1")) I '$T Q 0
+ Q 1
+HFSRWERR ;Error encountered
+ Q 0
+LOGRSRC(OPT,TYPE,STATUS) ;record resource usage in ^XTMP("KMPR"
+ Q:'$G(^%ZTSCH("LOGRSRC"))  ; quit if RUM not turned on.
+ ; call to RUM routine.
+ D RU^%ZOSVKR($G(OPT),$G(TYPE),$G(STATUS))
+ Q
+SETTRM(X) ;Turn on specified terminators.
+ U $I:(:"+T":X)
+ Q 1
+ ;
+T0 ; start RT clock
+ ;S XRT0=$H
+ Q
+T1 ; store RT datum, obsolete
+ ;S ^%ZRTL(3,XRTL,+$H,XRTN,$P($H,",",2))=XRT0 K XRT0
+ Q
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,60 +1,57 @@
-%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()
-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 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 %ZTVOL=^%ZOSF("VOL")
-	I $D(ZTCPU)[0 S ZTCPU=%ZTVOL
-	I ZTCPU="" S ZTCPU=%ZTVOL
-	I ZTCPU'=%ZTVOL G THERE
-	;
-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
-	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 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
-	I ZTSK(0)]"" K ZTSK("E") Q
-	I ZTSK("E")'="U" Q
-	S ZTSK("E",0)=$$EC^%ZOSV
-	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
-	S %ZTCPU=$O(^%ZIS(14.5,"B",ZTCPU,""))
-	I %ZTCPU="" S ZTSK("E")="IS" G QUIT
-	S %ZTM=$P(^%ZOSF("MGR"),",")
-	S %ZTM=$S($D(^%ZIS(14.5,%ZTCPU,0))[0:%ZTM,$P(^(0),U,6)="":%ZTM,1:$P(^(0),U,6))
-	S X=%ZTM,Y=ZTCPU
-	S ZTSK("E")="LS",ZT=$D(^[X,Y]%ZTSK(0)),ZTSK("E")="U" ; check link
-	;
-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)
-	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 ZTSK(0)=0 G QUIT
-	;
+%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
+ I $D(ZTSK)[0 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",X="QUIT^%ZTLOAD3",@^%ZOSF("TRAP")
+ S %ZTVOL=^%ZOSF("VOL")
+ I $D(ZTCPU)[0 S ZTCPU=%ZTVOL
+ I ZTCPU="" S ZTCPU=%ZTVOL
+ I ZTCPU'=%ZTVOL G THERE
+ ;
+HERE ;lookup task's status on current volume set
+ 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 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
+ I ZTSK(0)]"" K ZTSK("E") Q
+ I ZTSK("E")'="U" Q
+ S ZTSK("E",0)=$$EC^%ZOSV
+ Q
+ ;
+THERE ;rest of code looks up task's status on some other volume set
+ ;
+FILES ;find TaskMan files on the volume set to be searched
+ S %ZTCPU=$O(^%ZIS(14.5,"B",ZTCPU,""))
+ I %ZTCPU="" S ZTSK("E")="IS" G QUIT
+ S %ZTM=$P(^%ZOSF("MGR"),",")
+ S %ZTM=$S($D(^%ZIS(14.5,%ZTCPU,0))[0:%ZTM,$P(^(0),U,6)="":%ZTM,1:$P(^(0),U,6))
+ S X=%ZTM,Y=ZTCPU
+ S ZTSK("E")="LS",ZT=$D(^[X,Y]%ZTSK(0)),ZTSK("E")="U" ; check link
+ ;
+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=$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 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
+ ;
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,99 +1,91 @@
-%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
-	N %ZISOS,%ZISV
-	S U="^",%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^%ZOSF("VOL"))
-	;Check SPOOLER special case first
-INIT	I $D(ZTQUEUED),$G(IOT)="SPL",$D(IO)#2,$D(IO(0))#2,IO]"",IO=IO(0),$D(IO(1,IO))#2,%ZISOS["VAX DSM"!(%ZISOS["M/VX"),$G(IOP)[ION!(IOP[IO) K %ZIS,%IS,IOP Q
-	;
-	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 %ZHFN,%ZISOLD,DTOUT,DUOUT
-	;Save symbols to restore if don't open a device
-	D SYMBOL^%ZISUTL(0,$NA(%ZISOLD))
-A	D CLEAN ;(p363) K IO("CLOSE"),IO("HFSIO")
-	K IO("P"),IO("Q"),IO("S"),IO("T")
-K2	D K2^%ZIS1
-	S %ZISB=%ZIS'["N",(%E,%H,POP)=0,%Y="" S:'$D(IO(0)) IO(0)=$I
-	I %ZISOS["VAX DSM",$I["SYS$INPUT:.;" S:%ZIS'[0 %IS=%IS_"0",%ZIS=%ZIS_"0"
-	;I %IS["T"&(%IS["0") S (%H,%E)=0 G ^%ZIS1
-	I $D(IOP),IOP=$I!(IOP="HOME")!(0[IOP),$D(^XUTL("XQ",$J,"IO")) D HOME K %IS,%Y,%ZIS,%ZISB,%ZISV,IOP Q
-	;Don't worry about HOME if %ZIS[0
-	D:%ZIS'[0 GETHOME G EXIT^%ZIS1:POP,^%ZIS1 ;Jump to next part
-	;
-GETHOME	I $D(IO("HOME")),$P(IO("HOME"),"^",2)=IO(0) S (%E,%H)=+IO("HOME") Q
-	I $D(^XUTL("XQ",$J,"IOS")),$D(^("IO")),IO(0)=^("IO") S (%E,%H)=^("IOS") Q
-	;CALL LINEPORT CODE HERE---
-	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
-	S %H=%E S:'%H&(%IS'[0) POP=1 S:(%H>0)&('$D(IO("HOME"))) IO("HOME")=%H_"^"_$I
-	Q
-VIRTUAL	;See if a Virtual Terminal (LAT, TELNET)
-	;Change the MSM check for telnet to work with v4.4
-	I %ZISOS["MSM" X "I $P($ZV,""Version "",2)'<3 S %ZISVT=$ZDE(+%ZISVT) I %ZISVT?.E1""~""4.5N.E S %ZISVT=""TELNET"""
-	F %ZISI=$L(%ZISVT):-1:0 D:$D(^%ZIS(1,"C",%ZISVT))  Q:$S('%E:0,'$D(^%ZIS(1,%E,"TYPE")):0,^("TYPE")="VTRM":1,1:0)  S %ZISVT=$E(%ZISVT,1,%ZISI)
-	.D VTLKUP Q:$S('%E:0,'$D(^%ZIS(1,%E,"TYPE")):0,^("TYPE")="VTRM":1,1:0)
-	.S %X=0 F %ZISX=%ZISV,"" Q:%X>0  S %X=0 F  S %E=+$O(^%ZIS(1,"CPU",%ZISX_"."_%ZISVT,%X)) S %X=%E Q:%E'>0  I $G(^%ZIS(1,+%E,"TYPE"))="VTRM" Q
-	Q
-VTLKUP	F %ZISX=%ZISV,"" S %E=+$O(^%ZIS(1,"G","SYS."_%ZISX_"."_%ZISVT,0)) Q:%E  S %E=+$O(^%ZIS(1,"CPU",%ZISX_"."_%ZISVT,0)) Q:%E
-	Q
-	;
-CURRENT	N POP,%ZIS,%IS,%E,%H
-	S FF="#",SL=24,BS="*8",RM=80,(SUB,XY)="",%IS=0,%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^("VOL")),POP=0
-	D GETHOME K %E,%IS,%ZISI,%ZISOS,%ZISV,%ZISVT,%ZISX Q:POP
-	I $D(^%ZIS(1,%H,"SUBTYPE")) S SUB=+^("SUBTYPE") K %H
-	I $D(SUB),SUB,$D(^%ZIS(2,SUB,1)) S SUB=$S($D(^(0)):$P(^(0),"^"),1:""),FF=$P(^(1),"^",2),SL=$P(^(1),"^",3),BS=$P(^(1),"^",4),XY=$P(^(1),"^",5),RM=+^(1)
-	E  S SUB=""
-	I $D(^%ZOSF("RM")) N X S X=RM X ^("RM") K %A
-	Q
-HOME	;Entry point to establish IO* variables for home device.
-	D CLEAN ;(p363)
-	N X I '$D(^XUTL("XQ",$J,"IO")) S IOP="HOME" D ^%ZIS Q
-	D RESETVAR
-	I '$D(IO("C")),$G(IOM),IO=$I,$D(IO(1,IO)),$D(^%ZOSF("RM")) S X=+IOM X ^("RM")
-	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
-	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
-	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,%)=@%
-	Q
-ZISLPC	Q  ;No longer called in Kernel v8.
-	;
-HLP1	G EN1^%ZIS7
-HLP2	N %E,%H,%X,%ZISV,X S %ZISV=$S($D(^%ZOSF("VOL")):^("VOL"),1:"") G EN2^%ZIS7
-	;
-REWIND(IO2,IOT,IOPAR)	;Rewind Device
-	N %,X,Y,$ES,$ET S $ET="D REWERR^%ZIS Q 0"
-	S %=$I
-	I '($D(IO2)#2)!'$D(IOT)!'$D(IOPAR) Q 0
-	I "MT^SDP^HFS"'[IOT Q 0
-	S @("Y=$$REW"_IOT_"^%ZIS4(IO2,IOPAR)")
-	U %
-	Q Y
-REWERR	;Error encountered
-	S IO("ERROR")=$EC
-	S $EC="",$ET="Q:$ES>1  S $EC="""" Q 0" S $EC=",U1,"
-	Q 0
-	;
+%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"))
+ ;Check SPOOLER special case first
+INIT I $D(ZTQUEUED),$G(IOT)="SPL",$D(IO)#2,$D(IO(0))#2,IO]"",IO=IO(0),$D(IO(1,IO))#2,%ZISOS["VAX DSM"!(%ZISOS["M/VX"),$G(IOP)[ION!(IOP[IO) K %ZIS,%IS,IOP Q
+ ;
+ I '$D(%ZIS),$D(%IS) M %ZIS=%IS
+ S:'($D(%ZIS)#2) %ZIS="M" M %IS=%ZIS ;update %IS for now
+ ;
+ 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,%Z9,%Z90,%Z91,%Z95,%ZISB,%ZTIME,%ZTYPE
+ N %ZHFN,%ZISOLD,DTOUT,DUOUT
+ ;Save symbols to restore if don't open a device
+ D SYMBOL^%ZISUTL(0,$NA(%ZISOLD))
+A D CLEAN ;(p363) K IO("CLOSE"),IO("HFSIO")
+ K IO("P"),IO("Q"),IO("S"),IO("T")
+K2 D K2^%ZIS1
+ S %ZISB=%ZIS'["N",(%E,%H,POP)=0,%Y="" S:'$D(IO(0)) IO(0)=$I
+ I %ZISOS["VAX DSM",$I["SYS$INPUT:.;" S:%ZIS'[0 %IS=%IS_"0",%ZIS=%ZIS_"0"
+ ;I %IS["T"&(%IS["0") S (%H,%E)=0 G ^%ZIS1
+ I $D(IOP),IOP=$I!(IOP="HOME")!(0[IOP),$D(^XUTL("XQ",$J,"IO")) D HOME K %IS,%Y,%ZIS,%ZISB,%ZISV,IOP Q
+ ;Don't worry about HOME if %ZIS[0
+ D:%ZIS'[0 GETHOME G EXIT^%ZIS1:POP,^%ZIS1 ;Jump to next part
+ ;
+GETHOME I $D(IO("HOME")),$P(IO("HOME"),"^",2)=IO(0) S (%E,%H)=+IO("HOME") Q
+ I $D(^XUTL("XQ",$J,"IOS")),$D(^("IO")),IO(0)=^("IO") S (%E,%H)=^("IOS") Q
+ ;CALL LINEPORT CODE HERE---
+ 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 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
+VIRTUAL ;See if a Virtual Terminal (LAT, TELNET)
+ ;Change the MSM check for telnet to work with v4.4
+ I %ZISOS["MSM" X "I $P($ZV,""Version "",2)'<3 S %ZISVT=$ZDE(+%ZISVT) I %ZISVT?.E1""~""4.5N.E S %ZISVT=""TELNET"""
+ F %ZISI=$L(%ZISVT):-1:0 D:$D(^%ZIS(1,"C",%ZISVT))  Q:$S('%E:0,'$D(^%ZIS(1,%E,"TYPE")):0,^("TYPE")="VTRM":1,1:0)  S %ZISVT=$E(%ZISVT,1,%ZISI)
+ .D VTLKUP Q:$S('%E:0,'$D(^%ZIS(1,%E,"TYPE")):0,^("TYPE")="VTRM":1,1:0)
+ .S %X=0 F %ZISX=%ZISV,"" Q:%X>0  S %X=0 F  S %E=+$O(^%ZIS(1,"CPU",%ZISX_"."_%ZISVT,%X)) S %X=%E Q:%E'>0  I $G(^%ZIS(1,+%E,"TYPE"))="VTRM" Q
+ Q
+VTLKUP F %ZISX=%ZISV,"" S %E=+$O(^%ZIS(1,"G","SYS."_%ZISX_"."_%ZISVT,0)) Q:%E  S %E=+$O(^%ZIS(1,"CPU",%ZISX_"."_%ZISVT,0)) Q:%E
+ Q
+ ;
+CURRENT N POP,%ZIS,%IS,%E,%H
+ S FF="#",SL=24,BS="*8",RM=80,(SUB,XY)="",%IS=0,%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^("VOL")),POP=0
+ D GETHOME K %E,%IS,%ZISI,%ZISOS,%ZISV,%ZISVT,%ZISX Q:POP
+ I $D(^%ZIS(1,%H,"SUBTYPE")) S SUB=+^("SUBTYPE") K %H
+ I $D(SUB),SUB,$D(^%ZIS(2,SUB,1)) S SUB=$S($D(^(0)):$P(^(0),"^"),1:""),FF=$P(^(1),"^",2),SL=$P(^(1),"^",3),BS=$P(^(1),"^",4),XY=$P(^(1),"^",5),RM=+^(1)
+ E  S SUB=""
+ I $D(^%ZOSF("RM")) N X S X=RM X ^("RM") K %A
+ Q
+HOME ;Entry point to establish IO* variables for home device.
+ D CLEAN ;(p363)
+ N X I '$D(^XUTL("XQ",$J,"IO")) S IOP="HOME" D ^%ZIS Q
+ D RESETVAR
+ I '$D(IO("C")),$G(IOM),IO=$I,$D(IO(1,IO)),$D(^%ZOSF("RM")) S X=+IOM X ^("RM")
+ 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.
+ 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" I $D(^XUTL("XQ",$J,%))#2 S @%=^(%)
+ S POP=0,IO(0)=IO,(IOPAR,IOUPAR)=""
+ Q
+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.
+ ;
+HLP1 G EN1^%ZIS7
+HLP2 N %E,%H,%X,%ZISV,X S %ZISV=$S($D(^%ZOSF("VOL")):^("VOL"),1:"") G EN2^%ZIS7
+ ;
+REWIND(IO2,IOT,IOPAR) ;Rewind Device
+ N %,X,Y,$ES,$ET S $ET="D REWERR^%ZIS Q 0"
+ S %=$I
+ I '($D(IO2)#2)!'$D(IOT)!'$D(IOPAR) Q 0
+ I "MT^SDP^HFS"'[IOT Q 0
+ S @("Y=$$REW"_IOT_"^%ZIS4(IO2,IOPAR)")
+ U %
+ Q Y
+REWERR ;Error encountered
+ S IO("ERROR")=$EC
+ S $EC="",$ET="Q:$ES>1  S $EC="""" Q 0" S $EC=",U1,"
+ Q 0
+ ;
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,102 +1,93 @@
-%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
-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
-L1	;Main Loop
-	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
-	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 '$D(^%ZIS(1,%A,0)) D MSG1 K %ZISIOS S POP=1
-	I POP G EXIT:$D(IOP),L1:'$D(IOP)
-	S %E=%A,%Z=^%ZIS(1,%A,0),%Z1=$G(^(1))
-	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
-G	G L1:POP&'$D(IOP)&'($D(DTOUT)!$D(DUOUT)) ;Didn't get it
-	;
-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
-	;Do count of number of times device opened.  Field 51.
-	I $L($G(IO)),$D(IO(1,IO))#2,$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 %IS'[0,$G(IO(0))]"" U IO(0) ;Make sure return with home active
-	G SETVAR:'POP!(%IS["T"),KILVAR
-	;
-IOP	;Request with IOP set
-	S (%ZISVT,%X)=IOP S:%X'?1.UNP %X=$$UP(%X) I %X'="Q" D SETQ Q
-	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"
-	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)
-RD	W !,$S($D(%IS("A")):%IS("A"),1:"DEVICE: ") W:%A]"" %A,"// " D SBR S:%X="" %X=%A S %ZISVT=%X
-	I %X?2"?".E D EN2^%ZIS7 G R
-	I %X?1"?".E D EN1^%ZIS7 G R
-	I $D(DTOUT)!$D(DUOUT)!(%X'?.ANP)!($L($P(%X,";"))>31) S:%IS["T" IO="" S POP=1 Q
-	S:%X'?1.UNP %X=$$UP(%X) D SETQ G R:$T Q
-SETQ	S %Y=$P(%X,";",2,9),%X=$P(%X,";",1) S:$L(";"_%Y,";/")=2 IO("P")=$P(";"_%Y,";/",2)
-	I %IS["Q",%X="Q" S %X=%Y,%ZISVT=$P(%ZISVT,";",2,9),%ZISB=0,IO("Q")=1,%IS("A")="DEVICE: " S:$D(IOP) %Y=$P(%X,";",2,9),%X=$P(%X,";",1)
-	I $T,'$D(IOP) W "UEUE TO PRINT ON" Q  ; Return $T value
-	Q
-LKUP	S %ZISMY=$P(%ZISVT,";",2,999),%ZISVT=$P(%ZISVT,";")
-	I %X="H" W:'$D(IOP) "ome" S %X=0
-	I 0[%X!(%X="HOME")!(%X=$I) S %A=%H Q
-	I $E(%ZISVT)="`",$D(IOP) S %A=+$E(%ZISVT,2,999) I $G(^%ZIS(1,%A,0))]"" Q
-	S %A=0 I "P"[%X Q:$D(IOP)&('$D(^%ZIS(1,%E,99)))  I $D(^%ZIS(1,%E,99)) S %A=+^(99) Q
-	I %X=" ",$D(DUZ)#2,$D(^DISV(+DUZ,"^%ZIS(1,")) S %A=^("^%ZIS(1,") Q
-	S %A=+$O(^%ZIS(1,"B",%ZISVT,0)) Q:%A>0  ;mixed case lookup
-	I %X'=%ZISVT S %A=+$O(^%ZIS(1,"B",%X,0)) Q:%A>0  ;uppercase lookup
-	D VTLKUP^%ZIS S %A=%E Q:%A>0  ;mixed case lookup
-	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
-	S:%X="."!(%X="^") DUOUT=1,%X="" Q
-LC	S %X=$$UP(%X)
-	Q
-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)
-	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]"
-	Q
-SETVAR	;Come here to setup the variables for the selected device
-	S:$D(IO)[0 IO="" G KILVAR:%IS["T"&(IO="")
-	I $G(%Z)="" S ION="Unknown device",POP=1 G KILVAR
-	S:IO'=IO(0)&($D(DUZ)#2) ^DISV(+DUZ,"^%ZIS(1,")=%E
-	S ION=$P(%Z,"^",1),IOM=+%Z91,IOF=$P(%Z91,"^",2),IOSL=$P(%Z91,"^",3),IOBS=$P(%Z91,"^",4),IOXY=$P(%Z91,"^",5)
-	I IOSL>65530 S IOSL=65530 ;Cache rolls $Y at 65535
-	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
-	;
-KILVAR	;Come here to restore the calling variables
-	D SYMBOL^%ZISUTL(1,"%ZISOLD")
-	S:'$L($G(IOF)) IOF="#" S:'$D(IOST(0)) IOST(0)=0
-	;See that all standard variables are defined
-	F %I="IO","ION","IOM","IOBS","IOSL","IOST" S:$D(@%I)[0 @%I=""
-	K IO("HFSIO"),IO("OPEN") I $D(%ZISCPU) S:'$D(IOCPU) IOCPU=%ZISCPU
-KIL	;Final exit cleanup
-	S:'POP IOS=%ZISIOS I POP K:%IS'["T" %ZISIOS I %IS["T" K IOS S:$D(%ZISIOS) IOS=%ZISIOS
-	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
-	Q
+%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
+L1 ;Main Loop
+ 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) !,*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)
+ S %E=%A,%Z=^%ZIS(1,%A,0),%Z1=$G(^(1))
+ 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
+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 $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,'POP,$G(%ZISIOS) D
+ . S $P(^(5),"^",1)=$P($G(^%ZIS(1,%ZISIOS,5)),"^",1)+1
+ 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
+ ;
+IOP ;Request with IOP set
+ S (%ZISVT,%X)=IOP S:%X'?1.UNP %X=$$UP(%X) I %X'="Q" D SETQ Q
+ 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 !,*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)
+RD W !,$S($D(%IS("A")):%IS("A"),1:"DEVICE: ") W:%A]"" %A,"// " D SBR S:%X="" %X=%A S %ZISVT=%X
+ I %X?2"?".E D EN2^%ZIS7 G R
+ I %X?1"?".E D EN1^%ZIS7 G R
+ I $D(DTOUT)!$D(DUOUT)!(%X'?.ANP)!($L($P(%X,";"))>31) S:%IS["T" IO="" S POP=1 Q
+ S:%X'?1.UNP %X=$$UP(%X) D SETQ G R:$T Q
+SETQ S %Y=$P(%X,";",2,9),%X=$P(%X,";",1) S:$L(";"_%Y,";/")=2 IO("P")=$P(";"_%Y,";/",2)
+ I %IS["Q",%X="Q" S %X=%Y,%ZISVT=$P(%ZISVT,";",2,9),%ZISB=0,IO("Q")=1,%IS("A")="DEVICE: " S:$D(IOP) %Y=$P(%X,";",2,9),%X=$P(%X,";",1)
+ I $T,'$D(IOP) W "UEUE TO PRINT ON" Q  ; Return $T value
+ Q
+LKUP S %ZISMY=$P(%ZISVT,";",2,999),%ZISVT=$P(%ZISVT,";")
+ I %X="H" W:'$D(IOP) "ome" S %X=0
+ I 0[%X!(%X="HOME")!(%X=$I) S %A=%H Q
+ I $E(%ZISVT)="`",$D(IOP) S %A=+$E(%ZISVT,2,999) I $G(^%ZIS(1,%A,0))]"" Q
+ S %A=0 I "P"[%X Q:$D(IOP)&('$D(^%ZIS(1,%E,99)))  I $D(^%ZIS(1,%E,99)) S %A=+^(99) Q
+ I %X=" ",$D(DUZ)#2,$D(^DISV(+DUZ,"^%ZIS(1,")) S %A=^("^%ZIS(1,") Q
+ S %A=+$O(^%ZIS(1,"B",%ZISVT,0)) Q:%A>0  ;mixed case lookup
+ I %X'=%ZISVT S %A=+$O(^%ZIS(1,"B",%X,0)) Q:%A>0  ;uppercase lookup
+ D VTLKUP^%ZIS S %A=%E Q:%A>0  ;mixed case lookup
+ 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 *7 S DTOUT=1 Q
+ S:%X="."!(%X="^") DUOUT=1,%X="" Q
+LC S %X=$$UP(%X)
+ Q
+LOW(%) Q $TR(%,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
+UP(%) Q $TR(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+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 *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:$D(IO)[0 IO="" G KILVAR:%IS["T"&(IO="")
+ I $G(%Z)="" S ION="Unknown device",POP=1 G KILVAR
+ S:IO'=IO(0)&($D(DUZ)#2) ^DISV(+DUZ,"^%ZIS(1,")=%E
+ S ION=$P(%Z,"^",1),IOM=+%Z91,IOF=$P(%Z91,"^",2),IOSL=$P(%Z91,"^",3),IOBS=$P(%Z91,"^",4),IOXY=$P(%Z91,"^",5)
+ I IOSL>65530 S IOSL=65530 ;Cache rolls $Y at 65535
+ 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
+ ;
+KILVAR ;Come here to restore the calling variables
+ D SYMBOL^%ZISUTL(1,"%ZISOLD")
+ S:'$L($G(IOF)) IOF="#" S:'$D(IOST(0)) IOST(0)=0
+ ;See that all standard variables are defined
+ F %I="IO","ION","IOM","IOBS","IOSL","IOST" S:$D(@%I)[0 @%I=""
+ K IO("HFSIO"),IO("OPEN") I $D(%ZISCPU) S:'$D(IOCPU) IOCPU=%ZISCPU
+KIL ;Final exit cleanup
+ S:'POP IOS=%ZISIOS I POP K:%IS'["T" %ZISIOS I %IS["T" K IOS S:$D(%ZISIOS) IOS=%ZISIOS
+ 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,%ZISIOF,%ZISIOSL,%ZISIOBS,%ZISIOST,%ZISIOST(0),%ZISTO,%ZISTP,%ZISHG,%ZISSIO,%ZISOPEN,%ZISOPAR,%ZISUPAR
+ K %ZISMY,%ZISQUIT
+ Q
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,94 +1,90 @@
-%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
-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
-	. N %1,%2 S %1=$G(^%ZIS(1,%ZISHG(0),"HG",+%ZISHGL,0)),%2=$G(^%ZIS(1,+%1,0))
-	. ;Check that HG device is on same VOL.
-	. I $P(%2,"^",9)=%ZISV!($P(%2,"^",9)="") S %E=+$P(^%ZIS(1,%ZISHG(0),"HG",+%ZISHGL,0),"^")
-	. Q
-	G L2:%ZISHGL>0 S %ZISHPOP=1,%E=%ZISHP
-	;
-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
-	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"
-	. S POP=1 K:$D(IOP) IO("Q") Q
-	S %Z90=$G(^(90)),%Z95=$G(^(95)),%ZTIME=$G(^("TIME")),%ZTYPE=$G(^("TYPE")),%ZISHG=$O(^%ZIS(1,"AHG",%E,0))
-	I %ZISHG,$D(^%ZIS(1,+%ZISHG,0)) S:'$D(%ZISHG(0)) %ZISHG(0)=+%ZISHG S %ZISHG=$P(^(0),"^",1)
-	E  S %ZISHG=""
-	I %ZTYPE="HG" D OTHCPU("HUNT GROUP") G T:$D(%ZISHG(0))!POP
-	I %ZTYPE="RES" S %ZISRL=+$P(%Z1,"^",10) G T
-VTRM	I %ZTYPE="VTRM",'('$D(IO("Q"))&(%A=%H)) W:'$D(IOP)&'$D(%ZISHP) *7,"  [YOU CAN NOT SELECT A VIRTUAL TERMINAL]" S POP=1 ;Virtual Terminal Check
-	S:%ZTYPE="VTRM"&'$D(IO("Q"))&(%A=%H) IO=$I
-	;
-SLAVE	I $D(IO("Q")),$P(%Z,"^",2)=0,$P(%Z,"^",8)']"" W:'$D(IOP) *7,!?10,"  [SLAVE device NOT set up for queuing]" S POP=1 G T
-OCPU	D OTHCPU("DEVICE")
-	;
-OOS	G T:POP I %Z90,$D(DT)#2,%Z90'>DT S POP=1 ;Out Of Service Check
-	I $T,'$D(IOP),'$D(%ZISHP) W *7,"  [Out of Service]" ;I 'POP W " ..OK" S %=2,U="^" D YN^%ZIS1 G:%=0 OOS S:%'=1 POP=1
-	;
-PTIME	G T:POP!(IO=$I)!(IO=0)
-	;Prohibitted Time Check
-	S %A=$P(%ZTIME,"^") I %ZISB,$L(%A) D  I POP,'$D(IOP),'$D(%ZISHP) W *7,"  [ACCESS PROHIBITED "_%A_"]" ;AT THIS TIME]"
-	. N %C,%L,%H ;%C is current time, %L is lower limit, %H is upper limit
-	. S %C=$P($H,",",2),%C=%C\60#60+(%C\3600*100),%H=$P(%A,"-",2),%L=+%A
-	. I $S(%H'<%L:(%C'>%H&(%C'<%L)),1:(%C'<%L!(%C'>%H))) S POP=1
-	. Q
-DUZ	I 'POP D SEC ;Security Check
-	;
-T	I POP,$D(%ZISHG(0)),%IS'["D",'$D(%ZISHPOP),%ZISB G HUNT
-	I POP D HGBSY:$D(%ZISHPOP) ;G T2:%IS["T"
-	;
-TMPVAR	K IO("S") S %ZISIOS=%E S:IO=0 IO=$I,IO("S")=%H
-	S %ZISOPAR=$$IOPAR(%E,"IOPAR")
-	S %ZISUPAR=$$IOPAR(%E,"IOUPAR"),%ZISTO=+$P(%ZTIME,"^",2)
-	I $D(IO("S")) D  I POP Q
-	. S IO=$S(%IS["S":$P($G(^%ZIS(1,+$P(%Z,"^",8),0)),"^",2),1:IO)
-	. I %IS["S",IO]"" S %H=+$P(%Z,"^",8),IO("S")=%H,IO(0)=IO
-	. S IO("S")=$S($G(^XUTL("XQ",$J,"IOST(0)")):^("IOST(0)"),1:$G(^%ZIS(1,%H,"SUBTYPE")))
-	. S:IO="" POP=1
-	. Q
-	S %A=+$G(^%ZIS(1,%E,"SUBTYPE")),%ZISTP=0 ;%A is pointer to subtype
-	I %E=%H,%ZTYPE["TRM" D  I 1
-	. I $D(^XUTL("XQ",$J,"IOST(0)")) D  ;Use home
-	. . S %A=+^XUTL("XQ",$J,"IOST(0)"),%Z91="",%ZISTP=1
-	. . F %ZISI="IOM","IOF","IOSL","IOBS","IOXY" S %Z91=%Z91_$G(^XUTL("XQ",$J,%ZISI))_"^"
-	. E  S %=$$LNPRTSUB^%ZISUTL I %>0 S %A=%,%Z91=""
-	E  S %Z91=$P($G(^%ZIS(2,%A,1)),"^",1,4),$P(%Z91,"^",5)=$G(^("XY"))
-	;I $D(%Z91),%Z91'?1.4"^" ;$P(%Z91,"^")]"",$P(%Z91,"^",2)]"",$P(%Z91,"^",3),$P(%Z91,"^",4)]""
-	D ST^%ZIS3(%ZISTP) S:%IS["U" USIO=$P(%Z91,"^",1,4)
-T2	I POP S:%IS'["T" IO="" Q
-	G ^%ZIS3:"^MTRM^VTRM^TRM^SPL^MT^SDP^HFS^RES^OTH^BAR^HG^IMPC^CHAN^"[("^"_%ZTYPE_"^") ;Jump to next part
-	S POP=1 Q
-	;
-HGBSY	S POP=1 S:%IS'["T" IO="" K %ZISHP,%ZISHPOP Q:$D(IOP)
-	W:$X>38 !,?5 W *7," All devices in hunt group "_%ZISHG_" are busy!" Q
-	;
-OTHCPU(%1)	;%1 should be either DEVICE or HUNT GROUP
-	N %2,X,Y,%ZISMSG S %ZISMSG=0
-	F %2="CPU","VOLUME SET" D
-	.I %2="VOLUME SET" S X=$P($P(%Z,"^",9),":"),Y=%ZISV
-	.E  D GETENV^%ZOSV S X=$P($P(%Z,"^",9),":",2),Y=$P($P(Y,"^",4),":",2)
-	.I X=Y!(X="") Q:%1="DEVICE"  D  Q  ;Other Vol Set/Cpu Check
-	..S %ZISHG(0)=%E,%ZISHG=$P(%Z,"^")
-	..I %ZISB S POP=1
-	..E  S IO=" "
-	.I %2="VOLUME SET" S $P(%ZISCPU,":")=X
-	.E  S $P(%ZISCPU,":",2)=X
-	.I %1="HUNT GROUP" K %ZISHG(0)
-	.I %IS["Q" S IO("Q")=1,%ZISB=0 S:%1="HUNT GROUP" IO=" "
-	.E  I %ZISB&(%ZTYPE="TRM"&($D(%ZISHG(0))&(%IS'["D"))) S POP=1
-	.E  W:'$D(IOP)&'%ZISMSG *7,"  ["_%1_" is on another "_%2_" ('"_X_"')]",! S POP=1,%ZISMSG=1
-	Q
-IOPAR(%DA,%N)	;Return I/O parameters
-	Q $S($G(%ZIS(%N))]"":%ZIS(%N),1:$G(^%ZIS(1,%DA,%N)))
-	;
-SEC	I %Z95]"" S %X=$G(DUZ(0)) I %X'="@" S POP=1 F %A=1:1:$L(%X) I %Z95[$E(%X,%A) S POP=0 Q
-	I POP,'$D(IOP),'$D(%ZISHP) W *7,"  [Access Prohibited]"
-	Q
+%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
+ . N %1,%2 S %1=$G(^%ZIS(1,%ZISHG(0),"HG",+%ZISHGL,0)),%2=$G(^%ZIS(1,+%1,0))
+ . ;Check that HG device is on same VOL.
+ . I $P(%2,"^",9)=%ZISV!($P(%2,"^",9)="") S %E=+$P(^%ZIS(1,%ZISHG(0),"HG",+%ZISHGL,0),"^")
+ . Q
+ G L2:%ZISHGL>0 S %ZISHPOP=1,%E=%ZISHP
+ ;
+L2 ;Entry point from %ZIS1
+ I $D(DTOUT)!$D(DUOUT) K %ZISHP,%ZISHPOP Q
+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"
+ . S POP=1 K:$D(IOP) IO("Q") Q
+ S %Z90=$G(^(90)),%Z95=$G(^(95)),%ZTIME=$G(^("TIME")),%ZTYPE=$G(^("TYPE")),%ZISHG=$O(^%ZIS(1,"AHG",%E,0))
+ I %ZISHG,$D(^%ZIS(1,+%ZISHG,0)) S:'$D(%ZISHG(0)) %ZISHG(0)=+%ZISHG S %ZISHG=$P(^(0),"^",1)
+ E  S %ZISHG=""
+ I %ZTYPE="HG" D OTHCPU("HUNT GROUP") G T:$D(%ZISHG(0))!POP
+ I %ZTYPE="RES" S %ZISRL=+$P(%Z1,"^",10) G T
+VTRM I %ZTYPE="VTRM",'('$D(IO("Q"))&(%A=%H)) W:'$D(IOP)&'$D(%ZISHP) *7,"  [YOU CAN NOT SELECT A VIRTUAL TERMINAL]" S POP=1 ;Virtual Terminal Check
+ S:%ZTYPE="VTRM"&'$D(IO("Q"))&(%A=%H) IO=$I
+ ;
+SLAVE I $D(IO("Q")),$P(%Z,"^",2)=0,$P(%Z,"^",8)']"" W:'$D(IOP) *7,!?10,"  [SLAVE device NOT set up for queuing]" S POP=1 G T
+OCPU D OTHCPU("DEVICE")
+ ;
+OOS G T:POP I %Z90,$D(DT)#2,%Z90'>DT S POP=1 ;Out Of Service Check
+ I $T,'$D(IOP),'$D(%ZISHP) W *7,"  [Out of Service]" ;I 'POP W " ..OK" S %=2,U="^" D YN^%ZIS1 G:%=0 OOS S:%'=1 POP=1
+ ;
+PTIME G T:POP!(IO=$I)!(IO=0)
+ ;Prohibitted Time Check
+ S %A=$P(%ZTIME,"^") I %ZISB,$L(%A) D  I POP,'$D(IOP),'$D(%ZISHP) W *7,"  [ACCESS PROHIBITED "_%A_"]" ;AT THIS TIME]"
+ . N %C,%L,%H ;%C is current time, %L is lower limit, %H is upper limit
+ . S %C=$P($H,",",2),%C=%C\60#60+(%C\3600*100),%H=$P(%A,"-",2),%L=+%A
+ . I $S(%H'<%L:(%C'>%H&(%C'<%L)),1:(%C'<%L!(%C'>%H))) S POP=1
+ . Q
+DUZ I 'POP D SEC ;Security Check
+ ;
+T I POP,$D(%ZISHG(0)),%IS'["D",'$D(%ZISHPOP),%ZISB G HUNT
+ I POP D HGBSY:$D(%ZISHPOP) ;G T2:%IS["T"
+ ;
+TMPVAR K IO("S") S %ZISIOS=%E S:IO=0 IO=$I,IO("S")=%H
+ S %ZISOPAR=$$IOPAR(%E,"IOPAR")
+ S %ZISUPAR=$$IOPAR(%E,"IOUPAR"),%ZISTO=+$P(%ZTIME,"^",2)
+ I $D(IO("S")) D  I POP Q
+ . S IO=$S(%IS["S":$P($G(^%ZIS(1,+$P(%Z,"^",8),0)),"^",2),1:IO)
+ . I %IS["S",IO]"" S %H=+$P(%Z,"^",8),IO("S")=%H,IO(0)=IO
+ . S IO("S")=$S($G(^XUTL("XQ",$J,"IOST(0)")):^("IOST(0)"),1:$G(^%ZIS(1,%H,"SUBTYPE")))
+ . S:IO="" POP=1
+ . Q
+ S %A=+$G(^%ZIS(1,%E,"SUBTYPE")),%ZISTP=0 ;%A is pointer to subtype
+ I %E=%H,%ZTYPE["TRM" D  I 1
+ . I $D(^XUTL("XQ",$J,"IOST(0)")) D  ;Use home
+ . . S %A=+^XUTL("XQ",$J,"IOST(0)"),%Z91="",%ZISTP=1
+ . . F %ZISI="IOM","IOF","IOSL","IOBS","IOXY" S %Z91=%Z91_$G(^XUTL("XQ",$J,%ZISI))_"^"
+ . E  S %=$$LNPRTSUB^%ZISUTL I %>0 S %A=%,%Z91=""
+ E  S %Z91=$P($G(^%ZIS(2,%A,1)),"^",1,4),$P(%Z91,"^",5)=$G(^("XY"))
+ ;I $D(%Z91),%Z91'?1.4"^" ;$P(%Z91,"^")]"",$P(%Z91,"^",2)]"",$P(%Z91,"^",3),$P(%Z91,"^",4)]""
+ D ST^%ZIS3(%ZISTP) S:%IS["U" USIO=$P(%Z91,"^",1,4)
+T2 I POP S:%IS'["T" IO="" Q
+ G ^%ZIS3:"^MTRM^VTRM^TRM^SPL^MT^SDP^HFS^RES^OTH^BAR^HG^IMPC^CHAN^"[("^"_%ZTYPE_"^") ;Jump to next part
+ S POP=1 Q
+ ;
+HGBSY S POP=1 S:%IS'["T" IO="" K %ZISHP,%ZISHPOP Q:$D(IOP)
+ W:$X>38 !,?5 W *7," All devices in hunt group "_%ZISHG_" are busy!" Q
+ ;
+OTHCPU(%1) ;%1 should be either DEVICE or HUNT GROUP
+ N %2,X,Y,%ZISMSG S %ZISMSG=0
+ F %2="CPU","VOLUME SET" D
+ .I %2="VOLUME SET" S X=$P($P(%Z,"^",9),":"),Y=%ZISV
+ .E  D GETENV^%ZOSV S X=$P($P(%Z,"^",9),":",2),Y=$P($P(Y,"^",4),":",2)
+ .I X=Y!(X="") Q:%1="DEVICE"  D  Q  ;Other Vol Set/Cpu Check
+ ..S %ZISHG(0)=%E,%ZISHG=$P(%Z,"^")
+ ..I %ZISB S POP=1
+ ..E  S IO=" "
+ .I %2="VOLUME SET" S $P(%ZISCPU,":")=X
+ .E  S $P(%ZISCPU,":",2)=X
+ .I %1="HUNT GROUP" K %ZISHG(0)
+ .I %IS["Q" S IO("Q")=1,%ZISB=0 S:%1="HUNT GROUP" IO=" "
+ .E  I %ZISB&(%ZTYPE="TRM"&($D(%ZISHG(0))&(%IS'["D"))) S POP=1
+ .E  W:'$D(IOP)&'%ZISMSG *7,"  ["_%1_" is on another "_%2_" ('"_X_"')]",! S POP=1,%ZISMSG=1
+ Q
+IOPAR(%DA,%N) ;Return I/O parameters
+ Q $S($G(%ZIS(%N))]"":%ZIS(%N),1:$G(^%ZIS(1,%DA,%N)))
+ ;
+SEC I %Z95]"" S %X=$G(DUZ(0)) I %X'="@" S POP=1 F %A=1:1:$L(%X) I %Z95[$E(%X,%A) S POP=0 Q
+ I POP,'$D(IOP),'$D(%ZISHP) W *7,"  [Access Prohibited]"
+ Q
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,82 +1,71 @@
-%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
-	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 $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
-	;
-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
-	G Q
-DEVOK	N X,Y,X1 ;Not sure this is needed
-	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
-	Q
-	;
-MARGN	;Get the margin and page length
-	S %A=$P(%Y,";",1)
-	I %A?1A.ANP D SUBIEN(.%A,1) I $D(^%ZIS(2,%A,1)) K %Z91 D ST(1) S %Y=$P(%Y,";",2,9),%ZISMY=$P(%ZISMY,";",2,9) G MARGN
-	I %A>3 S $P(%Z91,"^")=$S(%A>255:255,1:+%A)
-	I $P(%Y,";",2) S $P(%Z91,"^",3)=+$S($P(%Y,";",2)>65530:65530,1:$P(%Y,";",2)) ;Cache fix for $Y#65535 wrap
-	;
-ALTP	I '$D(IO("P")) Q:%A>3  G ASKMAR:%ZTYPE["TRM" Q
-	S %X=$F(IO("P"),"M") I %X S %A=+$E(IO("P"),%X,99),$P(%Z91,"^")=$S(%A>255:255,1:%A)
-	S %X=$F(IO("P"),"L") I %X S $P(%Z91,"^",3)=+$E(IO("P"),%X,99)
-	Q:%A>3!(%ZTYPE'["TRM")
-ASKMAR	I %IS["M",'$D(IOP),$S(%E=%H:+$P(%Z,"^",3),1:1),$P(%Z,"^",4) W "    Right Margin: " W:$P(%Z91,"^")]"" +%Z91,"// "
-	E  Q
-	D SBR^%ZIS1 I '$D(DTOUT)&'$D(DUOUT) S:%X=""&($P(%Z91,"^")]"") %X=+%Z91 G ASKMAR:%X'?1.N S $P(%Z91,"^")=$S(%X>255:255,1:%X) 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_")"
-	Q
-AQUE	;Ask about Queueing
-	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"
-	D YN^%ZIS1 K %ZISDTIM G AQUE:%=0 Q:$D(IO("Q"))
-	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 %ZISIOST(0)=%A,%ZISIOST=$P($G(^%ZIS(2,%A,0)),"^")
-	S:'$D(%Z91) %Z91=$P($G(^%ZIS(2,%A,1),"132^#^60^$C(8)"),"^",1,4),$P(%Z91,"^",5)=$G(^("XY"))
-	Q:%ZISTP
-STP	N %B ;%E is a pointer to the Device file
-	S %B=$G(^%ZIS(1,%E,91))
-	S:$P(%B,"^")]"" $P(%Z91,"^")=+%B S:$P(%B,"^",3)]"" $P(%Z91,"^",3)=$P(%B,"^",3) ;S $P(%Z91,"^",5)=$G(^%ZIS(2,%ZISIOST(0),"XY"))
-	Q
-SUBIEN(%1,%)	;Return Subtype ien. %1 is call by Ref.
-	N %XX,%YY
-	I $D(^%ZIS(2,"B",%1))>9 S %1=+$O(^%ZIS(2,"B",%1,0)) Q
-	I '$G(%) S X="" Q
-	S %XX=%1 D 2^%ZIS5 S %1=+%YY
-	Q
-SUBTYPE(%A)	;Called from %ZISH
-	N %ZISIOST,%Z91
-	S:$G(%A)="" %A="P-OTHER"
-	D SUBIEN(.%A),ST(1)
-	S IOM=$P(%Z91,U,1),IOF=$P(%Z91,U,2),IOSL=$P(%Z91,U,3),IOST=%ZISIOST,IOST(0)=%ZISIOST(0),IOBS="$C(8)"
-	S:IOST="" IOST="P-OTHER",IOST(0)=0
-	Q
+%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
+ 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:%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&(%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
+ 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")) !,*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
+ ;
+MARGN ;Get the margin and page length
+ S %A=$P(%Y,";",1)
+ I %A?1A.ANP D SUBIEN(.%A,1) I $D(^%ZIS(2,%A,1)) K %Z91 D ST(1) S %Y=$P(%Y,";",2,9),%ZISMY=$P(%ZISMY,";",2,9) G MARGN
+ I %A>3 S $P(%Z91,"^")=$S(%A>255:255,1:+%A)
+ I $P(%Y,";",2) S $P(%Z91,"^",3)=+$S($P(%Y,";",2)>65530:65530,1:$P(%Y,";",2)) ;Cache fix for $Y#65535 wrap
+ ;
+ALTP I '$D(IO("P")) Q:%A>3  G ASKMAR:%ZTYPE["TRM" Q
+ S %X=$F(IO("P"),"M") I %X S %A=+$E(IO("P"),%X,99),$P(%Z91,"^")=$S(%A>255:255,1:%A)
+ S %X=$F(IO("P"),"L") I %X S $P(%Z91,"^",3)=+$E(IO("P"),%X,99)
+ Q:%A>3!(%ZTYPE'["TRM")
+ASKMAR I %IS["M",'$D(IOP),$S(%E=%H:+$P(%Z,"^",3),1:1),$P(%Z,"^",4) W "    Right Margin: " W:$P(%Z91,"^")]"" +%Z91,"// "
+ E  Q
+ D SBR^%ZIS1 I '$D(DTOUT)&'$D(DUOUT) S:%X=""&($P(%Z91,"^")]"") %X=+%Z91 G ASKMAR:%X'?1.N S $P(%Z91,"^")=$S(%X>255:255,1:%X) Q
+ S POP=1 I %ZISB&(%ZTYPE["TRM")&(IO'=IO(0)) C IO K IO(1,IO) Q
+ Q
+SETPAR S:%ZISOPAR]""&($A(%ZISOPAR)-40) %ZISOPAR="("_%ZISOPAR_")"
+ Q
+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"
+ D YN^%ZIS1 K %ZISDTIM G AQUE:%=0 Q:$D(IO("Q"))
+ 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
+ Q
+ST(%ZISTP) ;
+ S %ZISIOST(0)=%A,%ZISIOST=$P($G(^%ZIS(2,%A,0)),"^")
+ S:'$D(%Z91) %Z91=$P($G(^%ZIS(2,%A,1),"132^#^60^$C(8)"),"^",1,4),$P(%Z91,"^",5)=$G(^("XY"))
+ Q:%ZISTP
+STP N %B ;%E is a pointer to the Device file
+ S %B=$G(^%ZIS(1,%E,91))
+ S:$P(%B,"^")]"" $P(%Z91,"^")=+%B S:$P(%B,"^",3)]"" $P(%Z91,"^",3)=$P(%B,"^",3) ;S $P(%Z91,"^",5)=$G(^%ZIS(2,%ZISIOST(0),"XY"))
+ Q
+SUBIEN(%1,%) ;Return Subtype ien. %1 is call by Ref.
+ N %XX,%YY
+ I $D(^%ZIS(2,"B",%1))>9 S %1=+$O(^%ZIS(2,"B",%1,0)) Q
+ I '$G(%) S X="" Q
+ S %XX=%1 D 2^%ZIS5 S %1=+%YY
+ Q
+SUBTYPE(%A) ;Called from %ZISH
+ N %ZISIOST,%Z91
+ S:$G(%A)="" %A="P-OTHER"
+ D SUBIEN(.%A),ST(1)
+ S IOM=$P(%Z91,U,1),IOF=$P(%Z91,U,2),IOSL=$P(%Z91,U,3),IOST=%ZISIOST,IOST(0)=%ZISIOST(0),IOBS="$C(8)"
+ S:IOST="" IOST="P-OTHER",IOST(0)=0
+ Q
+ 
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,109 +1,103 @@
-%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
-OPEN	;From %ZIS3 for TRM
-	G OPN2:$D(IO(1,IO))
-	S POP=0 D OP1 G NOPEN:'$D(IO(1,IO))
-OPN2	;
-	I $D(%ZISHP),'$D(IOP) W !,*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
-	I '$D(IOP) W *7,"  [BUSY]" W "  ...  RETRY" S %=2,U="^" D YN^%ZIS1 G OPEN:%=1
-	S POP=1 Q
-	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
-	Q
-OPNERR	;Open Error
-	S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$$EC^%ZOSV,$EC=""
-	Q
-	;
-O	;From %ZIS6 for all 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
-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)
-	N % S %(IO)="",%=$P($P($NA(%(IO)),"(",2),")")
-	S %A=%_$E(":",%A]"")_%A
-	D O1 I POP D  Q
-	.I %ZTYPE="HFS",'$D(IOP),$G(IO("ERROR"))["file not found" W !,?5,*7,"[File Not Found]" Q
-	.W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q
-	;S IO(1,IO)="" U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91)
-	U IO S $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91)
-	I %ZISUPAR]"" S %A1=""""_IO_""":"_%ZISUPAR U @%A1
-	;U:%IS'[0 IO(0)
-	G OXECUTE^%ZIS6
-	;
-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)=""
-	S IO("ERROR")="" Q
-	;
-	;Need to find out how to get IP address
-ZIO	N %,%1 S (%,%1)=$ZIO
-	I $ZV["VMS",%["_TNA" D
-	. S (%,%1)=$ZGETDVI($I,"TT_ACCPORNAM")
-	. S %=$S(%["Host:":$P($P(%,"Host: ",2)," ")_":"_$P(%,"Port: ",2),1:%) S:%[" " %=$TR(%," ")
-	I $ZV'["VMS" D
-	. S (%,%1)=$ZTRNLNM("REMOTEHOST") S:$L(%) %1="Host:"_% S:'$L(%) %=$ZIO
-	S IO("ZIO")=% S:(%1["Host:")&'$D(IO("IP")) IO("IP")=$P(%,":")
-	Q
-	;
-TCPIP	;For TCP/IP devices, should use ^%ZISTCP
-	N %S
-	S %ZISTO=$G(%ZISTO,3)
-	S %A="IO:"_$S($E(%ZISOPAR)="(":"",1:"(")_%ZISOPAR_$S($E(%ZISOPAR,$L(%ZISOPAR))=")":"",1:")")_":%ZISTO:""SOCKET"""
-	;U $P W !,"%A=",%A
-	O @%A I '$T S POP=1 Q  ;D O1 ;Do the open.
-	U IO:(WIDTH=512:NOWRAP:EXCEPT="G OPNERR^%ZIS4") S %S=$KEY
-	U $P ;W !,"$KEY=",%S
-	Q
-	;
-SPOOL	;%ZDA=pointer to ^XMB(3.51, %ZFN=spool file name.
-	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
-	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="#"
-	I $D(^%ZIS(1,%ZISIOS,1)),$P(^(1),"^",8),$O(^("SPL",0)) S ^XUTL("XQ",$J,"ADSPL")=%ZISIOS,ZISPLAD=%ZISIOS
-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
-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<%
-SPLEX	C %ZFN:(DELETE) K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q
-	;
-CL2	S %=%+1 I %Z1<% S ^XMBS(3.519,XS,2,%,0)="*** INCOMPLETE REPORT  -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***",$P(^XMB(3.51,%ZDA,0),"^",11)=1 Q
-	I %2[$C(12) S ^XMBS(3.519,XS,2,%,0)="|TOP|" Q
-	S ^XMBS(3.519,XS,2,%,0)=%2 Q
-	;
-HFS	G HFS^%ZISF
-REWMT(IO,IOPAR)	;Rewind Magtape
-	S X="REWERR^%ZIS4",@^%ZOSF("TRAP")
-	U IO W *5
-	Q 1
-REWSDP(IO,IOPAR)	;Rewind SDP
-	G REW1
-REWHFS(IO,IOPAR)	;Rewind Host File.
-REW1	S X="REWERR^%ZIS4",@^%ZOSF("TRAP")
-	U IO:(REWIND)
-	Q 1
-REWERR	;Error encountered
-	Q 0
+%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))
+ S POP=0 D OP1 G NOPEN:'$D(IO(1,IO))
+OPN2 ;
+ I $D(%ZISHP),'$D(IOP) W !,*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
+ I '$D(IOP) W *7,"  [BUSY]" W "  ...  RETRY" S %=2,U="^" D YN^%ZIS1 G OPEN:%=1
+ S POP=1 Q
+ Q
+ ;Why no open paraneters???
+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
+ ;
+O ;From %ZIS6 for other types.
+ D:%IS["L" ZIO
+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["):":"",%ZTYPE["CHAN"&($P(%ZTIME,"^",3)="n"):"",1:":"_%ZISTO)
+ N % S %(IO)="",%=$P($P($NA(%(IO)),"(",2),")")
+ S %A=%_$E(":",%A]"")_%A
+ D O1 I POP D  Q
+ .I %ZTYPE="HFS",'$D(IOP),$G(IO("ERROR"))["file not found" W !,?5,*7,"[File Not Found]" Q
+ .W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q
+ ;S IO(1,IO)="" U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91)
+ U IO S $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91)
+ I %ZISUPAR]"" S %A1=""""_IO_""":"_%ZISUPAR U @%A1
+ ;U:%IS'[0 IO(0)
+ G OXECUTE^%ZIS6
+ ;
+O1 N $ES,$ET S $ET="G OPNERR^%ZIS4"
+ 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
+ ;
+ ;Need to find out how to get IP address
+ZIO N %,%1 S (%,%1)=$ZIO
+ I $ZV["VMS",%["_TNA" D
+ . S (%,%1)=$ZGETDVI($I,"TT_ACCPORNAM")
+ . S %=$S(%["Host:":$P($P(%,"Host: ",2)," ")_":"_$P(%,"Port: ",2),1:%) S:%[" " %=$TR(%," ")
+ I $ZV'["VMS" D
+ . S (%,%1)=$ZTRNLNM("REMOTEHOST") S:$L(%) %1="Host:"_% S:'$L(%) %=$ZIO
+ S IO("ZIO")=% S:(%1["Host:")&'$D(IO("IP")) IO("IP")=$P(%,":")
+ Q
+ ;
+TCPIP ;For TCP/IP devices
+ N %S
+ S %ZISTO=$G(%ZISTO,3)
+ S %A="IO:"_$S($E(%ZISOPAR)="(":"",1:"(")_%ZISOPAR_$S($E(%ZISOPAR,$L(%ZISOPAR))=")":"",1:")")_":%ZISTO:""SOCKET"""
+ ;U $P W !,"%A=",%A
+ O @%A I '$T S POP=1 Q  ;D O1 ;Do the open.
+ U IO:(WIDTH=512:NOWRAP:EXCEPT="G OPNERR^%ZIS4") S %S=$KEY
+ U $P ;W !,"$KEY=",%S
+ Q
+ ;
+SPOOL ;%ZDA=pointer to ^XMB(3.51, %ZFN=spool file name.
+ 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),%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="#"
+ I $D(^%ZIS(1,%ZISIOS,1)),$P(^(1),"^",8),$O(^("SPL",0)) S ^XUTL("XQ",$J,"ADSPL")=%ZISIOS,ZISPLAD=%ZISIOS
+OK K %ZDA,%ZFN Q
+N K %ZDA,%ZFN,IO("DOC") S POP=1 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 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
+ ;
+CL2 S %=%+1 I %Z1<% S ^XMBS(3.519,XS,2,%,0)="*** INCOMPLETE REPORT  -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***",$P(^XMB(3.51,%ZDA,0),"^",11)=1 Q
+ I %2[$C(12) S ^XMBS(3.519,XS,2,%,0)="|TOP|" Q
+ S ^XMBS(3.519,XS,2,%,0)=%2 Q
+ ;
+HFS G HFS^%ZISF
+REWMT(IO,IOPAR) ;Rewind Magtape
+ S X="REWERR^%ZIS4",@^%ZOSF("TRAP")
+ U IO W *5
+ Q 1
+REWSDP(IO,IOPAR) ;Rewind SDP
+ G REW1
+REWHFS(IO,IOPAR) ;Rewind Host File.
+REW1 S X="REWERR^%ZIS4",@^%ZOSF("TRAP")
+ U IO:(REWIND)
+ Q 1
+REWERR ;Error encountered
+ Q 0
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,101 +1,88 @@
-%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
-	;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
-	I $D(%ZISMTR) X ^%ZOSF("MAGTAPE") U IO W:$D(%MT("REW")) @%MT("REW") U IO(0) K %MT
-	G QUIT:'$D(IO("P"))
-	I $F(IO("P"),"B"),$D(^%ZIS(2,%ZISIOST(0),7)) S %Y=$P(^(7),"^",1) I %Y]"" W @%Y
-	S %Y=$F(IO("P"),"P") G QLTY:'%Y S %Y=+$E(IO("P"),%Y,99),%X=$S(%Y=16:12.1,%Y=10!(%Y=12):5,1:"") G QLTY:'%X
-	S %Y=$S($D(^%ZIS(2,%ZISIOST(0),%X)):$P(^(%X),"^",$S(%Y=12:2,1:1)),1:"")
-	I %Y]"" W @%Y
-QLTY	S %Y=$F(IO("P"),"Q") Q:'%Y  S %Y=+$E(IO("P"),%Y,99),%X=$S(%Y<0!(%Y>2):0,1:%Y+1)
-	I %X S %Y=$S($D(^%ZIS(2,%ZISIOST(0),12.2)):$P(^(12.2),"^",%X),1:"") I %Y]""  W @%Y
-QUIT	U:%IS'[0 IO(0)
-	Q
-2	Q:%Y=""  I %IS'[0,$D(^%ZIS(1,+%H,"TYPE")),^("TYPE")["TRM" D OH Q:POP
-	S %X=$T U IO D %Y^ZISX ;Q:'%X  U IO(0)
-	Q
-OH	Q:$S($G(IO(0))]"":$D(IO(1,IO(0))),1:0)
-	N X S X="OPNERR^%ZIS4",@^%ZOSF("TRAP")
-	O IO(0)::0 S IO(1,IO(0))="" Q  ;See that HOME DEVICE is open.
-	;
-SAY(%SAY)	;
-	Q:%IS[0  U IO(0) W %SAY U IO
-	Q
-RES1	;Allocate a resource slot, Release in %ZISC.
-	N A,L,X,%ZISD0
-	S %ZISD0=$O(^%ZISL(3.54,"B",IO,0))
-	I '%ZISD0 S %ZISD0=$$RADD(IO) ;New one
-	L +^%ZISL(3.54,%ZISD0,0):2 I '$T S POP=1 W:'$D(IOP) *7,"  [NOT Available]" G RESX
-RES2	S X=$P(^%ZISL(3.54,%ZISD0,0),"^",2)
-	I X<1 S POP=1 W:'$D(IOP) *7,"  [NOT Available]" G RESX
-	S X=$S(X>0:X-1,1:0),$P(^%ZISL(3.54,%ZISD0,0),"^",2)=X
-	;
-R1	;Grab a slot
-	S IO(1,IO)="RES",A=$G(^%ZISL(3.54,%ZISD0,1,0),"^3.542^^")
-	F L=1:1:%ZISRL I '$D(^%ZISL(3.54,%ZISD0,1,L,0)) Q
-	I '$T K IO(1,IO) G RES2 ;No free slots
-	S ^%ZISL(3.54,%ZISD0,1,L,0)=L_"^"_%ZISV_"^"_$J_"^"_$G(ZTSK)_"^"_$H,^%ZISL(3.54,"AJ",$J,%ZISD0,L)="",^%ZISL(3.54,%ZISD0,1,"B",L,L)=""
-	S $P(A,"^",3,4)=L_U_($P(A,U,4)+1),^%ZISL(3.54,%ZISD0,1,0)=A
-RESX	L -^%ZISL(3.54,%ZISD0,0) Q
-	;
-RADD(X)	;Add Resource
-	N %1,%2
-	S %1=$G(^%ZISL(3.54,0),"RESOURCE^3.54^^"),%2=$P(%1,U,3)
-	F %2=%2:1 Q:'$D(^%ZISL(3.54,%2,0))
-	S $P(^%ZISL(3.54,0),U,3,4)=%2_U_($P(%1,U,4)+1),^%ZISL(3.54,%2,0)=X_"^"_$G(%ZISRL,1),^%ZISL(3.54,"B",X,%2)=""
-	Q %2
-	;
-RESOK	;DEVOK check for RES devices, for all OS's.
-	N %ZISD0,%ZISD1
-	S Y=0,%ZISD0=$O(^%ZISL(3.54,"B",X,0))
-	I '%ZISD0 S Y=-1,%ZISD0=$O(^%ZIS(1,"C",X,0)) Q:'%ZISD0  Q:'$D(^%ZIS(1,+%ZISD0,0))  Q:$P(^(0),"^")'=X  Q:'$D(^("TYPE"))  Q:^("TYPE")'="RES"  S Y=0 Q
-	S X1=$G(^%ZISL(3.54,+%ZISD0,0))
-	I $P(X1,"^",2)&(X=$P(X1,"^")) S Y=0 Q
-	S Y=999 F %ZISD1=0:0 S %ZISD1=$O(^%ZISL(3.54,%ZISD0,1,%ZISD1)) Q:%ZISD1'>0  I $D(^(%ZISD1,0)) S Y=$P(^(0),"^",3) Q
-	Q
-	;
-Q	G Q^%ZIS3
-HG	;
-	Q
-SPL	;Spool type
-	N %E,%Z D MARGN^%ZIS3 W:'$D(IOP) ! D SPOOL^%ZIS4:%IS'["T"
-	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"))
-	G Q
-HFS	;Host File Server type
-	D MARGN^%ZIS3,HFS^%ZIS4 W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T"))
-	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
-	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
-CHAN	;Network Channel type devices -- DecNet or TCP/IP devices.
-	I IO="SYS$NET",$I="SYS$INPUT:;" S IO(0)=IO U IO ;DECNET Server Device
-	D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T"))
-	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"))
-	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
-	I POP,%ZISB&(%ZTYPE["TRM") C IO K IO(1,IO) Q
-	Q:POP  G SETPAR^%ZIS3
-	;
-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
-	;
+%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 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"))
+ I $F(IO("P"),"B"),$D(^%ZIS(2,%ZISIOST(0),7)) S %Y=$P(^(7),"^",1) I %Y]"" W @%Y
+ S %Y=$F(IO("P"),"P") G QLTY:'%Y S %Y=+$E(IO("P"),%Y,99),%X=$S(%Y=16:12.1,%Y=10!(%Y=12):5,1:"") G QLTY:'%X
+ S %Y=$S($D(^%ZIS(2,%ZISIOST(0),%X)):$P(^(%X),"^",$S(%Y=12:2,1:1)),1:"")
+ I %Y]"" W @%Y
+QLTY S %Y=$F(IO("P"),"Q") Q:'%Y  S %Y=+$E(IO("P"),%Y,99),%X=$S(%Y<0!(%Y>2):0,1:%Y+1)
+ I %X S %Y=$S($D(^%ZIS(2,%ZISIOST(0),12.2)):$P(^(12.2),"^",%X),1:"") I %Y]""  W @%Y
+QUIT U:%IS'[0 IO(0)
+ Q
+2 Q:%Y=""  I %IS'[0,$D(^%ZIS(1,+%H,"TYPE")),^("TYPE")["TRM" D OH Q:POP
+ S %X=$T U IO D %Y^ZISX ;Q:'%X  U IO(0)
+ Q
+OH Q:$S($G(IO(0))]"":$D(IO(1,IO(0))),1:0)
+ N X S X="OPNERR^%ZIS4",@^%ZOSF("TRAP")
+ O IO(0)::0 S IO(1,IO(0))="" Q  ;See that HOME DEVICE is open.
+ ;
+SAY(%SAY) ;
+ Q:%IS[0  U IO(0) W %SAY U IO
+ Q
+RES1 ;Allocate a resource slot, Release in %ZISC.
+ N A,L,X,%ZISD0
+ S %ZISD0=$O(^%ZISL(3.54,"B",IO,0))
+ I '%ZISD0 S %ZISD0=$$RADD(IO) ;New one
+ L +^%ZISL(3.54,%ZISD0,0):2 I '$T S POP=1 W:'$D(IOP) *7,"  [NOT Available]" G RESX
+RES2 S X=$P(^%ZISL(3.54,%ZISD0,0),"^",2)
+ I X<1 S POP=1 W:'$D(IOP) *7,"  [NOT Available]" G RESX
+ S X=$S(X>0:X-1,1:0),$P(^%ZISL(3.54,%ZISD0,0),"^",2)=X
+ ;
+R1 ;Grab a slot
+ S IO(1,IO)="RES",A=$G(^%ZISL(3.54,%ZISD0,1,0),"^3.542^^")
+ F L=1:1:%ZISRL I '$D(^%ZISL(3.54,%ZISD0,1,L,0)) Q
+ I '$T K IO(1,IO) G RES2 ;No free slots
+ S ^%ZISL(3.54,%ZISD0,1,L,0)=L_"^"_%ZISV_"^"_$J_"^"_$G(ZTSK)_"^"_$H,^%ZISL(3.54,"AJ",$J,%ZISD0,L)="",^%ZISL(3.54,%ZISD0,1,"B",L,L)=""
+ S $P(A,"^",3,4)=L_U_($P(A,U,4)+1),^%ZISL(3.54,%ZISD0,1,0)=A
+RESX L -^%ZISL(3.54,%ZISD0,0) Q
+ ;
+RADD(X) ;Add Resource
+ N %1,%2
+ S %1=$G(^%ZISL(3.54,0),"RESOURCE^3.54^^"),%2=$P(%1,U,3)
+ F %2=%2:1 Q:'$D(^%ZISL(3.54,%2,0))
+ S $P(^%ZISL(3.54,0),U,3,4)=%2_U_($P(%1,U,4)+1),^%ZISL(3.54,%2,0)=X_"^"_$G(%ZISRL,1),^%ZISL(3.54,"B",X,%2)=""
+ Q %2
+ ;
+RESOK ;DEVOK check for RES devices, for all OS's.
+ N %ZISD0,%ZISD1
+ S Y=0,%ZISD0=$O(^%ZISL(3.54,"B",X,0))
+ I '%ZISD0 S Y=-1,%ZISD0=$O(^%ZIS(1,"C",X,0)) Q:'%ZISD0  Q:'$D(^%ZIS(1,+%ZISD0,0))  Q:$P(^(0),"^")'=X  Q:'$D(^("TYPE"))  Q:^("TYPE")'="RES"  S Y=0 Q
+ S X1=$G(^%ZISL(3.54,+%ZISD0,0))
+ I $P(X1,"^",2)&(X=$P(X1,"^")) S Y=0 Q
+ S Y=999 F %ZISD1=0:0 S %ZISD1=$O(^%ZISL(3.54,%ZISD0,1,%ZISD1)) Q:%ZISD1'>0  I $D(^(%ZISD1,0)) S Y=$P(^(0),"^",3) Q
+ Q
+ ;
+Q G Q^%ZIS3
+HG ;
+ Q
+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 D MARGN^%ZIS3,ASKPAR W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Sequential disk processor type
+ G Q
+HFS D MARGN^%ZIS3,HFS^%ZIS4 W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Host File Server type
+ G 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
+CHAN ;Network Channel type devices -- DecNet or TCP/IP devices.
+ I IO="SYS$NET",$I="SYS$INPUT:;" S IO(0)=IO U IO ;DECNET Server Device
+ D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T"))
+ G Q
+IMPC ;Imaging Work Station
+BAR ;Bar Code
+OTH D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Other Device type
+ G Q
+ ;
+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
+ ;
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,130 +1,131 @@
-%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
-C0	;
-	N %,%E,%H,%ZISI,%ZISOS,%ZISX,%ZISV
-	;Clear IO var we will use for reporting
-	K IO("ERROR"),IO("LASTERR"),IO("CLOSE")
-	;Protect ourself from calls with incomplete setup.
-	S:$D(IO)[0 IO=$I S:'$D(IO(0)) IO(0)=$P
-	S U="^",%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^("VOL"))
-	;S %=$S(+$G(IOS):IOS,$L($G(ION)):ION,1:IO)
-	S %=$S($L($G(ION)):ION,1:IO) ;p409
-	I (%="")!(IO="") G SETIO:IO(0)]"",END
-	I $G(IOT)="RES" D RES G SETIO ;Handle a resource device
-	;
-	;Define subtype info if not already defined.
-	D SUBTYPE
-	;
-	;perform close execute
-	I $G(IOST(0))>0 D
-	. I $G(^%ZIS(2,+IOST(0),3))]"",$D(IO(1,IO)) D
-	. . U IO S:$X $X=1 D X3^ZISX:'$D(IO("T"))
-	;
-	;Incase the Close execute changed IO, Open IO("HOME") or NULL.
-	I '$L($G(IO)) D  Q
-	. S IOP=$S($L($G(IO("HOME"))):"`"_(+IO("HOME")),1:"NULL") D ^%ZIS
-	. Q
-	;
-	;Perform the following if the device is open.
-	I $D(IO(1,IO)) D
-	. I $G(IO("P"))["B" D  ;Return to normal intensity
-	. . S %=$P($G(^%ZIS(2,+IOST(0),7)),"^",3) I %]"" W @%
-	. I $G(IO("P"))["P" D  ;Return to default pitch
-	. . S %=$G(^%ZIS(2,+IOST(0),12.11)) I %]"" W @%
-	. ;
-	. W:$$FF @IOF ;Issue form feed at close
-	. I $$CLOSPP D X11^ZISX:'$D(IO("T")) K IO("S") ;Close printer port
-	. Q
-	;
-	;Don't use IOCPU as we now use IO(1,IO)
-	I (IO'=IO(0)!$D(IO("C"))),$D(IO(1,IO)) D
-	. 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(IO("SPOOL")) D CLOSE^%ZIS4 ;Special close for spool device
-	;
-SETIO	;
-	;See if old device has PCX code
-	I $G(IOS),$G(^%ZIS(1,+IOS,"PCX"))]"" S %ZISPCX=^("PCX")
-	;Setup the IO(0) device, should be the home device
-	S IO=IO(0),(IOPAR,IOUPAR)="" K IO("T") D CIOS(IO(0))
-	I 'IOS S IOT="TRM" G END
-	S ION=$P(^%ZIS(1,IOS,0),"^",1),IOT=$G(^("TYPE")),IOST(0)=$S(IOT["TRM"&($D(^XUTL("XQ",$J,"IOST(0)"))):^("IOST(0)"),1:$G(^%ZIS(1,IOS,"SUBTYPE")))
-	I IOT["TRM",$D(^XUTL("XQ",$J,"IO")) D HOME^%ZIS G END
-	S %="Y"
-	I IOST(0),$D(^%ZIS(2,IOST(0),1)) S %=^(1),IOM=+%,IOF=$P(%,"^",2),IOSL=$P(%,"^",3),IOBS=$P(%,"^",4)
-	I $D(^%ZIS(1,IOS,91)) S %=^%ZIS(1,IOS,91) S:+% IOM=+% S:$P(%,"^",3) IOSL=$P(%,"^",3)
-	;Don't know the subtype so set some defaults
-	I %="Y" S IOM=80,IOSL=24,IOF="#",IOST="C-OTHER",IOBS="$C(8)"
-S1	S:IOST(0) IOST=$P($G(^%ZIS(2,+IOST(0),0)),"^"),IOXY=$G(^("XY"))
-	I '$D(ZTQUEUED),'$D(IO("C")),IOT["TRM" D RM:$D(IO(1,IO))
-	;With home device set, Do Post-close execute code of Device closed.
-END	I '$D(IO("T")),$G(%ZISPCX)]"" S %Y=%ZISPCX D %Y^ZISX
-	;See that any extra IO variables are cleaned up
-	K IO("P"),IO("DOC"),IO("HFSIO"),IO("SPOOL"),IOC,IONOFF
-	;IOCPU should not be changed.
-	Q
-	;
-SUBTYPE	;Find a subtype
-	N %S
-	S IOST=$G(IOST),IOST(0)=+$G(IOST(0))
-	I $L(IOST)&$L(IOST(0)) Q  ;Have a subtype
-	S %S=$G(^%ZIS(2,+IOST(0),0)) I $L(%S) S IOST=$P(%S,U) Q
-	I $L(IOST) S %S=$O(^%ZIS(2,"B",$G(IOST,"X"),0)) I %S>0 S IOST(0)=+%S Q
-	S IOST="",IOST(0)=0 D CIOS($I) Q:IOS'>0
-	S IOST(0)=$G(^%ZIS(1,+IOS,"SUBTYPE")),IOST=$P($G(^%ZIS(2,+IOST(0),0)),"^")
-	Q
-	;
-CIOS(%I)	;Find a value for IOS (IEN into device file)
-	N %ZISVT
-	I $D(^XUTL("XQ",$J,"IOS")) S IOS=+^("IOS") Q
-	I $D(%ZISV) S %ZISVT=%I D VTLKUP^%ZIS S IOS=+%E
-	E  S IOS=+$O(^%ZIS(1,"C",%I,0))
-	Q:$G(IOS)>0
-	S %ZISVT=%I D VIRTUAL^%ZIS
-	I $D(%ZISVT) S %H=%E I %ZISVT]"",%H>0,$D(^%ZIS(1,%H,0)),$D(^("TYPE")),^("TYPE")="VTRM" S IOS=%H
-	Q
-	;
-RM	N X S X=+IOM X ^%ZOSF("RM")
-	Q
-	;
-RES	;Close resource device.
-	Q:'$D(IO(1,IO))&'$D(^%ZISL(3.54,"AJ",$J))
-	N %ZISJOB,%X,%Y,%ZISD0,%ZISD1,%ZISRES,%ZISRL,%ZISY0,%ZTRTN,ZTSAVE,ZTIO
-	S %ZISJOB=$J
-	;
-RES1	G RQ:'$D(IOS),RQ:'$D(^%ZIS(1,+IOS,1)) S %ZISRL=+$P(^(1),"^",10),%ZISRL=$S(%ZISRL:%ZISRL,1:1)
-	S %X=$O(^%ZISL(3.54,"B",IO,0)) G RQ:'%X
-	G RQ:'$D(^%ZISL(3.54,+%X,0)) S %ZISD0=+%X,%ZISY0=^(0)
-	S %X=$O(^%ZISL(3.54,"AJ",%ZISJOB,%ZISD0,0)) S %ZISD1=%X G RQ:'%X
-	S %Y=$G(^%ZISL(3.54,%ZISD0,1,+%ZISD1,0)) G RQ:$P(%Y,"^",3)'=%ZISJOB
-	D KILLRES(+%ZISD0,+%ZISD1)
-RQ	K IO(1,IO)
-	Q
-	;
-KILLRES(D0,D1)	;Kill one resource use
-	Q:(D0'>0)!(D1'>0)
-	N %X,%Y,%J,%ZISRL
-	L +^%ZISL(3.54,D0,0)
-	S %Y=$G(^%ZISL(3.54,D0,0)) G KRX:%Y=""
-	S %X=$G(^%ZISL(3.54,D0,1,D1,0)),%J=$P(%X,"^",3) S:%J="" %J=" "
-	K ^%ZISL(3.54,D0,1,D1,0),^%ZISL(3.54,D0,1,"B",D1,D1),^%ZISL(3.54,"AJ",%J,D0,D1)
-	S %X=$P(%Y,"^",2)+1,$P(^%ZISL(3.54,D0,0),"^",2)=%X
-	;I '$D(^%ZISL(3.54,%ZISD0,1,0)) S ^(0)="^3.542A^^" G RQ
-	S %Y=$G(^%ZISL(3.54,D0,1,0)),%X=$P(%Y,"^",4),$P(^%ZISL(3.54,D0,1,0),"^",3,4)="^"_$S(%X>0:(%X-1),1:0)
-KRX	L -^%ZISL(3.54,D0,0)
-	Q
-	;
-DQCRES	;Tasked entry point to close resource device.
-	S IO=%ZISRES G RES1
-	;
-FF()	;Issue form feed
-	I $E(IOST,1,2)'["C-",$D(IO(1,IO)),$G(IOT)="TRM"!($G(IOT)="SPL"),'$D(IO("T"))&$Y&'$D(IONOFF)&'$D(IO(1,IO,"NOFF")) Q 1
-	Q 0
-	;
-CLOSPP()	;Close printer port
-	I $D(IO("S")),$D(^%ZIS(2,+IO("S"),11))&$D(IO(1,IO)) Q 1
-	Q 0
+%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
+ ;Clear IO var we will use for reporting
+ K IO("ERROR"),IO("LASTERR"),IO("CLOSE")
+ ;Protect ourself from calls with incomplete setup.
+ S:$D(IO)[0 IO=$I S:'$D(IO(0)) IO(0)=$P
+ S U="^",%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^("VOL"))
+ ;S %=$S(+$G(IOS):IOS,$L($G(ION)):ION,1:IO)
+ S %=$S($L($G(ION)):ION,1:IO) ;p409
+ I (%="")!(IO="") G SETIO:IO(0)]"",END
+ I $G(IOT)="RES" D RES G SETIO ;Handle a resource device
+ ;
+ ;Define subtype info if not already defined.
+ D SUBTYPE
+ ;
+ ;perform close execute
+ I $G(IOST(0))>0 D
+ . I $G(^%ZIS(2,+IOST(0),3))]"",$D(IO(1,IO)) D
+ . . U IO S:$X $X=1 D X3^ZISX:'$D(IO("T"))
+ ;
+ ;Incase the Close execute changed IO, Open IO("HOME") or NULL.
+ I '$L($G(IO)) D  Q
+ . S IOP=$S($L($G(IO("HOME"))):"`"_(+IO("HOME")),1:"NULL") D ^%ZIS
+ . Q
+ ;
+ ;Perform the following if the device is open.
+ I $D(IO(1,IO)) D
+ . I $G(IO("P"))["B" D  ;Return to normal intensity
+ . . S %=$P($G(^%ZIS(2,+IOST(0),7)),"^",3) I %]"" W @%
+ . I $G(IO("P"))["P" D  ;Return to default pitch
+ . . S %=$G(^%ZIS(2,+IOST(0),12.11)) I %]"" W @%
+ . ;
+ . W:$$FF @IOF ;Issue form feed at close
+ . I $$CLOSPP D X11^ZISX:'$D(IO("T")) K IO("S") ;Close printer port
+ . Q
+ ;
+ ;Don't use IOCPU as we now use IO(1,IO)
+ I (IO'=IO(0)!$D(IO("C"))),$D(IO(1,IO)) D
+ . 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
+ ;
+ ;
+ 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
+ ;
+SETIO ;
+ ;See if old device has PCX code
+ I $G(IOS),$G(^%ZIS(1,+IOS,"PCX"))]"" S %ZISPCX=^("PCX")
+ ;Setup the IO(0) device, should be the home device
+ S IO=IO(0),(IOPAR,IOUPAR)="" K IO("T") D CIOS(IO(0))
+ I 'IOS S IOT="TRM" G END
+ S ION=$P(^%ZIS(1,IOS,0),"^",1),IOT=$G(^("TYPE")),IOST(0)=$S(IOT["TRM"&($D(^XUTL("XQ",$J,"IOST(0)"))):^("IOST(0)"),1:$G(^%ZIS(1,IOS,"SUBTYPE")))
+ I IOT["TRM",$D(^XUTL("XQ",$J,"IO")) D HOME^%ZIS G END
+ S %="Y"
+ I IOST(0),$D(^%ZIS(2,IOST(0),1)) S %=^(1),IOM=+%,IOF=$P(%,"^",2),IOSL=$P(%,"^",3),IOBS=$P(%,"^",4)
+ I $D(^%ZIS(1,IOS,91)) S %=^%ZIS(1,IOS,91) S:+% IOM=+% S:$P(%,"^",3) IOSL=$P(%,"^",3)
+ ;Don't know the subtype so set some defaults
+ I %="Y" S IOM=80,IOSL=24,IOF="#",IOST="C-OTHER",IOBS="$C(8)"
+S1 S:IOST(0) IOST=$P($G(^%ZIS(2,+IOST(0),0)),"^"),IOXY=$G(^("XY"))
+ I '$D(ZTQUEUED),'$D(IO("C")),IOT["TRM" D RM:$D(IO(1,IO))
+ ;With home device set, Do Post-close execute code of Device closed.
+END I '$D(IO("T")),$G(%ZISPCX)]"" S %Y=%ZISPCX D %Y^ZISX
+ ;See that any extra IO variables are cleaned up
+ K IO("P"),IO("DOC"),IO("HFSIO"),IO("SPOOL"),IOC,IONOFF
+ ;IOCPU should not be changed.
+ Q
+ ;
+SUBTYPE ;Find a subtype
+ N %S
+ S IOST=$G(IOST),IOST(0)=+$G(IOST(0))
+ I $L(IOST)&$L(IOST(0)) Q  ;Have a subtype
+ S %S=$G(^%ZIS(2,+IOST(0),0)) I $L(%S) S IOST=$P(%S,U) Q
+ I $L(IOST) S %S=$O(^%ZIS(2,"B",$G(IOST,"X"),0)) I %S>0 S IOST(0)=+%S Q
+ S IOST="",IOST(0)=0 D CIOS($I) Q:IOS'>0
+ S IOST(0)=$G(^%ZIS(1,+IOS,"SUBTYPE")),IOST=$P($G(^%ZIS(2,+IOST(0),0)),"^")
+ Q
+ ;
+CIOS(%I) ;Find a value for IOS (IEN into device file)
+ N %ZISVT
+ I $D(^XUTL("XQ",$J,"IOS")) S IOS=+^("IOS") Q
+ I $D(%ZISV) S %ZISVT=%I D VTLKUP^%ZIS S IOS=+%E
+ E  S IOS=+$O(^%ZIS(1,"C",%I,0))
+ Q:$G(IOS)>0
+ S %ZISVT=%I D VIRTUAL^%ZIS
+ I $D(%ZISVT) S %H=%E I %ZISVT]"",%H>0,$D(^%ZIS(1,%H,0)),$D(^("TYPE")),^("TYPE")="VTRM" S IOS=%H
+ Q
+ ;
+RM N X S X=+IOM X ^%ZOSF("RM")
+ Q
+ ;
+RES ;Close resource device.
+ Q:'$D(IO(1,IO))&'$D(^%ZISL(3.54,"AJ",$J))
+ N %ZISJOB,%X,%Y,%ZISD0,%ZISD1,%ZISRES,%ZISRL,%ZISY0,%ZTRTN,ZTSAVE,ZTIO
+ S %ZISJOB=$J
+ ;
+RES1 G RQ:'$D(IOS),RQ:'$D(^%ZIS(1,+IOS,1)) S %ZISRL=+$P(^(1),"^",10),%ZISRL=$S(%ZISRL:%ZISRL,1:1)
+ S %X=$O(^%ZISL(3.54,"B",IO,0)) G RQ:'%X
+ G RQ:'$D(^%ZISL(3.54,+%X,0)) S %ZISD0=+%X,%ZISY0=^(0)
+ S %X=$O(^%ZISL(3.54,"AJ",%ZISJOB,%ZISD0,0)) S %ZISD1=%X G RQ:'%X
+ S %Y=$G(^%ZISL(3.54,%ZISD0,1,+%ZISD1,0)) G RQ:$P(%Y,"^",3)'=%ZISJOB
+ D KILLRES(+%ZISD0,+%ZISD1)
+RQ K IO(1,IO)
+ Q
+ ;
+KILLRES(D0,D1) ;Kill one resource use
+ Q:(D0'>0)!(D1'>0)
+ N %X,%Y,%J,%ZISRL
+ L +^%ZISL(3.54,D0,0)
+ S %Y=$G(^%ZISL(3.54,D0,0)) G KRX:%Y=""
+ S %X=$G(^%ZISL(3.54,D0,1,D1,0)),%J=$P(%X,"^",3) S:%J="" %J=" "
+ K ^%ZISL(3.54,D0,1,D1,0),^%ZISL(3.54,D0,1,"B",D1,D1),^%ZISL(3.54,"AJ",%J,D0,D1)
+ S %X=$P(%Y,"^",2)+1,$P(^%ZISL(3.54,D0,0),"^",2)=%X
+ ;I '$D(^%ZISL(3.54,%ZISD0,1,0)) S ^(0)="^3.542A^^" G RQ
+ S %Y=$G(^%ZISL(3.54,D0,1,0)),%X=$P(%Y,"^",4),$P(^%ZISL(3.54,D0,1,0),"^",3,4)="^"_$S(%X>0:(%X-1),1:0)
+KRX L -^%ZISL(3.54,D0,0)
+ Q
+ ;
+DQCRES ;Tasked entry point to close resource device.
+ S IO=%ZISRES G RES1
+ ;
+FF() ;Issue form feed
+ I $E(IOST,1,2)'["C-",$D(IO(1,IO)),$G(IOT)="TRM"!($G(IOT)="SPL"),'$D(IO("T"))&$Y&'$D(IONOFF)&'$D(IO(1,IO,"NOFF")) Q 1
+ Q 0
+ ;
+CLOSPP() ;Close printer port
+ I $D(IO("S")),$D(^%ZIS(2,+IO("S"),11))&$D(IO(1,IO)) Q 1
+ Q 0
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,88 +1,69 @@
-%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
-	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=""
-	I "IOEFLD^IOSTBM"[%ZISFN S @%ZISFN=%ZISXX Q
-	I %ZISXX]"" S @("%ZISY="_%ZISXX)
-	;E  S @("%ZISY="_"""""")
-	I $E(%ZISFN,1,2)="IO" S @%ZISFN=%ZISY
-	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))
-	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
-	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)
-	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
-	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
-	;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
-	Q
-L1	I ZISCH="_"!(ZISCH=",") S %ZISYY=%ZISYY_"_" Q
-	I ZISCH=ZISQ D QUOTE Q
-	I ZISCH="$" D DOLR Q
-	I ZISCH="*" D STAR Q
-	I ZISCH="(" D PAREN Q
-	S %ZISYY=%ZISYY_ZISCH
-	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)_")"
-	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
-	S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH'=""&(ZISCH'=",") ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_ZISNUM_")",ZISXL=ZISXL-1 Q
-	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.
-	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
-	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
-S1	I ZISCH=ZISQ D QUOTE Q
-	I ZISCH="$" D DOLR Q
-	I ZISCH="(" D PAREN Q
-	S %ZISYY=%ZISYY_ZISCH
-	Q
-	;
-S2	;MERGE $C
-	S %ZISX1=$E(%ZISX1,1,$L(%ZISX1)-1),%ZISX2=","_$E(%ZISX2,4,$L(%ZISX2))
-	S $P(%ZISXX,"_",I,I+1)=%ZISX1_%ZISX2
-	N I D L2
-	Q
+%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
+INDCK S %ZISY=""
+ I "IOEFLD^IOSTBM"[%ZISFN S @%ZISFN=%ZISXX Q
+ I %ZISXX]"" S @("%ZISY="_%ZISXX)
+ ;E  S @("%ZISY="_"""""")
+ I $E(%ZISFN,1,2)="IO" S @%ZISFN=%ZISY
+ 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))
+ 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.
+ 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.
+ 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) 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
+ ;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 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
+ ;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
+ Q
+L1 I ZISCH="_"!(ZISCH=",") S %ZISYY=%ZISYY_"_" Q
+ I ZISCH=ZISQ D QUOTE Q
+ I ZISCH="$" D DOLR Q
+ I ZISCH="*" D STAR Q
+ I ZISCH="(" D PAREN Q
+ 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
+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
+ S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH'=""&(ZISCH'=",") ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_ZISNUM_")",ZISXL=ZISXL-1 Q
+ 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.
+ 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
+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
+S1 I ZISCH=ZISQ D QUOTE Q
+ I ZISCH="$" D DOLR Q
+ I ZISCH="(" D PAREN Q
+ S %ZISYY=%ZISYY_ZISCH Q
+ ;
+S2 ;MERGE $C
+ S %ZISX1=$E(%ZISX1,1,$L(%ZISX1)-1),%ZISX2=","_$E(%ZISX2,4,$L(%ZISX2))
+ S $P(%ZISXX,"_",I,I+1)=%ZISX1_%ZISX2
+ N I D L2
+ Q
Index: WorldVistAEHR/trunk/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
===================================================================
--- WorldVistAEHR/trunk/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	(revision 613)
+++ WorldVistAEHR/trunk/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	(revision 623)
@@ -1,60 +1,57 @@
-%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()
-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 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 %ZTVOL=^%ZOSF("VOL")
-	I $D(ZTCPU)[0 S ZTCPU=%ZTVOL
-	I ZTCPU="" S ZTCPU=%ZTVOL
-	I ZTCPU'=%ZTVOL G THERE
-	;
-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
-	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 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
-	I ZTSK(0)]"" K ZTSK("E") Q
-	I ZTSK("E")'="U" Q
-	S ZTSK("E",0)=$$EC^%ZOSV
-	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
-	S %ZTCPU=$O(^%ZIS(14.5,"B",ZTCPU,""))
-	I %ZTCPU="" S ZTSK("E")="IS" G QUIT
-	S %ZTM=$P(^%ZOSF("MGR"),",")
-	S %ZTM=$S($D(^%ZIS(14.5,%ZTCPU,0))[0:%ZTM,$P(^(0),U,6)="":%ZTM,1:$P(^(0),U,6))
-	S X=%ZTM,Y=ZTCPU
-	S ZTSK("E")="LS",ZT=$D(^[X,Y]%ZTSK(0)),ZTSK("E")="U" ; check link
-	;
-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)
-	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 ZTSK(0)=0 G QUIT
-	;
+%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
+ I $D(ZTSK)[0 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",X="QUIT^%ZTLOAD3",@^%ZOSF("TRAP")
+ S %ZTVOL=^%ZOSF("VOL")
+ I $D(ZTCPU)[0 S ZTCPU=%ZTVOL
+ I ZTCPU="" S ZTCPU=%ZTVOL
+ I ZTCPU'=%ZTVOL G THERE
+ ;
+HERE ;lookup task's status on current volume set
+ 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 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
+ I ZTSK(0)]"" K ZTSK("E") Q
+ I ZTSK("E")'="U" Q
+ S ZTSK("E",0)=$$EC^%ZOSV
+ Q
+ ;
+THERE ;rest of code looks up task's status on some other volume set
+ ;
+FILES ;find TaskMan files on the volume set to be searched
+ S %ZTCPU=$O(^%ZIS(14.5,"B",ZTCPU,""))
+ I %ZTCPU="" S ZTSK("E")="IS" G QUIT
+ S %ZTM=$P(^%ZOSF("MGR"),",")
+ S %ZTM=$S($D(^%ZIS(14.5,%ZTCPU,0))[0:%ZTM,$P(^(0),U,6)="":%ZTM,1:$P(^(0),U,6))
+ S X=%ZTM,Y=ZTCPU
+ S ZTSK("E")="LS",ZT=$D(^[X,Y]%ZTSK(0)),ZTSK("E")="U" ; check link
+ ;
+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=$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 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
+ ;
