- 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 Feb 18, 2025@23:53:59 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