PSODEAUJ ;ALB/MFR - DEA NIGHTLY UPDATE JOB ; 11 Jul 2025 7:08 PM
;;7.0;OUTPATIENT PHARMACY;**770**;DEC 1997;Build 145
;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
Q
AUTO ; DEA Nightly Update Scheduled Background Job Edit
N DIC,Y S DIC(0)="XZM",DIC="^DIC(19.2,",X="PSO DEA/DOJ NIGHTLY DATA UPD" D ^DIC
I +Y>0 S DA=Y D EDIT^XUTMOPT("PSO DEA/DOJ NIGHTLY DATA UPD") Q
D RESCH^XUTMOPT("PSO DEA/DOJ NIGHTLY DATA UPD",$$FMADD^XLFDT(DT,1)+.0001,"","24H","L")
D EDIT^XUTMOPT("PSO DEA/DOJ NIGHTLY DATA UPD")
Q
;
DEAUPD ; Update DEA #'s that are about to expire in the DEA NUMBERS file (#8991.9)
N DEANUM,DEAIEN,DATA,OLDDEA,MSGTXT,COUNT,MSGLINE
;
I '$$PROD^XUPROD() Q ; Will run in Prod accounts only
;
S (DEAIEN,MSGLINE,COUNT)=0
F S DEAIEN=$O(^XTV(8991.9,DEAIEN)) Q:'DEAIEN D I COUNT>500 Q
. S DEAEXP=$$GET1^DIQ(8991.9,DEAIEN,.04,"I")
. I DEAEXP>$$FMADD^XLFDT(DT,30) Q ; Exp. Date more than 30 days in the future
. S DEANUM=$$GET1^DIQ(8991.9,DEAIEN,.01)
. D GETS^DIQ(8991.9,DEAIEN,"**","","DATA")
. M OLDDEA=DATA(8991.9,DEAIEN_",")
. D DEADOJ^PSODEAUT(.NEWDEA,DEANUM) I '$G(NEWDEA(0)) Q
. S $P(NEWDEA(1),"^",12)=$$HL7TFM^XLFDT($P(NEWDEA(1),"^",12))
. I $P(NEWDEA(1),"^",12)'>DEAEXP Q ; New Exp. Date not later than Exp. Date on file
. ; Preserving USE FOR INPATIENT ORDERS? (#.06) and SCHEDULE permissions (#2.1-#2.6) fields (except MbM)
. I $$GET1^DIQ(59.7,1,102,"I")'="MBM" D
. . S $P(NEWDEA(1),"^",21)=$G(OLDDEA(.06))
. . S $P(NEWDEA(1),"^",15)=$G(OLDDEA(2.1))
. . S $P(NEWDEA(1),"^",16)=$G(OLDDEA(2.2))
. . S $P(NEWDEA(1),"^",17)=$G(OLDDEA(2.3))
. . S $P(NEWDEA(1),"^",18)=$G(OLDDEA(2.4))
. . S $P(NEWDEA(1),"^",19)=$G(OLDDEA(2.5))
. . S $P(NEWDEA(1),"^",20)=$G(OLDDEA(2.6))
. D FILEFM^PSODEAUT(.RET,$G(NEWDEA(1)))
. D ADD2MSG(DEANUM,.OLDDEA,$G(NEWDEA(1)))
. S COUNT=COUNT+1
I 'COUNT Q
D ADDTXT(""),ADDTXT(COUNT_" DEA #'s have been updated.")
D SENDMSG
;
Q
;
ADD2MSG(DEANUM,OLDDEA,NEWDEA) ; Builds the Mailman Message to be sent to PSDRPH key holders
;Input: DEANUM - DEA Number
; OLDDEA - DEA data before the Update
; NEWDEA - DEA data after the Update
I '$D(MSGTXT) D
. S MSGTXT(1)="The list below shows DEA Numbers that have been updated with data from DEA/DOJ"
. S MSGTXT(2)="Database because they were 30 days or less from expiring."
;
D ADDTXT("")
D ADDTXT("DEA #: "_DEANUM)
D ADDTXT("----------------")
S TXT="BEFORE:",$E(TXT,41)="AFTER"
D ADDTXT($$DATALINE("Exp. Date: ",$G(OLDDEA(.04)),$$FMTE^XLFDT($P(NEWDEA,"^",12))))
D ADDTXT($$DATALINE("Name: ",$G(OLDDEA(1.1)),$P(NEWDEA,"^",1)))
D ADDTXT($$DATALINE("Company: ",$G(OLDDEA(1.2)),$P(NEWDEA,"^",2)))
D ADDTXT($$DATALINE("Address 1: ",$G(OLDDEA(1.3)),$P(NEWDEA,"^",3)))
D ADDTXT($$DATALINE("Address 2: ",$G(OLDDEA(1.4)),$P(NEWDEA,"^",4)))
D ADDTXT($$DATALINE("City: ",$G(OLDDEA(1.5)),$P(NEWDEA,"^",5)))
D ADDTXT($$DATALINE("State: ",$G(OLDDEA(1.6)),$P(NEWDEA,"^",6)))
D ADDTXT($$DATALINE("Zip Code: ",$G(OLDDEA(1.7)),$P(NEWDEA,"^",8)))
D ADDTXT($$DATALINE("Activity Code: ",$G(OLDDEA(.02)),$P(NEWDEA,"^",9)))
D ADDTXT($$DATALINE("Type: ",$G(OLDDEA(.07)),$P(NEWDEA,"^",10)))
D ADDTXT($$DATALINE("Detox #: ",$G(OLDDEA(.03)),$P(NEWDEA,"^",14)))
I $$GET1^DIQ(59.7,1,102,"I")="MBM" D
. D ADDTXT($$DATALINE("Schedule II-Narcotic: ",$G(OLDDEA(2.1)),$P(NEWDEA,"^",15)))
. D ADDTXT($$DATALINE("Schedule II-Non Narcotic: ",$G(OLDDEA(2.2)),$P(NEWDEA,"^",16)))
. D ADDTXT($$DATALINE("Schedule III-Narcotic: ",$G(OLDDEA(2.3)),$P(NEWDEA,"^",17)))
. D ADDTXT($$DATALINE("Schedule III-Non Narcotic: ",$G(OLDDEA(2.4)),$P(NEWDEA,"^",18)))
. D ADDTXT($$DATALINE("Schedule IV: ",$G(OLDDEA(2.5)),$P(NEWDEA,"^",19)))
. D ADDTXT($$DATALINE("Schedule V: ",$G(OLDDEA(2.6)),$P(NEWDEA,"^",20)))
Q
;
ADDTXT(TXT) ; Setting Plain Text
S MSGLINE=$O(MSGTXT(99999),-1)+1,MSGTXT(MSGLINE)=TXT
Q
;
DATALINE(LABEL,BEFORE,AFTER) ;
N DATALINE
S DATALINE=$$TRUNC(LABEL_BEFORE,40),$E(DATALINE,41)=$$TRUNC(LABEL_AFTER,40)
Q DATALINE
;
TRUNC(TXT,LEN) ; Truncates Text
;Input: TXT - Text to be Truncated
; LEN - Maximum Lenght
;
I $L($G(TXT))'>$G(LEN) Q $G(TXT)
Q $E(TXT,1,LEN-3)_"..."
;
SENDMSG ; Sends Mailman message
S PSOSUB="DEA Numbers Data Update from DEA/DOJ"
S PSOFROM="DEA Update Nightly Job"
S PSOTEXT="MSGTXT"
D MAILMSG(PSOSUB,PSOFROM,PSOTEXT)
Q
;
MAILMSG(MSGSUBJ,MSGFROM,MSGTEXT) ; Build and send a MailMan message
N PSOREC,PSOMY,PSOMIN,PSOMZ
S PSOMIN("FROM")=MSGFROM
S PSOREC=""
F S PSOREC=$O(^XUSEC("PSDRPH",PSOREC)) Q:PSOREC="" S PSOMY(PSOREC)=""
S PSOMY(DUZ)=""
D SENDMSG^XMXAPI(DUZ,MSGSUBJ,MSGTEXT,.PSOMY,.PSOMIN,.PSOMZ,"")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODEAUJ 4731 printed Aug 26, 2025@22:42:44 Page 2
PSODEAUJ ;ALB/MFR - DEA NIGHTLY UPDATE JOB ; 11 Jul 2025 7:08 PM
+1 ;;7.0;OUTPATIENT PHARMACY;**770**;DEC 1997;Build 145
+2 ;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
+3 QUIT
AUTO ; DEA Nightly Update Scheduled Background Job Edit
+1 NEW DIC,Y
SET DIC(0)="XZM"
SET DIC="^DIC(19.2,"
SET X="PSO DEA/DOJ NIGHTLY DATA UPD"
DO ^DIC
+2 IF +Y>0
SET DA=Y
DO EDIT^XUTMOPT("PSO DEA/DOJ NIGHTLY DATA UPD")
QUIT
+3 DO RESCH^XUTMOPT("PSO DEA/DOJ NIGHTLY DATA UPD",$$FMADD^XLFDT(DT,1)+.0001,"","24H","L")
+4 DO EDIT^XUTMOPT("PSO DEA/DOJ NIGHTLY DATA UPD")
+5 QUIT
+6 ;
DEAUPD ; Update DEA #'s that are about to expire in the DEA NUMBERS file (#8991.9)
+1 NEW DEANUM,DEAIEN,DATA,OLDDEA,MSGTXT,COUNT,MSGLINE
+2 ;
+3 ; Will run in Prod accounts only
IF '$$PROD^XUPROD()
QUIT
+4 ;
+5 SET (DEAIEN,MSGLINE,COUNT)=0
+6 FOR
SET DEAIEN=$ORDER(^XTV(8991.9,DEAIEN))
if 'DEAIEN
QUIT
Begin DoDot:1
+7 SET DEAEXP=$$GET1^DIQ(8991.9,DEAIEN,.04,"I")
+8 ; Exp. Date more than 30 days in the future
IF DEAEXP>$$FMADD^XLFDT(DT,30)
QUIT
+9 SET DEANUM=$$GET1^DIQ(8991.9,DEAIEN,.01)
+10 DO GETS^DIQ(8991.9,DEAIEN,"**","","DATA")
+11 MERGE OLDDEA=DATA(8991.9,DEAIEN_",")
+12 DO DEADOJ^PSODEAUT(.NEWDEA,DEANUM)
IF '$GET(NEWDEA(0))
QUIT
+13 SET $PIECE(NEWDEA(1),"^",12)=$$HL7TFM^XLFDT($PIECE(NEWDEA(1),"^",12))
+14 ; New Exp. Date not later than Exp. Date on file
IF $PIECE(NEWDEA(1),"^",12)'>DEAEXP
QUIT
+15 ; Preserving USE FOR INPATIENT ORDERS? (#.06) and SCHEDULE permissions (#2.1-#2.6) fields (except MbM)
+16 IF $$GET1^DIQ(59.7,1,102,"I")'="MBM"
Begin DoDot:2
+17 SET $PIECE(NEWDEA(1),"^",21)=$GET(OLDDEA(.06))
+18 SET $PIECE(NEWDEA(1),"^",15)=$GET(OLDDEA(2.1))
+19 SET $PIECE(NEWDEA(1),"^",16)=$GET(OLDDEA(2.2))
+20 SET $PIECE(NEWDEA(1),"^",17)=$GET(OLDDEA(2.3))
+21 SET $PIECE(NEWDEA(1),"^",18)=$GET(OLDDEA(2.4))
+22 SET $PIECE(NEWDEA(1),"^",19)=$GET(OLDDEA(2.5))
+23 SET $PIECE(NEWDEA(1),"^",20)=$GET(OLDDEA(2.6))
End DoDot:2
+24 DO FILEFM^PSODEAUT(.RET,$GET(NEWDEA(1)))
+25 DO ADD2MSG(DEANUM,.OLDDEA,$GET(NEWDEA(1)))
+26 SET COUNT=COUNT+1
End DoDot:1
IF COUNT>500
QUIT
+27 IF 'COUNT
QUIT
+28 DO ADDTXT("")
DO ADDTXT(COUNT_" DEA #'s have been updated.")
+29 DO SENDMSG
+30 ;
+31 QUIT
+32 ;
ADD2MSG(DEANUM,OLDDEA,NEWDEA) ; Builds the Mailman Message to be sent to PSDRPH key holders
+1 ;Input: DEANUM - DEA Number
+2 ; OLDDEA - DEA data before the Update
+3 ; NEWDEA - DEA data after the Update
+4 IF '$DATA(MSGTXT)
Begin DoDot:1
+5 SET MSGTXT(1)="The list below shows DEA Numbers that have been updated with data from DEA/DOJ"
+6 SET MSGTXT(2)="Database because they were 30 days or less from expiring."
End DoDot:1
+7 ;
+8 DO ADDTXT("")
+9 DO ADDTXT("DEA #: "_DEANUM)
+10 DO ADDTXT("----------------")
+11 SET TXT="BEFORE:"
SET $EXTRACT(TXT,41)="AFTER"
+12 DO ADDTXT($$DATALINE("Exp. Date: ",$GET(OLDDEA(.04)),$$FMTE^XLFDT($PIECE(NEWDEA,"^",12))))
+13 DO ADDTXT($$DATALINE("Name: ",$GET(OLDDEA(1.1)),$PIECE(NEWDEA,"^",1)))
+14 DO ADDTXT($$DATALINE("Company: ",$GET(OLDDEA(1.2)),$PIECE(NEWDEA,"^",2)))
+15 DO ADDTXT($$DATALINE("Address 1: ",$GET(OLDDEA(1.3)),$PIECE(NEWDEA,"^",3)))
+16 DO ADDTXT($$DATALINE("Address 2: ",$GET(OLDDEA(1.4)),$PIECE(NEWDEA,"^",4)))
+17 DO ADDTXT($$DATALINE("City: ",$GET(OLDDEA(1.5)),$PIECE(NEWDEA,"^",5)))
+18 DO ADDTXT($$DATALINE("State: ",$GET(OLDDEA(1.6)),$PIECE(NEWDEA,"^",6)))
+19 DO ADDTXT($$DATALINE("Zip Code: ",$GET(OLDDEA(1.7)),$PIECE(NEWDEA,"^",8)))
+20 DO ADDTXT($$DATALINE("Activity Code: ",$GET(OLDDEA(.02)),$PIECE(NEWDEA,"^",9)))
+21 DO ADDTXT($$DATALINE("Type: ",$GET(OLDDEA(.07)),$PIECE(NEWDEA,"^",10)))
+22 DO ADDTXT($$DATALINE("Detox #: ",$GET(OLDDEA(.03)),$PIECE(NEWDEA,"^",14)))
+23 IF $$GET1^DIQ(59.7,1,102,"I")="MBM"
Begin DoDot:1
+24 DO ADDTXT($$DATALINE("Schedule II-Narcotic: ",$GET(OLDDEA(2.1)),$PIECE(NEWDEA,"^",15)))
+25 DO ADDTXT($$DATALINE("Schedule II-Non Narcotic: ",$GET(OLDDEA(2.2)),$PIECE(NEWDEA,"^",16)))
+26 DO ADDTXT($$DATALINE("Schedule III-Narcotic: ",$GET(OLDDEA(2.3)),$PIECE(NEWDEA,"^",17)))
+27 DO ADDTXT($$DATALINE("Schedule III-Non Narcotic: ",$GET(OLDDEA(2.4)),$PIECE(NEWDEA,"^",18)))
+28 DO ADDTXT($$DATALINE("Schedule IV: ",$GET(OLDDEA(2.5)),$PIECE(NEWDEA,"^",19)))
+29 DO ADDTXT($$DATALINE("Schedule V: ",$GET(OLDDEA(2.6)),$PIECE(NEWDEA,"^",20)))
End DoDot:1
+30 QUIT
+31 ;
ADDTXT(TXT) ; Setting Plain Text
+1 SET MSGLINE=$ORDER(MSGTXT(99999),-1)+1
SET MSGTXT(MSGLINE)=TXT
+2 QUIT
+3 ;
DATALINE(LABEL,BEFORE,AFTER) ;
+1 NEW DATALINE
+2 SET DATALINE=$$TRUNC(LABEL_BEFORE,40)
SET $EXTRACT(DATALINE,41)=$$TRUNC(LABEL_AFTER,40)
+3 QUIT DATALINE
+4 ;
TRUNC(TXT,LEN) ; Truncates Text
+1 ;Input: TXT - Text to be Truncated
+2 ; LEN - Maximum Lenght
+3 ;
+4 IF $LENGTH($GET(TXT))'>$GET(LEN)
QUIT $GET(TXT)
+5 QUIT $EXTRACT(TXT,1,LEN-3)_"..."
+6 ;
SENDMSG ; Sends Mailman message
+1 SET PSOSUB="DEA Numbers Data Update from DEA/DOJ"
+2 SET PSOFROM="DEA Update Nightly Job"
+3 SET PSOTEXT="MSGTXT"
+4 DO MAILMSG(PSOSUB,PSOFROM,PSOTEXT)
+5 QUIT
+6 ;
MAILMSG(MSGSUBJ,MSGFROM,MSGTEXT) ; Build and send a MailMan message
+1 NEW PSOREC,PSOMY,PSOMIN,PSOMZ
+2 SET PSOMIN("FROM")=MSGFROM
+3 SET PSOREC=""
+4 FOR
SET PSOREC=$ORDER(^XUSEC("PSDRPH",PSOREC))
if PSOREC=""
QUIT
SET PSOMY(PSOREC)=""
+5 SET PSOMY(DUZ)=""
+6 DO SENDMSG^XMXAPI(DUZ,MSGSUBJ,MSGTEXT,.PSOMY,.PSOMIN,.PSOMZ,"")
+7 QUIT
