DICL10 ;SEA/TOAD,SF/TKW-VA FileMan: Lookup: Lister, Part 2 ;5/21/98 15:27
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
POINT(DIFILE,DIFLAGS,DINDEX,DIDENT,DIEN,DIFIEN,DISCREEN,DILIST) ;
; save off the primary file info, follow the ptr chain to the end
S DIFLAGS=DIFLAGS_"p"
N DIVPTR,DIF S DIVPTR=$S(DINDEX(1,"TYPE")="V":1,1:0)
M DIF=DIFILE N DIFILE M DIFILE=DIF K DIF
D FOLLOW^DICL3(.DIFILE,"",DINDEX(1,"NODE"),1,0,"",DINDEX(1,"FIELD"),DINDEX(1,"FILE"),DIVPTR,1,.DISCREEN)
D SETB^DICL3
N DIX1 S DIX1="B"
S DIX1("WAY")=DINDEX("WAY")
N DIFROM S DIFROM(1)=$G(DINDEX(1,"FROM")),DIFROM("IEN")=""
N DIPART S DIPART(1)=$G(DINDEX(1,"PART"))
S DIFILE("STACK")=1_U_DIFILE("STACKEND",1)
S DIFILE=$P(DIFILE("STACK"),U,3)
D INDEX^DICUIX(.DIFILE,.DIFLAGS,.DIX1,.DIFROM,.DIPART)
I $G(DINDEX(1,"USE")) S DIX1(1,"USE")=1
N I F I="FIELD","FILE","FROM","GET","TYPE" K DIX1(1,I)
K DIX1("FLIST")
P1 ; no variable pointers in pointer chain
I '$O(DIFILE("STACKEND",1)) D Q
. D WALK^DICLIX(DIFLAGS,.DIX1,.DIDENT,.DIFILE,.DIEN,.DIFIEN,.DISCREEN,.DILIST,.DINDEX,"",.DIC)
. Q
P2 ; variable pointer(s) in pointer chain
N DIXV
S DIFLAGS=DIFLAGS_"v",DIFILE("STACK")=""
S I=0 F S I=$O(DIFILE("STACKEND",I)) Q:'I D
. N DIXNAME,DISUB,R S DIXNAME="DIXV("_I_")",DISUB=DIX1(1)
. N DIFL,DIGL S DIFL=+$P(DIFILE("STACKEND",I),U,2),DIGL=DIFILE(DIFL,"O")
. S @DIXNAME@(1)=DISUB,@DIXNAME@(1,"MORE?")=DIX1(1,"MORE?"),@DIXNAME@(2)=""
. S R=DIGL_"DINDEX"
. S @DIXNAME@(1,"ROOT")=R_")",@DIXNAME@(2,"ROOT")=R_",DINDEX(1))"
. I $G(DINDEX(1,"USE")),DISUB'="" D
. . S R=DIGL_"""B"")",DISUB=$O(@R@(DISUB),-DIX1(1,"WAY"))
. . S @DIXNAME@(1)=DISUB
. . Q
. S R=DIGL_"""B"")",DISUB=$O(@R@(DISUB)),@DIXNAME@(1,"NXTVAL")=DISUB
. I DISUB="" K @DIXNAME,DIFILE("STACKEND",I) Q
. Q:DIFILE("STACK")
. S DIFILE("STACK")=I_U_DIFILE("STACKEND",I)
. Q
K DIX1(1,"USE")
I +DIFILE("STACK")=1 S DIX1(1)=DIXV(1,1)
E S I="DIXV("_+DIFILE("STACK")_")" M DIX1=@I
D WALK^DICLIX(DIFLAGS,.DIX1,.DIDENT,.DIFILE,.DIEN,.DIFIEN,.DISCREEN,.DILIST,.DINDEX,.DIXV,.DIC)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICL10 2345 printed Apr 09, 2024@21:44:51 Page 2
DICL10 ;SEA/TOAD,SF/TKW-VA FileMan: Lookup: Lister, Part 2 ;5/21/98 15:27
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
POINT(DIFILE,DIFLAGS,DINDEX,DIDENT,DIEN,DIFIEN,DISCREEN,DILIST) ;
+1 ; save off the primary file info, follow the ptr chain to the end
+2 SET DIFLAGS=DIFLAGS_"p"
+3 NEW DIVPTR,DIF
SET DIVPTR=$SELECT(DINDEX(1,"TYPE")="V":1,1:0)
+4 MERGE DIF=DIFILE
NEW DIFILE
MERGE DIFILE=DIF
KILL DIF
+5 DO FOLLOW^DICL3(.DIFILE,"",DINDEX(1,"NODE"),1,0,"",DINDEX(1,"FIELD"),DINDEX(1,"FILE"),DIVPTR,1,.DISCREEN)
+6 DO SETB^DICL3
+7 NEW DIX1
SET DIX1="B"
+8 SET DIX1("WAY")=DINDEX("WAY")
+9 NEW DIFROM
SET DIFROM(1)=$GET(DINDEX(1,"FROM"))
SET DIFROM("IEN")=""
+10 NEW DIPART
SET DIPART(1)=$GET(DINDEX(1,"PART"))
+11 SET DIFILE("STACK")=1_U_DIFILE("STACKEND",1)
+12 SET DIFILE=$PIECE(DIFILE("STACK"),U,3)
+13 DO INDEX^DICUIX(.DIFILE,.DIFLAGS,.DIX1,.DIFROM,.DIPART)
+14 IF $GET(DINDEX(1,"USE"))
SET DIX1(1,"USE")=1
+15 NEW I
FOR I="FIELD","FILE","FROM","GET","TYPE"
KILL DIX1(1,I)
+16 KILL DIX1("FLIST")
P1 ; no variable pointers in pointer chain
+1 IF '$ORDER(DIFILE("STACKEND",1))
Begin DoDot:1
+2 DO WALK^DICLIX(DIFLAGS,.DIX1,.DIDENT,.DIFILE,.DIEN,.DIFIEN,.DISCREEN,.DILIST,.DINDEX,"",.DIC)
+3 QUIT
End DoDot:1
QUIT
P2 ; variable pointer(s) in pointer chain
+1 NEW DIXV
+2 SET DIFLAGS=DIFLAGS_"v"
SET DIFILE("STACK")=""
+3 SET I=0
FOR
SET I=$ORDER(DIFILE("STACKEND",I))
if 'I
QUIT
Begin DoDot:1
+4 NEW DIXNAME,DISUB,R
SET DIXNAME="DIXV("_I_")"
SET DISUB=DIX1(1)
+5 NEW DIFL,DIGL
SET DIFL=+$PIECE(DIFILE("STACKEND",I),U,2)
SET DIGL=DIFILE(DIFL,"O")
+6 SET @DIXNAME@(1)=DISUB
SET @DIXNAME@(1,"MORE?")=DIX1(1,"MORE?")
SET @DIXNAME@(2)=""
+7 SET R=DIGL_"DINDEX"
+8 SET @DIXNAME@(1,"ROOT")=R_")"
SET @DIXNAME@(2,"ROOT")=R_",DINDEX(1))"
+9 IF $GET(DINDEX(1,"USE"))
IF DISUB'=""
Begin DoDot:2
+10 SET R=DIGL_"""B"")"
SET DISUB=$ORDER(@R@(DISUB),-DIX1(1,"WAY"))
+11 SET @DIXNAME@(1)=DISUB
+12 QUIT
End DoDot:2
+13 SET R=DIGL_"""B"")"
SET DISUB=$ORDER(@R@(DISUB))
SET @DIXNAME@(1,"NXTVAL")=DISUB
+14 IF DISUB=""
KILL @DIXNAME,DIFILE("STACKEND",I)
QUIT
+15 if DIFILE("STACK")
QUIT
+16 SET DIFILE("STACK")=I_U_DIFILE("STACKEND",I)
+17 QUIT
End DoDot:1
+18 KILL DIX1(1,"USE")
+19 IF +DIFILE("STACK")=1
SET DIX1(1)=DIXV(1,1)
+20 IF '$TEST
SET I="DIXV("_+DIFILE("STACK")_")"
MERGE DIX1=@I
+21 DO WALK^DICLIX(DIFLAGS,.DIX1,.DIDENT,.DIFILE,.DIEN,.DIFIEN,.DISCREEN,.DILIST,.DINDEX,.DIXV,.DIC)
+22 QUIT
+23 ;
