source: FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDRPCU.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 6.8 KB
Line 
1MDRPCU ; HOIFO/DP - Object RPC Utilities ; [05-23-2003 10:16]
2 ;;1.0;CLINICAL PROCEDURES;**4**;Apr 01, 2004;Build 3
3 ; Integration Agreements:
4 ; IA# 10039 [Supported] Ward Location File #42
5 ; IA# 10035 [Supported] Access to DPT global
6 ; IA# 10040 [Supported] Access to SC global
7 ; IA# 1246 [Supported] Call to DGPMDDCF
8 ; IA# 3266 [Subscription] $$DOB call to DPTLK1
9 ; IA# 3267 [Subscription] Call to $$SSN of DPTLK1
10 ; IA# 2692 [Subscription] Calls to ORQPTQ1
11 ; IA# 3869 [Subscription] SDAMA202 calls
12 ;
13BADRPC(RPC,RTN,OPTION) ; [Procedure] When and RPC gets lost
14 ; Input parameters
15 ; 1. RPC [Literal/Required] No description
16 ; 2. RTN [Literal/Required] No description
17 ; 3. OPTION [Literal/Required] No description
18 ;
19 S @RESULTS@(0)="-1^Error calling RPC: "_RPC_" at "_OPTION_U_RTN
20 Q
21 ;
22DUPS(MDD,MDIEN,MDX) ; [Function] Return boolean if dups exist
23 N MDGBL
24 S MDGBL=$$GET1^DID(+MDD,"","","GLOBAL NAME")
25 S X=MDX X ^%ZOSF("UPPERCASE") S MDX=Y
26 S Y=$O(@(MDGBL_"""UC"",MDX,"""")")) Q:Y&(Y'=MDIEN) 1
27 S Y=$O(@(MDGBL_"""UC"",MDX,"""")"),-1) Q:Y&(Y'=MDIEN) 1
28 Q 0
29 ;
30LOCK(RESULTS,DD,IENS) ; [Procedure] Lock a record
31 L @("+"_$$ROOT^DILFD(DD,IENS)_(+IENS)_")"_":2")
32 I $T S @RESULTS@(0)="1^Lock acquired"
33 E S @RESULTS@(0)="-1^Lock *NOT* acquired"
34 Q
35 ;
36UNLOCK(RESULTS,DD,IENS) ; [Procedure] Unlock a record
37 L @("-"_$$ROOT^DILFD(DD,IENS)_(+IENS)_")")
38 S @RESULTS@(0)="1^Lock released"
39 Q
40 ;
41CLINICPT ; [Procedure] Return patients by clinic/appt dt
42 N MD,MDRET
43 S MDDT=P2\1,MDEND=MDDT+.24
44 D GETPLIST^SDAMA202(P1,"1;4;","R",MDDT,MDEND,.MDRET,"")
45 I MDRET<0 S @RESULTS@(0)="0^No patients for this clinic/appt date." Q
46 F MD=0:0 S MD=$O(^TMP($J,"SDAMA202","GETPLIST",MD)) Q:'MD D
47 .; Naked ref from above
48 .S Y=+$G(^(MD,4)) Q:'Y S @RESULTS@(Y)=$$GUIPT(Y)
49 I '$D(@RESULTS) S @RESULTS@(0)="0^No patients for this clinic/appointment date."
50 E S @RESULTS@(0)=$D(@RESULTS)
51 Q
52 ;
53CLINICS ; [Procedure]
54 F X=0:0 S X=$O(^SC(X)) Q:'X D:$P(^(X,0),U,3)="C"
55 .Q:+$G(^SC(X,"OOS"))
56 .S Y=$G(^SC(X,"I"))
57 .I Y Q:DT>+Y&($P(Y,U,2)=""!(DT<$P(Y,U,2)))
58 .S @RESULTS@($O(@RESULTS@(""),-1)+1)="44;"_X_U_$P(^SC(X,0),U)
59 S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
60 Q
61 ;
62COPY ; [Procedure] Make a copy of an item (Top level data only)
63 K ^TMP("MDCOPY",$J)
64 D GETS^DIQ(P1,P2_",","*","NI",$NA(^TMP("MDCOPY",$J)))
65 S MDFDA(P1,"+1,",.01)=$E("Copy of "_$$GET1^DIQ(P1,P2,.01),1,30)
66 F X=.01:0 S X=$O(^TMP("MDCOPY",$J,P1,P2_",",X)) Q:'X D
67 .S MDFDA(P1,"+1,",X)=$G(^TMP("MDCOPY",$J,P1,P2_",",X,"I"))
68 K ^TMP("MDCOPY",$J)
69 D UPDATE^DIE("","MDFDA","MDIEN")
70 I $G(MDIEN(1))<1 D ERROR(RESULTS) Q
71 S @RESULTS@(0)=P1_";"_MDIEN(1)_"^"_$$GET1^DIQ(P1,MDIEN(1)_",",.01)
72 Q
73 ;
74DELITEM ; [Procedure] Determines if a file entry can be deleted and deletes it
75 I P1="702.01" D ; Procedure File
76 .I $D(^MDD(702,"ACP",P2)) S @RESULTS@(1)="CP TRANSACTION"
77 I P1="702.09" D ; Instrument File
78 .I $D(^MDS(702.01,"AINST",P2)) S @RESULTS@(1)="CP DEFINITION"
79 .I $D(^MDS(702,"AINST",P2)) S @RESULTS@(2)="CP TRANSACTION"
80 .I $D(^MDS(703.1,"AINST",P2)) S @RESULTS@(3)="CP RESULTS"
81 I $O(@RESULTS@("")) S @RESULTS@(0)="-1^Unable to delete."
82 E S @RESULTS@(0)="1^OK"
83 Q
84 ;
85ERROR(TARGET,SOURCE) ; [Procedure]
86 ; Input parameters
87 ; 1. TARGET [Literal/Required] No description
88 ; 2. SOURCE [Literal/Required] No description
89 ;
90 N X,Y
91 I '$D(SOURCE) M SOURCE("DIERR")=^TMP("DIERR",$J)
92 I '$D(SOURCE) S @TARGET@(0)="-1^No error message available" Q
93 S @TARGET@(0)="-1^Error Encountered"
94 S @TARGET@(1)="The following Error(s) occurred on the server."
95 S @TARGET@(2)=" "
96 F X=0:0 S X=$O(SOURCE("DIERR",X)) Q:'X D
97 .S Y=$O(@TARGET@(X),-1)+1
98 .S @TARGET@(Y)="Error #: "_SOURCE("DIERR",X)_" "_$G(SOURCE("DIERR",X,"TEXT",1),"***")
99 .D:$D(SOURCE("DIERR",X,"PARAM"))
100 ..S @TARGET@(Y+1)=" ",@TARGET@(Y+2)="Parameters:"
101 ..S Z=0 F S Z=$O(SOURCE("DIERR",X,"PARAM",Z)) Q:Z="" D
102 ...S @TARGET@($O(@TARGET@(""),-1)+1)="Par: "_Z_" = "_SOURCE("DIERR",X,"PARAM",Z)
103 Q
104 ;
105GETRSLT ; [Procedure] Get result report entries
106 ; P1=PATIENT, P2=CPDefinition
107 ; Load valid instruments into MDINST()
108 F X=0:0 S X=$O(^MDS(702.01,+$G(P2),.1,"B",X)) Q:'X S MDINST(X)=""
109 ; Loop on the DFN index in 703.1
110 F X=0:0 S X=$O(^MDD(703.1,"ADFN",P1,X)) Q:'X D
111 .; Make sure it isn't pending CPGateway action
112 .Q:$P($G(^MDD(703.1,X,0)),U,9)="P"
113 .; Make sure it is for a valid instrument
114 .Q:'$D(MDINST(+$P($G(^MDD(703.1,X,0)),U,4)))
115 .F Y=0:0 S Y=$O(^MDD(703.1,X,.1,Y)) Q:'Y D
116 ..S Z="703.11;"_Y_","_X_",^"_$P(^MDD(703.1,X,0),U,1,4)_"^^^^"
117 ..S $P(Z,U,6)=$P(^MDD(703.1,X,.1,Y,0),U,2)
118 ..S @RESULTS@(+$O(@RESULTS@(""),-1)+1)=Z
119 S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
120 Q
121 ;
122GUIPT(X) ; [Procedure]
123 ; Input parameters
124 ; 1. X [Literal/Required] No description
125 ;
126 S Y="2;"_X_U_$P(^DPT(X,0),U,1,3)
127 S $P(Y,U,5)=$P(^DPT(X,0),U,9)
128 S $P(Y,U,10)=$$DOB^DPTLK1(X)
129 S $P(Y,U,11)=$$SSN^DPTLK1(X)
130 Q Y
131 ;
132RPC(RESULTS,OPTION,P1,P2,P3,P4,P5,P6) ; [Procedure] Main RPC call
133 ; RPC: [MD UTILITIES]
134 ;
135 ; Input parameters
136 ; 1. RESULTS [Literal/Required] No description
137 ; 2. OPTION [Literal/Required] No description
138 ; 3. P1 [Literal/Required] No description
139 ; 4. P2 [Literal/Required] No description
140 ; 5. P3 [Literal/Required] No description
141 ; 6. P4 [Literal/Required] No description
142 ; 7. P5 [Literal/Required] No description
143 ; 8. P6 [Literal/Required] No description
144 ;
145 ; Variables:
146 ; MDDT: [Private] Scratch
147 ; MDEND: [Private] Scratch
148 ; MDFDA: [Private] Fileman FDA variable
149 ; MDGBL: [Private] Scratch
150 ; MDIEN: [Private] Return array from UPDATE~DIE
151 ; MDPT: [Private] Scratch
152 ; Z: [Private] Scratch
153 ;
154 ; New private variables
155 NEW MDDT,MDEND,MDFDA,MDGBL,MDIEN,MDPT,Z
156 N MDRET,MDFDA,MDIEN,MDSCRN
157 D CLEAN^DILF
158 S RESULTS=$NA(^TMP("MDRPCU",$J)) K @RESULTS
159 I $T(@OPTION)="" D BADRPC("MD UTILITIES",OPTION,$T(+0)) Q
160 D @OPTION S:'$D(@RESULTS) @RESULTS@(0)="-1^No return"
161 D CLEAN^DILF
162 Q
163 ;
164TEAMPTS ; [Procedure] Return patients on a team
165 D TEAMPTS^ORQPTQ1(.MDRET,P1)
166 I '+$G(MDRET(1)) D Q
167 .S @RESULTS@(0)="0^No patients assigned to this team."
168 F X=0:0 S X=$O(MDRET(X)) Q:'X S @RESULTS@(X)=$$GUIPT(+MDRET(X))
169 S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
170 Q
171 ;
172TEAMS ; [Procedure] Return list of teams
173 D TEAMS^ORQPTQ1(.MDRET)
174 F X=0:0 S X=$O(MDRET(X)) Q:'X S @RESULTS@(X)="120.51;"_MDRET(X)
175 S @RESULTS@(0)=+$O(@RESULTS@(X))
176 Q
177 ;
178UNIQUE ; [Procedure] Is value P2 unique in file P1
179 S MDGBL=$$GET1^DID(+P1,"","","GLOBAL NAME")
180 I MDGBL="" S @RESULTS@(0)="-1^Not a valid DDNumber"
181 E S @RESULTS@(0)=($D(@(MDGBL_"P2,P3)"))=0)
182 Q
183 ;
184WARDPTS ; [Procedure] Return pts for a ward
185 S P1=$P($G(^DIC(42,P1,0)),U)
186 I '$D(^DPT("CN",P1)) D Q
187 .S @RESULTS@(0)="0^No Patients on ward '"_P1_"'."
188 F X=0:0 S X=$O(^DPT("CN",P1,X)) Q:'X D
189 .S Y=$O(@RESULTS@(""),-1)+1
190 .S @RESULTS@(Y)=$$GUIPT(X)
191 S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
192 Q
193 ;
194WARDS ; [Procedure] Return Active Set of Wards
195 N D0,X,Y
196 F D0=0:0 S D0=$O(^DIC(42,D0)) Q:'D0 D WIN^DGPMDDCF D:'X
197 .S Y=$O(@RESULTS@(""),-1)+1
198 .S @RESULTS@(Y)="42;"_D0_U_$P(^DIC(42,D0,0),U)
199 S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
200 Q
201 ;
Note: See TracBrowser for help on using the repository browser.