PSOEPREP ;BIR/TJL - ePCS Report RPC Broker ;12/2/21 08:38
;;7.0;OUTPATIENT PHARMACY;**545**;8 May 96;Build 270
;
RPTEN(RESULTS,EPCSARY) ;RPC Broker entry point for ePCS Reports
;All ePCS GUI reports will call this line tag
; RPC: PSO EPCS REPORTS
;INPUTS EPCSARY - Contains the following elements for report printing
; EPCSDEV - Print to queue, if device
; EPCSQDT - Queue to print (date/time), optional
; EPCSPTYP - Where to send output (P)rinter, (D)evice or screen
;
;OUTPUTS RESULTS - Array of help text in the HELP FRAM File (#9.2)
;
N HLPDA,HND,EPCSSTR,EPCSFILR,EPCSERR,EPCSDIRY,EPCSUFIL,EPCSGUI
N EPCSQTIM ;CMF should not need this! %DT call below fails for future dates within this routine
I '$G(DUZ) D
. S DUZ=.5,DUZ(0)="@",U="^",DTIME=300
. D NOW^%DTC S DT=X
S EPCSERR=0,EPCSGUI=1 D PARSE,CHKDT I EPCSERR Q
K ^TMP("EPCSMSG",$J),^TMP($J,"EPCSRPT")
D I EPCSERR D END Q
. I EPCSPTYP="E" Q
. I EPCSPTYP="D" D HFSOPEN(EPCSHNDL) Q
. I '$D(EPCSDEV) S ^TMP("EPCSMSG",$J,1)="0^Device undefined",EPCSERR=1
S HND=$P($T(@EPCSHNDL),";;",2) I HND="" D Q
. S ^TMP("EPCSMSG",$J,1)="0^Line Tag undefined" D END
S ^XTMP("PSOEPRPT",0)=$$FMADD^XLFDT($$DT^XLFDT(),90)_"^"_$$DT^XLFDT()
S ^XTMP("PSOEPRPT","PSOEPREP","EPCSQDTbefore")=$G(EPCSQDT) ;;cmf diagnostic hack
S:EPCSPTYP="P" EPCSQTIM=$TR($P(EPCSQDT,"@",2),":","")
S EPCSQDT=$G(EPCSQDT,"NOW"),%DT="XT",X=EPCSQDT D ^%DT ;Print time
S EPCSQDT=$S(Y>0:Y,1:"NOW")
S:EPCSPTYP="P"&(EPCSQDT="NOW") EPCSQDT=DT_"."_EPCSQTIM ;Should not have to do this! %DT malfunctions inside this routine!!!
D @$P(HND,";",2)
I EPCSPTYP="D" D HFSCLOSE(EPCSFILR)
END D KILLVAR
I $D(^TMP("EPCSMSG",$J)) S RESULTS=$NA(^TMP("EPCSMSG",$J)) Q
S RESULTS=$NA(^TMP($J))
Q
;
PARSE ;Parse data from array for filing
N SUB
S SUB="" F S SUB=$O(EPCSARY(SUB)) Q:SUB="" S @SUB=EPCSARY(SUB)
Q
CHKDT ;Required Data Check
N I,C
S C=1
F I="EPCSHNDL","EPCSPTYP" D
.I $G(@I)="" S ^TMP("EPCSMSG",$J,C)="0^Key data missing "_I,C=C+1,EPCSERR=1
Q
KILLVAR ;Kill variables
N SUB
S SUB="" F S SUB=$O(EPCSARY(SUB)) Q:SUB="" K @SUB
K EPCSARY,POP,ECPSQDT
Q
HFSOPEN(HANDLE) ;
;S EPCSDIRY=$$GET^XPAR("DIV","EPCS HFS SCRATCH")
S EPCSDIRY=$$DEFDIR^%ZISH()
I EPCSDIRY="" S EPCSERR=1 D Q
.S ^TMP("EPCSMSG",$J,1)="0^A scratch directory for reports doesn't exist"
S EPCSFILR="EPCS"_DUZ_".DAT",EPCSUFIL=EPCSFILR S ^TMP("JEN",$J,.1)=EPCSUFIL
D OPEN^%ZISH(HANDLE,EPCSDIRY,EPCSFILR,"W") D:POP Q:POP
.S EPCSERR=1,^TMP("EPCSMSG",$J,1)="0^Unable to open file "_EPCSDIRY_EPCSFILR
S IOM=132,IOSL=99999,IOST="P-DUMMY",IOF=""""""
Q
;
HFSCLOSE(HANDLE) ;
N EPCSDEL
D CLOSE^%ZISH(EPCSDIRY_HANDLE)
K ^TMP($J)
S EPCSDEL(EPCSFILR)=""
S X=$$FTG^%ZISH(EPCSDIRY,EPCSFILR,$NAME(^TMP($J,1)),2)
S X=$$DEL^%ZISH(EPCSDIRY,$NA(EPCSDEL))
Q
EPCSEXP ;;DEA Expiration Date Report;EPCSEXP^PSOEPRPT
EPCSPPP ;;Print Prescribers with Privileges;EPCSPPP^PSOEPRPT
EPCSDIS ;;Print DISUSER Prescriber with Privileges;EPCSDIS^PSOEPRPT
EPCSAUD ;;Print Audits for Prescriber Editing;EPCSAUD^PSOEPRPT
EPCSLACA ;;Logical Access Control Audit;EPCSLACA^PSOEPRPT
EPCS1007 ;;File 100.7 Report;EPCS1007^PSOEPRPT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOEPREP 3237 printed Apr 09, 2024@21:26:08 Page 2
PSOEPREP ;BIR/TJL - ePCS Report RPC Broker ;12/2/21 08:38
+1 ;;7.0;OUTPATIENT PHARMACY;**545**;8 May 96;Build 270
+2 ;
RPTEN(RESULTS,EPCSARY) ;RPC Broker entry point for ePCS Reports
+1 ;All ePCS GUI reports will call this line tag
+2 ; RPC: PSO EPCS REPORTS
+3 ;INPUTS EPCSARY - Contains the following elements for report printing
+4 ; EPCSDEV - Print to queue, if device
+5 ; EPCSQDT - Queue to print (date/time), optional
+6 ; EPCSPTYP - Where to send output (P)rinter, (D)evice or screen
+7 ;
+8 ;OUTPUTS RESULTS - Array of help text in the HELP FRAM File (#9.2)
+9 ;
+10 NEW HLPDA,HND,EPCSSTR,EPCSFILR,EPCSERR,EPCSDIRY,EPCSUFIL,EPCSGUI
+11 ;CMF should not need this! %DT call below fails for future dates within this routine
NEW EPCSQTIM
+12 IF '$GET(DUZ)
Begin DoDot:1
+13 SET DUZ=.5
SET DUZ(0)="@"
SET U="^"
SET DTIME=300
+14 DO NOW^%DTC
SET DT=X
End DoDot:1
+15 SET EPCSERR=0
SET EPCSGUI=1
DO PARSE
DO CHKDT
IF EPCSERR
QUIT
+16 KILL ^TMP("EPCSMSG",$JOB),^TMP($JOB,"EPCSRPT")
+17 Begin DoDot:1
+18 IF EPCSPTYP="E"
QUIT
+19 IF EPCSPTYP="D"
DO HFSOPEN(EPCSHNDL)
QUIT
+20 IF '$DATA(EPCSDEV)
SET ^TMP("EPCSMSG",$JOB,1)="0^Device undefined"
SET EPCSERR=1
End DoDot:1
IF EPCSERR
DO END
QUIT
+21 SET HND=$PIECE($TEXT(@EPCSHNDL),";;",2)
IF HND=""
Begin DoDot:1
+22 SET ^TMP("EPCSMSG",$JOB,1)="0^Line Tag undefined"
DO END
End DoDot:1
QUIT
+23 SET ^XTMP("PSOEPRPT",0)=$$FMADD^XLFDT($$DT^XLFDT(),90)_"^"_$$DT^XLFDT()
+24 ;;cmf diagnostic hack
SET ^XTMP("PSOEPRPT","PSOEPREP","EPCSQDTbefore")=$GET(EPCSQDT)
+25 if EPCSPTYP="P"
SET EPCSQTIM=$TRANSLATE($PIECE(EPCSQDT,"@",2),":","")
+26 ;Print time
SET EPCSQDT=$GET(EPCSQDT,"NOW")
SET %DT="XT"
SET X=EPCSQDT
DO ^%DT
+27 SET EPCSQDT=$SELECT(Y>0:Y,1:"NOW")
+28 ;Should not have to do this! %DT malfunctions inside this routine!!!
if EPCSPTYP="P"&(EPCSQDT="NOW")
SET EPCSQDT=DT_"."_EPCSQTIM
+29 DO @$PIECE(HND,";",2)
+30 IF EPCSPTYP="D"
DO HFSCLOSE(EPCSFILR)
END DO KILLVAR
+1 IF $DATA(^TMP("EPCSMSG",$JOB))
SET RESULTS=$NAME(^TMP("EPCSMSG",$JOB))
QUIT
+2 SET RESULTS=$NAME(^TMP($JOB))
+3 QUIT
+4 ;
PARSE ;Parse data from array for filing
+1 NEW SUB
+2 SET SUB=""
FOR
SET SUB=$ORDER(EPCSARY(SUB))
if SUB=""
QUIT
SET @SUB=EPCSARY(SUB)
+3 QUIT
CHKDT ;Required Data Check
+1 NEW I,C
+2 SET C=1
+3 FOR I="EPCSHNDL","EPCSPTYP"
Begin DoDot:1
+4 IF $GET(@I)=""
SET ^TMP("EPCSMSG",$JOB,C)="0^Key data missing "_I
SET C=C+1
SET EPCSERR=1
End DoDot:1
+5 QUIT
KILLVAR ;Kill variables
+1 NEW SUB
+2 SET SUB=""
FOR
SET SUB=$ORDER(EPCSARY(SUB))
if SUB=""
QUIT
KILL @SUB
+3 KILL EPCSARY,POP,ECPSQDT
+4 QUIT
HFSOPEN(HANDLE) ;
+1 ;S EPCSDIRY=$$GET^XPAR("DIV","EPCS HFS SCRATCH")
+2 SET EPCSDIRY=$$DEFDIR^%ZISH()
+3 IF EPCSDIRY=""
SET EPCSERR=1
Begin DoDot:1
+4 SET ^TMP("EPCSMSG",$JOB,1)="0^A scratch directory for reports doesn't exist"
End DoDot:1
QUIT
+5 SET EPCSFILR="EPCS"_DUZ_".DAT"
SET EPCSUFIL=EPCSFILR
SET ^TMP("JEN",$JOB,.1)=EPCSUFIL
+6 DO OPEN^%ZISH(HANDLE,EPCSDIRY,EPCSFILR,"W")
if POP
Begin DoDot:1
+7 SET EPCSERR=1
SET ^TMP("EPCSMSG",$JOB,1)="0^Unable to open file "_EPCSDIRY_EPCSFILR
End DoDot:1
if POP
QUIT
+8 SET IOM=132
SET IOSL=99999
SET IOST="P-DUMMY"
SET IOF=""""""
+9 QUIT
+10 ;
HFSCLOSE(HANDLE) ;
+1 NEW EPCSDEL
+2 DO CLOSE^%ZISH(EPCSDIRY_HANDLE)
+3 KILL ^TMP($JOB)
+4 SET EPCSDEL(EPCSFILR)=""
+5 SET X=$$FTG^%ZISH(EPCSDIRY,EPCSFILR,$NAME(^TMP($JOB,1)),2)
+6 SET X=$$DEL^%ZISH(EPCSDIRY,$NAME(EPCSDEL))
+7 QUIT
EPCSEXP ;;DEA Expiration Date Report;EPCSEXP^PSOEPRPT
EPCSPPP ;;Print Prescribers with Privileges;EPCSPPP^PSOEPRPT
EPCSDIS ;;Print DISUSER Prescriber with Privileges;EPCSDIS^PSOEPRPT
EPCSAUD ;;Print Audits for Prescriber Editing;EPCSAUD^PSOEPRPT
EPCSLACA ;;Logical Access Control Audit;EPCSLACA^PSOEPRPT
EPCS1007 ;;File 100.7 Report;EPCS1007^PSOEPRPT
