- 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 Jan 18, 2025@02:45:23 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