source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURECL1.m@ 824

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

initial load of WorldVistAEHR
File size: 6.7 KB
Line 
1TIURECL1 ; SLC/PKR,JER - Expand/collapse LM views ;5/8/03
2 ;;1.0;TEXT INTEGRATION UTILITIES;**100,113**;Jun 20, 1997
3 ; 7/6 Split TIURECL into TIURECL & TIURECL1, move RESOLVE to TIURECL1
4 ; 7/10 Move INSID, INSADD, VEXREQ, ISSUB to TIURECL1
5 ; 9/7 Move INSKIDS, INSADD, & associated modules to TIURECL2
6 ;=======================================================================
7ISSUB(CLASS1,CLASS2,LEVEL) ;Return true if CLASS2 is sub to CLASS1.
8 N IND,ISSUB
9 I LEVEL(CLASS1)'<LEVEL(CLASS2) Q 0
10 ;Check sublevel links between class1 and class2
11 S ISSUB=1
12 F IND=(CLASS1+1):1:(CLASS2-1) D
13 . I LEVEL(IND)=1 D Q
14 .. S ISSUB=0
15 Q ISSUB
16 ;
17 ;======================================================================
18VEXREQ(VALMY) ;Check for valid expand/contract requests.
19 ; A list of documents to expand/contract is invalid if any docmt
20 ;is a sub docmt of another docmt on the list.
21 N END,START
22 S START=$O(VALMY(""))
23 S END=$O(VALMY(""),-1)
24 I START=END Q 1
25 ;
26 N ACTION,ACTIND,ACTJND,CIND,CN,IND,JND,LEVEL,MSG,TEXT,VALID
27 ;Build the level list.
28 F IND=START:1:END D
29 . S LEVEL(IND)=$L(@VALMAR@(IND,0),"|")
30 S VALID=1
31 S IND=""
32 F S IND=$O(VALMY(IND)) Q:+IND'>0 D
33 . S TEXT(IND)=$G(@VALMAR@(IND,0))
34 . S ACTIND=$S(TEXT(IND)["+":"+ ",TEXT(IND)["-":"-",1:"")
35 . I ACTIND="" Q
36 . S ACTION(IND)=$S(TEXT(IND)["+":"expand ",TEXT(IND)["-":"collapse ",1:"")
37 . S JND=IND
38 . F S JND=$O(VALMY(JND)) Q:+JND'>0 D
39 .. S TEXT(JND)=$G(@VALMAR@(JND,0))
40 .. S ACTJND=$S(TEXT(JND)["+":"+",TEXT(JND)["-":"-",1:"")
41 .. I ACTJND="" Q
42 .. S ACTION(JND)=$S(TEXT(JND)["+":"expand ",TEXT(JND)["-":"collapse ",1:"")
43 .. I $$ISSUB(IND,JND,.LEVEL) D
44 ... I ACTION(IND)'=ACTION(JND) D Q
45 .... S CIND(IND)=$P(^TMP("TIURIDX",$J,IND),U,2)
46 .... S CN(IND)=$P(^TIU(8925,CIND(IND),0),U,1)
47 .... S CIND(JND)=$P(^TMP("TIURIDX",$J,JND),U,2)
48 .... S CN(JND)=$P(^TIU(8925,CIND(JND),0),U,1)
49 .... I '+$G(HUSH) D
50 ..... S MSG="You cannot "_ACTION(IND)_CN(IND)_" and "_ACTION(JND)_CN(JND)
51 ..... D MSG^VALM10(MSG)
52 ..... H 4
53 .... S VALID=0
54 Q VALID
55 ;======================================================================
56IDDATA(TIUDA,TIUD0,TIUD21) ; Return TIUGDATA:
57 ; TIUGDATA = 0 or
58 ; = TIUDA^haskid^IDparent^prmsort, where
59 ; TIUDA = note DA
60 ; haskid = 1 if note has ID kid, else 0
61 ; IDparent = parent DA if note has ID parent, else 0
62 ; prmsort = 'TITLE' if entries ordered by title, else 'REFDT'
63 ;Note: TIUGDATA is nonzero if note is POSSIBLE DAD, or dad, or kid.
64 ; Requires TIUDA; TIUD0 & TIUD21 are optional
65 N HASIDKID,POSSPRNT,TIUDPRM,PRMSORT,TIUGDATA
66 I '$G(TIUD0) S TIUD0=^TIU(8925,TIUDA,0)
67 I '$D(TIUD21) S TIUD21=+$G(^TIU(8925,TIUDA,21))
68 S (TIUGDATA,POSSPRNT)=0
69 S HASIDKID=$$HASIDKID^TIUGBR(TIUDA)
70 I 'TIUD21,'HASIDKID S POSSPRNT=$$POSSPRNT^TIULP(+TIUD0) ;has bus rules
71 I TIUD21!HASIDKID!POSSPRNT D
72 . I 'TIUD21 D I 1
73 . . D DOCPRM^TIULC1(+TIUD0,.TIUDPRM)
74 . . S PRMSORT=$S($P($G(TIUDPRM(0)),U,18):"TITLE",1:"REFDT")
75 . E S PRMSORT=""
76 . S TIUGDATA=TIUDA_U_HASIDKID_U_TIUD21_U_PRMSORT
77 Q TIUGDATA
78 ;
79RESOLVE(DA,TSTART,FIRSTPFX,XIDDATA) ; Get document data for insertion
80 ; Receives DA, TSTART, FIRSTPFX
81 ; FIRSTPFX = $$INSPFIX of parent of inserted document.
82 ; Returns line TSTART.
83 ; Receives XIDDATA by ref, finds it, and passes it back.
84 N DIC,DIQ,DR,TIUR,PT,MOM,ADT,DDT,LCT,AUT,AMD,EDT,SDT,XDT,RMD,TIULST4
85 N TIUP,TIUD0,TIUD12,TIUD13,TIUD15,TIULI,STATX,DOC,TIUY,TIUI,TIUFLDS
86 N PREFIX,GETTL,GETPT,TIUD21,INSTA,TIUSTN
87 I '$D(^TIU(8925,DA,0)) S TIUY="Record #"_DA_" is missing." G RESOLVEX
88 S TIUD0=$G(^TIU(8925,+DA,0)),TIUD12=$G(^TIU(8925,+DA,12))
89 S TIUD13=$G(^TIU(8925,+DA,13)),TIUD15=$G(^TIU(8925,+DA,15))
90 S TIUD21=$G(^TIU(8925,+DA,21))
91 S XIDDATA=$$IDDATA(DA,TIUD0,TIUD21)
92 S PREFIX=$$PREFIX^TIULA2(DA),PREFIX=FIRSTPFX_PREFIX
93 S GETTL=$$GETTL(TIUD0,PREFIX)
94 ; Most screens have docmt title in 1st column, but some have pat nm:
95 S DOC=$S($D(VALMDDF("PATIENT NAME")):$P(GETTL,U),1:$P(GETTL,U,2)_$P(GETTL,U))
96 S TIUFLDS("DOCUMENT TYPE")="DOC"
97 S TIUFLDS("TITLE")="DOC"
98 S GETPT=$$GETPT(TIUD0,PREFIX)
99 S TIULI=$E(GETPT)
100 S PT=$P(GETPT,U,2)_$P(GETPT,U)
101 S TIUFLDS("PATIENT NAME")="PT"
102 S TIULST4=$E($P($G(^DPT(+$P(TIUD0,U,2),0)),U,9),6,9)
103 S TIULST4="("_TIULI_TIULST4_")"
104 S TIUFLDS("LAST I/LAST 4")="TIULST4"
105 S ADT=$$DATE^TIULS($P(TIUD0,U,7),"MM/DD/YY")
106 S TIUFLDS("ADMISSION DATE")="ADT"
107 S DDT=$$DATE^TIULS($P(TIUD0,U,8),"MM/DD/YY"),LCT=$P(TIUD0,U,10)
108 S TIUFLDS("DISCH DATE")="DDT"
109 S TIUFLDS("LINE COUNT")="AMD"
110 S AMD=$$PERSNAME^TIULC1($P(TIUD12,U,8)) S:AMD="UNKNOWN" AMD=""
111 S AUT=$$PERSNAME^TIULC1($P(TIUD12,U,2)) S:AUT="UNKNOWN" AUT=""
112 S AMD=$$NAME^TIULS(AMD,"LAST, FI MI")
113 S TIUFLDS("ATTENDING")="AMD"
114 S TIUFLDS("COSIGNER")="AMD"
115 I $D(^TMP("TIUR",$J,"CTXT")) S AUT=$$NAME^TIULS(AUT,"LAST,FI") I 1
116 E S AUT=$$NAME^TIULS(AUT,"LAST, FI MI")
117 S TIUFLDS("AUTHOR")="AUT"
118 I $D(^TMP("TIUR",$J,"CTXT")) S EDT=$$DATE^TIULS($P(TIUD13,U),"MM/DD/YY HR:MIN") I 1
119 E S EDT=$$DATE^TIULS($P(TIUD13,U),"MM/DD/YY")
120 S TIUFLDS("REF DATE")="EDT"
121 S XDT=$$DATE^TIULS($P(TIUD13,U,7),"MM/DD/YY")
122 S TIUFLDS("DICT DATE")="XDT"
123 S SDT=$S(+$P(TIUD15,U,7):+$P(TIUD15,U,7),+$P(TIUD0,U,5)'<7:+$P(TIUD15,U),1:"")
124 S SDT=$$DATE^TIULS(SDT,"MM/DD/YY")
125 S TIUFLDS("SIG DATE")="SDT"
126 S STATX=$$LOW^XLFSTR($P($G(^TIU(8925.6,+$P(TIUD0,U,5),0)),U))
127 S TIUFLDS("STATUS")="STATX"
128 S INSTA=""
129 I +$P(TIUD12,U,12)>0 D
130 . S TIUSTN=$$NS^XUAF4($P(TIUD12,U,12))
131 . I $P(TIUSTN,U,2)]"" S INSTA=$P(TIUSTN,U,2)
132 S INSTA=$E(INSTA,1,8)
133 S TIUFLDS("DIVISION")="INSTA"
134 S (TIUI,TIUY)=""
135 S TIUY=$$SETFLD^VALM1(TSTART,TIUY,"NUMBER")
136 F S TIUI=$O(TIUFLDS(TIUI)) Q:TIUI="" D
137 . S:$D(VALMDDF(TIUI)) TIUY=$$SETFLD^VALM1(@TIUFLDS(TIUI),TIUY,TIUI)
138RESOLVEX Q TIUY
139 ;
140GETPT(TIUD0,PREFIX) ; Get patient column data; put updated prefix data
141 ;in second ^ piece
142 ; Receives TIUDO, PREFIX.
143 ; Returns (patient col data)^PREFIX
144 N TIUY
145 S TIUY=$$NAME^TIULS($$PTNAME^TIULC1($P(TIUD0,U,2)),"LAST,FI MI")
146 I $D(PREFIX) S TIUY=TIUY_U_PREFIX
147 Q TIUY
148 ;
149GETTL(TIUD0,PREFIX) ; Get title column data; put updated prefix
150 ;data in second ^ piece.
151 ; Receives TIUDO, PREFIX.
152 ; Returns (title col data)^PREFIX
153 N TIUY
154 S TIUY=$$PNAME^TIULC1(+TIUD0)
155 I TIUY="Addendum" S TIUY="Addendum to "_$$PNAME^TIULC1(+$G(^TIU(8925,+$P(TIUD0,U,6),0)))
156 I $D(PREFIX) S TIUY=TIUY_U_PREFIX
157 Q TIUY
158 ;
159SETTLPT(STRING,DA,PREFIX) ; Set field TITLE or PATIENT into string,
160 ;with prefix as first chars of string.
161 ; Receives STRING, DA, PREFIX:
162 ; PREFIX = beginning chars of title/pt column, up to but not
163 ; including title/pt itself.
164 ; Returns STRING.
165 N PT,DOC,TIUD0
166 S TIUD0=^TIU(8925,DA,0)
167 I $D(VALMDDF("PATIENT NAME")) D I 1
168 . S PT=$$GETPT(TIUD0,PREFIX)
169 . S PT=$P(PT,U,2)_$P(PT,U)
170 . S STRING=$$SETFLD^VALM1(PT,STRING,"PATIENT NAME")
171 E D
172 . S DOC=$$GETTL(TIUD0,PREFIX)
173 . S DOC=$P(DOC,U,2)_$P(DOC,U)
174 . S STRING=$$SETFLD^VALM1(DOC,STRING,"TITLE")
175 Q STRING
Note: See TracBrowser for help on using the repository browser.