5:33 PM  22-FEB-95
XB/ZIB version 2.6, patch 6, including routines from patches 1-5, 16 routines.
XB
XB ; IHS/ADC/GTH - UTILITY MENU ; [ 02/22/95  2:24 PM ]
 ;;2.6;IHS/VA UTILITIES;**6**;MAR 20, 1991 
 ; XB*2.6*6 IHS/ADC/GTH 02-22-95, Add options, standardized code.
 ;
 ; SEE ROUTINE XB1 FOR FURTHER DOCUMENTATION AND THE MENU OPTIONS.
 ;
 ; This routine lists available utilities in the form of a menu with
 ; a brief description of what the utility does.  New utilities may be
 ; added to this routine by adding the appropriate ";;" entries to the
 ; bottom of this routine.
 ;
START ;
 I '$D(^%ZOSF("TEST"))!('$D(^%ZOSF("TRAP"))) W !!,"Missing ^%ZOSF nodes!",! Q
 D ^XBKSET S IOP=$I D ^%ZIS
 S X="%ZIS" D RCHK I XBFAIL D EOJ Q
 S X="XBRPTL" D RCHK S:XBFAIL XBNH=""
 S XBLBL="M",XBQ=0
 F  D MENU Q:XBQ
 D EOJ
 Q
 ;
