- TIUFD1 ; SLC/MAM - LM Template DSUPLOAD(LASTLIN), DSEMBED(LASTLIN) ;03-Jan-2006 11:20;MGH
- ;;1.0;TEXT INTEGRATION UTILITIES;**1003**;Jun 20, 1997
- ;IHS/CIA/MGH Added line to call routine to display the description
- ;
- DSEMBED(LASTLIN) ; Set/Update Display Array TIUF3 starting with Object Embedded in Titles
- ; See DSBASICS for required variables, etc.
- ; Called by subtemplate D when OBJECTDA is object
- ; Sets ^TMP("TIUFEMBED",$J,OBJECTDA,SUBSCPT,"ANY",FILEDA), for SUBSCPTs
- ;TIUFTL,TIUFCO,TIUFORPHAN.
- N LINENO,TITLEDA,OBJECTDA,TIUREC,NODE0,IFN,TYPE,HASIT,OLDLNO,INFO
- N ORPHANDA
- S LINENO=LASTLIN,OBJECTDA=TIUFINFO("FILEDA"),TYPE=$P(TIUFNOD0,U,4)
- S TIUFELIN=LASTLIN
- I TYPE'="O" G DSEMX
- K ^TMP("TIUFEMBED",$J,OBJECTDA) D EMBED^TIUFLJ(OBJECTDA,TIUFNOD0,"ANY",1)
- TITLE I '$O(^TMP("TIUFEMBED",$J,OBJECTDA,"TIUFTL","ANY",0)) G ORPHAN
- S LINENO=LINENO+1,^TMP("TIUF3",$J,LINENO,0)="",IFN=$S("NM"[TIUFWHO:"IFN",1:" ")
- S LINENO=LINENO+1,^TMP("TIUF3",$J,LINENO,0)=" Object is Embedded in Title(s) Status Owner "_IFN
- S TITLEDA=0,OLDLNO=LINENO
- F S TITLEDA=$O(^TMP("TIUFEMBED",$J,OBJECTDA,"TIUFTL","ANY",TITLEDA)) Q:'TITLEDA D G:$D(DTOUT) DSEMX
- . S LINENO=LINENO+1 D NINFO^TIUFLLM(LINENO,TITLEDA,.INFO),PARSE^TIUFLLM(.INFO),NODE0ARR^TIUFLF(TITLEDA,.NODE0) Q:$D(DTOUT)
- . D BUFENTRY^TIUFLLM2(.INFO,.NODE0,"O")
- D UPDATE^TIUFLLM1("O",LINENO-OLDLNO,OLDLNO) K ^TMP("TIUFB",$J)
- ORPHAN I '$O(^TMP("TIUFEMBED",$J,OBJECTDA,"TIUFORPHAN","ANY",0)) G DSEMX
- S LINENO=LINENO+1,^TMP("TIUF3",$J,LINENO,0)="",IFN=$S("NM"[TIUFWHO:"IFN",1:" ")
- S LINENO=LINENO+1,^TMP("TIUF3",$J,LINENO,0)=" Object is Embedded in Orphan Component(s) Status Owner "_IFN
- S ORPHANDA=0,OLDLNO=LINENO
- F S ORPHANDA=$O(^TMP("TIUFEMBED",$J,OBJECTDA,"TIUFORPHAN","ANY",ORPHANDA)) Q:'ORPHANDA D G:$D(DTOUT) DSEMX
- . S LINENO=LINENO+1 D NINFO^TIUFLLM(LINENO,ORPHANDA,.INFO),PARSE^TIUFLLM(.INFO),NODE0ARR^TIUFLF(ORPHANDA,.NODE0) Q:$D(DTOUT)
- . D BUFENTRY^TIUFLLM2(.INFO,.NODE0,"O")
- D UPDATE^TIUFLLM1("O",LINENO-OLDLNO,OLDLNO) K ^TMP("TIUFB",$J)
- DSEMX S LASTLIN=LINENO Q:$D(DTOUT) D DSUPLOAD(.LASTLIN)
- Q
- ;
- DSUPLOAD(LASTLIN) ; Set/Update Display Array TIUF3 starting with Upload.
- ; See DSBASICS for required variables, etc.
- ; CAlled by subtemp D and T
- N LINENO,CNT,TIUI,FILEDA,FLDNO,HEADFLG,ITEMFLG,TIUM,CAPDEL
- N DIC,DR,DIQ,DA,TARGET,AFILEDA,TYPE,SUBFLDNO
- S (TIUFULIN,LINENO)=LASTLIN,TYPE=$P(TIUFNOD0,U,4)
- I "NM"'[TIUFWHO G DSUPX
- I TYPE'="CL",TYPE'="DC",TYPE'="DOC" G DSUPX
- ;If called to redisplay edited screen rather than by Init, kill array starting with Upload before resetting array.
- S CNT=$O(^TMP("TIUF3",$J,1000000),-1)
- F TIUI=LASTLIN+1:1:CNT K ^TMP("TIUF3",$J,TIUI),^TMP("TIUF3IDX",$J,TIUI)
- S FILEDA=TIUFINFO("FILEDA")
- S LINENO=LINENO+1,^TMP("TIUF3",$J,LINENO,0)=""
- S LINENO=LINENO+1,^TMP("TIUF3",$J,LINENO,0)=" Upload"
- I $G(^TIU(8925.1,FILEDA,1))="",'$D(^TIU(8925.1,FILEDA,"HEAD",0)),'$D(^TIU(8925.1,FILEDA,"ITEM",0)) G DSUPX
- K TIUFQ
- S DIC=8925.1,DR="1.01:1.03;4;4.5;4.8",DIQ(0)="I,E",DA=FILEDA,DIQ="TIUFQ" D EN^DIQ1
- F FLDNO=1.01,1.02,1.03,4,4.5,4.8 D
- . D SETFLD^TIUFLD(FILEDA,.LINENO,FLDNO)
- . Q
- K TIUFQ
- UPHEAD ;
- S (HEADFLG,ITEMFLG)=0
- S:$O(^TIU(8925.1,FILEDA,"HEAD",0)) HEADFLG=1
- S:$O(^TIU(8925.1,FILEDA,"ITEM",0)) ITEMFLG=1
- F TIUM="HEAD","ITEM" D G:$D(VALMQUIT) DSUPX
- . Q:'@(TIUM_"FLG")
- . N TIUJ
- . I TIUM="HEAD" S CAPDEL=" Captioned",FLDNO=2
- . E S CAPDEL=" Delimited",FLDNO=1
- . S LINENO=LINENO+1,^TMP("TIUF3",$J,LINENO,0)=""
- . S LINENO=LINENO+1,^TMP("TIUF3",$J,LINENO,0)=CAPDEL_" ASCII Record Header"
- . S TIUJ=0 K TIUFQ
- . F S TIUJ=$O(^TIU(8925.1,FILEDA,TIUM,TIUJ)) Q:'TIUJ D Q:$D(VALMQUIT)
- . . S LINENO=LINENO+1,^TMP("TIUF3",$J,LINENO,0)=""
- . . S DIC=8925.1,DR=FLDNO,DA=FILEDA,DR(8925.1_FLDNO)=".01:1"
- . . S DA(8925.1_FLDNO)=TIUJ,DIQ(0)="I,E",DIQ="TIUFQ" D EN^DIQ1
- . . F SUBFLDNO=.01:.01:.04,1,.05:.01:.07 D
- . . . D SETFLD^TIUFLD(FILEDA,.LINENO,FLDNO,TIUJ,SUBFLDNO)
- . . K TIUFQ
- . . Q
- . Q
- DSUPX ; IHS/CIA/MGH ADDED LINES FOR DESCRIPTION MGH
- ;S LASTLIN=LINENO
- K TIUFQ S LASTLIN=LINENO Q:$D(DTOUT) D DESC^BTIUFD(.LASTLIN)
- Q
- ;
- TIUFD1 ; SLC/MAM - LM Template DSUPLOAD(LASTLIN), DSEMBED(LASTLIN) ;03-Jan-2006 11:20;MGH
- +1 ;;1.0;TEXT INTEGRATION UTILITIES;**1003**;Jun 20, 1997
- +2 ;IHS/CIA/MGH Added line to call routine to display the description
- +3 ;
- DSEMBED(LASTLIN) ; Set/Update Display Array TIUF3 starting with Object Embedded in Titles
- +1 ; See DSBASICS for required variables, etc.
- +2 ; Called by subtemplate D when OBJECTDA is object
- +3 ; Sets ^TMP("TIUFEMBED",$J,OBJECTDA,SUBSCPT,"ANY",FILEDA), for SUBSCPTs
- +4 ;TIUFTL,TIUFCO,TIUFORPHAN.
- +5 NEW LINENO,TITLEDA,OBJECTDA,TIUREC,NODE0,IFN,TYPE,HASIT,OLDLNO,INFO
- +6 NEW ORPHANDA
- +7 SET LINENO=LASTLIN
- SET OBJECTDA=TIUFINFO("FILEDA")
- SET TYPE=$PIECE(TIUFNOD0,U,4)
- +8 SET TIUFELIN=LASTLIN
- +9 IF TYPE'="O"
- GOTO DSEMX
- +10 KILL ^TMP("TIUFEMBED",$JOB,OBJECTDA)
- DO EMBED^TIUFLJ(OBJECTDA,TIUFNOD0,"ANY",1)
- TITLE IF '$ORDER(^TMP("TIUFEMBED",$JOB,OBJECTDA,"TIUFTL","ANY",0))
- GOTO ORPHAN
- +1 SET LINENO=LINENO+1
- SET ^TMP("TIUF3",$JOB,LINENO,0)=""
- SET IFN=$SELECT("NM"[TIUFWHO:"IFN",1:" ")
- +2 SET LINENO=LINENO+1
- SET ^TMP("TIUF3",$JOB,LINENO,0)=" Object is Embedded in Title(s) Status Owner "_IFN
- +3 SET TITLEDA=0
- SET OLDLNO=LINENO
- +4 FOR
- SET TITLEDA=$ORDER(^TMP("TIUFEMBED",$JOB,OBJECTDA,"TIUFTL","ANY",TITLEDA))
- IF 'TITLEDA
- QUIT
- Begin DoDot:1
- +5 SET LINENO=LINENO+1
- DO NINFO^TIUFLLM(LINENO,TITLEDA,.INFO)
- DO PARSE^TIUFLLM(.INFO)
- DO NODE0ARR^TIUFLF(TITLEDA,.NODE0)
- IF $DATA(DTOUT)
- QUIT
- +6 DO BUFENTRY^TIUFLLM2(.INFO,.NODE0,"O")
- End DoDot:1
- IF $DATA(DTOUT)
- GOTO DSEMX
- +7 DO UPDATE^TIUFLLM1("O",LINENO-OLDLNO,OLDLNO)
- KILL ^TMP("TIUFB",$JOB)
- ORPHAN IF '$ORDER(^TMP("TIUFEMBED",$JOB,OBJECTDA,"TIUFORPHAN","ANY",0))
- GOTO DSEMX
- +1 SET LINENO=LINENO+1
- SET ^TMP("TIUF3",$JOB,LINENO,0)=""
- SET IFN=$SELECT("NM"[TIUFWHO:"IFN",1:" ")
- +2 SET LINENO=LINENO+1
- SET ^TMP("TIUF3",$JOB,LINENO,0)=" Object is Embedded in Orphan Component(s) Status Owner "_IFN
- +3 SET ORPHANDA=0
- SET OLDLNO=LINENO
- +4 FOR
- SET ORPHANDA=$ORDER(^TMP("TIUFEMBED",$JOB,OBJECTDA,"TIUFORPHAN","ANY",ORPHANDA))
- IF 'ORPHANDA
- QUIT
- Begin DoDot:1
- +5 SET LINENO=LINENO+1
- DO NINFO^TIUFLLM(LINENO,ORPHANDA,.INFO)
- DO PARSE^TIUFLLM(.INFO)
- DO NODE0ARR^TIUFLF(ORPHANDA,.NODE0)
- IF $DATA(DTOUT)
- QUIT
- +6 DO BUFENTRY^TIUFLLM2(.INFO,.NODE0,"O")
- End DoDot:1
- IF $DATA(DTOUT)
- GOTO DSEMX
- +7 DO UPDATE^TIUFLLM1("O",LINENO-OLDLNO,OLDLNO)
- KILL ^TMP("TIUFB",$JOB)
- DSEMX SET LASTLIN=LINENO
- IF $DATA(DTOUT)
- QUIT
- DO DSUPLOAD(.LASTLIN)
- +1 QUIT
- +2 ;
- DSUPLOAD(LASTLIN) ; Set/Update Display Array TIUF3 starting with Upload.
- +1 ; See DSBASICS for required variables, etc.
- +2 ; CAlled by subtemp D and T
- +3 NEW LINENO,CNT,TIUI,FILEDA,FLDNO,HEADFLG,ITEMFLG,TIUM,CAPDEL
- +4 NEW DIC,DR,DIQ,DA,TARGET,AFILEDA,TYPE,SUBFLDNO
- +5 SET (TIUFULIN,LINENO)=LASTLIN
- SET TYPE=$PIECE(TIUFNOD0,U,4)
- +6 IF "NM"'[TIUFWHO
- GOTO DSUPX
- +7 IF TYPE'="CL"
- IF TYPE'="DC"
- IF TYPE'="DOC"
- GOTO DSUPX
- +8 ;If called to redisplay edited screen rather than by Init, kill array starting with Upload before resetting array.
- +9 SET CNT=$ORDER(^TMP("TIUF3",$JOB,1000000),-1)
- +10 FOR TIUI=LASTLIN+1:1:CNT
- KILL ^TMP("TIUF3",$JOB,TIUI),^TMP("TIUF3IDX",$JOB,TIUI)
- +11 SET FILEDA=TIUFINFO("FILEDA")
- +12 SET LINENO=LINENO+1
- SET ^TMP("TIUF3",$JOB,LINENO,0)=""
- +13 SET LINENO=LINENO+1
- SET ^TMP("TIUF3",$JOB,LINENO,0)=" Upload"
- +14 IF $GET(^TIU(8925.1,FILEDA,1))=""
- IF '$DATA(^TIU(8925.1,FILEDA,"HEAD",0))
- IF '$DATA(^TIU(8925.1,FILEDA,"ITEM",0))
- GOTO DSUPX
- +15 KILL TIUFQ
- +16 SET DIC=8925.1
- SET DR="1.01:1.03;4;4.5;4.8"
- SET DIQ(0)="I,E"
- SET DA=FILEDA
- SET DIQ="TIUFQ"
- DO EN^DIQ1
- +17 FOR FLDNO=1.01,1.02,1.03,4,4.5,4.8
- Begin DoDot:1
- +18 DO SETFLD^TIUFLD(FILEDA,.LINENO,FLDNO)
- +19 QUIT
- End DoDot:1
- +20 KILL TIUFQ
- UPHEAD ;
- +1 SET (HEADFLG,ITEMFLG)=0
- +2 IF $ORDER(^TIU(8925.1,FILEDA,"HEAD",0))
- SET HEADFLG=1
- +3 IF $ORDER(^TIU(8925.1,FILEDA,"ITEM",0))
- SET ITEMFLG=1
- +4 FOR TIUM="HEAD","ITEM"
- Begin DoDot:1
- +5 IF '@(TIUM_"FLG")
- QUIT
- +6 NEW TIUJ
- +7 IF TIUM="HEAD"
- SET CAPDEL=" Captioned"
- SET FLDNO=2
- +8 IF '$TEST
- SET CAPDEL=" Delimited"
- SET FLDNO=1
- +9 SET LINENO=LINENO+1
- SET ^TMP("TIUF3",$JOB,LINENO,0)=""
- +10 SET LINENO=LINENO+1
- SET ^TMP("TIUF3",$JOB,LINENO,0)=CAPDEL_" ASCII Record Header"
- +11 SET TIUJ=0
- KILL TIUFQ
- +12 FOR
- SET TIUJ=$ORDER(^TIU(8925.1,FILEDA,TIUM,TIUJ))
- IF 'TIUJ
- QUIT
- Begin DoDot:2
- +13 SET LINENO=LINENO+1
- SET ^TMP("TIUF3",$JOB,LINENO,0)=""
- +14 SET DIC=8925.1
- SET DR=FLDNO
- SET DA=FILEDA
- SET DR(8925.1_FLDNO)=".01:1"
- +15 SET DA(8925.1_FLDNO)=TIUJ
- SET DIQ(0)="I,E"
- SET DIQ="TIUFQ"
- DO EN^DIQ1
- +16 FOR SUBFLDNO=.01:.01:.04,1,.05:.01:.07
- Begin DoDot:3
- +17 DO SETFLD^TIUFLD(FILEDA,.LINENO,FLDNO,TIUJ,SUBFLDNO)
- End DoDot:3
- +18 KILL TIUFQ
- +19 QUIT
- End DoDot:2
- IF $DATA(VALMQUIT)
- QUIT
- +20 QUIT
- End DoDot:1
- IF $DATA(VALMQUIT)
- GOTO DSUPX
- DSUPX ; IHS/CIA/MGH ADDED LINES FOR DESCRIPTION MGH
- +1 ;S LASTLIN=LINENO
- +2 KILL TIUFQ
- SET LASTLIN=LINENO
- IF $DATA(DTOUT)
- QUIT
- DO DESC^BTIUFD(.LASTLIN)
- +3 QUIT
- +4 ;