RORX001 ;HOIFO/SG,VAC - LIST OF REGISTRY PATIENTS ;4/16/09 11:53am
;;1.5;CLINICAL CASE REGISTRIES;**8,10,14,17,19,21,31,39**;Feb 17, 2006;Build 4
;
; This routine uses the following IAs:
;
; #2051 LIST^DIC (supported)
; #2056 GET1^DIQ, GETS^DIQ (supported)
; #10061 DEM^VADPT (supported)
; #10103 FMADD^XLFDT (supported)
;
; This routine modified March 2009 to handle ICD9 Filter for Include
; or Exclude
Q
;******************************************************************************
;******************************************************************************
; --- ROUTINE MODIFICATION LOG ---
;
;PKG/PATCH DATE DEVELOPER MODIFICATION
;----------- ---------- ----------- ----------------------------------------
;ROR*1.5*14 APR 2011 A SAUNDERS Added column and data for 'FIRSTDIAG'.
;ROR*1.5*17 AUG 2011 C RAY Added params 'CONFIRM_AFTER', 'CONFDT_AFTER'
;ROR*1.5*19 FEB 2012 K GUPTA Support for ICD-10 Coding System
;ROR*1.5*21 SEP 2013 T KOPP Added ICN as last report column if
; additional identifier option selected
;ROR*1.5*31 MAY 2017 M FERRARESE Adding PACT and PCP as additional identifiers.
;ROR*1.5*39 JUL 2021 M FERRARESE Setting SSN and LAST4 to zeros
;******************************************************************************
;******************************************************************************
;
;***** OUTPUTS THE REPORT HEADER
;
; PARTAG Reference (IEN) to the parent tag
;
; Return Values:
; <0 Error code
; 0 Ok
;
N COL,COLUMNS,HEADER,TMP,AGETYPE
S HEADER=$$HEADER^RORXU002(.RORTSK,PARTAG)
S COLUMNS=$$ADDVAL^RORTSK11(RORTSK,"TBLDEF",,HEADER)
D ADDATTR^RORTSK11(RORTSK,COLUMNS,"NAME","PATIENTS")
D ADDATTR^RORTSK11(RORTSK,COLUMNS,"HEADER","1")
D ADDATTR^RORTSK11(RORTSK,COLUMNS,"FOOTER","1")
S RORFLDS=".01"
;--- Required columns
F COL="#","NAME" D
. S TMP=$$ADDVAL^RORTSK11(RORTSK,"COLUMN",,COLUMNS)
. D ADDATTR^RORTSK11(RORTSK,TMP,"NAME",COL)
;--- Age/DOB header if needed
S AGETYPE=$$PARAM^RORTSK01("AGE_RANGE","TYPE") I AGETYPE'="ALL" D
. S TMP=$$ADDVAL^RORTSK11(RORTSK,"COLUMN",,COLUMNS)
. D ADDATTR^RORTSK11(RORTSK,TMP,"NAME",AGETYPE)
;
;--- Additional columns
F COL="DOD","CSSN","LAST4","SELRULES","SELDT","CONFDT","PENDCOMM","FIRSTDIAG" D
. Q:'$$OPTCOL^RORXU006(COL)
. S TMP=$$ADDVAL^RORTSK11(RORTSK,"COLUMN",,COLUMNS)
. D ADDATTR^RORTSK11(RORTSK,TMP,"NAME",COL)
; --- ICN if selected must be last column on report
I $$PARAM^RORTSK01("PATIENTS","ICN") D ICNHDR^RORXU006(RORTSK,COLUMNS)
I $$PARAM^RORTSK01("PATIENTS","PACT") D PACTHDR^RORXU006(RORTSK,COLUMNS)
I $$PARAM^RORTSK01("PATIENTS","PCP") D PCPHDR^RORXU006(RORTSK,COLUMNS)
;---
S:$$OPTCOL^RORXU006("CONFDT") RORFLDS=RORFLDS_";2"
S:$$OPTCOL^RORXU006("SELDT") RORFLDS=RORFLDS_";3.2"
S:$$OPTCOL^RORXU006("PENDCOMM") RORFLDS=RORFLDS_";12"
Q 0
;
;***** ADDS THE PATIENT DATA TO THE REPORT
;
; IENS IENS of the patient's record in the registry
; PARTAG Reference (IEN) to the parent tag
;
; Return Values:
; <0 Error code
; 0 Ok
;
PATIENT(IENS,PARTAG) ;
N DFN,IATIME,NAME,RC,RORBUF,RORMSG,TMP,VA,VADM,VAHOW,VAROOT,PTAG,AGETYPE,AGE
K RORMSG D GETS^DIQ(798,IENS,RORFLDS,"I","RORBUF","RORMSG")
Q:$G(RORMSG("DIERR")) $$DBS^RORERR("RORMSG",-9,,,798,IENS)
S DFN=$G(RORBUF(798,IENS,.01,"I"))
;--- Load the demographic data
D DEM^VADPT
;--- The <PATIENT> tag
S PTAG=$$ADDVAL^RORTSK11(RORTSK,"PATIENT",,PARTAG,,DFN)
;--- Patient Name
D ADDVAL^RORTSK11(RORTSK,"NAME",VADM(1),PTAG,1)
;--- Age/DOB
I $$PARAM^RORTSK01("AGE_RANGE","TYPE")'="ALL" S AGETYPE=$$PARAM^RORTSK01("AGE_RANGE","TYPE") D
. S AGE=$S(AGETYPE="AGE":$P(VADM(4),U),AGETYPE="DOB":$$DATE^RORXU002($P(VADM(3),U)\1),1:"")
. D ADDVAL^RORTSK11(RORTSK,AGETYPE,AGE,PTAG,1)
;
;--- Date of Death
D:$$OPTCOL^RORXU006("DOD")
. S TMP=$$DATE^RORXU002(VADM(6)\1)
. D ADDVAL^RORTSK11(RORTSK,"DOD",TMP,PTAG,1)
;--- Coded SSN
D:$$OPTCOL^RORXU006("CSSN")
. S TMP="000000000"
. D ADDVAL^RORTSK11(RORTSK,"CSSN",TMP,PTAG,1)
;--- Last 4 digits of the SSN
D:$$OPTCOL^RORXU006("LAST4")
. S VA("BID")="0000" D ADDVAL^RORTSK11(RORTSK,"LAST4",VA("BID"),PTAG,2)
;--- Selection Rules
I $$OPTCOL^RORXU006("SELRULES") D Q:RC<0 RC
. S RC=$$SELRULES(IENS,PTAG)
;--- Date Selected for the Registry
D:$$OPTCOL^RORXU006("SELDT")
. S TMP=$$DATE^RORXU002($G(RORBUF(798,IENS,3.2,"I"))\1)
. D ADDVAL^RORTSK11(RORTSK,"SELDT",TMP,PTAG,1)
;--- Date Confirmed in the Registry
D:$$OPTCOL^RORXU006("CONFDT")
. S TMP=$$DATE^RORXU002($G(RORBUF(798,IENS,2,"I"))\1)
. D ADDVAL^RORTSK11(RORTSK,"CONFDT",TMP,PTAG,1)
;--- Pending Comment
D:$$OPTCOL^RORXU006("PENDCOMM")
. S TMP=$G(RORBUF(798,IENS,12,"I"))
. S TMP=$S($L(TMP)>0:TMP,1:"")
. D ADDVAL^RORTSK11(RORTSK,"PENDCOMM",TMP,PTAG,1)
;--- First Healthcare Setting to Diagnose HIV
D:$$OPTCOL^RORXU006("FIRSTDIAG")
. K RORBUF,RORMSG D GETS^DIQ(799.4,IENS,12.08,"I","RORBUF","RORMSG")
. S TMP=$G(RORBUF(799.4,IENS,12.08,"I"))
. S TMP=$S($G(TMP)=1:"Yes",$G(TMP)=0:"No",$G(TMP)=9:"Unknown",1:"")
. D ADDVAL^RORTSK11(RORTSK,"FIRSTDIAG",$G(TMP),PTAG,1)
;--- ICN
I $$PARAM^RORTSK01("PATIENTS","ICN") D
. S:'$D(DFN) DFN=$G(RORBUF(798,IENS,.01,"I"))
. D ICNDATA^RORXU006(RORTSK,DFN,PTAG)
;
;--- PACT
I $$PARAM^RORTSK01("PATIENTS","PACT") D
. S:'$D(DFN) DFN=$G(RORBUF(798,IENS,.01,"I"))
. D PACTDATA^RORXU006(RORTSK,DFN,PTAG)
;
;--- PCP
I $$PARAM^RORTSK01("PATIENTS","PCP") D
. S:'$D(DFN) DFN=$G(RORBUF(798,IENS,.01,"I"))
. D PCPDATA^RORXU006(RORTSK,DFN,PTAG)
Q 0
;
;***** COMPILES A LIST OF REGISTRY PATIENTS
; REPORT CODE: 001
;
; .RORTSK Task number and task parameters
;
; Return Values:
; <0 Error code
; 0 Ok
;
REGPTLST(RORTSK) ;
N RORFLDS ; Fields to load from the file #798
N RORPTN ; Number of patients in the registry
N RORREG ; Registry IEN
;
N BODY,CNT,ECNT,IEN,IENS,MODE,PTNAME,RC,REPORT,SFLAGS,TMP,XREFNODE
N RCC,FLAG,RORCDT,PARAMS
;--- Root node of the report
S REPORT=$$ADDVAL^RORTSK11(RORTSK,"REPORT")
Q:REPORT<0 REPORT
;
;--- Get and prepare the report parameters
S RORREG=$$PARAM^RORTSK01("REGIEN")
S PARAMS=$$PARAMS^RORXU002(.RORTSK,REPORT,,,.SFLAGS) Q:PARAMS<0 PARAMS
S SFLAGS=$TR(SFLAGS,"DG")
I '$$PARAM^RORTSK01("PATIENTS","CONFIRMED"),'$$PARAM^RORTSK01("PATIENTS","CONFIRM_AFTER") S SFLAGS=SFLAGS_"C"
S:'$$PARAM^RORTSK01("PATIENTS","PENDING") SFLAGS=SFLAGS_"G"
S RORCDT=$$PARAM^RORTSK01("PATIENTS","CONFDT_AFTER")
D ADDVAL^RORTSK11(RORTSK,"TYPE",SFLAGS,REPORT)
;--- After date range
I RORCDT D
. S SFLAGS=SFLAGS_"P"
. S RORCDT=$$FMADD^XLFDT(RORCDT,1) ;add one day
;
;--- Initialize constants and variables
S RORPTN=$$REGSIZE^RORUTL02(+RORREG) S:RORPTN<0 RORPTN=0
S ECNT=0,XREFNODE=$NA(^RORDATA(798,"ARP",RORREG_"#"))
;
;--- The report header and list of patients
S RC=$$HEADER(REPORT) Q:RC<0 RC
S BODY=$$ADDVAL^RORTSK11(RORTSK,"PATIENTS",,REPORT)
D ADDATTR^RORTSK11(RORTSK,BODY,"TABLE","PATIENTS")
Q:BODY<0 BODY
;
;--- Browse through the registry records
S PTNAME="",(CNT,RC)=0
S FLAG=$G(RORTSK("PARAMS","ICDFILT","A","FILTER"))
F S PTNAME=$O(@XREFNODE@(PTNAME)) Q:PTNAME="" D Q:RC<0
. S IEN=0
. F S IEN=$O(@XREFNODE@(PTNAME,IEN)) Q:IEN'>0 D Q:RC<0
. . S TMP=$S(RORPTN>0:CNT/RORPTN,1:"")
. . S RC=$$LOOP^RORTSK01(TMP) Q:RC<0
. . S IENS=IEN_",",CNT=CNT+1
. . ;--- Check if the patient should be skipped
. . Q:$$SKIP^RORXU005(IEN,SFLAGS,RORCDT)
. .;--- Check the patient against the ICD Filter
. . S DFN=$$PTIEN^RORUTL01(+IENS)
. . S RCC=0
. . I FLAG'="ALL" D
. . . S RCC=$$ICD^RORXU010(DFN)
. . I (FLAG="INCLUDE")&(RCC=0) Q
. . I (FLAG="EXCLUDE")&(RCC=1) Q
. .;--- End of filter check
. . ;--- Process the registry record
. . I $$PATIENT(IENS,BODY)<0 S ECNT=ECNT+1 Q
;---
Q $S(RC<0:RC,ECNT>0:-43,1:0)
;
;***** ADDS THE SELECTION RULES TO THE REPORT
;
; IENS IENS of the patient's record in the registry
; PARTAG Reference (IEN) to the parent tag
;
; Return Values:
; <0 Error code
; 0 Ok
;
SELRULES(IENS,PARTAG) ;
N CNT,I,RORBUF,RORMSG,RT,SRLTAG,TMP
;--- Load the list of selection rules
K RORMSG D LIST^DIC(798.01,","_IENS,"@;.01I;1I",,,,,"B",,,"RORBUF","RORMSG")
;Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,,798.01,IENS)
Q:$G(RORMSG("DIERR")) $$DBS^RORERR("RORMSG",-9,,,798.01,IENS)
;--- The <SELRULES> ... </SELRULES> tags
S SRLTAG=$$ADDVAL^RORTSK11(RORTSK,"SELRULES",,PARTAG)
;--- Add the selection rules to the report
S I="",CNT=0
F S I=$O(RORBUF("DILIST","ID",I)) Q:I="" D
. S RT=$$ADDVAL^RORTSK11(RORTSK,"RULE",,SRLTAG),CNT=CNT+1
. S TMP=$G(RORBUF("DILIST","ID",I,.01))
. K RORMSG S TMP=$$GET1^DIQ(798.2,TMP_",",4,,,"RORMSG")
. ;Q:$G(DIERR)!(TMP="")
. Q:$G(RORMSG("DIERR"))!(TMP="")
. D ADDATTR^RORTSK11(RORTSK,RT,"DESCR",TMP)
. S TMP=$$DATE^RORXU002($G(RORBUF("DILIST","ID",I,1))\1)
. D:TMP'="" ADDATTR^RORTSK11(RORTSK,RT,"DATE",TMP)
;--- Add the default item if no selection rules have been found
D:CNT'>0
. S RT=$$ADDVAL^RORTSK11(RORTSK,"RULE",,SRLTAG)
. D ADDATTR^RORTSK11(RORTSK,RT,"DESCR","Manual Entry")
;
Q 0
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORX001 9517 printed Dec 13, 2024@01:44:16 Page 2
RORX001 ;HOIFO/SG,VAC - LIST OF REGISTRY PATIENTS ;4/16/09 11:53am
+1 ;;1.5;CLINICAL CASE REGISTRIES;**8,10,14,17,19,21,31,39**;Feb 17, 2006;Build 4
+2 ;
+3 ; This routine uses the following IAs:
+4 ;
+5 ; #2051 LIST^DIC (supported)
+6 ; #2056 GET1^DIQ, GETS^DIQ (supported)
+7 ; #10061 DEM^VADPT (supported)
+8 ; #10103 FMADD^XLFDT (supported)
+9 ;
+10 ; This routine modified March 2009 to handle ICD9 Filter for Include
+11 ; or Exclude
+12 QUIT
+13 ;******************************************************************************
+14 ;******************************************************************************
+15 ; --- ROUTINE MODIFICATION LOG ---
+16 ;
+17 ;PKG/PATCH DATE DEVELOPER MODIFICATION
+18 ;----------- ---------- ----------- ----------------------------------------
+19 ;ROR*1.5*14 APR 2011 A SAUNDERS Added column and data for 'FIRSTDIAG'.
+20 ;ROR*1.5*17 AUG 2011 C RAY Added params 'CONFIRM_AFTER', 'CONFDT_AFTER'
+21 ;ROR*1.5*19 FEB 2012 K GUPTA Support for ICD-10 Coding System
+22 ;ROR*1.5*21 SEP 2013 T KOPP Added ICN as last report column if
+23 ; additional identifier option selected
+24 ;ROR*1.5*31 MAY 2017 M FERRARESE Adding PACT and PCP as additional identifiers.
+25 ;ROR*1.5*39 JUL 2021 M FERRARESE Setting SSN and LAST4 to zeros
+26 ;******************************************************************************
+27 ;******************************************************************************
+28 ;
+29 ;***** OUTPUTS THE REPORT HEADER
+30 ;
+31 ; PARTAG Reference (IEN) to the parent tag
+32 ;
+33 ; Return Values:
+34 ; <0 Error code
+35 ; 0 Ok
+36 ;
+1 NEW COL,COLUMNS,HEADER,TMP,AGETYPE
+2 SET HEADER=$$HEADER^RORXU002(.RORTSK,PARTAG)
+3 SET COLUMNS=$$ADDVAL^RORTSK11(RORTSK,"TBLDEF",,HEADER)
+4 DO ADDATTR^RORTSK11(RORTSK,COLUMNS,"NAME","PATIENTS")
+5 DO ADDATTR^RORTSK11(RORTSK,COLUMNS,"HEADER","1")
+6 DO ADDATTR^RORTSK11(RORTSK,COLUMNS,"FOOTER","1")
+7 SET RORFLDS=".01"
+8 ;--- Required columns
+9 FOR COL="#","NAME"
Begin DoDot:1
+10 SET TMP=$$ADDVAL^RORTSK11(RORTSK,"COLUMN",,COLUMNS)
+11 DO ADDATTR^RORTSK11(RORTSK,TMP,"NAME",COL)
End DoDot:1
+12 ;--- Age/DOB header if needed
+13 SET AGETYPE=$$PARAM^RORTSK01("AGE_RANGE","TYPE")
IF AGETYPE'="ALL"
Begin DoDot:1
+14 SET TMP=$$ADDVAL^RORTSK11(RORTSK,"COLUMN",,COLUMNS)
+15 DO ADDATTR^RORTSK11(RORTSK,TMP,"NAME",AGETYPE)
End DoDot:1
+16 ;
+17 ;--- Additional columns
+18 FOR COL="DOD","CSSN","LAST4","SELRULES","SELDT","CONFDT","PENDCOMM","FIRSTDIAG"
Begin DoDot:1
+19 if '$$OPTCOL^RORXU006(COL)
QUIT
+20 SET TMP=$$ADDVAL^RORTSK11(RORTSK,"COLUMN",,COLUMNS)
+21 DO ADDATTR^RORTSK11(RORTSK,TMP,"NAME",COL)
End DoDot:1
+22 ; --- ICN if selected must be last column on report
+23 IF $$PARAM^RORTSK01("PATIENTS","ICN")
DO ICNHDR^RORXU006(RORTSK,COLUMNS)
+24 IF $$PARAM^RORTSK01("PATIENTS","PACT")
DO PACTHDR^RORXU006(RORTSK,COLUMNS)
+25 IF $$PARAM^RORTSK01("PATIENTS","PCP")
DO PCPHDR^RORXU006(RORTSK,COLUMNS)
+26 ;---
+27 if $$OPTCOL^RORXU006("CONFDT")
SET RORFLDS=RORFLDS_";2"
+28 if $$OPTCOL^RORXU006("SELDT")
SET RORFLDS=RORFLDS_";3.2"
+29 if $$OPTCOL^RORXU006("PENDCOMM")
SET RORFLDS=RORFLDS_";12"
+30 QUIT 0
+31 ;
+32 ;***** ADDS THE PATIENT DATA TO THE REPORT
+33 ;
+34 ; IENS IENS of the patient's record in the registry
+35 ; PARTAG Reference (IEN) to the parent tag
+36 ;
+37 ; Return Values:
+38 ; <0 Error code
+39 ; 0 Ok
+40 ;
PATIENT(IENS,PARTAG) ;
+1 NEW DFN,IATIME,NAME,RC,RORBUF,RORMSG,TMP,VA,VADM,VAHOW,VAROOT,PTAG,AGETYPE,AGE
+2 KILL RORMSG
DO GETS^DIQ(798,IENS,RORFLDS,"I","RORBUF","RORMSG")
+3 if $GET(RORMSG("DIERR"))
QUIT $$DBS^RORERR("RORMSG",-9,,,798,IENS)
+4 SET DFN=$GET(RORBUF(798,IENS,.01,"I"))
+5 ;--- Load the demographic data
+6 DO DEM^VADPT
+7 ;--- The <PATIENT> tag
+8 SET PTAG=$$ADDVAL^RORTSK11(RORTSK,"PATIENT",,PARTAG,,DFN)
+9 ;--- Patient Name
+10 DO ADDVAL^RORTSK11(RORTSK,"NAME",VADM(1),PTAG,1)
+11 ;--- Age/DOB
+12 IF $$PARAM^RORTSK01("AGE_RANGE","TYPE")'="ALL"
SET AGETYPE=$$PARAM^RORTSK01("AGE_RANGE","TYPE")
Begin DoDot:1
+13 SET AGE=$SELECT(AGETYPE="AGE":$PIECE(VADM(4),U),AGETYPE="DOB":$$DATE^RORXU002($PIECE(VADM(3),U)\1),1:"")
+14 DO ADDVAL^RORTSK11(RORTSK,AGETYPE,AGE,PTAG,1)
End DoDot:1
+15 ;
+16 ;--- Date of Death
+17 if $$OPTCOL^RORXU006("DOD")
Begin DoDot:1
+18 SET TMP=$$DATE^RORXU002(VADM(6)\1)
+19 DO ADDVAL^RORTSK11(RORTSK,"DOD",TMP,PTAG,1)
End DoDot:1
+20 ;--- Coded SSN
+21 if $$OPTCOL^RORXU006("CSSN")
Begin DoDot:1
+22 SET TMP="000000000"
+23 DO ADDVAL^RORTSK11(RORTSK,"CSSN",TMP,PTAG,1)
End DoDot:1
+24 ;--- Last 4 digits of the SSN
+25 if $$OPTCOL^RORXU006("LAST4")
Begin DoDot:1
+26 SET VA("BID")="0000"
DO ADDVAL^RORTSK11(RORTSK,"LAST4",VA("BID"),PTAG,2)
End DoDot:1
+27 ;--- Selection Rules
+28 IF $$OPTCOL^RORXU006("SELRULES")
Begin DoDot:1
+29 SET RC=$$SELRULES(IENS,PTAG)
End DoDot:1
if RC<0
QUIT RC
+30 ;--- Date Selected for the Registry
+31 if $$OPTCOL^RORXU006("SELDT")
Begin DoDot:1
+32 SET TMP=$$DATE^RORXU002($GET(RORBUF(798,IENS,3.2,"I"))\1)
+33 DO ADDVAL^RORTSK11(RORTSK,"SELDT",TMP,PTAG,1)
End DoDot:1
+34 ;--- Date Confirmed in the Registry
+35 if $$OPTCOL^RORXU006("CONFDT")
Begin DoDot:1
+36 SET TMP=$$DATE^RORXU002($GET(RORBUF(798,IENS,2,"I"))\1)
+37 DO ADDVAL^RORTSK11(RORTSK,"CONFDT",TMP,PTAG,1)
End DoDot:1
+38 ;--- Pending Comment
+39 if $$OPTCOL^RORXU006("PENDCOMM")
Begin DoDot:1
+40 SET TMP=$GET(RORBUF(798,IENS,12,"I"))
+41 SET TMP=$SELECT($LENGTH(TMP)>0:TMP,1:"")
+42 DO ADDVAL^RORTSK11(RORTSK,"PENDCOMM",TMP,PTAG,1)
End DoDot:1
+43 ;--- First Healthcare Setting to Diagnose HIV
+44 if $$OPTCOL^RORXU006("FIRSTDIAG")
Begin DoDot:1
+45 KILL RORBUF,RORMSG
DO GETS^DIQ(799.4,IENS,12.08,"I","RORBUF","RORMSG")
+46 SET TMP=$GET(RORBUF(799.4,IENS,12.08,"I"))
+47 SET TMP=$SELECT($GET(TMP)=1:"Yes",$GET(TMP)=0:"No",$GET(TMP)=9:"Unknown",1:"")
+48 DO ADDVAL^RORTSK11(RORTSK,"FIRSTDIAG",$GET(TMP),PTAG,1)
End DoDot:1
+49 ;--- ICN
+50 IF $$PARAM^RORTSK01("PATIENTS","ICN")
Begin DoDot:1
+51 if '$DATA(DFN)
SET DFN=$GET(RORBUF(798,IENS,.01,"I"))
+52 DO ICNDATA^RORXU006(RORTSK,DFN,PTAG)
End DoDot:1
+53 ;
+54 ;--- PACT
+55 IF $$PARAM^RORTSK01("PATIENTS","PACT")
Begin DoDot:1
+56 if '$DATA(DFN)
SET DFN=$GET(RORBUF(798,IENS,.01,"I"))
+57 DO PACTDATA^RORXU006(RORTSK,DFN,PTAG)
End DoDot:1
+58 ;
+59 ;--- PCP
+60 IF $$PARAM^RORTSK01("PATIENTS","PCP")
Begin DoDot:1
+61 if '$DATA(DFN)
SET DFN=$GET(RORBUF(798,IENS,.01,"I"))
+62 DO PCPDATA^RORXU006(RORTSK,DFN,PTAG)
End DoDot:1
+63 QUIT 0
+64 ;
+65 ;***** COMPILES A LIST OF REGISTRY PATIENTS
+66 ; REPORT CODE: 001
+67 ;
+68 ; .RORTSK Task number and task parameters
+69 ;
+70 ; Return Values:
+71 ; <0 Error code
+72 ; 0 Ok
+73 ;
REGPTLST(RORTSK) ;
+1 ; Fields to load from the file #798
NEW RORFLDS
+2 ; Number of patients in the registry
NEW RORPTN
+3 ; Registry IEN
NEW RORREG
+4 ;
+5 NEW BODY,CNT,ECNT,IEN,IENS,MODE,PTNAME,RC,REPORT,SFLAGS,TMP,XREFNODE
+6 NEW RCC,FLAG,RORCDT,PARAMS
+7 ;--- Root node of the report
+8 SET REPORT=$$ADDVAL^RORTSK11(RORTSK,"REPORT")
+9 if REPORT<0
QUIT REPORT
+10 ;
+11 ;--- Get and prepare the report parameters
+12 SET RORREG=$$PARAM^RORTSK01("REGIEN")
+13 SET PARAMS=$$PARAMS^RORXU002(.RORTSK,REPORT,,,.SFLAGS)
if PARAMS<0
QUIT PARAMS
+14 SET SFLAGS=$TRANSLATE(SFLAGS,"DG")
+15 IF '$$PARAM^RORTSK01("PATIENTS","CONFIRMED")
IF '$$PARAM^RORTSK01("PATIENTS","CONFIRM_AFTER")
SET SFLAGS=SFLAGS_"C"
+16 if '$$PARAM^RORTSK01("PATIENTS","PENDING")
SET SFLAGS=SFLAGS_"G"
+17 SET RORCDT=$$PARAM^RORTSK01("PATIENTS","CONFDT_AFTER")
+18 DO ADDVAL^RORTSK11(RORTSK,"TYPE",SFLAGS,REPORT)
+19 ;--- After date range
+20 IF RORCDT
Begin DoDot:1
+21 SET SFLAGS=SFLAGS_"P"
+22 ;add one day
SET RORCDT=$$FMADD^XLFDT(RORCDT,1)
End DoDot:1
+23 ;
+24 ;--- Initialize constants and variables
+25 SET RORPTN=$$REGSIZE^RORUTL02(+RORREG)
if RORPTN<0
SET RORPTN=0
+26 SET ECNT=0
SET XREFNODE=$NAME(^RORDATA(798,"ARP",RORREG_"#"))
+27 ;
+28 ;--- The report header and list of patients
+29 SET RC=$$HEADER(REPORT)
if RC<0
QUIT RC
+30 SET BODY=$$ADDVAL^RORTSK11(RORTSK,"PATIENTS",,REPORT)
+31 DO ADDATTR^RORTSK11(RORTSK,BODY,"TABLE","PATIENTS")
+32 if BODY<0
QUIT BODY
+33 ;
+34 ;--- Browse through the registry records
+35 SET PTNAME=""
SET (CNT,RC)=0
+36 SET FLAG=$GET(RORTSK("PARAMS","ICDFILT","A","FILTER"))
+37 FOR
SET PTNAME=$ORDER(@XREFNODE@(PTNAME))
if PTNAME=""
QUIT
Begin DoDot:1
+38 SET IEN=0
+39 FOR
SET IEN=$ORDER(@XREFNODE@(PTNAME,IEN))
if IEN'>0
QUIT
Begin DoDot:2
+40 SET TMP=$SELECT(RORPTN>0:CNT/RORPTN,1:"")
+41 SET RC=$$LOOP^RORTSK01(TMP)
if RC<0
QUIT
+42 SET IENS=IEN_","
SET CNT=CNT+1
+43 ;--- Check if the patient should be skipped
+44 if $$SKIP^RORXU005(IEN,SFLAGS,RORCDT)
QUIT
+45 ;--- Check the patient against the ICD Filter
+46 SET DFN=$$PTIEN^RORUTL01(+IENS)
+47 SET RCC=0
+48 IF FLAG'="ALL"
Begin DoDot:3
+49 SET RCC=$$ICD^RORXU010(DFN)
End DoDot:3
+50 IF (FLAG="INCLUDE")&(RCC=0)
QUIT
+51 IF (FLAG="EXCLUDE")&(RCC=1)
QUIT
+52 ;--- End of filter check
+53 ;--- Process the registry record
+54 IF $$PATIENT(IENS,BODY)<0
SET ECNT=ECNT+1
QUIT
End DoDot:2
if RC<0
QUIT
End DoDot:1
if RC<0
QUIT
+55 ;---
+56 QUIT $SELECT(RC<0:RC,ECNT>0:-43,1:0)
+57 ;
+58 ;***** ADDS THE SELECTION RULES TO THE REPORT
+59 ;
+60 ; IENS IENS of the patient's record in the registry
+61 ; PARTAG Reference (IEN) to the parent tag
+62 ;
+63 ; Return Values:
+64 ; <0 Error code
+65 ; 0 Ok
+66 ;
SELRULES(IENS,PARTAG) ;
+1 NEW CNT,I,RORBUF,RORMSG,RT,SRLTAG,TMP
+2 ;--- Load the list of selection rules
+3 KILL RORMSG
DO LIST^DIC(798.01,","_IENS,"@;.01I;1I",,,,,"B",,,"RORBUF","RORMSG")
+4 ;Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,,798.01,IENS)
+5 if $GET(RORMSG("DIERR"))
QUIT $$DBS^RORERR("RORMSG",-9,,,798.01,IENS)
+6 ;--- The <SELRULES> ... </SELRULES> tags
+7 SET SRLTAG=$$ADDVAL^RORTSK11(RORTSK,"SELRULES",,PARTAG)
+8 ;--- Add the selection rules to the report
+9 SET I=""
SET CNT=0
+10 FOR
SET I=$ORDER(RORBUF("DILIST","ID",I))
if I=""
QUIT
Begin DoDot:1
+11 SET RT=$$ADDVAL^RORTSK11(RORTSK,"RULE",,SRLTAG)
SET CNT=CNT+1
+12 SET TMP=$GET(RORBUF("DILIST","ID",I,.01))
+13 KILL RORMSG
SET TMP=$$GET1^DIQ(798.2,TMP_",",4,,,"RORMSG")
+14 ;Q:$G(DIERR)!(TMP="")
+15 if $GET(RORMSG("DIERR"))!(TMP="")
QUIT
+16 DO ADDATTR^RORTSK11(RORTSK,RT,"DESCR",TMP)
+17 SET TMP=$$DATE^RORXU002($GET(RORBUF("DILIST","ID",I,1))\1)
+18 if TMP'=""
DO ADDATTR^RORTSK11(RORTSK,RT,"DATE",TMP)
End DoDot:1
+19 ;--- Add the default item if no selection rules have been found
+20 if CNT'>0
Begin DoDot:1
+21 SET RT=$$ADDVAL^RORTSK11(RORTSK,"RULE",,SRLTAG)
+22 DO ADDATTR^RORTSK11(RORTSK,RT,"DESCR","Manual Entry")
End DoDot:1
+23 ;
+24 QUIT 0
+25 ;
+26
