iSharkFly-Open
/
VistA-IHS-VA_UTILITIES-XB
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Modified directory structure; moved routines.

This commit is contained in:
sam 2009-12-07 17:42:41 +00:00
commit 870730c3f5
225 changed files with 18500 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

183
XB.m Normal file
View File

@ -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

143
XB1.m Normal file
View File

@ -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

161
XB3P9.m Normal file
View File

@ -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
;

177
XBARRAY.m Normal file
View File

@ -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 ""
;

174
XBARRAY0.m Normal file
View File

@ -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
;

5
XBBJ.m Normal file
View File

@ -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

87
XBBPI.m Normal file
View File

@ -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

183
XBCDIC.m Normal file
View File

@ -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!(XBCDHI<XBCDLO) EOJ
I XBCDLO<2 W !!,"*** Don't mess with files less than 2!! ***",*7 G EOJ
S XBDSLO=XBCDLO,XBDSHI=XBCDHI
D EN1^XBDSET
I '$D(^UTILITY("XBDSET",$J)) W !!,"No dictionaries were selected!" G EOJ
D ^XBCDIC2 ; Check names and data globals *****
D ^XBCDICD ; Delete bad files found by ^XBCDIC2 *****
S XBDSLO=XBCDLO,XBDSHI=XBCDHI
D EN1^XBDSET ; Get list again *****
D ^XBCDIC3 ; Check ^DD entries *****
S XBRLO=XBCDLO,XBRHI=XBCDHI
D EN1^XBRESID ; Check dangling ^DD entries *****
W !!,"Now confirming ^DIC(""B"")"
S XBCDX=""
F XBCDL=0:0 S XBCDX=$O(^DIC("B",XBCDX)) Q:XBCDX="" S XBCDFILE="" F XBCDL=0:0 S XBCDFILE=$O(^DIC("B",XBCDX,XBCDFILE)) Q:XBCDFILE="" I XBCDFILE'<XBCDLO,XBCDFILE'>XBCDHI 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 ""
;

131
XBCDIC2.m Normal file
View File

@ -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
;

122
XBCDIC3.m Normal file
View File

@ -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
;

23
XBCDICD.m Normal file
View File

@ -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
;

35
XBCFIX.m Normal file
View File

@ -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
;

121
XBCFXREF.m Normal file
View File

@ -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
;

43
XBCLM.m Normal file
View File

@ -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)
;

7
XBCLS.m Normal file
View File

@ -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
;

21
XBCNODE.m Normal file
View File

@ -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
;

32
XBCOUNT.m Normal file
View File

@ -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
;

110
XBCSPC.m Normal file
View File

@ -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
;

37
XBDAD0.m Normal file
View File

@ -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
;

175
XBDANGLE.m Normal file
View File

@ -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
;

43
XBDATE.m Normal file
View File

