source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSO293P1.m@ 1608

Last change on this file since 1608 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 5.5 KB
Line 
1PSO293P1 ;BIR/MFR-EXPIRATION DATE CLEAN UP (Cont.) ;01/13/08
2 ;;7.0;OUTPATIENT PHARMACY;**293**;DEC 1997;Build 22
3 ;External reference to ^PS(59.7 is supported by DBIA 694
4 ;
5MAIL ;
6 N PSOTX,XMY,XMDUZ,XMSUB,XMTEXT,DIFROM
7 S XMY($S($G(PSODUZ):PSODUZ,1:+$G(DUZ)))=""
8 S XMDUZ=.5
9 S XMSUB="Patch PSO*7*293 - Rx EXPIRATION DATE CLEAN UP"
10 I $$PROD^XUPROD() D
11 . S XMY("RUZBACKI.RON@FORUM.VA.GOV")=""
12 . S XMY("ANWER.MOHAMED@FORUM.VA.GOV")=""
13 . S XMY("WILLIAMSON.ERIC@FORUM.VA.GOV")=""
14 . S XMY("WILLETTE.CANDY@FORUM.VA.GOV")=""
15 . S XMY("CONSENTINO.ALBERT@FORUM.VA.GOV")=""
16 . S XMY("JONES.TRES@FORUM.VA.GOV")=""
17 . S XMY("BRUUN.JESSE@FORUM.VA.GO")=""
18 . S XMY("ROCHA.MARCELO@FORUM.VA.GOV")=""
19 D SETTXT
20 ;
21 S XMTEXT="PSOTX(" D ^XMD
22 Q
23 ;
24DISPLAY ; Displays the current results
25 N PSOINST,J,DIR,PSOTX,DIR
26 S PSOINST=$P($$SITE^VASITE(),"^",2)_" ("_+$$SITE^VASITE()_")"
27 D SETTXT W !
28 F J=1:1 Q:'$D(PSOTX(J)) D
29 . W !,PSOTX(J)
30 . I '(J#19) K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR
31 Q
32 ;
33SETTXT ; Set the PSOTXT array with the Mailman message or screen display
34 N EXCEL,J,Z,LINE,JOBSTS,STS,LOGLN,NMSP
35 S LINE=0,NMSP="PSO293PI"
36 D SETLN("Expiration Date clean up job for Outpatient Pharmacy prescriptions")
37 D SETLN("==================================================================")
38 S JOBSTS=$$JOBSTS()
39 S:JOBSTS="N" STS="NEVER RUN"
40 S:JOBSTS="S" STS="STOPPED ON "_$$FMTE^XLFDT($G(^XTMP(NMSP,"STOPPED")))
41 S:JOBSTS="R" STS="RUNNING"
42 S:JOBSTS="C" STS="COMPLETED ON "_$$FMTE^XLFDT($G(^XTMP(NMSP,"COMPLETED")))
43 S:JOBSTS="U" STS="UNKNOWN"
44 S:$G(^XTMP(NMSP,"LASTRX")) STS=STS_" (Last Rx IEN: "_+$G(^XTMP(NMSP,"LASTRX"))_")"
45 D SETLN("Current status: "_STS)
46 D SETLN("DATE AUTO-EXPIRE COMPLETED field: "_$$FMTE^XLFDT($$GET1^DIQ(59.7,1,49.95,"I")))
47 D SETLN(" ")
48 D SETLN("1. Institution : "_PSOINST)
49 D SETLN(" # of Rx's")
50 D SETLN("Group 1: RX'S WITH NO EXPIRATION DATE cleaned up")
51 D SETLN("------------------------------------- ----------")
52 D SETLN("2. Calc exp date > CUTOFF (update HDR) "_$$TOT(2))
53 D SETLN("3. Calc exp date < CUTOFF,CPRS active (update HDR/CPRS) "_$$TOT(3))
54 D SETLN("4. Calc exp date < CUTOFF,CPRS non-active (update HDR) "_$$TOT(4))
55 D SETLN("5. No CPRS order# (Update HDR) "_$$TOT(5))
56 D SETLN(" ")
57 D SETLN("Group 2: RX'S IN EXPIRED STATUS")
58 D SETLN("-------------------------------")
59 D SETLN("6. CPRS active (update CPRS/HDR) "_$$TOT(6))
60 D SETLN("7. Exp>366 days,reset date,CPRS order# (update CPRS/HDR) "_$$TOT(7))
61 D SETLN("8. Exp>366 days,reset date,no CPRS order# (update HDR) "_$$TOT(8))
62 D SETLN(" ")
63 D SETLN("Group 3: RX'S PAST EXPIRATION DATE BUT STILL ACTIVE")
64 D SETLN("---------------------------------------------------")
65 D SETLN("9. CPRS active (update CPRS/HDR) "_$$TOT(9))
66 D SETLN("10. CPRS DC'd or expired (update HDR) "_$$TOT(10))
67 D SETLN("11. No CPRS order# (HDR will run own update) "_$$TOT(11))
68 D SETLN(" ")
69 D SETLN("Group 4: RX's IN DELETED STATUS")
70 D SETLN("-------------------------------")
71 D SETLN("12. No CPRS order# (update HDR) "_$$TOT(12))
72 D SETLN(" ")
73 D SETLN("13. TOTAL NUMBER OF PRESCRIPTIONS ANALYZED: "_$$TOT(14))
74 D SETLN(" ")
75 D SETLN("Up-arrow ('^') separated values:")
76 S EXCEL=PSOINST F J=2:1:14 S EXCEL=EXCEL_"^"_+$G(^XTMP(NMSP,J))
77 D SETLN(EXCEL)
78 D SETLN(" ")
79 D SETLN("Run Log:")
80 D SETLN("------------------------------------------------------------------------------")
81 D SETLN("SEQ DATE/TIME INITIATOR ACTION")
82 D SETLN("------------------------------------------------------------------------------")
83 I '$D(^XTMP(NMSP,"LOG")) D SETLN("No entries.")
84 F J=1:1 Q:'$D(^XTMP(NMSP,"LOG",J)) D
85 . S Z=^XTMP(NMSP,"LOG",J)
86 . S LOGLN=$J(J,3),$E(LOGLN,5)=$$FMTE^XLFDT(+Z,2)
87 . S $E(LOGLN,23)=$E($$GET1^DIQ(200,$P(Z,"^",2),.01),1,25),$E(LOGLN,50)=$P(Z,"^",3)
88 . D SETLN(LOGLN)
89 D SETLN("<END>")
90 Q
91 ;
92SETLN(TEXT) ; Add a new line to the mailman message text
93 S LINE=$G(LINE)+1,PSOTX(LINE)=TEXT
94 Q
95 ;
96TOT(FLD) ; returns the field to be displayed
97 Q $J($FNUMBER(+$G(^XTMP(NMSP,FLD)),","),10)
98 ;
99JOB(ZTDTH) ; Queue the job to run
100 N ZTRTN,ZTIO,ZTDESC,ZTSK,PSODUZ,ZTSAVE
101 S ZTRTN="EN^PSO293PI",ZTIO=""
102 S ZTDESC="Patch PSO*7*293 - Rx Expiration Date Clean up job (run >D ^PSO293PI)"
103 L -^XTMP(NMSP)
104 S PSODUZ=DUZ,ZTSAVE("PSODUZ")="",ZTSAVE("ACTION")=""
105 D ^%ZTLOAD
106 I $D(ZTSK) D
107 . D LOG("QUEUED")
108 . H 2 D MES^XPDUTL("*** Task #"_ZTSK_" Queued! ***")
109 . D BMES^XPDUTL("")
110 . H 1
111 K XPDQUES
112 Q
113 ;
114JOBSTS() ; Returns the current clean up job status
115 L +^XTMP(NMSP):0 E Q "R"
116 L -^XTMP(NMSP)
117 I $D(^XTMP(NMSP,"STOPPED")) Q "S"
118 I '$D(^XTMP(NMSP,"STARTED")) Q "N"
119 I $G(^XTMP(NMSP,"COMPLETED")) Q "C"
120 Q "U"
121 ;
122SETEXP ; SET EXPIRATION DATE
123 N X,%DT,X1,X2,PSOARR,PSDEA,PSOCS,DA,QQ
124 K PSOARR D GETS^DIQ(50,DRUG_",","3","I","PSOARR")
125 S PSDEA=$G(PSOARR(50,DRUG_",",3,"I"))
126 S X1=ISSUEDT,X2=DAYSSUP*(NUMREFS+1)\1
127 S PSOCS=0
128 F QQ=1:1 Q:$E(PSDEA,QQ)="" I $E(+PSDEA,QQ)>1,$E(+PSDEA,QQ)<6 D I PSOCS Q
129 . S PSOCS=1
130 S X2=$S(DAYSSUP=X2:X2,+$G(PSOCS):184,1:366)
131 D C^%DTC S EXPIRDT=$P(X,".")
132 S DA=RXP
133 S DIE=52,DR="26///"_EXPIRDT D ^DIE K DIE,DR
134 D RXACT^PSOBPSU2(RXP,0,"EXPIRATION DATE "_$$FMTE^XLFDT(EXPIRDT,2)_" set by PSO*7*293","E",PSODUZ)
135 Q
136 ;
137LOG(COMMENT) ; Running Log
138 N LOGCNT
139 S LOGCNT=+$O(^XTMP(NMSP,"LOG",""),-1)+1
140 S ^XTMP(NMSP,"LOG",LOGCNT)=$$NOW^XLFDT()_"^"_$S($G(PSODUZ):PSODUZ,1:+$G(DUZ))_"^"_COMMENT
141 Q
Note: See TracBrowser for help on using the repository browser.