source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUSRVP1.m@ 619

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

initial load of WorldVistAEHR
File size: 6.9 KB
Line 
1TIUSRVP1 ; SLC/JER - More API's in support of PUT ;8/14/07
2 ;;1.0;TEXT INTEGRATION UTILITIES;**19,59,89,100,109,167,113,112,219**;Jun 20, 1997;Build 11
3SITEPARM(TIUY) ; Get site parameters for GUI
4 N TIUPRM0,TIUPRM1
5 D SETPARM^TIULE
6 S TIUY=TIUPRM0
7 Q
8DEFDOC(TIUY,HLOC,USER,TIUDT,TIUIEN) ; Get default primary provider
9 N TIUSPRM,TIUDDOC,TIUAUTH
10 D SITEPARM(.TIUSPRM)
11 S TIUDDOC=+$P(TIUSPRM,U,8)
12 S TIUAUTH=$S((+$G(USER)!('+$G(TIUIEN))):0,1:+$P($G(^TIU(8925,+$G(TIUIEN),12)),U,2))
13 S USER=$S(+$G(USER):+$G(USER),+$G(TIUAUTH):+$G(TIUAUTH),1:DUZ)
14 S TIUDT=$S(+$G(TIUDT):+$G(TIUDT),1:DT)
15 S TIUY=$S(TIUDDOC=1:$$DFLTDOC^TIUPXAPI(HLOC),TIUDDOC=2:$$CURDOC(USER),1:"0^")
16 Q
17CURDOC(USER,TIUDT) ; Is the current user a known Provider?
18 N TIUY,TIUPROV S TIUY="0^"
19 S USER=$S(+$G(USER):+$G(USER),1:DUZ)
20 S TIUDT=$S(+$G(TIUDT):+$G(TIUDT),1:DT)
21 S TIUPROV=$$PROVIDER^TIUPXAP1(USER,TIUDT)
22 I +TIUPROV S TIUY=USER_U_$$PERSNAME^TIULC1(USER)
23 Q TIUY
24ISAPROV(TIUY,USER,DATE) ; Is user a provider?
25 ; Checks USR CLASS PROVIDER AND 200 Person Class
26 ; DATE must not include time (for ISA^USRLM)
27 S USER=$G(USER,DUZ)
28 S DATE=$G(DATE,DT)
29 S TIUY=$$PROVIDER^TIUPXAP1(USER,DATE)
30 Q
31USRPROV(TIUY,USER,DATE) ; Is USER a USR CLASS provider?
32 ; Checks USR CLASS PROVIDER only
33 ; DATE must not include time
34 N TIUERR
35 S USER=$G(USER,DUZ)
36 S DATE=$G(DATE,DT),TIUY=0
37 I +$$ISA^USRLM(USER,"PROVIDER",.TIUERR,DATE) S TIUY=1 ; DBIA/ICR 2324
38 Q
39DOCPARM(TIUY,TIUDA,TIUTYP) ; Get document parameters for GUI
40 I '+$G(TIUTYP),+$G(TIUDA) S TIUTYP=+$G(^TIU(8925,+TIUDA,0))
41 I '+$G(TIUTYP) S TIUY(0)="" Q
42 D DOCPRM^TIULC1(TIUTYP,.TIUY,$G(TIUDA))
43 I '$D(TIUY) S TIUY(0)=""
44 Q
45CONSTUB(TIUDA,GMRCVP,DFN) ; Create a stub for a Consult Report
46 N DIE,DR,DA
47 D STUB(.TIUDA,"CONSULT REPORT",DFN)
48 I +TIUDA'>0 Q
49 S DIE=8925,DA=+TIUDA,DR="1405////^S X=GMRCVP"
50 D ^DIE
51 Q
52STUB(TIUDA,TIUTITL,DFN) ; Create a stub
53 N TIUVSIT,TIUFPRIV,DIC,DIE,DR,DA,DLAYGO,X,Y S TIUFPRIV=1
54 I +$G(TIUTITL)'>0 S TIUTITL=$$WHATITLE^TIUPUTU(TIUTITL)
55 I +TIUTITL'>0 S TIUDA=-1 Q
56 S (DIC,DLAYGO)=8925,DIC(0)="LF"
57 S X=""""_"`"_+TIUTITL_""""
58 D ^DIC S TIUDA=+Y Q:+Y'>0
59 D EVENT(.TIU,DFN) I $L($G(TIU("VSTR")))'>0 S TIUDA=-1 Q
60 S DIE=DIC,DA=TIUDA
61 S DR=".02////"_+DFN_";.03////"_$P($G(TIU("VISIT")),U)_";.04////"_+$$DOCCLASS^TIULC1(TIUTITL)_";.05///UNDICTATED;.13////E;1301////"_+$$NOW^XLFDT
62 D ^DIE
63 Q
64EVENT(TIUY,DFN) ; Create an Event-type Visit Entry
65 N VDT,VSTR,DGPM
66 S DGPM=$G(^DPT(DFN,.105)) ;DBIA/ICR 10035
67 I +DGPM'>0 D
68 . S VDT=$$NOW^XLFDT
69 . S VSTR=";"_VDT_";"_"E"
70 D PATVADPT^TIULV(.TIUY,+DFN,DGPM,$G(VSTR))
71 I $G(TIUY("LOC"))="",+DUZ D
72 .N TIUPREF,IDX
73 .S TIUPREF=$$PERSPRF^TIULE(DUZ)
74 .S IDX=+$P(TIUPREF,U,2)
75 .I IDX S TIUY("LOC")=IDX_U_$P($G(^SC(IDX,0)),U,1) ; DBIA/ICR 10040
76 Q
77GETPNAME(TIUY,TIUTYPE) ; Get Print Name of a Document
78 S TIUY=$$PNAME^TIULC1(TIUTYPE)
79 Q
80SAVED(TIUY,TIUDA) ; Was the document committed to the database?
81 N TIUD12,TIUD13,TIUEBY,TIUAUT,TIUECS S TIUY=1
82 S TIUD12=$G(^TIU(8925,TIUDA,12)),TIUD13=$G(^(13))
83 S TIUEBY=$P(TIUD13,U,2),TIUAUT=$P(TIUD12,U,2),TIUECS=$P(TIUD12,U,8)
84 I $D(^TIU(8925,"ASAVE",+DUZ,TIUDA)) D Q
85 . S TIUY="0^You appear to have been disconnected..."
86 I DUZ'=TIUEBY,(TIUEBY'=TIUAUT),$D(^TIU(8925,"ASAVE",+TIUEBY,TIUDA)) D Q
87 . S TIUY="0^The transcriber appears to have been disconnected..."
88 I DUZ'=TIUAUT,$D(^TIU(8925,"ASAVE",+TIUAUT,TIUDA)) D Q
89 . S TIUY="0^The author appears to have been disconnected..."
90 I DUZ'=TIUECS,$D(^TIU(8925,"ASAVE",+TIUECS,TIUDA)) D Q
91 . S TIUY="0^The expected cosigner appears to have been disconnected..."
92 Q
93STUFREC(TIUDA,TIUREC,DFN,PARENT,TITLE,TIU) ; load TIUREC for create
94 N TIUREQCS,TIUSCAT,TIUSTAT,TIUCPF
95 ;Set a flag to indicate whether or not a Title is a member of the
96 ;Clinical Procedures Class (1=Yes and 0=No)
97 S TIUCPF=+$$ISA^TIULX(TITLE,+$$CLASS^TIUCP)
98 S TIUSTAT=$$STATUS(TIUDA,+$G(SUPPRESS),$G(TITLE))
99 D REQCOS^TIUSRVA(.TIUREQCS,+TITLE,"",$S(+$G(TIUREC(1202)):+$G(TIUREC(1202)),1:DUZ))
100 I +$G(PARENT)'>0 D
101 . S TIUREC(.02)=$G(DFN),TIUREC(.03)=$P($G(TIU("VISIT")),U)
102 . S TIUREC(.05)=$S(+$G(TIUREC(.05)):+$G(TIUREC(.05)),+TIUSTAT:TIUSTAT,1:5)
103 . S TIUREC(.07)=$P($G(TIU("EDT")),U),TIUREC(.08)=$P($G(TIU("LDT")),U)
104 . S TIUREC(1401)=$P($G(TIU("AD#")),U)
105 . S TIUREC(1402)=$P($G(TIU("TS")),U)
106 . S TIUREC(1404)=$P($G(TIU("SVC")),U)
107 I +$G(PARENT)>0 D
108 . S TIUREC(.02)=+$P($G(^TIU(8925,+PARENT,0)),U,2)
109 . S TIUREC(.03)=+$P($G(^TIU(8925,+PARENT,0)),U,3)
110 . S TIUREC(.05)=$S(+$G(TIUREC(.05)):+$G(TIUREC(.05)),+TIUSTAT:TIUSTAT,1:5)
111 . S TIUREC(.06)=PARENT,TIUREC(.07)=$P(TIU("EDT"),U)
112 . S TIUREC(.08)=$P(TIU("LDT"),U)
113 . S TIUREC(1401)=$P($G(^TIU(8925,+PARENT,14)),U)
114 . S TIUREC(1402)=$P($G(^TIU(8925,+PARENT,14)),U,2)
115 . S TIUREC(1404)=$P($G(^TIU(8925,+PARENT,14)),U,4)
116 . S TIUREC(1405)=$P($G(^TIU(8925,+PARENT,14)),U,5)
117 S TIUREC(.04)=$$DOCCLASS^TIULC1(TITLE)
118 S TIUSCAT=$S(+$L($P($G(TIU("CAT")),U)):$P($G(TIU("CAT")),U),+$L($P($G(TIU("VSTR")),";",3)):$P($G(TIU("VSTR")),";",3),1:"")
119 S TIUREC(.13)=TIUSCAT
120 ;If the document is a member of the Clinical Procedures Class, set the
121 ;Author/Dictator and the Expected Signer fields to Null
122 S (TIUREC(1202),TIUREC(1204))=$S(+$G(TIUREC(1202)):+$G(TIUREC(1202)),TIUCPF:"",1:+$G(DUZ))
123 S TIUREC(1212)=$P($G(TIU("INST")),U)
124 S TIUREC(1205)=$P($G(TIU("LOC")),U)
125 S TIUREC(1211)=$P($G(TIU("VLOC")),U)
126 S TIUREC(1201)=$$NOW^XLFDT
127 S TIUREC(1301)=$S($G(TIUREC(1301))]"":$P(TIUREC(1301),U),1:$$NOW^XLFDT)
128 I +$$ISDS^TIULX(TITLE) D
129 . I +$G(TIU("LDT"))'>0 S TIUREC(.12)=1
130 . S TIUREC(.13)="H"
131 . D REFDT(.TIUREC)
132 ;If the document is a member of the Clinical Procedures Class, set the
133 ;Entered By field to Null
134 S TIUREC(1303)="R",TIUREC(1302)=$S(TIUCPF:"",1:$G(DUZ))
135 I $S(+$G(TIUREC(1208))&(+$G(TIUREC(1204))'=+$G(TIUREC(1208))):1,+$G(TIUREQCS):1,1:0) S TIUREC(1506)=1
136 Q
137REFDT(TIUX) ; Hack Ref Date/time for DS's
138 S TIUX(1301)=$S(+$G(TIU("LDT")):+$G(TIU("LDT")),1:$G(TIUX(1301)))
139 Q
140STATUS(TIUDA,SUPPRESS,TITLE) ; Compute the status of the current record
141 N TIUDPRM,TIUY
142 ; If the document is an addendum, compute status based on processing
143 ; requirements of the Parent document or its ancestors
144 I +$$ISADDNDM^TIULC1(TIUDA) D
145 . S TIUDA=$S(+$P(^TIU(8925,TIUDA,0),U,6):$P(^(0),U,6),1:TIUDA)
146 . S TITLE=+$G(^TIU(8925,TIUDA,0))
147 D DOCPRM^TIULC1(TITLE,.TIUDPRM,$G(TIUDA))
148 I +$P(TIUDPRM(0),U,2),+$G(SUPPRESS) S TIUY=3 G STATUX
149 S TIUY=$S(+$$REQVER^TIULC(+TIUDA,+$P($G(TIUDPRM(0)),U,3)):4,1:5)
150STATUX Q TIUY
151IDATTCH(TIUY,TIUDA,TIUDAD) ; Attach TIUDA as ID Child entry to TIUDAD
152 N TIUX
153 S TIUX(2101)=TIUDAD
154 D FILE^TIUSRVP(.TIUY,TIUDA,.TIUX,1)
155 D AUDLINK^TIUGR1(TIUDA,"a",TIUDAD)
156 D SENDID^TIUALRT1(TIUDA)
157 Q
158IDDTCH(TIUY,TIUDA) ; Detach TIUDA from its ID Parent
159 N TIUX,IDDAD
160 I '+$G(^TIU(8925,TIUDA,21)) D Q
161 . S TIUY="0^Record #"_TIUDA_" is NOT an ID Entry."
162 S IDDAD=+$G(^TIU(8925,TIUDA,21))
163 S TIUX(2101)="@"
164 D FILE^TIUSRVP(.TIUY,TIUDA,.TIUX,1)
165 D AUDLINK^TIUGR1(TIUDA,"d",IDDAD)
166 D IDDEL^TIUALRT1(TIUDA)
167 Q
168CANDEL(TIUDA) ; Boolean function to evaluate delete request
169 Q $S($P(^TIU(8925,TIUDA,0),U,5)>3:0,'+$$EMPTYDOC^TIULF(TIUDA):0,1:1)
Note: See TracBrowser for help on using the repository browser.