- 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 Jan 18, 2025@03:42:45 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)