source: FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURS1.m@ 1614

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

initial load of FOIAVistA 6/30/08 version
File size: 8.9 KB
Line 
1TIURS1 ; SLC/JER - Additional /es/ actions ;1/18/05
2 ;;1.0;TEXT INTEGRATION UTILITIES;**7,36,58,100,109,142,156,184**;Jun 20, 1997
3 ;12/11/00 Moved ELSIG,MULTIPRN,LIST here from TIURS
4ELSIG ; Sign rec
5 N TIULST,TIUSLST,TIURJCT,TIUES,TIUI,X,X1,Y,TIUDAARY,TIUCHNG
6 I '$D(TIUPRM0) D SETPARM^TIULE
7 I $P(TIUPRM0,U,2)'>0 W !,"Electronic signature not yet enabled." H 3 G ELSIGX
8 I '$D(VALMY) D EN^VALM2(XQORNOD(0))
9 S TIUI=0 I $D(VALMY)>9 D CLEAR^VALM1
10 F S TIUI=$O(VALMY(TIUI)) Q:+TIUI'>0 D
11 . N TIU0,TIU12,TIUSTAT,TIUEVNT,TIUTYPE,TIUPOP,TIU15,TIUDPRM
12 . N ASK,SIGNER,COSIGNER,XTRASGNR,TIUDATA,TIUDA,RSTRCTD
13 . S (ASK,TIUPOP)=0
14 . S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI))
15 . S TIUDA=$P(TIUDATA,U,2) S RSTRCTD=$$DOCRES^TIULRR(TIUDA)
16 . I RSTRCTD D Q
17 . . W !!,$C(7),"Ok, no harm done...",! ; Echo denial message
18 . . I $$READ^TIUU("EA","RETURN to continue...") ; pause
19 . S TIU0=$G(^TIU(8925,+TIUDA,0)),TIU12=$G(^(12)),TIU15=$G(^(15))
20 . S SIGNER=$S(+$P(TIU12,U,4):$P(TIU12,U,4),1:$P(TIU12,U,2))
21 . S COSIGNER=$P(TIU12,U,8)
22 . I (DUZ'=SIGNER),(DUZ'=COSIGNER) S XTRASGNR=+$O(^TIU(8925.7,"AE",+TIUDA,+DUZ,0))
23 . S TIUSTAT=+$P(TIU0,U,5)
24 . S TIUTYPE=$$PNAME^TIULC1(+TIU0)
25 . S TIUEVNT=$S(TIUSTAT'>5:"SIGNATURE",+$G(XTRASGNR):"SIGNATURE",1:"COSIGNATURE")
26 . D DOCPRM^TIULC1(+TIU0,.TIUDPRM,TIUDA)
27 . S ASK=$$CANDO^TIULP(TIUDA,TIUEVNT)
28 . I +ASK>0 D
29 . . L +^TIU(8925,+TIUDA):1
30 . . E S ASK="0^ Another user is editing this entry."
31 . I +ASK'>0,$P(ASK,U,2)]"" D I 1
32 . . D FULL^VALM1
33 . . W !!,"Item #",TIUI,": ",$P(ASK,U,2),! K VALMY(TIUI)
34 . . W !,"Removed from signature list.",!
35 . . I $$READ^TIUU("FOA","Press RETURN to continue...")
36 . E D
37 . . ;If document is a clinical procedures title AND (P184) this is not an additional signature, check if clinical
38 . . ;procedure fields are required. If the fields are required, prompt for
39 . . ;them and don't permit the user to sign unless the fields are defined.
40 . . I '$G(XTRASGNR),+$$ISA^TIULX(+TIU0,+$$CLASS^TIUCP),$$REQCPF^TIULP(+$P($G(^TIU(8925,+TIUDA,14)),U,5)) D Q:+TIUPOP
41 . . . N TIUCPFLD
42 . . . W !!,"Item #",TIUI,": ",TIUTYPE," for "
43 . . . W $$PTNAME^TIULC1($P(TIU0,U,2))," will need Procedure Summary Code and Date/Time Performed..."
44 . . . I $G(^TIU(8925,+TIUDA,702)),$P(^(702),U)]"",$P(^(702),U,2)]"" S TIUCPFLD=1 Q
45 . . . S TIUCPFLD=$$ASKCPF^TIURS(TIUDA)
46 . . . I +TIUCPFLD'>0 D
47 . . . . S TIUPOP=1
48 . . . . W !!,"Item #",TIUI,": MUST have a Procedure Summary Code and Date/Time Performed",!,"before you may sign."
49 . . . . W !!,"Removed from signature list.",!
50 . . . . I $$READ^TIUU("FOA","Press RETURN to continue...")
51 . . I $S(+$$REQCOSIG^TIULP(+TIU0,+TIUDA,DUZ):1,+$P(TIU15,U,6):1,1:0),(+$P(TIU12,U,8)'>0) D Q:+TIUPOP
52 . . . N COSIGNER
53 . . . W !!,"Item #",TIUI,": ",TIUTYPE," for "
54 . . . W $$PTNAME^TIULC1($P(TIU0,U,2))," will need cosignature..."
55 . . . S COSIGNER=$$ASKCSNR^TIURS(TIUDA,DUZ)
56 . . . I +COSIGNER'>0 D
57 . . . . S TIUPOP=1
58 . . . . W !!,"Item #",TIUI,": MUST have a cosigner, before you may sign."
59 . . . . W !!,"Removed from signature list.",!
60 . . . . I $$READ^TIUU("FOA","Press RETURN to continue...")
61 . . N TIU,TIUY
62 . . D EN^VALM("TIU SIGN/COSIGN")
63 I $D(TIUSLST)'>9 D G ELSIGX
64 . S VALMSG="** Signature List Empty...Nothing signed. **"
65 I $D(TIUSLST)>9 D
66 . N TIUIO
67 . S TIUES=$$ASKSIG^TIULA1
68 . I '+TIUES S VALMSG="** Nothing Signed. **" D FIXLSTNW^TIULM Q
69 . D FULL^VALM1
70 . D MULTIPRN(.TIUSLST,.TIUIO)
71 . S TIUI=0 F S TIUI=$O(TIUSLST(TIUI)) Q:+TIUI'>0 D
72 . . N TIUPY,XTRASGNR
73 . . S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI)),TIUDA=$P(TIUDATA,U,2)
74 . . S TIUDAARY(TIUI)=TIUDA
75 . . S TIULST=$G(TIULST)_$S($G(TIULST)]"":",",1:"")_TIUI
76 . . S XTRASGNR=+$P(TIUSLST(TIUI),U,3)
77 . . I +$G(XTRASGNR) D ADDSIG^TIURS1(TIUDA,XTRASGNR)
78 . . I '+$G(XTRASGNR) D ES^TIURS(TIUDA,TIUES)
79 . . I +TIUSLST(TIUI),(TIUIO]"") D RPC^TIUPD(.TIUPY,TIUDA,TIUIO,$P(TIUSLST(TIUI),U,2))
80 . D FULL^VALM1
81ELSIGX I $G(TIUCHNG("ADDM"))!$G(TIUCHNG("DELETE")) S TIUCHNG("RBLD")=1
82 E S TIUCHNG("UPDATE")=1
83 D UPRBLD^TIURL(.TIUCHNG,.VALMY) K VALMY
84 S VALMBCK="R"
85 D VMSG($G(TIULST),.TIUDAARY,"signed")
86 Q
87VMSG(TIULST,TIUDAARY,ACTION) ; Set VALMSG for messagebar, bold changed items
88 N TIUI,LINENO,ACTFIRST
89 S ACTFIRST=$S(ACTION="Encounter Data Edited":1,ACTION="Signers identified/edited":1,ACTION="Title changed":1,1:0)
90 I TIULST']"" D Q
91 . I ACTFIRST S VALMSG="** No changes made. **" Q
92 . S VALMSG="** Nothing "_ACTION_". **"
93 I ACTION="copied" S ACTION="copied; See end of list"
94 S TIULST=$$NEWLST(TIULST,.TIUDAARY)
95 I TIULST]"" D
96 . I ACTFIRST D Q
97 . . S VALMSG="** "_ACTION_" for item"_$S($L(TIULST,",")>1:"s ",$L(TIULST,"-")>1:"s ",1:" ")_TIULST_". **"
98 . S VALMSG="** Item"_$S($L(TIULST,",")>1:"s ",$L(TIULST,"-")>1:"s ",1:" ")_TIULST_" "_ACTION_". **"
99 I TIULST']"" D
100 . I ACTFIRST D Q
101 . . S VALMSG="** "_ACTION_"; item(s) no longer in list. **"
102 . S VALMSG="** Item"_$S($L(TIULST,",")>1:"s ",$L(TIULST,"-")>1:"s ",1:" ")_TIULST_" "_ACTION_", no longer in list. **"
103 . ;S VALMSG="** Item(s) "_ACTION_", no longer in list. **"
104 Q:$G(^TMP("TIUR",$J,"RTN"))="TIUROR"
105 F TIUI=1:1 S LINENO=$P(TIULST,", ",TIUI) Q:'LINENO D
106 . D CNTRL^VALM10(LINENO,1,$G(VALM("RM")),IOINHI,IOINORM)
107 Q
108NEWLST(TIULST,TIUDAARY) ; Return TIULST with updated item numbers
109 N TIUI,TIULNO,TIUDA,TIUNLNO,TIUNLST
110 S TIUNLST=""
111 F TIUI=1:1 S TIULNO=$P(TIULST,",",TIUI) Q:'TIULNO D
112 . S TIUDA=TIUDAARY(TIULNO),TIUNLNO=$O(^TMP("TIUR",$J,"IEN",TIUDA,0))
113 . I TIUNLNO S TIUNLST=$G(TIUNLST)_$S($G(TIUNLST)]"":", ",1:"")_TIUNLNO
114 Q TIUNLST
115 ;
116MULTIPRN(TIUSLST,TIUIO) ; ask device
117 N TIUI,TIUASK,TIUION,TIUPOK,IO,TIUPLIST,TIUSCRN S (TIUI,TIUPOK)=0
118 F S TIUI=$O(TIUSLST(TIUI)) Q:TIUI'>0!+TIUPOK S:+TIUSLST(TIUI) TIUPOK=1
119 I '+TIUPOK S TIUIO="" Q
120 S TIUPLIST=$$LIST(.TIUSLST)
121 W !!,"Please specify the device for printing item"
122 W $S(TIUPLIST[",":"s",TIUPLIST["-":"s",1:""),": ",TIUPLIST,!!
123 S TIUSCRN="I $L($G(^%ZIS(1,+Y,""TYPE""))),("";HFS;MT;BAR;VTRM;RES;CHAN;IMPC;""'[("";""_^(""TYPE"")_"";""))"
124 S TIUION=$$DEVICE^TIUDEV(.TIUIO,"LAST","N",TIUSCRN,"Q")
125 I '$L(TIUION) S TIUIO=""
126 D ^%ZISC
127 Q
128LIST(LIST) ; build print list
129 N TIUY,TIUI S TIUI=0
130 F S TIUI=$O(LIST(TIUI)) Q:+TIUI'>0 D
131 . S:+LIST(TIUI) TIUY=$G(TIUY)_$S($G(TIUY)]"":", ",1:"")_TIUI
132 Q $G(TIUY)
133 ;
134ADDSIG(TIUDA,DA) ; Apply extra signatures to a document
135 N DIE,DR
136 S DIE=8925.7
137 S DR=".04////"_$$NOW^TIULC_";.05////"_DUZ_";.06///^S X=$$SIGNAME^TIULS("_DUZ_");.07///^S X=$$SIGTITL^TIULS("_DUZ_");.08////E"
138 D ^DIE
139 D SEND^TIUALRT(TIUDA)
140 Q
141CNVPOST ; Change Titles/Convert Postings
142 N TIUI,TIULST,Y,TIUVIEW,TIUCHNG,TIUDAARY
143 I $G(TIUGLINK) W !,"Please finish attaching the interdisciplinary note before changing title.",! H 3 Q
144 I '$D(VALMY) D EN^VALM2(XQORNOD(0))
145 S TIUI=0
146 I +$O(VALMY(0)) D FULL^VALM1
147 F S TIUI=$O(VALMY(TIUI)) Q:+TIUI'>0 D Q:$D(DIROUT)
148 . N TIU,TIUDA,DFN,TIUDATA,VALMY,XQORM,TIUVIEW,RSTRCTD
149 . S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI))
150 . S TIUDA=+$P(TIUDATA,U,2) S RSTRCTD=$$DOCRES^TIULRR(TIUDA)
151 . I RSTRCTD D Q
152 . . W !!,$C(7),"Ok, no harm done...",! ; Echo denial message
153 . . I $$READ^TIUU("EA","RETURN to continue...") ; pause
154 . S TIUVIEW=$$CANDO^TIULP(TIUDA,"VIEW")
155 . I +TIUVIEW'>0 D Q ; Exclude records user can't view
156 . . W !!,$C(7),$P(TIUVIEW,U,2),! ; Echo denial message
157 . . I $$READ^TIUU("EA","RETURN to continue...") ; pause
158 . S TIUCHNG=0
159 . D EN^VALM("TIU CHANGE TITLE")
160 . S TIUDAARY(TIUI)=TIUDA
161 . I +$G(TIUCHNG) S TIULST=$G(TIULST)_$S($G(TIULST)]"":",",1:"")_TIUI
162 ; -- Update list: --
163 S TIUCHNG("UPDATE")=1
164 D UPRBLD^TIURL(.TIUCHNG,.VALMY) K VALMY
165 S VALMBCK="R"
166 D VMSG($G(TIULST),.TIUDAARY,"Title changed")
167 Q
168CNVPOST1 ; Convert Single Posting to another title
169 N TIUD0,DIE,DR,TIUTITL,CHKSUM,TIUCHTTL,TIUCLSS,TIUCON,TIUQUIT
170 N DA,X,Y
171 ; Added TIUCON for **142
172 S TIUD0=$G(^TIU(8925,TIUDA,0)),TIUCHNG=0
173 ; Added TIUNOCS for **142
174 D FULL^VALM1
175 I +TIUD0=81 S TIUCHTTL="0^You may not change the TITLE of an ADDENDUM."
176 I '$D(TIUCHTTL) S TIUCHTTL=$$CANDO^TIULP(TIUDA,"CHANGE TITLE")
177 I +TIUCHTTL,$$DADORKID^TIUGBR(TIUDA) S TIUCHTTL="0^Interdisciplinary entries must be detached before changing titles." ;**100
178 I +TIUCHTTL'>0 D Q
179 . W !!,$C(7),$P(TIUCHTTL,U,2),! ; Echo denial
180 . I $$READ^TIUU("EA","RETURN to continue...") ; pause
181 L +^TIU(8925,TIUDA,0):1
182 E D Q
183 . W !!?5,$C(7),"Another user is editing this entry.",! ; Echo denial
184 . I $$READ^TIUU("EA","RETURN to continue...") ; pause
185 S TIUTITL=$$ASKTITLE^TIULA3(+$$CLINDOC^TIULC1(+TIUD0,TIUDA),+TIUD0)
186 S TIUCLSS=$$CLASS^TIUCNSLT()
187 S TIUCON=+$$ISA^TIULX(TIUTITL,TIUCLSS)
188 I TIUCON=1,+TIUD0'=TIUTITL D CHANGE^TIUCNSLT(TIUDA,"",.TIUNOCS)
189 I $G(TIUNOCS)=-1 D G POST1Q
190 . I $$READ^TIUU("EA","Press RETURN to continue...") ; **142
191 ;*184->
192 D CONSCT^TIUCNSLT(TIUDA,+TIUD0,TIUTITL)
193 D PRFCT^TIUPRF1(+TIUD0,TIUTITL,TIUDA)
194 ;<-*184
195 I $G(TIUQUIT)=1 G POST1Q
196 S DIE=8925,DA=TIUDA
197 S DR=".01////^S X="_TIUTITL_";.04////^S X="_$$DOCCLASS^TIULC1(TIUTITL)
198 D ^DIE
199 I +$G(^TIU(8925,+TIUDA,0))'=+TIUD0 S TIUCHNG=1
200 S CHKSUM=+$$CHKSUM^TIULC("^TIU(8925,"_+TIUDA_",""TEXT"")")
201 D AUDIT^TIUEDI1(TIUDA,CHKSUM,CHKSUM)
202POST1Q ;clean up, linetag put in with *171
203 L -^TIU(8925,TIUDA,0)
204 K TIUNOCS
205 Q
Note: See TracBrowser for help on using the repository browser.