2:00 PM  6-JUL-98

XBCSPC
XBCSPC ; IHS/ADC/GTH - CHECK POTENTIAL SPECIFIER FIELDS ; [ 11/04/97  10:26 AM ]
 ;;3.0;IHS/VA UTILITIES;**5**;FEB 07, 1997
 ; XB*3*5 IHS/ADC/GTH 10-30-97 Fix bug in count of duplicate values.
 ;
 ; This routine checks selected field to see what percent of
 ; the time it exists in the entries in a file, and if it
 ; should be unique, it makes sure it is unique.
 ;
START ;
 NEW CTRD,CTRT,CTRU,CTRX,ENTRY,FGBL,FIELD,FILE,NODE,PIECE,UNIQUE,XREF
 D ^XBKVAR
 F  D FILE Q:Y<1
 D EOJ
 Q
 ;
FILE ;
 W !
 I '$G(EXTERNAL) D  Q:Y<1
 . S DIC=1,DIC(0)="AEMQ"
 . D ^DIC
 . KILL DIC
 . Q:Y<1
 . S FILE=+Y
 .Q
 S FGBL=^DIC(FILE,0,"GL"),X=$O(@(FGBL_"0)"))
 I X'=+X W "  No data in file",*7 Q
 F  D FIELD Q:Y<0
 S Y=1
 Q
 ;
FIELD ;
 I '$G(EXTERNAL) D  Q:Y<0
 . S DIC="^DD("_FILE_",",DIC(0)="AEMQ"
 . D ^DIC
 . KILL DIC
 . Q:Y<0
 . S FIELD=+Y
 .Q
 D FLD^XBFDINFO(FILE,FIELD,.X)
 I '$D(X("NODE")) W *7 Q
 I X("NODE")="" W *7 Q
 S NODE=X("NODE"),PIECE=X("PIECE")
 KILL DIRUT,X
 I '$G(EXTERNAL) S UNIQUE=$$DIR^XBDIR("YO","Should field be unique","NO")
 Q:$D(DIRUT)
 D:UNIQUE CHKXREF
 D CHKDATA
 D LIST
 S:$G(EXTERNAL) Y=-1
 Q
 ;
