- 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 Mar 13, 2025@20:45:47 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
