PSO283P1 ;BIR/MFR-EXPIRATION DATE PROBLEM TALLY (Cont.) ;05/03/07
;;7.0;OUTPATIENT PHARMACY;**283**;DEC 1997;Build 28
;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*283 - Rx EXPIRATION DATE PROBLEM TALLY"
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("ROCHA.MARCELO@DOMAIN.EXT")=""
S XMY("BARRON.LUANNE@DOMAIN.EXT")=""
S XMY("JONES.TRES@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="PSO283PI"
D SETLN("Expiration Date problem tally patch 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:$G(^XTMP(NMSP,"LASTRX")) STS=STS_" (Last Rx IEN: "_$G(^XTMP(NMSP,"LASTRX"))_")"
D SETLN("Current status: "_STS)
D SETLN(" ")
D SETLN("1. Institution : "_PSOINST)
D SETLN(" PATIENTS")
D SETLN("Group 1: RX'S WITH NO EXPIRATION DATE WITH ICN# W/NO ICN#")
D SETLN("------------------------------------- ---------- ----------")
D SETLN("2. Calc exp date > CUTOFF (update HDR) "_$$TOT(2)_" "_$$TOT(102))
D SETLN("3. Calc exp date < CUTOFF,CPRS active (update HDR/CPRS) "_$$TOT(3)_" "_$$TOT(103))
D SETLN("4. Calc exp date < CUTOFF,CPRS non-active (update HDR) "_$$TOT(4)_" "_$$TOT(104))
D SETLN("5. No CPRS order# (Update HDR) "_$$TOT(5)_" "_$$TOT(105))
D SETLN(" ")
D SETLN("Group 2: RX'S IN EXPIRED STATUS")
D SETLN("-------------------------------")
D SETLN("6. CPRS active (update CPRS/HDR) "_$$TOT(6)_" "_$$TOT(106))
D SETLN("7. Exp>366 days,reset date,CPRS order# (update CPRS/HDR)"_$$TOT(7)_" "_$$TOT(107))
D SETLN("8. Exp>366 days,reset date,no CPRS order# (update HDR) "_$$TOT(8)_" "_$$TOT(108))
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)_" "_$$TOT(109))
D SETLN("10. CPRS DC'd or expired (update HDR) "_$$TOT(10)_" "_$$TOT(110))
D SETLN("11. No CPRS order# (HDR will run own update) "_$$TOT(11)_" "_$$TOT(111))
D SETLN(" ")
D SETLN("Group 4: RX's IN DELETED STATUS")
D SETLN("-------------------------------")
D SETLN("12. No CPRS order# (update HDR) "_$$TOT(12)_" "_$$TOT(112))
D SETLN(" ")
D SETLN("OTHER")
D SETLN("-----")
D SETLN("13. BAD RX's: NO PATIENT,DRUG or ISSUE DT (NO UPDATES): "_$$TOT(13))
D SETLN(" ")
D SETLN("14. TOTAL NUMBER OF PRESCRIPTIONS ANALYZED: "_$$TOT(14))
D SETLN(" ")
D SETLN("Up-arrow ('^') separated values (patients WITH ICN#):")
S EXCEL=PSOINST F J=2:1:14 S EXCEL=EXCEL_"^"_+$G(^XTMP(NMSP,J))
D SETLN(EXCEL)
D SETLN(" ")
D SETLN("Up-arrow ('^') separated values (patients WITHOUT ICN#):")
S EXCEL=PSOINST F J=102:1:112 S EXCEL=EXCEL_"^"_+$G(^XTMP(NMSP,J))
D SETLN(EXCEL_"^"_+$G(^XTMP(NMSP,13))_"^"_+$G(^XTMP(NMSP,14)))
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^PSO283PI",ZTIO=""
S ZTDESC="Patch PSO*7*283 - Rx Expiration Date problem tally job (run >D ^PSO283PI)"
L -^XTMP(NMSP)
S PSODUZ=DUZ,ZTSAVE("PSODUZ")=""
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 job status
L +^XTMP(NMSP):0 E Q "R"
L -^XTMP(NMSP)
I '$D(^XTMP(NMSP,"STARTED")) Q "N"
I $G(^XTMP(NMSP,"COMPLETED")) Q "C"
Q "S"
;
CALCEXP ; CALCULATE THE 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,".")
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[HPSO283P1 5913 printed Apr 09, 2024@21:33:02 Page 2
PSO283P1 ;BIR/MFR-EXPIRATION DATE PROBLEM TALLY (Cont.) ;05/03/07
+1 ;;7.0;OUTPATIENT PHARMACY;**283**;DEC 1997;Build 28
+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*283 - Rx EXPIRATION DATE PROBLEM TALLY"
+5 SET XMY("RUZBACKI.RON@DOMAIN.EXT")=""
+6 SET XMY("ANWER.MOHAMED@DOMAIN.EXT")=""
+7 SET XMY("WILLIAMSON.ERIC@DOMAIN.EXT")=""
+8 SET XMY("WILLETTE.CANDY@DOMAIN.EXT")=""
+9 SET XMY("ROCHA.MARCELO@DOMAIN.EXT")=""
+10 SET XMY("BARRON.LUANNE@DOMAIN.EXT")=""
+11 SET XMY("JONES.TRES@DOMAIN.EXT")=""
+12 DO SETTXT
+13 ;
+14 SET XMTEXT="PSOTX("
DO ^XMD
+15 QUIT
+16 ;
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="PSO283PI"
+3 DO SETLN("Expiration Date problem tally patch 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 $GET(^XTMP(NMSP,"LASTRX"))
SET STS=STS_" (Last Rx IEN: "_$GET(^XTMP(NMSP,"LASTRX"))_")"
+11 DO SETLN("Current status: "_STS)
+12 DO SETLN(" ")
+13 DO SETLN("1. Institution : "_PSOINST)
+14 DO SETLN(" PATIENTS")
+15 DO SETLN("Group 1: RX'S WITH NO EXPIRATION DATE WITH ICN# W/NO ICN#")
+16 DO SETLN("------------------------------------- ---------- ----------")
+17 DO SETLN("2. Calc exp date > CUTOFF (update HDR) "_$$TOT(2)_" "_$$TOT(102))
+18 DO SETLN("3. Calc exp date < CUTOFF,CPRS active (update HDR/CPRS) "_$$TOT(3)_" "_$$TOT(103))
+19 DO SETLN("4. Calc exp date < CUTOFF,CPRS non-active (update HDR) "_$$TOT(4)_" "_$$TOT(104))
+20 DO SETLN("5. No CPRS order# (Update HDR) "_$$TOT(5)_" "_$$TOT(105))
+21 DO SETLN(" ")
+22 DO SETLN("Group 2: RX'S IN EXPIRED STATUS")
+23 DO SETLN("-------------------------------")
+24 DO SETLN("6. CPRS active (update CPRS/HDR) "_$$TOT(6)_" "_$$TOT(106))
+25 DO SETLN("7. Exp>366 days,reset date,CPRS order# (update CPRS/HDR)"_$$TOT(7)_" "_$$TOT(107))
+26 DO SETLN("8. Exp>366 days,reset date,no CPRS order# (update HDR) "_$$TOT(8)_" "_$$TOT(108))
+27 DO SETLN(" ")
+28 DO SETLN("Group 3: RX'S PAST EXPIRATION DATE BUT STILL ACTIVE")
+29 DO SETLN("---------------------------------------------------")
+30 DO SETLN("9. CPRS active (update CPRS/HDR) "_$$TOT(9)_" "_$$TOT(109))
+31 DO SETLN("10. CPRS DC'd or expired (update HDR) "_$$TOT(10)_" "_$$TOT(110))
+32 DO SETLN("11. No CPRS order# (HDR will run own update) "_$$TOT(11)_" "_$$TOT(111))
+33 DO SETLN(" ")
+34 DO SETLN("Group 4: RX's IN DELETED STATUS")
+35 DO SETLN("-------------------------------")
+36 DO SETLN("12. No CPRS order# (update HDR) "_$$TOT(12)_" "_$$TOT(112))
+37 DO SETLN(" ")
+38 DO SETLN("OTHER")
+39 DO SETLN("-----")
+40 DO SETLN("13. BAD RX's: NO PATIENT,DRUG or ISSUE DT (NO UPDATES): "_$$TOT(13))
+41 DO SETLN(" ")
+42 DO SETLN("14. TOTAL NUMBER OF PRESCRIPTIONS ANALYZED: "_$$TOT(14))
+43 DO SETLN(" ")
+44 DO SETLN("Up-arrow ('^') separated values (patients WITH ICN#):")
+45 SET EXCEL=PSOINST
FOR J=2:1:14
SET EXCEL=EXCEL_"^"_+$GET(^XTMP(NMSP,J))
+46 DO SETLN(EXCEL)
+47 DO SETLN(" ")
+48 DO SETLN("Up-arrow ('^') separated values (patients WITHOUT ICN#):")
+49 SET EXCEL=PSOINST
FOR J=102:1:112
SET EXCEL=EXCEL_"^"_+$GET(^XTMP(NMSP,J))
+50 DO SETLN(EXCEL_"^"_+$GET(^XTMP(NMSP,13))_"^"_+$GET(^XTMP(NMSP,14)))
+51 DO SETLN(" ")
+52 DO SETLN("Run Log:")
+53 DO SETLN("------------------------------------------------------------------------------")
+54 DO SETLN("SEQ DATE/TIME INITIATOR ACTION")
+55 DO SETLN("------------------------------------------------------------------------------")
+56 IF '$DATA(^XTMP(NMSP,"LOG"))
DO SETLN("No entries.")
+57 FOR J=1:1
if '$DATA(^XTMP(NMSP,"LOG",J))
QUIT
Begin DoDot:1
+58 SET Z=^XTMP(NMSP,"LOG",J)
+59 SET LOGLN=$JUSTIFY(J,3)
SET $EXTRACT(LOGLN,5)=$$FMTE^XLFDT(+Z,2)
+60 SET $EXTRACT(LOGLN,23)=$EXTRACT($$GET1^DIQ(200,$PIECE(Z,"^",2),.01),1,25)
SET $EXTRACT(LOGLN,50)=$PIECE(Z,"^",3)
+61 DO SETLN(LOGLN)
End DoDot:1
+62 DO SETLN("<END>")
+63 QUIT
+64 ;
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^PSO283PI"
SET ZTIO=""
+3 SET ZTDESC="Patch PSO*7*283 - Rx Expiration Date problem tally job (run >D ^PSO283PI)"
+4 LOCK -^XTMP(NMSP)
+5 SET PSODUZ=DUZ
SET ZTSAVE("PSODUZ")=""
+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 job status
+1 LOCK +^XTMP(NMSP):0
IF '$TEST
QUIT "R"
+2 LOCK -^XTMP(NMSP)
+3 IF '$DATA(^XTMP(NMSP,"STARTED"))
QUIT "N"
+4 IF $GET(^XTMP(NMSP,"COMPLETED"))
QUIT "C"
+5 QUIT "S"
+6 ;
CALCEXP ; CALCULATE THE 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 QUIT
+11 ;
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
