- 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
- ;
- 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 ;