Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSO293P1

PSO293P1.m

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