@ -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!(Y<XBDAT) ^UTILITY($J,RTN) I Y>0,((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!(Y<XBDAT) ^UTILITY($J,RTN) I Y>0,((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!(Y<XBDAT) ^UTILITY($J,RTN) I Y>0,((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
;

83
XBDBQDOC.m Normal file
View File

@ -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

167
XBDBQUE.m Normal file
View File

@ -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 .. <CR> to continue" D ^DIR KILL DIR G END1
;
QUE1 ;
I ($D(IO("Q"))!($G(XBFQ))) D K IO("Q") W:(($G(ZTSK))&('$D(XB("ZTSK")))) !,"Tasked with ",ZTSK W:'$G(ZTSK) !,*7,"Que not successful ... REPORTING ABORTED" D ^%ZISC S IOP=XB("IOP1") D ^%ZIS G END1 ;--->
. I '$D(ZTQUEUED),IO=IO(0),$G(XBRP)]"" W !,"Queing to slave printer not allowed ... Report Aborting" Q ;---^
. S ZTDESC="Double Que COMPUTing "_XBRC_" "_$G(XBRP),ZTIO="",ZTRTN="DEQUE1^XBDBQUE"
. S:$D(XBDTH) ZTDTH=XBDTH
. S:$G(XB("CPU"))]"" ZTCPU=XB("CPU")
. S XBNSX=""
. F S XBNSX=$O(XB("NS",XBNSX)) Q:XBNSX="" S ZTSAVE(XBNSX)=""
. KILL XBRC,XBRP,XBRX,XBNS,XBFQ,XBDTH,XBIOP,XBPAR,XBDTH,XBNSX,XBI
. S ZTIO="" ; insure no device loaded
. D ^%ZTLOAD
. Q ; these do .s branch to END1
; (((if queued the above code branched to END)))
;
DEQUE1 ;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

26
XBDELR.m Normal file
View File

@ -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))_"<poof'd>")
KILL ^TMP("XBDELR",$J)
Q
;

38
XBDH.m Normal file
View File

@ -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
;

97
XBDHD.m Normal file
View File

@ -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
;

42
XBDHD1.m Normal file
View File

@ -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

129
XBDHD2.m Normal file
View File

@ -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 <CR> 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?
;;
;; <CR> 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

123
XBDHDF.m Normal file
View File

@ -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 <CR> WILL MOVE HIM TO THE NEXT HIGHER LEVEL

53
XBDHDF1.m Normal file
View File

@ -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
;

15
XBDHDIP.m Normal file
View File

@ -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

74
XBDHDSP.m Normal file
View File

@ -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

101
XBDHDSV.m Normal file
View File

@ -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
;

28
XBDHNTEG.m Normal file
View File

@ -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

79
XBDICV.m Normal file
View File

@ -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
;

71
XBDIE.m Normal file
View File

@ -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
;

61
XBDIFF.m Normal file
View File

@ -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:D<B E=E-1,D=D+86400 S D=D-B,F=D\3600,D=D-(F*3600),G=D\60,D=D-(G*60)
S X=E_":"_F_":"_G_":"_D
KILL %H,%T,%Y,A,B,C,D,E,F,G,X1
Q
;
EDIT ; EDIT INPUT
D EDITX
Q:X<0
D EDITX1
Q:X<0
I X?5N1"."5N D Q
. I $P(X,".",2)>86399 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
;

49
XBDINUM.m Normal file
View File

@ -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
;

80
XBDIQ0.m Normal file
View File

@ -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
;

188
XBDIQ1.m Normal file
View File

@ -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
;

51
XBDIR.m Normal file
View File

@ -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(<actual_parameter_list>)
; where the <actual_parameter_list> is:
;(DIR(0),DIR("A"),DIR("B"),DIR("T"),DIR("?"),DIR("??"),<skip>)
; where <skip> 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^<your_routine>",300,2)
;
; S <namespace>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^<your_routine>")
;
;
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
;

98
XBDR.m Normal file
View File

@ -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
;

140
XBDR1.m Normal file
View File

@ -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 <LINER>
;
; 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
;

135
XBDSET.m Normal file
View File

@ -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 +Y<XBDSFF W !," 'Thru FILE' number less than 'From FILE' number!",*7 S XBDSQ=9
.Q
I $D(DIRUT) S XBDSQ=1 Q
S XBDSTF=+Y
D RANGE2
W !
I XBDSC W !?4,XBDSC," file",$S(XBDSC=1:"",1:"s")," selected" I 1
E W !?4,"No files selected",*7
Q
;
RANGE2 ; LABEL FOR EXTERNAL ENTRY POINT EN1
S XBDSFILE=XBDSFF,XBDSC=0
F D S XBDSFILE=$O(^DIC(XBDSFILE)) Q:XBDSFILE'=+XBDSFILE!(XBDSFILE>XBDSTF)
. 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
;

50
XBDT.m Normal file
View File

@ -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
;

295
XBEHRCK.m Normal file
View File

@ -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 XBEHV<XBEHVER D Q
. . S XBEHOK=0,XBEHMSG=""
. . S XBEHMSG=$S(+XBEHV:"Upgrade ",1:"Install ")
. . S XBEHMSG=" "_XBEHMSG_XBEHPRE_" v "_XBEHVER_"."
. . D RSLT(XBEHMSG)
. . S XBEHNEED(XBEH(0))=""
. .Q
Q:'$P(XBEH(0),"*",3)
D PCHK(XBEH(0))
Q
;
PCHK(XBEH) ; -----------------------------------------------------
; Determine if patch XBEH was installed, where XBEH is
; the name of the INSTALL. E.g "AVA*93.2*12".
;
D RSLT(" Need Patch '"_XBEH)
NEW DIC,X,Y
; lookup package.
S X=$P(XBEH,"*",1)
S DIC="^DIC(9.4,",DIC(0)="FM",D="C"
D IX^DIC
I Y<1 D Q
. D RSLT(" Failed lookup for Namespace '"_X_"' in PACKAGE file.")
. S XBEHOK=0,XBEHNEED(XBEH)=""
. D DUPCHK(X)
.Q
; lookup version.
S DIC=DIC_+Y_",22,",X=$P(XBEH,"*",2)
D ^DIC
I Y<1 D RSLT(" Failed lookup for version '"_X_"' in PACKAGE file.") S XBEHOK=0,XBEHNEED(XBEH)="" Q
; lookup patch.
S DIC=DIC_+Y_",""PAH"",",X=$P(XBEH,"*",3)
D ^DIC
I Y<1 D RSLT(" Failed lookup for patch '"_X_"' in PACKAGE file.") S XBEHOK=0,XBEHNEED(XBEH)="" Q
D RSLT(" Patch '"_XBEH_"' IS installed.")
Q
DUPCHK(X) ; -----------------------------------------------------
; Check PACKAGE file for duplicate entries of namespace X.
;
NEW DA,DIC
S DIC="^DIC(9.4,",DIC(0)="",D="C"
D IX^DIC
Q:Y>0
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

58
XBENHANC.m Normal file
View File

@ -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
;

132
XBFCMP.m Normal file
View File

@ -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," <does not exist>" Q
Q:XBGPASS=2
I @ZZ'=@Y W !,$$MSMZR^ZIBNSSV," <differs>",!,@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
;

55
XBFDINFO.m Normal file
View File

@ -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
;

92
XBFIXL1.m Normal file
View File

@ -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
;

63
XBFIXPT.m Normal file
View File

@ -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
;

191
XBFLD.m Normal file
View File

@ -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
;

35
XBFLD0.m Normal file
View File

@ -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
;

45
XBFLD2.m Normal file
View File

@ -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
;

156
XBFLDO.m Normal file
View File

@ -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

11
XBFMK.m Normal file
View File

@ -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
;

131
XBFNC.m Normal file
View File

@ -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.
;;
;;********************************************

202
XBFORM.m Normal file
View File

@ -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)'<X) ""
F XBLLINE=XBLLINE:1:X-XBL D
. S T=" "
. S:'$G(XBFMT) XBZ(XBL+XBLLINE)=T
. S:($G(XBFMT)=1) XBZ(XBL+XBLLINE,0)=T
.Q
Q ""
;
FMSUB(X) ;process popular ;D8 ;L20 ;R20
NEW BARC,BARP
S BARC=$E(X,2),BARP=$E(X,3,999)
I BARC="D" S X="$J(X,"_BARP_",2)" Q X
I BARC="L" S X="$E(X,1,"_BARP_")" Q X
I BARC="R" S X="$J(X,"_BARP_")" Q X
S X="X"
Q X
;

192
XBFORM0.m Normal file
View File

@ -0,0 +1,192 @@
XBFORM0 ; IHS/ADC/GTH - Documentation for XBFORM ; [ 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^XBFORM(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^XBFORM. Once the form is
; designed the EDIT call is commented out.
;
; $$GEN^XBFORM(NAME,DIC,FIELD,%Y,FORMAT,OFFSET)
; Generates the form into the root array indicated by %Y.
; 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.
;
; INPUT VARIABLES
; NAME The name space variable that holds the name of
; the form to be used.
;
; DIC The root or file number of the file holding the
; forms.
;
; FIELD The field number of the WP field holding the form.
;
; %Y 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 %Y(line)="...
; 1 The array is built %Y(line,0)="....
;
; OFFSET The offset in line numbers in building the array.
; The array will start construction at OFFSET+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.
;
; To use a "|" in your display use "||" in the
; form.
;
; Mnemonics Comments - A short hand for variables is
; available. 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
;
; #mneum1=variable1|mneum2=variable2*...
; #mneumZ=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
; '=' EQUALS
;
; variable1 User's choice of the local variable
; ex: DUZ
; '|' Repeat seperator if more than one
; mnemonic is indicated on a line
;
; 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
;
; '@' Mneumonic dubstitution marker
;
; 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. Near 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).
;
; '|' Repeat Separator if more than one is put
; on one line.
;
; SPECIAL OUTPUT TRANSFORMS provided by XBFORM
;
; $$MDY(X)
; *xxx:$$MDY(X) a literal |"NOW"| or variable |IT@9|
; ex: *"NOW":$$MDY(X) or *IT@9:$$MDY(X)
; returns mm/dd/yy
;
; $$WP("X")
; *xxx:$$WP("X") for a word processing field array |xxx|
;
; NOTE: "X" IS ABSOLUTELY NECESSARY
; The variable array must have the form
; xxx(n) where n = 1:1
; xxx may be B@101 as if returned by
; XBDIQ1 in the node 101 of B@
; EX:
; *B@:$$WP("X") |B@| for B=BARWP with BARWP(n) defined
; *B@101:$$WP("X") |B@101| for B=BARWP with BARWP(101,n) defined
;
; $$FL(X)
; *19:$$FL(X) |19| in form: fill lines through 19
;
; ;D10
; *xxx:;D10 Performs $J(xxx,10,2)
;
; ;R20
; *xxx:;R20 Performs $J(xxx,20)
;
; ;L15
; *xxx:;L15 Performs $E(xxx,1,15)
;
Q
TEST ;;
;** set up variables
D ENP^XBDIQ1(200,DUZ,".01:.116","XBFU(")
I '$D(XBFFORM) S XBFFORM="JAN"
D EDIT^XBFORM(XBFFORM,90053.01,1000)
KILL XBFFM
S Y=$$GEN^XBFORM(XBFFORM,90053.01,1000,"XBFFM(",0,0)
Q
TESTE ;;END
PRT ;
D ^%ZIS
U IO W !
F I=1:1 Q:'$D(XBFFM(I)) U IO W XBFFM(I),!
U IO W #
D ^%ZISC
Q

47
XBFORM1.m Normal file
View File

@ -0,0 +1,47 @@
XBFORM1 ; IHS/ADC/GTH - sub x in output transforms [ 02/07/97 3:02 PM ]
;;4.0;XB;;Jul 20, 2009;Build 2
;
;XBV1=NEW CODE,XBLINX=original out transform
Q
;
SUB(XBV1,XBLINX) ;EP extrensic to return new output transform
D EN^XBNEW("XSUB^XBFORM1","XBV1;XBLINX")
Q XBLINX
;
XSUB ;EP - do it
NEW XB,XBT
D SCAN
I 'XBMK Q
S XBLIN=XBLINX
D BLDLIN1
S XBLINX=XBLIN1
Q
;
;----------------- SUB ROUTINES ---------------
;
SCAN ;EP - scan for X
S XBVX="X"
S XBP=" #&'()*+,'-/<=>@\_?;:[]!""",XBS=XBP
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 ;
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
;

35
XBFRESET.m Normal file
View File

@ -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
;

114
XBFUNC.m Normal file
View File

@ -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
;

55
XBFUNC1.m Normal file
View File

@ -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
;

69
XBFUNC2.m Normal file
View File

@ -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
;

59
XBGC.m Normal file
View File

@ -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
;

166
XBGCMP.m Normal file
View File

@ -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")["<UNDEF" W !,*7,"*** Probably missing quotes",! S XBS=1
Q
;
CHECK2 ; Check both globals
I (XBG1["("&(XBG2'["("))!(XBG1'["("&(XBG2["(")) W !,*7," Starting globals must be identically subscripted",! S XBS=1 G X5
I XBG1'["("
E I $P(XBG1,"(",2)'=$P(XBG2,"(",2) W !,*7," Starting globals must be identically subscripted",! S XBS=1 G X5
E I $E(XBG1,$L(XBG1))'=")"!($E(XBG2,$L(XBG2))'=")") W !,*7," Starting globals must end in a "")""",! S XBS=1
X5 ;
Q
;
SETUP ; Get print parameters, task?
KILL ZTSK,IOP,%ZIS
S %ZIS="PQM"
D ^%ZIS
Q:POP
I $D(IO("Q")) D QUE I 1
E D NOQUE
Q
;
NOQUE ;
S ^DISV($I,"^%ZIS(1,")=$O(^%ZIS(1,"C",IO,""))
U IO
D PROCESS
D ^%ZISC
Q
;
QUE ;
S XBION=ION
KILL ZTSAVE
F %="XBG1","XBG2","XBION" S ZTSAVE(%)=""
S ZTRTN="PROCESS^XBGCMP",ZTDESC="COMPARE TWO GLOBALS",ZTIO="",ZTDTH=""
D ^%ZTLOAD
KILL ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
D ^%ZISC
W !
Q
;
PROCESS ; Compare
S XBG1="^"_XBG1,XBG2="^"_XBG2,XBN=$J_$H,XBC=0
I '$D(ZTQUEUED) W:$D(IOF) @IOF W !!,"Comparison of globals ",XBG1," and ",XBG2,!
I $D(@XBG1)#2,'($D(@XBG2)#2) S XBC=XBC+1,XBTEMP=XBG1 D CHANGE S ^TMP("XBGCMP",XBN,XBTEMP)=XBG1_" Exists~"_XBG2_" Missing"
I '($D(@XBG1)#2),$D(@XBG2)#2 S XBC=XBC+1,XBTEMP=XBG1 D CHANGE S ^TMP("XBGCMP",XBN,XBTEMP)=XBG1_" Missing~"_XBG2_" Exists"
I $D(@XBG1)#2,$D(@XBG2)#2,'(@XBG1=@XBG2) S XBTEMP=XBG1 D CHANGE S XBC=XBC+1,^TMP("XBGCMP",XBN,XBTEMP)=XBG1_" Not Equal To~"_XBG2
S XBA=$P(XBG1,"("),XBB=$P(XBG2,"("),XB=XBG1
F S XB=$Q(@XB) Q:XB="" D
. I '($D(@(XBB_$P(XB,XBA,2)))#2) S XBC=XBC+1,XBTEMP=XB D CHANGE S ^TMP("XBGCMP",XBN,XBTEMP)=XB_" Exists~"_XBB_$P(XB,XBA,2)_" Missing" G X3
. I @XB'=@(XBB_$P(XB,XBA,2)) S XBC=XBC+1,XBTEMP=XB D CHANGE S ^TMP("XBGCMP",XBN,XBTEMP)=XB_" Not Equal To~"_XBB_$P(XB,XBA,2)
X3 . Q
S XBA=$P(XBG2,"("),XBB=$P(XBG1,"("),XB=XBG2
F S XB=$Q(@XB) Q:XB="" D
. I '($D(@(XBB_$P(XB,XBA,2)))#2) S XBC=XBC+1,XBTEMP=XBB_$P(XB,XBA,2) D CHANGE S ^TMP("XBGCMP",XBN,XBTEMP)=XBB_$P(XB,XBA,2)_" Missing~"_XB_" Exists"
I '$D(ZTQUEUED) D PRINT I 1
E D SCHED
Q
;
CHANGE ; Temp change double quotes to single
I XBTEMP["""" S XBTMP="",XBQTE=$L(XBTEMP,"""") F XBI=1:1:(XBQTE-1) S XBTMP=XBTMP_$P(XBTEMP,"""",XBI)_"" I XBI=(XBQTE-1) D
. S XBTEMP=XBTMP_$P(XBTEMP,"""",XBQTE)
KILL XBTMP,XBQTE
Q
;
PRINT ; Prints or displays results
I $D(ZTQUEUED) W:$D(IOF) @IOF W !!,"Comparison of globals ",XBG1," and ",XBG2,!
S XBL=IOSL-3,XB=""
F S XB=$O(^TMP("XBGCMP",XBN,XB)) Q:XB="" D I XBL'>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
;;@;!

8
XBGCMP2.m Normal file
View File

@ -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
;

63
XBGL.m Normal file
View File

@ -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

18
XBGLDFN.m Normal file
View File

@ -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
;

84
XBGSAVE.m Normal file
View File

@ -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 "<ns><asufac>.<JulianDate>"
; 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
;

38
XBGXFR.m Normal file
View File

@ -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
;

32
XBGXREFS.m Normal file
View File

@ -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
;

70
XBHEDD.m Normal file
View File

@ -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,"<RETURN> 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

55
XBHEDD1.m Normal file
View File

@ -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,"<RETURN>... 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,"<RETURN> 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,"<RETURN> 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

73
XBHEDD10.m Normal file
View File

@ -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,"<RETURN> 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

57
XBHEDD11.m Normal file
View File

@ -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,"<RETURN> 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,"<RETURN> 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

41
XBHEDD12.m Normal file
View File

@ -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,"<RETURN> 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

41
XBHEDD13.m Normal file
View File

@ -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 <RETURNED> 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 <RETURN> 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 <RETURN>, 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,"<RETURN> 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 <RETURNED> 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

34
XBHEDD2.m Normal file
View File

@ -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 !," <RETURN>=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

27
XBHEDD3.m Normal file
View File

@ -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

57
XBHEDD4.m Normal file
View File

@ -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

51
XBHEDD5.m Normal file
View File

@ -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,"<RETURN> 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

65
XBHEDD6.m Normal file
View File

@ -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,"<RETURN> 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

41
XBHEDD7.m Normal file
View File

@ -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 <RETURN> 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

52
XBHEDD8.m Normal file
View File

@ -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,"(<RETURN>=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,"<RETURN> 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

78
XBHEDD9.m Normal file
View File

@ -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,"<RETURN> to continue..",XX:DTIME
Q
PAGE ;
R !!?2,"<RETURN> 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

74
XBHEDDH1.m Normal file
View File

@ -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,"<RETURN> 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

58
XBHEDDH2.m Normal file
View File

@ -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 <RETURN>, 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,"<RETURN> to continue, '^' to quit: ",XX:DTIME S:'$T XX="^" S:XX="^" FLAGQ=1 I FLAGQ Q
W @IOF Q

56
XBHEDDH3.m Normal file
View File

@ -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 <RETURNED> 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 <RETURN> 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 <RETURN>,
;;; 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 <RETURNED>
;;; 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,"<RETURN> to continue, '^' to quit: ",XX:DTIME S:'$T XX="^" S:XX["^" FLAGQ=1 I FLAGQ Q
W @IOF Q
PAUSE ;
I $Y<SIZE F I=1:1:(SIZE-$Y) W !
R !?2,"<RETURN> to continue..",XX:DTIME
Q

26
XBHEDDH4.m Normal file
View File

@ -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,"<RETURN> to continue, '^' to quit: ",XX:DTIME S:'$T XX="^" S:XX="^" FLAGQ=1 I FLAGQ Q
W @IOF Q

37
XBHEDDM.m Normal file
View File

@ -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

32
XBHELP.m Normal file
View File

@ -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
;

109
XBHFMAN.m Normal file
View File

@ -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
; <namespace>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
;

126
XBHFMAN1.m Normal file
View File

@ -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("<NO DESCRIPTION>") 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("<NO HELP FRAME>") Q
I '$D(^DIC(9.2,A,1)) D PR("<NO HELP FRAME TEXT>") 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
;

105
XBHFMAN2.m Normal file
View File

@ -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

49
XBINIT.m Normal file
View File

@ -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

66
XBINTEG.m Normal file
View File

@ -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)

6
XBIV.m Normal file
View File

@ -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"

161
XBKD.m Normal file
View File

@ -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<XBKDLO) EOJ
DEL ;
R !!,"Data globals? [D]elete, [A]sk, [S]ave S//",XBKDDEL:$G(DTIME,999)
G:"DAS"'[XBKDDEL DEL
S:XBKDDEL="" XBKDDEL="S"
;
TMP ;
W !!,"TEMPLATES and AUTHORITIES? [D]elete, [A]sk, [S]ave ",XBKDDEL,"//"
R XBKDTMP:$G(DTIME,999)
G:"DAS"'[XBKDTMP TMP
S:XBKDTMP="" XBKDTMP=XBKDDEL
;
EN1 ;PEP - Variables XBKDLO, XBKDHI, XBKDDEL, XBKDTMP must be set when entering here.
I '$D(XBKDLO)!('$D(XBKDHI)) W !!,"XBKDLO and/or XBKDHI does not exist!" G EOJ
D ^XBKVAR
S:'$D(XBKDDEL) XBKDDEL="A"
S:XBKDDEL="K" XBKDDEL="S" ;***** BACKWARD COMPATABLE *****
I "DAS"'[XBKDDEL W !!,"Invalid XBKDDEL --->",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) <WAIT>"
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)="":"<NONE>",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. <WAIT>" 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
;

62
XBKD1.m Normal file
View File

@ -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
;

Some files were not shown because too many files have changed in this diff Show More