PSO7L529 ;WILM/BDB - MIGRATION REPORT ;04/30/2021
;;7.0;OUTPATIENT PHARMACY;**529,684,545**;DEC 1997;Build 270
;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
;
START ;
N DEA,NPIEN,PSI,RET,PSOSTOP,REMIG,PSOPRINT,HANDPSO
K RET
S PSOPRINT=2,HANDPSO="PSO70684-INSTALL"
W !!," This option will allow you to re-run the DEA migration and "
W !," print a migration report from the last completed migration, "
W !," including ""exception"" records that did not migrate.",!
;
S REMIG=$$ASKREMIG(.PSOPRINT) Q:REMIG<0!'$G(PSOPRINT)
I $G(REMIG) D REMIG^PSO7L684 S PSOPRINT=$$ASKSCH2^PSO7L684(HANDPSO) Q:'PSOPRINT
D RPTDTHD^PSO7L684(PSOPRINT,HANDPSO)
D SELDEV Q:PSOSTOP
S X=512 X ^%ZOSF("RM")
D LOGON Q:PSOSTOP
D PROCESS
D LOGOFF
Q
;
PROCESS ; Get data, build and print one line of output at a time
N PSRXBDT
S PSRXBDT=$$FMADD^XLFDT($$DT^XLFDT(),-1095)
D SETRXDT(PSRXBDT) ; 1095 days = 3 years
U IO
S DEA="A"
D
.S RET="LOCAL DEA NUMBER|DOJ DEA NUMBER|STATUS|SOURCE|DEA SUFFIX|BUSINESS CODE|NAME|ADDITIONAL COMPANY INFO|ADDRESS 1|ADDRESS 2|CITY|STATE|ZIP|DETOX NUMBER"
.S RET=RET_"|EXPIR DATE|II N|II N-N|III N"
.S RET=RET_"|III N-N|IV|V|INPAT|PROVIDER IEN|LAST SIGN-ON|LAST RX W/IN 3 YRS|EXCEPTION 1|EXCEPTION 2"
.W !,RET
F S DEA=$O(^VA(200,"PS1",DEA)) Q:DEA="" D
. S NPIEN=0 F S NPIEN=$O(^VA(200,"PS1",DEA,NPIEN)) Q:'NPIEN D
.. D DEALIST(.RET,NPIEN)
.. I $D(RET) S PSI=0 F S PSI=$O(RET(PSI)) Q:'PSI D
... I PSI=1 S:$D(RET(2)) $P(RET(PSI),"|",3)="M",$P(RET(PSI),"|",4)="VISTA" W !,RET(PSI) Q
... I PSI>1 S $P(RET(PSI),"|",3)="M",$P(RET(PSI),"|",4)="DOJ" W !,RET(PSI) Q
D EXIT
Q
;
DEALIST(RET,NPIEN) ; -- return a List of DEA numbers and information for a single provider.
; INPUT: NPIEN - NEW PERSON FILE #200 INTERNAL ENTRY NUMBER
;
; OUTPUT: RET - A STRING OF DEA INFORMATION DELIMITED BY THE "^"
;
Q:'$G(NPIEN)
N CNT,DNDEADAT,DNDEAIEN,NPDEADAT,NPDEAIEN,I,PSAR,IENS,SUB,LASTSON,LASTRX
N PHANDLE
K RET S CNT=1
S PHANDLE="PSODEAWB-"_$$FMADD^XLFDT($$DT^XLFDT,1)
S PHANDLE=$O(^XTMP(PHANDLE),-1) S:PHANDLE'["PSODEAWB" PHANDLE="PSODEAWB"
D GETS^DIQ(200,NPIEN,".01;.111;.112;.113;.114;.115;53.2;53.11;55.1;55.2;55.3;55.4;55.5;55.6;.116","E","PSAR")
D GETS^DIQ(200,NPIEN,"747.44","I","PSAR")
S SUB=NPIEN_","
;
S RET(CNT)=""
S RET(CNT)=RET(CNT)_PSAR(200,SUB,53.2,"E")_"|" ; NEW PERSON DEA NUMBER
S RET(CNT)=RET(CNT)_"|" ; DEA POINTER NO EQUIVALENT
S RET(CNT)=RET(CNT)_"E|" ; MIGRATION STATUS
S RET(CNT)=RET(CNT)_"VISTA|" ; SOURCE
S RET(CNT)=RET(CNT)_"|" ; INDIVIDUAL DEA SUFFIX
S RET(CNT)=RET(CNT)_"|" ; BUSINDESS CODE
S RET(CNT)=RET(CNT)_PSAR(200,SUB,.01,"E")_"|" ; NAME
S RET(CNT)=RET(CNT)_"|" ; ADDITIONAL COMPANY INFO
S RET(CNT)=RET(CNT)_PSAR(200,SUB,.111,"E")_"|" ; ADDR 1
S RET(CNT)=RET(CNT)_PSAR(200,SUB,.112,"E")_"|" ; ADDR 2
S RET(CNT)=RET(CNT)_PSAR(200,SUB,.114,"E")_"|" ; CITY
S RET(CNT)=RET(CNT)_PSAR(200,SUB,.115,"E")_"|" ; STATE
S RET(CNT)=RET(CNT)_PSAR(200,SUB,.116,"E")_"|" ; ZIP
S RET(CNT)=RET(CNT)_PSAR(200,SUB,53.11,"E")_"|" ; DETOX NUMBER
S RET(CNT)=RET(CNT)_$$FMTE^XLFDT(PSAR(200,SUB,747.44,"I"))_"|" ; EXPIRATION DATE
S RET(CNT)=RET(CNT)_$G(PSAR(200,SUB,55.1,"E"))_"|" ; SCHEDULE II NARCOTIC
S RET(CNT)=RET(CNT)_$G(PSAR(200,SUB,55.2,"E"))_"|" ; SCHEDULE II NON-NARCOTIC
S RET(CNT)=RET(CNT)_$G(PSAR(200,SUB,55.3,"E"))_"|" ; SCHEDULE III NARCOTIC
S RET(CNT)=RET(CNT)_$G(PSAR(200,SUB,55.4,"E"))_"|" ; SCHEDULE III NON-NARCOTIC
S RET(CNT)=RET(CNT)_$G(PSAR(200,SUB,55.5,"E"))_"|" ; SCHEDULE IV
S RET(CNT)=RET(CNT)_$G(PSAR(200,SUB,55.6,"E"))_"|" ; SCHEDULE V
S RET(CNT)=RET(CNT)_""_"|" ; USE FOR INPATIENT ORDERS?
S RET(CNT)=RET(CNT)_NPIEN_"|" ; FILE #200 IEN
S LASTSON=$$FMTE^XLFDT($P($$GET1^DIQ(200,NPIEN,202,"I"),"."),5) S:(LASTSON'?1.2N1"/"1.2N1"/"4N) LASTSON=""
S RET(CNT)=RET(CNT)_LASTSON_"|" ; LAST SIGN-ON DATE/TIME
S LASTRX=$$FMTE^XLFDT($G(^TMP("PSODEAMX",$J,"PROVIDER",NPIEN,"LAST RX DATE")),5) S:(LASTRX'?1.2N1"/"1.2N1"/"4N) LASTRX=""
S RET(CNT)=RET(CNT)_LASTRX_"|" ; LAST RX DATE ISSUED
S RET(CNT)=RET(CNT)_$G(^XTMP(PHANDLE,"PROVIDER",NPIEN,"DEA",DEA,1))_"|"
S RET(CNT)=RET(CNT)_$G(^XTMP(PHANDLE,"PROVIDER",NPIEN,"DEA",DEA,2))
S RET(CNT)=$$UPPER(RET(CNT))
;
S NPDEAIEN=0 F CNT=2:1 S NPDEAIEN=$O(^VA(200,NPIEN,"PS4",NPDEAIEN)) Q:'+NPDEAIEN D
. S IENS=NPDEAIEN_","_NPIEN_","
. K NPDEADAT D GETS^DIQ(200.5321,IENS,"**","","NPDEADAT") Q:'$D(NPDEADAT)
. S DNDEAIEN=$$GET1^DIQ(200.5321,IENS,.03,"I") Q:'DNDEAIEN
. K DNDEADAT D GETS^DIQ(8991.9,DNDEAIEN,"**","","DNDEADAT") Q:'$D(DNDEADAT)
. ;
. S RET(CNT)=""
. S RET(CNT)=RET(CNT)_NPDEADAT(200.5321,IENS,.01)_"|" ; NEW PERSON DEA NUMBER
. S RET(CNT)=RET(CNT)_NPDEADAT(200.5321,IENS,.03)_"|" ; NEW PERSON DEA NUMBER
. S RET(CNT)=RET(CNT)_"M|" ; MIGRATION STATUS
. S RET(CNT)=RET(CNT)_"DOJ|" ; SOURCE
. S RET(CNT)=RET(CNT)_NPDEADAT(200.5321,IENS,.02)_"|" ; INDIVIDUAL DEA SUFFIX
. S RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",.02)_"|" ; BUSINESS CODE
. S RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",1.1)_"|" ; NAME 8991.9
. S RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",1.2)_"|" ; ADDL COMPANY INFO
. S RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",1.3)_"|" ; ADDR 1
. S RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",1.4)_"|" ; ADDR 2
. S RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",1.5)_"|" ; CITY
. S RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",1.6)_"|" ; STATE
. S RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",1.7)_"|" ; ZIP
. S RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",.03)_"|" ; DETOX NUMBER
. S RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",.04)_"|" ; EXPIRATION DATE
. S RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.1)_"|" ; SCHEDULE II NARCOTIC
. S RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.2)_"|" ; SCHEDULE II NON-NARCOTIC
. S RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.3)_"|" ; SCHEDULE III NARCOTIC
. S RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.4)_"|" ; SCHEDULE III NON-NARCOTIC
. S RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.5)_"|" ; SCHEDULE IV
. S RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.6)_"|" ; SCHEDULE V
. S RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",.06)_"|" ; USE FOR INPATIENT ORDERS?
. S RET(CNT)=RET(CNT)_""_"|" ; IEN
. S RET(CNT)=RET(CNT)_""_"|" ; LAST SIGN-ON DATE/TIME
. S RET(CNT)=RET(CNT)_""_"|" ; LAST RX DATE ISSUED
. S RET(CNT)=$$UPPER(RET(CNT))
Q
;
UPPER(PSOUCS) ;
Q $TR(PSOUCS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;
SELDEV ; Select Device
;
N DIR,X,Y
S PSOSTOP=0
S DIR("A",1)=""
S DIR("A",2)=" *******************************************************"
S DIR("A",3)=" ** To avoid undesired wrapping of this report, you **"
S DIR("A",4)=" ** may need to set your terminal session display **"
S DIR("A",5)=" ** to a wider margin (e.g., 512 columns). **"
S DIR("A",6)=" *******************************************************"
;
S DIR("A")=" Press return to continue or '^' to quit"
S DIR(0)="EA" D ^DIR K DIR W !
I 'Y S PSOSTOP=1 Q
;
K X,Y
S DIR("T")=0
S DIR("A",1)=""
S DIR("A",2)=" ************************************************************"
S DIR("A",3)=" ** This report is designed for a 512 column format. **"
S DIR("A",4)=" ** Please enter '0;512;9999' at the 'DEVICE:' prompt. **"
S DIR("A",5)=" ** You may queue this report to print at a later time. **"
S DIR("A",5)=" ************************************************************"
S DIR("A")=""
S DIR(0)="EA" D ^DIR K DIR W !
;
K %ZIS,IOP,POP,ZTSK N I S PSOION=$I,%ZIS="QM"
D ^%ZIS K %ZIS
I POP S IOP=PSOION D ^%ZIS K IOP,PSOION D Q
.K X,Y
.S DIR("A",1)=""
.S DIR("A",2)=" ** No Device Selected **"
.S DIR("A")=" Press return to continue or '^' to quit"
.S DIR(0)="EA" D ^DIR K DIR W !
.S PSOSTOP=1
;
I $D(IO("Q")) D
. N ZTRTN,ZTDESC,ZTIO,ZTSAVE,ZTDTH,ZTSK,ZTREQ,ZTQUEUED
. S:$G(ZPR) ZTIO="`"_ZPR,ZTDTH=$H S ZTRTN="PROCESS^PSO7L529",ZTDESC=XQY0
. D ^%ZTLOAD W:$D(ZTSK) !,"Report is Queued to print !!"
. S PSOSTOP=1
Q
;
LOGON ; Turn on Logging Message
N DIR
S PSOSTOP=0
S DIR("A",1)=" *****************************************************"
S DIR("A",2)=" ** This is a Delimited report. Please verify you **"
S DIR("A",3)=" ** have identified a log file, and have turned **"
S DIR("A",4)=" ** logging on to capture the output. **"
S DIR("A",5)=" *****************************************************"
S DIR("A",6)=""
S DIR("A")=" Press return to continue or '^' to quit"
S DIR(0)="EA" D ^DIR W !
S:'Y PSOSTOP=1
Q
;
LOGOFF ; Turn off Logging Message
N DIR
S DIR("A",1)=" *******************************************************"
S DIR("A",2)=" ** The report is complete. Please verify you have **"
S DIR("A",3)=" ** turned logging off to save the captured output. **"
S DIR("A",4)=" *******************************************************"
S DIR("A",5)="",DIR("A",6)=""
S DIR("A")=" Press return to continue "
S DIR(0)="EA" D ^DIR W !
Q
SETRXDT(PSDSD) ; Find recent provider order activity
; Input: PSDSD (optional) - Only look back as far as this date; default to 365 days, ignore dates more than 10 years in the past.
; Output: ^TMP("PSODEAMX",$J,"PROVIDER",DUZ,"LAST RX DATE",RX ISSUE DATE)=RXIEN
;
N PSOCURDT S PSOCURDT=$$DT^XLFDT
I ($G(PSDSD)'?7N)&($G(PSDSD)'?8N1".".N) S PSDSD=""
K ^TMP("PSODEAMX",$J)
I '$G(PSDSD)!($G(PSDSD)<$$FMADD^XLFDT($$DT^XLFDT,-3650)) S PSDSD=$$FMADD^XLFDT($$DT^XLFDT,-365)
;
D PROCRX(PSDSD)
Q
;
PROCRX(PSDSD) ; Search Rx's
N PRVIEN,RXISSUE,RXISSUE,RXIEN,ORD,RX0
S RXISSUE=$$FMADD^XLFDT($$DT^XLFDT,365)
F S RXISSUE=$O(^PSRX("AC",RXISSUE),-1) Q:'RXISSUE!(RXISSUE<PSDSD) D
. S RXIEN=0 F S RXIEN=$O(^PSRX("AC",RXISSUE,RXIEN)) Q:'RXIEN D
.. Q:'$D(^PSRX(RXIEN,0)) S RX0=^(0),ORD=$P($G(^("OR1")),"^",2)
.. Q:'$P(RX0,"^",2) ; Order must contain a patient
.. S PRVIEN=$P(RX0,"^",4) Q:'PRVIEN ; Order must contain a provider
.. Q:'$L($P($G(^VA(200,PRVIEN,"PS")),"^",2))
.. I '$D(^TMP("PSODEAMX",$J,"PROVIDER",PRVIEN,"LAST RX DATE")) S ^TMP("PSODEAMX",$J,"PROVIDER",PRVIEN,"LAST RX DATE")=RXISSUE_"^"_RXIEN
Q
;
ASKREMIG(PSOPRINT) ; Ask if DEA Migration should be run
N DIR,LASTMSG,XTMP0,STATUS,XTMP0,P684CHK,LASTRUN,MIGSTAT,PSOAST,DUOUT,DTOUT,MIRESET,FG,WSTAT,P684CHK
S MIRESET=0,PSOPRINT=1
S $P(PSOAST,"*",75)="*"
S LASTMSG="The DEA Migration",LASTRUN=""
S STATUS=$G(^XTMP(HANDPSO,"STATUS"))
S LASTRUN=$P($G(^XTMP(HANDPSO,0)),"^",2)
I $G(LASTRUN) S P684CHK=$$FMDIFF^XLFDT($$DT^XLFDT(),LASTRUN)
I (STATUS="Install Completed"),LASTRUN S LASTMSG=LASTMSG_" was last run on "_$$FMTE^XLFDT(LASTRUN)
I $L(STATUS),(STATUS'="Install Completed") S LASTMSG=LASTMSG_" did not run to completion."
I '$G(LASTRUN) S LASTMSG=LASTMSG_" was last run more than 7 days ago."
;
S MIGSTAT=$G(^XTMP(HANDPSO,"STATUS"))
;
L +^XTMP(HANDPSO):0 I '$T D Q $S(($D(DTOUT)!$D(DUOUT)):-1,1:0)
. N DIR
. S DIR("A",1)=PSOAST
. S DIR("A",2)=" The DEA Migration is currently running. "
. S DIR("A",3)="The migration must run to completion before printing the migration report."
. S DIR("A",4)=" Please try again later."
. S DIR("A",5)=PSOAST
. S DIR(0)="E",(DIR("?"),DIR("A"))="Press Return to continue"
. D ^DIR S PSOPRINT=0
;
I $G(MIGSTAT)["Start of Install" S PSOPRINT=$$ASKRPTSCH^PSO7L684(.MIRESET) I '$G(MIRESET) Q $S(($D(DTOUT)!$D(DUOUT)):-1,1:0)
;
S WSTAT=$$WSGET^PSODEAU0(.FG,0) I $P(WSTAT,"^",3)=6059 D Q 0
. D BMES^XPDUTL("Unable to Establish a Connection to the PSO DOJ/DEA Web Service.")
. D MES^XPDUTL("The DEA Migration cannot be refreshed until a connection")
. D MES^XPDUTL("to the web service is restored.")
. L -^XTMP(HANDPSO)
;
I $$PROD^XUPROD,$$P545CHK7^PSO7E684() L -^XTMP(HANDPSO) Q 0 ; Don't run migration in production if PSO*7*545 has been installed more than 7 days ago
;
K DIR S DIR(0)="Y"
S DIR("?",1)="Answer YES if you wish to queue a re-run of the data migration."
S DIR("?",2)="This may take several hours. An email will be generated"
S DIR("?",3)="to holders of the PSDMGR key when the re-run is complete."
S DIR("?",4)="",DIR("?")="Answer NO to display the report of the existing migrated records."
S DIR("??")="^D MSHLP^PSO7E684"
S DIR("A",1)="",DIR("A",2)=LASTMSG
S DIR("A")="Do you want to re-run the DEA Migration",DIR("B")="N" D ^DIR
I $D(DTOUT)!($D(DUOUT)) L -^XTMP(HANDPSO) Q -1
;
I $G(Y)>0 D I $G(Y)>0 Q 1
. K DIR,Y,DUOUT,DTOUT S DIR(0)="Y"
. S DIR("A",1)=""
. S DIR("A",2)=" ******************** WARNING *************************"
. S DIR("A",3)=" This will DELETE all previously migrated DEA data "
. S DIR("A",4)=" and repopulate by running a new DEA migration."
. S DIR("A",5)="*******************************************************"
. S DIR("A")="Are you sure you want to re-run the DEA Migration",DIR("B")="N" D ^DIR
. D BMES^XPDUTL("")
;
L -^XTMP(HANDPSO)
I $D(DTOUT)!($D(DUOUT)) Q -1
Q 0
;
EXIT ; Close Device
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSO7L529 13736 printed Dec 13, 2024@02:23:40 Page 2
PSO7L529 ;WILM/BDB - MIGRATION REPORT ;04/30/2021
+1 ;;7.0;OUTPATIENT PHARMACY;**529,684,545**;DEC 1997;Build 270
+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 QUIT
+5 ;
START ;
+1 NEW DEA,NPIEN,PSI,RET,PSOSTOP,REMIG,PSOPRINT,HANDPSO
+2 KILL RET
+3 SET PSOPRINT=2
SET HANDPSO="PSO70684-INSTALL"
+4 WRITE !!," This option will allow you to re-run the DEA migration and "
+5 WRITE !," print a migration report from the last completed migration, "
+6 WRITE !," including ""exception"" records that did not migrate.",!
+7 ;
+8 SET REMIG=$$ASKREMIG(.PSOPRINT)
if REMIG<0!'$GET(PSOPRINT)
QUIT
+9 IF $GET(REMIG)
DO REMIG^PSO7L684
SET PSOPRINT=$$ASKSCH2^PSO7L684(HANDPSO)
if 'PSOPRINT
QUIT
+10 DO RPTDTHD^PSO7L684(PSOPRINT,HANDPSO)
+11 DO SELDEV
if PSOSTOP
QUIT
+12 SET X=512
XECUTE ^%ZOSF("RM")
+13 DO LOGON
if PSOSTOP
QUIT
+14 DO PROCESS
+15 DO LOGOFF
+16 QUIT
+17 ;
PROCESS ; Get data, build and print one line of output at a time
+1 NEW PSRXBDT
+2 SET PSRXBDT=$$FMADD^XLFDT($$DT^XLFDT(),-1095)
+3 ; 1095 days = 3 years
DO SETRXDT(PSRXBDT)
+4 USE IO
+5 SET DEA="A"
+6 Begin DoDot:1
+7 SET RET="LOCAL DEA NUMBER|DOJ DEA NUMBER|STATUS|SOURCE|DEA SUFFIX|BUSINESS CODE|NAME|ADDITIONAL COMPANY INFO|ADDRESS 1|ADDRESS 2|CITY|STATE|ZIP|DETOX NUMBER"
+8 SET RET=RET_"|EXPIR DATE|II N|II N-N|III N"
+9 SET RET=RET_"|III N-N|IV|V|INPAT|PROVIDER IEN|LAST SIGN-ON|LAST RX W/IN 3 YRS|EXCEPTION 1|EXCEPTION 2"
+10 WRITE !,RET
End DoDot:1
+11 FOR
SET DEA=$ORDER(^VA(200,"PS1",DEA))
if DEA=""
QUIT
Begin DoDot:1
+12 SET NPIEN=0
FOR
SET NPIEN=$ORDER(^VA(200,"PS1",DEA,NPIEN))
if 'NPIEN
QUIT
Begin DoDot:2
+13 DO DEALIST(.RET,NPIEN)
+14 IF $DATA(RET)
SET PSI=0
FOR
SET PSI=$ORDER(RET(PSI))
if 'PSI
QUIT
Begin DoDot:3
+15 IF PSI=1
if $DATA(RET(2))
SET $PIECE(RET(PSI),"|",3)="M"
SET $PIECE(RET(PSI),"|",4)="VISTA"
WRITE !,RET(PSI)
QUIT
+16 IF PSI>1
SET $PIECE(RET(PSI),"|",3)="M"
SET $PIECE(RET(PSI),"|",4)="DOJ"
WRITE !,RET(PSI)
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+17 DO EXIT
+18 QUIT
+19 ;
DEALIST(RET,NPIEN) ; -- return a List of DEA numbers and information for a single provider.
+1 ; INPUT: NPIEN - NEW PERSON FILE #200 INTERNAL ENTRY NUMBER
+2 ;
+3 ; OUTPUT: RET - A STRING OF DEA INFORMATION DELIMITED BY THE "^"
+4 ;
+5 if '$GET(NPIEN)
QUIT
+6 NEW CNT,DNDEADAT,DNDEAIEN,NPDEADAT,NPDEAIEN,I,PSAR,IENS,SUB,LASTSON,LASTRX
+7 NEW PHANDLE
+8 KILL RET
SET CNT=1
+9 SET PHANDLE="PSODEAWB-"_$$FMADD^XLFDT($$DT^XLFDT,1)
+10 SET PHANDLE=$ORDER(^XTMP(PHANDLE),-1)
if PHANDLE'["PSODEAWB"
SET PHANDLE="PSODEAWB"
+11 DO GETS^DIQ(200,NPIEN,".01;.111;.112;.113;.114;.115;53.2;53.11;55.1;55.2;55.3;55.4;55.5;55.6;.116","E","PSAR")
+12 DO GETS^DIQ(200,NPIEN,"747.44","I","PSAR")
+13 SET SUB=NPIEN_","
+14 ;
+15 SET RET(CNT)=""
+16 ; NEW PERSON DEA NUMBER
SET RET(CNT)=RET(CNT)_PSAR(200,SUB,53.2,"E")_"|"
+17 ; DEA POINTER NO EQUIVALENT
SET RET(CNT)=RET(CNT)_"|"
+18 ; MIGRATION STATUS
SET RET(CNT)=RET(CNT)_"E|"
+19 ; SOURCE
SET RET(CNT)=RET(CNT)_"VISTA|"
+20 ; INDIVIDUAL DEA SUFFIX
SET RET(CNT)=RET(CNT)_"|"
+21 ; BUSINDESS CODE
SET RET(CNT)=RET(CNT)_"|"
+22 ; NAME
SET RET(CNT)=RET(CNT)_PSAR(200,SUB,.01,"E")_"|"
+23 ; ADDITIONAL COMPANY INFO
SET RET(CNT)=RET(CNT)_"|"
+24 ; ADDR 1
SET RET(CNT)=RET(CNT)_PSAR(200,SUB,.111,"E")_"|"
+25 ; ADDR 2
SET RET(CNT)=RET(CNT)_PSAR(200,SUB,.112,"E")_"|"
+26 ; CITY
SET RET(CNT)=RET(CNT)_PSAR(200,SUB,.114,"E")_"|"
+27 ; STATE
SET RET(CNT)=RET(CNT)_PSAR(200,SUB,.115,"E")_"|"
+28 ; ZIP
SET RET(CNT)=RET(CNT)_PSAR(200,SUB,.116,"E")_"|"
+29 ; DETOX NUMBER
SET RET(CNT)=RET(CNT)_PSAR(200,SUB,53.11,"E")_"|"
+30 ; EXPIRATION DATE
SET RET(CNT)=RET(CNT)_$$FMTE^XLFDT(PSAR(200,SUB,747.44,"I"))_"|"
+31 ; SCHEDULE II NARCOTIC
SET RET(CNT)=RET(CNT)_$GET(PSAR(200,SUB,55.1,"E"))_"|"
+32 ; SCHEDULE II NON-NARCOTIC
SET RET(CNT)=RET(CNT)_$GET(PSAR(200,SUB,55.2,"E"))_"|"
+33 ; SCHEDULE III NARCOTIC
SET RET(CNT)=RET(CNT)_$GET(PSAR(200,SUB,55.3,"E"))_"|"
+34 ; SCHEDULE III NON-NARCOTIC
SET RET(CNT)=RET(CNT)_$GET(PSAR(200,SUB,55.4,"E"))_"|"
+35 ; SCHEDULE IV
SET RET(CNT)=RET(CNT)_$GET(PSAR(200,SUB,55.5,"E"))_"|"
+36 ; SCHEDULE V
SET RET(CNT)=RET(CNT)_$GET(PSAR(200,SUB,55.6,"E"))_"|"
+37 ; USE FOR INPATIENT ORDERS?
SET RET(CNT)=RET(CNT)_""_"|"
+38 ; FILE #200 IEN
SET RET(CNT)=RET(CNT)_NPIEN_"|"
+39 SET LASTSON=$$FMTE^XLFDT($PIECE($$GET1^DIQ(200,NPIEN,202,"I"),"."),5)
if (LASTSON'?1.2N1"/"1.2N1"/"4N)
SET LASTSON=""
+40 ; LAST SIGN-ON DATE/TIME
SET RET(CNT)=RET(CNT)_LASTSON_"|"
+41 SET LASTRX=$$FMTE^XLFDT($GET(^TMP("PSODEAMX",$JOB,"PROVIDER",NPIEN,"LAST RX DATE")),5)
if (LASTRX'?1.2N1"/"1.2N1"/"4N)
SET LASTRX=""
+42 ; LAST RX DATE ISSUED
SET RET(CNT)=RET(CNT)_LASTRX_"|"
+43 SET RET(CNT)=RET(CNT)_$GET(^XTMP(PHANDLE,"PROVIDER",NPIEN,"DEA",DEA,1))_"|"
+44 SET RET(CNT)=RET(CNT)_$GET(^XTMP(PHANDLE,"PROVIDER",NPIEN,"DEA",DEA,2))
+45 SET RET(CNT)=$$UPPER(RET(CNT))
+46 ;
+47 SET NPDEAIEN=0
FOR CNT=2:1
SET NPDEAIEN=$ORDER(^VA(200,NPIEN,"PS4",NPDEAIEN))
if '+NPDEAIEN
QUIT
Begin DoDot:1
+48 SET IENS=NPDEAIEN_","_NPIEN_","
+49 KILL NPDEADAT
DO GETS^DIQ(200.5321,IENS,"**","","NPDEADAT")
if '$DATA(NPDEADAT)
QUIT
+50 SET DNDEAIEN=$$GET1^DIQ(200.5321,IENS,.03,"I")
if 'DNDEAIEN
QUIT
+51 KILL DNDEADAT
DO GETS^DIQ(8991.9,DNDEAIEN,"**","","DNDEADAT")
if '$DATA(DNDEADAT)
QUIT
+52 ;
+53 SET RET(CNT)=""
+54 ; NEW PERSON DEA NUMBER
SET RET(CNT)=RET(CNT)_NPDEADAT(200.5321,IENS,.01)_"|"
+55 ; NEW PERSON DEA NUMBER
SET RET(CNT)=RET(CNT)_NPDEADAT(200.5321,IENS,.03)_"|"
+56 ; MIGRATION STATUS
SET RET(CNT)=RET(CNT)_"M|"
+57 ; SOURCE
SET RET(CNT)=RET(CNT)_"DOJ|"
+58 ; INDIVIDUAL DEA SUFFIX
SET RET(CNT)=RET(CNT)_NPDEADAT(200.5321,IENS,.02)_"|"
+59 ; BUSINESS CODE
SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",.02)_"|"
+60 ; NAME 8991.9
SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",1.1)_"|"
+61 ; ADDL COMPANY INFO
SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",1.2)_"|"
+62 ; ADDR 1
SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",1.3)_"|"
+63 ; ADDR 2
SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",1.4)_"|"
+64 ; CITY
SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",1.5)_"|"
+65 ; STATE
SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",1.6)_"|"
+66 ; ZIP
SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",1.7)_"|"
+67 ; DETOX NUMBER
SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",.03)_"|"
+68 ; EXPIRATION DATE
SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",.04)_"|"
+69 ; SCHEDULE II NARCOTIC
SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.1)_"|"
+70 ; SCHEDULE II NON-NARCOTIC
SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.2)_"|"
+71 ; SCHEDULE III NARCOTIC
SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.3)_"|"
+72 ; SCHEDULE III NON-NARCOTIC
SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.4)_"|"
+73 ; SCHEDULE IV
SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.5)_"|"
+74 ; SCHEDULE V
SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.6)_"|"
+75 ; USE FOR INPATIENT ORDERS?
SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",.06)_"|"
+76 ; IEN
SET RET(CNT)=RET(CNT)_""_"|"
+77 ; LAST SIGN-ON DATE/TIME
SET RET(CNT)=RET(CNT)_""_"|"
+78 ; LAST RX DATE ISSUED
SET RET(CNT)=RET(CNT)_""_"|"
+79 SET RET(CNT)=$$UPPER(RET(CNT))
End DoDot:1
+80 QUIT
+81 ;
UPPER(PSOUCS) ;
+1 QUIT $TRANSLATE(PSOUCS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 ;
SELDEV ; Select Device
+1 ;
+2 NEW DIR,X,Y
+3 SET PSOSTOP=0
+4 SET DIR("A",1)=""
+5 SET DIR("A",2)=" *******************************************************"
+6 SET DIR("A",3)=" ** To avoid undesired wrapping of this report, you **"
+7 SET DIR("A",4)=" ** may need to set your terminal session display **"
+8 SET DIR("A",5)=" ** to a wider margin (e.g., 512 columns). **"
+9 SET DIR("A",6)=" *******************************************************"
+10 ;
+11 SET DIR("A")=" Press return to continue or '^' to quit"
+12 SET DIR(0)="EA"
DO ^DIR
KILL DIR
WRITE !
+13 IF 'Y
SET PSOSTOP=1
QUIT
+14 ;
+15 KILL X,Y
+16 SET DIR("T")=0
+17 SET DIR("A",1)=""
+18 SET DIR("A",2)=" ************************************************************"
+19 SET DIR("A",3)=" ** This report is designed for a 512 column format. **"
+20 SET DIR("A",4)=" ** Please enter '0;512;9999' at the 'DEVICE:' prompt. **"
+21 SET DIR("A",5)=" ** You may queue this report to print at a later time. **"
+22 SET DIR("A",5)=" ************************************************************"
+23 SET DIR("A")=""
+24 SET DIR(0)="EA"
DO ^DIR
KILL DIR
WRITE !
+25 ;
+26 KILL %ZIS,IOP,POP,ZTSK
NEW I
SET PSOION=$IO
SET %ZIS="QM"
+27 DO ^%ZIS
KILL %ZIS
+28 IF POP
SET IOP=PSOION
DO ^%ZIS
KILL IOP,PSOION
Begin DoDot:1
+29 KILL X,Y
+30 SET DIR("A",1)=""
+31 SET DIR("A",2)=" ** No Device Selected **"
+32 SET DIR("A")=" Press return to continue or '^' to quit"
+33 SET DIR(0)="EA"
DO ^DIR
KILL DIR
WRITE !
+34 SET PSOSTOP=1
End DoDot:1
QUIT
+35 ;
+36 IF $DATA(IO("Q"))
Begin DoDot:1
+37 NEW ZTRTN,ZTDESC,ZTIO,ZTSAVE,ZTDTH,ZTSK,ZTREQ,ZTQUEUED
+38 if $GET(ZPR)
SET ZTIO="`"_ZPR
SET ZTDTH=$HOROLOG
SET ZTRTN="PROCESS^PSO7L529"
SET ZTDESC=XQY0
+39 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Report is Queued to print !!"
+40 SET PSOSTOP=1
End DoDot:1
+41 QUIT
+42 ;
LOGON ; Turn on Logging Message
+1 NEW DIR
+2 SET PSOSTOP=0
+3 SET DIR("A",1)=" *****************************************************"
+4 SET DIR("A",2)=" ** This is a Delimited report. Please verify you **"
+5 SET DIR("A",3)=" ** have identified a log file, and have turned **"
+6 SET DIR("A",4)=" ** logging on to capture the output. **"
+7 SET DIR("A",5)=" *****************************************************"
+8 SET DIR("A",6)=""
+9 SET DIR("A")=" Press return to continue or '^' to quit"
+10 SET DIR(0)="EA"
DO ^DIR
WRITE !
+11 if 'Y
SET PSOSTOP=1
+12 QUIT
+13 ;
LOGOFF ; Turn off Logging Message
+1 NEW DIR
+2 SET DIR("A",1)=" *******************************************************"
+3 SET DIR("A",2)=" ** The report is complete. Please verify you have **"
+4 SET DIR("A",3)=" ** turned logging off to save the captured output. **"
+5 SET DIR("A",4)=" *******************************************************"
+6 SET DIR("A",5)=""
SET DIR("A",6)=""
+7 SET DIR("A")=" Press return to continue "
+8 SET DIR(0)="EA"
DO ^DIR
WRITE !
+9 QUIT
SETRXDT(PSDSD) ; Find recent provider order activity
+1 ; Input: PSDSD (optional) - Only look back as far as this date; default to 365 days, ignore dates more than 10 years in the past.
+2 ; Output: ^TMP("PSODEAMX",$J,"PROVIDER",DUZ,"LAST RX DATE",RX ISSUE DATE)=RXIEN
+3 ;
+4 NEW PSOCURDT
SET PSOCURDT=$$DT^XLFDT
+5 IF ($GET(PSDSD)'?7N)&($GET(PSDSD)'?8N1".".N)
SET PSDSD=""
+6 KILL ^TMP("PSODEAMX",$JOB)
+7 IF '$GET(PSDSD)!($GET(PSDSD)<$$FMADD^XLFDT($$DT^XLFDT,-3650))
SET PSDSD=$$FMADD^XLFDT($$DT^XLFDT,-365)
+8 ;
+9 DO PROCRX(PSDSD)
+10 QUIT
+11 ;
PROCRX(PSDSD) ; Search Rx's
+1 NEW PRVIEN,RXISSUE,RXISSUE,RXIEN,ORD,RX0
+2 SET RXISSUE=$$FMADD^XLFDT($$DT^XLFDT,365)
+3 FOR
SET RXISSUE=$ORDER(^PSRX("AC",RXISSUE),-1)
if 'RXISSUE!(RXISSUE<PSDSD)
QUIT
Begin DoDot:1
+4 SET RXIEN=0
FOR
SET RXIEN=$ORDER(^PSRX("AC",RXISSUE,RXIEN))
if 'RXIEN
QUIT
Begin DoDot:2
+5 if '$DATA(^PSRX(RXIEN,0))
QUIT
SET RX0=^(0)
SET ORD=$PIECE($GET(^("OR1")),"^",2)
+6 ; Order must contain a patient
if '$PIECE(RX0,"^",2)
QUIT
+7 ; Order must contain a provider
SET PRVIEN=$PIECE(RX0,"^",4)
if 'PRVIEN
QUIT
+8 if '$LENGTH($PIECE($GET(^VA(200,PRVIEN,"PS")),"^",2))
QUIT
+9 IF '$DATA(^TMP("PSODEAMX",$JOB,"PROVIDER",PRVIEN,"LAST RX DATE"))
SET ^TMP("PSODEAMX",$JOB,"PROVIDER",PRVIEN,"LAST RX DATE")=RXISSUE_"^"_RXIEN
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
ASKREMIG(PSOPRINT) ; Ask if DEA Migration should be run
+1 NEW DIR,LASTMSG,XTMP0,STATUS,XTMP0,P684CHK,LASTRUN,MIGSTAT,PSOAST,DUOUT,DTOUT,MIRESET,FG,WSTAT,P684CHK
+2 SET MIRESET=0
SET PSOPRINT=1
+3 SET $PIECE(PSOAST,"*",75)="*"
+4 SET LASTMSG="The DEA Migration"
SET LASTRUN=""
+5 SET STATUS=$GET(^XTMP(HANDPSO,"STATUS"))
+6 SET LASTRUN=$PIECE($GET(^XTMP(HANDPSO,0)),"^",2)
+7 IF $GET(LASTRUN)
SET P684CHK=$$FMDIFF^XLFDT($$DT^XLFDT(),LASTRUN)
+8 IF (STATUS="Install Completed")
IF LASTRUN
SET LASTMSG=LASTMSG_" was last run on "_$$FMTE^XLFDT(LASTRUN)
+9 IF $LENGTH(STATUS)
IF (STATUS'="Install Completed")
SET LASTMSG=LASTMSG_" did not run to completion."
+10 IF '$GET(LASTRUN)
SET LASTMSG=LASTMSG_" was last run more than 7 days ago."
+11 ;
+12 SET MIGSTAT=$GET(^XTMP(HANDPSO,"STATUS"))
+13 ;
+14 LOCK +^XTMP(HANDPSO):0
IF '$TEST
Begin DoDot:1
+15 NEW DIR
+16 SET DIR("A",1)=PSOAST
+17 SET DIR("A",2)=" The DEA Migration is currently running. "
+18 SET DIR("A",3)="The migration must run to completion before printing the migration report."
+19 SET DIR("A",4)=" Please try again later."
+20 SET DIR("A",5)=PSOAST
+21 SET DIR(0)="E"
SET (DIR("?"),DIR("A"))="Press Return to continue"
+22 DO ^DIR
SET PSOPRINT=0
End DoDot:1
QUIT $SELECT(($DATA(DTOUT)!$DATA(DUOUT)):-1,1:0)
+23 ;
+24 IF $GET(MIGSTAT)["Start of Install"
SET PSOPRINT=$$ASKRPTSCH^PSO7L684(.MIRESET)
IF '$GET(MIRESET)
QUIT $SELECT(($DATA(DTOUT)!$DATA(DUOUT)):-1,1:0)
+25 ;
+26 SET WSTAT=$$WSGET^PSODEAU0(.FG,0)
IF $PIECE(WSTAT,"^",3)=6059
Begin DoDot:1
+27 DO BMES^XPDUTL("Unable to Establish a Connection to the PSO DOJ/DEA Web Service.")
+28 DO MES^XPDUTL("The DEA Migration cannot be refreshed until a connection")
+29 DO MES^XPDUTL("to the web service is restored.")
+30 LOCK -^XTMP(HANDPSO)
End DoDot:1
QUIT 0
+31 ;
+32 ; Don't run migration in production if PSO*7*545 has been installed more than 7 days ago
IF $$PROD^XUPROD
IF $$P545CHK7^PSO7E684()
LOCK -^XTMP(HANDPSO)
QUIT 0
+33 ;
+34 KILL DIR
SET DIR(0)="Y"
+35 SET DIR("?",1)="Answer YES if you wish to queue a re-run of the data migration."
+36 SET DIR("?",2)="This may take several hours. An email will be generated"
+37 SET DIR("?",3)="to holders of the PSDMGR key when the re-run is complete."
+38 SET DIR("?",4)=""
SET DIR("?")="Answer NO to display the report of the existing migrated records."
+39 SET DIR("??")="^D MSHLP^PSO7E684"
+40 SET DIR("A",1)=""
SET DIR("A",2)=LASTMSG
+41 SET DIR("A")="Do you want to re-run the DEA Migration"
SET DIR("B")="N"
DO ^DIR
+42 IF $DATA(DTOUT)!($DATA(DUOUT))
LOCK -^XTMP(HANDPSO)
QUIT -1
+43 ;
+44 IF $GET(Y)>0
Begin DoDot:1
+45 KILL DIR,Y,DUOUT,DTOUT
SET DIR(0)="Y"
+46 SET DIR("A",1)=""
+47 SET DIR("A",2)=" ******************** WARNING *************************"
+48 SET DIR("A",3)=" This will DELETE all previously migrated DEA data "
+49 SET DIR("A",4)=" and repopulate by running a new DEA migration."
+50 SET DIR("A",5)="*******************************************************"
+51 SET DIR("A")="Are you sure you want to re-run the DEA Migration"
SET DIR("B")="N"
DO ^DIR
+52 DO BMES^XPDUTL("")
End DoDot:1
IF $GET(Y)>0
QUIT 1
+53 ;
+54 LOCK -^XTMP(HANDPSO)
+55 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT -1
+56 QUIT 0
+57 ;
EXIT ; Close Device
+1 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 QUIT
