PSBRPC1 ;BIRMINGHAM/VN - BCMA RPC BROKER CALLS ;12/3/12 1:17pm
;;3.0;BAR CODE MED ADMIN;**42,70**;Mar 2004;Build 101
;
; Reference/IA
; ^%ZIS/812
; ^XUSEC/10076
; File 200/10060
;
;*70 - Add new RPC at tag MEDSONPT, to return true/false flags for 3
; key med types and actions: IV Infusing, IV Stopped, and
; Patch on not removed.
; - add Tags to perform Witness verification, RPC:PSB WITNESS
;
DEVICE(RESULTS,FROM,DIR) ;
;
; RPC: PSB DEVICE
;
; Return a subset of entries from the Device file
;
; .LST(n)=IEN;Name^DisplayName^Location^RMar^PLen
; FROM=text to $O from, DIR=$O direction
K RESULTS
N I,IEN,SHOW,X S I=0,CNT=20
I FROM["<" S FROM=$RE($P($RE(FROM),"< ",2))
F Q:I'<CNT S FROM=$O(^%ZIS(1,"B",FROM),DIR) Q:FROM="" D
. S IEN=0 F S IEN=$O(^%ZIS(1,"B",FROM,IEN)) Q:'IEN D
.. N X0,X1,X90,X91,X95,XTYPE,XSTYPE,XTIME,%A,%X,POP
.. Q:'$D(^%ZIS(1,IEN,0))
.. S X0=$G(^%ZIS(1,IEN,0)),X1=$G(^(1)),X90=$G(^(90)),X91=$G(^(91)),X95=$G(^(95)),XSTYPE=$G(^("SUBTYPE")),XTIME=$G(^("TIME")),XTYPE=$G(^("TYPE"))
.. I $E($G(^%ZIS(2,+XSTYPE,0)))'="P" Q ;Printers only
.. S X=$P(XTYPE,"^") ;Device Types
.. I $G(DUZ("AG"))="V",X'="TRM",X'="HG",X'="HFS",X'="CHAN" Q
.. I $G(DUZ("AG"))="I",X'="OTH" Q
.. S X=X0 I ($P(X,U,2)="0")!($P(X,U,12)=2) Q ;Queuing allowed
.. S X=+X90 I X,(X'>DT) Q ;Out of Service
.. I XTIME]"" S %A=$P(XTIME,"^"),%X=$P($H,",",2),%=%X\60#60+(%X\3600*100),%X=$P(%A,"-",2) I %X'<%A&(%'>%X&(%'<%A))!(%X<%A&(%'<%A!(%'>%X))) Q ;Prohibited Times
.. S POP=0
.. I X95]"" S %X=$G(DUZ(0)) I %X'="@" S POP=1 F %A=1:1:$L(%X) I X95[$E(%X,%A) S POP=0 Q
.. Q:POP ;Security check
.. S SHOW=$P(X0,U) I SHOW'=FROM S SHOW=FROM_" <"_SHOW_">"
.. S I=I+1,RESULTS(I)=IEN_";"_$P(X0,U)_U_SHOW_U_$P(X1,U)_U_$P(X91,U)_U_$P(X91,U,3)
.. S RESULTS(0)=I
I '$D(RESULTS(0)) S RESULTS(0)=1,RESULTS(1)="-1^No printers on file"
Q
;
GPROV(RESULTS,DUMMY) ;
K ^TMP("PSB",$J)
S RESULTS=$NAME(^TMP("PSB",$J)),PSBCNT=1,^TMP("PSB",$J,0)=0
D NOW^%DTC
S X="" F S X=$O(^XUSEC("PROVIDER",X)) Q:X="" D
.S PSBIACT=$$GET1^DIQ(200,X_",",53.4,"I") I PSBIACT'="",+PSBIACT'<% Q ;if Inactive date and date is less than now Q
.S PSBTERM=$$GET1^DIQ(200,X_",",9.2,"I") I PSBTERM'="",+PSBTERM'<% Q ;if termination date and date is less than now Q
.Q:'$$GET1^DIQ(200,X_",",53.1,"I") ;is authorized to write med orders
.Q:'$$GET1^DIQ(200,X_",",53.2) ;must have DEA#
.S ^TMP("PSBL",$J,$$GET1^DIQ(200,X_",",.01),X)=""
S X="^TMP(""PSBL"","_$J_")",PSBCNT=1,^TMP("PSB",$J,0)=0
F S X=$Q(@X) Q:$QS(X,1)'="PSBL" S ^TMP("PSB",$J,PSBCNT)=$QS(X,3)_"^"_$QS(X,4),^TMP("PSB",$J,0)=PSBCNT,PSBCNT=PSBCNT+1
K ^TMP("PSBL",$J),PSBIACT,PSBTERM,PSBAUTH,PSBCNT,DUMMY
Q
;
;*70 new tag below attached to RPC: PSB MEDS ON PATIENT
MEDSONPT(RESULTS,DFN) ; Return indicators for 3 types of meds on the patient
S RESULTS(0)=1
S $P(RESULTS(1),U,1)=$$INFUSING^PSBVDLU1(DFN) ;IV's infusing flag
S $P(RESULTS(1),U,2)=$$STOPPED^PSBVDLU1(DFN) ;IV's stopped flag
S $P(RESULTS(1),U,3)=$$PATCHON^PSBVDLU1(DFN) ;patch on flag
Q
;
WITNESS(RESULTS,PSBACC,PSBVER) ; Validate a witness to a BCMA action ;*70
;
; RPC: PSB WITNESS
; Descr: RPC for validating Acces and Verify codes for a Witness
; Used by: frmWitness to validate an witness(s) at the client via
; encrypted A/V Code.
;
N LOGPERS,WITNESS,GUIIEN,PSBGUI,ERR
S PSBACC=$$DECRYP^XUSRB1(PSBACC)
S PSBVER=$$DECRYP^XUSRB1(PSBVER)
S PSBWITN=$$CHECKAV^XUSRB(PSBACC_";"_PSBVER)
;
; valid ACC & VER code test
I PSBWITN<1 D WITERR("Invalid Witness sign-on") K PSBWITN Q
;
; authorized tests
I $D(^XUSEC("PSB STUDENT",PSBWITN)) D Q
. D WITERR("A student does not have authority to witness a High Risk/High Alert administration.")
I $D(^XUSEC("PSB NO WITNESS",PSBWITN)) D Q
. D WITERR("You do not have authority to witness a High Risk/High Alert administration.")
I $D(^XUSEC("PSB READ ONLY",PSBWITN)) D Q
. D WITERR("Read-Only users do not have authority to witness a High Risk/High Alert administration.")
I DUZ=PSBWITN D WITERR("Cannot Witness for yourself") K PSBWITN Q
;** workaround bug in kernel XQCHK, if fixed remove logic ref to
;** checking "AP" xref and quits thereof
N ACCESS
S ACCESS=$$ACCESS^XQCHK(PSBWITN,"PSB GUI CONTEXT - USER")
I ACCESS="N" D Q
. D WITERR("Invalid VistA user - No Primary menu setup for this user in the NEW PERSON file.")
;
;Code with ;** comments are extra checks to work around a bug in the
;Kernel API used above, and can be removed when this API is fixed.
I +ACCESS<1 D Q:ERR ;can be 0 or negative
. S ERR=1 ;**
. S PSBGUI=$O(^DIC(19,"B","PSB GUI CONTEXT - USER","")) ;**
. I $D(^VA(200,"AP",PSBGUI,PSBWITN)) S ERR=0 Q ;**
. D WITERR("A non-BCMA user does not have authority to witness a High Risk/High Alert administration.")
;
;error - instructor trying to witness for their student, is handled
; by the gui client.
;
; passed all tests
S PSBWITN(0)=$$GET1^DIQ(200,PSBWITN_",",.01)
S RESULTS(0)=PSBWITN_U_PSBWITN(0)
Q
;
WITERR(MSG) ;build witness error msg ;*70
S RESULTS(0)="-1^"_MSG
K PSBWITN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBRPC1 5316 printed Apr 09, 2024@20:45:49 Page 2
PSBRPC1 ;BIRMINGHAM/VN - BCMA RPC BROKER CALLS ;12/3/12 1:17pm
+1 ;;3.0;BAR CODE MED ADMIN;**42,70**;Mar 2004;Build 101
+2 ;
+3 ; Reference/IA
+4 ; ^%ZIS/812
+5 ; ^XUSEC/10076
+6 ; File 200/10060
+7 ;
+8 ;*70 - Add new RPC at tag MEDSONPT, to return true/false flags for 3
+9 ; key med types and actions: IV Infusing, IV Stopped, and
+10 ; Patch on not removed.
+11 ; - add Tags to perform Witness verification, RPC:PSB WITNESS
+12 ;
DEVICE(RESULTS,FROM,DIR) ;
+1 ;
+2 ; RPC: PSB DEVICE
+3 ;
+4 ; Return a subset of entries from the Device file
+5 ;
+6 ; .LST(n)=IEN;Name^DisplayName^Location^RMar^PLen
+7 ; FROM=text to $O from, DIR=$O direction
+8 KILL RESULTS
+9 NEW I,IEN,SHOW,X
SET I=0
SET CNT=20
+10 IF FROM["<"
SET FROM=$REVERSE($PIECE($REVERSE(FROM),"< ",2))
+11 FOR
if I'<CNT
QUIT
SET FROM=$ORDER(^%ZIS(1,"B",FROM),DIR)
if FROM=""
QUIT
Begin DoDot:1
+12 SET IEN=0
FOR
SET IEN=$ORDER(^%ZIS(1,"B",FROM,IEN))
if 'IEN
QUIT
Begin DoDot:2
+13 NEW X0,X1,X90,X91,X95,XTYPE,XSTYPE,XTIME,%A,%X,POP
+14 if '$DATA(^%ZIS(1,IEN,0))
QUIT
+15 SET X0=$GET(^%ZIS(1,IEN,0))
SET X1=$GET(^(1))
SET X90=$GET(^(90))
SET X91=$GET(^(91))
SET X95=$GET(^(95))
SET XSTYPE=$GET(^("SUBTYPE"))
SET XTIME=$GET(^("TIME"))
SET XTYPE=$GET(^("TYPE"))
+16 ;Printers only
IF $EXTRACT($GET(^%ZIS(2,+XSTYPE,0)))'="P"
QUIT
+17 ;Device Types
SET X=$PIECE(XTYPE,"^")
+18 IF $GET(DUZ("AG"))="V"
IF X'="TRM"
IF X'="HG"
IF X'="HFS"
IF X'="CHAN"
QUIT
+19 IF $GET(DUZ("AG"))="I"
IF X'="OTH"
QUIT
+20 ;Queuing allowed
SET X=X0
IF ($PIECE(X,U,2)="0")!($PIECE(X,U,12)=2)
QUIT
+21 ;Out of Service
SET X=+X90
IF X
IF (X'>DT)
QUIT
+22 ;Prohibited Times
IF XTIME]""
SET %A=$PIECE(XTIME,"^")
SET %X=$PIECE($HOROLOG,",",2)
SET %=%X\60#60+(%X\3600*100)
SET %X=$PIECE(%A,"-",2)
IF %X'<%A&(%'>%X&(%'<%A))!(%X<%A&(%'<%A!(%'>%X)))
QUIT
+23 SET POP=0
+24 IF X95]""
SET %X=$GET(DUZ(0))
IF %X'="@"
SET POP=1
FOR %A=1:1:$LENGTH(%X)
IF X95[$EXTRACT(%X,%A)
SET POP=0
QUIT
+25 ;Security check
if POP
QUIT
+26 SET SHOW=$PIECE(X0,U)
IF SHOW'=FROM
SET SHOW=FROM_" <"_SHOW_">"
+27 SET I=I+1
SET RESULTS(I)=IEN_";"_$PIECE(X0,U)_U_SHOW_U_$PIECE(X1,U)_U_$PIECE(X91,U)_U_$PIECE(X91,U,3)
+28 SET RESULTS(0)=I
End DoDot:2
End DoDot:1
+29 IF '$DATA(RESULTS(0))
SET RESULTS(0)=1
SET RESULTS(1)="-1^No printers on file"
+30 QUIT
+31 ;
GPROV(RESULTS,DUMMY) ;
+1 KILL ^TMP("PSB",$JOB)
+2 SET RESULTS=$NAME(^TMP("PSB",$JOB))
SET PSBCNT=1
SET ^TMP("PSB",$JOB,0)=0
+3 DO NOW^%DTC
+4 SET X=""
FOR
SET X=$ORDER(^XUSEC("PROVIDER",X))
if X=""
QUIT
Begin DoDot:1
+5 ;if Inactive date and date is less than now Q
SET PSBIACT=$$GET1^DIQ(200,X_",",53.4,"I")
IF PSBIACT'=""
IF +PSBIACT'<%
QUIT
+6 ;if termination date and date is less than now Q
SET PSBTERM=$$GET1^DIQ(200,X_",",9.2,"I")
IF PSBTERM'=""
IF +PSBTERM'<%
QUIT
+7 ;is authorized to write med orders
if '$$GET1^DIQ(200,X_",",53.1,"I")
QUIT
+8 ;must have DEA#
if '$$GET1^DIQ(200,X_",",53.2)
QUIT
+9 SET ^TMP("PSBL",$JOB,$$GET1^DIQ(200,X_",",.01),X)=""
End DoDot:1
+10 SET X="^TMP(""PSBL"","_$JOB_")"
SET PSBCNT=1
SET ^TMP("PSB",$JOB,0)=0
+11 FOR
SET X=$QUERY(@X)
if $QSUBSCRIPT(X,1)'="PSBL"
QUIT
SET ^TMP("PSB",$JOB,PSBCNT)=$QSUBSCRIPT(X,3)_"^"_$QSUBSCRIPT(X,4)
SET ^TMP("PSB",$JOB,0)=PSBCNT
SET PSBCNT=PSBCNT+1
+12 KILL ^TMP("PSBL",$JOB),PSBIACT,PSBTERM,PSBAUTH,PSBCNT,DUMMY
+13 QUIT
+14 ;
+15 ;*70 new tag below attached to RPC: PSB MEDS ON PATIENT
MEDSONPT(RESULTS,DFN) ; Return indicators for 3 types of meds on the patient
+1 SET RESULTS(0)=1
+2 ;IV's infusing flag
SET $PIECE(RESULTS(1),U,1)=$$INFUSING^PSBVDLU1(DFN)
+3 ;IV's stopped flag
SET $PIECE(RESULTS(1),U,2)=$$STOPPED^PSBVDLU1(DFN)
+4 ;patch on flag
SET $PIECE(RESULTS(1),U,3)=$$PATCHON^PSBVDLU1(DFN)
+5 QUIT
+6 ;
WITNESS(RESULTS,PSBACC,PSBVER) ; Validate a witness to a BCMA action ;*70
+1 ;
+2 ; RPC: PSB WITNESS
+3 ; Descr: RPC for validating Acces and Verify codes for a Witness
+4 ; Used by: frmWitness to validate an witness(s) at the client via
+5 ; encrypted A/V Code.
+6 ;
+7 NEW LOGPERS,WITNESS,GUIIEN,PSBGUI,ERR
+8 SET PSBACC=$$DECRYP^XUSRB1(PSBACC)
+9 SET PSBVER=$$DECRYP^XUSRB1(PSBVER)
+10 SET PSBWITN=$$CHECKAV^XUSRB(PSBACC_";"_PSBVER)
+11 ;
+12 ; valid ACC & VER code test
+13 IF PSBWITN<1
DO WITERR("Invalid Witness sign-on")
KILL PSBWITN
QUIT
+14 ;
+15 ; authorized tests
+16 IF $DATA(^XUSEC("PSB STUDENT",PSBWITN))
Begin DoDot:1
+17 DO WITERR("A student does not have authority to witness a High Risk/High Alert administration.")
End DoDot:1
QUIT
+18 IF $DATA(^XUSEC("PSB NO WITNESS",PSBWITN))
Begin DoDot:1
+19 DO WITERR("You do not have authority to witness a High Risk/High Alert administration.")
End DoDot:1
QUIT
+20 IF $DATA(^XUSEC("PSB READ ONLY",PSBWITN))
Begin DoDot:1
+21 DO WITERR("Read-Only users do not have authority to witness a High Risk/High Alert administration.")
End DoDot:1
QUIT
+22 IF DUZ=PSBWITN
DO WITERR("Cannot Witness for yourself")
KILL PSBWITN
QUIT
+23 ;** workaround bug in kernel XQCHK, if fixed remove logic ref to
+24 ;** checking "AP" xref and quits thereof
+25 NEW ACCESS
+26 SET ACCESS=$$ACCESS^XQCHK(PSBWITN,"PSB GUI CONTEXT - USER")
+27 IF ACCESS="N"
Begin DoDot:1
+28 DO WITERR("Invalid VistA user - No Primary menu setup for this user in the NEW PERSON file.")
End DoDot:1
QUIT
+29 ;
+30 ;Code with ;** comments are extra checks to work around a bug in the
+31 ;Kernel API used above, and can be removed when this API is fixed.
+32 ;can be 0 or negative
IF +ACCESS<1
Begin DoDot:1
+33 ;**
SET ERR=1
+34 ;**
SET PSBGUI=$ORDER(^DIC(19,"B","PSB GUI CONTEXT - USER",""))
+35 ;**
IF $DATA(^VA(200,"AP",PSBGUI,PSBWITN))
SET ERR=0
QUIT
+36 DO WITERR("A non-BCMA user does not have authority to witness a High Risk/High Alert administration.")
End DoDot:1
if ERR
QUIT
+37 ;
+38 ;error - instructor trying to witness for their student, is handled
+39 ; by the gui client.
+40 ;
+41 ; passed all tests
+42 SET PSBWITN(0)=$$GET1^DIQ(200,PSBWITN_",",.01)
+43 SET RESULTS(0)=PSBWITN_U_PSBWITN(0)
+44 QUIT
+45 ;
WITERR(MSG) ;build witness error msg ;*70
+1 SET RESULTS(0)="-1^"_MSG
+2 KILL PSBWITN
+3 QUIT
