APSPPDEA ;IHS/MSC/MGH - PROVIDER DEA REPORT ;21-Oct-2011 09:16;MGH
;;7.0;IHS PHARMACY MODIFICATIONS;**1013**;Sep 23, 2004;Build 33
EN ;EP
N APSPTYP,APSPNUM,APSPTERM,APSPQ,APSPDR,APSPDARY,APSPNAME,QFLG,APSPCNT
S (APSPQ,APSPTYP)=""
S APSPCNT=0
;All or individual providers
W @IOF
W !,"Provider IEN Report",!!
S APSPNUM=$$DIR^APSPUTIL("S^I:Individual Provider;A:All Providers","Lookup Individual Provider or List ALL Providers? ","A",,.APSPQ)
Q:APSPQ
I APSPNUM="I" D
.F D Q:QFLG
..S APSPDR=$$GETIEN1^APSPUTIL(200,"Select Provider: ",-1,"B")
..I APSPDR<1 S QFLG=1 Q
..S APSPNAME=$$GET1^DIQ(200,APSPDR,.01)
..S APSPTERM=$$GET1^DIQ(200,APSPDR,9.2,,"I")
..I (APSPTERM=""!(APSPTERM>DT))&($P($G(^VA(200,APSPDR,"PS")),U)) D
...S X=$$ORDROLE(APSPDR)
...I X'=3 W !,APSPNAME_" is not a provider."
...I X=3 D
....S APSPDARY(APSPNAME)=APSPDR
....S APSPCNT=APSPCNT+1
..E D
...W !,APSPNAME_" is not an active provider."
..S QFLG='$$DIRYN^APSPUTIL("Want to Select Another Provider","No","Enter a 'Y' or 'YES' to include more providers in your search",.APSPQ)
..S:'QFLG QFLG=APSPQ
Q:APSPQ
I APSPNUM="A" D DEV
I APSPNUM="I"&($D(APSPDARY)) D DEV
Q
DEV ;EP
N XBRP,XBNS
S XBRP="OUT^APSPPDEA"
S XBNS="APS*"
D ^XBDBQUE
Q
OUT ;EP
N IEN,PROV,X,DEA,EXP,PIEN,PRV,TITLE
U IO
D HDR
K ^TMP($J)
I APSPNUM="A" D
.S APSPCNT=0
.S IEN=0 F S IEN=$O(^VA(200,IEN)) Q:IEN=""!('+IEN) D
..S X=$$ORDROLE(IEN)
..I X=3 D
...S APSPTERM=$$GET1^DIQ(200,IEN,9.2,,"I")
...I (APSPTERM=""!(APSPTERM>DT))&($P($G(^VA(200,IEN,"PS")),U)) D
....S PROV=$$GET1^DIQ(200,IEN,.01)
....S APSPDARY(PROV)=IEN
S PRV=0 F S PRV=$O(APSPDARY(PRV)) Q:PRV=""!(+APSPQ) D
.S PIEN=$G(APSPDARY(PRV))
.S DEA=$$GET1^DIQ(200,PIEN,53.2)
.S EXP=$$GET1^DIQ(200,PIEN,747.44)
.S TITLE=$E($$GET1^DIQ(200,PIEN,53.5),1,19)
.W !,$E(PRV,1,25),?26,TITLE,?50,DEA,?65,EXP
.I $Y+4>IOSL,IOST["C-" D PAUS Q:APSPQ D HDR
.Q:APSPQ=1
Q
PAUS ;
N DTOUT,DUOUT,DIR
S DIR("?")="Enter '^' to Halt or Press Return to continue"
S DIR(0)="FO",DIR("A")="Press Return to continue or '^' to Halt"
D ^DIR
I $D(DUOUT) S APSPQ=1
Q
HDR ;
N LIN
I IOST["C-" W @IOF
W !,"Provider List Report"
W !,"Provider Name",?26,"Class",?50,"DEA#",?65,"Exp Date"
W ! F LIN=1:1:72 W "-"
W !
Q
ORDROLE(IEN) ;EP
Q:$$HASKEY("OREMAS",IEN)+$$HASKEY("ORELSE",IEN)+$$HASKEY("ORES",IEN)>1 5
Q:$$HASKEY("OREMAS",IEN) 1
Q:$$HASKEY("ORELSE",IEN) 2
Q:$$HASKEY("ORES",IEN)&$$ISPROV(IEN) 3
Q:$$ISPROV(IEN) 4
Q 0
; Returns true if user is a provider
ISPROV(IEN) ;EP
Q $$HASKEY("PROVIDER",IEN)
; Returns true if user has key
; KEY = Security key (or parameter if begins with "@")
; USR = IEN of user to check
HASKEY(KEY,USR) ;PEP - Does user have key?
Q:'$L(KEY) 1
S USR=$G(USR,DUZ)
I $E(KEY)="@" D GETPAR^CIAVMRPC(.KEY,$E(KEY,2,999),,,,USR) Q ''KEY
Q ''$D(^XUSEC(KEY,+USR))
APSPPDEA ;IHS/MSC/MGH - PROVIDER DEA REPORT ;21-Oct-2011 09:16;MGH
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1013**;Sep 23, 2004;Build 33
EN ;EP
+1 NEW APSPTYP,APSPNUM,APSPTERM,APSPQ,APSPDR,APSPDARY,APSPNAME,QFLG,APSPCNT
+2 SET (APSPQ,APSPTYP)=""
+3 SET APSPCNT=0
+4 ;All or individual providers
+5 WRITE @IOF
+6 WRITE !,"Provider IEN Report",!!
+7 SET APSPNUM=$$DIR^APSPUTIL("S^I:Individual Provider;A:All Providers","Lookup Individual Provider or List ALL Providers? ","A",,.APSPQ)
+8 IF APSPQ
QUIT
+9 IF APSPNUM="I"
Begin DoDot:1
+10 FOR
Begin DoDot:2
+11 SET APSPDR=$$GETIEN1^APSPUTIL(200,"Select Provider: ",-1,"B")
+12 IF APSPDR<1
SET QFLG=1
QUIT
+13 SET APSPNAME=$$GET1^DIQ(200,APSPDR,.01)
+14 SET APSPTERM=$$GET1^DIQ(200,APSPDR,9.2,,"I")
+15 IF (APSPTERM=""!(APSPTERM>DT))&($PIECE($GET(^VA(200,APSPDR,"PS")),U))
Begin DoDot:3
+16 SET X=$$ORDROLE(APSPDR)
+17 IF X'=3
WRITE !,APSPNAME_" is not a provider."
+18 IF X=3
Begin DoDot:4
+19 SET APSPDARY(APSPNAME)=APSPDR
+20 SET APSPCNT=APSPCNT+1
End DoDot:4
End DoDot:3
+21 IF '$TEST
Begin DoDot:3
+22 WRITE !,APSPNAME_" is not an active provider."
End DoDot:3
+23 SET QFLG='$$DIRYN^APSPUTIL("Want to Select Another Provider","No","Enter a 'Y' or 'YES' to include more providers in your search",.APSPQ)
+24 IF 'QFLG
SET QFLG=APSPQ
End DoDot:2
IF QFLG
QUIT
End DoDot:1
+25 IF APSPQ
QUIT
+26 IF APSPNUM="A"
DO DEV
+27 IF APSPNUM="I"&($DATA(APSPDARY))
DO DEV
+28 QUIT
DEV ;EP
+1 NEW XBRP,XBNS
+2 SET XBRP="OUT^APSPPDEA"
+3 SET XBNS="APS*"
+4 DO ^XBDBQUE
+5 QUIT
OUT ;EP
+1 NEW IEN,PROV,X,DEA,EXP,PIEN,PRV,TITLE
+2 USE IO
+3 DO HDR
+4 KILL ^TMP($JOB)
+5 IF APSPNUM="A"
Begin DoDot:1
+6 SET APSPCNT=0
+7 SET IEN=0
FOR
SET IEN=$ORDER(^VA(200,IEN))
IF IEN=""!('+IEN)
QUIT
Begin DoDot:2
+8 SET X=$$ORDROLE(IEN)
+9 IF X=3
Begin DoDot:3
+10 SET APSPTERM=$$GET1^DIQ(200,IEN,9.2,,"I")
+11 IF (APSPTERM=""!(APSPTERM>DT))&($PIECE($GET(^VA(200,IEN,"PS")),U))
Begin DoDot:4
+12 SET PROV=$$GET1^DIQ(200,IEN,.01)
+13 SET APSPDARY(PROV)=IEN
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+14 SET PRV=0
FOR
SET PRV=$ORDER(APSPDARY(PRV))
IF PRV=""!(+APSPQ)
QUIT
Begin DoDot:1
+15 SET PIEN=$GET(APSPDARY(PRV))
+16 SET DEA=$$GET1^DIQ(200,PIEN,53.2)
+17 SET EXP=$$GET1^DIQ(200,PIEN,747.44)
+18 SET TITLE=$EXTRACT($$GET1^DIQ(200,PIEN,53.5),1,19)
+19 WRITE !,$EXTRACT(PRV,1,25),?26,TITLE,?50,DEA,?65,EXP
+20 IF $Y+4>IOSL
IF IOST["C-"
DO PAUS
IF APSPQ
QUIT
DO HDR
+21 IF APSPQ=1
QUIT
End DoDot:1
+22 QUIT
PAUS ;
+1 NEW DTOUT,DUOUT,DIR
+2 SET DIR("?")="Enter '^' to Halt or Press Return to continue"
+3 SET DIR(0)="FO"
SET DIR("A")="Press Return to continue or '^' to Halt"
+4 DO ^DIR
+5 IF $DATA(DUOUT)
SET APSPQ=1
+6 QUIT
HDR ;
+1 NEW LIN
+2 IF IOST["C-"
WRITE @IOF
+3 WRITE !,"Provider List Report"
+4 WRITE !,"Provider Name",?26,"Class",?50,"DEA#",?65,"Exp Date"
+5 WRITE !
FOR LIN=1:1:72
WRITE "-"
+6 WRITE !
+7 QUIT
ORDROLE(IEN) ;EP
+1 IF $$HASKEY("OREMAS",IEN)+$$HASKEY("ORELSE",IEN)+$$HASKEY("ORES",IEN)>1
QUIT 5
+2 IF $$HASKEY("OREMAS",IEN)
QUIT 1
+3 IF $$HASKEY("ORELSE",IEN)
QUIT 2
+4 IF $$HASKEY("ORES",IEN)&$$ISPROV(IEN)
QUIT 3
+5 IF $$ISPROV(IEN)
QUIT 4
+6 QUIT 0
+7 ; Returns true if user is a provider
ISPROV(IEN) ;EP
+1 QUIT $$HASKEY("PROVIDER",IEN)
+2 ; Returns true if user has key
+3 ; KEY = Security key (or parameter if begins with "@")
+4 ; USR = IEN of user to check
HASKEY(KEY,USR) ;PEP - Does user have key?
+1 IF '$LENGTH(KEY)
QUIT 1
+2 SET USR=$GET(USR,DUZ)
+3 IF $EXTRACT(KEY)="@"
DO GETPAR^CIAVMRPC(.KEY,$EXTRACT(KEY,2,999),,,,USR)
QUIT ''KEY
+4 QUIT ''$DATA(^XUSEC(KEY,+USR))
