PSUCP ;BIR/TJH,PDW - PBM CONTROL POINT ; 06/08/07
;;4.0;PHARMACY BENEFITS MANAGEMENT;**12**;MARCH, 2005;Build 19
; Reference to File #4 supported by DBIA 10090
; Reference to File #4.3 supported by DBIA 10091
; Reference to File #40.8 supported by DBIA 2438
; Reference to File #59.7 supported by DBIA 2854
; move CLEANUP^PSUHL from PSURT1, delete calls to PSUCP3 (PSU*4*12)
MANUAL ; entry point for manual option
S PSUALERT=0 D MANUAL^PSUALERT
I PSUALERT K PSUALERT Q
K PSUALERT
S PSUFQ=1
I $D(^XTMP("PSUJFLG")) D Q:Y=0 Q:Y="^"
.W !!,"NOTE: A PREVIOUS JOB HAS NOT COMPLETED DUE TO AN ERROR"
.W !!,"PLEASE ALERT YOUR IRM."
.W !!,"RESPOND 'YES' TO CONTINUE, OR 'NO' TO EXIT"
.S DIR(0)="Y",DIR("B")="NO"
.S DIR("A")="Do you wish to continue"
.D ^DIR
D CLEANUP^PSUHL
S PSUJOB=$J_"_"_$P($H,",",2)
S ^XTMP("PSUMANL")=""
D EN^PSUCP1 ; prompt for report choices
I PSUERR G EXIT
D XMY^PSUTL1 ; Setup for mail groups according to choices
S ^XTMP("PSUJFLG")="",PSUAUTO=0,^XTMP("PSU_"_PSUJOB,"PSUJOB")=PSUJOB
D PUT
S PSUTITLE="PSU PBM MANUAL",PSURC="RUN^PSUCP"
S PSURP=$S('$L(PSUIOP):"",1:"PRINT^PSUCP")
S PSURX="EXIT^PSUCP",PSUNS="PS"
S ^XTMP("PSU","RUNNING")=$G(ZTSK)
K PSUALERT,XAQ,SQAFLG,SQAID,XQAMSG,XQMSG,ZTSK
D ^PSUDBQUE
MANUALQ Q
;
AUTO ; set variables for Auto-report option and task to background
S PSUALERT=0 D AUTO^PSUALERT
I PSUALERT K PSUALERT Q
I $D(^XTMP("PSU","RUNNING")) D Q
.S XQA(DUZ)="",XQA("G.PSU PBM")="",XQMSG="An ERROR has occurred. Please contact IRM for assistance."
.S XQAID="PSU",XQAFLG="D" D SETUP^XQALERT
D CLEANUP^PSUHL
S PSUJOB=$J_"_"_$P($H,",",2)
S ^XTMP("PSU_"_PSUJOB,"PSUFLAG1")="" ;flag for mail patient summary reports
S ^XTMP("PSU_"_PSUJOB,"PSUPSUMFLAG")=1 ;Set 'auto' flag
S ^XTMP("PSUJFLG")="" ;FLAG to avoid concurrent jobs running
D ; schedule job completion check
.S PSURC="AUTO^PSUCP2",PSUTITLE="PSU PBM JOB CHECK",PSUFQ=1
.S (PSURP,PSURX,PSUIOP)=""
.D NOW^%DTC S X1=%,X2=6 D C^%DTC S PSUDTH=X ; LIVE MODE, wait 6 days (72 hours)
.D ^PSUDBQUE
.S ^XTMP("PSU","RUNNING")=$G(ZTSK)
D NOW^%DTC S PSUMON=$S('$D(DT):X,1:DT),PSUMON=$E(PSUMON,1,5)-1 ; get previous month
I $E(PSUMON,4,5)="00" S PSUMON=($E(PSUMON,1,3)-1)_"12" ; set to Dec. of previous year if this month is Jan.
S ^XTMP("PSU_"_PSUJOB,"PSUMONTH")=PSUMON,PSUSDT=PSUMON_"01"
S PSULY=$$LEAPYR(PSUMON),X=U_$E(PSUMON,4,5)_U
S PSUEDT=PSUMON_$S(X["02":$S(PSULY:"29",1:"28"),"^04^06^09^11^"[X:"30",1:"31")
S PSUDUZ=$S(DUZ=0:.5,1:DUZ),PSUMASF=1,PSUSMRY=0,PSUPBMG=1
S ^XTMP("PSU_"_PSUJOB,"PSUPDFLAG")=1 ;Flag-detailed PD won't go to user auto extract
S X=$$VALI^PSUTL(4.3,1,217),PSUSNDR=+$$VAL^PSUTL(4,X,99)
S PSUOPTS="1,2,3,4,5,6,7,8,9,10,11,12,13",PSUAUTO=1,PSUIOP="" D
.S ^XTMP("PSU_"_PSUJOB,"CBAMIS")=""
S ^XTMP("PSU_"_PSUJOB,"PSUJOB")=PSUJOB
D PUT
S PSUTITLE="PSU PBM AUTO",PSURC="RUN^PSUCP",PSURX="EXIT^PSUCP",PSURP="",PSUNS="PS",PSUFQ=1
D NOW^%DTC S PSUDTH=%
D ^PSUDBQUE
K PSUALERT,XQA,XQAID,XQAFLG,XQA,ZTSK
AUTOQ Q ; exit from AUTO
;
RUN ; run each selected module
L ^XTMP("PSU","RUNNING"):1 I '$T Q
D PULL,OPTS
K PSUMOD,PSUFDA
I PSUAUTO S PSUFDA(59.7,"1,",90)="@" D FILE^DIE("","PSUFDA","")
F I=1:1:$L(PSUOPTS,",") S PSUMOD($P(PSUOPTS,",",I))=""
S PSUOPTN=""
F S PSUOPTN=$O(PSUMOD(PSUOPTN)) Q:PSUOPTN="" D
.K PSUMSGT
.D PULL
.I PSUAUTO S PSUPBMG=1
.D XMY^PSUTL1
.S PSURTN=PSUA(PSUOPTN,"R")
.D NOW^%DTC
.S ^XTMP("PSU_"_PSUJOB,"STATUS",PSUOPTN,"START")=%
.D @PSURTN,PULL,NOW^%DTC
.S ^XTMP("PSU_"_PSUJOB,"STATUS",PSUOPTN,"STOP")=%
D DT^DILF("E",PSUSDT,.EXTD)
S PSURP("START")=EXTD(0)
D DT^DILF("E",PSUEDT,.EXTD)
S PSURP("END")=EXTD(0),PSUSUB="PSU_"_PSUJOB
D MMNOMAP^PSUCP2 ; MM send regarding PBM locations not mapped
D TIMING ; send a report of how long each module took to complete
I PSUMASF!PSUPBMG D CONFIRM ;Confirmation message sent only if data went to Master File
I PSUAUTO D
.D NOW^%DTC
.S PSUFDA(59.7,"1,",90)=% K %,%H,%I,X
.D FILE^DIE("","PSUFDA","") ; file the completion date in 59.7,90;1
L
;
Q
PRINT ; print hard copy if requested
Q:'$L(PSUIOP) ; no printer selected, stop right here.
D PULL,OPTS
K PSUMOD
F I=1:1:$L(PSUOPTS,",") S PSUMOD($P(PSUOPTS,",",I))=""
S PSUOPTN=""
F S PSUOPTN=$O(PSUMOD(PSUOPTN)) Q:PSUOPTN="" D
.D PULL
.S PSURTN=PSUA(PSUOPTN,"P")
.D @PSURTN
L
K ^XTMP("PSU","RUNNING")
PRINTQ Q
EXIT ; exit point
K ^XTMP("PSU","RUNNING")
K ^XTMP("PSUJFLG") ;Remove flag to prevent concurrent jobs
Q
PUT ; put variables in ^XTMP so modules can retrieve them
S PSUVARS="PSUSDT,PSUEDT,PSUMON,PSUDUZ,PSUMASF,PSUPBMG,PSUSMRY,PSUIOP,PSUSNDR,PSUOPTS,PSUAUTO"
S PSUVSTR=""
F I=1:1:$L(PSUVARS,",") S $P(PSUVSTR,U,I)=@$P(PSUVARS,",",I)
S X1=DT,X2=6 D C^%DTC
S ^XTMP("PSU_"_PSUJOB,0)=X_U_DT_U_"Control data for PSU PBM individual modules"
S ^XTMP("PSU_"_PSUJOB,1)=PSUVSTR
K PSUVARS,PSUVSTR,X,X1
PUTQ Q
PULL ; pull variables from ^XTMP
; PSUJOB must exist and must be the job number used to store the data desired for this session.
N I
S PSUVARS="PSUSDT,PSUEDT,PSUMON,PSUDUZ,PSUMASF,PSUPBMG,PSUSMRY,PSUIOP,PSUSNDR,PSUOPTS,PSUAUTO"
F I=1:1:$L(PSUVARS,",") S @$P(PSUVARS,",",I)=$P($G(^XTMP("PSU_"_PSUJOB,1)),U,I)
PULLQ Q
;
OPTS ; set option array
S PSUA(1,"M")="IVs",PSUA(1,"R")="EN^PSUV0",PSUA(1,"P")="PRINT^PSUV0",PSUA(1,"C")="IV"
S PSUA(2,"M")="Unit Dose",PSUA(2,"R")="EN^PSUUD0",PSUA(2,"P")="PRINT^PSUUD0",PSUA(2,"C")="UD"
S PSUA(3,"M")="AR/WS",PSUA(3,"R")="EN^PSUAR0",PSUA(3,"P")="PRINT^PSUAR0",PSUA(3,"C")="AR"
S PSUA(4,"M")="Prescription",PSUA(4,"R")="EN^PSUOP0",PSUA(4,"P")="PRINT^PSUOP0",PSUA(4,"C")="OP"
S PSUA(5,"M")="Procurement",PSUA(5,"R")="EN^PSUPR0",PSUA(5,"P")="PRINT^PSUPR0",PSUA(5,"C")="PR"
S PSUA(6,"M")="Controlled Substances",PSUA(6,"R")="EN^PSUCS0",PSUA(6,"P")="PRINT^PSUCS0",PSUA(6,"C")="CS"
S PSUA(7,"M")="Patient Demographics",PSUA(7,"R")="EN^PSUDEM1",PSUA(7,"P")="PRINT^PSUDEM0",PSUA(7,"C")="PD"
S PSUA(8,"M")="Outpatient Visits",PSUA(8,"R")="EN^PSUDEM2",PSUA(8,"P")="OPV^PSUDEM0",PSUA(8,"C")="OV"
S PSUA(9,"M")="Inpatient PTF Records",PSUA(9,"R")="EN^PSUDEM7",PSUA(9,"P")="PTF^PSUDEM0",PSUA(9,"C")="PTF"
S PSUA(10,"M")="Provider Data",PSUA(10,"R")="EN^PSUDEM4",PSUA(10,"P")="PRO^PSUDEM0",PSUA(10,"C")="PRO"
S PSUA(11,"M")="Allergies/Adverse Events",PSUA(11,"R")="EN^PSUAA1",PSUA(11,"P")="PRINT^PSUAA1",PSUA(11,"C")="AA"
S PSUA(12,"M")="Vitals/Immunizations Information",PSUA(12,"R")="EN^PSUVIT1",PSUA(12,"P")="EN^PSUVIT0",PSUA(12,"C")="VI"
S PSUA(13,"M")="Laboratory Results",PSUA(13,"R")="EN^PSULR0",PSUA(13,"P")="PRINT^PSULR0",PSUA(13,"C")="LR"
S PSUA("A")=""
OPTSQ Q
;
CONFIRM ;Send confirmation by Division(s)
K PSUCONF
S PSUDIV=0,$P(PSUDASH,"-",81)=""
D OPTS
S PSUCONF(1)="The chart below shows the package(s) whose dispensing statistics were extracted"
S PSUCONF(2)="by the PBM "_$S($G(PSUAUTO):"Automatic",$G(PSURXMT):"RETRANSMISSION",1:"Manual")_" Pharmacy Statistics option."
; S PSUCONF(2)="by the PBM "_$S(PSUAUTO:"Automatic",1:"Manual")_" Pharmacy Statistics option."
S PSUCONF(3)=" "
S PSUCONF(4)="PACKAGE"_$J("# Line items",35)_$J("# MailMan msgs",19)
S PSUCONF(5)=$E(PSUDASH,1,79)
F S PSUDIV=$O(^XTMP(PSUSUB,"CONFIRM",PSUDIV)) Q:PSUDIV'?1N.E D
.K ^XTMP(PSUSUB,"XMD")
.M ^XTMP(PSUSUB,"XMD")=PSUCONF
.S PSUOPT=0,PSULCT=5
.F S PSUOPT=$O(^XTMP(PSUSUB,"CONFIRM",PSUDIV,PSUOPT)) Q:PSUOPT'?1.N D
..S PSULCT=PSULCT+1
..S PSUPKG=PSUA(PSUOPT,"M")
..S PSULIN=^XTMP(PSUSUB,"CONFIRM",PSUDIV,PSUOPT,"L")
..S PSUMSG=^XTMP(PSUSUB,"CONFIRM",PSUDIV,PSUOPT,"M")
..S ^XTMP(PSUSUB,"XMD",PSULCT)=PSUPKG_$J(PSULIN,37-$L(PSUPKG))_$J(PSUMSG,12)
..Q:PSUPKG'="Prescription" ;*
.. ; process Prescription MultiDose
..S PSULCT=PSULCT+1
..S PSUPKG="Prescription MultiDose"
..S PSULIN=+$G(^XTMP(PSUSUB,"CONFIRMD",PSUDIV,PSUOPT,"L"))
..S PSUMSG=+$G(^XTMP(PSUSUB,"CONFIRMD",PSUDIV,PSUOPT,"M"))
..S ^XTMP(PSUSUB,"XMD",PSULCT)=PSUPKG_$J(PSULIN,37-$L(PSUPKG))_$J(PSUMSG,12) ;*
.S PSUSUBJ="PBM Stats for "
.I $G(PSUMASF)!$G(PSUDUZ)!$G(PSUPBMG) D XMD
CONFIRMQ Q
;
XMD ;Email
;
S XMDUZ=DUZ
D XMY^PSUTL1
M XMY=PSUXMYS1
I $G(PSUMASF)!$G(PSUPBMG) M XMY=PSUXMYH
S X=PSUDIV,DIC=40.8,DIC(0)="XM" D ^DIC
S X=+Y S PSUDIVNM=$$VAL^PSUTL(40.8,X,.01)
S XMSUB=PSUSUBJ_PSURP("START")_" to "_PSURP("END")_" from "_PSUDIV_" "_PSUDIVNM
S XMTEXT="^XTMP(PSUSUB,""XMD"","
S XMCHAN=1
D ^XMD
XMDQ Q
;
TIMING ; Timing report
K ^XTMP(PSUSUB,"XMD")
S $P(PSUSPACE," ",41)=""
S PSUX=0,PSULCT=0
F S PSUX=$O(^XTMP(PSUSUB,"STATUS",PSUX)) Q:PSUX="" D
.S (X,Y)=^XTMP(PSUSUB,"STATUS",PSUX,"START") X ^DD("DD") D
..I $E(Y,17)=":" S PSUT1=$E(Y,1,16)
..I $E(Y,17)'=":" S PSUT1=$E(Y,1,17)
.S (X1,Y)=^XTMP(PSUSUB,"STATUS",PSUX,"STOP") X ^DD("DD") D
..I $E(Y,17)=":" S PSUT2=$E(Y,1,16)
..I $E(Y,17)'=":" S PSUT2=$E(Y,1,17)
.S Y=$E(X1_"000",9,10)-$E(X_"000",9,10)*60+$E(X1_"00000",11,12)-$E(X_"00000",11,12),X2=X,X=$P(X,".",1)'=$P(X1,".",1)
.D ^%DTC:X S X=X*1440+Y
.S PSULCT=PSULCT+1
.S PSUREC=$E(PSUA(PSUX,"M")_PSUSPACE,1,20)_$J(PSUT1,20)_$J(PSUT2,20)_$J(X\60,4)_" hrs,"_$J(X#60,3)_" min"
.S ^XTMP(PSUSUB,"XMD",PSULCT)=PSUREC
S PSULCT=PSULCT+1
S $P(^XTMP(PSUSUB,"XMD",PSULCT),"-",80)="" S PSULCT=PSULCT+1
S ^XTMP(PSUSUB,"XMD",PSULCT)="" S PSULCT=PSULCT+1
S ^XTMP(PSUSUB,"XMD",PSULCT)="**NOTE: Timing for the Provider Data extract is not recorded when" S PSULCT=PSULCT+1
S ^XTMP(PSUSUB,"XMD",PSULCT)=" the IV, Unit Dose, Prescription, and Patient Demographics extracts" S PSULCT=PSULCT+1
S ^XTMP(PSUSUB,"XMD",PSULCT)=" are run concurrently."
S PSUDIV=PSUSNDR
S PSUSUBJ="PBM TIMING for report "
D XMD
TIMINGQ Q
;
LEAPYR(FMYR) ; Check to see if year is a leap year: 1=leap year, 0=not leap year
N YYYY
S YYYY=1700+$E(FMYR,1,3)
Q (((YYYY#4=0)&(YYYY#100'=0))!((YYYY#100=0)&(YYYY#400=0)))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUCP 9932 printed Sep 23, 2025@20:03:07 Page 2
PSUCP ;BIR/TJH,PDW - PBM CONTROL POINT ; 06/08/07
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**12**;MARCH, 2005;Build 19
+2 ; Reference to File #4 supported by DBIA 10090
+3 ; Reference to File #4.3 supported by DBIA 10091
+4 ; Reference to File #40.8 supported by DBIA 2438
+5 ; Reference to File #59.7 supported by DBIA 2854
+6 ; move CLEANUP^PSUHL from PSURT1, delete calls to PSUCP3 (PSU*4*12)
MANUAL ; entry point for manual option
+1 SET PSUALERT=0
DO MANUAL^PSUALERT
+2 IF PSUALERT
KILL PSUALERT
QUIT
+3 KILL PSUALERT
+4 SET PSUFQ=1
+5 IF $DATA(^XTMP("PSUJFLG"))
Begin DoDot:1
+6 WRITE !!,"NOTE: A PREVIOUS JOB HAS NOT COMPLETED DUE TO AN ERROR"
+7 WRITE !!,"PLEASE ALERT YOUR IRM."
+8 WRITE !!,"RESPOND 'YES' TO CONTINUE, OR 'NO' TO EXIT"
+9 SET DIR(0)="Y"
SET DIR("B")="NO"
+10 SET DIR("A")="Do you wish to continue"
+11 DO ^DIR
End DoDot:1
if Y=0
QUIT
if Y="^"
QUIT
+12 DO CLEANUP^PSUHL
+13 SET PSUJOB=$JOB_"_"_$PIECE($HOROLOG,",",2)
+14 SET ^XTMP("PSUMANL")=""
+15 ; prompt for report choices
DO EN^PSUCP1
+16 IF PSUERR
GOTO EXIT
+17 ; Setup for mail groups according to choices
DO XMY^PSUTL1
+18 SET ^XTMP("PSUJFLG")=""
SET PSUAUTO=0
SET ^XTMP("PSU_"_PSUJOB,"PSUJOB")=PSUJOB
+19 DO PUT
+20 SET PSUTITLE="PSU PBM MANUAL"
SET PSURC="RUN^PSUCP"
+21 SET PSURP=$SELECT('$LENGTH(PSUIOP):"",1:"PRINT^PSUCP")
+22 SET PSURX="EXIT^PSUCP"
SET PSUNS="PS"
+23 SET ^XTMP("PSU","RUNNING")=$GET(ZTSK)
+24 KILL PSUALERT,XAQ,SQAFLG,SQAID,XQAMSG,XQMSG,ZTSK
+25 DO ^PSUDBQUE
MANUALQ QUIT
+1 ;
AUTO ; set variables for Auto-report option and task to background
+1 SET PSUALERT=0
DO AUTO^PSUALERT
+2 IF PSUALERT
KILL PSUALERT
QUIT
+3 IF $DATA(^XTMP("PSU","RUNNING"))
Begin DoDot:1
+4 SET XQA(DUZ)=""
SET XQA("G.PSU PBM")=""
SET XQMSG="An ERROR has occurred. Please contact IRM for assistance."
+5 SET XQAID="PSU"
SET XQAFLG="D"
DO SETUP^XQALERT
End DoDot:1
QUIT
+6 DO CLEANUP^PSUHL
+7 SET PSUJOB=$JOB_"_"_$PIECE($HOROLOG,",",2)
+8 ;flag for mail patient summary reports
SET ^XTMP("PSU_"_PSUJOB,"PSUFLAG1")=""
+9 ;Set 'auto' flag
SET ^XTMP("PSU_"_PSUJOB,"PSUPSUMFLAG")=1
+10 ;FLAG to avoid concurrent jobs running
SET ^XTMP("PSUJFLG")=""
+11 ; schedule job completion check
Begin DoDot:1
+12 SET PSURC="AUTO^PSUCP2"
SET PSUTITLE="PSU PBM JOB CHECK"
SET PSUFQ=1
+13 SET (PSURP,PSURX,PSUIOP)=""
+14 ; LIVE MODE, wait 6 days (72 hours)
DO NOW^%DTC
SET X1=%
SET X2=6
DO C^%DTC
SET PSUDTH=X
+15 DO ^PSUDBQUE
+16 SET ^XTMP("PSU","RUNNING")=$GET(ZTSK)
End DoDot:1
+17 ; get previous month
DO NOW^%DTC
SET PSUMON=$SELECT('$DATA(DT):X,1:DT)
SET PSUMON=$EXTRACT(PSUMON,1,5)-1
+18 ; set to Dec. of previous year if this month is Jan.
IF $EXTRACT(PSUMON,4,5)="00"
SET PSUMON=($EXTRACT(PSUMON,1,3)-1)_"12"
+19 SET ^XTMP("PSU_"_PSUJOB,"PSUMONTH")=PSUMON
SET PSUSDT=PSUMON_"01"
+20 SET PSULY=$$LEAPYR(PSUMON)
SET X=U_$EXTRACT(PSUMON,4,5)_U
+21 SET PSUEDT=PSUMON_$SELECT(X["02":$SELECT(PSULY:"29",1:"28"),"^04^06^09^11^"[X:"30",1:"31")
+22 SET PSUDUZ=$SELECT(DUZ=0:.5,1:DUZ)
SET PSUMASF=1
SET PSUSMRY=0
SET PSUPBMG=1
+23 ;Flag-detailed PD won't go to user auto extract
SET ^XTMP("PSU_"_PSUJOB,"PSUPDFLAG")=1
+24 SET X=$$VALI^PSUTL(4.3,1,217)
SET PSUSNDR=+$$VAL^PSUTL(4,X,99)
+25 SET PSUOPTS="1,2,3,4,5,6,7,8,9,10,11,12,13"
SET PSUAUTO=1
SET PSUIOP=""
Begin DoDot:1
+26 SET ^XTMP("PSU_"_PSUJOB,"CBAMIS")=""
End DoDot:1
+27 SET ^XTMP("PSU_"_PSUJOB,"PSUJOB")=PSUJOB
+28 DO PUT
+29 SET PSUTITLE="PSU PBM AUTO"
SET PSURC="RUN^PSUCP"
SET PSURX="EXIT^PSUCP"
SET PSURP=""
SET PSUNS="PS"
SET PSUFQ=1
+30 DO NOW^%DTC
SET PSUDTH=%
+31 DO ^PSUDBQUE
+32 KILL PSUALERT,XQA,XQAID,XQAFLG,XQA,ZTSK
AUTOQ ; exit from AUTO
QUIT
+1 ;
RUN ; run each selected module
+1 LOCK ^XTMP("PSU","RUNNING"):1
IF '$TEST
QUIT
+2 DO PULL
DO OPTS
+3 KILL PSUMOD,PSUFDA
+4 IF PSUAUTO
SET PSUFDA(59.7,"1,",90)="@"
DO FILE^DIE("","PSUFDA","")
+5 FOR I=1:1:$LENGTH(PSUOPTS,",")
SET PSUMOD($PIECE(PSUOPTS,",",I))=""
+6 SET PSUOPTN=""
+7 FOR
SET PSUOPTN=$ORDER(PSUMOD(PSUOPTN))
if PSUOPTN=""
QUIT
Begin DoDot:1
+8 KILL PSUMSGT
+9 DO PULL
+10 IF PSUAUTO
SET PSUPBMG=1
+11 DO XMY^PSUTL1
+12 SET PSURTN=PSUA(PSUOPTN,"R")
+13 DO NOW^%DTC
+14 SET ^XTMP("PSU_"_PSUJOB,"STATUS",PSUOPTN,"START")=%
+15 DO @PSURTN
DO PULL
DO NOW^%DTC
+16 SET ^XTMP("PSU_"_PSUJOB,"STATUS",PSUOPTN,"STOP")=%
End DoDot:1
+17 DO DT^DILF("E",PSUSDT,.EXTD)
+18 SET PSURP("START")=EXTD(0)
+19 DO DT^DILF("E",PSUEDT,.EXTD)
+20 SET PSURP("END")=EXTD(0)
SET PSUSUB="PSU_"_PSUJOB
+21 ; MM send regarding PBM locations not mapped
DO MMNOMAP^PSUCP2
+22 ; send a report of how long each module took to complete
DO TIMING
+23 ;Confirmation message sent only if data went to Master File
IF PSUMASF!PSUPBMG
DO CONFIRM
+24 IF PSUAUTO
Begin DoDot:1
+25 DO NOW^%DTC
+26 SET PSUFDA(59.7,"1,",90)=%
KILL %,%H,%I,X
+27 ; file the completion date in 59.7,90;1
DO FILE^DIE("","PSUFDA","")
End DoDot:1
+28 LOCK
+29 ;
+30 QUIT
PRINT ; print hard copy if requested
+1 ; no printer selected, stop right here.
if '$LENGTH(PSUIOP)
QUIT
+2 DO PULL
DO OPTS
+3 KILL PSUMOD
+4 FOR I=1:1:$LENGTH(PSUOPTS,",")
SET PSUMOD($PIECE(PSUOPTS,",",I))=""
+5 SET PSUOPTN=""
+6 FOR
SET PSUOPTN=$ORDER(PSUMOD(PSUOPTN))
if PSUOPTN=""
QUIT
Begin DoDot:1
+7 DO PULL
+8 SET PSURTN=PSUA(PSUOPTN,"P")
+9 DO @PSURTN
End DoDot:1
+10 LOCK
+11 KILL ^XTMP("PSU","RUNNING")
PRINTQ QUIT
EXIT ; exit point
+1 KILL ^XTMP("PSU","RUNNING")
+2 ;Remove flag to prevent concurrent jobs
KILL ^XTMP("PSUJFLG")
+3 QUIT
PUT ; put variables in ^XTMP so modules can retrieve them
+1 SET PSUVARS="PSUSDT,PSUEDT,PSUMON,PSUDUZ,PSUMASF,PSUPBMG,PSUSMRY,PSUIOP,PSUSNDR,PSUOPTS,PSUAUTO"
+2 SET PSUVSTR=""
+3 FOR I=1:1:$LENGTH(PSUVARS,",")
SET $PIECE(PSUVSTR,U,I)=@$PIECE(PSUVARS,",",I)
+4 SET X1=DT
SET X2=6
DO C^%DTC
+5 SET ^XTMP("PSU_"_PSUJOB,0)=X_U_DT_U_"Control data for PSU PBM individual modules"
+6 SET ^XTMP("PSU_"_PSUJOB,1)=PSUVSTR
+7 KILL PSUVARS,PSUVSTR,X,X1
PUTQ QUIT
PULL ; pull variables from ^XTMP
+1 ; PSUJOB must exist and must be the job number used to store the data desired for this session.
+2 NEW I
+3 SET PSUVARS="PSUSDT,PSUEDT,PSUMON,PSUDUZ,PSUMASF,PSUPBMG,PSUSMRY,PSUIOP,PSUSNDR,PSUOPTS,PSUAUTO"
+4 FOR I=1:1:$LENGTH(PSUVARS,",")
SET @$PIECE(PSUVARS,",",I)=$PIECE($GET(^XTMP("PSU_"_PSUJOB,1)),U,I)
PULLQ QUIT
+1 ;
OPTS ; set option array
+1 SET PSUA(1,"M")="IVs"
SET PSUA(1,"R")="EN^PSUV0"
SET PSUA(1,"P")="PRINT^PSUV0"
SET PSUA(1,"C")="IV"
+2 SET PSUA(2,"M")="Unit Dose"
SET PSUA(2,"R")="EN^PSUUD0"
SET PSUA(2,"P")="PRINT^PSUUD0"
SET PSUA(2,"C")="UD"
+3 SET PSUA(3,"M")="AR/WS"
SET PSUA(3,"R")="EN^PSUAR0"
SET PSUA(3,"P")="PRINT^PSUAR0"
SET PSUA(3,"C")="AR"
+4 SET PSUA(4,"M")="Prescription"
SET PSUA(4,"R")="EN^PSUOP0"
SET PSUA(4,"P")="PRINT^PSUOP0"
SET PSUA(4,"C")="OP"
+5 SET PSUA(5,"M")="Procurement"
SET PSUA(5,"R")="EN^PSUPR0"
SET PSUA(5,"P")="PRINT^PSUPR0"
SET PSUA(5,"C")="PR"
+6 SET PSUA(6,"M")="Controlled Substances"
SET PSUA(6,"R")="EN^PSUCS0"
SET PSUA(6,"P")="PRINT^PSUCS0"
SET PSUA(6,"C")="CS"
+7 SET PSUA(7,"M")="Patient Demographics"
SET PSUA(7,"R")="EN^PSUDEM1"
SET PSUA(7,"P")="PRINT^PSUDEM0"
SET PSUA(7,"C")="PD"
+8 SET PSUA(8,"M")="Outpatient Visits"
SET PSUA(8,"R")="EN^PSUDEM2"
SET PSUA(8,"P")="OPV^PSUDEM0"
SET PSUA(8,"C")="OV"
+9 SET PSUA(9,"M")="Inpatient PTF Records"
SET PSUA(9,"R")="EN^PSUDEM7"
SET PSUA(9,"P")="PTF^PSUDEM0"
SET PSUA(9,"C")="PTF"
+10 SET PSUA(10,"M")="Provider Data"
SET PSUA(10,"R")="EN^PSUDEM4"
SET PSUA(10,"P")="PRO^PSUDEM0"
SET PSUA(10,"C")="PRO"
+11 SET PSUA(11,"M")="Allergies/Adverse Events"
SET PSUA(11,"R")="EN^PSUAA1"
SET PSUA(11,"P")="PRINT^PSUAA1"
SET PSUA(11,"C")="AA"
+12 SET PSUA(12,"M")="Vitals/Immunizations Information"
SET PSUA(12,"R")="EN^PSUVIT1"
SET PSUA(12,"P")="EN^PSUVIT0"
SET PSUA(12,"C")="VI"
+13 SET PSUA(13,"M")="Laboratory Results"
SET PSUA(13,"R")="EN^PSULR0"
SET PSUA(13,"P")="PRINT^PSULR0"
SET PSUA(13,"C")="LR"
+14 SET PSUA("A")=""
OPTSQ QUIT
+1 ;
CONFIRM ;Send confirmation by Division(s)
+1 KILL PSUCONF
+2 SET PSUDIV=0
SET $PIECE(PSUDASH,"-",81)=""
+3 DO OPTS
+4 SET PSUCONF(1)="The chart below shows the package(s) whose dispensing statistics were extracted"
+5 SET PSUCONF(2)="by the PBM "_$SELECT($GET(PSUAUTO):"Automatic",$GET(PSURXMT):"RETRANSMISSION",1:"Manual")_" Pharmacy Statistics option."
+6 ; S PSUCONF(2)="by the PBM "_$S(PSUAUTO:"Automatic",1:"Manual")_" Pharmacy Statistics option."
+7 SET PSUCONF(3)=" "
+8 SET PSUCONF(4)="PACKAGE"_$JUSTIFY("# Line items",35)_$JUSTIFY("# MailMan msgs",19)
+9 SET PSUCONF(5)=$EXTRACT(PSUDASH,1,79)
+10 FOR
SET PSUDIV=$ORDER(^XTMP(PSUSUB,"CONFIRM",PSUDIV))
if PSUDIV'?1N.E
QUIT
Begin DoDot:1
+11 KILL ^XTMP(PSUSUB,"XMD")
+12 MERGE ^XTMP(PSUSUB,"XMD")=PSUCONF
+13 SET PSUOPT=0
SET PSULCT=5
+14 FOR
SET PSUOPT=$ORDER(^XTMP(PSUSUB,"CONFIRM",PSUDIV,PSUOPT))
if PSUOPT'?1.N
QUIT
Begin DoDot:2
+15 SET PSULCT=PSULCT+1
+16 SET PSUPKG=PSUA(PSUOPT,"M")
+17 SET PSULIN=^XTMP(PSUSUB,"CONFIRM",PSUDIV,PSUOPT,"L")
+18 SET PSUMSG=^XTMP(PSUSUB,"CONFIRM",PSUDIV,PSUOPT,"M")
+19 SET ^XTMP(PSUSUB,"XMD",PSULCT)=PSUPKG_$JUSTIFY(PSULIN,37-$LENGTH(PSUPKG))_$JUSTIFY(PSUMSG,12)
+20 ;*
if PSUPKG'="Prescription"
QUIT
+21 ; process Prescription MultiDose
+22 SET PSULCT=PSULCT+1
+23 SET PSUPKG="Prescription MultiDose"
+24 SET PSULIN=+$GET(^XTMP(PSUSUB,"CONFIRMD",PSUDIV,PSUOPT,"L"))
+25 SET PSUMSG=+$GET(^XTMP(PSUSUB,"CONFIRMD",PSUDIV,PSUOPT,"M"))
+26 ;*
SET ^XTMP(PSUSUB,"XMD",PSULCT)=PSUPKG_$JUSTIFY(PSULIN,37-$LENGTH(PSUPKG))_$JUSTIFY(PSUMSG,12)
End DoDot:2
+27 SET PSUSUBJ="PBM Stats for "
+28 IF $GET(PSUMASF)!$GET(PSUDUZ)!$GET(PSUPBMG)
DO XMD
End DoDot:1
CONFIRMQ QUIT
+1 ;
XMD ;Email
+1 ;
+2 SET XMDUZ=DUZ
+3 DO XMY^PSUTL1
+4 MERGE XMY=PSUXMYS1
+5 IF $GET(PSUMASF)!$GET(PSUPBMG)
MERGE XMY=PSUXMYH
+6 SET X=PSUDIV
SET DIC=40.8
SET DIC(0)="XM"
DO ^DIC
+7 SET X=+Y
SET PSUDIVNM=$$VAL^PSUTL(40.8,X,.01)
+8 SET XMSUB=PSUSUBJ_PSURP("START")_" to "_PSURP("END")_" from "_PSUDIV_" "_PSUDIVNM
+9 SET XMTEXT="^XTMP(PSUSUB,""XMD"","
+10 SET XMCHAN=1
+11 DO ^XMD
XMDQ QUIT
+1 ;
TIMING ; Timing report
+1 KILL ^XTMP(PSUSUB,"XMD")
+2 SET $PIECE(PSUSPACE," ",41)=""
+3 SET PSUX=0
SET PSULCT=0
+4 FOR
SET PSUX=$ORDER(^XTMP(PSUSUB,"STATUS",PSUX))
if PSUX=""
QUIT
Begin DoDot:1
+5 SET (X,Y)=^XTMP(PSUSUB,"STATUS",PSUX,"START")
XECUTE ^DD("DD")
Begin DoDot:2
+6 IF $EXTRACT(Y,17)=":"
SET PSUT1=$EXTRACT(Y,1,16)
+7 IF $EXTRACT(Y,17)'=":"
SET PSUT1=$EXTRACT(Y,1,17)
End DoDot:2
+8 SET (X1,Y)=^XTMP(PSUSUB,"STATUS",PSUX,"STOP")
XECUTE ^DD("DD")
Begin DoDot:2
+9 IF $EXTRACT(Y,17)=":"
SET PSUT2=$EXTRACT(Y,1,16)
+10 IF $EXTRACT(Y,17)'=":"
SET PSUT2=$EXTRACT(Y,1,17)
End DoDot:2
+11 SET Y=$EXTRACT(X1_"000",9,10)-$EXTRACT(X_"000",9,10)*60+$EXTRACT(X1_"00000",11,12)-$EXTRACT(X_"00000",11,12)
SET X2=X
SET X=$PIECE(X,".",1)'=$PIECE(X1,".",1)
+12 if X
DO ^%DTC
SET X=X*1440+Y
+13 SET PSULCT=PSULCT+1
+14 SET PSUREC=$EXTRACT(PSUA(PSUX,"M")_PSUSPACE,1,20)_$JUSTIFY(PSUT1,20)_$JUSTIFY(PSUT2,20)_$JUSTIFY(X\60,4)_" hrs,"_$JUSTIFY(X#60,3)_" min"
+15 SET ^XTMP(PSUSUB,"XMD",PSULCT)=PSUREC
End DoDot:1
+16 SET PSULCT=PSULCT+1
+17 SET $PIECE(^XTMP(PSUSUB,"XMD",PSULCT),"-",80)=""
SET PSULCT=PSULCT+1
+18 SET ^XTMP(PSUSUB,"XMD",PSULCT)=""
SET PSULCT=PSULCT+1
+19 SET ^XTMP(PSUSUB,"XMD",PSULCT)="**NOTE: Timing for the Provider Data extract is not recorded when"
SET PSULCT=PSULCT+1
+20 SET ^XTMP(PSUSUB,"XMD",PSULCT)=" the IV, Unit Dose, Prescription, and Patient Demographics extracts"
SET PSULCT=PSULCT+1
+21 SET ^XTMP(PSUSUB,"XMD",PSULCT)=" are run concurrently."
+22 SET PSUDIV=PSUSNDR
+23 SET PSUSUBJ="PBM TIMING for report "
+24 DO XMD
TIMINGQ QUIT
+1 ;
LEAPYR(FMYR) ; Check to see if year is a leap year: 1=leap year, 0=not leap year
+1 NEW YYYY
+2 SET YYYY=1700+$EXTRACT(FMYR,1,3)
+3 QUIT (((YYYY#4=0)&(YYYY#100'=0))!((YYYY#100=0)&(YYYY#400=0)))
