source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSO293PI.m@ 1553

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

initial load of FOIAVistA 6/30/08 version
File size: 7.9 KB
Line 
1PSO293PI ;BIR/MFR-EXPIRATION DATE CLEAN UP ;05/03/07
2 ;;7.0;OUTPATIENT PHARMACY;**293**;DEC 1997;Build 22
3 ;External references ^DPT supported by DBIA 10035
4 ;External reference to STATUS^ORQOR2 is supported by DBIA 3458
5 ;External reference to ^PS(59.7 is supported by DBIA 694
6 N NMSP,JOBSTS,DIR,DIRUT,DIROUT,DTOUT,DUOUT,X,Y,ACTION,EXPJOBDT,PSODUZ
7 S NMSP="PSO293PI"
8 ;
9 S JOBSTS=$$JOBSTS^PSO293P1()
10 ;
11 W !?5,"Expiration Date clean up job for Outpatient Pharamcy prescriptions"
12 W !?5,"=================================================================="
13 W !?5,"Current status: "
14 W:JOBSTS="N" "NEVER RUN"
15 W:JOBSTS="S" "STOPPED ON "_$$FMTE^XLFDT($G(^XTMP(NMSP,"STOPPED")))
16 W:JOBSTS="R" "RUNNING"
17 W:JOBSTS="C" "COMPLETED ON "_$$FMTE^XLFDT($G(^XTMP(NMSP,"COMPLETED")))
18 W:JOBSTS="U" "UNKNOWN"
19 W:$G(^XTMP(NMSP,"LASTRX")) " (Last Rx IEN: "_+$G(^XTMP(NMSP,"LASTRX"))_")"
20 ;
21 S DIR(0)="SO^",DIR("A")=""
22 I JOBSTS="N" D
23 .S DIR(0)=DIR(0)_"ST:START CLEAN UP JOB;",DIR("A")=DIR("A")_"(ST)Start,",DIR("B")="START"
24 I JOBSTS="S" D
25 . S DIR(0)=DIR(0)_"RE:RESUME CLEAN UP JOB;",DIR("A")=DIR("A")_"(RE)Resume,"
26 I JOBSTS="R" D
27 . S DIR(0)=DIR(0)_"SP:STOP CLEAN UP JOB;",DIR("A")=DIR("A")_"(SP)Stop,"
28 I JOBSTS="C" D
29 . S DIR(0)=DIR(0)_"RR:RE-RUN CLEAN UP JOB;",DIR("A")=DIR("A")_"(RR)Re-run,"
30 S DIR(0)=DIR(0)_"VW:VIEW "_$S(JOBSTS'="C":"PARTIAL ",1:"")_"CLEAN UP JOB RESULTS;"
31 S DIR("A")=DIR("A")_"(VW)View,",DIR("B")="VIEW"
32 S DIR(0)=DIR(0)_"QT:QUIT",DIR("A")=DIR("A")_"(QT)Quit"
33 D ^DIR I $D(DIRUT)!$D(DIROUT)!$D(DTOUT)!$D(DUOUT) G QUIT
34 S ACTION=Y
35 ;
36 I ACTION="SP" W !!,"This may take a few minutes, please wait..." D G QUIT
37 . N TIME,UNABLE
38 . S ^XTMP(NMSP,"STOP")=1,(TIME,UNABLE)=0
39 . F Q:$D(^XTMP(NMSP,"STOPPED")) D Q:UNABLE
40 . . H 1 S TIME=TIME+1
41 . . I '$D(^XTMP(NMSP,"STOPPED")) D
42 . . . I $D(^XTMP(NMSP,"COMPLETED"))!($$JOBSTS^PSO293P1()'="R")!(TIME>600) S UNABLE=1
43 ;
44 I ACTION="QT" G QUIT
45 I ACTION="VW" D DISPLAY^PSO293P1 G QUIT
46 ;
47 D JOB^PSO293P1()
48 Q
49 ;
50PI ; Post-Install entry point
51 N EXPJOBDT,NMSP
52 S NMSP="PSO293PI"
53 D LOG^PSO293P1("PATCH INSTALLATION")
54 S EXPJOBDT=$$GET1^DIQ(59.7,1,49.95,"I")
55 I 'EXPJOBDT D
56 . S EXPJOBDT=$$FMADD^XLFDT($$DT^XLFDT(),-2)
57 . S $P(^PS(59.7,1,49.99),"^",8)=EXPJOBDT
58 . D LOG^PSO293P1("DATE AUTO-EXPIRE set: "_$$FMTE^XLFDT(EXPJOBDT,2))
59 S ^XTMP(NMSP,"EXPJOBDT")=EXPJOBDT
60 ;
61 D JOB^PSO293P1($$NOW^XLFDT())
62 Q
63 ;
64EN ;
65 N NMSP,PSOINST,CUTOFF,PSOACT,RXP,STOP,PSOINACT,PATIENT,COUNTER,RXP,DRUG,STATUS
66 N ISSUEDT,EXPIRDT,BADRXCNT,DAYSSUP,NUMREFS,PSOPROD,LASTCNT,I
67 ;
68 S NMSP="PSO293PI" I '$G(PSODUZ) S PSODUZ=+$G(DUZ)
69 ;
70 ; - If can't get Lock, then already running.
71 L +^XTMP(NMSP):5 I '$T D LOG^PSO293P1("UNSUCCESSFUL (LOCKED)") G QUIT
72 ;
73 D SETXTMP
74 ;
75 I '$G(DT) S DT=$$DT^XLFDT
76 S PSOPROD=$$PROD^XUPROD()
77 ;
78 S PSOINST=$P($$SITE^VASITE(),"^",2)_" ("_+$$SITE^VASITE()_")"
79 S CUTOFF=$$GET1^DIQ(59.7,1,49.95,"I") I 'CUTOFF S CUTOFF=$$FMADD^XLFDT(DT,-2)
80 S PSOINACT=",11,12,13,14,15,"
81 S RXP=+$G(^XTMP(NMSP,"LASTRX"))
82 I $G(ACTION)="RE" D
83 . F I=2:1:12,14 S BADRXCNT(14)=+$G(^XTMP(NMSP,I))
84 S LASTCNT=+$G(BADRXCNT(14)),STOP=0
85 F COUNTER=LASTCNT:1 S RXP=$O(^PSRX(RXP)) Q:'RXP D Q:STOP
86 . S:'(COUNTER#10000) DT=$$DT^XLFDT()
87 . S PATIENT=$P($G(^PSRX(RXP,0)),"^",2)
88 . S DRUG=$P($G(^PSRX(RXP,0)),"^",6)
89 . S STATUS=$P($G(^PSRX(RXP,"STA")),"^")
90 . S ISSUEDT=$P($G(^PSRX(RXP,0)),"^",13)
91 . S DAYSSUP=$P($G(^PSRX(RXP,0)),"^",8)
92 . S NUMREFS=$P($G(^PSRX(RXP,0)),"^",9)
93 . S EXPIRDT=$P($G(^PSRX(RXP,2)),"^",6)
94 . S BADRXCNT(14)=$G(BADRXCNT(14))+1
95 . S BADRXCNT("LASTRX")=RXP_"^"_COUNTER
96 . ;--- SKIP bad Rx's
97 . I ('PATIENT!'DRUG) Q
98 . I '$D(^DPT(PATIENT))!('$D(^PSDRUG(DRUG))) Q
99 . I 'ISSUEDT Q
100 . ;---
101 . D SET
102 . ;---
103 . I '(COUNTER#5000) D
104 . . M ^XTMP(NMSP)=BADRXCNT
105 . . I $G(^XTMP(NMSP,"STOP")) S STOP=1
106 ;
107 I STOP D STOP G QUIT
108 ;
109 M ^XTMP(NMSP)=BADRXCNT
110 S ^XTMP(NMSP,"COMPLETED")=$$NOW^XLFDT()
111 K ^XTMP(NMSP,"LASTRX")
112 D LOG^PSO293P1("COMPLETED")
113 D MAIL^PSO293P1
114 ;
115QUIT ;
116 L -^XTMP(NMSP)
117 Q
118 ;
119STOP ;
120 K ^XTMP(NMSP,"STOP")
121 S ^XTMP(NMSP,"STOPPED")=$$NOW^XLFDT()
122 D LOG^PSO293P1("STOPPED")
123 D MAIL^PSO293P1
124 Q
125 ;
126SET ;
127 N CPRSDC,CPRSTA,NEWEXPDT,DA,DIE,ORN,DR
128 S CPRSDC=",1,7,12,13,"
129 ;
130 ; --- No expiration date on PRESCRIPTION file (#52)
131 I EXPIRDT="" D Q
132 . S ORN=$$CPRSNUM(RXP),CPRSTA=$P(ORN,"^",2),ORN=+ORN
133 . D SETEXP^PSO293P1 I '$G(EXPIRDT) Q
134 . I EXPIRDT>CUTOFF D Q ; Expiration Date past Cutoff (will be exp. by auto exp. job), Quit
135 . . S BADRXCNT(2)=$G(BADRXCNT(2))+1,^XTMP(NMSP,2,RXP)=""
136 . . D SENDHDR
137 . I PSOINACT'[(","_STATUS_",") D ; Foce expiration of Rx (Past Exp. Date)
138 . . S DA=RXP,DIE=52,DR="100///11",STATUS=11
139 . . D ^DIE K DIE,DR
140 . . D RXACT^PSOBPSU2(RXP,0,"Rx status set to EXPIRED by PSO*7*293","E",PSODUZ)
141 . I ORN D Q ; Rx is expired in CPRS (Update HDR with Exp. Date), Quit
142 . . I CPRSDC'[(","_CPRSTA_","),'$D(^PS(52.41,"AQ",RXP)) D Q
143 . . . S BADRXCNT(3)=$G(BADRXCNT(3))+1,^XTMP(NMSP,3,RXP)=""
144 . . . D SENDCPRS()
145 . . S BADRXCNT(4)=$G(BADRXCNT(4))+1,^XTMP(NMSP,4,RXP)=""
146 . . D SENDHDR
147 . I 'ORN D ; No CPRS Order # (Update HDR with Exp. Date)
148 . . S BADRXCNT(5)=$G(BADRXCNT(5))+1,^XTMP(NMSP,5,RXP)=""
149 . . D SENDHDR
150 ;
151 ; --- Rx is expired. Update CPRS and HDR if necessary
152 I STATUS=11 D Q
153 . S ORN=$$CPRSNUM(RXP),CPRSTA=$P(ORN,"^",2),ORN=+ORN
154 . S NEWEXPDT=0
155 . I $$FMDIFF^XLFDT(EXPIRDT,ISSUEDT,1)>366 D ; Expiration Date is > 366, Recalculate new Date
156 . . S NEWEXPDT=1 D SETEXP^PSO293P1
157 . I ORN,CPRSDC'[(","_CPRSTA_","),'$D(^PS(52.41,"AQ",RXP)) D ; Rx is not expired in CPRS (Update CPRS/HDR with Exp. Date), Quit
158 . . I 'NEWEXPDT S BADRXCNT(6)=$G(BADRXCNT(6))+1,^XTMP(NMSP,6,RXP)=""
159 . . I NEWEXPDT S BADRXCNT(7)=$G(BADRXCNT(7))+1,^XTMP(NMSP,7,RXP)=""
160 . . D SENDCPRS()
161 . I 'NEWEXPDT Q ; Expiration Date was not recalculated, don't send to HDR
162 . S BADRXCNT(8)=$G(BADRXCNT(8))+1,^XTMP(NMSP,8,RXP)=""
163 . D SENDHDR
164 ;
165 I EXPIRDT<CUTOFF,(PSOINACT'[(","_STATUS_",")) D ; Rx is past exp. date but is still on a non-Expired/DC'd status
166 . S DA=RXP ; Note: Rx's expiring on or after the CUTOFF will be picked up
167 . S DIE=52,DR="100///11",STATUS=11 ; by the Auto Expiration Job.
168 . D ^DIE K DIE,DR
169 . D RXACT^PSOBPSU2(RXP,0,"Rx status set to EXPIRED by PSO*7*293","E",PSODUZ)
170 . S ORN=$$CPRSNUM(RXP),CPRSTA=$P(ORN,"^",2),ORN=+ORN
171 . I ORN,CPRSDC'[(","_CPRSTA_",") D Q ; Update CPRS if necessary, this will also call HDR
172 . . S BADRXCNT(9)=$G(BADRXCNT(9))+1,^XTMP(NMSP,9,RXP)=""
173 . . D SENDCPRS()
174 . I ORN D Q ; If CPRS was not updated, call HDR if there is an Order #
175 . . S BADRXCNT(10)=$G(BADRXCNT(10))+1,^XTMP(NMSP,10,RXP)=""
176 . . D SENDHDR
177 . I 'ORN D ; If no CPRS Order #, just report (no updates to CPRS/HDR)
178 . . S BADRXCNT(11)=$G(BADRXCNT(11))+1
179 . . S ^XTMP(NMSP,11,RXP)=""
180 ;
181 I STATUS=13 D Q
182 . S ORN=+$$CPRSNUM(RXP)
183 . I 'ORN D
184 . . S BADRXCNT(12)=$G(BADRXCNT(12))+1,^XTMP(NMSP,12,RXP)=""
185 . . D SENDHDR
186 Q
187 ;
188CPRSNUM(RXP) ;
189 N ORN,STA
190 S ORN=$P($G(^PSRX(RXP,"OR1")),"^",2),STA=""
191 I ORN S STA=+$$STATUS^ORQOR2(ORN) I STA=0 S ORN=""
192 Q (ORN_"^"_STA)
193 ;
194SETXTMP ; - Initialize the XTMP global
195 I $D(^XTMP(NMSP,"STARTED")) D
196 . S ^XTMP(NMSP,"RE-STARTED")=$$NOW^XLFDT() D LOG^PSO293P1("RESUMED")
197 I '$D(^XTMP(NMSP,"STARTED")) D
198 . S ^XTMP(NMSP,"STARTED")=$$NOW^XLFDT() D LOG^PSO293P1("STARTED")
199 K ^XTMP(NMSP,"STOP"),^XTMP(NMSP,"STOPPED")
200 S ^XTMP(NMSP,0)=$$FMADD^XLFDT($$NOW^XLFDT(),730)_"^"_$$NOW^XLFDT()_"^PSO*7*293 - RX EXPIRATION DATE CLEAN UP"
201 Q
202 ;
203SENDCPRS(CPRSONLY) ; Update CPRS/HDR
204 N PSOSSMES,TYPE,STS,STSCOM
205 S:$G(CPRSONLY) PSOSSMES="CPRSUP"
206 ;
207 S TYPE="SC",STS="DC",STSCOM="Discontinued"
208 I STATUS=11 S $P(^PSRX(RXP,0),"^",19)=1,STS="ZE",STSCOM="Expired"
209 I STATUS=13 S TYPE="OC",STS="",STSCOM="Deleted"
210 I STATUS=14 S TYPE="OD",STS="RP",STSCOM="Discontinued/Edited"
211 D EN^PSOHLSN1(RXP,TYPE,STS,"Prescription is "_STSCOM_".")
212 Q
213 ;
214SENDHDR ; Update HDR only
215 D:$G(PSOPROD) EN^PSOHDR("PRES",RXP)
216 Q
Note: See TracBrowser for help on using the repository browser.