RORP014 ;BP/ACS CCR POST-INIT PATCH 14 ;12/31/10
;;1.5;CLINICAL CASE REGISTRIES;**14**;Feb 17, 2006;Build 24
;
; This routine uses the following IAs:
;
; #3556 GCPR^LA7QRY (controlled)
;
;******************************************************************************
;Change name of MELD report to "Liver Score by Range" in the ROR REPORT
;PARAMETERS file (#799.34)
;******************************************************************************
;find IEN of existing "MELD Score by Range" entry
N IEN,IENS,RORFDA,RORMSG S IEN=$O(^ROR(799.34,"B","MELD Score by Range",0))
I $G(IEN) S IENS=IEN_"," D
. S RORFDA(799.34,IENS,.01)="Liver Score by Range"
. K RORMSG D FILE^DIE(,"RORFDA","RORMSG")
K RORFDA,RORMSG
;
;******************************************************************************
;Add new entries to the ROR XML ITEM file (#799.31). These entries are needed
;for the new APRI/FIB4 calculations in the Liver Score by Range report.
;******************************************************************************
N RORXML,RORTAG,RORFDA,RORERR
;--- add codes
F I=1:1:5 S RORTAG="XML"_I D
. S RORXML=$T(@RORTAG)
. S RORXML=$P(RORXML,";;",2)
. ;don't add if it's already in the global
. Q:$D(^ROR(799.31,"B",RORXML))
. S RORFDA(799.31,"+1,",.01)=RORXML
. D UPDATE^DIE(,"RORFDA",,"RORERR")
K RORFDA,RORERR
;
;******************************************************************************
;Add "Purchased Care" to the ROR DATA AREA file (#799.33)
;******************************************************************************
;remove old entries if they exist
N DA,DIK
S DIK="^ROR(799.33,",DA=$O(^ROR(799.33,"B","Purchased Care",0)) I $G(DA)>0 D ^DIK
N RORDA F RORDA="Purchased Care" D
. Q:$D(^ROR(799.33,"B",RORDA)) ;don't add if already in global
. N RORFDA,RORERR,RORIEN
. S RORFDA(799.33,"+1,",.01)=RORDA
. S RORIEN(1)=20 ;IEN=20 for Purchased Care
. D UPDATE^DIE(,"RORFDA","RORIEN","RORERR")
. K RORFDA,RORERR,RORIEN
;
;******************************************************************************
;Update the PURCHASED CARE backpull entry in the ROR HISTORICAL DATA
;EXTRACT file with END DATE and ACTIVATION DATE = current date.
;******************************************************************************
N RORIEN S RORIEN=$O(^RORDATA(799.6,"B","PURCHASED CARE",0))
I $G(RORIEN) D
. N DIE,DA,DR
. S DIE="^RORDATA(799.6,",DA=RORIEN,DR=".04///"_DT_";.07///"_DT D ^DIE
;
;******************************************************************************
;Add new entries to the ROR LIST ITEM file (#799.1) for the 2 new Liver reports
;in the MELD group
;******************************************************************************
N RORDATA,RORTAG,RORFDA,I,TEXT,TYPE,REGISTRY,CODE
F I=1:1:4 S RORTAG="LI"_I D
. S RORDATA=$P($T(@RORTAG),";;",2)
. S TEXT=$P(RORDATA,"^",1) ;TEXT to add
. S TYPE=$P(RORDATA,"^",2) ;TYPE to add
. S REGISTRY=$P(RORDATA,"^",3) ;REGISTRY to add
. S CODE=$P(RORDATA,"^",4) ;CODE to add
. ;don't add if it's already in the global
. Q:$D(^ROR(799.1,"KEY",TYPE,REGISTRY,CODE))
. S RORFDA(799.1,"+1,",.01)=TEXT
. S RORFDA(799.1,"+1,",.02)=TYPE
. S RORFDA(799.1,"+1,",.03)=REGISTRY
. S RORFDA(799.1,"+1,",.04)=CODE
. D UPDATE^DIE(,"RORFDA",,"RORERR")
K RORFDA,RORERR
;
;******************************************************************************
;Add new LOINC codes to the VA HEPC lab search criteria in the
;ROR LAB SEARCH file #798.9. Don't add them if they already exist. Do not
;add the 'dash' or the number following it.
;******************************************************************************
N I,HEPCIEN,RORDATA,RORLOINC,RORTAG K RORMSG
N HEPCNT S HEPCNT=0
S HEPCIEN=$O(^ROR(798.9,"B","VA HEPC",0)) ;HEPC top level IEN
;--- add LOINC codes to the VA HEPC search criteria
F I=1:1:9 S RORTAG="HEP"_I D
. S RORLOINC=$P($P($T(@RORTAG),";;",2),"-",1)
. ;don't add if it's already in the global
. Q:($D(^ROR(798.9,HEPCIEN,1,"B",RORLOINC)))
. S RORDATA(1,798.92,"+2,"_HEPCIEN_",",.01)=$G(RORLOINC)
. S RORDATA(1,798.92,"+2,"_HEPCIEN_",",1)=0 ;indicator: ingore
. D UPDATE^DIE("","RORDATA(1)",,"RORMSG")
. S HEPCNT=HEPCNT+1
K RORDATA,RORMSG
;
;******************************************************************************
;Check each pending patient in the HEPC registry to see if they have ever had a positve
;HCV LOINC. If they have, then confirm them into the registry immediately.
;******************************************************************************
N IEN,DFN,PTID,START,END,RORFS,RORCS,H7CH,HEPCREG
S H7CH="|^~\&",RORFS="|",RORCS="^"
S HEPCREG=$O(^ROR(798.1,"B","VA HEPC",0)) Q:'HEPCREG ;HEPC Registry IEN
S IEN=0 F S IEN=$O(^RORDATA(798,IEN)) Q:'IEN D
. Q:$P($G(^RORDATA(798,IEN,0)),U,2)'=HEPCREG ;quit if not HEPC registry
. Q:$P($G(^RORDATA(798,IEN,0)),U,5)'=4 ;quit if not pending patient
. S DFN=$P($G(^RORDATA(798,IEN,0)),U,1) ;get patient DFN
. Q:'DFN
. S PTID=$$PTID^RORUTL02(DFN) ;get patient ID for call to GCPR^LA7QRY
. Q:+PTID'>0
. S START="2000101^CD" ;start date 1/1/1900
. S END=DT_".235959^CD"
. N RORLC,RORMSG,RORHCV
. S RORLC="CH,MI" ;search Chem and Micro sub-files in #63
. S RORLC(12)="11011-4^LN"
. S RORLC(13)="29609-5^LN"
. S RORLC(14)="34703-9^LN"
. S RORLC(15)="34704-7^LN"
. S RORLC(16)="10676-5^LN"
. S RORLC(17)="20416-4^LN"
. S RORLC(18)="20571-6^LN"
. S RORLC(19)="49758-6^LN"
. S RORLC(20)="50023-1^LN"
. S RORHCV=$NA(^TMP("RORHCV",$J)) K @RORHCV ;output to hold the HCV test results
. N RC S RC=$$GCPR^LA7QRY(PTID,START,END,.RORLC,"*",.RORMSG,RORHCV,H7CH)
. I $D(@RORHCV)'>1 Q
. N RORNODE,RORSEG,RORVAL,RORDONE,SEGTYPE
. S RORNODE=0,RORDONE=0
. ;loop through output and see if the test result value in OBX contains ">" in first character
. F S RORNODE=$O(^TMP("RORHCV",$J,RORNODE)) Q:(($G(RORNODE)="")!(RORDONE)) D
.. S RORSEG=$G(^TMP("RORHCV",$J,RORNODE)) ;entire HL7 segment
.. S SEGTYPE=$P(RORSEG,RORFS,1) ;segment type (PID,OBR,OBX,etc.)
.. Q:SEGTYPE'="OBX" ;we want OBX segments only
.. S RORVAL=$P(RORSEG,RORFS,6) ;test result value
.. S RORVAL=$TR(RORVAL,"""","") ;get rid of double quotes around values
.. N IENS I $E($G(RORVAL),1,1)=">" S IENS=IEN_"," D ;if positive test result
... S RORFDA(798,IENS,3)=0 ;set status = confirmed
... S RORFDA(798,IENS,12)="" ;set pending comment field to null
... K RORMSG D FILE^DIE(,"RORFDA","RORMSG") ;update
... S RORDONE=1
;
D CLEAN^DILF
Q
;******************************************************************************
;New HEPC LOINC codes
;******************************************************************************
HEP1 ;;11011-4
HEP2 ;;29609-5
HEP3 ;;34703-9
HEP4 ;;34704-7
HEP5 ;;10676-5
HEP6 ;;20416-4
HEP7 ;;20571-6
HEP8 ;;49758-6
HEP9 ;;50023-1
;
;
;******************************************************************************
;new XML tags to be added to ROR XML ITEM file (#799.31)
;******************************************************************************
XML1 ;;LOINC_CODES
XML2 ;;FIRSTDIAG
XML3 ;;APRI
XML4 ;;FIB4
XML5 ;;ULNAST
;
;******************************************************************************
; Data to be added to ROR LIST ITEM file (#799.1)
; TEXT^TYPE^REGIEN^CODE
;******************************************************************************
LI1 ;;APRI^6^1^3
LI2 ;;FIB-4^6^1^4
LI3 ;;APRI^6^2^3
LI4 ;;FIB-4^6^2^4
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORP014 7545 printed Apr 09, 2024@20:49:50 Page 2
RORP014 ;BP/ACS CCR POST-INIT PATCH 14 ;12/31/10
+1 ;;1.5;CLINICAL CASE REGISTRIES;**14**;Feb 17, 2006;Build 24
+2 ;
+3 ; This routine uses the following IAs:
+4 ;
+5 ; #3556 GCPR^LA7QRY (controlled)
+6 ;
+7 ;******************************************************************************
+8 ;Change name of MELD report to "Liver Score by Range" in the ROR REPORT
+9 ;PARAMETERS file (#799.34)
+10 ;******************************************************************************
+11 ;find IEN of existing "MELD Score by Range" entry
+12 NEW IEN,IENS,RORFDA,RORMSG
SET IEN=$ORDER(^ROR(799.34,"B","MELD Score by Range",0))
+13 IF $GET(IEN)
SET IENS=IEN_","
Begin DoDot:1
+14 SET RORFDA(799.34,IENS,.01)="Liver Score by Range"
+15 KILL RORMSG
DO FILE^DIE(,"RORFDA","RORMSG")
End DoDot:1
+16 KILL RORFDA,RORMSG
+17 ;
+18 ;******************************************************************************
+19 ;Add new entries to the ROR XML ITEM file (#799.31). These entries are needed
+20 ;for the new APRI/FIB4 calculations in the Liver Score by Range report.
+21 ;******************************************************************************
+22 NEW RORXML,RORTAG,RORFDA,RORERR
+23 ;--- add codes
+24 FOR I=1:1:5
SET RORTAG="XML"_I
Begin DoDot:1
+25 SET RORXML=$TEXT(@RORTAG)
+26 SET RORXML=$PIECE(RORXML,";;",2)
+27 ;don't add if it's already in the global
+28 if $DATA(^ROR(799.31,"B",RORXML))
QUIT
+29 SET RORFDA(799.31,"+1,",.01)=RORXML
+30 DO UPDATE^DIE(,"RORFDA",,"RORERR")
End DoDot:1
+31 KILL RORFDA,RORERR
+32 ;
+33 ;******************************************************************************
+34 ;Add "Purchased Care" to the ROR DATA AREA file (#799.33)
+35 ;******************************************************************************
+36 ;remove old entries if they exist
+37 NEW DA,DIK
+38 SET DIK="^ROR(799.33,"
SET DA=$ORDER(^ROR(799.33,"B","Purchased Care",0))
IF $GET(DA)>0
DO ^DIK
+39 NEW RORDA
FOR RORDA="Purchased Care"
Begin DoDot:1
+40 ;don't add if already in global
if $DATA(^ROR(799.33,"B",RORDA))
QUIT
+41 NEW RORFDA,RORERR,RORIEN
+42 SET RORFDA(799.33,"+1,",.01)=RORDA
+43 ;IEN=20 for Purchased Care
SET RORIEN(1)=20
+44 DO UPDATE^DIE(,"RORFDA","RORIEN","RORERR")
+45 KILL RORFDA,RORERR,RORIEN
End DoDot:1
+46 ;
+47 ;******************************************************************************
+48 ;Update the PURCHASED CARE backpull entry in the ROR HISTORICAL DATA
+49 ;EXTRACT file with END DATE and ACTIVATION DATE = current date.
+50 ;******************************************************************************
+51 NEW RORIEN
SET RORIEN=$ORDER(^RORDATA(799.6,"B","PURCHASED CARE",0))
+52 IF $GET(RORIEN)
Begin DoDot:1
+53 NEW DIE,DA,DR
+54 SET DIE="^RORDATA(799.6,"
SET DA=RORIEN
SET DR=".04///"_DT_";.07///"_DT
DO ^DIE
End DoDot:1
+55 ;
+56 ;******************************************************************************
+57 ;Add new entries to the ROR LIST ITEM file (#799.1) for the 2 new Liver reports
+58 ;in the MELD group
+59 ;******************************************************************************
+60 NEW RORDATA,RORTAG,RORFDA,I,TEXT,TYPE,REGISTRY,CODE
+61 FOR I=1:1:4
SET RORTAG="LI"_I
Begin DoDot:1
+62 SET RORDATA=$PIECE($TEXT(@RORTAG),";;",2)
+63 ;TEXT to add
SET TEXT=$PIECE(RORDATA,"^",1)
+64 ;TYPE to add
SET TYPE=$PIECE(RORDATA,"^",2)
+65 ;REGISTRY to add
SET REGISTRY=$PIECE(RORDATA,"^",3)
+66 ;CODE to add
SET CODE=$PIECE(RORDATA,"^",4)
+67 ;don't add if it's already in the global
+68 if $DATA(^ROR(799.1,"KEY",TYPE,REGISTRY,CODE))
QUIT
+69 SET RORFDA(799.1,"+1,",.01)=TEXT
+70 SET RORFDA(799.1,"+1,",.02)=TYPE
+71 SET RORFDA(799.1,"+1,",.03)=REGISTRY
+72 SET RORFDA(799.1,"+1,",.04)=CODE
+73 DO UPDATE^DIE(,"RORFDA",,"RORERR")
End DoDot:1
+74 KILL RORFDA,RORERR
+75 ;
+76 ;******************************************************************************
+77 ;Add new LOINC codes to the VA HEPC lab search criteria in the
+78 ;ROR LAB SEARCH file #798.9. Don't add them if they already exist. Do not
+79 ;add the 'dash' or the number following it.
+80 ;******************************************************************************
+81 NEW I,HEPCIEN,RORDATA,RORLOINC,RORTAG
KILL RORMSG
+82 NEW HEPCNT
SET HEPCNT=0
+83 ;HEPC top level IEN
SET HEPCIEN=$ORDER(^ROR(798.9,"B","VA HEPC",0))
+84 ;--- add LOINC codes to the VA HEPC search criteria
+85 FOR I=1:1:9
SET RORTAG="HEP"_I
Begin DoDot:1
+86 SET RORLOINC=$PIECE($PIECE($TEXT(@RORTAG),";;",2),"-",1)
+87 ;don't add if it's already in the global
+88 if ($DATA(^ROR(798.9,HEPCIEN,1,"B",RORLOINC)))
QUIT
+89 SET RORDATA(1,798.92,"+2,"_HEPCIEN_",",.01)=$GET(RORLOINC)
+90 ;indicator: ingore
SET RORDATA(1,798.92,"+2,"_HEPCIEN_",",1)=0
+91 DO UPDATE^DIE("","RORDATA(1)",,"RORMSG")
+92 SET HEPCNT=HEPCNT+1
End DoDot:1
+93 KILL RORDATA,RORMSG
+94 ;
+95 ;******************************************************************************
+96 ;Check each pending patient in the HEPC registry to see if they have ever had a positve
+97 ;HCV LOINC. If they have, then confirm them into the registry immediately.
+98 ;******************************************************************************
+99 NEW IEN,DFN,PTID,START,END,RORFS,RORCS,H7CH,HEPCREG
+100 SET H7CH="|^~\&"
SET RORFS="|"
SET RORCS="^"
+101 ;HEPC Registry IEN
SET HEPCREG=$ORDER(^ROR(798.1,"B","VA HEPC",0))
if 'HEPCREG
QUIT
+102 SET IEN=0
FOR
SET IEN=$ORDER(^RORDATA(798,IEN))
if 'IEN
QUIT
Begin DoDot:1
+103 ;quit if not HEPC registry
if $PIECE($GET(^RORDATA(798,IEN,0)),U,2)'=HEPCREG
QUIT
+104 ;quit if not pending patient
if $PIECE($GET(^RORDATA(798,IEN,0)),U,5)'=4
QUIT
+105 ;get patient DFN
SET DFN=$PIECE($GET(^RORDATA(798,IEN,0)),U,1)
+106 if 'DFN
QUIT
+107 ;get patient ID for call to GCPR^LA7QRY
SET PTID=$$PTID^RORUTL02(DFN)
+108 if +PTID'>0
QUIT
+109 ;start date 1/1/1900
SET START="2000101^CD"
+110 SET END=DT_".235959^CD"
+111 NEW RORLC,RORMSG,RORHCV
+112 ;search Chem and Micro sub-files in #63
SET RORLC="CH,MI"
+113 SET RORLC(12)="11011-4^LN"
+114 SET RORLC(13)="29609-5^LN"
+115 SET RORLC(14)="34703-9^LN"
+116 SET RORLC(15)="34704-7^LN"
+117 SET RORLC(16)="10676-5^LN"
+118 SET RORLC(17)="20416-4^LN"
+119 SET RORLC(18)="20571-6^LN"
+120 SET RORLC(19)="49758-6^LN"
+121 SET RORLC(20)="50023-1^LN"
+122 ;output to hold the HCV test results
SET RORHCV=$NAME(^TMP("RORHCV",$JOB))
KILL @RORHCV
+123 NEW RC
SET RC=$$GCPR^LA7QRY(PTID,START,END,.RORLC,"*",.RORMSG,RORHCV,H7CH)
+124 IF $DATA(@RORHCV)'>1
QUIT
+125 NEW RORNODE,RORSEG,RORVAL,RORDONE,SEGTYPE
+126 SET RORNODE=0
SET RORDONE=0
+127 ;loop through output and see if the test result value in OBX contains ">" in first character
+128 FOR
SET RORNODE=$ORDER(^TMP("RORHCV",$JOB,RORNODE))
if (($GET(RORNODE)="")!(RORDONE))
QUIT
Begin DoDot:2
+129 ;entire HL7 segment
SET RORSEG=$GET(^TMP("RORHCV",$JOB,RORNODE))
+130 ;segment type (PID,OBR,OBX,etc.)
SET SEGTYPE=$PIECE(RORSEG,RORFS,1)
+131 ;we want OBX segments only
if SEGTYPE'="OBX"
QUIT
+132 ;test result value
SET RORVAL=$PIECE(RORSEG,RORFS,6)
+133 ;get rid of double quotes around values
SET RORVAL=$TRANSLATE(RORVAL,"""","")
+134 ;if positive test result
NEW IENS
IF $EXTRACT($GET(RORVAL),1,1)=">"
SET IENS=IEN_","
Begin DoDot:3
+135 ;set status = confirmed
SET RORFDA(798,IENS,3)=0
+136 ;set pending comment field to null
SET RORFDA(798,IENS,12)=""
+137 ;update
KILL RORMSG
DO FILE^DIE(,"RORFDA","RORMSG")
+138 SET RORDONE=1
End DoDot:3
End DoDot:2
End DoDot:1
+139 ;
+140 DO CLEAN^DILF
+141 QUIT
+142 ;******************************************************************************
+143 ;New HEPC LOINC codes
+144 ;******************************************************************************
HEP1 ;;11011-4
HEP2 ;;29609-5
HEP3 ;;34703-9
HEP4 ;;34704-7
HEP5 ;;10676-5
HEP6 ;;20416-4
HEP7 ;;20571-6
HEP8 ;;49758-6
HEP9 ;;50023-1
+1 ;
+2 ;
+3 ;******************************************************************************
+4 ;new XML tags to be added to ROR XML ITEM file (#799.31)
+5 ;******************************************************************************
XML1 ;;LOINC_CODES
XML2 ;;FIRSTDIAG
XML3 ;;APRI
XML4 ;;FIB4
XML5 ;;ULNAST
+1 ;
+2 ;******************************************************************************
+3 ; Data to be added to ROR LIST ITEM file (#799.1)
+4 ; TEXT^TYPE^REGIEN^CODE
+5 ;******************************************************************************
LI1 ;;APRI^6^1^3
LI2 ;;FIB-4^6^1^4
LI3 ;;APRI^6^2^3
LI4 ;;FIB-4^6^2^4
