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