MENU ;
 D LIST
 W !!,"Choose: " R XBY:$S($D(DTIME):DTIME,1:999) S:XBY="^" XBY=""
 I XBY["?" D HELP Q
 I XBY="" S XBQ=1 Q
 I XBY'=+XBY D LETTERS
 I XBY'<1,XBY'>(XBI-1) D OPTION D:XBP="P" PAUSE S XBP="" Q
 W *7
 Q
 ;
HELP ;
 I XBY="?" D  D PAUSE Q
 . S XBH="" D LIST K XBH
 . W !!,"To get help on a non-menu option enter '?n' where n is the option number.",!
 . Q
 I XBY?1"?"1N.N S XBY=$P(XBY,"?",2) I XBY,XBY'>(XBI-1) D  D PAUSE Q
 . I $D(XBNH) W !!,"No help available.  Routine ^XBRPTL not in UCI.",! Q
 . K ^UTILITY($J)
 . S XBX=$P($T(@XBLBL+XBY^XB1),";;",3) ; XB*2.6*6 IHS/ADC/GTH 02-22-95
 . I XBX W !!,"No help available for menus." Q
 . I XBX?1"!".E W !!,"No help available for executable code [",$E(XBX,2,99),"]." Q
 . S XBX=$P(XBX,"^",2)
 . S X=XBX D RCHK I XBFAIL W !!,"No help available.  Routine ^",XBX," not in ",$S($E(XBX)="%":"MGR",1:"UCI"),".",! Q
 . S ^UTILITY($J,XBX)=""
 . D EN^XBRPTL
 . K ^UTILITY($J)
 . Q
 W *7
 Q
 ;
LIST ; LIST MENU OPTIONS
 K XBTBL
 W !!,?5,$P($T(@XBLBL^XB1),";;",2),! ; XB*2.6*6 IHS/ADC/GTH 02-22-95
 F XBI=1:1 S XBX=$T(@XBLBL+XBI^XB1) Q:$E(XBX)'=" "  S XBY=$P(XBX,";;",3),XBX=$P(XBX,";;",2) D  W !,XBI,?5,XBX,"    ",$S($D(XBH):$S(XBY:"[menu]",1:XBY),1:$S(XBY:"[menu]",1:""))
  ; XB*2.6*6 IHS/ADC/GTH 02-22-95
 . S X=XBX D ^XBUPCASE
 . S XBTBL(X)=XBI_"^"_XBX
 . Q
 Q
 ;
LETTERS ;
 K XBC
 S X=XBY D ^XBUPCASE S XBY=X
 I $D(XBTBL(XBY)) S XBY=XBTBL(XBY) Q
 S XBC=0,X=XBY F  S X=$O(XBTBL(X)) Q:X=""!($E(X,1,$L(XBY))'=XBY)  S XBC=XBC+1,XBC(XBC)=+XBTBL(X)_"^"_$P(XBTBL(X),"^",2)
 W !
 I XBC=0 S XBY=0 Q
 I XBC=1 S XBY=$P(XBC(1),"^",1) Q
 F I=1:1:XBC W !,I,"  ",$P(XBC(I),"^",2)
 W !!,"Which one? " R XBY:$S($D(DTIME):DTIME,1:999)
 I XBY'="",$D(XBC(XBY)) W " ",$P(XBC(XBY),"^",2) S XBY=$P(XBC(XBY),"^",1) Q
 W *7
 S XBY=0
 Q
 ;
OPTION ;
 S XBX=$T(@XBLBL+XBY^XB1),XBP=$P(XBX,";;",4),XBX=$P(XBX,";;",3) ; XB*2.6*6 IHS/ADC/GTH 02-22-95
 I XBX D RECURSE Q
 W !
 I XBX?1"!".E S XBX=$E(XBX,2,250)
 E  S X=$P(XBX,"^",2),XBX="D "_XBX D RCHK I XBFAIL W "Routine ",X," not in ",$S($E(X)="%":"MGR!",1:"UCI!") Q
 S X="TRAP^XB" S @^%ZOSF("TRAP")
 ; D CALL ; XB*2.6*6 IHS/ADC/GTH 02-22-95
 D ^XBNEW("CALL^XB:XBX;DT;DTIME;U;DUZ") ; XB*2.6*6 IHS/ADC/GTH 02-22-95
 Q
 ;
CALL ;
 ; NEW (XBX,DT,DTIME,U,DUZ) ; XB*2.6*6 IHS/ADC/GTH 02-22-95
 S IOP=$I D ^%ZIS
 X XBX
 U 0
 Q
 ;
RECURSE ;
 I $L(XBLBL)>6 W !,"Maximum menu depth exceeded." S XBQ=1 Q
 S XBLBL=XBLBL_XBX
 W !
 F  D MENU Q:XBQ
 S XBQ=0
 S XBLBL=$E(XBLBL,1,$L(XBLBL)-1)
 W !
 Q
 ;
TRAP ; ERROR TRAP
 W !!,"The following error has occurred: ",$$ERR^ZIBERR,! ; XB*2.6*6 IHS/ADC/GTH 02-22-95
 D:XBP="" PAUSE
 Q
 ;
PAUSE ;EP
 S DIR(0)="EO" D ^DIR K DIR,DIRUT
 S:$D(DUOUT) XBQ=1
 Q
 ;
CHECK ; CHECK XB OPTION ROUTINES (EXECUTED FROM ^XB MENU OPTION)
 F XBII=1:1 S X=$T(M+XBII^XB1) Q:X=""  I $P(X,";;",1)=" " S X=$P(X,";;",3) I X'=+X,X'?1"!".E D  ; XB*2.6*6 IHS/ADC/GTH 02-22-95
 . I X'?.8UN1"^"1.8UN,X'?.8UN1"^"1"%"1.7UN S XBII(4,XBII)=$P($T(M+XBII^XB1),";;",2,9) Q  ; XB*2.6*6 IHS/ADC/GTH 02-22-95
 . S X=$P(X,"^",2)
 . D RCHK I XBFAIL S XBII($S($E(X)'="%":1,$E(X,2,4)="ZIB":2,1:3),X)=""
 . Q
 I '$O(XBII(0)) W !,"All options seem to be ok.",! K XBII Q
 I $D(XBII(1)) W !,"The following routines are not in this UCI:" S X="" F  S X=$O(XBII(1,X)) Q:X=""  W !,?3,X
 I $D(XBII(2)) W !,"The following ZIB* routines must be moved to MGR as % routines:" S X="" F  S X=$O(XBII(2,X)) Q:X=""  W !,?3,X
 I $D(XBII(3)) W !,"The following % routines are not in MGR:" S X="" F  S X=$O(XBII(3,X)) Q:X=""  W !,?3,X
 I $D(XBII(4)) W !,"The following options have invalid routine names:" S X="" F  S X=$O(XBII(4,X)) Q:X=""  W !,?3,XBII(4,X)
 W !
 K XBII
 Q
 ;
RCHK ; CHECK ROUTINE EXISTENCE
 S XBFAIL=0,XBRTN=X,XUSLNT=1
 I $E(XBRTN)="%" X ^%ZOSF("UCI") S XBUCI=Y,%UCI="MGR" D 2^%XUCI ; XB*2.6*6 IHS/ADC/GTH 02-22-95
 S X=XBRTN X ^%ZOSF("TEST") S:'$T XBFAIL=1
 I $E(XBRTN)="%" S %UCI=XBUCI D 2^%XUCI
 W:XBFAIL !!,"Routine ",X," missing!"
 S X=XBRTN
 K XUSLNT
 Q
 ;
EOJ ;
 K ^UTILITY($J)
 K XBC,XBH,XBI,XBL,XBLBL,XBNH,XBP,XBQ,XBTBL,XBY,XBX,XBFAIL,XBUCI,XBRTN
 K DIRUT,DTOUT,DUOUT
 K X,Y
 Q
 ;

XB1
XB1 ; IHS/ADC/GTH - XB MENUS AND DOCUMENTATION ; [ 02/22/95  2:15 PM ]
 ;;2.6;IHS/VA UTILITIES;**6**;MAR 20, 1991 
 ; XB*2.6*6 IHS/ADC/GTH 02-22-95, Add options, standardized code.
 ;
 ; Each label represents a menu.  The label must begin with "M"
 ; and be followed by 1 or more 1 digit numbers 1-9.  Each digit
 ; represents the link # of the parent option.  E.G. 'M1' is the
 ; label for submenu options for the main menu option with a link #
 ; of 1;  'M11' would be the label for subsubmenu options for the
 ; option in 'M1' with a link # of 1.  Within a menu options are
 ; listed and selected positionally.  The only purpose of the link
 ; # is to link options to their parent menu.  Example:
 ;
 ; M1  ;;FILES/DICTIONARIES
 ;     ;;Submenu example one;;1
 ;     ;;Submenu example two;;2
 ; M11 ;;SUBMENU ONE
 ;     ;;Submenu option;;^ROUTINEX
 ; M12 ;;SUBMENU TWO
 ;     ;;Submenu option;;^ROUTINEY
 ;
 ; This label naming technique allows the menu tree to go to
 ; seven levels.  No more than nine options on one menu may also
 ; be menus.
 ;
 ; For menu options the 2nd ";;" piece is the title, the 3rd ";;"
 ; piece must be a number if the option is a submenu, a valid routine
 ; or label^routine or executable code if the 3rd piece begins with
 ; a !.  The code following the ! will be placed in a variable and
 ; the variable will be executed. A P in the 4th ";;" piece indicates
 ; pause after execution.
 ;
M ;;MAIN XB UTILITY MENU
 ;;Files/dictionaries;;1
 ;;Globals;;2
 ;;Routines;;3
 ;;Miscellaneous;;4
 ;;Developers;;5
 ;;Check ^XB options;;CHECK^XB;;P
M1 ;;FILES/DICTIONARIES
 ;;List fields;;^XBFLD
 ;;List 0th nodes;;^XBLZRO;;P
 ;;Check regular xrefs;;^XBCFXREF;;P
 ;;Selective RE-INDEX;;^XBRXREF
 ;;Compare dictionary in two UCIs;;^XBFCMP;;P
 ;;Search for routines executed from dictionary;;^XBRSRCH
 ;;Fix 0th nodes;;^XBCFIX;;P
 ;;Count entries in file;;^XBCOUNT
 ;;FileMan;;!D P^DI
 ;;Delete dictionaries;;^XBKD
 ;;Clean dictionaries [caution];;^XBCDIC
 ;;Electronic Data Dictionary;;^XBHEDD;;;; XB*2.6*6 IHS/ADC/GTH 02-22-95
M2 ;;GLOBALS
 ;;List global;;^%GL
 ;;Directory of selected globals;;^ZIBGD;;P
 ;;Count unique values;;^XBCNODE
 ;;List high entry number;;^XBGLDFN;;P
 ;;Copy to another global in same UCI;;^XBGC
 ;;Copy global to another UCI;;^%GCOPY
 ;;Search global for value;;^%GSE
 ;;Global edit;;^%GEDIT
 ;;Change global value;;^%GCHANGE
 ;;Global size/efficiency;;!D @$S(^%ZOSF("OS")["MSM":"^%GE",1:"^%ZTBKC");;P
 ;;Global characteristics;;^%GCH
 ;;Global delete;;^%GDEL
 ;;Global restore;;^%GR
 ;;Global save;;^%GS
 ;;Find control chrs in globals;;^ZIBGCHR
M3 ;;ROUTINES
 ;;List routines in various ways;;1
 ;;Compare routines in two UCIs;;^%RCMP;;P
 ;;Restore routines;;^%RR
 ;;Save routines;;^%RS
 ;;Save routines by edit date;;^XBRSBD
 ;;Routine size;;^XBRSIZ;;P
 ;;Delete routines;;^%RDEL
 ;;Search routines for values (OR);;^%RSE
 ;;Search routines for values (AND);;^%RSAND
 ;;Find routines by edit date;;^%NEWED;;P
 ;;Full screen editor;;!ZR  NEW  X ^%E
 ;;Routine change;;^%RCHANGE
 ;;Routine copy;;^%RCOPY
 ;;Directory of selected routines;;^%ZIBRD;;P
 ;;Scan UCIs for routine;;^ZIBFR;;P
 ;;Run routine;;!R "  Enter routine name: ",Y:30 Q:'$T  S:Y'["^" Y="^"_Y S X=$P(Y,"^",2) X ^%ZOSF("TEST") W:'$T "  huh? ",*7 I $T D @Y
M31 ;;LIST ROUTINES
 ;;List first one/two lines;;^%ZTP1;;P
 ;;List to first label;;^XBRPTL;;P
 ;;List routines;;^%RPRT;;P
 ;;List routines by edit date;;^XBRPRTBD
 ;;VA routine lister;;^%ZTPP;;P
 ;;List one routine with character counts;;^XBRLL;;P
 ;;%INDEX;;^%INDEX
 ;;Flow chart from entry point;;^XTFCE
 ;;Flow chart entire routine;;^XTFCR
M4 ;;MISCELLANEOUS
 ;;Error report;;^%ER
 ;;List ^UTILITY nodes for current job;;^XBLUTL;;P
 ;;Kill ^UTILITY nodes for current job;;^%ZIBCLU0
 ;;Cleanup utility globals in all UCIs;;EN^ZIBCLU
 ;;Cleanup utility globals in current UCI;;EN^%ZIBCLU0
 ;;Fix 'PT' nodes in all files;;^XBFIXPT
 ;;Convert non-DINUM data global to DINUM;;^XBDINUM
 ;;Check UCI routines against package file;;^ZIBCKPKG;;P
 ;;Display FileMan installation data;;^ZIBFMD;;P
 ;;Renamespace routines;;^ZIBRNSPC;;P
 ;;Number base changer;;^XTBASE
M5 ;;DEVELOPERS
 ;;Generate ^DIR call;;^XBDR;;P
 ;;Standardize line 1 of routines;;^XBFIXL1
 ;;Set version line;;^XBVLINE
 ;;Set dictionary version numbers;;^XBDICV;;P
 ;;Set no delete;;^XBNODEL;;P
 ;;Set audit;;^XBSAUD;;P
 ;;Set authorities;;^XBSAUTH;;P
 ;;Analyze file for specifiers;;^XBCSPC
 ;;Delete namespaced OPTIONS, KEYS, etc.;;RUN^XBPKDEL;;P
 ;;List namespaced OPTIONS, KEYS, etc.;;LIST^XBPKDEL;;P
 ;;Build pre-init routine;;^XBBPI
 ;;Build integ routine;;^XBINTEG
 ;;List callable subroutines;;^XBLCALL;;P
 ;;Reset file data globals *** DANGER ***;;^XBFRESET
 ;;Edit FM print template headers;;^XBDH;;;; XB*2.6*6 IHS/ADC/GTH 02-22-95
 ;;Build routine to kill namespaced variables;;^XBLDVKL;;;; XB*2.6*6 IHS/ADC/GTH 02-22-95

XBENHANC
XBENHANC ;IHS/DSD/GTH - DISPLAY/PRINT ENHANCEMENTS FIELD IN PACKAGE FILE ; [ 02/15/95  12:24 PM ]
 ;;2.6;IHS/VA UTILITIES;**2**;MAR 20, 1991 
 ;
EN(XB) ;EP - XB = Namespace of package to print enhancements.
 D HOME^%ZIS,DT^DICRW
DEV ;
 S %ZIS="OPQ" D ^%ZIS
 I POP S IOP=$I D ^%ZIS G K
 G:'$D(IO("Q")) START
 K IO("Q")
 I $D(IO("S"))!($E(IOST)'="P") W *7,!,"Please queue to system printers." D ^%ZISC G DEV
 S ZTRTN="START^XBENHANC",ZTDESC=$P($P($T(XBENHANC),"-",2),";",2),ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL,ZTSAVE("XB")=""
 D ^%ZTLOAD
 G:'$D(ZTSK) DEV
K K ZTSK
 D ^%ZISC
 Q
 ;
START ;EP - TaskMan.
 NEW A,B,DIRUT,DIWL,DIWR,DIWF,XBHDR,XBPG
 S A=$O(^DIC(9.4,"C",XB,0))
 Q:'A
 Q:'$D(^DIC(9.4,A,"VERSION"))
 S B=$O(^DIC(9.4,A,22,"B",^DIC(9.4,A,"VERSION"),0))
 Q:'B
 S XBHDR="Enhancements to "_$P(^DIC(9.4,A,0),U)_", Version "_^DIC(9.4,A,"VERSION")
 K ^UTILITY($J,"W")
 S DIWL=5,DIWR=IOM-6,DIWF="W"
 U IO
 D TOF
 S %=0
 F  S %=$O(^DIC(9.4,A,22,B,1,%)) Q:'%   D DIWP(^(%,0)),TOF:$Y>(IOSL-6) Q:$D(DIRUT)
 D:'$D(DIRUT) ^DIWW
 K ^UTILITY($J,"W")
 D ^%ZISC
 Q
 ;
DIWP(X) NEW %,A,B D ^DIWP Q
 ;
TOF NEW %,A,B,DIR
 S XBPG=$G(XBPG)+1
 W !!
 I '$D(ZTQUEUED),'$D(IO("S")),IO=IO(0) S DIR(0)="E" D ^DIR
 Q:$D(DIRUT)
 W @IOF,!!,?DIWL-1,XBHDR,?(DIWR-$L("Page "_XBPG)-1),"Page ",XBPG,!?DIWL-1,$$REPEAT^XLFSTR("-",DIWR-DIWL),!!
 Q

XBFIXL1
XBFIXL1 ;IHS/OHPRD/ACC - STANDARDIZE LINE 1 OF SELECTED ROUTINES ;  [ 02/15/95  12:24 PM ]
 ;;2.6;IHS/VA UTILITIES;**6**;JUN 28, 1993
 ;
 ; This routine calls ^%RSEL to select a set of routines, asks the user
 ; for the programmer information and standardizes the format of the
 ; first line of each routine.
 ;
 ; The form of the first line will be as follows:
 ;
 ;   label ; agency/site/developer - comment ; edit date    E.G.
 ;   XBFIXL1 ; IHS/OHPRD/ACC - FIX LINE 1 ; [ 11/08/90  10:41 AM ]
 ;
START ;
 NEW ASK,QUIT,RTN
 S QUIT=0
 K ^UTILITY($J)
 D ^XBKVAR
 ;
 X ^%ZOSF("RSEL")
 I $D(^UTILITY($J,"XBFIXL1")) W !,"^XBFIXL1 cannot modify itself.  Ignored." K ^UTILITY($J,"XBFIXL1")
 G:$O(^UTILITY($J,""))="" EOJ
 S DIR(0)="F^9:20",DIR("A")="Enter agency/site/programmer",DIR("?")="E.G IHS/OHPRD/ACC" D ^DIR K DIR ; XB*2.6*6
 G:$D(DIRUT) EOJ
 S XBPI=X
 S XBRTN="" F  S XBRTN=$O(^UTILITY($J,XBRTN)) Q:XBRTN=""  D CHECK Q:QUIT
 G EOJ
 ;
CHECK ;
 X "ZL @XBRTN S XBL1=$T(+1)"
 I $E($P(XBL1," ",2))'=";" W !!,XBRTN," - line 1 contains code and must be changed manually.  Skipping" Q
 S XBSAVE=XBL1
 D MODIFY
REVER D VERIFY
 Q:QUIT
 D:Y="R" FIX
 I QUIT S XBL1=XBSAVE G REVER
 X:XBL1'="" "ZL @XBRTN ZR +1 ZI XBL1 ZS @XBRTN"
 Q
 ;
MODIFY ; MODIFY LINE 1
 S XBTAG=$P(XBL1," "),X=$P(XBL1,";",2,99)
 D EXTDATE
 F  Q:$E(X)'=" "  S X=$E(X,2,$L(X))
 S:$P(X,";")?." " $P(X,";")=XBPI_" - NO DESCRIPTION PROVIDED"
 S %=$P(X,";") I %'["-",$P(%," ")?1A.AN1"/"1A.AN.E S $P(%," ")=$P(%," ")_" - ",$P(X,";")=%
 F  S %=$F(X,";") Q:'%  S X=$E(X,1,%-2)_" "_$E(X,%,$L(X))
 F  S %=$F(X,"  ") Q:'%  S X=$E(X,1,%-3)_" "_$E(X,%,$L(X))
 S:$E(X)=" " X=$E(X,2,$L(X)) S:$E(X,$L(X))=" " X=$E(X,1,$L(X)-1)
 I X["-" S %=$P($P(X,"-")," ") S %=(%["/")*(1+($P($P(X,"-"),%,2)?." ")) S:%=1 $P(X," ")=XBPI_" -" S:%=2 $P(X,"-")=XBPI_" " S:'% X=XBPI_" - "_X
 I X'["-" S X=XBPI_" - "_X
 S XBL1=XBTAG_" ; "_X_" ;"_$S(XBDATE]"":" [ "_XBDATE_" ]",1:"")
 Q
 ;
EXTDATE ; EXTRACT DATE AND REMOVE FROM LINE
 S XBNP=$L(X,";"),XBLP=$P(X,";",XBNP)
 F XBPAT=("1.2N1""/""1.2N1""/""2.4N"),("1.2N1"" ""3A1"" ""2.4N"),("1.2N1""-""3A1""-""2.4N") S XBLDT=$$GETPATRN^XBFUNC(XBLP,XBPAT) Q:XBLDT]""
 I XBLDT="" S XBDATE="" Q
 S XBLTM=$$GETPATRN^XBFUNC($P(XBLP,XBLDT,2),"1.2N1"":""1.2N1"" ""2A") S:XBLTM]"" XBLDT=XBLDT_" "_XBLTM
 S XBLP=$P(XBLP,XBLDT)_$P(XBLP,XBLDT,2)
 S XBLDJ=$$FNDPATRN^XBFUNC(XBLP,"."" ""1""["".E1""]"".E")
 S:XBLDJ XBLP=$E(XBLP,1,XBLDJ-1)
 S $P(X,";",XBNP)=XBLP
 S XBDATE=XBLDT
 Q
 ;
VERIFY ;
 ;W !,XBRTN," - the first line will be set to:",!,XBL1,!
 W !!,XBRTN,!," from: ",XBSAVE,!,"   to: ",XBL1
 S DIR(0)="S^A:Accept;R:Replace;S:Skip",DIR("B")="A",DIR("?")="Accept the proposed modification; Replace the proposal with your own line; Skip the routine" D ^DIR K DIR
 S:$D(DIRUT) QUIT=1
 S:Y="S" XBL1=""
 Q
 ;
FIX ; GET INFO FROM USER
 S DIR(0)="F^5:40",DIR("A")="Enter comment to follow agency/site/programmer " D ^DIR K DIR ; XB*2.6*6
 S:$D(DIRUT) QUIT=1
 S $P(XBL1,";",2)=XBPI_" - "_X
 Q
 ;
EOJ ;
 K %,X,Y,^UTILITY($J)
 K DTOUT,DUOUT,DIRUT,DIROUT
 K XBDATE,XBL1,XBLDJ,XBLDT,XBLP,XBLTM,XBNP,XBPAT,XBPI,XBRTN,XBSAVE,XBTAG
 Q
 ;

XBFUNC2
XBFUNC2 ;IHS/LAB/OHPRD - FUNCTION LIBRARY - PCC RELATED FUNCTIONS [ 02/15/95  12:25 PM ]
 ;;2.6;IHS/VA UTILITIES;**1**;20-SEP-93
 ;
 ;
PCCPPINT(VISIT) ;EP -return primary provider ien in VA(200
 NEW X,Y,Z,XBX,DIC,DR,DA,DIQ,XBY
 S XBX=0 F  S XBX=$O(^AUPNVPRV("AD",VISIT,XBX)) Q:XBX'=+XBX!($G(XBY))  I $P(^AUPNVPRV(XBX,0),U,4)="P" S XBY=+^AUPNVPRV(XBX,0)
 I '$G(XBY) S XBY="" Q XBY
 Q XBY
 ;
PCCPPN(VISIT) ;EP - return a visit's primary provider (NAME)
 NEW X,Y,Z,XBX,DIC,DR,DA,DIQ,XBY
 S XBX=0 F  S XBX=$O(^AUPNVPRV("AD",VISIT,XBX)) Q:XBX'=+XBX!($G(XBY))  I $P(^AUPNVPRV(XBX,0),U,4)="P" S XBY=+^AUPNVPRV(XBX,0)
 I '$G(XBY) S XBX="NONE ENTERED" Q XBX
 S XBX="",DA=XBY,DIC=200,DR=".01",DIQ="XBX",DIQ(0)="E" D EN^DIQ1
 S XBX=XBX(200,XBY,".01","E")
 S:XBX="" XBX="NONE ENTERED"
 Q XBX
 ;
PCCPPI(VISIT) ;EP - return a visit's primary provider (INITIALS)
 NEW X,Y,Z,XBX,DIC,DR,DA,DIQ,XBY
 S XBX=0 F  S XBX=$O(^AUPNVPRV("AD",VISIT,XBX)) Q:XBX'=+XBX!($G(XBY))  I $P(^AUPNVPRV(XBX,0),U,4)="P" S XBY=+^AUPNVPRV(XBX,0)
 I '$G(XBY) S XBX="???" Q XBX
 S XBX="",DA=XBY,DIC=200,DR=1,DIQ="XBX",DIQ(0)="E" D EN^DIQ1
 S XBX=XBX(200,XBY,".01","E")
 S:XBX="" XBX="???"
 Q XBX
 ;
PCCPPCLS(VISIT,FORM) ;EP - return a visit's primary provider class (CODE)
 NEW X,Y,Z,XBX,DIC,DR,DA,DIQ,XBY,XBCODE
 S XBX=0 F  S XBX=$O(^AUPNVPRV("AD",VISIT,XBX)) Q:XBX'=+XBX!($G(XBY))  I $P(^AUPNVPRV(XBX,0),U,4)="P" S XBY=+^AUPNVPRV(XBX,0)
 I '$G(XBY) S XBX="???" Q XBX
 S:$G(FORM)="I" DIQ(0)="I"
 S DA=XBY,DIC=$S($P($G(^AUTTSITE(1,0)),U,22):200,1:6),DR=$S($P($G(^AUTTSITE(1,0)),U,22):53.5,1:2),DIQ="XBX" D EN^DIQ1
 I $P($G(^AUTTSITE(1,0)),U,22) S XBX=$S($G(FORM)="I":XBX(200,XBY,"53.5","I"),1:XBX(200,XBY,"53.5"))
 I '$P($G(^AUTTSITE(1,0)),U,22) S XBX=$S($G(FORM)="I":XBX(6,XBY,"2","I"),1:XBX(6,XBY,"2"))
 I XBX="" S XBX="???" Q XBX
 Q XBX
 ;
PCCPPCLC(VISIT) ;EP - return a visit's primary provider class (CODE)
 NEW X,Y,Z,XBX,DIC,DR,DA,DIQ,XBY,XBN
 S XBX=0 F  S XBX=$O(^AUPNVPRV("AD",VISIT,XBX)) Q:XBX'=+XBX!($G(XBY))  I $P(^AUPNVPRV(XBX,0),U,4)="P" S XBY=+^AUPNVPRV(XBX,0)
 I '$G(XBY) S XBX="???" Q XBX
 S DA=XBY,DIC=200,DR="53.5",DIQ="XBX",DIQ(0)="I" D EN^DIQ1
 S XBX=XBX(200,XBY,".01","I")
 S:XBX="" XBX="???"
 S DIC=7,DR="9999999.01",DA=XBX,DIQ="XBCODE" D EN^DIQ1
 S XBX=XBCODE(7,XBX,"9999999.01")
 Q XBX
 ;
PCCPPAFF(VISIT,FORM) ;EP - return a visit's primary provider (affiliation)
 NEW X,Y,Z,XBX,DIC,DR,DA,DIQ,XBY,XBN
 S XBX=0 F  S XBX=$O(^AUPNVPRV("AD",VISIT,XBX)) Q:XBX'=+XBX!($G(XBY))  I $P(^AUPNVPRV(XBX,0),U,4)="P" S XBY=+^AUPNVPRV(XBX,0)
 I '$G(XBY) S XBX="???" Q XBX
 S:$G(FORM)="I" DIQ(0)="I"
 S DA=XBY,DIC=$S($P($G(^AUTTSITE(1,0)),U,22):200,1:6),DR="9999999.01",DIQ="XBX" D EN^DIQ1
 I $P($G(^AUTTSITE(1,0)),U,22) S XBX=$S($G(FORM)="I":XBX(200,XBY,9999999.01,"I"),1:XBX(200,XBY,9999999.01))
 I '$P($G(^AUTTSITE(1,0)),U,22) S XBX=$S($G(FORM)="I":XBX(6,XBY,9999999.01,"I"),1:XBX(6,XBY,9999999.01))
 S:XBX="" XBX="???"
 Q XBX
 ;

XBGSAVE
XBGSAVE ; IHS/DSD/GTH - GENERIC GLOBAL SAVE FOR TRANSMISSION GLOBALS ; [ 02/22/95  5:27 PM ]
 ;;2.6;IHS/VA UTILITIES;**1,6**;MAR 20, 1991 
 ; XBGSAVE replaces AUGSAVE 1.4.
 ;
 ; XBGL = name of global (mandatory, all others optional)
 ;
 ; XBMED= media to which to save global (user asked, if not exist)
 ; XBUF = directory, default "/usr/spool/uucppublic"
 ; XBFN = output file name, default "<ns><asufac>.<JulianDate>"
 ; XBDT = date of save, in FM format, default NOW
 ; XBNAR= description displayed to user, if user asks for help
 ; XBTLE= comment for dump header (facility name is concatenated)
 ; XBIO = output device number
 ; XBPAR= CR parameter (DSM only)
 ; XBF  = beginning first-level numeric subscript, seed for $ORDER
 ; XBE  = ending first-level numeric subscript
 ; XBQ  = Y/N, to place file in uucp q, default "Y"
 ; XBQTO= 'sendto' destination, default AO sysid in RPMS SITE file
 ; XBFLT= 1, saves as flat file ; XB*2.6*6
 ;
SETUP ;
 I '$D(^%ZOSF("OS")) S XBFLG(1)="The ^%ZOSF(""OS"") node does not exist",XBFLG=-1 G EOJ
 I '(^%ZOSF("OS")["MSM"),'(^%ZOSF("OS")["DSM") S XBFLG(1)="Operating system is not 'MSM' or 'DSM'",XBFLG=-1 G EOJ
 I '$G(DUZ(2)) S XBFLG(1)="Facility Number 'DUZ(2)' is not defined",XBFLG=-1 G EOJ
 I '$D(XBGL) S XBFLG(1)="The variable 'XBGL' must contain the name of the global you wish to save." S XBFLG=-1 G EOJ
 K XBFLG,XBGLL
 S:'$D(DTIME) DTIME=300
CHECK ;
 S X=XBGL
 I $L(X,"(")>1,$P(X,"(",2)="" S X=$P(X,"(")
 S:$E(X,$L(X))="," X=$E(X,1,($L(X)-1))
 I $L(XBGL,"(")>1,$E(XBGL,$L(XBGL))'="," S XBGL=XBGL_","
 I $L(X,"(")>1,$E(X,$L(X))'=")" S X=X_")"
 S:$L(X,"(")=1 XBGL=X_"("
 S XBGLL=U_X
CKGLOB I '$D(@XBGLL) S XBFLG(1)="Transaction File does not exist",XBFLG=-1 G EOJ
 S:'$D(XBUF) XBUF="/usr/spool/uucppublic"
 I '$D(DT) D DT^DICRW
 S X2=$E(DT,1,3)_"0101",X1=DT D ^%DTC S XBCARTNO=X+1
 S XBDT=$S($D(XBDT):$$FMTE^XLFDT(XBDT),1:$$HTE^XLFDT($H))
 S:$E(XBGL,1)'=U XBGL=U_XBGL
 S XBNAR=$G(XBNAR)
 S XBTLE=$G(XBTLE)_" "_$P(^DIC(4,DUZ(2),0),U)
 I $D(XBMED) S XBMED=$$UP^XLFSTR($E(XBMED))
 S XBQ=$E($G(XBQ)_"Y")
 I XBQ="Y" S XBQTO=$G(XBQTO) I XBQTO="" S XBQTO=$P(^AUTTSITE(1,0),U,14) I XBQTO="" S XBQ="N"
 S XBF=$G(XBF),XBE=$G(XBE) I XBF="" S XBF=""""""
 I ^%ZOSF("OS")["DSM" G SETUPDSM
SETUPMSM ;
 S:'$D(XBIO) XBIO=51
 I $D(XBMED),'("CDFT"[XBMED) S XBFLG(1)="Media Type '"_XBMED_"' is incorrect",XBFLG=-1 G EOJ
 D ^ZIBGSVEM
 G EOJ
SETUPDSM ;
 I '$D(XBIO) S XBIO=47
 I $D(XBMED),'("CT"[XBMED) S XBFLG(1)="Media Type '"_XBMED_"' is incorrect",XBFLG=-1 G EOJ
 D ^ZIBGSVED
EOJ ;
 S:'$D(XBFLG) XBFLG=0
 K XBFN,XBGL,XBGLL,XBCARTNO,X1,X2,XBNAR,XBTLE,XBIO
 K XBPAR,XBDT,XBE,XBF,XBMED,%DT,XBUF
 K XBQ,XBQTO
 K X,XBFLT,XBSUFAC,Y ; XB*2.6*6
 Q

XBLCALL
XBLCALL ; IHS/ADC/GTH - LIST CALLABLE SUBROUTINES ; [ 02/22/95  3:01 PM ]
 ;;2.6;IHS/VA UTILITIES;**6**;MAR 20, 1991
 ;
 ; This routine lists callable subroutines that are known to this
 ; routine.  To add subroutines to this routine just add them to
 ; the end of this routine in same manner.
 ;
START ;
 NEW I,X,Y
 F I=1:1 S X=$T(@("L")+I) Q:X=""  W !,$P(X,";",3),$E("...............",1,15-$L($P(X,";",3))),$P(X,";",4,99) I '(I#20) D PAUSE^XB Q:$G(XBQ)
 Q
 ;
L ;
 ;;^XBCLS;Clears the screen
 ;;^XBDAD0;Returns DA array for D0,D1, etc. or vice versa
 ;;^XBDATE;Limits selected routines to those edited after given date
 ;;^XBDBQUE;Double Q'uing shell handler
 ;;^XBDIE;Exclusive NEW of Kernel vars for nesting DIE calls
 ;;^XBDIFF;Returns difference between two date/times
 ;;EN1^XBDSET;Return FileMan dictionaries
 ;;XBFDINFO^XBFDINFO(FILE,FIELD,ROOT);Return field info from dd
 ;;^XBFMK;Kills variables left around by FileMan
 ;;EN1^XBFRESET;Reset global(s), confirm with user
 ;;EN2^XBFRESET;Reset global(s), do not confirm with user
 ;;^XBGXFR;Copies global to another global
 ;;^XBGXREFS;Returns xrefs for file/subfile,field
 ;;DECFRAC^XBFUNC(DECIMAL VALUE);returns fraction equivilent
 ;;FNDPATRN^XBFUNC(STR,PAT);finds pattern in string
 ;;GETPATRN^XBFUNC(STR,PAT);returns pattern from string
 ;;INTSET^XBFUNC(FILE,FIELD,EXTVAL);returns internal value
 ;;EXTSET^XBFUNC(FILE,FIELD,INTVAL);returns external value
 ;;$$PROVCLS^XBFUNC1(PROV,FORM);Return Provider Class from New Person
 ;;$$PROVCLSC^XBFUNC1(PROV);Return Provider Class Code given New Person IEN
 ;;$$PCCPPINT^XBFUNC2(VISIT);Return primary provider ien from 200
 ;;$$PCCPPN^XBFUNC2(VISIT);Return visit primary provider (NAME)
 ;;$$PCCPPI^XBFUNC2(VISIT);Return visit primary provider (INITIALS)
 ;;$$PCCPPCLS^XBFUNC2(VISIT,FORM);Return visit primary provider class (CODE)
 ;;$$PCCPPCLC^XBFUNC2(VISIT);Return visit primary provider class (CODE)
 ;;$$PCCPPAFF^XBFUNC2(VISIT,FORM);Return visit primary provider (affiliation)
 ;;^XBFSAVE;Generic global save for transmission globals
 ;;EN1^XBKD;Kill DICs and globals, info in vars
 ;;EN2^XBKD;Kill DICs and globals, info in ^UTILITY("XBDSET",$J) 
 ;;^XBKERCLN;Clean out kernel namespace items prior to install
 ;;^XBKVAR;Set minimum Kernel vars
 ;;EN^XBNEW(XBRET,XBNS);Nest Die calls, "TAG^ROUTINE:VAR;NSVAR*"
 ;;XBPFTV^XBPFTV(FILE,ENTRY,VALUE);Returns terminal value for pointer
 ;;^XBPKDEL;Delete parts of package, namespace in XBPKNSP
 ;;EN1^XBRESID;Clean up residuals in ^DD from XBRLO to XBRHI
 ;;^XBSITE;Ask user to select site to set DUZ(2)
 ;;^XBUPCASE;Upcases value in X
 ;;^XBXTSS;Given (_subscripts_) in X returns subscripts in Y array
 ;;^ZIBRUN;Sets $T based on whether routine in X is running

XBPKDEL
XBPKDEL ; IHS/DG/OHPD - REMOVE OPTIONS, INPUT,SORT,PRINT TEMPLATES, HELP FRAMES, BULLETINS, FUNCTIONS,, AND IF INDICATED, SECURITY KEYS FOR A PACKAGE ; [ 02/15/95  12:25 PM ]
 ;;2.6;IHS/VA UTILITIES;**3**;JUN 28, 1993
 ;
 ;;XBPKNSP must be set to the namespace, i.e. "AICD" if this routine is called from a preinit.
 ;;If you want security keys deleted, set XBPKEY=1 if this routine is called from a preinit
 ;;
 ;;Call LIST^XBPKDEL to list all namespaced options, templates, etc.
 ;;Call RUN^XBPKDEL to delete all namespaced options, templates, etc.
 ;;The RUN and LIST entry points are for programmer use and are not to
 ;;be called from a preinit.  Preinit calls XBPKDEL directly with
 ;;variables set as indicated above
 ;
START ;
 I '$D(^DIC(0)) W !,*7,"Filemanager does not exist in this UCI!" Q
 I '$D(XBPKNSP) W !,*7,"Namespace variable does not exist!" Q
 S U="^",DUZ(0)="@",XBPKQUIT=XBPKNSP_"{"
 I $D(XBPKRUN) S XBPKDOC="This routine"
 E  S XBPKDOC="The preinit for this package"
 D ASK G:XBPKSTP A
 F XBPKGLO="^DIBT(","^DIPT(","^DIE(","^DIC(19,","^XMB(3.6,","^DIC(9.2,","^DD(""FUNC""," D DELETE
 I $D(XBPKEY) S XBPKGLO="^DIC(19.1," D DELETE ;DELETE SECURITY KEYS WITH THIS NAMESPACE
 W !
 S %=1 D ENASK^XQ3 ;CALL TO FIX OPTION POINTERS
 W !,*7,"Be sure to give users a new primary menu option if one of the menu options",!,"deleted within this namespace had been used as a primary menu option."
A D EOJ
 Q
 ;
ASK ;ASK USER IF WANTS TO CONTINUE
 S XBPKSTP=0
 W !!,*7,XBPKDOC," will delete all options, sort, input,"
 W !,"and print templates, bulletins, functions, "
 W $S($D(XBPKEY):"help frames and security keys",1:"and help frames")
 W !,"namespaced '",XBPKNSP,"' that are currently in this UCI.  "
 W !,"Do you want to continue" S %=1 D YN^DICN
 I %=0 W !!,"If you answer with a ""NO"" or a ""^"" I will stop package initialization.",! G ASK
 I %=2!(%=-1) W:'$D(XBPKRUN) !!,*7,"Package initialization process stopped!" S XBPKSTP=1 K DIFQ ;KILLING DIFQ STOPS THE INITIALIZATION PROCESS
 W ! Q
 ;
DELETE ;
 W !!,"Now deleting `",XBPKNSP,"' namespaced ",$P(@(XBPKGLO_"0)"),U)_"S..."
 S XBPKNSPC=XBPKNSP
 I $D(@(XBPKGLO_"""B"",XBPKNSPC)")) S DA=$O(@(XBPKGLO_"""B"",XBPKNSPC,"""")")),DIK=XBPKGLO D ^DIK K DIK,DA
 F L=0:0 S XBPKNSPC=$O(@(XBPKGLO_"""B"",XBPKNSPC)")) Q:XBPKNSPC=""!(XBPKNSPC]XBPKQUIT)  S DA=$O(@(XBPKGLO_"""B"",XBPKNSPC,"""")")) W !,?3,XBPKNSPC S DIK=XBPKGLO D ^DIK K DIK,DA
 Q
 ;
LIST ; ENTRY POINT FOR LISTING NAMESPACED ITEMS
 I '$D(^DIC(0)) W !,*7,"Filemanager does not exist in this UCI!" Q
 S U="^",DUZ(0)="@"
 W !!,"Utility to list all namespaced items in current UCI",!
 D GETNSP G:XBPKNSP["^"!("^"[XBPKNSP) EOJ
 W !!,"Listing of items in namespace ",XBPKNSP,!
 W "--------------------------------------",!
 S XBPKQUIT=XBPKNSP_"{"
 S XBPKF=0
 F XBPKGLO="^DIBT(","^DIPT(","^DIE(","^DIC(19,","^DIC(19.1,","^XMB(3.6,","^DIC(9.2,","^DD(""FUNC""," D LIST2
 G EOJ
LIST2 ;
 S XBPKNSPC=$O(@(XBPKGLO_"""B"",XBPKNSP)"))
 I $P(XBPKNSPC,XBPKNSP)'="" W:XBPKF ! S XBPKF=0 W "NO ",$P(@(XBPKGLO_"0)"),"^",1),"S",! Q
 S XBPKF=1
 W !,$P(@(XBPKGLO_"0)"),"^",1),"S",!
 S XBPKNSPC=XBPKNSP
 F  Q:$D(DUOUT)  S XBPKNSPC=$O(@(XBPKGLO_"""B"",XBPKNSPC)")) Q:XBPKNSPC=""!(XBPKNSPC]XBPKQUIT)  S DA=$O(@(XBPKGLO_"""B"",XBPKNSPC,"""")")) W ?3,XBPKNSPC,! I $Y>(IOSL-5) D PAUSE
 Q
 ;
PAUSE ; Screen control for LIST
 S DIR(0)="E" D ^DIR K DIR
 W @IOF
 Q
 ;
RUN ; ENTRY POINT FOR ACQUIRING CONTROL ARGUMENTS AND DOING DELETIONS
 I '$D(^DIC(0)) W !,*7,"Filemanager does not exist in this UCI!" Q
 I $S('$D(DUZ(0)):1,DUZ(0)'="@":1,1:0) W !,"PROGRAMMER ACCESS REQUIRED",! Q
 W !!,"Utility to delete all namespaced items in current UCI",!
 D GETNSP G:XBPKNSP["^"!("^"[XBPKNSP) EOJ
 D GETKEY I $D(XBPKEY),XBPKEY="^" G EOJ
 S XBPKRUN="" G XBPKDEL
 ;
GETNSP ; CODE TO ACQUIRE NAMESPACE
 R "Namespace to process: ",XBPKNSP:600,!
 Q:("^"[XBPKNSP)!(XBPKNSP["^")
 I XBPKNSP["?" W "Enter null line or '^' to quit.",!
 I XBPKNSP'?1U1.7UN W "Namespace must begin with an upper-case letter and",!," consist only of upper-case letters and numbers",! G GETNSP
 Q
GETKEY ; CODE TO ACQUIRE SECURITY KEY FLAG
 W "Do you want to delete security keys" S %=1 D YN^DICN
 I %=0 W !!,"If you answer with a ""NO"" security keys will not be deleted.",! G ASK
 I %=2!(%=-1) S:%=-1 XBPKEY="^"
 E  S XBPKEY=""
 Q
 ;
EOJ ;
 K XBPKGLO,XBPKEY,XBPKSTP,XBPKNSP,XBPKNSPC,XBPKQUIT,XBPKRUN,XBPKDOC,DUOUT,DTOUT
 Q
 ;

XBVLINE
XBVLINE ; IHS/ADC/GTH - SET LINE TWO OF SELECTED ROUTINES ; [ 02/22/95  10:29 AM ]
 ;;2.6;IHS/VA UTILITIES;**6**;MAR 20,1991
 ;
 ; This routine calls ^%RSEL to select a set of routines, asks the user
 ; for the version number, package, and the date, and sets the second
 ; line of each routine.
 ;
 ; The form of the version line will be as follows:
 ;
 ;;n;package name;patch level;date    E.G.
 ;;1.1;PCC DATA ENTRY;**1,2**;Sep 9, 1989
 ;
START ;
 NEW ASK,QUIT,RTN
 K ^UTILITY($J)
 D ^XBKVAR
 ;D ^%RSEL K QUIT
 X ^%ZOSF("RSEL")
 I $D(^UTILITY($J,"XBVLINE")) W !,"Can't do ^XBVLINE.  Deleting." K ^UTILITY($J,"XBVLINE")
 I $D(^UTILITY($J,"XB")) W !,"Can't do ^XB.  Deleting." K ^UTILITY($J,"XB")
 I $O(^UTILITY($J,""))="" D EOJ Q
 ;S DIR(0)="F^1:5^K:'(X?1.2N!(X?1.2N1"".""1.2N)) X",DIR("A")="Enter version number",DIR("?")="Must be n or n.n where the length of n is 1-2" D ^DIR K DIR
 S DIR(0)="F^1:5^K:'(X?1.3N!(X?1.3N.1""."".2N.1A.2N)) X",DIR("A")="Enter version number",DIR("?")="Must be n or n.n or n.nAn where the length of n is 1-3 and A is an alpha character" D ^DIR K DIR ; IHS/DSD/JCM 11/25/92
 I $D(DIRUT) D EOJ Q
 S XBVLINE=" ;;"_X
 S DIR(0)="FO^2:30",DIR("A")="Enter package name" D ^DIR K DIR
 I $D(DTOUT)!($D(DUOUT)) D EOJ Q
 S XBVLINE=XBVLINE_";"_X
 S DIR(0)="FO^1:20",DIR("A")="Enter patch level" D ^DIR K DIR
 I $D(DUOUT)!($D(DTOUT)) D EOJ Q
 S XBVLINE=XBVLINE_$S(X="":";",1:";**"_X_"**") ; XB*2.6*6
 S DIR(0)="D",DIR("A")="Enter date",DIR("B")="TODAY" D ^DIR K DIR
 I $D(DIRUT) D EOJ Q
 D DD^%DT
 S XBVLINE=XBVLINE_";"_Y
 S DIR(0)="YO",DIR("A")="Do you want to be asked ok for each routine",DIR("B")="NO",DIR("?")="If you say 'YES' you will be asked if it is ok before each routine is modified." D ^DIR K DIR
 I $D(DIRUT) D EOJ Q
 S ASK=Y
 F %=1:1:6 S X=$P($T(@("LINE"_%)),";;",2),@("XBVLINE("_%_")=X")
 K %,X,Y
 X XBVLINE(1)
 Q
 ;
EOJ ;
 K %,X,Y,XBVLINE,^UTILITY($J)
 K DTOUT,DUOUT,DIRUT,DIROUT
 Q
 ;
LINE1 ;;X XBVLINE(2),XBVLINE(5)
LINE2 ;;S QUIT=0,RTN="" F  S RTN=$O(^UTILITY($J,RTN)) Q:RTN=""  W !,RTN ZL @RTN X XBVLINE(6) ZR @Y ZI X S X=$T(+2),Z=$P(X," ")_XBVLINE X XBVLINE(3):'ASK,XBVLINE(4):ASK Q:QUIT  I X ZI Z:+1 ZS
LINE3 ;;S X=$P(X," ",2,99),X=X?1.2";".1"V"1.N.E ZR:X +2 S X=1
LINE4 ;;W !,X S DIR(0)="S^R:Replace;I:Insert;S:Skip",DIR("B")="R",DIR("?")="Replace the line; Insert before the line; Skip the routine" D ^DIR K DIR ZL @RTN ZR:Y="R" +2 S:$D(DIRUT) Y="S",QUIT=1 S X=Y'="S"
LINE5 ;;K %,XBVLINE,DTOUT,DUOUT,DIRUT,DIROUT,X,Y,Z,^UTILITY($J)
LINE6 ;;S X=$T(+1),X=$P(X,"["),Y=$L(X,";") S Y=$P(X,$S(X?1.8U1"(".E:"(",1:" "),1)

ZIBERR
ZIBERR ; IHS/ADC/GTH - REPORT ERROR ; [ 02/22/95  11:27 AM ]
 ;;2.6;IHS/VA UTILITIES;**6**;MAR 20, 1991 
 ; XB*2.6*6 IHS/ADC/GTH 02-22-95, Add to support XB.
 ;
ERR() ;EP
 NEW O
 S O=$P($G(^%ZOSF("OS")),"-",1)
 I '$L($T(@(O))) Q "OPERATING SYSTEM '"_O_"' NOT SUPPORTED."
 G @(O)
 ;
MSM ;
 Q $ZE
 ;

ZIBGSVED
ZIBGSVED ; IHS/DSD/GTH - SAVE GLOBAL TO TAPE, DSM SPECIFIC ; [ 02/15/95  12:24 PM ]
 ;;2.6;IHS/VA UTILITIES;**1,6**;MAR 20, 1991 
 I $G(XBFLT) S XBFLG=-1,XBFLG(0)="DSM flat filer has not been tested." Q  ; XB*2.6*6
 G:$D(XBMED) NOSELT
ASK ;
 R !!,"Copy transaction file to ('^' To Exit Without Saving)",!!?10,"[T]ape, [C]artridge  C// ",XBMED:DTIME
 S XBMED=$$UP^XLFSTR($E(XBMED_"C"))
 I U[XBMED S XBFLG(1)="Job Terminated by Operator at Device Select",XBFLG=-1 G END
 G HELP:"?"[XBMED,ASK:'("CT"[XBMED)
NOSELT ;
 S IO=XBIO
 D TAPE:"T"[XBMED,CART:"C"[XBMED
 Q
 ;
HELP ;
 W !!,"This option saves the ' ",XBNAR," ",XBGL,"' transaction file to either a Cartridge",!,"or 9-Track Tape.  The default is to a 9-Track Tape."
 W !,"Enter either a ""C"" for Cartridge Tape or a ""T"" for 9-Track Tape."
 G ASK
 ;
CART ;
 S XBIO=47,XBMSG="Cartridge"
 G PROCESS
TAPE ;
 S XBIO=48,XBMSG="9-Track"
PROCESS ;
 S IOP=XBIO D ^%ZIS K IOP
 S:'$D(XBPAR) XBPAR=IOPAR
 I POP S XBFLG(1)=XBMSG_" Drive Not Available",XBFLG=-1 U IO(0) W !,XBFLG(1) G END
 U IO
 X ^%ZOSF("MAGTAPE")
 W @%MT("REW")
 U IO(0) W !!,"Mount The ",XBMSG," Tape 'WRITE ENABLED' And "
RETRY ;
 R !,?10,"Press RETURN When Ready  - ""^"" to Exit ",X:DTIME
 I X=U!('$T) S XBFLG(1)="Job Aborted by Operator During Tape Mount",XBFLG=-1 G CLOSE
 U IO X ^%ZOSF("MTONLINE")
 I 'Y U IO(0) W !!,"WAITING FOR TAPE"
 F I=1:1:75 U IO X ^%ZOSF("MTONLINE") G S9:Y U IO(0) W "." H 5
 U IO(0) W !!,XBFLG(1)," After 6 Minutes"
 S XBFLG(1)="Job Aborted, Tape not Ready",XBFLG=-1
 G END
S9 ;
 U IO X ^%ZOSF("MTWPROT") G WRITPROT:Y
 U IO(0) W !,"Please Standby - Copying Data to ",XBMSG
 U IO D SAVEDSM
 G CLOSE:$D(XBFLG),EXIT
 ;
WRITPROT ;
 U IO(0)
 W *7,!!,"  The Tape Is WRITE PROTECTED. Please Remove The Tape,"
 W !,"  And Re-position The Write Protect/Enable Switch.",!,"  "
 G RETRY
 ;
EXIT ;
 X ^%ZOSF("MAGTAPE")
 U IO W @%MT("WTM"),@%MT("REW")
 U IO(0) W !!,"Rewinding tape. <WAIT>"
 F L=1:1:150 U IO X ^%ZOSF("MTBOT") G:Y GOODREW  U IO(0) W "." H 2
 S XBFLG=-1,XBFLG(1)="Tape not rewound"
 U IO(0) W !!,XBFLG(1),*7
 G CLOSE
 ;
GOODREW ;
 U IO(0)
 W !!,"Remove the tape... Press RETURN when Ready:" R X:DTIME
CLOSE ;
 D ^%ZISC
 U IO(0)
END ;
 K XBMSG
 Q
 ;
SAVEDSM ;
 W XBDT W:XBPAR'["V" !
 W XBTLE W:XBPAR'["V" !
 S X=XBGL_XBF_")"
 F  S X=$Q(@X) Q:X=""  Q:(XBE]"")&($P($P(X,"(",2),",")>XBE)  S Y=X S:$E(Y,2)="[" Y=U_$P(Y,"]",2,999) W Y W:XBPAR'["V" ! W @X W:XBPAR'["V" !
 W "**END**" W:XBPAR'["V" !
 W "**END**" W:XBPAR'["V" !
 Q

ZIBGSVEM
ZIBGSVEM ; IHS/DSD/GTH - SAVE GLOBAL TO MSM UNIX ; [ 02/15/95  12:24 PM ]
 ;;2.6;IHS/VA UTILITIES;**1,5,6**;MAR 20, 1991 
 I ^%ZOSF("OS")["PC"!($P($G(^AUTTSITE(1,0)),U,21)=2) G ^ZIBGSVEP
 G:$D(XBMED) NOSELT
ASK ;
 R !!,"Copy transaction file to  ('^' TO EXIT WITHOUT SAVING)",!!?10,"[T]ape, [C]artridge, [D]iskette, or [F]ile   F// ",XBMED:DTIME
 S XBMED=$$UP^XLFSTR($E(XBMED_"F"))
 I U[XBMED S XBFLG(1)="Job Terminated by Operator at Device Select",XBFLG=-1 G END
 G HELP:"?"[XBMED,ASK:'("CDFT"[XBMED)
NOSELT ;
 S (IO,XBZDEV)=XBIO
 D TAPE:"T"[XBMED,CART:"C"[XBMED,DISK:"D"[XBMED,UNIX:"F"[XBMED
 Q
 ;
HELP ;
 W !!,"This option saves the ' ",XBNAR," ",XBGL,"' transaction file to either a tape,",!,"a floppy diskette, or a Unix file. The default is to a unix file",!,"in the ",XBUF," directory."
 W !,"Enter either a ""C"" for tape cartridge, a ""T"" for 9-track tape, a ""D"" for floppy disk, or an ""F"" for Unix file."
 G ASK
 ;
DISK ;TRANSFER TX GLOBAL TO FLOPPY DISK
 U IO(0)
 W !!,"Mount a FORMATTED Floppy Diskette, 'WRITE ENABLED' ",*7,!,"Press RETURN When Ready  or ""^"" to Exit WITHOUT SAVING " R X:DTIME
 I X[U!('$T) S XBFLG(1)="Job Aborted by Operator During Floppy Mount",XBFLG=-1 G END
 I $$OPEN^%ZISH("/dev/","fd0","W") S XBERRMSG="Floppy Disk" G ERRMESS
 U IO I $$STATUS^%ZISH U IO(0) W !!,"Please",*7 G DISK
 U IO(0) W !,"Please Standby - Copying Data to Floppy",!
 U IO D SAVEMSM
 D ^%ZISC
 U IO(0) R !!,"Remove the Floppy... Press RETURN when Ready:",X:DTIME
 G END
 ;
UNIX ;TRANSFER TX GLOBAL TO UNIX FILE.
 S XBPRE=$E(XBGL,2,5),XBASUFAC=$S('$D(XBSUFAC):$P(^AUTTLOC(DUZ(2),0),U,10),1:XBSUFAC)
 S XBFN=$S('$D(XBFN):XBPRE_XBASUFAC_"."_XBCARTNO,1:XBFN)
 S XBTEMPFN=XBUF_"/"_XBFN
 S %=$$OPEN^%ZISH(XBUF_"/",XBFN,"W") I % S XBERRMSG=$S(%=1:"All Host File Servers Busy!",1:"UNIX File") G ERRMESS
 I '$D(ZTQUEUED) U IO(0) W !,"Please Standby - Copying Data to UNIX File ",XBTEMPFN,!
 U IO D SAVEMSM
 G CLOSE
 ;
TAPE ;
 S XBDEV="rmt0",XBMSG="9-Track"
 G TAPETST
CART ;
 S XBDEV="rct",XBMSG="Cartridge"
 ;
TAPETST ;TRANSFER GLOBAL TO CARTRIDGE OR 9-TRACK
 W !,"Do you want to test the ",XBMSG," DRIVE? (Y/N) Y//" R Y:DTIME
 S Y=$E(Y_"Y")
 I "Yy"[Y D TAPETEST G:$D(XBFLG) CLOSE I Y[U S XBFLG(1)="Job Aborted by Operator During Tape Test",XBFLG=-1 G END
S ;
 U IO(0)
 W !!,"Mount ",XBMSG," Tape, 'WRITE ENABLED' ",*7
 R !,"Press RETURN When Ready  - ""^"" to Exit ",X:DTIME
 I X[U S XBFLG(1)="Job Terminated By Operator at Mount Message",XBFLG=-1 G CLOSE
MAGOPEN ;
 I $$OPEN^%ZISH("/dev/",XBDEV,"W") S XBERRMSG="Magtape Device" G ERRMESS
 U IO I $$STATUS^%ZISH U IO(0) W !!,"Please",*7 G S
 U IO(0) W !,"Please Standby - Copying Data to Tape",!
 U IO D SAVEMSM
 G EXIT
 ;
SW U IO(0)
 W *7,!!,"  The Tape Is WRITE PROTECTED. Please Remove The Tape,"
 W !,"  And Re-position The Write Protect/Enable Switch.",!,"  "
 G MAGOPEN
 ;
ERRMESS ;
 S XBFLG(1)=XBERRMSG_" Not Available",XBFLG=-1
 I '$D(ZTQUEUED) U IO(0) W !,XBFLG(1)
 G END
EXIT ;
 D ^%ZISC
 U IO(0) W !!,"Rewinding tape. <WAIT>" W "." H 2
 W !!,"Remove the tape... Press RETURN when Ready:" R X:DTIME
 G END
 ;
CLOSE ;
 D ^%ZISC
END ;
 I XBMED="F",'$D(XBFLG),XBQ="Y" D UUCPQ
 D HOME^%ZIS ; XB*2.6*5
 K XBPRE,XBASUFAC,XBOUTDAT,XBINDATA,XBDEV,XBMSG,XBERRMSG,XBTEMPFN,XBZDEV
 Q
 ;
TAPETEST ;
 U IO(0)
 W !!,"TAPE TEST...Mount ",XBMSG," Tape, 'WRITE ENABLED' ",*7
 R !,"TAPE TEST...Press RETURN When Ready  - ""^"" to Exit ",X:DTIME
 I X[U S XBFLG(1)="Job Aborted by Operator during Tape Test",XBFLG=-1 Q
 W !,"TAPE TEST...Opening tape drive." H 1
 I $$OPEN^%ZISH("/dev/",XBDEV,"W") G TESTERR
 U IO I $$STATUS^%ZISH U IO(0) W !!,"Please",*7 G TAPETEST
 U IO(0) W !,"TAPE TEST...Tape drive opened.",!,"TAPE TEST...Writing test data to tape."
 H 1
WRITE ;
 S XBOUTDAT="TEST DATA RECORD WRITTEN TO TAPE ON "_XBDT
 U IO W XBOUTDAT,!,"**",!,"**",!!
 U IO(0) W !,"TAPE TEST...Data written."
 D ^%ZISC
 H 6
 U IO(0) W !,"TAPE TEST...Reading test data from tape.",!
 H 1
 I $$OPEN^%ZISH("/dev/",XBDEV,"R") G TESTERR
 U IO R XBINDATA:DTIME
 D ^%ZISC
 U IO(0) W !,"WROTE : '",XBOUTDAT,"'",!," READ : '",XBINDATA,"'"
 I XBINDATA=XBOUTDAT W !,"TAPE TEST...Successful."
 E  W !,"TAPE TEST...FAILED...$#@!" S XBFLG(1)="Tape Test Failed During Testing",XBFLG=-1
 Q
 ;
TESTERR ;
 S XBFLG(1)="Device Not Available During Tape Testing",XBFLG=-1
 U IO(0) W !,*7,XBFLG(1),*7
 Q
 ;
UUCPQ ;auto queue to uucp subroutine, must have system id in RPMS SITE file
 I $$JOBWAIT^%HOSTCMD("/usr/bin/sendto "_XBQTO_" "_XBUF_"/"_XBFN) S XBFLG=-1,XBFLG(1)="Queue of File to uucp Failed" ; XB*2.6*6
 E  W:'$D(ZTQUEUED) !,"Export file ",XBUF,"/",XBFN," queued up to be sent to ",XBQTO,"...",! ; XB*2.6*6
 Q
 ;
SAVEMSM ;EP - $QUERY thru global, write to output.
 I '$G(XBFLT) W XBDT,!,XBTLE,! ; XB*2.6*6
 S X=XBGL_XBF_")"
 F  S X=$Q(@X) Q:X=""  S Y=$P($P($P(X,")",1),"(",2),",",1) Q:'(Y?1.N)  Q:(XBE)&(Y>XBE)  S Y=X S:$E(Y,2)="[" Y=U_$P(Y,"]",2,999) W:'$G(XBFLT) Y,! W @X,! ; XB*2.6*6
 I '$G(XBFLT) W "**",!,"**",!! ; XB*2.6*6
 Q

ZIBGSVEP
ZIBGSVEP ; IHS/DSD/GTH - SAVE GLOBAL TO DOS MEDIA ; [ 02/15/95  12:25 PM ]
 ;;2.6;IHS/VA UTILITIES;**1**;MAR 20, 1991 
 S XBUF="C:\EXPORT"
 G:$D(XBMED) NOSELT
ASK ;
 R !!,"Copy transaction file to ('^' TO EXIT WITHOUT SAVING)",!!?10,"[D]iskette, or [F]ile   F// ",XBMED:DTIME
 S XBMED=$$UP^XLFSTR($E(XBMED_"F"))
 I U[XBMED S XBFLG(1)="Job Terminated by Operator at Device Select",XBFLG=-1 G END
 G HELP:"?"[XBMED,ASK:"DF"'[XBMED
NOSELT ;
 S IO=XBIO
 D DISK:"D"[XBMED,DOS:"F"[XBMED
 Q
 ;
HELP ;
 W !!,"This option saves the ' ",XBNAR," ",XBGL,"' transaction file to either a floppy",!,"diskette, or a Dos file on the Hard Disk. The default is to a Dos file",!,"in the ",XBUF," directory."
 W !,"Enter either a ""D"" for floppy disk, or an ""F"" for Dos file."
 G ASK
 ;
DISK ;TRANSFER TX GLOBAL TO FLOPPY DISK
 F  R !,"Select the drive (A,B,C):  B//",Y:DTIME S Y=$$UP^XLFSTR($E(Y_"B")) Q:"ABC"[Y  W:'(U[Y) "  ??" I U[Y!('$T) S XBFLG(1)="Abort at drive select",XBFLG=-1 G END
 S XBUF=Y_":"
 W !!,"Insert a FORMATTED Floppy Diskette into drive '",XBUF,"', 'WRITE ENABLED' ",*7,!,"Press RETURN When Ready  or ""^"" to Exit WITHOUT SAVING " R X:DTIME
 I X[U!('$T) S XBFLG(1)="Job Aborted by Operator During Floppy Mount",XBFLG=-1 G END
DOS ;TRANSFER TX GLOBAL TO DOS FILE.
 I '$D(ZTQUEUED) U IO(0) W !!,"DOS File Being Created' ",*7
 I '$D(XBFN) S X2=$E(DT,1,3)_"0101",X1=DT D ^%DTC S X=X+1,XBFN=$E(XBGL,2,5)_$E($P(^AUTTLOC(DUZ(2),0),U,10),3,6)_"."_X
 I $$OPEN^%ZISH(XBUF_"\",XBFN,"W") S XBERRMSG="DOS File" G ERRMESS
 U IO(0) W !,"Please Standby - Copying Data to DOS File ",XBUF,"\",XBFN
 U IO D SAVEMSM^ZIBGSVEM
 G END
 ;
ERRMESS ;
 S XBFLG(1)=XBERRMSG_" Not Available",XBFLG=-1
 U IO(0) W !,XBFLG(1)
END ;
 D ^%ZISC
 D HOME^%ZIS K XBERRMSG
 Q

ZIBRPI
ZIBRPI ; IHS/DSD/GTH - REMOTE PATCH INSTALLATION ;  [ 02/15/95  12:24 PM ]
 ;;2.6;IHS/VA UTILITIES;**4**;MAR 20, 1991 
 ;
 ; 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
 K ^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 % 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 % 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) K ^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)
 . U IO:(D_F)
 . R %,%
 . ; The ZL and ZS in the following line are non-standard M commands.
 . F  R % 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
 . 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_%)
 K ^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 K 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) D ZIS Q:'POP
 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
 ;
SYTM ;;dpssyg
PATTERN ;;2.4L.2"_"4N1"."1"p"1.2N
WORK ;;ZIBRPI.WRK
PUB ;;/usr/spool/uucppublic/
NS ;;ZIB_P

ZIBRPI1
ZIBRPI1 ; IHS/DSD/GTH - REMOTE PATCH INSTALLATION (1) ;  [ 02/15/95  12:24 PM ]
 ;;2.6;IHS/VA UTILITIES;**4**;MAR 20, 1991 
 ;
 W !!,"EXECUTION UNAUTHORIZED.",!
 Q
 ;
OPT ;EP - Set option in OPTION file.
 I $P(^%ZOSF("OS"),"^")'["MSM" W !!,"SORRY.  MSM only.",! Q
 I $S('$D(DUZ(0)):1,DUZ(0)'="@":1,1:0) W !,"PROGRAMMER ACCESS REQUIRED",! Q
 D HOME^%ZIS,DT^DICRW,00:'$L($P(^AUTTSITE(1,0),U,14))
 NEW ZIB,ZIBAREA,D,DA,DIC,DIE,DR,I,O,POP,W
 D HFS
 I POP W !,"HFS not available." Q
 D OS,HELP^ZIBRPI2("GEN")
 S Y=1,%="Enter a number to choose the systems to which you want this report sent"
 I $L($P(^AUTTSITE(1,0),U,14)) S DIR(0)="N^1:3:0",DIR("A")="Send reports to (1) "_$P($T(SYTM),";;",2)_" (2) "_$P(^(0),U,14)_" or (3) both",DIR("B")=2,DIR("?")=%,DIR("??")="^D HELP^ZIBRPI2(""SYSID"")" D DIR I $D(DIRUT) D ZISC Q
 K DIR
 S ZIBAREA="20///I "_Y
 S DIR(0)="F^1:245",DIR("A")="From what "_$P(O,U)_" directory do you want to restore patches",DIR("?")="Enter the full path name of a directory",DIR("??")="^D HELP^ZIBRPI2(""DIRECT"")"
 S:D("IN")]"" DIR("B")=D("IN")
 ; The following line is non-standard M because of the Q:$L(X)
 F  D DIR Q:$D(DIRUT)  D HC(O("LS")_Y_"* > "_W) S IOP=I,%ZIS("IOPAR")="("""_W_""":""R"")" D ZIS U IO R X U IO(0) Q:$L(X)  W "  Directory does not exist (or empty).",*7
 S D=Y
 D ZISC
 Q:$D(DIRUT)
 S ZIBAREA=ZIBAREA_" S:0 %="""_D
 S (DIR(0),DIR("B"))="Y",DIR("A")="If action routine '(A/B)9<pkg><patch#>' exists, do you want it ran",DIR("??")="^D HELP^ZIBRPI2(""ACTION"")"
 D DIR
 Q:$D(DIRUT)
 S ZIBAREA=ZIBAREA_U_Y_""""
 S DIC="^DIC(19,",DIC(0)="",X="ZIB REMOTE PATCH INSTALLATION",DIC("DR")="1///Remote Patch Installation;4///R;"_ZIBAREA_";25///START^ZIBRPI;200///T@2315;202///1D"
 F ZIB="ZIB REMOTE PATCH INSTALLATION","AZHL REMOTE PATCH INSTALLATION" I $D(^DIC(19,"B",ZIB)) S DIE=DIC,DA=$O(^DIC(19,"B",ZIB,0)),DR=".01///"_X_";"_ZIBAREA_";25///START^ZIBRPI" D DIE I 1 Q
 E  D FILE
 W !!,"Done."
 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
FILE NEW D,E,F,I,J,L,N,O,P,V,W K DD,DO D FILE^DICN Q
HC(%) NEW D,E,F,I,J,L,N,O,P,V,W S %=$$JOBWAIT^%HOSTCMD(%) 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) D ZIS Q:'POP
 I 'I,'$D(POP) S POP=1
 Q:POP
 S I=$P(^%ZIS(1,I,0),U)
 Q
 ;
OS ;
 S O=$P($P(^%ZOSF("OS"),","),"-",2)
 S O("PF")=$P($T(PATTERN^ZIBRPI),";",3)
 S W=$P($T(WORK^ZIBRPI),";",3)
 I O["UNIX" S (D("IN"),D("OUT"))=$P($T(PUB^ZIBRPI),";",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
 ;
SYTM ;;dpssyg
10 ;;abr-ab
11 ;;bji-ao
20 ;;albisc
30 ;;akarea
40 ;;bilcsy
50 ;;okc-ao
51 ;;nsa-oa
61 ;;cao-as
60 ;;phx-ao
70 ;;pordps
80 ;;nav-aa
00 ;;tucdev
 NEW DIE,DR,DA
 S DA=$P($T(@($P(^AUTTAREA($P(^AUTTLOC($P(^AUTTSITE(1,0),U),0),U,4),0),U,2))),";;",2),DR="W $J("""",IOM-$L(X)\2)_X,!!"
 W !!
 F X="A system id for your area computer does not exist in the RPMS SITE file.","Based on your area code, it should probably be '"_DA_"'.","Please enter an area system id into the RPMS SITE file, now.","(Calling DIE for you)." X DR
 S DIE="^AUTTSITE(",DR=".14//"_DA,DA=1
 D DIE
 Q

ZIBRPI2
ZIBRPI2 ; IHS/DSD/GTH - REMOTE PATCH INSTALLATION (2) ;  [ 02/15/95  12:24 PM ]
 ;;2.6;IHS/VA UTILITIES;**4**;MAR 20, 1991 
 ;
 W !!,"EXECUTION UNAUTHORIZED.",!
 Q
 ;
GEN ; General description
 ;;This utility creates an entry in the OPTION file which is scheduled
 ;;to run daily thru TaskMan.  Files matching the naming conventions
 ;;for patch files (specified in the 1 Sep 94 SAC, Appendix E), are
 ;;looked for in the directory you indicate.  If the package and
 ;;version the patches are intended for are installed on this machine,
 ;;the routines are restored from the file, an entry is made in the
 ;;VERSION multiple of the PACKAGE file entry, and a report file is
 ;;sent to the systems you indicate.  If an action routine (A9 or B9)
 ;;is detected during the ZLOAD, and you have indicated permission to
 ;;run action routines, the action routine is called after all routines
 ;;have been restored.
 ;;NOTE:  Use the same entry point, OPT^ZIBRPI, to edit any changes you
 ;;       want to make to the parameters.  If you un-schedule the
 ;;       option, you must use the TaskMan options to re-schedule it.
 ;;###
 ;
SYSID ; Select system id's to receive result files.
 ;;Please indicate what system id's you want reports of results sent to.
 ;;Selecting 1 will send the report just to that system.
 ;;Selecting 2 will send the report to (what is intended to be) the
 ;;Area machine.
 ;;Selecting 3 will send the report to both systems.
 ;;It is recommended you just configure the utility to send report files
 ;;to your area machine (option 2).
 ;;NOTE:  root will be notified upon arrival of a uucp'd result file.
 ;;       You must read the file manually.
 ;;###
 ;
DIRECT ;
 ;;Enter the name of the directory into which files containing patches
 ;;are uucp'd or BLAST'd, or otherwise placed.  This is usually the
 ;;/usr/spool/uucppublic directory on unix machines.  You can designate
 ;;any directory that you want, for security purposes, but you should
 ;;ensure that permissions are correctly set to receive the files, and
 ;;to read the files from the MUMPS level.
 ;;THIS DIRECTORY MUST EXIST PRIOR TO COMPLETING THIS SET-UP.
 ;;###
 ;
ACTION ;
 ;;If an action routine is include in the patch file, do you want it
 ;;called after all the routines are restored?  The action routine will
 ;;be named (A/B)9<namespace><patch_number>.  E.g., A9AUM12 will be the
 ;;action routine for patch 12 to the table updates.
 ;;NOTE:  This feature allows you to do any type of unattended activity
 ;;       on any/all of your systems.  There is no checking for verified
 ;;       RPMS applications.  There must simply be an entry in PACKAGE,
 ;;       and the versions must match.
 ;;###
 ;
HELP(L) ;EP - From DIR
 W !
 F %=1:1 W !?4,$P($T(@L+%),";",3) Q:$P($T(@L+%+1),";",3)="###"
 Q
 ;
 ; dpssyg Any ACU2400 FTS-505-262-6250 n:--n:--n: uucpdps word: uucpdps
 ; dpssyg Any x25pad 9600 dpssyg "" \r n:--n:-@-n: uucpdps word: uucpdps
 ;