Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RORUTL18

RORUTL18.m

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