PSODEARA ;WILM/BDB - Print active prescribers with privledges; ;9/28/21 12:59
;;7.0;OUTPATIENT PHARMACY;**545,731**;DEC 1997;Build 18
;External reference to VA(200 is supported by DBIA 10060
;Reference DBIA 2343 - $$ACTIVE^XUSER
;Reference DBIA 2171 - PARENT^XUAF4()
;----------------------------------------------------------------
;
Q
;
PRIVSRT ; Print active prescribers with privledges
;
;ePCS on demand report
N PSONS,RHD,RT,PSOION D INIT K %DT,DTOUT,ZPR,POP
K IOP,%ZIS S PSOION=ION,%ZIS="MQ" D ^%ZIS I POP S IOP=PSOION D ^%ZIS G EXIT
AUTPRT ;
I $G(ZPR)!$D(IO("Q")) D G EXIT
. N ZTRTN,ZTDESC,ZTIO,ZTSAVE,ZTDTH,ZTSK,ZTREQ,ZTQUEUED
. S:$G(ZPR) ZTIO="`"_ZPR,ZTDTH=$H S ZTRTN="OEN^PSODEARA"
. S ZTSAVE("PSONS")="",ZTSAVE("RHD")="",ZTSAVE("RT")="",ZTSAVE("FSP")=""
. D ^%ZTLOAD W:$D(ZTSK) !,"Report is Queued to print !!"
OEN ;
U IO
N PAGE,LINE,LEN,XTV,ARR,I,J,RHD,HCL,FSP,RDT,DV,FE,NPIEN,RET,PSOSPS
N DV,ND,DAT,IEN,DVS,CNT,NDEA,DEA,DEAVA,PSOSRC,PSOSRCI K DIRUT,DTOUT
S CNT=0
K ^XTMP(PSONS,$J),^TMP(PSONS,$J)
S NPIEN=.99 F S NPIEN=$O(^VA(200,NPIEN)) Q:'NPIEN D
. I '$$ACTIVE^XUSER(NPIEN) Q
. K DAT D DEALIST^PSOEPUT(.DAT,NPIEN)
. I '$D(DAT) D
. . S DAT(1)="^^^^^^^^^^^^^"
. S NDEA=0 F S NDEA=$O(DAT(NDEA)) Q:'NDEA D
.. S DAT(NDEA)=$$UP^XLFSTR(DAT(NDEA))
.. D DATCHK ;Check for no new DEA numbers, use 200 schedules
.. I DAT(NDEA)?1"^"."^" Q ;Quit if no data
.. S CNT=CNT+1
.. S ^TMP(PSONS,$J,CNT)=NPIEN_"^"_DAT(NDEA)
.. S (DV,DVS)=0 F S DV=$O(^VA(200,NPIEN,2,DV)) Q:('DV)&(DVS>0) S:'DV DV=999999 D
... S DVS=DVS+1
... S ^XTMP(PSONS,$J,DV,CNT)=""
... S:$O(^VA(200,NPIEN,2,DV)) ^XTMP(PSONS,$J,"Z",NPIEN)=""
S RHD="PRESCRIBERS WITH PRIVILEGES"
S HCL=(80-$L(RHD))\2,RDT=$$UP^XLFSTR($$FMTE^XLFDT($$NOW^XLFDT,"1M"))
S PAGE=1,$P(LINE,"-",79)="",$P(FSP," ",25)=""
D HD
I '$D(^XTMP(PSONS,$J)) D G QT
. W !!," *************** NO MATCHING DATA ***************",!!
S DV="" F S DV=$O(^XTMP(PSONS,$J,DV)) Q:'DV D G:$D(DIRUT) QT
. K ARR S LEN="DIVISION: "_$S(DV=999999:"NO DIVISION",1:$$GET1^DIQ(4,DV,.01))
. W !!,?9,LEN
. S ND=0 F S ND=$O(^XTMP(PSONS,$J,DV,ND)) Q:'ND D Q:$D(DIRUT)
.. S DAT=^TMP(PSONS,$J,ND),NPIEN=$P(DAT,"^"),DEA=$P(DAT,"^",2)
.. I $P(DAT,"^",3)=.03 Q ;P731 detox/x-waiver removal
.. I $P(DAT,"^",9,14)'["Y" Q ;check for a schedule
.. S ARR(NPIEN)=""
.. S PSOSPS=$G(^VA(200,NPIEN,"PS"))
.. W !,$E($$GET1^DIQ(200,NPIEN,.01)_FSP,1,25),?32,$E(NPIEN_FSP,1,12),?45,$E(DEA_FSP,1,13),?60,$E($P(PSOSPS,U,3)_FSP,1,15)
.. W ?72,$E($S($P(DAT,"^",15)="":"NO",1:$P(DAT,"^",15))_FSP,1,5)
.. W !," SCHEDULE II:",?29,$S($P(DAT,"^",9)="":"NO",1:$P(DAT,"^",9))
.. W !," SCHEDULE II NON:",?29,$S($P(DAT,"^",10)="":"NO",1:$P(DAT,"^",10))
.. W !," SCHEDULE III:",?29,$S($P(DAT,"^",11)="":"NO",1:$P(DAT,"^",11))
.. W !," SCHEDULE III NON:",?29,$S($P(DAT,"^",12)="":"NO",1:$P(DAT,"^",12))
.. W !," SCHEDULE IV:",?29,$S($P(DAT,"^",13)="":"NO",1:$P(DAT,"^",13))
.. W !," SCHEDULE V:",?29,$S($P(DAT,"^",14)="":"NO",1:$P(DAT,"^",14))
.. S PSOSRC="",PSOSRCI=$P(DAT,"^",8) D W PSOSRC
... I PSOSRCI']"" S PSOSRC=" (Source: File #200)" Q
... S PSOSRC=$$GET1^DIQ(8991.9,PSOSRCI,.07)
... I PSOSRC="INDIVIDUAL" S PSOSRC=" (Source: File #8991.9)" Q
... I PSOSRC="INSTITUTIONAL" S PSOSRC=" (Source: File #200)" Q
.. D:($Y+4)>IOSL HD
. S J=0 F S J=$O(ARR(J)) Q:'J D:$D(^XTMP(PSONS,$J,"Z",J)) FT
QT ;
K DIR,DTOUT,DUOUT,DIRUT
D EXIT
Q
;
EXIT K ^TMP(PSONS,$J),^XTMP(PSONS,$J)
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
;
HD ;
I PAGE>1,$E(IOST)="C" S DIR(0)="E",DIR("A")=" Press Return to Continue or ^ to Exit" D ^DIR K DIR
Q:$D(DIRUT)!($D(DTOUT))
W @IOF
W !,RHD,?50,RDT,?72,"PAGE "_PAGE S PAGE=PAGE+1
W !,"NAME",?32,"DUZ",?45,"DEA #",?60,"VA#",?73,"INPAT"
W !,?45,"(E)=EXPIRED"
W !,LINE
Q
;
FT ;
S LEN="**Note: This user is defined under these divisions"
W !!,LEN
W ! F I=1:1:$L(LEN) W "-"
S (DAT,ND)=0 F S ND=$O(^VA(200,J,2,ND)) Q:'ND D
. S DAT=DAT+1 W ! W:DAT=1 $$GET1^DIQ(200,J,.01) W ?32,$$GET1^DIQ(4,ND,.01)
I $E(IOST)="C" S DIR(0)="E" D ^DIR K DIR
Q
;
INIT ;
S PSONS="PSODEAA",$P(FSP," ",25)=""
S RHD="PRINT PRESCRIBERS WITH PRIVILEGES"
S ZPR=""
S RT=$$NOW^XLFDT
K ^XTMP(PSONS,$J),^TMP(PSONS,$J)
Q
;
GUI ;
N PSONS,ZPR,RHD,RT,PSOSCR,BDT,EDT,PSOION
D INIT K %DT,DTOUT,ZPR
;
;I $G(ECPTYP)="E" D EXPORT,^EPCSKILL Q ; ePCS not exporting to Excel at this point
S PSOSCR=$S($E($G(IOST),1,2)="C-":1,1:0)
;
D OEN ; Run Report
;I $D(EPCSGUI) D ^EPCSKILL Q // Kill variables...
Q
;
DATCHK ;Check for no new DEA numbers, use 200 schedules
N X,EXPDTFM,NPSCHED,RET,Y
S RET=""
S X=$P(DAT(NDEA),"^",1) I X="" D
. ; Use #200 schedules
. K NPSCHED D GETS^DIQ(200,NPIEN_",","55.1:55.6","E","NPSCHED")
. S RET=RET_NPSCHED(200,NPIEN_",",55.1,"E")_"^" ; SCHEDULE II NARCOTIC
. S RET=RET_NPSCHED(200,NPIEN_",",55.2,"E")_"^" ; SCHEDULE II NON-NARCOTIC
. S RET=RET_NPSCHED(200,NPIEN_",",55.3,"E")_"^" ; SCHEDULE III NARCOTIC
. S RET=RET_NPSCHED(200,NPIEN_",",55.4,"E")_"^" ; SCHEDULE III NON-NARCOTIC
. S RET=RET_NPSCHED(200,NPIEN_",",55.5,"E")_"^" ; SCHEDULE IV
. S RET=RET_NPSCHED(200,NPIEN_",",55.6,"E")_"^" ; SCHEDULE V
. S DAT(NDEA)=$P(DAT(NDEA),"^",1,7)_"^"_RET_"^"_$P(DAT(NDEA),"^",14)
. S DAT(NDEA)=$$UP^XLFSTR(DAT(NDEA))
S X=$P(DAT(NDEA),"^",5) I X]"" D
. D ^%DT S EXPDTFM=Y Q:Y<0
. I EXPDTFM'<DT Q
. S:$P(DAT(NDEA),"^",1)]"" $P(DAT(NDEA),"^",1)=$P(DAT(NDEA),"^",1)_"(E)"
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODEARA 5609 printed Sep 23, 2025@20:02:52 Page 2
PSODEARA ;WILM/BDB - Print active prescribers with privledges; ;9/28/21 12:59
+1 ;;7.0;OUTPATIENT PHARMACY;**545,731**;DEC 1997;Build 18
+2 ;External reference to VA(200 is supported by DBIA 10060
+3 ;Reference DBIA 2343 - $$ACTIVE^XUSER
+4 ;Reference DBIA 2171 - PARENT^XUAF4()
+5 ;----------------------------------------------------------------
+6 ;
+7 QUIT
+8 ;
PRIVSRT ; Print active prescribers with privledges
+1 ;
+2 ;ePCS on demand report
+3 NEW PSONS,RHD,RT,PSOION
DO INIT
KILL %DT,DTOUT,ZPR,POP
+4 KILL IOP,%ZIS
SET PSOION=ION
SET %ZIS="MQ"
DO ^%ZIS
IF POP
SET IOP=PSOION
DO ^%ZIS
GOTO EXIT
AUTPRT ;
+1 IF $GET(ZPR)!$DATA(IO("Q"))
Begin DoDot:1
+2 NEW ZTRTN,ZTDESC,ZTIO,ZTSAVE,ZTDTH,ZTSK,ZTREQ,ZTQUEUED
+3 if $GET(ZPR)
SET ZTIO="`"_ZPR
SET ZTDTH=$HOROLOG
SET ZTRTN="OEN^PSODEARA"
+4 SET ZTSAVE("PSONS")=""
SET ZTSAVE("RHD")=""
SET ZTSAVE("RT")=""
SET ZTSAVE("FSP")=""
+5 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Report is Queued to print !!"
End DoDot:1
GOTO EXIT
OEN ;
+1 USE IO
+2 NEW PAGE,LINE,LEN,XTV,ARR,I,J,RHD,HCL,FSP,RDT,DV,FE,NPIEN,RET,PSOSPS
+3 NEW DV,ND,DAT,IEN,DVS,CNT,NDEA,DEA,DEAVA,PSOSRC,PSOSRCI
KILL DIRUT,DTOUT
+4 SET CNT=0
+5 KILL ^XTMP(PSONS,$JOB),^TMP(PSONS,$JOB)
+6 SET NPIEN=.99
FOR
SET NPIEN=$ORDER(^VA(200,NPIEN))
if 'NPIEN
QUIT
Begin DoDot:1
+7 IF '$$ACTIVE^XUSER(NPIEN)
QUIT
+8 KILL DAT
DO DEALIST^PSOEPUT(.DAT,NPIEN)
+9 IF '$DATA(DAT)
Begin DoDot:2
+10 SET DAT(1)="^^^^^^^^^^^^^"
End DoDot:2
+11 SET NDEA=0
FOR
SET NDEA=$ORDER(DAT(NDEA))
if 'NDEA
QUIT
Begin DoDot:2
+12 SET DAT(NDEA)=$$UP^XLFSTR(DAT(NDEA))
+13 ;Check for no new DEA numbers, use 200 schedules
DO DATCHK
+14 ;Quit if no data
IF DAT(NDEA)?1"^"."^"
QUIT
+15 SET CNT=CNT+1
+16 SET ^TMP(PSONS,$JOB,CNT)=NPIEN_"^"_DAT(NDEA)
+17 SET (DV,DVS)=0
FOR
SET DV=$ORDER(^VA(200,NPIEN,2,DV))
if ('DV)&(DVS>0)
QUIT
if 'DV
SET DV=999999
Begin DoDot:3
+18 SET DVS=DVS+1
+19 SET ^XTMP(PSONS,$JOB,DV,CNT)=""
+20 if $ORDER(^VA(200,NPIEN,2,DV))
SET ^XTMP(PSONS,$JOB,"Z",NPIEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+21 SET RHD="PRESCRIBERS WITH PRIVILEGES"
+22 SET HCL=(80-$LENGTH(RHD))\2
SET RDT=$$UP^XLFSTR($$FMTE^XLFDT($$NOW^XLFDT,"1M"))
+23 SET PAGE=1
SET $PIECE(LINE,"-",79)=""
SET $PIECE(FSP," ",25)=""
+24 DO HD
+25 IF '$DATA(^XTMP(PSONS,$JOB))
Begin DoDot:1
+26 WRITE !!," *************** NO MATCHING DATA ***************",!!
End DoDot:1
GOTO QT
+27 SET DV=""
FOR
SET DV=$ORDER(^XTMP(PSONS,$JOB,DV))
if 'DV
QUIT
Begin DoDot:1
+28 KILL ARR
SET LEN="DIVISION: "_$SELECT(DV=999999:"NO DIVISION",1:$$GET1^DIQ(4,DV,.01))
+29 WRITE !!,?9,LEN
+30 SET ND=0
FOR
SET ND=$ORDER(^XTMP(PSONS,$JOB,DV,ND))
if 'ND
QUIT
Begin DoDot:2
+31 SET DAT=^TMP(PSONS,$JOB,ND)
SET NPIEN=$PIECE(DAT,"^")
SET DEA=$PIECE(DAT,"^",2)
+32 ;P731 detox/x-waiver removal
IF $PIECE(DAT,"^",3)=.03
QUIT
+33 ;check for a schedule
IF $PIECE(DAT,"^",9,14)'["Y"
QUIT
+34 SET ARR(NPIEN)=""
+35 SET PSOSPS=$GET(^VA(200,NPIEN,"PS"))
+36 WRITE !,$EXTRACT($$GET1^DIQ(200,NPIEN,.01)_FSP,1,25),?32,$EXTRACT(NPIEN_FSP,1,12),?45,$EXTRACT(DEA_FSP,1,13),?60,$EXTRACT($PIECE(PSOSPS,U,3)_FSP,1,15)
+37 WRITE ?72,$EXTRACT($SELECT($PIECE(DAT,"^",15)="":"NO",1:$PIECE(DAT,"^",15))_FSP,1,5)
+38 WRITE !," SCHEDULE II:",?29,$SELECT($PIECE(DAT,"^",9)="":"NO",1:$PIECE(DAT,"^",9))
+39 WRITE !," SCHEDULE II NON:",?29,$SELECT($PIECE(DAT,"^",10)="":"NO",1:$PIECE(DAT,"^",10))
+40 WRITE !," SCHEDULE III:",?29,$SELECT($PIECE(DAT,"^",11)="":"NO",1:$PIECE(DAT,"^",11))
+41 WRITE !," SCHEDULE III NON:",?29,$SELECT($PIECE(DAT,"^",12)="":"NO",1:$PIECE(DAT,"^",12))
+42 WRITE !," SCHEDULE IV:",?29,$SELECT($PIECE(DAT,"^",13)="":"NO",1:$PIECE(DAT,"^",13))
+43 WRITE !," SCHEDULE V:",?29,$SELECT($PIECE(DAT,"^",14)="":"NO",1:$PIECE(DAT,"^",14))
+44 SET PSOSRC=""
SET PSOSRCI=$PIECE(DAT,"^",8)
Begin DoDot:3
+45 IF PSOSRCI']""
SET PSOSRC=" (Source: File #200)"
QUIT
+46 SET PSOSRC=$$GET1^DIQ(8991.9,PSOSRCI,.07)
+47 IF PSOSRC="INDIVIDUAL"
SET PSOSRC=" (Source: File #8991.9)"
QUIT
+48 IF PSOSRC="INSTITUTIONAL"
SET PSOSRC=" (Source: File #200)"
QUIT
End DoDot:3
WRITE PSOSRC
+49 if ($Y+4)>IOSL
DO HD
End DoDot:2
if $DATA(DIRUT)
QUIT
+50 SET J=0
FOR
SET J=$ORDER(ARR(J))
if 'J
QUIT
if $DATA(^XTMP(PSONS,$JOB,"Z",J))
DO FT
End DoDot:1
if $DATA(DIRUT)
GOTO QT
QT ;
+1 KILL DIR,DTOUT,DUOUT,DIRUT
+2 DO EXIT
+3 QUIT
+4 ;
EXIT KILL ^TMP(PSONS,$JOB),^XTMP(PSONS,$JOB)
+1 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 QUIT
+3 ;
HD ;
+1 IF PAGE>1
IF $EXTRACT(IOST)="C"
SET DIR(0)="E"
SET DIR("A")=" Press Return to Continue or ^ to Exit"
DO ^DIR
KILL DIR
+2 if $DATA(DIRUT)!($DATA(DTOUT))
QUIT
+3 WRITE @IOF
+4 WRITE !,RHD,?50,RDT,?72,"PAGE "_PAGE
SET PAGE=PAGE+1
+5 WRITE !,"NAME",?32,"DUZ",?45,"DEA #",?60,"VA#",?73,"INPAT"
+6 WRITE !,?45,"(E)=EXPIRED"
+7 WRITE !,LINE
+8 QUIT
+9 ;
FT ;
+1 SET LEN="**Note: This user is defined under these divisions"
+2 WRITE !!,LEN
+3 WRITE !
FOR I=1:1:$LENGTH(LEN)
WRITE "-"
+4 SET (DAT,ND)=0
FOR
SET ND=$ORDER(^VA(200,J,2,ND))
if 'ND
QUIT
Begin DoDot:1
+5 SET DAT=DAT+1
WRITE !
if DAT=1
WRITE $$GET1^DIQ(200,J,.01)
WRITE ?32,$$GET1^DIQ(4,ND,.01)
End DoDot:1
+6 IF $EXTRACT(IOST)="C"
SET DIR(0)="E"
DO ^DIR
KILL DIR
+7 QUIT
+8 ;
INIT ;
+1 SET PSONS="PSODEAA"
SET $PIECE(FSP," ",25)=""
+2 SET RHD="PRINT PRESCRIBERS WITH PRIVILEGES"
+3 SET ZPR=""
+4 SET RT=$$NOW^XLFDT
+5 KILL ^XTMP(PSONS,$JOB),^TMP(PSONS,$JOB)
+6 QUIT
+7 ;
GUI ;
+1 NEW PSONS,ZPR,RHD,RT,PSOSCR,BDT,EDT,PSOION
+2 DO INIT
KILL %DT,DTOUT,ZPR
+3 ;
+4 ;I $G(ECPTYP)="E" D EXPORT,^EPCSKILL Q ; ePCS not exporting to Excel at this point
+5 SET PSOSCR=$SELECT($EXTRACT($GET(IOST),1,2)="C-":1,1:0)
+6 ;
+7 ; Run Report
DO OEN
+8 ;I $D(EPCSGUI) D ^EPCSKILL Q // Kill variables...
+9 QUIT
+10 ;
DATCHK ;Check for no new DEA numbers, use 200 schedules
+1 NEW X,EXPDTFM,NPSCHED,RET,Y
+2 SET RET=""
+3 SET X=$PIECE(DAT(NDEA),"^",1)
IF X=""
Begin DoDot:1
+4 ; Use #200 schedules
+5 KILL NPSCHED
DO GETS^DIQ(200,NPIEN_",","55.1:55.6","E","NPSCHED")
+6 ; SCHEDULE II NARCOTIC
SET RET=RET_NPSCHED(200,NPIEN_",",55.1,"E")_"^"
+7 ; SCHEDULE II NON-NARCOTIC
SET RET=RET_NPSCHED(200,NPIEN_",",55.2,"E")_"^"
+8 ; SCHEDULE III NARCOTIC
SET RET=RET_NPSCHED(200,NPIEN_",",55.3,"E")_"^"
+9 ; SCHEDULE III NON-NARCOTIC
SET RET=RET_NPSCHED(200,NPIEN_",",55.4,"E")_"^"
+10 ; SCHEDULE IV
SET RET=RET_NPSCHED(200,NPIEN_",",55.5,"E")_"^"
+11 ; SCHEDULE V
SET RET=RET_NPSCHED(200,NPIEN_",",55.6,"E")_"^"
+12 SET DAT(NDEA)=$PIECE(DAT(NDEA),"^",1,7)_"^"_RET_"^"_$PIECE(DAT(NDEA),"^",14)
+13 SET DAT(NDEA)=$$UP^XLFSTR(DAT(NDEA))
End DoDot:1
+14 SET X=$PIECE(DAT(NDEA),"^",5)
IF X]""
Begin DoDot:1
+15 DO ^%DT
SET EXPDTFM=Y
if Y<0
QUIT
+16 IF EXPDTFM'<DT
QUIT
+17 if $PIECE(DAT(NDEA),"^",1)]""
SET $PIECE(DAT(NDEA),"^",1)=$PIECE(DAT(NDEA),"^",1)_"(E)"
End DoDot:1
+18 QUIT
+19 ;
