SCMCTSK6 ;ALB/JDS - PCMM Bulletins ;01/28/2013
;;5.3;Scheduling;**297,532,581,603**;AUG 13, 1993;Build 79
;
Q
MAKEMAIL(TYPE) ;
N PRE,IN
S ZERO=$G(^SCPT(404.43,+ENTRY,0)),ZERO1=$G(^SCPT(404.42,+ZERO,0))
S T=+$P(ZERO1,U,3),IN=$P($G(^SCTM(404.51,T,0)),U,7) S INSTNM=$$GET1^DIQ(4,(+IN)_",",.01)
I INSTNM'=DIV S DIV=INSTNM D
.S ^TMP("SCMCTXT",$J,CNT,0)=" "
.S ^TMP("SCMCTXT",$J,CNT+1,0)=" INSTITUTION: "_DIV,CNT=CNT+2
S PROV=$P($$GETPRTP^SCAPMCU2(+$P(ZERO,U,2),DT),U,2)
S PRE=$P($$OKPREC2^SCMCLK(+$P(ZERO,U,2),DT),U,2)
S A=$E($$NAME^SCMCQK1(+ZERO1)_$J("",30),1,20)_" "_$E($$GET1^DIQ(2,(+ZERO1)_",",.0905)_$J("",5),2,5)_" "
S A=A_$E(PROV_$J("",20),1,17)_" "_$E($E($$TEAMNM^SCMCQK1(+$P(ZERO1,U,3)),1,14)_$J("",20),1,15)
;S A=A_" "_$E($$POSITION^SCMCQK1(+$P(ZERO,U,2))_$J("",20),1,20)
D INACTDT^SCMCTSK1(+ENTRY) S Y=X S:$G(TYPE)=2 Y=$P(ZERO,U,4),Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3),A=A_$E(Y_$J("",20),1,11)
I $G(TYPE)=3 S Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) S A=A_" "_$E(Y_$J("",20),1,11)
I $G(TYPE)=1 S Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) S A=A_" "_$E(Y_$J("",20),1,11)
I $G(TYPE)=2 S B=$P(ZERO,U,12),A=A_" "_$S(B="NA":"NO APPT",B="DU":"DECEASED",1:"Unknown")
S ^TMP("SCMCTXT",$J,CNT,0)=A
I PRE'=PROV I $L(PRE) S CNT=CNT+1,^TMP("SCMCTXT",$J,CNT,0)=$J("",26)_$E(PRE,1,17)
S CNT=CNT+1
Q
MM(TYPE) ;for providers
N EXP
;S Y=$P($G(^SCTM(404.52,+ENTRY,0)),U,10) I 'ALPHA D
S EXP=$$EN^SCMCTSKI(1)
;.;S X1=Y,X2=30 D C^%DTC I $E(X,6,7)<16 S $E(X,6,7)=15 Q
;.;S X=$S($E(X,4,5)=2:28,$E(X,4,5)=4:30,$E(X,4,5)=6:30,$E(X,4,5)=9:30,$E(X,4,5)=11:30,1:31)
;I ALPHA D
;.S X1=Y,X2=2 D C^%DTC
S EXP=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
S ZERO=$G(^SCTM(404.52,+ENTRY,0)) N CLI
S TP=$G(^SCTM(404.57,+ZERO,0)) D MAIL^SCMCTSK5(+ZERO,+$P(TP,U,2)) S T=$P(TP,U,2)
S ^TMP("SCML",$J,"POS",+$P(ZERO,U,3))=""
S ^TMP("SCML",$J,"XM",+$P(ZERO,U,3),+ZERO)=""
I TYPE=5 S Y=$P(ZERO,U,2),EXP=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)
S IN=$P($G(^SCTM(404.51,T,0)),U,7) S INSTNM=$$GET1^DIQ(4,(+IN)_",",.01)
I INSTNM'=DIV S DIV=INSTNM D
.S ^TMP("SCMCTXT",$J,CNT,0)=" "
.S ^TMP("SCMCTXT",$J,CNT+1,0)=" INSTITUTION: "_DIV,CNT=CNT+2
N I,CNT1 S CNT1=0
S ROLE=$P($G(^SD(403.46,+$P(TP,U,3),0)),U)
S PC=$P($$GET^XUA4A72(+$P(ZERO,U,3)),U,2)
I $G(^TMP("SCMCTXT",$J,3,0))["|POS|" S A=^(0),^(0)=$P(A,"|POS|")_$P(TP,U)_" ROLE: "_ROLE D
.S A=$G(^TMP("SCMCTXT",$J,5,0)),^(0)=$P(A,"|PC|")_PC
F I=0:0 S I=$O(^SCTM(404.57,+ZERO,5,I)) Q:'I S CLI(CNT1)=$P($G(^SC(I,0)),U),CNT1=CNT1+1
S A=$E($P($G(^VA(200,+$P(ZERO,U,3),0)),U)_$J("",20),1,14)_" "_$E($G(CLI(0))_$J("",10),1,9)
S A=A_" "_$E($P(TP,U)_$J("",20),1,10)_" "_$E(ROLE_$J("",20),1,14)
S A=A_" "_$E(PC_$J("",20),1,14)
S A=A_" "_$E($$PCPOSCNT^SCAPMCU1(+ZERO,DT,0)_$J("",9),1,4)_" "_EXP
S ^TMP("SCMCTXT",$J,CNT,0)=A
F I=1:1 Q:'$D(CLI(I)) I $L(CLI(I)) S CNT=CNT+1,^TMP("SCMCTXT",$J,CNT,0)=$J("",15)_$E(CLI(I),1,9)
S CNT=CNT+1
Q
PRMAIL(TYPE) ;
;Send mail to providers
N USER
F USER=0:0 S USER=$O(^TMP("SCML",$J,"XM",USER)) Q:'USER D
.F I=HEAD:0 S I=$O(^TMP("SCMCTXT",$J,I)) Q:'I K ^(I)
.I TYPE=5 D M5
.S CNT=HEAD,DIV=""
.F I=0:0 S I=$O(^TMP("SCMC",$J,I)) Q:'I S ENTRY=+$O(^(I,0)) D
..S ZERO=$G(^SCPT(404.43,+ENTRY,0)),ZERO1=$G(^SCPT(404.42,+ZERO,0))
..I TYPE>3 D Q
...S ZERO=$G(^SCTM(404.52,+ENTRY,0))
...I $D(^TMP("SCML",$J,"XM",USER,+ZERO)) D MM(TYPE)
..I $D(^TMP("SCML",$J,"XM",USER,+$P(ZERO,U,2))) D MAKEMAIL(TYPE)
.I CNT=HEAD Q
.S XMY(USER)="",XMTEXT="^TMP(""SCMCTXT"",$J,"
.S XMSUB="Patients Scheduled for Inactivation from PACT"
.I TYPE=3 S XMSUB="Patients With Extended PCMM Inactivation Date"
.I TYPE=2 S XMSUB="Patients Automated Inactivations from PACT"
.I TYPE=4 S XMSUB="Primary Care Providers Scheduled for Inactivation"
.I TYPE=5 Q ;S XMSUB="Primary Care Providers Inactivated"
.D ^XMD
Q
M5 ;Individual provider bulletin
Q:$G(^TMP("SCMCTXT",$J,1,0))["ATTENTION"
F I=1:1:CNT-1 Q:'$D(^TMP("SCMCTXT",$J,I)) S A=^(I,0),^TMP("SCMCTXT",$J,I+11,0)=A
F I=0:1:10 S A=$P($T(M6+I),";;",2),^TMP("SCMCTXT",$J,I+1,0)=A
S HEAD=HEAD+12
Q
M6 ;;ATTENTION: You may be inactivated as Primary Care Staff in the computer program
;;Primary Care Management Module (PCMM) VistA
;;Your Primary Care position |POS| Role |ROLE|
;;May not correspond to your Person Class of
;;|PC|
;;in VistA (file 200). Associate Primary Care Providers who provide Primary Care
;;must be a Resident or Intern (Physician) a Nurse Practitioner or a Physician's
;;Assistant. Primary Care Providers must be an Attending physician (MD or DO),
;;Nurse Practitioner or a Physician's Assistant
;;Please contact your PCMM Coordinator or information systems department if you
;;do not think you should be inactivated in PCMM as a provider.
Q
ACLIN ;Get sting of clinics in Alpha Order
S X=""
N A,I
F I=0:0 S I=$O(^SCTM(404.57,+$G(D0),5,I)) Q:'I S A=$P($G(^SC(I,0)),U) I $L(A) S A(A)=""
S A="" F S A=$O(A(A)) Q:A="" S X=X_$E(A,1,5)_U
S X=$P(X,U,1,$S(X[U:$L(X,U)-1,1:1))
Q
BULL ;
N FLDS
S DISUPNO=1
K ^TMP("SCMC",$J),^TMP("SCMCTXT",$J),^TMP("SCML",$J),XMY
S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")=""
S XMTEXT="^TMP(""SCMCTXT"",$J,"
S DIC="^SCTM(404.52,",BY="[SCMC PROVIDER INACTIVATED]",DHIT="S CNT=$G(CNT)+1,^TMP(""SCMC"",$J,CNT,D0)=""""",CNT=0
S FLDS="",IOP="",DHD="@@",FR="",TO="" D EN1^DIP
S XMSUB="Primary Care Providers Inactivated"
D LINES^SCMCTSK5(5)
D ^XMD
D PRMAIL^SCMCTSK5(5)
Q
FTERPT ;FTEE REPORT
D PROMPT^SCMCTSK3("FTEE AND PANEL SIZE")
Q:'$D(^TMP("SC",$J,"XR"))
;D FLAGG^SCMCTSK3
S Q=""""
S DIC="^SCTM(404.52,",L=0
D FTEE
S (SCDHD,DHD)="FTEE AND PANEL SIZE"
D BY^SCMCTSK2
S DIOBEG="D DIOBEG^SCMCTSK4"
S FLDS="[SCMC FTEE AND PANEL SIZE]"
I $D(^TMP("SC",$J,"SCLIN")) S FLDS="[SCMC FTEE 1 CLN]"
S DIOEND="D DIOEND^SCMCTSK7"
D EN1^DIP
Q
FTEE ;Sort FLAGGED
K ^TMP("SCSORT",$J)
N I,A,J
I '$D(^TMP("SC",$J,"SORT",1)) S ^(1)="DV^INSTITUTION^SCDIV",SORTN="INSTITUTION",^(2)="TM^TEAM^SCTEAM",^(3)="PR^PROVIDER^SCPROV"
N SORT S A="" F S A=$O(^TMP("SC",$J,A)) Q:A="" I "XRSORTDTR"'[A I $G(^(A))'="ALL" S SORT($S(A="ASPR":"PR",A="CLINIC":"EC",A="DIV":"DV",A="POS":"TP",1:"TM"))=""
F I=0:0 S I=$O(^SCTM(404.52,"AIDT",I)) Q:'I S K=$O(^SCTM(404.52,"AIDT",I,1,-9999999)) I K D
.I $O(^SCTM(404.52,"AIDT",I,0,K),-1) Q ;inactive
.S J=$O(^SCTM(404.52,"AIDT",I,1,K,0)) Q:'J
.D SORT(0)
Q
SORT(INACTIVE) ;
N A,B,C,D,E,QUIT,SCA,K,KCNT
S ZERO=$G(^SCTM(404.52,+J,0))
S QUIT=0,KCNT=0
F K=1:1 Q:'$D(^TMP("SC",$J,"SORT",K)) S A=^(K) K SORT($P(A,U)) S @("A("_K_")=$$"_$P(A,U)_"("_J_")") D I (A(K)=-1)!($P(A(K),U)="") S QUIT=1 Q
.I ($P(A,U)="EC")!($P(A,U)="AC") D
..I $L(A(K),U)>2 S KCNT=K
..N I F I=1:1:$L(A(K),U)-1 S ^TMP("SC",$J,"SCLIN",+ZERO,$P(A(K),U,I))=""
Q:QUIT
S A="" F S A=$O(SORT(A)) Q:A="" S @("B=$$"_A_"("_J_")") I B=-1 S QUIT=1 Q
Q:QUIT
F PIECE=1:1:$S(KCNT:$L(A(KCNT),U)-1,1:1) D
.S B="E" K @B
.F K=1:1:$O(A(99),-1) S @B@($P(A(K),U,$S(K=KCNT:PIECE,1:1)))="" S C=$Q(@B) K @B S B=C
.S @B@(J)=""
.M ^TMP("SCSORT",$J)=E
Q
DV(PP) ;return institution sort of patient assignment entry and then IEN of team^ien of position
N A,B,C,T,I,INSTNM,INSTN
S T=+$P($G(^SCTM(404.57,+ZERO,0)),U,2) I $D(INST(T)) Q INST(T)_U_T_U_(+ZERO)
S I=+$P($G(^SCTM(404.51,T,0)),U,7) I $O(^TMP("SC",$J,"DIV",0)) I '$D(^TMP("SC",$J,"DIV",I)) Q -1
S INSTNM=$$GET1^DIQ(4,(+I)_",",.01),INSTN=$$GET1^DIQ(4,(+I)_",",99)
S INST(T)=$S($L(INSTN)=3:INSTN_" ",1:"")_INSTNM Q INST(T)_U_T_U_(+ZERO)
EC(PP) Q $$AC(PP)
AC(PP) ;return enrolled clinics
N I,A
S A=""
F I=0:0 S I=$O(^SCTM(404.57,+ZERO,5,I)) Q:'I D
.;I '$$PTCL^SCRPO2(DFN,U_I,0,DT) Q ;not enrolled
.I $D(CLIN(I)) S A=A_CLIN(I)_U Q
.I $O(^TMP("SC",$J,"CLINIC",0)) I '$D(^(I)) Q
.S CLIN(I)=$P($G(^SC(I,0)),U) I $L(CLIN(I)) S A=A_CLIN(I)_U
Q $S(A="":-1,1:A)
TM(PP) ;Return Team
N I,A,T
S T=+$P($G(^SCTM(404.57,+ZERO,0)),U,2)
I $D(TEAM(T)) Q TEAM(T)
I $O(^TMP("SC",$J,"TEAM",0)) I '$D(^(T)) Q -1
S TEAM(T)=$P($G(^SCTM(404.51,+T,0)),U)
I '$L(TEAM(T)) K TEAM(T) Q -1
Q TEAM(T)
TP(A) ;return the team position
N TP S TP=+ZERO
I $O(^TMP("SC",$J,"POS",0)) I '$D(^(TP)) Q -1
Q $P($G(^SCTM(404.57,+TP,0)),U)
PR(PP) ;Return assigned provider
N A
I $O(^TMP("SC",$J,"ASPR",0)) I '$D(^(+$P(ZERO,U,3))) Q -1
S A=$$GET1^DIQ(200,(+$P(ZERO,U,3))_",",.01) Q $S(A="":-1,1:A)
Q
PCP(D0) ;PCP or AP
N A I +$P($G(^SCTM(404.57,D0,0)),U,4)=0 Q " " ;SD/581
S A=$O(^SCTM(404.53,"AIDT",D0,1,0),-1)
I 'A Q "PCP"
I $O(^SCTM(404.53,"AIDT",D0,0,A),-1) Q "PCP"
Q "AP"
CLN(D0) ;sorted by clinic get next one
N A S A=$O(^TMP("SC",$J,"SCLIN",D0,"")) Q:A=""
N I F I=0:0 S I=$O(^SC("B",A,I)) Q:'I I $D(^SCTM(404.57,D0,5,I)) Q
Q:'I
S DIPA("NUM")="`"_I K ^TMP("SC",$J,"SCLIN",D0,A)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCTSK6 8846 printed Sep 23, 2025@20:17:57 Page 2
SCMCTSK6 ;ALB/JDS - PCMM Bulletins ;01/28/2013
+1 ;;5.3;Scheduling;**297,532,581,603**;AUG 13, 1993;Build 79
+2 ;
+3 QUIT
MAKEMAIL(TYPE) ;
+1 NEW PRE,IN
+2 SET ZERO=$GET(^SCPT(404.43,+ENTRY,0))
SET ZERO1=$GET(^SCPT(404.42,+ZERO,0))
+3 SET T=+$PIECE(ZERO1,U,3)
SET IN=$PIECE($GET(^SCTM(404.51,T,0)),U,7)
SET INSTNM=$$GET1^DIQ(4,(+IN)_",",.01)
+4 IF INSTNM'=DIV
SET DIV=INSTNM
Begin DoDot:1
+5 SET ^TMP("SCMCTXT",$JOB,CNT,0)=" "
+6 SET ^TMP("SCMCTXT",$JOB,CNT+1,0)=" INSTITUTION: "_DIV
SET CNT=CNT+2
End DoDot:1
+7 SET PROV=$PIECE($$GETPRTP^SCAPMCU2(+$PIECE(ZERO,U,2),DT),U,2)
+8 SET PRE=$PIECE($$OKPREC2^SCMCLK(+$PIECE(ZERO,U,2),DT),U,2)
+9 SET A=$EXTRACT($$NAME^SCMCQK1(+ZERO1)_$JUSTIFY("",30),1,20)_" "_$EXTRACT($$GET1^DIQ(2,(+ZERO1)_",",.0905)_$JUSTIFY("",5),2,5)_" "
+10 SET A=A_$EXTRACT(PROV_$JUSTIFY("",20),1,17)_" "_$EXTRACT($EXTRACT($$TEAMNM^SCMCQK1(+$PIECE(ZERO1,U,3)),1,14)_$JUSTIFY("",20),1,15)
+11 ;S A=A_" "_$E($$POSITION^SCMCQK1(+$P(ZERO,U,2))_$J("",20),1,20)
+12 DO INACTDT^SCMCTSK1(+ENTRY)
SET Y=X
if $GET(TYPE)=2
SET Y=$PIECE(ZERO,U,4)
SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)
SET A=A_$EXTRACT(Y_$JUSTIFY("",20),1,11)
+13 IF $GET(TYPE)=3
SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)
SET A=A_" "_$EXTRACT(Y_$JUSTIFY("",20),1,11)
+14 IF $GET(TYPE)=1
SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)
SET A=A_" "_$EXTRACT(Y_$JUSTIFY("",20),1,11)
+15 IF $GET(TYPE)=2
SET B=$PIECE(ZERO,U,12)
SET A=A_" "_$SELECT(B="NA":"NO APPT",B="DU":"DECEASED",1:"Unknown")
+16 SET ^TMP("SCMCTXT",$JOB,CNT,0)=A
+17 IF PRE'=PROV
IF $LENGTH(PRE)
SET CNT=CNT+1
SET ^TMP("SCMCTXT",$JOB,CNT,0)=$JUSTIFY("",26)_$EXTRACT(PRE,1,17)
+18 SET CNT=CNT+1
+19 QUIT
MM(TYPE) ;for providers
+1 NEW EXP
+2 ;S Y=$P($G(^SCTM(404.52,+ENTRY,0)),U,10) I 'ALPHA D
+3 SET EXP=$$EN^SCMCTSKI(1)
+4 ;.;S X1=Y,X2=30 D C^%DTC I $E(X,6,7)<16 S $E(X,6,7)=15 Q
+5 ;.;S X=$S($E(X,4,5)=2:28,$E(X,4,5)=4:30,$E(X,4,5)=6:30,$E(X,4,5)=9:30,$E(X,4,5)=11:30,1:31)
+6 ;I ALPHA D
+7 ;.S X1=Y,X2=2 D C^%DTC
+8 SET EXP=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)
+9 SET ZERO=$GET(^SCTM(404.52,+ENTRY,0))
NEW CLI
+10 SET TP=$GET(^SCTM(404.57,+ZERO,0))
DO MAIL^SCMCTSK5(+ZERO,+$PIECE(TP,U,2))
SET T=$PIECE(TP,U,2)
+11 SET ^TMP("SCML",$JOB,"POS",+$PIECE(ZERO,U,3))=""
+12 SET ^TMP("SCML",$JOB,"XM",+$PIECE(ZERO,U,3),+ZERO)=""
+13 IF TYPE=5
SET Y=$PIECE(ZERO,U,2)
SET EXP=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)
+14 SET IN=$PIECE($GET(^SCTM(404.51,T,0)),U,7)
SET INSTNM=$$GET1^DIQ(4,(+IN)_",",.01)
+15 IF INSTNM'=DIV
SET DIV=INSTNM
Begin DoDot:1
+16 SET ^TMP("SCMCTXT",$JOB,CNT,0)=" "
+17 SET ^TMP("SCMCTXT",$JOB,CNT+1,0)=" INSTITUTION: "_DIV
SET CNT=CNT+2
End DoDot:1
+18 NEW I,CNT1
SET CNT1=0
+19 SET ROLE=$PIECE($GET(^SD(403.46,+$PIECE(TP,U,3),0)),U)
+20 SET PC=$PIECE($$GET^XUA4A72(+$PIECE(ZERO,U,3)),U,2)
+21 IF $GET(^TMP("SCMCTXT",$JOB,3,0))["|POS|"
SET A=^(0)
SET ^(0)=$PIECE(A,"|POS|")_$PIECE(TP,U)_" ROLE: "_ROLE
Begin DoDot:1
+22 SET A=$GET(^TMP("SCMCTXT",$JOB,5,0))
SET ^(0)=$PIECE(A,"|PC|")_PC
End DoDot:1
+23 FOR I=0:0
SET I=$ORDER(^SCTM(404.57,+ZERO,5,I))
if 'I
QUIT
SET CLI(CNT1)=$PIECE($GET(^SC(I,0)),U)
SET CNT1=CNT1+1
+24 SET A=$EXTRACT($PIECE($GET(^VA(200,+$PIECE(ZERO,U,3),0)),U)_$JUSTIFY("",20),1,14)_" "_$EXTRACT($GET(CLI(0))_$JUSTIFY("",10),1,9)
+25 SET A=A_" "_$EXTRACT($PIECE(TP,U)_$JUSTIFY("",20),1,10)_" "_$EXTRACT(ROLE_$JUSTIFY("",20),1,14)
+26 SET A=A_" "_$EXTRACT(PC_$JUSTIFY("",20),1,14)
+27 SET A=A_" "_$EXTRACT($$PCPOSCNT^SCAPMCU1(+ZERO,DT,0)_$JUSTIFY("",9),1,4)_" "_EXP
+28 SET ^TMP("SCMCTXT",$JOB,CNT,0)=A
+29 FOR I=1:1
if '$DATA(CLI(I))
QUIT
IF $LENGTH(CLI(I))
SET CNT=CNT+1
SET ^TMP("SCMCTXT",$JOB,CNT,0)=$JUSTIFY("",15)_$EXTRACT(CLI(I),1,9)
+30 SET CNT=CNT+1
+31 QUIT
PRMAIL(TYPE) ;
+1 ;Send mail to providers
+2 NEW USER
+3 FOR USER=0:0
SET USER=$ORDER(^TMP("SCML",$JOB,"XM",USER))
if 'USER
QUIT
Begin DoDot:1
+4 FOR I=HEAD:0
SET I=$ORDER(^TMP("SCMCTXT",$JOB,I))
if 'I
QUIT
KILL ^(I)
+5 IF TYPE=5
DO M5
+6 SET CNT=HEAD
SET DIV=""
+7 FOR I=0:0
SET I=$ORDER(^TMP("SCMC",$JOB,I))
if 'I
QUIT
SET ENTRY=+$ORDER(^(I,0))
Begin DoDot:2
+8 SET ZERO=$GET(^SCPT(404.43,+ENTRY,0))
SET ZERO1=$GET(^SCPT(404.42,+ZERO,0))
+9 IF TYPE>3
Begin DoDot:3
+10 SET ZERO=$GET(^SCTM(404.52,+ENTRY,0))
+11 IF $DATA(^TMP("SCML",$JOB,"XM",USER,+ZERO))
DO MM(TYPE)
End DoDot:3
QUIT
+12 IF $DATA(^TMP("SCML",$JOB,"XM",USER,+$PIECE(ZERO,U,2)))
DO MAKEMAIL(TYPE)
End DoDot:2
+13 IF CNT=HEAD
QUIT
+14 SET XMY(USER)=""
SET XMTEXT="^TMP(""SCMCTXT"",$J,"
+15 SET XMSUB="Patients Scheduled for Inactivation from PACT"
+16 IF TYPE=3
SET XMSUB="Patients With Extended PCMM Inactivation Date"
+17 IF TYPE=2
SET XMSUB="Patients Automated Inactivations from PACT"
+18 IF TYPE=4
SET XMSUB="Primary Care Providers Scheduled for Inactivation"
+19 ;S XMSUB="Primary Care Providers Inactivated"
IF TYPE=5
QUIT
+20 DO ^XMD
End DoDot:1
+21 QUIT
M5 ;Individual provider bulletin
+1 if $GET(^TMP("SCMCTXT",$JOB,1,0))["ATTENTION"
QUIT
+2 FOR I=1:1:CNT-1
if '$DATA(^TMP("SCMCTXT",$JOB,I))
QUIT
SET A=^(I,0)
SET ^TMP("SCMCTXT",$JOB,I+11,0)=A
+3 FOR I=0:1:10
SET A=$PIECE($TEXT(M6+I),";;",2)
SET ^TMP("SCMCTXT",$JOB,I+1,0)=A
+4 SET HEAD=HEAD+12
+5 QUIT
M6 ;;ATTENTION: You may be inactivated as Primary Care Staff in the computer program
+1 ;;Primary Care Management Module (PCMM) VistA
+2 ;;Your Primary Care position |POS| Role |ROLE|
+3 ;;May not correspond to your Person Class of
+4 ;;|PC|
+5 ;;in VistA (file 200). Associate Primary Care Providers who provide Primary Care
+6 ;;must be a Resident or Intern (Physician) a Nurse Practitioner or a Physician's
+7 ;;Assistant. Primary Care Providers must be an Attending physician (MD or DO),
+8 ;;Nurse Practitioner or a Physician's Assistant
+9 ;;Please contact your PCMM Coordinator or information systems department if you
+10 ;;do not think you should be inactivated in PCMM as a provider.
+11 QUIT
ACLIN ;Get sting of clinics in Alpha Order
+1 SET X=""
+2 NEW A,I
+3 FOR I=0:0
SET I=$ORDER(^SCTM(404.57,+$GET(D0),5,I))
if 'I
QUIT
SET A=$PIECE($GET(^SC(I,0)),U)
IF $LENGTH(A)
SET A(A)=""
+4 SET A=""
FOR
SET A=$ORDER(A(A))
if A=""
QUIT
SET X=X_$EXTRACT(A,1,5)_U
+5 SET X=$PIECE(X,U,1,$SELECT(X[U:$LENGTH(X,U)-1,1:1))
+6 QUIT
BULL ;
+1 NEW FLDS
+2 SET DISUPNO=1
+3 KILL ^TMP("SCMC",$JOB),^TMP("SCMCTXT",$JOB),^TMP("SCML",$JOB),XMY
+4 SET XMY("G.PCMM PATIENT/PROVIDER INACTIVE")=""
+5 SET XMTEXT="^TMP(""SCMCTXT"",$J,"
+6 SET DIC="^SCTM(404.52,"
SET BY="[SCMC PROVIDER INACTIVATED]"
SET DHIT="S CNT=$G(CNT)+1,^TMP(""SCMC"",$J,CNT,D0)="""""
SET CNT=0
+7 SET FLDS=""
SET IOP=""
SET DHD="@@"
SET FR=""
SET TO=""
DO EN1^DIP
+8 SET XMSUB="Primary Care Providers Inactivated"
+9 DO LINES^SCMCTSK5(5)
+10 DO ^XMD
+11 DO PRMAIL^SCMCTSK5(5)
+12 QUIT
FTERPT ;FTEE REPORT
+1 DO PROMPT^SCMCTSK3("FTEE AND PANEL SIZE")
+2 if '$DATA(^TMP("SC",$JOB,"XR"))
QUIT
+3 ;D FLAGG^SCMCTSK3
+4 SET Q=""""
+5 SET DIC="^SCTM(404.52,"
SET L=0
+6 DO FTEE
+7 SET (SCDHD,DHD)="FTEE AND PANEL SIZE"
+8 DO BY^SCMCTSK2
+9 SET DIOBEG="D DIOBEG^SCMCTSK4"
+10 SET FLDS="[SCMC FTEE AND PANEL SIZE]"
+11 IF $DATA(^TMP("SC",$JOB,"SCLIN"))
SET FLDS="[SCMC FTEE 1 CLN]"
+12 SET DIOEND="D DIOEND^SCMCTSK7"
+13 DO EN1^DIP
+14 QUIT
FTEE ;Sort FLAGGED
+1 KILL ^TMP("SCSORT",$JOB)
+2 NEW I,A,J
+3 IF '$DATA(^TMP("SC",$JOB,"SORT",1))
SET ^(1)="DV^INSTITUTION^SCDIV"
SET SORTN="INSTITUTION"
SET ^(2)="TM^TEAM^SCTEAM"
SET ^(3)="PR^PROVIDER^SCPROV"
+4 NEW SORT
SET A=""
FOR
SET A=$ORDER(^TMP("SC",$JOB,A))
if A=""
QUIT
IF "XRSORTDTR"'[A
IF $GET(^(A))'="ALL"
SET SORT($SELECT(A="ASPR":"PR",A="CLINIC":"EC",A="DIV":"DV",A="POS":"TP",1:"TM"))=""
+5 FOR I=0:0
SET I=$ORDER(^SCTM(404.52,"AIDT",I))
if 'I
QUIT
SET K=$ORDER(^SCTM(404.52,"AIDT",I,1,-9999999))
IF K
Begin DoDot:1
+6 ;inactive
IF $ORDER(^SCTM(404.52,"AIDT",I,0,K),-1)
QUIT
+7 SET J=$ORDER(^SCTM(404.52,"AIDT",I,1,K,0))
if 'J
QUIT
+8 DO SORT(0)
End DoDot:1
+9 QUIT
SORT(INACTIVE) ;
+1 NEW A,B,C,D,E,QUIT,SCA,K,KCNT
+2 SET ZERO=$GET(^SCTM(404.52,+J,0))
+3 SET QUIT=0
SET KCNT=0
+4 FOR K=1:1
if '$DATA(^TMP("SC",$JOB,"SORT",K))
QUIT
SET A=^(K)
KILL SORT($PIECE(A,U))
SET @("A("_K_")=$$"_$PIECE(A,U)_"("_J_")")
Begin DoDot:1
+5 IF ($PIECE(A,U)="EC")!($PIECE(A,U)="AC")
Begin DoDot:2
+6 IF $LENGTH(A(K),U)>2
SET KCNT=K
+7 NEW I
FOR I=1:1:$LENGTH(A(K),U)-1
SET ^TMP("SC",$JOB,"SCLIN",+ZERO,$PIECE(A(K),U,I))=""
End DoDot:2
End DoDot:1
IF (A(K)=-1)!($PIECE(A(K),U)="")
SET QUIT=1
QUIT
+8 if QUIT
QUIT
+9 SET A=""
FOR
SET A=$ORDER(SORT(A))
if A=""
QUIT
SET @("B=$$"_A_"("_J_")")
IF B=-1
SET QUIT=1
QUIT
+10 if QUIT
QUIT
+11 FOR PIECE=1:1:$SELECT(KCNT:$LENGTH(A(KCNT),U)-1,1:1)
Begin DoDot:1
+12 SET B="E"
KILL @B
+13 FOR K=1:1:$ORDER(A(99),-1)
SET @B@($PIECE(A(K),U,$SELECT(K=KCNT:PIECE,1:1)))=""
SET C=$QUERY(@B)
KILL @B
SET B=C
+14 SET @B@(J)=""
+15 MERGE ^TMP("SCSORT",$JOB)=E
End DoDot:1
+16 QUIT
DV(PP) ;return institution sort of patient assignment entry and then IEN of team^ien of position
+1 NEW A,B,C,T,I,INSTNM,INSTN
+2 SET T=+$PIECE($GET(^SCTM(404.57,+ZERO,0)),U,2)
IF $DATA(INST(T))
QUIT INST(T)_U_T_U_(+ZERO)
+3 SET I=+$PIECE($GET(^SCTM(404.51,T,0)),U,7)
IF $ORDER(^TMP("SC",$JOB,"DIV",0))
IF '$DATA(^TMP("SC",$JOB,"DIV",I))
QUIT -1
+4 SET INSTNM=$$GET1^DIQ(4,(+I)_",",.01)
SET INSTN=$$GET1^DIQ(4,(+I)_",",99)
+5 SET INST(T)=$SELECT($LENGTH(INSTN)=3:INSTN_" ",1:"")_INSTNM
QUIT INST(T)_U_T_U_(+ZERO)
EC(PP) QUIT $$AC(PP)
AC(PP) ;return enrolled clinics
+1 NEW I,A
+2 SET A=""
+3 FOR I=0:0
SET I=$ORDER(^SCTM(404.57,+ZERO,5,I))
if 'I
QUIT
Begin DoDot:1
+4 ;I '$$PTCL^SCRPO2(DFN,U_I,0,DT) Q ;not enrolled
+5 IF $DATA(CLIN(I))
SET A=A_CLIN(I)_U
QUIT
+6 IF $ORDER(^TMP("SC",$JOB,"CLINIC",0))
IF '$DATA(^(I))
QUIT
+7 SET CLIN(I)=$PIECE($GET(^SC(I,0)),U)
IF $LENGTH(CLIN(I))
SET A=A_CLIN(I)_U
End DoDot:1
+8 QUIT $SELECT(A="":-1,1:A)
TM(PP) ;Return Team
+1 NEW I,A,T
+2 SET T=+$PIECE($GET(^SCTM(404.57,+ZERO,0)),U,2)
+3 IF $DATA(TEAM(T))
QUIT TEAM(T)
+4 IF $ORDER(^TMP("SC",$JOB,"TEAM",0))
IF '$DATA(^(T))
QUIT -1
+5 SET TEAM(T)=$PIECE($GET(^SCTM(404.51,+T,0)),U)
+6 IF '$LENGTH(TEAM(T))
KILL TEAM(T)
QUIT -1
+7 QUIT TEAM(T)
TP(A) ;return the team position
+1 NEW TP
SET TP=+ZERO
+2 IF $ORDER(^TMP("SC",$JOB,"POS",0))
IF '$DATA(^(TP))
QUIT -1
+3 QUIT $PIECE($GET(^SCTM(404.57,+TP,0)),U)
PR(PP) ;Return assigned provider
+1 NEW A
+2 IF $ORDER(^TMP("SC",$JOB,"ASPR",0))
IF '$DATA(^(+$PIECE(ZERO,U,3)))
QUIT -1
+3 SET A=$$GET1^DIQ(200,(+$PIECE(ZERO,U,3))_",",.01)
QUIT $SELECT(A="":-1,1:A)
+4 QUIT
PCP(D0) ;PCP or AP
+1 ;SD/581
NEW A
IF +$PIECE($GET(^SCTM(404.57,D0,0)),U,4)=0
QUIT " "
+2 SET A=$ORDER(^SCTM(404.53,"AIDT",D0,1,0),-1)
+3 IF 'A
QUIT "PCP"
+4 IF $ORDER(^SCTM(404.53,"AIDT",D0,0,A),-1)
QUIT "PCP"
+5 QUIT "AP"
CLN(D0) ;sorted by clinic get next one
+1 NEW A
SET A=$ORDER(^TMP("SC",$JOB,"SCLIN",D0,""))
if A=""
QUIT
+2 NEW I
FOR I=0:0
SET I=$ORDER(^SC("B",A,I))
if 'I
QUIT
IF $DATA(^SCTM(404.57,D0,5,I))
QUIT
+3 if 'I
QUIT
+4 SET DIPA("NUM")="`"_I
KILL ^TMP("SC",$JOB,"SCLIN",D0,A)
