commit 870730c3f51a43361744da983abfd22ffba0a108 Author: sam Date: Mon Dec 7 17:42:41 2009 +0000 Modified directory structure; moved routines. diff --git a/XB.m b/XB.m new file mode 100644 index 0000000..332dc10 --- /dev/null +++ b/XB.m @@ -0,0 +1,183 @@ +XB ; IHS/ADC/GTH - UTILITY MENU ; [ 04/28/2003 9:38 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; 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 routine XB1. + ; +START ; + I '$D(^%ZOSF("TEST"))!('$D(^%ZOSF("TRAP"))) W !!,"Missing ^%ZOSF nodes!",! Q + S X="%ZIS" + D RCHK + I XBFAIL D EOJ Q + D ^XBKSET + 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:$G(DTIME,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 Q + . S XBH="" + . D LIST + . KILL XBH + . W !!,"To get help on a non-menu option enter '?n' where n is the option number.",! + . D PAUSE + .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 + . KILL ^UTILITY($J) + . S XBX=$P($T(@XBLBL+XBY^XB1),";;",3) + . 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),X=XBX + . D RCHK + . I XBFAIL W !!,"No help available. Routine ^",XBX," not in ",$S($E(XBX)="%":"MGR",1:"UCI"),".",! Q + . S %=$$RSEL^ZIBRSEL(XBX,"^UTILITY($J,") + . D EN^XBRPTL + . KILL ^UTILITY($J) + .Q + W *7 + Q + ; +LIST ; List menu options. + KILL XBTBL + ;W !!?5,$P($T(XB+1),";",4)," v ",$$CV^XBFUNC("XB");IHS/SET/GTH XB*3*9 10/29/2002 + W !!?5,$P($T(XB+1),";",4)," v ",$$VERSION^XPDUTL("XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + W !!?5,$P($T(@XBLBL^XB1),";;",2),! + F XBI=1:1 S XBX=$T(@XBLBL+XBI^XB1) Q:$E(XBX)'=" " S XBY=$P(XBX,";;",3),XBX=$P(XBX,";;",2) D + . S X=$$UP^XLFSTR(XBX) + . S XBTBL(X)=XBI_"^"_XBX + . W !,XBI,?5,XBX," ",$S($D(XBH):$S(XBY:"[menu]",1:XBY),1:$S(XBY:"[menu]",1:"")) + .Q + Q + ; +LETTERS ; + KILL XBC + S XBY=$$UP^XLFSTR(XBY) + 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:$G(DTIME,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) + 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",@^%ZOSF("TRAP") + ; D ^XBNEW("CALL^XB:XBX;DT;DTIME;U;DUZ") ;IHS/SET/GTH XB*3*9 10/29/2002 + D EN^XBNEW("CALL^XB","XBX;DT;DTIME;U;DUZ") ;IHS/SET/GTH XB*3*9 10/29/2002 + Q + ; +CALL ; + 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,XBLBL=$E(XBLBL,1,$L(XBLBL)-1) + W ! + Q + ; +TRAP ; ERROR TRAP + W !!,"The following error has occurred: ",$$Z^ZIBNSSV("ERROR"),! + D:XBP="" PAUSE + Q + ; +PAUSE ;EP + Q:'(IO=IO(0)) + Q:'($E(IOST,1,2)="C-") + S Y=$$DIR^XBDIR("EO") + S:$D(DUOUT) XBQ=1 + Q + ; +CHECK ; CHECK XB OPTION ROUTINES (EXECUTED FROM ^XB MENU OPTION) + W !,"Patch ",$$PATS," is the highest XB/ZIB patch installed." ;IHS/SET/GTH XB*3*9 10/29/2002 + 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 + . I X'?.8UN1"^"1.8UN,X'?.8UN1"^"1"%"1.7UN S XBII(4,XBII)=$P($T(M+XBII^XB1),";;",2,9) Q + . 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.",! KILL 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 ",$S($$VERSION^%ZOSF(1)["Cache":"this Namespace",1:"MGR"),":" S X="" F S X=$O(XBII(3,X)) Q:X="" W !?3,X ;IHS/SET/GTH XB*3*9 10/29/2002 + 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 ! + KILL XBII + Q + ; +RCHK ;EP - Check Existence of Routine in X + S XBRTN=X,XUSLNT=1 + ; I $E(XBRTN)="%" X ^%ZOSF("UCI") S XBUCI=Y,%UCI="MGR" D 2^%XUCI ; IHS/SET/GTH XB*3*9 10/29/2002 + I ^%ZOSF("OS")["MSM",$E(XBRTN)="%" X ^%ZOSF("UCI") S XBUCI=Y,%UCI="MGR" D 2^%XUCI ; IHS/SET/GTH XB*3*9 10/29/2002 + S X=XBRTN + X ^%ZOSF("TEST") + S XBFAIL='$T + ; I $E(XBRTN)="%" S %UCI=XBUCI D 2^%XUCI ; IHS/SET/GTH XB*3*9 10/29/2002 + I ^%ZOSF("OS")["MSM",$E(XBRTN)="%" S %UCI=XBUCI D 2^%XUCI ; IHS/SET/GTH XB*3*9 10/29/2002 + W:XBFAIL !!,"Routine ",XBRTN," missing!" + S X=XBRTN + KILL XUSLNT + Q + ; +EOJ ; + D ^XBKTMP,EN^XBVK("XB") + KILL ^UTILITY($J) + KILL DIRUT,DTOUT,DUOUT + KILL X,Y + Q + ; +OSNO ;EP + W $C(7),!,"Sorry...",!,"Operating System '",$P(^%ZOSF("OS"),"^",1),"' is not supported." + I $$DIR^XBDIR("EO","Press RETURN") ;IHS/SET/GTH XB*3*9 10/29/2002 + Q + ; + ;Begin New Code;IHS/SET/GTH XB*3*9 10/29/2002 +PATS() ;Display patches installed for XB. + NEW I,P,V + S I=$O(^DIC(9.4,"C","XB",0)) + Q:'I "??" + S V=$O(^DIC(9.4,I,22,"B",$P($T(+2),";",3),0)) + Q:'V "??" + S P=0 + F %=0:0 S %=$O(^DIC(9.4,I,22,V,"PAH",%)) Q:'% I $P(^(%,0),"^",1)>P S P=$P(^(0),"^",1) + Q P + ;End New Code;IHS/SET/GTH XB*3*9 10/29/2002 diff --git a/XB1.m b/XB1.m new file mode 100644 index 0000000..0bffb2f --- /dev/null +++ b/XB1.m @@ -0,0 +1,143 @@ +XB1 ; IHS/ADC/GTH - XB MENUS AND DOCUMENTATION ; [ 12/29/2004 11:11 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods. + ; + ; 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 and patch level;;CHECK^XB;;P;;IHS/SET/GTH XB*3*9 10/29/2002 +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/Namespaces;;^XBFCMP;;P;;IHS/SET/GTH XB*3*9 10/29/2002 + ;;Search for routines executed from dictionary;;^XBRSRCH + ;;Fix 0th nodes;;^XBCFIX;;P + ;;Count entries in file;;^XBCOUNT + ;;FileMan;;P^DI + ;;Delete dictionaries;;^XBKD + ;;Clean dictionaries [caution];;^XBCDIC + ;;List file attributes in various ways;;1;;IHS/SET/GTH XB*3*9 10/29/2002 + ;;Files Marked For Deletion;;!N L,DIC,BY,FLDS S L=0,DIC=1,(BY,FLDS)="[XB - FILES MARKED FOR DELETION]" D EN1^DIP;;P;;IHS/SET/GTH XB*3*9 10/29/2002 + ;;Fields Marked For Deletion;;^XBLFMD;;P;;IHS/SET/GTH XB*3*9 10/29/2002 + ;;Print File IDs, Specifiers, and Conditionals;;^XBSIC;;P;;IHS/SET/GTH XB*3*9 10/29/2002 +M11 ;;LIST FILE ATTRIBUTES IN VARIOUS WAYS;;IHS/SET/GTH XB*3*9 10/29/2002 + ;;List Files, inc. Number, Name, Global, opt Desc.;;^XBLFD;;P;;IHS/SET/GTH XB*3*9 10/29/2002 + ;;List Fields for RIM Modeling;;^XBLFAM;;P;;IHS/SET/GTH XB*3*9 10/29/2002 + ;;List Fields for CodeSets (RTM) Modeling;;^XBLFSETS;;P;;IHS/SET/GTH XB*3*9 10/29/2002 +M2 ;;GLOBALS + ;;List global;;!D LG^ZIBVSS + ;;Directory of selected globals;;^ZIBGD;;P + ;;Count unique values;;^XBCNODE + ;;List high entry number;;^XBGLDFN;;P + ;;Copy to another global in same UCI/Namespace;;^XBGC;;;;IHS/SET/GTH XB*3*9 10/29/2002 + ;;Copy global to another UCI/Namespace;;!D CG^ZIBVSS;;;;IHS/SET/GTH XB*3*9 10/29/2002 + ;;Search global for value;;!D GSE^ZIBVSS + ;;Global edit;;!D GE^ZIBVSS + ;;Change global value;;!D GCH^ZIBVSS + ;;Global size/efficiency;;!D GSZE^ZIBVSS;;P + ;;Global characteristics;;!D GCHR^ZIBVSS + ;;Global delete;;!D GDEL^ZIBVSS + ;;Global restore;;!D GR^ZIBVSS + ;;Global save;;!D GS^ZIBVSS + ;;Find control chrs in globals;;^ZIBGCHR + ;;Compare Two Globals;;^XBGCMP +M3 ;;ROUTINES + ;;List routines in various ways;;1 + ;;Compare routines in two UCIs/Namespaces;;!D RCMP^ZIBVSS;;P;;IHS/SET/GTH XB*3*9 10/29/2002 + ;;Restore routines;;!D RR^ZIBVSS + ;;Save routines;;!D RS^ZIBVSS + ;;Routine size;;^XBRSIZ;;P + ;;Delete routines;;!D RDEL^ZIBVSS;;P;;IHS/SET/GTH XB*3*9 10/29/2002 + ;;Search routines for values (OR);;!D RSE^ZIBVSS;;P;;IHS/SET/GTH XB*3*9 10/29/2002 + ;;Search routines for values (AND);;!D RSAND^ZIBVSS + ;;Find routines by edit date;;!D NEWED^ZIBVSS;;P + ;;Full screen editor;;!D REDIT^ZIBVSS + ;;Routine change;;!D RCHANGE^ZIBVSS + ;;Routine copy;;!D RCOPY^ZIBVSS + ;;Directory of selected routines;;^ZIBRD;;P + ;;Scan UCIs/Namespaces for routine;;^ZIBFR;;P;;IHS/SET/GTH XB*3*9 10/29/2002 + ;;Run routine;;!R " Enter routine name: ",Y:30 Q:'$T S:Y'["^" Y="^"_Y S X=$P(Y,"^",2),X=$P(X,"(",1) 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;;!D RPRT^ZIBVSS;;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 + ;;List routines by patch number;;^XBPATSE;;P +M4 ;;MISCELLANEOUS + ;;Error report;;!D ER^ZIBVSS;;P;;IHS/SET/GTH XB*3*9 10/29/2002 + ;;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 + ;;Print a Help Frame manual;;^XBHFMAN + ;;List Local Variables, by Namespace;;MESSAGE^XBVL;;P + ;;Print XB/ZIB Technical Manual;;^XBTM + ;;Check Patient Globals;;^XBPATC;;P +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;;^XBSUMBLD + ;;List callable subroutines;;^XBLCALL;;P + ;;Reset file data globals *** DANGER ***;;^XBFRESET + ;;Edit FM print template headers;;^XBDH + ;;List retired/replaced packages;;LIST^XBPKDEL1;;P;;XB*3*8 + ;;Delete retired/replaced packages;;DECERT^XBPKDEL1;;P;;XB*3*8 + ;;Edit File attribute for selected File(s);;^XBDDEDIT;;P;;IHS/SET/GTH XB*3*9 10/29/2002 + ;;Move files into PACKAGE file FILE multiple;;^XBPKG;;P;;IHS/SET/GTH XB*3*9 10/29/2002 + ;;Set dd audit;;^XBSDDAUD;;P;;IHS/SET/GTH XB*3*9 10/29/2002 + ;;dd Field Numbering Conventions;;^XBFNC;;P;;IHS/SET/GTH XB*3*9 10/29/2002 + ;;Options and Security Keys;;^XBSECK;;P;;IHS/SET/GTH XB*3*9 10/29/2002 diff --git a/XB3P9.m b/XB3P9.m new file mode 100644 index 0000000..381da20 --- /dev/null +++ b/XB3P9.m @@ -0,0 +1,161 @@ +XB3P9 ;IHS/SET/GTH - XB 3 PATCH 9 ; [ 04/21/2003 9:21 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; IHS/SET/GTH XB*3*9 10/29/2002 + ; + I '$G(IOM) D HOME^%ZIS + ; + NEW IORVON,IORVOFF + S X="IORVON;IORVOFF" + D ENDR^%ZISS + ; + I '$G(DUZ) W !,"DUZ UNDEFINED OR 0." D SORRY(2) Q + ; + I '$L($G(DUZ(0))) W !,"DUZ(0) UNDEFINED OR NULL." D SORRY(2) Q + ; + S X=$P(^VA(200,DUZ,0),U) + D BMES^XPDUTL($$CJ^XLFSTR("Hello, "_$P(X,",",2)_" "_$P(X,","),IOM)) + D BMES^XPDUTL($$CJ^XLFSTR("Checking Environment for "_$P($T(+2),";",4)_" V "_$P($T(+2),";",3)_" Patch "_$P($T(+2),";",5)_".",IOM)) + ; + NEW XBQUIT + S XBQUIT=0 + I '$$VCHK("XB","3.0",2,"'=") S XBQUIT=2 + ; + NEW DA,DIC + S X="XB",DIC="^DIC(9.4,",DIC(0)="",D="C" + D IX^DIC + I Y<0,$D(^DIC(9.4,"C","XB")) D S XBQUIT=2 + . D BMES^XPDUTL($$CJ^XLFSTR("You Have More Than One Entry In The",IOM)),MES^XPDUTL($$CJ^XLFSTR("PACKAGE File with an ""XB"" prefix.",IOM)) + . D MES^XPDUTL($$CJ^XLFSTR(IORVON_"One entry needs to be deleted."_IORVOFF,IOM)) + . D MES^XPDUTL($$CJ^XLFSTR("FIX IT! Before Proceeding.",IOM)) + .Q + ; + I $G(XPDENV)=1 D + . S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0 + . Q:DUZ(0)["@" + . D BMES^XPDUTL("I need ""@"" in your DUZ(0) for the install to work.") + . D MES^XPDUTL("In programmer mode, D P^DI,^XUP, and select ""XPD MAIN"" when you're prompted") + . D MES^XPDUTL("for OPTION NAME.") + . S XBQUIT=2 + .Q + ; + I XBQUIT D SORRY(XBQUIT) Q + ; + D BMES^XPDUTL($$CJ^XLFSTR("ENVIRONMENT OK.",IOM)) + ; + I '$$DIR^XBDIR("E","","","","","",2) D SORRY(2) + Q + ; +SORRY(X) ; + KILL DIFQ + S XPDQUIT=X + W:'$D(ZTQUEUED) *7,!,$$CJ^XLFSTR(IORVON_"Sorry...."_IORVOFF,IOM),$$DIR^XBDIR("E","Press RETURN") + Q + ; +VCHK(XBPRE,XBVER,XBQUIT,XBCOMP) ; Check versions needed. + ; + NEW XBV + S XBV=$$VERSION^XPDUTL(XBPRE) + W !,$$CJ^XLFSTR("Need "_$S(XBCOMP="<":"at least ",1:"")_XBPRE_" v "_XBVER_"....."_XBPRE_" v "_XBV_" Present",IOM) + I @(""""_XBV_""""_XBCOMP_""""_XBVER_"""") Q 0 + Q 1 + ; + ; +PRE ;EP - From KIDS. + Q + D BMES^XPDUTL("Begin 'PRE^XB3P9' at "_$$FMTE^XLFDT($$NOW^XLFDT)_".") + D BMES^XPDUTL("End 'PRE^XB3P9' at "_$$FMTE^XLFDT($$NOW^XLFDT)_".") + Q + ; +POST ;EP - From KIDS. + D BMES^XPDUTL("Begin 'POST^XB3P9' at "_$$FMTE^XLFDT($$NOW^XLFDT)_".") + ; + D BMES^XPDUTL("Attaching ""XB PACKAGE TRACKING"" option to the Site Manager menu.") + D ATTACH + ; + D BMES^XPDUTL("Setting up Q'ing of option 'XBTRK' for every 30 days.") + D QUE + ; + I $$VERSION^%ZOSV(1)["Cache" D LOAD + ; + D BMES^XPDUTL("Delivering XB*3*9 install message to select users...") + D MAIL + ; + D BMES^XPDUTL("Creating Task to delete old/unused XB/ZIB routines.") + D DELR + ; + D BMES^XPDUTL("End 'POST^XB3P9' at "_$$FMTE^XLFDT($$NOW^XLFDT)_".") + Q + ; +ATTACH ; Attach option for protection and interactive access. + I $$ADD^XPDMENU("XUSITEMGR","XB PACKAGE TRACKING","PTRK",10) D BMES^XPDUTL("....successfully atch'd....allocating Security Keys...") D I 1 + . NEW XB,DA,DIC,DINUM + . S XB=0,XB("PG")=$O(^DIC(19.1,"B","XUPROGMODE",0)),XB("TRK")=$O(^DIC(19.1,"B","XBZ PACKAGE TRACKING",0)) + . Q:'XB("PG")!'XB("TRK") + . S DIC(0)="NMQ",DIC("P")=$P(^DD(200,51,0),U,2) + . F S XB=$O(^XUSEC("XUPROGMODE",XB)) Q:'XB D + .. Q:$D(^VA(200,XB,51,XB("TRK"))) + .. S DIC="^VA(200,XB,51,",DA(1)=XB,(DINUM,X)=XB("TRK") + .. D FILE^DICN + ..Q + .Q + E D BMES^XPDUTL("....Attachment *FAILED*.") + Q + ; +QUE ; Add the option to the OPTION SCHEDULING file. + NEW DA,DIC + S DIC=19.2,DIC(0)="L",X="XB PACKAGE TRACKING",DIC("DR")="2////"_$$SCH^XLFDT("1D",DT)_".05;6///30D" + D ^DIC + I +Y<0 D BMES^XPDUTL("Entry of ""XB PACKAGE TRACKING"" into OPTION SCHEDULING file failed.") Q + S DA(1)=+Y,DIC="^DIC(19.2,"_DA(1)_",2,",DIC(0)="",DIC("P")=$P(^DD(19.2,10,0),U,2),XBSYSID(1)="cmbsyb.hqw.ihs.gov",XBSYSID(2)=$P(^AUTTSITE(1,0),U,14) + KILL DO,DD + F X="XBSYSID(1)","XBSYSID(2)" S DIC("DR")="1///"""_(@X)_"""" D FILE^DICN + D BMES^XPDUTL("""XB PACKAGE TRACKING"" has been entered into OPTION SCHEDULING file.") + Q + ; +MAIL ; Send install mail message. + NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY + KILL ^TMP("XB3P9MS",$J) + S ^TMP("XB3P9MS",$J,1)=" --- XB v 3, Patch 9, has been installed ---" + S %=0 + F S %=$O(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%)) Q:'% S ^TMP("XB3P9MS",$J,(%+1))=" "_^(%,0) + S XMSUB=$P($P($T(+1),";",2)," ",3,99),XMDUZ=$S($G(DUZ):DUZ,1:.5),XMTEXT="^TMP(""XB3P9MS"",$J,",XMY(1)="",XMY(DUZ)="" + F %="XUMGR","XUPROG","XUPROGMODE" D SINGLE(%) + D ^XMD + KILL ^TMP("XB3P9MS",$J) + Q + ; +SINGLE(K) ; Get holders of a single key K. + NEW Y + S Y=0 + Q:'$D(^XUSEC(K)) + F S Y=$O(^XUSEC(K,Y)) Q:'Y S XMY(Y)="" + Q + ; +DELR ; Create task to delete unnecessary routines. + S ZTRTN="DEL^XBDELR(""XBP8"")",ZTDESC="Delete routines in the 'XBP8' namespace.",ZTDTH=$$HADD^XLFDT($H,0,0,30,0),ZTIO="",ZTPRI=1 + D ^%ZTLOAD + Q + ; +LOAD ; If Cache', save %-routines into Namespace + D BMES^XPDUTL("Saving 5 routines as % routines in current Namespace.") + NEW DIE,DIF,X,XB,XBF,XBL,XBT,XCM,XCN,XCNP + KILL ^TMP("XB3P9",$J) + F XB=1:1 S XBL=$P($T(RTN+XB),";",3) Q:'$L(XBL) D + . S XBF=$P(XBL,U,1),XBT=$P(XBL,U,2) + . D MES^XPDUTL(" Saving '"_$$LJ^XLFSTR(XBF,8)_"' as '"_$$LJ^XLFSTR(XBT,8)_"'.") + . S DIF="^TMP(""XB3P9"",$J,",XCNP=0,X=XBF + . X ^%ZOSF("LOAD") + . S DIE="^TMP(""XB3P9"",$J,",X=XBT,XCN=0 + . X ^%ZOSF("SAVE") + . KILL ^TMP("XB3P9",$J) + .Q + Q + ; +RTN ; Routine ^ Rename As + ;;XBCLS^%XBCLS + ;;ZIBGD^%ZIBGD + ;;ZIBRD^%ZIBRD + ;;ZIBCLU0^%ZIBCLU0 + ;;ZIBZUCI^%ZUCI + ; diff --git a/XBARRAY.m b/XBARRAY.m new file mode 100644 index 0000000..739348a --- /dev/null +++ b/XBARRAY.m @@ -0,0 +1,177 @@ +XBARRAY ; IHS/ADC/GTH - BUILD AN ARRAY ; [ 07/08/1999 3:54 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; Thanks to Paul Wesley, DSD/OIRM, for the original + ; routine. + ; + ; This utility provides a word processing format of free + ; text and local variable references to build an array. + ; + ; A file is necessary 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" KILL XBZ G EDIT2 + D EXIT + KILL XBLLINE + Q + ; +EDITWP ;** edit WP array + KILL DIE,DIC,DA,DR + S DIC=XBWPDIC,DR=XBWPFLD,DIC(0)="AEQMLZ" + I $L($G(XBFORM)) S X=XBFORM,DIC(0)="XL" + D ^DIC + I Y'>0 S XBQUIT=1 Q + S DIE=$$DIC^XBDIQ1(XBWPDIC),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 + KILL 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 + .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 + .Q + 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 + 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),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) + .Q + 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),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 + S XBT=$E(Z,I+1,W-1),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),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 + ;begin Y2K fix block + ;Q $E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) + Q $E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700) ;Y2000 + ;end Y2K fix block + ; +WP(X) ;build wp entry X #:: WP(FLD,n)=TEXTn + NEW I,W + S XBLWP=$G(XBLLINE),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 "" + ; diff --git a/XBARRAY0.m b/XBARRAY0.m new file mode 100644 index 0000000..e822445 --- /dev/null +++ b/XBARRAY0.m @@ -0,0 +1,174 @@ +XBARRAY0 ; IHS/ADC/GTH - Documentation for XBARRAY ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; This utility provides a word processing format of free + ; text and local variable references to build an array. + ; + ; A file is necessary 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 efficiency so that the pre-compilation of + ; the form is held for repetitive 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 KILL 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 variables. + ; + ; 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. + ; + ; Mnemonics: A short hand for variables is available. + ; + ; Comments: Programmers comments can be put into the form + ; which are ignored by the generator. + ; + ; Output Transform: 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 Reference: Name spaced variables can + ; be long. A mnemonic reference is available to make + ; life simple. Multiple mnemonic lines can be used + ; if desired. + ; + ; SETUP + ; + ; #mnemonic1|variable1*mnemonic2|variable2*... + ; #mnemonicZ|variableZ*..... + ; + ; Example: #D|DUZ*V|BARVPT + ; #I|BARIPT + ; + ; (BARIPT array is storing IHS Patient Information) + ; (BARVPT array is storing VA Patient Information) + ; + ; + ; '#' Marker placed in the first column + ; + ; mnemonic1 User's choice + ; ex: D to denote DUZ + ; '|' Separator + ; + ; variable1 User's choice of the local variable + ; ex: DUZ + ; '*' Repetative marker if more than one + ; mnemonic is indicated + ; + ; USE The mnemonic reference can be used any where + ; in the WP form. + ; + ; Format ~mnemonic|variable subscript~ + ; + ; '~' Beginning marker for the variable + ; + ; mnemonic1 User's mnemonic + ; + ; '|' 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 TRANSFORM + ; A simple mumps output transform is also provided to aid + ; in form design. A variable or mnemonic indicated will + ; have its output transformed prior to being put into the + ; form. + ; + ; SETUP + ; + ; *var1!mumps code1*var2!mumps code2 + ; *mnemonic3!mumps code3*mnemonic4!mumps code4 + ; + ; Ex: *DUZ(2)!$J(X,10,2) will output $J(DUZ(2),10,2) + ; *D | 2!$J(X,10,2) mnemonic notation of same + ; + ; '*' Output Transform marker in column one. At TOF + ; + ; Variable/ Variable or mnemonic as it would appear in the + ; Mneumonic form between '~'s. + ; + ; '!' Separator + ; + ; mumps code Mumps code expression as a function of x. + ; Do not state 'S X=f(x)' + ; Enter the function only, f(x). + ; + ; '*' Separator 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) + ; KILL BARFORM(BARFORM) + ; Q + ; diff --git a/XBBJ.m b/XBBJ.m new file mode 100644 index 0000000..19b5907 --- /dev/null +++ b/XBBJ.m @@ -0,0 +1,5 @@ +XBBJ ; EDE/OHPD/IHS GO TO %BJ^%ZTMS + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; +START ; + NEW (U,DT) G %BJ^%ZTMS diff --git a/XBBPI.m b/XBBPI.m new file mode 100644 index 0000000..2f67704 --- /dev/null +++ b/XBBPI.m @@ -0,0 +1,87 @@ +XBBPI ; IHS/ADC/GTH - BUILD PACKAGE PRE-INIT ROUTINE ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; 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 + KILL %,XBBPLOOP + Q + ; +PACKAGE ; + S DIC="^DIC(9.4,",DIC(0)="AEMQ" + D ^DIC + KILL DIC + Q + ; +BUILD ; + S XBBPDFN=+Y,XBBPPRFX=$P(^DIC(9.4,XBBPDFN,0),U,2),Y=DT + D DD^%DT + S XBBPVER=$G(^DIC(9.4,XBBPDFN,"VERSION"))_";"_$P(^DIC(9.4,XBBPDFN,0),U,1)_";;"_Y,XBBPPGM=XBBPPRFX_"PREI" + D CHECKRTN + I XBBPFLG D EOJ3 W !!,"Bye",! Q + KILL ^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 + S ^UTILITY("XBBPPGM",$J,2,0)=" ;;"_XBBPVER + F XBBPI=1:1:3 S ^UTILITY("XBBPPGM",$J,XBBPI+2,0)=$P($T(DTA+XBBPI),";;",2,99) + 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 + S DIE="^UTILITY(""XBBPPGM"",$J,",X=XBBPPGM,XCN=0 + X ^%ZOSF("SAVE") + 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,"INI")) D EOJ2 + I $D(^DIC(9.4,XBBPDFN,"INI")),$P(^("INI"),U)="" D EOJ2 I 1 + E I $D(^DIC(9.4,XBBPDFN,"INI")),$P(^("INI"),U)'=XBBPPGM W !!,"Package ",XBBPPRFX," has a pre-initialization routine entry but it is ",$P(^("INI"),U),"!" + D EOJ3 + Q + ; +EOJ2 ; + W !,"Package ",XBBPPRFX," has no pre-initialization routine entry!",! + Q + ; +EOJ3 ; + KILL ^UTILITY("XBBPI",$J),^UTILITY("XBBPPGM",$J),^UTILITY("XBBPI EXEC",$J) + KILL %,%DT,DIE,XCN + KILL XBBPDFN,XBBPFLE,XBBPFLG,XBBPI,XBBPL,XBBPP,XBBPPGM,XBBPPRFX,XBBPX,XBBPY,XBBPVER + 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 diff --git a/XBCDIC.m b/XBCDIC.m new file mode 100644 index 0000000..8761f26 --- /dev/null +++ b/XBCDIC.m @@ -0,0 +1,183 @@ +XBCDIC ; IHS/ADC/GTH - CLEAN UP ^DIC AND ^DD ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; PROGRAMMERS NOTE: + ; THIS FUNCTIONALITY HAS BEEN INCLUDED IN THE FILEMAN + ; DD UTILITIES, BEGINNING WITH V 19.0. WE RECOMMEND + ; IT'S USE AS IT IS MORE LIKELY TO BE CURRENT. + ; 3-20-96 + ; + ; This routine cleans up ^DIC and ^DD by a range of + ; dictionary numbers. All files in ^DIC within the range + ; of dictionary numbers are checked for the following: + ; + ; They must have a NAME in ^DIC. + ; The NAME in ^DIC must match the NAME in ^DD. + ; The NAME must exist in ^DIC("B" with the correct number, + ; and that number cannot occur more than once in ^DIC("B". + ; They must have a data global specified in ^DIC. + ; The data global must be in the correct form. + ; The data global must exist. + ; The data global must have a 0th node. + ; The NAME and NUMBER in the data global must match ^DIC. + ; The data globals 0th node must be consistent with + ; the data (Exact count not checked). + ; + ; They must have valid entries in ^DD as follows: + ; The ^DD entry must have a .01 field. + ; All "SB" pointers must point to existing sub-files. + ; All sub-files must point back to correct parent. + ; All "TRB" entries must exist. + ; All "PT" entries must exist. + ; All "ACOMP" entries must exist. + ; + ; When discrepancies are found the entries are corrected + ; automatically where ever possible. If this is not possible + ; operator interaction occurs to make the corrections. If + ; the file cannot be corrected, it will be deleted. + ; + ; After all dictionaries within the range of dictionary + ; numbers are checked, all other entries within the range + ; will be deleted. + ; + ; The last step is to set the 0th node of the FILE OF FILES + ; to the correct high DFN and the correct count of entries. + ; +BEGIN ; + S U="^" + W !!,"THIS FUNCTIONALITY HAS BEEN INCLUDED IN THE FILEMAN" + W !,"DD UTILITIES, BEGINNING WITH V 19.0. WE RECOMMEND" + W !,"IT'S USE AS IT IS MORE LIKELY TO BE CURRENT." + W !," 3-20-96",!! + Q:'$$DIR^XBDIR("E") + W !!,"This routine cleans up ^DIC and ^DD by a range of dictionary numbers." +LO ; + R !!,"Enter low number of range: ",XBCDLO:$G(DTIME,999) + G:XBCDLO'=+XBCDLO EOJ +HI ; + R !,"Enter high number of range: ",XBCDHI:$G(DTIME,999) + S:XBCDHI="" XBCDHI=XBCDLO + G:XBCDHI'=+XBCDHI!(XBCDHIXBCDHI W "." D BCHK + S XBCDFILE=XBCDLO-.00000001 + F XBCDL=0:0 S XBCDFILE=$O(^DIC(XBCDFILE)) Q:XBCDFILE'=+XBCDFILE I XBCDFILE'>XBCDHI W "." S XBCDNDIC=$P(^DIC(XBCDFILE,0),U,1) I XBCDNDIC]"",'$D(^DIC("B",XBCDNDIC,XBCDFILE)) S ^(XBCDFILE)="" W "|" + G EOJ + ; +BCHK ; + I '$D(^DIC(XBCDFILE,0))#2 KILL ^DIC("B",XBCDX,XBCDFILE) W "|" Q + I XBCDX'=$P(^DIC(XBCDFILE,0),U,1) KILL ^DIC("B",XBCDX,XBCDFILE) W "|" + Q +EOJ ; + KILL XBCDLO,XBCDHI,XBCDUCI,XBCDL,XBCDFILE,XBCDX,XBCDNDIC + KILL ^UTILITY("XBDSET",$J) + Q + ; + W !,"Package ",XBBPPRFX," has no pre-initialization routine entry!",! + Q + ; +EOJ3 ; + KILL ^UTILITY("XBBPI",$J),^UTILITY("XBBPPGM",$J),^UTILITY("XBBPI EXEC",$J) + KILL %,%DT,DIE,XCN + KILL 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 + ; ex: D to denote DUZ + ; '|' Separator + ; + ; variable1 User's choice of the local variable + ; ex: DUZ + ; '*' Repetative marker if more than one + ; mnemonic is indicated + ; + ; USE The mnemonic reference can be used any where + ; in the WP form. + ; Format ~mnemonic|variable subscript~ + ; + ; '~' Beginning marker for the variable + ; + ; mnemonic1 User's mnemonic + ; + ; '|' 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 + ; mnemonic indicated will have its output + ; transformed prior to being put into the form. + ; + ; SETUP + ; + ; *var1!mumps code1*var2!mumps code2 + ; *mnemonic3!mumps code3*mnemonic4!mumps code4 + ; + ; Ex: *DUZ(2)!$J(X,10,2) will output $J(DUZ(2),10,2) + ; *D|2!$J(X,10,2) mnemonic notation of same + ; + ; '*' Output Transform marker in column one. At TOF + ; + ; Variable/ Variable or mnemonic as it would appear in the + ; Mneumonic form between '~'s. + ; + ; '!' Separator + ; + ; mumps code Mumps code expression as a function of x. + ; Do not state 'S X=f(x)' + ; Enter the function only, f(x). + ; + ; '*' Separator 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 + ; + NEW I,W + S XBLWP=$G(XBLLINE),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 "" + ; diff --git a/XBCDIC2.m b/XBCDIC2.m new file mode 100644 index 0000000..f0de928 --- /dev/null +++ b/XBCDIC2.m @@ -0,0 +1,131 @@ +XBCDIC2 ; IHS/ADC/GTH - CHECK DICTIONARY NAMES AND DATA GLOBALS ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; Part of XBCDIC + ; +START ; + S (Y,XBCDUCI)="" + X:$D(^%ZOSF("UCI"))#2 ^("UCI") + I Y'="" S XBCDUCI="["""_$P(Y,",",1)_""""_$S($P(Y,",",2)'="":","""_$P(Y,",",2)_"""",1:"")_"]" + KILL Y + W !!,"Now checking dictionary names and data globals." + S XBCDFILE="" + F XBCDL=0:0 S XBCDFILE=$O(^UTILITY("XBDSET",$J,XBCDFILE)) Q:XBCDFILE="" W !?5,"Checking ",XBCDFILE D XBCDNC + KILL XBCDFILE,XBCDANS,XBCDC,XBCDG,XBCDGG,XBCDGNM,XBCDGNR,XBCDNDD,XBCDNDIC,XBCDNTBL,XBCDX,XBCDY,XBCDL,XBCDY + Q + ; +XBCDNC ; + S XBCDNDIC=$G(^DIC(XBCDFILE,0)),XBCDNDIC=$P(XBCDNDIC,U,1) + D GCHK + I XBCDNDIC]"",$D(^DD(XBCDFILE,0,"NM",XBCDNDIC))#2 KILL ^DD(XBCDFILE,0,"NM") S ^DD(XBCDFILE,0,"NM",XBCDNDIC)="" + S XBCDNDD=$O(^DD(XBCDFILE,0,"NM","")) + I XBCDNDIC=XBCDNDD,XBCDNDIC=XBCDGNM,XBCDFILE=XBCDGNR Q + I XBCDNDIC]"",XBCDNDIC=XBCDNDD G GNMCHK + I XBCDNDIC]"",XBCDNDD="" W !?10,"No name in ^DD. Using name in ^DIC." S XBCDNDD=XBCDNDIC,^DD(XBCDFILE,0,"NM",XBCDNDIC)="" G GNMCHK + I XBCDNDIC="",XBCDNDD]"" W !?10,"No name in ^DIC. Using name in ^DD." S XBCDNDIC=XBCDNDD,$P(^DIC(XBCDFILE,0),U,1)=XBCDNDIC,^DIC("B",XBCDNDIC,XBCDFILE)="" G GNMCHK + I XBCDNDIC="",XBCDNDD="",XBCDGNM]"",XBCDFILE=XBCDGNR W !?10,"No name in ^DIC or ^DD. Using name in data global." S (XBCDNDIC,XBCDNDD)=XBCDGNM,$P(^DIC(XBCDFILE,0),U,1)=XBCDNDIC,^DIC("B",XBCDNDIC,XBCDFILE)="",^DD(XBCDFILE,0,"NM",XBCDNDD)="" Q + I XBCDNDIC]"",XBCDNDD]"",XBCDNDIC'=XBCDNDD W !?10,"Name in ^DIC and ^DD differ. Using name in ^DIC." KILL ^DD(XBCDFILE,0,"NM") S XBCDNDD=XBCDNDIC,^DD(XBCDFILE,0,"NM",XBCDNDD)="" G GNMCHK + W !?10,"Unable to deduce name. Searching DIC(""B"")." + D DICB + G:XBCDNDIC]"" GNMCHK + D READNAME + G GNMCHK + ; +READNAME ; + W !?10,"Unable to deduce name. Enter File Name or ""^"": ",XBCDX + I $L(XBCDX)>2,$L(XBCDX)<31,XBCDX?.ANP S (XBCDNDIC,XBCDNDD)=XBCDX,$P(^DIC(XBCDFILE,0),U,1)=XBCDNDIC,^DIC("B",XBCDNDIC,XBCDFILE)="",^DD(XBCDFILE,0,"NM",XBCDNDD)="" Q + I XBCDX'="^" W *7," ??" G READNAME + S ^UTILITY("XBDSET",$J,XBCDFILE,"ERR",1)="File "_XBCDFILE_" has no name." + Q + ; +GCHK ; CHECK DATA GLOBAL + S (XBCDGNM,XBCDGNR)="",XBCDGG=0,XBCDG=$G(^DIC(XBCDFILE,0,"GL")) + S:XBCDG?1"^"1U.UN1"(".UNP!(XBCDG?1"^"1"%"1U.UN1"(".UNP) XBCDGG=1 + I XBCDG="" W !?10,"File ",XBCDFILE," has no data global specified in ^DIC." D READGBL G:XBCDG]"" GCHK Q + I 'XBCDGG W !?10,"File ",XBCDFILE," data global=",XBCDG," is invalid." D READGBL G:XBCDG]"" GCHK Q + S XBCDG="^"_XBCDUCI_$E(XBCDG,2,99),^UTILITY("XBDSET",$J,XBCDFILE)=XBCDG + Q:XBCDG["%" + S XBCDX=$E(XBCDG,1,$L(XBCDG)-1)_$S($E(XBCDG,$L(XBCDG))=",":")",1:""),XBCDX=$D(@XBCDX) + S XBCDY=$L(XBCDG),XBCDY=$E(XBCDG,1,XBCDY-1)_$E(")",$E(XBCDG,XBCDY)=","),XBCDY=$S(XBCDY[")":$E(XBCDY,1,$L(XBCDY)-1)_",0)",1:XBCDY_"(0)") + I 'XBCDX W !?10,"Data global ",XBCDG," does not exist. Creating 0th node!" S @XBCDY="CREATED BY XBCD"_U_XBCDFILE Q + S XBCDX=$D(@XBCDY) + I XBCDX S XBCDGNM=@XBCDY,XBCDGNR=+$P(XBCDGNM,U,2),XBCDGNM=$P(XBCDGNM,U,1) S:'XBCDGNR XBCDGNR="" G GCHK2 + W !?10,"File ",XBCDFILE," data global exists but has no 0th node.",!?12,"Creating 0th node. Piece 3 and 4 must be set!" + S @XBCDY="CREATED BY XBCD"_U_XBCDFILE + Q + ; +GCHK2 ; CHECK 3RD AND 4TH PIECE + S XBCDX=$P(@XBCDY,U,3,4),XBCDX1=$P(XBCDX,U,2),XBCDX=+XBCDX + S XBCDX2=$O(@XBCDY) + I 'XBCDX2,XBCDX!(XBCDX1) W !?10,"Data global 0th node inconsistent with data. Fixing." S $P(@XBCDY,U,3)=0,$P(@XBCDY,U,4)=0 G GCHK3 + I XBCDX2,'XBCDX!('XBCDX1) W !?10,"Data global 0th node inconsistent with data. Run ^XBCOUNT to fix." G GCHK3 + I XBCDX,'$D(@(XBCDG_XBCDX_")")) W !?10,"Data global 0th node inconsistent with data. Run ^XBCOUNT to fix." G GCHK3 +GCHK3 ; CHECK FILE NUMBER IN DATA GLOBAL + KILL XBCDX1,XBCDX2 + Q:XBCDGNR=XBCDFILE + W !?10,"Data global has different number than ^DIC. ",$P(@XBCDY,U,1,2) +G2R1 ; + R !?12,"Change number in data global? (Y/N) ",XBCDX:$G(DTIME,999) + I XBCDX'="Y"&(XBCDX'="N") W *7," ??" G G2R1 + I XBCDX="Y" S XBCDX=@XBCDY,XBCDX1=$P(XBCDX,U,2),XBCDX2=+XBCDX1,XBCDX3=$P(XBCDX1,XBCDX2,2),$P(XBCDX,U,2)=XBCDFILE_XBCDX3,@XBCDY=XBCDX,XBCDGNR=XBCDFILE KILL XBCDX1,XBCDX2,XBCDX3 KILL XBCDX3 Q + D READGBL + I XBCDG="" W !?10,"Removing ^DIC(",XBCDFILE,",""0"",""GL"") node." KILL ^DIC(XBCDFILE,0,"GL") + G GCHK + ; +READGBL ; + R !!,"Enter Data Global or ""^"": ",XBCDG:$G(DTIME,999) + I XBCDG="^" S XBCDG="",^UTILITY("XBDSET",$J,XBCDFILE,"ERR",2)="File "_XBCDFILE_" data global missing or invalid." Q + I XBCDG'?1"^"1U.UN1"(".UNP,XBCDG'?1"^"1"%"1U.UN1"(".UNP W *7," ??" G READGBL + S ^DIC(XBCDFILE,0,"GL")=XBCDG + Q + ; +DICB ; CHECK DIC("B" + KILL XBCDNTBL + S (XBCDX,XBCDC)=0 + F XBCDL=0:0 S XBCDX=$O(^DIC("B",XBCDX)) Q:XBCDX="" I $D(^(XBCDX,XBCDFILE)) S XBCDC=XBCDC+1,XBCDNTBL(XBCDC)=XBCDX + Q:'XBCDC + I XBCDC=1 S XBCDANS=1 D NAMESET KILL XBCDNTBL Q + W !?12,"Multiple entries were found in ^DIC(""B""). Select one name or enter ""^""",!?12," All unselected names will be removed." + D PICKNAME + I XBCDANS'="^" D NAMESET KILL XBCDNTBL(XBCDANS) W ! + S XBCDX="" + F XBCDL=0:0 S XBCDX=$O(XBCDNTBL(XBCDX)) Q:XBCDX="" W !?12,"Deleting ^DIC(""B"",""",XBCDNTBL(XBCDX),""",",XBCDFILE,")" KILL ^DIC("B",XBCDNTBL(XBCDX),XBCDFILE) + W ! + KILL XBCDNTBL + Q + ; +PICKNAME ; + F XBCDX=1:1:XBCDC W !?14,XBCDNTBL(XBCDX) +P1 ; + R !!?14,"Which one: ",XBCDANS:$G(DTIME,999) + Q:XBCDANS="^" + S:XBCDANS="" XBCDANS="?" + I '$D(XBCDNTBL(XBCDANS)) W *7," ??" G P1 + Q + ; +NAMESET ; + W !?12,"Setting names to '",XBCDNTBL(XBCDANS),"'" + S (XBCDNDIC,XBCDNDD)=XBCDNTBL(XBCDANS),$P(^DIC(XBCDFILE,0),U,1)=XBCDNDIC,^DIC("B",XBCDNDIC,XBCDFILE)="" + KILL ^DD(XBCDFILE,0,"NM") + S ^DD(XBCDFILE,0,"NM",XBCDNDD)="" + Q + ; +GNMCHK ; CHECK DATA GLOBAL NAME AGAINST ^DIC + Q:'XBCDGG + I XBCDGNM]""!(XBCDGNR),XBCDNDIC'=XBCDGNM W !?10,"Data global name does not match ^DIC.",!?12,"Data global: ",XBCDGNM,!?12," ^DIC: ",XBCDNDIC D GNMFIX + S XBCDX=XBCDG_"0)" + I XBCDGNM="",XBCDGNR="",$D(@XBCDX)#2 S $P(@XBCDX,U,1)=XBCDNDIC + Q + ; +GNMFIX ; + R !?12,"Change name in data global? (Y/N) ",XBCDX:$G(DTIME,999) + I XBCDX'="Y"&(XBCDX'="N") W *7," ??" G GNMFIX + I XBCDX="Y" S XBCDX=XBCDG_"0)",$P(@XBCDX,U,1)=XBCDNDIC,XBCDGNM=XBCDNDIC Q +GNMR1 ; + R !?12,"Change names in ^DIC and ^DD to name in data global? (Y/N) ",XBCDX:$G(DTIME,999) + I XBCDX'="Y"&(XBCDX'="N") W *7," ??" G GNMR1 + I XBCDX'="Y" S ^UTILITY("XBDSET",$J,XBCDFILE,"ERR",3)="File "_XBCDFILE_" data global name does not match ^DIC name." Q + KILL ^DIC("B",XBCDNDIC,XBCDFILE),^DD(XBCDFILE,0,"NM") + S (XBCDNDIC,XBCDNDD)=XBCDGNM,$P(^DIC(XBCDFILE,0),U,1)=XBCDNDIC,^DIC("B",XBCDNDIC,XBCDFILE)="",^DD(XBCDFILE,0,"NM",XBCDNDD)="" + Q + ; diff --git a/XBCDIC3.m b/XBCDIC3.m new file mode 100644 index 0000000..f97796a --- /dev/null +++ b/XBCDIC3.m @@ -0,0 +1,122 @@ +XBCDIC3 ; IHS/ADC/GTH - CHECK ^DD ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; Part of XBCDIC + ; +START ; + W !!,"Now checking ^DD entries." + S U="^",XBCDFILE="" + F XBCDL=0:0 S XBCDFILE=$O(^UTILITY("XBDSET",$J,XBCDFILE)) Q:XBCDFILE="" W !?5,"Checking ",XBCDFILE D XBCDDDC + KILL XBCDANS,XBCDFILE,XBCDL + Q + ; +XBCDDDC ; CHECK ^DD ENTRY + D CHKDD0 ; CHECK ^DD 0TH NODE + D CHKPT ; CHECK "PT" NODE + D CHKTRB ; CHECK "TRB" NODE + D CHKACOMP ; CHECK "ACOMP" NODE + D SBTRACE ; CHECK "SB" NODE + Q + ; +CHKDD0 ; CHECK 0TH NODE + I '($D(^DD(XBCDFILE,.01,0))#2) W !,"File ",XBCDFILE," has no ^DD(",XBCDFILE,",.01,0) entry." + I '$D(^DD(XBCDFILE,0,"NM")) W !,"File ",XBCDFILE," has no ^DD(",XBCDFILE,",0,""NM"") entry." + E S XBCDX=$O(^DD(XBCDFILE,0,"NM","")),XBCDX=$O(^(XBCDX)) I XBCDX]"" W !,"File ",XBCDFILE," has multiple names." + Q + ; +CHKPT ; CHECK "PT" NODE + S XBCDPFLE="" + F XBCDL=0:0 S XBCDPFLE=$O(^DD(XBCDFILE,0,"PT",XBCDPFLE)) Q:XBCDPFLE="" S XBCDPFLD="" F XBCDL=0:0 S XBCDPFLD=$O(^DD(XBCDFILE,0,"PT",XBCDPFLE,XBCDPFLD)) Q:XBCDPFLD="" D PT + KILL XBCDPFLE,XBCDPFLD,XBCDX + Q +PT ; + W "." + I '$D(^DD(XBCDPFLE)) W "|" KILL ^DD(XBCDFILE,0,"PT",XBCDPFLE) Q + I '$D(^DD(XBCDPFLE,XBCDPFLD)) W "|" KILL ^DD(XBCDFILE,0,"PT",XBCDPFLE,XBCDPFLD) Q + S XBCDX=$P(^DD(XBCDPFLE,XBCDPFLD,0),U,2) + I XBCDX["V",$D(^DD(XBCDPFLE,XBCDPFLD,"V","B",XBCDFILE)) Q + I XBCDX["P",XBCDX[XBCDFILE Q + W "|" KILL ^DD(XBCDFILE,0,"PT",XBCDPFLE,XBCDPFLD) + Q + ; +CHKTRB ; CHECK "TRB" NODE + Q:'$D(^DD(XBCDFILE,"TRB")) + S XBCDTFLE="" + F XBCDL=0:0 S XBCDTFLE=$O(^DD(XBCDFILE,"TRB",XBCDTFLE)) Q:XBCDTFLE="" S XBCDTFLD="" F XBCDL=0:0 S XBCDTFLD=$O(^DD(XBCDFILE,"TRB",XBCDTFLE,XBCDTFLD)) Q:XBCDTFLD="" D TRB + KILL XBCDTFLE,XBCDTFLD,XBCDX + Q + ; +TRB ; THIS CAN CHECK MORE THAN IT DOES *** + W "." + I '$D(^DD(XBCDTFLE)) W "|" KILL ^DD(XBCDFILE,"TRB",XBCDTFLE) Q + I '$D(^DD(XBCDTFLE,XBCDTFLD)) W "|" KILL ^DD(XBCDFILE,"TRB",XBCDTFLE,XBCDTFLD) Q + Q + ; +CHKACOMP ; CHECK "ACOMP" ENTRIES + Q:'$D(^DD("ACOMP",XBCDFILE)) + S XBCDFLD="" + F XBCDL=0:0 S XBCDFLD=$O(^DD("ACOMP",XBCDFILE,XBCDFLD)) Q:XBCDFLD'=+XBCDFLD D CHKFIELD + KILL XBCDFLD + Q + ; +CHKFIELD ; + S XBCDAFLE="" + F XBCDL=0:0 S XBCDAFLE=$O(^DD("ACOMP",XBCDFILE,XBCDFLD,XBCDAFLE)) Q:XBCDAFLE="" S XBCDAFLD="" F XBCDL=0:0 S XBCDAFLD=$O(^DD("ACOMP",XBCDFILE,XBCDFLD,XBCDAFLE,XBCDAFLD)) Q:XBCDAFLD="" D ACOMP + KILL XBCDAFLE,XBCDAFLD,XBCDX + Q + ; +ACOMP ; + W "." + I '$D(^DD(XBCDAFLE)) W "|" KILL ^DD("ACOMP",XBCDFILE,XBCDFLD,XBCDAFLE) Q + I '$D(^DD(XBCDAFLE,XBCDAFLD)) W "|" KILL ^DD("ACOMP",XBCDFILE,XBCDFLD,XBCDAFLE,XBCDAFLD) Q + I '($D(^DD(XBCDAFLE,XBCDAFLD,0))#2) W "|" KILL ^DD("ACOMP",XBCDFILE,XBCDFLD,XBCDAFLE,XBCDAFLD) Q + S XBCDX=$P(^DD(XBCDAFLE,XBCDAFLD,0),U,2) + I XBCDX'["C" W "|" KILL ^DD("ACOMP",XBCDFILE,XBCDFLD,XBCDAFLE,XBCDAFLD) + Q + ; +SBTRACE ; CHECK ALL SUB-FILES + KILL XBCDSFL + S XBCDC=1,XBCDSFL="",XBCDSFL(XBCDC)=XBCDFILE + F XBCDL=0:0 S XBCDI=$O(XBCDSFL("")) Q:XBCDI="" S XBCDSF=XBCDSFL(XBCDI) D SBTRACE2 S XBCDI=$O(XBCDSFL("")) W "." KILL XBCDSFL(XBCDI) + KILL XBCDC,XBCDI,XBCDSF,XBCDSFL,XBCDY,XBCDZ + Q + ; +SBTRACE2 ; + S XBCDI=0 + F XBCDL=0:0 S XBCDI=$O(^DD(XBCDSF,"SB",XBCDI)) Q:XBCDI="" W "." S XBCDC=XBCDC+1,XBCDSFL(XBCDC)=XBCDI D SBCHECK + Q + ; +SBCHECK ; + I '$D(^DD(XBCDI)) S X=$O(^DD(XBCDSF,"SB",XBCDI,0)),Y=$P(^DD(XBCDSF,X,0),U) D Q + . W !?10,"Subfile ",XBCDI," for field ",X," does not exists.",!?12,"Deleting field ",X," from file ",XBCDSF + . KILL ^DD(XBCDSF,X),^DD(XBCDSF,"SB",XBCDI),^DD(XBCDSF,"B",Y,X) + . Q + D SBTRACE3,SBTRACE4 + Q + ; +SBTRACE3 ; + I '$D(^DD(XBCDI,0,"UP")),$D(^DIC(XBCDI)) W !?10,XBCDI," is a primary file. Deleting ^DD(",XBCDSF,",""SB"",",XBCDI,")" KILL ^DD(XBCDSF,"SB",XBCDI) Q + I $D(^DD(XBCDI,0,"PT")) W !?10,XBCDI," sub-file has ""PT"" node. Deleting." KILL ^DD(XBCDI,0,"PT") + I '$D(^DD(XBCDI,0,"UP")) W !?10,XBCDI," has no ""UP"" node. Creating ^DD(",XBCDI,",0,""UP"")=",XBCDSF S ^DD(XBCDI,0,"UP")=XBCDSF + Q:^DD(XBCDI,0,"UP")=XBCDSF + I ^DD(XBCDI,0,"UP")="" W !?10,XBCDI," ""UP"" node is NULL. Setting ^DD(",XBCDI,",0,""UP"")=",XBCDSF S ^DD(XBCDI,0,"UP")=XBCDSF Q + W !?10,XBCDSF," lists ",XBCDI," as a sub-file. The ""UP"" node in ",!?10+$L(XBCDSF)+1,XBCDI," is ",^DD(XBCDI,0,"UP"),"." + I $D(^DD(^DD(XBCDI,0,"UP"),"SB",XBCDSF)) W !?12,"The ""SB"" in ",^DD(XBCDI,0,"UP")," agrees. Fixing." KILL ^DD(XBCDSF,"SB",XBCDI) Q + E W !?12,"The ""SB"" in ",^DD(XBCDI,0,"UP")," disagrees. Fixing." S ^DD(XBCDI,0,"UP")=XBCDSF + Q + ; +SBTRACE4 ; + I '$D(^DD(XBCDI,0,"NM")) W !?10,"Sub-file ",XBCDI," has no ^DD(",XBCDI,",0,""NM"") entry. Fixing." D SBTFIX I 1 + E S XBCDX=$O(^DD(XBCDI,0,"NM","")),XBCDX=$O(^(XBCDX)) I XBCDX]"" W !?10,"Sub-file ",XBCDI," has multiple names. Fixing." D SBTFIX + Q + ; +SBTFIX ; FIX "NM" + KILL ^DD(XBCDI,0,"NM") + I '$D(^DD(XBCDI,0,"UP")) W !?12,"Can't fix. No ""UP"" node." Q + S XBCDX=^DD(XBCDI,0,"UP") + I XBCDX="" W !?12,"Can't fix. ""UP"" node is NULL." Q + I '$D(^DD(XBCDX,"SB",XBCDI)) W !?12,"Can't fix because can't locate parent field." Q + S XBCDY=$O(^DD(XBCDX,"SB",XBCDI,"")),XBCDZ=$P(^DD(XBCDX,XBCDY,0),U,1) + S ^DD(XBCDI,0,"NM",XBCDZ)="" + Q + ; diff --git a/XBCDICD.m b/XBCDICD.m new file mode 100644 index 0000000..1c3dd48 --- /dev/null +++ b/XBCDICD.m @@ -0,0 +1,23 @@ +XBCDICD ; IHS/ADC/GTH - DELETE BAD FILES ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; Part of XBCDIC + ; +START ; + S XBCDDEL=0,XBCDFILE="" + F XBCDL=0:0 S XBCDFILE=$O(^UTILITY("XBDSET",$J,XBCDFILE)) Q:XBCDFILE="" S XBCDGOOD=1 D:$D(^(XBCDFILE,"ERR"))\10 ERRORS K:XBCDGOOD ^UTILITY("XBDSET",$J,XBCDFILE) + I XBCDDEL W !!,"Executing ^XBKD to delete specified files!" D EN2^XBKD + KILL XBCDDEL,XBCDFILE,XBCDGOOD,XBCDX,XBCDNDIC + Q + ; +ERRORS ; RESOLVE ERRORS SET BY ^XBCDIC2 OR ^XBCDIC3 + W ! + S XBCDX="" + F XBCDL=0:0 S XBCDX=$O(^UTILITY("XBDSET",$J,XBCDFILE,"ERR",XBCDX)) Q:XBCDX="" W !,^(XBCDX) +ACTR ; + R !!," Delete file? (Y/N) ",XBCDX:$G(DTIME,999) + I XBCDX'="Y"&(XBCDX'="N") W *7," ??" G ACTR + S:XBCDX="Y" XBCDDEL=1,XBCDGOOD=0,^UTILITY("XBDSET",$J,XBCDFILE)="A^A" + KILL ^UTILITY("XBDSET",$J,XBCDFILE,"ERR") + Q + ; diff --git a/XBCFIX.m b/XBCFIX.m new file mode 100644 index 0000000..e998d19 --- /dev/null +++ b/XBCFIX.m @@ -0,0 +1,35 @@ +XBCFIX ; IHS/ADC/GTH - COUNT ENTRIES IN FILEMAN FILES AND FIX ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; This routine counts primary entries in FileMan files and + ; fixes the 3rd and 4th piece of the 0th node. + ; +START ; + W !,"^XBCFIX - This routine counts primary entries in FileMan files and fixes",!," the 0th node.",! + S U="^" + D ^XBDSET + Q:'$D(^UTILITY("XBDSET",$J)) + W ! + S XBCFIXFL="" + F XBCFIXL=0:0 S XBCFIXFL=$O(^UTILITY("XBDSET",$J,XBCFIXFL)) Q:XBCFIXFL'=+XBCFIXFL D XBCFIXFL + D EOJ + Q + ; +XBCFIXFL ; + W !,XBCFIXFL + I XBCFIXFL=3.081 W " skipping" Q + I '$D(^DIC(XBCFIXFL,0,"GL")) W !!,"No data global specified in ^DIC!" Q + S XBCFIXGB=^DIC(XBCFIXFL,0,"GL") + I '$D(@($S($E(XBCFIXGB,$L(XBCFIXGB))="(":$E(XBCFIXGB,1,$L(XBCFIXGB)-1),1:$E(XBCFIXGB,1,$L(XBCFIXGB)-1)_")"))) W !!,"Bad global!" Q + S XBCFIXGB=XBCFIXGB_"XBCFIXNX)",(XBCFIXHI,XBCFIXNX,XBCFIXC)=0 + F XBCFIXL=0:0 S XBCFIXNX=$O(@(XBCFIXGB)) Q:XBCFIXNX'=+XBCFIXNX S XBCFIXHI=XBCFIXNX,XBCFIXC=XBCFIXC+1 W:'(XBCFIXC#50) "." + W !," Count=",XBCFIXC,?22,"High DFN=",XBCFIXHI + S XBCFIXNX="",XBCFIXX=$O(@(XBCFIXGB)),XBCFIXX=^(0),XBCFIXY=$P(XBCFIXX,U,4),XBCFIXX=$P(XBCFIXX,U,3),$P(^(0),U,3)=XBCFIXHI,$P(^(0),U,4)=XBCFIXC + I XBCFIXC=XBCFIXY,XBCFIXHI=XBCFIXX W ?50,"[correct]" Q + W ?50,"[incorrect -- fixed]" + Q + ; +EOJ ; + KILL XBCFIXHI,XBCFIXX,XBCFIXY,XBCFIXC,DIC,DIC(0),XBCFIXFL,XBCFIXGB,XBCFIXL,XBCFIXNX + Q + ; diff --git a/XBCFXREF.m b/XBCFXREF.m new file mode 100644 index 0000000..1e8d7a2 --- /dev/null +++ b/XBCFXREF.m @@ -0,0 +1,121 @@ +XBCFXREF ; IHS/ADC/GTH - CHECK/FIX XREFS ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; This routine checks all REGULAR xrefs at the file level + ; for selected files to insure all pointed to entries exist. + ; +START ; + D INIT + I XBCFXREF("QFLG") D EOJ Q + D FILES + D EOJ + Q + ; +INIT ; + S XBCFXREF("QFLG")=0 + D ^XBKVAR + W !,"This routine will check the xrefs for the files you select and display",!," all errors found. You may also delete the bad xrefs." + W !!,"You should probably capture the output to an aux printer." + S XBCFXREF("DF")=$$DIR^XBDIR("S^1:DISPLAY ONLY;2:DISPLAY & FIX","","1") + I $D(DIRUT) S XBCFXREF("QFLG")=1 Q + D ^XBDSET + I '$D(^UTILITY("XBDSET")) S XBCFXREF("QFLG")=1 Q + Q + ; +FILES ; CHECK FILES + S XBCFXREF("C")=0 + F XBCFXREF("FILE")=0:0 S XBCFXREF("FILE")=$O(^UTILITY("XBDSET",$J,XBCFXREF("FILE"))) Q:XBCFXREF("FILE")="" D FILE + Q + ; + ;--------------------------------------------------------------------- + ; Gather up xrefs to check + ; +FILE ; CHECK ONE FILE + W !!,"Checking the ",$P(^DIC(XBCFXREF("FILE"),0),U,1)," (",XBCFXREF("FILE"),") file" + KILL XBCFXREF("TBL") + S XBCFXREF("XREF")="" + F S XBCFXREF("XREF")=$O(^DD(XBCFXREF("FILE"),0,"IX",XBCFXREF("XREF"))) Q:XBCFXREF("XREF")="" S XBCFXREF("XREF FILE")=$O(^(XBCFXREF("XREF"),0)),XBCFXREF("XREF FIELD")=$O(^(XBCFXREF("XREF FILE"),0)) D + . S XBCFXREF("TBL",XBCFXREF("XREF FILE"),XBCFXREF("XREF FIELD"),XBCFXREF("XREF"))="" + .Q + I $D(XBCFXREF("TBL")) D XREFILE KILL XBCFXREF("TBL") + I $D(XBCFXREF("TBL2")) D CHECK KILL XBCFXREF("TBL2") + Q + ; +XREFILE ; CHECK EACH FILE/FIELD CREATING XREFS + F XBCFXREF("XREF FILE")=0:0 S XBCFXREF("XREF FILE")=$O(XBCFXREF("TBL",XBCFXREF("XREF FILE"))) Q:XBCFXREF("XREF FILE")="" D D XREFIELD + . S XBCFXREF("TOP DA")=0,XBCFXREF("PARENT")="" + . Q:'$D(^DD(XBCFXREF("XREF FILE"),0,"UP")) ; quit if not subfile + . NEW SUBFILE,PARENT,FIELD,LVL + . S SUBFILE=XBCFXREF("XREF FILE"),PARENT="",LVL=1 + . D BACKUP + . S XBCFXREF("TOP DA")=LVL,XBCFXREF("PARENT")=PARENT + . Q + Q + ; +BACKUP ; BACKUP TREE (CALLED RECURSIVELY) + S PARENT=^DD(SUBFILE,0,"UP") + S FIELD=$O(^DD(PARENT,"SB",SUBFILE,"")) + I $D(^DD(PARENT,0,"UP")) S SUBFILE=PARENT,LVL=LVL+1 D BACKUP ; Recurse + Q + ; +XREFIELD ; CHECK EACH FIELD CREATING XREFS + F XBCFXREF("XREF FIELD")=0:0 S XBCFXREF("XREF FIELD")=$O(XBCFXREF("TBL",XBCFXREF("XREF FILE"),XBCFXREF("XREF FIELD"))) Q:XBCFXREF("XREF FIELD")="" D XREF + Q + ; +XREF ; CHECK XREFS ON FIELD + NEW G,L,S,X,Y + KILL XBCFXRT,XBCFXREF("XREFS") + D ^XBGXREFS(XBCFXREF("XREF FILE"),XBCFXREF("XREF FIELD"),.XBCFXRT) + F XBCFXREF("XN")=0:0 S XBCFXREF("XN")=$O(XBCFXRT(XBCFXREF("XREF FIELD"),XBCFXREF("XN"))) Q:XBCFXREF("XN")="" S X=XBCFXRT(XBCFXREF("XREF FIELD"),XBCFXREF("XN")) D + . Q:$P(X,U,2)="" ; must be trigger + . Q:$P(X,U,3)]"" ; not REGULAR xref + . Q:'$D(XBCFXREF("TBL",XBCFXREF("XREF FILE"),XBCFXREF("XREF FIELD"),$P(X,U,2))) ; not of interest + . Q:'$D(XBCFXRT(XBCFXREF("XREF FIELD"),XBCFXREF("XN"),"S")) ; no set + . S Y=XBCFXRT(XBCFXREF("XREF FIELD"),XBCFXREF("XN"),"S") + . I '$F(Y,",DA"),'$F(Y,",D0") D Q + .. W !?2,$P(X,U,2)," doesn't use DA or D0. Skipping." + .. Q + . I $F(Y,",D0)=") D SAVE Q + . I XBCFXREF("PARENT")="",$F(Y,",DA)=") D SAVE Q + . I XBCFXREF("PARENT")]"" S S=",DA("_XBCFXREF("TOP DA")_"))=" I $F(Y,S) D SAVE Q + . Q + KILL XBCFXRT + Q + ; +SAVE ; SAVE XREF TO CHECK + S XBCFXREF("C")=XBCFXREF("C")+1 + S XBCFXREF("TBL2",XBCFXREF("C"))=$P(X,U,2) ; save it + Q + ; + ;--------------------------------------------------------------------- + ; Check data global for xrefs previously gathered + ; +CHECK ; CHECK DATA GLOBAL FOR XREFS + W !!," Checking the following xrefs:" + NEW I + F I=0:0 S I=$O(XBCFXREF("TBL2",I)) Q:I="" W:$X>73 ! W " ",XBCFXREF("TBL2",I) + F XBCFXREF("C")=0:0 S XBCFXREF("C")=$O(XBCFXREF("TBL2",XBCFXREF("C"))) Q:XBCFXREF("C")="" S XBCFXREF("XREF")=XBCFXREF("TBL2",XBCFXREF("C")) D CHKXREF + Q + ; +CHKXREF ; CHECK ONE XREF + W !!," Checking the """,XBCFXREF("XREF"),""" xref." + NEW G,L,R,V,X,Y + S X=XBCFXREF("XREF") + S G=^DIC(XBCFXREF("FILE"),0,"GL"),R=G_""""_X_""",",X=$E(R,1,$L(R)-1)_")",L=$L(R) + F S X=$Q(@X) Q:$E(X,1,L)'=R D + . Q:@X ; quit if mnemonic xref + . S Y=+$P(X,",",$L(X,",")) + . Q:$D(@(G_Y_",0)")) + . W !?4,$$MSMZR^ZIBNSSV," does not exist.",!?6,"XREF node=",X + . I XBCFXREF("DF")=2 KILL @X W " deleted." + .Q + Q + ; + ;--------------------------------------------------------------------- +EOJ ; + KILL ^UTILITY("XBDSET",$J) + KILL XBCFXREF,XBCFXRT + KILL DIRUT,DUOUT,DTOUT + W !!,"All done",! + Q + ; diff --git a/XBCLM.m b/XBCLM.m new file mode 100644 index 0000000..98f0f2c --- /dev/null +++ b/XBCLM.m @@ -0,0 +1,43 @@ +XBCLM ; IHS/ADC/GTH - COLUMN LISTER ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; Thanks to Don Enos, OHPRD, for the original routine, + ; 7 Feb 95. + ; + ; This routine displays a column number header followed by + ; the passed string. + ; + ; +EP(STR) ;PEP - Column Lister + Q:$G(STR)="" + NEW B,C1,C2,CH,CV,CV1,CV2,H,L,LC,X + KILL DIR,DIRUT + S CH=$S($L(STR)>80:3,1:2) ; set column header height + S LC=$L(STR)\80 + S:($L(STR)/80)>LC LC=LC+1 ; set loop count + W:$D(IOF) @IOF + F L=1:1:LC D LINE Q:$$QUIT($L(STR)) + Q + ; +LINE ; WRITE HEADER AND ONE LINE + KILL H + F C1=1:1:CH D + . F C2=1:1:80 D Q:(C2+((L-1)*80))'<$L(STR) + .. S CV=(C2+((L-1)*80)) + .. S CV1=CV\100,CV2=(CV#100)\10 + .. S $E(H(C1),C2)=$S(C1=CH:$E(C2,$L(C2)),C1=(CH-1):CV2,1:CV1) + .. Q + . Q + S X="",$P(X,"=",80)="=" + W !,X,! + F C1=1:1:CH W H(C1),! + S X="",$P(X,"-",80)="-" + S B=(1+((L-1)*80)) + W X,!,$E(STR,B,B+79),! + Q + ; +QUIT(L) ; + NEW B,C1,C2,CH,CV,CV1,CV2,H,LC,X + S X=$$DIR^XBDIR("E","<$L="_L_"> Press any key to continue") + Q $S($D(DIRUT):1,1:0) + ; diff --git a/XBCLS.m b/XBCLS.m new file mode 100644 index 0000000..80c1086 --- /dev/null +++ b/XBCLS.m @@ -0,0 +1,7 @@ +XBCLS ; IHS/ADC/GTH - CLEAR SCREEN ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + D EN^XBVIDEO("IOF") + U IO(0) + Q + ; diff --git a/XBCNODE.m b/XBCNODE.m new file mode 100644 index 0000000..754c5e8 --- /dev/null +++ b/XBCNODE.m @@ -0,0 +1,21 @@ +XBCNODE ; IHS/ADC/GTH - COUNT ENTRIES IN GLOBAL NODE ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; This program counts unique values in a selected global + ; node. + ; +START ; + NEW GBL,CC,NXT,L + W !!,"This program counts unique values in a global node.",! +LOOP ; + R !,"Enter global reference like '^DPT(""B"",' ",GBL:$G(DTIME,300) + Q:GBL="" + S:$E(GBL,$L(GBL))=")" GBL=$E(GBL,1,$L(GBL)-1) + S:$E(GBL)'="^" GBL="^"_GBL + S:$F(GBL,"(")<1 GBL=GBL_"(" + I $E(GBL,$L(GBL))'=",",$E(GBL,$L(GBL)-1)'="(",$E(GBL,$L(GBL))'="(" S GBL=GBL_"," + S CC=0,NXT="" + F L=0:0 X "S NXT=$O("_GBL_"NXT))" Q:NXT="" S CC=CC+1 W:'(CC#50) "." + W !!,"Count for ",GBL," is ",CC,! + G LOOP + ; diff --git a/XBCOUNT.m b/XBCOUNT.m new file mode 100644 index 0000000..f550a29 --- /dev/null +++ b/XBCOUNT.m @@ -0,0 +1,32 @@ +XBCOUNT ; IHS/ADC/GTH - COUNT ENTRIES IN FILEMAN FILE ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; This routine counts primary entries in a FileMan file and + ; corrects the 0th node. + ; +START ; + NEW ANS,CTR,FILE,GBL,L,NXT + W !,"This program counts primary entries for a FileMan file.",! +LOOP ; + W ! + S DIC=1,DIC(0)="AE" + D ^DIC + G:Y<0 EOJ + S FILE=+Y +ENT ; + I '$D(^DIC(FILE,0,"GL")) W !!,"DIC file entry invalid or does not exist!",! G LOOP + S GBL=^DIC(FILE,0,"GL") + I '$D(@($S($E(GBL,$L(GBL))="(":$E(GBL,1,$L(GBL)-1),1:$E(GBL,1,$L(GBL)-1)_")"))) W !!,"Bad global!!",! G LOOP + S GBL=GBL_"NXT)" + S (XBHI,NXT,CTR)=0 + F L=0:0 S NXT=$O(@(GBL)) Q:NXT'=+NXT S XBHI=NXT,CTR=CTR+1 W:'(CTR#50) "." + W !!,"FileMan file ",FILE," contains ",CTR," entries. High DFN=",XBHI,! + S NXT="",XBX=$O(@(GBL)),XBX=^(0),XBY=$P(XBX,U,4),XBX=$P(XBX,U,3) + W !,"The 0th node says ",XBY,", ",XBX," respectively." + I CTR'=XBY!(XBHI'=XBX) W !," Do you want me to fix it? (Y/N) Y//" R ANS:$G(DTIME,999) I "Y"[$E(ANS) S NXT=0,$P(@(GBL),U,3)=XBHI,$P(^(0),U,4)=CTR W " Done" + G LOOP + ; +EOJ ; + KILL ANS,XBHI,XBX,XBY,CTR,DIC,FILE,GBL,L,NXT + Q + ; diff --git a/XBCSPC.m b/XBCSPC.m new file mode 100644 index 0000000..d3b03c4 --- /dev/null +++ b/XBCSPC.m @@ -0,0 +1,110 @@ +XBCSPC ; IHS/ADC/GTH - CHECK POTENTIAL SPECIFIER FIELDS ; [ 11/04/97 10:26 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*5 IHS/ADC/GTH 10-30-97 Fix bug in count of duplicate values. + ; + ; This routine checks selected field to see what percent of + ; the time it exists in the entries in a file, and if it + ; should be unique, it makes sure it is unique. + ; +START ; + NEW CTRD,CTRT,CTRU,CTRX,ENTRY,FGBL,FIELD,FILE,NODE,PIECE,UNIQUE,XREF + D ^XBKVAR + F D FILE Q:Y<1 + D EOJ + Q + ; +FILE ; + W ! + I '$G(EXTERNAL) D Q:Y<1 + . S DIC=1,DIC(0)="AEMQ" + . D ^DIC + . KILL DIC + . Q:Y<1 + . S FILE=+Y + .Q + S FGBL=^DIC(FILE,0,"GL"),X=$O(@(FGBL_"0)")) + I X'=+X W " No data in file",*7 Q + F D FIELD Q:Y<0 + S Y=1 + Q + ; +FIELD ; + I '$G(EXTERNAL) D Q:Y<0 + . S DIC="^DD("_FILE_",",DIC(0)="AEMQ" + . D ^DIC + . KILL DIC + . Q:Y<0 + . S FIELD=+Y + .Q + D FLD^XBFDINFO(FILE,FIELD,.X) + I '$D(X("NODE")) W *7 Q + I X("NODE")="" W *7 Q + S NODE=X("NODE"),PIECE=X("PIECE") + KILL DIRUT,X + I '$G(EXTERNAL) S UNIQUE=$$DIR^XBDIR("YO","Should field be unique","NO") + Q:$D(DIRUT) + D:UNIQUE CHKXREF + D CHKDATA + D LIST + S:$G(EXTERNAL) Y=-1 + Q + ; +LIST ; + W !!,CTRT," entries in file.",!,$FN(CTRD/CTRT*100,"T",2)," percent of entries have data. ",$S(CTRT'=CTRD:CTRT-CTRD_" without data.",1:"") + I UNIQUE,XREF'="" D + . I CTRX=0 W !,"All entries with data have xref." + . E W !,CTRD-CTRX," entr",$S(CTRD-CTRX=1:"y",1:"ies"),", ",$FN(CTRX/CTRD*100,"T",2)," percent of entries with data have no xref." + . Q + I UNIQUE D + . I CTRU=0 W !,"All ",$P(^DD(FILE,FIELD,0),U,1)," field values are unique." + . E W !,CTRU,$S(CTRU=1:" entry has a value that is ",1:" entries have values that are "),"not unique." + . I '$G(EXTERNAL),CTRU W !,"If you want to see duplicate values select global ^TMP(""XBCSPC"",",$J,"," KILL ^TMP("XBCSPC",$J,1) D ^%G + . Q + W ! + Q + ; +CHKXREF ; SEE IF UNIQUE SPECIFIER HAS REGULAR XREF + Q:$G(XREF)'="" + S XREF="" + D XREF^XBGXREFS(FILE,FIELD,.X) + F I=0:0 S I=$O(X(FIELD,I)) Q:I'=+I I $P(X(FIELD,I),"^",3)="" S XREF=$P(X(FIELD,I),"^",2),XREF=""""_XREF_"""" Q + KILL X + I 'I W !,"The ",FIELD," field does not have a REGULAR xref." + E W !,"Using the ",XREF," xref on the ",FIELD," field." + Q + ; +CHKDATA ; CHECK DATA IN SELECTED FIELD + W !,"Checking data. Please wait. " + KILL ^TMP("XBCSPC",$J) + S (CTRT,CTRD,CTRU,CTRX)=0 + F ENTRY=0:0 S ENTRY=$O(@(FGBL_ENTRY_")")) Q:ENTRY'=+ENTRY D + . S CTRT=CTRT+1 + . Q:'$D(@(FGBL_ENTRY_","_NODE_")")) + . S X=$P(@(FGBL_ENTRY_","_NODE_")"),"^",PIECE) + . Q:X="" + . S CTRD=CTRD+1 + . I UNIQUE,XREF'="",'$D(@(FGBL_XREF_","""_X_""","_ENTRY_")")) S CTRX=CTRX+1 + . I UNIQUE D + .. ; I $D(^TMP("XBCSPC",$J,1,X)) S CTRU=CTRU+1,^TMP("XBCSPC",$J,2,X)=cCTRX ; XB*3*5 IHS/ADC/GTH 10-30-97 Fix bug in count of duplicate values. + .. I $D(^TMP("XBCSPC",$J,1,X)) S CTRU=CTRU+1,^(X)=$S($G(^TMP("XBCSPC",$J,2,X)):^(X)+1,1:2) ; XB*3*5 IHS/ADC/GTH 10-30-97 Fix bug in count of duplicate values. + .. E S ^TMP("XBCSPC",$J,1,X)=0 + .. Q + . Q + Q + ; +EN(FILE,FIELD,XREF,UNIQUE) ; EXTERNAL ENTRY POINT TO ALLOW SPECIFID FILE/FIELD + ; pass by value *** will abort if values not passed *** + NEW CTRD,CTRT,CTRU,CTRX,ENTRY,EXTERNAL,FGBL,NODE,PIECE + S EXTERNAL=1 + I FILE,FIELD,XREF'="",UNIQUE'="" + E Q + S XREF=""""_XREF_"""" + D FILE + KILL DIRUT,I,X,Y + Q + ; +EOJ ; + KILL DIRUT,I,X,Y + KILL ^TMP("XBCSPC",$J) + Q + ; diff --git a/XBDAD0.m b/XBDAD0.m new file mode 100644 index 0000000..4b2ce66 --- /dev/null +++ b/XBDAD0.m @@ -0,0 +1,37 @@ +XBDAD0 ; IHS/ADC/GTH - SET ALTERNATE DA/D0 ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; This routine sets the DA array from D0,D1 etc. or D0,D1 + ; etc. from the DA array. If the variable XBDAD0=2 it sets + ; the DA array, otherwise it sets D0,D1 etc. + ; + ; The variable XBDAD0 will be killed upon exiting this + ; routine. + ; + ; The entry point KILL kills D0, D1, etc. + ; +START ; + NEW I,J + I $G(XBDAD0)=2 D D0DA I 1 + E D DAD0 + KILL XBDAD0 + Q + ; +DAD0 ; ----- Set D0 (etc) from DA array. + F I=1:1 Q:'$D(DA(I)) S I(99-I)=DA(I) + S J=0 + F I=0:1 S J=$O(I(J)) Q:J'=+J S @("D"_I)=I(J) + S @("D"_I)=DA + Q + ; +D0DA ; ----- Set DA array from D0 (etc). + F I=0:1 Q:'$D(@("D"_I)) S J=I + F I=0:1 S DA(J)=@("D"_I) S J=J-1 Q:J<1 + S DA=@("D"_(I+1)) + Q + ; +KILL ;PEP - KILL D0, D1, ETC. + NEW I + F I=0:1 Q:'$D(@("D"_I)) KILL @("D"_I) + Q + ; diff --git a/XBDANGLE.m b/XBDANGLE.m new file mode 100644 index 0000000..d1742d6 --- /dev/null +++ b/XBDANGLE.m @@ -0,0 +1,175 @@ +XBDANGLE ;IHS/SET/GTH - Q'ABLE CLEANUP DANGLING POINTERS OPTION HELP FRAME PROTOCOL FILES ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cleanup dangling pointers. + ; + ; This utility can be scheduled to run via TaskMan. + ; + ; Actions are delivered to XUPROG key holders via MailMan. + ; + ; You can also run this interactively, but you'll still + ; get the MailMan note, even after the interactive run. + ; + ; Thanks to the VA for the original interactive routine, XQ3. + ; + D INIT + D OFIX,HFFIX,PFIX + D MAIL + D EXIT + Q + ; + ; ---------------------------------------------------------- + ; +OFIX ;Kill any dangling pointers in the OPTION File (#19) + NEW I,J,K,L,M,X,Y + S (I,X)=0 ;X=Total Deletions +L1 ; + S I=$O(^DIC(19,I)) + I I>0 S (Y,J)=0 G L2 ;Loop through menus + D RSLT(X_" pointer"_$S(X=1:"",1:"s")_" fixed in your OPTION file.") + Q + ; +L2 ; + S J=$O(^DIC(19,I,10,J)) + I J>0 G ITEM ;Loop through menu items + I '$D(^DIC(19,I,10,0)) G L1 + S (K,J)=0 + F L=1:1 S J=$O(^DIC(19,I,10,J)) Q:J'>0 S K=J ;K=Last item + S J=^DIC(19,I,10,0),^(0)=$P(J,"^",1,2)_"^"_K_"^"_Y ;fix counters + G XREFS + ; +ITEM ; + S K=+^DIC(19,I,10,J,0) + I $D(^DIC(19,K,0)) S Y=Y+1 G L2 ;Y=No. of items + D RSLT("Option "_$P(^DIC(19,I,0),U,1)_" points to missing option "_K) + S X=X+1 + KILL ^DIC(19,I,10,J) ;Kill invalid menu item + G L2 + ; +XREFS ; + S K=":" +L3 ; + S K=$O(^DIC(19,I,10,K)) + I K="" G L1 ;Loop through cross references + S L=-1 +L4 ; + S L=$O(^DIC(19,I,10,K,L)) + I L="" G L3 + S J=0 +L5 ; + S J=$O(^DIC(19,I,10,K,L,J)) + I J'>0 G L4 + I '$D(^DIC(19,I,10,J,0)) G KILLXR ;kill xref to invalid item +L6 ; + S M=^DIC(19,I,10,J,0) + I (M=L)!(M[L_"^") G L5 +KILLXR ; + KILL ^DIC(19,I,10,K,L,J) + I $O(^DIC(19,I,10,K,L,-1))="" KILL ^DIC(19,I,10,K,L) + G L5 + ; + ; ---------------------------------------------------------- + ; +HFFIX ; Fix dangling pointers on help frame file + NEW I,J,K,L,X,Y + S (X,I)=0 + F S I=$O(^DIC(9.2,I)) Q:I'>0 I $D(^(I,2)) D HF1,HF2,HF3 + D RSLT(X_" pointer"_$S(X=1:"",1:"s")_" fixed in your HELP FRAME file.") + Q + ; +HF1 ; + S (Y,J)=0 + F S J=$O(^DIC(9.2,I,2,J)) Q:J'>0 I $D(^(J,0)) S K=$P(^(0),U,2),Y=Y+1 I $L(K),'$D(^DIC(9.2,K)) S Y=Y-1,X=X+1 K ^DIC(9.2,I,2,J,0) + Q + ; +HF2 ; + S (K,J)=0 + F S J=$O(^DIC(9.2,I,2,J)) Q:J'>0 S K=J + S J=^DIC(9.2,I,2,0),^(0)=$P(J,U,1,2)_U_K_U_Y + Q + ; +HF3 ; + S K=":" + F S K=$O(^DIC(9.2,I,2,K)) Q:K="" S J=-1 F S J=$O(^DIC(9.2,I,2,K,J)) Q:J="" D HF4 + Q + ; +HF4 ; + S L=0 + F S L=$O(^DIC(9.2,I,2,K,J,L)) Q:L'>0 I '$D(^DIC(9.2,I,2,L,0)) K ^DIC(9.2,I,2,K,J,L) + Q + ; + ; ---------------------------------------------------------- + ; +PFIX ;Kill any dangling pointers in the PROTOCOL File (#101) + NEW I,J,K,L,M,X,Y + S (I,X)=0 ;X=Total Deletions +P1 ; + S I=$O(^ORD(101,I)) + I I>0 S (Y,J)=0 G P2 ;Loop through protocols + D RSLT(X_" pointer"_$S(X=1:"",1:"s")_" fixed in your PROTOCOL file.") + Q + ; +P2 ; + S J=$O(^ORD(101,I,10,J)) + I J>0 G PITEM ;Loop through items + I '$D(^ORD(101,I,10,0)) G P1 + S (K,J)=0 + F L=1:1 S J=$O(^ORD(101,I,10,J)) Q:J'>0 S K=J ;K=Last item + S J=^ORD(101,I,10,0),^(0)=$P(J,"^",1,2)_"^"_K_"^"_Y ;fix counters + G PXREFS + ; +PITEM ; + S K=+^ORD(101,I,10,J,0) + I $D(^ORD(101,K,0)) S Y=Y+1 G P2 ;Y=No. of items + D RSLT("Protocol "_$P(^ORD(101,I,0),U,1)_" points to missing option "_K) + S X=X+1 + KILL ^ORD(101,I,10,J) ;Kill invalid menu item + G P2 + ; +PXREFS ; + S K=":" +P3 ; + S K=$O(^ORD(101,I,10,K)) + I K="" G P1 ;Loop through cross references + S L=-1 +P4 ; + S L=$O(^ORD(101,I,10,K,L)) + I L="" G P3 + S J=0 +P5 ; + S J=$O(^ORD(101,I,10,K,L,J)) + I J'>0 G P4 + I '$D(^ORD(101,I,10,J,0)) G PKILLXR ;kill xref to invalid item +P6 ; + S M=^ORD(101,I,10,J,0) + I (M=L)!(M[L_"^") G P5 +PKILLXR ; + KILL ^ORD(101,I,10,K,L,J) + I $O(^ORD(101,I,10,K,L,-1))="" KILL ^ORD(101,I,10,K,L) + G P5 + ; +RSLT(%) S ^(0)=$G(^TMP("XBDANGLE",$J,0))+1,^(^(0))=% W:'$D(ZTQUEUED) !,% Q + ; + ; +INIT ; Set up. + NEW XMSUB,XMDUZ,XMTEXT,XMY + KILL ^TMP("XBDANGLE",$J) + Q + ; +MAIL ; Send a note to local programmers 'bout these results. + S XMSUB=$P($P($T(+1),";",2)," ",4,99),XMDUZ=$G(DUZ,.5),XMTEXT="^TMP(""XBDANGLE"",$J,",XMY(DUZ)="" + F %="XUPROGMODE" D SINGLE(%) + D ^XMD + Q + ; +EXIT ; + KILL ^TMP("XBDANGLE",$J) + I $D(ZTQUEUED) S ZTREQ="@" Q + Q + ; +SINGLE(K) ; Get holders of a single key K. + NEW Y + S Y=0 + Q:'$D(^XUSEC(K)) + F S Y=$O(^XUSEC(K,Y)) Q:'Y S XMY(Y)="" + Q + ; diff --git a/XBDATE.m b/XBDATE.m new file mode 100644 index 0000000..3048a1c --- /dev/null +++ b/XBDATE.m @@ -0,0 +1,43 @@ +XBDATE ; IHS/ADC/GTH - ADAPTATION OF %RS TO SELECT ROUTINES EDITED AFTER SPECIFIED DATE ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods. + ; + ; Thanks to Tom Love, DSD, for providing the original routine. + ; + ; This routine limits routines selected by RSEL to routines + ; edited after some date. + ; +START ; + I '$D(DT) D NOW^%DTC S DT=X + S DIR(0)="D^::EX" ;2800101:"_DT_":EX" + S DIR("A")="Date of last edit" + S Y=DT + X ^DD("DD") + S DIR("B")=Y + W !!,XBTYPE," ROUTINES edited on or after the following date:",! + D DIR + Q:$D(QUIT) + S XBDAT=Y + W !!,"One moment please, checking selected routines for last edit date.",! + ;Begin mod/add 2 lines;IHS/SET/GTH XB*3*9 10/29/2002 + I $$VERSION^%ZOSV(1)["MSM" D + . S XB="S RTN="""" F S RTN=$O(^UTILITY($J,RTN)) Q:RTN="""" ZL @RTN S X=$T(@RTN),X=$P($P(X,""[ "",2),"" "") D ^%DT K:Y<1!(Y0,((XBDAT=Y)!(Y>XBDAT)) X ^DD(""DD"") W !,RTN,?10,""last edited on "",Y" + I $$VERSION^%ZOSV(1)["Cache" D + . S XB="S RTN=0 F S RTN=$O(^UTILITY($J,RTN)) Q:RTN="""" S X=$P($$DATE^%R(RTN_"".INT"",1),"" "") D ^%DT K:Y<1!(Y0,((XBDAT=Y)!(Y>XBDAT)) X ^DD(""DD"") W !,RTN,?10,""last edited on "",Y" + ;S XB="S RTN="""" F S RTN=$O(^UTILITY($J,RTN)) Q:RTN="""" ZL @RTN S X=$T(@RTN),X=$P($P(X,""[ "",2),"" "") D ^%DT K:Y<1!(Y0,((XBDAT=Y)!(Y>XBDAT)) X ^DD(""DD"") W !,RTN,?10,""last edited on "",Y" + ;End mod/add 2 lines;IHS/SET/GTH XB*3*9 10/29/2002 + X XB + I $O(^UTILITY($J,""))="" S Y=XBDAT X ^DD("DD") S XBDAT=Y,QUIT="" Q + S DIR(0)="YO",DIR("A")="Proceed with "_XBTYPE,DIR("B")="NO" + W ! + D DIR + S:Y'=1 QUIT="" + KILL XBDAT + Q + ; +DIR ; + D ^DIR + S:$D(DIRUT) QUIT="" + KILL DIR,DIRUT,DUOUT,DTOUT + Q + ; diff --git a/XBDBQDOC.m b/XBDBQDOC.m new file mode 100644 index 0000000..59d368e --- /dev/null +++ b/XBDBQDOC.m @@ -0,0 +1,83 @@ +XBDBQDOC ; IHS/ADC/GTH - DOUBLE QUEUING SHELL HANDLER DOCUMENTATION ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ;---------------------- + ;NOTES FOR PROGRAMMERS| + ;---------------------- + ; + ; %ZIS with "PQM" is called by XBDBQUE if '$D(XBIOP). + ; + ; The user will be asked to queue if queuing has not been + ; selected. + ; + ; IO variables as necessary are automatically stored. + ; + ; XBxx variables are killed after loading into an XB array. + ; + ; XBDBQUE can be nested. + ; + ; The compute and print phases can call XBDBQUE individually + ; (XBIOP is required). + ; + ; The appropriate %ZTSK node is killed. + ; + ;EX: + ; S XBRC="C^AGTEST",XBRP="P^AGTEST",XBRX="END^AGTEST",XBNS="AG" + ; D ^XBDBQUE ;handles foreground and tasking + ; Q + ; + ; VARIABLES NEEDED FROM CALLING PROGRAM + ; + ;MANDATORY + ; EITHER XBRC-Compute Routine or XBRP-Print Routine. + ; + ;OPTIONAL + ; XBRC-Compute Routine. + ; XBRP-Print Routine. + ; XBRX-Exit Routine that cleans variables (HIGHLY SUGGESTED). + ; XBNS-name space of variables to auto load in + ; ZTSAVE("NS*")="" + ; ="DG;AUPN;PS;..." ; (will add '*'if missing). + ; XBNS("xxx")="" - ZTSAVE variable arrays where xxx is as + ; described for ZTSAVE("xxxx")="". + ; XBFQ=1 Force Queing. + ; XBDTH=FM date time of computing/printing. + ; XBIOP=pre-selected printer device with constructed with + ; ION ; IOST ; IOSL ; IOM + ; (mandatory if the calling routine is a queued routine). + ; XBPAR= %ZIS("IOPAR") values for host file with XBIOP if + ; needed. + ; +TEST ; + ; TESTING CODE the following are KISS (keep it supper simple) test + ; of double queing code including nesting. + Q + ;-------------------------------------------------------------------- +TEST1 ; test of stacking a second call to XBDBQUE in the printing routine. + S SD=1,DG=2 + S XBNS="SD;DG;AG;" + S XBRP="PA^XBDBQDOC" + D ^XBDBQUE + KILL DG,JKL,SD + Q +PA ; + W !,"GOT HERE ON ONE",! + X "ZW" + S IOP=XB("IOP"),XBRP="PB^XBDBQDOC",XBNS("JKL")="" + F I=1:1:10 S JKL(I)=I + S XBIOP=XB("IOP") + D ^XBDBQUE + Q +PB ; + W !,"GOT HERE ON TWO",! + X "ZW" + Q +TEST2 ; TEST FOR COMPUTING ONLY + D DT^DICRW + S XBRC="RC^XBDBQDOC" + F XBI=1:1:20 KILL ^XBDBT(XBI) + W !,"CREATES ^XBDBT(",! + D ^XBDBQUE + Q +RC S %H=$H D YX^%DTC F XBI=1:1:20 S ^PWDBT(XBI)=XBI_Y + Q diff --git a/XBDBQUE.m b/XBDBQUE.m new file mode 100644 index 0000000..44dffd9 --- /dev/null +++ b/XBDBQUE.m @@ -0,0 +1,167 @@ +XBDBQUE ; IHS/ADC/GTH - DOUBLE QUEUING SHELL HANDLER ; 17 Jul 2002 7:47 PM [ 04/28/2003 12:06 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*5 - IHS/ADC/GTH 10-31-97 + ; XB*3*8 - IHS/ASDST/GTH 12-07-00 + ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Parse of drive in SETIOPN. + ; Thanks to Paul Wesley, DSD, for the original routine. + ; --------------------------------------------------------- + ; |refer to XBDBQDOC for instructions, examples, and tests| + ; --------------------------------------------------------- + ; +START ; + NEW XB ; use a fresh array in case of nesting double queues + ; insure IO array is set fully + I ($D(IO)'>10) S IOP="HOME" D ^%ZIS + I $D(ZTQUEUED) S XBFQ=1 S:'$D(XBDTH) XBDTH="NOW" ; insure auto-requeue if called from a queued + I '$D(XBRC),'$D(XBRP) Q ; insure one of RC or RP exist + S XB("IOP1")=ION_";"_IOST_";"_IOM_";"_IOSL ; store current IO params + I $G(IOPAR)]"" S XB("IOPAR")=IOPAR ; store IOPAR + I $L($G(XBRC))=0 S XBRC="NORC^XBDBQUE" ; no compute identified + S XB("RC")=XBRC,XB("RP")=$G(XBRP),XB("RX")=$G(XBRX) + ; load XBNS="xx;yy;.." into XB("NS",xx*) ... + F XBI=1:1 S XBNSX=$P($G(XBNS),";",XBI) Q:XBNSX="" S:(XBNSX'["*") XBNSX=XBNSX_"*" S XB("NS",XBNSX)="" + S XB("NS","XB*")="" + ; load XBNS("xxx") array into XB("NS","xxx") + S XBNSX="" + F S XBNSX=$O(XBNS(XBNSX)) Q:XBNSX="" S XB("NS",XBNSX)="" + ; if this is a double queue with XB("IOP") setup .. pull the parameters out a ^%ZIS call to set up the parameters without an open + S XB("IOP")=$G(XBIOP) + I $D(XBIOP) S IOP=XBIOP + ; XB*3*5 - IHS/ADC/GTH 10-31-97 start block + I $G(XB("IOPAR"))]"" S %ZIS("IOPAR")=XB("IOPAR") D + . I XB("IOPAR")'?1"(""".E1""":""".E1""")" Q ; skip HFS if not an HFS + . S XBHFSNM=$P(XB("IOPAR"),":"),XBHFSNM=$TR(XBHFSNM,"()""") + . S XBHFSMD=$P(XB("IOPAR"),":",2),XBHFSMD=$TR(XBHFSMD,"()""") + . S %ZIS("HFSNAME")=XBHFSNM,%ZIS("HFSMODE")=XBHFSMD + . ;this code drops through + ; XB*3*5 - IHS/ADC/GTH 10-31-97 end block +ZIS ; + KILL IO("Q") + I $G(XBRC)]"",$G(XBRP)="" G ZISQ + S %ZIS="PQM" + D ^%ZIS ; get parameters without an open + I POP W !,"REPORTING-ABORTED",*7 G END1 + S XB("IO")=IO,XB("IOP")=ION_";"_IOST_";"_IOM_";"_IOSL,XB("IOPAR")=$G(IOPAR),XB("CPU")=$G(IOCPU),XB("ION")=ION +ZISQ ; + I '$D(IO("Q")),'$G(XBFQ) D + . I $D(ZTQUEUED) S XBFQ=1 Q + . I IO=IO(0),$G(XBRP)]"" Q + . Q:$$VALI^XBDIQ1(3.5,IOS,5.5)=2 ;Q'ing not allowed to DEVICE selected;IHS/SET/GTH XB*3*9 10/29/2002 + . KILL DIR + . S DIR(0)="Y",DIR("B")="Y",DIR("A")="Won't you queue this " + . D ^DIR + . KILL DIR + . I X["^" S XBQUIT=1 + . S:Y=1 IO("Q")=1 + . Q + ; + KILL XB("ZTSK") + I $D(ZTQUEUED),$G(ZTSK) S XB("ZTSK")=ZTSK + KILL ZTSK + ; quit if user says so + I $G(XBQUIT) KILL DIR S DIR(0)="E",DIR("A")="Report Aborted .. to continue" D ^DIR KILL DIR G END1 + ; +QUE1 ; + I ($D(IO("Q"))!($G(XBFQ))) D K IO("Q") W:(($G(ZTSK))&('$D(XB("ZTSK")))) !,"Tasked with ",ZTSK W:'$G(ZTSK) !,*7,"Que not successful ... REPORTING ABORTED" D ^%ZISC S IOP=XB("IOP1") D ^%ZIS G END1 ;---> + . I '$D(ZTQUEUED),IO=IO(0),$G(XBRP)]"" W !,"Queing to slave printer not allowed ... Report Aborting" Q ;---^ + . S ZTDESC="Double Que COMPUTing "_XBRC_" "_$G(XBRP),ZTIO="",ZTRTN="DEQUE1^XBDBQUE" + . S:$D(XBDTH) ZTDTH=XBDTH + . S:$G(XB("CPU"))]"" ZTCPU=XB("CPU") + . S XBNSX="" + . F S XBNSX=$O(XB("NS",XBNSX)) Q:XBNSX="" S ZTSAVE(XBNSX)="" + . KILL XBRC,XBRP,XBRX,XBNS,XBFQ,XBDTH,XBIOP,XBPAR,XBDTH,XBNSX,XBI + . S ZTIO="" ; insure no device loaded + . D ^%ZTLOAD + . Q ; these do .s branch to END1 + ; (((if queued the above code branched to END))) + ; +DEQUE1 ;EP - > 1st deque From TaskMan. + ; + KILL XBRC,XBRP,XBRX,XBNS,XBFQ,XBDTH,XBIOP,XBPAR,XBDTH + KILL XB("ZTSK") + I $D(ZTQUEUED),$G(ZTSK) S XB("ZTSK")=ZTSK + ; +COMPUTE ;>do computing | routine + ; + D @(XB("RC")) ; >>>PERFORM THE COMPUTE ROUTINE<<< ;stuffed if not provided with NORC^XBDBQUE + ; +QUE2 ; + ; + I $D(ZTQUEUED) D G ENDC ;===> automatically requeue if queued + . Q:XB("RP")="" + . S ZTDESC="Double Que PRINT "_XB("RC")_" "_XB("RP"),ZTIO=XB("IO"),ZTDTH=$H,ZTRTN="DEQUE2^XBDBQUE" ;IHS/SET/GTH 07/16/2002 + . S XBNSX="" + . F S XBNSX=$O(XB("NS",XBNSX)) Q:XBNSX="" S ZTSAVE(XBNSX)="" + . D SETIOPN K ZTIO + . D ^%ZTLOAD + . I '$D(ZTSK) S XBERR="SECOND QUE FAILED" D @^%ZOSF("ERRTN") Q + . S XBDBQUE=1 + . Q ; ======> this branches to ENDC + ; + ; device opened from the first que ask +DEQUE2 ;EP - 2nd Deque | printing + KILL XB("ZTSK") + I $D(ZTQUEUED),$G(ZTSK) S XB("ZTSK")=ZTSK + ;open printer device for printing with all selected parameters + G:(XB("RP")="") END ;---> exit if no print + ; + I $D(ZTQUEUED),$$VERSION^%ZOSV(1)["Cache",ION="HFS" D ^%ZISC S IOP=ION,%ZIS("HFSNAME")=XB("IO"),%ZIS("HFSMODE")="W" D ^%ZIS ;IHS/SET/GTH XB*3*9 10/29/2002 + U IO + D @(XB("RP")) ; >>>PERFORM PRINTING ROUTINE + ; + ;------- +END ;>End | cleanup + ; + I $G(XB("RX"))'="" D @(XB("RX")) ; >>>PERFORM CLEANUP ROUTINE<<< + ; +END0 ;EP - from compute cycle when XB("RP") EXISTS + I $D(XB("ZTSK")) S XBTZTSK=$G(ZTSK),ZTSK=XB("ZTSK") D KILL^%ZTLOAD K ZTSK S:$G(XBTZTSK) ZTSK=XBTZTSK KILL XBTZTSK +END1 ;EP clean out xb as passed in + D ^%ZISC + S IOP=XB("IOP1") ; restore original IO parameters + D ^%ZIS + K IOPAR,IOUPAR,IOP + KILL XB,XBRC,XBRP,XBRX,XBNS,XBFQ,XBDTH,XBIOP,XBPAR,XBDTH,XBERR,XBI,XBNSX,XBQUIT,XBDBQUE + ; + Q +ENDC ;EP - end computing cycle + I $G(XB("RP"))="" G END + G END0 + ; + ;---------------- + ;---------------- +SUB ;>Subroutines + ;---------- +NORC ;used if no XBRC identified + Q + ; +SETIOPN ;EP Set IOP parameters with (N)o open + Q:'$D(XB("IOP")) + S IOP=XB("IOP") + ;Begin New Code;XB*3*9 10/29/2002 + I $$VERSION^%ZOSV(1)["Cache",$G(XB("ION"))="HFS" D Q + . S %ZIS("HFSNAME")=XB("IO"),%ZIS("IOPAR")="WNS",%ZIS("HFSMODE")="W",IOP=$P(XB("IOP"),";"),XB("IOP")=IOP,%ZIS="N" + . D ^%ZIS + .Q + ;End New Code;XB*3*9 10/29/2002 + ; XB*3*5 - IHS/ADC/GTH 10-31-97 start block + I $G(XB("IOPAR"))]"" S %ZIS("IOPAR")=XB("IOPAR") D + . I XB("IOPAR")'?1"(""".E1""":""".E1""")" Q ; skip HFS if not an HFS + . ; XB*3*8 - IHS/ASDST/GTH 00-12-05 start block + . ; Index into XB("IOPAR") correctly if ":" in Pathname. + . NEW A,I + . S (I,A)=1 + . F S C=$E(XB("IOPAR"),A) Q:A=$L(XB("IOPAR")) S A=A+1,I=I+(C=":") + . ; XB*3*8 - IHS/ASDST/GTH 00-12-05 end block + . ; S XBHFSNM=$P(XB("IOPAR"),":"),XBHFSNM=$TR(XBHFSNM,"()""") ; XB*3*8 + . S XBHFSNM=$P(XB("IOPAR"),":",I-1),XBHFSNM=$TR(XBHFSNM,"()""") ; XB*3*8 + . ;S XBHFSNM=$P(XB("IOPAR"),":",I-1),XBHFSNM=$TR(XBHFSNM,"()""") ; XB*3*8 ;IHS/SET/GTH XB*3*9 10/29/2002 + . S XBHFSNM=$P(XB("IOPAR"),":",I-2,I-1),XBHFSNM=$TR(XBHFSNM,"()""") ; XB*3*8 ;IHS/SET/GTH XB*3*9 10/29/2002 + . ; S XBHFSMD=$P(XB("IOPAR"),":",2),XBHFSMD=$TR(XBHFSMD,"()""") ; XB*3*8 + . S XBHFSMD=$P(XB("IOPAR"),":",I),XBHFSMD=$TR(XBHFSMD,"()""") ; XB*3*8 + . S %ZIS("HFSNAME")=XBHFSNM,%ZIS("HFSMODE")=XBHFSMD + . Q + ; XB*3*5 - IHS/ADC/GTH 10-31-97 end block + S %ZIS="N" + D ^%ZIS + Q diff --git a/XBDELR.m b/XBDELR.m new file mode 100644 index 0000000..3042ff3 --- /dev/null +++ b/XBDELR.m @@ -0,0 +1,26 @@ +XBDELR ; IHS/ASDST/GTH - AN XB UTILITY ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; IHS/SET/GTH XB*3*9 10/29/2002 + ; + ; Delete routines in namespace "XBN", if XBA=0. + ; If XBA=1, single routine. + ; + ; It's up to the calling routine to make sure it's not deleted, if + ; the calling routine is the current routine. + ; + ; E.g.: D DEL^XBDELR("MYROUTIN",1) Del 1 routine named "MYROUTIN". + ; D DEL^XBDELR("NS") Del all routines in "NS" namespace. + ; + ; +DEL(XBN,XBA) ;PEP - Delete routine(s). + I $G(XBA)=1 S ^TMP("XBDELR",$J,XBN)="" + E Q:'$$RSEL^ZIBRSEL(XBN_"*","^TMP(""XBDELR"","_$J_",") + ; + NEW X + ; + S X="" + F S X=$O(^TMP("XBDELR",$J,X)) Q:X="" X ^%ZOSF("DEL") I '$D(ZTQUEUED) D BMES^XPDUTL(X_$E("...........",1,11-$L(X))_"") + KILL ^TMP("XBDELR",$J) + Q + ; diff --git a/XBDH.m b/XBDH.m new file mode 100644 index 0000000..864821e --- /dev/null +++ b/XBDH.m @@ -0,0 +1,38 @@ +XBDH ; IHS/ADC/GTH - HEADER EDITOR MAIN ROUTINE ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; Thanks to Dr. Dave Grau, OHPRD/TUCSON, for the original + ; routine. + ; + ; THIS ROUTINE IS DEDICATED TO MY FRIEND AND MENTOR, + ; KEN FLESHMAN M.D. + ; + ; Version 11.1 is dedicated to Maureen Hoye and Tami Winn + ; who made it possible to create a "legal", distributable + ; package. Sincere thanks!!! + ; +VAR ; + NEW XBDHMORE,DHD,V,X,Y,XBDHPDFN,XBDHPDNA,XBDHTHLW,XBDHL,XBDHI,%Y,%,A,C,Z,I,XBDHMFLG,XBDHWOFF + KILL ^TMP("XBDH",$J) + I '$D(DUZ) W !!,"KERNEL VARIABLES REQUIRED",!!,*7 G EXIT + KILL:'$D(XBDHDATA) ^TMP("XBDH",$J) + I $P($T(+2^DI),";",3)<17.77 W !!,"SORRY... THIS ROUTINE IS NOT COMPATABLE WITH YOUR VERSION OF FILEMAN" G EXIT + S XBDHWOFF="" + F %=2,8,15,16 I ^DD("OS")=% S XBDHWOFF="U 0:(0)" Q + S IOP=0 + D ^%ZIS + S V="|" + ; +TITLE ; + W @IOF,!,$$C^XBFUNC("***** HEADER LINE PROCESSOR *****"),!,$$C^XBFUNC("Version "_$P($T(XBDH+1),";",3)) + ; +XBDHD ; + D ^XBDHD + I $D(XBDHQUIT) KILL XBDHQUIT G EXIT + D:$D(^TMP("XBDH",$J,"HEADER"))=11 ^XBDHDSV + I $D(^TMP("XBDH",$J,"SAVE")) G XBDHD +EXIT ; + KILL:'$D(XBDHDATA) ^TMP("XBDH",$J) + KILL XBDHDATA + Q + ; diff --git a/XBDHD.m b/XBDHD.m new file mode 100644 index 0000000..640121b --- /dev/null +++ b/XBDHD.m @@ -0,0 +1,97 @@ +XBDHD ; IHS/ADC/GTH - GET BASIC INFO ABOUT FILE AND FIELDS ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; +NEW ; + NEW XBDHCHLW,XBDHDFN,XBDHDFNA,XBDHECHN,XBDHHDN,XBDHHDNO,XBDHHDR,XBDHHDW,XBDHREM,XBDHTCHN,XBDHX,XBDHY,XBDHZ,DIC,Z,XBDHXX,XBDHCHN,XBDHPDFN,XBDHPDNA,XBDHDPTH,XBDHDSUB,XBDHNSL,XBDHLIFO,XBDHY0 + W !! + I $D(^TMP("XBDH",$J,"SAVE")) D N1,^XBDHD1 S XBDHCHN=XBDHCHN+1 G STACK +XBDHPDFN ; + S DIR(0)="PO^1:EMQ",DIR("A")="Output from what file",DIR("?")="Enter the name of the file from which you wish to print." + D ^DIR + KILL DIR + D DIRCK + I $D(XBDHQUIT) G EXIT + S XBDHPDFN=+Y,XBDHPDNA=$P(Y,U,2),^TMP("XBDH",$J,"HEADER")=+Y_U_XBDHPDNA + W ! + ; +HEADER ; + I $D(XBDHDATA) S DHD="@",XBDHTHLW=240 G START + S Z=XBDHPDNA + S:$E(Z,$L(Z)-4,$L(Z))=" LIST" Z=$E(Z,1,$L(Z)-5) + S DIR(0)="FO^:",DIR("A")="Report heading",DIR("B")=Z_" LIST" + D ^DIR + KILL DIR + D DIRCK + I $D(XBDHQUIT) G EXIT + S DHD=X + I DHD="" S DHD="@" + W ! + ; +THLW ; + S DIR(0)="NO^1:256:",DIR("A")="Header line width",DIR("B")="132",DIR("?")="between 1 and 256" + D ^DIR + KILL DIR + S XBDHTHLW=Y + I "^"[XBDHTHLW G EXIT + ; +START ; + S XBDHTCHN="",XBDHCHLW=0,XBDHCHN=1,XBDHNSL=XBDHTHLW +STACK ; + KILL ^TMP("XBDH",$J,"STACK") + S ^TMP("XBDH",$J,"STACK",1)=XBDHPDFN_U_XBDHPDNA_U_U,XBDHLIFO=1 + ; +FIELD ; + KILL Y,XBDHY0 + D ^XBDHDF + I Y="",$D(^TMP("XBDH",$J,"HEADER",1)),XBDHLIFO=1 S ^TMP("XBDH",$J,"SAVE")=XBDHCHN_U_XBDHCHLW_U_XBDHNSL D:$D(^TMP("XBDH",$J,"HEADER",2)) ^XBDHDSP G EXIT + I "^"[Y S:Y=U XBDHQUIT="" G EXIT + I Y?1"."1U S XBDHREL="" G RESET + ; +HDR ; + I $D(Y(0))#2 S XBDHY0=Y(0) + S Z=$J("",(XBDHLIFO*2)-2),DIR(0)="FO^:",DIR("A")=Z_"Column header",DIR("B")=XBDHHDN,DIR("?")="Enter the label you want to appear at the top of this column" + D ^DIR + KILL DIR + S XBDHHDR=Y + I "^"[XBDHHDR W !! G EXIT + I $L(XBDHHDN)>XBDHNSL W *7,*7,!!,"THIS HEADER WILL NOT FIT ON THE LINE...TRY AGAIN",!! G HDR + ; +HDW ; + I '$D(XBDHY0) S XBDHZ=XBDHNSL G WIDTH + I $P(XBDHY0,U,2)["D",$L(XBDHHDR)<13,XBDHNSL>11 S XBDHZ=12 G WIDTH + S XBDHZ="",XBDHX=$P(XBDHY0,U,5),XBDHY="$L(X)>" + I XBDHX[XBDHY S XBDHZ=+$P(XBDHX,XBDHY,2) S:XBDHZ<$L(XBDHHDR) XBDHZ=$L(XBDHHDR) S:+$P(XBDHX,XBDHY,2)>XBDHNSL XBDHZ=XBDHNSL +WIDTH ; + S Z=$J("",(XBDHLIFO*2)-2) + KILL XBDHY0 + S DIR(0)="NO^"_$L(XBDHHDR)_":"_XBDHNSL_":",DIR("A")=Z_"Enter the width (in columns) of this field",DIR("B")=XBDHZ,DIR("?")="Must not be narrower than column header or wider than remaining space" + D ^DIR + KILL DIR + S XBDHHDW=Y + I XBDHHDW="" W ! G HDR + I XBDHHDW="^" W !! G EXIT + I XBDHHDW=+XBDHHDW,XBDHHDW'<$L(XBDHHDR),XBDHHDW'>XBDHNSL S $P(^TMP("XBDH",$J,"HEADER"),U,3)=XBDHTHLW G GLOB + W *7,*7,*13,$J("",IOM),*13 + G HDW + ; +GLOB ; + S V="|",^TMP("XBDH",$J,"HEADER",XBDHCHN)=XBDHDFN_"~"_XBDHHDNO_"~~"_XBDHDPTH_V_XBDHHDN_V_XBDHHDR_V_XBDHHDW_"|0|||0" +RESET ; + D ^XBDHD1,^XBDHD2 + I $D(XBDHQUIT) G EXIT + S XBDHCHN=XBDHCHN+1 + I $D(XBDHREL) KILL XBDHREL D ^XBDHD1 S XBDHCHN=XBDHCHN+1 G STACK + G FIELD + ; +N1 ; + S V="|",X=^TMP("XBDH",$J,"SAVE"),XBDHCHN=$P(X,U),XBDHCHLW=$P(X,U,2),XBDHNSL=$P(X,U,3),XBDHTCHN="",X=^("HEADER"),XBDHPDFN=$P(X,U),XBDHPDNA=$P(X,U,2),XBDHTHLW=$P(X,U,3) + KILL X + Q + ; +EXIT ; + Q + ; +DIRCK ; + I Y=""!($D(DIRUT))!($D(DTOUT)) S XBDHQUIT="" KILL DIRUT,DTOUT,DUOUT,DIROUT + Q + ; diff --git a/XBDHD1.m b/XBDHD1.m new file mode 100644 index 0000000..415d664 --- /dev/null +++ b/XBDHD1.m @@ -0,0 +1,42 @@ +XBDHD1 ; IHS/ADC/GTH - COMPILES HEADER LINE ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; +NEW ; + NEW XBDHCHN2,XBDHHDPD,XBDHHDSP,XBDHL1,XBDHL2,XBDHL3,DX,DY +INIT ; + W @IOF + X XBDHWOFF + S (XBDHL1,XBDHL2,XBDHL3,XBDHCHN2)="",XBDHCHLW=0,DX=0,XBDHNSL=XBDHTHLW + F XBDHL=0:0 S XBDHCHN2=$O(^TMP("XBDH",$J,"HEADER",XBDHCHN2)) Q:XBDHCHN2="" D:((XBDHCHN2\1)=XBDHCHN2) VAR W "." + W @IOF +WLINE ; + F XBDHZ=1:1:4 Q:XBDHZ>(((XBDHTHLW-1)\80)+1) D LINE +FIN ; + S DY=(3*XBDHZ)+1,XBDHX="",$P(XBDHX,"-",79)="" + X IOXY + W XBDHX,! +EXIT ; + Q + ; +LINE ; + S DY=(XBDHZ*3)-2,XBDHX=80*XBDHZ + F XBDHY="XBDHL1","XBDHL3" S DY=DY+1 X IOXY W $E(@XBDHY,XBDHX-79,XBDHX) + Q + ; +VAR ; + S XBDHHDR=$P(^TMP("XBDH",$J,"HEADER",XBDHCHN2),V,3),XBDHHDW=$P(^(XBDHCHN2),V,4),XBDHHDPD=$P(^(XBDHCHN2),V,5),XBDHHDSP=$P(^(XBDHCHN2),V,8),XBDHCHLW=XBDHCHLW+XBDHHDW,XBDHCHN=XBDHCHN2,XBDHNSL=XBDHNSL-(XBDHHDW+XBDHHDSP) + S XBDHL1=XBDHL1_$J("",XBDHHDPD)_XBDHHDR_$J("",(XBDHHDW-$L(XBDHHDR)-XBDHHDPD+XBDHHDSP)) + S XBDHXX=$C(64+XBDHCHN2) + I $D(XBDHECHN),XBDHECHN=XBDHCHN2 S XBDHXX="^" + S XBDHX="",$P(XBDHX,XBDHXX,XBDHHDW+1)="",XBDHY="",$P(XBDHY,".",XBDHHDSP+1)="" S XBDHL2=XBDHL2_XBDHX_XBDHY +L3 ; + S XBDHX="",$P(XBDHX,".",(XBDHTHLW+1-$L(XBDHL2)))="",XBDHL3=XBDHL2_XBDHX + KILL XBDHXX,XBDHX,XBDHY + Q + ; +NOTES ; + ; WRITES THE CURRENT HEADER LINE AT THE TOP OF THE SCREEN + ; INPUT = ^TMP("XBDH",$J,"HEADER",N),XBDHTHLW + ; OUTPUT = XBDHHDSP,XBDHHDPD + ; ALSO WRITES THE FIELD BOUNDARY LINE (AAAAAABBBCCCCC...) BELOW THE HEADER LINE + ; THIS ROUTINE IS CALLED EVERY TIME THE HEADER LINE IS CHANGED BY THE EDITING PROCESS diff --git a/XBDHD2.m b/XBDHD2.m new file mode 100644 index 0000000..91c44c0 --- /dev/null +++ b/XBDHD2.m @@ -0,0 +1,129 @@ +XBDHD2 ; IHS/ADC/GTH - SPECIAL CHOICES ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; +NEW ; + NEW XBDHFROM,XBDHI,XBDHTEMP,XBDHTO + ; +START ; + I $D(XBDHECHN) S XBDHCHN=XBDHECHN,XBDHX=^TMP("XBDH",$J,"HEADER",XBDHCHN),XBDHHDR=$P(XBDHX,V,3),XBDHHDW=$P(XBDHX,V,4) + W "EDITING HEADER LINE SEGMENT """,$C(64+XBDHCHN),""" FIELD = """,$P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,2),"""",! + F XBDHI=1:1:7 W $E($T(TEXT+XBDHI),4,99),! + W ! +CNEXT ; + S DIR(0)="NO^1:8:",DIR("A")="Your choice",DIR("?")="Enter the number of the editing function or to go on" + D ^DIR + KILL DIR + S XBDHX=Y + I "^"[XBDHX KILL XBDHECHN Q + G @("C"_XBDHX) + ; +C1 ; + S $P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,5)=(XBDHHDW-$L(XBDHHDR))\2 + D ^XBDHD1 + G START + ; +C2 ; + S $P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,5)=0 + D ^XBDHD1 + G START + ; +C3 ; + W !! +C31 ; + S DIR(0)="NO^"_$L(XBDHHDR)_":"_(XBDHNSL+XBDHHDW)_":",DIR("A")="New field width" + D ^DIR + KILL DIR + S XBDHX=Y + I "^"[XBDHX G START + I XBDHX'=+XBDHX W *13,$J("",IOM),*13,*7,*7 G C31 + I (XBDHX<$L(XBDHHDR))!(XBDHX>(XBDHNSL+XBDHHDW)) W *7,*7,*13,$J("",IOM),*13 G C31 + S XBDHHDW=XBDHX,$P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,4)=XBDHX G:$E($P(^(XBDHCHN),V,5)) C1 + D ^XBDHD1 + G START + ; +C4 ; + W !! + S DIR(0)="FO^1:"_XBDHHDW_"",DIR("A")="New header name" + D ^DIR + KILL DIR + S XBDHX=Y + I XBDHX="" G C8 + I XBDHX=U G START + I $P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,5) S $P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,3)=XBDHX,XBDHHDR=XBDHX G C1 + S $P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,3)=XBDHX + D ^XBDHD1 + G START + ; +C5 ; + S $P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,6)="+" + W !!,"ENTRIES RIGHT JUSTIFIED TO A WIDTH OF ",XBDHHDW," COLUMNS" + H 2 + D ^XBDHD1 + G START + ; +C6 ; + S $P(^TMP("XBDH",$J,"HEADER",XBDHCHN),V,7)="+" + W !!,"ENTRIES WILL BE WORD WRAPPED TO A WIDTH OF ",XBDHHDW," COLUMNS" + H 2 + D ^XBDHD1 + G START + ; +C7 ; + I '$D(XBDHECHN) KILL ^TMP("XBDH",$J,"HEADER",XBDHCHN) D ^XBDHD1 Q + S X="" + F L=0:0 S X=$O(^TMP("XBDH",$J,"HEADER",X)) Q:X="" S ^TMP("XBDH",$J,"HT",X)=^TMP("XBDH",$J,"HEADER",X) W "." + S XBDHTEMP=^TMP("XBDH",$J,"HEADER") + KILL ^TMP("XBDH",$J,"HT",XBDHECHN),^TMP("XBDH",$J,"HEADER") + S X="" + F I=1:1 S X=$O(^TMP("XBDH",$J,"HT",X)) Q:X="" S ^TMP("XBDH",$J,"HEADER",I)=^TMP("XBDH",$J,"HT",X) W "." + S ^TMP("XBDH",$J,"HEADER")=XBDHTEMP + KILL ^TMP("XBDH",$J,"HT"),XBDHTEMP + KILL XBDHECHN + D ^XBDHD1 + Q + ; +C8 ; + S XBDHFROM=$S($D(XBDHECHN):XBDHECHN,1:XBDHCHN),XBDHFROM=$C(64+XBDHFROM) + S X="" + F XBDHTCHN=0:1 S X=$O(^TMP("XBDH",$J,"HEADER",X)) Q:X="" S ^TMP("XBDH",$J,"HT",X)=^(X) W "." S Y="" F L=0:0 S Y=$O(^TMP("XBDH",$J,"HEADER",X,Y)) Q:Y="" S ^TMP("XBDH",$J,"HT",X,Y)=^(Y) + I XBDHCHN<2 W *7,*13,$J("",IOM),*13 G CNEXT + W *13,$J("",IOM),*13 + ; +MOVE ; + S DIR(0)="FO^",DIR("A")="Where do you want to move this header (A - "_$C(64+XBDHTCHN)_")",DIR("?")="Enter a letter which corresponds to a header line field" + D ^DIR + KILL DIR + S XBDHTO=Y + I "^"[XBDHTO W ! G START + I XBDHTO'?1U W *7,*7,*13,$J("",IOM),*13 G MOVE + I XBDHTO]$C(64+XBDHCHN) W *7,*7,*13,$J("",IOM),*13 G MOVE + I XBDHFROM=XBDHTO W *7,*13,$J("",IOM),*13 G MOVE + S XBDHFROM=$A(XBDHFROM)-64,XBDHTO=$A(XBDHTO)-64 + S XBDHX=XBDHTO+.1 + S:(XBDHFROM>XBDHTO) XBDHX=XBDHTO-.1 + S ^TMP("XBDH",$J,"HT",XBDHX)=^TMP("XBDH",$J,"HEADER",XBDHFROM) + S Y="" + F L=0:0 S Y=$O(^TMP("XBDH",$J,"HEADER",XBDHFROM,Y)) Q:Y="" S ^TMP("XBDH",$J,"HT",XBDHX,Y)=^TMP("XBDH",$J,"HEADER",XBDHFROM,Y) + S XBDHTEMP=^TMP("XBDH",$J,"HEADER") + KILL ^TMP("XBDH",$J,"HT",XBDHFROM),^TMP("XBDH",$J,"HEADER") + S X="" + F I=1:1 S X=$O(^TMP("XBDH",$J,"HT",X)) Q:X="" S ^TMP("XBDH",$J,"HEADER",I)=^TMP("XBDH",$J,"HT",X) S Y="" F L=0:0 S Y=$O(^TMP("XBDH",$J,"HT",X,Y)) Q:Y="" S ^TMP("XBDH",$J,"HEADER",I,Y)=^TMP("XBDH",$J,"HT",X,Y) + S ^TMP("XBDH",$J,"HEADER")=XBDHTEMP + KILL ^TMP("XBDH",$J,"HT"),XBDHTEMP,XBDHECHN + D ^XBDHD1 + G START + ; +TEXT ; + ;;DO YOU WANT TO MAKE ANY OTHER CHANGES TO THIS HEADER OR ITS FIELD? + ;; + ;; ACCEPT HEADER AS IS + ;; 1) CENTER HEADER WITHIN FIELD 5) RIGHT JUSTIFY ENTRIES + ;; 2) UNCENTER HEADER 6) WORD WRAP ENTRIES + ;; 3) CHANGE FIELD WIDTH 7) REMOVE THIS HEADER + ;; 4) CHANGE HEADER NAME 8) MOVE THIS HEADER + ; +NOTES ; + ; MAKES SECONDARY EDITING CHANGES AFTER EACH FIELD IS ENTERED + ; INPUT = XBDHCHN OR XBDHECHN (XBDHECHN IS THE .A OR .B CHN),^TMP("XBDH",$J,"HEADER",CHN),XBDHTHLW + ; OUTPUT = RESET ^TMP("XBDH",$J,"HEADER",CHN) + ; TO INSERT A NEW FIELD SIMPLY APPEND IT TO THE END OF THE LINE AND THE MOVE IT diff --git a/XBDHDF.m b/XBDHDF.m new file mode 100644 index 0000000..f87b847 --- /dev/null +++ b/XBDHDF.m @@ -0,0 +1,123 @@ +XBDHDF ; IHS/ADC/GTH - GETS FIELD INFO FOR HEADER LINE EDITOR ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; +NEW ; + NEW XBDHXX,XBDHQUIT +VAR ; + S X=^TMP("XBDH",$J,"STACK",XBDHLIFO),XBDHDFN=$P(X,U),XBDHDFNA=$P(X,U,2),XBDHDSUB=$P(X,U,3),XBDHDPTH=$P(X,U,4) + KILL X + I $D(XBDHMFLG) KILL XBDHMFLG S Y="" G OK1 +MORE ; + D PATH +GETFIELD ; + S Z=$J("",(XBDHLIFO*2)-2)_$S(XBDHCHN=1:"First",1:"Then")_" print "_$S(XBDHLIFO>1:(XBDHDFNA_" "),1:"")_XBDHDSUB_"field" + S A="" + I $D(XBDHMULT) S A=XBDHMULT,XBDHMFLG="" KILL XBDHMULT + S Z=Z_": " + I A]"" S Z=Z_A_"//" + W !,Z + R Y:DTIME + E S Y=U + I Y="" S Y=A + I Y="?" W !!,"Enter field name,number,computed expr.,MUMPS code,jump syntax or '??' for list",!! G GETFIELD + I Y="^" W !! Q + I Y="",XBDHCHN=1 W ! G GETFIELD + I Y="",XBDHLIFO=1 W !! Q +OK1 ; + I Y="" KILL ^TMP("XBDH",$J,"STACK",XBDHLIFO) S XBDHLIFO=XBDHLIFO-1,XBDHDPTH=$P(XBDHDPTH,";",1,XBDHLIFO)_";" W !!! G VAR + I Y?1"."1U,$E(Y,2)']$C(63+XBDHCHN) S XBDHECHN=($A($E(Y,2))-64) Q + S XBDHXX=Y + I $E(Y,$L(Y))=":" D ^XBDHDF1 G VAR:Y'=-1,OUT:A="^",GETFIELD + S DIC(0)="EZ",DIC="^DD(XBDHDFN,",X=Y + D ^DIC + I X="??" W !! G GETFIELD + I Y'=-1 D OK S X=$P(^DD(XBDHDFN,+Y,0),U,2) I X?1.9N1"."2N.E D MULTIPLE I Z="VAR" G VAR + I Y'=-1 Q +CKMUMPS ; + D ^DIM + I $D(X) W !,"MUMPS EXPRESSION ENTERED",!! D MUMPS G @X +CKM1 ; + S Y=XBDHXX + I $E(Y,$L(Y))'=":" D ^XBDHDF1 G VAR:Y'=-1,OUT:A="^" + D COMPUTED + G:$D(XBDHQUIT) OUT + W ! + Q:$D(XBDHHDN) + G GETFIELD + ; +OK ; + S XBDHHDNO=+Y,XBDHHDN=$P(Y,U,2) + Q + ; +COMPUTED ; + I XBDHXX="NUMBER" S (XBDHHDN,XBDHHDNO)=XBDHXX KILL XBDHXX Q + S X=XBDHXX + D ^DIM + I $D(X) G C1 + W ! + S DIR(0)="YO",DIR("A")="This is a computed expression, right",DIR("B")="YES" + D ^DIR + KILL DIR + I Y=U W !! Q + I 'Y KILL Y,XBDHHDN W !,"SORRY, I DON'T UNDERSTAND THIS ENTRY...TRY AGAIN",!!,*7 Q +C1 ; + S XBDHHDN="",XBDHHDNO=XBDHXX + KILL XBDHXX + Q + ; +MUMPS ; + S %=1 + W !,"DOES THIS MUMPS EXPRESSION REQUIRE A COLUMN HEADER" + D YN^DICN + I %Y=U S X="OUT" Q + I $E(%Y)'="N" W ! S X="CKM1" Q + F I=1:1 I '$D(^TMP("XBDH",$J,"HEADER",XBDHCHN,I)) S ^(I)=XBDHXX Q + S X="GETFIELD" + W !!! + Q + ; +MULTIPLE ; + S Z=^DD(+X,.01,0) + I $P(Z,U,2)["W" W " (word-processing)" Q + W " (multiple)" + S Z=$O(^DD(+X,0,"NM","")),XBDHLIFO=XBDHLIFO+1,XBDHDPTH=XBDHDPTH_Z_";" + S ^TMP("XBDH",$J,"STACK",XBDHLIFO)=+X_U_Z_U_"SUB-"_U_XBDHDPTH + S Z=$O(^DD(+X,.01)) + S:Z'=+Z XBDHMULT=$P(^DD(+X,.01,0),U) + W !! + S Z="VAR" + Q + ; +PATH ; + NEW A,X,Y,Z + S X="CURRENTLY PRINTING FIELDS FROM THE ",A=0,Y=$L(XBDHDPTH,";") + I XBDHDPTH="" S X=X_"'"_XBDHPDNA_"'"_" FILE" G LINE +DECI ; + S Y=Y-1 + G:Y=0 LAST + S A=A+1,Z=$P(XBDHDPTH,";",Y) + I A>1 S X=X_"OF THE " + I $E(Z,$L(Z))=":" S X=X_"'"_$P(^TMP("XBDH",$J,"STACK",XBDHLIFO),U,2)_"'"_" FILE" G LINE + S X=X_"'"_Z_"'"_" SUB-FILE " + G DECI + ; +LAST ; + I A S X=X_"OF THE " + S X=X_"'"_XBDHPDNA_"'"_" FILE" +LINE ; + W !!,X,!! + Q + ; +OUT ; + S Y="^" + Q + ; +NOTES ; + ; INTERPRETS THE ANSWER TO THE "THEN ENTER FIELD: " QUERY + ; INPUT = ^TMP("XBDH",$J,"STACK",XBDHLIFO) [XBDHDFN^XBDHDFNA^XBDHDSUB^XBDHDPTH],XBDHCHN,XBDHLIFO + ; OUTPUT = XBDHHDNO,XBDHHDN + ; IF FIELD IS A MULTIPLE, IT RESETS PATH AND LIFO AND ASKS FOR SUBFILE. IF ONLY .01 FIELD OF SUBFILE EXISTS, IT PROMPTS FOR IT. + ; ANY ANSWER IT CANT FIGURE OUT IS TREATED (AT LEAST TEMPORARILY) AS A COMPUTED FIELD + ; IF ANSWER IS A RELATIONAL JUMP (ie ENDS IN ':') IT CHECKS ITS LEGALITY,RESETS PATH AND LIFO. + ; MUMPS EXPRSSIONS ARE ATTACHED TO THE SUCCEEDING FIELD AS THE SUBSCRIPT ^TMP("XBDH",$J,"HEADER",X,Y) AND WILL FOLLOW THIS FIELD IF IT IS MOVED OR REMOVED + ; IF USER IS IN A SUBFILE OR JUMPED-TO FILE , PRESSING WILL MOVE HIM TO THE NEXT HIGHER LEVEL diff --git a/XBDHDF1.m b/XBDHDF1.m new file mode 100644 index 0000000..0aa03db --- /dev/null +++ b/XBDHDF1.m @@ -0,0 +1,53 @@ +XBDHDF1 ; IHS/ADC/GTH - CHECKS JUMP SYNTAX ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; +STRIP ; + KILL XBDHTC + I $E(Y,$L(Y))=":" S Y=$E(Y,1,$L(Y)-1),XBDHTC="" + S X=$L(Y,":"),Z=$S(X>1:$P(Y,":",X),1:Y),A="" + I $D(XBDHTC) D CKF I Y'=-1 G EXIT + D CKPT + I Y'=-1 G EXIT + I $D(XBDHTC) W " ??",*7,*7,*13,$J("",IOM),*13 +EXIT ; + KILL XBDHTC,Z + Q + ; +CKF ; + S X=Z,DIC(0)="",DIC="^DD(XBDHDFN," + D ^DIC + KILL DIC + I Y=-1 Q + S X=^DD(XBDHDFN,+Y,0),X=$P(X,U,2) + I X'["P" S Y=-1 Q + S X=+$P(X,"P",2),DIC="^DIC(",DIC(0)="" + D ^DIC + KILL DIC + I Y=-1 Q + D J1 + Q + ; +CKPT ; + S DIC="^DIC(",DIC(0)="",X=Z + D ^DIC + KILL DIC + I Y=-1 Q + F X=0:0 S A="",X=$O(^DD(XBDHDFN,0,"PT",+Y,X)) Q:X="" D JUMPQ I "Y^"[A Q + I X="" S Y=-1 Q + I A="^" Q + D J1 + Q + ; +J1 ; + S XBDHDPTH=XBDHDPTH_XBDHXX_$S($D(XBDHTC):"",1:":")_";" + S XBDHLIFO=XBDHLIFO+1,^TMP("XBDH",$J,"STACK",XBDHLIFO)=+Y_U_$P(Y,U,2)_U_U_XBDHDPTH + Q + ; +JUMPQ ; + I '$D(^DD(+Y,"IX",X)) Q + W !," By '",Z,"' do you mean the ",$P(Y,U,2)," File",!?7,"pointing via its '",$P(^DD(+Y,X,0),U),"' Field? YES// " + R A:DTIME + S:'$T A="^" + S A=$E(A) + Q + ; diff --git a/XBDHDIP.m b/XBDHDIP.m new file mode 100644 index 0000000..c3c5ea7 --- /dev/null +++ b/XBDHDIP.m @@ -0,0 +1,15 @@ +XBDHDIP ; IHS/ADC/GTH - OVERLAY OF DIP2 FOR AUTO FILEMAN ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; +AUTO ; + I '$D(XBDHHDX) S XBDHHDX="" + S XBDHHDX=$O(^TMP("XBDH",$J,"HELPR",XBDHHDX)),X=^(XBDHHDX) + I XBDHHDX=99 KILL DIRPIPE,XBDHHDX,^TMP("XBDH",$J,"HELPR") S X="" W !! Q + W X + Q + ; +NOTES ; + ; CALLED BY ^DIP2. GETS ^TMP("XBDH",$J,"HELPER",XBDHHDX) TO BE STUFFED INTO "THEN PRINT FIELD: " OF DIP2 + ; INPUT = XBDHHDX + ; OUTPUT = ^TMP("XBDH",$J,"HELPR",XBDHHDX),XBDHHDX + ; IF XBDHHDX=99 THE GLOBAL KILLS ITSELF OFF AND A NULL STRING IS PASSED TO DIP2 diff --git a/XBDHDSP.m b/XBDHDSP.m new file mode 100644 index 0000000..f5128ea --- /dev/null +++ b/XBDHDSP.m @@ -0,0 +1,74 @@ +XBDHDSP ; IHS/ADC/GTH - PUTS SPACES BETWEEN HEADERS ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; +NEW ; + NEW XBDHCHN1,XBDHI,XBDHTH,XBDHREP +INIT ; + S XBDHTH=XBDHCHN-1,XBDHNSL=XBDHTHLW-XBDHCHLW + I $P(^TMP("XBDH",$J,"HEADER",1),V,8)>0 G EXIT + S $P(^TMP("XBDH",$J,"HEADER",XBDHTH),V,8)=0 + W !!,"IT IS NOW TIME TO INSERT SPACES BETWEEN HEADER FIELDS",! +CQ ; + S DIR(0)="SO^1:REPATITIVE SPACING;2:MANUAL SPACING;3:AUTOMATIC SPACING",DIR("A")="Your choice",DIR("B")=1,DIR("?")="Automatic spacing puts maximum no. of spaces possible between fields." + D ^DIR + KILL DIR + S XBDHX=Y + I XBDHX="" G AUTO + I XBDHX=1 G REP +MANUAL ; + S XBDHCHN1="" + F XBDHL=0:0 S XBDHCHN1=$O(^TMP("XBDH",$J,"HEADER",XBDHCHN1)) G:XBDHCHN1=XBDHTH!(XBDHCHN1="") EXIT D MAN +EXIT ; + S DIR("B")="NO",DIR(0)="YO",DIR("A")="Want to make any more spacing changes" + D ^DIR + KILL DIR + I Y=1 W !! G CQ + I Y=U S XBDHQUIT="" Q + Q + ; +MAN ; + S XBDHY=$C(64+XBDHCHN1),XBDHZ=^TMP("XBDH",$J,"HEADER",XBDHCHN1) + W !!,"PUT SPACES AFTER HEADER """,$C(64+XBDHCHN1),"""" + W !,"TOTAL NUMBER OF UNUSED COLUMNS LEFT: ",XBDHNSL + W !,"TOTAL NUMBER OF HEADERS LEFT: ",XBDHTH+1-XBDHCHN1,! +SP ; + S DIR(0)="NO^::",DIR("A")="How many spaces do you want after field "_$C(64+XBDHCHN1) + S:$G(DIR("B"))]"" DIR("B")=XBDHX + D ^DIR + KILL DIR + S XBDHX=Y + I XBDHX="" S XBDHCHN1=XBDHTH-1 Q + I XBDHX?1"^"1U,$E(XBDHX,2)']$C(64+XBDHTH),($A(XBDHX)-64)'=XBDHTH S XBDHCHN1=$A($E(XBDHX,2))-64 G MAN + I XBDHX'=+XBDHX W *7,*7,*13,$J("",IOM),*13 G SP + I (XBDHX-$P(^TMP("XBDH",$J,"HEADER",XBDHCHN1),V,8))>XBDHNSL W *7,*7,*13,$J("",IOM),*13 G SP + S XBDHY=$P(^TMP("XBDH",$J,"HEADER",XBDHCHN1),V,8),$P(^TMP("XBDH",$J,"HEADER",XBDHCHN1),V,8)=XBDHX,XBDHNSL=XBDHNSL-XBDHX+XBDHY + D ^XBDHD1 + Q + ; +AUTO ; + S XBDHNSL=(XBDHTHLW-XBDHCHLW),XBDHY=XBDHNSL\(XBDHTH-1),XBDHZ=XBDHNSL-(XBDHY*(XBDHTH-1)),XBDHCHN1="" + F XBDHI=1:1 S XBDHCHN1=$O(^TMP("XBDH",$J,"HEADER",XBDHCHN1)) Q:XBDHCHN1=XBDHTH!(XBDHCHN1="") S XBDHX=XBDHY S:XBDHI'>XBDHZ XBDHX=XBDHX+1 S $P(^TMP("XBDH",$J,"HEADER",XBDHCHN1),V,8)=XBDHX + S XBDHNSL=0 + D ^XBDHD1 + G EXIT + ; +REP ; + W ! + S XBDHNSL=(XBDHTHLW-XBDHCHLW),XBDHREP=XBDHNSL\(XBDHTH-1),XBDHCHN1="" +EREP ; + S DIR(0)="NO^0:"_XBDHREP_":",DIR("A")="How many spaces between each header field",DIR("B")=XBDHREP + D ^DIR + KILL DIR + S XBDHX=Y + I XBDHX'=+XBDHX W *7,*7,*13,$J("",IOM),*13 G EREP + I XBDHX>XBDHREP W *7,*7,*13,$J("",IOM),*13 G EREP + I XBDHX="" S XBDHX=0 + F XBDHI=1:1 S XBDHCHN1=$O(^TMP("XBDH",$J,"HEADER",XBDHCHN1)) Q:XBDHCHN1=XBDHTH!(XBDHCHN1="") S:XBDHCHN1'["." $P(^TMP("XBDH",$J,"HEADER",XBDHCHN1),V,8)=XBDHX,XBDHNSL=XBDHNSL-XBDHX + D ^XBDHD1 + G EXIT + ; +NOTES ; + ; PUTS SPACES BETWEEN FIELDS ON THE HEADER LINE + ; INPUT = XBDHCHLW,XBDHTHLW,XBDHCHN + ; OUTPUT = 8TH PIECE OF ^TMP("XBDH",$J,"HEADER",XBDHCHN) + ; IGNORES PURE MUMPS EXPRESSION AS DESIGNATED BY DECIMAL XBDHCHN diff --git a/XBDHDSV.m b/XBDHDSV.m new file mode 100644 index 0000000..6be2894 --- /dev/null +++ b/XBDHDSV.m @@ -0,0 +1,101 @@ +XBDHDSV ; IHS/ADC/GTH - COMPILES HEADER INFO FOR AUTO ENTRY INTO DIP ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + I '$D(^TMP("XBDH",$J,"HEADER")) Q +NEW ; + NEW XBDHC,XBDHHDX,DIRPIPE,XBDHI,XBDHLJ,XBDHLPTH,XBDHMORE,XBDHN,XBDHNN,XBDHL,XBDHPDFN,XBDHRJ,XBDHSTG,XBDHTPTH,XBDHWW,XBDHX,XBDHY,I,J,L,P,X,Y,BY,DALL,DIC,DIJ,DP,DPP,FR,IOP,IOX,IOY,TO,XBDHCHLW,XBDHPDNA,% +INIT ; + S ^TMP("XBDH",$J,"HELPR",0)="]",^(99)="",X=^TMP("XBDH",$J,"HEADER"),XBDHCHLW=1,XBDHPDFN=$P(X,U),XBDHPDNA=$P(X,U,2),XBDHTHLW=$P(X,U,3),V="|" + KILL X + S XBDHLPTH="",(XBDHN,XBDHI)=0 +INCN ; + S XBDHN=XBDHN+1 + G:'$D(^TMP("XBDH",$J,"HEADER",XBDHN)) CLOSE S XBDHX=^(XBDHN) + D MUMPS,PRELIM + S XBDHLPTH=XBDHTPTH + D NORMAL + G INCN + ; +CLOSE ; + I XBDHTPTH]"" S X=$L(XBDHTPTH,";")-1,Y="" F X=1:1:X D SET + D STD + S DIR(0)="YO",DIR("A")="Want to make any more changes",DIR("B")="NO" + D ^DIR + KILL DIR + I Y=1 G EXIT + I Y=U S XBDHQUIT="" Q + KILL ^TMP("XBDH",$J,"SAVE") +EXIT ; + Q + ; +SET ; + S XBDHI=XBDHI+1,^TMP("XBDH",$J,"HELPR",XBDHI)=Y + Q + ; +MUMPS ; + S XBDHJ="" + F L=0:0 S XBDHJ=$O(^TMP("XBDH",$J,"HEADER",XBDHN,XBDHJ)) Q:XBDHJ="" S XBDHI=XBDHI+1,^TMP("XBDH",$J,"HELPR",XBDHI)=^TMP("XBDH",$J,"HEADER",XBDHN,XBDHJ) + KILL XBDHJ + Q + ; +PRELIM ; + S X=$P(^TMP("XBDH",$J,"HEADER",XBDHN),V),XBDHTPTH=$P(X,"~",4) + I XBDHLPTH=XBDHTPTH Q + I $E(XBDHTPTH,1,$L(XBDHLPTH))=XBDHLPTH D DOWN Q + I $E(XBDHLPTH,1,$L(XBDHTPTH))=XBDHTPTH D UP Q + D PATH + Q + ; +DOWN ; + S X=$L(XBDHLPTH,";") + F I=X:1 S Y=$P(XBDHTPTH,";",I) Q:Y="" D SET + Q + ; +UP ; + S X=$L(XBDHTPTH,";"),Y=$L(XBDHLPTH,";"),X=Y-X,Y="" + F I=1:1:X D SET + Q + ; +PATH ; + F I=1:1 I $P(XBDHLPTH,";",I)="" S A=I-1 Q + F I=1:1 I $P(XBDHTPTH,";",I)="" S B=I-1 Q + F I=1:1:A Q:$P(XBDHLPTH,";",1,I)'=$P(XBDHTPTH,";",1,I) + S C=I-1,N=A-C,Y="" + F I=1:1:N D SET + S C=C+1 + F I=C:1:B S Y=$P(XBDHTPTH,";",I) D SET + KILL A,B,C,I,N + Q + ; +NORMAL ; + S XBDHC=XBDHCHLW,XBDHNN=$J("",$P(XBDHX,V,5))_$P(XBDHX,V,3),XBDHLJ=$P(XBDHX,V,4),XBDHRJ=$P(XBDHX,V,6),XBDHWW=$P(XBDHX,V,7),XBDHCHLW=XBDHCHLW+$P(XBDHX,V,4)+$P(XBDHX,V,8) + S XBDHSTG=$P($P(XBDHX,V),"~",2) + I XBDHNN'=$P(XBDHX,V,2) S XBDHSTG=XBDHSTG_";"""_XBDHNN_"""" + S XBDHSTG=XBDHSTG_";C"_XBDHC + I XBDHLJ S XBDHSTG=XBDHSTG_$S(XBDHWW="+":";W",1:";L")_XBDHLJ + I XBDHRJ="+" S XBDHSTG=XBDHSTG_";R"_$P(XBDHX,V,4) + S XBDHI=XBDHI+1,^TMP("XBDH",$J,"HELPR",XBDHI)=XBDHSTG + Q + ; +STD ; + W !!,"I AM ABOUT TO PRINT A SAMPLE REPORT.",! + S DIR(0)="YO",DIR("A")="For this demo, do you want the 'standard' print options",DIR("B")="YES",DIR("?")="Standard options: SORT BY '@NUMBER', DEVICE = 'HOME'" + D ^DIR + KILL DIR + I Y=U S XBDHQUIT="" Q + W !!,"HMMM, LET ME THINK ABOUT THIS...",!! + I Y=1 S BY="NUMBER;@",FR="",TO="",IOP=$I,DUZ(0)="@" +DIP ; + S DIC=^DIC(XBDHPDFN,0,"GL") + S DIRPIPE="D ^XBDHDIP",L="]" + KILL XBDHHDX + D EN1^DIP + Q + ; +NOTES ; + ; CONVERTS THE INFO FROM THE "HEADER" GLOBAL INTO FM SYNATX FOR THE "HELPR" GLOBAL + ; INPUT = ^TMP("XBDH",$J,"HEADER",XBDHCHN) + ; OUTPUT = ^TMP("XBDH",$J,"HELPR",N) + ; ";L" IS SUPERCEEDED BY ";W" IF WORDWRAP IS IN EFFECT + ; EN1^DIP LEAVES SOME LOCALS HANGING AROUND WHICH ARE KILLED IN DIP+2 + ; diff --git a/XBDHNTEG.m b/XBDHNTEG.m new file mode 100644 index 0000000..72ccfcc --- /dev/null +++ b/XBDHNTEG.m @@ -0,0 +1,28 @@ +XBDHNTEG ;INTEGRITY CHECKER;JUN 12, 1991 + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; +START ; + NEW BYTE,COUNT,RTN + K ^UTILITY($J) + F I=1:1 S X=$T(LIST+I) Q:X="" S X=$P(X,";;",2),R=$P(X,"^",1),B=$P(X,"^",2),C=$P(X,"^",3),^UTILITY($J,R)=B_"^"_C + F I=1:1:6 S X=$P($T(@("LINE"_I)),";;",2,99),@("XBINTEG("_I_")=X") + X XBINTEG(1) + Q + ; +LINE1 ;;X XBINTEG(2),XBINTEG(6) +LINE2 ;;S RTN="" F S RTN=$O(^UTILITY($J,RTN)) Q:RTN="" W !,RTN ZL @RTN S (BYTE,COUNT)=0 S X=$T(+1),X=$P(X," [ ",1) X XBINTEG(4),XBINTEG(3),XBINTEG(5) +LINE3 ;;F I=2:1 S X=$T(+I) Q:X="" X XBINTEG(4) +LINE4 ;;F J=1:1 S Y=$E(X,J) Q:Y="" S BYTE=BYTE+1,COUNT=COUNT+$A(Y) +LINE5 ;;S B=$P(^(RTN),"^",1),C=$P(^(RTN),"^",2) I B'=BYTE!(C'=COUNT) W " has been modified" +LINE6 ;;K XBINTEG,B,C,I,J,R,X,Y + ; +LIST ; + ;;XBDH^1015^66897 + ;;XBDHD^3059^203397 + ;;XBDHD1^1477^95266 + ;;XBDHD2^4434^278456 + ;;XBDHDF^3469^221710 + ;;XBDHDF1^991^59705 + ;;XBDHDIP^550^35291 + ;;XBDHDSP^2728^178325 + ;;XBDHDSV^2938^188450 diff --git a/XBDICV.m b/XBDICV.m new file mode 100644 index 0000000..199e125 --- /dev/null +++ b/XBDICV.m @@ -0,0 +1,79 @@ +XBDICV ; IHS/ADC/GTH - SET DICTIONARY VERSION NUMBERS ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; This routine sets FileMan dictionary version numbers. + ; +START ; + I $G(DUZ(0))'="@" W !,*7," Insufficient FileMan access. DUZ(0) is not ""@""." Q + S U="^",IOP=$I + D ^%ZIS + W !!,"^XBDICV - This program sets FileMan dictionary version numbers." + ; + S (XBDICVHI,XBDICVQF)=0 + D GETDICS ; Get set of dictionaries + I XBDICVQF D EOJ Q + D SHOW ; Show current versions + D ASK ; See if user wants control + I XBDICVQF D EOJ Q + D VER ; Get new version number + I XBDICVQF D EOJ Q + D CHANGE ; Change version numbers + D EOJ ; Clean up + Q + ; +GETDICS ; GET SET OF DICTIONARIES + D ^XBDSET + S:'$D(^UTILITY("XBDSET",$J)) XBDICVQF=1 + Q + ; +SHOW ; SHOW CURRENT VERSION NUMBERS + W ! + S XBDICVFL="" + F XBDICVL=0:0 S XBDICVFL=$O(^UTILITY("XBDSET",$J,XBDICVFL)) Q:XBDICVFL="" W !,$P(^DIC(XBDICVFL,0),U,1),$S($D(^DD(XBDICVFL,0,"VR")):"..Current version is "_^("VR"),1:"..No version") D HIGH + Q + ; +HIGH ; SAVE HIGH VERSION NUMBER + I $D(^DD(XBDICVFL,0,"VR")),+^("VR")>+XBDICVHI S XBDICVHI=^("VR") + Q + ; +ASK ; + W !!,"Do you want to be asked before setting each file? (Y/N) Y// " + R XBDICASK:$G(DTIME,300) + S:XBDICASK="" XBDICASK="Y" + I "^YyNn"'[XBDICASK W *7 G ASK + I XBDICASK["^" S XBDICVQF=1 Q + S XBDICASK=$S("Yy"[$E(XBDICASK):1,1:0) + Q + ; +VER ; + R !!,"New version number: ",XBDICVVR:$G(DTIME,300) + I XBDICVVR["^" S XBDICVQF=1 Q + I XBDICVVR'?1.3N.1".".2N.1A.2N W *7 G VER + I +XBDICVVR<+XBDICVHI W !,"One or more selected files already has a version number greater than ",XBDICVVR,*7 G VER + Q + ; +CHANGE ; CHANGE VERSION NUMBERS + W ! + S XBDICVFL="" + F XBDICVL=0:0 S XBDICVFL=$O(^UTILITY("XBDSET",$J,XBDICVFL)) Q:XBDICVFL="" D PROCESS + Q + ; +PROCESS ; + S XBDICANS="Y" + W !,$P(^DIC(XBDICVFL,0),U,1),$S($D(^DD(XBDICVFL,0,"VR")):"..Current version is "_^("VR"),1:"..No version"),$S(XBDICASK:"..OK? Y// ",1:"") +P2 ; + I XBDICASK R XBDICANS:$G(DTIME,300) S:XBDICANS="" XBDICANS="Y" I "YyNn"'[$E(XBDICANS) D P2ERR G P2 + I XBDICANS="Y" S ^DD(XBDICVFL,0,"VR")=XBDICVVR W " Changed to ",XBDICVVR + Q + ; +P2ERR ; + W *7 + F XBDICVI=1:1:$L(XBDICANS) W @IOBS," ",@IOBS + Q + ; +EOJ ; + KILL ^UTILITY("XBDSET",$J) + KILL XBDICANS,XBDICASK,XBDICVFL,XBDICVHI,XBDICVI,XBDICVL,XBDICVQF,XBDICVVR + KILL BS,FF,RM,SL,SUB,XY + Q + ; diff --git a/XBDIE.m b/XBDIE.m new file mode 100644 index 0000000..d173735 --- /dev/null +++ b/XBDIE.m @@ -0,0 +1,71 @@ +XBDIE(XBRET) ; IHS/ADC/GTH - NESTING OF DIE ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; Thanks to Paul Wesley, DSD, for providing the original + ; routine. + ; + ; PROGRAMMERS NOTE: PLEASE USE THE MORE GENERIC ^XBNEW. + ; + ; 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 (....) XBDIE 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 XBDIE quits to return to the calling program it pops + ; the variable stack. + ; + ; The passing parameter is built by "tag^routine:var;vns*" + ; + ; The die call to be nested is structured with a tag entry + ; and a Quit. + ; + ; The call is made with DO ^XBDIE("TAG^ROUTINE:AGSITE,ABM*") + ; where the variable AGSITE and the namespace ABM is + ; included in the exclusive new for illustration. + ; + ; Proper logic flow after the XBDIE call usually needs some + ; attention. + ; + ; A TEST entry point is provided in this routine for + ; illustration. + ; +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 + .Q +RETURN ; + S XBN="("_XBN_","_XBKVAR_")" + S $P(XBRET,":",2)=XBN + KILL XBNS,XBN,XB,XBY,XBL,XBKVAR + NEW @($P(XBRET,":",2)) + D @($P(XBRET,":",1)) + Q + ; +END ;-------------------------------------------------------------- +XBKVAR ;;DUZ,DTIME,DT,DISYS,IO,IOF,IOBS,IOM,ION,IOSL,IOST,IOT,IOS,IOXY,U,XRTL,ZTSTOP,ZTQUEUED,ZTREQ + ;-------------------------------------------------------------- + Q + ; +TEST ; + D ^XBDIE("T2^XBDIE:AG;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",! + D ^XBVL + Q + ; diff --git a/XBDIFF.m b/XBDIFF.m new file mode 100644 index 0000000..3bc98a1 --- /dev/null +++ b/XBDIFF.m @@ -0,0 +1,61 @@ +XBDIFF ; IHS/ADC/GTH - RETURN DIFFERENCE BETWEEN TWO DATE/TIMES ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; Passed two date/times this routine returns the difference + ; in days, hours, minutes, seconds separated by colons ":". + ; + ; The date/times must be passed in the variables X and X1. + ; The result will be returned in X. X1 will be killed. + ; + ; If either X or X1 are invalid X will be returned as -1 and + ; X1 will be killed. + ; + ; The date/times may be passed in $HOROLOG format or in + ; internal FileMan format. + ; + ; See also, $$FMDIFF^XLFDT, and $$HDIFF^XLFDT. + ; +START ; + NEW A,B,C,D,E,F,G + D EDIT + Q:X<0 + S:X>X1 A=X,X=X1,X1=A + I X?5N1","5N S A=$P(X,",",1),B=$P(X,",",2) I 1 + E D H^%DTC S A=%H,B=%T + I X1?5N1","5N S C=$P(X1,",",1),D=$P(X1,",",2) I 1 + E S X=X1 D H^%DTC S C=%H,D=%T + S E=C-A S:D86399 S X=-1 KILL X1 + . Q + S A=$P(X,".",2) + I +$E(A,1,2)<24,+$E(A,3,4)<60,+$E(A,5,6)<60 Q + E S X=-1 KILL X1 + KILL A + Q + ; +EDITX ; EDIT X + Q:X?5N1"."5N + Q:X?7N + Q:X?7N1"."1.6N + S X=-1 + KILL X1 + Q + ; +EDITX1 ; EDIT X1 + Q:X?5N1"."5N + Q:X?7N + Q:X?7N1"."1.6N + S X=-1 + KILL X1 + Q + ; diff --git a/XBDINUM.m b/XBDINUM.m new file mode 100644 index 0000000..4c077ed --- /dev/null +++ b/XBDINUM.m @@ -0,0 +1,49 @@ +XBDINUM ; IHS/ADC/GTH - CONVERTS NON-DINUM FILE TO DINUM FILE ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; +START ; + S U="^" + W !!,"This program sets the DFNs of a DINUM file appropriately.",! + S DIC="^DIC(",DIC(0)="QAZEM" + D ^DIC + Q:Y<0 + S DIC=+Y + I '$D(^DIC(DIC,0,"GL")) W !!,"Corrupted ^DIC!",!,"No ""GL"" node in zeroth node of file ",DIC,"." Q + S XBDIGBL=^DIC(DIC,0,"GL") + X "S XBDIX=$D("_XBDIGBL_"0))" + I 'XBDIX W !!,XBDIGBL,"0) does not exist." Q + I '$P(@(XBDIGBL_"0)"),U,4) W !!,"File ",DIC," has no entries." Q + I '$D(^DD(DIC,.01,0)) W !!,"Corrupted ^DD!" Q + I ^DD(DIC,.01,0)'["DINUM=X" W !!,"File ",DIC," is not a DINUM file." Q + KILL ^UTILITY("XBDINUM",$J),^UTILITY("XBDIDUP",$J) + S (XBDI3,XBDI4,XBDIDFN)=0 + X "S ^UTILITY(""XBDINUM"",$J,0)="_XBDIGBL_"0)" + F XBDIL=0:0 X "S XBDIDFN=$O("_XBDIGBL_XBDIDFN_"))" Q:XBDIDFN'=+XBDIDFN D X1 + S XBDIX=^UTILITY("XBDINUM",$J,0),$P(XBDIX,U,3)=XBDI3,$P(XBDIX,U,4)=XBDI4,^(0)=XBDIX + W !!,"Global ",$E(XBDIGBL,1,$L(XBDIGBL)-1)," now renumbered and stored in ^UTILITY(""XBDINUM"",",$J,!," High DFN=",XBDI3," Number of entries=",XBDI4 + I $D(^UTILITY("XBDIDUP",$J)) W !!,"Duplicate entries found. Stored in ^UTILITY(""XBDIDUP"",",$J,!," Eliminate duplicates and rerun this job!" G EOJ + S XBDIX=$S($E(XBDIGBL,$L(XBDIGBL))="(":$E(XBDIGBL,1,$L(XBDIGBL)-1),1:$E(XBDIGBL,1,$L(XBDIGBL)-1)_")") + KILL @(XBDIX) + W !!,XBDIX," has been killed! Now being recreated." + S TO=XBDIGBL,FROM="^UTILITY(""XBDINUM"",$J,",TALK=1 + D ^XBGXFR + W !!,"File now being RE-INDEXED!",! + S DIK=XBDIGBL,XBDIX=0 + F XBDIL=0:0 X "S XBDIX=$O("_XBDIGBL_XBDIX_"))" Q:XBDIX'=+XBDIX W "." S DA=XBDIX D IX1^DIK + D EOJ + Q + ; +X1 ; + S FROM=XBDIGBL_XBDIDFN_"," + X "S TO=+"_XBDIGBL_XBDIDFN_",0)" + S:TO>XBDI3 XBDI3=TO + S TO=$S('$D(^UTILITY("XBDINUM",$J,TO)):"^UTILITY(""XBDINUM"",$J,"_TO_",",1:"^UTILITY(""XBDIDUP"",$J,"_TO_",") + S:TO'["XBDIDUP" XBDI4=XBDI4+1 + S TALK=1 + D ^XBGXFR + Q + ; +EOJ ; + KILL ^UTILITY("XBDINUM",$J),XBDIGBL,XBDIX,XBDI3,XBDI4,XBDIDFN,XBDIL + Q + ; diff --git a/XBDIQ0.m b/XBDIQ0.m new file mode 100644 index 0000000..d8a7251 --- /dev/null +++ b/XBDIQ0.m @@ -0,0 +1,80 @@ +XBDIQ0 ; IHS/ADC/GTH - Documentation for XBDIQ1 ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; 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" + ; + ; + Q + ; diff --git a/XBDIQ1.m b/XBDIQ1.m new file mode 100644 index 0000000..720d68c --- /dev/null +++ b/XBDIQ1.m @@ -0,0 +1,188 @@ +XBDIQ1 ; IHS/ADC/GTH - SPECIAL EN^DIQ1 DATA PULLER ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; Thanks to Paul Wesley, DSD/OIRM, for the original routine. + ; + ; Documentation for the APIs in this routine can be found + ; in routine XBDIQ0. + ; +DOC ; + Q + ; +EN ;PEP - Returns single entries + NEW XB0,XBDIC,XBFN,XBGBL,XBNEWPAR,XBGL + S XBDIC=DIC + I DA'=+DA D PARSE(DA) + D DICFNGL(DIC),^XBSFGBL(XBFN,.XBGBL) + S XBDIC=$P(XBGBL,"DA,"),DIC=XBDIC + D ENDIQ1,EXIT + Q + ; +ENP(DIC,DA,DR,DIQ,XBFMT) ;PEP - param pass into EN + S:'$D(DIQ(0)) DIQ(0)=$G(XBFMT) + D EN + Q + ; +ENPM(DIC,DA,DR,DIQ,XBFMT) ;PEP - param pass into EN + S:'$D(DIQ(0)) DIQ(0)=$G(XBFMT) + D ENM + Q + ; +ENM ;PEP - 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)="" + I $D(DIC("S")) S XBDICS=DIC("S") + F S DA=$O(@(XBDIC_"DA)")) Q:DA'>0 D + . S XB0=@(XBDIC_"DA,0)") + . I $L($G(XBDICS)) S DIC("S")=XBDICS + . I $D(DIC("S")) S X="`"_DA,DIC(0)="N" D ^DIC Q:Y'>0 + . S DIC=XBDIC + . D ENDIQ1 + .Q + KILL XBDICS + 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" + KILL DIC + S DIC=XBDIC ;reset dic + S DIQ(0)="I" + D ENDIQ1X,PULLDIQ1 + KILL ^UTILITY("DIQ1",$J) + Q + ; +ENDIQ1X ;EP - to call DIQ1 with new + 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;XBSRCFL") + 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_",",%Y=XBDIQ + .Q +1 I +XBDIQ(0)=1 D Q + . S %X="XBDTMP("_XBFN_",",%Y=XBDIQ,XBUDA=DA_"," + .Q +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 + ..Q + . S XBUDA=%Y_DA_"," + . S %Y=XBDIQ_%Y + .Q +%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) ;PEP - extrinsic pull a value for a field + NEW DIQ,XBT + S DIQ="XBT(" + D EN + Q $G(XBT(+DR)) + ; +VALI(DIC,DA,DR) ;PEP - extrinsic pull a value for a field + NEW DIQ,XBT + S DIQ="XBT(",DIQ(0)="I" + D EN + Q $G(XBT(+DR,"I")) + ; +PARSE(XBDA) ;PEP - 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) + KILL DA(0) + Q + ; +DIC(XBFN) ;PEP - 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") + .Q + ; kill off redundant DR( and DA( + S XBLVL=XBLVL-1 + KILL DR(XB(XBLVL,"FN")),DA(XB(XBLVL,"FN")) + Q + ; diff --git a/XBDIR.m b/XBDIR.m new file mode 100644 index 0000000..755b024 --- /dev/null +++ b/XBDIR.m @@ -0,0 +1,51 @@ +XBDIR ; IHS/ADC/GTH - DIR INTERFACE ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; The purpose of routine XBDIR is to provide interface + ; methodology for 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 a local variable to the + ; output of the call to DIR^XBDIR(), which will be Y at the + ; bottom of this routine, or, less likely, WRITE the value. + ; + ; 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,"","Produ + ; ce report by FY or Dates","^D HELP^",300,2) + ; + ; S FY=$$DIR^XBDIR("NO","Object Class Code Summar + ; y for FISCAL YEAR ",FY,$G(DTIME,500),"Enter a FOUR DIGIT F + ; ISCAL YEAR","^D SB1^") + ; + ; +DIR(O,A,B,T,Q,H,R) ;PEP - Extrinsic interface to ^DIR. + I '$L($G(O)) Q -1 + NEW DA,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 + ; diff --git a/XBDR.m b/XBDR.m new file mode 100644 index 0000000..6a1a9c2 --- /dev/null +++ b/XBDR.m @@ -0,0 +1,98 @@ +XBDR ; IHS/ADC/GTH - BUILDS DIR STRING ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; This routine builds a string which sets variable DIR, and + ; it's descendants, for use in a routine. The string is + ; stored in the variable "%", and in the "Temp" storage + ; area for the screen editor for the current device. + ; +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 KILL %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) + 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_" KILL DA D ^DIR KILL 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 ; + S %=" "_XBDRCODE + W !!!,"Saving the following line of code in the '%' variable:",!,%,!! + D SV(%) + Q + ; +SV(%) ; + NEW (%) + D SAVE^ZIBDR(%) + Q + ; diff --git a/XBDR1.m b/XBDR1.m new file mode 100644 index 0000000..108e5e5 --- /dev/null +++ b/XBDR1.m @@ -0,0 +1,140 @@ +XBDR1 ; IHS/ADC/GTH - XBDR SUBROUTINE; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Prevent + ; + ; Part of XBDR + ; +TYPE ; + S DIR("A")="Input data type" + S DIR(0)="S^D:DATE;E:END-OF-PAGE;F:FREE TEXT;L:LIST OR RANGE;N:NUMERIC;S:SET;Y:YES/NO;Z:FILEMAN" + D ^DIR KILL DIR + I $D(DIRUT) S XBDRQUIT="" Q + ;S XBDRTYPE=X;IHS/SET/GTH XB*3*9 10/29/2002 + S (XBDRTYPE,X)=$$UP^XLFSTR(X) ;IHS/SET/GTH XB*3*9 10/29/2002 + D @X + I $D(XBDRQUIT) Q + I XBDRTYPE'?1.4U Q + S DIR("A")="Is this query mandatory",DIR("B")="NO",DIR(0)="Y" + D ^DIR KILL DIR + X XBDROUT + I S XBDRQUIT="" Q + I "yY"'[$E(X) S XBDRTYPE=XBDRTYPE_"O" + Q + ; +E ; +Y ; + Q + ; +MINMAX ; + S DIR("A")="Minimum "_Z_" allowed",DIR(0)="NO^::7" + D ^DIR + KILL DIR + X XBDROUT + I S XBDRQUIT="" Q + S XBDRMIN=X,DIR("A")="Maximum "_Z_" allowed",DIR(0)="NO^::7" + D ^DIR + KILL DIR + X XBDROUT + I S XBDRQUIT="" Q + S XBDRMAX=X + Q + ; +F ; + S Z="length" + D MINMAX + Q + ; +L ; + S Z="value" + D MINMAX + Q + ; +N ; + S Z="value" + D MINMAX + S DIR("A")="Maximum number of decimal places",DIR(0)="NO^0:9" + D ^DIR + KILL DIR + X XBDROUT + I S XBDRQUIT="" Q + S XBDRSPEC=X + Q + ; +S ; + S XBDRMIN="" + F L=0:0 D S1 Q:X="" + I XBDRMIN="" S XBDRQUIT="" Q + I '$D(XBDRQUIT) D S2 + Q + ; +S1 ; + W ! + S DIR("A")="Code",DIR(0)="FO" + D ^DIR + KILL DIR + X XBDROUT + I S XBDRQUIT="",X="" Q + I X="" Q + S Z=X,DIR("A")="Stands for",DIR(0)="F" + D ^DIR + KILL DIR + X XBDROUT + I S XBDRQUIT="",X="" Q + S:XBDRMIN]"" XBDRMIN=XBDRMIN_";" + S XBDRMIN=XBDRMIN_Z_":"_X + I $L(XBDRMIN)>240 W *7," DIR STRING TOO LONG...SESSION ABORTED" S XBDRQUIT="",X="" + Q + ; +S2 ; + S DIR("A")="Possible choices should be listed which format" + S DIR("B")="VERTICAL" + S DIR(0)="SB^H:HORIZONTAL;V:VERTICAL;" + W ! + D ^DIR + KILL DIR + X XBDROUT + I S XBDRQUIT="" + I $E(X)="H" S XBDRTYPE=XBDRTYPE_"B" + Q + ; +D ; + S DIR("A")="Enter earliest date",DIR(0)="DO^::ETS" + D ^DIR + KILL DIR + X XBDROUT + I S XBDRQUIT="" Q + S XBDRMIN=Y + S DIR("A")="Enter maximum date",DIR(0)="DO^"_XBDRMIN_"::ETS" + D ^DIR + KILL DIR + X XBDROUT + I S XBDRQUIT="" Q + S XBDRMAX=Y +DTS ; + W !!!,"Enter the %DT string using as many of the following as you wish:",!! + S X="F;Future dates assumed^N;Numeric input not allowed^P;Past dates assumed^R;Time required^T;Time allowed^X;Exact time required^S;Seconds allowed" + F I=1:1 S Y=$P(X,U,I) Q:Y="" W $P(Y,";")," ",$P(Y,";",2),! +ADTS ; + S DIR("A")="%DT String",DIR(0)="FO" + D ^DIR + KILL DIR + X XBDROUT + I S XBDRQUIT="" Q + I X="" S XBDRSPEC="E" Q + I X'?1.9U W *7," ??" G ADTS + S XBDRSPEC="E"_X + Q + ; +Z ; + S DIC=1,DIC(0)="AEQ",DIC("A")="Enter FILE name: " + W ! + D ^DIC + KILL DIC + I Y=-1 S XBDRQUIT="" Q + S Z=+Y,DIC="^DD("_+Y_",",DIC(0)="AEQ",DIC("A")="Enter FIELD name: " + D ^DIC + KILL DIC + I Y=-1 S XBDRQUIT="" Q + S XBDRTYPE=Z_","_+Y,XBDRRUN=5 + Q + ; diff --git a/XBDSET.m b/XBDSET.m new file mode 100644 index 0000000..2edec1e --- /dev/null +++ b/XBDSET.m @@ -0,0 +1,135 @@ +XBDSET ; IHS/ADC/GTH - BUILDS LIST OF FILEMAN FILES ; [ 12/11/2000 3:13 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*8 - IHS/ASDST/GTH 12-07-00 - Add ability to select from BUILD file. + ; + ; This routine selects FileMan dictionaries individually, + ; by a range, or for a specific package. This routine can + ; be called from another routine by setting the variables + ; XBDSLO, XBDSHI and then D EN1^XBDSET. + ; + ; If the variable XBDSND exist upon entry no default menu + ; option will be displayed. + ; +START ; + S IOP=0 + D ^%ZIS + KILL DIC,DIR,^UTILITY("XBDSET",$J) + S (XBDSP,XBDSQ)=0 + F D GETFILES Q:XBDSQ + D EOJ + Q + ; +GETFILES ; + W ! + ; S DIR(0)="SO^"_$S('XBDSP:"O:One file only;",1:"")_"S:Selected files;R:Range of files;P:Package;"_$S($D(^UTILITY("XBDSET",$J)):"L:List of files already selected; : ",1:" : "); XB*3*8 + S DIR(0)="SO^"_$S('XBDSP:"O:One file only;",1:"")_"S:Selected files;R:Range of files;P:Package;B:Build;"_$S($D(^UTILITY("XBDSET",$J)):"L:List of files already selected; : ",1:" : ") ; XB*3*8 + S DIR("A")="Choose one,"_$S(XBDSP!($D(XBDSND)):" RETURN to continue,",1:"")_" or ^ to cancel" + I 'XBDSP,'$D(XBDSND) S DIR("B")="O" + S DIR("?")=$S(XBDSP:"Do you want",1:"Do you want one file,") + ; S DIR("?")=DIR("?")_" a range of files by number, files from a specific package, "_$S($D(^UTILITY("XBDSET",$J)):"individual files, or a list of files already selected?",1:"or individual files?") ; XB*3*8 + S DIR("?")=DIR("?")_" a range of files by number, files from a specific package or build, "_$S($D(^UTILITY("XBDSET",$J)):"individual files, or a list of files already selected?",1:"or individual files?") ; XB*3*8 + D ^DIR + KILL DIR + I $D(DIRUT) K:$D(DUOUT)!($D(DTOUT)) ^UTILITY("XBDSET",$J) S XBDSQ=1 Q + D OPTION ; Get files for selected option + I $D(^UTILITY("XBDSET",$J)) S XBDSP=1 + Q + ; +OPTION ; GET FILES FOR SELECTED OPTION + W ! + I Y="O" D ONEFILE Q ; Get one file and exit + I Y="S" D SELECT Q ; Get selected files + I Y="R" D RANGE Q ; Get range of files + I Y="P" D PACKAGE Q ; Get files from package + I Y="L" D LIST Q ; List selected files + I Y="B" D BUILD Q ; Get files from build ; XB*3*8 + Q + ; +ONEFILE ; GET ONE FILE AND EXIT + S XBDSND=1 + S DIC="^DIC(",DIC(0)="AEMQ" + D ^DIC + KILL DIC + Q:Y<0 + S ^UTILITY("XBDSET",$J,+Y)="" + S XBDSQ=1 + Q + ; +SELECT ; GET SELECTED FILES + S DIC="^DIC(",DIC(0)="AEMQ" + F D ^DIC Q:Y<0 S ^UTILITY("XBDSET",$J,+Y)="" + KILL DIC + I '$O(^UTILITY("XBDSET",$J,""))!($D(DUOUT)) S XBDSQ=1 Q + Q + ; +RANGE ; GET RANGE OF FILES + S DIR(0)="NO^1:99999999:3",DIR("A")="From file number" + D ^DIR + KILL DIR + I $D(DIRUT) S XBDSQ=1 Q + S XBDSFF=+Y + F S DIR(0)="NO^1:99999999:3",DIR("A")="Thru file number" D ^DIR KILL DIR Q:$D(DIRUT) D Q:'XBDSQ S XBDSQ=0 + . I +YXBDSTF) + . Q:'$D(^DIC(XBDSFILE,0)) + . S ^UTILITY("XBDSET",$J,XBDSFILE)="" + . S XBDSC=XBDSC+1 + .Q + Q + ; +PACKAGE ; GET FILES FROM SPECIFIC PACKAGE + S DIC=9.4,DIC(0)="AEMQ" + D ^DIC + KILL DIC + Q:Y<0 + S Y=+Y,X=0 + F S X=$O(^DIC(9.4,Y,4,X)) Q:X'=+X I $D(^DIC(^DIC(9.4,Y,4,X,0),0)) S ^UTILITY("XBDSET",$J,^DIC(9.4,Y,4,X,0))="" + Q + ; + ; XB*3*8 start block +BUILD ; Get files from selected BUILD + S DIC=9.6,DIC(0)="AEMQ" + D ^DIC + KILL DIC + Q:Y<0 + S Y=+Y,X=0 + F S X=$O(^XPD(9.6,Y,4,X)) Q:X'=+X I $D(^XPD(9.6,Y,4,X,0)) S ^UTILITY("XBDSET",$J,^XPD(9.6,Y,4,X,0))="" + Q + ; XB*3*8 end block + ; +LIST ; LIST FILES ALREADY SELECTED + I '$D(^UTILITY("XBDSET",$J)) W !,"No files selected." Q + W @IOF,"Files already selected:",! + S XBDSX="" + F S XBDSX=$O(^UTILITY("XBDSET",$J,XBDSX)) Q:XBDSX="" W !,XBDSX,?14,$P(^DIC(XBDSX,0),U,1) I $Y>(IOSL-3) D PXBSE Q:$D(DUOUT) W @IOF + I '$D(DUOUT),$Y>(IOSL-10) D PXBSE + Q + ; +PXBSE ; GIVE USER A CHANCE TO SEE LAST PAGE AND QUIT + I IO=IO(0),$E(IOST,1,2)="C-" S Y=$$DIR^XBDIR("E") + Q + ; +EN1 ;EP - Non-interactive selection of range of files. + KILL ^UTILITY("XBDSET",$J) + I '$D(XBDSLO)!('$D(XBDSHI)) Q + S XBDSFF=XBDSLO,XBDSTF=XBDSHI + D RANGE2 + D EOJ + Q + ; +EOJ ; + KILL XBDSC,XBDSFF,XBDSFILE,XBDSHI,XBDSL,XBDSLO,XBDSND,XBDSP,XBDSQ,XBDSTF,XBDSX + KILL DIC,DIR,DIRUT,DTOUT,DUOUT,X,Y + Q + ; diff --git a/XBDT.m b/XBDT.m new file mode 100644 index 0000000..727d55d --- /dev/null +++ b/XBDT.m @@ -0,0 +1,50 @@ +XBDT ;IHS/HQW/JDH - date/time utilities ;[ 06/19/1998 11:11 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ;FISCAL + ; usage: S %=$$FISCAL^XBDT(XBDT,XBFYMTH,XBADJ) + ; + ; Input: (all parameters are optional) + ; XBDT Date in either fileman of horlog format. If not defined, + ; default is today. + ; XBFYMT Month beginning fiscal year. The definition of this + ; variable can be assigned in the parameter list. If it + ; is not and Beginning fiscal year month field in the + ; PCC MASTER CONTROL file is valued for the current locaton, + ; its value is used. The default is 10. + ; XBADJ The value of this variable allows the adjustment of the + ; FY value + ; + ; Output: current fiscal year^star date of FY^end date of FY + ; + ;LEAP + ; input: (optional) date in Fileman, yyyy or horlog + ; output: boolean 1=yes 0=no + ; uses algorithm defined for leap year in the RPMS Y2000 Compliance Plan + ; +FISCAL(XBDT,XBFYMTH,XBADJ) ; return current fiscal year + ; + N %,T,T1,T2,XBFY,XBFYBEG,XBFYEND + S XBADJ=$G(XBADJ) ; adjustment variable + S:'$G(XBDT) XBDT=$$NOW^XLFDT + S:XBDT["," XBDT=$$HTFM^XLFDT(XBDT) ; horolog to fileman + S T=$P($G(^APCCCTRL(DUZ(2),0)),U,8) ; beg, FY month for location from PCC MASTER CONTROL file + S:'$G(XBFYMTH) XBFYMTH=$S(T:T,1:10) ; use month entered, as in MSTR file or 10 + S XBFYMTH=$E("0",XBFYMTH<10)_XBFYMTH ; if month is less then 10 make it two digits + S T1=XBFYMTH-1<$E(XBDT,4,5) ; boolean. month before or after FY start month + S T2=XBDT\10000-'T1 ; current year in FM 3 digit year format plus 1 or 0 determined by T1 calculation + S XBFY=XBDT\10000+T1 ; fiscal Year in external 4 digit format + S XBFYBEG=T2_XBFYMTH_"01" ; beginning of fiscal year + S %=T2+1_XBFYMTH_"01" + S XBFYEND=$$FMADD^XLFDT(%,-1) ;get the beginning date of the fiscal year + Q XBFY+1700+XBADJ_U_XBFYBEG_U_XBFYEND + ; + ; + ; +LEAP(XBDT) ; is the year a leap year? + ; + S:'$G(XBDT) XBDT=$$NOW^XLFDT + S:XBDT["," XBDT=$$HTFM^XLFDT(XBDT) ; horolog to fileman + S:$L(XBDT)>4 XBDT=XBDT\10000+1700 ; 4 digit date + Q '(XBDT#4)&(XBDT#100)!('(XBDT#100)&'(XBDT#400)) ; leap year algorithm + ; diff --git a/XBEHRCK.m b/XBEHRCK.m new file mode 100644 index 0000000..3a17e53 --- /dev/null +++ b/XBEHRCK.m @@ -0,0 +1,295 @@ +XBEHRCK ;IHS/SET/GTH - EHR ENVIRONMENT CHECK ; [ 05/11/2004 ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; To add to the list of requirements, add the info specific to the + ; application after the "ENV" label, below in the form: + ; Namespace*Version*Patch + ; E.g., to check for Pt Reg, v 6.1, patch 2: + ; AG*6.1*2 + ; If the application has no patches, leave the patch info blank. + ; 20040512d + ; 20040603 IHS/SET/HMW Added checks for Pharmacy Data Management + ; 20040615 Changed ABSP to check for patch 10 instead of 8 + ; 20040708 Removed SD patch 63 + ; 20040719 Removed SD Patches 300 307 314 + ; Removed HL Patches 17 18 21 8 9 + ; Removed GMTS Patch 45 + ; Removed ABSP Patch 10 + ; Removed APSE 6.1 + ; +ENV ; Namespace*Version*Patch + ;;XU*8.0*1010 + ;;XU*8.0*2 + ;;XU*8.0*15 + ;;XU*8.0*16 + ;;XU*8.0*26 + ;;XU*8.0*28 + ;;XU*8.0*32 + ;;XU*8.0*44 + ;;XU*8.0*311 + ;;XU*8.0*288 + ;;XT*7.3*1002 + ;;XT*7.3*73 + ;;DI*22.0*1001 + ;;DI*22.0*70 + ;;HL*1.6*1005 + ;;PSO*6.0*5 + ;;APSA*6.1 + ;;AUPN*99.1*11 + ;;LEX*2*9 + ;;VSIT*2 + ;;PX*1*45 + ;;PX*1*73 + ;;PX*1*74 + ;;PX*1*88 + ;;PX*1*115 + ;;PXRM*1.5*1 + ;;PXRM*1.5*2 + ;;PXRM*1.5*3 + ;;PXRM*1.5*4 + ;;PXRM*1.5*5 + ;;PXRM*1.5*6 + ;;PXRM*1.5*7 + ;;PXRM*1.5*8 + ;;PXRM*1.5*9 + ;;PXRM*1.5*10 + ;;PXRM*1.5*11 + ;;PXRM*1.5*13 + ;;PXRM*1.5*14 + ;;PXRM*1.5*17 + ;;PXRM*1.5*15 + ;;PXRM*1.5*19 + ;;GMTS*2.7*36 + ;;GMTS*2.7*43 + ;;GMTS*2.7*52 + ;;GMTS*2.7*60 + ;;GMTS*2.7*62 + ;;GMTS*2.7*64 + ;;GMTS*2.7*68 + ;;PIMS*5.3T11 + ;;DG*5.3*124 + ;;DG*5.3*57 + ;;DG*5.3*134 + ;;DG*5.3*249 + ;;DG*5.3*265 + ;;DG*5.3*276 + ;;DG*5.3*277 + ;;DG*5.3*389 + ;;DG*5.3*415 + ;;SD*5.3*131 SEQ #127 + ;;SD*5.3*263 SEQ #243 + ;;SD*5.3*254 SEQ #247 + ;;USR*1.0 + ;;TIU*1.0*1 SEQ #4 + ;;TIU*1.0*3 SEQ #5 + ;;TIU*1.0*4 SEQ #8 + ;;TIU*1.0*7 SEQ #9 + ;;TIU*1.0*15 SEQ #10 + ;;TIU*1.0*19 SEQ #19 + ;;TIU*1.0*28 SEQ #22 + ;;TIU*1.0*31 SEQ #34 + ;;TIU*1.0*47 SEQ #60 + ;;TIU*1.0*76 SEQ #70 + ;;TIU*1.0*80 SEQ #82 + ;;TIU*1.0*102 SEQ #86 + ;;TIU*1.0*89 SEQ #90 + ;;TIU*1.0*108 SEQ #99 + ;;TIU*1.0*170 + ;;TIU*1.0*150 SEQ #142 + ;;TIU*1.0*100 SEQ #103 + ;;TIU*1.0*105 SEQ #106 + ;;TIU*1.0*119 SEQ #109 + ;;TIU*1.0*125 SEQ #113 + ;;TIU*1.0*127 SEQ #118 + ;;TIU*1.0*122 SEQ #119 + ;;TIU*1.0*124 SEQ #124 + ;;TIU*1.0*138 SEQ #125 + ;;TIU*1.0*63 SEQ #76 + ;;TIU*1.0*137 + ;;TIU*1.0*134 + ;;TIU*1.0*109 SEQ #123 + ;;LR*5.2*1018 + ;;LR*5.2*128 + ;;LR*5.2*121 + ;;LR*5.2*201 + ;;LR*5.2*191 + ;;LR*5.2*208 + ;;RA*5.0 + ;;PSJ*4.5 + ;;BW*2.0 + ;;BW*2.0*9 + ;;XWB*1.1*6 + ;;XWB*1.1*12 + ;;END; <-- Leave this alone. It's the LOOP ender. + ; ----------------------------------------------------- + ; + ; begin - FOR TEST ONLY REMOVE FOR DIST. + ;I '$G(DUZ) D + ;. KILL + ;. KILL ^XUTL("XQ",$J) + ;. D HOME^%ZIS,DT^DICRW,^XBKTMP + ;. S DUZ=1,DUZ(2)=$P(^AUTTSITE(1,0),U) + ;.Q + ; end - FOR TEST ONLY REMOVE FOR DIST. + ; + I '$G(DUZ) D RSLT(""),RSLT("Please set your DUZ before running this routine.") Q + D DT^DICRW,^XBKVAR + D ASKDEV Q:POP + Q:$D(ZTQUEUED) + ; +ZTM ;EP - Taskman entry point + KILL ^TMP("XBEHRCK",$J) + NEW XBEH,XBEHNEED,XBEHOK + N XBEHNS,XBEHNAME,XBEHVER,XBEHPKG,XBEHC + U IO + S XBEHOK=1,XBEHC=0 + S XBEHPKG="" + S X=$P(^VA(200,DUZ,0),U) + ; + D RSLT(""),RSLT("Hello, "_$P(X,",",2)_" "_$P(X,",")) + D RSLT(""),RSLT("Environment Checker for "_$P($T(+2),";",4)_" V "_$P($T(+2),";",3)_", as of "_$P($T(+2),";",6)_".") + ; + F XBEH=1:1 Q:$P($T(ENV+XBEH),";",3)="END" D + . S XBEH(0)=$P($T(ENV+XBEH),";",3) + . S XBEHNS=$P(XBEH(0),"*") + . Q:XBEHNS="" + . S XBEHVER=$P(XBEH(0),"*",2) + . S XBEHNAME=$O(^DIC(9.4,"C",XBEHNS,0)) + . S:XBEHNAME]"" XBEHNAME=$G(^DIC(9.4,XBEHNAME,0)) + . S:XBEHNAME]"" XBEHNAME=$P(XBEHNAME,U) + . D VCHK(XBEHNS,XBEHVER,XBEHNAME) + . D RSLT("") + . Q + ; + D RXCK + D RSLT(""),RSLT("ENVIRONMENT "_$S(XBEHOK:"",1:"-NOT- ")_"OK.") + I 'XBEHOK D + . D RSLT("INSTALL THE FOLLOWING PACKAGES AND PATCHES:") + . S XBEHNEED="" + . F S XBEHNEED=$O(XBEHNEED(XBEHNEED)) Q:'$L(XBEHNEED) D RSLT(XBEHNEED) + .Q + ; + D POST + ; + Q +RXCK ; + ; + N PS S PS=$P($G(^PS(59.7,1,80)),U,2) + I 'PS D + . S XBEHMSG="The Pharmacy Data Management package must be installed, and the Orderable Item Auto Create run to completion." + . D RSLT(XBEHMSG) + . S XBEHNEED("Pharmacy Data Management")="" + I PS=1 D + . S XBEHMSG="The Orderable Item Auto Create in Pharmacy Data Management package must be run to completion." + . D RSLT(XBEHMSG) + . S XBEHNEED("Pharmacy Data Management Orderable Item Auto Create")="" + I PS=2 D + . S XBEHMSG="The Manual Matching Process for Orderable Items in Pharmacy Data Management package has not been completed." + . D RSLT(XBEHMSG) + . S XBEHNEED("Pharmacy Data Management Manual Matching Process must be completed.")="" + I $P($G(^PS(59.7,1,80)),"^",3)'=3 D + . S XBEHMSG="Pharmacy Dosage Conversion is not complete." + . D RSLT(XBEHMSG) + . S XBEHNEED("Pharmacy Dosage Conversion must be completed.")="" + Q + ; +VCHK(XBEHPRE,XBEHVER,XBEHNAME) ; ----------------------------------------------------- + ; Check versions needed. + ; Modifies XBEHNEED + ; + NEW XBEHV,XBEHMSG + I XBEHNAME'=XBEHPKG D + . D RSLT("") + . S XBEHPKG=XBEHNAME + . S XBEHV=$$VERSION^XPDUTL(XBEHPRE) + . S XBEHMSG=XBEHNAME_$S(XBEHNAME]"":":",1:"")_" Need at least "_XBEHPRE_" v "_XBEHVER + . I +XBEHV S XBEHMSG=XBEHMSG_"....."_XBEHPRE_" v "_XBEHV_" is installed." + . E S XBEHMSG=XBEHMSG_"....."_XBEHPRE_" is not installed." + . D RSLT(XBEHMSG) + . I XBEHV0 + Q:'$D(^DIC(9.4,"C",X)) + D RSLT(" You Have More Than One Entry In The") + D RSLT(" PACKAGE File with an "_X_" prefix.") + D RSLT(" One entry needs to be deleted.") + Q +POST ; ----------------------------------------------------- + NEW XMSUB,XMDUZ,XMTEXT,XMY + S XMSUB=$P($P($T(+1),";",2)," ",3,99),XMDUZ=$G(DUZ,.5),XMTEXT="^TMP(""XBEHRCK"",$J,",XMY(1)="",XMY(DUZ)="" + D SINGLE("XUPROGMODE") + NEW DIFROM + D ^XMD + KILL ^TMP("XBEHRCK",$J) + D RSLT("") + D RSLT("The results are in your MailMan 'IN' basket.") + Q + ; ----------------------------------------------------- +SINGLE(K) ; Get holders of a single key K. + NEW Y + S Y=0 + Q:'$D(^XUSEC(K)) + F S Y=$O(^XUSEC(K,Y)) Q:'Y S XMY(Y)="" + Q + ; ----------------------------------------------------- +RSLT(%) ;S ^(0)=$G(^TMP("XBEHRCK",$J,0))+1,^(^(0))=% + ;More readable: + S ^TMP("XBEHRCK",$J,0)=$G(^TMP("XBEHRCK",$J,0))+1 + S ^TMP("XBEHRCK",$J,^TMP("XBEHRCK",$J,0))=% + W !,% + Q + ; +ASKDEV ;EP + K IOP + S %ZIS="NQ" D ^%ZIS Q:POP + S IOP=ION + S %ZIS("IOPAR")=IOPAR + I $D(IO("Q")) D QUE I '$D(ZTQUEUED) K IOP G ASKDEV + I $D(IO("Q")) D HOME^%ZIS W !,"REPORT IS QUEUED!" + Q + ; +QUE ; + S ZTRTN="ZTM^XBEHRCK",ZTDESC="EHR ENVIRONMENT CHECK" + S ZTSAVE("IOP")="" + D ^%ZTLOAD + Q diff --git a/XBENHANC.m b/XBENHANC.m new file mode 100644 index 0000000..cc569f7 --- /dev/null +++ b/XBENHANC.m @@ -0,0 +1,58 @@ +XBENHANC ; IHS/ADC/GTH - DISPLAY/PRINT ENHANCEMENTS FIELD IN PACKAGE FILE ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; Print enhancements to a package, from the entry in the + ; PACKAGE file. Entry point EN^XBENHANC(ns) is used, with + ; the caller providing the namespace of the package. + ; +EN(XB) ;PEP - XB = Namespace of package to print enhancements. + Q:'($G(XB)]"") + 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 + KILL 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 ; + KILL 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") + KILL ^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 + KILL ^UTILITY($J,"W") + D ^%ZISC + Q + ; +DIWP(X) ; + NEW %,A,B + D ^DIWP + Q + ; +TOF ; + NEW %,A,B + S XBPG=$G(XBPG)+1 + W !! + I '$D(ZTQUEUED),'$D(IO("S")),IO=IO(0),$$DIR^XBDIR("E") + Q:$D(DIRUT) + W @IOF,!!,?DIWL-1,XBHDR,?(DIWR-$L("Page "_XBPG)-1),"Page ",XBPG,!?DIWL-1,$$REPEAT^XLFSTR("-",DIWR-DIWL),!! + Q + ; diff --git a/XBFCMP.m b/XBFCMP.m new file mode 100644 index 0000000..e5ed76c --- /dev/null +++ b/XBFCMP.m @@ -0,0 +1,132 @@ +XBFCMP ; IHS/ADC/GTH - COMPARES FILEMAN FILES IN TWO UCIs ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods. + ; + ; Ignores the following: + ; ^DD(file,0,"PT", + ; ^DD(file,field,1,0) + ; ^DD(file,field,21 + ; ^DD(file,field,"DT" + ; + ; If a field does not exist in one file, a message is + ; displayed and all sub-nodes of that field are ignored. + ; + ; If the compare is limited to fields containing a + ; particular GROUP, the second pass, which checks for + ; entries in the secondary UCI not in the primary UCI, is + ; not executed. On the first pass the GROUP multiple in the + ; secondary UCI is ignored. + ; +START ; + NEW XBWHERE S XBWHERE=$S($$VERSION^%ZOSV(1)["Cache":"Namespace",1:"UCI") ;IHS/SET/GTH XB*3*9 10/29/2002 + NEW GROUP + ; W !,"This program compares FileMan files in two different UCIs." ;IHS/SET/GTH XB*3*9 10/29/2002 + W !,"This program compares FileMan files in two different ",XBWHERE,"s." ;IHS/SET/GTH XB*3*9 10/29/2002 + S U="^" + X ^%ZOSF("UCI") + S XBFCMPU1=$P(Y,",",1) + ;W !!,"Primary UCI is ",XBFCMPU1 ;IHS/SET/GTH XB*3*9 10/29/2002 + W !!,"Primary ",XBWHERE," is ",XBFCMPU1 ;IHS/SET/GTH XB*3*9 10/29/2002 + D GET2ND + I XBFCMPU2="" W !!,"Bye",! D EOJ Q + D ^XBDSET + I '$D(^UTILITY("XBDSET",$J)) W !!,"No files selected",! D EOJ Q + R !!,"Only check fields with GROUP: ",GROUP:$G(DTIME,999) + I GROUP="" KILL GROUP + S XBFCMPFL="" + F XBFCMPL=0:0 S XBFCMPFL=$O(^UTILITY("XBDSET",$J,XBFCMPFL)) Q:XBFCMPFL'=+XBFCMPFL D XBFCMPFL + D EOJ + Q + ; +XBFCMPFL ; + W !!,XBFCMPFL,! + F XBFCMPG="DIC","DD" D COMPARE + S XBCDFILE=XBFCMPFL + D SBTRACE + S XBFCMPFL=XBCDFILE + Q + ; +COMPARE ; + S XBFCMPP="^["""_XBFCMPU1_"""]"_XBFCMPG_"("_XBFCMPFL_","_$S(XBFCMPG="DIC":"0,",1:"") + S XBFCMPS="^["""_XBFCMPU2_"""]"_XBFCMPG_"("_XBFCMPFL_","_$S(XBFCMPG="DIC":"0,",1:"") + ;I '$D(@($E(XBFCMPS,1,$L(XBFCMPS)-1)_")")) W " File not in ^",XBFCMPG," of secondary UCI" Q ;IHS/SET/GTH XB*3*9 10/29/2002 + I '$D(@($E(XBFCMPS,1,$L(XBFCMPS)-1)_")")) W " File not in ^",XBFCMPG," of secondary ",XBWHERE Q ;IHS/SET/GTH XB*3*9 10/29/2002 + S XBGP=XBFCMPP,XBGS=XBFCMPS,XBGPASS=1 + D XBGCMP + S XBGP=XBFCMPS,XBGS=XBFCMPP,XBGPASS=2 + D XBGCMP + Q + ; +SBTRACE ; CHECK ALL SUB-FILES + KILL XBCDSFL + S XBCDC=1,XBCDSFL="",XBCDSFL(XBCDC)=XBCDFILE + F XBCDL=0:0 S XBCDI=$O(XBCDSFL("")) Q:XBCDI="" S XBCDSF=XBCDSFL(XBCDI) D SBTRACE2 S XBCDI=$O(XBCDSFL("")) W "." KILL XBCDSFL(XBCDI) + KILL XBCDC,XBCDI,XBCDSF,XBCDSFL,XBCDY,XBCDZ + Q + ; +SBTRACE2 ; + S XBCDI=0 + F XBCDL=0:0 S XBCDI=$O(^DD(XBCDSF,"SB",XBCDI)) Q:XBCDI="" W "." S XBCDC=XBCDC+1,XBCDSFL(XBCDC)=XBCDI D SBTRACE3 + Q + ; +SBTRACE3 ; + W !!,XBCDI,! + S XBFCMPG="DD",XBFCMPFL=XBCDI + D COMPARE + Q + ; +GET2ND ; GET SECONDARY UCI + S XBFCMPU2="" + ;R !!,"Secondary UCI: ",X:$G(DTIME,999) ;IHS/SET/GTH XB*3*9 10/29/2002 + W !!,"Secondary ",XBWHERE,": " R X:$G(DTIME,999) ;IHS/SET/GTH XB*3*9 10/29/2002 + Q:X=""!(X="^") + S XBFCMPU2=X + Q + ; +EOJ ; + KILL C,I,GDFN,GROOT,L,NOGROUP,NT,P,T,T1,T2,T3,T4,T5,T6,TT,ZZ + KILL XBCDFILE,XBCDL + KILL %UCI,%UCN,XBFCMPFL,XBFCMPG,XBFCMPL,XBFCMPP,XBFCMPS,XBFCMPU1,XBFCMPU2,X,Y + Q + ; +XBGCMP ; COMPARES GLOBAL TREES + I $D(GROUP),XBFCMPG="DD",XBGPASS=2 Q + D SEARCH + KILL XBGP,XBGS,XBGPASS + Q + ; +SEARCH ; + S T="T",C=",",P=")",NT=$L(XBGP,C)-1,L=1,T1="" + S TT=XBGP + F I=1:1:30 S TT=TT_T_I_C +EXTR ; + S X=T_L,Y=$P(TT,C,1,L+NT)_P,@X=$O(@Y) + I @X]"" D:$D(@(Y))#2 SUB S L=L+1,@(T_L)="" G EXTR + S L=L-1 + Q:L=0 + G EXTR + ; +SUB ; + W "." + S ZZ=XBGS_$P(Y,XBGP,2) + I $D(@Y) + Q:$P($$MSMZR^ZIBNSSV,"DD(",2)?.".".N.".".N1",0,""PT""".E + Q:$P($$MSMZR^ZIBNSSV,"DD(",2)?.".".N.".".N1",".".".N.".".N1",21,".E + Q:$P($$MSMZR^ZIBNSSV,"DD(",2)?.".".N.".".N1",".".".N.".".N1",""DT""".E + Q:$P($$MSMZR^ZIBNSSV,"DD(",2)?.".".N.".".N1",".".".N.".".N1",1,0)" + I $D(SKIP),SKIP=$E($$MSMZR^ZIBNSSV,1,$L(SKIP)) Q + KILL SKIP + I $D(GROUP),$P($$MSMZR^ZIBNSSV,"DD(",2)?.".".N.".".N1",".".".N.".".N1",0)" D CHKGROUP I NOGROUP S SKIP=$E($$MSMZR^ZIBNSSV,1,$L($$MSMZR^ZIBNSSV)-3) Q + I '$D(@ZZ),$P($$MSMZR^ZIBNSSV,"DD(",2)?.".".N.".".N1",".".".N.".".N1",0)" W !,$$MSMZR^ZIBNSSV," <",$P(@Y,"^",1)," field does not exist>" S SKIP=$E($$MSMZR^ZIBNSSV,1,$L($$MSMZR^ZIBNSSV)-3) Q + I $D(GROUP),$P($$MSMZR^ZIBNSSV,"DD(",2)?.".".N.".".N1",".".".N1",20,".E Q + I '$D(@ZZ) W !,$$MSMZR^ZIBNSSV,"=",@Y," " Q + Q:XBGPASS=2 + I @ZZ'=@Y W !,$$MSMZR^ZIBNSSV," ",!,@ZZ,!,@Y Q + Q + ; +CHKGROUP ; + S GDFN=0,NOGROUP=1,GROOT=$E($$MSMZR^ZIBNSSV,1,$L($$MSMZR^ZIBNSSV)-3) + F GL=0:0 S GDFN=$O(@(GROOT_",20,GDFN)")) Q:GDFN="" I @(GROOT_",20,GDFN,0)")=GROUP S NOGROUP=0 Q + I $D(@Y) + Q + ; diff --git a/XBFDINFO.m b/XBFDINFO.m new file mode 100644 index 0000000..4cf3367 --- /dev/null +++ b/XBFDINFO.m @@ -0,0 +1,55 @@ +XBFDINFO(FILE,FIELD,ROOT) ; IHS/ADC/GTH - RETURN FIELD INFORMATION ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; ATTENTION PROGRAMMERS: Use line label FLD() for entry. + ; Do not use the first line for entry. + ; + ; Given a file/subfile number, a field number, and an array + ; root, this routine will return information about the + ; specified field. The information will be returned as + ; subscripted variables from the root passed by the caller. + ; + ; The field information returned will be a subset of the + ; following: + ; + ; ROOT("NAME") = name of field + ; ROOT("NODE") = node in data global + ; ROOT("PIECE") = piece in node + ; ROOT("TYPE") = FileMan field type or "M" for multiple, + ; or "C" for computed + ; ROOT("SFILE") = subfile number if the field is a multiple + ; ROOT("PFILE") = file number of pointed to file + ; ROOT("PGBL") = gbl of pointed to file + ; ROOT("DINUM") = existance indicates DINUM pointer + ; + ; ROOT("VPFILE",file) = variable pointer prefix. 'file' is + ; pointed to file + ; ROOT("VPGBL",file) = variable pointer gbl of pointed to + ; file. 'file' is pointed to file + ; + ; Formal list: + ; + ; 1) FILE = file/subfile number (call by value) + ; 2) FIELD = field number (call by value) + ; 3) ROOT = array root (call by reference) + ; +START ; + KILL ROOT + NEW W,X,Y,Z + Q:FILE'=+FILE + Q:FIELD'=+FIELD + Q:'$D(^DD(FILE,FIELD,0)) S X=^(0) + S ROOT("NAME")=$P(X,"^",1) + I $P(X,"^",2)["C" S ROOT("TYPE")="C" Q + S ROOT("NODE")=$S(FIELD=.001:"",1:$P($P(X,"^",4),";",1)) + S ROOT("PIECE")=$S(FIELD=.001:"",1:$P($P(X,"^",4),";",2)) + S Y=$P(X,"^",2) + S ROOT("TYPE")=$S(Y["F":"F",Y["C":"C",Y["D":"D",Y["K":"K",Y["N":"N",Y["P":"P",Y["S":"S",Y["V":"V",Y["K":"K",Y["W":"W",1:"?") + I +$P(X,"^",2) S ROOT("SFILE")=+$P(X,"^",2),ROOT("TYPE")="M" I 1 + E S:Y["P" ROOT("PFILE")=+$P(Y,"P",2),ROOT("PGBL")=$P(X,"^",3),@($S($P(X,"^",5,99)["DINUM"&(FIELD=.01):"ROOT(""DINUM"")",1:"Z"))="" + I Y["V" F Z=0:0 S Z=$O(^DD(FILE,FIELD,"V","B",Z)) Q:Z'=+Z S W=$O(^(Z,"")),ROOT("VPFILE",Z)=$P(^DD(FILE,FIELD,"V",W,0),"^",4),ROOT("VPGBL",Z)=^DIC(Z,0,"GL") + Q + ; +FLD(FILE,FIELD,ROOT) ;PEP - Return information about a field. + G START + ; diff --git a/XBFIXL1.m b/XBFIXL1.m new file mode 100644 index 0000000..dc6850a --- /dev/null +++ b/XBFIXL1.m @@ -0,0 +1,92 @@ +XBFIXL1 ; IHS/ADC/GTH - STANDARDIZE LINE 1 OF SELECTED ROUTINES ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods. + ; + ; This routine asks user 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 + D ^XBKTMP,^XBKVAR + X ^%ZOSF("RSEL") + I $D(^UTILITY($J,"XBFIXL1")) W !,"^XBFIXL1 cannot modify itself. Ignored." KILL ^UTILITY($J,"XBFIXL1") + G:$O(^UTILITY($J,""))="" EOJ + S XBPI=$$DIR^XBDIR("F^9:20","Enter agency/site/programmer","","","E.G IHS/OHPRD/ACC") + G:$D(DIRUT) EOJ + ;S XBRTN="";IHS/SET/GTH XB*3*9 10/29/2002 + S XBRTN=0 ;IHS/SET/GTH XB*3*9 10/29/2002 + F S XBRTN=$O(^UTILITY($J,XBRTN)) Q:XBRTN="" D CHECK Q:QUIT + G EOJ + ; +CHECK ; + KILL ^TMP("XBFIXL1",$J) + S DIF="^TMP(""XBFIXL1"",$J,",XCNP=0,X=XBRTN + X ^%ZOSF("LOAD") + S XBL1=^TMP("XBFIXL1",$J,1,0) + 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 + I XBL1]"" S ^TMP("XBFIXL1",$J,1,0)=XBL1,DIE=DIF,XCN=0,X=XBRTN X ^%ZOSF("SAVE") + 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 ; Ask user to verify mod. + W !!,XBRTN,!," from: ",XBSAVE,!," to: ",XBL1 + S Y=$$DIR^XBDIR("S^A:Accept;R:Replace;S:Skip","","A","","Accept the proposed modification; Replace the proposal with your own line; Skip the routine") + S:$D(DIRUT) QUIT=1 + S:Y="S" XBL1="" + Q + ; +FIX ; Get comment from user. + S X=$$DIR^XBDIR("F^5:40","Enter comment to follow agency/site/programmer ") + S:$D(DIRUT) QUIT=1 + S $P(XBL1,";",2)=XBPI_" - "_X + Q + ; +EOJ ; + D ^XBKTMP + KILL DIF,XCNP,DIE,XCN + KILL %,X,Y,^UTILITY($J) + KILL DTOUT,DUOUT,DIRUT,DIROUT + KILL XBDATE,XBL1,XBLDJ,XBLDT,XBLP,XBLTM,XBNP,XBPAT,XBPI,XBRTN,XBSAVE,XBTAG + Q + ; diff --git a/XBFIXPT.m b/XBFIXPT.m new file mode 100644 index 0000000..46f9b24 --- /dev/null +++ b/XBFIXPT.m @@ -0,0 +1,63 @@ +XBFIXPT ; IHS/ADC/GTH - FIX ALL "PT" NODES ; [ 11/04/97 10:26 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent UNDEF if ^DD entry incorrect. + ; + ; This routine fixes all "PT" nodes for files 1 through the + ; highest file number in the current UCI. + ; +START ; + W:'$D(XBFIXPT("NOTALK")) !!,"This routine insures the ""PT"" node of each FileMan file is correct.",! + W:'$D(XBFIXPT("NOTALK")) !!,"Now checking false positives.",! + S U="^" + S XBFFILE=.99999999 + F XBFL=0:0 S XBFFILE=$O(^DD(XBFFILE)) Q:XBFFILE'=+XBFFILE I $D(^DD(XBFFILE,0,"PT")) W:'$D(XBFIXPT("NOTALK")) !,XBFFILE D FPOS + W:'$D(XBFIXPT("NOTALK")) !!,"Now checking false negatives.",! + D FNEG + KILL XBFFILE,XBFL + W:'$D(XBFIXPT("NOTALK")) !!,"DONE",! + Q + ; +FPOS ; CHECK FOR FALSE POSITIVES + S XBFPFILE="" + F XBFL=0:0 S XBFPFILE=$O(^DD(XBFFILE,0,"PT",XBFPFILE)) Q:XBFPFILE="" S XBFPFLD="" F XBFL=0:0 S XBFPFLD=$O(^DD(XBFFILE,0,"PT",XBFPFILE,XBFPFLD)) Q:XBFPFLD="" D CHKIT + KILL XBFPFILE,XBFPFLD,XBFX + Q + ; +CHKIT ; + W:'$D(XBFIXPT("NOTALK")) "." + I '$D(^DD(XBFPFILE)) W:'$D(XBFIXPT("NOTALK")) "|" KILL ^DD(XBFFILE,0,"PT",XBFPFILE) Q + ; I '$D(^DD(XBFPFILE,XBFPFLD)) W:'$D(XBFIXPT("NOTALK")) "|" KILL ^DD(XBFFILE,0,"PT",XBFPFILE,XBFPFLD) Q ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent UNDEF if ^DD entry incorrect. + I '$D(^DD(XBFPFILE,XBFPFLD,0)) W:'$D(XBFIXPT("NOTALK")) "|" KILL ^DD(XBFFILE,0,"PT",XBFPFILE,XBFPFLD) Q ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent UNDEF if ^DD entry incorrect. + S XBFX=$P(^DD(XBFPFILE,XBFPFLD,0),U,2) + I XBFX["P",XBFX[XBFFILE Q + I XBFX["V",$D(^DD(XBFPFILE,XBFPFLD,"V","B",XBFFILE)) Q + W:'$D(XBFIXPT("NOTALK")) "|" + KILL ^DD(XBFFILE,0,"PT",XBFPFILE,XBFPFLD) + Q + ; +FNEG ; CHECK FOR FALSE NEGATIVES + S XBFFILE=.99999999 + F XBFL=0:0 S XBFFILE=$O(^DD(XBFFILE)) Q:XBFFILE'=+XBFFILE W:'$D(XBFIXPT("NOTALK")) !,XBFFILE S XBFFLD=0 F XBFL=0:0 S XBFFLD=$O(^DD(XBFFILE,XBFFLD)) Q:XBFFLD'=+XBFFLD D:$D(^(XBFFLD,0))#2 PTRCHK + KILL XBFFILE,XBFFLD,XBFX,XBFI + Q + ; +PTRCHK ; + S XBFX=$P(^DD(XBFFILE,XBFFLD,0),U,2) + I XBFX["V" D PTRCHK2 Q + Q:XBFX'["P" + F XBFI=1:1:$L(XBFX)+1 Q:$E(XBFX,XBFI)?1N + Q:XBFI>$L(XBFX) + S XBFX=$E(XBFX,XBFI,999),XBFX=+XBFX + Q:'XBFX + Q:XBFX<1 ;*** DOES NOT MESS WITH FILE NUMBERS < 1 *** + W:'$D(XBFIXPT("NOTALK")) "." + Q:'$D(^DIC(XBFX)) + Q:'$D(^DD(XBFX,0)) + I '$D(^DD(XBFX,0,"PT",XBFFILE,XBFFLD)) W "|" S ^(XBFFLD)="" + Q + ; +PTRCHK2 ; VARIABLE POINTER CHECK + S XBFX="" + F XBFL=0:0 S XBFX=$O(^DD(XBFFILE,XBFFLD,"V","B",XBFX)) Q:XBFX="" I '$D(^DD(XBFX,0,"PT",XBFFILE,XBFFLD)) W:'$D(XBFIXPT("NOTALK")) "|" S ^(XBFFLD)="" + Q + ; diff --git a/XBFLD.m b/XBFLD.m new file mode 100644 index 0000000..cdd0494 --- /dev/null +++ b/XBFLD.m @@ -0,0 +1,191 @@ +XBFLD ; IHS/ADC/GTH - DICTIONARY LISTING ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; 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 KILL 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 KILL 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 + ; diff --git a/XBFLD0.m b/XBFLD0.m new file mode 100644 index 0000000..43796d9 --- /dev/null +++ b/XBFLD0.m @@ -0,0 +1,35 @@ +XBFLD0 ; IHS/ADC/GTH - PRINT FIELD TRIGGERS ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; +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 + ; diff --git a/XBFLD2.m b/XBFLD2.m new file mode 100644 index 0000000..3129ca4 --- /dev/null +++ b/XBFLD2.m @@ -0,0 +1,45 @@ +XBFLD2 ; IHS/ADC/GTH - INITIALIZATION FOR ^XBFLD ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; 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 + KILL ^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) +XBLM ; + S Y=$$DIR^XBDIR("S^P:PRINT Output;B:BROWSE Output on Screen","Do you wish to ","P","","","",1) + KILL 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 +XBLME .Q + S %ZIS="Q" + D ^%ZIS + I POP S XBQFLG=1 KILL 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 + . KILL ZTSK,IO("Q") + . KILL ZTIO ; ^%ZTLOAD kills other ZT* variables, but not this one + .Q + U IO + Q + ; diff --git a/XBFLDO.m b/XBFLDO.m new file mode 100644 index 0000000..b944e1d --- /dev/null +++ b/XBFLDO.m @@ -0,0 +1,156 @@ +XBFLD ; DICTIONARY LISTING [ 02/15/95 12:25 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; 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 QFLG + W !,"^XBFLD - This routine lists FileMan dictionaries." + F D INIT Q:QFLG D LIST W ! X ^%ZIS("C") Q:QFLG + Q + ; +LIST ; LIST RANGE OF FILES + NEW COMP,FILE,FLD,LF,NAME,PC,PG,PSUB,PSUBOLD,SUBFILE,SUB,TAB,TYPE,WPC,WPSUB + S QFLG=0 + F FILE=0:0 S FILE=$O(^UTILITY("XBDSET",$J,FILE)) Q:FILE="" D FILE Q:QFLG + Q + ; +FILE ; LIST ONE FILE + S (COMP,LF,PG,TAB)=0,SUB="D0,",PSUBOLD="" + D HEADING + D FIELDS + Q:QFLG + D PAUSE + Q + ; +FIELDS ; LIST ALL FIELDS IN ONE FILE/SUBFILE (CALLED RECURSIVELY) + F FLD=0:0 S FLD=$O(^DD(FILE,FLD)) Q:FLD'=+FLD D FIELD Q:QFLG + Q + ; +FIELD ; LIST ONE FIELD + S (NAME,PC,PSUB,TYPE)="" + S X=^DD(FILE,FLD,0) + S NAME=$P(X,U,1) + S Y=$P(X,U,2) + S TYPE=$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 TYPE="C" D COMPUTED Q + I COMP S COMP=0 D WRITELF ; Extra lf after computed fields + I TYPE="" D MULTIPLE Q + S Y=$P(X,U,4) + S PSUB=SUB_$S($P(Y,";",1)=+$P(Y,";",1):$P(Y,";",1),1:""""_$P(Y,";",1)_"""") + S PC=$S(TYPE="K":" ",1:$P(Y,";",2)) ; MUMPS field has no piece + D WRITE + Q + ; +COMPUTED ; COMPUTED FIELD + ; The variable COMP prevents multiple lfs between adjacent + ; computed fields. + ; + D:'COMP WRITELF + S PSUB="COMPUTED",TYPE="",COMP=1 + S PSUB=PSUB_$S(Y["B":" (BOOLEAN)",Y["D":" (DATE)",1:"") + D WRITE + Q + ; +MULTIPLE ; LIST MULTIPLE, THEN FIELDS IN SUBFILE + S NAME=NAME_" ("_+Y_")",SUBFILE=+Y + D WRITELF,WRITE + Q:QFLG + NEW FILE,FLD,SUB + S FILE=SUBFILE + D ^XBSFGBL(FILE,.SUB,2) S SUB="D0"_$P(SUB,"D0",2),SUB=$P(SUB,")",1) + S TAB=TAB+2 + D FIELDS ; Recurse + S TAB=TAB-2 + Q:QFLG + D WRITELF + Q + ; +WRITE ; WRITE ONE LINE + S LF=0 + D PAGE:$Y>(IOSL-3) + Q:QFLG + S WPSUB=$S(FLD=.001:"",PSUB]""&(PSUB=PSUBOLD):" """,1:PSUB) + S WPC=$S(PC:$J(PC,5,0),1:PC) ;S:$E(WPC)="E" WPC=$E(" ",1,7-$L(WPC))_WPC + W !,?TAB,FLD,?13+TAB,$S(TYPE="":NAME,1:$E(NAME,1,31-TAB)),?46,$E(WPSUB,1,21),?68,WPC,?77,TYPE + I TYPE'="" I $L(NAME)>(31-TAB)!($L(WPSUB)>25) W !,?13+TAB,$E(NAME,32-TAB,$L(NAME)),?46,$E(WPSUB,22,$L(WPSUB)) + ;S S="" S:TAB $P(S," ",TAB)=" " + ;W !,S_FLD,?13,S_NAME,?42,$S(FLD=.001:"",PSUB]""&(PSUB=PSUBOLD):" """,1:PSUB),?70,$S(PC:$J(PC,2,0),1:""),?77,TYPE + S PSUBOLD=PSUB + Q + ; +WRITELF ; WRITE ONE LINE FEED + ; The variable LF prevents multiple lfs when backing out of + ; deep recursion. + ; + Q:LF + I $Y>2,$Y'>(IOSL-3) W ! S LF=1 + Q + ; +HEADING ; DICTIONARY HEADERS + NEW HR,MIN,TITLE,TM,TME,UCI + S PG=1 + W @IOF + D HEADING2 + W ?80-$L("FILE: "_$P(^DIC(FILE,0),"^",1))\2,"FILE: ",$P(^DIC(FILE,0),"^",1),!,?80-$L("GLOBAL: "_^DIC(FILE,0,"GL"))\2,"GLOBAL: ",^DIC(FILE,0,"GL"),!,?80-$L("FILE #: "_FILE)\2,"FILE #: ",FILE,!! + D PAGE + Q + ; +HEADING2 ; HARD COPY HEADERS + I IO=IO(0),$E(IOST,1,2)="C-" Q + S TITLE="I.H.S. DICTIONARY FIELDS",TM=$P($H,",",2),HR=TM\3600,MIN=TM#3600\60 S:MIN<10 MIN="0"_MIN S TME=HR_":"_MIN + W TME,?80-$L(TITLE)\2,TITLE,?72,"page ",PG,!,?80-$L(^DD("SITE"))\2,^DD("SITE"),! + X ^%ZOSF("UCI") S UCI="UCI: "_$P(Y,",",1) W ?80-$L(UCI)\2,UCI + 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 ; PAGE HEADERS + D:PG>1 PAUSE + Q:QFLG + I PG>1 W:$D(IOF) @IOF + S PG=PG+1 + S X="",$P(X,"=",79)="=" W "FIELD #",?13,"FIELD NAME",?46,"SUBSCRIPT",?69,"PIECE",?75,"TYPE",!,X,! S X="" + S PSUBOLD="" + Q + ; +PAUSE ; GIVE USER A CHANCE TO SEE LAST PAGE AND QUIT + I IO=IO(0),$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR S:$D(DIRUT)!($D(DUOUT)) QFLG=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 + ; +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 QFLG + I $D(IO)#2,$D(IO(0))#2,$D(IOF)#2,$D(IOSL)#2 D LIST + D EOJ + Q + ; +EOJ ; END OF JOB + K XBFLDP + K ^UTILITY("XBDSET",$J) + K DIR,DIRUT,DTOUT,DUOUT,POP,S,X,Y + I $D(ZTQUEUED) S ZTREQ="@" Q + I $D(ZTSK),ZTSK K ^%ZTSK(ZTSK) ; ***** For old Kernel ***** + Q diff --git a/XBFMK.m b/XBFMK.m new file mode 100644 index 0000000..3fb35e7 --- /dev/null +++ b/XBFMK.m @@ -0,0 +1,11 @@ +XBFMK ; IHS/ADC/GTH - KILL FILEMAN VARIABLES ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; This routine kills variables left around by FileMan. + ; + KILL %,%1,%DEVTYPE,%DT,%GSREF,%H,%K,%RCR,%ST,%T,%W,%X,%XUCI,%Y,%ZISOS + KILL A,C,I,J,L,S,UT,X,Y,Z + 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 + KILL DIRUT,DTOUT,DUOUT + Q + ; diff --git a/XBFNC.m b/XBFNC.m new file mode 100644 index 0000000..d0c181f --- /dev/null +++ b/XBFNC.m @@ -0,0 +1,131 @@ +XBFNC ;IHS/SET/GTH - Field Numbering Conventions ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 + ; + ; Given an input of files, check the fields in the files + ; for conformance to the SAC field numbering conventions. + ; + ; Can also print conventions. + ; +Q ; F = File + ; H = Header + ; I = Field + ; N = Node + ; P = Piece + ; + W !,"FileMan Field Numbering Conventions",! + D FNC,^XBDSET + Q:'$D(^UTILITY("XBDSET",$J)) + NEW F + S F=0 + F S F=$O(^UTILITY("XBDSET",$J,F)) Q:'F D FILE(F) + Q + ; +FILE(F) ; + NEW I,H,N,P + S I=0 + F S I=$O(^DD(F,I)) Q:'I I '($P(^(I,0),U,2)["C") D + . S H=0 + . I +$P(^DD(F,I,0),U,2) D Q + .. I $L(I)'=4 D ERR(1) + .. D FILE(+$P(^DD(F,I,0),U,2)) + ..Q + . S N=$P($P(^DD(F,I,0),U,4),";",1),P=$P($P(^(0),U,4),";",2) + . I N=0 D Q + .. I $E(I)'="." D ERR(2) + .. I P'=+$P(I,".",2)!(+$P(I,".")) D ERR(3) + .. I P=10 D ERR(4) + ..Q + . I $E(I)="." D ERR(5) + . I +N,N'=+$E(I,1,$L(N)) D ERR(6) + . I +N,P'=+$E(I,$L(N)+1,99) D ERR(7) + . I 'N,P'=I D ERR(8) + .Q + Q + ; +ERR(E) ; + W:'H !," ",F," (",$O(^DD(F,0,"NM","")),"), ",I," (",$P(^DD(F,I,0),U,1),"), global location ",$P(^(0),U,4),$S(+P:"",1:"(Multiple)") + S H=1 + W !?5,$P($T(@E),";",3),"." + Q + ; +1 ;;Field number of multiple field is not 4 digits +2 ;;Field number in 0th node should begin with '.' +3 ;;Piece number in 0th node should = +$P(fld#,".",2) +4 ;;Piece 10 of 0th node should be null +5 ;;Field begins with '.' and not in 0th node +6 ;;Field number does not begin with node location +7 ;;Piece number does not match non-nodal part of field number +8 ;;Field number and piece number do not match + ; +FNC ; + Q:'$$DIR^XBDIR("Y","Print conventions","N") + D ^%ZIS + Q:POP + U IO + D HELP^XBHELP("TXT","XBFNC",0),^%ZISC + Q + ; +TXT ; + ;; + ;; ------------------------------- + ;; DATA DICTIONARY FIELD NUMBERING + ;; AND DATA PLACEMENT CONVENTIONS + ;; ------------------------------- + ;; + ;;The following conventions for numbering fields, and placing data in pieces, is + ;;extracted from a mail message dated 25 Feb 88, and is considered to be those + ;;conventions referred to in the Programming Standards And Conventions paragraph + ;;which states "Field numbers for FileMan files will be assigned in accordance + ;;with established conventions." + ;; + ;; = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = + ;; + ;;1) There is a direct correlation between the field number and the node and + ;;piece, and for multiples, between the field number and the sub-file number. + ;; + ;;2) Fields beginning with a "." are all .01-.n and are in the 0th node. Where + ;;possible, files only have a 0th node. This reduces the number of disc accesses + ;;required. A field number must be canonic, therefore, there is no .10 field. + ;;It goes from .09 to .11. That means piece 10 will always be NULL. + ;; + ;;3) Where the entire entry cannot be put in one node, there are more nodes, + ;;generally grouped by logically related fields into field numbers within some + ;;range, say 1101-1116. These would be node 11 piece 1-16, and in this case + ;;piece 10 is allowed because it is canonic. + ;; + ;;4) Multiple fields are always 4 digits. The first two digits are the next + ;;higher group, using the example above, 11 would be the next higher group. The + ;;second two digits are always 00. The subscript for that multiple is always the + ;;first two digits of the multi-valued field number. 11 in this case. The + ;;sub-file number is always the parent file number with the first two digits of + ;;the multi-valued field number appended. If we were in file 9000001 in the + ;;above example, the sub-file for field 1100 would be 9000001.11, and the + ;;subscript would be 11. Now, if we added a multiple to that sub-file, as say + ;;field number 1500, its sub-file would be 9000001.1115 and its subscript would + ;;be 15. In the data global it would look like ^AUPNPAT(DA(1),11,DA,15,0). The + ;;assigning of sub-file numbers is important, because if you let FileMan do it, + ;;he will assign numbers that may fall within the number space of primary files + ;;using our file number assigning logic. + ;; + ;;5) There are special cases that do not follow the rules, of course. On most + ;;of the pointed to files, we have added a field number 9901 MNEMONIC which is + ;;used on a site by site basis if you have a very high percentage of your lookups + ;;to two or three entries, you can add data to the MNEMONIC field, say 1, 2, and + ;;3, and instead of responding CLAREMORE to a LOCATION lookup, you can respond 1. + ;;This field is in node 88 piece 1. It is 8801 so the MNEMONIC field would be + ;;the same number in all dictionaries, regardless of how many fields, and field + ;;numbers, a particular file had already. + ;; + ;;6) Computed fields, where ever possible, immediately follow the field from + ;;which they are computed, and the computed field number is the same as the real + ;;field followed by a 9. If the field above was .12 the computed field would be + ;;.129. If you wanted more than one computed field off of .12 they would be + ;;.1291 and .1292. + ;; + ;;7) There is another class of computed field. That is a computed field that + ;;points back to the VA PATIENT file. Those fields have a .2 following the field + ;;number. That indicates it is not really a computed field, but just a pointer + ;;back to the VA PATIENT file. + ;; + ;;******************************************** diff --git a/XBFORM.m b/XBFORM.m new file mode 100644 index 0000000..a935d19 --- /dev/null +++ b/XBFORM.m @@ -0,0 +1,202 @@ +XBFORM ; IHS/ADC/GTH - BUILD ARRAY FROM WP FORMAT ; [ 07/08/1999 3:53 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; Please refer to routine XBFORM0 for documentation. + ; + Q + ; +EDIT(XBFORM,XBWPDIC,XBWPFLD) ;EP Edit a Form +EDIT2 ; + KILL ^TMP($J,"XBFORM",XBFORM) + S XBLLINE=0,XBFMT=1 + I $D(XBLMMRK) S XBLMMARK=XBLMMRK + I '$D(XBLMMARK) S XBLMMARK=$$DIR^XBDIR("Y","MARKERS ","N") + S XBLMMRK=XBLMMARK + D EDITWP,WPGET,BUILD,ZBUILD + ;** add RV markers + I '$D(XBLMMARK) S XBLMMARK=$$DIR^XBDIR("Y","MARKERS ","N") + I $D(DIRUT) D EXIT KILL XBLLINE Q +MARK ; + I $G(XBLMMARK) F XBRVL=5:5 Q:'$D(XBZ(XBRVL)) S:'(XBRVL#10) $E(XBZ(XBRVL,0),80)=$E(XBRVL) + KILL XBRVL + D ARRAY^XBLM("XBZ(",XBFORM),CLEAR^VALM1 + I $$DIR^XBDIR("S^R:Re-Edit;Q:Quit")="R" KILL XBZ G EDIT2 + D EXIT + KILL XBLLINE + Q + ; +GEN(XBFORM,XBWPDIC,XBWPFLD,XBREF,XBFMT,XBLAST) ;EP ** generate array + NEW XBLLINE + S XBLLINE=$G(XBLAST) + I $D(^TMP($J,"XBFORM",XBFORM)) D ZBUILD,REFBUILD,EXIT Q XBLLINE + D WPGET,BUILD,ZBUILD,REFBUILD,EXIT + Q XBLLINE + ; +EDITWP ;** edit WP array + KILL DIE,DIC,DA,DR + S DIC=XBWPDIC,DR=XBWPFLD,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),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 + KILL XBWWP + Q + ; +BUILD ;** scan WP array to build XBL + S XBWPL="",XBLINE=0 + Q:$D(^TMP($J,"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),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 + .Q + KILL XBQUIT + Q + ; +ZBUILD ;** build Z array from XBL + KILL Z + I '$G(XBFMT) F XBL=1:1 D Q:('$O(^TMP($J,"XBFORM",XBFORM,XBL))) + . I '$D(^TMP($J,"XBFORM",XBFORM,XBL)),$O(^TMP($J,"XBFORM",XBFORM,XBL)) S XBZ(XBL+XBLLINE)=" " Q + . D FILL + .Q + I $G(XBFMT)=1 F XBL=1:1 D Q:('$O(^TMP($J,"XBFORM",XBFORM,XBL))) + . I '$D(^TMP($J,"XBFORM",XBFORM,XBL)),$O(^TMP($J,"XBFORM",XBFORM,XBL)) S XBZ(XBL+XBLLINE,0)=" " Q + . D FILL + .Q + 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(^TMP($J,"XBFORM",XBFORM,XBL,XBCOL)) Q:XBCOL'>0 D + . S X=^TMP($J,"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) + .Q + 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),^TMP($J,"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 + S XBT=$E(Z,I+1,W-1) + I XBT="" S XBT="""|""" + S ^TMP($J,"XBFORM",XBFORM,XBLINE,XBCOL+.5)=XBT,I=W + I XBT'["@" D Q + . Q:'$D(XBOUT(XBT)) + . I $E(XBOUT(XBT))=";" S XBOUT(XBT)=$$FMSUB(XBOUT(XBT)) + . S O=XBOUT(XBT),XBT=$$SUB^XBFORM1(XBT,O) + . S ^TMP($J,"XBFORM",XBFORM,XBLINE,XBCOL+.5)=XBT + .Q + S XBV=$P(XBT,"@"),XBV=XBVAR(XBV),XBS=$P(XBT,"@",2) + I $L(XBS) S XBS="("_XBS_")" + S ^TMP($J,"XBFORM",XBFORM,XBLINE,XBCOL+.5)=XBV_XBS + I $D(XBOUT(XBT)) D + . I $E(XBOUT(XBT))=";" S XBOUT(XBT)=$$FMSUB(XBOUT(XBT)) + . S O=XBOUT(XBT),XBT=XBV_XBS,XBT=$$SUB^XBFORM1(XBT,O) + . S ^TMP($J,"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 transform 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,99),XBOUT(XBVSUB)=XBVAL Q + F I=1:1 S P=$P(Z,"|",I) Q:P="" S XBVSUB=$P(P,":"),XBVAL=$P(P,":",2,99),XBOUT(XBVSUB)=XBVAL + Q + ; +TABS ; + S XBF="|....^...." + W # + F I=0:1:7 W ?I*10,I*10 + F L=1:1:66 W !?1,L,?3,"..^...." F X=1:1:7 W XBF + Q + ; +EXIT ; + 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,XBRVL,XBLWP,XBLMMRK + KILL XBLIN,XBLIN0,XBLIN1,XBLINX + Q + ; +MDY(X) ;external date to mm/dd/yy x :: var or ~"NOW"~ or ~"TODAY"~ + S %DT="TS" + D ^%DT + ;begin Y2K fix block + ;S X=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) + S X=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700) ;Y2000 + ;end Y2K fix block + Q X + ; +WP(X) ;build wp entry X #:: WP(FLD,n)=TEXTn + NEW I,W + S XBLWP=$G(XBLLINE),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 + Q "" + ; +FL(X) ; FL fill lines until line X + NEW I,W + S XBLWP=$G(XBLLINE) + Q:((XBLLINE+XBL)'0 D + .S XB(XBI,"M")=0,XB(XBI,0)=XB(XBI) + .I XBP[$E(XBLINX,XB(XBI)-1),XBS[$E(XBLINX,XB(XBI)+XBL) S XB(XBI,"M")=1 + .S XB("B",XB(XBI))=XBI,XB("E",XB(XBI)+XBL-1)=XBI + .S XB(XBI,"E")=XB(XBI)+XBL-1 + .Q + KILL XB(XBI) +CHKMK ; + S XBMK="",XBJM="" + F S XBJM=$O(XB(XBJM)) Q:XBJM="" I $G(XB(XBJM,"M")) S XBMK=1 Q + KILL XBJM +SCANE ; + Q + ; +BLDLIN1 ; + S XBLIN=XBLINX,XBV0="X" + S XBLIN0=XBLIN,XBSUB=XBV0_":"_XBV1,XBLIN1="" + F XBI=1:1 Q:'$D(XB(XBI)) S XBLIN1=XBLIN1_$E(XBLIN,$G(XB(XBI-1,"E"))+1,XB(XBI,0)-1)_$S(XB(XBI,"M"):XBV1,1:XBV0) + S XBI=XBI-1 S XBLIN1=XBLIN1_$E(XBLIN,XB(XBI,"E")+1,999) +BLDLIN1E ; + Q + ; diff --git a/XBFRESET.m b/XBFRESET.m new file mode 100644 index 0000000..29f718f --- /dev/null +++ b/XBFRESET.m @@ -0,0 +1,35 @@ +XBFRESET ; IHS/ADC/GTH - RESET FILE GLOBALS ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; This routine removes all data from FileMan files by + ; saving the 0th node, killing the global, then resetting + ; the 0th node. + ; +START ; + NEW I + W !!,$$REPEAT^XLFSTR("*",78),!,"This routine kills file data globals and resets the 0th nodes. If you are not",!,"absolutely sure of what you are doing, please ^ out at the first opportunity!",!,$$REPEAT^XLFSTR("*",78),!! + F I=1:1:3 W *7,"*** WARNING ***" H 1 W:I'=3 *13,$J("",79),*13 + KILL I + W !!,"Select the files you wish reset." + D ^XBDSET +EN1 ;PEP - Interactive entry, files already selected. + Q:'$D(^UTILITY("XBDSET",$J)) + W !!,"The following files globals will be killed and reset.",! + H 2 + D EN^XBLZRO + Q:'$$DIR^XBDIR("Y","Do you want to continue","NO","","","",1) +EN2 ;PEP - Non-interactive entry, files already selected. + NEW F,G,X,Y + S F="" + F S F=$O(^UTILITY("XBDSET",$J,F)) Q:F="" D + . Q:'$D(^DIC(F,0,"GL")) S G=^("GL") + . S Y=G_"0)" + . S G=$E(G,1,$L(G)-1)_$S($E(G,$L(G))="(":"",1:")") + . W:'$D(ZTQUEUED) "." + . S X=@Y,X=$P(X,"^",1,2)_"^0^0" + . KILL @G + . S @Y=X + . Q + KILL ^UTILITY("XBDSET",$J) + Q + ; diff --git a/XBFUNC.m b/XBFUNC.m new file mode 100644 index 0000000..db7cb8f --- /dev/null +++ b/XBFUNC.m @@ -0,0 +1,114 @@ +XBFUNC ; IHS/ADC/GTH - FUNCTION LIBRARY ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; +FNDPATRN(STR,PAT) ;PEP - Find pattern in string. Return beginning position. + ; + ; E.g.: $$FNDPATRN^XBFUNC("ABC8RX","1A1N") will return 3. + ; + I '$L($G(STR))!('$L($G(PAT))) Q 0 + I STR'?@(".E"_PAT_".E") Q 0 + NEW I,J + S J=0 + F I=1:1:$L(STR) I $E(STR,I,$L(STR))?@(PAT_".E") S J=I Q + Q J + ; +GETPATRN(STR,PAT) ;PEP - Retrieve pattern from string. + ; + ; E.g.: $$GETPATRN^XBFUNC("ABC8RX","1A1N") will return "C8". + ; + I '$L($G(STR))!('$L($G(PAT))) Q "" + NEW I,S + S I=$$FNDPATRN^XBFUNC(STR,PAT) + I 'I Q "" + S S=$E(STR,I,$L(STR)) + F I=1:1 Q:(S="")!(S?@PAT) S S=$E(S,1,$L(S)-1) + Q S + ; +INTSET(FILE,FIELD,EXTVAL) ;PEP - Get Intnl Field Value Given Extnl Field Value + ; For a set of codes type field + ; + ; E.g.: $$INTSET^XBFUNC(9000001,.21,"RETIRED") returns 5. + ; + I '$G(FILE)!('$G(FIELD)) Q "" + I $G(EXTVAL)="" Q "" + I '$D(^DD(FILE,FIELD)) Q "" + S EXTVAL=":"_EXTVAL_";" + I $P(^DD(FILE,FIELD,0),"^",3)'[EXTVAL Q "" + NEW %,%A,%B + S %=$P(^DD(FILE,FIELD,0),"^",3),%A=$P(%,EXTVAL),%B=$L(%A,";") + Q $P(%A,";",%B) + ; +EXTSET(FILE,FIELD,INTVAL) ;PEP - Get Extnl Field Value Given Intnl Field Value + ; For a set of codes type field + ; + ; E.g.: $$EXTSET^XBFUNC(9000001,.21,5) returns "RETIRED". + ; + I '$G(FILE)!('$G(FIELD)) Q "" + I $G(INTVAL)="" Q "" + I '$D(^DD(FILE,FIELD)) Q "" + I $P(^DD(FILE,FIELD,0),"^",3)'[INTVAL Q "" + NEW %,%A + S %=$P(^DD(FILE,FIELD,0),"^",3),%A=$P(%,(INTVAL_":"),2) + Q $P(%A,";") + ; +DECFRAC(X) ;PEP - Convert Decimal to Fraction (X contains Decimal number). + ; + ; E.g.: $$DECFRAC^XBFUNC(.25) returns "1/4". + ; + Q:'$D(X) "" + Q:$E(X)'="." "" + NEW D,N + S N=+$P(X,".",2) + Q:'N "" + S $P(D,"0",$L(+X))="" S D="1"_D + F Q:(N#2) S N=N/2,D=D/2 + F Q:(N#5) S N=N/5,D=D/5 + Q N_"/"_D + ; +C(X,Y) ;PEP - Center X in field length Y/IOM/80. + Q $J("",$S($D(Y):Y,$G(IOM):IOM,1:80)-$L(X)\2)_X + ; +GDT(JDT) ;PEP - Return Gregorian Date, given Julian Date. + Q:'$G(JDT) -1 + S:'$D(DT) DT=$$DT^XLFDT + Q $$HTE^XLFDT($P($$FMTH^XLFDT($E(DT,1,3)_"0101"),",")+JDT-1) + ; +JDT(XBDT) ;PEP - Return Julian Date, given FM date. + Q:'$D(XBDT) -1 + Q:'(XBDT?7N) -1 + S:'$D(DT) DT=$$DT^XLFDT + Q $$FMDIFF^XLFDT(XBDT,$E(DT,1,3)_"0101")+1 + ; +USR() ;PEP - Return name of current user for ^VA(200. + Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0") + ; +LOC() ;PEP - Return location name from file 4 based on DUZ(2). + Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0") + ; +CV(X) ;PEP - Given a Namespace, return current version. + Q $$VERSION^XPDUTL(X) ;IHS/SET/GTH XB*3*9 10/29/2002 + Q:'$L($G(X)) -1 + S X=$O(^DIC(9.4,"C",X,0)) + Q:'X -1 + Q $G(^DIC(9.4,X,"VERSION"),-1) + ; + ;Begin New Code;IHS/SET/GTH XB*3*9 10/29/2002 +FNAME(N) ;PEP - Given File number, return File Name. + Q:'$L($G(N)) -1 + S N=$O(^DD(N,0,"NM","")) + Q:'$L(N) -1 + Q N + ; +FGLOB(N) ;PEP - Given File number, return File Global. + Q:'$L($G(N)) -1 + Q $G(^DIC(N,0,"GL"),-1) + ; +ZEROTH(A,B,C,D,E,F,G,H,I,J,K) ;PEP - Return dd 0th node. A is file #, rest fields. + I '$G(A) Q -1 + I '$G(B) Q -1 + F %=67:1:75 Q:'$G(@($C(%))) S A=+$P(^DD(A,B,0),U,2),B=@($C(%)) + I 'A!('B) Q -1 + I '$D(^DD(A,B,0)) Q -1 + Q U_$P(^DD(A,B,0),U,2) + ;End New Code;IHS/SET/GTH XB*3*9 10/29/2002 + ; diff --git a/XBFUNC1.m b/XBFUNC1.m new file mode 100644 index 0000000..31e7575 --- /dev/null +++ b/XBFUNC1.m @@ -0,0 +1,55 @@ +XBFUNC1 ; IHS/ADC/GTH - FUNCTION LIBRARY CONTINUED ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; +PROVCLS(PROV,FORM) ;PEP - Retrieve Provider Class from New Person File + I $G(PROV)="" Q "" + I '$D(^VA(200,PROV)) Q "" + NEW X,Z,Y,CLS,DIC,DR,DA,DIQ + S DIC=200,DR="53.5",DA=PROV,DIQ="CLS" + S:$G(FORM)="I" DIQ(0)="I" + D ENDIQ1 + S CLS=$S($G(FORM)="I":CLS(200,PROV,"53.5","I"),1:CLS(200,PROV,"53.5")) + Q $S(CLS="":"UNKNOWN",1:CLS) + ; +PROVCLSC(PROV) ;PEP - Retrieve Provider Class Code given New Person File IEN + I $G(PROV)="" Q "" + I '$D(^VA(200,PROV)) Q "" + NEW X,Z,Y,CODE,DIC,DR,DA,DIQ,CLASS + S CLASS=$$PROVCLS^XBFUNC1(PROV,"I") + I CLASS="UNKNOWN" Q "UNKNOWN" + S DIC=7,DR="9999999.01",DA=CLASS,DIQ="CODE" + D ENDIQ1 + S CODE=CODE(7,CLASS,"9999999.01") + Q $S(CODE="":"UNKNOWN",1:CODE) + ; +PROVAFFL(PROV,FORM) ;PEP - Retrieve provider affiliation in int or ext format + I $G(PROV)="" Q "" + I '$D(^VA(200,PROV)) Q "" + NEW X,Z,Y,AFFL,DIC,DR,DA,DIQ + S DIC=200,DR="9999999.01",DA=PROV,DIQ="AFFL" + S:$G(FORM)="I" DIQ(0)="I" + D ENDIQ1 + S AFFL=$S($G(FORM)="I":AFFL(200,PROV,"9999999.01","I"),1:AFFL(200,PROV,"9999999.01")) + Q AFFL + ; +PROVCODE(PROV) ;PEP - Retrieve provider code + I $G(PROV)="" Q "" + I '$D(^VA(200,PROV)) Q "" + NEW X,Z,Y,CODE,DIC,DR,DA,DIQ + S DIC=200,DR="9999999.02",DA=PROV,DIQ="CODE",DIQ(0)="E" + D ENDIQ1 + Q CODE(200,PROV,"9999999.02","E") + ; +PROVINI(PROV) ;PEP - Retrieve provider initials + I '$G(PROV) Q "" + I '$D(^VA(200,PROV)) Q "" + NEW X,Z,Y,INIT,DIC,DR,DA,DIQ + S DIC=200,DR="1",DA=PROV,DIQ="INIT",DIQ(0)="E" + D ENDIQ1 + Q INIT(200,PROV,"1","E") + ; +ENDIQ1 ; + NEW CLASS,FORM,PROV,X,Y,Z + D EN^DIQ1 + Q + ; diff --git a/XBFUNC2.m b/XBFUNC2.m new file mode 100644 index 0000000..dfdce9e --- /dev/null +++ b/XBFUNC2.m @@ -0,0 +1,69 @@ +XBFUNC2 ; IHS/ADC/GTH - FUNCTION LIBRARY : PCC RELATED FUNCTIONS ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; +PCCPPINT(XBVISIT) ;PEP - 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",XBVISIT,XBX)) Q:XBX'=+XBX I $P(^AUPNVPRV(XBX,0),U,4)="P" S XBY=+^AUPNVPRV(XBX,0) Q + I '$G(XBY) Q "" + Q XBY + ; +PCCPPN(XBVISIT) ;PEP - 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",XBVISIT,XBX)) Q:XBX'=+XBX I $P(^AUPNVPRV(XBX,0),U,4)="P" S XBY=XBX Q + I '$G(XBY) Q "NONE ENTERED" + S XBX=$$VAL^XBDIQ1(9000010.06,XBY,.01) + Q:XBX="" "NONE ENTERED" + Q XBX + ; +PCCPPI(XBVISIT) ;PEP - 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",XBVISIT,XBX)) Q:XBX'=+XBX I $P(^AUPNVPRV(XBX,0),U,4)="P" S XBY=+^AUPNVPRV(XBX,0) Q + I '$G(XBY) Q "???" + S XBX=$$VAL^XBDIQ1($S($P($G(^AUTTSITE(1,0)),U,22):200,1:6),XBY,1) + Q:XBX="" "???" + Q XBX + ; +PCCPPCLS(XBVISIT,FORM) ;PEP - 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",XBVISIT,XBX)) Q:XBX'=+XBX I $P(^AUPNVPRV(XBX,0),U,4)="P" S XBY=+^AUPNVPRV(XBX,0) Q + I '$G(XBY) Q "???" + 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":$G(XBX(200,XBY,"53.5","I")),1:$G(XBX(200,XBY,"53.5"))) + I '$P($G(^AUTTSITE(1,0)),U,22) S XBX=$S($G(FORM)="I":$G(XBX(6,XBY,"2","I")),1:$G(XBX(6,XBY,"2"))) + I XBX="" Q "???" + Q XBX + ; +PCCPPCLC(XBVISIT) ;PEP - Return a visit's primary provider class (CODE) + NEW X,Y,Z,XBX,DIC,DR,DA,DIQ,XBCODE,XBY,XBN + S XBX=0 + F S XBX=$O(^AUPNVPRV("AD",XBVISIT,XBX)) Q:XBX'=+XBX I $P(^AUPNVPRV(XBX,0),U,4)="P" S XBY=+^AUPNVPRV(XBX,0) Q + I '$G(XBY) Q "???" + S DA=XBY,DIC=200,DR="53.5",DIQ="XBX",DIQ(0)="I" + D EN^DIQ1 + S XBX=$G(XBX(200,XBY,"53.5","I")) + Q:XBX="" "???" + S DIC=7,DR="9999999.01",DA=XBX,DIQ="XBCODE" + D EN^DIQ1 + S XBX=XBCODE(7,XBX,"9999999.01","I") + Q XBX + ; +PCCPPAFF(XBVISIT,FORM) ;PEP - 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",XBVISIT,XBX)) Q:XBX'=+XBX I $P(^AUPNVPRV(XBX,0),U,4)="P" S XBY=+^AUPNVPRV(XBX,0) Q + I '$G(XBY) Q "???" + 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":$G(XBX(200,XBY,9999999.01,"I")),1:$G(XBX(200,XBY,9999999.01))) + I '$P($G(^AUTTSITE(1,0)),U,22) S XBX=$S($G(FORM)="I":$G(XBX(6,XBY,9999999.01,"I")),1:$G(XBX(6,XBY,9999999.01))) + Q:XBX="" "???" + Q XBX + ; diff --git a/XBGC.m b/XBGC.m new file mode 100644 index 0000000..0017b7d --- /dev/null +++ b/XBGC.m @@ -0,0 +1,59 @@ +XBGC ; IHS/ADC/GTH - COPY GLOBAL (ANY LEVEL) ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; +START ; + NEW (%) +GSGL ; + R !,"Source global: ",SG:$G(DTIME,999),! + Q:SG="" + S:$E(SG)'="^" SG="^"_SG + S:SG'["(" SG=SG_"(" + S:$E(SG,$L(SG))="," SG=$E(SG,1,$L(SG)-1) + I SG'?1"^"1U.U1"(".UNP W $C(7) G GSGL + I $E(SG,$L(SG))=")" W !!,"Global must be partial!,",!,$C(7) G GSGL + KILL SUB,SCNT,NSUB + I $E(SG,$L(SG))="(" I $D(@($E(SG,1,$L(SG)-1)))=0 W !!,"Global ",SG," does not exist!",!,$C(7) G GSGL + I $E(SG,$L(SG))'="(" I $D(@(SG_")"))=0 W !!,"Partial global ",SG," does not exist!",!,$C(7) G GSGL +GDGL ; + R !,"Destination global: ",DG:$G(DTIME,999),! + Q:DG="" + S:$E(DG)'="^" DG="^"_DG + S:DG'["(" DG=DG_"(" + S:$E(DG,$L(DG))="," DG=$E(DG,1,$L(DG)-1) + I DG'?1"^"1U.U1"(".UNP W $C(7) G GDGL + I $E(DG,$L(DG))=")" W !!,"Global must be partial!,",!,$C(7) G GDGL + KILL SUB,SCNT,NSUB + I SG=DG W !!,"Output same as input!",$C(7),! G GSGL + I $L(DG)>$L(SG) I $E(DG,1,$L(SG))=SG W !!,"Output contained in input!",$C(7),! G GSGL + I $L(DG)<$L(SG) I $E(SG,1,$L(DG))=DG W !!,"Input contained in output!",$C(7),! G GSGL + I $E(DG,$L(DG))="(" I $D(@($P(DG,"(",1)))'=0 W !!,"Destination global """,$P(DG,"(",1),""" already exists!",! S IS="" + I $E(DG,$L(DG))'="(" I $D(@(DG_")"))'=0 W !!,"Partial global ",DG," already exists.",! S IS="" + I $D(IS) W !,"KILL (Y/N) " R ANS:$G(DTIME,999) I $E(ANS)="Y" K:$E(DG,$L(DG))="(" @($E(DG,1,$L(DG)-1)) K:$E(DG,$L(DG))'="(" @(DG_")") + I $D(IS),ANS'="Y" W !,"Copy anyway? (Y/N) N//" R ANS:$G(DTIME,999) S:ANS="" ANS="N" Q:ANS'="Y" + I $E(SG,$L(SG))="(" S FROM=$E(SG,1,$L(SG)-1) + E S FROM=SG_")" + I $E(DG,$L(DG))="(" S TO=$E(DG,1,$L(DG)-1) + E S TO=DG_")" + S:$D(@(FROM))#10 @(TO)=@(FROM) + S (SCMA,DCMA)="" + S:$E(SG,$L(SG))'="(" SCMA="," + S:$E(DG,$L(DG))'="(" DCMA="," + S CTR=0 + D WALK + W !!,"All done!",! + G START + ; +WALK ; TRAVERSE TREE AT CURRENT SUBSCRIPT LEVEL + NEW (CTR,SCMA,DCMA,SG,DG) + S NL="" + F L=0:0 S NL=$O(@(SG_SCMA_""""_NL_""")")) Q:NL="" D GOTNODE + Q + ; +GOTNODE ; PROCESS ONE NODE + S CTR=CTR+1 + W:'(CTR#100) "." + S FROM=SG_SCMA_"NL)",TO=DG_DCMA_"NL)" + I $D(@(FROM))#10 S VAL=@(FROM),@(TO)=VAL + I $D(@(FROM))\10 S LNL=$L(NL),SG=SG_SCMA_""""_NL_"""",DG=DG_DCMA_""""_NL_"""",SVSCMA=SCMA,SVDCMA=DCMA,(SCMA,DCMA)="," D WALK S SCMA=SVSCMA,DCMA=SVDCMA,SG=$E(SG,1,$L(SG)-(LNL+2+$L(SCMA))),DG=$E(DG,1,$L(DG)-(LNL+2+$L(DCMA))) + Q + ; diff --git a/XBGCMP.m b/XBGCMP.m new file mode 100644 index 0000000..53d63dd --- /dev/null +++ b/XBGCMP.m @@ -0,0 +1,166 @@ +XBGCMP ; IHS/ADC/GTH - COMPARES TWO DIFFERENT GLOBALS ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ;;This utility is to be used to compare two globals. The initial + ;;globals entered must be identically subscripted. The utility will + ;;indicate which nodes of the first global have values different + ;;than similarly subscipted nodes of the second global. It will + ;;also indicate if a node in one global exists and if a similarly + ;;subscripted node in the other does not exist. You may utilize the + ;;[UCI,VOLUME] syntax to compare across UCIs and volume groups. + ;; + ;;### + ; + NEW X + D INIT +A ; + D ASK + I XBQ G X1 + D SETUP ; sets up up print/display, calls subrtn to process gbls + G A +X1 ; + D EOJ + Q + ; +INIT ; Setup + D ^XBKVAR + S (XBS,XBQ)=0 + X ^%ZOSF("UCI") + S XBVOL=$P(Y,",",2) + Q + ; +ASK ; Get globals to be compared +1 ; + R !,"First global to compare, i.e., NAME, NAME(1) or NAME(""B""): ^",X:DTIME + D:X["?" HELP^XBHELP("XBGCMP","XBGCMP") + G:X["?" 1 + I "^"[X S XBQ=1 G X2 + D CHECK + I XBS S XBS=0 G 1 + S XBG1=X +2 ; + R !,"Second global to compare: ^",X:DTIME + D:X["?" HELP^XBHELP("XBGCMP","XBGCMP") + G:X["?" 2 + I "^"[X S XBQ=1 G X2 + D CHECK + I XBS S XBS=0 G 2 + S XBG2=X + D CHECK2 + I XBS S XBS=0 G 1 +X2 ; + Q + ; +CHECK ; Check each global + I X["(",X'[")" S XBS=1 W !,*7," Must end in "")""" G X6 + S XBT=$P(X,"(") + I XBT["[" D + . I XBT'["]" W !,*7," Invalid cross UCI notation" S XBS=1 G X4 + . S XBT=$P(XBT,"]") + . I XBT["""" F XBI=1:1:$L(XBT) I $E(XBT,XBI)="""" S $E(XBT,XBI)="",XBI=XBI-1 + . I XBT?1"["3U1","3U!(XBT?1"["3U) + . E W !,*7," Invalid cross UCI notation" S XBS=1 G X4 + . I XBT'[","!($P(XBT,",",2)'=XBVOL) S X="["""_$P(XBT,"[",2)_"""]"_$P(X,"]",2) G X4 + . S X="["""_$P($P(XBT,"[",2),",")_"""]"_$P(X,"]",2) +X4 . Q + S XBT(1)=$S($P(X,"(")["[":$P($P(X,"]",2),"("),1:$P(X,"(")) + I $L(XBT(1))>8 W !,*7," Invalid global name" S XBS=1 G X6 + I XBT(1)?1A.AN!(XBT(1)?1"XB".AN) + E W !,*7," Invalid global name" S XBS=1 G X6 + S XBT(2)=X,X="TRAP^XBGCMP",@^%ZOSF("TRAP"),X=XBT(2) + I '$D(@("^"_X)) W !,*7," Global does not exist" S XBS=1 +X6 ; + Q + ; +TRAP ; Error trap for missing quotes + I $$Z^ZIBNSSV("ERROR")["0 D PAUSE Q:$G(XBSTP) S XBL=IOSL-3 W ! + . I $L(^TMP("XBGCMP",XBN,XB))>76 W !,$P(^(XB),"~"),!,$P(^(XB),"~",2),! S XBL=XBL-3.25 + . E W !,$P(^TMP("XBGCMP",XBN,XB),"~")," ",$P(^(XB),"~",2),! S XBL=XBL-2 + I '$G(XBSTP) W !,"Comparison completed with ",XBC," difference",$S(XBC'=1:"s",1:"")," found.",! + KILL ^TMP("XBGCMP",XBN) + I $D(ZTQUEUED) S ZTREQ="@" D EOJ + Q + ; +PAUSE ; Quit display? + I $E(IOST,1,2)="C-" S Y=$$DIR^XBDIR("E") S:$D(DIRUT)!($D(DUOUT)) XBSTP=1 KILL DIRUT,DUOUT W ! + Q + ; +SCHED ; Schedules another task to print + KILL ZTSAVE + F %="XBN","XBG1","XBG2","XBC" S ZTSAVE(%)="" + S ZTRTN="PRINT^XBGCMP",ZTDESC="PRINT COMPARISON OF TWO GLOBALS",ZTIO=XBION,ZTDTH=DT + D ^%ZTLOAD + KILL ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK + Q + ; +EOJ ; + KILL XB,XBA,XBB,XBC,XBI,XBL,XBG1,XBG2,XBION,XBN,XBQ,XBS,XBSTP,XBT,XBTEMP,XBTMP,XBVOL + Q + ; +HELP ;EP - Dooda about the utility + ;;@;! diff --git a/XBGCMP2.m b/XBGCMP2.m new file mode 100644 index 0000000..a1af379 --- /dev/null +++ b/XBGCMP2.m @@ -0,0 +1,8 @@ +XBGCMP2 ;DG/OHPRD; HELP FOR GLOBAL COMPARE UTILITY [ 01/27/92 3:55 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 +HELP ; Dooda about the utility + W !!,"This utility is to be used to compare two globals. The initial globals entered",!,"must be identically subscripted. The utility will indicate which nodes of the" D + . W !,"first global have values different than similarly subscipted nodes of the",!,"second global. It will also indicate if a node in one global exists and",!,"if a similarly subscripted node in the other does not exist. You may" + . W !,"utilize the [UCI,VOLUME] syntax to compare across UCIs and volume groups.",! + Q + ; diff --git a/XBGL.m b/XBGL.m new file mode 100644 index 0000000..d65e3d5 --- /dev/null +++ b/XBGL.m @@ -0,0 +1,63 @@ +XBGL ;IHS/ITSC/DMJ - GLOBAL LISTER [ 03/17/2005 10:46 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 +START ;START HERE + K XB,DIR W ! S $Y=1 + S DIR(0)="FAO^1:80",DIR("A")="Global: ^" D ^DIR K DIR + I Y=""!(Y="^") W ! K DIR Q + I Y[",,"!(Y["(,") W *7,!!,"Use '*' for wildcard.",! G START + I $E(Y,1)'="^" S Y="^"_Y + I $L(Y,"(")=2,$P(Y,"(",2)']"" S Y=$P(Y,"(",1) + S (XB("Y"),XB("IN"))=Y + S XB("RB")=$P(XB("IN"),"(",1) +I1 ;SET UP INPUT FOR COMPARISON + I XB("IN")["(" D + .S (XB("LP"),XB("RP"))=0 F I=1:1:$L(XB("IN")) S:$E(XB("IN"),I)="(" XB("LP")=XB("LP")+1 S:$E(XB("IN"),I)=")" XB("RP")=XB("RP")+1 + .S XB("X")="",XB("Z")="" + .S XB("IS")=$P(XB("IN"),"(",2,999) + .I $E(XB("IS"),$L(XB("IS")))=")",XB("LP")=XB("RP") S XB("IS")=$E(XB("IS"),1,$L(XB("IS"))-1) + .F I=1:1:$L(XB("IS"),",") D + ..S XB("I"_I)=$P(XB("IS"),",",I) Q:XB("I"_I)="" + ..S X="ER2",@^%ZOSF("TRAP") I 'XB("I"_I),XB("I"_I)'=0,XB("I"_I)'="*",$E(XB("I"_I),1)'=$C(34) D + ...I $E(XB("I"_I),$L(XB("I"_I)))=":" S XB("I"_I)=$E(XB("I"_I),1,$L(XB("I"_I))-1),XB("F3")=1 + ...S XB("I"_I)=@XB("I"_I) + ...I $G(XB("F3")) S XB("I"_I)=XB("I"_I)_":",XB("F3")=0 + ..S $P(XB("X"),",",I)=XB("I"_I),$P(XB("Z"),",",I)=XB("I"_I) + ..I XB("I"_I)="*" S $P(XB("X"),",",I)="0" + ..I $E(XB("I"_I),$L(XB("I"_I)))=":" S $P(XB("Z"),",",I)="*",$P(XB("X"),",",I)=$E(XB("I"_I),1,$L(XB("I"_I))-1),XB("I"_I)="*" + .S XB("IN")=XB("RB")_"("_XB("Z")_$S($E(Y,$L(Y))=")"&(XB("RP")=XB("LP")):")",1:""),XB("I")=$L(XB("Z"),",") + .S XB("Y")=XB("RB")_"("_XB("X")_")" +FIRST ;INITIAL ENTRY + S X="ER1",@^%ZOSF("TRAP") + I XB("IN")[")",XB("IN")'["*" S XB("F1")=1 + I $D(@XB("Y"))#2 D DISP I $G(XB("OUT")) G START +LOOP ;LOOP HERE + S X="ER2",@^%ZOSF("TRAP") + F S XB("Y")=$Q(@(XB("Y"))) D MATCH Q:$G(XB("F1")) D DISP I $G(XB("OUT")) G START + G START +ER1 ;FIRST ERROR CONDITION + G LOOP +ER2 ;SECOND ERROR CONDITION + W *7,!!,"??",! G START +MATCH ;DECIPHER INPUT + I XB("Y")="" S XB("F1")=1 Q + I $P(XB("IN"),"(",2)']"" Q + S XB("F2")=0 + S XB("SB")=$P(XB("Y"),"(",2),XB("SB")=$E(XB("SB"),1,$L(XB("SB"))-1),XB("S")=$L(XB("SB"),",") + I $E(XB("IN"),$L(XB("IN")))=")",XB("S")'=XB("I") S XB("F2")=1 Q + S XB("*")=0 F I=1:1:XB("I") D + .I XB("I"_I)="*" S XB("*")=XB("*")+1 Q + .S XB("S"_I)=$P(XB("SB"),",",I) + .I XB("I"_I)'=XB("S"_I) D + ..S XB("F2")=1 + ..I 'XB("*") S XB("F1")=1 + ..I XB("IN")'["*" S XB("F1")=1 + Q +DISP ;OUTPUT + Q:$G(XB("F2")) + S XB("=")=@(XB("Y")) + W !,XB("Y")," = ",XB("=") + I $Y>20 D + .S DIR(0)="E" D ^DIR K DIR + .I 'Y S XB("OUT")=1 Q + .W @IOF + Q diff --git a/XBGLDFN.m b/XBGLDFN.m new file mode 100644 index 0000000..11b3e8f --- /dev/null +++ b/XBGLDFN.m @@ -0,0 +1,18 @@ +XBGLDFN ; IHS/ADC/GTH - GET LAST DFN ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; +START ; + NEW GBL,LDFN,NDFN,STRT,TGBL +LOOP ; + R !,"Enter global reference like '^DPT(""B"",' ",GBL:$G(DTIME,999) + Q:GBL="" + I $E(GBL)="?"!(GBL'?1"^"1U.U.E) W !,"Enter global reference (e.g. ""^AUPNPAT("")." G LOOP + S TGBL=$S($E(GBL,$L(GBL))="(":$P(GBL,"(",1),$E(GBL,$L(GBL))=",":$E(GBL,1,$L(GBL)-1)_")",$E(GBL,$L(GBL))'=")":GBL_")",1:GBL) + I '$D(@(TGBL)) W !!,"Global ",GBL," does not exist!" G XBGLDFN + R !,"Start after DFN: 0// ",STRT:$G(DTIME,999) + S:STRT="" STRT=0 + S LDFN="Started after high DFN" + S NDFN=$D(@(GBL_STRT_")")),NDFN=STRT F L=0:0 S NDFN=$O(^(NDFN)) Q:NDFN=""!(NDFN'?1N.N) S LDFN=NDFN + W !!,"Last DFN is ",LDFN + Q + ; diff --git a/XBGSAVE.m b/XBGSAVE.m new file mode 100644 index 0000000..c5ac320 --- /dev/null +++ b/XBGSAVE.m @@ -0,0 +1,84 @@ +XBGSAVE ; IHS/ADC/GTH - GENERIC GLOBAL SAVE FOR TRANSMISSION GLOBALS ; [ 07/21/2005 4:13 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods. + ; + ; XBGL = name of global (mandatory, all others optional) + ; + ; XBCON= if defined, stops if first-level subscript is non-cannonic + ; XBDT = date of save, in FM format, default NOW + ; XBE = ending first-level numeric subscript + ; XBFLT= 1, saves as flat file + ; XBFN = output file name, default "." + ; XBF = beginning first-level numeric subscript, seed for $ORDER + ; XBIO = output device number + ; XBMED= media to which to save global (user asked, if not exist) + ; XBNAR= description displayed to user, if user asks for help + ; XBPAR= CR parameter (DSM only) + ; XBQ = Y/N, to place file in uucp q, default "Y" + ; XBQTO= 'sendto' destination, default AO sysid in RPMS SITE file + ; XBTLE= comment for dump header (facility name is concatenated) + ; XBUF = directory, default no longer provided - will kick out error + ; if XBUF undefined and no directory found in files + ; 9999999.39 or 8989.3 + ; XBS1 = zish send paramaters file entry + ; +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 ; IHS/SET/GTH XB*3*9 10/29/2002 + I '(^%ZOSF("OS")["MSM"),'(^%ZOSF("OS")["OpenM") S XBFLG(1)="Operating system is not 'MSM' or 'Cache'",XBFLG=-1 G EOJ ; IHS/SET/GTH XB*3*9 10/29/2002 + 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 + KILL 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 $G(XBUF)="" S XBUF=$P($G(^AUTTSITE(1,1)),"^",2) + I XBUF="" S XBUF=$P($G(^XTV(8989.3,1,"DEV")),"^",1) + I XBUF="" D G EOJ + .S XBFLG(1)="Export Directory NOT Specified" + .S XBFLG=-1 + I "/\"[$E(XBUF,$L(XBUF)) D + .S XBUF=$E(XBUF,1,($L(XBUF)-1)) + I '$D(DT) D DT^DICRW + S X2=$E(DT,1,3)_"0101",X1=DT + D ^%DTC + S XBCARTNO=X+1,XBDT=$S($D(XBDT):$$FMTE^XLFDT(XBDT),1:$$HTE^XLFDT($H)) + S:$E(XBGL)'=U XBGL=U_XBGL + S XBNAR=$G(XBNAR),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 + I $G(XBS1)'="" D + .S XBFLG=$$SENDTO1^ZISHMSMU(XBS1,XBPAFN) + .S XBFLG(1)=$P(XBFLG,"^",2) + .S XBFLG=+XBFLG + .Q:$D(ZTQUEUED) + .W:XBFLG=0 !!,"File was sent successfully" + .W:'(XBFLG=0) !!,"File was **NOT** sent successfully" + 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 + KILL %DT,X,XBCON,XBFN,XBGL,XBGLL,XBCARTNO,X1,X2,XBNAR,XBTLE,XBIO,XBPAR,XBDT,XBE,XBF,XBMED,XBUF,XBQ,XBQTO,XBFLT,XBSUFAC,Y + Q + ; diff --git a/XBGXFR.m b/XBGXFR.m new file mode 100644 index 0000000..f022ee7 --- /dev/null +++ b/XBGXFR.m @@ -0,0 +1,38 @@ +XBGXFR ; IHS/ADC/GTH - TRANSFERS GLOBAL TREES ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; CREATED BY GIS 7/17/85 FOR MSM UNIX MUMPS (2.3) + ; MODIFIED AND RENAMED BY EDE 12/21/86 + ; +START ; + D SEARCH + KILL FROM,TO,TALK + Q + ; +SEARCH ; + NEW (FROM,TO,TALK) + S F="F",T="T",C=",",P=")",NF=$L(FROM,C)-1,NT=$L(TO,C)-1,L=1,F1="" + S TF=FROM + F I=1:1:30 S TF=TF_F_I_C + S TT=TO + F I=1:1:30 S TT=TT_F_I_C + S Y=$E(FROM,1,$L(FROM)-1)_$S($E(FROM,$L(FROM))=",":")",1:"") + I $D(@(Y))#2 S Z=TO_$P(FROM,"(",2),Z=$E(Z,1,$L(Z)-1)_")",@Z=@Y +EXTR ; + S X=F_L,Y=$P(TF,C,1,L+NF)_P,@X=$O(@Y) + I @X]"" D:$D(@(Y))#2 SUB S L=L+1,@(F_L)="" G EXTR + S L=L-1 + Q:L=0 + G EXTR + ; +SUB ; + S Z=$P(TT,C,1,L+NT)_P,@Z=@Y + W:$D(TALK) "." + Q + ; +EN(FROM,TO,TALK) ;PEP - Transfer global trees. + Q:$G(FROM)="" + Q:$G(TO)="" + S TALK=$G(TALK) + G START + ; diff --git a/XBGXREFS.m b/XBGXREFS.m new file mode 100644 index 0000000..45e33ab --- /dev/null +++ b/XBGXREFS.m @@ -0,0 +1,32 @@ +XBGXREFS(FILE,FIELD,ROOT) ; IHS/ADC/GTH - GET XREFS FOR ONE FIELD IN ONE FILE ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; ATTENTION PROGRAMMERS: Do not use line one for entry. + ; Use label XREF for entry. + ; + ; Given a file/subfile number, a field number, and a variable + ; from which to assign subscripted values, this routine will + ; return the xrefs for the specified field. + ; + ; The returned xrefs will be subscripted from the ROOT as + ; follows: + ; + ; ROOT(FIELD,n) = file/subfile^xref (e.g. 9000010^AC) + ; ROOT(FIELD,n,"K") = executable kill logic + ; ROOT(FIELD,n,"S") = executable set logic + ; + ; Formal list: + ; + ; 1) FILE = file or subfile number (call by value) + ; 2) FIELD = field number (call by value) + ; 3) ROOT = array root (call by reference) + ; + G START + ; +XREF(FILE,FIELD,ROOT) ;PEP - Return x-ref info for a field. + ; +START ; + NEW Y + F Y=0:0 S Y=$O(^DD(FILE,FIELD,1,Y)) Q:Y'=+Y S ROOT(FIELD,Y)=^(Y,0),ROOT(FIELD,Y,"S")=^(1),ROOT(FIELD,Y,"K")=^(2) + Q + ; diff --git a/XBHEDD.m b/XBHEDD.m new file mode 100644 index 0000000..229a9f7 --- /dev/null +++ b/XBHEDD.m @@ -0,0 +1,70 @@ +XBHEDD ;402,DJB,5/1/90,EDD - Electronic Data Dictionary + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;;FLAGQ='^',FLAGE='^^',FLAGP=Printing on,FLAGP1=Option 11 selected to turn on printing + ;;FLAGH=Bypass 1st screen + ;;FLAGS=Scrolling speed set,FLAGL=Last item in list,FLAGM='^' or + ;;'^^' in menu,FLAGG=No Groups,FLAGNFF=Suppress Form Feed,FLAGPT=Pointer File or Field nonexistent + ;;FLAGGL=Invalid entry in GLOBAL +TOP ; + S:'$D(DUZ)#2 DUZ=0 I +DUZ=0 W *7,!!?5,"Your DUZ is not defined!",! Q + N FLAGE,FLAGG,FLAGGL,FLAGGL1,FLAGL,FLAGM,FLAGP,FLAGP1,FLAGQ,FLAGS + N A,B,BAR,C,C1,DASHES,DIC,E,EDDDATE,FGRP,FILE,FLD,G,GROUP,GROUP1,GRP1,GRP2,GT,H,HD,I,I2,II,III,IOP,J,K,L,LENGTH,LEVEL,LINE,M1,M2,M3,M4,M5,NORMAL,NUM,O,PAGE,SCROLL,SIZE,SLOW,SPACE,STRING,X,XREF,XREFNAM,XREFTYPE,XX,Y,YCNT + N Z,Z1,ZA,ZANS,ZAP,ZB,ZCNT,ZD,ZDATA,ZDATA1,ZDSUB,ZFLDNAM,ZFLDNUM,ZGL,ZGL1,ZHELP,ZHNUM,ZLINE,ZLINE1,ZLINE2,ZMULT,ZMZ,ZNAM,ZPOTMP,ZZGL + N ZNUM,ZONE,ZPAGE,ZPF,ZPO,ZPO1,ZPO2,ZTHREE,ZTWO,ZX,ZY1,ZZ,ZZ1,ZZA,ZZB,ZZH,ZZX + D INIT +EN S (FLAGP,FLAGQ,FLAGS)=0 K ^UTILITY($J) + D:'FLAGH HD + D GETFILE G:FLAGQ EX D MULT^XBHEDD7,MENU G:FLAGE EX + S FLAGH=1 G EN ;Set FLAGH to bypass opening screen +EX ;Exit + K FLAGH,FLAGNFF,^UTILITY($J) + Q +GETFILE ;File lookup + R !?8,"Select FILE: ",X:DTIME S:'$T X="^" I "^"[X S FLAGQ=1 Q + I $L(X)>1,$E(X)="^" D GLOBAL^XBHEDD9 G:FLAGGL GETFILE Q + I X="?" W !?1,"Enter global in the format '^DG' or '^RA(78', or" + S DIC="^DIC(",DIC(0)="QEM" D ^DIC K DIC I Y<0 G GETFILE + S ZNUM=+Y,ZNAM=$P(Y,U,2),ZGL=^DIC(ZNUM,0,"GL") + Q +MENU ; + S (FLAGE,FLAGG,FLAGL,FLAGM,FLAGQ,FLAGP1,FLAGS)=0 + D HD1,^XBHEDDM G:FLAGP1 MENU I FLAGP S:IO'=IO(0) FLAGQ=1 D PRINT^XBHEDD7 ;Turn off printing + Q:FLAGM!FLAGE G:FLAGQ MENU + I $Y'>SIZE F I=$Y:1:SIZE W ! + R !!?2," to go to Main Menu, '^' to exit: ",Z1:DTIME S:'$T Z1="^" I Z1="^" S FLAGE=1 Q + G MENU +DIR ;Supress heading + S FLAGH=1 G TOP +GL ;Call XBHEDD here to get listing of Globals in ASCII order. + N FLAGH,FLAGNFF,FLAGP,FLAGQ,M1,M2,M3,M4,M5,SIZE,Z1,ZLINE,ZLINE1,ZLINE2 + S SIZE=(IOSL-5),(FLAGP,FLAGQ)=0 D INIT,GL^XBHEDD10 G EX +PRT ;Stop page feeds. Use on ptr/keyboard + S (FLAGH,FLAGNFF)=1 G TOP +HD ; + W:'FLAGNFF @IOF + W !?65,"David Bolduc",!?65,"Togus, ME" + W !!!?35,"E D D",!?34,"~~~~~~~",!?35,"~~~~~",!?36,"~~~",!?37,"~",!?25,"Electronic Data Dictionary",!?32,"Version 2.3",! + W !?22,"*",?25,"Everything you ever wanted",?53,"*",!?22,"*",?25,"to know about a file but",?53,"*",!?22,"*",?25,"were afraid to ask.",?53,"*" + W !! + Q +HD1 ;Heading for Top of Main Menu + W:'FLAGNFF @IOF W !?M1,"A.) FILE NAME:------------- ",ZNAM + W !?48,"F.) FILE ACCESS:" + W !?M1,"B.) FILE NUMBER:----------- ",ZNUM + W ?53,"DD______ ",$S($D(^DIC(ZNUM,0,"DD")):^("DD"),1:"") + W !?53,"Read____ ",$S($D(^DIC(ZNUM,0,"RD")):^("RD"),1:"") + W !?M1,"C.) NUM OF FLDS:----------- ",^UTILITY($J,"TOT") + W ?53,"Write___ ",$S($D(^DIC(ZNUM,0,"WR")):^("WR"),1:"") + W !?53,"Delete__ ",$S($D(^DIC(ZNUM,0,"DEL")):^("DEL"),1:"") + W !?M1,"D.) DATA GLOBAL:----------- ",ZGL + W ?53,"Laygo___ ",$S($D(^DIC(ZNUM,0,"LAYGO")):^("LAYGO"),1:"") + W !!?M1,"E.) TOTAL GLOBAL ENTRIES:-- " + S ZZGL=ZGL_"0)",ZZGL=@ZZGL W $S($P(ZZGL,U,4)]"":$P(ZZGL,U,4),1:"Blank") + W ?48,"G.) PRINTING STATUS:-- ",$S(FLAGP:"On",1:"Off") + W !,$E(ZLINE1,1,80) + Q +INIT ; + S:'$D(DTIME) DTIME=600 S M1=2,M2=15,M3=20,M4=22,M5=25 ;Variables for column numbers + K ZLINE,ZLINE1,ZLINE2 S $P(ZLINE,"-",212)="",$P(ZLINE1,"=",212)="",$P(ZLINE2,". ",106)="",U="^" + S IOP=0 D ^%ZIS K IOP S SIZE=(IOSL-5) S:'$D(FLAGNFF) FLAGNFF=0 S:'$D(FLAGH) FLAGH=0 + Q diff --git a/XBHEDD1.m b/XBHEDD1.m new file mode 100644 index 0000000..548dd04 --- /dev/null +++ b/XBHEDD1.m @@ -0,0 +1,55 @@ +XBHEDD1 ;402,DJB,10/23/91,EDD - FIELD Global Locations + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;;David Bolduc - Togus, ME +PRINT ;Called by START,LOOP + Q:'$D(^DD(FILE(LEVEL),FLD(LEVEL),0)) + S ZDATA=^DD(FILE(LEVEL),FLD(LEVEL),0),ZZA=$S($P(ZDATA,U,4)=" ; ":"Computed",1:$P(ZDATA,U,4)),ZZB=$P(ZDATA,U) + W !?2,$J(ZZA,12),?17,$J(FLD(LEVEL),8),?28,DASHES,ZZB + S ZY1=$P($P(ZDATA,U,4),";",2) W:ZY1=0 ?70,"-->Mult" + S ZMZ=" " I ZY1=0 F II=1:1:41-$L(DASHES_ZZB) S ZMZ=ZMZ_" " + I S ZMZ=ZMZ_"-->Mult" + I 'FLAGP S ^UTILITY($J,"LIST",PAGE,YCNT)=ZZA_"^"_FLD(LEVEL)_"^"_DASHES_ZZB_ZMZ + S YCNT=YCNT+1 + Q +EN ;Entry Point + D ASK G:FLAGQ EX + I FLAGP,IO'=IO(0),^UTILITY($J,"TOT")>100 D WARN G:FLAGQ EX + S HD="HD" D INIT^XBHEDD7 G:FLAGQ EX D @HD D START,LOOP +EX ; + I FLAGQ!FLAGE!FLAGP S:IO'=IO(0) FLAGQ=1 D KILL Q + S FLAGL=1 D ^XBHEDD2 S:'FLAGQ FLAGQ=1 D KILL + Q +ASK ; + W !?26,"""F""........ to select starting FIELD",!?26,"... for all fields" +ASK1 W !?30,"Select: ALL// " R ZZX:DTIME S:'$T ZZX="^" I ZZX["^" S FLAGQ=1 S:ZZX="^^" FLAGE=1 Q + I ZZX="?" W !?10,"Type ""^"" to quit",!?10," to see all fields",!?10,"""F"" to start listing at a particular field" G ASK1 + S (LEVEL,PAGE,YCNT)=1,FILE(LEVEL)=ZNUM,DASHES="" + I ZZX="F" W ! S DIC="^DD("_ZNUM_",",DIC(0)="QEAM",DIC("W")="I $P(^DD(ZNUM,Y,0),U,2)>0 W ?65,"" -->Mult""" D ^DIC K DIC("W") S:Y<0 FLAGQ=1 Q:Y<0 S FLD(LEVEL)=+Y + E S FLD(LEVEL)=0 + Q +START ;Print if data, otherwise continue to loop. + I $D(^DD(FILE(LEVEL),FLD(LEVEL),0))#2 D PRINT I ZY1=0 S LEVEL=LEVEL+1,FILE(LEVEL)=+$P(ZDATA,U,2),FLD(LEVEL)=0 + Q +LOOP ;Start For Loop + S FLD(LEVEL)=$O(^DD(FILE(LEVEL),FLD(LEVEL))) I +FLD(LEVEL)=0 S LEVEL=LEVEL-1 G:LEVEL LOOP Q + S (SPACE,BAR)="" + F II=1:1:LEVEL-1 S SPACE=SPACE_" ",BAR=BAR_"-" + S DASHES=SPACE_BAR + D PRINT I ZY1=0 S LEVEL=LEVEL+1,FILE(LEVEL)=+$P(ZDATA,U,2),FLD(LEVEL)=0 + I $Y>SIZE D:'FLAGP ^XBHEDD2 Q:FLAGQ I FLAGP D PAUSE Q:FLAGQ W @IOF W:IO'=IO(0) !!! D HD + G LOOP +PAUSE ; + Q:IO'=IO(0) + W !!?2," to continue, '^' to quit: " + R Z1:DTIME S:'$T Z1="^^" I Z1["^" S FLAGQ=1 S:Z1="^^" FLAGE=1 + Q +WARN ;Warn if printing and over 100 fields in file + W !?8,"This file has over 100 fields. Sure you want to print? YES//" + R XX:DTIME S:'$T XX="N" S:"Yy"'[$E(XX) FLAGQ=1 I XX="?" W !?2,"[Y]es to print, [N]o to return to Main Menu." G WARN + Q +HD ; + W !?2,"NODE ; PIECE",?17,"FLD NUM",?48,"FIELD NAME",!?2,"------------",?17,"--------",?28,"-------------------------------------------------" + Q +KILL ;Kill variables + K DASHES,EDDDATE,FILE,HD,LEVEL,PAGE,PAGETEMP,YCNT,^UTILITY($J,"LIST") + Q diff --git a/XBHEDD10.m b/XBHEDD10.m new file mode 100644 index 0000000..cf43a19 --- /dev/null +++ b/XBHEDD10.m @@ -0,0 +1,73 @@ +XBHEDD10 ;402,DJB,10/23/91,EDD - Pointers From This File and Global Listing + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;;David Bolduc - Togus, ME +PT ;Pointers from this file + D INIT^XBHEDD7 S HD="HD1" D @HD,PTGET +PTEX ; + K CNT,NAME,NODE0,NUMBER,ZDD + Q +PTGET ; + S ZDD="",CNT=1 + F S ZDD=$O(^UTILITY($J,"TMP",ZDD)) Q:ZDD=""!(FLAGQ) S NAME="" F S NAME=$O(^DD(ZDD,"B",NAME)) Q:NAME="" S NUMBER="",NUMBER=$O(^DD(ZDD,"B",NAME,"")) D PTLIST Q:FLAGQ + I CNT=1 W !!!!!?20,"This file has no fields that",!?20,"point to other files." + Q +PTLIST ; + Q:^DD(ZDD,"B",NAME,NUMBER)=1 ;If this node equals 1 it is TITLE not NAME + S NODE0=^DD(ZDD,NUMBER,0) Q:$P(NODE0,U,2)'["P" Q:$P(NODE0,U,3)']"" + W !?1,$S(ZDD'=ZNUM:"MULT",1:""),?6,$J(NUMBER,8),?16,NAME S FILE="^"_$P(NODE0,U,3)_"0)" W ?48,$S($D(@FILE):$E($P(@FILE,U),1,30),1:"-->No such file") + S CNT=CNT+1 I $Y>SIZE D PAGE Q:FLAGQ=1 + Q +GL ;List Globals in ASCII order + D:'$D(^UTILITY("EDD/GL")) HELP +GLTOP D @$S($D(^UTILITY("EDD/GL")):"GLRANGE",1:"GLRANGE1") G:FLAGQ GLEX D INIT S HD="HD" D @HD + D GLLIST G:FLAGQ GLEX +GLEX ;Global Exit + K AA,BB,CNT,HD,TEMP,VAR,XXX + Q +GLRANGE ;Starting and Ending Global + I FLAGP W !?8,"Enter Global range...Include Starting & Ending Global:" +GLRANGE1 R !?8,"Starting Global: ^",AA:DTIME S:'$T!(AA="") AA="^" S:AA["^" FLAGQ=1 S:AA="^^" FLAGE=1 Q:FLAGQ + I AA="?"!(AA="*R") D:AA="?" HELP1 D:AA="*R" GLLOAD G GLRANGE + I '$D(^UTILITY("EDD/GL")) W *7," Enter '*R' to build your Global listing." G GLRANGE1 + S AA=$S(AA="*":0,1:"^"_AA) + S BB="^ZZZZZZZZZ" I FLAGP R !?8,"Ending Global: ^",BB:DTIME S:'$T!(BB="") BB="^" G:BB="^" GLRANGE S BB="^"_BB I BB']AA W *7," Ending Global must 'follow' Starting Global" G GLRANGE1 + I FLAGP S TEMP=$O(^UTILITY("EDD/GL",AA)) I TEMP=""!(TEMP]BB) W *7," No globals in this range" G GLRANGE1 + Q +GLLIST ;Start listing Globals + F S AA=$O(^UTILITY("EDD/GL",AA)) Q:AA=""!(AA]BB) W !?2,AA,?23,$J($P(^(AA),U),14),?40,$E($P(^(AA),U,2),1,35) I $Y>SIZE D PAGE Q:FLAGQ + Q +GLLOAD ; + S AA=0,CNT=1 K ^UTILITY("EDD/GL") + F S AA=$O(^DIC(AA)) Q:AA'>0 I $D(^DIC(AA,0,"GL")) S ^UTILITY("EDD/GL",^DIC(AA,0,"GL"))=AA_"^"_$P(^DIC(AA,0),"^") W "." + Q +HELP ;No data in ^UTILITY("EDD/GL") + W *7,?35,"You have no data in ^UTILITY(""EDD/GL"")." + W !?35,"You must first build your Global listing." + W !?35,"Enter '?' at the 'Starting Global:' prompt." + Q +HELP1 ;"Starting Global" prompt + W !!?8,"1. Enter Global you want listing to start with.",!?11,"Examples: ^DPT , ^L , or ^%ZIS." + W !?8,"2. Enter '*' to list all globals." + W !?8,"3. Enter '*R' to Build/Update your Global listing." + W !?14,"Your Global listing is kept in ^UTILITY(""EDD/GL""). If this is the" + W !?14,"first time you've used this utility, or if you have added or" + W !?14,"deleted any files on your system, enter '*R' here to build/update" + W !?14,"your listing. It will take approximately 30 seconds to run." + Q +PAGE ; + I FLAGP,IO'=IO(0) W @IOF,!!! D @HD Q + R !!?2," to continue, '^' to quit, '^^' to exit: ",Z1:DTIME S:'$T Z1="^" I Z1["^" S FLAGQ=1 S:Z1="^^" FLAGE=1 Q + W @IOF D @HD + Q +HD ; + W !?2,"Globals in ASCII order:" + W !?10,"GLOBAL",?28,"FILE NUM",?46,"FILE (Truncated to 35)" + W !,?2,"----------------------",?27,"----------",?40,"-----------------------------------" + Q +HD1 ;Pointers from this file + W !?3,"Pointers FROM this file..",!?6,"FLD NUM",?26,"FIELD NAME",?52,"FILE (Truncated to 30)",!?6,"--------",?16,"------------------------------",?48,"------------------------------" + Q +INIT ; + I FLAGP,IO=IO(0),IOSL>25 D SCROLL^XBHEDD7 Q:FLAGQ + I FLAGP W:IO'=IO(0) " Printing.." U IO + W @IOF Q diff --git a/XBHEDD11.m b/XBHEDD11.m new file mode 100644 index 0000000..c17f0d5 --- /dev/null +++ b/XBHEDD11.m @@ -0,0 +1,57 @@ +XBHEDD11 ;402,DJB,10/23/91,EDD - Templates and Description + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;;David Bolduc - Togus,ME +EN ;Templates + I '$D(^DIBT("F"_ZNUM)),'$D(^DIPT("F"_ZNUM)),'$D(^DIE("F"_ZNUM)) W ?30,"No Templates" S FLAGG=1 G EX + S Z1="" D INIT^XBHEDD7 G:FLAGQ EX D HD + D DIPT G:FLAGQ EX D DIBT G:FLAGQ EX D DIE +EX ; + K A,DISYS,DIW,DIWI,DIWTC,DIWX,DIWT,DIWL,DIWF,DIWR,DN,HEAD,II,VAR + Q +DIPT ;Print Templates + S HEAD="A.) PRINT TEMPLATES:" W !?2,HEAD + S A="",VAR="^DIPT" + F II=1:1 S A=$O(^DIPT("F"_ZNUM,A)) Q:A="" W !?12,$J(II,4),". ",A S B=$O(^DIPT("F"_ZNUM,A,"")) W:$D(^DIPT(B,"ROU")) ?60,"Compiled: ",^DIPT(B,"ROU") I $Y>SIZE D PAGE Q:FLAGQ!(Z1="S") + I II=1 W ?25,"No print templates..." + Q +DIBT ;Sort Templates + S HEAD="B.) SORT TEMPLATES:" W !?2,HEAD + S A="",VAR="^DIBT" + F II=1:1 S A=$O(^DIBT("F"_ZNUM,A)) Q:A="" W !?12,$J(II,4),". ",A I $Y>SIZE D PAGE Q:FLAGQ!(Z1="S") + I II=1 W ?25,"No sort templates..." + Q +DIE ;Edit Templates + S HEAD="C.) INPUT TEMPLATES:" W !?2,HEAD + S A="",VAR="^DIE" + F II=1:1 S A=$O(^DIE("F"_ZNUM,A)) Q:A="" W !?12,$J(II,4),". ",A S B=$O(^DIE("F"_ZNUM,A,"")) W:$D(^DIE(B,"ROU")) ?60,"Compiled: ",^DIE(B,"ROU") I $Y>SIZE D PAGE Q:FLAGQ!(VAR="") + I II=1 W ?25,"No input templates..." + Q +PAGE ;Templates + I VAR="^DIE" S ZX=VAR_"(""F"_ZNUM_""","""_A_""")" I $O(@ZX)="" S VAR="" Q + I FLAGP,IO'=IO(0) W @IOF,!!! D HD Q + W !!?2," to continue, 'S' to skip, '^' to quit, '^^' to exit: " + R Z1:DTIME S:'$T Z1="^" I Z1["^" S FLAGQ=1 S:Z1="^^" FLAGE=1 Q + I Z1="S",VAR="^DIE" S FLAGQ=1 Q + S ZX=VAR_"(""F"_ZNUM_""","""_A_""")" + W @IOF D HD I Z1="S"!($O(@ZX)="") Q + W !?2,HEAD," continued..." Q +PAGE1 ;File Description + I FLAGP,IO'=IO(0) W @IOF,!!! D HD1 Q + R !!?2," to continue, '^' to quit, '^' to exit: ",Z1:DTIME + S:'$T Z1="^" I Z1["^" S FLAGQ=1 S:Z1="^^" FLAGE=1 Q + W @IOF D HD1 + Q +DES ;File Description + I FLAGP D PRINT^XBHEDD7 ;Shut off printing + I '$D(^DIC(ZNUM,"%D")) W ?30,"No description available." S FLAGG=1 Q + W @IOF D HD1 + K ^UTILITY($J,"W") + S A=0 F S A=$O(^DIC(ZNUM,"%D",A)) Q:A="" S X=^DIC(ZNUM,"%D",A,0),DIWL=5,DIWR=75,DIWF="W" D ^DIWP I $Y>SIZE D PAGE1 Q:FLAGQ + D:'FLAGQ ^DIWW + G EX +HD ;Templates + W !?2,"T E M P L A T E S PRINT * SORT * INPUT",!,$E(ZLINE,1,IOM) + Q +HD1 ;File description + W !?2,"File description for ",ZNAM," file.",!,$E(ZLINE1,1,IOM) + Q diff --git a/XBHEDD12.m b/XBHEDD12.m new file mode 100644 index 0000000..50f5742 --- /dev/null +++ b/XBHEDD12.m @@ -0,0 +1,41 @@ +XBHEDD12 ;402,DJB,10/23/91,EDD - File Characteristics + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;;David Bolduc - Togus, ME +CHAR ;Identifiers, Post Selection Actions, Special Look-up Program + I '$D(^DD(ZNUM,0,"ID")),'$D(^DD(ZNUM,0,"ACT")),'$D(^DD(ZNUM,0,"DIC")) W !?10,"No Identifiers, Post Selection Actions, or Special Look-up Program." S FLAGG=1 Q + D INIT^XBHEDD7 G:FLAGQ EX + W !?21,"F I L E C H A R A C T E R I S T I C S",!?20,"-----------------------------------------" + ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + W !!?2,"1. POST SELECTION ACTION:" I $D(^DD(ZNUM,0,"ACT")) D + .W " The following code is executed after an entry to" + .W !?29,"this file has been selected. If Y=-1 entry will" + .W !?29,"not be selected:" + .W !?14,"CODE:" S STRING=^DD(ZNUM,0,"ACT") D STRING + ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + W !!?2,"2. SPECIAL LOOK-UP PROGRAM: " I $D(^DD(ZNUM,0,"DIC")) W "^",^DD(ZNUM,0,"DIC") + ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + W !!?2,"3. IDENTIFIERS:" + I $D(^DD(ZNUM,0,"ID")) D NOTE,HD S XX="" F S XX=$O(^DD(ZNUM,0,"ID",XX)) Q:XX=""!FLAGQ D W ! + .W !?1,$J(XX,12),?15,$S(+XX=XX:"Yes",1:"No") S STRING=^DD(ZNUM,0,"ID",XX) D STRING + ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +EX ;Exit + Q +STRING ;String=code - Prints a string in lines of 55 characters + S LINE(1)=$E(STRING,1,55) W ?M3,LINE(1) I $Y>SIZE D PAGE Q:FLAGQ + I $L(STRING)>55 S LINE(2)=$E(STRING,56,110) W !?M3,LINE(2) I $Y>SIZE D PAGE Q:FLAGQ + I $L(STRING)>110 S LINE(3)=$E(STRING,111,165) W !?M3,LINE(3) I $Y>SIZE D PAGE Q:FLAGQ + I $L(STRING)>165 S LINE(4)=$E(STRING,166,220) W !?M3,LINE(4) I $Y>SIZE D PAGE Q:FLAGQ + I $L(STRING)>220 S LINE(5)=$E(STRING,221,275) W !?M3,LINE(5) I $Y>SIZE D PAGE Q:FLAGQ + I $L(STRING)>275 S LINE(6)=$E(STRING,276,330) W !?M3,LINE(6) I $Y>SIZE D PAGE Q:FLAGQ + Q +PAGE ; + I FLAGP,$E(IOST)="P" W @IOF,!!! D HD Q + R !!?2," to continue, ""^"" to quit, ""^^"" to exit: ",Z1:DTIME S:'$T Z1="^" I Z1["^" S FLAGQ=1 S:Z1="^^" FLAGE=1 Q + W @IOF D HD + Q +NOTE ; + W " If ASK=Yes, field is asked when a new entry is added.",! + Q +HD ;Heading + W !?8,"FIELD",?15,"ASK",?(M3+10),"WRITE STATEMENT TO GENERATE DISPLAY",!?8,"-----",?15,"---",?M3,"-------------------------------------------------------" + Q diff --git a/XBHEDD13.m b/XBHEDD13.m new file mode 100644 index 0000000..77ca5f2 --- /dev/null +++ b/XBHEDD13.m @@ -0,0 +1,41 @@ +XBHEDD13 ;402,DJB,5/1/90,EDD - Help Text 2 + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;;David Bolduc - Togus, ME + ;;Called by XBHEDD1 + W @IOF,!?5,"INPUT",?20,"EFFECT",!?5,"=======",?20,"=========================================================" + W !?2,"1.",?7,"""^""",?20,"Causes an exit back to the Main Menu." + W !!?2,"2.",?7,"""B""",?20,"Backs up to previous screen." + W !!?2,"3.",?7,"""n""",?20,"Typing a number here allows you to jump to that screen." + W !?20,"In the lower right hand corner of the screen, you will" + W !?20,"see 2 numbers: TOP and CUR. TOP is the highest screen" + W !?20,"you have to. CUR is the current screen" + W !?20,"you are viewing. You can only jump between the first and" + W !?20,"TOP screen. As an example, if you selected the ""FIELD" + W !?20,"Global Location"" option and then hit 6 times," + W !?20,"TOP would be equal to 6 and CUR would be equal to 6." + W !?20,"Now you can jump to any screen between 1 and 6." + W !?20,"If you entered a ""2"" and , you would jump" + W !?20,"to screen 2. TOP would still be equal to 6 but CUR" + W !?20,"would now be 2. If you then hit ""B"" to back up 1 screen," + W !?20,"TOP would be 6 and CUR would be 1. If you now" + W !?20,"wanted to return to TOP (screen 6) you would type a ""6""" + R !!?2," to continue, ""^"" to quit: ",Z1:DTIME S:'$T Z1="^" I Z1="^" S FLAG="QUIT" Q + W @IOF,!?5,"INPUT",?20,"EFFECT",!?5,"=======",?20,"=========================================================" + W !?20,"and this page would now be displayed. TOP and CUR would" + W !?20,"both be equal to 6 again." + W !!?2,"4.",?7,"""I""",?20,"""I"" allows you to zoom in on an individual field. It" + W !?20,"prompts you for a field and then gives you the Individual" + W !?20,"FIELD Summary for that field. When using ""I"", you" + W !?20,"must start at the top of the multiple. For example, if" + W !?20,"you were looking at the Patient file and you had selected" + W !?20,"""Admission Date"" as the starting point for FIELD Global" + W !?20,"Location and you thru 2 screens, you would see" + W !?20,"the field Treating Specialty. To view the Individual" + W !?20,"FIELD Summary for this field you would have to first" + W !?20,"select Admission Date and then Treating Specialty. This" + W !?20,"is made easier by the design of the FIELD Global Location" + W !?20,"screens. Each layer of multiple fields is preceeded by" + W !?20,"dashes that indicated their level. You trace these dashes" + W !?20,"back to locate the starting point for each layer." + W !?20,"You can also use the ""Trace a Field"" option." + R !!?2,"Hit any key to continue: ",Z1:DTIME S FLAG="QUIT" Q diff --git a/XBHEDD2.m b/XBHEDD2.m new file mode 100644 index 0000000..5d7db31 --- /dev/null +++ b/XBHEDD2.m @@ -0,0 +1,34 @@ +XBHEDD2 ;402,DJB,10/23/91,EDD - Screen prompt ; keeps track of pages + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;;David Bolduc - Togus, ME +TOP S PAGETEMP=PAGE D ASK + I Z1="B" S PAGETEMP=PAGE-1 D MOVE + I Z1?1.N S PAGETEMP=Z1 D MOVE + I Z1="I" S PAGETEMP=PAGE D ^XBHEDD3 Q:FLAGE D MOVE + I Z1="N" S PAGETEMP=PAGE D ^XBHEDD9 Q:FLAGE D MOVE + I Z1="?" S PAGETEMP=PAGE D ^XBHEDD14,MOVE + Q:FLAGQ!FLAGE I FLAGL,Z1="" Q + S PAGE=PAGE+1,YCNT=1 W @IOF W:IO'=IO(0) !!! D HD + Q +ASK ; + S FLAGQ=0 I $Y'>SIZE F I=$Y:1:SIZE W ! + W !,$E(ZLINE,1,IOM),!," B=Backup N=Node I=Indiv Fld Sum 'num'=Jump(1 to TOP)",?57,"|",?69,"| TOP: ",PAGE + W !," =Continue ^=Quit ^^=Exit ?=Help",?57,"|",?69,"| CUR: ",PAGETEMP + F I=1:1:18 W *8 + R "Select: ",Z1:DTIME S:'$T Z1="^" I Z1["^" S FLAGQ=1 S:Z1="^^" FLAGE=1 + S:$E(Z1)="0" Z1=+Z1 S:Z1["." Z1=Z1\1 + Q +MOVE ; + W @IOF W:IO'=IO(0) !!! D HD S PAGETEMP=$S(PAGETEMP<1:1,PAGETEMP>PAGE:PAGE,1:PAGETEMP) + S H="" F I=0:0 S H=$O(^UTILITY($J,"LIST",PAGETEMP,H)) Q:H="" S ZZH=^UTILITY($J,"LIST",PAGETEMP,H) S ZONE=$P(ZZH,U),ZTWO=$P(ZZH,U,2),ZTHREE=$P(ZZH,U,3) W !?2,$J(ZONE,12),?17,$J(ZTWO,8),?28,ZTHREE + D ASK Q:FLAGQ + I Z1="B" S PAGETEMP=PAGETEMP-1 G MOVE + I Z1?1.N S PAGETEMP=Z1 G MOVE + I Z1="I" D ^XBHEDD3 Q:FLAGE G MOVE + I Z1="N" D ^XBHEDD9 Q:FLAGE G MOVE + I Z1="?" D ^XBHEDD14 G MOVE + S PAGETEMP=PAGETEMP+1 Q:PAGETEMP>PAGE + G MOVE +HD ;Heading + W !?2,"NODE ; PIECE",?17,"FLD NUM",?48,"FIELD NAME",!?2,"------------",?17,"--------",?28,"-------------------------------------------------" + Q diff --git a/XBHEDD3.m b/XBHEDD3.m new file mode 100644 index 0000000..210679f --- /dev/null +++ b/XBHEDD3.m @@ -0,0 +1,27 @@ +XBHEDD3 ;402,DJB,10/23/91,EDD - Individual Field Summary + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;;David Bolduc - Togus,ME + N CNT,DATA,FILE,FNAM,FNUM,LEV,TEMP + D INIT I FLAGP D HD + F D GETFLD Q:'LEV!FLAGE + I FLAGP,$D(^UTILITY($J,"INDIV")) D PRINT +EX ; + K DIC,^UTILITY($J,"INDIV") S FLAGQ=1 Q +GETFLD ;Field lookup. Var LEV increments and decrements with Multiple layers. + S DIC="^DD("_FILE(LEV)_"," D ^DIC I Y<0 S LEV=LEV-1 Q + S FNUM=+Y,FNAM=$P(Y,U,2),TEMP=+$P(^DD(FILE(LEV),FNUM,0),U,2) + I TEMP S LEV=LEV+1,FILE(LEV)=TEMP Q + I 'FLAGP D ^XBHEDD4 Q + S ^UTILITY($J,"INDIV",CNT)=FILE(LEV)_"^"_FNUM_"^"_FNAM,CNT=CNT+1 + Q +PRINT ; + W:IO'=IO(0) " Printing.." U IO D TXT^XBHEDD7 + S CNT="" F S CNT=$O(^UTILITY($J,"INDIV",CNT)) Q:CNT="" S DATA=^UTILITY($J,"INDIV",CNT),FILE(LEV)=$P(DATA,U),FNUM=$P(DATA,U,2),FNAM=$P(DATA,U,3) D ^XBHEDD4 Q:FLAGQ W !!,$E(ZLINE2,1,IOM),!! + Q +HD ; + W @IOF,!,$E(ZLINE1,1,80),!?5,"Enter one at a time, as many fields as you wish to print. Fields will",!?5,"print in the order entered.",!,$E(ZLINE1,1,80),! + Q +INIT ; + S (CNT,LEV)=1,FILE(LEV)=ZNUM K ^UTILITY($J,"INDIV") + S DIC(0)="QEAM",DIC("W")="I $P(^DD(FILE(LEV),Y,0),U,2)>0 W "" -->Mult Fld""" + Q diff --git a/XBHEDD4.m b/XBHEDD4.m new file mode 100644 index 0000000..2338f79 --- /dev/null +++ b/XBHEDD4.m @@ -0,0 +1,57 @@ +XBHEDD4 ;DJB,402,10/23/91,EDD - Individual Field Summary + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;;David Bolduc - Togus, ME + ;; Called by XBHEDD3 + N NODE + I 'FLAGP W @IOF,!!,$E(ZLINE,1,IOM) + S FLAGQ=0 + F II=0,.1,2,3,4,12,12.1 S:$D(^DD(FILE(LEV),FNUM,II)) NODE(II)=^(II) + W !?M1,"FIELD NAME:",?M3,FNAM + W !!?M1,"FLD NUMBER:",?M3,FNUM,?36,"FLD TITLE: " W:$D(NODE(.1)) NODE(.1) + W !?M1,"NODE;PIECE:",?M3,$S($P(NODE(0),U,4)=" ; ":"Computed",1:$P(NODE(0),U,4)) + W ?35,"HELP FRAME: " W:$D(^DD(FILE(LEV),FNUM,22)) ^(22) + W !!?M1," ACCESS:",?M3,"RD: ",$S($D(^DD(FILE(LEV),FNUM,8)):^(8),1:"")," ","DEL: ",$S($D(^(8.5)):^(8.5),1:"")," ","WR: ",$S($D(^(9)):^(9),1:"") +DATATYPE S ZD=$P(NODE(0),U,2) W !!?M1," DATA TYPE:" + W ?M3,$S(ZD["C":"Computed",ZD["D":"Date/Time",ZD["F":"Free Text",ZD["N":"Numeric",ZD["P":"Pointer",ZD["S":"Set of Codes",ZD["W":"Word Processing",ZD["V":"Variable Pointer",ZD["K":"MUMPS code",1:"*****") + F I=1:1:$L(ZD) S ZDSUB=$E(ZD,I) D:"BIORX"[ZDSUB DTYPE1^XBHEDD5 D:"am*'"[ZDSUB DTYPE2^XBHEDD5 + I ZD["S" F I=1:1:$L($P(NODE(0),U,3),";")-1 W !?M4,$P($P(NODE(0),U,3),";",I) + I ZD["P" S ZA="^"_$P(NODE(0),U,3) W !!?M1,"POINTS TO:",?M3 S ZB=ZA_"0)" W:$D(@ZB) $P(@ZB,U)," file - ",ZA W:'$D(@ZB) ZB," - Global doesn't exist." + I ZD["V"&($D(^DD(FILE(LEV),FNUM,"V",0))) W !!?M1,"POINTS TO:" + I S VAR=0 F I=0:0 S VAR=$O(^DD(FILE(LEV),FNUM,"V",VAR)) Q:VAR'>0 S ZDATA1=^DD(FILE(LEV),FNUM,"V",VAR,0) W ?M3,$P(ZDATA1,U),?M5,$P(ZDATA1,U,2) W:$O(^DD(FILE(LEV),FNUM,"V",VAR))>0 ! + I $P(NODE(0),U,5)]"" W !!?M1,$S(ZD["C":"CODE CREATING X:",1:"INPUT TRANSFORM:") S STRING=$P(NODE(0),U,5,99) D STRING^XBHEDD5 G:FLAGQ EX + I $D(NODE(2)) W !!?M1,"OUTPUT TRANSFORM:" S STRING=NODE(2) D STRING^XBHEDD5 G:FLAGQ EX + I $D(^DD(FILE(LEV),FNUM,"DEL")) W !!?M1,"DELETE NODE(S):",?M3,"If $T is set to 1, no deleting." D + .S XX="" F S XX=$O(^DD(FILE(LEV),FNUM,"DEL",XX)) Q:XX="" W !?6,"Node: ",XX S STRING=^DD(FILE(LEV),FNUM,"DEL",XX,0) D STRING^XBHEDD5 Q:FLAGQ + G:FLAGQ EX + I $D(^DD(FILE(LEV),0,"ID",FNUM)) W !!?M1,"IDENTIFIER:" S STRING=^DD(FILE(LEV),0,"ID",FNUM) D STRING^XBHEDD5 G:FLAGQ EX + I $D(NODE(3)) W !!?M1,"PROMPT MESSAGE:" S STRING=NODE(3) D WORD^XBHEDD5 G:FLAGQ EX + I $D(NODE(12)) W !!?M1,"SCREEN: " S STRING=NODE(12) D STRING^XBHEDD5 G:FLAGQ EX + I $D(NODE(12.1)) W !?M1,"SCREEN CODE:" S STRING=NODE(12.1) D STRING^XBHEDD5 G:FLAGQ EX + I $D(^DD(FILE(LEV),FNUM,1)) D XREF G:FLAGQ EX + I $D(^DD(FILE(LEV),FNUM,21)) W ! D:$Y>SIZE PAGE^XBHEDD5 G:FLAGQ EX + I W !?M1,"DESCRIPTION:" S A=0 F S A=$O(^DD(FILE(LEV),FNUM,21,A)) Q:A=""!FLAGQ S STRING=^(A,0) D WORD^XBHEDD5 W ! + G:FLAGQ EX + I $D(^DD(FILE(LEV),FNUM,22)),^(22)]"" D HELP G:FLAGQ EX +EX ; + K LINE Q:FLAGQ + I 'FLAGP I $Y'>SIZE F I=$Y:1:SIZE W ! + I 'FLAGP W !,$E(ZLINE,1,IOM) + Q +XREF ; + S K=0 F S K=$O(^DD(FILE(LEV),FNUM,1,K)) Q:K=""!(K'>0)!FLAGQ S XREFNAM=$P(^DD(FILE(LEV),FNUM,1,K,0),U,2) S:XREFNAM="" XREFNAM="-----" S XREFTYPE=$P(^(0),U,3) S:XREFTYPE="" XREFTYPE="REGULAR" D XREF1 + Q +XREF1 ; + W ! D:$Y>SIZE PAGE^XBHEDD5 Q:FLAGQ + W !?M1,"CROSS REF NAME:",?M3,XREFNAM D:$Y>SIZE PAGE^XBHEDD5 Q:FLAGQ W !?12,"TYPE:",?M3,XREFTYPE D:$Y>SIZE PAGE^XBHEDD5 Q:FLAGQ + S L=0 F S L=$O(^DD(FILE(LEV),FNUM,1,K,L)) Q:L=""!FLAGQ D:L="%D" DESCRIP I $D(^(L))#2 W ! W:L'>0 ?M1,L W:L>0 ?6,"Node: ",L S STRING=^(L) D STRING^XBHEDD5 Q:FLAGQ + Q +DESCRIP ; + W ! S M=0 F S M=$O(^DD(FILE(LEV),FNUM,1,K,L,M)) Q:M=""!FLAGQ W !,?M1 S STRING=^(M,0) D WORD^XBHEDD5 Q:FLAGQ + W ! Q +HELP ;Print HELP FRAME text (^DIC(9.2,) + Q:FLAGP + W ! D:$Y>SIZE PAGE^XBHEDD5 Q:FLAGQ + W !?M1,"This field has a HELP FRAME." D:$Y>SIZE PAGE^XBHEDD5 Q:FLAGQ + R !?M1,"Do you wish to see the HELP FRAME text?: [YES/NO] NO//",ANS:DTIME S:'$T ANS="N" S:ANS="" ANS="N" Q:"Yy"'[$E(ANS) + S XQH=^DD(FILE(LEV),FNUM,22) D EN^XQH + K ANS,XQH Q diff --git a/XBHEDD5.m b/XBHEDD5.m new file mode 100644 index 0000000..a9b1f5d --- /dev/null +++ b/XBHEDD5.m @@ -0,0 +1,51 @@ +XBHEDD5 ;402,DJB,10/23/91,EDD - Individual Field Summary + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;;David Bolduc - Togus, ME +STRING ;String=code - Prints a string in lines of 55 characters + S LINE(1)=$E(STRING,1,55) W ?M3,LINE(1) I $Y>SIZE D PAGE Q:FLAGQ + I $L(STRING)>55 S LINE(2)=$E(STRING,56,110) W !?M3,LINE(2) I $Y>SIZE D PAGE Q:FLAGQ + I $L(STRING)>110 S LINE(3)=$E(STRING,111,165) W !?M3,LINE(3) I $Y>SIZE D PAGE Q:FLAGQ + I $L(STRING)>165 S LINE(4)=$E(STRING,166,220) W !?M3,LINE(4) I $Y>SIZE D PAGE Q:FLAGQ + I $L(STRING)>220 S LINE(5)=$E(STRING,221,275) W !?M3,LINE(5) I $Y>SIZE D PAGE Q:FLAGQ + I $L(STRING)>275 S LINE(6)=$E(STRING,276,330) W !?M3,LINE(6) I $Y>SIZE D PAGE Q:FLAGQ + Q +WORD ;String=text - Prints a string in lines of 55 characters + S LINE(1)=$E(STRING,1,55) + I $L(STRING)>55 S LINE(1)=$P(LINE(1)," ",1,$L(LINE(1)," ")-1) + W ?M3,LINE(1) I $Y>SIZE D PAGE Q:FLAGQ + S LENGTH=$L(LINE(1)) + Q:$L(STRING)'>LENGTH + S LINE(2)=$E(STRING,LENGTH+2,LENGTH+57) + I $L(STRING)>(LENGTH+2+55) S LINE(2)=$P(LINE(2)," ",1,$L(LINE(2)," ")-1) + W !?M3,LINE(2) I $Y>SIZE D PAGE Q:FLAGQ + S LENGTH=LENGTH+2+$L(LINE(2)) + Q:$L(STRING)'>LENGTH + S LINE(3)=$E(STRING,LENGTH+2,LENGTH+57) + I $L(STRING)>(LENGTH+2+55) S LINE(3)=$P(LINE(3)," ",1,$L(LINE(3)," ")-1) + W !?M3,LINE(3) I $Y>SIZE D PAGE Q:FLAGQ + S LENGTH=LENGTH+2+$L(LINE(3)) + S LINE(4)=$E(STRING,LENGTH+2,LENGTH+57) + I $L(STRING)>(LENGTH+2+55) S LINE(4)=$P(LINE(4)," ",1,$L(LINE(4)," ")-1) + W !?M3,LINE(4) I $Y>SIZE D PAGE Q:FLAGQ + S LENGTH=LENGTH+2+$L(LINE(4)) + S LINE(5)=$E(STRING,LENGTH+2,LENGTH+57) + I $L(STRING)>(LENGTH+2+55) S LINE(5)=$P(LINE(5)," ",1,$L(LINE(5)," ")-1) + W !?M3,LINE(5) I $Y>SIZE D PAGE Q:FLAGQ + S LENGTH=LENGTH+2+$L(LINE(5)) + S LINE(6)=$E(STRING,LENGTH+2,LENGTH+57) + I $L(STRING)>(LENGTH+2+55) S LINE(6)=$P(LINE(6)," ",1,$L(LINE(6)," ")-1) + W !?M3,LINE(6) I $Y>SIZE D PAGE Q:FLAGQ + Q +DTYPE1 ;Called by DATATYPE^XBHEDD4 + W !?M3,$S(ZDSUB["B":"True-False (""Boolean"")",ZDSUB["I":"Uneditable",ZDSUB["O":"Has output transform",ZDSUB["R":"Required field",ZDSUB["X":"Input Transform has been modified in Utility Option",1:"") + Q +DTYPE2 ;Called by DATATYPE^XBHEDD4 + W !?M3,$S(ZDSUB["a":"Marked for auditing",ZDSUB["m":"Multilined",ZDSUB["*":"Field has a screen",ZDSUB["'":"LAYGO to ""pointed to"" file not allowed",1:"") + Q +PAGE ; + I FLAGP,IO'=IO(0) W @IOF,!!! Q + I $Y'>SIZE F I=$Y:1:SIZE W ! + W:'FLAGP !,$E(ZLINE,1,IOM) W:FLAGP ! + R !?2," to continue, ""^"" to quit, ""^^"" to exit: ",Z1:DTIME S:'$T Z1="^" I Z1["^" S FLAGQ=1 S:Z1="^^" FLAGE=1 Q + W @IOF W:'FLAGP !?55,"FLD NUMBER: ",FNUM,!,$E(ZLINE,1,IOM),! + Q diff --git a/XBHEDD6.m b/XBHEDD6.m new file mode 100644 index 0000000..9d2aa7b --- /dev/null +++ b/XBHEDD6.m @@ -0,0 +1,65 @@ +XBHEDD6 ;402,DJB,10/23/91,EDD - Xref,Groups,Pointers In + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;; David Bolduc - Togus, ME +XREF ;Cross Reference Listing + I '$D(^DD(ZNUM,0,"IX")) W ?30,"No XREF for this file." S FLAGG=1 Q + S NM="",HD="HD1" D INIT^XBHEDD7 G:FLAGQ EX D HD1 + F S NM=$O(^DD(ZNUM,0,"IX",NM)) Q:NM="" D:$Y>SIZE PAGE Q:FLAGQ S ZDD="",ZDD=$O(^DD(ZNUM,0,"IX",NM,ZDD)),ZFLD="",ZFLD=$O(^DD(ZNUM,0,"IX",NM,ZDD,ZFLD)) D XREFPRT + G EX +XREFPRT ; + S GLTEMP=ZGL_""""_NM_""""_")" + W ! W:$D(@(GLTEMP)) ?1,"*" W ?4,"""",NM,"""",?22,$J(ZDD,8),?33,$J(ZFLD,10) + I $D(^DD(ZDD,ZFLD,0)) W ?46,$P(^(0),U) Q + W ?46,"---> Field doesn't exist" + Q +PT ;Pointers to this file + I '$D(^DD(ZNUM,0,"PT")) W ?30,"No files point to this file." S FLAGG=1 Q + D INIT^XBHEDD7 G:FLAGQ EX D HD3 S ZFILE="",ZCNT=1,HD="HD3" + F S ZFILE=$O(^DD(ZNUM,0,"PT",ZFILE)) Q:ZFILE=""!FLAGQ S FLAGPT=0 D @$S($D(^DIC(ZFILE,0)):"PTYES",1:"PTNO") I 'FLAGPT S ZFLD="" F S ZFLD=$O(^DD(ZNUM,0,"PT",ZFILE,ZFLD)) Q:ZFLD="" D PTPRT Q:FLAGQ + G EX +PTNO ; + I '$D(^DD(ZFILE,0,"UP")) S FLAGPT=1 Q + S ZFILETP=ZFILE F S ZFILETP=^DD(ZFILETP,0,"UP") Q:$D(^DIC(ZFILETP,0)) I '$D(^DD(ZFILETP,0,"UP")) Q + I '$D(^DIC(ZFILETP,0)) S FLAGPT=1 Q + S GL=^DIC(ZFILETP,0,"GL"),ZFILEN=$P(^DIC(ZFILETP,0),U) + Q +PTYES ; + S GL=^DIC(ZFILE,0,"GL"),ZFILEN=$P(^DIC(ZFILE,0),U) Q +PTPRT ; + W !,$J(ZCNT,4),".",?6,GL,?21,$E(ZFILEN,1,25) + W ?48 I $D(^DD(ZFILE,ZFLD,0)),$P(^(0),U)]"" W $E($P(^(0),U),1,22)," (",ZFLD,")" + E W "--> Field ",ZFLD," does not exist." + S ZCNT=ZCNT+1 I $Y>SIZE D PAGE Q:FLAGQ + Q +GRP ;Groups + S ZMULT="",HD="HD2" D GRPBLD G:FLAGG EX D INIT^XBHEDD7 G:FLAGQ EX D HD2,GRPPRT + G EX +GRPBLD ; + S Z="",X=1 + F S Z=$O(^UTILITY($J,"TMP",Z)) Q:Z="" I $D(^DD(Z,"GR")) S GRP="" F S GRP=$O(^DD(Z,"GR",GRP)) Q:GRP="" S ZFLD="" F S ZFLD=$O(^DD(Z,"GR",GRP,ZFLD)) Q:ZFLD="" S ^UTILITY($J,"GROUP",GRP,Z,ZFLD)=$P(^DD(Z,ZFLD,0),U),X=X+1 I X#9=0 W "." + I '$D(^UTILITY($J,"GROUP")) W ?30,"No Groups established." S FLAGG=1 + Q +GRPPRT ; + S GRP="" F I=1:1 S GRP=$O(^UTILITY($J,"GROUP",GRP)) Q:GRP=""!FLAGQ W !,$J(I,3),". ",GRP D GRPPRT1 + Q +GRPPRT1 ; + S GRP1="" + F S GRP1=$O(^UTILITY($J,"GROUP",GRP,GRP1)) Q:GRP1=""!FLAGQ S GRP2="" F S GRP2=$O(^UTILITY($J,"GROUP",GRP,GRP1,GRP2)) Q:GRP2="" W ?18,$J(GRP1,6),?27,$J(GRP2,8),?39,^(GRP2),! I $Y>SIZE D PAGE Q:FLAGQ + Q +EX ; + K FLAGPT,GL,GLTEMP,GRP,GRP1,GRP2,HD,NM,ZDD,ZFILE,ZFILEN,ZFILETP,ZFLD,ZGL1,ZMULT + K ^UTILITY($J,"GROUP") Q +HD1 ;XREF + W !?9,"XREF",?25,"DD",?34,"FLD NUM",?56,"FIELD NAME",!?4,"---------------",?22,"--------",?33,"----------",?46,"------------------------------" + Q +HD2 ;Groups + W !?5,"GROUP NAME",?20,"DD",?27,"FLD NUM",?48,"FIELD NAME",!?5,"-----------",?18,"------",?27,"--------",?39,"------------------------------",! + Q +HD3 ;Pointers to this file + W !?3,"Pointers TO this file..",!?9,"GLOBAL",?22,"FILE (Truncated to 25)",?50,"FIELD (Truncated to 22)",!?6,"-------------",?21,"-------------------------",?48,"------------------------------" + Q +PAGE ; + I FLAGP,IO'=IO(0) W @IOF,!!! D @HD Q + R !!?2," to continue, '^' to quit, '^^' to exit: ",Z1:DTIME S:'$T Z1="^" I Z1["^" S FLAGQ=1 S:Z1="^^" FLAGE=1 Q + W @IOF D @HD + Q diff --git a/XBHEDD7.m b/XBHEDD7.m new file mode 100644 index 0000000..f9608c1 --- /dev/null +++ b/XBHEDD7.m @@ -0,0 +1,41 @@ +XBHEDD7 ;402,DJB,10/23/91,EDD - Count fields, Printing + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;;David Bolduc - Togus, ME + ;;This is run each time EDD is run, right after you select a File. + ;;It sets up multiples in ^UTILITY($J,"TMP") +MULT ; + D MULTBLD K CNT,TMP Q +MULTBLD ; + K ^UTILITY($J) + S CNT=1,^UTILITY($J,"TMP",ZNUM)=$P(^DD(ZNUM,0),U,4)_"^"_CNT,^UTILITY($J,"TOT")=$P(^DD(ZNUM,0),U,4) + Q:'$D(^DD(ZNUM,"SB")) S TMP(1)=ZNUM,CNT=2,TMP(CNT)="" + F S TMP(CNT)=$O(^DD(TMP(CNT-1),"SB",TMP(CNT))) D MULTBLD1 Q:CNT=1 + Q +MULTBLD1 ; + I TMP(CNT)="" S CNT=CNT-1 Q + I '$D(^DD(TMP(CNT),0)) Q + S ^UTILITY($J,"TMP",TMP(CNT))=$P(^DD(TMP(CNT),0),U,4)_"^"_CNT_"^"_$O(^DD(TMP(CNT-1),"SB",TMP(CNT),"")) + S ^UTILITY($J,"TOT")=^UTILITY($J,"TOT")+$P(^DD(TMP(CNT),0),U,4) + I $D(^DD(TMP(CNT),"SB")) S CNT=CNT+1,TMP(CNT)="" + Q +PRINTM ;Option 11 in Main Menu + S FLAGP1=1 ;Redraws Main Menu. See MENU+2^XBHEDD. +PRINT ; + I FLAGS W *27,"[?4l" S FLAGS=0 ;Reset scroll to normal + S FLAGP=FLAGP=0 I FLAGP=0 W:IO'=IO(0)&('FLAGM) @IOF D ^%ZISC S SIZE=(IOSL-5) Q ;If FLAGM user hit at Main Menu pompt. + S %ZIS("A")=" DEVICE: " D ^%ZIS K %ZIS("A") I POP S FLAGP=0 Q + S SIZE=(IOSL-5) Q +TXT ; + W @IOF Q:'FLAGP W:IO'=IO(0) !!! + I '$D(EDDDATE) S X="NOW",%DT="T" D ^%DT K %DT S EDDDATE=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) + W !,$E(ZLINE1,1,IOM),!?2,"File:---- ",ZNAM,!?2,"Global:-- ",ZGL,?(IOM-17),"Date: ",EDDDATE,!,$E(ZLINE1,1,IOM),! + Q +SCROLL ;Adjust scroll rate + W !!?8,"SCROLLING: [N]ormal [S]mooth . . . . ","Select: N//" + R SCROLL:DTIME S:'$T SCROLL="^" S SCROLL=$E(SCROLL) I SCROLL="^" S FLAGQ=1 Q + I SCROLL="?" W !?8,"Since you're printing to your CRT and you've asked for a page",!?8,"length greater than 25, you may now adjust the scroll rate.",!?8,"For DEC VT-100 compatible devices only." G SCROLL + S:SCROLL="" SCROLL="N" Q:"S,s"'[SCROLL S FLAGS=1 W *27,"[?4h" Q +INIT ; + I FLAGP,IO=IO(0),IOSL>25 D SCROLL Q:FLAGQ + I FLAGP W:IO'=IO(0) " Printing.." U IO + D TXT Q diff --git a/XBHEDD8.m b/XBHEDD8.m new file mode 100644 index 0000000..d5874aa --- /dev/null +++ b/XBHEDD8.m @@ -0,0 +1,52 @@ +XBHEDD8 ;402,DJB,10/23/91,EDD - Trace a Field + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;;David Bolduc - Togus, ME +EN ; + I FLAGP D PRINT^XBHEDD7 ;Turn off printing + D GETFLD G:FLAGQ EX D LIST G:FLAGG!(FLAGE) EX + D TRACE G:FLAGQ EX D PRINT,ASK +EX K CNT,DATA,FLD,FLD1,FLDCNT,I,LEVEL,MAR,MAR1,ZDD,ZNAME,ZNUMBER,^UTILITY($J,"FLD") + S FLAGQ=1 Q +GETFLD ; + R !?8,"Enter Field Name: ALL FIELDS//",FLD:DTIME S:'$T FLD="^^" I FLD["^" S FLAGQ=1 S:FLD="^^" FLAGE=1 Q + I FLD="?" W !?2,"Enter field name or any portion of name. I will display the field's path.",!?2,"Use this option if you get ""beeped"" in the INDIVIDUAL FIELD SUMMARY because",!?2,"the field is decendent from a multiple." G GETFLD + Q +LIST ; + S ZDD="",FLDCNT=1 + F S ZDD=$O(^UTILITY($J,"TMP",ZDD)) Q:ZDD=""!(FLAGQ) S LEVEL=$P(^(ZDD),U,2),ZNAME="" F S ZNAME=$O(^DD(ZDD,"B",ZNAME)) Q:ZNAME="" I $E(ZNAME,1,$L(FLD))=FLD D LIST1 Q:FLAGQ + I '$D(^UTILITY($J,"FLD")) W ?50,"No such field." S FLAGG=1 + S FLAGQ=0 Q +LIST1 ; + S ZNUMBER=$O(^DD(ZDD,"B",ZNAME,"")) Q:^DD(ZDD,"B",ZNAME,ZNUMBER)=1 + D:FLDCNT=1 HD + W ! W:$P(^DD(ZDD,ZNUMBER,0),U,2)>0 "Mult->" W ?6,$J(FLDCNT,3),".",?LEVEL*5+6," ",ZNAME," (",ZNUMBER,")" + S ^UTILITY($J,"FLD",FLDCNT)=ZNAME_"^"_ZDD_"^"_ZNUMBER_"^"_LEVEL + D:$Y>SIZE PAGE Q:FLAGQ + S FLDCNT=FLDCNT+1 + Q +TRACE ;If more than one match do NUM + R !!?8,"Select Number: ",FLD1:DTIME S:'$T FLD1="^^" S:FLD1="" FLD1="^" I FLD1["^" S FLAGQ=1 S:FLD1="^^" FLAGE=1 Q + I FLD1<1!(FLD1>(FLDCNT)) W *7,!?2,"Enter a number from the left hand column." G TRACE + S CNT=1,ZNAME(CNT)=$P(^UTILITY($J,"FLD",FLD1),U),ZNUMBER(CNT)=$P(^(FLD1),U,3),ZDD=$P(^(FLD1),U,2) + Q:ZDD=ZNUM + F S CNT=CNT+1,ZNUMBER(CNT)=$P(^UTILITY($J,"TMP",ZDD),U,3),ZDD=^DD(ZDD,0,"UP"),ZNAME(CNT)=$P(^DD(ZDD,ZNUMBER(CNT),0),U) Q:ZDD=ZNUM + Q +PRINT ;Print data. + W @IOF,!!!,?IOM\2-11,"F I E L D T R A C E",!,$E(ZLINE1,1,IOM) + S MAR=5,MAR1=15 + F W !!?MAR,ZNUMBER(CNT),?MAR1,ZNAME(CNT) S CNT=CNT-1 Q:CNT=0 S MAR=MAR+5,MAR1=MAR1+5 + Q +ASK ; + I $Y'>SIZE F I=$Y:1:SIZE W ! + W !,$E(ZLINE1,1,IOM) + W !?2,"(=Main Menu) ('I'=Individual Field Summary)" +ASK1 R !?2,"Select: ",Z1:DTIME S:'$T Z1="^^" I Z1="^^" S FLAGE=1 + I Z1="?" W *7,!?2,"See menu on line above." G ASK1 + S:Z1="i" Z1="I" I Z1="I" D ^XBHEDD3 + Q +PAGE ; + R !!?2," to continue, '^' to quit, '^^' to exit: ",Z1:DTIME S:'$T Z1="^" I Z1["^" S FLAGQ=1 S:Z1="^^" FLAGE=1 Q + D HD Q +HD ;Trace a field + W @IOF,!!,"MULTIPLE",?13,"1 2 3 4 5 6 7",!,"LEVELS",?13,"| | | | | | |",!,$E(ZLINE,1,IOM),! + Q diff --git a/XBHEDD9.m b/XBHEDD9.m new file mode 100644 index 0000000..0ae5d59 --- /dev/null +++ b/XBHEDD9.m @@ -0,0 +1,78 @@ +XBHEDD9 ;402,DJB,10/23/91,EDD - NODE Lookup and Look-up by Global + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;;David Bolduc - Togus, ME + N FILE,FLD,NODE,NODE0,NODE1,PIECE + K ^UTILITY($J,"EDD/NP") S FILE=ZNUM +ND ;Lookup by NODE and PIECE + D NDGET G:FLAGQ EX D NDBLD + I '$D(^UTILITY($J,"EDD/NP")) W *7," No such node." G ND +ND1 D NDPRT G:FLAGQ EX + I $O(^UTILITY($J,"EDD/NP",NODE,""))=0 S FILE=+$P(^UTILITY($J,"EDD/NP",NODE,0),U,3),NODE1=NODE G ND + D NDSUM G:FLAGD ND G:FLAGE EX + S FLAGQ=0 G ND1 +EX ; + S:'FLAGE FLAGQ=0 K NP,FLAGD,FNAM,FNUM,LEV,^UTILITY($J,"EDD/NP") + Q +NDGET ;Node get + W ! +NDGET1 I FILE'=ZNUM W !,"Select '",NODE1,"' SUBNODE: " + E W !,"Select NODE: " + R NODE:DTIME S:'$T NODE="^" I "^"[NODE S FLAGQ=1 Q + I NODE="?" D HELP G NDGET1 + Q +NDBLD ; + S FLD=0 K ^UTILITY($J,"EDD/NP") + F S FLD=$O(^DD(FILE,FLD)) Q:FLD'>0 I $P($P(^DD(FILE,FLD,0),U,4),";")=NODE S NODE0=^(0),NP=$P(NODE0,U,4),PIECE=$P(NP,";",2),^UTILITY($J,"EDD/NP",NODE,PIECE)=FLD_U_$P(NODE0,U,1,4) + Q +NDPRT ;Print + S PIECE="" W @IOF D HD + F S PIECE=$O(^UTILITY($J,"EDD/NP",NODE,PIECE)) Q:PIECE="" W !?3,$J(NODE_";"_PIECE,12),?20,$J($P(^UTILITY($J,"EDD/NP",NODE,PIECE),U),7),?32,$P(^(PIECE),U,2) I $Y>SIZE D PAGE Q:FLAGQ=1 + Q +NDSUM ; + W !!?2,"You may now do an 'INDIVIDUAL FIELD SUMMARY'",!?2,"on the field(s) listed above.." + S FLAGD=0 W ! S DIC="^DD("_FILE_",",DIC(0)="QEAM" D ^DIC I Y<0 S FLAGD=1 Q + S FNUM=+Y,FNAM=$P(Y,U,2),LEV=1,FILE(LEV)=FILE D ^XBHEDD4 Q:FLAGQ + I $Y'>SIZE F I=$Y:1:SIZE W ! + R ?2," to continue..",XX:DTIME + Q +PAGE ; + R !!?2," to continue, '^' to quit, '^' to exit: ",Z1:DTIME S:'$T Z1="^" I Z1["^" S FLAGQ=1 S:Z1="^^" FLAGE=1 Q + W @IOF D HD + Q +HELP ; + N FLD,NDTEMP + S FLD=0 K ^UTILITY($J,"EDD/NP") + F S FLD=$O(^DD(FILE,FLD)) Q:FLD'>0 S NDTEMP=$P($P(^DD(FILE,FLD,0),U,4),";") W:'$D(^UTILITY($J,"EDD/NP",NDTEMP))#2 " ",NDTEMP W:$X>70 !?5 S ^UTILITY($J,"EDD/NP",NDTEMP)="" + K ^UTILITY($J,"EDD/NP") Q +HD ;Node look-up + W !?3,"NODE ; PIECE",?20,"FLD NUM",?42,"FIELD NAME" + W !?3,"------------",?20,"-------",?32,"------------------------------" + Q +GLOBAL ;Find File when user enters global + K ^UTILITY($J) S (FLAGGL,FLAGGL1)=0 + I '$D(^UTILITY("EDD/GL")) W *7,!?25,"You have no data in ^UTILITY(""EDD/GL""). You must run",!?25,"option 10, List Globals in ASCII Order, before you",!?25,"can do a lookup on a global." S FLAGGL=1 Q + I $D(^UTILITY("EDD/GL",X)) S ZNUM=$P(^(X),U),ZNAM=$P(^(X),U,2),ZGL=X Q + S XX=X F I=1:1 S XX=$O(^UTILITY("EDD/GL",XX)) Q:XX=""!($E(XX,1,$L(X))'=X) D GLLIST I I#5=0 D GLPAGE Q:FLAGGL!FLAGGL1 + I '$D(^UTILITY($J)) W *7," ??" S FLAGGL=1 + Q:FLAGGL + I 'FLAGGL1 S I=(I-1) D GLPAGE1 Q:FLAGGL + I Z1>I F II=(I+1):1:Z1 S XX=$O(^UTILITY("EDD/GL",XX)) Q:XX=""!($E(XX,1,$L(X))'=X) S ^UTILITY($J,II)=$P(^UTILITY("EDD/GL",XX),U)_"\~"_$P(^(XX),U,2)_"\~"_XX + I '$D(^UTILITY($J,Z1)) W *7," ??" S FLAGGL=1 Q + S ZNUM=$P(^UTILITY($J,Z1),"\~"),ZNAM=$P(^(Z1),"\~",2),ZGL=$P(^(Z1),"\~",3) + I '$D(^DD(ZNUM)) W *7," ?? This file has been deleted." S FLAGGL=1 ;Check to see if file still exists + Q +GLLIST ;List Globals + I I=1 W !?28,"FILE NUM",?38,"FILE NAME (Truncated to 32)",!?28,"--------",?38,"--------------------------------" + W !?3,$J(I,3)," ",XX,?28,$J($P(^UTILITY("EDD/GL",XX),U),8),?38,$E($P(^(XX),U,2),1,32) + S ^UTILITY($J,I)=$P(^UTILITY("EDD/GL",XX),U)_"\~"_$P(^(XX),U,2)_"\~"_XX + Q +GLPAGE ; + W !,"TYPE '^' TO STOP, OR",!,"CHOOSE NUMBER: " + R Z1:DTIME S:'$T Z1="^" I Z1="?" W " Enter a number from left hand column.." G GLPAGE + S:Z1["^" FLAGGL=1 I +Z1>0 S FLAGGL1=1 + Q +GLPAGE1 ; + W !,"TYPE '^' TO STOP, OR",!,"CHOOSE NUMBER: " + R Z1:DTIME S:'$T Z1="^" I "^"[Z1!(+Z1'>0) S FLAGGL=1 + I Z1="?" W " Enter a number from left hand column.." G GLPAGE1 + Q diff --git a/XBHEDDH1.m b/XBHEDDH1.m new file mode 100644 index 0000000..5d9b84c --- /dev/null +++ b/XBHEDDH1.m @@ -0,0 +1,74 @@ +XBHEDDH1 ;402,DJB,10/23/91,EDD - Help Text - Main Menu + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;;David Bolduc - Togus, ME + ;;Called by XBHEDD1 + D INIT G:FLAGQ EX + I FLAGP,IO'=IO(0) W !!! + F I=1:1 S TEXT=$P($T(TXT+I),";;;",2) Q:TEXT="***" W !,TEXT I $Y>SIZE D PAGE Q:FLAGQ + I 'FLAGQ D ^XBHEDDH2 +EX ; + K TEXT Q +TXT ;Start of text + ;;; E D D - Electonic Data Dictionary + ;;; Version 2.2 David Bolduc Togus,ME + ;;;============================================================================== + ;;; HELP [] HELP [] HELP [] HELP [] HELP [] HELP [] HELP [] HELP + ;;;============================================================================== + ;;; NOTE: When you're in EDD, enter '?' at any prompt for help. + ;;; + ;;; A) E N T R Y P O I N T S: + ;;; + ;;; DO ^XBHEDD - Main entry point. At 'Select FILE:' prompt + ;;; enter File Name, File Number, or File Global + ;;; in the form '^DG' or '^RA('. + ;;; DO GL^XBHEDD - Gives listing of your system's globals sorted + ;;; in ASCII order, including file number and name. + ;;; DO PRT^XBHEDD - Bypasses opening screen and suppressess some page + ;;; feeds. Use if you're on a printing/keyboard device + ;;; such as a counsol. + ;;; DO DIR^XBHEDD - Bypasses opening screen. + ;;; + ;;; B) M E N U O P T I O N S: + ;;; + ;;; 1) Cross References - An '*' in the far left column indicates this + ;;; XREF can be used for lookup purposes. If you + ;;; concantenate the global shown on the Main Menu + ;;; screen with this XREF, there will be data. + ;;; + ;;; 2) Pointers To This File - Lists all files that point to this file. + ;;; + ;;; 3) Pointers From This File - Lists all fields in this file that are + ;;; pointers, and the files they point to. An 'M' in + ;;; the far left column indicates the pointing field + ;;; is a multiple. Use 'Trace a Field' to determine + ;;; it's path. + ;;; + ;;; 4) Groups - In Filenanager Groups are a shorthand way for a user to + ;;; call up several fields at once for Print or + ;;; Entry/Edit purposes. Also, some programmers + ;;; use Groups to keep track of locally added/alterred + ;;; fields. See VA FILEMAN USER'S MANUAL to learn + ;;; how to use Groups. + ;;; + ;;; 5) Trace a Field - Displays the pathway to fields that are decendent + ;;; from a multiple. + ;;; Example: When looking at PATIENT file, you type + ;;; 'MOV' at the 'Enter Field Name:' prompt. Trace + ;;; a Field will display: + ;;; 401 Admission Date/Time + ;;; 5 Treating Specialty + ;;; 1000 Movement Number + ;;; This is the pathway to the MOVEMENT NUMBER field. + ;;; You can now select 'I' and type in the field + ;;; number of each field in the path. You will get + ;;; the Individual Field Listing for the MOVEMENT + ;;; NUMBER field. + ;;;*** +PAGE ; + I FLAGP,IO'=IO(0) W @IOF,!!! Q + R !!?2," to continue, '^' to quit: ",XX:DTIME S:'$T XX="^" S:XX["^" FLAGQ=1 I FLAGQ Q + W @IOF Q +INIT ; + I FLAGP,IO=IO(0),IOSL>25 D SCROLL^XBHEDD7 Q:FLAGQ + I FLAGP W:IO'=IO(0) " Printing.." U IO + W @IOF Q diff --git a/XBHEDDH2.m b/XBHEDDH2.m new file mode 100644 index 0000000..de410b3 --- /dev/null +++ b/XBHEDDH2.m @@ -0,0 +1,58 @@ +XBHEDDH2 ;402,DJB,10/23/91,EDD - Help Text - Main Menu cont. + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;;David Bolduc - Togus, ME + F I=1:1 S TEXT=$P($T(TXT+I),";;;",2) Q:TEXT="***" W !,TEXT I $Y>SIZE D PAGE Q:FLAGQ + Q +TXT ; + ;;; + ;;; 6) Individual Field Summary - Lists contents of the Data Dictionary + ;;; for selected field. This option is equivalent + ;;; to Filemanager's LIST FILE ATTRIBUTES. + ;;; + ;;; 7) Field Global Location - List of all fields and their global + ;;; location (NODE;PIECE). See the 'HELP' that's + ;;; available in this option. + ;;; + ;;; 8) Templates - Lists Print, Sort, and Input templates. If + ;;; listing is too long for any type, you may + ;;; enter 'S' and skip over to next type. + ;;; + ;;; 9) File Description - Narrative describing the selected file. + ;;; + ;;; 10) List Globals In ASCII Order - Gives listing of your system's globals + ;;; sorted in ASCII order. Includes file number + ;;; and name. Example: If you are looking at the + ;;; RADIOLOGY PATIENT file, the Main Menu screen + ;;; shows it's data global as ^RADPT. If you + ;;; wanted to identify other Radiology files, + ;;; you would use this option and start the + ;;; listing at ^R. + ;;; + ;;; 11) File Characteristics - Displays post-selection actions, special + ;;; look-up programs, and identifiers. For more + ;;; information on any of these topics see Chapter 5 + ;;; Section D of the VA Fileman Programmers' manual + ;;; (Version 18). + ;;; + ;;; 12) Printing On/Off - Allows you to send screens to a printer. You will + ;;; be offered the DEVICE: prompt. Enter printer. + ;;; After , Main Menu will reappear and + ;;; PRINTING STATUS, in the top half of the screen, + ;;; will be set to 'ON'. You then select a Main + ;;; Menu option and output will go to the selected + ;;; device. When you return to the Main Menu, + ;;; PRINTING STATUS will be 'OFF'. To print again + ;;; you must select Printing On/Off option again + ;;; to reset PRINTING STATUS to 'ON'. If PRINTING + ;;; STATUS is 'ON' you may turn it off by selecting + ;;; Printing On/Off option again. To slave + ;;; print, enter '0;;60' at the DEVICE: prompt. + ;;; + ;;; NOTE: Since all screens are designed to be + ;;; displayed on a CRT, printing to a 10 pitch, + ;;; 80 margin printer looks best. + ;;;*** +PAGE ; + I FLAGP,IO'=IO(0) W @IOF,!!! Q + R !!?2," to continue, '^' to quit: ",XX:DTIME S:'$T XX="^" S:XX="^" FLAGQ=1 I FLAGQ Q + W @IOF Q diff --git a/XBHEDDH3.m b/XBHEDDH3.m new file mode 100644 index 0000000..0530c5d --- /dev/null +++ b/XBHEDDH3.m @@ -0,0 +1,56 @@ +XBHEDDH3 ;402,DJB,10/23/91,EDD - Help Text - Field Global Location + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;;David Bolduc - Togus, ME + ;;Called by XBHEDD1 + W @IOF + F I=1:1 S TEXT=$P($T(TXT+I),";;;",2) Q:TEXT="***" W !,TEXT I $Y>SIZE D PAGE Q:FLAGQ + I 'FLAGQ D ^XBHEDDH4 +EX ; + K TEXT I 'FLAGQ D PAUSE + Q +TXT ; + ;;; INPUT EFFECT + ;;;========================================================================== + ;;; + ;;; 1. '^' Exit back to Main Menu. + ;;; + ;;; 2. 'B' Back up to previous screen. + ;;; + ;;; 3. 'n' Typing a number here allows you to jump to that screen. + ;;; In the lower right hand corner of the screen, you will + ;;; see 2 numbers: TOP and CUR. TOP is the highest screen + ;;; you have to. CUR is the current screen you + ;;; are viewing. You can only jump between the first and TOP + ;;; screen. As an example, if you selected the 'Field Global + ;;; Location' option and then hit 6 times, TOP would + ;;; be equal to 6 and CUR would be equal to 6. Now you can jump + ;;; to any screen between 1 and 6. If you entered '2' and , + ;;; you would jump to screen 2. TOP would still be equal to 6 but + ;;; CUR would now be 2. If you then hit 'B' to back up 1 screen, + ;;; TOP would be 6 and CUR would be 1. If you now wanted to return + ;;; to TOP (screen 6), you would type a '6' and this page + ;;; would now be displayed. TOP and CUR would both be equal + ;;; to 6 again. + ;;; + ;;; 4. 'I' Allows you to zoom in on an individual field. It prompts you + ;;; for a field and then gives you the Individual Field Summary + ;;; for that field. When using 'I', you must start at the top + ;;; of the multiple. For example, if you were looking at the + ;;; Patient file and you had selected 'Admission Date' as the + ;;; starting point for Field Global Location and you + ;;; thru 2 screens, you would see the field Treating Specialty. + ;;; To view the Individual Field Summary for this field you would + ;;; have to first select Admission Date and then Treating Specialty. + ;;; This is made easier by the design of the Field Global Location + ;;; screens. Each layer of multiple fields is preceeded by + ;;; dashes that indicated their level. You trace these dashes + ;;; back to locate the starting point for each layer. You can + ;;; also use the Trace a Field option. + ;;;*** +PAGE ; + R !!?2," to continue, '^' to quit: ",XX:DTIME S:'$T XX="^" S:XX["^" FLAGQ=1 I FLAGQ Q + W @IOF Q +PAUSE ; + I $Y to continue..",XX:DTIME + Q diff --git a/XBHEDDH4.m b/XBHEDDH4.m new file mode 100644 index 0000000..17d86d1 --- /dev/null +++ b/XBHEDDH4.m @@ -0,0 +1,26 @@ +XBHEDDH4 ;402,DJB,10/23/91,EDD - Help Text - Field Global Location cont. + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;;David Bolduc - Togus, ME + F I=1:1 S TEXT=$P($T(TXT+I),";;;",2) Q:TEXT="***" W !,TEXT I $Y>SIZE D PAGE Q:FLAGQ + Q +TXT ; + ;;; + ;;; 5. 'N' Allows you to do a look up by global node. At the 'Select NODE:' + ;;; prompt type '?' to see all nodes, or enter node. If that + ;;; node is a multiple you will be asked for subnode.You will then + ;;; get a list of all fields that are contained by that node. + ;;; You may do an 'Individual Field Summary' on any of them. + ;;; Example: If you wanted to know what fields are contained + ;;; in ^DPT(34,"DA",3,"T",0) you would enter '^DPT' at + ;;; the 'Select FILE:' prompt, select option 7, enter + ;;; 'N' for node, and then enter the following: + ;;; Select NODE: 'DA' + ;;; Select 'DA' SUBNODE: 'T' + ;;; Select 'T' SUBNODE: '0' + ;;; EDD will now display all the fields contained in + ;;; the selected node and allow you to do an 'Individual + ;;; Field Summary'. + ;;;*** +PAGE ; + R !!?2," to continue, '^' to quit: ",XX:DTIME S:'$T XX="^" S:XX="^" FLAGQ=1 I FLAGQ Q + W @IOF Q diff --git a/XBHEDDM.m b/XBHEDDM.m new file mode 100644 index 0000000..5678e23 --- /dev/null +++ b/XBHEDDM.m @@ -0,0 +1,37 @@ +XBHEDDM ;402,DJB,10/23/91,EDD - Menu Driver + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;;David Bolduc - Togus ME +EN ;Entry Point + D HD + I FLAGP F I=1,8,2,9,3,10,4,11,5,12,6,13,7 S X=$T(OPT+I) Q:X="" W @$S(I<8:"!?7",1:"?41"),$S(I=5:"*",I=9:"*",I=12:"*",1:" "),$J(I,2)_") ",$P(X,";",3) + ;I FLAGP F I=1,6,11,2,7,12,3,8,13,4,9,5,10 S X=$T(OPT+I) Q:X="" W @$S(I<6:"!",I<11:"?29",1:"?58"),$S(I=5:"*",I=9:"*",I=12:"*",1:" "),$J(I,2)_") ",$P(X,";",3) ;3 Columns + E F I=1,8,2,9,3,10,4,11,5,12,6,13,7 S X=$T(OPT+I) Q:X="" W @$S(I<8:"!?7",1:"?41"),$J(I,2)_") ",$P(X,";",3) + ;E F I=1,6,11,2,7,12,3,8,13,4,9,5,10 S X=$T(OPT+I) Q:X="" W @$S(I<6:"!",I<11:"?29",1:"?58"),$J(I,2)_") ",$P(X,";",3) ;3 Columns + W ! +B R !?8,"Select OPTION: ",O:DTIME S:'$T O="^^" I "^"[O S FLAGM=1 G EX + I O="^^" S FLAGE=1 G EX + I O?1.N,O>0,O<14,$T(OPT+O)'="" G C + I O'?1.N D ALLCAPS F I=1:1 S X=$P($T(OPT+I),";",5) Q:X="" I $E(X,1,$L(O))=O W $E(X,$L(O)+1,80) S O=I G C + W *7,?30,"Enter Option number or name." G B +C S X=$T(OPT+O) D @$P(X,";",4) I FLAGG S FLAGG=0 G B ;FLAGG indicates no Groups or no Pointers. +EX K I,X,Y,ZHDR Q +ALLCAPS ; + F %=1:1:$L(O) S:$E(O,%)?1L O=$E(O,0,%-1)_$C($A(O,%)-32)_$E(O,%+1,999) + Q +HD ; + S ZHDR="M A I N M E N U" W !?(IOM-$L(ZHDR)\2),ZHDR W:FLAGP ?57,"[*=Opts not printable]" + W ! Q +OPT ;MENU OPTIONS + ;;Cross References;XREF^XBHEDD6;CROSS REFERENCES + ;;Pointers TO This File;PT^XBHEDD6;POINTERS + ;;Pointers FROM This File;PT^XBHEDD10;POINTERS FROM THIS FILE + ;;Groups;GRP^XBHEDD6;GROUPS + ;;Trace a Field;EN^XBHEDD8;TRACE A FIELD + ;;Individual Fld Summary;^XBHEDD3;INDIVIDUAL FIELD SUMMARY + ;;Field Global Location;EN^XBHEDD1;FIELD GLOBAL LOCATION + ;;Templates;EN^XBHEDD11;TEMPLATES + ;;File Description;DES^XBHEDD11;FILE DESCRIPTION + ;;Globals in ASCII Order;GL^XBHEDD10;LIST GLOBALS IN ASCII ORDER + ;;File Characteristics;CHAR^XBHEDD12;FILE CHARACTERISTICS + ;;Printing-On/Off;PRINTM^XBHEDD7;PRINTING - ON/OFF + ;;Help;^XBHEDDH1;HELP diff --git a/XBHELP.m b/XBHELP.m new file mode 100644 index 0000000..88a27b6 --- /dev/null +++ b/XBHELP.m @@ -0,0 +1,32 @@ +XBHELP ; IHS/ADC/GTH - DISPLAY HELP TEXT FROM ROUTINE ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; Display text from the named routine, beginning at the + ; named label. The fourth semi-colon piece is displayed. + ; If the third semi-colon piece is "@", the indirection + ; of the fourth semi-colon piece is written. The display + ; ends if null or "###" is returned. + ; + ; E.g: + ; + ; D HELP^XBHELP("LABEL","ROUTINE",0) will print the text + ; after LABEL: + ; + ; ROUTINE ; + ; LABEL ; + ; ;;Please enter what I think you should enter. + ; ;;@;*7 + ; ;;@;! + ; ;;### + ; +HELP(L,R,T) ;PEP - Display text at label L, routine R, tab T spaces (default 4). + Q:$D(ZTQUEUED) + S:$G(T)'?1.N T=4 + NEW X + W ! + F %=1:1 S X=$T(@L+%^@R) Q:($P(X,";",3)="###")!(X="") D + . I $P(X,";",3)="@" W @($P(X,";",4)) Q + . W !?T,$P(X,";",3) + .Q + Q + ; diff --git a/XBHFMAN.m b/XBHFMAN.m new file mode 100644 index 0000000..6f4e2ae --- /dev/null +++ b/XBHFMAN.m @@ -0,0 +1,109 @@ +XBHFMAN ; IHS/ADC/GTH - HELP FRAME MANUAL (1/2) ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; Print a help frame manual for an IHS application, using + ; OPTION descriptions and HELP FRAME texts in the namespace + ; of the application selected from the PACKAGE file. + ; + ; Information for the title and preface pages, and for + ; indexed words, is expected to be in a routine named + ; HFMN. The title page lines are expected to + ; begin at line TITLE+1, and the preface page at PREFACE+1. + ; Any words to be indexed are expected to begin at line + ; INDEX+1. See routine XBHFMAN2 for an example. + ; + ; If entered from the top, user is asked for application. + ; Entry point EN() must have the namespace of the application + ; as the parameter. That allows programmers to create their + ; own option and call it, without forcing user to select the + ; applcation. + ; + D HOME^%ZIS,DT^DICRW + NEW DIR,XBSEL + G EN1 + ; +EN(XBSEL) ;PEP ----- From application options, with namespace of application. + ; +EN1 ; + S DIC=9.4,DIC(0)="AEM",DIC("S")="I ""AB""[$E($P(^(0),U,2))" + I $D(XBSEL) S X=XBSEL,DIC(0)="",D="C" D IX^DIC I 1 + E D ^DIC + I Y<1 W !,"^DIC( LOOKUP FAILED." Q + S XBSEL=+Y +DEV ; + S %ZIS="OPQ" + D ^%ZIS + I POP S IOP=$I D ^%ZIS G K + G:'$D(IO("Q")) START + KILL IO("Q") + I $D(IO("S"))!($E(IOST)'="P") W *7,!,"Please queue to system printers." D ^%ZISC G DEV + S ZTRTN="START^XBHFMAN",ZTDESC="Help Frame Manual for "_$P(^DIC(9.4,XBSEL,0),U),ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL,ZTSAVE("XBSEL")="" + D ^%ZTLOAD + G:'$D(ZTSK) DEV +K ; + KILL XB,ZTSK + D ^%ZISC + D END^XBHFMAN1 + Q + ; +START ;EP ----- From TaskMan. + ; + I '$D(ZTQUEUED),'$D(IO("S")) U IO(0) D WAIT^DICD U IO + ; + NEW DIWL,DIWR,DIWF,DIRUT + NEW XBBM,XBCHAP,XBCONT,XBSAVX,XBTM,XBTITL,XBPG,XBHDR,XBHDRE,XBHDRO,XBDASH,XBSTRIP,XBNOHDR,XBIENI,XBLEVEL,XBNAME,XBNS + ; + KILL ^TMP("XBHFMAN",$J),^UTILITY($J) + ; + ; S X=$O(^DIC(9.4,XBSEL,22,"B","0.5",0)) + ; I X S %=0 F S %=$O(^DIC(9.4,XBSEL,22,X,"P",%)) Q:'% S Y=^(%,0) I $L(Y) S ^TMP("XBHFMAN-I",$J,Y)="" + ; + ; ----- Set namespace and read indexed words into ^TMP("XBHFMAN-I",$J. + S XBNS=$P(^DIC(9.4,XBSEL,0),U,2) + F X=1:1 S Y=$P($T(@"INDX"+X^@(XBNS_"HFMN")),";",3) Q:'$L(Y) S ^TMP("XBHFMAN-I",$J,Y)="" + ; + S DIWL=10,DIWR=74,DIWF="W" + S XBBM=IOSL-5,XBTM=6,XBTITL=$P(^DIC(9.4,XBSEL,0),U)_" HELP FRAME MANUAL",XBPG=0,XBHDR="Index",(XBHDRE,XBHDRO)="",XBDASH="",$P(XBDASH,"-",81)="",XBDASH=$E(XBDASH,DIWL,DIWR) + S XBSTRIP=^DD("FUNC",$O(^DD("FUNC","B","STRIPBLANKS",0)),1) + S (XBCHAP,XBLEVEL)=1,(XBCONT,XBHDR,XBPG,XBNOHDR)=0 + ; + ; ----- Set primary menu as chapter 1. + D SETTMP($O(^DIC(19,"B",XBNS_"MENU",0)),"1") + ; + S XBNAME=XBNS + F S XBNAME=$O(^DIC(19,"B",XBNAME)) Q:$E(XBNAME,1,$L(XBNS))'=XBNS I '$D(^DIC(19,"AD",$O(^DIC(19,"B",XBNAME,0)))) S ^TMP("XBHFMAN-M",$J,XBNAME)="" + KILL ^TMP("XBHFMAN-M",$J,XBNS_"MENU") + D MENU($O(^DIC(19,"B",XBNS_"MENU",0))) + ; + S XBCHAP=1,XBNAME="" + F S XBNAME=$O(^TMP("XBHFMAN-M",$J,XBNAME)) Q:XBNAME="" S XBCHAP=+$P(XBCHAP,".")+1,XBLEVEL=1 D SETTMP($O(^DIC(19,"B",XBNAME,0)),XBCHAP),MENU($O(^DIC(19,"B",XBNAME,0))) + ; + U IO + D ^XBHFMAN1 + Q + ; + ; +MENU(I) ; ----- Assign chapter number to OPTIONs. Recurse if OPTION is a menu. + Q:'$G(I) + NEW X + S X=0,XBLEVEL=XBLEVEL+1 + F S X=$O(^DIC(19,I,10,X)) Q:'X S $P(XBCHAP,".",XBLEVEL)=$P(XBCHAP,".",XBLEVEL)+1,Y=+^(X,0) D SETTMP(Y,XBCHAP) I $$DATA(Y,0,4)="M" D MENU(Y) S $P(XBCHAP,".",XBLEVEL)=0,XBLEVEL=XBLEVEL-1 + Q + ; +DATA(I,N,P) ; + Q $P(^DIC(19,I,N),U,P) + ; + ; + ; +RTRN ;EP ----- If interactive, ask usr to press RETURN. + I IOST["C-",'$D(IO("S")),$$DIR^XBDIR("E","Press RETURN To Continue or ""^"" to exit","","","","",1) + Q + ; +SETTMP(I,N) ; ----- Set option IEN and chapter designation into ^TMP. + NEW X,Y + I '$D(ZTQUEUED),'$D(IO("S")) U IO(0) W "." U IO + F %=1:1 I '$P(N,".",%) S N=$P(N,".",1,%-1) Q + S ^(0)=$G(^TMP("XBHFMAN",$J,0))+1 + S ^TMP("XBHFMAN",$J,^TMP("XBHFMAN",$J,0))=I_"^"_N + Q + ; diff --git a/XBHFMAN1.m b/XBHFMAN1.m new file mode 100644 index 0000000..8267c93 --- /dev/null +++ b/XBHFMAN1.m @@ -0,0 +1,126 @@ +XBHFMAN1 ; IHS/ADC/GTH - HELP FRAME MANUAL (2/2) ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; ----- Print Title and Preface page. + ; + ; + S X=XBNS_"HFMN" + X ^%ZOSF("TEST") + E G MAIN + S XBNOHDR=1 + NEW A,B + F A="TITLE","PREFACE" Q:$D(DIRUT) D ^DIWW,TOF F B=1:1 S X=$T(@A+B^@(XBNS_"UMAN")) Q:$L($P(X,";",1))>1 D PR($P(X,";",3)) Q:$D(DIRUT) + ; + I $D(DIRUT) G HATOUT + D ^DIWW + ; +MAIN ; ----- $ORDER thru the list of OPTIONS, and print them. + S (XBNAME,XBNOHDR)=0 + F S XBNAME=$O(^TMP("XBHFMAN",$J,XBNAME)) Q:'XBNAME D MAKEHDRS,TOF Q:$D(DIRUT) D HDR(XBNAME),DESC(+^TMP("XBHFMAN",$J,XBNAME)),HF($P($G(^DIC(19,+^TMP("XBHFMAN",$J,XBNAME),0)),U,7)),^DIWW + I $D(DIRUT) G HATOUT + ; +INDEX ; ----- Print the index. + S XBHDR="Index" + D TOF + I $D(DIRUT) G HATOUT + W !!! + S X="|NOWRAP||SETTAB(""C"")||TAB|INDEX" + D ^DIWP,^DIWW + W !!! + D CONT("INDEX^^"_XBPG) + S (XB,XBCONT)="",$P(XBCONT,".",81)="" + F S XB=$O(^TMP("XBHFMAN-INDEX",$J,XB)) Q:XB="" S X="" D Q:$D(DIRUT) + .F XBX=0:0 S XBX=$O(^TMP("XBHFMAN-INDEX",$J,XB,XBX)) S X=X_XBX_"," I '$O(^(XBX)) D Q + ..S X=XB_"..."_$E(XBCONT,1,DIWR-DIWL-$L(XB)-3-$L(X))_$E(X,1,$L(X)-1) + ..S XBSAVX=X + ..F S X=$E(XBSAVX,1,DIWR-DIWL),XBSAVX=$E(XBSAVX,DIWR-DIWL+1,$L(XBSAVX)) Q:'$L(X) D TOF:$Y>XBBM Q:$D(DIRUT) D ^DIWP + ..Q + .Q + I $D(DIRUT) G HATOUT + D ^DIWW,RTRN^XBHFMAN + I $D(DIRUT) G HATOUT + ; +CONTENTS ; ----- Print the table of Contents. + S XBNOHDR=1 + W @IOF,!!!!! + S X="|SETTAB(""C"")||TAB|CONTENTS" + D ^DIWP,^DIWW + W !! + S XB=0 + F S XB=$O(^TMP("XBHFMAN-CONTENTS",$J,XB)) Q:'+XB S X=^(XB),X=$P(X,U)_" "_$P(X,U,2)_$E(XBCONT,1,DIWR-DIWL-$L(X)+1)_$P(X,U,3) D TOF:$Y>XBBM Q:$D(DIRUT) D ^DIWP + I $D(DIRUT) G HATOUT + D ^DIWW,RTRN^XBHFMAN + I $D(DIRUT) G HATOUT +END ;EP - Paginate, close, kill, quit. + W @IOF +HATOUT ; + D ^%ZISC + KILL ^TMP("XBHFMAN",$J),XB,XBBM,XBCHAP,XBCONT,XBODD,XBHDR,XBIEN,XBPARA,XBPG,XBROOT,XBTITL,XBTM,XBX,XBY,DIC,DIWF,DIWL,DIWR + Q + ; +PR(X) ;EP - Process one line of text. + NEW A,B,I,N,Y + I X="|TOP|" D TOF Q + D INDX(X),^DIWP,TOF:$Y>XBBM + Q + ; +INDX(X) ; ----- Parse/capitalize one line of text. Check for indexed words. + Q:'$D(XBPG) + NEW Y,Z + S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + S X=$TR(X,"~`!@#$%^&*()_-+=|\{[}]:;""""'<,>.?/"," ") + X XBSTRIP + F S %=$F(X," ") Q:'% S X=$E(X,1,%-2)_$E(X,%,$L(X)) + F %=1:1 S Y=$P(X," ",%) Q:Y="" I $D(^TMP("XBHFMAN-I",$J,Y)) S ^TMP("XBHFMAN-INDEX",$J,Y,XBPG)="" + Q + ; +HDR(XB) ; ----- Print a chapter heading. + S %=$P(^TMP("XBHFMAN",$J,XB),U,2),XB=%_U_$P($G(^DIC(19,+^TMP("XBHFMAN",$J,XB),0)),U,2) + F X="|SETTAB(""C"")||TAB|Chapter "_$P(XB,U),"|SETTAB(""C"")||TAB|"_$P(XB,U,2) D ^DIWP + W !! + D CONT($P(XB,U)_U_$P(XB,U,2)_U_XBPG) + Q + ; +TOF ;EP ----- Move to bottom of page, print footer, paginate, print header. + I XBNOHDR D RTRN^XBHFMAN Q:$D(DIRUT) W @IOF Q + F Q:$Y>XBBM W ! + I XBPG W !?(DIWL-1),XBDASH,!,?$S(XBODD:DIWR-$L(XBTITL),1:DIWL-1),XBTITL + D RTRN^XBHFMAN + I $D(DIRUT) Q + W @IOF + S XBPG=XBPG+1,XBODD=XBPG#2 + F Q:$Y=(XBTM-2) W ! + W ?$S(XBODD:DIWR-$L("Page "_XBPG),1:DIWL-1),"Page ",XBPG + I '(XBHDR="Index") W !?DIWL-1,$S(XBODD:XBHDRO,1:XBHDRE) + W !?(DIWL-1),XBDASH,!! + Q + ; +MAKEHDRS ; ----- Make headers for odd and even pages. + S (XBHDRE,XBHDRO)=$P($G(^DIC(19,+^TMP("XBHFMAN",$J,XBNAME),0)),U,2) + S XBCHAP=$P(^TMP("XBHFMAN",$J,XBNAME),U,2) + F %=1:1 I '$P(XBCHAP,".",%) S XBCHAP=$P(XBCHAP,".",1,%-1) Q + S XBHDRO=XBHDRO_$J("",DIWR-DIWL-$L(XBHDRO)-$L("Chapter "_XBCHAP)+1)_"Chapter "_XBCHAP + S XBHDRE="Chapter "_XBCHAP_$J("",DIWR-DIWL-$L(XBHDRE)-$L("Chapter "_XBCHAP)+1)_XBHDRE + Q + ; +CONT(X) ; ----- Add chapter number, title, and page number to list. + S XBCONT=XBCONT+1,^TMP("XBHFMAN-CONTENTS",$J,XBCONT)=X + Q + ; +DESC(A) ; ----- Print descriptions of the OPTIONs as the first of the chapter. + NEW B,I,N,Y + I '$D(^DIC(19,A,1)) D PR("") Q + S B=0 + F S B=$O(^DIC(19,A,1,B)) Q:'B D PR(^(B,0)) Q:$D(DIRUT) + Q + ; +HF(A) ; ----- Print the HELP FRAME text. + I 'A D PR("") Q + I '$D(^DIC(9.2,A,1)) D PR("") Q + NEW B,I,N,Y + S B=0 + F S B=$O(^DIC(9.2,A,1,B)) Q:'B D PR(^(B,0)) Q:$D(DIRUT) + ; ----- Print any tied HELP FRAMEs. + I $O(^DIC(9.2,A,2,0)) S B=0 F S B=$O(^DIC(9.2,A,2,B)) Q:'B D HF($P($G(^(B,0)),U,2)) Q:$D(DIRUT) + Q + ; diff --git a/XBHFMAN2.m b/XBHFMAN2.m new file mode 100644 index 0000000..0f6703c --- /dev/null +++ b/XBHFMAN2.m @@ -0,0 +1,105 @@ +XBHFMAN2 ; IHS/ADC/GTH - HELP FRAME MANUAL INFO EXAMPLE ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; +TITLE ;EP + ;; + ;; ---------------------------------------------------------- + ;; + ;; DRAFT ** DRAFT ** DRAFT ** DRAFT ** DRAFT ** + ;; + ;; GO DUCKS! + ;; + ;; + ;; INDIAN HEALTH SERVICE + ;; + ;; + ;; + ;; + ;; + ;; RESOURCE AND PATIENT MANAGEMENT SYSTEM + ;; + ;; + ;; RPMS ADP SYSTEMS HELP FRAME'S MANUAL + ;; + ;; + ;; + ;; + ;; ********************************** + ;; * CHS DENIED/DEFERRED SERVICES * + ;; ********************************** + ;; + ;; + ;; + ;; + ;; VERSION 2.1 + ;; + ;; + ;; DECEMBER 1994 + ;; + ;; Office of Information Resources Management + ;; Indian Health Service + ;; Albuquerque, New Mexico + ;; + ;; DRAFT ** DRAFT ** DRAFT ** DRAFT ** DRAFT ** + ;; + ;; ---------------------------------------------------------- +PREFACE ;EP + ;; + ;; + ;; + ;; + ;; Preface + ;; + ;; + ;;This Help Frame's Manual describes the procedures necessary to enter + ;;CHS Denials and Deferred Services information into the local + ;;facility's RPMS computer. + ;; + ;;Please address corrections and/or suggested changes to the + ;;software and associated documentations to: + ;; + ;; Division of Systems Development / OIRM + ;; IHS Headquarters West + ;; 5300 Homestead Road NE + ;; Albuquerque NM 87110 + ;; + ;; 505-837-4189 + ;; +INDX ;EP + ;;ABBREVIATION + ;;ACCRUED + ;;ADDRESS + ;;ALTERNATE + ;;AMOUNT + ;;APPEAL + ;;AREA + ;;CANCEL + ;;CAPTIONED + ;;CATEGORY + ;;CATEGORIES + ;;CHARGES + ;;CHART + ;;CLOSING + ;;CONTROL + ;;DIRECTOR + ;;DOCUMENT + ;;FACILITY + ;;ISSUE + ;;LETTER + ;;LETTERHEAD + ;;MEDICAL + ;;NEW + ;;NUMBER + ;;PATIENT + ;;PRIMARY + ;;PRIORITY + ;;PRIORITIES + ;;PROVIDER + ;;REPORT + ;;RESOURCE + ;;SERVICE + ;;SIGNATURE + ;;STREET + ;;SUPPLEMENTAL + ;;TABLE + ;;UNIT diff --git a/XBINIT.m b/XBINIT.m new file mode 100644 index 0000000..b764887 --- /dev/null +++ b/XBINIT.m @@ -0,0 +1,49 @@ +XBINIT ; IHS/ADC/GTH - XB/ZIB V 3.0 INITS ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + K DIF,DIFQ,DIFQR,DIFQN,DIK,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DIFROM,DFR,DTN,DIX,DZ,DIRUT,DTOUT,DUOUT + S DIOVRD=1,U="^",DIFQ=0,DIFROM="3.0" W !,"This version (#3.0) of 'XBINIT' was created on 07-FEB-1997" + W !?9,"(at GEORGE'S PC, by VA FileMan V.21.0)",! + I $D(^DD("VERSION")),^("VERSION")'<21 G GO + ;W !,"FIRST, I'LL FRESHEN UP YOUR VA FILEMAN...." D N^DINIT + I ^DD("VERSION")<21 W !,"but I need version 21 of the VA FileMan!" G Q +GO ; + W !,"I HAVE TO RUN AN ENVIRONMENT CHECK ROUTINE." D PKG,^XBPRE Q:'$D(DIFQ) D NOW^%DTC S DIFROM("PRE")=% +EN ; ENTER HERE TO BYPASS THE PRE-INIT PROGRAM + S DIFQ=0 K DIRUT,DTOUT,DUOUT + F DIFRIR=1:1:1 S DIFRRTN="^XBINIT"_$E("5",DIFRIR) D @DIFRRTN + W:0 !,"I AM GOING TO SET UP THE FOLLOWING FILE:" F I=1:2:0 S DIF(I)=^UTILITY("DIF",$J,I) D 1 G Q:DIFQ!$D(DIRUT) K DIF(I) + S DIFROM="3.0" D PKG:'$D(DIFROM(0)),^XBINIT1 G Q:'$D(DIFQ) S DIK(0)="AB" + F DIF=1:2:0 S %=^UTILITY("DIF",$J,DIF),DIK=$P(%,";",5),N=$P(%,";",3),D=$P(%,";",4)_U_N D D K DIFQ(N) + K DIFQR D ^XBINIT2,^XBINIT3 + L S DUZ=DIDUZ W:0 !,"NO"_$P("TE THAT FILE",U,DSEC)_" SECURITY-CODE PROTECTION HAS BEEN MADE" + D ^XBPOST,NOW^%DTC S DIFROM("INIT")=% + I DIFROM F DIF=1:2:0 S %=^UTILITY("DIF",$J,DIF),N=+$P(%,";",3) I N,$P(%,";",8)="y" S ^DD(N,0,"VR")=DIFROM + I DIFROM(0)>0 F %="PRE","INI","INIT" S:$D(DIFROM(%)) $P(^DIC(9.4,DIFROM(0),%),U,2)=DIFROM(%) + I $G(DIFQN) S $P(^(0),U,3,4)=$P(DIFQN,U,2)_U_($P(^DIC(0),U,4)+DIFQN) K DIFQN + I DIFROM,$D(^%ZTSK) S X="XBINIS" X ^%ZOSF("TEST") D:$T PAC^XBINIS($T(IXF),.DIFROM) + S:DIFROM(0)>0 ^DIC(9.4,DIFROM(0),"VERSION")=DIFROM G Q^DIFROM0 +D S:$D(^DIC(+N,0))[0 ^(0)=D S X=$D(@(DIK_"0)")),^(0)=D_U_$S(X#2:$P(^(0),U,3,9),1:U) + S DIFQR=DIFQR(+N) I ^DD("VERSION")>17.5,$D(^DD(+N,0,"DIK"))#2 S X=^("DIK"),Y=+N,DMAX=^DD("ROU") D EN^DIKZ + I DIFQR D IXALL^DIK:$O(@(DIK_"0)")) W "." + Q +R G REP^XBINIT2 + ; +1 S N=+$P(DIF(I),";",3),DIF=$P(DIF(I),";",4),S=$P(DIF(I),";",5) + W !!?3,N,?13,DIF,$P(" (Partial Definition)",U,$P(DIF(I),";",6)),$P(" (including data)",U,$P(DIF(I),";",13)="y") S Z=$S($D(^DIC(N,0))#2:^(0),1:"") + I Z="" S DIFQ(N)=1,DIFQN=$G(DIFQN)+1_U_N G S + I $L($P(Z,DIF)) W $C(7),!,"*BUT YOU ALREADY HAVE '",$P(Z,U),"' AS FILE #",N,"!" D R Q:DIFQ G S:$D(DIFKEP(N)),1 + S DIFQ(N)=$P(DIF(I),";",7)'="n" + I $L(Z) W $C(7),!,"Note: You already have the '",$P(Z,U),"' File." S DIFQ(0)=1 + S %=$E(^UTILITY("DIF",$J,I+1),4,245) I %]"" X % S DIFQ(N)=$T W:'$T !,"Screen on this Data Dictionary did not pass--DD will not be installed!" G S + I $L(Z),$P(DIF(I),";",10)="y" S DIR("A")="Shall I write over the existing Data Definition",DIR("??")="^D DD^DIFROMH1",DIR("B")="YES",DIR(0)="Y" D ^DIR S DIFQ(N)=Y +S S DIFQR(N)=0 Q:$P(DIF(I),";",13)'="y"!$D(DIRUT) + I $P(DIF(I),";",15)="y",$O(@(S_"0)"))>0 S DIF=$P(DIF(I),";",14)="o",DIR("A")="Want my data "_$P("merged with^to overwrite",U,DIF+1)_" yours",DIR("??")="^D DTA^DIFROMH1",DIR(0)="Y" D ^DIR S DIFQR(N)=$S('Y:Y,1:Y+DIF) Q + S %=$P(DIF(I),";",14)="o" W !,$C(7),"I will ",$P("MERGE^OVERWRITE",U,%+1)," your data with mine." S DIFQR(N)=%+1 + Q +Q W $C(7),!!,"NO UPDATING HAS OCCURRED!" G Q^DIFROM0 + ; +PKG S X=$P($T(IXF),";",3),DIC="^DIC(9.4,",DIC(0)="",DIC("S")="I $P(^(0),U,2)="""_$P(X,U,2)_"""",X=$P(X,U) D ^DIC S DIFROM(0)=+Y K DIC + Q + ; +IXF ;;IHS/VA UTILITIES^XB;0 diff --git a/XBINTEG.m b/XBINTEG.m new file mode 100644 index 0000000..fd52d10 --- /dev/null +++ b/XBINTEG.m @@ -0,0 +1,66 @@ +XBINTEG ; ROUTINE INTEGRITY CHECK + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; This routine calls ^%RSEL to select a set of routines and generates + ; an integrity checking routine for the selected routines. The user + ; is asked to enter the name of the generated routine. + ; +START ; + NEW BYTE,COUNT,QUIT,RTDATE,RTN,RTNAME,VERSION + K ^UTILITY($J),^UTILITY("XBINTEG",$J) + D ^XBKVAR + ;D ^%RSEL K QUIT + X ^%ZOSF("RSEL") + I $O(^UTILITY($J,""))="" D EOJ Q + S DIR(0)="F^5:8^K:X'?1U.U X",DIR("A")="Enter name of routine to be generated: ",DIR("?")="Example: APCDINTG" D ^DIR K DIR + I $D(DIRUT) D EOJ Q + S RTNAME=Y + D CHECKRTN + I 'Y 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 + I $D(DIRUT) D EOJ Q + S VERSION=" ;;"_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 VERSION=VERSION_";"_X + 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 RTDATE=Y + S VERSION=VERSION_";;"_Y + F %=1:1:11 S X=$P($T(@("LINE"_%)),";;",2,99),@("XBINTEG("_%_")=X") + F %=1:1:3 S X=$P($T(@("CODE"_%)),";;",2,99),@("XBINTEG(""CODE"_%_""")=X") + K %,X,Y + X XBINTEG(1) + Q + ; +CHECKRTN ; + S Y=1 + Q:'$D(^DD("OS"))#2 + Q:'$D(^DD("OS",^DD("OS"),18))#2 + S X=RTNAME X ^(18) + E Q + S DIR(0)="YO",DIR("A")="Routine already exists. Want to recreate it",DIR("B")="NO" D ^DIR K DIR + I $D(DIRUT) S Y=0 Q + Q + ; +EOJ ; + K %,X,Y,XBINTEG,^UTILITY($J) + K DTOUT,DUOUT,DIRUT,DIROUT + Q + ; + ; The only good thing I can say about the following is that it works. +LINE1 ;;X XBINTEG(2),XBINTEG(6),XBINTEG(11) +LINE2 ;;S RTN="" F S RTN=$O(^UTILITY($J,RTN)) Q:RTN="" W !,RTN ZL @RTN S (BYTE,COUNT)=0 S X=$T(+1),X=$P(X," [ ",1) X XBINTEG(4),XBINTEG(3),XBINTEG(5) +LINE3 ;;F I=2:1 S X=$T(+I) Q:X="" X XBINTEG(4) +LINE4 ;;F J=1:1 S Y=$E(X,J) Q:Y="" S BYTE=BYTE+1,COUNT=COUNT+$A(Y) +LINE5 ;;S ^UTILITY("XBINTEG",$J,RTN)=BYTE_"^"_COUNT +LINE6 ;;ZR S X=RTNAME_" ;INTEGRITY CHECKER;"_RTDATE ZI X ZI VERSION ZI " ;" ZI "START ;" ZI " NEW BYTE,COUNT,RTN" ZI " K ^UTILITY($J)" X XBINTEG(7),XBINTEG(8),XBINTEG(9),XBINTEG(10) ZS @RTNAME +LINE7 ;;F I=1:1:3 S V="CODE"_I S Z=XBINTEG(V) Q:Z="" ZI Z +LINE8 ;;ZI " Q" ZI " ;" ZI "LINE1 ;;X XBINTEG(2),XBINTEG(6)" F I=2:1:4 S Z="LINE"_I_" ;;"_XBINTEG(I) ZI Z +LINE9 ;;ZI "LINE5 ;;S B=$P(^(RTN),""^"",1),C=$P(^(RTN),""^"",2) I B'=BYTE!(C'=COUNT) W "" has been modified""" ZI "LINE6 ;;K XBINTEG,B,C,I,J,R,X,Y" ZI " ;" ZI "LIST ;" +LINE10 ;;S RTN="" F S RTN=$O(^UTILITY("XBINTEG",$J,RTN)) Q:RTN="" S Z=^(RTN),Z=" ;;"_RTN_"^"_Z ZI Z +LINE11 ;;K %,XBINTEG,DTOUT,DUOUT,DIRUT,DIROUT,I,J,V,X,Y,Z,^UTILITY($J),^UTILITY("XBINTEG",$J) +CODE1 ;; F I=1:1 S X=$T(LIST+I) Q:X="" S X=$P(X,";;",2),R=$P(X,"^",1),B=$P(X,"^",2),C=$P(X,"^",3),^UTILITY($J,R)=B_"^"_C +CODE2 ;; F I=1:1:6 S X=$P($T(@("LINE"_I)),";;",2,99),@("XBINTEG("_I_")=X") +CODE3 ;; X XBINTEG(1) diff --git a/XBIV.m b/XBIV.m new file mode 100644 index 0000000..56b6321 --- /dev/null +++ b/XBIV.m @@ -0,0 +1,6 @@ +XBIV(FILE,FIELD,EXTVAL) ;DG/OHPRD; + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;Get Internal Field Value Given External Field Value + ; + I '$D(^DD(FILE,FIELD)) Q "" + Q "HELLO" diff --git a/XBKD.m b/XBKD.m new file mode 100644 index 0000000..e3088bf --- /dev/null +++ b/XBKD.m @@ -0,0 +1,161 @@ +XBKD ; IHS/ADC/GTH - KILLS DICs and GLOBALS ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; This routine deletes FileMan dictionaries, and optionally + ; their globals, TEMPLATES and AUTHORITIES, by a range of + ; dictionary numbers, or if called from another routine, by + ; a predefined set of dictionaries. The assumptions made + ; by this routine are that ^UTILITY, ^DIC, and ^DD are not + ; UCI TRANSLATED. Any other globals may be translated, but + ; the KILLs will take place in the current UCI only. + ; + ; This routine can be called from another routine by setting + ; the variables XBKDLO, XBKDHI, XBKDDEL, XBKDTMP and then + ; D EN1^XBKD, or by creating the array ^UTILITY("XBDSET",$J) + ; and then D EN2^XBKD. + ; + ; The array ^UTILITY("XBDSET",$J) is subscripted by the file + ; numbers and has a value of 'v1^v2' where v1 applies to the + ; data global, and v2 applies to the TEMPLATES attached to + ; the file. The allowable values of v1 and v2 are 'S' for + ; save, 'D' for delete, 'A' for ask. + ; + ; This routine will execute ^XBRESID to delete any residual + ; entries in ^DD if dictionaries are deleted by a range of + ; numbers. + ; +BEGIN ; + D ^XBKVAR + W !!,"This program deletes FileMan dictionaries, and optionally their" + W !,"globals, TEMPLATES and AUTHORITIES, by a range of dictionary numbers.",!! + ; +LO ; + R !,"Enter first dictionary number to be deleted: ",XBKDLO:$G(DTIME,999) + G:XBKDLO'=+XBKDLO EOJ +HI ; + W !,"Enter last dictionary number to be deleted: ",XBKDLO,"//" + R XBKDHI:$G(DTIME,999) + S:XBKDHI="" XBKDHI=XBKDLO + G:XBKDHI'=+XBKDHI!(XBKDHI",XBKDDEL,"<---" G EOJ + S:'$D(XBKDTMP) XBKDTMP="A" + S:XBKDTMP="K" XBKDTMP="S" ;***** UPWARD COMPATABLE ***** + I "DAS"'[XBKDTMP W !!,"Invalid XBKDTMP --->",XBKDTMP,"<---" G EOJ + S XBDSLO=XBKDLO,XBDSHI=XBKDHI + D EN1^XBDSET + S XBKDFILE=(XBKDLO-.00000001) + F XBKDL=0:0 S XBKDFILE=$O(^DD(XBKDFILE)) Q:XBKDFILE>XBKDHI!(XBKDFILE'=+XBKDFILE) I '$D(^UTILITY("XBDSET",$J,XBKDFILE)) D CHECKDD + I '$D(^UTILITY("XBDSET",$J)) W !!,"No dictionaries were selected." G EOJ + S XBKDFILE=0 + F XBKDL=0:0 S XBKDFILE=$O(^UTILITY("XBDSET",$J,XBKDFILE)) Q:XBKDFILE="" S ^(XBKDFILE)=XBKDDEL_U_XBKDTMP + G EN2 + ; +CHECKDD ; CHECK ^DD FOR DANGLING ENTRIES + Q:$D(^DD(XBKDFILE,0,"UP")) + W "." + S ^UTILITY("XBDSET",$J,XBKDFILE)="" + Q + ; +EN2 ;PEP - Array ^UTILITY("XBDSET",$J) must exist when entering here. + I '$D(^UTILITY("XBDSET",$J)) W !!,"^UTILITY(""XBDSET"",$J) is not defined!" G EOJ + I $O(^UTILITY("XBDSET",$J,""))<2 W !!,"*** Don't mess with files less than 2!! ***",*7 KILL XBKDLO,XBKDHI G EOJ + D ^XBKVAR + S (XBKDFILE,XBKDFLG)=0 + F XBKDL=0:0 S XBKDFILE=$O(^UTILITY("XBDSET",$J,XBKDFILE)) Q:XBKDFILE="" S XBKDX=^(XBKDFILE) D CHKVAL + I XBKDFLG W !!,"One or more invalid GLOBAL^TEMPLATE disposition values encountered!" G EOJ + KILL XBKDDEL,XBKDERR,XBKDFLG,XBKDTMP,XBKDX + D ^XBKD2 + S XBKDFLG=0 + D CONFIRM + G:XBKDFLG EOJ + KILL XBKDASK,XBKDFLG,XBKDX,XBKDY + D ^XBKD3 + W !!,"Resetting ^DIC(0) " + S (XBKDC,XBKDFILE)=0,XBKDLAST="" + F XBKDL=0:0 S XBKDFILE=$O(^DIC(XBKDFILE)) Q:XBKDFILE'=+XBKDFILE S XBKDC=XBKDC+1,XBKDLAST=XBKDFILE + S $P(^DIC(0),"^",3)=XBKDLAST,$P(^DIC(0),"^",4)=XBKDC + G EOJ + ; +CHKVAL ; CHECK G^T VALUES + S XBKDERR=0 + I XBKDX'?1U1"^"1U S XBKDERR=1 + ;***** "K" TO "S" ADDED TO FOLLOWING LINE FOR UPWARD COMPABILITY ***** + I 'XBKDERR S XBKDDEL=$P(XBKDX,U,1),XBKDTMP=$P(XBKDX,U,2) S:XBKDDEL="K" XBKDDEL="S" S:XBKDTMP="K" XBKDTMP="S" S:"ADS"'[XBKDDEL XBKDERR=1 S:"ADS"'[XBKDTMP XBKDERR=1 + I XBKDERR S XBKDFLG=1 W !,"Invalid value ",XBKDFILE,"=",XBKDX + Q + ; +CONFIRM ; SHOW AND ASK + I '$D(^UTILITY("XBDSET",$J)) S XBKDFLG=1 Q + W !!," NUMBER",?14,"NAME",?45,"G^T",?50,"DATA GLOBAL",! + S (XBKDFILE,XBKDASK)=0 + F XBKDL=0:0 S XBKDFILE=$O(^UTILITY("XBDSET",$J,XBKDFILE)) Q:XBKDFILE="" S XBKDX=^(XBKDFILE) S:$E(XBKDX,1,3)["A" XBKDASK=1 D LIST + W !!,"The above list of dictionaries will be deleted in UCI ",XBKDUCI,". Data" + W !,"globals, TEMPLATES and AUTHORITIES, will be kept, deleted, or asked depending" + W !,"on flag. '?' in G position indicates invalid data global." + W !!,"[S]ave, [D]elete, [A]sk. Globals to be deleted are also marked" + W !," by '*' in position 1." + I $D(ADIFROM("IHS")) S XBKDX="" + E R !!,"[C]ontinue, [S]top, [M]odify? C//",XBKDX:$G(DTIME,999) S:XBKDX="^" XBKDX="S" + I $E(XBKDX)="S" S XBKDFLG=1 Q + I $E(XBKDX)="M" D MODIFY G CONFIRM + Q:'XBKDASK + W ! + S XBKDFILE="" + F XBKDL=0:0 S XBKDFILE=$O(^UTILITY("XBDSET",$J,XBKDFILE)) Q:XBKDFILE="" S XBKDX=^(XBKDFILE) D:$E(XBKDX,1,3)["A" ASK + G CONFIRM + ; +LIST ; LIST FILE INFO + W !,$S($P(XBKDX,U,1)="D":"*",1:" "),XBKDFILE,?14,$E($P(^DIC(XBKDFILE,0),U,1),1,30),?45,$E(XBKDX,1,3),?50,$S($P(XBKDX,U,3)="":"",1:$P(XBKDX,U,3)) + Q + ; +MODIFY ; + R !!,"Which file? ",XBKDFILE:$G(DTIME,999) + Q:XBKDFILE'=+XBKDFILE + I '$D(^UTILITY("XBDSET",$J,XBKDFILE)) W *7 G MODIFY + R !," Delete file from list of files to be deleted (Y/N) N//",XBKDY:$G(DTIME,999) + I $E(XBKDY)="Y" KILL ^UTILITY("XBDSET",$J,XBKDFILE) Q + S $P(^UTILITY("XBDSET",$J,XBKDFILE),U,2)="A",$P(^(XBKDFILE),U,1)=$S($P(^(XBKDFILE),U,1)="?":"?",1:"A"),XBKDX=^(XBKDFILE) + W ! + D ASK + Q + ; +ASK ; + G:$P(XBKDX,U,1)'="A" ASK2 + W !,"Do you want to delete the data global for ",XBKDFILE," ",$P(^DIC(XBKDFILE,0),U,1)," (Y/N) N//" + R XBKDY:$G(DTIME,999) + I $E(XBKDY)="Y" S $P(^UTILITY("XBDSET",$J,XBKDFILE),U,1)="D" + E S $P(^UTILITY("XBDSET",$J,XBKDFILE),U,1)="S" +ASK2 ; + Q:$P(XBKDX,U,2)'="A" + W !,"Do you want to delete the TEMPLATES and AUTHORITIES for ",XBKDFILE," ",$P(^DIC(XBKDFILE,0),U,1)," (Y/N) N//" + R XBKDY:$G(DTIME,999) + I $E(XBKDY)="Y" S $P(^UTILITY("XBDSET",$J,XBKDFILE),U,2)="D" + E S $P(^UTILITY("XBDSET",$J,XBKDFILE),U,2)="S" + Q + ; +EOJ ; + I $D(XBKDLO),$D(XBKDHI),XBKDLO=+XBKDLO,XBKDHI=+XBKDHI,XBKDHI>XBKDLO S XBRLO=XBKDLO,XBRHI=XBKDHI D EN1^XBRESID + I $D(^UTILITY("XBKD",$J)) W !,"Restoring saved ^DD nodes. " S FROM="^UTILITY(""XBKD"",$J,",TO="^DD(" D ^XBGXFR + KILL ^UTILITY("XBDSET",$J),^UTILITY("XBKD",$J) + KILL %,DA,DIK,Y + KILL XBKDASK,XBKDC,XBKDDEL,XBKDERR,XBKDFILE,XBKDFLD,XBKDFLG,XBKDG,XBKDHI,XBKDL,XBKDLAST,XBKDLO,XBKDNDIC,XBKDTMP,XBKDUCI,XBKDX,XBKDY + KILL FROM,TO + W !!,"DONE",!! + Q + ; diff --git a/XBKD1.m b/XBKD1.m new file mode 100644 index 0000000..6894f3c --- /dev/null +++ b/XBKD1.m @@ -0,0 +1,62 @@ +XBKD1 ; IHS/ADC/GTH - XBKD SUBROUTINES ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; Part of XBKD + ; +BX ; + KILL A + S (I,C)="" + F J=1:1 S I=$O(^DIC("B",I)) Q:I="" I $D(^(I,N)) S C=C+1,A(C)=I + I 'C S C=$O(^DD(N,"NM","")) I C]"" S A=C,C=1,A(C)=A + Q + ; +NCK ; + G NCKER:'$D(^DIC(N,0)),NCKER:+$P(^(0),"^",2)'=N + I $D(^DIC(N,0,"GL")) S G=^("GL") G NCKOK:G?1"^DIC(".E + I @("$D("_G_"0))"),+$P(^(0),"^",2)=N G NCKOK +NCKER ; + S E=1 + Q + ; +NCKOK ; + S E=0 + Q + ; +FGLB ; + G FGOK:'$D(^DD(N,.01,1)) + S I=0 + F J=1:1 S I=$O(^DD(N,.01,1,I)) Q:I="" I $D(^(I,1)) S X=^(1) D SB1 G FGOK:G]"" + S G="" +FGOK ; + Q + ; +END ; + Q + ; +TEMPLP ; + F TEMP="^DIE(","^DIBT(","^DIPT(" D TEMP + Q + ; +TEMP ; + S XBKDB="F"_XBKDFILE,XBKDA="" +TEMP1 ; + S @("XBKDA=$O("_TEMP_"XBKDB,XBKDA))") + G TEMPE:XBKDA="" + S DA="" +TEMP2 ; + S @("DA=$O("_TEMP_"XBKDB,XBKDA,DA))") + G TEMP1:DA="" + S DIE=TEMP,DR=".01" ;D ^DIE + W !,DIE,?8,DA,?12,XBKDB,?24,XBKDA + G TEMP2 + ; +TEMPE ; + KILL XBKDA,XBKDB + Q + ; +SB1 ; + S G="" + I X'?1"S ^"1UP.U1"(".N1",""B""".E + S G=$E($P(X,"""B""",1),3,999) + Q + ; diff --git a/XBKD2.m b/XBKD2.m new file mode 100644 index 0000000..b47e3d3 --- /dev/null +++ b/XBKD2.m @@ -0,0 +1,87 @@ +XBKD2 ; IHS/ADC/GTH - CHECK DICTIONARY NAMES AND DATA GLOBALS ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods. + ; + ; Part of XBKD + ; +START ; + S (Y,XBKDUCI)="" + X:$D(^%ZOSF("UCI"))#2 ^("UCI") + ;I Y'="" S XBKDUCI="["""_$P(Y,",",1)_""""_$S($P(Y,",",2)'="":","""_$P(Y,",",2)_"""",1:"")_"]" ;IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods. + I Y'="" S XBKDUCI="["""_$P(Y,",",1)_""""_$S($P(Y,",",2)'=""&($$VERSION^%ZOSV(1)'["Cache"):","""_$P(Y,",",2)_"""",1:"")_"]" ;IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods. + W !!,"Now checking dictionary names and data globals." + S XBKDFILE="" + F XBKDL=0:0 S XBKDFILE=$O(^UTILITY("XBDSET",$J,XBKDFILE)) Q:XBKDFILE="" W !?5,"Checking ",XBKDFILE D XBKDNC + KILL XBKDANS,XBKDC,XBKDG,XBKDGG,XBKDGNM,XBKDGNR,XBKDNDD,XBKDNDIC,XBKDNTBL,XBKDX,XBKDY + Q + ; +XBKDNC ; + I '$D(^DIC(XBKDFILE)),'$D(^DD(XBKDFILE)) W !,*7,?10,"Not in ^DIC or ^DD. Removing from ^UTILITY(""XBDSET"")." KILL ^UTILITY("XBDSET",$J,XBKDFILE) Q + S XBKDNDIC=$G(^DIC(XBKDFILE,0)),XBKDNDIC=$P(XBKDNDIC,U,1) + D GCHK + I XBKDG["%" W !,*7,?10,"Data global for ",XBKDFILE," is a % global. Removing from ^UTILITY(""XBDSET"")." KILL ^UTILITY("XBDSET",$J,XBKDFILE) Q + S XBKDNDD=$O(^DD(XBKDFILE,0,"NM","")) + I XBKDNDIC=XBKDNDD,XBKDNDIC=XBKDGNM,XBKDFILE=XBKDGNR Q + I XBKDNDIC]"",XBKDNDIC=XBKDNDD G GNMCHK + I XBKDNDIC]"",XBKDNDD="" W !?10,"No name in ^DD. Using name in ^DIC." S XBKDNDD=XBKDNDIC,^DD(XBKDFILE,0,"NM",XBKDNDD)="" G GNMCHK + I XBKDNDIC="",XBKDNDD]"" W !?10,"No name in ^DIC. Using name in ^DD." S $P(^DIC(XBKDFILE,0),U,1)=XBKDNDD,XBKDNDIC=XBKDNDD G GNMCHK + I XBKDNDIC="",XBKDNDD="",XBKDGNM]"",XBKDFILE=XBKDGNR W !?10,"No name in ^DIC or ^DD. Using name in data global." S $P(^DIC(XBKDFILE,0),U,1)=XBKDGNM,^DD(XBKDFILE,0,"NM",XBKDGNM)="",(XBKDNDIC,XBKDNDD)=XBKDGNM Q + I XBKDNDIC]"",XBKDNDD]"",XBKDNDIC'=XBKDNDD W !?10,"Name in ^DIC and ^DD differ. Using name in ^DIC." KILL ^DD(XBKDFILE,0,"NM") S XBKDNDD=XBKDNDIC,^DD(XBKDFILE,0,"NM",XBKDNDD)="" G GNMCHK + W !?10,"Unable to deduce name. Searching DIC(""B"")." + D DICB + G:XBKDNDIC]"" GNMCHK + W !?10,"Unable to deduce name. Setting to 'NO NAME'" + S (XBKDNDIC,XBKDNDD)="NO NAME",$P(^DIC(XBKDFILE,0),U,1)=XBKDNDIC,^DD(XBKDFILE,0,"NM",XBKDNDD)="" + G GNMCHK + ; +GCHK ; CHECK DATA GLOBAL + S (XBKDGNM,XBKDGNR)="" + S XBKDGG=0,XBKDG=$G(^DIC(XBKDFILE,0,"GL")) + S:XBKDG?1"^"1U.UN1"(".UNP XBKDGG=1 + I XBKDG="" W !?10,"File ",XBKDFILE," has no data global specified in ^DIC." S $P(^UTILITY("XBDSET",$J,XBKDFILE),U,1)="?" Q + I 'XBKDGG W !?10,"File ",XBKDFILE," data global=",XBKDG," is invalid." S $P(^UTILITY("XBDSET",$J,XBKDFILE),U,1)="?" Q + S XBKDG="^"_XBKDUCI_$E(XBKDG,2,99),$P(^UTILITY("XBDSET",$J,XBKDFILE),U,3)=$E(XBKDG,2,99) + S XBKDX=$E(XBKDG,1,$L(XBKDG)-1)_$S($E(XBKDG,$L(XBKDG))=",":")",1:""),XBKDX=$D(@XBKDX) + I 'XBKDX W !?10,"Data global ",XBKDG," does not exist!" S $P(^UTILITY("XBDSET",$J,XBKDFILE),U,1)="?" Q + S XBKDY=$L(XBKDG),XBKDY=$E(XBKDG,1,XBKDY-1)_$E(")",$E(XBKDG,XBKDY)=","),XBKDY=$S(XBKDY[")":$E(XBKDY,1,$L(XBKDY)-1)_",0)",1:XBKDY_"(0)") + S XBKDX=$D(@XBKDY) + I XBKDX S XBKDGNM=@XBKDY,XBKDGNR=+$P(XBKDGNM,U,2),XBKDGNM=$P(XBKDGNM,U,1) S:'XBKDGNR XBKDGNR="" Q + I 'XBKDX W !?10,"File ",XBKDFILE," data global has entries but no 0th node.",!?12,"If global not being deleted, piece 3 and 4 must be reset!",!?12,"Creating 0th node." S @XBKDY="CREATED BY XBKD"_U_XBKDFILE + Q + ; +DICB ; CHECK DIC("B" + KILL XBKDNTBL + S (XBKDX,XBKDC)=0 + F XBKDL=0:0 S XBKDX=$O(^DIC("B",XBKDX)) Q:XBKDX="" I $D(^(XBKDX,XBKDFILE)) S XBKDC=XBKDC+1,XBKDNTBL(XBKDC)=XBKDX + Q:'XBKDC + I XBKDC=1 S XBKDANS=1 D NAMESET KILL XBKDNTBL Q + W !?12,"Multiple entries were found in ^DIC(""B""). Selecting first name",!?12," found. All other names will be removed." + W ! + S XBKDANS=1 + D NAMESET + KILL XBKDNTBL(XBKDANS) + W ! + S XBKDX="" + F XBKDL=0:0 S XBKDX=$O(XBKDNTBL(XBKDX)) Q:XBKDX="" W !?12,"Deleting ^DIC(""B"",""",XBKDNTBL(XBKDX),""",",XBKDFILE,")" KILL ^DIC("B",XBKDNTBL(XBKDX),XBKDFILE) + W ! + KILL XBKDNTBL + Q +NAMESET ; + W !?12,"Setting names to '",XBKDNTBL(XBKDANS),"'" + KILL ^DD(XBKDFILE,0,"NM") + S (XBKDNDIC,XBKDNDD)=XBKDNTBL(XBKDANS),$P(^DIC(XBKDFILE,0),U,1)=XBKDNDIC,^DD(XBKDFILE,0,"NM",XBKDNDD)="" + Q + ; +GNMCHK ; CHECK DATA GLOBAL NAME AGAINST ^DIC + Q:'XBKDGG + I XBKDGNM]""!(XBKDGNR),XBKDFILE'=XBKDGNR!(XBKDNDIC'=XBKDGNM) D GNMCHK2 + S XBKDX=XBKDG_"0)" + I XBKDGNM="",XBKDGNR="",$D(@XBKDX)#2 S $P(@XBKDX,U,1)=XBKDNDIC + Q + ; +GNMCHK2 ; DATA GLOBAL MISMATCH + W !?10,"Data global name and/or number do not match ^DIC. Data global will",!?12,"not be deleted!! " + S $P(^UTILITY("XBDSET",$J,XBKDFILE),U,1)="S",XBKDX=XBKDG_"0)="_@(XBKDG_"0)") + W $E(XBKDX,1,47) + Q + ; diff --git a/XBKD3.m b/XBKD3.m new file mode 100644 index 0000000..e1a2746 --- /dev/null +++ b/XBKD3.m @@ -0,0 +1,63 @@ +XBKD3 ; IHS/ADC/GTH - KILLS DICs and GLOBALS (PART 3) ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; Part of XBKD + ; + ; Upon entry into this routine ^DIC(file #,0) must contain + ; the file name, and, if the data global is to be deleted + ; piece 3 of ^UTILITY("XBDSET",$J,file #) must be a valid + ; global reference. + ; +START ; + W !! + KILL ^UTILITY("XBKD",$J) + S (XBKDFILE,XBKDFLG)=0 + F XBKDL=0:0 S XBKDFILE=$O(^UTILITY("XBDSET",$J,XBKDFILE)) Q:XBKDFILE="" S XBKDDEL=$P(^(XBKDFILE),U,1),XBKDTMP=$P(^(XBKDFILE),U,2),XBKDG=$P(^(XBKDFILE),U,3) D KILL Q:XBKDFLG + Q + ; +KILL ; + S XBKDG="^"_$E(XBKDG,1,$L(XBKDG)-1)_$S($E(XBKDG,$L(XBKDG))=",":")",1:"") + S XBKDNDIC=$P(^DIC(XBKDFILE,0),U,1) + W XBKDFILE,?14,$P(^DIC(XBKDFILE,0),U,1)," " + I XBKDTMP'="D" D SAVE + KILL XBKDSFL + S XBKDC=1,XBKDSFL(XBKDC)=XBKDFILE + D SBTRACE + KILL XBKDC,XBKDI,XBKDSF,XBKDSFL + KILL ^DD("ACOMP",XBKDFILE) + KILL ^DIC(XBKDFILE,"%"),^("%A"),^("%D"),^DIC("B",XBKDNDIC,XBKDFILE) + I XBKDG'["DIC(",XBKDTMP="D" KILL ^DIC(XBKDFILE,0) + K:XBKDDEL="D" @XBKDG + I XBKDTMP="D" F DIK="^DIE(","^DIPT(","^DIBT(" W "." KILL @(DIK_"""F""_XBKDFILE)") F DA=.9:0 S DA=$O(@(DIK_"DA)")) Q:DA'>0 I $D(^(DA,0)) S %=$P(^(0),U,4) I %=""!'$D(^DD(+%)) W "." D ^DIK + W !! + Q + ; +SBTRACE ; Delete all Sub-Files. + F XBKDL=0:0 S XBKDI=$O(XBKDSFL("")) Q:XBKDI="" S XBKDSF=XBKDSFL(XBKDI) D SBTRACE2 S XBKDI=$O(XBKDSFL("")) W "." KILL ^DD(XBKDSFL(XBKDI)),XBKDSFL(XBKDI) + Q + ; +SBTRACE2 ; + S XBKDI=0 + F XBKDL=0:0 S XBKDI=$O(^DD(XBKDSF,"SB",XBKDI)) Q:XBKDI="" S XBKDC=XBKDC+1,XBKDSFL(XBKDC)=XBKDI + Q + ; +SAVE ; Save "PT", "TRB", and "ACOMP" node from ^DD. + S XBKDFLD="" + F XBKDL=0:0 S XBKDFLD=$O(^DD("ACOMP",XBKDFILE,XBKDFLD)) Q:XBKDFLD="" S XBKDFLE2="" F XBKDL=0:0 S XBKDFLE2=$O(^DD("ACOMP",XBKDFILE,XBKDFLD,XBKDFLE2)) Q:XBKDFLE2="" D SAVE2 + KILL ^DD(XBKDFILE,0,"PT",XBKDFILE),XBKDFLE2 + W "." + S FROM="^DD("_XBKDFILE_",0,""PT"",",TO="^UTILITY(""XBKD"",$J,"_XBKDFILE_",0,""PT""," + D ^XBGXFR + KILL ^DD(XBKDFILE,"TRB",XBKDFILE) + W "." + S FROM="^DD("_XBKDFILE_",""TRB"",",TO="^UTILITY(""XBKD"",$J,"_XBKDFILE_",""TRB""," + D ^XBGXFR + W "." + S FROM="^DD(""ACOMP"","_XBKDFILE_",",TO="^UTILITY(""XBKD"",$J,""ACOMP"","_XBKDFILE_"," + D ^XBGXFR + Q + ; +SAVE2 ; + I '$D(^DIC(XBKDFLE2))!(XBKDFILE=XBKDFLE2) W "." KILL ^DD("ACOMP",XBKDFILE,XBKDFLD,XBKDFLE2) + Q + ; diff --git a/XBKERCLN.m b/XBKERCLN.m new file mode 100644 index 0000000..996181b --- /dev/null +++ b/XBKERCLN.m @@ -0,0 +1,72 @@ +XBKERCLN ; IHS/ADC/GTH - CLEAN OUT KERNEL NAMESPACE ITEMS PRIOR TO INSTALL ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; This routine is a modified XBPKDEL for use specifically + ; to clean out KERNEL package items prior to new KERNEL + ; install. This routine does not delete any security keys. + ; + D ^XBKVAR,ASK + G:AUPKSTP EOJ + F AUPKNSP="XU","XQ","XM","ZT","ZE","ZI","ZR","ZS" D PKDEL + S %=1 + D ENASK^XQ3 ;CALL TO FIX OPTION POINTERS + G EOJ + ; +PKDEL ; + I '$D(^DIC(0)) W !,*7,"Filemanager does not exist in this UCI!" G EOJ + I '$D(AUPKNSP) W !,*7,"Namespace variable does not exist!" G EOJ + S U="^",DUZ(0)="@",AUPKQUIT=AUPKNSP_"{" + F AUPKGLO="^DIBT(","^DIPT(","^DIE(","^DIC(19,","^XMB(3.6,","^DIC(9.2,","^DD(""FUNC""," D DELETE + Q + ; +ASK ;ASK USER IF WANTS TO CONTINUE + S AUPKSTP=0 + W !!,*7,"This routine will delete all options, sort,input,print templates,",!,"bulletins, functions, ",$S($D(AUPKEY):"help frames and security keys",1:"and help frames")," namespaced `XU,XQ,XM,ZT,ZE,ZI,ZR,ZS' " + W !,"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 this package deletion.",! G ASK + I %=2!(%=-1) S AUPKSTP=1 + W ! + Q + ; +DELETE ; + W !!,"Now deleting `",AUPKNSP,"' namespaced ",$P(@(AUPKGLO_"0)"),U),"S..." + S AUPKNSPC=AUPKNSP + I $D(@(AUPKGLO_"""B"",AUPKNSPC)")) S DA=$O(@(AUPKGLO_"""B"",AUPKNSPC,"""")")),DIK=AUPKGLO D ^DIK KILL DIK,DA + F L=0:0 S AUPKNSPC=$O(@(AUPKGLO_"""B"",AUPKNSPC)")) Q:AUPKNSPC=""!(AUPKNSPC]AUPKQUIT) S DA=$O(@(AUPKGLO_"""B"",AUPKNSPC,"""")")) W !?3,AUPKNSPC S DIK=AUPKGLO D ^DIK KILL 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 Kernel namespaced items in current UCI",! + D ^%ZIS + G:POP EOJ + U IO + F AUPKNSP="XU","XQ","XM","ZT","ZE","ZI","ZR","ZS" D LIST1 + D ^%ZISC + G EOJ + ; +LIST1 ; + W !!,"Listing of items in namespace ",AUPKNSP,! + W "--------------------------------------",! + S AUPKQUIT=AUPKNSP_"{" + S %=0 + F AUPKGLO="^DIBT(","^DIPT(","^DIE(","^DIC(19,","^DIC(19.1,","^XMB(3.6,","^DIC(9.2,","^DD(""FUNC""," D LIST2 + Q + ; +LIST2 ; + S AUPKNSPC=$O(@(AUPKGLO_"""B"",AUPKNSP)")) + I $P(AUPKNSPC,AUPKNSP)]"" W:% ! S %=0 W "NO ",$P(@(AUPKGLO_"0)"),"^",1),"S",! Q + S %=1 + W !,$P(@(AUPKGLO_"0)"),"^",1),"S",! + S AUPKNSPC=AUPKNSP + F L=0:0 S AUPKNSPC=$O(@(AUPKGLO_"""B"",AUPKNSPC)")) Q:AUPKNSPC=""!(AUPKNSPC]AUPKQUIT) S DA=$O(@(AUPKGLO_"""B"",AUPKNSPC,"""")")) W ?3,AUPKNSPC,! + Q + ; +EOJ ; + KILL AUPKGLO,AUPKEY,AUPKSTP,AUPKNSP,AUPKNSPC,AUPKQUIT,AUPKRUN,AUPKDOC + Q + ; diff --git a/XBKIDS.m b/XBKIDS.m new file mode 100644 index 0000000..52fbeb6 --- /dev/null +++ b/XBKIDS.m @@ -0,0 +1,75 @@ +XBKIDS ; IHS/ASDST/GTH - KIDS UTILITIES ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; IHS/SET/GTH XB*3*9 10/29/2002 + ; + ; -------------------- + ; +VCHK(XBPRE,XBVER,XBQUIT) ;PEP - For environment check routines. + ; Pass "PREFIX","Version","XPDQUIT_value". + ; E.g.: Q:'$$VCHK^XBKIDS("AG",5.4,2) + ; + NEW XBV + S XBV=$$VERSION^XPDUTL(XBPRE) + W !,$$CJ^XLFSTR("Need at least "_XBPRE_" v "_XBVER_"....."_XBPRE_" v "_XBV_" Present",IOM) + I XBV0:XB_"""PAH"","_(+Y)_",",1:"PATCH NUMBER '"_$P(XBP,"*",3)_"' NOT FOUND IN PACKAGE FILE.") + ; + ; -------------------- + ; + ; OPTSAV() and OPTRES() are provided b/c if an option of type "menu" + ; is included in a KIDS transport and install, the existing option + ; is overwritten, thereby destroying any local modifications. + ; + ; Further, if an option of type "menu" is included in a KIDS transport + ; and install, -all- the options on that option of type "menu" -must- + ; be included in the KIDS transport, whether they are changed, or not. + ; + ; The value of XB2SUB is provided by the calling routine, and has no + ; particular meaning. + ; + ; E.g.: D OPTSAV^XBKIDS("AGMENU","Cochise") + ; D OPTRES^XBKIDS("AGMENU","Cochise") + ; +OPTSAV(XBM,XB2SUB) ;PEP - Save the menu portion of an option. + I $D(^XTMP("XBKIDS",XB2SUB,"OPTSAV",XBM)) D BMES^XPDUTL("NOT SAVED. Option '"_XBM_"' has previously been saved.") Q + I '$D(^XTMP("XBKIDS")) S ^XTMP("XBKIDS",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"XBKIDS - SAVE OPTION CONFIGURATIONS." + NEW I,A + S I=$O(^DIC(19,"B",XBM,0)) + I 'I D BMES^XPDUTL("NOT SAVED. Option '"_XBM_"' not found in OPTION file.") Q + S A=0 + F S A=$O(^DIC(19,I,10,A)) Q:'A S ^XTMP("XBKIDS",XB2SUB,"OPTSAV",XBM,A)=$P(^DIC(19,+^DIC(19,I,10,A,0),0),U,1)_U_$P(^DIC(19,I,10,A,0),U,2,3) + Q + ; + ; -------------------- + ; +OPTRES(XBM,XB2SUB) ; PEP - Restore the menu portion of an option. + NEW XB,XBI + I '$D(^XTMP("XBKIDS",XB2SUB,"OPTSAV",XBM)) D BMES^XPDUTL("FAILED. Option '"_XBM_"' was not previously saved.") Q + S XB=0 + F S XB=$O(^XTMP("XBKIDS",XB2SUB,"OPTSAV",XBM,XB)) Q:'XB S XBI=^(XB) I '$$ADD^XPDMENU(XBM,$P(XBI,U,1),$P(XBI,U,2),$P(XBI,U,3)) D BMES^XPDUTL("....FAILED to re-atch "_$P(XBI,U,1)_" to "_XBM_".") + Q + ; diff --git a/XBKSET.m b/XBKSET.m new file mode 100644 index 0000000..c35b0aa --- /dev/null +++ b/XBKSET.m @@ -0,0 +1,17 @@ +XBKSET ; IHS/ADC/GTH - SET MINIMUM KERNEL VARIABLES ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; This routine is for programmers in direct mode only. It + ; should not be called within a routine. + ; +START ; + D ^XBKVAR +KERNEL ; + KILL ^XUTL("XQ",$J),^UTILITY($J) + S %ZIS="L",IOP="HOME" + D ^%ZIS + Q:POP + D SAVE^XUS1 ; IHS/SET/GTH XB*3*9 10/29/2002 + ; F X="DUZ","DUZ(0)","DUZ(2)","IO","IOBS","IOF","ION","IOM","IOS","IOSL","IOST","IOST(0)","IOXY" I $D(@X) S ^XUTL("XQ",$J,X)=@X ; IHS/SET/GTH XB*3*9 10/29/2002 + Q + ; diff --git a/XBKTMP.m b/XBKTMP.m new file mode 100644 index 0000000..60bd02d --- /dev/null +++ b/XBKTMP.m @@ -0,0 +1,12 @@ +XBKTMP ; IHS/ADC/GTH - CLEAN ^TMP NODES FOR CURRENT JOB ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; Called from the top, this routine KILLs entries in the + ; ^TMP global that have $J as the first or second subscript. + ; + KILL ^TMP($J) + NEW X + S X="" + F S X=$O(^TMP(X)) Q:X="" KILL ^TMP(X,$J) + Q + ; diff --git a/XBKVAR.m b/XBKVAR.m new file mode 100644 index 0000000..b1469e7 --- /dev/null +++ b/XBKVAR.m @@ -0,0 +1,18 @@ +XBKVAR ; IHS/ADC/GTH - SET MINIMUM KERNEL VARIABLES ; [ 11/04/97 10:26 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*5 IHS/ADC/GTH 10-31-97 Correct the setting of DUZ("AG"). + ; +START ; + S U="^" + I '$D(DUZ(2)),$D(^AUTTSITE(1,0)) S DUZ(2)=+^(0) + I '$D(DUZ(2)),$D(^AUTTLOC("SITE")) S DUZ(2)=+^("SITE") + ; I '$D(DUZ("AG")) S DUZ("AG")=$S($P($G(^XMB(1,0)),"^",8)]"":$P(^XMB(1,0),"^",8),1:"I") ; XB*3*5 IHS/ADC/GTH 10-31-97 Correct the setting of DUZ("AG"). + I '$D(DUZ("AG")) S DUZ("AG")=$S($P($G(^XMB(1,1,0)),"^",8)]"":$P(^XMB(1,1,0),"^",8),1:"I") ; XB*3*5 IHS/ADC/GTH 10-31-97 Correct the setting of DUZ("AG"). + S:'($D(DUZ)#2) DUZ=0 + S:'($D(DUZ(0))#2) DUZ(0)="" + S:'($D(DUZ(2))#2) DUZ(2)=0 + I '$D(DT) S DT=($$HTFM^XLFDT($H)\1) + S:'$D(DTIME) DTIME=999 + KILL %,%H,%I + Q + ; diff --git a/XBL.m b/XBL.m new file mode 100644 index 0000000..c1928ca --- /dev/null +++ b/XBL.m @@ -0,0 +1,26 @@ +XBL ; IHS/ADC/GTH - List Template Exporter ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + W !,"'XB DISPLAY' List Template..." + S DA=$O(^SD(409.61,"B","XB DISPLAY",0)),DIK="^SD(409.61," + D ^DIK:DA + S DIC(0)="L",DIC="^SD(409.61,",X="XB DISPLAY" + KILL DO,DD 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 + ; diff --git a/XBLCALL.m b/XBLCALL.m new file mode 100644 index 0000000..8f381f8 --- /dev/null +++ b/XBLCALL.m @@ -0,0 +1,107 @@ +XBLCALL ; IHS/ADC/GTH - LIST CALLABLE SUBROUTINES ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; 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:'($$QUIT) + Q + ; +QUIT() ; + NEW I,X,Y + Q $$DIR^XBDIR("E") + ; +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 + ;;EP^XBCLM(STR);Lists numbered column headings over the passed string + ;;^XBDAD0;Returns DA array for D0,D1, etc. or vice versa + ;;KILL^XBDAD0;KILL D0, D1, ETC. + ;;^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 + ;;$$DIC^XBDIQ1(FN);Extrensic entry to return DIC from global + ;;EN^XBDIQ1;Returns single entries + ;;ENM^XBDIQ1;Returns multiple entries + ;;ENP^XBDIQ1(DIC,DA,DR,DIQ,FMT);Param pass into EN + ;;ENPM^XBDIQ1(DIC,DA,DR,DIQ,FMT);Param pass into EN + ;;PARSE^XBDIQ1(DA);Parse DA literal into da array + ;;$$VAL^XBDIQ1(DIC,DA,DR);Return a value for a field + ;;$$VALI^XBDIQ1(DIC,DA,DR);Return internal value for a field + ;;$$DIR^XBDIR();Standard interface to Reader + ;;EN1^XBDSET;Return FileMan dictionaries + ;;EN^XBENHANCE(NS);Print enhancements from PACKAGE given namespace + ;;FLD^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 + ;;$$C^XBFUNC(X,Y);Center X in field length Y/IOM/80. + ;;$$CV^XBFUNC(N);Return current version for package with namespace N + ;;$$DECFRAC^XBFUNC(DECIMAL VALUE);returns fraction equivilent + ;;$$FNDPATRN^XBFUNC(STR,PAT);finds pattern in string + ;;$$GDT^XBFUNC(JDT);Return Gregorian Date, given Julian Date. + ;;$$GETPATRN^XBFUNC(STR,PAT);returns pattern from string + ;;$$INTSET^XBFUNC(FILE,FIELD,EXTVAL);returns internal value + ;;$$JDT^XBFUNC(FMDT);Return Julian Date, given FM date. + ;;$$EXTSET^XBFUNC(FILE,FIELD,INTVAL);returns external value + ;;$$LOC^XBFUNC;Return location name from file 4 based on DUZ(2). + ;;$$USR^XBFUNC;Return name of current user for ^VA(200. + ;;$$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 + ;;HELP^XBHELP(L,R,T);Display text beginning at label L of routine R + ;;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 + ;;^XBKTMP;KILL nodes in ^TMP( that have $J as 1st or 2nd subscripts + ;;^XBKVAR;Set minimum Kernel vars + ;;ARRAY^XBLM(AR,HDR);Display array that has (...,n,0) structure + ;;DIQ^XBLM(DIC,DA);Display DIC and DA after call to EN^DIQ + ;;FILE^XBLM(DIR,FN);Read file into the TMP global for display + ;;GUID^XBLM(ROU,Y);Give routine and target array for FM prints + ;;GUIR^XBLM(ROU,Y);Give routine and target array + ;;SFILE^XBLM;Select a host file for display + ;;VIEWD^XBLM(ROU);Use ROU to print to a host file for viewing + ;;VIEWR^XBLM(ROU,HDR);Use ROU to print to a host file for viewing + ;;EN^XBLZRO;List 0th nodes of pre-selected list of FileMan files + ;;MAIL^XBMAIL(NS,REF);Send mail msg to holders of NS* security key + ;;EN^XBNEW(XBRET,XBNS);Nest Die calls, "TAG^ROUTINE:VAR;NSVAR*" + ;;^XBOFF;Set reverse video off + ;;^XBON;Set reverse video on + ;;PFTV^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^XBRPTL;Print routines down to first label + ;;EN^XBSFGBL(SUBFILE,ref,FORM);Return global ref of file or sub-file. + ;;^XBSITE;Ask user to select site to set DUZ(2) + ;;SET^XBSITE;Request set of DUZ(2) from applications + ;;^XBUPCASE;Upcases value in X + ;;EN^XBVIDEO(X);Set video attribute in X, return cursor + ;;EN^XBVK(NS);KILLS local variables in the passed namespace + ;;^XBVL;List variables in the selected namespace + ;;$$KILLOK^ZIBGCHAR(G);Allow kill of global G + ;;$$KILLNO^ZIBGCHAR(G);Prevent kill'ing of global G + ;;$$JOURN^ZIBGCHAR(G);Set Journaling to ALWAYS for global G + ;;$$NOJOURN^ZIBGCHAR(G);Set Journaling for global G to NEVER + ;;$$UCIJOURN^ZIBGCHAR(G);Journal global G when UCI is Journaled + ;;$$ERR^ZIBGCHAR(#);Return cause of error # + ;;$$Z^ZIBNSSV(ERR);Return values of Non-Standard ($Z) Special Variables + ;;^ZIBRUN;Sets $T based on whether routine in X is running + ;;$$RSEL^ZIBRSEL(NS,Y);Select a list or range of routines diff --git a/XBLFAM.m b/XBLFAM.m new file mode 100644 index 0000000..b5f39ae --- /dev/null +++ b/XBLFAM.m @@ -0,0 +1,194 @@ +XBLFAM ;IHS/SET/GTH - LISTS FILE ATTRIBUTES FOR MODELING ; [ 04/18/2003 9:05 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;IHS/SET/GTH XB*3*9 10/29/2002 New routine. + ; This routine lists the following file attributes, useful for + ; moving to a spreadsheet, or other desktop ap, for database + ; modeling activities: + ; + ; File #, File Name, Field #, Field Label, Field type, Desc/Help., + ; Min Length, Max Length + ; The output is one line of data per field, semi-colon delimited. + ; + ; NOTE: Fields marked for deletion with a "*" preceeding the label + ; are -not- processed. + ; + ; Thanks to George T. Huggins for the original routine. + ; +START ; + ; --- Display routine description. + D HOME^%ZIS,DT^DICRW + KILL ^UTILITY($J) + S ^UTILITY($J,"XBLFAM")="" + D EN^XBRPTL + KILL ^UTILITY($J) + ; + ; --- Start processing. + NEW QFLG + S QFLG=0 + ; + ; --- Get file(s). + D ^XBDSET + Q:'$D(^UTILITY("XBDSET",$J)) + ; + ; --- Select device. + W ! + S %ZIS="Q",ZTSAVE("^UTILITY(""XBDSET"",$J,")="" + D EN^XUTMDEVQ("EN^XBLFAM","List Attributes for Modeling",.ZTSAVE,.%ZIS) + D EN^XBVK("ZT") + Q + ; +EN ;EP - From TaskMan. + ; + ; --- Main loop: thru selected file(s). + NEW F,X + ; + ; F:File # + ; + S F=0 + F S F=$O(^UTILITY("XBDSET",$J,F)) Q:F'=+F D PAGE Q:QFLG D FIELDS(F) Q:QFLG + D ^%ZISC + Q + ; --- End main loop. +FIELDS(F) ; Process fields in File F. + ; Field #, File #, File Name, Field Label, Field type, Desc/Help. + NEW X,XB + S X="" + F XB=0:0 S XB=$O(^DD(F,XB)) Q:'(XB=+XB) D D:$Y>(IOSL-3) PAGE Q:QFLG + . I $E($P($G(^DD(F,XB,0)),"^",1))="*" Q ; field is deprecated. + . I $P(^DD(F,XB,0),"^",2) W $$OUTLINE,! D FIELDS(+$P(^DD(F,XB,0),"^",2)) Q ; Recurse sub-file. + . W $$OUTLINE,! + . Q + Q + ; ------------------------------------------------------- +OUTLINE() ; + ; File #, File Name, Field #, Field Label, Field type, Desc/Help., + ; Min Length, Max Length + Q F_";"_$$FNAME^XBFUNC(F)_";"_XB_";"_$P($G(^DD(F,XB,0)),"^",1)_";"_$$TYPE($P($G(^DD(F,XB,0)),"^",2))_";"_$$HP(F,XB)_$$DESC(F,XB)_$$TDESC(F,XB)_";"_$$MINL(F,XB)_";"_$$MAXL(F,XB)_";" + ; ------------------------------------------------------- +PAGE ; PAGE BREAK + NEW F,G,N,X + I IO=IO(0),$E(IOST,1,2)="C-" S QFLG='$$DIR^XBDIR("E") I 'QFLG W @IOF + Q + ; ------------------------------------------------------- +MINL(N,F) ; Return minimum length + NEW X + S X=$P(^DD(N,F,0),"^",2) + I X Q "-" + I '(X["F") Q "-" + S X=$P(^DD(N,F,0),"^",5,99) + Q +$E(X,$F(X,"$L(X)<"),$L(X)) + ; ------------------------------------------------------- +MAXL(N,F) ; Return maximum length + NEW X + S X=$P(^DD(N,F,0),"^",2) + I X Q "-" + I '(X["F") Q "-" + S X=$P(^DD(N,F,0),"^",5,99) + Q +$E(X,$F(X,"$L(X)>"),$L(X)) + ; ------------------------------------------------------- +NUMBER(F) ;;.001;NUMBER + Q F ; well, duh + ; ------------------------------------------------------- +LABEL(N,F) ;;.01;LABEL + Q $P($G(^DD(N,F,0)),"^",1) + ; ------------------------------------------------------- +TITLE(N,F) ;;.1;TITLE + Q $P($G(^DD(N,F,.1)),"^",1) + ; ------------------------------------------------------- + ;;.12;VARIABLE POINTER (multiple) + ; ------------------------------------------------------- + ;;.2;SPECIFIER + ; ------------------------------------------------------- + ;;.23;LENGTH + ; ------------------------------------------------------- + ;;.24;DECIMAL DEFAULT + ; ------------------------------------------------------- +TYPE(P) ;PEP;.25;TYPE + ; Return TYPE of field. Input is the 2nd piece of the 0th node. + I P Q "" + NEW W + F W="BOOLEAN","COMPUTED","FREE TEXT","SET","DATE","NUMBER","POINTER","WORD-PROCESSING","K","Z" I P[$E(W) Q + I W="SET" S W=W_" <"_$TR($P($G(^DD(F,XB,0)),"^",3),";","|")_">" + I W="POINTER" S W=W_" to "_$$FNAME^XBFUNC(+$P(P,"P",2))_" file" + Q $S(W'="Z":W,1:"??") + ; ------------------------------------------------------- + ;;.26;COMPUTE ALGORITHM + ; ------------------------------------------------------- + ;;.27;SUB-FIELDS + ; ------------------------------------------------------- + ;;.28;MULTIPLE-VALUED + ; ------------------------------------------------------- + ;;.29;DEPTH OF SUB-FIELD + ; ------------------------------------------------------- + ;;.3;POINTER + ; ------------------------------------------------------- +GSL(N,F) ;;.4;GLOBAL SUBSCRIPT LOCATION + Q 0 + ; ------------------------------------------------------- +IT(N,F) ;;.5;INPUT TRANSFORM + Q $P($G(^DD(N,F,0)),"^",5,99) + ; ------------------------------------------------------- + ;;1;CROSS-REFERENCE (multiple) + ; ------------------------------------------------------- +AUDIT(N,F) ;;1.1;AUDIT + Q $G(^DD(N,F,"AUDIT")) + ; ------------------------------------------------------- + ;;1.2;AUDIT CONDITION + ; ------------------------------------------------------- +OT(N,F) ;;2;OUTPUT TRANSFORM + Q $G(^DD(N,F,2.1)) + ; ------------------------------------------------------- +HP(N,F) ;;3;'HELP'-PROMPT + NEW X + S X=$G(^DD(N,F,3)) + I '$L(X) Q "" + Q "HELP-PROMPT("_$G(^DD(N,F,3))_")" + ; ------------------------------------------------------- +XH(N,F) ;;4;XECUTABLE 'HELP' + Q $G(^DD(N,F,4)) + ; ------------------------------------------------------- +RA(N,F) ;;8;READ ACCESS (OPTIONAL) + Q $G(^DD(N,F,8)) + ; ------------------------------------------------------- +DA(N,F) ;;8.5;DELETE ACCESS (OPTIONAL) + Q $G(^DD(N,F,8.5)) + ; ------------------------------------------------------- +WA(N,F) ;;9;WRITE ACCESS (OPTIONAL) + Q $G(^DD(N,F,9)) + ; ------------------------------------------------------- + ;;9.01;COMPUTED FIELDS USED + ; ------------------------------------------------------- +SRC(N,F) ;;10;SOURCE + Q $G(^DD(N,F,10)) + ; ------------------------------------------------------- + ;;11;DESTINATION (multiple) + ; ------------------------------------------------------- + ;;12;POINTER SCREEN + ; ------------------------------------------------------- + ;;12.1;CODE TO SET POINTER SCREEN + ; ------------------------------------------------------- + ;;12.2;EXPRESSION FOR POINTER SCREEN + ; ------------------------------------------------------- + ;;20;GROUP (multiple) + ; ------------------------------------------------------- +DESC(N,F) ;;21;DESCRIPTION (word-processing) + ; Field DESCRIPTION and Help-Prompt. N=File, F=Field + NEW X,XB + S X="" + F XB=0:0 S XB=$O(^DD(N,F,21,XB)) Q:'XB S X=X_$G(^(XB,0)) + I '$L(X) Q "" + Q "DESCRIPTION("_X_")" + ; ------------------------------------------------------- +TDESC(N,F) ;;23;TECHNICAL DESCRIPTION (word-processing) + NEW X,XB + S X="" + F XB=0:0 S XB=$O(^DD(N,F,23,XB)) Q:'XB S X=X_$G(^(XB,0)) + I '$L(X) Q "" + Q "TECH_DESCRIPTION("_X_")" + ; ------------------------------------------------------- +DFLE(N,F) ;;50;DATE FIELD LAST EDITED + Q $$FMTE^XLFDT($G(^DD(N,F,"DT"))) + ; ------------------------------------------------------- + ;;999;TRIGGERED-BY POINTER (multiple) + ; ------------------------------------------------------- + ; diff --git a/XBLFD.m b/XBLFD.m new file mode 100644 index 0000000..0fb0abb --- /dev/null +++ b/XBLFD.m @@ -0,0 +1,71 @@ +XBLFD ;IHS/SET/GTH - LISTS FILE DESCRIPTIONS ; [ 04/18/2003 9:05 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;IHS/SET/GTH XB*3*9 10/29/2002 New routine. + ; This routine lists the number, name, global, and, optionally, + ; description of the selected file(s). + ; +START ; + ; --- Display routine description. + D HOME^%ZIS,DT^DICRW + KILL ^UTILITY($J) + S ^UTILITY($J,"XBLFD")="" + D EN^XBRPTL + KILL ^UTILITY($J) + NEW QFLG,XBDESC + S QFLG=0 + ; --- Get file(s). + D ^XBDSET + Q:'$D(^UTILITY("XBDSET",$J)) + ; --- Print DESCRIPTION flag. + S XBDESC=$$DIR^XBDIR("Y","Print file DESCRIPTION ","Y",$G(DTIME,500),"You can include the DESCRIPTION of the file in your list") + Q:Y="^" + I XBDESC NEW DIWL,DIWR,DIWF S DIWL=14,DIWR=74,DIWF="W" + ; --- Select device. + W ! + S %ZIS="Q",ZTSAVE("^UTILITY(""XBDSET"",$J,")="" + D EN^XUTMDEVQ("EN^XBLFD","List File Descriptions.",.ZTSAVE,.%ZIS) + D EN^XBVK("ZT") + Q + ; +EN ;PEP - List 0th node of pre-selected list of FileMan files. + ; IOF,IOSL must be set and U IO if appropriate. + I $D(IOF)#2,$D(IOSL)#2 + E Q + NEW F,G,N,X,QFLG + ; F:File #; G:Global; N:Zeroth + S QFLG=0 + D HEADER + S F=0 + F S F=$O(^UTILITY("XBDSET",$J,F)) Q:F'=+F S G=$$FGLOB^XBFUNC(F) I G'=-1 D LIST Q:QFLG + D ^%ZISC + Q + ; +LIST ; + D:$Y>(IOSL-3) PAGE + Q:QFLG + W F,?13,$$FNAME^XBFUNC(F),?60,G,! + I XBDESC D DESC(F) + Q + ; +DESC(F) ; Print file DESCRIPTION. + NEW XB + F XB=0:0 S XB=$O(^DIC(F,"%D",XB)) Q:'XB S X=$G(^(XB,0)) D ^DIWP I $Y>(IOSL-3) D PAGE Q:QFLG + Q:QFLG + D ^DIWW + Q + ; +PAGE ; PAGE BREAK + NEW F,G,N,X + I IO=IO(0),$E(IOST,1,2)="C-" S Y=$$DIR^XBDIR("E") S:$D(DIRUT)!($D(DUOUT)) QFLG=1 KILL DIRUT,DUOUT + Q:QFLG + D HEADER + Q + ; +HEADER ; PRINT HEADER + W @IOF,$$FMTE^XLFDT($$NOW^XLFDT),?34,"FILE DESCRIPTIONS" + X ^%ZOSF("UCI") + W ?65,$P(Y," ",1),!,$$REPEAT^XLFSTR("-",IOM),!,"NUMBER",?13,"FILE",?60,"GLOBAL",! + I XBDESC W ?13,"",! + W $$REPEAT^XLFSTR("-",IOM),!! + Q + ; diff --git a/XBLFMD.m b/XBLFMD.m new file mode 100644 index 0000000..8a48875 --- /dev/null +++ b/XBLFMD.m @@ -0,0 +1,63 @@ +XBLFMD ;IHS/SET/GTH - LISTS FIELDS MARKED FOR DELETION ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;IHS/SET/GTH XB*3*9 10/29/2002 New Routine. + ; List fields in the selected files that are marked for deletion. + ; Output is File#, File Name, Field#, Field Name, Date Of Edit +START ; + ; --- Display routine description. + D HOME^%ZIS,DT^DICRW + KILL ^UTILITY($J) + S ^UTILITY($J,"XBLFMD")="" + D EN^XBRPTL + KILL ^UTILITY($J) + NEW QFLG + S QFLG=0 + ; --- Get file(s). + D ^XBDSET + Q:'$D(^UTILITY("XBDSET",$J)) + D DEVICE + Q:QFLG + NEW F,X,XBUCI,XBDASH,XBTIME + X ^%ZOSF("UCI") + S XBUCI=Y,XBDASH=$$REPEAT^XLFSTR("-",IOM),XBTIME=$$FMTE^XLFDT($$NOW^XLFDT) + ; F:File # + S F=0 + F S F=$O(^UTILITY("XBDSET",$J,F)) Q:F'=+F D FIELDS(F) Q:QFLG + D ^%ZISC + Q + ; +FIELDS(F) ; Process fields in File F. + ; Output is File#, Field#, Field Name, Date Of Edit + NEW X,XB + S X="" + F XB=0:0 S XB=$O(^DD(F,XB)) Q:'(XB=+XB) D D:$Y>(IOSL-3) PAGE Q:QFLG + . I $E($P($G(^DD(F,XB,0)),"^",1))="*" W $J(F,10),?12,$E($$FNAME^XBFUNC(F),1,20),?32,$J(XB,10),?44,$E($P($G(^DD(F,XB,0)),"^",1),1,24),?68,$$FMTE^XLFDT($G(^DD(F,XB,"DT"))),! + . I $P(^DD(F,XB,0),"^",2) D FIELDS(+$P(^DD(F,XB,0),"^",2)) Q ; Recurse sub-file. + .Q + Q + ; +PAGE ; PAGE BREAK + NEW F,G,N,X + I IO=IO(0),$E(IOST,1,2)="C-" S QFLG='$$DIR^XBDIR("E") I QFLG Q + W @IOF + W !,"Fields Marked For Deletion in ",XBUCI," uci.",?(IOM-$L(XBTIME)),XBTIME + W !,"File#",?12,"File Name",?32,"Field#",?44,"Field Name",?68,"Date Of Edit" + W !,XBDASH,! + Q + ; +DEVICE ; GET DEVICE (QUEUEING ALLOWED) + W ! + S %ZIS="Q" + D ^%ZIS + I POP S QFLG=1 KILL POP Q + I $D(IO("Q")) D S QFLG=1 Q + . S ZTRTN="EN^XBLFMD",ZTIO=ION,ZTDESC="List 0th nodes",ZTSAVE("^UTILITY(""XBDSET"",$J,")="" + . D ^%ZTLOAD + . W !!,$S($D(ZTSK):"Request queued!",1:"Request cancelled!") + . D ^%ZISC + . KILL ZTSK,IO("Q") + . KILL ZTIO ; ^%ZTLOAD kills other ZT* variables, but not this one + . Q + U IO + Q + ; diff --git a/XBLFSETS.m b/XBLFSETS.m new file mode 100644 index 0000000..8bf4396 --- /dev/null +++ b/XBLFSETS.m @@ -0,0 +1,102 @@ +XBLFSETS ;IHS/SET/GTH - LISTS FILE SETS ; [ 04/18/2003 9:06 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;IHS/SET/GTH XB*3*9 10/29/2002 New Routine. + ; This routine lists the following file information, useful for + ; moving to a spreadsheet, or other desktop ap, for database + ; Reference Terminology Modeling (RTM) activities: + ; CodeSetID;Acronym;Name;Requirement;Source;Information; + ; Note;DataType;MinSize;MaxSize;File #;Field # + ; The output is one line of data per field, semi-colon delimited. + ; Only fields of type SET are reported. Y/N fields are skipped. + ; (See routine for more info.) +MORE ; + ; CodeSetID: This is an identifier that is used to uniquely identify + ; the codeset. Some of these codeset ids are the formal + ; standard identifier such as "ICD 9-CM" or "ISO 3166"; + ; others have been assigned an unofficial codeset id. + ; Acronym: This is an abbreviated name for the codeset. + ; Name: This is the name of the codeset. + ; Requirement: This is an indicator that specifies the codeset is + ; required by regulation. An "H" denotes that the codeset + ; is required for HIPAA; an "O" denotes a requirement by + ; the Office of Management and Budget (OMB). + ; Source: This is the originating source of the codeset. + ; Information: This is information about the codeset or the location + ; of information about the codeset. + ; Note: This contains notes that may assist in locating, using, + ; documenting, etc., the codeset. + ; DateType: This is the datatype of the codeset. + ; MinSize: This is the maximum character size of the coded value. + ; MaxSize: This is the minimum character size of the coded value. + ; +START ; + ; --- Display routine description. + D HOME^%ZIS,DT^DICRW + KILL ^UTILITY($J) + S ^UTILITY($J,"XBLFSETS")="" + D EN^XBRPTL + KILL ^UTILITY($J) + ; --- Get file(s). + D ^XBDSET + Q:'$D(^UTILITY("XBDSET",$J)) + S XBIHS=$$DIR^XBDIR("N^500:999:0","Enter the beginning CodeSet ID number",500,"The response must be a number") + Q:Y="^" + ; --- Select device. + W ! + S %ZIS="Q",ZTSAVE("^UTILITY(""XBDSET"",$J,")="",ZTSAVE("XBIHS")="" + D EN^XUTMDEVQ("EN^XBLFSETS","List File Sets",.ZTSAVE,.%ZIS) + D EN^XBVK("ZT") + Q + ; +EN ;EP - from TaskMan. +VARS ;;F,N,X,W;Single-char work vars. + ; F:File # + NEW XBQFLG,@($P($T(VARS),";",3)) + S (XBQFLG,F)=0 + F S F=$O(^UTILITY("XBDSET",$J,F)) Q:F'=+F D PAGE Q:XBQFLG D FIELDS(F) Q:XBQFLG + D ^%ZISC + Q + ; +FIELDS(F) ; Process fields in File F. + NEW X,XB + S XB=0 + F S XB=$O(^DD(F,XB)) Q:'(XB=+XB) D D:$Y>(IOSL-3) PAGE Q:XBQFLG + . I $E($P($G(^DD(F,XB,0)),"^",1))="*" Q ; field is deprecated. + . I $P(^DD(F,XB,0),"^",2) D FIELDS($P(^(0),"^",2)) Q ; Recurse sub-file. + . S X=$$TYPE($P($G(^DD(F,XB,0)),"^",2)) + . I X'="SET" Q ; Process only SETs. + . I $P($$FINFO(F,XB),"<",2)="1:YES|0:NO|>" Q ; Skip Y/N fields. + . ; CodeSetID;Acronym;Name;Requirement;Source + . S XBIHS=XBIHS+1 + . W "IHS"_$J(XBIHS,3,0)_";;"_$P($G(^DD(F,XB,0)),"^",1)_";;;" + . ; Information;Note;DataType;MinSize;MaxSize;File #;Field # + . W $$DESC(F,XB)_";"_$$FINFO(F,XB)_";"_$$TYPE($P($G(^DD(F,XB,0)),"^",2))_";;;"_F_";"_XB_";" + . W ! + . Q + Q + ; +DESC(N,F) ; Field DESCRIPTION and Help-Prompt. N=File, F=Field + NEW X,XB + S X="" + S X="File Number "_N_", '"_$$FNAME^XBFUNC(N)_"', Field # "_F_", In Global "_$$FGLOB^XBFUNC(N)_", DESCRIPTION <" + F XB=0:0 S XB=$O(^DD(N,F,21,XB)) Q:'XB S X=X_$G(^(XB,0)) + S X=X_"> HELP-PROMPT <"_$G(^DD(N,F,3))_">" + Q X + ; +TYPE(P) ; Return TYPE of field. Input is the 2nd piece of the 0th node. + NEW W + F W="BOOLEAN","COMPUTED","FREE TEXT","SET","DATE","NUMBER","POINTER","K","Z" I P[$E(W) Q + Q $S(W'="Z":W,1:"?") + ; +FINFO(N,F) ; Return SET values, or Pointed-To. N=File, F=Field + NEW T + S T=$$TYPE($P(^DD(N,F,0),"^",2)) + I T="SET" Q "Values <"_$TR($P($G(^DD(N,F,0)),"^",3),";","|")_">" + I T="POINTER" Q " Points to "_$$FNAME^XBFUNC(+$P($P(^DD(N,F,0),"^",2),"P",2))_" file" + Q "?" + ; +PAGE ; PAGE BREAK + NEW F,G,N,X + I IO=IO(0),$E(IOST,1,2)="C-" S XBQFLG='$$DIR^XBDIR("E") I 'XBQFLG W @IOF + Q + ; diff --git a/XBLM.m b/XBLM.m new file mode 100644 index 0000000..6b00a4b --- /dev/null +++ b/XBLM.m @@ -0,0 +1,260 @@ +XBLM ; IHS/ADC/GTH - LIST MANAGER API'S ; [ 09/30/2004 12:07 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*5,6 IHS/ADC/GTH 10-31-97 Use %ZIS to open HF vs $$OPEN^%ZISH + ; XB*3*8 - IHS/ASDST/GTH 12-07-00 - Fix EOF bug in UNIX, timed READ. + ; + ; Documentation APIs for XBLM Generic Display. + ; + ; This utility uses the Veterans Administration List Manager + ; (VALM). + ; + ; APIs + ; + ; FILE^XBLM("Directory","File Name") + ; Displays file indicated. + ; + ; SFILE^XBLM + ; Selection of host file for display. + ; + ; VIEWR^XBLM("TAG^ROUTINE","Header") + ; Displays printout of the routine. (non - FM, using IO) + ; + ; VIEWD^XBLM("Tag^Routine","Header") + ; Displays printout of the routine. (FM - using EN1^DIP) + ; + ; DIQ^XBLM("DIC","DA") + ; Displays EN1^DIQ for the DIC,DA. + ; + ; ARRAY^XBLM("array(","Header") + ; Displays the array(..,n,0) (%RCR notation) + ; + ; >>GUI<< + ; + ; GUIR^XBLM("TAG^ROUTINE","root(") + ; Returns the hard coded output in the array specified. + ; "(" not required. + ; + ; GUID^XBLM("TAG^ROUTINE","root(") + ; Returns the output of the FM routine specified in the + ; array specified. Most often the call is "EN1^DIP". + ; + ; S XBGUI=1,XBY="root(" D entry_point^XBLM + ; The entry points sense these two variables and will + ; put the output into the array specified. + ; +EN ;EP -- main entry point for XB DISPLAY + D EN^VALM("XB DISPLAY") + Q + ; +HDR ;EP -- header code + I XBHDR]"" S VALMHDR(1)=XBHDR + Q + ; +INIT ;EP -- init variables and list array +MARKERS ; + I $G(XBLMMARK) F I=10:10 Q:'$D(@VALMAR@(I)) D + . F J=10:10:80 D CNTRL^VALM10(I,J,1,IORVON,IORVOFF) + .Q + KILL XBLMMARK + S VALMCNT=$O(^TMP("XBLM",$J,XBNODE,""),-1) + Q + ; +HELP ;EP -- help code + S X="?" + D DISP^XQORM1 + W !! + Q + ; +EXIT ;EP -- exit code + KILL ^TMP("XBLM",$J,XBNODE) +K ; + KILL XBAR,XBDIR,XBFL,XBFN,XBHDR,XBI,XBROU,XBDIR + I '$G(XQORS) D CLEAR^VALM1 + K IOPAR,IOUPAR + Q + ; +EXPND ;EP -- expand code + Q + ; +FILE(XBDIR,XBFN) ;PEP - pull up a file into the TMP global for display + ; or into an array for GUI (see GUIR and GUID entry points) + I '$D(XBHDR) S XBHDR="" + NEW Y,X,I,XBNODE + S XBNODE=$G(XQORS)+1 + ;S Y=$$OPEN^%ZISH(XBDIR,XBFN,"M") + ;open hfs with zis + D DF^%ZISH(.XBDIR) + ; + ; IHS/ADC/GTH XB*3*5 start of open HF change + KILL %ZIS + I ('$D(^%ZIS(1,"B","XBLM HF DEVICE")))!('$D(^%ZIS(2,"B","P-XBLM"))) D ^XBLMSET + S IOP="XBLM HF DEVICE",%ZIS("HFSMODE")="R",%ZIS("HFSNAME")=XBDIR_XBFN + D ^%ZIS + I POP W !,*7,"CANNOT OPEN (OR ACCESS) FILE '",XBDIR,XBFN,"'." S Y=$$DIR^XBDIR("E") G EFILE + KILL ^TMP("XBLM",$J,XBNODE) + ; F I=1:1 U IO R X:DTIME S:($L(X)>250) X=$E(X,1,250) S X=$$STRIP(X) S ^TMP("XBLM",$J,XBNODE,I,0)=X Q:$$STATUS^%ZISH ; XB*3*8 + F I=1:1 U IO R X S:($L(X)>250) X=$E(X,1,250) S X=$$STRIP(X) S ^TMP("XBLM",$J,XBNODE,I,0)=X Q:$$STATUS^%ZISH ; XB*3*8 - UNIX does not find EOF w/timed READ, writes to ^TMP(, and fills up journal space. + D ^%ZISC + ; IHS/ADC/GTH XB*3*5 END of open HF change + ; + I $G(XBGUI) D KILL ^TMP("XBLM",$J,XBNODE) Q + . S I=0 + . S XBY=$$OPENROOT(XBY) + . F S I=$O(^TMP("XBLM",$J,XBNODE,I)) Q:'+I S XBZ=XBY_"I)",@XBZ=^TMP("XBLM",$J,XBNODE,I,0) + .Q + D EN^XBLM + KILL ^TMP("XBLM",$J,XBNODE) +EFILE ; + Q + ; +SFILE ;PEP - Select a host file for display. +OPEN ; + S IOP="HOME" + D ^%ZIS,DT^DICRW,^XBCLS + W !!,"Select a Directory and File",!! + S Y=$$PWD^%ZISH(.XBDIR),XBDIR=XBDIR(1) + KILL DIR + S DIR(0)="F^1:30",DIR("A")="Directory ",DIR("B")=XBDIR + K XBDIR + D ^DIR + KILL DIR + Q:$G(DTOUT) + Q:Y["^" + S XBDIR=Y +FNAME ;PEP - Select a file (directory can be pre-loaded into XBDIR) + KILL DIR +FNAME1 ; + S DIR(0)="FO^1:15",DIR("A")="File Name " + D ^DIR + KILL DIR + Q:$G(DTOUT) + G:Y["^" OPEN + G:Y="" OPEN + I Y?.N,$D(XBFL(Y)) S DIR("B")=XBFL(Y) G FNAME1 + I Y["*" K XBFL S X=$$LIST^%ZISH(XBDIR,Y,.XBFL) D G FNAME + . F XBI=1:1 Q:'$D(XBFL(XBI)) W !?5,XBI,?10,XBFL(XBI) I '(XBI#20) R X:DTIME + .Q + S XBFN=Y + ;S X=$$OPEN^%ZISH(XBDIR,XBFN,"M") + ;open hfs with zis + D DF^%ZISH(.XBDIR) + ; + ; IHS/ADC/GTH XB*3*5 start of open HF change + KILL %ZIS + I ('$D(^%ZIS(1,"B","XBLM HF DEVICE")))!('$D(^%ZIS(2,"B","P-XBLM"))) D ^XBLMSET + S IOP="XBLM HF DEVICE",%ZIS("HFSMODE")="R",%ZIS("HFSNAME")=XBDIR_XBFN + D ^%ZIS +ES ; + I POP W !,"error on open of file ",XBDIR,XBFN,! S Y=$$DIR^XBDIR("E") Q:Y=1 G FNAME + D ^%ZISC + D FILE^XBLM(XBDIR,XBFN) + K XBFN +ESFILE ; + G FNAME + Q + ; +VIEWR(XBROU,XBHDR) ;PEP ** USING XBROU print to a host file for viewing + I '$D(XBHDR) S XBHDR="" + I +$G(IO(0)) U IO(0) D:'$G(XBGUI) WAIT^DICD + S Y=$$PWD^%ZISH(.XBDIR) + S XBDIR=XBDIR(1),XBFN="XB"_$J + ;open hfs with zis + D DF^%ZISH(.XBDIR) + K %ZIS + S XBIOM=IOM + I ('$D(^%ZIS(1,"B","XBLM HF DEVICE")))!('$D(^%ZIS(2,"B","P-XBLM"))) D ^XBLMSET + S IOP="XBLM HF DEVICE;"_IOM_";6000" + S %ZIS("HFSMODE")="W",%ZIS("HFSNAME")=XBDIR_XBFN + D ^%ZIS + U IO + K DX ;IHS/JDH 6/17/98 prevent if defined when DIQ is called + D @XBROU + D ^%ZISC,HOME^%ZIS + D FILE^XBLM(XBDIR,XBFN) + S X=$$DEL^%ZISH(XBDIR,XBFN) + S IOM=XBIOM + KILL XBDIR,XBFN,XBHDR,XBNODE,XBDIR,XBFN,XBIOM + ; IHS/ADC/GTH XB*3*5 END of open HF change + ; + Q + ; +GUIR(XBROU,XBY) ;PEP - give routine and target array + Q:$L(XBY)=0 + ; + S XBGUI=1 + D VIEWR^XBLM(XBROU,"") + KILL XBGUI,XBY + Q + ; +GUID(XBROU,XBY) ;PEP give routine and target array for FM prints + Q:$L(XBY)=0 + S:XBY["(" XBY=$P(XBY,"(") + S XBGUI=1 + D VIEWD^XBLM(XBROU,"") + KILL XBGUI,XBY + Q + ; +VIEWD(XBROU,XBHDR) ;PEP ** USING XBROU print to a host file for viewing + S:'$D(XBHDR) XBHDR="" + I +$G(IO(0)) I '$G(XBGUI) U IO(0) D WAIT^DICD + S XBFN="XB"_$J,Y=$$PWD^%ZISH(.XBDIR),XBDIR=XBDIR(1) + ;S X=$$OPEN^%ZISH(XBDIR,XBFN,"W"),IOP=IO_";P-OTHER;"_IOM_";"_IOSL + ;open hfs with zis + D DF^%ZISH(.XBDIR) + ; + ; IHS/ADC/GTH XB*3*5 start of open HF change + KILL %ZIS + S XBIOM=IOM + I ('$D(^%ZIS(1,"B","XBLM HF DEVICE")))!('$D(^%ZIS(2,"B","P-XBLM"))) D ^XBLMSET + S IOP="XBLM HF DEVICE;"_IOM_";6000" + S %ZIS("HFSMODE")="W",%ZIS("HFSNAME")=XBDIR_XBFN + ;D ^%ZIS ;XBROU must open device, XB*3*10, dmj + D @XBROU + K DX ;IHS/JDH 6/17/98 prevent if defined when DIQ is called + D ^%ZISC,HOME^%ZIS + D FILE^XBLM(XBDIR,XBFN) + S X=$$DEL^%ZISH(XBDIR,XBFN) + S IOM=XBIOM + KILL XBDIR,XBFN,XBNODE,XBDIR,XBFN,XBIOM + ; IHS/ADC/GTH XB*3*5 END of open HF change + ; + Q + ; +DIQ(DIC,DA) ;PEP - Display DIC and DA after call to EN^DIQ + S IOSTO=IOST,IOST="P-DEC",IOSLO=IOSL,IOSL=6000 + I DIC=+DIC S DIC=$$DIC^XBDIQ1(DIC) + I DA'=+DA D PARSE^XBDIQ1(DA) + NEW DIQ,DR + S DIQ(0)="C" + D VIEWR^XBLM("EN^DIQ") + S IOST=IOSTO + KILL IOSTO + S IOSL=IOSLO + KILL IOSLO,XBNODE,XBDIR,XBFN + Q + ; +ARRAY(XBAR,XBHDR) ;PEP Display an array that has (...,n,0) structure + I '$D(XBHDR) S XBHDR="" + NEW Y,X,I,XBNODE + S XBNODE=$G(XQORS)+1 + KILL ^TMP("XBLM",$J,XBNODE) + S %X=XBAR,%Y="^TMP(""XBLM"","_$J_","_XBNODE_"," + D %XY^%RCR,EN^XBLM + KILL ^TMP("XBLM",$J,XBNODE),XBNODE,XBDIR,XBFN +ARRAYE ; + Q + ; +STRIP(Z) ;REMOVE CONTROLL CHARACTERS + NEW I + F I=1:1:$L(Z) I (32>$A($E(Z,I))) S Z=$E(Z,1,I-1)_" "_$E(Z,I+1,999) + Q Z + ; +OPENROOT(XBY) ;EP - return OPen RooT form of XBY .. for %RCR use + NEW L + S L=$L(XBY) + I XBY["(",$E(XBY,L)="," G CONT + I XBY'["(" S XBY=XBY_"(" G CONT + I XBY["(",$E(XBY,L)=")" S XBY=$E(XBY,1,L-1)_"," G CONT +CONT ; + Q XBY + ; diff --git a/XBLML.m b/XBLML.m new file mode 100644 index 0000000..ea05e9d --- /dev/null +++ b/XBLML.m @@ -0,0 +1,26 @@ +XBLML ; IHS/ADC/GTH - ENTER OR RESET XB DISPLAY IN LIST TEMPLATE FILE FOR LIST MANAGER ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + W !,"'XB DISPLAY' List Template..." + S DA=$O(^SD(409.61,"B","XB DISPLAY",0)),DIK="^SD(409.61," + D ^DIK:DA + S DIC(0)="L",DIC="^SD(409.61,",X="XB DISPLAY" + KILL DO,DD D FILE^DICN + S VALM=+Y + I VALM>0 D + . S ^SD(409.61,VALM,0)="XB DISPLAY^2^^132^2^21^1^1^^^XB DISPLAY^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 + ; diff --git a/XBLMP.m b/XBLMP.m new file mode 100644 index 0000000..72e59f0 --- /dev/null +++ b/XBLMP.m @@ -0,0 +1,27 @@ +XBLMP ; ; 16-MAY-1995 + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;; ; +EN ; -- main entry point for XB DISPLAY (PROTOCAL) + D EN^VALM("XB DISPLAY (PROTOCAL)") + Q + ; +HDR ; -- header code + S VALMHDR(1)="This is a test header for XB DISPLAY (PROTOCAL)." + 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 + Q + ; +HELP ; -- help code + S X="?" D DISP^XQORM1 W !! + Q + ; +EXIT ; -- exit code + Q + ; +EXPND ; -- expand code + Q + ; diff --git a/XBLMSET.m b/XBLMSET.m new file mode 100644 index 0000000..6253a7e --- /dev/null +++ b/XBLMSET.m @@ -0,0 +1,55 @@ +XBLMSET ;IHS/ADC/PDW - setup XBLM terminal subtype & XBLM HF DEVICE for XBLM [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;; + I '$D(DUZ) D ^XUP +TERM ;SETUP TERMINAL SUBTYPE "P-XBLM" + K DIC + S DIC=$$DIC^XBDIQ1(3.2) + S X="P-XBLM",DIC(0)="XL" + D ^DIC + I Y'>0 W !,"ERROR IN SELECTION OF TERMINAL SUBTYPE",! Q + S DA=+Y + D TERMDR + S DIE=DIC D ^DIE + S XBTERDA=DA + ; +DEV ; SETUP device + K DIC + S DIC=$$DIC^XBDIQ1(3.5) + S X="XBLM HF DEVICE",DIC(0)="XL" D ^DIC + I Y'>0 W !,"ERROR IN DEVICE SELECTION" Q + S DA=+Y + D DEVDR + S DIE=$$DIC^XBDIQ1(3.5) + D ^DIE + S XBDEVDA=DA + ;D DIQ^XBLM(3.2,XBTERDA) + ;D DIQ^XBLM(3.5,XBDEVDA) + Q +TERMDR ;;EP + ;;~.02///^S X="NO";~ + ;;~1///^S X=255;~ + ;;~2///^S X="#";~ + ;;~3///3000;~ + ;;~4///^S X="$C(8)";~ + ;;~99///^S X="Host File for XBLM utility"~ + ;;~END~ + S DR="" + F I=1:1 S X=$P($T(TERMDR+I),"~",2) Q:X["END" S DR=DR_X + Q +DEVDR ;; + ;;~.02///^S X="HOST FILE FOR XBLM";~ + ;;~1///^S X=$S($$VERSION^%ZOSV(1)["Cache for Windows":"C:\Tmp\Tmp.xblm",$$VERSION^%ZOSV(1)["Cache for UNIX":"/Tmp/Tmp.xblm",1:51);~ ; IHS/SET/GTH XB*3*9 10/29/2002 Originally: ;;~1///^S X=51;~ + ;;~1.9///@;~ + ;;~1.95///^S X="NO";~ + ;;~2///^S X="HOST FILE SERVER";~ + ;;~3///^S X="P-XBLM";~ + ;;~4///^S X="NO";~ + ;;~5///^S X="NO";~ + ;;~5.1///^S X="NO";~ + ;;~5.2///^S X="NO";~ + ;;~11.2///^S X="YES";~ + ;;~END~ + S DR="" + F I=1:1 S X=$P($T(DEVDR+I),"~",2) Q:X["END" S DR=DR_X + Q diff --git a/XBLUTL.m b/XBLUTL.m new file mode 100644 index 0000000..3c070c3 --- /dev/null +++ b/XBLUTL.m @@ -0,0 +1,34 @@ +XBLUTL ; IHS/ADC/GTH - LIST ^UTILITY FOR $J ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods. + ; + ; This routine lists all entries in the ^UTILITY global for + ; the current $J where $J is the first or second subscript. + ; + ; This is most useful from programmer mode. If used thru the + ; XB menu, ^UTILITY($J) is killed in ^XBKSET before this + ; routine is run. + ; +START ; + W @($S($D(IOF):IOF,1:"#")) + X ^%ZOSF("UCI") + ;W !,"^UTILITY nodes for job ",$J," in UCI ",Y,!;IHS/SET/GTH XB*3*9 10/29/2002 + W !,"^UTILITY nodes for job ",$J," in ",$S($$VERSION^%ZOSV(1)["Cache":"Namespace",1:"UCI")," ",Y,! ;IHS/SET/GTH XB*3*9 10/29/2002 + S XBLUTL("QFLG")=0,XBLUTL("X")="^UTILITY($J,"""")" + F S XBLUTL("X")=$Q(@XBLUTL("X")) Q:$P($P(XBLUTL("X"),"(",2),",")'=$J D LIST Q:XBLUTL("QFLG") + S XBLUTL("Y")=" " + F S XBLUTL("Y")=$O(^UTILITY(XBLUTL("Y"))) Q:XBLUTL("Y")="" I $D(^UTILITY(XBLUTL("Y"),$J)) D + . S XBLUTL("X")="^UTILITY("""_XBLUTL("Y")_""","_$J_")",XBLUTL("Z")="1""^UTILITY("""""_XBLUTL("Y")_""""","_$J_"""1P.E" + . D:$D(@(XBLUTL("X")))#2 LIST + . Q:XBLUTL("QFLG") + . F S XBLUTL("X")=$Q(@XBLUTL("X")) Q:XBLUTL("X")'?@XBLUTL("Z") D LIST Q:XBLUTL("QFLG") + . Q + KILL XBLUTL + Q + ; +LIST ; + I $Y>($S($D(IOSL):IOSL,1:24)-3) S Y=$$DIR^XBDIR("E"),XBLUTL("QFLG")='Y W:Y @($S($D(IOF):IOF,1:"#")) + Q:XBLUTL("QFLG") + W !,XBLUTL("X")," = ",@XBLUTL("X") + Q + ; diff --git a/XBLZRO.m b/XBLZRO.m new file mode 100644 index 0000000..aae3683 --- /dev/null +++ b/XBLZRO.m @@ -0,0 +1,72 @@ +XBLZRO ; IHS/ADC/GTH - LISTS 0TH NODES ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; This routine lists the 0th nodes of FileMan files. + ; +START ; + NEW QFLG + S QFLG=0 + W !,"^XBLZRO - This routine lists the 0th nodes of FileMan files." + D ^XBDSET + Q:'$D(^UTILITY("XBDSET",$J)) + D DEVICE + I QFLG KILL QFLG Q +EN ;PEP - List 0th node of pre-selected list of FileMan files. + ; IOF,IOSL must be set and U IO if appropriate. + I $D(IOF)#2,$D(IOSL)#2 + E Q + NEW F,G,N,X,QFLG + S QFLG=0 + D HEADER + S F=0 + F S F=$O(^UTILITY("XBDSET",$J,F)) Q:F'=+F I $D(^DIC(F,0,"GL")) S G=^("GL") D LIST Q:QFLG + D ^%ZISC + Q + ; +LIST ; + S X=$L(G),X=$E(G,1,X-1)_$S($E(G,X)=",":",0)",1:"(0)") + S N="" + S:$D(@X) N=^(0) + D:$Y>(IOSL-3) PAGE + Q:QFLG + W F,?15,X,?35,N,! + Q + ; +PAGE ; PAGE BREAK + NEW F,G,N,X + I IO=IO(0),$E(IOST,1,2)="C-" S Y=$$DIR^XBDIR("E") S:$D(DIRUT)!($D(DUOUT)) QFLG=1 KILL DIRUT,DUOUT + Q:QFLG + D HEADER + Q + ; +HEADER ; PRINT HEADER + NEW TITLE,TM,HR,MIN,TME,UCI + W:$D(IOF) @IOF + S TITLE="FILE 0TH NODE LIST",TM=$P($H,",",2),HR=TM\3600,MIN=TM#3600\60 + S:MIN<10 MIN="0"_MIN + S TME=HR_":"_MIN + I '$D(DT) S %DT="",X="T" D ^%DT S DT=Y + S Y=DT + X ^DD("DD") + W Y,"@",TME,?30,TITLE + X ^%ZOSF("UCI") + S UCI="UCI: "_$P(Y,",",1) + W ?65,UCI,!,"FILE",?15,"GLOBAL",?35,"0TH NODE",!! + Q + ; +DEVICE ; GET DEVICE (QUEUEING ALLOWED) + W ! + S %ZIS="Q" + D ^%ZIS + I POP S QFLG=1 KILL POP Q + I $D(IO("Q")) D S QFLG=1 Q + . S ZTRTN="EN^XBLZRO",ZTIO=ION,ZTDESC="List 0th nodes",ZTSAVE("^UTILITY(""XBDSET"",$J,")="" + . D ^%ZTLOAD + . W !!,$S($D(ZTSK):"Request queued!",1:"Request cancelled!") + . D ^%ZISC + . KILL ZTSK,IO("Q") + . KILL ZTIO ; ^%ZTLOAD kills other ZT* variables, but not this one + . Q + U IO + Q + ; diff --git a/XBMAIL.m b/XBMAIL.m new file mode 100644 index 0000000..cc766a9 --- /dev/null +++ b/XBMAIL.m @@ -0,0 +1,113 @@ +XBMAIL ; IHS/ADC/GTH - MAIL MESSAGE TO SECURITY KEY HOLDERS ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; 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) + KILL ^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 + KILL ^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 + Q:'$D(^XUSEC(K)) + 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!(X="") 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 + ; diff --git a/XBNEW.m b/XBNEW.m new file mode 100644 index 0000000..f7f47ad --- /dev/null +++ b/XBNEW.m @@ -0,0 +1,58 @@ +XBNEW(XBRET) ; IHS/ADC/GTH - NESTING OF DIE ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Unwinder problem with NEW'ing + ; + ; PROGRAMMERS: DO NOT USE THE FIRST LINE FOR ENTRY. + ; USE LABEL EN^XBNEW() FOR ENTRY. + ; + ; 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",XBKVAR=$P($T(XBKVAR),";;",2),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,"*"),XBN=XBN_","_XB,XBL=$L(XB) + . F S XBY=$O(@XBY) Q:((XBY="")!(XB'=$E(XBY,1,XBL))) S XBN=XBN_","_XBY + .Q +RETURN ; + S XBN="("_XBN_","_XBKVAR_")",$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,IOBS,IOF,IOM,ION,IOSL,IOST,IOT,IOS,IOXY,U,XRTL,%ZH0,XQVOL,XQY,XQY0,XQDIC,XQPSM,XQPT,XQAUDIT,XQXFLG,ZTSTOP,ZTQUEUED,ZTREQ,XQORS;; IHS/SET/GTH XB*3*9 10/29/2002 + ;;DUZ,DTIME,DT,DISYS,IO,IOF,IOBS,IOM,ION,IOSL,IOST,IOT,IOS,IOXY,U,XRTL,ZTSTOP,ZTQUEUED,ZTREQ ; IHS/SET/GTH XB*3*9 10/29/2002 + ;-------------------------------------------------------------- + Q + ; diff --git a/XBNODEL.m b/XBNODEL.m new file mode 100644 index 0000000..55a12ae --- /dev/null +++ b/XBNODEL.m @@ -0,0 +1,43 @@ +XBNODEL ; IHS/ADC/GTH - PREVENT USER FROM DELETING ENTRIES ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; This routine sets FileMan dictionaries so users cannot + ; delete entries. Protection is provided by SET'ing the + ; "DEL" node of the .01 fields in the selected dd's to + ; "I 1". + ; +START ; + I $G(DUZ(0))'="@" W !,*7," Insufficient FileMan access. DUZ(0) is not ""@""." Q + S U="^",IOP=$I + D ^%ZIS + W !!,"^XBNODEL - This program sets FileMan dictionaries so users cannot delete",!," entries." + ; + D ^XBDSET + G:'$D(^UTILITY("XBDSET",$J)) EOJ +ASK ; + S XBNDASK=$$DIR^XBDIR("Y","Do you want to be asked before setting each file","Y","","",2) + W ! + S XBNDFILE="" + F XBNDL=0:0 S XBNDFILE=$O(^UTILITY("XBDSET",$J,XBNDFILE)) Q:XBNDFILE="" D PROCESS + G EOJ + ; +PROCESS ; + S XBNDANS="Y" + I $G(@("^DD("_XBNDFILE_",.01,""DEL"",.01,0)"))="I 1" W !,@("$P(^DIC("_XBNDFILE_",0),U,1)")," is already protected." Q + W !,@("$P(^DIC("_XBNDFILE_",0),U,1)"),$S(XBNDASK:"..OK? Y// ",1:"") +P2 ; + I XBNDASK R XBNDANS:$G(DTIME,999) S:XBNDANS="" XBNDANS="Y" I "YyNn"'[$E(XBNDANS) D P2ERR G P2 + I XBNDANS="Y" S @("^DD("_XBNDFILE_",.01,""DEL"",.01,0)")="I 1" W " Done" + Q + ; +P2ERR ; + W *7 + F XBNDI=1:1:$L(XBNDANS) W @IOBS," ",@IOBS + Q + ; +EOJ ; + KILL ^UTILITY("XBDSET",$J) + KILL XBNDANS,XBNDASK,XBNDFILE,XBNDI,XBNDL + KILL BS,FF,RM,SL,SUB,XY + Q + ; diff --git a/XBOFF.m b/XBOFF.m new file mode 100644 index 0000000..cb97289 --- /dev/null +++ b/XBOFF.m @@ -0,0 +1,15 @@ +XBOFF ; IHS/ADC/GTH - SET REVERSE VIDEO OFF ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; Original routine from IHS/OHPRD/EDE. 08-25-95 + ; + ; See also routine XBVIDEO. + ; +START ; + NEW %,X,IORVON,IORVOFF + I '$G(IOST(0)) D HOME^%ZIS + S X="IORVON;IORVOFF" + D ENDR^%ZISS + W IORVOFF + Q + ; diff --git a/XBON.m b/XBON.m new file mode 100644 index 0000000..dd77e9e --- /dev/null +++ b/XBON.m @@ -0,0 +1,15 @@ +XBON ; IHS/ADC/GTH - SET REVERSE VIDEO ON ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; Original routine from IHS/OHPRD/EDE. 08-25-95 + ; + ; See also routine XBVIDEO. + ; +START ; + NEW %,X,IORVON,IORVOFF + I '$G(IOST(0)) D HOME^%ZIS + S X="IORVON;IORVOFF" + D ENDR^%ZISS + W IORVON + Q + ; diff --git a/XBPATC.m b/XBPATC.m new file mode 100644 index 0000000..d1cfefa --- /dev/null +++ b/XBPATC.m @@ -0,0 +1,69 @@ +XBPATC ; IHS/ADC/GTH - CHECK PATIENT GLOBALS ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; $O thru the PATIENT and 3RD party globals looking for missing entries + ; + ; Thanks to Robert F. Dolan for the original routine. + ; +ST ; + W !,"I WILL $O THRU THE PATIENT GLOBALS LOOKING FOR UNEQUAL DFN" + W !,"AS UNEQUAL DFN ARE FOUND THE DFN WILL BE DISPLAYED" + W !,"YOU SHOULD USE A SLAVE PRINTER FOR THIS RUN, AS THE SCREEN WILL SCROLL AND YOU WILL LOSE NEEDED INFORMATION",! + Q:'$$DIR^XBDIR("E") + S (CNT,CNT1,CNT2,CNT3)=0,U="^" + W !,"LOOPING THROUGH THE IHS PATIENT GLOBAL",! +LOOP ; + S DFN=0 + F S DFN=$O(^AUPNPAT(DFN)) Q:DFN?.A W "I" D:'$D(^DPT(DFN)) PRT +LOOP1 ; + W !,"LOOPING THROUGH THE VA PATIENT GLOBAL",! + S DFN=0 + F S DFN=$O(^DPT(DFN)) Q:DFN?.A W "V" D:'$D(^AUPNPAT(DFN)) PRT1 +LOOP2 ; + W !,"LOOPING THROUGH THE MEDICARE GLOBAL",! + S DFN=0 + F S DFN=$O(^AUPNMCR(DFN)) Q:DFN?.A W "M" D:'$D(^AUPNPAT(DFN)) PRT2 +LOOP3 ; + W !,"LOOPING THROUGH THE MEDICAID GLOBAL",! + S (DFN,DA)=0 + F S DA=$O(^AUPNMCD(DA)) Q:DA?.A D + . S DFN=$P(^AUPNMCD(DA,0),U,1) + . W "D" + . I DFN="" D PRT3 Q + . D:'$D(^AUPNPAT(DFN)) PRT2 + .Q +LOOP4 ; + W !,"LOOPING THROUGH THE RAILROAD GLOBAL",! + S DFN=0 + F S DFN=$O(^AUPNRRE(DFN)) Q:DFN?.A W "R" D:'$D(^AUPNPAT(DFN)) PRT2 +LOOP5 ; + W !,"LOOPING THROUGH THE PRIVATE INSURANCE GLOBAL",! + S DFN=0 + F S DFN=$O(^AUPNPRVT(DFN)) Q:DFN?.A W "P" D:'$D(^AUPNPAT(DFN)) PRT2 +EXIT ; + W !!,"**E N D O F R U N **" + W !,"NUMBER OF DFN NOT IN DPT=",CNT + W !,"NUMBER OF DFN NOT IN AUPNPAT=",CNT1 + W !,"NUMBER OF 3RD PARTY DFN's NOT IN AUPNPAT=",CNT2 + W !,"NUMBER OF MEDICAID RECORDES WITH BAD DFN=",CNT3 + KILL CNT,CNT1,CNT2,CNT3,AZHDNUM + Q + ; +PRT ;PRINT FOR ENTRIES IN AUPNPAT NOT IN DPT + W !!,"ENTRY IN AUPNPAT NOT IN DPT, DFN=",DFN + S CNT=CNT+1 + Q + ; +PRT1 ;PRINT FOR ENTRIES IN DPT NOT IN AUPNPAT + W !!,"ENTRY IN DPT NOT IN AUPNPAT, DFN=",DFN + S CNT1=CNT1+1 + Q +PRT2 ;PRINT FOR ENTRIES IN 3RD PARTY FILES BUT NOT IN AUPNPAT + W !!,"ENTRY IN 3RD PARTY FILE NOT IN AUPNPAT, DFN=",DFN + S CNT2=CNT2+1 + Q +PRT3 ;PRINT FOR ENTRIES IN MEDICAID GLOBAL BUT NOT IN AUPNPAT OR POINTER NOT VALID + W !!,"ENTRY IN MEDICAID GLOBAL BUT DFN INVALID, DA=",DA,! + S CNT3=CNT3+1 + Q + ; diff --git a/XBPATSE.m b/XBPATSE.m new file mode 100644 index 0000000..121976e --- /dev/null +++ b/XBPATSE.m @@ -0,0 +1,195 @@ +XBPATSE ; IHS/ADC/GTH - SEARCH ROUTINES FOR PATCHES ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods. + ; + ; Search Routines for Patch Versions. + ; + ; Thanks to Ray A. Willie for the original routine. + ; +MAIN ; + NEW XB,DUZ,IO,IOF,IOM,IOSL,IOBS,IOXY,IOST,DT,DTIME,POP,U,X,Y + D INIT + D:'$D(ZTQUEUED) + . D RSEL + . D:'XB("END") DEVICE + .Q + D:'XB("END") SRCH + D:'XB("END") PRT + D EXIT + Q + ; +INIT ; + S (XB("END"),XB("VER"),XB("PNBR"),XB("Q"))=0,XB("NAM")="" + KILL ^TMP($J) + D:'$D(ZTQUEUED) ^XBKVAR,DT^DICRW,HOME^%ZIS + D NOW^%DTC + S Y=% + X ^DD("DD") + S XB("DT")=Y + X ^%ZOSF("UCI") + S XB("UCI")=$P(Y,","),XB("VOL")=$P(Y,",",2) + S XB("HD1")="R.P.M.S. PATCH SEARCH UTILITY Version: "_$P($T(+2),";",3) + S XB("HD2")="UCI: "_XB("UCI")_" CPU: "_XB("VOL")_" "_XB("DT") + Q + ; +RSEL ; + D SCHDR + X ^%ZOSF("RSEL") + S XB("END")='$D(^UTILITY($J)) + Q + ; +DEVICE ; + NEW %ZIS + S %ZIS="NMQ" + D ^%ZIS + S XB("END")=POP + Q:XB("END") + S XB("IOP")=ION_";"_IOST_$S($D(IO("DOC")):";"_IO("DOC"),1:";"_IOM_";"_IOSL) + D:$D(IO("Q")) QUE + Q + ; +QUE ; + NEW ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTSK + D:IO=IO(0)&($E(IOST,1,2)="C-")&($D(IO("Q"))#2) + . W !,"Cannot Queue to HOME or CHARACTER Device",! + . S XB("END")=1 + .Q + Q:XB("END") + S ZTRTN="^"_$TR($P($T(+1),";")," ",""),ZTIO=XB("IOP"),ZTDESC=$P($T(+1),";",2) + F Q:$E(ZTDESC)'=" " S ZTDESC=$E(ZTDESC,2,99) + S ZTSAVE("^UTILITY($J,")="" + D ^%ZTLOAD + I '$D(ZTSK) W !,"TASK not Queued with Task Manager",! S XB("END")=1 + Q:XB("END") + S %H=ZTSK("D") + D YX^%DTC + W !,"TASK Queued with Task Manager: JOB # ",ZTSK," at ",Y,! + D HOME^%ZIS + S XB("END")=1 + Q + ; +SRCH ; + NEW XCNP,DIF + D:'$D(ZTQUEUED) SCHDR + S XB("NSP")="" + F S XB("NSP")=$O(^DIC(9.4,"C",XB("NSP"))) Q:XB("NSP")="" D + . S XB("EIN")=0,XB("EIN")=$O(^DIC(9.4,"C",XB("NSP"),XB("EIN"))) + . S XB("NAM")=$P($G(^DIC(9.4,XB("EIN"),0)),U) + . S XB("VER")=$G(^DIC(9.4,XB("EIN"),"VERSION"),0) + . S XB("ROU")=XB("NSP") + . S:$D(^UTILITY($J,XB("ROU"))) XB("ROU")=$O(^UTILITY($J,XB("ROU")),-1) + . F XB("RKT")=0:1 S XB("ROU")=$O(^UTILITY($J,XB("ROU"))) Q:$E(XB("ROU"),1,$L(XB("NSP")))'=XB("NSP") D SRCH1 + . D:XB("RKT")>0 SRCH2 + .Q + ;S XB("NSP")="~~",XB("ROU")="";IHS/SET/GTH XB*3*9 10/29/2002 + S XB("NSP")="~~",XB("ROU")=0 ;IHS/SET/GTH XB*3*9 10/29/2002 + F XB("RKT")=0:1 S XB("ROU")=$O(^UTILITY($J,XB("ROU"))) Q:XB("ROU")="" D + . S XB("NAM")="",XB("VER")=0 + . D SRCH1 + .Q + S XB("NAM")="%",XB("VER")=0 + D:XB("RKT")>0 SRCH2 + Q + ; +SRCH1 ; + D:'$D(ZTQUEUED) + . W:'(XB("RKT")#8) ! + . W XB("ROU"),$J("",9-$L(XB("ROU"))) + .Q + S XCNP=0,DIF="^TMP("_$J_",""R"","""_XB("ROU")_""",",X=XB("ROU") + X ^%ZOSF("TEST") + Q:'$T + X ^%ZOSF("LOAD") + S XB("PPC")=$TR($P($G(^TMP($J,"R",XB("ROU"),2,0)),";",5),"*","") + D:XB("PPC")]""&(XB("PPC")'=0) + . S:XB("NAM")="" XB("NAM")=$P($G(^TMP($J,"R",XB("ROU"),2,0)),";",4) + . S:XB("VER")=0 XB("VER")=$P($G(^TMP($J,"R",XB("ROU"),2,0)),";",3) + . S XB("DESC")=$S($P($P($G(^TMP($J,"R",XB("ROU"),1,0)),";",2),"-",2,3)'="":$P($P($G(^TMP($J,"R",XB("ROU"),1,0)),";",2),"-",2,3),1:$P($G(^TMP($J,"R",XB("ROU"),1,0)),";",3)) + . F Q:$E(XB("DESC"))'=" " S XB("DESC")=$E(XB("DESC"),2,99) + . D:XB("VER")]""&(XB("NAM")]"") + .. F XB("J")=1:1 S XB("PNR")=$P(XB("PPC"),",",XB("J")) Q:XB("PNR")="" D:XB("PNR")?1.4N + ... S ^TMP($J,"P",XB("NSP"),XB("NAM"),XB("VER"),XB("PNR"),XB("ROU"))=XB("DESC") + ... S ^TMP($J,"P","P",XB("PNR"))="" + ... S ^TMP($J,"P","R",XB("ROU"))="" + KILL ^TMP($J,"R",XB("ROU")),^UTILITY($J,XB("ROU")) + Q + ; +SRCH2 ; + W:'$D(ZTQUEUED) !!?5,XB("RKT")," Routines Processed",!! + S (XB("PNR"),XB("ROU"))="" + F XB("PKT")=0:1 S XB("PNR")=$O(^TMP($J,"P","P",XB("PNR"))) Q:XB("PNR")="" + F XB("PRK")=0:1 S XB("ROU")=$O(^TMP($J,"P","R",XB("ROU"))) Q:XB("ROU")="" + KILL ^TMP($J,"P","P"),^TMP($J,"P","R") + S ^TMP($J,"P",XB("NSP"),XB("NAM"),XB("VER"),.01)=XB("RKT") + S ^TMP($J,"P",XB("NSP"),XB("NAM"),XB("VER"),.02)=XB("PKT") + S ^TMP($J,"P",XB("NSP"),XB("NAM"),XB("VER"),.03)=XB("PRK") + Q + ; +SCHDR ; + W !,?IOM-$L(XB("HD1"))\2,XB("HD1"),!,?IOM-$L(XB("HD2"))\2,XB("HD2"),! + Q + ; +PRT ; + S XB("PAGE")=0,XB("NSP")="" + D:'$D(ZTQUEUED) + . S IOP=XB("IOP") + . D ^%ZIS + .Q + U IO + D HDR + F S XB("NSP")=$O(^TMP($J,"P",XB("NSP"))) Q:XB("NSP")=""!(XB("END")) D + . S XB("NAM")="" + . F S XB("NAM")=$O(^TMP($J,"P",XB("NSP"),XB("NAM"))) Q:XB("NAM")=""!(XB("END")) D + .. D:XB("NAM")="%" + ... W !!,"****",?5,"ROUTINES THAT ARE NOT IN PACKAGE FILE NAME-SPACE" + ... W !?5,^TMP($J,"P",XB("NSP"),"%",0,.01)," TOTAL ROUTINE(s): " + ... W ^TMP($J,"P",XB("NSP"),"%",0,.02)," PATCHE(s) in " + ... W ^TMP($J,"P",XB("NSP"),"%",0,.03)," ROUTINE(s)",! + ... S XB("NAM")=$O(^TMP($J,"P",XB("NSP"),XB("NAM"))) + .. S XB("END")=(XB("NAM")="") + .. Q:XB("END") + .. S XB("VER")=.5 + .. F S XB("VER")=$O(^TMP($J,"P",XB("NSP"),XB("NAM"),XB("VER"))) Q:XB("VER")=""!(XB("END")) D + ... D:$Y+5>IOSL HDR + ... Q:XB("END") + ... W !!,XB("NSP"),?5,XB("NAM")," -- Version: ",XB("VER") + ... D:XB("NSP")'="~~" + .... W !?5,^TMP($J,"P",XB("NSP"),XB("NAM"),XB("VER"),.01)," TOTAL ROUTINE(s): " + .... W ^TMP($J,"P",XB("NSP"),XB("NAM"),XB("VER"),.02)," PATCHE(s) in " + .... W ^TMP($J,"P",XB("NSP"),XB("NAM"),XB("VER"),.03)," ROUTINE(s)",! + ... S XB("PNBR")=.5 + ... F S XB("PNBR")=$O(^TMP($J,"P",XB("NSP"),XB("NAM"),XB("VER"),XB("PNBR"))) Q:XB("PNBR")=""!(XB("END")) D + .... S XB("ROU")="" + .... F S XB("ROU")=$O(^TMP($J,"P",XB("NSP"),XB("NAM"),XB("VER"),XB("PNBR"),XB("ROU"))) Q:XB("ROU")=""!(XB("END")) D + ..... D:$Y+5>IOSL HDR + ..... Q:XB("END") + ..... W !,$J(XB("PNBR"),4),?5,XB("ROU"),?14,^TMP($J,"P",XB("NSP"),XB("NAM"),XB("VER"),XB("PNBR"),XB("ROU")) + Q + ; +HDR ; + NEW DIRUT,DUOUT + D:XB("PAGE")&($E(IOST,1,2)="C-")&(IO=IO(0)) + . S Y=$$DIR^XBDIR("E") + . S:$D(DIRUT)!($D(DUOUT)) XB("END")=1 + .Q + Q:XB("END") +HDR1 ; + D:$D(IO("S"))&('XB("PAGE")) + . S (DX,DY)=0 + . X ^%ZOSF("XY") + .Q + W:$E(IOST,1,2)="C-"!(($E(IOST,1,2)'="C-")&(XB("PAGE"))) @IOF +HDR2 ; + S XB("PAGE")=XB("PAGE")+1 + W !,?IOM-$L(XB("HD1"))\2,XB("HD1"),?(IOM-15),"PAGE: ",$J(XB("PAGE"),3) + W !,?IOM-$L(XB("HD2"))\2,XB("HD2") + W !,"PATCH" + W !,"NMBR",?5,"ROUTINE",?14,"ROUTINE DESCRIPTION" + W !,"==== ======== ",$$REPEAT^XLFSTR("=",IOM-19) + Q + ; +EXIT ; + D ^%ZISC + KILL ^UTILITY($J),^TMP($J) + Q + ; diff --git a/XBPFTV.m b/XBPFTV.m new file mode 100644 index 0000000..3670934 --- /dev/null +++ b/XBPFTV.m @@ -0,0 +1,52 @@ +XBPFTV(F,E,V) ; IHS/ADC/GTH - RETURN POINTER FIELD TERMINAL VALUE ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; 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 + ; + ; 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. + ; +START ; + NEW D,G + F D TRACE Q:D + Q + ; +TRACE ; FOLLOW POINTER CHAIN + S D=1,V=E + Q:'E + 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 + ; diff --git a/XBPKDEL.m b/XBPKDEL.m new file mode 100644 index 0000000..b9706dd --- /dev/null +++ b/XBPKDEL.m @@ -0,0 +1,146 @@ +XBPKDEL ; IHS/ADC/GTH - REMOVE OPTIONS, INPUT,SORT,PRINT TEMPLATES, HELP FRAMES, BULLETINS, FUNCTIONS, AND IF INDICATED, SECURITY KEYS FOR A PACKAGE ; [ 12/11/2000 3:13 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*8 - IHS/ASDST/GTH - 12-07-00 - Also delete Forms, Protocols, and List templates. Add support for routine XBPKDEL1. + ; + ; XBPKNSP must be set to the namespace, e.g. "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 ; XB*3*8 + F XBPKGLO="^DIBT(","^DIPT(","^SD(409.61,","^DIE(","^DIST(.403,","^DIC(19,","^XMB(3.6,","^DIC(9.2,","^DD(""FUNC"",","^ORD(101," D DELETE ; XB*3*8 + 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," ; XB*3*8 + ; W !,"and print templates, bulletins, functions, " ; XB*3*8 + ; W $S($D(XBPKEY):"help frames and security keys",1:"and help frames") ; XB*3*8 + ; W !,"namespaced '",XBPKNSP,"' that are currently in this UCI. " ; XB*3*8 + ; XB*3*8 begin block + KILL ^UTILITY($J,"W") + NEW DIW,DIWL,DIWR,DIWF,DIWT + S DIWL=1,DIWR=(IOM-10),DIWF="W" + W !!,*7 + S X=XBPKDOC + D ^DIWP + S X="will delete all options, templates (sort, input, list, and print), forms, bulletins, functions, protocols, " + D ^DIWP + S X=$S($D(XBPKEY):"help frames and security keys",1:"and help frames")_" namespaced '"_XBPKNSP_"' that are currently in this UCI." + D ^DIWP,^DIWW + KILL ^UTILITY($J,"W") + ; XB*3*8 end block + 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 KILL 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 KILL 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 KILL DIK,DA ; XB*3*8 + F L=0:0 S XBPKNSPC=$O(@(XBPKGLO_"""B"",XBPKNSPC)")) Q:XBPKNSPC=""!(XBPKNSPC]XBPKQUIT) S DA=$O(@(XBPKGLO_"""B"",XBPKNSPC,"""")")) W !?3,XBPKNSPC D S DIK=XBPKGLO D ^DIK KILL DIK,DA ; XB*3*8 + . ; XB*3*8 begin block + . ; Delete key from holders + . Q:XBPKGLO'="^DIC(19.1," + . S XBPKKIEN=DA + . NEW DA + . S XBPKHIEN=0 + . F S XBPKHIEN=$O(^XUSEC(XBPKNSPC,XBPKHIEN)) Q:'XBPKHIEN D + .. S DIE="^VA(200,XBPKHIEN,51,",DA(1)=XBPKHIEN,DA=XBPKKIEN,DR=".01///@" + .. D ^DIE + .. Q + . Q + ; XB*3*8 end block + 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,! ; XB*3*8 + W @IOF,!!,"Listing of items in namespace ",XBPKNSP,! ; XB*3*8 + W "--------------------------------------",! + S XBPKQUIT=XBPKNSP_"{",XBPKF=0 + ; F XBPKGLO="^DIBT(","^DIPT(","^DIE(","^DIC(19,","^DIC(19.1,","^XMB(3.6,","^DIC(9.2,","^DD(""FUNC""," D LIST2 ; XB*3*8 + F XBPKGLO="^DIBT(","^DIPT(","^SD(409.61,","^DIE(","^DIST(.403,","^DIC(19,","^DIC(19.1,","^XMB(3.6,","^DIC(9.2,","^DD(""FUNC"",","^ORD(101," D LIST2 ; XB*3*8 + 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 Y=$$DIR^XBDIR("E") + ; W @IOF ; XB*3*8 + W @IOF,! ; XB*3*8 + 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 ;EP - Clean up after this routine or XBPKDEL1 ; XB*3*8 + ; KILL XBPKF,XBPKGLO,XBPKEY,XBPKSTP,XBPKNSP,XBPKNSPC,XBPKQUIT,XBPKRUN,XBPKDOC,DUOUT,DTOUT ; XB*3*8 + KILL XBPKF,XBPKGLO,XBPKHIEN,XBPKKIEN,XBPKEY,XBPKSTP,XBPKNSP,XBPKNSPC,XBPKQUIT,XBPKRUN,XBPKDOC,DUOUT,DTOUT ; XB*3*8 + Q + ; diff --git a/XBPKDEL1.m b/XBPKDEL1.m new file mode 100644 index 0000000..6142f2a --- /dev/null +++ b/XBPKDEL1.m @@ -0,0 +1,124 @@ +XBPKDEL1 ; IHS/ADC/GTH - DELETE RETIRED AND REPLACED PACKAGES ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*8 - IHS/ASDST/GTH - 12-07-00 - New routine with patch 8. + ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Use $GLOBAL. + ; + ; DECERT subroutine processes a list of retired/replaced + ; packages, and gives the user the opportunity to delete all + ; the package components, the routines, and globals, in the + ; namspace of the package. + ; +Q Q + ; ------------------------------------------------------------- +DECERT ;EP - Delete de-certified packages. + 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 @IOF,!!,"You'll be given the opportunity to delete the following packages,",!,"Routines, and Globals in the indicated namespace, in 3 steps." +L1 ; + W !,"NAMESPACE--DESCRIPTION----------------------------RTNS-----GBLS------" + ; + NEW C,G,L,R + ; + F C=1:1 S L=$T(KILLEM+C),L=$P(L,";",3) Q:L="###" D + . W !,$P(L,"^",1),?11,$P(L,"^",2),?50,$J($$RSEL^ZIBRSEL($P(L,"^",1)_"*"),4),?59,$J($$CG($P(L,"^",1)),4) + . I $Y>(IOSL-3),$$DIR^XBDIR("E","Press RETURN for the rest of the list") W @IOF + .Q + ; + Q:$G(XBLIST) + ; + I '$$DIR^XBDIR("Y","Are you sure you want to continue","NO",$G(DTIME,300)) Q + ; + W !!,"There will be 3 steps:" + W !?10,"1) Delete package via call to XBPKDEL;" + W !?10,"2) Delete Routines (not asked if 0 routines);" + W !?10,"3) Delete Globals (not asked if 0 globals)." + W !,"Of course, your wisdom will be questioned if you do this w/o a full b/u...",! + ; + Q:'$$DIR^XBDIR("E") + ; + F C=1:1 S L=$T(KILLEM+C),L=$P(L,";",3) Q:L="###" D Q:$G(XBPKSTP) + . W !!,$P(L,"^",1),?11,$P(L,"^",2) + . S XBPKEY=1,XBPKNSP=$P(L,"^",1) + . D DEL(XBPKNSP) + . Q:$G(XBPKSTP) + . D RTNS(XBPKNSP) + . Q:$G(XBPKSTP) + . D GBLS(XBPKNSP) + . Q:$G(XBPKSTP) + .Q + ; + D EOJ^XBPKDEL + Q + ; + ; ------------------------------------------------------------- +DEL(XBPKNSP) ; + W !,"Deleting the ",XBPKNSP," package components via call to XBPKDEL" + NEW C,G,L,R + S XBPKRUN="" + D ^XBPKDEL + Q + ; ------------------------------------------------------------- +RTNS(XBPKNSP) ; + NEW C,G,L,R,XB + S XB=$$RSEL^ZIBRSEL(XBPKNSP_"*") + Q:'XB + I '$$DIR^XBDIR("Y","Delete "_XB_" routines in the "_XBPKNSP_" namespace","NO","","If you answer 'YES', the routines will be deleted") S:X=U XBPKSTP=1 Q + W !,"Deleting ",XB," ",XBPKNSP," routines",! + S X="" + F S X=$O(^TMP("ZIBRSEL",$J,X)) Q:X="" W X,$J("",10-$L(X)) X ^%ZOSF("DEL") + KILL ^TMP("ZIBRSEL",$J) + Q + ; ------------------------------------------------------------- +GBLS(XBPKNSP) ; + NEW C,G,L,R,XB + S XB=$$CG(XBPKNSP) + Q:'XB + I '$$DIR^XBDIR("Y","Delete "_XB_" globals in the "_XBPKNSP_" namespace","NO","","If you answer 'YES', the globals will be deleted") S:X=U XBPKSTP=1 Q + W !,"Kill'ing ",$$CG(XBPKNSP)," ",XBPKNSP," globals",! + S G="^"_XBPKNSP,L=$L(XBPKNSP) + ;I '$$KILLOK^ZIBGCHAR(G) KILL @G ;IHS/SET/GTH XB*3*9 10/29/2002 + I '$$KILLOK^ZIBGCHAR(XBPKNSP) KILL @G ;IHS/SET/GTH XB*3*9 10/29/2002 + ;F S G=$O(@G) Q:'($E(G,1,L)=XBPKNSP) S G="^"_G W G,$J("",10-$L(G)) D ;IHS/SET/GTH XB*3*9 10/29/2002 + F S G=$O(^$G(G)) Q:'($E(G,2,L+1)=XBPKNSP) W G,$J("",10-$L(G)) D ;IHS/SET/GTH XB*3*9 10/29/2002 + . I '$$KILLOK^ZIBGCHAR($E(G,2,$L(G))) KILL @G Q + . W !,": ",$$ERR^ZIBGCHAR($$KILLOK^ZIBGCHAR($E(G,2,$L(G)))) + .Q + Q + ; ------------------------------------------------------------- +CG(N) ; Count the globals in the N namespace. + NEW C,G,L,R + S C=0,G="^"_N,L=$L(N) + I $D(@G) S C=1 + ;F S G=$O(@G) Q:'($E(G,1,L)=N) S G="^"_G,C=C+1 ;IHS/SET/GTH XB*3*9 10/29/2002 + F S G=$O(^$G(G)) Q:'($E(G,2,L+1)=N) S C=C+1 ;IHS/SET/GTH XB*3*9 10/29/2002 + Q C + ; ------------------------------------------------------------- +LIST ;EP - List retired/replaced packages. + NEW XBLIST + S XBLIST=1 + W @IOF + D L1 + Q + ; ------------------------------------------------------------- +KILLEM ; Add the packages to be deleted, below: Namespace^Description + ;;AAPC^Ambulatory Patient Care Data Entry + ;;ACI^Injury Report + ;;ACHA^Community Health Nursing + ;;ADB^Diabetic Tracking System + ;;AMAL^Malpractice Claims + ;;APCM^PCC Table Maintenance + ;;AMCP^Women's Health/Pap Smear + ;;AMR^Management Status + ;;AMS^Management Referral + ;;APCQ^PCC Quality Assurance + ;;APCG^Family Genetic Linkage + ;;APCR^PCC Register + ;;APCS^PCC Surveillance + ;;APCT^PCC Clinic Training + ;;APHR^Physician Tracking + ;;ATA^Original Time and Attendance + ;;ALP^Mainframe to RPMS data insertion + ;;BRB^Institutional Review Board + ;;### + ; diff --git a/XBPKG.m b/XBPKG.m new file mode 100644 index 0000000..ef889c7 --- /dev/null +++ b/XBPKG.m @@ -0,0 +1,62 @@ +XBPKG ;IHS/SET/GTH - MOVE FILES INTO PACKAGE ENTRY ; [ 04/18/2003 9:06 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;IHS/SET/GTH XB*3*9 10/29/2002 New Routine. + ; Move selected files into the selected entry in the PACKAGE + ; file. The entry in the PACKAGE file can then be DIFROM'd, and + ; the resulting routines searched for routine or global references + ; or lines of code of interest. + ; + ; The IENs in the PACKAGE multiple will be equal to the FILE number. + ; Data will not be included with files. + ; + ; User will be asked if all entries in the selected entry in PACKAGE + ; should be KILL'd before the move. If the FILE multiple is not + ; KILL'd, the selected files will be added (possibly overwrite) to + ; the existing entries in the FILE multiple. + ; + ; +START ; + W !,"Select the files that you want to copy into the entry in PACKAGE",! + D ^XBDSET + Q:'$D(^UTILITY("XBDSET",$J)) + NEW DA + S DA=$$SELPKG + Q:+DA<1 + S X=$$ASKKILL($P(^DIC(9.4,DA,0),"^",1)) + Q:X="^" + I X KILL ^DIC(9.4,DA,4) + D MOVEFILS(DA) + D EOJ + Q + ; + ; +SELPKG() ;-- Select the entry in PACKAGE into which to move the files. + W !!,"Select the entry in PACKAGE into which to move the files" + NEW DIC + S DIC=9.4,DIC(0)="AEL" + D ^DIC + Q +Y + ; +ASKKILL(P) ;-- Ask the user if KILL multiple in PACKAGE prior to move. + Q $$DIR^XBDIR("Y","KILL the FILE multiple in PACKAGE for "_P,"N") + ; +MOVEFILS(DA) ;-- Move the selected files into the selected entry in PACKAGE. + Q:'(DA=+DA) + Q:'$D(^DIC(9.4,DA)) + NEW C,I + S (C,I)=0 + F S I=$O(^UTILITY("XBDSET",$J,I)) Q:'(I=+I) D + . S ^DIC(9.4,DA,4,I,0)=I + . S ^DIC(9.4,DA,4,I,222)="y^y^^n^^^n^m^y" + . S ^DIC(9.4,DA,4,"B",I,I)="" + . S C=C+1 + .Q + S ^DIC(9.4,DA,4,0)="^9.44PA^"_$O(^UTILITY("XBDSET",$J,99999999),-1)_"^"_C + W !!,C_" files set into Package "_$P(^DIC(9.4,DA,0),U)_".",! + Q + ; +EOJ ; + KILL XBDSC,XBDSFF,XBDSFILE,XBDSHI,XBDSL,XBDSLO,XBDSND,XBDSP,XBDSQ,XBDSTF,XBDSX + KILL DIC,DIR,DIRUT,DTOUT,DUOUT,X,Y + Q + ; diff --git a/XBPOST.m b/XBPOST.m new file mode 100644 index 0000000..53649b8 --- /dev/null +++ b/XBPOST.m @@ -0,0 +1,185 @@ +XBPOST ; IHS/ADC/GTH - XB/ZIB INSTALLATION POSTINIT ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + W !!,$$C^XBFUNC("Beginning XB/ZIB post-init at "_$$FMTE^XLFDT($$HTFM^XLFDT($H))_".") + ; + W !!,$$C^XBFUNC("Checking PROTOCOL file for XB entries") + ; + F XB="XB DISPLAY","XB NEXT SCREEN","XB PREVIOUS SCREEN","XB QUIT" I '$D(^ORD(101,"B",XB)) W *7,!,"You're missing option '",XB,"' from PROTOCOL." D + . I $$DIR^XBDIR("Y","Do you want to run XBONIT to add the option","Y","","Routine XBONIT will add the XB options to your PROTOCOL file","^D HELP^XBHELP(""ORD101"",""XBPOST"")","") D ^XBONIT + .Q + ; + ; + W !,$$C^XBFUNC("Delivering mail message to local programmers") + ; + D MAIL^XBMAIL("XUMGR-XUPROGMODE","DESC^XBPOST") + ; + I $$DIR^XBDIR("Y","Do you want to un-needed routines","N","","I'll delete the XB init routines, etc. (Except routine XBINIT)") D + . S X=$$RSEL^ZIBRSEL("XBINI*","^TMP(""XBPOST"",$J,") + . KILL ^TMP("XBPOST",$J,"XBINIT") + . I $D(^ORD(101,"B","XB DISPLAY")),$D(^("XB NEXT SCREEN")),$D(^("XB PREVIOUS SCREEN")),$D(^("XB QUIT")) S X=$$RSEL^ZIBRSEL("XBONI*","^TMP(""XBPOST"",$J,") + . S X="" + . F S X=$O(^TMP("XBPOST",$J,X)) Q:X="" X ^%ZOSF("DEL") W !,X,$E("...........",1,11-$L(X)),"" + . KILL ^TMP("XBPOST",$J) + .Q + ; + W !!,$$C^XBFUNC("You can print a Technical Manual thru the option") + W !,$$C^XBFUNC("on the 'MISCELLANEOUS' menu, or with DO ^XBTM.") + ; + NEW DIC + S DIC="^DIC(19,",DIC(0)="",X="ZIB REMOTE PATCH INSTALLATION" + D ^DIC + I Y<0 W !!,$$C^XBFUNC("You don't have the Remote Patch Installer (ZIBRPI) installed."),!,$$C^XBFUNC("See instructions/descriptions in routine ZIBRPI2.") + D HELP^XBHELP("MGR","XBPOST") + ; + D EN^XBVK("XB"),EN^XBVK("ZIB") + W !!,$$C^XBFUNC("XB/ZIB v 3.0 post-init complete at "_$$FMTE^XLFDT($$HTFM^XLFDT($H))_".") + Q + ; +ORD101 ; + ;;You're missing one of the XB options from your PROTOCOL file + ;;that's needed for the XB interface to the VA's list manager + ;;(VALM). If you answer "Y"es, routine ^XBONIT will be called, + ;;which will add (or overwrite) the following entries: + ;;"XB DISPLAY", "XB NEXT SCREEN", "XB PREVIOUS SCREEN", "XB QUIT". + ;;@;! + ;;If you answer "N"o, you can run the XBONIT routine later. If + ;;you don't run ^XBONIT, and are lacking the XB entries in your + ;;PROTOCOL file, you're XB interface to the list manager will be + ;;undetermined. + ;;### + ; +MGR ; + ;;Don't forget to copy, and rename, the following routines to the + ;;MGR uci: + ;; Routine Rename As + ;; -------- -------- + ;; XBCLS %XBCLS + ;; ZIBGD %ZIBGD + ;; ZIBRD %ZIBRD + ;; ZIBCLU0 %ZIBCLU0 + ;; ZIBZUCI %ZUCI + ;;### + ; +DESC ; + ;;XB/ZIB v 3.0, Installation Announcement. + ;; + ;;++++++++++++ XB/ZIB 3.0 Installation 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) XBDIR - DIR INTERFACE. + ;;The purpose of routine XBDIR is to provide interface methodology + ;;for 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 interface. + ;; + ;;----------------------------------------------------------------- + ;; + ;;(2) XBBPI - BUILD PRE-INIT ROUTINE. + ;;Implementation specific Z commands were replaced with equivalent + ;;^%ZOSF nodes. + ;; + ;;----------------------------------------------------------------- + ;; + ;;(3) XBHELP - DISPLAY HELP TEXT TO USER. + ;;Although this routine was specifically requested to provide the + ;;flexibility to display text to the user, it can be used at other + ;;times. + ;; + ;;----------------------------------------------------------------- + ;; + ;;(4) XBHFMAN - PRINT A MANUAL CONSISTING OF INFO FROM HELP FRAMES. + ;;This utility creates a "manual" consisting of information from the + ;;option tree of the selected application, and information contained + ;;in the option descriptions and help frames. + ;; + ;;----------------------------------------------------------------- + ;; + ;;(5) XBKTMP - CLEAN ^TMP(). + ;;This routine KILLs nodes in ^TMP( whose first or second subscripts + ;;are the current $J. + ;; + ;;----------------------------------------------------------------- + ;; + ;;(6) XBLCALL - LIST CALLABLE ROUTINES. + ;;The routine has been updated to list published entry points that + ;;are supported for calls from other applications. + ;; + ;;----------------------------------------------------------------- + ;; + ;;(7) XBLM - LIST MANAGER INTERFACE. + ;;Two entry points have been added for support of future GUI + ;;programming. + ;; + ;;----------------------------------------------------------------- + ;; + ;;(8) XBON/XBOFF - SET REVERSE VIDEO ON/OFF. + ;; + ;;----------------------------------------------------------------- + ;; + ;;(9) XBTM - PRINT XB/ZIB TECH MANUAL. + ;;This routine provides for the printing of a technical manual for + ;;the XB/ZIB routines. One or all chapters can be printed. The + ;;information comes from existing routines, and other attributes, + ;;on the local machine, and will reflect all local modifications. + ;;All entry points and published entry points (PEP) are listed. + ;; + ;;----------------------------------------------------------------- + ;; + ;;(10) XBVIDEO - SET/WRITE VARIOUS DEVICE ATTRIBUTES. + ;;Entry point EN provides access to creating, writing, and resetting + ;;cursor position for various device attributes, both supported by + ;;%ZISS, and not supported by %ZISS. See the routine for the + ;;variables. + ;; + ;;----------------------------------------------------------------- + ;; + ;;(11) XBVK - KILL LIST OF LOCAL VARIABLES. + ;;This routine calls an implementation specific routine which + ;;searches the symbol table and kills local variables within the + ;;namespace passed in the parameter. + ;; + ;;----------------------------------------------------------------- + ;; + ;;(12) XBVL - LIST LOCAL VARIABLES. + ;;This is an interactive utility which will provide programmers with + ;;the ability to list a subset, based on a selected namespace, of + ;;local variables. + ;; + ;;----------------------------------------------------------------- + ;; + ;;(13) ZIBERR - PROVIDE ACCESS TO THE SYSTEM ERROR VARIABLE. + ;;This provides access to implementation specific system variable to + ;;return the current error, if any. + ;; + ;;----------------------------------------------------------------- + ;; + ;;(14) ZIBGCHAR - MODIFY GLOBAL CHARACTERISTICS. + ;;Several entry points allow modification of implementation + ;;specific global characteristics. + ;; + ;;----------------------------------------------------------------- + ;; + ;;(15) ZIBNSSV - NON-STANDARD SYSTEM VARIABLES. + ;;This routine provides access to common non-standard system + ;;variables that are implementation specific. + ;; + ;;----------------------------------------------------------------- + ;; + ;;(16) ZIBTCP - PRINT TO REMOTE PRINTER THRU TCP. + ;; + ;;----------------------------------------------------------------- + ;; + ;;+++++++++++++ end of 3.0 Installation announcement ++++++++++++++ + ;;### + ; diff --git a/XBPRE.m b/XBPRE.m new file mode 100644 index 0000000..669f2c2 --- /dev/null +++ b/XBPRE.m @@ -0,0 +1,50 @@ +XBPRE ; IHS/ADC/GTH - PREINIT, CHK RQMNTS, ETC. ; [ 01/22/2001 11:54 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*8 - IHS/ASDST/GTH Add KIDS check to suppress questions. + ; + I '$G(DUZ) W !,"DUZ UNDEFINED OR 0." D SORRY Q + ; + I '$L($G(DUZ(0))) W !,"DUZ(0) UNDEFINED OR NULL." D SORRY Q + ; + S X=$P(^VA(200,DUZ,0),U) + W !!,$$C("Hello, "_$P(X,",",2)_" "_$P(X,",")),!!,$$C("Checking Environment for Version "_$P($T(+2),";",3)_" of XB/ZIB.") + ; + S X=$G(^DD("VERSION")) + W !!,$$C("Need at least FileMan 20.....FileMan "_X_" Present") + I X<20 D SORRY Q + ; + S X=$G(^DIC(9.4,$O(^DIC(9.4,"C","XU",0)),"VERSION")) + W !!,$$C("Need at least Kernel 7.....Kernel "_X_" Present") + I X<7 D SORRY Q + ; + S X=$S($L($T(STATUS^%ZISH)):"STATUS^%ZISH is Present",1:"") + W !!,$$C("Need Patch 25 to Kernel 7 (^%ZISH)....."_X) + I '$L($T(STATUS^%ZISH)) D SORRY Q + ; + NEW DA,DIC + S X="XB",DIC="^DIC(9.4,",DIC(0)="",D="C" + D IX^DIC + I Y<0,$D(^DIC(9.4,"C","XB")) D Q + . W !!,*7,*7,$$C("You Have More Than One Entry In The"),!,$$C("PACKAGE File with an ""XB"" prefix.") + . W !,$$C("One entry needs to be deleted.") + . W !,$$C("FIX IT! Before Proceeding."),!!,*7,*7,*7 + . D SORRY + . I $$DIR^XBDIR("E") + .Q + W !!,$$C("No 'XB' dups in PACKAGE file") + ; + W !!,$$C("ENVIRONMENT OK.") + I $D(DIFQ),'$$DIR^XBDIR("E","","","","","",2) KILL DIFQ + ; The following line prevents the "Disable Options..." and "Move ; XB*3*8 - IHS/ASDST/GTH + ; Routines..." questions from being asked during the install. ; XB*3*8 - IHS/ASDST/GTH + I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0 ; XB*3*8 - IHS/ASDST/GTH + Q + ; +C(X,Y) ; Center X in field length Y/IOM/80. + Q $J("",$S($D(Y):Y,$G(IOM):IOM,1:80)-$L(X)\2)_X + ; +SORRY ; + KILL DIFQ + W *7,!,$$C("Sorry....") + Q + ; diff --git a/XBRESID.m b/XBRESID.m new file mode 100644 index 0000000..932044c --- /dev/null +++ b/XBRESID.m @@ -0,0 +1,62 @@ +XBRESID ; IHS/ADC/GTH - CLEAN UP RESIDUAL ENTRIES IN ^DD ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; This routine deletes residual entries in ^DD by a range of + ; dictionary numbers. A residual entry is one that has no + ; parent. The process is reiterative, so an entry who has a + ; parent in ^DD, but the parent is deleted because it has no + ; parent, will also be deleted. The parent of an entry in + ; ^DD is defined as another entry in ^DD for sub-files, and + ; an entry in ^DIC for primary files. + ; + ; The range of dictionary numbers is inclusive but residual + ; entries for the high file number will not be deleted at + ; the sub-file level. This is because sub-files are numbered + ; with the primary file number with decimal numbers appended. + ; The terminating check is ^DD entry greater than high file + ; number specified, so by definition all sub-files for the + ; high number are greater than the high number. + ; + ; This routine can be called by another routine by setting + ; XBRLO and XBRHI and then D EN1^XBRESID. + ; +START ; + W !!,"This program deletes residual entries in ^DD by a range of dictionary numbers.",!! + ; +LO ; + R !,"Enter low dictionary number: ",XBRLO:$G(DTIME,999) + Q:XBRLO'=+XBRLO +HI ; + R !,"Enter high dictionary number: ",XBRHI:$G(DTIME,999) + Q:XBRHI'=+XBRHI!(XBRHI'>XBRLO) + ; +EN1 ;PEP - Clean residual entries in ^DD(. Hi/Lo file numbers must be set. + I $D(XBRLO),$D(XBRHI),XBRLO=+XBRLO,XBRHI=+XBRHI,XBRHI>XBRLO,XBRLO'<2 G RESID + W !!,"XBRLO and/or XBRHI missing or invalid!" + G EOJ + ; +RESID ; + W !!,"Now checking for residual ^DD entries within range.",! +LOOP ; + KILL ^TMP("XBRESID",$J) + S XBRFILE=(XBRLO-.00000001) + F XBRL=0:0 S XBRFILE=$O(^DD(XBRFILE)) Q:XBRFILE>XBRHI!(XBRFILE'=+XBRFILE) D CHK + S XBRFILE=0 + F XBRL=0:0 S XBRFILE=$O(^TMP("XBRESID",$J,XBRFILE)) Q:XBRFILE="" I ^(XBRFILE),$D(^TMP("XBRESID",$J,^TMP("XBRESID",$J,XBRFILE)))!($D(^DIC(^TMP("XBRESID",$J,XBRFILE)))) S ^TMP("XBRESID",$J,XBRFILE)="I" + S (XBRFILE,XBRY)=0 + F XBRL=0:0 S XBRFILE=$O(^TMP("XBRESID",$J,XBRFILE)) Q:XBRFILE="" I ^TMP("XBRESID",$J,XBRFILE)'="I" S XBRY=1 W !,XBRFILE KILL ^DD(XBRFILE) + G:XBRY LOOP + G EOJ + ; +CHK ; + W "." + Q:$D(^DIC(XBRFILE)) + I $D(^DD(XBRFILE,0,"UP")),^("UP")]"",(^("UP")XBRHI)) Q + S ^TMP("XBRESID",$J,XBRFILE)=$G(^DD(XBRFILE,0,"UP")) + Q + ; +EOJ ; + D ^XBKTMP + KILL XBRFILE,XBRHI,XBRL,XBRLO,XBRY + Q + ; diff --git a/XBRESTL1.m b/XBRESTL1.m new file mode 100644 index 0000000..eb3ceec --- /dev/null +++ b/XBRESTL1.m @@ -0,0 +1,35 @@ +XBRESTL1 ; acc/ohprd - routine to restore 1st line of routines from save file ; + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + W !!,"-- ROUTINE TO RESTORE 1ST LINE OF ROUTINES FROM %RS FILE --",! + W "CAUTION: THIS ROUTINE KILLS ALL VARIABLES, IS NOT NAMESPACED.",! + R "ABORT HERE (^ OR CTL-C) OR PRESS RETURN TO CONTINUE: ",%:$S($D(DTIME):DTIME,1:999),! I %="^" W "-- aborted.",! G OUT + W ! + K +GETFN R "Name of %RS-format save file: ",FN:$S($D(DTIME):DTIME,1:999),! G:"^"[FN EXIT + I FN["?" W "(Enter the name of a unix file containing routines which was produced by %RS)",! G GETFN + D GETHFS E W "-- couldn't get HFS device!",! G EXIT + U DEV + R L1,L2 + U 0 + W "Header lines from %RS file:",!,?2,L1,!,?2,L2,! + R "OK to proceed: N// ",%:$S($D(DTIME):DTIME,1:999),! S %=$E(%_"N") I "Yy"'[% W "-- aborted.",! G OUT + F NR=1:1 D GETR Q:RN="" W:NR=1 "Routines repaired:",! W ?2,$J(NR,3),": ",RL1,! D FIXL1 + C DEV +EXIT W "Bye.",! +OUT K + Q +GETHFS ; + F DEV=51:1:54 O DEV:(FN:"R"):1 Q:$T + E S DEV=0 + Q +GETR ; + U DEV + R RN Q:RN="" + R RL1 + F R RL Q:RL="" + U 0 + Q +FIXL1 ; + X "ZL @RN ZR +1 ZI RL1 ZS @RN" + Q diff --git a/XBRLL.m b/XBRLL.m new file mode 100644 index 0000000..6341f5a --- /dev/null +++ b/XBRLL.m @@ -0,0 +1,27 @@ +XBRLL ; IHS/ADC/GTH - LIST ROUTINE LINES WITH LENGTHS ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; This routine lists a single routine line by line noting + ; the length of the line plus the cumulative character count. + ; +START ; + NEW DIF,X,XCNP + S X=$$DIR^XBDIR("FO^1:8","Enter routine name") + Q:$D(DIRUT) + X ^%ZOSF("TEST") + Q:'$T + KILL ^TMP("XBRLL",$J) + S DIF="^TMP(""XBRLL"",$J,",XCNP=0 + X ^%ZOSF("LOAD") + D ^%ZIS + Q:POP + U IO + W !!,"....[LINE NUMBER/LENGTH OF THIS LINE/CUMULATIVE NUMBER OF CHARACTERS]",!! + S (%2,%1)=0 + F %I=1:1 S %X=$G(^TMP("XBRLL",$J,%I,0)) Q:%X="" W ! S %Y=$P(%X," "),%Z=$E(%X,$L(%Y)+2,255),%2=%2+$L(%X)+2,%1=$S(%Y="":%1+1,1:0) S:%1>0 %Y=" +"_%1 S %Y=%Y_$J("",8-$L(%Y)) W %Y," ",%Z," [+",%I,"/",$L(%X),"/",%2,"]" + KILL %1,%2,%N,%X,%Y,%Z,%I + W !! + KILL DIRUT,DTOUT,DUOUT,I,Y + D ^%ZISC + Q + ; diff --git a/XBRPRTBD.m b/XBRPRTBD.m new file mode 100644 index 0000000..6af6147 --- /dev/null +++ b/XBRPRTBD.m @@ -0,0 +1,8 @@ +XBRPRTBD ; IHS/ADC/GTH - ROUTINE PRINT ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; This functionality has been moved to ZIBRPTRD because + ; of the use of non-standard $Z special variables. + ; The below GO is provided for backwards compatibility. + G ^ZIBRPRTD + ; diff --git a/XBRPTL.m b/XBRPTL.m new file mode 100644 index 0000000..7c5ef2b --- /dev/null +++ b/XBRPTL.m @@ -0,0 +1,52 @@ +XBRPTL ; IHS/ADC/GTH - PRINT ROUTINE TO FIRST LABEL ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods. + ; + ; This routine prints selected routines down to the first + ; label. + ; +START ; + KILL ^UTILITY($J) + X ^%ZOSF("RSEL") + D ^%ZIS +PRINT ; + KILL ^TMP("XBRPTL",$J) + NEW %,I,L,R,X,Y + U IO + W @IOF + ;S XBRPTLQ=0,R="";IHS/SET/GTH XB*3*9 10/29/2002 + S XBRPTLQ=0,R=0 ;IHS/SET/GTH XB*3*9 10/29/2002 + F L=0:0 KILL XBRPTL Q:XBRPTLQ S R=$O(^UTILITY($J,R)) Q:R="" D + . S DIF="^TMP(""XBRPTL"",$J,",XCNP=0,X=R + . X ^%ZOSF("LOAD") + . S XBRPTL(1)=^TMP("XBRPTL",$J,1,0) + . F I=2:1 S Y=$G(^TMP("XBRPTL",$J,I,0)) Q:(Y="")!($E(Y,1,2)'=" ;") S XBRPTL(I)=Y + . S I=I-1 + . D TOP + . W !!! + . I $D(XBRPTL) F %=1:1:I W XBRPTL(%),! I IO=IO(0)&($E(IOST,1,2)="C-")&($Y>(IOSL-4)) D PAGE S:$D(DUOUT) %=I,XBRPTLQ=1 + .Q + ; + KILL DTOUT,DUOUT,XBRPTLQ + KILL ^UTILITY($J) + I IO'=IO(0)!($E(IOST,1,2)="P-") W @IOF D:'$D(XBRPTLE) ^%ZISC + KILL DIF,XBRPTLE,XCNP + KILL ^TMP("XBRPTL",$J) + Q + ; +TOP ; + I IO'=IO(0)!($E(IOST,1,2)="P-") W:$Y+I+3>IOSL @IOF + Q + ; +PAGE ; + NEW %,I,X + S Y=$$DIR^XBDIR("E") + W:'$D(DUOUT) @IOF + Q + ; +EN ;PEP - Print routines down to first label. + S XBRPTLE=1 + D PRINT + KILL XBRPTLE + Q + ; diff --git a/XBRSBD.m b/XBRSBD.m new file mode 100644 index 0000000..07fafb3 --- /dev/null +++ b/XBRSBD.m @@ -0,0 +1,86 @@ +XBRSBD ;IHS-OIRM-DSD/THL;ADAPTATION OF %RS TO SELECT ROUTINES EDITED AFTER SPECIFIED DATE; + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; This routine saves selected routines edited after a given date + ; +START ; + S $ZT="ERR^%RS",%SEQ=1 K %SBP + W !?10,$P($P($ZV,","),"-")," - Routine Save Utility" + O 63::0 E U 0 W !,"Waiting for device 63" O 63 +SDEV D OUT^%SDEV I $D(QUIT) C 63 K %SEQ Q + S QUIT=0,%SBP=%DEV>58&(%DEV<63),%TAP=%DEV>46&(%DEV<51) + S %TAPV=$S('%TAP:0,1:$ZB(%DEVMODE,"_",1)["V") G:'%TAP SIZE + ;U %DEV I @(%MTON_"=0") U 0 W *7,!,"Tape is not ready" C %DEV G SDEV + ;I @%MTWLK U 0 W *7,!,"Tape is write protected" C %DEV G SDEV + U 0 G RCMT +SIZE I %SBP S %SIZE=1024*#10000 G RCMT + R !,"Enter size of save medium (if applicable): ",%SIZE:$S($D(DTIME):DTIME,1:999) S:%SIZE="" %SIZE=1024*#10000 G SDEV:"^"=%SIZE,EXIT:%SIZE="^Q"!(%SIZE="^q") + I %SIZE?1N.N1A S %SIZE=$P(%SIZE,"K"),%SIZE=$P(%SIZE,"k") + I %SIZE?1N.N,%SIZE>0 S %SIZE=%SIZE*1024 G RCMT + I %SIZE'?1"?".E W " ??" G SIZE + W !!,"If using removeable disks or tape for save, enter the number of 1k blocks which",!,"each disk will hold. As each disk becomes full, you will be asked to",!,"replace it with an empty one." + W !!,"If not using removeable media, press ",! G SIZE + ; +RCMT R !,"Enter comment for dump header : ",%CMT:$S($D(DTIME):DTIME,1:999) G SDEV:%CMT="^",CNT1:%CMT'="?" + W !,"The comment will be displayed with the date and time before the routines",!,"are restored." G RCMT +CNT1 K QUIT D INT^%RSEL I $D(QUIT) W !,"No routines selected" G EXIT + S XBTYPE="SAVE" D ^XBDATE ;ADDED TO SPECIFY A DATE AND SCREEN OUT ROUTINES EDITED SINCE SPECIFIED DATE + I $D(QUIT) W !,"No routines will be saved." H 2 G EXIT + D:%TAP %SET^%MTCHK + S QUIT=0,%NEXT="D NEXTVOL^%RS Q:QUIT ZL @%RN" + I '%TAP S %ZPRINT="ZR S %S=$S ZL @%RN X:%S-$S>(%SIZE-$ZB-10) %NEXT Q:QUIT U %DEV W %RN,! S:'%SBP&$ZC!($ZA<0&%SBP) QUIT=2 Q:QUIT F %X=1:1 S %J=$T(+%X) W %J,! Q:%J=""""" + E I '%TAPV S %ZPRINT="ZL @%RN U %DEV W %RN,! S:$ZC QUIT=2 Q:QUIT P" + E S %ZPRINT="ZL @%RN U %DEV W %RN S:$ZC QUIT=2 Q:QUIT F %X=1:1 S %J=$T(+%X) W %J Q:%J=""""" + D INT^%T,INT^%D + W !!,"Saving ...",! + U %DEV W:'%DEV ! W %TIM1_" "_%DAT1 W:'%TAPV ! W %CMT W:'%TAPV ! + S %RN="" + F %I=1:1 S %RN=$O(^UTILITY($J,%RN)) Q:%RN=""!QUIT U 0 W ?%I-1#8*10,%RN W:(%I#8)=0 ! U %DEV D PCODE Q:QUIT I PCODE X %ZPRINT Q:QUIT I %TAP,@%MTEOT D NEXTTAPE Q:QUIT + I QUIT=2 U 0 W !!,"End of file reached, last portion of save may be corrupted! Terminating save." + E U %DEV W:'%TAPV !! W:%TAPV "","" + U 0 W !!,"Done. " +QUIT I '$D(%SBP) K %SEQ Q + I %SBP,QUIT<2 U %DEV S %BN=$ZA U 0 W "Last block used was ",%BN,"." +EXIT C 63 U 0 I $D(%DEV),%DEV'=$I,+%DEV C %DEV I $G(%DEVTYPE)="HFS",$ZA=-1 W !!,"Cannot write end of file. Last part of save may be corrupted." + I $D(%TAP) D:%TAP %KILL^%MTCHK + K %DEV,%RN,%BN,%I,%J,%CMT,%TIM,%TIM1,%DAT,%DAT1,%NEXT,%SEQ,%FN,%S,%SIZE,%SBP,%TAP,%X,%ZA,%ZPRINT,QUIT,%TAPV + K XBDAT,RTN + Q +PCODE ; Test for pcode only routine + I %DEV<47!(%DEV>62) S PCODE=1 Q + S PCODE=$ZBN(^ (%RN)) I PCODE=0 U 0 W !,%RN," does not exist" Q + V PCODE I $V(17,0,1)=0 S PCODE=1 Q ; not a pcode routine + G:%TAP PC10 + S %S=1056 F %K=0:0 S %K=$V(1012,0,4) Q:%K=0 V %K S %S=%S+1024 ;1056=1024+32, 32 byte cushion left for rtn name, etc. + I %S>(%SIZE-$ZB) X %NEXT Q:QUIT +PC10 V PCODE U %DEV W %RN_":"_$V(17,0,1) W:'%TAPV ! I $ZC S QUIT=2 Q + U:%DEV>58&(%DEV<63) %DEV:(::::"V") + F PCODE=PCODE:0 W $V(0,0,1024,1) S PCODE=$V(1012,0,4) Q:PCODE=0 V PCODE ;I %TAP,@%MTEOT D NEXTTAPE U %DEV Q:QUIT + I $ZC S QUIT=2 + U:%DEV>58&(%DEV<63) %DEV:(::::"S") Q +ERR I $F($ZE,"") U 0 W !!,"...Aborted." D EXIT V 0:$J:$ZB($V(0,$J,2),#0400,7):2 + ZQ +NEXTVOL ; + S %SEQ=%SEQ+1 U %DEV W "*EOF*",! C %DEV + U 0 W !,"Sequence #",%SEQ-1," is full, if using removeable media, please put in the next one" +NEXTVOL1 ; + R !,"Enter 'GO' to proceed: ",%X:$S($D(DTIME):DTIME,1:999) W ! + I %X="?" W !!,"Remove sequence #",%SEQ-1,", and put the next disk or tape into the drive. If you are",!,"not using removeable media, you should abort this save by typing 'control C';",!,"your save will still be good up to this point." G NEXTVOL1 + I %X'="GO" W " ??" G NEXTVOL1 + O %DEV:(%FN:"W") U %DEV I $ZA U 0 W !,"Cannot access ",%FN," please correct" G NEXTVOL1 + W "DISK#",%SEQ,! S %X=$ZC + U 0 I %X W !,"Cannot write to ",%FN," please correct" G NEXTVOL1 + S QUIT=0 Q +NEXTTAPE ; + U 0 W !,"Tape sequence number ",%SEQ," is full. Last routine was ",%RN,"." + W !,"After this tape rewinds, mount the next tape.",! + S %SEQ=%SEQ+1 U %DEV W "*EOF*" W:'%TAPV ! W *9 +NT0 U %DEV W *16 U 0 +NT1 W !,"Enter 'GO' when tape sequence number ",%SEQ R " is ready: ",%X:$S($D(DTIME):DTIME,1:999) + I %X="?" W !,"Mount the next tape (sequence number ",%SEQ,") and enter 'GO' when it is ready.",!,"Or enter '^' to abort the save.",! G NT1 + I %X["^" S QUIT=1 Q + I %X'="GO",%X'="go" W *7," ??" G NT1 + U %DEV W *10 I @(%MTON_"=0") U 0 W *7,!,"Tape is not ready" G NT1 + I @%MTWLK U 0 W *7,!,"Tape is write protected" G NT0 + W %TIM1_" "_%DAT1_" (sequence "_%SEQ_")" W:'%TAPV ! W %CMT W:'%TAPV ! + U 0 W !!,"Saving ...",! S QUIT=0 Q diff --git a/XBRSELM.m b/XBRSELM.m new file mode 100644 index 0000000..f23b469 --- /dev/null +++ b/XBRSELM.m @@ -0,0 +1,86 @@ +%RSEL ;DJM;ROUTINE SELECTOR; + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;COPYRIGHT MICRONETICS DESIGN CORP. @1985 + ;IHS/THL MODIFIED TO ALLOW ROUTINE SELECTION BY DATE LAST EDITED + S $ZT="ERROR^%RSEL" +INT ; + N %P,%RN,%RS,%RSN,FIRST,LAST,X S %RSN=0 +L0 ; + R !!,"Routine selector: ",%RS:$S($D(DTIME):DTIME,1:999) + I %RS="."!(%RS=" "),%RSN=0 D LIST S %RSN=1 G L0 + I %RS="^L"!(%RS="^l") D:%RSN LIST G L0 + I %RS="^"!(%RS="^Q")!(%RS="^q") K ^UTILITY($J) G EXIT + I %RS="" K:%RSN=0 ^UTILITY($J) G EXIT + I %RS="^D"!(%RS="^d") D DISPLAY G L0 + I %RS="?" D HELP G L0 +L1 ; + I %RSN=0 K ^UTILITY($J) S %RSN=1 + G:$E(%RS)="-" DEL + S %P=$$%SRCHPAT^%SRCHPAT(%RS) + I $D(FIRST)=0 W *7," ...Invalid routine name selection criteria, Specify '?' for help" G L0 + S %RN=0,X=FIRST D:FIRST'="" + .Q:$D(^ (X))=0 Q:X]LAST X %P S:$T %RN=%RN+1,^UTILITY($J,FIRST)="" + F S X=$O(^ (X)) Q:X=""!(X]LAST) X %P S:$T %RN=%RN+1,^UTILITY($J,X)="" + W !!,?10,%RN," routine",$S(%RN=1:"",1:"s")," selected." W:%RN=0 *7 + G L0 +DEL ; + S %P=$$%SRCHPAT^%SRCHPAT($E(%RS,2,$L(%RS))),%RN=0 + I $D(FIRST)=0 W *7," ...Invalid routine name selection criteria, Specify '?' for help" G L0 + S %RN=0,X=FIRST D:FIRST'="" + .Q:$D(^UTILITY($J,X))=0 Q:X]LAST X %P I $T S %RN=%RN+1 K ^UTILITY($J,X) + F S X=$O(^UTILITY($J,X)) Q:X=""!(X]LAST) X %P I $T S %RN=%RN+1 K ^UTILITY($J,X) + W !!,?10,%RN," routine",$S(%RN=1:"",1:"s")," de-selected." W:%RN=0 *7 + G L0 +DOTS W $E("..............................",1,24-$X) Q +EXIT ; +IHS1 I $D(^UTILITY($J)) D DATE I $D(XB) X XB W !!?10,%RN," routines edited after ",XBDAT D OUT ;IHS/THL ALLOWS SELECTION OF ROUTINES BY DATE LAST EDITED + S:'$D(^UTILITY($J)) QUIT="" Q +LIST ; + I $D(^UTILITY($J))<10 W !,"No routines selected" Q + W !! S %RN=0,%RS=-1 F X=1:1 S %RS=$N(^UTILITY($J,%RS)) Q:%RS<0 W:'(X-1#8) ! W ?(X-1)#8*10,%RS S %RN=%RN+1 + W !!,?10,%RN," routine",$S(%RN=1:"",1:"s")," selected so far.",! + Q +DISPLAY ; + W !! S %RN=0,%RS="" F X=1:1 S %RS=$O(^ (%RS)) Q:%RS="" W:'(X-1#8) ! W ?(X-1)#8*10,%RS S %RN=%RN+1 + W !!,?10,%RN," routine",$S(%RN=1:"",1:"s"),"." + Q +ERROR ; + I $F($ZE,"") U 0 W !!,"...Aborted." D EXIT V 0:$J:$ZB($V(0,$J,2),#0400,7):2 + ZQ +HELP ; + W !,"Respond with routine selection criteria.",!,"Valid responses:" + W !?5,"Routine name" D DOTS W "Eg: ABC" + W !?5,"Routine range" D DOTS W "Eg: AAA-HZZZ" + W !?5,"Routine pattern" D DOTS W "Eg: PROG? PRG*AA A*C?D *XYZ ?" + W !?24,"Where '?' matches any single character," + W !?24,"and '*' matches zero or more characters" + W !?5,"All routines" D DOTS W " * (selects ALL routines)" + W !,"Precede any of the above with a '-' to unselect previously selected routines." + W:%RSN=0 !,"Enter '.' or ' ' to retain previously selected range(s)." + W !,"Enter '^L' for display of previously selected routines." + W !,"Enter '^D' to display all routine names." + W !,"Enter '^' or '^Q' to exit." + Q +DATE ;IHS/THL ALLOWS SELECTION OF ROUTINES BY DATE LAST EDITED + R !!,"Screen ROUTINES by date last edited? NO// ",X:300 Q:'$T + I "^N"[$E(X)!(X="") W !!,"No date selected." Q + I "^Y?N"'[$E(X)!("?"[$E(X)) W !!,"Type 'Y'es to select ROUTINES edited on or after a specified date.",!,"Type '^' or strike to continue without selecting by date." G DATE + I X'="" D Q + .S %DN=$H + .D ^%DO + .S %DT("B")=%DS,%DT="AEQ",%DT("A")="ROUTINES last edited on or after: " + .W ! D ^%DT + .I Y<1 D OUT Q + .S XBX=$T(XBX),XBX=$P(XBX,";;",2) + .X XBX + .S (XBDAT,%DS)=Y D ^%DI + .D:%DN&'$D(%ER) + ..S DN1=%DN + ..S XB=$T(XB),XB=$P(XB,";;",2) + ..S XB1=$T(XB1),XB1=$P(XB1,";;",2) + .D:$D(%ER) OUT + Q +XB ;;S %RN=0,(RTN,%DN)="" F S RTN=$O(^UTILITY($J,RTN)) Q:RTN="" ZL @RTN X XB1 D:%DS?1.2N1"/"1.2N1"/"2N ^%DI K:$D(%ER)!'%DN!(%DN<(DN1)) ^UTILITY($J,RTN) K %ER I %DN>(DN1-1) D ^%DO W !,RTN,?10,"last edited on ",%DS S %RN=%RN+1 +XB1 ;;S X=$T(@RTN),X=$P($P(X,";",2,99)," ",2,99) F I=1:1:$L(X," ") S %DS=$P(X," ",I) Q:%DS?1.2N1"/"1.2N1"/"2N +XBX ;;S:Y Y=$S($E(Y,4,5):$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$E(Y,4,5))_" ",1:"")_$S($E(Y,6,7):+$E(Y,6,7)_",",1:"")_($E(Y,1,3)+1700) +OUT K %DT,XB,XB1,%RN,XBX,DN1,RTN,X,Y,%DA,%DN,%DS,I,XBDAT Q diff --git a/XBRSIZ.m b/XBRSIZ.m new file mode 100644 index 0000000..daf805f --- /dev/null +++ b/XBRSIZ.m @@ -0,0 +1,31 @@ +XBRSIZ ; IHS/ADC/GTH - List routine names and sizes w/overall total. ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; List routine names, sizes, and total bytes. + ; +START ; + W !!,"XBRSIZ - List routine names, sizes, and total bytes.",! + X ^%ZOSF("RSEL") + G EXIT:$O(^UTILITY($J,""))="" + D ^%ZIS + G EXIT:POP + KILL ^TMP("XBRSIZ",$J) + S (A,%R)=0 + X "F I=1:1 S A=$O(^UTILITY($J,A)),T=0 Q:'$L(A) ZL @A S %R=%R+1 F J=1:1 S ^TMP(""XBRSIZ"",$J,""CRF"",I,J)=$T(+J),T=T+$L($T(+J))+2 I $T(+J+1)="""" S ^TMP(""XBRSIZ"",$J,""CRF1"",I,0)=A_""^""_T Q" + KILL %R,A,I,J +PRT ; + U IO + W @IOF + W !!?10,"XBRSIZ - LIST ROUTINE SIZES of " + X ^%ZOSF("UCI") + W Y,", ",$$HTE^XLFDT($H),!!?24,"ROUTINE",?36,"SIZE",! + S SIZT=0 + F %I=1:1 Q:'$D(^TMP("XBRSIZ",$J,"CRF1",%I,0)) S Y=^(0) W !?24,$P(Y,"^"),?34,$J($P(Y,"^",2),6) S SIZT=SIZT+$P(Y,"^",2) + W !!?24,"TOTAL",?34,$J(SIZT,6) + W !!?24,%I-1," ROUTINE" W:%I-1>1 "S" + KILL %I,J,N,S,SIZT,T,V,W,X,Y,Z +EXIT ; + KILL ^TMP("XBRSIZ",$J),I,X + D ^%ZISC + Q + ; diff --git a/XBRSRCH.m b/XBRSRCH.m new file mode 100644 index 0000000..0132d9f --- /dev/null +++ b/XBRSRCH.m @@ -0,0 +1,52 @@ +XBRSRCH ; IHS/ADC/GTH - SEARCH DD FOR CALLED ROUTINES ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; This routine searches a dictionary for called routines, + ; excluding %DT*, DIC, DIK, and DIQ. + ; +START ; + W !,"This routine searches dictionaries for called routines, excluding %DT*, DIC,",!," DIK, and DIQ.",! + S U="^" + R !,"[D]etail or [L]ist only: L//",X:$G(DTIME,999) + S:X'="D" XBRSRCH("NO DETAIL")=1 + ; could be a little friendlier + W ! + D ^XBDSET + Q:'$D(^UTILITY("XBDSET",$J)) + S XBRSRCH("QFLG")=0,XBRSRCH("FILE")=0 + F XBRSRCH("L")=0:0 S XBRSRCH("FILE")=$O(^UTILITY("XBDSET",$J,XBRSRCH("FILE"))) Q:XBRSRCH("FILE")="" D CHECK Q:XBRSRCH("QFLG") + KILL XBRSRCH,^UTILITY("XBDSET",$J) + Q + ; +CHECK ; CHECK FILES UNTIL ALL DONE + W !!,"Searching ",$P(^DIC(XBRSRCH("FILE"),0),"^",1)," file (",XBRSRCH("FILE"),")" + KILL ^UTILITY("XBRSRCH",$J) + W !!,"INPUT TRANSFORMS",! + S XBSINP("FILE")=XBRSRCH("FILE") + D EN^XBRSRCH2 + W !!,"OUTPUT TRANSFORMS",! + S XBSOUT("FILE")=XBRSRCH("FILE") + D EN^XBRSRCH3 + W !!,"CROSS-REFERENCES",! + S XBSXREF("FILE")=XBRSRCH("FILE") + D EN^XBRSRCH4 + W !!,"MISCELLANEOUS ^DD ENTRIES",! + S XBSM("FILE")=XBRSRCH("FILE") + D EN^XBRSRCH5 + W ! + D LIST + D EOJ + Q + ; +LIST ; LIST ROUTINE NAMES + Q:'$D(^UTILITY("XBRSRCH",$J)) + W !!,"Sorted list of routines found:",! + S X="" + F XBRSRCH("L")=0:0 S X=$O(^UTILITY("XBRSRCH",$J,X)) Q:X="" W !,"^",X + W ! + Q + ; +EOJ ; + KILL ^UTILITY("XBRSRCH",$J),X,Y,DIC + Q + ; diff --git a/XBRSRCH1.m b/XBRSRCH1.m new file mode 100644 index 0000000..50e5400 --- /dev/null +++ b/XBRSRCH1.m @@ -0,0 +1,23 @@ +XBRSRCH1 ; IHS/ADC/GTH - COMMON CHECK LOGIC ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; Part of XBRSRCH + ; +CHECK ; EXCLUDE ^%DT,^DIC,^DIK,^DIQ, AND GLOBALS + Q:Y="" + Q:$E(Y)="""" + Q:$E(Y,1,3)="%DT" + Q:$E(Y,1,3)="DIC" + Q:$E(Y,1,3)="DIK" + Q:$E(Y,1,3)="DIQ" + S X0=$F(Y,")"),X1=$F(Y,"("),X2=$F(Y," ") + S:'X0 X0=999 + S:'X1 X1=999 + S:'X2 X2=888 + Q:X0" + S (DA,DCNT)=0 + D CNT^DIK1 + Q + ; +EOJ ; EOJ HOUSEKEEPING + I 'XBRXREF("QFLG") D NOW^%DTC S Y=% X ^DD("DD") W !!,"Finished run at ",$P(Y,"@",2) + KILL XBRXREF,%,%H,%I,DA,DCNT,DIC,DIK,X,Y,^TMP("XBRXREF",$J),^UTILITY("DIK",$J) + Q + ; diff --git a/XBRXREF2.m b/XBRXREF2.m new file mode 100644 index 0000000..297020e --- /dev/null +++ b/XBRXREF2.m @@ -0,0 +1,111 @@ +XBRXREF2 ; IHS/ADC/GTH - INITIALIZATION ROUTINES FOR DRIVER ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; Part of XBRXREF + ; +START ; + W !!,"Invalid entry point!",! + S XBRXREF("QFLG")=99 + Q + ; +INIT ;EP - INITIALIZATION + S U="^" + W !!,"RE-INDEX selected cross-references.",! + S XBRXREF("QFLG")=0 + KILL ^TMP("XBRXREF",$J) + Q + ; +GETFILE ;EP - GET FILE TO BE RE-XREFED + S DIC="^DIC(",DIC(0)="AEMQ" + D ^DIC + KILL DIC + I Y<0 S XBRXREF("QFLG")=1 Q + S XBRXREF("FILE")=+Y + S XBRXREF("GBL")=^DIC(XBRXREF("FILE"),0,"GL") + Q + ; +BLDXRT ;EP - BUILD XREF TABLE + F XBRXREF("L")=0:0 D GETFIELD Q:XBRXREF("FIELD")="" + S:'$O(^TMP("XBRXREF",$J,"")) XBRXREF("QFLG")=1 + Q + ; +GETFIELD ; GET FIELD TO XREF + W ! + S XBRXREF("FIELD")="" + S DIC="^DD("_XBRXREF("FILE")_",",DIC(0)="AEMQ" + D ^DIC + KILL DIC + Q:Y<0 + S XBRXREF("FIELD")=+Y + S X=$P(^DD(XBRXREF("FILE"),XBRXREF("FIELD"),0),U,4) + S XBRXREF("NODE")=$P(X,";",1) + S XBRXREF("PIECE")=$P(X,";",2) + I XBRXREF("PIECE")=0 D GFRCR Q + I XBRXREF("NODE")=" " W !!,"Computed fields do not have xrefs." Q + I $D(^DD(XBRXREF("FILE"),XBRXREF("FIELD"),1)),$O(^(1,0)) D XREFS Q + W !!,"This field has no xrefs!" + Q + ; +GFRCR ; GET FIELD RECURSION + S XBRXREF("SAVE FILE")=XBRXREF("FILE"),XBRXREF("SAVE FIELD")=XBRXREF("FIELD") + F Y="XBRXREF" S %RCR(Y)="" + S XBRXREF("FILE")=+$P(^DD(XBRXREF("FILE"),XBRXREF("FIELD"),0),U,2) + S %RCR="RECURSE^XBRXREF2" + D STORLIST^%RCR + S XBRXREF("FILE")=XBRXREF("SAVE FILE"),XBRXREF("FIELD")=XBRXREF("SAVE FIELD") + Q + ; +RECURSE ; + F XBRXREF("L")=0:0 D GETFIELD Q:XBRXREF("FIELD")="" + Q + ; +XREFS ; DISPLAY XREFS FOR FIELD + W !,"This field has the following xrefs. Select by number:" + S XBRXREF("XREF")=0 + F XBRXREF("L")=0:0 S XBRXREF("XREF")=$O(^DD(XBRXREF("FILE"),XBRXREF("FIELD"),1,XBRXREF("XREF"))) Q:XBRXREF("XREF")="" D XREFS2 + F XBRXREF("L")=0:0 D GETXREF Q:XBRXREF("XREF")="" + Q + ; +XREFS2 ; DISPLAY XREFS + S X=$P(^DD(XBRXREF("FILE"),XBRXREF("FIELD"),1,XBRXREF("XREF"),0),U,2) + S Y="" + S:X="" Y="TRIGGER" + I Y="",'$F(^DD(XBRXREF("FILE"),XBRXREF("FIELD"),1,XBRXREF("XREF"),1),"("""_X_"""") S Y="SUB-FILE LEVEL" + W !,XBRXREF("XREF"),?10,X,?20,Y + Q + ; +GETXREF ; GET XREFS FROM FIELD + W ! + S XBRXREF("XREF")="" + S DIC="^DD("_XBRXREF("FILE")_","_XBRXREF("FIELD")_",1,",DIC(0)="AEMQ" + D ^DIC + Q:Y<0 + S XBRXREF("XREF")=+Y + D INFOSAVE + Q + ; +INFOSAVE ; GET XREF/NODE/PIECE INFO AND SAVE + S X=$P(^DD(XBRXREF("FILE"),XBRXREF("FIELD"),1,XBRXREF("XREF"),0),U,2) + I X="" W !!,*7,"Sorry, I don't do TRIGGERS!" Q + I '$F(^DD(XBRXREF("FILE"),XBRXREF("FIELD"),1,XBRXREF("XREF"),1),"("""_X_"""") W !!,*7,"Sorry, I only do xrefs at the file level!" Q + S ^TMP("XBRXREF",$J,XBRXREF("FILE"),XBRXREF("FIELD"),XBRXREF("XREF"))=X + Q + ; +CONFIRM ;EP - GET USER CONFIRMATION + W !!,"The ",$P(^DIC(XBRXREF("FILE"),0),U,1)," file contains ",$P(@(XBRXREF("GBL")_"0)"),U,4)," entries. The following xrefs will be",!,"killed and reset by the specified file or sub-file, and field:",! + S XBRXREF("FILE")="" + F XBRXREF("L")=0:0 S XBRXREF("FILE")=$O(^TMP("XBRXREF",$J,XBRXREF("FILE"))) Q:XBRXREF("FILE")="" D CONFIRM2 + R !!,"Do you want to continue (Y/N) Y//",X:$G(DTIME,999) + S:"Yy"'[$E(X) XBRXREF("QFLG")=1 + Q + ; +CONFIRM2 ; + S XBRXREF("FIELD")="" + F XBRXREF("L")=0:0 S XBRXREF("FIELD")=$O(^TMP("XBRXREF",$J,XBRXREF("FILE"),XBRXREF("FIELD"))) Q:XBRXREF("FIELD")="" D CONFIRM3 + Q + ; +CONFIRM3 ; + S XBRXREF("XREF")="" + F XBRXREF("L")=0:0 S XBRXREF("XREF")=$O(^TMP("XBRXREF",$J,XBRXREF("FILE"),XBRXREF("FIELD"),XBRXREF("XREF"))) Q:XBRXREF("XREF")="" W !,XBRXREF("FILE"),?15,XBRXREF("FIELD"),?25,^(XBRXREF("XREF")) + Q + ; diff --git a/XBSAN.m b/XBSAN.m new file mode 100644 index 0000000..b34dfbb --- /dev/null +++ b/XBSAN.m @@ -0,0 +1,717 @@ +XBSAN ;IHS/ITSC/LAB/FJE;SANITIZE RPMS DATABASE; [ 01/29/2004 11:10 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + W !,"This routine sanitizes and deletes RPMS data. To use you must type: D START^XBSAN",!! + Q +START ; + S (XBDUZ,XBDEL,XBPAT,XBPHR,XBBH,XBCHR,XBPOS,XB3PB,XBAR,XBLAB,XBMMDEL,XBAUDEL,XBNCDEL)=0 + K ^XTMP("SAN") + S ^XTMP("SAN","LASTDFN")=0 + W !,"This routine will first sanitize AND randomize the NEW PERSON file in the RPMS database." + S DIR(0)="Y",DIR("A")="Do you want to convert the new person data?",DIR("B")="N" KILL DA D ^DIR KILL DIR + S:Y=1 XBDUZ=1 + W !,"This routine will then REMOVE/DELETE UNNEEDED PATIENT DATA in the RPMS database." + S DIR(0)="Y",DIR("A")="Do you want this data deleted?",DIR("B")="N" KILL DA D ^DIR KILL DIR + S:Y=1 XBDEL=1 + W !!,"This routine will then sanitize the PATIENT FILES of a RPMS database." + S DIR(0)="Y",DIR("A")="Do you want to convert the patient data",DIR("B")="N" KILL DA D ^DIR KILL DIR + S:Y=1 XBPAT=1 + W !!,"This routine will then sanitize the POLICY HOLDER FILE of a RPMS database." + S DIR(0)="Y",DIR("A")="Do you want to convert the POLICY HOLDER data?",DIR("B")="N" KILL DA D ^DIR KILL DIR + S:Y=1 XBPHR=1 + W !!,"This routine will then delete SENSITIVE CHR DATA from a RPMS database." + S DIR(0)="Y",DIR("A")="Do you want to delete this CHR patient data?",DIR("B")="N" KILL DA D ^DIR KILL DIR + S:Y=1 XBCHR=1 + W !!,"This routine will then delete SENSITIVE BH VERSION 3.0 COMPLIANT DATA from a RPMS database." + S DIR(0)="Y",DIR("A")="Do you want to delete this CHR patient data?",DIR("B")="N" KILL DA D ^DIR KILL DIR + S:Y=1 XBBH=1 + W !,"This routine will then REMOVE/DELETE UNNEEDED POS DATA in the RPMS database." + S DIR(0)="Y",DIR("A")="Do you want this data deleted?",DIR("B")="N" KILL DA D ^DIR KILL DIR + S:Y=1 XBPOS=1 + W !,"This routine will then REMOVE/DELETE UNNEEDED 3PB DATA in the RPMS database." + S DIR(0)="Y",DIR("A")="Do you want this data deleted?",DIR("B")="N" KILL DA D ^DIR KILL DIR + S:Y=1 XB3PB=1 + W !,"This routine will then REMOVE/DELETE UNNEEDED AR DATA in the RPMS database." + S DIR(0)="Y",DIR("A")="Do you want this data deleted?",DIR("B")="N" KILL DA D ^DIR KILL DIR + S:Y=1 XBAR=1 + W !,"This routine will then REMOVE/DELETE UNNEEDED LAB DATA in the RPMS database." + S DIR(0)="Y",DIR("A")="Do you want this data deleted?",DIR("B")="N" KILL DA D ^DIR KILL DIR + S:Y=1 XBLAB=1 + W !,"This routine will then REMOVE/DELETE MAILMAN MESSAGES in the RPMS database." + S DIR(0)="Y",DIR("A")="Do you want this data deleted?",DIR("B")="N" KILL DA D ^DIR KILL DIR + S:Y=1 XBMMDEL=1 + W !,"This routine will then REMOVE/DELETE AUDIT DATA in the RPMS database." + S DIR(0)="Y",DIR("A")="Do you want this data deleted?",DIR("B")="N" KILL DA D ^DIR KILL DIR + S:Y=1 XBAUDEL=1 + W !,"This routine will then REMOVE/DELETE NAME COMPONENTS in the RPMS database." + S DIR(0)="Y",DIR("A")="Do you want this data deleted?",DIR("B")="N" KILL DA D ^DIR KILL DIR + S:Y=1 XBNCDEL=1 + W !,"All failed fileman update data can be found in: ^XTMP(""SAN"",""FAILURE"", GLOBAL" + W !,"?? display usually means that there was a fileman update failure" + W !,"If a hard error like an UNDEFINED occurs during the Patient scrambling," + W !," you can restart at the next patient by typing: RESTART^XBSAN " + W !,"This routine does not purge HL7, or ARMS data." + W !,"When finished...don't forget to manually address the above and RENAME Institutions",!! + W !!,"This routine is about to scramble the RPMS database." + S DIR(0)="Y",DIR("A")="Last chance: Do you want your RPMS data SANITIZED?",DIR("B")="N" KILL DA D ^DIR KILL DIR + Q:Y'=1 + D ^XBKVAR + W !,"Collecting random names" D CLEAN + I XBDUZ W !,"SCRAMBLING FILE 200" D DUZ + I XBDEL W !,"DELETING PAT INFO" D PATDEL +RESTART ;WILL RESTART PAT SCRAMBLE IF HARD ERROR OCCURS + I $G(^XTMP("SAN","LASTDFN"))>0 S ^XTMP("SAN","FAILURE","PATDFN",^XTMP("SAN","LASTDFN"))="" + I XBPAT W !,"SCRAMBLING PAT FILE" D PAT + I XBPHR W !,"SCRAMBLING POLICY FILE" D PHR + I XBCHR W !,"SCRAMBLING CHR FILE" D CHR + I XBBH W !,"DELETING BH INFO" D BH + I XBPOS W !,"DELETING POS INFO" D POSDEL + I XB3PB W !,"SCRAMBLING 3PB FILE" D TPB + I XBAR W !,"SCRAMBLING AR FILE" D AR + I XBLAB W !,"SCRAMBLING LAB FILES" D LAB + I XBMMDEL W !,"DELETING MAILMAN MESSAGES" D MMDEL + I XBAUDEL W !,"DELETING AUDIT DATA" D AUDEL + I XBNCDEL W !,"DELETING NAME COMPONENTS" D NCDEL + D PAT2 + S ^XTMP("SAN","PROCESS","XBSAN")="FINISHED" + W !,"FINISHED" + D LISTE + D EOJ + Q + ; +PAT D ^XBKVAR + S XBCHART=100000 + S DFN=+$G(^XTMP("SAN","LASTDFN")) I DFN W !,"RESTARTING PATIENT SCRAMBLE AFTER "_DFN,! + F S DFN=$O(^DPT(DFN)) Q:DFN'=+DFN D PROCPAT + S ^XTMP("SAN","PROCESS","PAT")="FINISHED" + Q + ; +PAT2 D ^XBKVAR + S XBCHART=100000 + W !,"RETRYING FAILED PATIENTS",! + S DFN=0 F S DFN=$O(^XTMP("SAN","FAILURE","PATNAME",DFN)) Q:DFN'=+DFN D + .S Y=DFN D ^AUPNPAT + .S XBSCR=$S(AUPNSEX="M":3,1:2) + .D FNAME + .D LNAME + .S XBNAME=XBLNAME_","_XBFNAME + .S DA=DFN,DIE="^DPT(",DR=".01///"_XBNAME D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATNAME2",DFN)="" W !,$P(^DPT(DFN,0),U,1)," ",XBNAME + .D ^XBFMK + S ^XTMP("SAN","PROCESS","PAT")="FINISHED" + Q +CHR ; + S X=0 F S X=$O(^BCHR(X)) Q:X'=+X K ^BCHR(X,51),^BCHR(X,61),^BCHR(X,71) + S ^XTMP("SAN","PROCESS","CHR")="FINISHED" + Q +BH ;version 3.0 compliant only + S X=0 F S X=$O(^AMHREC(X)) Q:X'=+X K ^AMHREC(X,31),^AMHREC(X,81),^AMHREC(X,21) + S X=0 F S X=$O(^AMHPTXP(X)) Q:X'=+X K ^AMHPTXP(X,18) + S ^XTMP("SAN","PROCESS","BH")="FINISHED" + Q +PHR ; + ;policy holders not pointing to a patient + S XBP=0 F S XBP=$O(^AUPN3PPH(XBP)) Q:XBP'=+XBP D + .Q:$P(^AUPN3PPH(XBP,0),U,2) ;already converted + .S XBS=$P(^AUPN3PPH(XBP,0),U,8) I XBS="" S XBS="M" + .S XBSCR=$S(XBS="M":3,1:2) + .D FNAME + .D LNAME + .S XBNAME=XBLNAME_","_XBFNAME + .D PHNR + .S XBPHN="555-777-"_XBPHN + .S DA=XBP,DIE="^AUPN3PPH(",DR=".01///"_XBNAME_";.14///"_XBPHN D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","POLICYPHONE",DFN)="" + .D ^XBFMK + .D SSNR + .S DA=XBP,DIE="^AUPN3PPH(",DR=".04///"_XBSSN D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","POLICYSSN",DFN)="" + .D ^XBFMK + .S X=^XTMP("SAN",$J,"ADL1") D R S XBADDR=^XTMP("SAN",$J,"ADL1",X) + .S $P(^AUPN3PPH(XBP,0),U,9)=XBADDR + .S XBD=$P(^AUPN3PPH(XBP,0),U,19) I XBD]"" S XBD=$$FMADD^XLFDT(XBD,-33) + .S DA=XBP,DIE="^AUPN3PPH(",DR=".19///"_XBD D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","POLICYDOB",DA)="" + .D ^XBFMK + S ^XTMP("SAN","PROCESS","POLICY")="FINISHED" + Q +PROCPAT ; + S ^XTMP("SAN","LASTDFN")=DFN + I '(DFN#5000) W !,"."_DFN_"." + D ^XBFMK + S Y=DFN D ^AUPNPAT + D F201 + D F203 ;subtract 33 days from dob + D F209 + D F2111 + D F2131 + D F2132 + D F2211 + D F2212 + D F2213 + D F2219 + D F22401 + D F22402 + D F22403 + D OTHNAME + D TEN ;tribal enrollment number + D BRTH + D DTH + D PN + D EMPL + D NKR + D ECR + D XBCHART + D INSURE + D POLICY + Q +EOJ ; + D EN^XBVK("XB") + K DFN,XBH,OTDFN,XBB,AUPNSEX,X,X2,XB3PB,XBAR,XBAUDEL + K DA,DIE,DIK,DIR,DR,DUZSSN,I,XBA,XBADDR,XBADL1 + K XBBH,XBC,XBCHART,XBCHR,XBD,XBDAD,XBDEANUM,XBDEL,XBDFIRST,XBDLAST,XBDNAME + K XBDOB,XBDUZ,XBFIRST,XBFNAME,XBH,XBLAB,XBLNAME,XBMDFN,XBMMDEL,XBMOM + K XBNAME,XBNCDEL,XBNOK,XBNOKADL,XBP,XBPAT,XBPHN,XBPHR,XBPOS,XBS + K XBSCR,XBSEX,XBSSN,XBTEN,XBVAL,XBVANUM,XBX,Y,Z + W !,"If all data appears correct and you have chaecked failures, kill the ^XTMP(""SAN"") global",!! + Q +NKR ; + I $P($G(^AUPNPAT(DFN,28)),U,2)]"" S DA=DFN,DIE="^AUPNPAT(",DR="2802///`"_$O(^AUTTRLSH("B","MOTHER",0)) D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","PATNKR",DFN)="" + D ^XBFMK + Q +ECR ; + I $P($G(^AUPNPAT(DFN,31)),U,2)]"" S DA=DFN,DIE="^AUPNPAT(",DR="3102///`"_$O(^AUTTRLSH("B","MOTHER",0)) D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","PATECR",DFN)="" + D ^XBFMK + Q +EMPL ;employer .19 + I $P($G(^AUPNPAT(DFN,0)),U,19)]"" S DA=DFN,DIE="^AUPNPAT(",DR=".19///FIRST AMERICAN BANK" D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","PATEMP",DFN)="" + D ^XBFMK + Q +PN ; + I $P($G(^AUPNPAT(DFN,0)),U,31)]"" S DA=DFN,DIE="^AUPNPAT(",DR=".31///"_$P(^DPT(DFN,0),U) D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","PATPN",DFN)="" + D ^XBFMK + Q +TEN ; + S XBTEN="TN - "_DFN + I $P($G(^AUPNPAT(DFN,0)),U,7)]"" S DA=DFN,DIE="^AUPNPAT(",DR=".07///"_XBTEN D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","PATTEN",DFN)="" + D ^XBFMK + Q +BRTH ; + I $P($G(^AUPNPAT(DFN,11)),U,5)]"" S XBTEN=$E(DFN_"000000",1,7),DA=DFN,DIE="^AUPNPAT(",DR="1105///"_XBTEN D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","PATBIRTH",DFN)="" + D ^XBFMK + Q +DTH ; + I $P($G(^AUPNPAT(DFN,11)),U,16)]"" S XBTEN=$E("D"_DFN_"00000",1,7),DA=DFN,DIE="^AUPNPAT(",DR="1105///"_XBTEN D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","PATDEATH",DFN)="" + D ^XBFMK + Q +F201 ; + S XBSCR=$S(AUPNSEX="M":3,1:2) + D FNAME + D LNAME + S XBNAME=XBLNAME_","_XBFNAME + S DA=DFN,DIE="^DPT(",DR=".01///"_XBNAME D ^DIE + I $D(Y) S ^XTMP("SAN","FAILURE","PATNAME",DFN)="" + D ^XBFMK + Q +FNAME ; + I XBSCR=3 S X=^XTMP("SAN",$J,"FIRSTM") D R S XBFNAME=^XTMP("SAN",$J,"FIRSTM",X) Q + S X=^XTMP("SAN",$J,"FIRSTF") D R S XBFNAME=^XTMP("SAN",$J,"FIRSTF",X) + Q +LNAME ; + S X=^XTMP("SAN",$J,"LAST") D R S XBLNAME=^XTMP("SAN",$J,"LAST",X) + Q +F203 ;dob + S XBDOB=$P(^DPT(DFN,0),U,3) + I XBDOB="" Q + S XBDOB=$$FMADD^XLFDT(XBDOB,-33) + S DIE="^DPT(",DA=DFN,DR=".03///"_XBDOB D ^DIE + I $D(Y) S ^XTMP("SAN","FAILURE","PATDOB",DFN)="" + D ^XBFMK + Q +F2211 ;nok/emergency contact name + S XBSCR=2 D FNAME S XBNOK=XBLNAME_","_XBFNAME + I $P($G(^DPT(DFN,.21)),U,1)]"" D + .D ^XBFMK + .S DIE="^DPT(",DR=".211///"_XBNOK,DA=DFN D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATNOK",DFN)="" + .D ^XBFMK + I $P($G(^DPT(DFN,.33)),U,1)]"" D + .S DIE="^DPT(",DR=".331///"_XBNOK,DA=DFN D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATECN",DFN)="" + .D ^XBFMK + Q +F2212 ; + D ^XBFMK + I $P($G(^DPT(DFN,.21)),U,2)]"" D + .S DA=DFN,DIE="^DPT(",DR=".212///MOTHER" D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATNOKMOTHER",DFN)="" + .D ^XBFMK + I $P($G(^DPT(DFN,.33)),U,2)]"" D + .S DA=DFN,DIE="^DPT(",DR=".332///"_"MOTHER" D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATECNMOTHER",DFN)="" + .D ^XBFMK + Q +F22401 ;father's name + I $P($G(^DPT(DFN,.24)),U,1)="" Q + S XBSCR=3 D FNAME S XBDAD=XBLNAME_","_XBFNAME + S DIE="^DPT(",DR=".2401///"_XBDAD,DA=DFN D ^DIE + I $D(Y) S ^XTMP("SAN","FAILURE","PATFATHER",DFN)="" + D ^XBFMK + Q +F22402 ;mother's name + S XBSCR=2 D FNAME S XBMOM=XBLNAME_","_XBFNAME + I $P($G(^DPT(DFN,.24)),U,2)="" Q + S DIE="^DPT(",DR=".2402///"_XBMOM,DA=DFN D ^DIE + I $D(Y) S ^XTMP("SAN","FAILURE","PATMOTHER",DFN)="" + D ^XBFMK + Q +F22403 ;mother's maiden name + D LNAME + S XBMMN=XBLNAME_","_$P(XBMOM,",",2) + I $P($G(^DPT(DFN,.24)),U,3)="" Q + S DIE="^DPT(",DR=".2403///"_XBMMN,DA=DFN D ^DIE + I $D(Y) S ^XTMP("SAN","FAILURE","PATMOTHMAIDNAM",DFN)="" + D ^XBFMK + Q +OTHNAME ; + S OTDFN=0 F S OTDFN=$O(^DPT(DFN,.01,OTDFN)) Q:OTDFN'=+OTDFN D + .D LNAME + .S XBNAME=XBLNAME_","_XBFNAME + .S DA=OTDFN,DIE="^DPT("_DFN_",.01,",DA(1)=DFN,DR=".01///"_XBNAME D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATOTHRNAME",DFN)="" + .D ^XBFMK + Q +F2111 ; + I $P($G(^DPT(DFN,.11)),U,1)]"" D + .S X=^XTMP("SAN",$J,"ADL1") D R S XBADDR=^XTMP("SAN",$J,"ADL1",X) + .S DIE="^DPT(",DR=".111///"_XBADDR,DA=DFN D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATADDRESS",DFN)="" + .D ^XBFMK + .S $P(^DPT(DFN,.11),U,2)="" ;addr 2nd line + .S $P(^DPT(DFN,.11),U,3)="" ;addr 3rd line + Q +F2213 ; + I $P($G(^DPT(DFN,.21)),U,3)]"" D + .S X=^XTMP("SAN",$J,"ADL1") D R S XBADDR=^XTMP("SAN",$J,"ADL1",X) + .S DIE="^DPT(",DR=".213///"_XBADDR,DA=DFN D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATADDRESSL11",DFN)="" + .D ^XBFMK + I $P($G(^DPT(DFN,.33)),U,3)]"" D + .S X=^XTMP("SAN",$J,"ADL1") D R S XBADDR=^XTMP("SAN",$J,"ADL1",X) + .S DIE="^DPT(",DR=".333.//"_XBADDR,DA=DFN D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATADDRESSL111",DFN)="" + .D ^XBFMK + Q +POLICY ; + ;loop through policy holder + ;if has patient pointer use patient name and address and + D ^XBFMK + S XBP=$O(^AUPN3PPH("C",DFN,0)) + I 'XBP K XBP Q + S XBTEN=$P($G(^DPT(DFN,.11)),U,1) + S DA=XBP,DIE="^AUPN3PPH(",DR=".01///"_XBNAME_";.04///"_XBSSN_";.09///"_XBTEN_";.11///@;.13///@;.14///@;.19///"_XBDOB D ^DIE + I $D(Y) S ^XTMP("SAN","FAILURE","PATPOLICY",DA)="" + D ^XBFMK + Q +INSURE ; + D MCR,PI,MCD,RR + Q +MCR ; + ;MEDICARE + Q:'$D(^AUPNMCR(DFN)) + S X=^XTMP("SAN",$J,"DLAST") D R S XBDLAST=^XTMP("SAN",$J,"DLAST",X) + S X=^XTMP("SAN",$J,"DFIRST") D R S XBDFIRST=^XTMP("SAN",$J,"DFIRST",X) + S XBDLAST=XBDLAST_","_XBDFIRST + D SSNR + S DIE="^AUPNMCR(",DA=DFN,DR=".03///"_XBSSN_";.14///"_XBDLAST_";2101///"_$P(^DPT(DFN,0),U,1)_";2102///"_$P(^DPT(DFN,0),U,3) D ^DIE + I $D(Y) S ^XTMP("SAN","FAILURE","PATMEDICARE",DFN)="" + D ^XBFMK + Q +PI ; + Q:'$D(^AUPNPRVT(DFN)) + Q:'$D(^AUPNPRVT(DFN,11)) + S XBMDFN=0 F S XBMDFN=$O(^AUPNPRVT(DFN,11,XBMDFN)) Q:XBMDFN'=+XBMDFN D + .S $P(^AUPNPRVT(DFN,11,XBMDFN,0),U,2)=XBSSN + .S $P(^AUPNPRVT(DFN,11,XBMDFN,0),U,4)=XBNAME + .S $P(^AUPNPRVT(DFN,11,XBMDFN,0),U,12)="" + .S $P(^AUPNPRVT(DFN,11,XBMDFN,0),U,14)="" + Q + ; +RR ; + Q:'$D(^AUPNRRE(DFN)) + S X=^XTMP("SAN",$J,"DLAST") D R S XBDLAST=^XTMP("SAN",$J,"DLAST",X) + S X=^XTMP("SAN",$J,"DFIRST") D R S XBDFIRST=^XTMP("SAN",$J,"DFIRST",X) + S XBDLAST=XBDLAST_","_XBDFIRST + D SSNR + S DIE="^AUPNRRE(",DA=DFN,DR=".04///"_XBSSN_";.14///"_XBDLAST_";2101///"_$P(^DPT(DFN,0),U,1)_";2102///"_$P(^DPT(DFN,0),U,3) D ^DIE + I $D(Y) S ^XTMP("SAN","FAILURE","PATRAILROAD",DFN)="" + D ^XBFMK + Q +MCD ; + S XBMDFN=0 F S XBMDFN=$O(^AUPNMCD("B",DFN,XBMDFN)) Q:XBMDFN'=+XBMDFN D + .S X=^XTMP("SAN",$J,"DLAST") D R S XBDLAST=^XTMP("SAN",$J,"DLAST",X) + .S X=^XTMP("SAN",$J,"DFIRST") D R S XBDFIRST=^XTMP("SAN",$J,"DFIRST",X) + .S DIE="^AUPNMCD(",DA=XBMDFN,DR=".05///@;.12///@;.13///@" D ^DIE + .D ^XBFMK + .S XBDNAME=XBDLAST_","_XBDFIRST + .D SSNR + .S DIE="^AUPNMCD(",DA=XBMDFN,DR=".03///"_XBSSN_";.14///"_XBDNAME_";2101///"_$P(^DPT(DFN,0),U,1)_";2102///"_$P(^DPT(DFN,0),U,3)_";.05///"_$P(^DPT(DFN,0),U,1) D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATMEDICAID",DA)="" + .D ^XBFMK + Q +XBCHART ; + S XBH=0 F S XBH=$O(^AUPNPAT(DFN,41,XBH)) Q:XBH'=+XBH S XBCHART=XBCHART+1 D + .S DA=XBH,DIE="^AUPNPAT("_DFN_",41,",DA(1)=DFN,DR=".02///"_XBCHART D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATCHART",DFN)="" + .D ^XBFMK + Q +F209 ; + I $P($G(^DPT(DFN,0)),U,9)="" Q + D SSNR + S DIE="^DPT(",DA=DFN,DR=".09///"_XBSSN D ^DIE + I $D(Y) S DA=DFN,DIE="^DPT(",DR=".09///@" D ^DIE + I $D(Y) S ^XTMP("SAN","FAILURE","PATSSN",DFN)="" + D ^XBFMK + Q +F2219 ;nok phone + I $P($G(^DPT(DFN,.21)),U,9)]"" D PHNR D ;S $P(^DPT(DFN,.21),U,9)="555-888-"_XBPHN + .S XBPHN="555-888-"_XBPHN + .S DIE="^DPT(",DA=DFN,DR=".219///"_XBPHN D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATPHONE",DFN)="" + .D ^XBFMK + I $P($G(^DPT(DFN,.33)),U,9)]"" D PHNR D ;S $P(^DPT(DFN,.33),U,9)="555-888-"_XBPHN + .S XBPHN="555-888-"_XBPHN + .S DIE="^DPT(",DA=DFN,DR=".339///"_XBPHN D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATPHONE1",DFN)="" + .D ^XBFMK + Q +F2131 ; + I $P($G(^DPT(DFN,.13)),U,1)]"" D PHNR D + .S XBPHN="555-555-"_XBPHN + .S DIE="^DPT(",DA=DFN,DR=".131///"_XBPHN D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATPHONE2",DFN)="" + .D ^XBFMK + Q +F2132 ; + Q:$P($G(^DPT(DFN,.13)),U,2)="" ;no office phone + D PHNR S XBPHN="555-999-"_XBPHN + S DIE="^DPT(",DA=DFN,DR=".132///"_XBPHN D ^DIE + I $D(Y) S ^XTMP("SAN","FAILURE","PATPHONE3",DFN)="" + D ^XBFMK + Q + ; +DELP ;delete patients with no visits + ;S XBCNT=0,XBP=0 F S XBP=$O(^DPT(XBP)) Q:XBP'=+XBP D + ;.Q:$D(^AUPNVSIT("AC",XBP)) + ;.S DA=XBP,DIK="^DPT(" D ^DIK + ;.S DA=XBP,DIK="^AUPNPAT(" D ^DIK + ;.W DA,":" S XBCNT=XBCNT+1 + ;.Q + ;W !,XBCNT + ;Q +CLEAN ; + K ^XTMP("SAN",$J,"FIRSTM") + K ^XTMP("SAN",$J,"FIRSTF") + K ^XTMP("SAN",$J,"ADL1") + K ^XTMP("SAN",$J,"NOKADL") + K ^XTMP("SAN","FAILURE") + K ^XTMP("SAN",$J,"DLAST") + K ^XTMP("SAN",$J,"DFIRST") + K ^XTMP("SAN","PROCESS","DUZ") + K ^XTMP("SAN","DUZFAILURE") + D ^XBKVAR + S (XBC(1),XBC(2))=0,XBX=1 F S XBX=$O(^VA(200,XBX)) Q:+XBX=0 D + .S XBNAME=$P($G(^VA(200,XBX,0)),U,1) + .S XBLAST=$P(XBNAME,",",1) S:'$L(XBLAST) XBLAST="MOUSE" + .S XBFIRST=$P(XBNAME,",",2) S:'$L(XBFIRST) XBFIRST="MICKEY"_+XBX + .S XBC(1)=XBC(1)+1,^XTMP("SAN",$J,"DLAST")=XBC(1),^XTMP("SAN",$J,"DLAST",XBC(1))=XBLAST + .S XBC(2)=XBC(2)+1,^XTMP("SAN",$J,"DFIRST")=XBC(2),^XTMP("SAN",$J,"DFIRST",XBC(2))=XBFIRST + D ^XBKVAR + F I=1:1:5 S XBC(I)=0 + S Y=0 F S Y=$O(^DPT(Y)) Q:+Y=0 D + .S XBVAL=$G(^DPT(Y,0)) + .S XBNAME=$P(XBVAL,U,1) + .S XBLAST=$P(XBNAME,",",1) + .S XBFIRST=$P(XBNAME,",",2) + .S XBSEX=$P(XBVAL,U,2) + .S XBADL1=$P($G(^DPT(Y,.11)),U,1) + .S XBNOKADL=$P($G(^DPT(Y,.33)),U,3) +SET .S XBC(1)=XBC(1)+1,^XTMP("SAN",$J,"LAST")=XBC(1),^XTMP("SAN",$J,"LAST",XBC(1))=XBLAST + .I $L(XBSEX) S:XBSEX="M" XBC(2)=XBC(2)+1,^XTMP("SAN",$J,"FIRSTM")=XBC(2),^XTMP("SAN",$J,"FIRSTM",XBC(2))=XBFIRST + .I $L(XBSEX) S:XBSEX="F" XBC(3)=XBC(3)+1,^XTMP("SAN",$J,"FIRSTF")=XBC(3),^XTMP("SAN",$J,"FIRSTF",XBC(3))=XBFIRST + .I $L(XBADL1) S XBC(5)=XBC(5)+1,^XTMP("SAN",$J,"ADL1")=XBC(5),^XTMP("SAN",$J,"ADL1",XBC(5))=XBADL1 + .I $L(XBNOKADL) S XBC(5)=XBC(5)+1,^XTMP("SAN",$J,"ADL1")=XBC(5),^XTMP("SAN",$J,"ADL1",XBC(5))=XBNOKADL + Q +R S X2=$R(X) I X2=0 G R + S X=X2 + Q + ; +DUZ ;SCRAMBLES USER NAMES + K ^XTMP("SAN","FAILURE","DUZ") + K ^XTMP("SAN","FAILURE","DUZA") +DUZA D ^XBFMK + S XBX=1 F S XBX=$O(^VA(200,XBX)) Q:+XBX=0 D + .S X=^XTMP("SAN",$J,"DLAST") D R S XBLAST=^XTMP("SAN",$J,"DLAST",X) + .S X=^XTMP("SAN",$J,"DFIRST") D R S XBFIRST=^XTMP("SAN",$J,"DFIRST",X) + .D DUZSSN + .;W !,$P(^VA(200,XBX,0),"^",1)," ",XBLAST," ",XBFIRST,$P($G(^VA(200,XBX,1)),"^",9)," ",DUZSSN + .I DUZSSN S DA=XBX,DIE=200,DR=".01///"_XBLAST_","_XBFIRST_";9///"_DUZSSN D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","DUZ",XBX)="" + .I 'DUZSSN S DA=XBX,DIE=200,DR=".01///"_XBLAST_","_XBFIRST D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","DUZ",XBX)="" + .S DA=XBX,DIE=200,DR=";1///"_$E(XBLAST,1,3)_";13///"_$E(XBLAST,1,8) D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","DUZINITIALS",XBX)="" + .S XBVANUM=1000000+XBX + .S XBDEANUM=2000000+XBX + .S DA=XBX,DIE=200,DR=";53.2///"_XBDEANUM_";53.3///"_XBVANUM D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","DUZDEAVA",XBX)="" + .D ^XBFMK + S ^XTMP("SAN","PROCESS","DUZ")="FINISHED" + Q +DUZSSN ;CHANGES SSN FOR USER FILE + S DUZSSN=$P($G(^VA(200,XBX,1)),"^",9) + I DUZSSN D DUZSSNR S DUZSSN=XBSSN + Q +DUZSSNR ;FIND RANDOM SSN + F S XBSSN=$R(999999999) Q:XBSSN>100000000&(XBSSN<800000000) + I $D(^VA(200,"SSN",XBSSN)) G DUZSSNR + Q +ALLSSN ;ADDS SSN TO EVERY PATIENT + D ^XBFMK + S XBX=0 F S XBX=$O(^DPT(XBX)) Q:+XBX=0 D + .Q:$L($P($G(^DPT(XBX,0)),"^",9)) + .D SSNR + .S DA=XBX,DIE=2,DR=".09///"_XBSSN D ^DIE K DIE,DA + .D ^XBFMK + S ^XTMP("SAN","PROCESS","SSN-ALL")="FINISHED" + Q +SSNR ;FIND RANDOM SSN + F S XBSSN=$R(999999999) Q:XBSSN>100000000&(XBSSN<800000000) + I $D(^DPT("SSN",XBSSN)) G SSNR + Q +PHNR ;FIND RANDOM PHONE + F S XBPHN=$R(9999) Q:XBPHN>1000&(XBPHN<9999) + Q + ; +PATDEL ; + S DFN=0 F S DFN=$O(^DPT(DFN)) Q:DFN'=+DFN D + .I $P($G(^DPT(DFN,0)),U,10)]"" S DA=DFN,DIE=2,DR=".091///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL091",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.101)),U,1)]"" S DA=DFN,DIE=2,DR=".101///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL101",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.111)),U,1)]"" S DA=DFN,DIE=2,DR=".1181///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1181",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.111)),U,2)]"" S DA=DFN,DIE=2,DR=".1182///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1182",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.111)),U,3)]"" S DA=DFN,DIE=2,DR=".1183///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1183",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.111)),U,4)]"" S DA=DFN,DIE=2,DR=".1184///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1184",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.111)),U,5)]"" S DA=DFN,DIE=2,DR=".1185///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1185",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.111)),U,6)]"" S DA=DFN,DIE=2,DR=".1186///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1186",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.111)),U,7)]"" S DA=DFN,DIE=2,DR=".1187///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1187",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.12)),U,1)]"" S DA=DFN,DIE=2,DR=".121///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL121",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.12)),U,2)]"" S DA=DFN,DIE=2,DR=".122///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL122",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.12)),U,3)]"" S DA=DFN,DIE=2,DR=".123///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL123",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.12)),U,4)]"" S DA=DFN,DIE=2,DR=".124///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL124",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.12)),U,5)]"" S DA=DFN,DIE=2,DR=".125///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL125",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.12)),U,6)]"" S DA=DFN,DIE=2,DR=".126///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL126",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.12)),U,7)]"" S DA=DFN,DIE=2,DR=".127///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL127",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.121)),U,1)]"" S DA=DFN,DIE=2,DR=".1211///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1211",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.121)),U,2)]"" S DA=DFN,DIE=2,DR=".1212///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PAT1212",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.121)),U,3)]"" S DA=DFN,DIE=2,DR=".1213///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PAT1213",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.121)),U,4)]"" S DA=DFN,DIE=2,DR=".1214///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PAT1214",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.121)),U,5)]"" S DA=DFN,DIE=2,DR=".1215///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PAT1215",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.121)),U,6)]"" S DA=DFN,DIE=2,DR=".1216///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1216",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.121)),U,7)]"" S DA=DFN,DIE=2,DR=".1217///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1217",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.121)),U,8)]"" S DA=DFN,DIE=2,DR=".1218///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1218",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.121)),U,10)]"" S DA=DFN,DIE=2,DR=".1219///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1219",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.111)),U,1)]"" S DA=DFN,DIE=2,DR=".1181///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1181",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.13)),U,3)]"" S DA=DFN,DIE=2,DR=".133///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL133",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.13)),U,4)]"" S DA=DFN,DIE=2,DR=".134///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL134",DFN)="" D ^XBFMK + .I $P($G(^AUPNPAT(DFN,3)),U,2)]"" S DA=DFN,DIE="AUPNPAT(",DR=".32///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL32",DFN)="" D ^XBFMK + .I $P($G(^AUPNPAT(DFN,11)),U,18)]"" S DA=DFN,DIE="AUPNPAT(",DR="1118///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1118",DFN)="" D ^XBFMK + .I $P($G(^AUPNPAT(DFN,26)),U,2)]"" S DA=DFN,DIE="AUPNPAT(",DR="2602///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL2602",DFN)="" D ^XBFMK + .I $P($G(^AUPNPAT(DFN,26)),U,5)]"" S DA=DFN,DIE="AUPNPAT(",DR="2605///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL2605",DFN)="" D ^XBFMK + .I $P($G(^AUPNPAT(DFN,99999999)),U,1)]"" S DA=DFN,DIE="AUPNPAT(",DR="99999999///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL99999999",DFN)="" D ^XBFMK + .F X=12:1:15 K ^AUPNPAT(DFN,X) + .K ^AUPNPAT(DFN,42) + S ^XTMP("SAN","PROCESS","PATDELETEDATA")="FINISHED" + Q +POSDEL ; + S XBX=0 F S XBX=$O(^ABSPC(XBX)) Q:+XBX=0 D + .S DA=XBX,DIK="^ABSPC(" D ^DIK,^XBFMK + S XBX=0 F S XBX=$O(^ABSPR(XBX)) Q:+XBX=0 D + .S DA=XBX,DIK="^ABSPR(" D ^DIK,^XBFMK + S DA=1,DIE="ABSP(9002313.56,",DR=".01///OUTPATIENT SITE;.02///12345;.03///456789;.05///123456789;.06///987654" + D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","POSDELETE",DA)="" D ^XBFMK + K ^ABSP(9002313.56,1,"ADDR") + K ^ABSP(9002313.56,1,"INSURER-ASSIGNED #") + K ^ABSP(9002313.56,1,"OPSITE") + S ^XTMP("SAN","PROCESS","POSDEL")="FINNISHED" + Q +AR ; + D ^XBFMK S U="^",XBA=0 F S XBA=$O(^BARBL(XBA)) Q:+XBA=0 D + .S XBB=0 F S XBB=$O(^BARBL(XBA,XBB)) Q:+XBB=0 D + ..I $P($G(^BARBL(XBA,XBB,0)),U,12)]"" S DA=XBB,DIE="90050.01",DUZ(2)=XBA,DR="12///@" D ^DIE,^XBFMK + ..I $P($G(^BARBL(XBA,XBB,1)),U,5)]"" D + ...D SSNR S DA=XBB,DIE="90050.01",DUZ(2)=XBA,DR="105///"_XBSSN D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","AR105",DA)="" D ^XBFMK + ..I $P($G(^BARBL(XBA,XBB,1)),U,6)]"" S DA=XBB,DIE="90050.01",DUZ(2)=XBA,DR="106///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","AR106",DA)="" D ^XBFMK + ..I $P($G(^BARBL(XBA,XBB,1)),U,7)]"" D + ...D SSNR S XBTEN=$E(XBSSN,1,5),DA=XBB,DIE="90050.01",DUZ(2)=XBA,DR="107///"_XBTEN D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","AR107E",DA)="" D ^XBFMK + ..I $P($G(^BARBL(XBA,XBB,1)),U,16)]"" S DA=XBB,DIE="90050.01",DUZ(2)=XBA,DR="116///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","AR116",DA)="" D ^XBFMK + ..I $P($G(^BARBL(XBA,XBB,2)),U,3)]"" S DA=XBB,DIE="90050.01",DUZ(2)=XBA,DR="203///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","AR203",DA)="" D ^XBFMK + ..I $P($G(^BARBL(XBA,XBB,2)),U,4)]"" S DA=XBB,DIE="90050.01",DUZ(2)=XBA,DR="204///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","AR204",DA)="" D ^XBFMK + ..I $P($G(^BARBL(XBA,XBB,2)),U,16)]"" S DA=XBB,DIE="90050.01",DUZ(2)=XBA,DR="216///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","AR216",DA)="" D ^XBFMK + ..I $P($G(^BARBL(XBA,XBB,2)),U,17)]"" S DA=XBB,DIE="90050.01",DUZ(2)=XBA,DR="217///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","AR217",DA)="" D ^XBFMK + ..S DUZ(2)=XBA K ^BARBL(DUZ(2),XBB,10),^BARBL(DUZ(2),XBB,5),^BARBL(DUZ(2),XBB,6) + ..I $P($G(^BARBL(XBA,XBB,7)),U,1)]"" S DA=XBB,DIE="90050.01",DUZ(2)=XBA,DR="701///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","AR701",DA)="" D ^XBFMK + ..I $P($G(^BARBL(XBA,XBB,7)),U,2)]"" S DA=XBB,DIE="90050.01",DUZ(2)=XBA,DR="702///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","AR702",DA)="" D ^XBFMK + S ^XTMP("SAN","PROCESS","AR-BILL")="FINISHED" + S XBA=0 F S XBA=$O(^BARCOL(XBA)) Q:+XBA=0 D + .S XBB=0 F S XBB=$O(^BARCOL(XBA,XBB)) Q:+XBB=0 K ^BARTR(XBA,XBB,10) + S ^XTMP("SAN","PROCESS","AR-TRAN")="FINISHED" + S XBA=0 F S XBA=$O(^BARCOL(XBA)) Q:+XBA=0 D + .S XBB=0 F S XBB=$O(^BARCOL(XBA,XBB)) Q:+XBB=0 D + ..S XBC=0 F S XBC=$O(^BARCOL(XBA,XBB,"1",XBC)) Q:+XBC=0 D + ...I $P($G(^BARCOL(XBA,XBB,1,XBC,0)),U,12)]"" S DIE="^BARCOL(XBA,XBB,1,",DA=XBC,DA(1)=XBB,DUZ(2)=XBA,DR="12///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","ARCOL12",DA)="" D ^XBFMK + ...I $P($G(^BARCOL(XBA,XBB,1,XBC,0)),U,13)]"" S DIE="^BARCOL(XBA,XBB,1,",DA=XBC,DA(1)=XBB,DUZ(2)=XBA,DR="13///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","ARCOL13",DA)="" D ^XBFMK + ...I $P($G(^BARCOL(XBA,XBB,1,XBC,0)),U,14)]"" S DIE="^BARCOL(XBA,XBB,1,",DA=XBC,DA(1)=XBB,DUZ(2)=XBA,DR="14///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","ARCOL14",DA)="" D ^XBFMK + ...K ^BARCOL(XBA,XBB,"1",XBC,5) + S ^XTMP("SAN","PROCESS","AR-COLL")="FINISHED" + S XBA=0 F S XBA=$O(^BAREDI("I",XBA)) Q:+XBA=0 D + .S XBB=0 F S XBB=$O(^BAREDI("I",XBA,XBB)) Q:+XBB=0 D + ..S DIK="^BAREDI(""I"",XBA,",DA=XBB,DUZ(2)=XBA=XBA D ^DIK,^XBFMK + S ^XTMP("SAN","PROCESS","AR-EDIIMP")="FINISHED" + S XBA=0 F S XBA=$O(^BAREDI("C",XBA)) Q:+XBA=0 D + .S XBB=0 F S XBB=$O(^BAREDI("C",XBA,XBB)) Q:+XBB=0 D + ..I $P($G(^BAREDI("C",XBA,XBB,0)),U,3)]"" S DIE="^BAREDI(""C"",XBA,XBB,",DA=XBB,DUZ(2)=XBA,DR=".03///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","BAREDI03",DA)="" D ^XBFMK + S ^XTMP("SAN","PROCESS","AR-EDIC")="FINISHED" + S XBA=0 F S XBB=$O(^BAR835(XBA)) Q:+XBA=0 D + .I $P($G(^BAR835(XBA,1)),U,1)]"" S DIE="^BAR835,",DA=XBA,DR=".11///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","AR11",DA)="" D ^XBFMK + S ^XTMP("SAN","PROCESS","AR-EDI835")="FINISHED" + Q +TPB ;3RD PARTY BILLING + D ^XBFMK + S U="^",XBA=0 F S XBA=$O(^ABMDCLM(XBA)) Q:+XBA=0 D + .S XBB=0 F S XBB=$O(^ABMDCLM(XBA,XBB)) Q:+XBB=0 D + ..I $L($P($G(^ABMDCLM(XBA,XBB,8)),U,8)) D + ...S X=^XTMP("SAN",$J,"DLAST") D R S XBLAST=^XTMP("SAN",$J,"DLAST",X) + ...S X=^XTMP("SAN",$J,"DFIRST") D R S XBFIRST=^XTMP("SAN",$J,"DFIRST",X) + ...S DA=XBB,DIE="9002274.3",DUZ(2)=XBA,DR=".88///"_XBLAST_","_XBFIRST D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","ABM88",DA)="" D ^XBFMK + ..I $L($P($G(^ABMDCLM(XBA,XBB,8)),U,11)) D + ...S DA=XBB,DIE="9002274.3",DUZ(2)=XBA,DR=".885///"_(100000+DA) D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","ABM885",DA)="" D ^XBFMK + ..I $L($P($G(^ABMDCLM(XBA,XBB,9)),U,12)) D + ...S X=^XTMP("SAN",$J,"DLAST") D R S XBLAST=^XTMP("SAN",$J,"DLAST",X) + ...S X=^XTMP("SAN",$J,"DFIRST") D R S XBFIRST=^XTMP("SAN",$J,"DFIRST",X) + ...S DA=XBB,DIE="9002274.3",DUZ(2)=XBA,DR=".912///"_XBLAST_","_XBFIRST D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","ABM912",DA)="" D ^XBFMK + S ^XTMP("SAN","PROCESS","3P-CLAIM")="FINISHED" + S XBA=0 F S XBA=$O(^ABMDBILL(XBA)) Q:+XBA=0 D + .S XBB=0 F S XBB=$O(^ABMDBILL(XBA,XBB)) Q:+XBB=0 D + ..I $L($P($G(^ABMDBILL(XBA,XBB,8)),U,8)) D + ...S X=^XTMP("SAN",$J,"DLAST") D R S XBLAST=^XTMP("SAN",$J,"DLAST",X) + ...S X=^XTMP("SAN",$J,"DFIRST") D R S XBFIRST=^XTMP("SAN",$J,"DFIRST",X) + ...S DA=XBB,DIE="9002274.4",DUZ(2)=XBA,DR=".88///"_XBLAST_","_XBFIRST D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","ABM88",DA)="" D ^XBFMK + ..I $L($P($G(^ABMDBILL(XBA,XBB,8)),U,11)) D + ...S DA=XBB,DIE="9002274.4",DUZ(2)=XBA,DR=".885///"_(200000+DA) D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","ABM885",DA)="" D ^XBFMK + ..I $L($P($G(^ABMDBILL(XBA,XBB,9)),U,12)) D + ...S X=^XTMP("SAN",$J,"DLAST") D R S XBLAST=^XTMP("SAN",$J,"DLAST",X) + ...S X=^XTMP("SAN",$J,"DFIRST") D R S XBFIRST=^XTMP("SAN",$J,"DFIRST",X) + ...S DA=XBB,DIE="9002274.4",DUZ(2)=XBA,DR=".912///"_XBLAST_","_XBFIRST D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","ABM912",DA)="" D ^XBFMK + S ^XTMP("SAN","PROCESS","3P-BILL")="FINISHED" + Q +LAB ; + S X=0 F S X=$O(^LR(X)) Q:X'=+X D + .S Y=0 F S Y=$O(^LR(X,"CH",Y)) Q:Y'=+Y D + ..I $D(^LR(X,"CH",Y,1)) S Z=$P(^LR(X,"CH",Y,1,0),U,1,2) K ^LR(X,"CH",Y,1) S ^LR(X,"CH",Y,1,0)=Z + .S Y=0 F S Y=$O(^LR(X,"MI",Y)) Q:Y'=+Y D + ..I $D(^LR(X,"MI",Y,4)) S Z=$P(^LR(X,"MI",Y,4,0),U,1,2) K ^LR(X,"MI",Y,4) S ^LR(X,"MI",Y,4,0)=Z + ..I $D(^LR(X,"MI",Y,19)) S Z=$P(^LR(X,"MI",Y,19,0),U,1,2) K ^LR(X,"MI",Y,19) S ^LR(X,"MI",Y,19,0)=Z + ..I $D(^LR(X,"MI",Y,20)) S Z=$P(^LR(X,"MI",Y,20,0),U,1,2) K ^LR(X,"MI",Y,20) S ^LR(X,"MI",Y,20,0)=Z + ..I $D(^LR(X,"MI",Y,21)) S Z=$P(^LR(X,"MI",Y,21,0),U,1,2) K ^LR(X,"MI",Y,21) S ^LR(X,"MI",Y,21,0)=Z + ..I $D(^LR(X,"MI",Y,22)) S Z=$P(^LR(X,"MI",Y,22,0),U,1,2) K ^LR(X,"MI",Y,22) S ^LR(X,"MI",Y,22,0)=Z + ..I $D(^LR(X,"MI",Y,23)) S Z=$P(^LR(X,"MI",Y,23,0),U,1,2) K ^LR(X,"MI",Y,23) S ^LR(X,"MI",Y,23,0)=Z + ..K ^LR(X,"MI",Y,99) + S X=0 F S X=$O(^LRO(69,X)) Q:X'=+X D + .I $D(^LRO(69,X,1,"AL")) K ^LRO(69,X,1,"AL") + .I $D(^LRO(69,X,1,"AP")) K ^LRO(69,X,1,"AP") + .I $D(^LRO(69,X,1,"AR")) K ^LRO(69,X,1,"AR") + S X=$P(^BLRTXLOG(0),U,1,2) K ^BLRTXLOG S ^BLRTXLOG(0)=X + S ^XTMP("SAN","PROCESS","LAB")="FINISHED" + D ^LROC + Q +LISTE ; + W !,"Listed below are the nodes and number of records that did not" + W !,"update properly. At the end of the sanitization, the records" + W !,"for Patient Name failures are rerun. PATNAME2 nodes represent" + W !,"Patient Names that should be manually changed with fileman." + W !,"XTMP(""SAN"",""PROCESS"") nodes:" + W !,"XTMP(""SAN"",""FAILURE"") nodes:" + S X="" F S X=$O(^XTMP("SAN","FAILURE",X)) Q:X="" D + .S (Y,Z)=0 F S Y=$O(^XTMP("SAN","FAILURE",X,Y)) Q:+Y=0 D + ..S Z=Z+1 + .W !,"Failure: "_X_" "_Z + W !,"FINISHED" Q +LISTD ; + W !,"Listed below are the processes completed." + W !,"XTMP(""SAN"",""PROCESS"") nodes:" + S X="" F S X=$O(^XTMP("SAN","PROCESS",X)) Q:X="" D + .W !,"Process: "_X + W !,"FINISHED" Q +MCDE ; + S DFN=0 F S DFN=$O(^AUPNMCD("B",DFN)) Q:+DFN=0 D + .S XBMDFN=0 F S XBMDFN=$O(^AUPNMCD("B",DFN,XBMDFN)) Q:XBMDFN'=+XBMDFN D + ..S X=^XTMP("SAN",$J,"DLAST") D R S XBDLAST=^XTMP("SAN",$J,"DLAST",X) + ..S X=^XTMP("SAN",$J,"DFIRST") D R S XBDFIRST=^XTMP("SAN",$J,"DFIRST",X) + ..S DIE="^AUPNMCD(",DA=XBMDFN,DR=".05///@;.12///@;.13///@" D ^DIE + ..I $D(Y) S ^XTMP("SAN","FAILURE","PATMCDEA",DA)="" + ..D ^XBFMK + ..S XBDNAME=XBDLAST_","_XBDFIRST + ..D SSNR + ..S DIE="^AUPNMCD(",DA=XBMDFN,DR=".03///"_XBSSN_";.14///"_XBDNAME_";2101///"_$P(^DPT(DFN,0),U,1)_";2102///"_$P(^DPT(DFN,0),U,3)_";.05///"_$P(^DPT(DFN,0),U,1) D ^DIE + ..I $D(Y) S ^XTMP("SAN","FAILURE","PATMCDEB",DA)="" + ..D ^XBFMK + S ^XTMP("SAN","PROCESS","MCD")="FINISHED" + Q +MMDEL ;DELETES MAILMAN MESSAGES + K ^XMB(3.9) + S ^XMB(3.9,0)="MESSAGE^3.9s^0^0" + Q +AUDEL ;DELETES AUDIT FILE + K ^DIA + S ^DIA(0)="AUDIT^1.1|" + Q +NCDEL ;DELETES NAME COMPONENTS FILE + K ^VA(20) + S ^VA(20,0)="NAME COMPONENTS^20IA^^" + Q +STU ;SETS STUDENT NAMES + K ^XTMP("SAN","FAILURE","STU") + K ^XTMP("SAN","FAILURE","STUA") +STUA D ^XBFMK + S XBX=50 F S XBX=$O(^VA(200,XBX)) Q:+XBX>76 D + .S XBLAST=$E("ABCDEFGHIJKLMNOPQRSTUVWXYZ",XBX-50,XBX-50)_"STUDENT" + .S XBFIRST="USER" + .S DA=XBX,DIE=200,DR=".01///"_XBLAST_","_XBFIRST D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","STU",XBX)="" + .S DA=XBX,DIE=200,DR="1///"_$E(XBLAST,1,2)_"U;13///"_$E(XBLAST,1,8) D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","STUINITIALS",XBX)="" + .S DA=XBX,DIE=200,DR="201///`29" D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","STUMENU",XBX)="" + .D ^XBFMK + W !,"FINISHED" + Q +FJADD1 ; + S DFN=0 F S DFN=$O(^XTMP("SAN","FAILURE","PATADDRESS",DFN)) Q:+DFN=0 I $P($G(^DPT(DFN,.11)),U,1)]"" D + .S XBADDR=DFN_" SMITH STREET" + .S DIE="^DPT(",DR=".111///"_XBADDR,DA=DFN D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATADDRESSFJ",DFN)="" + .D ^XBFMK + .S $P(^DPT(DFN,.11),U,2)="" ;addr 2nd line + .S $P(^DPT(DFN,.11),U,3)="" ;addr 3rd line + Q +A2213 ; + I $P($G(^DPT(DFN,.21)),U,3)]"" D + .S X=^XTMP("SAN",$J,"ADL1") D R S XBADDR=^XTMP("SAN",$J,"ADL1",X) + .S DIE="^DPT(",DR=".213///"_XBADDR,DA=DFN D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATADDRESSL11",DFN)="" + .D ^XBFMK + I $P($G(^DPT(DFN,.33)),U,3)]"" D + .S X=^XTMP("SAN",$J,"ADL1") D R S XBADDR=^XTMP("SAN",$J,"ADL1",X) + .S DIE="^DPT(",DR=".333.//"_XBADDR,DA=DFN D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATADDRESSL111",DFN)="" + .D ^XBFMK + Q +A2219 ;nok phone + S DFN=0 F S DFN=$O(^XTMP("SAN","FAILURE","PATPHONE",DFN)) Q:+DFN=0 I $P($G(^DPT(DFN,.21)),U,9)]"" D + .S $P(^DPT(DFN,.21),U,9)="555-888-"_$E(DFN_"9999",1,4) + Q + S DFN=0 F S DFN=$O(^XTMP("SAN","FAILURE","PATPHONE1",DFN)) Q:+DFN=0 I $P($G(^DPT(DFN,.33)),U,9)]"" D + .S $P(^DPT(DFN,.33),U,9)="555-888-"_$E(DFN_"9999",1,4) + Q diff --git a/XBSANP.m b/XBSANP.m new file mode 100644 index 0000000..be07387 --- /dev/null +++ b/XBSANP.m @@ -0,0 +1,718 @@ +XBSANP ;IHS/ITSC/LAB/FJE;SANITIZE RPMS DATABASE; [ 01/29/2004 11:10 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + W !,"This routine sanitizes and deletes RPMS data. To use you must type: D START^XBSAN",!! + Q +START ; + S (XBDUZ,XBDEL,XBPAT,XBPHR,XBBH,XBCHR,XBPOS,XB3PB,XBAR,XBLAB,XBMMDEL,XBAUDEL,XBNCDEL)=0 + K ^XTMP("SAN") + S ^XTMP("SAN","LASTDFN")=0 + ;W !,"This routine will first sanitize AND randomize the NEW PERSON file in the RPMS database." + ;S DIR(0)="Y",DIR("A")="Do you want to convert the new person data?",DIR("B")="N" KILL DA D ^DIR KILL DIR + ;S:Y=1 XBDUZ=1 + W !,"This routine will then REMOVE/DELETE UNNEEDED PATIENT DATA in the RPMS database." + S DIR(0)="Y",DIR("A")="Do you want this data deleted?",DIR("B")="N" KILL DA D ^DIR KILL DIR + S:Y=1 XBDEL=1 + W !!,"This routine will then sanitize the PATIENT FILES of a RPMS database." + S DIR(0)="Y",DIR("A")="Do you want to convert the patient data",DIR("B")="N" KILL DA D ^DIR KILL DIR + S:Y=1 XBPAT=1 + W !!,"This routine will then sanitize the POLICY HOLDER FILE of a RPMS database." + S DIR(0)="Y",DIR("A")="Do you want to convert the POLICY HOLDER data?",DIR("B")="N" KILL DA D ^DIR KILL DIR + S:Y=1 XBPHR=1 + W !!,"This routine will then delete SENSITIVE CHR DATA from a RPMS database." + S DIR(0)="Y",DIR("A")="Do you want to delete this CHR patient data?",DIR("B")="N" KILL DA D ^DIR KILL DIR + S:Y=1 XBCHR=1 + W !!,"This routine will then delete SENSITIVE BH VERSION 3.0 COMPLIANT DATA from a RPMS database." + S DIR(0)="Y",DIR("A")="Do you want to delete this CHR patient data?",DIR("B")="N" KILL DA D ^DIR KILL DIR + S:Y=1 XBBH=1 + W !,"This routine will then REMOVE/DELETE UNNEEDED POS DATA in the RPMS database." + S DIR(0)="Y",DIR("A")="Do you want this data deleted?",DIR("B")="N" KILL DA D ^DIR KILL DIR + S:Y=1 XBPOS=1 + W !,"This routine will then REMOVE/DELETE UNNEEDED 3PB DATA in the RPMS database." + S DIR(0)="Y",DIR("A")="Do you want this data deleted?",DIR("B")="N" KILL DA D ^DIR KILL DIR + S:Y=1 XB3PB=1 + W !,"This routine will then REMOVE/DELETE UNNEEDED AR DATA in the RPMS database." + S DIR(0)="Y",DIR("A")="Do you want this data deleted?",DIR("B")="N" KILL DA D ^DIR KILL DIR + S:Y=1 XBAR=1 + W !,"This routine will then REMOVE/DELETE UNNEEDED LAB DATA in the RPMS database." + S DIR(0)="Y",DIR("A")="Do you want this data deleted?",DIR("B")="N" KILL DA D ^DIR KILL DIR + S:Y=1 XBLAB=1 + W !,"This routine will then REMOVE/DELETE MAILMAN MESSAGES in the RPMS database." + S DIR(0)="Y",DIR("A")="Do you want this data deleted?",DIR("B")="N" KILL DA D ^DIR KILL DIR + S:Y=1 XBMMDEL=1 + W !,"This routine will then REMOVE/DELETE AUDIT DATA in the RPMS database." + S DIR(0)="Y",DIR("A")="Do you want this data deleted?",DIR("B")="N" KILL DA D ^DIR KILL DIR + S:Y=1 XBAUDEL=1 + W !,"This routine will then REMOVE/DELETE NAME COMPONENTS in the RPMS database." + S DIR(0)="Y",DIR("A")="Do you want this data deleted?",DIR("B")="N" KILL DA D ^DIR KILL DIR + S:Y=1 XBNCDEL=1 + W !,"All failed fileman update data can be found in: ^XTMP(""SAN"",""FAILURE"", GLOBAL" + W !,"?? display usually means that there was a fileman update failure" + W !,"If a hard error like an UNDEFINED occurs during the Patient scrambling," + W !," you can restart at the next patient by typing: RESTART^XBSAN " + W !,"This routine does not purge HL7, or ARMS data." + W !,"When finished...don't forget to manually address the above and RENAME Institutions",!! + W !!,"This routine is about to scramble the RPMS database." + S DIR(0)="Y",DIR("A")="Last chance: Do you want your RPMS data SANITIZED?",DIR("B")="N" KILL DA D ^DIR KILL DIR + Q:Y'=1 + D ^XBKVAR + W !,"Collecting random names" D CLEAN + I XBDUZ W !,"SCRAMBLING FILE 200" D DUZ + I XBDEL W !,"DELETING PAT INFO" D PATDEL +RESTART ;WILL RESTART PAT SCRAMBLE IF HARD ERROR OCCURS + I $G(^XTMP("SAN","LASTDFN"))>0 S ^XTMP("SAN","FAILURE","PATDFN",^XTMP("SAN","LASTDFN"))="" + I XBPAT W !,"SCRAMBLING PAT FILE" D PAT + I XBPHR W !,"SCRAMBLING POLICY FILE" D PHR + I XBCHR W !,"SCRAMBLING CHR FILE" D CHR + I XBBH W !,"DELETING BH INFO" D BH + I XBPOS W !,"DELETING POS INFO" D POSDEL + I XB3PB W !,"SCRAMBLING 3PB FILE" D TPB + I XBAR W !,"SCRAMBLING AR FILE" D AR + I XBLAB W !,"SCRAMBLING LAB FILES" D LAB + I XBMMDEL W !,"DELETING MAILMAN MESSAGES" D MMDEL + I XBAUDEL W !,"DELETING AUDIT DATA" D AUDEL + I XBNCDEL W !,"DELETING NAME COMPONENTS" D NCDEL + D PAT2 + S ^XTMP("SAN","PROCESS","XBSAN")="FINISHED" + W !,"FINISHED" + D LISTE + D EOJ + Q + ; +PAT D ^XBKVAR + S XBCHART=100000 + S DFN=+$G(^XTMP("SAN","LASTDFN")) I DFN W !,"RESTARTING PATIENT SCRAMBLE AFTER "_DFN,! + F S DFN=$O(^DPT(DFN)) Q:DFN'=+DFN D PROCPAT + S ^XTMP("SAN","PROCESS","PAT")="FINISHED" + Q + ; +PAT2 D ^XBKVAR + S XBCHART=100000 + W !,"RETRYING FAILED PATIENTS",! + S DFN=0 F S DFN=$O(^XTMP("SAN","FAILURE","PATNAME",DFN)) Q:DFN'=+DFN D + .S Y=DFN D ^AUPNPAT + .S XBSCR=$S(AUPNSEX="M":3,1:2) + .D FNAME + .D LNAME + .S XBNAME=XBLNAME_","_XBFNAME + .S DA=DFN,DIE="^DPT(",DR=".01///"_XBNAME D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATNAME2",DFN)="" W !,$P(^DPT(DFN,0),U,1)," ",XBNAME + .D ^XBFMK + S ^XTMP("SAN","PROCESS","PAT")="FINISHED" + Q +CHR ; + S X=0 F S X=$O(^BCHR(X)) Q:X'=+X K ^BCHR(X,51),^BCHR(X,61),^BCHR(X,71) + S ^XTMP("SAN","PROCESS","CHR")="FINISHED" + Q +BH ;version 3.0 compliant only + S X=0 F S X=$O(^AMHREC(X)) Q:X'=+X K ^AMHREC(X,31),^AMHREC(X,81),^AMHREC(X,21) + S X=0 F S X=$O(^AMHPTXP(X)) Q:X'=+X K ^AMHPTXP(X,18) + S ^XTMP("SAN","PROCESS","BH")="FINISHED" + Q +PHR ; + ;policy holders not pointing to a patient + S XBP=0 F S XBP=$O(^AUPN3PPH(XBP)) Q:XBP'=+XBP D + .Q:$P(^AUPN3PPH(XBP,0),U,2) ;already converted + .S XBS=$P(^AUPN3PPH(XBP,0),U,8) I XBS="" S XBS="M" + .S XBSCR=$S(XBS="M":3,1:2) + .D FNAME + .D LNAME + .S XBNAME=XBLNAME_","_XBFNAME + .D PHNR + .S XBPHN="555-777-"_XBPHN + .S DA=XBP,DIE="^AUPN3PPH(",DR=".01///"_XBNAME_";.14///"_XBPHN D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","POLICYPHONE",DFN)="" + .D ^XBFMK + .D SSNR + .S DA=XBP,DIE="^AUPN3PPH(",DR=".04///"_XBSSN D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","POLICYSSN",DFN)="" + .D ^XBFMK + .S X=^XTMP("SAN",$J,"ADL1") D R S XBADDR=^XTMP("SAN",$J,"ADL1",X) + .S $P(^AUPN3PPH(XBP,0),U,9)=XBADDR + .S XBD=$P(^AUPN3PPH(XBP,0),U,19) I XBD]"" S XBD=$$FMADD^XLFDT(XBD,-33) + .S DA=XBP,DIE="^AUPN3PPH(",DR=".19///"_XBD D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","POLICYDOB",DA)="" + .D ^XBFMK + S ^XTMP("SAN","PROCESS","POLICY")="FINISHED" + Q +PROCPAT ; + S ^XTMP("SAN","LASTDFN")=DFN + I '(DFN#5000) W !,"."_DFN_"." + D ^XBFMK + S Y=DFN D ^AUPNPAT + D F201 + D F203 ;subtract 33 days from dob + D F209 + D F2111 + D F2131 + D F2132 + D F2211 + D F2212 + D F2213 + D F2219 + D F22401 + D F22402 + D F22403 + D OTHNAME + D TEN ;tribal enrollment number + D BRTH + D DTH + D PN + D EMPL + D NKR + D ECR + D XBCHART + D INSURE + D POLICY + Q +EOJ ; + D EN^XBVK("XB") + K DFN,XBH,OTDFN,XBB,AUPNSEX,X,X2,XB3PB,XBAR,XBAUDEL + K DA,DIE,DIK,DIR,DR,DUZSSN,I,XBA,XBADDR,XBADL1 + K XBBH,XBC,XBCHART,XBCHR,XBD,XBDAD,XBDEANUM,XBDEL,XBDFIRST,XBDLAST,XBDNAME + K XBDOB,XBDUZ,XBFIRST,XBFNAME,XBH,XBLAB,XBLNAME,XBMDFN,XBMMDEL,XBMOM + K XBNAME,XBNCDEL,XBNOK,XBNOKADL,XBP,XBPAT,XBPHN,XBPHR,XBPOS,XBS + K XBSCR,XBSEX,XBSSN,XBTEN,XBVAL,XBVANUM,XBX,Y,Z + W !,"If all data appears correct and you have chaecked failures, kill the ^XTMP(""SAN"") global",!! + Q +NKR ; + I $P($G(^AUPNPAT(DFN,28)),U,2)]"" S DA=DFN,DIE="^AUPNPAT(",DR="2802///`"_$O(^AUTTRLSH("B","MOTHER",0)) D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","PATNKR",DFN)="" + D ^XBFMK + Q +ECR ; + I $P($G(^AUPNPAT(DFN,31)),U,2)]"" S DA=DFN,DIE="^AUPNPAT(",DR="3102///`"_$O(^AUTTRLSH("B","MOTHER",0)) D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","PATECR",DFN)="" + D ^XBFMK + Q +EMPL ;employer .19 + I $P($G(^AUPNPAT(DFN,0)),U,19)]"" S DA=DFN,DIE="^AUPNPAT(",DR=".19///FIRST AMERICAN BANK" D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","PATEMP",DFN)="" + D ^XBFMK + Q +PN ; + I $P($G(^AUPNPAT(DFN,0)),U,31)]"" S DA=DFN,DIE="^AUPNPAT(",DR=".31///"_$P(^DPT(DFN,0),U) D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","PATPN",DFN)="" + D ^XBFMK + Q +TEN ; + S XBTEN="TN - "_DFN + I $P($G(^AUPNPAT(DFN,0)),U,7)]"" S DA=DFN,DIE="^AUPNPAT(",DR=".07///"_XBTEN D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","PATTEN",DFN)="" + D ^XBFMK + Q +BRTH ; + I $P($G(^AUPNPAT(DFN,11)),U,5)]"" S XBTEN=$E(DFN_"000000",1,7),DA=DFN,DIE="^AUPNPAT(",DR="1105///"_XBTEN D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","PATBIRTH",DFN)="" + D ^XBFMK + Q +DTH ; + I $P($G(^AUPNPAT(DFN,11)),U,16)]"" S XBTEN=$E("D"_DFN_"00000",1,7),DA=DFN,DIE="^AUPNPAT(",DR="1105///"_XBTEN D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","PATDEATH",DFN)="" + D ^XBFMK + Q +F201 ; + S XBSCR=$S(AUPNSEX="M":3,1:2) + D FNAME + D LNAME + S XBNAME=XBLNAME_","_XBFNAME + S DA=DFN,DIE="^DPT(",DR=".01///"_XBNAME D ^DIE + I $D(Y) S ^XTMP("SAN","FAILURE","PATNAME",DFN)="" + D ^XBFMK + Q +FNAME ; + I XBSCR=3 S X=^XTMP("SAN",$J,"FIRSTM") D R S XBFNAME=^XTMP("SAN",$J,"FIRSTM",X) Q + S X=^XTMP("SAN",$J,"FIRSTF") D R S XBFNAME=^XTMP("SAN",$J,"FIRSTF",X) + Q +LNAME ; + S X=^XTMP("SAN",$J,"LAST") D R S XBLNAME=^XTMP("SAN",$J,"LAST",X) + Q +F203 ;dob + S XBDOB=$P(^DPT(DFN,0),U,3) + I XBDOB="" Q + S XBDOB=$$FMADD^XLFDT(XBDOB,-33) + S DIE="^DPT(",DA=DFN,DR=".03///"_XBDOB D ^DIE + I $D(Y) S ^XTMP("SAN","FAILURE","PATDOB",DFN)="" + D ^XBFMK + Q +F2211 ;nok/emergency contact name + S XBSCR=2 D FNAME S XBNOK=XBLNAME_","_XBFNAME + I $P($G(^DPT(DFN,.21)),U,1)]"" D + .D ^XBFMK + .S DIE="^DPT(",DR=".211///"_XBNOK,DA=DFN D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATNOK",DFN)="" + .D ^XBFMK + I $P($G(^DPT(DFN,.33)),U,1)]"" D + .S DIE="^DPT(",DR=".331///"_XBNOK,DA=DFN D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATECN",DFN)="" + .D ^XBFMK + Q +F2212 ; + D ^XBFMK + I $P($G(^DPT(DFN,.21)),U,2)]"" D + .S DA=DFN,DIE="^DPT(",DR=".212///MOTHER" D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATNOKMOTHER",DFN)="" + .D ^XBFMK + I $P($G(^DPT(DFN,.33)),U,2)]"" D + .S DA=DFN,DIE="^DPT(",DR=".332///"_"MOTHER" D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATECNMOTHER",DFN)="" + .D ^XBFMK + Q +F22401 ;father's name + I $P($G(^DPT(DFN,.24)),U,1)="" Q + S XBSCR=3 D FNAME S XBDAD=XBLNAME_","_XBFNAME + S DIE="^DPT(",DR=".2401///"_XBDAD,DA=DFN D ^DIE + I $D(Y) S ^XTMP("SAN","FAILURE","PATFATHER",DFN)="" + D ^XBFMK + Q +F22402 ;mother's name + S XBSCR=2 D FNAME S XBMOM=XBLNAME_","_XBFNAME + I $P($G(^DPT(DFN,.24)),U,2)="" Q + S DIE="^DPT(",DR=".2402///"_XBMOM,DA=DFN D ^DIE + I $D(Y) S ^XTMP("SAN","FAILURE","PATMOTHER",DFN)="" + D ^XBFMK + Q +F22403 ;mother's maiden name + D LNAME + S XBMMN=XBLNAME_","_$P(XBMOM,",",2) + I $P($G(^DPT(DFN,.24)),U,3)="" Q + S DIE="^DPT(",DR=".2403///"_XBMMN,DA=DFN D ^DIE + I $D(Y) S ^XTMP("SAN","FAILURE","PATMOTHMAIDNAM",DFN)="" + D ^XBFMK + Q +OTHNAME ; + S OTDFN=0 F S OTDFN=$O(^DPT(DFN,.01,OTDFN)) Q:OTDFN'=+OTDFN D + .D LNAME + .S XBNAME=XBLNAME_","_XBFNAME + .S DA=OTDFN,DIE="^DPT("_DFN_",.01,",DA(1)=DFN,DR=".01///"_XBNAME D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATOTHRNAME",DFN)="" + .D ^XBFMK + Q +F2111 ; + I $P($G(^DPT(DFN,.11)),U,1)]"" D + .S X=^XTMP("SAN",$J,"ADL1") D R S XBADDR=^XTMP("SAN",$J,"ADL1",X) + .S DIE="^DPT(",DR=".111///"_XBADDR,DA=DFN D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATADDRESS",DFN)="" + .D ^XBFMK + .S $P(^DPT(DFN,.11),U,2)="" ;addr 2nd line + .S $P(^DPT(DFN,.11),U,3)="" ;addr 3rd line + Q +F2213 ; + I $P($G(^DPT(DFN,.21)),U,3)]"" D + .S X=^XTMP("SAN",$J,"ADL1") D R S XBADDR=^XTMP("SAN",$J,"ADL1",X) + .S DIE="^DPT(",DR=".213///"_XBADDR,DA=DFN D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATADDRESSL11",DFN)="" + .D ^XBFMK + I $P($G(^DPT(DFN,.33)),U,3)]"" D + .S X=^XTMP("SAN",$J,"ADL1") D R S XBADDR=^XTMP("SAN",$J,"ADL1",X) + .S DIE="^DPT(",DR=".333.//"_XBADDR,DA=DFN D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATADDRESSL111",DFN)="" + .D ^XBFMK + Q +POLICY ; + ;loop through policy holder + ;if has patient pointer use patient name and address and + D ^XBFMK + S XBP=$O(^AUPN3PPH("C",DFN,0)) + I 'XBP K XBP Q + S XBTEN=$P($G(^DPT(DFN,.11)),U,1) + S DA=XBP,DIE="^AUPN3PPH(",DR=".01///"_XBNAME_";.04///"_XBSSN_";.09///"_XBTEN_";.11///@;.13///@;.14///@;.19///"_XBDOB D ^DIE + I $D(Y) S ^XTMP("SAN","FAILURE","PATPOLICY",DA)="" + D ^XBFMK + Q +INSURE ; + D MCR,PI,MCD,RR + Q +MCR ; + ;MEDICARE + Q:'$D(^AUPNMCR(DFN)) + S X=^XTMP("SAN",$J,"DLAST") D R S XBDLAST=^XTMP("SAN",$J,"DLAST",X) + S X=^XTMP("SAN",$J,"DFIRST") D R S XBDFIRST=^XTMP("SAN",$J,"DFIRST",X) + S XBDLAST=XBDLAST_","_XBDFIRST + D SSNR + S DIE="^AUPNMCR(",DA=DFN,DR=".03///"_XBSSN_";.14///"_XBDLAST_";2101///"_$P(^DPT(DFN,0),U,1)_";2102///"_$P(^DPT(DFN,0),U,3) D ^DIE + I $D(Y) S ^XTMP("SAN","FAILURE","PATMEDICARE",DFN)="" + D ^XBFMK + Q +PI ; + Q:'$D(^AUPNPRVT(DFN)) + Q:'$D(^AUPNPRVT(DFN,11)) + S XBMDFN=0 F S XBMDFN=$O(^AUPNPRVT(DFN,11,XBMDFN)) Q:XBMDFN'=+XBMDFN D + .S $P(^AUPNPRVT(DFN,11,XBMDFN,0),U,2)=XBSSN + .S $P(^AUPNPRVT(DFN,11,XBMDFN,0),U,4)=XBNAME + .S $P(^AUPNPRVT(DFN,11,XBMDFN,0),U,12)="" + .S $P(^AUPNPRVT(DFN,11,XBMDFN,0),U,14)="" + Q + ; +RR ; + Q:'$D(^AUPNRRE(DFN)) + S X=^XTMP("SAN",$J,"DLAST") D R S XBDLAST=^XTMP("SAN",$J,"DLAST",X) + S X=^XTMP("SAN",$J,"DFIRST") D R S XBDFIRST=^XTMP("SAN",$J,"DFIRST",X) + S XBDLAST=XBDLAST_","_XBDFIRST + D SSNR + S DIE="^AUPNRRE(",DA=DFN,DR=".04///"_XBSSN_";.14///"_XBDLAST_";2101///"_$P(^DPT(DFN,0),U,1)_";2102///"_$P(^DPT(DFN,0),U,3) D ^DIE + I $D(Y) S ^XTMP("SAN","FAILURE","PATRAILROAD",DFN)="" + D ^XBFMK + Q +MCD ; + S XBMDFN=0 F S XBMDFN=$O(^AUPNMCD("B",DFN,XBMDFN)) Q:XBMDFN'=+XBMDFN D + .S X=^XTMP("SAN",$J,"DLAST") D R S XBDLAST=^XTMP("SAN",$J,"DLAST",X) + .S X=^XTMP("SAN",$J,"DFIRST") D R S XBDFIRST=^XTMP("SAN",$J,"DFIRST",X) + .S DIE="^AUPNMCD(",DA=XBMDFN,DR=".05///@;.12///@;.13///@" D ^DIE + .D ^XBFMK + .S XBDNAME=XBDLAST_","_XBDFIRST + .D SSNR + .S DIE="^AUPNMCD(",DA=XBMDFN,DR=".03///"_XBSSN_";.14///"_XBDNAME_";2101///"_$P(^DPT(DFN,0),U,1)_";2102///"_$P(^DPT(DFN,0),U,3)_";.05///"_$P(^DPT(DFN,0),U,1) D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATMEDICAID",DA)="" + .D ^XBFMK + Q +XBCHART ; + S XBH=0 F S XBH=$O(^AUPNPAT(DFN,41,XBH)) Q:XBH'=+XBH S XBCHART=XBCHART+1 D + .S DA=XBH,DIE="^AUPNPAT("_DFN_",41,",DA(1)=DFN,DR=".02///"_XBCHART D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATCHART",DFN)="" + .D ^XBFMK + Q +F209 ; + I $P($G(^DPT(DFN,0)),U,9)="" Q + D SSNR + S DIE="^DPT(",DA=DFN,DR=".09///"_XBSSN D ^DIE + I $D(Y) S DA=DFN,DIE="^DPT(",DR=".09///@" D ^DIE + I $D(Y) S ^XTMP("SAN","FAILURE","PATSSN",DFN)="" + D ^XBFMK + Q +F2219 ;nok phone + I $P($G(^DPT(DFN,.21)),U,9)]"" D PHNR D ;S $P(^DPT(DFN,.21),U,9)="555-888-"_XBPHN + .S XBPHN="555-888-"_XBPHN + .S DIE="^DPT(",DA=DFN,DR=".219///"_XBPHN D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATPHONE",DFN)="" + .D ^XBFMK + I $P($G(^DPT(DFN,.33)),U,9)]"" D PHNR D ;S $P(^DPT(DFN,.33),U,9)="555-888-"_XBPHN + .S XBPHN="555-888-"_XBPHN + .S DIE="^DPT(",DA=DFN,DR=".339///"_XBPHN D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATPHONE1",DFN)="" + .D ^XBFMK + Q +F2131 ; + I $P($G(^DPT(DFN,.13)),U,1)]"" D PHNR D + .S XBPHN="555-555-"_XBPHN + .S DIE="^DPT(",DA=DFN,DR=".131///"_XBPHN D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATPHONE2",DFN)="" + .D ^XBFMK + Q +F2132 ; + Q:$P($G(^DPT(DFN,.13)),U,2)="" ;no office phone + D PHNR S XBPHN="555-999-"_XBPHN + S DIE="^DPT(",DA=DFN,DR=".132///"_XBPHN D ^DIE + I $D(Y) S ^XTMP("SAN","FAILURE","PATPHONE3",DFN)="" + D ^XBFMK + Q + ; +DELP ;delete patients with no visits + ;S XBCNT=0,XBP=0 F S XBP=$O(^DPT(XBP)) Q:XBP'=+XBP D + ;.Q:$D(^AUPNVSIT("AC",XBP)) + ;.S DA=XBP,DIK="^DPT(" D ^DIK + ;.S DA=XBP,DIK="^AUPNPAT(" D ^DIK + ;.W DA,":" S XBCNT=XBCNT+1 + ;.Q + ;W !,XBCNT + ;Q +CLEAN ; + K ^XTMP("SAN",$J,"FIRSTM") + K ^XTMP("SAN",$J,"FIRSTF") + K ^XTMP("SAN",$J,"ADL1") + K ^XTMP("SAN",$J,"NOKADL") + K ^XTMP("SAN","FAILURE") + K ^XTMP("SAN",$J,"DLAST") + K ^XTMP("SAN",$J,"DFIRST") + K ^XTMP("SAN","PROCESS","DUZ") + K ^XTMP("SAN","DUZFAILURE") + D ^XBKVAR + S (XBC(1),XBC(2))=0,XBX=1 F S XBX=$O(^VA(200,XBX)) Q:+XBX=0 D + .S XBNAME=$P($G(^VA(200,XBX,0)),U,1) + .S XBLAST=$P(XBNAME,",",1) S:'$L(XBLAST) XBLAST="MOUSE" + .S XBFIRST=$P(XBNAME,",",2) S:'$L(XBFIRST) XBFIRST="MICKEY"_+XBX + .S XBC(1)=XBC(1)+1,^XTMP("SAN",$J,"DLAST")=XBC(1),^XTMP("SAN",$J,"DLAST",XBC(1))=XBLAST + .S XBC(2)=XBC(2)+1,^XTMP("SAN",$J,"DFIRST")=XBC(2),^XTMP("SAN",$J,"DFIRST",XBC(2))=XBFIRST + D ^XBKVAR + F I=1:1:5 S XBC(I)=0 + S Y=0 F S Y=$O(^DPT(Y)) Q:+Y=0 D + .S XBVAL=$G(^DPT(Y,0)) + .S XBNAME=$P(XBVAL,U,1) + .S XBLAST=$P(XBNAME,",",1) + .S XBFIRST=$P(XBNAME,",",2) + .S XBSEX=$P(XBVAL,U,2) + .S XBADL1=$P($G(^DPT(Y,.11)),U,1) + .S XBNOKADL=$P($G(^DPT(Y,.33)),U,3) +SET .S XBC(1)=XBC(1)+1,^XTMP("SAN",$J,"LAST")=XBC(1),^XTMP("SAN",$J,"LAST",XBC(1))=XBLAST + .I $L(XBSEX) S:XBSEX="M" XBC(2)=XBC(2)+1,^XTMP("SAN",$J,"FIRSTM")=XBC(2),^XTMP("SAN",$J,"FIRSTM",XBC(2))=XBFIRST + .I $L(XBSEX) S:XBSEX="F" XBC(3)=XBC(3)+1,^XTMP("SAN",$J,"FIRSTF")=XBC(3),^XTMP("SAN",$J,"FIRSTF",XBC(3))=XBFIRST + .I $L(XBADL1) S XBC(5)=XBC(5)+1,^XTMP("SAN",$J,"ADL1")=XBC(5),^XTMP("SAN",$J,"ADL1",XBC(5))=XBADL1 + .I $L(XBNOKADL) S XBC(5)=XBC(5)+1,^XTMP("SAN",$J,"ADL1")=XBC(5),^XTMP("SAN",$J,"ADL1",XBC(5))=XBNOKADL + Q +R S X2=$R(X) I X2=0 G R + S X=X2 + Q + ; +DUZ ;SCRAMBLES USER NAMES + K ^XTMP("SAN","FAILURE","DUZ") + K ^XTMP("SAN","FAILURE","DUZA") +DUZA D ^XBFMK + S XBX=1 F S XBX=$O(^VA(200,XBX)) Q:+XBX=0 D + .S X=^XTMP("SAN",$J,"DLAST") D R S XBLAST=^XTMP("SAN",$J,"DLAST",X) + .S X=^XTMP("SAN",$J,"DFIRST") D R S XBFIRST=^XTMP("SAN",$J,"DFIRST",X) + .D DUZSSN + .;W !,$P(^VA(200,XBX,0),"^",1)," ",XBLAST," ",XBFIRST,$P($G(^VA(200,XBX,1)),"^",9)," ",DUZSSN + .I DUZSSN S DA=XBX,DIE=200,DR=".01///"_XBLAST_","_XBFIRST_";9///"_DUZSSN D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","DUZ",XBX)="" + .I 'DUZSSN S DA=XBX,DIE=200,DR=".01///"_XBLAST_","_XBFIRST D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","DUZ",XBX)="" + .S DA=XBX,DIE=200,DR=";1///"_$E(XBLAST,1,3)_";13///"_$E(XBLAST,1,8) D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","DUZINITIALS",XBX)="" + .S XBVANUM=1000000+XBX + .S XBDEANUM=2000000+XBX + .S DA=XBX,DIE=200,DR=";53.2///"_XBDEANUM_";53.3///"_XBVANUM D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","DUZDEAVA",XBX)="" + .D ^XBFMK + S ^XTMP("SAN","PROCESS","DUZ")="FINISHED" + Q +DUZSSN ;CHANGES SSN FOR USER FILE + S DUZSSN=$P($G(^VA(200,XBX,1)),"^",9) + I DUZSSN D DUZSSNR S DUZSSN=XBSSN + Q +DUZSSNR ;FIND RANDOM SSN + F S XBSSN=$R(999999999) Q:XBSSN>100000000&(XBSSN<800000000) + I $D(^VA(200,"SSN",XBSSN)) G DUZSSNR + Q +ALLSSN ;ADDS SSN TO EVERY PATIENT + D ^XBFMK + S XBX=0 F S XBX=$O(^DPT(XBX)) Q:+XBX=0 D + .Q:$L($P($G(^DPT(XBX,0)),"^",9)) + .D SSNR + .S DA=XBX,DIE=2,DR=".09///"_XBSSN D ^DIE K DIE,DA + .D ^XBFMK + S ^XTMP("SAN","PROCESS","SSN-ALL")="FINISHED" + Q +SSNR ;FIND RANDOM SSN + F S XBSSN=$R(999999999) Q:XBSSN>100000000&(XBSSN<800000000) + I $D(^DPT("SSN",XBSSN)) G SSNR + I XBSSN>698999999&(XBSSN<729000001) G SSNR + Q +PHNR ;FIND RANDOM PHONE + F S XBPHN=$R(9999) Q:XBPHN>1000&(XBPHN<9999) + Q + ; +PATDEL ; + S DFN=0 F S DFN=$O(^DPT(DFN)) Q:DFN'=+DFN D + .I $P($G(^DPT(DFN,0)),U,10)]"" S DA=DFN,DIE=2,DR=".091///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL091",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.101)),U,1)]"" S DA=DFN,DIE=2,DR=".101///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL101",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.111)),U,1)]"" S DA=DFN,DIE=2,DR=".1181///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1181",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.111)),U,2)]"" S DA=DFN,DIE=2,DR=".1182///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1182",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.111)),U,3)]"" S DA=DFN,DIE=2,DR=".1183///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1183",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.111)),U,4)]"" S DA=DFN,DIE=2,DR=".1184///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1184",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.111)),U,5)]"" S DA=DFN,DIE=2,DR=".1185///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1185",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.111)),U,6)]"" S DA=DFN,DIE=2,DR=".1186///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1186",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.111)),U,7)]"" S DA=DFN,DIE=2,DR=".1187///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1187",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.12)),U,1)]"" S DA=DFN,DIE=2,DR=".121///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL121",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.12)),U,2)]"" S DA=DFN,DIE=2,DR=".122///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL122",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.12)),U,3)]"" S DA=DFN,DIE=2,DR=".123///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL123",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.12)),U,4)]"" S DA=DFN,DIE=2,DR=".124///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL124",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.12)),U,5)]"" S DA=DFN,DIE=2,DR=".125///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL125",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.12)),U,6)]"" S DA=DFN,DIE=2,DR=".126///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL126",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.12)),U,7)]"" S DA=DFN,DIE=2,DR=".127///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL127",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.121)),U,1)]"" S DA=DFN,DIE=2,DR=".1211///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1211",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.121)),U,2)]"" S DA=DFN,DIE=2,DR=".1212///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PAT1212",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.121)),U,3)]"" S DA=DFN,DIE=2,DR=".1213///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PAT1213",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.121)),U,4)]"" S DA=DFN,DIE=2,DR=".1214///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PAT1214",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.121)),U,5)]"" S DA=DFN,DIE=2,DR=".1215///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PAT1215",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.121)),U,6)]"" S DA=DFN,DIE=2,DR=".1216///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1216",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.121)),U,7)]"" S DA=DFN,DIE=2,DR=".1217///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1217",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.121)),U,8)]"" S DA=DFN,DIE=2,DR=".1218///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1218",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.121)),U,10)]"" S DA=DFN,DIE=2,DR=".1219///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1219",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.111)),U,1)]"" S DA=DFN,DIE=2,DR=".1181///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1181",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.13)),U,3)]"" S DA=DFN,DIE=2,DR=".133///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL133",DFN)="" D ^XBFMK + .I $P($G(^DPT(DFN,.13)),U,4)]"" S DA=DFN,DIE=2,DR=".134///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL134",DFN)="" D ^XBFMK + .I $P($G(^AUPNPAT(DFN,3)),U,2)]"" S DA=DFN,DIE="AUPNPAT(",DR=".32///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL32",DFN)="" D ^XBFMK + .I $P($G(^AUPNPAT(DFN,11)),U,18)]"" S DA=DFN,DIE="AUPNPAT(",DR="1118///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL1118",DFN)="" D ^XBFMK + .I $P($G(^AUPNPAT(DFN,26)),U,2)]"" S DA=DFN,DIE="AUPNPAT(",DR="2602///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL2602",DFN)="" D ^XBFMK + .I $P($G(^AUPNPAT(DFN,26)),U,5)]"" S DA=DFN,DIE="AUPNPAT(",DR="2605///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL2605",DFN)="" D ^XBFMK + .I $P($G(^AUPNPAT(DFN,99999999)),U,1)]"" S DA=DFN,DIE="AUPNPAT(",DR="99999999///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","PATDEL99999999",DFN)="" D ^XBFMK + .F X=12:1:15 K ^AUPNPAT(DFN,X) + .K ^AUPNPAT(DFN,42) + S ^XTMP("SAN","PROCESS","PATDELETEDATA")="FINISHED" + Q +POSDEL ; + S XBX=0 F S XBX=$O(^ABSPC(XBX)) Q:+XBX=0 D + .S DA=XBX,DIK="^ABSPC(" D ^DIK,^XBFMK + S XBX=0 F S XBX=$O(^ABSPR(XBX)) Q:+XBX=0 D + .S DA=XBX,DIK="^ABSPR(" D ^DIK,^XBFMK + S DA=1,DIE="ABSP(9002313.56,",DR=".01///OUTPATIENT SITE;.02///12345;.03///456789;.05///123456789;.06///987654" + D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","POSDELETE",DA)="" D ^XBFMK + K ^ABSP(9002313.56,1,"ADDR") + K ^ABSP(9002313.56,1,"INSURER-ASSIGNED #") + K ^ABSP(9002313.56,1,"OPSITE") + S ^XTMP("SAN","PROCESS","POSDEL")="FINNISHED" + Q +AR ; + D ^XBFMK S U="^",XBA=0 F S XBA=$O(^BARBL(XBA)) Q:+XBA=0 D + .S XBB=0 F S XBB=$O(^BARBL(XBA,XBB)) Q:+XBB=0 D + ..I $P($G(^BARBL(XBA,XBB,0)),U,12)]"" S DA=XBB,DIE="90050.01",DUZ(2)=XBA,DR="12///@" D ^DIE,^XBFMK + ..I $P($G(^BARBL(XBA,XBB,1)),U,5)]"" D + ...D SSNR S DA=XBB,DIE="90050.01",DUZ(2)=XBA,DR="105///"_XBSSN D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","AR105",DA)="" D ^XBFMK + ..I $P($G(^BARBL(XBA,XBB,1)),U,6)]"" S DA=XBB,DIE="90050.01",DUZ(2)=XBA,DR="106///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","AR106",DA)="" D ^XBFMK + ..I $P($G(^BARBL(XBA,XBB,1)),U,7)]"" D + ...D SSNR S XBTEN=$E(XBSSN,1,5),DA=XBB,DIE="90050.01",DUZ(2)=XBA,DR="107///"_XBTEN D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","AR107E",DA)="" D ^XBFMK + ..I $P($G(^BARBL(XBA,XBB,1)),U,16)]"" S DA=XBB,DIE="90050.01",DUZ(2)=XBA,DR="116///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","AR116",DA)="" D ^XBFMK + ..I $P($G(^BARBL(XBA,XBB,2)),U,3)]"" S DA=XBB,DIE="90050.01",DUZ(2)=XBA,DR="203///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","AR203",DA)="" D ^XBFMK + ..I $P($G(^BARBL(XBA,XBB,2)),U,4)]"" S DA=XBB,DIE="90050.01",DUZ(2)=XBA,DR="204///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","AR204",DA)="" D ^XBFMK + ..I $P($G(^BARBL(XBA,XBB,2)),U,16)]"" S DA=XBB,DIE="90050.01",DUZ(2)=XBA,DR="216///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","AR216",DA)="" D ^XBFMK + ..I $P($G(^BARBL(XBA,XBB,2)),U,17)]"" S DA=XBB,DIE="90050.01",DUZ(2)=XBA,DR="217///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","AR217",DA)="" D ^XBFMK + ..S DUZ(2)=XBA K ^BARBL(DUZ(2),XBB,10),^BARBL(DUZ(2),XBB,5),^BARBL(DUZ(2),XBB,6) + ..I $P($G(^BARBL(XBA,XBB,7)),U,1)]"" S DA=XBB,DIE="90050.01",DUZ(2)=XBA,DR="701///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","AR701",DA)="" D ^XBFMK + ..I $P($G(^BARBL(XBA,XBB,7)),U,2)]"" S DA=XBB,DIE="90050.01",DUZ(2)=XBA,DR="702///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","AR702",DA)="" D ^XBFMK + S ^XTMP("SAN","PROCESS","AR-BILL")="FINISHED" + S XBA=0 F S XBA=$O(^BARCOL(XBA)) Q:+XBA=0 D + .S XBB=0 F S XBB=$O(^BARCOL(XBA,XBB)) Q:+XBB=0 K ^BARTR(XBA,XBB,10) + S ^XTMP("SAN","PROCESS","AR-TRAN")="FINISHED" + S XBA=0 F S XBA=$O(^BARCOL(XBA)) Q:+XBA=0 D + .S XBB=0 F S XBB=$O(^BARCOL(XBA,XBB)) Q:+XBB=0 D + ..S XBC=0 F S XBC=$O(^BARCOL(XBA,XBB,"1",XBC)) Q:+XBC=0 D + ...I $P($G(^BARCOL(XBA,XBB,1,XBC,0)),U,12)]"" S DIE="^BARCOL(XBA,XBB,1,",DA=XBC,DA(1)=XBB,DUZ(2)=XBA,DR="12///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","ARCOL12",DA)="" D ^XBFMK + ...I $P($G(^BARCOL(XBA,XBB,1,XBC,0)),U,13)]"" S DIE="^BARCOL(XBA,XBB,1,",DA=XBC,DA(1)=XBB,DUZ(2)=XBA,DR="13///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","ARCOL13",DA)="" D ^XBFMK + ...I $P($G(^BARCOL(XBA,XBB,1,XBC,0)),U,14)]"" S DIE="^BARCOL(XBA,XBB,1,",DA=XBC,DA(1)=XBB,DUZ(2)=XBA,DR="14///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","ARCOL14",DA)="" D ^XBFMK + ...K ^BARCOL(XBA,XBB,"1",XBC,5) + S ^XTMP("SAN","PROCESS","AR-COLL")="FINISHED" + S XBA=0 F S XBA=$O(^BAREDI("I",XBA)) Q:+XBA=0 D + .S XBB=0 F S XBB=$O(^BAREDI("I",XBA,XBB)) Q:+XBB=0 D + ..S DIK="^BAREDI(""I"",XBA,",DA=XBB,DUZ(2)=XBA=XBA D ^DIK,^XBFMK + S ^XTMP("SAN","PROCESS","AR-EDIIMP")="FINISHED" + S XBA=0 F S XBA=$O(^BAREDI("C",XBA)) Q:+XBA=0 D + .S XBB=0 F S XBB=$O(^BAREDI("C",XBA,XBB)) Q:+XBB=0 D + ..I $P($G(^BAREDI("C",XBA,XBB,0)),U,3)]"" S DIE="^BAREDI(""C"",XBA,XBB,",DA=XBB,DUZ(2)=XBA,DR=".03///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","BAREDI03",DA)="" D ^XBFMK + S ^XTMP("SAN","PROCESS","AR-EDIC")="FINISHED" + S XBA=0 F S XBB=$O(^BAR835(XBA)) Q:+XBA=0 D + .I $P($G(^BAR835(XBA,1)),U,1)]"" S DIE="^BAR835,",DA=XBA,DR=".11///@" D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","AR11",DA)="" D ^XBFMK + S ^XTMP("SAN","PROCESS","AR-EDI835")="FINISHED" + Q +TPB ;3RD PARTY BILLING + D ^XBFMK + S U="^",XBA=0 F S XBA=$O(^ABMDCLM(XBA)) Q:+XBA=0 D + .S XBB=0 F S XBB=$O(^ABMDCLM(XBA,XBB)) Q:+XBB=0 D + ..I $L($P($G(^ABMDCLM(XBA,XBB,8)),U,8)) D + ...S X=^XTMP("SAN",$J,"DLAST") D R S XBLAST=^XTMP("SAN",$J,"DLAST",X) + ...S X=^XTMP("SAN",$J,"DFIRST") D R S XBFIRST=^XTMP("SAN",$J,"DFIRST",X) + ...S DA=XBB,DIE="9002274.3",DUZ(2)=XBA,DR=".88///"_XBLAST_","_XBFIRST D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","ABM88",DA)="" D ^XBFMK + ..I $L($P($G(^ABMDCLM(XBA,XBB,8)),U,11)) D + ...S DA=XBB,DIE="9002274.3",DUZ(2)=XBA,DR=".885///"_(100000+DA) D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","ABM885",DA)="" D ^XBFMK + ..I $L($P($G(^ABMDCLM(XBA,XBB,9)),U,12)) D + ...S X=^XTMP("SAN",$J,"DLAST") D R S XBLAST=^XTMP("SAN",$J,"DLAST",X) + ...S X=^XTMP("SAN",$J,"DFIRST") D R S XBFIRST=^XTMP("SAN",$J,"DFIRST",X) + ...S DA=XBB,DIE="9002274.3",DUZ(2)=XBA,DR=".912///"_XBLAST_","_XBFIRST D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","ABM912",DA)="" D ^XBFMK + S ^XTMP("SAN","PROCESS","3P-CLAIM")="FINISHED" + S XBA=0 F S XBA=$O(^ABMDBILL(XBA)) Q:+XBA=0 D + .S XBB=0 F S XBB=$O(^ABMDBILL(XBA,XBB)) Q:+XBB=0 D + ..I $L($P($G(^ABMDBILL(XBA,XBB,8)),U,8)) D + ...S X=^XTMP("SAN",$J,"DLAST") D R S XBLAST=^XTMP("SAN",$J,"DLAST",X) + ...S X=^XTMP("SAN",$J,"DFIRST") D R S XBFIRST=^XTMP("SAN",$J,"DFIRST",X) + ...S DA=XBB,DIE="9002274.4",DUZ(2)=XBA,DR=".88///"_XBLAST_","_XBFIRST D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","ABM88",DA)="" D ^XBFMK + ..I $L($P($G(^ABMDBILL(XBA,XBB,8)),U,11)) D + ...S DA=XBB,DIE="9002274.4",DUZ(2)=XBA,DR=".885///"_(200000+DA) D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","ABM885",DA)="" D ^XBFMK + ..I $L($P($G(^ABMDBILL(XBA,XBB,9)),U,12)) D + ...S X=^XTMP("SAN",$J,"DLAST") D R S XBLAST=^XTMP("SAN",$J,"DLAST",X) + ...S X=^XTMP("SAN",$J,"DFIRST") D R S XBFIRST=^XTMP("SAN",$J,"DFIRST",X) + ...S DA=XBB,DIE="9002274.4",DUZ(2)=XBA,DR=".912///"_XBLAST_","_XBFIRST D ^DIE S:$D(Y) ^XTMP("SAN","FAILURE","ABM912",DA)="" D ^XBFMK + S ^XTMP("SAN","PROCESS","3P-BILL")="FINISHED" + Q +LAB ; + S X=0 F S X=$O(^LR(X)) Q:X'=+X D + .S Y=0 F S Y=$O(^LR(X,"CH",Y)) Q:Y'=+Y D + ..I $D(^LR(X,"CH",Y,1)) S Z=$P(^LR(X,"CH",Y,1,0),U,1,2) K ^LR(X,"CH",Y,1) S ^LR(X,"CH",Y,1,0)=Z + .S Y=0 F S Y=$O(^LR(X,"MI",Y)) Q:Y'=+Y D + ..I $D(^LR(X,"MI",Y,4)) S Z=$P(^LR(X,"MI",Y,4,0),U,1,2) K ^LR(X,"MI",Y,4) S ^LR(X,"MI",Y,4,0)=Z + ..I $D(^LR(X,"MI",Y,19)) S Z=$P(^LR(X,"MI",Y,19,0),U,1,2) K ^LR(X,"MI",Y,19) S ^LR(X,"MI",Y,19,0)=Z + ..I $D(^LR(X,"MI",Y,20)) S Z=$P(^LR(X,"MI",Y,20,0),U,1,2) K ^LR(X,"MI",Y,20) S ^LR(X,"MI",Y,20,0)=Z + ..I $D(^LR(X,"MI",Y,21)) S Z=$P(^LR(X,"MI",Y,21,0),U,1,2) K ^LR(X,"MI",Y,21) S ^LR(X,"MI",Y,21,0)=Z + ..I $D(^LR(X,"MI",Y,22)) S Z=$P(^LR(X,"MI",Y,22,0),U,1,2) K ^LR(X,"MI",Y,22) S ^LR(X,"MI",Y,22,0)=Z + ..I $D(^LR(X,"MI",Y,23)) S Z=$P(^LR(X,"MI",Y,23,0),U,1,2) K ^LR(X,"MI",Y,23) S ^LR(X,"MI",Y,23,0)=Z + ..K ^LR(X,"MI",Y,99) + S X=0 F S X=$O(^LRO(69,X)) Q:X'=+X D + .I $D(^LRO(69,X,1,"AL")) K ^LRO(69,X,1,"AL") + .I $D(^LRO(69,X,1,"AP")) K ^LRO(69,X,1,"AP") + .I $D(^LRO(69,X,1,"AR")) K ^LRO(69,X,1,"AR") + S X=$P(^BLRTXLOG(0),U,1,2) K ^BLRTXLOG S ^BLRTXLOG(0)=X + S ^XTMP("SAN","PROCESS","LAB")="FINISHED" + D ^LROC + Q +LISTE ; + W !,"Listed below are the nodes and number of records that did not" + W !,"update properly. At the end of the sanitization, the records" + W !,"for Patient Name failures are rerun. PATNAME2 nodes represent" + W !,"Patient Names that should be manually changed with fileman." + W !,"XTMP(""SAN"",""PROCESS"") nodes:" + W !,"XTMP(""SAN"",""FAILURE"") nodes:" + S X="" F S X=$O(^XTMP("SAN","FAILURE",X)) Q:X="" D + .S (Y,Z)=0 F S Y=$O(^XTMP("SAN","FAILURE",X,Y)) Q:+Y=0 D + ..S Z=Z+1 + .W !,"Failure: "_X_" "_Z + W !,"FINISHED" Q +LISTD ; + W !,"Listed below are the processes completed." + W !,"XTMP(""SAN"",""PROCESS"") nodes:" + S X="" F S X=$O(^XTMP("SAN","PROCESS",X)) Q:X="" D + .W !,"Process: "_X + W !,"FINISHED" Q +MCDE ; + S DFN=0 F S DFN=$O(^AUPNMCD("B",DFN)) Q:+DFN=0 D + .S XBMDFN=0 F S XBMDFN=$O(^AUPNMCD("B",DFN,XBMDFN)) Q:XBMDFN'=+XBMDFN D + ..S X=^XTMP("SAN",$J,"DLAST") D R S XBDLAST=^XTMP("SAN",$J,"DLAST",X) + ..S X=^XTMP("SAN",$J,"DFIRST") D R S XBDFIRST=^XTMP("SAN",$J,"DFIRST",X) + ..S DIE="^AUPNMCD(",DA=XBMDFN,DR=".05///@;.12///@;.13///@" D ^DIE + ..I $D(Y) S ^XTMP("SAN","FAILURE","PATMCDEA",DA)="" + ..D ^XBFMK + ..S XBDNAME=XBDLAST_","_XBDFIRST + ..D SSNR + ..S DIE="^AUPNMCD(",DA=XBMDFN,DR=".03///"_XBSSN_";.14///"_XBDNAME_";2101///"_$P(^DPT(DFN,0),U,1)_";2102///"_$P(^DPT(DFN,0),U,3)_";.05///"_$P(^DPT(DFN,0),U,1) D ^DIE + ..I $D(Y) S ^XTMP("SAN","FAILURE","PATMCDEB",DA)="" + ..D ^XBFMK + S ^XTMP("SAN","PROCESS","MCD")="FINISHED" + Q +MMDEL ;DELETES MAILMAN MESSAGES + K ^XMB(3.9) + S ^XMB(3.9,0)="MESSAGE^3.9s^0^0" + Q +AUDEL ;DELETES AUDIT FILE + K ^DIA + S ^DIA(0)="AUDIT^1.1|" + Q +NCDEL ;DELETES NAME COMPONENTS FILE + K ^VA(20) + S ^VA(20,0)="NAME COMPONENTS^20IA^^" + Q +STU ;SETS STUDENT NAMES + K ^XTMP("SAN","FAILURE","STU") + K ^XTMP("SAN","FAILURE","STUA") +STUA D ^XBFMK + S XBX=50 F S XBX=$O(^VA(200,XBX)) Q:+XBX>76 D + .S XBLAST=$E("ABCDEFGHIJKLMNOPQRSTUVWXYZ",XBX-50,XBX-50)_"STUDENT" + .S XBFIRST="USER" + .S DA=XBX,DIE=200,DR=".01///"_XBLAST_","_XBFIRST D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","STU",XBX)="" + .S DA=XBX,DIE=200,DR="1///"_$E(XBLAST,1,2)_"U;13///"_$E(XBLAST,1,8) D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","STUINITIALS",XBX)="" + .S DA=XBX,DIE=200,DR="201///`29" D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","STUMENU",XBX)="" + .D ^XBFMK + W !,"FINISHED" + Q +FJADD1 ; + S DFN=0 F S DFN=$O(^XTMP("SAN","FAILURE","PATADDRESS",DFN)) Q:+DFN=0 I $P($G(^DPT(DFN,.11)),U,1)]"" D + .S XBADDR=DFN_" SMITH STREET" + .S DIE="^DPT(",DR=".111///"_XBADDR,DA=DFN D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATADDRESSFJ",DFN)="" + .D ^XBFMK + .S $P(^DPT(DFN,.11),U,2)="" ;addr 2nd line + .S $P(^DPT(DFN,.11),U,3)="" ;addr 3rd line + Q +A2213 ; + I $P($G(^DPT(DFN,.21)),U,3)]"" D + .S X=^XTMP("SAN",$J,"ADL1") D R S XBADDR=^XTMP("SAN",$J,"ADL1",X) + .S DIE="^DPT(",DR=".213///"_XBADDR,DA=DFN D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATADDRESSL11",DFN)="" + .D ^XBFMK + I $P($G(^DPT(DFN,.33)),U,3)]"" D + .S X=^XTMP("SAN",$J,"ADL1") D R S XBADDR=^XTMP("SAN",$J,"ADL1",X) + .S DIE="^DPT(",DR=".333.//"_XBADDR,DA=DFN D ^DIE + .I $D(Y) S ^XTMP("SAN","FAILURE","PATADDRESSL111",DFN)="" + .D ^XBFMK + Q +A2219 ;nok phone + S DFN=0 F S DFN=$O(^XTMP("SAN","FAILURE","PATPHONE",DFN)) Q:+DFN=0 I $P($G(^DPT(DFN,.21)),U,9)]"" D + .S $P(^DPT(DFN,.21),U,9)="555-888-"_$E(DFN_"9999",1,4) + Q + S DFN=0 F S DFN=$O(^XTMP("SAN","FAILURE","PATPHONE1",DFN)) Q:+DFN=0 I $P($G(^DPT(DFN,.33)),U,9)]"" D + .S $P(^DPT(DFN,.33),U,9)="555-888-"_$E(DFN_"9999",1,4) + Q diff --git a/XBSANU.m b/XBSANU.m new file mode 100644 index 0000000..db8d71f --- /dev/null +++ b/XBSANU.m @@ -0,0 +1,161 @@ +XBSANU ;IHS/ITSC/LAB/FJE;SANITIZE RPMS DATABASE; [ 01/29/2005 11:10 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + W !,"This routine sanitizes and deletes RPMS New Person file data. To use you must type: D START^XBSANU" + W !,"For help and an explanation of this utility type D HELP^XBSANU",!! + Q +START ; + S (XBDUZ,XBDEL,XBPAT,XBPHR,XBBH,XBCHR,XBPOS,XB3PB,XBAR,XBLAB,XBMMDEL,XBAUDEL,XBNCDEL)=0 + K ^XTMP("SAN") + S ^XTMP("SAN","LASTDFN")=0 + W !,"This routine will sanitize AND randomize the NEW PERSON file in the RPMS database." + S DIR(0)="Y",DIR("A")="Do you want to convert the new person data?",DIR("B")="N" KILL DA D ^DIR KILL DIR + S:Y=1 XBDUZ=1 + W !,"All failed fileman update data can be found in: ^XTMP(""SAN"",""DUZFAILURE"", GLOBAL" + W !,"?? display usually means that there was a fileman update failure" + W !,"If a hard error like an UNDEFINED occurs during the scrambling," + W !," you can restart at the next patient by typing: RESTART^XBSANU " + W !,"When finished...don't forget to manually address the failures" + W !,"D LIST^XBSANU will list the errors",!! + W !!,"This routine is about to scramble the RPMS database." + S DIR(0)="Y",DIR("A")="Last chance: Do you want your RPMS NEW PERSON file data SANITIZED?",DIR("B")="N" KILL DA D ^DIR KILL DIR + Q:Y'=1 + D ^XBKVAR + W !,"Collecting random names" D CLEAN +FJE ; + I XBDUZ W !,"SCRAMBLING FILE 200" D DUZ + S ^XTMP("SAN","DUZPROCESS","XBSAN")="FINISHED" + W !,"FINISHED" + D LIST + D EOJ + Q + ; +EOJ ; + D EN^XBVK("XB") + K DFN,XBH,OTDFN,XBB,AUPNSEX,X,X2,XB3PB,XBAR,XBAUDEL + K DA,DIE,DIK,DIR,DR,XBDUZSSN,I,XBA,XBADDR,XBADL1 + K XBBH,XBC,XBCHART,XBCHR,XBD,XBDAD,XBDEANUM,XBDEL,XBDFIRST,XBDLAST,XBDNAME + K XBDOB,XBDUZ,XBFIRST,XBFNAME,XBH,XBLAB,XBLNAME,XBMDFN,XBMMDEL,XBMOM + K XBNAME,XBNCDEL,XBNOK,XBNOKADL,XBP,XBPAT,XBPHN,XBPHR,XBPOS,XBS + K XBSCR,XBSEX,XBSSN,XBTEN,XBVAL,XBVANUM,XBX,Y,Z + W !,"If all data appears correct and you have chaecked failures, kill the ^XTMP(""SAN"") global",!! + Q + ; +CLEAN ; + K ^XTMP("SAN","DLAST") + K ^XTMP("SAN","DFIRST") + K ^XTMP("SAN","PROCESS","DUZ") + K ^XTMP("SAN","DUZFAILURE") + D ^XBKVAR + S (XBC(1),XBC(2))=0,XBX=1 F S XBX=$O(^VA(200,XBX)) Q:+XBX=0 D + .S XBNAME=$P($G(^VA(200,XBX,0)),U,1) + .S XBLAST=$P(XBNAME,",",1) S:'$L(XBLAST) XBLAST="MOUSE" S:$L(XBLAST)<3 XBLAST=XBLAST_"AAA" + .S XBFIRST=$P(XBNAME,",",2) S:'$L(XBFIRST) XBFIRST="MICKEY"_+XBX + .S XBC(1)=XBC(1)+1,^XTMP("SAN","DLAST")=XBC(1),^XTMP("SAN","DLAST",XBC(1))=XBLAST + .S XBC(2)=XBC(2)+1,^XTMP("SAN","DFIRST")=XBC(2),^XTMP("SAN","DFIRST",XBC(2))=XBFIRST + Q +R S X2=$R(X) I X2=0 G R + S X=X2 + Q + ; +DUZ ;SCRAMBLES USER NAMES + D ^XBFMK + I '$D(^XTMP("SAN","LASTDUZ")) S ^XTMP("SAN","LASTDUZ")=1 + S XBX=+^XTMP("SAN","LASTDUZ") + F S XBX=$O(^VA(200,XBX)) Q:+XBX=0 D + .S DA=XBX,DIE=200,DR="53.2///@" D ^DIE I $D(Y) S ^XTMP("SAN","DUZFAILURE","DUZDEA",XBX)="" + .D ^XBFMK +RESTART ;RESTARTS IF HARD FAILURE WITH DUZ (COMMON BECAUSE OF 3,6,16 PROBLEMS) + S XBX=+^XTMP("SAN","LASTDUZ") + F S XBX=$O(^VA(200,XBX)) Q:+XBX=0 D + .S ^XTMP("SAN","LASTDUZ")=XBX + .S X=^XTMP("SAN","DLAST") D R S XBLAST=^XTMP("SAN","DLAST",X) + .S X=^XTMP("SAN","DFIRST") D R S XBFIRST=^XTMP("SAN","DFIRST",X) + .D DUZSSN + .I XBDUZSSN S DA=XBX,DIE=200,DR=".01///"_XBLAST_","_XBFIRST_";9///"_XBDUZSSN D ^DIE I $D(Y) S ^XTMP("SAN","DUZFAILURE","DUZ IEN FAILURE",XBX)="" + .I 'XBDUZSSN S DA=XBX,DIE=200,DR=".01///"_XBLAST_","_XBFIRST D ^DIE I $D(Y) S ^XTMP("SAN","DUZFAILURE","DUZ IEN FAILURE",XBX)="" + .S DA=XBX,DIE=200,DR="1///"_$E(XBLAST,1,3)_";13///"_$E(XBLAST,1,8) D ^DIE I $D(Y) S ^XTMP("SAN","DUZFAILURE","DUZINITIALS",XBX)="" + .S XBVANUM=1000000+XBX + .S XBDEANUM=200000+XBX + .S XBDEAIL=$E(XBLAST,1) + .S XBDEAN=$E(XBDEANUM,1)+$E(XBDEANUM,3)+$E(XBDEANUM,5)+(2*($E(XBDEANUM,2)+$E(XBDEANUM,4)+$E(XBDEANUM,6))) + .S XBDEAN=XBDEAN#10 + .S XBDEA="A"_XBDEAIL_XBDEANUM_XBDEAN + .S DA=XBX,DIE=200,DR="53.2///"_XBDEA D ^DIE I $D(Y) S ^XTMP("SAN","DUZFAILURE","DUZDEA",XBX)="" + .D ^XBFMK + .S DA=XBX,DIE=200,DR="53.3///"_XBVANUM D ^DIE I $D(Y) S ^XTMP("SAN","DUZFAILURE","DUZVA",XBX)="" + .D ^XBFMK + S ^XTMP("SAN","DUZPROCESS","DUZ")="FINISHED" + Q +DUZSSN ;CHANGES SSN FOR USER FILE + S XBDUZSSN=$P($G(^VA(200,XBX,1)),"^",9) + I XBDUZSSN D DUZSSNR S XBDUZSSN=XBSSN + Q +DUZSSNR ;FIND RANDOM SSN + F S XBSSN=$R(999999999) Q:XBSSN>100000000&(XBSSN<800000000) + I $D(^VA(200,"SSN",XBSSN)) G DUZSSNR + Q +ALLSSN ;ADDS SSN TO EVERY DUZ + D ^XBFMK + S XBX=0 F S XBX=$O(^VA(200,XBX)) Q:+XBX=0 D + .Q:$L($P($G(^VA(200,XBX,0)),"^",9)) + .D SSNR + .S DA=XBX,DIE=200,DR=".09///"_XBSSN D ^DIE K DIE,DA + .D ^XBFMK + S ^XTMP("SAN","DUZPROCESS","DUZ SSN-ALL")="FINISHED" + Q +SSNR ;FIND RANDOM SSN + F S XBSSN=$R(999999999) Q:XBSSN>100000000&(XBSSN<800000000) + I $D(^VA(200,"SSN",XBSSN)) G SSNR + Q + ; +LIST ; + W !,"Listed below are the nodes and number of records that did not" + W !,"update properly." + W !,"XTMP(""SAN"",""DUZFAILURE"") nodes:" + S X="" F S X=$O(^XTMP("SAN","DUZFAILURE",X)) Q:X="" D + .S (Y,Z)=0 F S Y=$O(^XTMP("SAN","DUZFAILURE",X,Y)) Q:+Y=0 D + ..S Z=Z+1 + .W !,"Failure: "_X_" "_Z + W !,"FINISHED" +LISTD ; + W !,"Listed below are the processes completed." + W !,"XTMP(""SAN"",""PROCESS"") nodes:" + S X="" F S X=$O(^XTMP("SAN","PROCESS",X)) Q:X="" D + .W !,"Process: "_X + W !,"FINISHED" Q +STU ;SETS STUDENT NAMES + K ^XTMP("SAN","DUZFAILURE","STU") + K ^XTMP("SAN","DUZFAILURE","STUA") +STUA D ^XBFMK + S XBX=50 F S XBX=$O(^VA(200,XBX)) Q:+XBX>76 D + .S XBLAST=$E("ABCDEFGHIJKLMNOPQRSTUVWXYZ",XBX-50,XBX-50)_"STUDENT" + .S XBFIRST="USER" + .S DA=XBX,DIE=200,DR=".01///"_XBLAST_","_XBFIRST D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","STU",XBX)="" + .S DA=XBX,DIE=200,DR="1///"_$E(XBLAST,1,2)_"U;13///"_$E(XBLAST,1,8) D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","STUINITIALS",XBX)="" + .S DA=XBX,DIE=200,DR="201///`29" D ^DIE I $D(Y) S ^XTMP("SAN","FAILURE","STUMENU",XBX)="" + .D ^XBFMK + W !,"FINISHED" + Q +HELP ; + W !,"Notes for sanitizing file 200." + W !,"START^XBSANU will start the sanitizing. The last names and first names" + W !,"of file 200 are captured and then randomly combined to form a new name" + W !,"If the user has a SSN regestered then that number is also ramdomized." + W !,"The internal entry is added to 1000000 to create the VA number and" + W !,"2000000 is added to make the DEA number" + W !,"The first three letters of the last name make up the initials and" + W !,"the first eight characters of the last name make up the nick name." + W !,"To fix hard errors you should look at the following:" + W !,"File 200 (^VA(200,IEN,0)) piece 16 points to file 16 (^DIC(16)). If" + W !,"^DIC(16,pointer,0) does not exist, you will get a hard error. File 16" + W !,"and file 6 (^DIC(6)) are generally dinumed and in file 16 the " + W !,"^DIC(16,pointer,""A6"" and ""A3"" point to file 6 and 3 (^DIC(3))" + W !,"respectfully. If either is missing you will get an error. File 3's IEN" + W !,"generally is dinumed to file 200.",!! + W !,"You can run this utility over and over without problems. The result is" + W !,"randomized again. User IEN 1 remains as ADAM,ADAM and is unchanged" + W !,"LIST^XBSANU will list the errors found" + W !,"ALLSSN^XBSANU will add a random SSN to all file 200 users" + W !,"STU^XBSANU will create 26 student accounts starting with ASTUDENT,USER" + W !,"and ending with ZSTUDENT,USER for IENS 51-76." + Q diff --git a/XBSAUD.m b/XBSAUD.m new file mode 100644 index 0000000..95305ca --- /dev/null +++ b/XBSAUD.m @@ -0,0 +1,30 @@ +XBSAUD ; IHS/ADC/GTH - SET AUDIT AT FILE LEVEL ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; This routine sets 'audit' on at the file level for + ; selected files + ; +START ; + W !!,"^XBSAUD - This routine sets 'audit' at the file level." + D ^XBDSET + Q:'$D(^UTILITY("XBDSET",$J)) + NEW F,G,P + S Y=$$DIR^XBDIR("S^1:ON;2:OFF","Set 'audit' ON or OFF?","ON") + Q:$D(DUOUT)!$D(DTOUT) + S Y=Y-1 + W ! + F F=0:0 S F=$O(^UTILITY("XBDSET",$J,F)) Q:F'=+F D + . S G=^DIC(F,0,"GL") + . S P=$P(@(G_"0)"),"^",2) + . I Y S P=$P(P,"a",1)_$P(P,"a",2) I 1 + . E S P=P_$S(P'["a":"a",1:"") + . S $P(@(G_"0)"),"^",2)=P + . W !,F," set ",$S(Y:"off",1:"on") + .Q + D EOJ + Q + ; +EOJ ; + KILL X,Y,^UTILITY("XBDSET",$J) + Q + ; diff --git a/XBSAUTH.m b/XBSAUTH.m new file mode 100644 index 0000000..409ddbe --- /dev/null +++ b/XBSAUTH.m @@ -0,0 +1,75 @@ +XBSAUTH ; IHS/ADC/GTH - SET AUTHORITIES ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; This routine sets FileMan dictionary authorities: + ; "AUDIT" "DD" "DEL" "LAYGO" "RD" "WR" + ; +START ; + I $G(DUZ(0))'="@" W !,*7," Insufficient FileMan access. DUZ(0) is not ""@""." Q + S U="^",IOP=$I + D ^%ZIS + W !!,"^XBSAUTH - This program sets FileMan dictionary authorities." + D ^XBDSET + Q:'$D(^UTILITY("XBDSET",$J)) +ASK ; + W !!,"Do you want to be asked before setting each file? (Y/N) Y// " + R XBSAASK:$G(DTIME,999) + S:XBSAASK="" XBSAASK="Y" + S XBSAASK=$E(XBSAASK) + I "YyNn"'[XBSAASK W *7 G ASK + S XBSAASK=$S("Yy"[XBSAASK:1,1:0) + W !!,"To delete a particular authority enter '@@'",! + S XBSAF=0 + KILL XBSA + F XBSAX="AUDIT","DD","DEL","LAYGO","RD","WR" D GETAUTH + I 'XBSAF W !!,"Bye" Q + W !!,"I am going to set the following authorities:",! + F XBSAX="AUDIT","DD","DEL","LAYGO","RD","WR" D:@("XBSA("""_XBSAX_""")")'="" PRTAUTH +ASK2 ; + W !!,"Do you want to continue? (Y/N) N// " + R XBSAX:$G(DTIME,999) + S:XBSAX="" XBSAX="N" + S XBSAX=$E(XBSAX) + I "YyNn"'[XBSAX W *7 G ASK2 + G:"Yy"'[XBSAX EOJ + W ! + S XBSAFILE="" + F XBSAL=0:0 S XBSAFILE=$O(^UTILITY("XBDSET",$J,XBSAFILE)) Q:XBSAFILE="" D PROCESS + G EOJ + ; +GETAUTH ; GET DICTIONARY AUTHORITIES + W !,"Enter ",XBSAX," authority: " + R @("XBSA("""_XBSAX_""")") + S:@("XBSA("""_XBSAX_""")")'="" XBSAF=1 + Q + ; +PRTAUTH ; PRINT DICTIONARY AUTHORITIES + W !,XBSAX,?6," to """,@("XBSA("""_XBSAX_""")"),"""" + Q + ; +PROCESS ; + S XBSAANS="Y" + W !,@("$P(^DIC("_XBSAFILE_",0),U,1)") + I XBSAASK W !?4,"Current authorities are: " D W "..OK? Y// " + . F XBSAX="AUDIT","DD","DEL","LAYGO","RD","WR" I $D(@("^DIC("_XBSAFILE_",0,"""_XBSAX_""")")),@("^("""_XBSAX_""")")'="" W ?31,XBSAX,?38,@("^("""_XBSAX_""")"),! + . Q +P2 ; + I XBSAASK R XBSAANS:$G(DTIME,999) S:XBSAANS="" XBSAANS="Y" S XBSAANS=$E(XBSAANS) I "YyNn"'[XBSAANS D P2ERR G P2 + I "Yy"[XBSAANS D P2SETS Q + W " Skipping" + Q + ; +P2SETS ; + NEW X + F X="AUDIT","DD","DEL","LAYGO","RD","WR" S:XBSA(X)]"" @("^DIC("_XBSAFILE_",0,"""_X_""")")=XBSA(X) KILL:XBSA(X)="@@" @("^DIC("_XBSAFILE_",0,"""_X_""")") + Q + ; +P2ERR ; + W *7 + F %=1:1:$L(XBSAANS) W @IOBS," ",@IOBS + Q + ; +EOJ ; + KILL ^UTILITY("XBDSET",$J),XBSA,XBSAANS,XBSAASK,XBSAF,XBSAFILE,XBSAI,XBSAL,XBSAX + Q + ; diff --git a/XBSDDAUD.m b/XBSDDAUD.m new file mode 100644 index 0000000..6694de8 --- /dev/null +++ b/XBSDDAUD.m @@ -0,0 +1,57 @@ +XBSDDAUD ;IHS/SET/GTH - SET DICTIONARY AUDIT(S) ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;IHS/SET/GTH XB*3*9 10/29/2002 New Routine. + ; This routine allows you to toggle the dictionary (dd) audit + ; flag for selected files. The global location for dictionary + ; audit is: ^DD(FILE,0,"DDA") + ; If the valuey is "Y", dd audit is on. Any other value, or the + ; absence of the node, means dd audit is off. + ; +START ; + W !!,"^XBSDDAUD - This routine toggles the data dictionary audit flag(s)." + D ^XBDSET + Q:'$D(^UTILITY("XBDSET",$J)) + D DEV + Q:POP + D DISP + Q:'$$DIR^XBDIR("Y","Proceed to toggling dd audit for file(s)","N") + D SET + KILL X,Y,^UTILITY("XBDSET",$J) + Q + ; +DISP ; Display current dd audit values for file(s). + NEW F,G,P + W !,"File #",?15,"File Name",?50,"Global",?65,"dd Audit On/Off" + F F=0:0 S F=$O(^UTILITY("XBDSET",$J,F)) Q:F'=+F D + . S G=$G(^DIC(F,0,"GL")) + . S P=$G(^DD(F,0,"DDA")) + . W !,F,?15,$$FNAME^XBFUNC(F),?50,G,?65,$S(P="Y":"on",1:"off") + .Q + ; + Q + ; +DEV ; Select device for report. + W ! + S %=$$PB + I %=U!$D(DTOUT)!$D(DUOUT) Q + I %="B" D VIEWR^XBLM("DISP^XBSDDAUD"),EN^XBVK("VALM") Q + D ^%ZIS + Q + ; +PB() ; + Q $$DIR^XBDIR("SO^P:PRINT Output;B:BROWSE Output on Screen","Do you want to ","PRINT","","","",2) + ; +SET ; Set DDA for the file(s). + NEW F,G,P,Y + S Y=$$DIR^XBDIR("S^1:ON;2:OFF","Set 'dd audit' ON or OFF?","OFF") + Q:$D(DUOUT)!$D(DTOUT) + S Y=$S(Y=1:"Y",1:"") + W ! + F F=0:0 S F=$O(^UTILITY("XBDSET",$J,F)) Q:F'=+F D + . Q:'$D(^DD(F)) + . S ^DD(F,0,"DDA")=Y + . W !,F," set ",$S(Y="Y":"on",1:"off") + .Q + ; + Q + ; diff --git a/XBSFGBL.m b/XBSFGBL.m new file mode 100644 index 0000000..a3b7df0 --- /dev/null +++ b/XBSFGBL.m @@ -0,0 +1,70 @@ +XBSFGBL(S,G,F) ; IHS/ADC/GTH - RETURN SUBFILE GLOBAL REFERENCE ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; 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 + ;-------------------- diff --git a/XBSIC.m b/XBSIC.m new file mode 100644 index 0000000..41b56bf --- /dev/null +++ b/XBSIC.m @@ -0,0 +1,146 @@ +XBSIC ;IHS/SET/GTH - LIST ID,SP,FD NODES ON SELECTED FILES ; [ 12/05/2002 4:28 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;IHS/SET/GTH XB*3*9 10/29/2002 New Routine. + ; This routine lists the IDENTIFIERS, SPECIFIERS, and + ; CONDITIONALS from selected files. + ; + ; Thanks to E. Don Enos for the original routine in Sep 1997. + ; +START ; + D INIT + Q:XBQFLG + D DBQUE + Q + ; +INIT ; INITIALIZATION + D EN^XBVK("XB") + S (XBBT)=$H,XBJOB=$J + S XBQFLG=1 + I '$G(DUZ(2)) W !!,"Your DUZ(2) is not set!",!! Q + I '$G(^AUTTLOC(DUZ(2),0)) W !!,"The site specified in your DUZ(2) does not exist!",!! Q + KILL ^XTMP("XBSIC",XBJOB) + D ^XBKVAR + D ^XBDSET ; get files to check + I '$O(^UTILITY("XBDSET",XBJOB,0)) Q ; quit if no files selected + S XBQFLG=0 + Q + ; +DBQUE ; call to XBDBQUE + W ! + S DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen",DIR("A")="Do you wish to",DIR("B")="P" + KILL DA + D ^DIR + KILL DIR + Q:$D(DIRUT) + I Y="B" D BROWSE Q + S XBRP="LIST^XBSIC",XBRC="FILES^XBSIC",XBRX="EOJ^XBSIC",XBNS="XB" + D ^XBDBQUE + Q + ; +BROWSE ; + S XBRP="VIEWR^XBLM(""LIST^XBSIC"")" + S XBRC="FILES^XBSIC",XBRX="EOJ^XBSIC",XBIOP=0 + D ^XBDBQUE + Q + ; +FILES ; PROCESS ALL FILES + S XBFILE=0 + F S XBFILE=$O(^UTILITY("XBDSET",XBJOB,XBFILE)) Q:'XBFILE D FILE(XBFILE) Q:XBQFLG + Q + ; +FILE(XBFILE) ; PROCESS ONE FILE (CALLED RECURSIVELY) + NEW L,V,W,X,Y + I '$D(ZTQUEUED),'$D(IO("S")),$E(IOST,1,2)="C-" W "." + S ^XTMP("XBSIC",XBJOB,XBFILE,"!")="" ; file marker + F X="FD","ID","SP" D + . I '$D(^DD(XBFILE,0,X)) Q ; quit if no node + . I X="ID",'$O(^DD(XBFILE,0,X,0)) Q ; quit if no real identifier + . S Y=0 + . F S Y=$O(^DD(XBFILE,0,X,Y)) Q:Y="" I Y D + .. S V=$G(^DD(XBFILE,0,X,Y)) ; get value & set $ZR + .. I X="SP" S W=$S(V'="":"="_V,1:"") D SET Q + .. I X="ID" S W="" D SET Q + .. S L="" + .. F S L=$O(^DD(XBFILE,0,X,Y,L)) Q:L="" D + ... S V=$G(^DD(XBFILE,0,X,Y,L)) ; get value & set $ZR + ... S W="="_V D SET + ... Q + .. Q + . Q + ;I $P($G(^DD(XBFILE,.01,0)),U,2)["P" S X=^(0) D RECURSE ;ptr chain + I $P($G(^DD(XBFILE,.01,0)),U,2)["P" S X=^(0) I '(XBFILE=+$P($P(X,U,2),"P",2)) D FILE(+$P($P(X,U,2),"P",2)) + Q + Q:$G(RECURSE) ; quit if recursing + S XBFLD=.01 + F S XBFLD=$O(^DD(XBFILE,XBFLD)) Q:'XBFLD I $D(^(XBFLD,0)) S X=^(0) D + . Q:$P(X,U,2)'["P" ; quit if not pointer + . D RECURSE + . Q + Q + ; +SET ; SET ONE LINE + S ^XTMP("XBSIC",XBJOB,XBFILE,$$LGR^%ZOSV_W)="" + Q + ; +RECURSE ; RECURSE FOR FILES BEING POINTED TO + Q:XBFILE=+$P($P(X,U,2),"P",2) ; quit if self reference + NEW XBFILE,RECURSE + S RECURSE=1 + S XBFILE=+$P($P(X,U,2),"P",2) + D FILE + Q + ; +LIST ; LIST OUTPUT + U IO + D HEAD + S XBFILE=0 + F S XBFILE=$O(^XTMP("XBSIC",XBJOB,XBFILE)) Q:'XBFILE D Q:XBQFLG + . D F Q:XBQFLG + . W !,?4,XBFILE_" ("_$P($G(^DIC(XBFILE,0)),U)_")",! + . S XBDEV="" + . F S XBDEV=$O(^XTMP("XBSIC",XBJOB,XBFILE,XBDEV)) Q:XBDEV="" D WRITE Q:XBQFLG + . Q + Q + ; +WRITE ; WRITE ONE LINE + Q:XBDEV="!" ; quit if file marker + D F + Q:XBQFLG + W XBDEV,! + Q + ; +F ;Form feed + I ($Y+4)>IOSL D + . I '$D(ZTQUEUED),'$D(IO("S")),$E(IOST,1,2)'="P-" D PAUSE S:$D(DIRUT) XBQFLG=1 + . Q:XBQFLG + . W @IOF + . D HEAD + . Q + Q + ; +PAUSE ; PAUSE FOR USER + Q:$E(IOST)'="C" + Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S")) + S DIR(0)="E",DIR("A")="Press any key to continue" + KILL DIRUT + D ^DIR + KILL DIR + Q + ; +HEAD ; WRITE HEADER + I '$D(ZTQUEUED),'$D(IO("S")),$E(IOST,1,2)="C-" W @IOF + S XBPG=$G(XBPG)+1 + W " ID/SP/FD REPORT run at ",$P(^AUTTLOC(DUZ(2),0),U,2)," on ",$$FMTE^XLFDT(DT),?75,$J(XBPG,5),! + W $$REPEAT^XLFSTR("=",80),! + Q + ; +Q Q + ; +EOJ ; + S XBET=$H,XBTS=(86400*($P(XBET,",")-$P(XBBT,",")))+($P(XBET,",",2)-$P(XBBT,",",2)),XBH=+$P(XBTS/3600,"."),XBTS=XBTS-(XBH*3600),XBM=+$P(XBTS/60,"."),XBTS=XBTS-(XBM*60),XBS=XBTS + W !!,"RUN TIME (H.M.S): "_XBH_"."_XBM_"."_XBS,! + KILL ^XTMP("XBSIC",XBJOB) + KILL ^UTILITY("XBDSET",XBJOB) + D EN^XBVK("XB") + Q + ; diff --git a/XBSITE.m b/XBSITE.m new file mode 100644 index 0000000..fd9c369 --- /dev/null +++ b/XBSITE.m @@ -0,0 +1,43 @@ +XBSITE ; IHS/ADC/GTH - SET "DUZ(2)" ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; +L1 ; + KILL DIC + G:$D(DUZ)=0!($D(DUZ)=10) ERRMSG + I ('$D(^DIC(3,DUZ,0))),('$D(^VA(200,DUZ,0))) G ERRMSG + I ('$D(^DIC(3,DUZ,2,0))),('$D(^VA(200,DUZ,2,0))) G ERRMSG1 + 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," + 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 - Request 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 + ; diff --git a/XBSUMBLD.m b/XBSUMBLD.m new file mode 100644 index 0000000..1e169b1 --- /dev/null +++ b/XBSUMBLD.m @@ -0,0 +1,68 @@ +XBSUMBLD ; IHS/ADC/GTH - ROUTINE INTEGRITY CHECK GENERATOR ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods. + ; + ; This routine requests the user to select a set of routines and + ; generates an integrity checking routine for the selected routines. + ; The user is asked to enter the name of the generated routine. + ; + ; The VA's equivalent routine is XTSUMBLD, which will also create + ; integrity checking routine(s). + ; +START ; + W !,"NOTE: The VA's equivalent routine is XTSUMBLD, which" + W !," will also create integrity checking routine(s).",!! + Q:'$$DIR^XBDIR("E") + NEW BYTE,COUNT,QUIT,RTDATE,RTN,RTNAME,VERSION + KILL ^UTILITY($J),^TMP("XBSUMBLD",$J) + D ^XBKVAR + X ^%ZOSF("RSEL") + I $O(^UTILITY($J,""))="" D EOJ Q + S RTNAME=$$DIR^XBDIR("F^5:8^K:X'?1U.U X","Enter name of routine to be generated: ","","","Example: APCDINTG") + I $D(DIRUT) D EOJ Q + D CHECKRTN + I 'Y D EOJ Q + S VERSION=" ;;"_$$DIR^XBDIR("F^1:5^K:'(X?1.2N!(X?1.2N1"".""1.2N)) X","Enter version number","","","Must be n or n.n where the length of n is 1-2") + I $D(DIRUT) D EOJ Q + S VERSION=VERSION_";"_$$DIR^XBDIR("FO^2:30","Enter package name") + I $D(DTOUT)!($D(DUOUT)) D EOJ Q + ; begin Y2K fix block + ;S Y=$$DIR^XBDIR("D","Enter date","TODAY") + S Y=$$DIR^XBDIR("D^::E","Enter date","TODAY") ;Y2000 + ; end Y2K fix block + I $D(DIRUT) D EOJ Q + D DD^%DT + S RTDATE=Y,VERSION=VERSION_";;"_Y + F %=1:1:11 S X=$P($T(@("LINE"_%)),";;",2,99),@("XBSUMBLD("_%_")=X") + F %=1:1:3 S X=$P($T(@("CODE"_%)),";;",2,99),@("XBSUMBLD(""CODE"_%_""")=X") + KILL %,X,Y + X XBSUMBLD(1) + Q + ; +CHECKRTN ; + S Y=1,X=RTNAME + X ^%ZOSF("TEST") + E Q + S Y=$$DIR^XBDIR("YO","Routine already exists. Want to recreate it","NO") + I $D(DIRUT) S Y=0 + Q + ; +EOJ ; + KILL %,DTOUT,DUOUT,DIRUT,DIROUT,X,XBSUMBLD,Y,^UTILITY($J) + Q + ;IHS/SET/GTH XB*3*9 10/29/2002 LINE2 mod'd seed of RTN from "" to 0. + ; The only good thing I can say about the following is that it works. +LINE1 ;;X XBSUMBLD(2),XBSUMBLD(6),XBSUMBLD(11) +LINE2 ;;S RTN=0 F S RTN=$O(^UTILITY($J,RTN)) Q:RTN="" W !,RTN ZL @RTN S (BYTE,COUNT)=0 S X=$T(+1),X=$P(X," [ ",1) X XBSUMBLD(4),XBSUMBLD(3),XBSUMBLD(5) +LINE3 ;;F I=2:1 S X=$T(+I) Q:X="" X XBSUMBLD(4) +LINE4 ;;F J=1:1 S Y=$E(X,J) Q:Y="" S BYTE=BYTE+1,COUNT=COUNT+$A(Y) +LINE5 ;;S ^TMP("XBSUMBLD",$J,RTN)=BYTE_"^"_COUNT +LINE6 ;;ZR S X=RTNAME_" ;INTEGRITY CHECKER;"_RTDATE ZI X ZI VERSION ZI " ;" ZI "START ;" ZI " NEW BYTE,COUNT,RTN" ZI " K ^UTILITY($J)" X XBSUMBLD(7),XBSUMBLD(8),XBSUMBLD(9),XBSUMBLD(10) ZS @RTNAME +LINE7 ;;F I=1:1:3 S V="CODE"_I S Z=XBSUMBLD(V) Q:Z="" ZI Z +LINE8 ;;ZI " Q" ZI " ;" ZI "LINE1 ;;X XBSUMBLD(2),XBSUMBLD(6)" F I=2:1:4 S Z="LINE"_I_" ;;"_XBSUMBLD(I) ZI Z +LINE9 ;;ZI "LINE5 ;;S B=$P(^UTILITY($J,RTN),""^"",1),C=$P(^(RTN),""^"",2) I B'=BYTE!(C'=COUNT) W "" has been modified""" ZI "LINE6 ;;K XBSUMBLD,B,C,I,J,R,X,Y" ZI " ;" ZI "LIST ;" +LINE10 ;;S RTN="" F S RTN=$O(^TMP("XBSUMBLD",$J,RTN)) Q:RTN="" S Z=^(RTN),Z=" ;;"_RTN_"^"_Z ZI Z +LINE11 ;;K %,XBSUMBLD,DTOUT,DUOUT,DIRUT,DIROUT,I,J,V,X,Y,Z,^UTILITY($J),^TMP("XBSUMBLD",$J) +CODE1 ;; F I=1:1 S X=$T(LIST+I) Q:X="" S X=$P(X,";;",2),R=$P(X,"^",1),B=$P(X,"^",2),C=$P(X,"^",3),^UTILITY($J,R)=B_"^"_C +CODE2 ;; F I=1:1:6 S X=$P($T(@("LINE"_I)),";;",2,99),@("XBSUMBLD("_I_")=X") +CODE3 ;; X XBSUMBLD(1) diff --git a/XBTM.m b/XBTM.m new file mode 100644 index 0000000..1ef0dd0 --- /dev/null +++ b/XBTM.m @@ -0,0 +1,148 @@ +XBTM ; IHS/ADC/GTH - TECH MANUAL : MAIN ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; This routine, and subsequent routines in the XBTM* + ; namespace, produce a technical manual from information + ; contained in the package. The manual is approximately 80 + ; pages. All, or individual chapters can be printed. + ; + D HOME^%ZIS,DT^DICRW + NEW DIR,XBSEL +SEL ; + S XBSEL=$$DIR^XBDIR("S^1:only one chapter;A:All chapters","Print 1 chapter, or all? 1/A","1") + S:$D(DUOUT) DIRUT=1 + Q:$D(DIRUT) + I XBSEL S XBSEL=$$DIR^XBDIR("N^1:15:0","Which chapter?","","","","^D CHAPS^XBTM") S:$D(DUOUT) DIRUT=1 + Q:$D(DIRUT) +DEV ; + S %ZIS="OPQ" + D ^%ZIS + I POP S IOP=$I D ^%ZIS G K + G:'$D(IO("Q")) START + KILL IO("Q") + I $D(IO("S"))!($E(IOST)'="P") W *7,!,"Please queue to system printers." D ^%ZISC G DEV + S ZTRTN="START^XBTM",ZTDESC="TECHNICAL MANUAL.",ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL,ZTSAVE("XBSEL")="" + D ^%ZTLOAD + G:'$D(ZTSK) DEV +K ; + KILL XB,ZTSK + D ^%ZISC + G END + ; +START ;EP - TaskMan. + NEW DIWL,DIWR,DIWF,XBBM,XBCONT,XBSAVX,XBTM,XBTITL,XBPG,XBHDR,XBHDRE,XBHDRO,XBDASH + D ^XBKTMP + S DIWL=10,DIWR=74,DIWF="W",XBBM=IOSL-5,XBTM=6,XBTITL="IHS/VA UTILITIES TECHNICAL MANUAL",XBPG=0,XBHDR="Index",(XBHDRE,XBHDRO)="",XBDASH="",$P(XBDASH,"-",81)="",XBDASH=$E(XBDASH,DIWL,DIWR) + U IO + I 'XBSEL D ^XBTMI S DIWF="WN" D ^XBTMTI W @IOF S DIWF="W" D ^XBTMPR W @IOF +BODY ; + S (XBCONT,XBHDR,XBPG)=0 + KILL ^TMP("XBTM-CONTENTS",$J) + I XBSEL S XBCHAP=XBSEL D MAKEHDRS,TOF Q:$D(DUOUT) D HDR(XBCHAP),@("^XBTM"_XBCHAP) G END + F XBCHAP=1:1:15 D MAKEHDRS,TOF Q:$D(DUOUT) D HDR(XBCHAP),@("^XBTM"_XBCHAP) + ; +INDEX ; + S XBHDR="Index" + D TOF + G:$D(DUOUT) HAT + W !!! + S X="|NOWRAP||SETTAB(""C"")||TAB|INDEX" + D ^DIWP,^DIWW + W !!! + D CONT("INDEX^^"_XBPG) + S (XB,XBCONT)="",$P(XBCONT,".",81)="" + F S XB=$O(^TMP("XBTM-INDEX",$J,XB)) Q:XB="" Q:$D(DUOUT) S X="" D + .F XBX=0:0 S XBX=$O(^TMP("XBTM-INDEX",$J,XB,XBX)) Q:$D(DUOUT) S X=X_XBX_"," I '$O(^(XBX)) D Q + ..S X=XB_$E(XBCONT,1,DIWR-DIWL-$L(XB)-$L(X))_$E(X,1,$L(X)-1) + ..S XBSAVX=X + ..F S X=$E(XBSAVX,1,DIWR-DIWL),XBSAVX=$E(XBSAVX,DIWR-DIWL+1,$L(XBSAVX)) Q:'$L(X) D TOF:$Y>XBBM Q:$D(DUOUT) D ^DIWP + ..Q + .Q + D ^DIWW,PAUSE^XB + G:$D(DUOUT) HAT + ; +CONTENTS ; + W @IOF,!!!!! + S X="|SETTAB(""C"")||TAB|CONTENTS" + D ^DIWP,^DIWW + W !! + S XB=0 + F S XB=$O(^TMP("XBTM-CONTENTS",$J,XB)) Q:'+XB S X=^(XB),X=$P(X,U)_" "_$P(X,U,2)_$E(XBCONT,1,DIWR-DIWL-$L(X)+1)_$P(X,U,3) D TOF:$Y>XBBM Q:$D(DUOUT) D ^DIWP + G:$D(DUOUT) HAT + D ^DIWW,PAUSE^XB + G:$D(DUOUT) HAT +END ; + D PAUSE^XB + G:$D(DUOUT) HAT + W @IOF +HAT ; + D ^%ZISC + KILL XB,XBBM,XBCHAP,XBCONT,XBODD,XBHDR,XBIEN,XBPARA,XBPG,XBROOT,XBTITL,XBTM,XBX,XBY,DIC,DIWF,DIWL,DIWR + D ^XBKTMP + Q + ; +TEXT(XBLAB) ; + F XB=1:1 S X=$P($T(@XBLAB+XB),";;",2) Q:X="###" D PR(X) Q:$D(DUOUT) + Q:$D(DUOUT) + D ^DIWW + Q + ; +PR(X) ;EP + I X="|TOP|" D TOF Q + D INDX(X),^DIWP,TOF:$Y>XBBM + Q + ; +INDX(X) ; + Q:'$D(XBPG) + S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + S %="" + F S %=$O(^TMP("XBTM-I",$J,%)) Q:'$L(%) I $F(X,%) S ^TMP("XBTM-INDEX",$J,%,XBPG)="" + Q + ; +HDR(XB) ; + F X="|SETTAB(""C"")||TAB|Chapter "_XB,"|SETTAB(""C"")||TAB|"_$P($T(@XB),";",3) D ^DIWP + W !! + D CONT(XB_U_$P($T(@XB),";",3)_U_XBPG) + Q + ; +TOF ;EP + F Q:$Y>XBBM W ! + I XBPG>0 W !?(DIWL-1),XBDASH,!,?$S(XBODD:DIWR-$L(XBTITL),1:DIWL-1),XBTITL + D PAUSE^XB + Q:$D(DUOUT) + W @IOF + S XBPG=XBPG+1,XBODD=XBPG#2 + F Q:$Y=(XBTM-2) W ! + W ?$S(XBODD:DIWR-$L("Page "_XBPG),1:DIWL-1),"Page ",XBPG + I '(XBHDR="Index") W !?DIWL-1,$S(XBODD:XBHDRO,1:XBHDRE) + W !?(DIWL-1),XBDASH,!! + Q + ; +MAKEHDRS ; + S (XBHDRE,XBHDRO)=$P($T(@XBCHAP),";",3) + S XBHDRO=XBHDRO_$J("",DIWR-DIWL-$L(XBHDRO)-$L("Chapter "_XBCHAP)+1)_"Chapter "_XBCHAP + S XBHDRE="Chapter "_XBCHAP_$J("",DIWR-DIWL-$L(XBHDRE)-$L("Chapter "_XBCHAP)+1)_XBHDRE + Q + ; +CONT(X) ; + S XBCONT=XBCONT+1,^TMP("XBTM-CONTENTS",$J,XBCONT)=X + Q + ; +CHAPS ;EP - From DIR + F %=1:1:15 W !?3,$J(%,2),". ",$P($T(@%),";",3) + Q +1 ;;Facility Parameters +2 ;;Area Office Parameters +3 ;;Security Keys +4 ;;Options +5 ;;Fields in Files +6 ;;Archiving and Purging +7 ;;Callable Routines +8 ;;External Relations +9 ;;Internal Relations +10 ;;How to Generate On-Line Documentation +11 ;;Glossary +12 ;;System Requirements +13 ;;Installation notes +14 ;;Enhancements +15 ;;KILL of Unsubscripted Globals diff --git a/XBTM1.m b/XBTM1.m new file mode 100644 index 0000000..62e5ec9 --- /dev/null +++ b/XBTM1.m @@ -0,0 +1,16 @@ +XBTM1 ; IHS/ADC/GTH - TECH MANUAL : Facility Parameters ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + NEW A,B,C + F A=1:1 S X=$P($T(PR+A),";;",2) Q:X="###" D PR(X) Q:$D(DUOUT) + Q:$D(DUOUT) + D DIWW + Q + ; +DIWW NEW A,B,C D ^DIWW Q +PR(X) NEW A,B,C D PR^XBTM(X) Q + ;;There are no facility parameters for this package. + ;;|SETTAB("C")||TAB| + ;;|SETTAB("C")||TAB| + ;;### + ; diff --git a/XBTM10.m b/XBTM10.m new file mode 100644 index 0000000..4914998 --- /dev/null +++ b/XBTM10.m @@ -0,0 +1,21 @@ +XBTM10 ; IHS/ADC/GTH - TECH MANUAL : ONLINE DOC ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + NEW A + F A=1:1 S X=$P($T(PR+A),";;",2) Q:X="###" D PR(X) Q:$D(DUOUT) + Q:$D(DUOUT) + D ^DIWW + Q + ; +PR(X) NEW A D PR^XBTM(X) Q + ;;The package + ;;documentation presented in this manual is extensive and should + ;;provide most site managers, ISC staff members, and developers + ;;with sufficient information. + ;;|SETTAB("C")||TAB| + ;;This manual can be generated from programmer mode by DO'ing + ;;^XBTM. This is a cpu-intensive routine. Please q to TaskMan + ;;to run after hours, and expect approximately 150 pages of output. + ;;|SETTAB("C")||TAB| + ;;|SETTAB("C")||TAB| + ;;### diff --git a/XBTM11.m b/XBTM11.m new file mode 100644 index 0000000..6a0ce86 --- /dev/null +++ b/XBTM11.m @@ -0,0 +1,15 @@ +XBTM11 ; IHS/ADC/GTH - TECH MANUAL : GLOSSARY ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + NEW A + F A=1:1 S X=$P($T(PR+A),";;",2) Q:X="###" D PR(X) Q:$D(DUOUT) + Q:$D(DUOUT) + D ^DIWW + Q + ; +PR(X) NEW A D PR^XBTM(X) Q + ;;Please refer to the IHS Programming Standards And Conventions + ;;(SAC) for a list of terms relevant to programming. + ;;|SETTAB("C")||TAB| + ;;|SETTAB("C")||TAB| + ;;### diff --git a/XBTM12.m b/XBTM12.m new file mode 100644 index 0000000..3431668 --- /dev/null +++ b/XBTM12.m @@ -0,0 +1,13 @@ +XBTM12 ; IHS/ADC/GTH - TECH MANUAL : SYSTEM REQUIREMENTS ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + NEW A,B,C,I + S A=$O(^DIC(9.4,"C","XB",0)),B=$O(^DIC(9.4,A,22,"B",^DIC(9.4,A,"VERSION"),0)) + S %=0 + F S %=$O(^DIC(9.4,A,22,B,"S",%)) Q:'% D PR(^(%,0)) Q:$D(DUOUT) + Q:$D(DUOUT) + D ^DIWW + Q + ; +PR(X) NEW %,A,B,C,I D PR^XBTM(X) Q + ; diff --git a/XBTM13.m b/XBTM13.m new file mode 100644 index 0000000..0cdd737 --- /dev/null +++ b/XBTM13.m @@ -0,0 +1,13 @@ +XBTM13 ; IHS/ADC/GTH - TECH MANUAL : INSTALL NOTES ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + NEW A,B + S A=$O(^DIC(9.4,"C","XB",0)),B=$O(^DIC(9.4,A,22,"B",^DIC(9.4,A,"VERSION"),0)) + S %=0 + F S %=$O(^DIC(9.4,A,22,B,"I",%)) Q:'% D PR(^(%,0)) Q:$D(DUOUT) + Q:$D(DUOUT) + D ^DIWW + Q + ; +PR(X) NEW %,A,B D PR^XBTM(X) Q + ; diff --git a/XBTM14.m b/XBTM14.m new file mode 100644 index 0000000..564e3b1 --- /dev/null +++ b/XBTM14.m @@ -0,0 +1,13 @@ +XBTM14 ; IHS/ADC/GTH - TECH MANUAL : ENHANCEMENTS ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + NEW A,B + S A=$O(^DIC(9.4,"C","XB",0)),B=$O(^DIC(9.4,A,22,"B",^DIC(9.4,A,"VERSION"),0)) + S %=0 + F S %=$O(^DIC(9.4,A,22,B,1,%)) Q:'% D PR(^(%,0)) Q:$D(DUOUT) + Q:$D(DUOUT) + D ^DIWW + Q + ; +PR(X) NEW %,A,B D PR^XBTM(X) Q + ; diff --git a/XBTM15.m b/XBTM15.m new file mode 100644 index 0000000..751aee1 --- /dev/null +++ b/XBTM15.m @@ -0,0 +1,18 @@ +XBTM15 ; IHS/ADC/GTH - TECH MANUAL : KILL UNSUBSCRIPTED GLOBALS; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + NEW A + F A=1:1 S X=$P($T(PR+A),";;",2) Q:X="###" D PR(X) Q:$D(DUOUT) + Q:$D(DUOUT) + D ^DIWW + Q + ; +PR(X) NEW A D PR^XBTM(X) Q + ;;|SETTAB("C")||TAB| + ;;|SETTAB("C")||TAB| + ;;|SETTAB("C")||TAB|Unsubscripted Globals, KILL'd in the package. + ;;|SETTAB("C")||TAB| + ;;|SETTAB("C")||TAB| + ;; Routine Line Global + ;; ----------------- ------------------ ---------------- + ;;### diff --git a/XBTM2.m b/XBTM2.m new file mode 100644 index 0000000..8cd7aed --- /dev/null +++ b/XBTM2.m @@ -0,0 +1,16 @@ +XBTM2 ; IHS/ADC/GTH - TECH MANUAL : AREA OFFICE PARAMETERS; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + NEW A + F A=1:1 S X=$P($T(PR+A),";;",2) Q:X="###" D PR(X) Q:$D(DUOUT) + KILL A + Q:$D(DUOUT) + D ^DIWW + Q + ; +PR(X) NEW A D PR^XBTM(X) Q + ;;There are no Area Office parameters for this package. + ;;|SETTAB("C")||TAB| + ;;|SETTAB("C")||TAB| + ;;### + ; diff --git a/XBTM3.m b/XBTM3.m new file mode 100644 index 0000000..2f07d15 --- /dev/null +++ b/XBTM3.m @@ -0,0 +1,34 @@ +XBTM3 ; IHS/ADC/GTH - TECH MANUAL : SECURITY KEYS ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + NEW A,B,C + F A=1:1 S X=$P($T(PR+A),";;",2) Q:X="###" D PR(X) Q:$D(DUOUT) + Q:$D(DUOUT) + D ^DIWW + F A="XAz","ZIBz" D SK(A) Q:$D(DUOUT) + Q + ; +SK(A) ; Print info on security keys for namespace A. + F S A=$O(^DIC(19.1,"B",A)) Q:'($E(A,1,4)="XB") S B=$O(^(A,0)) D + . S DIWF="WN" + . D PR("|_|"_$P(^DIC(19.1,B,0),U)_"|_|") + . Q:$D(DUOUT) + . I '$O(^DIC(19,"AOL",A,0)) D PR(" --> KEY NOT USED <--") I 1 + . E S C=0 F S C=$O(^DIC(19,"AOL",A,C)) Q:'C D PR("Locks "_$P(^DIC(19,C,0),U)_", '"_$P(^DIC(19,C,0),U,2)_"'.") + . Q:$D(DUOUT) + . S DIWF="W" + . D PR("DESCRIPTION: ") + . Q:$D(DUOUT) + . S C=0 + . F S C=$O(^DIC(19.1,B,1,C)) Q:'C D PR(^(C,0)) + . Q:$D(DUOUT) + . D ^DIWW + . W ! + .Q + D ^DIWW + Q + ; +PR(X) NEW A,B,C D PR^XBTM(X) Q + ;;|SETTAB("C")||TAB| + ;;|SETTAB("C")||TAB| + ;;### diff --git a/XBTM4.m b/XBTM4.m new file mode 100644 index 0000000..e1d5868 --- /dev/null +++ b/XBTM4.m @@ -0,0 +1,56 @@ +XBTM4 ; IHS/ADC/GTH - TECH MANUAL : OPTIONS ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + NEW A,B,C,T,XB + F A=1:1 S X=$P($T(PR+A),";;",2) Q:X="###" D PR(X) Q:$D(DUOUT) + Q:$D(DUOUT) + D ^DIWW + S T=$P(^DD(19,4,0),U,3) + F %=1:1 Q:'$L($P(T,";",%)) S T($P($P(T,";",%),":"))=$P($P(T,";",%),":",2) + S XB="XB" + D OP("XAz") + S XB="ZIB" + D OP("ZIAz") + Q + ; +OP(A) ; Print info on options in namespace A. + F S A=$O(^DIC(19,"B",A)) Q:'($E(A,1,$L(XB))=XB) S B=$O(^(A,0)) D + . D PR("|_|"_$P(^DIC(19,B,0),U)_"|_|"_$S('$D(^DIC(19,"AD",B)):" ** no parents **",1:"")),^DIWW + . Q:$D(DUOUT) + . D PR("TYPE: "_T($P(^DIC(19,B,0),U,4))),^DIWW + . Q:$D(DUOUT) + . D PR("TEXT: "_$P(^DIC(19,B,0),U,2)),^DIWW + . Q:$D(DUOUT) + . I $L($P(^DIC(19,B,0),U,6)) D PR("LOCK: "_$P(^(0),U,6)),^DIWW + . I $L($G(^DIC(19,B,20))) D PR("ENTRY ACTION: "_^DIC(19,B,20)),^DIWW + . I $L($G(^DIC(19,B,15))) D PR("EXIT ACTION : "_^DIC(19,B,15)),^DIWW + . D PR("DESCRIPTION : ") + . Q:$D(DUOUT) + . S C=0 + . F S C=$O(^DIC(19,B,1,C)) Q:'C D PR(^(C,0)) Q:$D(DUOUT) + . Q:$D(DUOUT) + . D ^DIWW + . F C=30:1:36,50,51,60:1:69,69.1:.1:69.3,71:1:73,79:1:82 I $L($G(^DIC(19,B,C))) D PR($P(^DD(19,C,0),U)_": "_^DIC(19,B,C)),^DIWW Q:$D(DUOUT) + . Q:$D(DUOUT) + . W ! + .Q + Q:$D(DUOUT) + D ^DIWW + Q + ; +PR(X) NEW A,B,C,T,XB D PR^XBTM(X) Q + ;;There are no options distributed with the package. + ;;|SETTAB("C")||TAB| + ;;There is one option associated with the Remote Patch + ;;Installer (ZIBRPI), which is used to schedule the task. + ;;That option is installed by ZIBRPI when the local facility + ;;installs it. + ;;|SETTAB("C")||TAB| + ;;If you have Remote Error Reporting (ZIBRER) installed, there + ;;will be options in that namespace. + ;;|SETTAB("C")||TAB| + ;;Any other XB or ZIB listed option + ;;will have been created on your local machine. + ;;|SETTAB("C")||TAB| + ;;|SETTAB("C")||TAB| + ;;### diff --git a/XBTM5.m b/XBTM5.m new file mode 100644 index 0000000..a8df841 --- /dev/null +++ b/XBTM5.m @@ -0,0 +1,52 @@ +XBTM5 ; IHS/ADC/GTH - TECH MANUAL : FIELDS IN THE FILES ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + NEW A,B,C,I,J + F A=1:1 S X=$P($T(PR+A),";;",2) Q:X="###" D PR(X) Q:$D(DUOUT) + Q:$D(DUOUT) + D ^DIWW + KILL ^TMP("XBTM-FIF",$J) + S DIWF="WN" + D PR($J("",5)_"These are the files in the package:") + Q:$D(DUOUT) + D ALPHA + D PR($J("",5)),PR($J("",5)),PR($J("",5)_"These are the alphabetized fields in the files :") + Q:$D(DUOUT) + S DIWF="W",(A,B,I,J)="" + F S A=$O(^TMP("XBTM-FIF",$J,A)) Q:A="" S B=$O(^(A,0)),I=$O(^(B,0)) D Q:$D(DUOUT) + . D PR(A_$E($J("",40),1,(40-$L(A)))_B_$E($J("",12),1,(12-$L(B)))_I),^DIWW + . S J=J+1 + .Q + Q:$D(DUOUT) + D PR($J("",5)),PR($J("",5)),PR($J("",3)_"There are "_+J_" fields in the package files.") + Q:$D(DUOUT) + D ^DIWW + Q + ; +PR(X) NEW %,A,B,C,I,J D PR^XBTM(X) Q + ;;No files are distributed with this package. Any fields listed, + ;;below, will have been created locally. The list will be + ;;an alphabetical list of fields in the package's files. + ;;|SETTAB("C")||TAB| + ;;|SETTAB("C")||TAB| + ;;### + ; +ALPHA ; + NEW XBFLD,XBPIEN + S XBPIEN=$O(^DIC(9.4,"C","XB",0)) + S %=0 + F S %=$O(^DIC(9.4,XBPIEN,4,"B",%)) Q:'% D PR(%_$E(" ",1,(12-$L(%)))_$O(^DD(%,0,"NM",""))) Q:$D(DUOUT) D FLD + Q + ; +FLD ; + S XBFLD=0 + F S XBFLD=$O(^DD(%,XBFLD)) Q:'XBFLD D + .I +$P(^DD(%,XBFLD,0),U,2) S XB=+$P(^(0),U,2) D Q + ..NEW %,XBFLD + ..S %=XB + ..D FLD + ..Q + .S ^TMP("XBTM-FIF",$J,$P(^DD(%,XBFLD,0),U),%,XBFLD)="" + .Q + Q + ; diff --git a/XBTM6.m b/XBTM6.m new file mode 100644 index 0000000..4c52001 --- /dev/null +++ b/XBTM6.m @@ -0,0 +1,15 @@ +XBTM6 ; IHS/ADC/GTH - TECH MANUAL : ARCHIVING & PURGING ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + NEW A + F A=1:1 S X=$P($T(PR+A),";;",2) Q:X="###" D PR(X) Q:$D(DUOUT) + Q:$D(DUOUT) + D ^DIWW + Q + ; +PR(X) NEW A D PR^XBTM(X) Q + ;;At the present time there are no + ;;archiving and/or purging capabilities with this package. + ;;|SETTAB("C")||TAB| + ;;|SETTAB("C")||TAB| + ;;### diff --git a/XBTM7.m b/XBTM7.m new file mode 100644 index 0000000..572013d --- /dev/null +++ b/XBTM7.m @@ -0,0 +1,53 @@ +XBTM7 ; IHS/ADC/GTH - TECH MANUAL : ROUTINES ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + NEW A + F A=1:1 S X=$P($T(PR+A),";;",2) Q:X="###" D PR(X) Q:$D(DUOUT) + Q:$D(DUOUT) + D ^DIWW + KILL ^TMP("XBTM-RTN",$J) + NEW A,B + S DIWF="WN" + D PR("Routines & sub-routines in namespace :"),PR(" "),PR(" ") + Q:$D(DUOUT) + S %=$$RSEL^ZIBRSEL("XB*","^TMP(""XB"",$J,") + S %=$$RSEL^ZIBRSEL("ZIB*","^TMP(""XB"",$J,") + S %="" + F S %=$O(^TMP("XB",$J,%)) Q:%="" Q:$D(DUOUT) D + . D PR($E("|_|"_%_"|_| "_$P($T(+1^@%)," ",2,99),1,(DIWR-DIWL+7))) + . Q:$D(DUOUT) + . S B=$T(+1^@%) + . I B["; GENERATED FROM "!(B["; DRIVER FOR")!(B["; COMPILED XREF") S ^TMP("XBTM-RTN",$J,"C",%)=B + . F A=3:1 S B=$T(+A^@%) Q:B=""!('($E(B,1,2)=" ;")) D PR(" "_$E(B,1,(DIWR-DIWL-2))) Q:$D(DUOUT) + . Q:$D(DUOUT) + . F A=3:1 S B=$T(+A^@%) Q:B="" I '($E(B)=" ") D PR(" "_$E(B,1,(DIWR-DIWL-2))) I B[";EP"!(B["ENTRY POINT") S ^TMP("XBTM-RTN",$J,%,$P(B," "))=$P(B," ",2,999) Q:$D(DUOUT) + . Q:$D(DUOUT) + . D PR(" ") + .Q + ; + D PR("|TOP|"),PR(" "),PR("Documented entry points:"),PR(" ") + Q:$D(DUOUT) + S (A,B)="" + F S A=$O(^TMP("XBTM-RTN",$J,A)) Q:A=""!(A="C") Q:$D(DUOUT) F S B=$O(^TMP("XBTM-RTN",$J,A,B)) Q:B="" D PR($E(B_U_A_" : "_^(B),1,(DIWR-DIWL))) Q:$D(DUOUT) + Q:$D(DUOUT) + ; + D PR(" "),PR(" "),PR("Compiled/Generated routines:"),PR(" ") + Q:$D(DUOUT) + S A="" + F S A=$O(^TMP("XBTM-RTN",$J,"C",A)) Q:A="" D PR($E(^(A),1,(DIWR-DIWL))) Q:$D(DUOUT) + Q:$D(DUOUT) + ; + KILL ^TMP("XBTM-RTN",$J) + S DIWF="W" + Q + ; +PR(X) NEW %,A,B D PR^XBTM(X) Q + ;;These are the routine descriptions, which are usually contained + ;;in the commented lines prior to the first label or executable + ;;line. + ;;|SETTAB("C")||TAB| + ;;Each line label is also listed. The internally documented + ;;entry points (" ;EP") are listed. + ;;|SETTAB("C")||TAB| + ;;|SETTAB("C")||TAB| + ;;### diff --git a/XBTM8.m b/XBTM8.m new file mode 100644 index 0000000..f6b9da9 --- /dev/null +++ b/XBTM8.m @@ -0,0 +1,38 @@ +XBTM8 ; IHS/ADC/GTH - TECH MANUAL : EXTERNAL RELATIONS ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + NEW A + F A=1:1 S X=$P($T(PR+A),";;",2) Q:X="###" D PR(X) Q:$D(DUOUT) + Q:$D(DUOUT) + D ^DIWW + KILL ^TMP("XBTM8",$J) + NEW A,B + S DIWF="WN" + S %=$$RSEL^ZIBRSEL("XB*","^TMP(""XB"",$J,") + S %=$$RSEL^ZIBRSEL("ZIB*","^TMP(""XB"",$J,") + ; + S %="" + F S %=$O(^TMP("XB",$J,%)) Q:%="" D + .S B=$T(+1^@%) + .F A=3:1 S B=$T(+A^@%) Q:B="" I '($E(B)=" ") I B[";PEP" S ^TMP("XBTM8",$J,%,$P(B," "))=$P(B," ",2,999) + .Q + ; + F %=1:1 S B=$T(L+%^XBLCALL),A=$P(B,";",3) Q:B="" I $E(A)=U S A=$E(A,2,99),^TMP("XBTM8",$J,A,A)=$P(B,";",4,999) + D PR("|TOP|"),PR(" "),PR("Published entry points and supported routines:"),PR(" ") + Q:$D(DUOUT) + S (A,B)="" + F S A=$O(^TMP("XBTM8",$J,A)) Q:A="" Q:$D(DUOUT) F S B=$O(^TMP("XBTM8",$J,A,B)) Q:B="" D PR($E($S(A=B:"",1:$P(B,"(",1))_U_A_$S($L($P(B,"(",2)):"(",1:"")_$P(B,"(",2)_" : "_^(B),1,(DIWR-DIWL))) Q:$D(DUOUT) + ; + KILL ^TMP("XBTM8",$J) + Q:$D(DUOUT) + S DIWF="W" + Q + ; +PR(X) NEW %,A,B D PR^XBTM(X) Q + ;;There are several published entry points that may be called + ;;from other packages. Some XB/ZIB routines were programmed to be + ;;available to call from the top of the routine, and are so noted in + ;;the routine. + ;;|SETTAB("C")||TAB| + ;;|SETTAB("C")||TAB| + ;;### diff --git a/XBTM9.m b/XBTM9.m new file mode 100644 index 0000000..fb60016 --- /dev/null +++ b/XBTM9.m @@ -0,0 +1,17 @@ +XBTM9 ; IHS/ADC/GTH - TECH MANUAL : INTERNAL RELATIONS ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + NEW A + F A=1:1 S X=$P($T(PR+A),";;",2) Q:X="###" D PR(X) Q:$D(DUOUT) + Q:$D(DUOUT) + D ^DIWW + Q + ; +PR(X) NEW A D PR^XBTM(X) Q + ;;XB/ZIB contains routines and entry points that are for use + ;;both interactively by programmers, and as calls from applications. + ;;The XB menu can be accessed from programmer mode thru routine XB, + ;;i.e., DO ^XB. + ;;|SETTAB("C")||TAB| + ;;|SETTAB("C")||TAB| + ;;### diff --git a/XBTMI.m b/XBTMI.m new file mode 100644 index 0000000..b9f72da --- /dev/null +++ b/XBTMI.m @@ -0,0 +1,39 @@ +XBTMI ; IHS/ADC/GTH - TECH MANUAL : INDEXED WORDS; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + KILL ^TMP("XBTM-I",$J) + NEW A,I + D ALPHA + F %=19,19.1 S A="XAz" F S A=$O(^DIC(%,"B",A)) Q:'($E(A,1,2)="XB") S ^TMP("XBTM-I",$J,A)="" + F %=19,19.1 S A="ZIAz" F S A=$O(^DIC(%,"B",A)) Q:'($E(A,1,3)="ZIB") S ^TMP("XBTM-I",$J,A)="" + F %=1:1 S A=$P($T(1+%),";;",2) Q:A="" S ^TMP("XBTM-I",$J,A)="" + KILL ^TMP("XBTMI",$J) + S %=$$RSEL^ZIBRSEL("XB*","^TMP(""XBTMI"",$J,"),%=$$RSEL^ZIBRSEL("ZIB*","^TMP(""XBTMI"",$J,") + S %="" + F S %=$O(^TMP("XBTMI",$J,%)) Q:%="" S ^TMP("XBTM-I",$J,%)="" F I=3:1 S A=$T(+I^@%) Q:A="" I $L($P(A," ")),A[";EP"!(A["ENTRY POINT")!(A[";PEP") S ^TMP("XBTM-I",$J,$P(A," ")_U_%)="" + KILL ^TMP("XBTMI",$J) + Q + ; +ALPHA ; + NEW XBFLD,XBPIEN + S XBPIEN=$O(^DIC(9.4,"C","XB",0)) + S %=0 + F S %=$O(^DIC(9.4,XBPIEN,4,"B",%)) Q:'% D FLD + Q + ; +FLD ; + S XBFLD=0 + F S XBFLD=$O(^DD(%,XBFLD)) Q:'XBFLD D + .I +$P(^DD(%,XBFLD,0),U,2) S XB=+$P(^(0),U,2) D Q + ..NEW %,XBFLD S %=XB D FLD + ..Q + .S ^TMP("XBTM-I",$J,$P(^DD(%,XBFLD,0),U))="" + .Q + Q + ; +1 ;; + ;;CONTROL + ;;GUI + ;;LIST + ;;STANDARDS + ;;VIDEO diff --git a/XBTMPR.m b/XBTMPR.m new file mode 100644 index 0000000..81861c6 --- /dev/null +++ b/XBTMPR.m @@ -0,0 +1,47 @@ +XBTMPR ; IHS/ADC/GTH - TECH MANUAL : PREFACE ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + NEW XBCTR + F XBCTR=1:1 S X=$P($T(PREFACE+XBCTR),";;",2) Q:X="" D PR^XBTM(X) + D ^DIWW + Q + ; +PREFACE ;; + ;;|SETTAB("C")||TAB| + ;;|SETTAB("C")||TAB| + ;;|SETTAB("C")||TAB| + ;;|SETTAB("C")||TAB|PREFACE + ;; + ;;This document is designed primarily for RPMS application + ;;programmers. Area and site IRM personnel can find this + ;;document helpful in understanding how the XB/ZIB utility + ;;routines operate. + ;; + ;;|SETTAB("C")||TAB| + ;;|SETTAB("C")||TAB| + ;;|SETTAB("C")||TAB| + ;;|SETTAB("C")||TAB|INTRODUCTION + ;;|SETTAB("C")||TAB| + ;;|SETTAB("C")||TAB| + ;;The IHS/VA UTILITIES are in the XB + ;;namespace, for routines that are not MUMPS + ;;implementation specific. Routines that are implementation specific + ;;will be in the ZIB namespace. + ;; + ;;Programmer tools are available from programmer mode thru the + ;;menu-driver routine XB. + ;; + ;;There are no files associated with this package. + ;; + ;;To aid in your reading the routines, if required, the following + ;;style guidelines have been followed in most of the routines. + ;;|SETTAB("C")||TAB| + ;; (1) all NEW and KILL commands are not abbreviated; + ;;|SETTAB("C")||TAB| + ;; (2) only one command scope per line; + ;;|SETTAB("C")||TAB| + ;; (3) unconditional GOs/QUITs are followed by a comment line; + ;;|SETTAB("C")||TAB| + ;; (4) lines with labels have no executable code; + ;;|SETTAB("C")||TAB| + ;;|SETTAB("C")||TAB| diff --git a/XBTMTI.m b/XBTMTI.m new file mode 100644 index 0000000..596bd16 --- /dev/null +++ b/XBTMTI.m @@ -0,0 +1,64 @@ +XBTMTI ; IHS/ADC/GTH - TECH MANUAL : TITLE PAGE ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + NEW XBCTR + F XBCTR=1:1 S X=$P($T(TITLE+XBCTR),";;",2) Q:X="" D PR^XBTM(X) + D ^DIWW + Q + ; +TITLE ;; + ;; + ;; + ;; + ;;|SETTAB("C")||TAB| + ;;|SETTAB("C")||TAB|*********************************************************** + ;; + ;; + ;; + ;; + ;; + ;;|SETTAB("C")||TAB|RESOURCE AND PATIENT MANAGEMENT SYSTEM + ;;|SETTAB("C")||TAB|(RPMS) + ;; + ;; + ;; + ;; + ;; + ;;|SETTAB("C")||TAB|TECHNICAL MANUAL + ;; + ;; + ;; + ;; + ;; + ;;|SETTAB("C")||TAB|IHS/VA UTILITIES + ;;|SETTAB("C")||TAB|XB/ZIB + ;; + ;; + ;; + ;; + ;; + ;;|SETTAB("C")||TAB|Version 3.0 + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;;|SETTAB("C")||TAB|April 30, 1996 + ;; + ;; + ;; + ;; + ;; + ;;|SETTAB("C")||TAB|Office of Information Resource Management + ;;|SETTAB("C")||TAB|Indian Health Service + ;;|SETTAB("C")||TAB|Albuquerque, New Mexico + ;; + ;; + ;; + ;; + ;; + ;;|SETTAB("C")||TAB|*********************************************************** diff --git a/XBTRK.m b/XBTRK.m new file mode 100644 index 0000000..d013cde --- /dev/null +++ b/XBTRK.m @@ -0,0 +1,47 @@ +XBTRK ;IHS/ASDST/GTH - GET SITE PACKAGE INFO ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; IHS/SET/GTH XB*3*9 10/29/2002 + ; + ; Thanks to Don Jackson and Carlos Cordova for the original routine. + ; June 6, 2001. + ; + ; This routine counts the number of patched routines in each namespace + ; in each entry in the PACKAGE file, and, if run in foreground, only + ; delivers a mail message with the results to all local programmers. + ; + ; If Q'd thru option "XB PACKAGE TRACKING", in addition to the mail + ; message getting generated, a file is sent to the system id(s) + ; specified on the 2nd page of the TaskMan option scheduling function, + ; with the id(s) set into variable XBSYSID(n), where "n" is a numeric + ; subscript. + ; + ; The option, "XB PACKAGE TRACKING", is recommended to run every 30 + ; days, and is atch'd to the Site Manager's menu, "XUSITEMGR", as a + ; protection against deletion by the Kernel's dangling-option cleanup + ; process. + ; + ; The format of the data global transmitted to the System(s) is: + ; CV^namespace^name^version^#routines^patch + ; where "CV" means "Current Version" on that machine. If the + ; first piece is "PV", the info on that node means the the version + ; of the routines was a "Previous Version". This assumes there are + ; no 'future' versions. + ; +START ;EP - From TaskMan. + ; + I '$D(ZTQUEUED) D Q:'$$DIR^XBDIR("Y","Proceed","N",$S($G(DTIME):DTIME,1:300),"If you answer 'Y', we'll go ahead and run this") W ! + . D ^XBKVAR + . S ^UTILITY($J,"XBTRK")="" + . D EN^XBRPTL + .Q + ; + KILL ^XBPKDATA ; KILL of unsubscripted work global. + KILL ^TMP("XBTRK",$J),^TMP("XBTRK XMD",$J) + ; + ; Process every entry in the PACKAGE file that has a PREFIX value. + ; + NEW XBI,XBN + S XBI=0 + F S XBI=$O(^DIC(9.4,XBI)) Q:'XBI D + . S XBN=$P($G(^DIC(9.4,XBI,0)),U,2) diff --git a/XBUPCASE.m b/XBUPCASE.m new file mode 100644 index 0000000..64359cf --- /dev/null +++ b/XBUPCASE.m @@ -0,0 +1,9 @@ +XBUPCASE ; IHS/ADC/GTH - UPCASE VALUE IN X ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; Upcase value in X + ; +START ; + S X=$$UP^XLFSTR(X) + Q + ; diff --git a/XBUTL.m b/XBUTL.m new file mode 100644 index 0000000..2c3ba3d --- /dev/null +++ b/XBUTL.m @@ -0,0 +1,36 @@ +XBUTL ;IHS/ITSC/CLS - XB MISCELLANEOUS UTILITIES [ 10/06/2005 9:59 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; +LINK(P,C) ;link protocols child to parent + ;Input: P-Parent protocol + ; C-Child protocol + N IENARY,PIEN,AIEN,FDA,ERR + Q:'$L(P)!('$L(C)) + S IENARY(1)=$$FIND1^DIC(101,"","",P) + S AIEN=$$FIND1^DIC(101,"","",C) + Q:'IENARY(1)!'AIEN + S FDA(101.01,"?+2,"_IENARY(1)_",",.01)=AIEN + D UPDATE^DIE("S","FDA","IENARY","ERR") + ;I $G(ERR("DIERR",1)) W ! ZW ERR ;IHS/CIA/PLS for debugging use + Q +LUHN(X) ;calulate check digit, Luhn formula for NPI + ;x=10 digit number + I '+X S X=0 Q X + I $E(X,1,5)=80840 D + .S X=$E(X,6,15) + S XBSTRING="" + I X'?10N S X=0 Q X + S XBCD=$E(X,10) + F I=1:1:9 D + .I (I#2) D + ..S XBSTRING=XBSTRING_($E(X,I)*2) + .I '(I#2) D + ..S XBSTRING=XBSTRING_$E(X,I) + S XBTOT=0 + F I=1:1:$L(XBSTRING) D + .S XBTOT=XBTOT+$E(XBSTRING,I) + S XBTOT=XBTOT+24 + S XBTOT=1000-XBTOT + S X=$E(XBTOT,$L(XBTOT)) + I X'=XBCD S X=0 Q X + S X=1 Q X diff --git a/XBVCH.m b/XBVCH.m new file mode 100644 index 0000000..54d1371 --- /dev/null +++ b/XBVCH.m @@ -0,0 +1,141 @@ +XBVCH ; IHS/ADC/GTH - CHANGE VARIABLE NAMES ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; Thanks to Paul Wesley, DSD/OIRM, for the original routine. + ; + I '$D(IOST(0)) D HOME^%ZIS + S XBJ=$J + D EXIT^XBVCH + S XBJ=$J + S X="IORVON;IORVOFF;IOUON;IOUOFF;IOINHI;IOINORM;IOAWM0;IOAWM1" + D ENDR^%ZISS + S XBD(0)=IOUON,XBD(1)=IOUOFF,XBD(2)=IORVON,XBD(3)=IORVOFF,XBD(4)=IORVON,XBD(5)=IORVOFF,XBD(6)=IOAWM0,XBD(7)=IOAWM1,XBXY=IOXY + D KILL^%ZISS + S XBP=" #&'()*+,'-/<=>@\_?;:[]!""" + S XBS=" #&'()*+,'-/<=>@\_?;:[]!""" + KILL DIR + S DIR(0)="Y",DIR("B")="Y",DIR("A")="Do you have a %INDEX Summary in a Host File to work with ? " + D ^DIR + KILL DIR + D:Y=1 ^XBVCHV +START ; + KILL XBV0,XBV1,XBV2 +V0 ; + KILL DIR + S DIR(0)="F:0,8",DIR("A")="Old Variable ? or '^' to exit " + I $G(XBFILE) S DIR("A")=DIR("A")_" or '|' to see variables " + D ^DIR + KILL DIR + G:(Y="^") EXIT + I Y["|",$G(XBFILE) S XBV="" D SHOVAR G V0 + I $G(XBFILE),'$D(^XBVROU(XBJ,"V",Y)) W *7 G V0 + S XBV0=Y +V1 ; + KILL DIR + S DIR(0)="F:0,8",DIR("A")="New Variable ? or '^' to exit " + D ^DIR + KILL DIR + G:(Y="^") V0 + S XBV1=Y + I $G(XBFILE),$D(^XBVROU(XBJ,"V",XBV1)) W *7,!!,"FYI >> ",XBV1," << Already Exits" KILL DIR S DIR(0)="E" D ^DIR I Y'>0 G V1 + I $D(^XBVROU(XBJ,"NV",XBV1)) W *7,!!,"FYI >> ",XBV1," << is a >>NEW VARIABLE<" KILL DIR S DIR(0)="E" D ^DIR I Y'>0 G V1 + ; +V2 ; + S XBV1L=$L(XBV1) + I $E(XBV1,XBV1L)=")" S XBV2=$E(XBV1,1,XBV1L-1)_"," +SELROU ; + I '$G(XBFILE) X ^%ZOSF("RSEL") S %X="^UTILITY(XBJ,",%Y="^XBVROU(XBJ,""R""," D %XY^%RCR + I $G(XBFILE) F XBVI=1:1 Q:'$D(^XBVROU(XBJ,"V",XBV0,XBVI)) S XBVRM=^(XBVI) D + . I XBVRM'["," S ^XBVROU(XBJ,"R",XBVRM)="" Q + . F XBVJ=1:1 S XBVR=$P(XBVRM,",",XBVJ) Q:XBVR="" S ^XBVROU(XBJ,"R",XBVR)="" + .Q + ; + ;---------------------------------------- + ; +PROCESS ; + D ^XBVCH1 + G START + ; + ;-------------------- + ; +SHOVAR ; + D ^XBCLS + S XBVAR="" + F XBI=0:1 S XBVAR=$O(^XBVROU(XBJ,"V",XBVAR)) Q:XBVAR="" D:'(XBI#120) PAGE Q:X="^" W:'(XBI#6) ! W ?((XBI#6)*10),XBVAR + Q + ; +PAGE ; + Q:XBI=0 + KILL DIR + S DIR(0)="E" + D ^DIR + Q + ; + ;---------------------- +EXIT ;EP - Paginat, print, kill, quit. + D ^XBCLS + I $D(^XBVROU("PRT",XBJ,"VCHG")) D PRINT + KILL ^XBVROU(XBJ),^UTILITY(XBJ) + I '$D(ZTQUEUED) KILL ^XBVROU("PRT",XBJ) + D EN^XBVK("XB") + Q + ; +PRINT ;print variables and routines changed + ; + KILL XBRC,XBRP,XBRX + W !,"Changes were made and a Summary is available",!! + S XBRP="PRINT1^XBVCH",XBNS="XB*" + D ^XBDBQUE + Q + ; +PRINT1 ; Continue print + S:'$D(XBJ) XBJ=$J + S XBPG("HDR")="VARIABLES/ROUTINES CHANGED" + D XBHDR + S XBSUB="" + F S XBSUB=$O(^XBVROU("PRT",XBJ,"VCHG",XBSUB)) Q:XBSUB="" D + . U IO + . W !!?5,XBSUB + . S XBROU="" + . F XBC=2:1 S XBROU=$O(^XBVROU("PRT",XBJ,"VCHG",XBSUB,XBROU)) Q:XBROU="" D XBPG D + .. U IO + .. W ?(10*XBC),XBROU + .. I (XBC+2)>(IOM\10) S XBC=0 W ! D XBPG + ..Q + .Q + S XBROU="" + F S XBROU=$O(^XBVROU("PRT",XBJ,"RCHG",XBROU)) Q:XBROU="" D XBPG D + . U IO + . W !!?5,XBROU + . S XBSUB="" + . F XBC=2:1 S XBSUB=$O(^XBVROU("PRT",XBJ,"RCHG",XBROU,XBSUB)) Q:XBSUB="" D + .. U IO + .. W ?(20*XBC),XBSUB + .. I (XBC+2)>(IOM\20) S XBC=0 W ! D XBPG + ..Q + .Q + Q + ; +XBPG ;EP PAGE CONTROLLER + ; this utility uses variables XBPG("HDR"),XBPG("DT"),XBPG("LINE"),XBPG("PG") ; kill variables by D EXBPG + ; + Q:($Y<(IOSL-4))!($G(DUOUT)) + S XBPG("PG")=$G(XBPG("PG"))+1 + I $E(IOST)="C" S Y=$$DIR^XBDIR("E") Q:($G(DIROUT)!$G(DUOUT)!$G(DTOUT)) +XBHDR ;EP write page header + W:$Y @IOF + W ! + Q:'$D(XBPG("HDR")) + S:'$D(XBPG("LINE")) $P(XBPG("LINE"),"-",IOM-2)="" + S:'$D(XBPG("PG")) XBPG("PG")=1 + I '$D(XBPG("DT")) S %H=$H D YX^%DTC S XBPG("DT")=Y + U IO + W ?(IOM-40-$L(XBPG("HDR"))/2),XBPG("HDR"),?(IOM-40),XBPG("DT"),?(IOM-10),"PAGE: ",XBPG("PG"),!,XBPG("LINE") +XBHD ;EP Write column header / message + W !! + Q + ; +EXBPG ; + KILL XBPG("LINE"),XBPG("PG"),XBPG("HDR"),XBPG("DT") + Q + ; diff --git a/XBVCH1.m b/XBVCH1.m new file mode 100644 index 0000000..510c548 --- /dev/null +++ b/XBVCH1.m @@ -0,0 +1,200 @@ +XBVCH1 ; IHS/ADC/GTH - CONTINUE VARIABLE CHANGER ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; Thanks to Paul Wesley, DSD/OIRM, for the original routine. + ; +PROCESS ; + S XBL=$L(XBV0),XBOUT=0 + S X=0 + X ^%ZOSF("RM") + S (XBROU,XBRM)="" + F S XBROU=$O(^XBVROU(XBJ,"R",XBROU)) Q:XBROU="" S XBRM=XBRM_XBROU_"," + S XBROU="" + F S XBROU=$O(^XBVROU(XBJ,"R",XBROU)) Q:XBROU="" D Q:$G(XBOUT) + . S X=XBROU + . X ^%ZOSF("TEST") + . E D ^XBCLS W !!,X," NOT FOUND",! KILL DIR S DIR(0)="E" D ^DIR S:(Y=0) XBOUT=1 Q + . S X=XBROU,DIF="^XBVROU(XBJ,""R"","""_XBROU_""",",(XCNP,%N)=0 + . X ^%ZOSF("LOAD") + . I ^XBVROU(XBJ,"R",XBROU,1,0)["GENERATED FROM" W !,^(0),! KILL DIR S DIR(0)="E" D ^DIR D ^XBCLS Q + . S XBLN=0,XBEDIT=0 + . F S XBLN=$O(^XBVROU(XBJ,"R",XBROU,XBLN)) Q:XBLN="" S XBLIN=^(XBLN,0) D LIN Q:$G(XBOUT) + . I XBEDIT D SAVE + . KILL ^XBVROU(XBJ,"R",XBROU) + .Q + Q + ; +DISPROU ;display routine list + S DX=1,DY=22 + X XBXY + S XBRD="" + F XBRI=1:1 S XBRD=$P(XBRM,",",XBRI) Q:XBRD="" W:'(XBRI-1#8) ! S XBRC=(10*(XBRI-1#8)) W ?XBRC W:XBRD=XBROU "|" W XBRD W:XBRD=XBROU "|" + Q + ; + ;-------------------------------------- + ; +LIN ;PROCESS LINE FROM TOP + S XBLIN0=XBLIN,XBVX=XBV0 + Q:XBLIN0'[XBV0 + D SCAN0,CHKMK + I '$G(XBMK),$L(XBV0)=1 Q ;skip when single character variable + I '$G(XBMK) KILL XBEDLIN D EDIT,CHKMK Q:'$G(XBMK) Q:$G(XBOUT) + D ACCEPT + Q + ; +SCAN0 ; + S XBLINX=XBLIN0,XBVX=XBV0 + D SCAN,UPT + Q + ; +SCAN1 ; + S XBLINX=XBLIN1,XBVX=XBV1 + D SCAN + Q + ; +DISP0 ; + S XBVX=XBV0,XBLINX=XBLIN0 + D ^XBCLS,DISPLAY + Q + ; +DISP1 ; + S XBVX=XBV1,XBLINX=XBLIN1 + D DISPLAY + Q + ; +SCAN ; + KILL XB,XBT,XBMK + S XBL=$L(XBVX) + F XBI=1:1 S XB(XBI)=$F(XBLINX,XBVX,$G(XB(XBI-1))+1)-XBL Q:XB(XBI)'>0 D + . S XB(XBI,"M")=0,XB(XBI,0)=XB(XBI) + . I XBP[$E(XBLINX,XB(XBI)-1),XBS[$E(XBLINX,XB(XBI)+XBL) S XB(XBI,"M")=1 + . S XB("B",XB(XBI))=XBI,XB("E",XB(XBI)+XBL-1)=XBI + . S XB(XBI,"E")=XB(XBI)+XBL-1 + .Q + KILL XB(XBI) +CHKMK ; + I XBVX=XBV0 KILL XBMK S XBJM="" F S XBJM=$O(XB(XBJM)) Q:XBJM="" I $G(XB(XBJM,"M")) W *7 S XBMK=1 + KILL XBJM + Q + ; +EDIT ; + D DISP0 + S DX=1,DY=13 + X XBXY + R "TAB/T/SPC/CR/R/N/%/^/? :",*X:DTIME + S X=$C(X) + I X="T" D UPT G EDIT + I $A(X)=9 D UPT G EDIT + I X=" " S XB(XBT,"M")=XB(XBT,"M")+1#2 D UPT G EDIT + I X="R" S XBLN=0 KILL XBMK Q + I X="N" S XBLN=999 KILL XBMK Q + ; I X="%" D ^XBNEW("%EDIT^XBVCH1:XBJ;XBROU") S XBLN=0 KILL XBMK Q ; IHS/SET/GTH XB*3*9 10/29/2002 + I X="%" D EN^XBNEW("%EDIT^XBVCH1","XBJ;XBROU") S XBLN=0 KILL XBMK Q ; IHS/SET/GTH XB*3*9 10/29/2002 + I X="^" S XBOUT=1 KILL XBMK Q + KILL XBMK + S XBJM="" + F S XBJM=$O(XB(XBJM)) Q:XBJM="" I $G(XB(XBJM,"M")) W *7 S XBMK=1 + KILL XBJM + I $A(X)=13 Q + D ^XBCLS + W !!! + W !?5,"'X' Set changes" + W !?5,"'Tab' or 'T' Move to next marker" + W !?5,"'Space bar' Toggel marker and move to next" + W !?5,"'CR' Skip to next line" + W !?5,"'R' Restart the current Routine" + W !?5,"'%' %E Edit Routine" + W !?5,"'N' Next Routine" + W !?5,"'^' Exit" + KILL DIR + S DIR(0)="E" + D ^DIR + G EDIT + ; +DISPLAY ; display line + ; XB(XBI,0)=POS XB("B",POS)=XBI XB("E",POS)=XBI XB(XBI,"M")=MARK (0 OR 1) + ; XBD(0) =underline-on,XBD(1)=Bold on,XBD(2)=Underline Off,XBD(3)=Bold Off,XBD("RVON")=RVON,XBD("RVOFF")=RVOFF + D:(XBVX=XBV0) ^XBCLS ;displaying current line + D:XBVX=XBV0 DISPROU + S DX=0,DY=0 + X XBXY + W ?5,"routine ",XBROU,?35,"line ",XBLN,!! + I XBVX=XBV1 W ! ;displaying new line + W XBD(6) + F XBI=1:1:$L(XBLINX) D + . I '(XBI#80) W !!! + . I $D(XB("B",XBI)) W XBD(XB(XB("B",XBI),"M")*2) + . W $E(XBLINX,XBI) + . I $D(XB("E",XBI)) W XBD(XB(XB("E",XBI),"M")*2+1) + .Q + W XBD(7) + Q:(XBVX=XBV1) ;no tab marker when displaying new line +TAB ; + S DY=+3,DX=XB(XBT,0)#80-1,DY=DY+(XB(XBT,0)\80*3) + S:DY>8 DX=DX+1 +TAB1 ; + X XBXY + W XBD(2),"|",XBD(3) + Q + ; +UPT ; SET TAB + S XBT=$G(XBT),XBT=$O(XB(XBT)) + I XBT'>0 S XBT=0 G UPT + KILL XB("T") + S XB("T",XB(XBT,0))="" + Q + ; +BLDLIN1 ; + S XBLIN0=XBLIN,XBSUB=XBV0_":"_XBV1,XBLIN1="" + F XBI=1:1 Q:'$D(XB(XBI)) S XBLIN1=XBLIN1_$E(XBLIN,$G(XB(XBI-1,"E"))+1,XB(XBI,0)-1)_$S(XB(XBI,"M"):XBV1,1:XBV0) + S XBI=XBI-1 + S XBLIN1=XBLIN1_$E(XBLIN,XB(XBI,"E")+1,999) + Q + ; +ACCEPT ; + D DISP0,BLDLIN1,SCAN1,DISP1 + KILL DIR + S DIR(0)="S^Y:ACCEPT;E:EDIT;S:SKIP;N:NEXT ROUTINE;Q:QUIT",DIR("B")="Y" + S X=$P(XBLINX," ",2,999) + F Q:$E(X)'=" " S X=$E(X,2,999) + F Q:$E(X)'="." S X=$E(X,2,999) + D ^DIM + I '$D(X) W *7,!,XBD(2),"FM DIM checker does not like this line !",XBD(3),!,XBD(2),XBLINX,XBD(3),! S DIR("B")="E" + D ^DIR + KILL DIR + I Y="N" S XBLN=999 Q + I Y="S" Q + I Y="E" D SCAN0,EDIT,CHKMK G:$G(XBMK) ACCEPT Q + I Y="Q" S XBOUT=1 Q + I Y'="Y" G ACCEPT + S XBEDIT=1 ; set edit markers + S XBLIN=XBLIN1,^XBVROU(XBJ,"R",XBROU,XBLN,0)=XBLIN ;set new line + Q + ; +%EDIT ; USE %E EDITOR + X "ZL @XBROU X ^%E" + KILL ^XBVROU(XBJ,"R",XBROU) + S X=XBROU,DIF="^XBVROU(XBJ,""R"","""_XBROU_""",",(XCNP,%N)=0 + X ^%ZOSF("LOAD") + S XBLIN=0 + Q + ; +SAVE ; SAVE NEW ROUTINE TO DISK + D ^XBCLS + X ^%ZOSF("UCI") + I Y["DEV," W !,"you are in DEV .. NO CHANGES" H 2 Q + I Y["PRD," W !,"you are in PRD .. NO CHANGES" H 2 Q + KILL DIR + S DIR(0)="Y",DIR("A")=XBROU_" has been changed. Save with Changes ?",DIR("B")="Y" + D ^DIR + KILL DIR + I 'Y W !?5,XBROU," NOT CHANGED" H 3 D ^XBCLS Q + W !?5,XBROU,"is being saved with changes",! + S XBSAV1="ZR",XBSAV2="F XBI=1:1 S XBX=$G(^XBVROU(XBJ,""R"",XBROU,XBI,0)) Q:'$L(XBX) ZI XBX",XBSAV3="ZS @XBROU" + X "X XBSAV1,XBSAV2,XBSAV3" + S ^XBVROU("PRT",$J,"VCHG",XBSUB,XBROU)="" + S ^XBVROU("PRT",$J,"RCHG",XBROU,XBSUB)="" + S ^XBVROU(XBJ,"NV",XBV1)="" + W !?5,XBROU,"SAVED WITH CHANGES" H 2 + Q + ; diff --git a/XBVCHV.m b/XBVCHV.m new file mode 100644 index 0000000..a0c8bc8 --- /dev/null +++ b/XBVCHV.m @@ -0,0 +1,50 @@ +XBVCHV ; IHS/ADC/GTH - PULL IN VARIABLES AND ROUTINES FROM A %INDEX ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; Thanks to Paul Wesley, DSD/OIRM, for the original routine. + ; +OPEN ; + D DT^DICRW + D ^XBCLS + W !!,"Select a %INDEX Summary that was put to disk",! + KILL DIR + S DIR(0)="F^1:30",DIR("A")="Directory ",DIR("B")="/usr/mumps/" + D ^DIR + KILL DIR + Q:Y["^" + S XBDIR=Y +FNAME ; + KILL DIR +FNAME1 ; + S DIR(0)="F^1:15",DIR("A")="File Name " + D ^DIR + KILL DIR + G:Y["^" OPEN + I Y?.N,$D(XBFL(Y)) S DIR("B")=XBFL(Y) G FNAME1 + I Y["*" KILL 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) + .Q + S XBFN=Y,X=$$OPEN^%ZISH(XBDIR,XBFN,"R") +ES ; + I X W !,"error on open of file ",XBDIR,XBFN,! KILL DIR S DIR(0)="E" D ^DIRQ:Y=1 G FNAME + S XBJ=$J,XBVRLC=0 + KILL ^XBVROU(XBJ,"V") + W !,"Looking for 'Indexed Routines:' ",! +READ ; + F XBI=1:1:20 U IO R X:DTIME U IO(0) W "." I X["Indexed Routines:" S XBOK=1 W !,"Found ! ... continuing" Q + I '$G(XBOK) KILL DIR + F XBI=1:1 U IO R X:DTIME Q:X["Local V" + F XBI=1:1 U IO R X:DTIME Q:X["Global " D + . Q:$L(X)<17 + . Q:$E(X,17)=" " + . I X[$C(13) S X=$P(X,$C(13)) + . S XBVARL=$G(XBVAR) + . I $E(X,4)'=" " S XBVAR="" F XBI=4:1 S XBX=$E(X,XBI) Q:" ("[XBX S XBVAR=XBVAR_XBX + . I XBVAR'=XBVARL S XBVRLC=0 + . S XBR=$E(X,17,999),XBR=$TR(XBR,"*!","") + . S XBVRLC=XBVRLC+1,^XBVROU(XBJ,"V",XBVAR,XBVRLC)=XBR + .Q + D ^%ZISC + S XBFILE=1 + Q + ; diff --git a/XBVDF.m b/XBVDF.m new file mode 100644 index 0000000..9ef89b7 --- /dev/null +++ b/XBVDF.m @@ -0,0 +1,50 @@ +XBVDF ; IHS/ASDST/DMJ - VIDEO DISPLAY FEATURES ; [ 10/07/2004 3:00 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 +EN(X) ;EP + I X="" Q X + I '$L($T(@X)) S X="" Q X + S XB1("X")=$X + I '$G(IOST(0)) S IOP=0 D ^%ZIS + I '$D(XBVDF(+IOST(0),X)) D + .S XB1("LN")=$T(@X),XB1(1)=$P(XB1("LN"),";;",2),XB1(2)=$P(XB1("LN"),";;",3),XB1(3)=$P(XB1("LN"),";;",4) + .S XBVDF(+IOST(0),X)=$P($G(^%ZIS(2,+IOST(0),XB1(1))),"^",XB1(2),XB1(3)) + .I XBVDF(+IOST(0),X)="" S XBVDF(+IOST(0),X)="*0" + W @XBVDF(+IOST(0),X) + S $X=XB1("X") + S X="" + K XB1 + Q X + ;GLOBAL LOCATIONS TO FOLLOW +HIN ;;7;;1;;1;;HI INTENSITY ON +HIX ;;7;;2;;2;;HI INTENSITY OFF +RVN ;;5;;4;;4;;REVERSE VIDEO ON +RVX ;;5;;5;;5;;REVERSE VIDEO OFF +ULN ;;6;;4;;4;;UNDERLINE ON +ULX ;;6;;5;;5;;UNDERLINE OFF +DTP ;;17;;1;;1;;DOUBLE HIGH TOP HALF +DTB ;;17;;2;;2;;DOUBLE HIGH BOTTOM HALF +BLN ;;5;;8;;8;;BLINK ON +BLX ;;5;;9;;9;;BLINK OFF +CUP ;;8;;1;;1;;CURSOR UP +IOF ;;1;;2;;2;;FORM FEED/CLEAR SCREEN +10 ;;5;;1;;1;;TEN PITCH +12 ;;5;;2;;2;;TWELVE PITCH +16 ;;12.1;;1;;250;;SIXTEEN PITCH +BKF ;;CLRBKF;;1;;1;;BLACK FOREGROUND +BKB ;;CLRBKB;;1;;1;;BLACK BACKGROUND +REF ;;CLRREF;;1;;1;;RED FOREGROUND +REB ;;CLRREB;;1;;1;;RED BACKGROUND +GRF ;;CLRGRF;;1;;1;;GREEN FOREGROUND +GRB ;;CLRGRB;;1;;1;;GREEN BACKGROUND +YEF ;;CLRYEF;;1;;1;;YELLOW FOREGROUND +YEB ;;CLRYEB;;1;;1;;YELLOW BACKGROUND +BLF ;;CLRBLF;;1;;1;;BLUE FOREGROUND +BLB ;;CLRBLB;;1;;1;;BLUE BACKGROUND +MGF ;;CLRMGF;;1;;1;;MAGENTA FOREGROUND +MGB ;;CLRMGB;;1;;1;;MAGENTA BACKGROUND +CYF ;;CLRCYF;;1;;1;;CYAN FOREGROUND +CYB ;;CLRCYB;;1;;1;;CYAN BACKGROUND +WHF ;;CLRWHF;;1;;1;;WHITE FOREGROUND +WHB ;;CLRWHB;;1;;1;;WHITE BACKGROUND +CLR ;;6;;1;;1;;RESET +HOM ;;5;;3;;3;;HOME CURSOR diff --git a/XBVIDEO.m b/XBVIDEO.m new file mode 100644 index 0000000..e82c0d9 --- /dev/null +++ b/XBVIDEO.m @@ -0,0 +1,70 @@ +XBVIDEO ; IHS/ADC/GTH - SET VIDEO ATTRIBUTES ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; Thanks to Don Jackson, DSD/OIRM, for the original routine. + ; + ; Set various video attributes. $X is saved and the cursor + ; is returned to it's original position thru X IOXY (except + ; certain attributes). + ; + ; In addition to the attributes supported by ENDR^%ZISS, + ; some color attributes are supported, and other mnemonics + ; to provide for backward compatibility. + ; + ; + Q + ; +EN(XB) ;PEP - Set video attribute in XB. E.g. D EN^XBVIDEO("IOBOFF"). + ; + Q:'$L($G(XB)) + Q:$D(ZTQUEUED) + ; + NEW DX,DY,XBXY + S DX=$X,DY=$Y,XBXY=0 + ; + I '$G(IOST(0)) D HOME^%ZIS + U IO(0) + ; + I $L($T(@XB)),$L($P($T(@XB),";;",6)) S XBXY=$P($T(@XB),";;",7),XB=$P($T(@XB),";;",6) + I $L($T(@XB^%ZISS)) S X=XB D ENDR^%ZISS W @XB X:XBXY IOXY U IO Q + ; + I '$L($T(@XB)) U IO Q + ; + S XB("LN")=$T(@XB),XB(1)=$P(XB("LN"),";;",2),XB(2)=$P(XB("LN"),";;",3),XB(3)=$P(XB("LN"),";;",4) + S XB=$P($G(^%ZIS(2,+IOST(0),XB(1))),"^",XB(2),XB(3)) + I XB="" S XB="*0" + W @XB + X:XBXY IOXY + U IO + Q + ; + ; Global locations for mnenomics and colors supported by %ZISS. + ; + ;;;;;;;;;;;; + ; +10 ;;5;;1;;1;;TEN PITCH;;IOPTCH10;;1 +12 ;;5;;2;;2;;TWELVE PITCH;;IOPTCH12;;1 +16 ;;12.1;;1;;250;;SIXTEEN PITCH;;IOPTCH16;;1 +BLF ;;5;;9;;9;;BLINK OFF;;IOBOFF;;1 +BLN ;;5;;8;;8;;BLINK ON;;IOBON;;1 +CLR ;;6;;1;;1;;RESET;;IORESET;;1 +CUP ;;8;;1;;1;;CURSOR UP;;IOCUU;;0 +DTB ;;17;;2;;2;;DOUBLE HIGH BOTTOM HALF;;IODHLB;;0 +DTP ;;17;;1;;1;;DOUBLE HIGH TOP HALF;;IODHLT;;0 +HIF ;;7;;2;;2;;HI INTENSITY OFF;;IOINORM;;1 +HIN ;;7;;1;;1;;HI INTENSITY ON;;IOINHI;;1 +HOM ;;5;;3;;3;;HOME CURSOR;;IOHOME;;0 +IOF ;;1;;2;;2;;FORM FEED/CLEAR SCREEN;;;;0 +RVF ;;5;;5;;5;;REVERSE VIDEO OFF;;IORVOFF;;1 +RVN ;;5;;4;;4;;REVERSE VIDEO ON;;IORVON;;1 +ULF ;;6;;5;;5;;UNDERLINE OFF;;IOUOFF;;1 +ULN ;;6;;4;;4;;UNDERLINE ON;;IOUON;;1 + ; + ; Global locations for mnenomics and colors UN-supported by %ZISS. + ;;;;;;;;;;<>;; +CYB ;;C;;3;;3;;CYAN BACKGROUND;;;;1 +GRF ;;C;;1;;1;;GREEN FOREGROUND;;;;1 +REB ;;C;;5;;5;;RED BACKGROUND;;;;1 +WHF ;;C;;4;;4;;WHITE FOREGROUND;;;;1 +YEF ;;C;;2;;2;;YELLOW FOREGROUND;;;;1 + ; diff --git a/XBVK.m b/XBVK.m new file mode 100644 index 0000000..de12b03 --- /dev/null +++ b/XBVK.m @@ -0,0 +1,37 @@ +XBVK ; IHS/ADC/GTH - LOCAL VARIABLE KILLER FRONT END ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent INDIR on NT systems. + ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 NT and Cache' mods. + ; + ; This is the front end for killing local variables in the + ; namespaced parameter. Implementation specific routines + ; are called from this routine. Those routines are in the + ; ZIBVK* namespace. + ; + ; This routine is intended to be called by applications + ; that are thru executing, in order to KILL any remaining + ; namespaced local variables. E.g., D EN^XBVK("AG") will + ; KILL any local variables that exist in the AG namespace. + ; + ; Notice that if called in background, and the OS is not + ; supported, the routine will quit, unpleasantly. If your + ; implementation is other than what is supported, below, + ; and your vendor has implemented all Type A extensions to + ; the 1990 ANSI M standard, you can safely remove the two + ; lines that check for OS, and use the existing call to + ; the MSM-specific routine. + ; + Q + ; +EN(XBVK) ;PEP - Kill vars in namespace of parameter variable. + ; + ; I '$L($T(@$P(^%ZOSF("OS"),"-",1))) W !,*7,"OPERATING SYSTEM '",$P(^%ZOSF("OS"),"-",1),"' NOT SUPPORTED." Q ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent INDIR on NT systems. + ; I $P(^%ZOSF("OS"),"^",1)'["MSM" W !,*7,"OPERATING SYSTEM '",$P(^%ZOSF("OS"),"^",1),"' NOT SUPPORTED." Q ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent INDIR on NT systems. ; IHS/SET/GTH XB*3*9 10/29/2002 + I $P(^%ZOSF("OS"),"^",1)'["MSM",$P(^%ZOSF("OS"),"^",1)'["OpenM" W !,*7,"OPERATING SYSTEM '",$P(^%ZOSF("OS"),"^",1),"' NOT SUPPORTED." Q ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent INDIR on NT systems. ; IHS/SET/GTH XB*3*9 10/29/2002 + ; G @$P(^%ZOSF("OS"),"-",1) ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent INDIR on NT systems. + I $P(^%ZOSF("OS"),"^",1)["OpenM" D EN^ZIBVKCA(XBVK) Q ; IHS/SET/GTH XB*3*9 10/29/2002 + ; +MSM ; Micronetics Standard MUMPS. + D EN^ZIBVKMSM(XBVK) + Q + ; diff --git a/XBVL.m b/XBVL.m new file mode 100644 index 0000000..93e2525 --- /dev/null +++ b/XBVL.m @@ -0,0 +1,24 @@ +XBVL ; IHS/ADC/GTH - LOCAL VARIABLE LISTER FRONT END ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent err. + ; XB*3*9 IHS/SET/GTH 06/05/2002 Cache' mods. + ; + ; This is the front end for listing local variables. + ; Implementation specific routines are called from this + ; routine. Those routines are in the ZIBVL* namespace. + ; + ; I '$L($T(@$P(^%ZOSF("OS"),"-",1))) W !,*7,"OPERATING SYSTEM '",$P(^%ZOSF("OS"),"-",1),"' NOT SUPPORTED." Q ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent err. + ; G @$P(^%ZOSF("OS"),"-",1) ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent err. + I ($$VERSION^%ZOSV(1)["Cache")!($$VERSION^%ZOSV(1)["MSM") G ^ZIBVL ;IHS/SET/GTH XB*3*9 10/29/2002 + ; I $P(^%ZOSF("OS"),"^",1)["MSM" G MSM ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent err. ;IHS/SET/GTH XB*3*9 10/29/2002 + W !,*7,"OPERATING SYSTEM '",$P(^%ZOSF("OS"),"^",1),"' NOT SUPPORTED." ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent err. + Q ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent err. + ; +MSM ; Micronetics Standard MUMPS. + G ^ZIBVLMSM + ; +MESSAGE ;EP - Tell user of limitations. + W !!?5,"DO routine ^XBVL from programmer mode." + W !?5,"Not all local variables are available thru the XB menu.",!! + Q + ; diff --git a/XBVLINE.m b/XBVLINE.m new file mode 100644 index 0000000..1ee6a72 --- /dev/null +++ b/XBVLINE.m @@ -0,0 +1,52 @@ +XBVLINE ; IHS/ADC/GTH - SET LINE TWO OF SELECTED ROUTINES ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods. + ; + ; This routine asks user 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 + KILL ^UTILITY($J) + D ^XBKVAR + X ^%ZOSF("RSEL") + I $D(^UTILITY($J,"XBVLINE")) W !,"Can't do ^XBVLINE. Deleting." KILL ^UTILITY($J,"XBVLINE") + I $D(^UTILITY($J,"XB")) W !,"Can't do ^XB. Deleting." KILL ^UTILITY($J,"XB") + I $O(^UTILITY($J,""))="" D EOJ Q + S XBVLINE=" ;;"_$$DIR^XBDIR("F^1:5^K:'(X?1.3N!(X?1.3N.1""."".2N.1A.2N)) X","Enter version number","","","Must be n or n.n or n.nAn where the length of n is 1-3 and A is an alpha character") + I $D(DIRUT) D EOJ Q + S XBVLINE=XBVLINE_";"_$$DIR^XBDIR("FO^2:30","Enter package name") + I $D(DIRUT) D EOJ Q + S X=$$DIR^XBDIR("FO^0:20","Enter patch level") + I $D(DUOUT)!$D(DTOUT) D EOJ Q + S XBVLINE=XBVLINE_$S(X="":";",1:";**"_X_"**") + ;begin Y2K fix block + ;S Y=$$DIR^XBDIR("D","Enter date","TODAY") + S Y=$$DIR^XBDIR("D^::E","Enter date","TODAY") + ; end Y2K fix block + I $D(DIRUT) D EOJ Q + D DD^%DT + S XBVLINE=XBVLINE_";"_Y + S ASK=$$DIR^XBDIR("YO","Do you want to be asked ok for each routine","NO","","If you say 'YES' you will be asked if it is ok before each routine is modified.") + I $D(DIRUT) D EOJ Q + F %=1:1:6 S X=$P($T(@("LINE"_%)),";;",2),@("XBVLINE("_%_")=X") + KILL %,X,Y + X XBVLINE(1) + Q + ; +EOJ ; + KILL %,X,Y,XBVLINE,^UTILITY($J),DTOUT,DUOUT,DIRUT,DIROUT + Q + ;IHS/SET/GTH XB*3*9 10/29/2002 Mod'd LINE2 to seed RTN with 0 vs "". +LINE1 ;;X XBVLINE(2),XBVLINE(5) +LINE2 ;;S QUIT=0,RTN=0 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) diff --git a/XBX12R.m b/XBX12R.m new file mode 100644 index 0000000..291c917 --- /dev/null +++ b/XBX12R.m @@ -0,0 +1,60 @@ +XBX12R ;IHS/ASDST/DMJ - READ X12 FILE [ 08/10/2004 12:13 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 +START ;start + D LOAD + D ^%ZISC + D VIEW + F D V2 Q:$G(XB12QUIT) + K ^TMP($J,"XB12") + K XB12QUIT,XB12CTR,XB12REC + Q +LOAD ;load file into global + W !!,"Load File",! + S %ZIS("B")="HFS" + D ^%ZIS + Q:POP + K ^TMP($J,"XB12") + S XB12REC="" + S XB12CTR=0 + S XB12CTR2=0 + S XB12DLM="" + F D Q:$$STATUS^%ZISH + .U IO R X#1 + .Q:$$STATUS^%ZISH + .S XB12CTR2=XB12CTR2+1 + .I XB12CTR2=106 S XB12DLM=X + .I X=XB12DLM D FILE Q + .S XB12REC=XB12REC_X + Q +FILE ;file + S XB12CTR=XB12CTR+1 + S ^TMP($J,"XB12",XB12CTR)=XB12REC + S XB12REC="" + Q +VIEW ;view + S DA=0 + F S DA=$O(^TMP($J,"XB12",DA)) Q:'DA D + .S XB12CTR=DA + W !,XB12CTR," segments loaded.",! + Q +V2 ;view continued + W ! + S DIR(0)="LOC^1:"_XB12CTR + S DIR("A")="View lines" + D ^DIR K DIR + I Y["^" S XB12QUIT=1 Q + I Y="" S Y="1-"_XB12CTR + S XB12FR=+$P(Y,"-",1) + S XB12TO=+$P(Y,"-",2) + S:'XB12TO XB12TO=XB12FR + W @IOF + F I=XB12FR:1:XB12TO D Q:$G(XB12QUIT) + .I $Y+4>IOSL D + ..S DIR(0)="E" D ^DIR K DIR + ..I X["^" S XB12QUIT=1 + ..W @IOF + .Q:$G(XB12QUIT) + .W ! + .W "(",I,") " + .W ^TMP($J,"XB12",I) + Q diff --git a/XBXTSS.m b/XBXTSS.m new file mode 100644 index 0000000..748215a --- /dev/null +++ b/XBXTSS.m @@ -0,0 +1,24 @@ +XBXTSS ;OHPRD-TUCSON/BRJ;EXTRACT AND TABLE SUBSCRIPTS + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; X=SUBSCRIPT LIST ENCLOSED IN PARENTHESES PASSED BY CALLER + ; Y IS RETURNED AS: + ; Y=0 X VALUE NOT A PROPER SUBSCRIPT FORMAT + ; OR (SOME KIND OF ERROR ENCOUNTERED) + ; Y=n n=NUMBER OF SUBSCRIPTS IN X + ; Y(n)=value ARRAY OF SUBSCRIPTS + ; n=SUBSCRIPT POSITION + ; value=SUBSCRIPT VALUE +EN ; ENTRY + S $ZT="ZT" ; SET ERROR TRAP IN CASE OF BAD VALUE IN X + K ^XBXTSS,Y ; REMOVE POSSIBLE GARBAGE + S @("^XBXTSS"_X)="" ; SET DUMMY GLOBAL NODE + ; USE NAKED REFERENCE TO HOP DOWN SUBSCRIPTS AND STACK THEM IN Y + S XBSS=$O(^XBXTSS("")) ; GET FIRST SUBSCRIPT - SET NAKED FOR NEXT LINE + F Y=1:1 S Y(Y)=XBSS,XBSS=$O(^(XBSS,"")) Q:XBSS="" ;STACK SUBSCRIPTS IN Y(Y) + K XBSS,^XBXTSS ; CLEANUP + Q ; RETURN TO CALLER +ZT ; TRAP ERRORS RETURN Y=0 + S $ZE="",$ZT="" + K Y + S Y=0 ; RETURN ERROR TO CALLER + Q diff --git a/ZIBCKPKG.m b/ZIBCKPKG.m new file mode 100644 index 0000000..cb8f00e --- /dev/null +++ b/ZIBCKPKG.m @@ -0,0 +1,175 @@ +ZIBCKPKG ; IHS/ADC/GTH - CHECK UCI FOR PACKAGE CONTENT ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ;XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Change MSM systax to use $ROUTINE. + D INIT + S XBQUEST=1 D ASKIT G:XBQ=U EXIT S XBINPR=XBQ + S XBQUEST=2 D ASKIT G:XBQ=U EXIT S XBLC=XBQ + S XBQUEST=3 D ASKIT G:XBQ=U EXIT S XBLNPR=XBQ + ; +ZIS ; SELECT DEVICE + KILL ZTSK,IOP,%ZIS + S %ZIS="PQM" + D ^%ZIS + G:POP EXIT + G:$D(IO("Q")) QUE +NOQUE ; + U IO + D EN + D ^%ZISC + G EXIT + ; +QUE ; + KILL ZTSAVE + F %="XBINPR","XBLNPR","XBLC" S ZTSAVE(%)="" + S ZTRTN="EN^ZIBCKPKG",ZTDESC="SCAN UCI FOR PACKAGES",ZTIO=IO,ZTDTH=0 + D ^%ZTLOAD + KILL ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK +EXIT ; + D KILLS + Q + ; +EN1 ; ENTRY FOR SILENT OPERATION + D INIT + S (XBINPR,XBLC)=1 + G EN + ; +INIT ; INITIALIZATION + S U="^" + S:'$D(DTIME) DTIME=300 + Q + ; +EN ; COMMON INTERNAL ENTRY + S XBQUIT=0 + KILL ^UTILITY($J,"ZIBCKPKG") + D SCAN + Q:XBQUIT + D:XBLNPR SHOWNPR + D:XBLC SHOWLC + I $D(IOST),$D(IOF),$E(IOST,1,2)="P-" W @IOF + SET:$D(ZTQUEUED) ZTREQ="@" +KILLS ; + KILL XBINPR,XBRNPR,XBLNPR,XBLC,XBQUIT,XBR,XBR2,XBPF,XBI,XBJ,XBP,XBQ,XBCNT,XBQUEST + KILL ^UTILITY($J,"ZIBCKPKG"),ZTSK + Q + ; +SCAN ; + X ^%ZOSF("UCI") + W "- - - PACKAGE SCAN OF UCI ",Y,$S($D(^DD("SITE")):" ON "_^("SITE"),1:"")," - - -",!! + ; S XBR=$O(^ ("%zzzzzzz")) ;IHS/SET/GTH XB*3*9 10/29/2002 + S XBR=$O(^$R("%zzzzzzz")) ;IHS/SET/GTH XB*3*9 10/29/2002 + F Q:XBR="" Q:XBR?1L.E D CHKPKG Q:XBQUIT + Q:XBQUIT + F Q:XBR="" D GETNXT + Q + ; +CHKPKG ; CHECK FOR PACKAGE + S XBPF=$E(XBR,1,4) + F XBI=$L(XBPF):-1:0 S XBPF=$E(XBPF,1,XBI) Q:XBPF="" S XBP=$O(^DIC(9.4,"C",XBPF,0)) Q:XBP + I XBPF="" D NOTPKG Q + W XBPF,?4," - ",$P(^DIC(9.4,XBP,0),U,1) + S XBRNPR=0 + D SKIP + W " (",XBCNT,")",! + Q + ; +NOTPKG ; + I XBINPR S ^UTILITY($J,"ZIBCKPKG",2,XBR)="" S XBPF="" D GETNXT Q + F W XBR R " -- Package prefix? ",XBPF:DTIME S:'$T XBPF=U Q:XBPF[U D GETPKG Q:XBPF'="-" + I XBPF[U S XBQUIT=1 Q + W ! + I XBPF="" D GETNXT Q + S XBI=$L(XBPF),XBRNPR=1 + D SKIP + W " ",XBCNT," ROUTINES SKIPPED.",! + Q + ; +GETPKG ; + I XBPF?1."?" S XBQUEST=4 D DSPHLP W ! S XBPF="-" Q + I XBPF?1."?"1.E D DSPLY S XBPF="-" Q + Q:XBPF'?.E1CL.E&($L(XBPF)<5) + W " -- Package id must be upper case, length 1-4",! + S XBPF="-" + Q + ; +SKIP ; + F XBCNT=1:1 S:XBRNPR ^UTILITY($J,"ZIBCKPKG",2,XBR)="" D GETNXT Q:$E(XBR,1,XBI)'=XBPF + Q + ; +GETNXT ; + S:XBR?.E1L.E ^UTILITY($J,"ZIBCKPKG",1,XBR)="" + ; S XBR=$O(^ (XBR)) ;IHS/SET/GTH XB*3*9 10/29/2002 + S XBR=$O(^$R(XBR)) ;IHS/SET/GTH XB*3*9 10/29/2002 + Q + ; +DSPLY ; + S (XBPF,XBR2)=$E(XBPF,2,$L(XBPF)) + W ! + S XBJ=0 + S X=XBR2 + X ^%ZOSF("TEST") + I S XBJ=1 W !,XBR2 + ; F XBJ=XBJ:1 S XBR2=$O(^ (XBR2)) Q:$E(XBR2,1,$L(XBPF))'=XBPF W:XBJ#8=0 ! W ?XBJ#8*10,XBR2 ;IHS/SET/GTH XB*3*9 10/29/2002 + F XBJ=XBJ:1 S XBR2=$O(^$R(XBR2)) Q:$E(XBR2,1,$L(XBPF))'=XBPF W:XBJ#8=0 ! W ?XBJ#8*10,XBR2 ;IHS/SET/GTH XB*3*9 10/29/2002 + W:$X ! + W ! + Q + ; +SHOWNPR ; + Q:'$D(^UTILITY($J,"ZIBCKPKG",2)) + W !!,"Non-package routines:",! + S XBR2="" + F XBJ=0:1 S XBR2=$O(^UTILITY($J,"ZIBCKPKG",2,XBR2)) Q:XBR2="" W:XBJ#8=0 ! W ?XBJ#8*10,XBR2 + W ! + Q + ; +SHOWLC ; + Q:'$D(^UTILITY($J,"ZIBCKPKG",1)) + W !!,"Routine names containing lower case letters:",! + S XBR2="" + F XBJ=0:1 S XBR2=$O(^UTILITY($J,"ZIBCKPKG",1,XBR2)) Q:XBR2="" W:XBJ#8=0 ! W ?XBJ#8*10,XBR2 + W ! + Q + ; +ASKIT ; ASK A YES/NO QUESTION + KILL XBQ + S %=$T(@XBQUEST),XBQ("Q")=$P(%,";;",2),XBQ("D")=$P(%,";;",3) +ASKIT2 ; + W !,XBQ("Q")," ",XBQ("D"),"// " + R XBQ:DTIME + S:'$T XBQ=U + I XBQ="" S XBQ=XBQ("D") W XBQ + S XBQ("R")=XBQ,XBQ="" + I XBQ("R")[U S XBQ=U + I $P("YES",XBQ("R"))="" S XBQ=1 + I $P("yes",XBQ("R"))="" S XBQ=1 + I $P("NO",XBQ("R"))="" S XBQ=0 + I $P("no",XBQ("R"))="" S XBQ=0 + I XBQ]"" W ! Q + W !,"-- Please answer YES or NO" + D DSPHLP + G ASKIT + ; +DSPHLP ; + F XBI=1:1 S %=$T(@XBQUEST+XBI) Q:%="" Q:$P(%," ")]"" W !,"-- ",$P(%,";;",2) + W ! + KILL % + Q + ; +QUEST ; + ; +1 ;;Ignore non-package routines?;;YES + ;;Responding NO will cause you to be asked if a routine for which + ;;a namespace cannot be identified in the package file can be + ;;considered part of a "psuedo-package" with which a namespace can + ;;be associated. +2 ;;Display routine names containing lower case letters?;;YES + ;;Responding YES will cause a tabular listing to be produced + ;;displaying all routine names which contain a lower case letter. +3 ;;Display names of non-package routines?;;YES + ;;Responding YES will cause a tabular listing to be produced + ;;displaying the names of all routines which were not found + ;;to be part of a package. +4 ;; + ;;If you enter a namespace, routines will be processed as though a + ;;formal package association was made. diff --git a/ZIBCLU.m b/ZIBCLU.m new file mode 100644 index 0000000..8f86712 --- /dev/null +++ b/ZIBCLU.m @@ -0,0 +1,29 @@ +ZIBCLU ; IHS/ADC/GTH - GENERAL PURPOSE CLEAN UP UTILITY GLOBALS - DRIVER TO GET UCI ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ;THIS ROUTINE WILL INITIATE A JOB RUNNING ^%ZIBCLU0 IN EACH UCI + ;AND THEN WAIT 5 SECONDS TO ELAPSE BEFORE GETTING THE NEXT UCI + ;SKIP THE UCI THIS TASK IS IN AND THEN RUN ^%ZIBCLU0 HERE + ; - %ZIBCLU0 WILL REMOVE ALL DANGLING ^UTILITY,^XUTL,^ZUT ENTRIES + ;THIS ROUTINE IS USUALLY STARTED VIA TASKMAN BY SCHEDULING + ;THE -ZIBCLU- OPTION WHICH RUNS THIS ROUTINE + ; + ;DSM ONLY - $ZU(ZIBI) RETURNS ERROR AT END OF UCI LIST + ;MSM ONLY - $ZU(ZIBI) RETURNS -NULL- VALUE AT END OF UCI LIST + ; + W !,*7,"Entry not permitted here!" + Q + ; +EN ; + S X="%ZIBCLU0" + D RCHK^XB + I $G(XBFAIL) W:'$D(ZTQUEUED) !,"Cannot proceed because ^%ZIBCLU0 is not in MGR" Q + S $ZT="ZT^ZIBCLU" + F ZIBI=1:1 S ZIBUCI=$ZU(ZIBI) Q:ZIBUCI="" I ZIBUCI'=$ZU(0) J ^%ZIBCLU0[ZIBUCI] H 5 + D ^%ZIBCLU0 ; CLEAN UP THIS UCI +ZT ;END OF UCI LIST + I $ZV?1"DSM".E&($ZE'?1"".E) D ^%ET + S $ZT="" + KILL XBFAIL,ZIBI,ZIBUCI + Q + ; diff --git a/ZIBCLU0.m b/ZIBCLU0.m new file mode 100644 index 0000000..723572f --- /dev/null +++ b/ZIBCLU0.m @@ -0,0 +1,76 @@ +%ZIBCLU0 ; IHS/ADC/GTH - GENERAL PURPOSE CLEAN UP UTILITY GLOBALS ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 +EN ; + Q:'($ZV?1"MSM".E!($ZV?1"DSM".E)) ; Only works for MSM or DSM. + S ZIBOS=$ZV ; Set operating system. + D @$S(ZIBOS?1"DSM".E:"DSM",1:"MSM") ; Active JOB lookup per operating system. + D XUT ; Cleanup the ^XUTL global. + F ZIBGR="^ZUT(","^UTILITY(" D GO ; Check the ^ZUT and ^UTILITY globals for nodes to be removed. + D OUT ; KILL off variables and exit gracefully. + Q + ; +MSM ; MSM specific look up of active JOBs. + S $ZT="MER^%ZIBCLU0" + V 44:$J:$ZB($V(44,$J,2),1,7):2 + S ZIBST=$V(44),ZIBSTA=$V(ZIBST+8,-3,2)+ZIBST,ZIBMXJ=$V($V(ZIBST+284),-3,4),ZIBPT=$V(3*4+ZIBSTA) + ; Build active JOB table (ZIBJT). + F ZIBJ=1:1:ZIBMXJ S:$V(ZIBJ*4+ZIBPT) ZIBJT(ZIBJ)=$ZU(($V(2,ZIBJ,2)#32),($V(2,ZIBJ,2)\32)) + Q + ; +MER ;EP - MSM error trap. + V 44:$J:$ZB($V(44,$J,2),#FFFE,1):2 + ZQ + ; +DSM ; DSM specific look up of active JOBs. + S ZIBST=$V(44),ZIBSJT=$V(ZIBST+4) + ; Build active JOB table (ZIBJT). + F ZIBI=ZIBSJT+2:2:ZIBSJT+126 I $V(ZIBI+1),$V(ZIBI+1)'=244 S ZIBJ=ZIBI-ZIBSJT\2 S:ZIBJ]"" ZIBJT(ZIBJ)=$ZU(($V(149,ZIBJ)#32),($V(149,ZIBJ)\32)) + S ZIBJT($J)=$ZU(0) ; Put this JOB and UCI in the JOB table. + KILL ZIBSJT + Q + ; +XUT ; Clenaup ^XUTL in MGR separate from other UCIs. + I $ZU(0)?1"MGR".E D + . S ZIBJ="" + . F S ZIBJ=$O(^XUTL("XQ",ZIBJ)) Q:ZIBJ="" KILL:'$D(ZIBJT(ZIBJ)) ^(ZIBJ) + E D + .S ZIBJ="" + .S ZIBK=1 ; Set KILL flag ON - Set OFF if other JOBs active in this UCI + .F S ZIBJ=$O(ZIBJT(ZIBJ)) Q:ZIBJ="" S:ZIBJ'=$J&(ZIBJT(ZIBJ)=$ZU(0)) ZIBK=0 + .I ZIBK S ZIBX="" F S ZIBX=$O(^XUTL(ZIBX)) Q:ZIBX="" KILL ^(ZIBX) + Q + ; +GO ; $O down ^ZUT or ^UTILITY looking for (jobnbr OR (namespace,jobnbr + S ZIBX1="" + F S (ZIBA,ZIBJ,ZIBX1)=$O(@(ZIBGR_""""_ZIBX1_""")")) Q:ZIBX1="" D @$S(ZIBX1?1N.N:"N1",1:"N2") +GOQ ; + Q + ; +N1 ; Check first subscript value and remove if its a dangling node. + I ZIBOS?1"MSM".E,ZIBX1="%ER" D N2 G N1Q + D RM +N1Q ; + Q + ; +N2 ; Process second node if first is non-numeric or ^UTILITY("%ER" for MSM + S ZIBX2="",ZIBA1=""""_ZIBA_"""" + F ZIBI=1:1 S ZIBRM=1,ZIBX2=$O(@(ZIBGR_""""_ZIBX1_""","""_ZIBX2_""")")) D D:ZIBRM RM Q:ZIBX2="" + .I ZIBOS?1"MSM".E,ZIBX1="%ER",($P($H,",")-ZIBX2)<7 S ZIBRM=0 Q + .I ZIBX2]"" S ZIBA=ZIBA1_","""_ZIBX2_"""",ZIBJ=ZIBX2 + KILL ZIBRM + Q + ; +RM ; Remove dangling ^UTILITY node. + ; If not in active JOB table '$D(ZIBJT(ZIBJ)) + ; Or if an active JOB and not this UCI $D(ZIBJT(ZIBJ) & ZIBJT(ZIBJ)'=$Z(0) + ; Or if an active JOB and this UCI, but the same $J as this JOB. + I $D(ZIBJT(ZIBJ)),ZIBJT(ZIBJ)=$ZU(0),$J'=ZIBJ G RMQ + KILL @(ZIBGR_ZIBA_")") ; Remove dangling ^ZUT or ^UTILITY node. +RMQ ; + Q + ; +OUT ; + KILL ZIBOS,ZIBA,ZIBA1,ZIBX1,ZIBX2,ZIBST,ZIBJT,ZIBJM,ZIBJI,ZIBJ,ZIBQ,ZIBGR,ZIBSTA,ZIBMXJ,ZIBPT,ZIBK + I $ZV?1"MSM".E V 44:$J:$ZB($V(44,$J,2),#FFFE,1):2 + Q + ; diff --git a/ZIBDR.m b/ZIBDR.m new file mode 100644 index 0000000..337a292 --- /dev/null +++ b/ZIBDR.m @@ -0,0 +1,21 @@ +ZIBDR ; IHS/ADC/GTH - SAVES DIR STRING TO EDITORS ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods. + ; + ; The string is stored in the "Temp" storage area for the + ; screen and line editors for the current device. + ; +SAVE(ZIBDIR) ;EP - Save string in editor global locations. + ; I ^%ZOSF("OS")'["MSM" D OSNO^XB Q ; Only supports Micronetics. ;IHS/SET/GTH XB*3*9 10/29/2002 + I ^%ZOSF("OS")'["MSM",'(^%ZOSF("OS")["OpenM") D OSNO^XB Q ;IHS/SET/GTH XB*3*9 10/29/2002 + I $$VERSION^%ZOSV(1)["MSM" D Q ;IHS/SET/GTH XB*3*9 10/29/2002 + . W !!!,"Saving the following line of code in",!,"^%ZUT($I,""Temp"") for the ^%E editor,",!,"and ^ZUT($I,""Temp"") for the ^% editor:",!,ZIBDIR ;IHS/SET/GTH XB*3*9 10/29/2002 + . KILL ^%ZUT($I,"Temp") ;IHS/SET/GTH XB*3*9 10/29/2002 + . S ^%ZUT($I,"Temp",1)=ZIBDIR,^%ZUT($I,"Temp",0)="Temporary storage" ;IHS/SET/GTH XB*3*9 10/29/2002 + .Q ;IHS/SET/GTH XB*3*9 10/29/2002 + ;W !!!,"Saving the following line of code in",!,"^%ZUT($I,""Temp"") for the ^%E editor,",!,"and ^ZUT($I,""Temp"") for the ^% editor:",!,ZIBDIR ;IHS/SET/GTH XB*3*9 10/29/2002 + W !!!,"Saving the following line of code in",!,"^ZUT($I,""Temp"") for the ^% editor:",!,ZIBDIR ;IHS/SET/GTH XB*3*9 10/29/2002 + ; KILL ^%ZUT($I,"Temp") S ^%ZUT($I,"Temp",1)=ZIBDIR,^%ZUT($I,"Temp",0)="Temporary storage" ;IHS/SET/GTH XB*3*9 10/29/2002 + KILL ^ZUT($I,"Temp") S ^ZUT($I,"Temp",1)=ZIBDIR,^ZUT($I,"Temp",0)="Temporary storage" + Q + ; diff --git a/ZIBER.m b/ZIBER.m new file mode 100644 index 0000000..8982148 --- /dev/null +++ b/ZIBER.m @@ -0,0 +1,72 @@ +ZIBER ;BFH;MSM ERROR REPORT; [ 07/17/91 12:19 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;COPYRIGHT MICRONETICS DESIGN CORP @1982 + S $ZT="ERROR^ZIBER",%DEV=$I + W !?10,$P($P($ZV,","),"-")," - Error Report Utility" + I '$D(^UTILITY("%ER")) W !!,"NO ERRORS HAVE BEEN LOGGED" G EXIT + D ^%GUCI K %,%UCN + G PACKAGE +OPT I $D(%AZ("PACKAGE")) K %AZ G PACKAGE + U 0 W !!,?5,"1 - Display errors",!,?5,"2 - Print errors",!,?5,"3 - Erase errors",!,?5,"4 - Summarize errors" + R !!,"Enter option: ",%X G EXIT:"^Q"=%X!("^"[%X) + I %X="?" S %XQF="7,8,9,6,3,4" D QUE^ZIBER1 G OPT + I $E("Display",1,$L(%X))=%X W $E("Display",$L(%X)+1,99) S %SUM=0 G DAT + I %X=1 W " - Display" S %SUM=0 G DAT + I $E("Print",1,$L(%X))=%X W $E("Print",$L(%X)+1,99) G PRINT^ZIBER1 + I %X=2 W " - Print" G PRINT^ZIBER1 + I $E("Erase",1,$L(%X))=%X W $E("Erase",$L(%X)+1,99) G DELETE^ZIBER1 + I %X=3 W " - Erase" G DELETE^ZIBER1 + I $E("Summarize",1,$L(%X))=%X W $E("Summarize",$L(%X)+1,99) G DAT1 + I %X=4 W " - Summarize" G DAT1 + W *7," ..Invalid" G OPT + ; +PACKAGE W ! K DIC S DIC(0)="QEAM",DIC=9.4 D ^DIC G EXIT:Y<1!$D(DTOUT)!$D(DUOUT) S %AZ("PACKAGE")=$P(^DIC(9.4,+Y,0),U,2) D ^%GUCI K %,%UCN G DAT1 + ; +DAT S %DIS=1,FLG=0 R !!,"Enter date > ",%X G OPT:"^"[%X,EXIT:%X="^Q",DINFO:%X="?" D DCHK^ZIBER1 G DAT:%QF,NE + ; +DAT1 S %DEL=0,%DIS=0,%SUM=1 ;ENTRY POINT TO SUMMARIZE ERRORS + G DAT^ZIBER1 +DINFO S %J=$N(^UTILITY("%ER",-1)) I %J<0 W !!,"No errors have been logged for this UCI" G EXIT + W !!,"Errors have been logged for the following days: " + F %J=$N(^UTILITY("%ER",-1)):0 Q:%J<0 S %I=%J W "T",$P(",-",",",%I<+$H+1) W:+$H-%I +$H-%I,"," S %J=$N(^(%J)) + S %XQF="1,2,11" D QUE^ZIBER1 G DAT +DINFO1 S %J=$N(^UTILITY("%ER",-1)) I %J<0 W !!,"No errors have been logged for this UCI" G EXIT + W !!,"Errors have been logged for the following days: " + F %J=$N(^UTILITY("%ER",-1)):0 Q:%J<0 S %I=%J W "T",$P(",-",",",%I<+$H+1) W:+$H-%I +$H-%I,"," S %J=$N(^(%J)) + S %XQF="1,2,11,12,20" D QUE^ZIBER1 G DAT1:%SUM,DAT^ZIBER1 +NE S %NE=$D(^UTILITY("%ER",%DAT,0)) I '%NE D E1 G DAT1:%SUM,DAT + S %NE=^(0) D E1 +ERR K %LIST R !!,"Error # > ",%X G DAT:"^"[%X,EXIT:%X="^Q" I %X="^L" G:%NE>0 LIST D E1 G ERR + I %X="?" D E1 S %XQF="1,2,14,18" D QUE^ZIBER1 G ERR + I %X'?1N.N!(%X>%NE) W *7," ..Invalid" G ERR + S %NUM=%X + I '$D(^UTILITY("%ER",%DAT,%NUM,0)) W !!,"Error not on file" G ERR +WRT R !!,"Symbol > ",%X G ERR:"^"[%X,EXIT:%X="^Q",PMODE:%X="^S" + I %X="?" S %XQF="1,2,13,10,15,16" D QUE^ZIBER1 G WRT + S %FND=1,%Q=0 I %X="^L" S %SYM="" G WF^ZIBER1 + S %SYM=%X G WF^ZIBER1 +E1 S %A=%NE S:'%A %A="NO" W !,%A," ERROR" W:%A'=1 "S" W " LOGGED ON ",$ZD(%DAT) Q +E2 W !!,"No errors logged between ",$ZD(%DAT)," and " + S %DAT=%D2 W $ZD(%DAT) Q +EXIT U 0 S $ZT="" C:%DEV'=$I %DEV +KILL K %A,%B,%CASE,%D,%D1,%D2,%DAT,%DEL,%DEV,%DIS,%DUM,%FND,%I,%J,%K,%L,%M,%LIST,%NE,%NE1,%NUM,%PG,%Q,%QF,%RDTE,%RTME,%SYM,%TAG,%UCI,%SUM,%X,%XQF,%Y,%Z,FLG,X,%AZ Q +LIST S %LIST=1,%J=0,FLG=0 W ! S $Y=0 +L1 S %J=%J+1 G:%J>%NE ERR + I $D(%AZ("PACKAGE")) S %AZ("P")=%J D TMD2^ZIBER1 I '%AZ("PHIT") S %J=%J-1 G L1 + I $D(^UTILITY("%ER",%DAT,%J,0)) D:$Y>20 NPAGE^ZIBER1 G:FLG=1 ERR W %J,") ",^(0),!! G L1 +LIST1 S %LIST=1,%J=0 W ! +L2 S %J=%J+1 Q:%J>%NE + I $D(%AZ("PACKAGE")) S %AZ("P")=%J D TMD2^ZIBER1 I '%AZ("PHIT") S %J=%J-1 G L2 + I $D(^UTILITY("%ER",%DAT,%J,0)) W %J,") ",^(0),!! G L2 +PMODE S %(1)=%DAT,%(2)=%NUM K (%) F %=$N(^(100)):0 Q:%<0!(%>1E5) D SET S %=$N(^(%)) + W !!,"Symbols have been set into this partition",!!,"You are exiting this utility" K % W !!,"Error defined as: ",^(0) S $ZT="" S:$D(^(7)) %=$P(^(7),"=",2) I $D(%) I %'="" I $D(@%) + K % Q +SET ; + I ^(%)'?1";".E S @($P(^(%),"=",1))=$P(^(%),"=",2,999) Q + I $D(^(1E8+99-%))<10 S @($P($E(^(%),2,999),"=",1))=^(1E8+99-%) Q + S %(3)="" F %(4)=1:1 Q:'$D(^UTILITY("%ER",%(1),%(2),1E8+99-%,%(4))) S %(3)=%(3)_^(%(4)) + S @($P($E(^UTILITY("%ER",%(1),%(2),%),2,999),"=",1))=%(3) + Q +ERROR U 0 + I $F($ZE,"") U 0 W !!,"...Aborted." D EXIT V 0:$J:$ZB($V(0,$J,2),#0400,7):2 + ZQ diff --git a/ZIBERCD.m b/ZIBERCD.m new file mode 100644 index 0000000..24c3414 --- /dev/null +++ b/ZIBERCD.m @@ -0,0 +1,217 @@ +ZIBERCD ;DJM;DISPLAY ERROR CODE DEFINITIONS;[ 8/13/89 4:00 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; COPYRIGHT MICRONETICS DESIGN CORP @1990 + S $ZT="ERR^ZIBERCD" + W !?10,$P($P($ZV,","),"-")," - Error Code Description Utility" + N EC,EXP,I +CODE ; + W !!,"Error code: " R EC G:EC="^Q"!(EC="^q")!("^"[EC) EXIT + G MM:EC?1.N1":"1.N,ZV:EC?1.N,TXT:EC?1"<"5U1">",DISP:EC?5U + W !,*7,?5,"Enter error code in following format:" + W !,?7,"major:minor",?28,"Example: 4:1" + W !,?7,"",?28,"Example: " + W !,?7,"nnn",?28,"Error code from $ZVERIFY(), ex: 21" + G CODE +MM ;major:minor + S EC=$P(EC,":")_$P(EC,":",2) G DISP +ZV ;$ZV + S EC=99_EC G DISP +TXT ; + S EC=$E(EC,2,6) +DISP ; + S EXP=$T(@EC) I EXP="" W *7," ... no such error code on file" G CODE + W !,?5,$P(EXP,";",2,99) + F I=1:1 S EXP=$T(@EC+I) Q:EXP=""!($P(EXP," ")'="") W !,?5,$P(EXP,";",2,99) + G CODE +EXIT ; + Q +ERR ; + I $F($ZE,"") U 0 W !!,"...Aborted." D EXIT V 0:$J:$ZB($V(0,$J,2),#0400,7):2 + ZQ + ;error codes +21 ; missing parenthesis +22 ; missing or bad colon +23 ; missing or bad equal +24 ; missing or bad local variable +25 ; missing or bad global variable +26 ; missing or bad function +27 ; missing or bad routine name +28 ; missing or bad routine label +29 ; missing or bad routine displacement +210 ; indirect argument error +211 ; argument condition error +212 ; bad argument delimiter +213 ; bad command +30 ; bad special variable name +31 ; bad system function +32 ; bad local variable name +33 ; bad global variable +34 ; bad string constant +35 ; bad numeric constant +36 ; unbalanced parenthesis +37 ; invalid systax in term +38 ; bad operator +39 ; bad delimiter +40 ; undefined local variable +41 ; undefined global variable +42 ; undefined routine label +43 ; undefined routine name +44 ; bad naked reference +45 ; non-existant device +46 ; unsubscripted local reference required +47 ; variable reference required.. no expressions +48 ; zload/zremove command not inside of execute string +49 ; undefined uci reference +410 ; insertion of null line is illegal +411 ; unknown data type +412 ; missing parameter +413 ; undefined system reference +414 ; global access protection violation +415 ; VIEW command restriction +416 ; ZCALL error +417 ; Formal List not entered via DO command +418 ; QUIT with argument inside FOR scope +419 ; QUIT with argument, but routine not extrinsic +420 ; argumentless QUIT, but routine was extrinsic +421 ; end of extrinsic subroutine encountered without QUIT parm +422 ; label requires a Formal List +423 ; Actual List contains more parms than Formal List +424 ; Formal List parameter is subscripted variable +425 ; duplicate variable name in Formal List +426 ; passing a value by reference in JOB command not allowed +50 ; string exceeded maximum length + ; 4092 for locals, 255 for globals +51 ; select function error (all elements evaluated to FALSE) +52 ; attempt to divide by zero +53 ; negative number where only zero or positive values allowed +54 ; maximum number +55 ; attempt to access a non-opened device +56 ; maximum memory +57 ; string value required +58 ; name indirection resulted in null value +59 ; name indirection resolved into more than pure variable name + ; ex: SET X=@Y where Y="ABC+2" (the '+2' is illegal) +510 ; selected partition not active ($VIEW) +511 ; invalid VIEW/$VIEW() parameter +512 ; function parameter out of range +513 ; subscript contains $C(0), or is null, or total global reference + ; exceeds 255 characters (including delimiters) +514 ; attempt to read/write file when file not opened for that access + ; ex: writing to a file that is opened for input + ; reading from a file that is opened for output + ; reading from a file that is opened for input but was not found + ; during open processing ($ZA/$ZB indicate if file was found) +515 ; invalid kanji or compressed shiftjis char +516 ; not allowed to write to block 0 +517 ; invalid use of shared mode on VIEW buffer +60 ; break key depressed +61 ; attempt to exceed partition size limit set at 'logon' time +62 ; halt command executed +63 ; lock table full +64 ; BREAK command detected +65 ; expression stack overflowed (expression too complex or operands of + ; string operations too long) +66 ; system stack overflow (DO/XECUTE/INDIRECTION nesting is too deep) +67 ; old pcode.. need to ZLOAD and ZSAVE (run the %RELOAD utility) +68 ; ddp error + ; can be caused by: SET X="XECUTE X" X X +69 ; reserved for DDP internal use +610 ; DDP database access inhibited +611 ; MUMPS to MUMPS communication failure +612 ; I/O error on terminal operation +613 ; I/O error on magnetic tape operation +614 ; pcode too long to fit in one block +615 ; ZQUIT error +616 ; DDP circuit disabled +71 ; bad block type in global directory block +72 ; bad block type in pointer block +73 ; bad block type in global data block +74 ; bad block type in extended global data block +75 ; bad block type in routine directory block +76 ; bad block type in routine header block +77 ; bad block type in routine block +78 ; bad block type in map block +79 ; bad block type in journal block +710 ; bad block type in sequential-block-processor block +711 ; hardware i/o error (unable to read/write database block) +712 ; disk full (if this occurs on a SET of a global variable, you MUST + ; use ^VALIDATE in Manager's UCI to validate the global since it + ; is likely that the global has become corrupt since the SET did + ; not complete normally (you may need to use ^DBFIX to correct) +713 ; mismatch of block number id in block header +714 ; global data/pointer block 'string+key' is too long, proper + ; block split can't be performed +715 ; unable to open database +716 ; block being freed already marked as free + ; use ^VALIDATE and ^DBFIX in manager's UCI to correct problem +717 ; invalid block number to driver +BKERR ; BREAK command was executed +CMMND ; illegal or undefined command +CLOBR ; zload/zremove command not inside execute statement +DDPER ; ddp error +DIVER ; attempt to divide by zero +DKFUL ; all space on the disk has been exhausted +DKHER ; disk physical i/o error (can't read/write a block in database) +DKSER ; incorrect block type in block header (ex: reading in a 'data' + ; block but header in block indicates a 'directory' block) + ; use ^VALIDATE and ^DBFIX in manager's UCI to correct problem +DPARM ; invalid use of parameter passing +DSCON ; telephone associated with the device has been disconnected +FUNCT ; illegal or undefined function +INDER ; invalid use of the indirection operator +INRPT ; control-c or 'break' key detected +ISYNT ; invalid syntax of a line being ZINERTed into a routine +LINER ; reference made to a non-existent label +MAPER ; blk being freed already marked as free +MINUS ; positive number was expected +MODER ; read/write to file when incorrect read/write mode +MSMCX ; in memory communication path between tasks has been interrupted +MTERR ; magnetic tape Inpt/Output error +MXNUM ; number is greater than maximum allowed +MXMEM ; invalid memory specification in VIEW cmnd +MXSTR ; string exceeds maximum length +NAKED ; naked reference is invalid +NODEV ; attempt to open an undefined device +NOMEM ; attempt to access a nonexistant or protected memory location +NOPEN ; attempt to use an unopened device +NOPGM ; routine not found in directory +NOSYS ; reference to a non-existent volume group through extended global notation +NOUCI ; reference to a non-existent UCI through extended global notation +PCERR ; invalid post-conditioned +PGMOV ; no memory left in partition +PLDER ; old pcode.. need to ZLOAD and ZSAVE (run the %RELOAD utility) +SBSCR ; invalid subscript specfication +SYNTX ; invalid syntax in expression, command, etc +SYSTM ; system error (should not occur) +UNDEF ; local or global reference is undefined +PROT ; access protection violation +SBSCR ; invalid subscript in a local or global variable +STKOV ; system stack has overflowed due to nested indirection, program loop, etc. +SYNTX ; a syntax error has been encountered by the interperter +SYSTM ; an internal MUMPS error, shutdown system and reboot +VWERR ; invalid use of the shared VIEW buffer mode +ZCERR ; old pcode.. need to ZLOAD and ZSAVE +ZLZSV ; old pcode.. need to ZLOAD and ZSAVE +BADCH ; invalid kanji/shiftjis character +99 ; buffer validation error codes +991 ; unknown block type +992 ; unknown data type in block +993 ; block type mis-match of descendent block +994 ; block not marked allocated in map block +995 ; right hand link doesnt match next downlink of ptr +996 ; block number field in block is incorrect +9910 ; non-zero common count for leading key in blk +9911 ; zero length unique part of key +9912 ; common > common+unique of previous key +9920 ; length of leading key doesnt match expected value +9921 ; leading key doesnt match expected value +9930 ; keys not in ascending order +9931 ; key not higher than high key in subtree +9940 ; hdrnext() inconsistent with actual end +9950 ; zero pointer to lower level +9951 ; cyclic loop in pointer block(s) +9952 ; cyclic loop in right link of routine blocks +9960 ; incorrect offset to first free slot in map block +9961 ; incorrect free count in map block +9963 ; map block in illegal location (valid: 1, 513, ... 512*n+1) +9964 ; map block not allocated to SYSTEM diff --git a/ZIBFIND.m b/ZIBFIND.m new file mode 100644 index 0000000..eaab1ef --- /dev/null +++ b/ZIBFIND.m @@ -0,0 +1,67 @@ +ZIBFIND ; IHS/ADC/GTH - FIND MSM BLOCKS WITH CONTAIN SPECIFIC GLOBAL ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; Thanks to Ross Leatham, AAO, and Mark Delaney, DSM, for the + ; original routine. + ; + ; MSM-specific utility for finding blocks which contain a + ; specific GBL. + ; + ; ZIBCC=common count, ZIBUC=unique count + ; ZIBCHAR=string of characters + ; + ;S X="ERR^ZIBFIND",@^%ZOSF("TRAP") K X + ; + I '(^%ZOSF("OS")["MSM") D OSNO^XB Q ; IHS/SET/GTH XB*3*9 10/29/2002 + S ZIBOSET=-1 +GETINFO ; + KILL ZIBVN,ZIBGREF,ZIBTYPE + D GETVOL^%VGUTIL + S:VGVOL=1 ZIBVN=0 + I VGVOL>1 R !,"What Volume Number are you looking in? ",ZIBVN:30 + G END:"^"[ZIBVN + S ZIBLBLK=$P(VGVOL(ZIBVN),"^",4) +ASK1 ; + S ZIBN=1 + F R !,"Enter GLOBAL to search for: ^",ZIBGREF:30 Q:"^"[ZIBGREF S ZIBGREF(ZIBN)=ZIBGREF,ZIBN=ZIBN+1 + G END:ZIBGREF="^" + S ZIBTYPE="234" + O 63::0 + I '$T W !,"VIEW BUFFER IN USE- SORRY" Q + KILL ^TMP("ZIBFIND",$J) + V 0:"DB/"_ZIBVN ;get the actual block number at start of volume + S ZIBBBLK=$V(1016,0,4),ZIBEBLK=ZIBBBLK+ZIBLBLK-1 +ASK2 ; + W !,"Enter beginning actual block to search from <",ZIBBBLK,"> " + R X:30 + G ASK2:X'?.N,END:X["^"!(X>ZIBLBLK) + S:X]"" ZIBBBLK=X + S ZIBOSET=ZIBBBLK-1 +ASK3 ; + W !,"Enter last actual block to search to <",ZIBEBLK,"> " + R X:30 + G ASK3:X'?.N,END:X["^"!(XZIBFF2 D SHOWF3($P(^[ZIBFUCI]DIC(ZIBFF1,0),U),^[ZIBFUCI]DIC(ZIBFF1,0,"GL")) ;IHS/SET/GTH XB*3*9 10/29/2002 + W:$X ! + S X="",@^%ZOSF("TRAP") + Q + ; +NODIC ; + W ?15,"--",?30,"Cannot access ^DIC (protection)",! + Q + ; +SHOWF3(X,Y) ;IHS/SET/GTH XB*3*9 10/29/2002 Added parameter "Y". + ;W ?15,ZIBFF1,?30,X,! ;IHS/SET/GTH XB*3*9 10/29/2002 + W ?15,ZIBFF1,?30,X,?45,Y,! ;IHS/SET/GTH XB*3*9 10/29/2002 + Q + ; +EXIT ; + ;KILL X,ZIBFI,ZIBFUCI,ZIBFNAME,ZIBFNUM,ZIBFHDR,ZIBFF1,ZIBFF2,ZIBFTDY,%I,%H,DTOUT,DUOUT,^TMP("ZIBFMD",$J) ;IHS/SET/GTH XB*3*9 10/29/2002 + KILL X,ZIBFI,ZIBFUCI,ZIBGBL,ZIBFNAME,ZIBFNUM,ZIBFHDR,ZIBFF1,ZIBFF2,ZIBFTDY,%I,%H,DTOUT,DUOUT,^TMP("ZIBFMD",$J) ;IHS/SET/GTH XB*3*9 10/29/2002 + S:$D(ZTQUEUED) ZTREQ="@" + Q + ; +ERR ; + I $ZE'["" W $ZE,! Q + G SUMM + ; diff --git a/ZIBFR.m b/ZIBFR.m new file mode 100644 index 0000000..44f19ba --- /dev/null +++ b/ZIBFR.m @@ -0,0 +1,68 @@ +ZIBFR ; IHS/ADC/GTH - LIST UCI'S FOR A GIVEN ROUTINE ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods. + ; + ; Given a routine name, this routine searches all UCIs and + ; reports the first line of the selected routine to the user. + ; +EN ; + ;Q:'($ZV?1"MSM".E!($ZV?1"DSM".E)) ; Only works for MSM or DSM.;IHS/SET/GTH XB*3*9 10/29/2002 + S %=$$VERSION^%ZOSV(1) I '(%["Cache"),'(%["MSM") Q ;IHS/SET/GTH XB*3*9 10/29/2002 + R !,"Please enter full routine name to locate: ",%ZIB("RTN NAME"):$G(DTIME,300),! + ; G:"^"[%ZIB("RTN NAME") EX ;IHS/SET/GTH XB*3*9 10/29/2002 + G:"^"[%ZIB("RTN NAME") EXIT ;IHS/SET/GTH XB*3*9 10/29/2002 + S:%ZIB("RTN NAME")["^" %ZIB("RTN NAME")=$P(%ZIB("RTN NAME"),"^",2) ;IHS/SET/GTH XB*3*9 10/29/2002 + S %ZIB("OP SYS")=$ZV ; Set operating system. + I %ZIB("OP SYS")["Cache" G CACHE ;IHS/SET/GTH XB*3*9 10/29/2002 + S %ZIB("CURR UCI NBR")=$P($ZU($P($ZU(0),","),$P($ZU(0),",",2)),",") ; Save current UCI nbr. + S %ZIB("CURR VOL NBR")=$P($ZU($P($ZU(0),","),$P($ZU(0),",",2)),",",2) ; Save current VOL nbr. + ; S:%ZIB("RTN NAME")["^" %ZIB("RTN NAME")=$P(%ZIB("RTN NAME"),"^",2) ;IHS/SET/GTH XB*3*9 10/29/2002 + D ; Loop until last UCI of last VOLUME SET. + . S $ZT="ZT" ; Set error trap for DSM . + . F %ZIB("VOL NBR")=0:1 Q:$ZU(1,%ZIB("VOL NBR"))!($ZU(1,%ZIB("VOL NBR"))="") D + .. S $ZT="ZT" ; Set error trap for DSM . + .. F %ZIB("UCI NBR")=1:1 Q:$ZU(%ZIB("UCI NBR"),%ZIB("VOL NBR"))!($ZU(%ZIB("UCI NBR"),%ZIB("VOL NBR"))="") D + ... Q:$E(%ZIB("RTN NAME"))="%"&(%ZIB("UCI NBR")'=1) ; MGR routine. + ... I %ZIB("OP SYS")?1"MSM".E D + .... V 2:$J:%ZIB("VOL NBR")*32+%ZIB("UCI NBR"):2 ; MSM switch to next UCI. + ... E V 148:$J:$V(148,$J)#256+(%ZIB("VOL NBR")*32+%ZIB("UCI NBR"))*256 ; DSM switch to next UCI. + ... S X=%ZIB("RTN NAME") + ... X ^%ZOSF("TEST") + ... I D + .... X "ZL @%ZIB(""RTN NAME"") S %ZIB(""RTN FIRST LINE"")=$T(+1)" + .... W !!,$ZU(0),?10,"Routine - ",%ZIB("RTN NAME")," - was last saved on ",$P($P(%ZIB("RTN FIRST LINE"),"[",2),"]") + .... W !,%ZIB("RTN FIRST LINE") ; Display first line of routine. + I %ZIB("OP SYS")?1"MSM".E V 2:$J:%ZIB("CURR VOL NBR")*32+%ZIB("CURR UCI NBR"):2 ; Return to current UCI MSM. + E V 148:$J:$V(148,$J)#256+(%ZIB("CURR VOL NBR")*32+%ZIB("CURR UCI NBR"))*256) ; Return to current UCI DSM. +EXIT ;IHS/SET/GTH XB*3*9 10/29/2002 Label EX changed to EXIT. + KILL %ZIB +ENQ ; + Q + ;Begin New Code;IHS/SET/GTH XB*3*9 10/29/2002 +CACHE ; + S $ZT="BACK^%ETN" + S %ZIB("CURR NSP")=$ZU(5) + F I=1:1:$ZU(90,0) S ZIBLIST($ZU(90,2,0,I))="" + S ZIBFUCI="" F S ZIBFUCI=$O(ZIBLIST(ZIBFUCI)) Q:ZIBFUCI="" D + .I $ZU(5,ZIBFUCI) + .S X=%ZIB("RTN NAME") + .X "I X?1(1""%"",1A).7AN,$D(^$R(X))" + .I D + ..X "ZL @%ZIB(""RTN NAME"") S %ZIB(""RTN FIRST LINE"")=$T(+1),%ZIB(""RTN SECOND LINE"")=$T(+2)" + ..W !!,$ZU(5),?10,"Routine - ",%ZIB("RTN NAME")," - was last compiled on ",$$CDATE(%ZIB("RTN NAME")) + ..W !,%ZIB("RTN FIRST LINE") ; Display first line of routine. + ..W !,%ZIB("RTN SECOND LINE"),! ; Display second line + I $ZU(5,%ZIB("CURR NSP")) ; Go back to original Namespace + D EN^XBVK("ZIB") + KILL I,X + G EXIT + ; +CDATE(%ZIBRTN) ; retrieve date of last edit on Cache only + Q $$DATE^%R(%ZIBRTN_".INT",1) + ; + ;End New Code;IHS/SET/GTH XB*3*9 10/29/2002 +ZT ; ERROR TRAP + Q:$ZE[" err. + ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH. + ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods. + ; XB*3*10 IHS/ITSC/DMJ 8/19/2004 Bad global name. + ; + ; Not all capabilities of the implementation-specific global + ; characteristics routines are reflected in this routine. + ; + ; The argument for each entry point is the unsubscripted + ; name of the global whose characteristics you want to + ; change, with NO leading circumflex. + ; + ; If the call is successful, 0 is returned. + ; + ; If the call is not successful, a positive integer is + ; returned, and the cause can be retrieved at the ERR() + ; entry point. + ; + ; E.g's: + ; S %=$$NOJOURN^ZIBGCHAR("AUTTSITE") + ; I % W !,$$ERR^ZIBGCHAR(%) + ; + Q + ; + ;Begin New Code;IHS/SET/GTH XB*3*9 10/29/2002 +KILL(ZIBGLOB) ;PEP - Kill global or global referenced at the top level + NEW QF,X + I '$L($G(ZIBGLOB)) Q 1 + I ZIBGLOB'["," D Q QF ; just one global to kill + . S QF=$$PROCESS("D","N") + . I QF Q + . KILL @("^"_ZIBGLOB) + . I $$VERSION^%ZOSV(1)["Cache" S X=$ZU(68,28,1) ;disallow kill again + .Q + ;multiple globals to kill, comma delimited string like "gbl1,gbl2,gbl3" + F X=1:1:$L(ZIBGLOB,",") S ZIBGLOB(X)=$P(ZIBGLOB,",",X) + F X=1:1:$L(ZIBGLOB,",") D Q:QF + . S QF=$$KILLOK(ZIBGLOB(X)) + . I QF Q + . KILL @("^"_ZIBGLOB(X)),ZIBGLOB(X) + .Q + I $$VERSION^%ZOSV(1)["Cache" S X=$ZU(68,28,1) ;disallow kill again + Q QF + ; + ;End New Code;IHS/SET/GTH XB*3*9 10/29/2002 +KILLOK(ZIBGLOB) ;PEP - Allow kill of global. + Q $$PROCESS("D","N") + ; +KILLNO(ZIBGLOB) ;PEP - Prevent kill'ing of global. + Q $$PROCESS("D","Y") + ; +JOURN(ZIBGLOB) ;PEP - Set Journaling to ALWAYS. + Q $$PROCESS("J","A") + ; +NOJOURN(ZIBGLOB) ;PEP - Set Journaling for global to NEVER. + Q $$PROCESS("J","N") + ; +UCIJOURN(ZIBGLOB) ;PEP - Journal when UCI is Journaled. + Q $$PROCESS("J","U") + ; +PROCESS(ZIBFLAG,ZIBVAL) ; + I '$L($G(ZIBGLOB)) Q 1 + ;I '(ZIBGLOB?1.8U) Q 5;IHS/SET/GTH XB*3*9 10/29/2002 + ;I '(ZIBGLOB?1.8U!(ZIBGLOB?1"%"1.7U)) Q 5 ;Cache needs to SET % globals;IHS/SET/GTH XB*3*9 10/29/2002 XB*3*10 next line will do the job + I '$D(@("^"_ZIBGLOB)) Q 2 + ; NEW O ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent err. + ; S O=$P(^%ZOSF("OS"),"-",1) ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent err. + ; I '$L($T(@O)) Q 3 ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent err. + ; G @O ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent err. + ; I $P(^%ZOSF("OS"),"^",1)["MSM" G MSM ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent err. + I $$VERSION^%ZOSV(1)["Cache" Q $$CACHE(ZIBFLAG,ZIBGLOB,ZIBVAL) ;IHS/SET/GTH XB*3*9 10/29/2002 + I $P(^%ZOSF("OS"),"^",1)'["MSM" Q 3 ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH. + D MSM + I '$D(ZTQUEUED) D HOME^%ZIS U IO(0) ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH. + Q 0 ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH. + ; Q 3 ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent err. ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH. + ; + ;Begin New Code;IHS/SET/GTH XB*3*9 10/29/2002 +CACHE(ZIBFLAG,ZIBGLOB,ZIBVAL) ;PEP - allow/prevent kill or enable/disable journaling on Cache + ;TASSC/MFD added subroutine to mimic portions of %GCH that Cache can do + ; -Patterned after CALL subroutine of MSM's %GCH but an extrinsic + ; -Less options than MSM- journaling is either on or off for a global + ; as there is no Journal entire UCI option + ; -Allowing top-level kill is by process not by global specification + ; -If the call is successful, 0 is returned. + ; + ; ZIBGLOB = global reference, no leading ^ + ; ZIBFLAG can be "J" or "D"- J is for journaling on or off, D is for + ; allowing top kill or not + ; ZIBVAL = for Journaling- E, A or U for enable, D, N or null for disable + ; for Prev kill- Y to prevent kill, N to allow kill + ; + I '(ZIBGLOB?1.8AN!(ZIBGLOB?1"%"1.7AN)) Q 5 ; XB*3*10 allow lower case + I '$D(@("^"_ZIBGLOB)) Q 2 + I ZIBFLAG="D",ZIBVAL="N" NEW X S X=$ZU(68,28,0) Q 0 ;don't prevent top-level kill for the process + I ZIBFLAG="D",ZIBVAL="Y" NEW X S X=$ZU(68,28,1) Q 0 ;prevent top-level kill for the process + I ZIBFLAG="J" NEW ZIBRC D + .S ZIBVAL=$S(ZIBVAL="E":4,ZIBVAL="A":4,ZIBVAL="U":4,ZIBVAL="N":0,ZIBVAL="D":0,ZIBVAL="":0,1:1) + .I ZIBVAL'=1 S ZIBRC=$$SetJournalType^%DM("",ZIBGLOB,ZIBVAL) + .Q + I ZIBRC=1 Q 0 ;Cache returns a 1 if successful + Q 1 ; any other condition is bad so quit 1 + ; + ;End New Code;IHS/SET/GTH XB*3*9 10/29/2002 +MSM ; Micronetics Standard MUMPS. + I '$L($T(CALL^%GCH)) Q 4 + S:$D(ZTQUEUED) CALL="" ; Tell ^%GCH not to talk if errors. + KILL O + NEW (ZIBFLAG,ZIBGLOB,ZIBVAL) ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH. + D CALL^%GCH(ZIBFLAG,ZIBGLOB,ZIBVAL) + KILL CALL + ; Q 0 ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH. + Q ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH. + ; +ERR(Z) ;PEP - Return cause of error. + Q $P($T(@Z),";;",2) +1 ;;NO GLOBAL SPECIFIED IN PARAMETER +2 ;;GLOBAL DOES NOT EXIST +3 ;;OPERATING SYSTEM NOT SUPPORTED +4 ;;WRONG VERSION OF MSM'S ^%GCH +5 ;;BAD GLOBAL NAME + ; + ; +TEST ; + NEW AZHB,AZHB1 + F AZHBCTR=1:1 S AZHB=$P($T(DATA+AZHBCTR),";",3) Q:AZHB="###" D T1(AZHB),T2(AZHB) + Q + ; +T1(AZHB) ; + W !,"No Journaling For '",AZHB,"'" + S AZHB1=$$NOJOURN(AZHB) + W ?28," : ",AZHB1 + I AZHB1 W " : ",$$ERR(AZHB1) + E W " : " + Q + ; +T2(AZHB) ; + W !,"No Killing For '",AZHB,"'" + S AZHB1=$$KILLNO(AZHB) + W ?28," : ",AZHB1 + I AZHB1 W " : ",$$ERR(AZHB1) + E W " : " + Q + ; +DATA ; + ;; + ;;FREDDATA + ;;ACHSDATA + ;;AUTTSITE + ;;^AUTTLOC + ;;jen + ;;44 + ;;DIC(4, + ;;### diff --git a/ZIBGCHR.m b/ZIBGCHR.m new file mode 100644 index 0000000..e64774e --- /dev/null +++ b/ZIBGCHR.m @@ -0,0 +1,218 @@ +ZIBGCHR ; IHS/ADC/GTH - SEARCH FOR CONTROL CHAR. IN GLOBALS ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods. + ; +%GLCHR ;SEARCH FOR CONTROL CHAR. IN GLOBALS [ 04/15/85 9:13 AM ] +%ST ; + S %DEF=0,%TRM=$I,%TMO=60 ;,$ZE="%ERR^%GL" +%STL ; + I $D(%IOD) C:%IOD'=%TRM %IOD + S %QTY=2 + D ^%ZIS + G:'$D(IO) %END + S %DEF=IO,%PAG=IOSL-4 + ;I "SC^LP^TRM"'[%DTY!(%DTY="") W !?5,"Improper device selection.",!?5,"Must choose a terminal, a printer, or the system console." G %ST +%SCR ; + S %LN=132 + ;S:IOT="TRM" %LN=80 ;IHS/SET/GTH XB*3*9 10/29/2002 + S:IOT["TRM" %LN=80 ;IHS/SET/GTH XB*3*9 10/29/2002 + ;I IOT'="TRM" S %SC=0,%DCC=2 G %DO ;IHS/SET/GTH XB*3*9 10/29/2002 + I IOT'["TRM" S %SC=0,%DCC=2 G %DO ;IHS/SET/GTH XB*3*9 10/29/2002 +IHS1 ; + S %SC=0,%DCC=2,TGL=0 + G %DO + ; + ; -- UNreachable code follows (?) GTH 07-06-95 + R !,"Scroll ? ",%SC:%TMO + G:%SC="?" %Q1 + G:%SC="^"!('$T) %STL + G:%SC="^Q" %END + S:%SC="" %SC="N" + I "Y^N"'[$E(%SC) W " 'Y' or 'N'" G %SCR + S %SC=($E(%SC)="Y"),%PAG=20 +%PAG ; + G:'%SC %ASKC + W !,"Lines/Page <",%PAG R "> ",%X:%TMO + G:%X="^"!('$T) %SCR + G:%X="^Q" %END + S:%X="" %X=%PAG + I %X'?1N.N!(%X<1) G %Q2 + S %PAG=%X +%ASKC ; + R !,"Do you want to display control characters ? ",%X:%TMO + G:%X="?" %Q3 + G:%X="^Q" %END + S:%X="" %X="NO" + I %X="^"!('$T) G:%SC %PAG G:%DTY'="TRM" %STL G %SCR + I "Y^N"'[$E(%X) W " 'Y' or 'N'" G %ASKC + I $E(%X)="N" S %DCC=0 G %DO +%OPT ; + W !,"Specify one of the following:",!?5,"1. Line display",!?5,"2. Block display (with ASCII codes)" +%OPT1 ; + R !,"Display type <1> ",%X:%TMO + G:%X="?" %HELP + G:%X="^"!('$T) %ASKC + G:%X="^Q" %END + S:%X="" %X=1 + I %X'=1,%X'=2 G %OPT + S %DCC=%X +%DO ; + D %START + C:IO'=%TRM IO + G %END + ; +%START ; + S %NCR=%LN-5,%BAR="\" + ;D ^%GSEL ;IHS/SET/GTH XB*3*9 10/29/2002 + I $ZV["MSM" D ^%GSEL ;IHS/SET/GTH XB*3*9 10/29/2002 + I $ZV["Cache" D ^%GSET ;IHS/SET/GTH XB*3*9 10/29/2002 + S (%GL,%GN)="",%LIN=0 + ;I $ZS(^UTILITY($J,%GL))="" Q ;IHS/SET/GTH XB*3*9 10/29/2002 + I $O(^UTILITY($J,%GL))="" Q ;IHS/SET/GTH XB*3*9 10/29/2002 + U IO + D %GET + S %LC=1 + D %LIN + W # + U IO + G %START + ; +%GET ; + KILL %DX,%CK,FLG + ;S %GN=$ZS(^UTILITY($J,%GN)) ;IHS/SET/GTH XB*3*9 10/29/2002 + S %GN=$O(^UTILITY($J,%GN)) ;IHS/SET/GTH XB*3*9 10/29/2002 + Q:%GN="" + S GLREF=^UTILITY($J,%GN) + I GLREF="" S %CK="" G %WT + D %START^%GL1 + Q + ; +%WT ; + S %GL="^"_%GN + S %LC=2 + D %LIN + W %GL + I $D(@%GL)#2 S IN=@%GL I IN]"" W " = " D %OUT + S %LC=1 + D %LIN + S %GL=%GL_"("""")" +%NEXT ; + ;S %GL=$ZN(@%GL) ;IHS/SET/GTH XB*3*9 10/29/2002 + S %GL=$Q(@%GL) ;IHS/SET/GTH XB*3*9 10/29/2002 + ;G:%GL=-1 IHS3 ;IHS/SET/GTH XB*3*9 10/29/2002 + G:%GL="" IHS3 ;IHS/SET/GTH XB*3*9 10/29/2002 + S IN=@%GL + I IN?.E1C.E S TGL=TGL+1 W %GL," = " D %OUT +IHS2 ; + G %NEXT + ; +IHS3 ; + U IO + W !!,"TOTAL CORRUPT GLOBALS FOUND: ",TGL + D PAUSE^XB + S TGL=0 + G %GET + ; +%OUT ; + I '(IN?.E1C.E) G %OUT1 + D:%DCC=1 %DSP1 + D:%DCC=2 %DSP2 +%OUT1 ; + S %LC=1 + D %LIN + Q + ; +%DSP1 ; + F I=1:1:$L(IN) S %CHR=$E(IN,I) D %WRT + Q + ; +%WRT ; + I $A(%CHR)<32 W %BAR Q + I $A(%CHR)=92 W "\\" Q + W %CHR + Q + ; +%DSP2 ; + F I=1:1:4 S A(I)="" + F I=1:1:$L(IN) S %CHR=$E(IN,I) D:$A(%CHR)<32 %CTL D:$A(%CHR)'<32 %NML + S %FCR=1,%NLN=($L(IN)-1)\%NCR+1 + F I=1:1:%NLN S %LCR=%FCR+%NCR-1 D %LST + Q + ; +%CTL ; + S A(1)=A(1)_%BAR + D %FIXO + F K=2:1:4 S A(K)=A(K)_$E(%ASCII,K-1) + Q + ; +%NML ; + S A(1)=A(1)_%CHR + D %FIXO + F K=2:1:4 S A(K)=A(K)_$E(%ASCII,K-1) + Q + ; +%FIXO ; + S %ALN=3-$L($A(%CHR)),%ASCII=$A(%CHR) + F M=1:1:%ALN S %ASCII="0"_%ASCII + KILL %ALN + Q + ; +%LST ; + I $D(%SC) D:%LIN+4>%PAG %SC + F %J=1:1:4 S %LC=1 D %LIN W ?3,$E(A(%J),%FCR,%LCR) + S %LC=1 + D %LIN + S %FCR=%LCR+1 + Q + ; +%LIN ; + I $D(%SC) D:%LIN+%LC>%PAG %SC S %LIN=%LIN+%LC + F %K=1:1:%LC W ! + Q + ; +%SC ; + U 0 + R !,"Type to continue",%X:60 + S:'$T %X="^" + U IO + S %LIN=0 + Q + ; +%HELP ; + W !!?5,"Enter '1' to display control characters as ""\""." + W !?5,"Enter '2' to also display the ASCII code below each character." + W !?8,"Example: ^AA(""1"",""3"",""5"") =" + W !?22,"AB\C\\DEF",!?22,"000000000",!?22,"661612667",!?22,"562773890" + D %EX + G %OPT1 + ; +%Q1 ; + W !?5,"Enter Y(ES) to specify the number of lines to be displayed per page" + W !?8,"or N(O) to have a continuous display." + D %EX + G %SCR + ; +%Q2 ; + W !?5,"Enter the number of lines to be displayed per page." + W !?5,"(Should not exceed 20 lines per page for video terminals.)" + D %EX + G %PAG + ; +%Q3 ; + W !?5,"Enter Y(ES) for special treatment of control characters upon output.",!?5,"Otherwise enter N(O)." + D %EX + G %ASKC + ; +%EX ; + W !?5,"Enter ^ to return to the previous question,",!?8,"or ^Q to exit the routine." + Q + ; +%ERR ; + U 0 + I $ZE?1"" + 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 ; + KILL XBMSG,%MT + 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 + ; diff --git a/ZIBGSVEM.m b/ZIBGSVEM.m new file mode 100644 index 0000000..cee2b95 --- /dev/null +++ b/ZIBGSVEM.m @@ -0,0 +1,177 @@ +ZIBGSVEM ; IHS/ADC/GTH - SAVE GLOBAL TO MSM UNIX ; [ 09/14/2004 4:57 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ;I ^%ZOSF("OS")["PC"!(^%ZOSF("OS")["Windows NT")!($P($G(^AUTTSITE(1,0)),U,21)=2) G ^ZIBGSVEP ;COMMENTED OUT AND REPLACE BY NEXT LINE - AEF/08/08/03 + I $$VERSION^%ZOSV(1)["Windows" G ^ZIBGSVEP ;XB*3*10 TASSC/MFD 8/15/03 + 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 XBPAFN=XBTEMPFN + 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) + 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 + 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 ;EP - auto queue to uucp subroutine, must have system id in RPMS SITE file ; IHS/SET/GTH XB*3*9 10/29/2002 + I $$JOBWAIT^%HOSTCMD("/usr/bin/sendto "_XBQTO_" "_XBUF_"/"_XBFN) S XBFLG=-1,XBFLG(1)="Queue of File to uucp Failed" + E W:'$D(ZTQUEUED) !,"Export file ",XBUF,"/",XBFN," queued up to be sent to ",XBQTO,"...",! + Q + ; +SAVEMSM ;EP - $QUERY thru global, write to output. + K XBQUIT + I '$G(XBFLT) W XBDT,!,XBTLE,! + S X=XBGL_XBF_")" + F D Q:$G(XBQUIT) + .S X=$Q(@X) + .I X="" S XBQUIT=1 Q + .S Y=$P($P($P(X,")",1),"(",2),",",1) + .I XBE=+XBE,Y'=+Y S XBQUIT=1 Q + .I ($L(XBE)&($$FOLLOW(Y,XBE))) S XBQUIT=1 Q + .I $D(XBCON)&('(Y=+Y)) S XBQUIT=1 Q + .S Y=X + .S:$E(Y,2)="[" Y=U_$P(Y,"]",2,999) + .W:'$G(XBFLT) Y,! + .W @X,! + I '$G(XBFLT) W "**",!,"**",!! + K XBQUIT + Q + ; +FOLLOW(Y,XBE) ; If Y follows XBE return 1. Else return 0. + N Z + I '(Y=+Y) D + .S Z=(Y]XBE) + I Y=+Y D + .S Z=(Y>XBE) + Q Z + ; diff --git a/ZIBGSVEP.m b/ZIBGSVEP.m new file mode 100644 index 0000000..56d680b --- /dev/null +++ b/ZIBGSVEP.m @@ -0,0 +1,65 @@ +ZIBGSVEP ; IHS/ADC/GTH - SAVE GLOBAL TO DOS MEDIA ; [ 07/21/2005 3:22 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*8 - IHS/ASDST/GTH - 12-07-00 - Protect U IO(0) and WRITE's in background. + ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache', NT, and system mods. + ; + ;S XBUF=$S($P($G(^AUTTSITE(1,1)),U,2)]"":$P(^AUTTSITE(1,1),U,2),1:"C:\EXPORT") ;LINE COMMENTED OUT AND REPLACED BY NEXT LINE - AEF/08/08/03 + ;S:'$G(XBUF) XBUF=$S($P($G(^AUTTSITE(1,1)),U,2)]"":$P(^AUTTSITE(1,1),U,2),1:"C:\EXPORT") ;XB*3*10 + 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) D + .; if you're on NT put the full location code to be compatible with + .; area unix boxes + .;I ^%ZOSF("OS")["Windows NT" S X2=$E(DT,1,3)_"0101",X1=DT D ^%DTC S X=X+1,XBFN=$E(XBGL,2,5)_$P(^AUTTLOC(DUZ(2),0),U,10)_"."_X Q ; IHS/SET/GTH XB*3*9 10/29/2002 + .I ^%ZOSF("OS")["NT" S X2=$E(DT,1,3)_"0101",X1=DT D ^%DTC S X=X+1,XBFN=$E(XBGL,2,5)_$P(^AUTTLOC(DUZ(2),0),U,10)_"."_X Q ; IHS/SET/GTH XB*3*9 10/29/2002 + .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 + S XBPAFN=XBUF_"\"_XBFN + I $$OPEN^%ZISH(XBUF_"\",XBFN,"W") S XBERRMSG="DOS File" G ERRMESS + ; U IO(0) ; XB*3*8 + I '$D(ZTQUEUED) U IO(0) ; XB*3*8 + ; W !,"Please Standby - Copying Data to DOS File ",XBUF,"\",XBFN ; XB*3*8 + I '$D(ZTQUEUED) W !,"Please Standby - Copying Data to DOS File ",XBUF,"\",XBFN ; XB*3*8 + U IO + D SAVEMSM^ZIBGSVEM + G END + ; +UUCPQ ;EP - auto queue to sendto and ftp, must have system id in RPMS SITE file ; IHS/SET/GTH XB*3*9 10/29/2002 + I $$JOBWAIT^%HOSTCMD("sendto "_XBQTO_" "_XBUF_"\"_XBFN) S XBFLG=-1,XBFLG(1)="Queue of File to uucp Failed" + ; E W:'$D(ZTQUEUED) !,"Export file ",XBUF,"/",XBFN," queued up to be sent to ",XBQTO,"...",! ; IHS/SET/GTH XB*3*9 10/29/2002 + ;E W:'$D(ZTQUEUED) !,"Export file ",XBUF,"\",XBFN," queued up to be sent to ",XBQTO,"...",! ; IHS/SET/GTH XB*3*9 10/29/2002 ;LINE COMMENTED OUT AND REPLACED BY NEXT LINE - AEF/08/08/03 + E I '$D(ZTQUEUED) U IO(0) W !!,"Export file ",XBUF,"\",XBFN," queued up to be sent to ",XBQTO,"...",! ;XB*3*10 + Q + ; +ERRMESS ; + S XBFLG(1)=XBERRMSG_" Not Available",XBFLG=-1 + ; U IO(0) ; XB*3*8 + ; W !,XBFLG(1) ; XB*3*8 + I '$D(ZTQUEUED) U IO(0) W !,XBFLG(1) ; XB*3*8 +END ; + ; I '$D(AUFLG),$P(^AUTTSITE(1,0),"^",14)]"" D UUCPQ ;IHS/MFD added line ; XB*3*8 + I '$D(XBFLG),XBQ="Y" D UUCPQ ; XB*3*8 + D ^%ZISC,HOME^%ZIS + KILL XBERRMSG + Q diff --git a/ZIBNSSV.m b/ZIBNSSV.m new file mode 100644 index 0000000..e18720b --- /dev/null +++ b/ZIBNSSV.m @@ -0,0 +1,63 @@ +ZIBNSSV ; IHS/ADC/GTH - NONSTANDARD SPECIAL VARIABLES ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*8 - IHS/ASDST/GTH - Correct parsing for MSM Windows. + ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods. + ; + ; Return Non-Standard ($Z) Special Variables. + ; + ; E.g.: + ; W $$Z^ZIBNSSV("ERROR") + ; will write the contents of the error message most recently + ; produced by the OS. + ; + ; These are the variables supported: + ; + ; ERROR : Text of error message most recently produced. + ; LEVEL : Number of the current nesting level. + ; NAME : Name of routine currently loaded in memory. + ; ORDER : Data value of the next global node that follows + ; the current global reference. + ; TRAP : Line label and routine name of the program that + ; is to receive control when an error occurs. + ; VERSION : Name and release of M implementation. + ; +Z(NSSV) ;PEP - Return Non-Standard ($Z) Special Variables. + I '$L($G(NSSV)) Q "NONSTANDARD SPECIAL VAR NOT SPECIFIED." + I '$F("ERROR^LEVEL^NAME^ORDER^TRAP^VERSION",NSSV) Q "NONSTANDARD SPECIAL VAR '"_NSSV_"' NOT SUPPORTED." + NEW O + ; S O=$P($G(^%ZOSF("OS")),"-",1) ; XB*3*8 - IHS/ASDST/GTH + ;S O=$S($P($G(^%ZOSF("OS")),"^",1)["MSM":"MSM",1:"") ; XB*3*8 - IHS/ASDST/GTH;IHS/SET/GTH XB*3*9 10/29/2002 + S O=$S($P($G(^%ZOSF("OS")),"^",1)["MSM":"MSM",^%ZOSF("OS")["OpenM":"CACHE",1:"") ; XB*3*8 - IHS/ASDST/GTH ;IHS/SET/GTH XB*3*9 10/29/2002 + ;I '$L($T(@(O))) Q "OPERATING SYSTEM '"_O_"' NOT SUPPORTED." ;IHS/SET/GTH XB*3*9 10/29/2002 + I '$L(O) Q "OPERATING SYSTEM '"_^%ZOSF("OS")_"' NOT SUPPORTED." ;IHS/SET/GTH XB*3*9 10/29/2002 + G @(O) + ; +MSM ; Micronetics specific Non-Standard Special Variables. + NEW MSMSV + S MSMSV="MSMZ"_$E(NSSV) + I '$L($T(@MSMSV)) Q "Micronetics VALUE FOR '"_NSSV_"' NOT SUPPORTED." + G @(MSMSV) + ; +MSMZE Q $ZE +MSMZL Q $ZL +MSMZN Q $ZN +MSMZO Q $ZO +MSMZR() ;PEP - MSM's last global reference. + ; Going thru the "Z" entry point will re-set the global reference! + Q $ZR +MSMZT Q $ZT +MSMZV Q $ZV + ; + ;Begin New Code;IHS/SET/GTH XB*3*9 10/29/2002 +CACHE ; + NEW % + S %="CACHEZ"_$E(NSSV) + I '$L($T(@%)) Q "Cache' VALUE FOR '"_NSSV_"' NOT SUPPORTED." + G @(%) + ; +CACHEZE Q $ZE +CACHEZN Q $ZN +CACHEZO Q $ZO +CACHEZT Q $ZT +CACHEZV Q $ZV + ;End New Code;IHS/SET/GTH XB*3*9 10/29/2002 diff --git a/ZIBPKGF.m b/ZIBPKGF.m new file mode 100644 index 0000000..e0aef66 --- /dev/null +++ b/ZIBPKGF.m @@ -0,0 +1,120 @@ +ZIBPKGF ; IHS/ADC/GTH - INSTALLATION STATUS REPORT ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + W !!,"EXECUTION UNAUTHORIZED.",! + Q + ; +Q2 ;EP - From DIR + W ! F %=2:1:7 W $P($T(Q2+%),";;",2),! + ;; This utility reads thru the PACKAGE file for versions and + ;; dates of installed packages, writes the info to a file, + ;; and uucp's the file to the area machine and/or a central + ;; machine, probably cmbsyb. The info sent to cmbsyb will + ;; be copied to MailMan for auto processing into the + ;; Application Implementation Status options. + Q + ; + ; cmbsyb Any Timeplex 9600 .30-30 n:--n:--n: uucpb word: 10sne1 + ; cmbsyb Any ACU 2400 FTS-505-262-6166 n:--n:--n: uucpb word: 10sne1 + ; dpssyg Any Timeplex 9600 .00-15 n:--n:--n: uucpdps word: uucpdps + ; dpssyg Any ACU2400 FTS-505-262-6250 n:--n:--n: uucpdps word: uucpdps + ; +OPT ;EP - Set option in OPTION file. + I $P(^%ZOSF("OS"),"^")'="MSM-UNIX" W !!,"SORRY. MSM-UNIX 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)),Q2 + NEW DA,DIC,DIE,DIR,DR + 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")=3,DIR("?")=%,DIR("??")="^D Q2^ZIBPKGF" D ^DIR Q:$D(DIRUT) + S DIC="^DIC(19,",DIC(0)="",X="ZIB INSTALLATION STATUS REPORT",DIC("DR")="1///Installation Status Report;4///R;20///I "_Y_";25///START^ZIBPKGF;200///T@2110;202///25D" + I $D(^DIC(19,"B",X)) S DIE=DIC,DA=$O(^DIC(19,"B",X,0)),DR="20///I "_Y D ^DIE I 1 + E KILL DD,DO D FILE^DICN + W !!,"Done." + Q + ; +START ;EP - From TaskMan. + ; A = Area System Name + ; D = Date Package Installed + ; F = File Name + ; I = HFS Name + ; L = Location ASUFAC + ; M = System Name to Receive all Reports + ; P = Package Prefix + ; R = Directory + ; S = Short Description of Package + ; S(1) = 1st Subscript in PACKAGE + ; S(2) = 22 node Subscript in PACKAGE + ; V = Version of Package + ; + NEW %ZIS,A,D,DA,DIC,F,I,J,L,M,N,P,R,S,V + ; + S R="/usr/spool/uucppublic/",L=$P(^AUTTLOC($P(^AUTTSITE(1,0),U),0),U,10) + 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 + Q:POP!('I) + S I=$P(^%ZIS(1,I,0),U) + KILL ^TMP($J) + ; + ; rm xmit files over 2 weeks old. + ; + S X=$$JOBWAIT^%HOSTCMD("ls -l "_R_"pkg"_L_".* > /usr/mumps/zibpkg.wrk"),IOP=I,%ZIS("IOPAR")="(""/usr/mumps/zibpkg.wrk"":""R"")" + D ZIS,JDT + U IO + F R %:300 Q:%="" S %=$P(%,"/",5),X=+$P(%,".",2) I %?1"pkg"6N1"."3N,L=$E(%,4,9),((+X>+J)!(+X<(+J-14))) S X=$$JOBWAIT^%HOSTCMD("rm "_R_%) + S X=$$JOBWAIT^%HOSTCMD("rm /usr/mumps/zibpkg.wrk") + ; Initialize namespace, systems, and frequency. + S %=+$P(^DIC(19,$O(^DIC(19,"B","ZIB INSTALLATION STATUS REPORT",0)),20)," ",2) + I %>1 S A=$P(^AUTTSITE(1,0),U,14) + I '(%=2) S M=$P($T(SYTM),";;",2) + ; + S F="/usr/spool/uucppublic/pkg"_L_"."_J,IOP=I,%ZIS("IOPAR")="("""_F_""":""W"")" + D ZIS + U IO + S P="" +MAIN ; + F S P=$O(^DIC(9.4,"C",P)) Q:P="" D W L,U,P,U,S,U,V,U,D,! + .S (S,V,D)="error",S(1)=$O(^DIC(9.4,"C",P,0)) + .Q:'S(1) + .S S=$P(^DIC(9.4,S(1),0),U,3) + .S:S="" S="error" + .Q:'$D(^DIC(9.4,S(1),"VERSION")) + .S V=^DIC(9.4,S(1),"VERSION") + .I '$L(V) S V="error" Q + .S S(2)=$O(^DIC(9.4,S(1),22,"B",V,0)) + .Q:'S(2) + .S D=$P(^DIC(9.4,S(1),22,S(2),0),U,3) + .Q +ENDMAIN ; + S IOP=I,%ZIS("IOPAR")="(""zib.wrk"")" + D ZIS,ZISC + S X=$$JOBWAIT^%HOSTCMD("rm zib.wrk") + I $D(M) S X=$$JOBWAIT^%HOSTCMD("uucp -r "_F_" "_M_"!~") + I $D(A) S X=$$JOBWAIT^%HOSTCMD("uucp -r -nroot "_F_" "_A_"!~") + S ZTREQ="@" +Q ; + 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 +SYTM ;;cmbsyb +ZIS NEW A,D,F,I,J,L,M,P,R,S,V D ^%ZIS Q +ZISC NEW A,D,F,I,J,L,M,P,R,S,V D ^%ZISC Q +10 ;;abr-ab +11 ;;bji-ao +20 ;;albisc +30 ;;akarea +40 ;;bilcsy +50 ;;okc-ao +51 ;;nsa-oa +60 ;;phx-ao +61 ;;cao-as +70 ;;pordps +80 ;;nav-aa +00 ;;tucdev + NEW DIE,DR,DA + S DR="W $J("""",IOM-$L(%)\2)_%,!!" + S DA=$P($T(@($P(^AUTTAREA($P(^AUTTLOC($P(^AUTTSITE(1,0),U),0),U,4),0),U,2))),";;",2) + W ! + F %="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 + ; diff --git a/ZIBPKGP.m b/ZIBPKGP.m new file mode 100644 index 0000000..c3afa76 --- /dev/null +++ b/ZIBPKGP.m @@ -0,0 +1,99 @@ +ZIBPKGP ; IHS/ADC/GTH - PROCESS IMPLEMENTATION STATUS FILES ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + Q + ; +OPT ; Set option in OPTION file. + I $P(^%ZOSF("OS"),"^")'="MSM-UNIX" W !!,"SORRY. MSM-UNIX only.",! Q + I $S('$D(DUZ(0)):1,DUZ(0)'="@":1,1:0) W !,"PROGRAMMER ACCESS REQUIRED",! Q + NEW DA,DIC,DIE,DR + D HOME^%ZIS,DT^DICRW + S X="ZIB IMPLEMENTATION STATUS",DR="W $J("""",IOM-$L(%)\2)_%,!!" + W ! + F %="Option '"_X_"' will be placed","in the OPTION file for daily processing, beginning tomorrow morning","at 0530 AM. You can change the frequency/time of scheduling by","using the TaskMan option thru the Kernel." X DR + S DIC="^DIC(19,",DIC(0)="",DIC("DR")="1///ZIB Implementation Status;4///R;25///IN^ZIBPKGP;200///T+1@0530;202///1D" + I $D(^DIC(19,"B",$E(X,1,30))) S DIE=DIC,DA=$O(^DIC(19,"B",$E(X,1,30),0)),DR=DIC("DR") D DIE I 1 + E KILL DD,DO D FILE + W !!,"Done.",! + Q + ; +IN ;EP - From TaskMan. + ; A = Date of Installation + ; D = Directory + ; F = File + ; L = ASUFAC Code + ; P = Package Prefix + ; S = Short Description of Package + ; S(1) = 1st Subscript of ^DIZ(8009545 (Facility) + ; S(2) = 2nd Subscript of ^DIZ(8009545 (Package) + ; T = Patch + ; V = Version + ; Z = Line of Input + ; Read in status files from remote site and place in FM file. + ; + NEW A,D,F,L,P,S,T,V,XMB,XMTEXT,Z + S X=$$JOBWAIT^%HOSTCMD("ls -l /usr/spool/uucppublic/pkg* > zibpkg.wrk ; ls -l /usr/spool/uucppublic/rpi* >> zibpkg.wrk") + F A=0:0 S A=$O(^%ZIS(1,A)) Q:'A I ^(A,"TYPE")="HFS" S IOP=$P(^%ZIS(1,A,0),U),%ZIS("IOPAR")="(""zibpkg.wrk"":""R"")" D ZIS Q:'POP + Q:POP!('A) + KILL ^TMP($J) + U IO + F R %:300 Q:%="" S %=$P(%,"/",5) S:%?1"pkg"6N1"."3N ^TMP($J,"PKG",%)="" S:%?1"rpi"6N1"."3N ^TMP($J,"RPI",%)="" + S F="",D="/usr/spool/uucppublic/" +MAIN ; +PKG ; + F S F=$O(^TMP($J,"PKG",F)) Q:F="" U IO:(D_F) D + . F R Z:300 Q:(Z="")!(Z'?6N1"^"1U1.3UN1"^".E) D + .. S L=$P(Z,U),P=$P(Z,U,2),S=$P(Z,U,3),V=$P(Z,U,4),A=$P(Z,U,5) + .. S:S="" S="error" + .. D FAC + .. S DA=S(2),DIE="^DIZ(8009545,"_S(1)_",1,",DR="1////"_V_";2////P;3////"_A + .. D DIE + .. S ^TMP($J,"PKG",F)=L + ..Q + . S X=$$JOBWAIT^%HOSTCMD("rm "_D_F) + .Q + ; +RPI ; + F S F=$O(^TMP($J,"RPI",F)) Q:F="" U IO:(D_F) D + . F R Z:300 Q:(Z="")!(Z'?6N1"^"2.4L1".v"1.2N1"."1.2N.1A.2N1"p"1.3N1"^".E) I $P(Z,U,3)="INSTALLED" D + .. S L=$P(Z,U),T=$P(Z,U,2),A=$P(Z,U,4),P=$P(T,"."),V=$P($P(T,".v",2),"p"),T=$P($P(T,".v",2),"p",2) + .. F XMB="P","V" S X=@XMB X ^DD("FUNC",$O(^DD("FUNC","B","UPPERCASE",0)),1) S @XMB=X + .. S S=P + .. D FAC + .. S DA(2)=S(1),DA(1)=S(2),DA=T + .. I '$D(^DIZ(8009545,DA(2),1,DA(1),1,0)) S ^(0)="^8009545.03^^" + .. I '$D(^DIZ(8009545,DA(2),1,DA(1),1,DA)) S (X,DINUM)=DA,DIC="^DIZ(8009545,"_DA(2)_",1,"_DA(1)_",1,",DIC(0)="",DIC("DR")="1///"_A_";2///"_$P(Z,U,2) D FILE KILL DINUM I 1 + .. E S DIE="^DIZ(8009545,"_DA(2)_",1,"_DA(1)_",1,"_DA_",",DR="1///"_A_";2///"_$P(Z,U,2) D DIE + .. S ^TMP($J,"RPI",F)=L + ..Q + . S X=$$JOBWAIT^%HOSTCMD("rm "_D_F) + .Q + ; +ENDMAIN ; + D ZISC + S X=$$JOBWAIT^%HOSTCMD("rm zibpkg.wrk") + ; ^TMP($J,"PKG",file)=facility + S F="",%=0 + F S F=$O(^TMP($J,"PKG",F)) Q:F="" S %=%+1,XMTEXT(%)=" Application status received from "_^(F) + S F="" + F S F=$O(^TMP($J,"RPI",F)) Q:F="" I $L(^(F)) S %=%+1,XMTEXT(%)=" Patch application received from "_^(F) + I $L($O(^TMP($J,"PKG",""))) S XMB="ZIB PKG",XMTEXT="XMTEXT(" D XMB + KILL ^TMP($J) +Q ; + Q + ; +FAC ; + I '$D(^DIZ(8009545,"B",$O(^AUTTLOC("C",L,0)))) S X=$O(^AUTTLOC("C",L,0)),DIC="^DIZ(8009545,",DIC(0)="" D FILE S S(1)=+Y I 1 + E S S(1)=$O(^DIZ(8009545,"B",$O(^AUTTLOC("C",L,0)),0)) + I '$D(^DIZ(8009545,S(1),1,0)) S ^(0)="^8009545.02PA^^" + I '$D(^DIC(9.4,"C",P)) S X=S,DIC="^DIC(9.4,",DIC(0)="",DIC("DR")="1///"_P_";2///"_S D FILE S S(2)=+Y I 1 + E S S(2)=$O(^DIC(9.4,"C",P,0)) + I '$D(^DIZ(8009545,S(1),1,"B",S(2))) S X=S(2),DA(1)=S(1),DIC="^DIZ(8009545,"_S(1)_",1,",DIC(0)="" D FILE S S(2)=+Y I 1 + E S S(2)=$O(^DIZ(8009545,S(1),1,"B",S(2),0)) + Q + ; +FILE NEW A,D,DD,DO,F,L,P,S,T,V,Z D FILE^DICN KILL DIC Q +DIE NEW A,D,F,L,P,S,T,V,Z D ^DIE KILL DA,DR,DIE Q +XMB NEW A,D,F,L,P,S,T,V,Z D ^XMB Q +ZIS NEW A,D,F,L,P,S,T,V,Z D ^%ZIS Q +ZISC NEW A,D,F,L,P,S,T,V,Z D ^%ZISC Q diff --git a/ZIBRD.m b/ZIBRD.m new file mode 100644 index 0000000..e7bdea1 --- /dev/null +++ b/ZIBRD.m @@ -0,0 +1,31 @@ +%ZIBRD ; IHS/ADC/GTH - DISPLAY MSM DIRECTORY OF SELECTED RTNS ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods. + ; + ; Generate routine directory of selected routines + ; + ; Save, or %RCOPY, this routine to the MGR uci, named as + ; %ZIBRD. It may also be name %AZRD. + ; +START ; + I $$VERSION^%ZOSV(1)["Cache" D ^%RD KILL MSYS,R,nrou Q ; IHS/SET/GTH XB*3*9 10/29/2002 + X ^%ZOSF("RSEL") + G:$O(^UTILITY($J,""))="" EXIT + NEW I,NAM,Y + W !?21,"Routine Directory",?40 + D ^%D + X ^%ZOSF("UCI") + W !?25,"of ",Y,?40 + D ^%T + W ! +%ST1 ; + ;S NAM="" ;IHS/SET/GTH XB*3*9 10/29/2002 + S NAM=0 ;IHS/SET/GTH XB*3*9 10/29/2002 + F I=0:1 S NAM=$O(^UTILITY($J,NAM)) Q:NAM="" W:'(I#8) ! W NAM,$J("",9-$L(NAM)) + W !?5,I," Routines",! + G START ;IHS/SET/GTH XB*3*9 10/29/2002 +EXIT ; + KILL %UCI,%UCN + KILL I,^UTILITY($J) + Q + ; diff --git a/ZIBRNSPC.m b/ZIBRNSPC.m new file mode 100644 index 0000000..7fdafa9 --- /dev/null +++ b/ZIBRNSPC.m @@ -0,0 +1,213 @@ +ZIBRNSPC ; IHS/ADC/GTH - NAMESPACE PREVIOUSLY WRITTEN ROUTINES ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods. + ; +INIT ; + KILL (%) + D ^XBKVAR + S DTIME=300 + KILL %,DISYS,%H,X,^UTILITY($J),^TMP("ZIBRNSPC",$J) + S IOP=$I + D ^%ZIS +START ; + W "Routine Namespace Converter",! + S ZIBRQUIT=0 + D SETUP + G:ZIBRQUIT EXIT + ;S ZIBRRTN="";IHS/SET/GTH XB*3*9 10/29/2002 + S ZIBRRTN=0 ;IHS/SET/GTH XB*3*9 10/29/2002 + F ZIBRQ=0:0 S ZIBRRTN=$O(^UTILITY($J,ZIBRRTN)) Q:ZIBRRTN="" W !!,"-- ",ZIBRRTN," --",!! D RLOAD,RFIX,RSAVE,RNDX +EXIT ; + W !!,"Done.",! + KILL ^UTILITY($J),^TMP("ZIBRNSPC",$J),DUOUT,DTOUT,IOP + KILL ZIBRANS,ZIBRCAND,ZIBRCH,ZIBRCMDT,ZIBRCPOS,ZIBRDEV,ZIBRFLI,ZIBRI,ZIBRJ,ZIBRL,ZIBRLINE,ZIBROBJ,ZIBROUTP,ZIBRPART,ZIBRPLEV,ZIBRPN,ZIBRPRFX,ZIBRQ,ZIBRQUIT,ZIBRRTN,ZIBRT,ZIBRV,ZIBRW,ZIBRXC + Q + ; +SETUP ; INITIALIZE UTILITY + F ZIBRT="EXC","PEXC" F ZIBRI=0:1 S ZIBRL=$T(@ZIBRT+ZIBRI),ZIBRL=$P(ZIBRL,";;",2,255) Q:ZIBRL="" F ZIBRJ=1:1 S ZIBRW=$P(ZIBRL,"^",ZIBRJ) Q:ZIBRW="" S ^TMP("ZIBRNSPC",$J,ZIBRT,ZIBRW)="" +PLOOP ; + R "Package prefix (1-5 characters): ",ZIBRPRFX:DTIME + S:'$T ZIBRPRFX="^" + I "^"'[ZIBRPRFX I $L(ZIBRPRFX)>5!(ZIBRPRFX'?1.5U) W *7," -- Invalid prefix",! G PLOOP + W ! + I "^"[ZIBRPRFX S ZIBRQUIT=1 Q + W !,"Enter any variables to be treated as external references --",!,"not to be namespaced -- in the form NAME1,NAME2,...",! + F ZIBRQ=0:0 R " Externals: ",ZIBRL:DTIME,! S:'$T ZIBRL="^" Q:"^"[ZIBRL D:ZIBRL["?" SHEXT I ZIBRL]"" F ZIBRI=1:1 S ZIBRW=$P(ZIBRL,",",ZIBRI) Q:ZIBRW="" S ^TMP("ZIBRNSPC",$J,"EXC",ZIBRW)="" W " ",ZIBRW,! + I ZIBRL["^" S ZIBRQUIT=1 Q + X ^%ZOSF("RSEL") + I $O(^UTILITY($J,""))="" S ZIBRQUIT=1 + Q + ; +SHEXT ; + W !?2,"Currently defined externals:",! + S ZIBRW="" + F ZIBRQ=0:0 S W=$O(^TMP("ZIBRNSPC",$J,"EXC",ZIBRW)) Q:ZIBRW="" W ?3,ZIBRW,! + W ! + S ZIBRL="" + Q + ; +EXC ;;X^Y^DIE^DIC^DT^U^DUZ^DTIME^ZTSK^ZTDESC^ZTSAVE^ZTLOAD^ZTRTN^ZTIO^ZTDTH + ;; +PEXC ;;IO^D^XB^Z + ;; + ; +RLOAD ; LOAD ROUTINE INTO GLOBAL + W "Beginning routine load ... " + KILL ^TMP("ZIBRNSPC",$J,"T"),^("K") + S ZIBRXC=$E($T(RLOADX),10,255) + X ZIBRXC + W " completed.",! + Q + ; +RLOADX ;;S ^TMP("ZIBRNSPC",$J,"T",0)=ZIBRRTN ZL @ZIBRRTN F ZIBRI=1:1 S ZIBRL=$T(+ZIBRI) Q:ZIBRL="" S ^(ZIBRI)=ZIBRL + ; +RSAVE ; SAVE GLOBAL TEXT AS ROUTINE + W "Beginning routine save ... " + S ZIBRXC=$P($T(RSAVEX),"RSAVEX ",2) + X ZIBRXC + W " completed.",! + Q + ; + ; S ZIBRRTN=^TMP("ZIBRNSPC",$J,"T",0) X "ZR X ""F ZIBRI=1:1 Q:'$D(^(ZIBRI)) ZI ^(ZIBRI)"" ZS @ZIBRRTN" ; IHS/SET/GTH XB*3*9 10/29/2002 +RSAVEX S ZIBRRTN=^TMP("ZIBRNSPC",$J,"T",0) ZR X "F ZIBRI=1:1 Q:'$D(^(ZIBRI)) ZI ^(ZIBRI)" ZS @ZIBRRTN + ; +RNDX ; PRINT INDEX OF ROUTINE CONVERSION + KILL %ZIS,IOP + S %ZIS("A")="Enter device for auxiliary listing of variable changes",%ZIS("B")="" + D ^%ZIS + S ZIBRDEV=$S($D(DTOUT)!$D(DUOUT):"^",IO=IO(0):0,1:IO) + Q:ZIBRDEV["^" + D RNDXP + I ZIBRDEV U ZIBRDEV D RNDXP D ^%ZISC + Q + ; +RNDXP ; + S ZIBRV=" " + F ZIBRI=0:1 S:ZIBRI=4 ZIBRI=0 W:ZIBRI=0 ! S ZIBRV=$O(^TMP("ZIBRNSPC",$J,"V",ZIBRV)) Q:ZIBRV="" W ?(19*ZIBRI),$J(ZIBRV,8),">",^(ZIBRV) + W ! + Q + ; +RFIX ; FIX ROUTINE LINES STORED IN GLOBAL + F ZIBRFLI=1:1 Q:'$D(^TMP("ZIBRNSPC",$J,"T",ZIBRFLI)) S ZIBRLINE=^(ZIBRFLI) D LSCAN S ^TMP("ZIBRNSPC",$J,"T",ZIBRFLI)=ZIBROUTP + W "Line modification completed.",! + Q + ; +LSCAN ; SCAN LINE AND REPLACE VARIABLES + S ZIBRCPOS=$F(ZIBRLINE," ")-1,ZIBRCH=" ",ZIBROUTP=$E(ZIBRLINE,1,ZIBRCPOS-1) + F ZIBRQ=0:0 Q:ZIBRCH="" D COPY1,CMD + Q + ; +CMD ; + I ZIBRCH=";" S ZIBROUTP=ZIBROUTP_$E(ZIBRLINE,ZIBRCPOS,255),ZIBRCPOS=$L(ZIBRLINE)+1,ZIBRCH="" Q + S ZIBRCMDT=ZIBRCH + F ZIBRQ=0:0 Q:": "[ZIBRCH D COPY1 + D:ZIBRCH=":" EXPR + Q:ZIBRCH="" + D COPY1 + I ZIBRCH'=" " D ARGS + Q + ; +COPY1 ; + S ZIBROUTP=ZIBROUTP_ZIBRCH + D ADVPOS + Q + ; +ADDOBJ ; + S ZIBROBJ=ZIBROBJ_ZIBRCH + D ADVPOS + Q + ; +ADVPOS ; + S ZIBRCPOS=ZIBRCPOS+1,ZIBRCH=$E(ZIBRLINE,ZIBRCPOS) + Q + ; +EXPR ; + F ZIBRQ=0:0 Q:" "[ZIBRCH D COPYOBJ + Q + ; +COPYOBJ ; COPY AN OBJECT, CHECKING FOR VARIABLES + I ZIBRCH="""" D QSTR Q + I ZIBRCH'?1AN,"%^$"'[ZIBRCH D COPY1 Q + S ZIBROBJ="" + F ZIBRQ=0:0 D ADDOBJ Q:ZIBRCH'?1AN + D:$E(ZIBROBJ)?1A TSTOBJ + S ZIBROUTP=ZIBROUTP_ZIBROBJ + Q + ; +QSTR ; COPY QUOTED STRING (INCLUDED DOUBLED QUOTES) + F ZIBRQ=0:0 D COPY1 Q:""""[ZIBRCH + D COPY1 + G:ZIBRCH="""" QSTR + Q + ; +ARGS ; COPY ARGUMENTS -- 'DO' AND 'GO' SPECIAL CASES + I "GD"'[ZIBRCMDT D EXPR Q + F ZIBRQ=0:0 Q:" "[ZIBRCH D DGARG D:ZIBRCH=":" CPYTCOM + Q + ; +DGARG ; PROCESS DO/GO ARGUMENTS + I ZIBRCH="@" D CPYTCOM Q + F ZIBRQ=0:0 Q:",: "[ZIBRCH D COPY1 + D:ZIBRCH="," COPY1 + Q + ; +CPYTCOM ; COPIES OBJECTS THRU ZERO-LEVEL COMMA + S ZIBRPLEV=0 + F ZIBRQ=0:0 D CPYTKN Q:" "[ZIBRCH Q:ZIBRCH=","&(ZIBRPLEV=0) + D:ZIBRCH="," COPY1 + Q + ; +CPYTKN ; COPIES A TOKEN, MODIFYING PARENTHESIS LEVEL + I ZIBRCH="(" S ZIBRPLEV=ZIBRPLEV+1 D COPY1 Q + I ZIBRCH=")" S ZIBRPLEV=ZIBRPLEV-1 D COPY1 Q + D COPYOBJ + Q + ; +TSTOBJ ; CONDITIONALLY REPLACES A VARIABLE NAME + Q:$E(ZIBROBJ,1,$L(ZIBRPRFX))=ZIBRPRFX + Q:$D(^TMP("ZIBRNSPC",$J,"EXC",ZIBROBJ)) + I $D(^TMP("ZIBRNSPC",$J,"V",ZIBROBJ)) S ZIBROBJ=^(ZIBROBJ) Q + D CHKPART + I ZIBRPART D VERPART Q:'ZIBRPART + S ZIBRCAND=ZIBRPRFX_ZIBROBJ + D VERCAND + S:ZIBRCAND="^" ZIBRCAND=ZIBROBJ + S ^TMP("ZIBRNSPC",$J,"V",ZIBROBJ)=ZIBRCAND + S ^TMP("ZIBRNSPC",$J,"NV",ZIBRCAND)=ZIBROBJ + S ZIBROBJ=ZIBRCAND + Q + ; +CHKPART ; VERIFY MATCH WITH EXCLUSION PARTIAL NAME LIST + S ZIBRPART=0,ZIBRPN="" + F ZIBRQ=0:0 S ZIBRPN=$O(^TMP("ZIBRNSPC",$J,"PEXC",ZIBRPN)) Q:ZIBRPN="" I $E(ZIBROBJ,1,$L(ZIBRPN))=ZIBRPN S ZIBRPART=1 Q + Q + ; +VERPART ; MANAGE PARTIAL MATCH + W "'",ZIBROBJ,"' begins with '",ZIBRPN,"'",! + R "Do you wish to treat it as an external reference? YES// ",ZIBRANS:DTIME,! + S:'$T ZIBRANS="Y" + S ZIBRANS=$E(ZIBRANS_"Y") + I ZIBRANS="?" W " Usage: ",ZIBRLINE,! G VERPART + S:ZIBRANS?1L ZIBRANS=$C($A(ZIBRANS)-32) + S:ZIBRANS="Y" ZIBRPART=0,^TMP("ZIBRNSPC",$J,"EXC",ZIBROBJ)="" + Q + ; +VERCAND ; MANAGE AUTO CANDIDATE SELECTION + I $L(ZIBRCAND)>8 W "'",ZIBRCAND,"' cannot be used for '",ZIBROBJ,"' due to its length.",! D GETALT G VERCAND + I $D(^TMP("ZIBRNSPC",$J,"NV",ZIBRCAND)),^(ZIBRCAND)'=ZIBROBJ W "'",ZIBRCAND,"' cannot be used for '",ZIBROBJ,"'; used for '",^(ZIBRCAND),"'",! D GETALT G VERCAND + Q + ; +GETALT ; GET ALTERNATE FOR PROPOSED CANDIDATE REPLACEMENT NAME + R "Please supply an alternative: ",ZIBRCAND:DTIME + S:'$T ZIBRCAND="^" + Q:ZIBRCAND="^" + I ZIBRCAND="?" W " Usage: ",ZIBRLINE,! G GETALT + I $E(ZIBRCAND,1,$L(ZIBRPRFX))=ZIBRPRFX W ! Q + W *7," -- does not begin with '",ZIBRPRFX,"'",! + R "Are you sure you want a non-namespaced variable? N// ",ZIBRANS:DTIME,! + S:'$T ZIBRANS="N" + S ZIBRANS=$E(ZIBRANS_"N") + I ZIBRANS?1L S ZIBRANS=$C($A(ZIBRANS)-32) + I ZIBRANS="Y" W ! Q + G GETALT + ; diff --git a/ZIBRPI.m b/ZIBRPI.m new file mode 100644 index 0000000..1217645 --- /dev/null +++ b/ZIBRPI.m @@ -0,0 +1,139 @@ +ZIBRPI ; IHS/ADC/GTH - REMOTE PATCH INSTALLATION ; [ 11/04/97 10:26 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*1 IHS/ADC/GTH 03-07-97 Correct spelling of uucppublic. + ; XB*3*2 IHS/ADC/GTH 04-21-97 Correct patch file pattern match. + ; XB*3*3 IHS/ADC/GTH 04-25-97 Correct patch file name handling. + ; + ; For a description of this utility, see the text in routine + ; ZIBRPI2. + ; + ; D = Directory containing patch files + ; D("OUT") = Directory with results files + ; E = "Action" routine, named (A/B)9 + ; F = Name of a file containing a patch + ; J = Today's Julian date + ; L = Facility's Pseudo Prefix + ; N = Namespace derived from the name of the file + ; O = Operating System, and OS-specific commands + ; P = PACKAGE file IEN + ; V = Version derived from the name of the file + ; W = Work file + ; + W !!,"EXECUTION UNAUTHORIZED.",! + Q + ; +OPT ;EP - Set option in OPTION file. Called by a programmer. + D OPT^ZIBRPI1 + Q + ; +START ;EP - From TaskMan. + NEW %ZIS,D,DA,DIC,E,F,I,J,L,N,O,P,POP,V,W,XMSUB,XMTEXT,XMY + D HFS + Q:POP + D OS + KILL ^TMP($J) + ; rm xmit files over 2 weeks old. + S L=$P(^AUTTLOC($P(^AUTTSITE(1,0),U),1),U,2) I '($L(L)=3) S L="RPI" + D HC(O("LS")_D("OUT")_O("NS")_L_".* > "_W) + S IOP=I,%ZIS("IOPAR")="("""_W_""":""R"")" + D ZIS,JDT + U IO + ; Comment next line to keep xmit ("rpi") files over 2 wks old. + F R %:300 Q:%="" S %=$P(%,"/",$L(%,"/")),X=+$P(%,".",2) I $P(%,".")=O("NS")_L,((+X>+J)!(+X<(+J-14))) D HC(O("RM")_D("OUT")_%) + D HC(O("RM")_W) + ; Initialize namespace, systems, and frequency. + S %=+$P(^DIC(19,$O(^DIC(19,"B","ZIB REMOTE PATCH INSTALLATION",0)),20)," ",2),D=$P($P(^(20),"""",2),U) + S:'("/\"[$E(D,$L(D))) D=D_$S(O["UNIX":"/",1:"\") + D HC(O("LS")_D_"*.*"_" > "_W) + S IOP=I,%ZIS("IOPAR")="("""_W_""":""R"")" + D ZIS + U IO + ; The Q:%="" in the following line is non-standard MUMPS. + F R %:300 Q:%="" S %=$P(%,"/",$L(%,"/")) I %?@O("PF") S ^TMP($J,"ZIBRPI",%)="" + S F="" + I '$L($O(^TMP($J,"ZIBRPI",""))) D ZISC D HC(O("RM")_W) KILL ^TMP($J) S:$D(ZTQUEUED) ZTREQ="@" Q +MAIN ; + F S F=$O(^TMP($J,"ZIBRPI",F)) Q:F="" D S ^TMP($J,"ZIBRPI",F)=% D:%="INSTALLED" HC(O("RM")_D_F) + . S X=$E(F,1,4),X=$P(X,"_"),N=$$UP^XLFSTR(X) + . I '$D(^DIC(9.4,"C",N)) S %="FAILED - Not an Installed Package" Q + . S P=$O(^DIC(9.4,"C",N,0)) + . I 'P S %="FAILED - Bad ""C"" x-ref for "_N Q + . I '$D(^DIC(9.4,P,"VERSION")) S %="FAILED - 'VERSION' Node Missing" Q + . S V=+($E(F,5,6)_"."_$E(F,7,8)) + . I (+V)'=(+^DIC(9.4,P,"VERSION")) S %="FAILED - V "_^("VERSION")_" of "_N_" is Installed" Q + . ; S E=$S("AB"[$E(N):$E(N),1:"B")_"9"_N_$P($P(F,".",2),"p",2) ; XB*3*3 IHS/ADC/GTH 04-25-97 Correct patch file name handling. + . S E=$S("AB"[$E(N):$E(N),1:"B")_"9"_N_(+$P($P(F,".",2),"p",1)) ; XB*3*3 IHS/ADC/GTH 04-25-97 Correct patch file name handling. + . U IO:(D_F) + . R %:300 + . R %:300 + . ; The ZL and ZS in the following line are non-standard M commands. + . F R %:300 Q:%="" S:%=E ^TMP($J,"B9",%)="" X "ZL ZS @%" + . S DA(1)=^DIC(9.4,P,"VERSION"),DA(1)=$O(^DIC(9.4,P,22,"B",DA(1)_$S(DA(1)[".":"",1:".0"),0)) + . I 'DA(1) S DA(1)=$P(^DIC(9.4,P,22,0),U,3) + . S:'$D(^DIC(9.4,P,22,DA(1),"PAH",0)) ^(0)="^9.4901^^" + . ; S X=N_"*"_V_"*"_$P($P(F,".",2),"p",2),DIC="^DIC(9.4,"_P_",22,"_DA(1)_",""PAH"",",DIC(0)="",DIC("DR")=".02///"_DT_";.03///.5",DA(2)=P ; XB*3*3 IHS/ADC/GTH 04-25-97 Correct patch file name handling. + . S X=N_"*"_V_"*"_(+$P($P(F,".",2),"p",1)),DIC="^DIC(9.4,"_P_",22,"_DA(1)_",""PAH"",",DIC(0)="",DIC("DR")=".02///"_DT_";.03///.5",DA(2)=P ; XB*3*3 IHS/ADC/GTH 04-25-97 Correct patch file name handling. + . D FILE + . S %="INSTALLED" + . Q +ENDMAIN ; + D OS + S %=0,F="",D=D("OUT")_O("NS")_L_"."_J + U IO:(D:"W") + F S F=$O(^TMP($J,"ZIBRPI",F)) Q:F="" W L,U,F,U,^(F),U,DT,! S %=%+1,XMTEXT(%)="Restore from file "_$E(F_$J("",14),1,14)_": "_^(F) + U IO:(W) + D ZISC,HC(O("RM")_W) + ; uucp according to parameter: ENTRY ACTION of option. + S %=+$P(^DIC(19,$O(^DIC(19,"B","ZIB REMOTE PATCH INSTALLATION",0)),20)," ",2),E=$P($P(^(20),"""",2),U,2) + I O["UNIX" D + . I '(%=2) D HC("uucp -r "_D_" "_$P($T(SYTM),";",3)_"!~") + . I %>1 D HC("uucp -r -nroot "_D_" "_$P(^AUTTSITE(1,0),U,14)_"!~") + . Q + S XMTEXT="XMTEXT(",XMSUB=$P($P($T(ZIBRPI),";",2),"-",2),XMY(1)="" + D XMD + I E S %="" F S %=$O(^TMP($J,"B9",%)) Q:%="" D RTN(U_%) + KILL ^TMP($J) + S ZTREQ="@" +Q ; + Q + ; +DIE NEW D,E,F,I,J,L,N,O,P,V,W D ^DIE Q +DIR NEW D,E,F,I,J,L,N,O,P,V,W D ^DIR Q +DTC NEW D,E,F,I,J,L,N,O,P,V,W D ^%DTC Q +FILE NEW D,E,F,I,J,L,N,O,P,V,W KILL DD,DO D FILE^DICN Q +HC(%) NEW D,E,F,I,J,L,N,O,P,V,W S %=$$JOBWAIT^%HOSTCMD(%) Q +RTN(%) NEW D,E,F,I,J,L,N,O,P,V,W D @(%) Q +XMD NEW D,E,F,I,J,L,N,O,P,V,W D ^XMD Q +ZIS NEW D,E,F,I,J,L,N,O,P,V,W D ^%ZIS Q +ZISC NEW D,E,F,I,J,L,N,O,P,V,W D ^%ZISC Q + ; +HFS ; + ; F I=0:0 S I=$O(^%ZIS(1,I)) Q:'I I ^(I,"TYPE")="HFS" S IOP=$P(^%ZIS(1,I,0),U),%ZIS("IOPAR")="(""/usr/spool/uucpublic/work.zib"":""W"")" D ZIS Q:'POP ; XB*3*1 IHS/ADC/GTH 03-07-97 Correct spelling of uucppublic. + F I=0:0 S I=$O(^%ZIS(1,I)) Q:'I I ^(I,"TYPE")="HFS" S IOP=$P(^%ZIS(1,I,0),U),%ZIS("IOPAR")="(""/usr/spool/uucppublic/work.zib"":""W"")" D ZIS Q:'POP ; XB*3*1 IHS/ADC/GTH 03-07-97 Correct spelling of uucppublic. + I 'I,'$D(POP) S POP=1 + Q:POP + S I=$P(^%ZIS(1,I,0),U) + Q + ; +JDT ; + NEW X1,X2 + S X2=$E(DT,1,3)_"0101",X1=DT + D DTC + S X=X+1,X="00"_X,J=$E(X,$L(X)-2,$L(X)) + Q + ; +OS ; The "IN" directory is retrieved from the OPTION entry. + S O=$P($P(^%ZOSF("OS"),","),"-",2),O("PF")=$P($T(PATTERN),";",3) + S W=$P($T(WORK),";",3),O("NS")=$P($T(NS),";",3) + I O["UNIX" S (D("IN"),D("OUT"))=$P($T(PUB),";",3),O("RM")="rm ",O("LS")="ls -l ",W=D("OUT")_W Q + S %=$G(^AUTTSITE(1,1)),D("IN")=$P(%,U),D("OUT")=$P(%,U,2),O("RM")="DEL ",O("LS")="DIR /B " + Q + ; + ; XB*3*2 IHS/ADC/GTH 04-21-97 Correct patch file pattern match. + ; Old PATTERN: + ;;2.4L.2"_"4N1"."1"p"1.2N +SYTM ;;dpssyg +PATTERN ;;2.4L.2"_"4N1"."1.2N1"p"; XB*3*2 IHS/ADC/GTH 04-21-97 Correct patch file pattern match. +WORK ;;ZIBRPI.WRK +PUB ;;/usr/spool/uucppublic/ +NS ;;ZIB_P diff --git a/ZIBRPI1.m b/ZIBRPI1.m new file mode 100644 index 0000000..126a47e --- /dev/null +++ b/ZIBRPI1.m @@ -0,0 +1,79 @@ +ZIBRPI1 ; IHS/ADC/GTH - REMOTE PATCH INSTALLATION (1) ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + 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 + KILL 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:300 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 KILL 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),%ZIS("IOPAR")="(""/usr/spool/uucppublic/work.zib"":""W"")" 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 diff --git a/ZIBRPI2.m b/ZIBRPI2.m new file mode 100644 index 0000000..0dfe3c7 --- /dev/null +++ b/ZIBRPI2.m @@ -0,0 +1,64 @@ +ZIBRPI2 ; IHS/ADC/GTH - REMOTE PATCH INSTALLATION (2) ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + 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 + ; diff --git a/ZIBRPRTD.m b/ZIBRPRTD.m new file mode 100644 index 0000000..fe901ee --- /dev/null +++ b/ZIBRPRTD.m @@ -0,0 +1,105 @@ +ZIBRPRTD ; IHS/ADC/GTH - ROUTINE PRINT ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods. + ; This routine lists routines edited after given date. + ; +BEGIN ; + ;Begin adds/edits;IHS/SET/GTH XB*3*9 10/29/2002 + ;I ^%ZOSF("OS")'["MSM" D OSNO^XB Q + ;S X="ERR^ZIBRPRTD",@^%ZOSF("TRAP") + ;W !?10,$P($P($ZV,","),"-")," - Routine Print Utility" + NEW ZIBOS + S ZIBOS=$$VERSION^%ZOSV(1) + I '(ZIBOS["Cache"),'(ZIBOS["MSM") D OSNO^XB Q + I ZIBOS["MSM" S X="ERR^ZIBRPRTD",@^%ZOSF("TRAP") + I ZIBOS["Cache" S X="BACK^%ETN",@^%ZOSF("TRAP") + W !?10,ZIBOS," - Routine Print Utility" + ;End adds/edits;IHS/SET/GTH XB*3*9 10/29/2002 +RSEL ; + S %DEV=$I + U 0 + KILL QUIT + ;X ^%ZOSF("RSEL") ;IHS/SET/GTH XB*3*9 10/29/2002 + S %R=1 X ^%ZOSF("RSEL") ;IHS/SET/GTH XB*3*9 10/29/2002 + ;I $D(QUIT) W !,"No routines selected" G EXIT ;IHS/SET/GTH XB*3*9 10/29/2002 + I $D(QUIT)!(%R=0) W !,"No routines selected" G EXIT ;IHS/SET/GTH XB*3*9 10/29/2002 + S XBTYPE="PRINT" + D ^XBDATE ;ADDED TO SPECIFY A DATE AND SCREEN OUT ROUTINES EDITED SINCE SPECIFIED DATE + I $D(QUIT) W !,"No routines will be printed." H 2 G EXIT +SDEV ; + ;I %DEV=$I D PR^%SDEV G:$D(QUIT) EXIT ;IHS/SET/GTH XB*3*9 10/29/2002 + D ^%ZIS G:POP EXIT S %DEV=IO ;IHS/SET/GTH XB*3*9 10/29/2002 +F1 ; + S %LPP=60,%W=132 + W !!,"Lines per page <",%LPP,">: " + R %I:$G(DTIME,999) + I %I="" S %I=%LPP W %I + I %I'?1N.N G:%I="^" SDEV:$I'=%DEV,RSEL G:%I="^Q" EXIT W !,*7,"Response must be positive numeric" G F1 + S %LPP=+%I +F2 ; + W !,"Characters per line <",%W,">: " + R %I:$G(DTIME,999) + I %I="" S %I=%W W %I + I %I'?1N.N G EXIT:%I="^Q",F1:%I="^" W !,*7,"Response must be positive numeric" G F2 + S %W=+%I,%L=%W-18-63,%CMT="" + G:%L'>0 START +CMT ; + R !,"Enter comment for page header : ",%CMT:$G(DTIME,999) + G F2:%CMT="^",CMT1:%CMT'="?" + W !,"The comment will be displayed with the UCI, date, and time on each page header." + G CMT + ; +CMT1 ; + I $L(%CMT)>%L W !,*7,"Too long. Maximum comment length is ",%L G CMT +START ; + D INT^%T,INT^%D + D FORMAT + U %DEV + ;Begin adds/edits;IHS/SET/GTH XB*3*9 10/29/2002 + ;W !! + ;I %DEV<20!(%DEV>63) U %DEV:%W + ;U 0 + I ZIBOS["Cache" W @IOF + I %DEV<20!(%DEV>63),ZIBOS["MSM" U %DEV:%W + U $P + ;End adds/edits;IHS/SET/GTH XB*3*9 10/29/2002 + W !!,"Done. " +EXIT ; + ;U 0 ;IHS/SET/GTH XB*3*9 10/29/2002 + ;I '$D(QUIT),%DEV'=$I,+%DEV S IO=%DEV D ^%ZISC ;IHS/SET/GTH XB*3*9 10/29/2002 + I '$D(QUIT),%DEV'=$I S IO=%DEV D ^%ZISC ;IHS/SET/GTH XB*3*9 10/29/2002 + KILL %DEV,%LPP,%W,%I,%J,%CMT,%TIM,%TIM1,%DAT,%DAT1,%PG,%PGG,%RN,%L,%R,%X,%,%BLK,QUIT + Q + ; +ERR ;EP - If error, from error trap. + I $F($$Z^ZIBNSSV("ERROR"),"") U 0 W !!,"...Aborted." D EXIT V 0:$J:$ZB($V(0,$J,2),#0400,7):2 + ZQ + ; +FORMAT ; + S %PG=1,%PGG=1 + W !!,"Printing ...",! +F3 ; + ;Begin adds/edits;IHS/SET/GTH XB*3*9 10/29/2002 + ;S %X="W:$Y # W !,""Routine: "",%RN,?20,""UCI: "",$ZU(0),"" Date/Time: "",%DAT1,"", "",%TIM1,?$X+3,%CMT,?%W-18,""Page: "",%PG,""-"",%PGG,! S %PGG=%PGG+1" + ;U %DEV + ;I %DEV<20!(%DEV>63) U %DEV:%W + ;S %RN="" + ;F %I=1:1 S %RN=$O(^UTILITY($J,%RN)) Q:%RN="" X:$V(8,$J,2)'=$I "U 0 W ?$S($X=0:0,1:$X+10\10*10-1),%RN W:$X>70 ! U %DEV" D F4 S %PG=%PG+1,%PGG=1 + S:ZIBOS["MSM" %X="W:$Y # W !,""Routine: "",%RN,?20,""UCI: "",$ZU(0),"" Date/Time: "",%DAT1,"", "",%TIM1,?$X+3,%CMT,?%W-18,""Page: "",%PG,""-"",%PGG,! S %PGG=%PGG+1" + S:ZIBOS["Cache" %X="W:$Y # W !,""Routine: "",%RN,?20,""Namespace: "",$ZU(5),"" Date/Time: "",%DAT,"", "",%TIM,?$X+3,%CMT,?%W-18,""Page: "",%PG,""-"",%PGG,! S %PGG=%PGG+1" + U %DEV + I ZIBOS["MSM" D + . I %DEV<20!(%DEV>63) U %DEV:%W + . S %RN="" + . F %I=1:1 S %RN=$O(^UTILITY($J,%RN)) Q:%RN="" X:$V(8,$J,2)'=$I "U 0 W ?$S($X=0:0,1:$X+10\10*10-1),%RN W:$X>70 ! U %DEV" D F4 S %PG=%PG+1,%PGG=1 + I ZIBOS["Cache" D + . S %RN=0 + . F %I=1:1 S %RN=$O(^UTILITY($J,%RN)) Q:%RN="" X "U $P W ?$S($X=0:0,1:$X+10\10*10-1),%RN W:$X>70 ! U %DEV" D F4 S %PG=%PG+1,%PGG=1 + ;End adds/edits;IHS/SET/GTH XB*3*9 10/29/2002 + Q + ; +F4 ; + X %X + X "ZL @%RN F %I=1:1 S %J=$T(+%I) Q:%J="""" S %L=$P(%J,"" ""),%R=$P(%J,"" "",2,255) X:$Y>%LPP %X W !,%L,?10 F %J=1:%W-10:255 S %L=$E(%R,1,%W-10),%R=$E(%R,%W-10+1,255) W %L Q:%R="""" X:$Y>%LPP %X W !,""..........""" + Q + ; diff --git a/ZIBRSEL.m b/ZIBRSEL.m new file mode 100644 index 0000000..69ce5d9 --- /dev/null +++ b/ZIBRSEL.m @@ -0,0 +1,62 @@ +ZIBRSEL ; IHS/ADC/GTH - NONINTERACTIVE ROUTINE SELECT ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent err. + ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods. + ; + ; Return the number of selected routines set into the + ; indicated variable. + ; + ; E.g.: + ; I '$$RSEL^ZIBRSEL("B-BZZZZZZZ","ARRAY(") W "NONE SELECTED" Q + ; + ; If routines exists in the list or range, their name will + ; be returned as the last subscript of indicated variable in + ; the 2nd parameter. The default is ^TMP("ZIBRSEL",$J, + ; + ; If routine B exists, then node ^TMP("ZIBRSEL",$J,"B") will + ; be null. + ; + ; It is the programmer's responsibility to ensure the name + ; of the array is correctly formed. + ; + ; Variables used: + ; X = String indicating list or range of routines. + ; Y = String indicating variable into which to set the + ; selected routines. Default = ^TMP("ZIBRSEL",$J, + ; F = First routine, if range. + ; L = Last routine, if range. + ; N = Number of routines returned. + ; Q = Quote character. + ; + Q + ; +RSEL(X,Y) ;PEP - Select a list or range of routines, return in Y, # sel in N. + I '$L($G(X)) Q "NO ROUTINES SPECIFIED IN PARAMETER" + NEW F,L,N,O,Q + ; S O=$P(^%ZOSF("OS"),"-",1) ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent err. + ;S O=$P(^%ZOSF("OS"),"^",1) ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent err. ;IHS/SET/GTH XB*3*9 10/29/2002 + ;I O["MSM" S O="MSM" ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent err. ;IHS/SET/GTH XB*3*9 10/29/2002 + ;E S O="unknown" ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent err. ;IHS/SET/GTH XB*3*9 10/29/2002 + ;I '$L($T(@O)) Q "OPERATING SYSTEM '"_O_"' NOT SUPPORTED." ;IHS/SET/GTH XB*3*9 10/29/2002 + S O=$$VERSION^%ZOSV(1),O=$P(O," ") ;IHS/SET/GTH XB*3*9 10/29/2002 + I '(O["Cache"),'(O["MSM") Q "OPERATING SYSTEM '"_O_"' NOT SUPPORTED." ;IHS/SET/GTH XB*3*9 10/29/2002 + 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 ;IHS/SET/GTH XB*3*9 10/29/2002 + D DIR ;IHS/SET/GTH XB*3*9 10/29/2002 + Q N + ; +DIR ; Check the directory ;IHS/SET/GTH XB*3*9 10/29/2002 +MSM ; Micronetics Standard MUMPS. + ;I F]"",$D(^ (F)) S N=N+1,@(Y_Q_F_Q_")")="" ;IHS/SET/GTH XB*3*9 10/29/2002 + I F]"",$D(^$R(F)) S N=N+1,@(Y_Q_F_Q_")")="" ;IHS/SET/GTH XB*3*9 10/29/2002 + 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_")")="" ;IHS/SET/GTH XB*3*9 10/29/2002 + . F S F=$O(^$R(F)) Q:F=""!('(X=$E(F,1,$L(X)))) S N=N+1,@(Y_Q_F_Q_")")="" ;IHS/SET/GTH XB*3*9 10/29/2002 + .Q + ; F S F=$O(^ (F)) Q:F=""!(F]L) S N=N+1,@(Y_Q_F_Q_")")="" Q:L="" ;IHS/SET/GTH XB*3*9 10/29/2002 + F S F=$O(^$R(F)) Q:F=""!(F]L) S N=N+1,@(Y_Q_F_Q_")")="" Q:L="" ;IHS/SET/GTH XB*3*9 10/29/2002 + Q + ; diff --git a/ZIBRUN.m b/ZIBRUN.m new file mode 100644 index 0000000..7cef02d --- /dev/null +++ b/ZIBRUN.m @@ -0,0 +1,50 @@ +%ZIBRUN ; IHS/ADC/GTH - CHECK FOR ACTIVE ROUTINE IN A SPECIFIC UCI ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; +EN ; + Q:'($ZV?1"MSM".E!($ZV?1"DSM".E)) ; Only works for MSM or DSM. + ; Name of routine to be checked is passed in X. + S %ZIB("PARM")=X + S:$P(%ZIB("PARM"),"^",2)="" $P(%ZIB("PARM"),"^",2)=$ZU(0) ; If no UCI set to current UCI. + S %ZIB("OP SYS")=$ZV ; Set operating system. + D @$S(%ZIB("OP SYS")?1"DSM".E:"DSM",1:"MSM") ; Active JOB lookup per operating system. + D CK + D OUT ; KILL off variables and exit gracefully. + Q + ; +MSM ; MSM specific look up active JOBs. + S $ZT="MER" + V 44:$J:$ZB($V(44,$J,2),1,7):2 + S %ZIB("SYS TBL")=$V(44),%ZIB("JOB TBL")=$V(%ZIB("SYS TBL")+8,-3,2)+%ZIB("SYS TBL"),%ZIB("MAX JOBS")=$V($V(%ZIB("SYS TBL")+284),-3,4),%ZIB("PARTITION")=$V(3*4+%ZIB("JOB TBL")) + ; Build active JOB table (%ZIB("ACT JOB") + F %ZIB("ACT JOB")=1:1:%ZIB("MAX JOBS") S:$V(%ZIB("ACT JOB")*4+%ZIB("PARTITION")) $P(%ZIB("JOB TABLE",%ZIB("ACT JOB")),"^",2)=$ZU(($V(2,%ZIB("ACT JOB"),2)#32),($V(2,%ZIB("ACT JOB"),2)\32)) + Q + ; +MER ; MSM error trap. + V 44:$J:$ZB($V(44,$J,2),#FFFE,1):2 + ZQ + ; +DSM ; DSM specific look up active JOBs. + S %ZIB("SYS TBL")=$V(44),%ZIB("JOB TBL")=$V(%ZIB("SYS TBL")+4) + ; Build active JOB table (%ZIB("JOB TABLE")) + F %ZIB("JOB OFFSET")=%ZIB("JOB TBL")+2:2:%ZIB("JOB TBL")+126 I $V(%ZIB("JOB OFFSET")+1),$V(%ZIB("JOB OFFSET")+1)'=244 D + . S %ZIB("ACT JOB")=%ZIB("JOB OFFSET")-%ZIB("JOB TBL")\2 + . I %ZIB("ACT JOB")]"" D + .. S %ZIB("UCI NBR")=$V(149,%ZIB("ACT JOB")) + .. I %ZIB("UCI NBR")]"" D + ... S $P(%ZIB("JOB TABLE",%ZIB("ACT JOB")),"^",2)=$ZU(%ZIB("UCI NBR")) + ... S %ZIB("ACT RTN")="" + ... F %ZIB("LOC")=502:1:509 Q:$V(%ZIB("LOC"),%ZIB("ACT JOB"))#256>127!'$V(%ZIB("LOC"),%ZIB("ACT JOB")) S %ZIB("ACT RTN")=%ZIB("ACT RTN")_$C($V(%ZIB("LOC"),%ZIB("ACT JOB"))#128) + ... S $P(%ZIB("JOB TABLE",%ZIB("ACT JOB")),"^",1)=%ZIB("ACT RTN") + Q + ; +CK ; Check %ZIB("JOB TABLE) for match of ROUTINE^UCI. + S %ZIB("$T")=0,%ZIB("JOB NBR")="" + F S %ZIB("JOB NBR")=$O(%ZIB("JOB TABLE",%ZIB("JOB NBR"))) Q:%ZIB("JOB NBR")="" I %ZIB("JOB TABLE",%ZIB("JOB NBR"))=%ZIB("PARM") S %ZIB("$T")=1 Q + Q + ; +OUT ; + I $ZV?1"MSM".E V 44:$J:$ZB($V(44,$J,2),#FFFE,1):2 + I %ZIB("$T") + Q + ; diff --git a/ZIBTCP.m b/ZIBTCP.m new file mode 100644 index 0000000..d362df9 --- /dev/null +++ b/ZIBTCP.m @@ -0,0 +1,81 @@ +ZIBTCP ; IHS/ADC/GTH - TCP PRINT TEST ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; + ; This routine must be DONE from the CLOSE EXECUTE when + ; printing to a TCP printer. See below for further + ; documentation. + ; + ; H = Host IP address + ; P = Port number + ; I = Counter + ; +EN ; + D EN1 +EXIT ; + S ZIBX="rm XM"_ZIBH_".DAT",ZIBX=$$JOBWAIT^%HOSTCMD(ZIBX) + KILL ^TMP($J,"XM"_ZIBH),ZIBH,ZIBIO,ZIBI,ZIBX + Q + ; +EN1 ; + NEW H,P,I + S ZIBIO=ION,ZIBIO=$O(^%ZIS(1,"B",ZIBIO,0)),ZIBH=DUZ_$G(ZIBH) + Q:'ZIBIO + Q:'$D(^%ZIS(1,ZIBIO,90)) + S H=$P(^%ZIS(1,ZIBIO,90),U,2),P=$P(^(90),U,3) + D OPEN + Q:'$D(IO) + U IO:(::0) + F I=1:1 R X:300 S %X=$ZC Q:%X<0 S ^TMP($J,"XM"_ZIBH,I)=X + D ^%ZISC + O 56::99 + U 56::"TCP" + W /SOCKET(H,P) + S X=0 + F S X=$O(^TMP($J,"XM"_ZIBH,X)) Q:X="" W ^TMP($J,"XM"_ZIBH,X)_$C(10)_$C(13) + W !,#,! + C 56 + Q + ; +OPEN ;OPEN HOST FILE + F ZIBI=1:1:4 S (IOP,ION)="HOST FILE SERVER #"_ZIBI,%ZIS("IOPAR")="(""XM"_ZIBH_".DAT"":""R"")" D ^%ZIS Q:'POP + I POP H 2 G OPEN + KILL IOP + Q + ; + ; Technical Notes: + ; MSM TCP uses the "!" to clear the TCP buffer. FileMan (RPMS) + ; uses "!" for a carriage return, line feed. Further, TCP does not + ; recognize "?30" as 30 spaces from left margin. To circumvent these + ; problems, I write to a temporary host file, which formats the + ; document, and then I read it back into the TMP global. Once it's + ; in the TMP global, I $O through the global and write each line + ; with a $C(10) and $C(13) concatenated to the string. This process + ; handles the CR/LF problem at the remote end. + ; + ; Port 2501 is the assigned port from the vendor for the Net Que. + ; + ; As of 3Jan95, this has only been tested on the Unix platform using + ; MSM. It should work in a DOS environment using FTP Software's TCP, + ; but needs to be tested. + ; + ; Below is an inquiry of the Device file and Terminal Type file. + ; + ; OUTPUT FROM WHAT FILE: DEVICE// + ; NAME: P-TCP TEST PRINTER $I: 51 + ; ASK DEVICE: YES ASK PARAMETERS: NO + ; VOLUME SET(CPU): TUC SIGN-ON/SYSTEM DEVICE: NO + ; FORCED QUEUING: N0 + ; LOCATION OF TERMINAL: MAT PARKENSON PRINTER + ; ASK HOST FILE: NO MARGIN WIDTH: 255 + ; FORM FEED: # PAGE LENGTH: 256 + ; BACK SPACE: $C(8) OPEN PARAMETERS: ("XM"_DUZ_$G(ZIBH)_".DAT":"M") + ; SUBTYPE: P-TCP PRINTER TYPE: HOST FILE SERVER + ; + ; Select TERMINAL TYPE NAME: P-TCP PRINTER + ; NAME: P-TCP PRINTER SELECTABLE AT SIGN-ON: NO + ; RIGHT MARGIN: 255 FORM FEED: # + ; PAGE LENGTH: 256 BACK SPACE: $C(8) + ; OPEN EXECUTE: S XMREC="R X#255:1" CLOSE EXECUTE: D ^ZIBTCP Q + ; DESCRIPTION: Special Terminal Type used only for P-TCP Printer + ; Device.. diff --git a/ZIBVCHV.m b/ZIBVCHV.m new file mode 100644 index 0000000..1331fa5 --- /dev/null +++ b/ZIBVCHV.m @@ -0,0 +1,49 @@ +ZIBVCHV ; IHS/ADC/GTH - READ VARS AND RTNS FROM A %INDEX ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;; + ; + ; Thanks to Paul Wesley, DSD, for the original routine. + ; + I '(^%ZOSF("OS")["MSM") D OSNO^XB Q ; IHS/SET/GTH XB*3*9 10/29/2002 +OPEN ; + D DT^DICRW,^XBCLS + W !!,"Select a %INDEX Summary that was put to disk",! + KILL DIR + S DIR(0)="F^1:30",DIR("A")="Directory ",DIR("B")="/usr/mumps/" + D ^DIR + Q:Y["^" + S XBDIR=Y +FNAME ; + KILL DIR +FNAME1 ; + S DIR(0)="F^1:15",DIR("A")="File Name " + D ^DIR + G:Y["^" OPEN + I Y?.N,$D(XBFL(Y)) S DIR("B")=XBFL(Y) G FNAME1 + I Y["*" KILL 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) + .Q + S XBFN=Y,X=$$OPEN^%ZISH(XBDIR,XBFN,"R") +ES ; + I X W !,"error on open of file ",XBDIR,XBFN,! KILL DIR S DIR(0)="E" D ^DIRQ:Y=1 G FNAME + S XBJ=$J,XBVRLC=0 + KILL ^XBVROU(XBJ,"V") + W !,"Looking for 'Indexed Routines:' ",! +READ ; + F XBI=1:1:20 U IO R X:DTIME U IO(0) W "." I X["Indexed Routines:" S XBOK=1 W !,"Found ! ... continuing" Q + I '$G(XBOK) KILL DIR + F XBI=1:1 U IO R X:DTIME Q:X["Local V" + F XBI=1:1 U IO R X:DTIME Q:X["Global " D + .Q:$L(X)<17 + .Q:$E(X,17)=" " + .I X[$C(13) S X=$P(X,$C(13)) + .S XBVARL=$G(XBVAR) + .I $E(X,4)'=" " S XBVAR="" F XBI=4:1 S XBX=$E(X,XBI) Q:" ("[XBX S XBVAR=XBVAR_XBX + .I XBVAR'=XBVARL S XBVRLC=0 + .S XBR=$E(X,17,999),XBR=$TR(XBR,"*!","") + .S XBVRLC=XBVRLC+1,^XBVROU(XBJ,"V",XBVAR,XBVRLC)=XBR + .Q + D ^%ZISC + S XBFILE=1 + Q + ; diff --git a/ZIBVKCA.m b/ZIBVKCA.m new file mode 100644 index 0000000..5c4b7d8 --- /dev/null +++ b/ZIBVKCA.m @@ -0,0 +1,20 @@ +ZIBVKCA ; IHS/ADC/GTH - KILL VARIABLES ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 + ; + ; This routine kills variables in the namespace of the + ; variable passed in the parameter. + ; This routine is accessed thru the front end routine XBVK. + ; + ; Original routine provided by Dr. Mark Delaney, TASSC, 12 Dec 2001. + ; + Q ; No entry from top + ; +EN(ZIBVKNS) ;EP - KILL Local variables in the passed namespace. + ; + Q:$G(ZIBVKNS)="" + NEW ZIBVKX + S ZIBVKX=ZIBVKNS K @ZIBVKNS + F S ZIBVKX=$O(@ZIBVKX) Q:ZIBVKX="" Q:$E(ZIBVKX,1,$L(ZIBVKNS))]ZIBVKNS I $E(ZIBVKX,1,$L(ZIBVKNS))=ZIBVKNS,ZIBVKX'["ZIBVK" K @ZIBVKX + Q + ; diff --git a/ZIBVKIL.m b/ZIBVKIL.m new file mode 100644 index 0000000..8083361 --- /dev/null +++ b/ZIBVKIL.m @@ -0,0 +1,60 @@ +ZIBVKIL ; IHS/ADC/GTH - BUILD A KILL VARIABLE ROUTINE ; [ 11/04/97 10:26 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent err. + ; + ; Build a name space variable killer routine in ^.ns.KVAR. + ; + ; Select a %INDEX host file summary from which to build the + ; routine. Select a name space for the variables and the + ; routine to be built. Enter any package wide variables. + ; + ; Add D ^.ns.VKL0 to all menu exit actions where package + ; variables are to remain. + ; + ; Add D KILL^XUSCLEAN to the exit of all other menus. + ; + ; I $P(^%ZOSF("OS"),"-",1)'="MSM" W !,*7,"OPERATING SYSTEM '",$P(^%ZOSF("OS"),"-",1),"' NOT SUPPORTED." Q ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent err. + I $P(^%ZOSF("OS"),"^",1)'["MSM" W !,*7,"OPERATING SYSTEM '",$P(^%ZOSF("OS"),"^",1),"' NOT SUPPORTED." Q ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent err. + ; + D HOME^%ZIS + NEW XBNS +NS ; + KILL DIR + S DIR(0)="F^2:4",DIR("A")="Name Space - or ' ^ 'to exit" + D ^DIR + I X="^" G EXIT + I Y="" G NS + I '$D(^DIC(9.4,"C",Y)) W !,"NO PACKAGE ??",! G NS + S XBNS=Y +PKGVAR ; + KILL DIR + S DIR(0)="F^0:235",DIR("A")="List of Package Wide Variables or '^' to bypass",DIR("?")="LIST var1,var2, ... " + D ^DIR + I Y'="^" F XBI=1:1 S X=$P(Y,",",XBI) Q:X="" S XBVPKG(X)="" +KROU ; + KILL DIR + S DIR(0)="F^0:235",DIR("A")="List of other Kill routines to chain",DIR("?")=" ^ROU1,^ROU2, ... with '^'s" + D ^DIR + I Y]"",Y'="^" F XBI=1:1 S XBROU=$P(Y,",",XBI) Q:XBROU="" S X=$P(XBROU,"^",2) D + . I X="" W !,XBROU," error in list >> ",Y G KROU + . X ^%ZOSF("TEST") + . I '$T W !,X," error in list >> ",Y G KROU + .Q + I Y]"" S XBKROU=" D "_Y + D ^XBVCHV + I '$D(^XBVROU($J)) W !,"NO FILE ??",! G NS +S ; + F I=1:1 Q:'$T(@I) S XBLD(I)=$P($T(@I),";;",2,99) + X XBLD(1) +EXIT ; + D KILL^XUSCLEAN + KILL ^XBVROU($J),XBKROU,XBLD + W !,"REMEMBER TO EDIT THE TOP LINES OF THE ROUTINES CREATED !",!! + Q + ; +1 ;;S XBNUM=0 X XBLD(2),XBLD(3),XBLD(4),XBLD(6) ZS @XBROU W !,XBROU," Saved ",!! +2 ;;ZR S XBROU=XBNS_"VKL"_XBNUM,X=XBROU_" ; - kill variables",XBLNS=$L(XBNS) ZI X S X=" ;;" ZI X +3 ;;S XBVAR=XBNS,XBHD=" K ",X=" K " F S XBVAR=$O(^XBVROU($J,"V",XBVAR)) Q:$E(XBVAR,1,XBLNS)'=XBNS I '$D(XBVPKG(XBVAR)) S X=X_XBVAR_"," S XBLX=$L(X) I XBLX>235 S X=$E(X,1,XBLX-1) ZI X S X=" K " X ^%ZOSF("SIZE") I Y>3000 X XBLD(5),XBLD(2) +4 ;;S XBLX=$L(X) I XBLX>3 S X=$E(X,1,XBLX-1) ZI X +5 ;;S XBNUM=XBNUM+1 S X=" D ^"_XBNS_"VKL"_XBNUM ZI X ZS @XBROU W !,XBROU," Saved",!! +6 ;;I $D(XBKROU) S X=XBKROU ZI X W !,"ADDING ",X,! diff --git a/ZIBVKMSM.m b/ZIBVKMSM.m new file mode 100644 index 0000000..cf1b2fe --- /dev/null +++ b/ZIBVKMSM.m @@ -0,0 +1,21 @@ +ZIBVKMSM ; IHS/ADC/GTH - KILL VARIABLES ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; This routine kills variables in the namespace of the + ; variable passed in the parameter. + ; This routine is accessed thru the front end routine XBVK. + ; + ; Original routine provided by Don Enos, OHPRD, 2 Oct 1995. + ; + Q ; No entry from top + ; +EN(ZIBVKNS) ;EP - KILL Local variables in the passed namespace. + ; + Q:$G(ZIBVKNS)="" + NEW ZIBVKX + S ZIBVKX=$O(@ZIBVKNS,-1) + S:ZIBVKX="" ZIBVKX="%" + K:ZIBVKNS="%" @ZIBVKNS + F S ZIBVKX=$O(@ZIBVKX) Q:ZIBVKX="" Q:$E(ZIBVKX,1,$L(ZIBVKNS))]ZIBVKNS I $E(ZIBVKX,1,$L(ZIBVKNS))=ZIBVKNS,ZIBVKX'["ZIBVK" K @ZIBVKX + Q + ; diff --git a/ZIBVL.m b/ZIBVL.m new file mode 100644 index 0000000..e4801f7 --- /dev/null +++ b/ZIBVL.m @@ -0,0 +1,106 @@ +ZIBVL ;IHS/SET/GTH - LIST LOCAL VARIABLES ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Both MSM and Cache'. + ; + ; This routine lists variables that begin with the string + ; entered by the user. Selection of variables is case + ; sensitive. + ; + ; This routine is specific to MSM and Cache. It will work + ; with any M implementation that has all Type A extensions + ; to the 1990 M ANSI standard implemented. The front end + ; routine, XBVL, stops if any other than an MSM or Cache + ; implementation is encountered. + ; + ; TASSC/MFD formally ZIBVLMSM, patched this along with XBVL for Cache + ; +START ; + NEW ZIBVLC,ZIBVLDQT,ZIBVLI,ZIBVLLC,ZIBVLNS,ZIBVLQ,ZIBVLX,ZIBVLX2,ZIBVLY,ZIBVLZ + S $P(ZIBVLZ,"=",40)="" + F D LOOP Q:ZIBVLQ + Q + ; +LOOP ; WRITE NAME SPACED VARIABLES UNTIL USER IS THROUGH + D READ ; get name space + Q:ZIBVLQ + Q:ZIBVLNS="" + I $D(IOF) W @IOF I 1 + E W !! + W ZIBVLZ,! ; write leading === line + I ZIBVLNS="*" D ALL I 1 ; list variables + E D NMSPACE + D:ZIBVLLC>20 PAUSE ; pause if bottom of screen + I 'ZIBVLQ W ZIBVLZ,! I 1 ; write trailing === line + E W ! + S ZIBVLQ=0 + Q + ; +NMSPACE ; LIST VARIABLES IN NAME SPACE + S ZIBVLX="" + I $$VERSION^%ZOSV(1)["MSM" S ZIBVLX=$O(@ZIBVLNS,-1) ; backup to variable before name space + S:ZIBVLX="" ZIBVLX="%" ; if none start with % + I ZIBVLNS="%",$D(%) D WRITE,QUERY ;if % name space list % variable + ; now list variables in name space and subnodes if arrays + ; skip ZIBVL* variables + F S ZIBVLX=$O(@ZIBVLX) Q:ZIBVLX="" Q:$E(ZIBVLX,1,$L(ZIBVLNS))]ZIBVLNS I $E(ZIBVLX,1,$L(ZIBVLNS))=ZIBVLNS,$E(ZIBVLX,1,5)'="ZIBVL" D WRITE Q:ZIBVLQ D QUERY Q:ZIBVLQ + Q + ; +ALL ; LIST ALL VARIABLES + S ZIBVLX="%" + I $D(%) D WRITE,QUERY ; if % exists list it + ; now list all variables and subnodes if arrays + ; skip ZIBVL* variables + F S ZIBVLX=$O(@ZIBVLX) Q:ZIBVLX="" I $E(ZIBVLX,1,5)'="ZIBVL" D WRITE Q:ZIBVLQ D QUERY Q:ZIBVLQ + Q + ; +QUERY ; $Q THROUGH ARRAYS + S ZIBVLX2=ZIBVLX + NEW ZIBVLX + S ZIBVLX=ZIBVLX2 + F S ZIBVLX=$Q(@ZIBVLX) Q:ZIBVLX="" D WRITE Q:ZIBVLQ + Q + ; +WRITE ; WRITE ONE VARIABLE NAME AND VALUE + Q:'($D(@ZIBVLX)#2) + ; quote non-numeric values (numeric = canonic < 16 digits) + S ZIBVLDQT="""" + I $L(@ZIBVLX)<16,@ZIBVLX=+@ZIBVLX S ZIBVLDQT="" + ; figure out # of lines that will be used + S ZIBVLC=$L(ZIBVLX)+1+($L(ZIBVLDQT)*2)+$L(@ZIBVLX) F ZIBVLI=1:1 S ZIBVLC=ZIBVLC-80 Q:ZIBVLC<1 + S ZIBVLLC=ZIBVLLC+ZIBVLI + I ZIBVLLC>22 S ZIBVLLC=0 D PAUSE ; pause if not enough room + Q:ZIBVLQ + W ZIBVLX,"=",ZIBVLDQT,@ZIBVLX,ZIBVLDQT,! ; write name=value + Q + ; +READ ; READ USER INPUT + S ZIBVLQ=1,ZIBVLLC=0 + R !,"Enter Name Space: ",ZIBVLNS:300 + S:'$T ZIBVLNS="^" + Q:ZIBVLNS="" + Q:ZIBVLNS["^" + S ZIBVLQ=0 + I ZIBVLNS["?" D HELP Q + I $E(ZIBVLNS,1,5)="ZIBVL" W !!,"ZIBVL is not allowed!",*7 D HELP Q + I ZIBVLNS=" " W !!,"BLANK is not allowed!",*7 D HELP Q + I $L(ZIBVLNS)>1,$E(ZIBVLNS,$L(ZIBVLNS))="*" S ZIBVLNS=$E(ZIBVLNS,1,($L(ZIBVLNS)-1)) + D I ZIBVLQ S ZIBVLQ=0 D HELP W *7 Q + . Q:ZIBVLNS?1"%".AN + . Q:ZIBVLNS?1A.AN + . Q:ZIBVLNS="*" + . S ZIBVLQ=1 + . Q + Q + ; +HELP ; DISPLAY HELP MESSAGE + W !!,"Enter valid variable name string (e.g IO), or * for all, or RETURN or ^ to exit.",! + S ZIBVLNS="" + Q + ; +PAUSE ; PAUSE FOR USER + R "Press any key to continue",ZIBVLY:300 S:'$T ZIBVLY="^" + W ! + I ZIBVLY["^" S ZIBVLQ=1 Q + W:$D(IOF) @IOF + Q + ; diff --git a/ZIBVLMSM.m b/ZIBVLMSM.m new file mode 100644 index 0000000..3e68384 --- /dev/null +++ b/ZIBVLMSM.m @@ -0,0 +1,103 @@ +ZIBVLMSM ; IHS/ADC/GTH - LIST MSM VARIABLES ; [ 02/07/97 3:02 PM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; This routine lists variables that begin with the string + ; entered by the user. Selection of variables is case + ; sensitive. + ; + ; This routine is specific to Micronetics. It will work + ; with any M implementation that has all Type A extensions + ; to the 1990 M ANSI standard implemented. The front end + ; routine, XBVL, stops if any other than an MSM + ; implementation is encountered. + ; + ; Routine provided by Don Enos, OHPRD, 5 Feb 96. + ; +START ; + NEW ZIBVLC,ZIBVLDQT,ZIBVLI,ZIBVLLC,ZIBVLNS,ZIBVLQ,ZIBVLX,ZIBVLX2,ZIBVLY,ZIBVLZ + S $P(ZIBVLZ,"=",40)="" + F D LOOP Q:ZIBVLQ + Q + ; +LOOP ; WRITE NAME SPACED VARIABLES UNTIL USER IS THROUGH + D READ ; get name space + Q:ZIBVLQ + Q:ZIBVLNS="" + I $D(IOF) W @IOF I 1 + E W !! + W ZIBVLZ,! ; write leading === line + I ZIBVLNS="*" D ALL I 1 ; list variables + E D NMSPACE + D:ZIBVLLC>20 PAUSE ; pause if bottom of screen + I 'ZIBVLQ W ZIBVLZ,! I 1 ; write trailing === line + E W ! + S ZIBVLQ=0 + Q + ; +NMSPACE ; LIST VARIABLES IN NAME SPACE + S ZIBVLX=$O(@ZIBVLNS,-1) ; backup to variable before name space + S:ZIBVLX="" ZIBVLX="%" ; if none start with % + I ZIBVLNS="%",$D(%) D WRITE,QUERY ;if % name space list % variable + ; now list variables in name space and subnodes if arrays + ; skip ZIBVL* variables + F S ZIBVLX=$O(@ZIBVLX) Q:ZIBVLX="" Q:$E(ZIBVLX,1,$L(ZIBVLNS))]ZIBVLNS I $E(ZIBVLX,1,$L(ZIBVLNS))=ZIBVLNS,$E(ZIBVLX,1,5)'="ZIBVL" D WRITE Q:ZIBVLQ D QUERY Q:ZIBVLQ + Q + ; +ALL ; LIST ALL VARIABLES + S ZIBVLX="%" + I $D(%) D WRITE,QUERY ; if % exists list it + ; now list all variables and subnodes if arrays + ; skip ZIBVL* variables + F S ZIBVLX=$O(@ZIBVLX) Q:ZIBVLX="" I $E(ZIBVLX,1,5)'="ZIBVL" D WRITE Q:ZIBVLQ D QUERY Q:ZIBVLQ + Q + ; +QUERY ; $Q THROUGH ARRAYS + S ZIBVLX2=ZIBVLX + NEW ZIBVLX + S ZIBVLX=ZIBVLX2 + F S ZIBVLX=$Q(@ZIBVLX) Q:ZIBVLX="" D WRITE Q:ZIBVLQ + Q + ; +WRITE ; WRITE ONE VARIABLE NAME AND VALUE + Q:'($D(@ZIBVLX)#2) + ; quote non-numeric values (numeric = canonic < 16 digits) + S ZIBVLDQT="""" + I $L(@ZIBVLX)<16,@ZIBVLX=+@ZIBVLX S ZIBVLDQT="" + ; figure out # of lines that will be used + S ZIBVLC=$L(ZIBVLX)+1+($L(ZIBVLDQT)*2)+$L(@ZIBVLX) F ZIBVLI=1:1 S ZIBVLC=ZIBVLC-80 Q:ZIBVLC<1 + S ZIBVLLC=ZIBVLLC+ZIBVLI + I ZIBVLLC>22 S ZIBVLLC=0 D PAUSE ; pause if not enough room + Q:ZIBVLQ + W ZIBVLX,"=",ZIBVLDQT,@ZIBVLX,ZIBVLDQT,! ; write name=value + Q + ; +READ ; READ USER INPUT + S ZIBVLQ=1,ZIBVLLC=0 + R !,"Enter Name Space: ",ZIBVLNS:300 + S:'$T ZIBVLNS="^" + Q:ZIBVLNS="" + Q:ZIBVLNS["^" + S ZIBVLQ=0 + I ZIBVLNS["?" D HELP Q + I $E(ZIBVLNS,1,5)="ZIBVL" W !!,"ZIBVL is not allowed!",*7 D HELP Q + I ZIBVLNS=" " W !!,"BLANK is not allowed!",*7 D HELP Q + I $L(ZIBVLNS)>1,$E(ZIBVLNS,$L(ZIBVLNS))="*" S ZIBVLNS=$E(ZIBVLNS,1,($L(ZIBVLNS)-1)) + D I ZIBVLQ S ZIBVLQ=0 D HELP W *7 Q + . Q:ZIBVLNS?1"%".AN + . Q:ZIBVLNS?1A.AN + . Q:ZIBVLNS="*" + . S ZIBVLQ=1 + . Q + Q + ; +HELP ; DISPLAY HELP MESSAGE + W !!,"Enter valid variable name string (e.g IO), or * for all, or RETURN or ^ to exit.",! + S ZIBVLNS="" + Q + ; +PAUSE ; PAUSE FOR USER + R "Press any key to continue",ZIBVLY:300 S:'$T ZIBVLY="^" + W ! + I ZIBVLY["^" S ZIBVLQ=1 Q + W:$D(IOF) @IOF + Q diff --git a/ZIBVSS.m b/ZIBVSS.m new file mode 100644 index 0000000..410706e --- /dev/null +++ b/ZIBVSS.m @@ -0,0 +1,113 @@ +ZIBVSS ; IHS/ADC/GTH - VENDOR SPECIFIC SUBROUTINES ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ;XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods. + ;XB*3*9 fixed LG,CG,GCH,GSZE,GR,GS,RCMP,RR,RS,RDEL,RSE,RSAND,NEWED,RCHANGE,RCOPY,RPRT,ER to work with Cache' + ;XB*3*9 GSE,GE,GCHR,GDEL,REDIT don't currently work with Cache' + ; +LG ;EP - List global + ;D @$S($G(^%ZOSF("OS"))["MSM":"^%GL",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + D @$S($G(^%ZOSF("OS"))["MSM":"^%GL",$G(^%ZOSF("OS"))["OpenM":"^%G",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + Q + ; +CG ;EP - Copy global to another UCI + ;D @$S($G(^%ZOSF("OS"))["MSM":"^%GCOPY",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + D @$S($G(^%ZOSF("OS"))["MSM"!($G(^%ZOSF("OS"))["OpenM"):"^%GCOPY",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + Q + ; +GSE ;EP - Search global for value + D @$S($G(^%ZOSF("OS"))["MSM":"^%GSE",1:"OSNO^XB") + Q + ; +GE ;EP - Global edit + D @$S($G(^%ZOSF("OS"))["MSM":"^%GEDIT",1:"OSNO^XB") + Q + ; +GCH ;EP - Change global value + ;D @$S($G(^%ZOSF("OS"))["MSM":"^%GCHANGE",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + D @$S($G(^%ZOSF("OS"))["MSM"!($G(^%ZOSF("OS"))["OpenM"):"^%GCHANGE",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + Q + ; +GSZE ;EP - Global size/efficiency + ;D @$S(^%ZOSF("OS")["MSM":"^%GE",1:"^%ZTBKC") ;IHS/SET/GTH XB*3*9 10/29/2002 + D @$S($G(^%ZOSF("OS"))["MSM"!($G(^%ZOSF("OS"))["OpenM"):"^%GSIZE",1:"^%ZTBKC") + Q + ; +GCHR ;EP - Global characteristics + D @$S($G(^%ZOSF("OS"))["MSM":"^%GCH",1:"OSNO^XB") + Q + ; +GDEL ;EP - Global delete + D @$S($G(^%ZOSF("OS"))["MSM":"^%GDEL",1:"OSNO^XB") + Q + ; +GR ;EP - Global restore + ;D @$S($G(^%ZOSF("OS"))["MSM":"^%GR",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + D @$S($G(^%ZOSF("OS"))["MSM":"^%GR",$G(^%ZOSF("OS"))["OpenM":"^%GI",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + Q + ; +GS ;EP - Global save + ;D @$S($G(^%ZOSF("OS"))["MSM":"^%GS",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + D @$S($G(^%ZOSF("OS"))["MSM":"^%GS",$G(^%ZOSF("OS"))["OpenM":"^%GO",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + Q + ; +RCMP ;EP - Compare routines in two UCIs + ;D @$S($G(^%ZOSF("OS"))["MSM":"^%RCMP",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + D @$S($G(^%ZOSF("OS"))["MSM"!($G(^%ZOSF("OS"))["OpenM"):"^%RCMP",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + Q + ; +RR ;EP - Restore routines + ;D @$S($G(^%ZOSF("OS"))["MSM":"^%RR",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + D @$S($G(^%ZOSF("OS"))["MSM":"^%RR",$G(^%ZOSF("OS"))["OpenM":"^%RI",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + Q + ; +RS ;EP - Save routines + ;D @$S($G(^%ZOSF("OS"))["MSM":"^%RS",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + D @$S($G(^%ZOSF("OS"))["MSM":"^%RS",$G(^%ZOSF("OS"))["OpenM":"^%RO",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + Q + ; +RDEL ;EP - Delete routines + ;D @$S($G(^%ZOSF("OS"))["MSM":"^%RDEL",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + D @$S($G(^%ZOSF("OS"))["MSM":"^%RDEL",$G(^%ZOSF("OS"))["OpenM":"^%RDELETE",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + Q + ; +RSE ;EP - Search routines for values (OR) + ;D @$S($G(^%ZOSF("OS"))["MSM":"^%RSE",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + D @$S($G(^%ZOSF("OS"))["MSM":"^%RSE",$G(^%ZOSF("OS"))["OpenM":"^%RFIND",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + Q + ; +RSAND ;EP - Search routines for values (AND) + ;D @$S($G(^%ZOSF("OS"))["MSM":"^%RSAND",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + D @$S($G(^%ZOSF("OS"))["MSM":"^%RSAND",$G(^%ZOSF("OS"))["OpenM":"^%RFIND",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + Q + ; +NEWED ;EP - Find routines by edit date + ;D @$S($G(^%ZOSF("OS"))["MSM":"^%NEWED",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + D @$S($G(^%ZOSF("OS"))["MSM":"^%NEWED",$G(^%ZOSF("OS"))["OpenM":"^%RD",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + Q + ; +REDIT ;EP - Full screen editor + ;Q:'($G(^%ZOSF("OS"))["MSM") ;IHS/SET/GTH XB*3*9 10/29/2002 + I '($G(^%ZOSF("OS"))["MSM") D OSNO^XB Q ;IHS/SET/GTH XB*3*9 10/29/2002 + X "ZR NEW (XB) X ^%E" + Q + ; +RCHANGE ;EP - Routine change + ;D @$S($G(^%ZOSF("OS"))["MSM":"^%RCHANGE",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + D @$S($G(^%ZOSF("OS"))["MSM"!($G(^%ZOSF("OS"))["OpenM"):"^%RCHANGE",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + Q + ; +RCOPY ;EP - Routine copy + ;D @$S($G(^%ZOSF("OS"))["MSM":"^%RCOPY",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + D @$S($G(^%ZOSF("OS"))["MSM"!($G(^%ZOSF("OS"))["OpenM"):"^%RCOPY",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + Q + ; +RPRT ;EP - List routines + ;D @$S($G(^%ZOSF("OS"))["MSM":"^%RPRT",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + D @$S($G(^%ZOSF("OS"))["MSM":"^%RPRT",$G(^%ZOSF("OS"))["OpenM":"^ZIBRPRTD",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + Q + ; +ER ;EP - Error report + ;D @$S($G(^%ZOSF("OS"))["MSM":"^%ER",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + D @$S($G(^%ZOSF("OS"))["MSM"!($G(^%ZOSF("OS"))["OpenM"):"^%ER",1:"OSNO^XB") ;IHS/SET/GTH XB*3*9 10/29/2002 + Q + ; diff --git a/ZIBZUCI.m b/ZIBZUCI.m new file mode 100644 index 0000000..a276823 --- /dev/null +++ b/ZIBZUCI.m @@ -0,0 +1,141 @@ +%ZUCI ; IHS/ADC/GTH - SWAP UCI BETWEEN VOLUME SETS FOR MSM-UNIX ; [ 10/29/2002 7:42 AM ] + ;;4.0;XB;;Jul 20, 2009;Build 2 + ; + ; SAVE THIS ROUTINE AS %ZUCI IN THE MGR UCI + ; + ; This utility permits switching between UCIs and Volume + ; Groups when run in programmer mode. D ^%ZUCI + ; + ; If switching to a UCI in a Volume Group other than the + ; System Volume Group (0), you must enter either the Volume + ; Group Number or Volume Group Name along with the UCI Number + ; or Name. A 'help' display identifies all UCIs and Volume + ; Groups that are currently mounted. Use a '?' for 'help'. + ; + ; A routine may be tied to the UCI,VOL switch. This routine + ; will be called immediately after the UCI,VOL switch occurs. + I $$VERSION^%ZOSV(1)["Cache" D ^%CD Q ; IHS/SET/GTH XB*3*9 10/29/2002 + ; +EN ; ENTRY - Ask for [UCI,VOL] + W !,"SWITCH TO NEW UCI",! + S $P(%ZIB("DASHES"),"-",81)="" +ASK ; Get new UCI name or number. + F %ZIB("ASK")=0:0:0 D + . S %ZIB("ZT")=0 ; Set DSM error flag for or + . S %ZIB("VERIFY UCI")=0 ; Verify UCI flag set to NO. + . W !,"You are now in ",$ZU(0) + . W !!,"Enter new UCI: " + . ; If read timesout or a "^" or is entered then set the + . ; loop at ASK+1 to quit + . R %ZIB("%"):45 E W *7,"**Timeout**",!!,"You are still in ",$ZU(0) S %ZIB("ASK")=1 Q + . I "^"[%ZIB("%") W *7," No action taken!",!!,"You are still in ",$ZU(0) S %ZIB("ASK")=1 Q + . S %ZIB("VERIFY UCI")=1 ; Verify UCI flag set to YES. +ED . ; Edit input from user. + . D ; Edit input. + .. S %ZIB("ASK")=1 ; Set loop at ASK+1 to QUIT. + .. Q:%ZIB("%")?3A + .. Q:%ZIB("%")?3A1":"1.17E + .. Q:%ZIB("%")?3A1","3A + .. Q:%ZIB("%")?3A1","3A1":"1.17E + .. Q:%ZIB("%")?2N + .. Q:%ZIB("%")?2N1":"1.17E + .. Q:%ZIB("%")?2N1","1N + .. Q:%ZIB("%")?2N1","1N1":"1.17E + .. Q:%ZIB("%")?1N + .. Q:%ZIB("%")?1N1":"1.17E + .. Q:%ZIB("%")?1N1","1N + .. Q:%ZIB("%")?1N1","1N1":"1.17E + .. I %ZIB("%")'["?" D + ... W " ?? **Incorrect input**",*7 + ... W !,%ZIB("DASHES") + ... W !,"Enter ""?"" to get help or" + ... W !,"Enter {UCI} {UCI:ROUTINE} {UCI,VOL} {UCI,VOL:ROUTINE}" + ... W !,%ZIB("DASHES") + .. S %ZIB("ASK")=0 ; Continue the loop at ASK+1. + .. S %ZIB("VERIFY UCI")=0 ; Set verify UCI flag to NO. +HLP .. ; Display UCI list. + .. I %ZIB("%")?1"?" D + ... W !,%ZIB("DASHES") + ... W !,"UCIs and VOLume groups are identified by either a name or number." + ... W !,"Use the name or number identification when selecting a UCI." + ... W !!,"Enter ""??"" to get a list of UCIs and VOLume sets." + ... W !," ""???"" to get examples." + ... W !!,"Enter {UCI} {UCI,VOL} {UCI:ROUTINE} {UCI,VOL:ROUTINE}." + ... W !,%ZIB("DASHES") + .. I %ZIB("%")?1"??" D + ... W !!,"Select from any UCI,VOL from this list:" + ... S %ZIB("NO SYS")=0 ; Set no more VOLUME SETs for MSM. + ... F %ZIB("VOL NBR")=0:1 D Q:%ZIB("NO SYS") + .... S $ZT="ZT^%ZIBZUCI" ; Set DSM error trap for . + .... I $ZU(1,%ZIB("VOL NBR"))="" S %ZIB("NO SYS")=1 Q ; DSM gets a error if end of VOLUME SETs. + .... W !,%ZIB("DASHES") + .... W !,"UCIs in Volume Group Number ",%ZIB("VOL NBR")," . . . Volume Group Name is ",$P($ZU(1,%ZIB("VOL NBR")),",",2),! + .... S %ZIB("NO UCI")=0 ; Set no more UCI flag for MSM. + .... F %ZIB("UCI NBR")=1:1 D Q:%ZIB("NO UCI") + ..... S $ZT="ZT^%ZIBZUCI" ; Set DSM error trap for error. + ..... I $ZU(%ZIB("UCI NBR"),(%ZIB("VOL NBR")))="" S %ZIB("NO UCI")=1 Q ; End of UCIs for this VOLUME SET. + ..... S %ZIB("UCI,VOL","NAME")=$ZU(%ZIB("UCI NBR"),%ZIB("VOL NBR")) + ..... S %ZIB("UCI,VOL","NBR")=%ZIB("UCI NBR")_","_%ZIB("VOL NBR") + ..... W:'((%ZIB("UCI NBR")-1)#3) ! + ..... W "UCI ",%ZIB("UCI,VOL","NBR")," is ",%ZIB("UCI,VOL","NAME") + ..... W $J("",25-($L(%ZIB("UCI,VOL","NBR"))+$L(%ZIB("UCI,VOL","NAME"))+8)) + ... W !,%ZIB("DASHES") +EXAMP .. ; + .. I %ZIB("%")?1"???" D + ... W !!,"Examples for switching UCIs",?53,"NAME SYNTAX",?67,"NUMBER SYNTAX" + ... W !,%ZIB("DASHES") + ... W !," Switch to DEV on default volume group (0)",?55,"DEV",?72,"3" + ... W !," Switch to DEV on the volume group AAA (1)",?55,"DEV,AAA",?72,"3,1" + ... W !,%ZIB("DASHES") + ... W !,"Examples of switching UCIs and running a routine" + ... W ?55,"DEV:%SY",?72,"3:%SY" + ... W !?55,"DEV,AAA:%SY",?72,"3,1:%SY" + ... W !?55,"DEV:P^DI",?72,"3:P^DI" + ... W !,%ZIB("DASHES") + ... W !,"NOTE: Name,Number combinations for UCI,VOL syntax are mutually exclusive." + ... W !,"If you select a UCI in a Volume Group greater than 0 -" + ... W !,"Then you must enter the Volume Group Name or Number!" + ... W !,%ZIB("DASHES") +VER .. ; Verify if UCI,VOL exists. + . Q:'%ZIB("VERIFY UCI") ; Stop if verify UCI flag set to NO. + . S %ZIB("NEW UCI")=$P($P(%ZIB("%"),","),":") + . S %ZIB("NEW VOL")=$P($P(%ZIB("%"),",",2),":") + . I %ZIB("NEW VOL")="" D + .. I %ZIB("NEW UCI")?1N.E F %=0:1:20 I $P($ZU(0),",",2)=$P($ZU(1,%),",",2) S %ZIB("NEW VOL")=% I 1 Q + .. E S %ZIB("NEW VOL")=$P($ZU(0),",",2) + . S $ZT="ZT^%ZIBZUCI" ; Set DSM error trap for or + . I $ZU(%ZIB("NEW UCI"),%ZIB("NEW VOL"))="" S %ZIB("ZT")=1 Q +SW . ; SWITCH TO NEW UCI + . I %ZIB("NEW UCI")?3A S %ZIB("UCI,VOL")=$ZU(%ZIB("NEW UCI"),%ZIB("NEW VOL")) + . E S %ZIB("UCI,VOL")=%ZIB("NEW UCI")_","_%ZIB("NEW VOL") + . I $ZV["DSM" V 148:$J:$V(148,$J)#256+($P(%ZIB("UCI,VOL"),",",2)*32+$P(%ZIB("UCI,VOL"),",")*256) + . E V 2:$J:$P(%ZIB("UCI,VOL"),",",2)*32+$P(%ZIB("UCI,VOL"),","):2 + . W !!,*7,"You have switched to ",$ZU(0)," {",%ZIB("UCI,VOL"),"}" + . S %ZIB("ASK")=1 ; Set loop at ASK+1 to QUIT. + I %ZIB("ZT") W !!,*7,"Sorry - ",%ZIB("NEW UCI"),",",%ZIB("NEW VOL")," does not exist!",!,"** NO ACTION TAKEN**!",! G ASK +EX ; EXIT + KILL % ; Remove the call routine variable. + I ""'[$P(%ZIB("%"),":",2) D + . S %=$P(%ZIB("%"),":",2) + . I $E(%)="^" S %=$E(%,1,9) + . E I %["^" + . E S %="^"_$E(%,1,8) + KILL %ZIB ; Remove symbol table entries. + S $ZT="ZT^%ZIBZUCI" ; Set error trap for or + G:$D(%) @% ; GO TO routine if requested. + Q ; UCI switch completed + ; +ZT ; Error trap for DSM. + I $ZE?1"