source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUFLD.m@ 1311

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

initial load of WorldVistAEHR
File size: 7.9 KB
RevLine 
[613]1TIUFLD ; SLC/MAM - Lib; Template D Related; SETFLD(FILEDA,LASTLIN,FLDNO,SUBFDA,SUBFLDNO), INHERIT(FILEDA,PFILEDA,FLDNO,EIFORM,SUBFDA,SUBFLDNO,VALUE,AFILEDA), MULTILN(TIUREC,LASTLIN,FLDNAME) ;02/16/06
2 ;;1.0;TEXT INTEGRATION UTILITIES;**14,77,184,211**;Jun 20, 1997;Build 26
3 ;
4SETFLD(FILEDA,LASTLIN,FLDNO,SUBFDA,SUBFLDNO) ; Puts External Field in TMP("TIUF3") for Template D (Display), for FILEDA.
5 ; Requires Array TIUFQ as set in TIUFD, TIUFD1.
6 ; Requires FILEDA=DA in file.
7 ; Requires LASTLIN = Last array line set, if setting array; = Last
8 ;line to keep before resetting the rest if resetting array.
9 ; Updates LASTLIN to Last array line set by this module.
10 ; Requires FLDNO from list: 0, .01, 1501, .02, .03, .04, .05, .07, .08, .1, .11, .13, .15, 1, 1.01, 1.02, 1.03, 2, 3.02, 3.03, 4, 4.1, 4.2, 4.3, 4.4, 4,45, 4.5, 4.6, 4.7, 4.8, 4.9, 5, 6 6.1, 6.12, 6.13, 6.14, 7, 8, 9.
11 ; For FLDNO 0, sets IFN=FILEDA
12 ; For FLDNO 1 and 2, requires SUBFLDNO from list: .01, .02, .03, .04, .05, .06, .07, .1
13 ; For FLDNO 1 and 2, requires SUBFDA=DA in subfile.
14 ; For FLDNO .05, combines .05 and .06 into Owner (one value).
15 N TIUREC,LINENO,AVAIL,FLDNAME,NODE1,ZZCONT,FLDNAME1,UPFIELD,UPFILE,UPMSG
16 N FIELDNO,FDA,TYPE,POWNER,COWNER,LP,LC,OWNER,FLDVAL,FILENO,LENGTH
17 N TIUCKUP,TIUFTEMP
18 S:'$G(SUBFLDNO) SUBFLDNO=0 S:'$G(SUBFDA) SUBFDA=0
19 S FLDNAME=$S(FLDNO=.05:"OWNER^BASICS",$G(SUBFLDNO):^TMP("TIUF",$J,FLDNO,SUBFLDNO,"LABEL"),1:^TMP("TIUF",$J,FLDNO,"LABEL")),LENGTH=$P(FLDNAME,U,2),FLDNAME=$P(FLDNAME,U)
20 S LENGTH=$S(LENGTH="BASICS":16,LENGTH="TECH":20,LENGTH="UPLOAD":29,1:26)
21 S:FLDNO FLDNAME=$$MIXED^TIULS(FLDNAME)
22 S:FLDNO=.15 FLDNAME="PRF Flag",LENGTH=16
23 S:FLDNO=1501 FLDNAME="VHA Enterprise Standard Title",LENGTH=16
24 I $L(FLDNAME)>LENGTH S:$L(FLDNAME," ")=2 FLDNAME1=$P(FLDNAME," "),FLDNAME=$P(FLDNAME," ",2) S:$L(FLDNAME," ")>2 FLDNAME1=$P(FLDNAME," ",1,2),FLDNAME=$P(FLDNAME," ",3,5) S FLDNAME1=$J(FLDNAME1,LENGTH)
25 S AVAIL=77-$L(FLDNAME),TYPE=$P(TIUFNOD0,U,4)
26 S FLDNAME=$J(FLDNAME,LENGTH)
27 I FLDNO=.05 D G SETFLD2
28 . S POWNER=TIUFQ(8925.1,FILEDA,.05,"E"),COWNER=TIUFQ(8925.1,FILEDA,.06,"E")
29 . S LP=$L(POWNER),LC=$L(COWNER)
30 . S OWNER=$S(LP&'LC:POWNER,LC&'LP:COWNER,LP&LC:$E(POWNER,1,30)_","_$E(COWNER,1,30),1:"None")
31 . S TIUREC=OWNER
32 S FILENO=8925.1_$S(FLDNO=1!(FLDNO=2):FLDNO,1:"")
33 S FIELDNO=$S($G(SUBFLDNO):SUBFLDNO,1:FLDNO)
34 S FDA=$S($G(SUBFDA):SUBFDA,1:FILEDA)
35 I FLDNO=.07,$P(TIUFNOD0,U,10) S TIUREC="" G SETFX
36 S TIUREC=$G(TIUFQ(FILENO,FDA,FIELDNO,"E"))
37 I FLDNO=.08,TIUREC="NA" G SETFX
38 I FLDNO=.15,TIUREC="NA" G SETFX
39 I FLDNO=.1!(FLDNO=.13)!(FLDNO=3.02),TIUREC="" S TIUREC="NO"
40 I FLDNO=0 S TIUREC=FILEDA ; Sets IFN
41 G:FLDNO<1 SETFLD2 ; not heritable.
42 S NODE1=$G(^TIU(8925.1,FILEDA,1))
43 I FLDNO=1.01 D
44 . I $P(NODE1,U)="" S TIUREC="" Q
45 . D FILE^DID($P(NODE1,U),"","NAME","UPFILE")
46 . S UPMSG=" FILE ERROR; Please Edit Upload"
47 . I $G(DIERR) S TIUREC=UPMSG Q
48 . S TIUREC=UPFILE("NAME")
49 . D CHK^DIE(8925.1,1.01,"",TIUREC,.TIUCKUP) I TIUCKUP="^" S TIUREC=UPMSG
50 I FLDNO=1.03 D
51 . I $P(NODE1,U,3)="" S TIUREC="" Q
52 . S UPMSG=" FILE/FIELD/SUBSCRIPT ERROR; Please Edit Upload"
53 . D FIELD^DID($P(NODE1,U),+$P($P(NODE1,U,3),";"),"","LABEL;GLOBAL SUBSCRIPT LOCATION","UPFIELD")
54 . I $G(DIERR) S TIUREC=UPMSG Q
55 . I UPFIELD("GLOBAL SUBSCRIPT LOCATION")'=($P($P(NODE1,U,3),";",2)_";0") S TIUREC=UPMSG Q
56 . S TIUREC=UPFIELD("LABEL")
57 I FLDNO'<1,FLDNO<3 G SETFLD2 ;Upload flds, not heritable.
58 G:FLDNO=3.02!(FLDNO=4)!(FLDNO=4.5)!(FLDNO=4.8) SETFLD2 ; not heritable.
59SETFLD1 ; Technical fields, others which are heritable.
60 I TIUREC'="" S TIUREC=" "_TIUREC
61 I TIUREC="" D INHERIT(FILEDA,0,FLDNO,"E",SUBFDA,SUBFLDNO,.FLDVAL) S TIUREC=FLDVAL S TIUREC=$S(FLDVAL("E")'="":"* "_FLDVAL("E"),FLDNO=3.03&(FILEDA=38):" NO (by default)",FLDNO=3.03:"* NO",1:"") ;P77
62SETFLD2 I $D(FLDNAME1) S LASTLIN=LASTLIN+1,^TMP("TIUF3",$J,LASTLIN,0)=FLDNAME1
63 I FLDNO<1!(FLDNO=3.02),TIUREC'="" S TIUREC=" "_TIUREC
64 I $L(TIUREC)'>AVAIL S LASTLIN=LASTLIN+1,^TMP("TIUF3",$J,LASTLIN,0)=FLDNAME_": "_TIUREC G SETFX
65 I FLDNO'<4 D FIELD^DID(8925.1,FLDNO,"","TYPE","TIUFTEMP") I TIUFTEMP("TYPE")="MUMPS" D MMULTILN(TIUREC,.LASTLIN,FLDNAME) G SETFX
66 I FLDNO=1!(FLDNO=2),$G(SUBFLDNO)=1 D MMULTILN(TIUREC,.LASTLIN,FLDNAME) G SETFX ;Upload caption transform code
67 D MULTILN(TIUREC,.LASTLIN,FLDNAME)
68SETFX D CLEAN^DILF
69 Q
70 ;
71INHERIT(FILEDA,PFILEDA,FLDNO,EIFORM,SUBFDA,SUBFLDNO,VALUE,AFILEDA) ;
72 ; Can't make it a function with pieces since pieces may contain ^.
73 ; For FLDNO'=6.14, Returns in VALUE the Field Value for first ancestor
74 ;of FILEDA that has a field value. If not found, returns "".
75 ; For FLDNO=6.14, returns "" if no ancestor has a value, internal=0
76 ;if ANY ancestor is 0; else 1.
77 ; Requires FILEDA, FLDNO. If FLDNO = 1 or 2, requires SUBFDA,
78 ;SUBFLDNO. See SETFLDS.
79 ; Optional PFILEDA=anticipated parent IFN for ADD ITEMS, etc.
80 ; If EIFORM="E", returns in VALUE("E") the external value; else
81 ;returns VALUE("E")=""
82 ; Returns AFILEDA= IFN of ancestor used, if none, 0.
83 ; Requires FLDNO from list (heritable subset of list from SETFLD): 3.03, 4.1, 4.2, 4.3, 4.4, 4.45, 4.9, 5, 6 6.1, 6.12, 6.13, 6.14, 7, 8, 9. WHAT ABOUT ENTRY AND EXIT ACTIONS? MAM
84 N PNODE,NODENO,ZZCONT,C,Y
85 S (VALUE,VALUE("E"))=""
86 I '$D(EIFORM) S EIFORM="I"
87 S:'$G(SUBFLDNO) SUBFLDNO=0 S:'$G(SUBFDA) SUBFDA=0
88 S:'PFILEDA PFILEDA=$O(^TIU(8925.1,"AD",FILEDA,0)) G:'PFILEDA INHEX
89 S NODENO=$S((FLDNO=6.1)!(FLDNO=6.12)!(FLDNO=6.13)!(FLDNO=6.14):6.1,(FLDNO=3.03):3,1:FLDNO)
90 S PNODE=$G(^TIU(8925.1,PFILEDA,NODENO)) I PNODE="" G AGAIN
91 I FLDNO=6.14 S VALUE=$P(PNODE,U,4) G:VALUE=0 INHEX G:VALUE="" AGAIN
92 S VALUE=$S(FLDNO=6.1:$P(PNODE,U),FLDNO=6.12:$P(PNODE,U,2),FLDNO=6.13:$P(PNODE,U,3),FLDNO=6.14:$P(PNODE,U,4),FLDNO=3.03:$P(PNODE,U,3),1:PNODE)
93 G:VALUE'="" INHEX
94AGAIN D INHERIT(PFILEDA,0,FLDNO,EIFORM,SUBFDA,SUBFLDNO,.VALUE,.AFILEDA)
95INHEX S AFILEDA=+PFILEDA
96 I VALUE'="",EIFORM="E" D
97 . I FLDNO=1 S C=$P(^DD(8925.11,SUBFLDNO,0),U,2),Y=VALUE D Y^DIQ S VALUE("E")=Y Q
98 . I FLDNO=2 S C=$P(^DD(8925.12,SUBFLDNO,0),U,2),Y=VALUE D Y^DIQ S VALUE("E")=Y Q
99 . S C=$P(^DD(8925.1,FLDNO,0),U,2),Y=VALUE D Y^DIQ S VALUE("E")=Y Q
100 Q
101 ;
102MULTILN(TIUREC,LASTLIN,FLDNAME) ; Set FLDNAME and as much as fits of TIUREC
103 ;into line LASTLIN+1. Set rest of TIUREC into succeeding lines,
104 ;splitting at words.
105 ; Requires TIUREC,FLDNAME
106 ; Requires LASTLIN = Last array line set, if setting array; = Last
107 ;line to keep before resetting the rest if resetting array.
108 ; Updates LASTLIN to Last array line set by this module.
109 N TIUK,TIUL,REST,TIUFT,AVAIL,LINENO
110 S AVAIL=79-$L($G(FLDNAME)) D WRAP^TIUFLD(TIUREC,AVAIL)
111 S LINENO=LASTLIN+1 ;P77 cleanup
112 S ^TMP("TIUF3",$J,LINENO,0)=FLDNAME_": "_TIUFT(1)
113 S REST="" F TIUK=2:1 Q:'$D(TIUFT(TIUK)) S REST=REST_TIUFT(TIUK)
114 K TIUFT I REST'="" D WRAP^TIUFLD(REST,79)
115 F TIUL=1:1 Q:'$D(TIUFT(TIUL)) S LINENO=LINENO+1,^TMP("TIUF3",$J,LINENO,0)=TIUFT(TIUL)
116 S LASTLIN=LINENO
117 Q
118 ;
119MMULTILN(TIUREC,LASTLIN,FLDNAME) ;MULTILN for M code (show spaces)
120 N TIUK,TIUL,TIUFT,LINENO,FCHAR,LCHAR
121 S LINENO=LASTLIN,TIUK=1,FCHAR=1,LCHAR=79-($L($G(FLDNAME))+2)
122 F D Q:FCHAR>$L(TIUREC)
123 . S TIUFT(TIUK)=$E(TIUREC,FCHAR,LCHAR)
124 . S TIUK=TIUK+1,FCHAR=LCHAR+1,LCHAR=FCHAR+78
125 S TIUFT(1)=FLDNAME_": "_TIUFT(1)
126 F TIUL=1:1 Q:'$D(TIUFT(TIUL)) S LINENO=LINENO+1,^TMP("TIUF3",$J,LINENO,0)=TIUFT(TIUL)
127 F TIUL=2:1 Q:'$D(TIUFT(TIUL)) S ^TMP("TIUF3",$J,LINENO,0)=TIUFT(TIUL)
128 S LASTLIN=LINENO
129 Q
130 ;
131WRAP(TEXT,LENGTH,FLENGTH) ; Breaks text string into first substring of
132 ;length FLENGTH; subsequent substrings of length LENGTH;
133 ;Sets them into array TIUFT with subscripts 1,2,3, etc.
134 ;Adapted from Joel Russell's WRAP^GMTSORC.
135 N TIUFI,TIUFJ,LINE,TIUFT1,TIUFT2,TIUFY
136 I $G(TEXT)']"" Q
137 F TIUFI=1:1 D Q:TIUFI=$L(TEXT," ")
138 . S TIUFT=$P(TEXT," ",TIUFI)
139 . I $L(TIUFT)>LENGTH D
140 . . S TIUFT1=$E(TIUFT,1,LENGTH),TIUFT2=$E(TIUFT,LENGTH+1,$L(TIUFT))
141 . . S $P(TEXT," ",TIUFI)=TIUFT1_" "_TIUFT2
142 S LINE=1,TIUFT(1)=$P(TEXT," ")
143 F TIUFI=2:1 D Q:TIUFI'<$L(TEXT," ")
144 . S:$L($G(TIUFT(LINE))_" "_$P(TEXT," ",TIUFI))>LENGTH LINE=LINE+1,TIUFY=1
145 . S TIUFT(LINE)=$G(TIUFT(LINE))_$S(+$G(TIUFY):"",1:" ")_$P(TEXT," ",TIUFI),TIUFY=0
146 Q
147 ;
Note: See TracBrowser for help on using the repository browser.