source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCTSK.m@ 636

SCMCTSK ;ALB/JDS - PCMM ; 03 Jun 2004  3:30 PM
 ;;5.3;Scheduling;**264,278,272,297**;AUG 13, 1993
 Q
RPT1 ;REPORT
 N DHD,DIOBEG
 S DIOBEG="D INACTIVE^SCMCTSK",DIC="^SCPT(404.43,",(FLDS,BY)="[SCMC PENDING UNASSIGN]"
 S DHD="Patients Flagged for Inactivation from Primary Care Panels"
 D EN1^DIP
 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,TEAMNM
 D DT^DICRW S X="T-12M" D ^%DT S STDT=Y
 S X="T-24M" D ^%DT S TYDT=+Y
RPT ;eneter for report with STDT and TYDT defined
 S A="^SCPT(404.43,""ADFN""",L=""""""
 S Q=A_")"
 F  S Q=$Q(@Q) Q:Q'[A  D
 .S ENTRY=+$P(Q,",",6)
 .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(Q,",",5)>STDT Q  ;Later
 .S ZERO=$G(^SCPT(404.43,+ENTRY,0))
 .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),DFN=+$G(^SCPT(404.42,+DFN,0))
 .S SEEN=0
 .S TEAM=$P(Q,",",4),TEAMNM=$P($G(^SCTM(404.51,+TEAM,0)),U)
 .;who was provider for this position
 .Q:$$SEEN1(DFN,+$P(ZERO,U,2))
 .;I $G(DIS) D DIS Q
 .S ^TMP("SCMCTSK",$J,ENTRY)=""
 Q
SEEN1(DFN,POS) ;
 S SEEN=0
 K PROV F I=0:0 S I=$O(^SCTM(404.52,"B",+$G(POS),I)) Q:'I  D
 .N A S A=$G(^SCTM(404.52,+I,0)) I $P(A,U,4) S PROV(+$P(A,U,3))="" Q
 .I $P(A,U,2)<TYDT K PROV(+$P(A,U,3))
 F PROV=0:0 S PROV=$O(PROV(PROV)) Q:'PROV  D SEEN
 Q SEEN
SEEN ;See if seen in last 24 months go through visits
 F I=0:0 S I=$O(^AUPNVSIT("AA",DFN,I)) Q:'I  Q:(9999999-I<TYDT)  D  Q:SEEN
 .F J=0:0 S J=$O(^AUPNVSIT("AA",DFN,I,J)) Q:'J  D
 ..F P=0:0 S P=$O(^AUPNVPRV("AD",J,P))  Q:'P  S:PROV=(+$G(^AUPNVPRV(P,0))) SEEN=1 Q:SEEN  ;GET THE PROVIDERJ
 Q
DIS ;discharge
 N ZERO S ZERO=$G(^SCPT(404.43,+ENTRY,0))
 I $P(ZERO,U,4) Q  ;Already discharged
 ;I $P(ZERO,U,16) Q
 S DA=ENTRY,DIE="^SCPT(404.43,",DR=".04////"_DT_";.12////IU"
 D ^DIE
 ;
 Q
