PSOEPUT2 ;BIR/TJL - ePCS Broker Utilities ;10/13/21 10:35
;;7.0;OUTPATIENT PHARMACY;**545**;DEC 1997;Build 270
;
EPCSHELP(RESULTS,EPCSARY) ;
;
;Broker call returns the entries from HELP FILE #9.2
; RPC: PSO EPCS GET HELP
;INPUTS EPCSARY - Contains the following elements
; HELPDA - Help Frame Name
;
;OUTPUTS RESULTS - Array of help text in the HELP FRAME File (#9.2)
;
N HELPDA,DIC,X,Y
S HELPDA=$G(EPCSARY) I HELPDA="" Q
D SETENV K ^TMP("EPCSHELP",$J)
S DIC="^DIC(9.2,",DIC(0)="MN",X=HELPDA
D ^DIC M ^TMP("EPCSHELP",$J)=^DIC(9.2,+Y,1)
I $D(^TMP("EPCSHELP",$J)) D
. S $P(^TMP("EPCSHELP",$J,0),U)=$P(^DIC(9.2,+Y,0),U,2)
S RESULTS=$NA(^TMP("EPCSHELP",$J))
Q
;
EPCSDATE(RESULTS,EPCSARY) ;
;
;Broker call returns an FileMan internal date
; RPC: PSO EPCS SYSTEM DATE TIME
;INPUTS EPCSARY - Contains the following elements
; DTSTR - Date String (e.g., 'N' for 'Now')
;
;OUTPUTS RESULTS - A valid FileMan date format^External format
;
N EPCSDATE,DIC,X,Y,DATESTR
D SETENV
S DATESTR=$P(EPCSARY,U) I DATESTR="" Q
S X=DATESTR,%DT="XT",%DT(0)="-NOW" D ^%DT
I +Y<1 S RESULTS="0^Invalid Date/Time" Q
S RESULTS=Y D D^DIQ
S RESULTS=RESULTS_U_Y
Q
;
SRCLST(RESULTS,EPCSARY) ;
;
; This broker entry returns an array of codes from a file
; based on a search string.
; RPC: PSO EPCS GET LIST
;
;INPUTS EPCSARY - Contains the following subscripted elements
; EPCSFILE - File to search
; EPCSSTR - Search string
; EPCSDIR - Search order
; EPCSNUM - (Optional) # records to return [default=44]
;OUTPUTS RESULTS - Array of values based on the search criteria.
;
N EPCSFILE,EPCSSTR,EPCSDIR,EPCSORD,EPCSNUM
D SETENV
S EPCSFILE=$P(EPCSARY,U),EPCSSTR=$P(EPCSARY,U,2),EPCSDIR=$P(EPCSARY,U,3)
S EPCSORD=$S(EPCSDIR=-1:"B",1:"I")
K ^TMP($J,"EPCSFIND"),^TMP("EPCSSRCH",$J)
I EPCSFILE="" Q
S EPCSNUM=$S(+$P(EPCSARY,U,4)>0:$P(EPCSARY,U,4),1:44)
I EPCSFILE=200 D PROV(EPCSNUM) ;Providers
D SORT
EXIT K ^TMP("EPCSSRCH",$J)
S RESULTS=$NA(^TMP($J,"EPCSFIND"))
Q
;
SORT ;Order the data to be returned by the broker
N COUNT
S COUNT=0
F S COUNT=$O(^TMP("EPCSSRCH",$J,"DILIST","ID",COUNT)) Q:'COUNT D
.S ^TMP($J,"EPCSFIND",COUNT)=$G(^TMP("EPCSSRCH",$J,"DILIST","ID",COUNT,.01))_U_^TMP("EPCSSRCH",$J,"DILIST",2,COUNT)
Q
;
PROV(EPCSNUM) ;Return a set of providers from the NEW PERSON file
;Input Variables:-
; EPCSNUM - # of records to return
; FROM - text to begin $O from
; DATE - checks for an active person class on this date (optional)
; EPCSDIR - $O direction
; REPORT - Set to "R" to get all entries from file 200 OR set to blank
; if only users with a person class should be returned.
;
;Output Variables:-
; ^TMP($J,"EPCSFIND",1..n - returned array
; IEN of file 200^Provider Name^occupation^specialty^subspecialty
;
N I,IEN,COUNT,FROM,DATE,EPCSUTN,REPORT S I=0,COUNT=$S(+$G(EPCSNUM)>0:EPCSNUM,1:44)
S FROM=$P(EPCSSTR,"|"),DATE=$P(EPCSSTR,"|",2),REPORT=$P(EPCSSTR,"|",3)
F Q:I'<COUNT S FROM=$O(^VA(200,"B",FROM),EPCSDIR) Q:FROM="" D
. S IEN="" F S IEN=$O(^VA(200,"B",FROM,IEN),EPCSDIR) Q:'IEN D
. . I IEN<1 Q ; Don't include special users postmaster and sharedmail
. . I REPORT="R" S I=I+1,^TMP($J,"EPCSFIND",I)=IEN_"^"_FROM_"^" Q
. . S EPCSUTN=$$GET^XUA4A72(IEN,DATE)
. . S I=I+1,^TMP($J,"EPCSFIND",I)=IEN_"^"_FROM_"^"_$P(EPCSUTN,"^",2,4)
Q
SETENV ;
I '$G(DUZ) D
. S DUZ=.5,DUZ(0)="@",U="^",DTIME=300
. D NOW^%DTC S DT=X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOEPUT2 3616 printed Apr 09, 2024@21:30:58 Page 2
PSOEPUT2 ;BIR/TJL - ePCS Broker Utilities ;10/13/21 10:35
+1 ;;7.0;OUTPATIENT PHARMACY;**545**;DEC 1997;Build 270
+2 ;
EPCSHELP(RESULTS,EPCSARY) ;
+1 ;
+2 ;Broker call returns the entries from HELP FILE #9.2
+3 ; RPC: PSO EPCS GET HELP
+4 ;INPUTS EPCSARY - Contains the following elements
+5 ; HELPDA - Help Frame Name
+6 ;
+7 ;OUTPUTS RESULTS - Array of help text in the HELP FRAME File (#9.2)
+8 ;
+9 NEW HELPDA,DIC,X,Y
+10 SET HELPDA=$GET(EPCSARY)
IF HELPDA=""
QUIT
+11 DO SETENV
KILL ^TMP("EPCSHELP",$JOB)
+12 SET DIC="^DIC(9.2,"
SET DIC(0)="MN"
SET X=HELPDA
+13 DO ^DIC
MERGE ^TMP("EPCSHELP",$JOB)=^DIC(9.2,+Y,1)
+14 IF $DATA(^TMP("EPCSHELP",$JOB))
Begin DoDot:1
+15 SET $PIECE(^TMP("EPCSHELP",$JOB,0),U)=$PIECE(^DIC(9.2,+Y,0),U,2)
End DoDot:1
+16 SET RESULTS=$NAME(^TMP("EPCSHELP",$JOB))
+17 QUIT
+18 ;
EPCSDATE(RESULTS,EPCSARY) ;
+1 ;
+2 ;Broker call returns an FileMan internal date
+3 ; RPC: PSO EPCS SYSTEM DATE TIME
+4 ;INPUTS EPCSARY - Contains the following elements
+5 ; DTSTR - Date String (e.g., 'N' for 'Now')
+6 ;
+7 ;OUTPUTS RESULTS - A valid FileMan date format^External format
+8 ;
+9 NEW EPCSDATE,DIC,X,Y,DATESTR
+10 DO SETENV
+11 SET DATESTR=$PIECE(EPCSARY,U)
IF DATESTR=""
QUIT
+12 SET X=DATESTR
SET %DT="XT"
SET %DT(0)="-NOW"
DO ^%DT
+13 IF +Y<1
SET RESULTS="0^Invalid Date/Time"
QUIT
+14 SET RESULTS=Y
DO D^DIQ
+15 SET RESULTS=RESULTS_U_Y
+16 QUIT
+17 ;
SRCLST(RESULTS,EPCSARY) ;
+1 ;
+2 ; This broker entry returns an array of codes from a file
+3 ; based on a search string.
+4 ; RPC: PSO EPCS GET LIST
+5 ;
+6 ;INPUTS EPCSARY - Contains the following subscripted elements
+7 ; EPCSFILE - File to search
+8 ; EPCSSTR - Search string
+9 ; EPCSDIR - Search order
+10 ; EPCSNUM - (Optional) # records to return [default=44]
+11 ;OUTPUTS RESULTS - Array of values based on the search criteria.
+12 ;
+13 NEW EPCSFILE,EPCSSTR,EPCSDIR,EPCSORD,EPCSNUM
+14 DO SETENV
+15 SET EPCSFILE=$PIECE(EPCSARY,U)
SET EPCSSTR=$PIECE(EPCSARY,U,2)
SET EPCSDIR=$PIECE(EPCSARY,U,3)
+16 SET EPCSORD=$SELECT(EPCSDIR=-1:"B",1:"I")
+17 KILL ^TMP($JOB,"EPCSFIND"),^TMP("EPCSSRCH",$JOB)
+18 IF EPCSFILE=""
QUIT
+19 SET EPCSNUM=$SELECT(+$PIECE(EPCSARY,U,4)>0:$PIECE(EPCSARY,U,4),1:44)
+20 ;Providers
IF EPCSFILE=200
DO PROV(EPCSNUM)
+21 DO SORT
EXIT KILL ^TMP("EPCSSRCH",$JOB)
+1 SET RESULTS=$NAME(^TMP($JOB,"EPCSFIND"))
+2 QUIT
+3 ;
SORT ;Order the data to be returned by the broker
+1 NEW COUNT
+2 SET COUNT=0
+3 FOR
SET COUNT=$ORDER(^TMP("EPCSSRCH",$JOB,"DILIST","ID",COUNT))
if 'COUNT
QUIT
Begin DoDot:1
+4 SET ^TMP($JOB,"EPCSFIND",COUNT)=$GET(^TMP("EPCSSRCH",$JOB,"DILIST","ID",COUNT,.01))_U_^TMP("EPCSSRCH",$JOB,"DILIST",2,COUNT)
End DoDot:1
+5 QUIT
+6 ;
PROV(EPCSNUM) ;Return a set of providers from the NEW PERSON file
+1 ;Input Variables:-
+2 ; EPCSNUM - # of records to return
+3 ; FROM - text to begin $O from
+4 ; DATE - checks for an active person class on this date (optional)
+5 ; EPCSDIR - $O direction
+6 ; REPORT - Set to "R" to get all entries from file 200 OR set to blank
+7 ; if only users with a person class should be returned.
+8 ;
+9 ;Output Variables:-
+10 ; ^TMP($J,"EPCSFIND",1..n - returned array
+11 ; IEN of file 200^Provider Name^occupation^specialty^subspecialty
+12 ;
+13 NEW I,IEN,COUNT,FROM,DATE,EPCSUTN,REPORT
SET I=0
SET COUNT=$SELECT(+$GET(EPCSNUM)>0:EPCSNUM,1:44)
+14 SET FROM=$PIECE(EPCSSTR,"|")
SET DATE=$PIECE(EPCSSTR,"|",2)
SET REPORT=$PIECE(EPCSSTR,"|",3)
+15 FOR
if I'<COUNT
QUIT
SET FROM=$ORDER(^VA(200,"B",FROM),EPCSDIR)
if FROM=""
QUIT
Begin DoDot:1
+16 SET IEN=""
FOR
SET IEN=$ORDER(^VA(200,"B",FROM,IEN),EPCSDIR)
if 'IEN
QUIT
Begin DoDot:2
+17 ; Don't include special users postmaster and sharedmail
IF IEN<1
QUIT
+18 IF REPORT="R"
SET I=I+1
SET ^TMP($JOB,"EPCSFIND",I)=IEN_"^"_FROM_"^"
QUIT
+19 SET EPCSUTN=$$GET^XUA4A72(IEN,DATE)
+20 SET I=I+1
SET ^TMP($JOB,"EPCSFIND",I)=IEN_"^"_FROM_"^"_$PIECE(EPCSUTN,"^",2,4)
End DoDot:2
End DoDot:1
+21 QUIT
SETENV ;
+1 IF '$GET(DUZ)
Begin DoDot:1
+2 SET DUZ=.5
SET DUZ(0)="@"
SET U="^"
SET DTIME=300
+3 DO NOW^%DTC
SET DT=X
End DoDot:1
+4 QUIT
