- 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 Jan 18, 2025@03:46:52 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