VPRDJ07 ;SLC/MKB -- Radiology,Surgery ;6/25/12 16:11
;;1.0;VIRTUAL PATIENT RECORD;**2**;Sep 01, 2011;Build 317
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^SC 10040
; ^VA(200 10060
; DIC 2051
; DIQ 2056
; RAO7PC1 2043,2265
; SROESTV 3533
;
; All tags expect DFN, ID, [VPRSTART, VPRSTOP, VPRMAX, VPRTEXT]
;
RA1(ID) ; -- radiology exam ^TMP($J,"RAE1",DFN,ID)
N EXAM,X0,SET,PROC,DATE,LOC,X,Y,IENS,ID3,N
S X0=$G(^TMP($J,"RAE1",DFN,ID)),SET=$G(^(ID,"CPRS")),PROC=$P(X0,U) Q:X0=""
S EXAM("localId")=ID,EXAM("uid")=$$SETUID^VPRUTILS("image",DFN,ID)
S EXAM("name")=PROC,EXAM("case")=$P(X0,U,2),EXAM("category")="RA"
S DATE=9999999.9999-+ID,EXAM("dateTime")=$$JSONDT^VPRUTILS(DATE)
I $P(X0,U,5) D ;report exists
. N NM S NM=$S(+SET=2:$P(SET,U,2),1:PROC) ;2 = shared report
. S EXAM("results",1,"uid")=$$SETUID^VPRUTILS("document",DFN,ID)
. S EXAM("results",1,"localTitle")=NM
. S EXAM("verified")=$S($E($P(X0,U,3))="V":"true",1:"false")
S:$L($P(X0,U,6)) EXAM("statusName")=$P($P(X0,U,6),"~",2)
S X=$P(X0,U,7),LOC="" I $L(X) D
. S EXAM("imageLocation")=X,EXAM("locationName")=X
. S LOC=+$O(^SC("B",X,0))
. S EXAM("locationUid")=$$SETUID^VPRUTILS("location",,LOC)
S X=$$FAC^VPRD(LOC) D FACILITY^VPRUTILS(X,"EXAM")
I $L($P(X0,U,8)) S X=$P($P(X0,U,8),"~",2),EXAM("imagingTypeUid")=$$SETVURN^VPRUTILS("imaging-Type",X)
S X=$P(X0,U,10) I X D
. N CPT S CPT=$$CPT^VPRDRA(X)
. S (EXAM("typeName"),EXAM("summary"))=$P(CPT,U,2)
. ;I $D(^TMP($J,"RAE1",DFN,ID,"CMOD")) M EXAM("modifier")=^("CMOD")
I $P(X0,U,11) D
. S EXAM("orderUid")=$$SETUID^VPRUTILS("order",DFN,+$P(X0,U,11))
. S EXAM("orderName")=$S($L(SET):$P(SET,U,2),1:PROC)
S EXAM("hasImages")=$S($P(X0,U,12)="Y":"true",1:"false")
I $P(X0,U,4)="Y"!($P(X0,U,9)="Y") S EXAM("interpretation")="ABNORMAL"
S IENS=$P(ID,"-",2)_","_+ID_","_DFN_","
S X=$$GET1^DIQ(70.03,IENS,27,"I") I X D
. S EXAM("encounterUid")=$$SETUID^VPRUTILS("visit",DFN,+X)
. S EXAM("encounterName")=$$NAME^VPRDJ04(+X)
S ID3=DFN_U_$TR(ID,"-","^") D EN3^RAO7PC1(ID3) D ;get additional values
. S X=+$G(^TMP($J,"RAE2",DFN,+$P(ID3,U,3),PROC,"P")) Q:'X
. S EXAM("providers",1,"providerUid")=$$SETUID^VPRUTILS("user",,X)
. S EXAM("providers",1,"providerName")=$P($G(^VA(200,X,0)),U),N=0
. F S N=$O(^TMP($J,"RAE2",DFN,+$P(ID3,U,3),PROC,"D",N)) Q:N<1 S X=$G(^(N)) D
.. S EXAM("diagnosis",N,"code")=X
.. S:N=1 EXAM("diagnosis",N,"primary")="true"
.. N EXP S EXP=$$LEX(X) S:EXP EXAM("diagnosis",N,"lexicon")=X
. K ^TMP($J,"RAE2",DFN)
S EXAM("kind")="Imaging"
D ADD^VPRDJ("EXAM","image")
Q
;
LEX(X) ; -- Return Lexicon ptr for a Dx Code
N X,Y,DIC,LEX
S DIC=78.3,DIC(0)="BFOXZ" D ^DIC
S LEX=$P($G(Y(0)),U,6)
Q LEX
;
SR1(ID) ; -- surgery
N SURG,VPRX,VPRY,X,Y,I
D ONE^SROESTV("VPRY",ID) S VPRX=$G(VPRY(ID)) Q:VPRX=""
S SURG("localId")=ID,SURG("uid")=$$SETUID^VPRUTILS("surgery",DFN,ID)
S X=$P(VPRX,U,2),SURG("statusName")="COMPLETED"
I X?1"* Aborted * ".E S X=$E(X,13,999),SURG("statusName")="ABORTED"
S (SURG("typeName"),SURG("summary"))=X
S SURG("dateTime")=$$JSONDT^VPRUTILS($P(VPRX,U,3))
S X=$P(VPRX,U,4) I X D
. S SURG("providers",1,"providerUid")=$$SETUID^VPRUTILS("user",,+X)
. S SURG("providers",1,"providerName")=$P(X,";",2)
S X=$$GET1^DIQ(130,ID_",",50,"I"),X=$$FAC^VPRD(X)
D FACILITY^VPRUTILS(X,"SURG")
S X=$$GET1^DIQ(130,ID_",",.015,"I") I X D
. S SURG("encounterUid")=$$SETUID^VPRUTILS("visit",DFN,+X)
. S SURG("encounterName")=$$NAME^VPRDJ04(+X)
S X=$$GET1^DIQ(136,ID_",",.02,"I") I X D
. S X=$$CPT^VPRDSR(X)
. S (SURG("typeName"),SURG("summary"))=$P(X,U,2)
. S SURG("typeCode")=$$SETNCS^VPRUTILS("cpt",+X)
S I=0 F S I=$O(VPRY(ID,I)) Q:I<1 S X=$G(VPRY(ID,I)) I X D
. N LT,NT S LT=$P(X,U,2) Q:$P(LT," ")="Addendum"
. S NT=$$GET1^DIQ(8925,+X_",",".01:1501")
. S SURG("results",I,"uid")=$$SETUID^VPRUTILS("document",DFN,+X)
. S SURG("results",I,"localTitle")=LT
. S:$L(NT) SURG("results",I,"nationalTitle")=NT
S SURG("kind")="Surgery",SURG("category")="SR"
K ^TMP("TIULIST",$J)
D ADD^VPRDJ("SURG","surgery")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDJ07 4341 printed Oct 16, 2024@18:45:17 Page 2
VPRDJ07 ;SLC/MKB -- Radiology,Surgery ;6/25/12 16:11
+1 ;;1.0;VIRTUAL PATIENT RECORD;**2**;Sep 01, 2011;Build 317
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^SC 10040
+7 ; ^VA(200 10060
+8 ; DIC 2051
+9 ; DIQ 2056
+10 ; RAO7PC1 2043,2265
+11 ; SROESTV 3533
+12 ;
+13 ; All tags expect DFN, ID, [VPRSTART, VPRSTOP, VPRMAX, VPRTEXT]
+14 ;
RA1(ID) ; -- radiology exam ^TMP($J,"RAE1",DFN,ID)
+1 NEW EXAM,X0,SET,PROC,DATE,LOC,X,Y,IENS,ID3,N
+2 SET X0=$GET(^TMP($JOB,"RAE1",DFN,ID))
SET SET=$GET(^(ID,"CPRS"))
SET PROC=$PIECE(X0,U)
if X0=""
QUIT
+3 SET EXAM("localId")=ID
SET EXAM("uid")=$$SETUID^VPRUTILS("image",DFN,ID)
+4 SET EXAM("name")=PROC
SET EXAM("case")=$PIECE(X0,U,2)
SET EXAM("category")="RA"
+5 SET DATE=9999999.9999-+ID
SET EXAM("dateTime")=$$JSONDT^VPRUTILS(DATE)
+6 ;report exists
IF $PIECE(X0,U,5)
Begin DoDot:1
+7 ;2 = shared report
NEW NM
SET NM=$SELECT(+SET=2:$PIECE(SET,U,2),1:PROC)
+8 SET EXAM("results",1,"uid")=$$SETUID^VPRUTILS("document",DFN,ID)
+9 SET EXAM("results",1,"localTitle")=NM
+10 SET EXAM("verified")=$SELECT($EXTRACT($PIECE(X0,U,3))="V":"true",1:"false")
End DoDot:1
+11 if $LENGTH($PIECE(X0,U,6))
SET EXAM("statusName")=$PIECE($PIECE(X0,U,6),"~",2)
+12 SET X=$PIECE(X0,U,7)
SET LOC=""
IF $LENGTH(X)
Begin DoDot:1
+13 SET EXAM("imageLocation")=X
SET EXAM("locationName")=X
+14 SET LOC=+$ORDER(^SC("B",X,0))
+15 SET EXAM("locationUid")=$$SETUID^VPRUTILS("location",,LOC)
End DoDot:1
+16 SET X=$$FAC^VPRD(LOC)
DO FACILITY^VPRUTILS(X,"EXAM")
+17 IF $LENGTH($PIECE(X0,U,8))
SET X=$PIECE($PIECE(X0,U,8),"~",2)
SET EXAM("imagingTypeUid")=$$SETVURN^VPRUTILS("imaging-Type",X)
+18 SET X=$PIECE(X0,U,10)
IF X
Begin DoDot:1
+19 NEW CPT
SET CPT=$$CPT^VPRDRA(X)
+20 SET (EXAM("typeName"),EXAM("summary"))=$PIECE(CPT,U,2)
+21 ;I $D(^TMP($J,"RAE1",DFN,ID,"CMOD")) M EXAM("modifier")=^("CMOD")
End DoDot:1
+22 IF $PIECE(X0,U,11)
Begin DoDot:1
+23 SET EXAM("orderUid")=$$SETUID^VPRUTILS("order",DFN,+$PIECE(X0,U,11))
+24 SET EXAM("orderName")=$SELECT($LENGTH(SET):$PIECE(SET,U,2),1:PROC)
End DoDot:1
+25 SET EXAM("hasImages")=$SELECT($PIECE(X0,U,12)="Y":"true",1:"false")
+26 IF $PIECE(X0,U,4)="Y"!($PIECE(X0,U,9)="Y")
SET EXAM("interpretation")="ABNORMAL"
+27 SET IENS=$PIECE(ID,"-",2)_","_+ID_","_DFN_","
+28 SET X=$$GET1^DIQ(70.03,IENS,27,"I")
IF X
Begin DoDot:1
+29 SET EXAM("encounterUid")=$$SETUID^VPRUTILS("visit",DFN,+X)
+30 SET EXAM("encounterName")=$$NAME^VPRDJ04(+X)
End DoDot:1
+31 ;get additional values
SET ID3=DFN_U_$TRANSLATE(ID,"-","^")
DO EN3^RAO7PC1(ID3)
Begin DoDot:1
+32 SET X=+$GET(^TMP($JOB,"RAE2",DFN,+$PIECE(ID3,U,3),PROC,"P"))
if 'X
QUIT
+33 SET EXAM("providers",1,"providerUid")=$$SETUID^VPRUTILS("user",,X)
+34 SET EXAM("providers",1,"providerName")=$PIECE($GET(^VA(200,X,0)),U)
SET N=0
+35 FOR
SET N=$ORDER(^TMP($JOB,"RAE2",DFN,+$PIECE(ID3,U,3),PROC,"D",N))
if N<1
QUIT
SET X=$GET(^(N))
Begin DoDot:2
+36 SET EXAM("diagnosis",N,"code")=X
+37 if N=1
SET EXAM("diagnosis",N,"primary")="true"
+38 NEW EXP
SET EXP=$$LEX(X)
if EXP
SET EXAM("diagnosis",N,"lexicon")=X
End DoDot:2
+39 KILL ^TMP($JOB,"RAE2",DFN)
End DoDot:1
+40 SET EXAM("kind")="Imaging"
+41 DO ADD^VPRDJ("EXAM","image")
+42 QUIT
+43 ;
LEX(X) ; -- Return Lexicon ptr for a Dx Code
+1 NEW X,Y,DIC,LEX
+2 SET DIC=78.3
SET DIC(0)="BFOXZ"
DO ^DIC
+3 SET LEX=$PIECE($GET(Y(0)),U,6)
+4 QUIT LEX
+5 ;
SR1(ID) ; -- surgery
+1 NEW SURG,VPRX,VPRY,X,Y,I
+2 DO ONE^SROESTV("VPRY",ID)
SET VPRX=$GET(VPRY(ID))
if VPRX=""
QUIT
+3 SET SURG("localId")=ID
SET SURG("uid")=$$SETUID^VPRUTILS("surgery",DFN,ID)
+4 SET X=$PIECE(VPRX,U,2)
SET SURG("statusName")="COMPLETED"
+5 IF X?1"* Aborted * ".E
SET X=$EXTRACT(X,13,999)
SET SURG("statusName")="ABORTED"
+6 SET (SURG("typeName"),SURG("summary"))=X
+7 SET SURG("dateTime")=$$JSONDT^VPRUTILS($PIECE(VPRX,U,3))
+8 SET X=$PIECE(VPRX,U,4)
IF X
Begin DoDot:1
+9 SET SURG("providers",1,"providerUid")=$$SETUID^VPRUTILS("user",,+X)
+10 SET SURG("providers",1,"providerName")=$PIECE(X,";",2)
End DoDot:1
+11 SET X=$$GET1^DIQ(130,ID_",",50,"I")
SET X=$$FAC^VPRD(X)
+12 DO FACILITY^VPRUTILS(X,"SURG")
+13 SET X=$$GET1^DIQ(130,ID_",",.015,"I")
IF X
Begin DoDot:1
+14 SET SURG("encounterUid")=$$SETUID^VPRUTILS("visit",DFN,+X)
+15 SET SURG("encounterName")=$$NAME^VPRDJ04(+X)
End DoDot:1
+16 SET X=$$GET1^DIQ(136,ID_",",.02,"I")
IF X
Begin DoDot:1
+17 SET X=$$CPT^VPRDSR(X)
+18 SET (SURG("typeName"),SURG("summary"))=$PIECE(X,U,2)
+19 SET SURG("typeCode")=$$SETNCS^VPRUTILS("cpt",+X)
End DoDot:1
+20 SET I=0
FOR
SET I=$ORDER(VPRY(ID,I))
if I<1
QUIT
SET X=$GET(VPRY(ID,I))
IF X
Begin DoDot:1
+21 NEW LT,NT
SET LT=$PIECE(X,U,2)
if $PIECE(LT," ")="Addendum"
QUIT
+22 SET NT=$$GET1^DIQ(8925,+X_",",".01:1501")
+23 SET SURG("results",I,"uid")=$$SETUID^VPRUTILS("document",DFN,+X)
+24 SET SURG("results",I,"localTitle")=LT
+25 if $LENGTH(NT)
SET SURG("results",I,"nationalTitle")=NT
End DoDot:1
+26 SET SURG("kind")="Surgery"
SET SURG("category")="SR"
+27 KILL ^TMP("TIULIST",$JOB)
+28 DO ADD^VPRDJ("SURG","surgery")
+29 QUIT
