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

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

initial load of WorldVistAEHR

File size: 5.1 KB
RevLine 
[613]1DICU2 ;SEA/TOAD,SF/TKW-VA FileMan: Lookup Tools, Return IDs ;7/24/98 12:19
2 ;;22.0;VA FileMan;;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5IDS(DIFILE,DIEN,DIFLAGS,DINDEX,DICOUNT,DIDENT,DILIST,DI0NODE) ;
6 ;
7 ; ENTRY POINT--add an entry's identifiers to output
8 ;
9I1 ; setup 0-node and ID array interface, and output IEN
10 ;
11 I DIFLAGS["h" N F,N,I M F=DIFILE S N=$G(DI0NODE),I=+$G(DIEN) N DIFILE,DI0NODE,DIEN M DIFILE=F S DIEN=I S:N]"" DI0NODE=N K F,N,I
12 I '$D(DI0NODE) S DI0NODE=$G(@DIFILE(DIFILE)@(+DIEN,0))
13 N DID,DIDVAL
14 I DIFLAGS["P" N DINODE S DINODE=+DIEN
15 E S @DILIST@(2,DICOUNT)=+DIEN
16 ;
17I1A ; output primary value (index for Lister, .01 for Finder)
18 ;
19 I DIFLAGS'["P",$D(DIDENT(-2)) D
20 . N DIOUT S DIOUT=$NA(@DILIST@(1,DICOUNT))
21 . I DIFLAGS[3 N DISUB D Q
22 . . F DISUB=0:0 S DISUB=$O(DIDENT(0,-2,DISUB)) Q:'DISUB D
23 . . . I DINDEX("#")'>1 D SET(0,-2,DISUB,DIOUT,.DINDEX) Q
24 . . . N I S I=$NA(@DIOUT@(DISUB)) D SET(0,-2,DISUB,I,.DINDEX)
25 . I $D(DIDENT(0,-2,.01)) D SET(0,-2,.01,DIOUT,"",.DIFILE)
26 . Q
27 ;
28I2 ; start loop: loop through output values
29 ;
30 I DIFLAGS["P" N DILENGTH S DILENGTH=$L(DINODE)
31 N DICODE,DICRSR,DIOUT,DISUB S DICRSR=-1
32 F S DICRSR=$O(DIDENT(DICRSR)) Q:DICRSR=""!($G(DIERR)) S DID="" F S DID=$O(DIDENT(DICRSR,DID)) Q:DID=""!($G(DIERR)) S DISUB="" F D Q:DISUB=""!$G(DIERR)
33 . I DIFLAGS'["P",DID=-2 Q
34 . S DISUB=$O(DIDENT(DICRSR,DID,DISUB)) Q:DISUB=""
35 . K DIDVAL
36I20 . ; output indexed field if "IX" was in FIELDS parameter
37 . I DID=0 D Q
38 . . D SET(DICRSR,DID,DISUB,"DIDVAL",.DINDEX,.DIFILE)
39 . . I DIFLAGS["P" D ADD(.DIFLAGS,.DINODE,.DILENGTH,DIDVAL,DIEN,DILIST) Q
40 . . M @DILIST@("ID",DICOUNT,0,DISUB)=DIDVAL Q
41 .
42I3 . ; output field
43 . ; distinguish between computed and value fields
44 .
45 . I DID D Q:$G(DIERR)
46 . . ; process fields that are not computed.
47 . . I $G(DIDENT(DICRSR,DID,0,"TYPE"))'="C" D
48 . . . D SET(DICRSR,DID,DISUB,"DIDVAL",.DINDEX,.DIFILE) Q
49 . .
50I4 . . ; computed fields
51 . . E D
52 . . . N %,%H,%T,A,B,C,D,DFN,I,X,X1,X2,Y,Z,Z0,Z1
53 . . . N DA M DA=DIEN S DA=$P(DIEN,",")
54 . . . N DIARG S DIARG="D0"
55 . . . N DIMAX S DIMAX=+$O(DA(""),-1)
56 . . . N DIDVAR F DIDVAR=1:1:DIMAX S DIARG=DIARG_",D"_DIDVAR
57 . . . N @DIARG F DIDVAR=0:1:DIMAX-1 S @("D"_DIDVAR)=DA(DIMAX-DIDVAR)
58 . . . S @("D"_DIMAX)=DA
59 . . . X DIDENT(DICRSR,DID,0) S DIDVAL=$G(X)
60 . .
61I5 . . ; set field into array or pack node
62 . .
63 . . I DIFLAGS'["P" M @DILIST@("ID",DICOUNT,DID)=DIDVAL
64 . . E D ADD(.DIFLAGS,.DINODE,.DILENGTH,DIDVAL,DIEN,DILIST)
65 .
66I6 . ; output display-only identifier
67 .
68 . E D
69 . . N %,D,DIC,X,Y,Y1
70 . . S D=DINDEX
71 . . S DIC=DIFILE(DIFILE,"O")
72 . . S DIC(0)=$TR(DIFLAGS,"2^fglpqtuv104")
73 . . M Y=DIEN S Y=$P(DIEN,",")
74 . . S Y1=$G(@DIFILE(DIFILE)@(+DIEN,0)),Y1=DIEN
75 . .
76I7 . . ; execute the identifier's code
77 . .
78 . . N DIX S DIX=DIDENT(DICRSR,DID,0)
79 . . X DIX
80 . . I $G(DIERR) D Q
81 . . . N DICONTXT I DID="ZZZ ID" S DICONTXT="Identifier parameter"
82 . . . E S DICONTXT="MUMPS Identifier"
83 . . . D ERR^DICF4(120,DIFILE,DIEN,"",DICONTXT)
84 . .
85I8 . . ; set output from identifier into output array or pack node
86 . .
87 . . N DI,DILINE,DIEND S DI="" S:DIFLAGS'["P" DIEND=$O(@DILIST@("ID","WRITE",DICOUNT,"z"),-1)
88 . . I $O(^TMP("DIMSG",$J,""))="" S ^TMP("DIMSG",$J,1)=""
89 . . F D Q:DI=""!$G(DIERR)
90 . . . S DI=$O(^TMP("DIMSG",$J,DI)) Q:DI=""
91 . . . S DILINE=$G(^TMP("DIMSG",$J,DI))
92 . . . I DIFLAGS["P" D ADD(.DIFLAGS,.DINODE,.DILENGTH,DILINE,DIEN,DILIST,DI) Q
93 . . . S DIEND=DIEND+1,@DILIST@("ID","WRITE",DICOUNT,DIEND)=DILINE
94 . . . Q
95 . . K DIMSG,^TMP("DIMSG",$J)
96 ;
97I9 ; for packed output, set pack node into output array
98 ;
99 I '$G(DIERR),DIFLAGS["P" S @DILIST@(DICOUNT,0)=DINODE
100 Q
101 ;
102 ;
103SET(DICRSR,DIFID,DISUB,DIOUT,DINDEX,DIFILE) ; Move data to DIOUT.
104 N F1,F2
105 S F1=$O(DIDENT(DICRSR,DIFID,DISUB,"")),F2=$O(DIDENT(DICRSR,DIFID,DISUB,F1))
106 F F1=F1,F2 D:F1]""
107 . I DIDENT(DICRSR,DIFID,DISUB,F1)["DIVAL" N DIVAL S @DINDEX(DISUB,"GET")
108 . N X S @("X="_DIDENT(DICRSR,DIFID,DISUB,F1))
109 . I $G(DIERR),DIFLAGS["h" K DIERR,^TMP("DIERR",$J) S X=DINDEX(DISUB)
110 . I X["""" S X=$$CONVQQ^DILIBF(X)
111 . I +$P(X,"E")'=X S X=""""_X_""""
112 . I F2="" S @(DIOUT_"="_X) Q
113 . S O=$NA(@DIOUT@(F1)),@(O_"="_X) Q
114 Q
115 ;
116TRANOUT(DISUB,DIVL) ; Execute TRANSFORM FOR DISPLAY on index value
117 N X S X=DIVL
118 N DICODE S DICODE=$G(DINDEX(DISUB,"TRANOUT"))
119 I DICODE]"" X DICODE
120 Q X
121 ;
122ADD(DIFLAGS,DINODE,DILENGTH,DINEW,DIEN,DILIST,DILCNT) ;
123 ;
124 ; for Packed output, add DINEW to DINODE, erroring if overflow
125 ; xform if it contains ^
126 ;
127A1 N DINEWLEN,DELIM S DINEWLEN=$L(DINEW),DELIM=$S($G(DILCNT)'>1:"^",1:"~")
128 S DILENGTH=DILENGTH+1+DINEWLEN
129 I DILENGTH>255 D ERR^DICF4(206,"","","",+DIEN) Q
130 I DIFLAGS'[2,DINEW[U S DIFLAGS="2^"_DIFLAGS D ENCODE(DILIST,.DINODE)
131 I DIFLAGS[2,DINEW[U!(DINEW["&") S DINEW=$$HTML^DILF(DINEW) Q:$G(DIERR)
132 S DINODE=DINODE_DELIM_DINEW
133 Q
134 ;
135ENCODE(DILIST,DINODE) ;
136 ;
137 ; ADD: HTML encode records already output (we found an embedded ^)
138 ; procedure: loop through list encoding &s
139 ;
140E1 N DILINE,DIRULE S DIRULE(1,"&")="&"
141 N DIREC S DIREC=0 F S DIREC=$O(@DILIST@(DIREC)) Q:'DIREC D
142 . S DILINE=@DILIST@(DIREC,0) Q:DILINE'["&"
143 . S @DILIST@(DIREC,0)=$$TRANSL8^DILF(DILINE,.DIRULE)
144 I DINODE["&" S DINODE=$$TRANSL8^DILF(DINODE,.DIRULE)
145 Q
146 ;
Note: See TracBrowser for help on using the repository browser.