- PSODEAME ;ALB/BI - DEA MANUAL ENTRY ;05/15/2018
- ;;7.0;OUTPATIENT PHARMACY;**545,731**;DEC 1997;Build 18
- ;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
- ;External reference to sub-file NEW DEA #S (#200.5321) is supported by DBIA 7000
- Q
- ;
- EN(DEATXT,PSOWSDWN) ; -- main entry point for PSO DEA NUMBER MANAGEMENT
- N CN,FG,RESPONSE,SC,FG,GETS,DNDEAIEN,POP,VALMBCK,VALMCNT,VALMSG,DTRESULT
- N ASTRSK S $P(ASTRSK,"*",75)="*"
- D CONVNAME^PSODEAUT(.CN)
- S DNDEAIEN=$O(^XTV(8991.9,"B",DEATXT,0))
- S RESPONSE=0
- I '$G(PSOWSDWN) S SC=$$WSGET^PSODEAUT(.FG,DEATXT)
- I $P($G(SC),U,3)=6059 S PSOWSDWN=1
- I $G(PSOWSDWN) S RESPONSE=0 D Q RESPONSE
- .S SC="0^Unable to Connect to Server^6059"
- .S RESPONSE=SC
- .S DNDEAIEN=$O(^XTV(8991.9,"B",DEATXT,0))
- .N DIR S DIR("A",1)=" "_$E(ASTRSK,1,60)
- .S DIR("A",2)=" Unable to Connect to PSO DOJ/DEA Web Service"
- .S DIR("A",3)=" "_$E(ASTRSK,1,60),DIR("A",4)=" "
- .S DIR("A",5)=" If you continue, the DEA information entered "
- .S DIR("A",6)=" will not be checked against DOJ DEA source data."
- .S DIR(0)="Y",DIR("A")="Continue without Web Service",DIR("B")="NO" D ^DIR
- .Q:'Y
- .W !,"DEA NUMBER: "_$G(DEATXT)
- .D MANLOAD(DUZ,DEATXT,.GETS,.FG)
- .D ACTIONE,ACTIONA
- .S DNDEAIEN=$O(^XTV(8991.9,"B",DEATXT,0)) S:DNDEAIEN RESPONSE=DNDEAIEN
- I 'SC S RESPONSE=SC W !!," ***"_$P(RESPONSE,U,2)_"***" G ENX
- I $G(FG("type"))="INSTITUTIONAL" D
- .; PREFINST = flag to indicate an automatic update of INSTITUTIONAL DEA in File 8991.9
- .S DNDEAIEN=$O(^XTV(8991.9,"B",DEATXT,0)) Q:'DNDEAIEN ; Only auto-update previously filed institutional DEA's
- .N PREFINST S PREFINST=1
- .D DEACOPY(.FG)
- .D ACTIONA
- .D LSCHED(.GETS) ; Get Local Schedules if Institutional DEA
- D EN^VALM("PSO DEA NUMBER MANAGEMENT")
- ENX ; -- Cleanup and Exit
- S DNDEAIEN=$O(^XTV(8991.9,"B",DEATXT,0)) S:DNDEAIEN RESPONSE=DNDEAIEN
- Q RESPONSE
- ;
- HDR ; -- header code
- ;S VALMHDR(1)="Asterisks ""**"" next to fields in the DOJ column indicate the local value"
- ;S VALMHDR(2)="value has been changed and no longer matches the value in the DOJ file"
- S VALMHDR(1)="The asterisks ""**"" next to fields in the DOJ column indicate that the local"
- S VALMHDR(2)="value has been changed and does not match the value stored in the DOJ file."
- S VALMHDR(3)=""
- Q
- ;
- INIT ; -- Build the List Array
- D INIT^PSODEAED
- Q
- ;
- HELP ; -- help code
- N X
- S X="?" D DISP^XQORM1 W !!
- W !,"Asterisks ""**"" indicate the DOJ value does not match the local VistA value",!
- S VALMBCK="R"
- Q
- ;
- EXIT ; -- exit code
- Q
- ;
- EXPND ; -- expand code
- Q
- ;
- ACTIONA ; -- Perform Action A: ACCEPT AND SAVE CHANGES
- N FDA ; FileMan Data Array used to insert data into file #8991.9
- N DNDEAIEN ; The IEN for the entry in the DEA NUMBERS FILE #8991.9
- N IENROOT ; Variable for the IEN being returned from the ^DIE call.
- N IENS ; ENTRY IEN VALUE
- N MSGROOT ; Message Root for the error messages from the ^DIE call.
- I '$D(GETS) S VALMSG="NOTHING TO SAVE",VALMBCK="R" Q
- I '$$FIND1^DIC(8991.8,,,GETS(.02)) D
- .Q:$D(^XTV(8991.8,"B",GETS(.02))) ; Don't file duplicate BAC
- .N FDA,BACERR S FDA(8991.8,"+1,",.01)=GETS(.02)
- .S FDA(8991.8,"+1,",.02)=$E(GETS(.02))
- .S FDA(8991.8,"+1,",.03)=$E(GETS(.02),2,4)
- .D UPDATE^DIE("E","FDA",,"BACERR")
- S:$G(GETS(.01))'="" DNDEAIEN=$O(^XTV(8991.9,"B",GETS(.01),0))
- S IENS=$S($G(DNDEAIEN):$G(DNDEAIEN)_",",1:"+1,")
- ; Pre-file INSTITUTIONAL DEA without ListMan
- ; File INDIVIDUAL DEA when service is down without ListMan
- I '$G(PREFINST)&'$G(PSOWSDWN) D FULL^VALM1,CLEAN^VALM10
- S FDA(1,8991.9,IENS,1.1)=GETS(1.1) ; NAME
- S FDA(1,8991.9,IENS,1.2)=GETS(1.2) ; ADDRESS 1
- S FDA(1,8991.9,IENS,1.3)=GETS(1.3) ; ADDRESS 2
- S FDA(1,8991.9,IENS,1.4)=GETS(1.4) ; ADDRESS 3
- S FDA(1,8991.9,IENS,1.5)=GETS(1.5) ; CITY
- S FDA(1,8991.9,IENS,1.6)=GETS(1.6) ; STATE
- S FDA(1,8991.9,IENS,1.7)=GETS(1.7) ; ZIP CODE
- S FDA(1,8991.9,IENS,.02)=GETS(.02) ; BUSINESS ACTIVITY CODE AND SUBCODE
- S FDA(1,8991.9,IENS,.07)=GETS(.07) ; TYPE
- S FDA(1,8991.9,IENS,.01)=GETS(.01) ; DEA NUMBER
- I GETS(.03)'="" D CLEARDTX(NPIEN) ; REMOVE DETOX NUMBERS FROM OTHER DEA NUMBERS
- S FDA(1,8991.9,IENS,.03)=GETS(.03) ; DETOX NUMBER
- S FDA(1,8991.9,IENS,.04)=GETS(.04) ; EXPIRATION DATE
- S FDA(1,8991.9,IENS,2.1)=GETS(2.1) ; SCHEDULE II NARCOTIC
- S FDA(1,8991.9,IENS,2.2)=GETS(2.2) ; SCHEDULE II NON-NARCOTIC
- S FDA(1,8991.9,IENS,2.3)=GETS(2.3) ; SCHEDULE III NARCOTIC
- S FDA(1,8991.9,IENS,2.4)=GETS(2.4) ; SCHEDULE III NON-NARCOTIC
- S FDA(1,8991.9,IENS,2.5)=GETS(2.5) ; SCHEDULE IV
- S FDA(1,8991.9,IENS,2.6)=GETS(2.6) ; SCHEDULE V
- S FDA(1,8991.9,IENS,10.2)="N" ; LAST UPDATED DATE/TIME
- S FDA(1,8991.9,IENS,10.3)=GETS(10.3) ; LAST DOJ UPDATE
- D UPDATE^DIE("E","FDA(1)","IENROOT","MSGROOT")
- I $D(MSGROOT) D ACTIONAM G ACTIONAX
- S DNDEAIEN=$S($D(IENROOT(1)):IENROOT(1),1:IENS)
- S FDA(2,8991.9,DNDEAIEN,10.1)=DUZ D FILE^DIE("","FDA(2)","MSGROOT")
- I $G(GETS(.07))="INSTITUTIONAL" D
- .Q:'$D(GETS(55.1))
- .Q:$G(PREFINST)
- .K FDA
- .S FDA(1,200,NPIEN_",",55.1)=GETS(55.1)
- .S FDA(1,200,NPIEN_",",55.2)=GETS(55.2)
- .S FDA(1,200,NPIEN_",",55.3)=GETS(55.3)
- .S FDA(1,200,NPIEN_",",55.4)=GETS(55.4)
- .S FDA(1,200,NPIEN_",",55.5)=GETS(55.5)
- .S FDA(1,200,NPIEN_",",55.6)=GETS(55.6)
- .D UPDATE^DIE("E","FDA(1)","NPIEN","MSGROOT")
- ;
- K FDA S FDA(8991.9,IENS,10.3)=$S($G(PSOWSDWN):"",1:$$DT^XLFDT)
- N IENROOT,MSGROOT
- D UPDATE^DIE("","FDA","IENROOT","MSGROOT")
- ;
- ACTIONAX ; -- Return here to end cleanly.
- S VALMBCK="Q"
- Q
- ;
- ACTIONAM ; -- Provide filing error messge and pause.
- N DIR
- W !!,"*** The information could not be filed ***",!
- W:$D(MSGROOT("DIERR",1,"TEXT",1)) MSGROOT("DIERR",1,"TEXT",1),!
- S DIR(0)="E" D ^DIR W !
- Q
- ;
- ACTIONC ; -- Perform Action C: COPY DOJ/DEA VALUES TO VISTA
- N SC
- D DEACOPY(.FG)
- D CLEAN^VALM10
- D INIT
- S VALMBCK="R"
- Q
- ;
- ACTIONE ; -- Perform Action E: EDIT VISTA VALUES
- N DIRUT,DIR,X,Y,PSPROCDT
- I '$D(GETS) S VALMSG="NOTHING TO EDIT",VALMBCK="R" Q
- I '$G(PSOWSDWN) D FULL^VALM1,CLEAN^VALM10
- ;
- I $D(FG("processedDate")) D DT^DILF("E",FG("processedDate"),.DTRESULT)
- I '$D(FG("processedDate")) D DT^DILF("E",DT,.DTRESULT)
- S GETS(10.3)=$G(DTRESULT(0)) ; Automatically update DOJ processed date (is now)
- ;
- ; DETOX
- N CDETOX,NDETOX,GETS03,DTXDEAX
- S DTXDEAX=""
- I 0 D:GETS(.07)="INDIVIDUAL" ;P731 detox/x-waiver removal
- . S GETS03=GETS(.03)
- . S CDETOX=$$GETDNDTX^PSODEAUT(NPIEN,.DTXDEAX)
- . K DTOUT,DUOUT,DIR S DIR(0)="FO^9:9^K:'$$DEANUM^PSODEAUT(X)!$$DTXDUPIT^PSODEAU0(GETS(.01),$G(X),NPIEN) X",DIR("A")="DETOX",DIR("B")=GETS(.03)
- . S DIR("?")="^D DTXHLP^PSODEAME"
- . ; S DIR("?")="Response must contain 2 letters and 7 numbers. The numeric portion must satisfy the DEA number checksum rules."
- . D ^DIR
- . Q:$D(DTOUT)!($D(DUOUT))
- . S NDETOX=Y
- . I X="@" S GETS(.03)=$$UP^XLFSTR(NDETOX) Q
- . I CDETOX="" S GETS(.03)=$$UP^XLFSTR(NDETOX) Q
- . I CDETOX'=""&(NDETOX'="")&(CDETOX'=NDETOX) D
- .. K DTOUT,DUOUT,DIR S DIR(0)="Y"
- .. S DIR("A",1)="DETOX NUMBER: "_CDETOX_" already exists on DEA NUMBER: "_$G(DTXDEAX)
- .. S DIR("A",2)="for this provider. Only one DEA number can contain a DETOX number."
- .. S DIR("A",3)="Do you want to replace the existing DETOX number?"
- .. S DIR("A")="Enter Yes or No:"
- .. D ^DIR I '($D(DTOUT)!($D(DUOUT))) D
- ... I 'Y S GETS(.03)=$$UP^XLFSTR(GETS03)
- ... I Y S GETS(.03)=$$UP^XLFSTR(NDETOX)
- G:$D(DTOUT)!($D(DUOUT)) ACTIONEX
- K DTOUT,DUOUT
- ;
- ; Don't allow editing of DEA Expiration Date or Schedules if any of the following are true:
- ; PROVIDER TYPE NOT= 'FEE BASIS' or 'C&A'
- ; -OR-
- ; NON-VA PRESCRIBER NOT= 'YES'
- ; -OR-
- ; PHARMACY OPERATING MODE NOT= 'VAMC'
- ;
- ; Don't allow editing of DEA Expiration Date for Institutional DEA #'S
- ;
- N PSOEDCHK S PSOEDCHK=$$EDITCHK^PSOPRVW(+$G(NPIEN))
- I 'PSOEDCHK S DEAEDQ=1 D Q
- . N ASTER S $P(ASTER,"*",70)="*"
- . W !!?6,$E(ASTER,1,45)
- . W !?6,"* This provider's DEA Expiration Date *"
- . W !?6,"* and DEA Schedules are not editable *"
- . W !?6,$E(ASTER,1,45)
- . W !! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR W !
- ;
- ; Set NDROOT to "2" (file 8991.9 schedule fields root) if INDIVIDUAL DEA
- ; Set NDROOT to "55" (file 200 schedule fields root) if INSTITUTIONAL DEA
- ;
- N NDROOT S NDROOT=$S($G(GETS(.07))="INSTITUTIONAL":55,1:2)
- I '$D(GETS(55.1)),$G(GETS(.07))="INSTITUTIONAL" D LSCHED(.GETS) ; Get Local Schedules if Institutional DEA
- ;
- ; EXPIRATION DATE
- I GETS(.07)="INDIVIDUAL" D G:$D(DTOUT)!($D(DUOUT)) ACTIONEX
- . K DTOUT,DUOUT,DIR N DTRESULT
- . S DIR(0)="DO",DIR("A")="EXPIRATION DATE" S DIR("B")=GETS(.04) D ^DIR
- . Q:($D(DTOUT)!$D(DUOUT)) D DT^DILF("E",$G(Y),.DTRESULT)
- . S GETS(.04)=$G(DTRESULT(0))
- . W " ",GETS(.04)
- ;
- ; SCHEDULE II NARCOTIC
- K DTOUT,DUOUT,DIR S DIR(0)="Y",DIR("A")="SCHEDULE II NARCOTIC",DIR("B")=$S(GETS(NDROOT_".1")="YES":"YES",1:"NO") D ^DIR
- G:$D(DTOUT)!($D(DUOUT)) ACTIONEX S GETS(NDROOT_".1")=$S(Y=1:"YES",1:"NO")
- ;
- ; SCHEDULE II NON-NARCOTIC
- K DTOUT,DUOUT,DIR S DIR(0)="Y",DIR("A")="SCHEDULE II NON-NARCOTIC",DIR("B")=$S(GETS(NDROOT_".2")="YES":"YES",1:"NO") D ^DIR
- G:$D(DTOUT)!($D(DUOUT)) ACTIONEX S GETS(NDROOT_".2")=$S(Y=1:"YES",1:"NO")
- ;
- ; SCHEDULE III NARCOTIC
- K DTOUT,DUOUT,DIR S DIR(0)="Y",DIR("A")="SCHEDULE III NARCOTIC",DIR("B")=$S(GETS(NDROOT_".3")="YES":"YES",1:"NO") D ^DIR
- G:$D(DTOUT)!($D(DUOUT)) ACTIONEX S GETS(NDROOT_".3")=$S(Y=1:"YES",1:"NO")
- ;
- ; SCHEDULE III NON-NARCOTIC
- K DTOUT,DUOUT,DIR S DIR(0)="Y",DIR("A")="SCHEDULE III NON-NARCOTIC",DIR("B")=$S(GETS(NDROOT_".4")="YES":"YES",1:"NO") D ^DIR
- G:$D(DTOUT)!($D(DUOUT)) ACTIONEX S GETS(NDROOT_".4")=$S(Y=1:"YES",1:"NO")
- ;
- ; SCHEDULE IV
- K DTOUT,DUOUT,DIR S DIR(0)="Y",DIR("A")="SCHEDULE IV",DIR("B")=$S(GETS(NDROOT_".5")="YES":"YES",1:"NO") D ^DIR
- G:$D(DTOUT)!($D(DUOUT)) ACTIONEX S GETS(NDROOT_".5")=$S(Y=1:"YES",1:"NO")
- ;
- ; SCHEDULE V
- K DTOUT,DUOUT,DIR S DIR(0)="Y",DIR("A")="SCHEDULE V",DIR("B")=$S(GETS(NDROOT_".6")="YES":"YES",1:"NO") D ^DIR
- G:$D(DTOUT)!($D(DUOUT)) ACTIONEX S GETS(NDROOT_".6")=$S(Y=1:"YES",1:"NO")
- ;
- ACTIONEX ; -- ACTIONE Clean Exit Point
- K DIRUT,DIR
- Q:$G(PSOWSDWN)
- D INIT
- S VALMBCK="R"
- Q
- ;
- ACTIONX ; -- Perform Action X: QUIT AND REJECT CHANGES
- D FULL^VALM1
- D CLEAN^VALM10
- S VALMBCK="Q"
- Q
- ;
- DEACOPY(FG) ; -- Private Subroutine to Copy import data in the GETS Array
- ; POSTAL^XIPUTL used in agreement with Integration Agreement: 3618
- ;
- ; INPUT: FG ;Web Service Response Global
- ;
- ; VARIABLES:
- N DS ;Single drug schedule field as sent from the VA DOJ Web Service.
- N XIP ;Used to calculate the state from a zip code.
- N XSTATE ;Used to calculate the state from a zip code.
- N BAC ;Business Activity Code
- N I
- ;
- S DS=$G(FG("drugSchedule"))
- S GETS(.01)=$G(FG("deaNumber"))
- S BAC=$G(FG("businessActivityCode"))_$G(FG("businessActivitySubcode"))
- S GETS(.02)=BAC ; Pointer to file #8991.8
- S GETS(.03)=$S($$GETDNDTX^PSODEAUT(NPIEN)'="":"",$$DETOXCHK^PSODEAUT(BAC):"X"_$E($G(FG("deaNumber")),2,9),1:"") ; DETOX NUMBER
- D DT^DILF("E",$G(FG("expirationDate")),.DTRESULT)
- S GETS(.04)=$G(DTRESULT(0))
- S GETS(.07)=$G(FG("type"))
- S GETS(1.1)=$G(FG("name"))
- S GETS(1.2)=$G(FG("additionalCompanyInfo"))
- S GETS(1.3)=$G(FG("address1"))
- S GETS(1.4)=$G(FG("address2"))
- S GETS(1.5)=$G(FG("city"))
- ;
- ; Special State Processing
- S GETS(1.6)=$G(FG("state"))
- D POSTAL^XIPUTIL($G(FG("zipCode")),.XIP)
- S XSTATE=$G(XIP("STATE"))
- I XSTATE'="" S GETS(1.6)=XSTATE ; Pointer to the State File #5.
- ;
- S GETS(1.7)=$G(FG("zipCode"))
- ;
- S GETS(2.1)=$S(DS["22N":"YES",(DS["2"&(DS'["2N")):"YES",1:"NO") ; SCHEDULE II NARCOTIC
- S GETS(2.2)=$S(DS["2N":"YES",1:"NO") ; SCHEDULE II NON-NARCOTIC
- S GETS(2.3)=$S(DS["33N":"YES",(DS["3"&(DS'["3N")):"YES",1:"NO") ; SCHEDULE III NARCOTIC
- S GETS(2.4)=$S(DS["3N":"YES",1:"NO") ; SCHEDULE III NON-NARCOTIC
- S GETS(2.5)=$S(DS["4":"YES",1:"NO") ; SCHEDULE IV
- S GETS(2.6)=$S(DS["5":"YES",1:"NO") ; SCHEDULE V
- ;
- I $G(GETS(.07))="INSTITUTIONAL" F I=2.1:.1:2.6 S GETS(55_"."_$P(I,".",2))=GETS(I)
- ;
- D DT^DILF("E",$G(DT),.DTRESULT)
- S GETS(10.2)=$G(DTRESULT(0)) ; LAST UPDATED DATE/TIME
- ;D DT^DILF("E",$G(FG("processedDate")),.DTRESULT)
- S GETS(10.3)=$G(DTRESULT(0)) ; LAST DOJ UPDATE DATE/TIME
- S GETS(10.1)=DUZ
- Q
- ;
- CLEARDTX(NPIEN) ; REMOVE DETOX NUMBERS FROM ALL OF A PROVIDERS DEA NUMBERS
- N DNDEAIEN,FDA,NPDEAIEN
- 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")
- . K FDA S FDA(1,8991.9,DNDEAIEN_",",.03)="@" D UPDATE^DIE("","FDA(1)") K FDA
- Q
- ;
- DTXHLP ; Detox Number Help Text
- N CDETOX,DTXDEAX
- I $G(NPIEN) S CDETOX=$$GETDNDTX^PSODEAUT(NPIEN,.DTXDEAX)
- I $G(Y)'="",($G(CDETOX)'="") I Y=CDETOX D Q
- .I $G(DEATXT)'=$G(DTXDEAX) D Q
- .. W !,"The entered DETOX NUMBER already exists on DEA NUMBER: "_DTXDEAX
- .. W !,"for this provider."
- W !,"Response must contain 2 letters and 7 numbers. The numeric portion must satisfy the DEA number checksum rules."
- Q
- ;
- LSCHED(GETS) ; Get local provider schedules from NEW PERSON and add to GETS(55.1-55.6)
- Q:$G(GETS(.07))'="INSTITUTIONAL"
- Q:'$G(NPIEN)
- N LOCSCH,LOCSCH2,I
- D GETS^DIQ(200,NPIEN,"55.1;55.2;55.3;55.4;55.5;55.6","I","LOCSCH")
- M LOCSCH2=LOCSCH(200,NPIEN_",")
- F I=55.1,55.2,55.3,55.4,55.5,55.6 S GETS(I)=$S($G(LOCSCH2(I,"I")):"YES",1:"NO")
- Q
- ;
- MANLOAD(DUZ,DEA,GETS,FG) ; Manually load default values when web service is down
- ; Load GETS()
- N DNDEAIEN
- S DNDEAIEN=$O(^XTV(8991.9,"B",DEA,0))
- I $G(DNDEAIEN) D GETS^PSODEAUT(DNDEAIEN,.GETS) D Q
- .I $G(NPIEN),($G(GETS(.07))="INSTITUTIONAL") D LSCHED^PSODEAME(.GETS) ; Get Local Schedules if Institutional DEA
- ;
- ; New DEA entered without PSO DOJ/DEA WEB SERVICE connection. Default BAC? and TYPE.
- S GETS(.01)=DEA
- S GETS(.02)="C0"
- S GETS(.03)=""
- S GETS(.04)=""
- S GETS(.07)="INDIVIDUAL"
- S GETS(1.1)=$$GET1^DIQ(200,NPIEN,.01,"E")
- S GETS(1.2)=""
- S GETS(1.3)=""
- S GETS(1.4)=""
- S GETS(1.5)=""
- S GETS(1.6)=""
- S GETS(1.7)=""
- S GETS(2.1)=""
- S GETS(2.2)=""
- S GETS(2.3)=""
- S GETS(2.4)=""
- S GETS(2.5)=""
- S GETS(2.6)=""
- S GETS(10.1)=DUZ
- S GETS(10.2)=""
- S GETS(10.3)=""
- ;
- ; Load FG()
- S FG("drugSchedule")=""
- S FG("deaNumber")=DEA
- S FG("businessActivityCode")="C"
- S FG("businessActivitySubcode")=0
- S FG("expirationDate")=""
- S FG("type")="INDIVIDUAL"
- S FG("name")=GETS(1.1)
- S FG("address1")=""
- S FG("address2")=""
- S FG("address3")=""
- S FG("city")=""
- S FG("state")=""
- S FG("zipCode")=""
- S FG("processedDate")=""
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODEAME 14789 printed Jan 18, 2025@03:27:45 Page 2
- PSODEAME ;ALB/BI - DEA MANUAL ENTRY ;05/15/2018
- +1 ;;7.0;OUTPATIENT PHARMACY;**545,731**;DEC 1997;Build 18
- +2 ;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
- +3 ;External reference to sub-file NEW DEA #S (#200.5321) is supported by DBIA 7000
- +4 QUIT
- +5 ;
- EN(DEATXT,PSOWSDWN) ; -- main entry point for PSO DEA NUMBER MANAGEMENT
- +1 NEW CN,FG,RESPONSE,SC,FG,GETS,DNDEAIEN,POP,VALMBCK,VALMCNT,VALMSG,DTRESULT
- +2 NEW ASTRSK
- SET $PIECE(ASTRSK,"*",75)="*"
- +3 DO CONVNAME^PSODEAUT(.CN)
- +4 SET DNDEAIEN=$ORDER(^XTV(8991.9,"B",DEATXT,0))
- +5 SET RESPONSE=0
- +6 IF '$GET(PSOWSDWN)
- SET SC=$$WSGET^PSODEAUT(.FG,DEATXT)
- +7 IF $PIECE($GET(SC),U,3)=6059
- SET PSOWSDWN=1
- +8 IF $GET(PSOWSDWN)
- SET RESPONSE=0
- Begin DoDot:1
- +9 SET SC="0^Unable to Connect to Server^6059"
- +10 SET RESPONSE=SC
- +11 SET DNDEAIEN=$ORDER(^XTV(8991.9,"B",DEATXT,0))
- +12 NEW DIR
- SET DIR("A",1)=" "_$EXTRACT(ASTRSK,1,60)
- +13 SET DIR("A",2)=" Unable to Connect to PSO DOJ/DEA Web Service"
- +14 SET DIR("A",3)=" "_$EXTRACT(ASTRSK,1,60)
- SET DIR("A",4)=" "
- +15 SET DIR("A",5)=" If you continue, the DEA information entered "
- +16 SET DIR("A",6)=" will not be checked against DOJ DEA source data."
- +17 SET DIR(0)="Y"
- SET DIR("A")="Continue without Web Service"
- SET DIR("B")="NO"
- DO ^DIR
- +18 if 'Y
- QUIT
- +19 WRITE !,"DEA NUMBER: "_$GET(DEATXT)
- +20 DO MANLOAD(DUZ,DEATXT,.GETS,.FG)
- +21 DO ACTIONE
- DO ACTIONA
- +22 SET DNDEAIEN=$ORDER(^XTV(8991.9,"B",DEATXT,0))
- if DNDEAIEN
- SET RESPONSE=DNDEAIEN
- End DoDot:1
- QUIT RESPONSE
- +23 IF 'SC
- SET RESPONSE=SC
- WRITE !!," ***"_$PIECE(RESPONSE,U,2)_"***"
- GOTO ENX
- +24 IF $GET(FG("type"))="INSTITUTIONAL"
- Begin DoDot:1
- +25 ; PREFINST = flag to indicate an automatic update of INSTITUTIONAL DEA in File 8991.9
- +26 ; Only auto-update previously filed institutional DEA's
- SET DNDEAIEN=$ORDER(^XTV(8991.9,"B",DEATXT,0))
- if 'DNDEAIEN
- QUIT
- +27 NEW PREFINST
- SET PREFINST=1
- +28 DO DEACOPY(.FG)
- +29 DO ACTIONA
- +30 ; Get Local Schedules if Institutional DEA
- DO LSCHED(.GETS)
- End DoDot:1
- +31 DO EN^VALM("PSO DEA NUMBER MANAGEMENT")
- ENX ; -- Cleanup and Exit
- +1 SET DNDEAIEN=$ORDER(^XTV(8991.9,"B",DEATXT,0))
- if DNDEAIEN
- SET RESPONSE=DNDEAIEN
- +2 QUIT RESPONSE
- +3 ;
- HDR ; -- header code
- +1 ;S VALMHDR(1)="Asterisks ""**"" next to fields in the DOJ column indicate the local value"
- +2 ;S VALMHDR(2)="value has been changed and no longer matches the value in the DOJ file"
- +3 SET VALMHDR(1)="The asterisks ""**"" next to fields in the DOJ column indicate that the local"
- +4 SET VALMHDR(2)="value has been changed and does not match the value stored in the DOJ file."
- +5 SET VALMHDR(3)=""
- +6 QUIT
- +7 ;
- INIT ; -- Build the List Array
- +1 DO INIT^PSODEAED
- +2 QUIT
- +3 ;
- HELP ; -- help code
- +1 NEW X
- +2 SET X="?"
- DO DISP^XQORM1
- WRITE !!
- +3 WRITE !,"Asterisks ""**"" indicate the DOJ value does not match the local VistA value",!
- +4 SET VALMBCK="R"
- +5 QUIT
- +6 ;
- EXIT ; -- exit code
- +1 QUIT
- +2 ;
- EXPND ; -- expand code
- +1 QUIT
- +2 ;
- ACTIONA ; -- Perform Action A: ACCEPT AND SAVE CHANGES
- +1 ; FileMan Data Array used to insert data into file #8991.9
- NEW FDA
- +2 ; The IEN for the entry in the DEA NUMBERS FILE #8991.9
- NEW DNDEAIEN
- +3 ; Variable for the IEN being returned from the ^DIE call.
- NEW IENROOT
- +4 ; ENTRY IEN VALUE
- NEW IENS
- +5 ; Message Root for the error messages from the ^DIE call.
- NEW MSGROOT
- +6 IF '$DATA(GETS)
- SET VALMSG="NOTHING TO SAVE"
- SET VALMBCK="R"
- QUIT
- +7 IF '$$FIND1^DIC(8991.8,,,GETS(.02))
- Begin DoDot:1
- +8 ; Don't file duplicate BAC
- if $DATA(^XTV(8991.8,"B",GETS(.02)))
- QUIT
- +9 NEW FDA,BACERR
- SET FDA(8991.8,"+1,",.01)=GETS(.02)
- +10 SET FDA(8991.8,"+1,",.02)=$EXTRACT(GETS(.02))
- +11 SET FDA(8991.8,"+1,",.03)=$EXTRACT(GETS(.02),2,4)
- +12 DO UPDATE^DIE("E","FDA",,"BACERR")
- End DoDot:1
- +13 if $GET(GETS(.01))'=""
- SET DNDEAIEN=$ORDER(^XTV(8991.9,"B",GETS(.01),0))
- +14 SET IENS=$SELECT($GET(DNDEAIEN):$GET(DNDEAIEN)_",",1:"+1,")
- +15 ; Pre-file INSTITUTIONAL DEA without ListMan
- +16 ; File INDIVIDUAL DEA when service is down without ListMan
- +17 IF '$GET(PREFINST)&'$GET(PSOWSDWN)
- DO FULL^VALM1
- DO CLEAN^VALM10
- +18 ; NAME
- SET FDA(1,8991.9,IENS,1.1)=GETS(1.1)
- +19 ; ADDRESS 1
- SET FDA(1,8991.9,IENS,1.2)=GETS(1.2)
- +20 ; ADDRESS 2
- SET FDA(1,8991.9,IENS,1.3)=GETS(1.3)
- +21 ; ADDRESS 3
- SET FDA(1,8991.9,IENS,1.4)=GETS(1.4)
- +22 ; CITY
- SET FDA(1,8991.9,IENS,1.5)=GETS(1.5)
- +23 ; STATE
- SET FDA(1,8991.9,IENS,1.6)=GETS(1.6)
- +24 ; ZIP CODE
- SET FDA(1,8991.9,IENS,1.7)=GETS(1.7)
- +25 ; BUSINESS ACTIVITY CODE AND SUBCODE
- SET FDA(1,8991.9,IENS,.02)=GETS(.02)
- +26 ; TYPE
- SET FDA(1,8991.9,IENS,.07)=GETS(.07)
- +27 ; DEA NUMBER
- SET FDA(1,8991.9,IENS,.01)=GETS(.01)
- +28 ; REMOVE DETOX NUMBERS FROM OTHER DEA NUMBERS
- IF GETS(.03)'=""
- DO CLEARDTX(NPIEN)
- +29 ; DETOX NUMBER
- SET FDA(1,8991.9,IENS,.03)=GETS(.03)
- +30 ; EXPIRATION DATE
- SET FDA(1,8991.9,IENS,.04)=GETS(.04)
- +31 ; SCHEDULE II NARCOTIC
- SET FDA(1,8991.9,IENS,2.1)=GETS(2.1)
- +32 ; SCHEDULE II NON-NARCOTIC
- SET FDA(1,8991.9,IENS,2.2)=GETS(2.2)
- +33 ; SCHEDULE III NARCOTIC
- SET FDA(1,8991.9,IENS,2.3)=GETS(2.3)
- +34 ; SCHEDULE III NON-NARCOTIC
- SET FDA(1,8991.9,IENS,2.4)=GETS(2.4)
- +35 ; SCHEDULE IV
- SET FDA(1,8991.9,IENS,2.5)=GETS(2.5)
- +36 ; SCHEDULE V
- SET FDA(1,8991.9,IENS,2.6)=GETS(2.6)
- +37 ; LAST UPDATED DATE/TIME
- SET FDA(1,8991.9,IENS,10.2)="N"
- +38 ; LAST DOJ UPDATE
- SET FDA(1,8991.9,IENS,10.3)=GETS(10.3)
- +39 DO UPDATE^DIE("E","FDA(1)","IENROOT","MSGROOT")
- +40 IF $DATA(MSGROOT)
- DO ACTIONAM
- GOTO ACTIONAX
- +41 SET DNDEAIEN=$SELECT($DATA(IENROOT(1)):IENROOT(1),1:IENS)
- +42 SET FDA(2,8991.9,DNDEAIEN,10.1)=DUZ
- DO FILE^DIE("","FDA(2)","MSGROOT")
- +43 IF $GET(GETS(.07))="INSTITUTIONAL"
- Begin DoDot:1
- +44 if '$DATA(GETS(55.1))
- QUIT
- +45 if $GET(PREFINST)
- QUIT
- +46 KILL FDA
- +47 SET FDA(1,200,NPIEN_",",55.1)=GETS(55.1)
- +48 SET FDA(1,200,NPIEN_",",55.2)=GETS(55.2)
- +49 SET FDA(1,200,NPIEN_",",55.3)=GETS(55.3)
- +50 SET FDA(1,200,NPIEN_",",55.4)=GETS(55.4)
- +51 SET FDA(1,200,NPIEN_",",55.5)=GETS(55.5)
- +52 SET FDA(1,200,NPIEN_",",55.6)=GETS(55.6)
- +53 DO UPDATE^DIE("E","FDA(1)","NPIEN","MSGROOT")
- End DoDot:1
- +54 ;
- +55 KILL FDA
- SET FDA(8991.9,IENS,10.3)=$SELECT($GET(PSOWSDWN):"",1:$$DT^XLFDT)
- +56 NEW IENROOT,MSGROOT
- +57 DO UPDATE^DIE("","FDA","IENROOT","MSGROOT")
- +58 ;
- ACTIONAX ; -- Return here to end cleanly.
- +1 SET VALMBCK="Q"
- +2 QUIT
- +3 ;
- ACTIONAM ; -- Provide filing error messge and pause.
- +1 NEW DIR
- +2 WRITE !!,"*** The information could not be filed ***",!
- +3 if $DATA(MSGROOT("DIERR",1,"TEXT",1))
- WRITE MSGROOT("DIERR",1,"TEXT",1),!
- +4 SET DIR(0)="E"
- DO ^DIR
- WRITE !
- +5 QUIT
- +6 ;
- ACTIONC ; -- Perform Action C: COPY DOJ/DEA VALUES TO VISTA
- +1 NEW SC
- +2 DO DEACOPY(.FG)
- +3 DO CLEAN^VALM10
- +4 DO INIT
- +5 SET VALMBCK="R"
- +6 QUIT
- +7 ;
- ACTIONE ; -- Perform Action E: EDIT VISTA VALUES
- +1 NEW DIRUT,DIR,X,Y,PSPROCDT
- +2 IF '$DATA(GETS)
- SET VALMSG="NOTHING TO EDIT"
- SET VALMBCK="R"
- QUIT
- +3 IF '$GET(PSOWSDWN)
- DO FULL^VALM1
- DO CLEAN^VALM10
- +4 ;
- +5 IF $DATA(FG("processedDate"))
- DO DT^DILF("E",FG("processedDate"),.DTRESULT)
- +6 IF '$DATA(FG("processedDate"))
- DO DT^DILF("E",DT,.DTRESULT)
- +7 ; Automatically update DOJ processed date (is now)
- SET GETS(10.3)=$GET(DTRESULT(0))
- +8 ;
- +9 ; DETOX
- +10 NEW CDETOX,NDETOX,GETS03,DTXDEAX
- +11 SET DTXDEAX=""
- +12 ;P731 detox/x-waiver removal
- IF 0
- if GETS(.07)="INDIVIDUAL"
- Begin DoDot:1
- +13 SET GETS03=GETS(.03)
- +14 SET CDETOX=$$GETDNDTX^PSODEAUT(NPIEN,.DTXDEAX)
- +15 KILL DTOUT,DUOUT,DIR
- SET DIR(0)="FO^9:9^K:'$$DEANUM^PSODEAUT(X)!$$DTXDUPIT^PSODEAU0(GETS(.01),$G(X),NPIEN) X"
- SET DIR("A")="DETOX"
- SET DIR("B")=GETS(.03)
- +16 SET DIR("?")="^D DTXHLP^PSODEAME"
- +17 ; S DIR("?")="Response must contain 2 letters and 7 numbers. The numeric portion must satisfy the DEA number checksum rules."
- +18 DO ^DIR
- +19 if $DATA(DTOUT)!($DATA(DUOUT))
- QUIT
- +20 SET NDETOX=Y
- +21 IF X="@"
- SET GETS(.03)=$$UP^XLFSTR(NDETOX)
- QUIT
- +22 IF CDETOX=""
- SET GETS(.03)=$$UP^XLFSTR(NDETOX)
- QUIT
- +23 IF CDETOX'=""&(NDETOX'="")&(CDETOX'=NDETOX)
- Begin DoDot:2
- +24 KILL DTOUT,DUOUT,DIR
- SET DIR(0)="Y"
- +25 SET DIR("A",1)="DETOX NUMBER: "_CDETOX_" already exists on DEA NUMBER: "_$GET(DTXDEAX)
- +26 SET DIR("A",2)="for this provider. Only one DEA number can contain a DETOX number."
- +27 SET DIR("A",3)="Do you want to replace the existing DETOX number?"
- +28 SET DIR("A")="Enter Yes or No:"
- +29 DO ^DIR
- IF '($DATA(DTOUT)!($DATA(DUOUT)))
- Begin DoDot:3
- +30 IF 'Y
- SET GETS(.03)=$$UP^XLFSTR(GETS03)
- +31 IF Y
- SET GETS(.03)=$$UP^XLFSTR(NDETOX)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +32 if $DATA(DTOUT)!($DATA(DUOUT))
- GOTO ACTIONEX
- +33 KILL DTOUT,DUOUT
- +34 ;
- +35 ; Don't allow editing of DEA Expiration Date or Schedules if any of the following are true:
- +36 ; PROVIDER TYPE NOT= 'FEE BASIS' or 'C&A'
- +37 ; -OR-
- +38 ; NON-VA PRESCRIBER NOT= 'YES'
- +39 ; -OR-
- +40 ; PHARMACY OPERATING MODE NOT= 'VAMC'
- +41 ;
- +42 ; Don't allow editing of DEA Expiration Date for Institutional DEA #'S
- +43 ;
- +44 NEW PSOEDCHK
- SET PSOEDCHK=$$EDITCHK^PSOPRVW(+$GET(NPIEN))
- +45 IF 'PSOEDCHK
- SET DEAEDQ=1
- Begin DoDot:1
- +46 NEW ASTER
- SET $PIECE(ASTER,"*",70)="*"
- +47 WRITE !!?6,$EXTRACT(ASTER,1,45)
- +48 WRITE !?6,"* This provider's DEA Expiration Date *"
- +49 WRITE !?6,"* and DEA Schedules are not editable *"
- +50 WRITE !?6,$EXTRACT(ASTER,1,45)
- +51 WRITE !!
- KILL DIR
- SET DIR(0)="E"
- SET DIR("A")="Press Return to Continue"
- DO ^DIR
- KILL DIR
- WRITE !
- End DoDot:1
- QUIT
- +52 ;
- +53 ; Set NDROOT to "2" (file 8991.9 schedule fields root) if INDIVIDUAL DEA
- +54 ; Set NDROOT to "55" (file 200 schedule fields root) if INSTITUTIONAL DEA
- +55 ;
- +56 NEW NDROOT
- SET NDROOT=$SELECT($GET(GETS(.07))="INSTITUTIONAL":55,1:2)
- +57 ; Get Local Schedules if Institutional DEA
- IF '$DATA(GETS(55.1))
- IF $GET(GETS(.07))="INSTITUTIONAL"
- DO LSCHED(.GETS)
- +58 ;
- +59 ; EXPIRATION DATE
- +60 IF GETS(.07)="INDIVIDUAL"
- Begin DoDot:1
- +61 KILL DTOUT,DUOUT,DIR
- NEW DTRESULT
- +62 SET DIR(0)="DO"
- SET DIR("A")="EXPIRATION DATE"
- SET DIR("B")=GETS(.04)
- DO ^DIR
- +63 if ($DATA(DTOUT)!$DATA(DUOUT))
- QUIT
- DO DT^DILF("E",$GET(Y),.DTRESULT)
- +64 SET GETS(.04)=$GET(DTRESULT(0))
- +65 WRITE " ",GETS(.04)
- End DoDot:1
- if $DATA(DTOUT)!($DATA(DUOUT))
- GOTO ACTIONEX
- +66 ;
- +67 ; SCHEDULE II NARCOTIC
- +68 KILL DTOUT,DUOUT,DIR
- SET DIR(0)="Y"
- SET DIR("A")="SCHEDULE II NARCOTIC"
- SET DIR("B")=$SELECT(GETS(NDROOT_".1")="YES":"YES",1:"NO")
- DO ^DIR
- +69 if $DATA(DTOUT)!($DATA(DUOUT))
- GOTO ACTIONEX
- SET GETS(NDROOT_".1")=$SELECT(Y=1:"YES",1:"NO")
- +70 ;
- +71 ; SCHEDULE II NON-NARCOTIC
- +72 KILL DTOUT,DUOUT,DIR
- SET DIR(0)="Y"
- SET DIR("A")="SCHEDULE II NON-NARCOTIC"
- SET DIR("B")=$SELECT(GETS(NDROOT_".2")="YES":"YES",1:"NO")
- DO ^DIR
- +73 if $DATA(DTOUT)!($DATA(DUOUT))
- GOTO ACTIONEX
- SET GETS(NDROOT_".2")=$SELECT(Y=1:"YES",1:"NO")
- +74 ;
- +75 ; SCHEDULE III NARCOTIC
- +76 KILL DTOUT,DUOUT,DIR
- SET DIR(0)="Y"
- SET DIR("A")="SCHEDULE III NARCOTIC"
- SET DIR("B")=$SELECT(GETS(NDROOT_".3")="YES":"YES",1:"NO")
- DO ^DIR
- +77 if $DATA(DTOUT)!($DATA(DUOUT))
- GOTO ACTIONEX
- SET GETS(NDROOT_".3")=$SELECT(Y=1:"YES",1:"NO")
- +78 ;
- +79 ; SCHEDULE III NON-NARCOTIC
- +80 KILL DTOUT,DUOUT,DIR
- SET DIR(0)="Y"
- SET DIR("A")="SCHEDULE III NON-NARCOTIC"
- SET DIR("B")=$SELECT(GETS(NDROOT_".4")="YES":"YES",1:"NO")
- DO ^DIR
- +81 if $DATA(DTOUT)!($DATA(DUOUT))
- GOTO ACTIONEX
- SET GETS(NDROOT_".4")=$SELECT(Y=1:"YES",1:"NO")
- +82 ;
- +83 ; SCHEDULE IV
- +84 KILL DTOUT,DUOUT,DIR
- SET DIR(0)="Y"
- SET DIR("A")="SCHEDULE IV"
- SET DIR("B")=$SELECT(GETS(NDROOT_".5")="YES":"YES",1:"NO")
- DO ^DIR
- +85 if $DATA(DTOUT)!($DATA(DUOUT))
- GOTO ACTIONEX
- SET GETS(NDROOT_".5")=$SELECT(Y=1:"YES",1:"NO")
- +86 ;
- +87 ; SCHEDULE V
- +88 KILL DTOUT,DUOUT,DIR
- SET DIR(0)="Y"
- SET DIR("A")="SCHEDULE V"
- SET DIR("B")=$SELECT(GETS(NDROOT_".6")="YES":"YES",1:"NO")
- DO ^DIR
- +89 if $DATA(DTOUT)!($DATA(DUOUT))
- GOTO ACTIONEX
- SET GETS(NDROOT_".6")=$SELECT(Y=1:"YES",1:"NO")
- +90 ;
- ACTIONEX ; -- ACTIONE Clean Exit Point
- +1 KILL DIRUT,DIR
- +2 if $GET(PSOWSDWN)
- QUIT
- +3 DO INIT
- +4 SET VALMBCK="R"
- +5 QUIT
- +6 ;
- ACTIONX ; -- Perform Action X: QUIT AND REJECT CHANGES
- +1 DO FULL^VALM1
- +2 DO CLEAN^VALM10
- +3 SET VALMBCK="Q"
- +4 QUIT
- +5 ;
- DEACOPY(FG) ; -- Private Subroutine to Copy import data in the GETS Array
- +1 ; POSTAL^XIPUTL used in agreement with Integration Agreement: 3618
- +2 ;
- +3 ; INPUT: FG ;Web Service Response Global
- +4 ;
- +5 ; VARIABLES:
- +6 ;Single drug schedule field as sent from the VA DOJ Web Service.
- NEW DS
- +7 ;Used to calculate the state from a zip code.
- NEW XIP
- +8 ;Used to calculate the state from a zip code.
- NEW XSTATE
- +9 ;Business Activity Code
- NEW BAC
- +10 NEW I
- +11 ;
- +12 SET DS=$GET(FG("drugSchedule"))
- +13 SET GETS(.01)=$GET(FG("deaNumber"))
- +14 SET BAC=$GET(FG("businessActivityCode"))_$GET(FG("businessActivitySubcode"))
- +15 ; Pointer to file #8991.8
- SET GETS(.02)=BAC
- +16 ; DETOX NUMBER
- SET GETS(.03)=$SELECT($$GETDNDTX^PSODEAUT(NPIEN)'="":"",$$DETOXCHK^PSODEAUT(BAC):"X"_$EXTRACT($GET(FG("deaNumber")),2,9),1:"")
- +17 DO DT^DILF("E",$GET(FG("expirationDate")),.DTRESULT)
- +18 SET GETS(.04)=$GET(DTRESULT(0))
- +19 SET GETS(.07)=$GET(FG("type"))
- +20 SET GETS(1.1)=$GET(FG("name"))
- +21 SET GETS(1.2)=$GET(FG("additionalCompanyInfo"))
- +22 SET GETS(1.3)=$GET(FG("address1"))
- +23 SET GETS(1.4)=$GET(FG("address2"))
- +24 SET GETS(1.5)=$GET(FG("city"))
- +25 ;
- +26 ; Special State Processing
- +27 SET GETS(1.6)=$GET(FG("state"))
- +28 DO POSTAL^XIPUTIL($GET(FG("zipCode")),.XIP)
- +29 SET XSTATE=$GET(XIP("STATE"))
- +30 ; Pointer to the State File #5.
- IF XSTATE'=""
- SET GETS(1.6)=XSTATE
- +31 ;
- +32 SET GETS(1.7)=$GET(FG("zipCode"))
- +33 ;
- +34 ; SCHEDULE II NARCOTIC
- SET GETS(2.1)=$SELECT(DS["22N":"YES",(DS["2"&(DS'["2N")):"YES",1:"NO")
- +35 ; SCHEDULE II NON-NARCOTIC
- SET GETS(2.2)=$SELECT(DS["2N":"YES",1:"NO")
- +36 ; SCHEDULE III NARCOTIC
- SET GETS(2.3)=$SELECT(DS["33N":"YES",(DS["3"&(DS'["3N")):"YES",1:"NO")
- +37 ; SCHEDULE III NON-NARCOTIC
- SET GETS(2.4)=$SELECT(DS["3N":"YES",1:"NO")
- +38 ; SCHEDULE IV
- SET GETS(2.5)=$SELECT(DS["4":"YES",1:"NO")
- +39 ; SCHEDULE V
- SET GETS(2.6)=$SELECT(DS["5":"YES",1:"NO")
- +40 ;
- +41 IF $GET(GETS(.07))="INSTITUTIONAL"
- FOR I=2.1:.1:2.6
- SET GETS(55_"."_$PIECE(I,".",2))=GETS(I)
- +42 ;
- +43 DO DT^DILF("E",$GET(DT),.DTRESULT)
- +44 ; LAST UPDATED DATE/TIME
- SET GETS(10.2)=$GET(DTRESULT(0))
- +45 ;D DT^DILF("E",$G(FG("processedDate")),.DTRESULT)
- +46 ; LAST DOJ UPDATE DATE/TIME
- SET GETS(10.3)=$GET(DTRESULT(0))
- +47 SET GETS(10.1)=DUZ
- +48 QUIT
- +49 ;
- CLEARDTX(NPIEN) ; REMOVE DETOX NUMBERS FROM ALL OF A PROVIDERS DEA NUMBERS
- +1 NEW DNDEAIEN,FDA,NPDEAIEN
- +2 SET NPDEAIEN=0
- FOR
- SET NPDEAIEN=$ORDER(^VA(200,NPIEN,"PS4",NPDEAIEN))
- if 'NPDEAIEN
- QUIT
- Begin DoDot:1
- +3 SET DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
- +4 KILL FDA
- SET FDA(1,8991.9,DNDEAIEN_",",.03)="@"
- DO UPDATE^DIE("","FDA(1)")
- KILL FDA
- End DoDot:1
- +5 QUIT
- +6 ;
- DTXHLP ; Detox Number Help Text
- +1 NEW CDETOX,DTXDEAX
- +2 IF $GET(NPIEN)
- SET CDETOX=$$GETDNDTX^PSODEAUT(NPIEN,.DTXDEAX)
- +3 IF $GET(Y)'=""
- IF ($GET(CDETOX)'="")
- IF Y=CDETOX
- Begin DoDot:1
- +4 IF $GET(DEATXT)'=$GET(DTXDEAX)
- Begin DoDot:2
- +5 WRITE !,"The entered DETOX NUMBER already exists on DEA NUMBER: "_DTXDEAX
- +6 WRITE !,"for this provider."
- End DoDot:2
- QUIT
- End DoDot:1
- QUIT
- +7 WRITE !,"Response must contain 2 letters and 7 numbers. The numeric portion must satisfy the DEA number checksum rules."
- +8 QUIT
- +9 ;
- LSCHED(GETS) ; Get local provider schedules from NEW PERSON and add to GETS(55.1-55.6)
- +1 if $GET(GETS(.07))'="INSTITUTIONAL"
- QUIT
- +2 if '$GET(NPIEN)
- QUIT
- +3 NEW LOCSCH,LOCSCH2,I
- +4 DO GETS^DIQ(200,NPIEN,"55.1;55.2;55.3;55.4;55.5;55.6","I","LOCSCH")
- +5 MERGE LOCSCH2=LOCSCH(200,NPIEN_",")
- +6 FOR I=55.1,55.2,55.3,55.4,55.5,55.6
- SET GETS(I)=$SELECT($GET(LOCSCH2(I,"I")):"YES",1:"NO")
- +7 QUIT
- +8 ;
- MANLOAD(DUZ,DEA,GETS,FG) ; Manually load default values when web service is down
- +1 ; Load GETS()
- +2 NEW DNDEAIEN
- +3 SET DNDEAIEN=$ORDER(^XTV(8991.9,"B",DEA,0))
- +4 IF $GET(DNDEAIEN)
- DO GETS^PSODEAUT(DNDEAIEN,.GETS)
- Begin DoDot:1
- +5 ; Get Local Schedules if Institutional DEA
- IF $GET(NPIEN)
- IF ($GET(GETS(.07))="INSTITUTIONAL")
- DO LSCHED^PSODEAME(.GETS)
- End DoDot:1
- QUIT
- +6 ;
- +7 ; New DEA entered without PSO DOJ/DEA WEB SERVICE connection. Default BAC? and TYPE.
- +8 SET GETS(.01)=DEA
- +9 SET GETS(.02)="C0"
- +10 SET GETS(.03)=""
- +11 SET GETS(.04)=""
- +12 SET GETS(.07)="INDIVIDUAL"
- +13 SET GETS(1.1)=$$GET1^DIQ(200,NPIEN,.01,"E")
- +14 SET GETS(1.2)=""
- +15 SET GETS(1.3)=""
- +16 SET GETS(1.4)=""
- +17 SET GETS(1.5)=""
- +18 SET GETS(1.6)=""
- +19 SET GETS(1.7)=""
- +20 SET GETS(2.1)=""
- +21 SET GETS(2.2)=""
- +22 SET GETS(2.3)=""
- +23 SET GETS(2.4)=""
- +24 SET GETS(2.5)=""
- +25 SET GETS(2.6)=""
- +26 SET GETS(10.1)=DUZ
- +27 SET GETS(10.2)=""
- +28 SET GETS(10.3)=""
- +29 ;
- +30 ; Load FG()
- +31 SET FG("drugSchedule")=""
- +32 SET FG("deaNumber")=DEA
- +33 SET FG("businessActivityCode")="C"
- +34 SET FG("businessActivitySubcode")=0
- +35 SET FG("expirationDate")=""
- +36 SET FG("type")="INDIVIDUAL"
- +37 SET FG("name")=GETS(1.1)
- +38 SET FG("address1")=""
- +39 SET FG("address2")=""
- +40 SET FG("address3")=""
- +41 SET FG("city")=""
- +42 SET FG("state")=""
- +43 SET FG("zipCode")=""
- +44 SET FG("processedDate")=""
- +45 QUIT