source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICF4.m@ 1476

Last change on this file since 1476 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.6 KB
RevLine 
[613]1DICF4 ;SEA/TOAD,SF/TKW-VA FileMan: Finder, (pointer indexes) ;2/16/00 13:31
2 ;;22.0;VA FileMan;**4,31**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5POINT(DIFILE,DIFLAGS,DINDEX,DIDENT,DIEN,DIFIEN,DISCREEN,DIVALUE,DIC,DIFORCE) ;
6 ; PREPIX^DICF2--transform value for indexed pointer field
7 N DIF,DIFL,DIX,DIPVAL,DISCR,DITARGET,DISKIP,DIPRV,DINEW
8 S DIF=$TR(DIFLAGS,$TR(DIFLAGS,"4XOB"))_"Mp",DIX="B"
9 I DIFLAGS["B" S DIF=$TR(DIF,"M")
10 D GETTMP^DICUIX1(.DITARGET,"DICF")
11 S DITARGET("C")=0
12 S (DIPRV,DINEW)="S" F S DINEW=$O(DISCREEN(DINEW)) Q:$E(DINEW)'="S" S DIPRV=DINEW,DISCR(DIPRV)=DISCREEN(DIPRV)
13 S DINEW="S"_($P(DIPRV,"S",2)+1)
14P1 ; Process regular pointer
15 I DINDEX(1,"TYPE")="P" D Q
16 . S DIFL=+$P($P(DINDEX(1,"NODE"),U,2),"P",2) Q:'DIFL
17 . M DIPVAL(1)=DIVALUE(1),DISCR(1)=DISCREEN(1)
18 . I DIFLAGS["l" D DIC(.DIC,.DIEN,.DIFILE,.DINDEX,.DIVALUE,DITARGET)
19 . I DIFLAGS'["l" D
20 . . I $D(DIFORCE("PTRIX")) D SETIX(.DIFORCE,.DINDEX,.DIX,.DIF)
21 . . N F S F=DIF N DIF S DIF=F K F M DIFL("CHAIN")=DIFILE("CHAIN")
22 . . D BLDSCR(.DISCR,DINEW,DIPRV,.DIFL,.DINDEX,.DISCREEN,.DIFILE)
23 . . D FIND^DICF(.DIFL,",","",DIF,.DIPVAL,"",.DIX,.DISCR,"",.DITARGET)
24 . I $G(DIERR)!('$G(@DITARGET)) K @DITARGET Q
25 . S DINDEX(1,"IXROOT")=DINDEX(1,"ROOT"),DINDEX(1,"ROOT")=$NA(@DITARGET@("B"))
26 . Q
27P2 ; Process variable pointer
28 I DIFLAGS["l" D Q
29 . D DIC(.DIC,.DIEN,.DIFILE,.DINDEX,.DIVALUE,DITARGET)
30 . I $G(DIERR)!('$G(@DITARGET)) K @DITARGET Q
31 . S DINDEX(1,"IXROOT")=DINDEX(1,"ROOT"),DINDEX(1,"ROOT")=$NA(@DITARGET@("B"))
32 . Q
33 N DIFILES I DIVALUE(1)[".",$P(DIVALUE(1),".")]"" D
34 . N V S V=$$OUT^DIALOGU($P(DIVALUE(1),"."),"UC")
35 . D VPFILES^DIEV1(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),V,.DIFILES)
36 . Q
37P21 D P3 I $G(DIERR) K @DITARGET Q
38 I $O(DIFILES(0)),'$G(@DITARGET) K DIFILES D P3
39 I $G(DIERR)!('$G(@DITARGET)) K @DITARGET Q
40 S DINDEX(1,"IXROOT")=DINDEX(1,"ROOT"),DINDEX(1,"ROOT")=$NA(@DITARGET@("B"))
41 Q
42 ;
43P3 N DIVP,G,I,X,DIF1,DIS1
44 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)
45 . K DIF1,DIFL,DIPVAL,DIS1,DIX S DIX="B"
46 . Q:'X I $O(DIFILES(0)) Q:'$D(DIFILES(+X))
47 . I $G(DISCREEN("V",1))]"" D Q:G=""
48 . . S G=$G(^DIC(+X,0,"GL")) Q:G=""
49 . . S:'$D(DINDEX(DISUB,"VP",G)) G="" Q
50 . S DIF1=DIF_"v",DIFL=+X
51 . I $D(DIFORCE("PTRIX")) D SETIX(.DIFORCE,.DINDEX,.DIX,.DIF1)
52 . D FILE^DICUF(.DIFL,"",.DIF1) Q:$G(DIERR)
53 . M DIS1=DISCR
54 . I '$O(DIFILES(0)) M DIPVAL(1)=DIVALUE(1),DIS1(1)=DISCREEN(1)
55 . E D
56 . . S DIF1=DIF1_"t"
57 . . S DIPVAL(1)=$P(DIVALUE(1),".",2,99)
58 . . Q
59 . M DIFL("CHAIN")=DIFILE("CHAIN")
60 . D BLDSCR(.DIS1,DINEW,DIPRV,.DIFL,.DINDEX,.DISCREEN,.DIFILE)
61 . S DITARGET("C")=+$G(@DITARGET)
62 . D FIND^DICF(.DIFL,",","",DIF1,.DIPVAL,"",.DIX,.DIS1,"",.DITARGET)
63 . Q
64 Q
65 ;
66SETIX(DIFORCE,DINDEX,DIX,DIF) ; If user passes list of indexes to use on pointed-to file, set up to use them.
67 M DIX("PTRIX")=DIFORCE("PTRIX") N %
68 S %=$G(DIX("PTRIX",DINDEX(1,"FILE"),DINDEX(1,"FIELD"),DIFL))
69 Q:%="" S DIX=%
70 I $P(DIX,U,2)="" S:DIF["M" DIF=$TR(DIF,"M") Q
71 S:DIF'["M" DIF=DIF_"M" Q
72 ;
73BLDSCR(DISCR,DINEW,DIPRV,DIFL,DINDEX,DISCREEN,DIFILE) ; Build screen to make sure entry is in pointer index.
74 N DICSUBS S DICSUBS=""
75 S DISCR(DINEW)=$S(DIPRV="S":" Q",1:" "_DISCREEN("S")_" Q:$T")
76 N I S I="I" S:DINDEX(1,"TYPE")["V" I=I_"_"";"_$P(DIFL(DIFL,"O"),U,2)_""""
77 S DISCR("S")=DICSUBS_"N "_DINEW_" S "_DINEW_"="_I_" X DISCREEN("""_DINEW_""")"
78 I DINDEX("#")>1 D Q
79 . S DISCR(DINEW)="X ""I 0"" I $D("_DIFILE(DIFILE,"O")_""""_DINDEX_""","_DINEW_"))"_DISCR(DINEW)
80 . Q
81 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)
82 Q
83 ;
84SETDA(DIEN) ; Return code that sets DA array to current level when pointer field is in a multiple. DA itself=DA(1).
85 N %,DICODE S DICODE="S DA="_+$G(DIEN(1))
86 F %=1:1 Q:'$D(DIEN(%)) S DICODE=DICODE_",DA("_%_")="_DIEN(%)
87 Q DICODE
88 ;
89DIC(DIC,DIEN,DIFILE,DINDEX,DIVALUE,DITARGET) ; If we were called from ^DIC, we want to do recursive lookup there.
90 N %,%Y,D,DD,DIVAL,DF,DID,DINUM,DICRS,DS,DO,X,Y,DIFINDER
91 S DO(2)=DIFILE,(D,DF)=DINDEX("START"),(X,DIVAL(1))=DIVALUE(1),DIVAL(0)=1
92 S DD=0,%=DINDEX,DS=$G(^DD(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),0)),Y=DINDEX(1,"TYPE"),%Y=DINDEX(1,"FIELD")
93 S:$G(DICR)="" DICR=0
94 D
95 . N DIFILE,I
96 . S DIFINDER="p"
97 . M I=DIC N DIC M DIC=I K I
98 . N DA X $$SETDA(.DIEN) N DIEN
99 . D A^DICM Q:Y=-1 D ^DICM1 K DICR(DICR) S DICR=DICR-1 I DICR<1 K DICR
100 . Q
101 Q:Y'>0
102 S @DITARGET@("B",($P(Y,U,2)_U_X))="",@DITARGET=1
103 Q
104 ;
105ERR(DIERN,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3) ;
106 ; error logging procedure
107 N DIPE
108 N DI F DI="FILE","IENS","FIELD",1:1:3 S DIPE(DI)=$G(@("DI"_DI))
109 D BLD^DIALOG(DIERN,.DIPE,.DIPE)
110 Q
111 ;
Note: See TracBrowser for help on using the repository browser.