BMXADOS ; IHS/CIHA/GIS - UPDATE THE BMX ADO SCHEMA FILE ;
;;4.0;BMX;;JUN 28, 2010
; ENABLES NAVIGATION TO SUBFILES PRIOR TO UPDATING THE SCHEMA FILE ENTRY
;
;
;
UPDATE ; UPDATE THE SCHEMA FILE
N DIC,X,Y,%,STOP,FIEN,FNAME,SNAME,SIEN
UDIC S DIC("A")="Enter schema name: " ; EP FROM VENPCCTU
S DIC(0)="AEQLM",DIC="^BMXADO("
D ^DIC I Y=-1 G FIN
SCHEMA S SNAME=$P(Y,U,2),SIEN=+Y
S FIEN=$$FILE(SIEN) I 'FIEN G FIN
I FIEN'=$P($G(^BMXADO(SIEN,0)),U,2) S DIE=DIC,DA=SIEN,DR=".02////^S X=FIEN" D ^DIE
F D FLD(FIEN,SIEN) I $G(STOP) Q ; GET FIELD INFO
FIN D ^XBFMK
Q
;
FLD(FIEN,SIEN) ; GET THE FIELD
N DIC,X,Y,DIE,DA,DR,FLDIEN,FLDNAME,FLDTYPE,FDEF,TRANS
N %,%Y,HDR,DTYPE,LEN,FARR,I,TOT,PAUSE,PFLAG,IFLAG,IMSG,STG,READ
D FLIST(.FARR,FIEN,0)
S TOT=$O(FARR(9999),-1) I 'TOT S STOP=1 Q
W !,"Select a field from this "_$S($D(^DD(FIEN,0,"UP")):"sub-",1:"")_"file: "
S I=0 F S I=$O(FARR(I)) Q:'I S PAUSE=$$PAUSE(I) Q:PAUSE'="" W I,?3,FARR(I)
I $G(PAUSE)=U S STOP=1 Q
I $G(PAUSE) S Y=PAUSE G FLD1
S DIR(0)="NO^1:"_TOT_":",DIR("A")="Select a field from the list" K DA D ^DIR K DIR
I 'Y S STOP=1 Q
FLD1 S %=FARR(+Y)
S FLDIEN=+$P(%," [",2),FLDNAME=$P(%," [")
I $$FDEL(SIEN,FLDIEN) Q ; FIELD DELETED
S X=$$FDEF(FIEN,FLDIEN) I '$L(X) W " ??" Q
S DTYPE=$E(X),LEN=+$E(X,2,6)
S DIR(0)="F^1:30",DIR("A")="Column header",DIR("B")=FLDNAME D ^DIR K DIR
S HDR=Y,TRANS=0
S %=$P($G(^DD(FIEN,FLDIEN,0)),U,2) ; CHECK FM DD TO SEE IF FIELD IS REQUIRED
I %["R" W !,"FileMan requires a non-null value for this field" S %=2
E W !,"Is null allowed" S %=$S(FLDIEN=.01:2,1:1) D YN^DICN I %Y?1."^" Q
I %=2 S TRANS=1 ; NON NULL VALUE REQUIRED TO COMPLETE THE TRANSACTION OR THERE WILL BE ROLLBACK
I $G(PFLAG) D ; IF POINTER, ASK IF USER WANTS TO AUTOMATICALLY INSERT THE LOOKUP VALUE FIELD IN THE SCHEMA
. W !,"This field is a pointer value (IEN)."
. W !,"Want to automatically insert the lookup value in the schema"
. S %=2 D YN^DICN W ! I %=1 S PFLAG=2
. Q
IFLG I $G(IFLAG) D ; NON-POINTER .01 FIELD. ASK IF USER WANTS TO REFERENCE IDENTIFIER EP
. W !,"Want to display identifiers with this field"
. S %=2 D YN^DICN W ! I %'=1 Q
. S IMSG="Respond with a valid entry point in the format 'TAG^ROUTINE'."
. W !,"Entry Point to generate Identifiers: " R Y:$G(DTIME,60) E Q ; IHS/OIT/HMW SAC Exemption Applied For
. I Y?1."^" Q
. I Y?1."?" W !,IMSG S IFLAG(0)="!" Q
. I Y'?1U.7UN1"^"1U.7UN S IFLAG(0)="!" W " ??"
. I $L(Y)>2 S IFLAG(0)=Y,IFLAG=2
. Q
I $G(IFLAG(0))="!" W !,IMSG K IPFLAG(0),IMSG W !!! G IFLG
S DA(1)=SIEN,DIC="^BMXADO("_DA(1)_",1,"
S DIC("P")=90093.991,DIC(0)="L",X=FLDIEN
I '$D(^BMXADO(SIEN,1,0)) S ^BMXADO(SIEN,1,0)="^90093.991^^"
D ^DIC I Y=-1 Q
S READ=($P($G(^DD(FIEN,FLDIEN,0)),U,2)["C") ; COMPUTED FIELDS ARE READ ONLY!
S DIE=DIC,DA=+Y
S DR=".02///^S X=DTYPE;.03///^S X=LEN;.04///^S X=HDR;.05///^S X=READ;.06///0;.07///^S X=('TRANS)"
D ^DIE
I $G(IFLAG)=2 D ID
I $G(PFLAG)'=2 Q
LKUP ; AUTOMATICALLY ADD A LOOKUP FIELD TO THE SCHEMA
S X=FLDIEN_"IEN"
D ^DIC I Y=-1 Q
W !,"The LOOKUP field '"_X_"' has been added to the schema",!
S HDR=HDR_"_IEN",DTYPE="I",LEN="00009"
S DIE=DIC,DA=+Y
S DR=".02///^S X=DTYPE;.03///^S X=LEN;.04///^S X=HDR;.05///^S X=READ;.06///0;.07///^S X=('TRANS)"
D ^DIE
Q
;
ID ; AUTOMATICALLY ADD AN IDENTIFIER REFERENCE
N X,Y,DIE,DR,DA,REF
S X=".01ID",DA(1)=SIEN
S REF=IFLAG(0) I '$L(REF) Q
D ^DIC I Y=-1 Q
W !,"The identifier field '"_X_"' has been added to the schema",!
S HDR=HDR_"_ID",DTYPE="T",LEN="00017"
S DIE=DIC,DA=+Y
S DR=".02///^S X=DTYPE;.03///^S X=LEN;.04///^S X=HDR;.05///^S X=READ;.06///0;.07///^S X=('TRANS);1///^S X=REF"
D ^DIE
Q
;
FDEL(SIEN,FIELD) ; DELETE AN EXISTING ENTRY FROM THE 'FIELD' MULTIPLE. RETURN '1' IF THE RECORD WAS DELETED
N FIEN,DA,DIK
S FIEN=$O(^BMXADO(SIEN,1,"B",FIELD,0)) I 'FIEN Q 0 ; THIS IS A NEW ENTRY
W !,"This field already is attached to the schema. Want to delete it"
S %=2 D YN^DICN
I %'=1 Q 0
S DA(1)=SIEN,DIK="^BMXADO("_DA(1)_",1,",DA=FIEN
D ^DIK
S FIEN=$O(^BMXADO(SIEN,1,"B",(FIELD_"IEN"),0))
I FIEN S DA=FIEN D ^DIK ; DELETE LOOKUP VALUE FIELD AS WELL
W " Done!",!
Q 1
;
FDEF(FILE,FIELD) ;EP - GIVEN A FILEMAN FILE AND FIELD, RETURN THE DATA DEFINITION IN ADO FORMAT
N %,X,Y,Z,STG,I,DTYPE,FNAME,LEN,DNAME
I '$D(^DD(+$G(FILE),+$G(FIELD),0)) Q ""
S STG=$G(^DD(FILE,FIELD,0)) I '$L(STG) Q "" ; GET DATA DEF STRING
DTYPE S %="DNSFWCPVM",X=$P(STG,U,2),DTYPE="" ; GET DATA TYPE
F I=1:1:$L(%) S Y=$E(%,I) I X[Y S DTYPE=Y Q
I DTYPE="" Q ""
FNAME S DNAME=$P(STG,U) I '$L(DNAME) Q "" ; FIELD NAME
DDA ; ADO FORMAT
I DTYPE="D" D Q "D"_LEN_DNAME
. S LEN="00021"
. I STG["S %DT=" S %=$P(STG,"S %DT=",2),%=$P(%,$C(34))
. I $G(FLDIEN)=.01 S IFLAG=1
. I %["S" S LEN="00019" Q
. I %["T" S LEN="00018" Q
. Q
I DTYPE="N",STG["1N.N" D Q:'LEN "" Q "I"_LEN_DNAME ; INTEGER
. S %=+$P(STG,"K:+X'=X!(X>",2)
. S Y=$L(%)
. S LEN=$E("00000",1,5-$L(Y))_Y
. Q
I DTYPE="N" D Q:'LEN "" Q "N"_LEN_DNAME ; NUMBER (COULD HAVE A DECIMAL VALUE)
. S %=+$P(STG,"!(X?.E1"".""",2)
. S X=+$P(STG,"K:+X'=X!(X>",2)
. S Y=%+($L(+X))
. S LEN=$E("00000",1,5-$L(Y))_Y
. Q
I DTYPE="F" D Q:'LEN "" Q "T"_LEN_DNAME
. S Y=+$P(STG,"K:$L(X)>",2)
. S LEN=$E("00000",1,5-$L(Y))_Y
. I 'LEN S LEN="00030"
. I $G(FLDIEN)=.01 S IFLAG=1
. Q
I DTYPE="S" D Q:'LEN "" Q "T"_LEN_DNAME
. S X=$P(STG,U,3),Y=0
. F I=1:1:$L(X,":") S Z=$P(X,":",2),Z=$P(Z,";"),%=$L(Z) I %>Y S Y=%
. S LEN=$E("00000",1,5-$L(Y))_Y
. Q
I DTYPE="P" S PFLAG=1 Q "T00030"_DNAME
I DTYPE="W" Q "T05000"_DNAME
I DTYPE="V" Q ""
Q "T00250"_DNAME
;
FILE(SIEN) ; GET THE FILE OR SUBFILE NUMBER
N FNO,FIEN,DIC,X,Y,%,FILE,NSTG,GBL,FNAME,SUB,FARR,TOT,I
S (FILE,FNO)=$P(^BMXADO(SIEN,0),U,2)
OLD I FNO D I $G(FIEN) Q FIEN
. S NSTG=$O(^DD(FNO,0,"NM",""))
. F S FNO=$G(^DD(FNO,0,"UP")) Q:'FNO S NSTG=$O(^DD(FNO,0,"NM",""))_"/"_NSTG
OLD1 . W !,$S(NSTG["/":"Sub-",1:""),"File #",FILE," (",NSTG,") is linked to this schema."
. W !,"Want to keep it" S %=1
. D YN^DICN I %'=2 W:%=1 " OK" S FIEN=FILE Q
. W !!,"If you change or delete this file number,",!,"all the information in this schema will be deleted."
. W !,"Are you sure you want to do this" S %=2 D YN^DICN
. I %'=1 W !! G OLD1
. S GBL="^BMXADO("_SIEN_")"
. K @GBL@(1),@GBL@(2)
. S $P(@GBL@(0),U,2)=""
. W !,"This schema definition has been deleted. You may redefine it now"
. Q
NEW S DIC=1,DIC(0)="AEQM" D ^DIC I Y=-1 Q ""
S FNO=+Y,FNAME=$P(Y,U,2)
NEW1 D SC(.FARR,FNO,1)
S TOT=$O(FARR(999999),-1) I 'TOT Q FNO ; NO SUBFILES FOUND
W !!,"The ",FNAME," file contains the following sub-file" I TOT>1 W "s"
W !
S I=0 F S I=$O(FARR(I)) Q:'I S PAUSE=$$PAUSE(I) Q:PAUSE'="" W I,?3,FARR(I)
I $G(PAUSE)=U Q ""
I $G(PAUSE) S Y=PAUSE G NEW2
W !!,"Is the schema linked to a sub-file in this list"
S %=2 D YN^DICN I %=2 Q FNO
S DIR(0)="NO^1:"_TOT_":",DIR("A")="Select a sub-file from the list" K DA D ^DIR K DIR
I 'Y Q ""
NEW2 Q +$P(FARR(+Y)," (",2)
;
PAUSE(I) ; SCROLL CHECK
N %
W !
I (I#20) Q ""
W "Select a number from the list (1-",(I-1),") or press <ENTER> to continue: "
R %:$G(DTIME,60) E Q "" ; IHS/OIT/HMW SAC Exemption Applied For
I %?1."^" Q U
I $L(%),$D(FARR(I)) Q %
I $L(%) W " ??" H 2
W $C(13),?79,$C(13)
Q ""
;
SC(OUT,FILE,MODE) ;EP - SUB CRAWLER. GIVEN A FILE NUMBER RETURN ALL OF ITS DESCENDANT FILES IN AN ARRAY
I '$D(^DD(FILE,"SB")) Q ; NO DESCENDANTS
N TOT,FNO,FNAME,FIEN,LEVEL,NODE,SARR,STG,X,%,UP,ARR
S FIEN=FILE,TOT=0
D PASS1
I '$O(ARR(0)) Q
SC2 ; SECOND PASS. BUILD THE INTERMEDIATE ARRAY
S FNO=0 F S FNO=$O(ARR(FNO)) Q:'FNO D
. I $P($G(^DD(FNO,.01,0)),U,2)["W" K ARR(FNO) Q ; WORD PROCESSING FIELDS DO NOT COUNT
. S STG=FNO,UP=FNO
. F S UP=$G(^DD(UP,0,"UP")) Q:'UP S STG=UP_","_STG ; BUILD DESCENDANT STRING
. I $G(MODE) S STG=$$ASTG(STG)
. S STG=$P(STG,",",2,99) ; DONT NEED TOP LEVEL FILE
. I '$L(STG) Q ; SOMETHING IS SCREWED UP
. S LEVEL=$L(STG,",")
. S FNAME=$O(^DD(FNO,0,"NM",""))
. S X="SARR("_STG_")"
. S @X=FNAME_U_LEVEL_U_FNO
. K ARR(FNO)
. Q
SC3 ; 3RD PASS. BUILD OUTPUT ARAY
S NODE="SARR"
F S NODE=$Q(@NODE) Q:NODE="" D
. S X=@NODE
. S TOT=TOT+1
. S FNAME=$P(X,U)
. S LEVEL=$P(X,U,2)
. S FNO=$P(X,U,3)
. S OUT(TOT)=$E(" ",1,LEVEL)_FNAME_" ("_FNO_")"
. Q
Q
;
PASS1 ; PASS 1. BUILD THE ARRAY OF ALL SUBFILES
N FNO S FNO=0
F S FNO=$O(^DD(FIEN,"SB",FNO)) Q:'FNO D
. S ARR(FNO)=""
. I '$D(^DD(FNO,"SB")) Q
. N FIEN S FIEN=FNO
. D PASS1 ; RECURSION!!
. Q
Q
;
ASTG(STG) ; CONVERT STRING FROM FILE NUMBERS TO FILE NAMES
N PCE,LEV,FNO,NAME
S LEV=$L(STG,",")
F PCE=1:1:LEV S FNO=+$P(STG,",",PCE) D I '$L(STG) Q ""
. S NAME=$O(^DD(FNO,0,"NM",""))
. I $E(NAME)="*" S NAME=$E(NAME,2,99)
. I '$L(NAME) S STG="" Q
. S $P(STG,",",PCE)=""""_NAME_""""
. Q
Q STG
;
FLIST(OUT,FILE,MODE) ;EP - GIVEN A FILE RETURN THE FILEDS IN AN ARRAY MODE=0: NUMERIC ORDER, MODE=1: ALPHA ORDER
; ONLY NON MULTIPLES AND WORD PROCESSING FIELDS ARE LISTED
N FLD,TOT,NAME,ARR,SS,%,WP
S FLD=0,TOT=0
F1 F S FLD=$O(^DD(FILE,FLD)) Q:'FLD D ; PASS 1
. S STG=$G(^DD(FILE,FLD,0)) I '$L(STG) Q
. S %=$P(STG,U,2)
. I %,$P($G(^DD(%,.01,0)),U,2)'["W" Q ; EXCLUDE ALL MULTIPLE FIELDS EXCEPT WORD PROCESSING FIELDS
. S WP=0 I % S WP=1
. S NAME=$P(STG,U)
. S SS=FLD
. I $G(MODE)=1 S %=NAME S:$E(%)="*" %=$E(%,2,99) S SS=%
. S ARR(SS)=FLD_U_NAME_U_WP
. Q
F2 S SS=""
F S SS=$O(ARR(SS)) Q:SS="" D
. S TOT=TOT+1
. S %=ARR(SS)
. S OUT(TOT)=$P(%,U,2)_" ["_+%_"]"_$S($P(%,U,3):" (word processing)",1:"")
. K ARR(SS)
. Q
Q
;
BMXADOS ; IHS/CIHA/GIS - UPDATE THE BMX ADO SCHEMA FILE ;
+1 ;;4.0;BMX;;JUN 28, 2010
+2 ; ENABLES NAVIGATION TO SUBFILES PRIOR TO UPDATING THE SCHEMA FILE ENTRY
+3 ;
+4 ;
+5 ;
UPDATE ; UPDATE THE SCHEMA FILE
+1 NEW DIC,X,Y,%,STOP,FIEN,FNAME,SNAME,SIEN
UDIC ; EP FROM VENPCCTU
SET DIC("A")="Enter schema name: "
+1 SET DIC(0)="AEQLM"
SET DIC="^BMXADO("
+2 DO ^DIC
IF Y=-1
GOTO FIN
SCHEMA SET SNAME=$PIECE(Y,U,2)
SET SIEN=+Y
+1 SET FIEN=$$FILE(SIEN)
IF 'FIEN
GOTO FIN
+2 IF FIEN'=$PIECE($GET(^BMXADO(SIEN,0)),U,2)
SET DIE=DIC
SET DA=SIEN
SET DR=".02////^S X=FIEN"
DO ^DIE
+3 ; GET FIELD INFO
FOR
DO FLD(FIEN,SIEN)
IF $GET(STOP)
QUIT
FIN DO ^XBFMK
+1 QUIT
+2 ;
FLD(FIEN,SIEN) ; GET THE FIELD
+1 NEW DIC,X,Y,DIE,DA,DR,FLDIEN,FLDNAME,FLDTYPE,FDEF,TRANS
+2 NEW %,%Y,HDR,DTYPE,LEN,FARR,I,TOT,PAUSE,PFLAG,IFLAG,IMSG,STG,READ
+3 DO FLIST(.FARR,FIEN,0)
+4 SET TOT=$ORDER(FARR(9999),-1)
IF 'TOT
SET STOP=1
QUIT
+5 WRITE !,"Select a field from this "_$SELECT($DATA(^DD(FIEN,0,"UP")):"sub-",1:"")_"file: "
+6 SET I=0
FOR
SET I=$ORDER(FARR(I))
IF 'I
QUIT
SET PAUSE=$$PAUSE(I)
IF PAUSE'=""
QUIT
WRITE I,?3,FARR(I)
+7 IF $GET(PAUSE)=U
SET STOP=1
QUIT
+8 IF $GET(PAUSE)
SET Y=PAUSE
GOTO FLD1
+9 SET DIR(0)="NO^1:"_TOT_":"
SET DIR("A")="Select a field from the list"
KILL DA
DO ^DIR
KILL DIR
+10 IF 'Y
SET STOP=1
QUIT
FLD1 SET %=FARR(+Y)
+1 SET FLDIEN=+$PIECE(%," [",2)
SET FLDNAME=$PIECE(%," [")
+2 ; FIELD DELETED
IF $$FDEL(SIEN,FLDIEN)
QUIT
+3 SET X=$$FDEF(FIEN,FLDIEN)
IF '$LENGTH(X)
WRITE " ??"
QUIT
+4 SET DTYPE=$EXTRACT(X)
SET LEN=+$EXTRACT(X,2,6)
+5 SET DIR(0)="F^1:30"
SET DIR("A")="Column header"
SET DIR("B")=FLDNAME
DO ^DIR
KILL DIR
+6 SET HDR=Y
SET TRANS=0
+7 ; CHECK FM DD TO SEE IF FIELD IS REQUIRED
SET %=$PIECE($GET(^DD(FIEN,FLDIEN,0)),U,2)
+8 IF %["R"
WRITE !,"FileMan requires a non-null value for this field"
SET %=2
+9 IF '$TEST
WRITE !,"Is null allowed"
SET %=$SELECT(FLDIEN=.01:2,1:1)
DO YN^DICN
IF %Y?1."^"
QUIT
+10 ; NON NULL VALUE REQUIRED TO COMPLETE THE TRANSACTION OR THERE WILL BE ROLLBACK
IF %=2
SET TRANS=1
+11 ; IF POINTER, ASK IF USER WANTS TO AUTOMATICALLY INSERT THE LOOKUP VALUE FIELD IN THE SCHEMA
IF $GET(PFLAG)
Begin DoDot:1
+12 WRITE !,"This field is a pointer value (IEN)."
+13 WRITE !,"Want to automatically insert the lookup value in the schema"
+14 SET %=2
DO YN^DICN
WRITE !
IF %=1
SET PFLAG=2
+15 QUIT
End DoDot:1
IFLG ; NON-POINTER .01 FIELD. ASK IF USER WANTS TO REFERENCE IDENTIFIER EP
IF $GET(IFLAG)
Begin DoDot:1
+1 WRITE !,"Want to display identifiers with this field"
+2 SET %=2
DO YN^DICN
WRITE !
IF %'=1
QUIT
+3 SET IMSG="Respond with a valid entry point in the format 'TAG^ROUTINE'."
+4 ; IHS/OIT/HMW SAC Exemption Applied For
WRITE !,"Entry Point to generate Identifiers: "
READ Y:$GET(DTIME,60)
IF '$TEST
QUIT
+5 IF Y?1."^"
QUIT
+6 IF Y?1."?"
WRITE !,IMSG
SET IFLAG(0)="!"
QUIT
+7 IF Y'?1U.7UN1"^"1U.7UN
SET IFLAG(0)="!"
WRITE " ??"
+8 IF $LENGTH(Y)>2
SET IFLAG(0)=Y
SET IFLAG=2
+9 QUIT
End DoDot:1
+10 IF $GET(IFLAG(0))="!"
WRITE !,IMSG
KILL IPFLAG(0),IMSG
WRITE !!!
GOTO IFLG
+11 SET DA(1)=SIEN
SET DIC="^BMXADO("_DA(1)_",1,"
+12 SET DIC("P")=90093.991
SET DIC(0)="L"
SET X=FLDIEN
+13 IF '$DATA(^BMXADO(SIEN,1,0))
SET ^BMXADO(SIEN,1,0)="^90093.991^^"
+14 DO ^DIC
IF Y=-1
QUIT
+15 ; COMPUTED FIELDS ARE READ ONLY!
SET READ=($PIECE($GET(^DD(FIEN,FLDIEN,0)),U,2)["C")
+16 SET DIE=DIC
SET DA=+Y
+17 SET DR=".02///^S X=DTYPE;.03///^S X=LEN;.04///^S X=HDR;.05///^S X=READ;.06///0;.07///^S X=('TRANS)"
+18 DO ^DIE
+19 IF $GET(IFLAG)=2
DO ID
+20 IF $GET(PFLAG)'=2
QUIT
LKUP ; AUTOMATICALLY ADD A LOOKUP FIELD TO THE SCHEMA
+1 SET X=FLDIEN_"IEN"
+2 DO ^DIC
IF Y=-1
QUIT
+3 WRITE !,"The LOOKUP field '"_X_"' has been added to the schema",!
+4 SET HDR=HDR_"_IEN"
SET DTYPE="I"
SET LEN="00009"
+5 SET DIE=DIC
SET DA=+Y
+6 SET DR=".02///^S X=DTYPE;.03///^S X=LEN;.04///^S X=HDR;.05///^S X=READ;.06///0;.07///^S X=('TRANS)"
+7 DO ^DIE
+8 QUIT
+9 ;
ID ; AUTOMATICALLY ADD AN IDENTIFIER REFERENCE
+1 NEW X,Y,DIE,DR,DA,REF
+2 SET X=".01ID"
SET DA(1)=SIEN
+3 SET REF=IFLAG(0)
IF '$LENGTH(REF)
QUIT
+4 DO ^DIC
IF Y=-1
QUIT
+5 WRITE !,"The identifier field '"_X_"' has been added to the schema",!
+6 SET HDR=HDR_"_ID"
SET DTYPE="T"
SET LEN="00017"
+7 SET DIE=DIC
SET DA=+Y
+8 SET DR=".02///^S X=DTYPE;.03///^S X=LEN;.04///^S X=HDR;.05///^S X=READ;.06///0;.07///^S X=('TRANS);1///^S X=REF"
+9 DO ^DIE
+10 QUIT
+11 ;
FDEL(SIEN,FIELD) ; DELETE AN EXISTING ENTRY FROM THE 'FIELD' MULTIPLE. RETURN '1' IF THE RECORD WAS DELETED
+1 NEW FIEN,DA,DIK
+2 ; THIS IS A NEW ENTRY
SET FIEN=$ORDER(^BMXADO(SIEN,1,"B",FIELD,0))
IF 'FIEN
QUIT 0
+3 WRITE !,"This field already is attached to the schema. Want to delete it"
+4 SET %=2
DO YN^DICN
+5 IF %'=1
QUIT 0
+6 SET DA(1)=SIEN
SET DIK="^BMXADO("_DA(1)_",1,"
SET DA=FIEN
+7 DO ^DIK
+8 SET FIEN=$ORDER(^BMXADO(SIEN,1,"B",(FIELD_"IEN"),0))
+9 ; DELETE LOOKUP VALUE FIELD AS WELL
IF FIEN
SET DA=FIEN
DO ^DIK
+10 WRITE " Done!",!
+11 QUIT 1
+12 ;
FDEF(FILE,FIELD) ;EP - GIVEN A FILEMAN FILE AND FIELD, RETURN THE DATA DEFINITION IN ADO FORMAT
+1 NEW %,X,Y,Z,STG,I,DTYPE,FNAME,LEN,DNAME
+2 IF '$DATA(^DD(+$GET(FILE),+$GET(FIELD),0))
QUIT ""
+3 ; GET DATA DEF STRING
SET STG=$GET(^DD(FILE,FIELD,0))
IF '$LENGTH(STG)
QUIT ""
DTYPE ; GET DATA TYPE
SET %="DNSFWCPVM"
SET X=$PIECE(STG,U,2)
SET DTYPE=""
+1 FOR I=1:1:$LENGTH(%)
SET Y=$EXTRACT(%,I)
IF X[Y
SET DTYPE=Y
QUIT
+2 IF DTYPE=""
QUIT ""
FNAME ; FIELD NAME
SET DNAME=$PIECE(STG,U)
IF '$LENGTH(DNAME)
QUIT ""
DDA ; ADO FORMAT
+1 IF DTYPE="D"
Begin DoDot:1
+2 SET LEN="00021"
+3 IF STG["S %DT="
SET %=$PIECE(STG,"S %DT=",2)
SET %=$PIECE(%,$CHAR(34))
+4 IF $GET(FLDIEN)=.01
SET IFLAG=1
+5 IF %["S"
SET LEN="00019"
QUIT
+6 IF %["T"
SET LEN="00018"
QUIT
+7 QUIT
End DoDot:1
QUIT "D"_LEN_DNAME
+8 ; INTEGER
IF DTYPE="N"
IF STG["1N.N"
Begin DoDot:1
+9 SET %=+$PIECE(STG,"K:+X'=X!(X>",2)
+10 SET Y=$LENGTH(%)
+11 SET LEN=$EXTRACT("00000",1,5-$LENGTH(Y))_Y
+12 QUIT
End DoDot:1
IF 'LEN
QUIT ""
QUIT "I"_LEN_DNAME
+13 ; NUMBER (COULD HAVE A DECIMAL VALUE)
IF DTYPE="N"
Begin DoDot:1
+14 SET %=+$PIECE(STG,"!(X?.E1"".""",2)
+15 SET X=+$PIECE(STG,"K:+X'=X!(X>",2)
+16 SET Y=%+($LENGTH(+X))
+17 SET LEN=$EXTRACT("00000",1,5-$LENGTH(Y))_Y
+18 QUIT
End DoDot:1
IF 'LEN
QUIT ""
QUIT "N"_LEN_DNAME
+19 IF DTYPE="F"
Begin DoDot:1
+20 SET Y=+$PIECE(STG,"K:$L(X)>",2)
+21 SET LEN=$EXTRACT("00000",1,5-$LENGTH(Y))_Y
+22 IF 'LEN
SET LEN="00030"
+23 IF $GET(FLDIEN)=.01
SET IFLAG=1
+24 QUIT
End DoDot:1
IF 'LEN
QUIT ""
QUIT "T"_LEN_DNAME
+25 IF DTYPE="S"
Begin DoDot:1
+26 SET X=$PIECE(STG,U,3)
SET Y=0
+27 FOR I=1:1:$LENGTH(X,":")
SET Z=$PIECE(X,":",2)
SET Z=$PIECE(Z,";")
SET %=$LENGTH(Z)
IF %>Y
SET Y=%
+28 SET LEN=$EXTRACT("00000",1,5-$LENGTH(Y))_Y
+29 QUIT
End DoDot:1
IF 'LEN
QUIT ""
QUIT "T"_LEN_DNAME
+30 IF DTYPE="P"
SET PFLAG=1
QUIT "T00030"_DNAME
+31 IF DTYPE="W"
QUIT "T05000"_DNAME
+32 IF DTYPE="V"
QUIT ""
+33 QUIT "T00250"_DNAME
+34 ;
FILE(SIEN) ; GET THE FILE OR SUBFILE NUMBER
+1 NEW FNO,FIEN,DIC,X,Y,%,FILE,NSTG,GBL,FNAME,SUB,FARR,TOT,I
+2 SET (FILE,FNO)=$PIECE(^BMXADO(SIEN,0),U,2)
OLD IF FNO
Begin DoDot:1
+1 SET NSTG=$ORDER(^DD(FNO,0,"NM",""))
+2 FOR
SET FNO=$GET(^DD(FNO,0,"UP"))
IF 'FNO
QUIT
SET NSTG=$ORDER(^DD(FNO,0,"NM",""))_"/"_NSTG
OLD1 WRITE !,$SELECT(NSTG["/":"Sub-",1:""),"File #",FILE," (",NSTG,") is linked to this schema."
+1 WRITE !,"Want to keep it"
SET %=1
+2 DO YN^DICN
IF %'=2
IF %=1
WRITE " OK"
SET FIEN=FILE
QUIT
+3 WRITE !!,"If you change or delete this file number,",!,"all the information in this schema will be deleted."
+4 WRITE !,"Are you sure you want to do this"
SET %=2
DO YN^DICN
+5 IF %'=1
WRITE !!
GOTO OLD1
+6 SET GBL="^BMXADO("_SIEN_")"
+7 KILL @GBL@(1),@GBL@(2)
+8 SET $PIECE(@GBL@(0),U,2)=""
+9 WRITE !,"This schema definition has been deleted. You may redefine it now"
+10 QUIT
End DoDot:1
IF $GET(FIEN)
QUIT FIEN
NEW SET DIC=1
SET DIC(0)="AEQM"
DO ^DIC
IF Y=-1
QUIT ""
+1 SET FNO=+Y
SET FNAME=$PIECE(Y,U,2)
NEW1 DO SC(.FARR,FNO,1)
+1 ; NO SUBFILES FOUND
SET TOT=$ORDER(FARR(999999),-1)
IF 'TOT
QUIT FNO
+2 WRITE !!,"The ",FNAME," file contains the following sub-file"
IF TOT>1
WRITE "s"
+3 WRITE !
+4 SET I=0
FOR
SET I=$ORDER(FARR(I))
IF 'I
QUIT
SET PAUSE=$$PAUSE(I)
IF PAUSE'=""
QUIT
WRITE I,?3,FARR(I)
+5 IF $GET(PAUSE)=U
QUIT ""
+6 IF $GET(PAUSE)
SET Y=PAUSE
GOTO NEW2
+7 WRITE !!,"Is the schema linked to a sub-file in this list"
+8 SET %=2
DO YN^DICN
IF %=2
QUIT FNO
+9 SET DIR(0)="NO^1:"_TOT_":"
SET DIR("A")="Select a sub-file from the list"
KILL DA
DO ^DIR
KILL DIR
+10 IF 'Y
QUIT ""
NEW2 QUIT +$PIECE(FARR(+Y)," (",2)
+1 ;
PAUSE(I) ; SCROLL CHECK
+1 NEW %
+2 WRITE !
+3 IF (I#20)
QUIT ""
+4 WRITE "Select a number from the list (1-",(I-1),") or press <ENTER> to continue: "
+5 ; IHS/OIT/HMW SAC Exemption Applied For
READ %:$GET(DTIME,60)
IF '$TEST
QUIT ""
+6 IF %?1."^"
QUIT U
+7 IF $LENGTH(%)
IF $DATA(FARR(I))
QUIT %
+8 IF $LENGTH(%)
WRITE " ??"
HANG 2
+9 WRITE $CHAR(13),?79,$CHAR(13)
+10 QUIT ""
+11 ;
SC(OUT,FILE,MODE) ;EP - SUB CRAWLER. GIVEN A FILE NUMBER RETURN ALL OF ITS DESCENDANT FILES IN AN ARRAY
+1 ; NO DESCENDANTS
IF '$DATA(^DD(FILE,"SB"))
QUIT
+2 NEW TOT,FNO,FNAME,FIEN,LEVEL,NODE,SARR,STG,X,%,UP,ARR
+3 SET FIEN=FILE
SET TOT=0
+4 DO PASS1
+5 IF '$ORDER(ARR(0))
QUIT
SC2 ; SECOND PASS. BUILD THE INTERMEDIATE ARRAY
+1 SET FNO=0
FOR
SET FNO=$ORDER(ARR(FNO))
IF 'FNO
QUIT
Begin DoDot:1
+2 ; WORD PROCESSING FIELDS DO NOT COUNT
IF $PIECE($GET(^DD(FNO,.01,0)),U,2)["W"
KILL ARR(FNO)
QUIT
+3 SET STG=FNO
SET UP=FNO
+4 ; BUILD DESCENDANT STRING
FOR
SET UP=$GET(^DD(UP,0,"UP"))
IF 'UP
QUIT
SET STG=UP_","_STG
+5 IF $GET(MODE)
SET STG=$$ASTG(STG)
+6 ; DONT NEED TOP LEVEL FILE
SET STG=$PIECE(STG,",",2,99)
+7 ; SOMETHING IS SCREWED UP
IF '$LENGTH(STG)
QUIT
+8 SET LEVEL=$LENGTH(STG,",")
+9 SET FNAME=$ORDER(^DD(FNO,0,"NM",""))
+10 SET X="SARR("_STG_")"
+11 SET @X=FNAME_U_LEVEL_U_FNO
+12 KILL ARR(FNO)
+13 QUIT
End DoDot:1
SC3 ; 3RD PASS. BUILD OUTPUT ARAY
+1 SET NODE="SARR"
+2 FOR
SET NODE=$QUERY(@NODE)
IF NODE=""
QUIT
Begin DoDot:1
+3 SET X=@NODE
+4 SET TOT=TOT+1
+5 SET FNAME=$PIECE(X,U)
+6 SET LEVEL=$PIECE(X,U,2)
+7 SET FNO=$PIECE(X,U,3)
+8 SET OUT(TOT)=$EXTRACT(" ",1,LEVEL)_FNAME_" ("_FNO_")"
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
PASS1 ; PASS 1. BUILD THE ARRAY OF ALL SUBFILES
+1 NEW FNO
SET FNO=0
+2 FOR
SET FNO=$ORDER(^DD(FIEN,"SB",FNO))
IF 'FNO
QUIT
Begin DoDot:1
+3 SET ARR(FNO)=""
+4 IF '$DATA(^DD(FNO,"SB"))
QUIT
+5 NEW FIEN
SET FIEN=FNO
+6 ; RECURSION!!
DO PASS1
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
ASTG(STG) ; CONVERT STRING FROM FILE NUMBERS TO FILE NAMES
+1 NEW PCE,LEV,FNO,NAME
+2 SET LEV=$LENGTH(STG,",")
+3 FOR PCE=1:1:LEV
SET FNO=+$PIECE(STG,",",PCE)
Begin DoDot:1
+4 SET NAME=$ORDER(^DD(FNO,0,"NM",""))
+5 IF $EXTRACT(NAME)="*"
SET NAME=$EXTRACT(NAME,2,99)
+6 IF '$LENGTH(NAME)
SET STG=""
QUIT
+7 SET $PIECE(STG,",",PCE)=""""_NAME_""""
+8 QUIT
End DoDot:1
IF '$LENGTH(STG)
QUIT ""
+9 QUIT STG
+10 ;
FLIST(OUT,FILE,MODE) ;EP - GIVEN A FILE RETURN THE FILEDS IN AN ARRAY MODE=0: NUMERIC ORDER, MODE=1: ALPHA ORDER
+1 ; ONLY NON MULTIPLES AND WORD PROCESSING FIELDS ARE LISTED
+2 NEW FLD,TOT,NAME,ARR,SS,%,WP
+3 SET FLD=0
SET TOT=0
F1 ; PASS 1
FOR
SET FLD=$ORDER(^DD(FILE,FLD))
IF 'FLD
QUIT
Begin DoDot:1
+1 SET STG=$GET(^DD(FILE,FLD,0))
IF '$LENGTH(STG)
QUIT
+2 SET %=$PIECE(STG,U,2)
+3 ; EXCLUDE ALL MULTIPLE FIELDS EXCEPT WORD PROCESSING FIELDS
IF %
IF $PIECE($GET(^DD(%,.01,0)),U,2)'["W"
QUIT
+4 SET WP=0
IF %
SET WP=1
+5 SET NAME=$PIECE(STG,U)
+6 SET SS=FLD
+7 IF $GET(MODE)=1
SET %=NAME
IF $EXTRACT(%)="*"
SET %=$EXTRACT(%,2,99)
SET SS=%
+8 SET ARR(SS)=FLD_U_NAME_U_WP
+9 QUIT
End DoDot:1
F2 SET SS=""
+1 FOR
SET SS=$ORDER(ARR(SS))
IF SS=""
QUIT
Begin DoDot:1
+2 SET TOT=TOT+1
+3 SET %=ARR(SS)
+4 SET OUT(TOT)=$PIECE(%,U,2)_" ["_+%_"]"_$SELECT($PIECE(%,U,3):" (word processing)",1:"")
+5 KILL ARR(SS)
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
