Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGQPTQ1

DGQPTQ1.m

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