- 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 Feb 18, 2025@23:49:08 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