Changeset 636 for FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCTSK1.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/SCMCTSK1.m (modified) (14 diffs)

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

@@ -1 @@
-SCMCTSK1 ;ALB/JDS - PCMM Inactivations; 18 Apr 2003  9:36 AM ; 10/24/07 12:24pm  ; Compiled January 25, 2008 12:11:43  ; Compiled March 26, 2008 22:27:26
- ;;5.3;Scheduling;**297,498,527,499**;AUG 13, 1993;Build 21
- Q
-INACTIVE ;
- ;Flag patients
- N I,CNT,SC297,TPZ,TYDT,TEAMN,STDT,Q,SDDT,STDD S CNT=0
- D DT^DICRW
- N SD1 S SDDT="" F SD1=DT,DT-1 I $D(^XTMP("SCMCTSK2-"_SD1,$J,"START")) S SDDT=SD1 Q
- I SDDT'>0 D DT^DICRW S SDDT=DT
- S %DT="",X="T-11M" D ^%DT S STDD=+Y
+SCMCTSK1 ;ALB/JDS - PCMM Inactivations; 18 Apr 2003  9:36 AM ; 10/24/07 12:24pm
+ ;;5.3;Scheduling;**297,498,527**;AUG 13, 1993;Build 6
+ Q
+INACTIVE ;run every night to determine if patient can be inactivated from
+ ;team
+ ;Inactivation happens for patients without activity for 24 months
+ N I,CNT,SC297,TPZ,TYDT,TEAMN,STDT,Q S CNT=0
+ D DT^DICRW S %DT="",X="T-11M" D ^%DT S STDT=Y
+ S SC297=$$PDAT^SCMCGU("SD*5.3*297"),X1=DT,X2=SC297 D D^%DTC S SC297=X
+ S X="T-"_$S(SC297>330:"11M",1:"23M") D ^%DT S TYDT=+Y
  S A="^SCPT(404.43,""ADFN""",L=""""""
  S Q=A_")"
@@ -14 +14 @@
  .S ENTRY=+$P(Q,",",6)
  .S ZERO=$G(^SCPT(404.43,+ENTRY,0))
- .I $P(ZERO,U,15) Q
  .S POS=+$P(ZERO,U,2)
- .I $P(ZERO,U,4) Q  ;UNASS
- .I '$P(ZERO,U,5) Q  ;Not PC
- .I $P(ZERO,U,3)>STDD Q  ;<11 months
- .I $P(ZERO,U,17) Q  ;React
- .;get preceptor
+ .S TEAM=$P(Q,",",4)
+ .;I $P($G(^SCTM(404.51,+TEAM,0)),U,16) Q  ;no automatic for this team
+ .;I $G(^DPT(DFN,.35)) D DIS Q  ;Patient is deceased
+ .I $P(ZERO,U,3)>STDT Q  ;Later
+ .I $P(ZERO,U,17) Q  ;Already reactivated
+ .;get preceptor position
  .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) Q
