source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDI4.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.7 KB
Line 
1TIUEDI4 ; SLC/JER - Enter/Edit a Document ; 7-FEB-2001 08:01:51
2 ;;1.0;TEXT INTEGRATION UTILITIES;**100,109,216**;Jun 20, 1997
3 ;new rtn in TSC, created feb 2 from TIUEDIT
4 ; 2/2: Moved LOADDFLT, BOIL, CANXEC, REPLACE, INSMULT to TIUEDI4
5 ; 2/3 moved DIE, TEXTEDIT from TIUEDIT to TIUEDI4
6 ; 3/2 moved SETTL, GETVST, ASKOK from TIUEDIT to TIUEDI4
7 ;
8SETTL(TIUTYP,TIUCLASS,TIUTITLE) ; Set array TIUTYP w/ title info
9 ; e.g. TIUTYP(1) = 1^113^CRISIS, where 113 is IFN of CRISIS title,
10 ; TIUTYP = 1 if gotten from TIUTITLE
11 ; TIUTYP = 113 if gotten from user
12 ; Requires TIUCLASS
13 ; Receives TIUTITLE - optional = Title DA or Title Name or DA^Name
14 N TIUDFLT
15 ; -- Get title from TIUTITLE if it's there: --
16 I $G(TIUTITLE)]"",$S(+$G(NOSAVE):1,+$P(TIUTITLE,U,2):1,1:0) D I 1
17 . S TIUTYP=1,TIUTITLE=$P(TIUTITLE,U)
18 . S TIUTYP(1)=1_U_$S(+$G(TIUTITLE)>0:+$G(TIUTITLE),1:+$O(^TIU(8925.1,"B",TIUTITLE,0)))
19 . S $P(TIUTYP(1),U,3)=$$PNAME^TIULC1(+$P(TIUTYP(1),U,2))
20 ; -- If not, ask user: --
21 E D
22 . S TIUDFLT="LAST" ; use user's preferred list of docmts
23 . D DOCSPICK^TIULA2(.TIUTYP,TIUCLASS,"1A",TIUDFLT,"","+$$CANPICK^TIULP(+Y),+$$CANENTR^TIULP(+Y)")
24 I +$G(TIUTYP)'>0 S TIUOUT=1 Q
25 S TIUTYP=+$P($G(TIUTYP(1)),U,2)
26 Q
27 ;
28GETVST(DFN,TIUTYP,TIU,EVNTFLAG) ; Get visit, set array TIU
29 ; -- If no eventflag & don't suppress visit, then execute
30 ; visit linkage method: --
31 ; Requires DFN
32 ; Requires simple variable TIUTYP = title DA
33 ; Optional EVNTFLAG
34 ; Returns array TIU
35 N TIUVSUPP,TIULMETH
36 S TIUVSUPP=0
37 I '$G(EVNTFLAG) S TIUVSUPP=+$$SUPPVSIT^TIULC1(TIUTYP)
38 ; -- execute visit linkage method for TIUTYP --
39 I 'TIUVSUPP,'$G(EVNTFLAG) D I 1
40 . S TIULMETH=$$GETLMETH^TIUEDI1(TIUTYP)
41 . I '$L(TIULMETH) D S TIUOUT=1 Q
42 . . W !,$C(7),"No Visit Linkage Method defined for "
43 . . W $$PNAME^TIULC1(TIUTYP),".",!,"Please contact IRM..."
44 . ; -- TIULMETH for PN: D ENPN^TIUVSIT(.TIU,.DFN,1) --
45 . X TIULMETH
46 ; -- else create new historical "E" visit: --
47 E D EVENT^TIUSRVP1(.TIU,DFN)
48 I $S($D(DIROUT):1,$D(DTOUT):1,1:0) S TIUQUIT=1 Q
49 I '$D(TIU("VSTR")) D
50 . W !,$C(7),"Patient & Visit required." H 2
51 Q
52 ;
53ASKOK(TIUTYP,TIU,TIUBY,TIUASK) ; X Validation method.
54 ; Receives and returns array TIU, simple var TIUTYP, [array TIUBY]
55 ; Sets TIUASK = answer, = 0 for not OK or 1 for OK
56 N TIUVMETH
57 S TIUVMETH=$$GETVMETH^TIUEDI1(TIUTYP)
58 I '$L(TIUVMETH) D S TIUOUT=1 Q
59 . W !,$C(7),"No Validation Method defined for "
60 . W $$PNAME^TIULC1(TIUTYP),".",!,"Please contact IRM..."
61 ; -- TIUVMETH for PN: S TIUASK=$$CHEKPN^TIULD(.TIU,.TIUBY) --
62 X TIUVMETH
63 ; -- If finish without a visit, then quit: --
64 I '$D(TIU("VSTR")) D
65 . W !,$C(7),"Patient & Visit required." H 2
66 Q
67 ;
68DIE(DA,TIUQUIT,TIUCHNG) ; Invoke ^DIE
69 N Y,DIE,DR
70 I '$D(TIUPREF) S TIUPREF=$$PERSPRF^TIULE(DUZ)
71 L +^TIU(8925,+DA):1
72 E D Q
73 . W !!?5,$C(7),"Another user is editing this entry.",! S TIUQUIT=2
74 . I $$READ^TIUU("FOA","Press RETURN to continue...") W ""
75 S ^TIU(8925,"ASAVE",DUZ,DA)=""
76 S DR=$$GETTMPL^TIUEDI1(+$P(^TIU(8925,+DA,0),U))
77 I DR']"" W !?5,$C(7),"No Edit template defined for ",$$PNAME^TIULC1(+$P(^TIU(8925,+DA,0),U)),! S TIUQUIT=2 Q
78 S DIE=8925 D ^DIE
79 I $D(Y)!($D(DTOUT)) S TIUQUIT=1
80 I +$G(TIUQUIT)>0,+$G(TIUNEW)>0 Q
81 D:+$G(TIUQUIT) UPDTIRT^TIUDIRT(.TIU,DA),SEND^TIUALRT(DA)
82 Q:+$G(TIUQUIT)
83 D TEXTEDIT(DA,.TIUCHNG)
84 I +$G(^TIU(8925,DA,0))'>0 S TIUQUIT=2 Q
85 S DR=".05///"_$$STATUS^TIULC(DA),DIE=8925 D ^DIE
86 D UPDTIRT^TIUDIRT(.TIU,DA),SEND^TIUALRT(DA)
87 L -^TIU(8925,+DA)
88 Q
89TEXTEDIT(DA,TIUCMMT,TIUCHNG) ; Call DIWE
90 N DIC,DIWE,DIWESUB,DIWPT,DR,DWHD,DWI,DWLC,DWLR,DWLW,DWO,DWPK,DDWRW
91 N TIUCKSM0,TIUCKSM1,TIUESNM,TIUESBLK
92 S TIUESNM=$$DECRYPT^TIULC1($P($G(^TIU(8925,DA,15)),U,3),1,$$CHKSUM^TIULC("^TIU(8925,"_+DA_",""TEXT"")"))
93 S TIUESBLK=$$DECRYPT^TIULC1($P($G(^TIU(8925,DA,15)),U,4),1,$$CHKSUM^TIULC("^TIU(8925,"_+DA_",""TEXT"")"))
94 W !!,"Calling text editor, please wait..." H 1
95 X:$L($G(TIUPRM3)) TIUPRM3
96 D BUFFER^TIUEDIU(DA) ; Load edit buffer to protect original from booboos
97 S TIUCKSM0=$$CHKSUM^TIULC("^TIU(8925,"_+DA_",""TEMP"")")
98 I $D(^TIU(8925,+DA,"TEXT"))'>9 D LOADDFLT(DA,+$P(TIUTYP(1),U,2))
99 S DIWESUB="Patient: "_$G(TIU("PNM")),DIC="^TIU(8925,"_+DA_",""TEMP"","
100 I $G(VALMAR)="^TMP(""TIUVIEW"",$J)",(+$G(VALMBG)>5),(+$G(VALMBG)'>(+$P($G(^TIU(8925,+DA,"TEXT",0)),U,3)+4)) S DDWRW=+$G(VALMBG)-4
101 S DWPK=1,DWLW=74 D EN^DIWE
102 ; DELETE if NOSAVE
103 I +$G(NOSAVE) D DELETE^TIUEDIT(DA,0) S TIUQUIT=2 Q
104 ; Save edit buffer
105 S TIUCKSM1=$$CHKSUM^TIULC("^TIU(8925,"_+DA_",""TEMP"")")
106 I TIUCKSM0'=TIUCKSM1 D I 1
107 . D COMMIT^TIUEDIU(DA),AUDIT^TIUEDI1(DA,TIUCKSM0,TIUCKSM1)
108 . S TIUCHNG=1
109 . ; re-file /es/-block
110 . I $L(TIUESNM) D
111 . . S DR="1503///^S X=TIUESNM;1504///^S X=TIUESBLK",DIE=8925
112 . . D ^DIE
113 E W !,"No changes made..." D COMMIT^TIUEDIU(DA,1) S TIUCHNG=0
114 S DIE=8925,DR=".1///"_$$LINECNT^TIULC(DA) D ^DIE
115 Q
116 ;
117LOADDFLT(DA,TIUTYP) ; Load bp text
118 N TIUI,TIUJ,TIUK,TIUL S TIUI=0
119 S TIUJ=+$P($G(^TIU(8925,+DA,"TEMP",0)),U,3)+1
120 ; - Set comp hdr -
121 S ^TIU(8925,+DA,"TEMP",TIUJ,0)=$S($P($G(^TIU(8925.1,+TIUTYP,0)),U,4)="CO":$P(^TIU(8925.1,+TIUTYP,0),U)_": ",1:"")
122 I +TIUJ=1,($G(^TIU(8925,+DA,"TEMP",TIUJ,0))']"") K ^TIU(8925,+DA,"TEMP",TIUJ,0) S TIUJ=0
123 S ^TIU(8925,+DA,"TEMP",0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
124 F S TIUI=$O(^TIU(8925.1,+TIUTYP,"DFLT",TIUI)) Q:+TIUI'>0 D
125 . S TIUJ=TIUJ+1,X=$G(^TIU(8925.1,+TIUTYP,"DFLT",TIUI,0))
126 . I $L($T(DOLMLINE^TIUSRVF1)),'$D(XWBOS),(X["{FLD:") S X=$$DOLMLINE^TIUSRVF1(X)
127 . I X["|" S X=$$BOIL(X,TIUJ)
128 . I X["~@" D INSMULT(X,"^TIU(8925,"_+DA_",""TEMP"")",.TIUJ) I 1
129 . E S ^TIU(8925,+DA,"TEMP",TIUJ,0)=X
130 . S ^TIU(8925,+DA,"TEMP",0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
131 I +$O(^TIU(8925.1,+TIUTYP,10,0)) D
132 . N TIUFITEM,TIUI
133 . D ITEMS^TIUFLT(+TIUTYP)
134 . S TIUI=0 F S TIUI=$O(TIUFITEM(TIUI)) Q:+TIUI'>0 D
135 . . S TIUL=+$G(TIUFITEM(+TIUI)) D LOADDFLT(DA,TIUL)
136 Q
137BOIL(LINE,COUNT) ; execute objects
138 N TIUI,DIC,X,Y,TIUFPRIV S TIUFPRIV=1
139 N TIUOLDR,TIUNEWR,TIUOLDG,TIUNEWG
140 S DIC=8925.1,DIC(0)="FMXZ"
141 S DIC("S")="I $P($G(^TIU(8925.1,+Y,0)),U,4)=""O"""
142 F TIUI=2:2:$L(LINE,"|") S X=$P(LINE,"|",TIUI) D
143 . D ^DIC
144 . I +Y'>0 S X="The OBJECT "_X_" was NOT found...Contact IRM."
145 . I +Y>0 D
146 . . I $D(^TIU(8925.1,+Y,9)),+$$CANXEC(+Y) X ^(9) S:X["~@" X=$$APPEND(X) I 1
147 . . E S X="The OBJECT "_X_" is INACTIVE...Contact IRM."
148 . . I X["~@" D
149 . . . I X'["^" D
150 . . . . S TIUOLDR=$P(X,"~@",2),TIUNEWR=TIUOLDR_TIUI
151 . . . . M @TIUNEWR=@TIUOLDR K @TIUOLDR
152 . . . . S $P(X,"~@",2)=TIUNEWR
153 . . . I X["^" D
154 . . . . S TIUOLDG=$P(X,"~@",2),TIUNEWG="^TMP("_"""TIU201"""_","_$J_","_TIUI_")"
155 . . . . M @TIUNEWG=@TIUOLDG
156 . . . . S $P(X,"~@",2)=TIUNEWG
157 . S LINE=$$REPLACE(LINE,X,TIUI)
158 Q $TR(LINE,"|","")
159CANXEC(TIUODA) ; Eval Obj Status
160 N TIUOST,TIUY S TIUOST=+$P($G(^TIU(8925.1,+TIUODA,0)),U,7)
161 S TIUY=$S(TIUOST=11:1,+$G(NOSAVE):1,1:0)
162 Q +$G(TIUY)
163REPLACE(LINE,X,TIUI) ; Replace TIUIth object in LINE
164 S $P(LINE,"|",TIUI)=X
165 Q LINE
166INSMULT(LINE,TARGET,TIULCNT) ; Mult-valued results
167 N TIUPC
168 F TIUPC=2:2:$L(LINE,"~@") D
169 . N TIUI,TIULINE,TIUX,TIUSRC,TIUSCNT,TIUTAIL
170 . S TIUSRC=$P(LINE,"~@",TIUPC)
171 . S TIUTAIL=$P(LINE,"~@",TIUPC+1)
172 . S TIULINE=$P(LINE,"~@",(TIUPC-1)),(TIUI,TIUSCNT)=0
173 . I $E(TIULINE)=" ",(TIUPC>2) S $E(TIULINE)=""
174 . F S TIUI=$O(@TIUSRC@(TIUI)) Q:+TIUI'>0 D
175 . . N TIUSLINE
176 . . S TIUSCNT=TIUSCNT+1
177 . . S TIUSLINE=$G(@TIUSRC@(TIUI,0))
178 . . S:'+$O(@TIUSRC@(TIUI))&(TIUPC+2>$L(LINE,"~@")) TIUSLINE=TIUSLINE_TIUTAIL
179 . . I TIUSCNT=1,($L(TIULINE_TIUSLINE)>73) D Q
180 . . . S:$D(@TARGET@(TIULCNT,0)) TIULCNT=TIULCNT+1
181 . . . S @TARGET@(TIULCNT,0)=TIULINE
182 . . . S TIULCNT=TIULCNT+1
183 . . . S @TARGET@(TIULCNT,0)=TIUSLINE
184 . . I TIUSCNT=1,($L(TIULINE_TIUSLINE)'>73) D Q
185 . . . S:$D(@TARGET@(TIULCNT,0)) TIULCNT=TIULCNT+1
186 . . . S @TARGET@(TIULCNT,0)=TIULINE_TIUSLINE
187 . . S:$D(@TARGET@(TIULCNT,0)) TIULCNT=TIULCNT+1
188 . . S @TARGET@(TIULCNT,0)=$G(TIUSLINE)
189 . K @TIUSRC
190 Q
191APPEND(X) ;
192 N TIUXL S TIUXL=$L(X)
193 I $E(X,TIUXL-1,TIUXL)'="~@" S X=X_"~@"
194 Q X
Note: See TracBrowser for help on using the repository browser.