RORUPD09 ;HCIOFO/SG - PROCESSING OF THE 'PTF' FILE ;8/3/05 9:50am
;;1.5;CLINICAL CASE REGISTRIES;**18,25,26,37**;Feb 17, 2006;Build 9
;
;*****************************************************************************
;*****************************************************************************
; --- ROUTINE MODIFICATION LOG ---
;
;PKG/PATCH DATE DEVELOPER MODIFICATION
;----------- ---------- ----------- ----------------------------------------
;ROR*1.5*18 APR 2012 C RAY Modified PTF RULE to use B xref #798.5
;ROR*1.5*25 FEB 2015 T KOPP Modified PTF rule to add new Diagnosis
; fields for ICD-10 PTF expansion.
;ROR*1.5*26 MAR 2015 T KOPP Added rule for PTF procedure codes check
; in API #3
;ROR*1.5*37 SEP 2020 F TRAXLER Added ALLPAT subroutine
;*****************************************************************************
;*****************************************************************************
; This routine uses the following IAs:
;
; #3157 RPC^DGPTFAPI
; #3545 Access to the "AAD" cross-reference and the field 80
; #10103 $$FMADD^XLFDT (supported)
; #2171 $$IEN^XUAF4 (supported)
;
;
Q
;
;***** LOADS DATA ELEMENT VALUES
;
; IENS IENS of the current record
;
; Return values:
; <0 Error code
; 0 Ok
;
LOAD(IENS) ;
N RC S RC=0
;--- API #1 or #3
I $S($D(RORUPD("SR",RORFILE,"F",1)):1,1:$D(RORUPD("SR",RORFILE,"F",3))) D Q:RC<0 RC
. S RC=$$LOADFLDS^RORUPDUT(RORFILE,IENS)
;--- API #2
I $D(RORUPD("SR",RORFILE,"F",2)) D Q:RC<0 RC
. N API,DE,IN,IP,RORBUF,VT
. D RPC^DGPTFAPI(.RORBUF,+IENS)
. I $G(RORBUF(0))<0 S API="RPC^DGPTFAPI" D Q
. . S RC=$$ERROR^RORERR(-57,,,,RORBUF(0),API)
. ;---
. S DE=""
. F S DE=$O(RORUPD("SR",RORFILE,"F",2,DE)) Q:DE="" D
. . S VT=""
. . F S VT=$O(RORUPD("SR",RORFILE,"F",2,DE,VT)) Q:VT="" D
. . . S IP=+$P(RORUPD("SR",RORFILE,"F",2,DE,VT),U,1) Q:IP'>0
. . . S IN=+$P(RORUPD("SR",RORFILE,"F",2,DE,VT),U,2)
. . . S RORVALS("DV",RORFILE,DE,VT)=$P($G(RORBUF(IN)),U,IP)
Q 0
;
;***** PROCESSING OF THE 'PTF' FILE
;
; UPDSTART Date of the earliest update
; PATIEN Patient IEN
;
; Return values:
; <0 Error code
; 0 Continue processing of the current patient
; 1 Stop processing
;
PTF(UPDSTART,PATIEN) ;
N RORFILE ; File number
;
N ADMDT,ADMIENS,EDT,IEN,LOCATION,NODE,RC,TMP
S RORFILE=45,EDT=RORUPD("DSEND")
;--- Check the event references if the events are enabled
I $G(RORUPD("FLAGS"))["E" D Q:RC'>0 RC
. S RC=$$GET^RORUPP02(PATIEN,3,.UPDSTART,.EDT)
. S:RC>1 UPDSTART=UPDSTART\1,EDT=$$FMADD^XLFDT(EDT\1,1)
;--- Subtract 1 second from the start date to include
; it into the interval
S ADMDT=$$FMADD^XLFDT(UPDSTART,,,,-1)
;
;--- Browse through the admissions
S NODE=RORUPD("ROOT",RORFILE),NODE=$NA(@NODE@("AAD",PATIEN))
S RC=0
F S ADMDT=$O(@NODE@(ADMDT)) Q:(ADMDT="")!(ADMDT'<EDT) D Q:RC
. S IEN=""
. F S IEN=$O(@NODE@(ADMDT,IEN)) Q:IEN="" D Q:RC
. . S ADMIENS=IEN_","
. . ;--- Load necessary data elements
. . I $D(RORUPD("SR",RORFILE,"F"))>1 D I TMP<0 D INCEC^RORUPDUT() Q
. . . S TMP=$$LOAD(ADMIENS)
. . . S TMP=$$GETDE^RORUPDUT(45,131)_$$GETDE^RORUPDUT(45,132)
. . . S LOCATION=$S(TMP'="":$$IEN^XUAF4(TMP),1:"")
. . ;--- Apply "before" rules
. . S RC=$$APLRULES^RORUPDUT(RORFILE,ADMIENS,"B",ADMDT,$G(LOCATION))
. . I RC D INCEC^RORUPDUT(.RC) Q
. . ;--- Apply "after" rules
. . S RC=$$APLRULES^RORUPDUT(RORFILE,ADMIENS,"A",ADMDT,$G(LOCATION))
. . I RC D INCEC^RORUPDUT(.RC) Q
;
D CLRDES^RORUPDUT(RORFILE)
Q RC
;
;***** IMPLEMENTATION OF THE 'PTF' Diagnosis RULE
PTFRULE(ICD) ;
N DATELMT,RC
S RC=0
F DATELMT=111,101:1:110,131:1:147 D Q:RC
. S RC=+$D(^ROR(798.5,REGIEN,1,"B",+$G(RORVALS("DV",45,DATELMT,"I"))))
Q RC
;
;***** IMPLEMENTATION OF THE 'PTF' Procedure RULE for ICD and CPT
PTFRULE1(REGIEN) ;
N ROR
S RC=0
I $D(^ROR(798.5,REGIEN,2,"B")) D Q:RC ;ICD procedure codes
. S ROR=0 F S ROR=$O(RORVALS("PPTF","I",ROR)) Q:'ROR I +$D(^ROR(798.5,REGIEN,2,"B",+$G(RORVALS("PPTF","I",ROR,"I")))) S RC=1 Q
I 'RC,$D(^ROR(798.5,REGIEN,3,"B")) D ;CPT procedure codes
. S ROR=0 F S ROR=$O(RORVALS("PPTF","C",ROR)) Q:'ROR I +$D(^ROR(798.5,REGIEN,3,"B",+$G(RORVALS("PPTF","C",ROR,"I")))) S RC=1 Q
Q RC
;
ALLPAT(REGIEN) ;Is Admission Date (#2) value less than 2 years old
N RC,ROR2YRS
S RC=0,ROR2YRS=DT-20000
I $D(RORVALS("DV",45,154,"I")) D
. I RORVALS("DV",45,154,"I")>ROR2YRS S RC=1
Q RC
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORUPD09 4767 printed Nov 22, 2024@16:53:57 Page 2
RORUPD09 ;HCIOFO/SG - PROCESSING OF THE 'PTF' FILE ;8/3/05 9:50am
+1 ;;1.5;CLINICAL CASE REGISTRIES;**18,25,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 Modified PTF RULE to use B xref #798.5
+10 ;ROR*1.5*25 FEB 2015 T KOPP Modified PTF rule to add new Diagnosis
+11 ; fields for ICD-10 PTF expansion.
+12 ;ROR*1.5*26 MAR 2015 T KOPP Added rule for PTF procedure codes check
+13 ; in API #3
+14 ;ROR*1.5*37 SEP 2020 F TRAXLER Added ALLPAT subroutine
+15 ;*****************************************************************************
+16 ;*****************************************************************************
+17 ; This routine uses the following IAs:
+18 ;
+19 ; #3157 RPC^DGPTFAPI
+20 ; #3545 Access to the "AAD" cross-reference and the field 80
+21 ; #10103 $$FMADD^XLFDT (supported)
+22 ; #2171 $$IEN^XUAF4 (supported)
+23 ;
+24 ;
+25 QUIT
+26 ;
+27 ;***** LOADS DATA ELEMENT VALUES
+28 ;
+29 ; IENS IENS of the current record
+30 ;
+31 ; Return values:
+32 ; <0 Error code
+33 ; 0 Ok
+34 ;
LOAD(IENS) ;
+1 NEW RC
SET RC=0
+2 ;--- API #1 or #3
+3 IF $SELECT($DATA(RORUPD("SR",RORFILE,"F",1)):1,1:$DATA(RORUPD("SR",RORFILE,"F",3)))
Begin DoDot:1
+4 SET RC=$$LOADFLDS^RORUPDUT(RORFILE,IENS)
End DoDot:1
if RC<0
QUIT RC
+5 ;--- API #2
+6 IF $DATA(RORUPD("SR",RORFILE,"F",2))
Begin DoDot:1
+7 NEW API,DE,IN,IP,RORBUF,VT
+8 DO RPC^DGPTFAPI(.RORBUF,+IENS)
+9 IF $GET(RORBUF(0))<0
SET API="RPC^DGPTFAPI"
Begin DoDot:2
+10 SET RC=$$ERROR^RORERR(-57,,,,RORBUF(0),API)
End DoDot:2
QUIT
+11 ;---
+12 SET DE=""
+13 FOR
SET DE=$ORDER(RORUPD("SR",RORFILE,"F",2,DE))
if DE=""
QUIT
Begin DoDot:2
+14 SET VT=""
+15 FOR
SET VT=$ORDER(RORUPD("SR",RORFILE,"F",2,DE,VT))
if VT=""
QUIT
Begin DoDot:3
+16 SET IP=+$PIECE(RORUPD("SR",RORFILE,"F",2,DE,VT),U,1)
if IP'>0
QUIT
+17 SET IN=+$PIECE(RORUPD("SR",RORFILE,"F",2,DE,VT),U,2)
+18 SET RORVALS("DV",RORFILE,DE,VT)=$PIECE($GET(RORBUF(IN)),U,IP)
End DoDot:3
End DoDot:2
End DoDot:1
if RC<0
QUIT RC
+19 QUIT 0
+20 ;
+21 ;***** PROCESSING OF THE 'PTF' FILE
+22 ;
+23 ; UPDSTART Date of the earliest update
+24 ; PATIEN Patient IEN
+25 ;
+26 ; Return values:
+27 ; <0 Error code
+28 ; 0 Continue processing of the current patient
+29 ; 1 Stop processing
+30 ;
PTF(UPDSTART,PATIEN) ;
+1 ; File number
NEW RORFILE
+2 ;
+3 NEW ADMDT,ADMIENS,EDT,IEN,LOCATION,NODE,RC,TMP
+4 SET RORFILE=45
SET EDT=RORUPD("DSEND")
+5 ;--- Check the event references if the events are enabled
+6 IF $GET(RORUPD("FLAGS"))["E"
Begin DoDot:1
+7 SET RC=$$GET^RORUPP02(PATIEN,3,.UPDSTART,.EDT)
+8 if RC>1
SET UPDSTART=UPDSTART\1
SET EDT=$$FMADD^XLFDT(EDT\1,1)
End DoDot:1
if RC'>0
QUIT RC
+9 ;--- Subtract 1 second from the start date to include
+10 ; it into the interval
+11 SET ADMDT=$$FMADD^XLFDT(UPDSTART,,,,-1)
+12 ;
+13 ;--- Browse through the admissions
+14 SET NODE=RORUPD("ROOT",RORFILE)
SET NODE=$NAME(@NODE@("AAD",PATIEN))
+15 SET RC=0
+16 FOR
SET ADMDT=$ORDER(@NODE@(ADMDT))
if (ADMDT="")!(ADMDT'<EDT)
QUIT
Begin DoDot:1
+17 SET IEN=""
+18 FOR
SET IEN=$ORDER(@NODE@(ADMDT,IEN))
if IEN=""
QUIT
Begin DoDot:2
+19 SET ADMIENS=IEN_","
+20 ;--- Load necessary data elements
+21 IF $DATA(RORUPD("SR",RORFILE,"F"))>1
Begin DoDot:3
+22 SET TMP=$$LOAD(ADMIENS)
+23 SET TMP=$$GETDE^RORUPDUT(45,131)_$$GETDE^RORUPDUT(45,132)
+24 SET LOCATION=$SELECT(TMP'="":$$IEN^XUAF4(TMP),1:"")
End DoDot:3
IF TMP<0
DO INCEC^RORUPDUT()
QUIT
+25 ;--- Apply "before" rules
+26 SET RC=$$APLRULES^RORUPDUT(RORFILE,ADMIENS,"B",ADMDT,$GET(LOCATION))
+27 IF RC
DO INCEC^RORUPDUT(.RC)
QUIT
+28 ;--- Apply "after" rules
+29 SET RC=$$APLRULES^RORUPDUT(RORFILE,ADMIENS,"A",ADMDT,$GET(LOCATION))
+30 IF RC
DO INCEC^RORUPDUT(.RC)
QUIT
End DoDot:2
if RC
QUIT
End DoDot:1
if RC
QUIT
+31 ;
+32 DO CLRDES^RORUPDUT(RORFILE)
+33 QUIT RC
+34 ;
+35 ;***** IMPLEMENTATION OF THE 'PTF' Diagnosis RULE
PTFRULE(ICD) ;
+1 NEW DATELMT,RC
+2 SET RC=0
+3 FOR DATELMT=111,101:1:110,131:1:147
Begin DoDot:1
+4 SET RC=+$DATA(^ROR(798.5,REGIEN,1,"B",+$GET(RORVALS("DV",45,DATELMT,"I"))))
End DoDot:1
if RC
QUIT
+5 QUIT RC
+6 ;
+7 ;***** IMPLEMENTATION OF THE 'PTF' Procedure RULE for ICD and CPT
PTFRULE1(REGIEN) ;
+1 NEW ROR
+2 SET RC=0
+3 ;ICD procedure codes
IF $DATA(^ROR(798.5,REGIEN,2,"B"))
Begin DoDot:1
+4 SET ROR=0
FOR
SET ROR=$ORDER(RORVALS("PPTF","I",ROR))
if 'ROR
QUIT
IF +$DATA(^ROR(798.5,REGIEN,2,"B",+$GET(RORVALS("PPTF","I",ROR,"I"))))
SET RC=1
QUIT
End DoDot:1
if RC
QUIT
+5 ;CPT procedure codes
IF 'RC
IF $DATA(^ROR(798.5,REGIEN,3,"B"))
Begin DoDot:1
+6 SET ROR=0
FOR
SET ROR=$ORDER(RORVALS("PPTF","C",ROR))
if 'ROR
QUIT
IF +$DATA(^ROR(798.5,REGIEN,3,"B",+$GET(RORVALS("PPTF","C",ROR,"I"))))
SET RC=1
QUIT
End DoDot:1
+7 QUIT RC
+8 ;
ALLPAT(REGIEN) ;Is Admission Date (#2) value less than 2 years old
+1 NEW RC,ROR2YRS
+2 SET RC=0
SET ROR2YRS=DT-20000
+3 IF $DATA(RORVALS("DV",45,154,"I"))
Begin DoDot:1
+4 IF RORVALS("DV",45,154,"I")>ROR2YRS
SET RC=1
End DoDot:1
+5 QUIT RC
+6 ;
