71 lines
2.7 KiB
Mathematica
71 lines
2.7 KiB
Mathematica
|
DICU11 ;SEA/TOAD,SF/TKW-VA FileMan: Lookup Tools, Get IDs & Index ;11/5/99 15:13
|
||
|
|
;;22.0;VA FileMan;**17**;Mar 30, 1999
|
||
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
||
|
|
;
|
||
|
|
; Routines called from DICU1
|
||
|
|
;
|
||
|
|
THROW(DIFLAGS,DIDENT,DIDS,DICRSR,DICOUNT,DIDEFALT,DINDEX,DICF2) ;
|
||
|
|
;
|
||
|
|
; Build code into DIDENT array to get external field values
|
||
|
|
; for indexed fields.
|
||
|
|
;
|
||
|
|
T1 N DIFORMAT D GETFORM(.DIDENT,.DIFORMAT,.DIDS,.DICOUNT)
|
||
|
|
I DIFORMAT="" S DIFORMAT=DIDEFALT
|
||
|
|
N DIEXP,DISUB,DISUB0,DIMAP S DISUB0=$S(DIDENT["IX":0,1:DIDENT)
|
||
|
|
F DISUB=1:1:DINDEX("#") D
|
||
|
|
. S DIEXP="DINDEX(DISUB)"
|
||
|
|
. I DIFORMAT="I",DIFLAGS[3,"VP"[DINDEX(DISUB,"TYPE") D
|
||
|
|
. . I DISUB>1 S DIEXP="DIVAL" Q
|
||
|
|
. . Q:'$D(DINDEX("ROOTCNG",1))
|
||
|
|
. . S DIEXP="$G(@DINDEX(1,""ROOT"")@(DINDEX(1)))" Q
|
||
|
|
. I DIFORMAT="E",$G(DINDEX(DISUB,"GETEXT")) D
|
||
|
|
. . I DISUB>1,DIFLAGS[4,"VP"[DINDEX(DISUB,"TYPE") S DIEXP="DINDEX(DISUB,""EXT"")" Q
|
||
|
|
. . I DINDEX(DISUB,"GETEXT")=3 S DIEXP="$$TRANOUT(DISUB,"_DIEXP_")" Q
|
||
|
|
. . S:DINDEX(DISUB,"GETEXT")=2 DIEXP="DIVAL"
|
||
|
|
. . S DIEXP=$$FORMAT(DIDENT,DIEXP,0,DIFORMAT,DIDEFALT,DIFLAGS)
|
||
|
|
. . I DINDEX="B" S DIEXP="$S('$D(DIMNEM):"_DIEXP_",1:DINDEX(DISUB))"
|
||
|
|
. . Q
|
||
|
|
. I $G(DICF2) S DIDENT(DICRSR,DISUB0,DISUB,DIFORMAT)=DIEXP Q
|
||
|
|
. I DIFLAGS["P" S DICRSR=DICRSR+1
|
||
|
|
. S DIDENT(DICRSR,DISUB0,DISUB,DIFORMAT)=DIEXP
|
||
|
|
. S DIMAP="IX("_DISUB_")" S:DIFORMAT="I" DIMAP=DIMAP_"I"
|
||
|
|
. I DIFLAGS["P" S $P(DIDENT(-3),U,DICRSR)=DIMAP Q
|
||
|
|
. I DIDENT'=-2 S DIDENT(-3,0,DISUB,DIMAP)=""
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
GETFORM(DIDENT,DIFORMAT,DIDS,DICOUNT) ;
|
||
|
|
; Strip E or I off specifier and set into DIFORMAT
|
||
|
|
N DILENGTH S DILENGTH=$L(DIDENT)
|
||
|
|
S DIFORMAT=$E(DIDENT,DILENGTH)
|
||
|
|
I $TR(DIFORMAT,"EI")="" D
|
||
|
|
. N DIFIRST S DIFIRST=$E(DIDENT,DILENGTH-1) I $TR(DIFIRST,"EI")="" D Q
|
||
|
|
. . S $E(DIDENT,DILENGTH-1)="",$P(DIDS,";",DICOUNT)=DIDENT
|
||
|
|
. . S DIFORMAT=DIFIRST,DICOUNT=DICOUNT-1
|
||
|
|
. . S $E(DIDENT,DILENGTH-1)=""
|
||
|
|
. S $E(DIDENT,DILENGTH)=""
|
||
|
|
E S DIFORMAT=""
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
FORMAT(DIFIELD,DICODE,DIUSEKEY,DIFORMAT,DIDEFALT,DIFLAGS) ;
|
||
|
|
; Format fetch code to return either internal or external
|
||
|
|
N DIFILE S DIFILE="DIFILE"
|
||
|
|
I DIFIELD'>0 S DIFILE="DINDEX(DISUB,""FILE"")",DIFIELD="DINDEX(DISUB,""FIELD"")"
|
||
|
|
I DIFORMAT="E" D
|
||
|
|
. N F S F="""""" I DIFLAGS["h" S F="""h"""
|
||
|
|
. S DICODE="$$EXTERNAL^DIDU("_DIFILE_","_DIFIELD_","_F_","_DICODE_")"
|
||
|
|
Q DICODE
|
||
|
|
;
|
||
|
|
WRITEID(DIFILE,DIDENT,DICRSR) ;
|
||
|
|
; WRITE Identifiers Loop: add WRITE identifiers to output processor:
|
||
|
|
; for WRITE IDs we save the code as is
|
||
|
|
;
|
||
|
|
N DICODE
|
||
|
|
S DIDENT=$O(^DD(DIFILE,0,"ID"," "),-1),DIDENT=$O(^(DIDENT))
|
||
|
|
F Q:DIDENT="" D S DIDENT=$O(^DD(DIFILE,0,"ID",DIDENT))
|
||
|
|
. S DICODE=$G(^DD(DIFILE,0,"ID",DIDENT)) Q:DICODE=""
|
||
|
|
. I DIFLAGS["P" S DICRSR=DICRSR+1
|
||
|
|
. S DIDENT(DICRSR,DIDENT,0)="N DIMSG "_DICODE
|
||
|
|
. S:DIFLAGS["P" $P(DIDENT(-3),U,DICRSR)="WID("_DIDENT_")" Q
|
||
|
|
Q
|
||
|
|
;
|