VPRSDADG ;SLC/MKB -- SDA DG PTF utilities ;04/25/22 15:29
;;1.0;VIRTUAL PATIENT RECORD;**30,35**;Apr 05, 2022;Build 16
;;Per VA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^AUPNVSIT 2028
; ^DGPM 1865
; DGMSEUTL 5783
; DGPTFAPI 3157
; DGPTFUT 6130
; DGPTPXRM 4457
; DIC 2051
; ICDEX 5747
;
DXQ ; -- get PTF Dx via Admissions
; Query called from GET^DDE, returns DLIST(#)=ien
; Expects context variables DFN, DSTRT, DSTOP, DMAX
;
N IDT,END,VPRN,ADM,PTF,VPTF,I
S IDT=9999999.9999999-DSTOP-.0000001,END=9999999.9999999-DSTRT,VPRN=0
F S IDT=$O(^DGPM("ATID1",DFN,IDT)) Q:IDT<1!(IDT>END) D Q:VPRN'<DMAX
. S ADM=0 F S ADM=$O(^DGPM("ATID1",DFN,IDT,ADM)) Q:ADM<1 D Q:VPRN'<DMAX
.. S PTF=+$P($G(^DGPM(ADM,0)),U,16) Q:PTF<1 Q:'$$VNUM^VPRSDAV(ADM)
.. ;Q:'$$GET1^DIQ(45,PTF,79,"I") ;no DXLS
.. D RPC^DGPTFAPI(.VPTF,PTF) Q:VPTF(0)<1
.. S:$L($P(VPTF(1),U,3)) VPRN=VPRN+1,DLIST(VPRN)=PTF
.. F I=1:1:24 I $L($P(VPTF(2),U,I)) S VPRN=VPRN+1,DLIST(VPRN)=PTF_"-"_I
Q
;
DX1 ; -- get info for single PTF record [ID Action]
; Expects DIEN = #45 ien, returns VPRPOA & VPRPTF array
N VST,VPTF,N,X,Y K VPRPTF
S VPRPTF=$G(DIEN),DIEN=+$G(DIEN)
S VST="" D I VST<1 S DDEOUT=1 Q
. N ADM S ADM=$$FIND1^DIC(405,,"Q",DIEN,"APTF") Q:ADM<1
. S:'$G(DFN) DFN=+$P($G(^DGPM(ADM,0)),U,3)
. S VST=+$$VNUM^VPRSDAV(ADM) I 'VST!'$D(^AUPNVSIT(VST,0)) S VST=""
S VPRPTF("VISIT")=VST
D RPC^DGPTFAPI(.VPTF,DIEN) I VPTF(0)<1 S DDEOUT=1 Q
S N=+$P(VPRPTF,"-",2),VPRPOA=$P($G(VPTF(3)),U,N+1)
S X=$S(N:$P(VPTF(2),U,N),1:$P($G(VPTF(1)),U,3))
S Y=$$CODEBA^ICDEX(X,80) I Y<1 S DDEOUT=1 Q
S VPRPTF("DX")=Y_U_X ;ien^code
D PTF^DGPTPXRM(DIEN,.VPRPTF)
Q
;
OPQ ; -- get PTF 601 procedure codes via Admissions
; Query called from GET^DDE, returns DLIST(#)=ien
; Expects context variables DFN, DSTRT, DSTOP, DMAX
;
N IDT,END,VPRN,ADM,PTF,VPTF,DA,STR,P,X
S IDT=9999999.9999999-DSTOP-.0000001,END=9999999.9999999-DSTRT,VPRN=0
F S IDT=$O(^DGPM("ATID1",DFN,IDT)) Q:IDT<1!(IDT>END) D Q:VPRN'<DMAX
. S ADM=0 F S ADM=$O(^DGPM("ATID1",DFN,IDT,ADM)) Q:ADM<1 D Q:VPRN'<DMAX
.. S PTF=+$P($G(^DGPM(ADM,0)),U,16) Q:PTF<1 Q:'$$VNUM^VPRSDAV(ADM)
.. D PTFIEN^DGPTFUT(601,PTF,.VPTF)
.. S DA=0 F S DA=$O(VPTF(DA)) Q:DA<1 D
... S STR=$$STR601^DGPTFUT(PTF,DA)
... F P=1:1:25 S X=$P(STR,U,P) S:X VPRN=VPRN+1,DLIST(VPRN)=DA_","_PTF_"-"_P
Q
;
OP1 ; -- get info for single PTF record [ID Action]
; Expects DIEN = #45 iens, returns VPRPTF & VPRVST
N VST,VPTF,X,Y
S VPRPTF=$G(DIEN),DIEN=$P($G(DIEN),"-") ;DA,PTF-#
S VST="" D I VST<1 S DDEOUT=1 Q
. N ADM,PTF
. S PTF=+$P(VPRPTF,",",2),ADM=$$FIND1^DIC(405,,"Q",PTF,"APTF") Q:'ADM
. S:'$G(DFN) DFN=$P($G(^DGPM(ADM,0)),U,3)
. S VST=+$$VNUM^VPRSDAV(ADM) I 'VST!'$D(^AUPNVSIT(VST,0)) S VST=""
S VPRVST=VST
Q
;
MSE ;Using GETMSE^DGMSEUTL, build array for use in entity VPR PATIENT MSE ALL
N BRANCH,COUNT,COMP,DA,DONE,DTYP,EDATA,EDATE,I,SDATE,SERVNO,SUB,EDATE2,SDATE2,BRANCH2,DTYP2,VPRI
S COUNT=0,EDATE=""
K VPRMS,VPRSV D:$G(DFN) GETMSE^DGMSEUTL(DFN,.VPRMS)
;Retrieve all MSE
S VPRI=0 F S VPRI=$O(VPRMS(VPRI)) Q:'VPRI D
.;DJS, skip an MSE that has Future Discharge Date; DG*5.3*935
.S EDATA=$G(VPRMS(VPRI)) Q:EDATA=""!($P(EDATA,U,8)'="")
.S EDATE=$P(EDATA,U),EDATE2=$$DATE^VPRSDA(EDATE,1)
.S SDATE=$P(EDATA,U,2),SDATE2=$$DATE^VPRSDA(SDATE,1),EDATE2=$$DATE^VPRSDA(EDATE,1)
.S BRANCH=$P(EDATA,U,3),COMP=$P(EDATA,U,4),BRANCH2=$$GET1^DIQ(23,BRANCH,.01)
.S SERVNO=$P(EDATA,U,5),DTYP=$P(EDATA,U,6),DTYP2=$$GET1^DIQ(25,DTYP,.01)
.S COUNT=COUNT+1
.S SUB=1,VPRSV(COUNT)=$S($G(BRANCH):1,1:"")
.S VPRSV(COUNT,SUB)=DTYP_U_DTYP2
.S VPRSV(COUNT,SUB+1)=BRANCH_U_BRANCH2
.S VPRSV(COUNT,SUB+2)=EDATE_U_EDATE2
.S VPRSV(COUNT,SUB+3)=SDATE_U_SDATE2
.S VPRSV(COUNT,SUB+4)=SERVNO
.S VPRSV(COUNT,SUB+5)=COMP_U_$$EXTERNAL^DILFD(2.3216,.04,,$G(COMP))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRSDADG 4150 printed Sep 23, 2025@20:22:11 Page 2
VPRSDADG ;SLC/MKB -- SDA DG PTF utilities ;04/25/22 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**30,35**;Apr 05, 2022;Build 16
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^AUPNVSIT 2028
+7 ; ^DGPM 1865
+8 ; DGMSEUTL 5783
+9 ; DGPTFAPI 3157
+10 ; DGPTFUT 6130
+11 ; DGPTPXRM 4457
+12 ; DIC 2051
+13 ; ICDEX 5747
+14 ;
DXQ ; -- get PTF Dx via Admissions
+1 ; Query called from GET^DDE, returns DLIST(#)=ien
+2 ; Expects context variables DFN, DSTRT, DSTOP, DMAX
+3 ;
+4 NEW IDT,END,VPRN,ADM,PTF,VPTF,I
+5 SET IDT=9999999.9999999-DSTOP-.0000001
SET END=9999999.9999999-DSTRT
SET VPRN=0
+6 FOR
SET IDT=$ORDER(^DGPM("ATID1",DFN,IDT))
if IDT<1!(IDT>END)
QUIT
Begin DoDot:1
+7 SET ADM=0
FOR
SET ADM=$ORDER(^DGPM("ATID1",DFN,IDT,ADM))
if ADM<1
QUIT
Begin DoDot:2
+8 SET PTF=+$PIECE($GET(^DGPM(ADM,0)),U,16)
if PTF<1
QUIT
if '$$VNUM^VPRSDAV(ADM)
QUIT
+9 ;Q:'$$GET1^DIQ(45,PTF,79,"I") ;no DXLS
+10 DO RPC^DGPTFAPI(.VPTF,PTF)
if VPTF(0)<1
QUIT
+11 if $LENGTH($PIECE(VPTF(1),U,3))
SET VPRN=VPRN+1
SET DLIST(VPRN)=PTF
+12 FOR I=1:1:24
IF $LENGTH($PIECE(VPTF(2),U,I))
SET VPRN=VPRN+1
SET DLIST(VPRN)=PTF_"-"_I
End DoDot:2
if VPRN'<DMAX
QUIT
End DoDot:1
if VPRN'<DMAX
QUIT
+13 QUIT
+14 ;
DX1 ; -- get info for single PTF record [ID Action]
+1 ; Expects DIEN = #45 ien, returns VPRPOA & VPRPTF array
+2 NEW VST,VPTF,N,X,Y
KILL VPRPTF
+3 SET VPRPTF=$GET(DIEN)
SET DIEN=+$GET(DIEN)
+4 SET VST=""
Begin DoDot:1
+5 NEW ADM
SET ADM=$$FIND1^DIC(405,,"Q",DIEN,"APTF")
if ADM<1
QUIT
+6 if '$GET(DFN)
SET DFN=+$PIECE($GET(^DGPM(ADM,0)),U,3)
+7 SET VST=+$$VNUM^VPRSDAV(ADM)
IF 'VST!'$DATA(^AUPNVSIT(VST,0))
SET VST=""
End DoDot:1
IF VST<1
SET DDEOUT=1
QUIT
+8 SET VPRPTF("VISIT")=VST
+9 DO RPC^DGPTFAPI(.VPTF,DIEN)
IF VPTF(0)<1
SET DDEOUT=1
QUIT
+10 SET N=+$PIECE(VPRPTF,"-",2)
SET VPRPOA=$PIECE($GET(VPTF(3)),U,N+1)
+11 SET X=$SELECT(N:$PIECE(VPTF(2),U,N),1:$PIECE($GET(VPTF(1)),U,3))
+12 SET Y=$$CODEBA^ICDEX(X,80)
IF Y<1
SET DDEOUT=1
QUIT
+13 ;ien^code
SET VPRPTF("DX")=Y_U_X
+14 DO PTF^DGPTPXRM(DIEN,.VPRPTF)
+15 QUIT
+16 ;
OPQ ; -- get PTF 601 procedure codes via Admissions
+1 ; Query called from GET^DDE, returns DLIST(#)=ien
+2 ; Expects context variables DFN, DSTRT, DSTOP, DMAX
+3 ;
+4 NEW IDT,END,VPRN,ADM,PTF,VPTF,DA,STR,P,X
+5 SET IDT=9999999.9999999-DSTOP-.0000001
SET END=9999999.9999999-DSTRT
SET VPRN=0
+6 FOR
SET IDT=$ORDER(^DGPM("ATID1",DFN,IDT))
if IDT<1!(IDT>END)
QUIT
Begin DoDot:1
+7 SET ADM=0
FOR
SET ADM=$ORDER(^DGPM("ATID1",DFN,IDT,ADM))
if ADM<1
QUIT
Begin DoDot:2
+8 SET PTF=+$PIECE($GET(^DGPM(ADM,0)),U,16)
if PTF<1
QUIT
if '$$VNUM^VPRSDAV(ADM)
QUIT
+9 DO PTFIEN^DGPTFUT(601,PTF,.VPTF)
+10 SET DA=0
FOR
SET DA=$ORDER(VPTF(DA))
if DA<1
QUIT
Begin DoDot:3
+11 SET STR=$$STR601^DGPTFUT(PTF,DA)
+12 FOR P=1:1:25
SET X=$PIECE(STR,U,P)
if X
SET VPRN=VPRN+1
SET DLIST(VPRN)=DA_","_PTF_"-"_P
End DoDot:3
End DoDot:2
if VPRN'<DMAX
QUIT
End DoDot:1
if VPRN'<DMAX
QUIT
+13 QUIT
+14 ;
OP1 ; -- get info for single PTF record [ID Action]
+1 ; Expects DIEN = #45 iens, returns VPRPTF & VPRVST
+2 NEW VST,VPTF,X,Y
+3 ;DA,PTF-#
SET VPRPTF=$GET(DIEN)
SET DIEN=$PIECE($GET(DIEN),"-")
+4 SET VST=""
Begin DoDot:1
+5 NEW ADM,PTF
+6 SET PTF=+$PIECE(VPRPTF,",",2)
SET ADM=$$FIND1^DIC(405,,"Q",PTF,"APTF")
if 'ADM
QUIT
+7 if '$GET(DFN)
SET DFN=$PIECE($GET(^DGPM(ADM,0)),U,3)
+8 SET VST=+$$VNUM^VPRSDAV(ADM)
IF 'VST!'$DATA(^AUPNVSIT(VST,0))
SET VST=""
End DoDot:1
IF VST<1
SET DDEOUT=1
QUIT
+9 SET VPRVST=VST
+10 QUIT
+11 ;
MSE ;Using GETMSE^DGMSEUTL, build array for use in entity VPR PATIENT MSE ALL
+1 NEW BRANCH,COUNT,COMP,DA,DONE,DTYP,EDATA,EDATE,I,SDATE,SERVNO,SUB,EDATE2,SDATE2,BRANCH2,DTYP2,VPRI
+2 SET COUNT=0
SET EDATE=""
+3 KILL VPRMS,VPRSV
if $GET(DFN)
DO GETMSE^DGMSEUTL(DFN,.VPRMS)
+4 ;Retrieve all MSE
+5 SET VPRI=0
FOR
SET VPRI=$ORDER(VPRMS(VPRI))
if 'VPRI
QUIT
Begin DoDot:1
+6 ;DJS, skip an MSE that has Future Discharge Date; DG*5.3*935
+7 SET EDATA=$GET(VPRMS(VPRI))
if EDATA=""!($PIECE(EDATA,U,8)'="")
QUIT
+8 SET EDATE=$PIECE(EDATA,U)
SET EDATE2=$$DATE^VPRSDA(EDATE,1)
+9 SET SDATE=$PIECE(EDATA,U,2)
SET SDATE2=$$DATE^VPRSDA(SDATE,1)
SET EDATE2=$$DATE^VPRSDA(EDATE,1)
+10 SET BRANCH=$PIECE(EDATA,U,3)
SET COMP=$PIECE(EDATA,U,4)
SET BRANCH2=$$GET1^DIQ(23,BRANCH,.01)
+11 SET SERVNO=$PIECE(EDATA,U,5)
SET DTYP=$PIECE(EDATA,U,6)
SET DTYP2=$$GET1^DIQ(25,DTYP,.01)
+12 SET COUNT=COUNT+1
+13 SET SUB=1
SET VPRSV(COUNT)=$SELECT($GET(BRANCH):1,1:"")
+14 SET VPRSV(COUNT,SUB)=DTYP_U_DTYP2
+15 SET VPRSV(COUNT,SUB+1)=BRANCH_U_BRANCH2
+16 SET VPRSV(COUNT,SUB+2)=EDATE_U_EDATE2
+17 SET VPRSV(COUNT,SUB+3)=SDATE_U_SDATE2
+18 SET VPRSV(COUNT,SUB+4)=SERVNO
+19 SET VPRSV(COUNT,SUB+5)=COMP_U_$$EXTERNAL^DILFD(2.3216,.04,,$GET(COMP))
End DoDot:1
+20 QUIT
