HMPDJ04A ;ASMR/MKB - Admissions,PTF;Nov 12, 2015 16:42:22
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**2**;Sep 01, 2011;Build 28
;Per VA Directive 6402, 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
; ICDCODE 3990
; ICPTCOD 1995
; VADPT 10061
; XUAF4 2171
;
; All tags expect DFN, ID, [HMPSTART, HMPSTOP, HMPMAX, HMPTEXT]
Q
;
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^HMPUTILS("visit",DFN,ID)
S:'DATE DATE=+$G(VAIP(13,1)) S:'VST VST=$$VISIT(DFN,DATE)
S (ADM("dateTime"),ADM("stay","arrivalDateTime"))=$$JSONDT^HMPUTILS(DATE)
S:$L($P(VAIP(6),U,2)) ADM("roomBed")=$P(VAIP(6),U,2)
;DE2818, (#.105) CURRENT ADMISSION, changed ^DPT to FileMan, ICR 10035
S MVT=13,I=0 I VADMVT=$$GET1^DIQ(2,DFN_",",.105,"I") D ;if current admission,
. S ADM("current")="true",MVT=14 ; use last movement info
. S X=$$GET1^DIQ(2,DFN_",",.101,"I") S:$L(X) ADM("roomBed")=X ;(#.101) ROOM-BED, DE2818
. K HMPADMIT ;kill flag from HMPDJ0
S SPEC=$G(VAIP(MVT,6)),ADM("specialty")=$P(SPEC,U,2)
S X=$$SERV^HMPDVSIT(+SPEC),ADM("service")=X
;DE2818, changed from ^DIC(42) to FileMan, ICR 10039
S HLOC=+$$GET1^DIQ(42,+$G(VAIP(MVT,4))_",",44,"I"),FAC=$$FAC^HMPD(+HLOC) I HLOC D
. S ADM("locationUid")=$$SETUID^HMPUTILS("location",,+HLOC)
. ;DE2818 begin, changed ^SC to FileMan, ICR 10040
. S X=$$GET1^DIQ(44,HLOC_",",1) S:X]"" ADM("shortLocationName")=X ;(#1) ABBREVIATION
. S ADM("locationName")=$$GET1^DIQ(44,HLOC_",",.01) ;(#.01) NAME
. S X=$$AMIS^HMPDVSIT($$GET1^DIQ(44,HLOC_",",8,"I")) ;(#8) STOP CODE NUMBER
. ;DE2818, end
. 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^HMPUTILS(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^HMPUTILS(+$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^HMPDJ04(VST) S:'ICD ICD=$$PTF^HMPDVSIT(DFN,VAIP(12)) ;PTF>ICD
I $L(ICD)<2 S ADM("reasonName")=$G(VAIP(MVT,7))
E S ADM("reasonUid")=$$SETNCS^HMPUTILS("icd",ICD),ADM("reasonName")=$P(ICD,U,2)
S X=$$CPT^HMPDJ04(VST),ADM("typeName")=$S(X:$P($$CPT^ICPTCOD(X),U,3),1:$$CATG^HMPDVSIT("H"))
D MVT(VADMVT) ;sub-movements
; TIU(VST,.ADM) ;notes/summary
; Next 2 lines added for visits whose IDs start with an "H". JD - 1/26/15
S ADM("lastUpdateTime")=$$EN^HMPSTMP("adm") ;RHL 20150102
S ADM("stampTime")=ADM("lastUpdateTime") ; RHL 20150102
;US6734 - pre-compile metastamp
I $G(HMPMETA) D ADD^HMPMETA("visit",ADM("uid"),ADM("stampTime")) Q:HMPMETA=1 ;US6734,US11019
D ADD^HMPDJ("ADM","visit")
Q
;
TIU(VISIT,ARR) ; -- add notes to ARR("document")
N X,Y,I,HMPX,LT,NT,DA,CNT,HMPY
D FIND^DIC(8925,,.01,"QX",+$G(VISIT),,"V",,,"HMPX")
S Y="",(I,CNT)=0
F S I=$O(HMPX("DILIST",1,I)) Q:I<1 D
. S LT=$G(HMPX("DILIST","ID",I,.01)) Q:$P(LT," ")="Addendum"
. S DA=$G(HMPX("DILIST",2,I))
. S NT=$$GET1^DIQ(8925,+DA_",",".01:1501")
. S CNT=CNT+1,ARR("documents",CNT,"uid")=$$SETUID^HMPUTILS("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^HMPUTILS("user",,+IEN)
S @ARR@("providers",I,"providerName")=$$GET1^DIQ(200,IEN_",",.01) ;DE2818, changed ^VA(200) to FileMan ICR 10060
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
;DE2818, ^DGPM( - ICR 1865
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^HMPUTILS(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^HMPUTILS("user",,X)
.. S ADM("movements",CNT,"providerName")=$$GET1^DIQ(200,X_",",.01) ;DE2818, changed ^VA(200) to FileMan ICR 10060
. S X=+$P(X0,U,9)
. S:X ADM("movements",CNT,"specialty")=$$EXTERNAL^DILFD(405,.09,,X)
. ;DE2818, changed ^DIC(42) to FileMan, ICR 10039
. S HLOC=+$$GET1^DIQ(42,+$P(X0,U,6)_",",44,"I"),FAC=$$FAC^HMPD(HLOC) I HLOC D
.. S ADM("movements",CNT,"locationUid")=$$SETUID^HMPUTILS("location",,HLOC)
.. ;DE2818, changed ^SC to FileMan, ICR 10040
.. S ADM("movements",CNT,"locationName")=$$GET1^DIQ(44,HLOC_",",.01) ;(#.01) NAME
Q
;
PTFA(HMPLID) ; -- find ID in ^PXRMINDX(45) and call PTF1 if successful
;Purpose - Build ^TMP("HMPPX") from ^PXRMINDX(45,HMPISYS,"PNI",DFN)
;
;Called by - PTF^HMPDJ0 (if HMPID is set)
;
;Assumptions -
;1. ID is being passed and DFN variable exists
;2. ^TMP("HMPPX") does not already exist
;
;
;Modification History -
;US5630 (TW) 1. HMPISYS can be either "ICD" (ICD-9) or "10D" (ICD-10)
; 2. Namespaced variables and enhanced newing
;
N HMPLEN,HMPTYP,HMPID,HMPISYS,HMPTYP,HMPDX,HMPDT,HMPITEM,HMPRDT,HMPX
S HMPLEN=$L(HMPLID,";"),HMPTYP=$P(HMPLID,";",HMPLEN),HMPID=$P(HMPLID,";",1,HMPLEN-1)
; DE2818, ^PXRMINDX - ICR 4290
;Get ICD System from ^PXRMINDX Xref and loop for remaining subscripts
S HMPISYS="" F S HMPISYS=$O(^PXRMINDX(45,HMPISYS)) Q:HMPISYS="" D
. I '$D(^PXRMINDX(45,HMPISYS,"PNI",+$G(DFN),HMPTYP)) Q
. S HMPDX="" F S HMPDX=$O(^PXRMINDX(45,HMPISYS,"PNI",+$G(DFN),HMPTYP,HMPDX)) Q:HMPDX="" D
.. S HMPDT=0 F S HMPDT=$O(^PXRMINDX(45,HMPISYS,"PNI",+$G(DFN),HMPTYP,HMPDX,HMPDT)) Q:HMPDT="" D
... S HMPITEM="" F S HMPITEM=$O(^PXRMINDX(45,HMPISYS,"PNI",+$G(DFN),HMPTYP,HMPDX,HMPDT,HMPITEM)) Q:HMPITEM="" D
.... I HMPITEM'[HMPID Q
.... S HMPRDT=9999999-HMPDT
.... S HMPX=HMPDX_U_HMPDT_U_HMPISYS
.... S ^TMP("HMPPX",$J,HMPRDT,HMPLID)=HMPX
Q:'$D(^TMP("HMPPX",$J))
D PTF1
K ^TMP("HMPPX",$J)
Q
;
PTF1 ; Set PTF data into PTF array
;Purpose - Get data from ^TMP("HMPPX"), lookup addl PTF, set into PTF array and ^TMP
;
;Called by - PTFA^HMPDJ04A if HMPID is set, otherwise PTF^HMPDJ0
;
;Assumptions -
;1. HMPLID (local ID) is being passed and DFN,HMPRDT variables exist
;2. ^TMP("HMPPX",$J,HMPRDT,ID)=DxCode^[Discharge]Date exists
;
;Modification History -
;US5630 (TW)- HMPISYS can be either "ICD9" or "10D" (ICD-10)
;
N HMPTMP,PTF,HMPP,HMPTYP,HMPDIS,VAIN,HMPADM,VAINDT,HMPLOC,HMPFAC,HMPX,HMPISYS
S HMPTMP=$G(^TMP("HMPPX",$J,HMPRDT,HMPLID))
S PTF("localId")=HMPLID
S PTF("uid")=$$SETUID^HMPUTILS("ptf",DFN,HMPLID)
S HMPP=$L(HMPLID,";")
S HMPTYP=$P(HMPLID,";",HMPP)
I HMPTYP="DXLS" S PTF("principalDx")="true" ; Is this the principal dx?
I $P(HMPTYP," ")="M" Q ; Quit if movement dx
S HMPDIS=$P(HMPTMP,U,2)
I HMPDIS S VAINDT=HMPDIS-.0001
D INP^VADPT ; Get inpatient VAIN array
I '$G(VAIN(1)) Q ; Quit if not inpatient
;US5630 - TW - Extract Calculated DRG for PTF
S PTF("drg")=$$GET1^DIQ(45,+HMPLID_",",9,"")
S PTF("admissionUid")=$$SETUID^HMPUTILS("visit",DFN,"H"_VAIN(1))
S HMPADM=+$G(VAIN(7)) ; Admission date
;DE2818, changed from ^DIC(42) to FileMan, ICR 10039
S HMPLOC=+$$GET1^DIQ(42,+$G(VAIN(4))_",",44,"I") ; Get location
S:HMPADM PTF("arrivalDateTime")=$$JSONDT^HMPUTILS(HMPADM)
S:HMPDIS PTF("dischargeDateTime")=$$JSONDT^HMPUTILS(HMPDIS)
S HMPFAC=$$FAC^HMPD(HMPLOC) D:HMPFAC FACILITY^HMPUTILS(HMPFAC,"PTF")
S PTF("lastUpdateTime")=$$EN^HMPSTMP("ptf") ;RHL 20150102
S PTF("stampTime")=PTF("lastUpdateTime") ; RHL 20150102
;US5630 - TW - Check for ICD Coding System
S HMPDX=$P(HMPTMP,U)
S HMPISYS=$P(HMPTMP,U,3)
S HMPISYS=$S(HMPISYS="ICD":1,"ICP":2,"10D":30,"10P":31,1:1) ; Identify ICD coding system for correct lookup
S HMPX=$$ICDDX^ICDEX(HMPDX,"",HMPISYS)
S PTF("icdCode")=$$SETNCS^HMPUTILS("icd",$P(HMPX,U,2))
S PTF("icdName")=$P(HMPX,U,4)
;US6734 - pre-compile metastamp
I $G(HMPMETA) D ADD^HMPMETA("ptf",PTF("uid"),PTF("stampTime")) Q:HMPMETA=1 ;US6734,US11019
D ADD^HMPDJ("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)) ;DE2818, ICR 2028
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPDJ04A 9340 printed Sep 23, 2025@19:29:22 Page 2
HMPDJ04A ;ASMR/MKB - Admissions,PTF;Nov 12, 2015 16:42:22
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**2**;Sep 01, 2011;Build 28
+2 ;Per VA Directive 6402, 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 ; ICDCODE 3990
+17 ; ICPTCOD 1995
+18 ; VADPT 10061
+19 ; XUAF4 2171
+20 ;
+21 ; All tags expect DFN, ID, [HMPSTART, HMPSTOP, HMPMAX, HMPTEXT]
+22 QUIT
+23 ;
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^HMPUTILS("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^HMPUTILS(DATE)
+10 if $LENGTH($PIECE(VAIP(6),U,2))
SET ADM("roomBed")=$PIECE(VAIP(6),U,2)
+11 ;DE2818, (#.105) CURRENT ADMISSION, changed ^DPT to FileMan, ICR 10035
+12 ;if current admission,
SET MVT=13
SET I=0
IF VADMVT=$$GET1^DIQ(2,DFN_",",.105,"I")
Begin DoDot:1
+13 ; use last movement info
SET ADM("current")="true"
SET MVT=14
+14 ;(#.101) ROOM-BED, DE2818
SET X=$$GET1^DIQ(2,DFN_",",.101,"I")
if $LENGTH(X)
SET ADM("roomBed")=X
+15 ;kill flag from HMPDJ0
KILL HMPADMIT
End DoDot:1
+16 SET SPEC=$GET(VAIP(MVT,6))
SET ADM("specialty")=$PIECE(SPEC,U,2)
+17 SET X=$$SERV^HMPDVSIT(+SPEC)
SET ADM("service")=X
+18 ;DE2818, changed from ^DIC(42) to FileMan, ICR 10039
+19 SET HLOC=+$$GET1^DIQ(42,+$GET(VAIP(MVT,4))_",",44,"I")
SET FAC=$$FAC^HMPD(+HLOC)
IF HLOC
Begin DoDot:1
+20 SET ADM("locationUid")=$$SETUID^HMPUTILS("location",,+HLOC)
+21 ;DE2818 begin, changed ^SC to FileMan, ICR 10040
+22 ;(#1) ABBREVIATION
SET X=$$GET1^DIQ(44,HLOC_",",1)
if X]""
SET ADM("shortLocationName")=X
+23 ;(#.01) NAME
SET ADM("locationName")=$$GET1^DIQ(44,HLOC_",",.01)
+24 ;(#8) STOP CODE NUMBER
SET X=$$AMIS^HMPDVSIT($$GET1^DIQ(44,HLOC_",",8,"I"))
+25 ;DE2818, end
+26 if $LENGTH($GET(X))
SET ADM("stopCodeUid")="urn:va:stop-code:"_$PIECE(X,U)
SET ADM("stopCodeName")=$PIECE(X,U,2)
+27 SET ADM("summary")="${"_ADM("service")_"}:"_ADM("locationName")
End DoDot:1
+28 DO FACILITY^HMPUTILS(FAC,"ADM")
+29 SET ADM("categoryCode")="urn:va:encounter-category:AD"
SET ADM("categoryName")="Admission"
+30 SET ADM("patientClassCode")="urn:va:patient-class:IMP"
SET ADM("patientClassName")="Inpatient"
+31 IF $GET(VAIP(17))
SET ADM("stay","dischargeDateTime")=$$JSONDT^HMPUTILS(+$GET(VAIP(17,1)))
+32 ;attending
IF $GET(VAIP(18))
SET I=I+1
DO PROV("ADM",I,+VAIP(18),"A")
+33 ;primary
IF $GET(VAIP(MVT,5))
SET I=I+1
DO PROV("ADM",I,+VAIP(MVT,5),"P",1)
+34 ;PTF>ICD
SET ICD=$$POV^HMPDJ04(VST)
if 'ICD
SET ICD=$$PTF^HMPDVSIT(DFN,VAIP(12))
+35 IF $LENGTH(ICD)<2
SET ADM("reasonName")=$GET(VAIP(MVT,7))
+36 IF '$TEST
SET ADM("reasonUid")=$$SETNCS^HMPUTILS("icd",ICD)
SET ADM("reasonName")=$PIECE(ICD,U,2)
+37 SET X=$$CPT^HMPDJ04(VST)
SET ADM("typeName")=$SELECT(X:$PIECE($$CPT^ICPTCOD(X),U,3),1:$$CATG^HMPDVSIT("H"))
+38 ;sub-movements
DO MVT(VADMVT)
+39 ; TIU(VST,.ADM) ;notes/summary
+40 ; Next 2 lines added for visits whose IDs start with an "H". JD - 1/26/15
+41 ;RHL 20150102
SET ADM("lastUpdateTime")=$$EN^HMPSTMP("adm")
+42 ; RHL 20150102
SET ADM("stampTime")=ADM("lastUpdateTime")
+43 ;US6734 - pre-compile metastamp
+44 ;US6734,US11019
IF $GET(HMPMETA)
DO ADD^HMPMETA("visit",ADM("uid"),ADM("stampTime"))
if HMPMETA=1
QUIT
+45 DO ADD^HMPDJ("ADM","visit")
+46 QUIT
+47 ;
TIU(VISIT,ARR) ; -- add notes to ARR("document")
+1 NEW X,Y,I,HMPX,LT,NT,DA,CNT,HMPY
+2 DO FIND^DIC(8925,,.01,"QX",+$GET(VISIT),,"V",,,"HMPX")
+3 SET Y=""
SET (I,CNT)=0
+4 FOR
SET I=$ORDER(HMPX("DILIST",1,I))
if I<1
QUIT
Begin DoDot:1
+5 SET LT=$GET(HMPX("DILIST","ID",I,.01))
if $PIECE(LT," ")="Addendum"
QUIT
+6 SET DA=$GET(HMPX("DILIST",2,I))
+7 SET NT=$$GET1^DIQ(8925,+DA_",",".01:1501")
+8 SET CNT=CNT+1
SET ARR("documents",CNT,"uid")=$$SETUID^HMPUTILS("document",DFN,+DA)
+9 SET ARR("documents",CNT,"localTitle")=LT
+10 if $LENGTH(NT)
SET ARR("documents",CNT,"nationalTitle")=NT
End DoDot:1
+11 QUIT
+12 ;
PROV(ARR,I,IEN,ROLE,PRIM) ; -- add providers
+1 SET @ARR@("providers",I,"providerUid")=$$SETUID^HMPUTILS("user",,+IEN)
+2 ;DE2818, changed ^VA(200) to FileMan ICR 10060
SET @ARR@("providers",I,"providerName")=$$GET1^DIQ(200,IEN_",",.01)
+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 ;DE2818, ^DGPM( - ICR 1865
+3 FOR
SET DATE=$ORDER(^DGPM("APCA",DFN,CA,DATE))
if DATE<1
QUIT
SET DA=+$ORDER(^(DATE,0))
IF DA'=CA
Begin DoDot:1
+4 SET X0=$GET(^DGPM(DA,0))
SET CNT=CNT+1
+5 SET ADM("movements",CNT,"localId")=DA
+6 SET ADM("movements",CNT,"dateTime")=$$JSONDT^HMPUTILS(DATE)
+7 SET ADM("movements",CNT,"movementType")=$$EXTERNAL^DILFD(405,.02,,$PIECE(X0,U,2))
+8 SET X=+$PIECE(X0,U,19)
IF X
Begin DoDot:2
+9 SET ADM("movements",CNT,"providerUid")=$$SETUID^HMPUTILS("user",,X)
+10 ;DE2818, changed ^VA(200) to FileMan ICR 10060
SET ADM("movements",CNT,"providerName")=$$GET1^DIQ(200,X_",",.01)
End DoDot:2
+11 SET X=+$PIECE(X0,U,9)
+12 if X
SET ADM("movements",CNT,"specialty")=$$EXTERNAL^DILFD(405,.09,,X)
+13 ;DE2818, changed ^DIC(42) to FileMan, ICR 10039
+14 SET HLOC=+$$GET1^DIQ(42,+$PIECE(X0,U,6)_",",44,"I")
SET FAC=$$FAC^HMPD(HLOC)
IF HLOC
Begin DoDot:2
+15 SET ADM("movements",CNT,"locationUid")=$$SETUID^HMPUTILS("location",,HLOC)
+16 ;DE2818, changed ^SC to FileMan, ICR 10040
+17 ;(#.01) NAME
SET ADM("movements",CNT,"locationName")=$$GET1^DIQ(44,HLOC_",",.01)
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
PTFA(HMPLID) ; -- find ID in ^PXRMINDX(45) and call PTF1 if successful
+1 ;Purpose - Build ^TMP("HMPPX") from ^PXRMINDX(45,HMPISYS,"PNI",DFN)
+2 ;
+3 ;Called by - PTF^HMPDJ0 (if HMPID is set)
+4 ;
+5 ;Assumptions -
+6 ;1. ID is being passed and DFN variable exists
+7 ;2. ^TMP("HMPPX") does not already exist
+8 ;
+9 ;
+10 ;Modification History -
+11 ;US5630 (TW) 1. HMPISYS can be either "ICD" (ICD-9) or "10D" (ICD-10)
+12 ; 2. Namespaced variables and enhanced newing
+13 ;
+14 NEW HMPLEN,HMPTYP,HMPID,HMPISYS,HMPTYP,HMPDX,HMPDT,HMPITEM,HMPRDT,HMPX
+15 SET HMPLEN=$LENGTH(HMPLID,";")
SET HMPTYP=$PIECE(HMPLID,";",HMPLEN)
SET HMPID=$PIECE(HMPLID,";",1,HMPLEN-1)
+16 ; DE2818, ^PXRMINDX - ICR 4290
+17 ;Get ICD System from ^PXRMINDX Xref and loop for remaining subscripts
+18 SET HMPISYS=""
FOR
SET HMPISYS=$ORDER(^PXRMINDX(45,HMPISYS))
if HMPISYS=""
QUIT
Begin DoDot:1
+19 IF '$DATA(^PXRMINDX(45,HMPISYS,"PNI",+$GET(DFN),HMPTYP))
QUIT
+20 SET HMPDX=""
FOR
SET HMPDX=$ORDER(^PXRMINDX(45,HMPISYS,"PNI",+$GET(DFN),HMPTYP,HMPDX))
if HMPDX=""
QUIT
Begin DoDot:2
+21 SET HMPDT=0
FOR
SET HMPDT=$ORDER(^PXRMINDX(45,HMPISYS,"PNI",+$GET(DFN),HMPTYP,HMPDX,HMPDT))
if HMPDT=""
QUIT
Begin DoDot:3
+22 SET HMPITEM=""
FOR
SET HMPITEM=$ORDER(^PXRMINDX(45,HMPISYS,"PNI",+$GET(DFN),HMPTYP,HMPDX,HMPDT,HMPITEM))
if HMPITEM=""
QUIT
Begin DoDot:4
+23 IF HMPITEM'[HMPID
QUIT
+24 SET HMPRDT=9999999-HMPDT
+25 SET HMPX=HMPDX_U_HMPDT_U_HMPISYS
+26 SET ^TMP("HMPPX",$JOB,HMPRDT,HMPLID)=HMPX
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+27 if '$DATA(^TMP("HMPPX",$JOB))
QUIT
+28 DO PTF1
+29 KILL ^TMP("HMPPX",$JOB)
+30 QUIT
+31 ;
PTF1 ; Set PTF data into PTF array
+1 ;Purpose - Get data from ^TMP("HMPPX"), lookup addl PTF, set into PTF array and ^TMP
+2 ;
+3 ;Called by - PTFA^HMPDJ04A if HMPID is set, otherwise PTF^HMPDJ0
+4 ;
+5 ;Assumptions -
+6 ;1. HMPLID (local ID) is being passed and DFN,HMPRDT variables exist
+7 ;2. ^TMP("HMPPX",$J,HMPRDT,ID)=DxCode^[Discharge]Date exists
+8 ;
+9 ;Modification History -
+10 ;US5630 (TW)- HMPISYS can be either "ICD9" or "10D" (ICD-10)
+11 ;
+12 NEW HMPTMP,PTF,HMPP,HMPTYP,HMPDIS,VAIN,HMPADM,VAINDT,HMPLOC,HMPFAC,HMPX,HMPISYS
+13 SET HMPTMP=$GET(^TMP("HMPPX",$JOB,HMPRDT,HMPLID))
+14 SET PTF("localId")=HMPLID
+15 SET PTF("uid")=$$SETUID^HMPUTILS("ptf",DFN,HMPLID)
+16 SET HMPP=$LENGTH(HMPLID,";")
+17 SET HMPTYP=$PIECE(HMPLID,";",HMPP)
+18 ; Is this the principal dx?
IF HMPTYP="DXLS"
SET PTF("principalDx")="true"
+19 ; Quit if movement dx
IF $PIECE(HMPTYP," ")="M"
QUIT
+20 SET HMPDIS=$PIECE(HMPTMP,U,2)
+21 IF HMPDIS
SET VAINDT=HMPDIS-.0001
+22 ; Get inpatient VAIN array
DO INP^VADPT
+23 ; Quit if not inpatient
IF '$GET(VAIN(1))
QUIT
+24 ;US5630 - TW - Extract Calculated DRG for PTF
+25 SET PTF("drg")=$$GET1^DIQ(45,+HMPLID_",",9,"")
+26 SET PTF("admissionUid")=$$SETUID^HMPUTILS("visit",DFN,"H"_VAIN(1))
+27 ; Admission date
SET HMPADM=+$GET(VAIN(7))
+28 ;DE2818, changed from ^DIC(42) to FileMan, ICR 10039
+29 ; Get location
SET HMPLOC=+$$GET1^DIQ(42,+$GET(VAIN(4))_",",44,"I")
+30 if HMPADM
SET PTF("arrivalDateTime")=$$JSONDT^HMPUTILS(HMPADM)
+31 if HMPDIS
SET PTF("dischargeDateTime")=$$JSONDT^HMPUTILS(HMPDIS)
+32 SET HMPFAC=$$FAC^HMPD(HMPLOC)
if HMPFAC
DO FACILITY^HMPUTILS(HMPFAC,"PTF")
+33 ;RHL 20150102
SET PTF("lastUpdateTime")=$$EN^HMPSTMP("ptf")
+34 ; RHL 20150102
SET PTF("stampTime")=PTF("lastUpdateTime")
+35 ;US5630 - TW - Check for ICD Coding System
+36 SET HMPDX=$PIECE(HMPTMP,U)
+37 SET HMPISYS=$PIECE(HMPTMP,U,3)
+38 ; Identify ICD coding system for correct lookup
SET HMPISYS=$SELECT(HMPISYS="ICD":1,"ICP":2,"10D":30,"10P":31,1:1)
+39 SET HMPX=$$ICDDX^ICDEX(HMPDX,"",HMPISYS)
+40 SET PTF("icdCode")=$$SETNCS^HMPUTILS("icd",$PIECE(HMPX,U,2))
+41 SET PTF("icdName")=$PIECE(HMPX,U,4)
+42 ;US6734 - pre-compile metastamp
+43 ;US6734,US11019
IF $GET(HMPMETA)
DO ADD^HMPMETA("ptf",PTF("uid"),PTF("stampTime"))
if HMPMETA=1
QUIT
+44 DO ADD^HMPDJ("PTF","ptf")
+45 QUIT
+46 ;
VISIT(DFN,DATE) ; -- Return visit# for admission
+1 NEW X,Y
+2 SET X=9999999-$PIECE(DATE,".")_"."_$PIECE(DATE,".",2)
+3 ;DE2818, ICR 2028
SET Y=+$ORDER(^AUPNVSIT("AAH",DFN,X,0))
+4 QUIT Y
