- 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 Apr 23, 2025@18:41:04 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 ;
