ORQPTQ1 ; SLC/CLA - Functs which return OR patient lists and sources pt 1 ;Mar 13, 2018@12:21
;;3.0;ORDER ENTRY/RESULTS REPORTING;**9,74,63,91,85,139,243,449,377**;Dec 17, 1997;Build 582
;
;
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(ORY) ; return current user's default team list
Q:'$D(DUZ)
N ORSRV S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U)
S ORY=$$GET^XPAR("USR^SRV.`"_+$G(ORSRV),"ORLP DEFAULT TEAM",1,"B")
Q
TEAMS(ORY) ; return list of teams for a system
; Also called under DBIA # 2692.
N LAST,N12,ORTM,I,ORTMN
S ORTMN="",I=1
F S ORTMN=$O(^OR(100.21,"B",ORTMN)) Q:ORTMN="" D
.S ORTM="",ORTM=$O(^OR(100.21,"B",ORTMN,ORTM)) Q:ORTM=""
.S N12=$G(^OR(100.21,ORTM,12))
.I $P(N12,U,2)'="",+$P(N12,U)>0 S LAST=$$FMTE^XLFDT($P(N12,U))
.I $P(N12,U,2)=""!(+$P(N12,U)=0) S LAST=""
.I $P($G(^OR(100.21,ORTM,11)),U)'=0!($D(^OR(100.21,ORTM,1,$G(DUZ,0)))) S ORY(I)=ORTM_U_ORTMN_U_LAST,I=I+1
S:+$G(ORY(1))<1 ORY(1)="^No teams found."
Q
TEAMPTS(ORY,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 ORY, 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=ORY_1_")",@NEWTMP="^No team identified" Q
.I 'DOTMP S ORY(1)="^No team identified" Q
N ORI,ORPT,I
S I=0
S ORI=0 F S ORI=$O(^OR(100.21,+TEAM,10,ORI)) Q:ORI<1 D
.S ORPT=^OR(100.21,+TEAM,10,ORI,0)
.I DOTMP D
..S I=I+1,NEWTMP=ORY_+I_")"
..S @NEWTMP=+ORPT_U_$P(^DPT(+ORPT,0),U)
.I 'DOTMP S I=I+1,ORY(I)=+ORPT_U_$P(^DPT(+ORPT,0),U)
I DOTMP S:I<1 NEWTMP=ORY_1_")",@NEWTMP="^No patients found."
I 'DOTMP S:I<1 ORY(1)="^No patients found."
Q
PTEAMPTS(ORY,TEAM,TMPFLAG) ; RETURN LIST OF PATIENTS ASSIGNED TO A PCMM TEAM
; This tag section added by TDP on 5/21/2014
; If TMPFLAG passed and = TRUE, code expects a "^TMP(xxx"
; global root string passed in ORY, 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=ORY_1_")",@NEWTMP="^No PCMM team identified" Q
.I 'DOTMP S ORY(1)="^No PCMM team identified" Q
N I,ORERR,ORI,ORLST,ORPT,ORRSLT
K ^TMP("ORPCMMPT",$J),^TMP("SCERR",$J)
S ORRSLT=$$PTTM^SCAPMC(+TEAM,,"^TMP(""ORPCMMPT"",$J)",)
I $D(^TMP("ORPCMMPT",$J)) D
. S I=0
. S ORI=0
. F S ORI=$O(^TMP("ORPCMMPT",$J,ORI)) Q:ORI<1 D
.. S I=I+1
.. S ORPT=$G(^TMP("ORPCMMPT",$J,ORI))
.. I DOTMP D
... S NEWTMP=ORY_+I_")"
... S @NEWTMP=$P(ORPT,U,1,2)
.. I 'DOTMP S ORY(I)=$P(ORPT,U,1,2)
I '$D(^TMP("ORPCMMPT",$J)) D
. I DOTMP D
.. S NEWTMP=ORY_1_")"
.. S @NEWTMP="^No patients found."
. I 'DOTMP S ORY(1)="^No patients found."
K ^TMP("ORPCMMPT",$J),^TMP("SCERR",$J)
Q
TEAMPR(ORY,PROV) ; return list of teams linked to a provider
I +$G(PROV)<1 S ORY(1)="^No provider identified" Q
N ORTM,I,ORTMN
S ORTM="",I=1
F S ORTM=$O(^OR(100.21,"C",+PROV,ORTM)) Q:+$G(ORTM)<1 D
.S ORTMN=$P(^OR(100.21,ORTM,0),U)
.S ORY(I)=ORTM_U_ORTMN,I=I+1
S:+$G(ORY(1))<1 ORY(1)="^No teams found."
Q
PTEAMPR(ORY,PROV) ; return list of PCMM teams for a provider
; This tag section added by TDP on 5/21/2014
N I,ORI,ORRSLT,ORTM,ORTMN
I +$G(PROV)'>0 S PROV=DUZ
K ^TMP("ORPCMMPTM",$J),^TMP("SCERR",$J)
S ORRSLT=$$TMPR^SCAPMC(+PROV,,,"^TMP(""ORPCMMPTM"",$J)",)
I $D(^TMP("ORPCMMPTM",$J)) D
. S ORTM=""
. S I=0
. S ORI=0
. F S ORI=$O(^TMP("ORPCMMPTM",$J,ORI)) Q:+ORI<1 D
.. S I=I+1
.. S ORTM=$G(^TMP("ORPCMMPTM",$J,ORI))
.. S ORY(I)=$P(ORTM,U,1,2)_"^PCMM"
S:+$G(ORY(1))<1 ORY(1)="^No PCMM teams found."
K ^TMP("ORPCMMPTM",$J),^TMP("SCERR",$J)
Q
TEAMPR2(ORY,PROV) ; return list of teams linked to a provider
; This tag added by PKS/slc - 8/1999.
I +$G(PROV)<1 S ORY(1)="^No provider identified" Q
N ORTM,ORDATA,ORTMN,ORTYPE,I
S ORTM="",I=1
F S ORTM=$O(^OR(100.21,"C",+PROV,ORTM)) Q:+$G(ORTM)<1 D
.S ORDATA=^OR(100.21,ORTM,0) ; Get value.
.S ORTMN=$P(ORDATA,U) ; Team List name.
.S ORTYPE=$P(ORDATA,U,2) ; Team List type.
.S ORY(I)=ORTM_U_ORTMN_U_ORTYPE,I=I+1
S:+$G(ORY(1))<1 ORY(1)="^No teams found."
Q
TEAMPROV(ORY,TEAM) ; return list of providers linked to a team
I +$G(TEAM)<1 S ORY(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 ORY(I)=+PROV_U_$P(^VA(200,+PROV,0),U),I=I+1
S:+$G(ORY(1))<1 ORY(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("ORLPUPT",$J,"^No provider identified")=""
N ORTM,ORTMN,ORI,ORPT
S ORTM=""
F S ORTM=$O(^OR(100.21,"C",+PROV,ORTM)) Q:+$G(ORTM)<1 D ; Teams.
.S ORTMN=$P(^OR(100.21,+ORTM,0),U,1) ; Get name of Team List.
.S ORI=0 F S ORI=$O(^OR(100.21,+ORTM,10,ORI)) Q:ORI<1 D
..S ORPT=^OR(100.21,+ORTM,10,ORI,0)
..S ^TMP("ORLPUPT",$J,+ORPT_U_$P(^DPT(+ORPT,0),U))=""
..; Next line added by PKS:
..S ^TMP("ORLPUPT",$J,"B",ORTMN,$P(^DPT(+ORPT,0),U)_U_+ORPT)=""
I '$D(^TMP("ORLPUPT",$J)) S ^TMP("ORLPUPT",$J,"^No patients found.")=""
Q
TMSPT(ORY,PT) ;return list of teams linked to a patient (patient is active)
I +$G(PT)<1 S ORY(1)="^No patient identified" Q
N ORTM,I,ORTMN,ORTMTYP
S ORTM="",I=1
F S ORTM=$O(^OR(100.21,"AB",+PT_";DPT(",ORTM)) Q:+$G(ORTM)<1 D
.I '$D(^OR(100.21,ORTM)) Q
.S ORTMN=$P(^OR(100.21,ORTM,0),U)
.S ORTMTYP=$P(^OR(100.21,ORTM,0),U,2) I $L(ORTMTYP) D
..S ORTMTYP=$$EXTERNAL^DILFD(100.21,1,"",ORTMTYP,"")
.S ORY(I)=ORTM_U_ORTMN_U_$S($L(ORTMTYP):ORTMTYP,1:"no type"),I=I+1
S:+$G(ORY(1))<1 ORY(1)="^No teams found."
Q
TPTPR(ORY,PT) ;return list of providers linked to a patient via teams
I +$G(PT)<1 S ORY(1)="^No patient identified" Q
N ORTM,PROV,SEQ
S ORTM=""
F S ORTM=$O(^OR(100.21,"AB",+PT_";DPT(",ORTM)) Q:+$G(ORTM)<1 D
.S SEQ=0 F S SEQ=$O(^OR(100.21,+ORTM,1,SEQ)) Q:SEQ<1 D
..S PROV=^OR(100.21,+ORTM,1,SEQ,0) I $L(PROV) D
...S ORY(+PROV)=+PROV_U_$P(^VA(200,+PROV,0),U)
S:'$D(ORY) ORY(1)="^No providers found."
Q
PERSPR(ORY) ; return list of personal lists linked to current user
N ORTM,I,ORTMN
S ORTM="",I=1
F S ORTM=$O(^OR(100.21,"C",DUZ,ORTM)) Q:+$G(ORTM)<1 D
.Q:$P(^OR(100.21,ORTM,0),U,2)'="P" ;quit if not a personal list
.S ORTMN=$P(^OR(100.21,ORTM,0),U)
.S ORY(I)=ORTM_U_ORTMN,I=I+1
S:+$G(ORY(1))<1 ORY(1)="^No personal lists found."
Q
PRIMPT(ORY,ORPT) ; return patient's PCMM primary care team
I +$G(ORPT)<1 S ORY(1)="^No patient identified"
N ORQPUR,ORQERROR,ORQLST,ORQERR,ORQDT,ORIDT,ORADT,ORX
S ORQPUR(2)="" ;"2" is the ien for purpose "primary care" [^SD(403.47]
D NOW^%DTC S ORQDT("BEGIN")=%-.0001,ORQDT("END")=%+.0001,ORQDT("INCL")=0
S ORQERROR=$$TMPT^SCAPMC(.ORPT,"ORQDT","ORQPUR","ORQLST","ORQERR")
I ORQERROR=0 S ORY="^Error in search for primary care team."
I +$G(ORQLST(1))>0 D
.S ORX=ORQLST(1),ORADT=$P(ORX,U,4),ORIDT=$P(ORX,U,5)
.I ($G(ORADT)>$G(ORIDT)) S ORY=$P(ORX,U)_U_$P(ORX,U,2)
S:+$G(ORY)<1 ORY="^No primary care team found."
K %
Q
PROVPT(ORY,ORPT) ; return PCMM primary provider for a patient
I +$G(ORPT)<1 S ORY(1)="^No patient identified"
S ORY(1)=$$OUTPTPR^SDUTL3(ORPT,$$NOW^XLFDT,1)
Q
PPLINK(ORPROV,ORPT) ; returns '1' if patient is linked to provider
N ORX,ORPP
S ORX="",ORPP=0
I (+$G(ORPT)<1)!(+$G(ORPROV)<1) Q 0
I $D(^DPT("APR",ORPROV,ORPT)) Q "1^PRIM" ;provider is patient's primary
I $D(^DPT("AAP",ORPROV,ORPT)) Q "1^ATTD" ;provider is patient's attending
;is provider and patient on the same team:
D TPROVPT(ORPROV)
F S ORX=$O(^TMP("ORLPUPT",$J,ORX)) Q:ORX="" D
.I +ORX=ORPT S ORPP="1^OERRTM" Q
K ^TMP("ORLPUPT",$J)
;
;If not linked already, see if linked via PCMM:
I ORPP=0 S ORPP=$$PCMMLINK(ORPROV,ORPT)
;
Q ORPP
PDLINK(ORDEV,ORPT) ; returns '1' if patient is linked to device via team
;ORDEV can be either ien or device name
N ORY,ORX,ORTM,ORDP,ORTMDEV,ORDEVIEN
S ORDP=0
I (+$G(ORPT)<1)!($L($G(ORDEV))<1) Q 0
; Are device and patient on the same team?:
I '$D(^%ZIS(1,ORDEV,0)) D ;ORDEV is not an ien
.S ORDEVIEN=0,ORDEVIEN=$O(^%ZIS(1,"B",$P(ORDEV,U),ORDEVIEN))
.S ORDEV=ORDEVIEN
Q:+$G(ORDEV)<1 0
D TMSPT(.ORY,ORPT)
S ORX="" F S ORX=$O(ORY(ORX)) Q:ORX="" D
.S ORTM=ORY(ORX)
.I $D(^OR(100.21,+ORTM,0)),$P(^(0),U,4)=ORDEV S ORDP=1 Q
Q ORDP
PCMMLINK(ORPROV,ORPT) ;returns '1' if patient is linked to provider via PCMM
N ORPP,ORPCMM,ORPCP
S ORPP=0
I (+$G(ORPT)<1)!(+$G(ORPROV)<1) Q 0
;
;provider is patient's PCMM primary care practitioner:
I ORPROV=+$$OUTPTPR^SDUTL3(ORPT,$$NOW^XLFDT,1) Q "1^PCP" ;DBIA #1252
;
;provider is patient's PCMM associate provider:
I ORPROV=+$$OUTPTAP^SDUTL3(ORPT,$$NOW^XLFDT) Q "1^AP" ;DBIA #1252
;
;provider is linked to patient via PCMM team position assignment:
S ORPCMM=$$PRPT^SCAPMC(ORPT,,,,,,"^TMP(""ORPCMMLK"",$J)",) ;DBIA #1916
S ORPCP=0
F S ORPCP=$O(^TMP("ORPCMMLK",$J,"SCPR",ORPCP)) Q:'ORPCP!ORPP=1 D
.I ORPROV=ORPCP S ORPP="1^PCMMTM"
K ^TMP("ORPCMMLK",$J)
;
Q ORPP
PUNSIGN(ORY,ORBDFN) ;rtns array of providers with unsigned orders for pt
N ORDG,ORX,ORZ,ORDNUM
S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien
K ^TMP("ORR",$J)
;get unsigned orders:
D EN^ORQ1(ORBDFN_";DPT(",ORDG,11,"","","",0,0)
S ORX="",ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX=""
I +$G(^TMP("ORR",$J,ORX,"TOT"))>0 D
.S ORX="" F S ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX="" D
..S ORZ="" F S ORZ=$O(^TMP("ORR",$J,ORX,ORZ)) Q:+$G(ORZ)<1 D
...S ORDNUM=^TMP("ORR",$J,ORX,ORZ)
...S ORY(+$$UNSIGNOR^ORQOR2(+ORDNUM))=""
K ^TMP("ORR",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORQPTQ1 10460 printed Dec 13, 2024@02:33:25 Page 2
ORQPTQ1 ; SLC/CLA - Functs which return OR patient lists and sources pt 1 ;Mar 13, 2018@12:21
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**9,74,63,91,85,139,243,449,377**;Dec 17, 1997;Build 582
+2 ;
+3 ;
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(ORY) ; return current user's default team list
+1 if '$DATA(DUZ)
QUIT
+2 NEW ORSRV
SET ORSRV=$GET(^VA(200,DUZ,5))
IF +ORSRV>0
SET ORSRV=$PIECE(ORSRV,U)
+3 SET ORY=$$GET^XPAR("USR^SRV.`"_+$GET(ORSRV),"ORLP DEFAULT TEAM",1,"B")
+4 QUIT
TEAMS(ORY) ; return list of teams for a system
+1 ; Also called under DBIA # 2692.
+2 NEW LAST,N12,ORTM,I,ORTMN
+3 SET ORTMN=""
SET I=1
+4 FOR
SET ORTMN=$ORDER(^OR(100.21,"B",ORTMN))
if ORTMN=""
QUIT
Begin DoDot:1
+5 SET ORTM=""
SET ORTM=$ORDER(^OR(100.21,"B",ORTMN,ORTM))
if ORTM=""
QUIT
+6 SET N12=$GET(^OR(100.21,ORTM,12))
+7 IF $PIECE(N12,U,2)'=""
IF +$PIECE(N12,U)>0
SET LAST=$$FMTE^XLFDT($PIECE(N12,U))
+8 IF $PIECE(N12,U,2)=""!(+$PIECE(N12,U)=0)
SET LAST=""
+9 IF $PIECE($GET(^OR(100.21,ORTM,11)),U)'=0!($DATA(^OR(100.21,ORTM,1,$GET(DUZ,0))))
SET ORY(I)=ORTM_U_ORTMN_U_LAST
SET I=I+1
End DoDot:1
+10 if +$GET(ORY(1))<1
SET ORY(1)="^No teams found."
+11 QUIT
TEAMPTS(ORY,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 ORY, 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=ORY_1_")"
SET @NEWTMP="^No team identified"
QUIT
+11 IF 'DOTMP
SET ORY(1)="^No team identified"
QUIT
End DoDot:1
+12 NEW ORI,ORPT,I
+13 SET I=0
+14 SET ORI=0
FOR
SET ORI=$ORDER(^OR(100.21,+TEAM,10,ORI))
if ORI<1
QUIT
Begin DoDot:1
+15 SET ORPT=^OR(100.21,+TEAM,10,ORI,0)
+16 IF DOTMP
Begin DoDot:2
+17 SET I=I+1
SET NEWTMP=ORY_+I_")"
+18 SET @NEWTMP=+ORPT_U_$PIECE(^DPT(+ORPT,0),U)
End DoDot:2
+19 IF 'DOTMP
SET I=I+1
SET ORY(I)=+ORPT_U_$PIECE(^DPT(+ORPT,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 ORY(1)="^No patients found."
+22 QUIT
PTEAMPTS(ORY,TEAM,TMPFLAG) ; RETURN LIST OF PATIENTS ASSIGNED TO A PCMM TEAM
+1 ; This tag section added by TDP on 5/21/2014
+2 ; If TMPFLAG passed and = TRUE, code expects a "^TMP(xxx"
+3 ; global root string passed in ORY, 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=ORY_1_")"
SET @NEWTMP="^No PCMM team identified"
QUIT
+11 IF 'DOTMP
SET ORY(1)="^No PCMM team identified"
QUIT
End DoDot:1
+12 NEW I,ORERR,ORI,ORLST,ORPT,ORRSLT
+13 KILL ^TMP("ORPCMMPT",$JOB),^TMP("SCERR",$JOB)
+14 SET ORRSLT=$$PTTM^SCAPMC(+TEAM,,"^TMP(""ORPCMMPT"",$J)",)
+15 IF $DATA(^TMP("ORPCMMPT",$JOB))
Begin DoDot:1
+16 SET I=0
+17 SET ORI=0
+18 FOR
SET ORI=$ORDER(^TMP("ORPCMMPT",$JOB,ORI))
if ORI<1
QUIT
Begin DoDot:2
+19 SET I=I+1
+20 SET ORPT=$GET(^TMP("ORPCMMPT",$JOB,ORI))
+21 IF DOTMP
Begin DoDot:3
+22 SET NEWTMP=ORY_+I_")"
+23 SET @NEWTMP=$PIECE(ORPT,U,1,2)
End DoDot:3
+24 IF 'DOTMP
SET ORY(I)=$PIECE(ORPT,U,1,2)
End DoDot:2
End DoDot:1
+25 IF '$DATA(^TMP("ORPCMMPT",$JOB))
Begin DoDot:1
+26 IF DOTMP
Begin DoDot:2
+27 SET NEWTMP=ORY_1_")"
+28 SET @NEWTMP="^No patients found."
End DoDot:2
+29 IF 'DOTMP
SET ORY(1)="^No patients found."
End DoDot:1
+30 KILL ^TMP("ORPCMMPT",$JOB),^TMP("SCERR",$JOB)
+31 QUIT
TEAMPR(ORY,PROV) ; return list of teams linked to a provider
+1 IF +$GET(PROV)<1
SET ORY(1)="^No provider identified"
QUIT
+2 NEW ORTM,I,ORTMN
+3 SET ORTM=""
SET I=1
+4 FOR
SET ORTM=$ORDER(^OR(100.21,"C",+PROV,ORTM))
if +$GET(ORTM)<1
QUIT
Begin DoDot:1
+5 SET ORTMN=$PIECE(^OR(100.21,ORTM,0),U)
+6 SET ORY(I)=ORTM_U_ORTMN
SET I=I+1
End DoDot:1
+7 if +$GET(ORY(1))<1
SET ORY(1)="^No teams found."
+8 QUIT
PTEAMPR(ORY,PROV) ; return list of PCMM teams for a provider
+1 ; This tag section added by TDP on 5/21/2014
+2 NEW I,ORI,ORRSLT,ORTM,ORTMN
+3 IF +$GET(PROV)'>0
SET PROV=DUZ
+4 KILL ^TMP("ORPCMMPTM",$JOB),^TMP("SCERR",$JOB)
+5 SET ORRSLT=$$TMPR^SCAPMC(+PROV,,,"^TMP(""ORPCMMPTM"",$J)",)
+6 IF $DATA(^TMP("ORPCMMPTM",$JOB))
Begin DoDot:1
+7 SET ORTM=""
+8 SET I=0
+9 SET ORI=0
+10 FOR
SET ORI=$ORDER(^TMP("ORPCMMPTM",$JOB,ORI))
if +ORI<1
QUIT
Begin DoDot:2
+11 SET I=I+1
+12 SET ORTM=$GET(^TMP("ORPCMMPTM",$JOB,ORI))
+13 SET ORY(I)=$PIECE(ORTM,U,1,2)_"^PCMM"
End DoDot:2
End DoDot:1
+14 if +$GET(ORY(1))<1
SET ORY(1)="^No PCMM teams found."
+15 KILL ^TMP("ORPCMMPTM",$JOB),^TMP("SCERR",$JOB)
+16 QUIT
TEAMPR2(ORY,PROV) ; return list of teams linked to a provider
+1 ; This tag added by PKS/slc - 8/1999.
+2 IF +$GET(PROV)<1
SET ORY(1)="^No provider identified"
QUIT
+3 NEW ORTM,ORDATA,ORTMN,ORTYPE,I
+4 SET ORTM=""
SET I=1
+5 FOR
SET ORTM=$ORDER(^OR(100.21,"C",+PROV,ORTM))
if +$GET(ORTM)<1
QUIT
Begin DoDot:1
+6 ; Get value.
SET ORDATA=^OR(100.21,ORTM,0)
+7 ; Team List name.
SET ORTMN=$PIECE(ORDATA,U)
+8 ; Team List type.
SET ORTYPE=$PIECE(ORDATA,U,2)
+9 SET ORY(I)=ORTM_U_ORTMN_U_ORTYPE
SET I=I+1
End DoDot:1
+10 if +$GET(ORY(1))<1
SET ORY(1)="^No teams found."
+11 QUIT
TEAMPROV(ORY,TEAM) ; return list of providers linked to a team
+1 IF +$GET(TEAM)<1
SET ORY(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 ORY(I)=+PROV_U_$PIECE(^VA(200,+PROV,0),U)
SET I=I+1
End DoDot:2
End DoDot:1
+7 if +$GET(ORY(1))<1
SET ORY(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("ORLPUPT",$JOB,"^No provider identified")=""
+3 NEW ORTM,ORTMN,ORI,ORPT
+4 SET ORTM=""
+5 ; Teams.
FOR
SET ORTM=$ORDER(^OR(100.21,"C",+PROV,ORTM))
if +$GET(ORTM)<1
QUIT
Begin DoDot:1
+6 ; Get name of Team List.
SET ORTMN=$PIECE(^OR(100.21,+ORTM,0),U,1)
+7 SET ORI=0
FOR
SET ORI=$ORDER(^OR(100.21,+ORTM,10,ORI))
if ORI<1
QUIT
Begin DoDot:2
+8 SET ORPT=^OR(100.21,+ORTM,10,ORI,0)
+9 SET ^TMP("ORLPUPT",$JOB,+ORPT_U_$PIECE(^DPT(+ORPT,0),U))=""
+10 ; Next line added by PKS:
+11 SET ^TMP("ORLPUPT",$JOB,"B",ORTMN,$PIECE(^DPT(+ORPT,0),U)_U_+ORPT)=""
End DoDot:2
End DoDot:1
+12 IF '$DATA(^TMP("ORLPUPT",$JOB))
SET ^TMP("ORLPUPT",$JOB,"^No patients found.")=""
+13 QUIT
TMSPT(ORY,PT) ;return list of teams linked to a patient (patient is active)
+1 IF +$GET(PT)<1
SET ORY(1)="^No patient identified"
QUIT
+2 NEW ORTM,I,ORTMN,ORTMTYP
+3 SET ORTM=""
SET I=1
+4 FOR
SET ORTM=$ORDER(^OR(100.21,"AB",+PT_";DPT(",ORTM))
if +$GET(ORTM)<1
QUIT
Begin DoDot:1
+5 IF '$DATA(^OR(100.21,ORTM))
QUIT
+6 SET ORTMN=$PIECE(^OR(100.21,ORTM,0),U)
+7 SET ORTMTYP=$PIECE(^OR(100.21,ORTM,0),U,2)
IF $LENGTH(ORTMTYP)
Begin DoDot:2
+8 SET ORTMTYP=$$EXTERNAL^DILFD(100.21,1,"",ORTMTYP,"")
End DoDot:2
+9 SET ORY(I)=ORTM_U_ORTMN_U_$SELECT($LENGTH(ORTMTYP):ORTMTYP,1:"no type")
SET I=I+1
End DoDot:1
+10 if +$GET(ORY(1))<1
SET ORY(1)="^No teams found."
+11 QUIT
TPTPR(ORY,PT) ;return list of providers linked to a patient via teams
+1 IF +$GET(PT)<1
SET ORY(1)="^No patient identified"
QUIT
+2 NEW ORTM,PROV,SEQ
+3 SET ORTM=""
+4 FOR
SET ORTM=$ORDER(^OR(100.21,"AB",+PT_";DPT(",ORTM))
if +$GET(ORTM)<1
QUIT
Begin DoDot:1
+5 SET SEQ=0
FOR
SET SEQ=$ORDER(^OR(100.21,+ORTM,1,SEQ))
if SEQ<1
QUIT
Begin DoDot:2
+6 SET PROV=^OR(100.21,+ORTM,1,SEQ,0)
IF $LENGTH(PROV)
Begin DoDot:3
+7 SET ORY(+PROV)=+PROV_U_$PIECE(^VA(200,+PROV,0),U)
End DoDot:3
End DoDot:2
End DoDot:1
+8 if '$DATA(ORY)
SET ORY(1)="^No providers found."
+9 QUIT
PERSPR(ORY) ; return list of personal lists linked to current user
+1 NEW ORTM,I,ORTMN
+2 SET ORTM=""
SET I=1
+3 FOR
SET ORTM=$ORDER(^OR(100.21,"C",DUZ,ORTM))
if +$GET(ORTM)<1
QUIT
Begin DoDot:1
+4 ;quit if not a personal list
if $PIECE(^OR(100.21,ORTM,0),U,2)'="P"
QUIT
+5 SET ORTMN=$PIECE(^OR(100.21,ORTM,0),U)
+6 SET ORY(I)=ORTM_U_ORTMN
SET I=I+1
End DoDot:1
+7 if +$GET(ORY(1))<1
SET ORY(1)="^No personal lists found."
+8 QUIT
PRIMPT(ORY,ORPT) ; return patient's PCMM primary care team
+1 IF +$GET(ORPT)<1
SET ORY(1)="^No patient identified"
+2 NEW ORQPUR,ORQERROR,ORQLST,ORQERR,ORQDT,ORIDT,ORADT,ORX
+3 ;"2" is the ien for purpose "primary care" [^SD(403.47]
SET ORQPUR(2)=""
+4 DO NOW^%DTC
SET ORQDT("BEGIN")=%-.0001
SET ORQDT("END")=%+.0001
SET ORQDT("INCL")=0
+5 SET ORQERROR=$$TMPT^SCAPMC(.ORPT,"ORQDT","ORQPUR","ORQLST","ORQERR")
+6 IF ORQERROR=0
SET ORY="^Error in search for primary care team."
+7 IF +$GET(ORQLST(1))>0
Begin DoDot:1
+8 SET ORX=ORQLST(1)
SET ORADT=$PIECE(ORX,U,4)
SET ORIDT=$PIECE(ORX,U,5)
+9 IF ($GET(ORADT)>$GET(ORIDT))
SET ORY=$PIECE(ORX,U)_U_$PIECE(ORX,U,2)
End DoDot:1
+10 if +$GET(ORY)<1
SET ORY="^No primary care team found."
+11 KILL %
+12 QUIT
PROVPT(ORY,ORPT) ; return PCMM primary provider for a patient
+1 IF +$GET(ORPT)<1
SET ORY(1)="^No patient identified"
+2 SET ORY(1)=$$OUTPTPR^SDUTL3(ORPT,$$NOW^XLFDT,1)
+3 QUIT
PPLINK(ORPROV,ORPT) ; returns '1' if patient is linked to provider
+1 NEW ORX,ORPP
+2 SET ORX=""
SET ORPP=0
+3 IF (+$GET(ORPT)<1)!(+$GET(ORPROV)<1)
QUIT 0
+4 ;provider is patient's primary
IF $DATA(^DPT("APR",ORPROV,ORPT))
QUIT "1^PRIM"
+5 ;provider is patient's attending
IF $DATA(^DPT("AAP",ORPROV,ORPT))
QUIT "1^ATTD"
+6 ;is provider and patient on the same team:
+7 DO TPROVPT(ORPROV)
+8 FOR
SET ORX=$ORDER(^TMP("ORLPUPT",$JOB,ORX))
if ORX=""
QUIT
Begin DoDot:1
+9 IF +ORX=ORPT
SET ORPP="1^OERRTM"
QUIT
End DoDot:1
+10 KILL ^TMP("ORLPUPT",$JOB)
+11 ;
+12 ;If not linked already, see if linked via PCMM:
+13 IF ORPP=0
SET ORPP=$$PCMMLINK(ORPROV,ORPT)
+14 ;
+15 QUIT ORPP
PDLINK(ORDEV,ORPT) ; returns '1' if patient is linked to device via team
+1 ;ORDEV can be either ien or device name
+2 NEW ORY,ORX,ORTM,ORDP,ORTMDEV,ORDEVIEN
+3 SET ORDP=0
+4 IF (+$GET(ORPT)<1)!($LENGTH($GET(ORDEV))<1)
QUIT 0
+5 ; Are device and patient on the same team?:
+6 ;ORDEV is not an ien
IF '$DATA(^%ZIS(1,ORDEV,0))
Begin DoDot:1
+7 SET ORDEVIEN=0
SET ORDEVIEN=$ORDER(^%ZIS(1,"B",$PIECE(ORDEV,U),ORDEVIEN))
+8 SET ORDEV=ORDEVIEN
End DoDot:1
+9 if +$GET(ORDEV)<1
QUIT 0
+10 DO TMSPT(.ORY,ORPT)
+11 SET ORX=""
FOR
SET ORX=$ORDER(ORY(ORX))
if ORX=""
QUIT
Begin DoDot:1
+12 SET ORTM=ORY(ORX)
+13 IF $DATA(^OR(100.21,+ORTM,0))
IF $PIECE(^(0),U,4)=ORDEV
SET ORDP=1
QUIT
End DoDot:1
+14 QUIT ORDP
PCMMLINK(ORPROV,ORPT) ;returns '1' if patient is linked to provider via PCMM
+1 NEW ORPP,ORPCMM,ORPCP
+2 SET ORPP=0
+3 IF (+$GET(ORPT)<1)!(+$GET(ORPROV)<1)
QUIT 0
+4 ;
+5 ;provider is patient's PCMM primary care practitioner:
+6 ;DBIA #1252
IF ORPROV=+$$OUTPTPR^SDUTL3(ORPT,$$NOW^XLFDT,1)
QUIT "1^PCP"
+7 ;
+8 ;provider is patient's PCMM associate provider:
+9 ;DBIA #1252
IF ORPROV=+$$OUTPTAP^SDUTL3(ORPT,$$NOW^XLFDT)
QUIT "1^AP"
+10 ;
+11 ;provider is linked to patient via PCMM team position assignment:
+12 ;DBIA #1916
SET ORPCMM=$$PRPT^SCAPMC(ORPT,,,,,,"^TMP(""ORPCMMLK"",$J)",)
+13 SET ORPCP=0
+14 FOR
SET ORPCP=$ORDER(^TMP("ORPCMMLK",$JOB,"SCPR",ORPCP))
if 'ORPCP!ORPP=1
QUIT
Begin DoDot:1
+15 IF ORPROV=ORPCP
SET ORPP="1^PCMMTM"
End DoDot:1
+16 KILL ^TMP("ORPCMMLK",$JOB)
+17 ;
+18 QUIT ORPP
PUNSIGN(ORY,ORBDFN) ;rtns array of providers with unsigned orders for pt
+1 NEW ORDG,ORX,ORZ,ORDNUM
+2 ;get Display Group ien
SET ORDG=$$DG^ORQOR1("ALL")
+3 KILL ^TMP("ORR",$JOB)
+4 ;get unsigned orders:
+5 DO EN^ORQ1(ORBDFN_";DPT(",ORDG,11,"","","",0,0)
+6 SET ORX=""
SET ORX=$ORDER(^TMP("ORR",$JOB,ORX))
if ORX=""
QUIT
+7 IF +$GET(^TMP("ORR",$JOB,ORX,"TOT"))>0
Begin DoDot:1
+8 SET ORX=""
FOR
SET ORX=$ORDER(^TMP("ORR",$JOB,ORX))
if ORX=""
QUIT
Begin DoDot:2
+9 SET ORZ=""
FOR
SET ORZ=$ORDER(^TMP("ORR",$JOB,ORX,ORZ))
if +$GET(ORZ)<1
QUIT
Begin DoDot:3
+10 SET ORDNUM=^TMP("ORR",$JOB,ORX,ORZ)
+11 SET ORY(+$$UNSIGNOR^ORQOR2(+ORDNUM))=""
End DoDot:3
End DoDot:2
End DoDot:1
+12 KILL ^TMP("ORR",$JOB)
+13 QUIT
