source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUFLF1.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: 7.2 KB
RevLine 
[613]1TIUFLF1 ; SLC/MAM - Library; File 8925.1 Related: HASITEMS(FILEDA), ASKFLDS(FILEDA,FIELDS,PFILEDA,NEWSFLG,XFLG), BADNAP(NAP,FILEDA,OBJFLG) ; 03/16/2007
2 ;;1.0;TEXT INTEGRATION UTILITIES;**2,12,17,64,211,225**;Jun 20, 1997;Build 13
3 ;
4 ;
5 ;*** INCLUDES JOEL'S MODS FOR VUID PATCH ***
6 ;
7BADNAP(NAP,FILEDA,OBJFLG) ; Function returns 1 if NAP is ambiguous as a
8 ;name, abbrev or print name for FILEDA AND such ambiguity is a problem.
9 ;Else 0. Used when editing entries, or when finding permitted types.
10 ; Ambiguity is a problem if OBJFLG=1. OBJFLG=1 if FILEDA is an object,
11 ;or FILEDA WILL BE an object since we're in Create Objects, or we are
12 ;deciding whether to include type O as a permitted type
13 ;in TYPELIST^TIUFLF7.
14 ; TYPELIST, NAME of object in ASKFLDS must SEND OBJFLG=1. Others are SET here.
15 N NAPANS,XREF,OFILEDA
16 S NAPANS=0 I NAP="" G BADNX
17 I $D(^TIU(8925.1,"AT","O",FILEDA)) S OBJFLG=1
18 I $G(TIUFTMPL)="J" S OBJFLG=1
19 I $G(TIUFXNOD)["Copy",$P($G(NODE0),U,4)="O" S OBJFLG=1
20 S OBJFLG=+$G(OBJFLG)
21 I 'OBJFLG G BADNX
22 F XREF="B","C","D" D Q:NAPANS
23 . S OFILEDA=0 F S OFILEDA=$O(^TIU(8925.1,XREF,NAP,OFILEDA)) Q:'OFILEDA D Q:NAPANS
24 . . I OFILEDA'=FILEDA,$D(^TIU(8925.1,"AT","O",OFILEDA)) S NAPANS=1
25BADNX Q NAPANS
26 ;
27HASITEMS(FILEDA) ; Function returns 0 if FILEDA has no items, else returns 1.
28 Q $O(^TIU(8925.1,+FILEDA,10,0))
29 ;
30ASKFLDS(FILEDA,FIELDS,PFILEDA,NEWSFLG,XFLG) ; Ask FIELDS (String subset of: ;.01;.02;.03;.04;.05;.06;.07;.1;.13;3.03) w ;'s on ends as well as between numbers for file entry FILEDA.
31 ; Requires FILEDA, FIELDS.
32 ; If field is determined, correct, and exists, module doesn't ask even if it is contained in FIELDS.
33 ; Returns NEWSFLG=1 if ASKFIELDS has changed Status of FILEDA, else 0
34 ; Returns XFLG=1 if user ^exited, else 0.
35 ; Requires PFILEDA (= Actual/Anticipated parent) if FIELDS [ .04 Type
36 ;or .07 Status. If no such parent, send PFILEDA=0.
37 ; Should Lock FILEDA before calling ASKFLDS.
38 ; After calling ASKFLDS, Set back to screen mode if nec, set VALMBCK = "R" if necessary.
39 N DIE,DA,X,Y,NODE0,DR,PFDA,TYPEDR,USED,ITEMIFN,DIR,NAME,ANS
40 N TIUFQUIT,TIUFY,SIGNERS,TIUFTLST,TIUFTMSG,TIUFIMSG,DEFLT,CONTINUE
41 N SUPVISIT
42 S NEWSFLG=0,XFLG=0,NODE0=^TIU(8925.1,FILEDA,0)
43 S USED=$S($P(NODE0,U,4)="O":1,1:$$DDEFUSED^TIUFLF(FILEDA))
44 S DIE=8925.1,DA=FILEDA,TIUFQUIT=0
45 S PFILEDA=+$G(PFILEDA) K DIRUT
46 D FULL^VALM1 S TIUFFULL=1
47 I FIELDS'[";.01;" G ABBREV
48 I $P(NODE0,U,4)="O" S CONTINUE=$$WARNOBJ^TIUFLJ("N",FILEDA,NODE0) G:$D(DIRUT) ASKFX G:'CONTINUE ABBREV
49NAME S DEFLT=$P(NODE0,U) K DIRUT S NAME=$$SELNAME^TIUFLF2(DEFLT) G:$D(DIRUT) ASKFX
50 I PFILEDA,$$DUPITEM^TIUFLF7(NAME,PFILEDA,FILEDA) W !!,"Please enter a different Name; Parent already has Item with that Name",! G NAME
51 D TYPELIST^TIUFLF7(NAME,FILEDA,PFILEDA,.TIUFTMSG,.TIUFTLST) G:$D(DTOUT) ASKFX
52 I $D(TIUFTMSG("T")) W !!,TIUFTMSG("T"),!,"Can't edit Entry",! D PAUSE^TIUFXHLX G ASKFX
53 I TIUFTLST="" W !!," Please enter a different Name; File already has entries of every permitted Type",!,"with that Name",! G NAME
54 I $P(NODE0,U,4)'="",TIUFTLST'[(U_$P(NODE0,U,4)_U) W !!,"Please enter a different Name; File already has entry of this Type",!,"with that Name",! G NAME
55 I $P(NODE0,U,4)="O",$$BADNAP^TIUFLF1(NAME,FILEDA,1) W " ??",!,"Object Name must be unique among all object Names, Abbreviations,",!,"and Print Names." G NAME
56 S DR=".01///^S X=NAME" D ^DIE S NODE0=^TIU(8925.1,FILEDA,0)
57 I $D(DIRUT)!$D(Y)!$D(DTOUT) S DUOUT=1 G ASKFX
58ABBREV I FIELDS'[";.02;" G PRINTN
59 I $P(NODE0,U,4)="O" S CONTINUE=$$WARNOBJ^TIUFLJ("A",FILEDA,NODE0) G:$D(DIRUT) ASKFX G:'CONTINUE PRINTN
60ABBREV1 S DR=".02" D ^DIE S NODE0=^TIU(8925.1,FILEDA,0)
61 I $D(DIRUT)!$D(Y)!$D(DTOUT) S DUOUT=1 G ASKFX
62PRINTN I FIELDS'[";.03;" G LOINC
63 I $P(NODE0,U,4)="O" S CONTINUE=$$WARNOBJ^TIUFLJ("P",FILEDA,NODE0) G:$D(DIRUT) ASKFX G:'CONTINUE LOINC
64PRINTN1 N TIUFUPP S DR=".03" D ^DIE S NODE0=^TIU(8925.1,FILEDA,0)
65 I $D(DIRUT)!$D(Y)!$D(DTOUT) S DUOUT=1 G ASKFX
66 ; <VUID PATCH>
67LOINC I FIELDS'[";1501;"!($P(NODE0,U,4)'="DOC") G NATL
68 N TIUOUT S TIUOUT=0
69 W !!,"EVERY Local Title must be mapped to a VHA Enterprise Standard Title.",!
70 S DR="1501" D DIRECT^TIUMAP2(FILEDA) S NODE0=^TIU(8925.1,FILEDA,0)
71 I $D(DIRUT)!+$G(TIUOUT)!$D(DTOUT) S DUOUT=1 G ASKFX
72 ; </VUID PATCH>
73NATL I FIELDS[";.13;",TIUFWHO="N" D G:XFLG ASKFX S NODE0=^TIU(8925.1,FILEDA,0)
74 . S DIR("B")=$S($P(NODE0,U,13):"YES",1:"NO")
75 . D
76 . . S DIR(0)="YO",(DIR("?"),DIR("??"))="^D HELP2^TIUFXHLX(.13)"
77 . . S DIR("A")="NATIONAL"
78 . . D ^DIR I $D(DUOUT)!$D(DTOUT) S XFLG=1 Q
79 . . S ANS=Y,DR=".13////^S X=ANS" D ^DIE
80TYPE I FIELDS[";.04;" K DIRUT D EDTYPE^TIUFLF7(FILEDA,.NODE0,PFILEDA,.XFLG,USED) G:$D(DIRUT) ASKFX
81SHARE G:FIELDS'[";.1;" OWNER
82 N PARENT1,PARENT2,SHARE,STATUS,DIR
83 I "NM"'[TIUFWHO G OWNER
84 I $P(NODE0,U,4)'="CO" G OWNER
85 I '$$PERSOWNS^TIUFLF2(FILEDA,DUZ) W !!,"SHARED: Only an Owner can edit SHARED",! G OWNER
86 S SHARE=$P(NODE0,U,10)
87 ; If not presently SHARED set default=NO:
88 I 'SHARE S DIR("B")="NO"
89 ; If presently SHARED but only used once, set default=YES:
90 S PARENT1=$O(^TIU(8925.1,"AD",FILEDA,0)),PARENT2=$S('PARENT1:0,1:$O(^TIU(8925.1,"AD",FILEDA,PARENT1)))
91 I SHARE,'PARENT2 S DIR("B")="YES" I $P($G(^TIU(8925.1,+PARENT1,0)),U,10) W !!,"SHARED: Subcomponent of Shared Component; Must remain Shared",! G OWNER
92 I 'SHARE,$P($G(^TIU(8925.1,+PARENT1,0)),U,10) S DIR("B")="YES"
93 N Y
94 I $D(DIR("B")) D G:XFLG ASKFX S NODE0=^TIU(8925.1,FILEDA,0)
95 . S DIR(0)="YO",(DIR("?"),DIR("??"))="^D HELP2^TIUFXHLX(.1)"
96 . S DIR("A")="SHARED"
97 . D ^DIR I $D(DUOUT)!$D(DTOUT) S XFLG=1 Q
98 . S ANS=Y,DR=".1////^S X=ANS" D ^DIE
99 I 'SHARE,$G(ANS),$$HASITEMS^TIUFLF1(FILEDA) D DSETSHAR^TIUFLD1(FILEDA) G OWNER
100 I SHARE,PARENT2 W !!,"SHARED: Entry is SHARED with multiple parents; Can't edit SHARED"
101OWNER I FIELDS[";.05;" D EDOWN^TIUFLF8(FILEDA,.XFLG) G:XFLG ASKFX
102OKDIST I FIELDS[";3.02;",TIUFWHO="N" S DR="3.02//NO" D ^DIE I $D(Y)!$D(DTOUT) S DUOUT=1 G ASKFX
103SUPVISIT I FIELDS[";3.03;",$P(NODE0,U,4)="CL"!($P(NODE0,U,4)="DC")!($P(NODE0,U,4)="DOC") D G:$D(DUOUT) ASKFX
104 . S SUPVISIT=$P($G(^TIU(8925.1,FILEDA,3)),U,3)
105 . S SUPVISIT=$S(SUPVISIT=0:"NO",SUPVISIT=1:"YES",1:"")
106 . I SUPVISIT="" D INHERIT^TIUFLD(FILEDA,0,3.03,"E","","",.SUPVISIT) S SUPVISIT=SUPVISIT("E")
107 . S DR="3.03//^S X=SUPVISIT" D ^DIE I $D(Y)!$D(DTOUT) S DUOUT=1 Q
108 . I SUPVISIT="NO",$P($G(^TIU(8925.1,FILEDA,3)),U,3) S CONTINUE=$$WARNSUP D
109 . . I 'CONTINUE S DR="3.03///^S X=SUPVISIT" D ^DIE W " NOT"
110 . . W " Suppressed" H 1
111STATUS I FIELDS'[";.07;" G ASKFX
112 I $P(NODE0,U,4)="CO",$P(NODE0,U,10) W !,"STATUS: Shared Components have no Status; Can't Edit Status" H:TIUFXNOD["Basics"!(TIUFXNOD["Boil") 2 G ASKFX ;P64 add msg and hang
113 I TIUFTMPL="A",$G(TIUFSTMP)="",($P(NODE0,U,4)="CL")!($P(NODE0,U,4)="DC")!($P(NODE0,U,4)="DOC")!($P(NODE0,U,4)="CO") W !,"STATUS: Orphans are Inactive; Can't Edit Status" H 2 G ASKFX
114 I $P(NODE0,U,4)="CO" W !,"STATUS: Components get their Status from their Parent; Can't Edit Status" H:TIUFXNOD["Basics"!(TIUFXNOD["Boil") 2 G ASKFX
115 D ASKSTAT^TIUFLF6(FILEDA,.NODE0,PFILEDA,.NEWSFLG,.XFLG)
116ASKFX S:$D(DTOUT)!$D(DUOUT) XFLG=1
117 Q
118 ;
119WARNSUP() ; Function Warns user who asks to Suppress Visit, Returns 1 to Suppress, 0 to not Suppress.
120 N DIR,X,Y
121 S DIR(0)="Y",DIR("B")="NO",DIR("A",1)=" Warning: You will NOT GET WORKLOAD CREDIT if you Suppress Visit Selection."
122 S DIR("A")=" Sure you want to Suppress Visit Selection"
123 W ! D ^DIR W " ... "
124 Q Y
125 ;
Note: See TracBrowser for help on using the repository browser.