- 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 Feb 19, 2025@00:12:22 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
