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

RORUPDUT.m

Go to the documentation of this file.
  1. RORUPDUT ;HCIOFO/SG - REGISTRY UPDATE UTILITIES ;15 Jun 2015 12:30 PM
  1. ;;1.5;CLINICAL CASE REGISTRIES;**18,19,26,37**;Feb 17, 2006;Build 9
  1. ;
  1. ;*****************************************************************************
  1. ;*****************************************************************************
  1. ; --- ROUTINE MODIFICATION LOG ---
  1. ;
  1. ;PKG/PATCH DATE DEVELOPER MODIFICATION
  1. ;----------- ---------- ----------- ----------------------------------------
  1. ;ROR*1.5*18 APR 2012 C RAY Add logic to define REGIEN for
  1. ; ROR SELECTION RULE EXPRESSION
  1. ;ROR*1.5*19 FEB 2012 K GUPTA Support for ICD-10 Coding System
  1. ;ROR*1.5*26 APR 2015 T KOPP Add check for coding system for procedures
  1. ; Add logic for storing inpatient proc codes
  1. ;ROR*1.5*37 SEP 2020 F TRAXLER Add LAST2YRS, LASTADM, LASTVSIT and DELETE
  1. ; subroutines
  1. ;*****************************************************************************
  1. ;****************************************************************************
  1. ; This routine uses the following IAs:
  1. ;
  1. ; #2051 FIND^DIC (supported)
  1. ; #2053 FILE^DIC (supported)
  1. ; #2056 GETS^DIQ (supported)
  1. ; #2309 ^AUPNVSIT("AA") x-ref
  1. ; #3545 ^DGPT("AAD") x-ref
  1. ; #5679 IMPDATE^LEXU (Supported)
  1. ;
  1. ;****************************************************************************
  1. ;
  1. ; RORVALS ------------- CALCULATED VALUES
  1. ;
  1. ; RORVALS("DV", VALUES OF THE DATA ELEMENTS
  1. ; File#,DataCode,"E") External value
  1. ; File#,DataCode,"I") Internal value
  1. ;
  1. ; RORVALS("LS", LIST OF TRIGGERED LAB SEARCHES
  1. ; LabSearch#) Observation descriptor
  1. ; ^01: Date/time of the observation
  1. ; ^02: Institution IEN
  1. ; RORVALS("PPTF", List of inpatient procedure codes for patient
  1. ; Datatype, Datatype="C" for CPT, 'I' for ICD procedure
  1. ; n, n = seq # unique to each multiple file entry found
  1. ; "I") Internal value
  1. ;
  1. ; RORVALS("SV", VALUES OF THE SELECTION RULES
  1. ; Rule Name, Current value
  1. ; "AVG") Average value
  1. ; "CNT") Counter
  1. ; "DTF") Used by the {SDF} and {SDL} macros to store
  1. ; "DTL") the earliest and the latest trigger dates
  1. ; "MAX") Maximum value
  1. ; "MIN") Minimum value
  1. ; "SUM") Total value
  1. ;
  1. ; PREDEFINED NAME ----- VALUE AND DESCRIPTION
  1. ;
  1. ; "ROR DFN" IEN of the patient being processed
  1. ; "ROR SRDT" Date when the current selection rule was
  1. ; triggered (it is set by APLRULES^RORUPDUT
  1. ; but could be changed by selection rules).
  1. ; The {GDF} and {GDL} macros modify this
  1. ; value as well.
  1. ; "ROR SRLOC" Institution IEN where the selection rule
  1. ; was triggered
  1. ;
  1. Q
  1. ;
  1. ;***** APPLIES SELECTION RULES TO THE RECORD
  1. ;
  1. ; FILE File/Subfile number
  1. ; IENS IENS of the current record
  1. ; MODE "B" (process before subfiles) or
  1. ; "A" (process after subfiles)
  1. ; [DATE] Trigger date (TODAY by default)
  1. ; [LOCATION] Institution IEN (empty by default)
  1. ;
  1. ; Return values:
  1. ; <0 Error code
  1. ; 0 Continue processing of the current patient
  1. ; 1 Stop looping
  1. ;
  1. APLRULES(FILE,IENS,MODE,DATE,LOCATION) ;
  1. N EXPR,HDR,LM,PATIEN,RC,REGIEN,RI,RULENAME,RULENODE,TMP,RORCSYS
  1. S:'$G(DATE) DATE=$$DT^XLFDT
  1. S:$G(RORUPD("IMPDATE","ICD10"))="" RORUPD("IMPDATE","ICD10")=$$IMPDATE^LEXU("10D") ;ICD-10 implementation date
  1. ;--- Loop through the selection rules
  1. S RI="",RC=0
  1. F S RI=$O(RORUPD("SR",FILE,MODE,RI)) Q:RI="" D Q:RC<0
  1. . S RULENODE=$NA(RORUPD("SR",FILE,MODE,RI))
  1. . ;Check if rule is applicable or not based on coding system
  1. . S RORCSYS=@RULENODE@(3)
  1. . Q:(DATE<RORUPD("IMPDATE","ICD10")&(RORCSYS=30!(RORCSYS=31))) ;quit if date is before ICD-10 implementation date and selection rule is applicable for ICD-10 coding system
  1. . Q:(DATE'<RORUPD("IMPDATE","ICD10")&(RORCSYS=1!(RORCSYS=2))) ;quit if date is on or after ICD-10 implementation date and selection rule is applicable for ICD-9 coding system
  1. . S RORVALS("SV","ROR SRDT")=$P(DATE,".")
  1. . S RORVALS("SV","ROR SRLOC")=$G(LOCATION)
  1. . S HDR=$G(@RULENODE),RULENAME=$P(HDR,U)
  1. . ;--- If a top level rule does not exist in the control list, this
  1. . ; rule has been already triggered for the patient. So, there is
  1. . ; no need to check it again.
  1. . I $P(HDR,U,3) Q:'$D(RORUPD("LM",1,RULENAME))
  1. . ;--- Get value of registry for selection rule
  1. . S REGIEN=$O(@RULENODE@(2,""))
  1. . Q:REGIEN=""
  1. . ;--- Compute the expression of the selection rule
  1. . X "S RC="_@RULENODE@(1)
  1. . I $P(HDR,U,3) Q:'RC D ; TOP LEVEL RULE
  1. . . S PATIEN=$$GETVAL("ROR DFN"),REGIEN=""
  1. . . F S REGIEN=$O(@RULENODE@(2,REGIEN)) Q:REGIEN="" D
  1. . . . ;--- Check if the patient is already in the registry
  1. . . . Q:'$G(RORUPD("LM2",REGIEN))
  1. . . . ;--- Save the rule reference for the registry and new patient
  1. . . . S TMP=$$GETVAL("ROR SRDT")_U_$$GETVAL("ROR SRLOC")
  1. . . . S @RORUPDPI@("U",PATIEN,2,REGIEN,+$P(HDR,U,2))=TMP
  1. . . . ;--- Remove the registry from the control list
  1. . . . K RORUPD("LM",2,REGIEN)
  1. . . ;--- Remove the rule from the control list
  1. . . K RORUPD("LM",1,RULENAME)
  1. . E D SETVAL(RULENAME,RC) ; LOWER LEVEL RULE
  1. . S RC=0
  1. S LM=+$G(RORUPD("LM")) ; Loop mode
  1. ;--- If the loop mode equals 0, continue processing of the patient
  1. ; in any case. Otherwise, stop processing if the corresponding
  1. ; control list is empty.
  1. Q $S(RC<0:RC,LM:$D(RORUPD("LM",LM))<10,1:0)
  1. ;
  1. ;***** CLEARS DATA ELEMENT VALUES
  1. ;
  1. ; FILE File/Subfile number
  1. ;
  1. CLRDES(FILE) ;
  1. K RORVALS("DV",FILE)
  1. K RORVALS("PPTF",FILE)
  1. Q
  1. ;
  1. ;***** CLEARS VALUE OF THE ERROR COUNTER
  1. CLREC ;
  1. K RORUPD("ERRCNT")
  1. Q
  1. ;
  1. ;***** CLEARS VALUES OF THE SELECTION RULES ASSOCIATED WITH THE FILE
  1. ;
  1. ; FILE File/Subfile number
  1. ;
  1. CLRVALS(FILE) ;
  1. N MODE,RI,RULENAME
  1. F MODE="B","A" D
  1. . S RI=""
  1. . F S RI=$O(RORUPD("SR",FILE,MODE,RI)) Q:RI="" D
  1. . . S RULENAME=$P($G(RORUPD("SR",FILE,MODE,RI)),U)
  1. . . K:RULENAME'="" RORVALS("SV",RULENAME)
  1. Q
  1. ;
  1. ;***** RETURNS A CODE OF THE DATA ELEMENT
  1. ;
  1. ; FILE File number
  1. ; NAME Name of the data element
  1. ;
  1. ; Return values:
  1. ; <0 Error code
  1. ; >0 Code of the data element
  1. ;
  1. DATACODE(FILE,NAME) ;
  1. N DIERR,IENS,RC,RORBUF,RORMSG
  1. S IENS=","_FILE_","
  1. D FIND^DIC(799.22,IENS,"@;.02I","X",NAME,,"B",,,"RORBUF","RORMSG")
  1. I $G(DIERR) D Q RC
  1. . S RC=$$DBS^RORERR("RORMSG",-9,,,799.22,IENS)
  1. S RC=+$G(RORBUF("DILIST",0))
  1. Q:RC<1 $$ERROR^RORERR(-69,,NAME)
  1. Q:RC>1 $$ERROR^RORERR(-70,,NAME)
  1. Q +$G(RORBUF("DILIST","ID",1,.02))
  1. ;
  1. ;***** PRINTS SOME DEBUG INFORMATION
  1. DEBUG ;
  1. N I
  1. D ZW^RORUTL01($NA(RORUPD("FLAGS")),"Control Flags")
  1. D ZW^RORUTL01($NA(RORUPD("SR")),"Selection Rules")
  1. D ZW^RORUTL01($NA(RORUPD("UPD")),"Call-back Entry Points")
  1. W !,"Control Lists",!!
  1. F I="LM1","LM2" D ZW^RORUTL01($NA(RORUPD(I)))
  1. D ZW^RORUTL01("RORLRC","Lab Results to check")
  1. W !,"Job number: ",$J,!
  1. Q
  1. ;
  1. ;***** GETS A VALUE OF THE DATA ELEMENT
  1. ;
  1. ; FILE File number
  1. ; DATELMT Code of the data element
  1. ; [TYPE] Type of the value
  1. ; "E" External
  1. ; "I" Internal (default)
  1. ;
  1. GETDE(FILE,DATELMT,TYPE) ;
  1. Q $G(RORVALS("DV",FILE,DATELMT,$G(TYPE,"I")))
  1. ;
  1. ;***** RETURNS VALUE OF THE ERROR COUNTER
  1. GETEC() ;
  1. Q +$G(RORUPD("ERRCNT"))
  1. ;
  1. ;***** GETS VALUE OF THE SELECTION RULE
  1. ;
  1. ; RULENAME Name of the rule
  1. ; [PFX] Prefix of the value
  1. ; "" Value itself (default)
  1. ; "AVG" Average value
  1. ; "CNT" Counter
  1. ; "MAX" Maximum value
  1. ; "MIN" Minimum value
  1. ; "SUM" Total sum
  1. ;
  1. GETVAL(RULENAME,PFX) ;
  1. Q $S($G(PFX)="":$G(RORVALS("SV",RULENAME)),1:$G(RORVALS("SV",RULENAME,PFX)))
  1. ;
  1. ;***** INCREMENTS VALUE OF THE ERROR COUNTER
  1. ;
  1. ; [RC] Reference to a variable containing the error code
  1. ;
  1. INCEC(RC) ;
  1. S:$G(RC,-1)<0 RORUPD("ERRCNT")=$G(RORUPD("ERRCNT"))+1,RC=0
  1. Q
  1. ;
  1. ;***** LOADS DATA ELEMENT VALUES FROM CORRESPONDING FIELDS
  1. ;
  1. ; FILE File/Subfile number
  1. ; IENS IENS of the current record
  1. ;
  1. ; Return values:
  1. ; <0 Error code
  1. ; 0 Ok
  1. ;
  1. LOADFLDS(FILE,IENS) ;
  1. N DE,FLD,RC,RORFDA,RORMSG,VT K RORVALS("DV",FILE) K:FILE=45 RORVALS("PPTF",45)
  1. S FLD=$G(RORUPD("SR",FILE,"F",1)) Q:FLD="" 0
  1. ;--- Load the field values
  1. D GETS^DIQ(FILE,IENS,FLD,"EIN","RORFDA","RORMSG")
  1. I $G(DIERR) D Q RC
  1. . S RC=$$DBS^RORERR("RORMSG",-9,,,FILE,IENS)
  1. ;--- Copy the field values from the FDA
  1. S DE=""
  1. F S DE=$O(RORUPD("SR",FILE,"F",1,DE)) Q:DE="" D
  1. . S FLD=+$G(RORUPD("SR",FILE,"F",1,DE)) Q:'FLD
  1. . S VT=""
  1. . F S VT=$O(RORUPD("SR",FILE,"F",1,DE,VT)) Q:VT="" D
  1. . . S RORVALS("DV",FILE,DE,VT)=$G(RORFDA(FILE,IENS,FLD,VT))
  1. S DE=""
  1. F S DE=$O(RORUPD("SR",FILE,"F",3,DE)) Q:DE="" D
  1. . S VT=""
  1. . F S VT=$O(RORUPD("SR",FILE,"F",3,DE,VT)) Q:VT="" D
  1. . . N ADMDT,VT,FILE,IEN ; protect some variables
  1. . . ; Call the API to return the CPT codes and ICD procedures for surgery and 'other'
  1. . . ; Returns array RORVALS("PPTF","C",n,"I") for CPT codes
  1. . . ; RORVALS("PPTF","I",n,"I") for ICD procedure codes
  1. . . D SETPROC^RORUTL20(DE,IENS,.RORUPD,.RORVALS)
  1. Q 0
  1. ;
  1. ;***** SETS THE EARLIEST DATE FOR THE RULE
  1. ;
  1. ; NAME Name of the selection rule
  1. ; COND Result value of the logical condition
  1. ;
  1. ; Return values:
  1. ; 0 COND equals to zero
  1. ; 1 COND is not zero
  1. ;
  1. SDF(NAME,COND) ;
  1. Q:'$G(COND) 0
  1. N DATE
  1. S DATE=$G(RORVALS("SV","ROR SRDT"))
  1. D:DATE>0
  1. . I $G(RORVALS("SV",NAME,"DTF"))'>0 D Q
  1. . . S RORVALS("SV",NAME,"DTF")=DATE
  1. . S:DATE<RORVALS("SV",NAME,"DTF") RORVALS("SV",NAME,"DTF")=DATE
  1. Q 1
  1. ;
  1. ;***** SETS THE LATEST DATE FOR THE RULE
  1. ;
  1. ; NAME Name of the selection rule
  1. ; COND Result value of the logical condition
  1. ;
  1. ; Return values:
  1. ; 0 COND equals to zero
  1. ; 1 COND is not zero
  1. ;
  1. SDL(NAME,COND) ;
  1. Q:'$G(COND) 0
  1. N DATE
  1. S DATE=$G(RORVALS("SV","ROR SRDT"))
  1. D:DATE>0
  1. . S:DATE>$G(RORVALS("SV",NAME,"DTL")) RORVALS("SV",NAME,"DTL")=DATE
  1. Q 1
  1. ;
  1. ;***** SETS VALUE OF THE SELECTION RULE
  1. ;
  1. ; RULENAME Name of the rule
  1. ; VALUE New value
  1. ;
  1. SETVAL(RULENAME,VALUE) ;
  1. S RORVALS("SV",RULENAME)=VALUE
  1. S RORVALS("SV",RULENAME,"CNT")=$G(RORVALS("SV",RULENAME,"CNT"))+1
  1. S RORVALS("SV",RULENAME,"SUM")=$G(RORVALS("SV",RULENAME,"SUM"))+VALUE
  1. S RORVALS("SV",RULENAME,"AVG")=RORVALS("SV",RULENAME,"SUM")/RORVALS("SV",RULENAME,"CNT")
  1. ;
  1. I $G(RORVALS("SV",RULENAME,"MIN"))="" S RORVALS("SV",RULENAME,"MIN")=VALUE
  1. E S:VALUE<RORVALS("SV",RULENAME,"MIN") RORVALS("SV",RULENAME,"MIN")=VALUE
  1. ;
  1. I $G(RORVALS("SV",RULENAME,"MAX"))="" S RORVALS("SV",RULENAME,"MAX")=VALUE
  1. E S:VALUE>RORVALS("SV",RULENAME,"MAX") RORVALS("SV",RULENAME,"MAX")=VALUE
  1. Q
  1. ;
  1. ;***** GETS THE TRIGGER DATE OF THE RULE
  1. ;
  1. ; NAME Name of the selection rule
  1. ; PFX Prefix of the value ("GDF" or "GDL")
  1. ; COND Result value of the logical condition
  1. ;
  1. ; Return values:
  1. ; 0 COND equals to zero
  1. ; 1 COND is not zero
  1. ;
  1. SRDT(NAME,PFX,COND) ;
  1. Q:'$G(COND) 0
  1. N DATE
  1. S DATE=$G(RORVALS("SV",NAME,$S(PFX="GDL":"DTL",1:"DTF")))
  1. I DATE S:DATE<$G(RORVALS("SV","ROR SRDT")) RORVALS("SV","ROR SRDT")=DATE
  1. Q 1
  1. ;
  1. LAST2YRS(RORDFN) ;any admission or visit dates in the last 2 years?
  1. ; RORDFN = dfn
  1. ;
  1. ;return: 0 - admission and visit dates are more than 2 years old
  1. ; 1 - admission and/or visit dates are less than 2 years old
  1. N RC,ROR2YRS,RORADATE,RORIENS,RORVDATE,RORREGI
  1. S RC=0,ROR2YRS=DT-20000
  1. S RORADATE=+$$LASTADM(RORDFN) ;most recent admission date (file 45)
  1. S RORVDATE=+$$LASTVSIT(RORDFN) ;most recent visit date (file 9000010)
  1. I (RORADATE>ROR2YRS)!(RORVDATE>ROR2YRS) S RC=1 Q RC
  1. S RORREGI=$$REGIEN^RORUTL02("VA RECENT PATIENTS") ;registry ien
  1. S RORIENS=$$PRRIEN^RORUTL01(RORDFN,RORREGI)_"," ;get 798 ien for patient and registry
  1. I +RORIENS'>0 S RC=0 Q RC
  1. S RC=$$DELETE(RORIENS)
  1. Q RC
  1. ;
  1. LASTADM(RORDFN) ;returns patient's last admission date
  1. ; RORDFN = DFN
  1. S RORDFN=+$G(RORDFN)
  1. Q $O(^DGPT("AAD",RORDFN,9999999),-1)
  1. ;
  1. LASTVSIT(RORDFN) ;returns patient's last visit date
  1. ; RORDFN = DFN
  1. N RORDATE
  1. S RORDFN=+$G(RORDFN)
  1. S RORDATE=$O(^AUPNVSIT("AA",RORDFN,""))
  1. I +RORDATE>0 S RORDATE=9999999-$P(RORDATE,".",1)
  1. Q RORDATE
  1. ;
  1. DELETE(RORIENS) ;set STATUS=5 (Deleted)
  1. N DIERR,RC,RORFDA,RORMSG
  1. S RC=0
  1. S RORFDA(798,RORIENS,3)=5
  1. D FILE^DIE(,"RORFDA","RORMSG")
  1. S:'$G(DIERR) RC=1
  1. I $G(DIERR) D ;RC=-1
  1. . S RC=$$ERROR^RORERR(-9,"DELETE^RORUPDUT","STATUS not set to 5 (Deleted)",,RORIENS)
  1. Q RC
  1. ;