- TIUFC1 ; SLC/MAM - LM Template C (Create DDEF) Action Create ;7/7/06 15:44
- ;;1.0;TEXT INTEGRATION UTILITIES;**211**;Jun 20, 1997;Build 26
- ;
- CREATE ; TEMPLATE C Action Create.
- ; C in CNODE0, CSTATUS stands for Current position
- N DIC,DIE,DR,DLAYGO,X,Y,CREATE0,DA,DIK,PFILEDA,TENDA,MSG,PLINENO,PINFO,CREATE,FIELDS,NEWSTAT,NAME,TIUFXNOD,SHARED,NEWYES,SHARYES,CNODE0,LINENO
- N DIR,X,Y,DA,NAME,TIUFFULL,CSTATUS,TIUFTMSG,TIUFTLST,TIUFIMSG,SEQUENCE
- N DUOUT,DTOUT,DIRUT,DIROUT,XFLG
- S CREATE=0,TIUFXNOD=$G(XQORNOD(0)),VALMBCK="",CNODE0=^TIU(8925.1,TIUFCDA,0)
- I $P(CNODE0,U,13),TIUFWHO'="N",$P(CNODE0,U,4)="DOC"!($P(CNODE0,U,4)="CO") W !!," Parent is National, of Type TL or CO; Can't add or delete Items" D PAUSE^TIUFXHLX G CREAX
- ANOTHER L -^TIU(8925.1,+$G(CREATEDA)) L -^TIU(8925.1,+$G(TIUFCDA),10,+$G(TENDA))
- I TIUFCTYP="TL" S CSTATUS=$$STATWORD^TIUFLF5($P(CNODE0,U,7)) I CSTATUS'="INACTIVE" W !!,"Cannot create a Component unless the parent Title is Inactive.",! D PAUSE^TIUFXHLX G CREAX
- N DIR S DIR(0)="FAO^3:60^S X=$$UPPER^TIULS(X) K:'(X'?1P.E) X",(DIR("?"),DIR("??"))="^D NAME^TIUFXHLX"
- S:'CREATE DIR("A")=$S(TIUFCTYP="TL":" Enter a new Component of ",1:" Enter the Name of a new ")_TIUFCNM_": "
- S:CREATE DIR("A")=" If you wish, you may enter another "_$S(TIUFCTYP="TL":"Component of ",1:"")_TIUFCNM_": "
- D ^DIR I Y=""!$D(DUOUT) G CREAX
- S NAME=Y,NAME=$$UPPER^TIULS(NAME),(SHARED,NEWYES,SHARYES)=""
- I TIUFCTYP="TL" K DIRUT D Q:$D(DIRUT) G ADD:SHARYES,ANOTHER:NEWYES=0,ANOTHER:SHARYES=0
- . S DIC=8925.1,DIC(0)="Z"
- . S DIC("S")="I ($P(^(0),U,4)=""CO"")&($P(^(0),U,10))"
- . D ^DIC
- . I Y=-1 S DIR("A",1)=" Are you adding '"_NAME_"' as",DIR("A")="a new TIU DOCUMENT DEFINITION?",DIR(0)="Y",DIR("B")="YES" D ^DIR S NEWYES=Y Q
- . I Y>0 W $E($P(Y,U,2),$L(NAME)+1,60) D Q:'SHARYES
- . . S CREATEDA=+Y,CREATENM=$P(Y(0),U)
- . . S DIR("A",1)=" Are you adding shared component '"_$P(Y,U,2)_"' as",DIR("A")="a new Item",DIR("B")="YES",DIR(0)="Y" D ^DIR S SHARYES=Y
- . . I 'SHARYES K CREATEDA,CREATENM
- . I $$DUPITEM^TIUFLF7(CREATENM,TIUFCDA) W !!,TIUFIMSG,! D PAUSE^TIUFXHLX S DIRUT=1 Q
- . S CREATE0=^TIU(8925.1,CREATEDA,0)
- I $$DUPITEM^TIUFLF7(NAME,TIUFCDA) W !!,TIUFIMSG,! D PAUSE^TIUFXHLX G ANOTHER
- D TYPELIST^TIUFLF7(NAME,0,TIUFCDA,.TIUFTMSG,.TIUFTLST) G:$D(DTOUT) CREAX
- I TIUFTLST="" W !!," Please enter a different Name; File already has entries of every permitted Type",!,"with that Name",! D PAUSE^TIUFXHLX G ANOTHER
- N DIC S (DIC,DLAYGO)=8925.1,DIC(0)="L",X=""""_NAME_"""" D ^DIC
- I Y=-1 W !!,"Couldn't Create Entry; See IRM",! D PAUSE^TIUFXHLX G CREAX
- S CREATEDA=+Y,CREATENM=NAME
- L +^TIU(8925.1,CREATEDA):1 I '$T W !!," Another user is editing this entry; please try later.",! H 2 G CREAX
- D STUFFLDS^TIUFLF4(CREATEDA,TIUFCDA)
- S CREATE0=^TIU(8925.1,CREATEDA,0)
- S FIELDS=";.05;.06;" S:$P(CREATE0,U,4)="" FIELDS=";.04"_FIELDS S:TIUFWHO="N" FIELDS=FIELDS_".13;"
- D ASKFLDS^TIUFLF1(CREATEDA,FIELDS,TIUFCDA,.NEWSTAT,.XFLG) G:$D(DTOUT) CREAX
- NOTYPE S CREATE0=^TIU(8925.1,CREATEDA,0)
- I $P(CREATE0,U,4)="" S DA=CREATEDA,DIK="^TIU(8925.1," D ^DIK W !!," "_$E(CREATENM,1,40)," Deleted: No Type.",! D PAUSE^TIUFXHLX G CREAX
- D OWNCHEC^TIUFLF8(CREATEDA)
- ADD S PFILEDA=TIUFCDA
- L +^TIU(8925.1,TIUFCDA):3 I '$T D G ANOTHER
- . W !!,"Another user is editing current branch; can't hang item under parent. Entry",!,"deleted. Please create entry again.",! D PAUSE^TIUFXHLX
- . L -^TIU(8925.1,CREATEDA) S CREATE=0,DA=CREATEDA,DIK="^TIU(8925.1," D ^DIK
- D ADDTEN^TIUFLF4(PFILEDA,CREATEDA,CREATE0,.TENDA)
- L -^TIU(8925.1,TIUFCDA)
- I 'TENDA S VALMQUIT=1 W !!," Can't hang item under parent; See IRM. Entry deleted.",! D PAUSE^TIUFXHLX L -^TIU(8925.1,CREATEDA) S DA=CREATEDA,DIK="^TIU(8925.1," D ^DIK G CREAX
- I '$G(XFLG),'$D(DTOUT),'SHARED S FIELDS=";.07;" S:$P(CREATE0,U,4)="DOC" FIELDS=";1501"_FIELDS D ASKFLDS^TIUFLF1(CREATEDA,FIELDS,TIUFCDA,.NEWSTAT,.XFLG) G:$D(DTOUT) CREAX
- I '$G(XFLG),'$D(DTOUT) L +^TIU(8925.1,TIUFCDA,10,TENDA):1 W:'$T !!," Another user is editing this item; please edit later using Detailed Display for",!,"Current Branch.",! H:'$T 2 G:'$T CREAX D G:$D(DTOUT) CREAX
- . S DA(1)=TIUFCDA,DIE="^TIU(8925.1,DA(1),10,",DA=TENDA
- . S DR="3" D ^DIE I $D(Y)!$D(DTOUT) Q
- . I $P(CNODE0,U,4)="CL" S SEQUENCE=$P(^TIU(8925.1,TIUFCDA,10,TENDA,0),U,3),DR="2///^S X=SEQUENCE" I $L(SEQUENCE)<5,$L(SEQUENCE) D ^DIE ;Stuff mnem with seq value
- . S DR=$S($P(CNODE0,U,4)="CL":"2;4",1:4) D ^DIE
- . L -^TIU(8925.1,TIUFCDA,10,TENDA)
- S VALMBCK="R",MSG=" Entry Created"
- I SHARED S MSG=" Entry Added"
- W !!,MSG,! S CREATE=1 L -^TIU(8925.1,CREATEDA) G ANOTHER
- CREAX L -^TIU(8925.1,+$G(CREATEDA))
- L -^TIU(8925.1,+$G(TIUFCDA),10,+$G(TENDA))
- I $D(DTOUT) S VALMBCK="Q" Q
- S PLINENO=$O(^TMP("TIUF1IDX",$J,"DAF",TIUFCDA,""))
- S PINFO=^TMP("TIUF1IDX",$J,PLINENO)
- D PARSE^TIUFLLM(.PINFO)
- N TIUFSAVE D SAVE(.PINFO) ;Speeds up BUFENTRY^TIUFLLM2
- S VALMCNT=VALMCNT-PINFO("XPDLCNT") D COLLAPSE^TIUFH1(.PINFO)
- D EXPAND1^TIUFH1(.PINFO) S VALMCNT=VALMCNT+PINFO("XPDLCNT")
- S TIUFCITM=$S($P(PINFO,U,3):1,1:0)
- I CREATE K TIUFCMSG D
- . S TIUFCMSG(1)=" Select "_$S(TIUFCTYP="DC":"TITLE",1:"CLASS/DOCUMENTCLASS")_" to create a new "_TIUFCNM
- . S TIUFCMSG(2)="or to Go Down a Level, Select NEXT LEVEL."
- . I VALMCNT>VALM("LINES") S TIUFCMSG(2)="or to Go Down a Level, Screen to (+/-) Desired ",TIUFCMSG(3)=TIUFCNM_" Item, and Select NEXT LEVEL."
- I $G(TIUFFULL) S VALMBCK="R" D RESET^TIUFXHLX
- S LINENO=+$O(^TMP("TIUF1IDX",$J,"DAF",+$G(CREATEDA),0))
- I LINENO,LINENO<VALMBG!(LINENO>(VALMBG+VALM("LINES")-1)) S VALMBG=LINENO
- Q
- SAVE(EINFO) ;
- N LINENO,FILEDA
- F LINENO=+EINFO+1:1:+EINFO+EINFO("XPDLCNT") D Q:$D(DTOUT)
- . S FILEDA=$P(^TMP("TIUF1IDX",$J,LINENO),U,2)
- . S TIUFSAVE(FILEDA)=^TMP("TIUF1",$J,LINENO,0)
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUFC1 5786 printed Mar 13, 2025@21:45:29 Page 2
- TIUFC1 ; SLC/MAM - LM Template C (Create DDEF) Action Create ;7/7/06 15:44
- +1 ;;1.0;TEXT INTEGRATION UTILITIES;**211**;Jun 20, 1997;Build 26
- +2 ;
- CREATE ; TEMPLATE C Action Create.
- +1 ; C in CNODE0, CSTATUS stands for Current position
- +2 NEW DIC,DIE,DR,DLAYGO,X,Y,CREATE0,DA,DIK,PFILEDA,TENDA,MSG,PLINENO,PINFO,CREATE,FIELDS,NEWSTAT,NAME,TIUFXNOD,SHARED,NEWYES,SHARYES,CNODE0,LINENO
- +3 NEW DIR,X,Y,DA,NAME,TIUFFULL,CSTATUS,TIUFTMSG,TIUFTLST,TIUFIMSG,SEQUENCE
- +4 NEW DUOUT,DTOUT,DIRUT,DIROUT,XFLG
- +5 SET CREATE=0
- SET TIUFXNOD=$GET(XQORNOD(0))
- SET VALMBCK=""
- SET CNODE0=^TIU(8925.1,TIUFCDA,0)
- +6 IF $PIECE(CNODE0,U,13)
- IF TIUFWHO'="N"
- IF $PIECE(CNODE0,U,4)="DOC"!($PIECE(CNODE0,U,4)="CO")
- WRITE !!," Parent is National, of Type TL or CO; Can't add or delete Items"
- DO PAUSE^TIUFXHLX
- GOTO CREAX
- ANOTHER LOCK -^TIU(8925.1,+$GET(CREATEDA))
- LOCK -^TIU(8925.1,+$GET(TIUFCDA),10,+$GET(TENDA))
- +1 IF TIUFCTYP="TL"
- SET CSTATUS=$$STATWORD^TIUFLF5($PIECE(CNODE0,U,7))
- IF CSTATUS'="INACTIVE"
- WRITE !!,"Cannot create a Component unless the parent Title is Inactive.",!
- DO PAUSE^TIUFXHLX
- GOTO CREAX
- +2 NEW DIR
- SET DIR(0)="FAO^3:60^S X=$$UPPER^TIULS(X) K:'(X'?1P.E) X"
- SET (DIR("?"),DIR("??"))="^D NAME^TIUFXHLX"
- +3 if 'CREATE
- SET DIR("A")=$SELECT(TIUFCTYP="TL":" Enter a new Component of ",1:" Enter the Name of a new ")_TIUFCNM_": "
- +4 if CREATE
- SET DIR("A")=" If you wish, you may enter another "_$SELECT(TIUFCTYP="TL":"Component of ",1:"")_TIUFCNM_": "
- +5 DO ^DIR
- IF Y=""!$DATA(DUOUT)
- GOTO CREAX
- +6 SET NAME=Y
- SET NAME=$$UPPER^TIULS(NAME)
- SET (SHARED,NEWYES,SHARYES)=""
- +7 IF TIUFCTYP="TL"
- KILL DIRUT
- Begin DoDot:1
- +8 SET DIC=8925.1
- SET DIC(0)="Z"
- +9 SET DIC("S")="I ($P(^(0),U,4)=""CO"")&($P(^(0),U,10))"
- +10 DO ^DIC
- +11 IF Y=-1
- SET DIR("A",1)=" Are you adding '"_NAME_"' as"
- SET DIR("A")="a new TIU DOCUMENT DEFINITION?"
- SET DIR(0)="Y"
- SET DIR("B")="YES"
- DO ^DIR
- SET NEWYES=Y
- QUIT
- +12 IF Y>0
- WRITE $EXTRACT($PIECE(Y,U,2),$LENGTH(NAME)+1,60)
- Begin DoDot:2
- +13 SET CREATEDA=+Y
- SET CREATENM=$PIECE(Y(0),U)
- +14 SET DIR("A",1)=" Are you adding shared component '"_$PIECE(Y,U,2)_"' as"
- SET DIR("A")="a new Item"
- SET DIR("B")="YES"
- SET DIR(0)="Y"
- DO ^DIR
- SET SHARYES=Y
- +15 IF 'SHARYES
- KILL CREATEDA,CREATENM
- End DoDot:2
- if 'SHARYES
- QUIT
- +16 IF $$DUPITEM^TIUFLF7(CREATENM,TIUFCDA)
- WRITE !!,TIUFIMSG,!
- DO PAUSE^TIUFXHLX
- SET DIRUT=1
- QUIT
- +17 SET CREATE0=^TIU(8925.1,CREATEDA,0)
- End DoDot:1
- if $DATA(DIRUT)
- QUIT
- if SHARYES
- GOTO ADD
- if NEWYES=0
- GOTO ANOTHER
- if SHARYES=0
- GOTO ANOTHER
- +18 IF $$DUPITEM^TIUFLF7(NAME,TIUFCDA)
- WRITE !!,TIUFIMSG,!
- DO PAUSE^TIUFXHLX
- GOTO ANOTHER
- +19 DO TYPELIST^TIUFLF7(NAME,0,TIUFCDA,.TIUFTMSG,.TIUFTLST)
- if $DATA(DTOUT)
- GOTO CREAX
- +20 IF TIUFTLST=""
- WRITE !!," Please enter a different Name; File already has entries of every permitted Type",!,"with that Name",!
- DO PAUSE^TIUFXHLX
- GOTO ANOTHER
- +21 NEW DIC
- SET (DIC,DLAYGO)=8925.1
- SET DIC(0)="L"
- SET X=""""_NAME_""""
- DO ^DIC
- +22 IF Y=-1
- WRITE !!,"Couldn't Create Entry; See IRM",!
- DO PAUSE^TIUFXHLX
- GOTO CREAX
- +23 SET CREATEDA=+Y
- SET CREATENM=NAME
- +24 LOCK +^TIU(8925.1,CREATEDA):1
- IF '$TEST
- WRITE !!," Another user is editing this entry; please try later.",!
- HANG 2
- GOTO CREAX
- +25 DO STUFFLDS^TIUFLF4(CREATEDA,TIUFCDA)
- +26 SET CREATE0=^TIU(8925.1,CREATEDA,0)
- +27 SET FIELDS=";.05;.06;"
- if $PIECE(CREATE0,U,4)=""
- SET FIELDS=";.04"_FIELDS
- if TIUFWHO="N"
- SET FIELDS=FIELDS_".13;"
- +28 DO ASKFLDS^TIUFLF1(CREATEDA,FIELDS,TIUFCDA,.NEWSTAT,.XFLG)
- if $DATA(DTOUT)
- GOTO CREAX
- NOTYPE SET CREATE0=^TIU(8925.1,CREATEDA,0)
- +1 IF $PIECE(CREATE0,U,4)=""
- SET DA=CREATEDA
- SET DIK="^TIU(8925.1,"
- DO ^DIK
- WRITE !!," "_$EXTRACT(CREATENM,1,40)," Deleted: No Type.",!
- DO PAUSE^TIUFXHLX
- GOTO CREAX
- +2 DO OWNCHEC^TIUFLF8(CREATEDA)
- ADD SET PFILEDA=TIUFCDA
- +1 LOCK +^TIU(8925.1,TIUFCDA):3
- IF '$TEST
- Begin DoDot:1
- +2 WRITE !!,"Another user is editing current branch; can't hang item under parent. Entry",!,"deleted. Please create entry again.",!
- DO PAUSE^TIUFXHLX
- +3 LOCK -^TIU(8925.1,CREATEDA)
- SET CREATE=0
- SET DA=CREATEDA
- SET DIK="^TIU(8925.1,"
- DO ^DIK
- End DoDot:1
- GOTO ANOTHER
- +4 DO ADDTEN^TIUFLF4(PFILEDA,CREATEDA,CREATE0,.TENDA)
- +5 LOCK -^TIU(8925.1,TIUFCDA)
- +6 IF 'TENDA
- SET VALMQUIT=1
- WRITE !!," Can't hang item under parent; See IRM. Entry deleted.",!
- DO PAUSE^TIUFXHLX
- LOCK -^TIU(8925.1,CREATEDA)
- SET DA=CREATEDA
- SET DIK="^TIU(8925.1,"
- DO ^DIK
- GOTO CREAX
- +7 IF '$GET(XFLG)
- IF '$DATA(DTOUT)
- IF 'SHARED
- SET FIELDS=";.07;"
- if $PIECE(CREATE0,U,4)="DOC"
- SET FIELDS=";1501"_FIELDS
- DO ASKFLDS^TIUFLF1(CREATEDA,FIELDS,TIUFCDA,.NEWSTAT,.XFLG)
- if $DATA(DTOUT)
- GOTO CREAX
- +8 IF '$GET(XFLG)
- IF '$DATA(DTOUT)
- LOCK +^TIU(8925.1,TIUFCDA,10,TENDA):1
- if '$TEST
- WRITE !!," Another user is editing this item; please edit later using Detailed Display for",!,"Current Branch.",!
- if '$TEST
- HANG 2
- if '$TEST
- GOTO CREAX
- Begin DoDot:1
- +9 SET DA(1)=TIUFCDA
- SET DIE="^TIU(8925.1,DA(1),10,"
- SET DA=TENDA
- +10 SET DR="3"
- DO ^DIE
- IF $DATA(Y)!$DATA(DTOUT)
- QUIT
- +11 ;Stuff mnem with seq value
- IF $PIECE(CNODE0,U,4)="CL"
- SET SEQUENCE=$PIECE(^TIU(8925.1,TIUFCDA,10,TENDA,0),U,3)
- SET DR="2///^S X=SEQUENCE"
- IF $LENGTH(SEQUENCE)<5
- IF $LENGTH(SEQUENCE)
- DO ^DIE
- +12 SET DR=$SELECT($PIECE(CNODE0,U,4)="CL":"2;4",1:4)
- DO ^DIE
- +13 LOCK -^TIU(8925.1,TIUFCDA,10,TENDA)
- End DoDot:1
- if $DATA(DTOUT)
- GOTO CREAX
- +14 SET VALMBCK="R"
- SET MSG=" Entry Created"
- +15 IF SHARED
- SET MSG=" Entry Added"
- +16 WRITE !!,MSG,!
- SET CREATE=1
- LOCK -^TIU(8925.1,CREATEDA)
- GOTO ANOTHER
- CREAX LOCK -^TIU(8925.1,+$GET(CREATEDA))
- +1 LOCK -^TIU(8925.1,+$GET(TIUFCDA),10,+$GET(TENDA))
- +2 IF $DATA(DTOUT)
- SET VALMBCK="Q"
- QUIT
- +3 SET PLINENO=$ORDER(^TMP("TIUF1IDX",$JOB,"DAF",TIUFCDA,""))
- +4 SET PINFO=^TMP("TIUF1IDX",$JOB,PLINENO)
- +5 DO PARSE^TIUFLLM(.PINFO)
- +6 ;Speeds up BUFENTRY^TIUFLLM2
- NEW TIUFSAVE
- DO SAVE(.PINFO)
- +7 SET VALMCNT=VALMCNT-PINFO("XPDLCNT")
- DO COLLAPSE^TIUFH1(.PINFO)
- +8 DO EXPAND1^TIUFH1(.PINFO)
- SET VALMCNT=VALMCNT+PINFO("XPDLCNT")
- +9 SET TIUFCITM=$SELECT($PIECE(PINFO,U,3):1,1:0)
- +10 IF CREATE
- KILL TIUFCMSG
- Begin DoDot:1
- +11 SET TIUFCMSG(1)=" Select "_$SELECT(TIUFCTYP="DC":"TITLE",1:"CLASS/DOCUMENTCLASS")_" to create a new "_TIUFCNM
- +12 SET TIUFCMSG(2)="or to Go Down a Level, Select NEXT LEVEL."
- +13 IF VALMCNT>VALM("LINES")
- SET TIUFCMSG(2)="or to Go Down a Level, Screen to (+/-) Desired "
- SET TIUFCMSG(3)=TIUFCNM_" Item, and Select NEXT LEVEL."
- End DoDot:1
- +14 IF $GET(TIUFFULL)
- SET VALMBCK="R"
- DO RESET^TIUFXHLX
- +15 SET LINENO=+$ORDER(^TMP("TIUF1IDX",$JOB,"DAF",+$GET(CREATEDA),0))
- +16 IF LINENO
- IF LINENO<VALMBG!(LINENO>(VALMBG+VALM("LINES")-1))
- SET VALMBG=LINENO
- +17 QUIT
- SAVE(EINFO) ;
- +1 NEW LINENO,FILEDA
- +2 FOR LINENO=+EINFO+1:1:+EINFO+EINFO("XPDLCNT")
- Begin DoDot:1
- +3 SET FILEDA=$PIECE(^TMP("TIUF1IDX",$JOB,LINENO),U,2)
- +4 SET TIUFSAVE(FILEDA)=^TMP("TIUF1",$JOB,LINENO,0)
- End DoDot:1
- if $DATA(DTOUT)
- QUIT
- +5 QUIT
- +6 ;
