source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULA4.m@ 1742

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

initial load of WorldVistAEHR
File size: 4.6 KB
Line 
1TIULA4 ; SLC/JER,JM - Check out PUT API's ; 6/13/01
2 ;;1.0;TEXT INTEGRATION UTILITIES;**10,35,79,103,111,116**;Jun 20, 1997
3CLASPICK(PARENT,Y,TYPES) ; Boolean fn to screen selection of classes
4 N TIUY S TIUY=0,TYPES=$G(TYPES,"DCCL")
5 I ($P(^TIU(8925.1,+Y,0),U,4)]""),$S(TYPES[$P(^TIU(8925.1,+Y,0),U,4):1,(+Y=+$$CLASS^TIUCNSLT):1,1:0),+$$ISA^TIULX(+Y,+PARENT),+$$CANPICK^TIULP(+Y) S TIUY=1
6 Q TIUY
7DFLTPICK(PARENT,Y,LIST) ; Boolean function to screen selection of Default title
8 N TIUY S TIUY=0
9 I $P(^TIU(8925.1,+Y,0),U,4)="DOC",+$$ISA^TIULX(+Y,+PARENT),+$$CANPICK^TIULP(+Y) S TIUY=1
10 I +$G(LIST),(+$O(^TIU(8925.98,+$G(LIST),10,0))>0),(+$O(^TIU(8925.98,+$G(LIST),10,"B",+Y,0))'>0) S TIUY=0
11 Q TIUY
12LBYPASS() ; Interactive function to determine whether to bypass list
13 N PROMPT W !
14 S PROMPT="Edit (L)ist, (D)efault TITLE, or (B)oth? "
15 Q $P($$READ^TIUU("SA^L:list;D:default;B:both",PROMPT,"BOTH"),U)
16TITLPICK(TIUY,CLASS,ATTCHID) ; Select a title
17 N PICK,TITLES,I,L,Y,TIUDFLT,QUIT,DTOUT,DUOUT,CANLINK,PICKNUM
18 S CLASS=$G(CLASS,3)
19 D LIST(.TITLES,CLASS,"","",$G(ATTCHID)) Q:'+$O(TITLES(0))
20 S TIUDFLT=$G(TITLES("DFLT"))
21 I TIUDFLT,'$P(TITLES(TIUDFLT),U,3)!($G(ATTCHID)&'$P(TITLES(TIUDFLT),U,4)) S TIUDFLT=0,TIUY("NODFLT")=1
22RPT W !!,"Personal ",$$UP^XLFSTR($$PNAME^TIULC1(CLASS))," Title List for "
23 W $$NAME^TIULS($$PERSNAME^TIULC1(DUZ),"FIRST LAST"),!
24 S (I,L,PICK,QUIT,PICKNUM)=0
25 F S I=$O(TITLES(I)) Q:QUIT!(+I'>0)!(+PICK) D
26 . W !?3,I,?8,$P(TITLES(I),U,2)
27 . I I#15=0 D
28 . . I +$O(TITLES(I)) D I 1
29 . . . W !!,"Press <RETURN> to see more titles, '^' to exit personal list, or CHOOSE"
30 . . . S Y=$G(TITLES(+$$PICK(1,I))) ;If more titles, no default
31 . . E D
32 . . . W ! S PICKNUM=$$PICK(1,I,+$G(TIUDFLT))
33 . . . I PICKNUM="" S QUIT=1
34 . . . S Y=$G(TITLES(+PICKNUM))
35 . . . I Y="0^Other Title" S QUIT=1
36 . . I $D(DTOUT)!$D(DUOUT) S QUIT=1,Y=0
37 . . E S PICK=+Y
38 . I +PICK S TIUY(1)=1_U_+Y_$$PNAME^TIULC1(+Y),TIUY=1
39 . S L=I
40 I 'QUIT,'PICK W ! S Y=$G(TITLES(+$$PICK(1,L,+$G(TIUDFLT))))
41 I +Y,'$P(Y,U,3) D G RPT
42 . W !,$C(7),">>> ",$$PNAME^TIULC1(+Y)," is not an ACTIVE title."
43 . W " Please choose another."
44 . W !?4,"You may want to remove it from your list..."
45 . W !?4,"Check with your Clinical Application Coordinator.",! K Y
46 I +Y,$G(ATTCHID),'$P(Y,U,4) D G RPT
47 . S CANLINK=$$CANLINK^TIULP(+Y)
48 . W !,$C(7),">>> ",$P(CANLINK,U,2),!," Please choose another title."
49 . K Y
50 I +Y D
51 . S TIUY(1)=1_U_+Y_U_$$PNAME^TIULC1(+Y),TIUY=1
52 . W " ",$$PNAME^TIULC1(+Y)
53 I +Y=0 S (TIUY,TIUY(1))=0
54 ;If user selected other title, they rejected the default:
55 I Y="0^Other Title" S TIUY("NODFLT")=1
56 I 'Y D
57 . W !,"Exiting NUMBERED personal list.",!
58 . W "Please select other title by NAME:"
59 Q
60PICK(LOW,HIGH,DFLT) ; List selection
61 N X,Y
62 I +$G(DFLT) S Y=$$READ^TIUU("NO^"_LOW_":"_HIGH,"TITLE",DFLT) I 1
63 E S Y=$$READ^TIUU("NO^"_LOW_":"_HIGH,"TITLE")
64 W !
65 Q Y
66LIST(TIUY,CLASS,TYPE,TIUK,ATTCHID) ; Get list of document titles
67 N TIUDFLT
68 S TIUK=+$G(TIUK)
69 I $G(TYPE)']"" S TYPE="DOC"
70 ; If the user has a preferred list of titles for the CLASS, get it
71 I +$O(^TIU(8925.98,"AC",DUZ,CLASS,0)) D PERSLIST(.TIUY,DUZ,CLASS,.TIUK,ATTCHID)
72 Q
73PERSLIST(TIUY,DUZ,CLASS,TIUC,ATTCHID) ; Get personal list for a user
74 N TIUI,TIUDA,LASTSEQ,UNKSEQ,DFLTFL
75 S TIUDA=+$O(^TIU(8925.98,"AC",DUZ,CLASS,0))
76 Q:+TIUDA'>0
77 S TIUY("DFLT")=$P($G(^TIU(8925.98,+TIUDA,0)),U,3)
78 S TIUC=+$G(TIUC)
79 S (TIUI,LASTSEQ,UNKSEQ,DFLTFL)=0
80 F S TIUI=$O(^TIU(8925.98,TIUDA,10,TIUI)) Q:+TIUI'>0 D
81 . N TIUPL,TIUTNM,TIUDTYP,TIUSEQ,TLINE
82 . S TIUPL=$G(^TIU(8925.98,TIUDA,10,TIUI,0))
83 . S TIUDTYP=$P(TIUPL,U),TIUSEQ=+$P(TIUPL,U,2)
84 . I 'TIUSEQ S TIUSEQ=1000+UNKSEQ,UNKSEQ=UNKSEQ+1
85 . S TIUTNM=$S($P(TIUPL,U,3)]"":$P(TIUPL,U,3),1:$$PNAME^TIULC1(+TIUDTYP))
86 . S TIUC=+$G(TIUC)+1
87 . S TLINE=$$TLINE(TIUDTYP,TIUTNM,$G(ATTCHID))
88 . I $D(TIUY(TIUSEQ)) S TIUY(1000+UNKSEQ)=TLINE,LASTSEQ=1000+UNKSEQ,UNKSEQ=UNKSEQ+1
89 . E S TIUY(TIUSEQ)=TLINE
90 . I LASTSEQ<TIUSEQ S LASTSEQ=TIUSEQ
91 . I TIUDTYP=TIUY("DFLT") S TIUY("DFLT")=TIUSEQ,DFLTFL=1
92 I DFLTFL=0&($G(TIUY("DFLT"))) D
93 . N TIUTNM,DFLTLINE
94 . S TIUTNM=$$PNAME^TIULC1(+TIUY("DFLT"))
95 . S DFLTLINE=$$TLINE(+TIUY("DFLT"),TIUTNM,$G(ATTCHID))
96 . S TIUY(1000+UNKSEQ)=DFLTLINE,TIUY("DFLT")=1000+UNKSEQ,LASTSEQ=1000+UNKSEQ,UNKSEQ=UNKSEQ+1
97 I +$G(LASTSEQ)>0 S LASTSEQ=LASTSEQ+1,TIUY(LASTSEQ)=0_U_"Other Title"
98 Q
99 ;
100TLINE(TITLIFN,TIUTNM,ATTCHID) ; Function returns TitleIFN^Titlename^Canpick (i.e. active)^Canattach (user can attach child ID entries of this title)
101 N TIUPICK,CANLINK
102 S TIUPICK=+$$CANPICK^TIULP(TITLIFN)
103 S CANLINK=""
104 I $G(ATTCHID) S CANLINK=+$$CANLINK^TIULP(TITLIFN)
105 I 'TIUPICK!(CANLINK=0) S TIUTNM="("_TIUTNM_")"
106 Q TITLIFN_U_TIUTNM_U_TIUPICK_U_CANLINK
Note: See TracBrowser for help on using the repository browser.