Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: VPRSDA

VPRSDA.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VHA Directive 6402, this routine should not be modified.
  1. ;
  1. ; External References DBIA#
  1. ; ------------------- -----
  1. ; ^DIC(4 10090
  1. ; ^SC 10040
  1. ; %DT 10003
  1. ; DILFD 2055
  1. ; DIQ 2056
  1. ; ETSLNC 6731
  1. ; ETSRXN 6758
  1. ; ICPTCOD 1995
  1. ; LEXTRAN 4912
  1. ; VASITE 10112
  1. ; XLFNAME 3065
  1. ; XUAF4 2171
  1. ; XUPARAM 2541
  1. ;
  1. INTDATE(X) ; -- Return internal form of date X
  1. N %DT,Y
  1. S %DT="TSX" D ^%DT
  1. Q Y
  1. ;
  1. DATE(X,DTO) ; -- return FM date X as SDA Timestamp
  1. N D,T,Y
  1. S X=$G(X) I X'?7N.1".".7N Q ""
  1. S D=$P(X,"."),T=$P(X,".",2)
  1. ; validate date
  1. I '$$VALID(D) Q ""
  1. S Y=(1700+$E(D,1,3))_"-"_$E(D,4,5)_"-"_$E(D,6,7)
  1. ; if imprecise, add month or day of 01
  1. F I=2,3 I $P(Y,"-",I)="00" S $P(Y,"-",I)="01"
  1. I $G(DTO) Q Y ;date only
  1. ;
  1. ; validate T = time
  1. I T=24 S T=235959 ;for SDA
  1. S:$L(T)<6 T=$E((T_"000000"),1,6) ;pad the time to 6 digits
  1. I $E(T,1,2)>23 S T="000000" ;invalid hours >> remove time
  1. I $E(T,3,4)>59 S $E(T,3,6)="0000" ;strip invalid minutes/seconds
  1. I $E(T,5,6)>59 S $E(T,5,6)="00" ;strip invalid seconds
  1. S Y=Y_"T"_$E(T,1,2)_":"_$E(T,3,4)_":"_$E(T,5,6)
  1. Q Y
  1. ;
  1. VALID(X) ; -- returns 1 or 0, if valid FM date
  1. N %DT,Y S %DT="",X=$G(X)
  1. I X["." S X=$P(X,".") ;ck date only
  1. D ^%DT I Y<1 Q 0
  1. ; check if out of HL7 range
  1. I (Y<1410102)!(Y>4141015) Q 0
  1. Q 1
  1. ;
  1. NAMECOMP(NAME) ; -- return name as string of component pieces
  1. ; NAME -> FAMILY^GIVEN^MIDDLE^SUFFIX
  1. D NAMECOMP^XLFNAME(.NAME)
  1. N I,Y S Y=$G(NAME("FAMILY"))
  1. F I="GIVEN","MIDDLE","SUFFIX" S Y=Y_U_$G(NAME(I))
  1. Q Y
  1. ;
  1. CODED ; -- ck Code Table ID for internal^external format
  1. ; called from DDEG for entity VPR CODE TABLE using variables:
  1. ; FILE, FIELD, ID (read only, do NOT kill)
  1. Q:$G(ID)="" Q:$L(ID,"^")>1 ;ok
  1. N X,NM S NM=ID
  1. I $G(FILE),$G(FIELD) D
  1. . S X=$$EXTERNAL^DILFD(FILE,FIELD,,ID)
  1. . S:X'="" NM=X
  1. S ID=ID_U_NM
  1. Q
  1. ;
  1. CODE(IEN,FILE,CSYS,CDT) ; -- find CSYS code for IEN in FILE
  1. ; CSYS can be string of abbreviations to look for, in order
  1. N FLD,VPRC,SFN,S,SYS,NAMES,IENS,SFN1,I,X,Y
  1. S Y="",CDT=$G(CDT) S:CDT<1 CDT=DT
  1. S FLD=$$FLDNUM^DILFD(FILE,"CODING SYSTEM") Q:'FLD ""
  1. D GETS^DIQ(FILE,IEN_",",FLD_"*","NR","VPRC")
  1. S SFN=+$O(VPRC(0)) Q:'SFN "" ;Sub-file# = Coding System multiple
  1. F S=1:1 S SYS=$P(CSYS,U,S) Q:SYS="" D Q:$L(Y)
  1. . 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)
  1. . S IENS="" F S IENS=$O(VPRC(SFN,IENS)) Q:IENS="" D Q:$L(Y)
  1. .. S X=$G(VPRC(SFN,IENS,"CODING SYSTEM")) Q:X="" Q:NAMES'[X
  1. .. S SFN1=$O(VPRC(SFN)),I=$O(VPRC(SFN1,""))
  1. .. S:I Y=$G(VPRC(SFN1,I,"CODE")) ;first code for system
  1. . I $L(Y) S Y=Y_U_$$DESC(Y)_U_$P(NAMES,U)
  1. Q Y
  1. ;
  1. DESC(CODE) ; -- called from CODE, to return coding system text
  1. ; Expects all the variables used in CODE()
  1. N X,Y,LEX S Y=""
  1. I SYS="SCT" D
  1. . S X=$$CODE^LEXTRAN(CODE,"SCT",CDT)
  1. . S:X>0 Y=$G(LEX("P")) ;preferred term
  1. I SYS="RXN",$L($T(CSDATA^ETSRXN)) D
  1. . S X=$$CSDATA^ETSRXN(CODE,"RXN",CDT,.LEX)
  1. . S:X>0 Y=$P($G(LEX("LEX",1)),U,2)
  1. I SYS="LNC",$L($T(GETNAME^ETSLNC)) D
  1. . S X=$$GETNAME^ETSLNC(CODE,"C",.LEX)
  1. . S:X>0 Y=$G(LEX("LONGNAME"))
  1. I '$L($G(Y)) S Y=$$GET1^DIQ(FILE,IEN_",",.01)
  1. Q Y
  1. ;
  1. NULL(N) ; -- return null string(s) to delete property
  1. N I,Y,QOT S N=+$G(N,1),QOT=""""""
  1. S Y=QOT I N>1 F I=1:1:(N-1) S Y=Y_U_QOT
  1. Q Y
  1. ;
  1. CPT(IEN,DATE,LONG) ; -- return code^description^CPT-4 for #81 IEN
  1. N X0,VPRX,N,I,X,Y
  1. S IEN=+$G(IEN),DATE=$G(DATE) S:DATE<1 DATE=DT
  1. S X0=$$CPT^ICPTCOD(IEN,DATE) I X0<0 Q ""
  1. S Y=$P(X0,U,2,3)_"^CPT-4" ;CPT Code^Short Name
  1. I $G(LONG) D ;CPT Description instead
  1. . S N=$$CPTD^ICPTCOD($P(Y,U),"VPRX",,DATE)
  1. . I N'>0!'$L($G(VPRX(1))) Q
  1. . S X=$G(VPRX(1)),I=1
  1. . F S I=$O(VPRX(I)) Q:I<1 Q:VPRX(I)=" " S X=X_" "_VPRX(I)
  1. . S $P(Y,U,2)=X
  1. Q Y
  1. ;
  1. HLOC(X) ; -- return Hosp Loc #44 ien from location name X
  1. N Y S Y=0
  1. I $L($G(X)) S Y=+$O(^SC("B",X,0))
  1. Q Y
  1. ;
  1. COUNTY(ST,CTY) ; -- return ien^name for a STate and CounTY
  1. N Y S Y=""
  1. I +$G(ST),+$G(CTY) S Y=$$GET1^DIQ(5.01,(+CTY_","_+ST_","),.01)
  1. S:$L(Y) Y=+CTY_U_Y
  1. Q Y
  1. ;
  1. FAC(HLOC) ; -- return facility #4 ien for HospLOC #44 ien
  1. N X,Y S Y=""
  1. S HLOC=+$G(HLOC) I HLOC<1 S Y=$$SITE G FACQ
  1. S X=$$GET1^DIQ(44,HLOC,3,"I")
  1. S:X<1 X=$$GET1^DIQ(44,HLOC,"3.5:.07","I")
  1. S Y=$$CKFAC(X)
  1. FACQ Q Y
  1. ;
  1. CKFAC(IEN) ; -- validate #4 ien, return Parent if no stn#
  1. N VPRZ S IEN=+$G(IEN)
  1. I IEN<1 S Y=$$SITE Q Y
  1. I $L($P($G(^DIC(4,IEN,99)),U)) Q IEN ;ok
  1. D PARENT^XUAF4("VPRZ","`"_IEN,2) S Y=$O(VPRZ("P",0))
  1. S:Y<1 Y=$$SITE
  1. Q Y
  1. ;
  1. SITE() ; -- return current site#
  1. N Y S Y=+$$SITE^VASITE
  1. S:Y'>0 Y=$$KSP^XUPARAM("INST")
  1. Q Y
  1. ;
  1. DEL1 ; -- ID Action for Delete entities, returns VPR0=data
  1. N SEQ,VST S VPR0=""
  1. S SEQ=+$G(FILTER("sequence")) I SEQ,$L($G(DIEN)) D
  1. . S VPR0=$G(^XTMP("VPR-"_SEQ,DIEN,0)) Q:$L(VPR0) ;ok
  1. . ; else get visit# from header node
  1. . S VST=$P($G(^XTMP("VPR-"_SEQ,DIEN)),U,5) S:VST VPR0="^^"_VST
  1. Q
  1. ;
  1. NOQ ; -- no query
  1. Q