LIST ;
 W !!,CTRT," entries in file.",!,$FN(CTRD/CTRT*100,"T",2)," percent of entries have data.  ",$S(CTRT'=CTRD:CTRT-CTRD_" without data.",1:"")
 I UNIQUE,XREF'="" D
 . I CTRX=0 W !,"All entries with data have xref."
 . E  W !,CTRD-CTRX," entr",$S(CTRD-CTRX=1:"y",1:"ies"),", ",$FN(CTRX/CTRD*100,"T",2)," percent of entries with data have no xref."
 . Q
 I UNIQUE D
 . I CTRU=0 W !,"All ",$P(^DD(FILE,FIELD,0),U,1)," field values are unique."
 . E  W !,CTRU,$S(CTRU=1:" entry has a value that is ",1:" entries have values that are "),"not unique."
 . I '$G(EXTERNAL),CTRU W !,"If you want to see duplicate values select global ^TMP(""XBCSPC"",",$J,"," KILL ^TMP("XBCSPC",$J,1) D ^%G
 . Q
 W !
 Q
 ;
CHKXREF ; SEE IF UNIQUE SPECIFIER HAS REGULAR XREF
 Q:$G(XREF)'=""
 S XREF=""
 D XREF^XBGXREFS(FILE,FIELD,.X)
 F I=0:0 S I=$O(X(FIELD,I)) Q:I'=+I  I $P(X(FIELD,I),"^",3)="" S XREF=$P(X(FIELD,I),"^",2),XREF=""""_XREF_"""" Q
 KILL X
 I 'I W !,"The ",FIELD," field does not have a REGULAR xref."
 E  W !,"Using the ",XREF," xref on the ",FIELD," field."
 Q
 ;
CHKDATA ; CHECK DATA IN SELECTED FIELD
 W !,"Checking data.  Please wait. "
 KILL ^TMP("XBCSPC",$J)
 S (CTRT,CTRD,CTRU,CTRX)=0
 F ENTRY=0:0 S ENTRY=$O(@(FGBL_ENTRY_")")) Q:ENTRY'=+ENTRY  D
 . S CTRT=CTRT+1
 . Q:'$D(@(FGBL_ENTRY_","_NODE_")"))
 . S X=$P(@(FGBL_ENTRY_","_NODE_")"),"^",PIECE)
 . Q:X=""
 . S CTRD=CTRD+1
 . I UNIQUE,XREF'="",'$D(@(FGBL_XREF_","""_X_""","_ENTRY_")")) S CTRX=CTRX+1
 . I UNIQUE D
 .. ; I $D(^TMP("XBCSPC",$J,1,X)) S CTRU=CTRU+1,^TMP("XBCSPC",$J,2,X)=cCTRX ; XB*3*5 IHS/ADC/GTH 10-30-97 Fix bug in count of duplicate values.
 .. I $D(^TMP("XBCSPC",$J,1,X)) S CTRU=CTRU+1,^(X)=$S($G(^TMP("XBCSPC",$J,2,X)):^(X)+1,1:2) ; XB*3*5 IHS/ADC/GTH 10-30-97 Fix bug in count of duplicate values.
 .. E  S ^TMP("XBCSPC",$J,1,X)=0
 .. Q
 . Q
 Q
 ;
EN(FILE,FIELD,XREF,UNIQUE) ; EXTERNAL ENTRY POINT TO ALLOW SPECIFID FILE/FIELD
 ; pass by value  *** will abort if values not passed ***
 NEW CTRD,CTRT,CTRU,CTRX,ENTRY,EXTERNAL,FGBL,NODE,PIECE
 S EXTERNAL=1
 I FILE,FIELD,XREF'="",UNIQUE'=""
 E  Q
 S XREF=""""_XREF_""""
 D FILE
 KILL DIRUT,I,X,Y
 Q
 ;
EOJ ;
 KILL DIRUT,I,X,Y
 KILL ^TMP("XBCSPC",$J)
 Q
 ;

XBDBQUE
XBDBQUE ; IHS/ADC/GTH - DOUBLE QUEUING SHELL HANDLER ;  [ 11/04/97  10:26 AM ]
 ;;3.0;IHS/VA UTILITIES;**5**;FEB 07, 1997
 ; XB*3*5 - IHS/ADC/GTH 10-31-97
 ; Thanks to Paul Wesley, DSD, for the original routine.
 ; ---------------------------------------------------------
 ; |refer to XBDBQDOC for instructions, examples, and tests|
 ; ---------------------------------------------------------
 ;
START ;
 NEW XB ;     use a fresh array in case of nesting double queues
 ;     insure IO array is set fully
 I ($D(IO)'>10) S IOP="HOME" D ^%ZIS
 I $D(ZTQUEUED) S XBFQ=1 S:'$D(XBDTH) XBDTH="NOW" ;     insure auto-requeue if called from a queued
 I '$D(XBRC),'$D(XBRP) Q  ;                             insure one of RC or RP exist
 S XB("IOP1")=ION_";"_IOST_";"_IOM_";"_IOSL ;           store current IO params
 I $G(IOPAR)]"" S XB("IOPAR")=IOPAR ;                   store IOPAR
 I $L($G(XBRC))=0 S XBRC="NORC^XBDBQUE" ;               no compute identified
 S XB("RC")=XBRC,XB("RP")=$G(XBRP),XB("RX")=$G(XBRX)
 ;                                                      load XBNS="xx;yy;.." into XB("NS",xx*) ...
 F XBI=1:1 S XBNSX=$P($G(XBNS),";",XBI) Q:XBNSX=""  S:(XBNSX'["*") XBNSX=XBNSX_"*" S XB("NS",XBNSX)=""
 S XB("NS","XB*")=""
 ;                                                     load XBNS("xxx") array into XB("NS","xxx")
 S XBNSX=""
 F  S XBNSX=$O(XBNS(XBNSX)) Q:XBNSX=""  S XB("NS",XBNSX)=""
 ; if this is a double queue with XB("IOP") setup .. pull the parameters out a ^%ZIS call to set up the parameters without an open
 S XB("IOP")=$G(XBIOP)
 I $D(XBIOP) S IOP=XBIOP
 ; XB*3*5 - IHS/ADC/GTH 10-31-97 start block
 I $G(XB("IOPAR"))]"" S %ZIS("IOPAR")=XB("IOPAR") D
 . I XB("IOPAR")'?1"(""".E1""":""".E1""")" Q  ;                skip HFS if not an HFS
 . S XBHFSNM=$P(XB("IOPAR"),":"),XBHFSNM=$TR(XBHFSNM,"()""")
 . S XBHFSMD=$P(XB("IOPAR"),":",2),XBHFSMD=$TR(XBHFSMD,"()""")
 . S %ZIS("HFSNAME")=XBHFSNM,%ZIS("HFSMODE")=XBHFSMD
 . ;this code drops through
 ; XB*3*5 - IHS/ADC/GTH 10-31-97 end block
ZIS ;
 KILL IO("Q")
 I $G(XBRC)]"",$G(XBRP)="" G ZISQ
 S %ZIS="PQM"
 D ^%ZIS ;                 get parameters without an open
 I POP W !,"REPORTING-ABORTED",*7 G END1
 S XB("IO")=IO,XB("IOP")=ION_";"_IOST_";"_IOM_";"_IOSL,XB("IOPAR")=$G(IOPAR),XB("CPU")=$G(IOCPU),XB("ION")=ION
ZISQ ;
 I '$D(IO("Q")),'$G(XBFQ) D
 . I $D(ZTQUEUED) S XBFQ=1 Q
 . I IO=IO(0),$G(XBRP)]"" Q
 . KILL DIR
 . S DIR(0)="Y",DIR("B")="Y",DIR("A")="Won't you queue this "
 . D ^DIR
 . KILL DIR
 . I X["^" S XBQUIT=1
 . S:Y=1 IO("Q")=1
 . Q
 ;
 KILL XB("ZTSK")
 I $D(ZTQUEUED),$G(ZTSK) S XB("ZTSK")=ZTSK
 KILL ZTSK
 ;  quit if user says so
 I $G(XBQUIT) KILL DIR S DIR(0)="E",DIR("A")="Report Aborted .. <CR> to continue" D ^DIR KILL DIR G END1
 ;
QUE1 ;
 I ($D(IO("Q"))!($G(XBFQ))) D  K IO("Q") W:(($G(ZTSK))&('$D(XB("ZTSK")))) !,"Tasked with ",ZTSK W:'$G(ZTSK) !,*7,"Que not successful ... REPORTING ABORTED" D ^%ZISC S IOP=XB("IOP1") D ^%ZIS G END1 ;--->
 . I '$D(ZTQUEUED),IO=IO(0),$G(XBRP)]"" W !,"Queing to slave printer not allowed ... Report Aborting" Q  ;---^
 . S ZTDESC="Double Que COMPUTing  "_XBRC_"  "_$G(XBRP),ZTIO="",ZTRTN="DEQUE1^XBDBQUE"
 . S:$D(XBDTH) ZTDTH=XBDTH
 . S:$G(XB("CPU"))]"" ZTCPU=XB("CPU")
 . S XBNSX=""
 . F  S XBNSX=$O(XB("NS",XBNSX)) Q:XBNSX=""  S ZTSAVE(XBNSX)=""
 . KILL XBRC,XBRP,XBRX,XBNS,XBFQ,XBDTH,XBIOP,XBPAR,XBDTH,XBNSX,XBI
 . S ZTIO="" ;                               insure no device loaded
 . D ^%ZTLOAD
 . Q  ; these do .s branch to END1
 ; (((if queued the above code branched to END)))
 ;
DEQUE1 ;> 1st deque
 ;
 KILL XBRC,XBRP,XBRX,XBNS,XBFQ,XBDTH,XBIOP,XBPAR,XBDTH
 KILL XB("ZTSK")
 I $D(ZTQUEUED),$G(ZTSK) S XB("ZTSK")=ZTSK
 ;
COMPUTE ;>do computing | routine
 ;
 D @(XB("RC")) ;  >>>PERFORM THE COMPUTE ROUTINE<<< ;stuffed if not provided with NORC^XBDBQUE
 ;
QUE2 ;
 ;
 I $D(ZTQUEUED) D  G ENDC ;===>    automatically requeue if queued
 . Q:XB("RP")=""
 . S ZTDESC="Double Que PRINT "_XB("RC")_" "_XB("RP"),ZTIO=XB("IO"),ZTDTH=$H,ZTRTN="DEQUE2^XBDBQUE"
 . S XBNSX=""
 . F  S XBNSX=$O(XB("NS",XBNSX)) Q:XBNSX=""  S ZTSAVE(XBNSX)=""
 . D SETIOPN K ZTIO
 . D ^%ZTLOAD
 . I '$D(ZTSK) S XBERR="SECOND QUE FAILED" D @^%ZOSF("ERRTN") Q
 . S XBDBQUE=1
 . Q  ;                     ======>         this branches to ENDC
 ;
 ; device opened from the first que ask
DEQUE2 ;>EP 2nd Deque | printing
 KILL XB("ZTSK")
 I $D(ZTQUEUED),$G(ZTSK) S XB("ZTSK")=ZTSK
 ;open printer device for printing with all selected parameters
 G:(XB("RP")="") END ;---> exit if no print
 ;
 U IO
 D @(XB("RP")) ; >>>PERFORM PRINTING ROUTINE
 ;
 ;--------
END ;>End | cleanup
 ;
 I $G(XB("RX"))'="" D @(XB("RX")) ;   >>>PERFORM CLEANUP ROUTINE<<<
 ;
END0 ;EP - from compute cycle when XB("RP") EXISTS
 I $D(XB("ZTSK")) S XBTZTSK=$G(ZTSK),ZTSK=XB("ZTSK") D KILL^%ZTLOAD K ZTSK S:$G(XBTZTSK) ZTSK=XBTZTSK KILL XBTZTSK
END1 ;EP clean out xb as passed in
 D ^%ZISC
 S IOP=XB("IOP1") ; restore original IO parameters
 D ^%ZIS
 K IOPAR,IOUPAR,IOP
 KILL XB,XBRC,XBRP,XBRX,XBNS,XBFQ,XBDTH,XBIOP,XBPAR,XBDTH,XBERR,XBI,XBNSX,XBQUIT,XBDBQUE
 ;
 Q
ENDC ;EP - end computing cycle
 I $G(XB("RP"))="" G END
 G END0
 ;
 ;----------------
 ;----------------
SUB ;>Subroutines
 ;----------
NORC ;used if no XBRC identified
 Q
 ;
SETIOPN ;EP Set IOP parameters with (N)o open
 Q:'$D(XB("IOP"))
 S IOP=XB("IOP")
 ; XB*3*5 - IHS/ADC/GTH 10-31-97 start block
 I $G(XB("IOPAR"))]"" S %ZIS("IOPAR")=XB("IOPAR") D
 . I XB("IOPAR")'?1"(""".E1""":""".E1""")" Q  ;                skip HFS if not an HFS
 . S XBHFSNM=$P(XB("IOPAR"),":"),XBHFSNM=$TR(XBHFSNM,"()""")
 . S XBHFSMD=$P(XB("IOPAR"),":",2),XBHFSMD=$TR(XBHFSMD,"()""")
 . S %ZIS("HFSNAME")=XBHFSNM,%ZIS("HFSMODE")=XBHFSMD
 . Q
 ; XB*3*5 - IHS/ADC/GTH 10-31-97 end block
 S %ZIS="N"
 D ^%ZIS
 Q

XBDT
XBDT ;IHS/HQW/JDH - date/time utilities ;[ 06/19/1998  11:11 AM ]
 ;;3.0;IHS/VA UTILITIES;**6**;JUNE 17, 1998
 ;             
 ;FISCAL
 ;  usage:  S %=$$FISCAL^XBDT(XBDT,XBFYMTH,XBADJ)
 ;
 ;  Input: (all parameters are optional)
 ;      XBDT Date in either fileman of horlog format.  If not defined,
 ;           default is today.
 ;      XBFYMT Month beginning fiscal year.  The definition of this 
 ;           variable can be assigned in the parameter list.  If it 
 ;           is not and Beginning fiscal year month field in the 
 ;           PCC MASTER CONTROL file is valued for the current locaton,
 ;           its value is used. The default is 10. 
 ;      XBADJ  The value of this variable allows the adjustment of the
 ;             FY value
 ;
 ;   Output: current fiscal year^star date of FY^end date of FY 
 ;
 ;LEAP
 ; input: (optional) date in Fileman, yyyy or horlog
 ; output: boolean 1=yes 0=no
 ; uses algorithm defined for leap year in the RPMS Y2000 Compliance Plan
 ;
FISCAL(XBDT,XBFYMTH,XBADJ) ; return current fiscal year
 ; 
 N %,T,T1,T2,XBFY,XBFYBEG,XBFYEND
 S XBADJ=$G(XBADJ) ; adjustment variable
 S:'$G(XBDT) XBDT=$$NOW^XLFDT
 S:XBDT["," XBDT=$$HTFM^XLFDT(XBDT) ; horolog to fileman
 S T=$P($G(^APCCCTRL(DUZ(2),0)),U,8) ; beg, FY month for location from PCC MASTER CONTROL file
 S:'$G(XBFYMTH) XBFYMTH=$S(T:T,1:10) ; use month entered, as in MSTR file or 10
 S XBFYMTH=$E("0",XBFYMTH<10)_XBFYMTH ; if month is less then 10 make it two digits
 S T1=XBFYMTH-1<$E(XBDT,4,5) ; boolean.  month before or after FY start month
 S T2=XBDT\10000-'T1 ; current year in FM 3 digit year format plus 1 or 0 determined by T1 calculation
 S XBFY=XBDT\10000+T1 ; fiscal Year in external 4 digit format
 S XBFYBEG=T2_XBFYMTH_"01" ; beginning of fiscal year
 S %=T2+1_XBFYMTH_"01"
 S XBFYEND=$$FMADD^XLFDT(%,-1) ;get the beginning date of the fiscal year
 Q XBFY+1700+XBADJ_U_XBFYBEG_U_XBFYEND
 ;
 ;
 ;
LEAP(XBDT) ; is the year a leap year? 
 ;
 S:'$G(XBDT) XBDT=$$NOW^XLFDT
 S:XBDT["," XBDT=$$HTFM^XLFDT(XBDT) ; horolog to fileman
 S:$L(XBDT)>4 XBDT=XBDT\10000+1700 ; 4 digit date
 Q '(XBDT#4)&(XBDT#100)!('(XBDT#100)&'(XBDT#400)) ; leap year algorithm
 ;

XBFIXPT
XBFIXPT ; IHS/ADC/GTH - FIX ALL "PT" NODES ; [ 11/04/97  10:26 AM ]
 ;;3.0;IHS/VA UTILITIES;**5**;FEB 07, 1997
 ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent UNDEF if ^DD entry incorrect.
 ;
 ; This routine fixes all "PT" nodes for files 1 through the
 ; highest file number in the current UCI.
 ;
START ;
 W:'$D(XBFIXPT("NOTALK")) !!,"This routine insures the ""PT"" node of each FileMan file is correct.",!
 W:'$D(XBFIXPT("NOTALK")) !!,"Now checking false positives.",!
 S U="^"
 S XBFFILE=.99999999
 F XBFL=0:0 S XBFFILE=$O(^DD(XBFFILE)) Q:XBFFILE'=+XBFFILE  I $D(^DD(XBFFILE,0,"PT")) W:'$D(XBFIXPT("NOTALK")) !,XBFFILE D FPOS
 W:'$D(XBFIXPT("NOTALK")) !!,"Now checking false negatives.",!
 D FNEG
 KILL XBFFILE,XBFL
 W:'$D(XBFIXPT("NOTALK")) !!,"DONE",!
 Q
 ;
FPOS ; CHECK FOR FALSE POSITIVES
 S XBFPFILE=""
 F XBFL=0:0 S XBFPFILE=$O(^DD(XBFFILE,0,"PT",XBFPFILE)) Q:XBFPFILE=""  S XBFPFLD="" F XBFL=0:0 S XBFPFLD=$O(^DD(XBFFILE,0,"PT",XBFPFILE,XBFPFLD)) Q:XBFPFLD=""  D CHKIT
 KILL XBFPFILE,XBFPFLD,XBFX
 Q
 ;
CHKIT ;
 W:'$D(XBFIXPT("NOTALK")) "."
 I '$D(^DD(XBFPFILE)) W:'$D(XBFIXPT("NOTALK")) "|" KILL ^DD(XBFFILE,0,"PT",XBFPFILE) Q
 ; I '$D(^DD(XBFPFILE,XBFPFLD)) W:'$D(XBFIXPT("NOTALK")) "|" KILL ^DD(XBFFILE,0,"PT",XBFPFILE,XBFPFLD) Q  ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent UNDEF if ^DD entry incorrect.
 I '$D(^DD(XBFPFILE,XBFPFLD,0)) W:'$D(XBFIXPT("NOTALK")) "|" KILL ^DD(XBFFILE,0,"PT",XBFPFILE,XBFPFLD) Q  ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent UNDEF if ^DD entry incorrect.
 S XBFX=$P(^DD(XBFPFILE,XBFPFLD,0),U,2)
 I XBFX["P",XBFX[XBFFILE Q
 I XBFX["V",$D(^DD(XBFPFILE,XBFPFLD,"V","B",XBFFILE)) Q
 W:'$D(XBFIXPT("NOTALK")) "|"
 KILL ^DD(XBFFILE,0,"PT",XBFPFILE,XBFPFLD)
 Q
 ;
FNEG ; CHECK FOR FALSE NEGATIVES
 S XBFFILE=.99999999
 F XBFL=0:0 S XBFFILE=$O(^DD(XBFFILE)) Q:XBFFILE'=+XBFFILE  W:'$D(XBFIXPT("NOTALK")) !,XBFFILE S XBFFLD=0 F XBFL=0:0 S XBFFLD=$O(^DD(XBFFILE,XBFFLD)) Q:XBFFLD'=+XBFFLD  D:$D(^(XBFFLD,0))#2 PTRCHK
 KILL XBFFILE,XBFFLD,XBFX,XBFI
 Q
 ;
PTRCHK ;
 S XBFX=$P(^DD(XBFFILE,XBFFLD,0),U,2)
 I XBFX["V" D PTRCHK2 Q
 Q:XBFX'["P"
 F XBFI=1:1:$L(XBFX)+1 Q:$E(XBFX,XBFI)?1N
 Q:XBFI>$L(XBFX)
 S XBFX=$E(XBFX,XBFI,999),XBFX=+XBFX
 Q:'XBFX
 Q:XBFX<1  ;*** DOES NOT MESS WITH FILE NUMBERS < 1 ***
 W:'$D(XBFIXPT("NOTALK")) "."
 Q:'$D(^DIC(XBFX))
 Q:'$D(^DD(XBFX,0))
 I '$D(^DD(XBFX,0,"PT",XBFFILE,XBFFLD)) W "|" S ^(XBFFLD)=""
 Q
 ;
PTRCHK2 ; VARIABLE POINTER CHECK
 S XBFX=""
 F XBFL=0:0 S XBFX=$O(^DD(XBFFILE,XBFFLD,"V","B",XBFX)) Q:XBFX=""  I '$D(^DD(XBFX,0,"PT",XBFFILE,XBFFLD)) W:'$D(XBFIXPT("NOTALK")) "|" S ^(XBFFLD)=""
 Q
 ;

XBKVAR
XBKVAR ; IHS/ADC/GTH - SET MINIMUM KERNEL VARIABLES ; [ 11/04/97  10:26 AM ]
 ;;3.0;IHS/VA UTILITIES;**5**;FEB 07, 1997
 ; XB*3*5 IHS/ADC/GTH 10-31-97 Correct the setting of DUZ("AG").
 ;
START ;
 S U="^"
 I '$D(DUZ(2)),$D(^AUTTSITE(1,0)) S DUZ(2)=+^(0)
 I '$D(DUZ(2)),$D(^AUTTLOC("SITE")) S DUZ(2)=+^("SITE")
 ; I '$D(DUZ("AG")) S DUZ("AG")=$S($P($G(^XMB(1,0)),"^",8)]"":$P(^XMB(1,0),"^",8),1:"I") ; XB*3*5 IHS/ADC/GTH 10-31-97 Correct the setting of DUZ("AG").
 I '$D(DUZ("AG")) S DUZ("AG")=$S($P($G(^XMB(1,1,0)),"^",8)]"":$P(^XMB(1,1,0),"^",8),1:"I") ; XB*3*5 IHS/ADC/GTH 10-31-97 Correct the setting of DUZ("AG").
 S:'($D(DUZ)#2) DUZ=0
 S:'($D(DUZ(0))#2) DUZ(0)=""
 S:'($D(DUZ(2))#2) DUZ(2)=0
 I '$D(DT) S DT=($$HTFM^XLFDT($H)\1)
 S:'$D(DTIME) DTIME=999
 KILL %,%H,%I
 Q
 ;

XBLM
XBLM ; IHS/ADC/GTH - LIST MANAGER API'S ;  [ 07/01/1998  7:28 AM ]
 ;;3.0;IHS/VA UTILITIES;**5,6**;JUNE 18 1998
 ; XB*3*5,6 IHS/ADC/GTH 10-31-97 Use %ZIS to open HF vs $$OPEN^%ZISH
 ;
 ; Documentation APIs for XBLM Generic Display.
 ;
 ; This utility uses the Veterans Administration List Manager
 ; (VALM).
 ;
 ; APIs
 ;
 ; FILE^XBLM("Directory","File Name")
 ;     Displays file indicated.
 ;
 ; SFILE^XBLM
 ;     Selection of host file for display.
 ;
 ; VIEWR^XBLM("TAG^ROUTINE","Header")
 ;     Displays printout of the routine. (non - FM, using IO)
 ;
 ; VIEWD^XBLM("Tag^Routine","Header")
 ;     Displays printout of the routine. (FM - using EN1^DIP)
 ;
 ; DIQ^XBLM("DIC","DA")
 ;     Displays EN1^DIQ for the DIC,DA.
 ;
 ; ARRAY^XBLM("array(","Header")
 ;     Displays the array(..,n,0) (%RCR notation)
 ;
 ; >>GUI<<                                      
 ;
 ; GUIR^XBLM("TAG^ROUTINE","root(")
 ;     Returns the hard coded output in the array specified.
 ;     "(" not required.
 ;
 ; GUID^XBLM("TAG^ROUTINE","root(")
 ;     Returns the output of the FM routine specified in the
 ;     array specified.  Most often the call is "EN1^DIP".
 ;                                          
 ; S XBGUI=1,XBY="root(" D entry_point^XBLM    
 ;     The entry points sense these two variables and will
 ;     put the output into the array specified.
 ;
EN ;EP -- main entry point for XB DISPLAY
 D EN^VALM("XB DISPLAY")
 Q
 ;
HDR ;EP -- header code
 I XBHDR]"" S VALMHDR(1)=XBHDR
 Q
 ;
INIT ;EP -- init variables and list array
MARKERS ;
 I $G(XBLMMARK) F I=10:10 Q:'$D(@VALMAR@(I))  D
 . F J=10:10:80 D CNTRL^VALM10(I,J,1,IORVON,IORVOFF)
 .Q
 KILL XBLMMARK
 S VALMCNT=$O(^TMP("XBLM",$J,XBNODE,""),-1)
 Q
 ;
HELP ;EP -- help code
 S X="?"
 D DISP^XQORM1
 W !!
 Q
 ;
EXIT ;EP -- exit code
 KILL ^TMP("XBLM",$J,XBNODE)
K ;
 KILL XBAR,XBDIR,XBFL,XBFN,XBHDR,XBI,XBROU,XBDIR
 I '$G(XQORS) D CLEAR^VALM1
 K IOPAR,IOUPAR
 Q
 ;
EXPND ;EP -- expand code
 Q
 ;
FILE(XBDIR,XBFN) ;PEP - pull up a file into the TMP global for display
 ;      or into an array for GUI (see GUIR and GUID entry points)
 I '$D(XBHDR) S XBHDR=""
 NEW Y,X,I,XBNODE
 S XBNODE=$G(XQORS)+1
 ;S Y=$$OPEN^%ZISH(XBDIR,XBFN,"M")
 ;open hfs with zis
 D DF^%ZISH(.XBDIR)
 ;
 ; IHS/ADC/GTH XB*3*5 start of open HF change 
 KILL %ZIS
 I ('$D(^%ZIS(1,"B","XBLM HF DEVICE")))!('$D(^%ZIS(2,"B","P-XBLM"))) D ^XBLMSET
 S IOP="XBLM HF DEVICE",%ZIS("HFSMODE")="R",%ZIS("HFSNAME")=XBDIR_XBFN
 D ^%ZIS
 I POP W !,*7,"CANNOT OPEN (OR ACCESS) FILE '",XBDIR,XBFN,"'." S Y=$$DIR^XBDIR("E") G EFILE
 KILL ^TMP("XBLM",$J,XBNODE)
 F I=1:1 U IO R X:DTIME S:($L(X)>250) X=$E(X,1,250) S X=$$STRIP(X) S ^TMP("XBLM",$J,XBNODE,I,0)=X Q:$$STATUS^%ZISH
 D ^%ZISC
 ; IHS/ADC/GTH XB*3*5 END of open HF change 
 ;
 I $G(XBGUI) D  KILL ^TMP("XBLM",$J,XBNODE) Q
 . S I=0
 . S XBY=$$OPENROOT(XBY)
 . F  S I=$O(^TMP("XBLM",$J,XBNODE,I)) Q:'+I  S XBZ=XBY_"I)",@XBZ=^TMP("XBLM",$J,XBNODE,I,0)
 .Q
 D EN^XBLM
 KILL ^TMP("XBLM",$J,XBNODE)
EFILE ;
 Q
 ;
SFILE ;PEP - Select a host file for display.
OPEN ;
 S IOP="HOME"
 D ^%ZIS,DT^DICRW,^XBCLS
 W !!,"Select a Directory and File",!!
 S Y=$$PWD^%ZISH(.XBDIR),XBDIR=XBDIR(1)
 KILL DIR
 S DIR(0)="F^1:30",DIR("A")="Directory ",DIR("B")=XBDIR
 K XBDIR
 D ^DIR
 KILL DIR
 Q:$G(DTOUT)
 Q:Y["^"
 S XBDIR=Y
FNAME ;PEP - Select a file (directory can be pre-loaded into XBDIR)
 KILL DIR
FNAME1 ;
 S DIR(0)="FO^1:15",DIR("A")="File Name "
 D ^DIR
 KILL DIR
 Q:$G(DTOUT)
 G:Y["^" OPEN
 G:Y="" OPEN
 I Y?.N,$D(XBFL(Y)) S DIR("B")=XBFL(Y) G FNAME1
 I Y["*" K XBFL S X=$$LIST^%ZISH(XBDIR,Y,.XBFL) D  G FNAME
 . F XBI=1:1 Q:'$D(XBFL(XBI))  W !?5,XBI,?10,XBFL(XBI) I '(XBI#20) R X:DTIME
 .Q
 S XBFN=Y
 ;S X=$$OPEN^%ZISH(XBDIR,XBFN,"M")
 ;open hfs with zis
 D DF^%ZISH(.XBDIR)
 ;
 ; IHS/ADC/GTH XB*3*5 start of open HF change 
 KILL %ZIS
 I ('$D(^%ZIS(1,"B","XBLM HF DEVICE")))!('$D(^%ZIS(2,"B","P-XBLM"))) D ^XBLMSET
 S IOP="XBLM HF DEVICE",%ZIS("HFSMODE")="R",%ZIS("HFSNAME")=XBDIR_XBFN
 D ^%ZIS
ES ;
 I POP W !,"error on open of file ",XBDIR,XBFN,! S Y=$$DIR^XBDIR("E") Q:Y=1  G FNAME
 D ^%ZISC
 D FILE^XBLM(XBDIR,XBFN)
 K XBFN
ESFILE ;
 G FNAME
 Q
 ;
VIEWR(XBROU,XBHDR) ;PEP ** USING XBROU print to a host file for viewing
 I '$D(XBHDR) S XBHDR=""
 I +$G(IO(0)) U IO(0) D:'$G(XBGUI) WAIT^DICD
 S Y=$$PWD^%ZISH(.XBDIR)
 S XBDIR=XBDIR(1),XBFN="XB"_$J
 ;open hfs with zis
 D DF^%ZISH(.XBDIR)
 K %ZIS
 S XBIOM=IOM
 I ('$D(^%ZIS(1,"B","XBLM HF DEVICE")))!('$D(^%ZIS(2,"B","P-XBLM"))) D ^XBLMSET
 S IOP="XBLM HF DEVICE;"_IOM_";6000"
 S %ZIS("HFSMODE")="W",%ZIS("HFSNAME")=XBDIR_XBFN
 D ^%ZIS
 U IO
 K DX ;IHS/JDH 6/17/98 prevent <MODER> if defined when DIQ is called
 D @XBROU
 D ^%ZISC,HOME^%ZIS
 D FILE^XBLM(XBDIR,XBFN)
 S X=$$DEL^%ZISH(XBDIR,XBFN)
 S IOM=XBIOM
 KILL XBDIR,XBFN,XBHDR,XBNODE,XBDIR,XBFN,XBIOM
 ; IHS/ADC/GTH XB*3*5 END of open HF change 
 ;
 Q
 ;
GUIR(XBROU,XBY) ;PEP - give routine and target array
 Q:$L(XBY)=0
 ;
 S XBGUI=1
 D VIEWR^XBLM(XBROU,"")
 KILL XBGUI,XBY
 Q
 ;
GUID(XBROU,XBY) ;PEP give routine and target array for FM prints
 Q:$L(XBY)=0
 S:XBY["(" XBY=$P(XBY,"(")
 S XBGUI=1
 D VIEWD^XBLM(XBROU,"")
 KILL XBGUI,XBY
 Q
 ;
VIEWD(XBROU,XBHDR) ;PEP ** USING XBROU print to a host file for viewing
 S:'$D(XBHDR) XBHDR=""
 I +$G(IO(0)) I '$G(XBGUI) U IO(0) D WAIT^DICD
 S XBFN="XB"_$J,Y=$$PWD^%ZISH(.XBDIR),XBDIR=XBDIR(1)
 ;S X=$$OPEN^%ZISH(XBDIR,XBFN,"W"),IOP=IO_";P-OTHER;"_IOM_";"_IOSL
 ;open hfs with zis
 D DF^%ZISH(.XBDIR)
 ;
 ; IHS/ADC/GTH XB*3*5 start of open HF change 
 KILL %ZIS
 S XBIOM=IOM
 I ('$D(^%ZIS(1,"B","XBLM HF DEVICE")))!('$D(^%ZIS(2,"B","P-XBLM"))) D ^XBLMSET
 S IOP="XBLM HF DEVICE;"_IOM_";6000"
 S %ZIS("HFSMODE")="W",%ZIS("HFSNAME")=XBDIR_XBFN
 D ^%ZIS
 D @XBROU
 K DX ;IHS/JDH 6/17/98 prevent <MODER> if defined when DIQ is called
 D ^%ZISC,HOME^%ZIS
 D FILE^XBLM(XBDIR,XBFN)
 S X=$$DEL^%ZISH(XBDIR,XBFN)
 S IOM=XBIOM
 KILL XBDIR,XBFN,XBNODE,XBDIR,XBFN,XBIOM
 ; IHS/ADC/GTH XB*3*5 END of open HF change 
 ;
 Q
 ;
DIQ(DIC,DA) ;PEP - Display DIC and DA after call to EN^DIQ
 S IOSTO=IOST,IOST="P-DEC",IOSLO=IOSL,IOSL=6000
 I DIC=+DIC S DIC=$$DIC^XBDIQ1(DIC)
 I DA'=+DA D PARSE^XBDIQ1(DA)
 NEW DIQ,DR
 S DIQ(0)="C"
 D VIEWR^XBLM("EN^DIQ")
 S IOST=IOSTO
 KILL IOSTO
 S IOSL=IOSLO
 KILL IOSLO,XBNODE,XBDIR,XBFN
 Q
 ;
ARRAY(XBAR,XBHDR) ;PEP  Display an array that has (...,n,0) structure
 I '$D(XBHDR) S XBHDR=""
 NEW Y,X,I,XBNODE
 S XBNODE=$G(XQORS)+1
 KILL ^TMP("XBLM",$J,XBNODE)
 S %X=XBAR,%Y="^TMP(""XBLM"","_$J_","_XBNODE_","
 D %XY^%RCR,EN^XBLM
 KILL ^TMP("XBLM",$J,XBNODE),XBNODE,XBDIR,XBFN
ARRAYE ;
 Q
 ;
STRIP(Z) ;REMOVE CONTROLL CHARACTERS
 NEW I
 F I=1:1:$L(Z) I (32>$A($E(Z,I))) S Z=$E(Z,1,I-1)_" "_$E(Z,I+1,999)
 Q Z
 ;
OPENROOT(XBY) ;EP - return OPen RooT form of XBY .. for %RCR use
 NEW L
 S L=$L(XBY)
 I XBY["(",$E(XBY,L)="," G CONT
 I XBY'["(" S XBY=XBY_"(" G CONT
 I XBY["(",$E(XBY,L)=")" S XBY=$E(XBY,1,L-1)_"," G CONT
CONT ;
 Q XBY
 ;

XBLMSET
XBLMSET ;IHS/ADC/PDW - setup XBLM terminal subtype & XBLM HF DEVICE for XBLM  [ 11/04/97  10:26 AM ]
 ;;3.0;IHS/VA UTILITIES;**5**;FEB 07, 1997
 ;;
 I '$D(DUZ) D ^XUP
TERM ;SETUP TERMINAL SUBTYPE "P-XBLM"
 K DIC
 S DIC=$$DIC^XBDIQ1(3.2)
 S X="P-XBLM",DIC(0)="XL"
 D ^DIC
 I Y'>0 W !,"ERROR IN SELECTION OF TERMINAL SUBTYPE",! Q
 S DA=+Y
 D TERMDR
 S DIE=DIC D ^DIE
 S XBTERDA=DA
 ;
DEV ; SETUP device
 K DIC
 S DIC=$$DIC^XBDIQ1(3.5)
 S X="XBLM HF DEVICE",DIC(0)="XL" D ^DIC
 I Y'>0 W !,"ERROR IN DEVICE SELECTION" Q
 S DA=+Y
 D DEVDR
 S DIE=$$DIC^XBDIQ1(3.5)
 D ^DIE
 S XBDEVDA=DA
 ;D DIQ^XBLM(3.2,XBTERDA)
 ;D DIQ^XBLM(3.5,XBDEVDA)
 Q
TERMDR ;;EP
 ;;~.02///^S X="NO";~
 ;;~1///^S X=255;~
 ;;~2///^S X="#";~
 ;;~3///3000;~
 ;;~4///^S X="$C(8)";~
 ;;~99///^S X="Host File for XBLM utility"~
 ;;~END~
 S DR=""
 F I=1:1 S X=$P($T(TERMDR+I),"~",2) Q:X["END"  S DR=DR_X
 Q
DEVDR ;;
 ;;~.02///^S X="HOST FILE FOR XBLM";~
 ;;~1///^S X=51;~
 ;;~1.9///@;~
 ;;~1.95///^S X="NO";~
 ;;~2///^S X="HOST FILE SERVER";~
 ;;~3///^S X="P-XBLM";~
 ;;~4///^S X="NO";~
 ;;~5///^S X="NO";~
 ;;~5.1///^S X="NO";~
 ;;~5.2///^S X="NO";~
 ;;~11.2///^S X="YES";~
 ;;~END~
 S DR=""
 F I=1:1 S X=$P($T(DEVDR+I),"~",2) Q:X["END"  S DR=DR_X
 Q

XBP5
XBP5 ; IHS/ADC/GTH - XB/ZIB V 3.0 PATCH 5 ; [ 07/06/1998  1:57 PM ]
 ;;3.0;IHS/VA UTILITIES;**5**;FEB 07, 1997
 ;
 I '$G(DUZ) W !,"DUZ UNDEFINED OR ZERO.",! Q
 D HOME^%ZIS,DT^DICRW,HELP("INTRO")
 S Y=$$DIR^XBDIR("Y","Do you want to queue the upgrade to TaskMan","Y","","","^D HELP^XBP5(""Q2"")",2)
 I $D(DIRUT) Q
 G START:'Y
QUE ;
 S %DT="AERSX",%DT("A")="Requested Start Time: ",%DT("B")="T@2015",%DT(0)="NOW"
 D ^%DT
 I Y<1 W !,"QUEUE INFORMATION MISSING - NOT QUEUED" G XBP5
 S X=+Y
 D H^%DTC
 S ZTDTH=%H_","_%T
 S ZTRTN="START^XBP5",ZTIO="",ZTDESC=$P($P($T(+1),";",2)," ",4,99)
 D ^%ZTLOAD,HOME^%ZIS
 I $D(ZTSK) W !!,"QUEUED TO TASK ",ZTSK,!!,"A mail message with the results will be sent to your MailMan 'IN' basket.",!
 E  W !!,*7,"QUEUE UNSUCCESSFUL.  RESTART UTILITY."
 Q
 ;
START ;EP - From Taskman
 ;
 D MAIL^XBMAIL("XUMGR-XUPROGMODE","DESC^XBP5")
 I $D(ZTQUEUED) S ZTREQ="@"
 E  W !!,"You're done.  You may delete this routine.",!
 Q
 ;
HELP(L) ;EP - Display text at label L.
 W !
 F %=1:1 W !?4,$P($T(@L+%),";",3) Q:$P($T(@L+%+1),";",3)="###"
 Q
 ;
INTRO ;
 ;;This is Patch 5 to XB/ZIB utilities.  Please see the routines of the
 ;;patch for complete descriptions of the upgrades.  This patch
 ;;generates a mail message to everyone on your local machine that holds
 ;;the XUMGR, XUPROG, or XUPROGMODE security key.  The mail message
 ;;informs the users that the upgrade has been installed, and describes
 ;;the changes in greater detail.
 ;;###
 ;
Q2 ;
 ;;Answer "Y" if you want to queue this announcement to TaskMan.
 ;;Answer "N" if you want to run the announcement immediately.
 ;;
 ;;If you run interactively, a mail message with the description of this
 ;;upgrade will be delivered to those users holding the XUMGR, XUPROG, or
 ;;XUPROGMODE security key, now.  If you q the announcement to TaskMan,
 ;;the mail message will be delivered when TaskMan runs the task.
 ;;###
 ;
DESC ;
 ;;XB/ZIB v 3.0, Patch 5 Announcement.
 ;;  
 ;;+++++++++++++++ XB/ZIB 3.0 Patch 5 Announcement +++++++++++++++++
 ;;+     This mail message has been delivered to all local         +
 ;;+ users that hold an XUMGR, XUPROG, or XUPROGMODE security key. +
 ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 ;;  
 ;;Please direct your questions or comments about RPMS software to:
 ;;            OIRM / DSD (Division of Systems Development)
 ;;            5300 Homestead Road NE
 ;;            Albuquerque NM  87110
 ;;            505-248-4191
 ;;  
 ;;-----------------------------------------------------------------
 ;;  
 ;;(1) XBLM OPEN EXECUTES AND IOM VALUES.
 ;;$$OPEN^%ZISH can open host devices with unfriendly open executes.
 ;;Similar to the MESSAGE and BROWSER Device, XBLM HF DEVICE is
 ;;added to be used for functions.
 ;;  NOTE:  Kernel team has a concurrent patch release planned.
 ;;         In agreement with the Kernel support team, if the K8
 ;;         patch is not installed, XBLM will sense the lack of
 ;;         an appropriate device and will set it up.
 ;;When XBLM is exited, IOM has been set to 80, which can cause a
 ;;problem within Screenman calls to XBLM. (A recent link developed
 ;;by TUCSON.)  XBLM is recoded and now the existing IOM is used for
 ;;the host file open parameter and is restored when returning to
 ;;the calling application.
 ;;  
 ;;-----------------------------------------------------------------
 ;;  
 ;;(2) XBDBQUE - DOUBLE QUEING TO IP PRINTERS.
 ;;There has been a problem with doublequeing to printers that are
 ;;accessed using IP.  The IO parameters for IP printers are a
 ;;combination that were not anticipated in doublequeing.  XBDBQUE
 ;;was recoded to include the new combination of parameters.
 ;;  
 ;;-----------------------------------------------------------------
 ;;  
 ;;(3) XBFIXPT can abort because of a missing ^DD node.  This patch
 ;;adds $DATA protection for programmers.
 ;;  THANKS TO DON ENOS FOR FINDING, REPORTING, AND FIXING THE BUG.
 ;;  
 ;;-----------------------------------------------------------------
 ;;  
 ;;(4) XBCSPC had a bug resulting in the count of the number of
 ;;duplicate values for a particular value being wrong.  This patch
 ;;fixes the count.
 ;;  THANKS TO DON ENOS FOR FINDING, REPORTING, AND FIXING THE BUG.
 ;;  
 ;;-----------------------------------------------------------------
 ;;  
 ;;(5) XBVK expects "MSM" to be the first "-" piece of the first "^"
 ;;piece of the ^%ZOSF("OS") node.  Micronetic's implementation of
 ;;MSM on an NT platform departs from that de facto standard,
 ;;resulting in an <INDIR>.  This patch fixes the to look for "MSM"
 ;;in the first "^" piece of ^%ZOSF("OS").
 ;;  
 ;;-----------------------------------------------------------------
 ;;  
 ;;(6) XBKVAR had an incorrect reference to ^XMB(1,0), which should
 ;;have been ^XMB(1,1,0), sometimes resulting in DUZ("AG") being set
 ;;to null.  This patch the reference.
 ;;  
 ;;-----------------------------------------------------------------
 ;;  
 ;;++++++++++++++++++++ end of Patch 5 announcement ++++++++++++++++
 ;;###
 ;

XBP6
XBP6 ; IHS/ADC/GTH - XB/ZIB V 3.0 PATCH 6 ; [ 07/02/1998  8:11 AM ]
 ;;3.0;IHS/VA UTILITIES;**6**;FEB 07, 1997
 ;
 I '$G(DUZ) W !,"DUZ UNDEFINED OR ZERO.",! Q
 D HOME^%ZIS,DT^DICRW,HELP("INTRO")
 S Y=$$DIR^XBDIR("Y","Do you want to queue the upgrade to TaskMan","Y","","","^D HELP^XBP6(""Q2"")",2)
 I $D(DIRUT) Q
 G START:'Y
QUE ;
 S %DT="AERSX",%DT("A")="Requested Start Time: ",%DT("B")="T@2015",%DT(0)="NOW"
 D ^%DT
 I Y<1 W !,"QUEUE INFORMATION MISSING - NOT QUEUED" G XBP6
 S X=+Y
 D H^%DTC
 S ZTDTH=%H_","_%T
 S ZTRTN="START^XBP6",ZTIO="",ZTDESC=$P($P($T(+1),";",2)," ",4,99)
 D ^%ZTLOAD,HOME^%ZIS
 I $D(ZTSK) W !!,"QUEUED TO TASK ",ZTSK,!!,"A mail message with the results will be sent to your MailMan 'IN' basket.",!
 E  W !!,*7,"QUEUE UNSUCCESSFUL.  RESTART UTILITY."
 Q
 ;
START ;EP - From Taskman
 ;
 D MAIL^XBMAIL("XUMGR-XUPROGMODE","DESC^XBP6")
 I $D(ZTQUEUED) S ZTREQ="@"
 E  W !!,"You're done.  You may delete this routine.",!
 Q
 ;
HELP(L) ;EP - Display text at label L.
 W !
 F %=1:1 W !?4,$P($T(@L+%),";",3) Q:$P($T(@L+%+1),";",3)="###"
 Q
 ;
INTRO ;
 ;;This is Patch 6 to XB/ZIB utilities.  Please see the routines of the
 ;;patch for complete descriptions of the upgrades.  This patch
 ;;generates a mail message to everyone on your local machine that holds
 ;;the XUMGR, XUPROG, or XUPROGMODE security key.  The mail message
 ;;informs the users that the upgrade has been installed, and describes
 ;;the changes in greater detail.
 ;;###
 ;
Q2 ;
 ;;Answer "Y" if you want to queue this announcement to TaskMan.
 ;;Answer "N" if you want to run the announcement immediately.
 ;;
 ;;If you run interactively, a mail message with the description of this
 ;;upgrade will be delivered to those users holding the XUMGR, XUPROG, or
 ;;XUPROGMODE security key, now.  If you q the announcement to TaskMan,
 ;;the mail message will be delivered when TaskMan runs the task.
 ;;###
 ;
DESC ;
 ;;XB/ZIB v 3.0, Patch 6 Announcement.
 ;;  
 ;;+++++++++++++++ XB/ZIB 3.0 Patch 6 Announcement +++++++++++++++++
 ;;+     This mail message has been delivered to all local         +
 ;;+ users that hold an XUMGR, XUPROG, or XUPROGMODE security key. +
 ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 ;;  
 ;;Please direct your questions or comments about RPMS software to:
 ;;            OIRM / DSD (Division of Systems Development)
 ;;            5300 Homestead Road NE
 ;;            Albuquerque NM  87110
 ;;            505-248-4191
 ;;  
 ;;-----------------------------------------------------------------
 ;;  
 ;;(1) XBLM Was modified to correct a potential <MODER> when the 
 ;;routine calls DIQ when DX(0) contains a call to DIR and IO is open
 ;;for read.
 ;;  
 ;;-------------------------------------------------------------------
 ;; 
 ;;(2) XBDT is a new routine with two function calls:  FISCAL and LEAP.
 ;;these functions will provide accurate Y2K compliant values.  The
 ;;documentation is at the beginning of the routine.]
 ;; 
 ;;++++++++++++++++++++ end of Patch 6 announcement ++++++++++++++++
 ;;###
 ;

XBVK
XBVK ; IHS/ADC/GTH - LOCAL VARIABLE KILLER FRONT END ;  [ 11/04/97  10:26 AM ]
 ;;3.0;IHS/VA UTILITIES;**5**;FEB 07, 1997
 ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent INDIR on NT systems.
 ;
 ; This is the front end for killing local variables in the
 ; namespaced parameter.  Implementation specific routines
 ; are called from this routine.  Those routines are in the
 ; ZIBVK* namespace.
 ;
 ; This routine is intended to be called by applications
 ; that are thru executing, in order to KILL any remaining
 ; namespaced local variables.  E.g., D EN^XBVK("AG") will
 ; KILL any local variables that exist in the AG namespace.
 ;
 ; Notice that if called in background, and the OS is not
 ; supported, the routine will quit, unpleasantly.  If your
 ; implementation is other than what is supported, below,
 ; and your vendor has implemented all Type A extensions to
 ; the 1990 ANSI M standard, you can safely remove the two
 ; lines that check for OS, and use the existing call to
 ; the MSM-specific routine.
 ;
 Q
 ;
EN(XBVK) ;PEP - Kill vars in namespace of parameter variable.
 ;
 ; I '$L($T(@$P(^%ZOSF("OS"),"-",1))) W !,*7,"OPERATING SYSTEM '",$P(^%ZOSF("OS"),"-",1),"' NOT SUPPORTED." Q  ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent INDIR on NT systems.
 I $P(^%ZOSF("OS"),"^",1)'["MSM" W !,*7,"OPERATING SYSTEM '",$P(^%ZOSF("OS"),"^",1),"' NOT SUPPORTED." Q  ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent INDIR on NT systems.
 ; G @$P(^%ZOSF("OS"),"-",1) ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent INDIR on NT systems.
 ;
MSM ; Micronetics Standard MUMPS.
 D EN^ZIBVKMSM(XBVK)
 Q
 ;

XBVL
XBVL ; IHS/ADC/GTH - LOCAL VARIABLE LISTER FRONT END ; [ 11/04/97  10:26 AM ]
 ;;3.0;IHS/VA UTILITIES;**4**;FEB 07, 1997
 ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
 ;
 ; This is the front end for listing local variables.
 ; Implementation specific routines are called from this
 ; routine.  Those routines are in the ZIBVL* namespace.
 ;
 ; I '$L($T(@$P(^%ZOSF("OS"),"-",1))) W !,*7,"OPERATING SYSTEM '",$P(^%ZOSF("OS"),"-",1),"' NOT SUPPORTED." Q ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
 ; G @$P(^%ZOSF("OS"),"-",1) ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
 I $P(^%ZOSF("OS"),"^",1)["MSM" G MSM ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
 W !,*7,"OPERATING SYSTEM '",$P(^%ZOSF("OS"),"^",1),"' NOT SUPPORTED." ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
 Q  ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
 ;
MSM ; Micronetics Standard MUMPS.
 G ^ZIBVLMSM
 ;
MESSAGE ;EP - Tell user of limitations.
 W !!?5,"DO routine ^XBVL from programmer mode."
 W !?5,"Not all local variables are available thru the XB menu.",!!
 Q
 ;

ZIBGCHAR
ZIBGCHAR ; IHS/ADC/GTH - NONINTERACTIVE MODIFICATIONS OF GLOBAL CHARACTERISTICS ; [ 11/04/97  10:26 AM ]
 ;;3.0;IHS/VA UTILITIES;**4,5**;FEB 07, 1997
 ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
 ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
 ;
 ; Not all capabilities of the implementation-specific global
 ; characteristics routines are reflected in this routine.
 ;
 ; The argument for each entry point is the unsubscripted
 ; name of the global whose characteristics you want to
 ; change, with NO leading circumflex.  
 ;
 ; If the call is successful, 0 is returned.
 ;
 ; If the call is not successful, a positive integer is
 ; returned, and the cause can be retrieved at the ERR()
 ; entry point.
 ;
 ; E.g's: 
 ;          S %=$$NOJOURN^ZIBGCHAR("AUTTSITE")
 ;          I % W !,$$ERR^ZIBGCHAR(%)
 ;
 Q
 ;
KILLOK(ZIBGLOB) ;PEP - Allow kill of global.
 Q $$PROCESS("D","N")
 ;
KILLNO(ZIBGLOB) ;PEP - Prevent kill'ing of global.
 Q $$PROCESS("D","Y")
 ;
JOURN(ZIBGLOB) ;PEP - Set Journaling to ALWAYS.
 Q $$PROCESS("J","A")
 ;
NOJOURN(ZIBGLOB) ;PEP - Set Journaling for global to NEVER.
 Q $$PROCESS("J","N")
 ;
UCIJOURN(ZIBGLOB) ;PEP - Journal when UCI is Journaled.
 Q $$PROCESS("J","U")
 ;
PROCESS(ZIBFLAG,ZIBVAL) ;
 I '$L($G(ZIBGLOB)) Q 1
 I '(ZIBGLOB?1.8U) Q 5
 I '$D(@("^"_ZIBGLOB)) Q 2
 ; NEW O ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
 ; S O=$P(^%ZOSF("OS"),"-",1) ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
 ; I '$L($T(@O)) Q 3 ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
 ; G @O ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
 ; I $P(^%ZOSF("OS"),"^",1)["MSM" G MSM ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
 I $P(^%ZOSF("OS"),"^",1)'["MSM" Q 3  ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
 D MSM
 I '$D(ZTQUEUED) D HOME^%ZIS U IO(0) ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
 Q 0  ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
 ; Q 3  ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err. ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
 ;
MSM ; Micronetics Standard MUMPS.
 I '$L($T(CALL^%GCH)) Q 4
 S:$D(ZTQUEUED) CALL="" ; Tell ^%GCH not to talk if errors.
 KILL O
 NEW (ZIBFLAG,ZIBGLOB,ZIBVAL) ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
 D CALL^%GCH(ZIBFLAG,ZIBGLOB,ZIBVAL)
 KILL CALL
 ; Q 0 ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
 Q  ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
 ;
ERR(Z) ;PEP - Return cause of error.
 Q $P($T(@Z),";;",2)
1 ;;NO GLOBAL SPECIFIED IN PARAMETER
2 ;;GLOBAL DOES NOT EXIST
3 ;;OPERATING SYSTEM NOT SUPPORTED
4 ;;WRONG VERSION OF MSM'S ^%GCH
5 ;;BAD GLOBAL NAME
 ;
 ;
TEST ;    
 NEW AZHB,AZHB1
 F AZHBCTR=1:1 S AZHB=$P($T(DATA+AZHBCTR),";",3) Q:AZHB="###"  D T1(AZHB),T2(AZHB)
 Q
 ;
T1(AZHB) ;
 W !,"No Journaling For '",AZHB,"'"
 S AZHB1=$$NOJOURN(AZHB)
 W ?28," : ",AZHB1
 I AZHB1 W " : ",$$ERR(AZHB1)
 E  W " : <kool>"
 Q
 ;
T2(AZHB) ;
 W !,"No Killing For '",AZHB,"'"
 S AZHB1=$$KILLNO(AZHB)
 W ?28," : ",AZHB1
 I AZHB1 W " : ",$$ERR(AZHB1)
 E  W " : <kool>"
 Q
 ;
DATA ;
 ;;
 ;;FREDDATA
 ;;ACHSDATA
 ;;AUTTSITE
 ;;^AUTTLOC
 ;;jen
 ;;44
 ;;DIC(4,
 ;;###

ZIBRPI
ZIBRPI ; IHS/ADC/GTH - REMOTE PATCH INSTALLATION ; [ 11/04/97  10:26 AM ]
 ;;3.0;IHS/VA UTILITIES;**1,2,3**;FEB 07, 1997
 ; XB*3*1 IHS/ADC/GTH 03-07-97 Correct spelling of uucppublic.
 ; XB*3*2 IHS/ADC/GTH 04-21-97 Correct patch file pattern match.
 ; XB*3*3 IHS/ADC/GTH 04-25-97 Correct patch file name handling.
 ;
 ; For a description of this utility, see the text in routine
 ; ZIBRPI2.
 ;
 ; D = Directory containing patch files
 ; D("OUT") = Directory with results files
 ; E = "Action" routine, named (A/B)9<namespace><patch_number>
 ; F = Name of a file containing a patch
 ; J = Today's Julian date
 ; L = Facility's Pseudo Prefix
 ; N = Namespace derived from the name of the file
 ; O = Operating System, and OS-specific commands
 ; P = PACKAGE file IEN
 ; V = Version derived from the name of the file
 ; W = Work file
 ;
 W !!,"EXECUTION UNAUTHORIZED.",!
 Q
 ;
OPT ;EP - Set option in OPTION file.  Called by a programmer.
 D OPT^ZIBRPI1
 Q
 ;
START ;EP - From TaskMan.
 NEW %ZIS,D,DA,DIC,E,F,I,J,L,N,O,P,POP,V,W,XMSUB,XMTEXT,XMY
 D HFS
 Q:POP
 D OS
 KILL ^TMP($J)
 ; rm xmit files over 2 weeks old.
 S L=$P(^AUTTLOC($P(^AUTTSITE(1,0),U),1),U,2) I '($L(L)=3) S L="RPI"
 D HC(O("LS")_D("OUT")_O("NS")_L_".* > "_W)
 S IOP=I,%ZIS("IOPAR")="("""_W_""":""R"")"
 D ZIS,JDT
 U IO
 ; Comment next line to keep xmit ("rpi") files over 2 wks old.
 F  R %:300 Q:%=""  S %=$P(%,"/",$L(%,"/")),X=+$P(%,".",2) I $P(%,".")=O("NS")_L,((+X>+J)!(+X<(+J-14))) D HC(O("RM")_D("OUT")_%)
 D HC(O("RM")_W)
 ; Initialize namespace, systems, and frequency.
 S %=+$P(^DIC(19,$O(^DIC(19,"B","ZIB REMOTE PATCH INSTALLATION",0)),20)," ",2),D=$P($P(^(20),"""",2),U)
 S:'("/\"[$E(D,$L(D))) D=D_$S(O["UNIX":"/",1:"\")
 D HC(O("LS")_D_"*.*"_" > "_W)
 S IOP=I,%ZIS("IOPAR")="("""_W_""":""R"")"
 D ZIS
 U IO
 ; The Q:%="" in the following line is non-standard MUMPS.
 F  R %:300 Q:%=""  S %=$P(%,"/",$L(%,"/")) I %?@O("PF") S ^TMP($J,"ZIBRPI",%)=""
 S F=""
 I '$L($O(^TMP($J,"ZIBRPI",""))) D ZISC D HC(O("RM")_W) KILL ^TMP($J) S:$D(ZTQUEUED) ZTREQ="@" Q
MAIN ;
 F  S F=$O(^TMP($J,"ZIBRPI",F)) Q:F=""  D  S ^TMP($J,"ZIBRPI",F)=% D:%="INSTALLED" HC(O("RM")_D_F)
 . S X=$E(F,1,4),X=$P(X,"_"),N=$$UP^XLFSTR(X)
 . I '$D(^DIC(9.4,"C",N)) S %="FAILED - Not an Installed Package" Q
 . S P=$O(^DIC(9.4,"C",N,0))
 . I 'P S %="FAILED - Bad ""C"" x-ref for "_N Q
 . I '$D(^DIC(9.4,P,"VERSION")) S %="FAILED - 'VERSION' Node Missing" Q
 . S V=+($E(F,5,6)_"."_$E(F,7,8))
 . I (+V)'=(+^DIC(9.4,P,"VERSION")) S %="FAILED - V "_^("VERSION")_" of "_N_" is Installed" Q
 . ; S E=$S("AB"[$E(N):$E(N),1:"B")_"9"_N_$P($P(F,".",2),"p",2) ; XB*3*3 IHS/ADC/GTH 04-25-97 Correct patch file name handling.
 . S E=$S("AB"[$E(N):$E(N),1:"B")_"9"_N_(+$P($P(F,".",2),"p",1)) ; XB*3*3 IHS/ADC/GTH 04-25-97 Correct patch file name handling.
 . U IO:(D_F)
 . R %:300
 . R %:300
 . ; The ZL and ZS in the following line are non-standard M commands.
 . F  R %:300 Q:%=""  S:%=E ^TMP($J,"B9",%)="" X "ZL  ZS @%"
 . S DA(1)=^DIC(9.4,P,"VERSION"),DA(1)=$O(^DIC(9.4,P,22,"B",DA(1)_$S(DA(1)[".":"",1:".0"),0))
 . I 'DA(1) S DA(1)=$P(^DIC(9.4,P,22,0),U,3)
 . S:'$D(^DIC(9.4,P,22,DA(1),"PAH",0)) ^(0)="^9.4901^^"
 . ; S X=N_"*"_V_"*"_$P($P(F,".",2),"p",2),DIC="^DIC(9.4,"_P_",22,"_DA(1)_",""PAH"",",DIC(0)="",DIC("DR")=".02///"_DT_";.03///.5",DA(2)=P ; XB*3*3 IHS/ADC/GTH 04-25-97 Correct patch file name handling.
 . S X=N_"*"_V_"*"_(+$P($P(F,".",2),"p",1)),DIC="^DIC(9.4,"_P_",22,"_DA(1)_",""PAH"",",DIC(0)="",DIC("DR")=".02///"_DT_";.03///.5",DA(2)=P ; XB*3*3 IHS/ADC/GTH 04-25-97 Correct patch file name handling.
 . D FILE
 . S %="INSTALLED"
 . Q
ENDMAIN ;
 D OS
 S %=0,F="",D=D("OUT")_O("NS")_L_"."_J
 U IO:(D:"W")
 F  S F=$O(^TMP($J,"ZIBRPI",F)) Q:F=""  W L,U,F,U,^(F),U,DT,! S %=%+1,XMTEXT(%)="Restore from file "_$E(F_$J("",14),1,14)_": "_^(F)
 U IO:(W)
 D ZISC,HC(O("RM")_W)
 ; uucp according to parameter: ENTRY ACTION of option.
 S %=+$P(^DIC(19,$O(^DIC(19,"B","ZIB REMOTE PATCH INSTALLATION",0)),20)," ",2),E=$P($P(^(20),"""",2),U,2)
 I O["UNIX" D
 . I '(%=2) D HC("uucp -r "_D_" "_$P($T(SYTM),";",3)_"!~")
 . I %>1 D HC("uucp -r -nroot "_D_" "_$P(^AUTTSITE(1,0),U,14)_"!~")
 . Q
 S XMTEXT="XMTEXT(",XMSUB=$P($P($T(ZIBRPI),";",2),"-",2),XMY(1)=""
 D XMD
 I E S %="" F  S %=$O(^TMP($J,"B9",%)) Q:%=""  D RTN(U_%)
 KILL ^TMP($J)
 S ZTREQ="@"
Q ;
 Q
 ;
DIE NEW D,E,F,I,J,L,N,O,P,V,W D ^DIE Q
DIR NEW D,E,F,I,J,L,N,O,P,V,W D ^DIR Q
DTC NEW D,E,F,I,J,L,N,O,P,V,W D ^%DTC Q
FILE NEW D,E,F,I,J,L,N,O,P,V,W KILL DD,DO D FILE^DICN Q
HC(%) NEW D,E,F,I,J,L,N,O,P,V,W S %=$$JOBWAIT^%HOSTCMD(%) Q
RTN(%) NEW D,E,F,I,J,L,N,O,P,V,W D @(%) Q
XMD NEW D,E,F,I,J,L,N,O,P,V,W D ^XMD Q
ZIS NEW D,E,F,I,J,L,N,O,P,V,W D ^%ZIS Q
ZISC NEW D,E,F,I,J,L,N,O,P,V,W D ^%ZISC Q
 ;
HFS ;
 ; F I=0:0 S I=$O(^%ZIS(1,I)) Q:'I  I ^(I,"TYPE")="HFS" S IOP=$P(^%ZIS(1,I,0),U),%ZIS("IOPAR")="(""/usr/spool/uucpublic/work.zib"":""W"")" D ZIS Q:'POP ; XB*3*1 IHS/ADC/GTH 03-07-97 Correct spelling of uucppublic.
 F I=0:0 S I=$O(^%ZIS(1,I)) Q:'I  I ^(I,"TYPE")="HFS" S IOP=$P(^%ZIS(1,I,0),U),%ZIS("IOPAR")="(""/usr/spool/uucppublic/work.zib"":""W"")" D ZIS Q:'POP  ; XB*3*1 IHS/ADC/GTH 03-07-97 Correct spelling of uucppublic.
 I 'I,'$D(POP) S POP=1
 Q:POP
 S I=$P(^%ZIS(1,I,0),U)
 Q
 ;
JDT ;
 NEW X1,X2
 S X2=$E(DT,1,3)_"0101",X1=DT
 D DTC
 S X=X+1,X="00"_X,J=$E(X,$L(X)-2,$L(X))
 Q
 ;
OS ; The "IN" directory is retrieved from the OPTION entry.
 S O=$P($P(^%ZOSF("OS"),","),"-",2),O("PF")=$P($T(PATTERN),";",3)
 S W=$P($T(WORK),";",3),O("NS")=$P($T(NS),";",3)
 I O["UNIX" S (D("IN"),D("OUT"))=$P($T(PUB),";",3),O("RM")="rm ",O("LS")="ls -l ",W=D("OUT")_W Q
 S %=$G(^AUTTSITE(1,1)),D("IN")=$P(%,U),D("OUT")=$P(%,U,2),O("RM")="DEL ",O("LS")="DIR /B "
 Q
 ;
 ; XB*3*2 IHS/ADC/GTH 04-21-97 Correct patch file pattern match.
 ;  Old PATTERN:
 ;;2.4L.2"_"4N1"."1"p"1.2N
SYTM ;;dpssyg
PATTERN ;;2.4L.2"_"4N1"."1.2N1"p"; XB*3*2 IHS/ADC/GTH 04-21-97 Correct patch file pattern match.
WORK ;;ZIBRPI.WRK
PUB ;;/usr/spool/uucppublic/
NS ;;ZIB_P

ZIBRSEL
ZIBRSEL ; IHS/ADC/GTH - NONINTERACTIVE ROUTINE SELECT ; [ 11/04/97  10:26 AM ]
 ;;3.0;IHS/VA UTILITIES;**4**;FEB 07, 1997
 ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
 ;
 ; Return the number of selected routines set into the
 ; indicated variable.
 ;
 ; E.g.:
 ; I '$$RSEL^ZIBRSEL("B-BZZZZZZZ","ARRAY(") W "NONE SELECTED" Q
 ;
 ; If routines exists in the list or range, their name will
 ; be returned as the last subscript of indicated variable in
 ; the 2nd parameter.  The default is ^TMP("ZIBRSEL",$J,
 ;
 ; If routine B exists, then node ^TMP("ZIBRSEL",$J,"B") will
 ; be null.
 ;
 ; It is the programmer's responsibility to ensure the name
 ; of the array is correctly formed.
 ;
 ;        Variables used:
 ; X = String indicating list or range of routines.
 ; Y = String indicating variable into which to set the
 ;     selected routines.  Default = ^TMP("ZIBRSEL",$J,
 ; F = First routine, if range.
 ; L = Last routine, if range.
 ; N = Number of routines returned.
 ; Q = Quote character.
 ;
 Q
 ;
RSEL(X,Y) ;PEP - Select a list or range of routines, return in Y, # sel in N.
 I '$L($G(X)) Q "NO ROUTINES SPECIFIED IN PARAMETER"
 NEW F,L,N,O,Q
 ; S O=$P(^%ZOSF("OS"),"-",1) ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
 S O=$P(^%ZOSF("OS"),"^",1) ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
 I O["MSM" S O="MSM" ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
 E  S O="unknown" ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
 I '$L($T(@O)) Q "OPERATING SYSTEM '"_O_"' NOT SUPPORTED."
 I '$L($G(Y)) KILL ^TMP("ZIBRSEL",$J) S Y="^TMP(""ZIBRSEL"","_$J_","
 S F=$P(X,"-"),L=$P(X,"-",2),N=0,Q=""""
 I '(F]"") Q 0
 I F["*" S F=$P(F,"*"),L="*",X=$P(X,"*")
 D @O
 Q N
 ;
MSM ; Micronetics Standard MUMPS.
 I F]"",$D(^ (F)) S N=N+1,@(Y_Q_F_Q_")")=""
 I L="*" D  Q
 . F  S F=$O(^ (F)) Q:F=""!('(X=$E(F,1,$L(X))))  S N=N+1,@(Y_Q_F_Q_")")=""
 .Q
 F  S F=$O(^ (F)) Q:F=""!(F]L)  S N=N+1,@(Y_Q_F_Q_")")="" Q:L=""
 Q
 ;

ZIBVKIL
ZIBVKIL ; IHS/ADC/GTH - BUILD A KILL VARIABLE ROUTINE ; [ 11/04/97  10:26 AM ]
 ;;3.0;IHS/VA UTILITIES;**4**;FEB 07, 1997
 ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
 ;
 ; Build a name space variable killer routine in ^.ns.KVAR.
 ;
 ; Select a %INDEX host file summary from which to build the
 ; routine.  Select a name space for the variables and the
 ; routine to be built.  Enter any package wide variables.
 ;
 ; Add D ^.ns.VKL0 to all menu exit actions where package
 ; variables are to remain.
 ;
 ; Add D KILL^XUSCLEAN to the exit of all other menus.
 ;
 ; I $P(^%ZOSF("OS"),"-",1)'="MSM" W !,*7,"OPERATING SYSTEM '",$P(^%ZOSF("OS"),"-",1),"' NOT SUPPORTED." Q ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
 I $P(^%ZOSF("OS"),"^",1)'["MSM" W !,*7,"OPERATING SYSTEM '",$P(^%ZOSF("OS"),"^",1),"' NOT SUPPORTED." Q  ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
 ;
 D HOME^%ZIS
 NEW XBNS
NS ;
 KILL DIR
 S DIR(0)="F^2:4",DIR("A")="Name Space - or ' ^ 'to exit"
 D ^DIR
 I X="^" G EXIT
 I Y="" G NS
 I '$D(^DIC(9.4,"C",Y)) W !,"NO PACKAGE ??",! G NS
 S XBNS=Y
PKGVAR ;
 KILL DIR
 S DIR(0)="F^0:235",DIR("A")="List of Package Wide Variables or '^' to bypass",DIR("?")="LIST var1,var2, ... "
 D ^DIR
 I Y'="^" F XBI=1:1 S X=$P(Y,",",XBI) Q:X=""  S XBVPKG(X)=""
KROU ;
 KILL DIR
 S DIR(0)="F^0:235",DIR("A")="List of other Kill routines to chain",DIR("?")=" ^ROU1,^ROU2, ... with '^'s"
 D ^DIR
 I Y]"",Y'="^"  F XBI=1:1 S XBROU=$P(Y,",",XBI) Q:XBROU=""  S X=$P(XBROU,"^",2) D
 . I X="" W !,XBROU,"   error in list >> ",Y G KROU
 . X ^%ZOSF("TEST")
 . I '$T W !,X,"   error in list >> ",Y G KROU
 .Q
 I Y]"" S XBKROU=" D "_Y
 D ^XBVCHV
 I '$D(^XBVROU($J)) W !,"NO FILE ??",! G NS
S ;
 F I=1:1 Q:'$T(@I)  S XBLD(I)=$P($T(@I),";;",2,99)
 X XBLD(1)
EXIT ;
 D KILL^XUSCLEAN
 KILL ^XBVROU($J),XBKROU,XBLD
 W !,"REMEMBER TO EDIT THE TOP LINES OF THE ROUTINES CREATED !",!!
 Q
 ;
1 ;;S XBNUM=0 X XBLD(2),XBLD(3),XBLD(4),XBLD(6) ZS @XBROU W !,XBROU," Saved ",!!
2 ;;ZR  S XBROU=XBNS_"VKL"_XBNUM,X=XBROU_" ; - kill variables",XBLNS=$L(XBNS) ZI X S X=" ;;" ZI X
3 ;;S XBVAR=XBNS,XBHD=" K ",X=" K " F  S XBVAR=$O(^XBVROU($J,"V",XBVAR)) Q:$E(XBVAR,1,XBLNS)'=XBNS  I '$D(XBVPKG(XBVAR)) S X=X_XBVAR_"," S XBLX=$L(X) I XBLX>235 S X=$E(X,1,XBLX-1) ZI X S X=" K " X ^%ZOSF("SIZE") I Y>3000 X XBLD(5),XBLD(2)
4 ;;S XBLX=$L(X) I XBLX>3 S X=$E(X,1,XBLX-1) ZI X
5 ;;S XBNUM=XBNUM+1 S X=" D ^"_XBNS_"VKL"_XBNUM ZI X ZS @XBROU W !,XBROU," Saved",!!
6 ;;I $D(XBKROU) S X=XBKROU ZI X W !,"ADDING ",X,!