source: WorldVistAEHR/trunk/r/PHARMACY_PRESCRIPTION_PRACTICE-PPP/PPPMSC1.m@ 1154

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

initial load of WorldVistAEHR
File size: 4.2 KB
Line 
1PPPMSC1 ;ALB/DMB - MISC PPP UTILITIES ; 2/12/92
2 ;;V1.0;PHARMACY PRESCRIPTION PRACTICE;;APR 7,1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5LOGEVNT(EVNTCODE,ROUTINE,TEXT) ; Log an event to the log file
6 ;
7 N DIC,X,Y,PARMERR,FMERR,DTOUT,DUOUT
8 ;
9 S PARMERR=-9001
10 S FMERR=-9002
11 ;
12 ; Make sure the parameters are valid
13 ;
14 I '$D(^PPP(1020.6,"B",EVNTCODE)) S EVNTCODE=9999
15 I '$D(TEXT) S TEXT=""
16 I $D(TEXT),($L(TEXT))>245 Q PARMERR
17 I '$D(ROUTINE) S ROUTINE=""
18 ;
19 ; Update DT so it has the correct date.
20 ;
21 D NOW^%DTC S DT=X K %,%H,%I,X
22 ;
23 S DIC="^PPP(1020.4,"
24 S X=$O(^PPP(1020.6,"B",EVNTCODE,""))
25 S DIC(0)=""
26 I $D(TEXT) S DIC("DR")="4///"_ROUTINE_";5///"_TEXT
27 K DD,DO ; -- required by FILE^DICN call
28 D FILE^DICN
29 ;
30 I (Y=-1)!($D(DTOUT))!($D(DUOUT)) Q FMERR
31 Q 0
32 ;
33STATUPDT(CODE,INCRMNT) ; Update statistics in stat file.
34 ;
35 ; This function is used to increment a specific statistic
36 ; by the amount passed in INCRMNT. The statistics are currently
37 ; referenced by the FileMan field number. They are currently
38 ; defined as follows:
39 ;
40 ; 2 - Total PDX's Sent
41 ; 3 - Total Alerts Issued
42 ; 4 - Total Alerts Ignored
43 ; 5 - Total Manual Entries Added
44 ; 6 - Total Entries Deleted
45 ; 7 - Total Entries Edited
46 ; 8 - Total New Patients Added
47 ; 9 - Total FMP's Viewed/Printed
48 ;
49 ; Return Values:
50 ;
51 ; 0 - Normal Termination
52 ; -9001 - Input Parameter Error
53 ; -9002 - Fileman Error
54 ;
55 N DA,DIC,DIE,DIDEL,DIQ,DR,ERR,PPPTMP,VAL,PARMERR,FMERR,PPPTMP
56 ;
57 S PARMERR=-9001
58 S FMERR=-9002
59 S ERR=0
60 ;
61 I '$D(CODE)!('$D(INCRMNT)) Q PARMERR
62 I CODE<2!(CODE>9) Q PARMERR
63 I '$D(INCRMNT) Q PARMERR
64 I INCRMNT'>0 Q PARMERR
65 ;
66 ; Get the current value of the statistic
67 ;
68 S DIC=1020.3
69 S DR=CODE
70 S DA=1
71 S DIQ="PPPTMP"
72 S DIQ(0)="I"
73 D EN^DIQ1
74 I $D(PPPTMP) D
75 .S VAL=PPPTMP(1020.3,DA,CODE,"I")
76 .S VAL=VAL+INCRMNT
77 .S DIE="^PPP(1020.3,"
78 .S DR=CODE_"///"_VAL
79 .D ^DIE
80 .I $D(DTOUT) S ERR=FMERR
81 E S ERR=FMERR
82 Q:ERR ERR
83 Q 0
84 ;
85CLRSTAT ; Set all statistics to 0
86 ;
87 N DA,DIE,DR,ERR,FMERR
88 N DIR,Y
89 ;
90 S FMERR=-9002
91 ;
92 I '$D(^PPP(1020.3)) D Q
93 .W !,"Error... PPP STATISTIC file missing"
94 S DIR(0)="YA"
95 S DIR("A")="Clear entries in PPP STATISTICS file: "
96 S DIR("B")="NO"
97 S DIR("?")="Enter yes to zero out entries in file."
98 D ^DIR
99 I Y D CLR1
100 E W !!,"PPP STATISTICS file unchanged"
101 ;
102 R !,"Press <RETURN> to continue...",PPPX:DTIME K PPPX
103 Q
104 ;
105CLR1 ; -- Clears statistics
106 I $D(^PPP(1020.3,1)) D
107 .S DIK="^PPP(1020.3,"
108 .S DA=1
109 .D ^DIK
110 ;
111 S ERR=0
112 S DIC="^PPP(1020.3,"
113 S X=1
114 S DIC(0)=""
115 S DIC("DR")="1///NOW;2///0;3///0;4///0;5///0;6///0;7///0;8///0;9///0"
116 K DD,DO ; -- required by FILE^DICN call
117 D FILE^DICN
118 I +Y=1 W !!,"All Statistics Set To 0."
119 E W !,"Error... Could not create entry in statistics file."
120 Q
121 ;
122SNDBLTN(MSGSUB,MSGFROM,MSGTXT) ; Send a message
123 ;
124 ; This function will send a message via mailman.
125 ;
126 ; Parameters:
127 ; MSGSUB - The subject of the message.
128 ; MSGFROM - The sender of the message. If this field is
129 ; not defined or NULL, the current DUZ is used.
130 ; MSGTXT - The array name which contains the text
131 ; of the message.
132 ;
133 ; Returns:
134 ; 0 - Normal Termination
135 ; -9001 - Input Parameter Error
136 ;
137 N PARMERR,BULLERR,GRPERR,XMDUZ,XMTEXT,Y,ERR
138 ;
139 S PARMERR=-9001
140 S GRPERR=-9016
141 ;
142 I '$D(MSGSUB) Q PARMERR
143 I MSGSUB="" Q PARMERR
144 S XMSUB=MSGSUB
145 ;
146 I '$D(MSGFROM) S MSGFROM=""
147 I MSGFROM="" S XMDUZ=.5
148 I MSGFROM'="" S XMDUZ=MSGFROM
149 ;
150 I $D(MSGTXT) S XMTEXT=MSGTXT
151 ;
152 S ERR=$$GETMBRS("PRESCRIPTION PRACTICES","XMY")
153 I ERR<1 Q GRPERR
154 ;
155 S XMCHAN=1 ; -- Silents all interactive feed back
156 D ^XMD
157 D KILL^XM
158 K XMCHAN
159 Q 0
160 ;
161GETMBRS(MAILGRP,ARRAY) ; Get the members of a mail group
162 ;
163 ; Parameters:
164 ; MAILGRP - The name of the group without the 'G.'
165 ; ARRAY - The name of the array where you want the names stored.
166 ;
167 ; Returns:
168 ; The number of members found or a negative error code.
169 ;
170 N PARMERR,GRPERR,MGIFN,MEMBER,TMEMBER
171 ;
172 S PARMERR=-9001
173 S GRPERR=-9016
174 S TMEMBER=0
175 ;
176 I '$D(PARMERR) Q PARMERR
177 I '$D(ARRAY) Q PARMERR
178 I $L(MAILGRP)=""!($L(ARRAY)="") Q PARMERR
179 ;
180 S MGIFN=$O(^XMB(3.8,"B",MAILGRP,"")) Q:MGIFN="" GRPERR
181 ;
182 S MEMBER=""
183 F I=0:0 D Q:MEMBER=""
184 .S MEMBER=$O(^XMB(3.8,MGIFN,1,"B",MEMBER)) Q:MEMBER=""
185 .S @ARRAY@(MEMBER)=""
186 .S TMEMBER=TMEMBER+1
187 Q TMEMBER
Note: See TracBrowser for help on using the repository browser.