- 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 Feb 18, 2025@23:07:29 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