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
 ;