PSOPRVW1 ;BIR/BI,MHA-enter/edit/view provider ; 11/9/2018
;;7.0;OUTPATIENT PHARMACY;**545,731**;DEC 1997;Build 18
;External reference to sub-file NEW DEA #'S (#200.5321) is supported by DBIA 7000
;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
;
Q
WS(X,PSOIENS,PSOWSDWN) ; -- Link the NEW PERSON FILE #200 DEA pointer to the DEA NUMBERS FILE #8991.9 record.
N DNDEAIEN,DA,DR,FDA
Q:$G(X)="" Q:$L(PSOIENS,",")'=3
S DNDEAIEN=$$EN^PSODEAME(X,PSOWSDWN)
I +DNDEAIEN D
. S FDA(2,200.5321,DIIENS,.03)=+DNDEAIEN
. D UPDATE^DIE("","FDA(2)")
Q
;
INS(X) ; -- Check for an Institutional DEA Number
N DNDEAIEN,TYPE
Q:$G(X)="" 0
S DNDEAIEN=$O(^XTV(8991.9,"B",X,0)) Q:'DNDEAIEN 0
S TYPE=$$GET1^DIQ(8991.9,DNDEAIEN,.07)
I TYPE="INSTITUTIONAL" Q 1
Q 0
;
NULL(X,DIIENS) ; -- Check for an User Exit without using the Copy function.
N DNDEAIEN,DA,DR,FDA,DQ,DP,DM,DL,DK
Q:$G(X)="" 0
S DNDEAIEN=$O(^XTV(8991.9,"B",X,0))
I '+DNDEAIEN D Q 1
. S DA=$P(DIIENS,",",1),DA(1)=$P(DIIENS,",",2)
. S DIE="^VA(200,"_DA(1)_",""PS4"","
. S DR=".01///@" D ^DIE
Q 0
;
DEAEDT(NPIEN) ; -- Code to use the DEA API to download and update DOJ/DEA Information
N DEAEDQ
S DEAEDQ=0
; Allow user to edit multiple DEA numbers without having to reselect provider and start over
F Q:$G(DEAEDQ) D DEAEDT1(NPIEN)
W !! D INPUSE(NPIEN)
Q
;
DEAEDT1(NPIEN) ; Select one DEA number and edit it
S DEAEDQ=0
I '$G(NPIEN) S DEAEDQ=1 Q
N %,%DT,CNT,DA,DIIENS,DIE,D,DI,DIC,DIR,DIRUT,DNDEAIEN,DNDEATXT,DR,D0,NPDEAIEN,NPDEALST,NPDEATXT,X,Y,SAVEX
N DK,DL,DM,DP,DQ,PSOWSDWN,PSODEAE
S PSOWSDWN=0 ; Web Service down flag
;
; Check VAMC/MbM mode
; If VAMC mode only allow for FEE BASIS and C & A provider types.
I '$$EDITCHK^PSOPRVW(NPIEN) S DEAEDQ=2
;
S NPDEALST(0)=0
S NPDEAIEN=0 F CNT=1:1 S NPDEAIEN=$O(^VA(200,NPIEN,"PS4",NPDEAIEN)) Q:'NPDEAIEN D
. S NPDEALST(CNT)=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.01)
. S $P(NPDEALST(CNT),U,2)=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.02)
. N F8991P9IE,F8991P9ER S F8991P9IE=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
. I '$$FIND1^DIC(8991.9,,"AX",F8991P9IE,,,"F8991P9ER"),($P(NPDEALST(CNT),U,3)="") S $P(NPDEALST(CNT),U,2)=" **ERROR-MISSING FROM DEA NUMBERS FILE**"
. S $P(NPDEALST(CNT),U,3)=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
. S $P(NPDEALST(CNT),U,4)=NPDEAIEN_","_NPIEN_","
. S:$P(NPDEALST(CNT),U,3) $P(NPDEALST(CNT),U,5)=$$GET1^DIQ(8991.9,$P(NPDEALST(CNT),U,3)_",",1.6)
. S:$P(NPDEALST(CNT),U,3) $P(NPDEALST(CNT),U,6)=$$GET1^DIQ(8991.9,$P(NPDEALST(CNT),U,3)_",",.03)
. S NPDEALST("B",$P(NPDEALST(CNT),U,1))=NPDEALST(CNT)
. S NPDEALST(0)=CNT
W !!,"DEA NUMBERS",!
I 'NPDEALST(0) W ?5," * NO DEA NUMBERS ON FILE *",!
F CNT=1:1:NPDEALST(0) D
. Q:'$D(NPDEALST(CNT))
. W $E(" ",1,5-$L(CNT)),CNT," - ",$P(NPDEALST(CNT),U,1)
. W:$P(NPDEALST(CNT),U,2)'="" "-",$P(NPDEALST(CNT),U,2)
. W " ",$P(NPDEALST(CNT),U,5)
. ;P731 detox/x-waiver removal
. ;W:$P(NPDEALST(CNT),U,6)'="" " Contains Detox # ",$P(NPDEALST(CNT),U,6)
. W:$O(NPDEALST(CNT)) !
I $G(DEAEDQ)=2 D Q
.W !,"Use EPCS GUI (EPCS Data Entry for Prescriber) to manage this provider's DEA"
.W !,"numbers."
Q:$G(DEAEDQ)
K DIRUT,DIR
S DIR(0)="FO^1:9^K:'$$DEAEDTST^PSOPRVW1(X,.NPDEALST,NPIEN,.PSOWSDWN) X"
;
I $O(^VA(200,+$G(NPIEN),"PS4",0)) S DIR("A",1)="SELECT an existing entry to edit,"
I $O(^VA(200,+$G(NPIEN),"PS4",0)) S DIR("A",2)="or type '@' to delete an existing entry."
S DIR("A")="Type a DEA number (e.g., AA1234563) to begin a new entry"
;
S DIR("?")="^D DEAHELP^PSOPRVW1"
;
D ^DIR S:X="@" DIRUT=0 I $G(DIRUT) S DEAEDQ=1 Q
S (PSODEAE,SAVEX)=X S PSODEANW='$$FIND1^DIC(8991.9,,"QA",$G(PSODEAE))
I $G(PSOWSDWN)&$G(PSODEANW) D Q
.N DIR,ASTRSK S $P(ASTRSK,"*",75)="*"
.S DIR("A",1)=" ",DIR("A",2)=" "_$E(ASTRSK,1,60)
.S DIR("A",3)=" UNABLE TO ESTABLISH A CONNECTION TO THE DOJ/DEA WEB SERVER "
.S DIR("A",4)=" DEA number "_PSODEAE_" cannot be added at this time "
.S DIR("A",5)=" "_$E(ASTRSK,1,60),DIR("A",6)=" "
.S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K X,Y,DIRUT,DUOUT
I '$D(NPDEALST(X))&('$D(NPDEALST("B",X))) D
. Q:$E(X)="@"
. S:'$D(^VA(200,NPIEN,"PS4",0)) ^VA(200,NPIEN,"PS4",0)="^200.5321^^0"
. S DIIENS=$O(^VA(200,NPIEN,"PS4",999),-1)+1_","_NPIEN_","
. S DA=$P(DIIENS,",",1),DA(1)=$P(DIIENS,",",2)
. S DIE="^VA(200,"_DA(1)_",""PS4"","
. S DR=".01///"_X D ^DIE
S X=SAVEX
I $D(NPDEALST(X)) D
. S DNDEATXT=$P(NPDEALST(X),U,1)
. S DNDEAIEN=$P(NPDEALST(X),U,3)
. S DIIENS=$P(NPDEALST(X),U,4)
I $D(NPDEALST("B",X)) D
. S DNDEATXT=$P(NPDEALST("B",X),U,1)
. S DNDEAIEN=$P(NPDEALST("B",X),U,3)
. S DIIENS=$P(NPDEALST("B",X),U,4)
S X=SAVEX
I X="@",$$DELDEA(.NPDEALST,NPIEN) Q ; 731 - Include Provider IEN
I X="@" Q ;S DEAEDQ=1 Q
S NPDEATXT=$$GET1^DIQ(200.5321,DIIENS,.01)
D WS^PSOPRVW1(NPDEATXT,DIIENS,PSOWSDWN)
I $$NULL^PSOPRVW1(NPDEATXT,DIIENS) Q
I '$$INS^PSOPRVW1(NPDEATXT) Q
S DA=$P(DIIENS,",",1),DA(1)=$P(DIIENS,",",2)
S DIE="^VA(200,"_DA(1)_",""PS4"",",DR=".02R",DIE("NO^")="NO" D ^DIE
I '$D(DA),$D(DNDEATXT),DNDEAIEN,'$D(^VA(200,"PS4",DNDEATXT)) D
. K FDA S FDA(1,8991.9,DNDEAIEN_",",.06)=0 D UPDATE^DIE("","FDA(1)") K FDA
Q
;
DEAEDTST(X,NPDEALST,NPIEN,PSOWSDWN) ; -- Input Transform for the DEAEDT Tag.
N DIR,DNDEAIEN,FG,INST,LNAME,RESPONSEX,PSOASTK
S RESPONSE=0,$P(PSOASTK,"*",75)="*"
I X="@" S RESPONSE=1 G DEAEDTSX
I $D(NPDEALST(X)) S RESPONSE=1 G DEAEDTSX
I '$$DEANUM^PSODEAUT(X) S RESPONSE=0 D G DEAEDTSX
. D EN^DDIOL($C(7)_" "),EN^DDIOL($C(7)_" DEA number is invalid. Please check the number entered.")
. S RESPONSE=0
I '$$DEANUMFL^PSODEAUT(X) S RESPONSE=0 G DEAEDTSX
S DNDEAIEN=$O(^XTV(8991.9,"B",X,0)),INST=$$GET1^DIQ(8991.9,DNDEAIEN,.07,"I")
I INST'=1,$D(X),$D(NPIEN),$D(^VA(200,"PS4",X)),$O(^(X,0))'=NPIEN D G DEAEDTSX
. D EN^DDIOL($C(7)_" "),EN^DDIOL($C(7)_$E(PSOASTK,1,70))
. D EN^DDIOL($C(7)_" DEA number "_X_" has already been assigned to another provider:")
. N DUPIEN S DUPIEN=$O(^VA(200,"PS4",X,"")) I DUPIEN S DUPNAME=$P($G(^VA(200,+DUPIEN,0)),U)
. I DUPIEN D
. . D EN^DDIOL($C(7)_" NAME: "_$G(DUPNAME))
. . D EN^DDIOL($C(7)_" IEN: "_DUPIEN)
. D EN^DDIOL($C(7)_$E(PSOASTK,1,70))
. D EN^DDIOL($C(7)_"Please check the number entered.")
. S RESPONSE=0
. N DIR W ! S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K X,Y,DIRUT,DUOUT
S RESPONSE=$$WSGET^PSODEAUT(.FG,X)
I 'RESPONSE!($P(RESPONSE,U,3)=6059) D G DEAEDTSX
.S PSOECODE=$P(RESPONSE,U,3) I PSOECODE=6059 S RESPONSE=PSOECODE_"^"_RESPONSE,PSOWSDWN=1 Q
.I '$G(PSOWSDWN) W !!,"*** "_$P(RESPONSE,U,2)_" ***"
.S RESPONSE=0
;
; Test for name match, provide an option to reject.
S LNAME=$$GET1^DIQ(200,NPIEN,.01)
I $G(FG("name"))'="" I $P(FG("name"),",",1)'=$P(LNAME,",",1) D
. W !!,"DOJ NAME: ",FG("name")
. W !,"VISTA NAME: ",LNAME,!
. S DIR(0)="Y"
. S DIR("A",1)="The last names don't match."
. S DIR("A")="Do you really want to continue"
. D ^DIR I Y'=1 S RESPONSE=0
;
DEAEDTSX ; Subroutine Exit Tag
Q RESPONSE
;
INPUSE(NPIEN) ; -- Subroutine to set the DEA NUMBER "USE FOR INPATIENT ORDERS?" flag.
N CNT,DEACNT,DIR,DIRUT,DNDEAIEN,FDA,MULTIP,NPDEAIEN,NPDEALST,UFIO,UFIOCNTY,UFIOCNTN,X,XSAVE,Y S UFIOCNTY=0,UFIOCNTN=0
;
I '$O(^VA(200,NPIEN,"PS4",0)) Q
;
; Loop through the DEA numbers in the NEW PERSON FILE #200
S CNT=0,DEACNT=0,NPDEAIEN=0 F S NPDEAIEN=$O(^VA(200,NPIEN,"PS4",NPDEAIEN)) Q:'NPDEAIEN D
. ;
. ; Get the DEA NUMBER IEN from the pointer in the NEW PERSON FILE
. S DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I") Q:'DNDEAIEN
. ;
. ; Test for an INSTITUTIONAL DEA; ignore INSTITIONAL DEA Numbers?
. Q:$$GET1^DIQ(8991.9,DNDEAIEN,.07,"I")'=2
. ;
. ; Load the New Person Dea List (NPDEALST)
. ; Piece: 1 - DEA NUMBER
. ; 2 - DEA POINTER; POINTER TO DEA NUMBERS FILE (#8991.9)
. ; 3 - USE FOR INPATIENT ORDERS? flag from the DEA NUMBERS FILE (#8991.9)
. S CNT=CNT+1
. S $P(NPDEALST(CNT),U,1)=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN,.01)
. S $P(NPDEALST(CNT),U,2)=DNDEAIEN
. S UFIO=$$GET1^DIQ(8991.9,DNDEAIEN,.06),$P(NPDEALST(CNT),U,3)=$S(UFIO="YES":"YES",1:"NO")
. S:UFIO="YES" UFIOCNTY=UFIOCNTY+1
. S:UFIO'="YES" UFIOCNTN=UFIOCNTN+1
. S DEACNT=CNT
Q:DEACNT=0
;
I DEACNT=1,$P(NPDEALST(1),U,3)="YES" Q
I DEACNT=1,$P(NPDEALST(1),U,3)'="YES" D Q
. K FDA S FDA(1,8991.9,$P(NPDEALST(1),U,2)_",",.06)=1 D UPDATE^DIE("","FDA(1)") K FDA
;
; Write the list to the screen, identifying the current DEA NUMBER to "USE FOR INPATIENT ORDERS?"
W "USE FOR INPATIENT ORDERS",!
S CNT=0 F S CNT=$O(NPDEALST(CNT)) Q:'CNT D
. W $E(" ",1,5-$L(CNT)),CNT," - ",$P(NPDEALST(CNT),U,1)," - "_$P(NPDEALST(CNT),U,3)
. W:$O(NPDEALST(CNT)) !
;
IPSLOOP ; Loop to prevent the user from existing without selecting a DEA number for inpatient usage.
; Set up the user interface prompt to select the "ONE" DEA NUMBER to be used for inpatient orders.
; If there are more than one DEA NUMBER currently and none selected, make it a required response.
; If there are more than one DEA NUMBER currently selected, make it a required response.
; If there is only one DEA NUMBER, make it a required response, and default to 1.
K DIRUT,DIR S DIR(0)="F"_$S(UFIOCNTY=0:"",UFIOCNTY>1:"",DEACNT=1:"",1:"O")_"^1:9^K:'$D(NPDEALST(X)) X"
S DIR("A")="SELECT a DEA NUMBER to change INPATIENT USAGE"
S:DEACNT=1 DIR("B")=1
S DIR("?",1)="Select a choice from the list above."
S DIR("?")="Must be a numeric value from the list above."
D ^DIR
I UFIOCNTY=0,((X="^")!(X="^^")) W !!,"THERE MUST BE ONE DEA SELECTED FOR INPATIENT ORDERS." G IPSLOOP
I UFIOCNTY>1,((X="^")!(X="^^")) W !!,"THERE CAN BE ONLY ONE DEA SELECTED FOR INPATIENT ORDERS." G IPSLOOP
I $G(DIRUT) W ! Q
W !
S XSAVE=X
;
; Set up the FDA array; marking the selected DEA NUMBER equal to YES(1) and the other DEA NUMBERS equal to NO(0)
S CNT=0,MULTIP=0 F S CNT=$O(NPDEALST(CNT)) Q:'CNT D
. I CNT=XSAVE S FDA(1,8991.9,$P(NPDEALST(CNT),U,2)_",",.06)=1 Q
. I $P(NPDEALST(CNT),U,3)="YES" D
.. S MULTIP=MULTIP+1
.. W !,"DEA # "_$P(NPDEALST(CNT),U,1)_" is already flagged as ""Use for Inpatient Orders""."
.. S FDA(1,8991.9,$P(NPDEALST(CNT),U,2)_",",.06)=0
;
; Ask the user to verify the "Update". Apply the FDA array for a "YES" response.
K DIRUT,DIR
I MULTIP D
. S DIR(0)="Y",DIR("B")="YES"
. S DIR("A",1)="The previous DEA # will no longer be flagged as ""Use for Inpatient Orders""."
. S DIR("A")="Do you want to proceed with this change"
. D ^DIR
I Y=1 D UPDATE^DIE("","FDA(1)")
I 'MULTIP D UPDATE^DIE("","FDA(1)")
;
; Re-Display the changes.
W !
N NPDEATXT S NPDEAIEN=0 F S NPDEAIEN=$O(^VA(200,NPIEN,"PS4",NPDEAIEN)) Q:'NPDEAIEN D
. S DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I") Q:'DNDEAIEN
. Q:$$GET1^DIQ(8991.9,DNDEAIEN,.07,"I")'=2
. S NPDEATXT=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN,.01)
. S UFIO=$$GET1^DIQ(8991.9,DNDEAIEN,.06)
. W " ",NPDEATXT," - "_$S(UFIO="YES":"YES",1:"NO"),!
Q
;
DELDEA(NPDEALST,NPIEN) ; -- Code used to add/edit/delete the VA Number
N ACNT,D,DA,DEATYPE,DI,DIC,DIE,DIE1,DIEDA,DIEL,DIETMP,DIEXREF,DIFLD,DIR,DNDEAIEN
N DNDETOX,DR,NPDEACNT,NPDEATXT,RESPONSE,VANUMBER,X,Y,SELECTED
S RESPONSE=0
I '$G(NPDEALST(0)) D Q RESPONSE
. W " ** No DEA Numbers to Delete ** "
K DIRUT,DIR S DIR(0)="NO^1:"_NPDEALST(0)_":0^"
S DIR("A",1)=" "
S DIR("A")="Select a choice from the list for DELETION."
S DIR("?")="Enter a number from the list above."
D ^DIR I $G(DIRUT) G DELDEAQ
S SELECTED=X
S DIIENS=$P(NPDEALST(SELECTED),"^",4)
I $L(DIIENS,",")'=3 G DELDEAQ
S NPDEACNT=$$NPDEACNT($P(DIIENS,",",2))
S VANUMBER=$$GET1^DIQ(200,$P(DIIENS,",",2),53.3)
S NPDEATXT=$$GET1^DIQ(200.5321,DIIENS,.01)
S DNDEAIEN=$$GET1^DIQ(200.5321,DIIENS,.03,"I")
S DNDETOX=$$GET1^DIQ(8991.9,DNDEAIEN,.03)
S DEATYPE=$$GET1^DIQ(8991.9,DNDEAIEN,.07,"I")
S DA=$P(DIIENS,",",1),DA(1)=$P(DIIENS,",",2)
S DIR("A")="DO YOU STILL WANT TO DELETE THIS DEA NUMBER"
S ACNT=0
S ACNT=ACNT+1,DIR("A",ACNT)=" "
S ACNT=ACNT+1,DIR("A",ACNT)="Removing the DEA number does not affect previously written prescriptions."
I VANUMBER="",NPDEACNT=1 D
. S ACNT=ACNT+1,DIR("A",ACNT)="This is the only DEA number on file for this provider. The provider will no"
. S ACNT=ACNT+1,DIR("A",ACNT)="longer be able to prescribe controlled substances at the VA."
;P731 detox/x-waiver removal
;I DNDETOX'="" D
;. S ACNT=ACNT+1,DIR("A",ACNT)="This DEA # contains Detox # "_DNDETOX_". To maintain the Detox #,"
;. S ACNT=ACNT+1,DIR("A",ACNT)="please add it to another DEA # on the provider's profile."
S ACNT=ACNT+1,DIR("A",ACNT)=" "
S DIR(0)="Y" D ^DIR K DIR G:Y'=1 DELDEAQ
S DIE="^VA(200,"_DA(1)_",""PS4"",",DR=".01///@" D ^DIE K DIE,DR,DA
I DEATYPE=2 D
. S DA=DNDEAIEN,DIK="^XTV(8991.9," D ^DIK K DIK,DA
. N PSOLDEA,PSODELDEA S PSOLDEA=$$GET1^DIQ(200,NPIEN,53.2),PSODELDEA=$P($G(NPDEALST(+$G(SELECTED))),"^") ; 731 - Remove DEA# field (#53.2) if no remaining DEAs
. Q:PSOLDEA="" I (PSOLDEA=PSODELDEA)!(($O(NPDEALST(999),-1)=1)&(SELECTED=1)) K DIE,DA,DR,X S DIE="^VA(200,",DA=NPIEN,DR="53.2///@" D ^DIE K DIE,DR,DA
S RESPONSE=1
DELDEAQ ; -- Common Exit Point
Q RESPONSE
;
NPDEACNT(NPIEN) ; -- Function used to count the number of DEA numbers for a provider.
N NPDEAIEN,NPDEACNT
S NPDEAIEN=0 F NPDEACNT=0:1 S NPDEAIEN=$O(^VA(200,NPIEN,"PS4",NPDEAIEN)) Q:+NPDEAIEN=0
Q NPDEACNT
;
DEAHELP ; DEA prompt help text for ^DIR(0)
I $G(X)'="?" D REDISP Q
W !,"Enter a New DEA Number."
I $O(^VA(200,+$G(NPIEN),"PS4",0)) W !,"Select a choice from the list above or,"
I $O(^VA(200,+$G(NPIEN),"PS4",0)) W !,"Or type '@' to delete an existing entry."
W !,"DEA NUMBERS must be valid, 2 letters and 7 numbers."
;
D REDISP
Q
;
REDISP ; Redisplay DEA numbers
N NPDEALST,CNT
S NPDEALST(0)=0
S NPDEAIEN=0 F CNT=1:1 S NPDEAIEN=$O(^VA(200,NPIEN,"PS4",NPDEAIEN)) Q:'NPDEAIEN D
. S NPDEALST(CNT)=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.01)
. S $P(NPDEALST(CNT),U,2)=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.02)
. S $P(NPDEALST(CNT),U,3)=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
. N F8991P9IE,F8991P9ER S F8991P9IE=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
. I '$$FIND1^DIC(8991.9,,"AX",F8991P9IE,,,"F8991P9ER"),($P(NPDEALST(CNT),U,3)="") S $P(NPDEALST(CNT),U,2)=" **ERROR-MISSING FROM DEA NUMBERS FILE**"
. S $P(NPDEALST(CNT),U,4)=NPDEAIEN_","_NPIEN_","
. S:$P(NPDEALST(CNT),U,3) $P(NPDEALST(CNT),U,5)=$$GET1^DIQ(8991.9,$P(NPDEALST(CNT),U,3)_",",1.6)
. S:$P(NPDEALST(CNT),U,3) $P(NPDEALST(CNT),U,6)=$$GET1^DIQ(8991.9,$P(NPDEALST(CNT),U,3)_",",.03)
. S NPDEALST("B",$P(NPDEALST(CNT),U,1))=NPDEALST(CNT)
. S NPDEALST(0)=CNT
W !!,"DEA NUMBERS",!
I 'NPDEALST(0) W ?5," * NO DEA NUMBERS ON FILE *",!
F CNT=1:1:NPDEALST(0) D
. Q:'$D(NPDEALST(CNT))
. W $E(" ",1,5-$L(CNT)),CNT," - ",$P(NPDEALST(CNT),U,1)
. W:$P(NPDEALST(CNT),U,2)'="" "-",$P(NPDEALST(CNT),U,2)
. W " ",$P(NPDEALST(CNT),U,5)
. ;P731 detox/x-waiver removal
. ;W:$P(NPDEALST(CNT),U,6)'="" " Contains Detox # ",$P(NPDEALST(CNT),U,6)
. W:$O(NPDEALST(CNT)) !
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOPRVW1 15316 printed Apr 09, 2024@21:26:24 Page 2
PSOPRVW1 ;BIR/BI,MHA-enter/edit/view provider ; 11/9/2018
+1 ;;7.0;OUTPATIENT PHARMACY;**545,731**;DEC 1997;Build 18
+2 ;External reference to sub-file NEW DEA #'S (#200.5321) is supported by DBIA 7000
+3 ;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
+4 ;
+5 QUIT
WS(X,PSOIENS,PSOWSDWN) ; -- Link the NEW PERSON FILE #200 DEA pointer to the DEA NUMBERS FILE #8991.9 record.
+1 NEW DNDEAIEN,DA,DR,FDA
+2 if $GET(X)=""
QUIT
if $LENGTH(PSOIENS,",")'=3
QUIT
+3 SET DNDEAIEN=$$EN^PSODEAME(X,PSOWSDWN)
+4 IF +DNDEAIEN
Begin DoDot:1
+5 SET FDA(2,200.5321,DIIENS,.03)=+DNDEAIEN
+6 DO UPDATE^DIE("","FDA(2)")
End DoDot:1
+7 QUIT
+8 ;
INS(X) ; -- Check for an Institutional DEA Number
+1 NEW DNDEAIEN,TYPE
+2 if $GET(X)=""
QUIT 0
+3 SET DNDEAIEN=$ORDER(^XTV(8991.9,"B",X,0))
if 'DNDEAIEN
QUIT 0
+4 SET TYPE=$$GET1^DIQ(8991.9,DNDEAIEN,.07)
+5 IF TYPE="INSTITUTIONAL"
QUIT 1
+6 QUIT 0
+7 ;
NULL(X,DIIENS) ; -- Check for an User Exit without using the Copy function.
+1 NEW DNDEAIEN,DA,DR,FDA,DQ,DP,DM,DL,DK
+2 if $GET(X)=""
QUIT 0
+3 SET DNDEAIEN=$ORDER(^XTV(8991.9,"B",X,0))
+4 IF '+DNDEAIEN
Begin DoDot:1
+5 SET DA=$PIECE(DIIENS,",",1)
SET DA(1)=$PIECE(DIIENS,",",2)
+6 SET DIE="^VA(200,"_DA(1)_",""PS4"","
+7 SET DR=".01///@"
DO ^DIE
End DoDot:1
QUIT 1
+8 QUIT 0
+9 ;
DEAEDT(NPIEN) ; -- Code to use the DEA API to download and update DOJ/DEA Information
+1 NEW DEAEDQ
+2 SET DEAEDQ=0
+3 ; Allow user to edit multiple DEA numbers without having to reselect provider and start over
+4 FOR
if $GET(DEAEDQ)
QUIT
DO DEAEDT1(NPIEN)
+5 WRITE !!
DO INPUSE(NPIEN)
+6 QUIT
+7 ;
DEAEDT1(NPIEN) ; Select one DEA number and edit it
+1 SET DEAEDQ=0
+2 IF '$GET(NPIEN)
SET DEAEDQ=1
QUIT
+3 NEW %,%DT,CNT,DA,DIIENS,DIE,D,DI,DIC,DIR,DIRUT,DNDEAIEN,DNDEATXT,DR,D0,NPDEAIEN,NPDEALST,NPDEATXT,X,Y,SAVEX
+4 NEW DK,DL,DM,DP,DQ,PSOWSDWN,PSODEAE
+5 ; Web Service down flag
SET PSOWSDWN=0
+6 ;
+7 ; Check VAMC/MbM mode
+8 ; If VAMC mode only allow for FEE BASIS and C & A provider types.
+9 IF '$$EDITCHK^PSOPRVW(NPIEN)
SET DEAEDQ=2
+10 ;
+11 SET NPDEALST(0)=0
+12 SET NPDEAIEN=0
FOR CNT=1:1
SET NPDEAIEN=$ORDER(^VA(200,NPIEN,"PS4",NPDEAIEN))
if 'NPDEAIEN
QUIT
Begin DoDot:1
+13 SET NPDEALST(CNT)=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.01)
+14 SET $PIECE(NPDEALST(CNT),U,2)=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.02)
+15 NEW F8991P9IE,F8991P9ER
SET F8991P9IE=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
+16 IF '$$FIND1^DIC(8991.9,,"AX",F8991P9IE,,,"F8991P9ER")
IF ($PIECE(NPDEALST(CNT),U,3)="")
SET $PIECE(NPDEALST(CNT),U,2)=" **ERROR-MISSING FROM DEA NUMBERS FILE**"
+17 SET $PIECE(NPDEALST(CNT),U,3)=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
+18 SET $PIECE(NPDEALST(CNT),U,4)=NPDEAIEN_","_NPIEN_","
+19 if $PIECE(NPDEALST(CNT),U,3)
SET $PIECE(NPDEALST(CNT),U,5)=$$GET1^DIQ(8991.9,$PIECE(NPDEALST(CNT),U,3)_",",1.6)
+20 if $PIECE(NPDEALST(CNT),U,3)
SET $PIECE(NPDEALST(CNT),U,6)=$$GET1^DIQ(8991.9,$PIECE(NPDEALST(CNT),U,3)_",",.03)
+21 SET NPDEALST("B",$PIECE(NPDEALST(CNT),U,1))=NPDEALST(CNT)
+22 SET NPDEALST(0)=CNT
End DoDot:1
+23 WRITE !!,"DEA NUMBERS",!
+24 IF 'NPDEALST(0)
WRITE ?5," * NO DEA NUMBERS ON FILE *",!
+25 FOR CNT=1:1:NPDEALST(0)
Begin DoDot:1
+26 if '$DATA(NPDEALST(CNT))
QUIT
+27 WRITE $EXTRACT(" ",1,5-$LENGTH(CNT)),CNT," - ",$PIECE(NPDEALST(CNT),U,1)
+28 if $PIECE(NPDEALST(CNT),U,2)'=""
WRITE "-",$PIECE(NPDEALST(CNT),U,2)
+29 WRITE " ",$PIECE(NPDEALST(CNT),U,5)
+30 ;P731 detox/x-waiver removal
+31 ;W:$P(NPDEALST(CNT),U,6)'="" " Contains Detox # ",$P(NPDEALST(CNT),U,6)
+32 if $ORDER(NPDEALST(CNT))
WRITE !
End DoDot:1
+33 IF $GET(DEAEDQ)=2
Begin DoDot:1
+34 WRITE !,"Use EPCS GUI (EPCS Data Entry for Prescriber) to manage this provider's DEA"
+35 WRITE !,"numbers."
End DoDot:1
QUIT
+36 if $GET(DEAEDQ)
QUIT
+37 KILL DIRUT,DIR
+38 SET DIR(0)="FO^1:9^K:'$$DEAEDTST^PSOPRVW1(X,.NPDEALST,NPIEN,.PSOWSDWN) X"
+39 ;
+40 IF $ORDER(^VA(200,+$GET(NPIEN),"PS4",0))
SET DIR("A",1)="SELECT an existing entry to edit,"
+41 IF $ORDER(^VA(200,+$GET(NPIEN),"PS4",0))
SET DIR("A",2)="or type '@' to delete an existing entry."
+42 SET DIR("A")="Type a DEA number (e.g., AA1234563) to begin a new entry"
+43 ;
+44 SET DIR("?")="^D DEAHELP^PSOPRVW1"
+45 ;
+46 DO ^DIR
if X="@"
SET DIRUT=0
IF $GET(DIRUT)
SET DEAEDQ=1
QUIT
+47 SET (PSODEAE,SAVEX)=X
SET PSODEANW='$$FIND1^DIC(8991.9,,"QA",$GET(PSODEAE))
+48 IF $GET(PSOWSDWN)&$GET(PSODEANW)
Begin DoDot:1
+49 NEW DIR,ASTRSK
SET $PIECE(ASTRSK,"*",75)="*"
+50 SET DIR("A",1)=" "
SET DIR("A",2)=" "_$EXTRACT(ASTRSK,1,60)
+51 SET DIR("A",3)=" UNABLE TO ESTABLISH A CONNECTION TO THE DOJ/DEA WEB SERVER "
+52 SET DIR("A",4)=" DEA number "_PSODEAE_" cannot be added at this time "
+53 SET DIR("A",5)=" "_$EXTRACT(ASTRSK,1,60)
SET DIR("A",6)=" "
+54 SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL X,Y,DIRUT,DUOUT
End DoDot:1
QUIT
+55 IF '$DATA(NPDEALST(X))&('$DATA(NPDEALST("B",X)))
Begin DoDot:1
+56 if $EXTRACT(X)="@"
QUIT
+57 if '$DATA(^VA(200,NPIEN,"PS4",0))
SET ^VA(200,NPIEN,"PS4",0)="^200.5321^^0"
+58 SET DIIENS=$ORDER(^VA(200,NPIEN,"PS4",999),-1)+1_","_NPIEN_","
+59 SET DA=$PIECE(DIIENS,",",1)
SET DA(1)=$PIECE(DIIENS,",",2)
+60 SET DIE="^VA(200,"_DA(1)_",""PS4"","
+61 SET DR=".01///"_X
DO ^DIE
End DoDot:1
+62 SET X=SAVEX
+63 IF $DATA(NPDEALST(X))
Begin DoDot:1
+64 SET DNDEATXT=$PIECE(NPDEALST(X),U,1)
+65 SET DNDEAIEN=$PIECE(NPDEALST(X),U,3)
+66 SET DIIENS=$PIECE(NPDEALST(X),U,4)
End DoDot:1
+67 IF $DATA(NPDEALST("B",X))
Begin DoDot:1
+68 SET DNDEATXT=$PIECE(NPDEALST("B",X),U,1)
+69 SET DNDEAIEN=$PIECE(NPDEALST("B",X),U,3)
+70 SET DIIENS=$PIECE(NPDEALST("B",X),U,4)
End DoDot:1
+71 SET X=SAVEX
+72 ; 731 - Include Provider IEN
IF X="@"
IF $$DELDEA(.NPDEALST,NPIEN)
QUIT
+73 ;S DEAEDQ=1 Q
IF X="@"
QUIT
+74 SET NPDEATXT=$$GET1^DIQ(200.5321,DIIENS,.01)
+75 DO WS^PSOPRVW1(NPDEATXT,DIIENS,PSOWSDWN)
+76 IF $$NULL^PSOPRVW1(NPDEATXT,DIIENS)
QUIT
+77 IF '$$INS^PSOPRVW1(NPDEATXT)
QUIT
+78 SET DA=$PIECE(DIIENS,",",1)
SET DA(1)=$PIECE(DIIENS,",",2)
+79 SET DIE="^VA(200,"_DA(1)_",""PS4"","
SET DR=".02R"
SET DIE("NO^")="NO"
DO ^DIE
+80 IF '$DATA(DA)
IF $DATA(DNDEATXT)
IF DNDEAIEN
IF '$DATA(^VA(200,"PS4",DNDEATXT))
Begin DoDot:1
+81 KILL FDA
SET FDA(1,8991.9,DNDEAIEN_",",.06)=0
DO UPDATE^DIE("","FDA(1)")
KILL FDA
End DoDot:1
+82 QUIT
+83 ;
DEAEDTST(X,NPDEALST,NPIEN,PSOWSDWN) ; -- Input Transform for the DEAEDT Tag.
+1 NEW DIR,DNDEAIEN,FG,INST,LNAME,RESPONSEX,PSOASTK
+2 SET RESPONSE=0
SET $PIECE(PSOASTK,"*",75)="*"
+3 IF X="@"
SET RESPONSE=1
GOTO DEAEDTSX
+4 IF $DATA(NPDEALST(X))
SET RESPONSE=1
GOTO DEAEDTSX
+5 IF '$$DEANUM^PSODEAUT(X)
SET RESPONSE=0
Begin DoDot:1
+6 DO EN^DDIOL($CHAR(7)_" ")
DO EN^DDIOL($CHAR(7)_" DEA number is invalid. Please check the number entered.")
+7 SET RESPONSE=0
End DoDot:1
GOTO DEAEDTSX
+8 IF '$$DEANUMFL^PSODEAUT(X)
SET RESPONSE=0
GOTO DEAEDTSX
+9 SET DNDEAIEN=$ORDER(^XTV(8991.9,"B",X,0))
SET INST=$$GET1^DIQ(8991.9,DNDEAIEN,.07,"I")
+10 IF INST'=1
IF $DATA(X)
IF $DATA(NPIEN)
IF $DATA(^VA(200,"PS4",X))
IF $ORDER(^(X,0))'=NPIEN
Begin DoDot:1
+11 DO EN^DDIOL($CHAR(7)_" ")
DO EN^DDIOL($CHAR(7)_$EXTRACT(PSOASTK,1,70))
+12 DO EN^DDIOL($CHAR(7)_" DEA number "_X_" has already been assigned to another provider:")
+13 NEW DUPIEN
SET DUPIEN=$ORDER(^VA(200,"PS4",X,""))
IF DUPIEN
SET DUPNAME=$PIECE($GET(^VA(200,+DUPIEN,0)),U)
+14 IF DUPIEN
Begin DoDot:2
+15 DO EN^DDIOL($CHAR(7)_" NAME: "_$GET(DUPNAME))
+16 DO EN^DDIOL($CHAR(7)_" IEN: "_DUPIEN)
End DoDot:2
+17 DO EN^DDIOL($CHAR(7)_$EXTRACT(PSOASTK,1,70))
+18 DO EN^DDIOL($CHAR(7)_"Please check the number entered.")
+19 SET RESPONSE=0
+20 NEW DIR
WRITE !
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL X,Y,DIRUT,DUOUT
End DoDot:1
GOTO DEAEDTSX
+21 SET RESPONSE=$$WSGET^PSODEAUT(.FG,X)
+22 IF 'RESPONSE!($PIECE(RESPONSE,U,3)=6059)
Begin DoDot:1
+23 SET PSOECODE=$PIECE(RESPONSE,U,3)
IF PSOECODE=6059
SET RESPONSE=PSOECODE_"^"_RESPONSE
SET PSOWSDWN=1
QUIT
+24 IF '$GET(PSOWSDWN)
WRITE !!,"*** "_$PIECE(RESPONSE,U,2)_" ***"
+25 SET RESPONSE=0
End DoDot:1
GOTO DEAEDTSX
+26 ;
+27 ; Test for name match, provide an option to reject.
+28 SET LNAME=$$GET1^DIQ(200,NPIEN,.01)
+29 IF $GET(FG("name"))'=""
IF $PIECE(FG("name"),",",1)'=$PIECE(LNAME,",",1)
Begin DoDot:1
+30 WRITE !!,"DOJ NAME: ",FG("name")
+31 WRITE !,"VISTA NAME: ",LNAME,!
+32 SET DIR(0)="Y"
+33 SET DIR("A",1)="The last names don't match."
+34 SET DIR("A")="Do you really want to continue"
+35 DO ^DIR
IF Y'=1
SET RESPONSE=0
End DoDot:1
+36 ;
DEAEDTSX ; Subroutine Exit Tag
+1 QUIT RESPONSE
+2 ;
INPUSE(NPIEN) ; -- Subroutine to set the DEA NUMBER "USE FOR INPATIENT ORDERS?" flag.
+1 NEW CNT,DEACNT,DIR,DIRUT,DNDEAIEN,FDA,MULTIP,NPDEAIEN,NPDEALST,UFIO,UFIOCNTY,UFIOCNTN,X,XSAVE,Y
SET UFIOCNTY=0
SET UFIOCNTN=0
+2 ;
+3 IF '$ORDER(^VA(200,NPIEN,"PS4",0))
QUIT
+4 ;
+5 ; Loop through the DEA numbers in the NEW PERSON FILE #200
+6 SET CNT=0
SET DEACNT=0
SET NPDEAIEN=0
FOR
SET NPDEAIEN=$ORDER(^VA(200,NPIEN,"PS4",NPDEAIEN))
if 'NPDEAIEN
QUIT
Begin DoDot:1
+7 ;
+8 ; Get the DEA NUMBER IEN from the pointer in the NEW PERSON FILE
+9 SET DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
if 'DNDEAIEN
QUIT
+10 ;
+11 ; Test for an INSTITUTIONAL DEA; ignore INSTITIONAL DEA Numbers?
+12 if $$GET1^DIQ(8991.9,DNDEAIEN,.07,"I")'=2
QUIT
+13 ;
+14 ; Load the New Person Dea List (NPDEALST)
+15 ; Piece: 1 - DEA NUMBER
+16 ; 2 - DEA POINTER; POINTER TO DEA NUMBERS FILE (#8991.9)
+17 ; 3 - USE FOR INPATIENT ORDERS? flag from the DEA NUMBERS FILE (#8991.9)
+18 SET CNT=CNT+1
+19 SET $PIECE(NPDEALST(CNT),U,1)=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN,.01)
+20 SET $PIECE(NPDEALST(CNT),U,2)=DNDEAIEN
+21 SET UFIO=$$GET1^DIQ(8991.9,DNDEAIEN,.06)
SET $PIECE(NPDEALST(CNT),U,3)=$SELECT(UFIO="YES":"YES",1:"NO")
+22 if UFIO="YES"
SET UFIOCNTY=UFIOCNTY+1
+23 if UFIO'="YES"
SET UFIOCNTN=UFIOCNTN+1
+24 SET DEACNT=CNT
End DoDot:1
+25 if DEACNT=0
QUIT
+26 ;
+27 IF DEACNT=1
IF $PIECE(NPDEALST(1),U,3)="YES"
QUIT
+28 IF DEACNT=1
IF $PIECE(NPDEALST(1),U,3)'="YES"
Begin DoDot:1
+29 KILL FDA
SET FDA(1,8991.9,$PIECE(NPDEALST(1),U,2)_",",.06)=1
DO UPDATE^DIE("","FDA(1)")
KILL FDA
End DoDot:1
QUIT
+30 ;
+31 ; Write the list to the screen, identifying the current DEA NUMBER to "USE FOR INPATIENT ORDERS?"
+32 WRITE "USE FOR INPATIENT ORDERS",!
+33 SET CNT=0
FOR
SET CNT=$ORDER(NPDEALST(CNT))
if 'CNT
QUIT
Begin DoDot:1
+34 WRITE $EXTRACT(" ",1,5-$LENGTH(CNT)),CNT," - ",$PIECE(NPDEALST(CNT),U,1)," - "_$PIECE(NPDEALST(CNT),U,3)
+35 if $ORDER(NPDEALST(CNT))
WRITE !
End DoDot:1
+36 ;
IPSLOOP ; Loop to prevent the user from existing without selecting a DEA number for inpatient usage.
+1 ; Set up the user interface prompt to select the "ONE" DEA NUMBER to be used for inpatient orders.
+2 ; If there are more than one DEA NUMBER currently and none selected, make it a required response.
+3 ; If there are more than one DEA NUMBER currently selected, make it a required response.
+4 ; If there is only one DEA NUMBER, make it a required response, and default to 1.
+5 KILL DIRUT,DIR
SET DIR(0)="F"_$SELECT(UFIOCNTY=0:"",UFIOCNTY>1:"",DEACNT=1:"",1:"O")_"^1:9^K:'$D(NPDEALST(X)) X"
+6 SET DIR("A")="SELECT a DEA NUMBER to change INPATIENT USAGE"
+7 if DEACNT=1
SET DIR("B")=1
+8 SET DIR("?",1)="Select a choice from the list above."
+9 SET DIR("?")="Must be a numeric value from the list above."
+10 DO ^DIR
+11 IF UFIOCNTY=0
IF ((X="^")!(X="^^"))
WRITE !!,"THERE MUST BE ONE DEA SELECTED FOR INPATIENT ORDERS."
GOTO IPSLOOP
+12 IF UFIOCNTY>1
IF ((X="^")!(X="^^"))
WRITE !!,"THERE CAN BE ONLY ONE DEA SELECTED FOR INPATIENT ORDERS."
GOTO IPSLOOP
+13 IF $GET(DIRUT)
WRITE !
QUIT
+14 WRITE !
+15 SET XSAVE=X
+16 ;
+17 ; Set up the FDA array; marking the selected DEA NUMBER equal to YES(1) and the other DEA NUMBERS equal to NO(0)
+18 SET CNT=0
SET MULTIP=0
FOR
SET CNT=$ORDER(NPDEALST(CNT))
if 'CNT
QUIT
Begin DoDot:1
+19 IF CNT=XSAVE
SET FDA(1,8991.9,$PIECE(NPDEALST(CNT),U,2)_",",.06)=1
QUIT
+20 IF $PIECE(NPDEALST(CNT),U,3)="YES"
Begin DoDot:2
+21 SET MULTIP=MULTIP+1
+22 WRITE !,"DEA # "_$PIECE(NPDEALST(CNT),U,1)_" is already flagged as ""Use for Inpatient Orders""."
+23 SET FDA(1,8991.9,$PIECE(NPDEALST(CNT),U,2)_",",.06)=0
End DoDot:2
End DoDot:1
+24 ;
+25 ; Ask the user to verify the "Update". Apply the FDA array for a "YES" response.
+26 KILL DIRUT,DIR
+27 IF MULTIP
Begin DoDot:1
+28 SET DIR(0)="Y"
SET DIR("B")="YES"
+29 SET DIR("A",1)="The previous DEA # will no longer be flagged as ""Use for Inpatient Orders""."
+30 SET DIR("A")="Do you want to proceed with this change"
+31 DO ^DIR
End DoDot:1
+32 IF Y=1
DO UPDATE^DIE("","FDA(1)")
+33 IF 'MULTIP
DO UPDATE^DIE("","FDA(1)")
+34 ;
+35 ; Re-Display the changes.
+36 WRITE !
+37 NEW NPDEATXT
SET NPDEAIEN=0
FOR
SET NPDEAIEN=$ORDER(^VA(200,NPIEN,"PS4",NPDEAIEN))
if 'NPDEAIEN
QUIT
Begin DoDot:1
+38 SET DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
if 'DNDEAIEN
QUIT
+39 if $$GET1^DIQ(8991.9,DNDEAIEN,.07,"I")'=2
QUIT
+40 SET NPDEATXT=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN,.01)
+41 SET UFIO=$$GET1^DIQ(8991.9,DNDEAIEN,.06)
+42 WRITE " ",NPDEATXT," - "_$SELECT(UFIO="YES":"YES",1:"NO"),!
End DoDot:1
+43 QUIT
+44 ;
DELDEA(NPDEALST,NPIEN) ; -- Code used to add/edit/delete the VA Number
+1 NEW ACNT,D,DA,DEATYPE,DI,DIC,DIE,DIE1,DIEDA,DIEL,DIETMP,DIEXREF,DIFLD,DIR,DNDEAIEN
+2 NEW DNDETOX,DR,NPDEACNT,NPDEATXT,RESPONSE,VANUMBER,X,Y,SELECTED
+3 SET RESPONSE=0
+4 IF '$GET(NPDEALST(0))
Begin DoDot:1
+5 WRITE " ** No DEA Numbers to Delete ** "
End DoDot:1
QUIT RESPONSE
+6 KILL DIRUT,DIR
SET DIR(0)="NO^1:"_NPDEALST(0)_":0^"
+7 SET DIR("A",1)=" "
+8 SET DIR("A")="Select a choice from the list for DELETION."
+9 SET DIR("?")="Enter a number from the list above."
+10 DO ^DIR
IF $GET(DIRUT)
GOTO DELDEAQ
+11 SET SELECTED=X
+12 SET DIIENS=$PIECE(NPDEALST(SELECTED),"^",4)
+13 IF $LENGTH(DIIENS,",")'=3
GOTO DELDEAQ
+14 SET NPDEACNT=$$NPDEACNT($PIECE(DIIENS,",",2))
+15 SET VANUMBER=$$GET1^DIQ(200,$PIECE(DIIENS,",",2),53.3)
+16 SET NPDEATXT=$$GET1^DIQ(200.5321,DIIENS,.01)
+17 SET DNDEAIEN=$$GET1^DIQ(200.5321,DIIENS,.03,"I")
+18 SET DNDETOX=$$GET1^DIQ(8991.9,DNDEAIEN,.03)
+19 SET DEATYPE=$$GET1^DIQ(8991.9,DNDEAIEN,.07,"I")
+20 SET DA=$PIECE(DIIENS,",",1)
SET DA(1)=$PIECE(DIIENS,",",2)
+21 SET DIR("A")="DO YOU STILL WANT TO DELETE THIS DEA NUMBER"
+22 SET ACNT=0
+23 SET ACNT=ACNT+1
SET DIR("A",ACNT)=" "
+24 SET ACNT=ACNT+1
SET DIR("A",ACNT)="Removing the DEA number does not affect previously written prescriptions."
+25 IF VANUMBER=""
IF NPDEACNT=1
Begin DoDot:1
+26 SET ACNT=ACNT+1
SET DIR("A",ACNT)="This is the only DEA number on file for this provider. The provider will no"
+27 SET ACNT=ACNT+1
SET DIR("A",ACNT)="longer be able to prescribe controlled substances at the VA."
End DoDot:1
+28 ;P731 detox/x-waiver removal
+29 ;I DNDETOX'="" D
+30 ;. S ACNT=ACNT+1,DIR("A",ACNT)="This DEA # contains Detox # "_DNDETOX_". To maintain the Detox #,"
+31 ;. S ACNT=ACNT+1,DIR("A",ACNT)="please add it to another DEA # on the provider's profile."
+32 SET ACNT=ACNT+1
SET DIR("A",ACNT)=" "
+33 SET DIR(0)="Y"
DO ^DIR
KILL DIR
if Y'=1
GOTO DELDEAQ
+34 SET DIE="^VA(200,"_DA(1)_",""PS4"","
SET DR=".01///@"
DO ^DIE
KILL DIE,DR,DA
+35 IF DEATYPE=2
Begin DoDot:1
+36 SET DA=DNDEAIEN
SET DIK="^XTV(8991.9,"
DO ^DIK
KILL DIK,DA
+37 ; 731 - Remove DEA# field (#53.2) if no remaining DEAs
NEW PSOLDEA,PSODELDEA
SET PSOLDEA=$$GET1^DIQ(200,NPIEN,53.2)
SET PSODELDEA=$PIECE($GET(NPDEALST(+$GET(SELECTED))),"^")
+38 if PSOLDEA=""
QUIT
IF (PSOLDEA=PSODELDEA)!(($ORDER(NPDEALST(999),-1)=1)&(SELECTED=1))
KILL DIE,DA,DR,X
SET DIE="^VA(200,"
SET DA=NPIEN
SET DR="53.2///@"
DO ^DIE
KILL DIE,DR,DA
End DoDot:1
+39 SET RESPONSE=1
DELDEAQ ; -- Common Exit Point
+1 QUIT RESPONSE
+2 ;
NPDEACNT(NPIEN) ; -- Function used to count the number of DEA numbers for a provider.
+1 NEW NPDEAIEN,NPDEACNT
+2 SET NPDEAIEN=0
FOR NPDEACNT=0:1
SET NPDEAIEN=$ORDER(^VA(200,NPIEN,"PS4",NPDEAIEN))
if +NPDEAIEN=0
QUIT
+3 QUIT NPDEACNT
+4 ;
DEAHELP ; DEA prompt help text for ^DIR(0)
+1 IF $GET(X)'="?"
DO REDISP
QUIT
+2 WRITE !,"Enter a New DEA Number."
+3 IF $ORDER(^VA(200,+$GET(NPIEN),"PS4",0))
WRITE !,"Select a choice from the list above or,"
+4 IF $ORDER(^VA(200,+$GET(NPIEN),"PS4",0))
WRITE !,"Or type '@' to delete an existing entry."
+5 WRITE !,"DEA NUMBERS must be valid, 2 letters and 7 numbers."
+6 ;
+7 DO REDISP
+8 QUIT
+9 ;
REDISP ; Redisplay DEA numbers
+1 NEW NPDEALST,CNT
+2 SET NPDEALST(0)=0
+3 SET NPDEAIEN=0
FOR CNT=1:1
SET NPDEAIEN=$ORDER(^VA(200,NPIEN,"PS4",NPDEAIEN))
if 'NPDEAIEN
QUIT
Begin DoDot:1
+4 SET NPDEALST(CNT)=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.01)
+5 SET $PIECE(NPDEALST(CNT),U,2)=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.02)
+6 SET $PIECE(NPDEALST(CNT),U,3)=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
+7 NEW F8991P9IE,F8991P9ER
SET F8991P9IE=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
+8 IF '$$FIND1^DIC(8991.9,,"AX",F8991P9IE,,,"F8991P9ER")
IF ($PIECE(NPDEALST(CNT),U,3)="")
SET $PIECE(NPDEALST(CNT),U,2)=" **ERROR-MISSING FROM DEA NUMBERS FILE**"
+9 SET $PIECE(NPDEALST(CNT),U,4)=NPDEAIEN_","_NPIEN_","
+10 if $PIECE(NPDEALST(CNT),U,3)
SET $PIECE(NPDEALST(CNT),U,5)=$$GET1^DIQ(8991.9,$PIECE(NPDEALST(CNT),U,3)_",",1.6)
+11 if $PIECE(NPDEALST(CNT),U,3)
SET $PIECE(NPDEALST(CNT),U,6)=$$GET1^DIQ(8991.9,$PIECE(NPDEALST(CNT),U,3)_",",.03)
+12 SET NPDEALST("B",$PIECE(NPDEALST(CNT),U,1))=NPDEALST(CNT)
+13 SET NPDEALST(0)=CNT
End DoDot:1
+14 WRITE !!,"DEA NUMBERS",!
+15 IF 'NPDEALST(0)
WRITE ?5," * NO DEA NUMBERS ON FILE *",!
+16 FOR CNT=1:1:NPDEALST(0)
Begin DoDot:1
+17 if '$DATA(NPDEALST(CNT))
QUIT
+18 WRITE $EXTRACT(" ",1,5-$LENGTH(CNT)),CNT," - ",$PIECE(NPDEALST(CNT),U,1)
+19 if $PIECE(NPDEALST(CNT),U,2)'=""
WRITE "-",$PIECE(NPDEALST(CNT),U,2)
+20 WRITE " ",$PIECE(NPDEALST(CNT),U,5)
+21 ;P731 detox/x-waiver removal
+22 ;W:$P(NPDEALST(CNT),U,6)'="" " Contains Detox # ",$P(NPDEALST(CNT),U,6)
+23 if $ORDER(NPDEALST(CNT))
WRITE !
End DoDot:1
+24 QUIT
