VPRSDA ;SLC/MKB -- SDA utilities ;10/25/18 15:29
;;1.0;VIRTUAL PATIENT RECORD;**8,10,16,20,26,28,29,30,31,33**;Sep 01, 2011;Build 8
;;Per VHA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^DIC(4 10090
; ^SC 10040
; %DT 10003
; DILFD 2055
; DIQ 2056
; ETSLNC 6731
; ETSRXN 6758
; ICPTCOD 1995
; LEXTRAN 4912
; VASITE 10112
; XLFNAME 3065
; XUAF4 2171
; XUPARAM 2541
;
INTDATE(X) ; -- Return internal form of date X
N %DT,Y
S %DT="TSX" D ^%DT
Q Y
;
DATE(X,DTO) ; -- return FM date X as SDA Timestamp
N D,T,Y
S X=$G(X) I X'?7N.1".".7N Q ""
S D=$P(X,"."),T=$P(X,".",2)
; validate date
I '$$VALID(D) Q ""
S Y=(1700+$E(D,1,3))_"-"_$E(D,4,5)_"-"_$E(D,6,7)
; if imprecise, add month or day of 01
F I=2,3 I $P(Y,"-",I)="00" S $P(Y,"-",I)="01"
I $G(DTO) Q Y ;date only
;
; validate T = time
I T=24 S T=235959 ;for SDA
S:$L(T)<6 T=$E((T_"000000"),1,6) ;pad the time to 6 digits
I $E(T,1,2)>23 S T="000000" ;invalid hours >> remove time
I $E(T,3,4)>59 S $E(T,3,6)="0000" ;strip invalid minutes/seconds
I $E(T,5,6)>59 S $E(T,5,6)="00" ;strip invalid seconds
S Y=Y_"T"_$E(T,1,2)_":"_$E(T,3,4)_":"_$E(T,5,6)
Q Y
;
VALID(X) ; -- returns 1 or 0, if valid FM date
N %DT,Y S %DT="",X=$G(X)
I X["." S X=$P(X,".") ;ck date only
D ^%DT I Y<1 Q 0
; check if out of HL7 range
I (Y<1410102)!(Y>4141015) Q 0
Q 1
;
NAMECOMP(NAME) ; -- return name as string of component pieces
; NAME -> FAMILY^GIVEN^MIDDLE^SUFFIX
D NAMECOMP^XLFNAME(.NAME)
N I,Y S Y=$G(NAME("FAMILY"))
F I="GIVEN","MIDDLE","SUFFIX" S Y=Y_U_$G(NAME(I))
Q Y
;
CODED ; -- ck Code Table ID for internal^external format
; called from DDEG for entity VPR CODE TABLE using variables:
; FILE, FIELD, ID (read only, do NOT kill)
Q:$G(ID)="" Q:$L(ID,"^")>1 ;ok
N X,NM S NM=ID
I $G(FILE),$G(FIELD) D
. S X=$$EXTERNAL^DILFD(FILE,FIELD,,ID)
. S:X'="" NM=X
S ID=ID_U_NM
Q
;
CODE(IEN,FILE,CSYS,CDT) ; -- find CSYS code for IEN in FILE
; CSYS can be string of abbreviations to look for, in order
N FLD,VPRC,SFN,S,SYS,NAMES,IENS,SFN1,I,X,Y
S Y="",CDT=$G(CDT) S:CDT<1 CDT=DT
S FLD=$$FLDNUM^DILFD(FILE,"CODING SYSTEM") Q:'FLD ""
D GETS^DIQ(FILE,IEN_",",FLD_"*","NR","VPRC")
S SFN=+$O(VPRC(0)) Q:'SFN "" ;Sub-file# = Coding System multiple
F S=1:1 S SYS=$P(CSYS,U,S) Q:SYS="" D Q:$L(Y)
. S NAMES=$S(SYS="RXN":"RxNorm^RXNORM",SYS="NDF":"NDF-RT^NDFRT^NDF",SYS="SCT":"SNOMED CT^SNOMED-CT^SCT",SYS="LNC":"LOINC^LNC",SYS="UNI":"UNII^UNI",1:SYS)
. S IENS="" F S IENS=$O(VPRC(SFN,IENS)) Q:IENS="" D Q:$L(Y)
.. S X=$G(VPRC(SFN,IENS,"CODING SYSTEM")) Q:X="" Q:NAMES'[X
.. S SFN1=$O(VPRC(SFN)),I=$O(VPRC(SFN1,""))
.. S:I Y=$G(VPRC(SFN1,I,"CODE")) ;first code for system
. I $L(Y) S Y=Y_U_$$DESC(Y)_U_$P(NAMES,U)
Q Y
;
DESC(CODE) ; -- called from CODE, to return coding system text
; Expects all the variables used in CODE()
N X,Y,LEX S Y=""
I SYS="SCT" D
. S X=$$CODE^LEXTRAN(CODE,"SCT",CDT)
. S:X>0 Y=$G(LEX("P")) ;preferred term
I SYS="RXN",$L($T(CSDATA^ETSRXN)) D
. S X=$$CSDATA^ETSRXN(CODE,"RXN",CDT,.LEX)
. S:X>0 Y=$P($G(LEX("LEX",1)),U,2)
I SYS="LNC",$L($T(GETNAME^ETSLNC)) D
. S X=$$GETNAME^ETSLNC(CODE,"C",.LEX)
. S:X>0 Y=$G(LEX("LONGNAME"))
I '$L($G(Y)) S Y=$$GET1^DIQ(FILE,IEN_",",.01)
Q Y
;
NULL(N) ; -- return null string(s) to delete property
N I,Y,QOT S N=+$G(N,1),QOT=""""""
S Y=QOT I N>1 F I=1:1:(N-1) S Y=Y_U_QOT
Q Y
;
CPT(IEN,DATE,LONG) ; -- return code^description^CPT-4 for #81 IEN
N X0,VPRX,N,I,X,Y
S IEN=+$G(IEN),DATE=$G(DATE) S:DATE<1 DATE=DT
S X0=$$CPT^ICPTCOD(IEN,DATE) I X0<0 Q ""
S Y=$P(X0,U,2,3)_"^CPT-4" ;CPT Code^Short Name
I $G(LONG) D ;CPT Description instead
. S N=$$CPTD^ICPTCOD($P(Y,U),"VPRX",,DATE)
. I N'>0!'$L($G(VPRX(1))) Q
. S X=$G(VPRX(1)),I=1
. F S I=$O(VPRX(I)) Q:I<1 Q:VPRX(I)=" " S X=X_" "_VPRX(I)
. S $P(Y,U,2)=X
Q Y
;
HLOC(X) ; -- return Hosp Loc #44 ien from location name X
N Y S Y=0
I $L($G(X)) S Y=+$O(^SC("B",X,0))
Q Y
;
COUNTY(ST,CTY) ; -- return ien^name for a STate and CounTY
N Y S Y=""
I +$G(ST),+$G(CTY) S Y=$$GET1^DIQ(5.01,(+CTY_","_+ST_","),.01)
S:$L(Y) Y=+CTY_U_Y
Q Y
;
FAC(HLOC) ; -- return facility #4 ien for HospLOC #44 ien
N X,Y S Y=""
S HLOC=+$G(HLOC) I HLOC<1 S Y=$$SITE G FACQ
S X=$$GET1^DIQ(44,HLOC,3,"I")
S:X<1 X=$$GET1^DIQ(44,HLOC,"3.5:.07","I")
S Y=$$CKFAC(X)
FACQ Q Y
;
CKFAC(IEN) ; -- validate #4 ien, return Parent if no stn#
N VPRZ S IEN=+$G(IEN)
I IEN<1 S Y=$$SITE Q Y
I $L($P($G(^DIC(4,IEN,99)),U)) Q IEN ;ok
D PARENT^XUAF4("VPRZ","`"_IEN,2) S Y=$O(VPRZ("P",0))
S:Y<1 Y=$$SITE
Q Y
;
SITE() ; -- return current site#
N Y S Y=+$$SITE^VASITE
S:Y'>0 Y=$$KSP^XUPARAM("INST")
Q Y
;
DEL1 ; -- ID Action for Delete entities, returns VPR0=data
N SEQ,VST S VPR0=""
S SEQ=+$G(FILTER("sequence")) I SEQ,$L($G(DIEN)) D
. S VPR0=$G(^XTMP("VPR-"_SEQ,DIEN,0)) Q:$L(VPR0) ;ok
. ; else get visit# from header node
. S VST=$P($G(^XTMP("VPR-"_SEQ,DIEN)),U,5) S:VST VPR0="^^"_VST
Q
;
NOQ ; -- no query
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRSDA 5505 printed Sep 23, 2025@20:22:07 Page 2
VPRSDA ;SLC/MKB -- SDA utilities ;10/25/18 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**8,10,16,20,26,28,29,30,31,33**;Sep 01, 2011;Build 8
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^DIC(4 10090
+7 ; ^SC 10040
+8 ; %DT 10003
+9 ; DILFD 2055
+10 ; DIQ 2056
+11 ; ETSLNC 6731
+12 ; ETSRXN 6758
+13 ; ICPTCOD 1995
+14 ; LEXTRAN 4912
+15 ; VASITE 10112
+16 ; XLFNAME 3065
+17 ; XUAF4 2171
+18 ; XUPARAM 2541
+19 ;
INTDATE(X) ; -- Return internal form of date X
+1 NEW %DT,Y
+2 SET %DT="TSX"
DO ^%DT
+3 QUIT Y
+4 ;
DATE(X,DTO) ; -- return FM date X as SDA Timestamp
+1 NEW D,T,Y
+2 SET X=$GET(X)
IF X'?7N.1".".7N
QUIT ""
+3 SET D=$PIECE(X,".")
SET T=$PIECE(X,".",2)
+4 ; validate date
+5 IF '$$VALID(D)
QUIT ""
+6 SET Y=(1700+$EXTRACT(D,1,3))_"-"_$EXTRACT(D,4,5)_"-"_$EXTRACT(D,6,7)
+7 ; if imprecise, add month or day of 01
+8 FOR I=2,3
IF $PIECE(Y,"-",I)="00"
SET $PIECE(Y,"-",I)="01"
+9 ;date only
IF $GET(DTO)
QUIT Y
+10 ;
+11 ; validate T = time
+12 ;for SDA
IF T=24
SET T=235959
+13 ;pad the time to 6 digits
if $LENGTH(T)<6
SET T=$EXTRACT((T_"000000"),1,6)
+14 ;invalid hours >> remove time
IF $EXTRACT(T,1,2)>23
SET T="000000"
+15 ;strip invalid minutes/seconds
IF $EXTRACT(T,3,4)>59
SET $EXTRACT(T,3,6)="0000"
+16 ;strip invalid seconds
IF $EXTRACT(T,5,6)>59
SET $EXTRACT(T,5,6)="00"
+17 SET Y=Y_"T"_$EXTRACT(T,1,2)_":"_$EXTRACT(T,3,4)_":"_$EXTRACT(T,5,6)
+18 QUIT Y
+19 ;
VALID(X) ; -- returns 1 or 0, if valid FM date
+1 NEW %DT,Y
SET %DT=""
SET X=$GET(X)
+2 ;ck date only
IF X["."
SET X=$PIECE(X,".")
+3 DO ^%DT
IF Y<1
QUIT 0
+4 ; check if out of HL7 range
+5 IF (Y<1410102)!(Y>4141015)
QUIT 0
+6 QUIT 1
+7 ;
NAMECOMP(NAME) ; -- return name as string of component pieces
+1 ; NAME -> FAMILY^GIVEN^MIDDLE^SUFFIX
+2 DO NAMECOMP^XLFNAME(.NAME)
+3 NEW I,Y
SET Y=$GET(NAME("FAMILY"))
+4 FOR I="GIVEN","MIDDLE","SUFFIX"
SET Y=Y_U_$GET(NAME(I))
+5 QUIT Y
+6 ;
CODED ; -- ck Code Table ID for internal^external format
+1 ; called from DDEG for entity VPR CODE TABLE using variables:
+2 ; FILE, FIELD, ID (read only, do NOT kill)
+3 ;ok
if $GET(ID)=""
QUIT
if $LENGTH(ID,"^")>1
QUIT
+4 NEW X,NM
SET NM=ID
+5 IF $GET(FILE)
IF $GET(FIELD)
Begin DoDot:1
+6 SET X=$$EXTERNAL^DILFD(FILE,FIELD,,ID)
+7 if X'=""
SET NM=X
End DoDot:1
+8 SET ID=ID_U_NM
+9 QUIT
+10 ;
CODE(IEN,FILE,CSYS,CDT) ; -- find CSYS code for IEN in FILE
+1 ; CSYS can be string of abbreviations to look for, in order
+2 NEW FLD,VPRC,SFN,S,SYS,NAMES,IENS,SFN1,I,X,Y
+3 SET Y=""
SET CDT=$GET(CDT)
if CDT<1
SET CDT=DT
+4 SET FLD=$$FLDNUM^DILFD(FILE,"CODING SYSTEM")
if 'FLD
QUIT ""
+5 DO GETS^DIQ(FILE,IEN_",",FLD_"*","NR","VPRC")
+6 ;Sub-file# = Coding System multiple
SET SFN=+$ORDER(VPRC(0))
if 'SFN
QUIT ""
+7 FOR S=1:1
SET SYS=$PIECE(CSYS,U,S)
if SYS=""
QUIT
Begin DoDot:1
+8 SET NAMES=$SELECT(SYS="RXN":"RxNorm^RXNORM",SYS="NDF":"NDF-RT^NDFRT^NDF",SYS="SCT":"SNOMED CT^SNOMED-CT^SCT",SYS="LNC":"LOINC^LNC",SYS="UNI":"UNII^UNI",1:SYS)
+9 SET IENS=""
FOR
SET IENS=$ORDER(VPRC(SFN,IENS))
if IENS=""
QUIT
Begin DoDot:2
+10 SET X=$GET(VPRC(SFN,IENS,"CODING SYSTEM"))
if X=""
QUIT
if NAMES'[X
QUIT
+11 SET SFN1=$ORDER(VPRC(SFN))
SET I=$ORDER(VPRC(SFN1,""))
+12 ;first code for system
if I
SET Y=$GET(VPRC(SFN1,I,"CODE"))
End DoDot:2
if $LENGTH(Y)
QUIT
+13 IF $LENGTH(Y)
SET Y=Y_U_$$DESC(Y)_U_$PIECE(NAMES,U)
End DoDot:1
if $LENGTH(Y)
QUIT
+14 QUIT Y
+15 ;
DESC(CODE) ; -- called from CODE, to return coding system text
+1 ; Expects all the variables used in CODE()
+2 NEW X,Y,LEX
SET Y=""
+3 IF SYS="SCT"
Begin DoDot:1
+4 SET X=$$CODE^LEXTRAN(CODE,"SCT",CDT)
+5 ;preferred term
if X>0
SET Y=$GET(LEX("P"))
End DoDot:1
+6 IF SYS="RXN"
IF $LENGTH($TEXT(CSDATA^ETSRXN))
Begin DoDot:1
+7 SET X=$$CSDATA^ETSRXN(CODE,"RXN",CDT,.LEX)
+8 if X>0
SET Y=$PIECE($GET(LEX("LEX",1)),U,2)
End DoDot:1
+9 IF SYS="LNC"
IF $LENGTH($TEXT(GETNAME^ETSLNC))
Begin DoDot:1
+10 SET X=$$GETNAME^ETSLNC(CODE,"C",.LEX)
+11 if X>0
SET Y=$GET(LEX("LONGNAME"))
End DoDot:1
+12 IF '$LENGTH($GET(Y))
SET Y=$$GET1^DIQ(FILE,IEN_",",.01)
+13 QUIT Y
+14 ;
NULL(N) ; -- return null string(s) to delete property
+1 NEW I,Y,QOT
SET N=+$GET(N,1)
SET QOT=""""""
+2 SET Y=QOT
IF N>1
FOR I=1:1:(N-1)
SET Y=Y_U_QOT
+3 QUIT Y
+4 ;
CPT(IEN,DATE,LONG) ; -- return code^description^CPT-4 for #81 IEN
+1 NEW X0,VPRX,N,I,X,Y
+2 SET IEN=+$GET(IEN)
SET DATE=$GET(DATE)
if DATE<1
SET DATE=DT
+3 SET X0=$$CPT^ICPTCOD(IEN,DATE)
IF X0<0
QUIT ""
+4 ;CPT Code^Short Name
SET Y=$PIECE(X0,U,2,3)_"^CPT-4"
+5 ;CPT Description instead
IF $GET(LONG)
Begin DoDot:1
+6 SET N=$$CPTD^ICPTCOD($PIECE(Y,U),"VPRX",,DATE)
+7 IF N'>0!'$LENGTH($GET(VPRX(1)))
QUIT
+8 SET X=$GET(VPRX(1))
SET I=1
+9 FOR
SET I=$ORDER(VPRX(I))
if I<1
QUIT
if VPRX(I)=" "
QUIT
SET X=X_" "_VPRX(I)
+10 SET $PIECE(Y,U,2)=X
End DoDot:1
+11 QUIT Y
+12 ;
HLOC(X) ; -- return Hosp Loc #44 ien from location name X
+1 NEW Y
SET Y=0
+2 IF $LENGTH($GET(X))
SET Y=+$ORDER(^SC("B",X,0))
+3 QUIT Y
+4 ;
COUNTY(ST,CTY) ; -- return ien^name for a STate and CounTY
+1 NEW Y
SET Y=""
+2 IF +$GET(ST)
IF +$GET(CTY)
SET Y=$$GET1^DIQ(5.01,(+CTY_","_+ST_","),.01)
+3 if $LENGTH(Y)
SET Y=+CTY_U_Y
+4 QUIT Y
+5 ;
FAC(HLOC) ; -- return facility #4 ien for HospLOC #44 ien
+1 NEW X,Y
SET Y=""
+2 SET HLOC=+$GET(HLOC)
IF HLOC<1
SET Y=$$SITE
GOTO FACQ
+3 SET X=$$GET1^DIQ(44,HLOC,3,"I")
+4 if X<1
SET X=$$GET1^DIQ(44,HLOC,"3.5:.07","I")
+5 SET Y=$$CKFAC(X)
FACQ QUIT Y
+1 ;
CKFAC(IEN) ; -- validate #4 ien, return Parent if no stn#
+1 NEW VPRZ
SET IEN=+$GET(IEN)
+2 IF IEN<1
SET Y=$$SITE
QUIT Y
+3 ;ok
IF $LENGTH($PIECE($GET(^DIC(4,IEN,99)),U))
QUIT IEN
+4 DO PARENT^XUAF4("VPRZ","`"_IEN,2)
SET Y=$ORDER(VPRZ("P",0))
+5 if Y<1
SET Y=$$SITE
+6 QUIT Y
+7 ;
SITE() ; -- return current site#
+1 NEW Y
SET Y=+$$SITE^VASITE
+2 if Y'>0
SET Y=$$KSP^XUPARAM("INST")
+3 QUIT Y
+4 ;
DEL1 ; -- ID Action for Delete entities, returns VPR0=data
+1 NEW SEQ,VST
SET VPR0=""
+2 SET SEQ=+$GET(FILTER("sequence"))
IF SEQ
IF $LENGTH($GET(DIEN))
Begin DoDot:1
+3 ;ok
SET VPR0=$GET(^XTMP("VPR-"_SEQ,DIEN,0))
if $LENGTH(VPR0)
QUIT
+4 ; else get visit# from header node
+5 SET VST=$PIECE($GET(^XTMP("VPR-"_SEQ,DIEN)),U,5)
if VST
SET VPR0="^^"_VST
End DoDot:1
+6 QUIT
+7 ;
NOQ ; -- no query
+1 QUIT
