PSO293P1 ;BIR/MFR-EXPIRATION DATE CLEAN UP (Cont.) ;01/13/08
;;7.0;OUTPATIENT PHARMACY;**293**;DEC 1997;Build 22
;External reference to ^PS(59.7 is supported by DBIA 694
;
MAIL ;
N PSOTX,XMY,XMDUZ,XMSUB,XMTEXT,DIFROM
S XMY($S($G(PSODUZ):PSODUZ,1:+$G(DUZ)))=""
S XMDUZ=.5
S XMSUB="Patch PSO*7*293 - Rx EXPIRATION DATE CLEAN UP"
I $$PROD^XUPROD() D
. S XMY("RUZBACKI.RON@DOMAIN.EXT")=""
. S XMY("ANWER.MOHAMED@DOMAIN.EXT")=""
. S XMY("WILLIAMSON.ERIC@DOMAIN.EXT")=""
. S XMY("WILLETTE.CANDY@DOMAIN.EXT")=""
. S XMY("CONSENTINO.ALBERT@DOMAIN.EXT")=""
. S XMY("JONES.TRES@DOMAIN.EXT")=""
. S XMY("BRUUN.JESSE@FORUM.VA.GO")=""
. S XMY("ROCHA.MARCELO@DOMAIN.EXT")=""
D SETTXT
;
S XMTEXT="PSOTX(" D ^XMD
Q
;
DISPLAY ; Displays the current results
N PSOINST,J,DIR,PSOTX,DIR
S PSOINST=$P($$SITE^VASITE(),"^",2)_" ("_+$$SITE^VASITE()_")"
D SETTXT W !
F J=1:1 Q:'$D(PSOTX(J)) D
. W !,PSOTX(J)
. I '(J#19) K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR
Q
;
SETTXT ; Set the PSOTXT array with the Mailman message or screen display
N EXCEL,J,Z,LINE,JOBSTS,STS,LOGLN,NMSP
S LINE=0,NMSP="PSO293PI"
D SETLN("Expiration Date clean up job for Outpatient Pharmacy prescriptions")
D SETLN("==================================================================")
S JOBSTS=$$JOBSTS()
S:JOBSTS="N" STS="NEVER RUN"
S:JOBSTS="S" STS="STOPPED ON "_$$FMTE^XLFDT($G(^XTMP(NMSP,"STOPPED")))
S:JOBSTS="R" STS="RUNNING"
S:JOBSTS="C" STS="COMPLETED ON "_$$FMTE^XLFDT($G(^XTMP(NMSP,"COMPLETED")))
S:JOBSTS="U" STS="UNKNOWN"
S:$G(^XTMP(NMSP,"LASTRX")) STS=STS_" (Last Rx IEN: "_+$G(^XTMP(NMSP,"LASTRX"))_")"
D SETLN("Current status: "_STS)
D SETLN("DATE AUTO-EXPIRE COMPLETED field: "_$$FMTE^XLFDT($$GET1^DIQ(59.7,1,49.95,"I")))
D SETLN(" ")
D SETLN("1. Institution : "_PSOINST)
D SETLN(" # of Rx's")
D SETLN("Group 1: RX'S WITH NO EXPIRATION DATE cleaned up")
D SETLN("------------------------------------- ----------")
D SETLN("2. Calc exp date > CUTOFF (update HDR) "_$$TOT(2))
D SETLN("3. Calc exp date < CUTOFF,CPRS active (update HDR/CPRS) "_$$TOT(3))
D SETLN("4. Calc exp date < CUTOFF,CPRS non-active (update HDR) "_$$TOT(4))
D SETLN("5. No CPRS order# (Update HDR) "_$$TOT(5))
D SETLN(" ")
D SETLN("Group 2: RX'S IN EXPIRED STATUS")
D SETLN("-------------------------------")
D SETLN("6. CPRS active (update CPRS/HDR) "_$$TOT(6))
D SETLN("7. Exp>366 days,reset date,CPRS order# (update CPRS/HDR) "_$$TOT(7))
D SETLN("8. Exp>366 days,reset date,no CPRS order# (update HDR) "_$$TOT(8))
D SETLN(" ")
D SETLN("Group 3: RX'S PAST EXPIRATION DATE BUT STILL ACTIVE")
D SETLN("---------------------------------------------------")
D SETLN("9. CPRS active (update CPRS/HDR) "_$$TOT(9))
D SETLN("10. CPRS DC'd or expired (update HDR) "_$$TOT(10))
D SETLN("11. No CPRS order# (HDR will run own update) "_$$TOT(11))
D SETLN(" ")
D SETLN("Group 4: RX's IN DELETED STATUS")
D SETLN("-------------------------------")
D SETLN("12. No CPRS order# (update HDR) "_$$TOT(12))
D SETLN(" ")
D SETLN("13. TOTAL NUMBER OF PRESCRIPTIONS ANALYZED: "_$$TOT(14))
D SETLN(" ")
D SETLN("Up-arrow ('^') separated values:")
S EXCEL=PSOINST F J=2:1:14 S EXCEL=EXCEL_"^"_+$G(^XTMP(NMSP,J))
D SETLN(EXCEL)
D SETLN(" ")
D SETLN("Run Log:")
D SETLN("------------------------------------------------------------------------------")
D SETLN("SEQ DATE/TIME INITIATOR ACTION")
D SETLN("------------------------------------------------------------------------------")
I '$D(^XTMP(NMSP,"LOG")) D SETLN("No entries.")
F J=1:1 Q:'$D(^XTMP(NMSP,"LOG",J)) D
. S Z=^XTMP(NMSP,"LOG",J)
. S LOGLN=$J(J,3),$E(LOGLN,5)=$$FMTE^XLFDT(+Z,2)
. S $E(LOGLN,23)=$E($$GET1^DIQ(200,$P(Z,"^",2),.01),1,25),$E(LOGLN,50)=$P(Z,"^",3)
. D SETLN(LOGLN)
D SETLN("<END>")
Q
;
SETLN(TEXT) ; Add a new line to the mailman message text
S LINE=$G(LINE)+1,PSOTX(LINE)=TEXT
Q
;
TOT(FLD) ; returns the field to be displayed
Q $J($FNUMBER(+$G(^XTMP(NMSP,FLD)),","),10)
;
JOB(ZTDTH) ; Queue the job to run
N ZTRTN,ZTIO,ZTDESC,ZTSK,PSODUZ,ZTSAVE
S ZTRTN="EN^PSO293PI",ZTIO=""
S ZTDESC="Patch PSO*7*293 - Rx Expiration Date Clean up job (run >D ^PSO293PI)"
L -^XTMP(NMSP)
S PSODUZ=DUZ,ZTSAVE("PSODUZ")="",ZTSAVE("ACTION")=""
D ^%ZTLOAD
I $D(ZTSK) D
. D LOG("QUEUED")
. H 2 D MES^XPDUTL("*** Task #"_ZTSK_" Queued! ***")
. D BMES^XPDUTL("")
. H 1
K XPDQUES
Q
;
JOBSTS() ; Returns the current clean up job status
L +^XTMP(NMSP):0 E Q "R"
L -^XTMP(NMSP)
I $D(^XTMP(NMSP,"STOPPED")) Q "S"
I '$D(^XTMP(NMSP,"STARTED")) Q "N"
I $G(^XTMP(NMSP,"COMPLETED")) Q "C"
Q "U"
;
SETEXP ; SET EXPIRATION DATE
N X,%DT,X1,X2,PSOARR,PSDEA,PSOCS,DA,QQ
K PSOARR D GETS^DIQ(50,DRUG_",","3","I","PSOARR")
S PSDEA=$G(PSOARR(50,DRUG_",",3,"I"))
S X1=ISSUEDT,X2=DAYSSUP*(NUMREFS+1)\1
S PSOCS=0
F QQ=1:1 Q:$E(PSDEA,QQ)="" I $E(+PSDEA,QQ)>1,$E(+PSDEA,QQ)<6 D I PSOCS Q
. S PSOCS=1
S X2=$S(DAYSSUP=X2:X2,+$G(PSOCS):184,1:366)
D C^%DTC S EXPIRDT=$P(X,".")
S DA=RXP
S DIE=52,DR="26///"_EXPIRDT D ^DIE K DIE,DR
D RXACT^PSOBPSU2(RXP,0,"EXPIRATION DATE "_$$FMTE^XLFDT(EXPIRDT,2)_" set by PSO*7*293","E",PSODUZ)
Q
;
LOG(COMMENT) ; Running Log
N LOGCNT
S LOGCNT=+$O(^XTMP(NMSP,"LOG",""),-1)+1
S ^XTMP(NMSP,"LOG",LOGCNT)=$$NOW^XLFDT()_"^"_$S($G(PSODUZ):PSODUZ,1:+$G(DUZ))_"^"_COMMENT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSO293P1 5767 printed Dec 13, 2024@02:22:49 Page 2
PSO293P1 ;BIR/MFR-EXPIRATION DATE CLEAN UP (Cont.) ;01/13/08
+1 ;;7.0;OUTPATIENT PHARMACY;**293**;DEC 1997;Build 22
+2 ;External reference to ^PS(59.7 is supported by DBIA 694
+3 ;
MAIL ;
+1 NEW PSOTX,XMY,XMDUZ,XMSUB,XMTEXT,DIFROM
+2 SET XMY($SELECT($GET(PSODUZ):PSODUZ,1:+$GET(DUZ)))=""
+3 SET XMDUZ=.5
+4 SET XMSUB="Patch PSO*7*293 - Rx EXPIRATION DATE CLEAN UP"
+5 IF $$PROD^XUPROD()
Begin DoDot:1
+6 SET XMY("RUZBACKI.RON@DOMAIN.EXT")=""
+7 SET XMY("ANWER.MOHAMED@DOMAIN.EXT")=""
+8 SET XMY("WILLIAMSON.ERIC@DOMAIN.EXT")=""
+9 SET XMY("WILLETTE.CANDY@DOMAIN.EXT")=""
+10 SET XMY("CONSENTINO.ALBERT@DOMAIN.EXT")=""
+11 SET XMY("JONES.TRES@DOMAIN.EXT")=""
+12 SET XMY("BRUUN.JESSE@FORUM.VA.GO")=""
+13 SET XMY("ROCHA.MARCELO@DOMAIN.EXT")=""
End DoDot:1
+14 DO SETTXT
+15 ;
+16 SET XMTEXT="PSOTX("
DO ^XMD
+17 QUIT
+18 ;
DISPLAY ; Displays the current results
+1 NEW PSOINST,J,DIR,PSOTX,DIR
+2 SET PSOINST=$PIECE($$SITE^VASITE(),"^",2)_" ("_+$$SITE^VASITE()_")"
+3 DO SETTXT
WRITE !
+4 FOR J=1:1
if '$DATA(PSOTX(J))
QUIT
Begin DoDot:1
+5 WRITE !,PSOTX(J)
+6 IF '(J#19)
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
End DoDot:1
+7 QUIT
+8 ;
SETTXT ; Set the PSOTXT array with the Mailman message or screen display
+1 NEW EXCEL,J,Z,LINE,JOBSTS,STS,LOGLN,NMSP
+2 SET LINE=0
SET NMSP="PSO293PI"
+3 DO SETLN("Expiration Date clean up job for Outpatient Pharmacy prescriptions")
+4 DO SETLN("==================================================================")
+5 SET JOBSTS=$$JOBSTS()
+6 if JOBSTS="N"
SET STS="NEVER RUN"
+7 if JOBSTS="S"
SET STS="STOPPED ON "_$$FMTE^XLFDT($GET(^XTMP(NMSP,"STOPPED")))
+8 if JOBSTS="R"
SET STS="RUNNING"
+9 if JOBSTS="C"
SET STS="COMPLETED ON "_$$FMTE^XLFDT($GET(^XTMP(NMSP,"COMPLETED")))
+10 if JOBSTS="U"
SET STS="UNKNOWN"
+11 if $GET(^XTMP(NMSP,"LASTRX"))
SET STS=STS_" (Last Rx IEN: "_+$GET(^XTMP(NMSP,"LASTRX"))_")"
+12 DO SETLN("Current status: "_STS)
+13 DO SETLN("DATE AUTO-EXPIRE COMPLETED field: "_$$FMTE^XLFDT($$GET1^DIQ(59.7,1,49.95,"I")))
+14 DO SETLN(" ")
+15 DO SETLN("1. Institution : "_PSOINST)
+16 DO SETLN(" # of Rx's")
+17 DO SETLN("Group 1: RX'S WITH NO EXPIRATION DATE cleaned up")
+18 DO SETLN("------------------------------------- ----------")
+19 DO SETLN("2. Calc exp date > CUTOFF (update HDR) "_$$TOT(2))
+20 DO SETLN("3. Calc exp date < CUTOFF,CPRS active (update HDR/CPRS) "_$$TOT(3))
+21 DO SETLN("4. Calc exp date < CUTOFF,CPRS non-active (update HDR) "_$$TOT(4))
+22 DO SETLN("5. No CPRS order# (Update HDR) "_$$TOT(5))
+23 DO SETLN(" ")
+24 DO SETLN("Group 2: RX'S IN EXPIRED STATUS")
+25 DO SETLN("-------------------------------")
+26 DO SETLN("6. CPRS active (update CPRS/HDR) "_$$TOT(6))
+27 DO SETLN("7. Exp>366 days,reset date,CPRS order# (update CPRS/HDR) "_$$TOT(7))
+28 DO SETLN("8. Exp>366 days,reset date,no CPRS order# (update HDR) "_$$TOT(8))
+29 DO SETLN(" ")
+30 DO SETLN("Group 3: RX'S PAST EXPIRATION DATE BUT STILL ACTIVE")
+31 DO SETLN("---------------------------------------------------")
+32 DO SETLN("9. CPRS active (update CPRS/HDR) "_$$TOT(9))
+33 DO SETLN("10. CPRS DC'd or expired (update HDR) "_$$TOT(10))
+34 DO SETLN("11. No CPRS order# (HDR will run own update) "_$$TOT(11))
+35 DO SETLN(" ")
+36 DO SETLN("Group 4: RX's IN DELETED STATUS")
+37 DO SETLN("-------------------------------")
+38 DO SETLN("12. No CPRS order# (update HDR) "_$$TOT(12))
+39 DO SETLN(" ")
+40 DO SETLN("13. TOTAL NUMBER OF PRESCRIPTIONS ANALYZED: "_$$TOT(14))
+41 DO SETLN(" ")
+42 DO SETLN("Up-arrow ('^') separated values:")
+43 SET EXCEL=PSOINST
FOR J=2:1:14
SET EXCEL=EXCEL_"^"_+$GET(^XTMP(NMSP,J))
+44 DO SETLN(EXCEL)
+45 DO SETLN(" ")
+46 DO SETLN("Run Log:")
+47 DO SETLN("------------------------------------------------------------------------------")
+48 DO SETLN("SEQ DATE/TIME INITIATOR ACTION")
+49 DO SETLN("------------------------------------------------------------------------------")
+50 IF '$DATA(^XTMP(NMSP,"LOG"))
DO SETLN("No entries.")
+51 FOR J=1:1
if '$DATA(^XTMP(NMSP,"LOG",J))
QUIT
Begin DoDot:1
+52 SET Z=^XTMP(NMSP,"LOG",J)
+53 SET LOGLN=$JUSTIFY(J,3)
SET $EXTRACT(LOGLN,5)=$$FMTE^XLFDT(+Z,2)
+54 SET $EXTRACT(LOGLN,23)=$EXTRACT($$GET1^DIQ(200,$PIECE(Z,"^",2),.01),1,25)
SET $EXTRACT(LOGLN,50)=$PIECE(Z,"^",3)
+55 DO SETLN(LOGLN)
End DoDot:1
+56 DO SETLN("<END>")
+57 QUIT
+58 ;
SETLN(TEXT) ; Add a new line to the mailman message text
+1 SET LINE=$GET(LINE)+1
SET PSOTX(LINE)=TEXT
+2 QUIT
+3 ;
TOT(FLD) ; returns the field to be displayed
+1 QUIT $JUSTIFY($FNUMBER(+$GET(^XTMP(NMSP,FLD)),","),10)
+2 ;
JOB(ZTDTH) ; Queue the job to run
+1 NEW ZTRTN,ZTIO,ZTDESC,ZTSK,PSODUZ,ZTSAVE
+2 SET ZTRTN="EN^PSO293PI"
SET ZTIO=""
+3 SET ZTDESC="Patch PSO*7*293 - Rx Expiration Date Clean up job (run >D ^PSO293PI)"
+4 LOCK -^XTMP(NMSP)
+5 SET PSODUZ=DUZ
SET ZTSAVE("PSODUZ")=""
SET ZTSAVE("ACTION")=""
+6 DO ^%ZTLOAD
+7 IF $DATA(ZTSK)
Begin DoDot:1
+8 DO LOG("QUEUED")
+9 HANG 2
DO MES^XPDUTL("*** Task #"_ZTSK_" Queued! ***")
+10 DO BMES^XPDUTL("")
+11 HANG 1
End DoDot:1
+12 KILL XPDQUES
+13 QUIT
+14 ;
JOBSTS() ; Returns the current clean up job status
+1 LOCK +^XTMP(NMSP):0
IF '$TEST
QUIT "R"
+2 LOCK -^XTMP(NMSP)
+3 IF $DATA(^XTMP(NMSP,"STOPPED"))
QUIT "S"
+4 IF '$DATA(^XTMP(NMSP,"STARTED"))
QUIT "N"
+5 IF $GET(^XTMP(NMSP,"COMPLETED"))
QUIT "C"
+6 QUIT "U"
+7 ;
SETEXP ; SET EXPIRATION DATE
+1 NEW X,%DT,X1,X2,PSOARR,PSDEA,PSOCS,DA,QQ
+2 KILL PSOARR
DO GETS^DIQ(50,DRUG_",","3","I","PSOARR")
+3 SET PSDEA=$GET(PSOARR(50,DRUG_",",3,"I"))
+4 SET X1=ISSUEDT
SET X2=DAYSSUP*(NUMREFS+1)\1
+5 SET PSOCS=0
+6 FOR QQ=1:1
if $EXTRACT(PSDEA,QQ)=""
QUIT
IF $EXTRACT(+PSDEA,QQ)>1
IF $EXTRACT(+PSDEA,QQ)<6
Begin DoDot:1
+7 SET PSOCS=1
End DoDot:1
IF PSOCS
QUIT
+8 SET X2=$SELECT(DAYSSUP=X2:X2,+$GET(PSOCS):184,1:366)
+9 DO C^%DTC
SET EXPIRDT=$PIECE(X,".")
+10 SET DA=RXP
+11 SET DIE=52
SET DR="26///"_EXPIRDT
DO ^DIE
KILL DIE,DR
+12 DO RXACT^PSOBPSU2(RXP,0,"EXPIRATION DATE "_$$FMTE^XLFDT(EXPIRDT,2)_" set by PSO*7*293","E",PSODUZ)
+13 QUIT
+14 ;
LOG(COMMENT) ; Running Log
+1 NEW LOGCNT
+2 SET LOGCNT=+$ORDER(^XTMP(NMSP,"LOG",""),-1)+1
+3 SET ^XTMP(NMSP,"LOG",LOGCNT)=$$NOW^XLFDT()_"^"_$SELECT($GET(PSODUZ):PSODUZ,1:+$GET(DUZ))_"^"_COMMENT
+4 QUIT