DEATH ;Called from date of death event
 ;
 I $G(DGFILE)'=2 Q
 I $G(DGFIELD)'=.351 Q
 S DFN=+$G(DGDA)
 N DEATH,I,DR,SCJ
 D DEM^VADPT S DEATH=$G(VADM(6))
 ;loop through assignments
 F SCJ=0:0 S SCJ=$O(^SCPT(404.42,"B",DFN,SCJ)) Q:'SCJ  D
 .S ZERO=$G(^SCPT(404.42,SCJ,0)) Q:'$L(ZERO)
 .I DEATH,'$P(ZERO,U,9) D
 ..S DA=SCJ,DIE="^SCPT(404.42,",DR=".09////"_DT_";.15////DU" D ^DIE
 .I ('DEATH)&($P(ZERO,U,15)="DU")&($P(ZERO,U,9)) D
 ..S DA=SCJ,DIE="^SCPT(404.42,",DR=".09///@;.15////DD" D ^DIE
 .F SCI=0:0 S SCI=$O(^SCPT(404.43,"B",SCJ,SCI)) Q:'SCI  D
 ..S ZERO=$G(^SCPT(404.43,SCI,0)),SCTP=+$P(ZERO,U,2) Q:'$L(ZERO)
 ..I DEATH,$P(ZERO,U,4) Q
 ..I 'DEATH I (('$P(ZERO,U,4))!($P(ZERO,U,12)'="DU")) Q
 ..I DEATH D  Q
 ...S DA=SCI,DIE="^SCPT(404.43,",DR=".04////"_DT_";.12////DU" D ^DIE
 ..I '+$$ACTHIST^SCAPMCU2(404.52,SCTP,,.SCERR) Q
 ..S DA=SCI,DIE="^SCPT(404.43,",DR=".04///@;.12////DD" D ^DIE
 Q:'DEATH
 ;DISPOSITION WAIT LIST
 F I=0:0 S I=$O(^SDWL(409.3,"B",+$G(DFN),I)) Q:'I  S A=$G(^SDWL(409.3,I,0)) D
 .I $G(^SDWL(409.3,I,"DIS")) Q
 .N FDA S FDA(409.3,I_",",21)="D"
 .S FDA(409.3,I_",",19)=DT,FDA(409.3,I_",",23)="C"
 .S FDA(409.3,I_",",20)=DUZ
 .D UPDATE^DIE("","FDA")
 Q
POST ;
 D MES^XPDUTL("Deleting Traditional ASTAT CROSS REFERENCE from FILE 404.43")
 D DELIX^DDMOD(404.43,.12,1)
 N ENTRY,DGDA,DGFIELD,DGFILE
 K DGLEFDA,YEAR
 I '$D(^SCTM(404.46,"B","1.2.3.0")) D
 .K DO S DIC(0)="LM",DIC("DR")=".02////1;.03////"_DT,DIC="^SCTM(404.46,",X="1.2.3.0" D FILE^DICN
 I '$D(^SCTM(404.45,"B","SD*5.3*264")) D
 .S ENTRY=$O(^SCTM(404.46,"B","1.2.3.0",0))
 .S DIC("DR")=".02////"_(+ENTRY)_";.03////"_DT_";.04////1",DIC(0)="LM"
 .K DO S X="SD*5.3*264",DIC="^SCTM(404.45," D FILE^DICN
 D MES^XPDUTL("Removing Patients with Date of Death from Team/Position Assignments")
 S YEAR=0
 F DATE=0:0 S DATE=$O(^DPT("AEXP1",DATE)) Q:'DATE  F DGDA=0:0 S DGDA=$O(^DPT("AEXP1",DATE,DGDA)) Q:'DGDA  D
 .S DFN=+DGDA D DEM^VADPT I $G(VADM(6)) S DGFILE=2,DGFIELD=.351 D DEATH
 .I $E(YEAR,1,3)'=$E(DATE,1,3) S YEAR=$E(DATE,1,3) I "05"[$E(YEAR,3) D MES^XPDUTL("Starting with Dates of Death in "_(1700+YEAR))
 Q
POST278 ;postinit for 278
 D MES^XPDUTL("Setting up GUI to VistA mapping")
 I '$D(^SCTM(404.46,"B","1.2.3.1")) D
 .K DO S DIC(0)="LM",DIC("DR")=".02////1;.03////"_DT,DIC="^SCTM(404.46,",X="1.2.3.1" D FILE^DICN
 I '$D(^SCTM(404.45,"B","SD*5.3*278")) D
 .S ENTRY=$O(^SCTM(404.46,"B","1.2.3.1",0))
 .S DIC("DR")=".02////"_(+ENTRY)_";.03////"_DT_";.04////1",DIC(0)="LM"
 .K DO S X="SD*5.3*278",DIC="^SCTM(404.45," D FILE^DICN
 Q
FTEE(DATA,SCTEAM) ;return list of posistions for the team
 ;IEN^POSITION^PROVIDER^FTEE
 N CNT,I,J,K,A S CNT=1 S SCTEAM=+$G(SCTEAM),DATA(1)="<DATA>"
 S A=""
 F  S A=$O(^SCTM(404.57,"ATMPOS",SCTEAM,A)) Q:A=""  D
 .F I=0:0 S I=$O(^SCTM(404.57,"ATMPOS",SCTEAM,A,I)) Q:'I  D
 ..I '$$DATES^SCAPMCU1(404.59,I) Q   ;Not an active position
 ..I '$P($G(^SCTM(404.57,I,0)),U,4) Q  ;Not PC
 ..S J=-(DT+1) S J=$O(^SCTM(404.52,"AIDT",I,1,J)) Q:J=""
 ..I $O(^SCTM(404.52,"AIDT",I,0,-(DT+1)))<J Q
 ..S K=0 S K=$O(^SCTM(404.52,"AIDT",I,1,J,K)) Q:'K
 ..S ZERO=$G(^SCTM(404.52,+K,0)) Q:'$P(ZERO,U,4)
 ..S CNT=CNT+1
 ..S DATA(CNT)=K_U_A_U_$$GET1^DIQ(200,(+$P(ZERO,U,3))_",",.01)_U_$P(ZERO,U,9)_U_K_U_$P(ZERO,U,3)
 Q
FILE(RES,DATA) ;File data on FTEE
 N I
 F I=1:1 Q:'$D(DATA(I))   D
 .S ZERO=$G(^SCTM(404.52,+DATA(I),0))
 .I $P(ZERO,U,9)=$P(DATA(I),U,7) Q
 .S FLDA(404.52,(+DATA(I))_",",.09)=+$TR($P(DATA(I),U,7)," ")
 I $O(FLDA(0)) D FILE^DIE("E","FLDA","ERR")
 Q
FTEXR ;Ftee cross reference
 N DIC,DD,DO,DINUM,DS,ENTRY,VALUE
 I '$D(^SCTM(404.52,+DA,1,0)) S ^(0)="^404.521DA"
 S ENTRY=+$G(DA),VALUE=X
 N DIC,FLDA,Y,DA,X S DIC="^SCTM(404.52,"_ENTRY_",1,",DA(1)=ENTRY
 S DIC(0)="LM",X="NOW",DIC("DR")=".02////"_VALUE_";.03////"_$G(DUZ)
 D ^DICN
 Q
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
 I '$P($G(^SCTM(404.57,+A,0)),U,4) Q  ;Not PC
 I '$$DATES^SCAPMCU1(404.59,+A) Q   ;Not an active position
 I $O(^SCTM(404.52,"AIDT",+A,0,-(DT+1)))<J S X=0 Q
 I '$D(^SCTM(404.52,"AIDT",+A,1,J,D0)) S X=0 Q
 S X=1 Q