EHMRXLP ;PBM/RMS-Automating the D/C of Migrated VistA Rx's ; 8/5/25 12:35pm
;;1.0;ELECTRONIC HEALTH MODERNIZATION;**8**;April 19, 2021;Build 38
;
;External Reference to ^DIC supported by DBIA #10006
;External Reference to $$EXTERNAL^DILFD supported by DBIA #2055
;External Reference to ^DIR supported by DBIA #10026
;External Reference to $$FMADD^XLFDT supported by DBIA #10103
;External References to ^XLFSTR supported by DBIA #10104
;External Reference to ^XMD supported by DBIA #10070
;External Reference to NODEV^XUTMDEVQ supported by DBIA #1519
;External Reference to ^PSRX supported by DBIA #7632
Q
WELCOME ;Introduce the routine, collect emails for delivery, confirm
;user is ready to proceed.
N EHMSTAT,XMY,%ZIS,ZTSAVE,EHMQUIT
W @IOF
W !!,$$CJ^XLFSTR("Automated D/C of Migrated VistA Prescriptions",IOM)
W !,$$REPEAT^XLFSTR("-",IOM),!!
W !,"This routine will discontinue any prescriptions with status of"
W !,"ACTIVE, SUSPENDED, or HOLD and finishing date in the last year."
W !!,"This job will be queued."
W !!
D EMAILS
Q:$D(EHMQUIT)
N DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y
S DIR(0)="Y"
S DIR("A")="Ready to proceed"
D ^DIR
Q:'+Y
W !!!
S ZTSAVE("*")=""
D NODEV^XUTMDEVQ("LOOP^EHMRXLP","Auto-D/C Migrated Rx's",.ZTSAVE,.%ZIS)
Q
EMAILS ;Collect recipient emails
N DIC,DTOUT,DUOUT,X,Y
S DIC=200
S DIC(0)="AEMQ"
S DIC("A")="Select a MailMan Recipient for the Completion Report: "
S DIC("B")=DUZ
D ^DIC
I $D(DUOUT)!$D(DTOUT) S EHMQUIT=1 Q
I Y S XMY(+Y)=""
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="FO"
S DIR("A")="Select an Outlook Recipient (optional) for the Completion Report"
D ^DIR
I $D(DUOUT)!$D(DTOUT) S EHMQUIT=1 Q
I Y]"" S XMY(Y)=""
Q
LOOP ;Perform the loop, collect statistics
N EHMRXSD,EHMRXOD,EHMRXIN,EHMSTA
S EHMRXSD=$$FMADD^XLFDT(DT,-367)
S EHMRXOD=EHMRXSD
F S EHMRXOD=$O(^PSRX("AFDT",EHMRXOD)) Q:'+EHMRXOD D
. S EHMRXIN=0
. F S EHMRXIN=$O(^PSRX("AFDT",EHMRXOD,EHMRXIN)) Q:'+EHMRXIN D
.. S EHMSTA=$G(^PSRX(EHMRXIN,"STA")) I EHMSTA<10!(EHMSTA=16) D
... S EHMSTAT(EHMSTA)=$G(EHMSTAT(EHMSTA))+1
... D CAN^EHMPSRXDC(EHMRXIN)
D REPORT
Q
REPORT ;Generate the completion email with resulting stats output
N EHMTEXT,XMSUB,XMTEXT
S EHMTEXT(1)="Count of Prescriptions Processed for Auto-D/C by Status"
S EHMTEXT(2)=" "
S EHMSTA=""
F S EHMSTA=$O(EHMSTAT(EHMSTA)) Q:EHMSTA']"" D ;
. S EHMTEXT(EHMSTA+3)="Status: "_$$EXTERNAL^DILFD(52,100,"",EHMSTA)_" Count: "_$G(EHMSTAT(EHMSTA))
S XMSUB="Prescription Auto-D/C Task Completed"
S XMTEXT="EHMTEXT("
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEHMRXLP 2610 printed Jul 11, 2026@01:48:15 Page 2
EHMRXLP ;PBM/RMS-Automating the D/C of Migrated VistA Rx's ; 8/5/25 12:35pm
+1 ;;1.0;ELECTRONIC HEALTH MODERNIZATION;**8**;April 19, 2021;Build 38
+2 ;
+3 ;External Reference to ^DIC supported by DBIA #10006
+4 ;External Reference to $$EXTERNAL^DILFD supported by DBIA #2055
+5 ;External Reference to ^DIR supported by DBIA #10026
+6 ;External Reference to $$FMADD^XLFDT supported by DBIA #10103
+7 ;External References to ^XLFSTR supported by DBIA #10104
+8 ;External Reference to ^XMD supported by DBIA #10070
+9 ;External Reference to NODEV^XUTMDEVQ supported by DBIA #1519
+10 ;External Reference to ^PSRX supported by DBIA #7632
+11 QUIT
WELCOME ;Introduce the routine, collect emails for delivery, confirm
+1 ;user is ready to proceed.
+2 NEW EHMSTAT,XMY,%ZIS,ZTSAVE,EHMQUIT
+3 WRITE @IOF
+4 WRITE !!,$$CJ^XLFSTR("Automated D/C of Migrated VistA Prescriptions",IOM)
+5 WRITE !,$$REPEAT^XLFSTR("-",IOM),!!
+6 WRITE !,"This routine will discontinue any prescriptions with status of"
+7 WRITE !,"ACTIVE, SUSPENDED, or HOLD and finishing date in the last year."
+8 WRITE !!,"This job will be queued."
+9 WRITE !!
+10 DO EMAILS
+11 if $DATA(EHMQUIT)
QUIT
+12 NEW DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y
+13 SET DIR(0)="Y"
+14 SET DIR("A")="Ready to proceed"
+15 DO ^DIR
+16 if '+Y
QUIT
+17 WRITE !!!
+18 SET ZTSAVE("*")=""
+19 DO NODEV^XUTMDEVQ("LOOP^EHMRXLP","Auto-D/C Migrated Rx's",.ZTSAVE,.%ZIS)
+20 QUIT
EMAILS ;Collect recipient emails
+1 NEW DIC,DTOUT,DUOUT,X,Y
+2 SET DIC=200
+3 SET DIC(0)="AEMQ"
+4 SET DIC("A")="Select a MailMan Recipient for the Completion Report: "
+5 SET DIC("B")=DUZ
+6 DO ^DIC
+7 IF $DATA(DUOUT)!$DATA(DTOUT)
SET EHMQUIT=1
QUIT
+8 IF Y
SET XMY(+Y)=""
+9 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+10 SET DIR(0)="FO"
+11 SET DIR("A")="Select an Outlook Recipient (optional) for the Completion Report"
+12 DO ^DIR
+13 IF $DATA(DUOUT)!$DATA(DTOUT)
SET EHMQUIT=1
QUIT
+14 IF Y]""
SET XMY(Y)=""
+15 QUIT
LOOP ;Perform the loop, collect statistics
+1 NEW EHMRXSD,EHMRXOD,EHMRXIN,EHMSTA
+2 SET EHMRXSD=$$FMADD^XLFDT(DT,-367)
+3 SET EHMRXOD=EHMRXSD
+4 FOR
SET EHMRXOD=$ORDER(^PSRX("AFDT",EHMRXOD))
if '+EHMRXOD
QUIT
Begin DoDot:1
+5 SET EHMRXIN=0
+6 FOR
SET EHMRXIN=$ORDER(^PSRX("AFDT",EHMRXOD,EHMRXIN))
if '+EHMRXIN
QUIT
Begin DoDot:2
+7 SET EHMSTA=$GET(^PSRX(EHMRXIN,"STA"))
IF EHMSTA<10!(EHMSTA=16)
Begin DoDot:3
+8 SET EHMSTAT(EHMSTA)=$GET(EHMSTAT(EHMSTA))+1
+9 DO CAN^EHMPSRXDC(EHMRXIN)
End DoDot:3
End DoDot:2
End DoDot:1
+10 DO REPORT
+11 QUIT
REPORT ;Generate the completion email with resulting stats output
+1 NEW EHMTEXT,XMSUB,XMTEXT
+2 SET EHMTEXT(1)="Count of Prescriptions Processed for Auto-D/C by Status"
+3 SET EHMTEXT(2)=" "
+4 SET EHMSTA=""
+5 ;
FOR
SET EHMSTA=$ORDER(EHMSTAT(EHMSTA))
if EHMSTA']""
QUIT
Begin DoDot:1
+6 SET EHMTEXT(EHMSTA+3)="Status: "_$$EXTERNAL^DILFD(52,100,"",EHMSTA)_" Count: "_$GET(EHMSTAT(EHMSTA))
End DoDot:1
+7 SET XMSUB="Prescription Auto-D/C Task Completed"
+8 SET XMTEXT="EHMTEXT("
+9 DO ^XMD
+10 QUIT
