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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUFLD 8245 printed Oct 16, 2024@18:41:38 Page 2
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 ;;1.0;TEXT INTEGRATION UTILITIES;**14,77,184,211**;Jun 20, 1997;Build 26
+2 ;
SETFLD(FILEDA,LASTLIN,FLDNO,SUBFDA,SUBFLDNO) ; Puts External Field in TMP("TIUF3") for Template D (Display), for FILEDA.
+1 ; Requires Array TIUFQ as set in TIUFD, TIUFD1.
+2 ; Requires FILEDA=DA in file.
+3 ; Requires LASTLIN = Last array line set, if setting array; = Last
+4 ;line to keep before resetting the rest if resetting array.
+5 ; Updates LASTLIN to Last array line set by this module.
+6 ; 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.
+7 ; For FLDNO 0, sets IFN=FILEDA
+8 ; For FLDNO 1 and 2, requires SUBFLDNO from list: .01, .02, .03, .04, .05, .06, .07, .1
+9 ; For FLDNO 1 and 2, requires SUBFDA=DA in subfile.
+10 ; For FLDNO .05, combines .05 and .06 into Owner (one value).
+11 NEW TIUREC,LINENO,AVAIL,FLDNAME,NODE1,ZZCONT,FLDNAME1,UPFIELD,UPFILE,UPMSG
+12 NEW FIELDNO,FDA,TYPE,POWNER,COWNER,LP,LC,OWNER,FLDVAL,FILENO,LENGTH
+13 NEW TIUCKUP,TIUFTEMP
+14 if '$GET(SUBFLDNO)
SET SUBFLDNO=0
if '$GET(SUBFDA)
SET SUBFDA=0
+15 SET FLDNAME=$SELECT(FLDNO=.05:"OWNER^BASICS",$GET(SUBFLDNO):^TMP("TIUF",$JOB,FLDNO,SUBFLDNO,"LABEL"),1:^TMP("TIUF",$JOB,FLDNO,"LABEL"))
SET LENGTH=$PIECE(FLDNAME,U,2)
SET FLDNAME=$PIECE(FLDNAME,U)
+16 SET LENGTH=$SELECT(LENGTH="BASICS":16,LENGTH="TECH":20,LENGTH="UPLOAD":29,1:26)
+17 if FLDNO
SET FLDNAME=$$MIXED^TIULS(FLDNAME)
+18 if FLDNO=.15
SET FLDNAME="PRF Flag"
SET LENGTH=16
+19 if FLDNO=1501
SET FLDNAME="VHA Enterprise Standard Title"
SET LENGTH=16
+20 IF $LENGTH(FLDNAME)>LENGTH
if $LENGTH(FLDNAME," ")=2
SET FLDNAME1=$PIECE(FLDNAME," ")
SET FLDNAME=$PIECE(FLDNAME," ",2)
if $LENGTH(FLDNAME," ")>2
SET FLDNAME1=$PIECE(FLDNAME," ",1,2)
SET FLDNAME=$PIECE(FLDNAME," ",3,5)
SET FLDNAME1=$JUSTIFY(FLDNAME1,LENGTH)
+21 SET AVAIL=77-$LENGTH(FLDNAME)
SET TYPE=$PIECE(TIUFNOD0,U,4)
+22 SET FLDNAME=$JUSTIFY(FLDNAME,LENGTH)
+23 IF FLDNO=.05
Begin DoDot:1
+24 SET POWNER=TIUFQ(8925.1,FILEDA,.05,"E")
SET COWNER=TIUFQ(8925.1,FILEDA,.06,"E")
+25 SET LP=$LENGTH(POWNER)
SET LC=$LENGTH(COWNER)
+26 SET OWNER=$SELECT(LP&'LC:POWNER,LC&'LP:COWNER,LP&LC:$EXTRACT(POWNER,1,30)_","_$EXTRACT(COWNER,1,30),1:"None")
+27 SET TIUREC=OWNER
End DoDot:1
GOTO SETFLD2
+28 SET FILENO=8925.1_$SELECT(FLDNO=1!(FLDNO=2):FLDNO,1:"")
+29 SET FIELDNO=$SELECT($GET(SUBFLDNO):SUBFLDNO,1:FLDNO)
+30 SET FDA=$SELECT($GET(SUBFDA):SUBFDA,1:FILEDA)
+31 IF FLDNO=.07
IF $PIECE(TIUFNOD0,U,10)
SET TIUREC=""
GOTO SETFX
+32 SET TIUREC=$GET(TIUFQ(FILENO,FDA,FIELDNO,"E"))
+33 IF FLDNO=.08
IF TIUREC="NA"
GOTO SETFX
+34 IF FLDNO=.15
IF TIUREC="NA"
GOTO SETFX
+35 IF FLDNO=.1!(FLDNO=.13)!(FLDNO=3.02)
IF TIUREC=""
SET TIUREC="NO"
+36 ; Sets IFN
IF FLDNO=0
SET TIUREC=FILEDA
+37 ; not heritable.
if FLDNO<1
GOTO SETFLD2
+38 SET NODE1=$GET(^TIU(8925.1,FILEDA,1))
+39 IF FLDNO=1.01
Begin DoDot:1
+40 IF $PIECE(NODE1,U)=""
SET TIUREC=""
QUIT
+41 DO FILE^DID($PIECE(NODE1,U),"","NAME","UPFILE")
+42 SET UPMSG=" FILE ERROR; Please Edit Upload"
+43 IF $GET(DIERR)
SET TIUREC=UPMSG
QUIT
+44 SET TIUREC=UPFILE("NAME")
+45 DO CHK^DIE(8925.1,1.01,"",TIUREC,.TIUCKUP)
IF TIUCKUP="^"
SET TIUREC=UPMSG
End DoDot:1
+46 IF FLDNO=1.03
Begin DoDot:1
+47 IF $PIECE(NODE1,U,3)=""
SET TIUREC=""
QUIT
+48 SET UPMSG=" FILE/FIELD/SUBSCRIPT ERROR; Please Edit Upload"
+49 DO FIELD^DID($PIECE(NODE1,U),+$PIECE($PIECE(NODE1,U,3),";"),"","LABEL;GLOBAL SUBSCRIPT LOCATION","UPFIELD")
+50 IF $GET(DIERR)
SET TIUREC=UPMSG
QUIT
+51 IF UPFIELD("GLOBAL SUBSCRIPT LOCATION")'=($PIECE($PIECE(NODE1,U,3),";",2)_";0")
SET TIUREC=UPMSG
QUIT
+52 SET TIUREC=UPFIELD("LABEL")
End DoDot:1
+53 ;Upload flds, not heritable.
IF FLDNO'<1
IF FLDNO<3
GOTO SETFLD2
+54 ; not heritable.
if FLDNO=3.02!(FLDNO=4)!(FLDNO=4.5)!(FLDNO=4.8)
GOTO SETFLD2
SETFLD1 ; Technical fields, others which are heritable.
+1 IF TIUREC'=""
SET TIUREC=" "_TIUREC
+2 ;P77
IF TIUREC=""
DO INHERIT(FILEDA,0,FLDNO,"E",SUBFDA,SUBFLDNO,.FLDVAL)
SET TIUREC=FLDVAL
SET TIUREC=$SELECT(FLDVAL("E")'="":"* "_FLDVAL("E"),FLDNO=3.03&(FILEDA=38):" NO (by default)",FLDNO=3.03:"* NO",1:"")
SETFLD2 IF $DATA(FLDNAME1)
SET LASTLIN=LASTLIN+1
SET ^TMP("TIUF3",$JOB,LASTLIN,0)=FLDNAME1
+1 IF FLDNO<1!(FLDNO=3.02)
IF TIUREC'=""
SET TIUREC=" "_TIUREC
+2 IF $LENGTH(TIUREC)'>AVAIL
SET LASTLIN=LASTLIN+1
SET ^TMP("TIUF3",$JOB,LASTLIN,0)=FLDNAME_": "_TIUREC
GOTO SETFX
+3 IF FLDNO'<4
DO FIELD^DID(8925.1,FLDNO,"","TYPE","TIUFTEMP")
IF TIUFTEMP("TYPE")="MUMPS"
DO MMULTILN(TIUREC,.LASTLIN,FLDNAME)
GOTO SETFX
+4 ;Upload caption transform code
IF FLDNO=1!(FLDNO=2)
IF $GET(SUBFLDNO)=1
DO MMULTILN(TIUREC,.LASTLIN,FLDNAME)
GOTO SETFX
+5 DO MULTILN(TIUREC,.LASTLIN,FLDNAME)
SETFX DO CLEAN^DILF
+1 QUIT
+2 ;
INHERIT(FILEDA,PFILEDA,FLDNO,EIFORM,SUBFDA,SUBFLDNO,VALUE,AFILEDA) ;
+1 ; Can't make it a function with pieces since pieces may contain ^.
+2 ; For FLDNO'=6.14, Returns in VALUE the Field Value for first ancestor
+3 ;of FILEDA that has a field value. If not found, returns "".
+4 ; For FLDNO=6.14, returns "" if no ancestor has a value, internal=0
+5 ;if ANY ancestor is 0; else 1.
+6 ; Requires FILEDA, FLDNO. If FLDNO = 1 or 2, requires SUBFDA,
+7 ;SUBFLDNO. See SETFLDS.
+8 ; Optional PFILEDA=anticipated parent IFN for ADD ITEMS, etc.
+9 ; If EIFORM="E", returns in VALUE("E") the external value; else
+10 ;returns VALUE("E")=""
+11 ; Returns AFILEDA= IFN of ancestor used, if none, 0.
+12 ; 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
+13 NEW PNODE,NODENO,ZZCONT,C,Y
+14 SET (VALUE,VALUE("E"))=""
+15 IF '$DATA(EIFORM)
SET EIFORM="I"
+16 if '$GET(SUBFLDNO)
SET SUBFLDNO=0
if '$GET(SUBFDA)
SET SUBFDA=0
+17 if 'PFILEDA
SET PFILEDA=$ORDER(^TIU(8925.1,"AD",FILEDA,0))
if 'PFILEDA
GOTO INHEX
+18 SET NODENO=$SELECT((FLDNO=6.1)!(FLDNO=6.12)!(FLDNO=6.13)!(FLDNO=6.14):6.1,(FLDNO=3.03):3,1:FLDNO)
+19 SET PNODE=$GET(^TIU(8925.1,PFILEDA,NODENO))
IF PNODE=""
GOTO AGAIN
+20 IF FLDNO=6.14
SET VALUE=$PIECE(PNODE,U,4)
if VALUE=0
GOTO INHEX
if VALUE=""
GOTO AGAIN
+21 SET VALUE=$SELECT(FLDNO=6.1:$PIECE(PNODE,U),FLDNO=6.12:$PIECE(PNODE,U,2),FLDNO=6.13:$PIECE(PNODE,U,3),FLDNO=6.14:$PIECE(PNODE,U,4),FLDNO=3.03:$PIECE(PNODE,U,3),1:PNODE)
+22 if VALUE'=""
GOTO INHEX
AGAIN DO INHERIT(PFILEDA,0,FLDNO,EIFORM,SUBFDA,SUBFLDNO,.VALUE,.AFILEDA)
INHEX SET AFILEDA=+PFILEDA
+1 IF VALUE'=""
IF EIFORM="E"
Begin DoDot:1
+2 IF FLDNO=1
SET C=$PIECE(^DD(8925.11,SUBFLDNO,0),U,2)
SET Y=VALUE
DO Y^DIQ
SET VALUE("E")=Y
QUIT
+3 IF FLDNO=2
SET C=$PIECE(^DD(8925.12,SUBFLDNO,0),U,2)
SET Y=VALUE
DO Y^DIQ
SET VALUE("E")=Y
QUIT
+4 SET C=$PIECE(^DD(8925.1,FLDNO,0),U,2)
SET Y=VALUE
DO Y^DIQ
SET VALUE("E")=Y
QUIT
End DoDot:1
+5 QUIT
+6 ;
MULTILN(TIUREC,LASTLIN,FLDNAME) ; Set FLDNAME and as much as fits of TIUREC
+1 ;into line LASTLIN+1. Set rest of TIUREC into succeeding lines,
+2 ;splitting at words.
+3 ; Requires TIUREC,FLDNAME
+4 ; Requires LASTLIN = Last array line set, if setting array; = Last
+5 ;line to keep before resetting the rest if resetting array.
+6 ; Updates LASTLIN to Last array line set by this module.
+7 NEW TIUK,TIUL,REST,TIUFT,AVAIL,LINENO
+8 SET AVAIL=79-$LENGTH($GET(FLDNAME))
DO WRAP^TIUFLD(TIUREC,AVAIL)
+9 ;P77 cleanup
SET LINENO=LASTLIN+1
+10 SET ^TMP("TIUF3",$JOB,LINENO,0)=FLDNAME_": "_TIUFT(1)
+11 SET REST=""
FOR TIUK=2:1
if '$DATA(TIUFT(TIUK))
QUIT
SET REST=REST_TIUFT(TIUK)
+12 KILL TIUFT
IF REST'=""
DO WRAP^TIUFLD(REST,79)
+13 FOR TIUL=1:1
if '$DATA(TIUFT(TIUL))
QUIT
SET LINENO=LINENO+1
SET ^TMP("TIUF3",$JOB,LINENO,0)=TIUFT(TIUL)
+14 SET LASTLIN=LINENO
+15 QUIT
+16 ;
MMULTILN(TIUREC,LASTLIN,FLDNAME) ;MULTILN for M code (show spaces)
+1 NEW TIUK,TIUL,TIUFT,LINENO,FCHAR,LCHAR
+2 SET LINENO=LASTLIN
SET TIUK=1
SET FCHAR=1
SET LCHAR=79-($LENGTH($GET(FLDNAME))+2)
+3 FOR
Begin DoDot:1
+4 SET TIUFT(TIUK)=$EXTRACT(TIUREC,FCHAR,LCHAR)
+5 SET TIUK=TIUK+1
SET FCHAR=LCHAR+1
SET LCHAR=FCHAR+78
End DoDot:1
if FCHAR>$LENGTH(TIUREC)
QUIT
+6 SET TIUFT(1)=FLDNAME_": "_TIUFT(1)
+7 FOR TIUL=1:1
if '$DATA(TIUFT(TIUL))
QUIT
SET LINENO=LINENO+1
SET ^TMP("TIUF3",$JOB,LINENO,0)=TIUFT(TIUL)
+8 FOR TIUL=2:1
if '$DATA(TIUFT(TIUL))
QUIT
SET ^TMP("TIUF3",$JOB,LINENO,0)=TIUFT(TIUL)
+9 SET LASTLIN=LINENO
+10 QUIT
+11 ;
WRAP(TEXT,LENGTH,FLENGTH) ; Breaks text string into first substring of
+1 ;length FLENGTH; subsequent substrings of length LENGTH;
+2 ;Sets them into array TIUFT with subscripts 1,2,3, etc.
+3 ;Adapted from Joel Russell's WRAP^GMTSORC.
+4 NEW TIUFI,TIUFJ,LINE,TIUFT1,TIUFT2,TIUFY
+5 IF $GET(TEXT)']""
QUIT
+6 FOR TIUFI=1:1
Begin DoDot:1
+7 SET TIUFT=$PIECE(TEXT," ",TIUFI)
+8 IF $LENGTH(TIUFT)>LENGTH
Begin DoDot:2
+9 SET TIUFT1=$EXTRACT(TIUFT,1,LENGTH)
SET TIUFT2=$EXTRACT(TIUFT,LENGTH+1,$LENGTH(TIUFT))
+10 SET $PIECE(TEXT," ",TIUFI)=TIUFT1_" "_TIUFT2
End DoDot:2
End DoDot:1
if TIUFI=$LENGTH(TEXT," ")
QUIT
+11 SET LINE=1
SET TIUFT(1)=$PIECE(TEXT," ")
+12 FOR TIUFI=2:1
Begin DoDot:1
+13 if $LENGTH($GET(TIUFT(LINE))_" "_$PIECE(TEXT," ",TIUFI))>LENGTH
SET LINE=LINE+1
SET TIUFY=1
+14 SET TIUFT(LINE)=$GET(TIUFT(LINE))_$SELECT(+$GET(TIUFY):"",1:" ")_$PIECE(TEXT," ",TIUFI)
SET TIUFY=0
End DoDot:1
if TIUFI'<$LENGTH(TEXT," ")
QUIT
+15 QUIT
+16 ;
