source: FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBRPC.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 9.6 KB
Line 
1PSBRPC ;BIRMINGHAM/EFC-BCMA RPC BROKER CALLS ;Mar 2004
2 ;;3.0;BAR CODE MED ADMIN;**6,3,4,13,32**;Mar 2004;Build 32
3 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
4 ;
5 ; Reference/IA
6 ; EN1^GMRADPT/10099
7 ; EN6^GMRVUTL/1120
8 ; DEM^VADPT/10061
9 ; IN5^VADPT/10061
10 ; File 200/10060
11 ; File 211.4/1409
12 ; CHECKAV^XUSRB/2882
13 ; GUIMTD^DPTLK6/3023
14 ; ^ORD(101.24/3429
15 ; File 2/10035
16 ; File 4/10090
17 ; EN1^GMRVUT0/1446
18 ; HASH^XUSHSHP/10045
19 ; $$DECRYP^XUSRB1/2241
20 ; ^DIC(42/1377
21 ; ^DIC(42/2440
22 ; $$GETACT^DGPFAPI/3860
23 ; $$GETICN^MPIF001/2701
24 ; $$GETDFN^MPIF001/2701
25 ; $$PROD^XUPROD/4440
26 ; $$GET^XPAR/2263
27 ; EN^XPAR/2263
28 ; $$BASE^XLFUTL/2622
29FMDATE(RESULTS,X) ;
30 ; RPC: PSB FMDATE Descr: Returns FM D/T frm Clnt DateToStr()
31 I $P(X,"@",2)="0000" S $P(X,"@",2)="0001"
32 ;if no time for dates, append the current time
33 I $P(X,"@",2)="",X'?1"N" D S $P(X,"@",2)=$P(Y,"@",2)
34 . N X
35 . S X="N",%DT="T" D ^%DT,DD^%DT
36 S %DT="T" D ^%DT
37 I +Y<1 S RESULTS(0)="-1^Invalid Date/Time" Q
38 S RESULTS(0)=Y D D^DIQ
39 S RESULTS(0)=RESULTS(0)_U_Y
40 Q
41USRLOAD(RESULTS,DUMMY) ;
42 ; RPC: PSB USERLOAD
43 S RESULTS(0)=DUZ ;UsrIEN
44 S RESULTS(1)=$$GET1^DIQ(200,DUZ_",",.01) ; Usr Nm
45 S RESULTS(2)=$S($D(^XUSEC("PSB STUDENT",DUZ)):1,1:0) ; Studnt?
46 S RESULTS(3)=$S($D(^XUSEC("PSB MANAGER",DUZ)):1,1:0) ; Mgr?
47 S RESULTS(4)=$S($D(^XUSEC("PSB CPRS MED BUTTON",DUZ)):1,1:0)
48 S RESULTS(5)=$$GET^XPAR("USR","PSB WINDOW")
49 S X=$S(+$$GET^XPAR("ALL","PSB VDL INCL CONT"):"T",1:"F")
50 S X=X_"/"_$S(+$$GET^XPAR("ALL","PSB VDL INCL PRN"):"T",1:"F")
51 S X=X_"/"_$S(+$$GET^XPAR("ALL","PSB VDL INCL ONE-TIME"):"T",1:"F")
52 S X=X_"/"_$S(+$$GET^XPAR("ALL","PSB VDL INCL ON-CALL"):"T",1:"F")
53 S X=X_"/"_+$$GET^XPAR("ALL","PSB VDL SORT COLUMN")
54 S X=X_"/"_+$$GET^XPAR("ALL","PSB VDL PB SORT COLUMN")
55 S X=X_"/"_+$$GET^XPAR("ALL","PSB VDL IV SORT COLUMN")
56 S RESULTS(6)=X ;VDL Setp
57 S RESULTS(7)=+$G(DUZ(2))
58 I RESULTS(7) S RESULTS(8)=$$GET1^DIQ(4,RESULTS(7)_",",.01)
59 E S RESULTS(8)="Undefined Division"
60 S RESULTS(7)=RESULTS(7)_U_$P($$SITE^VASITE,U,3)
61 I $T(PROD^XUPROD)]"" S RESULTS(7)=RESULTS(7)_U_$$PROD^XUPROD(1)
62 S RESULTS(9)=+$$GET^XPAR("DIV","PSB ADMIN ESIG")
63 S RESULTS(10)=+$$GET^XPAR("DIV","PSB ONLINE")
64 S RESULTS(11)=$G(DTIME,300)
65 S RESULTS(12)=$$GET^XPAR("USR","PSB UNIT DOSE COLUMN WIDTHS")
66 S RESULTS(13)=$J_"^"_$$BASE^XLFUTL($J,10,16)
67 S RESULTS(14)=$$GET^XPAR("USR","PSB IVPB COLUMN WIDTHS")
68 S RESULTS(15)=$$GET^XPAR("USR","PSB IV COLUMN WIDTHS")
69 S RESULTS(16)=$$GET^XPAR("USR","PSB PRINTER USER DEFAULT")
70 S RESULTS(17)=$$GET^XPAR("USR","PSB GUI DEFAULT PRINTER")
71 S RESULTS(18)=$S($D(^XUSEC("PSB READ ONLY",DUZ)):1,1:0)
72 S RESULTS(19)=$$GET^XPAR("USR","PSB COVERSHEET VIEWS COL SORT")
73 S RESULTS(20)=$$GET^XPAR("USR","PSB COVERSHEET V1 COL WIDTHS")
74 S RESULTS(21)=$$GET^XPAR("USR","PSB COVERSHEET V2 COL WIDTHS")
75 S RESULTS(22)=$$GET^XPAR("USR","PSB COVERSHEET V3 COL WIDTHS")
76 S RESULTS(23)=$$GET^XPAR("USR","PSB COVERSHEET V4 COL WIDTHS")
77 Q
78USRSAVE(RESULTS,PSBWIN,PSBVDL,PSBUDCW,PSBPBCW,PSBIVCW,PSBDEV,PSBCSRT,PSBCV1,PSBCV2,PSBCV3,PSBCV4) ;
79 ; RPC: PSB USERSAVE ; Saves user settings.
80 S RESULTS(0)="-1^FAILED - Parameters Save"
81 S PSBWIN=$G(PSBWIN),PSBVDL=$G(PSBVDL),PSBUDCW=$G(PSBUDCW)
82 S PSBPBCW=$G(PSBPBCW),PSBIVCW=$G(PSBIVCW),PSBDEV=$G(PSBDEV)
83 S PSBCSRT=$G(PSBCSRT),PSBCV1=$G(PSBCV1),PSBCV2=$G(PSBCV2),PSBCV3=$G(PSBCV3),PSBCV4=$G(PSBCV4)
84 D EN^XPAR("USR","PSB WINDOW",1,PSBWIN)
85 D EN^XPAR("USR","PSB VDL INCL CONT",1,$P(PSBVDL,"/",1)["T")
86 D EN^XPAR("USR","PSB VDL INCL PRN",1,$P(PSBVDL,"/",2)["T")
87 D EN^XPAR("USR","PSB VDL INCL ONE-TIME",1,$P(PSBVDL,"/",3)["T")
88 D EN^XPAR("USR","PSB VDL INCL ON-CALL",1,$P(PSBVDL,"/",4)["T")
89 D EN^XPAR("USR","PSB VDL SORT COLUMN",1,+$P(PSBVDL,"/",5))
90 D EN^XPAR("USR","PSB VDL PB SORT COLUMN",1,+$P(PSBVDL,"/",6))
91 D EN^XPAR("USR","PSB VDL IV SORT COLUMN",1,+$P(PSBVDL,"/",7))
92 D EN^XPAR("USR","PSB UNIT DOSE COLUMN WIDTHS",1,PSBUDCW)
93 D EN^XPAR("USR","PSB IVPB COLUMN WIDTHS",1,PSBPBCW)
94 D EN^XPAR("USR","PSB IV COLUMN WIDTHS",1,PSBIVCW)
95 D EN^XPAR("USR","PSB GUI DEFAULT PRINTER",1,PSBDEV)
96 D EN^XPAR("USR","PSB COVERSHEET VIEWS COL SORT",1,PSBCSRT)
97 D EN^XPAR("USR","PSB COVERSHEET V1 COL WIDTHS",1,PSBCV1)
98 D EN^XPAR("USR","PSB COVERSHEET V2 COL WIDTHS",1,PSBCV2)
99 D EN^XPAR("USR","PSB COVERSHEET V3 COL WIDTHS",1,PSBCV3)
100 D EN^XPAR("USR","PSB COVERSHEET V4 COL WIDTHS",1,PSBCV4)
101 S RESULTS(0)="1^Parameters Saved"
102 Q
103INST(RESULTS,PSBACC,PSBVER) ;
104 ; RPC: PSB INSTRUCTOR
105 ; Descr:
106 ; Used by frmInstructor to validate an instructor(s) at
107 ; the client via encrypted A/V Code.
108 S PSBACC=$$DECRYP^XUSRB1(PSBACC)
109 S PSBVER=$$DECRYP^XUSRB1(PSBVER)
110 S PSBINST=$$CHECKAV^XUSRB(PSBACC_";"_PSBVER)
111 I PSBINST<1 S RESULTS(0)="-1^Invalid Instructor Sign-On" K PSBINST Q
112 I '$D(^XUSEC("PSB INSTRUCTOR",PSBINST)) S RESULTS(0)="-1^Instructor doesn't have authority" K PSBINST Q
113 S PSBINST(0)=$$GET1^DIQ(200,PSBINST_",",.01)
114 S RESULTS(0)=PSBINST_U_PSBINST(0)
115 Q
116ESIG(RESULTS,PSBESIG) ;
117 ; RPC: PSB VALIDATE ESIG ; Validate the data in PSBESIG against user (DUZ)
118 S PSBDSIG=$P($G(PSBESIG),U,2) I PSBDSIG'="" S PSBDSIG=$$DECRYP^XUSRB1(PSBDSIG),PSBESIG=PSBDSIG
119 I $G(PSBESIG)="" S RESULTS(0)="-1^Must Supply ESig" Q
120 S X=PSBESIG D HASH^XUSHSHP
121 I X'=$$GET1^DIQ(200,DUZ_",",20.4,"I") S RESULTS(0)="-1^Invalid ESig"
122 E S RESULTS(0)="1^ESig Verified"
123 Q
124SCANPT(RESULTS,PSBDATA) ; Lookup Pt by Full SSN
125 ; RPC: PSB SCANPT
126 ; File #2 lookup either by full SSN
127 ; returns -1 error / patient data
128 ; Check for Interleave 2 of 5 Check Digit on SSN and remove
129 N DFN
130 I "SS"[$P($G(PSBDATA),"^",3) D Q:RESULTS(1)<0
131 .S:$P(PSBDATA,"^")?1"0"9N.U PSBDATA=$E(PSBDATA,2,99) N PSBCNT
132 .I $P(PSBDATA,U)'?9N.1U S RESULTS(0)=1,RESULTS(1)="-1^Invalid Patient Lookup" Q
133 .S X=$$FIND1^DIC(2,"","",$P(PSBDATA,U),"SSN")
134 .I X<1 S RESULTS(0)=1,RESULTS(1)="-1^Invalid Patient Lookup" Q
135 .S (DFN,RESULTS(1),PSBDFN)=X
136 .S PSBICN=$$GETICN^MPIF001(PSBDFN) I +PSBICN=-1 S PSBICN=""
137 I $G(DFN)']"" D Q:+PSBDFN'>0
138 .; CCOW !
139 .I "DF"[$P($G(PSBDATA),"^",3) S PSBDFN=$P($G(PSBDATA),"^"),PSBICN=$$GETICN^MPIF001(PSBDFN) I +PSBICN=-1 S PSBICN="",RESULTS(0)=1,RESULTS(1)="-1^Cannot find ICN via DFN"
140 .I "IC"[$P($G(PSBDATA),"^",3) S PSBICN=$P($G(PSBDATA),"^"),PSBDFN=$$GETDFN^MPIF001(PSBICN) I +PSBDFN=-1 S PSBDFN="",RESULTS(0)=1,RESULTS(1)="-1^Cannot find DFN via ICN" Q
141 .S (DFN,RESULTS(1))=PSBDFN
142 K VADM,VAIN
143 D DEM^VADPT,IN5^VADPT
144 I ('$P(PSBDATA,U,2))&('VAIP(13)&'VADM(6)) S RESULTS(0)=1,RESULTS(1)="-1^Patient has been DISCHARGED" I ($P($G(PSBDATA),U,3)'["IC")&($P($G(PSBDATA),U,3)'["DF") K VAIP,VADM Q
145 I ('$P(PSBDATA,U,2))&(VADM(6)'="") S RESULTS(0)=1,RESULTS(1)="-1^"_"This patient died "_$TR($P(VADM(6),U,2),"@"," ") I ($P($G(PSBDATA),U,3)'["IC")&($P($G(PSBDATA),U,3)'["DF") K VAIP,VADM Q
146 S RESULTS(1)=PSBDFN
147 F X=1,2,3,4,5 S RESULTS(X+1)=$G(VADM(X))
148 F X=3,4,5,6,7,8,9,10,11 S RESULTS(X+4)=$G(VAIP(X))
149 S $P(RESULTS(9),U,3)=$$GET1^DIQ(42,$P(RESULTS(9),U)_",",44,"I")_"^"_$$GET1^DIQ(42,$P(RESULTS(9),U)_",",44)
150 S GMRVSTR="HT" D EN6^GMRVUTL
151 S X=+$P(X,U,8) S:X X=X*2.54\1 S PSBHDR("HEIGHT")=$S(X:X_"cm",1:"*")
152 S RESULTS(16)=PSBHDR("HEIGHT")
153 S GMRVSTR="WT" D EN6^GMRVUTL
154 S X=+$P(X,U,8) S X=$J(X/2.2,0,2) S PSBHDR("WEIGHT")=$S(X:X_"kg",1:"*")
155 S RESULTS(17)=PSBHDR("WEIGHT")
156 S GMRA="0^0^111" D EN1^GMRADPT
157 I $O(GMRAL(0)) S RESULTS(18)=1
158 E S RESULTS(18)=0
159 ; Means Tst
160 D GUIMTD^DPTLK6(.PSBDATA,PSBDFN)
161 S RESULTS(19)=+$G(PSBDATA(1))_U_$G(PSBDATA(2))_U_$G(PSBDATA(3))
162 S PSBICN=$$GETICN^MPIF001(PSBDFN) I +PSBICN=-1 S PSBICN=""
163 S RESULTS(20)=PSBICN
164 S RESULTS(21)="",RESULTS(0)=21
165 S:VADM(6)'="" RESULTS(21)="This patient died "_$TR($P(VADM(6),U,2),"@"," ")
166 S:('VAIP(13))&('VADM(6)) RESULTS(21)="Patient has been DISCHARGED"
167 S (RESULTS(0),PSBCNT)=22
168 S RESULTS(PSBCNT)=""
169 F PSBINDX=1:1:($$GETACT^DGPFAPI(PSBDFN,.PSBPTFLG)) D
170 .Q:'$D(PSBPTFLG) Q:'$D(@(PSBPTFLG_"(PSBINDX,""FLAG"")")) S PSBPFLAG="PATFLG",$P(PSBPFLAG,U,2)=$P(@(PSBPTFLG_"(PSBINDX,""FLAG"")"),"^",2)
171 .S $P(PSBPFLAG,U,3)=PSBINDX,PSBCNT=21+PSBINDX,RESULTS(PSBCNT)=PSBPFLAG
172 S RESULTS(0)=PSBCNT
173 I $D(PSBPTFLG) K @PSBPTFLG
174 K VAIP,VADM
175 Q
176MAX(RESULTS,PSBDAYS) ;
177 ; RPC: PSB MAXDAYS ; Max days - MAH
178 S X=$O(^ORD(101.24,"B","ORRP BCMA MAH",""))
179 S RESULTS(0)=$$GET1^DIQ(101.24,X_",",.42)
180 Q
181NWLIST(RESULTS,DUMMY) ; ward/nurs File #211.4
182 K ^TMP("PSB",$J)
183 S PSBIEN=0 F S PSBIEN=$O(^NURSF(211.4,PSBIEN)) Q:PSBIEN'?.N D
184 .S ^TMP("PSB",$J,$$GET1^DIQ(211.4,PSBIEN_",",.01)_" [NURS UNIT]")=PSBIEN
185 .S PSBX=0 F S PSBX=$O(^NURSF(211.4,PSBIEN,3,PSBX)) Q:PSBX="" D
186 ..S PSBWIEN=$P(^NURSF(211.4,PSBIEN,3,PSBX,0),"^")
187 ..I $$GET1^DIQ(42,PSBWIEN_",",.01)]"" S ^TMP("PSB",$J,$$GET1^DIQ(42,PSBWIEN_",",.01)_" [MAS WARD]")=PSBIEN
188 S RESULTS(0)=0
189 S X="" F S X=$O(^TMP("PSB",$J,X)) Q:X="" D
190 .S RESULTS(0)=RESULTS(0)+1
191 .S RESULTS(RESULTS(0))=^TMP("PSB",$J,X)_U_X_U_$S(($$GET1^DIQ(211.4,^TMP("PSB",$J,X)_",",1)="ACTIVE")&($$GET1^DIQ(211.4,^TMP("PSB",$J,X)_",",1.5)'="**INACTIVE**"):"1",1:"0")
192 K ^TMP("PSB",$J)
193 Q
194VITALS(RESULTS,DFN) ;Vitals API
195 ; RPC PSB VITALS
196 K RESULTS
197 N PSBSTRT,PSBSTOP,PSBNOW
198 S PSBDFN=DFN,GMRVSTR="T;P;R;BP;PN"
199 D NOW^%DTC S PSBNOW=%,PSBSTRT=$$FMADD^XLFDT(PSBNOW,"",-168),PSBSTOP=PSBNOW,GMRVSTR(0)=PSBSTRT_U_PSBSTOP_U_4_U
200 K ^UTILITY($J,"GMRVD")
201 D EN1^GMRVUT0
202 S PSBCNT=1
203 I '$D(^UTILITY($J,"GMRVD")) S RESULTS(0)=PSBCNT,RESULTS(PSBCNT)="No Vitals to report" Q
204 S PSBTYP=""
205 F S PSBTYP=$O(^UTILITY($J,"GMRVD",PSBTYP)) Q:PSBTYP="" D
206 .S PSBRDT=""
207 .F S PSBRDT=$O(^UTILITY($J,"GMRVD",PSBTYP,PSBRDT)) Q:PSBRDT="" D
208 ..S PSBIEN=""
209 ..F S PSBIEN=$O(^UTILITY($J,"GMRVD",PSBTYP,PSBRDT,PSBIEN)) Q:PSBIEN="" D
210 ...S PSBDATA=($G(^UTILITY($J,"GMRVD",PSBTYP,PSBRDT,PSBIEN)))
211 ...S RESULTS(PSBCNT)=PSBTYP_U_$P(PSBDATA,U,1,2)_U_$P(PSBDATA,U,8)
212 ...S PSBCNT=PSBCNT+1
213 S RESULTS(0)=PSBCNT-1
214 K ^UTILITY($J,"GMRVD"),GMRBSTR,PSBDFN,PSBTYPE,PSBDATA,PSBCNT
215 Q
Note: See TracBrowser for help on using the repository browser.