source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUFT.m@ 1800

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

initial load of WorldVistAEHR
File size: 7.7 KB
RevLine 
[613]1TIUFT ; SLC/MAM - LM Template T (Items) INIT, Action Add Items ; 4-AUG-1999 10:52:47
2 ;;1.0;TEXT INTEGRATION UTILITIES;**2,5,17,27,77**;Jun 20, 1997
3HDR ; -- header code
4 ; Requires Array TIUFNOD0.
5 N TYPE,NAME
6 S NAME=$P(TIUFNOD0,U)
7 I $L(NAME)>60 S TYPE=$P(TIUFNOD0,U,4) S:TYPE="DOC" TYPE="TL" G SETHDR
8 S TYPE=$$MIXED^TIULS(TIUFNOD0("TYPE"))
9SETHDR I TYPE'="" S TYPE=TYPE_" "
10 S VALMHDR(1)=$$CENTER^TIUFL("Items for "_TYPE_NAME,79)
11HDRX Q
12 ;
13INIT ; -- init variables and list array; Also Update.
14 ; Requires TIUFSTMP as set in EDITEMS^TIUFD2.
15 ; Requires CURRENT array TIUFINFO
16 ;as set in EDVIEW^TIUFHA, updated (if Template A has changed)
17 ;in AUPDATE^TIUFLA1.
18 ;WARNING: +TIUFINFO may = 0!
19 N LINENO,FILEDA
20 K ^TMP("TIUF2",$J),^TMP("TIUF2IDX",$J)
21 D CLEAN^VALM10
22 S FILEDA=TIUFINFO("FILEDA"),VALMCNT=0
23 I '$O(^TIU(8925.1,FILEDA,10,0)) D G INITX
24 . S ^TMP("TIUF2",$J,1,0)=""
25 . S ^TMP("TIUF2",$J,2,0)="Entry has no items.",VALMCNT=2
26 . Q
27 S LINENO=0
28 ; EDit Items checks item existence, so we know items exist in file:
29 D BUFITEMS^TIUFLT("T",.TIUFINFO,.LINENO) G:$D(DTOUT) INITX
30 D UPDATE^TIUFLLM1("T",LINENO,0) S VALMCNT=VALMCNT+LINENO
31INITX I $D(DTOUT) S VALMQUIT=1
32 Q
33 ;
34EXIT ; -- exit code for LM Template T
35 K ^TMP("TIUF2",$J),^TMP("TIUFB",$J),^TMP("TIUF2IDX",$J),^TMP("TIUFBIDX",$J)
36 Q
37 ;
38ADD ; Template T (Items) Action Add Items
39 ; Adds new or existing Docmt Defs to parent entry as items.
40 ; Updates Template H or A and D as well as Item Template I.
41 ; Requires CURRENT arrays TIUFINFO, TIUFNOD0, CURRENT variable TUIFVCN1
42 ;as set in EDVIEW^TIUFHA, updated (if Template A has changed)
43 ;in AUPDATE^TIUFLA1, or (if Template H has changed) in UPDATE^TIUFLLM1.
44 ;WARNING: +TIUFINFO may = 0 if Template A has changed!
45 ; Requires TIUFTMPL, TIUFSTMP.
46 ; Requires TIUFWHO, set in Options TIUF/A/C/H EDIT/SORT/CREATE DDEFS CLIN/MGR/NATL.
47 ; If TIUFTMPL ="A", Requires TIUFATTR, TIUFAVAL as set in protocols TIUF SORT BY...
48 N FILEDA,NEWOR,ADDFLAG,DIC,DLAYGO,X,Y,NFILEDA,NEWFLAG,NEWSTAT
49 N MSG2,MSG,MSG1,TENDA,DA,DIE,DR,CFILEDA,LINENO,DTOUT,DIRUT,DIROUT,DUOUT
50 N CNTCHNG,FIELDS,DIK,TIUFOUT1,EXITFLG,TIUFXNOD,TIUFY,TIUFXHLX
51 N NNODE0,TIUFTMSG,TIUFTLST,TIUFIMSG,SEQUENCE,SUBS,OVERRIDE,DDEFUSED
52 S FILEDA=TIUFINFO("FILEDA"),TIUFXNOD=$G(XQORNOD(0))
53 S VALMBCK=""
54 I TIUFWHO="N" D FULL^VALM1,OVERWARN^TIUFHA2
55 I $P(TIUFNOD0,U,13),TIUFWHO'="N",$P(TIUFNOD0,U,4)="DOC"!($P(TIUFNOD0,U,4)="CO") W !!," Parent is National, of Type TL or CO; Can't add or delete Items" D PAUSE^TIUFXHLX G ADDX
56 S (ADDFLAG,TIUFOUT1)=0
57 ; Can't avoid redisplay since may have asked for help or answered no, not adding, in which case must erase and redisplay.
58 F D L -^TIU(8925.1,+$G(NFILEDA)) G:$D(DTOUT) ADDX S VALMSG=$$VMSG^TIUFL D RE^VALM4,RESET^TIUFXHLX S:$D(DUOUT) TIUFOUT1=1 Q:TIUFOUT1
59 . K MSG2
60 . D FULL^VALM1 ;displays list before does XE Help, so must full here
61 . S DIC("A")=$S(TIUFWHO="C":"Enter Shared Component Name to add as Item: ",1:"Enter Document Definition Name to add as Item: ")
62 . S DIC=8925.1,DIC(0)="AELQ" I TIUFWHO="C" S DIC(0)="AEQ"
63 . S DIC("S")=$S(TIUFWHO="C":"I $P(^(0),U,10)&($P(^(0),U,4)=""CO"")",1:$$NAMSCRN^TIUFLF2(FILEDA)),DLAYGO=8925.1
64 . N OVERRIDE S OVERRIDE=$$OVERRIDE^TIUFHA2("be allowed to select ANY inactive orphan item, including the wrong TYPE") Q:$D(DIRUT) I TIUFWHO="N",'OVERRIDE W !," OK, you can only select appropriate items:",!
65 . I OVERRIDE S DIC("S")="I $$ORPHAN^TIUFLF4(Y,^TIU(8925.1,Y,0))=""YES"""
66 . D ^DIC S TIUFY=Y
67 . I TIUFY=-1 S TIUFOUT1=1 Q
68 . S NFILEDA=+TIUFY,NEWFLAG=$P(TIUFY,U,3),NNODE0=^TIU(8925.1,NFILEDA,0)
69 . L +^TIU(8925.1,NFILEDA):1 I '$T W !!,"Another user is editing item. Please try later.",! K DUOUT D PAUSE^TIUFXHLX Q
70 . I 'NEWFLAG,$$STATWORD^TIUFLF5($P(^TIU(8925.1,+Y,0),U,7))'="INACTIVE" W !!,"NOT inactive; Can't add Item",! H 3 Q
71 . S DDEFUSED=$$DDEFUSED^TIUFLF(NFILEDA)
72 . I TIUFWHO'="N",DDEFUSED="YES" N DIR,Y D Q:'Y
73 . . I $P(NNODE0,U,10) S Y=1 Q ;P76 Shared component
74 . . I $P(NNODE0,U,4)'="DOC" S Y=0 Q
75 . . S DIR(0)="Y",DIR("B")="NO"
76 . . S DIR("A",1)="WARNING: This orphan Title is already IN USE, an ABNORMAL situation. You will",DIR("A",2)="have to take additional actions after adding it. You will not be able to",DIR("A",3)="delete it once it is added."
77 . . S DIR("A")=" Want to go ahead and add it anyway" W ! D ^DIR
78 . N TIUFIMSG I $$DUP^TIUFLF7($P(NNODE0,U),FILEDA,NFILEDA) W !!,TIUFIMSG,! K DUOUT D PAUSE^TIUFXHLX D:NEWFLAG DELETE(NFILEDA) Q
79 . D TYPELIST^TIUFLF7($P(NNODE0,U),NFILEDA,FILEDA,.TIUFTMSG,.TIUFTLST) I $D(DTOUT) D:NEWFLAG DELETE(NFILEDA) Q
80 . I $D(TIUFTMSG("T")) W !!,TIUFTMSG("T"),!,"Can't add Item",! K DUOUT D PAUSE^TIUFXHLX D:NEWFLAG DELETE(NFILEDA) Q ;Parent has no/wrong type
81 . I TIUFTLST="" W !!," Please enter a different Name; File already has entries of every permitted Type",!,"with that Name",! K DUOUT D PAUSE^TIUFXHLX D:NEWFLAG DELETE(NFILEDA) Q
82 . I NEWFLAG D STUFFLDS^TIUFLF4(NFILEDA,FILEDA) S NNODE0=^TIU(8925.1,NFILEDA,0)
83 . W !!," Editing prospective Item:",!
84 . S EXITFLG=0
85 . I NEWFLAG S FIELDS=";.05;.06;" S:$P(NNODE0,U,4)="" FIELDS=";.04"_FIELDS S:TIUFWHO="N" FIELDS=FIELDS_".13;" D ASKFLDS^TIUFLF1(NFILEDA,FIELDS,FILEDA,.NEWSTAT,.EXITFLG) Q:$D(DTOUT)
86 . D OWNCHEC^TIUFLF8(NFILEDA)
87 . N TIUFCK
88 . I 'OVERRIDE D CHECK^TIUFLF3(NFILEDA,FILEDA,1,.TIUFCK) D I $D(MSG2) S MSG=MSG1_MSG2 W !!,MSG,! K DUOUT D PAUSE^TIUFXHLX D:NEWFLAG DELETE(NFILEDA) Q
89 . . F SUBS="S","OBJ","OBJINACT","B","O","V","E","R","H","N","G","D" K TIUFCK(SUBS)
90 . . S MSG1="Can't Add Item: "
91 . . I $D(TIUFCK)>9 S MSG2=$P(TIUFCK,U,2) Q
92 . . S NNODE0=^TIU(8925.1,NFILEDA,0)
93 . . I $O(^TIU(8925.1,"AD",NFILEDA,0)),'$P(NNODE0,U,10) S MSG2="Item Already has Parent" Q
94 . . I $D(^TIU(8925.1,FILEDA,10,"B",NFILEDA)) S MSG2="Entry Already has Item"
95 . D ADDTEN^TIUFLF4(FILEDA,NFILEDA,NNODE0,.TENDA)
96 . I TENDA="" W " ?? Couldn't be added! " K DUOUT D PAUSE^TIUFXHLX Q
97 . I TIUFTMPL="A",$E(TIUFATTR)="P" S TIUFREDO=1 ; Adding item affects parentage globally.
98 . I DDEFUSED'="YES",'EXITFLG,'$D(DTOUT) S FIELDS=";.07;" D ASKFLDS^TIUFLF1(NFILEDA,FIELDS,FILEDA,.NEWSTAT,.EXITFLG) Q:$D(DTOUT)
99 . S DA(1)=FILEDA,DA=TENDA
100 . I 'EXITFLG,'$D(DTOUT) D L -^TIU(8925.1,FILEDA,10,TENDA) Q:$D(DTOUT)
101 . . L +^TIU(8925.1,FILEDA,10,TENDA):1 I '$T W !!,"Another user is editing item. Please edit later.",! H 2 Q
102 . . S DIE="^TIU(8925.1,DA(1),10,"
103 . . S DR="3" D ^DIE I $D(Y)!$D(DTOUT) Q
104 . . I $P(TIUFNOD0,U,4)="CL" S SEQUENCE=$P(^TIU(8925.1,DA(1),10,DA,0),U,3),DR="2///^S X=SEQUENCE" I $L(SEQUENCE)<5,$L(SEQUENCE) D ^DIE ;Stuff mnem with seq value
105 . . S DR=$S($P(TIUFNOD0,U,4)="CL":"2;4",1:4) D ^DIE K DUOUT
106 . S MSG=" Item Added" W !,MSG,! H 1
107 . I DDEFUSED="YES" D D PAUSE^TIUFXHLX
108 . . I $P(NNODE0,U,10) Q ;P76
109 . . I TIUFWHO'="N" W !,"WARNING: You have just added a Title which is already IN USE. Please Update",!,"Parent Document Type for this Title. If documents still seem to be missing,",!,"please contact Customer Service.",! Q
110 . . W !,"WARNING: You have just added an item which is already IN USE. Please Update",!,"Parent Document Type for this Title/all Titles under this item. If documents"
111 . . W !,"are still missing, use TLDOCMTS^TIUFHA8 to reindex class cross references.",!
112 . ; Update Template T with Item:
113 . D INIT Q:$D(DTOUT)
114 . S LINENO=$O(^TMP("TIUF2IDX",$J,"DAF",NFILEDA,""))
115 . I LINENO<VALMBG!(LINENO>(VALMBG+VALM("LINES")-1)) S VALMBG=LINENO
116 . S ADDFLAG=1
117 . ; Update Template A with item (may be new, may be no longer Orphan):
118 . I TIUFTMPL="A" D
119 . . D AUPDATE^TIUFLA1(NNODE0,NFILEDA,.CNTCHNG) S:CNTCHNG TIUFVCN1=TIUFVCN1+1 ;CNTCHNG is Count Change
120 G:'ADDFLAG ADDX
121 D NODE0ARR^TIUFLF(FILEDA,.TIUFNOD0) G:$D(DTOUT) ADDX
122 ; Template D is updated when return to it from T
123 ; Template H doesn't need update: will just reexpand when leave items.
124ADDX ;
125 I $D(DTOUT) S VALMBCK="Q"
126 Q
127 ;
128DELETE(DA) ; Delete DA from file
129 N DIK S DIK="^TIU(8925.1," D ^DIK
130 Q
Note: See TracBrowser for help on using the repository browser.