RORXU002 ;HCIOFO/SG - REPORT BUILDER UTILITIES ; 20 Apr 2016 1:21 PM
;;1.5;CLINICAL CASE REGISTRIES;**1,10,13,15,17,19,21,22,26,29,30,31,33,34**;Feb 17, 2006;Build 45
;
; This routine uses the following IAs:
;
; #3990 $$ICDD^ICDCODE (supported)
; #2050 BLD^DIALOG (supported)
; #2056 GETS^DIQ (supported)
; #2056 $$GET1^DIQ (supported)
; #10103 $$NOW^XLFDT (supported)
; #10104 $$TRIM^XLFSTR (supported)
; #417 Read access to .01 field of file #40.8 (controlled)
; #10040 Read access to file #44 (supported)
; #5747 $$VLTD^ICDEX (controlled)
;
;******************************************************************************
;******************************************************************************
; --- ROUTINE MODIFICATION LOG ---
;
;PKG/PATCH DATE DEVELOPER MODIFICATION
;----------- ---------- ----------- ----------------------------------------
;ROR*1.5*10 APR 2010 A SAUNDERS Modified Lab Tests Ranges section in
; PARAMS tag to include the 3 new reports.
;ROR*1.5*13 DEC 2010 A SAUNDERS Added Division and Clinic sections in
; PARAMS tag (pulled from RORXU006).
;ROR*1.5*15 JUN 2011 C RAY Added HIV_DX
;
;ROR*1.5*17 AUG 2011 C RAY Modified to allow
; PATIENTS,OPTIONS params to have other
; values besides boolean
; Modified to add DATE_RANGE_4
;ROR*1.5*19 FEB 2012 J SCOTT Support for ICD-10 Coding System.
;
;ROR*1.5*21 SEP 2013 T KOPP Added flags for GENDER (SEX) selection on
; reports in PATIENTS XML tag
; Added ICN column if Additional Identifier
; requested.
;
;ROR*1.5*22 FEB 2014 T KOPP Added flags for OEF/OIF period of service
; selection on reports in PATIENTS XML tag
;
;ROR*1.5*26 JAN 2015 T KOPP Added flags for SVR ONLY or NO SVR ONLY
; selection on reports in PATIENTS XML tag.
; Suppress FIB4 header on DAA Potential
; Candidates report if FIB-4 parameter not
; selected
;
;ROR*1.5*29 APR 2016 T KOPP Added DATE_RANGE_5-7 to parameter output in
; PARAMS
;
;ROR*1.5*30 OCT 2016 M FERRARESE Changing the dispay for "Sex" to "Birth Sex"
;
;ROR*1.5*31 MAY 2017 M FERRARESE Adding PACT, PCP, and AGE/DOB as additional
; identifiers.
;ROR*1.5*34 SEP 2018 M FERRARESE Adding Future Appointment clinic name ; Fix LOINC code table for HEP A/B
;******************************************************************************
;******************************************************************************
Q
;
;***** SCANS THE TABLE DEFINITION (RORSRC) FOR COLUMN NAMES
;
; .TERM Reference to a local variable where
; is terminator is returned
;
; Return Values:
; "" End of definition
; ... Name of the column
;
COLSCAN(TERM) ;
N CH,I,TOKEN
F I=1:1 S TERM=$E(RORSRC,I) Q:"(,)"[TERM
S TOKEN=$E(RORSRC,1,I-1)
F I=I+1:1 S CH=$E(RORSRC,I) Q:(CH="")!("(,)"'[CH)
S $E(RORSRC,1,I-1)=""
Q TOKEN
;
;***** CHECKS THE FILEMAN DATE/TIME VALUE
DATE(DT) ;
Q $S(DT>0:+DT,1:"")
;
;***** OUTPUTS THE BASIC HEADER TO THE REPORT
;
; .RORTSK Task number and task parameters
;
; PARTAG Reference (IEN) to the parent tag
;
; Return Values:
; <0 Error code
; >0 IEN of the HEADER element
;
N HEADER,IENS,REGIEN,RORBUF,RORMSG,TMP,DIERR
S HEADER=$$ADDVAL^RORTSK11(RORTSK,"HEADER",,PARTAG)
Q:HEADER<0 HEADER
D ADDVAL^RORTSK11(RORTSK,"DATE",$$DATE($$NOW^XLFDT),HEADER)
D ADDVAL^RORTSK11(RORTSK,"TASK_NUMBER",RORTSK,HEADER)
S REGIEN=+$$PARAM^RORTSK01("REGIEN")
;---
S IENS=REGIEN_","
D GETS^DIQ(798.1,IENS,"1;2","I","RORBUF","RORMSG")
Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,,798.1,IENS)
S TMP=$G(RORBUF(798.1,IENS,1,"I"))
D ADDVAL^RORTSK11(RORTSK,"UPDATED_UNTIL",$$DATE(TMP),HEADER)
S TMP=$G(RORBUF(798.1,IENS,2,"I"))
D ADDVAL^RORTSK11(RORTSK,"EXTRACTED_UNTIL",$$DATE(TMP),HEADER)
Q HEADER
;
;***** PARSES THE COMMA-SEPARATED LIST
;
; .LIST Reference to a local variable that contains a list.
; Items of the list are returned as the subscripts of
; this variable.
;
LIST(LIST) ;
N I,TMP,VAL
F I=1:1 S VAL=$P(LIST,",",I) Q:VAL="" D
. S TMP=$$TRIM^XLFSTR(VAL)
. S:TMP'="" LIST(TMP)=""
Q
;
;***** COMPILES A TEXT DESCRIPTION FOR THE REPORT OPTIONS
;
; .OPTIONS Reference to a local variable containing
; the options as subscripts
;
; [DLGNUM] Number of the dialog that contains the template
; (7980000.018, by default).
;
; Return Values:
; ... Text description of the options
;
OPTXT(OPTIONS,DLGNUM) ;
N I,J,NS,RORBUF,TEXT,TMP
S:$G(DLGNUM)'>0 DLGNUM=7980000.018
D BLD^DIALOG(DLGNUM,,,"RORBUF")
S TEXT="",I=0
F S I=$O(RORBUF(I)) Q:I="" D:$E(RORBUF(I),1)'=" "
. S NS=0
. F J=1:1 S TMP=$TR($P(RORBUF(I),",",J)," ") Q:TMP="" D
. . S:$D(OPTIONS(TMP)) NS=2**(J-1)+NS
. Q:'NS
. S TMP=$$TRIM^XLFSTR($G(RORBUF(I+NS)))
. S:TMP'="" TEXT=TEXT_", "_TMP
Q $P(TEXT,", ",2,999)
;
;***** OUTPUTS THE PARAMETERS TO THE REPORT
;
; .RORTSK Task number and task parameters
;
; PARTAG Reference (IEN) to the parent tag
;
; .STDT Start and end dates of the report
; .ENDT are returned via these parameters
;
; [.FLAGS] Flags for the $$SKIP^RORXU005 are returned via this
; parameter. The "D" (skip deceased patients) and "G"
; (skip pending patients) flags are always added.
;
; Return Values:
; <0 Error code
; >0 IEN of the PARAMETERS element
;
PARAMS(RORTSK,PARTAG,STDT,ENDT,FLAGS) ;
N APPT,BUF,ELEMENT,I,LTAG,MODE,NAME,PARAMS,RC,REGIEN,RORMSG,TMP,IEN,DIERR,TMP1
S PARAMS=$$ADDVAL^RORTSK11(RORTSK,"PARAMETERS",,PARTAG)
S RC=0,(ARENDT,ENDT,ARSTDT,STDT)="",FLAGS=""
;
S REGIEN=+$$PARAM^RORTSK01("REGIEN")
I REGIEN>0 D Q:RC<0 RC
. S TMP=$P($$REGNAME^RORUTL01(REGIEN),U)
. I TMP="" S RC=-1 Q
. S RC=$$ADDVAL^RORTSK11(RORTSK,"REGNAME",TMP,PARAMS)
;
;=== Alternate date ranges
F I=2:1:7 D Q:RC<0
. S STDT=$$PARAM^RORTSK01("DATE_RANGE_"_I,"START")\1 Q:STDT'>0
. S ENDT=$$PARAM^RORTSK01("DATE_RANGE_"_I,"END")\1 Q:ENDT'>0
. S ELEMENT=$$ADDVAL^RORTSK11(RORTSK,"DATE_RANGE_"_I,,PARAMS)
. I ELEMENT<0 S RC=+ELEMENT Q
. S RC=$$ADDATTR^RORTSK11(RORTSK,ELEMENT,"START",STDT) Q:RC<0
. S RC=$$ADDATTR^RORTSK11(RORTSK,ELEMENT,"END",ENDT)
Q:RC<0 RC
;
;=== Main date range
S STDT=$$PARAM^RORTSK01("DATE_RANGE","START")\1
S ENDT=$$PARAM^RORTSK01("DATE_RANGE","END")\1
I STDT>0,ENDT>0 D Q:RC<0 RC
. S ELEMENT=$$ADDVAL^RORTSK11(RORTSK,"DATE_RANGE",,PARAMS)
. I ELEMENT<0 S RC=+ELEMENT Q
. S RC=$$ADDATTR^RORTSK11(RORTSK,ELEMENT,"START",STDT) Q:RC<0
. S RC=$$ADDATTR^RORTSK11(RORTSK,ELEMENT,"END",ENDT)
E S (ENDT,STDT)=""
;
;=== Task comment
S TMP=$$PARAM^RORTSK01("TASK_COMMENT")
D:TMP'="" ADDVAL^RORTSK11(RORTSK,"TASK_COMMENT",TMP,PARAMS)
;
;=== Clinic Selection - patch 13
D:$D(RORTSK("PARAMS","CLINICS","C"))
. S LTAG=$$ADDVAL^RORTSK11(RORTSK,"CLINICS",,PARAMS) Q:LTAG'>0
. S IEN=0
. F S IEN=$O(RORTSK("PARAMS","CLINICS","C",IEN)) Q:IEN'>0 D
. . S TMP=$$GET1^DIQ(44,IEN_",",.01,,,"RORMSG")
. . D:$G(DIERR) DBS^RORERR("RORMSG",-9,,,44,IEN_",")
. . Q:TMP=""
. . D ADDVAL^RORTSK11(RORTSK,"CLINIC",TMP,LTAG,,IEN)
D:$$PARAM^RORTSK01("CLINICS","ALL")
. S LTAG=$$ADDVAL^RORTSK11(RORTSK,"CLINICS","ALL",PARAMS)
;
;=== Division Selection - patch 13
D:$D(RORTSK("PARAMS","DIVISIONS","C"))
. S LTAG=$$ADDVAL^RORTSK11(RORTSK,"DIVISIONS",,PARAMS) Q:LTAG'>0
. S IEN=0
. F S IEN=$O(RORTSK("PARAMS","DIVISIONS","C",IEN)) Q:IEN'>0 D
. . S TMP=$$GET1^DIQ(40.8,IEN_",",.01,,,"RORMSG")
. . D:$G(DIERR) DBS^RORERR("RORMSG",-9,,,40.8,IEN_",")
. . Q:TMP=""
. . D ADDVAL^RORTSK11(RORTSK,"DIVISION",TMP,LTAG,,IEN)
D:$$PARAM^RORTSK01("DIVISIONS","ALL")
. S LTAG=$$ADDVAL^RORTSK11(RORTSK,"DIVISIONS","ALL",PARAMS)
;
;=== Age Range - patch 31
S TMP1=$G(RORTSK("PARAMS","AGE_RANGE","A","TYPE"))
I TMP1="ALL" D Q:RC<0 RC
. S RC=$$ADDVAL^RORTSK11(RORTSK,"AGE_RANGE",,PARAMS)
. S RC=$$ADDATTR^RORTSK11(RORTSK,"AGE_RANGE","TYPE",TMP1)
;
I TMP1="AGE"!(TMP1="DOB") D Q:RC<0 RC
. S ARSTDT=$$PARAM^RORTSK01("AGE_RANGE","START")
. S ARENDT=$$PARAM^RORTSK01("AGE_RANGE","END")
. I ARSTDT>0,ARENDT>0 D Q
. . S ELEMENT=$$ADDVAL^RORTSK11(RORTSK,"AGE_RANGE",,PARAMS)
. . I ELEMENT<0 S RC=+ELEMENT Q
. . S RC=$$ADDATTR^RORTSK11(RORTSK,ELEMENT,"TYPE",TMP1) Q:RC<0
. . S RC=$$ADDATTR^RORTSK11(RORTSK,ELEMENT,"START",ARSTDT)
. . S RC=$$ADDATTR^RORTSK11(RORTSK,ELEMENT,"END",ARENDT)
. E S (ARENDT,ARSTDT)=""
;
;=== Patient selection and Options
F NAME="PATIENTS","OPTIONS" D Q:RC<0
. K BUF M BUF=RORTSK("PARAMS",NAME,"A") Q:$D(BUF)<10
. ;--- Generate the XML tags
. S ELEMENT=$$ADDVAL^RORTSK11(RORTSK,NAME,$$OPTXT(.BUF),PARAMS)
. I ELEMENT'>0 S RC=ELEMENT Q
. S TMP=""
. F S TMP=$O(BUF(TMP)) Q:TMP="" D Q:RC<0
. . S RC=$$ADDATTR^RORTSK11(RORTSK,ELEMENT,TMP,$G(BUF(TMP)))
. ;--- Compile the flags
. D:NAME="PATIENTS"
. . S:'$D(BUF("DE_BEFORE")) FLAGS=FLAGS_"P"
. . S:'$D(BUF("DE_DURING")) FLAGS=FLAGS_"N"
. . S:'$D(BUF("DE_AFTER")) FLAGS=FLAGS_"F"
. . I $D(BUF("BIRTHSEX")) S FLAGS=FLAGS_$S(BUF("BIRTHSEX")="M":"W",BUF("BIRTHSEX")="F":"M",1:"")
. . I $D(BUF("OEF")) D
. . . S FLAGS=FLAGS_$S(BUF("OEF")=1:"I",BUF("OEF")=-1:"E",1:"")
. . I $D(BUF("SVR")) S FLAGS=FLAGS_$S(BUF("SVR")=1:"S",BUF("SVR")=0:"V",1:"")
. D:NAME="OPTIONS" ;PATCH 33
. .S:$D(BUF("FUT_APPT")) FLAGS=FLAGS_"U"
Q:RC<0 RC
;
;=== Other Registries
I $D(RORTSK("PARAMS","OTHER_REGISTRIES","C"))>1 D Q:RC<0 RC
. N NODE,REGIEN
. S LTAG=$$ADDVAL^RORTSK11(RORTSK,"OTHER_REGISTRIES",,PARAMS)
. I LTAG<0 S RC=+LTAG Q
. S NODE=$NA(RORTSK("PARAMS","OTHER_REGISTRIES","C"))
. S REGIEN=0
. F S REGIEN=$O(@NODE@(REGIEN)) Q:REGIEN'>0 D Q:RC<0
. . S TMP=$P($$REGNAME^RORUTL01(REGIEN),U,2)
. . S MODE=+$G(@NODE@(REGIEN))
. . I 'MODE!(TMP="") K @NODE@(REGIEN) Q
. . S TMP=TMP_" ("_$S(MODE<0:"Exclude",1:"Include")_")"
. . S RC=$$ADDVAL^RORTSK11(RORTSK,"REGNAME",TMP,LTAG)
. S FLAGS=FLAGS_"R"
;
;=== Local Fields
I $D(RORTSK("PARAMS","LOCAL_FIELDS","C"))>1 D Q:RC<0 RC
. N NODE,IEN,IENS
. S LTAG=$$ADDVAL^RORTSK11(RORTSK,"LOCAL_FIELDS",,PARAMS)
. I LTAG<0 S RC=+LTAG Q
. S NODE=$NA(RORTSK("PARAMS","LOCAL_FIELDS","C"))
. S IEN=0
. F S IEN=$O(@NODE@(IEN)) Q:IEN'>0 D Q:RC<0
. . S TMP=$$GET1^DIQ(799.53,IEN_",",.01,,,"RORMSG")
. . D:$G(DIERR) DBS^RORERR("RORMSG",-9,,,799.53,IEN_",")
. . S MODE=+$G(@NODE@(IEN))
. . I 'MODE!(TMP="") K @NODE@(IEN) Q
. . S TMP=TMP_" ("_$S(MODE<0:"Exclude",1:"Include")_")"
. . S RC=$$ADDVAL^RORTSK11(RORTSK,"FIELD",TMP,LTAG)
. S FLAGS=FLAGS_"O"
;
;=== Lab test ranges
I $D(RORTSK("PARAMS","LRGRANGES","C"))>1 D Q:RC<0 RC
. N TYPE S TYPE=3 ;default = 3 for 'lab by range' report
. I $G(RORTSK("EP"))["BMIRANGE" S TYPE=5 ;change to 5 if BMI
. I $G(RORTSK("EP"))["MLDRANGE"!($G(RORTSK("EP"))["HCVDAA") S TYPE=6 ;change to 6 if MELD
. I $G(RORTSK("EP"))["RFRANGE" S TYPE=7 ;change to 7 if Renal
. N GRC,NODE
. S NODE=$NA(RORTSK("PARAMS","LRGRANGES","C"))
. S GRC=0
. F S GRC=$O(@NODE@(GRC)) Q:GRC'>0 D Q:RC<0
. . S RC=$$ITEMIEN^RORUTL09(TYPE,REGIEN,GRC,.TMP)
. . S:RC'<0 @NODE@(GRC)=TMP
;
;=== ICD filter/group/codes
N LEV1FILT,LEV2GRP,LEV3ICD,ICDIEN,ICDCODE,GRPNAME,FILTER,ICDDESC,RORXMLNODE,RORICDSYS
S FILTER=$G(RORTSK("PARAMS","ICDFILT","A","FILTER"))
I $L(FILTER)>0 D ;quit if no ICD filter exists
. S LEV1FILT=$$ADDVAL^RORTSK11(RORTSK,"ICDFILT",,PARAMS)
. I LEV1FILT<0 S RC=LEV1FILT Q
. ;add filter value to the output
. S RC=$$ADDATTR^RORTSK11(RORTSK,LEV1FILT,"FILTER",FILTER)
. ;if there's an ICD group, process it
. I $D(RORTSK("PARAMS","ICDFILT","G"))>1 D Q:RC<0
.. S NODE=$NA(RORTSK("PARAMS","ICDFILT","G"))
.. S GRPNAME=0,RC=0
.. F S GRPNAME=$O(@NODE@(GRPNAME)) Q:GRPNAME="" D Q:RC<0
... S LEV2GRP=$$ADDVAL^RORTSK11(RORTSK,"GROUP",,LEV1FILT)
... I LEV2GRP'>0 S RC=LEV2GRP Q
... ;add group name to the output
... D ADDATTR^RORTSK11(RORTSK,LEV2GRP,"ID",GRPNAME)
... S ICDIEN=0
... F S ICDIEN=$O(@NODE@(GRPNAME,"C",ICDIEN)) Q:ICDIEN'>0 D
.... S ICDCODE=$P(@NODE@(GRPNAME,"C",ICDIEN),U,1) Q:ICDCODE=""
.... S RORICDSYS=$P(@NODE@(GRPNAME,"C",ICDIEN),U,2)
.... ;get diagnosis description
.... S ICDDESC=$$VLTD^ICDEX(ICDIEN)
.... S RORXMLNODE=$S(RORICDSYS=1:"ICD9",1:"ICD10")
.... S LEV3ICD=$$ADDVAL^RORTSK11(RORTSK,RORXMLNODE,ICDDESC,LEV2GRP)
.... D ADDATTR^RORTSK11(RORTSK,LEV3ICD,"ID",ICDCODE)
;
;=== get Max Date
N MAXDT S MAXDT=$$PARAM^RORTSK01("OPTIONS","MAX_DATE")
I $G(MAXDT)>0 D ADDVAL^RORTSK11(RORTSK,"MAX_DATE",MAXDT,PARAMS)
;
;=== get HIV_DX
N RORMODE S RORMODE=$$PARAM^RORTSK01("HIV_DX")
S RORMODE=$S(RORMODE=1:"Include",RORMODE=-1:"Exclude",1:"")
I RORMODE'="" D
. D ADDVAL^RORTSK11(RORTSK,"HIV_DX",RORMODE,PARAMS)
. S FLAGS=FLAGS_"H"
;
;=== Defaults
S TMP=$TR(FLAGS,"FNP") S:$L(FLAGS)-$L(TMP)=3 FLAGS=TMP
S FLAGS=FLAGS_"DG"
;
;=== Success
Q PARAMS
;
;***** GENERATES TABLE DEFINITION
;
; TBLREF Reference to the definition table in the source
; code (TAG^ROUTINE). See the HEADER^RORX013 for
; examples of table definitions.
;
; HEADER IEN of the HEADER element
;
; Return Values:
; <0 Error code
; 0 Ok
;
TBLDEF(TBLREF,HEADER) ;
N COND,IT,NAME,RC,RORSRC,TBLDEF,TERM,TGET
K ^TMP($J,"RORSELCOL")
S TGET="S RORSRC=$T("_$P(TBLREF,"^")_"+IT^"_$P(TBLREF,"^",2)_")"
S RC=0
F IT=1:1 X TGET S RORSRC=$P(RORSRC,";;",2) Q:RORSRC="" D Q:RC<0
. S COND=$$TRIM^XLFSTR($P(RORSRC,U,2,999))
. I COND'="" X COND E Q
. S RORSRC=$$TRIM^XLFSTR($P(RORSRC,U))
. S NAME=$$COLSCAN(.TERM) Q:(NAME="")!(TERM'="(")
. S TBLDEF=$$ADDVAL^RORTSK11(RORTSK,"TBLDEF",,HEADER)
. I TBLDEF<0 S RC=TBLDEF Q
. D ADDATTR^RORTSK11(RORTSK,TBLDEF,"NAME",NAME)
. D ADDATTR^RORTSK11(RORTSK,TBLDEF,"HEADER","1")
. D ADDATTR^RORTSK11(RORTSK,TBLDEF,"FOOTER","1")
. D TBLDEF1(TBLDEF)
K ^TMP($J,"RORSELCOL")
Q $S(RC<0:RC,1:0)
;
;***** GENERATES <COLUMN> ELEMENTS FROM TABLE DEFINITION (RORSRC)
;
; PTAG IEN of the parent element
;
TBLDEF1(PTAG) ;
N COLUMN,IT,NAME,OK,ROR,TERM
F S NAME=$$COLSCAN(.TERM) Q:NAME="" D Q:")"[TERM
. I '$D(^TMP($J,"RORSELCOL")) D ; set up special columns selection criteria
. . F IT=1:1 X "S ROR=$P($T(SELCOL+"_IT_"^RORXU002),"";;"",2)" Q:$P(ROR,U)="" D
. . . S ^TMP($J,"RORSELCOL",$P(ROR,U))=$P(ROR,U,2,999)
. I $D(^TMP($J,"RORSELCOL",NAME)) D Q:'OK
. . X ^TMP($J,"RORSELCOL",NAME) S OK=$T
. S COLUMN=$$ADDVAL^RORTSK11(RORTSK,"COLUMN",,PTAG)
. D ADDATTR^RORTSK11(RORTSK,COLUMN,"NAME",NAME)
. D:TERM="(" TBLDEF1(COLUMN)
Q
;
;Setup of values in SELCOL is:
;name of selected optional column^statement to execute to set $T if the condition to include this field has been met
;
SELCOL ;selected optional fields and screen criteria is listed here
;;ICN^I $$PARAM^RORTSK01("PATIENTS","ICN")
;;FIB4^I $D(RORTSK("PARAMS","LRGRANGES","C",4))
;;PACT^I $$PARAM^RORTSK01("PATIENTS","PACT")
;;PCP^I $$PARAM^RORTSK01("PATIENTS","PCP")
;;FUT_APPT^I $$PARAM^RORTSK01("OPTIONS","FUT_APPT")
;;FUT_CLIN^I $$PARAM^RORTSK01("OPTIONS","FUT_APPT")
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORXU002 16103 printed Apr 09, 2024@20:48 Page 2
RORXU002 ;HCIOFO/SG - REPORT BUILDER UTILITIES ; 20 Apr 2016 1:21 PM
+1 ;;1.5;CLINICAL CASE REGISTRIES;**1,10,13,15,17,19,21,22,26,29,30,31,33,34**;Feb 17, 2006;Build 45
+2 ;
+3 ; This routine uses the following IAs:
+4 ;
+5 ; #3990 $$ICDD^ICDCODE (supported)
+6 ; #2050 BLD^DIALOG (supported)
+7 ; #2056 GETS^DIQ (supported)
+8 ; #2056 $$GET1^DIQ (supported)
+9 ; #10103 $$NOW^XLFDT (supported)
+10 ; #10104 $$TRIM^XLFSTR (supported)
+11 ; #417 Read access to .01 field of file #40.8 (controlled)
+12 ; #10040 Read access to file #44 (supported)
+13 ; #5747 $$VLTD^ICDEX (controlled)
+14 ;
+15 ;******************************************************************************
+16 ;******************************************************************************
+17 ; --- ROUTINE MODIFICATION LOG ---
+18 ;
+19 ;PKG/PATCH DATE DEVELOPER MODIFICATION
+20 ;----------- ---------- ----------- ----------------------------------------
+21 ;ROR*1.5*10 APR 2010 A SAUNDERS Modified Lab Tests Ranges section in
+22 ; PARAMS tag to include the 3 new reports.
+23 ;ROR*1.5*13 DEC 2010 A SAUNDERS Added Division and Clinic sections in
+24 ; PARAMS tag (pulled from RORXU006).
+25 ;ROR*1.5*15 JUN 2011 C RAY Added HIV_DX
+26 ;
+27 ;ROR*1.5*17 AUG 2011 C RAY Modified to allow
+28 ; PATIENTS,OPTIONS params to have other
+29 ; values besides boolean
+30 ; Modified to add DATE_RANGE_4
+31 ;ROR*1.5*19 FEB 2012 J SCOTT Support for ICD-10 Coding System.
+32 ;
+33 ;ROR*1.5*21 SEP 2013 T KOPP Added flags for GENDER (SEX) selection on
+34 ; reports in PATIENTS XML tag
+35 ; Added ICN column if Additional Identifier
+36 ; requested.
+37 ;
+38 ;ROR*1.5*22 FEB 2014 T KOPP Added flags for OEF/OIF period of service
+39 ; selection on reports in PATIENTS XML tag
+40 ;
+41 ;ROR*1.5*26 JAN 2015 T KOPP Added flags for SVR ONLY or NO SVR ONLY
+42 ; selection on reports in PATIENTS XML tag.
+43 ; Suppress FIB4 header on DAA Potential
+44 ; Candidates report if FIB-4 parameter not
+45 ; selected
+46 ;
+47 ;ROR*1.5*29 APR 2016 T KOPP Added DATE_RANGE_5-7 to parameter output in
+48 ; PARAMS
+49 ;
+50 ;ROR*1.5*30 OCT 2016 M FERRARESE Changing the dispay for "Sex" to "Birth Sex"
+51 ;
+52 ;ROR*1.5*31 MAY 2017 M FERRARESE Adding PACT, PCP, and AGE/DOB as additional
+53 ; identifiers.
+54 ;ROR*1.5*34 SEP 2018 M FERRARESE Adding Future Appointment clinic name ; Fix LOINC code table for HEP A/B
+55 ;******************************************************************************
+56 ;******************************************************************************
+57 QUIT
+58 ;
+59 ;***** SCANS THE TABLE DEFINITION (RORSRC) FOR COLUMN NAMES
+60 ;
+61 ; .TERM Reference to a local variable where
+62 ; is terminator is returned
+63 ;
+64 ; Return Values:
+65 ; "" End of definition
+66 ; ... Name of the column
+67 ;
COLSCAN(TERM) ;
+1 NEW CH,I,TOKEN
+2 FOR I=1:1
SET TERM=$EXTRACT(RORSRC,I)
if "(,)"[TERM
QUIT
+3 SET TOKEN=$EXTRACT(RORSRC,1,I-1)
+4 FOR I=I+1:1
SET CH=$EXTRACT(RORSRC,I)
if (CH="")!("(,)"'[CH)
QUIT
+5 SET $EXTRACT(RORSRC,1,I-1)=""
+6 QUIT TOKEN
+7 ;
+8 ;***** CHECKS THE FILEMAN DATE/TIME VALUE
DATE(DT) ;
+1 QUIT $SELECT(DT>0:+DT,1:"")
+2 ;
+3 ;***** OUTPUTS THE BASIC HEADER TO THE REPORT
+4 ;
+5 ; .RORTSK Task number and task parameters
+6 ;
+7 ; PARTAG Reference (IEN) to the parent tag
+8 ;
+9 ; Return Values:
+10 ; <0 Error code
+11 ; >0 IEN of the HEADER element
+12 ;
+1 NEW HEADER,IENS,REGIEN,RORBUF,RORMSG,TMP,DIERR
+2 SET HEADER=$$ADDVAL^RORTSK11(RORTSK,"HEADER",,PARTAG)
+3 if HEADER<0
QUIT HEADER
+4 DO ADDVAL^RORTSK11(RORTSK,"DATE",$$DATE($$NOW^XLFDT),HEADER)
+5 DO ADDVAL^RORTSK11(RORTSK,"TASK_NUMBER",RORTSK,HEADER)
+6 SET REGIEN=+$$PARAM^RORTSK01("REGIEN")
+7 ;---
+8 SET IENS=REGIEN_","
+9 DO GETS^DIQ(798.1,IENS,"1;2","I","RORBUF","RORMSG")
+10 if $GET(DIERR)
QUIT $$DBS^RORERR("RORMSG",-9,,,798.1,IENS)
+11 SET TMP=$GET(RORBUF(798.1,IENS,1,"I"))
+12 DO ADDVAL^RORTSK11(RORTSK,"UPDATED_UNTIL",$$DATE(TMP),HEADER)
+13 SET TMP=$GET(RORBUF(798.1,IENS,2,"I"))
+14 DO ADDVAL^RORTSK11(RORTSK,"EXTRACTED_UNTIL",$$DATE(TMP),HEADER)
+15 QUIT HEADER
+16 ;
+17 ;***** PARSES THE COMMA-SEPARATED LIST
+18 ;
+19 ; .LIST Reference to a local variable that contains a list.
+20 ; Items of the list are returned as the subscripts of
+21 ; this variable.
+22 ;
LIST(LIST) ;
+1 NEW I,TMP,VAL
+2 FOR I=1:1
SET VAL=$PIECE(LIST,",",I)
if VAL=""
QUIT
Begin DoDot:1
+3 SET TMP=$$TRIM^XLFSTR(VAL)
+4 if TMP'=""
SET LIST(TMP)=""
End DoDot:1
+5 QUIT
+6 ;
+7 ;***** COMPILES A TEXT DESCRIPTION FOR THE REPORT OPTIONS
+8 ;
+9 ; .OPTIONS Reference to a local variable containing
+10 ; the options as subscripts
+11 ;
+12 ; [DLGNUM] Number of the dialog that contains the template
+13 ; (7980000.018, by default).
+14 ;
+15 ; Return Values:
+16 ; ... Text description of the options
+17 ;
OPTXT(OPTIONS,DLGNUM) ;
+1 NEW I,J,NS,RORBUF,TEXT,TMP
+2 if $GET(DLGNUM)'>0
SET DLGNUM=7980000.018
+3 DO BLD^DIALOG(DLGNUM,,,"RORBUF")
+4 SET TEXT=""
SET I=0
+5 FOR
SET I=$ORDER(RORBUF(I))
if I=""
QUIT
if $EXTRACT(RORBUF(I),1)'=" "
Begin DoDot:1
+6 SET NS=0
+7 FOR J=1:1
SET TMP=$TRANSLATE($PIECE(RORBUF(I),",",J)," ")
if TMP=""
QUIT
Begin DoDot:2
+8 if $DATA(OPTIONS(TMP))
SET NS=2**(J-1)+NS
End DoDot:2
+9 if 'NS
QUIT
+10 SET TMP=$$TRIM^XLFSTR($GET(RORBUF(I+NS)))
+11 if TMP'=""
SET TEXT=TEXT_", "_TMP
End DoDot:1
+12 QUIT $PIECE(TEXT,", ",2,999)
+13 ;
+14 ;***** OUTPUTS THE PARAMETERS TO THE REPORT
+15 ;
+16 ; .RORTSK Task number and task parameters
+17 ;
+18 ; PARTAG Reference (IEN) to the parent tag
+19 ;
+20 ; .STDT Start and end dates of the report
+21 ; .ENDT are returned via these parameters
+22 ;
+23 ; [.FLAGS] Flags for the $$SKIP^RORXU005 are returned via this
+24 ; parameter. The "D" (skip deceased patients) and "G"
+25 ; (skip pending patients) flags are always added.
+26 ;
+27 ; Return Values:
+28 ; <0 Error code
+29 ; >0 IEN of the PARAMETERS element
+30 ;
PARAMS(RORTSK,PARTAG,STDT,ENDT,FLAGS) ;
+1 NEW APPT,BUF,ELEMENT,I,LTAG,MODE,NAME,PARAMS,RC,REGIEN,RORMSG,TMP,IEN,DIERR,TMP1
+2 SET PARAMS=$$ADDVAL^RORTSK11(RORTSK,"PARAMETERS",,PARTAG)
+3 SET RC=0
SET (ARENDT,ENDT,ARSTDT,STDT)=""
SET FLAGS=""
+4 ;
+5 SET REGIEN=+$$PARAM^RORTSK01("REGIEN")
+6 IF REGIEN>0
Begin DoDot:1
+7 SET TMP=$PIECE($$REGNAME^RORUTL01(REGIEN),U)
+8 IF TMP=""
SET RC=-1
QUIT
+9 SET RC=$$ADDVAL^RORTSK11(RORTSK,"REGNAME",TMP,PARAMS)
End DoDot:1
if RC<0
QUIT RC
+10 ;
+11 ;=== Alternate date ranges
+12 FOR I=2:1:7
Begin DoDot:1
+13 SET STDT=$$PARAM^RORTSK01("DATE_RANGE_"_I,"START")\1
if STDT'>0
QUIT
+14 SET ENDT=$$PARAM^RORTSK01("DATE_RANGE_"_I,"END")\1
if ENDT'>0
QUIT
+15 SET ELEMENT=$$ADDVAL^RORTSK11(RORTSK,"DATE_RANGE_"_I,,PARAMS)
+16 IF ELEMENT<0
SET RC=+ELEMENT
QUIT
+17 SET RC=$$ADDATTR^RORTSK11(RORTSK,ELEMENT,"START",STDT)
if RC<0
QUIT
+18 SET RC=$$ADDATTR^RORTSK11(RORTSK,ELEMENT,"END",ENDT)
End DoDot:1
if RC<0
QUIT
+19 if RC<0
QUIT RC
+20 ;
+21 ;=== Main date range
+22 SET STDT=$$PARAM^RORTSK01("DATE_RANGE","START")\1
+23 SET ENDT=$$PARAM^RORTSK01("DATE_RANGE","END")\1
+24 IF STDT>0
IF ENDT>0
Begin DoDot:1
+25 SET ELEMENT=$$ADDVAL^RORTSK11(RORTSK,"DATE_RANGE",,PARAMS)
+26 IF ELEMENT<0
SET RC=+ELEMENT
QUIT
+27 SET RC=$$ADDATTR^RORTSK11(RORTSK,ELEMENT,"START",STDT)
if RC<0
QUIT
+28 SET RC=$$ADDATTR^RORTSK11(RORTSK,ELEMENT,"END",ENDT)
End DoDot:1
if RC<0
QUIT RC
+29 IF '$TEST
SET (ENDT,STDT)=""
+30 ;
+31 ;=== Task comment
+32 SET TMP=$$PARAM^RORTSK01("TASK_COMMENT")
+33 if TMP'=""
DO ADDVAL^RORTSK11(RORTSK,"TASK_COMMENT",TMP,PARAMS)
+34 ;
+35 ;=== Clinic Selection - patch 13
+36 if $DATA(RORTSK("PARAMS","CLINICS","C"))
Begin DoDot:1
+37 SET LTAG=$$ADDVAL^RORTSK11(RORTSK,"CLINICS",,PARAMS)
if LTAG'>0
QUIT
+38 SET IEN=0
+39 FOR
SET IEN=$ORDER(RORTSK("PARAMS","CLINICS","C",IEN))
if IEN'>0
QUIT
Begin DoDot:2
+40 SET TMP=$$GET1^DIQ(44,IEN_",",.01,,,"RORMSG")
+41 if $GET(DIERR)
DO DBS^RORERR("RORMSG",-9,,,44,IEN_",")
+42 if TMP=""
QUIT
+43 DO ADDVAL^RORTSK11(RORTSK,"CLINIC",TMP,LTAG,,IEN)
End DoDot:2
End DoDot:1
+44 if $$PARAM^RORTSK01("CLINICS","ALL")
Begin DoDot:1
+45 SET LTAG=$$ADDVAL^RORTSK11(RORTSK,"CLINICS","ALL",PARAMS)
End DoDot:1
+46 ;
+47 ;=== Division Selection - patch 13
+48 if $DATA(RORTSK("PARAMS","DIVISIONS","C"))
Begin DoDot:1
+49 SET LTAG=$$ADDVAL^RORTSK11(RORTSK,"DIVISIONS",,PARAMS)
if LTAG'>0
QUIT
+50 SET IEN=0
+51 FOR
SET IEN=$ORDER(RORTSK("PARAMS","DIVISIONS","C",IEN))
if IEN'>0
QUIT
Begin DoDot:2
+52 SET TMP=$$GET1^DIQ(40.8,IEN_",",.01,,,"RORMSG")
+53 if $GET(DIERR)
DO DBS^RORERR("RORMSG",-9,,,40.8,IEN_",")
+54 if TMP=""
QUIT
+55 DO ADDVAL^RORTSK11(RORTSK,"DIVISION",TMP,LTAG,,IEN)
End DoDot:2
End DoDot:1
+56 if $$PARAM^RORTSK01("DIVISIONS","ALL")
Begin DoDot:1
+57 SET LTAG=$$ADDVAL^RORTSK11(RORTSK,"DIVISIONS","ALL",PARAMS)
End DoDot:1
+58 ;
+59 ;=== Age Range - patch 31
+60 SET TMP1=$GET(RORTSK("PARAMS","AGE_RANGE","A","TYPE"))
+61 IF TMP1="ALL"
Begin DoDot:1
+62 SET RC=$$ADDVAL^RORTSK11(RORTSK,"AGE_RANGE",,PARAMS)
+63 SET RC=$$ADDATTR^RORTSK11(RORTSK,"AGE_RANGE","TYPE",TMP1)
End DoDot:1
if RC<0
QUIT RC
+64 ;
+65 IF TMP1="AGE"!(TMP1="DOB")
Begin DoDot:1
+66 SET ARSTDT=$$PARAM^RORTSK01("AGE_RANGE","START")
+67 SET ARENDT=$$PARAM^RORTSK01("AGE_RANGE","END")
+68 IF ARSTDT>0
IF ARENDT>0
Begin DoDot:2
+69 SET ELEMENT=$$ADDVAL^RORTSK11(RORTSK,"AGE_RANGE",,PARAMS)
+70 IF ELEMENT<0
SET RC=+ELEMENT
QUIT
+71 SET RC=$$ADDATTR^RORTSK11(RORTSK,ELEMENT,"TYPE",TMP1)
if RC<0
QUIT
+72 SET RC=$$ADDATTR^RORTSK11(RORTSK,ELEMENT,"START",ARSTDT)
+73 SET RC=$$ADDATTR^RORTSK11(RORTSK,ELEMENT,"END",ARENDT)
End DoDot:2
QUIT
+74 IF '$TEST
SET (ARENDT,ARSTDT)=""
End DoDot:1
if RC<0
QUIT RC
+75 ;
+76 ;=== Patient selection and Options
+77 FOR NAME="PATIENTS","OPTIONS"
Begin DoDot:1
+78 KILL BUF
MERGE BUF=RORTSK("PARAMS",NAME,"A")
if $DATA(BUF)<10
QUIT
+79 ;--- Generate the XML tags
+80 SET ELEMENT=$$ADDVAL^RORTSK11(RORTSK,NAME,$$OPTXT(.BUF),PARAMS)
+81 IF ELEMENT'>0
SET RC=ELEMENT
QUIT
+82 SET TMP=""
+83 FOR
SET TMP=$ORDER(BUF(TMP))
if TMP=""
QUIT
Begin DoDot:2
+84 SET RC=$$ADDATTR^RORTSK11(RORTSK,ELEMENT,TMP,$GET(BUF(TMP)))
End DoDot:2
if RC<0
QUIT
+85 ;--- Compile the flags
+86 if NAME="PATIENTS"
Begin DoDot:2
+87 if '$DATA(BUF("DE_BEFORE"))
SET FLAGS=FLAGS_"P"
+88 if '$DATA(BUF("DE_DURING"))
SET FLAGS=FLAGS_"N"
+89 if '$DATA(BUF("DE_AFTER"))
SET FLAGS=FLAGS_"F"
+90 IF $DATA(BUF("BIRTHSEX"))
SET FLAGS=FLAGS_$SELECT(BUF("BIRTHSEX")="M":"W",BUF("BIRTHSEX")="F":"M",1:"")
+91 IF $DATA(BUF("OEF"))
Begin DoDot:3
+92 SET FLAGS=FLAGS_$SELECT(BUF("OEF")=1:"I",BUF("OEF")=-1:"E",1:"")
End DoDot:3
+93 IF $DATA(BUF("SVR"))
SET FLAGS=FLAGS_$SELECT(BUF("SVR")=1:"S",BUF("SVR")=0:"V",1:"")
End DoDot:2
+94 ;PATCH 33
if NAME="OPTIONS"
Begin DoDot:2
+95 if $DATA(BUF("FUT_APPT"))
SET FLAGS=FLAGS_"U"
End DoDot:2
End DoDot:1
if RC<0
QUIT
+96 if RC<0
QUIT RC
+97 ;
+98 ;=== Other Registries
+99 IF $DATA(RORTSK("PARAMS","OTHER_REGISTRIES","C"))>1
Begin DoDot:1
+100 NEW NODE,REGIEN
+101 SET LTAG=$$ADDVAL^RORTSK11(RORTSK,"OTHER_REGISTRIES",,PARAMS)
+102 IF LTAG<0
SET RC=+LTAG
QUIT
+103 SET NODE=$NAME(RORTSK("PARAMS","OTHER_REGISTRIES","C"))
+104 SET REGIEN=0
+105 FOR
SET REGIEN=$ORDER(@NODE@(REGIEN))
if REGIEN'>0
QUIT
Begin DoDot:2
+106 SET TMP=$PIECE($$REGNAME^RORUTL01(REGIEN),U,2)
+107 SET MODE=+$GET(@NODE@(REGIEN))
+108 IF 'MODE!(TMP="")
KILL @NODE@(REGIEN)
QUIT
+109 SET TMP=TMP_" ("_$SELECT(MODE<0:"Exclude",1:"Include")_")"
+110 SET RC=$$ADDVAL^RORTSK11(RORTSK,"REGNAME",TMP,LTAG)
End DoDot:2
if RC<0
QUIT
+111 SET FLAGS=FLAGS_"R"
End DoDot:1
if RC<0
QUIT RC
+112 ;
+113 ;=== Local Fields
+114 IF $DATA(RORTSK("PARAMS","LOCAL_FIELDS","C"))>1
Begin DoDot:1
+115 NEW NODE,IEN,IENS
+116 SET LTAG=$$ADDVAL^RORTSK11(RORTSK,"LOCAL_FIELDS",,PARAMS)
+117 IF LTAG<0
SET RC=+LTAG
QUIT
+118 SET NODE=$NAME(RORTSK("PARAMS","LOCAL_FIELDS","C"))
+119 SET IEN=0
+120 FOR
SET IEN=$ORDER(@NODE@(IEN))
if IEN'>0
QUIT
Begin DoDot:2
+121 SET TMP=$$GET1^DIQ(799.53,IEN_",",.01,,,"RORMSG")
+122 if $GET(DIERR)
DO DBS^RORERR("RORMSG",-9,,,799.53,IEN_",")
+123 SET MODE=+$GET(@NODE@(IEN))
+124 IF 'MODE!(TMP="")
KILL @NODE@(IEN)
QUIT
+125 SET TMP=TMP_" ("_$SELECT(MODE<0:"Exclude",1:"Include")_")"
+126 SET RC=$$ADDVAL^RORTSK11(RORTSK,"FIELD",TMP,LTAG)
End DoDot:2
if RC<0
QUIT
+127 SET FLAGS=FLAGS_"O"
End DoDot:1
if RC<0
QUIT RC
+128 ;
+129 ;=== Lab test ranges
+130 IF $DATA(RORTSK("PARAMS","LRGRANGES","C"))>1
Begin DoDot:1
+131 ;default = 3 for 'lab by range' report
NEW TYPE
SET TYPE=3
+132 ;change to 5 if BMI
IF $GET(RORTSK("EP"))["BMIRANGE"
SET TYPE=5
+133 ;change to 6 if MELD
IF $GET(RORTSK("EP"))["MLDRANGE"!($GET(RORTSK("EP"))["HCVDAA")
SET TYPE=6
+134 ;change to 7 if Renal
IF $GET(RORTSK("EP"))["RFRANGE"
SET TYPE=7
+135 NEW GRC,NODE
+136 SET NODE=$NAME(RORTSK("PARAMS","LRGRANGES","C"))
+137 SET GRC=0
+138 FOR
SET GRC=$ORDER(@NODE@(GRC))
if GRC'>0
QUIT
Begin DoDot:2
+139 SET RC=$$ITEMIEN^RORUTL09(TYPE,REGIEN,GRC,.TMP)
+140 if RC'<0
SET @NODE@(GRC)=TMP
End DoDot:2
if RC<0
QUIT
End DoDot:1
if RC<0
QUIT RC
+141 ;
+142 ;=== ICD filter/group/codes
+143 NEW LEV1FILT,LEV2GRP,LEV3ICD,ICDIEN,ICDCODE,GRPNAME,FILTER,ICDDESC,RORXMLNODE,RORICDSYS
+144 SET FILTER=$GET(RORTSK("PARAMS","ICDFILT","A","FILTER"))
+145 ;quit if no ICD filter exists
IF $LENGTH(FILTER)>0
Begin DoDot:1
+146 SET LEV1FILT=$$ADDVAL^RORTSK11(RORTSK,"ICDFILT",,PARAMS)
+147 IF LEV1FILT<0
SET RC=LEV1FILT
QUIT
+148 ;add filter value to the output
+149 SET RC=$$ADDATTR^RORTSK11(RORTSK,LEV1FILT,"FILTER",FILTER)
+150 ;if there's an ICD group, process it
+151 IF $DATA(RORTSK("PARAMS","ICDFILT","G"))>1
Begin DoDot:2
+152 SET NODE=$NAME(RORTSK("PARAMS","ICDFILT","G"))
+153 SET GRPNAME=0
SET RC=0
+154 FOR
SET GRPNAME=$ORDER(@NODE@(GRPNAME))
if GRPNAME=""
QUIT
Begin DoDot:3
+155 SET LEV2GRP=$$ADDVAL^RORTSK11(RORTSK,"GROUP",,LEV1FILT)
+156 IF LEV2GRP'>0
SET RC=LEV2GRP
QUIT
+157 ;add group name to the output
+158 DO ADDATTR^RORTSK11(RORTSK,LEV2GRP,"ID",GRPNAME)
+159 SET ICDIEN=0
+160 FOR
SET ICDIEN=$ORDER(@NODE@(GRPNAME,"C",ICDIEN))
if ICDIEN'>0
QUIT
Begin DoDot:4
+161 SET ICDCODE=$PIECE(@NODE@(GRPNAME,"C",ICDIEN),U,1)
if ICDCODE=""
QUIT
+162 SET RORICDSYS=$PIECE(@NODE@(GRPNAME,"C",ICDIEN),U,2)
+163 ;get diagnosis description
+164 SET ICDDESC=$$VLTD^ICDEX(ICDIEN)
+165 SET RORXMLNODE=$SELECT(RORICDSYS=1:"ICD9",1:"ICD10")
+166 SET LEV3ICD=$$ADDVAL^RORTSK11(RORTSK,RORXMLNODE,ICDDESC,LEV2GRP)
+167 DO ADDATTR^RORTSK11(RORTSK,LEV3ICD,"ID",ICDCODE)
End DoDot:4
End DoDot:3
if RC<0
QUIT
End DoDot:2
if RC<0
QUIT
End DoDot:1
+168 ;
+169 ;=== get Max Date
+170 NEW MAXDT
SET MAXDT=$$PARAM^RORTSK01("OPTIONS","MAX_DATE")
+171 IF $GET(MAXDT)>0
DO ADDVAL^RORTSK11(RORTSK,"MAX_DATE",MAXDT,PARAMS)
+172 ;
+173 ;=== get HIV_DX
+174 NEW RORMODE
SET RORMODE=$$PARAM^RORTSK01("HIV_DX")
+175 SET RORMODE=$SELECT(RORMODE=1:"Include",RORMODE=-1:"Exclude",1:"")
+176 IF RORMODE'=""
Begin DoDot:1
+177 DO ADDVAL^RORTSK11(RORTSK,"HIV_DX",RORMODE,PARAMS)
+178 SET FLAGS=FLAGS_"H"
End DoDot:1
+179 ;
+180 ;=== Defaults
+181 SET TMP=$TRANSLATE(FLAGS,"FNP")
if $LENGTH(FLAGS)-$LENGTH(TMP)=3
SET FLAGS=TMP
+182 SET FLAGS=FLAGS_"DG"
+183 ;
+184 ;=== Success
+185 QUIT PARAMS
+186 ;
+187 ;***** GENERATES TABLE DEFINITION
+188 ;
+189 ; TBLREF Reference to the definition table in the source
+190 ; code (TAG^ROUTINE). See the HEADER^RORX013 for
+191 ; examples of table definitions.
+192 ;
+193 ; HEADER IEN of the HEADER element
+194 ;
+195 ; Return Values:
+196 ; <0 Error code
+197 ; 0 Ok
+198 ;
TBLDEF(TBLREF,HEADER) ;
+1 NEW COND,IT,NAME,RC,RORSRC,TBLDEF,TERM,TGET
+2 KILL ^TMP($JOB,"RORSELCOL")
+3 SET TGET="S RORSRC=$T("_$PIECE(TBLREF,"^")_"+IT^"_$PIECE(TBLREF,"^",2)_")"
+4 SET RC=0
+5 FOR IT=1:1
XECUTE TGET
SET RORSRC=$PIECE(RORSRC,";;",2)
if RORSRC=""
QUIT
Begin DoDot:1
+6 SET COND=$$TRIM^XLFSTR($PIECE(RORSRC,U,2,999))
+7 IF COND'=""
XECUTE COND
IF '$TEST
QUIT
+8 SET RORSRC=$$TRIM^XLFSTR($PIECE(RORSRC,U))
+9 SET NAME=$$COLSCAN(.TERM)
if (NAME="")!(TERM'="(")
QUIT
+10 SET TBLDEF=$$ADDVAL^RORTSK11(RORTSK,"TBLDEF",,HEADER)
+11 IF TBLDEF<0
SET RC=TBLDEF
QUIT
+12 DO ADDATTR^RORTSK11(RORTSK,TBLDEF,"NAME",NAME)
+13 DO ADDATTR^RORTSK11(RORTSK,TBLDEF,"HEADER","1")
+14 DO ADDATTR^RORTSK11(RORTSK,TBLDEF,"FOOTER","1")
+15 DO TBLDEF1(TBLDEF)
End DoDot:1
if RC<0
QUIT
+16 KILL ^TMP($JOB,"RORSELCOL")
+17 QUIT $SELECT(RC<0:RC,1:0)
+18 ;
+19 ;***** GENERATES <COLUMN> ELEMENTS FROM TABLE DEFINITION (RORSRC)
+20 ;
+21 ; PTAG IEN of the parent element
+22 ;
TBLDEF1(PTAG) ;
+1 NEW COLUMN,IT,NAME,OK,ROR,TERM
+2 FOR
SET NAME=$$COLSCAN(.TERM)
if NAME=""
QUIT
Begin DoDot:1
+3 ; set up special columns selection criteria
IF '$DATA(^TMP($JOB,"RORSELCOL"))
Begin DoDot:2
+4 FOR IT=1:1
XECUTE "S ROR=$P($T(SELCOL+"_IT_"^RORXU002),"";;"",2)"
if $PIECE(ROR,U)=""
QUIT
Begin DoDot:3
+5 SET ^TMP($JOB,"RORSELCOL",$PIECE(ROR,U))=$PIECE(ROR,U,2,999)
End DoDot:3
End DoDot:2
+6 IF $DATA(^TMP($JOB,"RORSELCOL",NAME))
Begin DoDot:2
+7 XECUTE ^TMP($JOB,"RORSELCOL",NAME)
SET OK=$TEST
End DoDot:2
if 'OK
QUIT
+8 SET COLUMN=$$ADDVAL^RORTSK11(RORTSK,"COLUMN",,PTAG)
+9 DO ADDATTR^RORTSK11(RORTSK,COLUMN,"NAME",NAME)
+10 if TERM="("
DO TBLDEF1(COLUMN)
End DoDot:1
if ")"[TERM
QUIT
+11 QUIT
+12 ;
+13 ;Setup of values in SELCOL is:
+14 ;name of selected optional column^statement to execute to set $T if the condition to include this field has been met
+15 ;
SELCOL ;selected optional fields and screen criteria is listed here
+1 ;;ICN^I $$PARAM^RORTSK01("PATIENTS","ICN")
+2 ;;FIB4^I $D(RORTSK("PARAMS","LRGRANGES","C",4))
+3 ;;PACT^I $$PARAM^RORTSK01("PATIENTS","PACT")
+4 ;;PCP^I $$PARAM^RORTSK01("PATIENTS","PCP")
+5 ;;FUT_APPT^I $$PARAM^RORTSK01("OPTIONS","FUT_APPT")
+6 ;;FUT_CLIN^I $$PARAM^RORTSK01("OPTIONS","FUT_APPT")
+7 ;;
