source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUFC1.m@ 949

Last change on this file since 949 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 5.6 KB
RevLine 
[613]1TIUFC1 ; SLC/MAM - LM Template C (Create DDEF) Action Create ;7/7/06 15:44
2 ;;1.0;TEXT INTEGRATION UTILITIES;**211**;Jun 20, 1997;Build 26
3 ;
4CREATE ; TEMPLATE C Action Create.
5 ; C in CNODE0, CSTATUS stands for Current position
6 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
7 N DIR,X,Y,DA,NAME,TIUFFULL,CSTATUS,TIUFTMSG,TIUFTLST,TIUFIMSG,SEQUENCE
8 N DUOUT,DTOUT,DIRUT,DIROUT,XFLG
9 S CREATE=0,TIUFXNOD=$G(XQORNOD(0)),VALMBCK="",CNODE0=^TIU(8925.1,TIUFCDA,0)
10 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
11ANOTHER L -^TIU(8925.1,+$G(CREATEDA)) L -^TIU(8925.1,+$G(TIUFCDA),10,+$G(TENDA))
12 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
13 N DIR S DIR(0)="FAO^3:60^S X=$$UPPER^TIULS(X) K:'(X'?1P.E) X",(DIR("?"),DIR("??"))="^D NAME^TIUFXHLX"
14 S:'CREATE DIR("A")=$S(TIUFCTYP="TL":" Enter a new Component of ",1:" Enter the Name of a new ")_TIUFCNM_": "
15 S:CREATE DIR("A")=" If you wish, you may enter another "_$S(TIUFCTYP="TL":"Component of ",1:"")_TIUFCNM_": "
16 D ^DIR I Y=""!$D(DUOUT) G CREAX
17 S NAME=Y,NAME=$$UPPER^TIULS(NAME),(SHARED,NEWYES,SHARYES)=""
18 I TIUFCTYP="TL" K DIRUT D Q:$D(DIRUT) G ADD:SHARYES,ANOTHER:NEWYES=0,ANOTHER:SHARYES=0
19 . S DIC=8925.1,DIC(0)="Z"
20 . S DIC("S")="I ($P(^(0),U,4)=""CO"")&($P(^(0),U,10))"
21 . D ^DIC
22 . 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
23 . I Y>0 W $E($P(Y,U,2),$L(NAME)+1,60) D Q:'SHARYES
24 . . S CREATEDA=+Y,CREATENM=$P(Y(0),U)
25 . . 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
26 . . I 'SHARYES K CREATEDA,CREATENM
27 . I $$DUPITEM^TIUFLF7(CREATENM,TIUFCDA) W !!,TIUFIMSG,! D PAUSE^TIUFXHLX S DIRUT=1 Q
28 . S CREATE0=^TIU(8925.1,CREATEDA,0)
29 I $$DUPITEM^TIUFLF7(NAME,TIUFCDA) W !!,TIUFIMSG,! D PAUSE^TIUFXHLX G ANOTHER
30 D TYPELIST^TIUFLF7(NAME,0,TIUFCDA,.TIUFTMSG,.TIUFTLST) G:$D(DTOUT) CREAX
31 I TIUFTLST="" W !!," Please enter a different Name; File already has entries of every permitted Type",!,"with that Name",! D PAUSE^TIUFXHLX G ANOTHER
32 N DIC S (DIC,DLAYGO)=8925.1,DIC(0)="L",X=""""_NAME_"""" D ^DIC
33 I Y=-1 W !!,"Couldn't Create Entry; See IRM",! D PAUSE^TIUFXHLX G CREAX
34 S CREATEDA=+Y,CREATENM=NAME
35 L +^TIU(8925.1,CREATEDA):1 I '$T W !!," Another user is editing this entry; please try later.",! H 2 G CREAX
36 D STUFFLDS^TIUFLF4(CREATEDA,TIUFCDA)
37 S CREATE0=^TIU(8925.1,CREATEDA,0)
38 S FIELDS=";.05;.06;" S:$P(CREATE0,U,4)="" FIELDS=";.04"_FIELDS S:TIUFWHO="N" FIELDS=FIELDS_".13;"
39 D ASKFLDS^TIUFLF1(CREATEDA,FIELDS,TIUFCDA,.NEWSTAT,.XFLG) G:$D(DTOUT) CREAX
40NOTYPE S CREATE0=^TIU(8925.1,CREATEDA,0)
41 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
42 D OWNCHEC^TIUFLF8(CREATEDA)
43ADD S PFILEDA=TIUFCDA
44 L +^TIU(8925.1,TIUFCDA):3 I '$T D G ANOTHER
45 . W !!,"Another user is editing current branch; can't hang item under parent. Entry",!,"deleted. Please create entry again.",! D PAUSE^TIUFXHLX
46 . L -^TIU(8925.1,CREATEDA) S CREATE=0,DA=CREATEDA,DIK="^TIU(8925.1," D ^DIK
47 D ADDTEN^TIUFLF4(PFILEDA,CREATEDA,CREATE0,.TENDA)
48 L -^TIU(8925.1,TIUFCDA)
49 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
50 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
51 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
52 . S DA(1)=TIUFCDA,DIE="^TIU(8925.1,DA(1),10,",DA=TENDA
53 . S DR="3" D ^DIE I $D(Y)!$D(DTOUT) Q
54 . 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
55 . S DR=$S($P(CNODE0,U,4)="CL":"2;4",1:4) D ^DIE
56 . L -^TIU(8925.1,TIUFCDA,10,TENDA)
57 S VALMBCK="R",MSG=" Entry Created"
58 I SHARED S MSG=" Entry Added"
59 W !!,MSG,! S CREATE=1 L -^TIU(8925.1,CREATEDA) G ANOTHER
60CREAX L -^TIU(8925.1,+$G(CREATEDA))
61 L -^TIU(8925.1,+$G(TIUFCDA),10,+$G(TENDA))
62 I $D(DTOUT) S VALMBCK="Q" Q
63 S PLINENO=$O(^TMP("TIUF1IDX",$J,"DAF",TIUFCDA,""))
64 S PINFO=^TMP("TIUF1IDX",$J,PLINENO)
65 D PARSE^TIUFLLM(.PINFO)
66 N TIUFSAVE D SAVE(.PINFO) ;Speeds up BUFENTRY^TIUFLLM2
67 S VALMCNT=VALMCNT-PINFO("XPDLCNT") D COLLAPSE^TIUFH1(.PINFO)
68 D EXPAND1^TIUFH1(.PINFO) S VALMCNT=VALMCNT+PINFO("XPDLCNT")
69 S TIUFCITM=$S($P(PINFO,U,3):1,1:0)
70 I CREATE K TIUFCMSG D
71 . S TIUFCMSG(1)=" Select "_$S(TIUFCTYP="DC":"TITLE",1:"CLASS/DOCUMENTCLASS")_" to create a new "_TIUFCNM
72 . S TIUFCMSG(2)="or to Go Down a Level, Select NEXT LEVEL."
73 . I VALMCNT>VALM("LINES") S TIUFCMSG(2)="or to Go Down a Level, Screen to (+/-) Desired ",TIUFCMSG(3)=TIUFCNM_" Item, and Select NEXT LEVEL."
74 I $G(TIUFFULL) S VALMBCK="R" D RESET^TIUFXHLX
75 S LINENO=+$O(^TMP("TIUF1IDX",$J,"DAF",+$G(CREATEDA),0))
76 I LINENO,LINENO<VALMBG!(LINENO>(VALMBG+VALM("LINES")-1)) S VALMBG=LINENO
77 Q
78SAVE(EINFO) ;
79 N LINENO,FILEDA
80 F LINENO=+EINFO+1:1:+EINFO+EINFO("XPDLCNT") D Q:$D(DTOUT)
81 . S FILEDA=$P(^TMP("TIUF1IDX",$J,LINENO),U,2)
82 . S TIUFSAVE(FILEDA)=^TMP("TIUF1",$J,LINENO,0)
83 Q
84 ;
Note: See TracBrowser for help on using the repository browser.