DICF4 ;SEA/TOAD,SF/TKW-VA FileMan: Finder, (pointer indexes) ;15NOV2012
;;22.0;VA FileMan;**4,31,165,169**;Mar 30, 1999;Build 28
;Per VHA Directive 2004-038, 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
NUM ..;I +$P(DIPVAL(1),"E")=DIPVAL(1),$G(DINDEX)'="B",DIFLAGS["M" Q ;GFT PATCH 165 DO NOT LOOK UP POINTERS; DI*22*169 (mko): Commented out this line to allow the use of indexes on the pointed-to file
. . 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
;
DICF4 ;SEA/TOAD,SF/TKW-VA FileMan: Finder, (pointer indexes) ;15NOV2012
+1 ;;22.0;VA FileMan;**4,31,165,169**;Mar 30, 1999;Build 28
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
POINT(DIFILE,DIFLAGS,DINDEX,DIDENT,DIEN,DIFIEN,DISCREEN,DIVALUE,DIC,DIFORCE) ;
+1 ; PREPIX^DICF2--transform value for indexed pointer field
+2 NEW DIF,DIFL,DIX,DIPVAL,DISCR,DITARGET,DISKIP,DIPRV,DINEW
+3 SET DIF=$TRANSLATE(DIFLAGS,$TRANSLATE(DIFLAGS,"4XOB"))_"Mp"
SET DIX="B"
+4 IF DIFLAGS["B"
SET DIF=$TRANSLATE(DIF,"M")
+5 DO GETTMP^DICUIX1(.DITARGET,"DICF")
+6 SET DITARGET("C")=0
+7 SET (DIPRV,DINEW)="S"
FOR
SET DINEW=$ORDER(DISCREEN(DINEW))
IF $EXTRACT(DINEW)'="S"
QUIT
SET DIPRV=DINEW
SET DISCR(DIPRV)=DISCREEN(DIPRV)
+8 SET DINEW="S"_($PIECE(DIPRV,"S",2)+1)
P1 ; Process regular pointer
+1 IF DINDEX(1,"TYPE")="P"
Begin DoDot:1
+2 SET DIFL=+$PIECE($PIECE(DINDEX(1,"NODE"),U,2),"P",2)
IF 'DIFL
QUIT
+3 MERGE DIPVAL(1)=DIVALUE(1),DISCR(1)=DISCREEN(1)
+4 IF DIFLAGS["l"
DO DIC(.DIC,.DIEN,.DIFILE,.DINDEX,.DIVALUE,DITARGET)
+5 IF DIFLAGS'["l"
Begin DoDot:2
NUM ;I +$P(DIPVAL(1),"E")=DIPVAL(1),$G(DINDEX)'="B",DIFLAGS["M" Q ;GFT PATCH 165 DO NOT LOOK UP POINTERS; DI*22*169 (mko): Commented out this line to allow the use of indexes on the pointed-to file
+1 IF $DATA(DIFORCE("PTRIX"))
DO SETIX(.DIFORCE,.DINDEX,.DIX,.DIF)
+2 NEW F
SET F=DIF
NEW DIF
SET DIF=F
KILL F
MERGE DIFL("CHAIN")=DIFILE("CHAIN")
+3 DO BLDSCR(.DISCR,DINEW,DIPRV,.DIFL,.DINDEX,.DISCREEN,.DIFILE)
+4 DO FIND^DICF(.DIFL,",","",DIF,.DIPVAL,"",.DIX,.DISCR,"",.DITARGET)
End DoDot:2
+5 IF $GET(DIERR)!('$GET(@DITARGET))
KILL @DITARGET
QUIT
+6 SET DINDEX(1,"IXROOT")=DINDEX(1,"ROOT")
SET DINDEX(1,"ROOT")=$NAME(@DITARGET@("B"))
+7 QUIT
End DoDot:1
QUIT
P2 ; Process variable pointer
+1 IF DIFLAGS["l"
Begin DoDot:1
+2 DO DIC(.DIC,.DIEN,.DIFILE,.DINDEX,.DIVALUE,DITARGET)
+3 IF $GET(DIERR)!('$GET(@DITARGET))
KILL @DITARGET
QUIT
+4 SET DINDEX(1,"IXROOT")=DINDEX(1,"ROOT")
SET DINDEX(1,"ROOT")=$NAME(@DITARGET@("B"))
+5 QUIT
End DoDot:1
QUIT
+6 NEW DIFILES
IF DIVALUE(1)["."
IF $PIECE(DIVALUE(1),".")]""
Begin DoDot:1
+7 NEW V
SET V=$$OUT^DIALOGU($PIECE(DIVALUE(1),"."),"UC")
+8 DO VPFILES^DIEV1(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),V,.DIFILES)
+9 QUIT
End DoDot:1
P21 DO P3
IF $GET(DIERR)
KILL @DITARGET
QUIT
+1 IF $ORDER(DIFILES(0))
IF '$GET(@DITARGET)
KILL DIFILES
DO P3
+2 IF $GET(DIERR)!('$GET(@DITARGET))
KILL @DITARGET
QUIT
+3 SET DINDEX(1,"IXROOT")=DINDEX(1,"ROOT")
SET DINDEX(1,"ROOT")=$NAME(@DITARGET@("B"))
+4 QUIT
+5 ;
P3 NEW DIVP,G,I,X,DIF1,DIS1
+1 FOR DIVP=0:0
SET DIVP=$ORDER(^DD(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),"V",DIVP))
IF 'DIVP
QUIT
SET X=$GET(^(DIVP,0))
Begin DoDot:1
+2 KILL DIF1,DIFL,DIPVAL,DIS1,DIX
SET DIX="B"
+3 IF 'X
QUIT
IF $ORDER(DIFILES(0))
IF '$DATA(DIFILES(+X))
QUIT
+4 IF $GET(DISCREEN("V",1))]""
Begin DoDot:2
+5 SET G=$GET(^DIC(+X,0,"GL"))
IF G=""
QUIT
+6 IF '$DATA(DINDEX(DISUB,"VP",G))
SET G=""
QUIT
End DoDot:2
IF G=""
QUIT
+7 SET DIF1=DIF_"v"
SET DIFL=+X
+8 IF $DATA(DIFORCE("PTRIX"))
DO SETIX(.DIFORCE,.DINDEX,.DIX,.DIF1)
+9 DO FILE^DICUF(.DIFL,"",.DIF1)
IF $GET(DIERR)
QUIT
+10 MERGE DIS1=DISCR
+11 IF '$ORDER(DIFILES(0))
MERGE DIPVAL(1)=DIVALUE(1),DIS1(1)=DISCREEN(1)
+12 IF '$TEST
Begin DoDot:2
+13 SET DIF1=DIF1_"t"
+14 SET DIPVAL(1)=$PIECE(DIVALUE(1),".",2,99)
+15 QUIT
End DoDot:2
+16 MERGE DIFL("CHAIN")=DIFILE("CHAIN")
+17 DO BLDSCR(.DIS1,DINEW,DIPRV,.DIFL,.DINDEX,.DISCREEN,.DIFILE)
+18 SET DITARGET("C")=+$GET(@DITARGET)
+19 DO FIND^DICF(.DIFL,",","",DIF1,.DIPVAL,"",.DIX,.DIS1,"",.DITARGET)
+20 QUIT
End DoDot:1
IF $GET(DIERR)
QUIT
+21 QUIT
+22 ;
SETIX(DIFORCE,DINDEX,DIX,DIF) ; If user passes list of indexes to use on pointed-to file, set up to use them.
+1 MERGE DIX("PTRIX")=DIFORCE("PTRIX")
NEW %
+2 SET %=$GET(DIX("PTRIX",DINDEX(1,"FILE"),DINDEX(1,"FIELD"),DIFL))
+3 IF %=""
QUIT
SET DIX=%
+4 IF $PIECE(DIX,U,2)=""
IF DIF["M"
SET DIF=$TRANSLATE(DIF,"M")
QUIT
+5 IF DIF'["M"
SET DIF=DIF_"M"
QUIT
+6 ;
BLDSCR(DISCR,DINEW,DIPRV,DIFL,DINDEX,DISCREEN,DIFILE) ; Build screen to make sure entry is in pointer index.
+1 NEW DICSUBS
SET DICSUBS=""
+2 SET DISCR(DINEW)=$SELECT(DIPRV="S":" Q",1:" "_DISCREEN("S")_" Q:$T")
+3 NEW I
SET I="I"
IF DINDEX(1,"TYPE")["V"
SET I=I_"_"";"_$PIECE(DIFL(DIFL,"O"),U,2)_""""
+4 SET DISCR("S")=DICSUBS_"N "_DINEW_" S "_DINEW_"="_I_" X DISCREEN("""_DINEW_""")"
+5 IF DINDEX("#")>1
Begin DoDot:1
+6 SET DISCR(DINEW)="X ""I 0"" I $D("_DIFILE(DIFILE,"O")_""""_DINDEX_""","_DINEW_"))"_DISCR(DINEW)
+7 QUIT
End DoDot:1
QUIT
+8 SET 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)
+9 QUIT
+10 ;
SETDA(DIEN) ; Return code that sets DA array to current level when pointer field is in a multiple. DA itself=DA(1).
+1 NEW %,DICODE
SET DICODE="S DA="_+$GET(DIEN(1))
+2 FOR %=1:1
IF '$DATA(DIEN(%))
QUIT
SET DICODE=DICODE_",DA("_%_")="_DIEN(%)
+3 QUIT DICODE
+4 ;
DIC(DIC,DIEN,DIFILE,DINDEX,DIVALUE,DITARGET) ; If we were called from ^DIC, we want to do recursive lookup there.
+1 NEW %,%Y,D,DD,DIVAL,DF,DID,DINUM,DICRS,DS,DO,X,Y,DIFINDER
+2 SET DO(2)=DIFILE
SET (D,DF)=DINDEX("START")
SET (X,DIVAL(1))=DIVALUE(1)
SET DIVAL(0)=1
+3 SET DD=0
SET %=DINDEX
SET DS=$GET(^DD(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),0))
SET Y=DINDEX(1,"TYPE")
SET %Y=DINDEX(1,"FIELD")
+4 IF $GET(DICR)=""
SET DICR=0
+5 Begin DoDot:1
+6 NEW DIFILE,I
+7 SET DIFINDER="p"
+8 MERGE I=DIC
NEW DIC
MERGE DIC=I
KILL I
+9 NEW DA
XECUTE $$SETDA(.DIEN)
NEW DIEN
+10 DO A^DICM
IF Y=-1
QUIT
DO ^DICM1
KILL DICR(DICR)
SET DICR=DICR-1
IF DICR<1
KILL DICR
+11 QUIT
End DoDot:1
+12 IF Y'>0
QUIT
+13 SET @DITARGET@("B",($PIECE(Y,U,2)_U_X))=""
SET @DITARGET=1
+14 QUIT
+15 ;
ERR(DIERN,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3) ;
+1 ; error logging procedure
+2 NEW DIPE
+3 NEW DI
FOR DI="FILE","IENS","FIELD",1:1:3
SET DIPE(DI)=$GET(@("DI"_DI))
+4 DO BLD^DIALOG(DIERN,.DIPE,.DIPE)
+5 QUIT
+6 ;
