188 lines
4.2 KiB
Mathematica
188 lines
4.2 KiB
Mathematica
PPPMSC1 ;ALB/DMB - MISC PPP UTILITIES ; 2/12/92
|
|
;;V1.0;PHARMACY PRESCRIPTION PRACTICE;;APR 7,1995
|
|
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
;
|
|
LOGEVNT(EVNTCODE,ROUTINE,TEXT) ; Log an event to the log file
|
|
;
|
|
N DIC,X,Y,PARMERR,FMERR,DTOUT,DUOUT
|
|
;
|
|
S PARMERR=-9001
|
|
S FMERR=-9002
|
|
;
|
|
; Make sure the parameters are valid
|
|
;
|
|
I '$D(^PPP(1020.6,"B",EVNTCODE)) S EVNTCODE=9999
|
|
I '$D(TEXT) S TEXT=""
|
|
I $D(TEXT),($L(TEXT))>245 Q PARMERR
|
|
I '$D(ROUTINE) S ROUTINE=""
|
|
;
|
|
; Update DT so it has the correct date.
|
|
;
|
|
D NOW^%DTC S DT=X K %,%H,%I,X
|
|
;
|
|
S DIC="^PPP(1020.4,"
|
|
S X=$O(^PPP(1020.6,"B",EVNTCODE,""))
|
|
S DIC(0)=""
|
|
I $D(TEXT) S DIC("DR")="4///"_ROUTINE_";5///"_TEXT
|
|
K DD,DO ; -- required by FILE^DICN call
|
|
D FILE^DICN
|
|
;
|
|
I (Y=-1)!($D(DTOUT))!($D(DUOUT)) Q FMERR
|
|
Q 0
|
|
;
|
|
STATUPDT(CODE,INCRMNT) ; Update statistics in stat file.
|
|
;
|
|
; This function is used to increment a specific statistic
|
|
; by the amount passed in INCRMNT. The statistics are currently
|
|
; referenced by the FileMan field number. They are currently
|
|
; defined as follows:
|
|
;
|
|
; 2 - Total PDX's Sent
|
|
; 3 - Total Alerts Issued
|
|
; 4 - Total Alerts Ignored
|
|
; 5 - Total Manual Entries Added
|
|
; 6 - Total Entries Deleted
|
|
; 7 - Total Entries Edited
|
|
; 8 - Total New Patients Added
|
|
; 9 - Total FMP's Viewed/Printed
|
|
;
|
|
; Return Values:
|
|
;
|
|
; 0 - Normal Termination
|
|
; -9001 - Input Parameter Error
|
|
; -9002 - Fileman Error
|
|
;
|
|
N DA,DIC,DIE,DIDEL,DIQ,DR,ERR,PPPTMP,VAL,PARMERR,FMERR,PPPTMP
|
|
;
|
|
S PARMERR=-9001
|
|
S FMERR=-9002
|
|
S ERR=0
|
|
;
|
|
I '$D(CODE)!('$D(INCRMNT)) Q PARMERR
|
|
I CODE<2!(CODE>9) Q PARMERR
|
|
I '$D(INCRMNT) Q PARMERR
|
|
I INCRMNT'>0 Q PARMERR
|
|
;
|
|
; Get the current value of the statistic
|
|
;
|
|
S DIC=1020.3
|
|
S DR=CODE
|
|
S DA=1
|
|
S DIQ="PPPTMP"
|
|
S DIQ(0)="I"
|
|
D EN^DIQ1
|
|
I $D(PPPTMP) D
|
|
.S VAL=PPPTMP(1020.3,DA,CODE,"I")
|
|
.S VAL=VAL+INCRMNT
|
|
.S DIE="^PPP(1020.3,"
|
|
.S DR=CODE_"///"_VAL
|
|
.D ^DIE
|
|
.I $D(DTOUT) S ERR=FMERR
|
|
E S ERR=FMERR
|
|
Q:ERR ERR
|
|
Q 0
|
|
;
|
|
CLRSTAT ; Set all statistics to 0
|
|
;
|
|
N DA,DIE,DR,ERR,FMERR
|
|
N DIR,Y
|
|
;
|
|
S FMERR=-9002
|
|
;
|
|
I '$D(^PPP(1020.3)) D Q
|
|
.W !,"Error... PPP STATISTIC file missing"
|
|
S DIR(0)="YA"
|
|
S DIR("A")="Clear entries in PPP STATISTICS file: "
|
|
S DIR("B")="NO"
|
|
S DIR("?")="Enter yes to zero out entries in file."
|
|
D ^DIR
|
|
I Y D CLR1
|
|
E W !!,"PPP STATISTICS file unchanged"
|
|
;
|
|
R !,"Press <RETURN> to continue...",PPPX:DTIME K PPPX
|
|
Q
|
|
;
|
|
CLR1 ; -- Clears statistics
|
|
I $D(^PPP(1020.3,1)) D
|
|
.S DIK="^PPP(1020.3,"
|
|
.S DA=1
|
|
.D ^DIK
|
|
;
|
|
S ERR=0
|
|
S DIC="^PPP(1020.3,"
|
|
S X=1
|
|
S DIC(0)=""
|
|
S DIC("DR")="1///NOW;2///0;3///0;4///0;5///0;6///0;7///0;8///0;9///0"
|
|
K DD,DO ; -- required by FILE^DICN call
|
|
D FILE^DICN
|
|
I +Y=1 W !!,"All Statistics Set To 0."
|
|
E W !,"Error... Could not create entry in statistics file."
|
|
Q
|
|
;
|
|
SNDBLTN(MSGSUB,MSGFROM,MSGTXT) ; Send a message
|
|
;
|
|
; This function will send a message via mailman.
|
|
;
|
|
; Parameters:
|
|
; MSGSUB - The subject of the message.
|
|
; MSGFROM - The sender of the message. If this field is
|
|
; not defined or NULL, the current DUZ is used.
|
|
; MSGTXT - The array name which contains the text
|
|
; of the message.
|
|
;
|
|
; Returns:
|
|
; 0 - Normal Termination
|
|
; -9001 - Input Parameter Error
|
|
;
|
|
N PARMERR,BULLERR,GRPERR,XMDUZ,XMTEXT,Y,ERR
|
|
;
|
|
S PARMERR=-9001
|
|
S GRPERR=-9016
|
|
;
|
|
I '$D(MSGSUB) Q PARMERR
|
|
I MSGSUB="" Q PARMERR
|
|
S XMSUB=MSGSUB
|
|
;
|
|
I '$D(MSGFROM) S MSGFROM=""
|
|
I MSGFROM="" S XMDUZ=.5
|
|
I MSGFROM'="" S XMDUZ=MSGFROM
|
|
;
|
|
I $D(MSGTXT) S XMTEXT=MSGTXT
|
|
;
|
|
S ERR=$$GETMBRS("PRESCRIPTION PRACTICES","XMY")
|
|
I ERR<1 Q GRPERR
|
|
;
|
|
S XMCHAN=1 ; -- Silents all interactive feed back
|
|
D ^XMD
|
|
D KILL^XM
|
|
K XMCHAN
|
|
Q 0
|
|
;
|
|
GETMBRS(MAILGRP,ARRAY) ; Get the members of a mail group
|
|
;
|
|
; Parameters:
|
|
; MAILGRP - The name of the group without the 'G.'
|
|
; ARRAY - The name of the array where you want the names stored.
|
|
;
|
|
; Returns:
|
|
; The number of members found or a negative error code.
|
|
;
|
|
N PARMERR,GRPERR,MGIFN,MEMBER,TMEMBER
|
|
;
|
|
S PARMERR=-9001
|
|
S GRPERR=-9016
|
|
S TMEMBER=0
|
|
;
|
|
I '$D(PARMERR) Q PARMERR
|
|
I '$D(ARRAY) Q PARMERR
|
|
I $L(MAILGRP)=""!($L(ARRAY)="") Q PARMERR
|
|
;
|
|
S MGIFN=$O(^XMB(3.8,"B",MAILGRP,"")) Q:MGIFN="" GRPERR
|
|
;
|
|
S MEMBER=""
|
|
F I=0:0 D Q:MEMBER=""
|
|
.S MEMBER=$O(^XMB(3.8,MGIFN,1,"B",MEMBER)) Q:MEMBER=""
|
|
.S @ARRAY@(MEMBER)=""
|
|
.S TMEMBER=TMEMBER+1
|
|
Q TMEMBER
|