PREAPO3 ;BIR/RTR - Identify AMPL users for patch PREA*1*3; OCT 16, 2020
;;1.0;ADVANCED MEDICATION PLATFORM;**3**;9/1/20;Build 19
; Reference to ^VA(200 in ICR #7209
;
EN ;Identify AMPL Users - called from the PREA AMPL GUI ACCESS option
N PREAPROD,PREARUN,PREAPRG,PREAFNL,PREAWHO,PREAWHO1,PREAWHO2,PREAPIN1,PREAPIN2,PREAPIN3,X,X1,X2,DIR,Y,DTOUT,DUOUT,DIRUT,DIROUT
I $D(^XTMP("PREAUSID","RUNNING")) D Q
.S PREAWHO=+^XTMP("PREAUSID","RUNNING")_","
.D GETS^DIQ(200,PREAWHO,".01","E","PREAWHO2")
.S PREAWHO1=$G(PREAWHO2(200,PREAWHO,.01,"E"))
.W !!,"This job is currently running or tasked from another process by:",!
.W $S($G(PREAWHO1)'="":" "_PREAWHO1,1:" Unknown User."),!
.S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR W !
S PREAPIN1=DUZ_","
D GETS^DIQ(200,PREAPIN1,"205.5","E","PREAPIN2")
S PREAPIN3=$G(PREAPIN2(200,PREAPIN1,205.5,"E"))
I PREAPIN3="" D Q
.W !!,"You must have data in the ADUPN Field (#205.5) of the NEW PERSON File (#200)",!,"to run this option.",!
.S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR W !
D CLEAN
I '$G(DT) S DT=$$DT^XLFDT
S X1=DT,X2=30 D C^%DTC S PREAPRG=$G(X)
S ^XTMP("PREAUSID",0)=PREAPRG_"^"_DT_"^"_"Identify AMPL users for patch PREA*1*3."
S ^XTMP("PREAUSID","RUNNING")=$G(DUZ)
S PREAPROD=+$$PROD^XUPROD,(PREARUN,PREAFNL)=0
D ASK
I 'PREARUN W !,"Nothing run, exiting option.",! D CLEAN Q
D TASK
Q
;
;
RUN ;Run job
I PREAFNL D OUT^XPDMENU("PREA AMPL GUI ACCESS","Out of order, AMPL access already submitted.")
N PREASITE,PREASTRT,PREASTOP
S PREASTRT=$$DATE
S PREASITE=$$SITE^VASITE
D USER,MAIL I PREAFNL D MAILF
D CLEAN
S:$D(ZTQUEUED) ZTREQ="@"
Q
;
;
TASK ;Task Job
N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKILL,ZTSYNC
S ZTRTN="RUN^PREAPO3"
S ZTDESC="Identify AMPL Users for access."
S ZTSAVE("PREAPROD")="",ZTSAVE("PREAFNL")="",ZTSAVE("PREAPIN3")=""
S ZTIO=""
D ^%ZTLOAD
I $D(ZTSK)[0 W !!,"Job not tasked to run.",! D CLEAN
E W !!,"Job tasked to run.",!
D HOME^%ZIS
Q
;
;
CLEAN ;Kill TMP Globals
K ^TMP($J,"PREACHK"),^TMP($J,"PREAUSER"),^TMP($J,"PREANONM"),^TMP($J,"PREANET"),^XTMP("PREAUSID")
Q
;
;
ASK ;User prompts
N DIR,X,Y,DTOUT,DUOUT,DIRUT
W !!,"This option generates the initial list of users that will be submitted for"
w !,"Advanced Medication Platform (AMPL) access, based on Security Keys and"
W !,"Person Class. Individual access can subsequently be granted or taken away by"
W !,"following the procedures outlined in Appendix A of the PREA Technical Manual.",!
;
I 'PREAPROD D TEST Q
;
W !,"Since this is a production account, you can elect to:"
W !," 1. Only send this list to your Outlook and VistA emails, the"
W !," list will not be submitted to grant AMPL access."
W !," 2. At the request of the Implementation Manager, send the list to"
W !," yourself and the people who will submit AMPL access requests for"
W !," all users on the list. If you elect to send the list to the team"
W !," who submits AMPL access requests, the option will then be disabled."
W !!," ********************NOTE********************"
W !," Option 2 should only be done when requested by the Implementation"
W !," Manager, AMPL will be a phased rollout.",!
K DIR,Y S DIR(0)="Y",DIR("B")="Y",DIR("A")="Only send list to my Outlook and Vista emails"
S DIR("?")=" ",DIR("?",1)="Enter 'Y' to only send the AMPL access user request list to yourself in"
S DIR("?",2)="Outlook and VistA emails. Enter 'N' to submit the list for access granting."
s DIR("?",3)="Enter '^' to exit." D ^DIR K DIR W !
I $D(DTOUT)!($D(DUOUT)) Q
I 'Y D I $D(DTOUT)!($D(DUOUT)) Q
.K DIR,Y S DIR(0)="Y",DIR("B")="N",DIR("A")="Are you sure you want to submit the final AMPL User request list"
.S DIR("?")=" ",DIR("?",1)="Enter 'Y' to officially submit the AMPL access user request list."
.S DIR("?",2)="Doing so will disable this option, since the list can be sent only once."
.S DIR("?",3)="Enter '^' to exit." D ^DIR K DIR W !
.I Y S PREAFNL=1
S PREARUN=1
Q
;
;
TEST ;Test account
W !,"Since this is a test account, the list will only be sent to you at your Outlook"
W !,"and VistA emails and will not be submitted to grant AMPL access. Submitting"
W !,"for AMPL access can only happen when running this option in production.",!
K DIR,Y S DIR(0)="Y",DIR("B")="Y",DIR("A")="Generate AMPL access user list"
S DIR("?")=" ",DIR("?",1)="Enter 'Y' to generate the AMPL access user request list. This"
S DIR("?",2)="list will only be sent to you at your Outlook and VistA emails." D ^DIR K DIR W !
I Y'=1!($D(DTOUT))!($D(DUOUT)) Q
S PREARUN=1
Q
;
;
MAIL ;Send mail message
N XMTEXT,XMY,XMSUB,XMDUZ,XMMG,XMSTRIP,XMROU,XMYBLOB,XMZ
K ^TMP($J,"PREATEXT")
S XMDUZ="PREA*1*3 AMPL User Identification"
S XMSUB="AMPL access list-PREA*1*3 "_$P(PREASITE,"^",2)_" "_$P(PREASITE,"^",3)
D SETTMP
S XMTEXT="^TMP($J,""PREATEXT"","
S XMY(DUZ)=""
S XMY(PREAPIN3)=""
N DIFROM,DUZ D ^XMD
K ^TMP($J,"PREATEXT")
Q
;
;
SETTMP ;Set TMP global data
N PREALP1,PREALP2,PREALP3,PREALP4,PREALP5
S PREALP1="",PREALP3=3
F S PREALP1=$O(^TMP($J,"PREAUSER",PREALP1)) Q:PREALP1="" D
.F PREALP2=0:0 S PREALP2=$O(^TMP($J,"PREAUSER",PREALP1,PREALP2)) Q:'PREALP2 D
..S ^TMP($J,"PREATEXT",PREALP3)=PREALP1,PREALP3=PREALP3+1
S PREALP4=PREALP3-3
S ^TMP($J,"PREATEXT",2)="Name ("_$S($G(PREAPROD):"PRODUCTION ACCOUNT",1:"TEST ACCOUNT")_") Total: "_PREALP4
S ^TMP($J,"PREATEXT",PREALP3)="",PREALP3=PREALP3+1
S PREALP4=PREALP3,PREALP1="",PREALP3=PREALP3+1,PREALP5=0
F S PREALP1=$O(^TMP($J,"PREANONM",PREALP1)) Q:PREALP1="" D
.F PREALP2=0:0 S PREALP2=$O(^TMP($J,"PREANONM",PREALP1,PREALP2)) Q:'PREALP2 D
..S ^TMP($J,"PREATEXT",PREALP3)=PREALP1,PREALP3=PREALP3+1,PREALP5=PREALP5+1
S ^TMP($J,"PREATEXT",PREALP4)="Users Missing Network UserName Total: "_PREALP5
I 'PREALP5 D
.S PREALP3=PREALP3+1,^TMP($J,"PREATEXT",PREALP3)=""
.S PREALP3=PREALP3+1,^TMP($J,"PREATEXT",PREALP3)="No entries found."
S PREASTOP=$$DATE
S ^TMP($J,"PREATEXT",1)="AMPL User ID job began: "_PREASTRT_" ended: "_PREASTOP
Q
;
;
USER ;Find users to get AMPL access
;^TMP($J,"PREACHK",DUZ)="" - User already identified as an AMPL user with/without vausername or uneligible
;^TMP($J,"PREAUSER",NAME,DUZ)=vausername - User identified as an AMPL User with vausername
;^TMP($J,"PREANONM",NAME,DUZ)="" - User identified as an AMPL User without vausername
N PREAKEY,PREAVAUS,PREANAME,PREADATA,PREAVALU,PREADUZ
F PREAKEY="PSORPH","PSO TECH ADV","PSD TECH","PSD TECH ADV","PSDRPH","PSDMGR","PSJ PHARM TECH","PSJ RPHARM","PSJI MGR","PSJI PHARM TECH","PSJU MGR","PSJU RPH" D
.F PREADUZ=0:0 S PREADUZ=$O(^XUSEC(PREAKEY,PREADUZ)) Q:'PREADUZ D
..I $D(^TMP($J,"PREACHK",PREADUZ)) Q
..S ^TMP($J,"PREACHK",PREADUZ)=""
..I $$ACTIVE(PREADUZ) D ADD(PREADUZ)
;Must loop through File 200 since there are no cross-references that gives all person of a Person Class:
F PREADUZ=0:0 S PREADUZ=$O(^VA(200,PREADUZ)) Q:'PREADUZ D
.I $D(^TMP($J,"PREACHK",PREADUZ)) Q
.I $$ACTIVE(PREADUZ),$$PER(PREADUZ) D ADD(PREADUZ)
Q
;
;
ADD(PREAUSE1) ;User gets access, add to TMP global
S PREAVALU=PREAUSE1_","
D GETS^DIQ(200,PREAVALU,".01;501.1","E","PREADATA")
S PREANAME=$G(PREADATA(200,PREAVALU,.01,"E")) I PREANAME="" Q
S PREAVAUS=$G(PREADATA(200,PREAVALU,501.1,"E"))
I PREAVAUS'="" S ^TMP($J,"PREAUSER",PREANAME,PREAUSE1)="" D:PREAFNL Q
.S ^TMP($J,"PREANET",PREAVAUS)=""
S ^TMP($J,"PREANONM",PREANAME,PREAUSE1)=""
Q
;
;
ACTIVE(PREAINAC) ;Check if user is inactive
Q $$ACTIVE^XUSER(PREAINAC)
;
;
PER(PREAUSE2) ;Person Class check
N PREAPCLS
S PREAPCLS=$$GET^XUA4A72(PREAUSE2) I PREAPCLS'>0 Q 0
I $$UP^XLFSTR($P(PREAPCLS,"^",2,3))'["PHARM" Q 0
Q 1
;
;
MAILF ;Send final mail message
N XMTEXT,XMY,XMSUB,XMDUZ,XMMG,XMSTRIP,XMROU,XMYBLOB,XMZ,PREANT,PREANTC
K ^TMP($J,"PREATEXT") S PREANTC=1
S XMDUZ="PREA*1*3 AMPL User Identification"
S XMSUB="AMPL access list-PREA*1*3 "_$P(PREASITE,"^",2)_" "_$P(PREASITE,"^",3)
S PREANT="" F S PREANT=$O(^TMP($J,"PREANET",PREANT)) Q:PREANT="" D
.S ^TMP($J,"PREATEXT",PREANTC)=PREANT,PREANTC=PREANTC+1
I PREANTC=1 S ^TMP($J,"PREATEXT",1)="No users found."
S XMTEXT="^TMP($J,""PREATEXT"","
S XMY("VAITEPMOEPMDPREPHARMGUISSOI@domain.ext")=""
S XMY(PREAPIN3)=""
N DIFROM,DUZ D ^XMD
K ^TMP($J,"PREATEXT")
Q
;
;
DATE() ;Returns Date/Time
N X,Y,%,%H,%I,PREADATE
D NOW^%DTC
D YX^%DTC S PREADATE=Y
Q PREADATE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPREAPO3 8578 printed Dec 13, 2024@01:38:38 Page 2
PREAPO3 ;BIR/RTR - Identify AMPL users for patch PREA*1*3; OCT 16, 2020
+1 ;;1.0;ADVANCED MEDICATION PLATFORM;**3**;9/1/20;Build 19
+2 ; Reference to ^VA(200 in ICR #7209
+3 ;
EN ;Identify AMPL Users - called from the PREA AMPL GUI ACCESS option
+1 NEW PREAPROD,PREARUN,PREAPRG,PREAFNL,PREAWHO,PREAWHO1,PREAWHO2,PREAPIN1,PREAPIN2,PREAPIN3,X,X1,X2,DIR,Y,DTOUT,DUOUT,DIRUT,DIROUT
+2 IF $DATA(^XTMP("PREAUSID","RUNNING"))
Begin DoDot:1
+3 SET PREAWHO=+^XTMP("PREAUSID","RUNNING")_","
+4 DO GETS^DIQ(200,PREAWHO,".01","E","PREAWHO2")
+5 SET PREAWHO1=$GET(PREAWHO2(200,PREAWHO,.01,"E"))
+6 WRITE !!,"This job is currently running or tasked from another process by:",!
+7 WRITE $SELECT($GET(PREAWHO1)'="":" "_PREAWHO1,1:" Unknown User."),!
+8 SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
WRITE !
End DoDot:1
QUIT
+9 SET PREAPIN1=DUZ_","
+10 DO GETS^DIQ(200,PREAPIN1,"205.5","E","PREAPIN2")
+11 SET PREAPIN3=$GET(PREAPIN2(200,PREAPIN1,205.5,"E"))
+12 IF PREAPIN3=""
Begin DoDot:1
+13 WRITE !!,"You must have data in the ADUPN Field (#205.5) of the NEW PERSON File (#200)",!,"to run this option.",!
+14 SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
WRITE !
End DoDot:1
QUIT
+15 DO CLEAN
+16 IF '$GET(DT)
SET DT=$$DT^XLFDT
+17 SET X1=DT
SET X2=30
DO C^%DTC
SET PREAPRG=$GET(X)
+18 SET ^XTMP("PREAUSID",0)=PREAPRG_"^"_DT_"^"_"Identify AMPL users for patch PREA*1*3."
+19 SET ^XTMP("PREAUSID","RUNNING")=$GET(DUZ)
+20 SET PREAPROD=+$$PROD^XUPROD
SET (PREARUN,PREAFNL)=0
+21 DO ASK
+22 IF 'PREARUN
WRITE !,"Nothing run, exiting option.",!
DO CLEAN
QUIT
+23 DO TASK
+24 QUIT
+25 ;
+26 ;
RUN ;Run job
+1 IF PREAFNL
DO OUT^XPDMENU("PREA AMPL GUI ACCESS","Out of order, AMPL access already submitted.")
+2 NEW PREASITE,PREASTRT,PREASTOP
+3 SET PREASTRT=$$DATE
+4 SET PREASITE=$$SITE^VASITE
+5 DO USER
DO MAIL
IF PREAFNL
DO MAILF
+6 DO CLEAN
+7 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+8 QUIT
+9 ;
+10 ;
TASK ;Task Job
+1 NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKILL,ZTSYNC
+2 SET ZTRTN="RUN^PREAPO3"
+3 SET ZTDESC="Identify AMPL Users for access."
+4 SET ZTSAVE("PREAPROD")=""
SET ZTSAVE("PREAFNL")=""
SET ZTSAVE("PREAPIN3")=""
+5 SET ZTIO=""
+6 DO ^%ZTLOAD
+7 IF $DATA(ZTSK)[0
WRITE !!,"Job not tasked to run.",!
DO CLEAN
+8 IF '$TEST
WRITE !!,"Job tasked to run.",!
+9 DO HOME^%ZIS
+10 QUIT
+11 ;
+12 ;
CLEAN ;Kill TMP Globals
+1 KILL ^TMP($JOB,"PREACHK"),^TMP($JOB,"PREAUSER"),^TMP($JOB,"PREANONM"),^TMP($JOB,"PREANET"),^XTMP("PREAUSID")
+2 QUIT
+3 ;
+4 ;
ASK ;User prompts
+1 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT
+2 WRITE !!,"This option generates the initial list of users that will be submitted for"
+3 WRITE !,"Advanced Medication Platform (AMPL) access, based on Security Keys and"
+4 WRITE !,"Person Class. Individual access can subsequently be granted or taken away by"
+5 WRITE !,"following the procedures outlined in Appendix A of the PREA Technical Manual.",!
+6 ;
+7 IF 'PREAPROD
DO TEST
QUIT
+8 ;
+9 WRITE !,"Since this is a production account, you can elect to:"
+10 WRITE !," 1. Only send this list to your Outlook and VistA emails, the"
+11 WRITE !," list will not be submitted to grant AMPL access."
+12 WRITE !," 2. At the request of the Implementation Manager, send the list to"
+13 WRITE !," yourself and the people who will submit AMPL access requests for"
+14 WRITE !," all users on the list. If you elect to send the list to the team"
+15 WRITE !," who submits AMPL access requests, the option will then be disabled."
+16 WRITE !!," ********************NOTE********************"
+17 WRITE !," Option 2 should only be done when requested by the Implementation"
+18 WRITE !," Manager, AMPL will be a phased rollout.",!
+19 KILL DIR,Y
SET DIR(0)="Y"
SET DIR("B")="Y"
SET DIR("A")="Only send list to my Outlook and Vista emails"
+20 SET DIR("?")=" "
SET DIR("?",1)="Enter 'Y' to only send the AMPL access user request list to yourself in"
+21 SET DIR("?",2)="Outlook and VistA emails. Enter 'N' to submit the list for access granting."
+22 SET DIR("?",3)="Enter '^' to exit."
DO ^DIR
KILL DIR
WRITE !
+23 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+24 IF 'Y
Begin DoDot:1
+25 KILL DIR,Y
SET DIR(0)="Y"
SET DIR("B")="N"
SET DIR("A")="Are you sure you want to submit the final AMPL User request list"
+26 SET DIR("?")=" "
SET DIR("?",1)="Enter 'Y' to officially submit the AMPL access user request list."
+27 SET DIR("?",2)="Doing so will disable this option, since the list can be sent only once."
+28 SET DIR("?",3)="Enter '^' to exit."
DO ^DIR
KILL DIR
WRITE !
+29 IF Y
SET PREAFNL=1
End DoDot:1
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+30 SET PREARUN=1
+31 QUIT
+32 ;
+33 ;
TEST ;Test account
+1 WRITE !,"Since this is a test account, the list will only be sent to you at your Outlook"
+2 WRITE !,"and VistA emails and will not be submitted to grant AMPL access. Submitting"
+3 WRITE !,"for AMPL access can only happen when running this option in production.",!
+4 KILL DIR,Y
SET DIR(0)="Y"
SET DIR("B")="Y"
SET DIR("A")="Generate AMPL access user list"
+5 SET DIR("?")=" "
SET DIR("?",1)="Enter 'Y' to generate the AMPL access user request list. This"
+6 SET DIR("?",2)="list will only be sent to you at your Outlook and VistA emails."
DO ^DIR
KILL DIR
WRITE !
+7 IF Y'=1!($DATA(DTOUT))!($DATA(DUOUT))
QUIT
+8 SET PREARUN=1
+9 QUIT
+10 ;
+11 ;
MAIL ;Send mail message
+1 NEW XMTEXT,XMY,XMSUB,XMDUZ,XMMG,XMSTRIP,XMROU,XMYBLOB,XMZ
+2 KILL ^TMP($JOB,"PREATEXT")
+3 SET XMDUZ="PREA*1*3 AMPL User Identification"
+4 SET XMSUB="AMPL access list-PREA*1*3 "_$PIECE(PREASITE,"^",2)_" "_$PIECE(PREASITE,"^",3)
+5 DO SETTMP
+6 SET XMTEXT="^TMP($J,""PREATEXT"","
+7 SET XMY(DUZ)=""
+8 SET XMY(PREAPIN3)=""
+9 NEW DIFROM,DUZ
DO ^XMD
+10 KILL ^TMP($JOB,"PREATEXT")
+11 QUIT
+12 ;
+13 ;
SETTMP ;Set TMP global data
+1 NEW PREALP1,PREALP2,PREALP3,PREALP4,PREALP5
+2 SET PREALP1=""
SET PREALP3=3
+3 FOR
SET PREALP1=$ORDER(^TMP($JOB,"PREAUSER",PREALP1))
if PREALP1=""
QUIT
Begin DoDot:1
+4 FOR PREALP2=0:0
SET PREALP2=$ORDER(^TMP($JOB,"PREAUSER",PREALP1,PREALP2))
if 'PREALP2
QUIT
Begin DoDot:2
+5 SET ^TMP($JOB,"PREATEXT",PREALP3)=PREALP1
SET PREALP3=PREALP3+1
End DoDot:2
End DoDot:1
+6 SET PREALP4=PREALP3-3
+7 SET ^TMP($JOB,"PREATEXT",2)="Name ("_$SELECT($GET(PREAPROD):"PRODUCTION ACCOUNT",1:"TEST ACCOUNT")_") Total: "_PREALP4
+8 SET ^TMP($JOB,"PREATEXT",PREALP3)=""
SET PREALP3=PREALP3+1
+9 SET PREALP4=PREALP3
SET PREALP1=""
SET PREALP3=PREALP3+1
SET PREALP5=0
+10 FOR
SET PREALP1=$ORDER(^TMP($JOB,"PREANONM",PREALP1))
if PREALP1=""
QUIT
Begin DoDot:1
+11 FOR PREALP2=0:0
SET PREALP2=$ORDER(^TMP($JOB,"PREANONM",PREALP1,PREALP2))
if 'PREALP2
QUIT
Begin DoDot:2
+12 SET ^TMP($JOB,"PREATEXT",PREALP3)=PREALP1
SET PREALP3=PREALP3+1
SET PREALP5=PREALP5+1
End DoDot:2
End DoDot:1
+13 SET ^TMP($JOB,"PREATEXT",PREALP4)="Users Missing Network UserName Total: "_PREALP5
+14 IF 'PREALP5
Begin DoDot:1
+15 SET PREALP3=PREALP3+1
SET ^TMP($JOB,"PREATEXT",PREALP3)=""
+16 SET PREALP3=PREALP3+1
SET ^TMP($JOB,"PREATEXT",PREALP3)="No entries found."
End DoDot:1
+17 SET PREASTOP=$$DATE
+18 SET ^TMP($JOB,"PREATEXT",1)="AMPL User ID job began: "_PREASTRT_" ended: "_PREASTOP
+19 QUIT
+20 ;
+21 ;
USER ;Find users to get AMPL access
+1 ;^TMP($J,"PREACHK",DUZ)="" - User already identified as an AMPL user with/without vausername or uneligible
+2 ;^TMP($J,"PREAUSER",NAME,DUZ)=vausername - User identified as an AMPL User with vausername
+3 ;^TMP($J,"PREANONM",NAME,DUZ)="" - User identified as an AMPL User without vausername
+4 NEW PREAKEY,PREAVAUS,PREANAME,PREADATA,PREAVALU,PREADUZ
+5 FOR PREAKEY="PSORPH","PSO TECH ADV","PSD TECH","PSD TECH ADV","PSDRPH","PSDMGR","PSJ PHARM TECH","PSJ RPHARM","PSJI MGR","PSJI PHARM TECH","PSJU MGR","PSJU RPH"
Begin DoDot:1
+6 FOR PREADUZ=0:0
SET PREADUZ=$ORDER(^XUSEC(PREAKEY,PREADUZ))
if 'PREADUZ
QUIT
Begin DoDot:2
+7 IF $DATA(^TMP($JOB,"PREACHK",PREADUZ))
QUIT
+8 SET ^TMP($JOB,"PREACHK",PREADUZ)=""
+9 IF $$ACTIVE(PREADUZ)
DO ADD(PREADUZ)
End DoDot:2
End DoDot:1
+10 ;Must loop through File 200 since there are no cross-references that gives all person of a Person Class:
+11 FOR PREADUZ=0:0
SET PREADUZ=$ORDER(^VA(200,PREADUZ))
if 'PREADUZ
QUIT
Begin DoDot:1
+12 IF $DATA(^TMP($JOB,"PREACHK",PREADUZ))
QUIT
+13 IF $$ACTIVE(PREADUZ)
IF $$PER(PREADUZ)
DO ADD(PREADUZ)
End DoDot:1
+14 QUIT
+15 ;
+16 ;
ADD(PREAUSE1) ;User gets access, add to TMP global
+1 SET PREAVALU=PREAUSE1_","
+2 DO GETS^DIQ(200,PREAVALU,".01;501.1","E","PREADATA")
+3 SET PREANAME=$GET(PREADATA(200,PREAVALU,.01,"E"))
IF PREANAME=""
QUIT
+4 SET PREAVAUS=$GET(PREADATA(200,PREAVALU,501.1,"E"))
+5 IF PREAVAUS'=""
SET ^TMP($JOB,"PREAUSER",PREANAME,PREAUSE1)=""
if PREAFNL
Begin DoDot:1
+6 SET ^TMP($JOB,"PREANET",PREAVAUS)=""
End DoDot:1
QUIT
+7 SET ^TMP($JOB,"PREANONM",PREANAME,PREAUSE1)=""
+8 QUIT
+9 ;
+10 ;
ACTIVE(PREAINAC) ;Check if user is inactive
+1 QUIT $$ACTIVE^XUSER(PREAINAC)
+2 ;
+3 ;
PER(PREAUSE2) ;Person Class check
+1 NEW PREAPCLS
+2 SET PREAPCLS=$$GET^XUA4A72(PREAUSE2)
IF PREAPCLS'>0
QUIT 0
+3 IF $$UP^XLFSTR($PIECE(PREAPCLS,"^",2,3))'["PHARM"
QUIT 0
+4 QUIT 1
+5 ;
+6 ;
MAILF ;Send final mail message
+1 NEW XMTEXT,XMY,XMSUB,XMDUZ,XMMG,XMSTRIP,XMROU,XMYBLOB,XMZ,PREANT,PREANTC
+2 KILL ^TMP($JOB,"PREATEXT")
SET PREANTC=1
+3 SET XMDUZ="PREA*1*3 AMPL User Identification"
+4 SET XMSUB="AMPL access list-PREA*1*3 "_$PIECE(PREASITE,"^",2)_" "_$PIECE(PREASITE,"^",3)
+5 SET PREANT=""
FOR
SET PREANT=$ORDER(^TMP($JOB,"PREANET",PREANT))
if PREANT=""
QUIT
Begin DoDot:1
+6 SET ^TMP($JOB,"PREATEXT",PREANTC)=PREANT
SET PREANTC=PREANTC+1
End DoDot:1
+7 IF PREANTC=1
SET ^TMP($JOB,"PREATEXT",1)="No users found."
+8 SET XMTEXT="^TMP($J,""PREATEXT"","
+9 SET XMY("VAITEPMOEPMDPREPHARMGUISSOI@domain.ext")=""
+10 SET XMY(PREAPIN3)=""
+11 NEW DIFROM,DUZ
DO ^XMD
+12 KILL ^TMP($JOB,"PREATEXT")
+13 QUIT
+14 ;
+15 ;
DATE() ;Returns Date/Time
+1 NEW X,Y,%,%H,%I,PREADATE
+2 DO NOW^%DTC
+3 DO YX^%DTC
SET PREADATE=Y
+4 QUIT PREADATE
