RORX019A ;BPOIFO/ACS - LIVER SCORE BY RANGE (CONT.) ; 8/23/11 8:38am
;;1.5;CLINICAL CASE REGISTRIES;**10,13,14,16**;Feb 17, 2006;Build 3
;
;08/23/2011 BP/KAM ROR*1.5*16 Remedy Call 512757 Correct the Liver
; Score Calculation
;
; This routine uses the following IAs:
;
; #10105 $$LN^XLFMTH (supported)
; #3556 GCPR^LA7QRY (supported)
; #10061 DEM^VADPT (supported)
;
;******************************************************************************
;******************************************************************************
; --- ROUTINE MODIFICATION LOG ---
;
;PKG/PATCH DATE DEVELOPER MODIFICATION
;----------- ---------- ----------- ----------------------------------------
;ROR*1.5*10 MAR 2010 A SAUNDERS Routine created
;ROR*1.5*13 DEC 2010 A SAUNDERS Moved tag CALCMLD to this routine
;ROR*1.5*14 APR 2011 A SAUNDERS Added logic to calculate the APRI and
; FIB4 scores.
;
;******************************************************************************
;******************************************************************************
Q
;
;*****************************************************************************
;OUTPUT REPORT 'RANGE' PARAMETERS, SET UP REPORT ID LIST (EXTRINISIC FUNCTION)
;
; PARTAG Reference (IEN) to the parent tag
;
; Return Values:
; RORDATA("IDLST") - list of IDs for tests requested
; <0 Error code
; 0 Ok
;*****************************************************************************
PARAMS(PARTAG,RORDATA,RORTSK) ;
N PARAMS,DESC,TMP,RC S RC=0
;--- Lab test ranges
S RORDATA("RANGE",1)=0 ;initialize MELD to 'no range passed in'
S RORDATA("RANGE",2)=0 ;initialize MELD Na to 'no range passed in'
S RORDATA("RANGE",3)=0 ;initialize APRI to 'no range passed in'
S RORDATA("RANGE",4)=0 ;initialize FIB4 to 'no range passed in'
I $D(RORTSK("PARAMS","LRGRANGES","C"))>1 D Q:RC<0 RC
. N GRC,ELEMENT,NODE,RTAG,RANGE
. S NODE=$NA(RORTSK("PARAMS","LRGRANGES","C"))
. S RTAG=$$ADDVAL^RORTSK11(RORTSK,"LRGRANGES",,PARTAG)
. S (GRC,RC)=0
. F S GRC=$O(@NODE@(GRC)) Q:GRC'>0 D Q:RC<0
.. S RANGE=0,DESC=$$RTEXT(GRC,.RORDATA,.RORTSK) ;get range description
.. S ELEMENT=$$ADDVAL^RORTSK11(RORTSK,"LRGRANGE",DESC,RTAG) ;add desc to output
.. I ELEMENT<0 S RC=ELEMENT Q
.. D ADDATTR^RORTSK11(RORTSK,ELEMENT,"ID",GRC)
.. ;add test ID to the test ID 'list'
.. S RORDATA("IDLST")=$G(RORDATA("IDLST"))_$S($G(RORDATA("IDLST"))'="":","_GRC,1:GRC)
.. ;--- Process the range values
.. S TMP=$G(@NODE@(GRC,"L"))
.. I TMP'="" D S RANGE=1
... D ADDATTR^RORTSK11(RORTSK,ELEMENT,"LOW",TMP) S RORDATA("RANGE",GRC)=1
.. S TMP=$G(@NODE@(GRC,"H"))
.. I TMP'="" D S RANGE=1
... D ADDATTR^RORTSK11(RORTSK,ELEMENT,"HIGH",TMP) S RORDATA("RANGE",GRC)=1
.. I RANGE D ADDATTR^RORTSK11(RORTSK,ELEMENT,"RANGE",1)
;if user didn't select any tests, default to both tests
;I $G(RORDATA("IDLST"))="" S RORDATA("IDLST")="1,2" ;user must select a report in PATCH 12
;--- Success
Q RC
;
;*****************************************************************************
;RETURN RANGE TEXT, ADD RANGE VALUES TO RORDATA (EXTRINISIC FUNCTION)
;
;INPUT:
; GRC Test ID number
; ID=1: MELD
; ID=2: MELD-Na
; ID=3: APRI
; ID=4: FIB4
; RORDATA - Array with ROR data
; RORTSK - Task parameters
;
;OUTPUT:
; RORDATA(ID,"L") - test ID low range
; RORDATA(ID,"H") - test ID high range
; Description - <range>
;*****************************************************************************
RTEXT(GRC,RORDATA,RORTSK) ;
N RANGE,TMP
S RANGE=""
;--- Range
I $D(RORTSK("PARAMS","LRGRANGES","C",GRC))>1 D
. ;--- Low
. S TMP=$G(RORTSK("PARAMS","LRGRANGES","C",GRC,"L"))
. S RORDATA(GRC,"L")=$G(TMP)
. S:TMP'="" RANGE=RANGE_" not less than "_TMP
. ;--- High
. S TMP=$G(RORTSK("PARAMS","LRGRANGES","C",GRC,"H"))
. S RORDATA(GRC,"H")=$G(TMP)
. I TMP'="" D:RANGE'="" S RANGE=RANGE_" not greater than "_TMP
. . S RANGE=RANGE_" and"
;--- Description
S TMP=$G(RORTSK("PARAMS","LRGRANGES","C",GRC))
S:TMP="" TMP="Unknown ("_GRC_")"
Q TMP_" - "_$S(RANGE'="":"numeric results"_RANGE,1:"all results")
;
;************************************************************************
;CALCULATE THE MELD SCORE(S) - MELD AND MELD-NA
;
;INPUT
; DFN Patient DFN in LAB DATA file (#63)
; PTAG Reference IEN to the 'body' parent XML tag
; RORDATA Array with ROR data
; RORDATA("FIELDS") - Field list for retrieving the test results
; RORPTIEN Patient IEN in the ROR registry
; RORLC sub-file and LOINC codes to search for
;
;OUTPUT
; RORDATA Array with ROR data
; RORDATA("BILI")=RESULT^DATE - Bilirubin result and date
; RORDATA("CR")=RESULT^DATE - Creatinine result and date
; RORDATA("INR")=RESULT^DATE - INR result and date
; RORDATA("NA")=RESULT^DATE - Sodium result and date
; RORDATA("SCORE",1) - MELD score
; RORDATA("SCORE",2) - MELD-Na score
;
; 1 Patient should appear on report
; -1 Patient should NOT appear on report
;
; NOTE: the 'invalid' results will be stored as 'backup' results, in
; case no valid result is found for Creatinine or Sodium. An invalid
; creatinine result is >12. An invalid Sodium result is <100 or >180.
; These results will be displayed on the report if no MELD range was
; specifically requested by the user, but the score will not be calculated.
; They will not be displayed on the report if the user requested a MELD
; range.
;************************************************************************
CALCMLD(DFN,PTAG,RORDATA,RORPTIEN,RORLC) ;
N RORID,RORST,ROREND,RORLAB,RORMSG,RC
S RORDATA("CALC")=0,RORDATA("CALCNA")=0 ;don't automatically calculate scores
K RORDATA("SCORE",1),RORDATA("SCORE",2) ;calculated test scores
K RORDATA("BVAL"),RORDATA("CVAL"),RORDATA("IVAL"),RORDATA("SVAL") ;test results
K RORDATA("CINV"),RORDATA("SINV") ;test results
K RORDATA("BILI"),RORDATA("CR"),RORDATA("INR"),RORDATA("NA") ;test result&date
;get patient ICN or SSN
S RORID=$$PTID^RORUTL02(DFN)
Q:'$G(RORID) -1
;---SET UP LAB API INPUT/OUTPUT PARMS---
S RORST="2000101^CD" ;start date 1/1/1900
S ROREND=$G(RORDATA("DATE"))\1 ;end date
;add 1 to the end date so the Lab API INCLUDES the end date correctly
N X1,X2,X3 S X1=ROREND,X2=1 D C^%DTC S ROREND=X K X,X1,X2
S ROREND=ROREND_"^CD"
S RORLAB=$NA(^TMP("ROROUT",$J)) ;lab API output global
K RORMSG,@RORLAB ;initialize prior to call
;---CALL LAB API---
S RC=$$GCPR^LA7QRY(RORID,RORST,ROREND,.RORLC,"*",.RORMSG,RORLAB)
I RC="",$D(RORMSG)>1 D ;quit if error returned
. N ERR,I,LST,TMP
. S (ERR,LST)=""
. F I=1:1 S ERR=$O(RORMSG(ERR)) Q:ERR="" D
. . S LST=LST_","_ERR,TMP=RORMSG(ERR)
. . K RORMSG(ERR) S RORMSG(I)=TMP
. S LST=$P(LST,",",2,999) Q:(LST=3)!(LST=99)
. S RC=$$ERROR^RORERR(-27,,.RORMSG,RORPTIEN)
I RC<0 Q -1
;Note: the Lab API returns data in the form of HL7 segments
N TMP,RORSPEC,RORVAL,RORNODE,RORSEG,SEGTYPE,RORLOINC,RORDONE,RORDATE,RORTEST
N RORCR,RORBIL,RORSOD,RORINR,FS
S FS="|" ;HL7 field separator for lab data
S (RORCR,RORBIL,RORSOD,RORINR,RORDONE,RORNODE)=0
F S RORNODE=$O(^TMP("ROROUT",$J,RORNODE)) Q:((RORNODE="")!(RORDONE)) D
. S RORSEG=$G(^TMP("ROROUT",$J,RORNODE)) ;get entire HL7 segment
. S SEGTYPE=$P(RORSEG,FS,1) ;get segment type (PID,OBR,OBX,etc.)
. Q:SEGTYPE'="OBX" ;we want OBX segments only
. S RORSPEC=$P($P(RORSEG,FS,4),U,2) ;specimen type string (urine, serum, etc.)
. S RORSPEC=":"_RORSPEC_":" ;append ":" as prefix and suffix
. I ((RORSPEC[":UA:")!(RORSPEC[":UR:")) Q ;quit if specimen type is urine
. S RORLOINC=$P($P(RORSEG,FS,4),U,1) ;get LOINC code for test
. S RORVAL=$P(RORSEG,FS,6) ;test result value
. S RORVAL=$TR(RORVAL,"""","") ;get rid of double quotes around values
. Q:($G(RORVAL)'>0) ;quit if no value
. S RORDATE=$$HL7TFM^XLFDT($P(RORSEG,FS,15)) ;get date collected
. S RORDATE=RORDATE\1
. ;---check for Creatinine match on LOINC---
. I 'RORCR,RORDATA("CR_LOINC")[(";"_RORLOINC_";") D Q
.. ;store 'valid' value (12 or less) if no 'valid' value has been stored yet
.. I RORVAL'>12,$O(RORDATA("CVAL",0))="" S RORDATA("CVAL",RORDATE)=RORVAL,RORCR=1 Q
.. ;store 'invalid' value (>12) if no other value has been stored
.. I RORVAL>12,$O(RORDATA("CVAL",0))="",$O(RORDATA("CINV",0))="" D
... S RORDATA("CINV",RORDATE)=$G(RORVAL)_"*" ;mark as 'invalid' value
. ;---check for Sodium match on LOINC---
. I 'RORSOD,RORDATA("SOD_LOINC")[(";"_RORLOINC_";") D Q
.. ;store 'valid' value (100 to 180) if no other 'valid' value has been stored
.. I RORVAL'<100,RORVAL'>180,$O(RORDATA("SVAL",0))="" D Q
... S RORDATA("SVAL",RORDATE)=$G(RORVAL),RORSOD=1
.. ;store 'invalid' value (<100 or >180) if no other value has been stored yet
.. I ((RORVAL<100)!(RORVAL>180)),$O(RORDATA("SVAL",0))="",$O(RORDATA("SINV",0))="" D Q
... S RORDATA("SINV",RORDATE)=RORVAL_"*" Q ;mark as 'invalid' value
. ;---check for Bilirubin match on LOINC---
. I 'RORBIL,RORDATA("BIL_LOINC")[(";"_RORLOINC_";") D Q
.. ;store first Bilirubin value
.. I $O(RORDATA("BVAL",0))="" S RORDATA("BVAL",RORDATE)=RORVAL,RORBIL=1
. ;---check for INR match on LOINC---
. I 'RORINR,RORDATA("INR_LOINC")[(";"_RORLOINC_";") D Q
.. ;store first INR value
.. I $O(RORDATA("IVAL",0))="" S RORDATA("IVAL",RORDATE)=RORVAL,RORINR=1
. ;set flags to indicate if MELD/MELD-NA scores are ready to be calculated for this patient
. I RORCR,RORBIL,RORINR S RORDATA("CALC")=1 D
.. I RORDATA("IDLST")=1 S RORDONE=1 Q
.. I RORSOD S RORDATA("CALCNA")=1,RORDONE=1
;
;if patient doesn't have data for either score, don't put them on report
I '$G(RORDATA("CALC")),'$G(RORDATA("CALCNA")) Q -1
;--- put test result and test date into RORDATA(<test_name>)=result^date
N DATE
S DATE=$O(RORDATA("BVAL",0)) ;Bilirubin
S RORDATA("BILI")=$S($G(DATE)="":U,1:$G(RORDATA("BVAL",DATE))_U_$G(DATE))
S DATE=$O(RORDATA("CVAL",0)) ;Creatinine
I $G(DATE)="" D ;if regular Creatinine value is null, take invalid value
. S DATE=$O(RORDATA("CINV",0)) I $G(DATE)>0 S RORDATA("CVAL",DATE)=$G(RORDATA("CINV",DATE))
S RORDATA("CR")=$S($G(DATE)="":U,1:$G(RORDATA("CVAL",DATE))_U_$G(DATE))
S DATE=$O(RORDATA("IVAL",0)) ;INR
S RORDATA("INR")=$S($G(DATE)="":U,1:$G(RORDATA("IVAL",DATE))_U_$G(DATE))
S DATE=$O(RORDATA("SVAL",0)) ;Sodium
I $G(DATE)="" D ;if regular Sodium value is null, take invalid value
. S DATE=$O(RORDATA("SINV",0)) I $G(DATE)>0 S RORDATA("SVAL",DATE)=$G(RORDATA("SINV",DATE))
S RORDATA("NA")=$S($G(DATE)="":U,1:$G(RORDATA("SVAL",DATE))_U_$G(DATE))
;
N TEST,BILI,CR,INR,NA
;set lower limits for Bili, Cr, and INR to 1 if there's a value in there
F TEST="BILI","CR","INR" D
. S @TEST=$P($G(RORDATA(TEST)),U,1) Q:$G(@TEST)["*" I $G(@TEST),@TEST<1 S @TEST=1
;for valid creatinine, use max=4 for calculations
I $G(CR)'["*" D
. I $G(CR)>4 S CR=4
S NA=$P($G(RORDATA("NA")),U,1)
;for valid sodium, use min=120, max=135 for calculations
I $G(NA)'["*" D
. I $G(NA)>135 S NA=135 Q
. I $G(NA)'="" I NA<120 S NA=120
;
N TMP1,TMP2
;RORDATA("SCORE",1) will hold the calculated MELD score
;RORDATA("SCORE",2) will hold the calculated MELD Na score
S (RORDATA("SCORE",1),RORDATA("SCORE",2))="" ;init calculated scores to null
D
. Q:($G(CR)["*") ;quit if no calculation should occur
. I $G(BILI),$G(CR),$G(INR) D
.. ;MELD forumula: (.957*lne(Cr) + .378*lne(Bili) + 1.120*lne(Inr) + .643) * 10
.. S TMP1=(.957*($$LN^XLFMTH(CR))+(.378*($$LN^XLFMTH(BILI)))+(1.120*($$LN^XLFMTH(INR)))+.643)*10
.. S RORDATA("SCORE",1)=$J($G(TMP1),0,0) ;round MELD to whole number
.. Q:($G(NA)["*") ;quit if no calculation should occur
.. ;if meld NA requested, sodium test must have a valid value
.. I $G(NA),RORDATA("SCORE",1),RORDATA("IDLST")[2 D
... ;MELD-Na forumula: MELD + (1.59 *(135-Na))
... S TMP2=$G(RORDATA("SCORE",1))+(1.59*(135-NA))
... S RORDATA("SCORE",2)=$J($G(TMP2),0,0)
Q 1
;************************************************************************
;CALCULATE THE FIBROSIS SCORE(S) - APRI and FIB4
;
;INPUT
; DFN Patient DFN in LAB DATA file (#63)
; PTAG Reference IEN to the 'body' parent XML tag
; RORDATA Array with ROR data
; RORDATA("FIELDS") - Field list for retrieving the test results
; RORPTIEN Patient IEN in the ROR registry
; RORLC sub-file and LOINC codes to search for
;
;OUTPUT
; RORDATA Array with ROR data
; RORDATA("AST")=RESULT^DATE - AST result and date
; RORDATA("PLAT")=RESULT^DATE - Platelet result and date
; RORDATA("ALT")=RESULT^DATE - ALT result and date
; RORDATA("SCORE",3) - calculated APRI score
; RORDATA("SCORE",4) - calculated FIB4 score
; 1 Patient should appear on report
; -1 Patient should NOT appear on report
;
;************************************************************************
CALCFIB(DFN,PTAG,RORDATA,RORPTIEN,RORLC) ;
N RORID,RORST,ROREND,RORLAB,RORMSG,RC
S RORDATA("CALCAPRI")=0,RORDATA("CALCFIB4")=0 ;don't automatically calculate scores
K RORDATA("SCORE",3),RORDATA("SCORE",4) ;calculated test scores
K RORDATA("SVAL"),RORDATA("PVAL"),RORDATA("LVAL") ;test results
K RORDATA("ALT"),RORDATA("PLAT"),RORDATA("AST") ; tes result and date
;get patient ICN or SSN
S RORID=$$PTID^RORUTL02(DFN)
Q:'$G(RORID) -1
;---SET UP LAB API INPUT/OUTPUT PARMS---
S RORST="2000101^CD" ;start date 1/1/1900
S ROREND=$G(RORDATA("DATE"))\1 ;end date
;add 1 to the end date so the Lab API INCLUDES the end date correctly
N X1,X2,X3 S X1=ROREND,X2=1 D C^%DTC S ROREND=X K X,X1,X2
S ROREND=ROREND_"^CD"
S RORLAB=$NA(^TMP("ROROUT",$J)) ;lab API output global
K RORMSG,@RORLAB ;initialize prior to call
;---CALL LAB API TO GET TEST RESULTS---
S RC=$$GCPR^LA7QRY(RORID,RORST,ROREND,.RORLC,"*",.RORMSG,RORLAB)
I RC="",$D(RORMSG)>1 D Q -1 ;quit if error returned
. N ERR,I,LST,TMP
. S (ERR,LST)=""
. F I=1:1 S ERR=$O(RORMSG(ERR)) Q:ERR="" D
. . S LST=LST_","_ERR,TMP=RORMSG(ERR)
. . K RORMSG(ERR) S RORMSG(I)=TMP
. S LST=$P(LST,",",2,999) Q:(LST=3)!(LST=99)
. S RC=$$ERROR^RORERR(-27,,.RORMSG,RORPTIEN)
I RC<0 Q -1
;Note: the Lab API returns data in the form of HL7 segments
N TMP,RORSPEC,RORVAL,RORNODE,RORSEG,SEGTYPE,RORLOINC,RORDONE,RORDATE,RORTEST
N RORAST,RORPLAT,RORALT,FS
S FS="|" ;HL7 field separator for lab data
S (RORAST,RORPLAT,RORALT,RORDONE,RORNODE)=0
F S RORNODE=$O(^TMP("ROROUT",$J,RORNODE)) Q:((RORNODE="")!(RORDONE)) D
. S RORSEG=$G(^TMP("ROROUT",$J,RORNODE)) ;entire HL7 segment
. S SEGTYPE=$P(RORSEG,FS,1) ;segment type (PID,OBR,OBX,etc.)
. Q:SEGTYPE'="OBX" ;test results are in the OBX segment
. S RORSPEC=$P($P(RORSEG,FS,4),U,2) ;specimen type (urine, serum, etc.)
. S RORSPEC=":"_RORSPEC_":" ;append ":" as prefix and suffix
. I ((RORSPEC[":UA:")!(RORSPEC[":UR:")) Q ;quit if specimen type is urine
. S RORLOINC=$P($P(RORSEG,FS,4),U,1) ;LOINC code for test
. S RORVAL=$P(RORSEG,FS,6) ;test result value
. S RORVAL=$TR(RORVAL,"""","") ;get rid of double quotes around values
. Q:($G(RORVAL)'>0) ;quit if no value
. S RORDATE=$$HL7TFM^XLFDT($P(RORSEG,FS,15)) ;get date collected
. S RORDATE=RORDATE\1
. ;test results will be stored in RORDATA("SVAL"),RORDATA("PVAL"), and RORDATA("LVAL")
. ;---check for AST match on LOINC if not yet found and store it---
. I 'RORAST,RORDATA("AST_LOINC")[(";"_RORLOINC_";") D Q
.. S RORDATA("SVAL",RORDATE)=RORVAL,RORAST=1 Q
. ;---check for Platelet match on LOINC if not yet found and store it---
. I 'RORPLAT,RORDATA("PLAT_LOINC")[(";"_RORLOINC_";") D Q
.. S RORDATA("PVAL",RORDATE)=$G(RORVAL),RORPLAT=1
. ;---check for ALT match on LOINC if not yet found and store it---
. I 'RORALT,RORDATA("ALT_LOINC")[(";"_RORLOINC_";") D Q
.. S RORDATA("LVAL",RORDATE)=RORVAL,RORALT=1
. ;set flags to indicate if APRI/FIB4 scores are ready to be calculated for this patient
. I RORAST,RORPLAT S RORDATA("CALCAPRI")=1 D
.. I RORDATA("IDLST")=3 S RORDONE=1 ;done if APRI is the only score requested
.. I RORALT S RORDATA("CALCFIB4")=1,RORDONE=1
;
;if patient doesn't have data for either score, then they shouldn't show up on report
I '$G(RORDATA("CALCAPRI")),'$G(RORDATA("CALCFIB4")) Q -1
;--- put test result and test date into RORDATA(<test_name>)=result^date
N DATE
S DATE=$O(RORDATA("SVAL",0)) ;AST
S RORDATA("AST")=$S($G(DATE)="":U,1:$G(RORDATA("SVAL",DATE))_U_$G(DATE))
S DATE=$O(RORDATA("PVAL",0)) ;Platelet
S RORDATA("PLAT")=$S($G(DATE)="":U,1:$G(RORDATA("PVAL",DATE))_U_$G(DATE))
S DATE=$O(RORDATA("LVAL",0)) ;ALT
S RORDATA("ALT")=$S($G(DATE)="":U,1:$G(RORDATA("LVAL",DATE))_U_$G(DATE))
;--- get just the test result values from array
N TEST,AST,PLAT,ALT
F TEST="AST","PLAT","ALT" S @TEST=$P($G(RORDATA(TEST)),U,1)
;--- calculate APRI/FIB4 scores
N TMP1,TMP2
;RORDATA("SCORE",3) will hold the calculated APRI score
;RORDATA("SCORE",4) will hold the calculated FIB4 score
S (RORDATA("SCORE",3),RORDATA("SCORE",4))="" ;init calculated scores to null
S RC=1
I $G(AST),$G(PLAT) D
. I RORDATA("IDLST")[3 D ;calculate APRI score: [AST/ULNAST/PLAT] * 100
.. S TMP1=(AST/RORDATA("ULNAST")/PLAT)*100
.. S RORDATA("SCORE",3)=$J($G(TMP1),0,2) ;round to 2 decimal points
. I $G(ALT),RORDATA("IDLST")[4 D ;calculate FIB4 score: (AGE*AST)/[(PLAT*ALT) to 1/2 power]
.. N AGE S AGE=$$AGE(DFN,RORDATA("DATE")) ;get patient age
.. I '$G(AGE) S RC=-1 Q ;quit if age can't be calculated
.. ;
.. ; ROR*1.5*16 remedy ticket 512757 changed next two lines
.. ;S TMP2=(AGE*AST)/$$PWR^XLFMTH((PLAT*ALT),.5)
.. ;S RORDATA("SCORE",4)=$J($G(TMP2),0,0) ;round to whole number
.. S TMP2=(AGE*AST)/(PLAT*($$PWR^XLFMTH((ALT),.5)))
.. S RORDATA("SCORE",4)=$J($G(TMP2),0,2) ;round to 2 decimal places
.. ;
Q RC
;
;************************************************************************
;CALCULATE PATIENT AGE - EXTRINSIC FUNCTION
;
;INPUT
; DFN Patient DFN in PATIENT file (#2)
; DATE user-selected date for report calculations
;
;OUTPUT
; Patient age is returned
;************************************************************************
AGE(DFN,DATE) ;
;--- get patient dob and dod using DEM^VADPT
N RORDEM,RORDOB,RORDOD,RORAGE,VAROOT
S VAROOT="RORDEM" D DEM^VADPT
S RORDOB=$P($G(RORDEM(3)),U,1) ;date of birth
S RORAGE=$P($G(RORDEM(4)),U,1) ;age as of today (DT)
S RORDOD=$P($G(RORDEM(6)),U,1) ;date of death
I DATE=DT Q $G(RORAGE) ;if 'most recent' date, return age in API results
;compare DOD and user-selected 'as of' DATE
I $G(RORDOD),$G(RORDOD)<DATE S DATE=RORDOD\1 ;use DOD if earlier than DATE
S RORAGE=DATE-RORDOB ;calculate age
S RORAGE=$S($L(RORAGE)=6:$E($G(RORAGE),1,2),1:$E($G(RORAGE),1,3))
Q $G(RORAGE)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORX019A 19318 printed Sep 23, 2025@19:20:51 Page 2
RORX019A ;BPOIFO/ACS - LIVER SCORE BY RANGE (CONT.) ; 8/23/11 8:38am
+1 ;;1.5;CLINICAL CASE REGISTRIES;**10,13,14,16**;Feb 17, 2006;Build 3
+2 ;
+3 ;08/23/2011 BP/KAM ROR*1.5*16 Remedy Call 512757 Correct the Liver
+4 ; Score Calculation
+5 ;
+6 ; This routine uses the following IAs:
+7 ;
+8 ; #10105 $$LN^XLFMTH (supported)
+9 ; #3556 GCPR^LA7QRY (supported)
+10 ; #10061 DEM^VADPT (supported)
+11 ;
+12 ;******************************************************************************
+13 ;******************************************************************************
+14 ; --- ROUTINE MODIFICATION LOG ---
+15 ;
+16 ;PKG/PATCH DATE DEVELOPER MODIFICATION
+17 ;----------- ---------- ----------- ----------------------------------------
+18 ;ROR*1.5*10 MAR 2010 A SAUNDERS Routine created
+19 ;ROR*1.5*13 DEC 2010 A SAUNDERS Moved tag CALCMLD to this routine
+20 ;ROR*1.5*14 APR 2011 A SAUNDERS Added logic to calculate the APRI and
+21 ; FIB4 scores.
+22 ;
+23 ;******************************************************************************
+24 ;******************************************************************************
+25 QUIT
+26 ;
+27 ;*****************************************************************************
+28 ;OUTPUT REPORT 'RANGE' PARAMETERS, SET UP REPORT ID LIST (EXTRINISIC FUNCTION)
+29 ;
+30 ; PARTAG Reference (IEN) to the parent tag
+31 ;
+32 ; Return Values:
+33 ; RORDATA("IDLST") - list of IDs for tests requested
+34 ; <0 Error code
+35 ; 0 Ok
+36 ;*****************************************************************************
PARAMS(PARTAG,RORDATA,RORTSK) ;
+1 NEW PARAMS,DESC,TMP,RC
SET RC=0
+2 ;--- Lab test ranges
+3 ;initialize MELD to 'no range passed in'
SET RORDATA("RANGE",1)=0
+4 ;initialize MELD Na to 'no range passed in'
SET RORDATA("RANGE",2)=0
+5 ;initialize APRI to 'no range passed in'
SET RORDATA("RANGE",3)=0
+6 ;initialize FIB4 to 'no range passed in'
SET RORDATA("RANGE",4)=0
+7 IF $DATA(RORTSK("PARAMS","LRGRANGES","C"))>1
Begin DoDot:1
+8 NEW GRC,ELEMENT,NODE,RTAG,RANGE
+9 SET NODE=$NAME(RORTSK("PARAMS","LRGRANGES","C"))
+10 SET RTAG=$$ADDVAL^RORTSK11(RORTSK,"LRGRANGES",,PARTAG)
+11 SET (GRC,RC)=0
+12 FOR
SET GRC=$ORDER(@NODE@(GRC))
if GRC'>0
QUIT
Begin DoDot:2
+13 ;get range description
SET RANGE=0
SET DESC=$$RTEXT(GRC,.RORDATA,.RORTSK)
+14 ;add desc to output
SET ELEMENT=$$ADDVAL^RORTSK11(RORTSK,"LRGRANGE",DESC,RTAG)
+15 IF ELEMENT<0
SET RC=ELEMENT
QUIT
+16 DO ADDATTR^RORTSK11(RORTSK,ELEMENT,"ID",GRC)
+17 ;add test ID to the test ID 'list'
+18 SET RORDATA("IDLST")=$GET(RORDATA("IDLST"))_$SELECT($GET(RORDATA("IDLST"))'="":","_GRC,1:GRC)
+19 ;--- Process the range values
+20 SET TMP=$GET(@NODE@(GRC,"L"))
+21 IF TMP'=""
Begin DoDot:3
+22 DO ADDATTR^RORTSK11(RORTSK,ELEMENT,"LOW",TMP)
SET RORDATA("RANGE",GRC)=1
End DoDot:3
SET RANGE=1
+23 SET TMP=$GET(@NODE@(GRC,"H"))
+24 IF TMP'=""
Begin DoDot:3
+25 DO ADDATTR^RORTSK11(RORTSK,ELEMENT,"HIGH",TMP)
SET RORDATA("RANGE",GRC)=1
End DoDot:3
SET RANGE=1
+26 IF RANGE
DO ADDATTR^RORTSK11(RORTSK,ELEMENT,"RANGE",1)
End DoDot:2
if RC<0
QUIT
End DoDot:1
if RC<0
QUIT RC
+27 ;if user didn't select any tests, default to both tests
+28 ;I $G(RORDATA("IDLST"))="" S RORDATA("IDLST")="1,2" ;user must select a report in PATCH 12
+29 ;--- Success
+30 QUIT RC
+31 ;
+32 ;*****************************************************************************
+33 ;RETURN RANGE TEXT, ADD RANGE VALUES TO RORDATA (EXTRINISIC FUNCTION)
+34 ;
+35 ;INPUT:
+36 ; GRC Test ID number
+37 ; ID=1: MELD
+38 ; ID=2: MELD-Na
+39 ; ID=3: APRI
+40 ; ID=4: FIB4
+41 ; RORDATA - Array with ROR data
+42 ; RORTSK - Task parameters
+43 ;
+44 ;OUTPUT:
+45 ; RORDATA(ID,"L") - test ID low range
+46 ; RORDATA(ID,"H") - test ID high range
+47 ; Description - <range>
+48 ;*****************************************************************************
RTEXT(GRC,RORDATA,RORTSK) ;
+1 NEW RANGE,TMP
+2 SET RANGE=""
+3 ;--- Range
+4 IF $DATA(RORTSK("PARAMS","LRGRANGES","C",GRC))>1
Begin DoDot:1
+5 ;--- Low
+6 SET TMP=$GET(RORTSK("PARAMS","LRGRANGES","C",GRC,"L"))
+7 SET RORDATA(GRC,"L")=$GET(TMP)
+8 if TMP'=""
SET RANGE=RANGE_" not less than "_TMP
+9 ;--- High
+10 SET TMP=$GET(RORTSK("PARAMS","LRGRANGES","C",GRC,"H"))
+11 SET RORDATA(GRC,"H")=$GET(TMP)
+12 IF TMP'=""
if RANGE'=""
Begin DoDot:2
+13 SET RANGE=RANGE_" and"
End DoDot:2
SET RANGE=RANGE_" not greater than "_TMP
End DoDot:1
+14 ;--- Description
+15 SET TMP=$GET(RORTSK("PARAMS","LRGRANGES","C",GRC))
+16 if TMP=""
SET TMP="Unknown ("_GRC_")"
+17 QUIT TMP_" - "_$SELECT(RANGE'="":"numeric results"_RANGE,1:"all results")
+18 ;
+19 ;************************************************************************
+20 ;CALCULATE THE MELD SCORE(S) - MELD AND MELD-NA
+21 ;
+22 ;INPUT
+23 ; DFN Patient DFN in LAB DATA file (#63)
+24 ; PTAG Reference IEN to the 'body' parent XML tag
+25 ; RORDATA Array with ROR data
+26 ; RORDATA("FIELDS") - Field list for retrieving the test results
+27 ; RORPTIEN Patient IEN in the ROR registry
+28 ; RORLC sub-file and LOINC codes to search for
+29 ;
+30 ;OUTPUT
+31 ; RORDATA Array with ROR data
+32 ; RORDATA("BILI")=RESULT^DATE - Bilirubin result and date
+33 ; RORDATA("CR")=RESULT^DATE - Creatinine result and date
+34 ; RORDATA("INR")=RESULT^DATE - INR result and date
+35 ; RORDATA("NA")=RESULT^DATE - Sodium result and date
+36 ; RORDATA("SCORE",1) - MELD score
+37 ; RORDATA("SCORE",2) - MELD-Na score
+38 ;
+39 ; 1 Patient should appear on report
+40 ; -1 Patient should NOT appear on report
+41 ;
+42 ; NOTE: the 'invalid' results will be stored as 'backup' results, in
+43 ; case no valid result is found for Creatinine or Sodium. An invalid
+44 ; creatinine result is >12. An invalid Sodium result is <100 or >180.
+45 ; These results will be displayed on the report if no MELD range was
+46 ; specifically requested by the user, but the score will not be calculated.
+47 ; They will not be displayed on the report if the user requested a MELD
+48 ; range.
+49 ;************************************************************************
CALCMLD(DFN,PTAG,RORDATA,RORPTIEN,RORLC) ;
+1 NEW RORID,RORST,ROREND,RORLAB,RORMSG,RC
+2 ;don't automatically calculate scores
SET RORDATA("CALC")=0
SET RORDATA("CALCNA")=0
+3 ;calculated test scores
KILL RORDATA("SCORE",1),RORDATA("SCORE",2)
+4 ;test results
KILL RORDATA("BVAL"),RORDATA("CVAL"),RORDATA("IVAL"),RORDATA("SVAL")
+5 ;test results
KILL RORDATA("CINV"),RORDATA("SINV")
+6 ;test result&date
KILL RORDATA("BILI"),RORDATA("CR"),RORDATA("INR"),RORDATA("NA")
+7 ;get patient ICN or SSN
+8 SET RORID=$$PTID^RORUTL02(DFN)
+9 if '$GET(RORID)
QUIT -1
+10 ;---SET UP LAB API INPUT/OUTPUT PARMS---
+11 ;start date 1/1/1900
SET RORST="2000101^CD"
+12 ;end date
SET ROREND=$GET(RORDATA("DATE"))\1
+13 ;add 1 to the end date so the Lab API INCLUDES the end date correctly
+14 NEW X1,X2,X3
SET X1=ROREND
SET X2=1
DO C^%DTC
SET ROREND=X
KILL X,X1,X2
+15 SET ROREND=ROREND_"^CD"
+16 ;lab API output global
SET RORLAB=$NAME(^TMP("ROROUT",$JOB))
+17 ;initialize prior to call
KILL RORMSG,@RORLAB
+18 ;---CALL LAB API---
+19 SET RC=$$GCPR^LA7QRY(RORID,RORST,ROREND,.RORLC,"*",.RORMSG,RORLAB)
+20 ;quit if error returned
IF RC=""
IF $DATA(RORMSG)>1
Begin DoDot:1
+21 NEW ERR,I,LST,TMP
+22 SET (ERR,LST)=""
+23 FOR I=1:1
SET ERR=$ORDER(RORMSG(ERR))
if ERR=""
QUIT
Begin DoDot:2
+24 SET LST=LST_","_ERR
SET TMP=RORMSG(ERR)
+25 KILL RORMSG(ERR)
SET RORMSG(I)=TMP
End DoDot:2
+26 SET LST=$PIECE(LST,",",2,999)
if (LST=3)!(LST=99)
QUIT
+27 SET RC=$$ERROR^RORERR(-27,,.RORMSG,RORPTIEN)
End DoDot:1
+28 IF RC<0
QUIT -1
+29 ;Note: the Lab API returns data in the form of HL7 segments
+30 NEW TMP,RORSPEC,RORVAL,RORNODE,RORSEG,SEGTYPE,RORLOINC,RORDONE,RORDATE,RORTEST
+31 NEW RORCR,RORBIL,RORSOD,RORINR,FS
+32 ;HL7 field separator for lab data
SET FS="|"
+33 SET (RORCR,RORBIL,RORSOD,RORINR,RORDONE,RORNODE)=0
+34 FOR
SET RORNODE=$ORDER(^TMP("ROROUT",$JOB,RORNODE))
if ((RORNODE="")!(RORDONE))
QUIT
Begin DoDot:1
+35 ;get entire HL7 segment
SET RORSEG=$GET(^TMP("ROROUT",$JOB,RORNODE))
+36 ;get segment type (PID,OBR,OBX,etc.)
SET SEGTYPE=$PIECE(RORSEG,FS,1)
+37 ;we want OBX segments only
if SEGTYPE'="OBX"
QUIT
+38 ;specimen type string (urine, serum, etc.)
SET RORSPEC=$PIECE($PIECE(RORSEG,FS,4),U,2)
+39 ;append ":" as prefix and suffix
SET RORSPEC=":"_RORSPEC_":"
+40 ;quit if specimen type is urine
IF ((RORSPEC[":UA:")!(RORSPEC[":UR:"))
QUIT
+41 ;get LOINC code for test
SET RORLOINC=$PIECE($PIECE(RORSEG,FS,4),U,1)
+42 ;test result value
SET RORVAL=$PIECE(RORSEG,FS,6)
+43 ;get rid of double quotes around values
SET RORVAL=$TRANSLATE(RORVAL,"""","")
+44 ;quit if no value
if ($GET(RORVAL)'>0)
QUIT
+45 ;get date collected
SET RORDATE=$$HL7TFM^XLFDT($PIECE(RORSEG,FS,15))
+46 SET RORDATE=RORDATE\1
+47 ;---check for Creatinine match on LOINC---
+48 IF 'RORCR
IF RORDATA("CR_LOINC")[(";"_RORLOINC_";")
Begin DoDot:2
+49 ;store 'valid' value (12 or less) if no 'valid' value has been stored yet
+50 IF RORVAL'>12
IF $ORDER(RORDATA("CVAL",0))=""
SET RORDATA("CVAL",RORDATE)=RORVAL
SET RORCR=1
QUIT
+51 ;store 'invalid' value (>12) if no other value has been stored
+52 IF RORVAL>12
IF $ORDER(RORDATA("CVAL",0))=""
IF $ORDER(RORDATA("CINV",0))=""
Begin DoDot:3
+53 ;mark as 'invalid' value
SET RORDATA("CINV",RORDATE)=$GET(RORVAL)_"*"
End DoDot:3
End DoDot:2
QUIT
+54 ;---check for Sodium match on LOINC---
+55 IF 'RORSOD
IF RORDATA("SOD_LOINC")[(";"_RORLOINC_";")
Begin DoDot:2
+56 ;store 'valid' value (100 to 180) if no other 'valid' value has been stored
+57 IF RORVAL'<100
IF RORVAL'>180
IF $ORDER(RORDATA("SVAL",0))=""
Begin DoDot:3
+58 SET RORDATA("SVAL",RORDATE)=$GET(RORVAL)
SET RORSOD=1
End DoDot:3
QUIT
+59 ;store 'invalid' value (<100 or >180) if no other value has been stored yet
+60 IF ((RORVAL<100)!(RORVAL>180))
IF $ORDER(RORDATA("SVAL",0))=""
IF $ORDER(RORDATA("SINV",0))=""
Begin DoDot:3
+61 ;mark as 'invalid' value
SET RORDATA("SINV",RORDATE)=RORVAL_"*"
QUIT
End DoDot:3
QUIT
End DoDot:2
QUIT
+62 ;---check for Bilirubin match on LOINC---
+63 IF 'RORBIL
IF RORDATA("BIL_LOINC")[(";"_RORLOINC_";")
Begin DoDot:2
+64 ;store first Bilirubin value
+65 IF $ORDER(RORDATA("BVAL",0))=""
SET RORDATA("BVAL",RORDATE)=RORVAL
SET RORBIL=1
End DoDot:2
QUIT
+66 ;---check for INR match on LOINC---
+67 IF 'RORINR
IF RORDATA("INR_LOINC")[(";"_RORLOINC_";")
Begin DoDot:2
+68 ;store first INR value
+69 IF $ORDER(RORDATA("IVAL",0))=""
SET RORDATA("IVAL",RORDATE)=RORVAL
SET RORINR=1
End DoDot:2
QUIT
+70 ;set flags to indicate if MELD/MELD-NA scores are ready to be calculated for this patient
+71 IF RORCR
IF RORBIL
IF RORINR
SET RORDATA("CALC")=1
Begin DoDot:2
+72 IF RORDATA("IDLST")=1
SET RORDONE=1
QUIT
+73 IF RORSOD
SET RORDATA("CALCNA")=1
SET RORDONE=1
End DoDot:2
End DoDot:1
+74 ;
+75 ;if patient doesn't have data for either score, don't put them on report
+76 IF '$GET(RORDATA("CALC"))
IF '$GET(RORDATA("CALCNA"))
QUIT -1
+77 ;--- put test result and test date into RORDATA(<test_name>)=result^date
+78 NEW DATE
+79 ;Bilirubin
SET DATE=$ORDER(RORDATA("BVAL",0))
+80 SET RORDATA("BILI")=$SELECT($GET(DATE)="":U,1:$GET(RORDATA("BVAL",DATE))_U_$GET(DATE))
+81 ;Creatinine
SET DATE=$ORDER(RORDATA("CVAL",0))
+82 ;if regular Creatinine value is null, take invalid value
IF $GET(DATE)=""
Begin DoDot:1
+83 SET DATE=$ORDER(RORDATA("CINV",0))
IF $GET(DATE)>0
SET RORDATA("CVAL",DATE)=$GET(RORDATA("CINV",DATE))
End DoDot:1
+84 SET RORDATA("CR")=$SELECT($GET(DATE)="":U,1:$GET(RORDATA("CVAL",DATE))_U_$GET(DATE))
+85 ;INR
SET DATE=$ORDER(RORDATA("IVAL",0))
+86 SET RORDATA("INR")=$SELECT($GET(DATE)="":U,1:$GET(RORDATA("IVAL",DATE))_U_$GET(DATE))
+87 ;Sodium
SET DATE=$ORDER(RORDATA("SVAL",0))
+88 ;if regular Sodium value is null, take invalid value
IF $GET(DATE)=""
Begin DoDot:1
+89 SET DATE=$ORDER(RORDATA("SINV",0))
IF $GET(DATE)>0
SET RORDATA("SVAL",DATE)=$GET(RORDATA("SINV",DATE))
End DoDot:1
+90 SET RORDATA("NA")=$SELECT($GET(DATE)="":U,1:$GET(RORDATA("SVAL",DATE))_U_$GET(DATE))
+91 ;
+92 NEW TEST,BILI,CR,INR,NA
+93 ;set lower limits for Bili, Cr, and INR to 1 if there's a value in there
+94 FOR TEST="BILI","CR","INR"
Begin DoDot:1
+95 SET @TEST=$PIECE($GET(RORDATA(TEST)),U,1)
if $GET(@TEST)["*"
QUIT
IF $GET(@TEST)
IF @TEST<1
SET @TEST=1
End DoDot:1
+96 ;for valid creatinine, use max=4 for calculations
+97 IF $GET(CR)'["*"
Begin DoDot:1
+98 IF $GET(CR)>4
SET CR=4
End DoDot:1
+99 SET NA=$PIECE($GET(RORDATA("NA")),U,1)
+100 ;for valid sodium, use min=120, max=135 for calculations
+101 IF $GET(NA)'["*"
Begin DoDot:1
+102 IF $GET(NA)>135
SET NA=135
QUIT
+103 IF $GET(NA)'=""
IF NA<120
SET NA=120
End DoDot:1
+104 ;
+105 NEW TMP1,TMP2
+106 ;RORDATA("SCORE",1) will hold the calculated MELD score
+107 ;RORDATA("SCORE",2) will hold the calculated MELD Na score
+108 ;init calculated scores to null
SET (RORDATA("SCORE",1),RORDATA("SCORE",2))=""
+109 Begin DoDot:1
+110 ;quit if no calculation should occur
if ($GET(CR)["*")
QUIT
+111 IF $GET(BILI)
IF $GET(CR)
IF $GET(INR)
Begin DoDot:2
+112 ;MELD forumula: (.957*lne(Cr) + .378*lne(Bili) + 1.120*lne(Inr) + .643) * 10
+113 SET TMP1=(.957*($$LN^XLFMTH(CR))+(.378*($$LN^XLFMTH(BILI)))+(1.120*($$LN^XLFMTH(INR)))+.643)*10
+114 ;round MELD to whole number
SET RORDATA("SCORE",1)=$JUSTIFY($GET(TMP1),0,0)
+115 ;quit if no calculation should occur
if ($GET(NA)["*")
QUIT
+116 ;if meld NA requested, sodium test must have a valid value
+117 IF $GET(NA)
IF RORDATA("SCORE",1)
IF RORDATA("IDLST")[2
Begin DoDot:3
+118 ;MELD-Na forumula: MELD + (1.59 *(135-Na))
+119 SET TMP2=$GET(RORDATA("SCORE",1))+(1.59*(135-NA))
+120 SET RORDATA("SCORE",2)=$JUSTIFY($GET(TMP2),0,0)
End DoDot:3
End DoDot:2
End DoDot:1
+121 QUIT 1
+122 ;************************************************************************
+123 ;CALCULATE THE FIBROSIS SCORE(S) - APRI and FIB4
+124 ;
+125 ;INPUT
+126 ; DFN Patient DFN in LAB DATA file (#63)
+127 ; PTAG Reference IEN to the 'body' parent XML tag
+128 ; RORDATA Array with ROR data
+129 ; RORDATA("FIELDS") - Field list for retrieving the test results
+130 ; RORPTIEN Patient IEN in the ROR registry
+131 ; RORLC sub-file and LOINC codes to search for
+132 ;
+133 ;OUTPUT
+134 ; RORDATA Array with ROR data
+135 ; RORDATA("AST")=RESULT^DATE - AST result and date
+136 ; RORDATA("PLAT")=RESULT^DATE - Platelet result and date
+137 ; RORDATA("ALT")=RESULT^DATE - ALT result and date
+138 ; RORDATA("SCORE",3) - calculated APRI score
+139 ; RORDATA("SCORE",4) - calculated FIB4 score
+140 ; 1 Patient should appear on report
+141 ; -1 Patient should NOT appear on report
+142 ;
+143 ;************************************************************************
CALCFIB(DFN,PTAG,RORDATA,RORPTIEN,RORLC) ;
+1 NEW RORID,RORST,ROREND,RORLAB,RORMSG,RC
+2 ;don't automatically calculate scores
SET RORDATA("CALCAPRI")=0
SET RORDATA("CALCFIB4")=0
+3 ;calculated test scores
KILL RORDATA("SCORE",3),RORDATA("SCORE",4)
+4 ;test results
KILL RORDATA("SVAL"),RORDATA("PVAL"),RORDATA("LVAL")
+5 ; tes result and date
KILL RORDATA("ALT"),RORDATA("PLAT"),RORDATA("AST")
+6 ;get patient ICN or SSN
+7 SET RORID=$$PTID^RORUTL02(DFN)
+8 if '$GET(RORID)
QUIT -1
+9 ;---SET UP LAB API INPUT/OUTPUT PARMS---
+10 ;start date 1/1/1900
SET RORST="2000101^CD"
+11 ;end date
SET ROREND=$GET(RORDATA("DATE"))\1
+12 ;add 1 to the end date so the Lab API INCLUDES the end date correctly
+13 NEW X1,X2,X3
SET X1=ROREND
SET X2=1
DO C^%DTC
SET ROREND=X
KILL X,X1,X2
+14 SET ROREND=ROREND_"^CD"
+15 ;lab API output global
SET RORLAB=$NAME(^TMP("ROROUT",$JOB))
+16 ;initialize prior to call
KILL RORMSG,@RORLAB
+17 ;---CALL LAB API TO GET TEST RESULTS---
+18 SET RC=$$GCPR^LA7QRY(RORID,RORST,ROREND,.RORLC,"*",.RORMSG,RORLAB)
+19 ;quit if error returned
IF RC=""
IF $DATA(RORMSG)>1
Begin DoDot:1
+20 NEW ERR,I,LST,TMP
+21 SET (ERR,LST)=""
+22 FOR I=1:1
SET ERR=$ORDER(RORMSG(ERR))
if ERR=""
QUIT
Begin DoDot:2
+23 SET LST=LST_","_ERR
SET TMP=RORMSG(ERR)
+24 KILL RORMSG(ERR)
SET RORMSG(I)=TMP
End DoDot:2
+25 SET LST=$PIECE(LST,",",2,999)
if (LST=3)!(LST=99)
QUIT
+26 SET RC=$$ERROR^RORERR(-27,,.RORMSG,RORPTIEN)
End DoDot:1
QUIT -1
+27 IF RC<0
QUIT -1
+28 ;Note: the Lab API returns data in the form of HL7 segments
+29 NEW TMP,RORSPEC,RORVAL,RORNODE,RORSEG,SEGTYPE,RORLOINC,RORDONE,RORDATE,RORTEST
+30 NEW RORAST,RORPLAT,RORALT,FS
+31 ;HL7 field separator for lab data
SET FS="|"
+32 SET (RORAST,RORPLAT,RORALT,RORDONE,RORNODE)=0
+33 FOR
SET RORNODE=$ORDER(^TMP("ROROUT",$JOB,RORNODE))
if ((RORNODE="")!(RORDONE))
QUIT
Begin DoDot:1
+34 ;entire HL7 segment
SET RORSEG=$GET(^TMP("ROROUT",$JOB,RORNODE))
+35 ;segment type (PID,OBR,OBX,etc.)
SET SEGTYPE=$PIECE(RORSEG,FS,1)
+36 ;test results are in the OBX segment
if SEGTYPE'="OBX"
QUIT
+37 ;specimen type (urine, serum, etc.)
SET RORSPEC=$PIECE($PIECE(RORSEG,FS,4),U,2)
+38 ;append ":" as prefix and suffix
SET RORSPEC=":"_RORSPEC_":"
+39 ;quit if specimen type is urine
IF ((RORSPEC[":UA:")!(RORSPEC[":UR:"))
QUIT
+40 ;LOINC code for test
SET RORLOINC=$PIECE($PIECE(RORSEG,FS,4),U,1)
+41 ;test result value
SET RORVAL=$PIECE(RORSEG,FS,6)
+42 ;get rid of double quotes around values
SET RORVAL=$TRANSLATE(RORVAL,"""","")
+43 ;quit if no value
if ($GET(RORVAL)'>0)
QUIT
+44 ;get date collected
SET RORDATE=$$HL7TFM^XLFDT($PIECE(RORSEG,FS,15))
+45 SET RORDATE=RORDATE\1
+46 ;test results will be stored in RORDATA("SVAL"),RORDATA("PVAL"), and RORDATA("LVAL")
+47 ;---check for AST match on LOINC if not yet found and store it---
+48 IF 'RORAST
IF RORDATA("AST_LOINC")[(";"_RORLOINC_";")
Begin DoDot:2
+49 SET RORDATA("SVAL",RORDATE)=RORVAL
SET RORAST=1
QUIT
End DoDot:2
QUIT
+50 ;---check for Platelet match on LOINC if not yet found and store it---
+51 IF 'RORPLAT
IF RORDATA("PLAT_LOINC")[(";"_RORLOINC_";")
Begin DoDot:2
+52 SET RORDATA("PVAL",RORDATE)=$GET(RORVAL)
SET RORPLAT=1
End DoDot:2
QUIT
+53 ;---check for ALT match on LOINC if not yet found and store it---
+54 IF 'RORALT
IF RORDATA("ALT_LOINC")[(";"_RORLOINC_";")
Begin DoDot:2
+55 SET RORDATA("LVAL",RORDATE)=RORVAL
SET RORALT=1
End DoDot:2
QUIT
+56 ;set flags to indicate if APRI/FIB4 scores are ready to be calculated for this patient
+57 IF RORAST
IF RORPLAT
SET RORDATA("CALCAPRI")=1
Begin DoDot:2
+58 ;done if APRI is the only score requested
IF RORDATA("IDLST")=3
SET RORDONE=1
+59 IF RORALT
SET RORDATA("CALCFIB4")=1
SET RORDONE=1
End DoDot:2
End DoDot:1
+60 ;
+61 ;if patient doesn't have data for either score, then they shouldn't show up on report
+62 IF '$GET(RORDATA("CALCAPRI"))
IF '$GET(RORDATA("CALCFIB4"))
QUIT -1
+63 ;--- put test result and test date into RORDATA(<test_name>)=result^date
+64 NEW DATE
+65 ;AST
SET DATE=$ORDER(RORDATA("SVAL",0))
+66 SET RORDATA("AST")=$SELECT($GET(DATE)="":U,1:$GET(RORDATA("SVAL",DATE))_U_$GET(DATE))
+67 ;Platelet
SET DATE=$ORDER(RORDATA("PVAL",0))
+68 SET RORDATA("PLAT")=$SELECT($GET(DATE)="":U,1:$GET(RORDATA("PVAL",DATE))_U_$GET(DATE))
+69 ;ALT
SET DATE=$ORDER(RORDATA("LVAL",0))
+70 SET RORDATA("ALT")=$SELECT($GET(DATE)="":U,1:$GET(RORDATA("LVAL",DATE))_U_$GET(DATE))
+71 ;--- get just the test result values from array
+72 NEW TEST,AST,PLAT,ALT
+73 FOR TEST="AST","PLAT","ALT"
SET @TEST=$PIECE($GET(RORDATA(TEST)),U,1)
+74 ;--- calculate APRI/FIB4 scores
+75 NEW TMP1,TMP2
+76 ;RORDATA("SCORE",3) will hold the calculated APRI score
+77 ;RORDATA("SCORE",4) will hold the calculated FIB4 score
+78 ;init calculated scores to null
SET (RORDATA("SCORE",3),RORDATA("SCORE",4))=""
+79 SET RC=1
+80 IF $GET(AST)
IF $GET(PLAT)
Begin DoDot:1
+81 ;calculate APRI score: [AST/ULNAST/PLAT] * 100
IF RORDATA("IDLST")[3
Begin DoDot:2
+82 SET TMP1=(AST/RORDATA("ULNAST")/PLAT)*100
+83 ;round to 2 decimal points
SET RORDATA("SCORE",3)=$JUSTIFY($GET(TMP1),0,2)
End DoDot:2
+84 ;calculate FIB4 score: (AGE*AST)/[(PLAT*ALT) to 1/2 power]
IF $GET(ALT)
IF RORDATA("IDLST")[4
Begin DoDot:2
+85 ;get patient age
NEW AGE
SET AGE=$$AGE(DFN,RORDATA("DATE"))
+86 ;quit if age can't be calculated
IF '$GET(AGE)
SET RC=-1
QUIT
+87 ;
+88 ; ROR*1.5*16 remedy ticket 512757 changed next two lines
+89 ;S TMP2=(AGE*AST)/$$PWR^XLFMTH((PLAT*ALT),.5)
+90 ;S RORDATA("SCORE",4)=$J($G(TMP2),0,0) ;round to whole number
+91 SET TMP2=(AGE*AST)/(PLAT*($$PWR^XLFMTH((ALT),.5)))
+92 ;round to 2 decimal places
SET RORDATA("SCORE",4)=$JUSTIFY($GET(TMP2),0,2)
+93 ;
End DoDot:2
End DoDot:1
+94 QUIT RC
+95 ;
+96 ;************************************************************************
+97 ;CALCULATE PATIENT AGE - EXTRINSIC FUNCTION
+98 ;
+99 ;INPUT
+100 ; DFN Patient DFN in PATIENT file (#2)
+101 ; DATE user-selected date for report calculations
+102 ;
+103 ;OUTPUT
+104 ; Patient age is returned
+105 ;************************************************************************
AGE(DFN,DATE) ;
+1 ;--- get patient dob and dod using DEM^VADPT
+2 NEW RORDEM,RORDOB,RORDOD,RORAGE,VAROOT
+3 SET VAROOT="RORDEM"
DO DEM^VADPT
+4 ;date of birth
SET RORDOB=$PIECE($GET(RORDEM(3)),U,1)
+5 ;age as of today (DT)
SET RORAGE=$PIECE($GET(RORDEM(4)),U,1)
+6 ;date of death
SET RORDOD=$PIECE($GET(RORDEM(6)),U,1)
+7 ;if 'most recent' date, return age in API results
IF DATE=DT
QUIT $GET(RORAGE)
+8 ;compare DOD and user-selected 'as of' DATE
+9 ;use DOD if earlier than DATE
IF $GET(RORDOD)
IF $GET(RORDOD)<DATE
SET DATE=RORDOD\1
+10 ;calculate age
SET RORAGE=DATE-RORDOB
+11 SET RORAGE=$SELECT($LENGTH(RORAGE)=6:$EXTRACT($GET(RORAGE),1,2),1:$EXTRACT($GET(RORAGE),1,3))
+12 QUIT $GET(RORAGE)
