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

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

initial load of WorldVistAEHR
File size: 4.9 KB
Line 
1DDSPTR ;SFISC/MKO-SET "PT" AND "PTB" NODES ;9:43 AM 4 Apr 1996
2 ;;22.0;VA FileMan;;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5PT(DDSDDP,EXP,DDS,PG,BK) ;Set "PT" and "PTB" nodes
6 N DDP,FDL,CD,FD
7 S DDP=DDSDDP
8 S $P(@DDSREFS@(PG,BK),U,8)=1
9 ;
10 D:EXP?1"FO(".E FO(DDP,EXP,DDS,PG,BK,.CD,.FDL)
11 D:EXP'?1"FO(".E DD(DDP,EXP,BK,.CD,.FDL)
12 Q:$G(DIERR)
13 ;
14 S:FDL?.E1"^" FDL=$E(FDL,1,$L(FDL)-1)
15 S @DDSREFS@(PG,BK,"PTB")=FDL
16 F CD=1:1:CD S @DDSREFS@(PG,BK,"PTB",CD)=CD(CD)
17 F CD=1:1:$L(FDL,U) D
18 . S FD=$P($P(FDL,U,CD),";"),DDP=+FD,FD=$P(FD,",",2,99)
19 . S @DDSREFS@("PT",DDP,FD,PG,BK)=""
20 Q
21 ;
22DD(DDP,EXP,BK,CD,FDL,COMP) ;Parse DD expression
23 ;In:
24 ; DDP = file #
25 ; EXP = rel expr
26 ; BK = blk # (to get DD# of blk)
27 ; COMP = flag, EXP not pointer link
28 ; 1, def is ext (DDSCOMP and DDSVAL)
29 ; 2, def is int (DDSVAL)
30 ;Returns:
31 ; CD = array of code that sets DA
32 ; FDL = list of flds used in expr
33 ;
34 N FD1,FD2,P,TYP
35 I EXP?1"DD(".E D
36 . N I
37 . S I=$$RPAR^DDSLIB(EXP,3)
38 . S DDP=$P($E(EXP,4,I-2),",")
39 . S EXP=$P($E(EXP,4,I-2),",",2,999)_$E(EXP,I,999)
40 ;
41 I $G(DDP)="" D BLD^DIALOG(202,"file") Q
42 ;
43LOOP S CD=$G(CD)+1
44LOOP1 I $E(EXP)="""" D
45 . N I S I=$$AFTQ^DDSLIB(EXP)
46 . S FD1=$$UQT^DDSLIB($E(EXP,1,I-1)),FD2=$P($E(EXP,I,999),":",2,999)
47 . S P=$P($E(EXP,I,999),":")
48 E D
49 . S FD1=$P($P(EXP,":"),";"),FD2=$P(EXP,":",2,999)
50 . S P=$P($P(EXP,":"),";",2,999)
51 S FD1=$$FIELD^DDSLIB(DDP,FD1) Q:$G(DIERR)
52 ;
53 S TYP=$P(^DD(DDP,FD1,0),U,2)
54 I TYP S DDP=+TYP,EXP=FD2 D:EXP="" BLD^DIALOG(3083) Q:EXP="" G LOOP1
55 ;
56 I FD2="",$G(COMP) D Q
57 . S P=$S(COMP=1:P'["I",1:P["E")
58 . S CD(CD)="S X=$$GET^DDSVAL("_DDP_","_$S(CD=1:".DA",1:"X")_","_FD1_$S(P:","""",""E""",1:"")_")"
59 . S FDL=$G(FDL)_DDP_","_FD1_U
60 ;
61 I TYP["V" D Q:$G(DIERR)
62 . S CD(CD)="S X=+$$GET^DDSVAL("_DDP_","_$S(CD=1:".DA",1:"X")_","_FD1_")"
63 . S FDL=$G(FDL)_DDP_","_FD1_U
64 . D GETFF(.FD2,.DDP)
65 E I TYP["P" D
66 . S CD(CD)="S X=$$GET^DDSVAL("_DDP_","_$S(CD=1:".DA",1:"X")_","_FD1_")"
67 . S FDL=$G(FDL)_DDP_","_FD1_U
68 . S DDP=+$P(TYP,"P",2)
69 E D Q:$G(DIERR)
70 . N D,F,S
71 . S FDL=$G(FDL)_DDP_","_FD1_";J^"
72 . D LKPARM(P,.F,.D,.S)
73 . S CD(CD)="N D,DIC,Y S X=$$GET^DDSVAL("_DDP_","_$S(CD=1:".DA",1:"X")_","_FD1_$S(F:"",1:","""",""E""")_")"
74 . D GETFF(.FD2,.DDP) Q:$G(DIERR)
75 . I FD2="" D Q:$G(DIERR)
76 .. I $G(COMP) D BLD^DIALOG(3083) Q
77 .. S DDP=$P(^DIST(.404,BK,0),U,2)
78 . I DDP="" D BLD^DIALOG(202,"file") Q
79 . I '$D(^DD(DDP))!'$D(^DIC(DDP,0,"GL")) D Q
80 .. N P S P("FILE")=DDP D BLD^DIALOG(401,.P)
81 . S CD(CD)=CD(CD)_",DIC="""_^DIC(DDP,0,"GL")_""""_D_S_" S X=+Y"
82 ;
83 I FD2]"" S EXP=FD2 G LOOP
84 S CD(CD)=CD(CD)_",DA=X"
85 Q
86 ;
87FO(DDP,EXP,DDS,PG,BK,CD,FDL,COMP) ;Parse FO expression
88 N FD1,FD2,I,P
89 ;
90 S:'$D(DDS) DDS="" S:'$D(PG) PG="" S:'$D(BK) BK=""
91 S CD=1
92 S I=$$RPAR^DDSLIB(EXP,3)
93 S FD1=$E(EXP,4,I-2),P=$P($E(EXP,I,999),":")
94 S FD2=$P($E(EXP,I,999),":",2,999)
95 F I=1:1:3 S P(I)=$$PIECE^DDSLIB(FD1,",",I)
96 ;
97 S FD1=$P($$GETFLD^DDSLIB(P(1),P(2),P(3),DDS,PG,BK,"F"),",",1,2)
98 Q:$G(DIERR)
99 ;
100 I FD2="",$G(COMP) D Q
101 . S P=$S(COMP=1:P'["I",1:P["E")
102 . S CD(1)="S X=$$GET^DDSVALF("""_FD1_""","""","""","""_$S(P:"E",1:"")_""",DDSDA)"
103 . S FDL=$G(FDL)_"0,"_FD1_U
104 ;
105 I $P($G(^DIST(.404,+$P(FD1,",",2),40,+FD1,20)),U)="" D Q
106 . N P S P(1)="READ TYPE",P(2)="form-only field in the BLOCK"
107 . D BLD^DIALOG(3011,.P)
108 ;
109 I $P(^DIST(.404,+$P(FD1,",",2),40,+FD1,20),U)["P" D
110 . S CD(1)="S X=$$GET^DDSVALF("""_FD1_""","""","""","""",DDSDA)"
111 . S FDL=$G(FDL)_"0,"_FD1_U
112 . S DDP=U_$P($P(^DIST(.404,+$P(FD1,",",2),40,+FD1,20),U,3),":")
113 E D Q:$G(DIERR)
114 . N D,F,S
115 . S FDL=$G(FDL)_"0,"_FD1_";J^"
116 . D LKPARM(P,.F,.D,.S)
117 . S CD(1)="N D,DIC,Y S X=$$GET^DDSVALF("""_FD1_""","""","""","""_$S(F:"",1:"E")_""",DDSDA)"
118 . D GETFF(.FD2,.DDP) Q:$G(DIERR)
119 . I FD2="" S DDP=$P(^DIST(.404,BK,0),U,2)
120 . I DDP="" D BLD^DIALOG(202,"file") Q
121 . I '$D(^DD(DDP))!'$D(^DIC(DDP,0,"GL")) D Q
122 .. N P S P("FILE")=DDP D BLD^DIALOG(401,.P)
123 . S CD(1)=CD(1)_",DIC="""_^DIC(DDP,0,"GL")_""""_D_S_" S X=+Y"
124 ;
125 I FD2="" S CD(CD)=CD(CD)_",DA=X"
126 E S EXP=FD2 D DD(DDP,EXP,BK,.CD,.FDL,$G(COMP))
127 Q
128 ;
129GETFF(FD2,DDP) ;Get file, field
130 ;Input: FD2=file:field:...
131 ;Output: FD2=field:...
132 ; DDP=file number
133 I $E(FD2)="""" D
134 . N I S I=$$AFTQ^DDSLIB(FD2,1)
135 . S DDP=$$UQT^DDSLIB($E(FD2,1,I-1)),FD2=$E(FD2,I,999)
136 E S DDP=$P(FD2,":"),FD2=$P(FD2,":",2,999)
137 ;
138 I DDP]"",DDP'=+$P(DDP,"E") D
139 . I '$D(^DIC("B",DDP)) D BLD^DIALOG(3012,DDP) Q
140 . S DDP=$O(^DIC("B",DDP,""))
141 Q
142 ;
143LKPARM(P,F,D,S) ;Parse lookup params
144 ;In: P = specifiers separated by ;
145 ;Out: F = 1 if int form wanted
146 ; D = code that sets D and DIC(0)
147 ; S = code that calls ^DIC
148 N I,IP,L,M
149 S (D,F,L,M)=""
150 F I=1:1:$L(P,";") D
151 . S IP=$P(P,";",I) Q:IP=""
152 . I IP="I" S F=1 Q
153 . I IP="L" S L=1 Q
154 . I IP?.1"M"1"IX(".E1")" D Q
155 .. S IP=$P($P(IP,"(",2),")")
156 .. S:$E(IP)'="""" IP=$$QT^DDSLIB(IP)
157 .. S D=",D="_IP
158 .. I $L(IP,U)>1 S D=D_",DIC(0)=""MF""",S=" D MIX^DIC1"
159 .. E S D=D_",DIC(0)=""F""",S=" D IX^DIC"
160 S:D="" D=",DIC(0)=""MF""",S=" D ^DIC"
161 S D=D_" S:$G(DDS1E) DIC(0)=DIC(0)_""E"_$E("L",L)_""""
162 Q
Note: See TracBrowser for help on using the repository browser.