243 lines
7.3 KiB
Mathematica
243 lines
7.3 KiB
Mathematica
RORUTL01 ;HCIOFO/SG - UTILITIES ; 5/12/05 3:29pm
|
|
;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
|
|
;
|
|
; This routine uses the following IAs:
|
|
;
|
|
; #3301 Access to the .6 field of the file #2
|
|
; #3744 $$TESTPAT^VADPT
|
|
; #10035 Access to the .01 and .09 fields of the file #2
|
|
; #10038 Access to the HOLIDAY file (supported)
|
|
Q
|
|
;
|
|
;***** SENDS ALERT TO REGISTRY COORDINATORS
|
|
;
|
|
; [.]REGLST Either name of the registry or reference to a local
|
|
; array containing registry names as subscripts and
|
|
; optional registry IENs as values
|
|
;
|
|
; MSG Text of the message or negative error code. The '^'
|
|
; characters are replaced with spaces in the text.
|
|
;
|
|
; [XQAROU] Indicates a ROUTINE or TAG^ROUTINE to run when
|
|
; the alert is processed
|
|
;
|
|
; [XQADATA] Use this to store a package-specific data string,
|
|
; in any format
|
|
;
|
|
; [PATIEN] Patient IEN
|
|
;
|
|
; [ARG2-ARG5] Optional parameters as for the $$ERROR^RORERR
|
|
;
|
|
ALERT(REGLST,MSG,XQAROU,XQADATA,PATIEN,ARG2,ARG3,ARG4,ARG5) ;
|
|
N IR,RC,REGIEN,REGNAME,RORBUF,RORMSG,TMP,XQA,XQAFLG,XQAMSG
|
|
;--- Prepare the notification list
|
|
I $D(REGLST)=1 Q:REGLST="" S REGLST(REGLST)=""
|
|
S REGNAME="",RC=0
|
|
F S REGNAME=$O(REGLST(REGNAME)) Q:REGNAME="" D
|
|
. S REGIEN=+$G(REGLST(REGNAME))
|
|
. I REGIEN'>0 D Q:REGIEN'>0
|
|
. . S REGIEN=$$REGIEN^RORUTL02(REGNAME)
|
|
. ;--- Load the notification list from the registry parameters
|
|
. K RORBUF S TMP=","_REGIEN_","
|
|
. D LIST^DIC(798.114,TMP,"@;.01I","U",,,,"B",,,"RORBUF","RORMSG")
|
|
. S RC=$$DBS^RORERR("RORMSG",-9) Q:RC<0
|
|
. S IR=""
|
|
. F S IR=$O(RORBUF("DILIST","ID",IR)) Q:IR="" D
|
|
. . S TMP=+$G(RORBUF("DILIST","ID",IR,.01)) S:TMP>0 XQA(TMP)=""
|
|
Q:$D(XQA)<10
|
|
;--- Get text of the error message (if necessary)
|
|
I +MSG=MSG Q:MSG'<0 D
|
|
. S MSG=$$MSG^RORERR20(+MSG,,.PATIEN,.ARG2,.ARG3,.ARG4,.ARG5)
|
|
S MSG=$TR(MSG,"^"," "),XQAMSG="ROR: ",TMP=70-$L(XQAMSG)-3
|
|
S XQAMSG=XQAMSG_$S($L(MSG)>TMP:$E(MSG,1,TMP)_"...",1:MSG)
|
|
;--- Setup default alert processing routine
|
|
I $G(XQAROU)="",$G(XQADATA)="" D
|
|
. S XQADATA=$E(MSG,1,78)_U_$G(PATIEN)
|
|
. S REGNAME=""
|
|
. F S REGNAME=$O(REGLST(REGNAME)) Q:REGNAME="" D
|
|
. . S XQADATA=XQADATA_U_REGNAME
|
|
. S XQAROU="ALERTRTN^RORUTL01"
|
|
;--- Send the alert
|
|
S XQAFLG="D" D SETUP^XQALERT
|
|
Q
|
|
;
|
|
;***** DEFAULT ALERT PROCESSING ROUTINE
|
|
;
|
|
; XQADATA Alert data
|
|
; ^1: Message
|
|
; ^2: Patient DFN
|
|
; ^3: Registry name
|
|
; ...
|
|
; ^N: Registry name
|
|
;
|
|
ALERTRTN ;
|
|
Q:$G(XQADATA)=""
|
|
N I,REGNAME
|
|
W !!,$P(XQADATA,"^"),!
|
|
W:$P(XQADATA,"^",2) "Patient DFN: ",$P(XQADATA,"^",2),!
|
|
W "Processed Registries",!
|
|
F I=3:1 S REGNAME=$P(XQADATA,"^",I) Q:REGNAME="" W ?3,REGNAME,!
|
|
Q
|
|
;
|
|
;***** INITIALIZES THE VARIABLES
|
|
;
|
|
; NAMESP Namespace to kill in the ^TMP global
|
|
; (must start with "ROR")
|
|
; [XPURGE] Purge namespaced nodes in the ^XTMP global.
|
|
; The ^XTMP(NAMESP_$J) node is always killed.
|
|
;
|
|
INIT(NAMESP,XPURGE) ;
|
|
N I,L,NOW K ^TMP($J)
|
|
S:$G(U)="" U="^" S:'$G(DT) DT=$$DT^XLFDT
|
|
Q:$E($G(NAMESP),1,3)'="ROR"
|
|
;--- Kill namespaced nodes in the ^TMP global
|
|
S I=NAMESP,L=$L(NAMESP)
|
|
F K ^TMP(I,$J) S I=$O(^TMP(I)) Q:$E(I,1,L)'=NAMESP
|
|
;--- Purge old namespaced nodes in the ^XTMP global
|
|
K ^XTMP(NAMESP_$J)
|
|
D:$G(XPURGE)
|
|
. S NOW=$$NOW^XLFDT,I=NAMESP,L=$L(NAMESP)
|
|
. F D S I=$O(^XTMP(I)) Q:$E(I,1,L)'=NAMESP
|
|
. . K:$G(^XTMP(I,0))<NOW ^XTMP(I)
|
|
Q
|
|
;
|
|
;***** INVERTS THE DATE
|
|
;
|
|
; DATE Date in FileMan format
|
|
; [MODE] Mode of inversion
|
|
; 1 Strip the time BEFORE inversion
|
|
; 2 Strip the time AFTER inversion
|
|
; 3 Do not invert the time
|
|
;
|
|
INVDATE(DATE,MODE) ;
|
|
Q:$G(MODE)=1 9999999-$P(DATE,".")
|
|
Q:$G(MODE)=2 $P(9999999-DATE,".")
|
|
I $G(MODE)=3 Q:$P(DATE,".",2) (9999999-$P(DATE,"."))_"."_+$P(DATE,".",2)
|
|
Q 9999999-DATE
|
|
;
|
|
;***** RETURNS THE PATIENT IEN (DFN) FROM THE REGISTRY RECORD
|
|
;
|
|
; IEN IEN of the registry record
|
|
;
|
|
PTIEN(IEN) ;
|
|
Q +$P($G(^RORDATA(798,+IEN,0)),U)
|
|
;
|
|
;***** RETURNS IEN OF THE PATIENT'S RECORD IN THE REGISTRY
|
|
;
|
|
; PATIEN Patient IEN
|
|
; REGIEN Registry IEN
|
|
;
|
|
; Return Values:
|
|
; "" The registry record has not been found
|
|
; >0 IEN of the patient's registry record
|
|
;
|
|
PRRIEN(PATIEN,REGIEN) ;
|
|
Q:(PATIEN'>0)!(REGIEN'>0) 0
|
|
Q $O(^RORDATA(798,"KEY",+PATIEN,+REGIEN,0))
|
|
;
|
|
;***** RETURNS NAME AND SHORT DESCRIPTION OF THE REGISTRY
|
|
;
|
|
; REGIEN Registry IEN
|
|
;
|
|
; Return Values:
|
|
;
|
|
; An empty string is returned in case of an error or if there
|
|
; is no registry with such IEN. Otherwise, the name and short
|
|
; description of the registry separated by "^" are returned.
|
|
;
|
|
REGNAME(REGIEN) ;
|
|
N IENS,NAME,RORBUF,RORMSG
|
|
Q:'$D(^ROR(798.1,+REGIEN)) ""
|
|
S IENS=+REGIEN_","
|
|
D GETS^DIQ(798.1,IENS,".01;4",,"RORBUF","RORMSG")
|
|
I $G(DIERR) D Q ""
|
|
. D DBS^RORERR("RORMSG",-9,,,798.1,IENS)
|
|
Q RORBUF(798.1,IENS,.01)_U_$G(RORBUF(798.1,IENS,4))
|
|
;
|
|
;***** CHECKS IF THE PATIENT IS A TEST ONE
|
|
;
|
|
; PATIEN Patient IEN
|
|
;
|
|
; Return Values:
|
|
; 0 The patient is NOT a test patient
|
|
; 1 The patient IS a test patient
|
|
;
|
|
TESTPAT(PATIEN) ;
|
|
Q:$$TESTPAT^VADPT(PATIEN) 1
|
|
Q:$E($G(^DPT(PATIEN,0)),1,2)="ZZ" 1 ; NAME starts with "ZZ"
|
|
Q 0
|
|
;
|
|
;***** VERIFY THE ENTRY POINT
|
|
;
|
|
; ENTRY Entry point of the external MUMPS function
|
|
; [RECERR] Record the errors (do not record by default)
|
|
;
|
|
; Return Values:
|
|
; -18 Routine does not exist
|
|
; -17 Invalid entry point
|
|
; 0 Ok
|
|
;
|
|
VERIFYEP(ENTRY,RECERR) ;
|
|
N X
|
|
S X="S Y="_ENTRY D ^DIM
|
|
Q:'$D(X) $S($G(RECERR):$$ERROR^RORERR(-17,,,,ENTRY),1:-17)
|
|
S X=$P(ENTRY,U,2)
|
|
X ^%ZOSF("TEST") E Q $S($G(RECERR):$$ERROR^RORERR(-18,,,,X),1:-18)
|
|
Q 0
|
|
;
|
|
;***** CHECKS IF THE DATE IS A WORKING DAY
|
|
;
|
|
; DATE The date to be checked
|
|
;
|
|
; Return Values:
|
|
; 0 Weekend or Holiday
|
|
; 1 Working day
|
|
;
|
|
WDCHK(DATE) ;
|
|
N DOW,RORMSG
|
|
;--- Return zero if Saturday (6) or Sunday (0)
|
|
S DOW=$$DOW^XLFDT(DATE,1) Q:'DOW!(DOW>5) 0
|
|
;--- Return 1 if cannot be found in the HOLIDAY file
|
|
Q $$FIND1^DIC(40.5,,"QX",DATE\1,"B",,"RORMSG")'>0
|
|
;
|
|
;***** RETURNS THE NEXT WORKING DAY DATE
|
|
;
|
|
; DATE The source date
|
|
;
|
|
; The function returns a date of the next working day.
|
|
;
|
|
WDNEXT(DATE) ;
|
|
N DOW,RORMSG
|
|
F D Q:$$FIND1^DIC(40.5,,"QX",DATE,"B",,"RORMSG")'>0
|
|
. S DOW=$$DOW^XLFDT(DATE,1) S:'DOW DOW=7
|
|
. ;--- Get the next day and skip a weekend if necessary
|
|
. S DATE=$$FMADD^XLFDT(DATE,$S(DOW<5:1,1:8-DOW))
|
|
Q DATE
|
|
;
|
|
;***** CREATES A HEADER OF THE NODE IN THE ^XTMP GLOBAL
|
|
;
|
|
; SUBSCR Subscript of the node in the ^XTMP global
|
|
; [DKEEP] Number of days to keep the node (1 by default)
|
|
; [DESCR] Description of the node
|
|
;
|
|
XTMPHDR(SUBSCR,DKEEP,DESCR) ;
|
|
N DATE S DATE=$$DT^XLFDT S:$G(DKEEP)'>0 DKEEP=1
|
|
S ^XTMP(SUBSCR,0)=$$FMADD^XLFDT(DATE,DKEEP)_U_DATE_U_$G(DESCR)
|
|
Q
|
|
;
|
|
;***** EMULATES AND EXTENDS THE ZWRITE COMMAND :-)
|
|
;
|
|
; ROR8NODE Closed root of the sub-tree to display
|
|
; (either local array or global variable)
|
|
; [TITLE] Title of the output
|
|
;
|
|
ZW(ROR8NODE,TITLE) ;
|
|
Q:ROR8NODE="" Q:'$D(@ROR8NODE)
|
|
N FLT,L,PI W !
|
|
W:$G(TITLE)'="" TITLE,!!
|
|
W:$D(@ROR8NODE)#10 ROR8NODE_"="_@ROR8NODE,!
|
|
S L=$L(ROR8NODE) S:$E(ROR8NODE,L)=")" L=L-1
|
|
S FLT=$E(ROR8NODE,1,L),PI=ROR8NODE
|
|
F S PI=$Q(@PI) Q:$E(PI,1,L)'=FLT W PI_"="_@PI,!
|
|
Q
|