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