88 lines
2.8 KiB
Mathematica
88 lines
2.8 KiB
Mathematica
DICU ;SEA/TOAD-VA FileMan: Lookup Utilities ;5/15/97 08:31
|
|
;;22.0;VA FileMan;;Mar 30, 1999
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
;11961;3150917;2853;
|
|
;
|
|
REQIDS(DIFILE,DITARGET) ;
|
|
; return REQUIRED IDENTIFIERS file attribute
|
|
; DIFILE = file#, DITARGET = target array
|
|
N DIATTRBT S DIATTRBT="REQUIRED IDENTIFIERS"
|
|
S @DITARGET@(DIATTRBT,.01)=""
|
|
N DIFIELD
|
|
S DIFIELD=0 F S DIFIELD=$O(^DD(DIFILE,0,"ID",DIFIELD)) Q:'DIFIELD D
|
|
. I $D(^DD(DIFILE,"RQ",DIFIELD)) S @DITARGET@(DIATTRBT,DIFIELD)=""
|
|
Q
|
|
;
|
|
RID(DIFILE) ;
|
|
; return a string listing a file's required identifiers
|
|
; DIFILE = file#
|
|
N DILIST S DILIST=".01"
|
|
N DID S DID="" F S DID=$O(^DD(DIFILE,0,"ID",DID)) Q:'DID D
|
|
. I $D(^DD(DIFILE,"RQ",DID)) S DILIST=DILIST_U_DID
|
|
Q DILIST
|
|
;
|
|
RECALL(DIFILE,DIEN,DIUSER) ;
|
|
RECALLX ; input from DILFD
|
|
;
|
|
; ENTRY POINT--save a user's selection for use with space-bar recall
|
|
; procedure, all passed by value
|
|
;
|
|
I '$D(DIQUIET) N DIQUIET S DIQUIET=1
|
|
I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
|
|
N DICLERR S DICLERR=$G(DIERR) K DIERR
|
|
;
|
|
30 S DIFILE=$G(DIFILE)
|
|
I +DIFILE'=DIFILE!(DIFILE<0) D ERR(202,"","","","file") Q
|
|
S DIEN=$G(DIEN) I DIEN="" S DIEN=","
|
|
I '$$IEN^DIDU1(DIEN) D ERR(202,"","","","IEN string") Q
|
|
S DIUSER=+$G(DIUSER)
|
|
;
|
|
32 N DIOROOT,DIOUT S DIOUT=0 D I DIOUT Q
|
|
. I '$D(^DD(DIFILE)) D ERR(401,DIFILE) S DIOUT=1 Q
|
|
. S DIOROOT=$$ROOT^DILFD(DIFILE,DIEN,"Q")
|
|
. I DIOROOT'?1"^"1U.7UN1"(".ANP,DIOROOT'?1"^%".7UN1"(".ANP D Q
|
|
. . D ERR(402,DIFILE,"","","","","",DIOROOT) S DIOUT=1
|
|
S ^DISV(DIUSER,$E(DIOROOT,1,28))=$E(DIOROOT,29,$L(DIOROOT))_+DIEN
|
|
I DICLERR'=""!$G(DIERR) D
|
|
. S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2))
|
|
Q
|
|
;
|
|
FILE(DIFILE,DIDA,DIFLAGS,DIROOT) ;
|
|
; entry point -- given a root, calculate the file # and DA
|
|
; DO NOT USE UNTIL $QS & $QL AVAILABLE
|
|
N DIGLOBAL I $G(DIFLAGS)'["O" S DIGLOBAL=DIROOT
|
|
E S DIGLOBAL=$$CREF^DIQGU(DIROOT),DIROOT=DIGLOBAL
|
|
S DIFILE=+$P($G(@DIGLOBAL@(0)),U,2),DIDA=""
|
|
N DA,DIENTRY S DA=1,DIENTRY=0
|
|
;
|
|
LOOP N DICHAR,DIL,DILEAD,DIQL,DIQS,DIQSL F D Q:'DIQL
|
|
.
|
|
STRIP .
|
|
. ; S DIQL=$QL(DIGLOBAL) Q:'DIQL
|
|
. ; S DIQS=$QS(DIGLOBAL,DIQL)
|
|
. N DIQSL S DIQSL=$L(DIQS)+1 I +DIQS'=DIQS S DIQSL=DIQSL+2
|
|
. S DIL=$L(DIGLOBAL),DILEAD=DIL-DIQSL
|
|
. S $E(DIGLOBAL,DILEAD+1,DIL-1)=""
|
|
. S DICHAR=$E(DIGLOBAL,DILEAD)
|
|
. I DICHAR="," S $E(DIGLOBAL,DILEAD)=""
|
|
. E I DICHAR="(" S $E(DIGLOBAL,DILEAD,DILEAD+1)=""
|
|
. E S DIGLOBAL="ERROR: "_DIGLOBAL,DIQL=0
|
|
.
|
|
ENTRY . I DIENTRY D
|
|
. . S DIFILE(DA)=+$P($G(@DIGLOBAL@(0)),U,2)
|
|
. . S DIROOT(DA)=DIGLOBAL
|
|
. . S DIDA(DA)=DIQS,DA=DA+1
|
|
. S DIENTRY='DIENTRY
|
|
Q
|
|
;
|
|
ERR(DIERN,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3,DIROOT) ;
|
|
;
|
|
; error logging procedure
|
|
; RECALL
|
|
;
|
|
N DIPE,DI
|
|
F DI="FILE","IENS","FIELD",1:1:3,"ROOT" S DIPE(DI)=$G(@("DI"_DI))
|
|
D BLD^DIALOG(DIERN,.DIPE,.DIPE)
|
|
S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2))
|
|
Q
|