8:25 AM 20-SEP-95 XB/ZIB v 2.6, patch 7, 41 routines. Restore the routines and DO ^XBP7. XB XB ; IHS/ADC/GTH - UTILITY MENU ; [ 08/22/95 3:57 PM ] ;;2.6;IHS/VA UTILITIES;**6,7**;JUN 28, 1993 ; XB*2.6*6 IHS/ADC/GTH 02-22-95, Add options, standardized code. ; XB*2.6*7 IHS/ADC/GTH 08-21-95 ; ; 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 ; XB*2.6*7 IHS/ADC/GTH 08-21-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 ; [ 09/08/95 4:04 PM ] ;;2.6;IHS/VA UTILITIES;**6,7**;JUN 28, 1993 ; XB*2.6*6 IHS/ADC/GTH 02-22-95, Add options, standardized code. ; XB*2.6*7 IHS/ADC/GTH 09-08-95 Removed Developers 16th option. ; ; 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 XBARRAY XBARRAY ; IHS/ADC/GTH ;[ 08/22/95 3:57 PM ] ;;2.6;IHS/VA UTILITIES;**7**;JUN 28, 1993 ; DOC ; This utility provides a word processing format of free text and ; local variable references to build an array. ; ; A file is necesary that has a .01 field for the form name and ; a WP field to hold the WP form. ; ; Please refer to routine XBFORM0 for documentation Q ; GEN(XBFORM,XBWPDIC,XBWPFLD,XBREF,XBFMT,XBLAST) ;EP ** generate array NEW XBLLINE S XBLLINE=$G(XBLAST) I $D(XBFORM(XBFORM)) D ZBUILD,REFBUILD,EXIT Q XBLLINE D WPGET,BUILD,ZBUILD D REFBUILD D EXIT Q XBLLINE ; EDIT(XBFORM,XBWPDIC,XBWPFLD) ;EP Edit a Form EDIT2 ; KILL XBFORM(XBFORM) S XBLLINE=0,XBFMT=1 D EDITWP,WPGET,BUILD,ZBUILD D ARRAY^XBLM("XBZ(",XBFORM) I $$DIR^XBDIR("S^R:Re-Edit;Q:Quit")="R" K XBZ G EDIT2 D EXIT K XBLLINE Q ; EDITWP ;** edit WP array K DIE,DIC,DA,DR S DIC=XBWPDIC,DR=XBWPFLD S DIC(0)="AEQMLZ" I $L($G(XBFORM))>0 S X=XBFORM,DIC(0)="XL" D ^DIC I Y'>0 S XBQUIT=1 Q S DIE=$$DIC^XBDIQ1(XBWPDIC) S DA=+Y,DR=XBWPFLD D ^DIE Q ; WPGET ;** get WP array KILL XBWP,XBL,XBOUT,XBVAR,XBWWP,DIC,DR,DIE,DA S X=XBFORM,DIC=XBWPDIC,DR=XBWPFLD,DIC(0)="X" D ^DIC I Y'>0 S XBWP(1)=XBFORM_" NOT FOUND",XBQUIT=1 S DA=+Y D ENP^XBDIQ1(XBWPDIC,DA,XBWPFLD,"XBWWP(") S %X="XBWWP("_XBWPFLD_",",%Y="XBWP(" D %XY^%RCR K XBWWP Q ; BUILD ;** scan WP array to build XBL S XBWPL="",XBLINE=0 Q:$D(XBFORM(XBFORM)) F S XBWPL=$O(XBWP(XBWPL)) Q:XBWPL'>0 D LINE Q ; LINE ;** process one line of the WP array S Z=XBWP(XBWPL) S XBLINE=XBLINE+1 F I=1:1:$L(Z) S A=$E(Z,I) D Q:$G(XBQUIT) . I I=1,A="#" D MAP S I=$L(Z),XBLINE=XBLINE-1,XBQUIT=1 Q . I I=1,A="*" D OUT S I=$L(Z),XBLINE=XBLINE-1,XBQUIT=1 Q . I I=1,A=";" S I=$L(Z),XBLINE=XBLINE-1,XBQUIT=1 Q . I A'=" ",A'="~" D TEXT Q . I A="~" D VAR Q KILL XBQUIT Q ; ZBUILD ;** build Z array from XBL KILL Z I '$G(XBFMT) F XBL=1:1 D Q:('$O(XBFORM(XBFORM,XBL))) . I '$D(XBFORM(XBFORM,XBL)),$O(XBFORM(XBFORM,XBL)) S XBZ(XBL+XBLLINE)=" " Q . D FILL I $G(XBFMT)=1 F XBL=1:1 D Q:('$O(XBFORM(XBFORM,XBL))) . I '$D(XBFORM(XBFORM,XBL)),$O(XBFORM(XBFORM,XBL)) S XBZ(XBL+XBLLINE,0)=" " Q . D FILL Q ; REFBUILD ; %RCR BACK TO CALL S %Y=XBREF,%X="XBZ(" D %XY^%RCR S XBLLINE=XBLLINE+XBL Q ; FILL ;** fill one line S XBCOL=0,T="" F S XBCOL=$O(XBFORM(XBFORM,XBL,XBCOL)) Q:XBCOL'>0 D . S X=XBFORM(XBFORM,XBL,XBCOL) . S XBCOLX=XBCOL . I XBCOL#1 S XBCOLX=XBCOL\1,X="S X="_X X X . S XBXL=$L(X) Q:X="" . S T=$$SETSTR^VALM1(X,T,XBCOLX,XBXL) I T="" S XBLLINE=$G(XBLLINE)-1 Q S:'$G(XBFMT) XBZ(XBL+XBLLINE)=T S:($G(XBFMT)=1) XBZ(XBL+XBLLINE,0)=T Q ; TEXT ;** NEW W S XBCOL=I F W=I:1:$L(Z) S A=$E(Z,W) Q:A="~" I W'=$L(Z) S W=W-1 S XBT=$E(Z,I,W) S XBFORM(XBFORM,XBLINE,XBCOL)=XBT,I=W Q ; VAR ;** add .5 to column count to indicate a variable vs text S XBCOL=I F W=I+1:1:$L(Z) S A=$E(Z,W) I A="~" Q ;I W=$L(Z) S W=W+1 S XBT=$E(Z,I+1,W-1) S XBFORM(XBFORM,XBLINE,XBCOL+.5)=XBT,I=W I XBT'["|" D Q . Q:'$D(XBOUT(XBT)) . S O=XBOUT(XBT),XBT=$P(O,"X")_XBT_$P(O,"X",2) . S XBFORM(XBFORM,XBLINE,XBCOL+.5)=XBT .Q S XBV=$P(XBT,"|"),XBV=XBVAR(XBV) S XBS=$P(XBT,"|",2) I $L(XBS) S XBS="("_XBS_")" S XBFORM(XBFORM,XBLINE,XBCOL+.5)=XBV_XBS I $D(XBOUT(XBT)) D . S O=XBOUT(XBT),XBT=XBV_XBS,XBT=$P(O,"X")_XBT_$P(O,"X",2) . S XBFORM(XBFORM,XBLINE,XBCOL+.5)=XBT .Q Q ; MAP ;** map shorthand for variables ;#xx1|yyy1*xx2|yyy2* S Z=$E(Z,2,999) I Z'["*" S XBVSUB=$P(Z,"|"),XBVAL=$P(Z,"|",2),XBVAR(XBVSUB)=XBVAL Q F I=1:1 S P=$P(Z,"*",I) Q:P="" S XBVSUB=$P(P,"|"),XBVAL=$P(P,"|",2),XBVAR(XBVSUB)=XBVAL Q ; OUT ;** output tranform of data field ;*field|mumps output transform f(x)* S Z=$E(Z,2,999) I Z'["*" S XBVSUB=$P(Z,"!"),XBVAL=$P(Z,"!",2),XBOUT(XBVSUB)=XBVAL Q F I=1:1 S P=$P(Z,"*",I) Q:P="" S XBVSUB=$P(P,"!"),XBVAL=$P(P,"!",2),XBOUT(XBVSUB)=XBVAL Q ; TABS ; W # F %=0:1:7 W ?%*10,%*10 F %=1:1:66 W !,?1,%,?3,"..^...." F X=1:1:7 W "|....^...." Q ; EXIT ; KILL %X,%Y,A,I,L,O,P,T,W,X KILL XBZ,XBFMT,XBCOL,XBCOLX,XBF,XBL,XBLINE,XBLN,XBLOAD,XBOUT,XBQUIT,XBROU,XBS,XBT,XBTAG,XBTAGE,XBV,XBVAL,XBVAR,XBVSUB,XBWP,XBWPDA,XBWPDIC,XBWPFLD,XBWPL,XBWPNODE,XBWPSUB,XBWWP,XBX,XBXL Q ; MDY(X) ;external date to mm/dd/yy x :: var or ~"NOW"~ or ~"TODAY"~ S %DT="TS" D ^%DT Q $E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) ; WP(X) ;build wp entry X #:: WP(FLD,n)=TEXTn NEW I,W S XBLWP=$G(XBLLINE) S W=$P(X,")") F I=0:1 S X=$Q(@X) Q:X="" Q:(W'=$P(X,",")) D . S T=@X,XBLLINE=XBLWP+I . S:'$G(XBFMT) XBZ(XBL+XBLLINE)=T . S:($G(XBFMT)=1) XBZ(XBL+XBLLINE,0)=T Q "" ; XBARRAY0 XBARRAY0 ; IHS/ADC/GTH - Documentation for XBARRAY ; [ 08/22/95 3:57 PM ] ;;2.6;IHS/VA UTILITIES;**7**;JUN 28, 1993 ; DOC ; This utility provides a word processing format of free text and ; local variable references to build an array. ; ; A file is necesary that has a .01 field for the form name and ; a WP field to hold the WP form. ; ; Two Entry points ; ; EDIT^XBARRAY(.NAME,DIC,FIELD) Edits and Displays the form. ; Place the call to EDIT in the code where the data or ; variables have been gathered. Typically this is one line ; previous to the call to $$GEN^XBARRAY. Once the form is ; designed the EDIT call is commented out. ; ; $$GEN^XBARRAY(.NAME,DIC,FIELD,ROOT,FORMAT,LINE) ; Generates the form into the ARRAY indicated by the ROOT. ; The call to $$GEN must have all variables used gathered. ; The return value of $$GEN is equal to the last line set ; in the array. ; ; VARIABLES ; .NAME The name space variable that holds the name of the form ; to be used. A pass by reference is needed for effeciency ; so that the pre-compilation of the form is held for ; repetative use. The compilation is stored in the sub ; array as NAME(@NAME,line,.....,). IE one local variable ; can be used for all form references. ; Ex: S BARFORM="A/R BILL" will store and use the form ; compilation in BARFORM("A/R BILL",line,....,) ; When finished K BARFORM(BARFORM) will retrieve the local ; variable space from the last form used. ; ; DIC The root or file number of the file holding the forms. ; ; FIELD The field number of the WP field holding the form. ; ; ROOT The root of the target array to be built. ; Either a global or a variable root as in the format used ; for a %XY^%RCR call. (%RCR is actually used) ; ; FORMAT null or zero The array is built ROOT(line)="... ; 1 The array is built ROOT(line,0)=".... ; ; LINE The offset in line numbers in building the array. ; The array will start construction at LINE +1. ; The value of the last line created is returned $$GEN. ; ; WP FORMAT INSTRUCTIONS ; ; Free Text: Free text is key striked in where desired. ; Do not use ~ as it is used to mark varibles. ; Variables: The reference to a variable is marked with ; a beginning ~ and a trailing ~. The trailing ; ~ is always required even if the variable is ; last item on the line. ; ; Mneumonics A short hand for variables is available. ; Comments Programmers comments can be put into the form ; which are ignored by the generator. ; Output Tranform Mumps output transforms can be indicated for ; execution upon selected variables. ; ; WP SPECIAL FUNCTIONS Located at the top of the form. ; ; Comment line Begin the line with a ';' ; ; Variable Mneumonic Name spaced variables can be long. A mneumonic ; Reference reference is available to make life simple. ; Multiple mneumonic lines can be used if desired ; SETUP ; ; #mneumonic1|variable1*mneumonic2|variable2*... ; #mneumonicZ|variableZ*..... ; ; Example: #D|DUZ*V|BARVPT ; #I|BARIPT ; ; (BARIPT array is storing IHS Patient Information) ; (BARVPT array is stroing VA Patient Information) ; ; ; '#' Marker placed in the fist column ; ; mneumonic1 User's choice ; ex: D to denote DUZ ; '|' Seperator ; ; variable1 User's choice of the local variable ; ex: DUZ ; '*' Repetative marker if more than one ; mneumonic is indicated ; ; USE The mneumonic reference can be used any where ; in the WP form. ; Format ~mneumonic|variable subscript~ ; ; '~' Beginning marker for the variable ; ; mneumonic1 User's mneumonic ; ; '|' Separator ; ; subscript The subscript of the variable to be used ; ; '~' Ending marker for the variable ; ; ex: ~D|~ for DUZ ; ~D|0~ for DUZ(0) ; ~I|.01~ for BARIPT(.01) ; ; MUMPS OUTPUT A simple mumps output transform is also ; TRANSFORM provided to aid in form design. A variable or ; mneumonic indicated will have its output ; transformed prior to being put into the form. ; ; SETUP ; ; *var1!mumps code1*var2!mumps code2 ; *mneumonic3!mumps code3*mneumonic4!mumps code4 ; ; Ex: *DUZ(2)!$J(X,10,2) will output $J(DUZ(2),10,2) ; *D|2!$J(X,10,2) mneumonic notation of same ; ; '*' Output Tranform marker in column one. At TOF ; ; Variable/ Variable or mneumonic as it would appear in the ; Mneumonic form between '~'s. ; ; '!' Seperator ; ; mumps code Mumps code expression as a function of x. ; Do not state 'S X=f(x)' ; Enter the function only, f(x). ; ; '*' Seperator if more than one is put on one line. ; ; SPECIAL OUTPUT TRANSFORMS provided by XBARRAY ; ; xxx!$$MDY(X) a literal ~"NOW"~ or variable ~IT|9~ ; ex: *"NOW"!$$MDY(X) or *IT|9!$$MDY(X) ; returns mm/dd/yy ; ; xxx!$$WP("X") for a word processing field ; NOTE: "X" IS ABSOLUTELY NECESSARY ; The variable array must have the form ; VAR(subcript,n) where n = 1:1 ; DOCE ; ; TEST ; If you have A/R installed, uncomment the following lines for a ; demonstration. ; D INIT^BARUTL ; D ENP^XBDIQ1(200,DUZ,".01:.116","BARU(") ; S BARFORM="PW TEST" ; D EDIT^XBARRAY(.BARFORM,90053.01,1000) ; S Y=$$GEN^XBARRAY(.BARFORM,90053.01,1000,"BARFM",0,10) ; K BARFORM(BARFORM) ; Q ; XBBPI XBBPI ; IHS/ADC/GTH - BUILD PACKAGE PRE-INIT ROUTINE ; [ 08/22/95 4:05 PM ] ;;2.6;IHS/VA UTILITIES;**7**;JUN 28, 1993 ; XB*2.6*7 IHS/ADC/GTH 07-10-95, Corrected piece for pre-init routine and Z calls. ; ; This routine builds a pre-init routine for a specified package. ; The pre-init routine will delete FileMan dictionaries being ; created by the package. Data globals and templates will be ; saved. ; START ; D ^XBKVAR W !!,"This routine will build a pre-init routine for the specified package." W !,"The pre-init routine will call XBKD to delete the FileMan dictionaries" W !,"being created by the package. Data globals and templates will be saved.",!! F XBBPLOOP=0:0 D PACKAGE Q:Y<0 D BUILD K %,XBBPLOOP Q ; PACKAGE ; S DIC="^DIC(9.4,",DIC(0)="AEMQ" D ^DIC K DIC Q ; BUILD ; S XBBPDFN=+Y S XBBPPRFX=$P(^DIC(9.4,XBBPDFN,0),U,2) S Y=DT D DD^%DT S XBBPVER=$S($D(^DIC(9.4,XBBPDFN,"VERSION")):^("VERSION"),1:"")_";"_$P(^DIC(9.4,XBBPDFN,0),U,1)_";;"_Y S XBBPPGM=XBBPPRFX_"PREI" D CHECKRTN I XBBPFLG D EOJ3 W !!,"Bye",! Q K ^UTILITY("XBBPI",$J),^UTILITY("XBBPPGM",$J),^UTILITY("XBBPI EXEC",$J) W "." S (XBBPX,XBBPFLE)=0 F XBBPL=0:0 S XBBPFLE=$O(^DIC(9.4,XBBPDFN,4,"B",XBBPFLE)) Q:XBBPFLE'=+XBBPFLE S ^UTILITY("XBBPI",$J,XBBPFLE)="" W "." S XBBPFLG=0,XBBPFLE="" F XBBPL=0:0 S XBBPFLE=$O(^UTILITY("XBBPI",$J,XBBPFLE)) Q:XBBPFLE'=+XBBPFLE I '$D(^DIC(XBBPFLE)) S XBBPFLG=1 W !,XBBPFLE," does not exist in ^DIC!" I XBBPFLG W !!,"All files in package must exist. Fix and rerun.",!! D EOJ Q W "." S XBBPFLE="" F XBBPL=0:0 S XBBPFLE=$O(^UTILITY("XBBPI",$J,XBBPFLE)) Q:XBBPFLE'=+XBBPFLE S ^(XBBPFLE)="^UTILITY(""XBDSET"",$J,"_XBBPFLE_")=S^S" W "." S %DT="",X="T" D ^%DT X ^DD("DD") S ^UTILITY("XBBPPGM",$J,1,0)=XBBPPGM_" ;CREATED BY XBBPI ON "_Y ; XB*2.6*7 IHS/ADC/GTH 07-10-95 S ^UTILITY("XBBPPGM",$J,2,0)=" ;;"_XBBPVER ; XB*2.6*7 IHS/ADC/GTH 07-10-95 F XBBPI=1:1:3 S ^UTILITY("XBBPPGM",$J,XBBPI+2,0)=$P($T(DTA+XBBPI),";;",2,99) ; XB*2.6*7 IHS/ADC/GTH 07-10-95 S XBBPFLE=0 F XBBPI=6:1 S XBBPFLE=$O(^UTILITY("XBBPI",$J,XBBPFLE)) Q:XBBPFLE'=+XBBPFLE S XBBPY=^(XBBPFLE),^UTILITY("XBBPPGM",$J,XBBPI,0)=" ;;"_XBBPY ; XB*2.6*7 IHS/ADC/GTH 07-10-95 S DIE="^UTILITY(""XBBPPGM"",$J,",X=XBBPPGM,XCN=0 ; XB*2.6*7 IHS/ADC/GTH 07-10-95 X ^%ZOSF("SAVE") ; XB*2.6*7 IHS/ADC/GTH 07-10-95 ; S ^UTILITY("XBBPI EXEC",$J)="S XBBPP="""_XBBPPGM_""",XBBPY=0 ZR X ""F XBBPL=0:0 S XBBPY=$O(^UTILITY(""""XBBPPGM"""",$J,XBBPY)) Q:XBBPY'=+XBBPY ZI ^(XBBPY)"" ZS @XBBPP" ; XB*2.6*7 IHS/ADC/GTH 07-10-95 ; X ^UTILITY("XBBPI EXEC",$J) ; XB*2.6*7 IHS/ADC/GTH 07-10-95 D EOJ Q ; CHECKRTN ; S XBBPFLG=0 Q:'$D(^DD("OS"))#2 Q:'$D(^DD("OS",^DD("OS"),18))#2 S X=XBBPPGM X ^(18) E Q CR2 ; W !!,XBBPPGM," already exists. Want to recreate it (Y/N) Y//" D YN^DICN S:$E(%Y)="N" XBBPFLG=1 Q ; EOJ ; W !!,"Routine ",XBBPPGM," has been filed.",!! I '$D(^DIC(9.4,XBBPDFN,"PRE")) D EOJ2 I $D(^DIC(9.4,XBBPDFN,"PRE")),^("PRE")="" D EOJ2 I 1 E I $D(^DIC(9.4,XBBPDFN,"PRE")),$P(^("PRE"),U)'=XBBPPGM W !!,"Package ",XBBPPRFX," has a pre-initialization routine entry but it is ",^("PRE"),"!" ; XB*2.6*7 IHS/OHPRD/EDE 07-07-95 D EOJ3 Q ; EOJ2 ; W !,"Package ",XBBPPRFX," has no pre-initialization routine entry!",! Q ; EOJ3 ; K ^UTILITY("XBBPI",$J),^UTILITY("XBBPPGM",$J),^UTILITY("XBBPI EXEC",$J) K %,%DT,DIE,XCN ; XB*2.6*7 IHS/ADC/GTH 08-14-95 K XBBPDFN,XBBPFLE,XBBPFLG,XBBPI,XBBPL,XBBPP,XBBPPGM,XBBPPRFX,XBBPX,XBBPY Q ; DTA ; ;; K ^UTILITY("XBDSET",$J) F XBBPI=1:1 S XBBPIX=$P($T(Q+XBBPI),";;",2) Q:XBBPIX="" S XBBPIY=$P(XBBPIX,"=",2,99),XBBPIX=$P(XBBPIX,"=",1) S @XBBPIX=XBBPIY ;; K XBBPI,XBBPIX,XBBPIY D EN2^XBKD ;;Q Q XBDIQ0 XBDIQ0 ; IHS/ADC/GTH - Documentation for XBDIQ1 ; ;;2.6;IHS/VA UTILITIES;**7**;SEP 19, 1995 DOCB ; Documentation for XBDIQ1 ; ; This routine provides a friendly front end to EN^DIQ1 and ; an assortment of other features. ; ; 1. Data arrays are returned into 'DIQ in a variety of formats ; controlled by the parameter set into DIQ(0). ; The default is 'DIQ(FLDNUM)= external value of field ; FLDNUM is the DD number of the field as used in DR. ; ; 2. Data retrieval is non-intrusive! Does not disturb the partition. ; ; 3. Input Variables used are the same as for EN^DIQ1 with ; more friendly results. ; ; 4. DR(filenumber and DA(filenumber arrays are automatically built ; when needed. ; ; ENTRY POINTS ; ; ENP^XBDIQ1(DIC,DA,DR,DIQ,DIQ(0)) ; Returns 'DIQ(FLDNUM)= data for One Entry ; ; ENPM^XBDIQ1(DIC,DA,DR,DIQ,DIQ(0)) ; Returns 'DIQ(DA,FLDNUM)= data for Multiple Entries ; DIC("S") can be set and used for screening entries ; ; $$VAL^XBDIQ1(DIC,DA,DR) ; Returns External value of one field. ; ; $$VALI^XBDIQ1(DIC,DA,DR) ; Returns Internal value of one field. ; ; $$DIC^XBDIQ1(DIC) Returns constructed DIC from file/subfile number ; ; PARSE^XBDIQ1(DA) ; Returns a DA array from a literal string made from Variables ; or Numbers mixed in descending order. ; EXMP: "1,DFN,56" => DA=56,DA(1)=34,DA(2)=1 where DFN=34 ; also: S VAR(I)="1,DFN,56" D PARSE^XBDIQ1(VAR(I)) => as above ; ; EN Returns one Entry (DR) fields ; needs DIC,DA,DR,DIQ,DIQ(0) as set up for calls ; to EN^DIQ1 ; ; ENM Returns Multiple Entry's (DR) fields ; 1) upper DA array ie: DA(1),DA(2), ... ; 2) DA="" in the passing array ; 3) optional DIC("S") ; needs DIC,DA,DR,DIQ,DIQ(0) as set up for calls ; to EN^DIQ1 ; DIQ(0)=1 BY DEFAULT ; ; DIQ(0) Format Options ; ; DIQ(0) If DIQ(0) is not present the default is set to NULL ; ; 0 OR NULL DIQ(FLD)= ; 1 DIQ(DA,FLD)= ; 2 DIQ(DA(x),..,DA,FLD)= ; nI DIQ(... ,FLD,"I")=internal value(s) returned ; nN NULL fields are not returned ; ; DA can be the array .DA or a literal string in descending order ; "1,23,45" ; "1,PATDFN,BLDFN" variables will be unfolded ; BARVDA("EOBSUB") ("EOBSUB")="BAFCLDA,BARITDA,BAREDA" ; DOCE Q XBDIQ1 XBDIQ1 ; IHS/ADC/GTH - SPECIAL EN^DIQ1 DATA PULLER ; [ 09/20/95 8:18 AM ] ;;2.6;IHS/VA UTILITIES;**7**;JUN 28, 1993 ; XB*2.6*7 IHS/ADC/GTH - This routine has been included in patch 7 ; at the request of the field. Some differences were found in ; this routine and the same routine on operational machines. ; DOC ; routine API documented in XBDIQ0 Q ;-- EN ;EP - single entries NEW XB0,XBDIC,XBFN,XBGBL,XBNEWPAR,XBGL S XBDIC=DIC I DA'=+DA D PARSE(DA) D DICFNGL(DIC) D ^XBSFGBL(XBFN,.XBGBL) S XBDIC=$P(XBGBL,"DA,") S DIC=XBDIC D ENDIQ1 D EXIT Q ;-- ENP(DIC,DA,DR,DIQ,XBFMT) ;EP - param pass into EN S:'$D(DIQ(0)) DIQ(0)=$G(XBFMT) D EN Q ;-- ENPM(DIC,DA,DR,DIQ,XBFMT) ;EP - param pass into EN S:'$D(DIQ(0)) DIQ(0)=$G(XBFMT) D ENM Q ;-- ENM ;EP - get multiple entries NEW XB0,XBDIC,XBFN,XBGBL,XBNEWPAR,XBGL S XBDIC=DIC S:$G(DA)="" DA=0 I DA'=+DA D PARSE(DA) S:(+$G(DIQ(0))'>0) DIQ(0)=1_$G(DIQ(0)) D DICFNGL(DIC) S XBDIC=$P(XBGL,"DA,"),DIC=XBDIC,DA=0,DIC(0)="" F S DA=$O(@(XBDIC_"DA)")) Q:DA'>0 D . S XB0=@(XBDIC_"DA,0)") . I $D(DIC("S")) S X="`"_DA D ^DIC Q:Y'>0 . S DIC=XBDIC . D ENDIQ1 .Q S DA="" D EXIT Q ;-- ENDIQ1 ;EP - call EN^DIQ1 NEW XBDIQ,XBGBL0,XBGLS,XBLVL,XBUDA,XB,XB0 S XBDIQ=DIQ,XBDIQ(0)=$G(DIQ(0)) NEW DIQ,XBDTMP D LEVELS D . NEW DIC,DR,DA . D SETDIQ1 . D ENDIQ1X .Q D PULLDIQ1 ; Q:XBDIQ(0)'["I" ; Internal if XB["I" K DIC S DIC=XBDIC ;reset dic S DIQ(0)="I" D ENDIQ1X,PULLDIQ1 K ^UTILITY("DIQ1",$J) Q ;-- ENDIQ1X ;ep - to call diq1 with new ;S XBNEWPAR="ENDIQ1XN^XBDIQ1:DR;DA;DIC;DIQ;XBDTMP" D ^XBNEW(XBNEWPAR) I $G(XBDIQ1(0))["N" S DIQ(0)=$G(DIQ(0))_"N" I $G(XBFMT)["N",$G(DIQ(0))'["N" S DIQ(0)=$G(DIQ(0))_"N" D EN^XBNEW("ENDIQ1XN^XBDIQ1","DR;DA;DIC;DIQ;XBDTMP") Q ;-- ENDIQ1XN ;EP S DIQ="XBDTMP(" D EN^DIQ1 Q ;-- EXIT ;EP KILL XBI,XBDEST,XBNEWPAR Q ;-- PULLDIQ1 ;EP - PULL FROM ^UTILITY("DIQ1",$J) D %XY S XBGLS=XBDIQ_"""ID"")" S @XBGLS=DA_":"_DIC_":"_XBUDA_":"_+XBDIQ(0) D %XY^%RCR Q ;-- %XY ;EP - set %X & %Y to format KILL %X,%Y S XBUDA="" 0 I +XBDIQ(0)=0 D Q .S %X="XBDTMP("_XBFN_","_DA_"," .S %Y=XBDIQ 1 I +XBDIQ(0)=1 D Q .S %X="XBDTMP("_XBFN_"," .S %Y=XBDIQ .S XBUDA=DA_"," 2 I +XBDIQ(0)=2 D Q .S %X="XBDTMP("_XBFN_"," .D ;build da(x),..,da subscripts ..S %Y="" F %=1:1 Q:'$G(DA(%)) S %Y=DA(%)_","_%Y .S XBUDA=%Y_DA_"," .S %Y=XBDIQ_%Y %XYE Q ;-- DICFNGL(X) ;EP - set XBFN & XBGL0 return 1 error NEW Y KILL XBGL,XBFN I X S XBFN=X D ^XBSFGBL(XBFN,.XBGL) Q I 'X S Y=X_"0)" S XBFN=+$P(@Y,U,2),Y=0 D ^XBSFGBL(XBFN,.XBGL) Q ;-- DICFNGLX Q ;-- VAL(DIC,DA,DR) ;EP - extrinsic pull a value for a field NEW DIQ,XBT S DIQ="XBT(" D EN Q XBT(+DR) ;-- VALI(DIC,DA,DR) ;EP - extrinsic pull a value for a field NEW DIQ,XBT S DIQ="XBT(",DIQ(0)="I" D EN Q XBT(+DR,"I") ;-- PARSE(XBDA) ;EP - parse DA literal into da array NEW D,I,J F I=1:1 S D(I)=$P(XBDA,",",I) Q:D(I)="" S I=I-1 F J=0:1:I-1 S DA(J)=D(I-J) F J=0:1:I-1 F Q:(DA(J)=+DA(J)) S DA(J)=@(DA(J)) S DA=DA(0) K DA(0) Q ;-- DIC(XBFN) ;EP - Extrensic entry to return DIC from global NEW XBDIC D EN^XBSFGBL(XBFN,.XBDIC) S XBDIC=$P(XBDIC,"DA,") Q XBDIC ;-- LEVELS ;EP - setup XB_FN_DA_DR_FLD arrays for upper levels it they exist ;set bottom level KILL XB S XBLVL=0 S XB(0,"DR")=DR,XB(0,"DA")=DA,XB(0,"FN")=XBFN S XB(0,"FLD")="" S XB(0,"PAR")=$G(^DD(XB(0,"FN"),0,"UP")) S:XB(0,"PAR")]"" XB(XBLVL,"FLD")=$O(^DD(XB(0,"PAR"),"SB",XB(0,"FN"),"")) D ^XBSFGBL(XB(0,"FN"),.XBGBL0) S XB(0,"GBL")=$P(XBGBL0,"DA,") I XB(0,"PAR")]"" S XB(0+1,"FN")=XB(0,"PAR"),XBLVL=XBLVL+1 D PARENT Q ;-- PARENT ; gather parent information ; build elements from XBFN(XBLVL) S XB(XBLVL,"DA")=DA(XBLVL) S XB(XBLVL,"DR")=XB(XBLVL-1,"FLD") S XB(XBLVL,"FLD")="" S XB(XBLVL,"PAR")=$G(^DD(XB(XBLVL,"FN"),0,"UP")) S:XB(XBLVL,"PAR")]"" XB(XBLVL,"FLD")=$O(^DD(XB(XBLVL,"PAR"),"SB",XB(XBLVL,"FN"),"")) D ^XBSFGBL(XB(XBLVL,"FN"),.XBGBL0) S XB(XBLVL,"GBL")=$P(XBGBL0,"DA,") I XB(XBLVL,"PAR")]"" S XB(XBLVL+1,"FN")=XB(XBLVL,"PAR"),XBLVL=XBLVL+1 D PARENT EPAR Q ;-- SETDIQ1 ;EP - set DR(fn and DA(fn arrays for DIQ1 F XBLVL=0:1 Q:'$D(XB(XBLVL)) D .S DR(XB(XBLVL,"FN"))=XB(XBLVL,"DR") .S DA(XB(XBLVL,"FN"))=XB(XBLVL,"DA") .S DIC=XB(XBLVL,"GBL") .S DR=XB(XBLVL,"DR") .S DA=XB(XBLVL,"DA") ; kill off redundant DR( and DA( S XBLVL=XBLVL-1 K DR(XB(XBLVL,"FN")),DA(XB(XBLVL,"FN")) Q ; XBDIR XBDIR ; IHS/ADC/GTH - DIR INTERFACE ; [ 08/22/95 3:57 PM ] ;;2.6;IHS/VA UTILITIES;**7**;JUN 28, 1993 ; ; The purpose of routine XBDIR is to provide standardization of a ; call to ^DIR, to ensure correct handling of variables, and to ; provide for the expressiveness of an extrinsic function. ; ; There is no requirement to use the entry point, below. ; ; The format of the call is to set your local variable to the output ; of the call to DIR^XBDIR(), which will be Y at the bottom of this ; routine. ; ; An example of the call is: ; S %=$$DIR^XBDIR() ; where the is: ; (DIR(0),DIR("A"),DIR("B"),DIR("T"),DIR("?"),DIR("??"),) ; where is the number of lines to skip before the call to ^DIR. ; ; Examples: ; ; S %=$$DIR^XBDIR("N^1:2","Select report method",2,"","Produce report by FY or Dates","^D HELP^",300,2) ; ; S FY=$$DIR^XBDIR("NO","Object Class Code Summary for FISCAL YEAR ",FY,$G(DTIME,500),"Enter a FOUR DIGIT FISCAL YEAR","^D SB1^") ; ; DIR(O,A,B,T,Q,H,R) ;PEP I '$L($G(O)) Q -1 NEW DIR S DIR(0)=O I $D(A) D . I $L($G(A)) S DIR("A")=A . I $L($O(A(""))) S O="" F S O=$O(A(O)) Q:'$L(O) S DIR("A",O)=A(O) .Q I $L($G(B)) S DIR("B")=B I $G(T) S DIR("T")=T I $D(Q) D . I $L($G(Q)) S DIR("?")=Q . I $L($O(Q(""))) S O="" F S O=$O(Q(O)) Q:'$L(O) S DIR("?",O)=Q(O) .Q I $L($G(H)) S DIR("??")=H I $G(R) F A=1:1:R W ! KILL O,A,B,T,Q,H,R,DTOUT,DUOUT,DIRUT,DIROUT D ^DIR Q Y ; XBDR XBDR ; IHS/ADC/GTH - BUILDS DIR STRING ; [ 09/20/95 8:12 AM ] ;;2.6;IHS/VA UTILITIES;**7**;JUN 28, 1993 ; XB*2.6*7 IHS/ADC/GTH 08-23-95 ; START ; NEW XBDRQUIT,DIR,XBDRMIN,XBDRMAX,XBDRSPEC,X,Y,V,XBDRCODE,XBDRDIR,XBDRDIRA,XBDRDIRB,XBDRRUN,XBDRTYPE,I,Z,DIROUT,DUOUT,DTOUT,DIRUT,XBDRDQ,XBDRDQQ,XBDROUT RUN ; F XBDRRUN=1:1:8 D @$P("LOC,NAR,DFLT,^XBDR1,HELP,SET,TEST,SAVE",",",XBDRRUN) I $D(XBDRQUIT) Q EXIT ; Q ; LOC ; S V="|",U="^" S XBDROUT="I $D(DTOUT)!($D(DUOUT))!($D(DIROUT))" I '$D(DT) S X="T" D ^%DT S DT=Y K %DT I '$D(DTIME) S DTIME=9999 I $D(IOM),$D(IOF),$D(IOST),$D(IOSL) Q D HOME^%ZIS KILL IOPAR,IOT,IOBS,POP Q ; HELP ; W !!,"The current HELP text is: " S X=$E(XBDRTYPE)_1,X=$T(@X^DIR2),X=$P(X,";",4) ; XB*2.6*7 IHS/ADC/GTH 08-23-95 W """",X,"""" S DIR("A")="Additional HELP text",DIR(0)="FO^1:199" D ^DIR KILL DIR X XBDROUT I S XBDRQUIT="" Q S XBDRDQ=X W ! I '$D(^DIC(9.2)) Q QQ ; S DIC("A")="Enter HELP FRAME name: ",DIC(0)="AEQ",DIC=9.2 D ^DIC KILL DIC X XBDROUT I S XBDRQUIT="" Q I Y=-1 Q S XBDRDQQ=$P(Y,U,2) Q ; SET ; S XBDRDIR=XBDRTYPE,Y="" F I=1:1:3 S X="XBDR"_$P("MIN,MAX,SPEC",",",I) I $D(@X) S $P(Y,":",I)=@X I Y'="" S XBDRDIR=XBDRDIR_U_Y S1 ; S XBDRCODE="S DIR(0)="""_XBDRDIR_"""" I $D(XBDRDIRA) S:XBDRTYPE["F"!($E(XBDRTYPE)) XBDRDIRA=XBDRDIRA S XBDRCODE=XBDRCODE_",DIR(""A"")="""_XBDRDIRA_"""" I $D(XBDRDIRB) S XBDRCODE=XBDRCODE_",DIR(""B"")="""_XBDRDIRB_"""" I $D(XBDRDQ),XBDRDQ'="" S XBDRCODE=XBDRCODE_",DIR(""?"")="""_XBDRDQ_"""" I $D(XBDRDQQ),XBDRDQQ'="" S XBDRCODE=XBDRCODE_",DIR(""??"")="""_XBDRDQQ_"""" S XBDRCODE=XBDRCODE_" K DA D ^DIR K DIR" Q ; NAR ; S DIR("A")="Enter query narrative",DIR(0)="FO" D ^DIR KILL DIR I X="" Q X XBDROUT I S XBDRQUIT="" Q S XBDRDIRA=X Q ; DFLT ; S DIR("A")="Enter default value",DIR(0)="FO" D ^DIR KILL DIR I X="" Q X XBDROUT I S XBDRQUIT="" Q S XBDRDIRB=X Q ; TEST ; W !!!!!,?30,"***** TEST *****" TQ ; X XBDRCODE I X=U Q G TQ ; SAVE ; W !!!,"Saving the following line of code in the '%' variable and ^ZUT($I,""Temp""):",!," ",XBDRCODE,!!! S %=" "_XBDRCODE I $D(^DD("OS")),^("OS")=2!(^("OS")=8) K ^ZUT($I,"Temp") S ^ZUT($I,"Temp",1)=%,^ZUT($I,"Temp",0)="Temporary storage" Q ; XBENHANC XBENHANC ; IHS/ADC/GTH - DISPLAY/PRINT ENHANCEMENTS FIELD IN PACKAGE FILE ; [ 08/22/95 3:57 PM ] ;;2.6;IHS/VA UTILITIES;**2**;JUN 28, 1993 ; 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/ADC/GTH - STANDARDIZE LINE 1 OF SELECTED ROUTINES ; [ 08/22/95 4:05 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/ADC/GTH - 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 ; XBFLD XBFLD ; IHS/ADC/GTH - DICTIONARY LISTING ; [ 08/22/95 3:57 PM ] ;;2.6;IHS/VA UTILITIES;**7**;JUN 28, 1993 ; ; This routine lists dictionaries which may be selected individually ; or by a range of dictionary numbers. ; ; This routine requires the 89 MUMPS Standard, FileMan Version 17.7 ; or greater, Kernel Version 6 or greater, and the following routines ; must exist in the UCI in which this routine is running: ; ; XBKVAR, XBSFGBL ; START ; D LOOP ; List files until user says stop D EOJ ; Clean up Q ; LOOP ; LIST FILES UNTIL USER SAYS STOP NEW XBQFLG W !,"^XBFLD - This routine lists FileMan dictionaries." F D INIT Q:XBQFLG D LIST W ! D ^%ZISC Q:XBQFLG Q ; LIST ; LIST RANGE OF FILES S:'$D(XBFMT) XBFMT="" NEW XBCOMP,XBFILE,XBFIELD,XBLNFEED,XBNAME,XBPIECE,XBPAGE,XBPSUB,XBPSUBOL,XBSUBFIL,XBSUB,XBTAB,XBTYPE,XBWPC,XBWPSUB S XBQFLG=0 F XBFILE=0:0 S XBFILE=$O(^UTILITY("XBDSET",$J,XBFILE)) Q:XBFILE="" D FILE Q:XBQFLG Q ; FILE ; LIST ONE FILE S (XBCOMP,XBLNFEED,XBPAGE,XBTAB)=0,XBSUB="D0,",XBPSUBOL="" D HEADING D FIELDS Q:XBQFLG D PAUSE Q ; FIELDS ; LIST ALL FIELDS IN ONE FILE/SUBFILE (CALLED RECURSIVELY) F XBFIELD=0:0 S XBFIELD=$O(^DD(XBFILE,XBFIELD)) Q:XBFIELD'=+XBFIELD D FIELD Q:XBQFLG Q ; FIELD ; LIST ONE FIELD S (XBNAME,XBPIECE,XBPSUB,XBTYPE)="" S X=^DD(XBFILE,XBFIELD,0) S XBNAME=$P(X,U,1) S Y=$P(X,U,2) S XBTYPE=$S(+Y:"",Y["C":"C",Y["F":"F",Y["N":"N",Y["P":"P",Y["S":"S",Y["V":"V",Y["K":"K",Y["W":"W",Y["D":"D",1:"?") I XBTYPE="C" D COMPUTED Q I XBCOMP S XBCOMP=0 D WRITELF ; Extra lf after computed fields I XBTYPE="" D MULTIPLE Q S Y=$P(X,U,4) S XBPSUB=XBSUB_$S($P(Y,";",1)=+$P(Y,";",1):$P(Y,";",1),1:""""_$P(Y,";",1)_"""") S XBPIECE=$S(XBTYPE="K":" ",1:$P(Y,";",2)) ; MUMPS field has no piece D WRITE Q ; COMPUTED ; COMPUTED FIELD ; The variable XBCOMP prevents multiple lfs between adjacent ; computed fields. ; D:'XBCOMP WRITELF S XBPSUB="COMPUTED",XBTYPE="",XBCOMP=1 S XBPSUB=XBPSUB_$S(Y["B":" (BOOLEAN)",Y["D":" (DATE)",1:"") D WRITE Q ; MULTIPLE ; LIST MULTIPLE, THEN FIELDS IN SUBFILE S XBNAME=XBNAME_" ("_+Y_")",XBSUBFIL=+Y D WRITELF,WRITE Q:XBQFLG NEW XBFILE,XBFIELD,XBSUB S XBFILE=XBSUBFIL D ^XBSFGBL(XBFILE,.XBSUB,2) S XBSUB="D0"_$P(XBSUB,"D0",2),XBSUB=$P(XBSUB,")",1) S XBTAB=XBTAB+2 D FIELDS ; Recurse S XBTAB=XBTAB-2 Q:XBQFLG D WRITELF Q ; WRITE ; WRITE ONE LINE S XBLNFEED=0 D PAGE:$Y>(IOSL-3) Q:XBQFLG S XBWPSUB=$S(XBFIELD=.001:"",XBPSUB]""&(XBPSUB=XBPSUBOL):" """,1:XBPSUB) S XBWPC=$S(XBPIECE:$J(XBPIECE,5,0),1:XBPIECE) I (XBPSUB'["COMPUTED") W !,?XBTAB,XBFIELD,?13+XBTAB,$S(XBTYPE="":XBNAME,1:$E(XBNAME,1,31-XBTAB)),?46,$E(XBWPSUB,1,21),?68,XBWPC,?77,XBTYPE I 1 E W !,?XBTAB,XBFIELD,?13+XBTAB,$S(XBTYPE="":XBNAME,1:$E(XBNAME,1,31-XBTAB)),?46,$E(XBWPSUB,1,21) W:XBFMT["C" ?56,^DD(XBFILE,XBFIELD,9.1) I XBTYPE'="" I $L(XBNAME)>(31-XBTAB)!($L(XBWPSUB)>25) W !,?13+XBTAB,$E(XBNAME,32-XBTAB,$L(XBNAME)),?46,$E(XBWPSUB,22,$L(XBWPSUB)) I XBTYPE="S",XBFMT["S" W !,?16+XBTAB,"S: ",$P(^DD(XBFILE,XBFIELD,0),"^",3) I XBTYPE="P",XBFMT["P" S XBFLDPT=$P(X,"^",2),XBFLDPT=+$P(XBFLDPT,"P",2) S:$D(^DIC(XBFLDPT,0)) XBFLDPT=$P(^DIC(XBFLDPT,0),"^") W !,?16+XBTAB,"P: ",XBFLDPT K XBFLDPT I XBTYPE="V",XBFMT["V" S XBFLDPT=0 F S XBFLDPT=$O(^DD(XBFILE,XBFIELD,"V",XBFLDPT)) Q:'XBFLDPT W !,?16+XBTAB,"V: ",$P(^DD(XBFILE,XBFIELD,"V",XBFLDPT,0),"^",1,2) S XBPSUBOL=XBPSUB I $D(^DD(XBFILE,XBFIELD,1,1,0)),XBFMT["X" D ^XBFLD0 Q ; WRITELF ; WRITE ONE LINE FEED ; The variable XBLNFEED prevents multiple lfs when backing out of ; deep recursion. ; Q:XBLNFEED I $Y>2,$Y'>(IOSL-3) W ! S XBLNFEED=1 Q ; HEADING ; DICTIONARY HEADERS NEW XBHOUR,XBMINUT,XBTITLE,XBTIME S XBPAGE=1 W @IOF D HEADING2 W ?80-$L("FILE: "_$P(^DIC(XBFILE,0),"^",1))\2,"FILE: ",$P(^DIC(XBFILE,0),"^",1),!,?80-$L("GLOBAL: "_^DIC(XBFILE,0,"GL"))\2,"GLOBAL: ",^DIC(XBFILE,0,"GL"),!,?80-$L("FILE #: "_XBFILE)\2,"FILE #: ",XBFILE,!! D PAGE Q ; HEADING2 ; HARD COPY HEADERS I IO=IO(0),$E(IOST,1,2)="C-" Q I $G(XBFLD("BROWSE")) W !!! Q S XBTITLE="I.H.S. DICTIONARY FIELDS",XBTIME=$P($H,",",2),XBHOUR=XBTIME\3600,XBMINUT=XBTIME#3600\60 S:XBMINUT<10 XBMINUT="0"_XBMINUT S XBTIME=XBHOUR_":"_XBMINUT W XBTIME,?80-$L(XBTITLE)\2,XBTITLE,?72,"page ",XBPAGE,!,?80-$L(^DD("SITE"))\2,^DD("SITE"),! X ^%ZOSF("UCI") S Y="UCI: "_$P(Y,",",1) W ?80-$L(Y)\2,Y I '$D(DT) S %DT="",X="T" D ^%DT S DT=Y S Y=DT X ^DD("DD") W !!,?80-$L("as of "_Y)\2,"as of ",Y,!! Q ; PAGE ;EP - PAGE HEADERS NEW X D:XBPAGE>1 PAUSE Q:XBQFLG I XBPAGE>1 W:$D(IOF) @IOF S XBPAGE=XBPAGE+1 W "FIELD #",?13,"FIELD NAME",?46,"SUBSCRIPT",?69,"PIECE",?75,"TYPE",!,$$REPEAT^XLFSTR("=",79),! S XBPSUBOL="" Q ; PAUSE ; GIVE USER A CHANCE TO SEE LAST PAGE AND QUIT I IO=IO(0),$E(IOST,1,2)="C-" S %=$$DIR^XBDIR("E") S:$D(DIRUT)!($D(DUOUT)) XBQFLG=1 K DIRUT,DUOUT Q ; INIT ; INITIALIZATION S XBFLDP=$S($D(XBFLDP):1,1:0) S:XBFLDP XBDSND=1 D ^XBFLD2 ; Get device and files to list Q ; FORMAT ;EP - select format NEW A,X S A="Select Format Combination" F %=1:1 S X=$P($T(TXT+%),";;",2) Q:X="END" S A(%)=X S Y=$$DIR^XBDIR("FO^0:5",.A,"","","","",1) I Y="A" S Y="VPSXC" S XBFMT=Y Q ; TXT ; ;; ;;Addition resolution of fields is available ;; V - VARIABLE POINTER ;; P - POINTER ;; S - SET OF CODES ;; C - COMPUTED EXPRESSION ;; X - CROSS-REFERENCES ;; A - ALL ;; ;;END ; EN ; EXTERNAL ENTRY POINT ; To use this entry point ^UTILITY("XBDSET",$J, must contain ; the list of dictionaries. All device variables must be set ; and, if appropriate, the U IO executed prior to the call. ; It is the callers responsibility to close the device. ; NEW XBQFLG I $D(IO)#2,$D(IO(0))#2,$D(IOF)#2,$D(IOSL)#2 D LIST D EOJ Q ; EOJ ; END OF JOB KILL XBFLDP,XBFLDPT,XBFMT,XBFLD,XBIHS KILL ^UTILITY("XBDSET",$J) KILL DIR,DIRUT,DTOUT,DUOUT,POP,S,X,Y I $D(ZTQUEUED) S ZTREQ="@" Q Q ; XBFLD0 XBFLD0 ; IHS/ADC/GTH - PRINT FIELD TRIGGERS ; [ 08/22/95 3:57 PM ] ;;2.6;IHS/VA UTILITIES;**7**;JUN 28, 1993 ; S ; NEW I,T,N S I=0 F S I=$O(^DD(XBFILE,XBFIELD,1,I)) Q:I'>0 D . D:$Y>(IOSL-4) PAGE^XBFLD . W !,?16,"X: ",$P(^DD(XBFILE,XBFIELD,1,I,0),"^",2,5) S T=$P(^(0),U,3),T=$E(T,1,2) . S:T="" T="RG" . ;choices for T==> RG,MU,BU,KW,MN,TR . D @T Q ; MU ;MUMPS MN ;MNEMONIC F N=1,2 W !,?20,N,")",?25,^DD(XBFILE,XBFIELD,1,I,N) Q ; RG ;REGULAR F N=1 W !,?20,N,")",?25,^DD(XBFILE,XBFIELD,1,I,N) Q ; BU ;BULLETIN S X="CREATE",N=X F S N=$O(^DD(XBFILE,XBFIELD,1,I,N)) Q:N'[X W !,?20,N,?40,^(N) Q ; KW ;KWIC Q ; TR ;TRIGGER F N="CREATE VALUE","DELETE VALUE","FIELD" W !,?20,N,?35,$G(^DD(XBFILE,XBFIELD,1,I,N)) Q ; XBFLD2 XBFLD2 ; IHS/ADC/GTH - INITIALIZATION FOR ^XBFLD ; [ 08/22/95 3:57 PM ] ;;2.6;IHS/VA UTILITIES;**7**;JUN 28, 1993 ; XB*2.6*7 IHS/ADC/GTH 07-10-95, Enable use of List Manager. ; ; Part of XBFLD ; ; ^UTILITY("XBDSET",$J, is used to store the list of files to ; be listed so that other software can pass files to be listed ; to the external entry point EN^XBFLD, and the other software ; could select files by using ^XBDSET. ; INIT ; INITIALIZATION NEW XBFILE D ^XBKVAR K ^UTILITY($J),^UTILITY("XBDSET",$J) S XBQFLG=0 D ^XBDSET S:'$D(^UTILITY("XBDSET",$J)) XBQFLG=1 Q:XBQFLG D FORMAT^XBFLD D DEVICE ; Get device Q ; DEVICE ; GET DEVICE (QUEUEING ALLOWED) S Y=$$DIR^XBDIR("S^P:PRINT Output;B:BROWSE Output on Screen","Do you wish to ","P","","","",1) K DA Q:$D(DIRUT) I Y="B" S XBFLD("BROWSE")=1 D VIEWR^XBLM("EN^XBFLD"),FULL^VALM1 W:$D(IOF) @IOF D Q . D CLEAR^VALM1 ;clears out all list man stuff . KILL XQORNEST,VALMKEY,VALM,VALMAR,VALMBCK,VALMBG,VALMCAP,VALMCNT,VALMOFF,VALMCON,VALMDN,VALMEVL,VALMIOXY,VALMKEY,VALMLFT,VALMLST,VALMMENU,VALMSGR,VALMUP,VALMWD,VALMY,XQORS,XQORSPEW,VALMCOFF .Q S %ZIS="Q" D ^%ZIS I POP S XBQFLG=1 K POP Q I $D(IO("Q")) D S XBQFLG=1 Q . S ZTRTN="EN^XBFLD",ZTIO=ION,ZTDESC="List dictionary",ZTSAVE("^UTILITY(""XBDSET"",$J,")="",ZTSAVE("XBFMT")="" D ^%ZTLOAD . W !!,$S($D(ZTSK):"Request queued!",1:"Request cancelled!") . D ^%ZISC . K ZTSK,IO("Q") . K ZTIO ; ^%ZTLOAD kills other ZT* variables, but not this one . Q U IO Q ; XBFMK XBFMK ; IHS/ADC/GTH - KILL FILEMAN VARIABLES ; [ 08/22/95 3:57 PM ] ;;2.6;IHS/VA UTILITIES;**7**;JUN 28, 1993 ; XB*2.6*7 IHS/ADC/GTH 07-10-95, add unKILLed variables. ; ; This routine kills variables left around by FileMan ; KILL %,%1,%DEVTYPE,%DT,%GSREF,%H,%K,%RCR,%ST,%T,%W,%X,%XUCI,%Y,%ZISOS ; XB*2.6*7 IHS/ADC/GTH 07-10-95, KILL A,C,I,J,L,S,UT,X,Y,Z ; XB*2.6*7 IHS/ADC/GTH 07-10-95, KILL D,D0,D1,D2,DA,DD,DDC,DDH,DI,DIC,DIC1,DICR,DIE,DIEC,DIG,DIH,DIK,DILC,DIOV,DIPGM,DIR,DIU,DIV,DIW,DIWF,DIWL,DIWR,DIWT,DIZ,DK,DL,DLAYGO,DN,DQ,DR,DX,DZ ; XB*2.6*7 IHS/ADC/GTH 07-10-95, KILL DIRUT,DTOUT,DUOUT Q XBFUNC2 XBFUNC2 ; IHS/ADC/GTH - FUNCTION LIBRARY - PCC RELATED FUNCTIONS [ 08/22/95 3:57 PM ] ;;2.6;IHS/VA UTILITIES;**1**;JUN 28, 1993 ; ; 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 ; [ 08/22/95 3:57 PM ] ;;2.6;IHS/VA UTILITIES;**1,6**;JUN 28, 1993 ; 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 "." ; 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 XBL XBL ; IHS/ADC/GTH - List Template Exporter ; [ 08/22/95 1:30 PM ] ;;2.6;IHS/VA UTILITIES;**7**;JUN 28, 1993 ;; ; W !,"'XB DISPLAY' List Template..." S DA=$O(^SD(409.61,"B","XB DISPLAY",0)),DIK="^SD(409.61," D ^DIK:DA K DO,DD S DIC(0)="L",DIC="^SD(409.61,",X="XB DISPLAY" D FILE^DICN S VALM=+Y I VALM>0 D .S ^SD(409.61,VALM,0)="XB DISPLAY^1^^200^4^21^1^1^^XB DISPLAY^OUTPUT BROWSER^1^^1" .S ^SD(409.61,VALM,1)="^VALM HIDDEN ACTIONS" .S ^SD(409.61,VALM,"ARRAY")=" ^TMP(""XBLM"",$J,XBNODE)" .S ^SD(409.61,VALM,"FNL")="D EXIT^XBLM" .S ^SD(409.61,VALM,"HDR")="D HDR^XBLM" .S ^SD(409.61,VALM,"HLP")="D HELP^XBLM" .S ^SD(409.61,VALM,"INIT")="D INIT^XBLM" .S DA=VALM,DIK="^SD(409.61," .D IX1^DIK .KILL DA,DIK .W "Filed." .Q ; KILL DIC,DIK,VALM,X,DA Q ; XBLCALL XBLCALL ; IHS/ADC/GTH - LIST CALLABLE SUBROUTINES ; [ 08/22/95 3:57 PM ] ;;2.6;IHS/VA UTILITIES;**6,7**;JUN 28, 1993 ; XB*2.6*7 IHS/ADC/GTH 07-10-95, More EPs added. ; ; 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) Q:$$DIR^XBDIR("E") Q ; STARDATE(X) ; Return Stardate of FM date/time. I X'?7N.1".".6N Q -1 NEW Y S Y=$P(X,".",2),Y=+$E(Y,1,2)/24+(+$E(Y,3,4)/(60*24))+(+$E(Y,5,6)/(60*60*24)) Q $FN($E(X,3,7)+Y,"-",2) ; 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 ;;$$DIR^XBDIR();Standard interface to Reader ;;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) ;;^XBGSAVE;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 ;;EN^XBSFGBL(SUBFILE,ref,FORM);Return global ref of file or sub-file. ;;^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 XBLM XBLM ; IHS/ADC/GTH - LIST MANAGER API'S ; [ 09/19/95 8:02 AM ] ;;2.6;IHS/VA UTILITIES;**7**;JUN 28, 1993 ;; ; DOC ;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) ; ; EN ; -- main entry point for XB DISPLAY D EN^VALM("XB DISPLAY") Q ; HDR ; -- header code I XBHDR]"" S VALMHDR(1)=XBHDR ;S VALMHDR(1)="This is a test header for XB DISPLAY." ;S VALMHDR(2)="This is the second line" Q ; INIT ; -- init variables and list array ;F LINE=1:1:30 D SET^VALM10(LINE,LINE_" Line number "_LINE) ;S VALMCNT=30 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) KILL XBLMMARK S VALMCNT=$O(^TMP("XBLM",$J,XBNODE,""),-1) Q ; HELP ; -- help code S X="?" D DISP^XQORM1 W !! Q ; EXIT ; -- exit code KILL ^TMP("XBLM",$J,XBNODE) K ; KILL XBAR,XBDIR,XBFL,XBFN,XBHDR,XBI,XBROU,XBDIR I '$G(XQORS) D CLEAR^VALM1 Q ; EXPND ; -- expand code Q ; FILE(XBDIR,XBFN) ;PEP pull up a file into the TMP global for display I '$D(XBHDR) S XBHDR="" NEW Y,X,I,XBNODE S XBNODE=$G(XQORS)+1 S Y=$$OPEN^%ZISH(XBDIR,XBFN,"R") I Y 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 X=$$STRIP(X) S ^TMP("XBLM",$J,XBNODE,I,0)=X Q:$$STATUS^%ZISH=-1 D ^%ZISC D EN^XBLM KILL ^TMP("XBLM",$J,XBNODE) EFILE ; Q ; SFILE ;PEP SELECT FILE OPEN ; S IOP="HOME" D ^%ZIS D DT^DICRW D ^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 D ^DIR K DIR Q:$G(DTOUT) Q:Y["^" S XBDIR=Y FNAME ; KILL DIR FNAME1 ; S DIR(0)="F^1:15",DIR("A")="File Name " D ^DIR K DIR Q:$G(DTOUT) 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 S XBFN=Y S X=$$OPEN^%ZISH(XBDIR,XBFN,"R") ES ; I X W !,"error on open of file ",XBDIR,XBFN,! K DIR S DIR(0)="E" D ^DIR K DIR Q:Y=1 G FNAME D ^%ZISC D FILE^XBLM(XBDIR,XBFN) ESFILE ; Q ; VIEWR(XBROU,XBHDR) ;PEP ** USING XBROU print to a host file for viewing I '$D(XBHDR) S XBHDR="" U IO(0) D WAIT^DICD S Y=$$PWD^%ZISH(.XBDIR) S XBDIR=XBDIR(1) S XBFN="XB"_$J S X=$$OPEN^%ZISH(XBDIR,XBFN,"W") S IOST="P-DEC",IOST(0)=$O(^%ZIS(2,"B","P-DEC",0)) S IOSL=6000 S IOF="#" ;S IOF=IOF_",!!,"_""">PAGE MARK<"""_",!!" ;S IOP=IO_";P-DEC;"_IOM_";"_IOSL ;S %ZIS("IOPAR")="("""_XBFN_""":""W"")" U IO D @XBROU D ^%ZISC D HOME^%ZIS D FILE^XBLM(XBDIR,XBFN) S X=$$DEL^%ZISH(XBDIR,XBFN) KILL XBDIR,XBFN,XBHDR,XBNODE,XBDIR,XBFN Q ; VIEWD(XBROU) ;PEP ** USING XBROU print to a host file for viewing U IO(0) D WAIT^DICD S XBFN="XB"_$J S Y=$$PWD^%ZISH(.XBDIR) S XBDIR=XBDIR(1) D DF^%ZISH(.XBDIR) S X=$$OPEN^%ZISH(XBDIR,XBFN,"W") S IOP=IO_";P-DEC;"_IOM_";"_IOSL D ^%ZISC S IOST="P-DEC",IOST(0)=$O(^%ZIS(2,"B","P-DEC",0)) S IOSL=6000 S IOF="#" ;S IOF=IOF_",!!,"_""">PAGE MARK<"""_",!!" S %ZIS("IOPAR")="("""_XBDIR_XBFN_""":""W"")" D @XBROU D ^%ZISC D HOME^%ZIS D FILE^XBLM(XBDIR,XBFN) S X=$$DEL^%ZISH(XBDIR,XBFN) KILL XBDIR,XBFN,XBNODE,XBDIR,XBFN Q ; DIQ(DIC,DA) ;PEP ** EN^DIQ S IOSTO=IOST,IOST="P-DEC" S 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 KILL 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 D EN^XBLM KILL ^TMP("XBLM",$J,XBNODE) KILL 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 ; XBMAIL XBMAIL ; IHS/ADC/GTH - MAIL MESSAGE TO SECURITY KEY HOLDERS ; [ 08/22/95 3:57 PM ] ;;2.6;IHS/VA UTILITIES;**7**;JUN 28, 1993 ; ; This utility generates a mail message to everyone on the local ; machine that holds a security key according to the namespace, range, ; or single key provided in the parameter. The text of the mail ; messages must be provided by you, and passed to the utility as a ; line reference. The utility uses the first line after the line ; reference as the mail message subject, and subsequent lines as the ; body of the message, until a null string is encountered. This ; places an implicit limit on your mail messages to the maximum size ; of a routine. Suggested text would be to inform the users that a ; patch has been installed, and describe any changes in displays or ; functionality, or problems addressed, and provide a contact number ; for questions, e.g: ; ------------------------------------------------------------------ ; Please direct your questions or comments about RPMS software to: ; OIRM / DSD (Division of Systems Development) ; 5300 Homestead Road NE ; Albuquerque NM 87110 ; 505-837-4189 ; ------------------------------------------------------------------ ; ; Call examples are: ; ; D MAIL^XBMAIL("ACHS*","MSG^ACHSP56") ; D MAIL^XBMAIL("AG*,XUMGR-XUPROGMODE,APCDZMENU","LABEL^AGP5") ; ; The second example would deliver a mail message containing the text ; beginning at LABEL+2^AGP5, and continuing to the end of routine AGP5, ; to each local user that holds a security key in the AG namespace, in ; the range from XUMGR to XUPROGMODE (inclusive), and to holders of the ; APCDZMENU security key. ; ; If you are indicating a namespace, your namespace must end with a ; star ("*") character. ; ; If you are indicating a range of security keys, the beginning and ; ending keys must be separated with a dash ("-"). If the utility ; encounters a dash in a comma-piece of the first parameter, it will ; consider it to be range-indicated, and not part of the name of the ; key. Use caution not to begin or end with a key that has a dash ; in it's name. ; ; If a comma-piece does not contain a star or dash, a single key is ; assumed. ; ; The subject of the message is assumed to be the first line after ; LABEL^AGP5: ; LABEL ;EP - Mail msg text. ; ;;PATIENT REG, PATCH 5 CHANGES. ; ; The utility will return Y=0 if successful, and Y=-1 if not ; successful. The message "Message delivered." will be displayed ; if the routine is called interactively. ; ; Q ; MAIL(XBNS,XBREF) ;PEP - XBNS is namespace, XBREF is line reference. ; NEW XBLAB,XBRTN,XMSUB,XMDUZ,XMTEXT,XMY S XBLAB=$P(XBREF,U),XBRTN=$P(XBREF,U,2) I XBLAB=""!(XBRTN="") S Y=-1 Q ; Invalid label reference. I '$L($T(@XBLAB+1^@XBRTN)) S Y=-1 Q ; No text to send. S XMSUB=$P($T(@XBLAB+1^@XBRTN),";",3) K ^TMP("XBMAIL",$J) D WRITDESC,GETRECIP I '$D(XMY) S Y=-1 Q ; No recipients. S XMDUZ=$S($G(DUZ):DUZ,1:.5),XMTEXT="^TMP(""XBMAIL"",$J," D ^XMD K ^TMP("XBMAIL",$J) I '$D(ZTQUEUED) W !!,"Message delivered.",! S Y=0 Q ; GETRECIP ; NEW X,XBCTR,Y F XBCTR=1:1 S %=$P(XBNS,",",XBCTR) Q:%="" D . I %["*" D NS(%) Q . I %["-" D RANGE(%) Q . D SINGLE(%) .Q Q ; SINGLE(K) ; Get holders of a single key K. S Y=0 F S Y=$O(^XUSEC(K,Y)) Q:'Y S XMY(Y)="" Q ; RANGE(R) ; Get holders of a range of keys. S X=$P(R,"-",1),R=$P(R,"-",2) D SINGLE(X) F S X=$O(^XUSEC(X)) Q:X=R S Y=0 F S Y=$O(^XUSEC(X,Y)) Q:'Y S XMY(Y)="" D SINGLE(R) Q ; NS(N) ; Get holders of keys in namespace N. S (X,N)=$P(N,"*",1),Y=0 D SINGLE(X) F S X=$O(^XUSEC(X)) Q:'($E(X,1,$L(N))=N) S Y=0 F S Y=$O(^XUSEC(X,Y)) Q:'Y S XMY(Y)="" Q ; ; WRITDESC ; F %=2:1 S X=$P($T(@XBLAB+%^@XBRTN),";",3) Q:X="" S ^TMP("XBMAIL",$J,%)=X Q ; XBNEW XBNEW(XBRET) ; IHS/ADC/GTH - NESTING OF DIE ; [ 08/22/95 1:30 PM ] ;;2.6;IHS/VA UTILITIES;**7**;JUN 28, 1993 ; XB*2.6*7 IHS/ADC/GTH 08-08-95 new entry point added ; & kill of variables eliminated ; EN^XBNEW("TAG^ROUTINE","variable list") ; ; variable list has the form "AGDFN;AGINS;AGP*" ; wild card * allowed ; ; XBRET has the form "TAG^ROUTINE:VAR;NSVAR*" ; This allows for the nesting of die calls by ; ; 1. Building and executing an exclusive new from preselected ; kernel variables and any local variables &/or name spaces ; identified by the calling parameter. ; 2. After executing the new (....) XBNEW performs a DO call to the ; program entry point identified by the calling parameter. ; The entry point passed should build the variables and execute ; the DIE call to be nested. ; 3. As XBNEW quits to return to the calling program it pops the ; variable stack. ; ; NEW XB,XBNS,XBN,XB,XBY,XBL,XBKVAR G S ; EN(XBRT,XBNS) ;PEP XBRT=TAG^ROUTINE XBNS=varialbe list ";" with * allowed NEW XB,XBN,XB,XBY,XBL,XBKVAR,XBRET S XBRET=XBRT_":"_XBNS S I XBRET'[":" S XBRET=XBRET_":" S XBN="XBRET" S XBKVAR=$P($T(XBKVAR),";;",2) S XBNS=$P(XBRET,":",2) I XBNS="" G RETURN F XBI=1:1 S (XB,XBY)=$P(XBNS,";",XBI) Q:XB="" D .I XB'["*" S XBN=XBN_","_XB Q .S (XB,XBY)=$P(XB,"*") .S XBN=XBN_","_XB,XBL=$L(XB) .F S XBY=$O(@XBY) Q:((XBY="")!(XB'=$E(XBY,1,XBL))) S XBN=XBN_","_XBY RETURN ; S XBN="("_XBN_","_XBKVAR_")" S $P(XBRET,":",2)=XBN NEW NEW @($P(XBRET,":",2)) D @($P(XBRET,":",1)) Q END ;-------------------------------------------------------------- ; the following taken from the variable list in KILL^XUSCLEAN from KERNEL XBKVAR ;;DUZ,DTIME,DT,DISYS,IO,IOF,IOBS,IOM,ION,IOSL,IOST,IOT,IOS,IOXY,U,XRTL,ZTSTOP,ZTQUEUED,ZTREQ ;-------------------------------------------------------------- Q ; TEST ; ;substitute your own variable(s) for 'AG*,PW' in the following ;D ^XBNEW("T2^XBNEW:A*;PW") D EN^XBNEW("T2^XBNEW","A*;PW") Q T2 W !,"GOT TO T2",! W !,"Here is where the die call would be structured and called",!,"Following is a list of variables that were within the exclusive new",! H 3 I ($D(A)#2) W !,"A" S XB="A" F S XB=$O(@XB) Q:XB="" W !,XB W ! K XB Q XBONI001 XBONI001 ; IHS/ADC/GTH - ENTRIES TO PROTOCOL FILE FOR LIST MANAGER, UPGRADE 7 ; [ 08/22/95 1:30 PM ] ;;2.6;IHS/VA UTILITIES;**7**;JUN 28, 1993 F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^UTILITY(U,$J,"PRO",111,0) ;;=XB DISPLAY^OUTPUT Browser^^M^^^^^^^^ ;;^UTILITY(U,$J,"PRO",111,4) ;;=26 ;;^UTILITY(U,$J,"PRO",111,10,0) ;;=^101.01PA^3^3 ;;^UTILITY(U,$J,"PRO",111,10,1,0) ;;=113^+^10 ;;^UTILITY(U,$J,"PRO",111,10,1,"^") ;;=XB NEXT SCREEN ;;^UTILITY(U,$J,"PRO",111,10,2,0) ;;=114^-^20 ;;^UTILITY(U,$J,"PRO",111,10,2,"^") ;;=XB PREVIOUS SCREEN ;;^UTILITY(U,$J,"PRO",111,10,3,0) ;;=112^Q^99 ;;^UTILITY(U,$J,"PRO",111,10,3,"^") ;;=XB QUIT ;;^UTILITY(U,$J,"PRO",111,26) ;;=D SHOW^VALM ;;^UTILITY(U,$J,"PRO",111,28) ;;=Select Action: ;;^UTILITY(U,$J,"PRO",111,29) ;;=+ ;;^UTILITY(U,$J,"PRO",111,99) ;;=56383,43856 ;;^UTILITY(U,$J,"PRO",112,0) ;;=XB QUIT^QUIT^^A^^^^^^^^LIST MANAGER ;;^UTILITY(U,$J,"PRO",112,1,0) ;;=^^1^1^2911105^ ;;^UTILITY(U,$J,"PRO",112,1,1,0) ;;=This protocol can be used as a generic 'quit' action. ;;^UTILITY(U,$J,"PRO",112,2,0) ;;=^101.02A^2^2 ;;^UTILITY(U,$J,"PRO",112,2,1,0) ;;=EXIT ;;^UTILITY(U,$J,"PRO",112,2,2,0) ;;=QUIT ;;^UTILITY(U,$J,"PRO",112,2,"B","EXIT",1) ;;= ;;^UTILITY(U,$J,"PRO",112,2,"B","QUIT",2) ;;= ;;^UTILITY(U,$J,"PRO",112,20) ;;=Q ;;^UTILITY(U,$J,"PRO",112,99) ;;=56383,43775 ;;^UTILITY(U,$J,"PRO",113,0) ;;=XB NEXT SCREEN^NEXT SCREEN^^A^^^^^^^^LIST MANAGER ;;^UTILITY(U,$J,"PRO",113,1,0) ;;=^^2^2^2920519^^^ ;;^UTILITY(U,$J,"PRO",113,1,1,0) ;;=This action will allow the user to view the next screen ;;^UTILITY(U,$J,"PRO",113,1,2,0) ;;=of entries, if any exist. ;;^UTILITY(U,$J,"PRO",113,2,0) ;;=^101.02A^1^1 ;;^UTILITY(U,$J,"PRO",113,2,1,0) ;;=NX ;;^UTILITY(U,$J,"PRO",113,2,"B","NX",1) ;;= ;;^UTILITY(U,$J,"PRO",113,20) ;;=D NEXT^VALM4 ;;^UTILITY(U,$J,"PRO",113,99) ;;=56383,43793 ;;^UTILITY(U,$J,"PRO",114,0) ;;=XB PREVIOUS SCREEN^PREVIOUS SCREEN^^A^^^^^^^^LIST MANAGER ;;^UTILITY(U,$J,"PRO",114,1,0) ;;=^^2^2^2920113^^ ;;^UTILITY(U,$J,"PRO",114,1,1,0) ;;=This action will allow the user to view the previous screen ;;^UTILITY(U,$J,"PRO",114,1,2,0) ;;=of entries, if any exist. ;;^UTILITY(U,$J,"PRO",114,2,0) ;;=^101.02A^3^3 ;;^UTILITY(U,$J,"PRO",114,2,1,0) ;;=PR ;;^UTILITY(U,$J,"PRO",114,2,2,0) ;;=BK ;;^UTILITY(U,$J,"PRO",114,2,3,0) ;;=PR ;;^UTILITY(U,$J,"PRO",114,2,"B","BK",2) ;;= ;;^UTILITY(U,$J,"PRO",114,2,"B","PR",1) ;;= ;;^UTILITY(U,$J,"PRO",114,2,"B","PR",3) ;;= ;;^UTILITY(U,$J,"PRO",114,20) ;;=D PREV^VALM4 ;;^UTILITY(U,$J,"PRO",114,99) ;;=56383,43810 XBONIT XBONIT ; IHS/ADC/GTH - ENTRIES TO PROTOCOL FILE FOR LIST MANAGER, UPGRADE 7 ; [ 08/22/95 1:30 PM ] ;;2.6;IHS/VA UTILITIES;**7**;JUN 28, 1993 ; K DIF,DIK,DDF,DDT,DTO,D0,DLAYGO,DIC,DIR,DA,ORVROM,DFR,DTN,DIX,DZ S DIFQ=0,ORVROM=0 W:'$D(ZTQUEUED) !!,"This version of 'XBONIT' was created on 16-MAY-1995" W:'$D(ZTQUEUED) !?9,"(at TUSCON ISD, by OE/RR V.2.5)",! G Q:DIFQ D ^XBONIT1 G Q:'$D(DIFQ) S DIK(0)="B" D ^XBONIT2,^XBONIT3 L W:'$D(ZTQUEUED) !,*7,"OK, Protocol Installation is Complete.",! K %ZW,%,%H,D0,DA,DIF,DIFQ,DIG,DIH,DIK,DIU,DIV,DSEC,I,J,KEY,DIY,N,NM,NO,ORVROM,R,X,X0 Q ; Q W:'$D(ZTQUEUED) *7,!!,"NO UPDATING HAS OCCURRED!" Q ; IXF ;;XB XBONIT1 XBONIT1 ; IHS/ADC/GTH - ENTRIES TO PROTOCOL FILE FOR LIST MANAGER, UPGRADE 7 ; [ 08/22/95 1:30 PM ] ;;2.6;IHS/VA UTILITIES;**7**;JUN 28, 1993 ; LOADS ; I $S('$D(DUZ)#2:1,'$D(DUZ(0))#2:1,1:0) W:'$D(ZTQUEUED) !,"DUZ and DUZ(0) must be defined to continue." K DIFQ Q K DIF,DIK,D,DDF,DDT,DTO,D0,DLAYGO,DIC,DIR,DA,DFR,DTN,DIX,DZ D DT^XBONIT2 S %=1,U="^",DSEC=1 S NO=$P("I 0^I $D(@X)#2,X[U",U,%) I %<1 K DIFQ Q W:'$D(ZTQUEUED) !," PROTOCOL INSTALLATION" Q:'$D(DIFQ) ;S %=0 W:'$D(ZTQUEUED) !!,"ARE YOU SURE YOU WANT TO CONTINUE" D YN^DICN I %-1 K DIFQ Q D DT^XBONIT2 K ^UTILITY(U,$J),^UTILITY("DIK",$J) W:'$D(ZTQUEUED) !,"...OK, this may take a while, hold on please..." F R=1001:1:1001 D @("^XBONI"_$E(R,2,4)) W:'$D(ZTQUEUED) "." XBONIT2 XBONIT2 ; IHS/ADC/GTH - ENTRIES TO PROTOCOL FILE FOR LIST MANAGER, UPGRADE 7 ; [ 08/22/95 1:30 PM ] ;;2.6;IHS/VA UTILITIES;**7**;JUN 28, 1993 ; ; K ^UTILITY("ORVROM",$J),DIC Q DT W:'$D(ZTQUEUED) ! I '$D(DTIME) S DTIME=999 K %DT D NOW^%DTC S DT=X K DIK,DIC,%I,DICS Q ; XBONIT3 XBONIT3 ; IHS/ADC/GTH - ENTRIES TO PROTOCOL FILE FOR LIST MANAGER, UPGRADE 7 ; [ 08/22/95 1:30 PM ] ;;2.6;IHS/VA UTILITIES;**7**;JUN 28, 1993 ; ; K ^UTILITY("ORVROM",$J) S DIC(0)="LX",ORNMCHK=1 I $D(^ORD(101,0))#2,^(0)?1"PROTOCOL".E S DIC="^ORD(101,",DLAYGO=101,N="PRO" D ADD,OP K ^UTILITY(U,$J),DIC,DLAYGO Q DIEZ I ^DD("VERSION")>17.4,'$D(DISYS),$D(^%ZOSF("OS"))#2 S DISYS=+$P(^("OS"),"^",2) E S DISYS=^DD("OS") Q:'$D(^DD("OS",DISYS,"ZS")) S N=$O(^UTILITY("ORVROM",$J,DIR,0)) Q:N="" S Y=+^(N) K ^(N) I $D(@("^"_DIR_"(Y,""ROU"")")) K ^("ROU") I $D(^("ROUOLD")) S X=^("ROUOLD"),DMAX=^DD("ROU") D:X]"" @("EN^DI"_$E(DIR,3)_"Z") G DIEZ ; OP S NM=$O(^UTILITY("ORVROM",$J,N,NM)) I NM="" K ^UTILITY("ORVROM",$J) G Q S R=$O(^UTILITY("ORVROM",$J,N,NM,0)) G:R="" OP W:'$D(ZTQUEUED) !,"'"_NM_"' Protocol Filed" S DA=+^UTILITY("ORVROM",$J,N,NM,R) S %=$P(^ORD(101,DA,0),U,12) S:%]"" %=$O(^DIC(9.4,"B",%,0)) S $P(^ORD(101,DA,0),U,12)=%,(ORDZ,ORDIX)=0 S %=$S($D(^ORD(101,DA,5)):$P(^(5),"^"),1:"") I $L(%) S $P(^(5),"^")="",X=$P(%,";",2),%=$P(%,";") I $D(@("^"_X_"""B"","""_%_""")")) S %=$O(^(%,0)) S %=$S(%:%_";"_X,1:""),$P(^ORD(101,DA,5),"^")=% I $D(^ORD(101,DA,3,0)) S I=0 F S I=$O(^ORD(101,DA,3,I)) Q:I<1 S KEY=^(I,0) K ^(0) I $D(^DIC(19.1,"B",KEY)) S KEY=$O(^(KEY,0)) I KEY S ^ORD(101,DA,3,I,0)=KEY I $D(^ORD(101,DA,3)) S I=0 F S I=$O(^ORD(101,DA,3,I)) Q:I<1 S ORDZ=ORDZ+1,ORDIX=X I S $P(^ORD(101,DA,3,0),"^",3,4)=ORDIX_"^"_ORDZ I $D(^UTILITY("ORVROM",$J,N,NM,R,10)) S X=0 F S X=$O(^UTILITY("ORVROM",$J,N,NM,R,10,X)) Q:X<1 D A1 S (ORDZ,ORDIX)=0 S X=0 F S X=$O(^ORD(101,DA,10,X)) Q:X<1 S ORDZ=ORDZ+1,ORDIX=X S:$D(^ORD(101,DA,10,0)) ^(0)="^101.01PA^"_ORDIX_U_ORDZ D IX1^DIK I $D(^UTILITY("ORVROM",$J,N,NM,R,"MEN")) S IMEN=0 F S IMEN=$O(^UTILITY("ORVROM",$J,N,NM,R,"MEN",IMEN)) Q:IMEN="" S OMEN=^(IMEN),MEN=IMEN D MEN K MEN,IMEN,OMEN G OP ; ADD S R=0 F S R=$O(^UTILITY(U,$J,N,R)) Q:R="" S X=$P(^(R,0),U),I=$P(^(0),U,4) D . I $L($T(DOT^ORVOM)) D DOT^ORVOM . I '$L($T(DOT^ORVOM)) W:'$D(ZTQUEUED) "." . I $O(^ORD(101,"B",X,0)) S Y=$O(^(0)),ORA=Y,Y=Y_U D A Q . D ^DIC I Y>0,'$D(DIFQ(N))!$P(Y,U,3) S ORA=Y,Y=Y_U D A Q K ORA,MEN,OMEN,ORNMCHK,ORDZ,ORDIX S (NM,R)=0 Q A S ^UTILITY("ORVROM",$J,N,X,R)=Y I $O(^UTILITY(U,$J,N,R,1,0))>0 K ^ORD(101,+Y,1) I $O(^UTILITY(U,$J,N,R,10,0))>0 S %X="^UTILITY(U,$J,N,R,10,",%Y="^UTILITY(""ORVROM"",$J,N,X,R,10," D %XY^%RCR K ^UTILITY(U,$J,N,R,10) I $D(^UTILITY(U,$J,N,R,"MEN")) S %X="^UTILITY(U,$J,N,R,""MEN"",",%Y="^UTILITY(""ORVROM"",$J,N,X,R,""MEN""," D %XY^%RCR K ^UTILITY(U,$J,N,R,"MEN") S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+ORA,",DA=+ORA,DIK=DIC D %XY^%RCR Q A1 S ORA=DA N DA,DIC,ORI S Y="",ORI=0,DIC="^ORD(101,"_+ORA_",10,",DIC(0)="L",DA(1)=+ORA S:'$D(^ORD(101,DA(1),10,0)) ^(0)="^101.01PA^^" F S ORI=$O(^UTILITY("ORVROM",$J,N,NM,R,10,ORI)) Q:ORI<1 S X0=^(ORI,0),X=$S($D(^(U)):^(U),1:"") I $L(X) D A2 K DA,^UTILITY("ORVROM",$J,N,NM,R,10) Q A2 N X1 S DLAYGO=101 D ^DIC Q:'Y I $P(Y,"^",3) W:'$D(ZTQUEUED) !?2,X_" added as item to "_$P(^ORD(101,DA(1),0),"^")_"." S X0=^UTILITY("ORVROM",$J,N,NM,R,10,ORI,0) S %=$P(X0,"^",4) I $L(%) S %=$O(^ORD(101,"B",%,0)) S:% $P(X0,"^",4)=% S $P(^ORD(101,DA(1),10,+Y,0),"^",2,99)=$P(X0,"^",2,99) S X1=0 F S X1=$O(^UTILITY("ORVROM",$J,N,NM,R,10,ORI,X1)) Q:X1="" I X1'["^" S X0=^UTILITY("ORVROM",$J,N,NM,R,10,ORI,X1),^ORD(101,DA(1),10,+Y,X1)=X0 Q MEN S MEN=$S($D(^ORD(101,"B",MEN)):$O(^(MEN,0)),1:"") I 'MEN K ^UTILITY("ORVROM",$J,N,NM,R,"MEN") Q S X=NM,X0=OMEN,DIC="^ORD(101,"_MEN_",10,",DIC(0)="L",DA(1)=MEN S:'$D(^ORD(101,DA(1),10,0)) ^(0)="^101.01PA^^" S DIC("DR")="2///"_$P(X0,"^",2)_";3///"_$P(X0,"^",3)_";4///"_$P(X0,"^",4)_";5///"_$P(X0,"^",5)_";6///"_$P(X0,"^",6),DLAYGO=101 D ^DIC I $P(Y,"^",3) W:'$D(ZTQUEUED) !?2,X_" added as item to "_$P(^ORD(101,DA(1),0),"^")_"." Q XBP7 XBP7 ; IHS/ADC/GTH - XB/ZIB V 2.6 UPGRADE 7 ; [ 09/08/95 4:02 PM ] ;;2.6;IHS/VA UTILITIES;**7**;JUN 28, 1993 ; 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^XBP7(""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 XBP7 S X=+Y D H^%DTC S ZTDTH=%H_","_%T S ZTRTN="START^XBP7",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 FILE94 W:'$D(ZTQUEUED) !!?5,"Adding 4 Protocols to PROTOCOL file..." D ^XBONIT D MAIL^XBMAIL("XUMGR-XUPROGMODE","DESC^XBP7") I $D(ZTQUEUED) S ZTREQ="@" F X="XBONI001","XBONIT","XBONIT1","XBONIT2","XBONIT3" X ^%ZOSF("DEL") E W !!,"You're done. ",$S('Y:"Thank you. You may delete this routine and 5 XBON* routines.",1:"MAIL MESSAGE FAILED."),! 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 upgrade is to XB/ZIB utilities. Please see the routines of the ;;upgrade for complete descriptions of the upgrades. This upgrade ;;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 upgrades in greater detail. ;;### ; Q2 ; ;;Answer "Y" if you want to queue this upgrade 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. ;;### ; FILE94 ; ----- Check for/add entry for XB in 9.4 for use with ZIBRPI. I '$D(ZTQUEUED) W !!?5,"Checking PACKAGE file for XB entry..." S Y=$$LOOK94 I Y<1 S Y=$$ADDENT I Y<1 Q I '$O(^DIC(9.4,+Y,22,"B",2.6,0)) D ADDVERS(+Y) Q ; ADDENT() ; -- Add XB entry to 9.4 I '$D(ZTQUEUED) W !!?5,"Adding XB entry to PACKAGE..." NEW DD,DIC,DLAYGO,DO,DR S DIC="^DIC(9.4,",DIC(0)="L",DLAYGO=9,X="IHS/VA UTILITIES",DIC("DR")="1///XB;2///IHS/VA XB/ZIB ROUTINES;13///2.6" D FILE^DICN Q Y ; ADDVERS(Y) ; -- Add version info to XB entry in 9.4. I '$D(ZTQUEUED) W !!?5,"Adding XB Version info to PACKAGE..." NEW DD,DIC,DLAYGO,DO,DR I '$P($G(^DIC(9.4,Y,22,0)),U,2) S $P(^DIC(9.4,Y,22,0),U,2)="9.49I" S DA(1)=Y,DIC="^DIC(9.4,"_Y_",22,",DIC(0)="L",DLAYGO=9,X="2.6",DIC("DR")="1///JUN 28, 1993" D FILE^DICN Q ; LOOK94() ; -- Look for XB entry in 9.4 NEW DIC S X="IHS/VA UTILITIES",DIC=9.4,DIC(0)="" D ^DIC I Y>0 Q Y S D="C",X="XB" D IX^DIC Q Y ; DESC ; ;;XB/ZIB v 2.6, Upgrade 7 Announcement. ;; ;;+++++++++++++++ XB/ZIB 2.6 Upgrade 7 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-837-4189 ;; ;;----------------------------------------------------------------- ;; ;;(1) XBMAIL - DELIVER MAIL MESSAGE TO LOCAL SECURITY KEY HOLDERS. ;;Routine XBMAIL will deliver a mail message to local users holding ;;given security keys. The text of the message must be in a routine ;;supplied by the caller. This utility is intended to facilitate ;;communications with local users when upgrades to application ;;packages are installed. Please see routine XBMAIL for details ;;and examples. ;; ;;----------------------------------------------------------------- ;; ;;(2) XBDIR - DIR INTERFACE. ;;This utility provides one location for steps in setting up and ;;calling the reader, ^DIR. The call is in the form of an extrinsic. ;;Please see routine XBDIR for details and examples. ;; ;;----------------------------------------------------------------- ;; ;;(3) XBBPI - BUILD PRE-INIT ROUTINE. ;;The routine has been modified to use %ZOSF("SAVE") instead of ;;implementation-specific ZI and ZS commands, and to accommodate a ;;change in the PACKAGE file that affected the checking for the ;;existence of the entry of a pre-init routine. ;; ;;----------------------------------------------------------------- ;; ;;(4) XBDIQ1 - FRIENDLY FRONT END TO EN^DIQ1. ;;This routine provides a friendly front end to EN^DIQ1 and an ;;assortment of other features. Please see the documentation routine, ;;XBDIQ0, for descriptions and examples. ;; ;;----------------------------------------------------------------- ;; ;;(5) XBFLD - DICTIONARY LISTING. ;;The list manager has been incorporated into a display of the ;;selected dd(s), for browse capabilities. Expanded information is ;;provided for selected field types. ;; ;;----------------------------------------------------------------- ;; ;;(6) XBFMK - KILL FILEMAN VARIABLES. ;;The list of KILL'd variables left around after calls to FileMan ;;has been updated. ;; ;;----------------------------------------------------------------- ;; ;;(7) XBLM - INTERFACE TO LIST MANAGER. ;;This utility uses the Veterans Administration List Manager (VALM). ;;Functionality includes displaying a selected file, selecting a host ;;file for display, displaying a printout of a routine, and displaying ;;an array. Please see the top of routine XBLM for a list and ;;description of entry points. ;;NOTE: Protocols are installed by 5 init routines in this upgrade in ;; the XBON* namespace. ;; ;;----------------------------------------------------------------- ;; ;;(8) XBNEW - NEW ENTRY POINT. ;;Because of the continuing debate in MDC over conformance to the ;;ANSI standard if a first line of a routine contains a formal ;;parameter list, a new entry point has been added that maintains ;;the functionality of the first line entry. The first line has ;;been retained for backwards compatibility, but could be removed if ;;the MDC rules it illegal. An unnecessary KILL has been removed. ;; ;;----------------------------------------------------------------- ;; ;;(9) XBPFTV - POINTER FIELD TERMINAL VALUE. ;;This utility was upgraded to allow an unlimited level of retrieval, ;;and to provide a non-first-line entry point, should the MDC decide ;;formal lists are incompatible with routine first lines. ;; ;;----------------------------------------------------------------- ;; ;;(10) XBSFGBL - SUBFILE GLOBAL REFERENCE. ;;The capability of returning the top level global reference has been ;;corrected. A non-first-line entry point has been added. ;; ;;----------------------------------------------------------------- ;; ;;(11) XBSITE - SET DUZ(2). ;;This utility has been upgraded to check file 200, as well as file 3, ;;for facilities that the user is allowed to select. ;; ;;----------------------------------------------------------------- ;; ;;(12) ZIBRSEL - NONINTERACTIVE ROUTINE SELECT. ;;This utility provides the capability of a programmer selecting ;;routines for processing, without user intervention. Please see the ;;routine for documentation. Currently, only MSM is supported. ;; ;;----------------------------------------------------------------- ;; ;;(13) XBFORM - BUILD LM ARRAY FROM WP FORMAT. ;;This utility allows you to construct a screen format for the List ;;Manager thru manipulating an array of word processing lines. For ;;documentation, please see routine XBFORM0. ;; ;;----------------------------------------------------------------- ;; ;;(14) ZIBGSVEM - CHMOD FOR FILE PERMISSIONS. ;;It is possible for uucp to fail on SCO platforms because of file ;;permissions denying access from the polling system. This upgrade ;;changes the permissions on unix files saved by the XBGSAVE utility. ;; ;;----------------------------------------------------------------- ;; ;;(15) XBLCALL - LIST CALLABLE ROUTINES. ;;This routine has been updated to briefly list callable XB/ZIB entry ;;points from the XB menu for programmers. ;; ;;----------------------------------------------------------------- ;; ;;++++++++++++++++++++ end of Upgrade 7 announcement +++++++++++++++++ ;;### ; XBPFTV XBPFTV(F,E,V) ; IHS/ADC/GTH - RETURN POINTER FIELD TERMINAL VALUE ; [ 08/22/95 1:34 PM ] ;;2.6;IHS/VA UTILITIES;**7**;JUN 28, 1993 ; XB*2.6*7 IHS/ADC/GTH 07-10-95, Namespace and check for valid E. ; ; NOTE TO PROGRAMMERS; Use entry point PFTV. Do not use the first ; line of this routine, as pending initiatives in MDC might make ; a formal list on the first line of a routine invalid. ; GTH 07-10-95 ; ; Given a file number, file entry number, and variable name into ; which the results will be placed, return the terminal value after ; following the pointer chain. ; ; U must exist and have a value of "^" ; ; Formal list: ; ; 1) F = file number (call by value) ; 2) E = file entry number (call by value) ; 3) V = variable for results (call by reference) ; ; Scratch vars: ; D = Flag, 1 = Done, 0 = continue ; G = Global for file F. ; ; *** NO ERROR CHECKING DONE *** ; G START ; XB*2.6*7 IHS/ADC/GTH 07-10-95, ; ; The below PEP should be used in case the current movement to ; not allow a formal list of parameters on the first line of a ; routine passes thru MDC. ; PFTV(F,E,V) ;PEP - Return Pointer Field Terminal Value. ; XB*2.6*7 IHS/ADC/GTH 07-10-95, ; START ; NEW D,G F D TRACE Q:D Q ; TRACE ; FOLLOW POINTER CHAIN S D=1,V=E ; XB*2.6*7 IHS/ADC/GTH 07-10-95, Q:'E ; XB*2.6*7 IHS/ADC/GTH 07-10-95, S G=^DIC(F,0,"GL") Q:'$D(@(G_E_",0)")) S V=$P(@(G_E_",0)"),U) Q:$P(^DD(F,.01,0),U,2)'["P" S F=+$P($P(^DD(F,.01,0),U,2),"P",2) Q:'$D(@(G_E_",0)")) S E=$P(@(G_E_",0)"),U) S D=0 Q ; XBPKDEL XBPKDEL ; IHS/ADC/GTH - REMOVE OPTIONS, INPUT,SORT,PRINT TEMPLATES, HELP FRAMES, BULLETINS, FUNCTIONS,, AND IF INDICATED, SECURITY KEYS FOR A PACKAGE ; [ 08/22/95 4:00 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 ; XBSFGBL XBSFGBL(S,G,F) ; IHS/ADC/GTH - RETURN SUBFILE GLOBAL REFERENCE ; [ 08/22/95 1:34 PM ] ;;2.6;IHS/VA UTILITIES;**7**;JUN 28, 1993 ; XB*2.6*7 IHS/ADC/GTH 07-10-95, Produce root form, EN, namespace. ; ; NOTE TO PROGRAMMERS; Use entry point EN. Do not use the first line ; of this routine, as pending initiatives in MDC might make a formal ; list on the first line of a routine invalid. GTH 07-10-95 ; ; Given a file or subfile number and global reference form, this ; routine will return the global reference in the form specified. ; ; F (form) is optional but if passed should equal 1 or 2. If F is ; not passed the default form will be 1. ; ; F = 1 will be in the form ^GLOBAL(DA(2),11,DA(1),11,DA, ; F = 2 will be in the form ^GLOBAL(D0,11,D1,11,D2, ; ; Formal list: ; ; 1) S = subfile number (call by value) ; 2) G = global reference (call by reference) ; 3) F = global reference form (call by value) ; ; *** NO ERROR CHECKING DONE *** ; START ; ; D = Field ; I = Counter ; L = Level ; N = Node ; P = Parent ; NEW D,I,L,N,P ; S G="",L=1 I '$D(^DD(S,0,"UP")) D NOPARENT Q D BACKUP S G=^DIC(P,0,"GL") I $G(F)=2 D S G=G_"D"_(I+1)_"," I 1 . F I=0:1 S G=G_"D"_I_","_N(99-L)_",",L=L-1 Q:L=0 . Q E D S G=G_"DA," . F L=L:-1:0 Q:L=0 S G=G_"DA("_L_"),"_N(99-L)_"," . Q Q ; BACKUP ; BACKUP TREE S P=^DD(S,0,"UP") S D=$O(^DD(P,"SB",S,"")) S N(99-L)=$P($P(^DD(P,D,0),"^",4),";",1) S:N(99-L)'=+N(99-L) N(99-L)=""""_N(99-L)_"""" I $D(^DD(P,0,"UP")) S S=P,L=L+1 D BACKUP Q ; NOPARENT ; for no parent S G=^DIC(S,0,"GL") I $G(F)=2 S G=G_"D0" I 1 E S G=G_"DA," Q ; DIC(S) ;PEP - Extrinsic entry to return root global from FILE number NEW G D EN(S,.G) S G=$P(G,"DA,") Q G ; EN(S,G,F) ;PEP - RETURN SUBFILE GLOBAL REFERENCE G START ;-------------------- XBSITE XBSITE ; IHS/ACD/GTH - SET "DUZ(2)" ; [ 08/22/95 1:30 PM ] ;;2.6;IHS/VA UTILITIES;**7**;JUN 28, 1993 ; XB*2.6*7 IHS/ADC/GTH 07-07-95, Add check for ^VA(200. ; L1 ; KILL DIC G:$D(DUZ)=0!($D(DUZ)=10) ERRMSG I ('$D(^DIC(3,DUZ,0))),('$D(^VA(200,DUZ,0))) G ERRMSG ; XB*2.6*7 IHS/ADC/GTH 07-07-95 I ('$D(^DIC(3,DUZ,2,0))),('$D(^VA(200,DUZ,2,0))) G ERRMSG1 ; XB*2.6*7 IHS/ADC/GTH 07-07-95 I +DUZ(2)>0 S DIC("B")=$P(^DIC(4,DUZ(2),0),"^",1) G B1 S DIC("B")="Site set to zero (0) for Universal" B1 ; W !! D ASK S SITENUM=DUZ(2) KILL DIC("A"),DIC("B"),DA,DR,Y Q ; ASK ; S DIC="^DIC(3,DUZ,2,",DIC("A")="Enter your facility's name: ",DIC(0)="QAEM" I $D(^VA(200,DUZ,2,0)) S DIC="^VA(200,DUZ,2," ; XB*2.6*7 IHS/ADC/GTH 07-07-95 D ^DIC G:X["?" ASK I X="^",$D(DIC("B")) W !,*7,"The default facility remains ",DIC("B"),!! Q S DUZ(2)=+Y I DUZ(2)<1 S DUZ(2)=$P(^AUTTSITE(1,0),U,1) W !,*7,"The default facility has been set to ",$P(^DIC(4,DUZ(2),0),"^",1),!! S SITENUM=DUZ(2) Q ; SET ;PEP - ENTRY POINT TO FORCE SET OF DUZ(2) FROM APPLICATIONS* G L1 ERRMSG W !!,"USER not set in DUZ - use KERNEL!" Q ERRMSG1 W !!,"No Divisions (facilities) set in USER file!" Q ERRMSG2 W !!,"That facility is not included in your Divisions field in the USER file!" Q ; XBVLINE XBVLINE ; IHS/ADC/GTH - SET LINE TWO OF SELECTED ROUTINES ; [ 08/22/95 1:30 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 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 ; [ 08/22/95 1:30 PM ] ;;2.6;IHS/VA UTILITIES;**6**;JUN 28, 1993 ; 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 ; [ 07/07/95 3:19 PM ] ;;2.6;IHS/VA UTILITIES;**1,6**;JUN 28, 1993 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. " 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 ; [ 08/22/95 1:30 PM ] ;;2.6;IHS/VA UTILITIES;**1,5,6,7**;JUN 28, 1993 ; XB*2.6*7 IHS/ADC/GTH 08-09-95 ; 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,! S X=$$JOBWAIT^%HOSTCMD("chmod 666 "_XBUF_"/"_XBFN) ; XB*2.6*7 IHS/ADC/GTH 08-09-95 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. ." 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 KILL 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 ; [ 07/07/95 3:19 PM ] ;;2.6;IHS/VA UTILITIES;**1**;JUN 28, 1993 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 ; [ 07/07/95 3:19 PM ] ;;2.6;IHS/VA UTILITIES;**4**;JUN 28, 1993 ; ; 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 ; 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) ; [ 08/22/95 4:00 PM ] ;;2.6;IHS/VA UTILITIES;**4**;JUN 28, 1993 ; 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' 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) ; [ 07/07/95 3:19 PM ] ;;2.6;IHS/VA UTILITIES;**4**;JUN 28, 1993 ; 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. 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 ; ZIBRSEL ZIBRSEL ; IHS/ADC/GTH - NONINTERACTIVE ROUTINE SELECT ; [ 08/22/95 1:30 PM ] ;;2.6;IHS/VA UTILITIES;**7**;JUN 28, 1993 ; ; 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) 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 $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 ;