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 Dec 13, 2024@01:43:49 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 ;
