VPRSDAV ;SLC/MKB -- SDA Visit utilities ;10/25/18 15:29
;;1.0;VIRTUAL PATIENT RECORD;**20,26,27,28,29,30**;Sep 01, 2011;Build 9
;;Per VHA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^AUPNVSIT 2028
; ^DDE 7014
; ^DGPM 1865
; ^DIC(42 10039
; ^DPT 10035
; ^EDP(230 7180
; ^SC 10040
; ^SCE("AVSIT" 2045
; ^SRF 5675
; DIQ 2056
; PXAPI, ^TMP("PXKENC",$J 1894
; PXPXRM 4250
; SDOE 2546
; VADPT 10061
; VADPT2 325
;
QRY ; -- get visits (all types)
; Query called from GET^DDE, returns DLIST(#)=ien
; Expects context variables DFN, DSTRT, DSTOP, DMAX
;
N BEG,END,IDT,TYPE,OK,VPRN,ID
S BEG=DSTRT,END=DSTOP D IDT^VPRDVSIT
S VPRN=0,IDT=BEG,TYPE=$G(FILTER("type")) ;I,O,E
F S IDT=$O(^AUPNVSIT("AA",DFN,IDT)) Q:IDT<1!(IDT>END) D Q:VPRN'<DMAX
. S ID=0 F S ID=$O(^AUPNVSIT("AA",DFN,IDT,ID)) Q:ID<1 D
.. Q:"CS"[$P($G(^AUPNVSIT(ID,150)),U,3) ;skip stop code child visits
.. I TYPE'="" D Q:'OK ;filter
... N X S OK=0
... S X=$S($O(^EDP(230,"V",ID,0)):"E",$P($G(^AUPNVSIT(ID,0)),U,7)="H":"I",1:"O")
... I TYPE[X S OK=1 Q
.. S VPRN=VPRN+1,DLIST(VPRN)=ID
Q
;
ADMQ ; -- Admissions only (visits)
; Query for VPR ADMISSION via Test option
N IDT,BEG,END,ID,VPRN,VAINDT,VADMVT,VAERR S VPRN=0
S BEG=DSTRT,END=DSTOP D IDT^VPRDVSIT
S IDT=BEG F S IDT=$O(^AUPNVSIT("AAH",DFN,IDT)) Q:IDT<1!(IDT>END) D Q:VPRN'<DMAX
. S ID=0 F S ID=$O(^AUPNVSIT("AAH",DFN,IDT,ID)) Q:ID<1 D
.. S VAINDT=(9999999-$P(IDT,"."))_"."_$P(IDT,".",2)
.. D ADM^VADPT2 Q:'$G(VADMVT)
.. S VPRN=VPRN+1,DLIST(VPRN)=VADMVT_"~"_ID
Q
;
EDPQ ; -- Emergency Dept only (visits)
; Query for VPR EDP LOG via Test option
N IDT,BEG,END,VST,ID,VPRN
S BEG=DSTRT,END=DSTOP D IDT^VPRDVSIT
S VPRN=0,IDT=BEG
F S IDT=$O(^AUPNVSIT("AA",DFN,IDT)) Q:IDT<1!(IDT>END) D Q:VPRN'<DMAX
. S VST=0 F S VST=$O(^AUPNVSIT("AA",DFN,IDT,VST)) Q:VST<1 D
.. S ID=+$O(^EDP(230,"V",VST,0))
.. S:ID VPRN=VPRN+1,DLIST(VPRN)=ID
Q
;
VST ; -- get info for a VISIT in @VPRVST [ID Action]
S DIEN=+$G(DIEN) I DIEN<1 S DDEOUT=1 Q
N VADMVT,PX0A,EDP S PX0A=$G(^AUPNVSIT(DIEN,0))
I PX0A="" D STUB(DIEN) Q
; ck DFN (in case re-added at diff Enc#)
I $G(DFN),DFN'=$P(PX0A,U,5) D STUB(DIEN) Q
S:'$G(DFN) DFN=+$P(PX0A,U,5)
; switch to Admission entity?
I $P(PX0A,U,7)="H" D Q:$G(VADMVT)
. N VAINDT,ENT S VAINDT=+PX0A D ADM^VADPT2 Q:'$G(VADMVT)
. S ENT=+$O(^DDE("B","VPR ADMISSION",0)) I ENT<1 K VADMVT Q
. S DIENTY=ENT,DIFN=405,DIEN=VADMVT_"~"_DIEN
. D VAIP
; switch to EDP Log entity?
S EDP=+$O(^EDP(230,"V",DIEN,0)) I EDP D Q:$G(EDP)
. N ENT S EDP=+$O(^EDP(230,"V",DIEN,0))
. S ENT=+$O(^DDE("B","VPR EDP LOG",0)) I ENT<1 K EDP Q
. S DIENTY=ENT,DIFN=230,DIEN=EDP
. D EDP1
; continue with Visit
D ENCEVENT^PXAPI(DIEN)
S VPRVST=$NA(^TMP("PXKENC",$J,DIEN,"VST",DIEN))
; validate Visit, Check-Out D/T
N D S D=$P(+$G(@VPRVST@(0)),".")
I D,'$$VALID^VPRSDA(D) S $P(@VPRVST@(0),U)=$P(@VPRVST@(0),U,2) ;created
S D=$P($G(@VPRVST@(0)),U,18)
I D,'$$VALID^VPRSDA(D) S $P(@VPRVST@(0),U,18)=""
Q
;
STUB(VST) ; -- switch to stub entity for deleted visits
N ENT S ENT=+$O(^DDE("B","VPR VISIT STUB",0))
I ENT<1 S DDEOUT=1 Q
S DIENTY=ENT,DIEN=+$G(VST)
Q
;
VDEL ; -- old V file Entry Action: I ID["~" D VDEL^VPRSDAV
; Expects ID & FILE
; Returns VPRVST, VPRVFN, VPRVT & resets DTYPE for entity
S VPRVST=+$P($G(ID),"~",2),ID=+$G(ID),VPRVFN=+$G(FILE),VPRVT=DTYPE
S DTYPE=$O(^DDE("B","VPR VFILE DELETE",0))
Q
;
DEL1 ; -- ID Action for Vfile Delete entities, returns VPR0=data
N SEQ,VST S VPR0=""
S SEQ=+$G(FILTER("sequence")) I SEQ D
. S VPR0=$G(^XTMP("VPR-"_SEQ,+$G(DIEN),0)) Q:$L(VPR0)
. S VST=$P($G(^XTMP("VPR-"_SEQ,+$G(DIEN))),U,5) S:VST VPR0="^^"_VST
Q
;
EDP1 ; -- get info for single EDP Log record [VST/ID Action]
; Returns EDP0, EDP1, EDP3, VPRV, VPRVST to Entity
S EDP0=$G(^EDP(230,DIEN,0)),EDP1=$G(^(1)),EDP3=$G(^(3))
S VPRV=+$P(EDP0,U,12) I 'VPRV S DDEOUT=1 Q
D ENCEVENT^PXAPI(VPRV)
S VPRVST=$NA(^TMP("PXKENC",$J,VPRV,"VST",VPRV))
Q
;
VAIP ; -- get admission info & Visit# [ID Action]
; Expects DIEN = #405 ien ~ #9000010 ien
; Validates DFN = #2 ien
; Return VAIP(#)= array of movements
; VPRVST = Visit#
; VPRCA = Current Adm# (or 0)
; DIEN = Movement#
N VAERR,VADMVT K VAIP,VAINDT
S DIEN=$G(DIEN),DFN=+$G(DFN)
S VPRVST=+$P(DIEN,"~",2),DIEN=+DIEN
S:'DFN DFN=+$P($G(^DGPM(DIEN,0)),U,3)
I 'DFN!'DIEN S DDEOUT=1 Q
S VPRCA=+$G(^DPT(DFN,.105)) S:DIEN'=VPRCA VAIP("E")=DIEN
D IN5^VADPT
I $G(VAIP(13)),+VAIP(13)'=DIEN S DIEN=+VAIP(13),VPRVST=0
S:'VPRVST VPRVST=$$VNUM(DIEN)
I VPRVST<1 S DDEOUT=1 Q
Q
;
MVTS(ADM) ; -- get movements for an ADMission in DLIST(#)=mvt ien
; Expects DFN
N MVTS,IDX,DA,X0,PHYMVT,DATE,N,TS
S ADM=+$G(ADM) Q:ADM<1
S IDX=$NA(^DGPM("APCA",DFN,ADM)) ;get all physical mvts
F S IDX=$Q(@IDX) Q:$QS(IDX,3)'=ADM D
. S DA=$QS(IDX,5),DATE=+$G(^DGPM(DA,0))
. I DATE,DA S MVTS(DATE,DA)=""
S IDX=$NA(^DGPM("ATS",DFN,ADM)) ;add TS mvts to list
F S IDX=$Q(@IDX) Q:$QS(IDX,3)'=ADM S DA=$QS(IDX,6) D
. S X0=$G(^DGPM(DA,0)),PHYMVT=+$P(X0,U,24)
. I PHYMVT,$D(MVTS(+X0,PHYMVT)) S MVTS(+X0,PHYMVT)=DA Q
. S MVTS(+X0,DA)=DA
; create return DLIST from MVTS
S (DATE,N)=0 F S DATE=$O(MVTS(DATE)) Q:DATE<1 D
. S DA=0 F S DA=$O(MVTS(DATE,DA)) Q:DA<1 D
.. S TS=$G(MVTS(DATE,DA))
.. S N=N+1,DLIST(N)=DA_$S(TS:";"_TS,1:"")
Q
;
VNUM(ADM) ; -- find Visit# for an admission [expects DFN]
N Y,ADM0,ADMDT,HLOC,VIEN
S ADM0=$G(^DGPM(+$G(ADM),0)),ADMDT=+ADM0
S HLOC=+$G(^DIC(42,+$P(ADM0,U,6),44)),(Y,VIEN)=""
F S VIEN=$O(^AUPNVSIT("AET",DFN,ADMDT,HLOC,"P",VIEN)) Q:'VIEN D Q:Y
. I $P(^AUPNVSIT(VIEN,0),U,7)="H" S Y=VIEN
I 'Y D ;try w/o location
. N IDT S IDT=(9999999-$P(ADMDT,"."))_"."_$P(ADMDT,".",2)
. S Y=$O(^AUPNVSIT("AAH",DFN,IDT,0))
Q Y
;
WARDFAC(IEN) ; -- return #4 ien for a Ward Location
N HLOC,Y
S HLOC=+$G(^DIC(42,+$G(IEN),44)),Y=""
S:HLOC Y=$P($G(^SC(HLOC,0)),U,4)
Q Y
;
SPEC ; -- build DLIST(#)=45.7 iens using VAIP array
N I,X,SPEC
F I=13:1:17 S X=$G(VAIP(I,6)) S:X SPEC(+X)=""
S (I,X)=0 F S X=$O(SPEC(X)) Q:X<1 S I=I+1,DLIST(I)=X
Q
;
VSTR() ; -- build Visit string of Type;date.time[;location]
N Y S Y=""
I $G(VAIP(13)) S Y="H;"_+VAIP(13)
E S X=$G(@VPRVST@(0)),Y=$P(X,U,7)_";"_+X_";"_$P(X,U,22)
Q Y
;
CPT(VISIT) ; -- Return CPT code of encounter type
N DA,Y,X,X0 S Y=""
S DA=0 F S DA=$O(^TMP("PXKENC",$J,VISIT,"CPT",DA)) Q:DA<1 S X0=$G(^(DA,0)) D Q:$L(Y)
. S X=$P(X0,U) I X?1"992"2N S Y=X Q
Q Y
;
VPRV(VISIT) ; -- build DLIST(n)=#200 ien for V Providers
N I,X,R S I=0
F S I=$O(^TMP("PXKENC",$J,VISIT,"PRV",I)) Q:I<1 S X=$G(^(I,0)) D
. S R=$P(X,U,4)
. S DLIST(I)=+X_U_$S(R="P":"PRIMARY",R="S":"SECONDARY",1:"")
Q
;
HF1 ; -- get info for single HF record [ID Action]
; Expects/updates DIEN = #9000010.23 ien
; Returns VPRVST = #9000010 ien
; VPRVST0 = Visit zero node
; VPRHF array
K VPRHF D:$$ZERO^VPRENC("HF",+DIEN) VHF^PXPXRM(+DIEN,.VPRHF)
S VPRVST=+$G(VPRHF("VISIT")),VPRVST0=$G(^AUPNVSIT(+VPRVST,0))
S VPRHF=DIEN,DIEN=+DIEN
Q
;
VTO(VISIT) ; -- determine ToTime for a visit based on type
N TYPE,INPT,Y S Y="",VISIT=+$G(VISIT)
S TYPE=$P($G(@VPRVST@(0)),U,7),INPT=$P($G(@VPRVST@(150)),U,2)
; should not have any inpatient episodes here, handled via DGPM
I "H^R"[TYPE,INPT Q Y
; look for an appointment check-out time
I "A^I^O"[TYPE S Y=$$CKOUT(VISIT) I Y Q Y
; check Surgery for Time Out of OR
I TYPE="S" D I Y Q Y
. N I S I=$O(^SRF("AV",VISIT,0))
. S:I Y=$$GET1^DIQ(130,I_",",.232,"I")
; otherwise use the Visit Time
I "H^R^A^I^O^S"'[TYPE!(+$G(@VPRVST@(0))<DT) S Y=+$G(@VPRVST@(0))
Q Y
;
CKOUT(VISIT) ; -- get Check-out date from Outpt Enc or EDP Log file
N X,Y,IEN S VISIT=+$G(VISIT)
I $G(VPREDP) S Y=$$GET1^DIQ(230,VPREDP,.09,"I") Q Y
S IEN=$O(^SCE("AVSIT",VISIT,0)),(X,Y)=""
S:IEN X=$$GETOE^SDOE(IEN),Y=$P(X,U,7)
Q Y
;
LAST(DFN) ; -- return date.time of last visit (last treated)
N IDT,X,Y S Y=""
I '$G(DFN) Q ""
S IDT=(9999999-DT-.000001),X=$O(^AUPNVSIT("AA",DFN,IDT))
S:X Y=(9999999-$P(X,"."))_$S($L(X,".")>1:"."_$P(X,".",2),1:"")
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRSDAV 8686 printed Oct 16, 2024@18:46:37 Page 2
VPRSDAV ;SLC/MKB -- SDA Visit utilities ;10/25/18 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**20,26,27,28,29,30**;Sep 01, 2011;Build 9
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^AUPNVSIT 2028
+7 ; ^DDE 7014
+8 ; ^DGPM 1865
+9 ; ^DIC(42 10039
+10 ; ^DPT 10035
+11 ; ^EDP(230 7180
+12 ; ^SC 10040
+13 ; ^SCE("AVSIT" 2045
+14 ; ^SRF 5675
+15 ; DIQ 2056
+16 ; PXAPI, ^TMP("PXKENC",$J 1894
+17 ; PXPXRM 4250
+18 ; SDOE 2546
+19 ; VADPT 10061
+20 ; VADPT2 325
+21 ;
QRY ; -- get visits (all types)
+1 ; Query called from GET^DDE, returns DLIST(#)=ien
+2 ; Expects context variables DFN, DSTRT, DSTOP, DMAX
+3 ;
+4 NEW BEG,END,IDT,TYPE,OK,VPRN,ID
+5 SET BEG=DSTRT
SET END=DSTOP
DO IDT^VPRDVSIT
+6 ;I,O,E
SET VPRN=0
SET IDT=BEG
SET TYPE=$GET(FILTER("type"))
+7 FOR
SET IDT=$ORDER(^AUPNVSIT("AA",DFN,IDT))
if IDT<1!(IDT>END)
QUIT
Begin DoDot:1
+8 SET ID=0
FOR
SET ID=$ORDER(^AUPNVSIT("AA",DFN,IDT,ID))
if ID<1
QUIT
Begin DoDot:2
+9 ;skip stop code child visits
if "CS"[$PIECE($GET(^AUPNVSIT(ID,150)),U,3)
QUIT
+10 ;filter
IF TYPE'=""
Begin DoDot:3
+11 NEW X
SET OK=0
+12 SET X=$SELECT($ORDER(^EDP(230,"V",ID,0)):"E",$PIECE($GET(^AUPNVSIT(ID,0)),U,7)="H":"I",1:"O")
+13 IF TYPE[X
SET OK=1
QUIT
End DoDot:3
if 'OK
QUIT
+14 SET VPRN=VPRN+1
SET DLIST(VPRN)=ID
End DoDot:2
End DoDot:1
if VPRN'<DMAX
QUIT
+15 QUIT
+16 ;
ADMQ ; -- Admissions only (visits)
+1 ; Query for VPR ADMISSION via Test option
+2 NEW IDT,BEG,END,ID,VPRN,VAINDT,VADMVT,VAERR
SET VPRN=0
+3 SET BEG=DSTRT
SET END=DSTOP
DO IDT^VPRDVSIT
+4 SET IDT=BEG
FOR
SET IDT=$ORDER(^AUPNVSIT("AAH",DFN,IDT))
if IDT<1!(IDT>END)
QUIT
Begin DoDot:1
+5 SET ID=0
FOR
SET ID=$ORDER(^AUPNVSIT("AAH",DFN,IDT,ID))
if ID<1
QUIT
Begin DoDot:2
+6 SET VAINDT=(9999999-$PIECE(IDT,"."))_"."_$PIECE(IDT,".",2)
+7 DO ADM^VADPT2
if '$GET(VADMVT)
QUIT
+8 SET VPRN=VPRN+1
SET DLIST(VPRN)=VADMVT_"~"_ID
End DoDot:2
End DoDot:1
if VPRN'<DMAX
QUIT
+9 QUIT
+10 ;
EDPQ ; -- Emergency Dept only (visits)
+1 ; Query for VPR EDP LOG via Test option
+2 NEW IDT,BEG,END,VST,ID,VPRN
+3 SET BEG=DSTRT
SET END=DSTOP
DO IDT^VPRDVSIT
+4 SET VPRN=0
SET IDT=BEG
+5 FOR
SET IDT=$ORDER(^AUPNVSIT("AA",DFN,IDT))
if IDT<1!(IDT>END)
QUIT
Begin DoDot:1
+6 SET VST=0
FOR
SET VST=$ORDER(^AUPNVSIT("AA",DFN,IDT,VST))
if VST<1
QUIT
Begin DoDot:2
+7 SET ID=+$ORDER(^EDP(230,"V",VST,0))
+8 if ID
SET VPRN=VPRN+1
SET DLIST(VPRN)=ID
End DoDot:2
End DoDot:1
if VPRN'<DMAX
QUIT
+9 QUIT
+10 ;
VST ; -- get info for a VISIT in @VPRVST [ID Action]
+1 SET DIEN=+$GET(DIEN)
IF DIEN<1
SET DDEOUT=1
QUIT
+2 NEW VADMVT,PX0A,EDP
SET PX0A=$GET(^AUPNVSIT(DIEN,0))
+3 IF PX0A=""
DO STUB(DIEN)
QUIT
+4 ; ck DFN (in case re-added at diff Enc#)
+5 IF $GET(DFN)
IF DFN'=$PIECE(PX0A,U,5)
DO STUB(DIEN)
QUIT
+6 if '$GET(DFN)
SET DFN=+$PIECE(PX0A,U,5)
+7 ; switch to Admission entity?
+8 IF $PIECE(PX0A,U,7)="H"
Begin DoDot:1
+9 NEW VAINDT,ENT
SET VAINDT=+PX0A
DO ADM^VADPT2
if '$GET(VADMVT)
QUIT
+10 SET ENT=+$ORDER(^DDE("B","VPR ADMISSION",0))
IF ENT<1
KILL VADMVT
QUIT
+11 SET DIENTY=ENT
SET DIFN=405
SET DIEN=VADMVT_"~"_DIEN
+12 DO VAIP
End DoDot:1
if $GET(VADMVT)
QUIT
+13 ; switch to EDP Log entity?
+14 SET EDP=+$ORDER(^EDP(230,"V",DIEN,0))
IF EDP
Begin DoDot:1
+15 NEW ENT
SET EDP=+$ORDER(^EDP(230,"V",DIEN,0))
+16 SET ENT=+$ORDER(^DDE("B","VPR EDP LOG",0))
IF ENT<1
KILL EDP
QUIT
+17 SET DIENTY=ENT
SET DIFN=230
SET DIEN=EDP
+18 DO EDP1
End DoDot:1
if $GET(EDP)
QUIT
+19 ; continue with Visit
+20 DO ENCEVENT^PXAPI(DIEN)
+21 SET VPRVST=$NAME(^TMP("PXKENC",$JOB,DIEN,"VST",DIEN))
+22 ; validate Visit, Check-Out D/T
+23 NEW D
SET D=$PIECE(+$GET(@VPRVST@(0)),".")
+24 ;created
IF D
IF '$$VALID^VPRSDA(D)
SET $PIECE(@VPRVST@(0),U)=$PIECE(@VPRVST@(0),U,2)
+25 SET D=$PIECE($GET(@VPRVST@(0)),U,18)
+26 IF D
IF '$$VALID^VPRSDA(D)
SET $PIECE(@VPRVST@(0),U,18)=""
+27 QUIT
+28 ;
STUB(VST) ; -- switch to stub entity for deleted visits
+1 NEW ENT
SET ENT=+$ORDER(^DDE("B","VPR VISIT STUB",0))
+2 IF ENT<1
SET DDEOUT=1
QUIT
+3 SET DIENTY=ENT
SET DIEN=+$GET(VST)
+4 QUIT
+5 ;
VDEL ; -- old V file Entry Action: I ID["~" D VDEL^VPRSDAV
+1 ; Expects ID & FILE
+2 ; Returns VPRVST, VPRVFN, VPRVT & resets DTYPE for entity
+3 SET VPRVST=+$PIECE($GET(ID),"~",2)
SET ID=+$GET(ID)
SET VPRVFN=+$GET(FILE)
SET VPRVT=DTYPE
+4 SET DTYPE=$ORDER(^DDE("B","VPR VFILE DELETE",0))
+5 QUIT
+6 ;
DEL1 ; -- ID Action for Vfile Delete entities, returns VPR0=data
+1 NEW SEQ,VST
SET VPR0=""
+2 SET SEQ=+$GET(FILTER("sequence"))
IF SEQ
Begin DoDot:1
+3 SET VPR0=$GET(^XTMP("VPR-"_SEQ,+$GET(DIEN),0))
if $LENGTH(VPR0)
QUIT
+4 SET VST=$PIECE($GET(^XTMP("VPR-"_SEQ,+$GET(DIEN))),U,5)
if VST
SET VPR0="^^"_VST
End DoDot:1
+5 QUIT
+6 ;
EDP1 ; -- get info for single EDP Log record [VST/ID Action]
+1 ; Returns EDP0, EDP1, EDP3, VPRV, VPRVST to Entity
+2 SET EDP0=$GET(^EDP(230,DIEN,0))
SET EDP1=$GET(^(1))
SET EDP3=$GET(^(3))
+3 SET VPRV=+$PIECE(EDP0,U,12)
IF 'VPRV
SET DDEOUT=1
QUIT
+4 DO ENCEVENT^PXAPI(VPRV)
+5 SET VPRVST=$NAME(^TMP("PXKENC",$JOB,VPRV,"VST",VPRV))
+6 QUIT
+7 ;
VAIP ; -- get admission info & Visit# [ID Action]
+1 ; Expects DIEN = #405 ien ~ #9000010 ien
+2 ; Validates DFN = #2 ien
+3 ; Return VAIP(#)= array of movements
+4 ; VPRVST = Visit#
+5 ; VPRCA = Current Adm# (or 0)
+6 ; DIEN = Movement#
+7 NEW VAERR,VADMVT
KILL VAIP,VAINDT
+8 SET DIEN=$GET(DIEN)
SET DFN=+$GET(DFN)
+9 SET VPRVST=+$PIECE(DIEN,"~",2)
SET DIEN=+DIEN
+10 if 'DFN
SET DFN=+$PIECE($GET(^DGPM(DIEN,0)),U,3)
+11 IF 'DFN!'DIEN
SET DDEOUT=1
QUIT
+12 SET VPRCA=+$GET(^DPT(DFN,.105))
if DIEN'=VPRCA
SET VAIP("E")=DIEN
+13 DO IN5^VADPT
+14 IF $GET(VAIP(13))
IF +VAIP(13)'=DIEN
SET DIEN=+VAIP(13)
SET VPRVST=0
+15 if 'VPRVST
SET VPRVST=$$VNUM(DIEN)
+16 IF VPRVST<1
SET DDEOUT=1
QUIT
+17 QUIT
+18 ;
MVTS(ADM) ; -- get movements for an ADMission in DLIST(#)=mvt ien
+1 ; Expects DFN
+2 NEW MVTS,IDX,DA,X0,PHYMVT,DATE,N,TS
+3 SET ADM=+$GET(ADM)
if ADM<1
QUIT
+4 ;get all physical mvts
SET IDX=$NAME(^DGPM("APCA",DFN,ADM))
+5 FOR
SET IDX=$QUERY(@IDX)
if $QSUBSCRIPT(IDX,3)'=ADM
QUIT
Begin DoDot:1
+6 SET DA=$QSUBSCRIPT(IDX,5)
SET DATE=+$GET(^DGPM(DA,0))
+7 IF DATE
IF DA
SET MVTS(DATE,DA)=""
End DoDot:1
+8 ;add TS mvts to list
SET IDX=$NAME(^DGPM("ATS",DFN,ADM))
+9 FOR
SET IDX=$QUERY(@IDX)
if $QSUBSCRIPT(IDX,3)'=ADM
QUIT
SET DA=$QSUBSCRIPT(IDX,6)
Begin DoDot:1
+10 SET X0=$GET(^DGPM(DA,0))
SET PHYMVT=+$PIECE(X0,U,24)
+11 IF PHYMVT
IF $DATA(MVTS(+X0,PHYMVT))
SET MVTS(+X0,PHYMVT)=DA
QUIT
+12 SET MVTS(+X0,DA)=DA
End DoDot:1
+13 ; create return DLIST from MVTS
+14 SET (DATE,N)=0
FOR
SET DATE=$ORDER(MVTS(DATE))
if DATE<1
QUIT
Begin DoDot:1
+15 SET DA=0
FOR
SET DA=$ORDER(MVTS(DATE,DA))
if DA<1
QUIT
Begin DoDot:2
+16 SET TS=$GET(MVTS(DATE,DA))
+17 SET N=N+1
SET DLIST(N)=DA_$SELECT(TS:";"_TS,1:"")
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
VNUM(ADM) ; -- find Visit# for an admission [expects DFN]
+1 NEW Y,ADM0,ADMDT,HLOC,VIEN
+2 SET ADM0=$GET(^DGPM(+$GET(ADM),0))
SET ADMDT=+ADM0
+3 SET HLOC=+$GET(^DIC(42,+$PIECE(ADM0,U,6),44))
SET (Y,VIEN)=""
+4 FOR
SET VIEN=$ORDER(^AUPNVSIT("AET",DFN,ADMDT,HLOC,"P",VIEN))
if 'VIEN
QUIT
Begin DoDot:1
+5 IF $PIECE(^AUPNVSIT(VIEN,0),U,7)="H"
SET Y=VIEN
End DoDot:1
if Y
QUIT
+6 ;try w/o location
IF 'Y
Begin DoDot:1
+7 NEW IDT
SET IDT=(9999999-$PIECE(ADMDT,"."))_"."_$PIECE(ADMDT,".",2)
+8 SET Y=$ORDER(^AUPNVSIT("AAH",DFN,IDT,0))
End DoDot:1
+9 QUIT Y
+10 ;
WARDFAC(IEN) ; -- return #4 ien for a Ward Location
+1 NEW HLOC,Y
+2 SET HLOC=+$GET(^DIC(42,+$GET(IEN),44))
SET Y=""
+3 if HLOC
SET Y=$PIECE($GET(^SC(HLOC,0)),U,4)
+4 QUIT Y
+5 ;
SPEC ; -- build DLIST(#)=45.7 iens using VAIP array
+1 NEW I,X,SPEC
+2 FOR I=13:1:17
SET X=$GET(VAIP(I,6))
if X
SET SPEC(+X)=""
+3 SET (I,X)=0
FOR
SET X=$ORDER(SPEC(X))
if X<1
QUIT
SET I=I+1
SET DLIST(I)=X
+4 QUIT
+5 ;
VSTR() ; -- build Visit string of Type;date.time[;location]
+1 NEW Y
SET Y=""
+2 IF $GET(VAIP(13))
SET Y="H;"_+VAIP(13)
+3 IF '$TEST
SET X=$GET(@VPRVST@(0))
SET Y=$PIECE(X,U,7)_";"_+X_";"_$PIECE(X,U,22)
+4 QUIT Y
+5 ;
CPT(VISIT) ; -- Return CPT code of encounter type
+1 NEW DA,Y,X,X0
SET Y=""
+2 SET DA=0
FOR
SET DA=$ORDER(^TMP("PXKENC",$JOB,VISIT,"CPT",DA))
if DA<1
QUIT
SET X0=$GET(^(DA,0))
Begin DoDot:1
+3 SET X=$PIECE(X0,U)
IF X?1"992"2N
SET Y=X
QUIT
End DoDot:1
if $LENGTH(Y)
QUIT
+4 QUIT Y
+5 ;
VPRV(VISIT) ; -- build DLIST(n)=#200 ien for V Providers
+1 NEW I,X,R
SET I=0
+2 FOR
SET I=$ORDER(^TMP("PXKENC",$JOB,VISIT,"PRV",I))
if I<1
QUIT
SET X=$GET(^(I,0))
Begin DoDot:1
+3 SET R=$PIECE(X,U,4)
+4 SET DLIST(I)=+X_U_$SELECT(R="P":"PRIMARY",R="S":"SECONDARY",1:"")
End DoDot:1
+5 QUIT
+6 ;
HF1 ; -- get info for single HF record [ID Action]
+1 ; Expects/updates DIEN = #9000010.23 ien
+2 ; Returns VPRVST = #9000010 ien
+3 ; VPRVST0 = Visit zero node
+4 ; VPRHF array
+5 KILL VPRHF
if $$ZERO^VPRENC("HF",+DIEN)
DO VHF^PXPXRM(+DIEN,.VPRHF)
+6 SET VPRVST=+$GET(VPRHF("VISIT"))
SET VPRVST0=$GET(^AUPNVSIT(+VPRVST,0))
+7 SET VPRHF=DIEN
SET DIEN=+DIEN
+8 QUIT
+9 ;
VTO(VISIT) ; -- determine ToTime for a visit based on type
+1 NEW TYPE,INPT,Y
SET Y=""
SET VISIT=+$GET(VISIT)
+2 SET TYPE=$PIECE($GET(@VPRVST@(0)),U,7)
SET INPT=$PIECE($GET(@VPRVST@(150)),U,2)
+3 ; should not have any inpatient episodes here, handled via DGPM
+4 IF "H^R"[TYPE
IF INPT
QUIT Y
+5 ; look for an appointment check-out time
+6 IF "A^I^O"[TYPE
SET Y=$$CKOUT(VISIT)
IF Y
QUIT Y
+7 ; check Surgery for Time Out of OR
+8 IF TYPE="S"
Begin DoDot:1
+9 NEW I
SET I=$ORDER(^SRF("AV",VISIT,0))
+10 if I
SET Y=$$GET1^DIQ(130,I_",",.232,"I")
End DoDot:1
IF Y
QUIT Y
+11 ; otherwise use the Visit Time
+12 IF "H^R^A^I^O^S"'[TYPE!(+$GET(@VPRVST@(0))<DT)
SET Y=+$GET(@VPRVST@(0))
+13 QUIT Y
+14 ;
CKOUT(VISIT) ; -- get Check-out date from Outpt Enc or EDP Log file
+1 NEW X,Y,IEN
SET VISIT=+$GET(VISIT)
+2 IF $GET(VPREDP)
SET Y=$$GET1^DIQ(230,VPREDP,.09,"I")
QUIT Y
+3 SET IEN=$ORDER(^SCE("AVSIT",VISIT,0))
SET (X,Y)=""
+4 if IEN
SET X=$$GETOE^SDOE(IEN)
SET Y=$PIECE(X,U,7)
+5 QUIT Y
+6 ;
LAST(DFN) ; -- return date.time of last visit (last treated)
+1 NEW IDT,X,Y
SET Y=""
+2 IF '$GET(DFN)
QUIT ""
+3 SET IDT=(9999999-DT-.000001)
SET X=$ORDER(^AUPNVSIT("AA",DFN,IDT))
+4 if X
SET Y=(9999999-$PIECE(X,"."))_$SELECT($LENGTH(X,".")>1:"."_$PIECE(X,".",2),1:"")
+5 QUIT Y
