- 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 Feb 18, 2025@23:10:39 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