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 Dec 13, 2024@02:40:35 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 ;
