DGQPTQ1 ; SLC/CLA - Functs which return DG patient lists and sources pt 1 ;12/15/97
;;5.3;Registration;**447**;Aug 13, 1993
VAMCPTS(Y) ; RETURN LIST OF PATIENTS IN VAMC: DFN^NAME
N I,J,V
S I=1
S J=0 F S J=$O(^DPT("B",J)) Q:J="" S V=0,V=$O(^DPT("B",J,V)) S Y(I)=V_"^"_J,I=I+1
Q
VAMCLONG(Y,DIR,FROM) ; return a bolus of patients in VAMC: DFN^NAME
N I,IEN,CNT S CNT=44
I DIR=0 D ; Forward direction
. F I=1:1:CNT S FROM=$O(^DPT("B",FROM)) Q:FROM="" D
. . S Y(I)=$O(^DPT("B",FROM,0))_"^"_FROM
. I +$G(Y(CNT))="" S Y(I)=""
I DIR=1 D ; Reverse direction
. F I=1:1:CNT S FROM=$O(^DPT("B",FROM),-1) Q:FROM="" D
. . S Y(I)=$O(^DPT("B",FROM,0))_"^"_FROM
Q
DEFTM(DGY) ; return current user's default team list
Q:'$D(DUZ)
N DGSRV S DGSRV=$G(^VA(200,DUZ,5)) I +DGSRV>0 S DGSRV=$P(DGSRV,U)
S DGY=$$GET^XPAR("USR^SRV.`"_+$G(DGSRV),"DGLP DEFAULT TEAM",1,"B")
Q
TEAMS(DGY) ; return list of teams for a system
; Also called under DBIA # 2692.
N DGTM,I,DGTMN
S DGTMN="",I=1
F S DGTMN=$O(^OR(100.21,"B",DGTMN)) Q:DGTMN="" D
.S DGTM="",DGTM=$O(^OR(100.21,"B",DGTMN,DGTM)) Q:DGTM=""
.S DGY(I)=DGTM_U_DGTMN,I=I+1
S:+$G(DGY(1))<1 DGY(1)="^No teams found."
Q
TEAMPTS(DGY,TEAM,TMPFLAG) ; RETURN LIST OF PATIENTS IN A TEAM
; Also called under DBIA # 2692.
; If TMPFLAG passed and = TRUE, code expects a "^TMP(xxx"
; global root string passed in DGY, and builds the returned
; list in that global instead of to a memory array.
N DOTMP,NEWTMP
S DOTMP=0
I $G(TMPFLAG) D ; Was value passed?
.I TMPFLAG S DOTMP=1 ; Is value TRUE?
I +$G(TEAM)<1 D
.I DOTMP S NEWTMP=DGY_1_")",@NEWTMP="^No team identified" Q
.I 'DOTMP S DGY(1)="^No team identified" Q
N DGI,DGPT,I
S I=0
S DGI=0 F S DGI=$O(^OR(100.21,+TEAM,10,DGI)) Q:DGI<1 D
.S DGPT=^OR(100.21,+TEAM,10,DGI,0)
.I DOTMP D
..S I=I+1,NEWTMP=DGY_+I_")"
..S @NEWTMP=+DGPT_U_$P(^DPT(+DGPT,0),U)
.I 'DOTMP S I=I+1,DGY(I)=+DGPT_U_$P(^DPT(+DGPT,0),U)
I DOTMP S:I<1 NEWTMP=ORY_1_")",@NEWTMP="^No patients found."
I 'DOTMP S:I<1 DGY(1)="^No patients found."
Q
TEAMPR(DGY,PROV) ; return list of teams linked to a provider
I +$G(PROV)<1 S DGY(1)="^No provider identified" Q
N DGTM,I,DGTMN
S DGTM="",I=1
F S DGTM=$O(^OR(100.21,"C",+PROV,DGTM)) Q:+$G(DGTM)<1 D
.S DGTMN=$P(^OR(100.21,DGTM,0),U)
.S DGY(I)=DGTM_U_DGTMN,I=I+1
S:+$G(DGY(1))<1 DGY(1)="^No teams found."
Q
TEAMPR2(DGY,PROV) ; return list of teams linked to a provider
; This tag added by PKS/slc - 8/1999.
I +$G(PROV)<1 S DGY(1)="^No provider identified" Q
N DGTM,DGDATA,DGTMN,DGTYPE,I
S DGTM="",I=1
F S DGTM=$O(^OR(100.21,"C",+PROV,DGTM)) Q:+$G(DGTM)<1 D
.S DGDATA=^OR(100.21,ORTM,0) ; Get value.
.S DGTMN=$P(ORDATA,U) ; Team List name.
.S DGTYPE=$P(ORDATA,U,2) ; Team List type.
.S DGY(I)=DGTM_U_DGTMN_U_DGTYPE,I=I+1
S:+$G(DGY(1))<1 DGY(1)="^No teams found."
Q
TEAMPROV(DGY,TEAM) ; return list of providers linked to a team
I +$G(TEAM)<1 S DGY(1)="^No team identified"
N PROV,I,SEQ
S I=1
S SEQ=0 F S SEQ=$O(^OR(100.21,+TEAM,1,SEQ)) Q:SEQ<1 D
.S PROV=^OR(100.21,+TEAM,1,SEQ,0) I $L(PROV) D
..S DGY(I)=+PROV_U_$P(^VA(200,+PROV,0),U),I=I+1
S:+$G(DGY(1))<1 DGY(1)="^No providers found."
Q
TPROVPT(PROV) ;return list of patients linked to a provider via teams
; Modified by PKS: 8/1999.
I +$G(PROV)<1 S ^TMP("DGLPUPT",$J,"^No provider identified")=""
N DGTM,DGTMN,DGI,DGPT
S DGTM=""
F S DGTM=$O(^OR(100.21,"C",+PROV,DGTM)) Q:+$G(DGTM)<1 D ; Teams.
.S DGTMN=$P(^OR(100.21,+DGTM,0),U,1) ; Get name of Team List.
.S DGI=0 F S DGI=$O(^OR(100.21,+DGTM,10,DGI)) Q:DGI<1 D
..S DGPT=^OR(100.21,+DGTM,10,DGI,0)
..S ^TMP("DGLPUPT",$J,+DGPT_U_$P(^DPT(+DGPT,0),U))=""
..; Next line added by PKS:
..S ^TMP("DGLPUPT",$J,"B",DGTMN,$P(^DPT(+DGPT,0),U)_U_+DGPT)=""
I '$D(^TMP("DGLPUPT",$J)) S ^TMP("DGLPUPT",$J,"^No patients found.")=""
Q
TMSPT(DGY,PT) ;return list of teams linked to a patient (patient is active)
I +$G(PT)<1 S DGY(1)="^No patient identified" Q
N DGTM,I,DGTMN,DGTMTYP
S DGTM="",I=1
F S DGTM=$O(^OR(100.21,"AB",+PT_";DPT(",DGTM)) Q:+$G(DGTM)<1 D
.S DGTMN=$P(^OR(100.21,DGTM,0),U)
.S DGTMTYP=$P(^OR(100.21,DGTM,0),U,2) I $L(DGTMTYP) D
..S DGTMTYP=$$EXTERNAL^DILFD(100.21,1,"",DGTMTYP,"")
.S DGY(I)=DGTM_U_DGTMN_U_$S($L(DGTMTYP):DGTMTYP,1:"no type"),I=I+1
S:+$G(DGY(1))<1 DGY(1)="^No teams found."
Q
TPTPR(DGY,PT) ;return list of providers linked to a patient via teams
I +$G(PT)<1 S DGY(1)="^No patient identified" Q
N DGTM,PROV,SEQ
S DGTM=""
F S DGTM=$O(^OR(100.21,"AB",+PT_";DPT(",DGTM)) Q:+$G(DGTM)<1 D
.S SEQ=0 F S SEQ=$O(^OR(100.21,+DGTM,1,SEQ)) Q:SEQ<1 D
..S PROV=^OR(100.21,+DGTM,1,SEQ,0) I $L(PROV) D
...S DGY(+PROV)=+PROV_U_$P(^VA(200,+PROV,0),U)
S:'$D(DGY) DGY(1)="^No providers found."
Q
PERSPR(DGY) ; return list of personal lists linked to current user
N DGTM,I,DGTMN
S DGTM="",I=1
F S DGTM=$O(^OR(100.21,"C",DUZ,DGTM)) Q:+$G(DGTM)<1 D
.Q:$P(^OR(100.21,DGTM,0),U,2)'="P" ;quit if not a personal list
.S DGTMN=$P(^OR(100.21,DGTM,0),U)
.S DGY(I)=DGTM_U_DGTMN,I=I+1
S:+$G(DGY(1))<1 DGY(1)="^No personal lists found."
Q
PRIMPT(DGY,DGPT) ; return patient's PCMM primary care team
I +$G(DGPT)<1 S DGY(1)="^No patient identified"
N DGQPUR,DGQERROR,DGQLST,DGQERR,DGQDT,DGIDT,DGADT,DGX
S DGQPUR(2)="" ;"2" is the ien for purpose "primary care" [^SD(403.47]
D NOW^%DTC S DGQDT("BEGIN")=%-.0001,DGQDT("END")=%+.0001,DGQDT("INCL")=0
S DGQERROR=$$TMPT^SCAPMC(.DGPT,"DGQDT","DGQPUR","DGQLST","DGQERR")
I DGQERROR=0 S DGY="^Error in search for primary care team."
I +$G(DGQLST(1))>0 D
.S DGX=DGQLST(1),DGADT=$P(DGX,U,4),DGIDT=$P(DGX,U,5)
.I ($G(DGADT)>$G(DGIDT)) S DGY=$P(DGX,U)_U_$P(DGX,U,2)
S:+$G(DGY)<1 DGY="^No primary care team found."
K %
Q
PROVPT(DGY,DGPT) ; return PCMM primary provider for a patient
I +$G(DGPT)<1 S DGY(1)="^No patient identified"
S DGY(1)=$$OUTPTPR^SDUTL3(DGPT,$$NOW^XLFDT,1)
Q
PPLINK(DGPROV,DGPT) ; returns '1' if patient is linked to provider
N DGX,DGPP
S DGX="",DGPP=0
I (+$G(DGPT)<1)!(+$G(DGPROV)<1) Q 0
I $D(^DPT("APR",DGPROV,DGPT)) Q "1^PRIM" ;provider is patient's primary
I $D(^DPT("AAP",DGPROV,DGPT)) Q "1^ATTD" ;provider is patient's attending
;is provider and patient on the same team:
D TPROVPT(DGPROV)
F S DGX=$O(^TMP("DGLPUPT",$J,DGX)) Q:DGX="" D
.I +DGX=DGPT S DGPP="1^OERRTM" Q
K ^TMP("DGLPUPT",$J)
;
;If not linked already, see if linked via PCMM:
I DGPP=0 S DGPP=$$PCMMLINK(DGPROV,DGPT)
;
Q DGPP
PDLINK(DGDEV,DGPT) ; returns '1' if patient is linked to device via team
;DGDEV can be either ien or device name
N DGY,DGX,DGTM,DGDP,DGTMDEV,DGDEVIEN
S DGDP=0
I (+$G(DGPT)<1)!($L($G(DGDEV))<1) Q 0
; Are device and patient on the same team?:
I '$D(^%ZIS(1,DGDEV,0)) D ;DGDEV is not an ien
.S DGDEVIEN=0,DGDEVIEN=$O(^%ZIS(1,"B",$P(DGDEV,U),ORDEVIEN))
.S DGDEV=DGDEVIEN
Q:+$G(DGDEV)<1 0
D TMSPT(.DGY,DGPT)
S DGX="" F S DGX=$O(DGY(DGX)) Q:DGX="" D
.S DGTM=DGY(DGX)
.I $D(^OR(100.21,+DGTM,0)),$P(^(0),U,4)=DGDEV S DGDP=1 Q
Q DGDP
PCMMLINK(DGPROV,DGPT) ;returns '1' if patient is linked to provider via PCMM
N DGPP,DGPCMM,DGPCP
S DGPP=0
I (+$G(DGPT)<1)!(+$G(DGPROV)<1) Q 0
;
;provider is patient's PCMM primary care practitioner:
I DGPROV=+$$OUTPTPR^SDUTL3(DGPT,$$NOW^XLFDT,1) Q "1^PCP" ;DBIA #1252
;
;provider is patient's PCMM associate provider:
I DGPROV=+$$OUTPTAP^SDUTL3(DGPT,$$NOW^XLFDT) Q "1^AP" ;DBIA #1252
;
;provider is linked to patient via PCMM team position assignment:
S DGPCMM=$$PRPT^SCAPMC(DGPT,,,,,,"^TMP(""DGPCMMLK"",$J)",) ;DBIA #1916
S DGPCP=0
F S DGPCP=$O(^TMP("DGPCMMLK",$J,"SCPR",DGPCP)) Q:'DGPCP!DGPP=1 D
.I DGPROV=DGPCP S DGPP="1^PCMMTM"
K ^TMP("DGPCMMLK",$J)
;
Q DGPP
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGQPTQ1 7846 printed Sep 23, 2025@20:30:33 Page 2
DGQPTQ1 ; SLC/CLA - Functs which return DG patient lists and sources pt 1 ;12/15/97
+1 ;;5.3;Registration;**447**;Aug 13, 1993
VAMCPTS(Y) ; RETURN LIST OF PATIENTS IN VAMC: DFN^NAME
+1 NEW I,J,V
+2 SET I=1
+3 SET J=0
FOR
SET J=$ORDER(^DPT("B",J))
if J=""
QUIT
SET V=0
SET V=$ORDER(^DPT("B",J,V))
SET Y(I)=V_"^"_J
SET I=I+1
+4 QUIT
VAMCLONG(Y,DIR,FROM) ; return a bolus of patients in VAMC: DFN^NAME
+1 NEW I,IEN,CNT
SET CNT=44
+2 ; Forward direction
IF DIR=0
Begin DoDot:1
+3 FOR I=1:1:CNT
SET FROM=$ORDER(^DPT("B",FROM))
if FROM=""
QUIT
Begin DoDot:2
+4 SET Y(I)=$ORDER(^DPT("B",FROM,0))_"^"_FROM
End DoDot:2
+5 IF +$GET(Y(CNT))=""
SET Y(I)=""
End DoDot:1
+6 ; Reverse direction
IF DIR=1
Begin DoDot:1
+7 FOR I=1:1:CNT
SET FROM=$ORDER(^DPT("B",FROM),-1)
if FROM=""
QUIT
Begin DoDot:2
+8 SET Y(I)=$ORDER(^DPT("B",FROM,0))_"^"_FROM
End DoDot:2
End DoDot:1
+9 QUIT
DEFTM(DGY) ; return current user's default team list
+1 if '$DATA(DUZ)
QUIT
+2 NEW DGSRV
SET DGSRV=$GET(^VA(200,DUZ,5))
IF +DGSRV>0
SET DGSRV=$PIECE(DGSRV,U)
+3 SET DGY=$$GET^XPAR("USR^SRV.`"_+$GET(DGSRV),"DGLP DEFAULT TEAM",1,"B")
+4 QUIT
TEAMS(DGY) ; return list of teams for a system
+1 ; Also called under DBIA # 2692.
+2 NEW DGTM,I,DGTMN
+3 SET DGTMN=""
SET I=1
+4 FOR
SET DGTMN=$ORDER(^OR(100.21,"B",DGTMN))
if DGTMN=""
QUIT
Begin DoDot:1
+5 SET DGTM=""
SET DGTM=$ORDER(^OR(100.21,"B",DGTMN,DGTM))
if DGTM=""
QUIT
+6 SET DGY(I)=DGTM_U_DGTMN
SET I=I+1
End DoDot:1
+7 if +$GET(DGY(1))<1
SET DGY(1)="^No teams found."
+8 QUIT
TEAMPTS(DGY,TEAM,TMPFLAG) ; RETURN LIST OF PATIENTS IN A TEAM
+1 ; Also called under DBIA # 2692.
+2 ; If TMPFLAG passed and = TRUE, code expects a "^TMP(xxx"
+3 ; global root string passed in DGY, and builds the returned
+4 ; list in that global instead of to a memory array.
+5 NEW DOTMP,NEWTMP
+6 SET DOTMP=0
+7 ; Was value passed?
IF $GET(TMPFLAG)
Begin DoDot:1
+8 ; Is value TRUE?
IF TMPFLAG
SET DOTMP=1
End DoDot:1
+9 IF +$GET(TEAM)<1
Begin DoDot:1
+10 IF DOTMP
SET NEWTMP=DGY_1_")"
SET @NEWTMP="^No team identified"
QUIT
+11 IF 'DOTMP
SET DGY(1)="^No team identified"
QUIT
End DoDot:1
+12 NEW DGI,DGPT,I
+13 SET I=0
+14 SET DGI=0
FOR
SET DGI=$ORDER(^OR(100.21,+TEAM,10,DGI))
if DGI<1
QUIT
Begin DoDot:1
+15 SET DGPT=^OR(100.21,+TEAM,10,DGI,0)
+16 IF DOTMP
Begin DoDot:2
+17 SET I=I+1
SET NEWTMP=DGY_+I_")"
+18 SET @NEWTMP=+DGPT_U_$PIECE(^DPT(+DGPT,0),U)
End DoDot:2
+19 IF 'DOTMP
SET I=I+1
SET DGY(I)=+DGPT_U_$PIECE(^DPT(+DGPT,0),U)
End DoDot:1
+20 IF DOTMP
if I<1
SET NEWTMP=ORY_1_")"
SET @NEWTMP="^No patients found."
+21 IF 'DOTMP
if I<1
SET DGY(1)="^No patients found."
+22 QUIT
TEAMPR(DGY,PROV) ; return list of teams linked to a provider
+1 IF +$GET(PROV)<1
SET DGY(1)="^No provider identified"
QUIT
+2 NEW DGTM,I,DGTMN
+3 SET DGTM=""
SET I=1
+4 FOR
SET DGTM=$ORDER(^OR(100.21,"C",+PROV,DGTM))
if +$GET(DGTM)<1
QUIT
Begin DoDot:1
+5 SET DGTMN=$PIECE(^OR(100.21,DGTM,0),U)
+6 SET DGY(I)=DGTM_U_DGTMN
SET I=I+1
End DoDot:1
+7 if +$GET(DGY(1))<1
SET DGY(1)="^No teams found."
+8 QUIT
TEAMPR2(DGY,PROV) ; return list of teams linked to a provider
+1 ; This tag added by PKS/slc - 8/1999.
+2 IF +$GET(PROV)<1
SET DGY(1)="^No provider identified"
QUIT
+3 NEW DGTM,DGDATA,DGTMN,DGTYPE,I
+4 SET DGTM=""
SET I=1
+5 FOR
SET DGTM=$ORDER(^OR(100.21,"C",+PROV,DGTM))
if +$GET(DGTM)<1
QUIT
Begin DoDot:1
+6 ; Get value.
SET DGDATA=^OR(100.21,ORTM,0)
+7 ; Team List name.
SET DGTMN=$PIECE(ORDATA,U)
+8 ; Team List type.
SET DGTYPE=$PIECE(ORDATA,U,2)
+9 SET DGY(I)=DGTM_U_DGTMN_U_DGTYPE
SET I=I+1
End DoDot:1
+10 if +$GET(DGY(1))<1
SET DGY(1)="^No teams found."
+11 QUIT
TEAMPROV(DGY,TEAM) ; return list of providers linked to a team
+1 IF +$GET(TEAM)<1
SET DGY(1)="^No team identified"
+2 NEW PROV,I,SEQ
+3 SET I=1
+4 SET SEQ=0
FOR
SET SEQ=$ORDER(^OR(100.21,+TEAM,1,SEQ))
if SEQ<1
QUIT
Begin DoDot:1
+5 SET PROV=^OR(100.21,+TEAM,1,SEQ,0)
IF $LENGTH(PROV)
Begin DoDot:2
+6 SET DGY(I)=+PROV_U_$PIECE(^VA(200,+PROV,0),U)
SET I=I+1
End DoDot:2
End DoDot:1
+7 if +$GET(DGY(1))<1
SET DGY(1)="^No providers found."
+8 QUIT
TPROVPT(PROV) ;return list of patients linked to a provider via teams
+1 ; Modified by PKS: 8/1999.
+2 IF +$GET(PROV)<1
SET ^TMP("DGLPUPT",$JOB,"^No provider identified")=""
+3 NEW DGTM,DGTMN,DGI,DGPT
+4 SET DGTM=""
+5 ; Teams.
FOR
SET DGTM=$ORDER(^OR(100.21,"C",+PROV,DGTM))
if +$GET(DGTM)<1
QUIT
Begin DoDot:1
+6 ; Get name of Team List.
SET DGTMN=$PIECE(^OR(100.21,+DGTM,0),U,1)
+7 SET DGI=0
FOR
SET DGI=$ORDER(^OR(100.21,+DGTM,10,DGI))
if DGI<1
QUIT
Begin DoDot:2
+8 SET DGPT=^OR(100.21,+DGTM,10,DGI,0)
+9 SET ^TMP("DGLPUPT",$JOB,+DGPT_U_$PIECE(^DPT(+DGPT,0),U))=""
+10 ; Next line added by PKS:
+11 SET ^TMP("DGLPUPT",$JOB,"B",DGTMN,$PIECE(^DPT(+DGPT,0),U)_U_+DGPT)=""
End DoDot:2
End DoDot:1
+12 IF '$DATA(^TMP("DGLPUPT",$JOB))
SET ^TMP("DGLPUPT",$JOB,"^No patients found.")=""
+13 QUIT
TMSPT(DGY,PT) ;return list of teams linked to a patient (patient is active)
+1 IF +$GET(PT)<1
SET DGY(1)="^No patient identified"
QUIT
+2 NEW DGTM,I,DGTMN,DGTMTYP
+3 SET DGTM=""
SET I=1
+4 FOR
SET DGTM=$ORDER(^OR(100.21,"AB",+PT_";DPT(",DGTM))
if +$GET(DGTM)<1
QUIT
Begin DoDot:1
+5 SET DGTMN=$PIECE(^OR(100.21,DGTM,0),U)
+6 SET DGTMTYP=$PIECE(^OR(100.21,DGTM,0),U,2)
IF $LENGTH(DGTMTYP)
Begin DoDot:2
+7 SET DGTMTYP=$$EXTERNAL^DILFD(100.21,1,"",DGTMTYP,"")
End DoDot:2
+8 SET DGY(I)=DGTM_U_DGTMN_U_$SELECT($LENGTH(DGTMTYP):DGTMTYP,1:"no type")
SET I=I+1
End DoDot:1
+9 if +$GET(DGY(1))<1
SET DGY(1)="^No teams found."
+10 QUIT
TPTPR(DGY,PT) ;return list of providers linked to a patient via teams
+1 IF +$GET(PT)<1
SET DGY(1)="^No patient identified"
QUIT
+2 NEW DGTM,PROV,SEQ
+3 SET DGTM=""
+4 FOR
SET DGTM=$ORDER(^OR(100.21,"AB",+PT_";DPT(",DGTM))
if +$GET(DGTM)<1
QUIT
Begin DoDot:1
+5 SET SEQ=0
FOR
SET SEQ=$ORDER(^OR(100.21,+DGTM,1,SEQ))
if SEQ<1
QUIT
Begin DoDot:2
+6 SET PROV=^OR(100.21,+DGTM,1,SEQ,0)
IF $LENGTH(PROV)
Begin DoDot:3
+7 SET DGY(+PROV)=+PROV_U_$PIECE(^VA(200,+PROV,0),U)
End DoDot:3
End DoDot:2
End DoDot:1
+8 if '$DATA(DGY)
SET DGY(1)="^No providers found."
+9 QUIT
PERSPR(DGY) ; return list of personal lists linked to current user
+1 NEW DGTM,I,DGTMN
+2 SET DGTM=""
SET I=1
+3 FOR
SET DGTM=$ORDER(^OR(100.21,"C",DUZ,DGTM))
if +$GET(DGTM)<1
QUIT
Begin DoDot:1
+4 ;quit if not a personal list
if $PIECE(^OR(100.21,DGTM,0),U,2)'="P"
QUIT
+5 SET DGTMN=$PIECE(^OR(100.21,DGTM,0),U)
+6 SET DGY(I)=DGTM_U_DGTMN
SET I=I+1
End DoDot:1
+7 if +$GET(DGY(1))<1
SET DGY(1)="^No personal lists found."
+8 QUIT
PRIMPT(DGY,DGPT) ; return patient's PCMM primary care team
+1 IF +$GET(DGPT)<1
SET DGY(1)="^No patient identified"
+2 NEW DGQPUR,DGQERROR,DGQLST,DGQERR,DGQDT,DGIDT,DGADT,DGX
+3 ;"2" is the ien for purpose "primary care" [^SD(403.47]
SET DGQPUR(2)=""
+4 DO NOW^%DTC
SET DGQDT("BEGIN")=%-.0001
SET DGQDT("END")=%+.0001
SET DGQDT("INCL")=0
+5 SET DGQERROR=$$TMPT^SCAPMC(.DGPT,"DGQDT","DGQPUR","DGQLST","DGQERR")
+6 IF DGQERROR=0
SET DGY="^Error in search for primary care team."
+7 IF +$GET(DGQLST(1))>0
Begin DoDot:1
+8 SET DGX=DGQLST(1)
SET DGADT=$PIECE(DGX,U,4)
SET DGIDT=$PIECE(DGX,U,5)
+9 IF ($GET(DGADT)>$GET(DGIDT))
SET DGY=$PIECE(DGX,U)_U_$PIECE(DGX,U,2)
End DoDot:1
+10 if +$GET(DGY)<1
SET DGY="^No primary care team found."
+11 KILL %
+12 QUIT
PROVPT(DGY,DGPT) ; return PCMM primary provider for a patient
+1 IF +$GET(DGPT)<1
SET DGY(1)="^No patient identified"
+2 SET DGY(1)=$$OUTPTPR^SDUTL3(DGPT,$$NOW^XLFDT,1)
+3 QUIT
PPLINK(DGPROV,DGPT) ; returns '1' if patient is linked to provider
+1 NEW DGX,DGPP
+2 SET DGX=""
SET DGPP=0
+3 IF (+$GET(DGPT)<1)!(+$GET(DGPROV)<1)
QUIT 0
+4 ;provider is patient's primary
IF $DATA(^DPT("APR",DGPROV,DGPT))
QUIT "1^PRIM"
+5 ;provider is patient's attending
IF $DATA(^DPT("AAP",DGPROV,DGPT))
QUIT "1^ATTD"
+6 ;is provider and patient on the same team:
+7 DO TPROVPT(DGPROV)
+8 FOR
SET DGX=$ORDER(^TMP("DGLPUPT",$JOB,DGX))
if DGX=""
QUIT
Begin DoDot:1
+9 IF +DGX=DGPT
SET DGPP="1^OERRTM"
QUIT
End DoDot:1
+10 KILL ^TMP("DGLPUPT",$JOB)
+11 ;
+12 ;If not linked already, see if linked via PCMM:
+13 IF DGPP=0
SET DGPP=$$PCMMLINK(DGPROV,DGPT)
+14 ;
+15 QUIT DGPP
PDLINK(DGDEV,DGPT) ; returns '1' if patient is linked to device via team
+1 ;DGDEV can be either ien or device name
+2 NEW DGY,DGX,DGTM,DGDP,DGTMDEV,DGDEVIEN
+3 SET DGDP=0
+4 IF (+$GET(DGPT)<1)!($LENGTH($GET(DGDEV))<1)
QUIT 0
+5 ; Are device and patient on the same team?:
+6 ;DGDEV is not an ien
IF '$DATA(^%ZIS(1,DGDEV,0))
Begin DoDot:1
+7 SET DGDEVIEN=0
SET DGDEVIEN=$ORDER(^%ZIS(1,"B",$PIECE(DGDEV,U),ORDEVIEN))
+8 SET DGDEV=DGDEVIEN
End DoDot:1
+9 if +$GET(DGDEV)<1
QUIT 0
+10 DO TMSPT(.DGY,DGPT)
+11 SET DGX=""
FOR
SET DGX=$ORDER(DGY(DGX))
if DGX=""
QUIT
Begin DoDot:1
+12 SET DGTM=DGY(DGX)
+13 IF $DATA(^OR(100.21,+DGTM,0))
IF $PIECE(^(0),U,4)=DGDEV
SET DGDP=1
QUIT
End DoDot:1
+14 QUIT DGDP
PCMMLINK(DGPROV,DGPT) ;returns '1' if patient is linked to provider via PCMM
+1 NEW DGPP,DGPCMM,DGPCP
+2 SET DGPP=0
+3 IF (+$GET(DGPT)<1)!(+$GET(DGPROV)<1)
QUIT 0
+4 ;
+5 ;provider is patient's PCMM primary care practitioner:
+6 ;DBIA #1252
IF DGPROV=+$$OUTPTPR^SDUTL3(DGPT,$$NOW^XLFDT,1)
QUIT "1^PCP"
+7 ;
+8 ;provider is patient's PCMM associate provider:
+9 ;DBIA #1252
IF DGPROV=+$$OUTPTAP^SDUTL3(DGPT,$$NOW^XLFDT)
QUIT "1^AP"
+10 ;
+11 ;provider is linked to patient via PCMM team position assignment:
+12 ;DBIA #1916
SET DGPCMM=$$PRPT^SCAPMC(DGPT,,,,,,"^TMP(""DGPCMMLK"",$J)",)
+13 SET DGPCP=0
+14 FOR
SET DGPCP=$ORDER(^TMP("DGPCMMLK",$JOB,"SCPR",DGPCP))
if 'DGPCP!DGPP=1
QUIT
Begin DoDot:1
+15 IF DGPROV=DGPCP
SET DGPP="1^PCMMTM"
End DoDot:1
+16 KILL ^TMP("DGPCMMLK",$JOB)
+17 ;
+18 QUIT DGPP
