148 lines
7.9 KiB
Mathematica
148 lines
7.9 KiB
Mathematica
TIUFLD ; 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
|
|
;;1.0;TEXT INTEGRATION UTILITIES;**14,77,184,211**;Jun 20, 1997;Build 26
|
|
;
|
|
SETFLD(FILEDA,LASTLIN,FLDNO,SUBFDA,SUBFLDNO) ; Puts External Field in TMP("TIUF3") for Template D (Display), for FILEDA.
|
|
; Requires Array TIUFQ as set in TIUFD, TIUFD1.
|
|
; Requires FILEDA=DA in file.
|
|
; Requires LASTLIN = Last array line set, if setting array; = Last
|
|
;line to keep before resetting the rest if resetting array.
|
|
; Updates LASTLIN to Last array line set by this module.
|
|
; 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.
|
|
; For FLDNO 0, sets IFN=FILEDA
|
|
; For FLDNO 1 and 2, requires SUBFLDNO from list: .01, .02, .03, .04, .05, .06, .07, .1
|
|
; For FLDNO 1 and 2, requires SUBFDA=DA in subfile.
|
|
; For FLDNO .05, combines .05 and .06 into Owner (one value).
|
|
N TIUREC,LINENO,AVAIL,FLDNAME,NODE1,ZZCONT,FLDNAME1,UPFIELD,UPFILE,UPMSG
|
|
N FIELDNO,FDA,TYPE,POWNER,COWNER,LP,LC,OWNER,FLDVAL,FILENO,LENGTH
|
|
N TIUCKUP,TIUFTEMP
|
|
S:'$G(SUBFLDNO) SUBFLDNO=0 S:'$G(SUBFDA) SUBFDA=0
|
|
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)
|
|
S LENGTH=$S(LENGTH="BASICS":16,LENGTH="TECH":20,LENGTH="UPLOAD":29,1:26)
|
|
S:FLDNO FLDNAME=$$MIXED^TIULS(FLDNAME)
|
|
S:FLDNO=.15 FLDNAME="PRF Flag",LENGTH=16
|
|
S:FLDNO=1501 FLDNAME="VHA Enterprise Standard Title",LENGTH=16
|
|
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)
|
|
S AVAIL=77-$L(FLDNAME),TYPE=$P(TIUFNOD0,U,4)
|
|
S FLDNAME=$J(FLDNAME,LENGTH)
|
|
I FLDNO=.05 D G SETFLD2
|
|
. S POWNER=TIUFQ(8925.1,FILEDA,.05,"E"),COWNER=TIUFQ(8925.1,FILEDA,.06,"E")
|
|
. S LP=$L(POWNER),LC=$L(COWNER)
|
|
. S OWNER=$S(LP&'LC:POWNER,LC&'LP:COWNER,LP&LC:$E(POWNER,1,30)_","_$E(COWNER,1,30),1:"None")
|
|
. S TIUREC=OWNER
|
|
S FILENO=8925.1_$S(FLDNO=1!(FLDNO=2):FLDNO,1:"")
|
|
S FIELDNO=$S($G(SUBFLDNO):SUBFLDNO,1:FLDNO)
|
|
S FDA=$S($G(SUBFDA):SUBFDA,1:FILEDA)
|
|
I FLDNO=.07,$P(TIUFNOD0,U,10) S TIUREC="" G SETFX
|
|
S TIUREC=$G(TIUFQ(FILENO,FDA,FIELDNO,"E"))
|
|
I FLDNO=.08,TIUREC="NA" G SETFX
|
|
I FLDNO=.15,TIUREC="NA" G SETFX
|
|
I FLDNO=.1!(FLDNO=.13)!(FLDNO=3.02),TIUREC="" S TIUREC="NO"
|
|
I FLDNO=0 S TIUREC=FILEDA ; Sets IFN
|
|
G:FLDNO<1 SETFLD2 ; not heritable.
|
|
S NODE1=$G(^TIU(8925.1,FILEDA,1))
|
|
I FLDNO=1.01 D
|
|
. I $P(NODE1,U)="" S TIUREC="" Q
|
|
. D FILE^DID($P(NODE1,U),"","NAME","UPFILE")
|
|
. S UPMSG=" FILE ERROR; Please Edit Upload"
|
|
. I $G(DIERR) S TIUREC=UPMSG Q
|
|
. S TIUREC=UPFILE("NAME")
|
|
. D CHK^DIE(8925.1,1.01,"",TIUREC,.TIUCKUP) I TIUCKUP="^" S TIUREC=UPMSG
|
|
I FLDNO=1.03 D
|
|
. I $P(NODE1,U,3)="" S TIUREC="" Q
|
|
. S UPMSG=" FILE/FIELD/SUBSCRIPT ERROR; Please Edit Upload"
|
|
. D FIELD^DID($P(NODE1,U),+$P($P(NODE1,U,3),";"),"","LABEL;GLOBAL SUBSCRIPT LOCATION","UPFIELD")
|
|
. I $G(DIERR) S TIUREC=UPMSG Q
|
|
. I UPFIELD("GLOBAL SUBSCRIPT LOCATION")'=($P($P(NODE1,U,3),";",2)_";0") S TIUREC=UPMSG Q
|
|
. S TIUREC=UPFIELD("LABEL")
|
|
I FLDNO'<1,FLDNO<3 G SETFLD2 ;Upload flds, not heritable.
|
|
G:FLDNO=3.02!(FLDNO=4)!(FLDNO=4.5)!(FLDNO=4.8) SETFLD2 ; not heritable.
|
|
SETFLD1 ; Technical fields, others which are heritable.
|
|
I TIUREC'="" S TIUREC=" "_TIUREC
|
|
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
|
|
SETFLD2 I $D(FLDNAME1) S LASTLIN=LASTLIN+1,^TMP("TIUF3",$J,LASTLIN,0)=FLDNAME1
|
|
I FLDNO<1!(FLDNO=3.02),TIUREC'="" S TIUREC=" "_TIUREC
|
|
I $L(TIUREC)'>AVAIL S LASTLIN=LASTLIN+1,^TMP("TIUF3",$J,LASTLIN,0)=FLDNAME_": "_TIUREC G SETFX
|
|
I FLDNO'<4 D FIELD^DID(8925.1,FLDNO,"","TYPE","TIUFTEMP") I TIUFTEMP("TYPE")="MUMPS" D MMULTILN(TIUREC,.LASTLIN,FLDNAME) G SETFX
|
|
I FLDNO=1!(FLDNO=2),$G(SUBFLDNO)=1 D MMULTILN(TIUREC,.LASTLIN,FLDNAME) G SETFX ;Upload caption transform code
|
|
D MULTILN(TIUREC,.LASTLIN,FLDNAME)
|
|
SETFX D CLEAN^DILF
|
|
Q
|
|
;
|
|
INHERIT(FILEDA,PFILEDA,FLDNO,EIFORM,SUBFDA,SUBFLDNO,VALUE,AFILEDA) ;
|
|
; Can't make it a function with pieces since pieces may contain ^.
|
|
; For FLDNO'=6.14, Returns in VALUE the Field Value for first ancestor
|
|
;of FILEDA that has a field value. If not found, returns "".
|
|
; For FLDNO=6.14, returns "" if no ancestor has a value, internal=0
|
|
;if ANY ancestor is 0; else 1.
|
|
; Requires FILEDA, FLDNO. If FLDNO = 1 or 2, requires SUBFDA,
|
|
;SUBFLDNO. See SETFLDS.
|
|
; Optional PFILEDA=anticipated parent IFN for ADD ITEMS, etc.
|
|
; If EIFORM="E", returns in VALUE("E") the external value; else
|
|
;returns VALUE("E")=""
|
|
; Returns AFILEDA= IFN of ancestor used, if none, 0.
|
|
; 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
|
|
N PNODE,NODENO,ZZCONT,C,Y
|
|
S (VALUE,VALUE("E"))=""
|
|
I '$D(EIFORM) S EIFORM="I"
|
|
S:'$G(SUBFLDNO) SUBFLDNO=0 S:'$G(SUBFDA) SUBFDA=0
|
|
S:'PFILEDA PFILEDA=$O(^TIU(8925.1,"AD",FILEDA,0)) G:'PFILEDA INHEX
|
|
S NODENO=$S((FLDNO=6.1)!(FLDNO=6.12)!(FLDNO=6.13)!(FLDNO=6.14):6.1,(FLDNO=3.03):3,1:FLDNO)
|
|
S PNODE=$G(^TIU(8925.1,PFILEDA,NODENO)) I PNODE="" G AGAIN
|
|
I FLDNO=6.14 S VALUE=$P(PNODE,U,4) G:VALUE=0 INHEX G:VALUE="" AGAIN
|
|
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)
|
|
G:VALUE'="" INHEX
|
|
AGAIN D INHERIT(PFILEDA,0,FLDNO,EIFORM,SUBFDA,SUBFLDNO,.VALUE,.AFILEDA)
|
|
INHEX S AFILEDA=+PFILEDA
|
|
I VALUE'="",EIFORM="E" D
|
|
. I FLDNO=1 S C=$P(^DD(8925.11,SUBFLDNO,0),U,2),Y=VALUE D Y^DIQ S VALUE("E")=Y Q
|
|
. I FLDNO=2 S C=$P(^DD(8925.12,SUBFLDNO,0),U,2),Y=VALUE D Y^DIQ S VALUE("E")=Y Q
|
|
. S C=$P(^DD(8925.1,FLDNO,0),U,2),Y=VALUE D Y^DIQ S VALUE("E")=Y Q
|
|
Q
|
|
;
|
|
MULTILN(TIUREC,LASTLIN,FLDNAME) ; Set FLDNAME and as much as fits of TIUREC
|
|
;into line LASTLIN+1. Set rest of TIUREC into succeeding lines,
|
|
;splitting at words.
|
|
; Requires TIUREC,FLDNAME
|
|
; Requires LASTLIN = Last array line set, if setting array; = Last
|
|
;line to keep before resetting the rest if resetting array.
|
|
; Updates LASTLIN to Last array line set by this module.
|
|
N TIUK,TIUL,REST,TIUFT,AVAIL,LINENO
|
|
S AVAIL=79-$L($G(FLDNAME)) D WRAP^TIUFLD(TIUREC,AVAIL)
|
|
S LINENO=LASTLIN+1 ;P77 cleanup
|
|
S ^TMP("TIUF3",$J,LINENO,0)=FLDNAME_": "_TIUFT(1)
|
|
S REST="" F TIUK=2:1 Q:'$D(TIUFT(TIUK)) S REST=REST_TIUFT(TIUK)
|
|
K TIUFT I REST'="" D WRAP^TIUFLD(REST,79)
|
|
F TIUL=1:1 Q:'$D(TIUFT(TIUL)) S LINENO=LINENO+1,^TMP("TIUF3",$J,LINENO,0)=TIUFT(TIUL)
|
|
S LASTLIN=LINENO
|
|
Q
|
|
;
|
|
MMULTILN(TIUREC,LASTLIN,FLDNAME) ;MULTILN for M code (show spaces)
|
|
N TIUK,TIUL,TIUFT,LINENO,FCHAR,LCHAR
|
|
S LINENO=LASTLIN,TIUK=1,FCHAR=1,LCHAR=79-($L($G(FLDNAME))+2)
|
|
F D Q:FCHAR>$L(TIUREC)
|
|
. S TIUFT(TIUK)=$E(TIUREC,FCHAR,LCHAR)
|
|
. S TIUK=TIUK+1,FCHAR=LCHAR+1,LCHAR=FCHAR+78
|
|
S TIUFT(1)=FLDNAME_": "_TIUFT(1)
|
|
F TIUL=1:1 Q:'$D(TIUFT(TIUL)) S LINENO=LINENO+1,^TMP("TIUF3",$J,LINENO,0)=TIUFT(TIUL)
|
|
F TIUL=2:1 Q:'$D(TIUFT(TIUL)) S ^TMP("TIUF3",$J,LINENO,0)=TIUFT(TIUL)
|
|
S LASTLIN=LINENO
|
|
Q
|
|
;
|
|
WRAP(TEXT,LENGTH,FLENGTH) ; Breaks text string into first substring of
|
|
;length FLENGTH; subsequent substrings of length LENGTH;
|
|
;Sets them into array TIUFT with subscripts 1,2,3, etc.
|
|
;Adapted from Joel Russell's WRAP^GMTSORC.
|
|
N TIUFI,TIUFJ,LINE,TIUFT1,TIUFT2,TIUFY
|
|
I $G(TEXT)']"" Q
|
|
F TIUFI=1:1 D Q:TIUFI=$L(TEXT," ")
|
|
. S TIUFT=$P(TEXT," ",TIUFI)
|
|
. I $L(TIUFT)>LENGTH D
|
|
. . S TIUFT1=$E(TIUFT,1,LENGTH),TIUFT2=$E(TIUFT,LENGTH+1,$L(TIUFT))
|
|
. . S $P(TEXT," ",TIUFI)=TIUFT1_" "_TIUFT2
|
|
S LINE=1,TIUFT(1)=$P(TEXT," ")
|
|
F TIUFI=2:1 D Q:TIUFI'<$L(TEXT," ")
|
|
. S:$L($G(TIUFT(LINE))_" "_$P(TEXT," ",TIUFI))>LENGTH LINE=LINE+1,TIUFY=1
|
|
. S TIUFT(LINE)=$G(TIUFT(LINE))_$S(+$G(TIUFY):"",1:" ")_$P(TEXT," ",TIUFI),TIUFY=0
|
|
Q
|
|
;
|