source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSO283P1.m@ 738

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

initial load of WorldVistAEHR
File size: 5.7 KB
Line 
1PSO283P1 ;BIR/MFR-EXPIRATION DATE PROBLEM TALLY (Cont.) ;05/03/07
2 ;;7.0;OUTPATIENT PHARMACY;**283**;DEC 1997;Build 28
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*283 - Rx EXPIRATION DATE PROBLEM TALLY"
10 S XMY("RUZBACKI.RON@FORUM.VA.GOV")=""
11 S XMY("ANWER.MOHAMED@FORUM.VA.GOV")=""
12 S XMY("WILLIAMSON.ERIC@FORUM.VA.GOV")=""
13 S XMY("WILLETTE.CANDY@FORUM.VA.GOV")=""
14 S XMY("ROCHA.MARCELO@FORUM.VA.GOV")=""
15 S XMY("BARRON.LUANNE@FORUM.VA.GOV")=""
16 S XMY("JONES.TRES@FORUM.VA.GOV")=""
17 D SETTXT
18 ;
19 S XMTEXT="PSOTX(" D ^XMD
20 Q
21 ;
22DISPLAY ; Displays the current results
23 N PSOINST,J,DIR,PSOTX,DIR
24 S PSOINST=$P($$SITE^VASITE(),"^",2)_" ("_+$$SITE^VASITE()_")"
25 D SETTXT W !
26 F J=1:1 Q:'$D(PSOTX(J)) D
27 . W !,PSOTX(J)
28 . I '(J#19) K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR
29 Q
30 ;
31SETTXT ; Set the PSOTXT array with the Mailman message or screen display
32 N EXCEL,J,Z,LINE,JOBSTS,STS,LOGLN,NMSP
33 S LINE=0,NMSP="PSO283PI"
34 D SETLN("Expiration Date problem tally patch for Outpatient Pharmacy prescriptions")
35 D SETLN("=========================================================================")
36 S JOBSTS=$$JOBSTS()
37 S:JOBSTS="N" STS="NEVER RUN"
38 S:JOBSTS="S" STS="STOPPED ON "_$$FMTE^XLFDT($G(^XTMP(NMSP,"STOPPED")))
39 S:JOBSTS="R" STS="RUNNING"
40 S:JOBSTS="C" STS="COMPLETED ON "_$$FMTE^XLFDT($G(^XTMP(NMSP,"COMPLETED")))
41 S:$G(^XTMP(NMSP,"LASTRX")) STS=STS_" (Last Rx IEN: "_$G(^XTMP(NMSP,"LASTRX"))_")"
42 D SETLN("Current status: "_STS)
43 D SETLN(" ")
44 D SETLN("1. Institution : "_PSOINST)
45 D SETLN(" PATIENTS")
46 D SETLN("Group 1: RX'S WITH NO EXPIRATION DATE WITH ICN# W/NO ICN#")
47 D SETLN("------------------------------------- ---------- ----------")
48 D SETLN("2. Calc exp date > CUTOFF (update HDR) "_$$TOT(2)_" "_$$TOT(102))
49 D SETLN("3. Calc exp date < CUTOFF,CPRS active (update HDR/CPRS) "_$$TOT(3)_" "_$$TOT(103))
50 D SETLN("4. Calc exp date < CUTOFF,CPRS non-active (update HDR) "_$$TOT(4)_" "_$$TOT(104))
51 D SETLN("5. No CPRS order# (Update HDR) "_$$TOT(5)_" "_$$TOT(105))
52 D SETLN(" ")
53 D SETLN("Group 2: RX'S IN EXPIRED STATUS")
54 D SETLN("-------------------------------")
55 D SETLN("6. CPRS active (update CPRS/HDR) "_$$TOT(6)_" "_$$TOT(106))
56 D SETLN("7. Exp>366 days,reset date,CPRS order# (update CPRS/HDR)"_$$TOT(7)_" "_$$TOT(107))
57 D SETLN("8. Exp>366 days,reset date,no CPRS order# (update HDR) "_$$TOT(8)_" "_$$TOT(108))
58 D SETLN(" ")
59 D SETLN("Group 3: RX'S PAST EXPIRATION DATE BUT STILL ACTIVE")
60 D SETLN("---------------------------------------------------")
61 D SETLN("9. CPRS active (update CPRS/HDR) "_$$TOT(9)_" "_$$TOT(109))
62 D SETLN("10. CPRS DC'd or expired (update HDR) "_$$TOT(10)_" "_$$TOT(110))
63 D SETLN("11. No CPRS order# (HDR will run own update) "_$$TOT(11)_" "_$$TOT(111))
64 D SETLN(" ")
65 D SETLN("Group 4: RX's IN DELETED STATUS")
66 D SETLN("-------------------------------")
67 D SETLN("12. No CPRS order# (update HDR) "_$$TOT(12)_" "_$$TOT(112))
68 D SETLN(" ")
69 D SETLN("OTHER")
70 D SETLN("-----")
71 D SETLN("13. BAD RX's: NO PATIENT,DRUG or ISSUE DT (NO UPDATES): "_$$TOT(13))
72 D SETLN(" ")
73 D SETLN("14. TOTAL NUMBER OF PRESCRIPTIONS ANALYZED: "_$$TOT(14))
74 D SETLN(" ")
75 D SETLN("Up-arrow ('^') separated values (patients WITH ICN#):")
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("Up-arrow ('^') separated values (patients WITHOUT ICN#):")
80 S EXCEL=PSOINST F J=102:1:112 S EXCEL=EXCEL_"^"_+$G(^XTMP(NMSP,J))
81 D SETLN(EXCEL_"^"_+$G(^XTMP(NMSP,13))_"^"_+$G(^XTMP(NMSP,14)))
82 D SETLN(" ")
83 D SETLN("Run Log:")
84 D SETLN("------------------------------------------------------------------------------")
85 D SETLN("SEQ DATE/TIME INITIATOR ACTION")
86 D SETLN("------------------------------------------------------------------------------")
87 I '$D(^XTMP(NMSP,"LOG")) D SETLN("No entries.")
88 F J=1:1 Q:'$D(^XTMP(NMSP,"LOG",J)) D
89 . S Z=^XTMP(NMSP,"LOG",J)
90 . S LOGLN=$J(J,3),$E(LOGLN,5)=$$FMTE^XLFDT(+Z,2)
91 . S $E(LOGLN,23)=$E($$GET1^DIQ(200,$P(Z,"^",2),.01),1,25),$E(LOGLN,50)=$P(Z,"^",3)
92 . D SETLN(LOGLN)
93 D SETLN("<END>")
94 Q
95 ;
96SETLN(TEXT) ; Add a new line to the mailman message text
97 S LINE=$G(LINE)+1,PSOTX(LINE)=TEXT
98 Q
99 ;
100TOT(FLD) ; returns the field to be displayed
101 Q $J($FNUMBER(+$G(^XTMP(NMSP,FLD)),","),10)
102 ;
103JOB(ZTDTH) ; Queue the job to run
104 N ZTRTN,ZTIO,ZTDESC,ZTSK,PSODUZ,ZTSAVE
105 S ZTRTN="EN^PSO283PI",ZTIO=""
106 S ZTDESC="Patch PSO*7*283 - Rx Expiration Date problem tally job (run >D ^PSO283PI)"
107 L -^XTMP(NMSP)
108 S PSODUZ=DUZ,ZTSAVE("PSODUZ")=""
109 D ^%ZTLOAD
110 I $D(ZTSK) D
111 . D LOG("QUEUED")
112 . H 2 D MES^XPDUTL("*** Task #"_ZTSK_" Queued! ***")
113 . D BMES^XPDUTL("")
114 . H 1
115 K XPDQUES
116 Q
117 ;
118JOBSTS() ; Returns the current job status
119 L +^XTMP(NMSP):0 E Q "R"
120 L -^XTMP(NMSP)
121 I '$D(^XTMP(NMSP,"STARTED")) Q "N"
122 I $G(^XTMP(NMSP,"COMPLETED")) Q "C"
123 Q "S"
124 ;
125CALCEXP ; CALCULATE THE EXPIRATION DATE
126 N X,%DT,X1,X2,PSOARR,PSDEA,PSOCS,DA,QQ
127 K PSOARR D GETS^DIQ(50,DRUG_",","3","I","PSOARR")
128 S PSDEA=$G(PSOARR(50,DRUG_",",3,"I"))
129 S X1=ISSUEDT,X2=DAYSSUP*(NUMREFS+1)\1
130 S PSOCS=0
131 F QQ=1:1 Q:$E(PSDEA,QQ)="" I $E(+PSDEA,QQ)>1,$E(+PSDEA,QQ)<6 D I PSOCS Q
132 . S PSOCS=1
133 S X2=$S(DAYSSUP=X2:X2,+$G(PSOCS):184,1:366)
134 D C^%DTC S EXPIRDT=$P(X,".")
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.