PSBRPC ;BIRMINGHAM/EFC - BCMA RPC BROKER CALLS ;29-May-2012 14:21;PLS
;;3.0;BAR CODE MED ADMIN;**6,3,4,1005,1006,13,32,28,1010,42,1015**;Mar 2004;Build 62
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
; Reference/IA
; File 211.4/1409
; CHECKAV^XUSRB/2882
; GUIMTD^DPTLK6/3023
; ^ORD(101.24/3429
; EN1^GMRVUT0/1446
; $$GETACT^DGPFAPI/3860
;
; Modified - IHS/MSC/PLS - 03/27/06 - Reapplied mod at line VITALS+14
; Also modified the VITALS API
FMDATE(RESULTS,X) ;
; RPC: PSB FMDATE
; Descr: Returns FM Date/Time from Clnt DateToStr()
;
I $P(X,"@",2)="0000" S $P(X,"@",2)="0001"
;if no time for dates like T-1, append the current time
I $P(X,"@",2)="",X'?1"N" D S $P(X,"@",2)=$P(Y,"@",2)
. N X
. S X="N",%DT="T" D ^%DT,DD^%DT
S %DT="T" D ^%DT
I +Y<1 S RESULTS(0)="-1^Invalid Date/Time" Q
S RESULTS(0)=Y D D^DIQ
S RESULTS(0)=RESULTS(0)_U_Y
Q
;
USRLOAD(RESULTS,DUMMY) ;
;
; RPC: PSB USERLOAD
; Descr: Load wkst user
;
S RESULTS(0)=DUZ ;UsrIEN
S RESULTS(1)=$$GET1^DIQ(200,DUZ_",",.01) ; Usr Nm
S RESULTS(2)=$S($D(^XUSEC("PSB STUDENT",DUZ)):1,1:0) ; Studnt?
S RESULTS(3)=$S($D(^XUSEC("PSB MANAGER",DUZ)):1,1:0) ; Mgr?
S RESULTS(4)=$S($D(^XUSEC("PSB CPRS MED BUTTON",DUZ)):1,1:0)
S RESULTS(5)=$$GET^XPAR("USR","PSB WINDOW")
;VDL Strng
S X=$S(+$$GET^XPAR("ALL","PSB VDL INCL CONT"):"T",1:"F")
S X=X_"/"_$S(+$$GET^XPAR("ALL","PSB VDL INCL PRN"):"T",1:"F")
S X=X_"/"_$S(+$$GET^XPAR("ALL","PSB VDL INCL ONE-TIME"):"T",1:"F")
S X=X_"/"_$S(+$$GET^XPAR("ALL","PSB VDL INCL ON-CALL"):"T",1:"F")
S X=X_"/"_+$$GET^XPAR("ALL","PSB VDL SORT COLUMN")
S X=X_"/"_+$$GET^XPAR("ALL","PSB VDL PB SORT COLUMN")
S X=X_"/"_+$$GET^XPAR("ALL","PSB VDL IV SORT COLUMN")
;
S RESULTS(6)=X ;VDL Setp
S RESULTS(7)=+$G(DUZ(2))
I RESULTS(7) S RESULTS(8)=$$GET1^DIQ(4,RESULTS(7)_",",.01)
E S RESULTS(8)="Undefined Division"
S RESULTS(7)=RESULTS(7)_U_$P($$SITE^VASITE,U,3)
I $T(PROD^XUPROD)]"" S RESULTS(7)=RESULTS(7)_U_$$PROD^XUPROD(1)
S RESULTS(9)=+$$GET^XPAR("DIV","PSB ADMIN ESIG")
S RESULTS(10)=+$$GET^XPAR("DIV","PSB ONLINE")
S RESULTS(11)=$G(DTIME,300)
S RESULTS(12)=$$GET^XPAR("USR","PSB UNIT DOSE COLUMN WIDTHS")
S RESULTS(13)=$J_"^"_$$BASE^XLFUTL($J,10,16)
S RESULTS(14)=$$GET^XPAR("USR","PSB IVPB COLUMN WIDTHS")
S RESULTS(15)=$$GET^XPAR("USR","PSB IV COLUMN WIDTHS")
S RESULTS(16)=$$GET^XPAR("USR","PSB PRINTER USER DEFAULT")
S RESULTS(17)=$$GET^XPAR("USR","PSB GUI DEFAULT PRINTER")
S RESULTS(18)=$S($D(^XUSEC("PSB READ ONLY",DUZ)):1,1:0)
S RESULTS(19)=$$GET^XPAR("USR","PSB COVERSHEET VIEWS COL SORT")
S RESULTS(20)=$$GET^XPAR("USR","PSB COVERSHEET V1 COL WIDTHS")
S RESULTS(21)=$$GET^XPAR("USR","PSB COVERSHEET V2 COL WIDTHS")
S RESULTS(22)=$$GET^XPAR("USR","PSB COVERSHEET V3 COL WIDTHS")
S RESULTS(23)=$$GET^XPAR("USR","PSB COVERSHEET V4 COL WIDTHS")
S RESULTS(24)=$S($D(^XUSEC("PSB UNABLE TO SCAN",DUZ)):1,1:0)
S RESULTS(25)=$$GET^XPAR("DIV","PSB 5 RIGHTS UNITDOSE")
S RESULTS(26)=$$GET^XPAR("DIV","PSB 5 RIGHTS IV")
S RESULTS(27)=$G(DUZ("AG")) ;IHS/MSC/PLS
Q
;
USRSAVE(RESULTS,PSBWIN,PSBVDL,PSBUDCW,PSBPBCW,PSBIVCW,PSBDEV,PSBCSRT,PSBCV1,PSBCV2,PSBCV3,PSBCV4) ;
;
; RPC: PSB USERSAVE
; Descr: Saves user settings.
;
S RESULTS(0)="-1^FAILED - Parameters Save"
S PSBWIN=$G(PSBWIN),PSBVDL=$G(PSBVDL),PSBUDCW=$G(PSBUDCW)
S PSBPBCW=$G(PSBPBCW),PSBIVCW=$G(PSBIVCW),PSBDEV=$G(PSBDEV)
S PSBCSRT=$G(PSBCSRT),PSBCV1=$G(PSBCV1),PSBCV2=$G(PSBCV2),PSBCV3=$G(PSBCV3),PSBCV4=$G(PSBCV4)
;
D EN^XPAR("USR","PSB WINDOW",1,PSBWIN)
D EN^XPAR("USR","PSB VDL INCL CONT",1,$P(PSBVDL,"/",1)["T")
D EN^XPAR("USR","PSB VDL INCL PRN",1,$P(PSBVDL,"/",2)["T")
D EN^XPAR("USR","PSB VDL INCL ONE-TIME",1,$P(PSBVDL,"/",3)["T")
D EN^XPAR("USR","PSB VDL INCL ON-CALL",1,$P(PSBVDL,"/",4)["T")
D EN^XPAR("USR","PSB VDL SORT COLUMN",1,+$P(PSBVDL,"/",5))
D EN^XPAR("USR","PSB VDL PB SORT COLUMN",1,+$P(PSBVDL,"/",6))
D EN^XPAR("USR","PSB VDL IV SORT COLUMN",1,+$P(PSBVDL,"/",7))
D EN^XPAR("USR","PSB UNIT DOSE COLUMN WIDTHS",1,PSBUDCW)
D EN^XPAR("USR","PSB IVPB COLUMN WIDTHS",1,PSBPBCW)
D EN^XPAR("USR","PSB IV COLUMN WIDTHS",1,PSBIVCW)
D EN^XPAR("USR","PSB GUI DEFAULT PRINTER",1,PSBDEV)
D EN^XPAR("USR","PSB COVERSHEET VIEWS COL SORT",1,PSBCSRT)
D EN^XPAR("USR","PSB COVERSHEET V1 COL WIDTHS",1,PSBCV1)
D EN^XPAR("USR","PSB COVERSHEET V2 COL WIDTHS",1,PSBCV2)
D EN^XPAR("USR","PSB COVERSHEET V3 COL WIDTHS",1,PSBCV3)
D EN^XPAR("USR","PSB COVERSHEET V4 COL WIDTHS",1,PSBCV4)
S RESULTS(0)="1^Parameters Saved"
Q
;
INST(RESULTS,PSBACC,PSBVER) ;
;
; RPC: PSB INSTRUCTOR
; Descr:
; Used by frmInstructor to validate an instructor(s) at
; the client via encrypted A/V Code.
;
S PSBACC=$$DECRYP^XUSRB1(PSBACC)
S PSBVER=$$DECRYP^XUSRB1(PSBVER)
S PSBINST=$$CHECKAV^XUSRB(PSBACC_";"_PSBVER)
I PSBINST<1 S RESULTS(0)="-1^Invalid Instructor Sign-On" K PSBINST Q
I '$D(^XUSEC("PSB INSTRUCTOR",PSBINST)) S RESULTS(0)="-1^Instructor doesn't have authority" K PSBINST Q
S PSBINST(0)=$$GET1^DIQ(200,PSBINST_",",.01)
S RESULTS(0)=PSBINST_U_PSBINST(0)
Q
;
ESIG(RESULTS,PSBESIG) ;
;
; RPC: PSB VALIDATE ESIG
; Descr: Validate the data in PSBESIG against user (DUZ)
;
S PSBDSIG=$P($G(PSBESIG),U,2) I PSBDSIG'="" S PSBDSIG=$$DECRYP^XUSRB1(PSBDSIG),PSBESIG=PSBDSIG
I $G(PSBESIG)="" S RESULTS(0)="-1^Must Supply ESig" Q
S X=PSBESIG D HASH^XUSHSHP
I X'=$$GET1^DIQ(200,DUZ_",",20.4,"I") S RESULTS(0)="-1^Invalid ESig"
E S RESULTS(0)="1^ESig Verified"
Q
;
SCANPT(RESULTS,PSBDATA) ; Lookup Pt by Full SSN
;
; RPC: PSB SCANPT
; Descr:
; File #2 lookup either by full SSN
; returns -1 on error or patient data
; Check for Interleave 2 of 5 Check Digit on SSN and remove
;
N DFN
I "SS"[$P($G(PSBDATA),"^",3) D Q:RESULTS(1)<0
.S:$P(PSBDATA,"^")?1"0"9N.U PSBDATA=$E(PSBDATA,2,99) N PSBCNT
.; IHS vs VA Agency check for Patient ID info
.I $G(DUZ("AG"))'="I",$G(DUZ("AG"))'="V" S RESULTS(0)=1,RESULTS(1)="-1^Invalid Agency Code - Not IHS or VA" Q
.I $G(DUZ("AG"))="I" D
..S X=-1
..I $P(PSBDATA,U)?12N S X=$$HRCNF^APSPFUNC($P(PSBDATA,U))
..S:X'>0 RESULTS(0)=1,RESULTS(1)="-1^Patient not found or # not 12 digit"
.E D
..I $P(PSBDATA,U)'?9N.1U S RESULTS(0)=1,RESULTS(1)="-1^Invalid Patient Lookup" Q
..S X=$$FIND1^DIC(2,"","",$P(PSBDATA,U),"SSN")
..I X<1 S RESULTS(0)=1,RESULTS(1)="-1^Invalid Patient Lookup"
.Q:$G(RESULTS(1))<0
.;
.S (DFN,RESULTS(1),PSBDFN)=X
.S PSBICN=$$GETICN^MPIF001(PSBDFN) I +PSBICN=-1 S PSBICN=""
I $G(DFN)']"" D Q:+PSBDFN'>0
.; CCOW !
.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"
.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
.S (DFN,RESULTS(1))=PSBDFN
.;
K VADM,VAIN
D DEM^VADPT,IN5^VADPT
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,VA Q
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,VA Q
S RESULTS(1)=PSBDFN
F X=1,3,4,5 S RESULTS(X+1)=$G(VADM(X))
; IHS/VA - use VA("PID") instead of VADM(2) for Pat ID
S RESULTS(3)=$TR(VA("PID"),"-")_U_VA("PID")
F X=3,4,5,6,7,8,9,10,11 S RESULTS(X+4)=$G(VAIP(X))
;
; IHS/MSC/PLS - 03/27/06 - Changed to call PCC Vitals based on
; parameter flag DUZ("AG")="I" and PCC Vitals package usage
; flag "BEHOVM USE VMSR"=1
;
I $G(DUZ("AG"))="I",$$GET^XPAR("ALL","BEHOVM USE VMSR") D
.S X=+$P($$VITAL^APSPFUNC(DFN,"HT"),U,2),X=$$VITCHT^APSPFUNC(X)\1,PSBHDR("HEIGHT")=$S(X:X_"cm",1:"*")
.S X=+$P($$VITAL^APSPFUNC(DFN,"WT"),U,2),X=$$VITCWT^APSPFUNC(X)\1,PSBHDR("WEIGHT")=$S(X:X_"kg",1:"*")
E D
.S GMRVSTR="HT" D EN6^GMRVUTL
.S X=+$P(X,U,8) S:X X=X*2.54\1 S PSBHDR("HEIGHT")=$S(X:X_"cm",1:"*")
.S GMRVSTR="WT" D EN6^GMRVUTL
.S X=+$P(X,U,8) S X=$J(X/2.2,0,2) S PSBHDR("WEIGHT")=$S(X:X_"kg",1:"*")
;
S $P(RESULTS(9),U,3)=$$GET1^DIQ(42,$P(RESULTS(9),U)_",",44,"I")_"^"_$$GET1^DIQ(42,$P(RESULTS(9),U)_",",44)
S RESULTS(16)=PSBHDR("HEIGHT")
S RESULTS(17)=PSBHDR("WEIGHT")
S GMRA="0^0^111" D EN1^GMRADPT
I $O(GMRAL(0)) S RESULTS(18)=1
E S RESULTS(18)=0
; Means Tst
D GUIMTD^DPTLK6(.PSBDATA,PSBDFN)
S RESULTS(19)=+$G(PSBDATA(1))_U_$G(PSBDATA(2))_U_$G(PSBDATA(3))
S PSBICN=$$GETICN^MPIF001(PSBDFN) I +PSBICN=-1 S PSBICN=""
S RESULTS(20)=PSBICN
S RESULTS(21)="",RESULTS(0)=21
S:VADM(6)'="" RESULTS(21)="This patient died "_$TR($P(VADM(6),U,2),"@"," ")
S:('VAIP(13))&('VADM(6)) RESULTS(21)="Patient has been DISCHARGED"
S (RESULTS(0),PSBCNT)=22
S RESULTS(PSBCNT)=""
F PSBINDX=1:1:($$GETACT^DGPFAPI(PSBDFN,.PSBPTFLG)) D
.Q:'$D(PSBPTFLG) Q:'$D(@(PSBPTFLG_"(PSBINDX,""FLAG"")")) S PSBPFLAG="PATFLG",$P(PSBPFLAG,U,2)=$P(@(PSBPTFLG_"(PSBINDX,""FLAG"")"),"^",2)
.S $P(PSBPFLAG,U,3)=PSBINDX,PSBCNT=21+PSBINDX,RESULTS(PSBCNT)=PSBPFLAG
S RESULTS(0)=PSBCNT
I $D(PSBPTFLG) K @PSBPTFLG
K VAIP,VADM,VA
Q
;
MAX(RESULTS,PSBDAYS) ;
;
; RPC: PSB MAXDAYS ; Max days user view/print MAH
;
S X=$O(^ORD(101.24,"B","ORRP BCMA MAH",""))
S RESULTS(0)=$$GET1^DIQ(101.24,X_",",.42)
Q
;
NWLIST(RESULTS,DUMMY) ; ward list - NURS LOCATION, file 211.4
;
; RPC: PSB NURS WARDLIST
;
K ^TMP("PSB",$J)
S PSBIEN=0 F S PSBIEN=$O(^NURSF(211.4,PSBIEN)) Q:PSBIEN'?.N D
.S ^TMP("PSB",$J,$$GET1^DIQ(211.4,PSBIEN_",",.01)_" [NURS UNIT]")=PSBIEN
.S PSBX=0 F S PSBX=$O(^NURSF(211.4,PSBIEN,3,PSBX)) Q:PSBX="" D
..S PSBWIEN=$P(^NURSF(211.4,PSBIEN,3,PSBX,0),"^")
..I $$GET1^DIQ(42,PSBWIEN_",",.01)]"" S ^TMP("PSB",$J,$$GET1^DIQ(42,PSBWIEN_",",.01)_" [MAS WARD]")=PSBIEN
S RESULTS(0)=0
S X="" F S X=$O(^TMP("PSB",$J,X)) Q:X="" D
.S RESULTS(0)=RESULTS(0)+1
.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")
K ^TMP("PSB",$J)
Q
;
VITALS(RESULTS,DFN) ;Vitals API
;
; RPC PSB VITALS
;
;Retrieve vitals from either the PCC V Measurment file or VA Vitals
; file. Based on agency code = "I" & Vitals package flag=1 for the
; PCC V Measurement file or "V" for the VA Vitals file.
;
I $G(DUZ("AG"))="I",$$GET^XPAR("ALL","BEHOVM USE VMSR") D Q
.K RESULTS
.N PSBNOW,PSBSTRT,VITS,CNT,VTYP,LP,DATA,NODE,XREF
.S XREF("TMP")="T",XREF("PU")="P",XREF("BP")="BP",XREF("RS")="R",XREF("PA")="PN"
.S PSBNOW=$$NOW^XLFDT(),PSBSTRT=$$FMADD^XLFDT(PSBNOW,-168)
.S CNT=0 F LP="TMP","PU","RS","BP","PA" D
..;IHS/MSC/PLS - 1/16/08 - Fixed IEN lookup
..;S VTYP=$$FIND1^DIC(9999999.07,"","BX",LP)
..S VTYP=+$$VCTL^BEHOVM(LP)
..I VTYP S VITS(CNT+1)=VTYP,CNT=CNT+1
.D GRID^BEHOVM(.DATA,DFN,PSBNOW,$$FMADD^XLFDT(PSBNOW,"",-168),0,.VITS)
.;BUILD RESULTS ARRAY
.I '$P(@DATA@(0),U,3) D Q ; No Results
..S RESULTS(0)=1,RESULTS(1)="No Vitals to report"
.S (CNT,LP)=0 F S LP=$O(@DATA@("R",LP)) Q:'LP D
..S NODE=@DATA@("R",LP)
..S RESULTS(CNT+1)=XREF($P(@DATA@(0,$P(NODE,U,2)),U,4))_U_$E($$GET1^DIQ(9000010.01,$P(NODE,U,5),1201,"I"),1,12)_U_DFN_U_$P(NODE,U,3)
..S CNT=CNT+1
.S RESULTS(0)=CNT
;
K RESULTS
N PSBSTRT,PSBSTOP,PSBNOW
S PSBDFN=DFN,GMRVSTR="T;P;R;BP;PN"
D NOW^%DTC S PSBNOW=%,PSBSTRT=$$FMADD^XLFDT(PSBNOW,"",-168),PSBSTOP=PSBNOW,GMRVSTR(0)=PSBSTRT_U_PSBSTOP_U_4_U
K ^UTILITY($J,"GMRVD")
D EN1^GMRVUT0
S PSBCNT=1
I '$D(^UTILITY($J,"GMRVD")) S RESULTS(0)=PSBCNT,RESULTS(PSBCNT)="No Vitals to report" Q
S PSBTYP=""
F S PSBTYP=$O(^UTILITY($J,"GMRVD",PSBTYP)) Q:PSBTYP="" D
.S PSBRDT=""
.F S PSBRDT=$O(^UTILITY($J,"GMRVD",PSBTYP,PSBRDT)) Q:PSBRDT="" D
..S PSBIEN=""
..F S PSBIEN=$O(^UTILITY($J,"GMRVD",PSBTYP,PSBRDT,PSBIEN)) Q:PSBIEN="" D
...S PSBDATA=($G(^UTILITY($J,"GMRVD",PSBTYP,PSBRDT,PSBIEN)))
...S RESULTS(PSBCNT)=PSBTYP_U_$P(PSBDATA,U,1,2)_U_$P(PSBDATA,U,8)
...S PSBCNT=PSBCNT+1
S RESULTS(0)=PSBCNT-1
K ^UTILITY($J,"GMRVD"),GMRBSTR,PSBDFN,PSBTYPE,PSBDATA,PSBCNT
Q
PSBRPC ;BIRMINGHAM/EFC - BCMA RPC BROKER CALLS ;29-May-2012 14:21;PLS
+1 ;;3.0;BAR CODE MED ADMIN;**6,3,4,1005,1006,13,32,28,1010,42,1015**;Mar 2004;Build 62
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; File 211.4/1409
+6 ; CHECKAV^XUSRB/2882
+7 ; GUIMTD^DPTLK6/3023
+8 ; ^ORD(101.24/3429
+9 ; EN1^GMRVUT0/1446
+10 ; $$GETACT^DGPFAPI/3860
+11 ;
+12 ; Modified - IHS/MSC/PLS - 03/27/06 - Reapplied mod at line VITALS+14
+13 ; Also modified the VITALS API
FMDATE(RESULTS,X) ;
+1 ; RPC: PSB FMDATE
+2 ; Descr: Returns FM Date/Time from Clnt DateToStr()
+3 ;
+4 IF $PIECE(X,"@",2)="0000"
SET $PIECE(X,"@",2)="0001"
+5 ;if no time for dates like T-1, append the current time
+6 IF $PIECE(X,"@",2)=""
IF X'?1"N"
Begin DoDot:1
+7 NEW X
+8 SET X="N"
SET %DT="T"
DO ^%DT
DO DD^%DT
End DoDot:1
SET $PIECE(X,"@",2)=$PIECE(Y,"@",2)
+9 SET %DT="T"
DO ^%DT
+10 IF +Y<1
SET RESULTS(0)="-1^Invalid Date/Time"
QUIT
+11 SET RESULTS(0)=Y
DO D^DIQ
+12 SET RESULTS(0)=RESULTS(0)_U_Y
+13 QUIT
+14 ;
USRLOAD(RESULTS,DUMMY) ;
+1 ;
+2 ; RPC: PSB USERLOAD
+3 ; Descr: Load wkst user
+4 ;
+5 ;UsrIEN
SET RESULTS(0)=DUZ
+6 ; Usr Nm
SET RESULTS(1)=$$GET1^DIQ(200,DUZ_",",.01)
+7 ; Studnt?
SET RESULTS(2)=$SELECT($DATA(^XUSEC("PSB STUDENT",DUZ)):1,1:0)
+8 ; Mgr?
SET RESULTS(3)=$SELECT($DATA(^XUSEC("PSB MANAGER",DUZ)):1,1:0)
+9 SET RESULTS(4)=$SELECT($DATA(^XUSEC("PSB CPRS MED BUTTON",DUZ)):1,1:0)
+10 SET RESULTS(5)=$$GET^XPAR("USR","PSB WINDOW")
+11 ;VDL Strng
+12 SET X=$SELECT(+$$GET^XPAR("ALL","PSB VDL INCL CONT"):"T",1:"F")
+13 SET X=X_"/"_$SELECT(+$$GET^XPAR("ALL","PSB VDL INCL PRN"):"T",1:"F")
+14 SET X=X_"/"_$SELECT(+$$GET^XPAR("ALL","PSB VDL INCL ONE-TIME"):"T",1:"F")
+15 SET X=X_"/"_$SELECT(+$$GET^XPAR("ALL","PSB VDL INCL ON-CALL"):"T",1:"F")
+16 SET X=X_"/"_+$$GET^XPAR("ALL","PSB VDL SORT COLUMN")
+17 SET X=X_"/"_+$$GET^XPAR("ALL","PSB VDL PB SORT COLUMN")
+18 SET X=X_"/"_+$$GET^XPAR("ALL","PSB VDL IV SORT COLUMN")
+19 ;
+20 ;VDL Setp
SET RESULTS(6)=X
+21 SET RESULTS(7)=+$GET(DUZ(2))
+22 IF RESULTS(7)
SET RESULTS(8)=$$GET1^DIQ(4,RESULTS(7)_",",.01)
+23 IF '$TEST
SET RESULTS(8)="Undefined Division"
+24 SET RESULTS(7)=RESULTS(7)_U_$PIECE($$SITE^VASITE,U,3)
+25 IF $TEXT(PROD^XUPROD)]""
SET RESULTS(7)=RESULTS(7)_U_$$PROD^XUPROD(1)
+26 SET RESULTS(9)=+$$GET^XPAR("DIV","PSB ADMIN ESIG")
+27 SET RESULTS(10)=+$$GET^XPAR("DIV","PSB ONLINE")
+28 SET RESULTS(11)=$GET(DTIME,300)
+29 SET RESULTS(12)=$$GET^XPAR("USR","PSB UNIT DOSE COLUMN WIDTHS")
+30 SET RESULTS(13)=$JOB_"^"_$$BASE^XLFUTL($JOB,10,16)
+31 SET RESULTS(14)=$$GET^XPAR("USR","PSB IVPB COLUMN WIDTHS")
+32 SET RESULTS(15)=$$GET^XPAR("USR","PSB IV COLUMN WIDTHS")
+33 SET RESULTS(16)=$$GET^XPAR("USR","PSB PRINTER USER DEFAULT")
+34 SET RESULTS(17)=$$GET^XPAR("USR","PSB GUI DEFAULT PRINTER")
+35 SET RESULTS(18)=$SELECT($DATA(^XUSEC("PSB READ ONLY",DUZ)):1,1:0)
+36 SET RESULTS(19)=$$GET^XPAR("USR","PSB COVERSHEET VIEWS COL SORT")
+37 SET RESULTS(20)=$$GET^XPAR("USR","PSB COVERSHEET V1 COL WIDTHS")
+38 SET RESULTS(21)=$$GET^XPAR("USR","PSB COVERSHEET V2 COL WIDTHS")
+39 SET RESULTS(22)=$$GET^XPAR("USR","PSB COVERSHEET V3 COL WIDTHS")
+40 SET RESULTS(23)=$$GET^XPAR("USR","PSB COVERSHEET V4 COL WIDTHS")
+41 SET RESULTS(24)=$SELECT($DATA(^XUSEC("PSB UNABLE TO SCAN",DUZ)):1,1:0)
+42 SET RESULTS(25)=$$GET^XPAR("DIV","PSB 5 RIGHTS UNITDOSE")
+43 SET RESULTS(26)=$$GET^XPAR("DIV","PSB 5 RIGHTS IV")
+44 ;IHS/MSC/PLS
SET RESULTS(27)=$GET(DUZ("AG"))
+45 QUIT
+46 ;
USRSAVE(RESULTS,PSBWIN,PSBVDL,PSBUDCW,PSBPBCW,PSBIVCW,PSBDEV,PSBCSRT,PSBCV1,PSBCV2,PSBCV3,PSBCV4) ;
+1 ;
+2 ; RPC: PSB USERSAVE
+3 ; Descr: Saves user settings.
+4 ;
+5 SET RESULTS(0)="-1^FAILED - Parameters Save"
+6 SET PSBWIN=$GET(PSBWIN)
SET PSBVDL=$GET(PSBVDL)
SET PSBUDCW=$GET(PSBUDCW)
+7 SET PSBPBCW=$GET(PSBPBCW)
SET PSBIVCW=$GET(PSBIVCW)
SET PSBDEV=$GET(PSBDEV)
+8 SET PSBCSRT=$GET(PSBCSRT)
SET PSBCV1=$GET(PSBCV1)
SET PSBCV2=$GET(PSBCV2)
SET PSBCV3=$GET(PSBCV3)
SET PSBCV4=$GET(PSBCV4)
+9 ;
+10 DO EN^XPAR("USR","PSB WINDOW",1,PSBWIN)
+11 DO EN^XPAR("USR","PSB VDL INCL CONT",1,$PIECE(PSBVDL,"/",1)["T")
+12 DO EN^XPAR("USR","PSB VDL INCL PRN",1,$PIECE(PSBVDL,"/",2)["T")
+13 DO EN^XPAR("USR","PSB VDL INCL ONE-TIME",1,$PIECE(PSBVDL,"/",3)["T")
+14 DO EN^XPAR("USR","PSB VDL INCL ON-CALL",1,$PIECE(PSBVDL,"/",4)["T")
+15 DO EN^XPAR("USR","PSB VDL SORT COLUMN",1,+$PIECE(PSBVDL,"/",5))
+16 DO EN^XPAR("USR","PSB VDL PB SORT COLUMN",1,+$PIECE(PSBVDL,"/",6))
+17 DO EN^XPAR("USR","PSB VDL IV SORT COLUMN",1,+$PIECE(PSBVDL,"/",7))
+18 DO EN^XPAR("USR","PSB UNIT DOSE COLUMN WIDTHS",1,PSBUDCW)
+19 DO EN^XPAR("USR","PSB IVPB COLUMN WIDTHS",1,PSBPBCW)
+20 DO EN^XPAR("USR","PSB IV COLUMN WIDTHS",1,PSBIVCW)
+21 DO EN^XPAR("USR","PSB GUI DEFAULT PRINTER",1,PSBDEV)
+22 DO EN^XPAR("USR","PSB COVERSHEET VIEWS COL SORT",1,PSBCSRT)
+23 DO EN^XPAR("USR","PSB COVERSHEET V1 COL WIDTHS",1,PSBCV1)
+24 DO EN^XPAR("USR","PSB COVERSHEET V2 COL WIDTHS",1,PSBCV2)
+25 DO EN^XPAR("USR","PSB COVERSHEET V3 COL WIDTHS",1,PSBCV3)
+26 DO EN^XPAR("USR","PSB COVERSHEET V4 COL WIDTHS",1,PSBCV4)
+27 SET RESULTS(0)="1^Parameters Saved"
+28 QUIT
+29 ;
INST(RESULTS,PSBACC,PSBVER) ;
+1 ;
+2 ; RPC: PSB INSTRUCTOR
+3 ; Descr:
+4 ; Used by frmInstructor to validate an instructor(s) at
+5 ; the client via encrypted A/V Code.
+6 ;
+7 SET PSBACC=$$DECRYP^XUSRB1(PSBACC)
+8 SET PSBVER=$$DECRYP^XUSRB1(PSBVER)
+9 SET PSBINST=$$CHECKAV^XUSRB(PSBACC_";"_PSBVER)
+10 IF PSBINST<1
SET RESULTS(0)="-1^Invalid Instructor Sign-On"
KILL PSBINST
QUIT
+11 IF '$DATA(^XUSEC("PSB INSTRUCTOR",PSBINST))
SET RESULTS(0)="-1^Instructor doesn't have authority"
KILL PSBINST
QUIT
+12 SET PSBINST(0)=$$GET1^DIQ(200,PSBINST_",",.01)
+13 SET RESULTS(0)=PSBINST_U_PSBINST(0)
+14 QUIT
+15 ;
ESIG(RESULTS,PSBESIG) ;
+1 ;
+2 ; RPC: PSB VALIDATE ESIG
+3 ; Descr: Validate the data in PSBESIG against user (DUZ)
+4 ;
+5 SET PSBDSIG=$PIECE($GET(PSBESIG),U,2)
IF PSBDSIG'=""
SET PSBDSIG=$$DECRYP^XUSRB1(PSBDSIG)
SET PSBESIG=PSBDSIG
+6 IF $GET(PSBESIG)=""
SET RESULTS(0)="-1^Must Supply ESig"
QUIT
+7 SET X=PSBESIG
DO HASH^XUSHSHP
+8 IF X'=$$GET1^DIQ(200,DUZ_",",20.4,"I")
SET RESULTS(0)="-1^Invalid ESig"
+9 IF '$TEST
SET RESULTS(0)="1^ESig Verified"
+10 QUIT
+11 ;
SCANPT(RESULTS,PSBDATA) ; Lookup Pt by Full SSN
+1 ;
+2 ; RPC: PSB SCANPT
+3 ; Descr:
+4 ; File #2 lookup either by full SSN
+5 ; returns -1 on error or patient data
+6 ; Check for Interleave 2 of 5 Check Digit on SSN and remove
+7 ;
+8 NEW DFN
+9 IF "SS"[$PIECE($GET(PSBDATA),"^",3)
Begin DoDot:1
+10 IF $PIECE(PSBDATA,"^")?1"0"9N.U
SET PSBDATA=$EXTRACT(PSBDATA,2,99)
NEW PSBCNT
+11 ; IHS vs VA Agency check for Patient ID info
+12 IF $GET(DUZ("AG"))'="I"
IF $GET(DUZ("AG"))'="V"
SET RESULTS(0)=1
SET RESULTS(1)="-1^Invalid Agency Code - Not IHS or VA"
QUIT
+13 IF $GET(DUZ("AG"))="I"
Begin DoDot:2
+14 SET X=-1
+15 IF $PIECE(PSBDATA,U)?12N
SET X=$$HRCNF^APSPFUNC($PIECE(PSBDATA,U))
+16 IF X'>0
SET RESULTS(0)=1
SET RESULTS(1)="-1^Patient not found or # not 12 digit"
End DoDot:2
+17 IF '$TEST
Begin DoDot:2
+18 IF $PIECE(PSBDATA,U)'?9N.1U
SET RESULTS(0)=1
SET RESULTS(1)="-1^Invalid Patient Lookup"
QUIT
+19 SET X=$$FIND1^DIC(2,"","",$PIECE(PSBDATA,U),"SSN")
+20 IF X<1
SET RESULTS(0)=1
SET RESULTS(1)="-1^Invalid Patient Lookup"
End DoDot:2
+21 IF $GET(RESULTS(1))<0
QUIT
+22 ;
+23 SET (DFN,RESULTS(1),PSBDFN)=X
+24 SET PSBICN=$$GETICN^MPIF001(PSBDFN)
IF +PSBICN=-1
SET PSBICN=""
End DoDot:1
IF RESULTS(1)<0
QUIT
+25 IF $GET(DFN)']""
Begin DoDot:1
+26 ; CCOW !
+27 IF "DF"[$PIECE($GET(PSBDATA),"^",3)
SET PSBDFN=$PIECE($GET(PSBDATA),"^")
SET PSBICN=$$GETICN^MPIF001(PSBDFN)
IF +PSBICN=-1
SET PSBICN=""
SET RESULTS(0)=1
SET RESULTS(1)="-1^Cannot find ICN via DFN"
+28 IF "IC"[$PIECE($GET(PSBDATA),"^",3)
SET PSBICN=$PIECE($GET(PSBDATA),"^")
SET PSBDFN=$$GETDFN^MPIF001(PSBICN)
IF +PSBDFN=-1
SET PSBDFN=""
SET RESULTS(0)=1
SET RESULTS(1)="-1^Cannot find DFN via ICN"
QUIT
+29 SET (DFN,RESULTS(1))=PSBDFN
+30 ;
End DoDot:1
IF +PSBDFN'>0
QUIT
+31 KILL VADM,VAIN
+32 DO DEM^VADPT
DO IN5^VADPT
+33 IF ('$PIECE(PSBDATA,U,2))&('VAIP(13)&'VADM(6))
SET RESULTS(0)=1
SET RESULTS(1)="-1^Patient has been DISCHARGED"
IF ($PIECE($GET(PSBDATA),U,3)'["IC")&($PIECE($GET(PSBDATA),U,3)'["DF")
KILL VAIP,VADM,VA
QUIT
+34 IF ('$PIECE(PSBDATA,U,2))&(VADM(6)'="")
SET RESULTS(0)=1
SET RESULTS(1)="-1^"_"This patient died "_$TRANSLATE($PIECE(VADM(6),U,2),"@"," ")
IF ($PIECE($GET(PSBDATA),U,3)'["IC")&($PIECE($GET(PSBDATA),U,3)'["DF")
KILL VAIP,VADM,VA
QUIT
+35 SET RESULTS(1)=PSBDFN
+36 FOR X=1,3,4,5
SET RESULTS(X+1)=$GET(VADM(X))
+37 ; IHS/VA - use VA("PID") instead of VADM(2) for Pat ID
+38 SET RESULTS(3)=$TRANSLATE(VA("PID"),"-")_U_VA("PID")
+39 FOR X=3,4,5,6,7,8,9,10,11
SET RESULTS(X+4)=$GET(VAIP(X))
+40 ;
+41 ; IHS/MSC/PLS - 03/27/06 - Changed to call PCC Vitals based on
+42 ; parameter flag DUZ("AG")="I" and PCC Vitals package usage
+43 ; flag "BEHOVM USE VMSR"=1
+44 ;
+45 IF $GET(DUZ("AG"))="I"
IF $$GET^XPAR("ALL","BEHOVM USE VMSR")
Begin DoDot:1
+46 SET X=+$PIECE($$VITAL^APSPFUNC(DFN,"HT"),U,2)
SET X=$$VITCHT^APSPFUNC(X)\1
SET PSBHDR("HEIGHT")=$SELECT(X:X_"cm",1:"*")
+47 SET X=+$PIECE($$VITAL^APSPFUNC(DFN,"WT"),U,2)
SET X=$$VITCWT^APSPFUNC(X)\1
SET PSBHDR("WEIGHT")=$SELECT(X:X_"kg",1:"*")
End DoDot:1
+48 IF '$TEST
Begin DoDot:1
+49 SET GMRVSTR="HT"
DO EN6^GMRVUTL
+50 SET X=+$PIECE(X,U,8)
IF X
SET X=X*2.54\1
SET PSBHDR("HEIGHT")=$SELECT(X:X_"cm",1:"*")
+51 SET GMRVSTR="WT"
DO EN6^GMRVUTL
+52 SET X=+$PIECE(X,U,8)
SET X=$JUSTIFY(X/2.2,0,2)
SET PSBHDR("WEIGHT")=$SELECT(X:X_"kg",1:"*")
End DoDot:1
+53 ;
+54 SET $PIECE(RESULTS(9),U,3)=$$GET1^DIQ(42,$PIECE(RESULTS(9),U)_",",44,"I")_"^"_$$GET1^DIQ(42,$PIECE(RESULTS(9),U)_",",44)
+55 SET RESULTS(16)=PSBHDR("HEIGHT")
+56 SET RESULTS(17)=PSBHDR("WEIGHT")
+57 SET GMRA="0^0^111"
DO EN1^GMRADPT
+58 IF $ORDER(GMRAL(0))
SET RESULTS(18)=1
+59 IF '$TEST
SET RESULTS(18)=0
+60 ; Means Tst
+61 DO GUIMTD^DPTLK6(.PSBDATA,PSBDFN)
+62 SET RESULTS(19)=+$GET(PSBDATA(1))_U_$GET(PSBDATA(2))_U_$GET(PSBDATA(3))
+63 SET PSBICN=$$GETICN^MPIF001(PSBDFN)
IF +PSBICN=-1
SET PSBICN=""
+64 SET RESULTS(20)=PSBICN
+65 SET RESULTS(21)=""
SET RESULTS(0)=21
+66 IF VADM(6)'=""
SET RESULTS(21)="This patient died "_$TRANSLATE($PIECE(VADM(6),U,2),"@"," ")
+67 IF ('VAIP(13))&('VADM(6))
SET RESULTS(21)="Patient has been DISCHARGED"
+68 SET (RESULTS(0),PSBCNT)=22
+69 SET RESULTS(PSBCNT)=""
+70 FOR PSBINDX=1:1:($$GETACT^DGPFAPI(PSBDFN,.PSBPTFLG))
Begin DoDot:1
+71 IF '$DATA(PSBPTFLG)
QUIT
IF '$DATA(@(PSBPTFLG_"(PSBINDX,""FLAG"")"))
QUIT
SET PSBPFLAG="PATFLG"
SET $PIECE(PSBPFLAG,U,2)=$PIECE(@(PSBPTFLG_"(PSBINDX,""FLAG"")"),"^",2)
+72 SET $PIECE(PSBPFLAG,U,3)=PSBINDX
SET PSBCNT=21+PSBINDX
SET RESULTS(PSBCNT)=PSBPFLAG
End DoDot:1
+73 SET RESULTS(0)=PSBCNT
+74 IF $DATA(PSBPTFLG)
KILL @PSBPTFLG
+75 KILL VAIP,VADM,VA
+76 QUIT
+77 ;
MAX(RESULTS,PSBDAYS) ;
+1 ;
+2 ; RPC: PSB MAXDAYS ; Max days user view/print MAH
+3 ;
+4 SET X=$ORDER(^ORD(101.24,"B","ORRP BCMA MAH",""))
+5 SET RESULTS(0)=$$GET1^DIQ(101.24,X_",",.42)
+6 QUIT
+7 ;
NWLIST(RESULTS,DUMMY) ; ward list - NURS LOCATION, file 211.4
+1 ;
+2 ; RPC: PSB NURS WARDLIST
+3 ;
+4 KILL ^TMP("PSB",$JOB)
+5 SET PSBIEN=0
FOR
SET PSBIEN=$ORDER(^NURSF(211.4,PSBIEN))
IF PSBIEN'?.N
QUIT
Begin DoDot:1
+6 SET ^TMP("PSB",$JOB,$$GET1^DIQ(211.4,PSBIEN_",",.01)_" [NURS UNIT]")=PSBIEN
+7 SET PSBX=0
FOR
SET PSBX=$ORDER(^NURSF(211.4,PSBIEN,3,PSBX))
IF PSBX=""
QUIT
Begin DoDot:2
+8 SET PSBWIEN=$PIECE(^NURSF(211.4,PSBIEN,3,PSBX,0),"^")
+9 IF $$GET1^DIQ(42,PSBWIEN_",",.01)]""
SET ^TMP("PSB",$JOB,$$GET1^DIQ(42,PSBWIEN_",",.01)_" [MAS WARD]")=PSBIEN
End DoDot:2
End DoDot:1
+10 SET RESULTS(0)=0
+11 SET X=""
FOR
SET X=$ORDER(^TMP("PSB",$JOB,X))
IF X=""
QUIT
Begin DoDot:1
+12 SET RESULTS(0)=RESULTS(0)+1
+13 SET RESULTS(RESULTS(0))=^TMP("PSB",$JOB,X)_U_X_U_$SELECT(($$GET1^DIQ(211.4,^TMP("PSB",$JOB,X)_",",1)="ACTIVE")&($$GET1^DIQ(211.4,^TMP("PSB",$JOB,X)_",",1.5)'="**INACTIVE**"):"1",1:"0")
End DoDot:1
+14 KILL ^TMP("PSB",$JOB)
+15 QUIT
+16 ;
VITALS(RESULTS,DFN) ;Vitals API
+1 ;
+2 ; RPC PSB VITALS
+3 ;
+4 ;Retrieve vitals from either the PCC V Measurment file or VA Vitals
+5 ; file. Based on agency code = "I" & Vitals package flag=1 for the
+6 ; PCC V Measurement file or "V" for the VA Vitals file.
+7 ;
+8 IF $GET(DUZ("AG"))="I"
IF $$GET^XPAR("ALL","BEHOVM USE VMSR")
Begin DoDot:1
+9 KILL RESULTS
+10 NEW PSBNOW,PSBSTRT,VITS,CNT,VTYP,LP,DATA,NODE,XREF
+11 SET XREF("TMP")="T"
SET XREF("PU")="P"
SET XREF("BP")="BP"
SET XREF("RS")="R"
SET XREF("PA")="PN"
+12 SET PSBNOW=$$NOW^XLFDT()
SET PSBSTRT=$$FMADD^XLFDT(PSBNOW,-168)
+13 SET CNT=0
FOR LP="TMP","PU","RS","BP","PA"
Begin DoDot:2
+14 ;IHS/MSC/PLS - 1/16/08 - Fixed IEN lookup
+15 ;S VTYP=$$FIND1^DIC(9999999.07,"","BX",LP)
+16 SET VTYP=+$$VCTL^BEHOVM(LP)
+17 IF VTYP
SET VITS(CNT+1)=VTYP
SET CNT=CNT+1
End DoDot:2
+18 DO GRID^BEHOVM(.DATA,DFN,PSBNOW,$$FMADD^XLFDT(PSBNOW,"",-168),0,.VITS)
+19 ;BUILD RESULTS ARRAY
+20 ; No Results
IF '$PIECE(@DATA@(0),U,3)
Begin DoDot:2
+21 SET RESULTS(0)=1
SET RESULTS(1)="No Vitals to report"
End DoDot:2
QUIT
+22 SET (CNT,LP)=0
FOR
SET LP=$ORDER(@DATA@("R",LP))
IF 'LP
QUIT
Begin DoDot:2
+23 SET NODE=@DATA@("R",LP)
+24 SET RESULTS(CNT+1)=XREF($PIECE(@DATA@(0,$PIECE(NODE,U,2)),U,4))_U_$EXTRACT($$GET1^DIQ(9000010.01,$PIECE(NODE,U,5),1201,"I"),1,12)_U_DFN_U_$PIECE(NODE,U,3)
+25 SET CNT=CNT+1
End DoDot:2
+26 SET RESULTS(0)=CNT
End DoDot:1
QUIT
+27 ;
+28 KILL RESULTS
+29 NEW PSBSTRT,PSBSTOP,PSBNOW
+30 SET PSBDFN=DFN
SET GMRVSTR="T;P;R;BP;PN"
+31 DO NOW^%DTC
SET PSBNOW=%
SET PSBSTRT=$$FMADD^XLFDT(PSBNOW,"",-168)
SET PSBSTOP=PSBNOW
SET GMRVSTR(0)=PSBSTRT_U_PSBSTOP_U_4_U
+32 KILL ^UTILITY($JOB,"GMRVD")
+33 DO EN1^GMRVUT0
+34 SET PSBCNT=1
+35 IF '$DATA(^UTILITY($JOB,"GMRVD"))
SET RESULTS(0)=PSBCNT
SET RESULTS(PSBCNT)="No Vitals to report"
QUIT
+36 SET PSBTYP=""
+37 FOR
SET PSBTYP=$ORDER(^UTILITY($JOB,"GMRVD",PSBTYP))
IF PSBTYP=""
QUIT
Begin DoDot:1
+38 SET PSBRDT=""
+39 FOR
SET PSBRDT=$ORDER(^UTILITY($JOB,"GMRVD",PSBTYP,PSBRDT))
IF PSBRDT=""
QUIT
Begin DoDot:2
+40 SET PSBIEN=""
+41 FOR
SET PSBIEN=$ORDER(^UTILITY($JOB,"GMRVD",PSBTYP,PSBRDT,PSBIEN))
IF PSBIEN=""
QUIT
Begin DoDot:3
+42 SET PSBDATA=($GET(^UTILITY($JOB,"GMRVD",PSBTYP,PSBRDT,PSBIEN)))
+43 SET RESULTS(PSBCNT)=PSBTYP_U_$PIECE(PSBDATA,U,1,2)_U_$PIECE(PSBDATA,U,8)
+44 SET PSBCNT=PSBCNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+45 SET RESULTS(0)=PSBCNT-1
+46 KILL ^UTILITY($JOB,"GMRVD"),GMRBSTR,PSBDFN,PSBTYPE,PSBDATA,PSBCNT
+47 QUIT
