112 lines
4.6 KiB
Mathematica
112 lines
4.6 KiB
Mathematica
DICF4 ;SEA/TOAD,SF/TKW-VA FileMan: Finder, (pointer indexes) ;2/16/00 13:31
|
|
;;22.0;VA FileMan;**4,31**;Mar 30, 1999
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
;
|
|
POINT(DIFILE,DIFLAGS,DINDEX,DIDENT,DIEN,DIFIEN,DISCREEN,DIVALUE,DIC,DIFORCE) ;
|
|
; PREPIX^DICF2--transform value for indexed pointer field
|
|
N DIF,DIFL,DIX,DIPVAL,DISCR,DITARGET,DISKIP,DIPRV,DINEW
|
|
S DIF=$TR(DIFLAGS,$TR(DIFLAGS,"4XOB"))_"Mp",DIX="B"
|
|
I DIFLAGS["B" S DIF=$TR(DIF,"M")
|
|
D GETTMP^DICUIX1(.DITARGET,"DICF")
|
|
S DITARGET("C")=0
|
|
S (DIPRV,DINEW)="S" F S DINEW=$O(DISCREEN(DINEW)) Q:$E(DINEW)'="S" S DIPRV=DINEW,DISCR(DIPRV)=DISCREEN(DIPRV)
|
|
S DINEW="S"_($P(DIPRV,"S",2)+1)
|
|
P1 ; Process regular pointer
|
|
I DINDEX(1,"TYPE")="P" D Q
|
|
. S DIFL=+$P($P(DINDEX(1,"NODE"),U,2),"P",2) Q:'DIFL
|
|
. M DIPVAL(1)=DIVALUE(1),DISCR(1)=DISCREEN(1)
|
|
. I DIFLAGS["l" D DIC(.DIC,.DIEN,.DIFILE,.DINDEX,.DIVALUE,DITARGET)
|
|
. I DIFLAGS'["l" D
|
|
. . I $D(DIFORCE("PTRIX")) D SETIX(.DIFORCE,.DINDEX,.DIX,.DIF)
|
|
. . N F S F=DIF N DIF S DIF=F K F M DIFL("CHAIN")=DIFILE("CHAIN")
|
|
. . D BLDSCR(.DISCR,DINEW,DIPRV,.DIFL,.DINDEX,.DISCREEN,.DIFILE)
|
|
. . D FIND^DICF(.DIFL,",","",DIF,.DIPVAL,"",.DIX,.DISCR,"",.DITARGET)
|
|
. I $G(DIERR)!('$G(@DITARGET)) K @DITARGET Q
|
|
. S DINDEX(1,"IXROOT")=DINDEX(1,"ROOT"),DINDEX(1,"ROOT")=$NA(@DITARGET@("B"))
|
|
. Q
|
|
P2 ; Process variable pointer
|
|
I DIFLAGS["l" D Q
|
|
. D DIC(.DIC,.DIEN,.DIFILE,.DINDEX,.DIVALUE,DITARGET)
|
|
. I $G(DIERR)!('$G(@DITARGET)) K @DITARGET Q
|
|
. S DINDEX(1,"IXROOT")=DINDEX(1,"ROOT"),DINDEX(1,"ROOT")=$NA(@DITARGET@("B"))
|
|
. Q
|
|
N DIFILES I DIVALUE(1)[".",$P(DIVALUE(1),".")]"" D
|
|
. N V S V=$$OUT^DIALOGU($P(DIVALUE(1),"."),"UC")
|
|
. D VPFILES^DIEV1(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),V,.DIFILES)
|
|
. Q
|
|
P21 D P3 I $G(DIERR) K @DITARGET Q
|
|
I $O(DIFILES(0)),'$G(@DITARGET) K DIFILES D P3
|
|
I $G(DIERR)!('$G(@DITARGET)) K @DITARGET Q
|
|
S DINDEX(1,"IXROOT")=DINDEX(1,"ROOT"),DINDEX(1,"ROOT")=$NA(@DITARGET@("B"))
|
|
Q
|
|
;
|
|
P3 N DIVP,G,I,X,DIF1,DIS1
|
|
F DIVP=0:0 S DIVP=$O(^DD(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),"V",DIVP)) Q:'DIVP S X=$G(^(DIVP,0)) D Q:$G(DIERR)
|
|
. K DIF1,DIFL,DIPVAL,DIS1,DIX S DIX="B"
|
|
. Q:'X I $O(DIFILES(0)) Q:'$D(DIFILES(+X))
|
|
. I $G(DISCREEN("V",1))]"" D Q:G=""
|
|
. . S G=$G(^DIC(+X,0,"GL")) Q:G=""
|
|
. . S:'$D(DINDEX(DISUB,"VP",G)) G="" Q
|
|
. S DIF1=DIF_"v",DIFL=+X
|
|
. I $D(DIFORCE("PTRIX")) D SETIX(.DIFORCE,.DINDEX,.DIX,.DIF1)
|
|
. D FILE^DICUF(.DIFL,"",.DIF1) Q:$G(DIERR)
|
|
. M DIS1=DISCR
|
|
. I '$O(DIFILES(0)) M DIPVAL(1)=DIVALUE(1),DIS1(1)=DISCREEN(1)
|
|
. E D
|
|
. . S DIF1=DIF1_"t"
|
|
. . S DIPVAL(1)=$P(DIVALUE(1),".",2,99)
|
|
. . Q
|
|
. M DIFL("CHAIN")=DIFILE("CHAIN")
|
|
. D BLDSCR(.DIS1,DINEW,DIPRV,.DIFL,.DINDEX,.DISCREEN,.DIFILE)
|
|
. S DITARGET("C")=+$G(@DITARGET)
|
|
. D FIND^DICF(.DIFL,",","",DIF1,.DIPVAL,"",.DIX,.DIS1,"",.DITARGET)
|
|
. Q
|
|
Q
|
|
;
|
|
SETIX(DIFORCE,DINDEX,DIX,DIF) ; If user passes list of indexes to use on pointed-to file, set up to use them.
|
|
M DIX("PTRIX")=DIFORCE("PTRIX") N %
|
|
S %=$G(DIX("PTRIX",DINDEX(1,"FILE"),DINDEX(1,"FIELD"),DIFL))
|
|
Q:%="" S DIX=%
|
|
I $P(DIX,U,2)="" S:DIF["M" DIF=$TR(DIF,"M") Q
|
|
S:DIF'["M" DIF=DIF_"M" Q
|
|
;
|
|
BLDSCR(DISCR,DINEW,DIPRV,DIFL,DINDEX,DISCREEN,DIFILE) ; Build screen to make sure entry is in pointer index.
|
|
N DICSUBS S DICSUBS=""
|
|
S DISCR(DINEW)=$S(DIPRV="S":" Q",1:" "_DISCREEN("S")_" Q:$T")
|
|
N I S I="I" S:DINDEX(1,"TYPE")["V" I=I_"_"";"_$P(DIFL(DIFL,"O"),U,2)_""""
|
|
S DISCR("S")=DICSUBS_"N "_DINEW_" S "_DINEW_"="_I_" X DISCREEN("""_DINEW_""")"
|
|
I DINDEX("#")>1 D Q
|
|
. S DISCR(DINEW)="X ""I 0"" I $D("_DIFILE(DIFILE,"O")_""""_DINDEX_""","_DINEW_"))"_DISCR(DINEW)
|
|
. Q
|
|
S DISCR(DINEW)="X ""I 0"" N I F I=0:0 S I=$O("_DIFILE(DIFILE,"O")_""""_DINDEX_""","_DINEW_",I)) Q:'I I $D("_DIFILE(DIFILE,"O")_"I,0))"_DISCR(DINEW)
|
|
Q
|
|
;
|
|
SETDA(DIEN) ; Return code that sets DA array to current level when pointer field is in a multiple. DA itself=DA(1).
|
|
N %,DICODE S DICODE="S DA="_+$G(DIEN(1))
|
|
F %=1:1 Q:'$D(DIEN(%)) S DICODE=DICODE_",DA("_%_")="_DIEN(%)
|
|
Q DICODE
|
|
;
|
|
DIC(DIC,DIEN,DIFILE,DINDEX,DIVALUE,DITARGET) ; If we were called from ^DIC, we want to do recursive lookup there.
|
|
N %,%Y,D,DD,DIVAL,DF,DID,DINUM,DICRS,DS,DO,X,Y,DIFINDER
|
|
S DO(2)=DIFILE,(D,DF)=DINDEX("START"),(X,DIVAL(1))=DIVALUE(1),DIVAL(0)=1
|
|
S DD=0,%=DINDEX,DS=$G(^DD(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),0)),Y=DINDEX(1,"TYPE"),%Y=DINDEX(1,"FIELD")
|
|
S:$G(DICR)="" DICR=0
|
|
D
|
|
. N DIFILE,I
|
|
. S DIFINDER="p"
|
|
. M I=DIC N DIC M DIC=I K I
|
|
. N DA X $$SETDA(.DIEN) N DIEN
|
|
. D A^DICM Q:Y=-1 D ^DICM1 K DICR(DICR) S DICR=DICR-1 I DICR<1 K DICR
|
|
. Q
|
|
Q:Y'>0
|
|
S @DITARGET@("B",($P(Y,U,2)_U_X))="",@DITARGET=1
|
|
Q
|
|
;
|
|
ERR(DIERN,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3) ;
|
|
; error logging procedure
|
|
N DIPE
|
|
N DI F DI="FILE","IENS","FIELD",1:1:3 S DIPE(DI)=$G(@("DI"_DI))
|
|
D BLD^DIALOG(DIERN,.DIPE,.DIPE)
|
|
Q
|
|
;
|