- ORQQLR1 ; slc/CLA - Extrinsic functions and procedures which return patient lab results ; 7/10/17 5:45pm
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**6,51,74,143,414**;Dec 17, 1997;Build 8
- ;Per VA Directive 6402, this routine should not be modified.
- ;
- ;DBIA reference section
- ;2387 ^LAB(60
- ;2503 RR^LR7OR1
- ;10103 FMTE^XLFDT
- ;
- OETOLAB(ORNUM) ;extrinsic funct to get a lab order number from an oe/rr number
- N LRNUM
- S LRNUM=$G(^OR(100,ORNUM,4))
- Q +LRNUM
- ;
- PRINTNAM(LRIEN) ;extrinsic function to return the print name for an entry in the Lab file [#60]
- Q:+$G(LRIEN)<1 ""
- N NODE,NAME
- S NODE=$G(^LAB(60,LRIEN,.1))
- Q:'$L(NODE) ""
- S NAME=$P(NODE,U)
- Q NAME
- ;
- OIRES(PT,OILR,SPEC) ;extrinsic function to return pt's most recent lab results for a lab orderable item in the format:
- ; test id^abbrev test name^result^units^flag^collection d/t
- N RSLT,ORZ
- S ORZ=""
- S RSLT=$$GETDATA^OCXCACHE(.ORZ,"$$OIRESC^ORQQLR1("_PT_","_OILR_","_SPEC_")",PT,)
- Q ORZ
- ;
- OIRESC(PT,OILR,SPEC) ;extrinsic function to return pt's most recent lab results for a lab orderable item in the format:
- ; test id^abbrev test name^result^units^flag^collection d/t
- N ORY,ORX,ORN,ORLR,SUB,INVDT,SEQ,ORDG,RESULT
- S SUB="",INVDT=0,SEQ=0,ORY=""
- ;check to make sure the OI is in DG lab
- Q:'$L($G(PT))!('$L($G(OILR))) ORY
- Q:'$L($G(^ORD(101.43,OILR,0))) ORY
- I +$G(SPEC)<1 S SPEC=""
- S ORDG=$$DG^ORQOR1("LAB")
- Q:'$L($G(ORDG)) ORY
- Q:$P(^ORD(101.43,OILR,0),U,5)'=ORDG ORY ;quit if display grp is not lab
- ;get lab test ien
- S ORX=$P(^ORD(101.43,OILR,0),U,2)
- S ORLR=$S(ORX["~":$P(ORX,"~"),1:$P(ORX,";"))
- ;get lab results
- K ^TMP("LRRR",$J)
- D RR^LR7OR1(PT,"","","","",ORLR,"L",1,SPEC) I $D(^TMP("LRRR",$J,PT)) D
- .S SUB=$O(^TMP("LRRR",$J,PT,SUB)) Q:SUB=""
- .S INVDT=$O(^TMP("LRRR",$J,PT,SUB,INVDT)) Q:'INVDT
- .S SEQ=$O(^TMP("LRRR",$J,PT,SUB,INVDT,SEQ)) Q:'SEQ D
- ..S RESULT=^(SEQ),ORY=$P(RESULT,U)_U_$P(RESULT,U,15)_U_$P(RESULT,U,2)_U_$P(RESULT,U,4)_U_$P(RESULT,U,3)_U_$P(RESULT,U,5)_U_(9999999-INVDT)
- K ^TMP("LRRR",$J)
- Q ORY
- ;
- NATL(PT,NID,SPEC) ;extrinsic function to return pt's most recent lab results for a lab national id in the format:
- ; test id^abbrev test name^result^units^flag^collection d/t
- N RSLT,ORZ
- S ORZ=""
- S RSLT=$$GETDATA^OCXCACHE(.ORZ,"$$NATLC^ORQQLR1("_PT_","_NID_","_SPEC_")",PT,)
- Q ORZ
- ;
- NATLC(PT,NID,SPEC) ;extrinsic function to return pt's most recent lab results for a lab national id in the format:
- ; test id^abbrev test name^result^units^flag^collection d/t
- N ORY,ORX,ORN,ORLR,SUB,INVDT,SEQ,ORDG
- S SUB="",INVDT=0,SEQ=0,ORY=""
- I +$G(SPEC)<1 S SPEC=""
- ;get lab results
- K ^TMP("LRRR",$J)
- D RR^LR7OR1(PT,"","","","",NID,"N",1,SPEC) I $D(^TMP("LRRR",$J,PT)) D
- .S SUB=$O(^TMP("LRRR",$J,PT,SUB)) Q:SUB=""
- .S INVDT=$O(^TMP("LRRR",$J,PT,SUB,INVDT)) Q:'INVDT
- .S SEQ=$O(^TMP("LRRR",$J,PT,SUB,INVDT,SEQ)) Q:'SEQ D
- ..S RESULT=^(SEQ),ORY=$P(RESULT,U)_U_$P(RESULT,U,15)_U_$P(RESULT,U,2)_U_$P(RESULT,U,4)_U_$P(RESULT,U,3)_U_$P(RESULT,U,5)_U_(9999999-INVDT)
- K ^TMP("LRRR",$J)
- Q ORY
- ;
- LOCL(PT,LID,SPEC) ;extrinsic function to return pt's most recent lab results for a lab local id in the format:
- ; test id^abbrev test name^result^units^flag^collection d/t
- N RSLT,ORZ
- S ORZ=""
- S RSLT=$$GETDATA^OCXCACHE(.ORZ,"$$LOCLC^ORQQLR1("_PT_","_LID_","_SPEC_")",PT,)
- Q ORZ
- ;
- LOCLC(PT,LID,SPEC) ;extrinsic function to return pt's most recent lab results for a lab local id in the format:
- ; test id^abbrev test name^result^units^flag^collection d/t
- N ORY,ORX,SUB,INVDT,SEQ,RESULT
- S SUB="",INVDT=0,SEQ=0,ORY=""
- ;get lab results
- I +$G(SPEC)<1 S SPEC=""
- K ^TMP("LRRR",$J)
- D RR^LR7OR1(PT,"","","","",LID,"L",,SPEC) I $D(^TMP("LRRR",$J,PT)) D
- .S SUB=$O(^TMP("LRRR",$J,PT,SUB)) Q:SUB=""
- .S INVDT="" F S INVDT=$O(^TMP("LRRR",$J,PT,SUB,INVDT)) Q:'INVDT D
- ..S SEQ="" F S SEQ=$O(^TMP("LRRR",$J,PT,SUB,INVDT,SEQ)) Q:'SEQ!(+$G(RESULT)>0) D
- ...S ORX=^(SEQ)
- ...I $P(ORX,U,2)'="canc" D ;if results were not cancelled in lab:
- ....S RESULT=$P(ORX,U,2)
- ....S ORY=$P(ORX,U)_U_$P(ORX,U,15)_U_$P(ORX,U,2)_U_$P(ORX,U,4)
- ....S ORY=ORY_U_$P(ORX,U,3)_U_$P(ORX,U,5)_U_(9999999-INVDT)
- K ^TMP("LRRR",$J)
- Q ORY
- ;
- LOCLFORM(PT,LID,SPEC) ;extrinsic function to return formatted most recnt lab
- ;rtn format: 1 (if results)^<print name> <value> <units> <high/low flag>
- ; (<reference range>) <collection date/time>
- N FRCNT,X
- S X=$$LOCL(PT,LID,SPEC)
- Q:'$L(X) "^No results found."
- S FRCNT="1^"_$P(X,U,2)_" "_$P(X,U,3)_" "_$P(X,U,4)_" "_$P(X,U,5)
- S FRCNT=FRCNT_" ("_$P(X,U,6)_") "_$$FMTE^XLFDT($P(X,U,7),"2P")
- Q FRCNT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORQQLR1 4631 printed Jan 18, 2025@03:34:47 Page 2
- ORQQLR1 ; slc/CLA - Extrinsic functions and procedures which return patient lab results ; 7/10/17 5:45pm
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**6,51,74,143,414**;Dec 17, 1997;Build 8
- +2 ;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ;DBIA reference section
- +5 ;2387 ^LAB(60
- +6 ;2503 RR^LR7OR1
- +7 ;10103 FMTE^XLFDT
- +8 ;
- OETOLAB(ORNUM) ;extrinsic funct to get a lab order number from an oe/rr number
- +1 NEW LRNUM
- +2 SET LRNUM=$GET(^OR(100,ORNUM,4))
- +3 QUIT +LRNUM
- +4 ;
- PRINTNAM(LRIEN) ;extrinsic function to return the print name for an entry in the Lab file [#60]
- +1 if +$GET(LRIEN)<1
- QUIT ""
- +2 NEW NODE,NAME
- +3 SET NODE=$GET(^LAB(60,LRIEN,.1))
- +4 if '$LENGTH(NODE)
- QUIT ""
- +5 SET NAME=$PIECE(NODE,U)
- +6 QUIT NAME
- +7 ;
- OIRES(PT,OILR,SPEC) ;extrinsic function to return pt's most recent lab results for a lab orderable item in the format:
- +1 ; test id^abbrev test name^result^units^flag^collection d/t
- +2 NEW RSLT,ORZ
- +3 SET ORZ=""
- +4 SET RSLT=$$GETDATA^OCXCACHE(.ORZ,"$$OIRESC^ORQQLR1("_PT_","_OILR_","_SPEC_")",PT,)
- +5 QUIT ORZ
- +6 ;
- OIRESC(PT,OILR,SPEC) ;extrinsic function to return pt's most recent lab results for a lab orderable item in the format:
- +1 ; test id^abbrev test name^result^units^flag^collection d/t
- +2 NEW ORY,ORX,ORN,ORLR,SUB,INVDT,SEQ,ORDG,RESULT
- +3 SET SUB=""
- SET INVDT=0
- SET SEQ=0
- SET ORY=""
- +4 ;check to make sure the OI is in DG lab
- +5 if '$LENGTH($GET(PT))!('$LENGTH($GET(OILR)))
- QUIT ORY
- +6 if '$LENGTH($GET(^ORD(101.43,OILR,0)))
- QUIT ORY
- +7 IF +$GET(SPEC)<1
- SET SPEC=""
- +8 SET ORDG=$$DG^ORQOR1("LAB")
- +9 if '$LENGTH($GET(ORDG))
- QUIT ORY
- +10 ;quit if display grp is not lab
- if $PIECE(^ORD(101.43,OILR,0),U,5)'=ORDG
- QUIT ORY
- +11 ;get lab test ien
- +12 SET ORX=$PIECE(^ORD(101.43,OILR,0),U,2)
- +13 SET ORLR=$SELECT(ORX["~":$PIECE(ORX,"~"),1:$PIECE(ORX,";"))
- +14 ;get lab results
- +15 KILL ^TMP("LRRR",$JOB)
- +16 DO RR^LR7OR1(PT,"","","","",ORLR,"L",1,SPEC)
- IF $DATA(^TMP("LRRR",$JOB,PT))
- Begin DoDot:1
- +17 SET SUB=$ORDER(^TMP("LRRR",$JOB,PT,SUB))
- if SUB=""
- QUIT
- +18 SET INVDT=$ORDER(^TMP("LRRR",$JOB,PT,SUB,INVDT))
- if 'INVDT
- QUIT
- +19 SET SEQ=$ORDER(^TMP("LRRR",$JOB,PT,SUB,INVDT,SEQ))
- if 'SEQ
- QUIT
- Begin DoDot:2
- +20 SET RESULT=^(SEQ)
- SET ORY=$PIECE(RESULT,U)_U_$PIECE(RESULT,U,15)_U_$PIECE(RESULT,U,2)_U_$PIECE(RESULT,U,4)_U_$PIECE(RESULT,U,3)_U_$PIECE(RESULT,U,5)_U_(9999999-INVDT)
- End DoDot:2
- End DoDot:1
- +21 KILL ^TMP("LRRR",$JOB)
- +22 QUIT ORY
- +23 ;
- NATL(PT,NID,SPEC) ;extrinsic function to return pt's most recent lab results for a lab national id in the format:
- +1 ; test id^abbrev test name^result^units^flag^collection d/t
- +2 NEW RSLT,ORZ
- +3 SET ORZ=""
- +4 SET RSLT=$$GETDATA^OCXCACHE(.ORZ,"$$NATLC^ORQQLR1("_PT_","_NID_","_SPEC_")",PT,)
- +5 QUIT ORZ
- +6 ;
- NATLC(PT,NID,SPEC) ;extrinsic function to return pt's most recent lab results for a lab national id in the format:
- +1 ; test id^abbrev test name^result^units^flag^collection d/t
- +2 NEW ORY,ORX,ORN,ORLR,SUB,INVDT,SEQ,ORDG
- +3 SET SUB=""
- SET INVDT=0
- SET SEQ=0
- SET ORY=""
- +4 IF +$GET(SPEC)<1
- SET SPEC=""
- +5 ;get lab results
- +6 KILL ^TMP("LRRR",$JOB)
- +7 DO RR^LR7OR1(PT,"","","","",NID,"N",1,SPEC)
- IF $DATA(^TMP("LRRR",$JOB,PT))
- Begin DoDot:1
- +8 SET SUB=$ORDER(^TMP("LRRR",$JOB,PT,SUB))
- if SUB=""
- QUIT
- +9 SET INVDT=$ORDER(^TMP("LRRR",$JOB,PT,SUB,INVDT))
- if 'INVDT
- QUIT
- +10 SET SEQ=$ORDER(^TMP("LRRR",$JOB,PT,SUB,INVDT,SEQ))
- if 'SEQ
- QUIT
- Begin DoDot:2
- +11 SET RESULT=^(SEQ)
- SET ORY=$PIECE(RESULT,U)_U_$PIECE(RESULT,U,15)_U_$PIECE(RESULT,U,2)_U_$PIECE(RESULT,U,4)_U_$PIECE(RESULT,U,3)_U_$PIECE(RESULT,U,5)_U_(9999999-INVDT)
- End DoDot:2
- End DoDot:1
- +12 KILL ^TMP("LRRR",$JOB)
- +13 QUIT ORY
- +14 ;
- LOCL(PT,LID,SPEC) ;extrinsic function to return pt's most recent lab results for a lab local id in the format:
- +1 ; test id^abbrev test name^result^units^flag^collection d/t
- +2 NEW RSLT,ORZ
- +3 SET ORZ=""
- +4 SET RSLT=$$GETDATA^OCXCACHE(.ORZ,"$$LOCLC^ORQQLR1("_PT_","_LID_","_SPEC_")",PT,)
- +5 QUIT ORZ
- +6 ;
- LOCLC(PT,LID,SPEC) ;extrinsic function to return pt's most recent lab results for a lab local id in the format:
- +1 ; test id^abbrev test name^result^units^flag^collection d/t
- +2 NEW ORY,ORX,SUB,INVDT,SEQ,RESULT
- +3 SET SUB=""
- SET INVDT=0
- SET SEQ=0
- SET ORY=""
- +4 ;get lab results
- +5 IF +$GET(SPEC)<1
- SET SPEC=""
- +6 KILL ^TMP("LRRR",$JOB)
- +7 DO RR^LR7OR1(PT,"","","","",LID,"L",,SPEC)
- IF $DATA(^TMP("LRRR",$JOB,PT))
- Begin DoDot:1
- +8 SET SUB=$ORDER(^TMP("LRRR",$JOB,PT,SUB))
- if SUB=""
- QUIT
- +9 SET INVDT=""
- FOR
- SET INVDT=$ORDER(^TMP("LRRR",$JOB,PT,SUB,INVDT))
- if 'INVDT
- QUIT
- Begin DoDot:2
- +10 SET SEQ=""
- FOR
- SET SEQ=$ORDER(^TMP("LRRR",$JOB,PT,SUB,INVDT,SEQ))
- if 'SEQ!(+$GET(RESULT)>0)
- QUIT
- Begin DoDot:3
- +11 SET ORX=^(SEQ)
- +12 ;if results were not cancelled in lab:
- IF $PIECE(ORX,U,2)'="canc"
- Begin DoDot:4
- +13 SET RESULT=$PIECE(ORX,U,2)
- +14 SET ORY=$PIECE(ORX,U)_U_$PIECE(ORX,U,15)_U_$PIECE(ORX,U,2)_U_$PIECE(ORX,U,4)
- +15 SET ORY=ORY_U_$PIECE(ORX,U,3)_U_$PIECE(ORX,U,5)_U_(9999999-INVDT)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +16 KILL ^TMP("LRRR",$JOB)
- +17 QUIT ORY
- +18 ;
- LOCLFORM(PT,LID,SPEC) ;extrinsic function to return formatted most recnt lab
- +1 ;rtn format: 1 (if results)^<print name> <value> <units> <high/low flag>
- +2 ; (<reference range>) <collection date/time>
- +3 NEW FRCNT,X
- +4 SET X=$$LOCL(PT,LID,SPEC)
- +5 if '$LENGTH(X)
- QUIT "^No results found."
- +6 SET FRCNT="1^"_$PIECE(X,U,2)_" "_$PIECE(X,U,3)_" "_$PIECE(X,U,4)_" "_$PIECE(X,U,5)
- +7 SET FRCNT=FRCNT_" ("_$PIECE(X,U,6)_") "_$$FMTE^XLFDT($PIECE(X,U,7),"2P")
- +8 QUIT FRCNT