source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUSRVD.m@ 1078

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

initial load of WorldVistAEHR

File size: 7.3 KB
Line 
1TIUSRVD ; SLC/JER - RPC's for document definition ; 09/12/2003 [6/8/05 8:07am]
2 ;;1.0;TEXT INTEGRATION UTILITIES;**1,7,22,47,103,100,115,164,112,186,201**;Jun 20, 1997
3NOTES(TIUY) ; Get list of PN Titles
4 D LIST(.TIUY,3)
5 Q
6SUMMARY(TIUY) ; Get list of DS Titles
7 D LIST(.TIUY,244)
8 Q
9LIST(TIUY,CLASS,TYPE,TIUK) ; Get list of document titles
10 N TIUDFLT
11 ; TIUK is STATIC
12 S TIUK=+$G(TIUK)
13 I $G(TYPE)']"" S TYPE="DOC"
14 ; If the user has a preferred list of titles for the CLASS, get it
15 I +$O(^TIU(8925.98,"AC",DUZ,CLASS,0)) D PERSLIST(.TIUY,DUZ,CLASS,.TIUK,1)
16 S TIUK=+$G(TIUK)+1 S TIUY(TIUK)="~LONG LIST"
17 D TRAVERSE(.TIUY,CLASS,$G(TYPE),.TIUK)
18 S TIUDFLT=$$PERSDOC^TIULE(DUZ,+CLASS)
19 I +TIUDFLT S TIUK=+$G(TIUK)+1,TIUY(TIUK)="d"_$P(TIUDFLT,U,2)
20 Q
21TRAVERSE(TIUY,CLASS,TYPE,TIUK) ; Get all selectable titles for the CLASS
22 N I,J,X,CURTYP,Y,TIUI,TIUC,TYPMATCH S (TIUC,TIUI)=0
23 S TIUK=+$G(TIUK)
24 I $S(+$$CANENTR^TIULP(CLASS)'>0:1,+$$CANPICK^TIULP(CLASS)'>0:1,1:0) Q
25 S CURTYP=$P(^TIU(8925.1,+CLASS,0),U,4)
26 S TYPMATCH=$$TYPMATCH^TIULA1(TYPE,CURTYP)
27 I +TYPMATCH S TIUK=+$G(TIUK)+1
28 I S TIUY(TIUK)="i"_+CLASS_U_$$PNAME^TIULC1(+CLASS)
29 S I=0 F S I=$O(^TIU(8925.1,+CLASS,10,I)) Q:+I'>0 D
30 . N J
31 . S J=+$G(^TIU(8925.1,+CLASS,10,+I,0)) Q:+J'>0
32 . D TRAVERSE(.TIUY,+J,TYPE,.TIUK)
33 Q
34PERSLIST(TIUY,DUZ,CLASS,TIUC,TIUFLG) ; Get personal list for a user
35 N TIUI,TIUDA,TIUDFLT,INLST
36 S TIUDA=+$O(^TIU(8925.98,"AC",DUZ,CLASS,0))
37 Q:+TIUDA'>0
38 I +$G(TIUFLG) S TIUC=1,TIUY(TIUC)="~SHORT LIST"
39 S TIUI=0,TIUC=+$G(TIUC)
40 F S TIUI=$O(^TIU(8925.98,TIUDA,10,TIUI)) Q:+TIUI'>0 D
41 . N TIUPL,TIUTNM,TIUDTYP,TIUSEQ
42 . S TIUPL=$G(^TIU(8925.98,TIUDA,10,TIUI,0))
43 . S TIUDTYP=$P(TIUPL,U)
44 . I $S(+$$CANENTR^TIULP(TIUDTYP)'>0:1,+$$CANPICK^TIULP(TIUDTYP)'>0:1,1:0) Q
45 . S TIUTNM=$S($P(TIUPL,U,3)]"":$P(TIUPL,U,3),1:$$PNAME^TIULC1(+TIUDTYP))
46 . S TIUSEQ=+$P(TIUPL,U,2),TIUC=+$G(TIUC)+1
47 . S TIUSEQ=$S(+TIUSEQ:$S('$D(TIUY(TIUSEQ)):TIUSEQ,1:(TIUSEQ+1)),1:TIUC)
48 . S TIUY(TIUSEQ)="i"_TIUDTYP_U_TIUTNM,TIUC=+TIUSEQ
49 I +$G(TIUFLG) Q
50 S TIUDFLT=$$PERSDOC^TIULE(DUZ,+CLASS)
51 S (TIUI,TIUC)=0
52 F S TIUI=$O(TIUY(TIUI)) Q:+TIUI'>0 D
53 . S TIUC=TIUI
54 . I +TIUDFLT,($P($G(TIUY(TIUI)),U)=("i"_+TIUDFLT)) S $P(TIUDFLT,U,2)=$P(TIUY(TIUI),U,2),INLST=TIUI
55 I +TIUDFLT D
56 . ;if default isn't in list, append it as an item
57 . I '$G(INLST) S TIUC=+$G(TIUC)+1,TIUY(TIUC)="i"_TIUDFLT
58 . ;otherwise, just append as default
59 . S TIUC=+$G(TIUC)+1,TIUY(TIUC)="d"_TIUDFLT
60 Q
61BLRSHELL(TIUY,TITLE,DFN,VSTR) ; Shell for boilerplate RPC
62 K ^TMP("TIUBOIL",$J)
63 D BLRPLT(.TIUY,TITLE,DFN,$G(VSTR))
64 K ^TMP("TIUBOIL",$J,0)
65 Q
66BLRPLT(TIUY,TITLE,DFN,VSTR,ROOT) ; Load/Execute the Boilerplate for TITLE
67 ; or ROOT
68 N TIU,TIUI,TIUJ,TIUK,TIUL,VADM,VAIN,VA,VAERR S TIUI=0
69 S:'$D(TIUY) TIUY=$NA(^TMP("TIUBOIL",$J))
70 S:'$D(ROOT) ROOT=$NA(^TIU(8925.1,+TITLE,"DFLT")) ; **47**
71 I $L($G(VSTR)) D PATVADPT^TIULV(.TIU,DFN,"",$G(VSTR)) ; **47**
72 S TIUJ=+$P($G(^TMP("TIUBOIL",$J,0)),U,3)+1
73 ; --- Set component header ---
74 I ROOT["^TIU(8925.1," D
75 . S ^TMP("TIUBOIL",$J,TIUJ,0)=$S($P($G(^TIU(8925.1,+TITLE,0)),U,4)="CO":$P(^TIU(8925.1,+TITLE,0),U)_": ",1:"")
76 I +TIUJ=1,($G(^TMP("TIUBOIL",$J,TIUJ,0))']"") K ^TMP("TIUBOIL",$J,TIUJ,0) S TIUJ=0
77 S ^TMP("TIUBOIL",$J,0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
78 F S TIUI=$O(@ROOT@(TIUI)) Q:+TIUI'>0 D
79 . S TIUJ=TIUJ+1,X=$G(@ROOT@(TIUI,0))
80 . I $L($T(DOLMLINE^TIUSRVF1)),'$D(XWBOS),(X["{FLD:") S X=$$DOLMLINE^TIUSRVF1(X)
81 . I X["|" S X=$$BOIL(X,TIUJ)
82 . I X["~@" D INSMULT(X,"^TMP(""TIUBOIL"",$J)",.TIUJ) I 1
83 . E S ^TMP("TIUBOIL",$J,TIUJ,0)=X
84 . S ^TMP("TIUBOIL",$J,0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
85 I ROOT["^TIU(8925.1,",+$O(^TIU(8925.1,+TITLE,10,0)) D
86 . N TIUFITEM,TIUI D ITEMS^TIUFLT(+TITLE)
87 . S TIUI=0 F S TIUI=$O(TIUFITEM(TIUI)) Q:+TIUI'>0 D
88 . . S TIUL=+$G(TIUFITEM(+TIUI)) D BLRPLT(.TIUY,TIUL,DFN,$G(VSTR))
89 Q
90BOIL(LINE,COUNT) ; Execute Boilerplates
91 N TIUNEWG,TIUNEWR,TIUOLDG,TIUOLDR
92 N TIUI,DIC,X,Y,TIUFPRIV S TIUFPRIV=1
93 S DIC=8925.1,DIC(0)="FMXZ"
94 S DIC("S")="I $P($G(^TIU(8925.1,+Y,0)),U,4)=""O"""
95 F TIUI=2:2:$L(LINE,"|") S X=$P(LINE,"|",TIUI) D
96 . D ^DIC
97 . I +Y'>0 S X="The OBJECT "_X_" was NOT found...Contact IRM."
98 . I +Y>0 D
99 . . I $D(^TIU(8925.1,+Y,9)),+$$CANXEC(+Y) X ^(9) S:X["~@" X=$$APPEND(X) I 1
100 . . E S X="The OBJECT "_X_" is INACTIVE...Contact IRM."
101 . . I X["~@" D
102 . . . I X'["^" D
103 . . . . S TIUOLDR=$P(X,"~@",2),TIUNEWR=TIUOLDR_TIUI
104 . . . . M @TIUNEWR=@TIUOLDR K @TIUOLDR
105 . . . . S $P(X,"~@",2)=TIUNEWR
106 . . . I X["^" D
107 . . . . S TIUOLDG=$P(X,"~@",2),TIUNEWG="^TMP("_"""TIU201"""_","_$J_","_TIUI_")"
108 . . . . M @TIUNEWG=@TIUOLDG K @TIUOLDG
109 . . . . S $P(X,"~@",2)=TIUNEWG
110 . S LINE=$$REPLACE(LINE,X,TIUI)
111 Q $TR(LINE,"|","")
112CANXEC(TIUODA) ; Evaluate Object Status
113 N TIUOST,TIUY S TIUOST=+$P($G(^TIU(8925.1,+TIUODA,0)),U,7)
114 S TIUY=$S(TIUOST=11:1,+$G(NOSAVE):1,1:0)
115 Q +$G(TIUY)
116APPEND(X) ;
117 N TIUXL S TIUXL=$L(X)
118 I $E(X,TIUXL-1,TIUXL)'="~@" S X=X_"~@"
119 Q X
120REPLACE(LINE,X,TIUI) ; Replace the TIUIth object in LINE w/X
121 S $P(LINE,"|",TIUI)=X
122 Q LINE
123INSMULT(LINE,TARGET,TIULCNT) ; Mult-valued results
124 N TIUPC,TIULGTH
125 ; TIU*1*164 ;
126 S TIULGTH=73 ; 2 replacements of 73 below for TIULGTH
127 S:$$BROKER^XWBLIB TIULGTH=80
128 F TIUPC=2:2:$L(LINE,"~@") D
129 . N TIUI,TIULINE,TIUX,TIUSRC,TIUSCNT,TIUTAIL
130 . S TIUSRC=$P(LINE,"~@",TIUPC)
131 . S TIUTAIL=$P(LINE,"~@",TIUPC+1)
132 . S TIULINE=$P(LINE,"~@",(TIUPC-1)),(TIUI,TIUSCNT)=0
133 . I $E(TIULINE)=" ",(TIUPC>2) S $E(TIULINE)=""
134 . F S TIUI=$O(@TIUSRC@(TIUI)) Q:+TIUI'>0 D
135 . . N TIUSLINE
136 . . S TIUSCNT=TIUSCNT+1
137 . . S TIUSLINE=$G(@TIUSRC@(TIUI,0))
138 . . S:'+$O(@TIUSRC@(TIUI))&(TIUPC+2>$L(LINE,"~@")) TIUSLINE=TIUSLINE_TIUTAIL
139 . . I TIUSCNT=1,($L(TIULINE_TIUSLINE)>TIULGTH) D Q
140 . . . S:$D(@TARGET@(TIULCNT,0)) TIULCNT=TIULCNT+1
141 . . . S @TARGET@(TIULCNT,0)=TIULINE
142 . . . S TIULCNT=TIULCNT+1
143 . . . S @TARGET@(TIULCNT,0)=TIUSLINE
144 . . I TIUSCNT=1,($L(TIULINE_TIUSLINE)'>TIULGTH) D Q
145 . . . S:$D(@TARGET@(TIULCNT,0)) TIULCNT=TIULCNT+1
146 . . . S @TARGET@(TIULCNT,0)=TIULINE_TIUSLINE
147 . . S:$D(@TARGET@(TIULCNT,0)) TIULCNT=TIULCNT+1
148 . . S @TARGET@(TIULCNT,0)=$G(TIUSLINE)
149 . K @TIUSRC
150 Q
151LNGCNSLT(Y,FROM,DIR) ; Handle long list of titles for CONSULTS
152 N CLASS S CLASS=+$$CLASS^TIUCNSLT Q:+CLASS'>0
153 D LONGLIST(.Y,CLASS,$G(FROM),$G(DIR,1))
154 Q
155LNGSURG(Y,FROM,DIR,CLNAME) ; long list SURGICAL REPORT titles
156 ; CLNAME = "SURGICAL REPORTS" or "PROCEDURE REPORTS (NON-O.R.)"
157 ; depending on context
158 N CLASS S CLNAME=$S($G(CLNAME)]"":CLNAME,1:"OPERATION REPORTS")
159 S CLASS=$$CLASS^TIUSROI(CLNAME) Q:+CLASS'>0
160 D LONGLIST(.Y,CLASS,$G(FROM),$G(DIR,1))
161 Q
162LONGLIST(Y,CLASS,FROM,DIR,IDNOTE) ; long list of titles for a class
163 ; .Y=returned list, CLASS=ptr to class in 8925.1, FROM=text to $O from,
164 ; DIR=$O direction, IDNOTE=flag to indicate selection for ID Entry
165 N I,DA,CNT S I=0,CNT=44,DIR=$G(DIR,1)
166 F Q:I'<CNT S FROM=$O(^TIU(8925.1,"ACL",CLASS,FROM),DIR) Q:FROM="" D
167 . S DA=0
168 . F Q:I'<CNT S DA=$O(^TIU(8925.1,"ACL",CLASS,FROM,DA)) Q:+DA'>0 D
169 . . I $S(+$$CANENTR^TIULP(DA)'>0:1,+$$CANPICK^TIULP(DA)'>0:1,1:0) Q
170 . . I +$L($T(CANLINK^TIULP)),+$G(IDNOTE),(+$$CANLINK^TIULP(DA)'>0) Q
171 . . S I=I+1,Y(I)=DA_"^"_FROM
172 Q
173CNSLCLAS(Y) ; RPC to identify class CONSULTS
174 S Y=$$CLASS^TIUCNSLT
175 Q
176SURGCLAS(Y,CLNAME) ; RPC to identify class
177 ; CLNAME = "SURGICAL REPORTS" or "PROCEDURE REPORTS (NON-O.R.)"
178 S CLNAME=$G(CLNAME,"SURGICAL REPORTS")
179 S Y=$$CLASS^TIUSROI(CLNAME)
180 Q
181CANLINK(Y,TIUTTL) ; Wrap call to $$CANLINK^TIULP
182 S Y=$$CANLINK^TIULP(TIUTTL)
183 Q
Note: See TracBrowser for help on using the repository browser.