VIABEFR ;AAC/JMC - VIA EFR RPCs ;05/17/2016
;;1.0;VISTA INTEGRATION ADAPTER;**9**;06-FEB-2014;Build 1
;
;The following RPC is in support of the Embedded Fragment Registry (EFR). This RPC reads data from the
;RESEARCH File #67.1 and the LAB DATA File #63.
;
; RPC VIAB EFR
; ICR 2052 Database Server API: Data Dictionary Utilities
; ICR 6743 VIAB LAB [File 63, "CH" node] (private)
; ICR 6476 RESEARCH [File #67.1, fields #.01,9,63] (private)
;
Q
;
EN(RESULT,VIA) ; entry point for RPC
D PARSE(.VIA)
D TMP
D DTCHK
D LAB671
D KVAR
Q
;
PARSE(VIA) ; -- array parsing to parameters and initializing variables
;Input parameters
; VIA("FROM")=value to start from in Files #67.1 & #63.04 [optional]
; VIA("SDATE")=Start Date for search [optional]
; VIA("EDATE")=End Date for search [optional]
; VIA("IDS")=List of Patient Identifiers separated by a semicolon [optional]
; VIA("FIELDS")=list of extra fields to return data, separate by semicolon (;)[optional]
; Example: VIA("FIELDS")="631807;631568;631567;631007;631808;631798;631799;631800;631801;631809"
; VIA("MAX")=n [optional]
N SFLDS,IFLDS,I,X
S VIAFIELDS=$G(VIA("FIELDS"))
S VIAMAX=$G(VIA("MAX")) I VIAMAX>1000 S VIAMAX=1000
I $G(VIAMAX)="" S VIAMAX=1000
S VIAFROM=$G(VIA("FROM"))
S VIABFRM=VIAFROM
S VIASDT=$G(VIA("SDATE"))
S VIAEDT=$G(VIA("EDATE"))
S VIAIDS=$G(VIA("IDS"))
Q
;
TMP ; -- temporary environment variables sets until kernel tools arrives
IF '$G(DUZ) D
. S DUZ=.5,DUZ(0)="@",U="^",DTIME=300
. D NOW^%DTC S DT=X
Q
;
LAB671 ; -- returns a list of lab identifiers from RESEARCH File #67.1
; Builds the ^TMP("VIABEFR",$J) array
; ^TMP("VIABEFR",$J,1)="[Data"] or if there is an error ^TMP("VIABEFR",$J,1)="[Errors"]
; ^TMP("VIABEFR",$J,n)=67.1:IEN^.01 NAME^9 IDENTIFIER^63 LABORATORY REFERENCE
; where n is a numeric value starting from 2
;
N VIACNT,VIA671,IENS,QFLG,LRIEN,VIAC,XREF,STR671
K ^TMP("VIABEFR",$J)
S VIAC=1,(VIACNT,QFLG)=0
S ^TMP("VIABEFR",$J,1)="[Data]"
I VIAIDS'="" D IDS Q
I VIAFROM'="" S VIAFROM=$$STRTFRM() I VIAFROM="" D Q
. S ^TMP("VIABEFR",$J,1)="[Errors]"
. S ^TMP("VIABEFR",$J,2)="Starting Entry not found" K RESULT S RESULT=$NA(^TMP("VIABEFR",$J)) Q
S XREF=$S(VIAFROM'="":VIAFROM,1:"")
F S XREF=$O(^LRT(67.1,"B",XREF)) Q:XREF="" D I QFLG Q
. S IENS=0 F S IENS=$O(^LRT(67.1,"B",XREF,IENS)) Q:'IENS D I QFLG Q
. . S LRIEN=$$GET1^DIQ(67.1,IENS,63,"I") I LRIEN="" Q
. . S $P(VIA671,U)=$$GET1^DIQ(67.1,IENS,.01,"I"),$P(VIA671,U,9)=$$GET1^DIQ(67.1,IENS,9,"I")
. . S STR671="67.1:"_IENS_U_$P(VIA671,U)_U_$P(VIA671,U,9)_U_LRIEN
. . D LAB6304
K RESULT
S RESULT=$NA(^TMP("VIABEFR",$J))
Q
;
IDS ; -- return lab results for list of identifiers
N VIAID,I,X,Y
; parse identifiers into array
F I=1:1:$L(VIAIDS,";") S Y=$P(VIAIDS,";",I) I Y'="" S VIAID(Y)=""
S XREF="" F S XREF=$O(VIAID(XREF)) Q:XREF="" D:$D(^LRT(67.1,"C",XREF)) I QFLG Q
. S IENS=0 F S IENS=$O(^LRT(67.1,"C",XREF,IENS)) Q:'IENS D I QFLG Q
. . S LRIEN=$$GET1^DIQ(67.1,IENS,63,"I") I LRIEN="" Q
. . S $P(VIA671,U)=$$GET1^DIQ(67.1,IENS,.01,"I"),$P(VIA671,U,9)=$$GET1^DIQ(67.1,IENS,9,"I")
. . S STR671="67.1:"_IENS_U_$P(VIA671,U)_U_$P(VIA671,U,9)_U_LRIEN
. . D LAB6304
K RESULT
S RESULT=$NA(^TMP("VIABEFR",$J))
Q
;
LAB6304 ; -- Using the LAB IEN from File #67.1, get data from LAB DATA File #63.04
; Builds ^TMP("VIABEFR",$J,n)=list of standard fields returned by the RPC. n is a numeric value.
; ^TMP("VIABEFR",$J,n+1)=63:04:IEN^.01 DATE/TIME SPECIMEN TAKEN^.06 ACCESSION^.03 DATE REPORT COMPLETED
; ^TMP("VIABEFR",$J,n+2)=4 CREATININE
; ^TMP("VIABEFR",$J,n+3)=31 COPPER
; ^TMP("VIABEFR",$J,n+4)=32 ZINC
; ^TMP("VIABEFR",$J,n+5)=33 ARSENIC
; ^TMP("VIABEFR",$J,n+6)=35 LEAD (SK)
; ^TMP("VIABEFR",$J,n+7)=101 CADMIUM
; ^TMP("VIABEFR",$J,n+8)=106 CHROMIUM
; ^TMP("VIABEFR",$J,n+9)=108 COBALT
; ^TMP("VIABEFR",$J,n+10)=116 MANGANESE (SK)
; ^TMP("VIABEFR",$J,n+11)=205 ALUMINUM
; ^TMP("VIABEFR",$J,n+12)=322 NICKEL (SK)
; ^TMP("VIABEFR",$J,n+13)=750 IRON
; ^TMP("VIABEFR",$J,n+14)=797 VOLUME
; ^TMP("VIABEFR",$J,n+15)=840 ELAPSED TIME
; VIAEFLDS - custom fields passed in as input parameter and returned by the RPC are stored after the standard fields.
; ^TMP("VIABEFR",$J,n+16)=TESTNAME;NUMBER^RESULT
;
N X,VIAEFLDS,VIASFLDS,VIASFLDS1,VIASTR,IVDT,J,FLD,F671,VIAVAL
S VIASFLDS=".01;.06;.03",VIASFLDS1="4;31;32;33;35;101;106;108;116;205;322;750;797;840",F671=1
S VIAEFLDS=VIAFIELDS,IVDT=$S(VIABFRM'="":$P($P(VIABFRM,"^",2),",",2),1:VIASDT)
F S IVDT=$O(^LR(LRIEN,"CH",IVDT)) Q:'IVDT Q:(IVDT>VIAEDT) D I VIACNT>VIAMAX S QFLG=1 D SETFRM Q
. I F671 S VIAC=VIAC+1,^TMP("VIABEFR",$J,VIAC)=STR671,VIACNT=VIACNT+1,F671=0
. S VIAVAL="",VIACNT=VIACNT+1
. F J=1:1:$L(VIASFLDS,";") S FLD=$P(VIASFLDS,";",J) I FLD'="" D
. . S VIASTR=$$GET1^DIQ(63.04,IVDT_","_LRIEN_",",FLD,"I")
. . S VIAVAL=VIAVAL_$S(VIAVAL="":"",1:"^")_VIASTR
. S VIAC=VIAC+1,^TMP("VIABEFR",$J,VIAC)="63.04:"_IVDT_"^"_VIAVAL
. ; get data for remaining standard fields; get entire node since these are stored in non-standard FileMan format.
. F J=1:1:$L(VIASFLDS1,";") S FLD=$P(VIASFLDS1,";",J) I FLD'="" D STMP
. ; get data for additional fields passed in input parameter
. F J=1:1:$L(VIAEFLDS,";") S FLD=$P(VIAEFLDS,";",J) I FLD'="" D STMP
Q
;
STMP ;set ^TMP("VIAEFR"
N FLDNM,VIASTR
D FIELD^DID(63.04,FLD,,"LABEL","VIALB") S FLDNM=$$UP^XLFSTR($G(VIALB("LABEL")))
S VIASTR=$G(^LR(LRIEN,"CH",IVDT,FLD))
I VIASTR'="" S VIAC=VIAC+1,^TMP("VIABEFR",$J,VIAC)=FLDNM_";"_FLD_"^"_VIASTR
K VIALB
Q
;
STRTFRM() ; find where to start File 67.1 search
N STR
S STR=$P($P(VIAFROM,U),",")
I $D(^LRT(67.1,"B",STR)) S VIAFROM=$O(^LRT(67.1,"B",STR),-1) Q VIAFROM
S STR=$G(^LRT(67.1,+$P($P(VIAFROM,U),",",2),0)) I STR'="" S VIAFROM=$O(^LRT(67.1,"B",STR),-1) Q VIAFROM
Q ""
;
SETFRM ; entry to start list.
S VIAC=VIAC+1,^TMP("VIABEFR",$J,VIAC)="[Misc]"
S VIAC=VIAC+1,^TMP("VIABEFR",$J,VIAC)="MORE"_U_$P(VIA671,U)_","_IENS_U_LRIEN_","_$G(IVDT)
Q
;
DTCHK ;check/set date
I $G(VIAEDT)<$G(VIASDT) S X=$G(VIAEDT),VIAEDT=$G(VIASDT),VIASDT=X
I $G(VIAEDT) S VIAEDT=$S($L(VIAEDT,".")=2:VIAEDT+.000001,1:VIAEDT+1)
S VIASDT=$S($G(VIASDT):9999999-VIASDT,1:9999999),VIAEDT=$S($G(VIAEDT):9999999-VIAEDT,1:1)
S X=VIAEDT,VIAEDT=VIASDT,VIASDT=X
Q
;
KVAR ;Clean-up
K VIAFIELDS,VIAEDT,VIAMAX,VIASDT,VIAFROM,VIABFRM,VIAIDS,X,Y
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVIABEFR 6676 printed Dec 13, 2024@02:45:13 Page 2
VIABEFR ;AAC/JMC - VIA EFR RPCs ;05/17/2016
+1 ;;1.0;VISTA INTEGRATION ADAPTER;**9**;06-FEB-2014;Build 1
+2 ;
+3 ;The following RPC is in support of the Embedded Fragment Registry (EFR). This RPC reads data from the
+4 ;RESEARCH File #67.1 and the LAB DATA File #63.
+5 ;
+6 ; RPC VIAB EFR
+7 ; ICR 2052 Database Server API: Data Dictionary Utilities
+8 ; ICR 6743 VIAB LAB [File 63, "CH" node] (private)
+9 ; ICR 6476 RESEARCH [File #67.1, fields #.01,9,63] (private)
+10 ;
+11 QUIT
+12 ;
EN(RESULT,VIA) ; entry point for RPC
+1 DO PARSE(.VIA)
+2 DO TMP
+3 DO DTCHK
+4 DO LAB671
+5 DO KVAR
+6 QUIT
+7 ;
PARSE(VIA) ; -- array parsing to parameters and initializing variables
+1 ;Input parameters
+2 ; VIA("FROM")=value to start from in Files #67.1 & #63.04 [optional]
+3 ; VIA("SDATE")=Start Date for search [optional]
+4 ; VIA("EDATE")=End Date for search [optional]
+5 ; VIA("IDS")=List of Patient Identifiers separated by a semicolon [optional]
+6 ; VIA("FIELDS")=list of extra fields to return data, separate by semicolon (;)[optional]
+7 ; Example: VIA("FIELDS")="631807;631568;631567;631007;631808;631798;631799;631800;631801;631809"
+8 ; VIA("MAX")=n [optional]
+9 NEW SFLDS,IFLDS,I,X
+10 SET VIAFIELDS=$GET(VIA("FIELDS"))
+11 SET VIAMAX=$GET(VIA("MAX"))
IF VIAMAX>1000
SET VIAMAX=1000
+12 IF $GET(VIAMAX)=""
SET VIAMAX=1000
+13 SET VIAFROM=$GET(VIA("FROM"))
+14 SET VIABFRM=VIAFROM
+15 SET VIASDT=$GET(VIA("SDATE"))
+16 SET VIAEDT=$GET(VIA("EDATE"))
+17 SET VIAIDS=$GET(VIA("IDS"))
+18 QUIT
+19 ;
TMP ; -- temporary environment variables sets until kernel tools arrives
+1 IF '$GET(DUZ)
Begin DoDot:1
+2 SET DUZ=.5
SET DUZ(0)="@"
SET U="^"
SET DTIME=300
+3 DO NOW^%DTC
SET DT=X
End DoDot:1
+4 QUIT
+5 ;
LAB671 ; -- returns a list of lab identifiers from RESEARCH File #67.1
+1 ; Builds the ^TMP("VIABEFR",$J) array
+2 ; ^TMP("VIABEFR",$J,1)="[Data"] or if there is an error ^TMP("VIABEFR",$J,1)="[Errors"]
+3 ; ^TMP("VIABEFR",$J,n)=67.1:IEN^.01 NAME^9 IDENTIFIER^63 LABORATORY REFERENCE
+4 ; where n is a numeric value starting from 2
+5 ;
+6 NEW VIACNT,VIA671,IENS,QFLG,LRIEN,VIAC,XREF,STR671
+7 KILL ^TMP("VIABEFR",$JOB)
+8 SET VIAC=1
SET (VIACNT,QFLG)=0
+9 SET ^TMP("VIABEFR",$JOB,1)="[Data]"
+10 IF VIAIDS'=""
DO IDS
QUIT
+11 IF VIAFROM'=""
SET VIAFROM=$$STRTFRM()
IF VIAFROM=""
Begin DoDot:1
+12 SET ^TMP("VIABEFR",$JOB,1)="[Errors]"
+13 SET ^TMP("VIABEFR",$JOB,2)="Starting Entry not found"
KILL RESULT
SET RESULT=$NAME(^TMP("VIABEFR",$JOB))
QUIT
End DoDot:1
QUIT
+14 SET XREF=$SELECT(VIAFROM'="":VIAFROM,1:"")
+15 FOR
SET XREF=$ORDER(^LRT(67.1,"B",XREF))
if XREF=""
QUIT
Begin DoDot:1
+16 SET IENS=0
FOR
SET IENS=$ORDER(^LRT(67.1,"B",XREF,IENS))
if 'IENS
QUIT
Begin DoDot:2
+17 SET LRIEN=$$GET1^DIQ(67.1,IENS,63,"I")
IF LRIEN=""
QUIT
+18 SET $PIECE(VIA671,U)=$$GET1^DIQ(67.1,IENS,.01,"I")
SET $PIECE(VIA671,U,9)=$$GET1^DIQ(67.1,IENS,9,"I")
+19 SET STR671="67.1:"_IENS_U_$PIECE(VIA671,U)_U_$PIECE(VIA671,U,9)_U_LRIEN
+20 DO LAB6304
End DoDot:2
IF QFLG
QUIT
End DoDot:1
IF QFLG
QUIT
+21 KILL RESULT
+22 SET RESULT=$NAME(^TMP("VIABEFR",$JOB))
+23 QUIT
+24 ;
IDS ; -- return lab results for list of identifiers
+1 NEW VIAID,I,X,Y
+2 ; parse identifiers into array
+3 FOR I=1:1:$LENGTH(VIAIDS,";")
SET Y=$PIECE(VIAIDS,";",I)
IF Y'=""
SET VIAID(Y)=""
+4 SET XREF=""
FOR
SET XREF=$ORDER(VIAID(XREF))
if XREF=""
QUIT
if $DATA(^LRT(67.1,"C",XREF))
Begin DoDot:1
+5 SET IENS=0
FOR
SET IENS=$ORDER(^LRT(67.1,"C",XREF,IENS))
if 'IENS
QUIT
Begin DoDot:2
+6 SET LRIEN=$$GET1^DIQ(67.1,IENS,63,"I")
IF LRIEN=""
QUIT
+7 SET $PIECE(VIA671,U)=$$GET1^DIQ(67.1,IENS,.01,"I")
SET $PIECE(VIA671,U,9)=$$GET1^DIQ(67.1,IENS,9,"I")
+8 SET STR671="67.1:"_IENS_U_$PIECE(VIA671,U)_U_$PIECE(VIA671,U,9)_U_LRIEN
+9 DO LAB6304
End DoDot:2
IF QFLG
QUIT
End DoDot:1
IF QFLG
QUIT
+10 KILL RESULT
+11 SET RESULT=$NAME(^TMP("VIABEFR",$JOB))
+12 QUIT
+13 ;
LAB6304 ; -- Using the LAB IEN from File #67.1, get data from LAB DATA File #63.04
+1 ; Builds ^TMP("VIABEFR",$J,n)=list of standard fields returned by the RPC. n is a numeric value.
+2 ; ^TMP("VIABEFR",$J,n+1)=63:04:IEN^.01 DATE/TIME SPECIMEN TAKEN^.06 ACCESSION^.03 DATE REPORT COMPLETED
+3 ; ^TMP("VIABEFR",$J,n+2)=4 CREATININE
+4 ; ^TMP("VIABEFR",$J,n+3)=31 COPPER
+5 ; ^TMP("VIABEFR",$J,n+4)=32 ZINC
+6 ; ^TMP("VIABEFR",$J,n+5)=33 ARSENIC
+7 ; ^TMP("VIABEFR",$J,n+6)=35 LEAD (SK)
+8 ; ^TMP("VIABEFR",$J,n+7)=101 CADMIUM
+9 ; ^TMP("VIABEFR",$J,n+8)=106 CHROMIUM
+10 ; ^TMP("VIABEFR",$J,n+9)=108 COBALT
+11 ; ^TMP("VIABEFR",$J,n+10)=116 MANGANESE (SK)
+12 ; ^TMP("VIABEFR",$J,n+11)=205 ALUMINUM
+13 ; ^TMP("VIABEFR",$J,n+12)=322 NICKEL (SK)
+14 ; ^TMP("VIABEFR",$J,n+13)=750 IRON
+15 ; ^TMP("VIABEFR",$J,n+14)=797 VOLUME
+16 ; ^TMP("VIABEFR",$J,n+15)=840 ELAPSED TIME
+17 ; VIAEFLDS - custom fields passed in as input parameter and returned by the RPC are stored after the standard fields.
+18 ; ^TMP("VIABEFR",$J,n+16)=TESTNAME;NUMBER^RESULT
+19 ;
+20 NEW X,VIAEFLDS,VIASFLDS,VIASFLDS1,VIASTR,IVDT,J,FLD,F671,VIAVAL
+21 SET VIASFLDS=".01;.06;.03"
SET VIASFLDS1="4;31;32;33;35;101;106;108;116;205;322;750;797;840"
SET F671=1
+22 SET VIAEFLDS=VIAFIELDS
SET IVDT=$SELECT(VIABFRM'="":$PIECE($PIECE(VIABFRM,"^",2),",",2),1:VIASDT)
+23 FOR
SET IVDT=$ORDER(^LR(LRIEN,"CH",IVDT))
if 'IVDT
QUIT
if (IVDT>VIAEDT)
QUIT
Begin DoDot:1
+24 IF F671
SET VIAC=VIAC+1
SET ^TMP("VIABEFR",$JOB,VIAC)=STR671
SET VIACNT=VIACNT+1
SET F671=0
+25 SET VIAVAL=""
SET VIACNT=VIACNT+1
+26 FOR J=1:1:$LENGTH(VIASFLDS,";")
SET FLD=$PIECE(VIASFLDS,";",J)
IF FLD'=""
Begin DoDot:2
+27 SET VIASTR=$$GET1^DIQ(63.04,IVDT_","_LRIEN_",",FLD,"I")
+28 SET VIAVAL=VIAVAL_$SELECT(VIAVAL="":"",1:"^")_VIASTR
End DoDot:2
+29 SET VIAC=VIAC+1
SET ^TMP("VIABEFR",$JOB,VIAC)="63.04:"_IVDT_"^"_VIAVAL
+30 ; get data for remaining standard fields; get entire node since these are stored in non-standard FileMan format.
+31 FOR J=1:1:$LENGTH(VIASFLDS1,";")
SET FLD=$PIECE(VIASFLDS1,";",J)
IF FLD'=""
DO STMP
+32 ; get data for additional fields passed in input parameter
+33 FOR J=1:1:$LENGTH(VIAEFLDS,";")
SET FLD=$PIECE(VIAEFLDS,";",J)
IF FLD'=""
DO STMP
End DoDot:1
IF VIACNT>VIAMAX
SET QFLG=1
DO SETFRM
QUIT
+34 QUIT
+35 ;
STMP ;set ^TMP("VIAEFR"
+1 NEW FLDNM,VIASTR
+2 DO FIELD^DID(63.04,FLD,,"LABEL","VIALB")
SET FLDNM=$$UP^XLFSTR($GET(VIALB("LABEL")))
+3 SET VIASTR=$GET(^LR(LRIEN,"CH",IVDT,FLD))
+4 IF VIASTR'=""
SET VIAC=VIAC+1
SET ^TMP("VIABEFR",$JOB,VIAC)=FLDNM_";"_FLD_"^"_VIASTR
+5 KILL VIALB
+6 QUIT
+7 ;
STRTFRM() ; find where to start File 67.1 search
+1 NEW STR
+2 SET STR=$PIECE($PIECE(VIAFROM,U),",")
+3 IF $DATA(^LRT(67.1,"B",STR))
SET VIAFROM=$ORDER(^LRT(67.1,"B",STR),-1)
QUIT VIAFROM
+4 SET STR=$GET(^LRT(67.1,+$PIECE($PIECE(VIAFROM,U),",",2),0))
IF STR'=""
SET VIAFROM=$ORDER(^LRT(67.1,"B",STR),-1)
QUIT VIAFROM
+5 QUIT ""
+6 ;
SETFRM ; entry to start list.
+1 SET VIAC=VIAC+1
SET ^TMP("VIABEFR",$JOB,VIAC)="[Misc]"
+2 SET VIAC=VIAC+1
SET ^TMP("VIABEFR",$JOB,VIAC)="MORE"_U_$PIECE(VIA671,U)_","_IENS_U_LRIEN_","_$GET(IVDT)
+3 QUIT
+4 ;
DTCHK ;check/set date
+1 IF $GET(VIAEDT)<$GET(VIASDT)
SET X=$GET(VIAEDT)
SET VIAEDT=$GET(VIASDT)
SET VIASDT=X
+2 IF $GET(VIAEDT)
SET VIAEDT=$SELECT($LENGTH(VIAEDT,".")=2:VIAEDT+.000001,1:VIAEDT+1)
+3 SET VIASDT=$SELECT($GET(VIASDT):9999999-VIASDT,1:9999999)
SET VIAEDT=$SELECT($GET(VIAEDT):9999999-VIAEDT,1:1)
+4 SET X=VIAEDT
SET VIAEDT=VIASDT
SET VIASDT=X
+5 QUIT
+6 ;
KVAR ;Clean-up
+1 KILL VIAFIELDS,VIAEDT,VIAMAX,VIASDT,VIAFROM,VIABFRM,VIAIDS,X,Y
+2 QUIT
+3 ;
