source: FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUDD0.m@ 1726

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

initial load of FOIAVistA 6/30/08 version
File size: 8.0 KB
Line 
1TIUDD0 ; SLC/JER,AJB - Cross-references on 8925
2 ;;1.0;TEXT INTEGRATION UTILITIES;**65,153**;Jun 20, 1997
3SACLPT(FLD,X) ; SET Logic for ACLPT
4 ;"ACLPT" On .01 CLASS, .02 PT, 1301 INV RDT
5 N TIUD0,TIUD13
6 S TIUD0=$G(^TIU(8925,+DA,0)),TIUD13=$G(^(13))
7 I $S(FLD=.05:1,FLD=1501:1,FLD=1507:1,1:0) D ;P65 add ACLPT to fld .05
8 . I +$P(TIUD0,U),+$P(TIUD13,U),+$P(TIUD0,U,2),($P(TIUD0,U,5)'<6) S ^TIU(8925,"ACLPT",+$$CLINDOC^TIULC1(+$P(TIUD0,U),+DA),+$P(TIUD0,U,2),$$INVDATE($P(TIUD13,U)),DA)=""
9 I FLD=.01 D
10 . I +$P(TIUD13,U),+$P(TIUD0,U,2),($P(TIUD0,U,5)'<6) S ^TIU(8925,"ACLPT",+$$CLINDOC^TIULC1(+X,+DA),+$P(TIUD0,U,2),$$INVDATE($P(TIUD13,U)),DA)=""
11 I FLD=.02 D
12 . I +$P(TIUD0,U),+$P(TIUD13,U),($P(TIUD0,U,5)'<6) S ^TIU(8925,"ACLPT",+$$CLINDOC^TIULC1(+$P(TIUD0,U),+DA),+X,$$INVDATE($P(TIUD13,U)),DA)=""
13 I FLD=1301 D
14 . I +$P(TIUD0,U),+$P(TIUD0,U,2),($P(TIUD0,U,5)'<6) S ^TIU(8925,"ACLPT",+$$CLINDOC^TIULC1(+$P(TIUD0,U),+DA),+$P(TIUD0,U,2),$$INVDATE(+X),DA)=""
15 Q
16 ;
17SACLAU(FLD,X) ; SET Logic for ACLAU
18 ; "ACLAU" X-REF ON .01 CLASS, 1202 AUTHOR, .02 PT, & 1301 INV RDT:
19 N TIUD0,TIUD13,TIUD12,TIUSIGFL
20 S TIUD0=$G(^TIU(8925,+DA,0)),TIUD13=$G(^(13)),TIUD12=$G(^(12))
21 I $P(TIUD0,U,5),+$P(TIUD0,U,5)<6 S TIUSIGFL=1
22 I FLD=.05,$G(TIUSIGFL) D
23 . I +$P(TIUD0,U),+$P(TIUD0,U,2),+$P(TIUD13,U),+$P(TIUD12,U,2) S ^TIU(8925,"ACLAU",+$$CLINDOC^TIULC1(+$P(TIUD0,U),+DA),+$P(TIUD12,U,2),+$P(TIUD0,U,2),$$INVDATE($P(TIUD13,U)),DA)=""
24 I FLD=1501,$G(TIUSIGFL) D
25 . I +$P(TIUD0,U),+$P(TIUD0,U,2),+$P(TIUD13,U),+$P(TIUD12,U,2) S ^TIU(8925,"ACLAU",+$$CLINDOC^TIULC1(+$P(TIUD0,U),+DA),+$P(TIUD12,U,2),+$P(TIUD0,U,2),$$INVDATE($P(TIUD13,U)),DA)=""
26 I FLD=.01,$G(TIUSIGFL) D
27 . I +$P(TIUD0,U,2),+$P(TIUD13,U),+$P(TIUD12,U,2) S ^TIU(8925,"ACLAU",+$$CLINDOC^TIULC1(+X,+DA),+$P(TIUD12,U,2),+$P(TIUD0,U,2),$$INVDATE($P(TIUD13,U)),DA)=""
28 I FLD=1202,$G(TIUSIGFL) D
29 . I +$P(TIUD0,U),+$P(TIUD0,U,2),+$P(TIUD13,U) S ^TIU(8925,"ACLAU",+$$CLINDOC^TIULC1(+$P(TIUD0,U),+DA),+X,+$P(TIUD0,U,2),$$INVDATE($P(TIUD13,U)),DA)=""
30 I FLD=.02,$G(TIUSIGFL) D
31 . I +$P(TIUD0,U),+$P(TIUD13,U),+$P(TIUD12,U,2) S ^TIU(8925,"ACLAU",+$$CLINDOC^TIULC1(+$P(TIUD0,U),+DA),+$P(TIUD12,U,2),+X,$$INVDATE($P(TIUD13,U)),DA)=""
32 I FLD=1301,$G(TIUSIGFL) D
33 . I +$P(TIUD0,U),+$P(TIUD0,U,2),+$P(TIUD12,U,2) S ^TIU(8925,"ACLAU",+$$CLINDOC^TIULC1(+$P(TIUD0,U),+DA),+$P(TIUD12,U,2),+$P(TIUD0,U,2),$$INVDATE(+X),DA)=""
34 Q
35 ;
36SACLAU1(FLD,X) ; SET LOGIC FOR ACLAU - TRANSCRIPTIONIST (ENTERED BY)
37 ; "ACLAU" X-REF ON .01 CLASS, 1302 ENTERED BY, .02 PT, & 1301 INV RDT:
38 N TIUD0,TIUD12,TIUD13,TIUSIGFL
39 S TIUD0=$G(^TIU(8925,+DA,0)),TIUD12=$G(^(12)),TIUD13=$G(^(13))
40 I FLD'=1302,(+$P(TIUD13,U,2)'=0),(+$P(TIUD13,U,2)=+$P(TIUD12,U,2)) Q
41 I FLD=1302,(+X'=0),(+X=+$P(TIUD12,U,2)) Q
42 I $P(TIUD0,U,5),+$P(TIUD0,U,5)<6 S TIUSIGFL=1
43 I FLD=.05,$G(TIUSIGFL) D
44 . I +$P(TIUD0,U),+$P(TIUD0,U,2),+$P(TIUD13,U),+$P(TIUD13,U,2) S ^TIU(8925,"ACLAU",+$$CLINDOC^TIULC1(+$P(TIUD0,U),+DA),+$P(TIUD13,U,2),+$P(TIUD0,U,2),$$INVDATE($P(TIUD13,U)),DA)=""
45 I FLD=1501,$G(TIUSIGFL) D
46 . I +$P(TIUD0,U),+$P(TIUD0,U,2),+$P(TIUD13,U),+$P(TIUD13,U,2) S ^TIU(8925,"ACLAU",+$$CLINDOC^TIULC1(+$P(TIUD0,U),+DA),+$P(TIUD13,U,2),+$P(TIUD0,U,2),$$INVDATE($P(TIUD13,U)),DA)=""
47 I FLD=.01,$G(TIUSIGFL) D
48 . I +$P(TIUD0,U,2),+$P(TIUD13,U),+$P(TIUD13,U,2) S ^TIU(8925,"ACLAU",+$$CLINDOC^TIULC1(+X,+DA),+$P(TIUD13,U,2),+$P(TIUD0,U,2),$$INVDATE($P(TIUD13,U)),DA)=""
49 I FLD=1302,$G(TIUSIGFL) D
50 . I +$P(TIUD0,U),+$P(TIUD0,U,2),+$P(TIUD13,U) S ^TIU(8925,"ACLAU",+$$CLINDOC^TIULC1(+$P(TIUD0,U),+DA),+X,+$P(TIUD0,U,2),$$INVDATE($P(TIUD13,U)),DA)=""
51 I FLD=.02,$G(TIUSIGFL) D
52 . I +$P(TIUD0,U),+$P(TIUD13,U),+$P(TIUD13,U,2) S ^TIU(8925,"ACLAU",+$$CLINDOC^TIULC1(+$P(TIUD0,U),+DA),+$P(TIUD13,U,2),+X,$$INVDATE($P(TIUD13,U)),DA)=""
53 I FLD=1301,$G(TIUSIGFL) D
54 . I +$P(TIUD0,U),+$P(TIUD0,U,2),+$P(TIUD13,U,2) S ^TIU(8925,"ACLAU",+$$CLINDOC^TIULC1(+$P(TIUD0,U),+DA),+$P(TIUD13,U,2),+$P(TIUD0,U,2),$$INVDATE(+X),DA)=""
55 Q
56 ;
57SACLEC(FLD,X) ; SET Logic For ACLEC
58 ; "ACLEC" On .01 CLASS, 1208 EC, .02 PT, 1301 INV RDT:
59 N TIUD0,TIUD13,TIUD12,TIUCOSFL
60 S TIUD0=$G(^TIU(8925,+DA,0)),TIUD13=$G(^(13)),TIUD12=$G(^(12))
61 I $P(TIUD0,U,5),+$P(TIUD0,U,5)<7 S TIUCOSFL=1
62 I $S(FLD=.05:1,FLD=1501:1,FLD=1507:1,1:0),$G(TIUCOSFL) D
63 . I +$P(TIUD0,U),+$P(TIUD0,U,2),+$P(TIUD13,U),+$P(TIUD12,U,8) S ^TIU(8925,"ACLEC",+$$CLINDOC^TIULC1(+$P(TIUD0,U),+DA),+$P(TIUD12,U,8),+$P(TIUD0,U,2),$$INVDATE($P(TIUD13,U)),DA)=""
64 I FLD=.01,$G(TIUCOSFL) D
65 . I +$P(TIUD0,U,2),+$P(TIUD13,U),+$P(TIUD12,U,8) S ^TIU(8925,"ACLEC",+$$CLINDOC^TIULC1(+X,+DA),+$P(TIUD12,U,8),+$P(TIUD0,U,2),$$INVDATE($P(TIUD13,U)),DA)=""
66 I FLD=1208,$G(TIUCOSFL) D
67 . I +$P(TIUD0,U),+$P(TIUD0,U,2),+$P(TIUD13,U) S ^TIU(8925,"ACLEC",+$$CLINDOC^TIULC1(+$P(TIUD0,U),+DA),+X,+$P(TIUD0,U,2),$$INVDATE($P(TIUD13,U)),DA)=""
68 I FLD=.02,$G(TIUCOSFL) D
69 . I +$P(TIUD0,U),+$P(TIUD13,U),+$P(TIUD12,U,8) S ^TIU(8925,"ACLEC",+$$CLINDOC^TIULC1(+$P(TIUD0,U),+DA),+$P(TIUD12,U,8),+X,$$INVDATE($P(TIUD13,U)),DA)=""
70 I FLD=1301,$G(TIUCOSFL) D
71 . I +$P(TIUD0,U),+$P(TIUD0,U,2),+$P(TIUD12,U,8) S ^TIU(8925,"ACLEC",+$$CLINDOC^TIULC1(+$P(TIUD0,U),+DA),+$P(TIUD12,U,8),+$P(TIUD0,U,2),$$INVDATE(+X),DA)=""
72 Q
73 ;
74SACLSB(FLD,X) ; SET Logic for ACLSB
75 ;"ACLSB" X-REF ON .01 CLASS, 1502 SIGNER, .02 PT, 1301 RDT:
76 N TIUD0,TIUD13,TIUD15
77 S TIUD0=$G(^TIU(8925,+DA,0)),TIUD13=$G(^(13)),TIUD15=$G(^(15))
78 I FLD=.01 D
79 . I +$P(TIUD0,U,2),+$P(TIUD13,U),+$P(TIUD15,U,2) S ^TIU(8925,"ACLSB",+$$CLINDOC^TIULC1(+X,+DA),+$P(TIUD15,U,2),+$P(TIUD0,U,2),$$INVDATE($P(TIUD13,U)),DA)=""
80 I FLD=1502 D
81 . I +$P(TIUD0,U),+$P(TIUD0,U,2),+$P(TIUD13,U) S ^TIU(8925,"ACLSB",+$$CLINDOC^TIULC1(+$P(TIUD0,U),+DA),+X,+$P(TIUD0,U,2),$$INVDATE($P(TIUD13,U)),DA)=""
82 I FLD=.02 D
83 . I +$P(TIUD0,U),+$P(TIUD13,U),+$P(TIUD15,U,2) S ^TIU(8925,"ACLSB",+$$CLINDOC^TIULC1(+$P(TIUD0,U),+DA),+$P(TIUD15,U,2),+X,$$INVDATE($P(TIUD13,U)),DA)=""
84 I FLD=1301 D
85 . I +$P(TIUD0,U),+$P(TIUD0,U,2),+$P(TIUD15,U,2) S ^TIU(8925,"ACLSB",+$$CLINDOC^TIULC1(+$P(TIUD0,U),+DA),+$P(TIUD15,U,2),+$P(TIUD0,U,2),$$INVDATE(+X),DA)=""
86 Q
87 ;
88SAPTLD(FLD,X) ; SET Logic for "APTLD"
89 ; APTLD on fields .02 PT, .01 TITLE, "1211;.07;.13" VSTR, .03 VISIT
90 N TIUD0,TIUD12
91 S TIUD0=$G(^TIU(8925,+DA,0)),TIUD12=$G(^(12))
92 I FLD=.02 D
93 . I +TIUD0,+$P(TIUD0,U,7),$L($P(TIUD0,U,13)),+$P(TIUD12,U,11) D
94 . . N TIUVS
95 . . ; TIUVS="Hosp Loc;Visit/Adm Date/time;Visit Type"
96 . . S TIUVS=$P(TIUD12,U,11)_";"_$P(TIUD0,U,7)_";"_$P(TIUD0,U,13)
97 . . S ^TIU(8925,"APTLD",+X,+TIUD0,TIUVS,DA)=""
98 . . I +$P(TIUD0,U,3) S ^TIU(8925,"AVSTRV",+X,TIUVS,+$P(TIUD0,U,3),DA)=""
99 I FLD=.01 D
100 . I +$P(TIUD0,U,2),+$P(TIUD0,U,7),$L($P(TIUD0,U,13)),+$P(TIUD12,U,11) D
101 . . N TIUVS
102 . . ; TIUVS="Hosp Loc;Visit/Adm Date/time;Visit Type"
103 . . S TIUVS=$P(TIUD12,U,11)_";"_$P(TIUD0,U,7)_";"_$P(TIUD0,U,13)
104 . . S ^TIU(8925,"APTLD",+$P(TIUD0,U,2),+X,TIUVS,DA)=""
105 I FLD=1211 D
106 . I +TIUD0,+$P(TIUD0,U,2),+$P(TIUD0,U,7),$L($P(TIUD0,U,13)) D
107 . . N TIUVS
108 . . ; TIUVS="Hosp Loc;Visit/Adm Date/time;Visit Type"
109 . . S TIUVS=+X_";"_$P(TIUD0,U,7)_";"_$P(TIUD0,U,13)
110 . . S ^TIU(8925,"APTLD",+$P(TIUD0,U,2),+TIUD0,TIUVS,DA)=""
111 . . I +$P(TIUD0,U,3) S ^TIU(8925,"AVSTRV",+$P(TIUD0,U,2),TIUVS,+$P(TIUD0,U,3),DA)=""
112 I FLD=.07 D
113 . I +TIUD0,+$P(TIUD0,U,2),$L($P(TIUD0,U,13)),+$P(TIUD12,U,11) D
114 . . N TIUVS
115 . . ; TIUVS="Hosp Loc;Visit/Adm Date/time;Visit Type"
116 . . S TIUVS=$P(TIUD12,U,11)_";"_+X_";"_$P(TIUD0,U,13)
117 . . S ^TIU(8925,"APTLD",+$P(TIUD0,U,2),+TIUD0,TIUVS,DA)=""
118 . . I +$P(TIUD0,U,3) S ^TIU(8925,"AVSTRV",+$P(TIUD0,U,2),TIUVS,+$P(TIUD0,U,3),DA)=""
119 I FLD=.13 D
120 . I +TIUD0,+$P(TIUD0,U,2),+$P(TIUD0,U,7),+$P(TIUD12,U,11) D
121 . . N TIUVS
122 . . ; TIUVS="Hosp Loc;Visit/Adm Date/time;Visit Type"
123 . . S TIUVS=$P(TIUD12,U,11)_";"_$P(TIUD0,U,7)_";"_X
124 . . S ^TIU(8925,"APTLD",+$P(TIUD0,U,2),+TIUD0,TIUVS,DA)=""
125 . . I +$P(TIUD0,U,3) S ^TIU(8925,"AVSTRV",+$P(TIUD0,U,2),TIUVS,+$P(TIUD0,U,3),DA)=""
126 ; SET V-String/Visit Map if Visit record exists
127 I FLD=.03 D
128 . I +$P(TIUD0,U,2),+$P(TIUD0,U,7),$L($P(TIUD0,U,13)),+$P(TIUD12,U,11) D
129 . . N TIUVS
130 . . ; TIUVS="Hosp Loc;Visit/Adm Date/time;Visit Type"
131 . . S TIUVS=$P(TIUD12,U,11)_";"_$P(TIUD0,U,7)_";"_$P(TIUD0,U,13)
132 . . S ^TIU(8925,"AVSTRV",+$P(TIUD0,U,2),TIUVS,+X,DA)=""
133 Q
134 ;
135INVDATE(DATE) ; Inverts date
136 Q 9999999-DATE
Note: See TracBrowser for help on using the repository browser.