VPRPCMM ;SLC/MKB/BLJ -- PCMM Utilities ;2/20/20 14:58
;;1.0;VIRTUAL PATIENT RECORD;**24,28**;Sep 01, 2011;Build 6
;;Per VA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; SCMC PATIENT TEAM CHANGES 7012
; SCMC PATIENT TEAM POSITION 7013
; ^SCTM(404.52 7174
; %DTC
; %ZTLOAD 10063
; DIQ 2056
; SCAPMC 1916
; SDUTL3 1252
;
PCP ; -- get DLIST(#)=ien^role of PCP, team members
; Expects DFN, VPRTEAM = ien^name of PCTeam
N PCP,ALL S PCP=$$OUTPTPR^SDUTL3(DFN)
S:PCP>0 DLIST(1)=+PCP_"^PRIMARY CARE PROVIDER"
S ALL=$$PRPT^SCAPMC(DFN,,,,,,"VPRPTP") ;all prov's assigned to pt
MBRS ; -- enter here for just team members [expects VPRTEAM, VPRPTP]
N VPRTM,VPRN,PRV,ROLE
Q:'$G(VPRTEAM) ;set by *TeamName property
Q:'$$PRTM^SCAPMC(+$G(VPRTEAM),,,,"VPRTM") ;team members
S VPRN=+$O(DLIST("A"),-1)
S PRV=0 F S PRV=$O(VPRTM("SCPR",PRV)) Q:PRV<1 I PRV'=+$G(PCP) D
. S ROLE=+$O(VPRTM("SCPR",PRV,0))
. Q:'$D(VPRPTP("SCPR",PRV,ROLE)) ;not assigned to pt
. S VPRN=VPRN+1,DLIST(VPRN)=PRV_U_$$GET1^DIQ(404.57,ROLE,.01)
. ; provider #200 ien ^ position name
Q
;
MHTEAM(DFN) ; -- returns ien^name of MH Team, or ""
N X,Y,VPRP,VPRTM
S VPRP(4)="",X=$$TMPT^SCAPMC(DFN,,"VPRP","VPRTM"),Y=""
I X S Y=$G(VPRTM(1))
Q Y
;
PTEVT ; -- SCMC PATIENT TEAM CHANGES protocol listener
;I '$G(SCPCTM) Q ;not pc change
N DFN S DFN=$S($G(SCPTTMAF):+SCPTTMAF,1:+$G(SCPTTMB4)) Q:'DFN
D QUE^VPRHS(DFN) ;POST^VPRHS(DFN,"Patient",DFN_";2")
Q
;
PTPEVT ; -- SCMC PATIENT TEAM POSITION CHANGES protocol listener
;I '$G(SCPCTP) Q ;not pc change
N TM,DFN
S TM=$S($G(SCPTTPAF):+SCPTTPAF,1:+$G(SCPTTPB4)) Q:'TM
S DFN=+$$GET1^DIQ(404.42,TM_",",.01,"I")
D QUE^VPRHS(DFN) ;POST^VPRHS(DFN,"Patient",DFN_";2")
Q
;
PTPCEVT ; -- PROVIDER TEAM POSITION change tasked job.
N U S U="^"
N DFN,DATE,EFFDATE,POSITION,%
S EFFDATE=9999999
D NOW^%DTC S DATE=%-1 ; Get the last 24 hrs of changes.
F S EFFDATE=$O(^SCTM(404.52,"ADP",EFFDATE),-1) Q:EFFDATE<DATE D
.S POSITION=""
.F S POSITION=$O(^SCTM(404.52,"ADP",EFFDATE,POSITION)) Q:'POSITION D
..K ^TMP("SC TMP LIST",$J)
..Q:'$$PTTP^SCAPMC(POSITION)
..S DFN=0
..F S DFN=$O(^TMP("SC TMP LIST",$J,"SCPTA",DFN)) Q:+DFN<1 D QUE^VPRHS(DFN)
K ^TMP("SC TMP LIST",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRPCMM 2656 printed Dec 13, 2024@02:45:42 Page 2
VPRPCMM ;SLC/MKB/BLJ -- PCMM Utilities ;2/20/20 14:58
+1 ;;1.0;VIRTUAL PATIENT RECORD;**24,28**;Sep 01, 2011;Build 6
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; SCMC PATIENT TEAM CHANGES 7012
+7 ; SCMC PATIENT TEAM POSITION 7013
+8 ; ^SCTM(404.52 7174
+9 ; %DTC
+10 ; %ZTLOAD 10063
+11 ; DIQ 2056
+12 ; SCAPMC 1916
+13 ; SDUTL3 1252
+14 ;
PCP ; -- get DLIST(#)=ien^role of PCP, team members
+1 ; Expects DFN, VPRTEAM = ien^name of PCTeam
+2 NEW PCP,ALL
SET PCP=$$OUTPTPR^SDUTL3(DFN)
+3 if PCP>0
SET DLIST(1)=+PCP_"^PRIMARY CARE PROVIDER"
+4 ;all prov's assigned to pt
SET ALL=$$PRPT^SCAPMC(DFN,,,,,,"VPRPTP")
MBRS ; -- enter here for just team members [expects VPRTEAM, VPRPTP]
+1 NEW VPRTM,VPRN,PRV,ROLE
+2 ;set by *TeamName property
if '$GET(VPRTEAM)
QUIT
+3 ;team members
if '$$PRTM^SCAPMC(+$GET(VPRTEAM),,,,"VPRTM")
QUIT
+4 SET VPRN=+$ORDER(DLIST("A"),-1)
+5 SET PRV=0
FOR
SET PRV=$ORDER(VPRTM("SCPR",PRV))
if PRV<1
QUIT
IF PRV'=+$GET(PCP)
Begin DoDot:1
+6 SET ROLE=+$ORDER(VPRTM("SCPR",PRV,0))
+7 ;not assigned to pt
if '$DATA(VPRPTP("SCPR",PRV,ROLE))
QUIT
+8 SET VPRN=VPRN+1
SET DLIST(VPRN)=PRV_U_$$GET1^DIQ(404.57,ROLE,.01)
+9 ; provider #200 ien ^ position name
End DoDot:1
+10 QUIT
+11 ;
MHTEAM(DFN) ; -- returns ien^name of MH Team, or ""
+1 NEW X,Y,VPRP,VPRTM
+2 SET VPRP(4)=""
SET X=$$TMPT^SCAPMC(DFN,,"VPRP","VPRTM")
SET Y=""
+3 IF X
SET Y=$GET(VPRTM(1))
+4 QUIT Y
+5 ;
PTEVT ; -- SCMC PATIENT TEAM CHANGES protocol listener
+1 ;I '$G(SCPCTM) Q ;not pc change
+2 NEW DFN
SET DFN=$SELECT($GET(SCPTTMAF):+SCPTTMAF,1:+$GET(SCPTTMB4))
if 'DFN
QUIT
+3 ;POST^VPRHS(DFN,"Patient",DFN_";2")
DO QUE^VPRHS(DFN)
+4 QUIT
+5 ;
PTPEVT ; -- SCMC PATIENT TEAM POSITION CHANGES protocol listener
+1 ;I '$G(SCPCTP) Q ;not pc change
+2 NEW TM,DFN
+3 SET TM=$SELECT($GET(SCPTTPAF):+SCPTTPAF,1:+$GET(SCPTTPB4))
if 'TM
QUIT
+4 SET DFN=+$$GET1^DIQ(404.42,TM_",",.01,"I")
+5 ;POST^VPRHS(DFN,"Patient",DFN_";2")
DO QUE^VPRHS(DFN)
+6 QUIT
+7 ;
PTPCEVT ; -- PROVIDER TEAM POSITION change tasked job.
+1 NEW U
SET U="^"
+2 NEW DFN,DATE,EFFDATE,POSITION,%
+3 SET EFFDATE=9999999
+4 ; Get the last 24 hrs of changes.
DO NOW^%DTC
SET DATE=%-1
+5 FOR
SET EFFDATE=$ORDER(^SCTM(404.52,"ADP",EFFDATE),-1)
if EFFDATE<DATE
QUIT
Begin DoDot:1
+6 SET POSITION=""
+7 FOR
SET POSITION=$ORDER(^SCTM(404.52,"ADP",EFFDATE,POSITION))
if 'POSITION
QUIT
Begin DoDot:2
+8 KILL ^TMP("SC TMP LIST",$JOB)
+9 if '$$PTTP^SCAPMC(POSITION)
QUIT
+10 SET DFN=0
+11 FOR
SET DFN=$ORDER(^TMP("SC TMP LIST",$JOB,"SCPTA",DFN))
if +DFN<1
QUIT
DO QUE^VPRHS(DFN)
End DoDot:2
End DoDot:1
+12 KILL ^TMP("SC TMP LIST",$JOB)
+13 QUIT
