RORUTL18 ;HCIOFO/SG - MISCELLANEOUS UTILITIES ; 4/4/07 1:19pm
;;1.5;CLINICAL CASE REGISTRIES;**2,33**;Feb 17, 2006;Build 81
;
; This routine uses the following IA's:
;
; #10035 Access to the field #63 of the file #2
; #10063 %ZTLOAD
; #1472 XUTMOPT
; #10070 XMD
; #10061 VADPT
; #10104 XLFSTR
; #10081 XQALERT
;
;***************************************************************************
;***************************************************************************
; --- ROUTINE MODIFICATION LOG ---
;
;PKG/PATCH DATE DEVELOPER MODIFICATION
;----------- ---------- ----------- ----------------------------------------
;ROR*1.5*33 MAY 2018 F TRAXLER Added GETSCHED, SETSCHED, QSCHED, TASKCHK
;
;***************************************************************************
;***************************************************************************
Q
;
;***** STRIPS NON-NUMERIC CHARACTERS FROM THE LAB RESULT VALUE
;
; VAL Source value
;
CLRNMVAL(VAL) ;
Q $TR(VAL," <>,")
;
;***** CHECKS FOR 'CONFIRMED' STATUS
;
; IEN IEN of the registry record (in file #798)
;
; Return Values:
; 0 Not confirmed
; >0 Confirmation date/time
;
CONFDT(IEN) ;
N CONF S CONF=$P($G(^RORDATA(798,+IEN,0)),U,4,5)
Q $S('$P(CONF,U,2):$P(CONF,U),1:0)
;
;***** DATE RANGE COMPARISON FUNCTIONS
DTMAX(DT1,DT2) ;
I DT1>0 Q $S(DT2>DT1:DT2,1:DT1)
Q $S(DT2>0:DT2,1:0)
;
DTMIN(DT1,DT2) ;
I DT1>0 Q $S(DT2'>0:DT1,DT2<DT1:DT2,1:DT1)
Q $S(DT2>0:DT2,1:0)
;
;***** RETURNS THE INSTITUTION IEN FOR THE HOSPITAL LOCATION
;
; IEN44 IEN in the HOSPITAL LOCATION file (#44)
;
; Return Values:
; <0 Error
; "" Location has no corresponding institution
; >0 Institution IEN
;
IEN4(IEN44) ;
N IEN4,RC,RORMSG
Q:$G(IEN44)'>0 ""
S IEN4=+$$GET1^DIQ(44,IEN44_",",3,"I",,"RORMSG")
Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,,44,IEN44_",")
Q $S(IEN4>0:IEN4,1:"")
;
;***** RETURNS A LAB REFERENCE (IEN IN 'LAB DATA') FOR THE PATIENT
;
; PTIEN Patient IEN
;
; Return values:
; <0 Error code
; 0 No lab data
; >0 IEN of the record in LAB DATA file
;
LABREF(PTIEN) ;
N LABREF,RORMSG
Q:$G(PTIEN)'>0 0
Q:$$MERGED(PTIEN) 0
S LABREF=+$$GET1^DIQ(2,PTIEN_",",63,"I",,"RORMSG")
Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,PTIEN,2,PTIEN_",")
Q LABREF
;
;***** RETURNS THE NEW DFN OF A MERGED PATIENT RECORD
;
; DFN Patient IEN
;
; Return values:
; 0 The patient has not been merged
; >0 New DFN
;
MERGED(DFN) ;
N NEWDFN
F S DFN=+$G(^DPT(+DFN,-9)) Q:DFN'>0 S NEWDFN=DFN
Q +$G(NEWDFN)
;
;***** SENDS THE CPRS-COMPATIBLE INFORMATIONAL ALERT
;
; MSG Text of the alert message. The text is truncated
; to 50 characters and '^' are replaced with '~'.
;
; [DFN] Patient IEN
;
; [.XQA] List of addressees. By default, the
; alert is sent to the current user.
;
ORALERT(MSG,DFN,XQA) ;
N LAST4,NAME,VA,VADM,VAHOW,VAROOT,XQADATA,XQAID,XQAMSG,XQAROU
S XQAMSG="",XQAID="ROR,,"
I $G(DFN)>0 D
. D DEM^VADPT
. S NAME=$E($G(VADM(1)),1,9) ; Patient name
. S LAST4=$E($P($G(VADM(2)),U),6,9) ; Last 4 of SSN
. S XQAMSG=$$LJ^XLFSTR(NAME_" ("_$E(NAME,1)_LAST4_"):",19)
. S $P(XQAID,",",2)=+DFN
S XQAMSG=XQAMSG_$TR(MSG,"^","~")
S:$L(XQAMSG)>70 $E(XQAMSG,68,999)="..."
I $D(XQA)<10 Q:$G(DUZ)'>0 S XQA(+DUZ)=""
D SETUP^XQALERT
Q
;
;***** CHECKS FOR 'PENDING' STATUS
;
; IEN IEN of the registry record (in file #798)
;
; Return Values:
; 0 Non-pending
; 1 Pending patient
;
PENDING(IEN) ;
Q ($P($G(^RORDATA(798,+IEN,0)),U,5)=4)
;
;***** EMULATES $QUERY WITH 'DIRECTION' PARAMETER
;
; NODE Closed root of a node
;
; [DIR] Direction:
; $G(DIR)'<0 forward
; DIR<0 backward
;
Q(NODE,DIR) ;
Q:$G(DIR)'<0 $Q(@NODE)
N I,DN,PI,TMP
S TMP=$QL(NODE) Q:TMP'>0 ""
S I=$QS(NODE,TMP),NODE=$NA(@NODE,TMP-1)
S PI=""
F S I=$O(@NODE@(I),-1) Q:I="" D Q:PI'=""
. S DN=$D(@NODE@(I))
. I DN#10 S PI=$NA(@NODE@(I)) Q
. S:DN>1 PI=$$Q($NA(@NODE@(I,"")),-1)
Q PI
;
;***** COUNTS THE REGISTRY PATIENTS
;
; .REGLST Reference to a local array containing registry
; names as the subscripts and optional registry IENs
; as the values.
;
; [FLAGS] Flags (can be combined)
; A Skip non-active patients
; S Skip patients marked as "Do not Send"
;
; [ROR8DST] Closed root of the global node that will contain a
; list of patients. By default ($G(ROR8DST)=""), the
; ^TMP("RORUTL18",$J) global node is used internally
; (it is deleted before exiting the function).
; @ROR8DST@(
; PatIEN,
; RegIEN) Registry Record IEN
;
; Return Values:
; <0 Error code
; 0 All provided registries are empty
; >0 Number of unique patients
;
REGPTCNT(REGLST,FLAGS,ROR8DST) ;
N CNT,IEN,NODE,PLKILL,PTIEN,REGIEN,REGNAME
S:$G(ROR8DST)="" ROR8DST=$NA(^TMP("RORUTL18",$J)),PLKILL=1
S FLAGS=$G(FLAGS),NODE=$$ROOT^DILFD(798,"",1),CNT=0
K @ROR8DST
;--- Build a list of unique patients and count them
S REGNAME=""
F S REGNAME=$O(REGLST(REGNAME)) Q:REGNAME="" D
. ;--- Get the registry IEN
. S REGIEN=+$G(REGLST(REGNAME))
. I REGIEN'>0 D Q:REGIEN'>0
. . S REGIEN=$$REGIEN^RORUTL02(REGNAME)
. ;--- Count the registry patients
. S IEN=0
. F S IEN=$O(@NODE@("AC",REGIEN,IEN)) Q:IEN'>0 D
. . I FLAGS["A" Q:'$$ACTIVE^RORDD(IEN)
. . I FLAGS["S" Q:$P($G(^RORDATA(798,IEN,2)),U,4)
. . S PTIEN=$$PTIEN^RORUTL01(IEN) Q:PTIEN'>0
. . I '$D(@ROR8DST@(PTIEN)) D S CNT=CNT+1
. . . S @ROR8DST@(PTIEN,REGIEN)=IEN
;--- Cleanup
K:$G(PLKILL) @ROR8DST
Q CNT
;
;***** SELECTS A REGISTRY DESCRIPTOR IN THE FILE #798.1
;
; [.REGNAME] Registry name is returned via this parameter
;
; Return Values:
; <0 Error code
; "" Timeout, "^" entered, or an error in ^DIC
; 0 There are no records in the file #798.1
; >0 IEN of the selected registry
;
SELREG(REGNAME) ;
N DA,DIC,DLAYGO,DTOUT,DUOUT,RC,RORBUF,RORMSG,X,Y
S REGNAME=""
;--- If there are less than two records, do not ask a user
D LIST^DIC(798.1,,"@;.01E",,2,,,"B",,,"RORBUF","RORMSG")
Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,,798.1)
I $G(RORBUF("DILIST",0))<2 D Q +$G(RORBUF("DILIST",2,1))
. S REGNAME=$G(RORBUF("DILIST","ID",1,.01))
;--- Select a registry
S DIC=798.1,DIC(0)="AENQZ"
S DIC("A")="Select a Registry: "
D ^DIC
S:Y>0 REGNAME=Y(0,0)
Q $S($D(DTOUT)!$D(DUOUT):"",Y<0:"",1:+Y)
;
;***** RETURNS THE CLINIC'S STOP CODE
;
; CLIEN Clinic IEN
;
; Return Values:
; <0 Error code
; "" No stop code
; >0 Stop code
;
STOPCODE(CLIEN) ;
N RORMSG,STOP
I CLIEN>0 D
. S STOP=$$GET1^DIQ(44,CLIEN_",","#8:#1","I",,"RORMSG")
. S:$G(DIERR) STOP=$$DBS^RORERR("RORMSG",-99,,,44,CLIEN_",")
E S STOP=""
Q STOP
;
GETSCHED(RORNAME) ;Function to get option schedule information from FILE 19.1
; Input: RORNAME = option name (file 19, field .01)
; Output: (1) = task number^scheduled time^reschedule freq^special queueing flag
; Example: (1) = "1466544^3180427.154^1D^"
; Returns null if option name not defined or option is not scheduled.
;
N RORINFO
S RORNAME=$G(RORNAME)
I RORNAME="" Q ""
D OPTSTAT^XUTMOPT(RORNAME,.RORINFO) ;NOTE: API also returns variable: RORINFO=count
I +$G(RORINFO)=0 Q ""
Q $G(RORINFO(1))
;
SETSCHED(RORNAME,ROR1,ROR2,ROR3,ROR4,ROR5,ROR6) ;Function to set option schedule in FILE 19.1
; Input: RORNAME = option name (file 19, field .01)
; ROR1 = date/time to run
; ROR2 = device to use
; ROR3 = re-sechedule frequency
; ROR4 = flags
; ROR5 = error array
; ROR6 = queueing flag (0:don't queue{default}, 1:queue)
; Output: 1 = changes made
; 0 = changes not made
;
N RORVAR,ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTIO
S RORNAME=$G(RORNAME)
I RORNAME="" Q 0
S ROR1=$G(ROR1),ROR2=$G(ROR2),ROR3=$G(ROR3),ROR4=$G(ROR4),ROR5=$G(ROR5),ROR6=$G(ROR6,0)
I ROR6=1 D Q 1
.S ZTRTN="QSCHED^RORUTL18",ZTDESC="ROR reschedule option",ZTDTH=$$NOW^XLFDT(),ZTIO=""
.F RORVAR="RORNAME","ROR1","ROR2","ROR3","ROR4","ROR5" S ZTSAVE(RORVAR)=""
.D ^%ZTLOAD
D RESCH^XUTMOPT(RORNAME,ROR1,ROR2,ROR3,ROR4,.ROR5)
I $G(ROR5)=-1 Q 0
Q 1
;
TASKCHK(RORNAME) ;Function: Is option currently running?
;Calls %ZTLOAD API with option name.
; Input: RORNAME = option name (file 19, field .01)
; Output: 1 = task is running
; 0 = task is not running
; -1 = error
;
N RORARRAY,RORFLAG,ZTSK
S RORFLAG=0
S RORNAME=$G(RORNAME)
I RORNAME="" Q -1
D OPTION^%ZTLOAD(RORNAME,.RORARRAY) ;returns data in ^TMP($J)
S ZTSK=0
F S ZTSK=$O(@RORARRAY@(ZTSK)) Q:'ZTSK D I $G(ZTSK(1))=2 S RORFLAG=1 Q
. D STAT^%ZTLOAD
;don't want to K ^TMP($J). may kill something that is needed elsewhere.
S ZTSK=0 F S ZTSK=$O(@RORARRAY@(ZTSK)) Q:'ZTSK K @RORARRAY@(ZTSK)
Q RORFLAG
;
QSCHED ;Reschedule an option as a tasked job to avoid date/time from writing to the display
D RESCH^XUTMOPT(RORNAME,ROR1,ROR2,ROR3,ROR4,.ROR5)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORUTL18 9656 printed Sep 23, 2025@19:20:09 Page 2
RORUTL18 ;HCIOFO/SG - MISCELLANEOUS UTILITIES ; 4/4/07 1:19pm
+1 ;;1.5;CLINICAL CASE REGISTRIES;**2,33**;Feb 17, 2006;Build 81
+2 ;
+3 ; This routine uses the following IA's:
+4 ;
+5 ; #10035 Access to the field #63 of the file #2
+6 ; #10063 %ZTLOAD
+7 ; #1472 XUTMOPT
+8 ; #10070 XMD
+9 ; #10061 VADPT
+10 ; #10104 XLFSTR
+11 ; #10081 XQALERT
+12 ;
+13 ;***************************************************************************
+14 ;***************************************************************************
+15 ; --- ROUTINE MODIFICATION LOG ---
+16 ;
+17 ;PKG/PATCH DATE DEVELOPER MODIFICATION
+18 ;----------- ---------- ----------- ----------------------------------------
+19 ;ROR*1.5*33 MAY 2018 F TRAXLER Added GETSCHED, SETSCHED, QSCHED, TASKCHK
+20 ;
+21 ;***************************************************************************
+22 ;***************************************************************************
+23 QUIT
+24 ;
+25 ;***** STRIPS NON-NUMERIC CHARACTERS FROM THE LAB RESULT VALUE
+26 ;
+27 ; VAL Source value
+28 ;
CLRNMVAL(VAL) ;
+1 QUIT $TRANSLATE(VAL," <>,")
+2 ;
+3 ;***** CHECKS FOR 'CONFIRMED' STATUS
+4 ;
+5 ; IEN IEN of the registry record (in file #798)
+6 ;
+7 ; Return Values:
+8 ; 0 Not confirmed
+9 ; >0 Confirmation date/time
+10 ;
CONFDT(IEN) ;
+1 NEW CONF
SET CONF=$PIECE($GET(^RORDATA(798,+IEN,0)),U,4,5)
+2 QUIT $SELECT('$PIECE(CONF,U,2):$PIECE(CONF,U),1:0)
+3 ;
+4 ;***** DATE RANGE COMPARISON FUNCTIONS
DTMAX(DT1,DT2) ;
+1 IF DT1>0
QUIT $SELECT(DT2>DT1:DT2,1:DT1)
+2 QUIT $SELECT(DT2>0:DT2,1:0)
+3 ;
DTMIN(DT1,DT2) ;
+1 IF DT1>0
QUIT $SELECT(DT2'>0:DT1,DT2<DT1:DT2,1:DT1)
+2 QUIT $SELECT(DT2>0:DT2,1:0)
+3 ;
+4 ;***** RETURNS THE INSTITUTION IEN FOR THE HOSPITAL LOCATION
+5 ;
+6 ; IEN44 IEN in the HOSPITAL LOCATION file (#44)
+7 ;
+8 ; Return Values:
+9 ; <0 Error
+10 ; "" Location has no corresponding institution
+11 ; >0 Institution IEN
+12 ;
IEN4(IEN44) ;
+1 NEW IEN4,RC,RORMSG
+2 if $GET(IEN44)'>0
QUIT ""
+3 SET IEN4=+$$GET1^DIQ(44,IEN44_",",3,"I",,"RORMSG")
+4 if $GET(DIERR)
QUIT $$DBS^RORERR("RORMSG",-9,,,44,IEN44_",")
+5 QUIT $SELECT(IEN4>0:IEN4,1:"")
+6 ;
+7 ;***** RETURNS A LAB REFERENCE (IEN IN 'LAB DATA') FOR THE PATIENT
+8 ;
+9 ; PTIEN Patient IEN
+10 ;
+11 ; Return values:
+12 ; <0 Error code
+13 ; 0 No lab data
+14 ; >0 IEN of the record in LAB DATA file
+15 ;
LABREF(PTIEN) ;
+1 NEW LABREF,RORMSG
+2 if $GET(PTIEN)'>0
QUIT 0
+3 if $$MERGED(PTIEN)
QUIT 0
+4 SET LABREF=+$$GET1^DIQ(2,PTIEN_",",63,"I",,"RORMSG")
+5 if $GET(DIERR)
QUIT $$DBS^RORERR("RORMSG",-9,,PTIEN,2,PTIEN_",")
+6 QUIT LABREF
+7 ;
+8 ;***** RETURNS THE NEW DFN OF A MERGED PATIENT RECORD
+9 ;
+10 ; DFN Patient IEN
+11 ;
+12 ; Return values:
+13 ; 0 The patient has not been merged
+14 ; >0 New DFN
+15 ;
MERGED(DFN) ;
+1 NEW NEWDFN
+2 FOR
SET DFN=+$GET(^DPT(+DFN,-9))
if DFN'>0
QUIT
SET NEWDFN=DFN
+3 QUIT +$GET(NEWDFN)
+4 ;
+5 ;***** SENDS THE CPRS-COMPATIBLE INFORMATIONAL ALERT
+6 ;
+7 ; MSG Text of the alert message. The text is truncated
+8 ; to 50 characters and '^' are replaced with '~'.
+9 ;
+10 ; [DFN] Patient IEN
+11 ;
+12 ; [.XQA] List of addressees. By default, the
+13 ; alert is sent to the current user.
+14 ;
ORALERT(MSG,DFN,XQA) ;
+1 NEW LAST4,NAME,VA,VADM,VAHOW,VAROOT,XQADATA,XQAID,XQAMSG,XQAROU
+2 SET XQAMSG=""
SET XQAID="ROR,,"
+3 IF $GET(DFN)>0
Begin DoDot:1
+4 DO DEM^VADPT
+5 ; Patient name
SET NAME=$EXTRACT($GET(VADM(1)),1,9)
+6 ; Last 4 of SSN
SET LAST4=$EXTRACT($PIECE($GET(VADM(2)),U),6,9)
+7 SET XQAMSG=$$LJ^XLFSTR(NAME_" ("_$EXTRACT(NAME,1)_LAST4_"):",19)
+8 SET $PIECE(XQAID,",",2)=+DFN
End DoDot:1
+9 SET XQAMSG=XQAMSG_$TRANSLATE(MSG,"^","~")
+10 if $LENGTH(XQAMSG)>70
SET $EXTRACT(XQAMSG,68,999)="..."
+11 IF $DATA(XQA)<10
if $GET(DUZ)'>0
QUIT
SET XQA(+DUZ)=""
+12 DO SETUP^XQALERT
+13 QUIT
+14 ;
+15 ;***** CHECKS FOR 'PENDING' STATUS
+16 ;
+17 ; IEN IEN of the registry record (in file #798)
+18 ;
+19 ; Return Values:
+20 ; 0 Non-pending
+21 ; 1 Pending patient
+22 ;
PENDING(IEN) ;
+1 QUIT ($PIECE($GET(^RORDATA(798,+IEN,0)),U,5)=4)
+2 ;
+3 ;***** EMULATES $QUERY WITH 'DIRECTION' PARAMETER
+4 ;
+5 ; NODE Closed root of a node
+6 ;
+7 ; [DIR] Direction:
+8 ; $G(DIR)'<0 forward
+9 ; DIR<0 backward
+10 ;
Q(NODE,DIR) ;
+1 if $GET(DIR)'<0
QUIT $QUERY(@NODE)
+2 NEW I,DN,PI,TMP
+3 SET TMP=$QLENGTH(NODE)
if TMP'>0
QUIT ""
+4 SET I=$QSUBSCRIPT(NODE,TMP)
SET NODE=$NAME(@NODE,TMP-1)
+5 SET PI=""
+6 FOR
SET I=$ORDER(@NODE@(I),-1)
if I=""
QUIT
Begin DoDot:1
+7 SET DN=$DATA(@NODE@(I))
+8 IF DN#10
SET PI=$NAME(@NODE@(I))
QUIT
+9 if DN>1
SET PI=$$Q($NAME(@NODE@(I,"")),-1)
End DoDot:1
if PI'=""
QUIT
+10 QUIT PI
+11 ;
+12 ;***** COUNTS THE REGISTRY PATIENTS
+13 ;
+14 ; .REGLST Reference to a local array containing registry
+15 ; names as the subscripts and optional registry IENs
+16 ; as the values.
+17 ;
+18 ; [FLAGS] Flags (can be combined)
+19 ; A Skip non-active patients
+20 ; S Skip patients marked as "Do not Send"
+21 ;
+22 ; [ROR8DST] Closed root of the global node that will contain a
+23 ; list of patients. By default ($G(ROR8DST)=""), the
+24 ; ^TMP("RORUTL18",$J) global node is used internally
+25 ; (it is deleted before exiting the function).
+26 ; @ROR8DST@(
+27 ; PatIEN,
+28 ; RegIEN) Registry Record IEN
+29 ;
+30 ; Return Values:
+31 ; <0 Error code
+32 ; 0 All provided registries are empty
+33 ; >0 Number of unique patients
+34 ;
REGPTCNT(REGLST,FLAGS,ROR8DST) ;
+1 NEW CNT,IEN,NODE,PLKILL,PTIEN,REGIEN,REGNAME
+2 if $GET(ROR8DST)=""
SET ROR8DST=$NAME(^TMP("RORUTL18",$JOB))
SET PLKILL=1
+3 SET FLAGS=$GET(FLAGS)
SET NODE=$$ROOT^DILFD(798,"",1)
SET CNT=0
+4 KILL @ROR8DST
+5 ;--- Build a list of unique patients and count them
+6 SET REGNAME=""
+7 FOR
SET REGNAME=$ORDER(REGLST(REGNAME))
if REGNAME=""
QUIT
Begin DoDot:1
+8 ;--- Get the registry IEN
+9 SET REGIEN=+$GET(REGLST(REGNAME))
+10 IF REGIEN'>0
Begin DoDot:2
+11 SET REGIEN=$$REGIEN^RORUTL02(REGNAME)
End DoDot:2
if REGIEN'>0
QUIT
+12 ;--- Count the registry patients
+13 SET IEN=0
+14 FOR
SET IEN=$ORDER(@NODE@("AC",REGIEN,IEN))
if IEN'>0
QUIT
Begin DoDot:2
+15 IF FLAGS["A"
if '$$ACTIVE^RORDD(IEN)
QUIT
+16 IF FLAGS["S"
if $PIECE($GET(^RORDATA(798,IEN,2)),U,4)
QUIT
+17 SET PTIEN=$$PTIEN^RORUTL01(IEN)
if PTIEN'>0
QUIT
+18 IF '$DATA(@ROR8DST@(PTIEN))
Begin DoDot:3
+19 SET @ROR8DST@(PTIEN,REGIEN)=IEN
End DoDot:3
SET CNT=CNT+1
End DoDot:2
End DoDot:1
+20 ;--- Cleanup
+21 if $GET(PLKILL)
KILL @ROR8DST
+22 QUIT CNT
+23 ;
+24 ;***** SELECTS A REGISTRY DESCRIPTOR IN THE FILE #798.1
+25 ;
+26 ; [.REGNAME] Registry name is returned via this parameter
+27 ;
+28 ; Return Values:
+29 ; <0 Error code
+30 ; "" Timeout, "^" entered, or an error in ^DIC
+31 ; 0 There are no records in the file #798.1
+32 ; >0 IEN of the selected registry
+33 ;
SELREG(REGNAME) ;
+1 NEW DA,DIC,DLAYGO,DTOUT,DUOUT,RC,RORBUF,RORMSG,X,Y
+2 SET REGNAME=""
+3 ;--- If there are less than two records, do not ask a user
+4 DO LIST^DIC(798.1,,"@;.01E",,2,,,"B",,,"RORBUF","RORMSG")
+5 if $GET(DIERR)
QUIT $$DBS^RORERR("RORMSG",-9,,,798.1)
+6 IF $GET(RORBUF("DILIST",0))<2
Begin DoDot:1
+7 SET REGNAME=$GET(RORBUF("DILIST","ID",1,.01))
End DoDot:1
QUIT +$GET(RORBUF("DILIST",2,1))
+8 ;--- Select a registry
+9 SET DIC=798.1
SET DIC(0)="AENQZ"
+10 SET DIC("A")="Select a Registry: "
+11 DO ^DIC
+12 if Y>0
SET REGNAME=Y(0,0)
+13 QUIT $SELECT($DATA(DTOUT)!$DATA(DUOUT):"",Y<0:"",1:+Y)
+14 ;
+15 ;***** RETURNS THE CLINIC'S STOP CODE
+16 ;
+17 ; CLIEN Clinic IEN
+18 ;
+19 ; Return Values:
+20 ; <0 Error code
+21 ; "" No stop code
+22 ; >0 Stop code
+23 ;
STOPCODE(CLIEN) ;
+1 NEW RORMSG,STOP
+2 IF CLIEN>0
Begin DoDot:1
+3 SET STOP=$$GET1^DIQ(44,CLIEN_",","#8:#1","I",,"RORMSG")
+4 if $GET(DIERR)
SET STOP=$$DBS^RORERR("RORMSG",-99,,,44,CLIEN_",")
End DoDot:1
+5 IF '$TEST
SET STOP=""
+6 QUIT STOP
+7 ;
GETSCHED(RORNAME) ;Function to get option schedule information from FILE 19.1
+1 ; Input: RORNAME = option name (file 19, field .01)
+2 ; Output: (1) = task number^scheduled time^reschedule freq^special queueing flag
+3 ; Example: (1) = "1466544^3180427.154^1D^"
+4 ; Returns null if option name not defined or option is not scheduled.
+5 ;
+6 NEW RORINFO
+7 SET RORNAME=$GET(RORNAME)
+8 IF RORNAME=""
QUIT ""
+9 ;NOTE: API also returns variable: RORINFO=count
DO OPTSTAT^XUTMOPT(RORNAME,.RORINFO)
+10 IF +$GET(RORINFO)=0
QUIT ""
+11 QUIT $GET(RORINFO(1))
+12 ;
SETSCHED(RORNAME,ROR1,ROR2,ROR3,ROR4,ROR5,ROR6) ;Function to set option schedule in FILE 19.1
+1 ; Input: RORNAME = option name (file 19, field .01)
+2 ; ROR1 = date/time to run
+3 ; ROR2 = device to use
+4 ; ROR3 = re-sechedule frequency
+5 ; ROR4 = flags
+6 ; ROR5 = error array
+7 ; ROR6 = queueing flag (0:don't queue{default}, 1:queue)
+8 ; Output: 1 = changes made
+9 ; 0 = changes not made
+10 ;
+11 NEW RORVAR,ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTIO
+12 SET RORNAME=$GET(RORNAME)
+13 IF RORNAME=""
QUIT 0
+14 SET ROR1=$GET(ROR1)
SET ROR2=$GET(ROR2)
SET ROR3=$GET(ROR3)
SET ROR4=$GET(ROR4)
SET ROR5=$GET(ROR5)
SET ROR6=$GET(ROR6,0)
+15 IF ROR6=1
Begin DoDot:1
+16 SET ZTRTN="QSCHED^RORUTL18"
SET ZTDESC="ROR reschedule option"
SET ZTDTH=$$NOW^XLFDT()
SET ZTIO=""
+17 FOR RORVAR="RORNAME","ROR1","ROR2","ROR3","ROR4","ROR5"
SET ZTSAVE(RORVAR)=""
+18 DO ^%ZTLOAD
End DoDot:1
QUIT 1
+19 DO RESCH^XUTMOPT(RORNAME,ROR1,ROR2,ROR3,ROR4,.ROR5)
+20 IF $GET(ROR5)=-1
QUIT 0
+21 QUIT 1
+22 ;
TASKCHK(RORNAME) ;Function: Is option currently running?
+1 ;Calls %ZTLOAD API with option name.
+2 ; Input: RORNAME = option name (file 19, field .01)
+3 ; Output: 1 = task is running
+4 ; 0 = task is not running
+5 ; -1 = error
+6 ;
+7 NEW RORARRAY,RORFLAG,ZTSK
+8 SET RORFLAG=0
+9 SET RORNAME=$GET(RORNAME)
+10 IF RORNAME=""
QUIT -1
+11 ;returns data in ^TMP($J)
DO OPTION^%ZTLOAD(RORNAME,.RORARRAY)
+12 SET ZTSK=0
+13 FOR
SET ZTSK=$ORDER(@RORARRAY@(ZTSK))
if 'ZTSK
QUIT
Begin DoDot:1
+14 DO STAT^%ZTLOAD
End DoDot:1
IF $GET(ZTSK(1))=2
SET RORFLAG=1
QUIT
+15 ;don't want to K ^TMP($J). may kill something that is needed elsewhere.
+16 SET ZTSK=0
FOR
SET ZTSK=$ORDER(@RORARRAY@(ZTSK))
if 'ZTSK
QUIT
KILL @RORARRAY@(ZTSK)
+17 QUIT RORFLAG
+18 ;
QSCHED ;Reschedule an option as a tasked job to avoid date/time from writing to the display
+1 DO RESCH^XUTMOPT(RORNAME,ROR1,ROR2,ROR3,ROR4,.ROR5)
+2 QUIT
