PSBRPC1 ;BIRMINGHAM/VN - BCMA RPC BROKER CALLS ;29-May-2012 14:22;PLS
;;3.0;BAR CODE MED ADMIN;**42,1015**;23-May-2012 13:30;Build 62
;
; Reference/IA
; ^%ZIS/812
; ^XUSEC/10076
; File 200/10060
;
; Modified - IHS/MSC/PLS - 09/19/2007 - Line DEVICE+17 - Added OTH as a valid device type
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 ;IHS/MSC/PLS - 05/23/2012 - corrected the device check statement
.. I $G(DUZ("AG"))="I",X'="TRM",X'="HG",X'="HFS",X'="CHAN",X'="OTH" Q ;Device Types
.. 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
PSBRPC1 ;BIRMINGHAM/VN - BCMA RPC BROKER CALLS ;29-May-2012 14:22;PLS
+1 ;;3.0;BAR CODE MED ADMIN;**42,1015**;23-May-2012 13:30;Build 62
+2 ;
+3 ; Reference/IA
+4 ; ^%ZIS/812
+5 ; ^XUSEC/10076
+6 ; File 200/10060
+7 ;
+8 ; Modified - IHS/MSC/PLS - 09/19/2007 - Line DEVICE+17 - Added OTH as a valid device type
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 ;I $G(DUZ("AG"))="I",X'="OTH" Q ;IHS/MSC/PLS - 05/23/2012 - corrected the device check statement
+20 ;Device Types
IF $GET(DUZ("AG"))="I"
IF X'="TRM"
IF X'="HG"
IF X'="HFS"
IF X'="CHAN"
IF X'="OTH"
QUIT
+21 ;Queuing allowed
SET X=X0
IF ($PIECE(X,U,2)="0")!($PIECE(X,U,12)=2)
QUIT
+22 ;Out of Service
SET X=+X90
IF X
IF (X'>DT)
QUIT
+23 ;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
+24 SET POP=0
+25 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
+26 ;Security check
IF POP
QUIT
+27 SET SHOW=$PIECE(X0,U)
IF SHOW'=FROM
SET SHOW=FROM_" <"_SHOW_">"
+28 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)
+29 SET RESULTS(0)=I
End DoDot:2
End DoDot:1
+30 IF '$DATA(RESULTS(0))
SET RESULTS(0)=1
SET RESULTS(1)="-1^No printers on file"
+31 QUIT
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
