VPRDJ04A ;SLC/MKB -- Admissions,PTF ;7/25/13
;;1.0;VIRTUAL PATIENT RECORD;**2,5**;Sep 01, 2011;Build 21
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^AUPNVSIT 2028
; ^DGPM 1865
; ^DIC(42 10039
; ^DPT 10035
; ^SC 10040
; ^VA(200 10060
; DGPTFAPI 3157
; DIC 2051
; DILFD 2055
; DIQ 2056
; ICDEX 5747
; ICPTCOD 1995
; VADPT 10061
; XUAF4 2171
;
; All tags expect DFN, ID, [VPRSTART, VPRSTOP, VPRMAX, VPRTEXT]
;
ADM(ID,DATE) ; -- admission [from VSIT1]
N ADM,VADMVT,VAIP,VAERR,MVT,SPEC,HLOC,FAC,ICD,I
S ID=$G(ID),DATE=+$G(DATE) Q:ID="" ;Q:DATE<1
I ID S VAIP("D")=DATE,VST=+ID
I ID?1"H"1.N S VAIP("E")=+$E(ID,2,99),VST=0
D IN5^VADPT Q:'$G(VAIP(1)) ;deleted
S VADMVT=+$G(VAIP(13)),ID="H"_VADMVT
S ADM("localId")=ID,ADM("uid")=$$SETUID^VPRUTILS("visit",DFN,ID)
S:'DATE DATE=+$G(VAIP(13,1)) S:'VST VST=$$VISIT(DFN,DATE)
S (ADM("dateTime"),ADM("stay","arrivalDateTime"))=$$JSONDT^VPRUTILS(DATE)
S:$L($P(VAIP(6),U,2)) ADM("roomBed")=$P(VAIP(6),U,2)
S MVT=13,I=0 I VADMVT=$G(^DPT(DFN,.105)) D ;if current admission,
. S ADM("current")="true",MVT=14 ; use last movement info
. S X=$G(^DPT(DFN,.101)) S:$L(X) ADM("roomBed")=X
. K VPRADMIT ;kill flag from VPRDJ0
S SPEC=$G(VAIP(MVT,6)),ADM("specialty")=$P(SPEC,U,2)
S X=$$SERV^VPRDVSIT(+SPEC),ADM("service")=X
S HLOC=+$G(^DIC(42,+$G(VAIP(MVT,4)),44)),FAC=$$FAC^VPRD(+HLOC) I HLOC D
. S ADM("locationUid")=$$SETUID^VPRUTILS("location",,+HLOC)
. S ADM("locationName")=$P($G(^SC(HLOC,0)),U)
. S X=$$AMIS^VPRDVSIT($P($G(^SC(HLOC,0)),U,7))
. S:$L($G(X)) ADM("stopCodeUid")="urn:va:stop-code:"_$P(X,U),ADM("stopCodeName")=$P(X,U,2)
. S ADM("summary")="${"_ADM("service")_"}:"_ADM("locationName")
D FACILITY^VPRUTILS(FAC,"ADM")
S ADM("categoryCode")="urn:va:encounter-category:AD",ADM("categoryName")="Admission"
S ADM("patientClassCode")="urn:va:patient-class:IMP",ADM("patientClassName")="Inpatient"
I $G(VAIP(17)) S ADM("stay","dischargeDateTime")=$$JSONDT^VPRUTILS(+$G(VAIP(17,1)))
I $G(VAIP(18)) S I=I+1 D PROV("ADM",I,+VAIP(18),"A") ;attending
I $G(VAIP(MVT,5)) S I=I+1 D PROV("ADM",I,+VAIP(MVT,5),"P",1) ;primary
S ICD=$$POV^VPRDVSIT(VST,DATE) S:'ICD ICD=$$PTF^VPRDVSIT(DFN,VAIP(12),DATE) ;PTF>ICD
I $L(ICD)<3 S ADM("reasonName")=$G(VAIP(MVT,7))
E D
. N SYS S SYS=$P(ICD,U,3),SYS=$$LOW^XLFSTR(SYS)
. S ADM("reasonUid")=$$SETNCS^VPRUTILS(SYS,ICD),ADM("reasonName")=$P(ICD,U,2)
S X=$$CPT^VPRDVSIT(VST),ADM("typeName")=$S(X:$P($$CPT^ICPTCOD(X),U,3),1:$$CATG^VPRDVSIT("H"))
D MVT(VADMVT) ;sub-movements
D TIU(VST,.ADM) ;notes/summary
D ADD^VPRDJ("ADM","visit")
Q
;
TIU(VISIT,ARR) ; -- add notes to ARR("document")
N X,Y,I,SCR,VPRX,LT,NT,DA,CNT,VPRY
S SCR="I $P(^(0),U,5)>6,$P(^(0),U,5)<14"
D FIND^DIC(8925,,.01,"QX",+$G(VISIT),,"V",SCR,,"VPRX")
S Y="",(I,CNT)=0
F S I=$O(VPRX("DILIST",1,I)) Q:I<1 D
. S LT=$G(VPRX("DILIST","ID",I,.01)) Q:$P(LT," ")="Addendum"
. S DA=$G(VPRX("DILIST",2,I))
. S NT=$$GET1^DIQ(8925,+DA_",",".01:1501")
. S CNT=CNT+1,ARR("documents",CNT,"uid")=$$SETUID^VPRUTILS("document",DFN,+DA)
. S ARR("documents",CNT,"localTitle")=LT
. S:$L(NT) ARR("documents",CNT,"nationalTitle")=NT
Q
;
PROV(ARR,I,IEN,ROLE,PRIM) ; -- add providers
S @ARR@("providers",I,"providerUid")=$$SETUID^VPRUTILS("user",,+IEN)
S @ARR@("providers",I,"providerName")=$P($G(^VA(200,+IEN,0)),U)
S @ARR@("providers",I,"role")=ROLE
S:$G(PRIM) @ARR@("providers",I,"primary")="true"
Q
;
MVT(CA) ; -- add movements to ADM("movement",i,"attribute")
N DATE,DA,CNT,X S (DATE,CNT)=0
F S DATE=$O(^DGPM("APCA",DFN,CA,DATE)) Q:DATE<1 S DA=+$O(^(DATE,0)) I DA'=CA D
. S X0=$G(^DGPM(DA,0)),CNT=CNT+1
. S ADM("movements",CNT,"localId")=DA
. S ADM("movements",CNT,"dateTime")=$$JSONDT^VPRUTILS(DATE)
. S ADM("movements",CNT,"movementType")=$$EXTERNAL^DILFD(405,.02,,$P(X0,U,2))
. S X=+$P(X0,U,19) I X D
.. S ADM("movements",CNT,"providerUid")=$$SETUID^VPRUTILS("user",,X)
.. S ADM("movements",CNT,"providerName")=$P($G(^VA(200,X,0)),U)
. S X=+$P(X0,U,9)
. S:X ADM("movements",CNT,"specialty")=$$EXTERNAL^DILFD(405,.09,,X)
. S HLOC=+$G(^DIC(42,+$P(X0,U,6),44)),FAC=$$FAC^VPRD(HLOC) I HLOC D
.. S ADM("movements",CNT,"locationUid")=$$SETUID^VPRUTILS("location",,HLOC)
.. S ADM("movements",CNT,"locationName")=$P($G(^SC(HLOC,0)),U)
Q
;
PTFA(ID) ; -- find ID in ^TMP("VPRPX",$J), fall thru to PX1 if successful
N IDT S (IDT,VPRIDT)=0
F S IDT=$O(^TMP("VPRPX",$J,IDT)) Q:IDT<1 I $D(^(IDT,ID)) S VPRIDT=IDT Q
Q:VPRIDT<1 ;not found
PTF1 ; -- PTF where ID=iens;TYPE
; Expects ^TMP("VPRPX",$J,VPRIDT,ID)=ITM^[DISCHARGE]DATE^SYS
N TMP,PTF,ADM,DIS,VAIN,VAINDT,HLOC,FAC,X,Y,VISIT,X0
; PTF^DGPTPXRM(+ID,.VPRF)
S TMP=$G(^TMP("VPRPX",$J,VPRIDT,ID))
;
S PTF("localId")=ID,PTF("uid")=$$SETUID^VPRUTILS("ptf",DFN,ID)
S P=$L(ID,";"),TYPE=$P(ID,";",P) S:TYPE="DXLS" PTF("principalDx")="true"
S X=$$ICDDX^ICDEX($P(TMP,U),$P(TMP,U,2),,"E")
S Y=$$LOW^XLFSTR($$SAB^ICDEX($P(X,U,20))) ;coding system
S PTF("icdCode")=$$SETNCS^VPRUTILS(Y,$P(X,U,2)),PTF("icdName")=$P(X,U,4)
S DIS=$P(TMP,U,2) S:DIS VAINDT=DIS-.0001 D INP^VADPT
S ADM=+$G(VAIN(7)),HLOC=+$G(^DIC(42,+$G(VAIN(4)),44))
S:ADM PTF("arrivalDateTime")=$$JSONDT^VPRUTILS(ADM)
S:DIS PTF("dischargeDateTime")=$$JSONDT^VPRUTILS(DIS)
S FAC=$$FAC^VPRD(HLOC)
S VISIT=+$$VISIT(DFN,ADM) I VISIT D
. S PTF("encounterUid")=$$SETUID^VPRUTILS("visit",DFN,VISIT)
. S PTF("encounterName")=$$NAME^VPRDJ04(VISIT) Q:FAC
. S X0=$G(^AUPNVSIT(+VISIT,0)),FAC=+$P(X0,U,6)
. S:FAC X=$$STA^XUAF4(FAC)_U_$P($$NS^XUAF4(FAC),U)
. S:'FAC X=$$FAC^VPRD(+$P(X0,U,22)) ;location
D:FAC FACILITY^VPRUTILS(FAC,"PTF")
D ADD^VPRDJ("PTF","ptf")
Q
;
VISIT(DFN,DATE) ; -- Return visit# for admission
N X,Y
S X=9999999-$P(DATE,".")_"."_$P(DATE,".",2)
S Y=+$O(^AUPNVSIT("AAH",DFN,X,0))
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDJ04A 6339 printed Apr 09, 2024@21:47:58 Page 2
VPRDJ04A ;SLC/MKB -- Admissions,PTF ;7/25/13
+1 ;;1.0;VIRTUAL PATIENT RECORD;**2,5**;Sep 01, 2011;Build 21
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^AUPNVSIT 2028
+7 ; ^DGPM 1865
+8 ; ^DIC(42 10039
+9 ; ^DPT 10035
+10 ; ^SC 10040
+11 ; ^VA(200 10060
+12 ; DGPTFAPI 3157
+13 ; DIC 2051
+14 ; DILFD 2055
+15 ; DIQ 2056
+16 ; ICDEX 5747
+17 ; ICPTCOD 1995
+18 ; VADPT 10061
+19 ; XUAF4 2171
+20 ;
+21 ; All tags expect DFN, ID, [VPRSTART, VPRSTOP, VPRMAX, VPRTEXT]
+22 ;
ADM(ID,DATE) ; -- admission [from VSIT1]
+1 NEW ADM,VADMVT,VAIP,VAERR,MVT,SPEC,HLOC,FAC,ICD,I
+2 ;Q:DATE<1
SET ID=$GET(ID)
SET DATE=+$GET(DATE)
if ID=""
QUIT
+3 IF ID
SET VAIP("D")=DATE
SET VST=+ID
+4 IF ID?1"H"1.N
SET VAIP("E")=+$EXTRACT(ID,2,99)
SET VST=0
+5 ;deleted
DO IN5^VADPT
if '$GET(VAIP(1))
QUIT
+6 SET VADMVT=+$GET(VAIP(13))
SET ID="H"_VADMVT
+7 SET ADM("localId")=ID
SET ADM("uid")=$$SETUID^VPRUTILS("visit",DFN,ID)
+8 if 'DATE
SET DATE=+$GET(VAIP(13,1))
if 'VST
SET VST=$$VISIT(DFN,DATE)
+9 SET (ADM("dateTime"),ADM("stay","arrivalDateTime"))=$$JSONDT^VPRUTILS(DATE)
+10 if $LENGTH($PIECE(VAIP(6),U,2))
SET ADM("roomBed")=$PIECE(VAIP(6),U,2)
+11 ;if current admission,
SET MVT=13
SET I=0
IF VADMVT=$GET(^DPT(DFN,.105))
Begin DoDot:1
+12 ; use last movement info
SET ADM("current")="true"
SET MVT=14
+13 SET X=$GET(^DPT(DFN,.101))
if $LENGTH(X)
SET ADM("roomBed")=X
+14 ;kill flag from VPRDJ0
KILL VPRADMIT
End DoDot:1
+15 SET SPEC=$GET(VAIP(MVT,6))
SET ADM("specialty")=$PIECE(SPEC,U,2)
+16 SET X=$$SERV^VPRDVSIT(+SPEC)
SET ADM("service")=X
+17 SET HLOC=+$GET(^DIC(42,+$GET(VAIP(MVT,4)),44))
SET FAC=$$FAC^VPRD(+HLOC)
IF HLOC
Begin DoDot:1
+18 SET ADM("locationUid")=$$SETUID^VPRUTILS("location",,+HLOC)
+19 SET ADM("locationName")=$PIECE($GET(^SC(HLOC,0)),U)
+20 SET X=$$AMIS^VPRDVSIT($PIECE($GET(^SC(HLOC,0)),U,7))
+21 if $LENGTH($GET(X))
SET ADM("stopCodeUid")="urn:va:stop-code:"_$PIECE(X,U)
SET ADM("stopCodeName")=$PIECE(X,U,2)
+22 SET ADM("summary")="${"_ADM("service")_"}:"_ADM("locationName")
End DoDot:1
+23 DO FACILITY^VPRUTILS(FAC,"ADM")
+24 SET ADM("categoryCode")="urn:va:encounter-category:AD"
SET ADM("categoryName")="Admission"
+25 SET ADM("patientClassCode")="urn:va:patient-class:IMP"
SET ADM("patientClassName")="Inpatient"
+26 IF $GET(VAIP(17))
SET ADM("stay","dischargeDateTime")=$$JSONDT^VPRUTILS(+$GET(VAIP(17,1)))
+27 ;attending
IF $GET(VAIP(18))
SET I=I+1
DO PROV("ADM",I,+VAIP(18),"A")
+28 ;primary
IF $GET(VAIP(MVT,5))
SET I=I+1
DO PROV("ADM",I,+VAIP(MVT,5),"P",1)
+29 ;PTF>ICD
SET ICD=$$POV^VPRDVSIT(VST,DATE)
if 'ICD
SET ICD=$$PTF^VPRDVSIT(DFN,VAIP(12),DATE)
+30 IF $LENGTH(ICD)<3
SET ADM("reasonName")=$GET(VAIP(MVT,7))
+31 IF '$TEST
Begin DoDot:1
+32 NEW SYS
SET SYS=$PIECE(ICD,U,3)
SET SYS=$$LOW^XLFSTR(SYS)
+33 SET ADM("reasonUid")=$$SETNCS^VPRUTILS(SYS,ICD)
SET ADM("reasonName")=$PIECE(ICD,U,2)
End DoDot:1
+34 SET X=$$CPT^VPRDVSIT(VST)
SET ADM("typeName")=$SELECT(X:$PIECE($$CPT^ICPTCOD(X),U,3),1:$$CATG^VPRDVSIT("H"))
+35 ;sub-movements
DO MVT(VADMVT)
+36 ;notes/summary
DO TIU(VST,.ADM)
+37 DO ADD^VPRDJ("ADM","visit")
+38 QUIT
+39 ;
TIU(VISIT,ARR) ; -- add notes to ARR("document")
+1 NEW X,Y,I,SCR,VPRX,LT,NT,DA,CNT,VPRY
+2 SET SCR="I $P(^(0),U,5)>6,$P(^(0),U,5)<14"
+3 DO FIND^DIC(8925,,.01,"QX",+$GET(VISIT),,"V",SCR,,"VPRX")
+4 SET Y=""
SET (I,CNT)=0
+5 FOR
SET I=$ORDER(VPRX("DILIST",1,I))
if I<1
QUIT
Begin DoDot:1
+6 SET LT=$GET(VPRX("DILIST","ID",I,.01))
if $PIECE(LT," ")="Addendum"
QUIT
+7 SET DA=$GET(VPRX("DILIST",2,I))
+8 SET NT=$$GET1^DIQ(8925,+DA_",",".01:1501")
+9 SET CNT=CNT+1
SET ARR("documents",CNT,"uid")=$$SETUID^VPRUTILS("document",DFN,+DA)
+10 SET ARR("documents",CNT,"localTitle")=LT
+11 if $LENGTH(NT)
SET ARR("documents",CNT,"nationalTitle")=NT
End DoDot:1
+12 QUIT
+13 ;
PROV(ARR,I,IEN,ROLE,PRIM) ; -- add providers
+1 SET @ARR@("providers",I,"providerUid")=$$SETUID^VPRUTILS("user",,+IEN)
+2 SET @ARR@("providers",I,"providerName")=$PIECE($GET(^VA(200,+IEN,0)),U)
+3 SET @ARR@("providers",I,"role")=ROLE
+4 if $GET(PRIM)
SET @ARR@("providers",I,"primary")="true"
+5 QUIT
+6 ;
MVT(CA) ; -- add movements to ADM("movement",i,"attribute")
+1 NEW DATE,DA,CNT,X
SET (DATE,CNT)=0
+2 FOR
SET DATE=$ORDER(^DGPM("APCA",DFN,CA,DATE))
if DATE<1
QUIT
SET DA=+$ORDER(^(DATE,0))
IF DA'=CA
Begin DoDot:1
+3 SET X0=$GET(^DGPM(DA,0))
SET CNT=CNT+1
+4 SET ADM("movements",CNT,"localId")=DA
+5 SET ADM("movements",CNT,"dateTime")=$$JSONDT^VPRUTILS(DATE)
+6 SET ADM("movements",CNT,"movementType")=$$EXTERNAL^DILFD(405,.02,,$PIECE(X0,U,2))
+7 SET X=+$PIECE(X0,U,19)
IF X
Begin DoDot:2
+8 SET ADM("movements",CNT,"providerUid")=$$SETUID^VPRUTILS("user",,X)
+9 SET ADM("movements",CNT,"providerName")=$PIECE($GET(^VA(200,X,0)),U)
End DoDot:2
+10 SET X=+$PIECE(X0,U,9)
+11 if X
SET ADM("movements",CNT,"specialty")=$$EXTERNAL^DILFD(405,.09,,X)
+12 SET HLOC=+$GET(^DIC(42,+$PIECE(X0,U,6),44))
SET FAC=$$FAC^VPRD(HLOC)
IF HLOC
Begin DoDot:2
+13 SET ADM("movements",CNT,"locationUid")=$$SETUID^VPRUTILS("location",,HLOC)
+14 SET ADM("movements",CNT,"locationName")=$PIECE($GET(^SC(HLOC,0)),U)
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
PTFA(ID) ; -- find ID in ^TMP("VPRPX",$J), fall thru to PX1 if successful
+1 NEW IDT
SET (IDT,VPRIDT)=0
+2 FOR
SET IDT=$ORDER(^TMP("VPRPX",$JOB,IDT))
if IDT<1
QUIT
IF $DATA(^(IDT,ID))
SET VPRIDT=IDT
QUIT
+3 ;not found
if VPRIDT<1
QUIT
PTF1 ; -- PTF where ID=iens;TYPE
+1 ; Expects ^TMP("VPRPX",$J,VPRIDT,ID)=ITM^[DISCHARGE]DATE^SYS
+2 NEW TMP,PTF,ADM,DIS,VAIN,VAINDT,HLOC,FAC,X,Y,VISIT,X0
+3 ; PTF^DGPTPXRM(+ID,.VPRF)
+4 SET TMP=$GET(^TMP("VPRPX",$JOB,VPRIDT,ID))
+5 ;
+6 SET PTF("localId")=ID
SET PTF("uid")=$$SETUID^VPRUTILS("ptf",DFN,ID)
+7 SET P=$LENGTH(ID,";")
SET TYPE=$PIECE(ID,";",P)
if TYPE="DXLS"
SET PTF("principalDx")="true"
+8 SET X=$$ICDDX^ICDEX($PIECE(TMP,U),$PIECE(TMP,U,2),,"E")
+9 ;coding system
SET Y=$$LOW^XLFSTR($$SAB^ICDEX($PIECE(X,U,20)))
+10 SET PTF("icdCode")=$$SETNCS^VPRUTILS(Y,$PIECE(X,U,2))
SET PTF("icdName")=$PIECE(X,U,4)
+11 SET DIS=$PIECE(TMP,U,2)
if DIS
SET VAINDT=DIS-.0001
DO INP^VADPT
+12 SET ADM=+$GET(VAIN(7))
SET HLOC=+$GET(^DIC(42,+$GET(VAIN(4)),44))
+13 if ADM
SET PTF("arrivalDateTime")=$$JSONDT^VPRUTILS(ADM)
+14 if DIS
SET PTF("dischargeDateTime")=$$JSONDT^VPRUTILS(DIS)
+15 SET FAC=$$FAC^VPRD(HLOC)
+16 SET VISIT=+$$VISIT(DFN,ADM)
IF VISIT
Begin DoDot:1
+17 SET PTF("encounterUid")=$$SETUID^VPRUTILS("visit",DFN,VISIT)
+18 SET PTF("encounterName")=$$NAME^VPRDJ04(VISIT)
if FAC
QUIT
+19 SET X0=$GET(^AUPNVSIT(+VISIT,0))
SET FAC=+$PIECE(X0,U,6)
+20 if FAC
SET X=$$STA^XUAF4(FAC)_U_$PIECE($$NS^XUAF4(FAC),U)
+21 ;location
if 'FAC
SET X=$$FAC^VPRD(+$PIECE(X0,U,22))
End DoDot:1
+22 if FAC
DO FACILITY^VPRUTILS(FAC,"PTF")
+23 DO ADD^VPRDJ("PTF","ptf")
+24 QUIT
+25 ;
VISIT(DFN,DATE) ; -- Return visit# for admission
+1 NEW X,Y
+2 SET X=9999999-$PIECE(DATE,".")_"."_$PIECE(DATE,".",2)
+3 SET Y=+$ORDER(^AUPNVSIT("AAH",DFN,X,0))
+4 QUIT Y
