- 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 Dec 13, 2024@02:44:38 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