PSBRPC ;BIRMINGHAM/EFC - BCMA RPC BROKER CALLS ; 19 Jul 2013 12:34 PM
;;3.0;BAR CODE MED ADMIN;**6,3,4,13,32,28,42,58,66,70,76,86**;Mar 2004;Build 5
;Per VA Directive 6402, 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
; File #40.8/2817
; $$GET^XPAR/2263
; $$GET1^DIQ/2056
; XMD/10070
; RPCVIC^DPTLK/5888
; File #42/1377
;
;*70 - remove restriction of allowing BCMA to view Discharged
; patients
; - add Tag GETLIST, RPC:PSB CLINICLIST (returns requested
; clinic names)
; - add to User load & User save 2 new varaibles, 1 for Last
; Order mode and other for Last Clinic name search text
; - 1489: Blended PSB*3*66 with PSB*3*70
; - Add Registration API call to support VIC 4.0 cards
;
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"
N DVIEN S DVIEN=$O(^DG(40.8,"AD",RESULTS(7),""))
S RESULTS(7)=RESULTS(7)_U_$P($$SITE^VASITE(DT,DVIEN),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
S RESULTS(28)=$$GET^XPAR("USR","PSB ORDER MODE") ;*70
S RESULTS(29)=$$GET^XPAR("USR","PSB CLINIC SEARCH") ;*70
Q
;
USRSAVE(RESULTS,PSBWIN,PSBVDL,PSBUDCW,PSBPBCW,PSBIVCW,PSBDEV,PSBCSRT,PSBCV1,PSBCV2,PSBCV3,PSBCV4,PSBORMODE,PSBCLSRCH) ;
;
; 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)
D EN^XPAR("USR","PSB ORDER MODE",1,PSBORMODE) ;*70
D EN^XPAR("USR","PSB CLINIC SEARCH",1,PSBCLSRCH) ;*70
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,PSBWARD,PSBHDR ;[*70-1489]
I "SS"[$P($G(PSBDATA),"^",3) D Q:RESULTS(1)<0
.I $P($G(PSBDATA),"^")["`" S RESULTS(0)=1,RESULTS(1)="-1^Invalid Patient Lookup" Q ;Add code to disallow "`", PSB*3*86
.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
..;*70 Implement VIC 4.0 cards. Old Bar code with SSN still accepted
..S DPTDATA=$P(PSBDATA,U) ;,DPTDATA=$TR(DPTDATA,"|","^") ; ST - $TR not needed
..D RPCVIC^DPTLK(.DFN,DPTDATA)
..I DFN=""!(DFN<0) S:$P(PSBDATA,U)?9N.1U DFN=$$FIND1^DIC(2,"","",DPTDATA,"SSN") S:'DFN DFN=-1 ;old SSN lookup, added full SSN check, PSB*3*76
.I DFN=-1 S RESULTS(0)=1,RESULTS(1)="-1^Invalid Patient Lookup"
.;*End *70 Implement VIC 4.0 cards.
.Q:$G(RESULTS(1))<0
.S (RESULTS(1),PSBDFN)=DFN
.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
.;
;*70 get registration owned data for admit date or deceased date
N VADM,VA,VAIN,VAIP,VA D DEM^VADPT,IN5^VADPT
N QUIT ;*70
; remove discharge test ;*70
; if patient is deceased ;*70
S QUIT=0
I VADM(6)'="" D Q:QUIT
.S RESULTS(0)=1
.S RESULTS(1)="-1^"_"This patient died "_$TR($P(VADM(6),U,2),"@"," ")
.D:'$P(PSBDATA,U,2) ;not read only/limited mode
..I ($P($G(PSBDATA),U,3)'["IC")&($P($G(PSBDATA),U,3)'["DF") S QUIT=1
;
; continue to load patient data
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=$J((X*2.54),3,0) S PSBHDR("HEIGHT")=$S(X:X_"cm",1:"*") ;Rounding correction, PSB*3*76
.S GMRVSTR="WT" D EN6^GMRVUTL
.S X=+$P(X,U,8) S X=$J(X/2.20462262,0,2) S PSBHDR("WEIGHT")=$S(X:X_"kg",1:"*") ;Rounding to more actuate calculation, PSB*3*86
;
S $P(RESULTS(9),U,3)=$$GET1^DIQ(42,$P(RESULTS(9),U)_",",44,"I")_"^"_$$GET1^DIQ(42,$P(RESULTS(9),U)_",",44)
S PSBWARD=$P($G(RESULTS(9)),U,2) D IVBAGPAR(PSBWARD) ;[*70-1489]
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 not Admitted" ;*70
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
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
..S VTYP=$$FIND1^DIC(9999999.07,"","BX",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
; ;[*70-1489]...start
IVBAGPAR(PSBWARD) ; Send Mailman Message to owners of PSB Manager Key if IV Bag Parameters are not set for this Ward
Q:PSBWARD=""
N PSBCSTR,PSBWDIV,PSB,PSBIVT,PSBFLAG,PSBSTNMB,PSBINST,PSBIVPAR
S PSBCSTR="^ADDITIVE^STRENGTH^BOTTLE^SOLUTION^VOLUME^INFUSION RATE^MED ROUTE^SCHEDULE^ADMIN TIME^REMARKS^OTHER PRINT INFO^PROVIDER^START DATE/TIME^STOP DATE/TIME^PROVIDER COMMENTS"
S PSBWARD=$O(^DIC(42,"B",PSBWARD,""))
S PSBWDIV=$$GET1^DIQ(42,PSBWARD_",",.015,"I")
I $G(PSBWDIV)']"" S PSBWDIV="DIV"
E S PSBWDIV=$P($$SITE^VASITE(DT,PSBWDIV),U,1),PSBWDIV="DIV.`"_PSBWDIV
F PSBIVT="A","P","H","S","C" S PSBIVPAR=PSBIVT D
.F PSBX=2:1 Q:$P(PSBCSTR,U,PSBX)="" S PSBIVPAR=PSBIVPAR_U_$P($P($$GET^XPAR(PSBWDIV,"PSBIV "_$P(PSBCSTR,U,PSBX),PSBIVT,"B"),U,2),"-",1),^TMP("PSBWARD",PSBX,PSBIVT)=PSBIVPAR I $P(PSBIVPAR,U,PSBX)="" S PSBFLAG=""
S PSBSTNMB=$$GET1^DIQ(4,($P(PSBWDIV,"`",2)),99)
S:PSBSTNMB="" PSBINST=$$GET1^DIQ(4,($P(PSBWDIV,"`",2)),.01)
I $D(PSBFLAG) D
.N XMDUZ,XMSUB,XMTEXT,XMY,PSBERR,PSBMG1,PSBCNT
.S PSBCNT=1
.I PSBSTNMB'="" S XMSUB="ACTION NEEDED! DIV "_PSBSTNMB_" IV PARAMS NOT DEFINED"
.E S XMSUB=" ACTION NEEDED! INSTITUTION IV PARAMS NOT DEFINED"
.S XMDUZ="BCMA PARAMETERS"
.S XMTEXT="PSBERR("
.S PSBMG1="" F S PSBMG1=$O(^XUSEC("PSB MANAGER",PSBMG1)) Q:PSBMG1="" S XMY(PSBMG1)=""
.S PSBERR(PSBCNT)="The IV Bag Parameters are not defined",PSBCNT=PSBCNT+1
.S PSBERR(PSBCNT)="for Ward '"_$$GET1^DIQ(42,PSBWARD,.01)_"', which is associated ",PSBCNT=PSBCNT+1
.I PSBSTNMB'="" S PSBERR(PSBCNT)="with Facility Division #"_PSBSTNMB_" and needs to",PSBCNT=PSBCNT+1
.E S PSBERR(PSBCNT)="with Institution '"_PSBINST_"' and needs to",PSBCNT=PSBCNT+1
.S PSBERR(PSBCNT)="be set immediately!",PSBCNT=PSBCNT+1
.S PSBERR(PSBCNT)="",PSBCNT=PSBCNT+1
.I PSBSTNMB="" S PSBERR(PSBCNT)="A Station Number is not defined for",PSBCNT=PSBCNT+1 D
..S PSBERR(PSBCNT)="Institution '"_PSBINST_"'.",PSBCNT=PSBCNT+1
..S PSBERR(PSBCNT)="Please log a ticket with the VA Service Desk!!",PSBCNT=PSBCNT+1
..S PSBERR(PSBCNT)="Once a Station Number has been assigned,",PSBCNT=PSBCNT+1
..S PSBERR(PSBCNT)="please complete the following steps:",PSBCNT=PSBCNT+1
.S:PSBSTNMB'="" PSBERR(PSBCNT)="To do so: ",PSBCNT=PSBCNT+1
.S PSBERR(PSBCNT)="",PSBCNT=PSBCNT+1
.S PSBERR(PSBCNT)="1. Log into the BCMA Parameters GUI.",PSBCNT=PSBCNT+1
.S PSBERR(PSBCNT)="2. Select Facility Division Number "_PSBSTNMB_".",PSBCNT=PSBCNT+1
.S PSBERR(PSBCNT)="3. Set IV Parameters desired for this Division.",PSBCNT=PSBCNT+1
.S PSBERR(PSBCNT)="4. Select OK.",PSBCNT=PSBCNT+1
.S PSBERR(PSBCNT)="",PSBCNT=PSBCNT+1
.S PSBERR(PSBCNT)="Please log a ticket with the ",PSBCNT=PSBCNT+1
.S PSBERR(PSBCNT)="VA Service Desk if you need assistance.",PSBCNT=PSBCNT+1
.D ^XMD
Q
; ;[*70-1489]...end
GETLIST(RESULTS,PRE,CONTAIN) ; Get Clinics by name ;*70
N LIN
K ^TMP("PSBCLIN",$J)
S RESULTS=$NAME(^TMP("PSBCLIN",$J))
S LIN=0 D CLNLIST(PRE,CONTAIN,.LIN)
;set total rec counter
I $D(^TMP("PSBCLIN",$J)) D
. S ^TMP("PSBCLIN",$J,0)=LIN
E D
. S ^TMP("PSBCLIN",$J,0)=1
. S ^TMP("PSBCLIN",$J,1)="-1^Invalid Clinic Lookup"
Q
;
CLNLIST(PR,CON,LN) ;return Clinic list in TMP by name *70
N QQ,NODE0,INACTDT,NAME,REACTDT
F QQ=0:0 S QQ=$O(^SC(QQ)) Q:'QQ D
. S NODE0=$G(^SC(QQ,0)) Q:NODE0=""
. Q:$P(NODE0,U,3)'="C" ;type Clinic
. S INACTDT=+$P($G(^SC(QQ,"I")),U) ;inactive date
. S REACTDT=+$P($G(^SC(QQ,"I")),U,2)
. I INACTDT,INACTDT<DT I 'REACTDT!(REACTDT&((REACTDT<INACTDT)!(REACTDT>DT))) Q
. S NAME=$P(NODE0,U)
. I PR]"" D
.. I $E(NAME,1,$L(PR))=PR,NAME[CON D
... S LN=LN+1,^TMP("PSBCLIN",$J,LN)=NAME
. E D
.. I NAME[CON D
... S LN=LN+1,^TMP("PSBCLIN",$J,LN)=NAME
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBRPC 17564 printed Oct 16, 2024@17:41:58 Page 2
PSBRPC ;BIRMINGHAM/EFC - BCMA RPC BROKER CALLS ; 19 Jul 2013 12:34 PM
+1 ;;3.0;BAR CODE MED ADMIN;**6,3,4,13,32,28,42,58,66,70,76,86**;Mar 2004;Build 5
+2 ;Per VA Directive 6402, 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 ; File #40.8/2817
+12 ; $$GET^XPAR/2263
+13 ; $$GET1^DIQ/2056
+14 ; XMD/10070
+15 ; RPCVIC^DPTLK/5888
+16 ; File #42/1377
+17 ;
+18 ;*70 - remove restriction of allowing BCMA to view Discharged
+19 ; patients
+20 ; - add Tag GETLIST, RPC:PSB CLINICLIST (returns requested
+21 ; clinic names)
+22 ; - add to User load & User save 2 new varaibles, 1 for Last
+23 ; Order mode and other for Last Clinic name search text
+24 ; - 1489: Blended PSB*3*66 with PSB*3*70
+25 ; - Add Registration API call to support VIC 4.0 cards
+26 ;
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 NEW DVIEN
SET DVIEN=$ORDER(^DG(40.8,"AD",RESULTS(7),""))
+25 SET RESULTS(7)=RESULTS(7)_U_$PIECE($$SITE^VASITE(DT,DVIEN),U,3)
+26 IF $TEXT(PROD^XUPROD)]""
SET RESULTS(7)=RESULTS(7)_U_$$PROD^XUPROD(1)
+27 SET RESULTS(9)=+$$GET^XPAR("DIV","PSB ADMIN ESIG")
+28 SET RESULTS(10)=+$$GET^XPAR("DIV","PSB ONLINE")
+29 SET RESULTS(11)=$GET(DTIME,300)
+30 SET RESULTS(12)=$$GET^XPAR("USR","PSB UNIT DOSE COLUMN WIDTHS")
+31 SET RESULTS(13)=$JOB_"^"_$$BASE^XLFUTL($JOB,10,16)
+32 SET RESULTS(14)=$$GET^XPAR("USR","PSB IVPB COLUMN WIDTHS")
+33 SET RESULTS(15)=$$GET^XPAR("USR","PSB IV COLUMN WIDTHS")
+34 SET RESULTS(16)=$$GET^XPAR("USR","PSB PRINTER USER DEFAULT")
+35 SET RESULTS(17)=$$GET^XPAR("USR","PSB GUI DEFAULT PRINTER")
+36 SET RESULTS(18)=$SELECT($DATA(^XUSEC("PSB READ ONLY",DUZ)):1,1:0)
+37 SET RESULTS(19)=$$GET^XPAR("USR","PSB COVERSHEET VIEWS COL SORT")
+38 SET RESULTS(20)=$$GET^XPAR("USR","PSB COVERSHEET V1 COL WIDTHS")
+39 SET RESULTS(21)=$$GET^XPAR("USR","PSB COVERSHEET V2 COL WIDTHS")
+40 SET RESULTS(22)=$$GET^XPAR("USR","PSB COVERSHEET V3 COL WIDTHS")
+41 SET RESULTS(23)=$$GET^XPAR("USR","PSB COVERSHEET V4 COL WIDTHS")
+42 SET RESULTS(24)=$SELECT($DATA(^XUSEC("PSB UNABLE TO SCAN",DUZ)):1,1:0)
+43 SET RESULTS(25)=$$GET^XPAR("DIV","PSB 5 RIGHTS UNITDOSE")
+44 SET RESULTS(26)=$$GET^XPAR("DIV","PSB 5 RIGHTS IV")
+45 ;IHS/MSC/PLS
SET RESULTS(27)=$GET(DUZ("AG"))
+46 ;*70
SET RESULTS(28)=$$GET^XPAR("USR","PSB ORDER MODE")
+47 ;*70
SET RESULTS(29)=$$GET^XPAR("USR","PSB CLINIC SEARCH")
+48 QUIT
+49 ;
USRSAVE(RESULTS,PSBWIN,PSBVDL,PSBUDCW,PSBPBCW,PSBIVCW,PSBDEV,PSBCSRT,PSBCV1,PSBCV2,PSBCV3,PSBCV4,PSBORMODE,PSBCLSRCH) ;
+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 ;*70
DO EN^XPAR("USR","PSB ORDER MODE",1,PSBORMODE)
+28 ;*70
DO EN^XPAR("USR","PSB CLINIC SEARCH",1,PSBCLSRCH)
+29 SET RESULTS(0)="1^Parameters Saved"
+30 QUIT
+31 ;
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 ;[*70-1489]
NEW DFN,PSBWARD,PSBHDR
+9 IF "SS"[$PIECE($GET(PSBDATA),"^",3)
Begin DoDot:1
+10 ;Add code to disallow "`", PSB*3*86
IF $PIECE($GET(PSBDATA),"^")["`"
SET RESULTS(0)=1
SET RESULTS(1)="-1^Invalid Patient Lookup"
QUIT
+11 if $PIECE(PSBDATA,"^")?1"0"9N.U
SET PSBDATA=$EXTRACT(PSBDATA,2,99)
NEW PSBCNT
+12 ; IHS vs VA Agency check for Patient ID info
+13 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
+14 IF $GET(DUZ("AG"))="I"
Begin DoDot:2
+15 SET X=-1
+16 IF $PIECE(PSBDATA,U)?12N
SET X=$$HRCNF^APSPFUNC($PIECE(PSBDATA,U))
+17 if X'>0
SET RESULTS(0)=1
SET RESULTS(1)="-1^Patient not found or # not 12 digit"
End DoDot:2
+18 IF '$TEST
Begin DoDot:2
+19 ;*70 Implement VIC 4.0 cards. Old Bar code with SSN still accepted
+20 ;,DPTDATA=$TR(DPTDATA,"|","^") ; ST - $TR not needed
SET DPTDATA=$PIECE(PSBDATA,U)
+21 DO RPCVIC^DPTLK(.DFN,DPTDATA)
+22 ;old SSN lookup, added full SSN check, PSB*3*76
IF DFN=""!(DFN<0)
if $PIECE(PSBDATA,U)?9N.1U
SET DFN=$$FIND1^DIC(2,"","",DPTDATA,"SSN")
if 'DFN
SET DFN=-1
End DoDot:2
+23 IF DFN=-1
SET RESULTS(0)=1
SET RESULTS(1)="-1^Invalid Patient Lookup"
+24 ;*End *70 Implement VIC 4.0 cards.
+25 if $GET(RESULTS(1))<0
QUIT
+26 SET (RESULTS(1),PSBDFN)=DFN
+27 SET PSBICN=$$GETICN^MPIF001(PSBDFN)
IF +PSBICN=-1
SET PSBICN=""
End DoDot:1
if RESULTS(1)<0
QUIT
+28 IF $GET(DFN)']""
Begin DoDot:1
+29 ; CCOW !
+30 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"
+31 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
+32 SET (DFN,RESULTS(1))=PSBDFN
+33 ;
End DoDot:1
if +PSBDFN'>0
QUIT
+34 ;*70 get registration owned data for admit date or deceased date
+35 NEW VADM,VA,VAIN,VAIP,VA
DO DEM^VADPT
DO IN5^VADPT
+36 ;*70
NEW QUIT
+37 ; remove discharge test ;*70
+38 ; if patient is deceased ;*70
+39 SET QUIT=0
+40 IF VADM(6)'=""
Begin DoDot:1
+41 SET RESULTS(0)=1
+42 SET RESULTS(1)="-1^"_"This patient died "_$TRANSLATE($PIECE(VADM(6),U,2),"@"," ")
+43 ;not read only/limited mode
if '$PIECE(PSBDATA,U,2)
Begin DoDot:2
+44 IF ($PIECE($GET(PSBDATA),U,3)'["IC")&($PIECE($GET(PSBDATA),U,3)'["DF")
SET QUIT=1
End DoDot:2
End DoDot:1
if QUIT
QUIT
+45 ;
+46 ; continue to load patient data
+47 SET RESULTS(1)=PSBDFN
+48 FOR X=1,3,4,5
SET RESULTS(X+1)=$GET(VADM(X))
+49 ; IHS/VA - use VA("PID") instead of VADM(2) for Pat ID
+50 SET RESULTS(3)=$TRANSLATE(VA("PID"),"-")_U_VA("PID")
+51 FOR X=3,4,5,6,7,8,9,10,11
SET RESULTS(X+4)=$GET(VAIP(X))
+52 ;
+53 ; IHS/MSC/PLS - 03/27/06 - Changed to call PCC Vitals based on
+54 ; parameter flag DUZ("AG")="I" and PCC Vitals package usage
+55 ; flag "BEHOVM USE VMSR"=1
+56 ;
+57 IF $GET(DUZ("AG"))="I"
IF $$GET^XPAR("ALL","BEHOVM USE VMSR")
Begin DoDot:1
+58 SET X=+$PIECE($$VITAL^APSPFUNC(DFN,"HT"),U,2)
SET X=$$VITCHT^APSPFUNC(X)\1
SET PSBHDR("HEIGHT")=$SELECT(X:X_"cm",1:"*")
+59 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
+60 IF '$TEST
Begin DoDot:1
+61 SET GMRVSTR="HT"
DO EN6^GMRVUTL
+62 ;Rounding correction, PSB*3*76
SET X=+$PIECE(X,U,8)
if X
SET X=$JUSTIFY((X*2.54),3,0)
SET PSBHDR("HEIGHT")=$SELECT(X:X_"cm",1:"*")
+63 SET GMRVSTR="WT"
DO EN6^GMRVUTL
+64 ;Rounding to more actuate calculation, PSB*3*86
SET X=+$PIECE(X,U,8)
SET X=$JUSTIFY(X/2.20462262,0,2)
SET PSBHDR("WEIGHT")=$SELECT(X:X_"kg",1:"*")
End DoDot:1
+65 ;
+66 SET $PIECE(RESULTS(9),U,3)=$$GET1^DIQ(42,$PIECE(RESULTS(9),U)_",",44,"I")_"^"_$$GET1^DIQ(42,$PIECE(RESULTS(9),U)_",",44)
+67 ;[*70-1489]
SET PSBWARD=$PIECE($GET(RESULTS(9)),U,2)
DO IVBAGPAR(PSBWARD)
+68 SET RESULTS(16)=PSBHDR("HEIGHT")
+69 SET RESULTS(17)=PSBHDR("WEIGHT")
+70 SET GMRA="0^0^111"
DO EN1^GMRADPT
+71 IF $ORDER(GMRAL(0))
SET RESULTS(18)=1
+72 IF '$TEST
SET RESULTS(18)=0
+73 ; Means Tst
+74 DO GUIMTD^DPTLK6(.PSBDATA,PSBDFN)
+75 SET RESULTS(19)=+$GET(PSBDATA(1))_U_$GET(PSBDATA(2))_U_$GET(PSBDATA(3))
+76 SET PSBICN=$$GETICN^MPIF001(PSBDFN)
IF +PSBICN=-1
SET PSBICN=""
+77 SET RESULTS(20)=PSBICN
+78 SET RESULTS(21)=""
SET RESULTS(0)=21
+79 if VADM(6)'=""
SET RESULTS(21)="This patient died "_$TRANSLATE($PIECE(VADM(6),U,2),"@"," ")
+80 ;*70
if ('VAIP(13))&('VADM(6))
SET RESULTS(21)="Patient not Admitted"
+81 SET (RESULTS(0),PSBCNT)=22
+82 SET RESULTS(PSBCNT)=""
+83 FOR PSBINDX=1:1:($$GETACT^DGPFAPI(PSBDFN,.PSBPTFLG))
Begin DoDot:1
+84 if '$DATA(PSBPTFLG)
QUIT
if '$DATA(@(PSBPTFLG_"(PSBINDX,""FLAG"")"))
QUIT
SET PSBPFLAG="PATFLG"
SET $PIECE(PSBPFLAG,U,2)=$PIECE(@(PSBPTFLG_"(PSBINDX,""FLAG"")"),"^",2)
+85 SET $PIECE(PSBPFLAG,U,3)=PSBINDX
SET PSBCNT=21+PSBINDX
SET RESULTS(PSBCNT)=PSBPFLAG
End DoDot:1
+86 SET RESULTS(0)=PSBCNT
+87 IF $DATA(PSBPTFLG)
KILL @PSBPTFLG
+88 QUIT
+89 ;
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 SET VTYP=$$FIND1^DIC(9999999.07,"","BX",LP)
+15 IF VTYP
SET VITS(CNT+1)=VTYP
SET CNT=CNT+1
End DoDot:2
+16 DO GRID^BEHOVM(.DATA,DFN,PSBNOW,$$FMADD^XLFDT(PSBNOW,"",-168),0,.VITS)
+17 ;BUILD RESULTS ARRAY
+18 ; No Results
IF '$PIECE(@DATA@(0),U,3)
Begin DoDot:2
+19 SET RESULTS(0)=1
SET RESULTS(1)="No Vitals to report"
End DoDot:2
QUIT
+20 SET (CNT,LP)=0
FOR
SET LP=$ORDER(@DATA@("R",LP))
if 'LP
QUIT
Begin DoDot:2
+21 SET NODE=@DATA@("R",LP)
+22 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)
+23 SET CNT=CNT+1
End DoDot:2
+24 SET RESULTS(0)=CNT
End DoDot:1
QUIT
+25 ;
+26 KILL RESULTS
+27 NEW PSBSTRT,PSBSTOP,PSBNOW
+28 SET PSBDFN=DFN
SET GMRVSTR="T;P;R;BP;PN"
+29 DO NOW^%DTC
SET PSBNOW=%
SET PSBSTRT=$$FMADD^XLFDT(PSBNOW,"",-168)
SET PSBSTOP=PSBNOW
SET GMRVSTR(0)=PSBSTRT_U_PSBSTOP_U_4_U
+30 KILL ^UTILITY($JOB,"GMRVD")
+31 DO EN1^GMRVUT0
+32 SET PSBCNT=1
+33 IF '$DATA(^UTILITY($JOB,"GMRVD"))
SET RESULTS(0)=PSBCNT
SET RESULTS(PSBCNT)="No Vitals to report"
QUIT
+34 SET PSBTYP=""
+35 FOR
SET PSBTYP=$ORDER(^UTILITY($JOB,"GMRVD",PSBTYP))
if PSBTYP=""
QUIT
Begin DoDot:1
+36 SET PSBRDT=""
+37 FOR
SET PSBRDT=$ORDER(^UTILITY($JOB,"GMRVD",PSBTYP,PSBRDT))
if PSBRDT=""
QUIT
Begin DoDot:2
+38 SET PSBIEN=""
+39 FOR
SET PSBIEN=$ORDER(^UTILITY($JOB,"GMRVD",PSBTYP,PSBRDT,PSBIEN))
if PSBIEN=""
QUIT
Begin DoDot:3
+40 SET PSBDATA=($GET(^UTILITY($JOB,"GMRVD",PSBTYP,PSBRDT,PSBIEN)))
+41 SET RESULTS(PSBCNT)=PSBTYP_U_$PIECE(PSBDATA,U,1,2)_U_$PIECE(PSBDATA,U,8)
+42 SET PSBCNT=PSBCNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+43 SET RESULTS(0)=PSBCNT-1
+44 KILL ^UTILITY($JOB,"GMRVD"),GMRBSTR,PSBDFN,PSBTYPE,PSBDATA,PSBCNT
+45 QUIT
+46 ; ;[*70-1489]...start
IVBAGPAR(PSBWARD) ; Send Mailman Message to owners of PSB Manager Key if IV Bag Parameters are not set for this Ward
+1 if PSBWARD=""
QUIT
+2 NEW PSBCSTR,PSBWDIV,PSB,PSBIVT,PSBFLAG,PSBSTNMB,PSBINST,PSBIVPAR
+3 SET PSBCSTR="^ADDITIVE^STRENGTH^BOTTLE^SOLUTION^VOLUME^INFUSION RATE^MED ROUTE^SCHEDULE^ADMIN TIME^REMARKS^OTHER PRINT INFO^PROVIDER^START DATE/TIME^STOP DATE/TIME^PROVIDER COMMENTS"
+4 SET PSBWARD=$ORDER(^DIC(42,"B",PSBWARD,""))
+5 SET PSBWDIV=$$GET1^DIQ(42,PSBWARD_",",.015,"I")
+6 IF $GET(PSBWDIV)']""
SET PSBWDIV="DIV"
+7 IF '$TEST
SET PSBWDIV=$PIECE($$SITE^VASITE(DT,PSBWDIV),U,1)
SET PSBWDIV="DIV.`"_PSBWDIV
+8 FOR PSBIVT="A","P","H","S","C"
SET PSBIVPAR=PSBIVT
Begin DoDot:1
+9 FOR PSBX=2:1
if $PIECE(PSBCSTR,U,PSBX)=""
QUIT
SET PSBIVPAR=PSBIVPAR_U_$PIECE($PIECE($$GET^XPAR(PSBWDIV,"PSBIV "_$PIECE(PSBCSTR,U,PSBX),PSBIVT,"B"),U,2),"-",1)
SET ^TMP("PSBWARD",PSBX,PSBIVT)=PSBIVPAR
IF $PIECE(PSBIVPAR,U,PSBX)=""
SET PSBFLAG=""
End DoDot:1
+10 SET PSBSTNMB=$$GET1^DIQ(4,($PIECE(PSBWDIV,"`",2)),99)
+11 if PSBSTNMB=""
SET PSBINST=$$GET1^DIQ(4,($PIECE(PSBWDIV,"`",2)),.01)
+12 IF $DATA(PSBFLAG)
Begin DoDot:1
+13 NEW XMDUZ,XMSUB,XMTEXT,XMY,PSBERR,PSBMG1,PSBCNT
+14 SET PSBCNT=1
+15 IF PSBSTNMB'=""
SET XMSUB="ACTION NEEDED! DIV "_PSBSTNMB_" IV PARAMS NOT DEFINED"
+16 IF '$TEST
SET XMSUB=" ACTION NEEDED! INSTITUTION IV PARAMS NOT DEFINED"
+17 SET XMDUZ="BCMA PARAMETERS"
+18 SET XMTEXT="PSBERR("
+19 SET PSBMG1=""
FOR
SET PSBMG1=$ORDER(^XUSEC("PSB MANAGER",PSBMG1))
if PSBMG1=""
QUIT
SET XMY(PSBMG1)=""
+20 SET PSBERR(PSBCNT)="The IV Bag Parameters are not defined"
SET PSBCNT=PSBCNT+1
+21 SET PSBERR(PSBCNT)="for Ward '"_$$GET1^DIQ(42,PSBWARD,.01)_"', which is associated "
SET PSBCNT=PSBCNT+1
+22 IF PSBSTNMB'=""
SET PSBERR(PSBCNT)="with Facility Division #"_PSBSTNMB_" and needs to"
SET PSBCNT=PSBCNT+1
+23 IF '$TEST
SET PSBERR(PSBCNT)="with Institution '"_PSBINST_"' and needs to"
SET PSBCNT=PSBCNT+1
+24 SET PSBERR(PSBCNT)="be set immediately!"
SET PSBCNT=PSBCNT+1
+25 SET PSBERR(PSBCNT)=""
SET PSBCNT=PSBCNT+1
+26 IF PSBSTNMB=""
SET PSBERR(PSBCNT)="A Station Number is not defined for"
SET PSBCNT=PSBCNT+1
Begin DoDot:2
+27 SET PSBERR(PSBCNT)="Institution '"_PSBINST_"'."
SET PSBCNT=PSBCNT+1
+28 SET PSBERR(PSBCNT)="Please log a ticket with the VA Service Desk!!"
SET PSBCNT=PSBCNT+1
+29 SET PSBERR(PSBCNT)="Once a Station Number has been assigned,"
SET PSBCNT=PSBCNT+1
+30 SET PSBERR(PSBCNT)="please complete the following steps:"
SET PSBCNT=PSBCNT+1
End DoDot:2
+31 if PSBSTNMB'=""
SET PSBERR(PSBCNT)="To do so: "
SET PSBCNT=PSBCNT+1
+32 SET PSBERR(PSBCNT)=""
SET PSBCNT=PSBCNT+1
+33 SET PSBERR(PSBCNT)="1. Log into the BCMA Parameters GUI."
SET PSBCNT=PSBCNT+1
+34 SET PSBERR(PSBCNT)="2. Select Facility Division Number "_PSBSTNMB_"."
SET PSBCNT=PSBCNT+1
+35 SET PSBERR(PSBCNT)="3. Set IV Parameters desired for this Division."
SET PSBCNT=PSBCNT+1
+36 SET PSBERR(PSBCNT)="4. Select OK."
SET PSBCNT=PSBCNT+1
+37 SET PSBERR(PSBCNT)=""
SET PSBCNT=PSBCNT+1
+38 SET PSBERR(PSBCNT)="Please log a ticket with the "
SET PSBCNT=PSBCNT+1
+39 SET PSBERR(PSBCNT)="VA Service Desk if you need assistance."
SET PSBCNT=PSBCNT+1
+40 DO ^XMD
End DoDot:1
+41 QUIT
+42 ; ;[*70-1489]...end
GETLIST(RESULTS,PRE,CONTAIN) ; Get Clinics by name ;*70
+1 NEW LIN
+2 KILL ^TMP("PSBCLIN",$JOB)
+3 SET RESULTS=$NAME(^TMP("PSBCLIN",$JOB))
+4 SET LIN=0
DO CLNLIST(PRE,CONTAIN,.LIN)
+5 ;set total rec counter
+6 IF $DATA(^TMP("PSBCLIN",$JOB))
Begin DoDot:1
+7 SET ^TMP("PSBCLIN",$JOB,0)=LIN
End DoDot:1
+8 IF '$TEST
Begin DoDot:1
+9 SET ^TMP("PSBCLIN",$JOB,0)=1
+10 SET ^TMP("PSBCLIN",$JOB,1)="-1^Invalid Clinic Lookup"
End DoDot:1
+11 QUIT
+12 ;
CLNLIST(PR,CON,LN) ;return Clinic list in TMP by name *70
+1 NEW QQ,NODE0,INACTDT,NAME,REACTDT
+2 FOR QQ=0:0
SET QQ=$ORDER(^SC(QQ))
if 'QQ
QUIT
Begin DoDot:1
+3 SET NODE0=$GET(^SC(QQ,0))
if NODE0=""
QUIT
+4 ;type Clinic
if $PIECE(NODE0,U,3)'="C"
QUIT
+5 ;inactive date
SET INACTDT=+$PIECE($GET(^SC(QQ,"I")),U)
+6 SET REACTDT=+$PIECE($GET(^SC(QQ,"I")),U,2)
+7 IF INACTDT
IF INACTDT<DT
IF 'REACTDT!(REACTDT&((REACTDT<INACTDT)!(REACTDT>DT)))
QUIT
+8 SET NAME=$PIECE(NODE0,U)
+9 IF PR]""
Begin DoDot:2
+10 IF $EXTRACT(NAME,1,$LENGTH(PR))=PR
IF NAME[CON
Begin DoDot:3
+11 SET LN=LN+1
SET ^TMP("PSBCLIN",$JOB,LN)=NAME
End DoDot:3
End DoDot:2
+12 IF '$TEST
Begin DoDot:2
+13 IF NAME[CON
Begin DoDot:3
+14 SET LN=LN+1
SET ^TMP("PSBCLIN",$JOB,LN)=NAME
End DoDot:3
End DoDot:2
End DoDot:1
+15 QUIT