+ .I $P(ZERO,U,4) Q  ;Already unassigned
+ .I '$P(ZERO,U,5) Q  ;Not primary care
+ .;I $P(ZERO,U,16) Q  ;No Automatic unassign
+ .;Check if any activity
  .S DFN=$P(Q,",",3)
  .I $G(XPDIDTOT),('(DFN#5)) D UPDATE^XPDID(DFN)
  .S TEAM=$P(Q,",",4),TEAMNM=$P($G(^SCTM(404.51,+TEAM,0)),U)
- .N STDT S %DT="",X="T-12M" D ^%DT S STDT=+Y
- .;N-new or E-est
- .N NEW
- .I $P(ZERO,U,3)<STDT S NEW=0
- .E  S NEW=1
- .N TYDT
- .I NEW N STDT S %DT="",X="T-11M" D ^%DT S STDT=+Y D
- ..S X1=STDT,X2=-7 D C^%DTC S TYDT=X
- .I 'NEW N STDT S %DT="",X="T-23M" D ^%DT S STDT=+Y Q:$P(ZERO,U,3)'<STDT  D
- ..S X1=STDT,X2=-7 D C^%DTC S TYDT=X
- .N PROV,SEEN,PRECP D SEEN(DFN,POS,TYDT,SDDT,.PROV,.PRECP,.SEEN) Q:SEEN
- .;flag
- .S DIE="^SCPT(404.43,",DR=".15////"_SDDT,DA=ENTRY D ^DIE
- .S TPZ=$G(^SCTM(404.57,+POS,2))
- .I "TP"[$P(TPZ,U,9) I $G(PROV) S CNT=CNT+1,^TMP("SCF",$J,PROV,CNT,ENTRY)=""
- .I $P(TPZ,U,10),$G(PRECP) S CNT=CNT+1,^TMP("SCF",$J,PRECP,CNT,ENTRY)=""
- Q
-SEEN(DFN,POS,TYDT,SDDT,PROV,PROVP,SEEN) ;
- S SEEN=0,PROVP=""
- N SCPRO,I,PRO,X,SCPRDTS,SCPR,PREC
- S PROV=+$$GETPRTP^SCAPMCU2(POS,SDDT)
- S SCPRDTS("BEGIN")=TYDT,SCPRDTS("END")=SDDT,SCPRDTS("INCL")=0
+ .D SEEN Q:SEEN
+ .I '$P(ZERO,U,15) D
+ ..S DIE="^SCPT(404.43,",DR=".15////"_DT,DA=ENTRY D ^DIE
+ ..S TPZ=$G(^SCTM(404.57,+POS,2))
+ ..I "TP"[$P(TPZ,U,10) I $G(PROV) S CNT=CNT+1,^TMP("SCF",$J,PROV,CNT,ENTRY)=""
+ ..I $P(TPZ,U,9),$G(PRECP) S CNT=CNT+1,^TMP("SCF",$J,PRECP,CNT,ENTRY)=""
+ Q
+SEEN ;was patient seen
+ S SEEN=0
+ N SCPRO,I,PRECP,PRO
+ N X,SCPRDTS,SCPR
+ ;get list of providers for this position
+ S PROV=+$$GETPRTP^SCAPMCU2(POS,DT) S SCPRO(+PROV)=""
+ S SCPRDTS("BEGIN")=TYDT
+ S SCPRDTS("END")=DT
  S X=$$PRTP^SCAPMC(POS,"SCPRDTS","SCPR")
- S I=0 F  S I=$O(SCPR(I)) Q:'I  S SCPRO(+SCPR(I))="",SCPRO(+SCPR(I),I)=$P(SCPR(I),U,9,10) D
- .S PREC=$P(SCPR(I),U,12)
- .I PREC,PREC'=POS S PROVP=+$$GETPRTP^SCAPMCU2(PREC,SDDT) S SCPRO(+PROVP)="" S SCPRO(+PROVP,I)=$P(SCPR(I),U,9,10)
+ F I=0:0 S I=$O(SCPR(I)) Q:'I  S SCPRO(+SCPR(I))=""
+ S PRECP=0 I $G(PREC),$G(PREC)'=POS S PRECP=+$$GETPRTP^SCAPMCU2(PREC,DT),SCPRO(+PRECP)=""
  F I=TYDT:0 S I=$O(^SCE("ADFN",DFN,I)) Q:'I  D  Q:SEEN
- .S J=0 F  S J=$O(^SCE("ADFN",DFN,I,J)) Q:'J  D  Q:SEEN
+ .F J=0:0 S J=$O(^SCE("ADFN",DFN,I,J)) Q:'J  D  Q:SEEN
  ..N VISIT S VISIT=+$P($G(^SCE(J,0)),U,5) I $G(^SCE(J,0))<$G(TYDT) Q
- ..S PRO=0 F  S PRO=$O(SCPRO(PRO)) Q:'PRO  D  Q:SEEN
- ...I $D(^SDD(409.44,"AO",J,$G(PRO))) D CHK I SEEN=1 Q
- ...N V F V=0:0 S V=$O(^AUPNVPRV("AD",VISIT,V)) Q:'V  I PRO=(+$G(^AUPNVPRV(V,0))) D CHK I SEEN=1 Q
- Q
-CHK ;
- N SDX S SDX="" F  S SDX=$O(SCPRO(PRO,SDX)) Q:SDX=""  D  Q:SEEN
- .I $P(SCPRO(PRO,SDX),U,2)="" D  Q
- ..I I'<$P(SCPRO(PRO,SDX),U) S SEEN=1
- .I I'<TYDT&(I'>$P(SCPRO(PRO,SDX),U,2)) S SEEN=1
- Q
-DIS ;disch
+ ..F PRO=0:0 S PRO=$O(SCPRO(PRO)) Q:'PRO  D  Q:SEEN
+ ...I $D(^SDD(409.44,"AO",J,$G(PRO))) S SEEN=1 Q  ;GET THE PROVIDERJ
+ ...N V F V=0:0 S V=$O(^AUPNVPRV("AD",VISIT,V)) Q:'V  I PRO=(+$G(^AUPNVPRV(V,0))) S SEEN=1 Q
+ Q
+DIS ;discharge
  N ZERO S ZERO=$G(^SCPT(404.43,+ENTRY,0))
- I $P(ZERO,U,4) Q
+ I $P(ZERO,U,4) Q  ;Already discharged
  D DIS2^SCMCTSK7
  Q
-CHKENR(DATA,INFO) ;check if patient enrolled in teamposition clinic
- S DATA(0)=-1
- Q
-EXTEND(DATA,SCTEAM) ;to inact. in next 60 days
+EXTEND(DATA,SCTEAM) ;return list of patients to inactivate in next 60 days
  ;IEN^POSITION^PATIENT^EXTENDED^REASON
  K DATA,SCDATA,SDDATA
  N CNT,I,J,K,A,POSA S CNT=1 S SCTEAM=$G(SCTEAM),DATA(1)="<DATA>"
- D DT^DICRW
- N SD1 S SDDT="" F SD1=DT,DT-1 I $D(^XTMP("SCMCTSK2-"_SD1,$J,"START")) S SDDT=SD1 Q
- I SDDT'>0 D DT^DICRW S SDDT=DT
- S X="T-9M" D ^%DT S STDT=Y
+ D DT^DICRW S X="T-9M" D ^%DT S STDT=Y
  S X="T-21M" D ^%DT S TYDT=+Y  ;MAKE THIS 21
  S POSA=""
@@ -91 +77 @@
  .S CNT=CNT+1
  Q
-POS I '$$DATES^SCAPMCU1(404.59,POS) Q  ;Position inact
+POS I '$$DATES^SCAPMCU1(404.59,POS) Q   ;Not an active position
  I '$P($G(^SCTM(404.57,POS,0)),U,4) Q  ;Not PC
- ;patients for position
+ ;get patients for this position
  K ^TMP("SC TMP LIST",$J)
  S X=$$PTTP^SCAPMC(POS,"",.SCLIST,.SCERR)
@@ -101 +87 @@
  .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,15) Q
  .S DFN=+SCDATA
- .D SEEN(DFN,POS,TYDT,SDDT,.PROV,.PRECP,.SEEN) Q:SEEN
+ .D SEEN Q:SEEN
  .S SDDATA($P($G(^SCTM(404.57,POS,0)),U),$P(SCDATA,U,2),+SCDATA)=SCDATA,CNT=CNT+1
  K @SCLIST
@@ -107 +93 @@
 FILE(RES,DATA) ;File data on FTEE
  N I
- F I=1:1 Q:'$D(DATA(I))  D
+ F I=1:1 Q:'$D(DATA(I))   D
  .S $P(DATA(I),U,7)=$TR($P(DATA(I),U,7),"[]")
  .S ZERO=$G(^SCPT(404.43,+DATA(I),0))
@@ -116 +102 @@
  I $O(FLDA(0)) D FILE^DIE("E","FLDA","ERR")
  Q
-SCREEN ;Active assign. screen
+SCREEN ;Screen for active assignments
  N A S A=$G(^SCTM(404.52,D0,0))
  N J S J=-(DT+1),J=$O(^SCTM(404.52,"AIDT",+A,1,J)) I J="" S X=0 Q
@@ -124 +110 @@
  I '$D(^SCTM(404.52,"AIDT",+A,1,J,D0)) S X=0 Q
  S X=1 Q
-SUM(PR,POSI) ;get pos for prov
+SUM(PR,POSI) ; get positions for this provider
  N I,INS,ZERO,SCA,TEAM,FTEE,Z
  S I="",FTEE=0
@@ -139 +125 @@
  .S FTEE=FTEE+$P(ZERO,U,9)
  Q FTEE
-FTEECHK(DATA,PAIEN) ;check Ftee>1
+FTEECHK(DATA,PAIEN) ;check Ftee greater than 1
  N A S A=$G(^SCTM(404.52,+PAIEN,0)),FTEE=$$SUM(+$P(PAIEN,U,3),+A)
  S DATA=0
  S DATA=FTEE+$P(PAIEN,U,2)
  Q
-SORT(DIPA,SDD) ;sort tmpl
- N DIC
+SORT ;sort template
+ N DIC,DIPA
  S DIC=4,DIC(0)="ZME"
  S DIC("S")="I $D(^SCTM(404.51,""AINST"",+Y))"
  S DIR("A")="Start with Institution",DIR("B")="FIRST",DIR(0)="F" D ^DIR
- I X="FIRST" S DIPA("SI")="",DIPA("EI")="zzz",SDD=1 Q
- D ^DIC I Y<0 S DIPA("SI")=X S SDD=X Q:SDD[U  D
+ I X="FIRST" S DIPA("SI")="",DIPA("EI")="zzz",X=1 Q
+ D ^DIC I Y<0 S DIPA("SI")=X Q:X[U  D
  .S DIR("A")="Go to Institutiton",DIR("B")="LAST" S DIR(0)="F" D ^DIR
  .I X="LAST" S DIPA("EI")="zzz"
@@ -156 +142 @@
  D ^DIC
  I Y>0 S DIPA("EI")=$P(Y(0),U)
- I Y<0 S DIPA("EI")=X S SDD=X Q:SDD[U
- S SDD=1 Q
+ I Y<0 S DIPA("EI")=X Q:X[U
+ S X=1 Q
 FTEERPT ;FTEE REPORT
  D FTERPT^SCMCTSK6 Q
@@ -169 +155 @@
  S DATA=0
  I ('INFO)!('$P(INFO,U,2)) Q
- ;Is provider role acceptable?
+ ;Check if provider can be in this role.
  S J=-(DT+1) S J=$O(^SCTM(404.52,"AIDT",+INFO,1,J)) Q:J=""
  I $O(^SCTM(404.52,"AIDT",+INFO,0,-(DT+1)))<J Q
@@ -191 +177 @@
  S SCDFN=+Y W !,SCDFN
 SCDFN S SC1="^SCPT(404.43,""APCPOS"",SCDFN,1)"
- ;quit if no PC assign
+ ;
+ ;quit if no PC assignments
  Q:'$D(@SC1)
  S SCADT=0
  F  S SCADT=$O(@SC1@(SCADT)) Q:SCADT=""  D
- .S SCTP=0
- .F  S SCTP=$O(@SC1@(SCADT,SCTP)) Q:'SCTP  D
- ..; quit if team position does not exist
- ..Q:'$D(^SCTM(404.57,SCTP,0))
- ..S SCPAI=0
- ..F  S SCPAI=$O(@SC1@(SCADT,SCTP,SCPAI)) Q:'SCPAI  D
- ...S SCDDT=$P($G(^SCPT(404.43,SCPAI,0)),U,4)
- ...;quit if not active within date range
- ...Q:$$DTCHK^SCAPU1(SC177,DT,0,SCADT,SCDDT)<1
- ...N SCVAR S SCVAR=SCPAI_";SCPT(404.43,"
- ...;add to HL7 event file
- ...Q:$D(^SCPT(404.48,"AACXMIT",SCVAR))
- ...Q:$$CHECK^SCMCHLB1(SCVAR)'=1
- ...D ADD^SCMCHLE("NOW",SCVAR,SCDFN,SCTP)
+ . S SCTP=0
+ . F  S SCTP=$O(@SC1@(SCADT,SCTP)) Q:'SCTP  D
+ . . ;
+ . . ; quit if team position does not exist
+ . . Q:'$D(^SCTM(404.57,SCTP,0))
+ . . S SCPAI=0
+ . . F  S SCPAI=$O(@SC1@(SCADT,SCTP,SCPAI)) Q:'SCPAI  D
+ . . . S SCDDT=$P($G(^SCPT(404.43,SCPAI,0)),U,4)
+ . . . ;
+ . . . ; quit if not active within date range
+ . . . Q:$$DTCHK^SCAPU1(SC177,DT,0,SCADT,SCDDT)<1
+ . . . N SCVAR S SCVAR=SCPAI_";SCPT(404.43,"
+ . . . ;
+ . . . ; add to HL7 event file
+ . . . Q:$D(^SCPT(404.48,"AACXMIT",SCVAR))
+ . . . Q:$$CHECK^SCMCHLB1(SCVAR)'=1
+ . . . D ADD^SCMCHLE("NOW",SCVAR,SCDFN,SCTP)
  Q
 PRSEED ;seed practitioner
@@ -214 +204 @@
  S SC177=$$PDAT^SCMCGU("SD*5.3*177")
  I +SC177=0 D  Q
- . S SC2=" No SD*5.3*177 Installation Date."
+ . S SC2="  Unable to obtain SD*5.3*177 Installation Date."
  . D MSG^SCMCCV6(SC1,SC2)
+ . Q
  S DIC=200,DIC(0)="MEQA",DIC("A")="Select Provider: " D ^DIC Q:Y'>0
  S SCPROV=+Y
@@ -230 +221 @@
  . D ADD^SCMCHLE("NOW",SCVAR,,AH,1)
  Q
-INCON ;inconsistent PC assignments
+INCON ;get list of incositent provider assignments
  N POS
  D INCON^SCMCTSK3
@@ -240 +231 @@
  D EN1^DIP
  Q
+CHKENR(DATA,INFO) ;check if patient enrolled in teamposition clinic
+ S DATA(0)=-1
+ N I
+ N POS,DFN S DFN=+$G(INFO) Q:'DFN  S POS=+$P($G(INFO),U,2) Q:'POS
+ F I=0:0 S I=$O(^SCTM(404.57,POS,5,I)) Q:'I  D CECHK^SCRPPAT2(I,.CNAME,DFN) I $L(CNAME) S:DATA(0)=-1 DATA(0)="" S DATA(0)=DATA(0)_CNAME_"."
+ I DATA(0)'=-1 S DATA(0)=$E(DATA(0),1,$L(DATA(0))-2)
+ Q
 INACTDT(PA) ;Scheduled inactivation date.
  D INACT^SCMCTSK3 Q