VPRSDADG ;SLC/MKB -- SDA DG PTF utilities ;04/25/22 15:29
;;1.0;VIRTUAL PATIENT RECORD;**30**;Apr 05, 2022;Build 9
;;Per VA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^AUPNVSIT 2028
; ^DGPM 1865
; 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRSDADG 3044 printed Apr 09, 2024@21:47:18 Page 2
VPRSDADG ;SLC/MKB -- SDA DG PTF utilities ;04/25/22 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**30**;Apr 05, 2022;Build 9
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^AUPNVSIT 2028
+7 ; ^DGPM 1865
+8 ; DGPTFAPI 3157
+9 ; DGPTFUT 6130
+10 ; DGPTPXRM 4457
+11 ; DIC 2051
+12 ; ICDEX 5747
+13 ;
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
