RORUTL01 ;HCIOFO/SG - UTILITIES ; 5/12/05 3:29pm
;;1.5;CLINICAL CASE REGISTRIES;**18**;Feb 17, 2006;Build 25
;
; 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)
; #2051 $$FIND1^DIC
; LIST^DIC
; #10016 ^DIM
; #2056 GETS^DIQ
;*****************************************************************************
; --- ROUTINE MODIFICATION LOG ---
;
;PKG/PATCH DATE DEVELOPER MODIFICATION
;----------- ---------- ----------- ----------------------------------------
;ROR*1.5*18 APR 2012 C RAY Added API $$REGSEL
;
;******************************************************************************
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))
;
;***** RETURNS LIST OF REGISTRIES
;
; FLAGS "I": Registry is initialized
; "U": Registry is uninitialized
; "A": Registry records are auto confirm
; "M": Registry records are manually confirmed
;
; Return Values:
; REGLST Reference to a local array containing registry
; names as subscripts
; 0 No errors
; -9 DBS FM error
;
REGSEL(FLAGS) ;
N RORSCR,RORMSG,INDX,REGIEN,REGNAME,RORBUF,DIERR,RC
;--- filter by auto-confirm and HDT date/time
S RORSCR="I $P(^(0),U,7)'=1" ;exclude inactive
D LIST^DIC(798.1,,"@;.01E;21.05;31I",,,,,"B",.RORSCR,,"RORBUF","RORMSG")
I $G(DIERR) S RC=$$DBS^RORERR("RORMSG",-9,,,798.1) Q RC
I $G(FLAGS)="" S FLAGS=""
S INDX="" F S INDX=$O(RORBUF("DILIST","ID",INDX)) Q:INDX="" D
. I FLAGS["I",($G(RORBUF("DILIST","ID",INDX,21.05))="") Q
. I FLAGS["U",($G(RORBUF("DILIST","ID",INDX,21.05))'="") Q
. I FLAGS["M",($G(RORBUF("DILIST","ID",INDX,31))=1) Q ;skip auto confirm
. I FLAGS["A",($G(RORBUF("DILIST","ID",INDX,31))'=1) Q ;skip non auto-confirm
. S REGNAME=$G(RORBUF("DILIST","ID",INDX,.01)) Q:REGNAME=""
. S REGLST(REGNAME)=""
Q 0
;
;***** 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORUTL01 9588 printed Dec 13, 2024@01:43:55 Page 2
RORUTL01 ;HCIOFO/SG - UTILITIES ; 5/12/05 3:29pm
+1 ;;1.5;CLINICAL CASE REGISTRIES;**18**;Feb 17, 2006;Build 25
+2 ;
+3 ; This routine uses the following IAs:
+4 ;
+5 ; #3301 Access to the .6 field of the file #2
+6 ; #3744 $$TESTPAT^VADPT
+7 ; #10035 Access to the .01 and .09 fields of the file #2
+8 ; #10038 Access to the HOLIDAY file (supported)
+9 ; #2051 $$FIND1^DIC
+10 ; LIST^DIC
+11 ; #10016 ^DIM
+12 ; #2056 GETS^DIQ
+13 ;*****************************************************************************
+14 ; --- ROUTINE MODIFICATION LOG ---
+15 ;
+16 ;PKG/PATCH DATE DEVELOPER MODIFICATION
+17 ;----------- ---------- ----------- ----------------------------------------
+18 ;ROR*1.5*18 APR 2012 C RAY Added API $$REGSEL
+19 ;
+20 ;******************************************************************************
+21 QUIT
+22 ;
+23 ;***** SENDS ALERT TO REGISTRY COORDINATORS
+24 ;
+25 ; [.]REGLST Either name of the registry or reference to a local
+26 ; array containing registry names as subscripts and
+27 ; optional registry IENs as values
+28 ;
+29 ; MSG Text of the message or negative error code. The '^'
+30 ; characters are replaced with spaces in the text.
+31 ;
+32 ; [XQAROU] Indicates a ROUTINE or TAG^ROUTINE to run when
+33 ; the alert is processed
+34 ;
+35 ; [XQADATA] Use this to store a package-specific data string,
+36 ; in any format
+37 ;
+38 ; [PATIEN] Patient IEN
+39 ;
+40 ; [ARG2-ARG5] Optional parameters as for the $$ERROR^RORERR
+41 ;
ALERT(REGLST,MSG,XQAROU,XQADATA,PATIEN,ARG2,ARG3,ARG4,ARG5) ;
+1 NEW IR,RC,REGIEN,REGNAME,RORBUF,RORMSG,TMP,XQA,XQAFLG,XQAMSG
+2 ;--- Prepare the notification list
+3 IF $DATA(REGLST)=1
if REGLST=""
QUIT
SET REGLST(REGLST)=""
+4 SET REGNAME=""
SET RC=0
+5 FOR
SET REGNAME=$ORDER(REGLST(REGNAME))
if REGNAME=""
QUIT
Begin DoDot:1
+6 SET REGIEN=+$GET(REGLST(REGNAME))
+7 IF REGIEN'>0
Begin DoDot:2
+8 SET REGIEN=$$REGIEN^RORUTL02(REGNAME)
End DoDot:2
if REGIEN'>0
QUIT
+9 ;--- Load the notification list from the registry parameters
+10 KILL RORBUF
SET TMP=","_REGIEN_","
+11 DO LIST^DIC(798.114,TMP,"@;.01I","U",,,,"B",,,"RORBUF","RORMSG")
+12 SET RC=$$DBS^RORERR("RORMSG",-9)
if RC<0
QUIT
+13 SET IR=""
+14 FOR
SET IR=$ORDER(RORBUF("DILIST","ID",IR))
if IR=""
QUIT
Begin DoDot:2
+15 SET TMP=+$GET(RORBUF("DILIST","ID",IR,.01))
if TMP>0
SET XQA(TMP)=""
End DoDot:2
End DoDot:1
+16 if $DATA(XQA)<10
QUIT
+17 ;--- Get text of the error message (if necessary)
+18 IF +MSG=MSG
if MSG'<0
QUIT
Begin DoDot:1
+19 SET MSG=$$MSG^RORERR20(+MSG,,.PATIEN,.ARG2,.ARG3,.ARG4,.ARG5)
End DoDot:1
+20 SET MSG=$TRANSLATE(MSG,"^"," ")
SET XQAMSG="ROR: "
SET TMP=70-$LENGTH(XQAMSG)-3
+21 SET XQAMSG=XQAMSG_$SELECT($LENGTH(MSG)>TMP:$EXTRACT(MSG,1,TMP)_"...",1:MSG)
+22 ;--- Setup default alert processing routine
+23 IF $GET(XQAROU)=""
IF $GET(XQADATA)=""
Begin DoDot:1
+24 SET XQADATA=$EXTRACT(MSG,1,78)_U_$GET(PATIEN)
+25 SET REGNAME=""
+26 FOR
SET REGNAME=$ORDER(REGLST(REGNAME))
if REGNAME=""
QUIT
Begin DoDot:2
+27 SET XQADATA=XQADATA_U_REGNAME
End DoDot:2
+28 SET XQAROU="ALERTRTN^RORUTL01"
End DoDot:1
+29 ;--- Send the alert
+30 SET XQAFLG="D"
DO SETUP^XQALERT
+31 QUIT
+32 ;
+33 ;***** DEFAULT ALERT PROCESSING ROUTINE
+34 ;
+35 ; XQADATA Alert data
+36 ; ^1: Message
+37 ; ^2: Patient DFN
+38 ; ^3: Registry name
+39 ; ...
+40 ; ^N: Registry name
+41 ;
ALERTRTN ;
+1 if $GET(XQADATA)=""
QUIT
+2 NEW I,REGNAME
+3 WRITE !!,$PIECE(XQADATA,"^"),!
+4 if $PIECE(XQADATA,"^",2)
WRITE "Patient DFN: ",$PIECE(XQADATA,"^",2),!
+5 WRITE "Processed Registries",!
+6 FOR I=3:1
SET REGNAME=$PIECE(XQADATA,"^",I)
if REGNAME=""
QUIT
WRITE ?3,REGNAME,!
+7 QUIT
+8 ;
+9 ;***** INITIALIZES THE VARIABLES
+10 ;
+11 ; NAMESP Namespace to kill in the ^TMP global
+12 ; (must start with "ROR")
+13 ; [XPURGE] Purge namespaced nodes in the ^XTMP global.
+14 ; The ^XTMP(NAMESP_$J) node is always killed.
+15 ;
INIT(NAMESP,XPURGE) ;
+1 NEW I,L,NOW
KILL ^TMP($JOB)
+2 if $GET(U)=""
SET U="^"
if '$GET(DT)
SET DT=$$DT^XLFDT
+3 if $EXTRACT($GET(NAMESP),1,3)'="ROR"
QUIT
+4 ;--- Kill namespaced nodes in the ^TMP global
+5 SET I=NAMESP
SET L=$LENGTH(NAMESP)
+6 FOR
KILL ^TMP(I,$JOB)
SET I=$ORDER(^TMP(I))
if $EXTRACT(I,1,L)'=NAMESP
QUIT
+7 ;--- Purge old namespaced nodes in the ^XTMP global
+8 KILL ^XTMP(NAMESP_$JOB)
+9 if $GET(XPURGE)
Begin DoDot:1
+10 SET NOW=$$NOW^XLFDT
SET I=NAMESP
SET L=$LENGTH(NAMESP)
+11 FOR
Begin DoDot:2
+12 if $GET(^XTMP(I,0))<NOW
KILL ^XTMP(I)
End DoDot:2
SET I=$ORDER(^XTMP(I))
if $EXTRACT(I,1,L)'=NAMESP
QUIT
End DoDot:1
+13 QUIT
+14 ;
+15 ;***** INVERTS THE DATE
+16 ;
+17 ; DATE Date in FileMan format
+18 ; [MODE] Mode of inversion
+19 ; 1 Strip the time BEFORE inversion
+20 ; 2 Strip the time AFTER inversion
+21 ; 3 Do not invert the time
+22 ;
INVDATE(DATE,MODE) ;
+1 if $GET(MODE)=1
QUIT 9999999-$PIECE(DATE,".")
+2 if $GET(MODE)=2
QUIT $PIECE(9999999-DATE,".")
+3 IF $GET(MODE)=3
if $PIECE(DATE,".",2)
QUIT (9999999-$PIECE(DATE,"."))_"."_+$PIECE(DATE,".",2)
+4 QUIT 9999999-DATE
+5 ;
+6 ;***** RETURNS THE PATIENT IEN (DFN) FROM THE REGISTRY RECORD
+7 ;
+8 ; IEN IEN of the registry record
+9 ;
PTIEN(IEN) ;
+1 QUIT +$PIECE($GET(^RORDATA(798,+IEN,0)),U)
+2 ;
+3 ;***** RETURNS IEN OF THE PATIENT'S RECORD IN THE REGISTRY
+4 ;
+5 ; PATIEN Patient IEN
+6 ; REGIEN Registry IEN
+7 ;
+8 ; Return Values:
+9 ; "" The registry record has not been found
+10 ; >0 IEN of the patient's registry record
+11 ;
PRRIEN(PATIEN,REGIEN) ;
+1 if (PATIEN'>0)!(REGIEN'>0)
QUIT 0
+2 QUIT $ORDER(^RORDATA(798,"KEY",+PATIEN,+REGIEN,0))
+3 ;
+4 ;***** RETURNS NAME AND SHORT DESCRIPTION OF THE REGISTRY
+5 ;
+6 ; REGIEN Registry IEN
+7 ;
+8 ; Return Values:
+9 ;
+10 ; An empty string is returned in case of an error or if there
+11 ; is no registry with such IEN. Otherwise, the name and short
+12 ; description of the registry separated by "^" are returned.
+13 ;
REGNAME(REGIEN) ;
+1 NEW IENS,NAME,RORBUF,RORMSG
+2 if '$DATA(^ROR(798.1,+REGIEN))
QUIT ""
+3 SET IENS=+REGIEN_","
+4 DO GETS^DIQ(798.1,IENS,".01;4",,"RORBUF","RORMSG")
+5 IF $GET(DIERR)
Begin DoDot:1
+6 DO DBS^RORERR("RORMSG",-9,,,798.1,IENS)
End DoDot:1
QUIT ""
+7 QUIT RORBUF(798.1,IENS,.01)_U_$GET(RORBUF(798.1,IENS,4))
+8 ;
+9 ;***** RETURNS LIST OF REGISTRIES
+10 ;
+11 ; FLAGS "I": Registry is initialized
+12 ; "U": Registry is uninitialized
+13 ; "A": Registry records are auto confirm
+14 ; "M": Registry records are manually confirmed
+15 ;
+16 ; Return Values:
+17 ; REGLST Reference to a local array containing registry
+18 ; names as subscripts
+19 ; 0 No errors
+20 ; -9 DBS FM error
+21 ;
REGSEL(FLAGS) ;
+1 NEW RORSCR,RORMSG,INDX,REGIEN,REGNAME,RORBUF,DIERR,RC
+2 ;--- filter by auto-confirm and HDT date/time
+3 ;exclude inactive
SET RORSCR="I $P(^(0),U,7)'=1"
+4 DO LIST^DIC(798.1,,"@;.01E;21.05;31I",,,,,"B",.RORSCR,,"RORBUF","RORMSG")
+5 IF $GET(DIERR)
SET RC=$$DBS^RORERR("RORMSG",-9,,,798.1)
QUIT RC
+6 IF $GET(FLAGS)=""
SET FLAGS=""
+7 SET INDX=""
FOR
SET INDX=$ORDER(RORBUF("DILIST","ID",INDX))
if INDX=""
QUIT
Begin DoDot:1
+8 IF FLAGS["I"
IF ($GET(RORBUF("DILIST","ID",INDX,21.05))="")
QUIT
+9 IF FLAGS["U"
IF ($GET(RORBUF("DILIST","ID",INDX,21.05))'="")
QUIT
+10 ;skip auto confirm
IF FLAGS["M"
IF ($GET(RORBUF("DILIST","ID",INDX,31))=1)
QUIT
+11 ;skip non auto-confirm
IF FLAGS["A"
IF ($GET(RORBUF("DILIST","ID",INDX,31))'=1)
QUIT
+12 SET REGNAME=$GET(RORBUF("DILIST","ID",INDX,.01))
if REGNAME=""
QUIT
+13 SET REGLST(REGNAME)=""
End DoDot:1
+14 QUIT 0
+15 ;
+16 ;***** CHECKS IF THE PATIENT IS A TEST ONE
+17 ;
+18 ; PATIEN Patient IEN
+19 ;
+20 ; Return Values:
+21 ; 0 The patient is NOT a test patient
+22 ; 1 The patient IS a test patient
+23 ;
TESTPAT(PATIEN) ;
+1 if $$TESTPAT^VADPT(PATIEN)
QUIT 1
+2 ; NAME starts with "ZZ"
if $EXTRACT($GET(^DPT(PATIEN,0)),1,2)="ZZ"
QUIT 1
+3 QUIT 0
+4 ;
+5 ;***** VERIFY THE ENTRY POINT
+6 ;
+7 ; ENTRY Entry point of the external MUMPS function
+8 ; [RECERR] Record the errors (do not record by default)
+9 ;
+10 ; Return Values:
+11 ; -18 Routine does not exist
+12 ; -17 Invalid entry point
+13 ; 0 Ok
+14 ;
VERIFYEP(ENTRY,RECERR) ;
+1 NEW X
+2 SET X="S Y="_ENTRY
DO ^DIM
+3 if '$DATA(X)
QUIT $SELECT($GET(RECERR):$$ERROR^RORERR(-17,,,,ENTRY),1:-17)
+4 SET X=$PIECE(ENTRY,U,2)
+5 XECUTE ^%ZOSF("TEST")
IF '$TEST
QUIT $SELECT($GET(RECERR):$$ERROR^RORERR(-18,,,,X),1:-18)
+6 QUIT 0
+7 ;
+8 ;***** CHECKS IF THE DATE IS A WORKING DAY
+9 ;
+10 ; DATE The date to be checked
+11 ;
+12 ; Return Values:
+13 ; 0 Weekend or Holiday
+14 ; 1 Working day
+15 ;
WDCHK(DATE) ;
+1 NEW DOW,RORMSG
+2 ;--- Return zero if Saturday (6) or Sunday (0)
+3 SET DOW=$$DOW^XLFDT(DATE,1)
if 'DOW!(DOW>5)
QUIT 0
+4 ;--- Return 1 if cannot be found in the HOLIDAY file
+5 QUIT $$FIND1^DIC(40.5,,"QX",DATE\1,"B",,"RORMSG")'>0
+6 ;
+7 ;***** RETURNS THE NEXT WORKING DAY DATE
+8 ;
+9 ; DATE The source date
+10 ;
+11 ; The function returns a date of the next working day.
+12 ;
WDNEXT(DATE) ;
+1 NEW DOW,RORMSG
+2 FOR
Begin DoDot:1
+3 SET DOW=$$DOW^XLFDT(DATE,1)
if 'DOW
SET DOW=7
+4 ;--- Get the next day and skip a weekend if necessary
+5 SET DATE=$$FMADD^XLFDT(DATE,$SELECT(DOW<5:1,1:8-DOW))
End DoDot:1
if $$FIND1^DIC(40.5,,"QX",DATE,"B",,"RORMSG")'>0
QUIT
+6 QUIT DATE
+7 ;
+8 ;***** CREATES A HEADER OF THE NODE IN THE ^XTMP GLOBAL
+9 ;
+10 ; SUBSCR Subscript of the node in the ^XTMP global
+11 ; [DKEEP] Number of days to keep the node (1 by default)
+12 ; [DESCR] Description of the node
+13 ;
XTMPHDR(SUBSCR,DKEEP,DESCR) ;
+1 NEW DATE
SET DATE=$$DT^XLFDT
if $GET(DKEEP)'>0
SET DKEEP=1
+2 SET ^XTMP(SUBSCR,0)=$$FMADD^XLFDT(DATE,DKEEP)_U_DATE_U_$GET(DESCR)
+3 QUIT
+4 ;
+5 ;***** EMULATES AND EXTENDS THE ZWRITE COMMAND :-)
+6 ;
+7 ; ROR8NODE Closed root of the sub-tree to display
+8 ; (either local array or global variable)
+9 ; [TITLE] Title of the output
+10 ;
ZW(ROR8NODE,TITLE) ;
+1 if ROR8NODE=""
QUIT
if '$DATA(@ROR8NODE)
QUIT
+2 NEW FLT,L,PI
WRITE !
+3 if $GET(TITLE)'=""
WRITE TITLE,!!
+4 if $DATA(@ROR8NODE)#10
WRITE ROR8NODE_"="_@ROR8NODE,!
+5 SET L=$LENGTH(ROR8NODE)
if $EXTRACT(ROR8NODE,L)=")"
SET L=L-1
+6 SET FLT=$EXTRACT(ROR8NODE,1,L)
SET PI=ROR8NODE
+7 FOR
SET PI=$QUERY(@PI)
if $EXTRACT(PI,1,L)'=FLT
QUIT
WRITE PI_"="_@PI,!
+8 QUIT
