RORX019A.m

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 ---RORX019A   19318     printed  Mar 13, 2025@20:49:31                                                                                                                                                                                                   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))=""