SCMCTSK2 ;ALB/JDS - PCMM Inactivation Nightly Job; 18 Apr 2003 9:36 AM ; 10/24/07 12:23pm ; Compiled November 21, 2007 13:32:47 ; 9/22/09 8:43am
;;5.3;PIMS;**297,498,527,499,532,1015,1016**;JUN 30, 2012;Build 20
Q
NIGHT ;
N ENDDT,NOINAC,SIXM,FLGDT,L,PATDT,SEEN,SDDT,LDOM
D DT^DICRW S SDDT=$P($G(^XTMP("SCMCTSK2-"_DT,0)),U,2)
I SDDT="" S SDDT=DT
S ALPHA=$G(^SCTM(404.44,1,1)),ALPHA=$P(ALPHA,U,8) I ALPHA<SDDT S ALPHA=0
;if 'ALPHA NOINAC=1 except 15th and the Last Day of a Month (LDoM)
;inact only on 15th and on LDoM
S (NOINAC,LDOM)=0
S X1=SDDT,X2=1 D C^%DTC
I ($E(SDDT,1,5)'=$E(X,1,5)) S LDOM=1
I 'ALPHA D
.I ($E(SDDT,6,7)'=15)&('LDOM) S NOINAC=1
.D INACTIVE^SCMCTSK1
S SIXM=$P($G(^SCTM(404.44,1,1)),U,9)
I SIXM!(LDOM) D PRFLAG
I ALPHA D INACTIVE^SCMCTSK1
;determine ENDDT-Inactn Date-30 days if flagged today
F DATE=0:0 S DATE=$O(^SCPT(404.43,"AFLG",DATE)) Q:'DATE D
.F ENTRY=0:0 S ENTRY=$O(^SCPT(404.43,"AFLG",DATE,ENTRY)) Q:'ENTRY D
..S ZERO=$G(^SCPT(404.43,ENTRY,0)) Q:'ZERO
..S DFN=+$G(^SCPT(404.42,+ZERO,0)) Q:'DFN
..S POS=$P(ZERO,U,2)
..I $P(ZERO,U,4) D UNFLG Q ;unass.
..S X1=DATE,X2=$S(ALPHA:+2,1:+30) D C^%DTC S ENDDT=X
..N SDASS S SDASS=$P(ZERO,U,3)
..;N-new or E-stbl.
..;assig >12 months since flagging, not NEW, E-stbl)
..N NEW
..S NEW=0 S X1=DATE,X2=SDASS D ^%DTC I X<365 S NEW=1
..I NEW S %DT="",X="T-12M" D ^%DT S STDT=+Y D
...S X1=STDT,X2=-7 D C^%DTC S TYDT=X
..I 'NEW S %DT="",X="T-24M" D ^%DT S STDT=+Y D
...S X1=STDT,X2=-7 D C^%DTC S TYDT=X
..;
..;I $P(ZERO,U,17) D UNFLG Q ;react.
..;get prec
..;S %DT="",X="T-12M" D ^%DT S STDT=+Y
..;S PREC=$$DATES^SCAPMCU1(404.53,+POS),PREC=$S(PREC:$P($G(^SCTM(404.53,+$P(PREC,U,4),0)),U,6),1:+POS)
..I '$P(ZERO,U,5) D UNFLG Q ;Not PC
..D SEEN^SCMCTSK1(DFN,POS,TYDT,SDDT,.PROV,.PRECP,.SEEN)
..;S PC=$$GET^XUA4A72(+PROV)
..I SEEN D UNFLG Q
..I $P(ZERO,U,13) S X1=DATE,X2=$S(ALPHA:4,1:90) D C^%DTC S FLGDT=X I FLGDT>SDDT Q ;do not inactivate yet; extended
..I ('NOINAC)&(SDDT'<ENDDT) D DIS^SCMCTSK1
;flag prov 6m after install sd/297
I NOINAC D:ALPHA BULL I '$D(^SCPT(404.43,"AFLG",SDDT)) K ^TMP($J,"SCMCTSK2") Q
;flag prov 6m after install sd/297
;I SIXM&(SIXM'>SDDT)!LDOM D
I LDOM!ALPHA D
.D PRINAC
.;N FLDA
.;S FLDA(404.44,"1,",19)=""
.;D FILE^DIE("I","FLDA","ERR")
D BULL K ^TMP($J,"SCMCTSK2")
Q
UNFLG ;Unflagging
N DR,DIE,DA
S DR=".15///@;.13///@;.12///@",DIE="^SCPT(404.43,",DA=ENTRY D ^DIE
Q
PRFLAG ;flag incorrect provider pos
N POS
;prov inact. has run once
;I $P($G(^SCTM(404.44,1,1)),U,11)'="" Q
D PRFLAG^SCMCTSK3
Q
PRINAC ;inact. flagged providers
N I,II
;Prov inact. run already
I $G(SDDT)="" S SDDT=DT
;S II=$P($G(^SCTM(404.44,1,1)),U,11) I II'="",II'=SDDT Q
F I=0:0 S I=$O(^SCTM(404.52,I)) Q:'I S ZERO=$G(^(I,0)) I $P(ZERO,U,10) D
.S ZEROIEN=I
.;uncomment next line for testing only bpfo/swo 11.19.2008
.;S X1=$P(ZERO,U,10),X2=$S(ALPHA:2,1:30) D C^%DTC I SDDT<X Q ;not time yet
.;I $P(ZERO,U,10)>$G(ENDDT) Q ;not time yet
.I +$$EN^SCMCTSKI(1)<SDDT Q
.I $O(^SCTM(404.52,"AIDT",+ZERO,0,-9999999))<(-$P(ZERO,U,2)) Q ;inactivated
.;Check valid criteria
.S POS=+ZERO
.S PROV=+$$GETPRTP^SCAPMCU2(POS,SDDT)
.S PC=$$GET^XUA4A72(+PROV)
.S DR=".091///@",DIE="^SCTM(404.52,",DA=ZEROIEN D ^DIE ;remove flag
.S ZERO1=$G(^SCTM(404.57,POS,0))
.I '$D(^SD(403.46,+$P(ZERO1,U,3),2,+PC)) D
..;inactivation
..K DO
..S DIC="^SCTM(404.52,",X=+ZERO,DIC("DR")=".02////"_DT_";.03////"_$P(ZERO,U,3)_";.04////0;.05///EMPLOYEE LEAVES POSITION;.11////1"
..S DIC(0)="Z" D FILE^DICN
..;S DIE="^SCTM(404.52,",DA=+ZERO,DR=".02////"_SDDT_";.03////"_$P(ZERO,U,3)_";.04////0;.05///EMPLOYEE LEAVES POSITION;.11////1"
..;D ^DIE
;only run inact. once
S $P(^SCTM(404.44,1,1),U,11)=SDDT
Q
FUTAPP(DFN) ;print future appts
N TAB,SCDT0,SCARRAY,SCDTMP S TAB=$X
I $G(SDDT)="" S SDDT=DT
S SCDT=SDDT+.24
S SCARRAY(1)=SCDT ;date/time filter
S SCARRAY(4)=DFN ;patient filter
S SCARRAY("SORT")="P" ;sort filter
S SCARRAY("FLDS")="1;2;3"
I ($$SDAPI^SDAMA301(.SCARRAY)>0) D
.S SCDTMP=0 F S SCDTMP=$O(^TMP($J,"SDAMA301",DFN,SCDTMP)) Q:'SCDTMP D
..S SCDT0=$G(^TMP($J,"SDAMA301",DFN,SCDTMP)) Q:($P($P(SCDT0,U,3),U)="R")
..S Y=SCDTMP X ^DD("DD") W $E(Y_" ",1,17)_" "_$E($P($P(SCDT0,U,2),";",2),1,10)
Q
GETASC(DATA,ENTRY) ;get assoc. clinics
N I,CNT S CNT=0
F I=0:0 S I=$O(^SCTM(404.57,+$G(ENTRY),5,I)) Q:'I S CNT=CNT+1,DATA(CNT)=I_U_$P($G(^SC(I,0)),U)
Q
SETASC(RESULT,DATA) ;set assoc. clinics
D SETASC^SCMCTSK7(.RESULT,DATA) Q
MSG(SCTP,DFN) ;send inact. message
;given valid positions get current practitioners
S SCLIST="SCL"
I $G(SDDT)="" S SDDT=DT
I "N"'[$P($G(^SCTM(404.57,SCTP,2)),U,9) D
.S SCOK=$$PRTP^SCAPMC(SCTP,"",.SCLIST,.SCERR)
.;if preceptor notice turned on for message type
I +$P($G(^SCTM(404.57,SCTP,2)),U,9) D
.S SCX=+$$OKPREC2^SCMCLK(SCTP,SDDT)
.;if preceptor duz returned, add to array
.I SCX S @SCLIST@("SCPR",SCX)=""
N XMY F I=0:0 S I=$O(@SCLIST@("SCPR",I)) Q:'I S XMY(I)=""
S SCTEXT(1,0)="PATIENT "_$P($G(^DPT(DFN,0)),U)_" has been inactivated from PC team position "_$P($G(^SCTM(404.57,SCTP,0)),U)
S XMSUB="Provider's Inactivated Primary Care Patients" D ^XMD
Q
BULL ;EOM Bulletin
N DISUPNO,BY,DHIT,HEAD
S DISUPNO=1,L=0
S XMSUB="Patients Scheduled for Inactivation from PC Panel"
S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")=""
K ^TMP("SCMC",$J),^TMP("SCMCTXT",$J),^TMP("SCML",$J)
S XMTEXT="^TMP(""SCMCTXT"",$J," ;S @XMTEXT@(0)=""
S DIC="^SCPT(404.43,",BY="[SCMC FLAGGED BULLETIN]",FLDS="[SC BULLETIN]",CNT=0
S:0 FLDS="" S IOP="",DHD="@@",(FR,TO)="" D EN1^DIP
S ^TMP("SCMCTXT",$J,1,0)="There are "_$O(^TMP("SCMC",$J,""),-1)_" Patients scheduled for inactivation in next 30 days"
D LINES(1)
D ^XMD
D PRMAIL^SCMCTSK5(1)
F SCI=0:0 S SCI=$O(^TMP("SCF",$J,SCI)) Q:'SCI D
.K XMY S XMY(SCI)="" K ^TMP("SCMC",$J),^TMP("SCMCTXT",$J)
.M ^TMP("SCMC",$J)=^TMP("SCF",$J,SCI)
.S XMSUB="Patients Scheduled for Inactivation from PC Panel"
.S XMTEXT="^TMP(""SCMCTXT"",$J,"
S DISUPNO=1
K ^TMP("SCMC",$J),^TMP("SCMCTXT")
I $G(NOINAC) K ^TMP($J,"SCMCTSK2") Q ; SD/499
S XMSUB="Patients With Extended PCMM Inactivation Dates"
S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")=""
K ^TMP("SCMC",$J)
S XMTEXT="^TMP(""SCMCTXT"",$J," ;S @XMTEXT@(0)=""
S DIC="^SCPT(404.43,",BY="[SCMC EXTENDED BULLETIN]",DHIT="S CNT=$G(CNT)+1,^TMP(""SCMC"",$J,CNT,D0)=""""",CNT=0
S FR=",,,",TO=FR,FLDS="",IOP="",DHD="@@" D EN1^DIP
S ^TMP("SCMCTXT",$J,1,0)="There are "_$O(^TMP("SCMC",$J,""),-1)_" Patients Extended from inactivation"
D LINES(3)
D ^XMD
D PRMAIL^SCMCTSK5(3)
S DISUPNO=1
K ^TMP("SCMC",$J),^TMP("SCMCTXT")
S XMSUB="Patients Automated Inactivations from PC Panels"
S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")=""
K ^TMP("SCMC",$J)
S XMTEXT="^TMP(""SCMCTXT"",$J," ;S @XMTEXT@(0)=""
S DIC="^SCPT(404.43,",BY="[SCMC INACTIVATED]",DHIT="S CNT=$G(CNT)+1,^TMP(""SCMC"",$J,CNT,D0)=""""",CNT=0
S FLDS="",IOP="",DHD="@@",FR=",T-30,,",TO=",,,,," D EN1^DIP
S ^TMP("SCMCTXT",$J,1,0)="There are "_$O(^TMP("SCMC",$J,""),-1)_" Patients Inactivated in last 30 days"
D LINES(2)
D ^XMD
TST ;
S DISUPNO=1
D PRMAIL^SCMCTSK5(2)
K ^TMP("SCMC",$J),^TMP("SCMCTXT")
;I $P($G(^SCTM(404.44,1,1)),U,11)="" D
S XMSUB="PC Providers Scheduled for Inactivation"
S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")=""
K ^TMP("SCMC",$J)
S XMTEXT="^TMP(""SCMCTXT"",$J,"
S DIC="^SCTM(404.52,",BY="[SC PROVIDER FLAGGED BULLE]",DHIT="S CNT=$G(CNT)+1,^TMP(""SCMC"",$J,CNT,D0)=""""",CNT=0
S FLDS="",IOP="",DHD="@@",FR="",TO="" D EN1^DIP
D LINES(4)
D ^XMD
D PRMAIL^SCMCTSK5(4)
D BULL^SCMCTSK6
Q
LINES(TYPE) ;Lines of Bulletin
D LINES^SCMCTSK5(TYPE) Q
ROLE(DATA,INFO) ;SCMC ROLE
N ROLE,TP,I,SCRSLT,SCTF,SCLS,SCPOR
S (SCPOR,SCRSLT)=0
S ROLE=+$G(INFO),TP=+$P($G(INFO),U,2)
I 'ROLE Q
I 'TP Q
;get values
S DATA(0)=+$P($G(^SD(403.46,ROLE,0)),U,3)
I $$DATES^SCAPMCU1(404.53,+TP) S SCPOR=1
N PREC S PREC=0
F I=0:0 S I=$O(^SCTM(404.53,"AD",TP,I)) Q:'I D Q:PREC
.I $D(^SCTM(404.53,"AD",TP,I,1)) I '$D(^(0)) S PREC=1
I +DATA(0)'=0 D
. S SCTF=$$GETPRTP^SCAPMCU2(TP) Q:+SCTF=0
. S SCLS=$$GET^XUA4A72(+SCTF)
. I SCLS S SCRSLT=$S('$D(^SD(403.46,ROLE,2,"B",+SCLS)):1,1:0)
;end of get
;type of role^preceptor^preceptee^person class check
S DATA(0)=DATA(0)_U_SCPOR_U_PREC_U_SCRSLT
Q
INRPT ; REPORT
N DIOEND,SCDHD
D PROMPT^SCMCTSK3("** Date Range Selection **","DATE PATIENTS INACTIVATED FROM PC PANELS")
Q:'$D(^TMP("SC",$J,"XR"))
D UNASSIGN^SCMCTSK3
S Q=""""
S DIC="^SCPT(404.43," ;=0,BY="[SCMC INACTIVATION SORT]"
D BY
S (SCDHD,DHD)="AUTOMATED PATIENT INACTIVATION FROM PRIMARY CARE PANELS REPORT"
S DIOBEG="D DIOBEG^SCMCTSK4"
S DIOEND="D DIOEND1^SCMCTSK4"
S FLDS="[SCMC INACTIVATED]" ;,FR="?,,"_$TR(DIPA("SI"),","," "),TO="T,,"_$TR(DIPA("EI")_"z",","," ")
D EN1^DIP
Q
IN30 ;inact. last month
N DIPA,SDD D SORT^SCMCTSK1(.DIPA,.SDD) Q:'SDD ;SD/499
S Q=""""
S DIC="^SCPT(404.43,",L=0,BY="[SCMC INACTIVATION SORT]"
S DHD="Patients Inactivated from Primary Care Panels in the Past Month"
S FLDS="[SCMC INACTIVATED]",FR="T-31,,"_$TR(DIPA("SI"),","," "),TO="T,,"_$TR(DIPA("EI")_"z",","," ")
D EN1^DIP
Q
EXRPT ;EXTEND REPORT
K CLIN,TEAM,INST
D PROMPT^SCMCTSK3("PCMM Patients with Extended Inactivations","Scheduled Inactivation Date")
Q:'$D(^TMP("SC",$J,"XR"))
S Q="""",SORT=1
D EXTEND^SCMCTSK3
S DIC="^SCPT(404.43," ;,L=0,BY="[SCMC EXTENDED]"
S (SCDHD,DHD)="PCMM Patients with extended Inactivations"
S DIOBEG="D DIOBEG^SCMCTSK4",DIOEND="D EXTKEY^SCMCTSK9"
D BY
S FLDS="[SCMC EXTENDED]"
D EN1^DIP
Q
BY N DISPAR
S BY(0)="^TMP(""SCSORT"",$J)",L(0)=$O(^TMP("SC",$J,"SORT",99),-1)+1,DISPAR(0,1)="+",L=0 I $G(SCDHD)["FTEE" S DISPAR(0,1)="+#" ;BY="@'.01"
F I=1:1:$L(SORTN,U) S A=$P(SORTN,U,I) Q:'$L(A) S $P(DISPAR(0,I),U,2)=";"_Q_A_": "_Q D
.I A["PATIENT" I (I>1)!($G(SCDHD)["Patients Scheduled for Inactivation from PC Panel") S $P(DISPAR(0,I),U)="@"
.I $G(SCDHD)["FTEE" D
..I A["PROV" S $P(DISPAR(0,I),U)="@"
..I I>1 I (A["CLI")!(A["POS") S $P(DISPAR(0,I),U)="@"_$P($G(DISPAR(0,I)),U)
S ZTSAVE("^TMP(""SC"",$J,")="",ZTSAVE("^TMP(""SCSORT"",$J,")=""
Q
FLRPT ;FLAGGED REPORT
D PROMPT^SCMCTSK3("Patients Scheduled for Inactivation from PC Panels","Date Scheduled for Inactivation")
Q:'$D(^TMP("SC",$J,"XR"))
D FLAGG^SCMCTSK3
S Q=""""
S DIC="^SCPT(404.43,",L=0
S (SCDHD,DHD)="Patients Scheduled for Inactivation from PC Panels"
D BY
S DIOBEG="D DIOBEG^SCMCTSK4"
S FLDS="[SCMC PENDING UNASSIGN]"
I $G(DISPAR(0,1))["PATIENT" S FLDS="[SCMC PENDING UNASSIGN PAT]"
S DIOEND="D DIOEND^SCMCTSK4"
D EN1^DIP
SCMCTSK2 ;ALB/JDS - PCMM Inactivation Nightly Job; 18 Apr 2003 9:36 AM ; 10/24/07 12:23pm ; Compiled November 21, 2007 13:32:47 ; 9/22/09 8:43am
+1 ;;5.3;PIMS;**297,498,527,499,532,1015,1016**;JUN 30, 2012;Build 20
+2 QUIT
NIGHT ;
+1 NEW ENDDT,NOINAC,SIXM,FLGDT,L,PATDT,SEEN,SDDT,LDOM
+2 DO DT^DICRW
SET SDDT=$PIECE($GET(^XTMP("SCMCTSK2-"_DT,0)),U,2)
+3 IF SDDT=""
SET SDDT=DT
+4 SET ALPHA=$GET(^SCTM(404.44,1,1))
SET ALPHA=$PIECE(ALPHA,U,8)
IF ALPHA<SDDT
SET ALPHA=0
+5 ;if 'ALPHA NOINAC=1 except 15th and the Last Day of a Month (LDoM)
+6 ;inact only on 15th and on LDoM
+7 SET (NOINAC,LDOM)=0
+8 SET X1=SDDT
SET X2=1
DO C^%DTC
+9 IF ($EXTRACT(SDDT,1,5)'=$EXTRACT(X,1,5))
SET LDOM=1
+10 IF 'ALPHA
Begin DoDot:1
+11 IF ($EXTRACT(SDDT,6,7)'=15)&('LDOM)
SET NOINAC=1
+12 DO INACTIVE^SCMCTSK1
End DoDot:1
+13 SET SIXM=$PIECE($GET(^SCTM(404.44,1,1)),U,9)
+14 IF SIXM!(LDOM)
DO PRFLAG
+15 IF ALPHA
DO INACTIVE^SCMCTSK1
+16 ;determine ENDDT-Inactn Date-30 days if flagged today
+17 FOR DATE=0:0
SET DATE=$ORDER(^SCPT(404.43,"AFLG",DATE))
IF 'DATE
QUIT
Begin DoDot:1
+18 FOR ENTRY=0:0
SET ENTRY=$ORDER(^SCPT(404.43,"AFLG",DATE,ENTRY))
IF 'ENTRY
QUIT
Begin DoDot:2
+19 SET ZERO=$GET(^SCPT(404.43,ENTRY,0))
IF 'ZERO
QUIT
+20 SET DFN=+$GET(^SCPT(404.42,+ZERO,0))
IF 'DFN
QUIT
+21 SET POS=$PIECE(ZERO,U,2)
+22 ;unass.
IF $PIECE(ZERO,U,4)
DO UNFLG
QUIT
+23 SET X1=DATE
SET X2=$SELECT(ALPHA:+2,1:+30)
DO C^%DTC
SET ENDDT=X
+24 NEW SDASS
SET SDASS=$PIECE(ZERO,U,3)
+25 ;N-new or E-stbl.
+26 ;assig >12 months since flagging, not NEW, E-stbl)
+27 NEW NEW
+28 SET NEW=0
SET X1=DATE
SET X2=SDASS
DO ^%DTC
IF X<365
SET NEW=1
+29 IF NEW
SET %DT=""
SET X="T-12M"
DO ^%DT
SET STDT=+Y
Begin DoDot:3
+30 SET X1=STDT
SET X2=-7
DO C^%DTC
SET TYDT=X
End DoDot:3
+31 IF 'NEW
SET %DT=""
SET X="T-24M"
DO ^%DT
SET STDT=+Y
Begin DoDot:3
+32 SET X1=STDT
SET X2=-7
DO C^%DTC
SET TYDT=X
End DoDot:3
+33 ;
+34 ;I $P(ZERO,U,17) D UNFLG Q ;react.
+35 ;get prec
+36 ;S %DT="",X="T-12M" D ^%DT S STDT=+Y
+37 ;S PREC=$$DATES^SCAPMCU1(404.53,+POS),PREC=$S(PREC:$P($G(^SCTM(404.53,+$P(PREC,U,4),0)),U,6),1:+POS)
+38 ;Not PC
IF '$PIECE(ZERO,U,5)
DO UNFLG
QUIT
+39 DO SEEN^SCMCTSK1(DFN,POS,TYDT,SDDT,.PROV,.PRECP,.SEEN)
+40 ;S PC=$$GET^XUA4A72(+PROV)
+41 IF SEEN
DO UNFLG
QUIT
+42 ;do not inactivate yet; extended
IF $PIECE(ZERO,U,13)
SET X1=DATE
SET X2=$SELECT(ALPHA:4,1:90)
DO C^%DTC
SET FLGDT=X
IF FLGDT>SDDT
QUIT
+43 IF ('NOINAC)&(SDDT'<ENDDT)
DO DIS^SCMCTSK1
End DoDot:2
End DoDot:1
+44 ;flag prov 6m after install sd/297
+45 IF NOINAC
IF ALPHA
DO BULL
IF '$DATA(^SCPT(404.43,"AFLG",SDDT))
KILL ^TMP($JOB,"SCMCTSK2")
QUIT
+46 ;flag prov 6m after install sd/297
+47 ;I SIXM&(SIXM'>SDDT)!LDOM D
+48 IF LDOM!ALPHA
Begin DoDot:1
+49 DO PRINAC
+50 ;N FLDA
+51 ;S FLDA(404.44,"1,",19)=""
+52 ;D FILE^DIE("I","FLDA","ERR")
End DoDot:1
+53 DO BULL
KILL ^TMP($JOB,"SCMCTSK2")
+54 QUIT
UNFLG ;Unflagging
+1 NEW DR,DIE,DA
+2 SET DR=".15///@;.13///@;.12///@"
SET DIE="^SCPT(404.43,"
SET DA=ENTRY
DO ^DIE
+3 QUIT
PRFLAG ;flag incorrect provider pos
+1 NEW POS
+2 ;prov inact. has run once
+3 ;I $P($G(^SCTM(404.44,1,1)),U,11)'="" Q
+4 DO PRFLAG^SCMCTSK3
+5 QUIT
PRINAC ;inact. flagged providers
+1 NEW I,II
+2 ;Prov inact. run already
+3 IF $GET(SDDT)=""
SET SDDT=DT
+4 ;S II=$P($G(^SCTM(404.44,1,1)),U,11) I II'="",II'=SDDT Q
+5 FOR I=0:0
SET I=$ORDER(^SCTM(404.52,I))
IF 'I
QUIT
SET ZERO=$GET(^(I,0))
IF $PIECE(ZERO,U,10)
Begin DoDot:1
+6 SET ZEROIEN=I
+7 ;uncomment next line for testing only bpfo/swo 11.19.2008
+8 ;S X1=$P(ZERO,U,10),X2=$S(ALPHA:2,1:30) D C^%DTC I SDDT<X Q ;not time yet
+9 ;I $P(ZERO,U,10)>$G(ENDDT) Q ;not time yet
+10 IF +$$EN^SCMCTSKI(1)<SDDT
QUIT
+11 ;inactivated
IF $ORDER(^SCTM(404.52,"AIDT",+ZERO,0,-9999999))<(-$PIECE(ZERO,U,2))
QUIT
+12 ;Check valid criteria
+13 SET POS=+ZERO
+14 SET PROV=+$$GETPRTP^SCAPMCU2(POS,SDDT)
+15 SET PC=$$GET^XUA4A72(+PROV)
+16 ;remove flag
SET DR=".091///@"
SET DIE="^SCTM(404.52,"
SET DA=ZEROIEN
DO ^DIE
+17 SET ZERO1=$GET(^SCTM(404.57,POS,0))
+18 IF '$DATA(^SD(403.46,+$PIECE(ZERO1,U,3),2,+PC))
Begin DoDot:2
+19 ;inactivation
+20 KILL DO
+21 SET DIC="^SCTM(404.52,"
SET X=+ZERO
SET DIC("DR")=".02////"_DT_";.03////"_$PIECE(ZERO,U,3)_";.04////0;.05///EMPLOYEE LEAVES POSITION;.11////1"
+22 SET DIC(0)="Z"
DO FILE^DICN
+23 ;S DIE="^SCTM(404.52,",DA=+ZERO,DR=".02////"_SDDT_";.03////"_$P(ZERO,U,3)_";.04////0;.05///EMPLOYEE LEAVES POSITION;.11////1"
+24 ;D ^DIE
End DoDot:2
End DoDot:1
+25 ;only run inact. once
+26 SET $PIECE(^SCTM(404.44,1,1),U,11)=SDDT
+27 QUIT
FUTAPP(DFN) ;print future appts
+1 NEW TAB,SCDT0,SCARRAY,SCDTMP
SET TAB=$X
+2 IF $GET(SDDT)=""
SET SDDT=DT
+3 SET SCDT=SDDT+.24
+4 ;date/time filter
SET SCARRAY(1)=SCDT
+5 ;patient filter
SET SCARRAY(4)=DFN
+6 ;sort filter
SET SCARRAY("SORT")="P"
+7 SET SCARRAY("FLDS")="1;2;3"
+8 IF ($$SDAPI^SDAMA301(.SCARRAY)>0)
Begin DoDot:1
+9 SET SCDTMP=0
FOR
SET SCDTMP=$ORDER(^TMP($JOB,"SDAMA301",DFN,SCDTMP))
IF 'SCDTMP
QUIT
Begin DoDot:2
+10 SET SCDT0=$GET(^TMP($JOB,"SDAMA301",DFN,SCDTMP))
IF ($PIECE($PIECE(SCDT0,U,3),U)="R")
QUIT
+11 SET Y=SCDTMP
XECUTE ^DD("DD")
WRITE $EXTRACT(Y_" ",1,17)_" "_$EXTRACT($PIECE($PIECE(SCDT0,U,2),";",2),1,10)
End DoDot:2
End DoDot:1
+12 QUIT
GETASC(DATA,ENTRY) ;get assoc. clinics
+1 NEW I,CNT
SET CNT=0
+2 FOR I=0:0
SET I=$ORDER(^SCTM(404.57,+$GET(ENTRY),5,I))
IF 'I
QUIT
SET CNT=CNT+1
SET DATA(CNT)=I_U_$PIECE($GET(^SC(I,0)),U)
+3 QUIT
SETASC(RESULT,DATA) ;set assoc. clinics
+1 DO SETASC^SCMCTSK7(.RESULT,DATA)
QUIT
MSG(SCTP,DFN) ;send inact. message
+1 ;given valid positions get current practitioners
+2 SET SCLIST="SCL"
+3 IF $GET(SDDT)=""
SET SDDT=DT
+4 IF "N"'[$PIECE($GET(^SCTM(404.57,SCTP,2)),U,9)
Begin DoDot:1
+5 SET SCOK=$$PRTP^SCAPMC(SCTP,"",.SCLIST,.SCERR)
+6 ;if preceptor notice turned on for message type
End DoDot:1
+7 IF +$PIECE($GET(^SCTM(404.57,SCTP,2)),U,9)
Begin DoDot:1
+8 SET SCX=+$$OKPREC2^SCMCLK(SCTP,SDDT)
+9 ;if preceptor duz returned, add to array
+10 IF SCX
SET @SCLIST@("SCPR",SCX)=""
End DoDot:1
+11 NEW XMY
FOR I=0:0
SET I=$ORDER(@SCLIST@("SCPR",I))
IF 'I
QUIT
SET XMY(I)=""
+12 SET SCTEXT(1,0)="PATIENT "_$PIECE($GET(^DPT(DFN,0)),U)_" has been inactivated from PC team position "_$PIECE($GET(^SCTM(404.57,SCTP,0)),U)
+13 SET XMSUB="Provider's Inactivated Primary Care Patients"
DO ^XMD
+14 QUIT
BULL ;EOM Bulletin
+1 NEW DISUPNO,BY,DHIT,HEAD
+2 SET DISUPNO=1
SET L=0
+3 SET XMSUB="Patients Scheduled for Inactivation from PC Panel"
+4 SET XMY("G.PCMM PATIENT/PROVIDER INACTIVE")=""
+5 KILL ^TMP("SCMC",$JOB),^TMP("SCMCTXT",$JOB),^TMP("SCML",$JOB)
+6 ;S @XMTEXT@(0)=""
SET XMTEXT="^TMP(""SCMCTXT"",$J,"
+7 SET DIC="^SCPT(404.43,"
SET BY="[SCMC FLAGGED BULLETIN]"
SET FLDS="[SC BULLETIN]"
SET CNT=0
+8 IF 0
SET FLDS=""
SET IOP=""
SET DHD="@@"
SET (FR,TO)=""
DO EN1^DIP
+9 SET ^TMP("SCMCTXT",$JOB,1,0)="There are "_$ORDER(^TMP("SCMC",$JOB,""),-1)_" Patients scheduled for inactivation in next 30 days"
+10 DO LINES(1)
+11 DO ^XMD
+12 DO PRMAIL^SCMCTSK5(1)
+13 FOR SCI=0:0
SET SCI=$ORDER(^TMP("SCF",$JOB,SCI))
IF 'SCI
QUIT
Begin DoDot:1
+14 KILL XMY
SET XMY(SCI)=""
KILL ^TMP("SCMC",$JOB),^TMP("SCMCTXT",$JOB)
+15 MERGE ^TMP("SCMC",$JOB)=^TMP("SCF",$JOB,SCI)
+16 SET XMSUB="Patients Scheduled for Inactivation from PC Panel"
+17 SET XMTEXT="^TMP(""SCMCTXT"",$J,"
End DoDot:1
+18 SET DISUPNO=1
+19 KILL ^TMP("SCMC",$JOB),^TMP("SCMCTXT")
+20 ; SD/499
IF $GET(NOINAC)
KILL ^TMP($JOB,"SCMCTSK2")
QUIT
+21 SET XMSUB="Patients With Extended PCMM Inactivation Dates"
+22 SET XMY("G.PCMM PATIENT/PROVIDER INACTIVE")=""
+23 KILL ^TMP("SCMC",$JOB)
+24 ;S @XMTEXT@(0)=""
SET XMTEXT="^TMP(""SCMCTXT"",$J,"
+25 SET DIC="^SCPT(404.43,"
SET BY="[SCMC EXTENDED BULLETIN]"
SET DHIT="S CNT=$G(CNT)+1,^TMP(""SCMC"",$J,CNT,D0)="""""
SET CNT=0
+26 SET FR=",,,"
SET TO=FR
SET FLDS=""
SET IOP=""
SET DHD="@@"
DO EN1^DIP
+27 SET ^TMP("SCMCTXT",$JOB,1,0)="There are "_$ORDER(^TMP("SCMC",$JOB,""),-1)_" Patients Extended from inactivation"
+28 DO LINES(3)
+29 DO ^XMD
+30 DO PRMAIL^SCMCTSK5(3)
+31 SET DISUPNO=1
+32 KILL ^TMP("SCMC",$JOB),^TMP("SCMCTXT")
+33 SET XMSUB="Patients Automated Inactivations from PC Panels"
+34 SET XMY("G.PCMM PATIENT/PROVIDER INACTIVE")=""
+35 KILL ^TMP("SCMC",$JOB)
+36 ;S @XMTEXT@(0)=""
SET XMTEXT="^TMP(""SCMCTXT"",$J,"
+37 SET DIC="^SCPT(404.43,"
SET BY="[SCMC INACTIVATED]"
SET DHIT="S CNT=$G(CNT)+1,^TMP(""SCMC"",$J,CNT,D0)="""""
SET CNT=0
+38 SET FLDS=""
SET IOP=""
SET DHD="@@"
SET FR=",T-30,,"
SET TO=",,,,,"
DO EN1^DIP
+39 SET ^TMP("SCMCTXT",$JOB,1,0)="There are "_$ORDER(^TMP("SCMC",$JOB,""),-1)_" Patients Inactivated in last 30 days"
+40 DO LINES(2)
+41 DO ^XMD
TST ;
+1 SET DISUPNO=1
+2 DO PRMAIL^SCMCTSK5(2)
+3 KILL ^TMP("SCMC",$JOB),^TMP("SCMCTXT")
+4 ;I $P($G(^SCTM(404.44,1,1)),U,11)="" D
+5 SET XMSUB="PC Providers Scheduled for Inactivation"
+6 SET XMY("G.PCMM PATIENT/PROVIDER INACTIVE")=""
+7 KILL ^TMP("SCMC",$JOB)
+8 SET XMTEXT="^TMP(""SCMCTXT"",$J,"
+9 SET DIC="^SCTM(404.52,"
SET BY="[SC PROVIDER FLAGGED BULLE]"
SET DHIT="S CNT=$G(CNT)+1,^TMP(""SCMC"",$J,CNT,D0)="""""
SET CNT=0
+10 SET FLDS=""
SET IOP=""
SET DHD="@@"
SET FR=""
SET TO=""
DO EN1^DIP
+11 DO LINES(4)
+12 DO ^XMD
+13 DO PRMAIL^SCMCTSK5(4)
+14 DO BULL^SCMCTSK6
+15 QUIT
LINES(TYPE) ;Lines of Bulletin
+1 DO LINES^SCMCTSK5(TYPE)
QUIT
ROLE(DATA,INFO) ;SCMC ROLE
+1 NEW ROLE,TP,I,SCRSLT,SCTF,SCLS,SCPOR
+2 SET (SCPOR,SCRSLT)=0
+3 SET ROLE=+$GET(INFO)
SET TP=+$PIECE($GET(INFO),U,2)
+4 IF 'ROLE
QUIT
+5 IF 'TP
QUIT
+6 ;get values
+7 SET DATA(0)=+$PIECE($GET(^SD(403.46,ROLE,0)),U,3)
+8 IF $$DATES^SCAPMCU1(404.53,+TP)
SET SCPOR=1
+9 NEW PREC
SET PREC=0
+10 FOR I=0:0
SET I=$ORDER(^SCTM(404.53,"AD",TP,I))
IF 'I
QUIT
Begin DoDot:1
+11 IF $DATA(^SCTM(404.53,"AD",TP,I,1))
IF '$DATA(^(0))
SET PREC=1
End DoDot:1
IF PREC
QUIT
+12 IF +DATA(0)'=0
Begin DoDot:1
+13 SET SCTF=$$GETPRTP^SCAPMCU2(TP)
IF +SCTF=0
QUIT
+14 SET SCLS=$$GET^XUA4A72(+SCTF)
+15 IF SCLS
SET SCRSLT=$SELECT('$DATA(^SD(403.46,ROLE,2,"B",+SCLS)):1,1:0)
End DoDot:1
+16 ;end of get
+17 ;type of role^preceptor^preceptee^person class check
+18 SET DATA(0)=DATA(0)_U_SCPOR_U_PREC_U_SCRSLT
+19 QUIT
INRPT ; REPORT
+1 NEW DIOEND,SCDHD
+2 DO PROMPT^SCMCTSK3("** Date Range Selection **","DATE PATIENTS INACTIVATED FROM PC PANELS")
+3 IF '$DATA(^TMP("SC",$JOB,"XR"))
QUIT
+4 DO UNASSIGN^SCMCTSK3
+5 SET Q=""""
+6 ;=0,BY="[SCMC INACTIVATION SORT]"
SET DIC="^SCPT(404.43,"
+7 DO BY
+8 SET (SCDHD,DHD)="AUTOMATED PATIENT INACTIVATION FROM PRIMARY CARE PANELS REPORT"
+9 SET DIOBEG="D DIOBEG^SCMCTSK4"
+10 SET DIOEND="D DIOEND1^SCMCTSK4"
+11 ;,FR="?,,"_$TR(DIPA("SI"),","," "),TO="T,,"_$TR(DIPA("EI")_"z",","," ")
SET FLDS="[SCMC INACTIVATED]"
+12 DO EN1^DIP
+13 QUIT
IN30 ;inact. last month
+1 ;SD/499
NEW DIPA,SDD
DO SORT^SCMCTSK1(.DIPA,.SDD)
IF 'SDD
QUIT
+2 SET Q=""""
+3 SET DIC="^SCPT(404.43,"
SET L=0
SET BY="[SCMC INACTIVATION SORT]"
+4 SET DHD="Patients Inactivated from Primary Care Panels in the Past Month"
+5 SET FLDS="[SCMC INACTIVATED]"
SET FR="T-31,,"_$TRANSLATE(DIPA("SI"),","," ")
SET TO="T,,"_$TRANSLATE(DIPA("EI")_"z",","," ")
+6 DO EN1^DIP
+7 QUIT
EXRPT ;EXTEND REPORT
+1 KILL CLIN,TEAM,INST
+2 DO PROMPT^SCMCTSK3("PCMM Patients with Extended Inactivations","Scheduled Inactivation Date")
+3 IF '$DATA(^TMP("SC",$JOB,"XR"))
QUIT
+4 SET Q=""""
SET SORT=1
+5 DO EXTEND^SCMCTSK3
+6 ;,L=0,BY="[SCMC EXTENDED]"
SET DIC="^SCPT(404.43,"
+7 SET (SCDHD,DHD)="PCMM Patients with extended Inactivations"
+8 SET DIOBEG="D DIOBEG^SCMCTSK4"
SET DIOEND="D EXTKEY^SCMCTSK9"
+9 DO BY
+10 SET FLDS="[SCMC EXTENDED]"
+11 DO EN1^DIP
+12 QUIT
BY NEW DISPAR
+1 ;BY="@'.01"
SET BY(0)="^TMP(""SCSORT"",$J)"
SET L(0)=$ORDER(^TMP("SC",$JOB,"SORT",99),-1)+1
SET DISPAR(0,1)="+"
SET L=0
IF $GET(SCDHD)["FTEE"
SET DISPAR(0,1)="+#"
+2 FOR I=1:1:$LENGTH(SORTN,U)
SET A=$PIECE(SORTN,U,I)
IF '$LENGTH(A)
QUIT
SET $PIECE(DISPAR(0,I),U,2)=";"_Q_A_": "_Q
Begin DoDot:1
+3 IF A["PATIENT"
IF (I>1)!($GET(SCDHD)["Patients Scheduled for Inactivation from PC Panel")
SET $PIECE(DISPAR(0,I),U)="@"
+4 IF $GET(SCDHD)["FTEE"
Begin DoDot:2
+5 IF A["PROV"
SET $PIECE(DISPAR(0,I),U)="@"
+6 IF I>1
IF (A["CLI")!(A["POS")
SET $PIECE(DISPAR(0,I),U)="@"_$PIECE($GET(DISPAR(0,I)),U)
End DoDot:2
End DoDot:1
+7 SET ZTSAVE("^TMP(""SC"",$J,")=""
SET ZTSAVE("^TMP(""SCSORT"",$J,")=""
+8 QUIT
FLRPT ;FLAGGED REPORT
+1 DO PROMPT^SCMCTSK3("Patients Scheduled for Inactivation from PC Panels","Date Scheduled for Inactivation")
+2 IF '$DATA(^TMP("SC",$JOB,"XR"))
QUIT
+3 DO FLAGG^SCMCTSK3
+4 SET Q=""""
+5 SET DIC="^SCPT(404.43,"
SET L=0
+6 SET (SCDHD,DHD)="Patients Scheduled for Inactivation from PC Panels"
+7 DO BY
+8 SET DIOBEG="D DIOBEG^SCMCTSK4"
+9 SET FLDS="[SCMC PENDING UNASSIGN]"
+10 IF $GET(DISPAR(0,1))["PATIENT"
SET FLDS="[SCMC PENDING UNASSIGN PAT]"
+11 SET DIOEND="D DIOEND^SCMCTSK4"
+12 DO EN1^DIP
