source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULX.m@ 613

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

initial load of WorldVistAEHR
File size: 7.4 KB
Line 
1TIULX ; SLC/JER - Cross-reference library functions ;6/21/06
2 ;;1.0;TEXT INTEGRATION UTILITIES;**1,28,79,100,136,219**;Jun 20, 1997;Build 11
3 ; File 200 - IA 10060
4 ; ^ORD(101 - IA 872
5 ; ^DISV - IA 510
6ALOCP(DA) ; Should record be included in daily print queue by location?
7 ; Receives DA = record # in 8925
8 Q +$$ISPN(+$G(^TIU(8925,+DA,0)))
9APTP(DA) ; Should record be included in daily print queue by patient?
10 ; Receives DA = record # in 8925
11 Q +$$ISPN(+$G(^TIU(8925,+DA,0)))
12AAUP(DA) ; Should record be included in daily print queue by author?
13 ; Receives DA = record # in 8925
14 Q +$$ISPN(+$G(^TIU(8925,+DA,0)))
15BELONGS(TIUDA,CLASS) ; Evaluate whether a given document belongs to a
16 ; particular document class
17 N TIUY
18 I +$$ISADDNDM^TIULC1(TIUDA) S TIUDA=+$P($G(^TIU(8925,+TIUDA,0)),U,6)
19 S TIUY=+$$ISA(+$G(^TIU(8925,+TIUDA,0)),CLASS)
20 Q TIUY
21ISA(DA,CLASS) ; Evaluate whether a given document type is a member of a
22 ; particular document class
23 ; Receives DA = record # in 8925.1, and
24 ; CLASS = record # of class in 8925.1
25 N TIUI,TIUY S (TIUI,TIUY)=0
26 F S TIUI=$O(^TIU(8925.1,"AD",DA,TIUI)) Q:+TIUI'>0!(TIUY=1) D
27 . I TIUI=CLASS S TIUY=1 Q
28 . S TIUY=$$ISA(TIUI,CLASS)
29 Q TIUY
30ISPN(DA) ; Evaluate whether a given document is a Progress Note
31 ; Receives DA = record # in 8925.1
32 N TIUI,TIUY S (TIUI,TIUY)=0
33 F S TIUI=$O(^TIU(8925.1,"AD",DA,TIUI)) Q:+TIUI'>0!(TIUY=1) D
34 . I TIUI=3 S TIUY=1 Q
35 . S TIUY=$$ISPN(TIUI)
36 Q TIUY
37ISCWAD(DA) ; Evaluate whether a given title is a CWAD
38 ;Is the given title in a CWAD document class?
39 ;New for ID notes
40 ; Receives DA = record # in 8925.1
41 Q $S($$ISA(DA,25):1,$$ISA(DA,27):1,$$ISA(DA,30):1,$$ISA(DA,31):1,1:0)
42ISDS(DA) ; Evaluate whether a given document is a Discharge Summary
43 ; Receives DA = record # in 8925.1
44 N TIUI,TIUY S (TIUI,TIUY)=0
45 F S TIUI=$O(^TIU(8925.1,"AD",DA,TIUI)) Q:+TIUI'>0!(TIUY=1) D
46 . I TIUI=244 S TIUY=1 Q
47 . S TIUY=$$ISDS(TIUI)
48 Q TIUY
49TRNSFRM(RTYPE,FLD,X) ; Executes Transform code for a given header field
50 N XFORM
51 S FLD=$O(^TIU(8925.1,+RTYPE("TYPE"),"HEAD","D",+FLD,0))
52 I +FLD'>0 G TRNSFRMX
53 S XFORM=$G(^TIU(8925.1,+RTYPE("TYPE"),"HEAD",+FLD,1))
54 I XFORM']"" G TRNSFRMX
55 X XFORM
56TRNSFRMX Q X
57MENUS ; Evaluate/enforce user's menu display preference
58 N TIUI,TIUPREF S TIUPREF=$$PERSPRF^TIULE(DUZ),TIUI=0
59 F S TIUI=$O(^DISV(DUZ,"VALMMENU",TIUI)) Q:+TIUI'>0 D
60 . I $P($G(^ORD(101,+TIUI,0)),U)["TIU" S ^DISV(DUZ,"VALMMENU",TIUI)=$S($P(TIUPREF,U,5)=0:0,1:1)
61 Q
62XTRASIGN(TIUY,TIUDA) ; Get list of extra signers for a document
63 N TIUI,TIUJ,TIUL,DA,DR,DIC,DIQ,TIUXTRA S (TIUI,TIUJ,TIUL)=0
64 S DIC="^TIU(8925.7,",DIQ="TIUXTRA"
65 F S TIUI=$O(^TIU(8925.7,"B",TIUDA,TIUI)) Q:+TIUI'>0 D
66 . N TIUX,TIUSGNR
67 . S DA=TIUI,DR=".03;.04" D EN^DIQ1 Q:+$D(TIUXTRA)'>9
68 . I $L($G(TIUXTRA(8925.7,DA,.04))) Q
69 . S TIUJ=+$G(TIUJ)+1,TIUL=+$G(TIUL)+1
70 . S TIUSGNR=$G(TIUXTRA(8925.7,DA,.03))
71 . S TIUX=$$SETSTR^VALM1($G(TIUJ)_") "_TIUSGNR,$G(TIUX),1,39)
72 . S TIUY(TIUL)=DA_U_TIUX
73 Q
74ASKSIGN(TIUY) ; Identify which Signature to edit
75 N I,L,Y
76 W !!,"Please Indicate Which Expected Signer to Change:",!
77 S (I,L,Y)=0 F S I=$O(TIUY(I)) Q:+I'>0!+Y D
78 . W:$P(TIUY(I),U)]"" !,$P(TIUY(I),U,2)
79 . I I#20=0 S Y=$P($$PICK(1,I,"Select Signer","NO"),U)
80 . S L=I
81 I L#20,'+Y S Y=$P($$PICK(1,L,"Select Signer","NO"),U)
82 I +Y,+$G(TIUY(+Y)) S Y=+$G(TIUY(+Y))
83 Q Y
84PICK(LOW,HIGH,PROMPT,TYPE) ; List selection
85 N X,Y S PROMPT=$G(PROMPT,"Select Item"),TYPE=$G(TYPE,"LO")
86 W !
87 S Y=$$READ^TIUU(TYPE_U_LOW_":"_HIGH,PROMPT)
88 W !
89 Q Y
90CWAD ; Entry action for CWAD protocol
91 N GMRPALG,GMRPCWAD,GMRPDFN,GMRPOPT,GMRPEN,GMRPAGE,GMRPCWAD,GMRPDOB
92 N GMRPLOC,GMRPRB,GMRPSSN,GMRPQT
93 I $G(TIUGLINK) W !,"Please finish attaching the interdisciplinay note before displaying alerts.",! H 3 Q
94 D FULL^VALM1
95 I '+$G(DFN),'+$G(ORVP) D Q
96 . W !!,"No Patient Selected...",!
97 . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause
98 . S VALMBCK="R"
99 D PAT^GMRPNOR1 I $D(GMRPQT) S VALMBCK="R" Q
100 S Y=GMRPDFN,GMRPOPT=1,GMRPEN=1 W !!,"** Current Patient: "_$P(Y,U,2)
101 D ENPAT^GMRPNCW S VALMBCK="R"
102 Q
103IDSIGNRS(TIUY,TIUDA,TIULIST) ; Add list of Add'l Signers for a TIU Document
104 ; TIULIST(TIUI) [By Ref] = array of users to add/remove as signers
105 ; TIUDA = IEN in ^TIU(8925,
106 N TIUI S TIUI=0
107 F S TIUI=$O(TIULIST(TIUI)) Q:+TIUI'>0 D
108 . N DA,DIC,DLAYGO,DIE,DR,X,Y
109 . ; if current user is already an additional signer, and current user
110 . ; is NOT being removed as an additional signer, then QUIT
111 . I +$O(^TIU(8925.7,"AE",TIUDA,+TIULIST(TIUI),0)),($P(TIULIST(TIUI),U,3)'="REMOVE") Q
112 . ; if current user is being removed as a cosigner, then remove him
113 . I $P(TIULIST(TIUI),U,3)="REMOVE" D REMSIGNR(TIUDA,+TIULIST(TIUI)) Q
114 . ; otherwise, add the current user as an additional signer
115 . S X=""""_"`"_TIUDA_"""",(DIC,DLAYGO)=8925.7,DIC(0)="LX" D ^DIC Q:+Y'>0
116 . S DIE=DIC,TIUY=$G(TIUY)_$S($G(TIUY)]"":U,1:"")_+TIULIST(TIUI)
117 . S DR=".02////"_0_";.03////"_+$G(TIULIST(TIUI))
118 . D ^DIE
119 . D SEND^TIUALRT(TIUDA)
120 Q
121REMSIGNR(TIUDA,TIUDUZ) ; Remove user from additional signer list
122 N DA,DIE,DR,DIDEL
123 S DA=+$O(^TIU(8925.7,"AE",TIUDA,TIUDUZ,0)) Q:+DA'>0
124 S (DIDEL,DIE)=8925.7,DR=".01///@" D ^DIE
125 D SEND^TIUALRT(TIUDA)
126 Q
127GETSIGNR(TIUY,TIUDA) ; RPC to Get list of extra signers for a document
128 N TIUI,DA,DR,DIC,DIQ,TIUXTRA,TIUD12,TIUAU,TIUEC S (DA,TIUI)=0
129 S DIC="^TIU(8925.7,",DIQ="TIUXTRA"
130 F S DA=$O(^TIU(8925.7,"B",TIUDA,DA)) Q:+DA'>0 D
131 . N TIUX,TIUSGNR
132 . S DR=".03;.04",DIQ(0)="IE" D EN^DIQ1 Q:+$D(TIUXTRA)'>9
133 . I +$G(TIUXTRA(8925.7,DA,.04,"I")) Q
134 . S TIUI=+$G(TIUI)+1
135 . S TIUY(TIUI)=$G(TIUXTRA(8925.7,DA,.03,"I"))_U_$G(TIUXTRA(8925.7,DA,.03,"E"))
136 S TIUD12=$G(^TIU(8925,TIUDA,12))
137 S TIUAU=$P(TIUD12,U,4),TIUEC=$P(TIUD12,U,8)
138 S TIUI=+$G(TIUI)+1,TIUY(TIUI)=TIUAU_U_$$PERSNAME^TIULC1(TIUAU)_U_"AUTHOR"
139 I +TIUEC'>0 Q
140 I '$$FIND1^DIC(200,"","","`"_+TIUEC) D CLEAN^DILF Q
141 S TIUI=+$G(TIUI)+1,TIUY(TIUI)=TIUEC_U_$$PERSNAME^TIULC1(TIUEC)_U_"EXPECTED COSIGNER"
142 Q
143HASDS(DFN,VSTR) ; Does an admission have a Discharge Summary?
144 N TITLE,TIUDA S (TIUDA,TITLE)=0
145 F S TITLE=$O(^TIU(8925,"APTLD",DFN,TITLE)) Q:+TITLE'>0 D Q:+TIUDA>0
146 . N STATUS,CONTEXT S TIUDA=0
147 . I '+$$ISDS(TITLE) S TIUDA=0_U_0 Q
148 . F S TIUDA=$O(^TIU(8925,"APTLD",DFN,TITLE,VSTR,+TIUDA)) Q:+TIUDA'>0 D Q:+$P(TIUDA,U,2)
149 . . S STATUS=+$P($G(^TIU(8925,+TIUDA,0)),U,5)
150 . . S CONTEXT=$S(STATUS=0:0,STATUS>13:0,STATUS'>5:2,1:1)
151 . . S TIUDA=TIUDA_U_CONTEXT
152 I '+TIUDA,($L(TIUDA,U)<2) S TIUDA=TIUDA_U_0
153 Q TIUDA
154NEEDSIG(TIUY,USER,CLASS) ; Get list of documents for which USER is an additional signer
155 N TIUDA,TIUI,TIUJ S (TIUDA,TIUJ)=0
156 S USER=$G(USER,DUZ),CLASS=$G(CLASS,38),TIUY=$NA(^TMP("TIUSIGN",$J))
157 K @TIUY ; Clear out return array before query
158 F S TIUDA=$O(^TIU(8925.7,"AES",USER,TIUDA)) Q:+TIUDA'>0 D
159 . S TIUI=0 F S TIUI=$O(^TIU(8925.7,"AES",USER,TIUDA,TIUI)) Q:+TIUI'>0 D
160 . . N TIUD0 S TIUD0=$G(^TIU(8925.7,TIUI,0)) Q:+$P(TIUD0,U,4)
161 . . Q:'+$$ISA(+$G(^TIU(8925,TIUDA,0)),CLASS)
162 . . S TIUJ=+$G(TIUJ)+1,@TIUY@(TIUJ)=TIUDA
163 Q
164TITLIENS ; Get IENs of DDEF entries that have type Title
165 ; in Document Definition file 8925.1
166 ;Creates array ^TMP("TIUTLS,$J,TLIEN)=
167 ;Caller must kill ^TMP("TIUTLS",$J) when finished with the global.
168 N TIUIDX S TIUIDX=0 K ^TMP("TIUTLS",$J)
169 F S TIUIDX=$O(^TIU(8925.1,"AT","DOC",TIUIDX)) Q:TIUIDX'>0 D
170 . S ^TMP("TIUTLS",$J,TIUIDX)=""
171 Q
172HASDOCMT(DFN) ;Does patient have ANY entries in TIU DOCUMENT file 8925?
173 ;Any entries includes original documents, addenda, components
174 ;(like S in SOAP notes), "deleted" documents, retracted documents, etc!
175 Q $O(^TIU(8925,"C",+$G(DFN),0))>0
176
Note: See TracBrowser for help on using the repository browser.