PSOPRVW1.m

PSOPRVW1 ;BIR/BI,MHA-enter/edit/view provider ; 11/9/2018

 ;;7.0;OUTPATIENT PHARMACY;**545,731,743**;DEC 1997;Build 24

 ;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,PSOLDEA,PSODELDEA

 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

 S PSOLDEA=$$GET1^DIQ(200,NPIEN,53.2),PSODELDEA=$P($G(NPDEALST(+$G(SELECTED))),"^")

 I (PSOLDEA]"") D  ; 731 - Remove DEA# field (#53.2) if no remaining DEAs

 . ; 743 - Do not delete DEA numbers from DEA NUMBERS file (#8991.9)

 . 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 ---PSOPRVW1   15322     printed  Feb 18, 2025@23:59:34                                                                                                                                                                                                   Page 2

PSOPRVW1  ;BIR/BI,MHA-enter/edit/view provider ; 11/9/2018

 +1       ;;7.0;OUTPATIENT PHARMACY;**545,731,743**;DEC 1997;Build 24

 +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)")