118 lines
4.7 KiB
Mathematica
118 lines
4.7 KiB
Mathematica
DICF1 ;SEA/TOAD,SF/TKW-VA FileMan: Finder, Part 2 (Transform) ;1:36 PM 6 May 2004
|
|
;;22.0;VA FileMan;**15,51,70,135**;Mar 30, 1999
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
;
|
|
XFORM(DIFLAGS,DIVALUE,DISCREEN,DINDEX) ;
|
|
; FIND--produce array of values and screens by transforming input
|
|
; subroutine, DIVALUE, DINDEX, & DISCREEN passed by reference
|
|
N DISUB F DISUB=1:1:DINDEX("#") D VALUES
|
|
Q
|
|
VALUES ; Set original lookup value into array.
|
|
I $D(DIVALUE(DISUB,0,1)) S DIVALUE(DISUB)=DIVALUE(DISUB,0,1)
|
|
N I F I="PART","FROM","TO" I $D(DIVALUE(DISUB,0,1,I)) D
|
|
. S DINDEX(DISUB,I)=DIVALUE(DISUB,0,1,I) Q
|
|
D
|
|
. S I=-1 F S I=$O(DIVALUE(DISUB,I)) Q:I="" K DIVALUE(DISUB,I)
|
|
. S I=-1 F S I=$O(DISCREEN(DISUB,I)) Q:I="" K DISCREEN(DISUB,I)
|
|
. Q
|
|
S DIVALUE(DISUB,1)=DIVALUE(DISUB)
|
|
Q:DIVALUE(DISUB)=""
|
|
I DIFLAGS["Q" D LONG Q
|
|
LOWER ;
|
|
I DIVALUE(DISUB)?.E1L.E,DIFLAGS'["X" D
|
|
. S DIVALUE(DISUB,2)=$$OUT^DIALOGU(DIVALUE(DISUB),"UC")
|
|
. Q
|
|
;
|
|
CHK ; Quit if data type not free-text, pointer or vp, or if lookup value is numeric or a date.
|
|
I "PVF"'[$G(DINDEX(DISUB,"TYPE"))!(DIVALUE(DISUB)?.NP) Q
|
|
N Y D Q:Y>0
|
|
. N X S X=DIVALUE(DISUB) N %DT,DIFLAGS,DIVALUE,DISCREEN,DINDEX,DISUB
|
|
. S %DT="T" D ^%DT Q
|
|
COMMA I DIVALUE(DISUB)[",",DIFLAGS'["X" D
|
|
. N DISTEMP,DIPIECE1 S DISTEMP="",DIPIECE1=$P(DIVALUE(DISUB),",")
|
|
. Q:$L(DIPIECE1)>DINDEX(DISUB,"LENGTH")
|
|
. Q:'$L(DIPIECE1) ;SO
|
|
21 . I DIFLAGS["C" D
|
|
. . N DIPART1 S DIPART1=" I %?.E1P1"""
|
|
. . N DIPART2 S DIPART2=""".E!(D'=""B""&(%?1"""
|
|
. . N DIPART3 S DIPART3=""".E))"
|
|
. . N DIOUT S DIOUT=0
|
|
. . N DIPIECE,DIVPIECE F DIPIECE=2:1 D I DIOUT Q
|
|
. . . S DIVPIECE=$P(DIVALUE(DISUB),",",DIPIECE)
|
|
. . . I DIVPIECE["""" Q
|
|
. . . I $E(DIVPIECE)=" " S DIVPIECE=$E(DIVPIECE,2,$L(DIVPIECE))
|
|
. . . I DIVPIECE="" S DIOUT=1 Q
|
|
. . . I $L(DIVPIECE)*2+$L(DISTEMP)+33+14+34>255 S DIOUT=1 Q
|
|
. . . S DISTEMP=DISTEMP_DIPART1_DIVPIECE_DIPART2_DIVPIECE_DIPART3
|
|
. . . Q:DISTEMP=""
|
|
. . . S DISTEMP="S %=DIVAL "_DISTEMP Q ;22*135
|
|
. . I DISTEMP="" Q
|
|
22 . I DIFLAGS'["C" N DIPIECE2,DIPC2 D
|
|
. . S (DIPC2,DIPIECE2)=$P(DIVALUE(DISUB),",",2)
|
|
. . I DIPIECE2["""" S DIPC2=$$CONVQQ^DILIBF(DIPIECE2)
|
|
. . S DISTEMP="S %=$P(DIVAL,"","",2) I $E(%,1,"_$L(DIPIECE2)_")="""_DIPC2_""""
|
|
. . Q
|
|
23 . S DIVALUE(DISUB,3)=DIPIECE1
|
|
. S DISCREEN(DISUB,3)=DISTEMP
|
|
. I DIFLAGS'["C" S DIVALUE(DISUB,3,"c")=DIPIECE2
|
|
24 . I DIVALUE(DISUB)'?.E1L.E Q
|
|
. S DIVALUE(DISUB,4)=$$OUT^DIALOGU(DIPIECE1,"UC")
|
|
. S DISCREEN(DISUB,4)=$$OUT^DIALOGU(DISTEMP,"UC")
|
|
. I DIFLAGS'["C" S DIVALUE(DISUB,4,"c")=$$OUT^DIALOGU(DIPIECE2,"UC")
|
|
;
|
|
LONG I $L(DIVALUE(DISUB))'>DINDEX(DISUB,"LENGTH") Q
|
|
N J,X,DISLONG,DISPART,DISXACT,DIREF
|
|
F I=0:0 S I=$O(DIVALUE(DISUB,I)) Q:'I D
|
|
. N L,M S L=DINDEX(DISUB,"LENGTH")
|
|
. Q:$L(DIVALUE(DISUB,I))'>L
|
|
. S X=DIVALUE(DISUB,I) K DIVALUE(DISUB,I) S DIVALUE(DISUB,0,I)=X
|
|
. I $G(DISCREEN(DISUB,I))]"" S X=DISCREEN(DISUB,I) K DISCREEN(DISUB,I) S DISCREEN(DISUB,0,I)=X
|
|
. S DIVALUE(DISUB,I)=$E(DIVALUE(DISUB,0,I),1,L)
|
|
. I I=1 D
|
|
. . S (DIVALUE(DISUB),DINDEX(DISUB))=DIVALUE(DISUB,I)
|
|
. . F J="PART","FROM","TO" S M=$L($G(DINDEX(DISUB,J))) D:M>L
|
|
. . . S DIVALUE(DISUB,0,I,J)=DINDEX(DISUB,J)
|
|
. . . S DINDEX(DISUB,J)=$E(DINDEX(DISUB,J),1,L) Q
|
|
. . Q
|
|
. S DISLONG=""
|
|
. I $D(DISCREEN(DISUB,0,I)) S DISLONG=" X DISCREEN("_DISUB_",0,"_I_")"
|
|
. S DIREF="DINDEX("_DISUB_",0,"_I_")"
|
|
. S DISPART="I $P(DIVAL,$G("_DIREF_"))="""""_DISLONG ;DI*22*70
|
|
. S DISXACT="I $P(DIVAL,U)="_DIREF_DISLONG
|
|
L10 . I DIFLAGS["X" S DISCREEN(DISUB,I)=DISXACT Q
|
|
. I DIFLAGS'["O" S DISCREEN(DISUB,I)=DISPART Q
|
|
. S DISCREEN(DISUB,I)=DISXACT
|
|
. S DISCREEN(DISUB,I,2)=DISPART
|
|
. Q
|
|
Q
|
|
;
|
|
SPECIAL(DIFILE,DIEN,DIFIEN,DIFLAGS,DIVALUE,DINDEX,DISCREEN,DIDENT,DIOUT,DILIST) ;
|
|
; Process space-bar return, 'IEN or DIVALUE equal to an IEN.
|
|
S DIOUT=0
|
|
11 I DIVALUE=" " D S DIOUT=1 Q
|
|
. N DIROOT S DIROOT=$$ROOT^DIQGU(DIFILE,DIFIEN,"Q")
|
|
. N DINODE S DINODE=$G(^DISV(DUZ,$E(DIROOT,1,28)))
|
|
. N DINODEL S DINODEL=$L(DINODE,",")
|
|
. I $P(DINODE,",",1,DINODEL-1)'=$E(DIROOT,29,9999) Q
|
|
. S DIEN=$P(DINODE,",",DINODEL)
|
|
. I 'DIEN S DIEN="" Q
|
|
. D ENTRY Q
|
|
12 I DIVALUE?1"`".NP D Q:DIOUT=1
|
|
. S DIEN=$E(DIVALUE,2,$L(DIVALUE)) Q:+DIEN'=DIEN
|
|
. D ENTRY S DIOUT=1 Q
|
|
13 I $S(DIVALUE?1.N:1,DIVALUE'?.NP:0,1:+DIVALUE=DIVALUE) D
|
|
. N DI001 S DI001=$D(^DD(DIFILE,.001))
|
|
. N DI01FLAG S DI01FLAG=$P($G(^DD(DIFILE,.01,0)),U,2)
|
|
. I $D(@DIFILE(DIFILE)@(DIVALUE)) D
|
|
. . I DIFLAGS'["A",'DI001,DI01FLAG["N"!($O(@DIFILE(DIFILE)@("A["))'="") Q
|
|
. . S DIEN=DIVALUE
|
|
. . D ENTRY
|
|
. . I $G(DINDEX("DONE"))!($G(DIERR)) S DIEN="",DIOUT=1
|
|
Q
|
|
;
|
|
ENTRY ; Execute screens, and if entry passes, do ACCEPT to add it to output.
|
|
N DI0NODE S DI0NODE=$G(@DIFILE(DIFILE)@(DIEN,0))
|
|
Q:$$SCREEN^DICL2(.DIFILE,.DIEN,DIFLAGS,DIFIEN,.DISCREEN,.DINDEX,DI0NODE)
|
|
D ACCEPT^DICL2(.DIFILE,.DIEN,.DIFLAGS,DIFIEN,.DINDEX,.DIDENT,.DILIST,DI0NODE)
|
|
Q
|