VistA-WorldVistAEHR/r/PHARMACY_PRESCRIPTION_PRACT.../PPPMSC1.m

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