XBCDIC ; IHS/ADC/GTH - CLEAN UP ^DIC AND ^DD ; [ 02/07/97 3:02 PM ]
;;3.0;IHS/VA UTILITIES;;FEB 07, 1997
;
; 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 ""
;
XBCDIC ; IHS/ADC/GTH - CLEAN UP ^DIC AND ^DD ; [ 02/07/97 3:02 PM ]
+1 ;;3.0;IHS/VA UTILITIES;;FEB 07, 1997
+2 ;
+3 ; PROGRAMMERS NOTE:
+4 ; THIS FUNCTIONALITY HAS BEEN INCLUDED IN THE FILEMAN
+5 ; DD UTILITIES, BEGINNING WITH V 19.0. WE RECOMMEND
+6 ; IT'S USE AS IT IS MORE LIKELY TO BE CURRENT.
+7 ; 3-20-96
+8 ;
+9 ; This routine cleans up ^DIC and ^DD by a range of
+10 ; dictionary numbers. All files in ^DIC within the range
+11 ; of dictionary numbers are checked for the following:
+12 ;
+13 ; They must have a NAME in ^DIC.
+14 ; The NAME in ^DIC must match the NAME in ^DD.
+15 ; The NAME must exist in ^DIC("B" with the correct number,
+16 ; and that number cannot occur more than once in ^DIC("B".
+17 ; They must have a data global specified in ^DIC.
+18 ; The data global must be in the correct form.
+19 ; The data global must exist.
+20 ; The data global must have a 0th node.
+21 ; The NAME and NUMBER in the data global must match ^DIC.
+22 ; The data globals 0th node must be consistent with
+23 ; the data (Exact count not checked).
+24 ;
+25 ; They must have valid entries in ^DD as follows:
+26 ; The ^DD entry must have a .01 field.
+27 ; All "SB" pointers must point to existing sub-files.
+28 ; All sub-files must point back to correct parent.
+29 ; All "TRB" entries must exist.
+30 ; All "PT" entries must exist.
+31 ; All "ACOMP" entries must exist.
+32 ;
+33 ; When discrepancies are found the entries are corrected
+34 ; automatically where ever possible. If this is not possible
+35 ; operator interaction occurs to make the corrections. If
+36 ; the file cannot be corrected, it will be deleted.
+37 ;
+38 ; After all dictionaries within the range of dictionary
+39 ; numbers are checked, all other entries within the range
+40 ; will be deleted.
+41 ;
+42 ; The last step is to set the 0th node of the FILE OF FILES
+43 ; to the correct high DFN and the correct count of entries.
+44 ;
BEGIN ;
+1 SET U="^"
+2 WRITE !!,"THIS FUNCTIONALITY HAS BEEN INCLUDED IN THE FILEMAN"
+3 WRITE !,"DD UTILITIES, BEGINNING WITH V 19.0. WE RECOMMEND"
+4 WRITE !,"IT'S USE AS IT IS MORE LIKELY TO BE CURRENT."
+5 WRITE !," 3-20-96",!!
+6 IF '$$DIR^XBDIR("E")
QUIT
+7 WRITE !!,"This routine cleans up ^DIC and ^DD by a range of dictionary numbers."
LO ;
+1 READ !!,"Enter low number of range: ",XBCDLO:$GET(DTIME,999)
+2 IF XBCDLO'=+XBCDLO
GOTO EOJ
HI ;
+1 READ !,"Enter high number of range: ",XBCDHI:$GET(DTIME,999)
+2 IF XBCDHI=""
SET XBCDHI=XBCDLO
+3 IF XBCDHI'=+XBCDHI!(XBCDHI<XBCDLO)
GOTO EOJ
+4 IF XBCDLO<2
WRITE !!,"*** Don't mess with files less than 2!! ***",*7
GOTO EOJ
+5 SET XBDSLO=XBCDLO
SET XBDSHI=XBCDHI
+6 DO EN1^XBDSET
+7 IF '$DATA(^UTILITY("XBDSET",$JOB))
WRITE !!,"No dictionaries were selected!"
GOTO EOJ
+8 ; Check names and data globals *****
DO ^XBCDIC2
+9 ; Delete bad files found by ^XBCDIC2 *****
DO ^XBCDICD
+10 SET XBDSLO=XBCDLO
SET XBDSHI=XBCDHI
+11 ; Get list again *****
DO EN1^XBDSET
+12 ; Check ^DD entries *****
DO ^XBCDIC3
+13 SET XBRLO=XBCDLO
SET XBRHI=XBCDHI
+14 ; Check dangling ^DD entries *****
DO EN1^XBRESID
+15 WRITE !!,"Now confirming ^DIC(""B"")"
+16 SET XBCDX=""
+17 FOR XBCDL=0:0
SET XBCDX=$ORDER(^DIC("B",XBCDX))
IF XBCDX=""
QUIT
SET XBCDFILE=""
FOR XBCDL=0:0
SET XBCDFILE=$ORDER(^DIC("B",XBCDX,XBCDFILE))
IF XBCDFILE=""
QUIT
IF XBCDFILE'<XBCDLO
IF XBCDFILE'>XBCDHI
WRITE "."
DO BCHK
+18 SET XBCDFILE=XBCDLO-.00000001
+19 FOR XBCDL=0:0
SET XBCDFILE=$ORDER(^DIC(XBCDFILE))
IF XBCDFILE'=+XBCDFILE
QUIT
IF XBCDFILE'>XBCDHI
WRITE "."
SET XBCDNDIC=$PIECE(^DIC(XBCDFILE,0),U,1)
IF XBCDNDIC]""
IF '$DATA(^DIC("B",XBCDNDIC,XBCDFILE))
SET ^(XBCDFILE)=""
WRITE "|"
+20 GOTO EOJ
+21 ;
BCHK ;
+1 IF '$DATA(^DIC(XBCDFILE,0))#2
KILL ^DIC("B",XBCDX,XBCDFILE)
WRITE "|"
QUIT
+2 IF XBCDX'=$PIECE(^DIC(XBCDFILE,0),U,1)
KILL ^DIC("B",XBCDX,XBCDFILE)
WRITE "|"
+3 QUIT
EOJ ;
+1 KILL XBCDLO,XBCDHI,XBCDUCI,XBCDL,XBCDFILE,XBCDX,XBCDNDIC
+2 KILL ^UTILITY("XBDSET",$JOB)
+3 QUIT
+4 ;
+5 WRITE !,"Package ",XBBPPRFX," has no pre-initialization routine entry!",!
+6 QUIT
+7 ;
EOJ3 ;
+1 KILL ^UTILITY("XBBPI",$JOB),^UTILITY("XBBPPGM",$JOB),^UTILITY("XBBPI EXEC",$JOB)
+2 KILL %,%DT,DIE,XCN
+3 KILL XBBPDFN,XBBPFLE,XBBPFLG,XBBPI,XBBPL,XBBPP,XBBPPGM,XBBPPRFX,XBBPX,XBBPY
+4 QUIT
+5 ;
DTA ;
+1 ;; 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
+2 ;; K XBBPI,XBBPIX,XBBPIY D EN2^XBKD
+3 ;;Q Q
+4 ; ex: D to denote DUZ
+5 ; '|' Separator
+6 ;
+7 ; variable1 User's choice of the local variable
+8 ; ex: DUZ
+9 ; '*' Repetative marker if more than one
+10 ; mnemonic is indicated
+11 ;
+12 ; USE The mnemonic reference can be used any where
+13 ; in the WP form.
+14 ; Format ~mnemonic|variable subscript~
+15 ;
+16 ; '~' Beginning marker for the variable
+17 ;
+18 ; mnemonic1 User's mnemonic
+19 ;
+20 ; '|' Separator
+21 ;
+22 ; subscript The subscript of the variable to be used
+23 ;
+24 ; '~' Ending marker for the variable
+25 ;
+26 ; ex: ~D|~ for DUZ
+27 ; ~D|0~ for DUZ(0)
+28 ; ~I|.01~ for BARIPT(.01)
+29 ;
+30 ; MUMPS OUTPUT A simple mumps output transform is also
+31 ; TRANSFORM provided to aid in form design. A variable or
+32 ; mnemonic indicated will have its output
+33 ; transformed prior to being put into the form.
+34 ;
+35 ; SETUP
+36 ;
+37 ; *var1!mumps code1*var2!mumps code2
+38 ; *mnemonic3!mumps code3*mnemonic4!mumps code4
+39 ;
+40 ; Ex: *DUZ(2)!$J(X,10,2) will output $J(DUZ(2),10,2)
+41 ; *D|2!$J(X,10,2) mnemonic notation of same
+42 ;
+43 ; '*' Output Transform marker in column one. At TOF
+44 ;
+45 ; Variable/ Variable or mnemonic as it would appear in the
+46 ; Mneumonic form between '~'s.
+47 ;
+48 ; '!' Separator
+49 ;
+50 ; mumps code Mumps code expression as a function of x.
+51 ; Do not state 'S X=f(x)'
+52 ; Enter the function only, f(x).
+53 ;
+54 ; '*' Separator if more than one is put on one line.
+55 ;
+56 ; SPECIAL OUTPUT TRANSFORMS provided by XBARRAY
+57 ;
+58 ; xxx!$$MDY(X) a literal ~"NOW"~ or variable ~IT|9~
+59 ; ex: *"NOW"!$$MDY(X) or *IT|9!$$MDY(X)
+60 ; returns mm/dd/yy
+61 ;
+62 ; xxx!$$WP("X") for a word processing field
+63 ; NOTE: "X" IS ABSOLUTELY NECESSARY
+64 ; The variable array must have the form
+65 ; VAR(subcript,n) where n = 1:1
+66 ;
DOCE ;
+1 ;
TEST ; If you have A/R installed, uncomment the following lines for a
+1 ; demonstration.
+2 ; D INIT^BARUTL
+3 ; D ENP^XBDIQ1(200,DUZ,".01:.116","BARU(")
+4 ; S BARFORM="PW TEST"
+5 ; D EDIT^XBARRAY(.BARFORM,90053.01,1000)
+6 ; S Y=$$GEN^XBARRAY(.BARFORM,90053.01,1000,"BARFM",0,10)
+7 ; K BARFORM(BARFORM)
+8 ; Q
+9 ;
+10 NEW I,W
+11 SET XBLWP=$GET(XBLLINE)
SET W=$PIECE(X,")")
+12 FOR I=0:1
SET X=$QUERY(@X)
IF X=""
QUIT
IF (W'=$PIECE(X,","))
QUIT
Begin DoDot:1
+13 SET T=@X
SET XBLLINE=XBLWP+I
+14 IF '$GET(XBFMT)
SET XBZ(XBL+XBLLINE)=T
+15 IF ($GET(XBFMT)=1)
SET XBZ(XBL+XBLLINE,0)=T
End DoDot:1
+16 QUIT ""
+17 ;
