- 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 Jan 18, 2025@03:28:10 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)))