VPSRPC12 ;WOIFO/BT - Patient Demographic - Lab Orders;08/14/14 13:07
;;1.0;VA POINT OF SERVICE (KIOSKS);**4**;Aug 14, 2014;Build 27
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External Reference DBIA#
; ------------------------
; #3366 - AGET^ORWORR (Controlled Subs)
; #3367 - GET4LST^ORWORR (Controlled Subs)
; #6100 - DETAIL^ORWOR (Private)
; #10104 - XLFSTR call (Supported)
QUIT
;
GETLAB(VPSARR,DFN,DTRANGE) ;given DFN, returns the patient lab
; OUTPUT
; VPSARR - passed in by reference; this is the output array to store lab order
; INPUT
; DFN - patient DFN (This value must be validated before calling this procedure)
; DTRANGE - FROMDATE:THROUGHDATE
;
; --- Filter ---------
K ^TMP("ORR",$J)
N DTFROM S DTFROM=$P(DTRANGE,":")
N DTTHRU S DTTHRU=$P(DTRANGE,":",2)
S:DTFROM="" DTFROM=0
S:DTTHRU="" DTTHRU=0
I $P(DTFROM,".")=$P(DTTHRU,"."),$P(DTFROM,".",2)>$P(DTTHRU,".",2),$P(DTTHRU,".",2)="" S $P(DTTHRU,".",2)=2359
;
; --- Compile ---------
N GROUP S GROUP=$O(^ORD(100.98,"B","LABORATORY",0)) ;lab orders
N ORSLT D AGET^ORWORR(.ORSLT,DFN,,GROUP,DTFROM,DTTHRU)
N LST D PREPLST(.LST)
;
; --- Store Lab Order --------------
N DETRES,VAL,ORDIEN
N SEQ S SEQ=0
N EXIST S EXIST=0
;
F S SEQ=$O(LST(SEQ)) QUIT:'SEQ D
. S ORDIEN=LST(SEQ)
. QUIT:'ORDIEN
. D DETAIL^ORWOR(.DETRES,ORDIEN,DFN) ; Get Detail Info
. D STORE(.VPSARR,DFN,ORDIEN,DETRES) ;Store Lab Orders
. S EXIST=1
. K @DETRES
;
I 'EXIST D SET(.VPSARR,"E",DFN,"","NO LAB ORDER RECORDS FOUND FOR PATIENT","LAB ORDER NOT FOUND")
K ^TMP("ORR",$J)
QUIT
;
PREPLST(LST) ;Prepare Lab Order List
N MAX,DAT,SEQ
S (SEQ,DAT)=0
K LST
;
F S DAT=$O(^TMP("ORR",$J,DAT)) QUIT:'DAT D
. S MAX=+$G(^TMP("ORR",$J,DAT,.1)) QUIT:'MAX
. F SEQ=1:1:MAX S LST(SEQ)=$P(^TMP("ORR",$J,DAT,SEQ),U)
QUIT
;
STORE(VPSARR,DFN,ORDIEN,LST) ;Store Lab Orders
; OUTPUT
; VPSARR - passed in by reference; this is the output array to store lab order
; INPUT
; DFN - patient DFN (This value must be validated before calling this procedure)
; ORDIEN - Order Number
; LST - Detail Result Array
;
N IDX S IDX=DFN_";"_ORDIEN
D SET(.VPSARR,100,IDX,.01,+ORDIEN) ;ORDER NUMBER
N VAL S VAL=$$GET1^DIQ(100,+ORDIEN_",",16,"I")
D SET(.VPSARR,100,IDX,16,VAL,"LAB APPOINTMENT DATE/TIME")
N LINE,FLD,VAL,SEQ S SEQ=0
;
F S SEQ=$O(@LST@(SEQ)) Q:'SEQ D
. S LINE=@LST@(SEQ)
. S FLD=$P(LINE,":")
. S VAL=$$TRIM^XLFSTR($P(LINE,":",2,99))
. I FLD="Lab Test" D SET(.VPSARR,69.03,IDX,.01,VAL,"LAB TEST")
. I FLD="Urgency" D SET(.VPSARR,69.03,IDX,1,VAL,"URGENCY")
. I FLD="Current Status" D SET(.VPSARR,100,IDX,8,VAL,"CURRENT STATUS")
. I FLD="Collection Date/Time" S VAL=$$EXT2FM(VAL) D SET(.VPSARR,69.01,IDX,10,VAL,"COLLECTION DATE/TIME")
QUIT
;
EXT2FM(VAL) ;External to FM Date -> Oct 20, 2014@17:30 -> 3141020@173
; -- Get Date
N MTHS S MTHS="Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"
N MTH S MTH=$P(VAL," "),MTH=$F(MTHS,MTH)\4
I 'MTH QUIT VAL
N DAT S DAT=+$P(VAL," ",2)
N YR S YR=+$P(VAL," ",3)
N FMDT S FMDT=YR-1700*100+MTH*100+DAT
;
; -- Get Time
N EXTTM S EXTTM=$P(VAL,"@",2) ;Time
N FMTM S FMTM="."_$TR(EXTTM,":")
;
QUIT FMDT_(+FMTM)
;
SET(VPSARR,VPSFL,VPSIEN,VPSFLD,VPSDA,VPSDS) ;Set line item to output array
I VPSDA'="" D SET^VPSRPC1(.VPSARR,VPSFL,VPSIEN,VPSFLD,VPSDA,$G(VPSDS),2) ;Set line item to output array
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPSRPC12 3534 printed Dec 13, 2024@02:43:26 Page 2
VPSRPC12 ;WOIFO/BT - Patient Demographic - Lab Orders;08/14/14 13:07
+1 ;;1.0;VA POINT OF SERVICE (KIOSKS);**4**;Aug 14, 2014;Build 27
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; External Reference DBIA#
+5 ; ------------------------
+6 ; #3366 - AGET^ORWORR (Controlled Subs)
+7 ; #3367 - GET4LST^ORWORR (Controlled Subs)
+8 ; #6100 - DETAIL^ORWOR (Private)
+9 ; #10104 - XLFSTR call (Supported)
+10 QUIT
+11 ;
GETLAB(VPSARR,DFN,DTRANGE) ;given DFN, returns the patient lab
+1 ; OUTPUT
+2 ; VPSARR - passed in by reference; this is the output array to store lab order
+3 ; INPUT
+4 ; DFN - patient DFN (This value must be validated before calling this procedure)
+5 ; DTRANGE - FROMDATE:THROUGHDATE
+6 ;
+7 ; --- Filter ---------
+8 KILL ^TMP("ORR",$JOB)
+9 NEW DTFROM
SET DTFROM=$PIECE(DTRANGE,":")
+10 NEW DTTHRU
SET DTTHRU=$PIECE(DTRANGE,":",2)
+11 if DTFROM=""
SET DTFROM=0
+12 if DTTHRU=""
SET DTTHRU=0
+13 IF $PIECE(DTFROM,".")=$PIECE(DTTHRU,".")
IF $PIECE(DTFROM,".",2)>$PIECE(DTTHRU,".",2)
IF $PIECE(DTTHRU,".",2)=""
SET $PIECE(DTTHRU,".",2)=2359
+14 ;
+15 ; --- Compile ---------
+16 ;lab orders
NEW GROUP
SET GROUP=$ORDER(^ORD(100.98,"B","LABORATORY",0))
+17 NEW ORSLT
DO AGET^ORWORR(.ORSLT,DFN,,GROUP,DTFROM,DTTHRU)
+18 NEW LST
DO PREPLST(.LST)
+19 ;
+20 ; --- Store Lab Order --------------
+21 NEW DETRES,VAL,ORDIEN
+22 NEW SEQ
SET SEQ=0
+23 NEW EXIST
SET EXIST=0
+24 ;
+25 FOR
SET SEQ=$ORDER(LST(SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+26 SET ORDIEN=LST(SEQ)
+27 if 'ORDIEN
QUIT
+28 ; Get Detail Info
DO DETAIL^ORWOR(.DETRES,ORDIEN,DFN)
+29 ;Store Lab Orders
DO STORE(.VPSARR,DFN,ORDIEN,DETRES)
+30 SET EXIST=1
+31 KILL @DETRES
End DoDot:1
+32 ;
+33 IF 'EXIST
DO SET(.VPSARR,"E",DFN,"","NO LAB ORDER RECORDS FOUND FOR PATIENT","LAB ORDER NOT FOUND")
+34 KILL ^TMP("ORR",$JOB)
+35 QUIT
+36 ;
PREPLST(LST) ;Prepare Lab Order List
+1 NEW MAX,DAT,SEQ
+2 SET (SEQ,DAT)=0
+3 KILL LST
+4 ;
+5 FOR
SET DAT=$ORDER(^TMP("ORR",$JOB,DAT))
if 'DAT
QUIT
Begin DoDot:1
+6 SET MAX=+$GET(^TMP("ORR",$JOB,DAT,.1))
if 'MAX
QUIT
+7 FOR SEQ=1:1:MAX
SET LST(SEQ)=$PIECE(^TMP("ORR",$JOB,DAT,SEQ),U)
End DoDot:1
+8 QUIT
+9 ;
STORE(VPSARR,DFN,ORDIEN,LST) ;Store Lab Orders
+1 ; OUTPUT
+2 ; VPSARR - passed in by reference; this is the output array to store lab order
+3 ; INPUT
+4 ; DFN - patient DFN (This value must be validated before calling this procedure)
+5 ; ORDIEN - Order Number
+6 ; LST - Detail Result Array
+7 ;
+8 NEW IDX
SET IDX=DFN_";"_ORDIEN
+9 ;ORDER NUMBER
DO SET(.VPSARR,100,IDX,.01,+ORDIEN)
+10 NEW VAL
SET VAL=$$GET1^DIQ(100,+ORDIEN_",",16,"I")
+11 DO SET(.VPSARR,100,IDX,16,VAL,"LAB APPOINTMENT DATE/TIME")
+12 NEW LINE,FLD,VAL,SEQ
SET SEQ=0
+13 ;
+14 FOR
SET SEQ=$ORDER(@LST@(SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+15 SET LINE=@LST@(SEQ)
+16 SET FLD=$PIECE(LINE,":")
+17 SET VAL=$$TRIM^XLFSTR($PIECE(LINE,":",2,99))
+18 IF FLD="Lab Test"
DO SET(.VPSARR,69.03,IDX,.01,VAL,"LAB TEST")
+19 IF FLD="Urgency"
DO SET(.VPSARR,69.03,IDX,1,VAL,"URGENCY")
+20 IF FLD="Current Status"
DO SET(.VPSARR,100,IDX,8,VAL,"CURRENT STATUS")
+21 IF FLD="Collection Date/Time"
SET VAL=$$EXT2FM(VAL)
DO SET(.VPSARR,69.01,IDX,10,VAL,"COLLECTION DATE/TIME")
End DoDot:1
+22 QUIT
+23 ;
EXT2FM(VAL) ;External to FM Date -> Oct 20, 2014@17:30 -> 3141020@173
+1 ; -- Get Date
+2 NEW MTHS
SET MTHS="Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"
+3 NEW MTH
SET MTH=$PIECE(VAL," ")
SET MTH=$FIND(MTHS,MTH)\4
+4 IF 'MTH
QUIT VAL
+5 NEW DAT
SET DAT=+$PIECE(VAL," ",2)
+6 NEW YR
SET YR=+$PIECE(VAL," ",3)
+7 NEW FMDT
SET FMDT=YR-1700*100+MTH*100+DAT
+8 ;
+9 ; -- Get Time
+10 ;Time
NEW EXTTM
SET EXTTM=$PIECE(VAL,"@",2)
+11 NEW FMTM
SET FMTM="."_$TRANSLATE(EXTTM,":")
+12 ;
+13 QUIT FMDT_(+FMTM)
+14 ;
SET(VPSARR,VPSFL,VPSIEN,VPSFLD,VPSDA,VPSDS) ;Set line item to output array
+1 ;Set line item to output array
IF VPSDA'=""
DO SET^VPSRPC1(.VPSARR,VPSFL,VPSIEN,VPSFLD,VPSDA,$GET(VPSDS),2)
+2 QUIT
