PSODEARP ;ALB/BI - DEA EXPIRATION DATE REPORT ;10/12/22 16:32
;;7.0;OUTPATIENT PHARMACY;**667,684,545**;DEC 1997;Build 270
;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
;External reference to sub-file NEW DEA #'S (#200.5321) is supported by DBIA 7000
Q
;
EN ; Main Routine Entry Point
N DIROUT,DTOUT,DUOUT,PSOQ,PSOPAGE,POP,PSHEADER,PSCPRSSA,PSOEDS,PSOSCR,PSOOUT,PSOTYP,PSOCPRSU
S PSOPAGE=0
W !!,"Report requires 512 Columns"
S PSOQ=0 ; quit flag
S PSOCPRSU=""
;
S PSHEADER="Includes: "
;
; Input Questions
;
; CPRS System Access {Active, DISUSERed, or Both}
S DIR(0)="S^A:Active;D:DISUSERed/Terminated;B:Both",DIR("A")="CPRS System Access" D ^DIR K DIR Q:$D(DUOUT)!$D(DTOUT)!$D(DIROUT)
S PSCPRSSA=Y
S PSOCPRSU=$$CPRSUSRS(PSCPRSSA) Q:PSOCPRSU<0
S PSHEADER=PSHEADER_$S(PSOCPRSU:"CPRS ",PSOCPRSU=0:"ALL Eligible ",1:"")
S PSHEADER=PSHEADER_$S(PSCPRSSA="A":"Active ",PSCPRSSA="D":"DISUSERed/Terminated ",PSCPRSSA="B":"Active, DISUSERed/Terminated, ",1:"")_"and "
;
; Expiration Date Status {EXPIRED, NO EXP DATE, <30-DAYS, <90-DAYS}
S DIR(0)="S^E:EXPIRED;N:NO EXP DATE;3:<30-DAYS;9:<90-DAYS",DIR("A")="Expiration Date Status" D ^DIR K DIR Q:$D(DUOUT)!$D(DTOUT)!$D(DIROUT)
S PSOEDS=Y,PSHEADER=PSHEADER_$S(Y="E":"Expired DEA Number.",Y="N":"No DEA Expiration Date.",Y="3":"DEA Expiring within next 30 days.",Y="9":"DEA Expiring within next 90 days.",1:"")
D Q:$G(PSOTYP)="D" I $G(PSOOUT) Q
. S PSOTYP=$$TYPE() I $G(PSOOUT) Q
. I $G(PSOTYP)="D" D DL^PSODEARV I $G(PSOOUT) Q
. I $G(PSOTYP)="D" D RUN^PSODEARV(PSHEADER,PSCPRSSA,PSOEDS,PSOCPRSU)
;
D DEVICE Q:PSOQ ; Print to device
D RUN(PSHEADER,PSCPRSSA,PSOEDS,PSOCPRSU) Q:PSOQ ; Run Report
Q
;
GUI ; Entry point for ePCS GUI Report
N %H,PSOQ,PSOPAGE,PSOSCR,PSCPRSSA,PSOEDS,PSOCPRSU
; I $G(ECPTYP)="E" D EXPORT,^EPCSKILL Q ; ePCS not exporting to Excel at this point
S %H=$H D YX^%DTC S EPCSRDT=Y ; Date report is run
S PSOQ=0 ; quit flag
S PSOPAGE=0
S PSOSCR=$S($E($G(IOST),1,2)="C-":1,1:0)
S PSOCPRSU=$S(EPCSTYPE="C":1,EPCSTYPE="A":0)
S PSHEADER="Includes: "
S PSHEADER=PSHEADER_$S(PSOCPRSU:"CPRS ",PSOCPRSU=0:"ALL Eligible ",1:"")
;
; CPRS System Access {Active, DISUSERed/Terminated, or Both}
S PSHEADER=PSHEADER_$S(EPCSCPRS="A":"Active",EPCSCPRS="D":"DISUSERed/Terminated",EPCSCPRS="B":"Active, DISUSERed/Terminated,",1:"")_" and "
;
; Expiration Date Status {EXPIRED, NO EXP DATE, <30-DAYS, <90-DAYS}
S PSHEADER=PSHEADER_$S(EPCSSTAT="E":"Expired DEA Number.",EPCSSTAT="N":"No DEA Expiration Date.",EPCSSTAT="3":"DEA Expiring within next 30 days.",EPCSSTAT="9":"DEA Expiring within next 90 days.",1:"")
;
S PSCPRSSA=EPCSCPRS S PSOEDS=EPCSSTAT
D RUN(PSHEADER,PSCPRSSA,PSOEDS,PSOCPRSU) Q:PSOQ ; Run Report
;I $D(EPCSGUI) D ^EPCSKILL Q // Kill variables...
Q
;
DEVICE ; Request Device Information
N %ZIS,IOP,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,POP,RTN,VAR
K IO("Q")
S %ZIS="QM"
W ! D ^%ZIS
I POP S PSOQ=1 Q
S PSOSCR=$S($E($G(IOST),1,2)="C-":1,1:0)
I $D(IO("Q")) D S PSOQ=1
. S RTN=$P($T(+1)," ",1)
. S ZTRTN="RUN^"_RTN_"(PSHEADER,PSCPRSSA,PSOEDS)"
. S ZTIO=ION
. S ZTSAVE("PS*")=""
. S ZTDESC="DEA EXPIRATION REPORT"
. D ^%ZTLOAD
. W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
. D HOME^%ZIS
U IO
Q
;
COMPILE(PSCPRSSA,PSOEDS,PSOCPRSU,PSOPROB) ; -- Compile the report lines into the sort global
N DEAIEN,DEATXT,PSCOUNT1,PSOLINE,PSOTD
S PSCOUNT1=0
S DEATXT="" F S DEATXT=$O(^XTV(8991.9,"B",DEATXT)) Q:DEATXT="" D
. S DEAIEN=$O(^XTV(8991.9,"B",DEATXT,0)) Q:'DEAIEN
. S NPIEN="" F S NPIEN=$O(^VA(200,"PS4",DEATXT,NPIEN)) Q:'NPIEN D
. . K TMP,PSODNOBJ D GETS^DIQ(8991.9,DEAIEN_",","**","","TMP","MSG") M PSODNOBJ=TMP(8991.9,DEAIEN_",")
. . K TMP,PSONPOBJ D GETS^DIQ(200,NPIEN_",","**","","TMP","MSG") M PSONPOBJ=TMP(200,NPIEN_",")
. . S (PSOTD,PSONPOBJ(9.2))=$$GET1^DIQ(200,NPIEN_",",9.2,"I"),PSONPOBJ(9.2)=$$FMTE^XLFDT(PSONPOBJ(9.2),"5DZ")
. . S PSONPOBJ(202)=$$GET1^DIQ(200,NPIEN_",",202,"I"),PSONPOBJ(202)=$$FMTE^XLFDT(PSONPOBJ(202),"5DZ")
. . S PSODNOBJ(.04)=$$GET1^DIQ(8991.9,DEAIEN_",",.04,"I"),PSODNOBJ(.04)=$$FMTE^XLFDT(PSODNOBJ(.04),"5DZ")
. . S PSONPOBJ(747.44)=$$GET1^DIQ(200,NPIEN_",",747.44,"I"),PSONPOBJ(747.44)=$$FMTE^XLFDT(PSONPOBJ(747.44),"5DZ")
. . Q:'$$TEST(.PSODNOBJ,.PSONPOBJ,PSCPRSSA,PSOEDS,NPIEN,PSOCPRSU)
. . N P200P5321 S P200P5321=$$FIND1^DIC(200.5321,","_NPIEN_",",,DEATXT)
. . I '$G(P200P5321) S PSODNOBJ(.01)="*PROBLEM*",PSOPROB=$G(PSOPROB)+1
. . S PSOLINE=""
. . S PSOLINE=PSOLINE_$$LJ^XLFSTR(PSONPOBJ(9.2),"12T")_" " ; TERMINATION DATE #200, #9.2
. . S PSOLINE=PSOLINE_$$LJ^XLFSTR(PSONPOBJ(.01),"33T")_" " ; NAME #200, #.01
. . S PSOLINE=PSOLINE_$$LJ^XLFSTR(PSODNOBJ(.01),"9T")_" " ; DEA #8991.9, #.01
. . S PSOLINE=PSOLINE_$$LJ^XLFSTR(PSODNOBJ(.04),"12T")_" " ; DEA Expiration Date #8991.9, #.04
. . ;S PSOLINE=PSOLINE_$$LJ^XLFSTR(PSONPOBJ(53.2),"9T")_" " ; DEA #200, #53.2
. . ;S PSOLINE=PSOLINE_$$LJ^XLFSTR(PSONPOBJ(747.44),"12T")_" " ; DEA Expiration Date #200, #747.44
. . S PSOLINE=PSOLINE_$$LJ^XLFSTR(PSONPOBJ(202),"12T")_" " ; LAST SIGN-ON #200, #202
. . S PSOLINE=PSOLINE_$$LJ^XLFSTR(PSONPOBJ(8),"23T")_" " ; TITLE #200, #8
. . S PSOLINE=PSOLINE_$$LJ^XLFSTR(PSONPOBJ(29),"16T")_" " ; SERVICE/SECTION #200, #29
. . S PSCOUNT1=PSCOUNT1+1
. . S PSOTD=$S(PSOTD:PSOTD,1:1)
. . S ^TMP($J,"PSODEARP",PSOTD,PSONPOBJ(.01),PSCOUNT1,1)=PSOLINE
. . ;
. . D:PSONPOBJ(53.9)'=""
. . . S PSOLINE=$$LJ^XLFSTR(" ","21T") ; INDENT 21 SPACES
. . . S PSOLINE=PSOLINE_"REMARKS: "_$$LJ^XLFSTR(PSONPOBJ(53.9),"100T") ; REMARKS FIELD #200, #53.9
. . . S ^TMP($J,"PSODEARP",PSOTD,PSONPOBJ(.01),PSCOUNT1,2)=PSOLINE
. . ;
. . S PSOLINE="" ; BLANK LINE
. . S ^TMP($J,"PSODEARP",PSOTD,PSONPOBJ(.01),PSCOUNT1,3)=PSOLINE
Q
;
RUN(PSHEADER,PSCPRSSA,PSOEDS,PSOCPRSU) ; Run Report
N PSCOUNT2,PSOTD,PSONAME,PSOPROB
S PSOPROB=0 ; Track orphan x-refs in ^VA(200,"PS1"
K ^TMP($J,"PSODEARP") ; Clear the temporary accumulator
D COMPILE(PSCPRSSA,PSOEDS,PSOCPRSU,.PSOPROB)
U IO
D HDR(PSHEADER)
I '$D(^TMP($J,"PSODEARP")) W "There is no Data to Print",!
S PSOTD=0 F S PSOTD=$O(^TMP($J,"PSODEARP",PSOTD)) Q:+PSOTD=0 Q:PSOQ D
. S PSONAME="" F S PSONAME=$O(^TMP($J,"PSODEARP",PSOTD,PSONAME)) Q:PSONAME="" Q:PSOQ D
.. S PSCOUNT2=0 F S PSCOUNT2=$O(^TMP($J,"PSODEARP",PSOTD,PSONAME,PSCOUNT2)) Q:+PSCOUNT2=0 Q:PSOQ D
... W ^TMP($J,"PSODEARP",PSOTD,PSONAME,PSCOUNT2,1),! D CHKP(PSHEADER) Q:PSOQ
... I $D(^TMP($J,"PSODEARP",PSOTD,PSONAME,PSCOUNT2,2)) D Q:PSOQ
.... W ^TMP($J,"PSODEARP",PSOTD,PSONAME,PSCOUNT2,2),! D CHKP(PSHEADER) Q:PSOQ
... W ^TMP($J,"PSODEARP",PSOTD,PSONAME,PSCOUNT2,3),! D CHKP(PSHEADER) Q:PSOQ
I 'PSOQ,$G(PSOPROB) D
. W !,"*PROBLEM* INDICATES BAD CROSS REFERENCE IN NEW PERSON FILE.",!,"CONTACT PRODUCT SUPPORT TO RESOLVE.",!
I $D(EPCSGUI) Q
I 'PSOSCR W !,@IOF
D ^%ZISC
K ^TMP($J,"PSODEARP") ; Clear the temporary accumulator
Q:PSOQ
I PSOSCR K DIR("A") S DIR(0)="E" D ^DIR K DIR
Q
;
HDR(PSHEADER) ; Report header
N PSOI
S PSOPAGE=PSOPAGE+1
W @IOF,?(IOM-83),"DEA Expiration Date Report"
W !,PSHEADER,?(IOM-45)," Run Date: ",$$FMTE^XLFDT(DT,"5DZ"),?(IOM-12)," Page: ",PSOPAGE,!
W !,$$TITLES
W ! F PSOI=1:1:$S($G(IOM):(IOM-1),1:130) W "-"
W !
Q
;
CHKP(PSHEADER) ; Check for End Of Page
I $Y>(IOSL-4) D:PSOSCR Q:PSOQ D HDR(PSHEADER)
. N X,Y,DTOUT,DUOUT,DIRUT,DIR
. U IO(0) S DIR(0)="E" D ^DIR K DIR S:$D(DIRUT) PSOQ=2
. U IO
Q
;
TITLES() ; -- Create the header TITLES.
N TITLES
S TITLES=""
S TITLES=TITLES_$$LJ^XLFSTR("TERM DATE","12T")_" " ; TERMINATION DATE #200, #9.2
S TITLES=TITLES_$$LJ^XLFSTR("NAME","33T")_" " ; NAME #8991.9, #1.1
S TITLES=TITLES_$$LJ^XLFSTR("DEA","9T")_" " ; DEA #8991.9, #.01
S TITLES=TITLES_$$LJ^XLFSTR("DEA EXP DT","12T")_" " ; DEA Expiration Date #8991.9, #.04
S TITLES=TITLES_$$LJ^XLFSTR("LAST SIGN-ON","12T")_" " ; LAST SIGN-ON #200, #202
S TITLES=TITLES_$$LJ^XLFSTR("TITLE","23T")_" " ; TITLE #200, #8
S TITLES=TITLES_$$LJ^XLFSTR("SERVICE/SECTION","16T")_" " ; SERVICE/SECTION #200, #29
Q TITLES
;
TEST(PSODNOBJ,PSONPOBJ,PSCPRSSA,PSOEDS,NPIEN,PSOCPRSU) ; -- Perform the requested test for screening critera
N DEAEXPDT D DT^DILF("",PSODNOBJ(.04),.DEAEXPDT)
N RESP,PSOACC S RESP=0
N PSOTERM,PSOTODAY
S PSOTERM=$$GET1^DIQ(200,NPIEN,9.2,"I")
S PSOTODAY=$$DT^XLFDT
S PSOACC=$$GET1^DIQ(200,NPIEN,2,"I")
;
; CPRS Provider Active and DEA is expired.
I PSOCPRSU,((PSCPRSSA="A")!(PSCPRSSA="B")),PSOEDS="E",$$ACTIVE^XUSER(NPIEN),PSODNOBJ(.04)'="",(DEAEXPDT<$$DT^XLFDT()) Q 1 ; Active CPRS Providers Only
; All (CPRS and Non-CPRS) Active Providers and DEA is expired
I 'PSOCPRSU,((PSCPRSSA="A")!(PSCPRSSA="B")),PSOEDS="E",PSONPOBJ(7)'="YES",('PSOTERM!(PSOTERM>PSOTODAY)),PSODNOBJ(.04)'="",(DEAEXPDT<$$DT^XLFDT()) Q 1 ; All Active Providers
;
; CPRS Provider Active and does not have a DEA expiration date.
I PSOCPRSU,((PSCPRSSA="A")!(PSCPRSSA="B")),PSOEDS="N",$$ACTIVE^XUSER(NPIEN),PSODNOBJ(.04)="" Q 1 ; Active CPRS Providers Only
; All (CPRS and Non-CPRS) Active Provider and does not have a DEA expiration date.
I 'PSOCPRSU,((PSCPRSSA="A")!(PSCPRSSA="B")),PSOEDS="N",PSONPOBJ(7)'="YES",('PSOTERM!(PSOTERM>PSOTODAY)),PSODNOBJ(.04)="" Q 1 ; All Active Providers
;
; CPRS Provider Active and DEA is expiring within next 30 days.
I PSOCPRSU,((PSCPRSSA="A")!(PSCPRSSA="B")),PSOEDS="3",$$ACTIVE^XUSER(NPIEN),PSODNOBJ(.04)'="",DEAEXPDT<$$FMADD^XLFDT(DT,30),DEAEXPDT>$$FMADD^XLFDT(DT,-1) Q 1 ; Active CPRS Providers Only
; All (CPRS and Non-CPRS) Active Provider and DEA is expiring within next 30 days.
I 'PSOCPRSU,((PSCPRSSA="A")!(PSCPRSSA="B")),PSOEDS="3",PSONPOBJ(7)'="YES",('PSOTERM!(PSOTERM>PSOTODAY)),PSODNOBJ(.04)'="",(DEAEXPDT'>$$FMADD^XLFDT(DT,30)),DEAEXPDT>$$FMADD^XLFDT(DT,-1) Q 1 ; All Active Providers
;
; CPRS Provider Active and DEA expiring within the next 90 days.
I PSOCPRSU,((PSCPRSSA="A")!(PSCPRSSA="B")),PSOEDS="9",$$ACTIVE^XUSER(NPIEN),PSODNOBJ(.04)'="",DEAEXPDT<$$FMADD^XLFDT(DT,90),DEAEXPDT>$$FMADD^XLFDT(DT,-1) Q 1 ; Active CPRS Providers Only
; All (CPRS and Non-CPRS) Active DEA expiring within the next 90 days.
I 'PSOCPRSU,((PSCPRSSA="A")!(PSCPRSSA="B")),PSOEDS="9",PSONPOBJ(7)'="YES",('PSOTERM!(PSOTERM>PSOTODAY)),PSODNOBJ(.04)'="",(DEAEXPDT'>$$FMADD^XLFDT(DT,90)),DEAEXPDT>$$FMADD^XLFDT(DT,-1) Q 1 ; All Active Providers
;
; CPRS Provider disusered and DEA is expired.
I PSOCPRSU,$L(PSOACC),((PSCPRSSA="D")!(PSCPRSSA="B")),PSOEDS="E",((PSONPOBJ(7)="YES")!(PSOTERM&(PSOTERM<PSOTODAY))),PSODNOBJ(.04)'="",(DEAEXPDT<$$DT^XLFDT()) Q 1
; All (CPRS and Non-CPRS) disusered provider and DEA is expired.
I 'PSOCPRSU,((PSCPRSSA="D")!(PSCPRSSA="B")),PSOEDS="E",((PSONPOBJ(7)="YES")!(PSOTERM&(PSOTERM<PSOTODAY))),PSODNOBJ(.04)'="",(DEAEXPDT<$$DT^XLFDT()) Q 1
;
; CPRS Provider disusered and does not have a DEA expiration date.
I PSOCPRSU,$L(PSOACC),((PSCPRSSA="D")!(PSCPRSSA="B")),PSOEDS="N",((PSONPOBJ(7)="YES")!(PSOTERM&(PSOTERM<PSOTODAY))),PSODNOBJ(.04)="" Q 1
; All (CPRS and Non-CPRS) disusered provider and does not have a DEA expiration date.
I 'PSOCPRSU,((PSCPRSSA="D")!(PSCPRSSA="B")),PSOEDS="N",((PSONPOBJ(7)="YES")!(PSOTERM&(PSOTERM<PSOTODAY))),PSODNOBJ(.04)="" Q 1
;
; CPRS Provider disusered and DEA is expiring within the next 30 days.
I PSOCPRSU,$L(PSOACC),((PSCPRSSA="D")!(PSCPRSSA="B")),PSOEDS="3",((PSONPOBJ(7)="YES")!(PSOTERM&(PSOTERM<PSOTODAY))),PSODNOBJ(.04)'="",(DEAEXPDT'>$$FMADD^XLFDT(DT,30)),DEAEXPDT>$$FMADD^XLFDT(DT,-1) Q 1
; All (CPRS and Non-CPRS) disusered Provider and DEA is expiring within the next 30 days.
I 'PSOCPRSU,((PSCPRSSA="D")!(PSCPRSSA="B")),PSOEDS="3",((PSONPOBJ(7)="YES")!(PSOTERM&(PSOTERM<PSOTODAY))),PSODNOBJ(.04)'="",(DEAEXPDT'>$$FMADD^XLFDT(DT,30)),DEAEXPDT>$$FMADD^XLFDT(DT,-1) Q 1
;
; CPRS Provider disusered and DEA is expiring within the next 90 days.
I PSOCPRSU,$L(PSOACC),((PSCPRSSA="D")!(PSCPRSSA="B")),PSOEDS="9",((PSONPOBJ(7)="YES")!(PSOTERM&(PSOTERM<PSOTODAY))),PSODNOBJ(.04)'="",(DEAEXPDT'>$$FMADD^XLFDT(DT,90)),DEAEXPDT>$$FMADD^XLFDT(DT,-1) Q 1
; All (CPRS and Non-CPRS) disusered and DEA is expiring within the next 90 days.
I 'PSOCPRSU,((PSCPRSSA="D")!(PSCPRSSA="B")),PSOEDS="9",((PSONPOBJ(7)="YES")!(PSOTERM&(PSOTERM<PSOTODAY))),PSODNOBJ(.04)'="",(DEAEXPDT'>$$FMADD^XLFDT(DT,90)),DEAEXPDT>$$FMADD^XLFDT(DT,-1) Q 1
;
Q RESP
;
TYPE() ;Prompt for report format or delimited list
N PSOTYP
S PSOTYP=""
W ! K DIR,Y S DIR(0)="S^R:Report;D:Delimited File"
S DIR("?",1)="Enter 'R' to see the output in a report format,"
S DIR("?")="enter 'D' for a delimited list that can be exported to Excel."
S DIR("A")="Select (R)eport or (D)elimited File"
S DIR("B")="R"
D ^DIR K DIR I $D(DIRUT) S PSOOUT=1 K DIRUT,DTOUT,DUOUT,DIR,X,Y Q PSOTYP
S PSOTYP=Y
K DIRUT,DTOUT,DUOUT,DIR,X,Y
Q PSOTYP
;
CPRSUSRS(STATUS) ; Ask user if they want to constrain report to users with ACCESS CODE (CPRS Users) or ALL (e.g., Comm Care/Non-VA)
; Active CPRS System Access only, or ALL active access (i.e., no ACCESS CODE for Community Care/Non-VA providers)
N DIR,STATUSE
S STATUSE=$S($G(STATUS)="A":"Active ",$G(STATUS)="D":"Disusered/Terminated ",1:"")
S DIR(0)="S^CPRS:CPRS "_STATUSE_"Providers Only;ALL:ALL Eligible "_STATUSE_"Providers",DIR("A")="Type of System Access"
S DIR("?",1)="If CPRS is selected, only providers with an ACCESS CODE are displayed."
S DIR("?")="If ALL is selected, providers with and without an ACCESS CODE are displayed."
D ^DIR K DIR Q:$D(DUOUT)!$D(DTOUT)!$D(DIROUT) -1
Q $S(Y="CPRS":1,Y="ALL":0,1:-1)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODEARP 14273 printed Apr 09, 2024@21:27:56 Page 2
PSODEARP ;ALB/BI - DEA EXPIRATION DATE REPORT ;10/12/22 16:32
+1 ;;7.0;OUTPATIENT PHARMACY;**667,684,545**;DEC 1997;Build 270
+2 ;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
+3 ;External reference to sub-file NEW DEA #'S (#200.5321) is supported by DBIA 7000
+4 QUIT
+5 ;
EN ; Main Routine Entry Point
+1 NEW DIROUT,DTOUT,DUOUT,PSOQ,PSOPAGE,POP,PSHEADER,PSCPRSSA,PSOEDS,PSOSCR,PSOOUT,PSOTYP,PSOCPRSU
+2 SET PSOPAGE=0
+3 WRITE !!,"Report requires 512 Columns"
+4 ; quit flag
SET PSOQ=0
+5 SET PSOCPRSU=""
+6 ;
+7 SET PSHEADER="Includes: "
+8 ;
+9 ; Input Questions
+10 ;
+11 ; CPRS System Access {Active, DISUSERed, or Both}
+12 SET DIR(0)="S^A:Active;D:DISUSERed/Terminated;B:Both"
SET DIR("A")="CPRS System Access"
DO ^DIR
KILL DIR
if $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)
QUIT
+13 SET PSCPRSSA=Y
+14 SET PSOCPRSU=$$CPRSUSRS(PSCPRSSA)
if PSOCPRSU<0
QUIT
+15 SET PSHEADER=PSHEADER_$SELECT(PSOCPRSU:"CPRS ",PSOCPRSU=0:"ALL Eligible ",1:"")
+16 SET PSHEADER=PSHEADER_$SELECT(PSCPRSSA="A":"Active ",PSCPRSSA="D":"DISUSERed/Terminated ",PSCPRSSA="B":"Active, DISUSERed/Terminated, ",1:"")_"and "
+17 ;
+18 ; Expiration Date Status {EXPIRED, NO EXP DATE, <30-DAYS, <90-DAYS}
+19 SET DIR(0)="S^E:EXPIRED;N:NO EXP DATE;3:<30-DAYS;9:<90-DAYS"
SET DIR("A")="Expiration Date Status"
DO ^DIR
KILL DIR
if $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)
QUIT
+20 SET PSOEDS=Y
SET PSHEADER=PSHEADER_$SELECT(Y="E":"Expired DEA Number.",Y="N":"No DEA Expiration Date.",Y="3":"DEA Expiring within next 30 days.",Y="9":"DEA Expiring within next 90 days.",1:"")
+21 Begin DoDot:1
+22 SET PSOTYP=$$TYPE()
IF $GET(PSOOUT)
QUIT
+23 IF $GET(PSOTYP)="D"
DO DL^PSODEARV
IF $GET(PSOOUT)
QUIT
+24 IF $GET(PSOTYP)="D"
DO RUN^PSODEARV(PSHEADER,PSCPRSSA,PSOEDS,PSOCPRSU)
End DoDot:1
if $GET(PSOTYP)="D"
QUIT
IF $GET(PSOOUT)
QUIT
+25 ;
+26 ; Print to device
DO DEVICE
if PSOQ
QUIT
+27 ; Run Report
DO RUN(PSHEADER,PSCPRSSA,PSOEDS,PSOCPRSU)
if PSOQ
QUIT
+28 QUIT
+29 ;
GUI ; Entry point for ePCS GUI Report
+1 NEW %H,PSOQ,PSOPAGE,PSOSCR,PSCPRSSA,PSOEDS,PSOCPRSU
+2 ; I $G(ECPTYP)="E" D EXPORT,^EPCSKILL Q ; ePCS not exporting to Excel at this point
+3 ; Date report is run
SET %H=$HOROLOG
DO YX^%DTC
SET EPCSRDT=Y
+4 ; quit flag
SET PSOQ=0
+5 SET PSOPAGE=0
+6 SET PSOSCR=$SELECT($EXTRACT($GET(IOST),1,2)="C-":1,1:0)
+7 SET PSOCPRSU=$SELECT(EPCSTYPE="C":1,EPCSTYPE="A":0)
+8 SET PSHEADER="Includes: "
+9 SET PSHEADER=PSHEADER_$SELECT(PSOCPRSU:"CPRS ",PSOCPRSU=0:"ALL Eligible ",1:"")
+10 ;
+11 ; CPRS System Access {Active, DISUSERed/Terminated, or Both}
+12 SET PSHEADER=PSHEADER_$SELECT(EPCSCPRS="A":"Active",EPCSCPRS="D":"DISUSERed/Terminated",EPCSCPRS="B":"Active, DISUSERed/Terminated,",1:"")_" and "
+13 ;
+14 ; Expiration Date Status {EXPIRED, NO EXP DATE, <30-DAYS, <90-DAYS}
+15 SET PSHEADER=PSHEADER_$SELECT(EPCSSTAT="E":"Expired DEA Number.",EPCSSTAT="N":"No DEA Expiration Date.",EPCSSTAT="3":"DEA Expiring within next 30 days.",EPCSSTAT="9":"DEA Expiring within next 90 days.",1:"")
+16 ;
+17 SET PSCPRSSA=EPCSCPRS
SET PSOEDS=EPCSSTAT
+18 ; Run Report
DO RUN(PSHEADER,PSCPRSSA,PSOEDS,PSOCPRSU)
if PSOQ
QUIT
+19 ;I $D(EPCSGUI) D ^EPCSKILL Q // Kill variables...
+20 QUIT
+21 ;
DEVICE ; Request Device Information
+1 NEW %ZIS,IOP,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,POP,RTN,VAR
+2 KILL IO("Q")
+3 SET %ZIS="QM"
+4 WRITE !
DO ^%ZIS
+5 IF POP
SET PSOQ=1
QUIT
+6 SET PSOSCR=$SELECT($EXTRACT($GET(IOST),1,2)="C-":1,1:0)
+7 IF $DATA(IO("Q"))
Begin DoDot:1
+8 SET RTN=$PIECE($TEXT(+1)," ",1)
+9 SET ZTRTN="RUN^"_RTN_"(PSHEADER,PSCPRSSA,PSOEDS)"
+10 SET ZTIO=ION
+11 SET ZTSAVE("PS*")=""
+12 SET ZTDESC="DEA EXPIRATION REPORT"
+13 DO ^%ZTLOAD
+14 WRITE !,$SELECT($DATA(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
+15 DO HOME^%ZIS
End DoDot:1
SET PSOQ=1
+16 USE IO
+17 QUIT
+18 ;
COMPILE(PSCPRSSA,PSOEDS,PSOCPRSU,PSOPROB) ; -- Compile the report lines into the sort global
+1 NEW DEAIEN,DEATXT,PSCOUNT1,PSOLINE,PSOTD
+2 SET PSCOUNT1=0
+3 SET DEATXT=""
FOR
SET DEATXT=$ORDER(^XTV(8991.9,"B",DEATXT))
if DEATXT=""
QUIT
Begin DoDot:1
+4 SET DEAIEN=$ORDER(^XTV(8991.9,"B",DEATXT,0))
if 'DEAIEN
QUIT
+5 SET NPIEN=""
FOR
SET NPIEN=$ORDER(^VA(200,"PS4",DEATXT,NPIEN))
if 'NPIEN
QUIT
Begin DoDot:2
+6 KILL TMP,PSODNOBJ
DO GETS^DIQ(8991.9,DEAIEN_",","**","","TMP","MSG")
MERGE PSODNOBJ=TMP(8991.9,DEAIEN_",")
+7 KILL TMP,PSONPOBJ
DO GETS^DIQ(200,NPIEN_",","**","","TMP","MSG")
MERGE PSONPOBJ=TMP(200,NPIEN_",")
+8 SET (PSOTD,PSONPOBJ(9.2))=$$GET1^DIQ(200,NPIEN_",",9.2,"I")
SET PSONPOBJ(9.2)=$$FMTE^XLFDT(PSONPOBJ(9.2),"5DZ")
+9 SET PSONPOBJ(202)=$$GET1^DIQ(200,NPIEN_",",202,"I")
SET PSONPOBJ(202)=$$FMTE^XLFDT(PSONPOBJ(202),"5DZ")
+10 SET PSODNOBJ(.04)=$$GET1^DIQ(8991.9,DEAIEN_",",.04,"I")
SET PSODNOBJ(.04)=$$FMTE^XLFDT(PSODNOBJ(.04),"5DZ")
+11 SET PSONPOBJ(747.44)=$$GET1^DIQ(200,NPIEN_",",747.44,"I")
SET PSONPOBJ(747.44)=$$FMTE^XLFDT(PSONPOBJ(747.44),"5DZ")
+12 if '$$TEST(.PSODNOBJ,.PSONPOBJ,PSCPRSSA,PSOEDS,NPIEN,PSOCPRSU)
QUIT
+13 NEW P200P5321
SET P200P5321=$$FIND1^DIC(200.5321,","_NPIEN_",",,DEATXT)
+14 IF '$GET(P200P5321)
SET PSODNOBJ(.01)="*PROBLEM*"
SET PSOPROB=$GET(PSOPROB)+1
+15 SET PSOLINE=""
+16 ; TERMINATION DATE #200, #9.2
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(PSONPOBJ(9.2),"12T")_" "
+17 ; NAME #200, #.01
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(PSONPOBJ(.01),"33T")_" "
+18 ; DEA #8991.9, #.01
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(PSODNOBJ(.01),"9T")_" "
+19 ; DEA Expiration Date #8991.9, #.04
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(PSODNOBJ(.04),"12T")_" "
+20 ;S PSOLINE=PSOLINE_$$LJ^XLFSTR(PSONPOBJ(53.2),"9T")_" " ; DEA #200, #53.2
+21 ;S PSOLINE=PSOLINE_$$LJ^XLFSTR(PSONPOBJ(747.44),"12T")_" " ; DEA Expiration Date #200, #747.44
+22 ; LAST SIGN-ON #200, #202
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(PSONPOBJ(202),"12T")_" "
+23 ; TITLE #200, #8
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(PSONPOBJ(8),"23T")_" "
+24 ; SERVICE/SECTION #200, #29
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(PSONPOBJ(29),"16T")_" "
+25 SET PSCOUNT1=PSCOUNT1+1
+26 SET PSOTD=$SELECT(PSOTD:PSOTD,1:1)
+27 SET ^TMP($JOB,"PSODEARP",PSOTD,PSONPOBJ(.01),PSCOUNT1,1)=PSOLINE
+28 ;
+29 if PSONPOBJ(53.9)'=""
Begin DoDot:3
+30 ; INDENT 21 SPACES
SET PSOLINE=$$LJ^XLFSTR(" ","21T")
+31 ; REMARKS FIELD #200, #53.9
SET PSOLINE=PSOLINE_"REMARKS: "_$$LJ^XLFSTR(PSONPOBJ(53.9),"100T")
+32 SET ^TMP($JOB,"PSODEARP",PSOTD,PSONPOBJ(.01),PSCOUNT1,2)=PSOLINE
End DoDot:3
+33 ;
+34 ; BLANK LINE
SET PSOLINE=""
+35 SET ^TMP($JOB,"PSODEARP",PSOTD,PSONPOBJ(.01),PSCOUNT1,3)=PSOLINE
End DoDot:2
End DoDot:1
+36 QUIT
+37 ;
RUN(PSHEADER,PSCPRSSA,PSOEDS,PSOCPRSU) ; Run Report
+1 NEW PSCOUNT2,PSOTD,PSONAME,PSOPROB
+2 ; Track orphan x-refs in ^VA(200,"PS1"
SET PSOPROB=0
+3 ; Clear the temporary accumulator
KILL ^TMP($JOB,"PSODEARP")
+4 DO COMPILE(PSCPRSSA,PSOEDS,PSOCPRSU,.PSOPROB)
+5 USE IO
+6 DO HDR(PSHEADER)
+7 IF '$DATA(^TMP($JOB,"PSODEARP"))
WRITE "There is no Data to Print",!
+8 SET PSOTD=0
FOR
SET PSOTD=$ORDER(^TMP($JOB,"PSODEARP",PSOTD))
if +PSOTD=0
QUIT
if PSOQ
QUIT
Begin DoDot:1
+9 SET PSONAME=""
FOR
SET PSONAME=$ORDER(^TMP($JOB,"PSODEARP",PSOTD,PSONAME))
if PSONAME=""
QUIT
if PSOQ
QUIT
Begin DoDot:2
+10 SET PSCOUNT2=0
FOR
SET PSCOUNT2=$ORDER(^TMP($JOB,"PSODEARP",PSOTD,PSONAME,PSCOUNT2))
if +PSCOUNT2=0
QUIT
if PSOQ
QUIT
Begin DoDot:3
+11 WRITE ^TMP($JOB,"PSODEARP",PSOTD,PSONAME,PSCOUNT2,1),!
DO CHKP(PSHEADER)
if PSOQ
QUIT
+12 IF $DATA(^TMP($JOB,"PSODEARP",PSOTD,PSONAME,PSCOUNT2,2))
Begin DoDot:4
+13 WRITE ^TMP($JOB,"PSODEARP",PSOTD,PSONAME,PSCOUNT2,2),!
DO CHKP(PSHEADER)
if PSOQ
QUIT
End DoDot:4
if PSOQ
QUIT
+14 WRITE ^TMP($JOB,"PSODEARP",PSOTD,PSONAME,PSCOUNT2,3),!
DO CHKP(PSHEADER)
if PSOQ
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+15 IF 'PSOQ
IF $GET(PSOPROB)
Begin DoDot:1
+16 WRITE !,"*PROBLEM* INDICATES BAD CROSS REFERENCE IN NEW PERSON FILE.",!,"CONTACT PRODUCT SUPPORT TO RESOLVE.",!
End DoDot:1
+17 IF $DATA(EPCSGUI)
QUIT
+18 IF 'PSOSCR
WRITE !,@IOF
+19 DO ^%ZISC
+20 ; Clear the temporary accumulator
KILL ^TMP($JOB,"PSODEARP")
+21 if PSOQ
QUIT
+22 IF PSOSCR
KILL DIR("A")
SET DIR(0)="E"
DO ^DIR
KILL DIR
+23 QUIT
+24 ;
HDR(PSHEADER) ; Report header
+1 NEW PSOI
+2 SET PSOPAGE=PSOPAGE+1
+3 WRITE @IOF,?(IOM-83),"DEA Expiration Date Report"
+4 WRITE !,PSHEADER,?(IOM-45)," Run Date: ",$$FMTE^XLFDT(DT,"5DZ"),?(IOM-12)," Page: ",PSOPAGE,!
+5 WRITE !,$$TITLES
+6 WRITE !
FOR PSOI=1:1:$SELECT($GET(IOM):(IOM-1),1:130)
WRITE "-"
+7 WRITE !
+8 QUIT
+9 ;
CHKP(PSHEADER) ; Check for End Of Page
+1 IF $Y>(IOSL-4)
if PSOSCR
Begin DoDot:1
+2 NEW X,Y,DTOUT,DUOUT,DIRUT,DIR
+3 USE IO(0)
SET DIR(0)="E"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
SET PSOQ=2
+4 USE IO
End DoDot:1
if PSOQ
QUIT
DO HDR(PSHEADER)
+5 QUIT
+6 ;
TITLES() ; -- Create the header TITLES.
+1 NEW TITLES
+2 SET TITLES=""
+3 ; TERMINATION DATE #200, #9.2
SET TITLES=TITLES_$$LJ^XLFSTR("TERM DATE","12T")_" "
+4 ; NAME #8991.9, #1.1
SET TITLES=TITLES_$$LJ^XLFSTR("NAME","33T")_" "
+5 ; DEA #8991.9, #.01
SET TITLES=TITLES_$$LJ^XLFSTR("DEA","9T")_" "
+6 ; DEA Expiration Date #8991.9, #.04
SET TITLES=TITLES_$$LJ^XLFSTR("DEA EXP DT","12T")_" "
+7 ; LAST SIGN-ON #200, #202
SET TITLES=TITLES_$$LJ^XLFSTR("LAST SIGN-ON","12T")_" "
+8 ; TITLE #200, #8
SET TITLES=TITLES_$$LJ^XLFSTR("TITLE","23T")_" "
+9 ; SERVICE/SECTION #200, #29
SET TITLES=TITLES_$$LJ^XLFSTR("SERVICE/SECTION","16T")_" "
+10 QUIT TITLES
+11 ;
TEST(PSODNOBJ,PSONPOBJ,PSCPRSSA,PSOEDS,NPIEN,PSOCPRSU) ; -- Perform the requested test for screening critera
+1 NEW DEAEXPDT
DO DT^DILF("",PSODNOBJ(.04),.DEAEXPDT)
+2 NEW RESP,PSOACC
SET RESP=0
+3 NEW PSOTERM,PSOTODAY
+4 SET PSOTERM=$$GET1^DIQ(200,NPIEN,9.2,"I")
+5 SET PSOTODAY=$$DT^XLFDT
+6 SET PSOACC=$$GET1^DIQ(200,NPIEN,2,"I")
+7 ;
+8 ; CPRS Provider Active and DEA is expired.
+9 ; Active CPRS Providers Only
IF PSOCPRSU
IF ((PSCPRSSA="A")!(PSCPRSSA="B"))
IF PSOEDS="E"
IF $$ACTIVE^XUSER(NPIEN)
IF PSODNOBJ(.04)'=""
IF (DEAEXPDT<$$DT^XLFDT())
QUIT 1
+10 ; All (CPRS and Non-CPRS) Active Providers and DEA is expired
+11 ; All Active Providers
IF 'PSOCPRSU
IF ((PSCPRSSA="A")!(PSCPRSSA="B"))
IF PSOEDS="E"
IF PSONPOBJ(7)'="YES"
IF ('PSOTERM!(PSOTERM>PSOTODAY))
IF PSODNOBJ(.04)'=""
IF (DEAEXPDT<$$DT^XLFDT())
QUIT 1
+12 ;
+13 ; CPRS Provider Active and does not have a DEA expiration date.
+14 ; Active CPRS Providers Only
IF PSOCPRSU
IF ((PSCPRSSA="A")!(PSCPRSSA="B"))
IF PSOEDS="N"
IF $$ACTIVE^XUSER(NPIEN)
IF PSODNOBJ(.04)=""
QUIT 1
+15 ; All (CPRS and Non-CPRS) Active Provider and does not have a DEA expiration date.
+16 ; All Active Providers
IF 'PSOCPRSU
IF ((PSCPRSSA="A")!(PSCPRSSA="B"))
IF PSOEDS="N"
IF PSONPOBJ(7)'="YES"
IF ('PSOTERM!(PSOTERM>PSOTODAY))
IF PSODNOBJ(.04)=""
QUIT 1
+17 ;
+18 ; CPRS Provider Active and DEA is expiring within next 30 days.
+19 ; Active CPRS Providers Only
IF PSOCPRSU
IF ((PSCPRSSA="A")!(PSCPRSSA="B"))
IF PSOEDS="3"
IF $$ACTIVE^XUSER(NPIEN)
IF PSODNOBJ(.04)'=""
IF DEAEXPDT<$$FMADD^XLFDT(DT,30)
IF DEAEXPDT>$$FMADD^XLFDT(DT,-1)
QUIT 1
+20 ; All (CPRS and Non-CPRS) Active Provider and DEA is expiring within next 30 days.
+21 ; All Active Providers
IF 'PSOCPRSU
IF ((PSCPRSSA="A")!(PSCPRSSA="B"))
IF PSOEDS="3"
IF PSONPOBJ(7)'="YES"
IF ('PSOTERM!(PSOTERM>PSOTODAY))
IF PSODNOBJ(.04)'=""
IF (DEAEXPDT'>$$FMADD^XLFDT(DT,30))
IF DEAEXPDT>$$FMADD^XLFDT(DT,-1)
QUIT 1
+22 ;
+23 ; CPRS Provider Active and DEA expiring within the next 90 days.
+24 ; Active CPRS Providers Only
IF PSOCPRSU
IF ((PSCPRSSA="A")!(PSCPRSSA="B"))
IF PSOEDS="9"
IF $$ACTIVE^XUSER(NPIEN)
IF PSODNOBJ(.04)'=""
IF DEAEXPDT<$$FMADD^XLFDT(DT,90)
IF DEAEXPDT>$$FMADD^XLFDT(DT,-1)
QUIT 1
+25 ; All (CPRS and Non-CPRS) Active DEA expiring within the next 90 days.
+26 ; All Active Providers
IF 'PSOCPRSU
IF ((PSCPRSSA="A")!(PSCPRSSA="B"))
IF PSOEDS="9"
IF PSONPOBJ(7)'="YES"
IF ('PSOTERM!(PSOTERM>PSOTODAY))
IF PSODNOBJ(.04)'=""
IF (DEAEXPDT'>$$FMADD^XLFDT(DT,90))
IF DEAEXPDT>$$FMADD^XLFDT(DT,-1)
QUIT 1
+27 ;
+28 ; CPRS Provider disusered and DEA is expired.
+29 IF PSOCPRSU
IF $LENGTH(PSOACC)
IF ((PSCPRSSA="D")!(PSCPRSSA="B"))
IF PSOEDS="E"
IF ((PSONPOBJ(7)="YES")!(PSOTERM&(PSOTERM<PSOTODAY)))
IF PSODNOBJ(.04)'=""
IF (DEAEXPDT<$$DT^XLFDT())
QUIT 1
+30 ; All (CPRS and Non-CPRS) disusered provider and DEA is expired.
+31 IF 'PSOCPRSU
IF ((PSCPRSSA="D")!(PSCPRSSA="B"))
IF PSOEDS="E"
IF ((PSONPOBJ(7)="YES")!(PSOTERM&(PSOTERM<PSOTODAY)))
IF PSODNOBJ(.04)'=""
IF (DEAEXPDT<$$DT^XLFDT())
QUIT 1
+32 ;
+33 ; CPRS Provider disusered and does not have a DEA expiration date.
+34 IF PSOCPRSU
IF $LENGTH(PSOACC)
IF ((PSCPRSSA="D")!(PSCPRSSA="B"))
IF PSOEDS="N"
IF ((PSONPOBJ(7)="YES")!(PSOTERM&(PSOTERM<PSOTODAY)))
IF PSODNOBJ(.04)=""
QUIT 1
+35 ; All (CPRS and Non-CPRS) disusered provider and does not have a DEA expiration date.
+36 IF 'PSOCPRSU
IF ((PSCPRSSA="D")!(PSCPRSSA="B"))
IF PSOEDS="N"
IF ((PSONPOBJ(7)="YES")!(PSOTERM&(PSOTERM<PSOTODAY)))
IF PSODNOBJ(.04)=""
QUIT 1
+37 ;
+38 ; CPRS Provider disusered and DEA is expiring within the next 30 days.
+39 IF PSOCPRSU
IF $LENGTH(PSOACC)
IF ((PSCPRSSA="D")!(PSCPRSSA="B"))
IF PSOEDS="3"
IF ((PSONPOBJ(7)="YES")!(PSOTERM&(PSOTERM<PSOTODAY)))
IF PSODNOBJ(.04)'=""
IF (DEAEXPDT'>$$FMADD^XLFDT(DT,30))
IF DEAEXPDT>$$FMADD^XLFDT(DT,-1)
QUIT 1
+40 ; All (CPRS and Non-CPRS) disusered Provider and DEA is expiring within the next 30 days.
+41 IF 'PSOCPRSU
IF ((PSCPRSSA="D")!(PSCPRSSA="B"))
IF PSOEDS="3"
IF ((PSONPOBJ(7)="YES")!(PSOTERM&(PSOTERM<PSOTODAY)))
IF PSODNOBJ(.04)'=""
IF (DEAEXPDT'>$$FMADD^XLFDT(DT,30))
IF DEAEXPDT>$$FMADD^XLFDT(DT,-1)
QUIT 1
+42 ;
+43 ; CPRS Provider disusered and DEA is expiring within the next 90 days.
+44 IF PSOCPRSU
IF $LENGTH(PSOACC)
IF ((PSCPRSSA="D")!(PSCPRSSA="B"))
IF PSOEDS="9"
IF ((PSONPOBJ(7)="YES")!(PSOTERM&(PSOTERM<PSOTODAY)))
IF PSODNOBJ(.04)'=""
IF (DEAEXPDT'>$$FMADD^XLFDT(DT,90))
IF DEAEXPDT>$$FMADD^XLFDT(DT,-1)
QUIT 1
+45 ; All (CPRS and Non-CPRS) disusered and DEA is expiring within the next 90 days.
+46 IF 'PSOCPRSU
IF ((PSCPRSSA="D")!(PSCPRSSA="B"))
IF PSOEDS="9"
IF ((PSONPOBJ(7)="YES")!(PSOTERM&(PSOTERM<PSOTODAY)))
IF PSODNOBJ(.04)'=""
IF (DEAEXPDT'>$$FMADD^XLFDT(DT,90))
IF DEAEXPDT>$$FMADD^XLFDT(DT,-1)
QUIT 1
+47 ;
+48 QUIT RESP
+49 ;
TYPE() ;Prompt for report format or delimited list
+1 NEW PSOTYP
+2 SET PSOTYP=""
+3 WRITE !
KILL DIR,Y
SET DIR(0)="S^R:Report;D:Delimited File"
+4 SET DIR("?",1)="Enter 'R' to see the output in a report format,"
+5 SET DIR("?")="enter 'D' for a delimited list that can be exported to Excel."
+6 SET DIR("A")="Select (R)eport or (D)elimited File"
+7 SET DIR("B")="R"
+8 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET PSOOUT=1
KILL DIRUT,DTOUT,DUOUT,DIR,X,Y
QUIT PSOTYP
+9 SET PSOTYP=Y
+10 KILL DIRUT,DTOUT,DUOUT,DIR,X,Y
+11 QUIT PSOTYP
+12 ;
CPRSUSRS(STATUS) ; Ask user if they want to constrain report to users with ACCESS CODE (CPRS Users) or ALL (e.g., Comm Care/Non-VA)
+1 ; Active CPRS System Access only, or ALL active access (i.e., no ACCESS CODE for Community Care/Non-VA providers)
+2 NEW DIR,STATUSE
+3 SET STATUSE=$SELECT($GET(STATUS)="A":"Active ",$GET(STATUS)="D":"Disusered/Terminated ",1:"")
+4 SET DIR(0)="S^CPRS:CPRS "_STATUSE_"Providers Only;ALL:ALL Eligible "_STATUSE_"Providers"
SET DIR("A")="Type of System Access"
+5 SET DIR("?",1)="If CPRS is selected, only providers with an ACCESS CODE are displayed."
+6 SET DIR("?")="If ALL is selected, providers with and without an ACCESS CODE are displayed."
+7 DO ^DIR
KILL DIR
if $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)
QUIT -1
+8 QUIT $SELECT(Y="CPRS":1,Y="ALL":0,1:-1)
