Changeset 636 for FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCTSK2.m

Timestamp:

Dec 4, 2009, 8:26:01 PM (14 years ago)

Author:

George Lilly

Message:

WorldVistAEHR overlayed on FOIAVistA

Location:

FOIAVistA/tag/r

Files:

• . (copied) (copied from FOIAVistA/trunk/r )
• SCHEDULING-SD-SC/SCMCTSK2.m (modified) (7 diffs)

FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCTSK2.m

@@ -1 @@
-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  ; Compiled March 17, 2008 15:27:15
- ;;5.3;Scheduling;**297,498,527,499**;AUG 13, 1993;Build 21
- Q
-NIGHT ;
- N ENDDT,NOINAC,SIXM,FLGDT,L,PATDT,SEEN,SDDT
- 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=0
- I 'ALPHA  S X1=SDDT,X2=1 D C^%DTC I ($E(SDDT,6,7)'=15)&($E(SDDT,1,5)=$E(X,1,5)) S NOINAC=1
- I 'ALPHA D INACTIVE^SCMCTSK1
+SCMCTSK2 ;ALB/JDS - PCMM Inactivation Nightly Job; 18 Apr 2003  9:36 AM ; 10/24/07 12:23pm
+ ;;5.3;Scheduling;**297,498,527**;AUG 13, 1993;Build 6
+ Q
+NIGHT ;nightly task for inact.
+ N ENDDT,NOINAC,SIXM,FLGDT,L,PATDT,SEEN
+ K ^TMP("SCTSK",$J)
+ D DT^DICRW
+ S ALPHA=$G(^SCTM(404.44,1,1)),ALPHA=$P(ALPHA,U,8) I ALPHA<DT S ALPHA=0
+ ;check if this is last day of month
+ S X1=DT,X2=1 D C^%DTC I $E(DT,1,5)'=$E(X,1,5) I 'ALPHA D INACTIVE^SCMCTSK1
  S SIXM=$P($G(^SCTM(404.44,1,1)),U,9)
  I SIXM 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
+ S NOINAC=0 I 'ALPHA  S X1=DT,X2=1 D C^%DTC I ($E(DT,6,7)'=15)&($E(DT,1,5)=$E(X,1,5)) S NOINAC=1
+ ;check for 60 days after flagged for inact.
+ S X1=DT,X2=$S(ALPHA:-2,1:-30) D C^%DTC S ENDDT=X
+ F DATE=0:0 S DATE=$O(^SCPT(404.43,"AFLG",DATE)) Q:(('DATE)!(('NOINAC)&(DATE>ENDDT)))  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 D
+ ..I $P(ZERO,U,4) D UNFLG Q  ;already unassigned
+ ..I $P(ZERO,U,13) S X1=DATE,X2=$S(ALPHA:4,1:90) D C^%DTC S FLGDT=X I FLGDT>DT Q    ;ext
+ ..;check if criteria still met
+ ..I $P(ZERO,U,17) D UNFLG Q  ;Already reactivated
+ ..;get preceptor position
+ ..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)
+ ..;see if provider changed
+ ..I $O(^SCTM(404.52,"AIDT",+PREC,1,-STDT),-1) D UNFLG Q
+ ..I '$P(ZERO,U,5) D UNFLG Q  ;Not primary care
+ ..S PROV=+$$GETPRTP^SCAPMCU2(POS,DT)
+ ..S PC=$$GET^XUA4A72(+PROV)
+ ..S SC297=$$PDAT^SCMCGU("SD*5.3*297")
+ ..N NEW S NEW=$S($P(ZERO,U,3)<SC297:0,1:1)   ;D D^%DTC S NEW=$S(X>330:0,1:1)
+ ..S X1=DT,X2=SC297 D D^%DTC S SC297=X
+ ..S X="T-"_$S(SC297>365:"11M",NEW:"11M",1:"23M") D ^%DT S TYDT=+Y D SEEN^SCMCTSK1 I $G(SEEN) D UNFLG Q 
+ ..S X="T-"_$S(SC297>365:"12M",NEW:"12M",1:"24M") D ^%DT S TYDT=+Y D SEEN^SCMCTSK1 I $G(SEEN) D:(DATE>ENDDT) UNFLG Q
+ ..I ('NOINAC)&(DATE'>ENDDT) D DIS^SCMCTSK1
+ ..;D MSG(POS,DFN)
+ ;if 6 months after installation check to flag providers
+ I NOINAC D:ALPHA BULL Q
+ S PATDT=$$PDAT^SCMCGU("SD*5.3*297") Q:'PATDT
+ I SIXM,SIXM'>DT 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
+ D BULL
+ Q
+UNFLG ;Remove the flag
  N DR,DIE,DA
  S DR=".15///@;.13///@;.12///@",DIE="^SCPT(404.43,",DA=ENTRY D ^DIE
  Q
-PRFLAG ;flag incorrect provider pos
+PRFLAG ;flag incorrect provider positions
  N POS
- ;prov inact. has run once
+ ;provider inactivation has run once
  I $P($G(^SCTM(404.44,1,1)),U,11)'="" Q
  D PRFLAG^SCMCTSK3
  Q
