VPRSDAM ;SLC/MKB -- SDA Appointment utilities ;7/29/22 14:11
;;1.0;VIRTUAL PATIENT RECORD;**30,35**;Sep 01, 2011;Build 16
;;Per VHA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^DGS(41.1 3796
; ^DPT 10035
; DIQ 2056
; SDAMA301, ^TMP($J) 4433
; SDOE 2546
;
;
APPTS ; -- get Appointments
; Query called from GET^DDE, returns DLIST(#)=ien
; Expects context variables DFN, DSTRT, DSTOP, DMAX
;
N VPRX,VPRNUM,VPRDT,VPRN
S VPRX(1)=DSTRT_";"_DSTOP,VPRX(4)=DFN
S VPRX("FLDS")="1;2;3;5;6;8;9;10;11;12;16;18;22;25;29;32",VPRX("SORT")="P"
; appointments
S VPRX(3)="R;I;NS;NSR;NT;CP;CPR;CC;CCR" ;p35 cancelled pats
S VPRNUM=$$SDAPI^SDAMA301(.VPRX),(VPRDT,VPRN)=0
F S VPRDT=$O(^TMP($J,"SDAMA301",DFN,VPRDT)) Q:VPRDT<1 D Q:VPRN'<DMAX
. S VPRN=VPRN+1,DLIST(VPRN)=VPRDT_","_DFN ;^TMP($J,"SDAMA301",DFN,VPRDT)
;K ^TMP($J,"SDAMA301",DFN)
Q
;
SCHADMS ; -- get Scheduled Admissions
; Query called from GET^DDE, returns DLIST(#)=ien
; Expects context variables DFN, DSTRT, DSTOP, DMAX
;
N VPRA,VPRX,X,VPRN S VPRN=0
S VPRA=0 F S VPRA=$O(^DGS(41.1,"B",DFN,VPRA)) Q:VPRA<1 D Q:VPRN'<DMAX
. S VPRX=$G(^DGS(41.1,VPRA,0))
. S X=$P(VPRX,U,2) Q:X<DSTRT!(X>DSTOP) ;out of date range
. ;Q:$P(VPRX,U,13) ;Q:$P(VPRX,U,17) ;cancelled or admitted
. S VPRN=VPRN+1,DLIST(VPRN)=VPRA
Q
;
APPT1(VPRID) ; -- get ^TMP node for single appt, returns VPRAPPT
N DFN,VPRDT S VPRID=$G(VPRID)
S DFN=$P(VPRID,",",2),VPRDT=$P(VPRID,",")
I 'DFN!'VPRDT S DDEOUT=1 Q
I '$D(^TMP($J,"SDAMA301",DFN)) D
. N VPRX,VPRNUM
. S VPRX(1)=VPRDT_";"_VPRDT,VPRX(4)=DFN
. S VPRX("FLDS")="1;2;3;5;6;8;9;10;11;12;16;18;22;25;29;32",VPRX("SORT")="P"
. S VPRNUM=$$SDAPI^SDAMA301(.VPRX)
S VPRAPPT=$G(^TMP($J,"SDAMA301",DFN,VPRDT)),VPRAPPT("C")=$G(^(VPRDT,"C"))
S VPRAPPT(0)=$G(^TMP($J,"SDAMA301",DFN,VPRDT,0))
S:VPRAPPT="" VPRAPPT=VPRDT_U_$P($G(^DPT(DFN,"S",VPRDT,0)),U,1,2) ;DDEOUT=1
Q
;
APPTPRV() ; -- return the default/primary provider for VPRAPPT
N Y,I,SDOE,LOC,VPROV S Y=""
S SDOE=$P($G(VPRAPPT),U,12) I SDOE D
. D GETPRV^SDOE(SDOE,"VPROV") S I=0
. F S I=$O(VPROV(I)) Q:I<1 I $P($G(VPROV(I)),U,4)="P" S Y=+VPROV(I) Q
. I 'Y S I=$O(VPROV(0)) S:I Y=+VPROV(I) ;first, if no Primary
I 'SDOE,+$G(VPRAPPT)>DT D ;future
. S LOC=+$P($G(VPRAPPT),U,2),Y=$$GET1^DIQ(44,LOC,16,"I") Q:Y
. ;S I=+$O(^SC("ADPR",LOC,0)) I I S Y=+$G(^SC(LOC,"PR",I,0))
. D GETS^DIQ(44,LOC,"2600*","I","VPROV")
. S I="" F S I=$O(VPROV(44.1,I)) Q:I="" I $G(VPROV(44.1,I,.02,"I"))=1 S Y=$G(VPROV(44.1,I,.01,"I"))
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRSDAM 2750 printed Sep 23, 2025@20:22:16 Page 2
VPRSDAM ;SLC/MKB -- SDA Appointment utilities ;7/29/22 14:11
+1 ;;1.0;VIRTUAL PATIENT RECORD;**30,35**;Sep 01, 2011;Build 16
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^DGS(41.1 3796
+7 ; ^DPT 10035
+8 ; DIQ 2056
+9 ; SDAMA301, ^TMP($J) 4433
+10 ; SDOE 2546
+11 ;
+12 ;
APPTS ; -- get Appointments
+1 ; Query called from GET^DDE, returns DLIST(#)=ien
+2 ; Expects context variables DFN, DSTRT, DSTOP, DMAX
+3 ;
+4 NEW VPRX,VPRNUM,VPRDT,VPRN
+5 SET VPRX(1)=DSTRT_";"_DSTOP
SET VPRX(4)=DFN
+6 SET VPRX("FLDS")="1;2;3;5;6;8;9;10;11;12;16;18;22;25;29;32"
SET VPRX("SORT")="P"
+7 ; appointments
+8 ;p35 cancelled pats
SET VPRX(3)="R;I;NS;NSR;NT;CP;CPR;CC;CCR"
+9 SET VPRNUM=$$SDAPI^SDAMA301(.VPRX)
SET (VPRDT,VPRN)=0
+10 FOR
SET VPRDT=$ORDER(^TMP($JOB,"SDAMA301",DFN,VPRDT))
if VPRDT<1
QUIT
Begin DoDot:1
+11 ;^TMP($J,"SDAMA301",DFN,VPRDT)
SET VPRN=VPRN+1
SET DLIST(VPRN)=VPRDT_","_DFN
End DoDot:1
if VPRN'<DMAX
QUIT
+12 ;K ^TMP($J,"SDAMA301",DFN)
+13 QUIT
+14 ;
SCHADMS ; -- get Scheduled Admissions
+1 ; Query called from GET^DDE, returns DLIST(#)=ien
+2 ; Expects context variables DFN, DSTRT, DSTOP, DMAX
+3 ;
+4 NEW VPRA,VPRX,X,VPRN
SET VPRN=0
+5 SET VPRA=0
FOR
SET VPRA=$ORDER(^DGS(41.1,"B",DFN,VPRA))
if VPRA<1
QUIT
Begin DoDot:1
+6 SET VPRX=$GET(^DGS(41.1,VPRA,0))
+7 ;out of date range
SET X=$PIECE(VPRX,U,2)
if X<DSTRT!(X>DSTOP)
QUIT
+8 ;Q:$P(VPRX,U,13) ;Q:$P(VPRX,U,17) ;cancelled or admitted
+9 SET VPRN=VPRN+1
SET DLIST(VPRN)=VPRA
End DoDot:1
if VPRN'<DMAX
QUIT
+10 QUIT
+11 ;
APPT1(VPRID) ; -- get ^TMP node for single appt, returns VPRAPPT
+1 NEW DFN,VPRDT
SET VPRID=$GET(VPRID)
+2 SET DFN=$PIECE(VPRID,",",2)
SET VPRDT=$PIECE(VPRID,",")
+3 IF 'DFN!'VPRDT
SET DDEOUT=1
QUIT
+4 IF '$DATA(^TMP($JOB,"SDAMA301",DFN))
Begin DoDot:1
+5 NEW VPRX,VPRNUM
+6 SET VPRX(1)=VPRDT_";"_VPRDT
SET VPRX(4)=DFN
+7 SET VPRX("FLDS")="1;2;3;5;6;8;9;10;11;12;16;18;22;25;29;32"
SET VPRX("SORT")="P"
+8 SET VPRNUM=$$SDAPI^SDAMA301(.VPRX)
End DoDot:1
+9 SET VPRAPPT=$GET(^TMP($JOB,"SDAMA301",DFN,VPRDT))
SET VPRAPPT("C")=$GET(^(VPRDT,"C"))
+10 SET VPRAPPT(0)=$GET(^TMP($JOB,"SDAMA301",DFN,VPRDT,0))
+11 ;DDEOUT=1
if VPRAPPT=""
SET VPRAPPT=VPRDT_U_$PIECE($GET(^DPT(DFN,"S",VPRDT,0)),U,1,2)
+12 QUIT
+13 ;
APPTPRV() ; -- return the default/primary provider for VPRAPPT
+1 NEW Y,I,SDOE,LOC,VPROV
SET Y=""
+2 SET SDOE=$PIECE($GET(VPRAPPT),U,12)
IF SDOE
Begin DoDot:1
+3 DO GETPRV^SDOE(SDOE,"VPROV")
SET I=0
+4 FOR
SET I=$ORDER(VPROV(I))
if I<1
QUIT
IF $PIECE($GET(VPROV(I)),U,4)="P"
SET Y=+VPROV(I)
QUIT
+5 ;first, if no Primary
IF 'Y
SET I=$ORDER(VPROV(0))
if I
SET Y=+VPROV(I)
End DoDot:1
+6 ;future
IF 'SDOE
IF +$GET(VPRAPPT)>DT
Begin DoDot:1
+7 SET LOC=+$PIECE($GET(VPRAPPT),U,2)
SET Y=$$GET1^DIQ(44,LOC,16,"I")
if Y
QUIT
+8 ;S I=+$O(^SC("ADPR",LOC,0)) I I S Y=+$G(^SC(LOC,"PR",I,0))
+9 DO GETS^DIQ(44,LOC,"2600*","I","VPROV")
+10 SET I=""
FOR
SET I=$ORDER(VPROV(44.1,I))
if I=""
QUIT
IF $GET(VPROV(44.1,I,.02,"I"))=1
SET Y=$GET(VPROV(44.1,I,.01,"I"))
End DoDot:1
+11 QUIT Y
