source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUFLF7.m@ 1000

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

initial load of WorldVistAEHR
File size: 7.5 KB
Line 
1TIUFLF7 ; SLC/MAM - Library; File 8925.1: POSSTYPE(PFILEDA),TYPELIST(NAME,FILEDA,PFILEDA,TYPEMSG,TYPELIST),EDTYPE(FILEDA,NODE0,PFILEDA,XFLG,USED),DUPNAME(NAME,FILEDA),DUPITEM(NAME,PFILEDA,FILEDA),DDEFIEN(TIUDEFNM,etc) ;5/2/05
2 ;;1.0;TEXT INTEGRATION UTILITIES;**2,17,90,184**;Jun 20, 1997
3 ;
4POSSTYPE(PFILEDA) ; Function returns possible Types an Entry may have to
5 ;be consistent with its parent, e.g. ^CL^DC^
6 ; If parent has bad type or no type, Returns POSSTYPE="".
7 ; If PFILEDA = 0, Returns all Types including Object.
8 ; Requires PFILEDA = 8925.1 IFN of parent of Entry;
9 ; = 0 if Entry has no parent, actual or prospective.
10 ; Shared CO can have more than 1 parent. But any parent will determine the type of the Child to be a CO, so OK to check only 1 parent.
11 N PNODE0,POSSTYPE,PTYPE
12 S POSSTYPE=""
13 I 'PFILEDA S POSSTYPE="^CL^DC^DOC^CO^O^" G POSTX
14 S PNODE0=$G(^TIU(8925.1,PFILEDA,0)) I '$D(PNODE0) W !!," File entry "_PFILEDA_" does not exist in File; See IRM",! D PAUSE^TIUFXHLX G POSTX
15 S PTYPE=$P(PNODE0,U,4)
16 S POSSTYPE=$S(PTYPE="CL":"^CL^DC^",PTYPE="DC":"^DOC^",PTYPE="CO"!(PTYPE="DOC"):"^CO^",1:"")
17POSTX Q POSSTYPE
18 ;
19TYPELIST(NAME,FILEDA,PFILEDA,TYPEMSG,TYPELIST) ; Module sets list of possible types, sets msg array TYPEMSG explaining nonparent limits on type.
20 ; Requires NAME of entry being checked
21 ; Requires PFILEDA=IFN of parent if entry has actual or prospective parent (as in Create, Add Items)
22 ; Requires FILEDA if entry already exists in the file
23 ; Optional TYPEMSG
24 ; Optional TYPELIST: Returns TYPELIST = subset of CL,DC,DOC,CO,O
25 ;representing permitted Types. Example: ^CL^DOC^
26 ;If has parent, parent already has item w same name, then TYPELIST=""
27 N DUPNAME,POSSTYPE,TYPE,REST,FDATYPE
28 S FILEDA=+$G(FILEDA),PFILEDA=+$G(PFILEDA),TYPELIST=""
29 S FDATYPE=$S(FILEDA:$P(^TIU(8925.1,FILEDA,0),U,4),1:"")
30 I (FDATYPE'="CL")&(FDATYPE'="DC")&(FDATYPE'="DOC")&(FDATYPE'="CO")&(FDATYPE'="O") S FDATYPE=""
31 S DUPNAME=$$DUPNAME(NAME,FILEDA)
32 S POSSTYPE=$$POSSTYPE(PFILEDA) G:$D(DTOUT) TYPEX
33 I POSSTYPE="" S TYPEMSG("T")="Parent has No Type/Wrong Type" G TYPEX
34 I FDATYPE="O"!(TIUFTMPL="J") S TYPELIST="^O^" G TYPEX
35 S REST="" F TYPE="CL","DC","DOC","CO","O" I POSSTYPE[(U_TYPE_U) D
36 . I DUPNAME[(U_TYPE_U) S:TYPE'="DOC" REST=$S(REST'="":REST_" or "_TYPE,1:TYPE) S:TYPE="DOC" REST=$S(REST'="":REST_" or TL",1:"TL") Q
37 . I TYPE="O" D Q
38 . . I FDATYPE'="" Q
39 . . I '$$BADNAP^TIUFLF1(NAME,FILEDA,1) S TYPELIST=TYPELIST_U_TYPE Q
40 . . S TYPEMSG("O")=" Type cannot be Object; Object would be ambiguous"
41 . S TYPELIST=TYPELIST_U_TYPE
42 I TYPELIST'="" S TYPELIST=TYPELIST_U
43 I REST'="" S TYPEMSG("R")=" Type cannot be "_REST_"; File already has",TYPEMSG("R1")="an entry of that Type with the same Name" Q
44TYPEX Q
45 ;
46DUPNAME(NAME,FILEDA) ; Function returns 1 if NAME already
47 ;exists in file for entry OTHER THAN FILEDA, else 0. If 1, returns
48 ;1^Type^Type^ etc., for example, 1^DOC^CO^ means: file has a duplicate
49 ;name of Type DOC other than FILEDA and a duplicate name of Type CO
50 ;other than FILEDA.
51 N XDUPANS,XDUPDA,TYPE
52 S FILEDA=+$G(FILEDA)
53 S (XDUPDA,XDUPANS)=0
54 F S XDUPDA=$O(^TIU(8925.1,"B",$E(NAME,1,60),XDUPDA)) Q:'XDUPDA D ;TIU*1*90 change to 60 chars
55 . I NAME=$P(^TIU(8925.1,XDUPDA,0),U),XDUPDA'=FILEDA S:'XDUPANS XDUPANS="1^" S TYPE=$P(^TIU(8925.1,XDUPDA,0),U,4) I TYPE'="" S:XDUPANS'[(U_TYPE_U) XDUPANS=XDUPANS_TYPE_U
56 Q XDUPANS
57 ;
58DUPITEM(NAME,PFILEDA,FILEDA) ; Function returns 1 if PFILEDA already has item
59 ;(other than FILEDA) named NAME.
60 ; Requires NAME, PFILEDA
61 ; Requires FILEDA if FILEDA should be excluded from items checked for
62 ;duplicate names
63 N ITEMANS,XDUPDA
64 S (XDUPDA,ITEMANS)=0,FILEDA=+$G(FILEDA)
65 F S XDUPDA=$O(^TIU(8925.1,"B",$E(NAME,1,60),XDUPDA)) Q:'XDUPDA D Q:ITEMANS ; TIU*1*90 change to 60 chars
66 . I NAME=$P(^TIU(8925.1,XDUPDA,0),U),$D(^TIU(8925.1,"AD",XDUPDA,PFILEDA)),XDUPDA'=FILEDA S ITEMANS=1
67 I ITEMANS S TIUFIMSG=" Please enter a different Name; Parent already has Item with that Name"
68DUPIX Q ITEMANS
69 ;
70DUP(NAME,PFILEDA,FILEDA) ; Function returns 1 if PFILEDA already has item
71 ;(possibly FILEDA itself if FILEDA is Shared) named NAME.
72 ; Requires NAME, PFILEDA, FILEDA; Used in NAMSCRN^TIUFLF2
73 ; FILEDA is potential, not actual item of PFILEDA.
74 N DUPANS S DUPANS=0
75 ;Patch 13: Set TIUFIMSG here so NAMSCRN (which calls DUP) always sets
76 ;it:
77 I $D(^TIU(8925.1,PFILEDA,10,"B",FILEDA)) S DUPANS=1,TIUFIMSG=" Please enter a different Name; Parent already has Item with that Name" G DUPX
78 S DUPANS=$$DUPITEM(NAME,PFILEDA,FILEDA)
79DUPX Q DUPANS
80 ;
81EDTYPE(FILEDA,NODE0,PFILEDA,XFLG,USED) ; User edit FILEDA Type.
82 ; Requires FILEDA, NODE0.
83 ; Requires PFILEDA if DA has an actual/prospective parent. Need PFILEDA
84 ;for add items/Create DDEF - they're not in AD xref because not items
85 ;yet.
86 ; Updates NODE0 (not the array, just the node).
87 ; Returns XFLG=1 if user ^exited or timed out, else as received.
88 ; Requires USED =1 for object or $$DDEFUSED^TIUFLF
89 N TYPE,X,Y,NAME,TIUFTMSG,TIUFTLST,DEFLT,DIE,DR
90 K DIRUT,DUOUT,DIROUT
91 I $P(NODE0,U,4)="O" W !!,"TYPE: Object. Can't edit Type",! G EDTYX
92 I USED="YES"!(USED="ERROR") W !!,"TYPE: Entry In Use by Documents; Can't edit Type",! G EDTYX
93 S PFILEDA=+$G(PFILEDA),NAME=$P(NODE0,U)
94 D TYPELIST(NAME,FILEDA,PFILEDA,.TIUFTMSG,.TIUFTLST) G:$D(DTOUT) EDTYX
95 I $D(TIUFTMSG("T")) W !!,TIUFTMSG("T"),!,"Can't edit Type" S XFLG=1 D PAUSE^TIUFXHLX G EDTYX
96 I $D(TIUFTMSG("R")),$D(TIUFTMSG("R1")) W !!,TIUFTMSG("R"),!,TIUFTMSG("R1"),!
97 I $D(TIUFTMSG("O")) W:'$D(TIUFTMSG("R")) ! W TIUFTMSG("O"),!
98 I TIUFTLST="" W !!,"TYPE: ",$S($D(TIUFTMSG):TIUFTMSG(1),1:" Faulty entry; File has entries of every permitted Type with the same Name"),! D PAUSE^TIUFXHLX S XFLG=1 G EDTYX
99 S DEFLT=$P(NODE0,U,4) S:$L(TIUFTLST,U)=3 DEFLT=$P(TIUFTLST,U,2) S:DEFLT="DOC" DEFLT="TL"
100READTYP K DUOUT S TYPE=$S(DEFLT'="":$$SELTYPE^TIUFLF8(FILEDA,DEFLT),1:$$SELTYPE^TIUFLF8(FILEDA))
101 I $D(DUOUT)!$D(DTOUT) G EDTYX
102 I TYPE="" W " ?? Enter appropriate Type or '^' to exit",! H 2 G READTYP
103 S:TYPE="TL" TYPE="DOC" S DIE=8925.1,DR=".04////"_TYPE D ^DIE
104 S NODE0=^TIU(8925.1,FILEDA,0)
105EDTYX S:$D(DUOUT)!$D(DTOUT) XFLG=1
106 Q
107 ;
108DDEFIEN(TIUDEFNM,TIUTYPE) ; Function gets IEN (and more) of Doc Def
109 ;Requires TIUDEFNM - .01 name of Title, Docmt Class or Class in
110 ; the Document Definition file #8925.1
111 ;Requires TIUTYPE - Expected type of DDEF: TL or DC or CL
112 ;Returns IEN^STATUS^NATL if exactly one DDEF of type TIUTYPE
113 ; is found
114 ; or 0^ErrMsg
115 ; NOTE: Only ONE DDEF of a given type is allowed in 8925.1.
116 ; If DDEFs are created using TIU DDEF options, that is enforced.
117 ; If DDEFs are created in a patch, the patch MUST
118 ; enforce it.
119 ;As a precaution, this module returns 0^ErrMsg if duplicates are found.
120 ;However, TIU code ASSUMES there are no duplicates within a type.
121 N TIUDEFDA,GOTIT,ERRMSG,TIUNODE0
122 S TIUTYPE=$G(TIUTYPE)
123 I TIUTYPE'="TL",TIUTYPE'="DC",TIUTYPE'="CL" Q "0^Type Required"
124 I TIUTYPE="TL" S TIUTYPE="DOC"
125 S TIUDEFDA=0
126 ; -- Not in B xref:
127 I '$O(^TIU(8925.1,"B",TIUDEFNM,0)) S ERRMSG="0^Entry not found" Q ERRMSG
128 F S TIUDEFDA=+$O(^TIU(8925.1,"B",TIUDEFNM,TIUDEFDA)) Q:TIUDEFDA'>0 D Q:$D(ERRMSG)
129 . S TIUNODE0=$G(^TIU(8925.1,TIUDEFDA,0))
130 . ; -- Not in file or not right type:
131 . I $P(TIUNODE0,U,4)'=TIUTYPE Q
132 . ; -- Second good one:
133 . I $D(GOTIT) S ERRMSG="0^Duplicates found" Q
134 . ; -- First good one; set GOTIT=IEN^STATUS^NATL:
135 . S GOTIT=TIUDEFDA_U_$P(TIUNODE0,U,7)_U_$P(TIUNODE0,U,13)
136 ; -- Not in B xref, or dups:
137 I $D(ERRMSG) Q ERRMSG
138 ; Good one w/o dups:
139 I $D(GOTIT) Q GOTIT
140 ; In B xref but not in file, or bad type:
141 Q "0^Entry not found"
142 ;
Note: See TracBrowser for help on using the repository browser.