-PRINAC ;inact. flagged providers
+PRINAC ;inactivate 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
+ ;Provider inactivation run already
+ S II=$P($G(^SCTM(404.44,1,1)),U,11) I II'="",II'=DT 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
  .;I $P(ZERO,U,10)>$G(ENDT) Q   ;not time yet
- .I $O(^SCTM(404.52,"AIDT",+ZERO,0,-9999999))<(-$P(ZERO,U,2)) Q   ;inactivated
- .;Check valid criteria
+ .I $O(^SCTM(404.52,"AIDT",+ZERO,0,-9999999))<(-$P(ZERO,U,2)) Q   ;already inactivated
+ .;Check if criteria still valid
  .S POS=+ZERO
- .S PROV=+$$GETPRTP^SCAPMCU2(POS,SDDT)
+ .S PROV=+$$GETPRTP^SCAPMCU2(POS,DT)
  .S PC=$$GET^XUA4A72(+PROV)
  .S DR=".091///@",DIE="^SCTM(404.52,",DA=I 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
- ..S DIC="^SCTM(404.52,",X=+ZERO,DIC("DR")=".02////"_SDDT_";.03////"_$P(ZERO,U,3)_";.04////0;.05///EMPLOYEE LEAVES POSITION;.11////1"
+ ..;enter the inactivation
+ ..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)="LM" D ^DIC
- ;only run inact. once
- S $P(^SCTM(404.44,1,1),U,11)=SDDT
- Q
-FUTAPP(DFN) ;print future appts
+ ;only run the inactivation once.
+ S $P(^SCTM(404.44,1,1),U,11)=DT
+ Q
+FUTAPP(DFN) ;print future appointments
  N TAB,SCDT0 S TAB=$X
- I $G(SDDT)="" S SDDT=DT
- S SCDT=SDDT+.24
+ S SCDT=DT+.24
  F  S SCDT=$O(^DPT(DFN,"S",SCDT)) Q:'SCDT  D
  . S SCDT0=$G(^DPT(DFN,"S",SCDT,0)) Q:$L($P(SCDT0,U,2))
@@ -93 +87 @@
  . S Y=SCDT X ^DD("DD") W $E(Y_" ",1,17)_" "_$E($P($G(^SC(+CLIEN,0)),U),1,10)
  Q
-GETASC(DATA,ENTRY) ;get assoc. clinics
+GETASC(DATA,ENTRY) ;get associated 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
+SETASC(RESULT,DATA) ;set associated clinics
  D SETASC^SCMCTSK7(.RESULT,DATA) Q
-MSG(SCTP,DFN) ;send inact. message
- ;given valid positions get current practitioners
+MSG(SCTP,DFN) ;send inactivation message
+         ;given list of 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)
+ .S SCX=+$$OKPREC2^SCMCLK(SCTP,DT)
  .;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 SCTEXT(1,0)="PATIENT "_$P($G(^DPT(DFN,0)),U)_" has been inactivated from primary care team position "_$P($G(^SCTM(404.57,SCTP,0)),U)
  S XMSUB="Provider's Inactivated Primary Care Patients" D ^XMD
  Q
-BULL ;EOM Bulletin
+BULL ;end of Month Bulletin
  N DISUPNO,BY,DHIT,HEAD
  S DISUPNO=1,L=0
- S XMSUB="Patients Scheduled for Inactivation from PC Panel"
+ S XMSUB="Patients Scheduled for Inactivation from Primary Care Panel"
  S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")=""
  K ^TMP("SCMC",$J),^TMP("SCMCTXT",$J),^TMP("SCML",$J)
@@ -130 +123 @@
  .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 XMSUB="Patients Scheduled for Inactivation from Primary Care Panel"
  .S XMTEXT="^TMP(""SCMCTXT"",$J,"
+ .;D LINES(1) D ^XMD
  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")=""
@@ -147 +140 @@
  S DISUPNO=1
  K ^TMP("SCMC",$J),^TMP("SCMCTXT")
- S XMSUB="Patients Automated Inactivations from PC Panels"
+ S XMSUB="Patients Automated Inactivations from Primary Care Panels"
  S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")=""
  K ^TMP("SCMC",$J)
@@ -160 +153 @@
  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 XMSUB="Primary Care Providers Scheduled for Inactivation"
  . S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")=""
  . K ^TMP("SCMC",$J)
@@ -189 +182 @@
 INRPT  ; REPORT
  N DIOEND,SCDHD
- D PROMPT^SCMCTSK3("** Date Range Selection **","DATE PATIENTS INACTIVATED FROM PC PANELS")
+ D PROMPT^SCMCTSK3("**** Date Range Selection ****","DATE PATIENTS INACTIVATED FROM PRIMARY CARE PANELS")
  Q:'$D(^TMP("SC",$J,"XR"))
  D UNASSIGN^SCMCTSK3
@@ -201 +194 @@
  D EN1^DIP
  Q
-IN30 ;inact. last month
- N DIPA,SDD D SORT^SCMCTSK1(.DIPA,.SDD) Q:'SDD  ;SD/499
+IN30 ;inactivated last month
+ D SORT^SCMCTSK1 Q:'X
  S Q=""""
  S DIC="^SCPT(404.43,",L=0,BY="[SCMC INACTIVATION SORT]"